| 1 |
- #' Count patients with toxicity grades that have worsened from baseline by highest grade post-baseline+ #' Formatting functions |
||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' See below for the list of formatting functions created in `tern` to work with `rtables`. |
||
| 5 |
- #' The analyze function [count_abnormal_lab_worsen_by_baseline()] creates a layout element to count patients with+ #' Other available formats can be listed via [`formatters::list_valid_format_labels()`]. Additional |
||
| 6 |
- #' analysis toxicity grades which have worsened from baseline, categorized by highest (worst) grade post-baseline.+ #' custom formats can be created via the [`formatters::sprintf_format()`] function. |
||
| 8 |
- #' This function analyzes primary analysis variable `var` which indicates analysis toxicity grades. Additional+ #' @family formatting functions |
||
| 9 |
- #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to `USUBJID`),+ #' @name formatting_functions |
||
| 10 |
- #' a variable to indicate unique subject identifiers, `baseline_var` (defaults to `BTOXGR`), a variable to indicate+ NULL |
||
| 11 |
- #' baseline toxicity grades, and `direction_var` (defaults to `GRADDIR`), a variable to indicate toxicity grade+ |
||
| 12 |
- #' directions of interest to include (e.g. `"H"` (high), `"L"` (low), or `"B"` (both)).+ #' Format fraction and percentage |
||
| 14 |
- #' For the direction(s) specified in `direction_var`, patient counts by worst grade for patients who have+ #' @description `r lifecycle::badge("stable")`
|
||
| 15 |
- #' worsened from baseline are calculated as follows:+ #' |
||
| 16 |
- #' * `1` to `4`: The number of patients who have worsened from their baseline grades with worst+ #' Formats a fraction together with ratio in percent. |
||
| 17 |
- #' grades 1-4, respectively.+ #' |
||
| 18 |
- #' * `Any`: The total number of patients who have worsened from their baseline grades.+ #' @param x (named `integer`)\cr vector with elements `num` and `denom`. |
||
| 19 |
- #'+ #' @param ... not used. Required for `rtables` interface. |
||
| 20 |
- #' Fractions are calculated by dividing the above counts by the number of patients who's analysis toxicity grades+ #' |
||
| 21 |
- #' have worsened from baseline toxicity grades during treatment.+ #' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`. |
||
| 23 |
- #' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create a row+ #' @examples |
||
| 24 |
- #' split on variable `direction_var`.+ #' format_fraction(x = c(num = 2L, denom = 3L)) |
||
| 25 |
- #'+ #' format_fraction(x = c(num = 0L, denom = 3L)) |
||
| 26 |
- #' @inheritParams argument_convention+ #' |
||
| 27 |
- #' @param variables (named `list` of `string`)\cr list of additional analysis variables including:+ #' @family formatting functions |
||
| 28 |
- #' * `id` (`string`)\cr subject variable name.+ #' @export |
||
| 29 |
- #' * `baseline_var` (`string`)\cr name of the data column containing baseline toxicity variable.+ format_fraction <- function(x, ...) {
|
||
| 30 | -+ | 4x |
- #' * `direction_var` (`string`)\cr see `direction_var` for more details.+ attr(x, "label") <- NULL |
| 31 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal_by_worst_grade_worsen")`
+
|
||
| 32 | -+ | 4x |
- #' to see all available statistics.+ checkmate::assert_vector(x) |
| 33 | -+ | 4x |
- #'+ checkmate::assert_count(x["num"]) |
| 34 | -+ | 2x |
- #' @seealso Relevant helper functions [h_adlb_worsen()] and [h_worsen_counter()] which are used within+ checkmate::assert_count(x["denom"]) |
| 35 |
- #' [s_count_abnormal_lab_worsen_by_baseline()] to process input data.+ |
||
| 36 | -+ | 2x |
- #'+ result <- if (x["num"] == 0) {
|
| 37 | -+ | 1x |
- #' @name abnormal_by_worst_grade_worsen+ paste0(x["num"], "/", x["denom"]) |
| 38 |
- #' @order 1+ } else {
|
||
| 39 | -+ | 1x |
- NULL+ paste0( |
| 40 | -+ | 1x |
-
+ x["num"], "/", x["denom"], |
| 41 | -+ | 1x |
- #' Helper function to prepare ADLB with worst labs+ " (", round(x["num"] / x["denom"] * 100, 1), "%)"
|
| 42 |
- #'+ ) |
||
| 43 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 44 |
- #'+ |
||
| 45 | -+ | 2x |
- #' Helper function to prepare a `df` for generate the patient count shift table.+ return(result) |
| 46 |
- #'+ } |
||
| 47 |
- #' @param adlb (`data.frame`)\cr ADLB data frame.+ |
||
| 48 |
- #' @param worst_flag_low (named `vector`)\cr worst low post-baseline lab grade flag variable. See how this is+ #' Format fraction and percentage with fixed single decimal place |
||
| 49 |
- #' implemented in the following examples.+ #' |
||
| 50 |
- #' @param worst_flag_high (named `vector`)\cr worst high post-baseline lab grade flag variable. See how this is+ #' @description `r lifecycle::badge("stable")`
|
||
| 51 |
- #' implemented in the following examples.+ #' |
||
| 52 |
- #' @param direction_var (`string`)\cr name of the direction variable specifying the direction of the shift table of+ #' Formats a fraction together with ratio in percent with fixed single decimal place. |
||
| 53 |
- #' interest. Only lab records flagged by `L`, `H` or `B` are included in the shift table.+ #' Includes trailing zero in case of whole number percentages to always keep one decimal place. |
||
| 54 |
- #' * `L`: low direction only+ #' |
||
| 55 |
- #' * `H`: high direction only+ #' @inheritParams format_fraction |
||
| 56 |
- #' * `B`: both low and high directions+ #' |
||
| 57 |
- #'+ #' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`. |
||
| 58 |
- #' @return `h_adlb_worsen()` returns the `adlb` `data.frame` containing only the+ #' |
||
| 59 |
- #' worst labs specified according to `worst_flag_low` or `worst_flag_high` for the+ #' @examples |
||
| 60 |
- #' direction specified according to `direction_var`. For instance, for a lab that is+ #' format_fraction_fixed_dp(x = c(num = 1L, denom = 2L)) |
||
| 61 |
- #' needed for the low direction only, only records flagged by `worst_flag_low` are+ #' format_fraction_fixed_dp(x = c(num = 1L, denom = 4L)) |
||
| 62 |
- #' selected. For a lab that is needed for both low and high directions, the worst+ #' format_fraction_fixed_dp(x = c(num = 0L, denom = 3L)) |
||
| 63 |
- #' low records are selected for the low direction, and the worst high record are selected+ #' |
||
| 64 |
- #' for the high direction.+ #' @family formatting functions |
||
| 65 |
- #'+ #' @export |
||
| 66 |
- #' @seealso [abnormal_by_worst_grade_worsen]+ format_fraction_fixed_dp <- function(x, ...) {
|
||
| 67 | -+ | 3x |
- #'+ attr(x, "label") <- NULL |
| 68 | -+ | 3x |
- #' @examples+ checkmate::assert_vector(x) |
| 69 | -+ | 3x |
- #' library(dplyr)+ checkmate::assert_count(x["num"]) |
| 70 | -+ | 3x |
- #'+ checkmate::assert_count(x["denom"]) |
| 71 |
- #' # The direction variable, GRADDR, is based on metadata+ |
||
| 72 | -+ | 3x |
- #' adlb <- tern_ex_adlb %>%+ result <- if (x["num"] == 0) {
|
| 73 | -+ | 1x |
- #' mutate(+ paste0(x["num"], "/", x["denom"]) |
| 74 |
- #' GRADDR = case_when(+ } else {
|
||
| 75 | -+ | 2x |
- #' PARAMCD == "ALT" ~ "B",+ paste0( |
| 76 | -+ | 2x |
- #' PARAMCD == "CRP" ~ "L",+ x["num"], "/", x["denom"], |
| 77 | -+ | 2x |
- #' PARAMCD == "IGA" ~ "H"+ " (", sprintf("%.1f", round(x["num"] / x["denom"] * 100, 1)), "%)"
|
| 78 |
- #' )+ ) |
||
| 79 |
- #' ) %>%+ } |
||
| 80 | -+ | 3x |
- #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")+ return(result) |
| 81 |
- #'+ } |
||
| 82 |
- #' df <- h_adlb_worsen(+ |
||
| 83 |
- #' adlb,+ #' Format count and fraction |
||
| 84 |
- #' worst_flag_low = c("WGRLOFL" = "Y"),
+ #' |
||
| 85 |
- #' worst_flag_high = c("WGRHIFL" = "Y"),
+ #' @description `r lifecycle::badge("stable")`
|
||
| 86 |
- #' direction_var = "GRADDR"+ #' |
||
| 87 |
- #' )+ #' Formats a count together with fraction with special consideration when count is `0`. |
||
| 89 |
- #' @export+ #' @param x (`numeric(2)`)\cr vector of length 2 with count and fraction, respectively. |
||
| 90 |
- h_adlb_worsen <- function(adlb,+ #' @param ... not used. Required for `rtables` interface. |
||
| 91 |
- worst_flag_low = NULL,+ #' |
||
| 92 |
- worst_flag_high = NULL,+ #' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`. |
||
| 93 |
- direction_var) {
+ #' |
||
| 94 | -5x | +
- checkmate::assert_string(direction_var)+ #' @examples |
|
| 95 | -5x | +
- checkmate::assert_subset(as.character(unique(adlb[[direction_var]])), c("B", "L", "H"))
+ #' format_count_fraction(x = c(2, 0.6667)) |
|
| 96 | -5x | +
- assert_df_with_variables(adlb, list("Col" = direction_var))
+ #' format_count_fraction(x = c(0, 0)) |
|
| 97 |
-
+ #' |
||
| 98 | -5x | +
- if (any(unique(adlb[[direction_var]]) == "H")) {
+ #' @family formatting functions |
|
| 99 | -4x | +
- assert_df_with_variables(adlb, list("High" = names(worst_flag_high)))
+ #' @export |
|
| 100 |
- }+ format_count_fraction <- function(x, ...) {
|
||
| 101 | -+ | 3x |
-
+ attr(x, "label") <- NULL |
| 102 | -5x | +
- if (any(unique(adlb[[direction_var]]) == "L")) {
+
|
|
| 103 | -4x | +3x |
- assert_df_with_variables(adlb, list("Low" = names(worst_flag_low)))
+ if (any(is.na(x))) {
|
| 104 | -+ | 1x |
- }+ return("NA")
|
| 105 |
-
+ } |
||
| 106 | -5x | +
- if (any(unique(adlb[[direction_var]]) == "B")) {
+
|
|
| 107 | -3x | +2x |
- assert_df_with_variables(+ checkmate::assert_vector(x) |
| 108 | -3x | +2x |
- adlb,+ checkmate::assert_integerish(x[1]) |
| 109 | -3x | +2x |
- list(+ assert_proportion_value(x[2], include_boundaries = TRUE) |
| 110 | -3x | +
- "Low" = names(worst_flag_low),+ |
|
| 111 | -3x | +2x |
- "High" = names(worst_flag_high)+ result <- if (x[1] == 0) {
|
| 112 | -+ | 1x |
- )+ "0" |
| 113 |
- )+ } else {
|
||
| 114 | -+ | 1x |
- }+ paste0(x[1], " (", round(x[2] * 100, 1), "%)")
|
| 115 |
-
+ } |
||
| 116 |
- # extract patients with worst post-baseline lab, either low or high or both+ |
||
| 117 | -5x | +2x |
- worst_flag <- c(worst_flag_low, worst_flag_high)+ return(result) |
| 118 | -5x | +
- col_names <- names(worst_flag)+ } |
|
| 119 | -5x | +
- filter_values <- worst_flag+ |
|
| 120 | -5x | +
- temp <- Map(+ #' Format count and percentage with fixed single decimal place |
|
| 121 | -5x | +
- function(x, y) which(adlb[[x]] == y),+ #' |
|
| 122 | -5x | +
- col_names,+ #' @description `r lifecycle::badge("experimental")`
|
|
| 123 | -5x | +
- filter_values+ #' |
|
| 124 |
- )+ #' Formats a count together with fraction with special consideration when count is `0`. |
||
| 125 | -5x | +
- position_satisfy_filters <- Reduce(union, temp)+ #' |
|
| 126 |
-
+ #' @inheritParams format_count_fraction |
||
| 127 |
- # select variables of interest+ #' |
||
| 128 | -5x | +
- adlb_f <- adlb[position_satisfy_filters, ]+ #' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`. |
|
| 129 |
-
+ #' |
||
| 130 |
- # generate subsets for different directionality+ #' @examples |
||
| 131 | -5x | +
- adlb_f_h <- adlb_f[which(adlb_f[[direction_var]] == "H"), ]+ #' format_count_fraction_fixed_dp(x = c(2, 0.6667)) |
|
| 132 | -5x | +
- adlb_f_l <- adlb_f[which(adlb_f[[direction_var]] == "L"), ]+ #' format_count_fraction_fixed_dp(x = c(2, 0.5)) |
|
| 133 | -5x | +
- adlb_f_b <- adlb_f[which(adlb_f[[direction_var]] == "B"), ]+ #' format_count_fraction_fixed_dp(x = c(0, 0)) |
|
| 134 |
-
+ #' |
||
| 135 |
- # for labs requiring both high and low, data is duplicated and will be stacked on top of each other+ #' @family formatting functions |
||
| 136 | -5x | +
- adlb_f_b_h <- adlb_f_b+ #' @export |
|
| 137 | -5x | +
- adlb_f_b_l <- adlb_f_b+ format_count_fraction_fixed_dp <- function(x, ...) {
|
|
| 138 | -+ | 503x |
-
+ attr(x, "label") <- NULL |
| 139 |
- # extract data with worst lab+ |
||
| 140 | -5x | +503x |
- if (!is.null(worst_flag_high) && !is.null(worst_flag_low)) {
+ if (any(is.na(x))) {
|
| 141 | -+ | ! |
- # change H to High, L to Low+ return("NA")
|
| 142 | -3x | +
- adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
+ } |
|
| 143 | -3x | +
- adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
+
|
|
| 144 | -+ | 503x |
-
+ checkmate::assert_vector(x) |
| 145 | -+ | 503x |
- # change, B to High and Low+ checkmate::assert_integerish(x[1]) |
| 146 | -3x | +503x |
- adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
+ assert_proportion_value(x[2], include_boundaries = TRUE) |
| 147 | -3x | +
- adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
+
|
|
| 148 | -+ | 503x |
-
+ result <- if (x[1] == 0) {
|
| 149 | -3x | +1x |
- adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ]+ "0" |
| 150 | -3x | +503x |
- adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ]+ } else if (.is_equal_float(x[2], 1)) {
|
| 151 | -3x | +500x |
- adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ]+ sprintf("%d (100%%)", x[1])
|
| 152 | -3x | +
- adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ]+ } else {
|
|
| 153 | -+ | 2x |
-
+ sprintf("%d (%.1f%%)", x[1], x[2] * 100)
|
| 154 | -3x | +
- out <- rbind(adlb_out_h, adlb_out_b_h, adlb_out_l, adlb_out_b_l)+ } |
|
| 155 | -2x | +
- } else if (!is.null(worst_flag_high)) {
+
|
|
| 156 | -1x | +503x |
- adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
+ return(result) |
| 157 | -1x | +
- adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
+ } |
|
| 159 | -1x | +
- adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ]+ #' Format count and fraction with special case for count < 10 |
|
| 160 | -1x | +
- adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ]+ #' |
|
| 161 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 162 | -1x | +
- out <- rbind(adlb_out_h, adlb_out_b_h)+ #' |
|
| 163 | -1x | +
- } else if (!is.null(worst_flag_low)) {
+ #' Formats a count together with fraction with special consideration when count is less than 10. |
|
| 164 | -1x | +
- adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
+ #' |
|
| 165 | -1x | +
- adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
+ #' @inheritParams format_count_fraction |
|
| 166 |
-
+ #' |
||
| 167 | -1x | +
- adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ]+ #' @return A string in the format `count (fraction %)`. If `count` is less than 10, only `count` is printed. |
|
| 168 | -1x | +
- adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ]+ #' |
|
| 169 |
-
+ #' @examples |
||
| 170 | -1x | +
- out <- rbind(adlb_out_l, adlb_out_b_l)+ #' format_count_fraction_lt10(x = c(275, 0.9673)) |
|
| 171 |
- }+ #' format_count_fraction_lt10(x = c(2, 0.6667)) |
||
| 172 |
-
+ #' format_count_fraction_lt10(x = c(9, 1)) |
||
| 173 |
- # label+ #' |
||
| 174 | -5x | +
- formatters::var_labels(out) <- formatters::var_labels(adlb_f, fill = FALSE)+ #' @family formatting functions |
|
| 175 |
- # NA+ #' @export |
||
| 176 | -5x | +
- out+ format_count_fraction_lt10 <- function(x, ...) {
|
|
| 177 | -+ | 7x |
- }+ attr(x, "label") <- NULL |
| 179 | -+ | 7x |
- #' Helper function to analyze patients for `s_count_abnormal_lab_worsen_by_baseline()`+ if (any(is.na(x))) {
|
| 180 | -+ | 1x |
- #'+ return("NA")
|
| 181 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 182 |
- #'+ |
||
| 183 | -+ | 6x |
- #' Helper function to count the number of patients and the fraction of patients according to+ checkmate::assert_vector(x) |
| 184 | -+ | 6x |
- #' highest post-baseline lab grade variable `.var`, baseline lab grade variable `baseline_var`,+ checkmate::assert_integerish(x[1]) |
| 185 | -+ | 6x |
- #' and the direction of interest specified in `direction_var`.+ assert_proportion_value(x[2], include_boundaries = TRUE) |
| 186 |
- #'+ |
||
| 187 | -+ | 6x |
- #' @inheritParams argument_convention+ result <- if (x[1] < 10) {
|
| 188 | -+ | 3x |
- #' @inheritParams h_adlb_worsen+ paste0(x[1]) |
| 189 |
- #' @param baseline_var (`string`)\cr name of the baseline lab grade variable.+ } else {
|
||
| 190 | -+ | 3x |
- #'+ paste0(x[1], " (", round(x[2] * 100, 1), "%)")
|
| 191 |
- #' @return The counts and fraction of patients+ } |
||
| 192 |
- #' whose worst post-baseline lab grades are worse than their baseline grades, for+ |
||
| 193 | -+ | 6x |
- #' post-baseline worst grades "1", "2", "3", "4" and "Any".+ return(result) |
| 194 |
- #'+ } |
||
| 195 |
- #' @seealso [abnormal_by_worst_grade_worsen]+ |
||
| 196 |
- #'+ #' Format XX as a formatting function |
||
| 197 |
- #' @examples+ #' |
||
| 198 |
- #' library(dplyr)+ #' Translate a string where x and dots are interpreted as number place |
||
| 199 |
- #'+ #' holders, and others as formatting elements. |
||
| 200 |
- #' # The direction variable, GRADDR, is based on metadata+ #' |
||
| 201 |
- #' adlb <- tern_ex_adlb %>%+ #' @param str (`string`)\cr template. |
||
| 202 |
- #' mutate(+ #' |
||
| 203 |
- #' GRADDR = case_when(+ #' @return An `rtables` formatting function. |
||
| 204 |
- #' PARAMCD == "ALT" ~ "B",+ #' |
||
| 205 |
- #' PARAMCD == "CRP" ~ "L",+ #' @examples |
||
| 206 |
- #' PARAMCD == "IGA" ~ "H"+ #' test <- list(c(1.658, 0.5761), c(1e1, 785.6)) |
||
| 207 |
- #' )+ #' |
||
| 208 |
- #' ) %>%+ #' z <- format_xx("xx (xx.x)")
|
||
| 209 |
- #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")+ #' sapply(test, z) |
||
| 211 |
- #' df <- h_adlb_worsen(+ #' z <- format_xx("xx.x - xx.x")
|
||
| 212 |
- #' adlb,+ #' sapply(test, z) |
||
| 213 |
- #' worst_flag_low = c("WGRLOFL" = "Y"),
+ #' |
||
| 214 |
- #' worst_flag_high = c("WGRHIFL" = "Y"),
+ #' z <- format_xx("xx.x, incl. xx.x% NE")
|
||
| 215 |
- #' direction_var = "GRADDR"+ #' sapply(test, z) |
||
| 216 |
- #' )+ #' |
||
| 217 |
- #'+ #' @family formatting functions |
||
| 218 |
- #' # `h_worsen_counter`+ #' @export |
||
| 219 |
- #' h_worsen_counter(+ format_xx <- function(str) {
|
||
| 220 |
- #' df %>% filter(PARAMCD == "CRP" & GRADDR == "Low"),+ # Find position in the string. |
||
| 221 | -+ | 1x |
- #' id = "USUBJID",+ positions <- gregexpr(pattern = "x+\\.x+|x+", text = str, perl = TRUE) |
| 222 | -+ | 1x |
- #' .var = "ATOXGR",+ x_positions <- regmatches(x = str, m = positions)[[1]] |
| 223 |
- #' baseline_var = "BTOXGR",+ |
||
| 224 |
- #' direction_var = "GRADDR"+ # Roundings depends on the number of x behind [.]. |
||
| 225 | -+ | 1x |
- #' )+ roundings <- lapply( |
| 226 | -+ | 1x |
- #'+ X = x_positions, |
| 227 | -+ | 1x |
- #' @export+ function(x) {
|
| 228 | -+ | 2x |
- h_worsen_counter <- function(df, id, .var, baseline_var, direction_var) {
+ y <- strsplit(split = "\\.", x = x)[[1]] |
| 229 | -17x | +2x |
- checkmate::assert_string(id)+ rounding <- function(x) {
|
| 230 | -17x | +4x |
- checkmate::assert_string(.var)+ round(x, digits = ifelse(length(y) > 1, nchar(y[2]), 0)) |
| 231 | -17x | +
- checkmate::assert_string(baseline_var)+ } |
|
| 232 | -17x | +2x |
- checkmate::assert_scalar(unique(df[[direction_var]]))+ return(rounding) |
| 233 | -17x | +
- checkmate::assert_subset(unique(df[[direction_var]]), c("High", "Low"))
+ } |
|
| 234 | -17x | +
- assert_df_with_variables(df, list(val = c(id, .var, baseline_var, direction_var)))+ ) |
|
| 236 | -+ | 1x |
- # remove post-baseline missing+ rtable_format <- function(x, output) {
|
| 237 | -17x | +2x |
- df <- df[df[[.var]] != "<Missing>", ]+ values <- Map(y = x, fun = roundings, function(y, fun) fun(y)) |
| 238 | -+ | 2x |
-
+ regmatches(x = str, m = positions)[[1]] <- values |
| 239 | -+ | 2x |
- # obtain directionality+ return(str) |
| 240 | -17x | +
- direction <- unique(df[[direction_var]])+ } |
|
| 242 | -17x | +1x |
- if (direction == "Low") {
+ return(rtable_format) |
| 243 | -10x | +
- grade <- -1:-4+ } |
|
| 244 | -10x | +
- worst_grade <- -4+ |
|
| 245 | -7x | +
- } else if (direction == "High") {
+ #' Format numeric values by significant figures |
|
| 246 | -7x | +
- grade <- 1:4+ #' |
|
| 247 | -7x | +
- worst_grade <- 4+ #' Format numeric values to print with a specified number of significant figures. |
|
| 248 |
- }+ #' |
||
| 249 |
-
+ #' @param sigfig (`integer(1)`)\cr number of significant figures to display. |
||
| 250 | -17x | +
- if (nrow(df) > 0) {
+ #' @param format (`string`)\cr the format label (string) to apply when printing the value. Decimal |
|
| 251 | -17x | +
- by_grade <- lapply(grade, function(i) {
+ #' places in string are ignored in favor of formatting by significant figures. Formats options are: |
|
| 252 |
- # filter baseline values that is less than i or <Missing>+ #' `"xx"`, `"xx / xx"`, `"(xx, xx)"`, `"xx - xx"`, and `"xx (xx)"`. |
||
| 253 | -68x | +
- df_temp <- df[df[[baseline_var]] %in% c((i + sign(i) * -1):(-1 * worst_grade), "<Missing>"), ]+ #' @param num_fmt (`string`)\cr numeric format modifiers to apply to the value. Defaults to `"fg"` for |
|
| 254 |
- # num: number of patients with post-baseline worst lab equal to i+ #' standard significant figures formatting - fixed (non-scientific notation) format (`"f"`) |
||
| 255 | -68x | +
- num <- length(unique(df_temp[df_temp[[.var]] %in% i, id, drop = TRUE]))+ #' and `sigfig` equal to number of significant figures instead of decimal places (`"g"`). See the |
|
| 256 |
- # denom: number of patients with baseline values less than i or <missing> and post-baseline in the same direction+ #' [formatC()] `format` argument for more options. |
||
| 257 | -68x | +
- denom <- length(unique(df_temp[[id]]))+ #' |
|
| 258 | -68x | +
- rm(df_temp)+ #' @return An `rtables` formatting function. |
|
| 259 | -68x | +
- c(num = num, denom = denom)+ #' |
|
| 260 |
- })+ #' @examples |
||
| 261 |
- } else {
+ #' fmt_3sf <- format_sigfig(3) |
||
| 262 | -! | +
- by_grade <- lapply(1, function(i) {
+ #' fmt_3sf(1.658) |
|
| 263 | -! | +
- c(num = 0, denom = 0)+ #' fmt_3sf(1e1) |
|
| 264 |
- })+ #' |
||
| 265 |
- }+ #' fmt_5sf <- format_sigfig(5) |
||
| 266 |
-
+ #' fmt_5sf(0.57) |
||
| 267 | -17x | +
- names(by_grade) <- as.character(seq_along(by_grade))+ #' fmt_5sf(0.000025645) |
|
| 268 |
-
+ #' |
||
| 269 |
- # baseline grade less 4 or missing+ #' @family formatting functions |
||
| 270 | -17x | +
- df_temp <- df[!df[[baseline_var]] %in% worst_grade, ]+ #' @export |
|
| 271 |
-
+ format_sigfig <- function(sigfig, format = "xx", num_fmt = "fg") {
|
||
| 272 | -+ | 3x |
- # denom: number of patients with baseline values less than 4 or <missing> and post-baseline in the same direction+ checkmate::assert_integerish(sigfig) |
| 273 | -17x | +3x |
- denom <- length(unique(df_temp[, id, drop = TRUE]))+ format <- gsub("xx\\.|xx\\.x+", "xx", format)
|
| 274 | -+ | 3x |
-
+ checkmate::assert_choice(format, c("xx", "xx / xx", "(xx, xx)", "xx - xx", "xx (xx)"))
|
| 275 | -+ | 3x |
- # condition 1: missing baseline and in the direction of abnormality+ function(x, ...) {
|
| 276 | -17x | +! |
- con1 <- which(df_temp[[baseline_var]] == "<Missing>" & df_temp[[.var]] %in% grade)+ if (!is.numeric(x)) stop("`format_sigfig` cannot be used for non-numeric values. Please choose another format.")
|
| 277 | -17x | +12x |
- df_temp_nm <- df_temp[which(df_temp[[baseline_var]] != "<Missing>" & df_temp[[.var]] %in% grade), ]+ num <- formatC(signif(x, digits = sigfig), digits = sigfig, format = num_fmt, flag = "#") |
| 278 | -+ | 12x |
-
+ num <- gsub("\\.$", "", num) # remove trailing "."
|
| 279 |
- # condition 2: if post-baseline values are present then post-baseline values must be worse than baseline+ |
||
| 280 | -17x | +12x |
- if (direction == "Low") {
+ format_value(num, format) |
| 281 | -10x | +
- con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) < as.numeric(as.character(df_temp_nm[[baseline_var]])))+ } |
|
| 282 |
- } else {
+ } |
||
| 283 | -7x | +
- con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) > as.numeric(as.character(df_temp_nm[[baseline_var]])))+ |
|
| 284 |
- }+ #' Format fraction with lower threshold |
||
| 285 |
-
+ #' |
||
| 286 |
- # number of patients satisfy either conditions 1 or 2+ #' @description `r lifecycle::badge("stable")`
|
||
| 287 | -17x | +
- num <- length(unique(df_temp[union(con1, con2), id, drop = TRUE]))+ #' |
|
| 288 |
-
+ #' Formats a fraction when the second element of the input `x` is the fraction. It applies |
||
| 289 | -17x | +
- list(fraction = c(by_grade, list("Any" = c(num = num, denom = denom))))
+ #' a lower threshold, below which it is just stated that the fraction is smaller than that. |
|
| 290 |
- }+ #' |
||
| 291 |
-
+ #' @param threshold (`proportion`)\cr lower threshold. |
||
| 292 |
- #' @describeIn abnormal_by_worst_grade_worsen Statistics function for patients whose worst post-baseline+ #' |
||
| 293 |
- #' lab grades are worse than their baseline grades.+ #' @return An `rtables` formatting function that takes numeric input `x` where the second |
||
| 294 |
- #'+ #' element is the fraction that is formatted. If the fraction is above or equal to the threshold, |
||
| 295 |
- #' @return+ #' then it is displayed in percentage. If it is positive but below the threshold, it returns, |
||
| 296 |
- #' * `s_count_abnormal_lab_worsen_by_baseline()` returns the counts and fraction of patients whose worst+ #' e.g. "<1" if the threshold is `0.01`. If it is zero, then just "0" is returned. |
||
| 297 |
- #' post-baseline lab grades are worse than their baseline grades, for post-baseline worst grades+ #' |
||
| 298 |
- #' "1", "2", "3", "4" and "Any".+ #' @examples |
||
| 299 |
- #'+ #' format_fun <- format_fraction_threshold(0.05) |
||
| 300 |
- #' @keywords internal+ #' format_fun(x = c(20, 0.1)) |
||
| 301 |
- s_count_abnormal_lab_worsen_by_baseline <- function(df, # nolint+ #' format_fun(x = c(2, 0.01)) |
||
| 302 |
- .var = "ATOXGR",+ #' format_fun(x = c(0, 0)) |
||
| 303 |
- variables = list(+ #' |
||
| 304 |
- id = "USUBJID",+ #' @family formatting functions |
||
| 305 |
- baseline_var = "BTOXGR",+ #' @export |
||
| 306 |
- direction_var = "GRADDR"+ format_fraction_threshold <- function(threshold) {
|
||
| 307 | -+ | 1x |
- )) {
+ assert_proportion_value(threshold) |
| 308 | 1x |
- checkmate::assert_string(.var)+ string_below_threshold <- paste0("<", round(threshold * 100))
|
|
| 309 | 1x |
- checkmate::assert_set_equal(names(variables), c("id", "baseline_var", "direction_var"))
+ function(x, ...) {
|
|
| 310 | -1x | +3x |
- checkmate::assert_string(variables$id)+ assert_proportion_value(x[2], include_boundaries = TRUE) |
| 311 | -1x | +3x |
- checkmate::assert_string(variables$baseline_var)+ ifelse( |
| 312 | -1x | +3x |
- checkmate::assert_string(variables$direction_var)+ x[2] > 0.01, |
| 313 | -1x | +3x |
- assert_df_with_variables(df, c(aval = .var, variables[1:3]))+ round(x[2] * 100), |
| 314 | -1x | +3x |
- assert_list_of_variables(variables)+ ifelse( |
| 315 | -+ | 3x |
-
+ x[2] == 0, |
| 316 | -1x | +3x |
- h_worsen_counter(df, variables$id, .var, variables$baseline_var, variables$direction_var)+ "0", |
| 317 | -+ | 3x |
- }+ string_below_threshold |
| 318 |
-
+ ) |
||
| 319 |
- #' @describeIn abnormal_by_worst_grade_worsen Formatted analysis function which is used as `afun`+ ) |
||
| 320 |
- #' in `count_abnormal_lab_worsen_by_baseline()`.+ } |
||
| 321 |
- #'+ } |
||
| 322 |
- #' @return+ |
||
| 323 |
- #' * `a_count_abnormal_lab_worsen_by_baseline()` returns the corresponding list with+ #' Format extreme values |
||
| 324 |
- #' formatted [rtables::CellValue()].+ #' |
||
| 325 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 326 |
- #' @keywords internal+ #' |
||
| 327 |
- a_count_abnormal_lab_worsen_by_baseline <- make_afun( # nolint+ #' `rtables` formatting functions that handle extreme values. |
||
| 328 |
- s_count_abnormal_lab_worsen_by_baseline,+ #' |
||
| 329 |
- .formats = c(fraction = format_fraction),+ #' @param digits (`integer(1)`)\cr number of decimal places to display. |
||
| 330 |
- .ungroup_stats = "fraction"+ #' |
||
| 331 |
- )+ #' @details For each input, apply a format to the specified number of `digits`. If the value is |
||
| 332 |
-
+ #' below a threshold, it returns "<0.01" e.g. if the number of `digits` is 2. If the value is |
||
| 333 |
- #' @describeIn abnormal_by_worst_grade_worsen Layout-creating function which can take statistics function+ #' above a threshold, it returns ">999.99" e.g. if the number of `digits` is 2. |
||
| 334 |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' If it is zero, then returns "0.00". |
||
| 336 |
- #' @return+ #' @family formatting functions |
||
| 337 |
- #' * `count_abnormal_lab_worsen_by_baseline()` returns a layout object suitable for passing to further layouting+ #' @name extreme_format |
||
| 338 |
- #' functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted+ NULL |
||
| 339 |
- #' rows containing the statistics from `s_count_abnormal_lab_worsen_by_baseline()` to the table layout.+ |
||
| 340 |
- #'+ #' @describeIn extreme_format Internal helper function to calculate the threshold and create formatted strings |
||
| 341 |
- #' @examples+ #' used in Formatting Functions. Returns a list with elements `threshold` and `format_string`. |
||
| 342 |
- #' library(dplyr)+ #' |
||
| 343 |
- #'+ #' @return |
||
| 344 |
- #' # The direction variable, GRADDR, is based on metadata+ #' * `h_get_format_threshold()` returns a `list` of 2 elements: `threshold`, with `low` and `high` thresholds, |
||
| 345 |
- #' adlb <- tern_ex_adlb %>%+ #' and `format_string`, with thresholds formatted as strings. |
||
| 346 |
- #' mutate(+ #' |
||
| 347 |
- #' GRADDR = case_when(+ #' @examples |
||
| 348 |
- #' PARAMCD == "ALT" ~ "B",+ #' h_get_format_threshold(2L) |
||
| 349 |
- #' PARAMCD == "CRP" ~ "L",+ #' |
||
| 350 |
- #' PARAMCD == "IGA" ~ "H"+ #' @export |
||
| 351 |
- #' )+ h_get_format_threshold <- function(digits = 2L) {
|
||
| 352 | -+ | 2113x |
- #' ) %>%+ checkmate::assert_integerish(digits) |
| 353 |
- #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")+ |
||
| 354 | -+ | 2113x |
- #'+ low_threshold <- 1 / (10 ^ digits) # styler: off |
| 355 | -+ | 2113x |
- #' df <- h_adlb_worsen(+ high_threshold <- 1000 - (1 / (10 ^ digits)) # styler: off |
| 356 |
- #' adlb,+ |
||
| 357 | -+ | 2113x |
- #' worst_flag_low = c("WGRLOFL" = "Y"),
+ string_below_threshold <- paste0("<", low_threshold)
|
| 358 | -+ | 2113x |
- #' worst_flag_high = c("WGRHIFL" = "Y"),
+ string_above_threshold <- paste0(">", high_threshold)
|
| 359 |
- #' direction_var = "GRADDR"+ |
||
| 360 | -+ | 2113x |
- #' )+ list( |
| 361 | -+ | 2113x |
- #'+ "threshold" = c(low = low_threshold, high = high_threshold), |
| 362 | -+ | 2113x |
- #' basic_table() %>%+ "format_string" = c(low = string_below_threshold, high = string_above_threshold) |
| 363 |
- #' split_cols_by("ARMCD") %>%
+ ) |
||
| 364 |
- #' add_colcounts() %>%+ } |
||
| 365 |
- #' split_rows_by("PARAMCD") %>%
+
|
||
| 366 |
- #' split_rows_by("GRADDR") %>%
+ #' @describeIn extreme_format Internal helper function to apply a threshold format to a value. |
||
| 367 |
- #' count_abnormal_lab_worsen_by_baseline(+ #' Creates a formatted string to be used in Formatting Functions. |
||
| 368 |
- #' var = "ATOXGR",+ #' |
||
| 369 |
- #' variables = list(+ #' @param x (`numeric(1)`)\cr value to format. |
||
| 370 |
- #' id = "USUBJID",+ #' |
||
| 371 |
- #' baseline_var = "BTOXGR",+ #' @return |
||
| 372 |
- #' direction_var = "GRADDR"+ #' * `h_format_threshold()` returns the given value, or if the value is not within the digit threshold the relation |
||
| 373 |
- #' )+ #' of the given value to the digit threshold, as a formatted string. |
||
| 374 |
- #' ) %>%+ #' |
||
| 375 |
- #' append_topleft("Direction of Abnormality") %>%
+ #' @examples |
||
| 376 |
- #' build_table(df = df, alt_counts_df = tern_ex_adsl)+ #' h_format_threshold(0.001) |
||
| 377 |
- #'+ #' h_format_threshold(1000) |
||
| 378 |
- #' @export+ #' |
||
| 379 |
- #' @order 2+ #' @export |
||
| 380 |
- count_abnormal_lab_worsen_by_baseline <- function(lyt, # nolint+ h_format_threshold <- function(x, digits = 2L) {
|
||
| 381 | -+ | 2115x |
- var,+ if (is.na(x)) {
|
| 382 | -+ | 4x |
- variables = list(+ return(x) |
| 383 |
- id = "USUBJID",+ } |
||
| 384 |
- baseline_var = "BTOXGR",+ |
||
| 385 | -+ | 2111x |
- direction_var = "GRADDR"+ checkmate::assert_numeric(x, lower = 0) |
| 386 |
- ),+ |
||
| 387 | -+ | 2111x |
- na_str = default_na_str(),+ l_fmt <- h_get_format_threshold(digits) |
| 388 |
- nested = TRUE,+ |
||
| 389 | -+ | 2111x |
- ...,+ result <- if (x < l_fmt$threshold["low"] && 0 < x) {
|
| 390 | -+ | 44x |
- table_names = NULL,+ l_fmt$format_string["low"] |
| 391 | -+ | 2111x |
- .stats = NULL,+ } else if (x > l_fmt$threshold["high"]) {
|
| 392 | -+ | 99x |
- .formats = NULL,+ l_fmt$format_string["high"] |
| 393 |
- .labels = NULL,+ } else {
|
||
| 394 | -+ | 1968x |
- .indent_mods = NULL) {
+ sprintf(fmt = paste0("%.", digits, "f"), x)
|
| 395 | -1x | +
- checkmate::assert_string(var)+ } |
|
| 397 | -1x | +2111x |
- extra_args <- list(variables = variables, ...)+ unname(result) |
| 398 |
-
+ } |
||
| 399 | -1x | +
- afun <- make_afun(+ |
|
| 400 | -1x | +
- a_count_abnormal_lab_worsen_by_baseline,+ #' Format a single extreme value |
|
| 401 | -1x | +
- .stats = .stats,+ #' |
|
| 402 | -1x | +
- .formats = .formats,+ #' @description `r lifecycle::badge("stable")`
|
|
| 403 | -1x | +
- .labels = .labels,+ #' |
|
| 404 | -1x | +
- .indent_mods = .indent_mods+ #' Create a formatting function for a single extreme value. |
|
| 405 |
- )+ #' |
||
| 406 |
-
+ #' @inheritParams extreme_format |
||
| 407 | -1x | +
- lyt <- analyze(+ #' |
|
| 408 | -1x | +
- lyt = lyt,+ #' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme value. |
|
| 409 | -1x | +
- vars = var,+ #' |
|
| 410 | -1x | +
- afun = afun,+ #' @examples |
|
| 411 | -1x | +
- na_str = na_str,+ #' format_fun <- format_extreme_values(2L) |
|
| 412 | -1x | +
- nested = nested,+ #' format_fun(x = 0.127) |
|
| 413 | -1x | +
- extra_args = extra_args,+ #' format_fun(x = Inf) |
|
| 414 | -1x | +
- show_labels = "hidden"+ #' format_fun(x = 0) |
|
| 415 |
- )+ #' format_fun(x = 0.009) |
||
| 416 |
-
+ #' |
||
| 417 | -1x | +
- lyt+ #' @family formatting functions |
|
| 418 |
- }+ #' @export |
| 1 | +419 |
- #' Tabulate biomarker effects on survival by subgroup+ format_extreme_values <- function(digits = 2L) {
|
||
| 2 | -+ | |||
| 420 | +63x |
- #'+ function(x, ...) {
|
||
| 3 | -+ | |||
| 421 | +657x |
- #' @description `r lifecycle::badge("stable")`
+ checkmate::assert_scalar(x, na.ok = TRUE) |
||
| 4 | +422 |
- #'+ |
||
| 5 | -+ | |||
| 423 | +657x |
- #' The [tabulate_survival_biomarkers()] function creates a layout element to tabulate the estimated effects of multiple+ h_format_threshold(x = x, digits = digits) |
||
| 6 | +424 |
- #' continuous biomarker variables on survival across subgroups, returning statistics including median survival time and+ } |
||
| 7 | +425 |
- #' hazard ratio for each population subgroup. The table is created from `df`, a list of data frames returned by+ } |
||
| 8 | +426 |
- #' [extract_survival_biomarkers()], with the statistics to include specified via the `vars` parameter.+ |
||
| 9 | +427 |
- #'+ #' Format extreme values part of a confidence interval |
||
| 10 | +428 |
- #' A forest plot can be created from the resulting table using the [g_forest()] function.+ #' |
||
| 11 | +429 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 12 | +430 |
- #' @inheritParams fit_coxreg_multivar+ #' |
||
| 13 | +431 |
- #' @inheritParams survival_duration_subgroups+ #' Formatting Function for extreme values part of a confidence interval. Values |
||
| 14 | +432 |
- #' @inheritParams argument_convention+ #' are formatted as e.g. "(xx.xx, xx.xx)" if the number of `digits` is 2. |
||
| 15 | +433 |
- #' @param df (`data.frame`)\cr containing all analysis variables, as returned by+ #' |
||
| 16 | +434 |
- #' [extract_survival_biomarkers()].+ #' @inheritParams extreme_format |
||
| 17 | +435 |
- #' @param vars (`character`)\cr the names of statistics to be reported among:+ #' |
||
| 18 | +436 |
- #' * `n_tot_events`: Total number of events per group.+ #' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme |
||
| 19 | +437 |
- #' * `n_tot`: Total number of observations per group.+ #' values confidence interval. |
||
| 20 | +438 |
- #' * `median`: Median survival time.+ #' |
||
| 21 | +439 |
- #' * `hr`: Hazard ratio.+ #' @examples |
||
| 22 | +440 |
- #' * `ci`: Confidence interval of hazard ratio.+ #' format_fun <- format_extreme_values_ci(2L) |
||
| 23 | +441 |
- #' * `pval`: p-value of the effect.+ #' format_fun(x = c(0.127, Inf)) |
||
| 24 | +442 |
- #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` are required.+ #' format_fun(x = c(0, 0.009)) |
||
| 25 | +443 |
#' |
||
| 26 | +444 |
- #' @details These functions create a layout starting from a data frame which contains+ #' @family formatting functions |
||
| 27 | +445 |
- #' the required statistics. The tables are then typically used as input for forest plots.+ #' @export |
||
| 28 | +446 |
- #'+ format_extreme_values_ci <- function(digits = 2L) {
|
||
| 29 | -+ | |||
| 447 | +71x |
- #' @examples+ function(x, ...) {
|
||
| 30 | -+ | |||
| 448 | +726x |
- #' library(dplyr)+ checkmate::assert_vector(x, len = 2) |
||
| 31 | -+ | |||
| 449 | +726x |
- #'+ l_result <- h_format_threshold(x = x[1], digits = digits) |
||
| 32 | -+ | |||
| 450 | +726x |
- #' adtte <- tern_ex_adtte+ h_result <- h_format_threshold(x = x[2], digits = digits) |
||
| 33 | +451 |
- #'+ |
||
| 34 | -+ | |||
| 452 | +726x |
- #' # Save variable labels before data processing steps.+ paste0("(", l_result, ", ", h_result, ")")
|
||
| 35 | +453 |
- #' adtte_labels <- formatters::var_labels(adtte)+ } |
||
| 36 | +454 |
- #'+ } |
||
| 37 | +455 |
- #' adtte_f <- adtte %>%+ |
||
| 38 | +456 |
- #' filter(PARAMCD == "OS") %>%+ #' Format automatically using data significant digits |
||
| 39 | +457 |
- #' mutate(+ #' |
||
| 40 | +458 |
- #' AVALU = as.character(AVALU),+ #' @description `r lifecycle::badge("stable")`
|
||
| 41 | +459 |
- #' is_event = CNSR == 0+ #' |
||
| 42 | +460 |
- #' )+ #' Formatting function for the majority of default methods used in [analyze_vars()]. |
||
| 43 | +461 |
- #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
+ #' For non-derived values, the significant digits of data is used (e.g. range), while derived |
||
| 44 | +462 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ #' values have one more digits (measure of location and dispersion like mean, standard deviation). |
||
| 45 | +463 |
- #'+ #' This function can be called internally with "auto" like, for example, |
||
| 46 | +464 |
- #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`,+ #' `.formats = c("mean" = "auto")`. See details to see how this works with the inner function.
|
||
| 47 | +465 |
- #' # in multiple regression models containing one covariate `RACE`,+ #' |
||
| 48 | +466 |
- #' # as well as one stratification variable `STRATA1`. The subgroups+ #' @param dt_var (`numeric`)\cr variable data the statistics were calculated from. Used only to |
||
| 49 | +467 |
- #' # are defined by the levels of `BMRKR2`.+ #' find significant digits. In [analyze_vars] this comes from `.df_row` (see |
||
| 50 | +468 |
- #'+ #' [rtables::additional_fun_params]), and it is the row data after the above row splits. No |
||
| 51 | +469 |
- #' df <- extract_survival_biomarkers(+ #' column split is considered. |
||
| 52 | +470 |
- #' variables = list(+ #' @param x_stat (`string`)\cr string indicating the current statistical method used. |
||
| 53 | +471 |
- #' tte = "AVAL",+ #' |
||
| 54 | +472 |
- #' is_event = "is_event",+ #' @return A string that `rtables` prints in a table cell. |
||
| 55 | +473 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' |
||
| 56 | +474 |
- #' strata = "STRATA1",+ #' @details |
||
| 57 | +475 |
- #' covariates = "SEX",+ #' The internal function is needed to work with `rtables` default structure for |
||
| 58 | +476 |
- #' subgroups = "BMRKR2"+ #' format functions, i.e. `function(x, ...)`, where is x are results from statistical evaluation. |
||
| 59 | +477 |
- #' ),+ #' It can be more than one element (e.g. for `.stats = "mean_sd"`). |
||
| 60 | +478 |
- #' label_all = "Total Patients",+ #' |
||
| 61 | +479 |
- #' data = adtte_f+ #' @examples |
||
| 62 | +480 |
- #' )+ #' x_todo <- c(0.001, 0.2, 0.0011000, 3, 4) |
||
| 63 | +481 |
- #' df+ #' res <- c(mean(x_todo[1:3]), sd(x_todo[1:3])) |
||
| 64 | +482 |
#' |
||
| 65 | +483 |
- #' # Here we group the levels of `BMRKR2` manually.+ #' # x is the result coming into the formatting function -> res!! |
||
| 66 | +484 |
- #' df_grouped <- extract_survival_biomarkers(+ #' format_auto(dt_var = x_todo, x_stat = "mean_sd")(x = res) |
||
| 67 | +485 |
- #' variables = list(+ #' format_auto(x_todo, "range")(x = range(x_todo)) |
||
| 68 | +486 |
- #' tte = "AVAL",+ #' no_sc_x <- c(0.0000001, 1) |
||
| 69 | +487 |
- #' is_event = "is_event",+ #' format_auto(no_sc_x, "range")(x = no_sc_x) |
||
| 70 | +488 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' |
||
| 71 | +489 |
- #' strata = "STRATA1",+ #' @family formatting functions |
||
| 72 | +490 |
- #' covariates = "SEX",+ #' @export |
||
| 73 | +491 |
- #' subgroups = "BMRKR2"+ format_auto <- function(dt_var, x_stat) {
|
||
| 74 | -+ | |||
| 492 | +10x |
- #' ),+ function(x = "", ...) {
|
||
| 75 | -+ | |||
| 493 | +18x |
- #' data = adtte_f,+ checkmate::assert_numeric(x, min.len = 1) |
||
| 76 | -+ | |||
| 494 | +18x |
- #' groups_lists = list(+ checkmate::assert_numeric(dt_var, min.len = 1) |
||
| 77 | +495 |
- #' BMRKR2 = list(+ # Defaults - they may be a param in the future |
||
| 78 | -+ | |||
| 496 | +18x |
- #' "low" = "LOW",+ der_stats <- c( |
||
| 79 | -+ | |||
| 497 | +18x |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ "mean", "sd", "se", "median", "geom_mean", "quantiles", "iqr", |
||
| 80 | -+ | |||
| 498 | +18x |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ "mean_sd", "mean_se", "mean_se", "mean_ci", "mean_sei", "mean_sdi", |
||
| 81 | -+ | |||
| 499 | +18x |
- #' )+ "median_ci" |
||
| 82 | +500 |
- #' )+ ) |
||
| 83 | -+ | |||
| 501 | +18x |
- #' )+ nonder_stats <- c("n", "range", "min", "max")
|
||
| 84 | +502 |
- #' df_grouped+ |
||
| 85 | +503 |
- #'+ # Safenet for miss-modifications |
||
| 86 | -+ | |||
| 504 | +18x |
- #' @name survival_biomarkers_subgroups+ stopifnot(length(intersect(der_stats, nonder_stats)) == 0) # nolint |
||
| 87 | -+ | |||
| 505 | +18x |
- #' @order 1+ checkmate::assert_choice(x_stat, c(der_stats, nonder_stats)) |
||
| 88 | +506 |
- NULL+ |
||
| 89 | +507 |
-
+ # Finds the max number of digits in data |
||
| 90 | -+ | |||
| 508 | +18x |
- #' Prepare survival data estimates for multiple biomarkers in a single data frame+ detect_dig <- vapply(dt_var, count_decimalplaces, FUN.VALUE = numeric(1)) %>% |
||
| 91 | -+ | |||
| 509 | +18x |
- #'+ max() |
||
| 92 | +510 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 93 | -+ | |||
| 511 | +18x |
- #'+ if (x_stat %in% der_stats) {
|
||
| 94 | -+ | |||
| 512 | +8x |
- #' Prepares estimates for number of events, patients and median survival times, as well as hazard ratio estimates,+ detect_dig <- detect_dig + 1 |
||
| 95 | +513 |
- #' confidence intervals and p-values, for multiple biomarkers across population subgroups in a single data frame.+ } |
||
| 96 | +514 |
- #' `variables` corresponds to the names of variables found in `data`, passed as a named `list` and requires elements+ |
||
| 97 | +515 |
- #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables), and optionally `subgroups` and `strata`.+ # Render input |
||
| 98 | -+ | |||
| 516 | +18x |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ str_vals <- formatC(x, digits = detect_dig, format = "f") |
||
| 99 | -+ | |||
| 517 | +18x |
- #'+ def_fmt <- get_formats_from_stats(x_stat)[[x_stat]] |
||
| 100 | -+ | |||
| 518 | +18x |
- #' @inheritParams argument_convention+ str_fmt <- str_extract(def_fmt, invert = FALSE)[[1]] |
||
| 101 | -+ | |||
| 519 | +18x |
- #' @inheritParams fit_coxreg_multivar+ if (length(str_fmt) != length(str_vals)) {
|
||
| 102 | -+ | |||
| 520 | +2x |
- #' @inheritParams survival_duration_subgroups+ stop( |
||
| 103 | -+ | |||
| 521 | +2x |
- #'+ "Number of inserted values as result (", length(str_vals),
|
||
| 104 | -+ | |||
| 522 | +2x |
- #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_tot_events`,+ ") is not the same as there should be in the default tern formats for ", |
||
| 105 | -+ | |||
| 523 | +2x |
- #' `median`, `hr`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`,+ x_stat, " (-> ", def_fmt, " needs ", length(str_fmt), " values). ", |
||
| 106 | -+ | |||
| 524 | +2x |
- #' `var_label`, and `row_type`.+ "See tern_default_formats to check all of them." |
||
| 107 | +525 |
- #'+ ) |
||
| 108 | +526 |
- #' @seealso [h_coxreg_mult_cont_df()] which is used internally, [tabulate_survival_biomarkers()].+ } |
||
| 109 | +527 |
- #'+ |
||
| 110 | +528 |
- #' @export+ # Squashing them together |
||
| 111 | -- |
- extract_survival_biomarkers <- function(variables,+ | ||
| 529 | +16x | +
+ inv_str_fmt <- str_extract(def_fmt, invert = TRUE)[[1]] |
||
| 112 | -+ | |||
| 530 | +16x |
- data,+ stopifnot(length(inv_str_fmt) == length(str_vals) + 1) # nolint |
||
| 113 | +531 |
- groups_lists = list(),+ |
||
| 114 | -+ | |||
| 532 | +16x |
- control = control_coxreg(),+ out <- vector("character", length = length(inv_str_fmt) + length(str_vals))
|
||
| 115 | -+ | |||
| 533 | +16x |
- label_all = "All Patients") {
+ is_even <- seq_along(out) %% 2 == 0 |
||
| 116 | -6x | +534 | +16x |
- if ("strat" %in% names(variables)) {
+ out[is_even] <- str_vals |
| 117 | -! | +|||
| 535 | +16x |
- warning(+ out[!is_even] <- inv_str_fmt |
||
| 118 | -! | +|||
| 536 | +
- "Warning: the `strat` element name of the `variables` list argument to `extract_survival_biomarkers() ",+ |
|||
| 119 | -! | +|||
| 537 | +16x |
- "was deprecated in tern 0.9.4.\n ",+ return(paste0(out, collapse = "")) |
||
| 120 | -! | +|||
| 538 | +
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ } |
|||
| 121 | +539 |
- )+ } |
||
| 122 | -! | +|||
| 540 | +
- variables[["strata"]] <- variables[["strat"]]+ |
|||
| 123 | +541 |
- }+ # Utility function that could be useful in general |
||
| 124 | +542 |
-
+ str_extract <- function(string, pattern = "xx|xx\\.|xx\\.x+", invert = FALSE) {
|
||
| 125 | -6x | +543 | +34x |
- checkmate::assert_list(variables)+ regmatches(string, gregexpr(pattern, string), invert = invert) |
| 126 | -6x | +|||
| 544 | +
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ } |
|||
| 127 | -6x | +|||
| 545 | +
- checkmate::assert_string(label_all)+ |
|||
| 128 | +546 |
-
+ # Helper function |
||
| 129 | +547 |
- # Start with all patients.+ count_decimalplaces <- function(dec) {
|
||
| 130 | -6x | +548 | +161x |
- result_all <- h_coxreg_mult_cont_df(+ if (is.na(dec)) {
|
| 131 | +549 | 6x |
- variables = variables,+ return(0) |
|
| 132 | -6x | +550 | +155x |
- data = data,+ } else if (abs(dec - round(dec)) > .Machine$double.eps^0.5) { # For precision
|
| 133 | -6x | +551 | +122x |
- control = control+ nchar(strsplit(format(dec, scientific = FALSE, trim = FALSE), ".", fixed = TRUE)[[1]][[2]]) |
| 134 | +552 |
- )+ } else {
|
||
| 135 | -6x | +553 | +33x |
- result_all$subgroup <- label_all+ return(0) |
| 136 | -6x | +|||
| 554 | +
- result_all$var <- "ALL"+ } |
|||
| 137 | -6x | +|||
| 555 | +
- result_all$var_label <- label_all+ } |
|||
| 138 | -6x | +|||
| 556 | +
- result_all$row_type <- "content"+ |
|||
| 139 | -6x | +|||
| 557 | +
- if (is.null(variables$subgroups)) {
+ #' Apply automatic formatting |
|||
| 140 | +558 |
- # Only return result for all patients.+ #' |
||
| 141 | -1x | +|||
| 559 | +
- result_all+ #' Checks if any of the listed formats in `.formats` are `"auto"`, and replaces `"auto"` with |
|||
| 142 | +560 |
- } else {
+ #' the correct implementation of `format_auto` for the given statistics, data, and variable. |
||
| 143 | +561 |
- # Add subgroups results.+ #' |
||
| 144 | -5x | +|||
| 562 | +
- l_data <- h_split_by_subgroups(+ #' @inheritParams argument_convention |
|||
| 145 | -5x | +|||
| 563 | +
- data,+ #' @param x_stats (named `list`)\cr a named list of statistics where each element corresponds |
|||
| 146 | -5x | +|||
| 564 | +
- variables$subgroups,+ #' to an element in `.formats`, with matching names. |
|||
| 147 | -5x | +|||
| 565 | +
- groups_lists = groups_lists+ #' |
|||
| 148 | +566 |
- )+ #' @keywords internal |
||
| 149 | -5x | +|||
| 567 | +
- l_result <- lapply(l_data, function(grp) {
+ apply_auto_formatting <- function(.formats, x_stats, .df_row, .var) {
|
|||
| 150 | -25x | +568 | +420x |
- result <- h_coxreg_mult_cont_df(+ is_auto_fmt <- vapply(.formats, function(ii) is.character(ii) && ii == "auto", logical(1)) |
| 151 | -25x | +569 | +420x |
- variables = variables,+ if (any(is_auto_fmt)) {
|
| 152 | -25x | +570 | +3x |
- data = grp$df,+ auto_stats <- x_stats[is_auto_fmt] |
| 153 | -25x | +571 | +3x |
- control = control+ var_df <- .df_row[[.var]] # xxx this can be extended for the WHOLE data or single facets |
| 154 | -+ | |||
| 572 | +3x |
- )+ .formats[is_auto_fmt] <- lapply(names(auto_stats), format_auto, dt_var = var_df) |
||
| 155 | -25x | +|||
| 573 | +
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ } |
|||
| 156 | -25x | +574 | +420x |
- cbind(result, result_labels)+ .formats |
| 157 | +575 |
- })+ } |
||
| 158 | -5x | +
| 1 | +
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ #' Helper functions for subgroup treatment effect pattern (STEP) calculations |
|||
| 159 | -5x | +|||
| 2 | +
- result_subgroups$row_type <- "analysis"+ #' |
|||
| 160 | -5x | +|||
| 3 | +
- rbind(+ #' @description `r lifecycle::badge("stable")`
|
|||
| 161 | -5x | +|||
| 4 | +
- result_all,+ #' |
|||
| 162 | -5x | +|||
| 5 | +
- result_subgroups+ #' Helper functions that are used internally for the STEP calculations. |
|||
| 163 | +6 |
- )+ #' |
||
| 164 | +7 |
- }+ #' @inheritParams argument_convention |
||
| 165 | +8 |
- }+ #' |
||
| 166 | +9 |
-
+ #' @name h_step |
||
| 167 | +10 |
- #' @describeIn survival_biomarkers_subgroups Table-creating function which creates a table+ #' @include control_step.R |
||
| 168 | +11 |
- #' summarizing biomarker effects on survival by subgroup.+ NULL |
||
| 169 | +12 |
- #'+ |
||
| 170 | +13 |
- #' @param label_all `r lifecycle::badge("deprecated")`\cr please assign the `label_all` parameter within the
+ #' @describeIn h_step Creates the windows for STEP, based on the control settings |
||
| 171 | +14 |
- #' [extract_survival_biomarkers()] function when creating `df`.+ #' provided. |
||
| 172 | +15 |
#' |
||
| 173 | +16 |
- #' @return An `rtables` table summarizing biomarker effects on survival by subgroup.+ #' @param x (`numeric`)\cr biomarker value(s) to use (without `NA`). |
||
| 174 | +17 |
- #'+ #' @param control (named `list`)\cr output from `control_step()`. |
||
| 175 | +18 |
- #' @note In contrast to [tabulate_survival_subgroups()] this tabulation function does+ #' |
||
| 176 | +19 |
- #' not start from an input layout `lyt`. This is because internally the table is+ #' @return |
||
| 177 | +20 |
- #' created by combining multiple subtables.+ #' * `h_step_window()` returns a list containing the window-selection matrix `sel` |
||
| 178 | +21 |
- #'+ #' and the interval information matrix `interval`. |
||
| 179 | +22 |
- #' @seealso [h_tab_surv_one_biomarker()] which is used internally, [extract_survival_biomarkers()].+ #' |
||
| 180 | +23 |
- #'+ #' @export |
||
| 181 | +24 |
- #' @examples+ h_step_window <- function(x, |
||
| 182 | +25 |
- #' ## Table with default columns.+ control = control_step()) {
|
||
| 183 | -+ | |||
| 26 | +12x |
- #' tabulate_survival_biomarkers(df)+ checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) |
||
| 184 | -+ | |||
| 27 | +12x |
- #'+ checkmate::assert_list(control, names = "named") |
||
| 185 | +28 |
- #' ## Table with a manually chosen set of columns: leave out "pval", reorder.+ |
||
| 186 | -+ | |||
| 29 | +12x |
- #' tab <- tabulate_survival_biomarkers(+ sel <- matrix(FALSE, length(x), control$num_points) |
||
| 187 | -+ | |||
| 30 | +12x |
- #' df = df,+ out <- matrix(0, control$num_points, 3) |
||
| 188 | -+ | |||
| 31 | +12x |
- #' vars = c("n_tot_events", "ci", "n_tot", "median", "hr"),
+ colnames(out) <- paste("Interval", c("Center", "Lower", "Upper"))
|
||
| 189 | -+ | |||
| 32 | +12x |
- #' time_unit = as.character(adtte_f$AVALU[1])+ if (control$use_percentile) {
|
||
| 190 | +33 |
- #' )+ # Create windows according to percentile cutoffs. |
||
| 191 | -+ | |||
| 34 | +9x |
- #'+ out <- cbind(out, out) |
||
| 192 | -+ | |||
| 35 | +9x |
- #' ## Finally produce the forest plot.+ colnames(out)[1:3] <- paste("Percentile", c("Center", "Lower", "Upper"))
|
||
| 193 | -+ | |||
| 36 | +9x |
- #' \donttest{
+ xs <- seq(0, 1, length.out = control$num_points + 2)[-1] |
||
| 194 | -+ | |||
| 37 | +9x |
- #' g_forest(tab, xlim = c(0.8, 1.2))+ for (i in seq_len(control$num_points)) {
|
||
| 195 | -+ | |||
| 38 | +185x |
- #' }+ out[i, 2:3] <- c( |
||
| 196 | -+ | |||
| 39 | +185x |
- #'+ max(xs[i] - control$bandwidth, 0), |
||
| 197 | -+ | |||
| 40 | +185x |
- #' @export+ min(xs[i] + control$bandwidth, 1) |
||
| 198 | +41 |
- #' @order 2+ ) |
||
| 199 | -+ | |||
| 42 | +185x |
- tabulate_survival_biomarkers <- function(df,+ out[i, 5:6] <- stats::quantile(x, out[i, 2:3]) |
||
| 200 | -+ | |||
| 43 | +185x |
- vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
+ sel[, i] <- x >= out[i, 5] & x <= out[i, 6] |
||
| 201 | +44 |
- groups_lists = list(),+ } |
||
| 202 | +45 |
- control = control_coxreg(),+ # Center is the middle point of the percentile window. |
||
| 203 | -+ | |||
| 46 | +9x |
- label_all = lifecycle::deprecated(),+ out[, 1] <- xs[-control$num_points - 1] |
||
| 204 | -+ | |||
| 47 | +9x |
- time_unit = NULL,+ out[, 4] <- stats::quantile(x, out[, 1]) |
||
| 205 | +48 |
- na_str = default_na_str(),+ } else {
|
||
| 206 | +49 |
- .indent_mods = 0L) {
+ # Create windows according to cutoffs. |
||
| 207 | -5x | +50 | +3x |
- if (lifecycle::is_present(label_all)) {
+ m <- c(min(x), max(x)) |
| 208 | -1x | +51 | +3x |
- lifecycle::deprecate_warn(+ xs <- seq(m[1], m[2], length.out = control$num_points + 2)[-1] |
| 209 | -1x | +52 | +3x |
- "0.9.5", "tabulate_survival_biomarkers(label_all)",+ for (i in seq_len(control$num_points)) {
|
| 210 | -1x | +53 | +11x |
- details = paste(+ out[i, 2:3] <- c( |
| 211 | -1x | +54 | +11x |
- "Please assign the `label_all` parameter within the",+ max(xs[i] - control$bandwidth, m[1]), |
| 212 | -1x | +55 | +11x |
- "`extract_survival_biomarkers()` function when creating `df`."+ min(xs[i] + control$bandwidth, m[2]) |
| 213 | +56 |
) |
||
| 214 | -+ | |||
| 57 | +11x |
- )+ sel[, i] <- x >= out[i, 2] & x <= out[i, 3] |
||
| 215 | +58 |
- }+ } |
||
| 216 | +59 |
-
+ # Center is the same as the point for predicting. |
||
| 217 | -5x | +60 | +3x |
- checkmate::assert_data_frame(df)+ out[, 1] <- xs[-control$num_points - 1] |
| 218 | -5x | +|||
| 61 | +
- checkmate::assert_character(df$biomarker)+ } |
|||
| 219 | -5x | +62 | +12x |
- checkmate::assert_character(df$biomarker_label)+ list(sel = sel, interval = out) |
| 220 | -5x | +|||
| 63 | +
- checkmate::assert_subset(vars, get_stats("tabulate_survival_biomarkers"))
+ } |
|||
| 221 | +64 | |||
| 222 | -5x | +|||
| 65 | +
- extra_args <- list(groups_lists = groups_lists, control = control)+ #' @describeIn h_step Calculates the estimated treatment effect estimate |
|||
| 223 | +66 |
-
+ #' on the linear predictor scale and corresponding standard error from a STEP `model` fitted |
||
| 224 | -5x | +|||
| 67 | +
- df_subs <- split(df, f = df$biomarker)+ #' on `data` given `variables` specification, for a single biomarker value `x`. |
|||
| 225 | -5x | +|||
| 68 | +
- tabs <- lapply(df_subs, FUN = function(df_sub) {
+ #' This works for both `coxph` and `glm` models, i.e. for calculating log hazard ratio or log odds |
|||
| 226 | -9x | +|||
| 69 | +
- tab_sub <- h_tab_surv_one_biomarker(+ #' ratio estimates. |
|||
| 227 | -9x | +|||
| 70 | +
- df = df_sub,+ #' |
|||
| 228 | -9x | +|||
| 71 | +
- vars = vars,+ #' @param model (`coxph` or `glm`)\cr the regression model object. |
|||
| 229 | -9x | +|||
| 72 | +
- time_unit = time_unit,+ #' |
|||
| 230 | -9x | +|||
| 73 | +
- na_str = na_str,+ #' @return |
|||
| 231 | -9x | +|||
| 74 | +
- .indent_mods = .indent_mods,+ #' * `h_step_trt_effect()` returns a vector with elements `est` and `se`. |
|||
| 232 | -9x | +|||
| 75 | +
- extra_args = extra_args+ #' |
|||
| 233 | +76 |
- )+ #' @export |
||
| 234 | +77 |
- # Insert label row as first row in table.+ h_step_trt_effect <- function(data, |
||
| 235 | -9x | +|||
| 78 | +
- label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1]+ model, |
|||
| 236 | -9x | +|||
| 79 | +
- tab_sub+ variables, |
|||
| 237 | +80 |
- })+ x) {
|
||
| 238 | -5x | +81 | +208x |
- result <- do.call(rbind, tabs)+ checkmate::assert_multi_class(model, c("coxph", "glm"))
|
| 239 | -+ | |||
| 82 | +208x |
-
+ checkmate::assert_number(x) |
||
| 240 | -5x | +83 | +208x |
- n_tot_ids <- grep("^n_tot", vars)
+ assert_df_with_variables(data, variables) |
| 241 | -5x | +84 | +208x |
- hr_id <- match("hr", vars)
+ checkmate::assert_factor(data[[variables$arm]], n.levels = 2) |
| 242 | -5x | +|||
| 85 | +
- ci_id <- match("ci", vars)
+
|
|||
| 243 | -5x | +86 | +208x |
- structure(+ newdata <- data[c(1, 1), ] |
| 244 | -5x | +87 | +208x |
- result,+ newdata[, variables$biomarker] <- x |
| 245 | -5x | +88 | +208x |
- forest_header = paste0(c("Higher", "Lower"), "\nBetter"),
+ newdata[, variables$arm] <- levels(data[[variables$arm]]) |
| 246 | -5x | +89 | +208x |
- col_x = hr_id,+ model_terms <- stats::delete.response(stats::terms(model)) |
| 247 | -5x | +90 | +208x |
- col_ci = ci_id,+ model_frame <- stats::model.frame(model_terms, data = newdata, xlev = model$xlevels) |
| 248 | -5x | +91 | +208x |
- col_symbol_size = n_tot_ids[1]+ mat <- stats::model.matrix(model_terms, data = model_frame, contrasts.arg = model$contrasts) |
| 249 | -+ | |||
| 92 | +208x |
- )+ coefs <- stats::coef(model) |
||
| 250 | +93 |
- }+ # Note: It is important to use the coef subset from matrix, otherwise intercept and |
| 1 | +94 |
- #' Helper function for deriving analysis datasets for select laboratory tables+ # strata are included for coxph() models. |
||
| 2 | -+ | |||
| 95 | +208x |
- #'+ mat <- mat[, names(coefs)] |
||
| 3 | -+ | |||
| 96 | +208x |
- #' @description `r lifecycle::badge("stable")`
+ mat_diff <- diff(mat) |
||
| 4 | -+ | |||
| 97 | +208x |
- #'+ est <- mat_diff %*% coefs |
||
| 5 | -+ | |||
| 98 | +208x |
- #' Helper function that merges ADSL and ADLB datasets so that missing lab test records are inserted in the+ var <- mat_diff %*% stats::vcov(model) %*% t(mat_diff) |
||
| 6 | -+ | |||
| 99 | +208x |
- #' output dataset. Remember that `na_level` must match the needed pre-processing+ se <- sqrt(var) |
||
| 7 | -+ | |||
| 100 | +208x |
- #' done with [df_explicit_na()] to have the desired output.+ c( |
||
| 8 | -+ | |||
| 101 | +208x |
- #'+ est = est, |
||
| 9 | -+ | |||
| 102 | +208x |
- #' @param adsl (`data.frame`)\cr ADSL data frame.+ se = se |
||
| 10 | +103 |
- #' @param adlb (`data.frame`)\cr ADLB data frame.+ ) |
||
| 11 | +104 |
- #' @param worst_flag (named `character`)\cr worst post-baseline lab flag variable. See how this is implemented in the+ } |
||
| 12 | +105 |
- #' following examples.+ |
||
| 13 | +106 |
- #' @param by_visit (`flag`)\cr defaults to `FALSE` to generate worst grade per patient.+ #' @describeIn h_step Builds the model formula used in survival STEP calculations. |
||
| 14 | +107 |
- #' If worst grade per patient per visit is specified for `worst_flag`, then+ #' |
||
| 15 | +108 |
- #' `by_visit` should be `TRUE` to generate worst grade patient per visit.+ #' @return |
||
| 16 | +109 |
- #' @param no_fillin_visits (named `character`)\cr visits that are not considered for post-baseline worst toxicity+ #' * `h_step_survival_formula()` returns a model formula. |
||
| 17 | +110 |
- #' grade. Defaults to `c("SCREENING", "BASELINE")`.
+ #' |
||
| 18 | +111 |
- #'+ #' @export |
||
| 19 | +112 |
- #' @return `df` containing variables shared between `adlb` and `adsl` along with variables `PARAM`, `PARAMCD`,+ h_step_survival_formula <- function(variables, |
||
| 20 | +113 |
- #' `ATOXGR`, and `BTOXGR` relevant for analysis. Optionally, `AVISIT` are `AVISITN` are included when+ control = control_step()) {
|
||
| 21 | -+ | |||
| 114 | +10x |
- #' `by_visit = TRUE` and `no_fillin_visits = c("SCREENING", "BASELINE")`.
+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
||
| 22 | +115 |
- #'+ |
||
| 23 | -+ | |||
| 116 | +10x |
- #' @details In the result data missing records will be created for the following situations:+ assert_list_of_variables(variables[c("arm", "biomarker", "event", "time")])
|
||
| 24 | -+ | |||
| 117 | +10x |
- #' * Patients who are present in `adsl` but have no lab data in `adlb` (both baseline and post-baseline).+ form <- paste0("Surv(", variables$time, ", ", variables$event, ") ~ ", variables$arm)
|
||
| 25 | -+ | |||
| 118 | +10x |
- #' * Patients who do not have any post-baseline lab values.+ if (control$degree > 0) {
|
||
| 26 | -- |
- #' * Patients without any post-baseline values flagged as the worst.+ | ||
| 119 | +5x | +
+ form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
|
||
| 27 | +120 |
- #'+ } |
||
| 28 | -+ | |||
| 121 | +10x |
- #' @examples+ if (!is.null(variables$covariates)) {
|
||
| 29 | -+ | |||
| 122 | +6x |
- #' # `h_adsl_adlb_merge_using_worst_flag`+ form <- paste(form, "+", paste(variables$covariates, collapse = "+")) |
||
| 30 | +123 |
- #' adlb_out <- h_adsl_adlb_merge_using_worst_flag(+ } |
||
| 31 | -+ | |||
| 124 | +10x |
- #' tern_ex_adsl,+ if (!is.null(variables$strata)) {
|
||
| 32 | -+ | |||
| 125 | +2x |
- #' tern_ex_adlb,+ form <- paste0(form, " + strata(", paste0(variables$strata, collapse = ", "), ")")
|
||
| 33 | +126 |
- #' worst_flag = c("WGRHIFL" = "Y")
+ } |
||
| 34 | -+ | |||
| 127 | +10x |
- #' )+ stats::as.formula(form) |
||
| 35 | +128 |
- #'+ } |
||
| 36 | +129 |
- #' # `h_adsl_adlb_merge_using_worst_flag` by visit example+ |
||
| 37 | +130 |
- #' adlb_out_by_visit <- h_adsl_adlb_merge_using_worst_flag(+ #' @describeIn h_step Estimates the model with `formula` built based on |
||
| 38 | +131 |
- #' tern_ex_adsl,+ #' `variables` in `data` for a given `subset` and `control` parameters for the |
||
| 39 | +132 |
- #' tern_ex_adlb,+ #' Cox regression. |
||
| 40 | +133 |
- #' worst_flag = c("WGRLOVFL" = "Y"),
+ #' |
||
| 41 | +134 |
- #' by_visit = TRUE+ #' @param formula (`formula`)\cr the regression model formula. |
||
| 42 | +135 |
- #' )+ #' @param subset (`logical`)\cr subset vector. |
||
| 43 | +136 |
#' |
||
| 44 | +137 |
- #' @export+ #' @return |
||
| 45 | +138 |
- h_adsl_adlb_merge_using_worst_flag <- function(adsl, # nolint+ #' * `h_step_survival_est()` returns a matrix of number of observations `n`, |
||
| 46 | +139 |
- adlb,+ #' `events`, log hazard ratio estimates `loghr`, standard error `se`, |
||
| 47 | +140 |
- worst_flag = c("WGRHIFL" = "Y"),
+ #' and Wald confidence interval bounds `ci_lower` and `ci_upper`. One row is |
||
| 48 | +141 |
- by_visit = FALSE,+ #' included for each biomarker value in `x`. |
||
| 49 | +142 |
- no_fillin_visits = c("SCREENING", "BASELINE")) {
- |
- ||
| 50 | -5x | -
- col_names <- names(worst_flag)- |
- ||
| 51 | -5x | -
- filter_values <- worst_flag+ #' |
||
| 52 | +143 | - - | -||
| 53 | -5x | -
- temp <- Map(- |
- ||
| 54 | -5x | -
- function(x, y) which(adlb[[x]] == y),+ #' @export |
||
| 55 | -5x | +|||
| 144 | +
- col_names,+ h_step_survival_est <- function(formula, |
|||
| 56 | -5x | +|||
| 145 | +
- filter_values+ data, |
|||
| 57 | +146 |
- )+ variables, |
||
| 58 | +147 |
-
+ x, |
||
| 59 | -5x | +|||
| 148 | +
- position_satisfy_filters <- Reduce(intersect, temp)+ subset = rep(TRUE, nrow(data)), |
|||
| 60 | +149 |
-
+ control = control_coxph()) {
|
||
| 61 | -5x | +150 | +55x |
- adsl_adlb_common_columns <- intersect(colnames(adsl), colnames(adlb))+ checkmate::assert_formula(formula) |
| 62 | -5x | +151 | +55x |
- columns_from_adlb <- c("USUBJID", "PARAM", "PARAMCD", "AVISIT", "AVISITN", "ATOXGR", "BTOXGR")
+ assert_df_with_variables(data, variables) |
| 63 | -+ | |||
| 152 | +55x |
-
+ checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE) |
||
| 64 | -5x | +153 | +55x |
- adlb_f <- adlb[position_satisfy_filters, ] %>%+ checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) |
| 65 | -5x | +154 | +55x |
- dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits)+ checkmate::assert_list(control, names = "named") |
| 66 | -5x | +|||
| 155 | +
- adlb_f <- adlb_f[, columns_from_adlb]+ |
|||
| 67 | +156 |
-
+ # Note: `subset` in `coxph` needs to be an expression referring to `data` variables. |
||
| 68 | -5x | +157 | +55x |
- avisits_grid <- adlb %>%+ data$.subset <- subset |
| 69 | -5x | +158 | +55x |
- dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) %>%+ coxph_warnings <- NULL |
| 70 | -5x | +159 | +55x |
- dplyr::pull(.data[["AVISIT"]]) %>%+ tryCatch( |
| 71 | -5x | +160 | +55x |
- unique()+ withCallingHandlers( |
| 72 | -+ | |||
| 161 | +55x |
-
+ expr = {
|
||
| 73 | -5x | +162 | +55x |
- if (by_visit) {
+ fit <- survival::coxph( |
| 74 | -1x | +163 | +55x |
- adsl_lb <- expand.grid(+ formula = formula, |
| 75 | -1x | +164 | +55x |
- USUBJID = unique(adsl$USUBJID),+ data = data, |
| 76 | -1x | +165 | +55x |
- AVISIT = avisits_grid,+ subset = .subset, |
| 77 | -1x | +166 | +55x |
- PARAMCD = unique(adlb$PARAMCD)+ ties = control$ties |
| 78 | +167 |
- )+ ) |
||
| 79 | +168 |
-
+ }, |
||
| 80 | -1x | +169 | +55x |
- adsl_lb <- adsl_lb %>%+ warning = function(w) {
|
| 81 | +170 | 1x |
- dplyr::left_join(unique(adlb[c("AVISIT", "AVISITN")]), by = "AVISIT") %>%
+ coxph_warnings <<- c(coxph_warnings, w) |
|
| 82 | +171 | 1x |
- dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
+ invokeRestart("muffleWarning")
|
|
| 83 | +172 |
-
+ } |
||
| 84 | -1x | +|||
| 173 | +
- adsl1 <- adsl[, adsl_adlb_common_columns]+ ), |
|||
| 85 | -1x | +174 | +55x |
- adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID")+ finally = {
|
| 86 | +175 | - - | -||
| 87 | -1x | -
- by_variables_from_adlb <- c("USUBJID", "AVISIT", "AVISITN", "PARAMCD", "PARAM")
+ } |
||
| 88 | +176 |
-
+ ) |
||
| 89 | -1x | +177 | +55x |
- adlb_btoxgr <- adlb %>%+ if (!is.null(coxph_warnings)) {
|
| 90 | +178 | 1x |
- dplyr::select(c("USUBJID", "PARAMCD", "BTOXGR")) %>%
+ warning(paste( |
|
| 91 | +179 | 1x |
- unique() %>%+ "Fit warnings occurred, please consider using a simpler model, or", |
|
| 92 | +180 | 1x |
- dplyr::rename("BTOXGR_MAP" = "BTOXGR")
+ "larger `bandwidth`, less `num_points` in `control_step()` settings" |
|
| 93 | +181 | - - | -||
| 94 | -1x | -
- adlb_out <- merge(+ )) |
||
| 95 | -1x | +|||
| 182 | +
- adlb_f,+ } |
|||
| 96 | -1x | +|||
| 183 | +
- adsl_lb,+ # Produce a matrix with one row per `x` and columns `est` and `se`. |
|||
| 97 | -1x | +184 | +55x |
- by = by_variables_from_adlb,+ estimates <- t(vapply( |
| 98 | -1x | +185 | +55x |
- all = TRUE,+ X = x, |
| 99 | -1x | -
- sort = FALSE- |
- ||
| 100 | -+ | 186 | +55x |
- )+ FUN = h_step_trt_effect, |
| 101 | -1x | +187 | +55x |
- adlb_out <- adlb_out %>%+ FUN.VALUE = c(1, 2), |
| 102 | -1x | +188 | +55x |
- dplyr::left_join(adlb_btoxgr, by = c("USUBJID", "PARAMCD")) %>%
+ data = data, |
| 103 | -1x | +189 | +55x |
- dplyr::mutate(BTOXGR = .data$BTOXGR_MAP) %>%+ model = fit, |
| 104 | -1x | +190 | +55x |
- dplyr::select(-"BTOXGR_MAP")+ variables = variables |
| 105 | +191 |
-
+ )) |
||
| 106 | -1x | +192 | +55x |
- adlb_var_labels <- c(+ q_norm <- stats::qnorm((1 + control$conf_level) / 2) |
| 107 | -1x | +193 | +55x |
- formatters::var_labels(adlb[by_variables_from_adlb]),+ cbind( |
| 108 | -1x | +194 | +55x |
- formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]),+ n = fit$n, |
| 109 | -1x | +195 | +55x |
- formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]])+ events = fit$nevent, |
| 110 | -+ | |||
| 196 | +55x |
- )+ loghr = estimates[, "est"], |
||
| 111 | -+ | |||
| 197 | +55x |
- } else {
+ se = estimates[, "se"], |
||
| 112 | -4x | +198 | +55x |
- adsl_lb <- expand.grid(+ ci_lower = estimates[, "est"] - q_norm * estimates[, "se"], |
| 113 | -4x | +199 | +55x |
- USUBJID = unique(adsl$USUBJID),+ ci_upper = estimates[, "est"] + q_norm * estimates[, "se"] |
| 114 | -4x | +|||
| 200 | +
- PARAMCD = unique(adlb$PARAMCD)+ ) |
|||
| 115 | +201 |
- )+ } |
||
| 116 | +202 | |||
| 117 | -4x | +|||
| 203 | +
- adsl_lb <- adsl_lb %>% dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
+ #' @describeIn h_step Builds the model formula used in response STEP calculations. |
|||
| 118 | +204 |
-
+ #' |
||
| 119 | -4x | +|||
| 205 | +
- adsl1 <- adsl[, adsl_adlb_common_columns]+ #' @return |
|||
| 120 | -4x | +|||
| 206 | +
- adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID")+ #' * `h_step_rsp_formula()` returns a model formula. |
|||
| 121 | +207 |
-
+ #' |
||
| 122 | -4x | +|||
| 208 | +
- by_variables_from_adlb <- c("USUBJID", "PARAMCD", "PARAM")
+ #' @export |
|||
| 123 | +209 |
-
+ h_step_rsp_formula <- function(variables,+ |
+ ||
| 210 | ++ |
+ control = c(control_step(), control_logistic())) {
|
||
| 124 | -4x | +211 | +14x |
- adlb_out <- merge(+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
| 125 | -4x | +212 | +14x |
- adlb_f,+ assert_list_of_variables(variables[c("arm", "biomarker", "response")])
|
| 126 | -4x | +213 | +14x |
- adsl_lb,+ response_definition <- sub( |
| 127 | -4x | +214 | +14x |
- by = by_variables_from_adlb,+ pattern = "response", |
| 128 | -4x | +215 | +14x |
- all = TRUE,+ replacement = variables$response, |
| 129 | -4x | +216 | +14x |
- sort = FALSE+ x = control$response_definition, |
| 130 | -+ | |||
| 217 | +14x |
- )+ fixed = TRUE |
||
| 131 | +218 |
-
+ ) |
||
| 132 | -4x | +219 | +14x |
- adlb_var_labels <- c(+ form <- paste0(response_definition, " ~ ", variables$arm) |
| 133 | -4x | +220 | +14x |
- formatters::var_labels(adlb[by_variables_from_adlb]),+ if (control$degree > 0) {
|
| 134 | -4x | +221 | +8x |
- formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]),+ form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
+ |
+
| 222 | ++ |
+ } |
||
| 135 | -4x | +223 | +14x |
- formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]])+ if (!is.null(variables$covariates)) {
|
| 136 | -+ | |||
| 224 | +8x |
- )+ form <- paste(form, "+", paste(variables$covariates, collapse = "+")) |
||
| 137 | +225 |
} |
||
| 138 | -+ | |||
| 226 | +14x |
-
+ if (!is.null(variables$strata)) {
|
||
| 139 | +227 | 5x |
- adlb_out$ATOXGR <- as.factor(adlb_out$ATOXGR)+ strata_arg <- if (length(variables$strata) > 1) {
|
|
| 140 | -5x | +228 | +2x |
- adlb_out$BTOXGR <- as.factor(adlb_out$BTOXGR)+ paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
|
| 141 | +229 |
-
+ } else {
|
||
| 142 | -5x | +230 | +3x |
- formatters::var_labels(adlb_out) <- adlb_var_labels+ variables$strata |
| 143 | +231 |
-
+ } |
||
| 144 | +232 | 5x |
- adlb_out+ form <- paste0(form, "+ strata(", strata_arg, ")")
|
|
| 145 | +233 |
- }+ } |
| 1 | -+ | |||
| 234 | +14x |
- #' Count patients with marked laboratory abnormalities+ stats::as.formula(form) |
||
| 2 | +235 |
- #'+ } |
||
| 3 | +236 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 4 | +237 |
- #'+ #' @describeIn h_step Estimates the model with `formula` built based on |
||
| 5 | +238 |
- #' The analyze function [count_abnormal_by_marked()] creates a layout element to count patients with marked laboratory+ #' `variables` in `data` for a given `subset` and `control` parameters for the |
||
| 6 | +239 |
- #' abnormalities for each direction of abnormality, categorized by parameter value.+ #' logistic regression. |
||
| 7 | +240 |
#' |
||
| 8 | +241 |
- #' This function analyzes primary analysis variable `var` which indicates whether a single, replicated,+ #' @param formula (`formula`)\cr the regression model formula. |
||
| 9 | +242 |
- #' or last marked laboratory abnormality was observed. Levels of `var` to include for each marked lab+ #' @param subset (`logical`)\cr subset vector. |
||
| 10 | +243 |
- #' abnormality (`single` and `last_replicated`) can be supplied via the `category` parameter. Additional+ #' |
||
| 11 | +244 |
- #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults+ #' @return |
||
| 12 | +245 |
- #' to `USUBJID`), a variable to indicate unique subject identifiers, `param` (defaults to `PARAM`), a+ #' * `h_step_rsp_est()` returns a matrix of number of observations `n`, log odds |
||
| 13 | +246 |
- #' variable to indicate parameter values, and `direction` (defaults to `abn_dir`), a variable to indicate+ #' ratio estimates `logor`, standard error `se`, and Wald confidence interval bounds |
||
| 14 | +247 |
- #' abnormality directions.+ #' `ci_lower` and `ci_upper`. One row is included for each biomarker value in `x`. |
||
| 15 | +248 |
#' |
||
| 16 | +249 |
- #' For each combination of `param` and `direction` levels, marked lab abnormality counts are calculated+ #' @export |
||
| 17 | +250 |
- #' as follows:+ h_step_rsp_est <- function(formula, |
||
| 18 | +251 |
- #' * `Single, not last` & `Last or replicated`: The number of patients with `Single, not last`+ data, |
||
| 19 | +252 |
- #' and `Last or replicated` values, respectively.+ variables, |
||
| 20 | +253 |
- #' * `Any`: The number of patients with either single or replicated marked abnormalities.+ x, |
||
| 21 | +254 |
- #'+ subset = rep(TRUE, nrow(data)), |
||
| 22 | +255 |
- #' Fractions are calculated by dividing the above counts by the number of patients with at least one+ control = control_logistic()) {
|
||
| 23 | -+ | |||
| 256 | +58x |
- #' valid measurement recorded during the analysis.+ checkmate::assert_formula(formula) |
||
| 24 | -+ | |||
| 257 | +58x |
- #'+ assert_df_with_variables(data, variables) |
||
| 25 | -+ | |||
| 258 | +58x |
- #' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create two+ checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE) |
||
| 26 | -+ | |||
| 259 | +58x |
- #' row splits, one on variable `param` and one on variable `direction`.+ checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) |
||
| 27 | -+ | |||
| 260 | +58x |
- #'+ checkmate::assert_list(control, names = "named") |
||
| 28 | +261 |
- #' @inheritParams argument_convention+ # Note: `subset` in `glm` needs to be an expression referring to `data` variables. |
||
| 29 | -+ | |||
| 262 | +58x |
- #' @param category (`list`)\cr a list with different marked category names for single+ data$.subset <- subset |
||
| 30 | -+ | |||
| 263 | +58x |
- #' and last or replicated.+ fit_warnings <- NULL |
||
| 31 | -+ | |||
| 264 | +58x |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal_by_marked")`
+ tryCatch( |
||
| 32 | -+ | |||
| 265 | +58x |
- #' to see available statistics for this function.+ withCallingHandlers( |
||
| 33 | -+ | |||
| 266 | +58x |
- #'+ expr = {
|
||
| 34 | -+ | |||
| 267 | +58x |
- #' @note `Single, not last` and `Last or replicated` levels are mutually exclusive. If a patient has+ fit <- if (is.null(variables$strata)) {
|
||
| 35 | -+ | |||
| 268 | +54x |
- #' abnormalities that meet both the `Single, not last` and `Last or replicated` criteria, then the+ stats::glm( |
||
| 36 | -+ | |||
| 269 | +54x |
- #' patient will be counted only under the `Last or replicated` category.+ formula = formula, |
||
| 37 | -+ | |||
| 270 | +54x |
- #'+ data = data, |
||
| 38 | -+ | |||
| 271 | +54x |
- #' @name abnormal_by_marked+ subset = .subset, |
||
| 39 | -+ | |||
| 272 | +54x |
- #' @order 1+ family = stats::binomial("logit")
|
||
| 40 | +273 |
- NULL+ ) |
||
| 41 | +274 |
-
+ } else {
|
||
| 42 | +275 |
- #' @describeIn abnormal_by_marked Statistics function for patients with marked lab abnormalities.+ # clogit needs coxph and strata imported |
||
| 43 | -+ | |||
| 276 | +4x |
- #'+ survival::clogit( |
||
| 44 | -+ | |||
| 277 | +4x |
- #' @return+ formula = formula, |
||
| 45 | -+ | |||
| 278 | +4x |
- #' * `s_count_abnormal_by_marked()` returns statistic `count_fraction` with `Single, not last`,+ data = data, |
||
| 46 | -+ | |||
| 279 | +4x |
- #' `Last or replicated`, and `Any` results.+ subset = .subset |
||
| 47 | +280 |
- #'+ ) |
||
| 48 | +281 |
- #' @keywords internal+ } |
||
| 49 | +282 |
- s_count_abnormal_by_marked <- function(df,+ }, |
||
| 50 | -+ | |||
| 283 | +58x |
- .var = "AVALCAT1",+ warning = function(w) {
|
||
| 51 | -+ | |||
| 284 | +19x |
- .spl_context,+ fit_warnings <<- c(fit_warnings, w)+ |
+ ||
| 285 | +19x | +
+ invokeRestart("muffleWarning")
|
||
| 52 | +286 |
- category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
+ } |
||
| 53 | +287 |
- variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir")) {
+ ), |
||
| 54 | -3x | +288 | +58x |
- checkmate::assert_string(.var)+ finally = {
|
| 55 | -3x | +|||
| 289 | +
- checkmate::assert_list(variables)+ } |
|||
| 56 | -3x | +|||
| 290 | +
- checkmate::assert_list(category)+ ) |
|||
| 57 | -3x | -
- checkmate::assert_subset(names(category), c("single", "last_replicated"))
- |
- ||
| 58 | -3x | -
- checkmate::assert_subset(names(variables), c("id", "param", "direction"))
- |
- ||
| 59 | -3x | -
- checkmate::assert_vector(unique(df[[variables$direction]]), max.len = 1)- |
- ||
| 60 | -+ | 291 | +58x |
-
+ if (!is.null(fit_warnings)) {
|
| 61 | -2x | +292 | +13x |
- assert_df_with_variables(df, c(aval = .var, variables))+ warning(paste( |
| 62 | -2x | +293 | +13x |
- checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
+ "Fit warnings occurred, please consider using a simpler model, or", |
| 63 | -2x | +294 | +13x |
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ "larger `bandwidth`, less `num_points` in `control_step()` settings" |
| 64 | +295 |
-
+ )) |
||
| 65 | +296 | - - | -||
| 66 | -2x | -
- first_row <- .spl_context[.spl_context$split == variables[["param"]], ]+ } |
||
| 67 | +297 |
- # Patients in the denominator have at least one post-baseline visit.- |
- ||
| 68 | -2x | -
- subj <- first_row$full_parent_df[[1]][[variables[["id"]]]]+ # Produce a matrix with one row per `x` and columns `est` and `se`. |
||
| 69 | -2x | -
- subj_cur_col <- subj[first_row$cur_col_subset[[1]]]- |
- ||
| 70 | -- |
- # Some subjects may have a record for high and low directions but- |
- ||
| 71 | -+ | 298 | +58x |
- # should be counted only once.+ estimates <- t(vapply( |
| 72 | -2x | -
- denom <- length(unique(subj_cur_col))- |
- ||
| 73 | -+ | 299 | +58x |
-
+ X = x, |
| 74 | -2x | +300 | +58x |
- if (denom != 0) {
+ FUN = h_step_trt_effect, |
| 75 | -2x | +301 | +58x |
- subjects_last_replicated <- unique(+ FUN.VALUE = c(1, 2), |
| 76 | -2x | -
- df[df[[.var]] %in% category[["last_replicated"]], variables$id, drop = TRUE]- |
- ||
| 77 | -+ | 302 | +58x |
- )+ data = data, |
| 78 | -2x | +303 | +58x |
- subjects_single <- unique(+ model = fit, |
| 79 | -2x | -
- df[df[[.var]] %in% category[["single"]], variables$id, drop = TRUE]- |
- ||
| 80 | -+ | 304 | +58x |
- )+ variables = variables |
| 81 | +305 |
- # Subjects who have both single and last/replicated abnormalities are counted in only the last/replicated group.- |
- ||
| 82 | -2x | -
- subjects_single <- setdiff(subjects_single, subjects_last_replicated)+ )) |
||
| 83 | -2x | +306 | +58x |
- n_single <- length(subjects_single)+ q_norm <- stats::qnorm((1 + control$conf_level) / 2) |
| 84 | -2x | +307 | +58x |
- n_last_replicated <- length(subjects_last_replicated)+ cbind( |
| 85 | -2x | +308 | +58x |
- n_any <- n_single + n_last_replicated+ n = length(fit$y), |
| 86 | -2x | +309 | +58x |
- result <- list(count_fraction = list(+ logor = estimates[, "est"], |
| 87 | -2x | +310 | +58x |
- "Single, not last" = c(n_single, n_single / denom),+ se = estimates[, "se"], |
| 88 | -2x | +311 | +58x |
- "Last or replicated" = c(n_last_replicated, n_last_replicated / denom),+ ci_lower = estimates[, "est"] - q_norm * estimates[, "se"], |
| 89 | -2x | +312 | +58x |
- "Any Abnormality" = c(n_any, n_any / denom)+ ci_upper = estimates[, "est"] + q_norm * estimates[, "se"] |
| 90 | +313 |
- ))+ ) |
||
| 91 | +314 |
- } else {
- |
- ||
| 92 | -! | -
- result <- list(count_fraction = list(- |
- ||
| 93 | -! | -
- "Single, not last" = c(0, 0),- |
- ||
| 94 | -! | -
- "Last or replicated" = c(0, 0),- |
- ||
| 95 | -! | -
- "Any Abnormality" = c(0, 0)+ } |
| 96 | +1 |
- ))+ #' Confidence intervals for a difference of binomials |
||
| 97 | +2 |
- }+ #' |
||
| 98 | +3 | - - | -||
| 99 | -2x | -
- result+ #' @description `r lifecycle::badge("experimental")`
|
||
| 100 | +4 |
- }+ #' |
||
| 101 | +5 |
-
+ #' Several confidence intervals for the difference between proportions. |
||
| 102 | +6 |
- #' @describeIn abnormal_by_marked Formatted analysis function which is used as `afun`+ #' |
||
| 103 | +7 |
- #' in `count_abnormal_by_marked()`.+ #' @name desctools_binom |
||
| 104 | +8 |
- #'+ NULL |
||
| 105 | +9 |
- #' @return+ |
||
| 106 | +10 |
- #' * `a_count_abnormal_by_marked()` returns the corresponding list with formatted [rtables::CellValue()].+ #' Recycle list of parameters |
||
| 107 | +11 |
#' |
||
| 108 | +12 |
- #' @keywords internal+ #' This function recycles all supplied elements to the maximal dimension. |
||
| 109 | +13 |
- a_count_abnormal_by_marked <- make_afun(+ #' |
||
| 110 | +14 |
- s_count_abnormal_by_marked,+ #' @param ... (`any`)\cr elements to recycle. |
||
| 111 | +15 |
- .formats = c(count_fraction = format_count_fraction)+ #' |
||
| 112 | +16 |
- )+ #' @return A `list`. |
||
| 113 | +17 |
-
+ #' |
||
| 114 | +18 |
- #' @describeIn abnormal_by_marked Layout-creating function which can take statistics function arguments+ #' @keywords internal |
||
| 115 | +19 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' @noRd |
||
| 116 | +20 |
- #'+ h_recycle <- function(...) {
|
||
| 117 | -+ | |||
| 21 | +78x |
- #' @return+ lst <- list(...) |
||
| 118 | -+ | |||
| 22 | +78x |
- #' * `count_abnormal_by_marked()` returns a layout object suitable for passing to further layouting functions,+ maxdim <- max(lengths(lst)) |
||
| 119 | -+ | |||
| 23 | +78x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ res <- lapply(lst, rep, length.out = maxdim) |
||
| 120 | -+ | |||
| 24 | +78x |
- #' the statistics from `s_count_abnormal_by_marked()` to the table layout.+ attr(res, "maxdim") <- maxdim |
||
| 121 | -+ | |||
| 25 | +78x |
- #'+ return(res) |
||
| 122 | +26 |
- #' @examples+ } |
||
| 123 | +27 |
- #' library(dplyr)+ |
||
| 124 | +28 |
- #'+ #' @describeIn desctools_binom Several confidence intervals for the difference between proportions. |
||
| 125 | +29 |
- #' df <- data.frame(+ #' |
||
| 126 | +30 |
- #' USUBJID = as.character(c(rep(1, 5), rep(2, 5), rep(1, 5), rep(2, 5))),+ #' @return A `matrix` of 3 values: |
||
| 127 | +31 |
- #' ARMCD = factor(c(rep("ARM A", 5), rep("ARM B", 5), rep("ARM A", 5), rep("ARM B", 5))),
+ #' * `est`: estimate of proportion difference. |
||
| 128 | +32 |
- #' ANRIND = factor(c(+ #' * `lwr.ci`: estimate of lower end of the confidence interval. |
||
| 129 | +33 |
- #' "NORMAL", "HIGH", "HIGH", "HIGH HIGH", "HIGH",+ #' * `upr.ci`: estimate of upper end of the confidence interval. |
||
| 130 | +34 |
- #' "HIGH", "HIGH", "HIGH HIGH", "NORMAL", "HIGH HIGH", "NORMAL", "LOW", "LOW", "LOW LOW", "LOW",+ #' |
||
| 131 | +35 |
- #' "LOW", "LOW", "LOW LOW", "NORMAL", "LOW LOW"+ #' @keywords internal |
||
| 132 | +36 |
- #' )),+ desctools_binom <- function(x1, |
||
| 133 | +37 |
- #' ONTRTFL = rep(c("", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y"), 2),
+ n1, |
||
| 134 | +38 |
- #' PARAMCD = factor(c(rep("CRP", 10), rep("ALT", 10))),
+ x2, |
||
| 135 | +39 |
- #' AVALCAT1 = factor(rep(c("", "", "", "SINGLE", "REPLICATED", "", "", "LAST", "", "SINGLE"), 2)),
+ n2, |
||
| 136 | +40 |
- #' stringsAsFactors = FALSE+ conf.level = 0.95, # nolint |
||
| 137 | +41 |
- #' )+ sides = c("two.sided", "left", "right"),
|
||
| 138 | +42 |
- #'+ method = c( |
||
| 139 | +43 |
- #' df <- df %>%+ "ac", "wald", "waldcc", "score", "scorecc", "mn", "mee", "blj", "ha", "hal", "jp" |
||
| 140 | +44 |
- #' mutate(abn_dir = factor(+ )) {
|
||
| 141 | -+ | |||
| 45 | +26x |
- #' case_when(+ if (missing(sides)) {
|
||
| 142 | -+ | |||
| 46 | +26x |
- #' ANRIND == "LOW LOW" ~ "Low",+ sides <- match.arg(sides) |
||
| 143 | +47 |
- #' ANRIND == "HIGH HIGH" ~ "High",+ } |
||
| 144 | -+ | |||
| 48 | +26x |
- #' TRUE ~ ""+ if (missing(method)) {
|
||
| 145 | -+ | |||
| 49 | +1x |
- #' ),+ method <- match.arg(method) |
||
| 146 | +50 |
- #' levels = c("Low", "High")
+ } |
||
| 147 | -+ | |||
| 51 | +26x |
- #' ))+ iBinomDiffCI <- function(x1, n1, x2, n2, conf.level, sides, method) { # nolint
|
||
| 148 | -+ | |||
| 52 | +26x |
- #'+ if (sides != "two.sided") {
|
||
| 149 | -+ | |||
| 53 | +! |
- #' # Select only post-baseline records.+ conf.level <- 1 - 2 * (1 - conf.level) # nolint |
||
| 150 | +54 |
- #' df <- df %>% filter(ONTRTFL == "Y")+ } |
||
| 151 | -+ | |||
| 55 | +26x |
- #' df_crp <- df %>%+ alpha <- 1 - conf.level |
||
| 152 | -+ | |||
| 56 | +26x |
- #' filter(PARAMCD == "CRP") %>%+ kappa <- stats::qnorm(1 - alpha / 2) |
||
| 153 | -+ | |||
| 57 | +26x |
- #' droplevels()+ p1_hat <- x1 / n1 |
||
| 154 | -+ | |||
| 58 | +26x |
- #' full_parent_df <- list(df_crp, "not_needed")+ p2_hat <- x2 / n2 |
||
| 155 | -+ | |||
| 59 | +26x |
- #' cur_col_subset <- list(rep(TRUE, nrow(df_crp)), "not_needed")+ est <- p1_hat - p2_hat |
||
| 156 | -+ | |||
| 60 | +26x |
- #' spl_context <- data.frame(+ switch(method, |
||
| 157 | -+ | |||
| 61 | +26x |
- #' split = c("PARAMCD", "GRADE_DIR"),
+ wald = {
|
||
| 158 | -+ | |||
| 62 | +4x |
- #' full_parent_df = I(full_parent_df),+ vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2 |
||
| 159 | -+ | |||
| 63 | +4x |
- #' cur_col_subset = I(cur_col_subset)+ term2 <- kappa * sqrt(vd) |
||
| 160 | -+ | |||
| 64 | +4x |
- #' )+ ci_lwr <- max(-1, est - term2) |
||
| 161 | -+ | |||
| 65 | +4x |
- #'+ ci_upr <- min(1, est + term2) |
||
| 162 | +66 |
- #' map <- unique(+ }, |
||
| 163 | -+ | |||
| 67 | +26x |
- #' df[df$abn_dir %in% c("Low", "High") & df$AVALCAT1 != "", c("PARAMCD", "abn_dir")]
+ waldcc = {
|
||
| 164 | -+ | |||
| 68 | +6x |
- #' ) %>%+ vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2 |
||
| 165 | -+ | |||
| 69 | +6x |
- #' lapply(as.character) %>%+ term2 <- kappa * sqrt(vd) |
||
| 166 | -+ | |||
| 70 | +6x |
- #' as.data.frame() %>%+ term2 <- term2 + 0.5 * (1 / n1 + 1 / n2) |
||
| 167 | -+ | |||
| 71 | +6x |
- #' arrange(PARAMCD, abn_dir)+ ci_lwr <- max(-1, est - term2) |
||
| 168 | -+ | |||
| 72 | +6x |
- #'+ ci_upr <- min(1, est + term2) |
||
| 169 | +73 |
- #' basic_table() %>%+ }, |
||
| 170 | -+ | |||
| 74 | +26x |
- #' split_cols_by("ARMCD") %>%
+ ac = {
|
||
| 171 | -+ | |||
| 75 | +2x |
- #' split_rows_by("PARAMCD") %>%
+ n1 <- n1 + 2 |
||
| 172 | -+ | |||
| 76 | +2x |
- #' summarize_num_patients(+ n2 <- n2 + 2 |
||
| 173 | -+ | |||
| 77 | +2x |
- #' var = "USUBJID",+ x1 <- x1 + 1 |
||
| 174 | -+ | |||
| 78 | +2x |
- #' .stats = "unique_count"+ x2 <- x2 + 1 |
||
| 175 | -+ | |||
| 79 | +2x |
- #' ) %>%+ p1_hat <- x1 / n1 |
||
| 176 | -+ | |||
| 80 | +2x |
- #' split_rows_by(+ p2_hat <- x2 / n2 |
||
| 177 | -+ | |||
| 81 | +2x |
- #' "abn_dir",+ est1 <- p1_hat - p2_hat |
||
| 178 | -+ | |||
| 82 | +2x |
- #' split_fun = trim_levels_to_map(map)+ vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2 |
||
| 179 | -+ | |||
| 83 | +2x |
- #' ) %>%+ term2 <- kappa * sqrt(vd) |
||
| 180 | -+ | |||
| 84 | +2x |
- #' count_abnormal_by_marked(+ ci_lwr <- max(-1, est1 - term2) |
||
| 181 | -+ | |||
| 85 | +2x |
- #' var = "AVALCAT1",+ ci_upr <- min(1, est1 + term2) |
||
| 182 | +86 |
- #' variables = list(+ }, |
||
| 183 | -+ | |||
| 87 | +26x |
- #' id = "USUBJID",+ exact = {
|
||
| 184 | -+ | |||
| 88 | +! |
- #' param = "PARAMCD",+ ci_lwr <- NA |
||
| 185 | -+ | |||
| 89 | +! |
- #' direction = "abn_dir"+ ci_upr <- NA |
||
| 186 | +90 |
- #' )+ }, |
||
| 187 | -+ | |||
| 91 | +26x |
- #' ) %>%+ score = {
|
||
| 188 | -+ | |||
| 92 | +3x |
- #' build_table(df = df)+ w1 <- desctools_binomci( |
||
| 189 | -+ | |||
| 93 | +3x |
- #'+ x = x1, n = n1, conf.level = conf.level, |
||
| 190 | -+ | |||
| 94 | +3x |
- #' basic_table() %>%+ method = "wilson" |
||
| 191 | +95 |
- #' split_cols_by("ARMCD") %>%
+ ) |
||
| 192 | -+ | |||
| 96 | +3x |
- #' split_rows_by("PARAMCD") %>%
+ w2 <- desctools_binomci( |
||
| 193 | -+ | |||
| 97 | +3x |
- #' summarize_num_patients(+ x = x2, n = n2, conf.level = conf.level, |
||
| 194 | -+ | |||
| 98 | +3x |
- #' var = "USUBJID",+ method = "wilson" |
||
| 195 | +99 |
- #' .stats = "unique_count"+ ) |
||
| 196 | -+ | |||
| 100 | +3x |
- #' ) %>%+ l1 <- w1[2] |
||
| 197 | -+ | |||
| 101 | +3x |
- #' split_rows_by(+ u1 <- w1[3] |
||
| 198 | -+ | |||
| 102 | +3x |
- #' "abn_dir",+ l2 <- w2[2] |
||
| 199 | -+ | |||
| 103 | +3x |
- #' split_fun = trim_levels_in_group("abn_dir")
+ u2 <- w2[3] |
||
| 200 | -+ | |||
| 104 | +3x |
- #' ) %>%+ ci_lwr <- est - kappa * sqrt(l1 * (1 - l1) / n1 + u2 * (1 - u2) / n2) |
||
| 201 | -+ | |||
| 105 | +3x |
- #' count_abnormal_by_marked(+ ci_upr <- est + kappa * sqrt(u1 * (1 - u1) / n1 + l2 * (1 - l2) / n2) |
||
| 202 | +106 |
- #' var = "AVALCAT1",+ }, |
||
| 203 | -+ | |||
| 107 | +26x |
- #' variables = list(+ scorecc = {
|
||
| 204 | -+ | |||
| 108 | +1x |
- #' id = "USUBJID",+ w1 <- desctools_binomci( |
||
| 205 | -+ | |||
| 109 | +1x |
- #' param = "PARAMCD",+ x = x1, n = n1, conf.level = conf.level, |
||
| 206 | -+ | |||
| 110 | +1x |
- #' direction = "abn_dir"+ method = "wilsoncc" |
||
| 207 | +111 |
- #' )+ ) |
||
| 208 | -+ | |||
| 112 | +1x |
- #' ) %>%+ w2 <- desctools_binomci( |
||
| 209 | -+ | |||
| 113 | +1x |
- #' build_table(df = df)+ x = x2, n = n2, conf.level = conf.level, |
||
| 210 | -+ | |||
| 114 | +1x |
- #'+ method = "wilsoncc" |
||
| 211 | +115 |
- #' @export+ ) |
||
| 212 | -+ | |||
| 116 | +1x |
- #' @order 2+ l1 <- w1[2] |
||
| 213 | -+ | |||
| 117 | +1x |
- count_abnormal_by_marked <- function(lyt,+ u1 <- w1[3] |
||
| 214 | -+ | |||
| 118 | +1x |
- var,+ l2 <- w2[2] |
||
| 215 | -+ | |||
| 119 | +1x |
- category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
+ u2 <- w2[3] |
||
| 216 | -+ | |||
| 120 | +1x |
- variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir"),+ ci_lwr <- max(-1, est - sqrt((p1_hat - l1)^2 + (u2 - p2_hat)^2)) |
||
| 217 | -+ | |||
| 121 | +1x |
- na_str = default_na_str(),+ ci_upr <- min(1, est + sqrt((u1 - p1_hat)^2 + (p2_hat - l2)^2)) |
||
| 218 | +122 |
- nested = TRUE,+ }, |
||
| 219 | -+ | |||
| 123 | +26x |
- ...,+ mee = {
|
||
| 220 | -+ | |||
| 124 | +1x |
- .stats = NULL,+ .score <- function(p1, n1, p2, n2, dif) {
+ |
+ ||
| 125 | +! | +
+ if (dif > 1) dif <- 1+ |
+ ||
| 126 | +! | +
+ if (dif < -1) dif <- -1+ |
+ ||
| 127 | +24x | +
+ diff <- p1 - p2 - dif+ |
+ ||
| 128 | +24x | +
+ if (abs(diff) == 0) {
+ |
+ ||
| 129 | +! | +
+ res <- 0 |
||
| 221 | +130 |
- .formats = NULL,+ } else {
+ |
+ ||
| 131 | +24x | +
+ t <- n2 / n1+ |
+ ||
| 132 | +24x | +
+ a <- 1 + t+ |
+ ||
| 133 | +24x | +
+ b <- -(1 + t + p1 + t * p2 + dif * (t + 2))+ |
+ ||
| 134 | +24x | +
+ c <- dif * dif + dif * (2 * p1 + t + 1) + p1 + t * p2+ |
+ ||
| 135 | +24x | +
+ d <- -p1 * dif * (1 + dif)+ |
+ ||
| 136 | +24x | +
+ v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2+ |
+ ||
| 137 | +24x | +
+ if (abs(v) < .Machine$double.eps) v <- 0+ |
+ ||
| 138 | +24x | +
+ s <- sqrt((b / a / 3)^2 - c / a / 3)+ |
+ ||
| 139 | +24x | +
+ u <- ifelse(v > 0, 1, -1) * s+ |
+ ||
| 140 | +24x | +
+ w <- (3.141592654 + acos(v / u^3)) / 3+ |
+ ||
| 141 | +24x | +
+ p1d <- 2 * u * cos(w) - b / a / 3+ |
+ ||
| 142 | +24x | +
+ p2d <- p1d - dif+ |
+ ||
| 143 | +24x | +
+ n <- n1 + n2+ |
+ ||
| 144 | +24x | +
+ res <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2) |
||
| 222 | +145 |
- .labels = NULL,+ }+ |
+ ||
| 146 | +24x | +
+ return(sqrt(res)) |
||
| 223 | +147 |
- .indent_mods = NULL) {
+ } |
||
| 224 | +148 | 1x |
- checkmate::assert_string(var)+ pval <- function(delta) {
+ |
+ |
| 149 | +24x | +
+ z <- (est - delta) / .score(p1_hat, n1, p2_hat, n2, delta)+ |
+ ||
| 150 | +24x | +
+ 2 * min(stats::pnorm(z), 1 - stats::pnorm(z)) |
||
| 225 | +151 |
-
+ } |
||
| 226 | +152 | 1x |
- extra_args <- list(category = category, variables = variables, ...)+ ci_lwr <- max(-1, stats::uniroot(function(delta) {
+ |
+ |
| 153 | +12x | +
+ pval(delta) - alpha+ |
+ ||
| 154 | +1x | +
+ }, interval = c(-1 + 1e-06, est - 1e-06))$root)+ |
+ ||
| 155 | +1x | +
+ ci_upr <- min(1, stats::uniroot(function(delta) {
+ |
+ ||
| 156 | +12x | +
+ pval(delta) - alpha+ |
+ ||
| 157 | +1x | +
+ }, interval = c(est + 1e-06, 1 - 1e-06))$root) |
||
| 227 | +158 |
-
+ }, |
||
| 228 | +159 | +26x | +
+ blj = {
+ |
+ |
| 160 | 1x |
- afun <- make_afun(+ p1_dash <- (x1 + 0.5) / (n1 + 1) |
||
| 229 | +161 | 1x |
- a_count_abnormal_by_marked,+ p2_dash <- (x2 + 0.5) / (n2 + 1) |
|
| 230 | +162 | 1x |
- .stats = .stats,+ vd <- p1_dash * (1 - p1_dash) / n1 + p2_dash * (1 - p2_dash) / n2 |
|
| 231 | +163 | 1x |
- .formats = .formats,+ term2 <- kappa * sqrt(vd) |
|
| 232 | +164 | 1x |
- .labels = .labels,+ est_dash <- p1_dash - p2_dash |
|
| 233 | +165 | 1x |
- .indent_mods = .indent_mods,+ ci_lwr <- max(-1, est_dash - term2) |
|
| 234 | +166 | 1x |
- .ungroup_stats = "count_fraction"+ ci_upr <- min(1, est_dash + term2) |
|
| 235 | +167 |
- )+ },+ |
+ ||
| 168 | +26x | +
+ ha = {
+ |
+ ||
| 169 | +5x | +
+ term2 <- 1 /+ |
+ ||
| 170 | +5x | +
+ (2 * min(n1, n2)) + kappa * sqrt(p1_hat * (1 - p1_hat) / (n1 - 1) + p2_hat * (1 - p2_hat) / (n2 - 1))+ |
+ ||
| 171 | +5x | +
+ ci_lwr <- max(-1, est - term2)+ |
+ ||
| 172 | +5x | +
+ ci_upr <- min(1, est + term2) |
||
| 236 | +173 |
-
+ }, |
||
| 237 | -1x | +174 | +26x |
- lyt <- analyze(+ mn = {
|
| 238 | +175 | 1x |
- lyt = lyt,+ .conf <- function(x1, n1, x2, n2, z, lower = FALSE) {
|
|
| 239 | -1x | +176 | +2x |
- vars = var,+ p1 <- x1 / n1 |
| 240 | -1x | +177 | +2x |
- afun = afun,+ p2 <- x2 / n2 |
| 241 | -1x | +178 | +2x |
- na_str = na_str,+ p_hat <- p1 - p2 |
| 242 | -1x | +179 | +2x |
- nested = nested,+ dp <- 1 + ifelse(lower, 1, -1) * p_hat |
| 243 | -1x | +180 | +2x |
- show_labels = "hidden",+ i <- 1 |
| 244 | -1x | +181 | +2x |
- extra_args = extra_args+ while (i <= 50) {
|
| 245 | -+ | |||
| 182 | +46x |
- )+ dp <- 0.5 * dp |
||
| 246 | -1x | +183 | +46x |
- lyt+ y <- p_hat + ifelse(lower, -1, 1) * dp |
| 247 | -+ | |||
| 184 | +46x |
- }+ score <- .score(p1, n1, p2, n2, y) |
| 1 | -+ | |||
| 185 | +46x |
- #' Formatting functions+ if (score < z) {
|
||
| 2 | -+ | |||
| 186 | +20x |
- #'+ p_hat <- y |
||
| 3 | +187 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 4 | -+ | |||
| 188 | +46x |
- #'+ if ((dp < 1e-07) || (abs(z - score) < 1e-06)) {
|
||
| 5 | -+ | |||
| 189 | +2x |
- #' See below for the list of formatting functions created in `tern` to work with `rtables`.+ (break)() |
||
| 6 | +190 |
- #'+ } else {
|
||
| 7 | -+ | |||
| 191 | +44x |
- #' Other available formats can be listed via [`formatters::list_valid_format_labels()`]. Additional+ i <- i + 1 |
||
| 8 | +192 |
- #' custom formats can be created via the [`formatters::sprintf_format()`] function.+ } |
||
| 9 | +193 |
- #'+ } |
||
| 10 | -+ | |||
| 194 | +2x |
- #' @family formatting functions+ return(y) |
||
| 11 | +195 |
- #' @name formatting_functions+ } |
||
| 12 | -+ | |||
| 196 | +1x |
- NULL+ .score <- function(p1, n1, p2, n2, dif) {
|
||
| 13 | -+ | |||
| 197 | +46x |
-
+ diff <- p1 - p2 - dif |
||
| 14 | -+ | |||
| 198 | +46x |
- #' Format fraction and percentage+ if (abs(diff) == 0) {
|
||
| 15 | -+ | |||
| 199 | +! |
- #'+ res <- 0 |
||
| 16 | +200 |
- #' @description `r lifecycle::badge("stable")`
+ } else {
|
||
| 17 | -+ | |||
| 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 |
||
| 18 | +215 |
- #' Formats a fraction together with ratio in percent.+ }+ |
+ ||
| 216 | +46x | +
+ return(res) |
||
| 19 | +217 |
- #'+ }+ |
+ ||
| 218 | +1x | +
+ z <- stats::qchisq(conf.level, 1)+ |
+ ||
| 219 | +1x | +
+ ci_lwr <- max(-1, .conf(x1, n1, x2, n2, z, TRUE))+ |
+ ||
| 220 | +1x | +
+ ci_upr <- min(1, .conf(x1, n1, x2, n2, z, FALSE)) |
||
| 20 | +221 |
- #' @param x (named `integer`)\cr vector with elements `num` and `denom`.+ },+ |
+ ||
| 222 | +26x | +
+ beal = {
+ |
+ ||
| 223 | +! | +
+ a <- p1_hat + p2_hat+ |
+ ||
| 224 | +! | +
+ b <- p1_hat - p2_hat+ |
+ ||
| 225 | +! | +
+ u <- ((1 / n1) + (1 / n2)) / 4+ |
+ ||
| 226 | +! | +
+ v <- ((1 / n1) - (1 / n2)) / 4+ |
+ ||
| 227 | +! | +
+ V <- u * ((2 - a) * a - b^2) + 2 * v * (1 - a) * b # nolint+ |
+ ||
| 228 | +! | +
+ z <- stats::qchisq(p = 1 - alpha / 2, df = 1)+ |
+ ||
| 229 | +! | +
+ A <- sqrt(z * (V + z * u^2 * (2 - a) * a + z * v^2 * (1 - a)^2)) # nolint+ |
+ ||
| 230 | +! | +
+ B <- (b + z * v * (1 - a)) / (1 + z * u) # nolint+ |
+ ||
| 231 | +! | +
+ ci_lwr <- max(-1, B - A / (1 + z * u))+ |
+ ||
| 232 | +! | +
+ ci_upr <- min(1, B + A / (1 + z * u)) |
||
| 21 | +233 |
- #' @param ... not used. Required for `rtables` interface.+ },+ |
+ ||
| 234 | +26x | +
+ hal = {
+ |
+ ||
| 235 | +1x | +
+ psi <- (p1_hat + p2_hat) / 2+ |
+ ||
| 236 | +1x | +
+ u <- (1 / n1 + 1 / n2) / 4+ |
+ ||
| 237 | +1x | +
+ v <- (1 / n1 - 1 / n2) / 4+ |
+ ||
| 238 | +1x | +
+ z <- kappa+ |
+ ||
| 239 | +1x | +
+ theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 * psi)) / (1 + z^2 * u)+ |
+ ||
| 240 | +1x | +
+ w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) - (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) *+ |
+ ||
| 241 | +1x | +
+ (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) * psi + z^2 * v^2 * (1 - 2 * psi)^2) # nolint+ |
+ ||
| 242 | +1x | +
+ c(theta + w, theta - w)+ |
+ ||
| 243 | +1x | +
+ ci_lwr <- max(-1, theta - w)+ |
+ ||
| 244 | +1x | +
+ ci_upr <- min(1, theta + w) |
||
| 22 | +245 |
- #'+ },+ |
+ ||
| 246 | +26x | +
+ jp = {
+ |
+ ||
| 247 | +1x | +
+ psi <- 0.5 * ((x1 + 0.5) / (n1 + 1) + (x2 + 0.5) / (n2 + 1))+ |
+ ||
| 248 | +1x | +
+ u <- (1 / n1 + 1 / n2) / 4+ |
+ ||
| 249 | +1x | +
+ v <- (1 / n1 - 1 / n2) / 4+ |
+ ||
| 250 | +1x | +
+ z <- kappa+ |
+ ||
| 251 | +1x | +
+ theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 * psi)) / (1 + z^2 * u)+ |
+ ||
| 252 | +1x | +
+ w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) - (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) *+ |
+ ||
| 253 | +1x | +
+ (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) * psi + z^2 * v^2 * (1 - 2 * psi)^2) # nolint+ |
+ ||
| 254 | +1x | +
+ c(theta + w, theta - w)+ |
+ ||
| 255 | +1x | +
+ ci_lwr <- max(-1, theta - w)+ |
+ ||
| 256 | +1x | +
+ ci_upr <- min(1, theta + w) |
||
| 23 | +257 |
- #' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`.+ }, |
||
| 24 | +258 |
- #'+ )+ |
+ ||
| 259 | +26x | +
+ ci <- c(+ |
+ ||
| 260 | +26x | +
+ est = est, lwr.ci = min(ci_lwr, ci_upr),+ |
+ ||
| 261 | +26x | +
+ upr.ci = max(ci_lwr, ci_upr) |
||
| 25 | +262 |
- #' @examples+ )+ |
+ ||
| 263 | +26x | +
+ if (sides == "left") {
+ |
+ ||
| 264 | +! | +
+ ci[3] <- 1+ |
+ ||
| 265 | +26x | +
+ } else if (sides == "right") {
+ |
+ ||
| 266 | +! | +
+ ci[2] <- -1 |
||
| 26 | +267 |
- #' format_fraction(x = c(num = 2L, denom = 3L))+ }+ |
+ ||
| 268 | +26x | +
+ return(ci) |
||
| 27 | +269 |
- #' format_fraction(x = c(num = 0L, denom = 3L))+ }+ |
+ ||
| 270 | +26x | +
+ method <- match.arg(arg = method, several.ok = TRUE)+ |
+ ||
| 271 | +26x | +
+ sides <- match.arg(arg = sides, several.ok = TRUE)+ |
+ ||
| 272 | +26x | +
+ lst <- h_recycle(+ |
+ ||
| 273 | +26x | +
+ x1 = x1, n1 = n1, x2 = x2, n2 = n2, conf.level = conf.level,+ |
+ ||
| 274 | +26x | +
+ sides = sides, method = method |
||
| 28 | +275 |
- #'+ )+ |
+ ||
| 276 | +26x | +
+ res <- t(sapply(1:attr(lst, "maxdim"), function(i) {
+ |
+ ||
| 277 | +26x | +
+ iBinomDiffCI(+ |
+ ||
| 278 | +26x | +
+ x1 = lst$x1[i],+ |
+ ||
| 279 | +26x | +
+ n1 = lst$n1[i], x2 = lst$x2[i], n2 = lst$n2[i], conf.level = lst$conf.level[i],+ |
+ ||
| 280 | +26x | +
+ sides = lst$sides[i], method = lst$method[i] |
||
| 29 | +281 |
- #' @family formatting functions+ ) |
||
| 30 | +282 |
- #' @export+ }))+ |
+ ||
| 283 | +26x | +
+ lgn <- h_recycle(x1 = if (is.null(names(x1))) {
+ |
+ ||
| 284 | +26x | +
+ paste("x1", seq_along(x1), sep = ".")
|
||
| 31 | +285 |
- format_fraction <- function(x, ...) {
+ } else {
+ |
+ ||
| 286 | +! | +
+ names(x1) |
||
| 32 | -4x | +287 | +26x |
- attr(x, "label") <- NULL+ }, n1 = if (is.null(names(n1))) {
+ |
+
| 288 | +26x | +
+ paste("n1", seq_along(n1), sep = ".")
|
||
| 33 | +289 |
-
+ } else {
|
||
| 34 | -4x | +|||
| 290 | +! |
- checkmate::assert_vector(x)+ names(n1) |
||
| 35 | -4x | +291 | +26x |
- checkmate::assert_count(x["num"])+ }, x2 = if (is.null(names(x2))) {
|
| 36 | -2x | +292 | +26x |
- checkmate::assert_count(x["denom"])+ paste("x2", seq_along(x2), sep = ".")
|
| 37 | +293 |
-
+ } else {
+ |
+ ||
| 294 | +! | +
+ names(x2) |
||
| 38 | -2x | +295 | +26x |
- result <- if (x["num"] == 0) {
+ }, n2 = if (is.null(names(n2))) {
|
| 39 | -1x | +296 | +26x |
- paste0(x["num"], "/", x["denom"])+ paste("n2", seq_along(n2), sep = ".")
|
| 40 | +297 |
} else {
|
||
| 298 | +! | +
+ names(n2)+ |
+ ||
| 41 | -1x | +299 | +26x |
- paste0(+ }, conf.level = conf.level, sides = sides, method = method) |
| 42 | -1x | +300 | +26x |
- x["num"], "/", x["denom"],+ xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
|
| 43 | -1x | +301 | +182x |
- " (", round(x["num"] / x["denom"] * 100, 1), "%)"
+ length(unique(x)) !=+ |
+
| 302 | +182x | +
+ 1+ |
+ ||
| 303 | +26x | +
+ })]), 1, paste, collapse = ":")+ |
+ ||
| 304 | +26x | +
+ rownames(res) <- xn+ |
+ ||
| 305 | +26x | +
+ return(res) |
||
| 44 | +306 |
- )+ } |
||
| 45 | +307 |
- }+ |
||
| 46 | +308 |
-
+ #' @describeIn desctools_binom Compute confidence intervals for binomial proportions. |
||
| 47 | -2x | +|||
| 309 | +
- return(result)+ #' |
|||
| 48 | +310 |
- }+ #' @param x (`integer(1)`)\cr number of successes. |
||
| 49 | +311 |
-
+ #' @param n (`integer(1)`)\cr number of trials. |
||
| 50 | +312 |
- #' Format fraction and percentage with fixed single decimal place+ #' @param conf.level (`proportion`)\cr confidence level, defaults to 0.95. |
||
| 51 | +313 |
- #'+ #' @param sides (`string`)\cr side of the confidence interval to compute. Must be one of `"two-sided"` (default), |
||
| 52 | +314 |
- #' @description `r lifecycle::badge("stable")`
+ #' `"left"`, or `"right"`. |
||
| 53 | +315 |
- #'+ #' @param method (`string`)\cr method to use. Can be one out of: `"wald"`, `"wilson"`, `"wilsoncc"`, |
||
| 54 | +316 |
- #' Formats a fraction together with ratio in percent with fixed single decimal place.+ #' `"agresti-coull"`, `"jeffreys"`, `"modified wilson"`, `"modified jeffreys"`, `"clopper-pearson"`, `"arcsine"`, |
||
| 55 | +317 |
- #' Includes trailing zero in case of whole number percentages to always keep one decimal place.+ #' `"logit"`, `"witting"`, `"pratt"`, `"midp"`, `"lik"`, and `"blaker"`. |
||
| 56 | +318 |
#' |
||
| 57 | +319 |
- #' @inheritParams format_fraction+ #' @return A `matrix` with 3 columns containing: |
||
| 58 | +320 |
- #'+ #' * `est`: estimate of proportion difference. |
||
| 59 | +321 |
- #' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`.+ #' * `lwr.ci`: lower end of the confidence interval. |
||
| 60 | +322 | ++ |
+ #' * `upr.ci`: upper end of the confidence interval.+ |
+ |
| 323 |
#' |
|||
| 61 | +324 |
- #' @examples+ #' @keywords internal |
||
| 62 | +325 |
- #' format_fraction_fixed_dp(x = c(num = 1L, denom = 2L))+ desctools_binomci <- function(x, |
||
| 63 | +326 |
- #' format_fraction_fixed_dp(x = c(num = 1L, denom = 4L))+ n, |
||
| 64 | +327 |
- #' format_fraction_fixed_dp(x = c(num = 0L, denom = 3L))+ conf.level = 0.95, # nolint |
||
| 65 | +328 |
- #'+ sides = c("two.sided", "left", "right"),
|
||
| 66 | +329 |
- #' @family formatting functions+ method = c( |
||
| 67 | +330 |
- #' @export+ "wilson", "wald", "waldcc", "agresti-coull", |
||
| 68 | +331 |
- format_fraction_fixed_dp <- function(x, ...) {
+ "jeffreys", "modified wilson", "wilsoncc", "modified jeffreys", |
||
| 69 | -3x | +|||
| 332 | +
- attr(x, "label") <- NULL+ "clopper-pearson", "arcsine", "logit", "witting", "pratt", |
|||
| 70 | -3x | +|||
| 333 | +
- checkmate::assert_vector(x)+ "midp", "lik", "blaker"+ |
+ |||
| 334 | ++ |
+ ),+ |
+ ||
| 335 | ++ |
+ rand = 123,+ |
+ ||
| 336 | ++ |
+ tol = 1e-05) {
|
||
| 71 | -3x | +337 | +26x |
- checkmate::assert_count(x["num"])+ if (missing(method)) {
|
| 72 | -3x | +338 | +1x |
- checkmate::assert_count(x["denom"])+ method <- "wilson" |
| 73 | +339 |
-
+ } |
||
| 74 | -3x | +340 | +26x |
- result <- if (x["num"] == 0) {
+ if (missing(sides)) {
|
| 75 | -1x | +341 | +25x |
- paste0(x["num"], "/", x["denom"])+ sides <- "two.sided" |
| 76 | +342 |
- } else {
+ } |
||
| 77 | -2x | +343 | +26x |
- paste0(+ iBinomCI <- function(x, n, conf.level = 0.95, sides = c("two.sided", "left", "right"), # nolint
|
| 78 | -2x | +344 | +26x |
- x["num"], "/", x["denom"],+ method = c( |
| 79 | -2x | +345 | +26x |
- " (", sprintf("%.1f", round(x["num"] / x["denom"] * 100, 1)), "%)"
+ "wilson", "wilsoncc", "wald", |
| 80 | -+ | |||
| 346 | +26x |
- )+ "waldcc", "agresti-coull", "jeffreys", "modified wilson", |
||
| 81 | -+ | |||
| 347 | +26x |
- }+ "modified jeffreys", "clopper-pearson", "arcsine", "logit", |
||
| 82 | -3x | +348 | +26x |
- return(result)+ "witting", "pratt", "midp", "lik", "blaker" |
| 83 | +349 |
- }+ ), |
||
| 84 | -+ | |||
| 350 | +26x |
-
+ rand = 123, |
||
| 85 | -+ | |||
| 351 | +26x |
- #' Format count and fraction+ tol = 1e-05) {
|
||
| 86 | -+ | |||
| 352 | +26x |
- #'+ if (length(x) != 1) {
|
||
| 87 | -+ | |||
| 353 | +! |
- #' @description `r lifecycle::badge("stable")`
+ stop("'x' has to be of length 1 (number of successes)")
|
||
| 88 | +354 |
- #'+ } |
||
| 89 | -+ | |||
| 355 | +26x |
- #' Formats a count together with fraction with special consideration when count is `0`.+ if (length(n) != 1) {
|
||
| 90 | -+ | |||
| 356 | +! |
- #'+ stop("'n' has to be of length 1 (number of trials)")
|
||
| 91 | +357 |
- #' @param x (`numeric(2)`)\cr vector of length 2 with count and fraction, respectively.+ } |
||
| 92 | -+ | |||
| 358 | +26x |
- #' @param ... not used. Required for `rtables` interface.+ if (length(conf.level) != 1) {
+ |
+ ||
| 359 | +! | +
+ stop("'conf.level' has to be of length 1 (confidence level)")
|
||
| 93 | +360 |
- #'+ }+ |
+ ||
| 361 | +26x | +
+ if (conf.level < 0.5 || conf.level > 1) {
+ |
+ ||
| 362 | +! | +
+ stop("'conf.level' has to be in [0.5, 1]")
|
||
| 94 | +363 |
- #' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`.+ }+ |
+ ||
| 364 | +26x | +
+ sides <- match.arg(sides, choices = c(+ |
+ ||
| 365 | +26x | +
+ "two.sided", "left",+ |
+ ||
| 366 | +26x | +
+ "right"+ |
+ ||
| 367 | +26x | +
+ ), several.ok = FALSE)+ |
+ ||
| 368 | +26x | +
+ if (sides != "two.sided") {
+ |
+ ||
| 369 | +1x | +
+ conf.level <- 1 - 2 * (1 - conf.level) # nolint |
||
| 95 | +370 |
- #'+ }+ |
+ ||
| 371 | +26x | +
+ alpha <- 1 - conf.level+ |
+ ||
| 372 | +26x | +
+ kappa <- stats::qnorm(1 - alpha / 2)+ |
+ ||
| 373 | +26x | +
+ p_hat <- x / n+ |
+ ||
| 374 | +26x | +
+ q_hat <- 1 - p_hat+ |
+ ||
| 375 | +26x | +
+ est <- p_hat+ |
+ ||
| 376 | +26x | +
+ switch(match.arg(arg = method, choices = c(+ |
+ ||
| 377 | +26x | +
+ "wilson",+ |
+ ||
| 378 | +26x | +
+ "wald", "waldcc", "wilsoncc", "agresti-coull", "jeffreys",+ |
+ ||
| 379 | +26x | +
+ "modified wilson", "modified jeffreys", "clopper-pearson",+ |
+ ||
| 380 | +26x | +
+ "arcsine", "logit", "witting", "pratt", "midp", "lik",+ |
+ ||
| 381 | +26x | +
+ "blaker" |
||
| 96 | +382 |
- #' @examples+ )),+ |
+ ||
| 383 | +26x | +
+ wald = {
+ |
+ ||
| 384 | +1x | +
+ term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n)+ |
+ ||
| 385 | +1x | +
+ ci_lwr <- max(0, p_hat - term2)+ |
+ ||
| 386 | +1x | +
+ ci_upr <- min(1, p_hat + term2) |
||
| 97 | +387 |
- #' format_count_fraction(x = c(2, 0.6667))+ },+ |
+ ||
| 388 | +26x | +
+ waldcc = {
+ |
+ ||
| 389 | +1x | +
+ term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n)+ |
+ ||
| 390 | +1x | +
+ term2 <- term2 + 1 / (2 * n)+ |
+ ||
| 391 | +1x | +
+ ci_lwr <- max(0, p_hat - term2)+ |
+ ||
| 392 | +1x | +
+ ci_upr <- min(1, p_hat + term2) |
||
| 98 | +393 |
- #' format_count_fraction(x = c(0, 0))+ },+ |
+ ||
| 394 | +26x | +
+ wilson = {
+ |
+ ||
| 395 | +8x | +
+ term1 <- (x + kappa^2 / 2) / (n + kappa^2)+ |
+ ||
| 396 | +8x | +
+ term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat * q_hat + kappa^2 / (4 * n))+ |
+ ||
| 397 | +8x | +
+ ci_lwr <- max(0, term1 - term2)+ |
+ ||
| 398 | +8x | +
+ ci_upr <- min(1, term1 + term2) |
||
| 99 | +399 |
- #'+ },+ |
+ ||
| 400 | +26x | +
+ wilsoncc = {
|
||
| 100 | -+ | |||
| 401 | +3x |
- #' @family formatting functions+ lci <- ( |
||
| 101 | -+ | |||
| 402 | +3x |
- #' @export+ 2 * x + kappa^2 - 1 - kappa * sqrt(kappa^2 - 2 - 1 / n + 4 * p_hat * (n * q_hat + 1)) |
||
| 102 | -+ | |||
| 403 | +3x |
- format_count_fraction <- function(x, ...) {
+ ) / (2 * (n + kappa^2)) |
||
| 103 | +404 | 3x |
- attr(x, "label") <- NULL+ uci <- ( |
|
| 104 | -+ | |||
| 405 | +3x |
-
+ 2 * x + kappa^2 + 1 + kappa * sqrt(kappa^2 + 2 - 1 / n + 4 * p_hat * (n * q_hat - 1)) |
||
| 105 | +406 | 3x |
- if (any(is.na(x))) {
+ ) / (2 * (n + kappa^2)) |
|
| 106 | -1x | +407 | +3x |
- return("NA")
+ ci_lwr <- max(0, ifelse(p_hat == 0, 0, lci)) |
| 107 | -+ | |||
| 408 | +3x |
- }+ ci_upr <- min(1, ifelse(p_hat == 1, 1, uci)) |
||
| 108 | +409 |
-
+ }, |
||
| 109 | -2x | +410 | +26x |
- checkmate::assert_vector(x)+ `agresti-coull` = {
|
| 110 | -2x | +411 | +1x |
- checkmate::assert_integerish(x[1])+ x_tilde <- x + kappa^2 / 2 |
| 111 | -2x | +412 | +1x |
- assert_proportion_value(x[2], include_boundaries = TRUE)+ n_tilde <- n + kappa^2 |
| 112 | -+ | |||
| 413 | +1x |
-
+ p_tilde <- x_tilde / n_tilde |
||
| 113 | -2x | +414 | +1x |
- result <- if (x[1] == 0) {
+ q_tilde <- 1 - p_tilde |
| 114 | +415 | 1x |
- "0"+ est <- p_tilde |
|
| 115 | -+ | |||
| 416 | +1x |
- } else {
+ term2 <- kappa * sqrt(p_tilde * q_tilde) / sqrt(n_tilde) |
||
| 116 | +417 | 1x |
- paste0(x[1], " (", round(x[2] * 100, 1), "%)")
+ ci_lwr <- max(0, p_tilde - term2) |
|
| 117 | -+ | |||
| 418 | +1x |
- }+ ci_upr <- min(1, p_tilde + term2) |
||
| 118 | +419 |
-
+ }, |
||
| 119 | -2x | +420 | +26x |
- return(result)+ jeffreys = {
|
| 120 | -+ | |||
| 421 | +1x |
- }+ if (x == 0) {
|
||
| 121 | -+ | |||
| 422 | +! |
-
+ ci_lwr <- 0 |
||
| 122 | +423 |
- #' Format count and percentage with fixed single decimal place+ } else {
|
||
| 123 | -+ | |||
| 424 | +1x |
- #'+ ci_lwr <- stats::qbeta( |
||
| 124 | -+ | |||
| 425 | +1x |
- #' @description `r lifecycle::badge("experimental")`
+ alpha / 2, |
||
| 125 | -+ | |||
| 426 | +1x |
- #'+ x + 0.5, n - x + 0.5 |
||
| 126 | +427 |
- #' Formats a count together with fraction with special consideration when count is `0`.+ ) |
||
| 127 | +428 |
- #'+ } |
||
| 128 | -+ | |||
| 429 | +1x |
- #' @inheritParams format_count_fraction+ if (x == n) {
|
||
| 129 | -+ | |||
| 430 | +! |
- #'+ ci_upr <- 1 |
||
| 130 | +431 |
- #' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`.+ } else {
|
||
| 131 | -+ | |||
| 432 | +1x |
- #'+ ci_upr <- stats::qbeta(1 - alpha / 2, x + 0.5, n - x + 0.5) |
||
| 132 | +433 |
- #' @examples+ } |
||
| 133 | +434 |
- #' format_count_fraction_fixed_dp(x = c(2, 0.6667))+ }, |
||
| 134 | -+ | |||
| 435 | +26x |
- #' format_count_fraction_fixed_dp(x = c(2, 0.5))+ `modified wilson` = {
|
||
| 135 | -+ | |||
| 436 | +1x |
- #' format_count_fraction_fixed_dp(x = c(0, 0))+ term1 <- (x + kappa^2 / 2) / (n + kappa^2) |
||
| 136 | -+ | |||
| 437 | +1x |
- #'+ term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat * q_hat + kappa^2 / (4 * n)) |
||
| 137 | -+ | |||
| 438 | +1x |
- #' @family formatting functions+ if ((n <= 50 & x %in% c(1, 2)) | (n >= 51 & x %in% c(1:3))) {
|
||
| 138 | -+ | |||
| 439 | +! |
- #' @export+ ci_lwr <- 0.5 * stats::qchisq(alpha, 2 * x) / n |
||
| 139 | +440 |
- format_count_fraction_fixed_dp <- function(x, ...) {
+ } else {
|
||
| 140 | -503x | +441 | +1x |
- attr(x, "label") <- NULL+ ci_lwr <- max(0, term1 - term2) |
| 141 | +442 |
-
+ } |
||
| 142 | -503x | +443 | +1x |
- if (any(is.na(x))) {
+ if ((n <= 50 & x %in% c(n - 1, n - 2)) | (n >= 51 & x %in% c(n - (1:3)))) {
|
| 143 | +444 | ! |
- return("NA")
+ ci_upr <- 1 - 0.5 * stats::qchisq( |
|
| 144 | -+ | |||
| 445 | +! |
- }+ alpha, |
||
| 145 | -+ | |||
| 446 | +! |
-
+ 2 * (n - x) |
||
| 146 | -503x | +|||
| 447 | +! |
- checkmate::assert_vector(x)+ ) / n |
||
| 147 | -503x | +|||
| 448 | +
- checkmate::assert_integerish(x[1])+ } else {
|
|||
| 148 | -503x | +449 | +1x |
- assert_proportion_value(x[2], include_boundaries = TRUE)+ ci_upr <- min(1, term1 + term2) |
| 149 | +450 |
-
+ } |
||
| 150 | -503x | +|||
| 451 | +
- result <- if (x[1] == 0) {
+ }, |
|||
| 151 | -1x | +452 | +26x |
- "0"+ `modified jeffreys` = {
|
| 152 | -503x | +453 | +1x |
- } else if (.is_equal_float(x[2], 1)) {
+ if (x == n) {
|
| 153 | -500x | +|||
| 454 | +! |
- sprintf("%d (100%%)", x[1])
+ ci_lwr <- (alpha / 2)^(1 / n) |
||
| 154 | +455 |
- } else {
+ } else {
|
||
| 155 | -2x | +456 | +1x |
- sprintf("%d (%.1f%%)", x[1], x[2] * 100)
+ if (x <= 1) {
|
| 156 | -+ | |||
| 457 | +! |
- }+ ci_lwr <- 0 |
||
| 157 | +458 |
-
+ } else {
|
||
| 158 | -503x | +459 | +1x |
- return(result)+ ci_lwr <- stats::qbeta( |
| 159 | -+ | |||
| 460 | +1x |
- }+ alpha / 2, |
||
| 160 | -+ | |||
| 461 | +1x |
-
+ x + 0.5, n - x + 0.5 |
||
| 161 | +462 |
- #' Format count and fraction with special case for count < 10+ ) |
||
| 162 | +463 |
- #'+ } |
||
| 163 | +464 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 164 | -+ | |||
| 465 | +1x |
- #'+ if (x == 0) {
|
||
| 165 | -+ | |||
| 466 | +! |
- #' Formats a count together with fraction with special consideration when count is less than 10.+ ci_upr <- 1 - (alpha / 2)^(1 / n) |
||
| 166 | +467 |
- #'+ } else {
|
||
| 167 | -+ | |||
| 468 | +1x |
- #' @inheritParams format_count_fraction+ if (x >= n - 1) {
|
||
| 168 | -+ | |||
| 469 | +! |
- #'+ ci_upr <- 1 |
||
| 169 | +470 |
- #' @return A string in the format `count (fraction %)`. If `count` is less than 10, only `count` is printed.+ } else {
|
||
| 170 | -+ | |||
| 471 | +1x |
- #'+ ci_upr <- stats::qbeta(1 - alpha / 2, x + 0.5, n - x + 0.5) |
||
| 171 | +472 |
- #' @examples+ } |
||
| 172 | +473 |
- #' format_count_fraction_lt10(x = c(275, 0.9673))+ } |
||
| 173 | +474 |
- #' format_count_fraction_lt10(x = c(2, 0.6667))+ }, |
||
| 174 | -+ | |||
| 475 | +26x |
- #' format_count_fraction_lt10(x = c(9, 1))+ `clopper-pearson` = {
|
||
| 175 | -+ | |||
| 476 | +1x |
- #'+ ci_lwr <- stats::qbeta(alpha / 2, x, n - x + 1) |
||
| 176 | -+ | |||
| 477 | +1x |
- #' @family formatting functions+ ci_upr <- stats::qbeta(1 - alpha / 2, x + 1, n - x) |
||
| 177 | +478 |
- #' @export+ }, |
||
| 178 | -+ | |||
| 479 | +26x |
- format_count_fraction_lt10 <- function(x, ...) {
+ arcsine = {
|
||
| 179 | -7x | +480 | +1x |
- attr(x, "label") <- NULL+ p_tilde <- (x + 0.375) / (n + 0.75) |
| 180 | -+ | |||
| 481 | +1x |
-
+ est <- p_tilde |
||
| 181 | -7x | +482 | +1x |
- if (any(is.na(x))) {
+ ci_lwr <- sin(asin(sqrt(p_tilde)) - 0.5 * kappa / sqrt(n))^2 |
| 182 | +483 | 1x |
- return("NA")
+ ci_upr <- sin(asin(sqrt(p_tilde)) + 0.5 * kappa / sqrt(n))^2 |
|
| 183 | +484 |
- }+ }, |
||
| 184 | -+ | |||
| 485 | +26x |
-
+ logit = {
|
||
| 185 | -6x | +486 | +1x |
- checkmate::assert_vector(x)+ lambda_hat <- log(x / (n - x)) |
| 186 | -6x | +487 | +1x |
- checkmate::assert_integerish(x[1])+ V_hat <- n / (x * (n - x)) # nolint |
| 187 | -6x | +488 | +1x |
- assert_proportion_value(x[2], include_boundaries = TRUE)+ lambda_lower <- lambda_hat - kappa * sqrt(V_hat) |
| 188 | -+ | |||
| 489 | +1x |
-
+ lambda_upper <- lambda_hat + kappa * sqrt(V_hat) |
||
| 189 | -6x | +490 | +1x |
- result <- if (x[1] < 10) {
+ ci_lwr <- exp(lambda_lower) / (1 + exp(lambda_lower)) |
| 190 | -3x | +491 | +1x |
- paste0(x[1])+ ci_upr <- exp(lambda_upper) / (1 + exp(lambda_upper)) |
| 191 | +492 |
- } else {
+ }, |
||
| 192 | -3x | +493 | +26x |
- paste0(x[1], " (", round(x[2] * 100, 1), "%)")
+ witting = {
|
| 193 | -+ | |||
| 494 | +1x |
- }+ set.seed(rand) |
||
| 194 | -+ | |||
| 495 | +1x |
-
+ x_tilde <- x + stats::runif(1, min = 0, max = 1) |
||
| 195 | -6x | +496 | +1x |
- return(result)+ pbinom_abscont <- function(q, size, prob) {
|
| 196 | -+ | |||
| 497 | +22x |
- }+ v <- trunc(q) |
||
| 197 | -+ | |||
| 498 | +22x |
-
+ term1 <- stats::pbinom(v - 1, size = size, prob = prob) |
||
| 198 | -+ | |||
| 499 | +22x |
- #' Format XX as a formatting function+ term2 <- (q - v) * stats::dbinom(v, size = size, prob = prob) |
||
| 199 | -+ | |||
| 500 | +22x |
- #'+ return(term1 + term2) |
||
| 200 | +501 |
- #' Translate a string where x and dots are interpreted as number place+ } |
||
| 201 | -+ | |||
| 502 | +1x |
- #' holders, and others as formatting elements.+ qbinom_abscont <- function(p, size, x) {
|
||
| 202 | -+ | |||
| 503 | +2x |
- #'+ fun <- function(prob, size, x, p) {
|
||
| 203 | -+ | |||
| 504 | +22x |
- #' @param str (`string`)\cr template.+ pbinom_abscont(x, size, prob) - p |
||
| 204 | +505 |
- #'+ } |
||
| 205 | -+ | |||
| 506 | +2x |
- #' @return An `rtables` formatting function.+ stats::uniroot(fun, |
||
| 206 | -+ | |||
| 507 | +2x |
- #'+ interval = c(0, 1), size = size, |
||
| 207 | -+ | |||
| 508 | +2x |
- #' @examples+ x = x, p = p |
||
| 208 | -+ | |||
| 509 | +2x |
- #' test <- list(c(1.658, 0.5761), c(1e1, 785.6))+ )$root |
||
| 209 | +510 |
- #'+ } |
||
| 210 | -+ | |||
| 511 | +1x |
- #' z <- format_xx("xx (xx.x)")
+ ci_lwr <- qbinom_abscont(1 - alpha, size = n, x = x_tilde) |
||
| 211 | -+ | |||
| 512 | +1x |
- #' sapply(test, z)+ ci_upr <- qbinom_abscont(alpha, size = n, x = x_tilde) |
||
| 212 | +513 |
- #'+ }, |
||
| 213 | -+ | |||
| 514 | +26x |
- #' z <- format_xx("xx.x - xx.x")
+ pratt = {
|
||
| 214 | -+ | |||
| 515 | +1x |
- #' sapply(test, z)+ if (x == 0) {
|
||
| 215 | -+ | |||
| 516 | +! |
- #'+ ci_lwr <- 0 |
||
| 216 | -+ | |||
| 517 | +! |
- #' z <- format_xx("xx.x, incl. xx.x% NE")
+ ci_upr <- 1 - alpha^(1 / n) |
||
| 217 | -+ | |||
| 518 | +1x |
- #' sapply(test, z)+ } else if (x == 1) {
|
||
| 218 | -+ | |||
| 519 | +! |
- #'+ ci_lwr <- 1 - (1 - alpha / 2)^(1 / n) |
||
| 219 | -+ | |||
| 520 | +! |
- #' @family formatting functions+ ci_upr <- 1 - (alpha / 2)^(1 / n) |
||
| 220 | -+ | |||
| 521 | +1x |
- #' @export+ } else if (x == (n - 1)) {
|
||
| 221 | -+ | |||
| 522 | +! |
- format_xx <- function(str) {
+ ci_lwr <- (alpha / 2)^(1 / n)+ |
+ ||
| 523 | +! | +
+ ci_upr <- (1 - alpha / 2)^(1 / n)+ |
+ ||
| 524 | +1x | +
+ } else if (x == n) {
+ |
+ ||
| 525 | +! | +
+ ci_lwr <- alpha^(1 / n)+ |
+ ||
| 526 | +! | +
+ ci_upr <- 1 |
||
| 222 | +527 |
- # Find position in the string.+ } else {
|
||
| 223 | +528 | 1x |
- positions <- gregexpr(pattern = "x+\\.x+|x+", text = str, perl = TRUE)+ z <- stats::qnorm(1 - alpha / 2) |
|
| 224 | +529 | 1x |
- x_positions <- regmatches(x = str, m = positions)[[1]]+ A <- ((x + 1) / (n - x))^2 # nolint |
|
| 225 | -+ | |||
| 530 | +1x |
-
+ B <- 81 * (x + 1) * (n - x) - 9 * n - 8 # nolint |
||
| 226 | -+ | |||
| 531 | +1x |
- # Roundings depends on the number of x behind [.].+ C <- (0 - 3) * z * sqrt(9 * (x + 1) * (n - x) * (9 * n + 5 - z^2) + n + 1) # nolint |
||
| 227 | +532 | 1x |
- roundings <- lapply(+ D <- 81 * (x + 1)^2 - 9 * (x + 1) * (2 + z^2) + 1 # nolint |
|
| 228 | +533 | 1x |
- X = x_positions,+ E <- 1 + A * ((B + C) / D)^3 # nolint |
|
| 229 | +534 | 1x |
- function(x) {
+ ci_upr <- 1 / E |
|
| 230 | -2x | +535 | +1x |
- y <- strsplit(split = "\\.", x = x)[[1]]+ A <- (x / (n - x - 1))^2 # nolint |
| 231 | -2x | +536 | +1x |
- rounding <- function(x) {
+ B <- 81 * x * (n - x - 1) - 9 * n - 8 # nolint |
| 232 | -4x | +537 | +1x |
- round(x, digits = ifelse(length(y) > 1, nchar(y[2]), 0))+ C <- 3 * z * sqrt(9 * x * (n - x - 1) * (9 * n + 5 - z^2) + n + 1) # nolint |
| 233 | -+ | |||
| 538 | +1x |
- }+ D <- 81 * x^2 - 9 * x * (2 + z^2) + 1 # nolint |
||
| 234 | -2x | +539 | +1x |
- return(rounding)+ E <- 1 + A * ((B + C) / D)^3 # nolint |
| 235 | -+ | |||
| 540 | +1x |
- }+ ci_lwr <- 1 / E |
||
| 236 | +541 |
- )+ } |
||
| 237 | +542 |
-
+ }, |
||
| 238 | -1x | +543 | +26x |
- rtable_format <- function(x, output) {
+ midp = {
|
| 239 | -2x | +544 | +1x |
- values <- Map(y = x, fun = roundings, function(y, fun) fun(y))+ f_low <- function(pi, x, n) {
|
| 240 | -2x | +545 | +12x |
- regmatches(x = str, m = positions)[[1]] <- values+ 1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x, |
| 241 | -2x | +546 | +12x |
- return(str)+ size = n, prob = pi, lower.tail = FALSE |
| 242 | +547 |
- }+ ) -+ |
+ ||
| 548 | +12x | +
+ (1 - conf.level) / 2 |
||
| 243 | +549 |
-
+ } |
||
| 244 | +550 | 1x |
- return(rtable_format)+ f_up <- function(pi, x, n) {
|
|
| 245 | -+ | |||
| 551 | +12x |
- }+ 1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x - 1, size = n, prob = pi) - (1 - conf.level) / 2 |
||
| 246 | +552 |
-
+ } |
||
| 247 | -+ | |||
| 553 | +1x |
- #' Format numeric values by significant figures+ ci_lwr <- 0 |
||
| 248 | -+ | |||
| 554 | +1x |
- #'+ ci_upr <- 1 |
||
| 249 | -+ | |||
| 555 | +1x |
- #' Format numeric values to print with a specified number of significant figures.+ if (x != 0) {
|
||
| 250 | -+ | |||
| 556 | +1x | +
+ ci_lwr <- stats::uniroot(f_low,+ |
+ ||
| 557 | +1x | +
+ interval = c(0, p_hat),+ |
+ ||
| 558 | +1x | +
+ x = x, n = n+ |
+ ||
| 559 | +1x |
- #'+ )$root |
||
| 251 | +560 |
- #' @param sigfig (`integer(1)`)\cr number of significant figures to display.+ } |
||
| 252 | -+ | |||
| 561 | +1x |
- #' @param format (`string`)\cr the format label (string) to apply when printing the value. Decimal+ if (x != n) {
|
||
| 253 | -+ | |||
| 562 | +1x |
- #' places in string are ignored in favor of formatting by significant figures. Formats options are:+ ci_upr <- stats::uniroot(f_up, interval = c( |
||
| 254 | -+ | |||
| 563 | +1x |
- #' `"xx"`, `"xx / xx"`, `"(xx, xx)"`, `"xx - xx"`, and `"xx (xx)"`.+ p_hat, |
||
| 255 | -+ | |||
| 564 | +1x |
- #' @param num_fmt (`string`)\cr numeric format modifiers to apply to the value. Defaults to `"fg"` for+ 1 |
||
| 256 | -+ | |||
| 565 | +1x |
- #' standard significant figures formatting - fixed (non-scientific notation) format (`"f"`)+ ), x = x, n = n)$root |
||
| 257 | +566 |
- #' and `sigfig` equal to number of significant figures instead of decimal places (`"g"`). See the+ } |
||
| 258 | +567 |
- #' [formatC()] `format` argument for more options.+ }, |
||
| 259 | -+ | |||
| 568 | +26x |
- #'+ lik = {
|
||
| 260 | -+ | |||
| 569 | +2x |
- #' @return An `rtables` formatting function.+ ci_lwr <- 0 |
||
| 261 | -+ | |||
| 570 | +2x |
- #'+ ci_upr <- 1 |
||
| 262 | -+ | |||
| 571 | +2x |
- #' @examples+ z <- stats::qnorm(1 - alpha * 0.5) |
||
| 263 | -+ | |||
| 572 | +2x |
- #' fmt_3sf <- format_sigfig(3)+ tol <- .Machine$double.eps^0.5 |
||
| 264 | -+ | |||
| 573 | +2x |
- #' fmt_3sf(1.658)+ BinDev <- function(y, x, mu, wt, bound = 0, tol = .Machine$double.eps^0.5, # nolint |
||
| 265 | +574 |
- #' fmt_3sf(1e1)+ ...) {
|
||
| 266 | -+ | |||
| 575 | +40x |
- #'+ ll_y <- ifelse(y %in% c(0, 1), 0, stats::dbinom(x, wt, |
||
| 267 | -+ | |||
| 576 | +40x |
- #' fmt_5sf <- format_sigfig(5)+ y, |
||
| 268 | -+ | |||
| 577 | +40x |
- #' fmt_5sf(0.57)+ log = TRUE |
||
| 269 | +578 |
- #' fmt_5sf(0.000025645)+ )) |
||
| 270 | -+ | |||
| 579 | +40x |
- #'+ ll_mu <- ifelse(mu %in% c(0, 1), 0, stats::dbinom(x, |
||
| 271 | -+ | |||
| 580 | +40x |
- #' @family formatting functions+ wt, mu, |
||
| 272 | -+ | |||
| 581 | +40x |
- #' @export+ log = TRUE |
||
| 273 | +582 |
- format_sigfig <- function(sigfig, format = "xx", num_fmt = "fg") {
+ )) |
||
| 274 | -3x | +583 | +40x |
- checkmate::assert_integerish(sigfig)+ res <- ifelse(abs(y - mu) < tol, 0, sign(y - mu) * sqrt(-2 * (ll_y - ll_mu))) |
| 275 | -3x | +584 | +40x |
- format <- gsub("xx\\.|xx\\.x+", "xx", format)
+ return(res - bound) |
| 276 | -3x | +|||
| 585 | +
- checkmate::assert_choice(format, c("xx", "xx / xx", "(xx, xx)", "xx - xx", "xx (xx)"))
+ } |
|||
| 277 | -3x | +586 | +2x |
- function(x, ...) {
+ if (x != 0 && tol < p_hat) {
|
| 278 | -! | +|||
| 587 | +2x |
- if (!is.numeric(x)) stop("`format_sigfig` cannot be used for non-numeric values. Please choose another format.")
+ ci_lwr <- if (BinDev( |
||
| 279 | -12x | +588 | +2x |
- num <- formatC(signif(x, digits = sigfig), digits = sigfig, format = num_fmt, flag = "#")+ tol, x, p_hat, n, -z, |
| 280 | -12x | +589 | +2x |
- num <- gsub("\\.$", "", num) # remove trailing "."
+ tol |
| 281 | -+ | |||
| 590 | +2x |
-
+ ) <= 0) {
|
||
| 282 | -12x | +591 | +2x |
- format_value(num, format)+ stats::uniroot( |
| 283 | -+ | |||
| 592 | +2x |
- }+ f = BinDev, interval = c(tol, if (p_hat < tol || p_hat == 1) {
|
||
| 284 | -+ | |||
| 593 | +! |
- }+ 1 - tol |
||
| 285 | +594 |
-
+ } else {
|
||
| 286 | -+ | |||
| 595 | +2x |
- #' Format fraction with lower threshold+ p_hat |
||
| 287 | -+ | |||
| 596 | +2x |
- #'+ }), bound = -z, |
||
| 288 | -+ | |||
| 597 | +2x |
- #' @description `r lifecycle::badge("stable")`
+ x = x, mu = p_hat, wt = n |
||
| 289 | -+ | |||
| 598 | +2x |
- #'+ )$root |
||
| 290 | +599 |
- #' Formats a fraction when the second element of the input `x` is the fraction. It applies+ } |
||
| 291 | +600 |
- #' a lower threshold, below which it is just stated that the fraction is smaller than that.+ } |
||
| 292 | -+ | |||
| 601 | +2x |
- #'+ if (x != n && p_hat < (1 - tol)) {
|
||
| 293 | -+ | |||
| 602 | +2x |
- #' @param threshold (`proportion`)\cr lower threshold.+ ci_upr <- if ( |
||
| 294 | -+ | |||
| 603 | +2x |
- #'+ BinDev(y = 1 - tol, x = x, mu = ifelse(p_hat > 1 - tol, tol, p_hat), wt = n, bound = z, tol = tol) < 0) { # nolint
|
||
| 295 | -+ | |||
| 604 | +! |
- #' @return An `rtables` formatting function that takes numeric input `x` where the second+ ci_lwr <- if (BinDev( |
||
| 296 | -+ | |||
| 605 | +! |
- #' element is the fraction that is formatted. If the fraction is above or equal to the threshold,+ tol, x, if (p_hat < tol || p_hat == 1) {
|
||
| 297 | -+ | |||
| 606 | +! |
- #' then it is displayed in percentage. If it is positive but below the threshold, it returns,+ 1 - tol |
||
| 298 | +607 |
- #' e.g. "<1" if the threshold is `0.01`. If it is zero, then just "0" is returned.+ } else {
|
||
| 299 | -+ | |||
| 608 | +! |
- #'+ p_hat |
||
| 300 | -+ | |||
| 609 | +! |
- #' @examples+ }, n, |
||
| 301 | -+ | |||
| 610 | +! |
- #' format_fun <- format_fraction_threshold(0.05)+ -z, tol |
||
| 302 | -+ | |||
| 611 | +! |
- #' format_fun(x = c(20, 0.1))+ ) <= 0) {
|
||
| 303 | -+ | |||
| 612 | +! |
- #' format_fun(x = c(2, 0.01))+ stats::uniroot( |
||
| 304 | -+ | |||
| 613 | +! |
- #' format_fun(x = c(0, 0))+ f = BinDev, interval = c(tol, p_hat), |
||
| 305 | -+ | |||
| 614 | +! |
- #'+ bound = -z, x = x, mu = p_hat, wt = n |
||
| 306 | -+ | |||
| 615 | +! |
- #' @family formatting functions+ )$root |
||
| 307 | +616 |
- #' @export+ } |
||
| 308 | +617 |
- format_fraction_threshold <- function(threshold) {
- |
- ||
| 309 | -1x | -
- assert_proportion_value(threshold)- |
- ||
| 310 | -1x | -
- string_below_threshold <- paste0("<", round(threshold * 100))
- |
- ||
| 311 | -1x | -
- function(x, ...) {
+ } else {
|
||
| 312 | -3x | +618 | +2x |
- assert_proportion_value(x[2], include_boundaries = TRUE)+ stats::uniroot( |
| 313 | -3x | +619 | +2x |
- ifelse(+ f = BinDev, interval = c(if (p_hat > 1 - tol) {
|
| 314 | -3x | +|||
| 620 | +! |
- x[2] > 0.01,+ tol |
||
| 315 | -3x | +|||
| 621 | +
- round(x[2] * 100),+ } else {
|
|||
| 316 | -3x | +622 | +2x |
- ifelse(+ p_hat |
| 317 | -3x | +623 | +2x |
- x[2] == 0,+ }, 1 - tol), bound = z, |
| 318 | -3x | +624 | +2x |
- "0",+ x = x, mu = p_hat, wt = n |
| 319 | -3x | +625 | +2x |
- string_below_threshold+ )$root |
| 320 | +626 |
- )+ } |
||
| 321 | +627 |
- )+ } |
||
| 322 | +628 |
- }+ }, |
||
| 323 | -+ | |||
| 629 | +26x |
- }+ blaker = {
|
||
| 324 | -+ | |||
| 630 | +1x |
-
+ acceptbin <- function(x, n, p) {
|
||
| 325 | -+ | |||
| 631 | +3954x |
- #' Format extreme values+ p1 <- 1 - stats::pbinom(x - 1, n, p) |
||
| 326 | -+ | |||
| 632 | +3954x |
- #'+ p2 <- stats::pbinom(x, n, p) |
||
| 327 | -+ | |||
| 633 | +3954x |
- #' @description `r lifecycle::badge("stable")`
+ a1 <- p1 + stats::pbinom(stats::qbinom(p1, n, p) - 1, n, p) |
||
| 328 | -+ | |||
| 634 | +3954x |
- #'+ a2 <- p2 + 1 - stats::pbinom( |
||
| 329 | -+ | |||
| 635 | +3954x |
- #' `rtables` formatting functions that handle extreme values.+ stats::qbinom(1 - p2, n, p), n, |
||
| 330 | -+ | |||
| 636 | +3954x |
- #'+ p |
||
| 331 | +637 |
- #' @param digits (`integer(1)`)\cr number of decimal places to display.+ ) |
||
| 332 | -+ | |||
| 638 | +3954x |
- #'+ return(min(a1, a2)) |
||
| 333 | +639 |
- #' @details For each input, apply a format to the specified number of `digits`. If the value is+ } |
||
| 334 | -+ | |||
| 640 | +1x |
- #' below a threshold, it returns "<0.01" e.g. if the number of `digits` is 2. If the value is+ ci_lwr <- 0 |
||
| 335 | -+ | |||
| 641 | +1x |
- #' above a threshold, it returns ">999.99" e.g. if the number of `digits` is 2.+ ci_upr <- 1 |
||
| 336 | -+ | |||
| 642 | +1x |
- #' If it is zero, then returns "0.00".+ if (x != 0) {
|
||
| 337 | -+ | |||
| 643 | +1x |
- #'+ ci_lwr <- stats::qbeta((1 - conf.level) / 2, x, n - x + 1) |
||
| 338 | -+ | |||
| 644 | +1x |
- #' @family formatting functions+ while (acceptbin(x, n, ci_lwr + tol) < (1 - conf.level)) {
|
||
| 339 | -+ | |||
| 645 | +1976x |
- #' @name extreme_format+ ci_lwr <- ci_lwr + tol |
||
| 340 | +646 |
- NULL+ } |
||
| 341 | +647 |
-
+ } |
||
| 342 | -+ | |||
| 648 | +1x |
- #' @describeIn extreme_format Internal helper function to calculate the threshold and create formatted strings+ if (x != n) {
|
||
| 343 | -+ | |||
| 649 | +1x |
- #' used in Formatting Functions. Returns a list with elements `threshold` and `format_string`.+ ci_upr <- stats::qbeta(1 - (1 - conf.level) / 2, x + 1, n - x) |
||
| 344 | -+ | |||
| 650 | +1x |
- #'+ while (acceptbin(x, n, ci_upr - tol) < (1 - conf.level)) {
|
||
| 345 | -+ | |||
| 651 | +1976x |
- #' @return+ ci_upr <- ci_upr - tol |
||
| 346 | +652 |
- #' * `h_get_format_threshold()` returns a `list` of 2 elements: `threshold`, with `low` and `high` thresholds,+ } |
||
| 347 | +653 |
- #' and `format_string`, with thresholds formatted as strings.+ } |
||
| 348 | +654 |
- #'+ } |
||
| 349 | +655 |
- #' @examples+ ) |
||
| 350 | -+ | |||
| 656 | +26x |
- #' h_get_format_threshold(2L)+ ci <- c(est = est, lwr.ci = max(0, ci_lwr), upr.ci = min( |
||
| 351 | -+ | |||
| 657 | +26x |
- #'+ 1, |
||
| 352 | -+ | |||
| 658 | +26x |
- #' @export+ ci_upr |
||
| 353 | +659 |
- h_get_format_threshold <- function(digits = 2L) {
+ )) |
||
| 354 | -2113x | +660 | +26x |
- checkmate::assert_integerish(digits)+ if (sides == "left") {
|
| 355 | -+ | |||
| 661 | +1x |
-
+ ci[3] <- 1 |
||
| 356 | -2113x | +662 | +25x |
- low_threshold <- 1 / (10 ^ digits) # styler: off+ } else if (sides == "right") {
|
| 357 | -2113x | +|||
| 663 | +! |
- high_threshold <- 1000 - (1 / (10 ^ digits)) # styler: off+ ci[2] <- 0 |
||
| 358 | +664 | - - | -||
| 359 | -2113x | -
- string_below_threshold <- paste0("<", low_threshold)
+ } |
||
| 360 | -2113x | +665 | +26x |
- string_above_threshold <- paste0(">", high_threshold)
+ return(ci) |
| 361 | +666 |
-
+ } |
||
| 362 | -2113x | +667 | +26x |
- list(+ lst <- list( |
| 363 | -2113x | +668 | +26x |
- "threshold" = c(low = low_threshold, high = high_threshold),+ x = x, n = n, conf.level = conf.level, sides = sides, |
| 364 | -2113x | +669 | +26x |
- "format_string" = c(low = string_below_threshold, high = string_above_threshold)+ method = method, rand = rand |
| 365 | +670 |
) |
||
| 366 | -- |
- }- |
- ||
| 367 | -- | - - | -||
| 368 | -+ | |||
| 671 | +26x |
- #' @describeIn extreme_format Internal helper function to apply a threshold format to a value.+ maxdim <- max(unlist(lapply(lst, length))) |
||
| 369 | -+ | |||
| 672 | +26x |
- #' Creates a formatted string to be used in Formatting Functions.+ lgp <- lapply(lst, rep, length.out = maxdim) |
||
| 370 | -+ | |||
| 673 | +26x |
- #'+ lgn <- h_recycle(x = if (is.null(names(x))) {
|
||
| 371 | -+ | |||
| 674 | +26x |
- #' @param x (`numeric(1)`)\cr value to format.+ paste("x", seq_along(x), sep = ".")
|
||
| 372 | +675 |
- #'+ } else {
|
||
| 373 | -+ | |||
| 676 | +! |
- #' @return+ names(x) |
||
| 374 | -+ | |||
| 677 | +26x |
- #' * `h_format_threshold()` returns the given value, or if the value is not within the digit threshold the relation+ }, n = if (is.null(names(n))) {
|
||
| 375 | -+ | |||
| 678 | +26x |
- #' of the given value to the digit threshold, as a formatted string.+ paste("n", seq_along(n), sep = ".")
|
||
| 376 | +679 |
- #'+ } else {
|
||
| 377 | -+ | |||
| 680 | +! |
- #' @examples+ names(n) |
||
| 378 | -+ | |||
| 681 | +26x |
- #' h_format_threshold(0.001)+ }, conf.level = conf.level, sides = sides, method = method) |
||
| 379 | -+ | |||
| 682 | +26x |
- #' h_format_threshold(1000)+ xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
|
||
| 380 | -+ | |||
| 683 | +130x |
- #'+ length(unique(x)) != |
||
| 381 | -+ | |||
| 684 | +130x |
- #' @export+ 1 |
||
| 382 | -+ | |||
| 685 | +26x |
- h_format_threshold <- function(x, digits = 2L) {
+ })]), 1, paste, collapse = ":") |
||
| 383 | -2115x | +686 | +26x |
- if (is.na(x)) {
+ res <- t(sapply(1:maxdim, function(i) {
|
| 384 | -4x | +687 | +26x |
- return(x)+ iBinomCI( |
| 385 | -+ | |||
| 688 | +26x |
- }+ x = lgp$x[i], |
||
| 386 | -+ | |||
| 689 | +26x |
-
+ n = lgp$n[i], conf.level = lgp$conf.level[i], sides = lgp$sides[i], |
||
| 387 | -2111x | +690 | +26x |
- checkmate::assert_numeric(x, lower = 0)+ method = lgp$method[i], rand = lgp$rand[i] |
| 388 | +691 | - - | -||
| 389 | -2111x | -
- l_fmt <- h_get_format_threshold(digits)+ ) |
||
| 390 | +692 | - - | -||
| 391 | -2111x | -
- result <- if (x < l_fmt$threshold["low"] && 0 < x) {
+ })) |
||
| 392 | -44x | +693 | +26x |
- l_fmt$format_string["low"]+ colnames(res)[1] <- c("est")
|
| 393 | -2111x | +694 | +26x |
- } else if (x > l_fmt$threshold["high"]) {
+ rownames(res) <- xn |
| 394 | -99x | +695 | +26x |
- l_fmt$format_string["high"]+ return(res) |
| 395 | +696 |
- } else {
+ } |
||
| 396 | -1968x | +
| 1 | +
- sprintf(fmt = paste0("%.", digits, "f"), x)
+ #' Helper functions for accessing information from `rtables` |
|||
| 397 | +2 |
- }+ #' |
||
| 398 | +3 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 399 | -2111x | +|||
| 4 | +
- unname(result)+ #' |
|||
| 400 | +5 |
- }+ #' These are a couple of functions that help with accessing the data in `rtables` objects. |
||
| 401 | +6 |
-
+ #' Currently these work for occurrence tables, which are defined as having a count as the first |
||
| 402 | +7 |
- #' Format a single extreme value+ #' element and a fraction as the second element in each cell. |
||
| 403 | +8 |
#' |
||
| 404 | +9 |
- #' @description `r lifecycle::badge("stable")`
+ #' @seealso [prune_occurrences] for usage of these functions. |
||
| 405 | +10 |
#' |
||
| 406 | +11 |
- #' Create a formatting function for a single extreme value.+ #' @name rtables_access |
||
| 407 | +12 |
- #'+ NULL |
||
| 408 | +13 |
- #' @inheritParams extreme_format+ |
||
| 409 | +14 |
- #'+ #' @describeIn rtables_access Helper function to extract the first values from each content |
||
| 410 | +15 |
- #' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme value.+ #' cell and from specified columns in a `TableRow`. Defaults to all columns. |
||
| 411 | +16 |
#' |
||
| 412 | +17 |
- #' @examples+ #' @param table_row (`TableRow`)\cr an analysis row in a occurrence table. |
||
| 413 | +18 |
- #' format_fun <- format_extreme_values(2L)+ #' @param col_names (`character`)\cr the names of the columns to extract from. |
||
| 414 | +19 |
- #' format_fun(x = 0.127)+ #' @param col_indices (`integer`)\cr the indices of the columns to extract from. If `col_names` are provided, |
||
| 415 | +20 |
- #' format_fun(x = Inf)+ #' then these are inferred from the names of `table_row`. Note that this currently only works well with a single |
||
| 416 | +21 |
- #' format_fun(x = 0)+ #' column split. |
||
| 417 | +22 |
- #' format_fun(x = 0.009)+ #' |
||
| 418 | +23 |
- #'+ #' @return |
||
| 419 | +24 |
- #' @family formatting functions+ #' * `h_row_first_values()` returns a `vector` of numeric values. |
||
| 420 | +25 |
- #' @export+ #' |
||
| 421 | +26 |
- format_extreme_values <- function(digits = 2L) {
+ #' @examples |
||
| 422 | -63x | +|||
| 27 | +
- function(x, ...) {
+ #' tbl <- basic_table() %>% |
|||
| 423 | -657x | +|||
| 28 | +
- checkmate::assert_scalar(x, na.ok = TRUE)+ #' split_cols_by("ARM") %>%
|
|||
| 424 | +29 |
-
+ #' split_rows_by("RACE") %>%
|
||
| 425 | -657x | +|||
| 30 | +
- h_format_threshold(x = x, digits = digits)+ #' analyze("AGE", function(x) {
|
|||
| 426 | +31 |
- }+ #' list( |
||
| 427 | +32 |
- }+ #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.x (xx.x)"), |
||
| 428 | +33 |
-
+ #' "n" = length(x), |
||
| 429 | +34 |
- #' Format extreme values part of a confidence interval+ #' "frac" = rcell(c(0.1, 0.1), format = "xx (xx)") |
||
| 430 | +35 |
- #'+ #' ) |
||
| 431 | +36 |
- #' @description `r lifecycle::badge("stable")`
+ #' }) %>% |
||
| 432 | +37 |
- #'+ #' build_table(tern_ex_adsl) %>% |
||
| 433 | +38 |
- #' Formatting Function for extreme values part of a confidence interval. Values+ #' prune_table() |
||
| 434 | +39 |
- #' are formatted as e.g. "(xx.xx, xx.xx)" if the number of `digits` is 2.+ #' tree_row_elem <- collect_leaves(tbl[2, ])[[1]] |
||
| 435 | +40 |
- #'+ #' result <- max(h_row_first_values(tree_row_elem)) |
||
| 436 | +41 |
- #' @inheritParams extreme_format+ #' result |
||
| 437 | +42 |
#' |
||
| 438 | +43 |
- #' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme+ #' @export |
||
| 439 | +44 |
- #' values confidence interval.+ h_row_first_values <- function(table_row, |
||
| 440 | +45 |
- #'+ col_names = NULL, |
||
| 441 | +46 |
- #' @examples+ col_indices = NULL) {
|
||
| 442 | -+ | |||
| 47 | +745x |
- #' format_fun <- format_extreme_values_ci(2L)+ col_indices <- check_names_indices(table_row, col_names, col_indices) |
||
| 443 | -+ | |||
| 48 | +744x |
- #' format_fun(x = c(0.127, Inf))+ checkmate::assert_integerish(col_indices) |
||
| 444 | -+ | |||
| 49 | +744x |
- #' format_fun(x = c(0, 0.009))+ checkmate::assert_subset(col_indices, seq_len(ncol(table_row))) |
||
| 445 | +50 |
- #'+ |
||
| 446 | +51 |
- #' @family formatting functions+ # Main values are extracted |
||
| 447 | -+ | |||
| 52 | +744x |
- #' @export+ row_vals <- row_values(table_row)[col_indices] |
||
| 448 | +53 |
- format_extreme_values_ci <- function(digits = 2L) {
+
|
||
| 449 | -71x | +|||
| 54 | +
- function(x, ...) {
+ # Main return |
|||
| 450 | -726x | +55 | +744x |
- checkmate::assert_vector(x, len = 2)+ vapply(row_vals, function(rv) {
|
| 451 | -726x | +56 | +2096x |
- l_result <- h_format_threshold(x = x[1], digits = digits)+ if (is.null(rv)) {
|
| 452 | -726x | +57 | +744x |
- h_result <- h_format_threshold(x = x[2], digits = digits)+ NA_real_ |
| 453 | +58 |
-
+ } else {
|
||
| 454 | -726x | +59 | +2090x |
- paste0("(", l_result, ", ", h_result, ")")
+ rv[1L] |
| 455 | +60 |
- }+ }+ |
+ ||
| 61 | +744x | +
+ }, FUN.VALUE = numeric(1)) |
||
| 456 | +62 |
} |
||
| 457 | +63 | |||
| 458 | +64 |
- #' Format automatically using data significant digits+ #' @describeIn rtables_access Helper function that extracts row values and checks if they are |
||
| 459 | +65 |
- #'+ #' convertible to integers (`integerish` values). |
||
| 460 | +66 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 461 | +67 |
- #'+ #' @return |
||
| 462 | +68 |
- #' Formatting function for the majority of default methods used in [analyze_vars()].+ #' * `h_row_counts()` returns a `vector` of numeric values. |
||
| 463 | +69 |
- #' For non-derived values, the significant digits of data is used (e.g. range), while derived+ #' |
||
| 464 | +70 |
- #' values have one more digits (measure of location and dispersion like mean, standard deviation).+ #' @examples |
||
| 465 | +71 |
- #' This function can be called internally with "auto" like, for example,+ #' # Row counts (integer values) |
||
| 466 | +72 |
- #' `.formats = c("mean" = "auto")`. See details to see how this works with the inner function.
+ #' # h_row_counts(tree_row_elem) # Fails because there are no integers |
||
| 467 | +73 |
- #'+ #' # Using values with integers |
||
| 468 | +74 |
- #' @param dt_var (`numeric`)\cr variable data the statistics were calculated from. Used only to+ #' tree_row_elem <- collect_leaves(tbl[3, ])[[1]] |
||
| 469 | +75 |
- #' find significant digits. In [analyze_vars] this comes from `.df_row` (see+ #' result <- h_row_counts(tree_row_elem) |
||
| 470 | +76 |
- #' [rtables::additional_fun_params]), and it is the row data after the above row splits. No+ #' # result |
||
| 471 | +77 |
- #' column split is considered.+ #' |
||
| 472 | +78 |
- #' @param x_stat (`string`)\cr string indicating the current statistical method used.+ #' @export |
||
| 473 | +79 |
- #'+ h_row_counts <- function(table_row, |
||
| 474 | +80 |
- #' @return A string that `rtables` prints in a table cell.+ col_names = NULL, |
||
| 475 | +81 |
- #'+ col_indices = NULL) {
|
||
| 476 | -+ | |||
| 82 | +741x |
- #' @details+ counts <- h_row_first_values(table_row, col_names, col_indices) |
||
| 477 | -+ | |||
| 83 | +741x |
- #' The internal function is needed to work with `rtables` default structure for+ checkmate::assert_integerish(counts) |
||
| 478 | -+ | |||
| 84 | +741x |
- #' format functions, i.e. `function(x, ...)`, where is x are results from statistical evaluation.+ counts |
||
| 479 | +85 |
- #' It can be more than one element (e.g. for `.stats = "mean_sd"`).+ } |
||
| 480 | +86 |
- #'+ |
||
| 481 | +87 |
- #' @examples+ #' @describeIn rtables_access Helper function to extract fractions from specified columns in a `TableRow`. |
||
| 482 | +88 |
- #' x_todo <- c(0.001, 0.2, 0.0011000, 3, 4)+ #' More specifically it extracts the second values from each content cell and checks it is a fraction. |
||
| 483 | +89 |
- #' res <- c(mean(x_todo[1:3]), sd(x_todo[1:3]))+ #' |
||
| 484 | +90 |
- #'+ #' @return |
||
| 485 | +91 |
- #' # x is the result coming into the formatting function -> res!!+ #' * `h_row_fractions()` returns a `vector` of proportions. |
||
| 486 | +92 |
- #' format_auto(dt_var = x_todo, x_stat = "mean_sd")(x = res)+ #' |
||
| 487 | +93 |
- #' format_auto(x_todo, "range")(x = range(x_todo))+ #' @examples |
||
| 488 | +94 |
- #' no_sc_x <- c(0.0000001, 1)+ #' # Row fractions |
||
| 489 | +95 |
- #' format_auto(no_sc_x, "range")(x = no_sc_x)+ #' tree_row_elem <- collect_leaves(tbl[4, ])[[1]] |
||
| 490 | +96 |
- #'+ #' h_row_fractions(tree_row_elem) |
||
| 491 | +97 |
- #' @family formatting functions+ #' |
||
| 492 | +98 |
#' @export |
||
| 493 | +99 |
- format_auto <- function(dt_var, x_stat) {
+ h_row_fractions <- function(table_row, |
||
| 494 | -10x | +|||
| 100 | +
- function(x = "", ...) {
+ col_names = NULL, |
|||
| 495 | -18x | +|||
| 101 | +
- checkmate::assert_numeric(x, min.len = 1)+ col_indices = NULL) {
|
|||
| 496 | -18x | -
- checkmate::assert_numeric(dt_var, min.len = 1)- |
- ||
| 497 | -+ | 102 | +250x |
- # Defaults - they may be a param in the future+ col_indices <- check_names_indices(table_row, col_names, col_indices) |
| 498 | -18x | +103 | +250x |
- der_stats <- c(+ row_vals <- row_values(table_row)[col_indices] |
| 499 | -18x | +104 | +250x |
- "mean", "sd", "se", "median", "geom_mean", "quantiles", "iqr",+ fractions <- sapply(row_vals, "[", 2L) |
| 500 | -18x | +105 | +250x |
- "mean_sd", "mean_se", "mean_se", "mean_ci", "mean_sei", "mean_sdi",+ checkmate::assert_numeric(fractions, lower = 0, upper = 1) |
| 501 | -18x | +106 | +250x |
- "median_ci"+ fractions |
| 502 | +107 |
- )- |
- ||
| 503 | -18x | -
- nonder_stats <- c("n", "range", "min", "max")
+ } |
||
| 504 | +108 | |||
| 505 | +109 |
- # Safenet for miss-modifications- |
- ||
| 506 | -18x | -
- stopifnot(length(intersect(der_stats, nonder_stats)) == 0) # nolint- |
- ||
| 507 | -18x | -
- checkmate::assert_choice(x_stat, c(der_stats, nonder_stats))+ #' @describeIn rtables_access Helper function to extract column counts from specified columns in a table. |
||
| 508 | +110 |
-
+ #' |
||
| 509 | +111 |
- # Finds the max number of digits in data- |
- ||
| 510 | -18x | -
- detect_dig <- vapply(dt_var, count_decimalplaces, FUN.VALUE = numeric(1)) %>%- |
- ||
| 511 | -18x | -
- max()+ #' @param table (`VTableNodeInfo`)\cr an occurrence table or row. |
||
| 512 | +112 | - - | -||
| 513 | -18x | -
- if (x_stat %in% der_stats) {
- |
- ||
| 514 | -8x | -
- detect_dig <- detect_dig + 1+ #' |
||
| 515 | +113 |
- }+ #' @return |
||
| 516 | +114 |
-
+ #' * `h_col_counts()` returns a `vector` of column counts. |
||
| 517 | +115 |
- # Render input- |
- ||
| 518 | -18x | -
- str_vals <- formatC(x, digits = detect_dig, format = "f")- |
- ||
| 519 | -18x | -
- def_fmt <- get_formats_from_stats(x_stat)[[x_stat]]+ #' |
||
| 520 | -18x | +|||
| 116 | +
- str_fmt <- str_extract(def_fmt, invert = FALSE)[[1]]+ #' @export |
|||
| 521 | -18x | +|||
| 117 | +
- if (length(str_fmt) != length(str_vals)) {
+ h_col_counts <- function(table, |
|||
| 522 | -2x | +|||
| 118 | +
- stop(+ col_names = NULL, |
|||
| 523 | -2x | +|||
| 119 | +
- "Number of inserted values as result (", length(str_vals),
+ col_indices = NULL) {
|
|||
| 524 | -2x | +120 | +307x |
- ") is not the same as there should be in the default tern formats for ",+ col_indices <- check_names_indices(table, col_names, col_indices) |
| 525 | -2x | +121 | +307x |
- x_stat, " (-> ", def_fmt, " needs ", length(str_fmt), " values). ",+ counts <- col_counts(table)[col_indices] |
| 526 | -2x | +122 | +307x |
- "See tern_default_formats to check all of them."+ stats::setNames(counts, col_names) |
| 527 | +123 |
- )+ } |
||
| 528 | +124 |
- }+ |
||
| 529 | +125 |
-
+ #' @describeIn rtables_access Helper function to get first row of content table of current table. |
||
| 530 | +126 |
- # Squashing them together- |
- ||
| 531 | -16x | -
- inv_str_fmt <- str_extract(def_fmt, invert = TRUE)[[1]]- |
- ||
| 532 | -16x | -
- stopifnot(length(inv_str_fmt) == length(str_vals) + 1) # nolint+ #' |
||
| 533 | +127 | - - | -||
| 534 | -16x | -
- out <- vector("character", length = length(inv_str_fmt) + length(str_vals))
+ #' @return |
||
| 535 | -16x | +|||
| 128 | +
- is_even <- seq_along(out) %% 2 == 0+ #' * `h_content_first_row()` returns a row from an `rtables` table. |
|||
| 536 | -16x | +|||
| 129 | +
- out[is_even] <- str_vals+ #' |
|||
| 537 | -16x | +|||
| 130 | +
- out[!is_even] <- inv_str_fmt+ #' @export |
|||
| 538 | +131 |
-
+ h_content_first_row <- function(table) {
|
||
| 539 | -16x | +132 | +27x |
- return(paste0(out, collapse = ""))+ ct <- content_table(table) |
| 540 | -+ | |||
| 133 | +27x |
- }+ tree_children(ct)[[1]] |
||
| 541 | +134 |
} |
||
| 542 | +135 | |||
| 543 | +136 |
- # Utility function that could be useful in general+ #' @describeIn rtables_access Helper function which says whether current table is a leaf in the tree. |
||
| 544 | +137 |
- str_extract <- function(string, pattern = "xx|xx\\.|xx\\.x+", invert = FALSE) {
- |
- ||
| 545 | -34x | -
- regmatches(string, gregexpr(pattern, string), invert = invert)+ #' |
||
| 546 | +138 |
- }+ #' @return |
||
| 547 | +139 |
-
+ #' * `is_leaf_table()` returns a `logical` value indicating whether current table is a leaf. |
||
| 548 | +140 |
- # Helper function+ #' |
||
| 549 | +141 |
- count_decimalplaces <- function(dec) {
+ #' @keywords internal |
||
| 550 | -161x | +|||
| 142 | +
- if (is.na(dec)) {
+ is_leaf_table <- function(table) {
|
|||
| 551 | -6x | +143 | +168x |
- return(0)+ children <- tree_children(table) |
| 552 | -155x | +144 | +168x |
- } else if (abs(dec - round(dec)) > .Machine$double.eps^0.5) { # For precision
+ child_classes <- unique(sapply(children, class)) |
| 553 | -122x | +145 | +168x |
- nchar(strsplit(format(dec, scientific = FALSE, trim = FALSE), ".", fixed = TRUE)[[1]][[2]])+ identical(child_classes, "ElementaryTable") |
| 554 | +146 |
- } else {
+ } |
||
| 555 | -33x | +|||
| 147 | +
- return(0)+ |
|||
| 556 | +148 |
- }+ #' @describeIn rtables_access Internal helper function that tests standard inputs for column indices. |
||
| 557 | +149 |
- }+ #' |
||
| 558 | +150 |
-
+ #' @return |
||
| 559 | +151 |
- #' Apply automatic formatting+ #' * `check_names_indices` returns column indices. |
||
| 560 | +152 |
#' |
||
| 561 | +153 |
- #' Checks if any of the listed formats in `.formats` are `"auto"`, and replaces `"auto"` with+ #' @keywords internal |
||
| 562 | +154 |
- #' the correct implementation of `format_auto` for the given statistics, data, and variable.+ check_names_indices <- function(table_row, |
||
| 563 | +155 |
- #'+ col_names = NULL, |
||
| 564 | +156 |
- #' @inheritParams argument_convention+ col_indices = NULL) {
|
||
| 565 | -+ | |||
| 157 | +1302x |
- #' @param x_stats (named `list`)\cr a named list of statistics where each element corresponds+ if (!is.null(col_names)) {
|
||
| 566 | -+ | |||
| 158 | +1256x |
- #' to an element in `.formats`, with matching names.+ if (!is.null(col_indices)) {
|
||
| 567 | -+ | |||
| 159 | +1x |
- #'+ stop(+ |
+ ||
| 160 | +1x | +
+ "Inserted both col_names and col_indices when selecting row values. ",+ |
+ ||
| 161 | +1x | +
+ "Please choose one." |
||
| 568 | +162 |
- #' @keywords internal+ ) |
||
| 569 | +163 |
- apply_auto_formatting <- function(.formats, x_stats, .df_row, .var) {
+ } |
||
| 570 | -420x | +164 | +1255x |
- is_auto_fmt <- vapply(.formats, function(ii) is.character(ii) && ii == "auto", logical(1))+ col_indices <- h_col_indices(table_row, col_names) |
| 571 | -420x | +|||
| 165 | +
- if (any(is_auto_fmt)) {
+ } |
|||
| 572 | -3x | +166 | +1301x |
- auto_stats <- x_stats[is_auto_fmt]+ if (is.null(col_indices)) {
|
| 573 | -3x | +167 | +39x |
- var_df <- .df_row[[.var]] # xxx this can be extended for the WHOLE data or single facets+ ll <- ifelse(is.null(ncol(table_row)), length(table_row), ncol(table_row)) |
| 574 | -3x | +168 | +39x |
- .formats[is_auto_fmt] <- lapply(names(auto_stats), format_auto, dt_var = var_df)+ col_indices <- seq_len(ll) |
| 575 | +169 |
} |
||
| 170 | ++ | + + | +||
| 576 | -420x | +171 | +1301x |
- .formats+ return(col_indices) |
| 577 | +172 |
}@@ -11601,14 +12435,14 @@ tern coverage - 95.64% |
| 1 |
- #' Univariate formula special term+ #' Occurrence table pruning |
|||
| 5 |
- #' The special term `univariate` indicate that the model should be fitted individually for+ #' Family of constructor and condition functions to flexibly prune occurrence tables. |
|||
| 6 |
- #' every variable included in univariate.+ #' The condition functions always return whether the row result is higher than the threshold. |
|||
| 7 |
- #'+ #' Since they are of class [CombinationFunction()] they can be logically combined with other condition |
|||
| 8 |
- #' @param x (`character`)\cr a vector of variable names separated by commas.+ #' functions. |
|||
| 10 |
- #' @return When used within a model formula, produces univariate models for each variable provided.+ #' @note Since most table specifications are worded positively, we name our constructor and condition |
|||
| 11 |
- #'+ #' functions positively, too. However, note that the result of [keep_rows()] says what |
|||
| 12 |
- #' @details+ #' should be pruned, to conform with the [rtables::prune_table()] interface. |
|||
| 13 |
- #' If provided alongside with pairwise specification, the model+ #' |
|||
| 14 |
- #' `y ~ ARM + univariate(SEX, AGE, RACE)` lead to the study and comparison of the models+ #' @examples |
|||
| 15 |
- #' + `y ~ ARM`+ #' \donttest{
|
|||
| 16 |
- #' + `y ~ ARM + SEX`+ #' tab <- basic_table() %>% |
|||
| 17 |
- #' + `y ~ ARM + AGE`+ #' split_cols_by("ARM") %>%
|
|||
| 18 |
- #' + `y ~ ARM + RACE`+ #' split_rows_by("RACE") %>%
|
|||
| 19 |
- #'+ #' split_rows_by("STRATA1") %>%
|
|||
| 20 |
- #' @export+ #' summarize_row_groups() %>% |
|||
| 21 |
- univariate <- function(x) {
+ #' analyze_vars("COUNTRY", .stats = "count_fraction") %>%
|
|||
| 22 | -2x | +
- structure(x, varname = deparse(substitute(x)))+ #' build_table(DM) |
||
| 23 |
- }+ #' } |
|||
| 24 |
-
+ #' |
|||
| 25 |
- # Get the right-hand-term of a formula+ #' @name prune_occurrences |
|||
| 26 |
- rht <- function(x) {
+ NULL |
|||
| 27 | -4x | +
- checkmate::assert_formula(x)+ |
||
| 28 | -4x | +
- y <- as.character(rev(x)[[1]])+ #' @describeIn prune_occurrences Constructor for creating pruning functions based on |
||
| 29 | -4x | +
- return(y)+ #' a row condition function. This removes all analysis rows (`TableRow`) that should be |
||
| 30 |
- }+ #' pruned, i.e., don't fulfill the row condition. It removes the sub-tree if there are no |
|||
| 31 |
-
+ #' children left. |
|||
| 32 |
- #' Hazard ratio estimation in interactions+ #' |
|||
| 33 |
- #'+ #' @param row_condition (`CombinationFunction`)\cr condition function which works on individual |
|||
| 34 |
- #' This function estimates the hazard ratios between arms when an interaction variable is given with+ #' analysis rows and flags whether these should be kept in the pruned table. |
|||
| 35 |
- #' specific values.+ #' |
|||
| 36 |
- #'+ #' @return |
|||
| 37 |
- #' @param variable,given (`character(2)`)\cr names of the two variables in the interaction. We seek the estimation of+ #' * `keep_rows()` returns a pruning function that can be used with [rtables::prune_table()] |
|||
| 38 |
- #' the levels of `variable` given the levels of `given`.+ #' to prune an `rtables` table. |
|||
| 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.+ #' @examples |
|||
| 41 |
- #' @param coef (`numeric`)\cr vector of estimated coefficients.+ #' \donttest{
|
|||
| 42 |
- #' @param vcov (`matrix`)\cr variance-covariance matrix of underlying model.+ #' # `keep_rows` |
|||
| 43 |
- #' @param conf_level (`proportion`)\cr confidence level of estimate intervals.+ #' is_non_empty <- !CombinationFunction(all_zero_or_na) |
|||
| 44 |
- #'+ #' prune_table(tab, keep_rows(is_non_empty)) |
|||
| 45 |
- #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A)+ #' } |
|||
| 46 |
- #' and Sex (F, M; reference Female). The model is abbreviated: y ~ Arm + Sex + Arm x Sex.+ #' |
|||
| 47 |
- #' The cox regression estimates the coefficients along with a variance-covariance matrix for:+ #' @export |
|||
| 48 |
- #'+ keep_rows <- function(row_condition) {
|
|||
| 49 | -+ | 6x |
- #' - b1 (arm b), b2 (arm c)+ checkmate::assert_function(row_condition) |
|
| 50 | -+ | 6x |
- #' - b3 (sex m)+ function(table_tree) {
|
|
| 51 | -+ | 2256x |
- #' - b4 (arm b: sex m), b5 (arm c: sex m)+ if (inherits(table_tree, "TableRow")) {
|
|
| 52 | -+ | 1872x |
- #'+ return(!row_condition(table_tree)) |
|
| 53 |
- #' Given that I want an estimation of the Hazard Ratio for arm C/sex M, the estimation+ } |
|||
| 54 | -+ | 384x |
- #' will be given in reference to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5),+ children <- tree_children(table_tree) |
|
| 55 | -+ | 384x |
- #' therefore the interaction coefficient is given by b2 + b5 while the standard error is obtained+ identical(length(children), 0L) |
|
| 56 |
- #' as $1.96 * sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$ for a confidence level of 0.95.+ } |
|||
| 57 |
- #'+ } |
|||
| 58 |
- #' @return A list of matrices (one per level of variable) with rows corresponding to the combinations of+ |
|||
| 59 |
- #' `variable` and `given`, with columns:+ #' @describeIn prune_occurrences Constructor for creating pruning functions based on |
|||
| 60 |
- #' * `coef_hat`: Estimation of the coefficient.+ #' a condition for the (first) content row in leaf tables. This removes all leaf tables where |
|||
| 61 |
- #' * `coef_se`: Standard error of the estimation.+ #' the first content row does not fulfill the condition. It does not check individual rows. |
|||
| 62 |
- #' * `hr`: Hazard ratio.+ #' It then proceeds recursively by removing the sub tree if there are no children left. |
|||
| 63 |
- #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio.+ #' |
|||
| 64 |
- #'+ #' @param content_row_condition (`CombinationFunction`)\cr condition function which works on individual |
|||
| 65 |
- #' @seealso [s_cox_multivariate()].+ #' first content rows of leaf tables and flags whether these leaf tables should be kept in the pruned table. |
|||
| 67 |
- #' @examples+ #' @return |
|||
| 68 |
- #' library(dplyr)+ #' * `keep_content_rows()` returns a pruning function that checks the condition on the first content |
|||
| 69 |
- #' library(survival)+ #' row of leaf tables in the table. |
|||
| 71 |
- #' ADSL <- tern_ex_adsl %>%+ #' @examples |
|||
| 72 |
- #' filter(SEX %in% c("F", "M"))
+ #' # `keep_content_rows` |
|||
| 73 |
- #'+ #' \donttest{
|
|||
| 74 |
- #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "PFS")+ #' more_than_twenty <- has_count_in_cols(atleast = 20L, col_names = names(tab)) |
|||
| 75 |
- #' adtte$ARMCD <- droplevels(adtte$ARMCD)+ #' prune_table(tab, keep_content_rows(more_than_twenty)) |
|||
| 76 |
- #' adtte$SEX <- droplevels(adtte$SEX)+ #' } |
|||
| 78 |
- #' mod <- coxph(+ #' @export |
|||
| 79 |
- #' formula = Surv(time = AVAL, event = 1 - CNSR) ~ (SEX + ARMCD)^2,+ keep_content_rows <- function(content_row_condition) {
|
|||
| 80 | -+ | 1x |
- #' data = adtte+ checkmate::assert_function(content_row_condition) |
|
| 81 | -+ | 1x |
- #' )+ function(table_tree) {
|
|
| 82 | -+ | 166x |
- #'+ if (is_leaf_table(table_tree)) {
|
|
| 83 | -+ | 24x |
- #' mmat <- stats::model.matrix(mod)[1, ]+ content_row <- h_content_first_row(table_tree) |
|
| 84 | -+ | 24x |
- #' mmat[!mmat == 0] <- 0+ return(!content_row_condition(content_row)) |
|
| 85 |
- #'+ } |
|||
| 86 | -+ | 142x |
- #' @keywords internal+ if (inherits(table_tree, "DataRow")) {
|
|
| 87 | -+ | 120x |
- estimate_coef <- function(variable, given,+ return(FALSE) |
|
| 88 |
- lvl_var, lvl_given,+ } |
|||
| 89 | -+ | 22x |
- coef,+ children <- tree_children(table_tree) |
|
| 90 | -+ | 22x |
- mmat,+ identical(length(children), 0L) |
|
| 91 |
- vcov,+ } |
|||
| 92 |
- conf_level = 0.95) {
+ } |
|||
| 93 | -8x | +
- var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level+ |
||
| 94 | -8x | +
- giv_lvl <- paste0(given, lvl_given)+ #' @describeIn prune_occurrences Constructor for creating condition functions on total counts in the specified columns. |
||
| 95 |
-
+ #' |
|||
| 96 | -8x | +
- design_mat <- expand.grid(variable = var_lvl, given = giv_lvl)+ #' @param atleast (`numeric(1)`)\cr threshold which should be met in order to keep the row. |
||
| 97 | -8x | +
- design_mat <- design_mat[order(design_mat$variable, design_mat$given), ]+ #' @param ... arguments for row or column access, see [`rtables_access`]: either `col_names` (`character`) including |
||
| 98 | -8x | +
- design_mat <- within(+ #' the names of the columns which should be used, or alternatively `col_indices` (`integer`) giving the indices |
||
| 99 | -8x | +
- data = design_mat,+ #' directly instead. |
||
| 100 | -8x | +
- expr = {
+ #' |
||
| 101 | -8x | +
- inter <- paste0(variable, ":", given)+ #' @return |
||
| 102 | -8x | +
- rev_inter <- paste0(given, ":", variable)+ #' * `has_count_in_cols()` returns a condition function that sums the counts in the specified column. |
||
| 103 |
- }+ #' |
|||
| 104 |
- )+ #' @examples |
|||
| 105 |
-
+ #' \donttest{
|
|||
| 106 | -8x | +
- split_by_variable <- design_mat$variable+ #' more_than_one <- has_count_in_cols(atleast = 1L, col_names = names(tab)) |
||
| 107 | -8x | +
- interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/")+ #' prune_table(tab, keep_rows(more_than_one)) |
||
| 108 |
-
+ #' } |
|||
| 109 | -8x | +
- design_mat <- apply(+ #' |
||
| 110 | -8x | +
- X = design_mat, MARGIN = 1, FUN = function(x) {
+ #' @export |
||
| 111 | -27x | +
- mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1+ has_count_in_cols <- function(atleast, ...) {
|
||
| 112 | -27x | +6x |
- return(mmat)+ checkmate::assert_count(atleast) |
|
| 113 | -+ | 6x |
- }+ CombinationFunction(function(table_row) {
|
|
| 114 | -+ | 337x |
- )+ row_counts <- h_row_counts(table_row, ...) |
|
| 115 | -8x | +337x |
- colnames(design_mat) <- interaction_names+ total_count <- sum(row_counts) |
|
| 116 | -+ | 337x |
-
+ total_count >= atleast |
|
| 117 | -8x | +
- betas <- as.matrix(coef)+ }) |
||
| 118 |
-
+ } |
|||
| 119 | -8x | +
- coef_hat <- t(design_mat) %*% betas+ |
||
| 120 | -8x | +
- dimnames(coef_hat)[2] <- "coef"+ #' @describeIn prune_occurrences Constructor for creating condition functions on any of the counts in |
||
| 121 |
-
+ #' the specified columns satisfying a threshold. |
|||
| 122 | -8x | +
- coef_se <- apply(design_mat, 2, function(x) {
+ #' |
||
| 123 | -27x | +
- vcov_el <- as.logical(x)+ #' @param atleast (`numeric(1)`)\cr threshold which should be met in order to keep the row. |
||
| 124 | -27x | +
- y <- vcov[vcov_el, vcov_el]+ #' |
||
| 125 | -27x | +
- y <- sum(y)+ #' @return |
||
| 126 | -27x | +
- y <- sqrt(y)+ #' * `has_count_in_any_col()` returns a condition function that compares the counts in the |
||
| 127 | -27x | +
- return(y)+ #' specified columns with the threshold. |
||
| 128 |
- })+ #' |
|||
| 129 |
-
+ #' @examples |
|||
| 130 | -8x | +
- q_norm <- stats::qnorm((1 + conf_level) / 2)+ #' \donttest{
|
||
| 131 | -8x | +
- y <- cbind(coef_hat, `se(coef)` = coef_se)+ #' # `has_count_in_any_col` |
||
| 132 |
-
+ #' any_more_than_one <- has_count_in_any_col(atleast = 1L, col_names = names(tab)) |
|||
| 133 | -8x | +
- y <- apply(y, 1, function(x) {
+ #' prune_table(tab, keep_rows(any_more_than_one)) |
||
| 134 | -27x | +
- x["hr"] <- exp(x["coef"])+ #' } |
||
| 135 | -27x | +
- x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"])+ #' |
||
| 136 | -27x | +
- x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"])+ #' @export |
||
| 137 |
-
+ has_count_in_any_col <- function(atleast, ...) {
|
|||
| 138 | -27x | +3x |
- return(x)+ checkmate::assert_count(atleast) |
|
| 139 | -+ | 3x |
- })+ CombinationFunction(function(table_row) {
|
|
| 140 | -+ | 3x |
-
+ row_counts <- h_row_counts(table_row, ...) |
|
| 141 | -8x | +3x |
- y <- t(y)+ any(row_counts >= atleast) |
|
| 142 | -8x | +
- y <- by(y, split_by_variable, identity)+ }) |
||
| 143 | -8x | +
- y <- lapply(y, as.matrix)+ } |
||
| 145 | -8x | +
- attr(y, "details") <- paste0(+ #' @describeIn prune_occurrences Constructor for creating condition functions on total fraction in |
||
| 146 | -8x | +
- "Estimations of ", variable,+ #' the specified columns. |
||
| 147 | -8x | +
- " hazard ratio given the level of ", given, " compared to ",+ #' |
||
| 148 | -8x | +
- variable, " level ", lvl_var[1], "."+ #' @return |
||
| 149 |
- )+ #' * `has_fraction_in_cols()` returns a condition function that sums the counts in the |
|||
| 150 | -8x | +
- return(y)+ #' specified column, and computes the fraction by dividing by the total column counts. |
||
| 151 |
- }+ #' |
|||
| 152 |
-
+ #' @examples |
|||
| 153 |
- #' `tryCatch` around `car::Anova`+ #' \donttest{
|
|||
| 154 |
- #'+ #' # `has_fraction_in_cols` |
|||
| 155 |
- #' Captures warnings when executing [car::Anova].+ #' more_than_five_percent <- has_fraction_in_cols(atleast = 0.05, col_names = names(tab)) |
|||
| 156 |
- #'+ #' prune_table(tab, keep_rows(more_than_five_percent)) |
|||
| 157 |
- #' @inheritParams car::Anova+ #' } |
|||
| 159 |
- #' @return A list with item `aov` for the result of the model and `error_text` for the captured warnings.+ #' @export |
|||
| 160 |
- #'+ has_fraction_in_cols <- function(atleast, ...) {
|
|||
| 161 | -+ | 4x |
- #' @examples+ assert_proportion_value(atleast, include_boundaries = TRUE) |
|
| 162 | -+ | 4x |
- #' # `car::Anova` on cox regression model including strata and expected+ CombinationFunction(function(table_row) {
|
|
| 163 | -+ | 306x |
- #' # a likelihood ratio test triggers a warning as only Wald method is+ row_counts <- h_row_counts(table_row, ...) |
|
| 164 | -+ | 306x |
- #' # accepted.+ total_count <- sum(row_counts) |
|
| 165 | -+ | 306x |
- #'+ col_counts <- h_col_counts(table_row, ...) |
|
| 166 | -+ | 306x |
- #' library(survival)+ total_n <- sum(col_counts) |
|
| 167 | -+ | 306x |
- #'+ total_percent <- total_count / total_n |
|
| 168 | -+ | 306x |
- #' mod <- coxph(+ total_percent >= atleast |
|
| 169 |
- #' formula = Surv(time = futime, event = fustat) ~ factor(rx) + strata(ecog.ps),+ }) |
|||
| 170 |
- #' data = ovarian+ } |
|||
| 171 |
- #' )+ |
|||
| 172 |
- #'+ #' @describeIn prune_occurrences Constructor for creating condition functions on any fraction in |
|||
| 173 |
- #' @keywords internal+ #' the specified columns. |
|||
| 174 |
- try_car_anova <- function(mod,+ #' |
|||
| 175 |
- test.statistic) { # nolint
+ #' @return |
|||
| 176 | -2x | +
- y <- tryCatch(+ #' * `has_fraction_in_any_col()` returns a condition function that looks at the fractions |
||
| 177 | -2x | +
- withCallingHandlers(+ #' in the specified columns and checks whether any of them fulfill the threshold. |
||
| 178 | -2x | +
- expr = {
+ #' |
||
| 179 | -2x | +
- warn_text <- c()+ #' @examples |
||
| 180 | -2x | +
- list(+ #' \donttest{
|
||
| 181 | -2x | +
- aov = car::Anova(+ #' # `has_fraction_in_any_col` |
||
| 182 | -2x | +
- mod,+ #' any_atleast_five_percent <- has_fraction_in_any_col(atleast = 0.05, col_names = names(tab)) |
||
| 183 | -2x | +
- test.statistic = test.statistic,+ #' prune_table(tab, keep_rows(any_atleast_five_percent)) |
||
| 184 | -2x | +
- type = "III"+ #' } |
||
| 185 |
- ),+ #' |
|||
| 186 | -2x | +
- warn_text = warn_text+ #' @export |
||
| 187 |
- )+ has_fraction_in_any_col <- function(atleast, ...) {
|
|||
| 188 | -+ | 3x |
- },+ assert_proportion_value(atleast, include_boundaries = TRUE) |
|
| 189 | -2x | +3x |
- warning = function(w) {
+ CombinationFunction(function(table_row) {
|
|
| 190 | -+ | 3x |
- # If a warning is detected it is handled as "w".+ row_fractions <- h_row_fractions(table_row, ...) |
|
| 191 | -! | +3x |
- warn_text <<- trimws(paste0("Warning in `try_car_anova`: ", w))
+ any(row_fractions >= atleast) |
|
| 192 |
-
+ }) |
|||
| 193 |
- # A warning is sometimes expected, then, we want to restart+ } |
|||
| 194 |
- # the execution while ignoring the warning.+ |
|||
| 195 | -! | +
- invokeRestart("muffleWarning")
+ #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference |
||
| 196 |
- }+ #' between the fractions reported in each specified column. |
|||
| 197 |
- ),+ #' |
|||
| 198 | -2x | +
- finally = {
+ #' @return |
||
| 199 |
- }+ #' * `has_fractions_difference()` returns a condition function that extracts the fractions of each |
|||
| 200 |
- )+ #' specified column, and computes the difference of the minimum and maximum. |
|||
| 201 |
-
+ #' |
|||
| 202 | -2x | +
- return(y)+ #' @examples |
||
| 203 |
- }+ #' \donttest{
|
|||
| 204 |
-
+ #' # `has_fractions_difference` |
|||
| 205 |
- #' Fit a Cox regression model and ANOVA+ #' more_than_five_percent_diff <- has_fractions_difference(atleast = 0.05, col_names = names(tab)) |
|||
| 206 |
- #'+ #' prune_table(tab, keep_rows(more_than_five_percent_diff)) |
|||
| 207 |
- #' The functions derives the effect p-values using [car::Anova()] from [survival::coxph()] results.+ #' } |
|||
| 209 |
- #' @inheritParams t_coxreg+ #' @export |
|||
| 210 |
- #'+ has_fractions_difference <- function(atleast, ...) {
|
|||
| 211 | -+ | 4x |
- #' @return A list with items `mod` (results of [survival::coxph()]), `msum` (result of `summary`) and+ assert_proportion_value(atleast, include_boundaries = TRUE) |
|
| 212 | -+ | 4x |
- #' `aov` (result of [car::Anova()]).+ CombinationFunction(function(table_row) {
|
|
| 213 | -+ | 246x |
- #'+ fractions <- h_row_fractions(table_row, ...) |
|
| 214 | -+ | 246x |
- #' @noRd+ difference <- diff(range(fractions)) |
|
| 215 | -+ | 246x |
- fit_n_aov <- function(formula,+ difference >= atleast |
|
| 216 | - |
- data = data,- |
- ||
| 217 | -- |
- conf_level = conf_level,- |
- ||
| 218 | -- |
- pval_method = c("wald", "likelihood"),
- |
- ||
| 219 | -- |
- ...) {
- |
- ||
| 220 | -1x | -
- pval_method <- match.arg(pval_method)- |
- ||
| 221 | -- | - - | -||
| 222 | -1x | -
- environment(formula) <- environment()- |
- ||
| 223 | -1x | -
- suppressWarnings({
- |
- ||
| 224 | -- |
- # We expect some warnings due to coxph which fails strict programming.- |
- ||
| 225 | -1x | -
- mod <- survival::coxph(formula, data = data, ...)- |
- ||
| 226 | -1x | -
- msum <- summary(mod, conf.int = conf_level)- |
- ||
| 227 | -
}) |
|||
| 228 | -- | - - | -||
| 229 | -1x | -
- aov <- try_car_anova(- |
- ||
| 230 | -1x | -
- mod,- |
- ||
| 231 | -1x | -
- test.statistic = switch(pval_method,- |
- ||
| 232 | -1x | -
- "wald" = "Wald",- |
- ||
| 233 | -1x | -
- "likelihood" = "LR"- |
- ||
| 234 | -- |
- )- |
- ||
| 235 | -- |
- )- |
- ||
| 236 | -- | - - | -||
| 237 | -1x | -
- warn_attr <- aov$warn_text- |
- ||
| 238 | -! | -
- if (!is.null(aov$warn_text)) message(warn_attr)- |
- ||
| 239 | -- | - - | -||
| 240 | -1x | -
- aov <- aov$aov- |
- ||
| 241 | -1x | -
- y <- list(mod = mod, msum = msum, aov = aov)- |
- ||
| 242 | -1x | -
- attr(y, "message") <- warn_attr- |
- ||
| 243 | -- | - - | -||
| 244 | -1x | -
- return(y)- |
- ||
| 245 | +217 |
} |
||
| 246 | +218 | |||
| 247 | +219 |
- # argument_checks+ #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference |
||
| 248 | +220 |
- check_formula <- function(formula) {
- |
- ||
| 249 | -1x | -
- if (!(inherits(formula, "formula"))) {
- |
- ||
| 250 | -1x | -
- stop("Check `formula`. A formula should resemble `Surv(time = AVAL, event = 1 - CNSR) ~ study_arm(ARMCD)`.")
+ #' between the counts reported in each specified column. |
||
| 251 | +221 |
- }+ #' |
||
| 252 | +222 | - - | -||
| 253 | -! | -
- invisible()+ #' @return |
||
| 254 | +223 |
- }+ #' * `has_counts_difference()` returns a condition function that extracts the counts of each |
||
| 255 | +224 |
-
+ #' specified column, and computes the difference of the minimum and maximum. |
||
| 256 | +225 |
- check_covariate_formulas <- function(covariates) {
- |
- ||
| 257 | -1x | -
- if (!all(vapply(X = covariates, FUN = inherits, what = "formula", FUN.VALUE = TRUE)) || is.null(covariates)) {
- |
- ||
| 258 | -1x | -
- stop("Check `covariates`, it should be a list of right-hand-term formulas, e.g. list(Age = ~AGE).")
+ #' |
||
| 259 | +226 |
- }+ #' @examples |
||
| 260 | +227 | - - | -||
| 261 | -! | -
- invisible()+ #' \donttest{
|
||
| 262 | +228 |
- }+ #' more_than_one_diff <- has_counts_difference(atleast = 1L, col_names = names(tab)) |
||
| 263 | +229 |
-
+ #' prune_table(tab, keep_rows(more_than_one_diff)) |
||
| 264 | +230 |
- name_covariate_names <- function(covariates) {
- |
- ||
| 265 | -1x | -
- miss_names <- names(covariates) == ""- |
- ||
| 266 | -1x | -
- no_names <- is.null(names(covariates))- |
- ||
| 267 | -! | -
- if (any(miss_names)) names(covariates)[miss_names] <- vapply(covariates[miss_names], FUN = rht, FUN.VALUE = "name")- |
- ||
| 268 | -! | -
- if (no_names) names(covariates) <- vapply(covariates, FUN = rht, FUN.VALUE = "name")- |
- ||
| 269 | -1x | -
- return(covariates)+ #' } |
||
| 270 | +231 |
- }+ #' |
||
| 271 | +232 |
-
+ #' @export |
||
| 272 | +233 |
- check_increments <- function(increments, covariates) {
- |
- ||
| 273 | -1x | -
- if (!is.null(increments)) {
- |
- ||
| 274 | -1x | -
- covariates <- vapply(covariates, FUN = rht, FUN.VALUE = "name")- |
- ||
| 275 | -1x | -
- lapply(- |
- ||
| 276 | -1x | -
- X = names(increments), FUN = function(x) {
+ has_counts_difference <- function(atleast, ...) {
|
||
| 277 | -3x | +234 | +4x |
- if (!x %in% covariates) {
+ checkmate::assert_count(atleast) |
| 278 | -1x | +235 | +4x |
- warning(+ CombinationFunction(function(table_row) {
|
| 279 | -1x | +236 | +30x |
- paste(+ counts <- h_row_counts(table_row, ...) |
| 280 | -1x | +237 | +30x |
- "Check `increments`, the `increment` for ", x,+ difference <- diff(range(counts)) |
| 281 | -1x | +238 | +30x |
- "doesn't match any names in investigated covariate(s)."+ difference >= atleast |
| 282 | +239 |
- )+ }) |
||
| 283 | +240 |
- )+ } |
| 284 | +1 |
- }+ #' Cox proportional hazards regression |
|
| 285 | +2 |
- }+ #' |
|
| 286 | +3 |
- )+ #' @description `r lifecycle::badge("stable")`
|
|
| 287 | +4 |
- }+ #' |
|
| 288 | +5 |
-
+ #' Fits a Cox regression model and estimates hazard ratio to describe the effect size in a survival analysis. |
|
| 289 | -1x | +||
| 6 | +
- invisible()+ #' |
||
| 290 | +7 |
- }+ #' @inheritParams argument_convention |
|
| 291 | +8 |
-
+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("summarize_coxreg")`
|
|
| 292 | +9 |
- #' Multivariate Cox model - summarized results+ #' to see available statistics for this function. |
|
| 293 | +10 |
#' |
|
| 294 | +11 |
- #' Analyses based on multivariate Cox model are usually not performed for the Controlled Substance Reporting or+ #' @details Cox models are the most commonly used methods to estimate the magnitude of |
|
| 295 | +12 |
- #' regulatory documents but serve exploratory purposes only (e.g., for publication). In practice, the model usually+ #' the effect in survival analysis. It assumes proportional hazards: the ratio |
|
| 296 | +13 |
- #' includes only the main effects (without interaction terms). It produces the hazard ratio estimates for each of the+ #' of the hazards between groups (e.g., two arms) is constant over time. |
|
| 297 | +14 |
- #' covariates included in the model.+ #' This ratio is referred to as the "hazard ratio" (HR) and is one of the |
|
| 298 | +15 |
- #' The analysis follows the same principles (e.g., stratified vs. unstratified analysis and tie handling) as the+ #' most commonly reported metrics to describe the effect size in survival |
|
| 299 | +16 |
- #' usual Cox model analysis. Since there is usually no pre-specified hypothesis testing for such analysis,+ #' analysis (NEST Team, 2020). |
|
| 300 | +17 |
- #' the p.values need to be interpreted with caution. (**Statistical Analysis of Clinical Trials Data with R**,+ #' |
|
| 301 | +18 |
- #' `NEST's bookdown`)+ #' @seealso [fit_coxreg] for relevant fitting functions, [h_cox_regression] for relevant |
|
| 302 | +19 |
- #'+ #' helper functions, and [tidy_coxreg] for custom tidy methods. |
|
| 303 | +20 |
- #' @param formula (`formula`)\cr a formula corresponding to the investigated [survival::Surv()] survival model+ #' |
|
| 304 | +21 |
- #' including covariates.+ #' @examples |
|
| 305 | +22 |
- #' @param data (`data.frame`)\cr a data frame which includes the variable in formula and covariates.+ #' library(survival) |
|
| 306 | +23 |
- #' @param conf_level (`proportion`)\cr the confidence level for the hazard ratio interval estimations. Default is 0.95.+ #' |
|
| 307 | +24 |
- #' @param pval_method (`string`)\cr the method used for the estimation of p-values, should be one of+ #' # Testing dataset [survival::bladder]. |
|
| 308 | +25 |
- #' `"wald"` (default) or `"likelihood"`.+ #' set.seed(1, kind = "Mersenne-Twister") |
|
| 309 | +26 |
- #' @param ... optional parameters passed to [survival::coxph()]. Can include `ties`, a character string specifying the+ #' dta_bladder <- with( |
|
| 310 | +27 |
- #' method for tie handling, one of `exact` (default), `efron`, `breslow`.+ #' data = bladder[bladder$enum < 5, ], |
|
| 311 | +28 |
- #'+ #' tibble::tibble( |
|
| 312 | +29 |
- #' @return A `list` with elements `mod`, `msum`, `aov`, and `coef_inter`.+ #' TIME = stop, |
|
| 313 | +30 |
- #'+ #' STATUS = event, |
|
| 314 | +31 |
- #' @details The output is limited to single effect terms. Work in ongoing for estimation of interaction terms+ #' ARM = as.factor(rx), |
|
| 315 | +32 |
- #' but is out of scope as defined by the Global Data Standards Repository+ #' COVAR1 = as.factor(enum) %>% formatters::with_label("A Covariate Label"),
|
|
| 316 | +33 |
- #' (**`GDS_Standard_TLG_Specs_Tables_2.doc`**).+ #' COVAR2 = factor( |
|
| 317 | +34 |
- #'+ #' sample(as.factor(enum)), |
|
| 318 | +35 |
- #' @seealso [estimate_coef()].+ #' levels = 1:4, labels = c("F", "F", "M", "M")
|
|
| 319 | +36 |
- #'+ #' ) %>% formatters::with_label("Sex (F/M)")
|
|
| 320 | +37 |
- #' @examples+ #' ) |
|
| 321 | +38 |
- #' library(dplyr)+ #' ) |
|
| 322 | +39 |
- #'+ #' dta_bladder$AGE <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
|
| 323 | +40 |
- #' adtte <- tern_ex_adtte+ #' dta_bladder$STUDYID <- factor("X")
|
|
| 324 | +41 |
- #' adtte_f <- subset(adtte, PARAMCD == "OS") # _f: filtered+ #' |
|
| 325 | +42 |
- #' adtte_f <- filter(+ #' u1_variables <- list( |
|
| 326 | +43 |
- #' adtte_f,+ #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
|
|
| 327 | +44 |
- #' PARAMCD == "OS" &+ #' ) |
|
| 328 | +45 |
- #' SEX %in% c("F", "M") &
+ #' |
|
| 329 | +46 |
- #' RACE %in% c("ASIAN", "BLACK OR AFRICAN AMERICAN", "WHITE")
+ #' u2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
|
|
| 330 | +47 |
- #' )+ #' |
|
| 331 | +48 |
- #' adtte_f$SEX <- droplevels(adtte_f$SEX)+ #' m1_variables <- list( |
|
| 332 | +49 |
- #' adtte_f$RACE <- droplevels(adtte_f$RACE)+ #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
|
|
| 333 | +50 |
- #'+ #' ) |
|
| 334 | +51 |
- #' @keywords internal+ #' |
|
| 335 | +52 |
- s_cox_multivariate <- function(formula, data,+ #' m2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
|
|
| 336 | +53 |
- conf_level = 0.95,+ #' |
|
| 337 | +54 |
- pval_method = c("wald", "likelihood"),
+ #' @name cox_regression |
|
| 338 | +55 |
- ...) {
+ #' @order 1 |
|
| 339 | -1x | +||
| 56 | +
- tf <- stats::terms(formula, specials = c("strata"))
+ NULL |
||
| 340 | -1x | +||
| 57 | +
- covariates <- rownames(attr(tf, "factors"))[-c(1, unlist(attr(tf, "specials")))]+ |
||
| 341 | -1x | +||
| 58 | +
- lapply(+ #' @describeIn cox_regression Statistics function that transforms results tabulated |
||
| 342 | -1x | +||
| 59 | +
- X = covariates,+ #' from [fit_coxreg_univar()] or [fit_coxreg_multivar()] into a list. |
||
| 343 | -1x | +||
| 60 | +
- FUN = function(x) {
+ #' |
||
| 344 | -3x | +||
| 61 | +
- if (is.character(data[[x]])) {
+ #' @param model_df (`data.frame`)\cr contains the resulting model fit from a [fit_coxreg] |
||
| 345 | -1x | +||
| 62 | +
- data[[x]] <<- as.factor(data[[x]])+ #' function with tidying applied via [broom::tidy()]. |
||
| 346 | +63 |
- }+ #' @param .stats (`character`)\cr the names of statistics to be reported among: |
|
| 347 | -3x | +||
| 64 | +
- invisible()+ #' * `n`: number of observations (univariate only) |
||
| 348 | +65 |
- }+ #' * `hr`: hazard ratio |
|
| 349 | +66 |
- )+ #' * `ci`: confidence interval |
|
| 350 | -1x | +||
| 67 | +
- pval_method <- match.arg(pval_method)+ #' * `pval`: p-value of the treatment effect |
||
| 351 | +68 |
-
+ #' * `pval_inter`: p-value of the interaction effect between the treatment and the covariate (univariate only) |
|
| 352 | +69 |
- # Results directly exported from environment(fit_n_aov) to environment(s_function_draft)+ #' @param .which_vars (`character`)\cr which rows should statistics be returned for from the given model. |
|
| 353 | -1x | +||
| 70 | +
- y <- fit_n_aov(+ #' Defaults to `"all"`. Other options include `"var_main"` for main effects, `"inter"` for interaction effects, |
||
| 354 | -1x | +||
| 71 | +
- formula = formula,+ #' and `"multi_lvl"` for multivariate model covariate level rows. When `.which_vars` is `"all"`, specific |
||
| 355 | -1x | +||
| 72 | +
- data = data,+ #' variables can be selected by specifying `.var_nms`. |
||
| 356 | -1x | +||
| 73 | +
- conf_level = conf_level,+ #' @param .var_nms (`character`)\cr the `term` value of rows in `df` for which `.stats` should be returned. Typically |
||
| 357 | -1x | +||
| 74 | +
- pval_method = pval_method,+ #' this is the name of a variable. If using variable labels, `var` should be a vector of both the desired |
||
| 358 | +75 |
- ...+ #' variable name and the variable label in that order to see all `.stats` related to that variable. When `.which_vars` |
|
| 359 | +76 |
- )+ #' is `"var_main"`, `.var_nms` should be only the variable name. |
|
| 360 | -1x | +||
| 77 | +
- mod <- y$mod+ #' |
||
| 361 | -1x | +||
| 78 | +
- aov <- y$aov+ #' @return |
||
| 362 | -1x | +||
| 79 | +
- msum <- y$msum+ #' * `s_coxreg()` returns the selected statistic for from the Cox regression model for the selected variable(s). |
||
| 363 | -1x | +||
| 80 | +
- list2env(as.list(y), environment())+ #' |
||
| 364 | +81 |
-
+ #' @examples |
|
| 365 | -1x | +||
| 82 | +
- all_term_labs <- attr(mod$terms, "term.labels")+ #' # s_coxreg |
||
| 366 | -1x | +||
| 83 | +
- term_labs <- all_term_labs[which(attr(mod$terms, "order") == 1)]+ #' |
||
| 367 | -1x | +||
| 84 | +
- names(term_labs) <- term_labs+ #' # Univariate |
||
| 368 | +85 |
-
+ #' univar_model <- fit_coxreg_univar(variables = u1_variables, data = dta_bladder) |
|
| 369 | -1x | +||
| 86 | +
- coef_inter <- NULL+ #' df1 <- broom::tidy(univar_model) |
||
| 370 | -1x | +||
| 87 | +
- if (any(attr(mod$terms, "order") > 1)) {
+ #' |
||
| 371 | -1x | +||
| 88 | +
- for_inter <- all_term_labs[attr(mod$terms, "order") > 1]+ #' s_coxreg(model_df = df1, .stats = "hr") |
||
| 372 | -1x | +||
| 89 | +
- names(for_inter) <- for_inter+ #' |
||
| 373 | -1x | +||
| 90 | +
- mmat <- stats::model.matrix(mod)[1, ]+ #' # Univariate with interactions |
||
| 374 | -1x | +||
| 91 | +
- mmat[!mmat == 0] <- 0+ #' univar_model_inter <- fit_coxreg_univar( |
||
| 375 | -1x | +||
| 92 | +
- mcoef <- stats::coef(mod)+ #' variables = u1_variables, control = control_coxreg(interaction = TRUE), data = dta_bladder |
||
| 376 | -1x | +||
| 93 | +
- mvcov <- stats::vcov(mod)+ #' ) |
||
| 377 | +94 |
-
+ #' df1_inter <- broom::tidy(univar_model_inter) |
|
| 378 | -1x | +||
| 95 | +
- estimate_coef_local <- function(variable, given) {
+ #' |
||
| 379 | -6x | +||
| 96 | +
- estimate_coef(+ #' s_coxreg(model_df = df1_inter, .stats = "hr", .which_vars = "inter", .var_nms = "COVAR1") |
||
| 380 | -6x | +||
| 97 | +
- variable, given,+ #' |
||
| 381 | -6x | +||
| 98 | +
- coef = mcoef, mmat = mmat, vcov = mvcov, conf_level = conf_level,+ #' # Univariate without treatment arm - only "COVAR2" covariate effects |
||
| 382 | -6x | +||
| 99 | +
- lvl_var = levels(data[[variable]]), lvl_given = levels(data[[given]])+ #' univar_covs_model <- fit_coxreg_univar(variables = u2_variables, data = dta_bladder) |
||
| 383 | +100 |
- )+ #' df1_covs <- broom::tidy(univar_covs_model) |
|
| 384 | +101 |
- }+ #' |
|
| 385 | +102 |
-
+ #' s_coxreg(model_df = df1_covs, .stats = "hr", .var_nms = c("COVAR2", "Sex (F/M)"))
|
|
| 386 | -1x | +||
| 103 | +
- coef_inter <- lapply(+ #' |
||
| 387 | -1x | +||
| 104 | +
- for_inter, function(x) {
+ #' # Multivariate. |
||
| 388 | -3x | +||
| 105 | +
- y <- attr(mod$terms, "factors")[, x]+ #' multivar_model <- fit_coxreg_multivar(variables = m1_variables, data = dta_bladder) |
||
| 389 | -3x | +||
| 106 | +
- y <- names(y[y > 0])+ #' df2 <- broom::tidy(multivar_model) |
||
| 390 | -3x | +||
| 107 | +
- Map(estimate_coef_local, variable = y, given = rev(y))+ #' |
||
| 391 | +108 |
- }+ #' s_coxreg(model_df = df2, .stats = "pval", .which_vars = "var_main", .var_nms = "COVAR1") |
|
| 392 | +109 |
- )+ #' s_coxreg( |
|
| 393 | +110 |
- }+ #' model_df = df2, .stats = "pval", .which_vars = "multi_lvl", |
|
| 394 | +111 |
-
+ #' .var_nms = c("COVAR1", "A Covariate Label")
|
|
| 395 | -1x | +||
| 112 | +
- list(mod = mod, msum = msum, aov = aov, coef_inter = coef_inter)+ #' ) |
||
| 396 | +113 |
- }+ #' |
| 1 | +114 |
- #' Proportion difference estimation+ #' # Multivariate without treatment arm - only "COVAR1" main effect |
||
| 2 | +115 |
- #'+ #' multivar_covs_model <- fit_coxreg_multivar(variables = m2_variables, data = dta_bladder) |
||
| 3 | +116 |
- #' @description `r lifecycle::badge("stable")`
+ #' df2_covs <- broom::tidy(multivar_covs_model) |
||
| 4 | +117 |
#' |
||
| 5 | +118 |
- #' The analysis function [estimate_proportion_diff()] creates a layout element to estimate the difference in proportion+ #' s_coxreg(model_df = df2_covs, .stats = "hr") |
||
| 6 | +119 |
- #' of responders within a studied population. The primary analysis variable, `vars`, is a logical variable indicating+ #' |
||
| 7 | +120 |
- #' whether a response has occurred for each record. See the `method` parameter for options of methods to use when+ #' @export |
||
| 8 | +121 |
- #' constructing the confidence interval of the proportion difference. A stratification variable can be supplied via the+ s_coxreg <- function(model_df, .stats, .which_vars = "all", .var_nms = NULL) {
|
||
| 9 | -+ | |||
| 122 | +291x |
- #' `strata` element of the `variables` argument.+ assert_df_with_variables(model_df, list(term = "term", stat = .stats)) |
||
| 10 | -+ | |||
| 123 | +291x |
- #'+ checkmate::assert_multi_class(model_df$term, classes = c("factor", "character"))
|
||
| 11 | -+ | |||
| 124 | +291x |
- #'+ model_df$term <- as.character(model_df$term) |
||
| 12 | -+ | |||
| 125 | +291x |
- #' @inheritParams prop_diff_strat_nc+ .var_nms <- .var_nms[!is.na(.var_nms)] |
||
| 13 | +126 |
- #' @inheritParams argument_convention+ |
||
| 14 | -+ | |||
| 127 | +289x |
- #' @param method (`string`)\cr the method used for the confidence interval estimation.+ if (length(.var_nms) > 0) model_df <- model_df[model_df$term %in% .var_nms, ] |
||
| 15 | -+ | |||
| 128 | +69x |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_proportion_diff")`
+ if (.which_vars == "multi_lvl") model_df$term <- tail(.var_nms, 1) |
||
| 16 | +129 |
- #' to see available statistics for this function.+ |
||
| 17 | +130 |
- #'+ # We need a list with names corresponding to the stats to display of equal length to the list of stats. |
||
| 18 | -+ | |||
| 131 | +291x |
- #' @seealso [d_proportion_diff()]+ y <- split(model_df, f = model_df$term, drop = FALSE) |
||
| 19 | -+ | |||
| 132 | +291x |
- #'+ y <- stats::setNames(y, nm = rep(.stats, length(y))) |
||
| 20 | +133 |
- #' @name prop_diff+ + |
+ ||
| 134 | +291x | +
+ if (.which_vars == "var_main") {
+ |
+ ||
| 135 | +128x | +
+ y <- lapply(y, function(x) x[1, ]) # only main effect+ |
+ ||
| 136 | +163x | +
+ } else if (.which_vars %in% c("inter", "multi_lvl")) {
+ |
+ ||
| 137 | +120x | +
+ y <- lapply(y, function(x) if (nrow(y[[1]]) > 1) x[-1, ] else x) # exclude main effect |
||
| 21 | +138 |
- #' @order 1+ } |
||
| 22 | +139 |
- NULL+ + |
+ ||
| 140 | +291x | +
+ lapply(+ |
+ ||
| 141 | +291x | +
+ X = y,+ |
+ ||
| 142 | +291x | +
+ FUN = function(x) {
+ |
+ ||
| 143 | +295x | +
+ z <- as.list(x[[.stats]])+ |
+ ||
| 144 | +295x | +
+ stats::setNames(z, nm = x$term_label) |
||
| 23 | +145 |
-
+ } |
||
| 24 | +146 |
- #' @describeIn prop_diff Statistics function estimating the difference+ ) |
||
| 25 | +147 |
- #' in terms of responder proportion.+ } |
||
| 26 | +148 |
- #'+ |
||
| 27 | +149 |
- #' @return+ #' @describeIn cox_regression Analysis function which is used as `afun` in [rtables::analyze()] |
||
| 28 | +150 |
- #' * `s_proportion_diff()` returns a named list of elements `diff` and `diff_ci`.+ #' and `cfun` in [rtables::summarize_row_groups()] within `summarize_coxreg()`. |
||
| 29 | +151 |
#' |
||
| 30 | +152 |
- #' @note When performing an unstratified analysis, methods `"cmh"`, `"strat_newcombe"`, and `"strat_newcombecc"` are+ #' @param eff (`flag`)\cr whether treatment effect should be calculated. Defaults to `FALSE`. |
||
| 31 | +153 |
- #' not permitted.+ #' @param var_main (`flag`)\cr whether main effects should be calculated. Defaults to `FALSE`. |
||
| 32 | +154 |
- #'+ #' @param na_str (`string`)\cr custom string to replace all `NA` values with. Defaults to `""`. |
||
| 33 | +155 |
- #' @examples+ #' @param cache_env (`environment`)\cr an environment object used to cache the regression model in order to |
||
| 34 | +156 |
- #' s_proportion_diff(+ #' avoid repeatedly fitting the same model for every row in the table. Defaults to `NULL` (no caching). |
||
| 35 | +157 |
- #' df = subset(dta, grp == "A"),+ #' @param varlabels (`list`)\cr a named list corresponds to the names of variables found in data, passed |
||
| 36 | +158 |
- #' .var = "rsp",+ #' as a named list and corresponding to time, event, arm, strata, and covariates terms. If arm is missing |
||
| 37 | +159 |
- #' .ref_group = subset(dta, grp == "B"),+ #' from variables, then only Cox model(s) including the covariates will be fitted and the corresponding |
||
| 38 | +160 |
- #' .in_ref_col = FALSE,+ #' effect estimates will be tabulated later. |
||
| 39 | +161 |
- #' conf_level = 0.90,+ #' |
||
| 40 | +162 |
- #' method = "ha"+ #' @return |
||
| 41 | +163 |
- #' )+ #' * `a_coxreg()` returns formatted [rtables::CellValue()]. |
||
| 42 | +164 |
#' |
||
| 43 | +165 |
- #' # CMH example with strata+ #' @examples |
||
| 44 | +166 |
- #' s_proportion_diff(+ #' a_coxreg( |
||
| 45 | +167 |
- #' df = subset(dta, grp == "A"),+ #' df = dta_bladder, |
||
| 46 | +168 |
- #' .var = "rsp",+ #' labelstr = "Label 1", |
||
| 47 | +169 |
- #' .ref_group = subset(dta, grp == "B"),+ #' variables = u1_variables, |
||
| 48 | +170 |
- #' .in_ref_col = FALSE,+ #' .spl_context = list(value = "COVAR1"), |
||
| 49 | +171 |
- #' variables = list(strata = c("f1", "f2")),
+ #' .stats = "n", |
||
| 50 | +172 |
- #' conf_level = 0.90,+ #' .formats = "xx" |
||
| 51 | +173 |
- #' method = "cmh"+ #' ) |
||
| 52 | +174 |
- #' )+ #' |
||
| 53 | +175 |
- #'+ #' a_coxreg( |
||
| 54 | +176 |
- #' @export+ #' df = dta_bladder, |
||
| 55 | +177 |
- s_proportion_diff <- function(df,+ #' labelstr = "", |
||
| 56 | +178 |
- .var,+ #' variables = u1_variables, |
||
| 57 | +179 |
- .ref_group,+ #' .spl_context = list(value = "COVAR2"), |
||
| 58 | +180 |
- .in_ref_col,+ #' .stats = "pval", |
||
| 59 | +181 |
- variables = list(strata = NULL),+ #' .formats = "xx.xxxx" |
||
| 60 | +182 |
- conf_level = 0.95,+ #' ) |
||
| 61 | +183 |
- method = c(+ #' |
||
| 62 | +184 |
- "waldcc", "wald", "cmh",+ #' @export |
||
| 63 | +185 |
- "ha", "newcombe", "newcombecc",+ a_coxreg <- function(df, |
||
| 64 | +186 |
- "strat_newcombe", "strat_newcombecc"+ labelstr, |
||
| 65 | +187 |
- ),+ eff = FALSE, |
||
| 66 | +188 |
- weights_method = "cmh") {
+ var_main = FALSE, |
||
| 67 | -2x | +|||
| 189 | +
- method <- match.arg(method)+ multivar = FALSE, |
|||
| 68 | -2x | +|||
| 190 | +
- if (is.null(variables$strata) && checkmate::test_subset(method, c("cmh", "strat_newcombe", "strat_newcombecc"))) {
+ variables, |
|||
| 69 | -! | +|||
| 191 | +
- stop(paste(+ at = list(), |
|||
| 70 | -! | +|||
| 192 | +
- "When performing an unstratified analysis, methods 'cmh', 'strat_newcombe', and 'strat_newcombecc' are not",+ control = control_coxreg(), |
|||
| 71 | -! | +|||
| 193 | +
- "permitted. Please choose a different method."+ .spl_context, |
|||
| 72 | +194 |
- ))+ .stats, |
||
| 73 | +195 |
- }+ .formats, |
||
| 74 | -2x | +|||
| 196 | +
- y <- list(diff = "", diff_ci = "")+ .indent_mods = NULL, |
|||
| 75 | +197 |
-
+ na_str = "", |
||
| 76 | -2x | +|||
| 198 | +
- if (!.in_ref_col) {
+ cache_env = NULL) {
|
|||
| 77 | -2x | +199 | +288x |
- rsp <- c(.ref_group[[.var]], df[[.var]])+ cov_no_arm <- !multivar && !"arm" %in% names(variables) && control$interaction # special case: univar no arm |
| 78 | -2x | +200 | +288x |
- grp <- factor(+ cov <- tail(.spl_context$value, 1) # current variable/covariate |
| 79 | -2x | +201 | +288x |
- rep(+ var_lbl <- formatters::var_labels(df)[cov] # check for df labels |
| 80 | -2x | +202 | +288x |
- c("ref", "Not-ref"),
+ if (length(labelstr) > 1) {
|
| 81 | -2x | +203 | +8x |
- c(nrow(.ref_group), nrow(df))+ labelstr <- if (cov %in% names(labelstr)) labelstr[[cov]] else var_lbl # use df labels if none |
| 82 | -+ | |||
| 204 | +280x |
- ),+ } else if (!is.na(var_lbl) && labelstr == cov && cov %in% variables$covariates) {
|
||
| 83 | -2x | +205 | +67x |
- levels = c("ref", "Not-ref")
+ labelstr <- var_lbl |
| 84 | +206 |
- )+ } |
||
| 85 | -+ | |||
| 207 | +288x |
-
+ if (eff || multivar || cov_no_arm) {
|
||
| 86 | -2x | +208 | +143x |
- if (!is.null(variables$strata)) {
+ control$interaction <- FALSE |
| 87 | -1x | +|||
| 209 | +
- strata_colnames <- variables$strata+ } else {
|
|||
| 88 | -1x | +210 | +145x |
- checkmate::assert_character(strata_colnames, null.ok = FALSE)+ variables$covariates <- cov |
| 89 | -1x | +211 | +50x |
- strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)+ if (var_main) control$interaction <- TRUE |
| 90 | +212 | ++ |
+ }+ |
+ |
| 213 | ||||
| 91 | -1x | +214 | +288x |
- assert_df_with_variables(df, strata_vars)+ if (is.null(cache_env[[cov]])) {
|
| 92 | -1x | +215 | +47x |
- assert_df_with_variables(.ref_group, strata_vars)+ if (!multivar) {
|
| 93 | -+ | |||
| 216 | +32x |
-
+ model <- fit_coxreg_univar(variables = variables, data = df, at = at, control = control) %>% broom::tidy() |
||
| 94 | +217 |
- # Merging interaction strata for reference group rows data and remaining+ } else {
|
||
| 95 | -1x | +218 | +15x |
- strata <- c(+ model <- fit_coxreg_multivar(variables = variables, data = df, control = control) %>% broom::tidy() |
| 96 | -1x | +|||
| 219 | +
- interaction(.ref_group[strata_colnames]),+ } |
|||
| 97 | -1x | +220 | +47x |
- interaction(df[strata_colnames])+ cache_env[[cov]] <- model |
| 98 | +221 |
- )+ } else {
|
||
| 99 | -1x | +222 | +241x |
- strata <- as.factor(strata)+ model <- cache_env[[cov]] |
| 100 | +223 |
- }+ } |
||
| 101 | -+ | |||
| 224 | +148x |
-
+ if (!multivar && !var_main) model[, "pval_inter"] <- NA_real_ |
||
| 102 | +225 |
- # Defining the std way to calculate weights for strat_newcombe+ |
||
| 103 | -2x | -
- if (!is.null(variables$weights_method)) {
- |
- ||
| 104 | -! | +226 | +288x |
- weights_method <- variables$weights_method+ if (cov_no_arm || (!cov_no_arm && !"arm" %in% names(variables) && is.numeric(df[[cov]]))) {
|
| 105 | -+ | |||
| 227 | +15x |
- } else {
+ multivar <- TRUE |
||
| 106 | -2x | +228 | +3x |
- weights_method <- "cmh"+ if (!cov_no_arm) var_main <- TRUE |
| 107 | +229 |
- }+ } |
||
| 108 | +230 | |||
| 109 | -2x | +231 | +288x |
- y <- switch(method,+ vars_coxreg <- list(which_vars = "all", var_nms = NULL) |
| 110 | -2x | +232 | +288x |
- "wald" = prop_diff_wald(rsp, grp, conf_level, correct = FALSE),+ if (eff) {
|
| 111 | -2x | +233 | +65x |
- "waldcc" = prop_diff_wald(rsp, grp, conf_level, correct = TRUE),+ if (multivar && !var_main) { # multivar treatment level
|
| 112 | -2x | +234 | +12x |
- "ha" = prop_diff_ha(rsp, grp, conf_level),+ var_lbl_arm <- formatters::var_labels(df)[[variables$arm]] |
| 113 | -2x | +235 | +12x |
- "newcombe" = prop_diff_nc(rsp, grp, conf_level, correct = FALSE),+ vars_coxreg[c("var_nms", "which_vars")] <- list(c(variables$arm, var_lbl_arm), "multi_lvl")
+ |
+
| 236 | ++ |
+ } else { # treatment effect
|
||
| 114 | -2x | +237 | +53x |
- "newcombecc" = prop_diff_nc(rsp, grp, conf_level, correct = TRUE),+ vars_coxreg["var_nms"] <- variables$arm |
| 115 | -2x | +238 | +12x |
- "strat_newcombe" = prop_diff_strat_nc(rsp,+ if (var_main) vars_coxreg["which_vars"] <- "var_main"+ |
+
| 239 | ++ |
+ }+ |
+ ||
| 240 | ++ |
+ } else {
|
||
| 116 | -2x | +241 | +223x |
- grp,+ if (!multivar || (multivar && var_main && !is.numeric(df[[cov]]))) { # covariate effect/level
|
| 117 | -2x | +242 | +166x |
- strata,+ vars_coxreg[c("var_nms", "which_vars")] <- list(cov, "var_main")
|
| 118 | -2x | +243 | +57x |
- weights_method,+ } else if (multivar) { # multivar covariate level
|
| 119 | -2x | +244 | +57x |
- conf_level,+ vars_coxreg[c("var_nms", "which_vars")] <- list(c(cov, var_lbl), "multi_lvl")
|
| 120 | -2x | +245 | +12x |
- correct = FALSE+ if (var_main) model[cov, .stats] <- NA_real_ |
| 121 | +246 |
- ),+ } |
||
| 122 | -2x | +247 | +50x |
- "strat_newcombecc" = prop_diff_strat_nc(rsp,+ if (!multivar && !var_main && control$interaction) vars_coxreg["which_vars"] <- "inter" # interaction effect |
| 123 | -2x | +|||
| 248 | +
- grp,+ } |
|||
| 124 | -2x | +249 | +288x |
- strata,+ var_vals <- s_coxreg(model, .stats, .which_vars = vars_coxreg$which_vars, .var_nms = vars_coxreg$var_nms)[[1]] |
| 125 | -2x | +250 | +288x |
- weights_method,+ var_names <- if (all(grepl("\\(reference = ", names(var_vals))) && labelstr != tail(.spl_context$value, 1)) {
|
| 126 | -2x | +251 | +27x |
- conf_level,+ paste(c(labelstr, tail(strsplit(names(var_vals), " ")[[1]], 3)), collapse = " ") # "reference" main effect labels |
| 127 | -2x | +252 | +288x |
- correct = TRUE+ } else if ((!multivar && !eff && !(!var_main && control$interaction) && nchar(labelstr) > 0) || |
| 128 | -+ | |||
| 253 | +288x |
- ),+ (multivar && var_main && is.numeric(df[[cov]]))) { # nolint
|
||
| 129 | -2x | +254 | +71x |
- "cmh" = prop_diff_cmh(rsp, grp, strata, conf_level)[c("diff", "diff_ci")]
+ labelstr # other main effect labels |
| 130 | -+ | |||
| 255 | +288x |
- )+ } else if (multivar && !eff && !var_main && is.numeric(df[[cov]])) {
|
||
| 131 | -+ | |||
| 256 | +12x |
-
+ "All" # multivar numeric covariate |
||
| 132 | -2x | +|||
| 257 | +
- y$diff <- y$diff * 100+ } else {
|
|||
| 133 | -2x | +258 | +178x |
- y$diff_ci <- y$diff_ci * 100+ names(var_vals) |
| 134 | +259 |
} |
||
| 135 | -+ | |||
| 260 | +288x |
-
+ in_rows( |
||
| 136 | -2x | +261 | +288x |
- attr(y$diff, "label") <- "Difference in Response rate (%)"+ .list = var_vals, .names = var_names, .labels = var_names, .indent_mods = .indent_mods, |
| 137 | -2x | +262 | +288x |
- attr(y$diff_ci, "label") <- d_proportion_diff(+ .formats = stats::setNames(rep(.formats, length(var_names)), var_names), |
| 138 | -2x | +263 | +288x |
- conf_level, method,+ .format_na_strs = stats::setNames(rep(na_str, length(var_names)), var_names) |
| 139 | -2x | +|||
| 264 | +
- long = FALSE+ ) |
|||
| 140 | +265 |
- )+ } |
||
| 141 | +266 | |||
| 142 | -2x | +|||
| 267 | +
- y+ #' @describeIn cox_regression Layout-creating function which creates a Cox regression summary table |
|||
| 143 | +268 |
- }+ #' layout. This function is a wrapper for several `rtables` layouting functions. This function |
||
| 144 | +269 |
-
+ #' is a wrapper for [rtables::analyze_colvars()] and [rtables::summarize_row_groups()]. |
||
| 145 | +270 |
- #' @describeIn prop_diff Formatted analysis function which is used as `afun` in `estimate_proportion_diff()`.+ #' |
||
| 146 | +271 |
- #'+ #' @inheritParams fit_coxreg_univar |
||
| 147 | +272 |
- #' @return+ #' @param multivar (`flag`)\cr whether multivariate Cox regression should run (defaults to `FALSE`), otherwise |
||
| 148 | +273 |
- #' * `a_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()].+ #' univariate Cox regression will run. |
||
| 149 | +274 |
- #'+ #' @param common_var (`string`)\cr the name of a factor variable in the dataset which takes the same value |
||
| 150 | +275 |
- #' @examples+ #' for all rows. This should be created during pre-processing if no such variable currently exists. |
||
| 151 | +276 |
- #' a_proportion_diff(+ #' @param .section_div (`string` or `NA`)\cr string which should be repeated as a section divider between sections. |
||
| 152 | +277 |
- #' df = subset(dta, grp == "A"),+ #' Defaults to `NA` for no section divider. If a vector of two strings are given, the first will be used between |
||
| 153 | +278 |
- #' .var = "rsp",+ #' treatment and covariate sections and the second between different covariates. |
||
| 154 | +279 |
- #' .ref_group = subset(dta, grp == "B"),+ #' |
||
| 155 | +280 |
- #' .in_ref_col = FALSE,+ #' @return |
||
| 156 | +281 |
- #' conf_level = 0.90,+ #' * `summarize_coxreg()` returns a layout object suitable for passing to further layouting functions, |
||
| 157 | +282 |
- #' method = "ha"+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add a Cox regression table |
||
| 158 | +283 |
- #' )+ #' containing the chosen statistics to the table layout. |
||
| 159 | +284 |
#' |
||
| 160 | +285 |
- #' @export+ #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()] which also take the `variables`, `data`, |
||
| 161 | +286 |
- a_proportion_diff <- make_afun(+ #' `at` (univariate only), and `control` arguments but return unformatted univariate and multivariate |
||
| 162 | +287 |
- s_proportion_diff,+ #' Cox regression models, respectively. |
||
| 163 | +288 |
- .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"),+ #' |
||
| 164 | +289 |
- .indent_mods = c(diff = 0L, diff_ci = 1L)+ #' @examples |
||
| 165 | +290 |
- )+ #' # summarize_coxreg |
||
| 166 | +291 |
-
+ #' |
||
| 167 | +292 |
- #' @describeIn prop_diff Layout-creating function which can take statistics function arguments+ #' result_univar <- basic_table() %>% |
||
| 168 | +293 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' summarize_coxreg(variables = u1_variables) %>% |
||
| 169 | +294 |
- #'+ #' build_table(dta_bladder) |
||
| 170 | +295 |
- #' @return+ #' result_univar |
||
| 171 | +296 |
- #' * `estimate_proportion_diff()` returns a layout object suitable for passing to further layouting functions,+ #' |
||
| 172 | +297 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' result_univar_covs <- basic_table() %>% |
||
| 173 | +298 |
- #' the statistics from `s_proportion_diff()` to the table layout.+ #' summarize_coxreg( |
||
| 174 | +299 |
- #'+ #' variables = u2_variables, |
||
| 175 | +300 |
- #' @examples+ #' ) %>% |
||
| 176 | +301 |
- #' ## "Mid" case: 4/4 respond in group A, 1/2 respond in group B.+ #' build_table(dta_bladder) |
||
| 177 | +302 |
- #' nex <- 100 # Number of example rows+ #' result_univar_covs |
||
| 178 | +303 |
- #' dta <- data.frame(+ #' |
||
| 179 | +304 |
- #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE),+ #' result_multivar <- basic_table() %>% |
||
| 180 | +305 |
- #' "grp" = sample(c("A", "B"), nex, TRUE),
+ #' summarize_coxreg( |
||
| 181 | +306 |
- #' "f1" = sample(c("a1", "a2"), nex, TRUE),
+ #' variables = m1_variables, |
||
| 182 | +307 |
- #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
+ #' multivar = TRUE, |
||
| 183 | +308 |
- #' stringsAsFactors = TRUE+ #' ) %>% |
||
| 184 | +309 |
- #' )+ #' build_table(dta_bladder) |
||
| 185 | +310 |
- #'+ #' result_multivar |
||
| 186 | +311 |
- #' l <- basic_table() %>%+ #' |
||
| 187 | +312 |
- #' split_cols_by(var = "grp", ref_group = "B") %>%+ #' result_multivar_covs <- basic_table() %>% |
||
| 188 | +313 |
- #' estimate_proportion_diff(+ #' summarize_coxreg( |
||
| 189 | +314 |
- #' vars = "rsp",+ #' variables = m2_variables, |
||
| 190 | +315 |
- #' conf_level = 0.90,+ #' multivar = TRUE, |
||
| 191 | +316 |
- #' method = "ha"+ #' varlabels = c("Covariate 1", "Covariate 2") # custom labels
|
||
| 192 | +317 |
- #' )+ #' ) %>% |
||
| 193 | +318 |
- #'+ #' build_table(dta_bladder) |
||
| 194 | +319 |
- #' build_table(l, df = dta)+ #' result_multivar_covs |
||
| 195 | +320 |
#' |
||
| 196 | +321 |
#' @export |
||
| 197 | +322 |
#' @order 2 |
||
| 198 | +323 |
- estimate_proportion_diff <- function(lyt,+ summarize_coxreg <- function(lyt, |
||
| 199 | +324 |
- vars,+ variables, |
||
| 200 | +325 |
- variables = list(strata = NULL),+ control = control_coxreg(), |
||
| 201 | +326 |
- conf_level = 0.95,+ at = list(), |
||
| 202 | +327 |
- method = c(+ multivar = FALSE, |
||
| 203 | +328 |
- "waldcc", "wald", "cmh",+ common_var = "STUDYID", |
||
| 204 | +329 |
- "ha", "newcombe", "newcombecc",+ .stats = c("n", "hr", "ci", "pval", "pval_inter"),
|
||
| 205 | +330 |
- "strat_newcombe", "strat_newcombecc"+ .formats = c( |
||
| 206 | +331 |
- ),+ n = "xx", hr = "xx.xx", ci = "(xx.xx, xx.xx)", |
||
| 207 | +332 |
- weights_method = "cmh",+ pval = "x.xxxx | (<0.0001)", pval_inter = "x.xxxx | (<0.0001)" |
||
| 208 | +333 |
- na_str = default_na_str(),+ ), |
||
| 209 | +334 |
- nested = TRUE,+ varlabels = NULL, |
||
| 210 | +335 |
- ...,+ .indent_mods = NULL, |
||
| 211 | +336 |
- var_labels = vars,+ na_str = "", |
||
| 212 | +337 |
- show_labels = "hidden",+ .section_div = NA_character_) {
+ |
+ ||
| 338 | +16x | +
+ if (multivar && control$interaction) {
+ |
+ ||
| 339 | +1x | +
+ warning(paste(+ |
+ ||
| 340 | +1x | +
+ "Interactions are not available for multivariate cox regression using summarize_coxreg.",+ |
+ ||
| 341 | +1x | +
+ "The model will be calculated without interaction effects." |
||
| 213 | +342 |
- table_names = vars,+ )) |
||
| 214 | +343 |
- .stats = NULL,+ }+ |
+ ||
| 344 | +16x | +
+ if (control$interaction && !"arm" %in% names(variables)) {
+ |
+ ||
| 345 | +1x | +
+ stop("To include interactions please specify 'arm' in variables.")
|
||
| 215 | +346 |
- .formats = NULL,+ } |
||
| 216 | +347 |
- .labels = NULL,+ + |
+ ||
| 348 | +15x | +
+ .stats <- if (!"arm" %in% names(variables) || multivar) { # only valid statistics
+ |
+ ||
| 349 | +6x | +
+ intersect(c("hr", "ci", "pval"), .stats)
+ |
+ ||
| 350 | +15x | +
+ } else if (control$interaction) {
+ |
+ ||
| 351 | +5x | +
+ intersect(c("n", "hr", "ci", "pval", "pval_inter"), .stats)
|
||
| 217 | +352 |
- .indent_mods = NULL) {
+ } else {
|
||
| 218 | +353 | 4x |
- extra_args <- list(+ intersect(c("n", "hr", "ci", "pval"), .stats)
+ |
+ |
| 354 | ++ |
+ } |
||
| 219 | -4x | +355 | +15x |
- variables = variables, conf_level = conf_level, method = method, weights_method = weights_method, ...+ stat_labels <- c(+ |
+
| 356 | +15x | +
+ n = "n", hr = "Hazard Ratio", ci = paste0(control$conf_level * 100, "% CI"),+ |
+ ||
| 357 | +15x | +
+ pval = "p-value", pval_inter = "Interaction p-value" |
||
| 220 | +358 |
) |
||
| 359 | +15x | +
+ stat_labels <- stat_labels[names(stat_labels) %in% .stats]+ |
+ ||
| 360 | +15x | +
+ .formats <- .formats[names(.formats) %in% .stats]+ |
+ ||
| 361 | +15x | +
+ env <- new.env() # create caching environment+ |
+ ||
| 221 | +362 | |||
| 222 | -4x | +363 | +15x |
- afun <- make_afun(+ lyt <- lyt %>% |
| 223 | -4x | +364 | +15x |
- a_proportion_diff,+ split_cols_by_multivar( |
| 224 | -4x | +365 | +15x |
- .stats = .stats,+ vars = rep(common_var, length(.stats)), |
| 225 | -4x | +366 | +15x |
- .formats = .formats,+ varlabels = stat_labels, |
| 226 | -4x | +367 | +15x |
- .labels = .labels,+ extra_args = list( |
| 227 | -4x | +368 | +15x |
- .indent_mods = .indent_mods+ .stats = .stats, .formats = .formats, .indent_mods = .indent_mods, na_str = rep(na_str, length(.stats)),+ |
+
| 369 | +15x | +
+ cache_env = replicate(length(.stats), list(env)) |
||
| 228 | +370 |
- )+ ) |
||
| 229 | +371 | ++ |
+ )+ |
+ |
| 372 | ||||
| 230 | -4x | +373 | +15x |
- analyze(+ if ("arm" %in% names(variables)) { # treatment effect
|
| 231 | -4x | +374 | +13x |
- lyt,+ lyt <- lyt %>% |
| 232 | -4x | +375 | +13x |
- vars,+ split_rows_by( |
| 233 | -4x | +376 | +13x |
- afun = afun,+ common_var, |
| 234 | -4x | +377 | +13x |
- var_labels = var_labels,+ split_label = "Treatment:", |
| 235 | -4x | +378 | +13x |
- na_str = na_str,+ label_pos = "visible", |
| 236 | -4x | +379 | +13x |
- nested = nested,+ child_labels = "hidden", |
| 237 | -4x | +380 | +13x |
- extra_args = extra_args,+ section_div = head(.section_div, 1)+ |
+
| 381 | ++ |
+ ) |
||
| 238 | -4x | +382 | +13x |
- show_labels = show_labels,+ if (!multivar) {
|
| 239 | -4x | +383 | +9x |
- table_names = table_names+ lyt <- lyt %>% |
| 240 | -+ | |||
| 384 | +9x |
- )+ analyze_colvars( |
||
| 241 | -+ | |||
| 385 | +9x |
- }+ afun = a_coxreg, |
||
| 242 | -+ | |||
| 386 | +9x |
-
+ na_str = na_str, |
||
| 243 | -+ | |||
| 387 | +9x |
- #' Check proportion difference arguments+ extra_args = list( |
||
| 244 | -+ | |||
| 388 | +9x |
- #'+ variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar, |
||
| 245 | -+ | |||
| 389 | +9x |
- #' Verifies that and/or convert arguments into valid values to be used in the+ labelstr = "" |
||
| 246 | +390 |
- #' estimation of difference in responder proportions.+ ) |
||
| 247 | +391 |
- #'+ ) |
||
| 248 | +392 |
- #' @inheritParams prop_diff+ } else { # treatment level effects
|
||
| 249 | -+ | |||
| 393 | +4x |
- #' @inheritParams prop_diff_wald+ lyt <- lyt %>% |
||
| 250 | -+ | |||
| 394 | +4x |
- #'+ summarize_row_groups( |
||
| 251 | -+ | |||
| 395 | +4x |
- #' @keywords internal+ cfun = a_coxreg, |
||
| 252 | -+ | |||
| 396 | +4x |
- check_diff_prop_ci <- function(rsp,+ na_str = na_str, |
||
| 253 | -+ | |||
| 397 | +4x |
- grp,+ extra_args = list( |
||
| 254 | -+ | |||
| 398 | +4x |
- strata = NULL,+ variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar |
||
| 255 | +399 |
- conf_level,+ ) |
||
| 256 | +400 |
- correct = NULL) {
+ ) %>% |
||
| 257 | -26x | +401 | +4x |
- checkmate::assert_logical(rsp, any.missing = FALSE)+ analyze_colvars( |
| 258 | -26x | +402 | +4x |
- checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2)+ afun = a_coxreg, |
| 259 | -26x | +403 | +4x |
- checkmate::assert_number(conf_level, lower = 0, upper = 1)+ na_str = na_str, |
| 260 | -26x | +404 | +4x |
- checkmate::assert_flag(correct, null.ok = TRUE)+ extra_args = list(eff = TRUE, control = control, variables = variables, multivar = multivar, labelstr = "") |
| 261 | +405 | - - | -||
| 262 | -26x | -
- if (!is.null(strata)) {
+ ) |
||
| 263 | -12x | +|||
| 406 | +
- checkmate::assert_factor(strata, len = length(rsp))+ } |
|||
| 264 | +407 |
} |
||
| 265 | +408 | |||
| 266 | -26x | +409 | +15x |
- invisible()+ if ("covariates" %in% names(variables)) { # covariate main effects
|
| 267 | -+ | |||
| 410 | +15x |
- }+ lyt <- lyt %>% |
||
| 268 | -+ | |||
| 411 | +15x |
-
+ split_rows_by_multivar( |
||
| 269 | -+ | |||
| 412 | +15x |
- #' Description of method used for proportion comparison+ vars = variables$covariates, |
||
| 270 | -+ | |||
| 413 | +15x |
- #'+ varlabels = varlabels, |
||
| 271 | -+ | |||
| 414 | +15x |
- #' @description `r lifecycle::badge("stable")`
+ split_label = "Covariate:", |
||
| 272 | -+ | |||
| 415 | +15x |
- #'+ nested = FALSE, |
||
| 273 | -+ | |||
| 416 | +15x |
- #' This is an auxiliary function that describes the analysis in+ child_labels = if (multivar || control$interaction || !"arm" %in% names(variables)) "default" else "hidden", |
||
| 274 | -+ | |||
| 417 | +15x |
- #' [s_proportion_diff()].+ section_div = tail(.section_div, 1) |
||
| 275 | +418 |
- #'+ ) |
||
| 276 | -+ | |||
| 419 | +15x |
- #' @inheritParams s_proportion_diff+ if (multivar || control$interaction || !"arm" %in% names(variables)) {
|
||
| 277 | -+ | |||
| 420 | +11x |
- #' @param long (`flag`)\cr whether a long (`TRUE`) or a short (`FALSE`, default) description is required.+ lyt <- lyt %>% |
||
| 278 | -+ | |||
| 421 | +11x |
- #'+ summarize_row_groups( |
||
| 279 | -+ | |||
| 422 | +11x |
- #' @return A `string` describing the analysis.+ cfun = a_coxreg, |
||
| 280 | -+ | |||
| 423 | +11x |
- #'+ na_str = na_str, |
||
| 281 | -+ | |||
| 424 | +11x |
- #' @seealso [prop_diff]+ extra_args = list( |
||
| 282 | -+ | |||
| 425 | +11x |
- #'+ variables = variables, at = at, control = control, multivar = multivar, |
||
| 283 | -+ | |||
| 426 | +11x |
- #' @export+ var_main = if (multivar) multivar else control$interaction |
||
| 284 | +427 |
- d_proportion_diff <- function(conf_level,+ ) |
||
| 285 | +428 |
- method,+ ) |
||
| 286 | +429 |
- long = FALSE) {
+ } else {
|
||
| 287 | -11x | +430 | +1x |
- label <- paste0(conf_level * 100, "% CI")+ if (!is.null(varlabels)) names(varlabels) <- variables$covariates |
| 288 | -11x | +431 | +4x |
- if (long) {
+ lyt <- lyt %>% |
| 289 | -! | +|||
| 432 | +4x |
- label <- paste(+ analyze_colvars( |
||
| 290 | -! | +|||
| 433 | +4x |
- label,+ afun = a_coxreg, |
||
| 291 | -! | +|||
| 434 | +4x |
- ifelse(+ na_str = na_str, |
||
| 292 | -! | +|||
| 435 | +4x |
- method == "cmh",+ extra_args = list( |
||
| 293 | -! | +|||
| 436 | +4x |
- "for adjusted difference",+ variables = variables, at = at, control = control, multivar = multivar, |
||
| 294 | -! | +|||
| 437 | +4x |
- "for difference"+ var_main = if (multivar) multivar else control$interaction,+ |
+ ||
| 438 | +4x | +
+ labelstr = if (is.null(varlabels)) "" else varlabels |
||
| 295 | +439 |
- )+ ) |
||
| 296 | +440 |
- )+ ) |
||
| 297 | +441 |
- }+ } |
||
| 298 | +442 | |||
| 299 | -11x | +443 | +2x |
- method_part <- switch(method,+ if (!"arm" %in% names(variables)) control$interaction <- TRUE # special case: univar no arm |
| 300 | -11x | +444 | +15x |
- "cmh" = "CMH, without correction",+ if (multivar || control$interaction) { # covariate level effects
|
| 301 | +445 | 11x |
- "waldcc" = "Wald, with correction",+ lyt <- lyt %>% |
|
| 302 | +446 | 11x |
- "wald" = "Wald, without correction",+ analyze_colvars( |
|
| 303 | +447 | 11x |
- "ha" = "Anderson-Hauck",+ afun = a_coxreg, |
|
| 304 | +448 | 11x |
- "newcombe" = "Newcombe, without correction",+ na_str = na_str, |
|
| 305 | +449 | 11x |
- "newcombecc" = "Newcombe, with correction",+ extra_args = list(variables = variables, at = at, control = control, multivar = multivar, labelstr = ""), |
|
| 306 | +450 | 11x |
- "strat_newcombe" = "Stratified Newcombe, without correction",+ indent_mod = if (!"arm" %in% names(variables) || multivar) 0L else -1L |
|
| 307 | -11x | +|||
| 451 | +
- "strat_newcombecc" = "Stratified Newcombe, with correction",+ ) |
|||
| 308 | -11x | +|||
| 452 | +
- stop(paste(method, "does not have a description"))+ } |
|||
| 309 | +453 |
- )+ }+ |
+ ||
| 454 | ++ | + | ||
| 310 | -11x | +455 | +15x |
- paste0(label, " (", method_part, ")")
+ lyt |
| 311 | +456 |
} |
| 312 | +1 |
-
+ #' Confidence interval for mean |
||
| 313 | +2 |
- #' Helper functions to calculate proportion difference+ #' |
||
| 314 | +3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+ |
| 4 |
#' |
|||
| 315 | +5 |
- #' @description `r lifecycle::badge("stable")`
+ #' Convenient function for calculating the mean confidence interval. It calculates the arithmetic as well as the |
||
| 316 | +6 | ++ |
+ #' geometric mean. It can be used as a `ggplot` helper function for plotting.+ |
+ |
| 7 |
#' |
|||
| 317 | +8 |
#' @inheritParams argument_convention |
||
| 318 | +9 |
- #' @inheritParams prop_diff+ #' @param n_min (`numeric(1)`)\cr a minimum number of non-missing `x` to estimate the confidence interval for mean. |
||
| 319 | +10 |
- #' @param grp (`factor`)\cr vector assigning observations to one out of two groups+ #' @param gg_helper (`flag`)\cr whether output should be aligned for use with `ggplot`s. |
||
| 320 | +11 |
- #' (e.g. reference and treatment group).+ #' @param geom_mean (`flag`)\cr whether the geometric mean should be calculated. |
||
| 321 | +12 |
#' |
||
| 322 | +13 |
- #' @return A named `list` of elements `diff` (proportion difference) and `diff_ci`+ #' @return A named `vector` of values `mean_ci_lwr` and `mean_ci_upr`. |
||
| 323 | +14 |
- #' (proportion difference confidence interval).+ #' |
||
| 324 | +15 |
- #'+ #' @examples |
||
| 325 | +16 |
- #' @seealso [prop_diff()] for implementation of these helper functions.+ #' stat_mean_ci(sample(10), gg_helper = FALSE) |
||
| 326 | +17 |
#' |
||
| 327 | +18 |
- #' @name h_prop_diff+ #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) + |
||
| 328 | +19 |
- NULL+ #' ggplot2::geom_point() |
||
| 329 | +20 |
-
+ #' |
||
| 330 | +21 |
- #' @describeIn h_prop_diff The Wald interval follows the usual textbook+ #' p + ggplot2::stat_summary( |
||
| 331 | +22 |
- #' definition for a single proportion confidence interval using the normal+ #' fun.data = stat_mean_ci, |
||
| 332 | +23 |
- #' approximation. It is possible to include a continuity correction for Wald's+ #' geom = "errorbar" |
||
| 333 | +24 |
- #' interval.+ #' ) |
||
| 334 | +25 |
#' |
||
| 335 | +26 |
- #' @param correct (`flag`)\cr whether to include the continuity correction. For further+ #' p + ggplot2::stat_summary( |
||
| 336 | +27 |
- #' information, see [stats::prop.test()].+ #' fun.data = stat_mean_ci, |
||
| 337 | +28 |
- #'+ #' fun.args = list(conf_level = 0.5), |
||
| 338 | +29 |
- #' @examples+ #' geom = "errorbar" |
||
| 339 | +30 |
- #' # Wald confidence interval+ #' ) |
||
| 340 | +31 |
- #' set.seed(2)+ #' |
||
| 341 | +32 |
- #' rsp <- sample(c(TRUE, FALSE), replace = TRUE, size = 20)+ #' p + ggplot2::stat_summary( |
||
| 342 | +33 |
- #' grp <- factor(c(rep("A", 10), rep("B", 10)))
+ #' fun.data = stat_mean_ci, |
||
| 343 | +34 |
- #'+ #' fun.args = list(conf_level = 0.5, geom_mean = TRUE), |
||
| 344 | +35 |
- #' prop_diff_wald(rsp = rsp, grp = grp, conf_level = 0.95, correct = FALSE)+ #' geom = "errorbar" |
||
| 345 | +36 | ++ |
+ #' )+ |
+ |
| 37 |
#' |
|||
| 346 | +38 |
#' @export |
||
| 347 | +39 |
- prop_diff_wald <- function(rsp,+ stat_mean_ci <- function(x, |
||
| 348 | +40 |
- grp,+ conf_level = 0.95, |
||
| 349 | +41 |
- conf_level = 0.95,+ na.rm = TRUE, # nolint |
||
| 350 | +42 |
- correct = FALSE) {
+ n_min = 2,+ |
+ ||
| 43 | ++ |
+ gg_helper = TRUE,+ |
+ ||
| 44 | ++ |
+ geom_mean = FALSE) {
|
||
| 351 | -8x | +45 | +2211x |
- if (isTRUE(correct)) {
+ if (na.rm) {
|
| 352 | -5x | +46 | +10x |
- mthd <- "waldcc"+ x <- stats::na.omit(x) |
| 353 | +47 |
- } else {
+ } |
||
| 354 | -3x | +48 | +2211x |
- mthd <- "wald"+ n <- length(x) |
| 355 | +49 |
- }+ |
||
| 356 | -8x | +50 | +2211x |
- grp <- as_factor_keep_attributes(grp)+ if (!geom_mean) {
|
| 357 | -8x | +51 | +1113x |
- check_diff_prop_ci(+ m <- mean(x)+ |
+
| 52 | ++ |
+ } else {
|
||
| 358 | -8x | +53 | +1098x |
- rsp = rsp, grp = grp, conf_level = conf_level, correct = correct+ negative_values_exist <- any(is.na(x[!is.na(x)]) <- x[!is.na(x)] <= 0) |
| 359 | -+ | |||
| 54 | +1098x |
- )+ if (negative_values_exist) {
|
||
| 360 | -+ | |||
| 55 | +22x |
-
+ m <- NA_real_ |
||
| 361 | +56 |
- # check if binary response is coded as logical+ } else {
|
||
| 362 | -8x | +57 | +1076x |
- checkmate::assert_logical(rsp, any.missing = FALSE)+ x <- log(x) |
| 363 | -8x | +58 | +1076x |
- checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2)+ m <- mean(x) |
| 364 | +59 | ++ |
+ }+ |
+ |
| 60 | ++ |
+ }+ |
+ ||
| 61 | ||||
| 365 | -8x | +62 | +2211x |
- tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ if (n < n_min || is.na(m)) {
+ |
+
| 63 | +302x | +
+ ci <- c(mean_ci_lwr = NA_real_, mean_ci_upr = NA_real_) |
||
| 366 | +64 |
- # x1 and n1 are non-reference groups.+ } else {
|
||
| 367 | -8x | +65 | +1909x |
- diff_ci <- desctools_binom(+ hci <- stats::qt((1 + conf_level) / 2, df = n - 1) * stats::sd(x) / sqrt(n) |
| 368 | -8x | +66 | +1909x |
- x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ ci <- c(mean_ci_lwr = m - hci, mean_ci_upr = m + hci) |
| 369 | -8x | +67 | +1909x |
- x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ if (geom_mean) {
|
| 370 | -8x | +68 | +945x |
- conf.level = conf_level,+ ci <- exp(ci) |
| 371 | -8x | +|||
| 69 | +
- method = mthd+ } |
|||
| 372 | +70 |
- )+ } |
||
| 373 | +71 | |||
| 374 | -8x | +72 | +2211x |
- list(+ if (gg_helper) {
|
| 375 | -8x | +73 | +4x |
- "diff" = unname(diff_ci[, "est"]),+ m <- ifelse(is.na(m), NA_real_, m) |
| 376 | -8x | +74 | +4x |
- "diff_ci" = unname(diff_ci[, c("lwr.ci", "upr.ci")])
+ ci <- data.frame(y = ifelse(geom_mean, exp(m), m), ymin = ci[[1]], ymax = ci[[2]]) |
| 377 | +75 |
- )+ } |
||
| 378 | +76 | ++ | + + | +|
| 77 | +2211x | +
+ return(ci)+ |
+ ||
| 78 |
} |
|||
| 379 | +79 | |||
| 380 | +80 |
- #' @describeIn h_prop_diff Anderson-Hauck confidence interval.+ #' Confidence interval for median |
||
| 381 | +81 |
#' |
||
| 382 | +82 |
- #' @examples+ #' @description `r lifecycle::badge("stable")`
|
||
| 383 | +83 |
- #' # Anderson-Hauck confidence interval+ #' |
||
| 384 | +84 |
- #' ## "Mid" case: 3/4 respond in group A, 1/2 respond in group B.+ #' Convenient function for calculating the median confidence interval. It can be used as a `ggplot` helper |
||
| 385 | +85 |
- #' rsp <- c(TRUE, FALSE, FALSE, TRUE, TRUE, TRUE)+ #' function for plotting. |
||
| 386 | +86 |
- #' grp <- factor(c("A", "B", "A", "B", "A", "A"), levels = c("B", "A"))
+ #' |
||
| 387 | +87 | ++ |
+ #' @inheritParams argument_convention+ |
+ |
| 88 | ++ |
+ #' @param gg_helper (`flag`)\cr whether output should be aligned for use with `ggplot`s.+ |
+ ||
| 89 |
#' |
|||
| 388 | +90 |
- #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.90)+ #' @details This function was adapted from `DescTools/versions/0.99.35/source` |
||
| 389 | +91 |
#' |
||
| 390 | +92 |
- #' ## Edge case: Same proportion of response in A and B.+ #' @return A named `vector` of values `median_ci_lwr` and `median_ci_upr`. |
||
| 391 | +93 |
- #' rsp <- c(TRUE, FALSE, TRUE, FALSE)+ #' |
||
| 392 | +94 |
- #' grp <- factor(c("A", "A", "B", "B"), levels = c("A", "B"))
+ #' @examples |
||
| 393 | +95 | ++ |
+ #' stat_median_ci(sample(10), gg_helper = FALSE)+ |
+ |
| 96 |
#' |
|||
| 394 | +97 |
- #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.6)+ #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) + |
||
| 395 | +98 | ++ |
+ #' ggplot2::geom_point()+ |
+ |
| 99 | ++ |
+ #' p + ggplot2::stat_summary(+ |
+ ||
| 100 | ++ |
+ #' fun.data = stat_median_ci,+ |
+ ||
| 101 | ++ |
+ #' geom = "errorbar"+ |
+ ||
| 102 | ++ |
+ #' )+ |
+ ||
| 103 |
#' |
|||
| 396 | +104 |
#' @export |
||
| 397 | +105 |
- prop_diff_ha <- function(rsp,+ stat_median_ci <- function(x, |
||
| 398 | +106 |
- grp,+ conf_level = 0.95, |
||
| 399 | +107 |
- conf_level) {
+ na.rm = TRUE, # nolint+ |
+ ||
| 108 | ++ |
+ gg_helper = TRUE) {
|
||
| 400 | -4x | +109 | +1111x |
- grp <- as_factor_keep_attributes(grp)+ x <- unname(x) |
| 401 | -4x | +110 | +1111x |
- check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level)+ if (na.rm) {
+ |
+
| 111 | +9x | +
+ x <- x[!is.na(x)] |
||
| 402 | +112 | ++ |
+ }+ |
+ |
| 113 | +1111x | +
+ n <- length(x)+ |
+ ||
| 114 | +1111x | +
+ med <- stats::median(x)+ |
+ ||
| 115 | ||||
| 403 | -4x | +116 | +1111x |
- tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ k <- stats::qbinom(p = (1 - conf_level) / 2, size = n, prob = 0.5, lower.tail = TRUE) |
| 404 | +117 | ++ | + + | +|
| 118 |
- # x1 and n1 are non-reference groups.+ # k == 0 - for small samples (e.g. n <= 5) ci can be outside the observed range+ |
+ |||
| 119 | +1111x | +
+ if (k == 0 || is.na(med)) {
+ |
+ ||
| 120 | +242x | +
+ ci <- c(median_ci_lwr = NA_real_, median_ci_upr = NA_real_) |
||
| 405 | -4x | +121 | +242x |
- ci <- desctools_binom(+ empir_conf_level <- NA_real_ |
| 406 | -4x | +|||
| 122 | +
- x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ } else {
|
|||
| 407 | -4x | +123 | +869x |
- x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ x_sort <- sort(x) |
| 408 | -4x | +124 | +869x |
- conf.level = conf_level,+ ci <- c(median_ci_lwr = x_sort[k], median_ci_upr = x_sort[n - k + 1]) |
| 409 | -4x | +125 | +869x |
- method = "ha"+ empir_conf_level <- 1 - 2 * stats::pbinom(k - 1, size = n, prob = 0.5) |
| 410 | +126 |
- )+ } |
||
| 411 | -4x | +|||
| 127 | +
- list(+ |
|||
| 412 | -4x | +128 | +1111x |
- "diff" = unname(ci[, "est"]),+ if (gg_helper) {
|
| 413 | +129 | 4x |
- "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
+ ci <- data.frame(y = med, ymin = ci[[1]], ymax = ci[[2]]) |
|
| 414 | +130 |
- )+ } |
||
| 415 | +131 |
- }+ |
||
| 416 | -+ | |||
| 132 | +1111x |
-
+ attr(ci, "conf_level") <- empir_conf_level |
||
| 417 | +133 |
- #' @describeIn h_prop_diff Newcombe confidence interval. It is based on+ |
||
| 418 | -+ | |||
| 134 | +1111x |
- #' the Wilson score confidence interval for a single binomial proportion.+ return(ci) |
||
| 419 | +135 |
- #'+ } |
||
| 420 | +136 |
- #' @examples+ |
||
| 421 | +137 |
- #' # Newcombe confidence interval+ #' p-Value of the mean |
||
| 422 | +138 |
#' |
||
| 423 | +139 |
- #' set.seed(1)+ #' @description `r lifecycle::badge("stable")`
|
||
| 424 | +140 |
- #' rsp <- c(+ #' |
||
| 425 | +141 |
- #' sample(c(TRUE, FALSE), size = 40, prob = c(3 / 4, 1 / 4), replace = TRUE),+ #' Convenient function for calculating the two-sided p-value of the mean. |
||
| 426 | +142 |
- #' sample(c(TRUE, FALSE), size = 40, prob = c(1 / 2, 1 / 2), replace = TRUE)+ #' |
||
| 427 | +143 |
- #' )+ #' @inheritParams argument_convention |
||
| 428 | +144 |
- #' grp <- factor(rep(c("A", "B"), each = 40), levels = c("B", "A"))
+ #' @param n_min (`numeric(1)`)\cr a minimum number of non-missing `x` to estimate the p-value of the mean. |
||
| 429 | +145 |
- #' table(rsp, grp)+ #' @param test_mean (`numeric(1)`)\cr mean value to test under the null hypothesis. |
||
| 430 | +146 |
#' |
||
| 431 | +147 |
- #' prop_diff_nc(rsp = rsp, grp = grp, conf_level = 0.9)+ #' @return A p-value. |
||
| 432 | +148 |
#' |
||
| 433 | +149 |
- #' @export+ #' @examples |
||
| 434 | +150 |
- prop_diff_nc <- function(rsp,+ #' stat_mean_pval(sample(10)) |
||
| 435 | +151 |
- grp,+ #' |
||
| 436 | +152 |
- conf_level,+ #' stat_mean_pval(rnorm(10), test_mean = 0.5) |
||
| 437 | +153 |
- correct = FALSE) {
+ #' |
||
| 438 | -2x | +|||
| 154 | +
- if (isTRUE(correct)) {
+ #' @export |
|||
| 439 | -! | +|||
| 155 | +
- mthd <- "scorecc"+ stat_mean_pval <- function(x, |
|||
| 440 | +156 |
- } else {
+ na.rm = TRUE, # nolint |
||
| 441 | -2x | +|||
| 157 | +
- mthd <- "score"+ n_min = 2, |
|||
| 442 | +158 |
- }+ test_mean = 0) {
|
||
| 443 | -2x | +159 | +1111x |
- grp <- as_factor_keep_attributes(grp)+ if (na.rm) {
|
| 444 | -2x | +160 | +9x |
- check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level)+ x <- stats::na.omit(x) |
| 445 | +161 |
-
+ } |
||
| 446 | -2x | +162 | +1111x |
- p_grp <- tapply(rsp, grp, mean)+ n <- length(x) |
| 447 | -2x | +|||
| 163 | +
- diff_p <- unname(diff(p_grp))+ |
|||
| 448 | -2x | +164 | +1111x |
- tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ x_mean <- mean(x) |
| 449 | -2x | +165 | +1111x |
- ci <- desctools_binom(+ x_sd <- stats::sd(x) |
| 450 | +166 |
- # x1 and n1 are non-reference groups.- |
- ||
| 451 | -2x | -
- x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),- |
- ||
| 452 | -2x | -
- x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ |
||
| 453 | -2x | +167 | +1111x |
- conf.level = conf_level,+ if (n < n_min) {
|
| 454 | -2x | +168 | +140x |
- method = mthd+ pv <- c(p_value = NA_real_) |
| 455 | +169 |
- )+ } else {
|
||
| 456 | -2x | +170 | +971x |
- list(+ x_se <- stats::sd(x) / sqrt(n) |
| 457 | -2x | +171 | +971x |
- "diff" = unname(ci[, "est"]),+ ttest <- (x_mean - test_mean) / x_se |
| 458 | -2x | -
- "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
- |
- ||
| 459 | -+ | 172 | +971x |
- )+ pv <- c(p_value = 2 * stats::pt(-abs(ttest), df = n - 1)) |
| 460 | +173 |
- }+ } |
||
| 461 | +174 | |||
| 462 | -+ | |||
| 175 | +1111x |
- #' @describeIn h_prop_diff Calculates the weighted difference. This is defined as the difference in+ return(pv) |
||
| 463 | +176 |
- #' response rates between the experimental treatment group and the control treatment group, adjusted+ } |
||
| 464 | +177 |
- #' for stratification factors by applying Cochran-Mantel-Haenszel (CMH) weights. For the CMH chi-squared+ |
||
| 465 | +178 |
- #' test, use [stats::mantelhaen.test()].+ #' Proportion difference and confidence interval |
||
| 466 | +179 |
#' |
||
| 467 | +180 |
- #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 468 | +181 |
#' |
||
| 469 | +182 |
- #' @examples+ #' Function for calculating the proportion (or risk) difference and confidence interval between arm |
||
| 470 | +183 |
- #' # Cochran-Mantel-Haenszel confidence interval+ #' X (reference group) and arm Y. Risk difference is calculated by subtracting cumulative incidence |
||
| 471 | +184 |
- #'+ #' in arm Y from cumulative incidence in arm X. |
||
| 472 | +185 |
- #' set.seed(2)+ #' |
||
| 473 | +186 |
- #' rsp <- sample(c(TRUE, FALSE), 100, TRUE)+ #' @inheritParams argument_convention |
||
| 474 | +187 |
- #' grp <- sample(c("Placebo", "Treatment"), 100, TRUE)
+ #' @param x (`list` of `integer`)\cr list of number of occurrences in arm X (reference group). |
||
| 475 | +188 |
- #' grp <- factor(grp, levels = c("Placebo", "Treatment"))
+ #' @param y (`list` of `integer`)\cr list of number of occurrences in arm Y. Must be of equal length to `x`. |
||
| 476 | +189 |
- #' strata_data <- data.frame(+ #' @param N_x (`numeric(1)`)\cr total number of records in arm X. |
||
| 477 | +190 |
- #' "f1" = sample(c("a", "b"), 100, TRUE),
+ #' @param N_y (`numeric(1)`)\cr total number of records in arm Y. |
||
| 478 | +191 |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ #' @param list_names (`character`)\cr names of each variable/level corresponding to pair of proportions in |
||
| 479 | +192 |
- #' stringsAsFactors = TRUE+ #' `x` and `y`. Must be of equal length to `x` and `y`. |
||
| 480 | +193 |
- #' )+ #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`. |
||
| 481 | +194 |
#' |
||
| 482 | +195 |
- #' prop_diff_cmh(+ #' @return List of proportion differences and CIs corresponding to each pair of number of occurrences in `x` and |
||
| 483 | +196 |
- #' rsp = rsp, grp = grp, strata = interaction(strata_data),+ #' `y`. Each list element consists of 3 statistics: proportion difference, CI lower bound, and CI upper bound. |
||
| 484 | +197 |
- #' conf_level = 0.90+ #' |
||
| 485 | +198 |
- #' )+ #' @seealso Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()] |
||
| 486 | +199 |
- #'+ #' with `riskdiff` argument is set to `TRUE` in subsequent analyze functions, adds a column containing |
||
| 487 | +200 |
- #' @export+ #' proportion (risk) difference to an `rtables` layout. |
||
| 488 | +201 |
- prop_diff_cmh <- function(rsp,+ #' |
||
| 489 | +202 |
- grp,+ #' @examples |
||
| 490 | +203 |
- strata,+ #' stat_propdiff_ci( |
||
| 491 | +204 |
- conf_level = 0.95) {
+ #' x = list(0.375), y = list(0.01), N_x = 5, N_y = 5, list_names = "x", conf_level = 0.9 |
||
| 492 | -8x | +|||
| 205 | +
- grp <- as_factor_keep_attributes(grp)+ #' ) |
|||
| 493 | -8x | +|||
| 206 | +
- strata <- as_factor_keep_attributes(strata)+ #' |
|||
| 494 | -8x | +|||
| 207 | +
- check_diff_prop_ci(+ #' stat_propdiff_ci( |
|||
| 495 | -8x | +|||
| 208 | +
- rsp = rsp, grp = grp, conf_level = conf_level, strata = strata+ #' x = list(0.5, 0.75, 1), y = list(0.25, 0.05, 0.5), N_x = 10, N_y = 20, pct = FALSE |
|||
| 496 | +209 |
- )+ #' ) |
||
| 497 | +210 |
-
+ #' |
||
| 498 | -8x | +|||
| 211 | +
- if (any(tapply(rsp, strata, length) < 5)) {
+ #' @export |
|||
| 499 | -1x | +|||
| 212 | +
- warning("Less than 5 observations in some strata.")
+ stat_propdiff_ci <- function(x, |
|||
| 500 | +213 |
- }+ y, |
||
| 501 | +214 |
-
+ N_x, # nolint |
||
| 502 | +215 |
- # first dimension: FALSE, TRUE+ N_y, # nolint |
||
| 503 | +216 |
- # 2nd dimension: CONTROL, TX+ list_names = NULL, |
||
| 504 | +217 |
- # 3rd dimension: levels of strata+ conf_level = 0.95, |
||
| 505 | +218 |
- # rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records+ pct = TRUE) {
|
||
| 506 | -8x | +219 | +47x |
- t_tbl <- table(+ checkmate::assert_list(x, types = "numeric") |
| 507 | -8x | +220 | +47x |
- factor(rsp, levels = c("FALSE", "TRUE")),
+ checkmate::assert_list(y, types = "numeric", len = length(x)) |
| 508 | -8x | +221 | +47x |
- grp,+ checkmate::assert_character(list_names, len = length(x), null.ok = TRUE) |
| 509 | -8x | +222 | +47x |
- strata+ rd_list <- lapply(seq_along(x), function(i) {
|
| 510 | -+ | |||
| 223 | +120x |
- )+ p_x <- x[[i]] / N_x |
||
| 511 | -8x | +224 | +120x |
- n1 <- colSums(t_tbl[1:2, 1, ])+ p_y <- y[[i]] / N_y |
| 512 | -8x | +225 | +120x |
- n2 <- colSums(t_tbl[1:2, 2, ])+ rd_ci <- p_x - p_y + c(-1, 1) * stats::qnorm((1 + conf_level) / 2) * |
| 513 | -8x | +226 | +120x |
- p1 <- t_tbl[2, 1, ] / n1+ sqrt(p_x * (1 - p_x) / N_x + p_y * (1 - p_y) / N_y) |
| 514 | -8x | +227 | +120x |
- p2 <- t_tbl[2, 2, ] / n2+ c(p_x - p_y, rd_ci) * ifelse(pct, 100, 1) |
| 515 | +228 |
- # CMH weights+ }) |
||
| 516 | -8x | +229 | +47x |
- use_stratum <- (n1 > 0) & (n2 > 0)+ names(rd_list) <- list_names |
| 517 | -8x | +230 | +47x |
- n1 <- n1[use_stratum]+ rd_list |
| 518 | -8x | +|||
| 231 | +
- n2 <- n2[use_stratum]+ } |
|||
| 519 | -8x | +
| 1 | +
- p1 <- p1[use_stratum]+ #' Get default statistical methods and their associated formats, labels, and indent modifiers |
|||
| 520 | -8x | +|||
| 2 | +
- p2 <- p2[use_stratum]+ #' |
|||
| 521 | -8x | +|||
| 3 | +
- wt <- (n1 * n2 / (n1 + n2))+ #' @description `r lifecycle::badge("stable")`
|
|||
| 522 | -8x | +|||
| 4 | +
- wt_normalized <- wt / sum(wt)+ #' |
|||
| 523 | -8x | +|||
| 5 | +
- est1 <- sum(wt_normalized * p1)+ #' Utility functions to get valid statistic methods for different method groups |
|||
| 524 | -8x | +|||
| 6 | +
- est2 <- sum(wt_normalized * p2)+ #' (`.stats`) and their associated formats (`.formats`), labels (`.labels`), and indent modifiers |
|||
| 525 | -8x | +|||
| 7 | +
- estimate <- c(est1, est2)+ #' (`.indent_mods`). This utility is used across `tern`, but some of its working principles can be |
|||
| 526 | -8x | +|||
| 8 | +
- names(estimate) <- levels(grp)+ #' seen in [analyze_vars()]. See notes to understand why this is experimental. |
|||
| 527 | -8x | +|||
| 9 | +
- se1 <- sqrt(sum(wt_normalized^2 * p1 * (1 - p1) / n1))+ #' |
|||
| 528 | -8x | +|||
| 10 | +
- se2 <- sqrt(sum(wt_normalized^2 * p2 * (1 - p2) / n2))+ #' @param stats (`character`)\cr statistical methods to get defaults for. |
|||
| 529 | -8x | +|||
| 11 | +
- z <- stats::qnorm((1 + conf_level) / 2)+ #' |
|||
| 530 | -8x | +|||
| 12 | +
- err1 <- z * se1+ #' @details |
|||
| 531 | -8x | +|||
| 13 | +
- err2 <- z * se2+ #' Current choices for `type` are `counts` and `numeric` for [analyze_vars()] and affect `get_stats()`. |
|||
| 532 | -8x | +|||
| 14 | +
- ci1 <- c((est1 - err1), (est1 + err1))+ #' |
|||
| 533 | -8x | +|||
| 15 | +
- ci2 <- c((est2 - err2), (est2 + err2))+ #' @note |
|||
| 534 | -8x | +|||
| 16 | +
- estimate_ci <- list(ci1, ci2)+ #' These defaults are experimental because we use the names of functions to retrieve the default |
|||
| 535 | -8x | +|||
| 17 | +
- names(estimate_ci) <- levels(grp)+ #' statistics. This should be generalized in groups of methods according to more reasonable groupings. |
|||
| 536 | -8x | +|||
| 18 | +
- diff_est <- est2 - est1+ #' |
|||
| 537 | -8x | +|||
| 19 | +
- se_diff <- sqrt(sum(((p1 * (1 - p1) / n1) + (p2 * (1 - p2) / n2)) * wt_normalized^2))+ #' @name default_stats_formats_labels |
|||
| 538 | -8x | +|||
| 20 | +
- diff_ci <- c(diff_est - z * se_diff, diff_est + z * se_diff)+ NULL |
|||
| 539 | +21 | |||
| 540 | -8x | -
- list(- |
- ||
| 541 | -8x | +|||
| 22 | +
- prop = estimate,+ #' @describeIn default_stats_formats_labels Get statistics available for a given method |
|||
| 542 | -8x | +|||
| 23 | +
- prop_ci = estimate_ci,+ #' group (analyze function). To check available defaults see `tern::tern_default_stats` list. |
|||
| 543 | -8x | +|||
| 24 | +
- diff = diff_est,+ #' |
|||
| 544 | -8x | +|||
| 25 | +
- diff_ci = diff_ci,+ #' @param method_groups (`character`)\cr indicates the statistical method group (`tern` analyze function) |
|||
| 545 | -8x | +|||
| 26 | +
- weights = wt_normalized,+ #' to retrieve default statistics for. A character vector can be used to specify more than one statistical |
|||
| 546 | -8x | +|||
| 27 | +
- n1 = n1,+ #' method group. |
|||
| 547 | -8x | +|||
| 28 | +
- n2 = n2+ #' @param stats_in (`character`)\cr statistics to retrieve for the selected method group. |
|||
| 548 | +29 |
- )+ #' @param add_pval (`flag`)\cr should `"pval"` (or `"pval_counts"` if `method_groups` contains |
||
| 549 | +30 |
- }+ #' `"analyze_vars_counts"`) be added to the statistical methods? |
||
| 550 | +31 |
-
+ #' |
||
| 551 | +32 |
- #' @describeIn h_prop_diff Calculates the stratified Newcombe confidence interval and difference in response+ #' @return |
||
| 552 | +33 |
- #' rates between the experimental treatment group and the control treatment group, adjusted for stratification+ #' * `get_stats()` returns a `character` vector of statistical methods. |
||
| 553 | +34 |
- #' factors. This implementation follows closely the one proposed by \insertCite{Yan2010-jt;textual}{tern}.
+ #' |
||
| 554 | +35 |
- #' Weights can be estimated from the heuristic proposed in [prop_strat_wilson()] or from CMH-derived weights+ #' @examples |
||
| 555 | +36 |
- #' (see [prop_diff_cmh()]).+ #' # analyze_vars is numeric |
||
| 556 | +37 |
- #'+ #' num_stats <- get_stats("analyze_vars_numeric") # also the default
|
||
| 557 | +38 |
- #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ #' |
||
| 558 | +39 |
- #' @param weights_method (`string`)\cr weights method. Can be either `"cmh"` or `"heuristic"`+ #' # Other type |
||
| 559 | +40 |
- #' and directs the way weights are estimated.+ #' cnt_stats <- get_stats("analyze_vars_counts")
|
||
| 560 | +41 |
#' |
||
| 561 | +42 |
- #' @references+ #' # Weirdly taking the pval from count_occurrences |
||
| 562 | +43 |
- #' \insertRef{Yan2010-jt}{tern}
+ #' only_pval <- get_stats("count_occurrences", add_pval = TRUE, stats_in = "pval")
|
||
| 563 | +44 |
#' |
||
| 564 | +45 |
- #' @examples+ #' # All count_occurrences |
||
| 565 | +46 |
- #' # Stratified Newcombe confidence interval+ #' all_cnt_occ <- get_stats("count_occurrences")
|
||
| 566 | +47 |
#' |
||
| 567 | +48 |
- #' set.seed(2)+ #' # Multiple |
||
| 568 | +49 |
- #' data_set <- data.frame(+ #' get_stats(c("count_occurrences", "analyze_vars_counts"))
|
||
| 569 | +50 |
- #' "rsp" = sample(c(TRUE, FALSE), 100, TRUE),+ #' |
||
| 570 | +51 |
- #' "f1" = sample(c("a", "b"), 100, TRUE),
+ #' @export |
||
| 571 | +52 |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ get_stats <- function(method_groups = "analyze_vars_numeric", stats_in = NULL, add_pval = FALSE) {
|
||
| 572 | -+ | |||
| 53 | +505x |
- #' "grp" = sample(c("Placebo", "Treatment"), 100, TRUE),
+ checkmate::assert_character(method_groups) |
||
| 573 | -+ | |||
| 54 | +505x |
- #' stringsAsFactors = TRUE+ checkmate::assert_character(stats_in, null.ok = TRUE) |
||
| 574 | -+ | |||
| 55 | +505x |
- #' )+ checkmate::assert_flag(add_pval) |
||
| 575 | +56 |
- #'+ |
||
| 576 | +57 |
- #' prop_diff_strat_nc(+ # Default is still numeric |
||
| 577 | -+ | |||
| 58 | +505x |
- #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]),+ if (any(method_groups == "analyze_vars")) {
|
||
| 578 | -+ | |||
| 59 | +3x |
- #' weights_method = "cmh",+ method_groups[method_groups == "analyze_vars"] <- "analyze_vars_numeric" |
||
| 579 | +60 |
- #' conf_level = 0.90+ } |
||
| 580 | +61 |
- #' )+ |
||
| 581 | -+ | |||
| 62 | +505x |
- #'+ type_tmp <- ifelse(any(grepl("counts", method_groups)), "counts", "numeric") # for pval checks
|
||
| 582 | +63 |
- #' prop_diff_strat_nc(+ |
||
| 583 | +64 |
- #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]),+ # Defaults for loop+ |
+ ||
| 65 | +505x | +
+ out <- NULL |
||
| 584 | +66 |
- #' weights_method = "wilson_h",+ |
||
| 585 | +67 |
- #' conf_level = 0.90+ # Loop for multiple method groups+ |
+ ||
| 68 | +505x | +
+ for (mgi in method_groups) {
+ |
+ ||
| 69 | +532x | +
+ out_tmp <- if (mgi %in% names(tern_default_stats)) {
+ |
+ ||
| 70 | +531x | +
+ tern_default_stats[[mgi]] |
||
| 586 | +71 |
- #' )+ } else {
+ |
+ ||
| 72 | +1x | +
+ stop("The selected method group (", mgi, ") has no default statistical method.")
|
||
| 587 | +73 |
- #'+ }+ |
+ ||
| 74 | +531x | +
+ out <- unique(c(out, out_tmp)) |
||
| 588 | +75 |
- #' @export+ } |
||
| 589 | +76 |
- prop_diff_strat_nc <- function(rsp,+ |
||
| 590 | +77 |
- grp,+ # If you added pval to the stats_in you certainly want it |
||
| 591 | -+ | |||
| 78 | +504x |
- strata,+ if (!is.null(stats_in) && any(grepl("^pval", stats_in))) {
|
||
| 592 | -+ | |||
| 79 | +22x |
- weights_method = c("cmh", "wilson_h"),
+ stats_in_pval_value <- stats_in[grepl("^pval", stats_in)]
|
||
| 593 | +80 |
- conf_level = 0.95,+ |
||
| 594 | +81 |
- correct = FALSE) {
+ # Must be only one value between choices |
||
| 595 | -4x | +82 | +22x |
- weights_method <- match.arg(weights_method)+ checkmate::assert_choice(stats_in_pval_value, c("pval", "pval_counts"))
|
| 596 | -4x | +|||
| 83 | +
- grp <- as_factor_keep_attributes(grp)+ |
|||
| 597 | -4x | +|||
| 84 | +
- strata <- as_factor_keep_attributes(strata)+ # Mismatch with counts and numeric |
|||
| 598 | -4x | +85 | +21x |
- check_diff_prop_ci(+ if (any(grepl("counts", method_groups)) && stats_in_pval_value != "pval_counts" ||
|
| 599 | -4x | +86 | +21x |
- rsp = rsp, grp = grp, conf_level = conf_level, strata = strata+ any(grepl("numeric", method_groups)) && stats_in_pval_value != "pval") { # nolint
|
| 600 | -+ | |||
| 87 | +2x |
- )+ stop( |
||
| 601 | -4x | +88 | +2x |
- checkmate::assert_number(conf_level, lower = 0, upper = 1)+ "Inserted p-value (", stats_in_pval_value, ") is not valid for type ",
|
| 602 | -4x | +89 | +2x |
- checkmate::assert_flag(correct)+ type_tmp, ". Use ", paste(ifelse(stats_in_pval_value == "pval", "pval_counts", "pval")), |
| 603 | -4x | +90 | +2x |
- if (any(tapply(rsp, strata, length) < 5)) {
+ " instead." |
| 604 | -! | +|||
| 91 | +
- warning("Less than 5 observations in some strata.")
+ ) |
|||
| 605 | +92 |
- }+ } |
||
| 606 | +93 | |||
| 607 | -4x | +|||
| 94 | +
- rsp_by_grp <- split(rsp, f = grp)+ # Lets add it even if present (thanks to unique) |
|||
| 608 | -4x | +95 | +19x |
- strata_by_grp <- split(strata, f = grp)+ add_pval <- TRUE |
| 609 | +96 |
-
+ } |
||
| 610 | +97 |
- # Finding the weights+ |
||
| 611 | -4x | +|||
| 98 | +
- weights <- if (identical(weights_method, "cmh")) {
+ # Mainly used in "analyze_vars" but it could be necessary elsewhere |
|||
| 612 | -3x | +99 | +501x |
- prop_diff_cmh(rsp = rsp, grp = grp, strata = strata)$weights+ if (isTRUE(add_pval)) {
|
| 613 | -4x | +100 | +29x |
- } else if (identical(weights_method, "wilson_h")) {
+ if (any(grepl("counts", method_groups))) {
|
| 614 | -1x | +101 | +16x |
- prop_strat_wilson(rsp, strata, conf_level = conf_level, correct = correct)$weights+ out <- unique(c(out, "pval_counts")) |
| 615 | +102 |
- }+ } else {
|
||
| 616 | -4x | +103 | +13x |
- weights[levels(strata)[!levels(strata) %in% names(weights)]] <- 0+ out <- unique(c(out, "pval")) |
| 617 | +104 |
-
+ } |
||
| 618 | +105 |
- # Calculating lower (`l`) and upper (`u`) confidence bounds per group.- |
- ||
| 619 | -4x | -
- strat_wilson_by_grp <- Map(- |
- ||
| 620 | -4x | -
- prop_strat_wilson,- |
- ||
| 621 | -4x | -
- rsp = rsp_by_grp,+ } |
||
| 622 | -4x | +|||
| 106 | +
- strata = strata_by_grp,+ |
|||
| 623 | -4x | +|||
| 107 | +
- weights = list(weights, weights),+ # Filtering for stats_in (character vector) |
|||
| 624 | -4x | +108 | +501x |
- conf_level = conf_level,+ if (!is.null(stats_in)) {
|
| 625 | -4x | +109 | +452x |
- correct = correct+ out <- intersect(stats_in, out) # It orders them too |
| 626 | +110 |
- )+ } |
||
| 627 | +111 | |||
| 628 | -4x | +|||
| 112 | +
- ci_ref <- strat_wilson_by_grp[[1]]+ # If intersect did not find matches (and no pval?) -> error |
|||
| 629 | -4x | +113 | +501x |
- ci_trt <- strat_wilson_by_grp[[2]]+ if (length(out) == 0) {
|
| 630 | -4x | +114 | +2x |
- l_ref <- as.numeric(ci_ref$conf_int[1])+ stop( |
| 631 | -4x | +115 | +2x |
- u_ref <- as.numeric(ci_ref$conf_int[2])+ "The selected method group(s) (", paste0(method_groups, collapse = ", "), ")",
|
| 632 | -4x | +116 | +2x |
- l_trt <- as.numeric(ci_trt$conf_int[1])+ " do not have the required default statistical methods:\n", |
| 633 | -4x | +117 | +2x |
- u_trt <- as.numeric(ci_trt$conf_int[2])+ paste0(stats_in, collapse = " ") |
| 634 | +118 |
-
+ ) |
||
| 635 | +119 |
- # Estimating the diff and n_ref, n_trt (it allows different weights to be used)- |
- ||
| 636 | -4x | -
- t_tbl <- table(+ } |
||
| 637 | -4x | +|||
| 120 | +
- factor(rsp, levels = c("FALSE", "TRUE")),
+
|
|||
| 638 | -4x | +121 | +499x |
- grp,+ out |
| 639 | -4x | +|||
| 122 | +
- strata+ } |
|||
| 640 | +123 |
- )+ |
||
| 641 | -4x | +|||
| 124 | +
- n_ref <- colSums(t_tbl[1:2, 1, ])+ #' @describeIn default_stats_formats_labels Get formats corresponding to a list of statistics. |
|||
| 642 | -4x | +|||
| 125 | +
- n_trt <- colSums(t_tbl[1:2, 2, ])+ #' To check available defaults see `tern::tern_default_formats` list. |
|||
| 643 | -4x | +|||
| 126 | +
- use_stratum <- (n_ref > 0) & (n_trt > 0)+ #' |
|||
| 644 | -4x | +|||
| 127 | +
- n_ref <- n_ref[use_stratum]+ #' @param formats_in (named `vector`)\cr inserted formats to replace defaults. It can be a |
|||
| 645 | -4x | +|||
| 128 | +
- n_trt <- n_trt[use_stratum]+ #' character vector from [formatters::list_valid_format_labels()] or a custom format function. |
|||
| 646 | -4x | +|||
| 129 | +
- p_ref <- t_tbl[2, 1, use_stratum] / n_ref+ #' |
|||
| 647 | -4x | +|||
| 130 | +
- p_trt <- t_tbl[2, 2, use_stratum] / n_trt+ #' @return |
|||
| 648 | -4x | +|||
| 131 | +
- est1 <- sum(weights * p_ref)+ #' * `get_formats_from_stats()` returns a named vector of formats (if present in either |
|||
| 649 | -4x | +|||
| 132 | +
- est2 <- sum(weights * p_trt)+ #' `tern_default_formats` or `formats_in`, otherwise `NULL`). Values can be taken from |
|||
| 650 | -4x | +|||
| 133 | +
- diff_est <- est2 - est1+ #' [formatters::list_valid_format_labels()] or a custom function (e.g. [formatting_functions]). |
|||
| 651 | +134 |
-
+ #' |
||
| 652 | -4x | +|||
| 135 | +
- lambda1 <- sum(weights^2 / n_ref)+ #' @note Formats in `tern` and `rtables` can be functions that take in the table cell value and |
|||
| 653 | -4x | +|||
| 136 | +
- lambda2 <- sum(weights^2 / n_trt)+ #' return a string. This is well documented in `vignette("custom_appearance", package = "rtables")`.
|
|||
| 654 | -4x | +|||
| 137 | +
- z <- stats::qnorm((1 + conf_level) / 2)+ #' |
|||
| 655 | +138 |
-
+ #' @examples |
||
| 656 | -4x | +|||
| 139 | +
- lower <- diff_est - z * sqrt(lambda2 * l_trt * (1 - l_trt) + lambda1 * u_ref * (1 - u_ref))+ #' # Defaults formats |
|||
| 657 | -4x | +|||
| 140 | +
- upper <- diff_est + z * sqrt(lambda1 * l_ref * (1 - l_ref) + lambda2 * u_trt * (1 - u_trt))+ #' get_formats_from_stats(num_stats) |
|||
| 658 | +141 |
-
+ #' get_formats_from_stats(cnt_stats) |
||
| 659 | -4x | +|||
| 142 | +
- list(+ #' get_formats_from_stats(only_pval) |
|||
| 660 | -4x | +|||
| 143 | +
- "diff" = diff_est,+ #' get_formats_from_stats(all_cnt_occ) |
|||
| 661 | -4x | +|||
| 144 | +
- "diff_ci" = c("lower" = lower, "upper" = upper)
+ #' |
|||
| 662 | +145 |
- )+ #' # Addition of customs |
||
| 663 | +146 |
- }+ #' get_formats_from_stats(all_cnt_occ, formats_in = c("fraction" = c("xx")))
|
| 1 | +147 |
- #' Proportion estimation+ #' get_formats_from_stats(all_cnt_occ, formats_in = list("fraction" = c("xx.xx", "xx")))
|
||
| 2 | +148 |
#' |
||
| 3 | +149 |
- #' @description `r lifecycle::badge("stable")`
+ #' @seealso [formatting_functions] |
||
| 4 | +150 |
#' |
||
| 5 | +151 |
- #' The analyze function [estimate_proportion()] creates a layout element to estimate the proportion of responders+ #' @export |
||
| 6 | +152 |
- #' within a studied population. The primary analysis variable, `vars`, indicates whether a response has occurred for+ get_formats_from_stats <- function(stats, formats_in = NULL) {
|
||
| 7 | -+ | |||
| 153 | +494x |
- #' each record. See the `method` parameter for options of methods to use when constructing the confidence interval of+ checkmate::assert_character(stats, min.len = 1) |
||
| 8 | +154 |
- #' the proportion. Additionally, a stratification variable can be supplied via the `strata` element of the `variables`+ # It may be a list if there is a function in the formats |
||
| 9 | -+ | |||
| 155 | +494x |
- #' argument.+ if (checkmate::test_list(formats_in, null.ok = TRUE)) {
+ |
+ ||
| 156 | +432x | +
+ checkmate::assert_list(formats_in, null.ok = TRUE) |
||
| 10 | +157 |
- #'+ # Or it may be a vector of characters |
||
| 11 | +158 |
- #' @inheritParams prop_strat_wilson+ } else {
+ |
+ ||
| 159 | +62x | +
+ checkmate::assert_character(formats_in, null.ok = TRUE) |
||
| 12 | +160 |
- #' @inheritParams argument_convention+ } |
||
| 13 | +161 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_proportion")`
+
|
||
| 14 | +162 |
- #' to see available statistics for this function.+ # Extract global defaults+ |
+ ||
| 163 | +494x | +
+ which_fmt <- match(stats, names(tern_default_formats)) |
||
| 15 | +164 |
- #' @param method (`string`)\cr the method used to construct the confidence interval+ |
||
| 16 | +165 |
- #' for proportion of successful outcomes; one of `waldcc`, `wald`, `clopper-pearson`,+ # Select only needed formats from stats+ |
+ ||
| 166 | +494x | +
+ ret <- vector("list", length = length(stats)) # Returning a list is simpler
+ |
+ ||
| 167 | +494x | +
+ ret[!is.na(which_fmt)] <- tern_default_formats[which_fmt[!is.na(which_fmt)]] |
||
| 17 | +168 |
- #' `wilson`, `wilsonc`, `strat_wilson`, `strat_wilsonc`, `agresti-coull` or `jeffreys`.+ + |
+ ||
| 169 | +494x | +
+ out <- setNames(ret, stats) |
||
| 18 | +170 |
- #' @param long (`flag`)\cr whether a long description is required.+ |
||
| 19 | +171 |
- #'+ # Modify some with custom formats+ |
+ ||
| 172 | +494x | +
+ if (!is.null(formats_in)) {
|
||
| 20 | +173 |
- #' @seealso [h_proportions]+ # Stats is the main+ |
+ ||
| 174 | +64x | +
+ common_names <- intersect(names(out), names(formats_in))+ |
+ ||
| 175 | +64x | +
+ out[common_names] <- formats_in[common_names] |
||
| 21 | +176 |
- #'+ } |
||
| 22 | +177 |
- #' @name estimate_proportion+ + |
+ ||
| 178 | +494x | +
+ out |
||
| 23 | +179 |
- #' @order 1+ } |
||
| 24 | +180 |
- NULL+ |
||
| 25 | +181 |
-
+ #' @describeIn default_stats_formats_labels Get labels corresponding to a list of statistics. |
||
| 26 | +182 |
- #' @describeIn estimate_proportion Statistics function estimating a+ #' To check for available defaults see `tern::tern_default_labels` list. If not available there, |
||
| 27 | +183 |
- #' proportion along with its confidence interval.+ #' the statistics name will be used as label. |
||
| 28 | +184 |
#' |
||
| 29 | +185 |
- #' @param df (`logical` or `data.frame`)\cr if only a logical vector is used,+ #' @param labels_in (named `character`)\cr inserted labels to replace defaults. |
||
| 30 | +186 |
- #' it indicates whether each subject is a responder or not. `TRUE` represents+ #' @param row_nms (`character`)\cr row names. Levels of a `factor` or `character` variable, each |
||
| 31 | +187 |
- #' a successful outcome. If a `data.frame` is provided, also the `strata` variable+ #' of which the statistics in `.stats` will be calculated for. If this parameter is set, these |
||
| 32 | +188 |
- #' names must be provided in `variables` as a list element with the strata strings.+ #' variable levels will be used as the defaults, and the names of the given custom values should |
||
| 33 | +189 |
- #' In the case of `data.frame`, the logical vector of responses must be indicated as a+ #' correspond to levels (or have format `statistic.level`) instead of statistics. Can also be |
||
| 34 | +190 |
- #' variable name in `.var`.+ #' variable names if rows correspond to different variables instead of levels. Defaults to `NULL`. |
||
| 35 | +191 |
#' |
||
| 36 | +192 |
#' @return |
||
| 37 | +193 |
- #' * `s_proportion()` returns statistics `n_prop` (`n` and proportion) and `prop_ci` (proportion CI) for a+ #' * `get_labels_from_stats()` returns a named `character` vector of labels (if present in either |
||
| 38 | +194 |
- #' given variable.+ #' `tern_default_labels` or `labels_in`, otherwise `NULL`). |
||
| 39 | +195 |
#' |
||
| 40 | +196 |
#' @examples |
||
| 41 | +197 |
- #' # Case with only logical vector.+ #' # Defaults labels |
||
| 42 | +198 |
- #' rsp_v <- c(1, 0, 1, 0, 1, 1, 0, 0)+ #' get_labels_from_stats(num_stats) |
||
| 43 | +199 |
- #' s_proportion(rsp_v)+ #' get_labels_from_stats(cnt_stats) |
||
| 44 | +200 |
- #'+ #' get_labels_from_stats(only_pval) |
||
| 45 | +201 |
- #' # Example for Stratified Wilson CI+ #' get_labels_from_stats(all_cnt_occ) |
||
| 46 | +202 |
- #' nex <- 100 # Number of example rows+ #' |
||
| 47 | +203 |
- #' dta <- data.frame(+ #' # Addition of customs |
||
| 48 | +204 |
- #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE),+ #' get_labels_from_stats(all_cnt_occ, labels_in = c("fraction" = "Fraction"))
|
||
| 49 | +205 |
- #' "grp" = sample(c("A", "B"), nex, TRUE),
+ #' get_labels_from_stats(all_cnt_occ, labels_in = list("fraction" = c("Some more fractions")))
|
||
| 50 | +206 |
- #' "f1" = sample(c("a1", "a2"), nex, TRUE),
+ #' |
||
| 51 | +207 |
- #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
+ #' @export |
||
| 52 | +208 |
- #' stringsAsFactors = TRUE+ get_labels_from_stats <- function(stats, labels_in = NULL, row_nms = NULL) {
|
||
| 53 | -+ | |||
| 209 | +483x |
- #' )+ checkmate::assert_character(stats, min.len = 1) |
||
| 54 | -+ | |||
| 210 | +483x |
- #'+ checkmate::assert_character(row_nms, null.ok = TRUE) |
||
| 55 | +211 |
- #' s_proportion(+ # It may be a list |
||
| 56 | -+ | |||
| 212 | +483x |
- #' df = dta,+ if (checkmate::test_list(labels_in, null.ok = TRUE)) {
|
||
| 57 | -+ | |||
| 213 | +392x |
- #' .var = "rsp",+ checkmate::assert_list(labels_in, null.ok = TRUE) |
||
| 58 | +214 |
- #' variables = list(strata = c("f1", "f2")),
+ # Or it may be a vector of characters |
||
| 59 | +215 |
- #' conf_level = 0.90,+ } else {
|
||
| 60 | -+ | |||
| 216 | +91x |
- #' method = "strat_wilson"+ checkmate::assert_character(labels_in, null.ok = TRUE) |
||
| 61 | +217 |
- #' )+ } |
||
| 62 | +218 |
- #'+ |
||
| 63 | -+ | |||
| 219 | +483x |
- #' @export+ if (!is.null(row_nms)) {
|
||
| 64 | -+ | |||
| 220 | +83x |
- s_proportion <- function(df,+ ret <- rep(row_nms, length(stats)) |
||
| 65 | -+ | |||
| 221 | +83x |
- .var,+ out <- setNames(ret, paste(rep(stats, each = length(row_nms)), ret, sep = ".")) |
||
| 66 | +222 |
- conf_level = 0.95,+ |
||
| 67 | -+ | |||
| 223 | +83x |
- method = c(+ if (!is.null(labels_in)) {
+ |
+ ||
| 224 | +2x | +
+ lvl_lbls <- intersect(names(labels_in), row_nms)+ |
+ ||
| 225 | +2x | +
+ for (i in lvl_lbls) out[paste(stats, i, sep = ".")] <- labels_in[[i]] |
||
| 68 | +226 |
- "waldcc", "wald", "clopper-pearson",+ } |
||
| 69 | +227 |
- "wilson", "wilsonc", "strat_wilson", "strat_wilsonc",+ } else {
+ |
+ ||
| 228 | +400x | +
+ which_lbl <- match(stats, names(tern_default_labels)) |
||
| 70 | +229 |
- "agresti-coull", "jeffreys"+ + |
+ ||
| 230 | +400x | +
+ ret <- stats # The default+ |
+ ||
| 231 | +400x | +
+ ret[!is.na(which_lbl)] <- tern_default_labels[which_lbl[!is.na(which_lbl)]] |
||
| 71 | +232 |
- ),+ + |
+ ||
| 233 | +400x | +
+ out <- setNames(ret, stats) |
||
| 72 | +234 |
- weights = NULL,+ } |
||
| 73 | +235 |
- max_iterations = 50,+ |
||
| 74 | +236 |
- variables = list(strata = NULL),+ # Modify some with custom labels+ |
+ ||
| 237 | +483x | +
+ if (!is.null(labels_in)) {
|
||
| 75 | +238 |
- long = FALSE) {
+ # Stats is the main |
||
| 76 | -167x | +239 | +93x |
- method <- match.arg(method)+ common_names <- intersect(names(out), names(labels_in)) |
| 77 | -167x | +240 | +93x |
- checkmate::assert_flag(long)+ out[common_names] <- labels_in[common_names] |
| 78 | -167x | +|||
| 241 | +
- assert_proportion_value(conf_level)+ } |
|||
| 79 | +242 | |||
| 80 | -167x | +243 | +483x |
- if (!is.null(variables$strata)) {
+ out |
| 81 | +244 |
- # Checks for strata- |
- ||
| 82 | -! | -
- if (missing(df)) stop("When doing stratified analysis a data.frame with specific columns is needed.")
+ } |
||
| 83 | -! | +|||
| 245 | +
- strata_colnames <- variables$strata+ |
|||
| 84 | -! | +|||
| 246 | +
- checkmate::assert_character(strata_colnames, null.ok = FALSE)+ #' @describeIn default_stats_formats_labels Format indent modifiers for a given vector/list of statistics. |
|||
| 85 | -! | +|||
| 247 | +
- strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)+ #' It defaults to 0L for all values. |
|||
| 86 | -! | +|||
| 248 | +
- assert_df_with_variables(df, strata_vars)+ #' |
|||
| 87 | +249 |
-
+ #' @param indents_in (named `vector`)\cr inserted indent modifiers to replace defaults (default is `0L`). |
||
| 88 | -! | +|||
| 250 | +
- strata <- interaction(df[strata_colnames])+ #' |
|||
| 89 | -! | +|||
| 251 | +
- strata <- as.factor(strata)+ #' @return |
|||
| 90 | +252 |
-
+ #' * `get_indents_from_stats()` returns a single indent modifier value to apply to all rows |
||
| 91 | +253 |
- # Pushing down checks to prop_strat_wilson+ #' or a named numeric vector of indent modifiers (if present, otherwise `NULL`). |
||
| 92 | -167x | +|||
| 254 | +
- } else if (checkmate::test_subset(method, c("strat_wilson", "strat_wilsonc"))) {
+ #' |
|||
| 93 | -! | +|||
| 255 | +
- stop("To use stratified methods you need to specify the strata variables.")
+ #' @examples |
|||
| 94 | +256 |
- }+ #' get_indents_from_stats(all_cnt_occ, indents_in = 3L) |
||
| 95 | -167x | +|||
| 257 | +
- if (checkmate::test_atomic_vector(df)) {
+ #' get_indents_from_stats(all_cnt_occ, indents_in = list(count = 2L, count_fraction = 5L)) |
|||
| 96 | -167x | +|||
| 258 | +
- rsp <- as.logical(df)+ #' get_indents_from_stats( |
|||
| 97 | +259 |
- } else {
+ #' all_cnt_occ, |
||
| 98 | -! | +|||
| 260 | +
- rsp <- as.logical(df[[.var]])+ #' indents_in = list(a = 2L, count.a = 1L, count.b = 5L), row_nms = c("a", "b")
|
|||
| 99 | +261 |
- }+ #' ) |
||
| 100 | -167x | +|||
| 262 | +
- n <- sum(rsp)+ #' |
|||
| 101 | -167x | +|||
| 263 | +
- p_hat <- mean(rsp)+ #' @export |
|||
| 102 | +264 |
-
+ get_indents_from_stats <- function(stats, indents_in = NULL, row_nms = NULL) {
|
||
| 103 | -167x | +265 | +444x |
- prop_ci <- switch(method,+ checkmate::assert_character(stats, min.len = 1) |
| 104 | -167x | +266 | +444x |
- "clopper-pearson" = prop_clopper_pearson(rsp, conf_level),+ checkmate::assert_character(row_nms, null.ok = TRUE) |
| 105 | -167x | +|||
| 267 | +
- "wilson" = prop_wilson(rsp, conf_level),+ # It may be a list |
|||
| 106 | -167x | +268 | +444x |
- "wilsonc" = prop_wilson(rsp, conf_level, correct = TRUE),+ if (checkmate::test_list(indents_in, null.ok = TRUE)) {
|
| 107 | -167x | +269 | +402x |
- "strat_wilson" = prop_strat_wilson(rsp,+ checkmate::assert_list(indents_in, null.ok = TRUE) |
| 108 | -167x | +|||
| 270 | +
- strata,+ # Or it may be a vector of integers |
|||
| 109 | -167x | +|||
| 271 | +
- weights,+ } else {
|
|||
| 110 | -167x | +272 | +42x |
- conf_level,+ checkmate::assert_integerish(indents_in, null.ok = TRUE) |
| 111 | -167x | +|||
| 273 | +
- max_iterations,+ } |
|||
| 112 | -167x | +|||
| 274 | +
- correct = FALSE+ |
|||
| 113 | -167x | +275 | +444x |
- )$conf_int,+ if (is.null(names(indents_in)) && length(indents_in) == 1) {
|
| 114 | -167x | +276 | +9x |
- "strat_wilsonc" = prop_strat_wilson(rsp,+ out <- rep(indents_in, length(stats) * if (!is.null(row_nms)) length(row_nms) else 1) |
| 115 | -167x | +277 | +9x |
- strata,+ return(out) |
| 116 | -167x | +|||
| 278 | +
- weights,+ } |
|||
| 117 | -167x | +|||
| 279 | +
- conf_level,+ |
|||
| 118 | -167x | +280 | +435x |
- max_iterations,+ if (!is.null(row_nms)) {
|
| 119 | -167x | +281 | +77x |
- correct = TRUE+ ret <- rep(0L, length(stats) * length(row_nms)) |
| 120 | -167x | +282 | +77x |
- )$conf_int,+ out <- setNames(ret, paste(rep(stats, each = length(row_nms)), rep(row_nms, length(stats)), sep = ".")) |
| 121 | -167x | +|||
| 283 | +
- "wald" = prop_wald(rsp, conf_level),+ |
|||
| 122 | -167x | +284 | +77x |
- "waldcc" = prop_wald(rsp, conf_level, correct = TRUE),+ if (!is.null(indents_in)) {
|
| 123 | -167x | +285 | +2x |
- "agresti-coull" = prop_agresti_coull(rsp, conf_level),+ lvl_lbls <- intersect(names(indents_in), row_nms) |
| 124 | -167x | +286 | +2x |
- "jeffreys" = prop_jeffreys(rsp, conf_level)+ for (i in lvl_lbls) out[paste(stats, i, sep = ".")] <- indents_in[[i]] |
| 125 | +287 |
- )+ } |
||
| 126 | +288 | - - | -||
| 127 | -167x | -
- list(- |
- ||
| 128 | -167x | -
- "n_prop" = formatters::with_label(c(n, p_hat), "Responders"),+ } else {
|
||
| 129 | -167x | +289 | +358x |
- "prop_ci" = formatters::with_label(+ ret <- rep(0L, length(stats)) |
| 130 | -167x | -
- x = 100 * prop_ci, label = d_proportion(conf_level, method, long = long)- |
- ||
| 131 | -+ | 290 | +358x |
- )+ out <- setNames(ret, stats) |
| 132 | +291 |
- )+ } |
||
| 133 | +292 |
- }+ |
||
| 134 | +293 |
-
+ # Modify some with custom labels |
||
| 135 | -+ | |||
| 294 | +435x |
- #' @describeIn estimate_proportion Formatted analysis function which is used as `afun`+ if (!is.null(indents_in)) {
|
||
| 136 | +295 |
- #' in `estimate_proportion()`.+ # Stats is the main |
||
| 137 | -+ | |||
| 296 | +34x |
- #'+ common_names <- intersect(names(out), names(indents_in)) |
||
| 138 | -+ | |||
| 297 | +34x |
- #' @return+ out[common_names] <- indents_in[common_names] |
||
| 139 | +298 |
- #' * `a_proportion()` returns the corresponding list with formatted [rtables::CellValue()].+ } |
||
| 140 | +299 |
- #'+ |
||
| 141 | -+ | |||
| 300 | +435x |
- #' @export+ out |
||
| 142 | +301 |
- a_proportion <- make_afun(+ } |
||
| 143 | +302 |
- s_proportion,+ |
||
| 144 | +303 |
- .formats = c(n_prop = "xx (xx.x%)", prop_ci = "(xx.x, xx.x)")+ #' Update labels according to control specifications |
||
| 145 | +304 |
- )+ #' |
||
| 146 | +305 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 147 | +306 |
- #' @describeIn estimate_proportion Layout-creating function which can take statistics function arguments+ #' |
||
| 148 | +307 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' Given a list of statistic labels and and a list of control parameters, updates labels with a relevant |
||
| 149 | +308 |
- #'+ #' control specification. For example, if control has element `conf_level` set to `0.9`, the default |
||
| 150 | +309 |
- #' @return+ #' label for statistic `mean_ci` will be updated to `"Mean 90% CI"`. Any labels that are supplied |
||
| 151 | +310 |
- #' * `estimate_proportion()` returns a layout object suitable for passing to further layouting functions,+ #' via `labels_custom` will not be updated regardless of `control`. |
||
| 152 | +311 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 153 | +312 |
- #' the statistics from `s_proportion()` to the table layout.+ #' @param labels_default (named `character`)\cr a named vector of statistic labels to modify |
||
| 154 | +313 |
- #'+ #' according to the control specifications. Labels that are explicitly defined in `labels_custom` will |
||
| 155 | +314 |
- #' @examples+ #' not be affected. |
||
| 156 | +315 |
- #' dta_test <- data.frame(+ #' @param labels_custom (named `character`)\cr named vector of labels that are customized by |
||
| 157 | +316 |
- #' USUBJID = paste0("S", 1:12),
+ #' the user and should not be affected by `control`. |
||
| 158 | +317 |
- #' ARM = rep(LETTERS[1:3], each = 4),+ #' @param control (named `list`)\cr list of control parameters to apply to adjust default labels. |
||
| 159 | +318 |
- #' AVAL = rep(LETTERS[1:3], each = 4)+ #' |
||
| 160 | +319 |
- #' )+ #' @return A named character vector of labels with control specifications applied to relevant labels. |
||
| 161 | +320 |
#' |
||
| 162 | +321 |
- #' basic_table() %>%+ #' @examples |
||
| 163 | +322 |
- #' split_cols_by("ARM") %>%
+ #' control <- list(conf_level = 0.80, quantiles = c(0.1, 0.83), test_mean = 0.57) |
||
| 164 | +323 |
- #' estimate_proportion(vars = "AVAL") %>%+ #' get_labels_from_stats(c("mean_ci", "quantiles", "mean_pval")) %>%
|
||
| 165 | +324 |
- #' build_table(df = dta_test)+ #' labels_use_control(control = control) |
||
| 166 | +325 |
#' |
||
| 167 | +326 |
#' @export |
||
| 168 | +327 |
- #' @order 2+ labels_use_control <- function(labels_default, control, labels_custom = NULL) {
|
||
| 169 | -+ | |||
| 328 | +20x |
- estimate_proportion <- function(lyt,+ if ("conf_level" %in% names(control)) {
|
||
| 170 | -+ | |||
| 329 | +20x |
- vars,+ labels_default <- sapply( |
||
| 171 | -+ | |||
| 330 | +20x |
- conf_level = 0.95,+ names(labels_default), |
||
| 172 | -+ | |||
| 331 | +20x |
- method = c(+ function(x) {
|
||
| 173 | -+ | |||
| 332 | +91x |
- "waldcc", "wald", "clopper-pearson",+ if (!x %in% names(labels_custom)) {
|
||
| 174 | -+ | |||
| 333 | +88x |
- "wilson", "wilsonc", "strat_wilson", "strat_wilsonc",+ gsub(labels_default[[x]], pattern = "[0-9]+% CI", replacement = f_conf_level(control[["conf_level"]])) |
||
| 175 | +334 |
- "agresti-coull", "jeffreys"+ } else {
|
||
| 176 | -+ | |||
| 335 | +3x |
- ),+ labels_default[[x]] |
||
| 177 | +336 |
- weights = NULL,+ } |
||
| 178 | +337 |
- max_iterations = 50,+ } |
||
| 179 | +338 |
- variables = list(strata = NULL),+ ) |
||
| 180 | +339 |
- long = FALSE,+ } |
||
| 181 | -+ | |||
| 340 | +20x |
- na_str = default_na_str(),+ if ("quantiles" %in% names(control) && "quantiles" %in% names(labels_default) &&
|
||
| 182 | -+ | |||
| 341 | +20x |
- nested = TRUE,+ !"quantiles" %in% names(labels_custom)) { # nolint
|
||
| 183 | -+ | |||
| 342 | +16x |
- ...,+ labels_default["quantiles"] <- gsub( |
||
| 184 | -+ | |||
| 343 | +16x |
- show_labels = "hidden",+ "[0-9]+% and [0-9]+", paste0(control[["quantiles"]][1] * 100, "% and ", control[["quantiles"]][2] * 100, ""), |
||
| 185 | -+ | |||
| 344 | +16x |
- table_names = vars,+ labels_default["quantiles"] |
||
| 186 | +345 |
- .stats = NULL,+ ) |
||
| 187 | +346 |
- .formats = NULL,+ } |
||
| 188 | -+ | |||
| 347 | +20x |
- .labels = NULL,+ if ("test_mean" %in% names(control) && "mean_pval" %in% names(labels_default) &&
|
||
| 189 | -+ | |||
| 348 | +20x |
- .indent_mods = NULL) {
+ !"mean_pval" %in% names(labels_custom)) { # nolint
|
||
| 190 | -3x | +349 | +2x |
- extra_args <- list(+ labels_default["mean_pval"] <- gsub( |
| 191 | -3x | +350 | +2x |
- conf_level = conf_level, method = method, weights = weights, max_iterations = max_iterations,+ "p-value \\(H0: mean = [0-9\\.]+\\)", f_pval(control[["test_mean"]]), labels_default["mean_pval"] |
| 192 | -3x | +|||
| 351 | +
- variables = variables, long = long, ...+ ) |
|||
| 193 | +352 |
- )+ } |
||
| 194 | +353 | |||
| 195 | -3x | +354 | +20x |
- afun <- make_afun(+ labels_default |
| 196 | -3x | +|||
| 355 | +
- a_proportion,+ } |
|||
| 197 | -3x | +|||
| 356 | +
- .stats = .stats,+ |
|||
| 198 | -3x | +|||
| 357 | +
- .formats = .formats,+ #' @describeIn default_stats_formats_labels Named list of available statistics by method group for `tern`. |
|||
| 199 | -3x | +|||
| 358 | +
- .labels = .labels,+ #' |
|||
| 200 | -3x | +|||
| 359 | +
- .indent_mods = .indent_mods+ #' @format |
|||
| 201 | +360 |
- )+ #' * `tern_default_stats` is a named list of available statistics, with each element |
||
| 202 | -3x | +|||
| 361 | +
- analyze(+ #' named for their corresponding statistical method group. |
|||
| 203 | -3x | +|||
| 362 | +
- lyt,+ #' |
|||
| 204 | -3x | +|||
| 363 | +
- vars,+ #' @export |
|||
| 205 | -3x | +|||
| 364 | +
- afun = afun,+ tern_default_stats <- list( |
|||
| 206 | -3x | +|||
| 365 | +
- na_str = na_str,+ abnormal = c("fraction"),
|
|||
| 207 | -3x | +|||
| 366 | +
- nested = nested,+ abnormal_by_baseline = c("fraction"),
|
|||
| 208 | -3x | +|||
| 367 | +
- extra_args = extra_args,+ abnormal_by_marked = c("count_fraction", "count_fraction_fixed_dp"),
|
|||
| 209 | -3x | +|||
| 368 | +
- show_labels = show_labels,+ abnormal_by_worst_grade = c("count_fraction", "count_fraction_fixed_dp"),
|
|||
| 210 | -3x | +|||
| 369 | +
- table_names = table_names+ abnormal_by_worst_grade_worsen = c("fraction"),
|
|||
| 211 | +370 |
- )+ analyze_patients_exposure_in_cols = c("n_patients", "sum_exposure"),
|
||
| 212 | +371 |
- }+ analyze_vars_counts = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "fraction", "n_blq"),
|
||
| 213 | +372 |
-
+ analyze_vars_numeric = c( |
||
| 214 | +373 |
- #' Helper functions for calculating proportion confidence intervals+ "n", "sum", "mean", "sd", "se", "mean_sd", "mean_se", "mean_ci", "mean_sei", "mean_sdi", "mean_pval", |
||
| 215 | +374 |
- #'+ "median", "mad", "median_ci", "quantiles", "iqr", "range", "min", "max", "median_range", "cv", |
||
| 216 | +375 |
- #' @description `r lifecycle::badge("stable")`
+ "geom_mean", "geom_mean_ci", "geom_cv" |
||
| 217 | +376 |
- #'+ ), |
||
| 218 | +377 |
- #' Functions to calculate different proportion confidence intervals for use in [estimate_proportion()].+ count_cumulative = c("count_fraction", "count_fraction_fixed_dp"),
|
||
| 219 | +378 |
- #'+ count_missed_doses = c("n", "count_fraction", "count_fraction_fixed_dp"),
|
||
| 220 | +379 |
- #' @inheritParams argument_convention+ count_occurrences = c("count", "count_fraction", "count_fraction_fixed_dp", "fraction"),
|
||
| 221 | +380 |
- #' @inheritParams estimate_proportion+ count_occurrences_by_grade = c("count_fraction", "count_fraction_fixed_dp"),
|
||
| 222 | +381 |
- #'+ count_patients_with_event = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
|
||
| 223 | +382 |
- #' @return Confidence interval of a proportion.+ count_patients_with_flags = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
|
||
| 224 | +383 |
- #'+ count_values = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
|
||
| 225 | +384 |
- #' @seealso [estimate_proportion], descriptive function [d_proportion()],+ coxph_pairwise = c("pvalue", "hr", "hr_ci", "n_tot", "n_tot_events"),
|
||
| 226 | +385 |
- #' and helper functions [strata_normal_quantile()] and [update_weights_strat_wilson()].+ estimate_incidence_rate = c("person_years", "n_events", "rate", "rate_ci", "n_unique", "n_rate"),
|
||
| 227 | +386 |
- #'+ estimate_multinomial_response = c("n_prop", "prop_ci"),
|
||
| 228 | +387 |
- #' @name h_proportions+ estimate_odds_ratio = c("or_ci", "n_tot"),
|
||
| 229 | +388 |
- NULL+ estimate_proportion = c("n_prop", "prop_ci"),
|
||
| 230 | +389 |
-
+ estimate_proportion_diff = c("diff", "diff_ci"),
|
||
| 231 | +390 |
- #' @describeIn h_proportions Calculates the Wilson interval by calling [stats::prop.test()].+ summarize_ancova = c("n", "lsmean", "lsmean_diff", "lsmean_diff_ci", "pval"),
|
||
| 232 | +391 |
- #' Also referred to as Wilson score interval.+ summarize_coxreg = c("n", "hr", "ci", "pval", "pval_inter"),
|
||
| 233 | +392 |
- #'+ summarize_glm_count = c("n", "rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
|
||
| 234 | +393 |
- #' @examples+ summarize_num_patients = c("unique", "nonunique", "unique_count"),
|
||
| 235 | +394 |
- #' rsp <- c(+ summarize_patients_events_in_cols = c("unique", "all"),
|
||
| 236 | +395 |
- #' TRUE, TRUE, TRUE, TRUE, TRUE,+ surv_time = c("median", "median_ci", "quantiles", "range_censor", "range_event", "range"),
|
||
| 237 | +396 |
- #' FALSE, FALSE, FALSE, FALSE, FALSE+ surv_timepoint = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci", "rate_diff", "rate_diff_ci", "ztest_pval"),
|
||
| 238 | +397 |
- #' )+ tabulate_rsp_biomarkers = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
|
||
| 239 | +398 |
- #' prop_wilson(rsp, conf_level = 0.9)+ tabulate_rsp_subgroups = c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval"),
|
||
| 240 | +399 |
- #'+ tabulate_survival_biomarkers = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
|
||
| 241 | +400 |
- #' @export+ tabulate_survival_subgroups = c("n_tot_events", "n_events", "n_tot", "n", "median", "hr", "ci", "pval"),
|
||
| 242 | +401 |
- prop_wilson <- function(rsp, conf_level, correct = FALSE) {
+ test_proportion_diff = c("pval")
|
||
| 243 | -5x | +|||
| 402 | +
- y <- stats::prop.test(+ ) |
|||
| 244 | -5x | +|||
| 403 | +
- sum(rsp),+ |
|||
| 245 | -5x | +|||
| 404 | +
- length(rsp),+ #' @describeIn default_stats_formats_labels Named vector of default formats for `tern`. |
|||
| 246 | -5x | +|||
| 405 | +
- correct = correct,+ #' |
|||
| 247 | -5x | +|||
| 406 | +
- conf.level = conf_level+ #' @format |
|||
| 248 | +407 |
- )+ #' * `tern_default_formats` is a named vector of available default formats, with each element |
||
| 249 | +408 |
-
+ #' named for their corresponding statistic. |
||
| 250 | -5x | +|||
| 409 | +
- as.numeric(y$conf.int)+ #' |
|||
| 251 | +410 |
- }+ #' @export |
||
| 252 | +411 |
-
+ tern_default_formats <- c( |
||
| 253 | +412 |
- #' @describeIn h_proportions Calculates the stratified Wilson confidence+ fraction = format_fraction_fixed_dp, |
||
| 254 | +413 |
- #' interval for unequal proportions as described in \insertCite{Yan2010-jt;textual}{tern}
+ unique = format_count_fraction_fixed_dp, |
||
| 255 | +414 |
- #'+ nonunique = "xx", |
||
| 256 | +415 |
- #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ unique_count = "xx", |
||
| 257 | +416 |
- #' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are+ n = "xx.", |
||
| 258 | +417 |
- #' estimated using the iterative algorithm proposed in \insertCite{Yan2010-jt;textual}{tern} that
+ count = "xx.", |
||
| 259 | +418 |
- #' minimizes the weighted squared length of the confidence interval.+ count_fraction = format_count_fraction, |
||
| 260 | +419 |
- #' @param max_iterations (`count`)\cr maximum number of iterations for the iterative procedure used+ count_fraction_fixed_dp = format_count_fraction_fixed_dp, |
||
| 261 | +420 |
- #' to find estimates of optimal weights.+ n_blq = "xx.", |
||
| 262 | +421 |
- #' @param correct (`flag`)\cr whether to include the continuity correction. For further information, see for example+ sum = "xx.x", |
||
| 263 | +422 |
- #' for [stats::prop.test()].+ mean = "xx.x", |
||
| 264 | +423 |
- #'+ sd = "xx.x", |
||
| 265 | +424 |
- #' @references+ se = "xx.x", |
||
| 266 | +425 |
- #' \insertRef{Yan2010-jt}{tern}
+ mean_sd = "xx.x (xx.x)", |
||
| 267 | +426 |
- #'+ mean_se = "xx.x (xx.x)", |
||
| 268 | +427 |
- #' @examples+ mean_ci = "(xx.xx, xx.xx)", |
||
| 269 | +428 |
- #' # Stratified Wilson confidence interval with unequal probabilities+ mean_sei = "(xx.xx, xx.xx)", |
||
| 270 | +429 |
- #'+ mean_sdi = "(xx.xx, xx.xx)", |
||
| 271 | +430 |
- #' set.seed(1)+ mean_pval = "x.xxxx | (<0.0001)", |
||
| 272 | +431 |
- #' rsp <- sample(c(TRUE, FALSE), 100, TRUE)+ median = "xx.x", |
||
| 273 | +432 |
- #' strata_data <- data.frame(+ mad = "xx.x", |
||
| 274 | +433 |
- #' "f1" = sample(c("a", "b"), 100, TRUE),
+ median_ci = "(xx.xx, xx.xx)", |
||
| 275 | +434 |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ quantiles = "xx.x - xx.x", |
||
| 276 | +435 |
- #' stringsAsFactors = TRUE+ iqr = "xx.x", |
||
| 277 | +436 |
- #' )+ range = "xx.x - xx.x", |
||
| 278 | +437 |
- #' strata <- interaction(strata_data)+ min = "xx.x", |
||
| 279 | +438 |
- #' n_strata <- ncol(table(rsp, strata)) # Number of strata+ max = "xx.x",+ |
+ ||
| 439 | ++ |
+ median_range = "xx.x (xx.x - xx.x)",+ |
+ ||
| 440 | ++ |
+ cv = "xx.x", |
||
| 280 | +441 |
- #'+ geom_mean = "xx.x", |
||
| 281 | +442 |
- #' prop_strat_wilson(+ geom_mean_ci = "(xx.xx, xx.xx)", |
||
| 282 | +443 |
- #' rsp = rsp, strata = strata,+ geom_cv = "xx.x", |
||
| 283 | +444 |
- #' conf_level = 0.90+ pval = "x.xxxx | (<0.0001)", |
||
| 284 | +445 |
- #' )+ pval_counts = "x.xxxx | (<0.0001)", |
||
| 285 | +446 |
- #'+ range_censor = "xx.x to xx.x", |
||
| 286 | +447 |
- #' # Not automatic setting of weights+ range_event = "xx.x to xx.x", |
||
| 287 | +448 |
- #' prop_strat_wilson(+ rate = "xx.xxxx", |
||
| 288 | +449 |
- #' rsp = rsp, strata = strata,+ rate_ci = "(xx.xxxx, xx.xxxx)", |
||
| 289 | +450 |
- #' weights = rep(1 / n_strata, n_strata),+ rate_ratio = "xx.xxxx", |
||
| 290 | +451 |
- #' conf_level = 0.90+ rate_ratio_ci = "(xx.xxxx, xx.xxxx)" |
||
| 291 | +452 |
- #' )+ ) |
||
| 292 | +453 |
- #'+ |
||
| 293 | +454 |
- #' @export+ #' @describeIn default_stats_formats_labels Named `character` vector of default labels for `tern`. |
||
| 294 | +455 |
- prop_strat_wilson <- function(rsp,+ #' |
||
| 295 | +456 |
- strata,+ #' @format |
||
| 296 | +457 |
- weights = NULL,+ #' * `tern_default_labels` is a named `character` vector of available default labels, with each element |
||
| 297 | +458 |
- conf_level = 0.95,+ #' named for their corresponding statistic. |
||
| 298 | +459 |
- max_iterations = NULL,+ #' |
||
| 299 | +460 |
- correct = FALSE) {
+ #' @export |
||
| 300 | -20x | +|||
| 461 | +
- checkmate::assert_logical(rsp, any.missing = FALSE)+ tern_default_labels <- c( |
|||
| 301 | -20x | +|||
| 462 | +
- checkmate::assert_factor(strata, len = length(rsp))+ fraction = "fraction", |
|||
| 302 | -20x | +|||
| 463 | +
- assert_proportion_value(conf_level)+ unique = "Number of patients with at least one event", |
|||
| 303 | +464 |
-
+ nonunique = "Number of events", |
||
| 304 | -20x | +|||
| 465 | +
- tbl <- table(rsp, strata)+ n = "n", |
|||
| 305 | -20x | +|||
| 466 | +
- n_strata <- length(unique(strata))+ count = "count", |
|||
| 306 | +467 |
-
+ count_fraction = "count_fraction", |
||
| 307 | +468 |
- # Checking the weights and maximum number of iterations.+ count_fraction_fixed_dp = "count_fraction", |
||
| 308 | -20x | +|||
| 469 | +
- do_iter <- FALSE+ n_blq = "n_blq", |
|||
| 309 | -20x | +|||
| 470 | +
- if (is.null(weights)) {
+ sum = "Sum", |
|||
| 310 | -6x | +|||
| 471 | +
- weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure+ mean = "Mean", |
|||
| 311 | -6x | +|||
| 472 | +
- do_iter <- TRUE+ sd = "SD", |
|||
| 312 | +473 |
-
+ se = "SE", |
||
| 313 | +474 |
- # Iteration parameters+ mean_sd = "Mean (SD)", |
||
| 314 | -2x | +|||
| 475 | +
- if (is.null(max_iterations)) max_iterations <- 10+ mean_se = "Mean (SE)", |
|||
| 315 | -6x | +|||
| 476 | +
- checkmate::assert_int(max_iterations, na.ok = FALSE, null.ok = FALSE, lower = 1)+ mean_ci = "Mean 95% CI", |
|||
| 316 | +477 |
- }+ mean_sei = "Mean -/+ 1xSE", |
||
| 317 | -20x | +|||
| 478 | +
- checkmate::assert_numeric(weights, lower = 0, upper = 1, any.missing = FALSE, len = n_strata)+ mean_sdi = "Mean -/+ 1xSD", |
|||
| 318 | -20x | +|||
| 479 | +
- sum_weights <- checkmate::assert_int(sum(weights))+ mean_pval = "Mean p-value (H0: mean = 0)", |
|||
| 319 | -! | +|||
| 480 | +
- if (as.integer(sum_weights + 0.5) != 1L) stop("Sum of weights must be 1L.")
+ median = "Median", |
|||
| 320 | +481 |
-
+ mad = "Median Absolute Deviation", |
||
| 321 | -20x | +|||
| 482 | +
- xs <- tbl["TRUE", ]+ median_ci = "Median 95% CI", |
|||
| 322 | -20x | +|||
| 483 | +
- ns <- colSums(tbl)+ quantiles = "25% and 75%-ile", |
|||
| 323 | -20x | +|||
| 484 | +
- use_stratum <- (ns > 0)+ iqr = "IQR", |
|||
| 324 | -20x | +|||
| 485 | +
- ns <- ns[use_stratum]+ range = "Min - Max", |
|||
| 325 | -20x | +|||
| 486 | +
- xs <- xs[use_stratum]+ min = "Minimum", |
|||
| 326 | -20x | +|||
| 487 | +
- ests <- xs / ns+ max = "Maximum", |
|||
| 327 | -20x | +|||
| 488 | +
- vars <- ests * (1 - ests) / ns+ median_range = "Median (Min - Max)", |
|||
| 328 | +489 |
-
+ cv = "CV (%)", |
||
| 329 | -20x | +|||
| 490 | +
- strata_qnorm <- strata_normal_quantile(vars, weights, conf_level)+ geom_mean = "Geometric Mean", |
|||
| 330 | +491 |
-
+ geom_mean_ci = "Geometric Mean 95% CI", |
||
| 331 | +492 |
- # Iterative setting of weights if they were not set externally+ geom_cv = "CV % Geometric Mean", |
||
| 332 | -20x | +|||
| 493 | +
- weights_new <- if (do_iter) {
+ pval = "p-value (t-test)", # Default for numeric |
|||
| 333 | -6x | +|||
| 494 | +
- update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max_iterations, conf_level)$weights+ pval_counts = "p-value (chi-squared test)", # Default for counts |
|||
| 334 | +495 |
- } else {
+ rate = "Adjusted Rate", |
||
| 335 | -14x | +|||
| 496 | +
- weights+ rate_ratio = "Adjusted Rate Ratio" |
|||
| 336 | +497 |
- }+ ) |
||
| 337 | +498 | |||
| 338 | -20x | +|||
| 499 | +
- strata_conf_level <- 2 * stats::pnorm(strata_qnorm) - 1+ # To deprecate --------- |
|||
| 339 | +500 | |||
| 340 | -20x | +|||
| 501 | +
- ci_by_strata <- Map(+ #' @describeIn default_stats_formats_labels `r lifecycle::badge("deprecated")`
|
|||
| 341 | -20x | +|||
| 502 | +
- function(x, n) {
+ #' Quick function to retrieve default formats for summary statistics: |
|||
| 342 | +503 |
- # Classic Wilson's confidence interval+ #' [analyze_vars()] and [analyze_vars_in_cols()] principally. |
||
| 343 | -139x | +|||
| 504 | +
- suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf_level)$conf.int)+ #' |
|||
| 344 | +505 |
- },+ #' @param type (`string`)\cr `"numeric"` or `"counts"`. |
||
| 345 | -20x | +|||
| 506 | +
- x = xs,+ #' |
|||
| 346 | -20x | +|||
| 507 | +
- n = ns+ #' @return |
|||
| 347 | +508 |
- )+ #' * `summary_formats()` returns a named `vector` of default statistic formats for the given data type. |
||
| 348 | -20x | +|||
| 509 | +
- lower_by_strata <- sapply(ci_by_strata, "[", 1L)+ #' |
|||
| 349 | -20x | +|||
| 510 | +
- upper_by_strata <- sapply(ci_by_strata, "[", 2L)+ #' @examples |
|||
| 350 | +511 |
-
+ #' summary_formats() |
||
| 351 | -20x | +|||
| 512 | +
- lower <- sum(weights_new * lower_by_strata)+ #' summary_formats(type = "counts", include_pval = TRUE) |
|||
| 352 | -20x | +|||
| 513 | +
- upper <- sum(weights_new * upper_by_strata)+ #' |
|||
| 353 | +514 |
-
+ #' @export |
||
| 354 | +515 |
- # Return values+ summary_formats <- function(type = "numeric", include_pval = FALSE) {
|
||
| 355 | -20x | +516 | +2x |
- if (do_iter) {
+ lifecycle::deprecate_warn( |
| 356 | -6x | +517 | +2x |
- list(+ "0.9.6", "summary_formats()", |
| 357 | -6x | +518 | +2x |
- conf_int = c(+ details = 'Use get_formats_from_stats(get_stats("analyze_vars_numeric", add_pval = include_pval)) instead'
|
| 358 | -6x | +|||
| 519 | +
- lower = lower,+ ) |
|||
| 359 | -6x | -
- upper = upper- |
- ||
| 360 | -+ | 520 | +2x |
- ),+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
|
| 361 | -6x | +521 | +2x |
- weights = weights_new+ get_formats_from_stats(get_stats(met_grp, add_pval = include_pval)) |
| 362 | +522 |
- )+ } |
||
| 363 | +523 |
- } else {
- |
- ||
| 364 | -14x | -
- list(- |
- ||
| 365 | -14x | -
- conf_int = c(- |
- ||
| 366 | -14x | -
- lower = lower,+ |
||
| 367 | -14x | +|||
| 524 | +
- upper = upper+ #' @describeIn default_stats_formats_labels `r lifecycle::badge("deprecated")`
|
|||
| 368 | +525 |
- )+ #' Quick function to retrieve default labels for summary statistics. |
||
| 369 | +526 |
- )+ #' Returns labels of descriptive statistics which are understood by `rtables`. Similar to `summary_formats`. |
||
| 370 | +527 |
- }+ #' |
||
| 371 | +528 |
- }+ #' @param include_pval (`flag`)\cr same as the `add_pval` argument in [get_stats()]. |
||
| 372 | +529 |
-
+ #' |
||
| 373 | +530 |
- #' @describeIn h_proportions Calculates the Clopper-Pearson interval by calling [stats::binom.test()].+ #' @return |
||
| 374 | +531 |
- #' Also referred to as the `exact` method.+ #' * `summary_labels` returns a named `vector` of default statistic labels for the given data type. |
||
| 375 | +532 |
#' |
||
| 376 | +533 |
#' @examples |
||
| 377 | +534 |
- #' prop_clopper_pearson(rsp, conf_level = .95)+ #' summary_labels() |
||
| 378 | +535 |
- #'+ #' summary_labels(type = "counts", include_pval = TRUE) |
||
| 379 | +536 |
- #' @export+ #' |
||
| 380 | +537 |
- prop_clopper_pearson <- function(rsp,+ #' @export |
||
| 381 | +538 |
- conf_level) {
- |
- ||
| 382 | -1x | -
- y <- stats::binom.test(+ summary_labels <- function(type = "numeric", include_pval = FALSE) {
|
||
| 383 | -1x | +539 | +2x |
- x = sum(rsp),+ lifecycle::deprecate_warn( |
| 384 | -1x | +540 | +2x |
- n = length(rsp),+ "0.9.6", "summary_formats()", |
| 385 | -1x | +541 | +2x |
- conf.level = conf_level+ details = 'Use get_labels_from_stats(get_stats("analyze_vars_numeric", add_pval = include_pval)) instead'
|
| 386 | +542 |
) |
||
| 387 | -1x | +543 | +2x |
- as.numeric(y$conf.int)+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ |
+
| 544 | +2x | +
+ get_labels_from_stats(get_stats(met_grp, add_pval = include_pval)) |
||
| 388 | +545 |
} |
| 389 | +1 |
-
+ #' Re-implemented `range()` default S3 method for numerical objects |
||
| 390 | +2 |
- #' @describeIn h_proportions Calculates the Wald interval by following the usual textbook definition+ #' |
||
| 391 | +3 |
- #' for a single proportion confidence interval using the normal approximation.+ #' This function returns `c(NA, NA)` instead of `c(-Inf, Inf)` for zero-length data |
||
| 392 | +4 | ++ |
+ #' without any warnings.+ |
+ |
| 5 |
#' |
|||
| 393 | +6 |
- #' @param correct (`flag`)\cr whether to apply continuity correction.+ #' @param x (`numeric`)\cr a sequence of numbers for which the range is computed. |
||
| 394 | +7 |
- #'+ #' @param na.rm (`flag`)\cr flag indicating if `NA` should be omitted. |
||
| 395 | +8 |
- #' @examples+ #' @param finite (`flag`)\cr flag indicating if non-finite elements should be removed. |
||
| 396 | +9 |
- #' prop_wald(rsp, conf_level = 0.95)+ #' |
||
| 397 | +10 |
- #' prop_wald(rsp, conf_level = 0.95, correct = TRUE)+ #' @return A 2-element vector of class `numeric`. |
||
| 398 | +11 |
#' |
||
| 399 | +12 |
- #' @export+ #' @keywords internal |
||
| 400 | +13 |
- prop_wald <- function(rsp, conf_level, correct = FALSE) {
+ range_noinf <- function(x, na.rm = FALSE, finite = FALSE) { # nolint
+ |
+ ||
| 14 | ++ | + | ||
| 401 | -163x | +15 | +1842x |
- n <- length(rsp)+ checkmate::assert_numeric(x)+ |
+
| 16 | ++ | + | ||
| 402 | -163x | +17 | +1842x |
- p_hat <- mean(rsp)+ if (finite) {
|
| 403 | -163x | +18 | +24x |
- z <- stats::qnorm((1 + conf_level) / 2)+ x <- x[is.finite(x)] # removes NAs too |
| 404 | -163x | +19 | +1818x |
- q_hat <- 1 - p_hat+ } else if (na.rm) {
|
| 405 | -163x | +20 | +708x |
- correct <- if (correct) 1 / (2 * n) else 0+ x <- x[!is.na(x)] |
| 406 | +21 | ++ |
+ }+ |
+ |
| 22 | ||||
| 407 | -163x | +23 | +1842x |
- err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correct+ if (length(x) == 0) {
|
| 408 | -163x | +24 | +111x |
- l_ci <- max(0, p_hat - err)+ rval <- c(NA, NA) |
| 409 | -163x | +25 | +111x |
- u_ci <- min(1, p_hat + err)+ mode(rval) <- typeof(x) |
| 410 | +26 |
-
+ } else {
|
||
| 411 | -163x | +27 | +1731x |
- c(l_ci, u_ci)+ rval <- c(min(x, na.rm = FALSE), max(x, na.rm = FALSE)) |
| 412 | +28 |
- }+ } |
||
| 413 | +29 | |||
| 414 | -+ | |||
| 30 | +1842x |
- #' @describeIn h_proportions Calculates the Agresti-Coull interval. Constructed (for 95% CI) by adding two successes+ return(rval) |
||
| 415 | +31 |
- #' and two failures to the data and then using the Wald formula to construct a CI.+ } |
||
| 416 | +32 |
- #'+ |
||
| 417 | +33 |
- #' @examples+ #' Utility function to create label for confidence interval |
||
| 418 | +34 |
- #' prop_agresti_coull(rsp, conf_level = 0.95)+ #' |
||
| 419 | +35 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 420 | +36 |
- #' @export+ #' |
||
| 421 | +37 |
- prop_agresti_coull <- function(rsp, conf_level) {
- |
- ||
| 422 | -3x | -
- n <- length(rsp)- |
- ||
| 423 | -3x | -
- x_sum <- sum(rsp)- |
- ||
| 424 | -3x | -
- z <- stats::qnorm((1 + conf_level) / 2)+ #' @inheritParams argument_convention |
||
| 425 | +38 |
-
+ #' |
||
| 426 | +39 |
- # Add here both z^2 / 2 successes and failures.- |
- ||
| 427 | -3x | -
- x_sum_tilde <- x_sum + z^2 / 2- |
- ||
| 428 | -3x | -
- n_tilde <- n + z^2+ #' @return A `string`. |
||
| 429 | +40 |
-
+ #' |
||
| 430 | +41 |
- # Then proceed as with the Wald interval.- |
- ||
| 431 | -3x | -
- p_tilde <- x_sum_tilde / n_tilde- |
- ||
| 432 | -3x | -
- q_tilde <- 1 - p_tilde- |
- ||
| 433 | -3x | -
- err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)+ #' @export |
||
| 434 | -3x | +|||
| 42 | +
- l_ci <- max(0, p_tilde - err)+ f_conf_level <- function(conf_level) {
|
|||
| 435 | -3x | -
- u_ci <- min(1, p_tilde + err)- |
- ||
| 436 | -+ | 43 | +3860x |
-
+ assert_proportion_value(conf_level) |
| 437 | -3x | +44 | +3858x |
- c(l_ci, u_ci)+ paste0(conf_level * 100, "% CI") |
| 438 | +45 |
} |
||
| 439 | +46 | |||
| 440 | +47 |
- #' @describeIn h_proportions Calculates the Jeffreys interval, an equal-tailed interval based on the+ #' Utility function to create label for p-value |
||
| 441 | +48 |
- #' non-informative Jeffreys prior for a binomial proportion.+ #' |
||
| 442 | +49 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 443 | +50 |
- #' @examples+ #' |
||
| 444 | +51 |
- #' prop_jeffreys(rsp, conf_level = 0.95)+ #' @param test_mean (`numeric(1)`)\cr mean value to test under the null hypothesis. |
||
| 445 | +52 |
#' |
||
| 446 | +53 |
- #' @export+ #' @return A `string`. |
||
| 447 | +54 |
- prop_jeffreys <- function(rsp,+ #' |
||
| 448 | +55 |
- conf_level) {
- |
- ||
| 449 | -5x | -
- n <- length(rsp)- |
- ||
| 450 | -5x | -
- x_sum <- sum(rsp)+ #' @export |
||
| 451 | +56 |
-
+ f_pval <- function(test_mean) {
|
||
| 452 | -5x | +57 | +1103x |
- alpha <- 1 - conf_level+ checkmate::assert_numeric(test_mean, len = 1) |
| 453 | -5x | +58 | +1101x |
- l_ci <- ifelse(+ paste0("p-value (H0: mean = ", test_mean, ")")
|
| 454 | -5x | +|||
| 59 | +
- x_sum == 0,+ } |
|||
| 455 | -5x | +|||
| 60 | +
- 0,+ |
|||
| 456 | -5x | +|||
| 61 | +
- stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ #' Utility function to return a named list of covariate names |
|||
| 457 | +62 |
- )+ #' |
||
| 458 | +63 |
-
+ #' @param covariates (`character`)\cr a vector that can contain single variable names (such as |
||
| 459 | -5x | +|||
| 64 | +
- u_ci <- ifelse(+ #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`. |
|||
| 460 | -5x | +|||
| 65 | +
- x_sum == n,+ #' |
|||
| 461 | -5x | +|||
| 66 | +
- 1,+ #' @return A named `list` of `character` vector. |
|||
| 462 | -5x | +|||
| 67 | +
- stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ #' |
|||
| 463 | +68 |
- )+ #' @keywords internal |
||
| 464 | +69 |
-
+ get_covariates <- function(covariates) {
|
||
| 465 | -5x | +70 | +14x |
- c(l_ci, u_ci)+ checkmate::assert_character(covariates) |
| 466 | -+ | |||
| 71 | +12x |
- }+ cov_vars <- unique(trimws(unlist(strsplit(covariates, "\\*")))) |
||
| 467 | -+ | |||
| 72 | +12x |
-
+ stats::setNames(as.list(cov_vars), cov_vars) |
||
| 468 | +73 |
- #' Description of the proportion summary+ } |
||
| 469 | +74 |
- #'+ |
||
| 470 | +75 |
- #' @description `r lifecycle::badge("stable")`
+ #' Replicate entries of a vector if required |
||
| 471 | +76 |
#' |
||
| 472 | +77 |
- #' This is a helper function that describes the analysis in [s_proportion()].+ #' @description `r lifecycle::badge("stable")`
|
||
| 473 | +78 |
#' |
||
| 474 | +79 |
- #' @inheritParams s_proportion+ #' Replicate entries of a vector if required. |
||
| 475 | +80 |
- #' @param long (`flag`)\cr whether a long or a short (default) description is required.+ #' |
||
| 476 | +81 |
- #'+ #' @inheritParams argument_convention |
||
| 477 | +82 |
- #' @return String describing the analysis.+ #' @param n (`integer(1)`)\cr number of entries that are needed. |
||
| 478 | +83 |
#' |
||
| 479 | +84 |
- #' @export+ #' @return `x` if it has the required length already or is `NULL`, |
||
| 480 | +85 |
- d_proportion <- function(conf_level,+ #' otherwise if it is scalar the replicated version of it with `n` entries. |
||
| 481 | +86 |
- method,+ #' |
||
| 482 | +87 |
- long = FALSE) {
- |
- ||
| 483 | -179x | -
- label <- paste0(conf_level * 100, "% CI")+ #' @note This function will fail if `x` is not of length `n` and/or is not a scalar. |
||
| 484 | +88 |
-
+ #' |
||
| 485 | -! | +|||
| 89 | +
- if (long) label <- paste(label, "for Response Rates")+ #' @export |
|||
| 486 | +90 |
-
+ to_n <- function(x, n) {
|
||
| 487 | -179x | +91 | +5x |
- method_part <- switch(method,+ if (is.null(x)) {
|
| 488 | -179x | +92 | +1x |
- "clopper-pearson" = "Clopper-Pearson",+ NULL |
| 489 | -179x | +93 | +4x |
- "waldcc" = "Wald, with correction",+ } else if (length(x) == 1) {
|
| 490 | -179x | +94 | +1x |
- "wald" = "Wald, without correction",+ rep(x, n) |
| 491 | -179x | +95 | +3x |
- "wilson" = "Wilson, without correction",+ } else if (length(x) == n) {
|
| 492 | -179x | +96 | +2x |
- "strat_wilson" = "Stratified Wilson, without correction",+ x |
| 493 | -179x | +|||
| 97 | +
- "wilsonc" = "Wilson, with correction",+ } else {
|
|||
| 494 | -179x | +98 | +1x |
- "strat_wilsonc" = "Stratified Wilson, with correction",+ stop("dimension mismatch")
|
| 495 | -179x | +|||
| 99 | +
- "agresti-coull" = "Agresti-Coull",+ } |
|||
| 496 | -179x | +|||
| 100 | +
- "jeffreys" = "Jeffreys",+ } |
|||
| 497 | -179x | +|||
| 101 | +
- stop(paste(method, "does not have a description"))+ |
|||
| 498 | +102 |
- )+ #' Check element dimension |
||
| 499 | +103 |
-
+ #' |
||
| 500 | -179x | +|||
| 104 | +
- paste0(label, " (", method_part, ")")
+ #' Checks if the elements in `...` have the same dimension. |
|||
| 501 | +105 |
- }+ #' |
||
| 502 | +106 |
-
+ #' @param ... (`data.frame` or `vector`)\cr any data frames or vectors. |
||
| 503 | +107 |
- #' Helper function for the estimation of stratified quantiles+ #' @param omit_null (`flag`)\cr whether `NULL` elements in `...` should be omitted from the check. |
||
| 504 | +108 |
#' |
||
| 505 | +109 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return A `logical` value. |
||
| 506 | +110 |
#' |
||
| 507 | +111 |
- #' This function wraps the estimation of stratified percentiles when we assume+ #' @keywords internal |
||
| 508 | +112 |
- #' the approximation for large numbers. This is necessary only in the case+ check_same_n <- function(..., omit_null = TRUE) {
|
||
| 509 | -+ | |||
| 113 | +2x |
- #' proportions for each strata are unequal.+ dots <- list(...) |
||
| 510 | +114 |
- #'+ |
||
| 511 | -+ | |||
| 115 | +2x |
- #' @inheritParams argument_convention+ n_list <- Map( |
||
| 512 | -+ | |||
| 116 | +2x |
- #' @inheritParams prop_strat_wilson+ function(x, name) {
|
||
| 513 | -+ | |||
| 117 | +5x |
- #'+ if (is.null(x)) {
|
||
| 514 | -+ | |||
| 118 | +! |
- #' @return Stratified quantile.+ if (omit_null) {
|
||
| 515 | -+ | |||
| 119 | +2x |
- #'+ NA_integer_ |
||
| 516 | +120 |
- #' @seealso [prop_strat_wilson()]+ } else {
|
||
| 517 | -+ | |||
| 121 | +! |
- #'+ stop("arg", name, "is not supposed to be NULL")
|
||
| 518 | +122 |
- #' @examples+ } |
||
| 519 | -+ | |||
| 123 | +5x |
- #' strata_data <- table(data.frame(+ } else if (is.data.frame(x)) {
|
||
| 520 | -+ | |||
| 124 | +! |
- #' "f1" = sample(c(TRUE, FALSE), 100, TRUE),+ nrow(x) |
||
| 521 | -+ | |||
| 125 | +5x |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ } else if (is.atomic(x)) {
|
||
| 522 | -+ | |||
| 126 | +5x |
- #' stringsAsFactors = TRUE+ length(x) |
||
| 523 | +127 |
- #' ))+ } else {
|
||
| 524 | -+ | |||
| 128 | +! |
- #' ns <- colSums(strata_data)+ stop("data structure for ", name, "is currently not supported")
|
||
| 525 | +129 |
- #' ests <- strata_data["TRUE", ] / ns+ } |
||
| 526 | +130 |
- #' vars <- ests * (1 - ests) / ns+ }, |
||
| 527 | -+ | |||
| 131 | +2x |
- #' weights <- rep(1 / length(ns), length(ns))+ dots, names(dots) |
||
| 528 | +132 |
- #'+ ) |
||
| 529 | +133 |
- #' strata_normal_quantile(vars, weights, 0.95)+ |
||
| 530 | -+ | |||
| 134 | +2x |
- #'+ n <- stats::na.omit(unlist(n_list)) |
||
| 531 | +135 |
- #' @export+ |
||
| 532 | -+ | |||
| 136 | +2x |
- strata_normal_quantile <- function(vars, weights, conf_level) {
+ if (length(unique(n)) > 1) {
|
||
| 533 | -43x | +|||
| 137 | +! |
- summands <- weights^2 * vars+ sel <- which(n != n[1])+ |
+ ||
| 138 | +! | +
+ stop("Dimension mismatch:", paste(names(n)[sel], collapse = ", "), " do not have N=", n[1])
|
||
| 534 | +139 |
- # Stratified quantile+ }+ |
+ ||
| 140 | ++ | + | ||
| 535 | -43x | +141 | +2x |
- sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf_level) / 2)+ TRUE |
| 536 | +142 |
} |
||
| 537 | +143 | |||
| 538 | +144 |
- #' Helper function for the estimation of weights for `prop_strat_wilson()`+ #' Utility function to check if a float value is equal to another float value |
||
| 539 | +145 |
#' |
||
| 540 | +146 |
- #' @description `r lifecycle::badge("stable")`
+ #' Uses `.Machine$double.eps` as the tolerance for the comparison. |
||
| 541 | +147 |
#' |
||
| 542 | +148 |
- #' This function wraps the iteration procedure that allows you to estimate+ #' @param x (`numeric(1)`)\cr a float number. |
||
| 543 | +149 |
- #' the weights for each proportional strata. This assumes to minimize the+ #' @param y (`numeric(1)`)\cr a float number. |
||
| 544 | +150 |
- #' weighted squared length of the confidence interval.+ #' |
||
| 545 | +151 | ++ |
+ #' @return `TRUE` if identical, otherwise `FALSE`.+ |
+ |
| 152 |
#' |
|||
| 546 | +153 |
- #' @inheritParams prop_strat_wilson+ #' @keywords internal |
||
| 547 | +154 |
- #' @param vars (`numeric`)\cr normalized proportions for each strata.+ .is_equal_float <- function(x, y) {
+ |
+ ||
| 155 | +2820x | +
+ checkmate::assert_number(x)+ |
+ ||
| 156 | +2820x | +
+ checkmate::assert_number(y) |
||
| 548 | +157 |
- #' @param strata_qnorm (`numeric(1)`)\cr initial estimation with identical weights of the quantiles.+ |
||
| 549 | +158 |
- #' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can+ # Define a tolerance+ |
+ ||
| 159 | +2820x | +
+ tolerance <- .Machine$double.eps |
||
| 550 | +160 |
- #' be optimized in the future if we need to estimate better initial weights.+ |
||
| 551 | +161 |
- #' @param n_per_strata (`numeric`)\cr number of elements in each strata.+ # Check if x is close enough to y+ |
+ ||
| 162 | +2820x | +
+ abs(x - y) < tolerance |
||
| 552 | +163 |
- #' @param max_iterations (`integer(1)`)\cr maximum number of iterations to be tried. Convergence is always checked.+ } |
||
| 553 | +164 |
- #' @param tol (`numeric(1)`)\cr tolerance threshold for convergence.+ |
||
| 554 | +165 | ++ |
+ #' Make names without dots+ |
+ |
| 166 |
#' |
|||
| 555 | +167 |
- #' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`.+ #' @param nams (`character`)\cr vector of original names. |
||
| 556 | +168 |
#' |
||
| 557 | +169 |
- #' @seealso For references and details see [prop_strat_wilson()].+ #' @return A `character` `vector` of proper names, which does not use dots in contrast to [make.names()]. |
||
| 558 | +170 |
#' |
||
| 559 | +171 |
- #' @examples+ #' @keywords internal |
||
| 560 | +172 |
- #' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018)+ make_names <- function(nams) {
+ |
+ ||
| 173 | +6x | +
+ orig <- make.names(nams)+ |
+ ||
| 174 | +6x | +
+ gsub(".", "", x = orig, fixed = TRUE)
|
||
| 561 | +175 |
- #' sq <- 0.674+ } |
||
| 562 | +176 |
- #' ws <- rep(1 / length(vs), length(vs))+ |
||
| 563 | +177 |
- #' ns <- c(22, 18, 17, 17, 14, 12)+ #' Conversion of months to days |
||
| 564 | +178 |
#' |
||
| 565 | +179 |
- #' update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001)+ #' @description `r lifecycle::badge("stable")`
|
||
| 566 | +180 |
#' |
||
| 567 | +181 |
- #' @export+ #' Conversion of months to days. This is an approximative calculation because it |
||
| 568 | +182 |
- update_weights_strat_wilson <- function(vars,+ #' considers each month as having an average of 30.4375 days. |
||
| 569 | +183 |
- strata_qnorm,+ #' |
||
| 570 | +184 |
- initial_weights,+ #' @param x (`numeric(1)`)\cr time in months. |
||
| 571 | +185 |
- n_per_strata,+ #' |
||
| 572 | +186 |
- max_iterations = 50,+ #' @return A `numeric` vector with the time in days. |
||
| 573 | +187 |
- conf_level = 0.95,+ #' |
||
| 574 | +188 |
- tol = 0.001) {
+ #' @examples |
||
| 575 | -9x | +|||
| 189 | +
- it <- 0+ #' x <- c(13.25, 8.15, 1, 2.834) |
|||
| 576 | -9x | +|||
| 190 | +
- diff_v <- NULL+ #' month2day(x) |
|||
| 577 | +191 |
-
+ #' |
||
| 578 | -9x | +|||
| 192 | +
- while (it < max_iterations) {
+ #' @export |
|||
| 579 | -21x | +|||
| 193 | +
- it <- it + 1+ month2day <- function(x) {
|
|||
| 580 | -21x | +194 | +1x |
- weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2+ checkmate::assert_numeric(x) |
| 581 | -21x | +195 | +1x |
- weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2))+ x * 30.4375 |
| 582 | -21x | +|||
| 196 | +
- weights_new <- weights_new_t / weights_new_b+ } |
|||
| 583 | -21x | +|||
| 197 | +
- weights_new <- weights_new / sum(weights_new)+ |
|||
| 584 | -21x | +|||
| 198 | +
- strata_qnorm <- strata_normal_quantile(vars, weights_new, conf_level)+ #' Conversion of days to months |
|||
| 585 | -21x | +|||
| 199 | +
- diff_v <- c(diff_v, sum(abs(weights_new - initial_weights)))+ #' |
|||
| 586 | -8x | +|||
| 200 | +
- if (diff_v[length(diff_v)] < tol) break+ #' @param x (`numeric(1)`)\cr time in days. |
|||
| 587 | -13x | +|||
| 201 | +
- initial_weights <- weights_new+ #' |
|||
| 588 | +202 |
- }+ #' @return A `numeric` vector with the time in months. |
||
| 589 | +203 |
-
+ #' |
||
| 590 | -9x | +|||
| 204 | +
- if (it == max_iterations) {
+ #' @examples |
|||
| 591 | -1x | +|||
| 205 | +
- warning("The heuristic to find weights did not converge with max_iterations = ", max_iterations)
+ #' x <- c(403, 248, 30, 86) |
|||
| 592 | +206 |
- }+ #' day2month(x) |
||
| 593 | +207 |
-
+ #' |
||
| 594 | -9x | +|||
| 208 | +
- list(+ #' @export |
|||
| 595 | -9x | +|||
| 209 | +
- "n_it" = it,+ day2month <- function(x) {
|
|||
| 596 | -9x | +210 | +19x |
- "weights" = weights_new,+ checkmate::assert_numeric(x) |
| 597 | -9x | +211 | +19x |
- "diff_v" = diff_v+ x / 30.4375 |
| 598 | +212 |
- )+ } |
||
| 599 | +213 |
- }+ |
| 1 | +214 |
- #' Helper functions for subgroup treatment effect pattern (STEP) calculations+ #' Return an empty numeric if all elements are `NA`. |
||
| 2 | +215 |
#' |
||
| 3 | +216 |
- #' @description `r lifecycle::badge("stable")`
+ #' @param x (`numeric`)\cr vector. |
||
| 4 | +217 |
#' |
||
| 5 | +218 |
- #' Helper functions that are used internally for the STEP calculations.+ #' @return An empty `numeric` if all elements of `x` are `NA`, otherwise `x`. |
||
| 6 | +219 |
#' |
||
| 7 | +220 |
- #' @inheritParams argument_convention+ #' @examples |
||
| 8 | +221 |
- #'+ #' x <- c(NA, NA, NA) |
||
| 9 | +222 |
- #' @name h_step+ #' # Internal function - empty_vector_if_na |
||
| 10 | +223 |
- #' @include control_step.R+ #' @keywords internal |
||
| 11 | +224 |
- NULL+ empty_vector_if_na <- function(x) {
+ |
+ ||
| 225 | +1017x | +
+ if (all(is.na(x))) {
+ |
+ ||
| 226 | +310x | +
+ numeric() |
||
| 12 | +227 |
-
+ } else {
+ |
+ ||
| 228 | +707x | +
+ x |
||
| 13 | +229 |
- #' @describeIn h_step Creates the windows for STEP, based on the control settings+ } |
||
| 14 | +230 |
- #' provided.+ } |
||
| 15 | +231 | ++ | + + | +|
| 232 | ++ |
+ #' Element-wise combination of two vectors+ |
+ ||
| 233 |
#' |
|||
| 16 | +234 |
- #' @param x (`numeric`)\cr biomarker value(s) to use (without `NA`).+ #' @param x (`vector`)\cr first vector to combine. |
||
| 17 | +235 |
- #' @param control (named `list`)\cr output from `control_step()`.+ #' @param y (`vector`)\cr second vector to combine. |
||
| 18 | +236 |
#' |
||
| 19 | +237 |
- #' @return+ #' @return A `list` where each element combines corresponding elements of `x` and `y`. |
||
| 20 | +238 |
- #' * `h_step_window()` returns a list containing the window-selection matrix `sel`+ #' |
||
| 21 | +239 |
- #' and the interval information matrix `interval`.+ #' @examples |
||
| 22 | +240 |
- #'+ #' combine_vectors(1:3, 4:6) |
||
| 23 | +241 |
- #' @export+ #' |
||
| 24 | +242 |
- h_step_window <- function(x,+ #' @export |
||
| 25 | +243 |
- control = control_step()) {
+ combine_vectors <- function(x, y) {
|
||
| 26 | -12x | +244 | +51x |
- checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)+ checkmate::assert_vector(x) |
| 27 | -12x | +245 | +51x |
- checkmate::assert_list(control, names = "named")+ checkmate::assert_vector(y, len = length(x)) |
| 28 | +246 | |||
| 29 | -12x | +247 | +51x |
- sel <- matrix(FALSE, length(x), control$num_points)+ result <- lapply(as.data.frame(rbind(x, y)), `c`) |
| 30 | -12x | +248 | +51x |
- out <- matrix(0, control$num_points, 3)+ names(result) <- NULL |
| 31 | -12x | +249 | +51x |
- colnames(out) <- paste("Interval", c("Center", "Lower", "Upper"))
+ result |
| 32 | -12x | +|||
| 250 | +
- if (control$use_percentile) {
+ } |
|||
| 33 | +251 |
- # Create windows according to percentile cutoffs.+ |
||
| 34 | -9x | +|||
| 252 | +
- out <- cbind(out, out)+ #' Extract elements by name |
|||
| 35 | -9x | +|||
| 253 | +
- colnames(out)[1:3] <- paste("Percentile", c("Center", "Lower", "Upper"))
+ #' |
|||
| 36 | -9x | +|||
| 254 | +
- xs <- seq(0, 1, length.out = control$num_points + 2)[-1]+ #' This utility function extracts elements from a vector `x` by `names`. |
|||
| 37 | -9x | +|||
| 255 | +
- for (i in seq_len(control$num_points)) {
+ #' Differences to the standard `[` function are: |
|||
| 38 | -185x | +|||
| 256 | +
- out[i, 2:3] <- c(+ #' |
|||
| 39 | -185x | +|||
| 257 | +
- max(xs[i] - control$bandwidth, 0),+ #' - If `x` is `NULL`, then still always `NULL` is returned (same as in base function). |
|||
| 40 | -185x | +|||
| 258 | +
- min(xs[i] + control$bandwidth, 1)+ #' - If `x` is not `NULL`, then the intersection of its names is made with `names` and those |
|||
| 41 | +259 |
- )+ #' elements are returned. That is, `names` which don't appear in `x` are not returned as `NA`s. |
||
| 42 | -185x | +|||
| 260 | +
- out[i, 5:6] <- stats::quantile(x, out[i, 2:3])+ #' |
|||
| 43 | -185x | +|||
| 261 | +
- sel[, i] <- x >= out[i, 5] & x <= out[i, 6]+ #' @param x (named `vector`)\cr where to extract named elements from. |
|||
| 44 | +262 |
- }+ #' @param names (`character`)\cr vector of names to extract. |
||
| 45 | +263 |
- # Center is the middle point of the percentile window.+ #' |
||
| 46 | -9x | +|||
| 264 | +
- out[, 1] <- xs[-control$num_points - 1]+ #' @return `NULL` if `x` is `NULL`, otherwise the extracted elements from `x`. |
|||
| 47 | -9x | +|||
| 265 | +
- out[, 4] <- stats::quantile(x, out[, 1])+ #' |
|||
| 48 | +266 |
- } else {
+ #' @keywords internal |
||
| 49 | +267 |
- # Create windows according to cutoffs.+ extract_by_name <- function(x, names) {
|
||
| 50 | +268 | 3x |
- m <- c(min(x), max(x))+ if (is.null(x)) {
|
|
| 51 | -3x | +269 | +1x |
- xs <- seq(m[1], m[2], length.out = control$num_points + 2)[-1]+ return(NULL) |
| 52 | -3x | +|||
| 270 | +
- for (i in seq_len(control$num_points)) {
+ } |
|||
| 53 | -11x | +271 | +2x |
- out[i, 2:3] <- c(+ checkmate::assert_named(x) |
| 54 | -11x | +272 | +2x |
- max(xs[i] - control$bandwidth, m[1]),+ checkmate::assert_character(names) |
| 55 | -11x | -
- min(xs[i] + control$bandwidth, m[2])- |
- ||
| 56 | -+ | 273 | +2x |
- )+ which_extract <- intersect(names(x), names) |
| 57 | -11x | +274 | +2x |
- sel[, i] <- x >= out[i, 2] & x <= out[i, 3]+ if (length(which_extract) > 0) {
|
| 58 | -+ | |||
| 275 | +1x |
- }+ x[which_extract] |
||
| 59 | +276 |
- # Center is the same as the point for predicting.+ } else {
|
||
| 60 | -3x | +277 | +1x |
- out[, 1] <- xs[-control$num_points - 1]+ NULL |
| 61 | +278 |
} |
||
| 62 | -12x | -
- list(sel = sel, interval = out)- |
- ||
| 63 | +279 |
} |
||
| 64 | +280 | |||
| 65 | +281 |
- #' @describeIn h_step Calculates the estimated treatment effect estimate+ #' Labels for adverse event baskets |
||
| 66 | +282 |
- #' on the linear predictor scale and corresponding standard error from a STEP `model` fitted+ #' |
||
| 67 | +283 |
- #' on `data` given `variables` specification, for a single biomarker value `x`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 68 | +284 |
- #' This works for both `coxph` and `glm` models, i.e. for calculating log hazard ratio or log odds+ #' |
||
| 69 | +285 |
- #' ratio estimates.+ #' @param aesi (`character`)\cr vector with standardized MedDRA query name (e.g. `SMQxxNAM`) or customized query |
||
| 70 | +286 |
- #'+ #' name (e.g. `CQxxNAM`). |
||
| 71 | +287 |
- #' @param model (`coxph` or `glm`)\cr the regression model object.+ #' @param scope (`character`)\cr vector with scope of query (e.g. `SMQxxSC`). |
||
| 72 | +288 |
#' |
||
| 73 | +289 |
- #' @return+ #' @return A `string` with the standard label for the AE basket. |
||
| 74 | +290 |
- #' * `h_step_trt_effect()` returns a vector with elements `est` and `se`.+ #' |
||
| 75 | +291 |
- #'+ #' @examples |
||
| 76 | +292 |
- #' @export+ #' adae <- tern_ex_adae |
||
| 77 | +293 |
- h_step_trt_effect <- function(data,+ #' |
||
| 78 | +294 |
- model,+ #' # Standardized query label includes scope. |
||
| 79 | +295 |
- variables,+ #' aesi_label(adae$SMQ01NAM, scope = adae$SMQ01SC) |
||
| 80 | +296 |
- x) {
- |
- ||
| 81 | -208x | -
- checkmate::assert_multi_class(model, c("coxph", "glm"))
- |
- ||
| 82 | -208x | -
- checkmate::assert_number(x)+ #' |
||
| 83 | -208x | +|||
| 297 | +
- assert_df_with_variables(data, variables)+ #' # Customized query label. |
|||
| 84 | -208x | +|||
| 298 | +
- checkmate::assert_factor(data[[variables$arm]], n.levels = 2)+ #' aesi_label(adae$CQ01NAM) |
|||
| 85 | +299 |
-
+ #' |
||
| 86 | -208x | +|||
| 300 | +
- newdata <- data[c(1, 1), ]+ #' @export |
|||
| 87 | -208x | +|||
| 301 | +
- newdata[, variables$biomarker] <- x+ aesi_label <- function(aesi, scope = NULL) {
|
|||
| 88 | -208x | +302 | +4x |
- newdata[, variables$arm] <- levels(data[[variables$arm]])+ checkmate::assert_character(aesi) |
| 89 | -208x | +303 | +4x |
- model_terms <- stats::delete.response(stats::terms(model))+ checkmate::assert_character(scope, null.ok = TRUE) |
| 90 | -208x | +304 | +4x |
- model_frame <- stats::model.frame(model_terms, data = newdata, xlev = model$xlevels)+ aesi_label <- obj_label(aesi) |
| 91 | -208x | +305 | +4x |
- mat <- stats::model.matrix(model_terms, data = model_frame, contrasts.arg = model$contrasts)+ aesi <- sas_na(aesi) |
| 92 | -208x | -
- coefs <- stats::coef(model)- |
- ||
| 93 | -+ | 306 | +4x |
- # Note: It is important to use the coef subset from matrix, otherwise intercept and+ aesi <- unique(aesi)[!is.na(unique(aesi))] |
| 94 | +307 |
- # strata are included for coxph() models.+ |
||
| 95 | -208x | +308 | +4x |
- mat <- mat[, names(coefs)]+ lbl <- if (length(aesi) == 1 && !is.null(scope)) {
|
| 96 | -208x | +309 | +1x |
- mat_diff <- diff(mat)+ scope <- sas_na(scope) |
| 97 | -208x | +310 | +1x |
- est <- mat_diff %*% coefs+ scope <- unique(scope)[!is.na(unique(scope))] |
| 98 | -208x | +311 | +1x |
- var <- mat_diff %*% stats::vcov(model) %*% t(mat_diff)+ checkmate::assert_string(scope) |
| 99 | -208x | +312 | +1x |
- se <- sqrt(var)+ paste0(aesi, " (", scope, ")")
|
| 100 | -208x | +313 | +4x |
- c(+ } else if (length(aesi) == 1 && is.null(scope)) {
|
| 101 | -208x | +314 | +1x |
- est = est,+ aesi |
| 102 | -208x | +|||
| 315 | +
- se = se+ } else {
|
|||
| 103 | -+ | |||
| 316 | +2x |
- )+ aesi_label |
||
| 104 | +317 |
- }+ } |
||
| 105 | +318 | |||
| 106 | -+ | |||
| 319 | +4x |
- #' @describeIn h_step Builds the model formula used in survival STEP calculations.+ lbl |
||
| 107 | +320 |
- #'+ } |
||
| 108 | +321 |
- #' @return+ |
||
| 109 | +322 |
- #' * `h_step_survival_formula()` returns a model formula.+ #' Indicate study arm variable in formula |
||
| 110 | +323 |
#' |
||
| 111 | +324 |
- #' @export+ #' We use `study_arm` to indicate the study arm variable in `tern` formulas. |
||
| 112 | +325 |
- h_step_survival_formula <- function(variables,+ #' |
||
| 113 | +326 |
- control = control_step()) {
- |
- ||
| 114 | -10x | -
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ #' @param x arm information |
||
| 115 | +327 | - - | -||
| 116 | -10x | -
- assert_list_of_variables(variables[c("arm", "biomarker", "event", "time")])
- |
- ||
| 117 | -10x | -
- form <- paste0("Surv(", variables$time, ", ", variables$event, ") ~ ", variables$arm)
- |
- ||
| 118 | -10x | -
- if (control$degree > 0) {
- |
- ||
| 119 | -5x | -
- form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
+ #' |
||
| 120 | +328 |
- }- |
- ||
| 121 | -10x | -
- if (!is.null(variables$covariates)) {
- |
- ||
| 122 | -6x | -
- form <- paste(form, "+", paste(variables$covariates, collapse = "+"))+ #' @return `x` |
||
| 123 | +329 |
- }- |
- ||
| 124 | -10x | -
- if (!is.null(variables$strata)) {
+ #' |
||
| 125 | -2x | +|||
| 330 | +
- form <- paste0(form, " + strata(", paste0(variables$strata, collapse = ", "), ")")
+ #' @keywords internal |
|||
| 126 | +331 |
- }+ study_arm <- function(x) {
|
||
| 127 | -10x | +|||
| 332 | +! |
- stats::as.formula(form)+ structure(x, varname = deparse(substitute(x))) |
||
| 128 | +333 |
} |
||
| 129 | +334 | |||
| 130 | +335 |
- #' @describeIn h_step Estimates the model with `formula` built based on+ #' Smooth function with optional grouping |
||
| 131 | +336 |
- #' `variables` in `data` for a given `subset` and `control` parameters for the+ #' |
||
| 132 | +337 |
- #' Cox regression.+ #' @description `r lifecycle::badge("stable")`
|
||
| 133 | +338 |
#' |
||
| 134 | -- |
- #' @param formula (`formula`)\cr the regression model formula.- |
- ||
| 135 | +339 |
- #' @param subset (`logical`)\cr subset vector.+ #' This produces `loess` smoothed estimates of `y` with Student confidence intervals. |
||
| 136 | +340 |
#' |
||
| 137 | +341 |
- #' @return+ #' @param df (`data.frame`)\cr data set containing all analysis variables. |
||
| 138 | +342 |
- #' * `h_step_survival_est()` returns a matrix of number of observations `n`,+ #' @param x (`string`)\cr x column name. |
||
| 139 | +343 |
- #' `events`, log hazard ratio estimates `loghr`, standard error `se`,+ #' @param y (`string`)\cr y column name. |
||
| 140 | +344 |
- #' and Wald confidence interval bounds `ci_lower` and `ci_upper`. One row is+ #' @param groups (`character` or `NULL`)\cr vector with optional grouping variables names. |
||
| 141 | +345 |
- #' included for each biomarker value in `x`.+ #' @param level (`proportion`)\cr level of confidence interval to use (0.95 by default). |
||
| 142 | +346 |
#' |
||
| 143 | +347 |
- #' @export+ #' @return A `data.frame` with original `x`, smoothed `y`, `ylow`, and `yhigh`, and |
||
| 144 | +348 |
- h_step_survival_est <- function(formula,+ #' optional `groups` variables formatted as `factor` type. |
||
| 145 | +349 |
- data,+ #' |
||
| 146 | +350 |
- variables,+ #' @export |
||
| 147 | +351 |
- x,+ get_smooths <- function(df, x, y, groups = NULL, level = 0.95) {
|
||
| 148 | -+ | |||
| 352 | +5x |
- subset = rep(TRUE, nrow(data)),+ checkmate::assert_data_frame(df) |
||
| 149 | -+ | |||
| 353 | +5x |
- control = control_coxph()) {
+ df_cols <- colnames(df) |
||
| 150 | -55x | +354 | +5x |
- checkmate::assert_formula(formula)+ checkmate::assert_string(x) |
| 151 | -55x | +355 | +5x |
- assert_df_with_variables(data, variables)+ checkmate::assert_subset(x, df_cols) |
| 152 | -55x | +356 | +5x |
- checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE)+ checkmate::assert_numeric(df[[x]]) |
| 153 | -55x | +357 | +5x |
- checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)+ checkmate::assert_string(y) |
| 154 | -55x | +358 | +5x |
- checkmate::assert_list(control, names = "named")+ checkmate::assert_subset(y, df_cols) |
| 155 | -+ | |||
| 359 | +5x |
-
+ checkmate::assert_numeric(df[[y]]) |
||
| 156 | +360 |
- # Note: `subset` in `coxph` needs to be an expression referring to `data` variables.+ |
||
| 157 | -55x | +361 | +5x |
- data$.subset <- subset+ if (!is.null(groups)) {
|
| 158 | -55x | +362 | +4x |
- coxph_warnings <- NULL+ checkmate::assert_character(groups) |
| 159 | -55x | +363 | +4x |
- tryCatch(+ checkmate::assert_subset(groups, df_cols) |
| 160 | -55x | +|||
| 364 | +
- withCallingHandlers(+ } |
|||
| 161 | -55x | +|||
| 365 | +
- expr = {
+
|
|||
| 162 | -55x | +366 | +5x |
- fit <- survival::coxph(+ smooths <- function(x, y) {
|
| 163 | -55x | +367 | +18x |
- formula = formula,+ stats::predict(stats::loess(y ~ x), se = TRUE) |
| 164 | -55x | +|||
| 368 | +
- data = data,+ } |
|||
| 165 | -55x | +|||
| 369 | +
- subset = .subset,+ |
|||
| 166 | -55x | -
- ties = control$ties- |
- ||
| 167 | -+ | 370 | +5x |
- )+ if (!is.null(groups)) {
|
| 168 | -+ | |||
| 371 | +4x |
- },+ cc <- stats::complete.cases(df[c(x, y, groups)]) |
||
| 169 | -55x | +372 | +4x |
- warning = function(w) {
+ df_c <- df[cc, c(x, y, groups)] |
| 170 | -1x | +373 | +4x |
- coxph_warnings <<- c(coxph_warnings, w)+ df_c_ordered <- df_c[do.call("order", as.list(df_c[, groups, drop = FALSE])), , drop = FALSE]
|
| 171 | -1x | +374 | +4x |
- invokeRestart("muffleWarning")
+ df_c_g <- data.frame(Map(as.factor, df_c_ordered[groups])) |
| 172 | +375 |
- }+ |
||
| 173 | -+ | |||
| 376 | +4x |
- ),+ df_smooth_raw <- |
||
| 174 | -55x | +377 | +4x |
- finally = {
+ by(df_c_ordered, df_c_g, function(d) {
|
| 175 | -+ | |||
| 378 | +17x |
- }+ plx <- smooths(d[[x]], d[[y]]) |
||
| 176 | -+ | |||
| 379 | +17x |
- )+ data.frame( |
||
| 177 | -55x | +380 | +17x |
- if (!is.null(coxph_warnings)) {
+ x = d[[x]], |
| 178 | -1x | +381 | +17x |
- warning(paste(+ y = plx$fit, |
| 179 | -1x | +382 | +17x |
- "Fit warnings occurred, please consider using a simpler model, or",+ ylow = plx$fit - stats::qt(level, plx$df) * plx$se.fit, |
| 180 | -1x | +383 | +17x |
- "larger `bandwidth`, less `num_points` in `control_step()` settings"+ yhigh = plx$fit + stats::qt(level, plx$df) * plx$se.fit |
| 181 | +384 |
- ))+ ) |
||
| 182 | +385 |
- }+ }) |
||
| 183 | +386 |
- # Produce a matrix with one row per `x` and columns `est` and `se`.+ |
||
| 184 | -55x | +387 | +4x |
- estimates <- t(vapply(+ df_smooth <- do.call(rbind, df_smooth_raw) |
| 185 | -55x | +388 | +4x |
- X = x,+ df_smooth[groups] <- df_c_g |
| 186 | -55x | +|||
| 389 | +
- FUN = h_step_trt_effect,+ |
|||
| 187 | -55x | +390 | +4x |
- FUN.VALUE = c(1, 2),+ df_smooth+ |
+
| 391 | ++ |
+ } else {
|
||
| 188 | -55x | +392 | +1x |
- data = data,+ cc <- stats::complete.cases(df[c(x, y)]) |
| 189 | -55x | +393 | +1x |
- model = fit,+ df_c <- df[cc, ] |
| 190 | -55x | +394 | +1x |
- variables = variables+ plx <- smooths(df_c[[x]], df_c[[y]]) |
| 191 | +395 |
- ))+ |
||
| 192 | -55x | +396 | +1x |
- q_norm <- stats::qnorm((1 + control$conf_level) / 2)+ df_smooth <- data.frame( |
| 193 | -55x | +397 | +1x |
- cbind(+ x = df_c[[x]], |
| 194 | -55x | +398 | +1x |
- n = fit$n,+ y = plx$fit, |
| 195 | -55x | +399 | +1x |
- events = fit$nevent,+ ylow = plx$fit - stats::qt(level, plx$df) * plx$se.fit, |
| 196 | -55x | +400 | +1x |
- loghr = estimates[, "est"],+ yhigh = plx$fit + stats::qt(level, plx$df) * plx$se.fit |
| 197 | -55x | +|||
| 401 | +
- se = estimates[, "se"],+ ) |
|||
| 198 | -55x | +|||
| 402 | +
- ci_lower = estimates[, "est"] - q_norm * estimates[, "se"],+ |
|||
| 199 | -55x | +403 | +1x |
- ci_upper = estimates[, "est"] + q_norm * estimates[, "se"]+ df_smooth |
| 200 | +404 |
- )+ } |
||
| 201 | +405 |
} |
||
| 202 | +406 | |||
| 203 | +407 |
- #' @describeIn h_step Builds the model formula used in response STEP calculations.+ #' Number of available (non-missing entries) in a vector |
||
| 204 | +408 |
#' |
||
| 205 | +409 |
- #' @return+ #' Small utility function for better readability. |
||
| 206 | +410 |
- #' * `h_step_rsp_formula()` returns a model formula.+ #' |
||
| 207 | +411 | ++ |
+ #' @param x (`vector`)\cr vector in which to count non-missing values.+ |
+ |
| 412 |
#' |
|||
| 208 | +413 |
- #' @export+ #' @return Number of non-missing values. |
||
| 209 | +414 |
- h_step_rsp_formula <- function(variables,+ #' |
||
| 210 | +415 |
- control = c(control_step(), control_logistic())) {
+ #' @keywords internal |
||
| 211 | -14x | +|||
| 416 | +
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ n_available <- function(x) {
|
|||
| 212 | -14x | +417 | +351x |
- assert_list_of_variables(variables[c("arm", "biomarker", "response")])
+ sum(!is.na(x)) |
| 213 | -14x | +|||
| 418 | +
- response_definition <- sub(+ } |
|||
| 214 | -14x | +|||
| 419 | +
- pattern = "response",+ |
|||
| 215 | -14x | +|||
| 420 | +
- replacement = variables$response,+ #' Reapply variable labels |
|||
| 216 | -14x | +|||
| 421 | +
- x = control$response_definition,+ #' |
|||
| 217 | -14x | +|||
| 422 | +
- fixed = TRUE+ #' This is a helper function that is used in tests. |
|||
| 218 | +423 |
- )+ #' |
||
| 219 | -14x | +|||
| 424 | +
- form <- paste0(response_definition, " ~ ", variables$arm)+ #' @param x (`vector`)\cr vector of elements that needs new labels. |
|||
| 220 | -14x | +|||
| 425 | +
- if (control$degree > 0) {
+ #' @param varlabels (`character`)\cr vector of labels for `x`. |
|||
| 221 | -8x | +|||
| 426 | +
- form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
+ #' @param ... further parameters to be added to the list. |
|||
| 222 | +427 |
- }+ #' |
||
| 223 | -14x | +|||
| 428 | +
- if (!is.null(variables$covariates)) {
+ #' @return `x` with variable labels reapplied. |
|||
| 224 | -8x | +|||
| 429 | +
- form <- paste(form, "+", paste(variables$covariates, collapse = "+"))+ #' |
|||
| 225 | +430 |
- }+ #' @export+ |
+ ||
| 431 | ++ |
+ reapply_varlabels <- function(x, varlabels, ...) {
|
||
| 226 | -14x | +432 | +11x |
- if (!is.null(variables$strata)) {
+ named_labels <- c(as.list(varlabels), list(...)) |
| 227 | -5x | +433 | +11x |
- strata_arg <- if (length(variables$strata) > 1) {
+ formatters::var_labels(x)[names(named_labels)] <- as.character(named_labels) |
| 228 | -2x | +434 | +11x |
- paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
+ x |
| 229 | +435 |
- } else {
+ } |
||
| 230 | -3x | +|||
| 436 | +
- variables$strata+ |
|||
| 231 | +437 |
- }+ # Wrapper function of survival::clogit so that when model fitting failed, a more useful message would show |
||
| 232 | -5x | +|||
| 438 | +
- form <- paste0(form, "+ strata(", strata_arg, ")")
+ clogit_with_tryCatch <- function(formula, data, ...) { # nolint
|
|||
| 233 | -+ | |||
| 439 | +33x |
- }+ tryCatch( |
||
| 234 | -14x | +440 | +33x |
- stats::as.formula(form)+ survival::clogit(formula = formula, data = data, ...), |
| 235 | -+ | |||
| 441 | +33x |
- }+ error = function(e) stop("model not built successfully with survival::clogit")
|
||
| 236 | +442 |
-
+ ) |
||
| 237 | +443 |
- #' @describeIn h_step Estimates the model with `formula` built based on+ } |
| 238 | +1 |
- #' `variables` in `data` for a given `subset` and `control` parameters for the+ #' Create a forest plot from an `rtable` |
|
| 239 | +2 |
- #' logistic regression.+ #' |
|
| 240 | +3 |
- #'+ #' Given a [rtables::rtable()] object with at least one column with a single value and one column with 2 |
|
| 241 | +4 |
- #' @param formula (`formula`)\cr the regression model formula.+ #' values, converts table to a [ggplot2::ggplot()] object and generates an accompanying forest plot. The |
|
| 242 | +5 |
- #' @param subset (`logical`)\cr subset vector.+ #' table and forest plot are printed side-by-side. |
|
| 243 | +6 |
#' |
|
| 244 | +7 |
- #' @return+ #' @description `r lifecycle::badge("stable")`
|
|
| 245 | +8 |
- #' * `h_step_rsp_est()` returns a matrix of number of observations `n`, log odds+ #' |
|
| 246 | +9 |
- #' ratio estimates `logor`, standard error `se`, and Wald confidence interval bounds+ #' @inheritParams rtable2gg |
|
| 247 | +10 |
- #' `ci_lower` and `ci_upper`. One row is included for each biomarker value in `x`.+ #' @inheritParams argument_convention |
|
| 248 | +11 |
- #'+ #' @param tbl (`VTableTree`)\cr `rtables` table with at least one column with a single value and one column with 2 |
|
| 249 | +12 |
- #' @export+ #' values. |
|
| 250 | +13 |
- h_step_rsp_est <- function(formula,+ #' @param col_x (`integer(1)` or `NULL`)\cr column index with estimator. By default tries to get this from |
|
| 251 | +14 |
- data,+ #' `tbl` attribute `col_x`, otherwise needs to be manually specified. If `NULL`, points will be excluded |
|
| 252 | +15 |
- variables,+ #' from forest plot. |
|
| 253 | +16 |
- x,+ #' @param col_ci (`integer(1)` or `NULL`)\cr column index with confidence intervals. By default tries to get this from |
|
| 254 | +17 |
- subset = rep(TRUE, nrow(data)),+ #' `tbl` attribute `col_ci`, otherwise needs to be manually specified. If `NULL`, lines will be excluded |
|
| 255 | +18 |
- control = control_logistic()) {
+ #' from forest plot. |
|
| 256 | -58x | +||
| 19 | +
- checkmate::assert_formula(formula)+ #' @param vline (`numeric(1)` or `NULL`)\cr x coordinate for vertical line, if `NULL` then the line is omitted. |
||
| 257 | -58x | +||
| 20 | +
- assert_df_with_variables(data, variables)+ #' @param forest_header (`character(2)`)\cr text displayed to the left and right of `vline`, respectively. |
||
| 258 | -58x | +||
| 21 | +
- checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE)+ #' If `vline = NULL` then `forest_header` is not printed. By default tries to get this from `tbl` attribute |
||
| 259 | -58x | +||
| 22 | +
- checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)+ #' `forest_header`. If `NULL`, defaults will be extracted from the table if possible, and set to |
||
| 260 | -58x | +||
| 23 | +
- checkmate::assert_list(control, names = "named")+ #' `"Comparison\nBetter"` and `"Treatment\nBetter"` if not. |
||
| 261 | +24 |
- # Note: `subset` in `glm` needs to be an expression referring to `data` variables.+ #' @param xlim (`numeric(2)`)\cr limits for x axis. |
|
| 262 | -58x | +||
| 25 | +
- data$.subset <- subset+ #' @param logx (`flag`)\cr show the x-values on logarithm scale. |
||
| 263 | -58x | +||
| 26 | +
- fit_warnings <- NULL+ #' @param x_at (`numeric`)\cr x-tick locations, if `NULL`, `x_at` is set to `vline` and both `xlim` values. |
||
| 264 | -58x | +||
| 27 | +
- tryCatch(+ #' @param width_row_names `r lifecycle::badge("deprecated")` Please use the `lbl_col_padding` argument instead.
|
||
| 265 | -58x | +||
| 28 | +
- withCallingHandlers(+ #' @param width_columns (`numeric`)\cr a vector of column widths. Each element's position in |
||
| 266 | -58x | +||
| 29 | +
- expr = {
+ #' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths are calculated |
||
| 267 | -58x | +||
| 30 | +
- fit <- if (is.null(variables$strata)) {
+ #' according to maximum number of characters per column. |
||
| 268 | -54x | +||
| 31 | +
- stats::glm(+ #' @param width_forest `r lifecycle::badge("deprecated")` Please use the `rel_width_forest` argument instead.
|
||
| 269 | -54x | +||
| 32 | +
- formula = formula,+ #' @param rel_width_forest (`proportion`)\cr proportion of total width to allocate to the forest plot. Relative |
||
| 270 | -54x | +||
| 33 | +
- data = data,+ #' width of table is then `1 - rel_width_forest`. If `as_list = TRUE`, this parameter is ignored. |
||
| 271 | -54x | +||
| 34 | +
- subset = .subset,+ #' @param font_size (`numeric(1)`)\cr font size. |
||
| 272 | -54x | +||
| 35 | +
- family = stats::binomial("logit")
+ #' @param col_symbol_size (`numeric` or `NULL`)\cr column index from `tbl` containing data to be used |
||
| 273 | +36 |
- )+ #' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional |
|
| 274 | +37 |
- } else {
+ #' to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups. |
|
| 275 | +38 |
- # clogit needs coxph and strata imported+ #' By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified. |
|
| 276 | -4x | +||
| 39 | +
- survival::clogit(+ #' @param col (`character`)\cr color(s). |
||
| 277 | -4x | +||
| 40 | +
- formula = formula,+ #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot. |
||
| 278 | -4x | +||
| 41 | +
- data = data,+ #' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list. If `TRUE`, a named list |
||
| 279 | -4x | +||
| 42 | +
- subset = .subset+ #' with two elements, `table` and `plot`, will be returned. If `FALSE` (default) the table and forest plot are |
||
| 280 | +43 |
- )+ #' printed side-by-side via [cowplot::plot_grid()]. |
|
| 281 | +44 |
- }+ #' @param gp `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
|
|
| 282 | +45 |
- },+ #' is no longer used. |
|
| 283 | -58x | +||
| 46 | +
- warning = function(w) {
+ #' @param draw `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
|
||
| 284 | -19x | +||
| 47 | +
- fit_warnings <<- c(fit_warnings, w)+ #' is no longer used. |
||
| 285 | -19x | +||
| 48 | +
- invokeRestart("muffleWarning")
+ #' @param newpage `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
|
||
| 286 | +49 |
- }+ #' is no longer used. |
|
| 287 | +50 |
- ),+ #' |
|
| 288 | -58x | +||
| 51 | +
- finally = {
+ #' @return `ggplot` forest plot and table. |
||
| 289 | +52 |
- }+ #' |
|
| 290 | +53 |
- )+ #' @examples |
|
| 291 | -58x | +||
| 54 | +
- if (!is.null(fit_warnings)) {
+ #' library(dplyr) |
||
| 292 | -13x | +||
| 55 | +
- warning(paste(+ #' library(forcats) |
||
| 293 | -13x | +||
| 56 | +
- "Fit warnings occurred, please consider using a simpler model, or",+ #' library(nestcolor) |
||
| 294 | -13x | +||
| 57 | +
- "larger `bandwidth`, less `num_points` in `control_step()` settings"+ #' |
||
| 295 | +58 |
- ))+ #' adrs <- tern_ex_adrs |
|
| 296 | +59 |
- }+ #' n_records <- 20 |
|
| 297 | +60 |
- # Produce a matrix with one row per `x` and columns `est` and `se`.+ #' adrs_labels <- formatters::var_labels(adrs, fill = TRUE) |
|
| 298 | -58x | +||
| 61 | +
- estimates <- t(vapply(+ #' adrs <- adrs %>% |
||
| 299 | -58x | +||
| 62 | +
- X = x,+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 300 | -58x | +||
| 63 | +
- FUN = h_step_trt_effect,+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
|
||
| 301 | -58x | +||
| 64 | +
- FUN.VALUE = c(1, 2),+ #' slice(seq_len(n_records)) %>% |
||
| 302 | -58x | +||
| 65 | +
- data = data,+ #' droplevels() %>% |
||
| 303 | -58x | +||
| 66 | +
- model = fit,+ #' mutate( |
||
| 304 | -58x | +||
| 67 | +
- variables = variables+ #' # Reorder levels of factor to make the placebo group the reference arm. |
||
| 305 | +68 |
- ))+ #' ARM = fct_relevel(ARM, "B: Placebo"), |
|
| 306 | -58x | +||
| 69 | +
- q_norm <- stats::qnorm((1 + control$conf_level) / 2)+ #' rsp = AVALC == "CR" |
||
| 307 | -58x | +||
| 70 | +
- cbind(+ #' ) |
||
| 308 | -58x | +||
| 71 | +
- n = length(fit$y),+ #' formatters::var_labels(adrs) <- c(adrs_labels, "Response") |
||
| 309 | -58x | +||
| 72 | +
- logor = estimates[, "est"],+ #' df <- extract_rsp_subgroups( |
||
| 310 | -58x | +||
| 73 | +
- se = estimates[, "se"],+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")),
|
||
| 311 | -58x | +||
| 74 | +
- ci_lower = estimates[, "est"] - q_norm * estimates[, "se"],+ #' data = adrs |
||
| 312 | -58x | +||
| 75 | +
- ci_upper = estimates[, "est"] + q_norm * estimates[, "se"]+ #' ) |
||
| 313 | +76 |
- )+ #' # Full commonly used response table. |
|
| 314 | +77 |
- }+ #' |
| 1 | +78 |
- #' Confidence intervals for a difference of binomials+ #' tbl <- basic_table() %>% |
||
| 2 | +79 |
- #'+ #' tabulate_rsp_subgroups(df) |
||
| 3 | +80 |
- #' @description `r lifecycle::badge("experimental")`
+ #' g_forest(tbl) |
||
| 4 | +81 |
#' |
||
| 5 | +82 |
- #' Several confidence intervals for the difference between proportions.+ #' # Odds ratio only table. |
||
| 6 | +83 |
#' |
||
| 7 | +84 |
- #' @name desctools_binom+ #' tbl_or <- basic_table() %>% |
||
| 8 | +85 |
- NULL+ #' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci"))
|
||
| 9 | +86 |
-
+ #' g_forest( |
||
| 10 | +87 |
- #' Recycle list of parameters+ #' tbl_or, |
||
| 11 | +88 |
- #'+ #' forest_header = c("Comparison\nBetter", "Treatment\nBetter")
|
||
| 12 | +89 |
- #' This function recycles all supplied elements to the maximal dimension.+ #' ) |
||
| 13 | +90 |
#' |
||
| 14 | +91 |
- #' @param ... (`any`)\cr elements to recycle.+ #' # Survival forest plot example. |
||
| 15 | +92 |
- #'+ #' adtte <- tern_ex_adtte |
||
| 16 | +93 |
- #' @return A `list`.+ #' # Save variable labels before data processing steps. |
||
| 17 | +94 |
- #'+ #' adtte_labels <- formatters::var_labels(adtte, fill = TRUE) |
||
| 18 | +95 |
- #' @keywords internal+ #' adtte_f <- adtte %>% |
||
| 19 | +96 |
- #' @noRd+ #' filter( |
||
| 20 | +97 |
- h_recycle <- function(...) {
- |
- ||
| 21 | -78x | -
- lst <- list(...)+ #' PARAMCD == "OS", |
||
| 22 | -78x | +|||
| 98 | +
- maxdim <- max(lengths(lst))+ #' ARM %in% c("B: Placebo", "A: Drug X"),
|
|||
| 23 | -78x | +|||
| 99 | +
- res <- lapply(lst, rep, length.out = maxdim)+ #' SEX %in% c("M", "F")
|
|||
| 24 | -78x | +|||
| 100 | +
- attr(res, "maxdim") <- maxdim+ #' ) %>% |
|||
| 25 | -78x | +|||
| 101 | +
- return(res)+ #' mutate( |
|||
| 26 | +102 |
- }+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
||
| 27 | +103 |
-
+ #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")), |
||
| 28 | +104 |
- #' @describeIn desctools_binom Several confidence intervals for the difference between proportions.+ #' SEX = droplevels(SEX), |
||
| 29 | +105 |
- #'+ #' AVALU = as.character(AVALU), |
||
| 30 | +106 |
- #' @return A `matrix` of 3 values:+ #' is_event = CNSR == 0 |
||
| 31 | +107 |
- #' * `est`: estimate of proportion difference.+ #' ) |
||
| 32 | +108 |
- #' * `lwr.ci`: estimate of lower end of the confidence interval.+ #' labels <- list( |
||
| 33 | +109 |
- #' * `upr.ci`: estimate of upper end of the confidence interval.+ #' "ARM" = adtte_labels["ARM"], |
||
| 34 | +110 |
- #'+ #' "SEX" = adtte_labels["SEX"], |
||
| 35 | +111 |
- #' @keywords internal+ #' "AVALU" = adtte_labels["AVALU"], |
||
| 36 | +112 |
- desctools_binom <- function(x1,+ #' "is_event" = "Event Flag" |
||
| 37 | +113 |
- n1,+ #' ) |
||
| 38 | +114 |
- x2,+ #' formatters::var_labels(adtte_f)[names(labels)] <- as.character(labels) |
||
| 39 | +115 |
- n2,+ #' df <- extract_survival_subgroups( |
||
| 40 | +116 |
- conf.level = 0.95, # nolint+ #' variables = list( |
||
| 41 | +117 |
- sides = c("two.sided", "left", "right"),
+ #' tte = "AVAL", |
||
| 42 | +118 |
- method = c(+ #' is_event = "is_event", |
||
| 43 | +119 |
- "ac", "wald", "waldcc", "score", "scorecc", "mn", "mee", "blj", "ha", "hal", "jp"+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
|
||
| 44 | +120 |
- )) {
+ #' ), |
||
| 45 | -26x | +|||
| 121 | +
- if (missing(sides)) {
+ #' data = adtte_f |
|||
| 46 | -26x | +|||
| 122 | +
- sides <- match.arg(sides)+ #' ) |
|||
| 47 | +123 |
- }+ #' table_hr <- basic_table() %>% |
||
| 48 | -26x | +|||
| 124 | +
- if (missing(method)) {
+ #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) |
|||
| 49 | -1x | +|||
| 125 | +
- method <- match.arg(method)+ #' g_forest(table_hr) |
|||
| 50 | +126 |
- }+ #' |
||
| 51 | -26x | +|||
| 127 | +
- iBinomDiffCI <- function(x1, n1, x2, n2, conf.level, sides, method) { # nolint
+ #' # Works with any `rtable`. |
|||
| 52 | -26x | +|||
| 128 | +
- if (sides != "two.sided") {
+ #' tbl <- rtable( |
|||
| 53 | -! | +|||
| 129 | +
- conf.level <- 1 - 2 * (1 - conf.level) # nolint+ #' header = c("E", "CI", "N"),
|
|||
| 54 | +130 |
- }+ #' rrow("", 1, c(.8, 1.2), 200),
|
||
| 55 | -26x | +|||
| 131 | +
- alpha <- 1 - conf.level+ #' rrow("", 1.2, c(1.1, 1.4), 50)
|
|||
| 56 | -26x | +|||
| 132 | +
- kappa <- stats::qnorm(1 - alpha / 2)+ #' ) |
|||
| 57 | -26x | +|||
| 133 | +
- p1_hat <- x1 / n1+ #' g_forest( |
|||
| 58 | -26x | +|||
| 134 | +
- p2_hat <- x2 / n2+ #' tbl = tbl, |
|||
| 59 | -26x | +|||
| 135 | +
- est <- p1_hat - p2_hat+ #' col_x = 1, |
|||
| 60 | -26x | +|||
| 136 | +
- switch(method,+ #' col_ci = 2, |
|||
| 61 | -26x | +|||
| 137 | +
- wald = {
+ #' xlim = c(0.5, 2), |
|||
| 62 | -4x | +|||
| 138 | +
- vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2+ #' x_at = c(0.5, 1, 2), |
|||
| 63 | -4x | +|||
| 139 | +
- term2 <- kappa * sqrt(vd)+ #' col_symbol_size = 3 |
|||
| 64 | -4x | +|||
| 140 | +
- ci_lwr <- max(-1, est - term2)+ #' ) |
|||
| 65 | -4x | +|||
| 141 | +
- ci_upr <- min(1, est + term2)+ #' |
|||
| 66 | +142 |
- },+ #' tbl <- rtable( |
||
| 67 | -26x | +|||
| 143 | +
- waldcc = {
+ #' header = rheader( |
|||
| 68 | -6x | +|||
| 144 | +
- vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2+ #' rrow("", rcell("A", colspan = 2)),
|
|||
| 69 | -6x | +|||
| 145 | +
- term2 <- kappa * sqrt(vd)+ #' rrow("", "c1", "c2")
|
|||
| 70 | -6x | +|||
| 146 | +
- term2 <- term2 + 0.5 * (1 / n1 + 1 / n2)+ #' ), |
|||
| 71 | -6x | +|||
| 147 | +
- ci_lwr <- max(-1, est - term2)+ #' rrow("row 1", 1, c(.8, 1.2)),
|
|||
| 72 | -6x | +|||
| 148 | +
- ci_upr <- min(1, est + term2)+ #' rrow("row 2", 1.2, c(1.1, 1.4))
|
|||
| 73 | +149 |
- },+ #' ) |
||
| 74 | -26x | +|||
| 150 | +
- ac = {
+ #' g_forest( |
|||
| 75 | -2x | +|||
| 151 | +
- n1 <- n1 + 2+ #' tbl = tbl, |
|||
| 76 | -2x | +|||
| 152 | +
- n2 <- n2 + 2+ #' col_x = 1, |
|||
| 77 | -2x | +|||
| 153 | +
- x1 <- x1 + 1+ #' col_ci = 2, |
|||
| 78 | -2x | +|||
| 154 | +
- x2 <- x2 + 1+ #' xlim = c(0.5, 2), |
|||
| 79 | -2x | +|||
| 155 | +
- p1_hat <- x1 / n1+ #' x_at = c(0.5, 1, 2), |
|||
| 80 | -2x | +|||
| 156 | +
- p2_hat <- x2 / n2+ #' vline = 1, |
|||
| 81 | -2x | +|||
| 157 | +
- est1 <- p1_hat - p2_hat+ #' forest_header = c("Hello", "World")
|
|||
| 82 | -2x | +|||
| 158 | +
- vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2- |
- |||
| 83 | -2x | +|||
| 159 | +
- term2 <- kappa * sqrt(vd)+ #' |
|||
| 84 | -2x | +|||
| 160 | +
- ci_lwr <- max(-1, est1 - term2)+ #' @export |
|||
| 85 | -2x | +|||
| 161 | +
- ci_upr <- min(1, est1 + term2)+ g_forest <- function(tbl, |
|||
| 86 | +162 |
- },+ col_x = attr(tbl, "col_x"), |
||
| 87 | -26x | +|||
| 163 | +
- exact = {
+ col_ci = attr(tbl, "col_ci"), |
|||
| 88 | -! | +|||
| 164 | +
- ci_lwr <- NA+ vline = 1, |
|||
| 89 | -! | +|||
| 165 | +
- ci_upr <- NA+ forest_header = attr(tbl, "forest_header"), |
|||
| 90 | +166 |
- },+ xlim = c(0.1, 10), |
||
| 91 | -26x | +|||
| 167 | +
- score = {
+ logx = TRUE, |
|||
| 92 | -3x | +|||
| 168 | +
- w1 <- desctools_binomci(+ x_at = c(0.1, 1, 10), |
|||
| 93 | -3x | +|||
| 169 | +
- x = x1, n = n1, conf.level = conf.level,+ width_row_names = lifecycle::deprecated(), |
|||
| 94 | -3x | +|||
| 170 | +
- method = "wilson"+ width_columns = NULL, |
|||
| 95 | +171 |
- )+ width_forest = lifecycle::deprecated(), |
||
| 96 | -3x | +|||
| 172 | +
- w2 <- desctools_binomci(+ lbl_col_padding = 0, |
|||
| 97 | -3x | +|||
| 173 | +
- x = x2, n = n2, conf.level = conf.level,+ rel_width_forest = 0.25, |
|||
| 98 | -3x | +|||
| 174 | +
- method = "wilson"+ font_size = 12, |
|||
| 99 | +175 |
- )+ col_symbol_size = attr(tbl, "col_symbol_size"), |
||
| 100 | -3x | +|||
| 176 | +
- l1 <- w1[2]+ col = getOption("ggplot2.discrete.colour")[1],
|
|||
| 101 | -3x | +|||
| 177 | +
- u1 <- w1[3]+ ggtheme = NULL, |
|||
| 102 | -3x | +|||
| 178 | +
- l2 <- w2[2]+ as_list = FALSE, |
|||
| 103 | -3x | +|||
| 179 | +
- u2 <- w2[3]+ gp = lifecycle::deprecated(), |
|||
| 104 | -3x | +|||
| 180 | +
- ci_lwr <- est - kappa * sqrt(l1 * (1 - l1) / n1 + u2 * (1 - u2) / n2)+ draw = lifecycle::deprecated(), |
|||
| 105 | -3x | +|||
| 181 | +
- ci_upr <- est + kappa * sqrt(u1 * (1 - u1) / n1 + l2 * (1 - l2) / n2)+ newpage = lifecycle::deprecated()) {
|
|||
| 106 | +182 |
- },+ # Deprecated argument warnings |
||
| 107 | -26x | +183 | +4x |
- scorecc = {
+ if (lifecycle::is_present(width_row_names)) {
|
| 108 | +184 | 1x |
- w1 <- desctools_binomci(+ lifecycle::deprecate_warn( |
|
| 109 | +185 | 1x |
- x = x1, n = n1, conf.level = conf.level,+ "0.9.4", "g_forest(width_row_names)", "g_forest(lbl_col_padding)", |
|
| 110 | +186 | 1x |
- method = "wilsoncc"+ details = "The width of the row label column can be adjusted via the `lbl_col_padding` parameter." |
|
| 111 | +187 |
- )+ )+ |
+ ||
| 188 | ++ |
+ } |
||
| 112 | +189 | +4x | +
+ if (lifecycle::is_present(width_forest)) {
+ |
+ |
| 190 | 1x |
- w2 <- desctools_binomci(+ lifecycle::deprecate_warn( |
||
| 113 | +191 | 1x |
- x = x2, n = n2, conf.level = conf.level,+ "0.9.4", "g_forest(width_forest)", "g_forest(rel_width_forest)", |
|
| 114 | +192 | 1x |
- method = "wilsoncc"+ details = "Relative width of the forest plot (as a proportion) can be set via the `rel_width_forest` parameter." |
|
| 115 | +193 |
- )+ )+ |
+ ||
| 194 | ++ |
+ } |
||
| 116 | -1x | +195 | +4x |
- l1 <- w1[2]+ if (lifecycle::is_present(gp)) {
|
| 117 | +196 | 1x |
- u1 <- w1[3]+ lifecycle::deprecate_warn( |
|
| 118 | +197 | 1x |
- l2 <- w2[2]+ "0.9.4", "g_forest(gp)", "g_forest(ggtheme)", |
|
| 119 | +198 | 1x |
- u2 <- w2[3]+ details = paste( |
|
| 120 | +199 | 1x |
- ci_lwr <- max(-1, est - sqrt((p1_hat - l1)^2 + (u2 - p2_hat)^2))+ "`g_forest` is now generated as a `ggplot` object.", |
|
| 121 | +200 | 1x |
- ci_upr <- min(1, est + sqrt((u1 - p1_hat)^2 + (p2_hat - l2)^2))+ "Additional display settings should be supplied via the `ggtheme` parameter." |
|
| 122 | +201 |
- },+ ) |
||
| 123 | -26x | +|||
| 202 | +
- mee = {
+ ) |
|||
| 124 | -1x | +|||
| 203 | +
- .score <- function(p1, n1, p2, n2, dif) {
+ } |
|||
| 125 | -! | +|||
| 204 | +4x |
- if (dif > 1) dif <- 1+ if (lifecycle::is_present(draw)) {
|
||
| 126 | -! | +|||
| 205 | +1x |
- if (dif < -1) dif <- -1+ lifecycle::deprecate_warn( |
||
| 127 | -24x | +206 | +1x |
- diff <- p1 - p2 - dif+ "0.9.4", "g_forest(draw)", |
| 128 | -24x | +207 | +1x |
- if (abs(diff) == 0) {
+ details = "`g_forest` now generates `ggplot` objects. This parameter has no effect." |
| 129 | -! | +|||
| 208 | +
- res <- 0+ ) |
|||
| 130 | +209 |
- } else {
+ } |
||
| 131 | -24x | +210 | +4x |
- t <- n2 / n1+ if (lifecycle::is_present(newpage)) {
|
| 132 | -24x | +211 | +1x |
- a <- 1 + t+ lifecycle::deprecate_warn( |
| 133 | -24x | +212 | +1x |
- b <- -(1 + t + p1 + t * p2 + dif * (t + 2))+ "0.9.4", "g_forest(newpage)", |
| 134 | -24x | +213 | +1x |
- c <- dif * dif + dif * (2 * p1 + t + 1) + p1 + t * p2+ details = "`g_forest` now generates `ggplot` objects. This parameter has no effect." |
| 135 | -24x | +|||
| 214 | +
- d <- -p1 * dif * (1 + dif)+ ) |
|||
| 136 | -24x | +|||
| 215 | +
- v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2+ } |
|||
| 137 | -24x | +|||
| 216 | +
- if (abs(v) < .Machine$double.eps) v <- 0+ |
|||
| 138 | -24x | +217 | +4x |
- s <- sqrt((b / a / 3)^2 - c / a / 3)+ checkmate::assert_class(tbl, "VTableTree") |
| 139 | -24x | +218 | +4x |
- u <- ifelse(v > 0, 1, -1) * s+ checkmate::assert_number(col_x, lower = 0, upper = ncol(tbl), null.ok = TRUE) |
| 140 | -24x | +219 | +4x |
- w <- (3.141592654 + acos(v / u^3)) / 3+ checkmate::assert_number(col_ci, lower = 0, upper = ncol(tbl), null.ok = TRUE) |
| 141 | -24x | +220 | +4x |
- p1d <- 2 * u * cos(w) - b / a / 3+ checkmate::assert_number(col_symbol_size, lower = 0, upper = ncol(tbl), null.ok = TRUE) |
| 142 | -24x | +221 | +4x |
- p2d <- p1d - dif+ checkmate::assert_number(font_size, lower = 0) |
| 143 | -24x | +222 | +4x |
- n <- n1 + n2+ checkmate::assert_character(col, null.ok = TRUE) |
| 144 | -24x | +223 | +4x |
- res <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2)+ checkmate::assert_true(is.null(col) | length(col) == 1 | length(col) == nrow(tbl)) |
| 145 | +224 |
- }- |
- ||
| 146 | -24x | -
- return(sqrt(res))+ |
||
| 147 | +225 |
- }+ # Extract info from table |
||
| 148 | -1x | +226 | +4x |
- pval <- function(delta) {
+ mat <- matrix_form(tbl, indent_rownames = TRUE) |
| 149 | -24x | +227 | +4x |
- z <- (est - delta) / .score(p1_hat, n1, p2_hat, n2, delta)+ mat_strings <- formatters::mf_strings(mat) |
| 150 | -24x | -
- 2 * min(stats::pnorm(z), 1 - stats::pnorm(z))- |
- ||
| 151 | -+ | 228 | +4x |
- }+ nlines_hdr <- formatters::mf_nlheader(mat) |
| 152 | -1x | +229 | +4x |
- ci_lwr <- max(-1, stats::uniroot(function(delta) {
+ nrows_body <- nrow(mat_strings) - nlines_hdr |
| 153 | -12x | +230 | +4x |
- pval(delta) - alpha+ tbl_stats <- mat_strings[nlines_hdr, -1] |
| 154 | -1x | +|||
| 231 | +
- }, interval = c(-1 + 1e-06, est - 1e-06))$root)+ |
|||
| 155 | -1x | +|||
| 232 | +
- ci_upr <- min(1, stats::uniroot(function(delta) {
+ # Generate and modify table as ggplot object |
|||
| 156 | -12x | +233 | +4x |
- pval(delta) - alpha+ gg_table <- rtable2gg(tbl, fontsize = font_size, colwidths = width_columns, lbl_col_padding = lbl_col_padding) + |
| 157 | -1x | -
- }, interval = c(est + 1e-06, 1 - 1e-06))$root)- |
- ||
| 158 | -+ | 234 | +4x |
- },+ theme(plot.margin = margin(0, 0, 0, 0.025, "npc")) |
| 159 | -26x | +235 | +4x |
- blj = {
+ gg_table$scales$scales[[1]]$expand <- c(0.01, 0.01) |
| 160 | -1x | +236 | +4x |
- p1_dash <- (x1 + 0.5) / (n1 + 1)+ gg_table$scales$scales[[2]]$limits[2] <- nrow(mat_strings) + 1 |
| 161 | -1x | +237 | +4x |
- p2_dash <- (x2 + 0.5) / (n2 + 1)+ if (nlines_hdr == 2) {
|
| 162 | -1x | +238 | +4x |
- vd <- p1_dash * (1 - p1_dash) / n1 + p2_dash * (1 - p2_dash) / n2+ gg_table$scales$scales[[2]]$expand <- c(0, 0) |
| 163 | -1x | +239 | +4x |
- term2 <- kappa * sqrt(vd)+ arms <- unique(mat_strings[1, ][nzchar(trimws(mat_strings[1, ]))]) |
| 164 | -1x | +|||
| 240 | +
- est_dash <- p1_dash - p2_dash+ } else {
|
|||
| 165 | -1x | +|||
| 241 | +! |
- ci_lwr <- max(-1, est_dash - term2)+ arms <- NULL |
||
| 166 | -1x | +|||
| 242 | +
- ci_upr <- min(1, est_dash + term2)+ } |
|||
| 167 | +243 |
- },+ |
||
| 168 | -26x | +244 | +4x |
- ha = {
+ tbl_df <- as_result_df(tbl) |
| 169 | -5x | +245 | +4x |
- term2 <- 1 /+ dat_cols <- seq(which(names(tbl_df) == "node_class") + 1, ncol(tbl_df)) |
| 170 | -5x | +246 | +4x |
- (2 * min(n1, n2)) + kappa * sqrt(p1_hat * (1 - p1_hat) / (n1 - 1) + p2_hat * (1 - p2_hat) / (n2 - 1))+ tbl_df <- tbl_df[, c(which(names(tbl_df) == "row_num"), dat_cols)] |
| 171 | -5x | +247 | +4x |
- ci_lwr <- max(-1, est - term2)+ names(tbl_df) <- c("row_num", tbl_stats)
|
| 172 | -5x | +|||
| 248 | +
- ci_upr <- min(1, est + term2)+ |
|||
| 173 | +249 |
- },+ # Check table data columns |
||
| 174 | -26x | +250 | +4x |
- mn = {
+ if (!is.null(col_ci)) {
|
| 175 | -1x | +251 | +4x |
- .conf <- function(x1, n1, x2, n2, z, lower = FALSE) {
+ ci_col <- col_ci + 1 |
| 176 | -2x | +|||
| 252 | +
- p1 <- x1 / n1+ } else {
|
|||
| 177 | -2x | +|||
| 253 | +! |
- p2 <- x2 / n2+ tbl_df[["empty_ci"]] <- rep(list(c(NA_real_, NA_real_)), nrow(tbl_df)) |
||
| 178 | -2x | +|||
| 254 | +! |
- p_hat <- p1 - p2+ ci_col <- which(names(tbl_df) == "empty_ci") |
||
| 179 | -2x | +|||
| 255 | +
- dp <- 1 + ifelse(lower, 1, -1) * p_hat+ } |
|||
| 180 | -2x | +|||
| 256 | +! |
- i <- 1+ if (length(tbl_df[, ci_col][[1]]) != 2) stop("CI column must have two elements (lower and upper limits).")
|
||
| 181 | -2x | +|||
| 257 | +
- while (i <= 50) {
+
|
|||
| 182 | -46x | +258 | +4x |
- dp <- 0.5 * dp+ if (!is.null(col_x)) {
|
| 183 | -46x | +259 | +4x |
- y <- p_hat + ifelse(lower, -1, 1) * dp+ x_col <- col_x + 1 |
| 184 | -46x | +|||
| 260 | +
- score <- .score(p1, n1, p2, n2, y)+ } else {
|
|||
| 185 | -46x | +|||
| 261 | +! |
- if (score < z) {
+ tbl_df[["empty_x"]] <- NA_real_ |
||
| 186 | -20x | +|||
| 262 | +! |
- p_hat <- y+ x_col <- which(names(tbl_df) == "empty_x") |
||
| 187 | +263 |
- }+ } |
||
| 188 | -46x | +264 | +4x |
- if ((dp < 1e-07) || (abs(z - score) < 1e-06)) {
+ if (!is.null(col_symbol_size)) {
|
| 189 | -2x | +265 | +3x |
- (break)()+ sym_size <- unlist(tbl_df[, col_symbol_size + 1]) |
| 190 | +266 |
- } else {
+ } else {
|
||
| 191 | -44x | +267 | +1x |
- i <- i + 1+ sym_size <- rep(1, nrow(tbl_df)) |
| 192 | +268 |
- }+ } |
||
| 193 | +269 |
- }+ |
||
| 194 | -2x | -
- return(y)- |
- ||
| 195 | -+ | 270 | +4x |
- }+ tbl_df[, c("ci_lwr", "ci_upr")] <- t(sapply(tbl_df[, ci_col], unlist))
|
| 196 | -1x | +271 | +4x |
- .score <- function(p1, n1, p2, n2, dif) {
+ x <- unlist(tbl_df[, x_col]) |
| 197 | -46x | +272 | +4x |
- diff <- p1 - p2 - dif+ lwr <- unlist(tbl_df[["ci_lwr"]]) |
| 198 | -46x | +273 | +4x |
- if (abs(diff) == 0) {
+ upr <- unlist(tbl_df[["ci_upr"]]) |
| 199 | -! | +|||
| 274 | +4x |
- res <- 0+ row_num <- nrow(mat_strings) - tbl_df[["row_num"]] - as.numeric(nlines_hdr == 2) |
||
| 200 | +275 |
- } else {
+
|
||
| 201 | -46x | +276 | +4x |
- t <- n2 / n1+ if (is.null(col)) col <- "#343cff" |
| 202 | -46x | +277 | +4x |
- a <- 1 + t+ if (length(col) == 1) col <- rep(col, nrow(tbl_df)) |
| 203 | -46x | +|||
| 278 | +! |
- b <- -(1 + t + p1 + t * p2 + dif * (t + 2))+ if (is.null(x_at)) x_at <- union(xlim, vline) |
||
| 204 | -46x | +279 | +4x |
- c <- dif * dif + dif * (2 * p1 + t + 1) + p1 + t * p2+ x_labels <- x_at |
| 205 | -46x | +|||
| 280 | +
- d <- -p1 * dif * (1 + dif)+ |
|||
| 206 | -46x | +|||
| 281 | +
- v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2+ # Apply log transformation |
|||
| 207 | -46x | +282 | +4x |
- s <- sqrt((b / a / 3)^2 - c / a / 3)+ if (logx) {
|
| 208 | -46x | +283 | +4x |
- u <- ifelse(v > 0, 1, -1) * s+ x_t <- log(x) |
| 209 | -46x | +284 | +4x |
- w <- (3.141592654 + acos(v / u^3)) / 3+ lwr_t <- log(lwr) |
| 210 | -46x | +285 | +4x |
- p1d <- 2 * u * cos(w) - b / a / 3+ upr_t <- log(upr) |
| 211 | -46x | +286 | +4x |
- p2d <- p1d - dif+ xlim_t <- log(xlim) |
| 212 | -46x | +|||
| 287 | +
- n <- n1 + n2+ } else {
|
|||
| 213 | -46x | +|||
| 288 | +! |
- var <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2) * n / (n - 1)+ x_t <- x |
||
| 214 | -46x | +|||
| 289 | +! |
- res <- diff^2 / var+ lwr_t <- lwr |
||
| 215 | -+ | |||
| 290 | +! |
- }+ upr_t <- upr |
||
| 216 | -46x | +|||
| 291 | +! |
- return(res)+ xlim_t <- xlim |
||
| 217 | +292 |
- }+ } |
||
| 218 | -1x | +|||
| 293 | +
- z <- stats::qchisq(conf.level, 1)+ |
|||
| 219 | -1x | +|||
| 294 | +
- ci_lwr <- max(-1, .conf(x1, n1, x2, n2, z, TRUE))+ # Set up plot area |
|||
| 220 | -1x | -
- ci_upr <- min(1, .conf(x1, n1, x2, n2, z, FALSE))- |
- ||
| 221 | -+ | 295 | +4x |
- },+ gg_plt <- ggplot(data = tbl_df) + |
| 222 | -26x | +296 | +4x |
- beal = {
+ theme( |
| 223 | -! | +|||
| 297 | +4x |
- a <- p1_hat + p2_hat+ panel.background = element_rect(fill = "transparent", color = NA_character_), |
||
| 224 | -! | +|||
| 298 | +4x |
- b <- p1_hat - p2_hat+ plot.background = element_rect(fill = "transparent", color = NA_character_), |
||
| 225 | -! | +|||
| 299 | +4x |
- u <- ((1 / n1) + (1 / n2)) / 4+ panel.grid.major = element_blank(), |
||
| 226 | -! | +|||
| 300 | +4x |
- v <- ((1 / n1) - (1 / n2)) / 4+ panel.grid.minor = element_blank(), |
||
| 227 | -! | +|||
| 301 | +4x |
- V <- u * ((2 - a) * a - b^2) + 2 * v * (1 - a) * b # nolint+ axis.title.x = element_blank(), |
||
| 228 | -! | +|||
| 302 | +4x |
- z <- stats::qchisq(p = 1 - alpha / 2, df = 1)+ axis.title.y = element_blank(), |
||
| 229 | -! | +|||
| 303 | +4x |
- A <- sqrt(z * (V + z * u^2 * (2 - a) * a + z * v^2 * (1 - a)^2)) # nolint+ axis.line.x = element_line(), |
||
| 230 | -! | +|||
| 304 | +4x |
- B <- (b + z * v * (1 - a)) / (1 + z * u) # nolint+ axis.text = element_text(size = font_size), |
||
| 231 | -! | +|||
| 305 | +4x |
- ci_lwr <- max(-1, B - A / (1 + z * u))+ legend.position = "none", |
||
| 232 | -! | +|||
| 306 | +4x |
- ci_upr <- min(1, B + A / (1 + z * u))+ plot.margin = margin(0, 0.1, 0.05, 0, "npc") |
||
| 233 | +307 |
- },+ ) + |
||
| 234 | -26x | +308 | +4x |
- hal = {
+ scale_x_continuous( |
| 235 | -1x | +309 | +4x |
- psi <- (p1_hat + p2_hat) / 2+ transform = ifelse(logx, "log", "identity"), |
| 236 | -1x | +310 | +4x |
- u <- (1 / n1 + 1 / n2) / 4+ limits = xlim, |
| 237 | -1x | +311 | +4x |
- v <- (1 / n1 - 1 / n2) / 4+ breaks = x_at, |
| 238 | -1x | +312 | +4x |
- z <- kappa+ labels = x_labels, |
| 239 | -1x | +313 | +4x |
- theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 * psi)) / (1 + z^2 * u)+ expand = c(0.01, 0) |
| 240 | -1x | +|||
| 314 | +
- w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) - (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) *+ ) + |
|||
| 241 | -1x | +315 | +4x |
- (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) * psi + z^2 * v^2 * (1 - 2 * psi)^2) # nolint+ scale_y_continuous( |
| 242 | -1x | +316 | +4x |
- c(theta + w, theta - w)+ limits = c(0, nrow(mat_strings) + 1), |
| 243 | -1x | +317 | +4x |
- ci_lwr <- max(-1, theta - w)+ breaks = NULL, |
| 244 | -1x | +318 | +4x |
- ci_upr <- min(1, theta + w)+ expand = c(0, 0) |
| 245 | +319 |
- },- |
- ||
| 246 | -26x | -
- jp = {
+ ) + |
||
| 247 | -1x | +320 | +4x |
- psi <- 0.5 * ((x1 + 0.5) / (n1 + 1) + (x2 + 0.5) / (n2 + 1))+ coord_cartesian(clip = "off") |
| 248 | -1x | +|||
| 321 | +
- u <- (1 / n1 + 1 / n2) / 4+ |
|||
| 249 | -1x | +322 | +4x |
- v <- (1 / n1 - 1 / n2) / 4+ if (is.null(ggtheme)) {
|
| 250 | -1x | +323 | +4x |
- z <- kappa+ gg_plt <- gg_plt + annotate( |
| 251 | -1x | +324 | +4x |
- theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 * psi)) / (1 + z^2 * u)+ "rect", |
| 252 | -1x | +325 | +4x |
- w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) - (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) *+ xmin = xlim[1], |
| 253 | -1x | +326 | +4x |
- (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) * psi + z^2 * v^2 * (1 - 2 * psi)^2) # nolint+ xmax = xlim[2], |
| 254 | -1x | +327 | +4x |
- c(theta + w, theta - w)+ ymin = 0, |
| 255 | -1x | +328 | +4x |
- ci_lwr <- max(-1, theta - w)+ ymax = nrows_body + 0.5, |
| 256 | -1x | +329 | +4x |
- ci_upr <- min(1, theta + w)+ fill = "grey92" |
| 257 | +330 |
- },+ ) |
||
| 258 | +331 |
- )- |
- ||
| 259 | -26x | -
- ci <- c(+ } |
||
| 260 | -26x | +|||
| 332 | +
- est = est, lwr.ci = min(ci_lwr, ci_upr),+ |
|||
| 261 | -26x | +333 | +4x |
- upr.ci = max(ci_lwr, ci_upr)+ if (!is.null(vline)) {
|
| 262 | +334 |
- )+ # Set default forest header |
||
| 263 | -26x | +335 | +4x |
- if (sides == "left") {
+ if (is.null(forest_header)) {
|
| 264 | +336 | ! |
- ci[3] <- 1+ forest_header <- c( |
|
| 265 | -26x | +|||
| 337 | +! |
- } else if (sides == "right") {
+ paste(if (length(arms) == 2) arms[1] else "Comparison", "Better", sep = "\n"), |
||
| 266 | +338 | ! |
- ci[2] <- -1+ paste(if (length(arms) == 2) arms[2] else "Treatment", "Better", sep = "\n") |
|
| 267 | +339 |
- }+ ) |
||
| 268 | -26x | +|||
| 340 | +
- return(ci)+ } |
|||
| 269 | +341 |
- }+ |
||
| 270 | -26x | +|||
| 342 | +
- method <- match.arg(arg = method, several.ok = TRUE)+ # Add vline and forest header labels |
|||
| 271 | -26x | +343 | +4x |
- sides <- match.arg(arg = sides, several.ok = TRUE)+ mid_pts <- if (logx) {
|
| 272 | -26x | +344 | +4x |
- lst <- h_recycle(+ c(exp(mean(log(c(xlim[1], vline)))), exp(mean(log(c(vline, xlim[2]))))) |
| 273 | -26x | +|||
| 345 | +
- x1 = x1, n1 = n1, x2 = x2, n2 = n2, conf.level = conf.level,+ } else {
|
|||
| 274 | -26x | +|||
| 346 | +! |
- sides = sides, method = method+ c(mean(c(xlim[1], vline)), mean(c(vline, xlim[2]))) |
||
| 275 | +347 |
- )- |
- ||
| 276 | -26x | -
- res <- t(sapply(1:attr(lst, "maxdim"), function(i) {
+ } |
||
| 277 | -26x | +348 | +4x |
- iBinomDiffCI(+ gg_plt <- gg_plt + |
| 278 | -26x | +349 | +4x |
- x1 = lst$x1[i],+ annotate( |
| 279 | -26x | +350 | +4x |
- n1 = lst$n1[i], x2 = lst$x2[i], n2 = lst$n2[i], conf.level = lst$conf.level[i],+ "segment", |
| 280 | -26x | -
- sides = lst$sides[i], method = lst$method[i]- |
- ||
| 281 | -+ | 351 | +4x |
- )+ x = vline, xend = vline, y = 0, yend = nrows_body + 0.5 |
| 282 | +352 |
- }))+ ) + |
||
| 283 | -26x | +353 | +4x |
- lgn <- h_recycle(x1 = if (is.null(names(x1))) {
+ annotate( |
| 284 | -26x | +354 | +4x |
- paste("x1", seq_along(x1), sep = ".")
+ "text", |
| 285 | -+ | |||
| 355 | +4x |
- } else {
+ x = mid_pts[1], y = nrows_body + 1.25, |
||
| 286 | -! | +|||
| 356 | +4x |
- names(x1)+ label = forest_header[1], |
||
| 287 | -26x | +357 | +4x |
- }, n1 = if (is.null(names(n1))) {
+ size = font_size / .pt, |
| 288 | -26x | +358 | +4x |
- paste("n1", seq_along(n1), sep = ".")
+ lineheight = 0.9 |
| 289 | +359 |
- } else {
+ ) + |
||
| 290 | -! | +|||
| 360 | +4x |
- names(n1)+ annotate( |
||
| 291 | -26x | +361 | +4x |
- }, x2 = if (is.null(names(x2))) {
+ "text", |
| 292 | -26x | +362 | +4x |
- paste("x2", seq_along(x2), sep = ".")
+ x = mid_pts[2], y = nrows_body + 1.25, |
| 293 | -+ | |||
| 363 | +4x |
- } else {
+ label = forest_header[2], |
||
| 294 | -! | +|||
| 364 | +4x |
- names(x2)+ size = font_size / .pt, |
||
| 295 | -26x | +365 | +4x |
- }, n2 = if (is.null(names(n2))) {
+ lineheight = 0.9 |
| 296 | -26x | +|||
| 366 | +
- paste("n2", seq_along(n2), sep = ".")
+ ) |
|||
| 297 | +367 |
- } else {
+ } |
||
| 298 | -! | +|||
| 368 | +
- names(n2)+ + |
+ |||
| 369 | ++ |
+ # Add points to plot |
||
| 299 | -26x | +370 | +4x |
- }, conf.level = conf.level, sides = sides, method = method)+ if (any(!is.na(x_t))) {
|
| 300 | -26x | +371 | +4x |
- xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
+ x_t[x < xlim[1] | x > xlim[2]] <- NA |
| 301 | -182x | +372 | +4x |
- length(unique(x)) !=+ gg_plt <- gg_plt + geom_point( |
| 302 | -182x | +373 | +4x |
- 1+ x = x_t, |
| 303 | -26x | +374 | +4x |
- })]), 1, paste, collapse = ":")+ y = row_num, |
| 304 | -26x | +375 | +4x |
- rownames(res) <- xn+ color = col, |
| 305 | -26x | +376 | +4x |
- return(res)+ aes(size = sym_size), |
| 306 | -+ | |||
| 377 | +4x |
- }+ na.rm = TRUE |
||
| 307 | +378 |
-
+ ) |
||
| 308 | +379 |
- #' @describeIn desctools_binom Compute confidence intervals for binomial proportions.+ } |
||
| 309 | +380 |
- #'+ |
||
| 310 | -+ | |||
| 381 | +4x |
- #' @param x (`integer(1)`)\cr number of successes.+ for (i in seq_len(nrow(tbl_df))) {
|
||
| 311 | +382 |
- #' @param n (`integer(1)`)\cr number of trials.+ # Determine which arrow(s) to add to CI lines |
||
| 312 | -+ | |||
| 383 | +17x |
- #' @param conf.level (`proportion`)\cr confidence level, defaults to 0.95.+ which_arrow <- c(lwr_t[i] < xlim_t[1], upr_t[i] > xlim_t[2]) |
||
| 313 | -+ | |||
| 384 | +17x |
- #' @param sides (`string`)\cr side of the confidence interval to compute. Must be one of `"two-sided"` (default),+ which_arrow <- dplyr::case_when( |
||
| 314 | -+ | |||
| 385 | +17x |
- #' `"left"`, or `"right"`.+ all(which_arrow) ~ "both", |
||
| 315 | -+ | |||
| 386 | +17x |
- #' @param method (`string`)\cr method to use. Can be one out of: `"wald"`, `"wilson"`, `"wilsoncc"`,+ which_arrow[1] ~ "first", |
||
| 316 | -+ | |||
| 387 | +17x |
- #' `"agresti-coull"`, `"jeffreys"`, `"modified wilson"`, `"modified jeffreys"`, `"clopper-pearson"`, `"arcsine"`,+ which_arrow[2] ~ "last", |
||
| 317 | -+ | |||
| 388 | +17x |
- #' `"logit"`, `"witting"`, `"pratt"`, `"midp"`, `"lik"`, and `"blaker"`.+ TRUE ~ NA_character_ |
||
| 318 | +389 |
- #'+ ) |
||
| 319 | +390 |
- #' @return A `matrix` with 3 columns containing:+ |
||
| 320 | +391 |
- #' * `est`: estimate of proportion difference.+ # Add CI lines |
||
| 321 | -+ | |||
| 392 | +17x |
- #' * `lwr.ci`: lower end of the confidence interval.+ gg_plt <- gg_plt + |
||
| 322 | -+ | |||
| 393 | +17x |
- #' * `upr.ci`: upper end of the confidence interval.+ if (!is.na(which_arrow)) {
|
||
| 323 | -+ | |||
| 394 | +15x |
- #'+ annotate( |
||
| 324 | -+ | |||
| 395 | +15x |
- #' @keywords internal+ "segment", |
||
| 325 | -+ | |||
| 396 | +15x |
- desctools_binomci <- function(x,+ x = if (!which_arrow %in% c("first", "both")) lwr[i] else xlim[1],
|
||
| 326 | -+ | |||
| 397 | +15x |
- n,+ xend = if (!which_arrow %in% c("last", "both")) upr[i] else xlim[2],
|
||
| 327 | -+ | |||
| 398 | +15x |
- conf.level = 0.95, # nolint+ y = row_num[i], yend = row_num[i], |
||
| 328 | -+ | |||
| 399 | +15x |
- sides = c("two.sided", "left", "right"),
+ color = if (length(col) == 1) col else col[i], |
||
| 329 | -+ | |||
| 400 | +15x |
- method = c(+ arrow = arrow(length = unit(0.05, "npc"), ends = which_arrow), |
||
| 330 | -+ | |||
| 401 | +15x |
- "wilson", "wald", "waldcc", "agresti-coull",+ na.rm = TRUE |
||
| 331 | +402 |
- "jeffreys", "modified wilson", "wilsoncc", "modified jeffreys",+ ) |
||
| 332 | +403 |
- "clopper-pearson", "arcsine", "logit", "witting", "pratt",+ } else {
|
||
| 333 | -+ | |||
| 404 | +2x |
- "midp", "lik", "blaker"+ annotate( |
||
| 334 | -+ | |||
| 405 | +2x |
- ),+ "segment", |
||
| 335 | -+ | |||
| 406 | +2x |
- rand = 123,+ x = lwr[i], xend = upr[i], |
||
| 336 | -+ | |||
| 407 | +2x |
- tol = 1e-05) {
+ y = row_num[i], yend = row_num[i], |
||
| 337 | -26x | +408 | +2x |
- if (missing(method)) {
+ color = if (length(col) == 1) col else col[i], |
| 338 | -1x | +409 | +2x |
- method <- "wilson"+ na.rm = TRUE |
| 339 | +410 |
- }+ ) |
||
| 340 | -26x | +|||
| 411 | +
- if (missing(sides)) {
+ } |
|||
| 341 | -25x | +|||
| 412 | +
- sides <- "two.sided"+ } |
|||
| 342 | +413 |
- }+ |
||
| 343 | -26x | +|||
| 414 | +
- iBinomCI <- function(x, n, conf.level = 0.95, sides = c("two.sided", "left", "right"), # nolint
+ # Apply custom ggtheme to plot |
|||
| 344 | -26x | +|||
| 415 | +! |
- method = c(+ if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme+ |
+ ||
| 416 | ++ | + | ||
| 345 | -26x | +417 | +4x |
- "wilson", "wilsoncc", "wald",+ if (as_list) {
|
| 346 | -26x | +418 | +1x |
- "waldcc", "agresti-coull", "jeffreys", "modified wilson",+ list( |
| 347 | -26x | +419 | +1x |
- "modified jeffreys", "clopper-pearson", "arcsine", "logit",+ table = gg_table, |
| 348 | -26x | +420 | +1x |
- "witting", "pratt", "midp", "lik", "blaker"+ plot = gg_plt |
| 349 | +421 |
- ),+ ) |
||
| 350 | -26x | +|||
| 422 | +
- rand = 123,+ } else {
|
|||
| 351 | -26x | +423 | +3x |
- tol = 1e-05) {
+ cowplot::plot_grid( |
| 352 | -26x | +424 | +3x |
- if (length(x) != 1) {
+ gg_table, |
| 353 | -! | +|||
| 425 | +3x |
- stop("'x' has to be of length 1 (number of successes)")
+ gg_plt, |
||
| 354 | -+ | |||
| 426 | +3x |
- }+ align = "h", |
||
| 355 | -26x | +427 | +3x |
- if (length(n) != 1) {
+ axis = "tblr", |
| 356 | -! | +|||
| 428 | +3x |
- stop("'n' has to be of length 1 (number of trials)")
+ rel_widths = c(1 - rel_width_forest, rel_width_forest) |
||
| 357 | +429 |
- }- |
- ||
| 358 | -26x | -
- if (length(conf.level) != 1) {
+ ) |
||
| 359 | -! | +|||
| 430 | +
- stop("'conf.level' has to be of length 1 (confidence level)")
+ } |
|||
| 360 | +431 |
- }+ } |
||
| 361 | -26x | +|||
| 432 | +
- if (conf.level < 0.5 || conf.level > 1) {
+
|
|||
| 362 | -! | +|||
| 433 | +
- stop("'conf.level' has to be in [0.5, 1]")
+ #' Forest plot grob |
|||
| 363 | +434 |
- }+ #' |
||
| 364 | -26x | +|||
| 435 | +
- sides <- match.arg(sides, choices = c(+ #' @description `r lifecycle::badge("deprecated")`
|
|||
| 365 | -26x | +|||
| 436 | +
- "two.sided", "left",+ #' |
|||
| 366 | -26x | +|||
| 437 | +
- "right"+ #' @inheritParams g_forest |
|||
| 367 | -26x | +|||
| 438 | +
- ), several.ok = FALSE)+ #' @param tbl (`VTableTree`)\cr `rtables` table object. |
|||
| 368 | -26x | +|||
| 439 | +
- if (sides != "two.sided") {
+ #' @param x (`numeric`)\cr coordinate of point. |
|||
| 369 | -1x | +|||
| 440 | +
- conf.level <- 1 - 2 * (1 - conf.level) # nolint+ #' @param lower,upper (`numeric`)\cr lower/upper bound of the confidence interval. |
|||
| 370 | +441 |
- }+ #' @param symbol_size (`numeric`)\cr vector with relative size for plot symbol. |
||
| 371 | -26x | +|||
| 442 | +
- alpha <- 1 - conf.level+ #' If `NULL`, the same symbol size is used. |
|||
| 372 | -26x | +|||
| 443 | +
- kappa <- stats::qnorm(1 - alpha / 2)+ #' |
|||
| 373 | -26x | +|||
| 444 | +
- p_hat <- x / n+ #' @details |
|||
| 374 | -26x | +|||
| 445 | +
- q_hat <- 1 - p_hat+ #' The heights get automatically determined. |
|||
| 375 | -26x | +|||
| 446 | +
- est <- p_hat+ #' |
|||
| 376 | -26x | +|||
| 447 | +
- switch(match.arg(arg = method, choices = c(+ #' @examples |
|||
| 377 | -26x | +|||
| 448 | +
- "wilson",+ #' tbl <- rtable( |
|||
| 378 | -26x | +|||
| 449 | +
- "wald", "waldcc", "wilsoncc", "agresti-coull", "jeffreys",+ #' header = rheader( |
|||
| 379 | -26x | +|||
| 450 | +
- "modified wilson", "modified jeffreys", "clopper-pearson",+ #' rrow("", "E", rcell("CI", colspan = 2), "N"),
|
|||
| 380 | -26x | +|||
| 451 | +
- "arcsine", "logit", "witting", "pratt", "midp", "lik",+ #' rrow("", "A", "B", "C", "D")
|
|||
| 381 | -26x | +|||
| 452 | +
- "blaker"+ #' ), |
|||
| 382 | +453 |
- )),+ #' rrow("row 1", 1, 0.8, 1.1, 16),
|
||
| 383 | -26x | +|||
| 454 | +
- wald = {
+ #' rrow("row 2", 1.4, 0.8, 1.6, 25),
|
|||
| 384 | -1x | +|||
| 455 | +
- term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n)+ #' rrow("row 3", 1.2, 0.8, 1.6, 36)
|
|||
| 385 | -1x | +|||
| 456 | +
- ci_lwr <- max(0, p_hat - term2)+ #' ) |
|||
| 386 | -1x | +|||
| 457 | +
- ci_upr <- min(1, p_hat + term2)+ #' |
|||
| 387 | +458 |
- },+ #' x <- c(1, 1.4, 1.2) |
||
| 388 | -26x | +|||
| 459 | +
- waldcc = {
+ #' lower <- c(0.8, 0.8, 0.8) |
|||
| 389 | -1x | +|||
| 460 | +
- term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n)+ #' upper <- c(1.1, 1.6, 1.6) |
|||
| 390 | -1x | +|||
| 461 | +
- term2 <- term2 + 1 / (2 * n)+ #' # numeric vector with multiplication factor to scale each circle radius |
|||
| 391 | -1x | +|||
| 462 | +
- ci_lwr <- max(0, p_hat - term2)+ #' # default radius is 1/3.5 lines |
|||
| 392 | -1x | +|||
| 463 | +
- ci_upr <- min(1, p_hat + term2)+ #' symbol_scale <- c(1, 1.25, 1.5) |
|||
| 393 | +464 |
- },+ #' |
||
| 394 | -26x | +|||
| 465 | +
- wilson = {
+ #' # Internal function - forest_grob |
|||
| 395 | -8x | +|||
| 466 | +
- term1 <- (x + kappa^2 / 2) / (n + kappa^2)+ #' \donttest{
|
|||
| 396 | -8x | +|||
| 467 | +
- term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat * q_hat + kappa^2 / (4 * n))+ #' p <- forest_grob(tbl, x, lower, upper, |
|||
| 397 | -8x | +|||
| 468 | +
- ci_lwr <- max(0, term1 - term2)+ #' vline = 1, forest_header = c("A", "B"),
|
|||
| 398 | -8x | +|||
| 469 | +
- ci_upr <- min(1, term1 + term2)+ #' x_at = c(.1, 1, 10), xlim = c(0.1, 10), logx = TRUE, symbol_size = symbol_scale, |
|||
| 399 | +470 |
- },+ #' vp = grid::plotViewport(margins = c(1, 1, 1, 1)) |
||
| 400 | -26x | +|||
| 471 | +
- wilsoncc = {
+ #' ) |
|||
| 401 | -3x | +|||
| 472 | +
- lci <- (+ #' |
|||
| 402 | -3x | +|||
| 473 | +
- 2 * x + kappa^2 - 1 - kappa * sqrt(kappa^2 - 2 - 1 / n + 4 * p_hat * (n * q_hat + 1))+ #' draw_grob(p) |
|||
| 403 | -3x | +|||
| 474 | +
- ) / (2 * (n + kappa^2))+ #' } |
|||
| 404 | -3x | +|||
| 475 | +
- uci <- (+ #' |
|||
| 405 | -3x | +|||
| 476 | +
- 2 * x + kappa^2 + 1 + kappa * sqrt(kappa^2 + 2 - 1 / n + 4 * p_hat * (n * q_hat - 1))+ #' @noRd |
|||
| 406 | -3x | +|||
| 477 | +
- ) / (2 * (n + kappa^2))+ #' @keywords internal |
|||
| 407 | -3x | +|||
| 478 | +
- ci_lwr <- max(0, ifelse(p_hat == 0, 0, lci))+ forest_grob <- function(tbl, |
|||
| 408 | -3x | +|||
| 479 | +
- ci_upr <- min(1, ifelse(p_hat == 1, 1, uci))+ x, |
|||
| 409 | +480 |
- },+ lower, |
||
| 410 | -26x | +|||
| 481 | +
- `agresti-coull` = {
+ upper, |
|||
| 411 | -1x | +|||
| 482 | +
- x_tilde <- x + kappa^2 / 2+ vline, |
|||
| 412 | -1x | +|||
| 483 | +
- n_tilde <- n + kappa^2+ forest_header, |
|||
| 413 | -1x | +|||
| 484 | +
- p_tilde <- x_tilde / n_tilde+ xlim = NULL, |
|||
| 414 | -1x | +|||
| 485 | +
- q_tilde <- 1 - p_tilde+ logx = FALSE, |
|||
| 415 | -1x | +|||
| 486 | +
- est <- p_tilde+ x_at = NULL, |
|||
| 416 | -1x | +|||
| 487 | +
- term2 <- kappa * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)+ width_row_names = NULL, |
|||
| 417 | -1x | +|||
| 488 | +
- ci_lwr <- max(0, p_tilde - term2)+ width_columns = NULL, |
|||
| 418 | -1x | +|||
| 489 | +
- ci_upr <- min(1, p_tilde + term2)+ width_forest = grid::unit(1, "null"), |
|||
| 419 | +490 |
- },+ symbol_size = NULL, |
||
| 420 | -26x | +|||
| 491 | +
- jeffreys = {
+ col = "blue", |
|||
| 421 | -1x | +|||
| 492 | +
- if (x == 0) {
+ name = NULL, |
|||
| 422 | -! | +|||
| 493 | +
- ci_lwr <- 0+ gp = NULL, |
|||
| 423 | +494 |
- } else {
+ vp = NULL) {
|
||
| 424 | +495 | 1x |
- ci_lwr <- stats::qbeta(+ lifecycle::deprecate_warn( |
|
| 425 | +496 | 1x |
- alpha / 2,+ "0.9.4", "forest_grob()", |
|
| 426 | +497 | 1x |
- x + 0.5, n - x + 0.5+ details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
|
| 427 | +498 |
- )+ ) |
||
| 428 | +499 |
- }+ |
||
| 429 | +500 | 1x |
- if (x == n) {
+ nr <- nrow(tbl)+ |
+ |
| 501 | +1x | +
+ if (is.null(vline)) {
|
||
| 430 | +502 | ! |
- ci_upr <- 1+ checkmate::assert_true(is.null(forest_header)) |
|
| 431 | +503 |
- } else {
+ } else {
|
||
| 432 | +504 | 1x |
- ci_upr <- stats::qbeta(1 - alpha / 2, x + 0.5, n - x + 0.5)+ checkmate::assert_number(vline)+ |
+ |
| 505 | +1x | +
+ checkmate::assert_character(forest_header, len = 2, null.ok = TRUE) |
||
| 433 | +506 |
- }+ } |
||
| 434 | +507 |
- },+ |
||
| 435 | -26x | +508 | +1x |
- `modified wilson` = {
+ checkmate::assert_numeric(x, len = nr) |
| 436 | +509 | 1x |
- term1 <- (x + kappa^2 / 2) / (n + kappa^2)+ checkmate::assert_numeric(lower, len = nr) |
|
| 437 | +510 | 1x |
- term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat * q_hat + kappa^2 / (4 * n))+ checkmate::assert_numeric(upper, len = nr) |
|
| 438 | +511 | 1x |
- if ((n <= 50 & x %in% c(1, 2)) | (n >= 51 & x %in% c(1:3))) {
+ checkmate::assert_numeric(symbol_size, len = nr, null.ok = TRUE) |
|
| 439 | -! | +|||
| 512 | +1x |
- ci_lwr <- 0.5 * stats::qchisq(alpha, 2 * x) / n+ checkmate::assert_character(col) |
||
| 440 | +513 |
- } else {
+
|
||
| 441 | +514 | 1x |
- ci_lwr <- max(0, term1 - term2)+ if (is.null(symbol_size)) {
|
|
| 442 | -+ | |||
| 515 | +! |
- }+ symbol_size <- rep(1, nr) |
||
| 443 | -1x | +|||
| 516 | +
- if ((n <= 50 & x %in% c(n - 1, n - 2)) | (n >= 51 & x %in% c(n - (1:3)))) {
+ } |
|||
| 444 | -! | +|||
| 517 | +
- ci_upr <- 1 - 0.5 * stats::qchisq(+ |
|||
| 445 | -! | +|||
| 518 | +1x |
- alpha,+ if (is.null(xlim)) {
|
||
| 446 | +519 | ! |
- 2 * (n - x)+ r <- range(c(x, lower, upper), na.rm = TRUE) |
|
| 447 | +520 | ! |
- ) / n+ xlim <- r + c(-0.05, 0.05) * diff(r) |
|
| 448 | +521 |
- } else {
- |
- ||
| 449 | -1x | -
- ci_upr <- min(1, term1 + term2)+ } |
||
| 450 | +522 |
- }+ |
||
| 451 | -+ | |||
| 523 | +1x |
- },+ if (logx) {
|
||
| 452 | -26x | +524 | +1x |
- `modified jeffreys` = {
+ if (is.null(x_at)) {
|
| 453 | -1x | +|||
| 525 | +! |
- if (x == n) {
+ x_at <- pretty(log(stats::na.omit(c(x, lower, upper)))) |
||
| 454 | +526 | ! |
- ci_lwr <- (alpha / 2)^(1 / n)+ x_labels <- exp(x_at) |
|
| 455 | +527 |
- } else {
+ } else {
|
||
| 456 | +528 | 1x |
- if (x <= 1) {
+ x_labels <- x_at |
|
| 457 | -! | +|||
| 529 | +1x |
- ci_lwr <- 0+ x_at <- log(x_at) |
||
| 458 | +530 |
- } else {
+ } |
||
| 459 | +531 | 1x |
- ci_lwr <- stats::qbeta(+ xlim <- log(xlim) |
|
| 460 | +532 | 1x |
- alpha / 2,+ x <- log(x) |
|
| 461 | +533 | 1x |
- x + 0.5, n - x + 0.5+ lower <- log(lower) |
|
| 462 | -+ | |||
| 534 | +1x |
- )+ upper <- log(upper) |
||
| 463 | -+ | |||
| 535 | +1x |
- }+ if (!is.null(vline)) {
+ |
+ ||
| 536 | +1x | +
+ vline <- log(vline) |
||
| 464 | +537 |
- }+ } |
||
| 465 | -1x | +|||
| 538 | +
- if (x == 0) {
+ } else {
|
|||
| 466 | +539 | ! |
- ci_upr <- 1 - (alpha / 2)^(1 / n)+ x_labels <- TRUE |
|
| 467 | +540 |
- } else {
+ }+ |
+ ||
| 541 | ++ | + | ||
| 468 | +542 | 1x |
- if (x >= n - 1) {
+ data_forest_vp <- grid::dataViewport(xlim, c(0, 1)) |
|
| 469 | -! | +|||
| 543 | +
- ci_upr <- 1+ |
|||
| 470 | +544 |
- } else {
+ # Get table content as matrix form. |
||
| 471 | +545 | 1x |
- ci_upr <- stats::qbeta(1 - alpha / 2, x + 0.5, n - x + 0.5)- |
- |
| 472 | -- |
- }+ mf <- matrix_form(tbl) |
||
| 473 | +546 |
- }+ |
||
| 474 | +547 |
- },+ # Use `rtables` indent_string eventually. |
||
| 475 | -26x | +548 | +1x |
- `clopper-pearson` = {
+ mf$strings[, 1] <- paste0( |
| 476 | +549 | 1x |
- ci_lwr <- stats::qbeta(alpha / 2, x, n - x + 1)+ strrep(" ", c(rep(0, attr(mf, "nrow_header")), mf$row_info$indent)),
|
|
| 477 | +550 | 1x |
- ci_upr <- stats::qbeta(1 - alpha / 2, x + 1, n - x)+ mf$strings[, 1] |
|
| 478 | +551 |
- },- |
- ||
| 479 | -26x | -
- arcsine = {
+ ) |
||
| 480 | -1x | +|||
| 552 | +
- p_tilde <- (x + 0.375) / (n + 0.75)+ |
|||
| 481 | +553 | 1x |
- est <- p_tilde+ n_header <- attr(mf, "nrow_header") |
|
| 482 | -1x | +|||
| 554 | +
- ci_lwr <- sin(asin(sqrt(p_tilde)) - 0.5 * kappa / sqrt(n))^2+ |
|||
| 483 | -1x | +|||
| 555 | +! |
- ci_upr <- sin(asin(sqrt(p_tilde)) + 0.5 * kappa / sqrt(n))^2+ if (any(mf$display[, 1] == FALSE)) stop("row names need to be always displayed")
|
||
| 484 | +556 |
- },+ |
||
| 485 | -26x | +|||
| 557 | +
- logit = {
+ # Pre-process the data to be used in lapply and cell_in_rows. |
|||
| 486 | +558 | 1x |
- lambda_hat <- log(x / (n - x))+ to_args_for_cell_in_rows_fun <- function(part = c("body", "header"),
|
|
| 487 | +559 | 1x |
- V_hat <- n / (x * (n - x)) # nolint+ underline_colspan = FALSE) {
|
|
| 488 | -1x | +560 | +2x |
- lambda_lower <- lambda_hat - kappa * sqrt(V_hat)+ part <- match.arg(part) |
| 489 | -1x | +561 | +2x |
- lambda_upper <- lambda_hat + kappa * sqrt(V_hat)+ if (part == "body") {
|
| 490 | +562 | 1x |
- ci_lwr <- exp(lambda_lower) / (1 + exp(lambda_lower))+ mat_row_indices <- seq_len(nrow(tbl)) + n_header |
|
| 491 | +563 | 1x |
- ci_upr <- exp(lambda_upper) / (1 + exp(lambda_upper))+ row_ind_offset <- -n_header |
|
| 492 | +564 |
- },+ } else {
|
||
| 493 | -26x | +565 | +1x |
- witting = {
+ mat_row_indices <- seq_len(n_header) |
| 494 | +566 | 1x |
- set.seed(rand)+ row_ind_offset <- 0 |
|
| 495 | -1x | +|||
| 567 | +
- x_tilde <- x + stats::runif(1, min = 0, max = 1)+ } |
|||
| 496 | -1x | +|||
| 568 | +
- pbinom_abscont <- function(q, size, prob) {
+
|
|||
| 497 | -22x | +569 | +2x |
- v <- trunc(q)+ lapply(mat_row_indices, function(i) {
|
| 498 | -22x | +570 | +5x |
- term1 <- stats::pbinom(v - 1, size = size, prob = prob)+ disp <- mf$display[i, -1] |
| 499 | -22x | +571 | +5x |
- term2 <- (q - v) * stats::dbinom(v, size = size, prob = prob)+ list( |
| 500 | -22x | +572 | +5x |
- return(term1 + term2)+ row_name = mf$strings[i, 1], |
| 501 | -+ | |||
| 573 | +5x |
- }+ cells = mf$strings[i, -1][disp], |
||
| 502 | -1x | +574 | +5x |
- qbinom_abscont <- function(p, size, x) {
+ cell_spans = mf$spans[i, -1][disp], |
| 503 | -2x | +575 | +5x |
- fun <- function(prob, size, x, p) {
+ row_index = i + row_ind_offset, |
| 504 | -22x | +576 | +5x |
- pbinom_abscont(x, size, prob) - p+ underline_colspan = underline_colspan |
| 505 | +577 |
- }- |
- ||
| 506 | -2x | -
- stats::uniroot(fun,- |
- ||
| 507 | -2x | -
- interval = c(0, 1), size = size,+ ) |
||
| 508 | -2x | +|||
| 578 | +
- x = x, p = p+ }) |
|||
| 509 | -2x | +|||
| 579 | +
- )$root+ } |
|||
| 510 | +580 |
- }+ |
||
| 511 | +581 | 1x |
- ci_lwr <- qbinom_abscont(1 - alpha, size = n, x = x_tilde)+ args_header <- to_args_for_cell_in_rows_fun("header", underline_colspan = TRUE)
|
|
| 512 | +582 | 1x |
- ci_upr <- qbinom_abscont(alpha, size = n, x = x_tilde)+ args_body <- to_args_for_cell_in_rows_fun("body", underline_colspan = FALSE)
|
|
| 513 | +583 |
- },+ |
||
| 514 | -26x | +584 | +1x |
- pratt = {
+ grid::gTree( |
| 515 | +585 | 1x |
- if (x == 0) {
- |
- |
| 516 | -! | -
- ci_lwr <- 0- |
- ||
| 517 | -! | -
- ci_upr <- 1 - alpha^(1 / n)+ name = name, |
||
| 518 | +586 | 1x |
- } else if (x == 1) {
- |
- |
| 519 | -! | -
- ci_lwr <- 1 - (1 - alpha / 2)^(1 / n)+ children = grid::gList( |
||
| 520 | -! | +|||
| 587 | +1x |
- ci_upr <- 1 - (alpha / 2)^(1 / n)+ grid::gTree( |
||
| 521 | +588 | 1x |
- } else if (x == (n - 1)) {
+ children = do.call(grid::gList, lapply(args_header, do.call, what = cell_in_rows)), |
|
| 522 | -! | +|||
| 589 | +1x |
- ci_lwr <- (alpha / 2)^(1 / n)+ vp = grid::vpPath("vp_table_layout", "vp_header")
|
||
| 523 | -! | +|||
| 590 | +
- ci_upr <- (1 - alpha / 2)^(1 / n)+ ), |
|||
| 524 | +591 | 1x |
- } else if (x == n) {
+ grid::gTree( |
|
| 525 | -! | +|||
| 592 | +1x |
- ci_lwr <- alpha^(1 / n)+ children = do.call(grid::gList, lapply(args_body, do.call, what = cell_in_rows)), |
||
| 526 | -! | +|||
| 593 | +1x |
- ci_upr <- 1+ vp = grid::vpPath("vp_table_layout", "vp_body")
|
||
| 527 | +594 |
- } else {
+ ), |
||
| 528 | +595 | 1x |
- z <- stats::qnorm(1 - alpha / 2)+ grid::linesGrob( |
|
| 529 | +596 | 1x |
- A <- ((x + 1) / (n - x))^2 # nolint+ grid::unit(c(0, 1), "npc"), |
|
| 530 | +597 | 1x |
- B <- 81 * (x + 1) * (n - x) - 9 * n - 8 # nolint+ y = grid::unit(c(.5, .5), "npc"), |
|
| 531 | +598 | 1x |
- C <- (0 - 3) * z * sqrt(9 * (x + 1) * (n - x) * (9 * n + 5 - z^2) + n + 1) # nolint+ vp = grid::vpPath("vp_table_layout", "vp_spacer")
|
|
| 532 | -1x | +|||
| 599 | +
- D <- 81 * (x + 1)^2 - 9 * (x + 1) * (2 + z^2) + 1 # nolint+ ), |
|||
| 533 | -1x | +|||
| 600 | +
- E <- 1 + A * ((B + C) / D)^3 # nolint+ # forest part |
|||
| 534 | +601 | 1x |
- ci_upr <- 1 / E+ if (is.null(vline)) {
|
|
| 535 | -1x | +|||
| 602 | +! |
- A <- (x / (n - x - 1))^2 # nolint+ NULL |
||
| 536 | -1x | +|||
| 603 | +
- B <- 81 * x * (n - x - 1) - 9 * n - 8 # nolint+ } else {
|
|||
| 537 | +604 | 1x |
- C <- 3 * z * sqrt(9 * x * (n - x - 1) * (9 * n + 5 - z^2) + n + 1) # nolint+ grid::gTree( |
|
| 538 | +605 | 1x |
- D <- 81 * x^2 - 9 * x * (2 + z^2) + 1 # nolint+ children = grid::gList( |
|
| 539 | +606 | 1x |
- E <- 1 + A * ((B + C) / D)^3 # nolint+ grid::gTree( |
|
| 540 | +607 | 1x |
- ci_lwr <- 1 / E+ children = grid::gList( |
|
| 541 | +608 |
- }+ # this may overflow, to fix, look here |
||
| 542 | +609 |
- },+ # https://stackoverflow.com/questions/33623169/add-multi-line-footnote-to-tablegrob-while-using-gridextra-in-r # nolint |
||
| 543 | -26x | +610 | +1x |
- midp = {
+ grid::textGrob( |
| 544 | +611 | 1x |
- f_low <- function(pi, x, n) {
+ forest_header[1], |
|
| 545 | -12x | +612 | +1x |
- 1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x,+ x = grid::unit(vline, "native") - grid::unit(1, "lines"), |
| 546 | -12x | +613 | +1x |
- size = n, prob = pi, lower.tail = FALSE+ just = c("right", "center")
|
| 547 | +614 |
- ) -+ ), |
||
| 548 | -12x | +615 | +1x |
- (1 - conf.level) / 2+ grid::textGrob( |
| 549 | -+ | |||
| 616 | +1x |
- }+ forest_header[2], |
||
| 550 | +617 | 1x |
- f_up <- function(pi, x, n) {
+ x = grid::unit(vline, "native") + grid::unit(1, "lines"), |
|
| 551 | -12x | +618 | +1x |
- 1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x - 1, size = n, prob = pi) - (1 - conf.level) / 2+ just = c("left", "center")
|
| 552 | +619 |
- }+ ) |
||
| 553 | -1x | +|||
| 620 | +
- ci_lwr <- 0+ ), |
|||
| 554 | +621 | 1x |
- ci_upr <- 1+ vp = grid::vpStack(grid::viewport(layout.pos.col = ncol(tbl) + 2), data_forest_vp) |
|
| 555 | -1x | +|||
| 622 | +
- if (x != 0) {
+ ) |
|||
| 556 | -1x | +|||
| 623 | +
- ci_lwr <- stats::uniroot(f_low,+ ), |
|||
| 557 | +624 | 1x |
- interval = c(0, p_hat),+ vp = grid::vpPath("vp_table_layout", "vp_header")
|
|
| 558 | -1x | +|||
| 625 | +
- x = x, n = n+ ) |
|||
| 559 | -1x | +|||
| 626 | +
- )$root+ }, |
|||
| 560 | -+ | |||
| 627 | +1x |
- }+ grid::gTree( |
||
| 561 | +628 | 1x |
- if (x != n) {
+ children = grid::gList( |
|
| 562 | +629 | 1x |
- ci_upr <- stats::uniroot(f_up, interval = c(+ grid::gTree( |
|
| 563 | +630 | 1x |
- p_hat,+ children = grid::gList( |
|
| 564 | +631 | 1x |
- 1+ grid::rectGrob(gp = grid::gpar(col = "gray90", fill = "gray90")), |
|
| 565 | +632 | 1x |
- ), x = x, n = n)$root+ if (is.null(vline)) {
|
|
| 566 | -+ | |||
| 633 | +! |
- }+ NULL |
||
| 567 | +634 |
- },+ } else {
|
||
| 568 | -26x | +635 | +1x |
- lik = {
+ grid::linesGrob( |
| 569 | -2x | +636 | +1x |
- ci_lwr <- 0+ x = grid::unit(rep(vline, 2), "native"), |
| 570 | -2x | +637 | +1x |
- ci_upr <- 1+ y = grid::unit(c(0, 1), "npc"), |
| 571 | -2x | +638 | +1x |
- z <- stats::qnorm(1 - alpha * 0.5)+ gp = grid::gpar(lwd = 2), |
| 572 | -2x | +639 | +1x |
- tol <- .Machine$double.eps^0.5+ vp = data_forest_vp |
| 573 | -2x | +|||
| 640 | +
- BinDev <- function(y, x, mu, wt, bound = 0, tol = .Machine$double.eps^0.5, # nolint+ ) |
|||
| 574 | +641 |
- ...) {
+ }, |
||
| 575 | -40x | +642 | +1x |
- ll_y <- ifelse(y %in% c(0, 1), 0, stats::dbinom(x, wt,+ grid::xaxisGrob(at = x_at, label = x_labels, vp = data_forest_vp) |
| 576 | -40x | +|||
| 643 | +
- y,+ ), |
|||
| 577 | -40x | +644 | +1x |
- log = TRUE+ vp = grid::viewport(layout.pos.col = ncol(tbl) + 2) |
| 578 | +645 |
- ))- |
- ||
| 579 | -40x | -
- ll_mu <- ifelse(mu %in% c(0, 1), 0, stats::dbinom(x,+ ) |
||
| 580 | -40x | +|||
| 646 | +
- wt, mu,+ ), |
|||
| 581 | -40x | +647 | +1x |
- log = TRUE+ vp = grid::vpPath("vp_table_layout", "vp_body")
|
| 582 | +648 |
- ))+ ), |
||
| 583 | -40x | +649 | +1x |
- res <- ifelse(abs(y - mu) < tol, 0, sign(y - mu) * sqrt(-2 * (ll_y - ll_mu)))+ grid::gTree( |
| 584 | -40x | -
- return(res - bound)- |
- ||
| 585 | -+ | 650 | +1x |
- }+ children = do.call( |
| 586 | -2x | +651 | +1x |
- if (x != 0 && tol < p_hat) {
+ grid::gList, |
| 587 | -2x | +652 | +1x |
- ci_lwr <- if (BinDev(+ Map( |
| 588 | -2x | +653 | +1x |
- tol, x, p_hat, n, -z,+ function(xi, li, ui, row_index, size_i, col) {
|
| 589 | -2x | +654 | +3x |
- tol+ forest_dot_line( |
| 590 | -2x | +655 | +3x |
- ) <= 0) {
+ xi, |
| 591 | -2x | +656 | +3x |
- stats::uniroot(+ li, |
| 592 | -2x | -
- f = BinDev, interval = c(tol, if (p_hat < tol || p_hat == 1) {
- |
- ||
| 593 | -! | +657 | +3x |
- 1 - tol+ ui, |
| 594 | -+ | |||
| 658 | +3x |
- } else {
+ row_index, |
||
| 595 | -2x | +659 | +3x |
- p_hat+ xlim, |
| 596 | -2x | +660 | +3x |
- }), bound = -z,+ symbol_size = size_i, |
| 597 | -2x | +661 | +3x |
- x = x, mu = p_hat, wt = n+ col = col, |
| 598 | -2x | +662 | +3x |
- )$root+ datavp = data_forest_vp |
| 599 | +663 |
- }+ ) |
||
| 600 | +664 |
- }+ }, |
||
| 601 | -2x | +665 | +1x |
- if (x != n && p_hat < (1 - tol)) {
+ x, |
| 602 | -2x | +666 | +1x |
- ci_upr <- if (+ lower, |
| 603 | -2x | +667 | +1x |
- BinDev(y = 1 - tol, x = x, mu = ifelse(p_hat > 1 - tol, tol, p_hat), wt = n, bound = z, tol = tol) < 0) { # nolint
+ upper, |
| 604 | -! | +|||
| 668 | +1x |
- ci_lwr <- if (BinDev(+ seq_along(x), |
||
| 605 | -! | +|||
| 669 | +1x |
- tol, x, if (p_hat < tol || p_hat == 1) {
+ symbol_size, |
||
| 606 | -! | +|||
| 670 | +1x |
- 1 - tol+ col,+ |
+ ||
| 671 | +1x | +
+ USE.NAMES = FALSE |
||
| 607 | +672 |
- } else {
+ ) |
||
| 608 | -! | +|||
| 673 | +
- p_hat+ ), |
|||
| 609 | -! | +|||
| 674 | +1x |
- }, n,+ vp = grid::vpPath("vp_table_layout", "vp_body")
|
||
| 610 | -! | +|||
| 675 | +
- -z, tol+ ) |
|||
| 611 | -! | +|||
| 676 | +
- ) <= 0) {
+ ), |
|||
| 612 | -! | +|||
| 677 | +1x |
- stats::uniroot(+ childrenvp = forest_viewport(tbl, width_row_names, width_columns, width_forest), |
||
| 613 | -! | +|||
| 678 | +1x |
- f = BinDev, interval = c(tol, p_hat),+ vp = vp, |
||
| 614 | -! | +|||
| 679 | +1x |
- bound = -z, x = x, mu = p_hat, wt = n+ gp = gp |
||
| 615 | -! | +|||
| 680 | +
- )$root+ ) |
|||
| 616 | +681 |
- }+ } |
||
| 617 | +682 |
- } else {
+
|
||
| 618 | -2x | +|||
| 683 | +
- stats::uniroot(+ cell_in_rows <- function(row_name, |
|||
| 619 | -2x | +|||
| 684 | +
- f = BinDev, interval = c(if (p_hat > 1 - tol) {
+ cells, |
|||
| 620 | -! | +|||
| 685 | +
- tol+ cell_spans, |
|||
| 621 | +686 |
- } else {
+ row_index, |
||
| 622 | -2x | +|||
| 687 | +
- p_hat+ underline_colspan = FALSE) {
|
|||
| 623 | -2x | +688 | +5x |
- }, 1 - tol), bound = z,+ checkmate::assert_string(row_name) |
| 624 | -2x | +689 | +5x |
- x = x, mu = p_hat, wt = n+ checkmate::assert_character(cells, min.len = 1, any.missing = FALSE) |
| 625 | -2x | +690 | +5x |
- )$root+ checkmate::assert_numeric(cell_spans, len = length(cells), any.missing = FALSE) |
| 626 | -+ | |||
| 691 | +5x |
- }+ checkmate::assert_number(row_index) |
||
| 627 | -+ | |||
| 692 | +5x |
- }+ checkmate::assert_flag(underline_colspan) |
||
| 628 | +693 |
- },+ |
||
| 629 | -26x | +694 | +5x |
- blaker = {
+ vp_name_rn <- paste0("rowname-", row_index)
|
| 630 | -1x | +695 | +5x |
- acceptbin <- function(x, n, p) {
+ g_rowname <- if (!is.null(row_name) && row_name != "") {
|
| 631 | -3954x | +696 | +3x |
- p1 <- 1 - stats::pbinom(x - 1, n, p)+ grid::textGrob( |
| 632 | -3954x | +697 | +3x |
- p2 <- stats::pbinom(x, n, p)+ name = vp_name_rn, |
| 633 | -3954x | +698 | +3x |
- a1 <- p1 + stats::pbinom(stats::qbinom(p1, n, p) - 1, n, p)+ label = row_name, |
| 634 | -3954x | +699 | +3x |
- a2 <- p2 + 1 - stats::pbinom(+ x = grid::unit(0, "npc"), |
| 635 | -3954x | +700 | +3x |
- stats::qbinom(1 - p2, n, p), n,+ just = c("left", "center"),
|
| 636 | -3954x | +701 | +3x |
- p+ vp = grid::vpPath(paste0("rowname-", row_index))
|
| 637 | +702 |
- )- |
- ||
| 638 | -3954x | -
- return(min(a1, a2))+ ) |
||
| 639 | +703 |
- }+ } else {
|
||
| 640 | -1x | +704 | +2x |
- ci_lwr <- 0+ NULL |
| 641 | -1x | +|||
| 705 | +
- ci_upr <- 1+ } |
|||
| 642 | -1x | +|||
| 706 | +
- if (x != 0) {
+
|
|||
| 643 | -1x | +707 | +5x |
- ci_lwr <- stats::qbeta((1 - conf.level) / 2, x, n - x + 1)+ gl_cols <- if (!(length(cells) > 0)) {
|
| 644 | -1x | +|||
| 708 | +! |
- while (acceptbin(x, n, ci_lwr + tol) < (1 - conf.level)) {
+ list(NULL) |
||
| 645 | -1976x | +|||
| 709 | +
- ci_lwr <- ci_lwr + tol+ } else {
|
|||
| 646 | -+ | |||
| 710 | +5x |
- }+ j <- 1 # column index of cell |
||
| 647 | +711 |
- }+ |
||
| 648 | -1x | +712 | +5x |
- if (x != n) {
+ lapply(seq_along(cells), function(k) {
|
| 649 | -1x | +713 | +19x |
- ci_upr <- stats::qbeta(1 - (1 - conf.level) / 2, x + 1, n - x)+ cell_ascii <- cells[[k]] |
| 650 | -1x | +714 | +19x |
- while (acceptbin(x, n, ci_upr - tol) < (1 - conf.level)) {
+ cs <- cell_spans[[k]]+ |
+
| 715 | ++ | + | ||
| 651 | -1976x | +716 | +19x |
- ci_upr <- ci_upr - tol+ if (is.na(cell_ascii) || is.null(cell_ascii)) {
|
| 652 | -+ | |||
| 717 | +! |
- }+ cell_ascii <- "NA" |
||
| 653 | +718 |
} |
||
| 654 | +719 |
- }+ |
||
| 655 | -+ | |||
| 720 | +19x |
- )+ cell_name <- paste0("g-cell-", row_index, "-", j)
|
||
| 656 | -26x | +|||
| 721 | +
- ci <- c(est = est, lwr.ci = max(0, ci_lwr), upr.ci = min(+ |
|||
| 657 | -26x | +722 | +19x |
- 1,+ cell_grobs <- if (identical(cell_ascii, "")) {
|
| 658 | -26x | +|||
| 723 | +! |
- ci_upr+ NULL |
||
| 659 | +724 |
- ))+ } else {
|
||
| 660 | -26x | +725 | +19x |
- if (sides == "left") {
+ if (cs == 1) {
|
| 661 | -1x | +726 | +18x |
- ci[3] <- 1+ grid::textGrob( |
| 662 | -25x | -
- } else if (sides == "right") {
- |
- ||
| 663 | -! | +727 | +18x |
- ci[2] <- 0+ label = cell_ascii, |
| 664 | -+ | |||
| 728 | +18x |
- }+ name = cell_name, |
||
| 665 | -26x | +729 | +18x |
- return(ci)+ vp = grid::vpPath(paste0("cell-", row_index, "-", j))
|
| 666 | +730 |
- }+ ) |
||
| 667 | -26x | +|||
| 731 | +
- lst <- list(+ } else {
|
|||
| 668 | -26x | +|||
| 732 | +
- x = x, n = n, conf.level = conf.level, sides = sides,+ # +1 because of rowname |
|||
| 669 | -26x | +733 | +1x |
- method = method, rand = rand+ vp_joined_cols <- grid::viewport(layout.pos.row = row_index, layout.pos.col = seq(j + 1, j + cs)) |
| 670 | +734 |
- )+ |
||
| 671 | -26x | +735 | +1x |
- maxdim <- max(unlist(lapply(lst, length)))+ lab <- grid::textGrob( |
| 672 | -26x | +736 | +1x |
- lgp <- lapply(lst, rep, length.out = maxdim)+ label = cell_ascii, |
| 673 | -26x | +737 | +1x |
- lgn <- h_recycle(x = if (is.null(names(x))) {
+ name = cell_name, |
| 674 | -26x | +738 | +1x |
- paste("x", seq_along(x), sep = ".")
+ vp = vp_joined_cols |
| 675 | +739 |
- } else {
+ ) |
||
| 676 | -! | +|||
| 740 | +
- names(x)+ |
|||
| 677 | -26x | +741 | +1x |
- }, n = if (is.null(names(n))) {
+ if (!underline_colspan || grepl("^[[:space:]]*$", cell_ascii)) {
|
| 678 | -26x | +|||
| 742 | +! |
- paste("n", seq_along(n), sep = ".")
+ lab |
||
| 679 | +743 |
- } else {
+ } else {
|
||
| 680 | -! | +|||
| 744 | +1x |
- names(n)+ grid::gList( |
||
| 681 | -26x | +745 | +1x |
- }, conf.level = conf.level, sides = sides, method = method)+ lab, |
| 682 | -26x | +746 | +1x |
- xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
+ grid::linesGrob( |
| 683 | -130x | +747 | +1x |
- length(unique(x)) !=+ x = grid::unit.c(grid::unit(.2, "lines"), grid::unit(1, "npc") - grid::unit(.2, "lines")), |
| 684 | -130x | +748 | +1x |
- 1+ y = grid::unit(c(0, 0), "npc"), |
| 685 | -26x | +749 | +1x |
- })]), 1, paste, collapse = ":")+ vp = vp_joined_cols |
| 686 | -26x | +|||
| 750 | +
- res <- t(sapply(1:maxdim, function(i) {
+ ) |
|||
| 687 | -26x | +|||
| 751 | +
- iBinomCI(+ ) |
|||
| 688 | -26x | +|||
| 752 | +
- x = lgp$x[i],+ }+ |
+ |||
| 753 | ++ |
+ }+ |
+ ||
| 754 | ++ |
+ } |
||
| 689 | -26x | +755 | +19x |
- n = lgp$n[i], conf.level = lgp$conf.level[i], sides = lgp$sides[i],+ j <<- j + cs+ |
+
| 756 | ++ | + | ||
| 690 | -26x | +757 | +19x |
- method = lgp$method[i], rand = lgp$rand[i]+ cell_grobs |
| 691 | +758 |
- )+ }) |
||
| 692 | +759 |
- }))+ }+ |
+ ||
| 760 | ++ | + | ||
| 693 | -26x | +761 | +5x |
- colnames(res)[1] <- c("est")
+ grid::gList( |
| 694 | -26x | +762 | +5x |
- rownames(res) <- xn+ g_rowname, |
| 695 | -26x | +763 | +5x |
- return(res)+ do.call(grid::gList, gl_cols) |
| 696 | +764 | ++ |
+ )+ |
+ |
| 765 |
} |
| 1 | +766 |
- #' Helper functions for incidence rate+ |
||
| 2 | +767 | ++ |
+ #' Graphic object: forest dot line+ |
+ |
| 768 |
#' |
|||
| 3 | +769 |
- #' @description `r lifecycle::badge("stable")`
+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 4 | +770 |
#' |
||
| 5 | +771 |
- #' @param control (`list`)\cr parameters for estimation details, specified by using+ #' Calculate the `grob` corresponding to the dot line within the forest plot. |
||
| 6 | +772 |
- #' the helper function [control_incidence_rate()]. Possible parameter options are:+ #' |
||
| 7 | +773 |
- #' * `conf_level`: (`proportion`)\cr confidence level for the estimated incidence rate.+ #' @noRd |
||
| 8 | +774 |
- #' * `conf_type`: (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`+ #' @keywords internal |
||
| 9 | +775 |
- #' for confidence interval type.+ forest_dot_line <- function(x, |
||
| 10 | +776 |
- #' * `input_time_unit`: (`string`)\cr `day`, `week`, `month`, or `year` (default)+ lower, |
||
| 11 | +777 |
- #' indicating time unit for data input.+ upper, |
||
| 12 | +778 |
- #' * `num_pt_year`: (`numeric`)\cr time unit for desired output (in person-years).+ row_index, |
||
| 13 | +779 |
- #' @param person_years (`numeric(1)`)\cr total person-years at risk.+ xlim, |
||
| 14 | +780 |
- #' @param alpha (`numeric(1)`)\cr two-sided alpha-level for confidence interval.+ symbol_size = 1, |
||
| 15 | +781 |
- #' @param n_events (`integer(1)`)\cr number of events observed.+ col = "blue", |
||
| 16 | +782 |
- #'+ datavp) {
+ |
+ ||
| 783 | +3x | +
+ lifecycle::deprecate_warn(+ |
+ ||
| 784 | +3x | +
+ "0.9.4", "forest_dot_line()",+ |
+ ||
| 785 | +3x | +
+ details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
||
| 17 | +786 |
- #' @return Estimated incidence rate, `rate`, and associated confidence interval, `rate_ci`.+ ) |
||
| 18 | +787 |
- #'+ + |
+ ||
| 788 | +3x | +
+ ci <- c(lower, upper)+ |
+ ||
| 789 | +3x | +
+ if (any(!is.na(c(x, ci)))) {
|
||
| 19 | +790 |
- #' @seealso [incidence_rate]+ # line+ |
+ ||
| 791 | +3x | +
+ y <- grid::unit(c(0.5, 0.5), "npc") |
||
| 20 | +792 |
- #'+ + |
+ ||
| 793 | +3x | +
+ g_line <- if (all(!is.na(ci)) && ci[2] > xlim[1] && ci[1] < xlim[2]) {
|
||
| 21 | +794 |
- #' @name h_incidence_rate+ # - |
||
| 22 | -+ | |||
| 795 | +3x |
- NULL+ if (ci[1] >= xlim[1] && ci[2] <= xlim[2]) {
|
||
| 23 | -+ | |||
| 796 | +3x |
-
+ grid::linesGrob(x = grid::unit(c(ci[1], ci[2]), "native"), y = y) |
||
| 24 | -+ | |||
| 797 | +! |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ } else if (ci[1] < xlim[1] && ci[2] > xlim[2]) {
|
||
| 25 | +798 |
- #' associated confidence interval.+ # <-> |
||
| 26 | -+ | |||
| 799 | +! |
- #'+ grid::linesGrob( |
||
| 27 | -+ | |||
| 800 | +! |
- #' @keywords internal+ x = grid::unit(xlim, "native"), |
||
| 28 | -+ | |||
| 801 | +! |
- h_incidence_rate <- function(person_years,+ y = y, |
||
| 29 | -+ | |||
| 802 | +! |
- n_events,+ arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "both") |
||
| 30 | +803 |
- control = control_incidence_rate()) {
+ ) |
||
| 31 | -18x | +|||
| 804 | +! |
- alpha <- 1 - control$conf_level+ } else if (ci[1] < xlim[1] && ci[2] <= xlim[2]) {
|
||
| 32 | -18x | +|||
| 805 | +
- est <- switch(control$conf_type,+ # <- |
|||
| 33 | -18x | +|||
| 806 | +! |
- normal = h_incidence_rate_normal(person_years, n_events, alpha),+ grid::linesGrob( |
||
| 34 | -18x | +|||
| 807 | +! |
- normal_log = h_incidence_rate_normal_log(person_years, n_events, alpha),+ x = grid::unit(c(xlim[1], ci[2]), "native"), |
||
| 35 | -18x | +|||
| 808 | +! |
- exact = h_incidence_rate_exact(person_years, n_events, alpha),+ y = y, |
||
| 36 | -18x | +|||
| 809 | +! |
- byar = h_incidence_rate_byar(person_years, n_events, alpha)+ arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "first") |
||
| 37 | +810 |
- )+ )+ |
+ ||
| 811 | +! | +
+ } else if (ci[1] >= xlim[1] && ci[2] > xlim[2]) {
|
||
| 38 | +812 |
-
+ # -> |
||
| 39 | -18x | +|||
| 813 | +! |
- num_pt_year <- control$num_pt_year+ grid::linesGrob( |
||
| 40 | -18x | +|||
| 814 | +! |
- list(+ x = grid::unit(c(ci[1], xlim[2]), "native"), |
||
| 41 | -18x | +|||
| 815 | +! |
- rate = est$rate * num_pt_year,+ y = y, |
||
| 42 | -18x | +|||
| 816 | +! |
- rate_ci = est$rate_ci * num_pt_year+ arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "last") |
||
| 43 | +817 |
- )+ ) |
||
| 44 | +818 |
- }+ } |
||
| 45 | +819 |
-
+ } else {
|
||
| 46 | -+ | |||
| 820 | +! |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ NULL |
||
| 47 | +821 |
- #' associated confidence interval based on the normal approximation for the+ } |
||
| 48 | +822 |
- #' incidence rate. Unit is one person-year.+ |
||
| 49 | -+ | |||
| 823 | +3x |
- #'+ g_circle <- if (!is.na(x) && x >= xlim[1] && x <= xlim[2]) {
|
||
| 50 | -+ | |||
| 824 | +3x |
- #' @examples+ grid::circleGrob( |
||
| 51 | -+ | |||
| 825 | +3x |
- #' h_incidence_rate_normal(200, 2)+ x = grid::unit(x, "native"), |
||
| 52 | -+ | |||
| 826 | +3x |
- #'+ y = y, |
||
| 53 | -+ | |||
| 827 | +3x |
- #' @export+ r = grid::unit(1 / 3.5 * symbol_size, "lines"), |
||
| 54 | -+ | |||
| 828 | +3x |
- h_incidence_rate_normal <- function(person_years,+ name = "point" |
||
| 55 | +829 |
- n_events,+ ) |
||
| 56 | +830 |
- alpha = 0.05) {
- |
- ||
| 57 | -14x | -
- checkmate::assert_number(person_years)+ } else {
|
||
| 58 | -14x | +|||
| 831 | +! |
- checkmate::assert_number(n_events)+ NULL |
||
| 59 | -14x | +|||
| 832 | +
- assert_proportion_value(alpha)+ } |
|||
| 60 | +833 | |||
| 61 | -14x | +834 | +3x |
- est <- n_events / person_years+ grid::gTree( |
| 62 | -14x | +835 | +3x |
- se <- sqrt(est / person_years)+ children = grid::gList( |
| 63 | -14x | +836 | +3x |
- ci <- est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * se+ grid::gTree( |
| 64 | -+ | |||
| 837 | +3x |
-
+ children = grid::gList( |
||
| 65 | -14x | +838 | +3x |
- list(rate = est, rate_ci = ci)+ grid::gList( |
| 66 | -+ | |||
| 839 | +3x |
- }+ g_line, |
||
| 67 | -+ | |||
| 840 | +3x |
-
+ g_circle |
||
| 68 | +841 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ ) |
||
| 69 | +842 |
- #' associated confidence interval based on the normal approximation for the+ ), |
||
| 70 | -+ | |||
| 843 | +3x |
- #' logarithm of the incidence rate. Unit is one person-year.+ vp = datavp, |
||
| 71 | -+ | |||
| 844 | +3x |
- #'+ gp = grid::gpar(col = col, fill = col) |
||
| 72 | +845 |
- #' @examples+ ) |
||
| 73 | +846 |
- #' h_incidence_rate_normal_log(200, 2)+ ), |
||
| 74 | -+ | |||
| 847 | +3x |
- #'+ vp = grid::vpPath(paste0("forest-", row_index))
|
||
| 75 | +848 |
- #' @export+ ) |
||
| 76 | +849 |
- h_incidence_rate_normal_log <- function(person_years,+ } else {
|
||
| 77 | -+ | |||
| 850 | +! |
- n_events,+ NULL |
||
| 78 | +851 |
- alpha = 0.05) {
+ } |
||
| 79 | -6x | +|||
| 852 | +
- checkmate::assert_number(person_years)+ } |
|||
| 80 | -6x | +|||
| 853 | +
- checkmate::assert_number(n_events)+ |
|||
| 81 | -6x | +|||
| 854 | +
- assert_proportion_value(alpha)+ #' Create a viewport tree for the forest plot |
|||
| 82 | +855 |
-
+ #' |
||
| 83 | -6x | +|||
| 856 | +
- rate_est <- n_events / person_years+ #' @description `r lifecycle::badge("deprecated")`
|
|||
| 84 | -6x | +|||
| 857 | +
- rate_se <- sqrt(rate_est / person_years)+ #' |
|||
| 85 | -6x | +|||
| 858 | +
- lrate_est <- log(rate_est)+ #' @param tbl (`VTableTree`)\cr `rtables` table object. |
|||
| 86 | -6x | +|||
| 859 | +
- lrate_se <- rate_se / rate_est+ #' @param width_row_names (`grid::unit`)\cr width of row names. |
|||
| 87 | -6x | +|||
| 860 | +
- ci <- exp(lrate_est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * lrate_se)+ #' @param width_columns (`grid::unit`)\cr width of column spans. |
|||
| 88 | +861 |
-
+ #' @param width_forest (`grid::unit`)\cr width of the forest plot. |
||
| 89 | -6x | +|||
| 862 | +
- list(rate = rate_est, rate_ci = ci)+ #' @param gap_column (`grid::unit`)\cr gap width between the columns. |
|||
| 90 | +863 |
- }+ #' @param gap_header (`grid::unit`)\cr gap width between the header. |
||
| 91 | +864 |
-
+ #' @param mat_form (`MatrixPrintForm`)\cr matrix print form of the table. |
||
| 92 | +865 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ #' |
||
| 93 | +866 |
- #' associated exact confidence interval. Unit is one person-year.+ #' @return A viewport tree. |
||
| 94 | +867 |
#' |
||
| 95 | +868 |
#' @examples |
||
| 96 | +869 |
- #' h_incidence_rate_exact(200, 2)+ #' library(grid) |
||
| 97 | +870 |
#' |
||
| 98 | +871 |
- #' @export+ #' tbl <- rtable( |
||
| 99 | +872 |
- h_incidence_rate_exact <- function(person_years,+ #' header = rheader( |
||
| 100 | +873 |
- n_events,+ #' rrow("", "E", rcell("CI", colspan = 2)),
|
||
| 101 | +874 |
- alpha = 0.05) {
- |
- ||
| 102 | -1x | -
- checkmate::assert_number(person_years)+ #' rrow("", "A", "B", "C")
|
||
| 103 | -1x | +|||
| 875 | +
- checkmate::assert_number(n_events)+ #' ), |
|||
| 104 | -1x | +|||
| 876 | +
- assert_proportion_value(alpha)+ #' rrow("row 1", 1, 0.8, 1.1),
|
|||
| 105 | +877 |
-
+ #' rrow("row 2", 1.4, 0.8, 1.6),
|
||
| 106 | -1x | +|||
| 878 | +
- est <- n_events / person_years+ #' rrow("row 3", 1.2, 0.8, 1.2)
|
|||
| 107 | -1x | +|||
| 879 | +
- lcl <- stats::qchisq(p = (alpha) / 2, df = 2 * n_events) / (2 * person_years)+ #' ) |
|||
| 108 | -1x | +|||
| 880 | +
- ucl <- stats::qchisq(p = 1 - (alpha) / 2, df = 2 * n_events + 2) / (2 * person_years)+ #' |
|||
| 109 | +881 |
-
+ #' \donttest{
|
||
| 110 | -1x | +|||
| 882 | +
- list(rate = est, rate_ci = c(lcl, ucl))+ #' v <- forest_viewport(tbl) |
|||
| 111 | +883 |
- }+ #' |
||
| 112 | +884 |
-
+ #' grid::grid.newpage() |
||
| 113 | +885 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ #' showViewport(v) |
||
| 114 | +886 |
- #' associated Byar's confidence interval. Unit is one person-year.+ #' } |
||
| 115 | +887 |
#' |
||
| 116 | +888 |
- #' @examples+ #' @export |
||
| 117 | +889 |
- #' h_incidence_rate_byar(200, 2)+ forest_viewport <- function(tbl, |
||
| 118 | +890 |
- #'+ width_row_names = NULL, |
||
| 119 | +891 |
- #' @export+ width_columns = NULL, |
||
| 120 | +892 |
- h_incidence_rate_byar <- function(person_years,+ width_forest = grid::unit(1, "null"), |
||
| 121 | +893 |
- n_events,+ gap_column = grid::unit(1, "lines"), |
||
| 122 | +894 |
- alpha = 0.05) {
+ gap_header = grid::unit(1, "lines"), |
||
| 123 | -1x | +|||
| 895 | +
- checkmate::assert_number(person_years)+ mat_form = NULL) {
|
|||
| 124 | -1x | +896 | +2x |
- checkmate::assert_number(n_events)+ lifecycle::deprecate_warn( |
| 125 | -1x | -
- assert_proportion_value(alpha)- |
- ||
| 126 | -+ | 897 | +2x |
-
+ "0.9.4", |
| 127 | -1x | +898 | +2x |
- est <- n_events / person_years+ "forest_viewport()", |
| 128 | -1x | +899 | +2x |
- seg_1 <- n_events + 0.5+ details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
| 129 | -1x | +|||
| 900 | +
- seg_2 <- 1 - 1 / (9 * (n_events + 0.5))+ ) |
|||
| 130 | -1x | +|||
| 901 | +
- seg_3 <- stats::qnorm(1 - alpha / 2) * sqrt(1 / (n_events + 0.5)) / 3+ |
|||
| 131 | -1x | +902 | +2x |
- lcl <- seg_1 * ((seg_2 - seg_3)^3) / person_years+ checkmate::assert_class(tbl, "VTableTree") |
| 132 | -1x | +903 | +2x |
- ucl <- seg_1 * ((seg_2 + seg_3)^3) / person_years+ checkmate::assert_true(grid::is.unit(width_forest)) |
| 133 | -+ | |||
| 904 | +2x |
-
+ if (!is.null(width_row_names)) {
|
||
| 134 | -1x | +|||
| 905 | +! |
- list(rate = est, rate_ci = c(lcl, ucl))+ checkmate::assert_true(grid::is.unit(width_row_names)) |
||
| 135 | +906 |
- }+ } |
| 1 | -+ | |||
| 907 | +2x |
- #' Individual patient plots+ if (!is.null(width_columns)) {
|
||
| 2 | -+ | |||
| 908 | +! |
- #'+ checkmate::assert_true(grid::is.unit(width_columns)) |
||
| 3 | +909 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 4 | +910 |
- #'+ |
||
| 5 | -+ | |||
| 911 | +2x |
- #' Line plot(s) displaying trend in patients' parameter values over time is rendered.+ if (is.null(mat_form)) mat_form <- matrix_form(tbl) |
||
| 6 | +912 |
- #' Patients' individual baseline values can be added to the plot(s) as reference.+ |
||
| 7 | -+ | |||
| 913 | +2x |
- #'+ mat_form$strings[!mat_form$display] <- "" |
||
| 8 | +914 |
- #' @inheritParams argument_convention+ |
||
| 9 | -+ | |||
| 915 | +2x |
- #' @param xvar (`string`)\cr time point variable to be plotted on x-axis.+ nr <- nrow(tbl) |
||
| 10 | -+ | |||
| 916 | +2x |
- #' @param yvar (`string`)\cr continuous analysis variable to be plotted on y-axis.+ nc <- ncol(tbl) |
||
| 11 | -+ | |||
| 917 | +2x |
- #' @param xlab (`string`)\cr plot label for x-axis.+ nr_h <- attr(mat_form, "nrow_header") |
||
| 12 | +918 |
- #' @param ylab (`string`)\cr plot label for y-axis.+ |
||
| 13 | -+ | |||
| 919 | +2x |
- #' @param id_var (`string`)\cr variable used as patient identifier.+ if (is.null(width_row_names) || is.null(width_columns)) {
|
||
| 14 | -+ | |||
| 920 | +2x |
- #' @param title (`string`)\cr title for plot.+ tbl_widths <- formatters::propose_column_widths(mat_form) |
||
| 15 | -+ | |||
| 921 | +2x |
- #' @param subtitle (`string`)\cr subtitle for plot.+ strs_with_width <- strrep("x", tbl_widths) # that works for mono spaced fonts
|
||
| 16 | -+ | |||
| 922 | +2x |
- #' @param add_baseline_hline (`flag`)\cr adds horizontal line at baseline y-value on+ if (is.null(width_row_names)) width_row_names <- grid::stringWidth(strs_with_width[1]) |
||
| 17 | -+ | |||
| 923 | +2x |
- #' plot when `TRUE`.+ if (is.null(width_columns)) width_columns <- grid::stringWidth(strs_with_width[-1]) |
||
| 18 | +924 |
- #' @param yvar_baseline (`string`)\cr variable with baseline values only.+ } |
||
| 19 | +925 |
- #' Ignored when `add_baseline_hline` is `FALSE`.+ |
||
| 20 | +926 |
- #' @param ggtheme (`theme`)\cr optional graphical theme function as provided+ # Widths for row name, cols, forest. |
||
| 21 | -+ | |||
| 927 | +2x |
- #' by `ggplot2` to control outlook of plot. Use `ggplot2::theme()` to tweak the display.+ widths <- grid::unit.c( |
||
| 22 | -+ | |||
| 928 | +2x |
- #' @param plotting_choices (`string`)\cr specifies options for displaying+ width_row_names + gap_column, |
||
| 23 | -+ | |||
| 929 | +2x |
- #' plots. Must be one of `"all_in_one"`, `"split_by_max_obs"`, or `"separate_by_obs"`.+ width_columns + gap_column, |
||
| 24 | -+ | |||
| 930 | +2x |
- #' @param max_obs_per_plot (`integer(1)`)\cr number of observations to be plotted on one+ width_forest |
||
| 25 | +931 |
- #' plot. Ignored if `plotting_choices` is not `"separate_by_obs"`.+ ) |
||
| 26 | +932 |
- #' @param caption (`string`)\cr optional caption below the plot.+ |
||
| 27 | -+ | |||
| 933 | +2x |
- #' @param col (`character`)\cr line colors.+ n_lines_per_row <- apply( |
||
| 28 | -+ | |||
| 934 | +2x |
- #'+ X = mat_form$strings, |
||
| 29 | -+ | |||
| 935 | +2x |
- #' @seealso Relevant helper function [h_g_ipp()].+ MARGIN = 1, |
||
| 30 | -+ | |||
| 936 | +2x |
- #'+ FUN = function(row) {
|
||
| 31 | -+ | |||
| 937 | +10x |
- #' @name g_ipp+ tmp <- vapply( |
||
| 32 | -+ | |||
| 938 | +10x |
- #' @aliases individual_patient_plot+ gregexpr("\n", row, fixed = TRUE),
|
||
| 33 | -+ | |||
| 939 | +10x |
- NULL+ attr, numeric(1), |
||
| 34 | -+ | |||
| 940 | +10x |
-
+ "match.length" |
||
| 35 | -+ | |||
| 941 | +10x |
- #' Helper function to create simple line plot over time+ ) + 1 |
||
| 36 | -+ | |||
| 942 | +10x |
- #'+ max(c(tmp, 1)) |
||
| 37 | +943 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 38 | +944 |
- #'+ ) |
||
| 39 | +945 |
- #' Function that generates a simple line plot displaying parameter trends over time.+ |
||
| 40 | -+ | |||
| 946 | +2x |
- #'+ i_header <- seq_len(nr_h) |
||
| 41 | +947 |
- #' @inheritParams argument_convention+ |
||
| 42 | -+ | |||
| 948 | +2x |
- #' @inheritParams g_ipp+ height_body_rows <- grid::unit(n_lines_per_row[-i_header] * 1.2, "lines") |
||
| 43 | -+ | |||
| 949 | +2x |
- #'+ height_header_rows <- grid::unit(n_lines_per_row[i_header] * 1.2, "lines") |
||
| 44 | +950 |
- #' @return A `ggplot` line plot.+ |
||
| 45 | -+ | |||
| 951 | +2x |
- #'+ height_body <- grid::unit(sum(n_lines_per_row[-i_header]) * 1.2, "lines") |
||
| 46 | -+ | |||
| 952 | +2x |
- #' @seealso [g_ipp()] which uses this function.+ height_header <- grid::unit(sum(n_lines_per_row[i_header]) * 1.2, "lines") |
||
| 47 | +953 |
- #'+ |
||
| 48 | -+ | |||
| 954 | +2x |
- #' @examples+ nc_g <- nc + 2 # number of columns incl. row names and forest |
||
| 49 | +955 |
- #' library(dplyr)+ |
||
| 50 | -+ | |||
| 956 | +2x |
- #' library(nestcolor)+ vp_tbl <- grid::vpTree( |
||
| 51 | -+ | |||
| 957 | +2x |
- #'+ parent = grid::viewport( |
||
| 52 | -+ | |||
| 958 | +2x |
- #' # Select a small sample of data to plot.+ name = "vp_table_layout", |
||
| 53 | -+ | |||
| 959 | +2x |
- #' adlb <- tern_ex_adlb %>%+ layout = grid::grid.layout( |
||
| 54 | -+ | |||
| 960 | +2x |
- #' filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
+ nrow = 3, ncol = 1, |
||
| 55 | -+ | |||
| 961 | +2x |
- #' slice(1:36)+ heights = grid::unit.c(height_header, gap_header, height_body) |
||
| 56 | +962 |
- #'+ ) |
||
| 57 | +963 |
- #' p <- h_g_ipp(+ ), |
||
| 58 | -+ | |||
| 964 | +2x |
- #' df = adlb,+ children = grid::vpList( |
||
| 59 | -+ | |||
| 965 | +2x |
- #' xvar = "AVISIT",+ vp_forest_table_part(nr_h, nc_g, 1, 1, widths, height_header_rows, "vp_header"), |
||
| 60 | -+ | |||
| 966 | +2x |
- #' yvar = "AVAL",+ vp_forest_table_part(nr, nc_g, 3, 1, widths, height_body_rows, "vp_body"), |
||
| 61 | -+ | |||
| 967 | +2x |
- #' xlab = "Visit",+ grid::viewport(name = "vp_spacer", layout.pos.row = 2, layout.pos.col = 1) |
||
| 62 | +968 |
- #' id_var = "USUBJID",+ ) |
||
| 63 | +969 |
- #' ylab = "SGOT/ALT (U/L)",+ ) |
||
| 64 | -+ | |||
| 970 | +2x |
- #' add_baseline_hline = TRUE+ vp_tbl |
||
| 65 | +971 |
- #' )+ } |
||
| 66 | +972 |
- #' p+ |
||
| 67 | +973 |
- #'+ #' Viewport forest plot: table part |
||
| 68 | +974 |
- #' @export+ #' |
||
| 69 | +975 |
- h_g_ipp <- function(df,+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 70 | +976 |
- xvar,+ #' |
||
| 71 | +977 |
- yvar,+ #' Prepares a viewport for the table included in the forest plot. |
||
| 72 | +978 |
- xlab,+ #' |
||
| 73 | +979 |
- ylab,+ #' @noRd |
||
| 74 | +980 |
- id_var,+ #' @keywords internal |
||
| 75 | +981 |
- title = "Individual Patient Plots",+ vp_forest_table_part <- function(nrow, |
||
| 76 | +982 |
- subtitle = "",+ ncol, |
||
| 77 | +983 |
- caption = NULL,+ l_row, |
||
| 78 | +984 |
- add_baseline_hline = FALSE,+ l_col, |
||
| 79 | +985 |
- yvar_baseline = "BASE",+ widths, |
||
| 80 | +986 |
- ggtheme = nestcolor::theme_nest(),+ heights, |
||
| 81 | +987 |
- col = NULL) {
- |
- ||
| 82 | -13x | -
- checkmate::assert_string(xvar)+ name) {
|
||
| 83 | -13x | +988 | +4x |
- checkmate::assert_string(yvar)+ lifecycle::deprecate_warn( |
| 84 | -13x | +989 | +4x |
- checkmate::assert_string(yvar_baseline)+ "0.9.4", "vp_forest_table_part()", |
| 85 | -13x | +990 | +4x |
- checkmate::assert_string(id_var)+ details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
| 86 | -13x | +|||
| 991 | +
- checkmate::assert_string(xlab)+ ) |
|||
| 87 | -13x | +|||
| 992 | +
- checkmate::assert_string(ylab)+ |
|||
| 88 | -13x | +993 | +4x |
- checkmate::assert_string(title)+ grid::vpTree( |
| 89 | -13x | +994 | +4x |
- checkmate::assert_string(subtitle)+ grid::viewport( |
| 90 | -13x | +995 | +4x |
- checkmate::assert_subset(c(xvar, yvar, yvar_baseline, id_var), colnames(df))+ name = name, |
| 91 | -13x | +996 | +4x |
- checkmate::assert_data_frame(df)+ layout.pos.row = l_row, |
| 92 | -13x | +997 | +4x |
- checkmate::assert_flag(add_baseline_hline)+ layout.pos.col = l_col, |
| 93 | -13x | +998 | +4x |
- checkmate::assert_character(col, null.ok = TRUE)+ layout = grid::grid.layout(nrow = nrow, ncol = ncol, widths = widths, heights = heights) |
| 94 | +999 |
-
+ ), |
||
| 95 | -13x | +1000 | +4x |
- p <- ggplot2::ggplot(+ children = grid::vpList( |
| 96 | -13x | +1001 | +4x |
- data = df,+ do.call( |
| 97 | -13x | +1002 | +4x |
- mapping = ggplot2::aes(+ grid::vpList, |
| 98 | -13x | +1003 | +4x |
- x = .data[[xvar]],+ lapply( |
| 99 | -13x | +1004 | +4x |
- y = .data[[yvar]],+ seq_len(nrow), function(i) {
|
| 100 | -13x | +1005 | +10x |
- group = .data[[id_var]],+ grid::viewport(layout.pos.row = i, layout.pos.col = 1, name = paste0("rowname-", i))
|
| 101 | -13x | +|||
| 1006 | +
- colour = .data[[id_var]]+ } |
|||
| 102 | +1007 |
- )+ ) |
||
| 103 | +1008 |
- ) ++ ), |
||
| 104 | -13x | +1009 | +4x |
- ggplot2::geom_line(linewidth = 0.4) ++ do.call( |
| 105 | -13x | +1010 | +4x |
- ggplot2::geom_point(size = 2) ++ grid::vpList, |
| 106 | -13x | +1011 | +4x |
- ggplot2::labs(+ apply( |
| 107 | -13x | +1012 | +4x |
- x = xlab,+ expand.grid(seq_len(nrow), seq_len(ncol - 2)), |
| 108 | -13x | +1013 | +4x |
- y = ylab,+ 1, |
| 109 | -13x | +1014 | +4x |
- title = title,+ function(x) {
|
| 110 | -13x | +1015 | +35x |
- subtitle = subtitle,+ i <- x[1] |
| 111 | -13x | -
- caption = caption- |
- ||
| 112 | -+ | 1016 | +35x |
- ) ++ j <- x[2] |
| 113 | -13x | +1017 | +35x |
- ggtheme+ grid::viewport(layout.pos.row = i, layout.pos.col = j + 1, name = paste0("cell-", i, "-", j))
|
| 114 | +1018 | - - | -||
| 115 | -13x | -
- if (add_baseline_hline) {
- |
- ||
| 116 | -12x | -
- baseline_df <- df[, c(id_var, yvar_baseline)]+ } |
||
| 117 | -12x | +|||
| 1019 | +
- baseline_df <- unique(baseline_df)+ ) |
|||
| 118 | +1020 |
-
+ ), |
||
| 119 | -12x | +1021 | +4x |
- p <- p ++ do.call( |
| 120 | -12x | +1022 | +4x |
- ggplot2::geom_hline(+ grid::vpList, |
| 121 | -12x | +1023 | +4x |
- data = baseline_df,+ lapply( |
| 122 | -12x | +1024 | +4x |
- mapping = ggplot2::aes(+ seq_len(nrow), |
| 123 | -12x | +1025 | +4x |
- yintercept = .data[[yvar_baseline]],+ function(i) {
|
| 124 | -12x | +1026 | +10x |
- colour = .data[[id_var]]+ grid::viewport(layout.pos.row = i, layout.pos.col = ncol, name = paste0("forest-", i))
|
| 125 | +1027 |
- ),- |
- ||
| 126 | -12x | -
- linetype = "dotdash",+ } |
||
| 127 | -12x | +|||
| 1028 | +
- linewidth = 0.4+ ) |
|||
| 128 | +1029 |
- ) ++ ) |
||
| 129 | -12x | +|||
| 1030 | +
- ggplot2::geom_text(+ ) |
|||
| 130 | -12x | +|||
| 1031 | +
- data = baseline_df,+ ) |
|||
| 131 | -12x | +|||
| 1032 | +
- mapping = ggplot2::aes(+ } |
|||
| 132 | -12x | +|||
| 1033 | +
- x = 1,+ |
|||
| 133 | -12x | +|||
| 1034 | +
- y = .data[[yvar_baseline]],+ #' Forest rendering |
|||
| 134 | -12x | +|||
| 1035 | +
- label = .data[[id_var]],+ #' |
|||
| 135 | -12x | +|||
| 1036 | +
- colour = .data[[id_var]]+ #' @description `r lifecycle::badge("deprecated")`
|
|||
| 136 | +1037 |
- ),+ #' |
||
| 137 | -12x | +|||
| 1038 | +
- nudge_y = 0.025 * (max(df[, yvar], na.rm = TRUE) - min(df[, yvar], na.rm = TRUE)),+ #' Renders the forest grob. |
|||
| 138 | -12x | +|||
| 1039 | +
- vjust = "right",+ #' |
|||
| 139 | -12x | +|||
| 1040 | +
- size = 2+ #' @noRd |
|||
| 140 | +1041 |
- )+ #' @keywords internal |
||
| 141 | +1042 |
-
+ grid.forest <- function(...) { # nolint
|
||
| 142 | -12x | +|||
| 1043 | +! |
- if (!is.null(col)) {
+ lifecycle::deprecate_warn( |
||
| 143 | -1x | +|||
| 1044 | +! |
- p <- p ++ "0.9.4", "grid.forest()", |
||
| 144 | -1x | +|||
| 1045 | +! |
- ggplot2::scale_color_manual(values = col)+ details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
||
| 145 | +1046 |
- }+ ) |
||
| 146 | +1047 |
- }+ |
||
| 147 | -13x | +|||
| 1048 | +! |
- p+ grid::grid.draw(forest_grob(...)) |
||
| 148 | +1049 |
} |
| 149 | +1 |
-
+ #' Helper functions for multivariate logistic regression |
||
| 150 | +2 |
- #' @describeIn g_ipp Plotting function for individual patient plots which, depending on user+ #' |
||
| 151 | +3 |
- #' preference, renders a single graphic or compiles a list of graphics that show trends in individual's parameter+ #' @description `r lifecycle::badge("stable")`
|
||
| 152 | +4 |
- #' values over time.+ #' |
||
| 153 | +5 |
- #'+ #' Helper functions used in calculations for logistic regression. |
||
| 154 | +6 |
- #' @return A `ggplot` object or a list of `ggplot` objects.+ #' |
||
| 155 | +7 |
- #'+ #' @inheritParams argument_convention |
||
| 156 | +8 |
- #' @examples+ #' @param fit_glm (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family. |
||
| 157 | +9 |
- #' library(dplyr)+ #' Limited functionality is also available for conditional logistic regression models fitted by |
||
| 158 | +10 |
- #' library(nestcolor)+ #' [survival::clogit()], currently this is used only by [extract_rsp_biomarkers()]. |
||
| 159 | +11 |
- #'+ #' @param x (`character`)\cr a variable or interaction term in `fit_glm` (depending on the helper function used). |
||
| 160 | +12 |
- #' # Select a small sample of data to plot.+ #' |
||
| 161 | +13 |
- #' adlb <- tern_ex_adlb %>%+ #' @examples |
||
| 162 | +14 |
- #' filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
+ #' library(dplyr) |
||
| 163 | +15 |
- #' slice(1:36)+ #' library(broom) |
||
| 164 | +16 |
#' |
||
| 165 | +17 |
- #' plot_list <- g_ipp(+ #' adrs_f <- tern_ex_adrs %>% |
||
| 166 | +18 |
- #' df = adlb,+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 167 | +19 |
- #' xvar = "AVISIT",+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
|
||
| 168 | +20 |
- #' yvar = "AVAL",+ #' mutate( |
||
| 169 | +21 |
- #' xlab = "Visit",+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
||
| 170 | +22 |
- #' ylab = "SGOT/ALT (U/L)",+ #' RACE = factor(RACE), |
||
| 171 | +23 |
- #' title = "Individual Patient Plots",+ #' SEX = factor(SEX) |
||
| 172 | +24 |
- #' add_baseline_hline = TRUE,+ #' ) |
||
| 173 | +25 |
- #' plotting_choices = "split_by_max_obs",+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
||
| 174 | +26 |
- #' max_obs_per_plot = 5+ #' mod1 <- fit_logistic( |
||
| 175 | +27 |
- #' )+ #' data = adrs_f, |
||
| 176 | +28 |
- #' plot_list+ #' variables = list( |
||
| 177 | +29 |
- #'+ #' response = "Response", |
||
| 178 | +30 |
- #' @export+ #' arm = "ARMCD", |
||
| 179 | +31 |
- g_ipp <- function(df,+ #' covariates = c("AGE", "RACE")
|
||
| 180 | +32 |
- xvar,+ #' ) |
||
| 181 | +33 |
- yvar,+ #' ) |
||
| 182 | +34 |
- xlab,+ #' mod2 <- fit_logistic( |
||
| 183 | +35 |
- ylab,+ #' data = adrs_f, |
||
| 184 | +36 |
- id_var = "USUBJID",+ #' variables = list( |
||
| 185 | +37 |
- title = "Individual Patient Plots",+ #' response = "Response", |
||
| 186 | +38 |
- subtitle = "",+ #' arm = "ARMCD", |
||
| 187 | +39 |
- caption = NULL,+ #' covariates = c("AGE", "RACE"),
|
||
| 188 | +40 |
- add_baseline_hline = FALSE,+ #' interaction = "AGE" |
||
| 189 | +41 |
- yvar_baseline = "BASE",+ #' ) |
||
| 190 | +42 |
- ggtheme = nestcolor::theme_nest(),+ #' ) |
||
| 191 | +43 |
- plotting_choices = c("all_in_one", "split_by_max_obs", "separate_by_obs"),
+ #' |
||
| 192 | +44 |
- max_obs_per_plot = 4,+ #' @name h_logistic_regression |
||
| 193 | +45 |
- col = NULL) {
- |
- ||
| 194 | -3x | -
- checkmate::assert_count(max_obs_per_plot)- |
- ||
| 195 | -3x | -
- checkmate::assert_subset(plotting_choices, c("all_in_one", "split_by_max_obs", "separate_by_obs"))
- |
- ||
| 196 | -3x | -
- checkmate::assert_character(col, null.ok = TRUE)+ NULL |
||
| 197 | +46 | |||
| 198 | -3x | -
- plotting_choices <- match.arg(plotting_choices)- |
- ||
| 199 | +47 |
-
+ #' @describeIn h_logistic_regression Helper function to extract interaction variable names from a fitted |
||
| 200 | -3x | +|||
| 48 | +
- if (plotting_choices == "all_in_one") {
+ #' model assuming only one interaction term. |
|||
| 201 | -1x | +|||
| 49 | +
- p <- h_g_ipp(+ #' |
|||
| 202 | -1x | +|||
| 50 | +
- df = df,+ #' @return Vector of names of interaction variables. |
|||
| 203 | -1x | +|||
| 51 | +
- xvar = xvar,+ #' |
|||
| 204 | -1x | +|||
| 52 | +
- yvar = yvar,+ #' @export |
|||
| 205 | -1x | +|||
| 53 | +
- xlab = xlab,+ h_get_interaction_vars <- function(fit_glm) {
|
|||
| 206 | -1x | +54 | +34x |
- ylab = ylab,+ checkmate::assert_class(fit_glm, "glm") |
| 207 | -1x | +55 | +34x |
- id_var = id_var,+ terms_name <- attr(stats::terms(fit_glm), "term.labels") |
| 208 | -1x | +56 | +34x |
- title = title,+ terms_order <- attr(stats::terms(fit_glm), "order") |
| 209 | -1x | +57 | +34x |
- subtitle = subtitle,+ interaction_term <- terms_name[terms_order == 2] |
| 210 | -1x | +58 | +34x |
- caption = caption,+ checkmate::assert_string(interaction_term) |
| 211 | -1x | +59 | +34x |
- add_baseline_hline = add_baseline_hline,+ strsplit(interaction_term, split = ":")[[1]] |
| 212 | -1x | +|||
| 60 | +
- yvar_baseline = yvar_baseline,+ } |
|||
| 213 | -1x | +|||
| 61 | +
- ggtheme = ggtheme,+ |
|||
| 214 | -1x | +|||
| 62 | +
- col = col+ #' @describeIn h_logistic_regression Helper function to get the right coefficient name from the |
|||
| 215 | +63 |
- )+ #' interaction variable names and the given levels. The main value here is that the order |
||
| 216 | +64 |
-
+ #' of first and second variable is checked in the `interaction_vars` input. |
||
| 217 | -1x | +|||
| 65 | +
- return(p)+ #' |
|||
| 218 | -2x | +|||
| 66 | +
- } else if (plotting_choices == "split_by_max_obs") {
+ #' @param interaction_vars (`character(2)`)\cr interaction variable names. |
|||
| 219 | -1x | +|||
| 67 | +
- id_vec <- unique(df[[id_var]])+ #' @param first_var_with_level (`character(2)`)\cr the first variable name with the interaction level. |
|||
| 220 | -1x | +|||
| 68 | +
- id_list <- split(+ #' @param second_var_with_level (`character(2)`)\cr the second variable name with the interaction level. |
|||
| 221 | -1x | +|||
| 69 | +
- id_vec,+ #' |
|||
| 222 | -1x | +|||
| 70 | +
- rep(1:ceiling(length(id_vec) / max_obs_per_plot),+ #' @return Name of coefficient. |
|||
| 223 | -1x | +|||
| 71 | +
- each = max_obs_per_plot,+ #' |
|||
| 224 | -1x | +|||
| 72 | +
- length.out = length(id_vec)+ #' @export |
|||
| 225 | +73 |
- )+ h_interaction_coef_name <- function(interaction_vars, |
||
| 226 | +74 |
- )+ first_var_with_level, |
||
| 227 | +75 |
-
+ second_var_with_level) {
|
||
| 228 | -1x | +76 | +55x |
- df_list <- list()+ checkmate::assert_character(interaction_vars, len = 2, any.missing = FALSE) |
| 229 | -1x | -
- plot_list <- list()- |
- ||
| 230 | -+ | 77 | +55x |
-
+ checkmate::assert_character(first_var_with_level, len = 2, any.missing = FALSE) |
| 231 | -1x | +78 | +55x |
- for (i in seq_along(id_list)) {
+ checkmate::assert_character(second_var_with_level, len = 2, any.missing = FALSE) |
| 232 | -2x | +79 | +55x |
- df_list[[i]] <- df[df[[id_var]] %in% id_list[[i]], ]+ checkmate::assert_subset(c(first_var_with_level[1], second_var_with_level[1]), interaction_vars) |
| 233 | +80 | |||
| 234 | -2x | +81 | +55x |
- plots <- h_g_ipp(+ first_name <- paste(first_var_with_level, collapse = "") |
| 235 | -2x | +82 | +55x |
- df = df_list[[i]],+ second_name <- paste(second_var_with_level, collapse = "") |
| 236 | -2x | +83 | +55x |
- xvar = xvar,+ if (first_var_with_level[1] == interaction_vars[1]) {
|
| 237 | -2x | +84 | +36x |
- yvar = yvar,+ paste(first_name, second_name, sep = ":") |
| 238 | -2x | +85 | +19x |
- xlab = xlab,+ } else if (second_var_with_level[1] == interaction_vars[1]) {
|
| 239 | -2x | +86 | +19x |
- ylab = ylab,+ paste(second_name, first_name, sep = ":") |
| 240 | -2x | +|||
| 87 | +
- id_var = id_var,+ } |
|||
| 241 | -2x | +|||
| 88 | +
- title = title,+ } |
|||
| 242 | -2x | +|||
| 89 | +
- subtitle = subtitle,+ |
|||
| 243 | -2x | +|||
| 90 | +
- caption = caption,+ #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates |
|||
| 244 | -2x | +|||
| 91 | +
- add_baseline_hline = add_baseline_hline,+ #' for the case when both the odds ratio and the interaction variable are categorical. |
|||
| 245 | -2x | +|||
| 92 | +
- yvar_baseline = yvar_baseline,+ #' |
|||
| 246 | -2x | +|||
| 93 | +
- ggtheme = ggtheme,+ #' @param odds_ratio_var (`string`)\cr the odds ratio variable. |
|||
| 247 | -2x | +|||
| 94 | +
- col = col+ #' @param interaction_var (`string`)\cr the interaction variable. |
|||
| 248 | +95 |
- )+ #' |
||
| 249 | +96 |
-
+ #' @return Odds ratio. |
||
| 250 | -2x | +|||
| 97 | +
- plot_list[[i]] <- plots+ #' |
|||
| 251 | +98 |
- }+ #' @export |
||
| 252 | -1x | +|||
| 99 | +
- return(plot_list)+ h_or_cat_interaction <- function(odds_ratio_var, |
|||
| 253 | +100 |
- } else {
+ interaction_var, |
||
| 254 | -1x | +|||
| 101 | +
- ind_df <- split(df, df[[id_var]])+ fit_glm, |
|||
| 255 | -1x | +|||
| 102 | +
- plot_list <- lapply(+ conf_level = 0.95) {
|
|||
| 256 | -1x | +103 | +8x |
- ind_df,+ interaction_vars <- h_get_interaction_vars(fit_glm) |
| 257 | -1x | +104 | +8x |
- function(x) {
+ checkmate::assert_string(odds_ratio_var) |
| 258 | +105 | 8x |
- h_g_ipp(+ checkmate::assert_string(interaction_var) |
|
| 259 | +106 | 8x |
- df = x,+ checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars) |
|
| 260 | +107 | 8x |
- xvar = xvar,+ checkmate::assert_vector(interaction_vars, len = 2) |
|
| 261 | -8x | +|||
| 108 | +
- yvar = yvar,+ |
|||
| 262 | +109 | 8x |
- xlab = xlab,+ xs_level <- fit_glm$xlevels |
|
| 263 | +110 | 8x |
- ylab = ylab,+ xs_coef <- stats::coef(fit_glm) |
|
| 264 | +111 | 8x |
- id_var = id_var,+ xs_vcov <- stats::vcov(fit_glm) |
|
| 265 | +112 | 8x |
- title = title,+ y <- list() |
|
| 266 | +113 | 8x |
- subtitle = subtitle,+ for (var_level in xs_level[[odds_ratio_var]][-1]) {
|
|
| 267 | -8x | +114 | +14x |
- caption = caption,+ x <- list() |
| 268 | -8x | +115 | +14x |
- add_baseline_hline = add_baseline_hline,+ for (ref_level in xs_level[[interaction_var]]) {
|
| 269 | -8x | +116 | +38x |
- yvar_baseline = yvar_baseline,+ coef_names <- paste0(odds_ratio_var, var_level) |
| 270 | -8x | +117 | +38x |
- ggtheme = ggtheme,+ if (ref_level != xs_level[[interaction_var]][1]) {
|
| 271 | -8x | +118 | +24x |
- col = col+ interaction_coef_name <- h_interaction_coef_name( |
| 272 | -+ | |||
| 119 | +24x |
- )+ interaction_vars, |
||
| 273 | -+ | |||
| 120 | +24x |
- }+ c(odds_ratio_var, var_level), |
||
| 274 | -+ | |||
| 121 | +24x |
- )+ c(interaction_var, ref_level) |
||
| 275 | +122 |
-
+ ) |
||
| 276 | -1x | +123 | +24x |
- return(plot_list)+ coef_names <- c( |
| 277 | -+ | |||
| 124 | +24x |
- }+ coef_names, |
||
| 278 | -+ | |||
| 125 | +24x |
- }+ interaction_coef_name |
| 1 | +126 |
- #' Control functions for Kaplan-Meier plot annotation tables+ ) |
||
| 2 | +127 |
- #'+ } |
||
| 3 | -+ | |||
| 128 | +38x |
- #' @description `r lifecycle::badge("stable")`
+ if (length(coef_names) > 1) {
|
||
| 4 | -+ | |||
| 129 | +24x |
- #'+ ones <- t(c(1, 1)) |
||
| 5 | -+ | |||
| 130 | +24x |
- #' Auxiliary functions for controlling arguments for formatting the annotation tables that can be added to plots+ est <- as.numeric(ones %*% xs_coef[coef_names]) |
||
| 6 | -+ | |||
| 131 | +24x |
- #' generated via [g_km()].+ se <- sqrt(as.numeric(ones %*% xs_vcov[coef_names, coef_names] %*% t(ones))) |
||
| 7 | +132 |
- #'+ } else {
|
||
| 8 | -+ | |||
| 133 | +14x |
- #' @param x (`proportion`)\cr x-coordinate for center of annotation table.+ est <- xs_coef[coef_names] |
||
| 9 | -+ | |||
| 134 | +14x |
- #' @param y (`proportion`)\cr y-coordinate for center of annotation table.+ se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names])) |
||
| 10 | +135 |
- #' @param w (`proportion`)\cr relative width of the annotation table.+ } |
||
| 11 | -+ | |||
| 136 | +38x |
- #' @param h (`proportion`)\cr relative height of the annotation table.+ or <- exp(est) |
||
| 12 | -+ | |||
| 137 | +38x |
- #' @param fill (`flag` or `character`)\cr whether the annotation table should have a background fill color.+ ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se) |
||
| 13 | -+ | |||
| 138 | +38x |
- #' Can also be a color code to use as the background fill color. If `TRUE`, color code defaults to `"#00000020"`.+ x[[ref_level]] <- list(or = or, ci = ci) |
||
| 14 | +139 |
- #'+ } |
||
| 15 | -+ | |||
| 140 | +14x |
- #' @return A list of components with the same names as the arguments.+ y[[var_level]] <- x |
||
| 16 | +141 |
- #'+ } |
||
| 17 | -+ | |||
| 142 | +8x |
- #' @seealso [g_km()]+ y |
||
| 18 | +143 |
- #'+ } |
||
| 19 | +144 |
- #' @name control_annot+ |
||
| 20 | +145 |
- NULL+ #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates |
||
| 21 | +146 |
-
+ #' for the case when either the odds ratio or the interaction variable is continuous. |
||
| 22 | +147 |
- #' @describeIn control_annot Control function for formatting the median survival time annotation table. This annotation+ #' |
||
| 23 | +148 |
- #' table can be added in [g_km()] by setting `annot_surv_med=TRUE`, and can be configured using the+ #' @param at (`numeric` or `NULL`)\cr optional values for the interaction variable. Otherwise |
||
| 24 | +149 |
- #' `control_surv_med_annot()` function by setting it as the `control_annot_surv_med` argument.+ #' the median is used. |
||
| 25 | +150 |
#' |
||
| 26 | -- |
- #' @examples- |
- ||
| 27 | +151 |
- #' control_surv_med_annot()+ #' @return Odds ratio. |
||
| 28 | +152 |
#' |
||
| 29 | -- |
- #' @export- |
- ||
| 30 | +153 |
- control_surv_med_annot <- function(x = 0.8, y = 0.85, w = 0.32, h = 0.16, fill = TRUE) {
- |
- ||
| 31 | -22x | -
- assert_proportion_value(x)- |
- ||
| 32 | -22x | -
- assert_proportion_value(y)- |
- ||
| 33 | -22x | -
- assert_proportion_value(w)- |
- ||
| 34 | -22x | -
- assert_proportion_value(h)+ #' @note We don't provide a function for the case when both variables are continuous because |
||
| 35 | +154 | - - | -||
| 36 | -22x | -
- list(x = x, y = y, w = w, h = h, fill = fill)+ #' this does not arise in this table, as the treatment arm variable will always be involved |
||
| 37 | +155 |
- }+ #' and categorical. |
||
| 38 | +156 |
-
+ #' |
||
| 39 | +157 |
- #' @describeIn control_annot Control function for formatting the Cox-PH annotation table. This annotation table can be+ #' @export |
||
| 40 | +158 |
- #' added in [g_km()] by setting `annot_coxph=TRUE`, and can be configured using the `control_coxph_annot()` function+ h_or_cont_interaction <- function(odds_ratio_var, |
||
| 41 | +159 |
- #' by setting it as the `control_annot_coxph` argument.+ interaction_var, |
||
| 42 | +160 |
- #'+ fit_glm, |
||
| 43 | +161 |
- #' @param ref_lbls (`flag`)\cr whether the reference group should be explicitly printed in labels for the+ at = NULL, |
||
| 44 | +162 |
- #' annotation table. If `FALSE` (default), only comparison groups will be printed in the table labels.+ conf_level = 0.95) {
|
||
| 45 | -+ | |||
| 163 | +13x |
- #'+ interaction_vars <- h_get_interaction_vars(fit_glm) |
||
| 46 | -+ | |||
| 164 | +13x |
- #' @examples+ checkmate::assert_string(odds_ratio_var) |
||
| 47 | -+ | |||
| 165 | +13x |
- #' control_coxph_annot()+ checkmate::assert_string(interaction_var) |
||
| 48 | -+ | |||
| 166 | +13x |
- #'+ checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars) |
||
| 49 | -+ | |||
| 167 | +13x |
- #' @export+ checkmate::assert_vector(interaction_vars, len = 2) |
||
| 50 | -+ | |||
| 168 | +13x |
- control_coxph_annot <- function(x = 0.29, y = 0.51, w = 0.4, h = 0.125, fill = TRUE, ref_lbls = FALSE) {
+ checkmate::assert_numeric(at, min.len = 1, null.ok = TRUE, any.missing = FALSE) |
||
| 51 | -11x | +169 | +13x |
- checkmate::assert_logical(ref_lbls, any.missing = FALSE)+ xs_level <- fit_glm$xlevels |
| 52 | -+ | |||
| 170 | +13x |
-
+ xs_coef <- stats::coef(fit_glm) |
||
| 53 | -11x | +171 | +13x |
- res <- c(control_surv_med_annot(x = x, y = y, w = w, h = h), list(ref_lbls = ref_lbls))+ xs_vcov <- stats::vcov(fit_glm) |
| 54 | -11x | +172 | +13x |
- res+ xs_class <- attr(fit_glm$terms, "dataClasses") |
| 55 | -+ | |||
| 173 | +13x |
- }+ model_data <- fit_glm$model |
||
| 56 | -+ | |||
| 174 | +13x |
-
+ if (!is.null(at)) {
|
||
| 57 | -+ | |||
| 175 | +3x |
- #' Helper function to calculate x-tick positions+ checkmate::assert_set_equal(xs_class[interaction_var], "numeric") |
||
| 58 | +176 |
- #'+ } |
||
| 59 | -+ | |||
| 177 | +12x |
- #' @description `r lifecycle::badge("stable")`
+ y <- list() |
||
| 60 | -+ | |||
| 178 | +12x |
- #'+ if (xs_class[interaction_var] == "numeric") {
|
||
| 61 | -+ | |||
| 179 | +7x |
- #' Calculate the positions of ticks on the x-axis. However, if `xticks` already+ if (is.null(at)) {
|
||
| 62 | -+ | |||
| 180 | +5x |
- #' exists it is kept as is. It is based on the same function `ggplot2` relies on,+ at <- ceiling(stats::median(model_data[[interaction_var]])) |
||
| 63 | +181 |
- #' and is required in the graphic and the patient-at-risk annotation table.+ } |
||
| 64 | +182 |
- #'+ |
||
| 65 | -+ | |||
| 183 | +7x |
- #' @inheritParams g_km+ for (var_level in xs_level[[odds_ratio_var]][-1]) {
|
||
| 66 | -+ | |||
| 184 | +14x |
- #' @inheritParams h_ggkm+ x <- list() |
||
| 67 | -+ | |||
| 185 | +14x |
- #'+ for (increment in at) {
|
||
| 68 | -+ | |||
| 186 | +20x |
- #' @return A vector of positions to use for x-axis ticks on a `ggplot` object.+ coef_names <- paste0(odds_ratio_var, var_level) |
||
| 69 | -+ | |||
| 187 | +20x |
- #'+ if (increment != 0) {
|
||
| 70 | -+ | |||
| 188 | +20x |
- #' @examples+ interaction_coef_name <- h_interaction_coef_name( |
||
| 71 | -+ | |||
| 189 | +20x |
- #' library(dplyr)+ interaction_vars, |
||
| 72 | -+ | |||
| 190 | +20x |
- #' library(survival)+ c(odds_ratio_var, var_level), |
||
| 73 | -+ | |||
| 191 | +20x |
- #'+ c(interaction_var, "") |
||
| 74 | +192 |
- #' data <- tern_ex_adtte %>%+ ) |
||
| 75 | -+ | |||
| 193 | +20x |
- #' filter(PARAMCD == "OS") %>%+ coef_names <- c( |
||
| 76 | -+ | |||
| 194 | +20x |
- #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ coef_names, |
||
| 77 | -+ | |||
| 195 | +20x |
- #' h_data_plot()+ interaction_coef_name |
||
| 78 | +196 |
- #'+ ) |
||
| 79 | +197 |
- #' h_xticks(data)+ } |
||
| 80 | -+ | |||
| 198 | +20x |
- #' h_xticks(data, xticks = seq(0, 3000, 500))+ if (length(coef_names) > 1) {
|
||
| 81 | -+ | |||
| 199 | +20x |
- #' h_xticks(data, xticks = 500)+ xvec <- t(c(1, increment)) |
||
| 82 | -+ | |||
| 200 | +20x |
- #' h_xticks(data, xticks = 500, max_time = 6000)+ est <- as.numeric(xvec %*% xs_coef[coef_names]) |
||
| 83 | -+ | |||
| 201 | +20x |
- #' h_xticks(data, xticks = c(0, 500), max_time = 300)+ se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec))) |
||
| 84 | +202 |
- #' h_xticks(data, xticks = 500, max_time = 300)+ } else {
|
||
| 85 | -+ | |||
| 203 | +! |
- #'+ est <- xs_coef[coef_names] |
||
| 86 | -+ | |||
| 204 | +! |
- #' @export+ se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names])) |
||
| 87 | +205 |
- h_xticks <- function(data, xticks = NULL, max_time = NULL) {
+ } |
||
| 88 | -18x | +206 | +20x |
- if (is.null(xticks)) {
+ or <- exp(est) |
| 89 | -13x | +207 | +20x |
- if (is.null(max_time)) {
+ ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se) |
| 90 | -11x | +208 | +20x |
- labeling::extended(range(data$time)[1], range(data$time)[2], m = 5)+ x[[as.character(increment)]] <- list(or = or, ci = ci) |
| 91 | +209 |
- } else {
+ } |
||
| 92 | -2x | +210 | +14x |
- labeling::extended(range(data$time)[1], max(range(data$time)[2], max_time), m = 5)+ y[[var_level]] <- x |
| 93 | +211 |
} |
||
| 94 | -5x | +|||
| 212 | +
- } else if (checkmate::test_number(xticks)) {
+ } else {
|
|||
| 95 | -2x | +213 | +5x |
- if (is.null(max_time)) {
+ checkmate::assert_set_equal(xs_class[odds_ratio_var], "numeric") |
| 96 | -1x | +214 | +5x |
- seq(0, max(data$time), xticks)+ checkmate::assert_set_equal(xs_class[interaction_var], "factor") |
| 97 | -+ | |||
| 215 | +5x |
- } else {
+ for (var_level in xs_level[[interaction_var]]) {
|
||
| 98 | -1x | +216 | +15x |
- seq(0, max(data$time, max_time), xticks)+ coef_names <- odds_ratio_var |
| 99 | -+ | |||
| 217 | +15x |
- }+ if (var_level != xs_level[[interaction_var]][1]) {
|
||
| 100 | -3x | +218 | +10x |
- } else if (is.numeric(xticks)) {
+ interaction_coef_name <- h_interaction_coef_name( |
| 101 | -2x | +219 | +10x |
- xticks+ interaction_vars, |
| 102 | -+ | |||
| 220 | +10x |
- } else {
+ c(odds_ratio_var, ""), |
||
| 103 | -1x | +221 | +10x |
- stop(+ c(interaction_var, var_level) |
| 104 | -1x | +|||
| 222 | +
- paste(+ ) |
|||
| 105 | -1x | +223 | +10x |
- "xticks should be either `NULL`",+ coef_names <- c( |
| 106 | -1x | +224 | +10x |
- "or a single number (interval between x ticks)",+ coef_names, |
| 107 | -1x | +225 | +10x |
- "or a numeric vector (position of ticks on the x axis)"+ interaction_coef_name |
| 108 | +226 |
- )+ ) |
||
| 109 | +227 |
- )+ } |
||
| 110 | -+ | |||
| 228 | +15x |
- }+ if (length(coef_names) > 1) {
|
||
| 111 | -+ | |||
| 229 | +10x |
- }+ xvec <- t(c(1, 1)) |
||
| 112 | -+ | |||
| 230 | +10x |
-
+ est <- as.numeric(xvec %*% xs_coef[coef_names])+ |
+ ||
| 231 | +10x | +
+ se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec))) |
||
| 113 | +232 |
- #' Helper function for survival estimations+ } else {
+ |
+ ||
| 233 | +5x | +
+ est <- xs_coef[coef_names]+ |
+ ||
| 234 | +5x | +
+ se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names])) |
||
| 114 | +235 |
- #'+ } |
||
| 115 | -+ | |||
| 236 | +15x |
- #' @description `r lifecycle::badge("stable")`
+ or <- exp(est) |
||
| 116 | -+ | |||
| 237 | +15x |
- #'+ ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se) |
||
| 117 | -+ | |||
| 238 | +15x |
- #' Transform a survival fit to a table with groups in rows characterized by N, median and confidence interval.+ y[[var_level]] <- list(or = or, ci = ci) |
||
| 118 | +239 |
- #'+ } |
||
| 119 | +240 |
- #' @inheritParams h_data_plot+ } |
||
| 120 | -+ | |||
| 241 | +12x |
- #'+ y |
||
| 121 | +242 |
- #' @return A summary table with statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`).+ } |
||
| 122 | +243 |
- #'+ |
||
| 123 | +244 |
- #' @examples+ #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates |
||
| 124 | +245 |
- #' library(dplyr)+ #' in case of an interaction. This is a wrapper for [h_or_cont_interaction()] and |
||
| 125 | +246 |
- #' library(survival)+ #' [h_or_cat_interaction()]. |
||
| 126 | +247 |
#' |
||
| 127 | +248 |
- #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "OS")+ #' @return Odds ratio. |
||
| 128 | +249 |
- #' fit <- survfit(+ #' |
||
| 129 | +250 |
- #' formula = Surv(AVAL, 1 - CNSR) ~ ARMCD,+ #' @export |
||
| 130 | +251 |
- #' data = adtte+ h_or_interaction <- function(odds_ratio_var, |
||
| 131 | +252 |
- #' )+ interaction_var, |
||
| 132 | +253 |
- #' h_tbl_median_surv(fit_km = fit)+ fit_glm, |
||
| 133 | +254 |
- #'+ at = NULL, |
||
| 134 | +255 |
- #' @export+ conf_level = 0.95) {
|
||
| 135 | -+ | |||
| 256 | +15x |
- h_tbl_median_surv <- function(fit_km, armval = "All") {
+ xs_class <- attr(fit_glm$terms, "dataClasses") |
||
| 136 | -10x | +257 | +15x |
- y <- if (is.null(fit_km$strata)) {
+ if (any(xs_class[c(odds_ratio_var, interaction_var)] == "numeric")) {
|
| 137 | -! | +|||
| 258 | +9x |
- as.data.frame(t(summary(fit_km)$table), row.names = armval)+ h_or_cont_interaction( |
||
| 138 | -+ | |||
| 259 | +9x |
- } else {
+ odds_ratio_var, |
||
| 139 | -10x | +260 | +9x |
- tbl <- summary(fit_km)$table+ interaction_var, |
| 140 | -10x | +261 | +9x |
- rownames_lst <- strsplit(sub("=", "equals", rownames(tbl)), "equals")
+ fit_glm, |
| 141 | -10x | +262 | +9x |
- rownames(tbl) <- matrix(unlist(rownames_lst), ncol = 2, byrow = TRUE)[, 2]+ at = at, |
| 142 | -10x | +263 | +9x |
- as.data.frame(tbl)+ conf_level = conf_level |
| 143 | +264 |
- }+ ) |
||
| 144 | -10x | +265 | +6x |
- conf.int <- summary(fit_km)$conf.int # nolint+ } else if (all(xs_class[c(odds_ratio_var, interaction_var)] == "factor")) {
|
| 145 | -10x | +266 | +6x |
- y$records <- round(y$records)+ h_or_cat_interaction( |
| 146 | -10x | +267 | +6x |
- y$median <- signif(y$median, 4)+ odds_ratio_var, |
| 147 | -10x | +268 | +6x |
- y$`CI` <- paste0(+ interaction_var, |
| 148 | -10x | +269 | +6x |
- "(", signif(y[[paste0(conf.int, "LCL")]], 4), ", ", signif(y[[paste0(conf.int, "UCL")]], 4), ")"
+ fit_glm, |
| 149 | -+ | |||
| 270 | +6x |
- )+ conf_level = conf_level |
||
| 150 | -10x | +|||
| 271 | +
- stats::setNames(+ ) |
|||
| 151 | -10x | +|||
| 272 | +
- y[c("records", "median", "CI")],
+ } else {
|
|||
| 152 | -10x | +|||
| 273 | +! |
- c("N", "Median", f_conf_level(conf.int))
+ stop("wrong interaction variable class, the interaction variable is not a numeric nor a factor")
|
||
| 153 | +274 |
- )+ } |
||
| 154 | +275 |
} |
||
| 155 | +276 | |||
| 156 | +277 |
- #' Helper function for generating a pairwise Cox-PH table+ #' @describeIn h_logistic_regression Helper function to construct term labels from simple terms and the table |
||
| 157 | +278 |
- #'+ #' of numbers of patients. |
||
| 158 | +279 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 159 | +280 |
- #'+ #' @param terms (`character`)\cr simple terms. |
||
| 160 | +281 |
- #' Create a `data.frame` of pairwise stratified or unstratified Cox-PH analysis results.+ #' @param table (`table`)\cr table containing numbers for terms. |
||
| 161 | +282 |
#' |
||
| 162 | +283 |
- #' @inheritParams g_km+ #' @return Term labels containing numbers of patients. |
||
| 163 | +284 |
- #' @param annot_coxph_ref_lbls (`flag`)\cr whether the reference group should be explicitly printed in labels for the+ #' |
||
| 164 | +285 |
- #' `annot_coxph` table. If `FALSE` (default), only comparison groups will be printed in `annot_coxph` table labels.+ #' @export |
||
| 165 | +286 |
- #'+ h_simple_term_labels <- function(terms, |
||
| 166 | +287 |
- #' @return A `data.frame` containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`),+ table) {
|
||
| 167 | -+ | |||
| 288 | +54x |
- #' and `p-value (log-rank)`.+ checkmate::assert_true(is.table(table)) |
||
| 168 | -+ | |||
| 289 | +54x |
- #'+ checkmate::assert_multi_class(terms, classes = c("factor", "character"))
|
||
| 169 | -+ | |||
| 290 | +54x |
- #' @examples+ terms <- as.character(terms) |
||
| 170 | -+ | |||
| 291 | +54x |
- #' library(dplyr)+ term_n <- table[terms] |
||
| 171 | -+ | |||
| 292 | +54x |
- #'+ paste0(terms, ", n = ", term_n) |
||
| 172 | +293 |
- #' adtte <- tern_ex_adtte %>%+ } |
||
| 173 | +294 |
- #' filter(PARAMCD == "OS") %>%+ |
||
| 174 | +295 |
- #' mutate(is_event = CNSR == 0)+ #' @describeIn h_logistic_regression Helper function to construct term labels from interaction terms and the table |
||
| 175 | +296 |
- #'+ #' of numbers of patients. |
||
| 176 | +297 |
- #' h_tbl_coxph_pairwise(+ #' |
||
| 177 | +298 |
- #' df = adtte,+ #' @param terms1 (`character`)\cr terms for first dimension (rows). |
||
| 178 | +299 |
- #' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARM"),+ #' @param terms2 (`character`)\cr terms for second dimension (rows). |
||
| 179 | +300 |
- #' control_coxph_pw = control_coxph(conf_level = 0.9)+ #' @param any (`flag`)\cr whether any of `term1` and `term2` can be fulfilled to count the |
||
| 180 | +301 |
- #' )+ #' number of patients. In that case they can only be scalar (strings). |
||
| 181 | +302 |
#' |
||
| 182 | +303 |
- #' @export+ #' @return Term labels containing numbers of patients. |
||
| 183 | +304 |
- h_tbl_coxph_pairwise <- function(df,+ #' |
||
| 184 | +305 |
- variables,+ #' @export |
||
| 185 | +306 |
- ref_group_coxph = NULL,+ h_interaction_term_labels <- function(terms1, |
||
| 186 | +307 |
- control_coxph_pw = control_coxph(),+ terms2, |
||
| 187 | +308 |
- annot_coxph_ref_lbls = FALSE) {
- |
- ||
| 188 | -4x | -
- if ("strat" %in% names(variables)) {
- |
- ||
| 189 | -! | -
- warning(+ table, |
||
| 190 | -! | +|||
| 309 | +
- "Warning: the `strat` element name of the `variables` list argument to `h_tbl_coxph_pairwise() ",+ any = FALSE) {
|
|||
| 191 | -! | +|||
| 310 | +8x |
- "was deprecated in tern 0.9.4.\n ",+ checkmate::assert_true(is.table(table)) |
||
| 192 | -! | +|||
| 311 | +8x |
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ checkmate::assert_flag(any) |
||
| 193 | -+ | |||
| 312 | +8x |
- )+ checkmate::assert_multi_class(terms1, classes = c("factor", "character"))
|
||
| 194 | -! | +|||
| 313 | +8x |
- variables[["strata"]] <- variables[["strat"]]+ checkmate::assert_multi_class(terms2, classes = c("factor", "character"))
|
||
| 195 | -+ | |||
| 314 | +8x |
- }+ terms1 <- as.character(terms1) |
||
| 196 | -+ | |||
| 315 | +8x |
-
+ terms2 <- as.character(terms2) |
||
| 197 | -4x | +316 | +8x |
- assert_df_with_variables(df, variables)+ if (any) {
|
| 198 | +317 | 4x |
- checkmate::assert_choice(ref_group_coxph, levels(df[[variables$arm]]), null.ok = TRUE)+ checkmate::assert_scalar(terms1) |
|
| 199 | +318 | 4x |
- checkmate::assert_flag(annot_coxph_ref_lbls)- |
- |
| 200 | -- |
-
+ checkmate::assert_scalar(terms2) |
||
| 201 | +319 | 4x |
- arm <- variables$arm+ paste0( |
|
| 202 | +320 | 4x |
- df[[arm]] <- factor(df[[arm]])+ terms1, " or ", terms2, ", n = ", |
|
| 203 | +321 |
-
+ # Note that we double count in the initial sum the cell [terms1, terms2], therefore subtract. |
||
| 204 | +322 | 4x |
- ref_group <- if (!is.null(ref_group_coxph)) ref_group_coxph else levels(df[[variables$arm]])[1]+ sum(c(table[terms1, ], table[, terms2])) - table[terms1, terms2] |
|
| 205 | -4x | +|||
| 323 | +
- comp_group <- setdiff(levels(df[[arm]]), ref_group)+ ) |
|||
| 206 | +324 |
-
+ } else {
|
||
| 207 | +325 | 4x |
- results <- Map(function(comp) {
+ term_n <- table[cbind(terms1, terms2)] |
|
| 208 | -8x | +326 | +4x |
- res <- s_coxph_pairwise(+ paste0(terms1, " * ", terms2, ", n = ", term_n) |
| 209 | -8x | +|||
| 327 | +
- df = df[df[[arm]] == comp, , drop = FALSE],+ } |
|||
| 210 | -8x | +|||
| 328 | +
- .ref_group = df[df[[arm]] == ref_group, , drop = FALSE],+ } |
|||
| 211 | -8x | +|||
| 329 | +
- .in_ref_col = FALSE,+ |
|||
| 212 | -8x | +|||
| 330 | +
- .var = variables$tte,+ #' @describeIn h_logistic_regression Helper function to tabulate the main effect |
|||
| 213 | -8x | +|||
| 331 | +
- is_event = variables$is_event,+ #' results of a (conditional) logistic regression model. |
|||
| 214 | -8x | +|||
| 332 | +
- strata = variables$strata,+ #' |
|||
| 215 | -8x | +|||
| 333 | +
- control = control_coxph_pw+ #' @return Tabulated main effect results from a logistic regression model. |
|||
| 216 | +334 |
- )+ #' |
||
| 217 | -8x | +|||
| 335 | +
- res_df <- data.frame(+ #' @examples |
|||
| 218 | -8x | +|||
| 336 | +
- hr = format(round(res$hr, 2), nsmall = 2),+ #' h_glm_simple_term_extract("AGE", mod1)
|
|||
| 219 | -8x | +|||
| 337 | +
- hr_ci = paste0(+ #' h_glm_simple_term_extract("ARMCD", mod1)
|
|||
| 220 | -8x | +|||
| 338 | +
- "(", format(round(res$hr_ci[1], 2), nsmall = 2), ", ",
+ #' |
|||
| 221 | -8x | +|||
| 339 | +
- format(round(res$hr_ci[2], 2), nsmall = 2), ")"+ #' @export |
|||
| 222 | +340 |
- ),+ h_glm_simple_term_extract <- function(x, fit_glm) {
|
||
| 223 | -8x | +341 | +78x |
- pvalue = if (res$pvalue < 0.0001) "<0.0001" else format(round(res$pvalue, 4), 4),+ checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
|
| 224 | -8x | +342 | +78x |
- stringsAsFactors = FALSE+ checkmate::assert_string(x) |
| 225 | +343 |
- )+ |
||
| 226 | -8x | +344 | +78x |
- colnames(res_df) <- c("HR", vapply(res[c("hr_ci", "pvalue")], obj_label, FUN.VALUE = "character"))
+ xs_class <- attr(fit_glm$terms, "dataClasses") |
| 227 | -8x | +345 | +78x |
- row.names(res_df) <- comp+ xs_level <- fit_glm$xlevels |
| 228 | -8x | +346 | +78x |
- res_df+ xs_coef <- summary(fit_glm)$coefficients |
| 229 | -4x | +347 | +78x |
- }, comp_group)+ stats <- if (inherits(fit_glm, "glm")) {
|
| 230 | -1x | +348 | +66x |
- if (annot_coxph_ref_lbls) names(results) <- paste(comp_group, "vs.", ref_group)+ c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
|
| 231 | +349 |
-
+ } else {
|
||
| 232 | -4x | -
- do.call(rbind, results)- |
- ||
| 233 | -- |
- }- |
- ||
| 234 | -- | - - | -||
| 235 | -- |
- #' Helper function to tidy survival fit data- |
- ||
| 236 | -- |
- #'- |
- ||
| 237 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- ||
| 238 | -- |
- #'- |
- ||
| 239 | -- |
- #' Convert the survival fit data into a data frame designed for plotting- |
- ||
| 240 | -+ | 350 | +12x |
- #' within `g_km`.+ c("estimate" = "coef", "std_error" = "se(coef)", "pvalue" = "Pr(>|z|)")
|
| 241 | +351 |
- #'+ } |
||
| 242 | +352 |
- #' This starts from the [broom::tidy()] result, and then:+ # Make sure x is not an interaction term. |
||
| 243 | -+ | |||
| 353 | +78x |
- #' * Post-processes the `strata` column into a factor.+ checkmate::assert_subset(x, names(xs_class)) |
||
| 244 | -+ | |||
| 354 | +78x |
- #' * Extends each stratum by an additional first row with time 0 and probability 1 so that+ x_sel <- if (xs_class[x] == "numeric") x else paste0(x, xs_level[[x]][-1]) |
||
| 245 | -+ | |||
| 355 | +78x |
- #' downstream plot lines start at those coordinates.+ x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE) |
||
| 246 | -+ | |||
| 356 | +78x |
- #' * Adds a `censor` column.+ colnames(x_stats) <- names(stats) |
||
| 247 | -+ | |||
| 357 | +78x |
- #' * Filters the rows before `max_time`.+ x_stats$estimate <- as.list(x_stats$estimate) |
||
| 248 | -+ | |||
| 358 | +78x |
- #'+ x_stats$std_error <- as.list(x_stats$std_error) |
||
| 249 | -+ | |||
| 359 | +78x |
- #' @inheritParams g_km+ x_stats$pvalue <- as.list(x_stats$pvalue) |
||
| 250 | -+ | |||
| 360 | +78x |
- #' @param fit_km (`survfit`)\cr result of [survival::survfit()].+ x_stats$df <- as.list(1) |
||
| 251 | -+ | |||
| 361 | +78x |
- #' @param armval (`string`)\cr used as strata name when treatment arm variable only has one level. Default is `"All"`.+ if (xs_class[x] == "numeric") {
|
||
| 252 | -+ | |||
| 362 | +60x |
- #'+ x_stats$term <- x |
||
| 253 | -+ | |||
| 363 | +60x |
- #' @return A `tibble` with columns `time`, `n.risk`, `n.event`, `n.censor`, `estimate`, `std.error`, `conf.high`,+ x_stats$term_label <- if (inherits(fit_glm, "glm")) {
|
||
| 254 | -+ | |||
| 364 | +48x |
- #' `conf.low`, `strata`, and `censor`.+ formatters::var_labels(fit_glm$data[x], fill = TRUE) |
||
| 255 | +365 |
- #'+ } else {
|
||
| 256 | +366 |
- #' @examples+ # We just fill in here with the `term` itself as we don't have the data available. |
||
| 257 | -+ | |||
| 367 | +12x |
- #' library(dplyr)+ x |
||
| 258 | +368 |
- #' library(survival)+ } |
||
| 259 | -+ | |||
| 369 | +60x |
- #'+ x_stats$is_variable_summary <- FALSE |
||
| 260 | -+ | |||
| 370 | +60x |
- #' # Test with multiple arms+ x_stats$is_term_summary <- TRUE |
||
| 261 | +371 |
- #' tern_ex_adtte %>%+ } else {
|
||
| 262 | -+ | |||
| 372 | +18x |
- #' filter(PARAMCD == "OS") %>%+ checkmate::assert_class(fit_glm, "glm") |
||
| 263 | +373 |
- #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ # The reason is that we don't have the original data set in the `clogit` object |
||
| 264 | +374 |
- #' h_data_plot()+ # and therefore cannot determine the `x_numbers` here. |
||
| 265 | -+ | |||
| 375 | +18x |
- #'+ x_numbers <- table(fit_glm$data[[x]]) |
||
| 266 | -+ | |||
| 376 | +18x |
- #' # Test with single arm+ x_stats$term <- xs_level[[x]][-1] |
||
| 267 | -+ | |||
| 377 | +18x |
- #' tern_ex_adtte %>%+ x_stats$term_label <- h_simple_term_labels(x_stats$term, x_numbers) |
||
| 268 | -+ | |||
| 378 | +18x |
- #' filter(PARAMCD == "OS", ARMCD == "ARM B") %>%+ x_stats$is_variable_summary <- FALSE |
||
| 269 | -+ | |||
| 379 | +18x |
- #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ x_stats$is_term_summary <- TRUE |
||
| 270 | -+ | |||
| 380 | +18x |
- #' h_data_plot(armval = "ARM B")+ main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald") |
||
| 271 | -+ | |||
| 381 | +18x |
- #'+ x_main <- data.frame( |
||
| 272 | -+ | |||
| 382 | +18x |
- #' @export+ pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE], |
||
| 273 | -+ | |||
| 383 | +18x |
- h_data_plot <- function(fit_km,+ term = xs_level[[x]][1], |
||
| 274 | -+ | |||
| 384 | +18x |
- armval = "All",+ term_label = paste("Reference", h_simple_term_labels(xs_level[[x]][1], x_numbers)),
|
||
| 275 | -+ | |||
| 385 | +18x |
- max_time = NULL) {
+ df = main_effects[x, "Df", drop = TRUE], |
||
| 276 | +386 | 18x |
- y <- broom::tidy(fit_km)+ stringsAsFactors = FALSE |
|
| 277 | +387 |
-
+ ) |
||
| 278 | +388 | 18x |
- if (!is.null(fit_km$strata)) {
+ x_main$pvalue <- as.list(x_main$pvalue) |
|
| 279 | +389 | 18x |
- fit_km_var_level <- strsplit(sub("=", "equals", names(fit_km$strata)), "equals")
+ x_main$df <- as.list(x_main$df) |
|
| 280 | +390 | 18x |
- strata_levels <- vapply(fit_km_var_level, FUN = "[", FUN.VALUE = "a", i = 2)+ x_main$estimate <- list(numeric(0)) |
|
| 281 | +391 | 18x |
- strata_var_level <- strsplit(sub("=", "equals", y$strata), "equals")
+ x_main$std_error <- list(numeric(0)) |
|
| 282 | +392 | 18x |
- y$strata <- factor(+ if (length(xs_level[[x]][-1]) == 1) {
|
|
| 283 | -18x | +393 | +8x |
- vapply(strata_var_level, FUN = "[", FUN.VALUE = "a", i = 2),+ x_main$pvalue <- list(numeric(0)) |
| 284 | -18x | +394 | +8x |
- levels = strata_levels+ x_main$df <- list(numeric(0)) |
| 285 | +395 |
- )+ } |
||
| 286 | -+ | |||
| 396 | +18x |
- } else {
+ x_main$is_variable_summary <- TRUE |
||
| 287 | -! | +|||
| 397 | +18x | +
+ x_main$is_term_summary <- FALSE+ |
+ ||
| 398 | +18x |
- y$strata <- armval+ x_stats <- rbind(x_main, x_stats) |
||
| 288 | +399 |
} |
||
| 289 | -+ | |||
| 400 | +78x |
-
+ x_stats$variable <- x |
||
| 290 | -18x | +401 | +78x |
- y_by_strata <- split(y, y$strata)+ x_stats$variable_label <- if (inherits(fit_glm, "glm")) {
|
| 291 | -18x | +402 | +66x |
- y_by_strata_extended <- lapply(+ formatters::var_labels(fit_glm$data[x], fill = TRUE) |
| 292 | -18x | +|||
| 403 | +
- y_by_strata,+ } else {
|
|||
| 293 | -18x | +404 | +12x |
- FUN = function(tbl) {
+ x |
| 294 | -53x | +|||
| 405 | +
- first_row <- tbl[1L, ]+ } |
|||
| 295 | -53x | +406 | +78x |
- first_row$time <- 0+ x_stats$interaction <- "" |
| 296 | -53x | +407 | +78x |
- first_row$n.risk <- sum(first_row[, c("n.risk", "n.event", "n.censor")])
+ x_stats$interaction_label <- "" |
| 297 | -53x | +408 | +78x |
- first_row$n.event <- first_row$n.censor <- 0+ x_stats$reference <- "" |
| 298 | -53x | +409 | +78x |
- first_row$estimate <- first_row$conf.high <- first_row$conf.low <- 1+ x_stats$reference_label <- "" |
| 299 | -53x | +410 | +78x |
- first_row$std.error <- 0+ rownames(x_stats) <- NULL |
| 300 | -53x | +411 | +78x |
- rbind(+ x_stats[c( |
| 301 | -53x | +412 | +78x |
- first_row,+ "variable", |
| 302 | -53x | +413 | +78x |
- tbl+ "variable_label", |
| 303 | -+ | |||
| 414 | +78x |
- )+ "term", |
||
| 304 | -+ | |||
| 415 | +78x |
- }+ "term_label", |
||
| 305 | -+ | |||
| 416 | +78x |
- )+ "interaction", |
||
| 306 | -18x | +417 | +78x |
- y <- do.call(rbind, y_by_strata_extended)+ "interaction_label", |
| 307 | -+ | |||
| 418 | +78x |
-
+ "reference", |
||
| 308 | -18x | +419 | +78x |
- y$censor <- ifelse(y$n.censor > 0, y$estimate, NA)+ "reference_label", |
| 309 | -18x | +420 | +78x |
- if (!is.null(max_time)) {
+ "estimate", |
| 310 | -1x | +421 | +78x |
- y <- y[y$time <= max(max_time), ]+ "std_error", |
| 311 | -+ | |||
| 422 | +78x |
- }+ "df", |
||
| 312 | -18x | +423 | +78x |
- y+ "pvalue", |
| 313 | -+ | |||
| 424 | +78x |
- }+ "is_variable_summary", |
||
| 314 | -+ | |||
| 425 | +78x |
-
+ "is_term_summary" |
||
| 315 | +426 |
- ## Deprecated Functions ----+ )] |
||
| 316 | +427 |
-
+ } |
||
| 317 | +428 |
- #' Helper function to create a KM plot+ |
||
| 318 | +429 |
- #'+ #' @describeIn h_logistic_regression Helper function to tabulate the interaction term |
||
| 319 | +430 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' results of a logistic regression model. |
||
| 320 | +431 |
#' |
||
| 321 | +432 |
- #' Draw the Kaplan-Meier plot using `ggplot2`.+ #' @return Tabulated interaction term results from a logistic regression model. |
||
| 322 | +433 |
#' |
||
| 323 | +434 |
- #' @inheritParams g_km+ #' @examples |
||
| 324 | +435 |
- #' @param data (`data.frame`)\cr survival data as pre-processed by `h_data_plot`.+ #' h_glm_interaction_extract("ARMCD:AGE", mod2)
|
||
| 325 | +436 |
#' |
||
| 326 | +437 |
- #' @return A `ggplot` object.+ #' @export |
||
| 327 | +438 |
- #'+ h_glm_interaction_extract <- function(x, fit_glm) {
|
||
| 328 | -+ | |||
| 439 | +7x |
- #' @examples+ vars <- h_get_interaction_vars(fit_glm) |
||
| 329 | -+ | |||
| 440 | +7x |
- #' \donttest{
+ xs_class <- attr(fit_glm$terms, "dataClasses") |
||
| 330 | +441 |
- #' library(dplyr)+ |
||
| 331 | -+ | |||
| 442 | +7x |
- #' library(survival)+ checkmate::assert_string(x) |
||
| 332 | +443 |
- #'+ |
||
| 333 | +444 |
- #' fit_km <- tern_ex_adtte %>%+ # Only take two-way interaction |
||
| 334 | -+ | |||
| 445 | +7x |
- #' filter(PARAMCD == "OS") %>%+ checkmate::assert_vector(vars, len = 2) |
||
| 335 | +446 |
- #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ |
||
| 336 | +447 |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ # Only consider simple case: first variable in interaction is arm, a categorical variable |
||
| 337 | -+ | |||
| 448 | +7x |
- #' xticks <- h_xticks(data = data_plot)+ checkmate::assert_disjunct(xs_class[vars[1]], "numeric") |
||
| 338 | +449 |
- #' gg <- h_ggkm(+ |
||
| 339 | -+ | |||
| 450 | +7x |
- #' data = data_plot,+ xs_level <- fit_glm$xlevels |
||
| 340 | -+ | |||
| 451 | +7x |
- #' censor_show = TRUE,+ xs_coef <- summary(fit_glm)$coefficients |
||
| 341 | -+ | |||
| 452 | +7x |
- #' xticks = xticks,+ main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald") |
||
| 342 | -+ | |||
| 453 | +7x |
- #' xlab = "Days",+ stats <- c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
|
||
| 343 | -+ | |||
| 454 | +7x |
- #' yval = "Survival",+ v1_comp <- xs_level[[vars[1]]][-1] |
||
| 344 | -+ | |||
| 455 | +7x |
- #' ylab = "Survival Probability",+ if (xs_class[vars[2]] == "numeric") {
|
||
| 345 | -+ | |||
| 456 | +4x |
- #' title = "Survival"+ x_stats <- as.data.frame( |
||
| 346 | -+ | |||
| 457 | +4x |
- #' )+ xs_coef[paste0(vars[1], v1_comp, ":", vars[2]), stats, drop = FALSE], |
||
| 347 | -+ | |||
| 458 | +4x |
- #' gg+ stringsAsFactors = FALSE |
||
| 348 | +459 |
- #' }+ ) |
||
| 349 | -+ | |||
| 460 | +4x |
- #'+ colnames(x_stats) <- names(stats) |
||
| 350 | -+ | |||
| 461 | +4x |
- #' @export+ x_stats$term <- v1_comp |
||
| 351 | -+ | |||
| 462 | +4x |
- h_ggkm <- function(data,+ x_numbers <- table(fit_glm$data[[vars[1]]]) |
||
| 352 | -+ | |||
| 463 | +4x |
- xticks = NULL,+ x_stats$term_label <- h_simple_term_labels(v1_comp, x_numbers) |
||
| 353 | -+ | |||
| 464 | +4x |
- yval = "Survival",+ v1_ref <- xs_level[[vars[1]]][1] |
||
| 354 | -+ | |||
| 465 | +4x |
- censor_show,+ term_main <- v1_ref |
||
| 355 | -+ | |||
| 466 | +4x |
- xlab,+ ref_label <- h_simple_term_labels(v1_ref, x_numbers) |
||
| 356 | -+ | |||
| 467 | +3x |
- ylab,+ } else if (xs_class[vars[2]] != "numeric") {
|
||
| 357 | -+ | |||
| 468 | +3x |
- ylim = NULL,+ v2_comp <- xs_level[[vars[2]]][-1] |
||
| 358 | -+ | |||
| 469 | +3x |
- title,+ v1_v2_grid <- expand.grid(v1 = v1_comp, v2 = v2_comp) |
||
| 359 | -+ | |||
| 470 | +3x |
- footnotes = NULL,+ x_sel <- paste( |
||
| 360 | -+ | |||
| 471 | +3x |
- max_time = NULL,+ paste0(vars[1], v1_v2_grid$v1), |
||
| 361 | -+ | |||
| 472 | +3x |
- lwd = 1,+ paste0(vars[2], v1_v2_grid$v2), |
||
| 362 | -+ | |||
| 473 | +3x |
- lty = NULL,+ sep = ":" |
||
| 363 | +474 |
- pch = 3,+ ) |
||
| 364 | -+ | |||
| 475 | +3x |
- size = 2,+ x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE) |
||
| 365 | -+ | |||
| 476 | +3x |
- col = NULL,+ colnames(x_stats) <- names(stats) |
||
| 366 | -+ | |||
| 477 | +3x |
- ci_ribbon = FALSE,+ x_stats$term <- paste(v1_v2_grid$v1, "*", v1_v2_grid$v2) |
||
| 367 | -+ | |||
| 478 | +3x |
- ggtheme = nestcolor::theme_nest()) {
+ x_numbers <- table(fit_glm$data[[vars[1]]], fit_glm$data[[vars[2]]]) |
||
| 368 | -1x | +479 | +3x |
- lifecycle::deprecate_warn(+ x_stats$term_label <- h_interaction_term_labels(v1_v2_grid$v1, v1_v2_grid$v2, x_numbers) |
| 369 | -1x | +480 | +3x |
- "0.9.4",+ v1_ref <- xs_level[[vars[1]]][1] |
| 370 | -1x | +481 | +3x |
- "h_ggkm()",+ v2_ref <- xs_level[[vars[2]]][1] |
| 371 | -1x | +482 | +3x |
- details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`."+ term_main <- paste(vars[1], vars[2], sep = " * ")+ |
+
| 483 | +3x | +
+ ref_label <- h_interaction_term_labels(v1_ref, v2_ref, x_numbers, any = TRUE) |
||
| 372 | +484 |
- )+ } |
||
| 373 | -1x | +485 | +7x |
- checkmate::assert_numeric(lty, null.ok = TRUE)+ x_stats$df <- as.list(1) |
| 374 | -1x | +486 | +7x |
- checkmate::assert_character(col, null.ok = TRUE)+ x_stats$pvalue <- as.list(x_stats$pvalue) |
| 375 | -+ | |||
| 487 | +7x |
-
+ x_stats$is_variable_summary <- FALSE |
||
| 376 | -1x | +488 | +7x |
- if (is.null(ylim)) {
+ x_stats$is_term_summary <- TRUE |
| 377 | -1x | +489 | +7x |
- data_lims <- data+ x_main <- data.frame( |
| 378 | -! | +|||
| 490 | +7x |
- if (yval == "Failure") data_lims[["estimate"]] <- 1 - data_lims[["estimate"]]+ pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE], |
||
| 379 | -1x | +491 | +7x |
- if (!is.null(max_time)) {
+ term = term_main, |
| 380 | -! | +|||
| 492 | +7x |
- y_lwr <- min(data_lims[data_lims$time < max_time, ][["estimate"]])+ term_label = paste("Reference", ref_label),
|
||
| 381 | -! | +|||
| 493 | +7x |
- y_upr <- max(data_lims[data_lims$time < max_time, ][["estimate"]])+ df = main_effects[x, "Df", drop = TRUE],+ |
+ ||
| 494 | +7x | +
+ stringsAsFactors = FALSE |
||
| 382 | +495 |
- } else {
+ ) |
||
| 383 | -1x | +496 | +7x |
- y_lwr <- min(data_lims[["estimate"]])+ x_main$pvalue <- as.list(x_main$pvalue) |
| 384 | -1x | +497 | +7x |
- y_upr <- max(data_lims[["estimate"]])+ x_main$df <- as.list(x_main$df) |
| 385 | -+ | |||
| 498 | +7x |
- }+ x_main$estimate <- list(numeric(0)) |
||
| 386 | -1x | +499 | +7x |
- ylim <- c(y_lwr, y_upr)+ x_main$std_error <- list(numeric(0)) |
| 387 | -+ | |||
| 500 | +7x |
- }+ x_main$is_variable_summary <- TRUE |
||
| 388 | -1x | +501 | +7x |
- checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE)+ x_main$is_term_summary <- FALSE |
| 389 | +502 | |||
| 390 | -- |
- # change estimates of survival to estimates of failure (1 - survival)- |
- ||
| 391 | -1x | +503 | +7x |
- if (yval == "Failure") {
+ x_stats <- rbind(x_main, x_stats) |
| 392 | -! | +|||
| 504 | +7x |
- data$estimate <- 1 - data$estimate+ x_stats$variable <- x |
||
| 393 | -! | +|||
| 505 | +7x |
- data[c("conf.high", "conf.low")] <- list(1 - data$conf.low, 1 - data$conf.high)
+ x_stats$variable_label <- paste( |
||
| 394 | -! | +|||
| 506 | +7x |
- data$censor <- 1 - data$censor+ "Interaction of", |
||
| 395 | -+ | |||
| 507 | +7x |
- }+ formatters::var_labels(fit_glm$data[vars[1]], fill = TRUE), |
||
| 396 | +508 |
-
+ "*", |
||
| 397 | -1x | +509 | +7x |
- gg <- {
+ formatters::var_labels(fit_glm$data[vars[2]], fill = TRUE) |
| 398 | -1x | +|||
| 510 | +
- ggplot2::ggplot(+ ) |
|||
| 399 | -1x | +511 | +7x |
- data = data,+ x_stats$interaction <- "" |
| 400 | -1x | +512 | +7x |
- mapping = ggplot2::aes(+ x_stats$interaction_label <- "" |
| 401 | -1x | +513 | +7x |
- x = .data[["time"]],+ x_stats$reference <- "" |
| 402 | -1x | +514 | +7x |
- y = .data[["estimate"]],+ x_stats$reference_label <- "" |
| 403 | -1x | +515 | +7x |
- ymin = .data[["conf.low"]],+ rownames(x_stats) <- NULL |
| 404 | -1x | +516 | +7x |
- ymax = .data[["conf.high"]],+ x_stats[c( |
| 405 | -1x | +517 | +7x |
- color = .data[["strata"]],+ "variable", |
| 406 | -1x | +518 | +7x |
- fill = .data[["strata"]]+ "variable_label", |
| 407 | -+ | |||
| 519 | +7x |
- )+ "term", |
||
| 408 | -+ | |||
| 520 | +7x |
- ) ++ "term_label", |
||
| 409 | -1x | +521 | +7x |
- ggplot2::geom_hline(yintercept = 0)+ "interaction", |
| 410 | -+ | |||
| 522 | +7x |
- }+ "interaction_label", |
||
| 411 | -+ | |||
| 523 | +7x |
-
+ "reference", |
||
| 412 | -1x | +524 | +7x |
- if (ci_ribbon) {
+ "reference_label", |
| 413 | -! | +|||
| 525 | +7x |
- gg <- gg + ggplot2::geom_ribbon(alpha = .3, lty = 0)+ "estimate", |
||
| 414 | -+ | |||
| 526 | +7x |
- }+ "std_error", |
||
| 415 | -+ | |||
| 527 | +7x |
-
+ "df", |
||
| 416 | -1x | +528 | +7x |
- gg <- if (is.null(lty)) {
+ "pvalue", |
| 417 | -1x | +529 | +7x |
- gg ++ "is_variable_summary", |
| 418 | -1x | +530 | +7x |
- ggplot2::geom_step(linewidth = lwd)+ "is_term_summary" |
| 419 | -1x | +|||
| 531 | +
- } else if (checkmate::test_number(lty)) {
+ )] |
|||
| 420 | -! | +|||
| 532 | +
- gg ++ } |
|||
| 421 | -! | +|||
| 533 | +
- ggplot2::geom_step(linewidth = lwd, lty = lty)+ |
|||
| 422 | -1x | +|||
| 534 | +
- } else if (is.numeric(lty)) {
+ #' @describeIn h_logistic_regression Helper function to tabulate the interaction |
|||
| 423 | -! | +|||
| 535 | +
- gg ++ #' results of a logistic regression model. This basically is a wrapper for |
|||
| 424 | -! | +|||
| 536 | +
- ggplot2::geom_step(mapping = ggplot2::aes(linetype = .data[["strata"]]), linewidth = lwd) ++ #' [h_or_interaction()] and [h_glm_simple_term_extract()] which puts the results |
|||
| 425 | -! | +|||
| 537 | +
- ggplot2::scale_linetype_manual(values = lty)+ #' in the right data frame format. |
|||
| 426 | +538 |
- }+ #' |
||
| 427 | +539 |
-
+ #' @return A `data.frame` of tabulated interaction term results from a logistic regression model. |
||
| 428 | -1x | +|||
| 540 | +
- gg <- gg ++ #' |
|||
| 429 | -1x | +|||
| 541 | +
- ggplot2::coord_cartesian(ylim = ylim) ++ #' @examples |
|||
| 430 | -1x | +|||
| 542 | +
- ggplot2::labs(x = xlab, y = ylab, title = title, caption = footnotes)+ #' h_glm_inter_term_extract("AGE", "ARMCD", mod2)
|
|||
| 431 | +543 |
-
+ #' |
||
| 432 | -1x | +|||
| 544 | +
- if (!is.null(col)) {
+ #' @export |
|||
| 433 | -! | +|||
| 545 | +
- gg <- gg ++ h_glm_inter_term_extract <- function(odds_ratio_var, |
|||
| 434 | -! | +|||
| 546 | +
- ggplot2::scale_color_manual(values = col) ++ interaction_var, |
|||
| 435 | -! | +|||
| 547 | +
- ggplot2::scale_fill_manual(values = col)+ fit_glm, |
|||
| 436 | +548 |
- }+ ...) {
|
||
| 437 | -1x | +|||
| 549 | +
- if (censor_show) {
+ # First obtain the main effects. |
|||
| 438 | -1x | +550 | +13x |
- dt <- data[data$n.censor != 0, ]+ main_stats <- h_glm_simple_term_extract(odds_ratio_var, fit_glm) |
| 439 | -1x | +551 | +13x |
- dt$censor_lbl <- factor("Censored")
+ main_stats$is_reference_summary <- FALSE |
| 440 | -+ | |||
| 552 | +13x |
-
+ main_stats$odds_ratio <- NA |
||
| 441 | -1x | +553 | +13x |
- gg <- gg + ggplot2::geom_point(+ main_stats$lcl <- NA |
| 442 | -1x | +554 | +13x |
- data = dt,+ main_stats$ucl <- NA |
| 443 | -1x | +|||
| 555 | +
- ggplot2::aes(+ |
|||
| 444 | -1x | +|||
| 556 | +
- x = .data[["time"]],+ # Then we get the odds ratio estimates and put into df form. |
|||
| 445 | -1x | +557 | +13x |
- y = .data[["censor"]],+ or_numbers <- h_or_interaction(odds_ratio_var, interaction_var, fit_glm, ...) |
| 446 | -1x | +558 | +13x |
- shape = .data[["censor_lbl"]]+ is_num_or_var <- attr(fit_glm$terms, "dataClasses")[odds_ratio_var] == "numeric" |
| 447 | +559 |
- ),+ |
||
| 448 | -1x | +560 | +13x |
- size = size,+ if (is_num_or_var) {
+ |
+
| 561 | ++ |
+ # Numeric OR variable case. |
||
| 449 | -1x | +562 | +4x |
- show.legend = TRUE,+ references <- names(or_numbers) |
| 450 | -1x | +563 | +4x |
- inherit.aes = TRUE+ n_ref <- length(references) |
| 451 | +564 |
- ) ++ |
||
| 452 | -1x | +565 | +4x |
- ggplot2::scale_shape_manual(name = NULL, values = pch) ++ extract_from_list <- function(l, name, pos = 1) {
|
| 453 | -1x | +566 | +12x |
- ggplot2::guides(+ unname(unlist( |
| 454 | -1x | +567 | +12x |
- shape = ggplot2::guide_legend(override.aes = list(linetype = NA)),+ lapply(or_numbers, function(x) {
|
| 455 | -1x | +568 | +36x |
- fill = ggplot2::guide_legend(override.aes = list(shape = NA))+ x[[name]][pos] |
| 456 | +569 |
- )+ }) |
||
| 457 | +570 |
- }+ )) |
||
| 458 | +571 |
-
+ } |
||
| 459 | -1x | -
- if (!is.null(max_time) && !is.null(xticks)) {
- |
- ||
| 460 | -! | +572 | +4x |
- gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, xticks), max(c(xticks, max_time))))+ or_stats <- data.frame( |
| 461 | -1x | +573 | +4x |
- } else if (!is.null(xticks)) {
+ variable = odds_ratio_var, |
| 462 | -1x | +574 | +4x |
- if (max(data$time) <= max(xticks)) {
+ variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)), |
| 463 | -1x | -
- gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, min(xticks)), max(xticks)))- |
- ||
| 464 | -+ | 575 | +4x |
- } else {
+ term = odds_ratio_var, |
| 465 | -! | +|||
| 576 | +4x |
- gg <- gg + ggplot2::scale_x_continuous(breaks = xticks)+ term_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)), |
||
| 466 | -+ | |||
| 577 | +4x |
- }+ interaction = interaction_var, |
||
| 467 | -! | +|||
| 578 | +4x |
- } else if (!is.null(max_time)) {
+ interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)), |
||
| 468 | -! | +|||
| 579 | +4x |
- gg <- gg + ggplot2::scale_x_continuous(limits = c(0, max_time))+ reference = references, |
||
| 469 | -+ | |||
| 580 | +4x |
- }+ reference_label = references, |
||
| 470 | -+ | |||
| 581 | +4x |
-
+ estimate = NA, |
||
| 471 | -1x | +582 | +4x |
- if (!is.null(ggtheme)) {
+ std_error = NA, |
| 472 | -1x | +583 | +4x |
- gg <- gg + ggtheme+ odds_ratio = extract_from_list(or_numbers, "or"), |
| 473 | -+ | |||
| 584 | +4x |
- }+ lcl = extract_from_list(or_numbers, "ci", pos = "lcl"), |
||
| 474 | -+ | |||
| 585 | +4x |
-
+ ucl = extract_from_list(or_numbers, "ci", pos = "ucl"), |
||
| 475 | -1x | +586 | +4x |
- gg + ggplot2::theme(+ df = NA, |
| 476 | -1x | +587 | +4x |
- legend.position = "bottom",+ pvalue = NA, |
| 477 | -1x | +588 | +4x |
- legend.title = ggplot2::element_blank(),+ is_variable_summary = FALSE, |
| 478 | -1x | +589 | +4x |
- legend.key.height = unit(0.02, "npc"),+ is_term_summary = FALSE, |
| 479 | -1x | +590 | +4x |
- panel.grid.major.x = ggplot2::element_line(linewidth = 2)+ is_reference_summary = TRUE |
| 480 | +591 |
- )+ ) |
||
| 481 | +592 |
- }+ } else {
|
||
| 482 | +593 |
-
+ # Categorical OR variable case. |
||
| 483 | -+ | |||
| 594 | +9x |
- #' `ggplot` decomposition+ references <- names(or_numbers[[1]]) |
||
| 484 | -+ | |||
| 595 | +9x |
- #'+ n_ref <- length(references) |
||
| 485 | +596 |
- #' @description `r lifecycle::badge("deprecated")`
+
|
||
| 486 | -+ | |||
| 597 | +9x |
- #'+ extract_from_list <- function(l, name, pos = 1) {
|
||
| 487 | -+ | |||
| 598 | +27x |
- #' The elements composing the `ggplot` are extracted and organized in a `list`.+ unname(unlist( |
||
| 488 | -+ | |||
| 599 | +27x |
- #'+ lapply(or_numbers, function(x) {
|
||
| 489 | -+ | |||
| 600 | +48x |
- #' @param gg (`ggplot`)\cr a graphic to decompose.+ lapply(x, function(y) y[[name]][pos]) |
||
| 490 | +601 |
- #'+ }) |
||
| 491 | +602 |
- #' @return A named `list` with elements:+ )) |
||
| 492 | +603 |
- #' * `panel`: The panel.+ } |
||
| 493 | -+ | |||
| 604 | +9x |
- #' * `yaxis`: The y-axis.+ or_stats <- data.frame( |
||
| 494 | -+ | |||
| 605 | +9x |
- #' * `xaxis`: The x-axis.+ variable = odds_ratio_var, |
||
| 495 | -+ | |||
| 606 | +9x |
- #' * `xlab`: The x-axis label.+ variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)), |
||
| 496 | -+ | |||
| 607 | +9x |
- #' * `ylab`: The y-axis label.+ term = rep(names(or_numbers), each = n_ref), |
||
| 497 | -+ | |||
| 608 | +9x |
- #' * `guide`: The legend.+ term_label = h_simple_term_labels(rep(names(or_numbers), each = n_ref), table(fit_glm$data[[odds_ratio_var]])), |
||
| 498 | -+ | |||
| 609 | +9x |
- #'+ interaction = interaction_var, |
||
| 499 | -+ | |||
| 610 | +9x |
- #' @examples+ interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)), |
||
| 500 | -+ | |||
| 611 | +9x |
- #' \donttest{
+ reference = unlist(lapply(or_numbers, names)), |
||
| 501 | -+ | |||
| 612 | +9x |
- #' library(dplyr)+ reference_label = unlist(lapply(or_numbers, names)), |
||
| 502 | -+ | |||
| 613 | +9x |
- #' library(survival)+ estimate = NA, |
||
| 503 | -+ | |||
| 614 | +9x |
- #' library(grid)+ std_error = NA, |
||
| 504 | -+ | |||
| 615 | +9x |
- #'+ odds_ratio = extract_from_list(or_numbers, "or"), |
||
| 505 | -+ | |||
| 616 | +9x |
- #' fit_km <- tern_ex_adtte %>%+ lcl = extract_from_list(or_numbers, "ci", pos = "lcl"), |
||
| 506 | -+ | |||
| 617 | +9x |
- #' filter(PARAMCD == "OS") %>%+ ucl = extract_from_list(or_numbers, "ci", pos = "ucl"), |
||
| 507 | -+ | |||
| 618 | +9x |
- #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ df = NA, |
||
| 508 | -+ | |||
| 619 | +9x |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ pvalue = NA, |
||
| 509 | -+ | |||
| 620 | +9x |
- #' xticks <- h_xticks(data = data_plot)+ is_variable_summary = FALSE, |
||
| 510 | -+ | |||
| 621 | +9x |
- #' gg <- h_ggkm(+ is_term_summary = FALSE, |
||
| 511 | -+ | |||
| 622 | +9x |
- #' data = data_plot,+ is_reference_summary = TRUE |
||
| 512 | +623 |
- #' yval = "Survival",+ ) |
||
| 513 | +624 |
- #' censor_show = TRUE,+ } |
||
| 514 | +625 |
- #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ |
||
| 515 | -+ | |||
| 626 | +13x |
- #' title = "tt",+ df <- rbind( |
||
| 516 | -+ | |||
| 627 | +13x |
- #' footnotes = "ff"+ main_stats[, names(or_stats)], |
||
| 517 | -+ | |||
| 628 | +13x |
- #' )+ or_stats |
||
| 518 | +629 |
- #'+ )+ |
+ ||
| 630 | +13x | +
+ df[order(-df$is_variable_summary, df$term, -df$is_term_summary, df$reference), ] |
||
| 519 | +631 |
- #' g_el <- h_decompose_gg(gg)+ } |
||
| 520 | +632 |
- #' grid::grid.newpage()+ |
||
| 521 | +633 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "red", fill = "gray85", lwd = 5))+ #' @describeIn h_logistic_regression Helper function to tabulate the results including |
||
| 522 | +634 |
- #' grid::grid.draw(g_el$panel)+ #' odds ratios and confidence intervals of simple terms. |
||
| 523 | +635 |
#' |
||
| 524 | +636 |
- #' grid::grid.newpage()+ #' @return Tabulated statistics for the given variable(s) from the logistic regression model. |
||
| 525 | +637 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "royalblue", fill = "gray85", lwd = 5))+ #' |
||
| 526 | +638 |
- #' grid::grid.draw(with(g_el, cbind(ylab, yaxis)))+ #' @examples |
||
| 527 | +639 |
- #' }+ #' h_logistic_simple_terms("AGE", mod1)
|
||
| 528 | +640 |
#' |
||
| 529 | +641 |
#' @export |
||
| 530 | +642 |
- h_decompose_gg <- function(gg) {
- |
- ||
| 531 | -1x | -
- lifecycle::deprecate_warn(+ h_logistic_simple_terms <- function(x, fit_glm, conf_level = 0.95) {
|
||
| 532 | -1x | +643 | +53x |
- "0.9.4",+ checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
|
| 533 | -1x | +644 | +53x |
- "h_decompose_gg()",+ if (inherits(fit_glm, "glm")) {
|
| 534 | -1x | +645 | +42x |
- details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`."+ checkmate::assert_set_equal(fit_glm$family$family, "binomial") |
| 535 | +646 |
- )- |
- ||
| 536 | -1x | -
- g_el <- ggplot2::ggplotGrob(gg)- |
- ||
| 537 | -1x | -
- y <- c(- |
- ||
| 538 | -1x | -
- panel = "panel",+ } |
||
| 539 | -1x | +647 | +53x |
- yaxis = "axis-l",+ terms_name <- attr(stats::terms(fit_glm), "term.labels") |
| 540 | -1x | +648 | +53x |
- xaxis = "axis-b",+ xs_class <- attr(fit_glm$terms, "dataClasses") |
| 541 | -1x | +649 | +53x |
- xlab = "xlab-b",+ interaction <- terms_name[which(!terms_name %in% names(xs_class))] |
| 542 | -1x | +650 | +53x |
- ylab = "ylab-l",+ checkmate::assert_subset(x, terms_name) |
| 543 | -1x | +651 | +53x |
- guide = "guide"+ if (length(interaction) != 0) {
|
| 544 | +652 |
- )+ # Make sure any item in x is not part of interaction term |
||
| 545 | -1x | -
- lapply(X = y, function(x) gtable::gtable_filter(g_el, x))- |
- ||
| 546 | -- |
- }- |
- ||
| 547 | -+ | 653 | +2x |
-
+ checkmate::assert_disjunct(x, unlist(strsplit(interaction, ":"))) |
| 548 | +654 |
- #' Helper function to prepare a KM layout+ } |
||
| 549 | -+ | |||
| 655 | +53x |
- #'+ x_stats <- lapply(x, h_glm_simple_term_extract, fit_glm) |
||
| 550 | -+ | |||
| 656 | +53x |
- #' @description `r lifecycle::badge("deprecated")`
+ x_stats <- do.call(rbind, x_stats) |
||
| 551 | -+ | |||
| 657 | +53x |
- #'+ q_norm <- stats::qnorm((1 + conf_level) / 2) |
||
| 552 | -+ | |||
| 658 | +53x |
- #' Prepares a (5 rows) x (2 cols) layout for the Kaplan-Meier curve.+ x_stats$odds_ratio <- lapply(x_stats$estimate, exp) |
||
| 553 | -+ | |||
| 659 | +53x |
- #'+ x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
||
| 554 | -+ | |||
| 660 | +53x |
- #' @inheritParams g_km+ x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
||
| 555 | -+ | |||
| 661 | +53x |
- #' @inheritParams h_ggkm+ x_stats$ci <- Map(function(lcl, ucl) c(lcl, ucl), lcl = x_stats$lcl, ucl = x_stats$ucl) |
||
| 556 | -+ | |||
| 662 | +53x |
- #' @param g_el (`list` of `gtable`)\cr list as obtained by `h_decompose_gg()`.+ x_stats |
||
| 557 | +663 |
- #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of+ } |
||
| 558 | +664 |
- #' patient at risk matching the main grid of the Kaplan-Meier curve.+ |
||
| 559 | +665 |
- #'+ #' @describeIn h_logistic_regression Helper function to tabulate the results including |
||
| 560 | +666 |
- #' @return A grid layout.+ #' odds ratios and confidence intervals of interaction terms. |
||
| 561 | +667 |
#' |
||
| 562 | -- |
- #' @details The layout corresponds to a grid of two columns and five rows of unequal dimensions. Most of the- |
- ||
| 563 | -- |
- #' dimension are fixed, only the curve is flexible and will accommodate with the remaining free space.- |
- ||
| 564 | -- |
- #' * The left column gets the annotation of the `ggplot` (y-axis) and the names of the strata for the patient- |
- ||
| 565 | -- |
- #' at risk tabulation. The main constraint is about the width of the columns which must allow the writing of- |
- ||
| 566 | -- |
- #' the strata name.- |
- ||
| 567 | +668 |
- #' * The right column receive the `ggplot`, the legend, the x-axis and the patient at risk table.+ #' @return Tabulated statistics for the given variable(s) from the logistic regression model. |
||
| 568 | +669 |
#' |
||
| 569 | +670 |
#' @examples |
||
| 570 | -- |
- #' \donttest{
- |
- ||
| 571 | -- |
- #' library(dplyr)- |
- ||
| 572 | -- |
- #' library(survival)- |
- ||
| 573 | +671 |
- #' library(grid)+ #' h_logistic_inter_terms(c("RACE", "AGE", "ARMCD", "AGE:ARMCD"), mod2)
|
||
| 574 | +672 |
#' |
||
| 575 | +673 |
- #' fit_km <- tern_ex_adtte %>%+ #' @export |
||
| 576 | +674 |
- #' filter(PARAMCD == "OS") %>%+ h_logistic_inter_terms <- function(x, |
||
| 577 | +675 |
- #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ fit_glm, |
||
| 578 | +676 |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ conf_level = 0.95, |
||
| 579 | +677 |
- #' xticks <- h_xticks(data = data_plot)+ at = NULL) {
|
||
| 580 | +678 |
- #' gg <- h_ggkm(+ # Find out the interaction variables and interaction term. |
||
| 581 | -+ | |||
| 679 | +5x |
- #' data = data_plot,+ inter_vars <- h_get_interaction_vars(fit_glm) |
||
| 582 | -+ | |||
| 680 | +5x |
- #' censor_show = TRUE,+ checkmate::assert_vector(inter_vars, len = 2) |
||
| 583 | +681 |
- #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ |
||
| 584 | +682 |
- #' title = "tt", footnotes = "ff", yval = "Survival"+ |
||
| 585 | -+ | |||
| 683 | +5x |
- #' )+ inter_term_index <- intersect(grep(inter_vars[1], x), grep(inter_vars[2], x)) |
||
| 586 | -+ | |||
| 684 | +5x |
- #' g_el <- h_decompose_gg(gg)+ inter_term <- x[inter_term_index] |
||
| 587 | +685 |
- #' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f")+ |
||
| 588 | +686 |
- #' grid.show.layout(lyt)+ # For the non-interaction vars we need the standard stuff. |
||
| 589 | -+ | |||
| 687 | +5x |
- #' }+ normal_terms <- setdiff(x, union(inter_vars, inter_term)) |
||
| 590 | +688 |
- #'+ |
||
| 591 | -+ | |||
| 689 | +5x |
- #' @export+ x_stats <- lapply(normal_terms, h_glm_simple_term_extract, fit_glm) |
||
| 592 | -+ | |||
| 690 | +5x |
- h_km_layout <- function(data, g_el, title, footnotes, annot_at_risk = TRUE, annot_at_risk_title = TRUE) {
+ x_stats <- do.call(rbind, x_stats) |
||
| 593 | -1x | +691 | +5x |
- lifecycle::deprecate_warn(+ q_norm <- stats::qnorm((1 + conf_level) / 2) |
| 594 | -1x | +692 | +5x |
- "0.9.4",+ x_stats$odds_ratio <- lapply(x_stats$estimate, exp) |
| 595 | -1x | +693 | +5x |
- "h_km_layout()",+ x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
| 596 | -1x | +694 | +5x |
- details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`."+ x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
| 597 | -+ | |||
| 695 | +5x |
- )+ normal_stats <- x_stats |
||
| 598 | -1x | +696 | +5x |
- txtlines <- levels(as.factor(data$strata))+ normal_stats$is_reference_summary <- FALSE |
| 599 | -1x | +|||
| 697 | +
- nlines <- nlevels(as.factor(data$strata))+ |
|||
| 600 | -1x | +|||
| 698 | +
- col_annot_width <- max(+ # Now the interaction term itself. |
|||
| 601 | -1x | +699 | +5x |
- c(+ inter_term_stats <- h_glm_interaction_extract(inter_term, fit_glm) |
| 602 | -1x | +700 | +5x |
- as.numeric(grid::convertX(g_el$yaxis$widths + g_el$ylab$widths, "pt")),+ inter_term_stats$odds_ratio <- NA |
| 603 | -1x | +701 | +5x |
- as.numeric(+ inter_term_stats$lcl <- NA |
| 604 | -1x | +702 | +5x |
- grid::convertX(+ inter_term_stats$ucl <- NA |
| 605 | -1x | +703 | +5x |
- grid::stringWidth(txtlines) + grid::unit(7, "pt"), "pt"+ inter_term_stats$is_reference_summary <- FALSE |
| 606 | +704 |
- )+ |
||
| 607 | -+ | |||
| 705 | +5x |
- )+ is_intervar1_numeric <- attr(fit_glm$terms, "dataClasses")[inter_vars[1]] == "numeric" |
||
| 608 | +706 |
- )+ |
||
| 609 | +707 |
- )+ # Interaction stuff. |
||
| 610 | -+ | |||
| 708 | +5x |
-
+ inter_stats_one <- h_glm_inter_term_extract( |
||
| 611 | -1x | +709 | +5x |
- ttl_row <- as.numeric(!is.null(title))+ inter_vars[1], |
| 612 | -1x | +710 | +5x |
- foot_row <- as.numeric(!is.null(footnotes))+ inter_vars[2], |
| 613 | -1x | +711 | +5x |
- no_tbl_ind <- c()+ fit_glm, |
| 614 | -1x | +712 | +5x |
- ht_x <- c()+ conf_level = conf_level, |
| 615 | -1x | +713 | +5x |
- ht_units <- c()+ at = `if`(is_intervar1_numeric, NULL, at) |
| 616 | +714 |
-
+ ) |
||
| 617 | -1x | +715 | +5x |
- if (ttl_row == 1) {
+ inter_stats_two <- h_glm_inter_term_extract( |
| 618 | -1x | +716 | +5x |
- no_tbl_ind <- c(no_tbl_ind, TRUE)+ inter_vars[2], |
| 619 | -1x | +717 | +5x |
- ht_x <- c(ht_x, 2)+ inter_vars[1], |
| 620 | -1x | +718 | +5x |
- ht_units <- c(ht_units, "lines")+ fit_glm,+ |
+
| 719 | +5x | +
+ conf_level = conf_level,+ |
+ ||
| 720 | +5x | +
+ at = `if`(is_intervar1_numeric, at, NULL) |
||
| 621 | +721 |
- }+ ) |
||
| 622 | +722 | |||
| 723 | ++ |
+ # Now just combine everything in one data frame.+ |
+ ||
| 623 | -1x | +724 | +5x |
- no_tbl_ind <- c(no_tbl_ind, rep(TRUE, 3), rep(FALSE, 2))+ col_names <- c( |
| 624 | -1x | +725 | +5x |
- ht_x <- c(+ "variable", |
| 625 | -1x | +726 | +5x |
- ht_x,+ "variable_label", |
| 626 | -1x | +727 | +5x |
- 1,+ "term", |
| 627 | -1x | +728 | +5x |
- grid::convertX(with(g_el, xaxis$heights + ylab$widths), "pt") + grid::unit(5, "pt"),+ "term_label", |
| 628 | -1x | +729 | +5x |
- grid::convertX(g_el$guide$heights, "pt") + grid::unit(2, "pt"),+ "interaction", |
| 629 | -1x | +730 | +5x |
- 1,+ "interaction_label", |
| 630 | -1x | +731 | +5x |
- nlines + 0.5,+ "reference", |
| 631 | -1x | +732 | +5x |
- grid::convertX(with(g_el, xaxis$heights + ylab$widths), "pt")+ "reference_label", |
| 632 | -+ | |||
| 733 | +5x |
- )+ "estimate", |
||
| 633 | -1x | +734 | +5x |
- ht_units <- c(+ "std_error", |
| 634 | -1x | +735 | +5x |
- ht_units,+ "df", |
| 635 | -1x | +736 | +5x |
- "null",+ "pvalue", |
| 636 | -1x | +737 | +5x |
- "pt",+ "odds_ratio", |
| 637 | -1x | +738 | +5x |
- "pt",+ "lcl", |
| 638 | -1x | +739 | +5x |
- "lines",+ "ucl", |
| 639 | -1x | +740 | +5x |
- "lines",+ "is_variable_summary", |
| 640 | -1x | +741 | +5x |
- "pt"+ "is_term_summary", |
| 641 | -+ | |||
| 742 | +5x |
- )+ "is_reference_summary" |
||
| 642 | +743 |
-
+ ) |
||
| 643 | -1x | +744 | +5x |
- if (foot_row == 1) {
+ df <- rbind( |
| 644 | -1x | +745 | +5x |
- no_tbl_ind <- c(no_tbl_ind, TRUE)+ inter_stats_one[, col_names], |
| 645 | -1x | +746 | +5x |
- ht_x <- c(ht_x, 1)+ inter_stats_two[, col_names], |
| 646 | -1x | +747 | +5x |
- ht_units <- c(ht_units, "lines")+ inter_term_stats[, col_names] |
| 647 | +748 |
- }+ ) |
||
| 648 | -1x | +749 | +5x |
- if (annot_at_risk) {
+ if (length(normal_terms) > 0) {
|
| 649 | -1x | +750 | +5x |
- no_at_risk_tbl <- rep(TRUE, 6 + ttl_row + foot_row)+ df <- rbind( |
| 650 | -1x | -
- if (!annot_at_risk_title) {
- |
- ||
| 651 | -! | +751 | +5x |
- no_at_risk_tbl[length(no_at_risk_tbl) - 2 - foot_row] <- FALSE+ normal_stats[, col_names], |
| 652 | -+ | |||
| 752 | +5x |
- }+ df |
||
| 653 | +753 |
- } else {
- |
- ||
| 654 | -! | -
- no_at_risk_tbl <- no_tbl_ind+ ) |
||
| 655 | +754 |
} |
||
| 656 | -- | - - | -||
| 657 | -1x | -
- grid::grid.layout(- |
- ||
| 658 | -1x | +755 | +5x |
- nrow = sum(no_at_risk_tbl), ncol = 2,+ df$ci <- combine_vectors(df$lcl, df$ucl) |
| 659 | -1x | +756 | +5x |
- widths = grid::unit(c(col_annot_width, 1), c("pt", "null")),
+ df |
| 660 | -1x | +|||
| 757 | +
- heights = grid::unit(+ } |
|||
| 661 | -1x | +
| 1 | +
- x = ht_x[no_at_risk_tbl],+ #' Proportion difference estimation |
|||
| 662 | -1x | +|||
| 2 | +
- units = ht_units[no_at_risk_tbl]+ #' |
|||
| 663 | +3 |
- )+ #' @description `r lifecycle::badge("stable")`
|
||
| 664 | +4 |
- )+ #' |
||
| 665 | +5 |
- }+ #' The analysis function [estimate_proportion_diff()] creates a layout element to estimate the difference in proportion |
||
| 666 | +6 |
-
+ #' of responders within a studied population. The primary analysis variable, `vars`, is a logical variable indicating |
||
| 667 | +7 |
- #' Helper function to create patient-at-risk grobs+ #' whether a response has occurred for each record. See the `method` parameter for options of methods to use when |
||
| 668 | +8 |
- #'+ #' constructing the confidence interval of the proportion difference. A stratification variable can be supplied via the |
||
| 669 | +9 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' `strata` element of the `variables` argument. |
||
| 670 | +10 |
#' |
||
| 671 | +11 |
- #' Two graphical objects are obtained, one corresponding to row labeling and the second to the table of+ #' |
||
| 672 | +12 |
- #' numbers of patients at risk. If `title = TRUE`, a third object corresponding to the table title is+ #' @inheritParams prop_diff_strat_nc |
||
| 673 | +13 |
- #' also obtained.+ #' @inheritParams argument_convention |
||
| 674 | +14 |
- #'+ #' @param method (`string`)\cr the method used for the confidence interval estimation. |
||
| 675 | +15 |
- #' @inheritParams g_km+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_proportion_diff")`
|
||
| 676 | +16 |
- #' @inheritParams h_ggkm+ #' to see available statistics for this function. |
||
| 677 | +17 |
- #' @param annot_tbl (`data.frame`)\cr annotation as prepared by [survival::summary.survfit()] which+ #' |
||
| 678 | +18 |
- #' includes the number of patients at risk at given time points.+ #' @seealso [d_proportion_diff()] |
||
| 679 | +19 |
- #' @param xlim (`numeric(1)`)\cr the maximum value on the x-axis (used to ensure the at risk table aligns with the KM+ #' |
||
| 680 | +20 |
- #' graph).+ #' @name prop_diff |
||
| 681 | +21 |
- #' @param title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk`+ #' @order 1 |
||
| 682 | +22 |
- #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`.+ NULL |
||
| 683 | +23 |
- #'+ |
||
| 684 | +24 |
- #' @return A named `list` of two `gTree` objects if `title = FALSE`: `at_risk` and `label`, or three+ #' @describeIn prop_diff Statistics function estimating the difference |
||
| 685 | +25 |
- #' `gTree` objects if `title = TRUE`: `at_risk`, `label`, and `title`.+ #' in terms of responder proportion. |
||
| 686 | +26 |
#' |
||
| 687 | +27 |
- #' @examples+ #' @return |
||
| 688 | +28 |
- #' \donttest{
+ #' * `s_proportion_diff()` returns a named list of elements `diff` and `diff_ci`. |
||
| 689 | +29 |
- #' library(dplyr)+ #' |
||
| 690 | +30 |
- #' library(survival)+ #' @note When performing an unstratified analysis, methods `"cmh"`, `"strat_newcombe"`, and `"strat_newcombecc"` are |
||
| 691 | +31 |
- #' library(grid)+ #' not permitted. |
||
| 692 | +32 |
#' |
||
| 693 | +33 |
- #' fit_km <- tern_ex_adtte %>%+ #' @examples |
||
| 694 | +34 |
- #' filter(PARAMCD == "OS") %>%+ #' s_proportion_diff( |
||
| 695 | +35 |
- #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ #' df = subset(dta, grp == "A"), |
||
| 696 | +36 |
- #'+ #' .var = "rsp", |
||
| 697 | +37 |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ #' .ref_group = subset(dta, grp == "B"), |
||
| 698 | +38 |
- #'+ #' .in_ref_col = FALSE, |
||
| 699 | +39 |
- #' xticks <- h_xticks(data = data_plot)+ #' conf_level = 0.90, |
||
| 700 | +40 |
- #'+ #' method = "ha" |
||
| 701 | +41 |
- #' gg <- h_ggkm(+ #' ) |
||
| 702 | +42 |
- #' data = data_plot,+ #' |
||
| 703 | +43 |
- #' censor_show = TRUE,+ #' # CMH example with strata |
||
| 704 | +44 |
- #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ #' s_proportion_diff( |
||
| 705 | +45 |
- #' title = "tt", footnotes = "ff", yval = "Survival"+ #' df = subset(dta, grp == "A"), |
||
| 706 | +46 |
- #' )+ #' .var = "rsp", |
||
| 707 | +47 |
- #'+ #' .ref_group = subset(dta, grp == "B"), |
||
| 708 | +48 |
- #' # The annotation table reports the patient at risk for a given strata and+ #' .in_ref_col = FALSE, |
||
| 709 | +49 |
- #' # times (`xticks`).+ #' variables = list(strata = c("f1", "f2")),
|
||
| 710 | +50 |
- #' annot_tbl <- summary(fit_km, times = xticks)+ #' conf_level = 0.90, |
||
| 711 | +51 |
- #' if (is.null(fit_km$strata)) {
+ #' method = "cmh" |
||
| 712 | +52 |
- #' annot_tbl <- with(annot_tbl, data.frame(n.risk = n.risk, time = time, strata = "All"))+ #' ) |
||
| 713 | +53 |
- #' } else {
+ #' |
||
| 714 | +54 |
- #' strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
+ #' @export |
||
| 715 | +55 |
- #' levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2]+ s_proportion_diff <- function(df, |
||
| 716 | +56 |
- #' annot_tbl <- data.frame(+ .var, |
||
| 717 | +57 |
- #' n.risk = annot_tbl$n.risk,+ .ref_group, |
||
| 718 | +58 |
- #' time = annot_tbl$time,+ .in_ref_col, |
||
| 719 | +59 |
- #' strata = annot_tbl$strata+ variables = list(strata = NULL), |
||
| 720 | +60 |
- #' )+ conf_level = 0.95, |
||
| 721 | +61 |
- #' }+ method = c( |
||
| 722 | +62 |
- #'+ "waldcc", "wald", "cmh", |
||
| 723 | +63 |
- #' # The annotation table is transformed into a grob.+ "ha", "newcombe", "newcombecc", |
||
| 724 | +64 |
- #' tbl <- h_grob_tbl_at_risk(data = data_plot, annot_tbl = annot_tbl, xlim = max(xticks))+ "strat_newcombe", "strat_newcombecc" |
||
| 725 | +65 |
- #'+ ), |
||
| 726 | +66 |
- #' # For the representation, the layout is estimated for which the decomposition+ weights_method = "cmh") {
|
||
| 727 | -+ | |||
| 67 | +2x |
- #' # of the graphic element is necessary.+ method <- match.arg(method) |
||
| 728 | -+ | |||
| 68 | +2x |
- #' g_el <- h_decompose_gg(gg)+ if (is.null(variables$strata) && checkmate::test_subset(method, c("cmh", "strat_newcombe", "strat_newcombecc"))) {
|
||
| 729 | -+ | |||
| 69 | +! |
- #' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f")+ stop(paste( |
||
| 730 | -+ | |||
| 70 | +! |
- #'+ "When performing an unstratified analysis, methods 'cmh', 'strat_newcombe', and 'strat_newcombecc' are not", |
||
| 731 | -+ | |||
| 71 | +! |
- #' grid::grid.newpage()+ "permitted. Please choose a different method." |
||
| 732 | +72 |
- #' pushViewport(viewport(layout = lyt, height = .95, width = .95))+ )) |
||
| 733 | +73 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "purple", fill = "gray85", lwd = 1))+ } |
||
| 734 | -+ | |||
| 74 | +2x |
- #' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 2))+ y <- list(diff = "", diff_ci = "") |
||
| 735 | +75 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "orange", fill = "gray85", lwd = 1))+ |
||
| 736 | -+ | |||
| 76 | +2x |
- #' grid::grid.draw(tbl$at_risk)+ if (!.in_ref_col) {
|
||
| 737 | -+ | |||
| 77 | +2x |
- #' popViewport()+ rsp <- c(.ref_group[[.var]], df[[.var]]) |
||
| 738 | -+ | |||
| 78 | +2x |
- #' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 1))+ grp <- factor( |
||
| 739 | -+ | |||
| 79 | +2x |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "green3", fill = "gray85", lwd = 1))+ rep( |
||
| 740 | -+ | |||
| 80 | +2x |
- #' grid::grid.draw(tbl$label)+ c("ref", "Not-ref"),
|
||
| 741 | -+ | |||
| 81 | +2x |
- #' }+ c(nrow(.ref_group), nrow(df)) |
||
| 742 | +82 |
- #'+ ),+ |
+ ||
| 83 | +2x | +
+ levels = c("ref", "Not-ref")
|
||
| 743 | +84 |
- #' @export+ ) |
||
| 744 | +85 |
- h_grob_tbl_at_risk <- function(data, annot_tbl, xlim, title = TRUE) {
+
|
||
| 745 | -1x | +86 | +2x |
- lifecycle::deprecate_warn(+ if (!is.null(variables$strata)) {
|
| 746 | +87 | 1x |
- "0.9.4",+ strata_colnames <- variables$strata |
|
| 747 | +88 | 1x |
- "h_grob_tbl_at_risk()",+ checkmate::assert_character(strata_colnames, null.ok = FALSE) |
|
| 748 | +89 | 1x |
- details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`."+ strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames) |
|
| 749 | +90 |
- )+ |
||
| 750 | +91 | 1x |
- txtlines <- levels(as.factor(data$strata))+ assert_df_with_variables(df, strata_vars) |
|
| 751 | +92 | 1x |
- nlines <- nlevels(as.factor(data$strata))+ assert_df_with_variables(.ref_group, strata_vars) |
|
| 752 | -1x | +|||
| 93 | +
- y_int <- annot_tbl$time[2] - annot_tbl$time[1]+ |
|||
| 753 | -1x | +|||
| 94 | +
- annot_tbl <- expand.grid(+ # Merging interaction strata for reference group rows data and remaining |
|||
| 754 | +95 | 1x |
- time = seq(0, xlim, y_int),+ strata <- c( |
|
| 755 | +96 | 1x |
- strata = unique(annot_tbl$strata)+ interaction(.ref_group[strata_colnames]), |
|
| 756 | +97 | 1x |
- ) %>% dplyr::left_join(annot_tbl, by = c("time", "strata"))
+ interaction(df[strata_colnames]) |
|
| 757 | -1x | +|||
| 98 | +
- annot_tbl[is.na(annot_tbl)] <- 0+ ) |
|||
| 758 | +99 | 1x |
- y_str_unit <- as.numeric(annot_tbl$strata)+ strata <- as.factor(strata) |
|
| 759 | -1x | +|||
| 100 | +
- vp_table <- grid::plotViewport(margins = grid::unit(c(0, 0, 0, 0), "lines"))+ } |
|||
| 760 | +101 |
- if (title) {
+
+ |
+ ||
| 102 | ++ |
+ # Defining the std way to calculate weights for strat_newcombe |
||
| 761 | -1x | +103 | +2x |
- gb_table_title <- grid::gList(+ if (!is.null(variables$weights_method)) {
+ |
+
| 104 | +! | +
+ weights_method <- variables$weights_method+ |
+ ||
| 105 | ++ |
+ } else {
|
||
| 762 | -1x | +106 | +2x |
- grid::textGrob(+ weights_method <- "cmh"+ |
+
| 107 | ++ |
+ }+ |
+ ||
| 108 | ++ | + | ||
| 763 | -1x | +109 | +2x |
- label = "Patients at Risk:",+ y <- switch(method, |
| 764 | -1x | +110 | +2x |
- x = 1,+ "wald" = prop_diff_wald(rsp, grp, conf_level, correct = FALSE), |
| 765 | -1x | +111 | +2x |
- y = grid::unit(0.2, "native"),+ "waldcc" = prop_diff_wald(rsp, grp, conf_level, correct = TRUE), |
| 766 | -1x | +112 | +2x |
- gp = grid::gpar(fontface = "bold", fontsize = 10)+ "ha" = prop_diff_ha(rsp, grp, conf_level), |
| 767 | -+ | |||
| 113 | +2x |
- )+ "newcombe" = prop_diff_nc(rsp, grp, conf_level, correct = FALSE), |
||
| 768 | -+ | |||
| 114 | +2x |
- )+ "newcombecc" = prop_diff_nc(rsp, grp, conf_level, correct = TRUE), |
||
| 769 | -+ | |||
| 115 | +2x |
- }+ "strat_newcombe" = prop_diff_strat_nc(rsp, |
||
| 770 | -1x | +116 | +2x |
- gb_table_left_annot <- grid::gList(+ grp, |
| 771 | -1x | +117 | +2x |
- grid::rectGrob(+ strata, |
| 772 | -1x | +118 | +2x |
- x = 0, y = grid::unit(c(1:nlines) - 1, "lines"),+ weights_method, |
| 773 | -1x | +119 | +2x |
- gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
+ conf_level, |
| 774 | -1x | +120 | +2x |
- height = grid::unit(1, "lines"), just = "bottom", hjust = 0+ correct = FALSE |
| 775 | +121 |
- ),+ ), |
||
| 776 | -1x | +122 | +2x |
- grid::textGrob(+ "strat_newcombecc" = prop_diff_strat_nc(rsp, |
| 777 | -1x | +123 | +2x |
- label = unique(annot_tbl$strata),+ grp, |
| 778 | -1x | +124 | +2x |
- x = 0.5,+ strata, |
| 779 | -1x | +125 | +2x |
- y = grid::unit(+ weights_method, |
| 780 | -1x | +126 | +2x |
- (max(unique(y_str_unit)) - unique(y_str_unit)) + 0.75,+ conf_level, |
| 781 | -1x | +127 | +2x |
- "native"+ correct = TRUE |
| 782 | +128 |
), |
||
| 783 | -1x | +129 | +2x |
- gp = grid::gpar(fontface = "italic", fontsize = 10)+ "cmh" = prop_diff_cmh(rsp, grp, strata, conf_level)[c("diff", "diff_ci")]
|
| 784 | +130 |
) |
||
| 785 | +131 |
- )- |
- ||
| 786 | -1x | -
- gb_patient_at_risk <- grid::gList(- |
- ||
| 787 | -1x | -
- grid::rectGrob(+ |
||
| 788 | -1x | +132 | +2x |
- x = 0, y = grid::unit(c(1:nlines) - 1, "lines"),+ y$diff <- y$diff * 100 |
| 789 | -1x | +133 | +2x |
- gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
+ y$diff_ci <- y$diff_ci * 100 |
| 790 | -1x | +|||
| 134 | +
- height = grid::unit(1, "lines"), just = "bottom", hjust = 0+ } |
|||
| 791 | +135 |
- ),+ |
||
| 792 | -1x | +136 | +2x |
- grid::textGrob(+ attr(y$diff, "label") <- "Difference in Response rate (%)" |
| 793 | -1x | +137 | +2x |
- label = annot_tbl$n.risk,+ attr(y$diff_ci, "label") <- d_proportion_diff( |
| 794 | -1x | +138 | +2x |
- x = grid::unit(annot_tbl$time, "native"),+ conf_level, method, |
| 795 | -1x | +139 | +2x |
- y = grid::unit(+ long = FALSE |
| 796 | -1x | +|||
| 140 | +
- (max(y_str_unit) - y_str_unit) + .5,+ ) |
|||
| 797 | -1x | +|||
| 141 | +
- "line"+ |
|||
| 798 | -1x | +142 | +2x |
- ) # maybe native+ y |
| 799 | +143 |
- )+ } |
||
| 800 | +144 |
- )+ |
||
| 801 | +145 |
-
+ #' @describeIn prop_diff Formatted analysis function which is used as `afun` in `estimate_proportion_diff()`. |
||
| 802 | -1x | +|||
| 146 | +
- ret <- list(+ #' |
|||
| 803 | -1x | +|||
| 147 | +
- at_risk = grid::gList(+ #' @return |
|||
| 804 | -1x | +|||
| 148 | +
- grid::gTree(+ #' * `a_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 805 | -1x | +|||
| 149 | +
- vp = vp_table,+ #' |
|||
| 806 | -1x | +|||
| 150 | +
- children = grid::gList(+ #' @examples |
|||
| 807 | -1x | +|||
| 151 | +
- grid::gTree(+ #' a_proportion_diff( |
|||
| 808 | -1x | +|||
| 152 | +
- vp = grid::dataViewport(+ #' df = subset(dta, grp == "A"), |
|||
| 809 | -1x | +|||
| 153 | +
- xscale = c(0, xlim) + c(-0.05, 0.05) * xlim,+ #' .var = "rsp", |
|||
| 810 | -1x | +|||
| 154 | +
- yscale = c(0, nlines + 1),+ #' .ref_group = subset(dta, grp == "B"), |
|||
| 811 | -1x | +|||
| 155 | +
- extension = c(0.05, 0)+ #' .in_ref_col = FALSE, |
|||
| 812 | +156 |
- ),+ #' conf_level = 0.90, |
||
| 813 | -1x | +|||
| 157 | +
- children = grid::gList(gb_patient_at_risk)+ #' method = "ha" |
|||
| 814 | +158 |
- )+ #' ) |
||
| 815 | +159 |
- )+ #' |
||
| 816 | +160 |
- )+ #' @export |
||
| 817 | +161 |
- ),+ a_proportion_diff <- make_afun( |
||
| 818 | -1x | +|||
| 162 | +
- label = grid::gList(+ s_proportion_diff, |
|||
| 819 | -1x | +|||
| 163 | +
- grid::gTree(+ .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"), |
|||
| 820 | -1x | +|||
| 164 | +
- vp = grid::viewport(width = max(grid::stringWidth(txtlines))),+ .indent_mods = c(diff = 0L, diff_ci = 1L) |
|||
| 821 | -1x | +|||
| 165 | +
- children = grid::gList(+ ) |
|||
| 822 | -1x | +|||
| 166 | +
- grid::gTree(+ |
|||
| 823 | -1x | +|||
| 167 | +
- vp = grid::dataViewport(+ #' @describeIn prop_diff Layout-creating function which can take statistics function arguments |
|||
| 824 | -1x | +|||
| 168 | +
- xscale = 0:1,+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 825 | -1x | +|||
| 169 | +
- yscale = c(0, nlines + 1),+ #' |
|||
| 826 | -1x | +|||
| 170 | +
- extension = c(0.0, 0)+ #' @return |
|||
| 827 | +171 |
- ),+ #' * `estimate_proportion_diff()` returns a layout object suitable for passing to further layouting functions, |
||
| 828 | -1x | +|||
| 172 | +
- children = grid::gList(gb_table_left_annot)+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 829 | +173 |
- )+ #' the statistics from `s_proportion_diff()` to the table layout. |
||
| 830 | +174 |
- )+ #' |
||
| 831 | +175 |
- )+ #' @examples |
||
| 832 | +176 |
- )+ #' ## "Mid" case: 4/4 respond in group A, 1/2 respond in group B. |
||
| 833 | +177 |
- )+ #' nex <- 100 # Number of example rows |
||
| 834 | +178 |
-
+ #' dta <- data.frame( |
||
| 835 | -1x | +|||
| 179 | +
- if (title) {
+ #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE), |
|||
| 836 | -1x | +|||
| 180 | +
- ret[["title"]] <- grid::gList(+ #' "grp" = sample(c("A", "B"), nex, TRUE),
|
|||
| 837 | -1x | +|||
| 181 | +
- grid::gTree(+ #' "f1" = sample(c("a1", "a2"), nex, TRUE),
|
|||
| 838 | -1x | +|||
| 182 | +
- vp = grid::viewport(width = max(grid::stringWidth(txtlines))),+ #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
|
|||
| 839 | -1x | +|||
| 183 | +
- children = grid::gList(+ #' stringsAsFactors = TRUE |
|||
| 840 | -1x | +|||
| 184 | +
- grid::gTree(+ #' ) |
|||
| 841 | -1x | +|||
| 185 | +
- vp = grid::dataViewport(+ #' |
|||
| 842 | -1x | +|||
| 186 | +
- xscale = 0:1,+ #' l <- basic_table() %>% |
|||
| 843 | -1x | +|||
| 187 | +
- yscale = c(0, 1),+ #' split_cols_by(var = "grp", ref_group = "B") %>% |
|||
| 844 | -1x | +|||
| 188 | +
- extension = c(0, 0)+ #' estimate_proportion_diff( |
|||
| 845 | +189 |
- ),+ #' vars = "rsp", |
||
| 846 | -1x | +|||
| 190 | +
- children = grid::gList(gb_table_title)+ #' conf_level = 0.90, |
|||
| 847 | +191 |
- )+ #' method = "ha" |
||
| 848 | +192 |
- )+ #' ) |
||
| 849 | +193 |
- )+ #' |
||
| 850 | +194 |
- )+ #' build_table(l, df = dta) |
||
| 851 | +195 |
- }+ #' |
||
| 852 | +196 |
-
+ #' @export |
||
| 853 | -1x | +|||
| 197 | +
- ret+ #' @order 2 |
|||
| 854 | +198 |
- }+ estimate_proportion_diff <- function(lyt, |
||
| 855 | +199 |
-
+ vars, |
||
| 856 | +200 |
- #' Helper function to create survival estimation grobs+ variables = list(strata = NULL), |
||
| 857 | +201 |
- #'+ conf_level = 0.95, |
||
| 858 | +202 |
- #' @description `r lifecycle::badge("deprecated")`
+ method = c( |
||
| 859 | +203 |
- #'+ "waldcc", "wald", "cmh", |
||
| 860 | +204 |
- #' The survival fit is transformed in a grob containing a table with groups in+ "ha", "newcombe", "newcombecc", |
||
| 861 | +205 |
- #' rows characterized by N, median and 95% confidence interval.+ "strat_newcombe", "strat_newcombecc" |
||
| 862 | +206 |
- #'+ ), |
||
| 863 | +207 |
- #' @inheritParams g_km+ weights_method = "cmh", |
||
| 864 | +208 |
- #' @inheritParams h_data_plot+ na_str = default_na_str(), |
||
| 865 | +209 |
- #' @param ttheme (`list`)\cr see [gridExtra::ttheme_default()].+ nested = TRUE, |
||
| 866 | +210 |
- #' @param x (`proportion`)\cr a value between 0 and 1 specifying x-location.+ ..., |
||
| 867 | +211 |
- #' @param y (`proportion`)\cr a value between 0 and 1 specifying y-location.+ var_labels = vars, |
||
| 868 | +212 |
- #' @param width (`grid::unit`)\cr width (as a unit) to use when printing the grob.+ show_labels = "hidden", |
||
| 869 | +213 |
- #'+ table_names = vars, |
||
| 870 | +214 |
- #' @return A `grob` of a table containing statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`).+ .stats = NULL, |
||
| 871 | +215 |
- #'+ .formats = NULL, |
||
| 872 | +216 |
- #' @examples+ .labels = NULL, |
||
| 873 | +217 |
- #' \donttest{
+ .indent_mods = NULL) {
+ |
+ ||
| 218 | +4x | +
+ extra_args <- list(+ |
+ ||
| 219 | +4x | +
+ variables = variables, conf_level = conf_level, method = method, weights_method = weights_method, ... |
||
| 874 | +220 |
- #' library(dplyr)+ ) |
||
| 875 | +221 |
- #' library(survival)+ + |
+ ||
| 222 | +4x | +
+ afun <- make_afun(+ |
+ ||
| 223 | +4x | +
+ a_proportion_diff,+ |
+ ||
| 224 | +4x | +
+ .stats = .stats,+ |
+ ||
| 225 | +4x | +
+ .formats = .formats,+ |
+ ||
| 226 | +4x | +
+ .labels = .labels,+ |
+ ||
| 227 | +4x | +
+ .indent_mods = .indent_mods |
||
| 876 | +228 |
- #' library(grid)+ ) |
||
| 877 | +229 |
- #'+ + |
+ ||
| 230 | +4x | +
+ analyze(+ |
+ ||
| 231 | +4x | +
+ lyt,+ |
+ ||
| 232 | +4x | +
+ vars,+ |
+ ||
| 233 | +4x | +
+ afun = afun,+ |
+ ||
| 234 | +4x | +
+ var_labels = var_labels,+ |
+ ||
| 235 | +4x | +
+ na_str = na_str,+ |
+ ||
| 236 | +4x | +
+ nested = nested,+ |
+ ||
| 237 | +4x | +
+ extra_args = extra_args,+ |
+ ||
| 238 | +4x | +
+ show_labels = show_labels,+ |
+ ||
| 239 | +4x | +
+ table_names = table_names |
||
| 878 | +240 |
- #' grid::grid.newpage()+ ) |
||
| 879 | +241 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1))+ } |
||
| 880 | +242 |
- #' tern_ex_adtte %>%+ |
||
| 881 | +243 |
- #' filter(PARAMCD == "OS") %>%+ #' Check proportion difference arguments |
||
| 882 | +244 |
- #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ #' |
||
| 883 | +245 |
- #' h_grob_median_surv() %>%+ #' Verifies that and/or convert arguments into valid values to be used in the |
||
| 884 | +246 |
- #' grid::grid.draw()+ #' estimation of difference in responder proportions. |
||
| 885 | +247 |
- #' }+ #' |
||
| 886 | +248 |
- #'+ #' @inheritParams prop_diff |
||
| 887 | +249 |
- #' @export+ #' @inheritParams prop_diff_wald |
||
| 888 | +250 |
- h_grob_median_surv <- function(fit_km,+ #' |
||
| 889 | +251 |
- armval = "All",+ #' @keywords internal |
||
| 890 | +252 |
- x = 0.9,+ check_diff_prop_ci <- function(rsp, |
||
| 891 | +253 |
- y = 0.9,+ grp, |
||
| 892 | +254 |
- width = grid::unit(0.3, "npc"),+ strata = NULL, |
||
| 893 | +255 |
- ttheme = gridExtra::ttheme_default()) {
+ conf_level,+ |
+ ||
| 256 | ++ |
+ correct = NULL) {
|
||
| 894 | -1x | +257 | +26x |
- lifecycle::deprecate_warn(+ checkmate::assert_logical(rsp, any.missing = FALSE) |
| 895 | -1x | +258 | +26x |
- "0.9.4",+ checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) |
| 896 | -1x | +259 | +26x |
- "h_grob_median_surv()",+ checkmate::assert_number(conf_level, lower = 0, upper = 1) |
| 897 | -1x | +260 | +26x |
- details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`."+ checkmate::assert_flag(correct, null.ok = TRUE) |
| 898 | +261 |
- )+ |
||
| 899 | -1x | +262 | +26x |
- data <- h_tbl_median_surv(fit_km, armval = armval)+ if (!is.null(strata)) {
+ |
+
| 263 | +12x | +
+ checkmate::assert_factor(strata, len = length(rsp)) |
||
| 900 | +264 | ++ |
+ }+ |
+ |
| 265 | ||||
| 901 | -1x | +266 | +26x |
- width <- grid::convertUnit(grid::unit(as.numeric(width), grid::unitType(width)), "in")+ invisible() |
| 902 | -1x | +|||
| 267 | +
- height <- width * (nrow(data) + 1) / 12+ } |
|||
| 903 | +268 | |||
| 904 | -1x | +|||
| 269 | +
- w <- paste(" ", c(
+ #' Description of method used for proportion comparison |
|||
| 905 | -1x | +|||
| 270 | +
- rownames(data)[which.max(nchar(rownames(data)))],+ #' |
|||
| 906 | -1x | +|||
| 271 | +
- sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))])+ #' @description `r lifecycle::badge("stable")`
|
|||
| 907 | +272 |
- ))+ #' |
||
| 908 | -1x | +|||
| 273 | +
- w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE)+ #' This is an auxiliary function that describes the analysis in |
|||
| 909 | +274 |
-
+ #' [s_proportion_diff()]. |
||
| 910 | -1x | +|||
| 275 | +
- w_txt <- sapply(1:64, function(x) {
+ #' |
|||
| 911 | -64x | +|||
| 276 | +
- graphics::par(ps = x)+ #' @inheritParams s_proportion_diff |
|||
| 912 | -64x | +|||
| 277 | +
- graphics::strwidth(w[4], units = "in")+ #' @param long (`flag`)\cr whether a long (`TRUE`) or a short (`FALSE`, default) description is required. |
|||
| 913 | +278 |
- })+ #' |
||
| 914 | -1x | +|||
| 279 | +
- f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]])+ #' @return A `string` describing the analysis. |
|||
| 915 | +280 |
-
+ #' |
||
| 916 | -1x | +|||
| 281 | +
- h_txt <- sapply(1:64, function(x) {
+ #' @seealso [prop_diff] |
|||
| 917 | -64x | +|||
| 282 | +
- graphics::par(ps = x)+ #' |
|||
| 918 | -64x | +|||
| 283 | +
- graphics::strheight(grid::stringHeight("X"), units = "in")
+ #' @export |
|||
| 919 | +284 |
- })+ d_proportion_diff <- function(conf_level, |
||
| 920 | -1x | +|||
| 285 | +
- f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))])+ method, |
|||
| 921 | +286 |
-
+ long = FALSE) {
|
||
| 922 | -1x | +287 | +11x |
- if (ttheme$core$fg_params$fontsize == 12) {
+ label <- paste0(conf_level * 100, "% CI") |
| 923 | -1x | +288 | +11x |
- ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h)+ if (long) {
|
| 924 | -1x | +|||
| 289 | +! |
- ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ label <- paste( |
||
| 925 | -1x | +|||
| 290 | +! |
- ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ label,+ |
+ ||
| 291 | +! | +
+ ifelse(+ |
+ ||
| 292 | +! | +
+ method == "cmh",+ |
+ ||
| 293 | +! | +
+ "for adjusted difference",+ |
+ ||
| 294 | +! | +
+ "for difference" |
||
| 926 | +295 |
- }+ ) |
||
| 927 | +296 |
-
+ ) |
||
| 928 | -1x | +|||
| 297 | +
- gt <- gridExtra::tableGrob(+ } |
|||
| 929 | -1x | +|||
| 298 | +
- d = data,+ |
|||
| 930 | -1x | +299 | +11x |
- theme = ttheme+ method_part <- switch(method, |
| 931 | -+ | |||
| 300 | +11x |
- )+ "cmh" = "CMH, without correction", |
||
| 932 | -1x | +301 | +11x |
- gt$widths <- ((w_unit / sum(w_unit)) * width)+ "waldcc" = "Wald, with correction", |
| 933 | -1x | +302 | +11x |
- gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt))+ "wald" = "Wald, without correction", |
| 934 | -+ | |||
| 303 | +11x |
-
+ "ha" = "Anderson-Hauck", |
||
| 935 | -1x | +304 | +11x |
- vp <- grid::viewport(+ "newcombe" = "Newcombe, without correction", |
| 936 | -1x | +305 | +11x |
- x = grid::unit(x, "npc") + grid::unit(1, "lines"),+ "newcombecc" = "Newcombe, with correction", |
| 937 | -1x | +306 | +11x |
- y = grid::unit(y, "npc") + grid::unit(1.5, "lines"),+ "strat_newcombe" = "Stratified Newcombe, without correction", |
| 938 | -1x | +307 | +11x |
- height = height,+ "strat_newcombecc" = "Stratified Newcombe, with correction", |
| 939 | -1x | +308 | +11x | +
+ stop(paste(method, "does not have a description"))+ |
+
| 309 | +
- width = width,+ ) |
|||
| 940 | -1x | +310 | +11x |
- just = c("right", "top")
+ paste0(label, " (", method_part, ")")
|
| 941 | +311 |
- )+ } |
||
| 942 | +312 | |||
| 943 | -1x | +|||
| 313 | +
- grid::gList(+ #' Helper functions to calculate proportion difference |
|||
| 944 | -1x | +|||
| 314 | +
- grid::gTree(+ #' |
|||
| 945 | -1x | +|||
| 315 | +
- vp = vp,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 946 | -1x | +|||
| 316 | +
- children = grid::gList(gt)+ #' |
|||
| 947 | +317 |
- )+ #' @inheritParams argument_convention |
||
| 948 | +318 |
- )+ #' @inheritParams prop_diff |
||
| 949 | +319 |
- }+ #' @param grp (`factor`)\cr vector assigning observations to one out of two groups |
||
| 950 | +320 |
-
+ #' (e.g. reference and treatment group). |
||
| 951 | +321 |
- #' Helper function to create grid object with y-axis annotation+ #' |
||
| 952 | +322 |
- #'+ #' @return A named `list` of elements `diff` (proportion difference) and `diff_ci` |
||
| 953 | +323 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' (proportion difference confidence interval). |
||
| 954 | +324 |
#' |
||
| 955 | +325 |
- #' Build the y-axis annotation from a decomposed `ggplot`.+ #' @seealso [prop_diff()] for implementation of these helper functions. |
||
| 956 | +326 |
#' |
||
| 957 | +327 |
- #' @param ylab (`gtable`)\cr the y-lab as a graphical object derived from a `ggplot`.+ #' @name h_prop_diff |
||
| 958 | +328 |
- #' @param yaxis (`gtable`)\cr the y-axis as a graphical object derived from a `ggplot`.+ NULL |
||
| 959 | +329 |
- #'+ |
||
| 960 | +330 |
- #' @return A `gTree` object containing the y-axis annotation from a `ggplot`.+ #' @describeIn h_prop_diff The Wald interval follows the usual textbook |
||
| 961 | +331 |
- #'+ #' definition for a single proportion confidence interval using the normal |
||
| 962 | +332 |
- #' @examples+ #' approximation. It is possible to include a continuity correction for Wald's |
||
| 963 | +333 |
- #' \donttest{
+ #' interval. |
||
| 964 | +334 |
- #' library(dplyr)+ #' |
||
| 965 | +335 |
- #' library(survival)+ #' @param correct (`flag`)\cr whether to include the continuity correction. For further |
||
| 966 | +336 |
- #' library(grid)+ #' information, see [stats::prop.test()]. |
||
| 967 | +337 |
#' |
||
| 968 | +338 |
- #' fit_km <- tern_ex_adtte %>%+ #' @examples |
||
| 969 | +339 |
- #' filter(PARAMCD == "OS") %>%+ #' # Wald confidence interval |
||
| 970 | +340 |
- #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ #' set.seed(2) |
||
| 971 | +341 |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ #' rsp <- sample(c(TRUE, FALSE), replace = TRUE, size = 20) |
||
| 972 | +342 |
- #' xticks <- h_xticks(data = data_plot)+ #' grp <- factor(c(rep("A", 10), rep("B", 10)))
|
||
| 973 | +343 |
- #' gg <- h_ggkm(+ #' |
||
| 974 | +344 |
- #' data = data_plot,+ #' prop_diff_wald(rsp = rsp, grp = grp, conf_level = 0.95, correct = FALSE) |
||
| 975 | +345 |
- #' censor_show = TRUE,+ #' |
||
| 976 | +346 |
- #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ #' @export |
||
| 977 | +347 |
- #' title = "title", footnotes = "footnotes", yval = "Survival"+ prop_diff_wald <- function(rsp, |
||
| 978 | +348 |
- #' )+ grp, |
||
| 979 | +349 |
- #'+ conf_level = 0.95, |
||
| 980 | +350 |
- #' g_el <- h_decompose_gg(gg)+ correct = FALSE) {
|
||
| 981 | -+ | |||
| 351 | +8x |
- #'+ if (isTRUE(correct)) {
|
||
| 982 | -+ | |||
| 352 | +5x |
- #' grid::grid.newpage()+ mthd <- "waldcc" |
||
| 983 | +353 |
- #' pvp <- grid::plotViewport(margins = c(5, 4, 2, 20))+ } else {
|
||
| 984 | -+ | |||
| 354 | +3x |
- #' pushViewport(pvp)+ mthd <- "wald" |
||
| 985 | +355 |
- #' grid::grid.draw(h_grob_y_annot(ylab = g_el$ylab, yaxis = g_el$yaxis))+ } |
||
| 986 | -+ | |||
| 356 | +8x |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "gray35", fill = NA))+ grp <- as_factor_keep_attributes(grp) |
||
| 987 | -+ | |||
| 357 | +8x |
- #' }+ check_diff_prop_ci(+ |
+ ||
| 358 | +8x | +
+ rsp = rsp, grp = grp, conf_level = conf_level, correct = correct |
||
| 988 | +359 |
- #'+ ) |
||
| 989 | +360 |
- #' @export+ |
||
| 990 | +361 |
- h_grob_y_annot <- function(ylab, yaxis) {
+ # check if binary response is coded as logical |
||
| 991 | -1x | +362 | +8x |
- lifecycle::deprecate_warn(+ checkmate::assert_logical(rsp, any.missing = FALSE) |
| 992 | -1x | +363 | +8x |
- "0.9.4",+ checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) |
| 993 | -1x | +|||
| 364 | +
- "h_grob_y_annot()",+ |
|||
| 994 | -1x | +365 | +8x |
- details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`."+ tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE))) |
| 995 | +366 |
- )+ # x1 and n1 are non-reference groups. |
||
| 996 | -1x | +367 | +8x |
- grid::gList(+ diff_ci <- desctools_binom( |
| 997 | -1x | +368 | +8x |
- grid::gTree(+ x1 = tbl[2], n1 = sum(tbl[2], tbl[4]), |
| 998 | -1x | +369 | +8x |
- vp = grid::viewport(+ x2 = tbl[1], n2 = sum(tbl[1], tbl[3]), |
| 999 | -1x | +370 | +8x |
- width = grid::convertX(yaxis$widths + ylab$widths, "pt"),+ conf.level = conf_level, |
| 1000 | -1x | +371 | +8x |
- x = grid::unit(1, "npc"),+ method = mthd |
| 1001 | -1x | +|||
| 372 | +
- just = "right"+ ) |
|||
| 1002 | +373 |
- ),+ |
||
| 1003 | -1x | +374 | +8x |
- children = grid::gList(cbind(ylab, yaxis))+ list( |
| 1004 | -+ | |||
| 375 | +8x |
- )+ "diff" = unname(diff_ci[, "est"]),+ |
+ ||
| 376 | +8x | +
+ "diff_ci" = unname(diff_ci[, c("lwr.ci", "upr.ci")])
|
||
| 1005 | +377 |
) |
||
| 1006 | +378 |
} |
||
| 1007 | +379 | |||
| 1008 | +380 |
- #' Helper function to create Cox-PH grobs+ #' @describeIn h_prop_diff Anderson-Hauck confidence interval. |
||
| 1009 | +381 |
#' |
||
| 1010 | +382 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' @examples |
||
| 1011 | +383 |
- #'+ #' # Anderson-Hauck confidence interval |
||
| 1012 | +384 |
- #' Grob of `rtable` output from [h_tbl_coxph_pairwise()]+ #' ## "Mid" case: 3/4 respond in group A, 1/2 respond in group B. |
||
| 1013 | +385 | ++ |
+ #' rsp <- c(TRUE, FALSE, FALSE, TRUE, TRUE, TRUE)+ |
+ |
| 386 | ++ |
+ #' grp <- factor(c("A", "B", "A", "B", "A", "A"), levels = c("B", "A"))
+ |
+ ||
| 387 |
#' |
|||
| 1014 | +388 |
- #' @inheritParams h_grob_median_surv+ #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.90) |
||
| 1015 | +389 |
- #' @param ... arguments to pass to [h_tbl_coxph_pairwise()].+ #' |
||
| 1016 | +390 |
- #' @param x (`proportion`)\cr a value between 0 and 1 specifying x-location.+ #' ## Edge case: Same proportion of response in A and B. |
||
| 1017 | +391 |
- #' @param y (`proportion`)\cr a value between 0 and 1 specifying y-location.+ #' rsp <- c(TRUE, FALSE, TRUE, FALSE) |
||
| 1018 | +392 |
- #' @param width (`grid::unit`)\cr width (as a unit) to use when printing the grob.+ #' grp <- factor(c("A", "A", "B", "B"), levels = c("A", "B"))
|
||
| 1019 | +393 |
#' |
||
| 1020 | +394 |
- #' @return A `grob` of a table containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`),+ #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.6) |
||
| 1021 | +395 |
- #' and `p-value (log-rank)`.+ #' |
||
| 1022 | +396 |
- #'+ #' @export |
||
| 1023 | +397 |
- #' @examples+ prop_diff_ha <- function(rsp, |
||
| 1024 | +398 |
- #' \donttest{
+ grp, |
||
| 1025 | +399 |
- #' library(dplyr)+ conf_level) {
+ |
+ ||
| 400 | +4x | +
+ grp <- as_factor_keep_attributes(grp)+ |
+ ||
| 401 | +4x | +
+ check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level) |
||
| 1026 | +402 |
- #' library(survival)+ + |
+ ||
| 403 | +4x | +
+ tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE))) |
||
| 1027 | +404 |
- #' library(grid)+ # x1 and n1 are non-reference groups.+ |
+ ||
| 405 | +4x | +
+ ci <- desctools_binom(+ |
+ ||
| 406 | +4x | +
+ x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ |
+ ||
| 407 | +4x | +
+ x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ |
+ ||
| 408 | +4x | +
+ conf.level = conf_level,+ |
+ ||
| 409 | +4x | +
+ method = "ha" |
||
| 1028 | +410 |
- #'+ )+ |
+ ||
| 411 | +4x | +
+ list(+ |
+ ||
| 412 | +4x | +
+ "diff" = unname(ci[, "est"]),+ |
+ ||
| 413 | +4x | +
+ "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
|
||
| 1029 | +414 |
- #' grid::grid.newpage()+ ) |
||
| 1030 | +415 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1))+ } |
||
| 1031 | +416 |
- #' data <- tern_ex_adtte %>%+ |
||
| 1032 | +417 |
- #' filter(PARAMCD == "OS") %>%+ #' @describeIn h_prop_diff Newcombe confidence interval. It is based on |
||
| 1033 | +418 |
- #' mutate(is_event = CNSR == 0)+ #' the Wilson score confidence interval for a single binomial proportion. |
||
| 1034 | +419 |
- #' tbl_grob <- h_grob_coxph(+ #' |
||
| 1035 | +420 |
- #' df = data,+ #' @examples |
||
| 1036 | +421 |
- #' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARMCD"),+ #' # Newcombe confidence interval |
||
| 1037 | +422 |
- #' control_coxph_pw = control_coxph(conf_level = 0.9), x = 0.5, y = 0.5+ #' |
||
| 1038 | +423 |
- #' )+ #' set.seed(1) |
||
| 1039 | +424 |
- #' grid::grid.draw(tbl_grob)+ #' rsp <- c( |
||
| 1040 | +425 |
- #' }+ #' sample(c(TRUE, FALSE), size = 40, prob = c(3 / 4, 1 / 4), replace = TRUE), |
||
| 1041 | +426 |
- #'+ #' sample(c(TRUE, FALSE), size = 40, prob = c(1 / 2, 1 / 2), replace = TRUE) |
||
| 1042 | +427 |
- #' @export+ #' ) |
||
| 1043 | +428 |
- h_grob_coxph <- function(...,+ #' grp <- factor(rep(c("A", "B"), each = 40), levels = c("B", "A"))
|
||
| 1044 | +429 |
- x = 0,+ #' table(rsp, grp) |
||
| 1045 | +430 |
- y = 0,+ #' |
||
| 1046 | +431 |
- width = grid::unit(0.4, "npc"),+ #' prop_diff_nc(rsp = rsp, grp = grp, conf_level = 0.9) |
||
| 1047 | +432 |
- ttheme = gridExtra::ttheme_default(+ #' |
||
| 1048 | +433 |
- padding = grid::unit(c(1, .5), "lines"),+ #' @export |
||
| 1049 | +434 |
- core = list(bg_params = list(fill = c("grey95", "grey90"), alpha = .5))
+ prop_diff_nc <- function(rsp, |
||
| 1050 | +435 |
- )) {
+ grp, |
||
| 1051 | -1x | +|||
| 436 | +
- lifecycle::deprecate_warn(+ conf_level, |
|||
| 1052 | -1x | +|||
| 437 | +
- "0.9.4",+ correct = FALSE) {
|
|||
| 1053 | -1x | +438 | +2x |
- "h_grob_coxph()",+ if (isTRUE(correct)) {
|
| 1054 | -1x | +|||
| 439 | +! |
- details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`."+ mthd <- "scorecc" |
||
| 1055 | +440 |
- )+ } else {
|
||
| 1056 | -1x | +441 | +2x |
- data <- h_tbl_coxph_pairwise(...)+ mthd <- "score" |
| 1057 | +442 |
-
+ } |
||
| 1058 | -1x | +443 | +2x |
- width <- grid::convertUnit(grid::unit(as.numeric(width), grid::unitType(width)), "in")+ grp <- as_factor_keep_attributes(grp) |
| 1059 | -1x | +444 | +2x |
- height <- width * (nrow(data) + 1) / 12+ check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level) |
| 1060 | +445 | |||
| 1061 | -1x | +446 | +2x |
- w <- paste(" ", c(
+ p_grp <- tapply(rsp, grp, mean) |
| 1062 | -1x | +447 | +2x |
- rownames(data)[which.max(nchar(rownames(data)))],+ diff_p <- unname(diff(p_grp)) |
| 1063 | -1x | +448 | +2x |
- sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))])+ tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ |
+
| 449 | +2x | +
+ ci <- desctools_binom( |
||
| 1064 | +450 |
- ))+ # x1 and n1 are non-reference groups. |
||
| 1065 | -1x | +451 | +2x |
- w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE)+ x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ |
+
| 452 | +2x | +
+ x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ |
+ ||
| 453 | +2x | +
+ conf.level = conf_level,+ |
+ ||
| 454 | +2x | +
+ method = mthd |
||
| 1066 | +455 |
-
+ ) |
||
| 1067 | -1x | +456 | +2x |
- w_txt <- sapply(1:64, function(x) {
+ list( |
| 1068 | -64x | +457 | +2x |
- graphics::par(ps = x)+ "diff" = unname(ci[, "est"]), |
| 1069 | -64x | +458 | +2x |
- graphics::strwidth(w[4], units = "in")+ "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
|
| 1070 | +459 |
- })+ ) |
||
| 1071 | -1x | +|||
| 460 | +
- f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]])+ } |
|||
| 1072 | +461 | |||
| 1073 | -1x | +|||
| 462 | +
- h_txt <- sapply(1:64, function(x) {
+ #' @describeIn h_prop_diff Calculates the weighted difference. This is defined as the difference in |
|||
| 1074 | -64x | +|||
| 463 | +
- graphics::par(ps = x)+ #' response rates between the experimental treatment group and the control treatment group, adjusted |
|||
| 1075 | -64x | +|||
| 464 | +
- graphics::strheight(grid::stringHeight("X"), units = "in")
+ #' for stratification factors by applying Cochran-Mantel-Haenszel (CMH) weights. For the CMH chi-squared |
|||
| 1076 | +465 |
- })+ #' test, use [stats::mantelhaen.test()]. |
||
| 1077 | -1x | +|||
| 466 | +
- f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))])+ #' |
|||
| 1078 | +467 |
-
+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`. |
||
| 1079 | -1x | +|||
| 468 | +
- if (ttheme$core$fg_params$fontsize == 12) {
+ #' |
|||
| 1080 | -1x | +|||
| 469 | +
- ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h)+ #' @examples |
|||
| 1081 | -1x | +|||
| 470 | +
- ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ #' # Cochran-Mantel-Haenszel confidence interval |
|||
| 1082 | -1x | +|||
| 471 | +
- ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ #' |
|||
| 1083 | +472 |
- }+ #' set.seed(2) |
||
| 1084 | +473 |
-
+ #' rsp <- sample(c(TRUE, FALSE), 100, TRUE) |
||
| 1085 | -1x | +|||
| 474 | +
- tryCatch(+ #' grp <- sample(c("Placebo", "Treatment"), 100, TRUE)
|
|||
| 1086 | -1x | +|||
| 475 | +
- expr = {
+ #' grp <- factor(grp, levels = c("Placebo", "Treatment"))
|
|||
| 1087 | -1x | +|||
| 476 | +
- gt <- gridExtra::tableGrob(+ #' strata_data <- data.frame( |
|||
| 1088 | -1x | +|||
| 477 | +
- d = data,+ #' "f1" = sample(c("a", "b"), 100, TRUE),
|
|||
| 1089 | -1x | +|||
| 478 | +
- theme = ttheme+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
|||
| 1090 | -1x | +|||
| 479 | +
- ) # ERROR 'data' must be of a vector type, was 'NULL'+ #' stringsAsFactors = TRUE |
|||
| 1091 | -1x | +|||
| 480 | +
- gt$widths <- ((w_unit / sum(w_unit)) * width)+ #' ) |
|||
| 1092 | -1x | +|||
| 481 | +
- gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt))+ #' |
|||
| 1093 | -1x | +|||
| 482 | +
- vp <- grid::viewport(+ #' prop_diff_cmh( |
|||
| 1094 | -1x | +|||
| 483 | +
- x = grid::unit(x, "npc") + grid::unit(1, "lines"),+ #' rsp = rsp, grp = grp, strata = interaction(strata_data), |
|||
| 1095 | -1x | +|||
| 484 | +
- y = grid::unit(y, "npc") + grid::unit(1.5, "lines"),+ #' conf_level = 0.90 |
|||
| 1096 | -1x | +|||
| 485 | +
- height = height,+ #' ) |
|||
| 1097 | -1x | +|||
| 486 | +
- width = width,+ #' |
|||
| 1098 | -1x | +|||
| 487 | +
- just = c("left", "bottom")
+ #' @export |
|||
| 1099 | +488 |
- )+ prop_diff_cmh <- function(rsp,+ |
+ ||
| 489 | ++ |
+ grp,+ |
+ ||
| 490 | ++ |
+ strata,+ |
+ ||
| 491 | ++ |
+ conf_level = 0.95) {
|
||
| 1100 | -1x | +492 | +8x |
- grid::gList(+ grp <- as_factor_keep_attributes(grp) |
| 1101 | -1x | +493 | +8x |
- grid::gTree(+ strata <- as_factor_keep_attributes(strata) |
| 1102 | -1x | +494 | +8x |
- vp = vp,+ check_diff_prop_ci( |
| 1103 | -1x | +495 | +8x |
- children = grid::gList(gt)+ rsp = rsp, grp = grp, conf_level = conf_level, strata = strata |
| 1104 | +496 |
- )+ ) |
||
| 1105 | +497 |
- )+ |
||
| 1106 | -+ | |||
| 498 | +8x |
- },+ if (any(tapply(rsp, strata, length) < 5)) {
|
||
| 1107 | +499 | 1x |
- error = function(w) {
+ warning("Less than 5 observations in some strata.")
|
|
| 1108 | -! | +|||
| 500 | ++ |
+ }+ |
+ ||
| 501 | +
- message(paste(+ |
|||
| 1109 | -! | +|||
| 502 | +
- "Warning: Cox table will not be displayed as there is",+ # first dimension: FALSE, TRUE |
|||
| 1110 | -! | +|||
| 503 | +
- "not any level to be compared in the arm variable."+ # 2nd dimension: CONTROL, TX |
|||
| 1111 | +504 |
- ))+ # 3rd dimension: levels of strata |
||
| 1112 | -! | +|||
| 505 | +
- return(+ # rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records |
|||
| 1113 | -! | +|||
| 506 | +8x |
- grid::gList(+ t_tbl <- table( |
||
| 1114 | -! | +|||
| 507 | +8x |
- grid::gTree(+ factor(rsp, levels = c("FALSE", "TRUE")),
|
||
| 1115 | -! | +|||
| 508 | +8x |
- vp = NULL,+ grp, |
||
| 1116 | -! | +|||
| 509 | +8x |
- children = NULL+ strata |
||
| 1117 | +510 |
- )+ ) |
||
| 1118 | -+ | |||
| 511 | +8x |
- )+ n1 <- colSums(t_tbl[1:2, 1, ]) |
||
| 1119 | -+ | |||
| 512 | +8x |
- )+ n2 <- colSums(t_tbl[1:2, 2, ]) |
||
| 1120 | -+ | |||
| 513 | +8x |
- }+ p1 <- t_tbl[2, 1, ] / n1 |
||
| 1121 | -+ | |||
| 514 | +8x |
- )+ p2 <- t_tbl[2, 2, ] / n2 |
||
| 1122 | +515 |
- }+ # CMH weights |
| 1 | -+ | |||
| 516 | +8x |
- #' Count occurrences by grade+ use_stratum <- (n1 > 0) & (n2 > 0) |
||
| 2 | -+ | |||
| 517 | +8x |
- #'+ n1 <- n1[use_stratum] |
||
| 3 | -+ | |||
| 518 | +8x |
- #' @description `r lifecycle::badge("stable")`
+ n2 <- n2[use_stratum] |
||
| 4 | -+ | |||
| 519 | +8x |
- #'+ p1 <- p1[use_stratum] |
||
| 5 | -+ | |||
| 520 | +8x |
- #' The analyze function [count_occurrences_by_grade()] creates a layout element to calculate occurrence counts by grade.+ p2 <- p2[use_stratum] |
||
| 6 | -+ | |||
| 521 | +8x |
- #'+ wt <- (n1 * n2 / (n1 + n2)) |
||
| 7 | -+ | |||
| 522 | +8x |
- #' This function analyzes primary analysis variable `var` which indicates toxicity grades. The `id` variable+ wt_normalized <- wt / sum(wt) |
||
| 8 | -+ | |||
| 523 | +8x |
- #' is used to indicate unique subject identifiers (defaults to `USUBJID`). The user can also supply a list of+ est1 <- sum(wt_normalized * p1) |
||
| 9 | -+ | |||
| 524 | +8x |
- #' custom groups of grades to analyze via the `grade_groups` parameter. The `remove_single` argument will+ est2 <- sum(wt_normalized * p2) |
||
| 10 | -+ | |||
| 525 | +8x |
- #' remove single grades from the analysis so that *only* grade groups are analyzed.+ estimate <- c(est1, est2) |
||
| 11 | -+ | |||
| 526 | +8x |
- #'+ names(estimate) <- levels(grp) |
||
| 12 | -+ | |||
| 527 | +8x |
- #' If there are multiple grades recorded for one patient only the highest grade level is counted.+ se1 <- sqrt(sum(wt_normalized^2 * p1 * (1 - p1) / n1)) |
||
| 13 | -+ | |||
| 528 | +8x |
- #'+ se2 <- sqrt(sum(wt_normalized^2 * p2 * (1 - p2) / n2)) |
||
| 14 | -+ | |||
| 529 | +8x |
- #' The summarize function [summarize_occurrences_by_grade()] performs the same function as+ z <- stats::qnorm((1 + conf_level) / 2) |
||
| 15 | -+ | |||
| 530 | +8x |
- #' [count_occurrences_by_grade()] except it creates content rows, not data rows, to summarize the current table+ err1 <- z * se1 |
||
| 16 | -+ | |||
| 531 | +8x |
- #' row/column context and operates on the level of the latest row split or the root of the table if no row splits have+ err2 <- z * se2 |
||
| 17 | -+ | |||
| 532 | +8x |
- #' occurred.+ ci1 <- c((est1 - err1), (est1 + err1)) |
||
| 18 | -+ | |||
| 533 | +8x |
- #'+ ci2 <- c((est2 - err2), (est2 + err2)) |
||
| 19 | -+ | |||
| 534 | +8x |
- #' @inheritParams argument_convention+ estimate_ci <- list(ci1, ci2) |
||
| 20 | -+ | |||
| 535 | +8x |
- #' @param grade_groups (named `list` of `character`)\cr list containing groupings of grades.+ names(estimate_ci) <- levels(grp) |
||
| 21 | -+ | |||
| 536 | +8x |
- #' @param remove_single (`flag`)\cr `TRUE` to not include the elements of one-element grade groups+ diff_est <- est2 - est1 |
||
| 22 | -+ | |||
| 537 | +8x |
- #' in the the output list; in this case only the grade groups names will be included in the output. If+ se_diff <- sqrt(sum(((p1 * (1 - p1) / n1) + (p2 * (1 - p2) / n2)) * wt_normalized^2)) |
||
| 23 | -+ | |||
| 538 | +8x |
- #' `only_grade_groups` is set to `TRUE` this argument is ignored.+ diff_ci <- c(diff_est - z * se_diff, diff_est + z * se_diff) |
||
| 24 | +539 |
- #' @param only_grade_groups (`flag`)\cr whether only the specified grade groups should be+ |
||
| 25 | -+ | |||
| 540 | +8x |
- #' included, with individual grade rows removed (`TRUE`), or all grades and grade groups+ list( |
||
| 26 | -+ | |||
| 541 | +8x |
- #' should be displayed (`FALSE`).+ prop = estimate, |
||
| 27 | -+ | |||
| 542 | +8x |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_occurrences_by_grade")`
+ prop_ci = estimate_ci, |
||
| 28 | -+ | |||
| 543 | +8x |
- #' to see available statistics for this function.+ diff = diff_est, |
||
| 29 | -+ | |||
| 544 | +8x |
- #'+ diff_ci = diff_ci, |
||
| 30 | -+ | |||
| 545 | +8x |
- #' @seealso Relevant helper function [h_append_grade_groups()].+ weights = wt_normalized, |
||
| 31 | -+ | |||
| 546 | +8x |
- #'+ n1 = n1, |
||
| 32 | -+ | |||
| 547 | +8x |
- #' @name count_occurrences_by_grade+ n2 = n2 |
||
| 33 | +548 |
- #' @order 1+ ) |
||
| 34 | +549 |
- NULL+ } |
||
| 35 | +550 | |||
| 36 | +551 |
- #' Helper function for `s_count_occurrences_by_grade()`+ #' @describeIn h_prop_diff Calculates the stratified Newcombe confidence interval and difference in response |
||
| 37 | +552 |
- #'+ #' rates between the experimental treatment group and the control treatment group, adjusted for stratification |
||
| 38 | +553 |
- #' @description `r lifecycle::badge("stable")`
+ #' factors. This implementation follows closely the one proposed by \insertCite{Yan2010-jt;textual}{tern}.
|
||
| 39 | +554 |
- #'+ #' Weights can be estimated from the heuristic proposed in [prop_strat_wilson()] or from CMH-derived weights |
||
| 40 | +555 |
- #' Helper function for [s_count_occurrences_by_grade()] to insert grade groupings into list with+ #' (see [prop_diff_cmh()]). |
||
| 41 | +556 |
- #' individual grade frequencies. The order of the final result follows the order of `grade_groups`.+ #' |
||
| 42 | +557 |
- #' The elements under any-grade group (if any), i.e. the grade group equal to `refs` will be moved to+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`. |
||
| 43 | +558 |
- #' the end. Grade groups names must be unique.+ #' @param weights_method (`string`)\cr weights method. Can be either `"cmh"` or `"heuristic"` |
||
| 44 | +559 |
- #'+ #' and directs the way weights are estimated. |
||
| 45 | +560 |
- #' @inheritParams count_occurrences_by_grade+ #' |
||
| 46 | +561 |
- #' @param refs (named `list` of `numeric`)\cr named list where each name corresponds to a reference grade level+ #' @references |
||
| 47 | +562 |
- #' and each entry represents a count.+ #' \insertRef{Yan2010-jt}{tern}
|
||
| 48 | +563 |
#' |
||
| 49 | +564 |
- #' @return Formatted list of grade groupings.+ #' @examples |
||
| 50 | +565 |
- #'+ #' # Stratified Newcombe confidence interval |
||
| 51 | +566 |
- #' @examples+ #' |
||
| 52 | +567 |
- #' h_append_grade_groups(+ #' set.seed(2) |
||
| 53 | +568 |
- #' list(+ #' data_set <- data.frame( |
||
| 54 | +569 |
- #' "Any Grade" = as.character(1:5),+ #' "rsp" = sample(c(TRUE, FALSE), 100, TRUE), |
||
| 55 | +570 |
- #' "Grade 1-2" = c("1", "2"),
+ #' "f1" = sample(c("a", "b"), 100, TRUE),
|
||
| 56 | +571 |
- #' "Grade 3-4" = c("3", "4")
+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
||
| 57 | +572 |
- #' ),+ #' "grp" = sample(c("Placebo", "Treatment"), 100, TRUE),
|
||
| 58 | +573 |
- #' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
+ #' stringsAsFactors = TRUE |
||
| 59 | +574 |
#' ) |
||
| 60 | +575 |
#' |
||
| 61 | -- |
- #' h_append_grade_groups(- |
- ||
| 62 | +576 |
- #' list(+ #' prop_diff_strat_nc( |
||
| 63 | +577 |
- #' "Any Grade" = as.character(5:1),+ #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]), |
||
| 64 | +578 |
- #' "Grade A" = "5",+ #' weights_method = "cmh", |
||
| 65 | +579 |
- #' "Grade B" = c("4", "3")
+ #' conf_level = 0.90 |
||
| 66 | +580 |
- #' ),+ #' ) |
||
| 67 | +581 |
- #' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
+ #' |
||
| 68 | +582 |
- #' )+ #' prop_diff_strat_nc( |
||
| 69 | +583 |
- #'+ #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]), |
||
| 70 | +584 |
- #' h_append_grade_groups(+ #' weights_method = "wilson_h", |
||
| 71 | +585 |
- #' list(+ #' conf_level = 0.90 |
||
| 72 | +586 |
- #' "Any Grade" = as.character(1:5),+ #' ) |
||
| 73 | +587 |
- #' "Grade 1-2" = c("1", "2"),
+ #' |
||
| 74 | +588 |
- #' "Grade 3-4" = c("3", "4")
+ #' @export |
||
| 75 | +589 |
- #' ),+ prop_diff_strat_nc <- function(rsp, |
||
| 76 | +590 |
- #' list("1" = 10, "2" = 5, "3" = 0)
+ grp, |
||
| 77 | +591 |
- #' )+ strata, |
||
| 78 | +592 |
- #'+ weights_method = c("cmh", "wilson_h"),
|
||
| 79 | +593 |
- #' @export+ conf_level = 0.95, |
||
| 80 | +594 |
- h_append_grade_groups <- function(grade_groups, refs, remove_single = TRUE, only_grade_groups = FALSE) {
+ correct = FALSE) {
|
||
| 81 | -22x | +595 | +4x |
- checkmate::assert_list(grade_groups)+ weights_method <- match.arg(weights_method) |
| 82 | -22x | +596 | +4x |
- checkmate::assert_list(refs)+ grp <- as_factor_keep_attributes(grp) |
| 83 | -22x | +597 | +4x |
- refs_orig <- refs+ strata <- as_factor_keep_attributes(strata) |
| 84 | -22x | +598 | +4x |
- elements <- unique(unlist(grade_groups))+ check_diff_prop_ci( |
| 85 | -+ | |||
| 599 | +4x |
-
+ rsp = rsp, grp = grp, conf_level = conf_level, strata = strata |
||
| 86 | +600 |
- ### compute sums in groups+ ) |
||
| 87 | -22x | +601 | +4x |
- grp_sum <- lapply(grade_groups, function(i) do.call(sum, refs[i]))+ checkmate::assert_number(conf_level, lower = 0, upper = 1) |
| 88 | -22x | +602 | +4x |
- if (!checkmate::test_subset(elements, names(refs))) {
+ checkmate::assert_flag(correct) |
| 89 | -2x | +603 | +4x |
- padding_el <- setdiff(elements, names(refs))+ if (any(tapply(rsp, strata, length) < 5)) {
|
| 90 | -2x | +|||
| 604 | +! |
- refs[padding_el] <- 0+ warning("Less than 5 observations in some strata.")
|
||
| 91 | +605 |
} |
||
| 92 | -22x | -
- result <- c(grp_sum, refs)- |
- ||
| 93 | +606 | |||
| 94 | -+ | |||
| 607 | +4x |
- ### order result while keeping grade_groups's ordering+ rsp_by_grp <- split(rsp, f = grp) |
||
| 95 | -22x | +608 | +4x |
- ordr <- grade_groups+ strata_by_grp <- split(strata, f = grp) |
| 96 | +609 | |||
| 97 | +610 |
- # elements of any-grade group (if any) will be moved to the end+ # Finding the weights |
||
| 98 | -22x | +611 | +4x |
- is_any <- sapply(grade_groups, setequal, y = names(refs))+ weights <- if (identical(weights_method, "cmh")) {
|
| 99 | -22x | +612 | +3x |
- ordr[is_any] <- list(character(0)) # hide elements under any-grade group+ prop_diff_cmh(rsp = rsp, grp = grp, strata = strata)$weights |
| 100 | -+ | |||
| 613 | +4x |
-
+ } else if (identical(weights_method, "wilson_h")) {
|
||
| 101 | -+ | |||
| 614 | +1x |
- # groups-elements combined sequence+ prop_strat_wilson(rsp, strata, conf_level = conf_level, correct = correct)$weights |
||
| 102 | -22x | +|||
| 615 | +
- ordr <- c(lapply(names(ordr), function(g) c(g, ordr[[g]])), recursive = TRUE, use.names = FALSE)+ } |
|||
| 103 | -22x | +616 | +4x |
- ordr <- ordr[!duplicated(ordr)]+ weights[levels(strata)[!levels(strata) %in% names(weights)]] <- 0 |
| 104 | +617 | |||
| 105 | +618 |
- # append remaining elements (if any)+ # Calculating lower (`l`) and upper (`u`) confidence bounds per group. |
||
| 106 | -22x | +619 | +4x |
- ordr <- union(ordr, unlist(grade_groups[is_any])) # from any-grade group+ strat_wilson_by_grp <- Map( |
| 107 | -22x | -
- ordr <- union(ordr, names(refs)) # from refs- |
- ||
| 108 | -- | - - | -||
| 109 | -+ | 620 | +4x |
- # remove elements of single-element groups, if any+ prop_strat_wilson, |
| 110 | -22x | +621 | +4x |
- if (only_grade_groups) {
+ rsp = rsp_by_grp, |
| 111 | -3x | +622 | +4x |
- ordr <- intersect(ordr, names(grade_groups))+ strata = strata_by_grp, |
| 112 | -19x | +623 | +4x |
- } else if (remove_single) {
+ weights = list(weights, weights), |
| 113 | -19x | +624 | +4x |
- is_single <- sapply(grade_groups, length) == 1L+ conf_level = conf_level, |
| 114 | -19x | +625 | +4x |
- ordr <- setdiff(ordr, unlist(grade_groups[is_single]))+ correct = correct |
| 115 | +626 |
- }+ ) |
||
| 116 | +627 | |||
| 117 | -+ | |||
| 628 | +4x |
- # apply the order+ ci_ref <- strat_wilson_by_grp[[1]] |
||
| 118 | -22x | +629 | +4x |
- result <- result[ordr]+ ci_trt <- strat_wilson_by_grp[[2]] |
| 119 | -+ | |||
| 630 | +4x |
-
+ l_ref <- as.numeric(ci_ref$conf_int[1]) |
||
| 120 | -+ | |||
| 631 | +4x |
- # remove groups without any elements in the original refs+ u_ref <- as.numeric(ci_ref$conf_int[2]) |
||
| 121 | -+ | |||
| 632 | +4x |
- # note: it's OK if groups have 0 value+ l_trt <- as.numeric(ci_trt$conf_int[1]) |
||
| 122 | -22x | +633 | +4x |
- keep_grp <- vapply(grade_groups, function(x, rf) {
+ u_trt <- as.numeric(ci_trt$conf_int[2]) |
| 123 | -54x | +|||
| 634 | +
- any(x %in% rf)+ + |
+ |||
| 635 | ++ |
+ # Estimating the diff and n_ref, n_trt (it allows different weights to be used) |
||
| 124 | -22x | +636 | +4x |
- }, rf = names(refs_orig), logical(1))+ t_tbl <- table( |
| 125 | -+ | |||
| 637 | +4x |
-
+ factor(rsp, levels = c("FALSE", "TRUE")),
|
||
| 126 | -22x | +638 | +4x |
- keep_el <- names(result) %in% names(refs_orig) | names(result) %in% names(keep_grp)[keep_grp]+ grp, |
| 127 | -22x | +639 | +4x |
- result <- result[keep_el]+ strata |
| 128 | +640 |
-
+ ) |
||
| 129 | -22x | +641 | +4x |
- result+ n_ref <- colSums(t_tbl[1:2, 1, ]) |
| 130 | -+ | |||
| 642 | +4x |
- }+ n_trt <- colSums(t_tbl[1:2, 2, ]) |
||
| 131 | -+ | |||
| 643 | +4x |
-
+ use_stratum <- (n_ref > 0) & (n_trt > 0) |
||
| 132 | -+ | |||
| 644 | +4x |
- #' @describeIn count_occurrences_by_grade Statistics function which counts the+ n_ref <- n_ref[use_stratum] |
||
| 133 | -+ | |||
| 645 | +4x |
- #' number of patients by highest grade.+ n_trt <- n_trt[use_stratum] |
||
| 134 | -+ | |||
| 646 | +4x |
- #'+ p_ref <- t_tbl[2, 1, use_stratum] / n_ref |
||
| 135 | -+ | |||
| 647 | +4x |
- #' @return+ p_trt <- t_tbl[2, 2, use_stratum] / n_trt |
||
| 136 | -+ | |||
| 648 | +4x |
- #' * `s_count_occurrences_by_grade()` returns a list of counts and fractions with one element per grade level or+ est1 <- sum(weights * p_ref) |
||
| 137 | -+ | |||
| 649 | +4x |
- #' grade level grouping.+ est2 <- sum(weights * p_trt) |
||
| 138 | -+ | |||
| 650 | +4x |
- #'+ diff_est <- est2 - est1 |
||
| 139 | +651 |
- #' @examples+ |
||
| 140 | -+ | |||
| 652 | +4x |
- #' s_count_occurrences_by_grade(+ lambda1 <- sum(weights^2 / n_ref) |
||
| 141 | -+ | |||
| 653 | +4x |
- #' df,+ lambda2 <- sum(weights^2 / n_trt) |
||
| 142 | -+ | |||
| 654 | +4x |
- #' .N_col = 10L,+ z <- stats::qnorm((1 + conf_level) / 2) |
||
| 143 | +655 |
- #' .var = "AETOXGR",+ |
||
| 144 | -+ | |||
| 656 | +4x |
- #' id = "USUBJID",+ lower <- diff_est - z * sqrt(lambda2 * l_trt * (1 - l_trt) + lambda1 * u_ref * (1 - u_ref)) |
||
| 145 | -+ | |||
| 657 | +4x |
- #' grade_groups = list("ANY" = levels(df$AETOXGR))
+ upper <- diff_est + z * sqrt(lambda1 * l_ref * (1 - l_ref) + lambda2 * u_trt * (1 - u_trt)) |
||
| 146 | +658 |
- #' )+ |
||
| 147 | -+ | |||
| 659 | +4x |
- #'+ list( |
||
| 148 | -+ | |||
| 660 | +4x |
- #' @export+ "diff" = diff_est, |
||
| 149 | -+ | |||
| 661 | +4x |
- s_count_occurrences_by_grade <- function(df,+ "diff_ci" = c("lower" = lower, "upper" = upper)
|
||
| 150 | +662 |
- .var,+ ) |
||
| 151 | +663 |
- .N_col, # nolint+ } |
| 152 | +1 |
- id = "USUBJID",+ #' Kaplan-Meier plot |
||
| 153 | +2 |
- grade_groups = list(),+ #' |
||
| 154 | +3 |
- remove_single = TRUE,+ #' @description `r lifecycle::badge("stable")`
|
||
| 155 | +4 |
- only_grade_groups = FALSE,+ #' |
||
| 156 | +5 |
- labelstr = "") {
+ #' From a survival model, a graphic is rendered along with tabulated annotation |
||
| 157 | -11x | +|||
| 6 | +
- assert_valid_factor(df[[.var]])+ #' including the number of patient at risk at given time and the median survival |
|||
| 158 | -11x | +|||
| 7 | +
- assert_df_with_variables(df, list(grade = .var, id = id))+ #' per group. |
|||
| 159 | +8 |
-
+ #' |
||
| 160 | -11x | +|||
| 9 | +
- if (nrow(df) < 1) {
+ #' @inheritParams argument_convention |
|||
| 161 | -2x | +|||
| 10 | +
- grade_levels <- levels(df[[.var]])+ #' @param variables (named `list`)\cr variable names. Details are: |
|||
| 162 | -2x | +|||
| 11 | +
- l_count <- as.list(rep(0, length(grade_levels)))+ #' * `tte` (`numeric`)\cr variable indicating time-to-event duration values. |
|||
| 163 | -2x | +|||
| 12 | +
- names(l_count) <- grade_levels+ #' * `is_event` (`logical`)\cr event variable. `TRUE` if event, `FALSE` if time to event is censored. |
|||
| 164 | +13 |
- } else {
+ #' * `arm` (`factor`)\cr the treatment group variable. |
||
| 165 | -9x | +|||
| 14 | +
- if (isTRUE(is.factor(df[[id]]))) {
+ #' * `strata` (`character` or `NULL`)\cr variable names indicating stratification factors. |
|||
| 166 | -! | +|||
| 15 | +
- assert_valid_factor(df[[id]], any.missing = FALSE)+ #' @param control_surv (`list`)\cr parameters for comparison details, specified by using |
|||
| 167 | +16 |
- } else {
+ #' the helper function [control_surv_timepoint()]. Some possible parameter options are: |
||
| 168 | -9x | +|||
| 17 | +
- checkmate::assert_character(df[[id]], min.chars = 1, any.missing = FALSE)+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate. |
|||
| 169 | +18 |
- }+ #' * `conf_type` (`string`)\cr `"plain"` (default), `"log"`, `"log-log"` for confidence interval type, |
||
| 170 | -9x | +|||
| 19 | +
- checkmate::assert_count(.N_col)+ #' see more in [survival::survfit()]. Note that the option "none" is no longer supported. |
|||
| 171 | +20 |
-
+ #' @param col (`character`)\cr lines colors. Length of a vector should be equal |
||
| 172 | -9x | +|||
| 21 | +
- id <- df[[id]]+ #' to number of strata from [survival::survfit()]. |
|||
| 173 | -9x | +|||
| 22 | +
- grade <- df[[.var]]+ #' @param lty (`numeric`)\cr line type. If a vector is given, its length should be equal to the number of strata from |
|||
| 174 | +23 |
-
+ #' [survival::survfit()]. |
||
| 175 | -9x | +|||
| 24 | +
- if (!is.ordered(grade)) {
+ #' @param lwd (`numeric`)\cr line width. If a vector is given, its length should be equal to the number of strata from |
|||
| 176 | -9x | +|||
| 25 | +
- grade_lbl <- obj_label(grade)+ #' [survival::survfit()]. |
|||
| 177 | -9x | +|||
| 26 | +
- lvls <- levels(grade)+ #' @param censor_show (`flag`)\cr whether to show censored observations. |
|||
| 178 | -9x | +|||
| 27 | +
- if (sum(grepl("^\\d+$", lvls)) %in% c(0, length(lvls))) {
+ #' @param pch (`string`)\cr name of symbol or character to use as point symbol to indicate censored cases. |
|||
| 179 | -8x | +|||
| 28 | +
- lvl_ord <- lvls+ #' @param size (`numeric(1)`)\cr size of censored point symbols. |
|||
| 180 | +29 |
- } else {
+ #' @param max_time (`numeric(1)`)\cr maximum value to show on x-axis. Only data values less than or up to |
||
| 181 | -1x | +|||
| 30 | +
- lvls[!grepl("^\\d+$", lvls)] <- min(as.numeric(lvls[grepl("^\\d+$", lvls)])) - 1
+ #' this threshold value will be plotted (defaults to `NULL`). |
|||
| 182 | -1x | +|||
| 31 | +
- lvl_ord <- levels(grade)[order(as.numeric(lvls))]+ #' @param xticks (`numeric` or `NULL`)\cr numeric vector of tick positions or a single number with spacing |
|||
| 183 | +32 |
- }+ #' between ticks on the x-axis. If `NULL` (default), [labeling::extended()] is used to determine |
||
| 184 | -9x | +|||
| 33 | +
- grade <- formatters::with_label(factor(grade, levels = lvl_ord, ordered = TRUE), grade_lbl)+ #' optimal tick positions on the x-axis. |
|||
| 185 | +34 |
- }+ #' @param xlab (`string`)\cr x-axis label. |
||
| 186 | +35 |
-
+ #' @param yval (`string`)\cr type of plot, to be plotted on the y-axis. Options are `Survival` (default) and `Failure` |
||
| 187 | -9x | +|||
| 36 | +
- missing_lvl <- grepl("missing", tolower(levels(grade)))
+ #' probability. |
|||
| 188 | -9x | +|||
| 37 | +
- if (any(missing_lvl)) {
+ #' @param ylab (`string`)\cr y-axis label. |
|||
| 189 | -1x | +|||
| 38 | +
- grade <- factor(+ #' @param title (`string`)\cr plot title. |
|||
| 190 | -1x | +|||
| 39 | +
- grade,+ #' @param footnotes (`string`)\cr plot footnotes. |
|||
| 191 | -1x | +|||
| 40 | +
- levels = c(levels(grade)[!missing_lvl], levels(grade)[missing_lvl]),+ #' @param font_size (`numeric(1)`)\cr font size to use for all text. |
|||
| 192 | -1x | +|||
| 41 | +
- ordered = is.ordered(grade)+ #' @param ci_ribbon (`flag`)\cr whether the confidence interval should be drawn around the Kaplan-Meier curve. |
|||
| 193 | +42 |
- )+ #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of patient at risk |
||
| 194 | +43 |
- }+ #' matching the main grid of the Kaplan-Meier curve. |
||
| 195 | -9x | +|||
| 44 | +
- df_max <- stats::aggregate(grade ~ id, FUN = max, drop = FALSE)+ #' @param annot_at_risk_title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk` |
|||
| 196 | -9x | +|||
| 45 | +
- l_count <- as.list(table(df_max$grade))+ #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`. |
|||
| 197 | +46 |
- }+ #' @param annot_surv_med (`flag`)\cr compute and add the annotation table on the Kaplan-Meier curve estimating the |
||
| 198 | +47 |
-
+ #' median survival time per group. |
||
| 199 | -11x | +|||
| 48 | +
- if (length(grade_groups) > 0) {
+ #' @param annot_coxph (`flag`)\cr whether to add the annotation table from a [survival::coxph()] model. |
|||
| 200 | -6x | +|||
| 49 | +
- l_count <- h_append_grade_groups(grade_groups, l_count, remove_single, only_grade_groups)+ #' @param annot_stats (`string` or `NULL`)\cr statistics annotations to add to the plot. Options are |
|||
| 201 | +50 |
- }+ #' `median` (median survival follow-up time) and `min` (minimum survival follow-up time). |
||
| 202 | +51 |
-
+ #' @param annot_stats_vlines (`flag`)\cr add vertical lines corresponding to each of the statistics |
||
| 203 | -11x | +|||
| 52 | +
- l_count_fraction <- lapply(l_count, function(i, denom) c(i, i / denom), denom = .N_col)+ #' specified by `annot_stats`. If `annot_stats` is `NULL` no lines will be added. |
|||
| 204 | +53 |
-
+ #' @param control_coxph_pw (`list`)\cr parameters for comparison details, specified using the helper function |
||
| 205 | -11x | +|||
| 54 | +
- list(+ #' [control_coxph()]. Some possible parameter options are: |
|||
| 206 | -11x | +|||
| 55 | +
- count_fraction = l_count_fraction+ #' * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1. |
|||
| 207 | +56 |
- )+ #' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`. |
||
| 208 | +57 |
- }+ #' * `ties` (`string`)\cr method for tie handling. Default is `"efron"`, |
||
| 209 | +58 |
-
+ #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()] |
||
| 210 | +59 |
- #' @describeIn count_occurrences_by_grade Formatted analysis function which is used as `afun`+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR. |
||
| 211 | +60 |
- #' in `count_occurrences_by_grade()`.+ #' @param ref_group_coxph (`string` or `NULL`)\cr level of arm variable to use as reference group in calculations for |
||
| 212 | +61 |
- #'+ #' `annot_coxph` table. If `NULL` (default), uses the first level of the arm variable. |
||
| 213 | +62 |
- #' @return+ #' @param control_annot_surv_med (`list`)\cr parameters to control the position and size of the annotation table added |
||
| 214 | +63 |
- #' * `a_count_occurrences_by_grade()` returns the corresponding list with formatted [rtables::CellValue()].+ #' to the plot when `annot_surv_med = TRUE`, specified using the [control_surv_med_annot()] function. Parameter |
||
| 215 | +64 |
- #'+ #' options are: `x`, `y`, `w`, `h`, and `fill`. See [control_surv_med_annot()] for details. |
||
| 216 | +65 |
- #' @examples+ #' @param control_annot_coxph (`list`)\cr parameters to control the position and size of the annotation table added |
||
| 217 | +66 |
- #' # We need to ungroup `count_fraction` first so that the `rtables` formatting+ #' to the plot when `annot_coxph = TRUE`, specified using the [control_coxph_annot()] function. Parameter |
||
| 218 | +67 |
- #' # function `format_count_fraction()` can be applied correctly.+ #' options are: `x`, `y`, `w`, `h`, `fill`, and `ref_lbls`. See [control_coxph_annot()] for details. |
||
| 219 | +68 |
- #' afun <- make_afun(a_count_occurrences_by_grade, .ungroup_stats = "count_fraction")+ #' @param legend_pos (`numeric(2)` or `NULL`)\cr vector containing x- and y-coordinates, respectively, for the legend |
||
| 220 | +69 |
- #' afun(+ #' position relative to the KM plot area. If `NULL` (default), the legend is positioned in the bottom right corner of |
||
| 221 | +70 |
- #' df,+ #' the plot, or the middle right of the plot if needed to prevent overlapping. |
||
| 222 | +71 |
- #' .N_col = 10L,+ #' @param rel_height_plot (`proportion`)\cr proportion of total figure height to allocate to the Kaplan-Meier plot. |
||
| 223 | +72 |
- #' .var = "AETOXGR",+ #' Relative height of patients at risk table is then `1 - rel_height_plot`. If `annot_at_risk = FALSE` or |
||
| 224 | +73 |
- #' id = "USUBJID",+ #' `as_list = TRUE`, this parameter is ignored. |
||
| 225 | +74 |
- #' grade_groups = list("ANY" = levels(df$AETOXGR))
+ #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to format the Kaplan-Meier plot. |
||
| 226 | +75 |
- #' )+ #' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list when `annot_at_risk = TRUE`. |
||
| 227 | +76 |
- #'+ #' If `TRUE`, a named list with two elements, `plot` and `table`, will be returned. If `FALSE` (default) the patients |
||
| 228 | +77 |
- #' @export+ #' at risk table is printed below the plot via [cowplot::plot_grid()]. |
||
| 229 | +78 |
- a_count_occurrences_by_grade <- make_afun(+ #' @param draw `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
|
||
| 230 | +79 |
- s_count_occurrences_by_grade,+ #' @param newpage `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
|
||
| 231 | +80 |
- .formats = c("count_fraction" = format_count_fraction_fixed_dp)
+ #' @param gp `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
|
||
| 232 | +81 |
- )+ #' @param vp `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
|
||
| 233 | +82 |
-
+ #' @param name `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
|
||
| 234 | +83 |
- #' @describeIn count_occurrences_by_grade Layout-creating function which can take statistics function+ #' @param annot_coxph_ref_lbls `r lifecycle::badge("deprecated")` Please use the `ref_lbls` element of
|
||
| 235 | +84 |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' `control_annot_coxph` instead. |
||
| 236 | +85 |
- #'+ #' @param position_coxph `r lifecycle::badge("deprecated")` Please use the `x` and `y` elements of
|
||
| 237 | +86 |
- #' @return+ #' `control_annot_coxph` instead. |
||
| 238 | +87 |
- #' * `count_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions,+ #' @param position_surv_med `r lifecycle::badge("deprecated")` Please use the `x` and `y` elements of
|
||
| 239 | +88 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' `control_annot_surv_med` instead. |
||
| 240 | +89 |
- #' the statistics from `s_count_occurrences_by_grade()` to the table layout.+ #' @param width_annots `r lifecycle::badge("deprecated")` Please use the `w` element of `control_annot_surv_med`
|
||
| 241 | +90 |
- #'+ #' (for `surv_med`) and `control_annot_coxph` (for `coxph`)." |
||
| 242 | +91 |
- #' @examples+ #' |
||
| 243 | +92 |
- #' library(dplyr)+ #' @return A `ggplot` Kaplan-Meier plot and (optionally) summary table. |
||
| 244 | +93 |
#' |
||
| 245 | +94 |
- #' df <- data.frame(+ #' @examples |
||
| 246 | +95 |
- #' USUBJID = as.character(c(1:6, 1)),+ #' library(dplyr) |
||
| 247 | +96 |
- #' ARM = factor(c("A", "A", "A", "B", "B", "B", "A"), levels = c("A", "B")),
+ #' library(nestcolor) |
||
| 248 | +97 |
- #' AETOXGR = factor(c(1, 2, 3, 4, 1, 2, 3), levels = c(1:5)),+ #' |
||
| 249 | +98 |
- #' AESEV = factor(+ #' df <- tern_ex_adtte %>% |
||
| 250 | +99 |
- #' x = c("MILD", "MODERATE", "SEVERE", "MILD", "MILD", "MODERATE", "SEVERE"),
+ #' filter(PARAMCD == "OS") %>% |
||
| 251 | +100 |
- #' levels = c("MILD", "MODERATE", "SEVERE")
+ #' mutate(is_event = CNSR == 0) |
||
| 252 | +101 |
- #' ),+ #' variables <- list(tte = "AVAL", is_event = "is_event", arm = "ARMCD") |
||
| 253 | +102 |
- #' stringsAsFactors = FALSE+ #' |
||
| 254 | +103 |
- #' )+ #' # Basic examples |
||
| 255 | +104 |
- #'+ #' g_km(df = df, variables = variables) |
||
| 256 | +105 |
- #' df_adsl <- df %>%+ #' g_km(df = df, variables = variables, yval = "Failure") |
||
| 257 | +106 |
- #' select(USUBJID, ARM) %>%+ #' |
||
| 258 | +107 |
- #' unique()+ #' # Examples with customization parameters applied |
||
| 259 | +108 |
- #'+ #' g_km( |
||
| 260 | +109 |
- #' # Layout creating function with custom format.+ #' df = df, |
||
| 261 | +110 |
- #' basic_table() %>%+ #' variables = variables, |
||
| 262 | +111 |
- #' split_cols_by("ARM") %>%
+ #' control_surv = control_surv_timepoint(conf_level = 0.9), |
||
| 263 | +112 |
- #' add_colcounts() %>%+ #' col = c("grey25", "grey50", "grey75"),
|
||
| 264 | +113 |
- #' count_occurrences_by_grade(+ #' annot_at_risk_title = FALSE, |
||
| 265 | +114 |
- #' var = "AESEV",+ #' lty = 1:3, |
||
| 266 | +115 |
- #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
+ #' font_size = 8 |
||
| 267 | +116 |
- #' ) %>%+ #' ) |
||
| 268 | +117 |
- #' build_table(df, alt_counts_df = df_adsl)+ #' g_km( |
||
| 269 | +118 |
- #'+ #' df = df, |
||
| 270 | +119 |
- #' # Define additional grade groupings.+ #' variables = variables, |
||
| 271 | +120 |
- #' grade_groups <- list(+ #' annot_stats = c("min", "median"),
|
||
| 272 | +121 |
- #' "-Any-" = c("1", "2", "3", "4", "5"),
+ #' annot_stats_vlines = TRUE, |
||
| 273 | +122 |
- #' "Grade 1-2" = c("1", "2"),
+ #' max_time = 3000, |
||
| 274 | +123 |
- #' "Grade 3-5" = c("3", "4", "5")
+ #' ggtheme = ggplot2::theme_minimal() |
||
| 275 | +124 |
#' ) |
||
| 276 | +125 |
#' |
||
| 277 | +126 |
- #' basic_table() %>%+ #' # Example with pairwise Cox-PH analysis annotation table, adjusted annotation tables |
||
| 278 | +127 |
- #' split_cols_by("ARM") %>%
+ #' g_km( |
||
| 279 | +128 |
- #' add_colcounts() %>%+ #' df = df, variables = variables, |
||
| 280 | +129 |
- #' count_occurrences_by_grade(+ #' annot_coxph = TRUE, |
||
| 281 | +130 |
- #' var = "AETOXGR",+ #' control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99), |
||
| 282 | +131 |
- #' grade_groups = grade_groups,+ #' control_annot_coxph = control_coxph_annot(x = 0.26, w = 0.35), |
||
| 283 | +132 |
- #' only_grade_groups = TRUE+ #' control_annot_surv_med = control_surv_med_annot(x = 0.8, y = 0.9, w = 0.35) |
||
| 284 | +133 |
- #' ) %>%+ #' ) |
||
| 285 | +134 |
- #' build_table(df, alt_counts_df = df_adsl)+ #' |
||
| 286 | +135 |
- #'+ #' @aliases kaplan_meier |
||
| 287 | +136 |
#' @export |
||
| 288 | +137 |
- #' @order 2+ g_km <- function(df, |
||
| 289 | +138 |
- count_occurrences_by_grade <- function(lyt,+ variables, |
||
| 290 | +139 |
- var,+ control_surv = control_surv_timepoint(), |
||
| 291 | +140 |
- id = "USUBJID",+ col = NULL, |
||
| 292 | +141 |
- grade_groups = list(),+ lty = NULL, |
||
| 293 | +142 |
- remove_single = TRUE,+ lwd = 0.5, |
||
| 294 | +143 |
- only_grade_groups = FALSE,+ censor_show = TRUE, |
||
| 295 | +144 |
- var_labels = var,+ pch = 3, |
||
| 296 | +145 |
- show_labels = "default",+ size = 2, |
||
| 297 | +146 |
- riskdiff = FALSE,+ max_time = NULL, |
||
| 298 | +147 |
- na_str = default_na_str(),+ xticks = NULL, |
||
| 299 | +148 |
- nested = TRUE,+ xlab = "Days", |
||
| 300 | +149 |
- ...,+ yval = c("Survival", "Failure"),
|
||
| 301 | +150 |
- table_names = var,+ ylab = paste(yval, "Probability"), |
||
| 302 | +151 |
- .stats = NULL,+ ylim = NULL, |
||
| 303 | +152 |
- .formats = NULL,+ title = NULL, |
||
| 304 | +153 |
- .indent_mods = NULL,+ footnotes = NULL, |
||
| 305 | +154 |
- .labels = NULL) {
+ font_size = 10, |
||
| 306 | -11x | +|||
| 155 | +
- checkmate::assert_flag(riskdiff)+ ci_ribbon = FALSE, |
|||
| 307 | -11x | +|||
| 156 | +
- s_args <- list(+ annot_at_risk = TRUE, |
|||
| 308 | -11x | +|||
| 157 | +
- id = id, grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups, ...+ annot_at_risk_title = TRUE, |
|||
| 309 | +158 |
- )+ annot_surv_med = TRUE, |
||
| 310 | +159 |
-
+ annot_coxph = FALSE, |
||
| 311 | -11x | +|||
| 160 | +
- afun <- make_afun(+ annot_stats = NULL, |
|||
| 312 | -11x | +|||
| 161 | +
- a_count_occurrences_by_grade,+ annot_stats_vlines = FALSE, |
|||
| 313 | -11x | +|||
| 162 | +
- .stats = .stats,+ control_coxph_pw = control_coxph(), |
|||
| 314 | -11x | +|||
| 163 | +
- .formats = .formats,+ ref_group_coxph = NULL, |
|||
| 315 | -11x | +|||
| 164 | +
- .indent_mods = .indent_mods,+ control_annot_surv_med = control_surv_med_annot(), |
|||
| 316 | -11x | +|||
| 165 | +
- .ungroup_stats = "count_fraction"+ control_annot_coxph = control_coxph_annot(), |
|||
| 317 | +166 |
- )+ legend_pos = NULL, |
||
| 318 | +167 |
-
+ rel_height_plot = 0.75, |
||
| 319 | -11x | +|||
| 168 | +
- extra_args <- if (isFALSE(riskdiff)) {
+ ggtheme = NULL, |
|||
| 320 | -9x | +|||
| 169 | +
- s_args+ as_list = FALSE, |
|||
| 321 | +170 |
- } else {
+ draw = lifecycle::deprecated(), |
||
| 322 | -2x | +|||
| 171 | +
- list(+ newpage = lifecycle::deprecated(), |
|||
| 323 | -2x | +|||
| 172 | +
- afun = list("s_count_occurrences_by_grade" = afun),
+ gp = lifecycle::deprecated(), |
|||
| 324 | -2x | +|||
| 173 | +
- .stats = .stats,+ vp = lifecycle::deprecated(), |
|||
| 325 | -2x | +|||
| 174 | +
- .indent_mods = .indent_mods,+ name = lifecycle::deprecated(), |
|||
| 326 | -2x | +|||
| 175 | +
- s_args = s_args+ annot_coxph_ref_lbls = lifecycle::deprecated(), |
|||
| 327 | +176 |
- )+ position_coxph = lifecycle::deprecated(), |
||
| 328 | +177 |
- }+ position_surv_med = lifecycle::deprecated(), |
||
| 329 | +178 |
-
+ width_annots = lifecycle::deprecated()) {
|
||
| 330 | -11x | +|||
| 179 | +
- analyze(+ # Deprecated argument warnings |
|||
| 331 | -11x | +180 | +10x |
- lyt = lyt,+ if (lifecycle::is_present(draw)) {
|
| 332 | -11x | +181 | +1x |
- vars = var,+ lifecycle::deprecate_warn( |
| 333 | -11x | +182 | +1x |
- var_labels = var_labels,+ "0.9.4", "g_km(draw)", |
| 334 | -11x | +183 | +1x |
- show_labels = show_labels,+ details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
| 335 | -11x | +|||
| 184 | +
- afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ ) |
|||
| 336 | -11x | +|||
| 185 | +
- table_names = table_names,+ } |
|||
| 337 | -11x | +186 | +10x |
- na_str = na_str,+ if (lifecycle::is_present(newpage)) {
|
| 338 | -11x | +187 | +1x |
- nested = nested,+ lifecycle::deprecate_warn( |
| 339 | -11x | -
- extra_args = extra_args- |
- ||
| 340 | -- |
- )- |
- ||
| 341 | -- |
- }- |
- ||
| 342 | -- | - - | -||
| 343 | -+ | 188 | +1x |
- #' @describeIn count_occurrences_by_grade Layout-creating function which can take content function arguments+ "0.9.4", "g_km(newpage)", |
| 344 | -+ | |||
| 189 | +1x |
- #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
||
| 345 | +190 |
- #'+ ) |
||
| 346 | +191 |
- #' @return+ } |
||
| 347 | -+ | |||
| 192 | +10x |
- #' * `summarize_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions,+ if (lifecycle::is_present(gp)) {
|
||
| 348 | -+ | |||
| 193 | +1x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows+ lifecycle::deprecate_warn( |
||
| 349 | -+ | |||
| 194 | +1x |
- #' containing the statistics from `s_count_occurrences_by_grade()` to the table layout.+ "0.9.4", "g_km(gp)", |
||
| 350 | -+ | |||
| 195 | +1x |
- #'+ details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
||
| 351 | +196 |
- #' @examples+ ) |
||
| 352 | +197 |
- #' # Layout creating function with custom format.+ } |
||
| 353 | -+ | |||
| 198 | +10x |
- #' basic_table() %>%+ if (lifecycle::is_present(vp)) {
|
||
| 354 | -+ | |||
| 199 | +1x |
- #' add_colcounts() %>%+ lifecycle::deprecate_warn( |
||
| 355 | -+ | |||
| 200 | +1x |
- #' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
+ "0.9.4", "g_km(vp)", |
||
| 356 | -+ | |||
| 201 | +1x |
- #' summarize_occurrences_by_grade(+ details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
||
| 357 | +202 |
- #' var = "AESEV",+ ) |
||
| 358 | +203 |
- #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
+ } |
||
| 359 | -+ | |||
| 204 | +10x |
- #' ) %>%+ if (lifecycle::is_present(name)) {
|
||
| 360 | -+ | |||
| 205 | +1x |
- #' build_table(df, alt_counts_df = df_adsl)+ lifecycle::deprecate_warn( |
||
| 361 | -+ | |||
| 206 | +1x |
- #'+ "0.9.4", "g_km(name)", |
||
| 362 | -+ | |||
| 207 | +1x |
- #' basic_table() %>%+ details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
||
| 363 | +208 |
- #' add_colcounts() %>%+ ) |
||
| 364 | +209 |
- #' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
+ } |
||
| 365 | -+ | |||
| 210 | +10x |
- #' summarize_occurrences_by_grade(+ if (lifecycle::is_present(annot_coxph_ref_lbls)) {
|
||
| 366 | -+ | |||
| 211 | +1x |
- #' var = "AETOXGR",+ lifecycle::deprecate_warn( |
||
| 367 | -+ | |||
| 212 | +1x |
- #' grade_groups = grade_groups+ "0.9.4", "g_km(annot_coxph_ref_lbls)", |
||
| 368 | -+ | |||
| 213 | +1x |
- #' ) %>%+ details = "Please specify this setting using the 'ref_lbls' element of control_annot_coxph." |
||
| 369 | +214 |
- #' build_table(df, alt_counts_df = df_adsl)+ ) |
||
| 370 | -+ | |||
| 215 | +1x |
- #'+ control_annot_coxph[["ref_lbls"]] <- annot_coxph_ref_lbls |
||
| 371 | +216 |
- #' @export+ } |
||
| 372 | -+ | |||
| 217 | +10x |
- #' @order 3+ if (lifecycle::is_present(position_coxph)) {
|
||
| 373 | -+ | |||
| 218 | +1x |
- summarize_occurrences_by_grade <- function(lyt,+ lifecycle::deprecate_warn( |
||
| 374 | -+ | |||
| 219 | +1x |
- var,+ "0.9.4", "g_km(position_coxph)", |
||
| 375 | -+ | |||
| 220 | +1x |
- id = "USUBJID",+ details = "Please specify this setting using the 'x' and 'y' elements of control_annot_coxph." |
||
| 376 | +221 |
- grade_groups = list(),+ ) |
||
| 377 | -+ | |||
| 222 | +1x |
- remove_single = TRUE,+ control_annot_coxph[["x"]] <- position_coxph[1] |
||
| 378 | -+ | |||
| 223 | +1x |
- only_grade_groups = FALSE,+ control_annot_coxph[["y"]] <- position_coxph[2] |
||
| 379 | +224 |
- na_str = default_na_str(),+ } |
||
| 380 | -+ | |||
| 225 | +10x |
- ...,+ if (lifecycle::is_present(position_surv_med)) {
|
||
| 381 | -+ | |||
| 226 | +1x |
- .stats = NULL,+ lifecycle::deprecate_warn( |
||
| 382 | -+ | |||
| 227 | +1x |
- .formats = NULL,+ "0.9.4", "g_km(position_surv_med)", |
||
| 383 | -+ | |||
| 228 | +1x |
- .indent_mods = NULL,+ details = "Please specify this setting using the 'x' and 'y' elements of control_annot_surv_med." |
||
| 384 | +229 |
- .labels = NULL) {
+ ) |
||
| 385 | -3x | +230 | +1x |
- extra_args <- list(+ control_annot_surv_med[["x"]] <- position_surv_med[1] |
| 386 | -3x | +231 | +1x |
- id = id, grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups, ...+ control_annot_surv_med[["y"]] <- position_surv_med[2] |
| 387 | +232 |
- )+ } |
||
| 388 | -+ | |||
| 233 | +10x |
-
+ if (lifecycle::is_present(width_annots)) {
|
||
| 389 | -3x | +234 | +1x |
- cfun <- make_afun(+ lifecycle::deprecate_warn( |
| 390 | -3x | +235 | +1x |
- a_count_occurrences_by_grade,+ "0.9.4", "g_km(width_annots)", |
| 391 | -3x | +236 | +1x |
- .stats = .stats,+ details = paste( |
| 392 | -3x | +237 | +1x |
- .formats = .formats,+ "Please specify widths of annotation tables relative to the plot area using the 'w' element of", |
| 393 | -3x | +238 | +1x |
- .labels = .labels,+ "control_annot_surv_med (for surv_med) and control_annot_coxph (for coxph)."+ |
+
| 239 | ++ |
+ )+ |
+ ||
| 240 | ++ |
+ ) |
||
| 394 | -3x | +241 | +1x |
- .indent_mods = .indent_mods,+ control_annot_surv_med[["w"]] <- as.numeric(width_annots[["surv_med"]]) |
| 395 | -3x | +242 | +1x |
- .ungroup_stats = "count_fraction"+ control_annot_coxph[["w"]] <- as.numeric(width_annots[["coxph"]]) |
| 396 | +243 |
- )+ } |
||
| 397 | +244 | |||
| 398 | -3x | +245 | +10x |
- summarize_row_groups(+ checkmate::assert_list(variables) |
| 399 | -3x | +246 | +10x |
- lyt = lyt,+ checkmate::assert_subset(c("tte", "arm", "is_event"), names(variables))
|
| 400 | -3x | +247 | +10x |
- var = var,+ checkmate::assert_logical(censor_show, len = 1) |
| 401 | -3x | +248 | +10x |
- cfun = cfun,+ checkmate::assert_numeric(size, len = 1) |
| 402 | -3x | +249 | +10x |
- na_str = na_str,+ checkmate::assert_numeric(max_time, len = 1, null.ok = TRUE) |
| 403 | -3x | +250 | +10x |
- extra_args = extra_args+ checkmate::assert_numeric(xticks, null.ok = TRUE) |
| 404 | -+ | |||
| 251 | +10x |
- )+ checkmate::assert_character(xlab, len = 1, null.ok = TRUE) |
||
| 405 | -+ | |||
| 252 | +10x |
- }+ checkmate::assert_character(yval) |
| 1 | -+ | |||
| 253 | +10x |
- #' Control function for subgroup treatment effect pattern (STEP) calculations+ checkmate::assert_character(ylab, null.ok = TRUE) |
||
| 2 | -+ | |||
| 254 | +10x |
- #'+ checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE) |
||
| 3 | -+ | |||
| 255 | +10x |
- #' @description `r lifecycle::badge("stable")`
+ checkmate::assert_character(title, len = 1, null.ok = TRUE) |
||
| 4 | -+ | |||
| 256 | +10x |
- #'+ checkmate::assert_character(footnotes, len = 1, null.ok = TRUE) |
||
| 5 | -+ | |||
| 257 | +10x |
- #' This is an auxiliary function for controlling arguments for STEP calculations.+ checkmate::assert_numeric(font_size, len = 1) |
||
| 6 | -+ | |||
| 258 | +10x |
- #'+ checkmate::assert_logical(ci_ribbon, len = 1) |
||
| 7 | -+ | |||
| 259 | +10x |
- #' @param biomarker (`numeric` or `NULL`)\cr optional provision of the numeric biomarker variable, which+ checkmate::assert_logical(annot_at_risk, len = 1) |
||
| 8 | -+ | |||
| 260 | +10x |
- #' could be used to infer `bandwidth`, see below.+ checkmate::assert_logical(annot_at_risk_title, len = 1) |
||
| 9 | -+ | |||
| 261 | +10x |
- #' @param use_percentile (`flag`)\cr if `TRUE`, the running windows are created according to+ checkmate::assert_logical(annot_surv_med, len = 1) |
||
| 10 | -+ | |||
| 262 | +10x |
- #' quantiles rather than actual values, i.e. the bandwidth refers to the percentage of data+ checkmate::assert_logical(annot_coxph, len = 1) |
||
| 11 | -+ | |||
| 263 | +10x |
- #' covered in each window. Suggest `TRUE` if the biomarker variable is not uniformly+ checkmate::assert_subset(annot_stats, c("median", "min"))
|
||
| 12 | -+ | |||
| 264 | +10x |
- #' distributed.+ checkmate::assert_logical(annot_stats_vlines) |
||
| 13 | -+ | |||
| 265 | +10x |
- #' @param bandwidth (`numeric(1)` or `NULL`)\cr indicating the bandwidth of each window.+ checkmate::assert_list(control_coxph_pw) |
||
| 14 | -+ | |||
| 266 | +10x |
- #' Depending on the argument `use_percentile`, it can be either the length of actual-value+ checkmate::assert_character(ref_group_coxph, len = 1, null.ok = TRUE) |
||
| 15 | -+ | |||
| 267 | +10x |
- #' windows on the real biomarker scale, or percentage windows.+ checkmate::assert_list(control_annot_surv_med) |
||
| 16 | -+ | |||
| 268 | +10x |
- #' If `use_percentile = TRUE`, it should be a number between 0 and 1.+ checkmate::assert_list(control_annot_coxph) |
||
| 17 | -+ | |||
| 269 | +10x |
- #' If `NULL`, treat the bandwidth to be infinity, which means only one global model will be fitted.+ checkmate::assert_numeric(legend_pos, finite = TRUE, any.missing = FALSE, len = 2, null.ok = TRUE) |
||
| 18 | -+ | |||
| 270 | +10x |
- #' By default, `0.25` is used for percentage windows and one quarter of the range of the `biomarker`+ assert_proportion_value(rel_height_plot) |
||
| 19 | -+ | |||
| 271 | +10x |
- #' variable for actual-value windows.+ checkmate::assert_logical(as_list) |
||
| 20 | +272 |
- #' @param degree (`integer(1)`)\cr the degree of polynomial function of the biomarker as an interaction term+ |
||
| 21 | -+ | |||
| 273 | +10x |
- #' with the treatment arm fitted at each window. If 0 (default), then the biomarker variable+ tte <- variables$tte |
||
| 22 | -+ | |||
| 274 | +10x |
- #' is not included in the model fitted in each biomarker window.+ is_event <- variables$is_event |
||
| 23 | -+ | |||
| 275 | +10x |
- #' @param num_points (`integer(1)`)\cr the number of points at which the hazard ratios are estimated. The+ arm <- variables$arm |
||
| 24 | -+ | |||
| 276 | +10x |
- #' smallest number is 2.+ assert_valid_factor(df[[arm]]) |
||
| 25 | -+ | |||
| 277 | +10x |
- #'+ armval <- as.character(unique(df[[arm]])) |
||
| 26 | -+ | |||
| 278 | +10x |
- #' @return A list of components with the same names as the arguments, except `biomarker` which is+ assert_df_with_variables(df, list(tte = tte, is_event = is_event, arm = arm)) |
||
| 27 | -+ | |||
| 279 | +10x |
- #' just used to calculate the `bandwidth` in case that actual biomarker windows are requested.+ checkmate::assert_logical(df[[is_event]], min.len = 1) |
||
| 28 | -+ | |||
| 280 | +10x |
- #'+ checkmate::assert_numeric(df[[tte]], min.len = 1) |
||
| 29 | -+ | |||
| 281 | +10x |
- #' @examples+ checkmate::assert_vector(col, len = length(armval), null.ok = TRUE) |
||
| 30 | -+ | |||
| 282 | +10x |
- #' # Provide biomarker values and request actual values to be used,+ checkmate::assert_vector(lty, null.ok = TRUE) |
||
| 31 | -+ | |||
| 283 | +10x |
- #' # so that bandwidth is chosen from range.+ checkmate::assert_numeric(lwd, len = 1, null.ok = TRUE) |
||
| 32 | +284 |
- #' control_step(biomarker = 1:10, use_percentile = FALSE)+ |
||
| 33 | -+ | |||
| 285 | +10x |
- #'+ if (annot_coxph && length(armval) < 2) {
|
||
| 34 | -+ | |||
| 286 | +! |
- #' # Use a global model with quadratic biomarker interaction term.+ stop(paste( |
||
| 35 | -+ | |||
| 287 | +! |
- #' control_step(bandwidth = NULL, degree = 2)+ "When `annot_coxph` = TRUE, `df` must contain at least 2 levels of `variables$arm`", |
||
| 36 | -+ | |||
| 288 | +! |
- #'+ "in order to calculate the hazard ratio." |
||
| 37 | +289 |
- #' # Reduce number of points to be used.+ )) |
||
| 38 | +290 |
- #' control_step(num_points = 10)+ } |
||
| 39 | +291 |
- #'+ |
||
| 40 | +292 |
- #' @export+ # process model |
||
| 41 | -+ | |||
| 293 | +10x |
- control_step <- function(biomarker = NULL,+ yval <- match.arg(yval) |
||
| 42 | -+ | |||
| 294 | +10x |
- use_percentile = TRUE,+ formula <- stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", arm))
|
||
| 43 | -+ | |||
| 295 | +10x |
- bandwidth,+ fit_km <- survival::survfit( |
||
| 44 | -+ | |||
| 296 | +10x |
- degree = 0L,+ formula = formula, |
||
| 45 | -+ | |||
| 297 | +10x |
- num_points = 39L) {
+ data = df, |
||
| 46 | -31x | +298 | +10x |
- checkmate::assert_numeric(biomarker, null.ok = TRUE)+ conf.int = control_surv$conf_level, |
| 47 | -30x | +299 | +10x |
- checkmate::assert_flag(use_percentile)+ conf.type = control_surv$conf_type |
| 48 | -30x | +|||
| 300 | +
- checkmate::assert_int(num_points, lower = 2)+ ) |
|||
| 49 | -29x | +301 | +10x |
- checkmate::assert_count(degree)+ data <- h_data_plot(fit_km, armval = armval, max_time = max_time) |
| 50 | +302 | |||
| 51 | -29x | -
- if (missing(bandwidth)) {
- |
- ||
| 52 | +303 |
- # Infer bandwidth+ # calculate x-ticks |
||
| 53 | -21x | +304 | +10x |
- bandwidth <- if (use_percentile) {
+ xticks <- h_xticks(data = data, xticks = xticks, max_time = max_time) |
| 54 | -18x | +|||
| 305 | +
- 0.25+ |
|||
| 55 | -21x | +|||
| 306 | +
- } else if (!is.null(biomarker)) {
+ # change estimates of survival to estimates of failure (1 - survival) |
|||
| 56 | -3x | +307 | +10x |
- diff(range(biomarker, na.rm = TRUE)) / 4+ if (yval == "Failure") {
|
| 57 | -+ | |||
| 308 | +! |
- } else {
+ data[c("estimate", "conf.low", "conf.high", "censor")] <- list(
|
||
| 58 | +309 | ! |
- NULL+ 1 - data$estimate, 1 - data$conf.low, 1 - data$conf.high, 1 - data$censor |
|
| 59 | +310 |
- }+ ) |
||
| 60 | +311 |
- } else {
+ } |
||
| 61 | +312 |
- # Check bandwidth+ |
||
| 62 | -8x | +|||
| 313 | +
- if (!is.null(bandwidth)) {
+ # derive y-axis limits |
|||
| 63 | -5x | +314 | +10x |
- if (use_percentile) {
+ if (is.null(ylim)) {
|
| 64 | -4x | -
- assert_proportion_value(bandwidth)- |
- ||
| 65 | -+ | 315 | +10x |
- } else {
+ if (!is.null(max_time)) {
|
| 66 | +316 | 1x |
- checkmate::assert_scalar(bandwidth)+ y_lwr <- min(data[data$time < max_time, ][["estimate"]]) |
|
| 67 | +317 | 1x |
- checkmate::assert_true(bandwidth > 0)- |
- |
| 68 | -- |
- }- |
- ||
| 69 | -- |
- }+ y_upr <- max(data[data$time < max_time, ][["estimate"]]) |
||
| 70 | +318 |
- }+ } else {
|
||
| 71 | -28x | +319 | +9x |
- list(+ y_lwr <- min(data[["estimate"]]) |
| 72 | -28x | +320 | +9x |
- use_percentile = use_percentile,+ y_upr <- max(data[["estimate"]]) |
| 73 | -28x | +|||
| 321 | +
- bandwidth = bandwidth,+ } |
|||
| 74 | -28x | +322 | +10x |
- degree = as.integer(degree),+ ylim <- c(y_lwr, y_upr) |
| 75 | -28x | +|||
| 323 | +
- num_points = as.integer(num_points)+ } |
|||
| 76 | +324 |
- )+ |
||
| 77 | +325 |
- }+ # initialize ggplot |
| 1 | -+ | |||
| 326 | +10x |
- #' Cumulative counts of numeric variable by thresholds+ gg_plt <- ggplot( |
||
| 2 | -+ | |||
| 327 | +10x |
- #'+ data = data, |
||
| 3 | -+ | |||
| 328 | +10x |
- #' @description `r lifecycle::badge("stable")`
+ mapping = aes( |
||
| 4 | -+ | |||
| 329 | +10x |
- #'+ x = .data[["time"]], |
||
| 5 | -+ | |||
| 330 | +10x |
- #' The analyze function [count_cumulative()] creates a layout element to calculate cumulative counts of values in a+ y = .data[["estimate"]], |
||
| 6 | -+ | |||
| 331 | +10x |
- #' numeric variable that are less than, less or equal to, greater than, or greater or equal to user-specified+ ymin = .data[["conf.low"]], |
||
| 7 | -+ | |||
| 332 | +10x |
- #' threshold values.+ ymax = .data[["conf.high"]], |
||
| 8 | -+ | |||
| 333 | +10x |
- #'+ color = .data[["strata"]], |
||
| 9 | -+ | |||
| 334 | +10x |
- #' This function analyzes numeric variable `vars` against the threshold values supplied to the `thresholds`+ fill = .data[["strata"]] |
||
| 10 | +335 |
- #' argument as a numeric vector. Whether counts should include the threshold values, and whether to count+ ) |
||
| 11 | +336 |
- #' values lower or higher than the threshold values can be set via the `include_eq` and `lower_tail`+ ) + |
||
| 12 | -+ | |||
| 337 | +10x |
- #' parameters, respectively.+ theme_bw(base_size = font_size) + |
||
| 13 | -+ | |||
| 338 | +10x |
- #'+ scale_y_continuous(limits = ylim, expand = c(0.025, 0)) + |
||
| 14 | -+ | |||
| 339 | +10x |
- #' @inheritParams h_count_cumulative+ labs(title = title, x = xlab, y = ylab, caption = footnotes) + |
||
| 15 | -+ | |||
| 340 | +10x | +
+ theme(+ |
+ ||
| 341 | +10x | +
+ axis.text = element_text(size = font_size),+ |
+ ||
| 342 | +10x |
- #' @inheritParams argument_convention+ axis.title = element_text(size = font_size), |
||
| 16 | -+ | |||
| 343 | +10x |
- #' @param thresholds (`numeric`)\cr vector of cutoff values for the counts.+ legend.title = element_blank(), |
||
| 17 | -+ | |||
| 344 | +10x |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_cumulative")`
+ legend.text = element_text(size = font_size), |
||
| 18 | -+ | |||
| 345 | +10x |
- #' to see available statistics for this function.+ legend.box.background = element_rect(fill = "white", linewidth = 0.5), |
||
| 19 | -+ | |||
| 346 | +10x |
- #'+ legend.background = element_blank(), |
||
| 20 | -+ | |||
| 347 | +10x |
- #' @seealso Relevant helper function [h_count_cumulative()], and descriptive function [d_count_cumulative()].+ legend.position = "inside", |
||
| 21 | -+ | |||
| 348 | +10x |
- #'+ legend.spacing.y = unit(-0.02, "npc"), |
||
| 22 | -+ | |||
| 349 | +10x |
- #' @name count_cumulative+ panel.grid.major = element_blank(), |
||
| 23 | -+ | |||
| 350 | +10x |
- #' @order 1+ panel.grid.minor = element_blank() |
||
| 24 | +351 |
- NULL+ ) |
||
| 25 | +352 | |||
| 26 | +353 |
- #' Helper function for `s_count_cumulative()`+ # derive x-axis limits |
||
| 27 | -+ | |||
| 354 | +10x |
- #'+ if (!is.null(max_time) && !is.null(xticks)) {
|
||
| 28 | -+ | |||
| 355 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ gg_plt <- gg_plt + scale_x_continuous( |
||
| 29 | -+ | |||
| 356 | +1x |
- #'+ breaks = xticks, limits = c(min(0, xticks), max(c(xticks, max_time))), expand = c(0.025, 0) |
||
| 30 | +357 |
- #' Helper function to calculate count and fraction of `x` values in the lower or upper tail given a threshold.+ ) |
||
| 31 | -+ | |||
| 358 | +9x |
- #'+ } else if (!is.null(xticks)) {
|
||
| 32 | -+ | |||
| 359 | +9x |
- #' @inheritParams argument_convention+ if (max(data$time) <= max(xticks)) {
|
||
| 33 | -+ | |||
| 360 | +9x |
- #' @param threshold (`numeric(1)`)\cr a cutoff value as threshold to count values of `x`.+ gg_plt <- gg_plt + scale_x_continuous( |
||
| 34 | -+ | |||
| 361 | +9x |
- #' @param lower_tail (`flag`)\cr whether to count lower tail, default is `TRUE`.+ breaks = xticks, limits = c(min(0, min(xticks)), max(xticks)), expand = c(0.025, 0) |
||
| 35 | +362 |
- #' @param include_eq (`flag`)\cr whether to include value equal to the `threshold` in+ ) |
||
| 36 | +363 |
- #' count, default is `TRUE`.+ } else {
|
||
| 37 | -+ | |||
| 364 | +! |
- #'+ gg_plt <- gg_plt + scale_x_continuous(breaks = xticks, expand = c(0.025, 0)) |
||
| 38 | +365 |
- #' @return A named vector with items:+ } |
||
| 39 | -+ | |||
| 366 | +! |
- #' * `count`: the count of values less than, less or equal to, greater than, or greater or equal to a threshold+ } else if (!is.null(max_time)) {
|
||
| 40 | -+ | |||
| 367 | +! |
- #' of user specification.+ gg_plt <- gg_plt + scale_x_continuous(limits = c(0, max_time), expand = c(0.025, 0)) |
||
| 41 | +368 |
- #' * `fraction`: the fraction of the count.+ } |
||
| 42 | +369 |
- #'+ |
||
| 43 | +370 |
- #' @seealso [count_cumulative]+ # set legend position |
||
| 44 | -+ | |||
| 371 | +10x |
- #'+ if (!is.null(legend_pos)) {
|
||
| 45 | -+ | |||
| 372 | +2x |
- #' @examples+ gg_plt <- gg_plt + theme(legend.position.inside = legend_pos) |
||
| 46 | +373 |
- #' set.seed(1, kind = "Mersenne-Twister")+ } else {
|
||
| 47 | -+ | |||
| 374 | +8x |
- #' x <- c(sample(1:10, 10), NA)+ max_time2 <- sort( |
||
| 48 | -+ | |||
| 375 | +8x |
- #' .N_col <- length(x)+ data$time, |
||
| 49 | -+ | |||
| 376 | +8x |
- #'+ partial = nrow(data) - length(armval) - 1 |
||
| 50 | -+ | |||
| 377 | +8x |
- #' h_count_cumulative(x, 5, .N_col = .N_col)+ )[nrow(data) - length(armval) - 1] |
||
| 51 | +378 |
- #' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na.rm = FALSE, .N_col = .N_col)+ |
||
| 52 | -+ | |||
| 379 | +8x |
- #' h_count_cumulative(x, 0, lower_tail = FALSE, .N_col = .N_col)+ y_rng <- ylim[2] - ylim[1] |
||
| 53 | +380 |
- #' h_count_cumulative(x, 100, lower_tail = FALSE, .N_col = .N_col)+ |
||
| 54 | -+ | |||
| 381 | +8x |
- #'+ if (yval == "Survival" && all(data$estimate[data$time == max_time2] > ylim[1] + 0.09 * y_rng) && |
||
| 55 | -+ | |||
| 382 | +8x |
- #' @export+ all(data$estimate[data$time == max_time2] < ylim[1] + 0.5 * y_rng)) { # nolint
|
||
| 56 | -+ | |||
| 383 | +1x |
- h_count_cumulative <- function(x,+ gg_plt <- gg_plt + |
||
| 57 | -+ | |||
| 384 | +1x |
- threshold,+ theme( |
||
| 58 | -+ | |||
| 385 | +1x |
- lower_tail = TRUE,+ legend.position.inside = c(1, 0.5), |
||
| 59 | -+ | |||
| 386 | +1x |
- include_eq = TRUE,+ legend.justification = c(1.1, 0.6) |
||
| 60 | +387 |
- na.rm = TRUE, # nolint+ ) |
||
| 61 | +388 |
- .N_col) { # nolint
+ } else {
|
||
| 62 | -20x | +389 | +7x |
- checkmate::assert_numeric(x)+ gg_plt <- gg_plt + |
| 63 | -20x | +390 | +7x |
- checkmate::assert_numeric(threshold)+ theme( |
| 64 | -20x | +391 | +7x |
- checkmate::assert_numeric(.N_col)+ legend.position.inside = c(1, 0), |
| 65 | -20x | +392 | +7x |
- checkmate::assert_flag(lower_tail)+ legend.justification = c(1.1, -0.4) |
| 66 | -20x | +|||
| 393 | +
- checkmate::assert_flag(include_eq)+ ) |
|||
| 67 | -20x | +|||
| 394 | +
- checkmate::assert_flag(na.rm)+ } |
|||
| 68 | +395 | ++ |
+ }+ |
+ |
| 396 | ||||
| 69 | -20x | +|||
| 397 | +
- is_keep <- if (na.rm) !is.na(x) else rep(TRUE, length(x))+ # add lines |
|||
| 70 | -20x | +398 | +10x |
- count <- if (lower_tail && include_eq) {
+ gg_plt <- if (is.null(lty)) {
|
| 71 | -7x | +399 | +9x |
- length(x[is_keep & x <= threshold])+ gg_plt + geom_step(linewidth = lwd, na.rm = TRUE) |
| 72 | -20x | +400 | +10x |
- } else if (lower_tail && !include_eq) {
+ } else if (length(lty) == 1) {
|
| 73 | +401 | ! |
- length(x[is_keep & x < threshold])+ gg_plt + geom_step(linewidth = lwd, lty = lty, na.rm = TRUE) |
|
| 74 | -20x | +|||
| 402 | +
- } else if (!lower_tail && include_eq) {
+ } else {
|
|||
| 75 | -6x | +403 | +1x |
- length(x[is_keep & x >= threshold])+ gg_plt + |
| 76 | -20x | +404 | +1x |
- } else if (!lower_tail && !include_eq) {
+ geom_step(aes(lty = .data[["strata"]]), linewidth = lwd, na.rm = TRUE) + |
| 77 | -7x | +405 | +1x |
- length(x[is_keep & x > threshold])+ scale_linetype_manual(values = lty) |
| 78 | +406 |
} |
||
| 79 | +407 | |||
| 80 | -20x | +|||
| 408 | +
- result <- c(count = count, fraction = count / .N_col)+ # add censor marks |
|||
| 81 | -20x | +409 | +10x |
- result+ if (censor_show) {
|
| 82 | -+ | |||
| 410 | +10x |
- }+ gg_plt <- gg_plt + geom_point( |
||
| 83 | -+ | |||
| 411 | +10x |
-
+ data = data[data$n.censor != 0, ], |
||
| 84 | -+ | |||
| 412 | +10x |
- #' Description of cumulative count+ aes(x = .data[["time"]], y = .data[["censor"]], shape = "Censored"), |
||
| 85 | -+ | |||
| 413 | +10x |
- #'+ size = size, |
||
| 86 | -+ | |||
| 414 | +10x |
- #' @description `r lifecycle::badge("stable")`
+ na.rm = TRUE |
||
| 87 | +415 |
- #'+ ) + |
||
| 88 | -+ | |||
| 416 | +10x |
- #' This is a helper function that describes the analysis in [s_count_cumulative()].+ scale_shape_manual(name = NULL, values = pch) + |
||
| 89 | -+ | |||
| 417 | +10x |
- #'+ guides(fill = guide_legend(override.aes = list(shape = NA))) |
||
| 90 | +418 |
- #' @inheritParams h_count_cumulative+ } |
||
| 91 | +419 |
- #'+ |
||
| 92 | +420 |
- #' @return Labels for [s_count_cumulative()].+ # add ci ribbon |
||
| 93 | -+ | |||
| 421 | +1x |
- #'+ if (ci_ribbon) gg_plt <- gg_plt + geom_ribbon(alpha = 0.3, lty = 0, na.rm = TRUE) |
||
| 94 | +422 |
- #' @export+ |
||
| 95 | +423 |
- d_count_cumulative <- function(threshold, lower_tail = TRUE, include_eq = TRUE) {
+ # control aesthetics |
||
| 96 | -18x | +424 | +10x |
- checkmate::assert_numeric(threshold)+ if (!is.null(col)) {
|
| 97 | -18x | +425 | +1x |
- lg <- if (lower_tail) "<" else ">"+ gg_plt <- gg_plt + |
| 98 | -18x | +426 | +1x |
- eq <- if (include_eq) "=" else ""+ scale_color_manual(values = col) + |
| 99 | -18x | -
- paste0(lg, eq, " ", threshold)- |
- ||
| 100 | -- |
- }- |
- ||
| 101 | -- | - - | -||
| 102 | -+ | 427 | +1x |
- #' @describeIn count_cumulative Statistics function that produces a named list given a numeric vector of thresholds.+ scale_fill_manual(values = col) |
| 103 | +428 |
- #'+ } |
||
| 104 | -+ | |||
| 429 | +! |
- #' @return+ if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme |
||
| 105 | +430 |
- #' * `s_count_cumulative()` returns a named list of `count_fraction`s: a list with each `thresholds` value as a+ |
||
| 106 | +431 |
- #' component, each component containing a vector for the count and fraction.+ # annotate with stats (text/vlines) |
||
| 107 | -+ | |||
| 432 | +10x |
- #'+ if (!is.null(annot_stats)) {
|
||
| 108 | -+ | |||
| 433 | +! |
- #' @keywords internal+ if ("median" %in% annot_stats) {
|
||
| 109 | -+ | |||
| 434 | +! |
- s_count_cumulative <- function(x,+ fit_km_all <- survival::survfit( |
||
| 110 | -+ | |||
| 435 | +! |
- thresholds,+ formula = stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", 1)),
|
||
| 111 | -+ | |||
| 436 | +! |
- lower_tail = TRUE,+ data = df, |
||
| 112 | -+ | |||
| 437 | +! |
- include_eq = TRUE,+ conf.int = control_surv$conf_level, |
||
| 113 | -+ | |||
| 438 | +! |
- .N_col, # nolint+ conf.type = control_surv$conf_type |
||
| 114 | +439 |
- ...) {
+ ) |
||
| 115 | -5x | +|||
| 440 | +! |
- checkmate::assert_numeric(thresholds, min.len = 1, any.missing = FALSE)+ gg_plt <- gg_plt + |
||
| 116 | -+ | |||
| 441 | +! |
-
+ annotate( |
||
| 117 | -5x | +|||
| 442 | +! |
- count_fraction_list <- Map(function(thres) {
+ "text", |
||
| 118 | -10x | +|||
| 443 | +! |
- result <- h_count_cumulative(x, thres, lower_tail, include_eq, .N_col = .N_col, ...)+ size = font_size / .pt, col = 1, lineheight = 0.95, |
||
| 119 | -10x | +|||
| 444 | +! |
- label <- d_count_cumulative(thres, lower_tail, include_eq)+ x = stats::median(fit_km_all) + 0.07 * max(data$time), |
||
| 120 | -10x | +|||
| 445 | +! |
- formatters::with_label(result, label)+ y = ifelse(yval == "Survival", 0.65, 0.35), |
||
| 121 | -5x | +|||
| 446 | +! |
- }, thresholds)+ label = paste("Median F/U:\n", round(stats::median(fit_km_all), 1), tolower(df$AVALU[1]))
|
||
| 122 | +447 | - - | -||
| 123 | -5x | -
- names(count_fraction_list) <- thresholds- |
- ||
| 124 | -5x | -
- list(count_fraction = count_fraction_list)+ ) |
||
| 125 | -+ | |||
| 448 | +! |
- }+ if (annot_stats_vlines) {
|
||
| 126 | -+ | |||
| 449 | +! |
-
+ gg_plt <- gg_plt + |
||
| 127 | -+ | |||
| 450 | +! |
- #' @describeIn count_cumulative Formatted analysis function which is used as `afun`+ annotate( |
||
| 128 | -+ | |||
| 451 | +! |
- #' in `count_cumulative()`.+ "segment", |
||
| 129 | -+ | |||
| 452 | +! |
- #'+ x = stats::median(fit_km_all), xend = stats::median(fit_km_all), y = -Inf, yend = Inf, |
||
| 130 | -+ | |||
| 453 | +! |
- #' @return+ linetype = 2, col = "darkgray" |
||
| 131 | +454 |
- #' * `a_count_cumulative()` returns the corresponding list with formatted [rtables::CellValue()].+ ) |
||
| 132 | +455 |
- #'+ } |
||
| 133 | +456 |
- #' @keywords internal+ } |
||
| 134 | -+ | |||
| 457 | +! |
- a_count_cumulative <- make_afun(+ if ("min" %in% annot_stats) {
|
||
| 135 | -+ | |||
| 458 | +! |
- s_count_cumulative,+ min_fu <- min(df[[tte]]) |
||
| 136 | -+ | |||
| 459 | +! |
- .formats = c(count_fraction = format_count_fraction)+ gg_plt <- gg_plt + |
||
| 137 | -+ | |||
| 460 | +! |
- )+ annotate( |
||
| 138 | -+ | |||
| 461 | +! |
-
+ "text", |
||
| 139 | -+ | |||
| 462 | +! |
- #' @describeIn count_cumulative Layout-creating function which can take statistics function arguments+ size = font_size / .pt, col = 1, lineheight = 0.95, |
||
| 140 | -+ | |||
| 463 | +! |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ x = min_fu + max(data$time) * 0.07, |
||
| 141 | -+ | |||
| 464 | +! |
- #'+ y = ifelse(yval == "Survival", 0.96, 0.05), |
||
| 142 | -+ | |||
| 465 | +! |
- #' @return+ label = paste("Min. F/U:\n", round(min_fu, 1), tolower(df$AVALU[1]))
|
||
| 143 | +466 |
- #' * `count_cumulative()` returns a layout object suitable for passing to further layouting functions,+ ) |
||
| 144 | -+ | |||
| 467 | +! |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ if (annot_stats_vlines) {
|
||
| 145 | -+ | |||
| 468 | +! |
- #' the statistics from `s_count_cumulative()` to the table layout.+ gg_plt <- gg_plt + |
||
| 146 | -+ | |||
| 469 | +! |
- #'+ annotate( |
||
| 147 | -+ | |||
| 470 | +! |
- #' @examples+ "segment", |
||
| 148 | -+ | |||
| 471 | +! |
- #' basic_table() %>%+ linetype = 2, col = "darkgray", |
||
| 149 | -+ | |||
| 472 | +! |
- #' split_cols_by("ARM") %>%
+ x = min_fu, xend = min_fu, y = Inf, yend = -Inf |
||
| 150 | +473 |
- #' add_colcounts() %>%+ ) |
||
| 151 | +474 |
- #' count_cumulative(+ } |
||
| 152 | +475 |
- #' vars = "AGE",+ } |
||
| 153 | -+ | |||
| 476 | +! |
- #' thresholds = c(40, 60)+ gg_plt <- gg_plt + guides(fill = guide_legend(override.aes = list(shape = NA, label = ""))) |
||
| 154 | +477 |
- #' ) %>%+ } |
||
| 155 | +478 |
- #' build_table(tern_ex_adsl)+ |
||
| 156 | +479 |
- #'+ # add at risk annotation table |
||
| 157 | -+ | |||
| 480 | +10x |
- #' @export+ if (annot_at_risk) {
|
||
| 158 | -+ | |||
| 481 | +9x |
- #' @order 2+ annot_tbl <- summary(fit_km, times = xticks, extend = TRUE) |
||
| 159 | -+ | |||
| 482 | +9x |
- count_cumulative <- function(lyt,+ annot_tbl <- if (is.null(fit_km$strata)) {
|
||
| 160 | -+ | |||
| 483 | +! |
- vars,+ data.frame( |
||
| 161 | -+ | |||
| 484 | +! |
- thresholds,+ n.risk = annot_tbl$n.risk, |
||
| 162 | -+ | |||
| 485 | +! |
- lower_tail = TRUE,+ time = annot_tbl$time, |
||
| 163 | -+ | |||
| 486 | +! |
- include_eq = TRUE,+ strata = armval |
||
| 164 | +487 |
- var_labels = vars,+ ) |
||
| 165 | +488 |
- show_labels = "visible",+ } else {
|
||
| 166 | -+ | |||
| 489 | +9x |
- na_str = default_na_str(),+ strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
|
||
| 167 | -+ | |||
| 490 | +9x |
- nested = TRUE,+ levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2] |
||
| 168 | -+ | |||
| 491 | +9x |
- ...,+ data.frame( |
||
| 169 | -+ | |||
| 492 | +9x |
- table_names = vars,+ n.risk = annot_tbl$n.risk, |
||
| 170 | -+ | |||
| 493 | +9x |
- .stats = NULL,+ time = annot_tbl$time, |
||
| 171 | -+ | |||
| 494 | +9x |
- .formats = NULL,+ strata = annot_tbl$strata |
||
| 172 | +495 |
- .labels = NULL,+ ) |
||
| 173 | +496 |
- .indent_mods = NULL) {
- |
- ||
| 174 | -2x | -
- extra_args <- list(thresholds = thresholds, lower_tail = lower_tail, include_eq = include_eq, ...)+ } |
||
| 175 | +497 | |||
| 176 | -2x | +498 | +9x |
- afun <- make_afun(+ at_risk_tbl <- as.data.frame(tidyr::pivot_wider(annot_tbl, names_from = "time", values_from = "n.risk")[, -1]) |
| 177 | -2x | +499 | +9x |
- a_count_cumulative,+ at_risk_tbl[is.na(at_risk_tbl)] <- 0 |
| 178 | -2x | +500 | +9x |
- .stats = .stats,+ rownames(at_risk_tbl) <- levels(annot_tbl$strata)+ |
+
| 501 | ++ | + | ||
| 179 | -2x | +502 | +9x |
- .formats = .formats,+ gg_at_risk <- df2gg( |
| 180 | -2x | +503 | +9x |
- .labels = .labels,+ at_risk_tbl, |
| 181 | -2x | +504 | +9x |
- .indent_mods = .indent_mods,+ font_size = font_size, col_labels = FALSE, hline = FALSE, |
| 182 | -2x | +505 | +9x |
- .ungroup_stats = "count_fraction"+ colwidths = rep(1, ncol(at_risk_tbl)) |
| 183 | +506 |
- )+ ) + |
||
| 184 | -2x | +507 | +9x |
- analyze(+ labs(title = if (annot_at_risk_title) "Patients at Risk:" else NULL, x = xlab) + |
| 185 | -2x | +508 | +9x |
- lyt,+ theme_bw(base_size = font_size) + |
| 186 | -2x | +509 | +9x |
- vars,+ theme( |
| 187 | -2x | +510 | +9x |
- afun = afun,+ plot.title = element_text(size = font_size, vjust = 3, face = "bold"), |
| 188 | -2x | +511 | +9x |
- na_str = na_str,+ panel.border = element_blank(), |
| 189 | -2x | +512 | +9x |
- table_names = table_names,+ panel.grid = element_blank(), |
| 190 | -2x | +513 | +9x |
- var_labels = var_labels,+ axis.title.y = element_blank(), |
| 191 | -2x | +514 | +9x |
- show_labels = show_labels,+ axis.ticks.y = element_blank(), |
| 192 | -2x | +515 | +9x |
- nested = nested,+ axis.text.y = element_text(size = font_size, face = "italic", hjust = 1), |
| 193 | -2x | -
- extra_args = extra_args- |
- ||
| 194 | -- |
- )- |
- ||
| 195 | -- |
- }- |
-
| 1 | -- |
- #' Helper functions for multivariate logistic regression- |
- ||
| 2 | -+ | 516 | +9x |
- #'+ axis.text.x = element_text(size = font_size), |
| 3 | -+ | |||
| 517 | +9x |
- #' @description `r lifecycle::badge("stable")`
+ axis.line.x = element_line() |
||
| 4 | +518 |
- #'+ ) + |
||
| 5 | -+ | |||
| 519 | +9x |
- #' Helper functions used in calculations for logistic regression.+ coord_cartesian(clip = "off", ylim = c(0.5, nrow(at_risk_tbl))) |
||
| 6 | -+ | |||
| 520 | +9x |
- #'+ gg_at_risk <- suppressMessages( |
||
| 7 | -+ | |||
| 521 | +9x |
- #' @inheritParams argument_convention+ gg_at_risk + |
||
| 8 | -+ | |||
| 522 | +9x |
- #' @param fit_glm (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family.+ scale_x_continuous(expand = c(0.025, 0), breaks = seq_along(at_risk_tbl) - 0.5, labels = xticks) + |
||
| 9 | -+ | |||
| 523 | +9x |
- #' Limited functionality is also available for conditional logistic regression models fitted by+ scale_y_continuous(labels = rev(levels(annot_tbl$strata)), breaks = seq_len(nrow(at_risk_tbl))) |
||
| 10 | +524 |
- #' [survival::clogit()], currently this is used only by [extract_rsp_biomarkers()].+ ) |
||
| 11 | +525 |
- #' @param x (`character`)\cr a variable or interaction term in `fit_glm` (depending on the helper function used).+ |
||
| 12 | -+ | |||
| 526 | +9x |
- #'+ if (!as_list) {
|
||
| 13 | -+ | |||
| 527 | +8x |
- #' @examples+ gg_plt <- cowplot::plot_grid( |
||
| 14 | -+ | |||
| 528 | +8x |
- #' library(dplyr)+ gg_plt, |
||
| 15 | -+ | |||
| 529 | +8x |
- #' library(broom)+ gg_at_risk, |
||
| 16 | -+ | |||
| 530 | +8x |
- #'+ align = "v", |
||
| 17 | -+ | |||
| 531 | +8x |
- #' adrs_f <- tern_ex_adrs %>%+ axis = "tblr", |
||
| 18 | -+ | |||
| 532 | +8x |
- #' filter(PARAMCD == "BESRSPI") %>%+ ncol = 1, |
||
| 19 | -+ | |||
| 533 | +8x |
- #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ rel_heights = c(rel_height_plot, 1 - rel_height_plot) |
||
| 20 | +534 |
- #' mutate(+ ) |
||
| 21 | +535 |
- #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ } |
||
| 22 | +536 |
- #' RACE = factor(RACE),+ } |
||
| 23 | +537 |
- #' SEX = factor(SEX)+ |
||
| 24 | +538 |
- #' )+ # add median survival time annotation table |
||
| 25 | -+ | |||
| 539 | +10x |
- #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ if (annot_surv_med) {
|
||
| 26 | -+ | |||
| 540 | +8x |
- #' mod1 <- fit_logistic(+ surv_med_tbl <- h_tbl_median_surv(fit_km = fit_km, armval = armval) |
||
| 27 | -+ | |||
| 541 | +8x |
- #' data = adrs_f,+ bg_fill <- if (isTRUE(control_annot_surv_med[["fill"]])) "#00000020" else control_annot_surv_med[["fill"]] |
||
| 28 | +542 |
- #' variables = list(+ |
||
| 29 | -+ | |||
| 543 | +8x |
- #' response = "Response",+ gg_surv_med <- df2gg(surv_med_tbl, font_size = font_size, colwidths = c(1, 1, 2), bg_fill = bg_fill) + |
||
| 30 | -+ | |||
| 544 | +8x |
- #' arm = "ARMCD",+ theme( |
||
| 31 | -+ | |||
| 545 | +8x |
- #' covariates = c("AGE", "RACE")
+ axis.text.y = element_text(size = font_size, face = "italic", hjust = 1), |
||
| 32 | -+ | |||
| 546 | +8x |
- #' )+ plot.margin = margin(0, 2, 0, 5) |
||
| 33 | +547 |
- #' )+ ) + |
||
| 34 | -+ | |||
| 548 | +8x |
- #' mod2 <- fit_logistic(+ coord_cartesian(clip = "off", ylim = c(0.5, nrow(surv_med_tbl) + 1.5)) |
||
| 35 | -+ | |||
| 549 | +8x |
- #' data = adrs_f,+ gg_surv_med <- suppressMessages( |
||
| 36 | -+ | |||
| 550 | +8x |
- #' variables = list(+ gg_surv_med + |
||
| 37 | -+ | |||
| 551 | +8x |
- #' response = "Response",+ scale_x_continuous(expand = c(0.025, 0)) + |
||
| 38 | -+ | |||
| 552 | +8x |
- #' arm = "ARMCD",+ scale_y_continuous(labels = rev(rownames(surv_med_tbl)), breaks = seq_len(nrow(surv_med_tbl))) |
||
| 39 | +553 |
- #' covariates = c("AGE", "RACE"),
+ ) |
||
| 40 | +554 |
- #' interaction = "AGE"+ |
||
| 41 | -+ | |||
| 555 | +8x |
- #' )+ gg_plt <- cowplot::ggdraw(gg_plt) + |
||
| 42 | -+ | |||
| 556 | +8x |
- #' )+ cowplot::draw_plot( |
||
| 43 | -+ | |||
| 557 | +8x |
- #'+ gg_surv_med, |
||
| 44 | -+ | |||
| 558 | +8x |
- #' @name h_logistic_regression+ control_annot_surv_med[["x"]], |
||
| 45 | -+ | |||
| 559 | +8x |
- NULL+ control_annot_surv_med[["y"]], |
||
| 46 | -+ | |||
| 560 | +8x |
-
+ width = control_annot_surv_med[["w"]], |
||
| 47 | -+ | |||
| 561 | +8x |
- #' @describeIn h_logistic_regression Helper function to extract interaction variable names from a fitted+ height = control_annot_surv_med[["h"]], |
||
| 48 | -+ | |||
| 562 | +8x |
- #' model assuming only one interaction term.+ vjust = 0.5, |
||
| 49 | -+ | |||
| 563 | +8x |
- #'+ hjust = 0.5 |
||
| 50 | +564 |
- #' @return Vector of names of interaction variables.+ ) |
||
| 51 | +565 |
- #'+ } |
||
| 52 | +566 |
- #' @export+ |
||
| 53 | +567 |
- h_get_interaction_vars <- function(fit_glm) {
+ # add coxph annotation table |
||
| 54 | -34x | +568 | +10x |
- checkmate::assert_class(fit_glm, "glm")+ if (annot_coxph) {
|
| 55 | -34x | +569 | +1x |
- terms_name <- attr(stats::terms(fit_glm), "term.labels")+ coxph_tbl <- h_tbl_coxph_pairwise( |
| 56 | -34x | +570 | +1x |
- terms_order <- attr(stats::terms(fit_glm), "order")+ df = df, |
| 57 | -34x | +571 | +1x |
- interaction_term <- terms_name[terms_order == 2]+ variables = variables, |
| 58 | -34x | +572 | +1x |
- checkmate::assert_string(interaction_term)+ ref_group_coxph = ref_group_coxph, |
| 59 | -34x | +573 | +1x |
- strsplit(interaction_term, split = ":")[[1]]+ control_coxph_pw = control_coxph_pw, |
| 60 | -+ | |||
| 574 | +1x |
- }+ annot_coxph_ref_lbls = control_annot_coxph[["ref_lbls"]] |
||
| 61 | +575 |
-
+ ) |
||
| 62 | -+ | |||
| 576 | +1x |
- #' @describeIn h_logistic_regression Helper function to get the right coefficient name from the+ bg_fill <- if (isTRUE(control_annot_coxph[["fill"]])) "#00000020" else control_annot_coxph[["fill"]] |
||
| 63 | +577 |
- #' interaction variable names and the given levels. The main value here is that the order+ |
||
| 64 | -+ | |||
| 578 | +1x |
- #' of first and second variable is checked in the `interaction_vars` input.+ gg_coxph <- df2gg(coxph_tbl, font_size = font_size, colwidths = c(1.1, 1, 3), bg_fill = bg_fill) + |
||
| 65 | -+ | |||
| 579 | +1x |
- #'+ theme( |
||
| 66 | -+ | |||
| 580 | +1x |
- #' @param interaction_vars (`character(2)`)\cr interaction variable names.+ axis.text.y = element_text(size = font_size, face = "italic", hjust = 1), |
||
| 67 | -+ | |||
| 581 | +1x |
- #' @param first_var_with_level (`character(2)`)\cr the first variable name with the interaction level.+ plot.margin = margin(0, 2, 0, 5) |
||
| 68 | +582 |
- #' @param second_var_with_level (`character(2)`)\cr the second variable name with the interaction level.+ ) + |
||
| 69 | -+ | |||
| 583 | +1x |
- #'+ coord_cartesian(clip = "off", ylim = c(0.5, nrow(coxph_tbl) + 1.5)) |
||
| 70 | -+ | |||
| 584 | +1x |
- #' @return Name of coefficient.+ gg_coxph <- suppressMessages( |
||
| 71 | -+ | |||
| 585 | +1x |
- #'+ gg_coxph + |
||
| 72 | -+ | |||
| 586 | +1x |
- #' @export+ scale_x_continuous(expand = c(0.025, 0)) + |
||
| 73 | -+ | |||
| 587 | +1x |
- h_interaction_coef_name <- function(interaction_vars,+ scale_y_continuous(labels = rev(rownames(coxph_tbl)), breaks = seq_len(nrow(coxph_tbl))) |
||
| 74 | +588 |
- first_var_with_level,+ ) |
||
| 75 | +589 |
- second_var_with_level) {
+
|
||
| 76 | -55x | +590 | +1x |
- checkmate::assert_character(interaction_vars, len = 2, any.missing = FALSE)+ gg_plt <- cowplot::ggdraw(gg_plt) + |
| 77 | -55x | +591 | +1x |
- checkmate::assert_character(first_var_with_level, len = 2, any.missing = FALSE)+ cowplot::draw_plot( |
| 78 | -55x | +592 | +1x |
- checkmate::assert_character(second_var_with_level, len = 2, any.missing = FALSE)+ gg_coxph, |
| 79 | -55x | -
- checkmate::assert_subset(c(first_var_with_level[1], second_var_with_level[1]), interaction_vars)- |
- ||
| 80 | -+ | 593 | +1x |
-
+ control_annot_coxph[["x"]], |
| 81 | -55x | +594 | +1x |
- first_name <- paste(first_var_with_level, collapse = "")+ control_annot_coxph[["y"]], |
| 82 | -55x | +595 | +1x |
- second_name <- paste(second_var_with_level, collapse = "")+ width = control_annot_coxph[["w"]], |
| 83 | -55x | +596 | +1x |
- if (first_var_with_level[1] == interaction_vars[1]) {
+ height = control_annot_coxph[["h"]], |
| 84 | -36x | +597 | +1x |
- paste(first_name, second_name, sep = ":")+ vjust = 0.5, |
| 85 | -19x | +598 | +1x |
- } else if (second_var_with_level[1] == interaction_vars[1]) {
+ hjust = 0.5 |
| 86 | -19x | +|||
| 599 | +
- paste(second_name, first_name, sep = ":")+ ) |
|||
| 87 | +600 |
} |
||
| 88 | +601 |
- }+ |
||
| 89 | -+ | |||
| 602 | +10x |
-
+ if (as_list) {
|
||
| 90 | -+ | |||
| 603 | +1x |
- #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ list(plot = gg_plt, table = gg_at_risk) |
||
| 91 | +604 |
- #' for the case when both the odds ratio and the interaction variable are categorical.+ } else {
+ |
+ ||
| 605 | +9x | +
+ gg_plt |
||
| 92 | +606 |
- #'+ } |
||
| 93 | +607 |
- #' @param odds_ratio_var (`string`)\cr the odds ratio variable.+ } |
| 94 | +1 |
- #' @param interaction_var (`string`)\cr the interaction variable.+ #' Control function for descriptive statistics |
||
| 95 | +2 |
#' |
||
| 96 | +3 |
- #' @return Odds ratio.+ #' @description `r lifecycle::badge("stable")`
|
||
| 97 | +4 |
#' |
||
| 98 | +5 |
- #' @export+ #' Sets a list of parameters for summaries of descriptive statistics. Typically used internally to specify |
||
| 99 | +6 |
- h_or_cat_interaction <- function(odds_ratio_var,+ #' details for [s_summary()]. This function family is mainly used by [analyze_vars()]. |
||
| 100 | +7 |
- interaction_var,+ #' |
||
| 101 | +8 |
- fit_glm,+ #' @inheritParams argument_convention |
||
| 102 | +9 |
- conf_level = 0.95) {
+ #' @param quantiles (`numeric(2)`)\cr vector of length two to specify the quantiles to calculate. |
||
| 103 | -8x | +|||
| 10 | +
- interaction_vars <- h_get_interaction_vars(fit_glm)+ #' @param quantile_type (`numeric(1)`)\cr number between 1 and 9 selecting quantile algorithms to be used. |
|||
| 104 | -8x | +|||
| 11 | +
- checkmate::assert_string(odds_ratio_var)+ #' Default is set to 2 as this matches the default quantile algorithm in SAS `proc univariate` set by `QNTLDEF=5`. |
|||
| 105 | -8x | +|||
| 12 | +
- checkmate::assert_string(interaction_var)+ #' This differs from R's default. See more about `type` in [stats::quantile()]. |
|||
| 106 | -8x | +|||
| 13 | +
- checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars)+ #' @param test_mean (`numeric(1)`)\cr number to test against the mean under the null hypothesis when calculating |
|||
| 107 | -8x | +|||
| 14 | +
- checkmate::assert_vector(interaction_vars, len = 2)+ #' p-value. |
|||
| 108 | +15 |
-
+ #' |
||
| 109 | -8x | +|||
| 16 | +
- xs_level <- fit_glm$xlevels+ #' @return A list of components with the same names as the arguments. |
|||
| 110 | -8x | +|||
| 17 | +
- xs_coef <- stats::coef(fit_glm)+ #' |
|||
| 111 | -8x | +|||
| 18 | +
- xs_vcov <- stats::vcov(fit_glm)+ #' @export |
|||
| 112 | -8x | +|||
| 19 | +
- y <- list()+ control_analyze_vars <- function(conf_level = 0.95, |
|||
| 113 | -8x | +|||
| 20 | +
- for (var_level in xs_level[[odds_ratio_var]][-1]) {
+ quantiles = c(0.25, 0.75), |
|||
| 114 | -14x | +|||
| 21 | +
- x <- list()+ quantile_type = 2, |
|||
| 115 | -14x | +|||
| 22 | +
- for (ref_level in xs_level[[interaction_var]]) {
+ test_mean = 0) {
|
|||
| 116 | -38x | +23 | +1055x |
- coef_names <- paste0(odds_ratio_var, var_level)+ checkmate::assert_vector(quantiles, len = 2) |
| 117 | -38x | +24 | +1055x |
- if (ref_level != xs_level[[interaction_var]][1]) {
+ checkmate::assert_int(quantile_type, lower = 1, upper = 9) |
| 118 | -24x | +25 | +1055x |
- interaction_coef_name <- h_interaction_coef_name(+ checkmate::assert_numeric(test_mean) |
| 119 | -24x | +26 | +1055x |
- interaction_vars,+ lapply(quantiles, assert_proportion_value) |
| 120 | -24x | +27 | +1054x |
- c(odds_ratio_var, var_level),+ assert_proportion_value(conf_level) |
| 121 | -24x | +28 | +1053x |
- c(interaction_var, ref_level)+ list(conf_level = conf_level, quantiles = quantiles, quantile_type = quantile_type, test_mean = test_mean) |
| 122 | +29 |
- )- |
- ||
| 123 | -24x | -
- coef_names <- c(- |
- ||
| 124 | -24x | -
- coef_names,- |
- ||
| 125 | -24x | -
- interaction_coef_name+ } |
||
| 126 | +30 |
- )+ |
||
| 127 | +31 |
- }- |
- ||
| 128 | -38x | -
- if (length(coef_names) > 1) {
- |
- ||
| 129 | -24x | -
- ones <- t(c(1, 1))- |
- ||
| 130 | -24x | -
- est <- as.numeric(ones %*% xs_coef[coef_names])+ #' Analyze variables |
||
| 131 | -24x | +|||
| 32 | +
- se <- sqrt(as.numeric(ones %*% xs_vcov[coef_names, coef_names] %*% t(ones)))+ #' |
|||
| 132 | +33 |
- } else {
+ #' @description `r lifecycle::badge("stable")`
|
||
| 133 | -14x | +|||
| 34 | +
- est <- xs_coef[coef_names]+ #' |
|||
| 134 | -14x | +|||
| 35 | +
- se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ #' The analyze function [analyze_vars()] creates a layout element to summarize one or more variables, using the S3 |
|||
| 135 | +36 |
- }+ #' generic function [s_summary()] to calculate a list of summary statistics. A list of all available statistics for |
||
| 136 | -38x | +|||
| 37 | +
- or <- exp(est)+ #' numeric variables can be viewed by running `get_stats("analyze_vars_numeric")` and for non-numeric variables by
|
|||
| 137 | -38x | +|||
| 38 | +
- ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ #' running `get_stats("analyze_vars_counts")`. Use the `.stats` parameter to specify the statistics to include in your
|
|||
| 138 | -38x | +|||
| 39 | +
- x[[ref_level]] <- list(or = or, ci = ci)+ #' output summary table. |
|||
| 139 | +40 |
- }+ #' |
||
| 140 | -14x | +|||
| 41 | +
- y[[var_level]] <- x+ #' @details |
|||
| 141 | +42 |
- }+ #' **Automatic digit formatting:** The number of digits to display can be automatically determined from the analyzed |
||
| 142 | -8x | +|||
| 43 | +
- y+ #' variable(s) (`vars`) for certain statistics by setting the statistic format to `"auto"` in `.formats`. |
|||
| 143 | +44 |
- }+ #' This utilizes the [format_auto()] formatting function. Note that only data for the current row & variable (for all |
||
| 144 | +45 |
-
+ #' columns) will be considered (`.df_row[[.var]]`, see [`rtables::additional_fun_params`]) and not the whole dataset. |
||
| 145 | +46 |
- #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ #' |
||
| 146 | +47 |
- #' for the case when either the odds ratio or the interaction variable is continuous.+ #' @inheritParams argument_convention |
||
| 147 | +48 |
- #'+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("analyze_vars_numeric")` to see
|
||
| 148 | +49 |
- #' @param at (`numeric` or `NULL`)\cr optional values for the interaction variable. Otherwise+ #' statistics available for numeric variables, and `get_stats("analyze_vars_counts")` for statistics available
|
||
| 149 | +50 |
- #' the median is used.+ #' for non-numeric variables. |
||
| 150 | +51 |
#' |
||
| 151 | +52 |
- #' @return Odds ratio.+ #' @name analyze_variables |
||
| 152 | +53 |
- #'+ #' @order 1 |
||
| 153 | +54 |
- #' @note We don't provide a function for the case when both variables are continuous because+ NULL |
||
| 154 | +55 |
- #' this does not arise in this table, as the treatment arm variable will always be involved+ |
||
| 155 | +56 |
- #' and categorical.+ #' @describeIn analyze_variables S3 generic function to produces a variable summary. |
||
| 156 | +57 |
#' |
||
| 157 | +58 |
- #' @export+ #' @return |
||
| 158 | +59 |
- h_or_cont_interaction <- function(odds_ratio_var,+ #' * `s_summary()` returns different statistics depending on the class of `x`. |
||
| 159 | +60 |
- interaction_var,+ #' |
||
| 160 | +61 |
- fit_glm,+ #' @export |
||
| 161 | +62 |
- at = NULL,+ s_summary <- function(x, |
||
| 162 | +63 |
- conf_level = 0.95) {
- |
- ||
| 163 | -13x | -
- interaction_vars <- h_get_interaction_vars(fit_glm)+ na.rm = TRUE, # nolint |
||
| 164 | -13x | +|||
| 64 | +
- checkmate::assert_string(odds_ratio_var)+ denom, |
|||
| 165 | -13x | +|||
| 65 | +
- checkmate::assert_string(interaction_var)+ .N_row, # nolint |
|||
| 166 | -13x | +|||
| 66 | +
- checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars)+ .N_col, # nolint |
|||
| 167 | -13x | +|||
| 67 | +
- checkmate::assert_vector(interaction_vars, len = 2)+ .var, |
|||
| 168 | -13x | +|||
| 68 | +
- checkmate::assert_numeric(at, min.len = 1, null.ok = TRUE, any.missing = FALSE)+ ...) {
|
|||
| 169 | -13x | +69 | +1559x |
- xs_level <- fit_glm$xlevels+ checkmate::assert_flag(na.rm) |
| 170 | -13x | +70 | +1559x |
- xs_coef <- stats::coef(fit_glm)+ UseMethod("s_summary", x)
|
| 171 | -13x | +|||
| 71 | +
- xs_vcov <- stats::vcov(fit_glm)+ } |
|||
| 172 | -13x | +|||
| 72 | +
- xs_class <- attr(fit_glm$terms, "dataClasses")+ |
|||
| 173 | -13x | +|||
| 73 | +
- model_data <- fit_glm$model+ #' @describeIn analyze_variables Method for `numeric` class. |
|||
| 174 | -13x | +|||
| 74 | +
- if (!is.null(at)) {
+ #' |
|||
| 175 | -3x | +|||
| 75 | +
- checkmate::assert_set_equal(xs_class[interaction_var], "numeric")+ #' @param control (`list`)\cr parameters for descriptive statistics details, specified by using |
|||
| 176 | +76 |
- }+ #' the helper function [control_analyze_vars()]. Some possible parameter options are: |
||
| 177 | -12x | +|||
| 77 | +
- y <- list()+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for mean and median. |
|||
| 178 | -12x | +|||
| 78 | +
- if (xs_class[interaction_var] == "numeric") {
+ #' * `quantiles` (`numeric(2)`)\cr vector of length two to specify the quantiles. |
|||
| 179 | -7x | +|||
| 79 | +
- if (is.null(at)) {
+ #' * `quantile_type` (`numeric(1)`)\cr between 1 and 9 selecting quantile algorithms to be used. |
|||
| 180 | -5x | +|||
| 80 | +
- at <- ceiling(stats::median(model_data[[interaction_var]]))+ #' See more about `type` in [stats::quantile()]. |
|||
| 181 | +81 |
- }+ #' * `test_mean` (`numeric(1)`)\cr value to test against the mean under the null hypothesis when calculating p-value. |
||
| 182 | +82 |
-
+ #' |
||
| 183 | -7x | +|||
| 83 | +
- for (var_level in xs_level[[odds_ratio_var]][-1]) {
+ #' @return |
|||
| 184 | -14x | +|||
| 84 | +
- x <- list()+ #' * If `x` is of class `numeric`, returns a `list` with the following named `numeric` items: |
|||
| 185 | -14x | +|||
| 85 | +
- for (increment in at) {
+ #' * `n`: The [length()] of `x`. |
|||
| 186 | -20x | +|||
| 86 | +
- coef_names <- paste0(odds_ratio_var, var_level)+ #' * `sum`: The [sum()] of `x`. |
|||
| 187 | -20x | +|||
| 87 | +
- if (increment != 0) {
+ #' * `mean`: The [mean()] of `x`. |
|||
| 188 | -20x | +|||
| 88 | +
- interaction_coef_name <- h_interaction_coef_name(+ #' * `sd`: The [stats::sd()] of `x`. |
|||
| 189 | -20x | +|||
| 89 | +
- interaction_vars,+ #' * `se`: The standard error of `x` mean, i.e.: (`sd(x) / sqrt(length(x))`). |
|||
| 190 | -20x | +|||
| 90 | +
- c(odds_ratio_var, var_level),+ #' * `mean_sd`: The [mean()] and [stats::sd()] of `x`. |
|||
| 191 | -20x | +|||
| 91 | +
- c(interaction_var, "")+ #' * `mean_se`: The [mean()] of `x` and its standard error (see above). |
|||
| 192 | +92 |
- )+ #' * `mean_ci`: The CI for the mean of `x` (from [stat_mean_ci()]). |
||
| 193 | -20x | +|||
| 93 | +
- coef_names <- c(+ #' * `mean_sei`: The SE interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()] / [sqrt()]). |
|||
| 194 | -20x | +|||
| 94 | +
- coef_names,+ #' * `mean_sdi`: The SD interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()]). |
|||
| 195 | -20x | +|||
| 95 | +
- interaction_coef_name+ #' * `mean_pval`: The two-sided p-value of the mean of `x` (from [stat_mean_pval()]). |
|||
| 196 | +96 |
- )+ #' * `median`: The [stats::median()] of `x`. |
||
| 197 | +97 |
- }+ #' * `mad`: The median absolute deviation of `x`, i.e.: ([stats::median()] of `xc`, |
||
| 198 | -20x | +|||
| 98 | +
- if (length(coef_names) > 1) {
+ #' where `xc` = `x` - [stats::median()]). |
|||
| 199 | -20x | +|||
| 99 | +
- xvec <- t(c(1, increment))+ #' * `median_ci`: The CI for the median of `x` (from [stat_median_ci()]). |
|||
| 200 | -20x | +|||
| 100 | +
- est <- as.numeric(xvec %*% xs_coef[coef_names])+ #' * `quantiles`: Two sample quantiles of `x` (from [stats::quantile()]). |
|||
| 201 | -20x | +|||
| 101 | +
- se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec)))+ #' * `iqr`: The [stats::IQR()] of `x`. |
|||
| 202 | +102 |
- } else {
+ #' * `range`: The [range_noinf()] of `x`. |
||
| 203 | -! | +|||
| 103 | +
- est <- xs_coef[coef_names]+ #' * `min`: The [max()] of `x`. |
|||
| 204 | -! | +|||
| 104 | +
- se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ #' * `max`: The [min()] of `x`. |
|||
| 205 | +105 |
- }+ #' * `median_range`: The [median()] and [range_noinf()] of `x`. |
||
| 206 | -20x | +|||
| 106 | +
- or <- exp(est)+ #' * `cv`: The coefficient of variation of `x`, i.e.: ([stats::sd()] / [mean()] * 100). |
|||
| 207 | -20x | +|||
| 107 | +
- ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ #' * `geom_mean`: The geometric mean of `x`, i.e.: (`exp(mean(log(x)))`). |
|||
| 208 | -20x | +|||
| 108 | +
- x[[as.character(increment)]] <- list(or = or, ci = ci)+ #' * `geom_cv`: The geometric coefficient of variation of `x`, i.e.: (`sqrt(exp(sd(log(x)) ^ 2) - 1) * 100`). |
|||
| 209 | +109 |
- }+ #' |
||
| 210 | -14x | +|||
| 110 | +
- y[[var_level]] <- x+ #' @note |
|||
| 211 | +111 |
- }+ #' * If `x` is an empty vector, `NA` is returned. This is the expected feature so as to return `rcell` content in |
||
| 212 | +112 |
- } else {
+ #' `rtables` when the intersection of a column and a row delimits an empty data selection. |
||
| 213 | -5x | +|||
| 113 | +
- checkmate::assert_set_equal(xs_class[odds_ratio_var], "numeric")+ #' * When the `mean` function is applied to an empty vector, `NA` will be returned instead of `NaN`, the latter |
|||
| 214 | -5x | +|||
| 114 | +
- checkmate::assert_set_equal(xs_class[interaction_var], "factor")+ #' being standard behavior in R. |
|||
| 215 | -5x | +|||
| 115 | +
- for (var_level in xs_level[[interaction_var]]) {
+ #' |
|||
| 216 | -15x | +|||
| 116 | +
- coef_names <- odds_ratio_var+ #' @method s_summary numeric |
|||
| 217 | -15x | +|||
| 117 | +
- if (var_level != xs_level[[interaction_var]][1]) {
+ #' |
|||
| 218 | -10x | +|||
| 118 | +
- interaction_coef_name <- h_interaction_coef_name(+ #' @examples |
|||
| 219 | -10x | +|||
| 119 | +
- interaction_vars,+ #' # `s_summary.numeric` |
|||
| 220 | -10x | +|||
| 120 | +
- c(odds_ratio_var, ""),+ #' |
|||
| 221 | -10x | +|||
| 121 | +
- c(interaction_var, var_level)+ #' ## Basic usage: empty numeric returns NA-filled items. |
|||
| 222 | +122 |
- )+ #' s_summary(numeric()) |
||
| 223 | -10x | +|||
| 123 | +
- coef_names <- c(+ #' |
|||
| 224 | -10x | +|||
| 124 | +
- coef_names,+ #' ## Management of NA values. |
|||
| 225 | -10x | +|||
| 125 | +
- interaction_coef_name+ #' x <- c(NA_real_, 1) |
|||
| 226 | +126 |
- )+ #' s_summary(x, na.rm = TRUE) |
||
| 227 | +127 |
- }+ #' s_summary(x, na.rm = FALSE) |
||
| 228 | -15x | +|||
| 128 | +
- if (length(coef_names) > 1) {
+ #' |
|||
| 229 | -10x | +|||
| 129 | +
- xvec <- t(c(1, 1))+ #' x <- c(NA_real_, 1, 2) |
|||
| 230 | -10x | +|||
| 130 | +
- est <- as.numeric(xvec %*% xs_coef[coef_names])+ #' s_summary(x, stats = NULL) |
|||
| 231 | -10x | +|||
| 131 | +
- se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec)))+ #' |
|||
| 232 | +132 |
- } else {
+ #' ## Benefits in `rtables` contructions: |
||
| 233 | -5x | +|||
| 133 | +
- est <- xs_coef[coef_names]+ #' dta_test <- data.frame( |
|||
| 234 | -5x | +|||
| 134 | +
- se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ #' Group = rep(LETTERS[1:3], each = 2), |
|||
| 235 | +135 |
- }+ #' sub_group = rep(letters[1:2], each = 3), |
||
| 236 | -15x | +|||
| 136 | +
- or <- exp(est)+ #' x = 1:6 |
|||
| 237 | -15x | +|||
| 137 | +
- ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ #' ) |
|||
| 238 | -15x | +|||
| 138 | +
- y[[var_level]] <- list(or = or, ci = ci)+ #' |
|||
| 239 | +139 |
- }+ #' ## The summary obtained in with `rtables`: |
||
| 240 | +140 |
- }+ #' basic_table() %>% |
||
| 241 | -12x | +|||
| 141 | +
- y+ #' split_cols_by(var = "Group") %>% |
|||
| 242 | +142 |
- }+ #' split_rows_by(var = "sub_group") %>% |
||
| 243 | +143 |
-
+ #' analyze(vars = "x", afun = s_summary) %>% |
||
| 244 | +144 |
- #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ #' build_table(df = dta_test) |
||
| 245 | +145 |
- #' in case of an interaction. This is a wrapper for [h_or_cont_interaction()] and+ #' |
||
| 246 | +146 |
- #' [h_or_cat_interaction()].+ #' ## By comparison with `lapply`: |
||
| 247 | +147 |
- #'+ #' X <- split(dta_test, f = with(dta_test, interaction(Group, sub_group))) |
||
| 248 | +148 |
- #' @return Odds ratio.+ #' lapply(X, function(x) s_summary(x$x)) |
||
| 249 | +149 |
#' |
||
| 250 | +150 |
#' @export |
||
| 251 | +151 |
- h_or_interaction <- function(odds_ratio_var,+ s_summary.numeric <- function(x, |
||
| 252 | +152 |
- interaction_var,+ na.rm = TRUE, # nolint |
||
| 253 | +153 |
- fit_glm,+ denom, |
||
| 254 | +154 |
- at = NULL,+ .N_row, # nolint |
||
| 255 | +155 |
- conf_level = 0.95) {
+ .N_col, # nolint |
||
| 256 | -15x | +|||
| 156 | +
- xs_class <- attr(fit_glm$terms, "dataClasses")+ .var, |
|||
| 257 | -15x | +|||
| 157 | +
- if (any(xs_class[c(odds_ratio_var, interaction_var)] == "numeric")) {
+ control = control_analyze_vars(), |
|||
| 258 | -9x | +|||
| 158 | +
- h_or_cont_interaction(+ ...) {
|
|||
| 259 | -9x | +159 | +1098x |
- odds_ratio_var,+ checkmate::assert_numeric(x) |
| 260 | -9x | +|||
| 160 | +
- interaction_var,+ |
|||
| 261 | -9x | +161 | +1098x |
- fit_glm,+ if (na.rm) {
|
| 262 | -9x | +162 | +1096x |
- at = at,+ x <- x[!is.na(x)] |
| 263 | -9x | +|||
| 163 | +
- conf_level = conf_level+ } |
|||
| 264 | +164 |
- )+ |
||
| 265 | -6x | +165 | +1098x |
- } else if (all(xs_class[c(odds_ratio_var, interaction_var)] == "factor")) {
+ y <- list() |
| 266 | -6x | +|||
| 166 | +
- h_or_cat_interaction(+ |
|||
| 267 | -6x | +167 | +1098x |
- odds_ratio_var,+ y$n <- c("n" = length(x))
|
| 268 | -6x | +|||
| 168 | +
- interaction_var,+ |
|||
| 269 | -6x | +169 | +1098x |
- fit_glm,+ y$sum <- c("sum" = ifelse(length(x) == 0, NA_real_, sum(x, na.rm = FALSE)))
|
| 270 | -6x | +|||
| 170 | +
- conf_level = conf_level+ |
|||
| 271 | -+ | |||
| 171 | +1098x |
- )+ y$mean <- c("mean" = ifelse(length(x) == 0, NA_real_, mean(x, na.rm = FALSE)))
|
||
| 272 | +172 |
- } else {
+
|
||
| 273 | -! | +|||
| 173 | +1098x |
- stop("wrong interaction variable class, the interaction variable is not a numeric nor a factor")
+ y$sd <- c("sd" = stats::sd(x, na.rm = FALSE))
|
||
| 274 | +174 |
- }+ |
||
| 275 | -+ | |||
| 175 | +1098x |
- }+ y$se <- c("se" = stats::sd(x, na.rm = FALSE) / sqrt(length(stats::na.omit(x))))
|
||
| 276 | +176 | |||
| 277 | -+ | |||
| 177 | +1098x |
- #' @describeIn h_logistic_regression Helper function to construct term labels from simple terms and the table+ y$mean_sd <- c(y$mean, "sd" = stats::sd(x, na.rm = FALSE)) |
||
| 278 | +178 |
- #' of numbers of patients.+ |
||
| 279 | -+ | |||
| 179 | +1098x |
- #'+ y$mean_se <- c(y$mean, y$se) |
||
| 280 | +180 |
- #' @param terms (`character`)\cr simple terms.+ |
||
| 281 | -+ | |||
| 181 | +1098x |
- #' @param table (`table`)\cr table containing numbers for terms.+ mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE) |
||
| 282 | -+ | |||
| 182 | +1098x |
- #'+ y$mean_ci <- formatters::with_label(mean_ci, paste("Mean", f_conf_level(control$conf_level)))
|
||
| 283 | +183 |
- #' @return Term labels containing numbers of patients.+ |
||
| 284 | -+ | |||
| 184 | +1098x |
- #'+ mean_sei <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE) / sqrt(y$n) |
||
| 285 | -+ | |||
| 185 | +1098x |
- #' @export+ names(mean_sei) <- c("mean_sei_lwr", "mean_sei_upr")
|
||
| 286 | -+ | |||
| 186 | +1098x |
- h_simple_term_labels <- function(terms,+ y$mean_sei <- formatters::with_label(mean_sei, "Mean -/+ 1xSE") |
||
| 287 | +187 |
- table) {
+
|
||
| 288 | -54x | +188 | +1098x |
- checkmate::assert_true(is.table(table))+ mean_sdi <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE) |
| 289 | -54x | +189 | +1098x |
- checkmate::assert_multi_class(terms, classes = c("factor", "character"))
+ names(mean_sdi) <- c("mean_sdi_lwr", "mean_sdi_upr")
|
| 290 | -54x | +190 | +1098x |
- terms <- as.character(terms)+ y$mean_sdi <- formatters::with_label(mean_sdi, "Mean -/+ 1xSD") |
| 291 | -54x | +|||
| 191 | +
- term_n <- table[terms]+ |
|||
| 292 | -54x | +192 | +1098x |
- paste0(terms, ", n = ", term_n)+ mean_pval <- stat_mean_pval(x, test_mean = control$test_mean, na.rm = FALSE, n_min = 2) |
| 293 | -+ | |||
| 193 | +1098x |
- }+ y$mean_pval <- formatters::with_label(mean_pval, paste("Mean", f_pval(control$test_mean)))
|
||
| 294 | +194 | |||
| 295 | -+ | |||
| 195 | +1098x |
- #' @describeIn h_logistic_regression Helper function to construct term labels from interaction terms and the table+ y$median <- c("median" = stats::median(x, na.rm = FALSE))
|
||
| 296 | +196 |
- #' of numbers of patients.+ + |
+ ||
| 197 | +1098x | +
+ y$mad <- c("mad" = stats::median(x - y$median, na.rm = FALSE))
|
||
| 297 | +198 |
- #'+ |
||
| 298 | -+ | |||
| 199 | +1098x |
- #' @param terms1 (`character`)\cr terms for first dimension (rows).+ median_ci <- stat_median_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE) |
||
| 299 | -+ | |||
| 200 | +1098x |
- #' @param terms2 (`character`)\cr terms for second dimension (rows).+ y$median_ci <- formatters::with_label(median_ci, paste("Median", f_conf_level(control$conf_level)))
|
||
| 300 | +201 |
- #' @param any (`flag`)\cr whether any of `term1` and `term2` can be fulfilled to count the+ |
||
| 301 | -+ | |||
| 202 | +1098x |
- #' number of patients. In that case they can only be scalar (strings).+ q <- control$quantiles |
||
| 302 | -+ | |||
| 203 | +1098x |
- #'+ if (any(is.na(x))) {
|
||
| 303 | -+ | |||
| 204 | +2x |
- #' @return Term labels containing numbers of patients.+ qnts <- rep(NA_real_, length(q)) |
||
| 304 | +205 |
- #'+ } else {
|
||
| 305 | -+ | |||
| 206 | +1096x |
- #' @export+ qnts <- stats::quantile(x, probs = q, type = control$quantile_type, na.rm = FALSE) |
||
| 306 | +207 |
- h_interaction_term_labels <- function(terms1,+ } |
||
| 307 | -+ | |||
| 208 | +1098x |
- terms2,+ names(qnts) <- paste("quantile", q, sep = "_")
|
||
| 308 | -+ | |||
| 209 | +1098x |
- table,+ y$quantiles <- formatters::with_label(qnts, paste0(paste(paste0(q * 100, "%"), collapse = " and "), "-ile")) |
||
| 309 | +210 |
- any = FALSE) {
+
|
||
| 310 | -8x | +211 | +1098x |
- checkmate::assert_true(is.table(table))+ y$iqr <- c("iqr" = ifelse(
|
| 311 | -8x | +212 | +1098x |
- checkmate::assert_flag(any)+ any(is.na(x)), |
| 312 | -8x | +213 | +1098x |
- checkmate::assert_multi_class(terms1, classes = c("factor", "character"))
+ NA_real_, |
| 313 | -8x | +214 | +1098x |
- checkmate::assert_multi_class(terms2, classes = c("factor", "character"))
+ stats::IQR(x, na.rm = FALSE, type = control$quantile_type) |
| 314 | -8x | +|||
| 215 | +
- terms1 <- as.character(terms1)+ )) |
|||
| 315 | -8x | +|||
| 216 | +
- terms2 <- as.character(terms2)+ |
|||
| 316 | -8x | +217 | +1098x |
- if (any) {
+ y$range <- stats::setNames(range_noinf(x, na.rm = FALSE), c("min", "max"))
|
| 317 | -4x | +218 | +1098x |
- checkmate::assert_scalar(terms1)+ y$min <- y$range[1] |
| 318 | -4x | +219 | +1098x |
- checkmate::assert_scalar(terms2)+ y$max <- y$range[2] |
| 319 | -4x | +|||
| 220 | +
- paste0(+ |
|||
| 320 | -4x | +221 | +1098x |
- terms1, " or ", terms2, ", n = ",+ y$median_range <- formatters::with_label(c(y$median, y$range), "Median (Min - Max)") |
| 321 | +222 |
- # Note that we double count in the initial sum the cell [terms1, terms2], therefore subtract.+ |
||
| 322 | -4x | +223 | +1098x |
- sum(c(table[terms1, ], table[, terms2])) - table[terms1, terms2]+ y$cv <- c("cv" = unname(y$sd) / unname(y$mean) * 100)
|
| 323 | +224 |
- )+ |
||
| 324 | +225 |
- } else {
+ # Convert negative values to NA for log calculation. |
||
| 325 | -4x | +226 | +1098x |
- term_n <- table[cbind(terms1, terms2)]+ x_no_negative_vals <- x |
| 326 | -4x | +227 | +1098x |
- paste0(terms1, " * ", terms2, ", n = ", term_n)+ x_no_negative_vals[x_no_negative_vals <= 0] <- NA |
| 327 | -+ | |||
| 228 | +1098x |
- }+ y$geom_mean <- c("geom_mean" = exp(mean(log(x_no_negative_vals), na.rm = FALSE)))
|
||
| 328 | -+ | |||
| 229 | +1098x |
- }+ geom_mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE, geom_mean = TRUE) |
||
| 329 | -+ | |||
| 230 | +1098x |
-
+ y$geom_mean_ci <- formatters::with_label(geom_mean_ci, paste("Geometric Mean", f_conf_level(control$conf_level)))
|
||
| 330 | +231 |
- #' @describeIn h_logistic_regression Helper function to tabulate the main effect+ |
||
| 331 | -+ | |||
| 232 | +1098x |
- #' results of a (conditional) logistic regression model.+ y$geom_cv <- c("geom_cv" = sqrt(exp(stats::sd(log(x_no_negative_vals), na.rm = FALSE) ^ 2) - 1) * 100) # styler: off
|
||
| 332 | +233 |
- #'+ |
||
| 333 | -+ | |||
| 234 | +1098x |
- #' @return Tabulated main effect results from a logistic regression model.+ y |
||
| 334 | +235 |
- #'+ } |
||
| 335 | +236 |
- #' @examples+ |
||
| 336 | +237 |
- #' h_glm_simple_term_extract("AGE", mod1)
+ #' @describeIn analyze_variables Method for `factor` class. |
||
| 337 | +238 |
- #' h_glm_simple_term_extract("ARMCD", mod1)
+ #' |
||
| 338 | +239 |
- #'+ #' @param denom (`string`)\cr choice of denominator for factor proportions. Options are: |
||
| 339 | +240 |
- #' @export+ #' * `n`: number of values in this row and column intersection. |
||
| 340 | +241 |
- h_glm_simple_term_extract <- function(x, fit_glm) {
- |
- ||
| 341 | -78x | -
- checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
- |
- ||
| 342 | -78x | -
- checkmate::assert_string(x)+ #' * `N_row`: total number of values in this row across columns. |
||
| 343 | +242 | - - | -||
| 344 | -78x | -
- xs_class <- attr(fit_glm$terms, "dataClasses")+ #' * `N_col`: total number of values in this column across rows. |
||
| 345 | -78x | +|||
| 243 | +
- xs_level <- fit_glm$xlevels+ #' |
|||
| 346 | -78x | +|||
| 244 | +
- xs_coef <- summary(fit_glm)$coefficients+ #' @return |
|||
| 347 | -78x | +|||
| 245 | +
- stats <- if (inherits(fit_glm, "glm")) {
+ #' * If `x` is of class `factor` or converted from `character`, returns a `list` with named `numeric` items: |
|||
| 348 | -66x | +|||
| 246 | +
- c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
+ #' * `n`: The [length()] of `x`. |
|||
| 349 | +247 |
- } else {
+ #' * `count`: A list with the number of cases for each level of the factor `x`. |
||
| 350 | -12x | +|||
| 248 | +
- c("estimate" = "coef", "std_error" = "se(coef)", "pvalue" = "Pr(>|z|)")
+ #' * `count_fraction`: Similar to `count` but also includes the proportion of cases for each level of the |
|||
| 351 | +249 |
- }+ #' factor `x` relative to the denominator, or `NA` if the denominator is zero. |
||
| 352 | +250 |
- # Make sure x is not an interaction term.+ #' |
||
| 353 | -78x | +|||
| 251 | +
- checkmate::assert_subset(x, names(xs_class))+ #' @note |
|||
| 354 | -78x | +|||
| 252 | +
- x_sel <- if (xs_class[x] == "numeric") x else paste0(x, xs_level[[x]][-1])+ #' * If `x` is an empty `factor`, a list is still returned for `counts` with one element |
|||
| 355 | -78x | +|||
| 253 | +
- x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE)+ #' per factor level. If there are no levels in `x`, the function fails. |
|||
| 356 | -78x | +|||
| 254 | +
- colnames(x_stats) <- names(stats)+ #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values |
|||
| 357 | -78x | +|||
| 255 | +
- x_stats$estimate <- as.list(x_stats$estimate)+ #' set `na.rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit |
|||
| 358 | -78x | +|||
| 256 | +
- x_stats$std_error <- as.list(x_stats$std_error)+ #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the |
|||
| 359 | -78x | +|||
| 257 | +
- x_stats$pvalue <- as.list(x_stats$pvalue)+ #' default `na_level` (`"<Missing>"`) will also be excluded when `na.rm` is set to `TRUE`. |
|||
| 360 | -78x | +|||
| 258 | +
- x_stats$df <- as.list(1)+ #' |
|||
| 361 | -78x | +|||
| 259 | +
- if (xs_class[x] == "numeric") {
+ #' @method s_summary factor |
|||
| 362 | -60x | +|||
| 260 | +
- x_stats$term <- x+ #' |
|||
| 363 | -60x | +|||
| 261 | +
- x_stats$term_label <- if (inherits(fit_glm, "glm")) {
+ #' @examples |
|||
| 364 | -48x | +|||
| 262 | +
- formatters::var_labels(fit_glm$data[x], fill = TRUE)+ #' # `s_summary.factor` |
|||
| 365 | +263 |
- } else {
+ #' |
||
| 366 | +264 |
- # We just fill in here with the `term` itself as we don't have the data available.+ #' ## Basic usage: |
||
| 367 | -12x | +|||
| 265 | +
- x+ #' s_summary(factor(c("a", "a", "b", "c", "a")))
|
|||
| 368 | +266 |
- }+ #' |
||
| 369 | -60x | +|||
| 267 | +
- x_stats$is_variable_summary <- FALSE+ #' # Empty factor returns zero-filled items. |
|||
| 370 | -60x | +|||
| 268 | +
- x_stats$is_term_summary <- TRUE+ #' s_summary(factor(levels = c("a", "b", "c")))
|
|||
| 371 | +269 |
- } else {
+ #' |
||
| 372 | -18x | +|||
| 270 | +
- checkmate::assert_class(fit_glm, "glm")+ #' ## Management of NA values. |
|||
| 373 | +271 |
- # The reason is that we don't have the original data set in the `clogit` object+ #' x <- factor(c(NA, "Female")) |
||
| 374 | +272 |
- # and therefore cannot determine the `x_numbers` here.+ #' x <- explicit_na(x) |
||
| 375 | -18x | +|||
| 273 | +
- x_numbers <- table(fit_glm$data[[x]])+ #' s_summary(x, na.rm = TRUE) |
|||
| 376 | -18x | +|||
| 274 | +
- x_stats$term <- xs_level[[x]][-1]+ #' s_summary(x, na.rm = FALSE) |
|||
| 377 | -18x | +|||
| 275 | +
- x_stats$term_label <- h_simple_term_labels(x_stats$term, x_numbers)+ #' |
|||
| 378 | -18x | +|||
| 276 | +
- x_stats$is_variable_summary <- FALSE+ #' ## Different denominators. |
|||
| 379 | -18x | +|||
| 277 | +
- x_stats$is_term_summary <- TRUE+ #' x <- factor(c("a", "a", "b", "c", "a"))
|
|||
| 380 | -18x | +|||
| 278 | +
- main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald")+ #' s_summary(x, denom = "N_row", .N_row = 10L) |
|||
| 381 | -18x | +|||
| 279 | +
- x_main <- data.frame(+ #' s_summary(x, denom = "N_col", .N_col = 20L) |
|||
| 382 | -18x | +|||
| 280 | +
- pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE],+ #' |
|||
| 383 | -18x | +|||
| 281 | +
- term = xs_level[[x]][1],+ #' @export |
|||
| 384 | -18x | +|||
| 282 | +
- term_label = paste("Reference", h_simple_term_labels(xs_level[[x]][1], x_numbers)),
+ s_summary.factor <- function(x, |
|||
| 385 | -18x | +|||
| 283 | +
- df = main_effects[x, "Df", drop = TRUE],+ na.rm = TRUE, # nolint |
|||
| 386 | -18x | +|||
| 284 | +
- stringsAsFactors = FALSE+ denom = c("n", "N_row", "N_col"),
|
|||
| 387 | +285 |
- )+ .N_row, # nolint |
||
| 388 | -18x | +|||
| 286 | +
- x_main$pvalue <- as.list(x_main$pvalue)+ .N_col, # nolint |
|||
| 389 | -18x | +|||
| 287 | +
- x_main$df <- as.list(x_main$df)+ ...) {
|
|||
| 390 | -18x | +288 | +302x |
- x_main$estimate <- list(numeric(0))+ assert_valid_factor(x) |
| 391 | -18x | +289 | +299x |
- x_main$std_error <- list(numeric(0))+ denom <- match.arg(denom) |
| 392 | -18x | +|||
| 290 | +
- if (length(xs_level[[x]][-1]) == 1) {
+
|
|||
| 393 | -8x | +291 | +299x |
- x_main$pvalue <- list(numeric(0))+ if (na.rm) {
|
| 394 | -8x | +292 | +290x |
- x_main$df <- list(numeric(0))+ x <- x[!is.na(x)] %>% fct_discard("<Missing>")
|
| 395 | +293 |
- }- |
- ||
| 396 | -18x | -
- x_main$is_variable_summary <- TRUE- |
- ||
| 397 | -18x | -
- x_main$is_term_summary <- FALSE+ } else {
|
||
| 398 | -18x | +294 | +9x |
- x_stats <- rbind(x_main, x_stats)+ x <- x %>% explicit_na(label = "NA") |
| 399 | +295 |
} |
||
| 400 | -78x | -
- x_stats$variable <- x- |
- ||
| 401 | -78x | +|||
| 296 | +
- x_stats$variable_label <- if (inherits(fit_glm, "glm")) {
+
|
|||
| 402 | -66x | +297 | +299x |
- formatters::var_labels(fit_glm$data[x], fill = TRUE)+ y <- list() |
| 403 | +298 |
- } else {
+
|
||
| 404 | -12x | +299 | +299x |
- x+ y$n <- length(x) |
| 405 | +300 |
- }+ |
||
| 406 | -78x | +301 | +299x |
- x_stats$interaction <- ""+ y$count <- as.list(table(x, useNA = "ifany")) |
| 407 | -78x | +302 | +299x |
- x_stats$interaction_label <- ""+ dn <- switch(denom, |
| 408 | -78x | +303 | +299x |
- x_stats$reference <- ""+ n = length(x), |
| 409 | -78x | +304 | +299x |
- x_stats$reference_label <- ""+ N_row = .N_row, |
| 410 | -78x | +305 | +299x |
- rownames(x_stats) <- NULL+ N_col = .N_col |
| 411 | -78x | +|||
| 306 | +
- x_stats[c(+ ) |
|||
| 412 | -78x | +307 | +299x |
- "variable",+ y$count_fraction <- lapply( |
| 413 | -78x | +308 | +299x |
- "variable_label",+ y$count, |
| 414 | -78x | +309 | +299x |
- "term",+ function(x) {
|
| 415 | -78x | +310 | +2172x |
- "term_label",+ c(x, ifelse(dn > 0, x / dn, 0)) |
| 416 | -78x | +|||
| 311 | +
- "interaction",+ } |
|||
| 417 | -78x | +|||
| 312 | +
- "interaction_label",+ ) |
|||
| 418 | -78x | +313 | +299x |
- "reference",+ y$fraction <- lapply( |
| 419 | -78x | +314 | +299x |
- "reference_label",+ y$count, |
| 420 | -78x | +315 | +299x |
- "estimate",+ function(count) c("num" = count, "denom" = dn)
|
| 421 | -78x | +|||
| 316 | +
- "std_error",+ ) |
|||
| 422 | -78x | +|||
| 317 | +
- "df",+ |
|||
| 423 | -78x | +318 | +299x |
- "pvalue",+ y$n_blq <- sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", x))
|
| 424 | -78x | +|||
| 319 | +
- "is_variable_summary",+ |
|||
| 425 | -78x | +320 | +299x |
- "is_term_summary"+ y |
| 426 | +321 |
- )]+ } |
||
| 427 | +322 |
- }+ |
||
| 428 | +323 |
-
+ #' @describeIn analyze_variables Method for `character` class. This makes an automatic |
||
| 429 | +324 |
- #' @describeIn h_logistic_regression Helper function to tabulate the interaction term+ #' conversion to factor (with a warning) and then forwards to the method for factors. |
||
| 430 | +325 |
- #' results of a logistic regression model.+ #' |
||
| 431 | +326 |
- #'+ #' @param verbose (`flag`)\cr defaults to `TRUE`, which prints out warnings and messages. It is mainly used |
||
| 432 | +327 |
- #' @return Tabulated interaction term results from a logistic regression model.+ #' to print out information about factor casting. |
||
| 433 | +328 |
#' |
||
| 434 | +329 |
- #' @examples+ #' @note |
||
| 435 | +330 |
- #' h_glm_interaction_extract("ARMCD:AGE", mod2)
+ #' * Automatic conversion of character to factor does not guarantee that the table |
||
| 436 | +331 |
- #'+ #' can be generated correctly. In particular for sparse tables this very likely can fail. |
||
| 437 | +332 |
- #' @export+ #' It is therefore better to always pre-process the dataset such that factors are manually |
||
| 438 | +333 |
- h_glm_interaction_extract <- function(x, fit_glm) {
+ #' created from character variables before passing the dataset to [rtables::build_table()]. |
||
| 439 | -7x | +|||
| 334 | +
- vars <- h_get_interaction_vars(fit_glm)+ #' |
|||
| 440 | -7x | +|||
| 335 | +
- xs_class <- attr(fit_glm$terms, "dataClasses")+ #' @method s_summary character |
|||
| 441 | +336 |
-
+ #' |
||
| 442 | -7x | +|||
| 337 | +
- checkmate::assert_string(x)+ #' @examples |
|||
| 443 | +338 |
-
+ #' # `s_summary.character` |
||
| 444 | +339 |
- # Only take two-way interaction+ #' |
||
| 445 | -7x | +|||
| 340 | +
- checkmate::assert_vector(vars, len = 2)+ #' ## Basic usage: |
|||
| 446 | +341 |
-
+ #' s_summary(c("a", "a", "b", "c", "a"), .var = "x", verbose = FALSE)
|
||
| 447 | +342 |
- # Only consider simple case: first variable in interaction is arm, a categorical variable+ #' s_summary(c("a", "a", "b", "c", "a", ""), .var = "x", na.rm = FALSE, verbose = FALSE)
|
||
| 448 | -7x | +|||
| 343 | +
- checkmate::assert_disjunct(xs_class[vars[1]], "numeric")+ #' |
|||
| 449 | +344 |
-
+ #' @export |
||
| 450 | -7x | +|||
| 345 | +
- xs_level <- fit_glm$xlevels+ s_summary.character <- function(x, |
|||
| 451 | -7x | +|||
| 346 | +
- xs_coef <- summary(fit_glm)$coefficients+ na.rm = TRUE, # nolint |
|||
| 452 | -7x | +|||
| 347 | +
- main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald")+ denom = c("n", "N_row", "N_col"),
|
|||
| 453 | -7x | +|||
| 348 | +
- stats <- c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
+ .N_row, # nolint |
|||
| 454 | -7x | +|||
| 349 | +
- v1_comp <- xs_level[[vars[1]]][-1]+ .N_col, # nolint |
|||
| 455 | -7x | +|||
| 350 | +
- if (xs_class[vars[2]] == "numeric") {
+ .var, |
|||
| 456 | -4x | +|||
| 351 | +
- x_stats <- as.data.frame(+ verbose = TRUE, |
|||
| 457 | -4x | +|||
| 352 | +
- xs_coef[paste0(vars[1], v1_comp, ":", vars[2]), stats, drop = FALSE],+ ...) {
|
|||
| 458 | -4x | -
- stringsAsFactors = FALSE- |
- ||
| 459 | -+ | 353 | +8x |
- )+ if (na.rm) {
|
| 460 | -4x | +354 | +7x |
- colnames(x_stats) <- names(stats)+ y <- as_factor_keep_attributes(x, verbose = verbose) |
| 461 | -4x | +|||
| 355 | +
- x_stats$term <- v1_comp+ } else {
|
|||
| 462 | -4x | +356 | +1x |
- x_numbers <- table(fit_glm$data[[vars[1]]])+ y <- as_factor_keep_attributes(x, verbose = verbose, na_level = "NA") |
| 463 | -4x | +|||
| 357 | +
- x_stats$term_label <- h_simple_term_labels(v1_comp, x_numbers)+ } |
|||
| 464 | -4x | +|||
| 358 | +
- v1_ref <- xs_level[[vars[1]]][1]+ |
|||
| 465 | -4x | +359 | +8x |
- term_main <- v1_ref+ s_summary( |
| 466 | -4x | +360 | +8x |
- ref_label <- h_simple_term_labels(v1_ref, x_numbers)+ x = y, |
| 467 | -3x | +361 | +8x |
- } else if (xs_class[vars[2]] != "numeric") {
+ na.rm = na.rm, |
| 468 | -3x | +362 | +8x |
- v2_comp <- xs_level[[vars[2]]][-1]+ denom = denom, |
| 469 | -3x | +363 | +8x |
- v1_v2_grid <- expand.grid(v1 = v1_comp, v2 = v2_comp)+ .N_row = .N_row, |
| 470 | -3x | +364 | +8x |
- x_sel <- paste(+ .N_col = .N_col, |
| 471 | -3x | +|||
| 365 | +
- paste0(vars[1], v1_v2_grid$v1),+ ... |
|||
| 472 | -3x | +|||
| 366 | +
- paste0(vars[2], v1_v2_grid$v2),+ ) |
|||
| 473 | -3x | +|||
| 367 | +
- sep = ":"+ } |
|||
| 474 | +368 |
- )+ |
||
| 475 | -3x | +|||
| 369 | +
- x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE)+ #' @describeIn analyze_variables Method for `logical` class. |
|||
| 476 | -3x | +|||
| 370 | +
- colnames(x_stats) <- names(stats)+ #' |
|||
| 477 | -3x | +|||
| 371 | +
- x_stats$term <- paste(v1_v2_grid$v1, "*", v1_v2_grid$v2)+ #' @param denom (`string`)\cr choice of denominator for proportion. Options are: |
|||
| 478 | -3x | +|||
| 372 | +
- x_numbers <- table(fit_glm$data[[vars[1]]], fit_glm$data[[vars[2]]])+ #' * `n`: number of values in this row and column intersection. |
|||
| 479 | -3x | +|||
| 373 | +
- x_stats$term_label <- h_interaction_term_labels(v1_v2_grid$v1, v1_v2_grid$v2, x_numbers)+ #' * `N_row`: total number of values in this row across columns. |
|||
| 480 | -3x | +|||
| 374 | +
- v1_ref <- xs_level[[vars[1]]][1]+ #' * `N_col`: total number of values in this column across rows. |
|||
| 481 | -3x | +|||
| 375 | +
- v2_ref <- xs_level[[vars[2]]][1]+ #' |
|||
| 482 | -3x | +|||
| 376 | +
- term_main <- paste(vars[1], vars[2], sep = " * ")+ #' @return |
|||
| 483 | -3x | +|||
| 377 | +
- ref_label <- h_interaction_term_labels(v1_ref, v2_ref, x_numbers, any = TRUE)+ #' * If `x` is of class `logical`, returns a `list` with named `numeric` items: |
|||
| 484 | +378 |
- }+ #' * `n`: The [length()] of `x` (possibly after removing `NA`s). |
||
| 485 | -7x | +|||
| 379 | +
- x_stats$df <- as.list(1)+ #' * `count`: Count of `TRUE` in `x`. |
|||
| 486 | -7x | +|||
| 380 | +
- x_stats$pvalue <- as.list(x_stats$pvalue)+ #' * `count_fraction`: Count and proportion of `TRUE` in `x` relative to the denominator, or `NA` if the |
|||
| 487 | -7x | +|||
| 381 | +
- x_stats$is_variable_summary <- FALSE+ #' denominator is zero. Note that `NA`s in `x` are never counted or leading to `NA` here. |
|||
| 488 | -7x | +|||
| 382 | +
- x_stats$is_term_summary <- TRUE+ #' |
|||
| 489 | -7x | +|||
| 383 | +
- x_main <- data.frame(+ #' @method s_summary logical |
|||
| 490 | -7x | +|||
| 384 | +
- pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE],+ #' |
|||
| 491 | -7x | +|||
| 385 | +
- term = term_main,+ #' @examples |
|||
| 492 | -7x | +|||
| 386 | +
- term_label = paste("Reference", ref_label),
+ #' # `s_summary.logical` |
|||
| 493 | -7x | +|||
| 387 | +
- df = main_effects[x, "Df", drop = TRUE],+ #' |
|||
| 494 | -7x | +|||
| 388 | +
- stringsAsFactors = FALSE+ #' ## Basic usage: |
|||
| 495 | +389 |
- )+ #' s_summary(c(TRUE, FALSE, TRUE, TRUE)) |
||
| 496 | -7x | +|||
| 390 | +
- x_main$pvalue <- as.list(x_main$pvalue)+ #' |
|||
| 497 | -7x | +|||
| 391 | +
- x_main$df <- as.list(x_main$df)+ #' # Empty factor returns zero-filled items. |
|||
| 498 | -7x | +|||
| 392 | +
- x_main$estimate <- list(numeric(0))+ #' s_summary(as.logical(c())) |
|||
| 499 | -7x | +|||
| 393 | +
- x_main$std_error <- list(numeric(0))+ #' |
|||
| 500 | -7x | +|||
| 394 | +
- x_main$is_variable_summary <- TRUE+ #' ## Management of NA values. |
|||
| 501 | -7x | +|||
| 395 | +
- x_main$is_term_summary <- FALSE+ #' x <- c(NA, TRUE, FALSE) |
|||
| 502 | +396 |
-
+ #' s_summary(x, na.rm = TRUE) |
||
| 503 | -7x | +|||
| 397 | +
- x_stats <- rbind(x_main, x_stats)+ #' s_summary(x, na.rm = FALSE) |
|||
| 504 | -7x | +|||
| 398 | +
- x_stats$variable <- x+ #' |
|||
| 505 | -7x | +|||
| 399 | +
- x_stats$variable_label <- paste(+ #' ## Different denominators. |
|||
| 506 | -7x | +|||
| 400 | +
- "Interaction of",+ #' x <- c(TRUE, FALSE, TRUE, TRUE) |
|||
| 507 | -7x | +|||
| 401 | +
- formatters::var_labels(fit_glm$data[vars[1]], fill = TRUE),+ #' s_summary(x, denom = "N_row", .N_row = 10L) |
|||
| 508 | +402 |
- "*",+ #' s_summary(x, denom = "N_col", .N_col = 20L) |
||
| 509 | -7x | +|||
| 403 | +
- formatters::var_labels(fit_glm$data[vars[2]], fill = TRUE)+ #' |
|||
| 510 | +404 |
- )+ #' @export |
||
| 511 | -7x | +|||
| 405 | +
- x_stats$interaction <- ""+ s_summary.logical <- function(x, |
|||
| 512 | -7x | +|||
| 406 | +
- x_stats$interaction_label <- ""+ na.rm = TRUE, # nolint |
|||
| 513 | -7x | +|||
| 407 | +
- x_stats$reference <- ""+ denom = c("n", "N_row", "N_col"),
|
|||
| 514 | -7x | +|||
| 408 | +
- x_stats$reference_label <- ""+ .N_row, # nolint |
|||
| 515 | -7x | +|||
| 409 | +
- rownames(x_stats) <- NULL+ .N_col, # nolint |
|||
| 516 | -7x | +|||
| 410 | +
- x_stats[c(+ ...) {
|
|||
| 517 | -7x | +411 | +184x |
- "variable",+ denom <- match.arg(denom) |
| 518 | -7x | +412 | +182x |
- "variable_label",+ if (na.rm) x <- x[!is.na(x)] |
| 519 | -7x | +413 | +184x |
- "term",+ y <- list() |
| 520 | -7x | +414 | +184x |
- "term_label",+ y$n <- length(x) |
| 521 | -7x | +415 | +184x |
- "interaction",+ count <- sum(x, na.rm = TRUE) |
| 522 | -7x | +416 | +184x |
- "interaction_label",+ dn <- switch(denom, |
| 523 | -7x | +417 | +184x |
- "reference",+ n = length(x), |
| 524 | -7x | +418 | +184x |
- "reference_label",+ N_row = .N_row, |
| 525 | -7x | +419 | +184x |
- "estimate",+ N_col = .N_col |
| 526 | -7x | +|||
| 420 | +
- "std_error",+ ) |
|||
| 527 | -7x | +421 | +184x |
- "df",+ y$count <- count |
| 528 | -7x | +422 | +184x |
- "pvalue",+ y$count_fraction <- c(count, ifelse(dn > 0, count / dn, 0)) |
| 529 | -7x | +423 | +184x |
- "is_variable_summary",+ y$n_blq <- 0L |
| 530 | -7x | +424 | +184x |
- "is_term_summary"+ y |
| 531 | +425 |
- )]+ } |
||
| 532 | +426 |
- }+ |
||
| 533 | +427 |
-
+ #' @describeIn analyze_variables Formatted analysis function which is used as `afun` in `analyze_vars()` and |
||
| 534 | +428 |
- #' @describeIn h_logistic_regression Helper function to tabulate the interaction+ #' `compare_vars()` and as `cfun` in `summarize_colvars()`. |
||
| 535 | +429 |
- #' results of a logistic regression model. This basically is a wrapper for+ #' |
||
| 536 | +430 |
- #' [h_or_interaction()] and [h_glm_simple_term_extract()] which puts the results+ #' @param compare (`flag`)\cr whether comparison statistics should be analyzed instead of summary statistics |
||
| 537 | +431 |
- #' in the right data frame format.+ #' (`compare = TRUE` adds `pval` statistic comparing against reference group). |
||
| 538 | +432 |
#' |
||
| 539 | +433 |
- #' @return A `data.frame` of tabulated interaction term results from a logistic regression model.+ #' @return |
||
| 540 | +434 |
- #'+ #' * `a_summary()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 541 | +435 |
- #' @examples+ #' |
||
| 542 | +436 |
- #' h_glm_inter_term_extract("AGE", "ARMCD", mod2)
+ #' @note |
||
| 543 | +437 |
- #'+ #' * To use for comparison (with additional p-value statistic), parameter `compare` must be set to `TRUE`. |
||
| 544 | +438 |
- #' @export+ #' * Ensure that either all `NA` values are converted to an explicit `NA` level or all `NA` values are left as is. |
||
| 545 | +439 |
- h_glm_inter_term_extract <- function(odds_ratio_var,+ #' |
||
| 546 | +440 |
- interaction_var,+ #' @examples |
||
| 547 | +441 |
- fit_glm,+ #' a_summary(factor(c("a", "a", "b", "c", "a")), .N_row = 10, .N_col = 10)
|
||
| 548 | +442 |
- ...) {
+ #' a_summary( |
||
| 549 | +443 |
- # First obtain the main effects.- |
- ||
| 550 | -13x | -
- main_stats <- h_glm_simple_term_extract(odds_ratio_var, fit_glm)- |
- ||
| 551 | -13x | -
- main_stats$is_reference_summary <- FALSE+ #' factor(c("a", "a", "b", "c", "a")),
|
||
| 552 | -13x | +|||
| 444 | +
- main_stats$odds_ratio <- NA+ #' .ref_group = factor(c("a", "a", "b", "c")), compare = TRUE
|
|||
| 553 | -13x | +|||
| 445 | +
- main_stats$lcl <- NA+ #' ) |
|||
| 554 | -13x | +|||
| 446 | +
- main_stats$ucl <- NA+ #' |
|||
| 555 | +447 |
-
+ #' a_summary(c("A", "B", "A", "C"), .var = "x", .N_col = 10, .N_row = 10, verbose = FALSE)
|
||
| 556 | +448 |
- # Then we get the odds ratio estimates and put into df form.+ #' a_summary( |
||
| 557 | -13x | +|||
| 449 | +
- or_numbers <- h_or_interaction(odds_ratio_var, interaction_var, fit_glm, ...)+ #' c("A", "B", "A", "C"),
|
|||
| 558 | -13x | +|||
| 450 | +
- is_num_or_var <- attr(fit_glm$terms, "dataClasses")[odds_ratio_var] == "numeric"+ #' .ref_group = c("B", "A", "C"), .var = "x", compare = TRUE, verbose = FALSE
|
|||
| 559 | +451 |
-
+ #' ) |
||
| 560 | -13x | +|||
| 452 | +
- if (is_num_or_var) {
+ #' |
|||
| 561 | +453 |
- # Numeric OR variable case.+ #' a_summary(c(TRUE, FALSE, FALSE, TRUE, TRUE), .N_row = 10, .N_col = 10) |
||
| 562 | -4x | +|||
| 454 | +
- references <- names(or_numbers)+ #' a_summary( |
|||
| 563 | -4x | +|||
| 455 | +
- n_ref <- length(references)+ #' c(TRUE, FALSE, FALSE, TRUE, TRUE), |
|||
| 564 | +456 |
-
+ #' .ref_group = c(TRUE, FALSE), .in_ref_col = TRUE, compare = TRUE |
||
| 565 | -4x | +|||
| 457 | +
- extract_from_list <- function(l, name, pos = 1) {
+ #' ) |
|||
| 566 | -12x | +|||
| 458 | +
- unname(unlist(+ #' |
|||
| 567 | -12x | +|||
| 459 | +
- lapply(or_numbers, function(x) {
+ #' a_summary(rnorm(10), .N_col = 10, .N_row = 20, .var = "bla") |
|||
| 568 | -36x | +|||
| 460 | +
- x[[name]][pos]+ #' a_summary(rnorm(10, 5, 1), .ref_group = rnorm(20, -5, 1), .var = "bla", compare = TRUE) |
|||
| 569 | +461 |
- })+ #' |
||
| 570 | +462 |
- ))+ #' @export |
||
| 571 | +463 |
- }+ a_summary <- function(x, |
||
| 572 | -4x | +|||
| 464 | +
- or_stats <- data.frame(+ .N_col, # nolint |
|||
| 573 | -4x | +|||
| 465 | +
- variable = odds_ratio_var,+ .N_row, # nolint |
|||
| 574 | -4x | +|||
| 466 | +
- variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),+ .var = NULL, |
|||
| 575 | -4x | +|||
| 467 | +
- term = odds_ratio_var,+ .df_row = NULL, |
|||
| 576 | -4x | +|||
| 468 | +
- term_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),+ .ref_group = NULL, |
|||
| 577 | -4x | +|||
| 469 | +
- interaction = interaction_var,+ .in_ref_col = FALSE, |
|||
| 578 | -4x | +|||
| 470 | +
- interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)),+ compare = FALSE, |
|||
| 579 | -4x | +|||
| 471 | +
- reference = references,+ .stats = NULL, |
|||
| 580 | -4x | +|||
| 472 | +
- reference_label = references,+ .formats = NULL, |
|||
| 581 | -4x | +|||
| 473 | +
- estimate = NA,+ .labels = NULL, |
|||
| 582 | -4x | +|||
| 474 | +
- std_error = NA,+ .indent_mods = NULL, |
|||
| 583 | -4x | +|||
| 475 | +
- odds_ratio = extract_from_list(or_numbers, "or"),+ na.rm = TRUE, # nolint |
|||
| 584 | -4x | +|||
| 476 | +
- lcl = extract_from_list(or_numbers, "ci", pos = "lcl"),+ na_str = default_na_str(), |
|||
| 585 | -4x | +|||
| 477 | +
- ucl = extract_from_list(or_numbers, "ci", pos = "ucl"),+ ...) {
|
|||
| 586 | -4x | +478 | +324x |
- df = NA,+ extra_args <- list(...) |
| 587 | -4x | +479 | +324x |
- pvalue = NA,+ if (is.numeric(x)) {
|
| 588 | -4x | +480 | +86x |
- is_variable_summary = FALSE,+ type <- "numeric" |
| 589 | -4x | +481 | +86x |
- is_term_summary = FALSE,+ if (!is.null(.stats) && any(grepl("^pval", .stats))) {
|
| 590 | -4x | +482 | +10x |
- is_reference_summary = TRUE+ .stats[grepl("^pval", .stats)] <- "pval" # tmp fix xxx
|
| 591 | +483 |
- )+ } |
||
| 592 | +484 |
} else {
|
||
| 593 | -+ | |||
| 485 | +238x |
- # Categorical OR variable case.+ type <- "counts" |
||
| 594 | -9x | +486 | +238x |
- references <- names(or_numbers[[1]])+ if (!is.null(.stats) && any(grepl("^pval", .stats))) {
|
| 595 | +487 | 9x |
- n_ref <- length(references)+ .stats[grepl("^pval", .stats)] <- "pval_counts" # tmp fix xxx
|
|
| 596 | +488 | - - | -||
| 597 | -9x | -
- extract_from_list <- function(l, name, pos = 1) {
- |
- ||
| 598 | -27x | -
- unname(unlist(- |
- ||
| 599 | -27x | -
- lapply(or_numbers, function(x) {
+ } |
||
| 600 | -48x | +|||
| 489 | +
- lapply(x, function(y) y[[name]][pos])+ } |
|||
| 601 | +490 |
- })+ |
||
| 602 | +491 |
- ))+ # If one col has NA vals, must add NA row to other cols (using placeholder lvl `fill-na-level`) |
||
| 603 | -+ | |||
| 492 | +! |
- }+ if (any(is.na(.df_row[[.var]])) && !any(is.na(x)) && !na.rm) levels(x) <- c(levels(x), "fill-na-level") |
||
| 604 | -9x | +|||
| 493 | +
- or_stats <- data.frame(+ |
|||
| 605 | -9x | +494 | +324x |
- variable = odds_ratio_var,+ x_stats <- if (!compare) {
|
| 606 | -9x | +495 | +300x |
- variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),+ s_summary(x = x, .N_col = .N_col, .N_row = .N_row, na.rm = na.rm, ...) |
| 607 | -9x | +|||
| 496 | +
- term = rep(names(or_numbers), each = n_ref),+ } else {
|
|||
| 608 | -9x | +497 | +24x |
- term_label = h_simple_term_labels(rep(names(or_numbers), each = n_ref), table(fit_glm$data[[odds_ratio_var]])),+ s_compare( |
| 609 | -9x | +498 | +24x |
- interaction = interaction_var,+ x = x, .N_col = .N_col, .N_row = .N_row, na.rm = na.rm, .ref_group = .ref_group, .in_ref_col = .in_ref_col, ... |
| 610 | -9x | +|||
| 499 | +
- interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)),+ ) |
|||
| 611 | -9x | +|||
| 500 | +
- reference = unlist(lapply(or_numbers, names)),+ } |
|||
| 612 | -9x | +|||
| 501 | +
- reference_label = unlist(lapply(or_numbers, names)),+ |
|||
| 613 | -9x | +|||
| 502 | +
- estimate = NA,+ # Fill in with formatting defaults if needed |
|||
| 614 | -9x | +503 | +324x |
- std_error = NA,+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
|
| 615 | -9x | +504 | +324x |
- odds_ratio = extract_from_list(or_numbers, "or"),+ .stats <- get_stats(met_grp, stats_in = .stats, add_pval = compare) |
| 616 | -9x | +505 | +324x |
- lcl = extract_from_list(or_numbers, "ci", pos = "lcl"),+ .formats <- get_formats_from_stats(.stats, .formats) |
| 617 | -9x | +506 | +324x |
- ucl = extract_from_list(or_numbers, "ci", pos = "ucl"),+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods) |
| 618 | -9x | +|||
| 507 | +
- df = NA,+ |
|||
| 619 | -9x | +508 | +324x |
- pvalue = NA,+ lbls <- get_labels_from_stats(.stats, .labels) |
| 620 | -9x | +|||
| 509 | +
- is_variable_summary = FALSE,+ # Check for custom labels from control_analyze_vars |
|||
| 621 | -9x | +510 | +324x |
- is_term_summary = FALSE,+ .labels <- if ("control" %in% names(extra_args)) {
|
| 622 | -9x | +511 | +1x |
- is_reference_summary = TRUE+ lbls %>% labels_use_control(extra_args[["control"]], .labels) |
| 623 | +512 |
- )+ } else {
+ |
+ ||
| 513 | +323x | +
+ lbls |
||
| 624 | +514 |
} |
||
| 625 | +515 | |||
| 626 | -13x | -
- df <- rbind(- |
- ||
| 627 | -13x | +516 | +11x |
- main_stats[, names(or_stats)],+ if ("count_fraction_fixed_dp" %in% .stats) x_stats[["count_fraction_fixed_dp"]] <- x_stats[["count_fraction"]]
|
| 628 | -13x | +517 | +324x |
- or_stats+ x_stats <- x_stats[.stats] |
| 629 | +518 |
- )+ |
||
| 630 | -13x | +519 | +324x |
- df[order(-df$is_variable_summary, df$term, -df$is_term_summary, df$reference), ]+ if (is.factor(x) || is.character(x)) {
|
| 631 | +520 |
- }+ # Ungroup statistics with values for each level of x |
||
| 632 | -+ | |||
| 521 | +234x |
-
+ x_ungrp <- ungroup_stats(x_stats, .formats, .labels, .indent_mods) |
||
| 633 | -+ | |||
| 522 | +234x |
- #' @describeIn h_logistic_regression Helper function to tabulate the results including+ x_stats <- x_ungrp[["x"]] |
||
| 634 | -+ | |||
| 523 | +234x |
- #' odds ratios and confidence intervals of simple terms.+ .formats <- x_ungrp[[".formats"]] |
||
| 635 | -+ | |||
| 524 | +234x |
- #'+ .labels <- gsub("fill-na-level", "NA", x_ungrp[[".labels"]])
|
||
| 636 | -+ | |||
| 525 | +234x |
- #' @return Tabulated statistics for the given variable(s) from the logistic regression model.+ .indent_mods <- x_ungrp[[".indent_mods"]] |
||
| 637 | +526 |
- #'+ } |
||
| 638 | +527 |
- #' @examples+ |
||
| 639 | +528 |
- #' h_logistic_simple_terms("AGE", mod1)
+ # Auto format handling |
||
| 640 | -+ | |||
| 529 | +324x |
- #'+ .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var) |
||
| 641 | +530 |
- #' @export+ |
||
| 642 | -+ | |||
| 531 | +324x |
- h_logistic_simple_terms <- function(x, fit_glm, conf_level = 0.95) {
+ in_rows( |
||
| 643 | -53x | +532 | +324x |
- checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
+ .list = x_stats, |
| 644 | -53x | +533 | +324x |
- if (inherits(fit_glm, "glm")) {
+ .formats = .formats, |
| 645 | -42x | +534 | +324x |
- checkmate::assert_set_equal(fit_glm$family$family, "binomial")+ .names = names(.labels), |
| 646 | -+ | |||
| 535 | +324x |
- }+ .labels = .labels, |
||
| 647 | -53x | +536 | +324x |
- terms_name <- attr(stats::terms(fit_glm), "term.labels")+ .indent_mods = .indent_mods, |
| 648 | -53x | +537 | +324x |
- xs_class <- attr(fit_glm$terms, "dataClasses")+ .format_na_strs = na_str |
| 649 | -53x | +|||
| 538 | +
- interaction <- terms_name[which(!terms_name %in% names(xs_class))]+ ) |
|||
| 650 | -53x | +|||
| 539 | +
- checkmate::assert_subset(x, terms_name)+ } |
|||
| 651 | -53x | +|||
| 540 | +
- if (length(interaction) != 0) {
+
|
|||
| 652 | +541 |
- # Make sure any item in x is not part of interaction term+ #' @describeIn analyze_variables Layout-creating function which can take statistics function arguments |
||
| 653 | -2x | +|||
| 542 | +
- checkmate::assert_disjunct(x, unlist(strsplit(interaction, ":")))+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 654 | +543 |
- }+ #' |
||
| 655 | -53x | +|||
| 544 | +
- x_stats <- lapply(x, h_glm_simple_term_extract, fit_glm)+ #' @param ... arguments passed to `s_summary()`. |
|||
| 656 | -53x | +|||
| 545 | +
- x_stats <- do.call(rbind, x_stats)+ #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector |
|||
| 657 | -53x | +|||
| 546 | +
- q_norm <- stats::qnorm((1 + conf_level) / 2)+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
|||
| 658 | -53x | +|||
| 547 | +
- x_stats$odds_ratio <- lapply(x_stats$estimate, exp)+ #' for that statistic's row label. |
|||
| 659 | -53x | +|||
| 548 | +
- x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error)+ #' |
|||
| 660 | -53x | +|||
| 549 | +
- x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error)+ #' @return |
|||
| 661 | -53x | +|||
| 550 | +
- x_stats$ci <- Map(function(lcl, ucl) c(lcl, ucl), lcl = x_stats$lcl, ucl = x_stats$ucl)+ #' * `analyze_vars()` returns a layout object suitable for passing to further layouting functions, |
|||
| 662 | -53x | +|||
| 551 | +
- x_stats+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 663 | +552 |
- }+ #' the statistics from `s_summary()` to the table layout. |
||
| 664 | +553 |
-
+ #' |
||
| 665 | +554 |
- #' @describeIn h_logistic_regression Helper function to tabulate the results including+ #' @examples |
||
| 666 | +555 |
- #' odds ratios and confidence intervals of interaction terms.+ #' ## Fabricated dataset. |
||
| 667 | +556 |
- #'+ #' dta_test <- data.frame( |
||
| 668 | +557 |
- #' @return Tabulated statistics for the given variable(s) from the logistic regression model.+ #' USUBJID = rep(1:6, each = 3), |
||
| 669 | +558 |
- #'+ #' PARAMCD = rep("lab", 6 * 3),
|
||
| 670 | +559 |
- #' @examples+ #' AVISIT = rep(paste0("V", 1:3), 6),
|
||
| 671 | +560 |
- #' h_logistic_inter_terms(c("RACE", "AGE", "ARMCD", "AGE:ARMCD"), mod2)
+ #' ARM = rep(LETTERS[1:3], rep(6, 3)), |
||
| 672 | +561 |
- #'+ #' AVAL = c(9:1, rep(NA, 9)) |
||
| 673 | +562 |
- #' @export+ #' ) |
||
| 674 | +563 |
- h_logistic_inter_terms <- function(x,+ #' |
||
| 675 | +564 |
- fit_glm,+ #' # `analyze_vars()` in `rtables` pipelines |
||
| 676 | +565 |
- conf_level = 0.95,+ #' ## Default output within a `rtables` pipeline. |
||
| 677 | +566 |
- at = NULL) {
+ #' l <- basic_table() %>% |
||
| 678 | +567 |
- # Find out the interaction variables and interaction term.+ #' split_cols_by(var = "ARM") %>% |
||
| 679 | -5x | +|||
| 568 | +
- inter_vars <- h_get_interaction_vars(fit_glm)+ #' split_rows_by(var = "AVISIT") %>% |
|||
| 680 | -5x | +|||
| 569 | +
- checkmate::assert_vector(inter_vars, len = 2)+ #' analyze_vars(vars = "AVAL") |
|||
| 681 | +570 |
-
+ #' |
||
| 682 | +571 |
-
+ #' build_table(l, df = dta_test) |
||
| 683 | -5x | +|||
| 572 | +
- inter_term_index <- intersect(grep(inter_vars[1], x), grep(inter_vars[2], x))+ #' |
|||
| 684 | -5x | +|||
| 573 | +
- inter_term <- x[inter_term_index]+ #' ## Select and format statistics output. |
|||
| 685 | +574 |
-
+ #' l <- basic_table() %>% |
||
| 686 | +575 |
- # For the non-interaction vars we need the standard stuff.+ #' split_cols_by(var = "ARM") %>% |
||
| 687 | -5x | +|||
| 576 | +
- normal_terms <- setdiff(x, union(inter_vars, inter_term))+ #' split_rows_by(var = "AVISIT") %>% |
|||
| 688 | +577 |
-
+ #' analyze_vars( |
||
| 689 | -5x | +|||
| 578 | +
- x_stats <- lapply(normal_terms, h_glm_simple_term_extract, fit_glm)+ #' vars = "AVAL", |
|||
| 690 | -5x | +|||
| 579 | +
- x_stats <- do.call(rbind, x_stats)+ #' .stats = c("n", "mean_sd", "quantiles"),
|
|||
| 691 | -5x | +|||
| 580 | +
- q_norm <- stats::qnorm((1 + conf_level) / 2)+ #' .formats = c("mean_sd" = "xx.x, xx.x"),
|
|||
| 692 | -5x | +|||
| 581 | +
- x_stats$odds_ratio <- lapply(x_stats$estimate, exp)+ #' .labels = c(n = "n", mean_sd = "Mean, SD", quantiles = c("Q1 - Q3"))
|
|||
| 693 | -5x | +|||
| 582 | +
- x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error)+ #' ) |
|||
| 694 | -5x | +|||
| 583 | +
- x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error)+ #' |
|||
| 695 | -5x | +|||
| 584 | +
- normal_stats <- x_stats+ #' build_table(l, df = dta_test) |
|||
| 696 | -5x | +|||
| 585 | +
- normal_stats$is_reference_summary <- FALSE+ #' |
|||
| 697 | +586 |
-
+ #' ## Use arguments interpreted by `s_summary`. |
||
| 698 | +587 |
- # Now the interaction term itself.+ #' l <- basic_table() %>% |
||
| 699 | -5x | +|||
| 588 | +
- inter_term_stats <- h_glm_interaction_extract(inter_term, fit_glm)+ #' split_cols_by(var = "ARM") %>% |
|||
| 700 | -5x | +|||
| 589 | +
- inter_term_stats$odds_ratio <- NA+ #' split_rows_by(var = "AVISIT") %>% |
|||
| 701 | -5x | +|||
| 590 | +
- inter_term_stats$lcl <- NA+ #' analyze_vars(vars = "AVAL", na.rm = FALSE) |
|||
| 702 | -5x | +|||
| 591 | +
- inter_term_stats$ucl <- NA+ #' |
|||
| 703 | -5x | +|||
| 592 | +
- inter_term_stats$is_reference_summary <- FALSE+ #' build_table(l, df = dta_test) |
|||
| 704 | +593 |
-
+ #' |
||
| 705 | -5x | +|||
| 594 | +
- is_intervar1_numeric <- attr(fit_glm$terms, "dataClasses")[inter_vars[1]] == "numeric"+ #' ## Handle `NA` levels first when summarizing factors. |
|||
| 706 | +595 |
-
+ #' dta_test$AVISIT <- NA_character_ |
||
| 707 | +596 |
- # Interaction stuff.+ #' dta_test <- df_explicit_na(dta_test) |
||
| 708 | -5x | +|||
| 597 | +
- inter_stats_one <- h_glm_inter_term_extract(+ #' l <- basic_table() %>% |
|||
| 709 | -5x | +|||
| 598 | +
- inter_vars[1],+ #' split_cols_by(var = "ARM") %>% |
|||
| 710 | -5x | +|||
| 599 | +
- inter_vars[2],+ #' analyze_vars(vars = "AVISIT", na.rm = FALSE) |
|||
| 711 | -5x | +|||
| 600 | +
- fit_glm,+ #' |
|||
| 712 | -5x | +|||
| 601 | +
- conf_level = conf_level,+ #' build_table(l, df = dta_test) |
|||
| 713 | -5x | +|||
| 602 | +
- at = `if`(is_intervar1_numeric, NULL, at)+ #' |
|||
| 714 | +603 |
- )+ #' # auto format |
||
| 715 | -5x | +|||
| 604 | +
- inter_stats_two <- h_glm_inter_term_extract(+ #' dt <- data.frame("VAR" = c(0.001, 0.2, 0.0011000, 3, 4))
|
|||
| 716 | -5x | +|||
| 605 | +
- inter_vars[2],+ #' basic_table() %>% |
|||
| 717 | -5x | +|||
| 606 | +
- inter_vars[1],+ #' analyze_vars( |
|||
| 718 | -5x | +|||
| 607 | +
- fit_glm,+ #' vars = "VAR", |
|||
| 719 | -5x | +|||
| 608 | +
- conf_level = conf_level,+ #' .stats = c("n", "mean", "mean_sd", "range"),
|
|||
| 720 | -5x | +|||
| 609 | +
- at = `if`(is_intervar1_numeric, at, NULL)+ #' .formats = c("mean_sd" = "auto", "range" = "auto")
|
|||
| 721 | +610 |
- )+ #' ) %>% |
||
| 722 | +611 |
-
+ #' build_table(dt) |
||
| 723 | +612 |
- # Now just combine everything in one data frame.+ #' |
||
| 724 | -5x | +|||
| 613 | +
- col_names <- c(+ #' @export |
|||
| 725 | -5x | +|||
| 614 | +
- "variable",+ #' @order 2 |
|||
| 726 | -5x | +|||
| 615 | +
- "variable_label",+ analyze_vars <- function(lyt, |
|||
| 727 | -5x | +|||
| 616 | +
- "term",+ vars, |
|||
| 728 | -5x | +|||
| 617 | +
- "term_label",+ var_labels = vars, |
|||
| 729 | -5x | +|||
| 618 | +
- "interaction",+ na_str = default_na_str(), |
|||
| 730 | -5x | +|||
| 619 | +
- "interaction_label",+ nested = TRUE, |
|||
| 731 | -5x | +|||
| 620 | +
- "reference",+ ..., |
|||
| 732 | -5x | +|||
| 621 | +
- "reference_label",+ na.rm = TRUE, # nolint |
|||
| 733 | -5x | +|||
| 622 | +
- "estimate",+ show_labels = "default", |
|||
| 734 | -5x | +|||
| 623 | +
- "std_error",+ table_names = vars, |
|||
| 735 | -5x | +|||
| 624 | +
- "df",+ section_div = NA_character_, |
|||
| 736 | -5x | +|||
| 625 | +
- "pvalue",+ .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
|
|||
| 737 | -5x | +|||
| 626 | +
- "odds_ratio",+ .formats = NULL, |
|||
| 738 | -5x | +|||
| 627 | +
- "lcl",+ .labels = NULL, |
|||
| 739 | -5x | +|||
| 628 | +
- "ucl",+ .indent_mods = NULL) {
|
|||
| 740 | -5x | +629 | +30x |
- "is_variable_summary",+ extra_args <- list(.stats = .stats, na.rm = na.rm, na_str = na_str, ...) |
| 741 | -5x | +630 | +4x |
- "is_term_summary",+ if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
| 742 | -5x | +631 | +2x |
- "is_reference_summary"+ if (!is.null(.labels)) extra_args[[".labels"]] <- .labels+ |
+
| 632 | +! | +
+ if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
||
| 743 | +633 |
- )+ |
||
| 744 | -5x | +634 | +30x |
- df <- rbind(+ analyze( |
| 745 | -5x | +635 | +30x |
- inter_stats_one[, col_names],+ lyt = lyt, |
| 746 | -5x | +636 | +30x |
- inter_stats_two[, col_names],+ vars = vars, |
| 747 | -5x | +637 | +30x |
- inter_term_stats[, col_names]+ var_labels = var_labels, |
| 748 | -+ | |||
| 638 | +30x |
- )+ afun = a_summary, |
||
| 749 | -5x | +639 | +30x |
- if (length(normal_terms) > 0) {
+ na_str = na_str, |
| 750 | -5x | +640 | +30x |
- df <- rbind(+ nested = nested, |
| 751 | -5x | +641 | +30x |
- normal_stats[, col_names],+ extra_args = extra_args, |
| 752 | -5x | +642 | +30x |
- df+ inclNAs = TRUE, |
| 753 | -+ | |||
| 643 | +30x |
- )+ show_labels = show_labels, |
||
| 754 | -+ | |||
| 644 | +30x |
- }+ table_names = table_names, |
||
| 755 | -5x | +645 | +30x |
- df$ci <- combine_vectors(df$lcl, df$ucl)+ section_div = section_div |
| 756 | -5x | +|||
| 646 | +
- df+ ) |
|||
| 757 | +647 |
}@@ -51132,14 +51961,14 @@ tern coverage - 95.64% |
| 1 |
- #' Create a forest plot from an `rtable`+ #' Helper functions for tabulating survival duration by subgroup |
||
| 3 |
- #' Given a [rtables::rtable()] object with at least one column with a single value and one column with 2+ #' @description `r lifecycle::badge("stable")`
|
||
| 4 |
- #' values, converts table to a [ggplot2::ggplot()] object and generates an accompanying forest plot. The+ #' |
||
| 5 |
- #' table and forest plot are printed side-by-side.+ #' Helper functions that tabulate in a data frame statistics such as median survival |
||
| 6 |
- #'+ #' time and hazard ratio for population subgroups. |
||
| 7 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 8 |
- #'+ #' @inheritParams argument_convention |
||
| 9 |
- #' @inheritParams rtable2gg+ #' @inheritParams survival_coxph_pairwise |
||
| 10 |
- #' @inheritParams argument_convention+ #' @inheritParams survival_duration_subgroups |
||
| 11 |
- #' @param tbl (`VTableTree`)\cr `rtables` table with at least one column with a single value and one column with 2+ #' @param arm (`factor`)\cr the treatment group variable. |
||
| 12 |
- #' values.+ #' |
||
| 13 |
- #' @param col_x (`integer(1)` or `NULL`)\cr column index with estimator. By default tries to get this from+ #' @details Main functionality is to prepare data for use in a layout-creating function. |
||
| 14 |
- #' `tbl` attribute `col_x`, otherwise needs to be manually specified. If `NULL`, points will be excluded+ #' |
||
| 15 |
- #' from forest plot.+ #' @examples |
||
| 16 |
- #' @param col_ci (`integer(1)` or `NULL`)\cr column index with confidence intervals. By default tries to get this from+ #' library(dplyr) |
||
| 17 |
- #' `tbl` attribute `col_ci`, otherwise needs to be manually specified. If `NULL`, lines will be excluded+ #' library(forcats) |
||
| 18 |
- #' from forest plot.+ #' |
||
| 19 |
- #' @param vline (`numeric(1)` or `NULL`)\cr x coordinate for vertical line, if `NULL` then the line is omitted.+ #' adtte <- tern_ex_adtte |
||
| 20 |
- #' @param forest_header (`character(2)`)\cr text displayed to the left and right of `vline`, respectively.+ #' |
||
| 21 |
- #' If `vline = NULL` then `forest_header` is not printed. By default tries to get this from `tbl` attribute+ #' # Save variable labels before data processing steps. |
||
| 22 |
- #' `forest_header`. If `NULL`, defaults will be extracted from the table if possible, and set to+ #' adtte_labels <- formatters::var_labels(adtte) |
||
| 23 |
- #' `"Comparison\nBetter"` and `"Treatment\nBetter"` if not.+ #' |
||
| 24 |
- #' @param xlim (`numeric(2)`)\cr limits for x axis.+ #' adtte_f <- adtte %>% |
||
| 25 |
- #' @param logx (`flag`)\cr show the x-values on logarithm scale.+ #' filter( |
||
| 26 |
- #' @param x_at (`numeric`)\cr x-tick locations, if `NULL`, `x_at` is set to `vline` and both `xlim` values.+ #' PARAMCD == "OS", |
||
| 27 |
- #' @param width_row_names `r lifecycle::badge("deprecated")` Please use the `lbl_col_padding` argument instead.
+ #' ARM %in% c("B: Placebo", "A: Drug X"),
|
||
| 28 |
- #' @param width_columns (`numeric`)\cr a vector of column widths. Each element's position in+ #' SEX %in% c("M", "F")
|
||
| 29 |
- #' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths are calculated+ #' ) %>% |
||
| 30 |
- #' according to maximum number of characters per column.+ #' mutate( |
||
| 31 |
- #' @param width_forest `r lifecycle::badge("deprecated")` Please use the `rel_width_forest` argument instead.
+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
||
| 32 |
- #' @param rel_width_forest (`proportion`)\cr proportion of total width to allocate to the forest plot. Relative+ #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")), |
||
| 33 |
- #' width of table is then `1 - rel_width_forest`. If `as_list = TRUE`, this parameter is ignored.+ #' SEX = droplevels(SEX), |
||
| 34 |
- #' @param font_size (`numeric(1)`)\cr font size.+ #' is_event = CNSR == 0 |
||
| 35 |
- #' @param col_symbol_size (`numeric` or `NULL`)\cr column index from `tbl` containing data to be used+ #' ) |
||
| 36 |
- #' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional+ #' labels <- c("ARM" = adtte_labels[["ARM"]], "SEX" = adtte_labels[["SEX"]], "is_event" = "Event Flag")
|
||
| 37 |
- #' to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups.+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
||
| 38 |
- #' By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified.+ #' |
||
| 39 |
- #' @param col (`character`)\cr color(s).+ #' @name h_survival_duration_subgroups |
||
| 40 |
- #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot.+ NULL |
||
| 41 |
- #' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list. If `TRUE`, a named list+ |
||
| 42 |
- #' with two elements, `table` and `plot`, will be returned. If `FALSE` (default) the table and forest plot are+ #' @describeIn h_survival_duration_subgroups Helper to prepare a data frame of median survival times by arm. |
||
| 43 |
- #' printed side-by-side via [cowplot::plot_grid()].+ #' |
||
| 44 |
- #' @param gp `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
+ #' @return |
||
| 45 |
- #' is no longer used.+ #' * `h_survtime_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, and `median`. |
||
| 46 |
- #' @param draw `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
+ #' |
||
| 47 |
- #' is no longer used.+ #' @examples |
||
| 48 |
- #' @param newpage `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
+ #' # Extract median survival time for one group. |
||
| 49 |
- #' is no longer used.+ #' h_survtime_df( |
||
| 50 |
- #'+ #' tte = adtte_f$AVAL, |
||
| 51 |
- #' @return `ggplot` forest plot and table.+ #' is_event = adtte_f$is_event, |
||
| 52 |
- #'+ #' arm = adtte_f$ARM |
||
| 53 |
- #' @examples+ #' ) |
||
| 54 |
- #' library(dplyr)+ #' |
||
| 55 |
- #' library(forcats)+ #' @export |
||
| 56 |
- #' library(nestcolor)+ h_survtime_df <- function(tte, is_event, arm) {
|
||
| 57 | -+ | 79x |
- #'+ checkmate::assert_numeric(tte) |
| 58 | -+ | 78x |
- #' adrs <- tern_ex_adrs+ checkmate::assert_logical(is_event, len = length(tte)) |
| 59 | -+ | 78x |
- #' n_records <- 20+ assert_valid_factor(arm, len = length(tte)) |
| 60 |
- #' adrs_labels <- formatters::var_labels(adrs, fill = TRUE)+ |
||
| 61 | -+ | 78x |
- #' adrs <- adrs %>%+ df_tte <- data.frame( |
| 62 | -+ | 78x |
- #' filter(PARAMCD == "BESRSPI") %>%+ tte = tte, |
| 63 | -+ | 78x |
- #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+ is_event = is_event, |
| 64 | -+ | 78x |
- #' slice(seq_len(n_records)) %>%+ stringsAsFactors = FALSE |
| 65 |
- #' droplevels() %>%+ ) |
||
| 66 |
- #' mutate(+ |
||
| 67 |
- #' # Reorder levels of factor to make the placebo group the reference arm.+ # Delete NAs |
||
| 68 | -+ | 78x |
- #' ARM = fct_relevel(ARM, "B: Placebo"),+ non_missing_rows <- stats::complete.cases(df_tte) |
| 69 | -+ | 78x |
- #' rsp = AVALC == "CR"+ df_tte <- df_tte[non_missing_rows, ] |
| 70 | -+ | 78x |
- #' )+ arm <- arm[non_missing_rows] |
| 71 |
- #' formatters::var_labels(adrs) <- c(adrs_labels, "Response")+ |
||
| 72 | -+ | 78x |
- #' df <- extract_rsp_subgroups(+ lst_tte <- split(df_tte, arm) |
| 73 | -+ | 78x |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")),
+ lst_results <- Map(function(x, arm) {
|
| 74 | -+ | 156x |
- #' data = adrs+ if (nrow(x) > 0) {
|
| 75 | -+ | 152x |
- #' )+ s_surv <- s_surv_time(x, .var = "tte", is_event = "is_event") |
| 76 | -+ | 152x |
- #' # Full commonly used response table.+ median_est <- unname(as.numeric(s_surv$median)) |
| 77 | -+ | 152x |
- #'+ n_events <- sum(x$is_event) |
| 78 |
- #' tbl <- basic_table() %>%+ } else {
|
||
| 79 | -+ | 4x |
- #' tabulate_rsp_subgroups(df)+ median_est <- NA |
| 80 | -+ | 4x |
- #' g_forest(tbl)+ n_events <- NA |
| 81 |
- #'+ } |
||
| 82 |
- #' # Odds ratio only table.+ |
||
| 83 | -+ | 156x |
- #'+ data.frame( |
| 84 | -+ | 156x |
- #' tbl_or <- basic_table() %>%+ arm = arm, |
| 85 | -+ | 156x |
- #' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci"))
+ n = nrow(x), |
| 86 | -+ | 156x |
- #' g_forest(+ n_events = n_events, |
| 87 | -+ | 156x |
- #' tbl_or,+ median = median_est, |
| 88 | -+ | 156x |
- #' forest_header = c("Comparison\nBetter", "Treatment\nBetter")
+ stringsAsFactors = FALSE |
| 89 |
- #' )+ ) |
||
| 90 | -+ | 78x |
- #'+ }, lst_tte, names(lst_tte)) |
| 91 |
- #' # Survival forest plot example.+ |
||
| 92 | -+ | 78x |
- #' adtte <- tern_ex_adtte+ df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE)) |
| 93 | -+ | 78x |
- #' # Save variable labels before data processing steps.+ df$arm <- factor(df$arm, levels = levels(arm)) |
| 94 | -+ | 78x |
- #' adtte_labels <- formatters::var_labels(adtte, fill = TRUE)+ df |
| 95 |
- #' adtte_f <- adtte %>%+ } |
||
| 96 |
- #' filter(+ |
||
| 97 |
- #' PARAMCD == "OS",+ #' @describeIn h_survival_duration_subgroups Summarizes median survival times by arm and across subgroups |
||
| 98 |
- #' ARM %in% c("B: Placebo", "A: Drug X"),
+ #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and |
||
| 99 |
- #' SEX %in% c("M", "F")
+ #' requires elements `tte`, `is_event`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies |
||
| 100 |
- #' ) %>%+ #' groupings for `subgroups` variables. |
||
| 101 |
- #' mutate(+ #' |
||
| 102 |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ #' @return |
||
| 103 |
- #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),+ #' * `h_survtime_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, `median`, `subgroup`, |
||
| 104 |
- #' SEX = droplevels(SEX),+ #' `var`, `var_label`, and `row_type`. |
||
| 105 |
- #' AVALU = as.character(AVALU),+ #' |
||
| 106 |
- #' is_event = CNSR == 0+ #' @examples |
||
| 107 |
- #' )+ #' # Extract median survival time for multiple groups. |
||
| 108 |
- #' labels <- list(+ #' h_survtime_subgroups_df( |
||
| 109 |
- #' "ARM" = adtte_labels["ARM"],+ #' variables = list( |
||
| 110 |
- #' "SEX" = adtte_labels["SEX"],+ #' tte = "AVAL", |
||
| 111 |
- #' "AVALU" = adtte_labels["AVALU"],+ #' is_event = "is_event", |
||
| 112 |
- #' "is_event" = "Event Flag"+ #' arm = "ARM", |
||
| 113 |
- #' )+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 114 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- as.character(labels)+ #' ), |
||
| 115 |
- #' df <- extract_survival_subgroups(+ #' data = adtte_f |
||
| 116 |
- #' variables = list(+ #' ) |
||
| 117 |
- #' tte = "AVAL",+ #' |
||
| 118 |
- #' is_event = "is_event",+ #' # Define groupings for BMRKR2 levels. |
||
| 119 |
- #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ #' h_survtime_subgroups_df( |
||
| 120 |
- #' ),+ #' variables = list( |
||
| 121 |
- #' data = adtte_f+ #' tte = "AVAL", |
||
| 122 |
- #' )+ #' is_event = "is_event", |
||
| 123 |
- #' table_hr <- basic_table() %>%+ #' arm = "ARM", |
||
| 124 |
- #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1])+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 125 |
- #' g_forest(table_hr)+ #' ), |
||
| 126 |
- #'+ #' data = adtte_f, |
||
| 127 |
- #' # Works with any `rtable`.+ #' groups_lists = list( |
||
| 128 |
- #' tbl <- rtable(+ #' BMRKR2 = list( |
||
| 129 |
- #' header = c("E", "CI", "N"),
+ #' "low" = "LOW", |
||
| 130 |
- #' rrow("", 1, c(.8, 1.2), 200),
+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 131 |
- #' rrow("", 1.2, c(1.1, 1.4), 50)
+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 132 |
- #' )+ #' ) |
||
| 133 |
- #' g_forest(+ #' ) |
||
| 134 |
- #' tbl = tbl,+ #' ) |
||
| 135 |
- #' col_x = 1,+ #' |
||
| 136 |
- #' col_ci = 2,+ #' @export |
||
| 137 |
- #' xlim = c(0.5, 2),+ h_survtime_subgroups_df <- function(variables, |
||
| 138 |
- #' x_at = c(0.5, 1, 2),+ data, |
||
| 139 |
- #' col_symbol_size = 3+ groups_lists = list(), |
||
| 140 |
- #' )+ label_all = "All Patients") {
|
||
| 141 | -+ | 15x |
- #'+ checkmate::assert_character(variables$tte) |
| 142 | -+ | 15x |
- #' tbl <- rtable(+ checkmate::assert_character(variables$is_event) |
| 143 | -+ | 15x |
- #' header = rheader(+ checkmate::assert_character(variables$arm) |
| 144 | -+ | 15x |
- #' rrow("", rcell("A", colspan = 2)),
+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 145 |
- #' rrow("", "c1", "c2")
+
|
||
| 146 | -+ | 15x |
- #' ),+ assert_df_with_variables(data, variables) |
| 147 |
- #' rrow("row 1", 1, c(.8, 1.2)),
+
|
||
| 148 | -+ | 15x |
- #' rrow("row 2", 1.2, c(1.1, 1.4))
+ checkmate::assert_string(label_all) |
| 149 |
- #' )+ |
||
| 150 |
- #' g_forest(+ # Add All Patients. |
||
| 151 | -+ | 15x |
- #' tbl = tbl,+ result_all <- h_survtime_df(data[[variables$tte]], data[[variables$is_event]], data[[variables$arm]]) |
| 152 | -+ | 15x |
- #' col_x = 1,+ result_all$subgroup <- label_all |
| 153 | -+ | 15x |
- #' col_ci = 2,+ result_all$var <- "ALL" |
| 154 | -+ | 15x |
- #' xlim = c(0.5, 2),+ result_all$var_label <- label_all |
| 155 | -+ | 15x |
- #' x_at = c(0.5, 1, 2),+ result_all$row_type <- "content" |
| 156 |
- #' vline = 1,+ |
||
| 157 |
- #' forest_header = c("Hello", "World")
+ # Add Subgroups. |
||
| 158 | -+ | 15x |
- #' )+ if (is.null(variables$subgroups)) {
|
| 159 | -+ | 3x |
- #'+ result_all |
| 160 |
- #' @export+ } else {
|
||
| 161 | -+ | 12x |
- g_forest <- function(tbl,+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
| 162 | -+ | 12x |
- col_x = attr(tbl, "col_x"),+ l_result <- lapply(l_data, function(grp) {
|
| 163 | -+ | 60x |
- col_ci = attr(tbl, "col_ci"),+ result <- h_survtime_df(grp$df[[variables$tte]], grp$df[[variables$is_event]], grp$df[[variables$arm]]) |
| 164 | -+ | 60x |
- vline = 1,+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
| 165 | -+ | 60x |
- forest_header = attr(tbl, "forest_header"),+ cbind(result, result_labels) |
| 166 |
- xlim = c(0.1, 10),+ }) |
||
| 167 | -+ | 12x |
- logx = TRUE,+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 168 | -+ | 12x |
- x_at = c(0.1, 1, 10),+ result_subgroups$row_type <- "analysis" |
| 169 | -+ | 12x |
- width_row_names = lifecycle::deprecated(),+ rbind( |
| 170 | -+ | 12x |
- width_columns = NULL,+ result_all, |
| 171 | -+ | 12x |
- width_forest = lifecycle::deprecated(),+ result_subgroups |
| 172 |
- lbl_col_padding = 0,+ ) |
||
| 173 |
- rel_width_forest = 0.25,+ } |
||
| 174 |
- font_size = 12,+ } |
||
| 175 |
- col_symbol_size = attr(tbl, "col_symbol_size"),+ |
||
| 176 |
- col = getOption("ggplot2.discrete.colour")[1],
+ #' @describeIn h_survival_duration_subgroups Helper to prepare a data frame with estimates of |
||
| 177 |
- ggtheme = NULL,+ #' treatment hazard ratio. |
||
| 178 |
- as_list = FALSE,+ #' |
||
| 179 |
- gp = lifecycle::deprecated(),+ #' @param strata_data (`factor`, `data.frame`, or `NULL`)\cr required if stratified analysis is performed. |
||
| 180 |
- draw = lifecycle::deprecated(),+ #' |
||
| 181 |
- newpage = lifecycle::deprecated()) {
+ #' @return |
||
| 182 |
- # Deprecated argument warnings+ #' * `h_coxph_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`, |
||
| 183 | -4x | +
- if (lifecycle::is_present(width_row_names)) {
+ #' `conf_level`, `pval` and `pval_label`. |
|
| 184 | -1x | +
- lifecycle::deprecate_warn(+ #' |
|
| 185 | -1x | +
- "0.9.4", "g_forest(width_row_names)", "g_forest(lbl_col_padding)",+ #' @examples |
|
| 186 | -1x | +
- details = "The width of the row label column can be adjusted via the `lbl_col_padding` parameter."+ #' # Extract hazard ratio for one group. |
|
| 187 |
- )+ #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM) |
||
| 188 |
- }+ #' |
||
| 189 | -4x | +
- if (lifecycle::is_present(width_forest)) {
+ #' # Extract hazard ratio for one group with stratification factor. |
|
| 190 | -1x | +
- lifecycle::deprecate_warn(+ #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM, strata_data = adtte_f$STRATA1) |
|
| 191 | -1x | +
- "0.9.4", "g_forest(width_forest)", "g_forest(rel_width_forest)",+ #' |
|
| 192 | -1x | +
- details = "Relative width of the forest plot (as a proportion) can be set via the `rel_width_forest` parameter."+ #' @export |
|
| 193 |
- )+ h_coxph_df <- function(tte, is_event, arm, strata_data = NULL, control = control_coxph()) {
|
||
| 194 | -+ | 85x |
- }+ checkmate::assert_numeric(tte) |
| 195 | -4x | +85x |
- if (lifecycle::is_present(gp)) {
+ checkmate::assert_logical(is_event, len = length(tte)) |
| 196 | -1x | +85x |
- lifecycle::deprecate_warn(+ assert_valid_factor(arm, n.levels = 2, len = length(tte)) |
| 197 | -1x | +
- "0.9.4", "g_forest(gp)", "g_forest(ggtheme)",+ |
|
| 198 | -1x | +85x |
- details = paste(+ df_tte <- data.frame(tte = tte, is_event = is_event) |
| 199 | -1x | +85x |
- "`g_forest` is now generated as a `ggplot` object.",+ strata_vars <- NULL |
| 200 | -1x | +
- "Additional display settings should be supplied via the `ggtheme` parameter."+ |
|
| 201 | -+ | 85x |
- )+ if (!is.null(strata_data)) {
|
| 202 | -+ | 5x |
- )+ if (is.data.frame(strata_data)) {
|
| 203 | -+ | 4x |
- }+ strata_vars <- names(strata_data) |
| 204 | 4x |
- if (lifecycle::is_present(draw)) {
+ checkmate::assert_data_frame(strata_data, nrows = nrow(df_tte)) |
|
| 205 | -1x | +4x |
- lifecycle::deprecate_warn(+ assert_df_with_factors(strata_data, as.list(stats::setNames(strata_vars, strata_vars))) |
| 206 | -1x | +
- "0.9.4", "g_forest(draw)",+ } else {
|
|
| 207 | 1x |
- details = "`g_forest` now generates `ggplot` objects. This parameter has no effect."+ assert_valid_factor(strata_data, len = nrow(df_tte)) |
|
| 208 | -+ | 1x |
- )+ strata_vars <- "strata_data" |
| 209 |
- }+ } |
||
| 210 | -4x | +5x |
- if (lifecycle::is_present(newpage)) {
+ df_tte[strata_vars] <- strata_data |
| 211 | -1x | +
- lifecycle::deprecate_warn(+ } |
|
| 212 | -1x | +
- "0.9.4", "g_forest(newpage)",+ |
|
| 213 | -1x | +85x |
- details = "`g_forest` now generates `ggplot` objects. This parameter has no effect."+ l_df <- split(df_tte, arm) |
| 214 |
- )+ |
||
| 215 | -+ | 85x |
- }+ if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
|
| 216 |
-
+ # Hazard ratio and CI. |
||
| 217 | -4x | +79x |
- checkmate::assert_class(tbl, "VTableTree")+ result <- s_coxph_pairwise( |
| 218 | -4x | +79x |
- checkmate::assert_number(col_x, lower = 0, upper = ncol(tbl), null.ok = TRUE)+ df = l_df[[2]], |
| 219 | -4x | +79x |
- checkmate::assert_number(col_ci, lower = 0, upper = ncol(tbl), null.ok = TRUE)+ .ref_group = l_df[[1]], |
| 220 | -4x | +79x |
- checkmate::assert_number(col_symbol_size, lower = 0, upper = ncol(tbl), null.ok = TRUE)+ .in_ref_col = FALSE, |
| 221 | -4x | +79x |
- checkmate::assert_number(font_size, lower = 0)+ .var = "tte", |
| 222 | -4x | +79x |
- checkmate::assert_character(col, null.ok = TRUE)+ is_event = "is_event", |
| 223 | -4x | +79x |
- checkmate::assert_true(is.null(col) | length(col) == 1 | length(col) == nrow(tbl))+ strata = strata_vars, |
| 224 | -+ | 79x |
-
+ control = control |
| 225 |
- # Extract info from table+ ) |
||
| 226 | -4x | +
- mat <- matrix_form(tbl, indent_rownames = TRUE)+ |
|
| 227 | -4x | +79x |
- mat_strings <- formatters::mf_strings(mat)+ df <- data.frame( |
| 228 | -4x | +
- nlines_hdr <- formatters::mf_nlheader(mat)+ # Dummy column needed downstream to create a nested header. |
|
| 229 | -4x | +79x |
- nrows_body <- nrow(mat_strings) - nlines_hdr+ arm = " ", |
| 230 | -4x | +79x |
- tbl_stats <- mat_strings[nlines_hdr, -1]+ n_tot = unname(as.numeric(result$n_tot)), |
| 231 | -+ | 79x |
-
+ n_tot_events = unname(as.numeric(result$n_tot_events)), |
| 232 | -+ | 79x |
- # Generate and modify table as ggplot object+ hr = unname(as.numeric(result$hr)), |
| 233 | -4x | +79x |
- gg_table <- rtable2gg(tbl, fontsize = font_size, colwidths = width_columns, lbl_col_padding = lbl_col_padding) ++ lcl = unname(result$hr_ci[1]), |
| 234 | -4x | +79x |
- theme(plot.margin = margin(0, 0, 0, 0.025, "npc"))+ ucl = unname(result$hr_ci[2]), |
| 235 | -4x | +79x |
- gg_table$scales$scales[[1]]$expand <- c(0.01, 0.01)+ conf_level = control[["conf_level"]], |
| 236 | -4x | +79x |
- gg_table$scales$scales[[2]]$limits[2] <- nrow(mat_strings) + 1+ pval = as.numeric(result$pvalue), |
| 237 | -4x | +79x |
- if (nlines_hdr == 2) {
+ pval_label = obj_label(result$pvalue), |
| 238 | -4x | +79x |
- gg_table$scales$scales[[2]]$expand <- c(0, 0)+ stringsAsFactors = FALSE |
| 239 | -4x | +
- arms <- unique(mat_strings[1, ][nzchar(trimws(mat_strings[1, ]))])+ ) |
|
| 240 |
- } else {
+ } else if ( |
||
| 241 | -! | +6x |
- arms <- NULL+ (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) || |
| 242 | -+ | 6x |
- }+ (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0) |
| 243 |
-
+ ) {
|
||
| 244 | -4x | +6x |
- tbl_df <- as_result_df(tbl)+ df_tte_complete <- df_tte[stats::complete.cases(df_tte), ] |
| 245 | -4x | +6x |
- dat_cols <- seq(which(names(tbl_df) == "node_class") + 1, ncol(tbl_df))+ df <- data.frame( |
| 246 | -4x | +
- tbl_df <- tbl_df[, c(which(names(tbl_df) == "row_num"), dat_cols)]+ # Dummy column needed downstream to create a nested header. |
|
| 247 | -4x | +6x |
- names(tbl_df) <- c("row_num", tbl_stats)
+ arm = " ", |
| 248 | -+ | 6x |
-
+ n_tot = nrow(df_tte_complete), |
| 249 | -+ | 6x |
- # Check table data columns+ n_tot_events = sum(df_tte_complete$is_event), |
| 250 | -4x | +6x |
- if (!is.null(col_ci)) {
+ hr = NA, |
| 251 | -4x | +6x |
- ci_col <- col_ci + 1+ lcl = NA, |
| 252 | -+ | 6x |
- } else {
+ ucl = NA, |
| 253 | -! | +6x |
- tbl_df[["empty_ci"]] <- rep(list(c(NA_real_, NA_real_)), nrow(tbl_df))+ conf_level = control[["conf_level"]], |
| 254 | -! | +6x |
- ci_col <- which(names(tbl_df) == "empty_ci")+ pval = NA, |
| 255 | -+ | 6x |
- }+ pval_label = NA, |
| 256 | -! | +6x |
- if (length(tbl_df[, ci_col][[1]]) != 2) stop("CI column must have two elements (lower and upper limits).")
+ stringsAsFactors = FALSE |
| 257 |
-
+ ) |
||
| 258 | -4x | +
- if (!is.null(col_x)) {
+ } else {
|
|
| 259 | -4x | +! |
- x_col <- col_x + 1+ df <- data.frame( |
| 260 |
- } else {
+ # Dummy column needed downstream to create a nested header. |
||
| 261 | ! |
- tbl_df[["empty_x"]] <- NA_real_+ arm = " ", |
|
| 262 | ! |
- x_col <- which(names(tbl_df) == "empty_x")+ n_tot = 0L, |
|
| 263 | -+ | ! |
- }+ n_tot_events = 0L, |
| 264 | -4x | +! |
- if (!is.null(col_symbol_size)) {
+ hr = NA, |
| 265 | -3x | +! |
- sym_size <- unlist(tbl_df[, col_symbol_size + 1])+ lcl = NA, |
| 266 | -+ | ! |
- } else {
+ ucl = NA, |
| 267 | -1x | +! |
- sym_size <- rep(1, nrow(tbl_df))+ conf_level = control[["conf_level"]], |
| 268 | -+ | ! |
- }+ pval = NA, |
| 269 | -+ | ! |
-
+ pval_label = NA, |
| 270 | -4x | +! |
- tbl_df[, c("ci_lwr", "ci_upr")] <- t(sapply(tbl_df[, ci_col], unlist))
+ stringsAsFactors = FALSE |
| 271 | -4x | +
- x <- unlist(tbl_df[, x_col])+ ) |
|
| 272 | -4x | +
- lwr <- unlist(tbl_df[["ci_lwr"]])+ } |
|
| 273 | -4x | +
- upr <- unlist(tbl_df[["ci_upr"]])+ |
|
| 274 | -4x | +85x |
- row_num <- nrow(mat_strings) - tbl_df[["row_num"]] - as.numeric(nlines_hdr == 2)+ df |
| 275 |
-
+ } |
||
| 276 | -4x | +
- if (is.null(col)) col <- "#343cff"+ |
|
| 277 | -4x | +
- if (length(col) == 1) col <- rep(col, nrow(tbl_df))+ #' @describeIn h_survival_duration_subgroups Summarizes estimates of the treatment hazard ratio |
|
| 278 | -! | +
- if (is.null(x_at)) x_at <- union(xlim, vline)+ #' across subgroups in a data frame. `variables` corresponds to the names of variables found in |
|
| 279 | -4x | +
- x_labels <- x_at+ #' `data`, passed as a named list and requires elements `tte`, `is_event`, `arm` and |
|
| 280 |
-
+ #' optionally `subgroups` and `strata`. `groups_lists` optionally specifies |
||
| 281 |
- # Apply log transformation+ #' groupings for `subgroups` variables. |
||
| 282 | -4x | +
- if (logx) {
+ #' |
|
| 283 | -4x | +
- x_t <- log(x)+ #' @return |
|
| 284 | -4x | +
- lwr_t <- log(lwr)+ #' * `h_coxph_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`, |
|
| 285 | -4x | +
- upr_t <- log(upr)+ #' `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`. |
|
| 286 | -4x | +
- xlim_t <- log(xlim)+ #' |
|
| 287 |
- } else {
+ #' @examples |
||
| 288 | -! | +
- x_t <- x+ #' # Extract hazard ratio for multiple groups. |
|
| 289 | -! | +
- lwr_t <- lwr+ #' h_coxph_subgroups_df( |
|
| 290 | -! | +
- upr_t <- upr+ #' variables = list( |
|
| 291 | -! | +
- xlim_t <- xlim+ #' tte = "AVAL", |
|
| 292 |
- }+ #' is_event = "is_event", |
||
| 293 |
-
+ #' arm = "ARM", |
||
| 294 |
- # Set up plot area+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 295 | -4x | +
- gg_plt <- ggplot(data = tbl_df) ++ #' ), |
|
| 296 | -4x | +
- theme(+ #' data = adtte_f |
|
| 297 | -4x | +
- panel.background = element_rect(fill = "transparent", color = NA_character_),+ #' ) |
|
| 298 | -4x | +
- plot.background = element_rect(fill = "transparent", color = NA_character_),+ #' |
|
| 299 | -4x | +
- panel.grid.major = element_blank(),+ #' # Define groupings of BMRKR2 levels. |
|
| 300 | -4x | +
- panel.grid.minor = element_blank(),+ #' h_coxph_subgroups_df( |
|
| 301 | -4x | +
- axis.title.x = element_blank(),+ #' variables = list( |
|
| 302 | -4x | +
- axis.title.y = element_blank(),+ #' tte = "AVAL", |
|
| 303 | -4x | +
- axis.line.x = element_line(),+ #' is_event = "is_event", |
|
| 304 | -4x | +
- axis.text = element_text(size = font_size),+ #' arm = "ARM", |
|
| 305 | -4x | +
- legend.position = "none",+ #' subgroups = c("SEX", "BMRKR2")
|
|
| 306 | -4x | +
- plot.margin = margin(0, 0.1, 0.05, 0, "npc")+ #' ), |
|
| 307 |
- ) ++ #' data = adtte_f, |
||
| 308 | -4x | +
- scale_x_continuous(+ #' groups_lists = list( |
|
| 309 | -4x | +
- transform = ifelse(logx, "log", "identity"),+ #' BMRKR2 = list( |
|
| 310 | -4x | +
- limits = xlim,+ #' "low" = "LOW", |
|
| 311 | -4x | +
- breaks = x_at,+ #' "low/medium" = c("LOW", "MEDIUM"),
|
|
| 312 | -4x | +
- labels = x_labels,+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
|
| 313 | -4x | +
- expand = c(0.01, 0)+ #' ) |
|
| 314 |
- ) ++ #' ) |
||
| 315 | -4x | +
- scale_y_continuous(+ #' ) |
|
| 316 | -4x | +
- limits = c(0, nrow(mat_strings) + 1),+ #' |
|
| 317 | -4x | +
- breaks = NULL,+ #' # Extract hazard ratio for multiple groups with stratification factors. |
|
| 318 | -4x | +
- expand = c(0, 0)+ #' h_coxph_subgroups_df( |
|
| 319 |
- ) ++ #' variables = list( |
||
| 320 | -4x | +
- coord_cartesian(clip = "off")+ #' tte = "AVAL", |
|
| 321 |
-
+ #' is_event = "is_event", |
||
| 322 | -4x | +
- if (is.null(ggtheme)) {
+ #' arm = "ARM", |
|
| 323 | -4x | +
- gg_plt <- gg_plt + annotate(+ #' subgroups = c("SEX", "BMRKR2"),
|
|
| 324 | -4x | +
- "rect",+ #' strata = c("STRATA1", "STRATA2")
|
|
| 325 | -4x | +
- xmin = xlim[1],+ #' ), |
|
| 326 | -4x | +
- xmax = xlim[2],+ #' data = adtte_f |
|
| 327 | -4x | +
- ymin = 0,+ #' ) |
|
| 328 | -4x | +
- ymax = nrows_body + 0.5,+ #' |
|
| 329 | -4x | +
- fill = "grey92"+ #' @export |
|
| 330 |
- )+ h_coxph_subgroups_df <- function(variables, |
||
| 331 |
- }+ data, |
||
| 332 |
-
+ groups_lists = list(), |
||
| 333 | -4x | +
- if (!is.null(vline)) {
+ control = control_coxph(), |
|
| 334 |
- # Set default forest header+ label_all = "All Patients") {
|
||
| 335 | -4x | +17x |
- if (is.null(forest_header)) {
+ if ("strat" %in% names(variables)) {
|
| 336 | ! |
- forest_header <- c(+ warning( |
|
| 337 | ! |
- paste(if (length(arms) == 2) arms[1] else "Comparison", "Better", sep = "\n"),+ "Warning: the `strat` element name of the `variables` list argument to `h_coxph_subgroups_df() ", |
|
| 338 | ! |
- paste(if (length(arms) == 2) arms[2] else "Treatment", "Better", sep = "\n")+ "was deprecated in tern 0.9.4.\n ", |
|
| 339 | -+ | ! |
- )+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
| 340 |
- }+ ) |
||
| 341 | -+ | ! |
-
+ variables[["strata"]] <- variables[["strat"]] |
| 342 |
- # Add vline and forest header labels+ } |
||
| 343 | -4x | +
- mid_pts <- if (logx) {
+
|
|
| 344 | -4x | +17x |
- c(exp(mean(log(c(xlim[1], vline)))), exp(mean(log(c(vline, xlim[2])))))+ checkmate::assert_character(variables$tte) |
| 345 | -+ | 17x |
- } else {
+ checkmate::assert_character(variables$is_event) |
| 346 | -! | +17x |
- c(mean(c(xlim[1], vline)), mean(c(vline, xlim[2])))+ checkmate::assert_character(variables$arm) |
| 347 | -+ | 17x |
- }+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 348 | -4x | +17x |
- gg_plt <- gg_plt ++ checkmate::assert_character(variables$strata, null.ok = TRUE) |
| 349 | -4x | +17x |
- annotate(+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2) |
| 350 | -4x | +17x |
- "segment",+ assert_df_with_variables(data, variables) |
| 351 | -4x | +17x |
- x = vline, xend = vline, y = 0, yend = nrows_body + 0.5+ checkmate::assert_string(label_all) |
| 352 |
- ) ++ |
||
| 353 | -4x | +
- annotate(+ # Add All Patients. |
|
| 354 | -4x | +17x |
- "text",+ result_all <- h_coxph_df( |
| 355 | -4x | +17x |
- x = mid_pts[1], y = nrows_body + 1.25,+ tte = data[[variables$tte]], |
| 356 | -4x | +17x |
- label = forest_header[1],+ is_event = data[[variables$is_event]], |
| 357 | -4x | +17x |
- size = font_size / .pt,+ arm = data[[variables$arm]], |
| 358 | -4x | +17x |
- lineheight = 0.9+ strata_data = if (is.null(variables$strata)) NULL else data[variables$strata], |
| 359 | -+ | 17x |
- ) ++ control = control |
| 360 | -4x | +
- annotate(+ ) |
|
| 361 | -4x | +17x |
- "text",+ result_all$subgroup <- label_all |
| 362 | -4x | +17x |
- x = mid_pts[2], y = nrows_body + 1.25,+ result_all$var <- "ALL" |
| 363 | -4x | +17x |
- label = forest_header[2],+ result_all$var_label <- label_all |
| 364 | -4x | +17x |
- size = font_size / .pt,+ result_all$row_type <- "content" |
| 365 | -4x | +
- lineheight = 0.9+ |
|
| 366 |
- )+ # Add Subgroups. |
||
| 367 | -+ | 17x |
- }+ if (is.null(variables$subgroups)) {
|
| 368 | -+ | 3x |
-
+ result_all |
| 369 |
- # Add points to plot+ } else {
|
||
| 370 | -4x | +14x |
- if (any(!is.na(x_t))) {
+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
| 371 | -4x | +
- x_t[x < xlim[1] | x > xlim[2]] <- NA+ |
|
| 372 | -4x | +14x |
- gg_plt <- gg_plt + geom_point(+ l_result <- lapply(l_data, function(grp) {
|
| 373 | -4x | +64x |
- x = x_t,+ result <- h_coxph_df( |
| 374 | -4x | +64x |
- y = row_num,+ tte = grp$df[[variables$tte]], |
| 375 | -4x | +64x |
- color = col,+ is_event = grp$df[[variables$is_event]], |
| 376 | -4x | +64x |
- aes(size = sym_size),+ arm = grp$df[[variables$arm]], |
| 377 | -4x | +64x |
- na.rm = TRUE+ strata_data = if (is.null(variables$strata)) NULL else grp$df[variables$strata], |
| 378 | -+ | 64x |
- )+ control = control |
| 379 |
- }+ ) |
||
| 380 | -+ | 64x |
-
+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
| 381 | -4x | +64x |
- for (i in seq_len(nrow(tbl_df))) {
+ cbind(result, result_labels) |
| 382 |
- # Determine which arrow(s) to add to CI lines+ }) |
||
| 383 | -17x | +
- which_arrow <- c(lwr_t[i] < xlim_t[1], upr_t[i] > xlim_t[2])+ |
|
| 384 | -17x | +14x |
- which_arrow <- dplyr::case_when(+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 385 | -17x | +14x |
- all(which_arrow) ~ "both",+ result_subgroups$row_type <- "analysis" |
| 386 | -17x | +
- which_arrow[1] ~ "first",+ |
|
| 387 | -17x | +14x |
- which_arrow[2] ~ "last",+ rbind( |
| 388 | -17x | +14x |
- TRUE ~ NA_character_+ result_all, |
| 389 | -+ | 14x |
- )+ result_subgroups |
| 390 |
-
+ ) |
||
| 391 |
- # Add CI lines+ } |
||
| 392 | -17x | +
- gg_plt <- gg_plt ++ } |
|
| 393 | -17x | +
- if (!is.na(which_arrow)) {
+
|
|
| 394 | -15x | +
- annotate(+ #' Split data frame by subgroups |
|
| 395 | -15x | +
- "segment",+ #' |
|
| 396 | -15x | +
- x = if (!which_arrow %in% c("first", "both")) lwr[i] else xlim[1],
+ #' @description `r lifecycle::badge("stable")`
|
|
| 397 | -15x | +
- xend = if (!which_arrow %in% c("last", "both")) upr[i] else xlim[2],
+ #' |
|
| 398 | -15x | +
- y = row_num[i], yend = row_num[i],+ #' Split a data frame into a non-nested list of subsets. |
|
| 399 | -15x | +
- color = if (length(col) == 1) col else col[i],+ #' |
|
| 400 | -15x | +
- arrow = arrow(length = unit(0.05, "npc"), ends = which_arrow),+ #' @inheritParams argument_convention |
|
| 401 | -15x | +
- na.rm = TRUE+ #' @inheritParams survival_duration_subgroups |
|
| 402 |
- )+ #' @param data (`data.frame`)\cr dataset to split. |
||
| 403 |
- } else {
+ #' @param subgroups (`character`)\cr names of factor variables from `data` used to create subsets. |
||
| 404 | -2x | +
- annotate(+ #' Unused levels not present in `data` are dropped. Note that the order in this vector |
|
| 405 | -2x | +
- "segment",+ #' determines the order in the downstream table. |
|
| 406 | -2x | +
- x = lwr[i], xend = upr[i],+ #' |
|
| 407 | -2x | +
- y = row_num[i], yend = row_num[i],+ #' @return A list with subset data (`df`) and metadata about the subset (`df_labels`). |
|
| 408 | -2x | +
- color = if (length(col) == 1) col else col[i],+ #' |
|
| 409 | -2x | +
- na.rm = TRUE+ #' @details Main functionality is to prepare data for use in forest plot layouts. |
|
| 410 |
- )+ #' |
||
| 411 |
- }+ #' @examples |
||
| 412 |
- }+ #' df <- data.frame( |
||
| 413 |
-
+ #' x = c(1:5), |
||
| 414 |
- # Apply custom ggtheme to plot+ #' y = factor(c("A", "B", "A", "B", "A"), levels = c("A", "B", "C")),
|
||
| 415 | -! | +
- if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme+ #' z = factor(c("C", "C", "D", "D", "D"), levels = c("D", "C"))
|
|
| 416 |
-
+ #' ) |
||
| 417 | -4x | +
- if (as_list) {
+ #' formatters::var_labels(df) <- paste("label for", names(df))
|
|
| 418 | -1x | +
- list(+ #' |
|
| 419 | -1x | +
- table = gg_table,+ #' h_split_by_subgroups( |
|
| 420 | -1x | +
- plot = gg_plt+ #' data = df, |
|
| 421 |
- )+ #' subgroups = c("y", "z")
|
||
| 422 |
- } else {
+ #' ) |
||
| 423 | -3x | +
- cowplot::plot_grid(+ #' |
|
| 424 | -3x | +
- gg_table,+ #' h_split_by_subgroups( |
|
| 425 | -3x | +
- gg_plt,+ #' data = df, |
|
| 426 | -3x | +
- align = "h",+ #' subgroups = c("y", "z"),
|
|
| 427 | -3x | +
- axis = "tblr",+ #' groups_lists = list( |
|
| 428 | -3x | +
- rel_widths = c(1 - rel_width_forest, rel_width_forest)+ #' y = list("AB" = c("A", "B"), "C" = "C")
|
|
| 429 |
- )+ #' ) |
||
| 430 |
- }+ #' ) |
||
| 431 |
- }+ #' |
||
| 432 |
-
+ #' @export |
||
| 433 |
- #' Forest plot grob+ h_split_by_subgroups <- function(data, |
||
| 434 |
- #'+ subgroups, |
||
| 435 |
- #' @description `r lifecycle::badge("deprecated")`
+ groups_lists = list()) {
|
||
| 436 | +66x | +
+ checkmate::assert_character(subgroups, min.len = 1, any.missing = FALSE)+ |
+ |
| 437 | +66x | +
+ checkmate::assert_list(groups_lists, names = "named")+ |
+ |
| 438 | +66x | +
+ checkmate::assert_subset(names(groups_lists), subgroups)+ |
+ |
| 439 | +66x | +
+ assert_df_with_factors(data, as.list(stats::setNames(subgroups, subgroups)))+ |
+ |
| 440 |
- #'+ + |
+ ||
| 441 | +66x | +
+ data_labels <- unname(formatters::var_labels(data))+ |
+ |
| 442 | +66x | +
+ df_subgroups <- data[, subgroups, drop = FALSE]+ |
+ |
| 443 | +66x | +
+ subgroup_labels <- formatters::var_labels(df_subgroups, fill = TRUE) |
|
| 437 | +444 |
- #' @inheritParams g_forest+ + |
+ |
| 445 | +66x | +
+ l_labels <- Map(function(grp_i, name_i) {
+ |
+ |
| 446 | +120x | +
+ existing_levels <- levels(droplevels(grp_i))+ |
+ |
| 447 | +120x | +
+ grp_levels <- if (name_i %in% names(groups_lists)) {
|
|
| 438 | +448 |
- #' @param tbl (`VTableTree`)\cr `rtables` table object.+ # For this variable groupings are defined. We check which groups are contained in the data.+ |
+ |
| 449 | +11x | +
+ group_list_i <- groups_lists[[name_i]]+ |
+ |
| 450 | +11x | +
+ group_has_levels <- vapply(group_list_i, function(lvls) any(lvls %in% existing_levels), TRUE)+ |
+ |
| 451 | +11x | +
+ names(which(group_has_levels)) |
|
| 439 | +452 |
- #' @param x (`numeric`)\cr coordinate of point.+ } else {
+ |
+ |
| 453 | +109x | +
+ existing_levels |
|
| 440 | +454 |
- #' @param lower,upper (`numeric`)\cr lower/upper bound of the confidence interval.+ }+ |
+ |
| 455 | +120x | +
+ df_labels <- data.frame(+ |
+ |
| 456 | +120x | +
+ 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. |
|
| 441 | +460 |
- #' @param symbol_size (`numeric`)\cr vector with relative size for plot symbol.+ )+ |
+ |
| 461 | +66x | +
+ }, df_subgroups, names(df_subgroups)) |
|
| 442 | +462 |
- #' If `NULL`, the same symbol size is used.+ |
|
| 443 | +463 |
- #'+ # Create a data frame with one row per subgroup.+ |
+ |
| 464 | +66x | +
+ df_labels <- do.call(rbind, args = c(l_labels, make.row.names = FALSE))+ |
+ |
| 465 | +66x | +
+ row_label <- paste0(df_labels$var, ".", df_labels$subgroup)+ |
+ |
| 466 | +66x | +
+ row_split_var <- factor(row_label, levels = row_label) |
|
| 444 | +467 |
- #' @details+ |
|
| 445 | +468 |
- #' The heights get automatically determined.+ # Create a list of data subsets.+ |
+ |
| 469 | +66x | +
+ lapply(split(df_labels, row_split_var), function(row_i) {
+ |
+ |
| 470 | +294x | +
+ which_row <- if (row_i$var %in% names(groups_lists)) {
+ |
+ |
| 471 | +31x | +
+ data[[row_i$var]] %in% groups_lists[[row_i$var]][[row_i$subgroup]] |
|
| 446 | +472 |
- #'+ } else {
+ |
+ |
| 473 | +263x | +
+ data[[row_i$var]] == row_i$subgroup |
|
| 447 | +474 |
- #' @examples+ }+ |
+ |
| 475 | +294x | +
+ df <- data[which_row, ]+ |
+ |
| 476 | +294x | +
+ rownames(df) <- NULL+ |
+ |
| 477 | +294x | +
+ formatters::var_labels(df) <- data_labels |
|
| 448 | +478 |
- #' tbl <- rtable(+ + |
+ |
| 479 | +294x | +
+ list(+ |
+ |
| 480 | +294x | +
+ df = df,+ |
+ |
| 481 | +294x | +
+ df_labels = data.frame(row_i, row.names = NULL) |
|
| 449 | +482 |
- #' header = rheader(+ ) |
|
| 450 | +483 |
- #' rrow("", "E", rcell("CI", colspan = 2), "N"),
+ }) |
|
| 451 | +484 |
- #' rrow("", "A", "B", "C", "D")
+ } |
| 452 | +1 |
- #' ),+ #' Helper function to create a map data frame for `trim_levels_to_map()` |
||
| 453 | +2 |
- #' rrow("row 1", 1, 0.8, 1.1, 16),
+ #' |
||
| 454 | +3 |
- #' rrow("row 2", 1.4, 0.8, 1.6, 25),
+ #' @description `r lifecycle::badge("stable")`
|
||
| 455 | +4 |
- #' rrow("row 3", 1.2, 0.8, 1.6, 36)
+ #' |
||
| 456 | +5 |
- #' )+ #' Helper function to create a map data frame from the input dataset, which can be used as an argument in the |
||
| 457 | +6 | ++ |
+ #' `trim_levels_to_map` split function. Based on different method, the map is constructed differently.+ |
+ |
| 7 |
#' |
|||
| 458 | +8 |
- #' x <- c(1, 1.4, 1.2)+ #' @inheritParams argument_convention |
||
| 459 | +9 |
- #' lower <- c(0.8, 0.8, 0.8)+ #' @param abnormal (named `list`)\cr identifying the abnormal range level(s) in `df`. Based on the levels of |
||
| 460 | +10 |
- #' upper <- c(1.1, 1.6, 1.6)+ #' abnormality of the input dataset, it can be something like `list(Low = "LOW LOW", High = "HIGH HIGH")` or |
||
| 461 | +11 |
- #' # numeric vector with multiplication factor to scale each circle radius+ #' `abnormal = list(Low = "LOW", High = "HIGH"))` |
||
| 462 | +12 |
- #' # default radius is 1/3.5 lines+ #' @param method (`string`)\cr indicates how the returned map will be constructed. Can be `"default"` or `"range"`. |
||
| 463 | +13 |
- #' symbol_scale <- c(1, 1.25, 1.5)+ #' |
||
| 464 | +14 | ++ |
+ #' @return A map `data.frame`.+ |
+ |
| 15 |
#' |
|||
| 465 | +16 |
- #' # Internal function - forest_grob+ #' @note If method is `"default"`, the returned map will only have the abnormal directions that are observed in the |
||
| 466 | +17 |
- #' \donttest{
+ #' `df`, and records with all normal values will be excluded to avoid error in creating layout. If method is |
||
| 467 | +18 |
- #' p <- forest_grob(tbl, x, lower, upper,+ #' `"range"`, the returned map will be based on the rule that at least one observation with low range > 0 |
||
| 468 | +19 |
- #' vline = 1, forest_header = c("A", "B"),
+ #' for low direction and at least one observation with high range is not missing for high direction. |
||
| 469 | +20 |
- #' x_at = c(.1, 1, 10), xlim = c(0.1, 10), logx = TRUE, symbol_size = symbol_scale,+ #' |
||
| 470 | +21 |
- #' vp = grid::plotViewport(margins = c(1, 1, 1, 1))+ #' @examples |
||
| 471 | +22 |
- #' )+ #' adlb <- df_explicit_na(tern_ex_adlb) |
||
| 472 | +23 |
#' |
||
| 473 | +24 |
- #' draw_grob(p)+ #' h_map_for_count_abnormal( |
||
| 474 | +25 |
- #' }+ #' df = adlb, |
||
| 475 | +26 |
- #'+ #' variables = list(anl = "ANRIND", split_rows = c("LBCAT", "PARAM")),
|
||
| 476 | +27 |
- #' @noRd+ #' abnormal = list(low = c("LOW"), high = c("HIGH")),
|
||
| 477 | +28 |
- #' @keywords internal+ #' method = "default",+ |
+ ||
| 29 | ++ |
+ #' na_str = "<Missing>" |
||
| 478 | +30 |
- forest_grob <- function(tbl,+ #' ) |
||
| 479 | +31 |
- x,+ #' |
||
| 480 | +32 |
- lower,+ #' df <- data.frame( |
||
| 481 | +33 |
- upper,+ #' USUBJID = c(rep("1", 4), rep("2", 4), rep("3", 4)),
|
||
| 482 | +34 |
- vline,+ #' AVISIT = c( |
||
| 483 | +35 |
- forest_header,+ #' rep("WEEK 1", 2),
|
||
| 484 | +36 |
- xlim = NULL,+ #' rep("WEEK 2", 2),
|
||
| 485 | +37 |
- logx = FALSE,+ #' rep("WEEK 1", 2),
|
||
| 486 | +38 |
- x_at = NULL,+ #' rep("WEEK 2", 2),
|
||
| 487 | +39 |
- width_row_names = NULL,+ #' rep("WEEK 1", 2),
|
||
| 488 | +40 |
- width_columns = NULL,+ #' rep("WEEK 2", 2)
|
||
| 489 | +41 |
- width_forest = grid::unit(1, "null"),+ #' ), |
||
| 490 | +42 |
- symbol_size = NULL,+ #' PARAM = rep(c("ALT", "CPR"), 6),
|
||
| 491 | +43 |
- col = "blue",+ #' ANRIND = c( |
||
| 492 | +44 |
- name = NULL,+ #' "NORMAL", "NORMAL", "LOW", |
||
| 493 | +45 |
- gp = NULL,+ #' "HIGH", "LOW", "LOW", "HIGH", "HIGH", rep("NORMAL", 4)
|
||
| 494 | +46 |
- vp = NULL) {
+ #' ), |
||
| 495 | -1x | +|||
| 47 | +
- lifecycle::deprecate_warn(+ #' ANRLO = rep(5, 12), |
|||
| 496 | -1x | +|||
| 48 | +
- "0.9.4", "forest_grob()",+ #' ANRHI = rep(20, 12) |
|||
| 497 | -1x | +|||
| 49 | +
- details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`."+ #' ) |
|||
| 498 | +50 |
- )+ #' df$ANRIND <- factor(df$ANRIND, levels = c("LOW", "HIGH", "NORMAL"))
|
||
| 499 | +51 |
-
+ #' h_map_for_count_abnormal( |
||
| 500 | -1x | +|||
| 52 | +
- nr <- nrow(tbl)+ #' df = df, |
|||
| 501 | -1x | +|||
| 53 | +
- if (is.null(vline)) {
+ #' variables = list( |
|||
| 502 | -! | +|||
| 54 | +
- checkmate::assert_true(is.null(forest_header))+ #' anl = "ANRIND", |
|||
| 503 | +55 |
- } else {
+ #' split_rows = c("PARAM"),
|
||
| 504 | -1x | +|||
| 56 | +
- checkmate::assert_number(vline)+ #' range_low = "ANRLO", |
|||
| 505 | -1x | +|||
| 57 | +
- checkmate::assert_character(forest_header, len = 2, null.ok = TRUE)+ #' range_high = "ANRHI" |
|||
| 506 | +58 |
- }+ #' ), |
||
| 507 | +59 |
-
+ #' abnormal = list(low = c("LOW"), high = c("HIGH")),
|
||
| 508 | -1x | +|||
| 60 | +
- checkmate::assert_numeric(x, len = nr)+ #' method = "range", |
|||
| 509 | -1x | +|||
| 61 | +
- checkmate::assert_numeric(lower, len = nr)+ #' na_str = "<Missing>" |
|||
| 510 | -1x | +|||
| 62 | +
- checkmate::assert_numeric(upper, len = nr)+ #' ) |
|||
| 511 | -1x | +|||
| 63 | +
- checkmate::assert_numeric(symbol_size, len = nr, null.ok = TRUE)+ #' |
|||
| 512 | -1x | +|||
| 64 | +
- checkmate::assert_character(col)+ #' @export |
|||
| 513 | +65 |
-
+ h_map_for_count_abnormal <- function(df, |
||
| 514 | -1x | +|||
| 66 | +
- if (is.null(symbol_size)) {
+ variables = list( |
|||
| 515 | -! | +|||
| 67 | +
- symbol_size <- rep(1, nr)+ anl = "ANRIND", |
|||
| 516 | +68 |
- }+ split_rows = c("PARAM"),
|
||
| 517 | +69 |
-
+ range_low = "ANRLO", |
||
| 518 | -1x | +|||
| 70 | +
- if (is.null(xlim)) {
+ range_high = "ANRHI" |
|||
| 519 | -! | +|||
| 71 | +
- r <- range(c(x, lower, upper), na.rm = TRUE)+ ), |
|||
| 520 | -! | +|||
| 72 | +
- xlim <- r + c(-0.05, 0.05) * diff(r)+ abnormal = list(low = c("LOW", "LOW LOW"), high = c("HIGH", "HIGH HIGH")),
|
|||
| 521 | +73 |
- }+ method = c("default", "range"),
|
||
| 522 | +74 |
-
+ na_str = "<Missing>") {
|
||
| 523 | -1x | +75 | +7x |
- if (logx) {
+ method <- match.arg(method) |
| 524 | -1x | -
- if (is.null(x_at)) {
- |
- ||
| 525 | -! | +76 | +7x |
- x_at <- pretty(log(stats::na.omit(c(x, lower, upper))))+ checkmate::assert_subset(c("anl", "split_rows"), names(variables))
|
| 526 | -! | +|||
| 77 | +7x |
- x_labels <- exp(x_at)+ checkmate::assert_false(anyNA(df[variables$split_rows])) |
||
| 527 | -+ | |||
| 78 | +7x |
- } else {
+ assert_df_with_variables(df, |
||
| 528 | -1x | +79 | +7x |
- x_labels <- x_at+ variables = list(anl = variables$anl, split_rows = variables$split_rows), |
| 529 | -1x | +80 | +7x |
- x_at <- log(x_at)+ na_level = na_str |
| 530 | +81 |
- }- |
- ||
| 531 | -1x | -
- xlim <- log(xlim)- |
- ||
| 532 | -1x | -
- x <- log(x)+ ) |
||
| 533 | -1x | +82 | +7x |
- lower <- log(lower)+ assert_df_with_factors(df, list(val = variables$anl)) |
| 534 | -1x | +83 | +7x |
- upper <- log(upper)+ assert_valid_factor(df[[variables$anl]], any.missing = FALSE) |
| 535 | -1x | +84 | +7x |
- if (!is.null(vline)) {
+ assert_list_of_variables(variables) |
| 536 | -1x | +85 | +7x |
- vline <- log(vline)+ checkmate::assert_list(abnormal, types = "character", len = 2) |
| 537 | +86 |
- }+ |
||
| 538 | +87 |
- } else {
- |
- ||
| 539 | -! | -
- x_labels <- TRUE+ # Drop usued levels from df as they are not supposed to be in the final map |
||
| 540 | -+ | |||
| 88 | +7x |
- }+ df <- droplevels(df) |
||
| 541 | +89 | |||
| 542 | -1x | +90 | +7x |
- data_forest_vp <- grid::dataViewport(xlim, c(0, 1))+ normal_value <- setdiff(levels(df[[variables$anl]]), unlist(abnormal)) |
| 543 | +91 | |||
| 544 | +92 |
- # Get table content as matrix form.+ # Based on the understanding of clinical data, there should only be one level of normal which is "NORMAL" |
||
| 545 | -1x | +93 | +7x |
- mf <- matrix_form(tbl)+ checkmate::assert_vector(normal_value, len = 1) |
| 546 | +94 | |||
| 547 | +95 |
- # Use `rtables` indent_string eventually.+ # Default method will only have what is observed in the df, and records with all normal values will be excluded to |
||
| 548 | -1x | +|||
| 96 | +
- mf$strings[, 1] <- paste0(+ # avoid error in layout building. |
|||
| 549 | -1x | +97 | +7x |
- strrep(" ", c(rep(0, attr(mf, "nrow_header")), mf$row_info$indent)),
+ if (method == "default") {
|
| 550 | -1x | +98 | +3x |
- mf$strings[, 1]+ df_abnormal <- subset(df, df[[variables$anl]] %in% unlist(abnormal)) |
| 551 | -+ | |||
| 99 | +3x |
- )+ map <- unique(df_abnormal[c(variables$split_rows, variables$anl)]) |
||
| 552 | -+ | |||
| 100 | +3x |
-
+ map_normal <- unique(subset(map, select = variables$split_rows)) |
||
| 553 | -1x | +101 | +3x |
- n_header <- attr(mf, "nrow_header")+ map_normal[[variables$anl]] <- normal_value |
| 554 | -+ | |||
| 102 | +3x |
-
+ map <- rbind(map, map_normal) |
||
| 555 | -! | +|||
| 103 | +4x |
- if (any(mf$display[, 1] == FALSE)) stop("row names need to be always displayed")
+ } else if (method == "range") {
|
||
| 556 | +104 |
-
+ # range method follows the rule that at least one observation with ANRLO > 0 for low |
||
| 557 | +105 |
- # Pre-process the data to be used in lapply and cell_in_rows.+ # direction and at least one observation with ANRHI is not missing for high direction. |
||
| 558 | -1x | +106 | +4x |
- to_args_for_cell_in_rows_fun <- function(part = c("body", "header"),
+ checkmate::assert_subset(c("range_low", "range_high"), names(variables))
|
| 559 | -1x | +107 | +4x |
- underline_colspan = FALSE) {
+ checkmate::assert_subset(c("LOW", "HIGH"), toupper(names(abnormal)))
|
| 560 | -2x | +|||
| 108 | +
- part <- match.arg(part)+ |
|||
| 561 | -2x | +109 | +4x |
- if (part == "body") {
+ assert_df_with_variables(df, |
| 562 | -1x | +110 | +4x |
- mat_row_indices <- seq_len(nrow(tbl)) + n_header+ variables = list( |
| 563 | -1x | -
- row_ind_offset <- -n_header- |
- ||
| 564 | -+ | 111 | +4x |
- } else {
+ range_low = variables$range_low, |
| 565 | -1x | +112 | +4x |
- mat_row_indices <- seq_len(n_header)+ range_high = variables$range_high |
| 566 | -1x | +|||
| 113 | +
- row_ind_offset <- 0+ ) |
|||
| 567 | +114 |
- }+ ) |
||
| 568 | +115 | |||
| 569 | -2x | +|||
| 116 | +
- lapply(mat_row_indices, function(i) {
+ # Define low direction of map |
|||
| 570 | -5x | +117 | +4x |
- disp <- mf$display[i, -1]+ df_low <- subset(df, df[[variables$range_low]] > 0) |
| 571 | -5x | +118 | +4x |
- list(+ map_low <- unique(df_low[variables$split_rows]) |
| 572 | -5x | +119 | +4x |
- row_name = mf$strings[i, 1],+ low_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "LOW"])) |
| 573 | -5x | +120 | +4x |
- cells = mf$strings[i, -1][disp],+ low_levels_df <- as.data.frame(low_levels) |
| 574 | -5x | +121 | +4x |
- cell_spans = mf$spans[i, -1][disp],+ colnames(low_levels_df) <- variables$anl |
| 575 | -5x | +122 | +4x |
- row_index = i + row_ind_offset,+ low_levels_df <- do.call("rbind", replicate(nrow(map_low), low_levels_df, simplify = FALSE))
|
| 576 | -5x | +123 | +4x |
- underline_colspan = underline_colspan+ rownames(map_low) <- NULL # Just to avoid strange row index in case upstream functions changed |
| 577 | -+ | |||
| 124 | +4x |
- )+ map_low <- map_low[rep(seq_len(nrow(map_low)), each = length(low_levels)), , drop = FALSE] |
||
| 578 | -+ | |||
| 125 | +4x |
- })+ map_low <- cbind(map_low, low_levels_df) |
||
| 579 | +126 |
- }+ |
||
| 580 | +127 |
-
+ # Define high direction of map |
||
| 581 | -1x | +128 | +4x |
- args_header <- to_args_for_cell_in_rows_fun("header", underline_colspan = TRUE)
+ df_high <- subset(df, df[[variables$range_high]] != na_str | !is.na(df[[variables$range_high]])) |
| 582 | -1x | +129 | +4x |
- args_body <- to_args_for_cell_in_rows_fun("body", underline_colspan = FALSE)
+ map_high <- unique(df_high[variables$split_rows]) |
| 583 | -+ | |||
| 130 | +4x |
-
+ high_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "HIGH"])) |
||
| 584 | -1x | +131 | +4x |
- grid::gTree(+ high_levels_df <- as.data.frame(high_levels) |
| 585 | -1x | +132 | +4x |
- name = name,+ colnames(high_levels_df) <- variables$anl |
| 586 | -1x | +133 | +4x |
- children = grid::gList(+ high_levels_df <- do.call("rbind", replicate(nrow(map_high), high_levels_df, simplify = FALSE))
|
| 587 | -1x | +134 | +4x |
- grid::gTree(+ rownames(map_high) <- NULL |
| 588 | -1x | +135 | +4x |
- children = do.call(grid::gList, lapply(args_header, do.call, what = cell_in_rows)),+ map_high <- map_high[rep(seq_len(nrow(map_high)), each = length(high_levels)), , drop = FALSE] |
| 589 | -1x | +136 | +4x |
- vp = grid::vpPath("vp_table_layout", "vp_header")
+ map_high <- cbind(map_high, high_levels_df) |
| 590 | +137 |
- ),+ |
||
| 591 | -1x | +|||
| 138 | +
- grid::gTree(+ # Define normal of map |
|||
| 592 | -1x | +139 | +4x |
- children = do.call(grid::gList, lapply(args_body, do.call, what = cell_in_rows)),+ map_normal <- unique(rbind(map_low, map_high)[variables$split_rows]) |
| 593 | -1x | +140 | +4x |
- vp = grid::vpPath("vp_table_layout", "vp_body")
+ map_normal[variables$anl] <- normal_value |
| 594 | +141 |
- ),+ |
||
| 595 | -1x | +142 | +4x |
- grid::linesGrob(+ map <- rbind(map_low, map_high, map_normal) |
| 596 | -1x | +|||
| 143 | +
- grid::unit(c(0, 1), "npc"),+ } |
|||
| 597 | -1x | +|||
| 144 | +
- y = grid::unit(c(.5, .5), "npc"),+ + |
+ |||
| 145 | ++ |
+ # map should be all characters |
||
| 598 | -1x | +146 | +7x |
- vp = grid::vpPath("vp_table_layout", "vp_spacer")
+ map <- data.frame(lapply(map, as.character), stringsAsFactors = FALSE) |
| 599 | +147 |
- ),+ |
||
| 600 | +148 |
- # forest part+ # sort the map final output by split_rows variables |
||
| 601 | -1x | +149 | +7x |
- if (is.null(vline)) {
+ for (i in rev(seq_len(length(variables$split_rows)))) {
|
| 602 | -! | +|||
| 150 | +7x |
- NULL+ map <- map[order(map[[i]]), ] |
||
| 603 | +151 |
- } else {
- |
- ||
| 604 | -1x | -
- grid::gTree(+ } |
||
| 605 | -1x | +152 | +7x |
- children = grid::gList(+ map |
| 606 | -1x | +|||
| 153 | +
- grid::gTree(+ } |
|||
| 607 | -1x | +
| 1 | +
- children = grid::gList(+ #' Count occurrences |
|||
| 608 | +2 |
- # this may overflow, to fix, look here+ #' |
||
| 609 | +3 |
- # https://stackoverflow.com/questions/33623169/add-multi-line-footnote-to-tablegrob-while-using-gridextra-in-r # nolint+ #' @description `r lifecycle::badge("stable")`
|
||
| 610 | -1x | +|||
| 4 | +
- grid::textGrob(+ #' |
|||
| 611 | -1x | +|||
| 5 | +
- forest_header[1],+ #' The analyze function [count_occurrences()] creates a layout element to calculate occurrence counts for patients. |
|||
| 612 | -1x | +|||
| 6 | +
- x = grid::unit(vline, "native") - grid::unit(1, "lines"),+ #' |
|||
| 613 | -1x | +|||
| 7 | +
- just = c("right", "center")
+ #' This function analyzes the variable(s) supplied to `vars` and returns a table of occurrence counts for |
|||
| 614 | +8 |
- ),+ #' each unique value (or level) of the variable(s). This variable (or variables) must be |
||
| 615 | -1x | +|||
| 9 | +
- grid::textGrob(+ #' non-numeric. The `id` variable is used to indicate unique subject identifiers (defaults to `USUBJID`). |
|||
| 616 | -1x | +|||
| 10 | +
- forest_header[2],+ #' |
|||
| 617 | -1x | +|||
| 11 | +
- x = grid::unit(vline, "native") + grid::unit(1, "lines"),+ #' If there are multiple occurrences of the same value recorded for a patient, the value is only counted once. |
|||
| 618 | -1x | +|||
| 12 | +
- just = c("left", "center")
+ #' |
|||
| 619 | +13 |
- )+ #' The summarize function [summarize_occurrences()] performs the same function as [count_occurrences()] except it |
||
| 620 | +14 |
- ),+ #' creates content rows, not data rows, to summarize the current table row/column context and operates on the level of |
||
| 621 | -1x | +|||
| 15 | +
- vp = grid::vpStack(grid::viewport(layout.pos.col = ncol(tbl) + 2), data_forest_vp)+ #' the latest row split or the root of the table if no row splits have occurred. |
|||
| 622 | +16 |
- )+ #' |
||
| 623 | +17 |
- ),+ #' @inheritParams argument_convention |
||
| 624 | -1x | +|||
| 18 | +
- vp = grid::vpPath("vp_table_layout", "vp_header")
+ #' @param drop (`flag`)\cr whether non-appearing occurrence levels should be dropped from the resulting table. |
|||
| 625 | +19 |
- )+ #' Note that in that case the remaining occurrence levels in the table are sorted alphabetically. |
||
| 626 | +20 |
- },+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_occurrences")`
|
||
| 627 | -1x | +|||
| 21 | +
- grid::gTree(+ #' to see available statistics for this function. |
|||
| 628 | -1x | +|||
| 22 | +
- children = grid::gList(+ #' |
|||
| 629 | -1x | +|||
| 23 | +
- grid::gTree(+ #' @note By default, occurrences which don't appear in a given row split are dropped from the table and |
|||
| 630 | -1x | +|||
| 24 | +
- children = grid::gList(+ #' the occurrences in the table are sorted alphabetically per row split. Therefore, the corresponding layout |
|||
| 631 | -1x | +|||
| 25 | +
- grid::rectGrob(gp = grid::gpar(col = "gray90", fill = "gray90")),+ #' needs to use `split_fun = drop_split_levels` in the `split_rows_by` calls. Use `drop = FALSE` if you would |
|||
| 632 | -1x | +|||
| 26 | +
- if (is.null(vline)) {
+ #' like to show all occurrences. |
|||
| 633 | -! | +|||
| 27 | +
- NULL+ #' |
|||
| 634 | +28 |
- } else {
+ #' @examples |
||
| 635 | -1x | +|||
| 29 | +
- grid::linesGrob(+ #' library(dplyr) |
|||
| 636 | -1x | +|||
| 30 | +
- x = grid::unit(rep(vline, 2), "native"),+ #' df <- data.frame( |
|||
| 637 | -1x | +|||
| 31 | +
- y = grid::unit(c(0, 1), "npc"),+ #' USUBJID = as.character(c( |
|||
| 638 | -1x | +|||
| 32 | +
- gp = grid::gpar(lwd = 2),+ #' 1, 1, 2, 4, 4, 4, |
|||
| 639 | -1x | +|||
| 33 | +
- vp = data_forest_vp+ #' 6, 6, 6, 7, 7, 8 |
|||
| 640 | +34 |
- )+ #' )), |
||
| 641 | +35 |
- },+ #' MHDECOD = c( |
||
| 642 | -1x | +|||
| 36 | +
- grid::xaxisGrob(at = x_at, label = x_labels, vp = data_forest_vp)+ #' "MH1", "MH2", "MH1", "MH1", "MH1", "MH3", |
|||
| 643 | +37 |
- ),+ #' "MH2", "MH2", "MH3", "MH1", "MH2", "MH4" |
||
| 644 | -1x | +|||
| 38 | +
- vp = grid::viewport(layout.pos.col = ncol(tbl) + 2)+ #' ), |
|||
| 645 | +39 |
- )+ #' ARM = rep(c("A", "B"), each = 6),
|
||
| 646 | +40 |
- ),+ #' SEX = c("F", "F", "M", "M", "M", "M", "F", "F", "F", "M", "M", "F")
|
||
| 647 | -1x | +|||
| 41 | +
- vp = grid::vpPath("vp_table_layout", "vp_body")
+ #' ) |
|||
| 648 | +42 |
- ),+ #' df_adsl <- df %>% |
||
| 649 | -1x | +|||
| 43 | +
- grid::gTree(+ #' select(USUBJID, ARM) %>% |
|||
| 650 | -1x | +|||
| 44 | +
- children = do.call(+ #' unique() |
|||
| 651 | -1x | +|||
| 45 | +
- grid::gList,+ #' |
|||
| 652 | -1x | +|||
| 46 | +
- Map(+ #' @name count_occurrences |
|||
| 653 | -1x | +|||
| 47 | +
- function(xi, li, ui, row_index, size_i, col) {
+ #' @order 1 |
|||
| 654 | -3x | +|||
| 48 | +
- forest_dot_line(+ NULL |
|||
| 655 | -3x | +|||
| 49 | +
- xi,+ |
|||
| 656 | -3x | +|||
| 50 | +
- li,+ #' @describeIn count_occurrences Statistics function which counts number of patients that report an |
|||
| 657 | -3x | +|||
| 51 | +
- ui,+ #' occurrence. |
|||
| 658 | -3x | +|||
| 52 | +
- row_index,+ #' |
|||
| 659 | -3x | +|||
| 53 | +
- xlim,+ #' @param denom (`string`)\cr choice of denominator for patient proportions. Can be: |
|||
| 660 | -3x | +|||
| 54 | +
- symbol_size = size_i,+ #' - `N_col`: total number of patients in this column across rows |
|||
| 661 | -3x | +|||
| 55 | +
- col = col,+ #' - `n`: number of patients with any occurrences |
|||
| 662 | -3x | +|||
| 56 | +
- datavp = data_forest_vp+ #' |
|||
| 663 | +57 |
- )+ #' @return |
||
| 664 | +58 |
- },+ #' * `s_count_occurrences()` returns a list with: |
||
| 665 | -1x | +|||
| 59 | +
- x,+ #' * `count`: list of counts with one element per occurrence. |
|||
| 666 | -1x | +|||
| 60 | +
- lower,+ #' * `count_fraction`: list of counts and fractions with one element per occurrence. |
|||
| 667 | -1x | +|||
| 61 | +
- upper,+ #' * `fraction`: list of numerators and denominators with one element per occurrence. |
|||
| 668 | -1x | +|||
| 62 | +
- seq_along(x),+ #' |
|||
| 669 | -1x | +|||
| 63 | +
- symbol_size,+ #' @examples |
|||
| 670 | -1x | +|||
| 64 | +
- col,+ #' # Count unique occurrences per subject. |
|||
| 671 | -1x | +|||
| 65 | +
- USE.NAMES = FALSE+ #' s_count_occurrences( |
|||
| 672 | +66 |
- )+ #' df, |
||
| 673 | +67 |
- ),+ #' .N_col = 4L, |
||
| 674 | -1x | +|||
| 68 | +
- vp = grid::vpPath("vp_table_layout", "vp_body")
+ #' .df_row = df, |
|||
| 675 | +69 |
- )+ #' .var = "MHDECOD", |
||
| 676 | +70 |
- ),+ #' id = "USUBJID" |
||
| 677 | -1x | +|||
| 71 | +
- childrenvp = forest_viewport(tbl, width_row_names, width_columns, width_forest),+ #' ) |
|||
| 678 | -1x | +|||
| 72 | +
- vp = vp,+ #' |
|||
| 679 | -1x | +|||
| 73 | +
- gp = gp+ #' @export |
|||
| 680 | +74 |
- )+ s_count_occurrences <- function(df, |
||
| 681 | +75 |
- }+ denom = c("N_col", "n"),
|
||
| 682 | +76 |
-
+ .N_col, # nolint |
||
| 683 | +77 |
- cell_in_rows <- function(row_name,+ .df_row, |
||
| 684 | +78 |
- cells,+ drop = TRUE, |
||
| 685 | +79 |
- cell_spans,+ .var = "MHDECOD", |
||
| 686 | +80 |
- row_index,+ id = "USUBJID") {
|
||
| 687 | -+ | |||
| 81 | +126x |
- underline_colspan = FALSE) {
+ checkmate::assert_flag(drop) |
||
| 688 | -5x | +82 | +126x |
- checkmate::assert_string(row_name)+ assert_df_with_variables(df, list(range = .var, id = id)) |
| 689 | -5x | +83 | +126x |
- checkmate::assert_character(cells, min.len = 1, any.missing = FALSE)+ checkmate::assert_count(.N_col) |
| 690 | -5x | +84 | +126x |
- checkmate::assert_numeric(cell_spans, len = length(cells), any.missing = FALSE)+ checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
|
| 691 | -5x | +85 | +126x |
- checkmate::assert_number(row_index)+ checkmate::assert_multi_class(df[[id]], classes = c("factor", "character"))
|
| 692 | -5x | +86 | +126x |
- checkmate::assert_flag(underline_colspan)+ denom <- match.arg(denom) |
| 693 | +87 | |||
| 694 | -5x | +88 | +126x |
- vp_name_rn <- paste0("rowname-", row_index)
+ occurrences <- if (drop) {
|
| 695 | -5x | +|||
| 89 | +
- g_rowname <- if (!is.null(row_name) && row_name != "") {
+ # Note that we don't try to preserve original level order here since a) that would required |
|||
| 696 | -3x | +|||
| 90 | +
- grid::textGrob(+ # more time to look up in large original levels and b) that would fail for character input variable. |
|||
| 697 | -3x | +91 | +115x |
- name = vp_name_rn,+ occurrence_levels <- sort(unique(.df_row[[.var]])) |
| 698 | -3x | +92 | +115x |
- label = row_name,+ if (length(occurrence_levels) == 0) {
|
| 699 | -3x | +93 | +1x |
- x = grid::unit(0, "npc"),+ stop( |
| 700 | -3x | +94 | +1x |
- just = c("left", "center"),
+ "no empty `.df_row` input allowed when `drop = TRUE`,", |
| 701 | -3x | +95 | +1x |
- vp = grid::vpPath(paste0("rowname-", row_index))
+ " please use `split_fun = drop_split_levels` in the `rtables` `split_rows_by` calls" |
| 702 | +96 |
- )+ ) |
||
| 703 | +97 |
- } else {
+ } |
||
| 704 | -2x | +98 | +114x |
- NULL+ factor(df[[.var]], levels = occurrence_levels) |
| 705 | +99 |
- }+ } else {
+ |
+ ||
| 100 | +11x | +
+ df[[.var]] |
||
| 706 | +101 |
-
+ } |
||
| 707 | -5x | +102 | +125x |
- gl_cols <- if (!(length(cells) > 0)) {
+ ids <- factor(df[[id]]) |
| 708 | -! | +|||
| 103 | +125x |
- list(NULL)+ dn <- switch(denom, |
||
| 709 | -+ | |||
| 104 | +125x |
- } else {
+ n = nlevels(ids), |
||
| 710 | -5x | +105 | +125x |
- j <- 1 # column index of cell+ N_col = .N_col |
| 711 | +106 |
-
+ ) |
||
| 712 | -5x | +107 | +125x |
- lapply(seq_along(cells), function(k) {
+ has_occurrence_per_id <- table(occurrences, ids) > 0 |
| 713 | -19x | +108 | +125x |
- cell_ascii <- cells[[k]]+ n_ids_per_occurrence <- as.list(rowSums(has_occurrence_per_id)) |
| 714 | -19x | +109 | +125x |
- cs <- cell_spans[[k]]+ list( |
| 715 | -+ | |||
| 110 | +125x |
-
+ count = n_ids_per_occurrence, |
||
| 716 | -19x | +111 | +125x |
- if (is.na(cell_ascii) || is.null(cell_ascii)) {
+ count_fraction = lapply( |
| 717 | -! | +|||
| 112 | +125x |
- cell_ascii <- "NA"+ n_ids_per_occurrence, |
||
| 718 | -+ | |||
| 113 | +125x |
- }+ function(i, denom) {
+ |
+ ||
| 114 | +514x | +
+ if (i == 0 && denom == 0) {
+ |
+ ||
| 115 | +! | +
+ c(0, 0) |
||
| 719 | +116 |
-
+ } else {
|
||
| 720 | -19x | +117 | +514x |
- cell_name <- paste0("g-cell-", row_index, "-", j)
+ c(i, i / denom) |
| 721 | +118 |
-
+ } |
||
| 722 | -19x | +|||
| 119 | +
- cell_grobs <- if (identical(cell_ascii, "")) {
+ }, |
|||
| 723 | -! | +|||
| 120 | +125x |
- NULL+ denom = dn |
||
| 724 | +121 |
- } else {
+ ), |
||
| 725 | -19x | +122 | +125x |
- if (cs == 1) {
+ fraction = lapply( |
| 726 | -18x | +123 | +125x |
- grid::textGrob(+ n_ids_per_occurrence, |
| 727 | -18x | +124 | +125x |
- label = cell_ascii,+ function(i, denom) c("num" = i, "denom" = denom),
|
| 728 | -18x | +125 | +125x |
- name = cell_name,+ denom = dn |
| 729 | -18x | +|||
| 126 | +
- vp = grid::vpPath(paste0("cell-", row_index, "-", j))
+ ) |
|||
| 730 | +127 |
- )+ ) |
||
| 731 | +128 |
- } else {
+ } |
||
| 732 | +129 |
- # +1 because of rowname+ |
||
| 733 | -1x | +|||
| 130 | +
- vp_joined_cols <- grid::viewport(layout.pos.row = row_index, layout.pos.col = seq(j + 1, j + cs))+ #' @describeIn count_occurrences Formatted analysis function which is used as `afun` |
|||
| 734 | +131 |
-
+ #' in `count_occurrences()`. |
||
| 735 | -1x | +|||
| 132 | +
- lab <- grid::textGrob(+ #' |
|||
| 736 | -1x | +|||
| 133 | +
- label = cell_ascii,+ #' @return |
|||
| 737 | -1x | +|||
| 134 | +
- name = cell_name,+ #' * `a_count_occurrences()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 738 | -1x | +|||
| 135 | +
- vp = vp_joined_cols+ #' |
|||
| 739 | +136 |
- )+ #' @examples |
||
| 740 | +137 |
-
+ #' a_count_occurrences( |
||
| 741 | -1x | +|||
| 138 | +
- if (!underline_colspan || grepl("^[[:space:]]*$", cell_ascii)) {
+ #' df, |
|||
| 742 | -! | +|||
| 139 | +
- lab+ #' .N_col = 4L, |
|||
| 743 | +140 |
- } else {
+ #' .df_row = df, |
||
| 744 | -1x | +|||
| 141 | +
- grid::gList(+ #' .var = "MHDECOD", |
|||
| 745 | -1x | +|||
| 142 | +
- lab,+ #' id = "USUBJID" |
|||
| 746 | -1x | +|||
| 143 | +
- grid::linesGrob(+ #' ) |
|||
| 747 | -1x | +|||
| 144 | +
- x = grid::unit.c(grid::unit(.2, "lines"), grid::unit(1, "npc") - grid::unit(.2, "lines")),+ #' |
|||
| 748 | -1x | +|||
| 145 | +
- y = grid::unit(c(0, 0), "npc"),+ #' @export |
|||
| 749 | -1x | +|||
| 146 | +
- vp = vp_joined_cols+ a_count_occurrences <- function(df, |
|||
| 750 | +147 |
- )+ labelstr = "", |
||
| 751 | +148 |
- )+ id = "USUBJID", |
||
| 752 | +149 |
- }+ denom = c("N_col", "n"),
|
||
| 753 | +150 |
- }+ drop = TRUE, |
||
| 754 | +151 |
- }+ .N_col, # nolint |
||
| 755 | -19x | +|||
| 152 | +
- j <<- j + cs+ .var = NULL, |
|||
| 756 | +153 |
-
+ .df_row = NULL, |
||
| 757 | -19x | +|||
| 154 | +
- cell_grobs+ .stats = NULL, |
|||
| 758 | +155 |
- })+ .formats = NULL, |
||
| 759 | +156 |
- }+ .labels = NULL, |
||
| 760 | +157 |
-
+ .indent_mods = NULL,+ |
+ ||
| 158 | ++ |
+ na_str = default_na_str()) {
|
||
| 761 | -5x | +159 | +85x |
- grid::gList(+ denom <- match.arg(denom) |
| 762 | -5x | +160 | +85x |
- g_rowname,+ x_stats <- s_count_occurrences( |
| 763 | -5x | +161 | +85x |
- do.call(grid::gList, gl_cols)+ df = df, denom = denom, .N_col = .N_col, .df_row = .df_row, drop = drop, .var = .var, id = id |
| 764 | +162 |
) |
||
| 765 | -+ | |||
| 163 | +85x |
- }+ if (is.null(unlist(x_stats))) {
|
||
| 766 | -+ | |||
| 164 | +3x |
-
+ return(NULL) |
||
| 767 | +165 |
- #' Graphic object: forest dot line+ } |
||
| 768 | -+ | |||
| 166 | +82x |
- #'+ x_lvls <- names(x_stats[[1]]) |
||
| 769 | +167 |
- #' @description `r lifecycle::badge("deprecated")`
+
|
||
| 770 | +168 |
- #'+ # Fill in with formatting defaults if needed |
||
| 771 | -+ | |||
| 169 | +82x |
- #' Calculate the `grob` corresponding to the dot line within the forest plot.+ .stats <- get_stats("count_occurrences", stats_in = .stats)
|
||
| 772 | -+ | |||
| 170 | +82x |
- #'+ .formats <- get_formats_from_stats(.stats, .formats) |
||
| 773 | -+ | |||
| 171 | +82x |
- #' @noRd+ .labels <- get_labels_from_stats(.stats, .labels, row_nms = x_lvls) |
||
| 774 | -+ | |||
| 172 | +82x |
- #' @keywords internal+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods, row_nms = x_lvls) |
||
| 775 | +173 |
- forest_dot_line <- function(x,+ |
||
| 776 | -+ | |||
| 174 | +81x |
- lower,+ if ("count_fraction_fixed_dp" %in% .stats) x_stats[["count_fraction_fixed_dp"]] <- x_stats[["count_fraction"]]
|
||
| 777 | -+ | |||
| 175 | +82x |
- upper,+ x_stats <- x_stats[.stats] |
||
| 778 | +176 |
- row_index,+ |
||
| 779 | +177 |
- xlim,+ # Ungroup statistics with values for each level of x |
||
| 780 | -+ | |||
| 178 | +82x |
- symbol_size = 1,+ x_ungrp <- ungroup_stats(x_stats, .formats, list(), list())+ |
+ ||
| 179 | +82x | +
+ x_stats <- x_ungrp[["x"]]+ |
+ ||
| 180 | +82x | +
+ .formats <- x_ungrp[[".formats"]] |
||
| 781 | +181 |
- col = "blue",+ |
||
| 782 | +182 |
- datavp) {
+ # Auto format handling |
||
| 783 | -3x | +183 | +82x |
- lifecycle::deprecate_warn(+ .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var) |
| 784 | -3x | +|||
| 184 | +
- "0.9.4", "forest_dot_line()",+ |
|||
| 785 | -3x | +185 | +82x |
- details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`."+ in_rows( |
| 786 | -+ | |||
| 186 | +82x |
- )+ .list = x_stats, |
||
| 787 | -+ | |||
| 187 | +82x |
-
+ .formats = .formats, |
||
| 788 | -3x | +188 | +82x |
- ci <- c(lower, upper)+ .names = .labels, |
| 789 | -3x | +189 | +82x |
- if (any(!is.na(c(x, ci)))) {
+ .labels = .labels, |
| 790 | -+ | |||
| 190 | +82x |
- # line+ .indent_mods = .indent_mods, |
||
| 791 | -3x | +191 | +82x |
- y <- grid::unit(c(0.5, 0.5), "npc")+ .format_na_strs = na_str |
| 792 | +192 |
-
+ ) |
||
| 793 | -3x | +|||
| 193 | +
- g_line <- if (all(!is.na(ci)) && ci[2] > xlim[1] && ci[1] < xlim[2]) {
+ } |
|||
| 794 | +194 |
- # -+ |
||
| 795 | -3x | +|||
| 195 | +
- if (ci[1] >= xlim[1] && ci[2] <= xlim[2]) {
+ #' @describeIn count_occurrences Layout-creating function which can take statistics function arguments |
|||
| 796 | -3x | +|||
| 196 | +
- grid::linesGrob(x = grid::unit(c(ci[1], ci[2]), "native"), y = y)+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 797 | -! | +|||
| 197 | +
- } else if (ci[1] < xlim[1] && ci[2] > xlim[2]) {
+ #' |
|||
| 798 | +198 |
- # <->+ #' @return |
||
| 799 | -! | +|||
| 199 | +
- grid::linesGrob(+ #' * `count_occurrences()` returns a layout object suitable for passing to further layouting functions, |
|||
| 800 | -! | +|||
| 200 | +
- x = grid::unit(xlim, "native"),+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 801 | -! | +|||
| 201 | +
- y = y,+ #' the statistics from `s_count_occurrences()` to the table layout. |
|||
| 802 | -! | +|||
| 202 | +
- arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "both")+ #' |
|||
| 803 | +203 |
- )+ #' @examples |
||
| 804 | -! | +|||
| 204 | +
- } else if (ci[1] < xlim[1] && ci[2] <= xlim[2]) {
+ #' # Create table layout |
|||
| 805 | +205 |
- # <-+ #' lyt <- basic_table() %>% |
||
| 806 | -! | +|||
| 206 | +
- grid::linesGrob(+ #' split_cols_by("ARM") %>%
|
|||
| 807 | -! | +|||
| 207 | +
- x = grid::unit(c(xlim[1], ci[2]), "native"),+ #' add_colcounts() %>% |
|||
| 808 | -! | +|||
| 208 | +
- y = y,+ #' count_occurrences(vars = "MHDECOD", .stats = c("count_fraction"))
|
|||
| 809 | -! | +|||
| 209 | +
- arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "first")+ #' |
|||
| 810 | +210 |
- )+ #' # Apply table layout to data and produce `rtable` object |
||
| 811 | -! | +|||
| 211 | +
- } else if (ci[1] >= xlim[1] && ci[2] > xlim[2]) {
+ #' tbl <- lyt %>% |
|||
| 812 | +212 |
- # ->+ #' build_table(df, alt_counts_df = df_adsl) %>% |
||
| 813 | -! | +|||
| 213 | +
- grid::linesGrob(+ #' prune_table() |
|||
| 814 | -! | +|||
| 214 | +
- x = grid::unit(c(ci[1], xlim[2]), "native"),+ #' |
|||
| 815 | -! | +|||
| 215 | +
- y = y,+ #' tbl |
|||
| 816 | -! | +|||
| 216 | +
- arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "last")+ #' |
|||
| 817 | +217 |
- )+ #' @export |
||
| 818 | +218 |
- }+ #' @order 2 |
||
| 819 | +219 |
- } else {
+ count_occurrences <- function(lyt, |
||
| 820 | -! | +|||
| 220 | +
- NULL+ vars, |
|||
| 821 | +221 |
- }+ id = "USUBJID", |
||
| 822 | +222 |
-
+ drop = TRUE, |
||
| 823 | -3x | +|||
| 223 | +
- g_circle <- if (!is.na(x) && x >= xlim[1] && x <= xlim[2]) {
+ var_labels = vars, |
|||
| 824 | -3x | +|||
| 224 | +
- grid::circleGrob(+ show_labels = "hidden", |
|||
| 825 | -3x | +|||
| 225 | +
- x = grid::unit(x, "native"),+ riskdiff = FALSE, |
|||
| 826 | -3x | +|||
| 226 | +
- y = y,+ na_str = default_na_str(), |
|||
| 827 | -3x | +|||
| 227 | +
- r = grid::unit(1 / 3.5 * symbol_size, "lines"),+ nested = TRUE, |
|||
| 828 | -3x | +|||
| 228 | +
- name = "point"+ ..., |
|||
| 829 | +229 |
- )+ table_names = vars, |
||
| 830 | +230 |
- } else {
+ .stats = "count_fraction_fixed_dp", |
||
| 831 | -! | +|||
| 231 | +
- NULL+ .formats = NULL, |
|||
| 832 | +232 |
- }+ .labels = NULL, |
||
| 833 | +233 |
-
+ .indent_mods = NULL) {
|
||
| 834 | -3x | +234 | +9x |
- grid::gTree(+ checkmate::assert_flag(riskdiff) |
| 835 | -3x | +|||
| 235 | +
- children = grid::gList(+ |
|||
| 836 | -3x | +236 | +9x |
- grid::gTree(+ extra_args <- list( |
| 837 | -3x | +237 | +9x |
- children = grid::gList(+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str |
| 838 | -3x | +|||
| 238 | +
- grid::gList(+ ) |
|||
| 839 | -3x | +239 | +9x |
- g_line,+ s_args <- list(id = id, drop = drop, ...)+ |
+
| 240 | ++ | + | ||
| 840 | -3x | +241 | +9x |
- g_circle+ if (isFALSE(riskdiff)) {
|
| 841 | -+ | |||
| 242 | +6x |
- )+ extra_args <- c(extra_args, s_args) |
||
| 842 | +243 |
- ),+ } else {
|
||
| 843 | +244 | 3x |
- vp = datavp,+ extra_args <- c( |
|
| 844 | +245 | 3x |
- gp = grid::gpar(col = col, fill = col)+ extra_args, |
|
| 845 | -+ | |||
| 246 | +3x |
- )+ list( |
||
| 846 | -+ | |||
| 247 | +3x |
- ),+ afun = list("s_count_occurrences" = a_count_occurrences),
|
||
| 847 | +248 | 3x |
- vp = grid::vpPath(paste0("forest-", row_index))
+ s_args = s_args |
|
| 848 | +249 |
- )+ ) |
||
| 849 | +250 |
- } else {
- |
- ||
| 850 | -! | -
- NULL+ ) |
||
| 851 | +251 |
} |
||
| 852 | -- |
- }- |
- ||
| 853 | +252 | |||
| 854 | -+ | |||
| 253 | +9x |
- #' Create a viewport tree for the forest plot+ analyze( |
||
| 855 | -+ | |||
| 254 | +9x |
- #'+ lyt = lyt, |
||
| 856 | -+ | |||
| 255 | +9x |
- #' @description `r lifecycle::badge("deprecated")`
+ vars = vars, |
||
| 857 | -+ | |||
| 256 | +9x |
- #'+ afun = ifelse(isFALSE(riskdiff), a_count_occurrences, afun_riskdiff), |
||
| 858 | -+ | |||
| 257 | +9x |
- #' @param tbl (`VTableTree`)\cr `rtables` table object.+ var_labels = var_labels, |
||
| 859 | -+ | |||
| 258 | +9x |
- #' @param width_row_names (`grid::unit`)\cr width of row names.+ show_labels = show_labels, |
||
| 860 | -+ | |||
| 259 | +9x |
- #' @param width_columns (`grid::unit`)\cr width of column spans.+ table_names = table_names, |
||
| 861 | -+ | |||
| 260 | +9x |
- #' @param width_forest (`grid::unit`)\cr width of the forest plot.+ na_str = na_str, |
||
| 862 | -+ | |||
| 261 | +9x |
- #' @param gap_column (`grid::unit`)\cr gap width between the columns.+ nested = nested, |
||
| 863 | -+ | |||
| 262 | +9x |
- #' @param gap_header (`grid::unit`)\cr gap width between the header.+ extra_args = extra_args |
||
| 864 | +263 |
- #' @param mat_form (`MatrixPrintForm`)\cr matrix print form of the table.+ ) |
||
| 865 | +264 |
- #'+ } |
||
| 866 | +265 |
- #' @return A viewport tree.+ |
||
| 867 | +266 |
- #'+ #' @describeIn count_occurrences Layout-creating function which can take content function arguments |
||
| 868 | +267 |
- #' @examples+ #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 869 | +268 |
- #' library(grid)+ #' |
||
| 870 | +269 |
- #'+ #' @return |
||
| 871 | +270 |
- #' tbl <- rtable(+ #' * `summarize_occurrences()` returns a layout object suitable for passing to further layouting functions, |
||
| 872 | +271 |
- #' header = rheader(+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows |
||
| 873 | +272 |
- #' rrow("", "E", rcell("CI", colspan = 2)),
+ #' containing the statistics from `s_count_occurrences()` to the table layout. |
||
| 874 | +273 |
- #' rrow("", "A", "B", "C")
+ #' |
||
| 875 | +274 |
- #' ),+ #' @examples |
||
| 876 | +275 |
- #' rrow("row 1", 1, 0.8, 1.1),
+ #' # Layout creating function with custom format. |
||
| 877 | +276 |
- #' rrow("row 2", 1.4, 0.8, 1.6),
+ #' basic_table() %>% |
||
| 878 | +277 |
- #' rrow("row 3", 1.2, 0.8, 1.2)
+ #' add_colcounts() %>% |
||
| 879 | +278 |
- #' )+ #' split_rows_by("SEX", child_labels = "visible") %>%
|
||
| 880 | +279 |
- #'+ #' summarize_occurrences( |
||
| 881 | +280 |
- #' \donttest{
+ #' var = "MHDECOD", |
||
| 882 | +281 |
- #' v <- forest_viewport(tbl)+ #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
|
||
| 883 | +282 |
- #'+ #' ) %>% |
||
| 884 | +283 |
- #' grid::grid.newpage()+ #' build_table(df, alt_counts_df = df_adsl) |
||
| 885 | +284 |
- #' showViewport(v)+ #' |
||
| 886 | +285 |
- #' }+ #' @export |
||
| 887 | +286 |
- #'+ #' @order 3 |
||
| 888 | +287 |
- #' @export+ summarize_occurrences <- function(lyt, |
||
| 889 | +288 |
- forest_viewport <- function(tbl,+ var, |
||
| 890 | +289 |
- width_row_names = NULL,+ id = "USUBJID", |
||
| 891 | +290 |
- width_columns = NULL,+ drop = TRUE, |
||
| 892 | +291 |
- width_forest = grid::unit(1, "null"),+ riskdiff = FALSE, |
||
| 893 | +292 |
- gap_column = grid::unit(1, "lines"),+ na_str = default_na_str(), |
||
| 894 | +293 |
- gap_header = grid::unit(1, "lines"),+ ..., |
||
| 895 | +294 |
- mat_form = NULL) {
- |
- ||
| 896 | -2x | -
- lifecycle::deprecate_warn(- |
- ||
| 897 | -2x | -
- "0.9.4",- |
- ||
| 898 | -2x | -
- "forest_viewport()",- |
- ||
| 899 | -2x | -
- details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`."+ .stats = "count_fraction_fixed_dp", |
||
| 900 | +295 |
- )+ .formats = NULL, |
||
| 901 | +296 | - - | -||
| 902 | -2x | -
- checkmate::assert_class(tbl, "VTableTree")- |
- ||
| 903 | -2x | -
- checkmate::assert_true(grid::is.unit(width_forest))- |
- ||
| 904 | -2x | -
- if (!is.null(width_row_names)) {
- |
- ||
| 905 | -! | -
- checkmate::assert_true(grid::is.unit(width_row_names))+ .indent_mods = NULL, |
||
| 906 | +297 |
- }+ .labels = NULL) {
|
||
| 907 | -2x | -
- if (!is.null(width_columns)) {
- |
- ||
| 908 | -! | +298 | +5x |
- checkmate::assert_true(grid::is.unit(width_columns))+ checkmate::assert_flag(riskdiff) |
| 909 | +299 |
- }+ |
||
| 910 | -+ | |||
| 300 | +5x |
-
+ extra_args <- list( |
||
| 911 | -2x | +301 | +5x |
- if (is.null(mat_form)) mat_form <- matrix_form(tbl)+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str |
| 912 | +302 |
-
+ ) |
||
| 913 | -2x | +303 | +5x |
- mat_form$strings[!mat_form$display] <- ""+ s_args <- list(id = id, drop = drop, ...) |
| 914 | +304 | |||
| 915 | -2x | -
- nr <- nrow(tbl)- |
- ||
| 916 | -2x | +305 | +5x |
- nc <- ncol(tbl)+ if (isFALSE(riskdiff)) {
|
| 917 | -2x | +306 | +1x |
- nr_h <- attr(mat_form, "nrow_header")+ extra_args <- c(extra_args, s_args) |
| 918 | +307 |
-
+ } else {
|
||
| 919 | -2x | +308 | +4x |
- if (is.null(width_row_names) || is.null(width_columns)) {
+ extra_args <- c( |
| 920 | -2x | +309 | +4x |
- tbl_widths <- formatters::propose_column_widths(mat_form)+ extra_args, |
| 921 | -2x | +310 | +4x |
- strs_with_width <- strrep("x", tbl_widths) # that works for mono spaced fonts
+ list( |
| 922 | -2x | +311 | +4x |
- if (is.null(width_row_names)) width_row_names <- grid::stringWidth(strs_with_width[1])+ afun = list("s_count_occurrences" = a_count_occurrences),
|
| 923 | -2x | -
- if (is.null(width_columns)) width_columns <- grid::stringWidth(strs_with_width[-1])- |
- ||
| 924 | -+ | 312 | +4x |
- }+ s_args = s_args |
| 925 | +313 |
-
+ ) |
||
| 926 | +314 |
- # Widths for row name, cols, forest.- |
- ||
| 927 | -2x | -
- widths <- grid::unit.c(- |
- ||
| 928 | -2x | -
- width_row_names + gap_column,- |
- ||
| 929 | -2x | -
- width_columns + gap_column,- |
- ||
| 930 | -2x | -
- width_forest+ ) |
||
| 931 | +315 |
- )+ } |
||
| 932 | +316 | |||
| 933 | -2x | +317 | +5x |
- n_lines_per_row <- apply(+ summarize_row_groups( |
| 934 | -2x | +318 | +5x |
- X = mat_form$strings,+ lyt = lyt, |
| 935 | -2x | +319 | +5x |
- MARGIN = 1,+ var = var, |
| 936 | -2x | +320 | +5x |
- FUN = function(row) {
+ cfun = ifelse(isFALSE(riskdiff), a_count_occurrences, afun_riskdiff), |
| 937 | -10x | +321 | +5x |
- tmp <- vapply(+ na_str = na_str, |
| 938 | -10x | +322 | +5x |
- gregexpr("\n", row, fixed = TRUE),
+ extra_args = extra_args |
| 939 | -10x | +|||
| 323 | +
- attr, numeric(1),+ ) |
|||
| 940 | -10x | +|||
| 324 | +
- "match.length"+ } |
|||
| 941 | -10x | +
| 1 | +
- ) + 1+ #' Tabulate survival duration by subgroup |
||
| 942 | -10x | +||
| 2 | +
- max(c(tmp, 1))+ #' |
||
| 943 | +3 |
- }+ #' @description `r lifecycle::badge("stable")`
|
|
| 944 | +4 |
- )+ #' |
|
| 945 | +5 |
-
+ #' The [tabulate_survival_subgroups()] function creates a layout element to tabulate survival duration by subgroup, |
|
| 946 | -2x | +||
| 6 | +
- i_header <- seq_len(nr_h)+ #' returning statistics including median survival time and hazard ratio for each population subgroup. The table is |
||
| 947 | +7 |
-
+ #' created from `df`, a list of data frames returned by [extract_survival_subgroups()], with the statistics to include |
|
| 948 | -2x | +||
| 8 | +
- height_body_rows <- grid::unit(n_lines_per_row[-i_header] * 1.2, "lines")+ #' specified via the `vars` parameter. |
||
| 949 | -2x | +||
| 9 | +
- height_header_rows <- grid::unit(n_lines_per_row[i_header] * 1.2, "lines")+ #' |
||
| 950 | +10 |
-
+ #' A forest plot can be created from the resulting table using the [g_forest()] function. |
|
| 951 | -2x | +||
| 11 | +
- height_body <- grid::unit(sum(n_lines_per_row[-i_header]) * 1.2, "lines")+ #' |
||
| 952 | -2x | +||
| 12 | +
- height_header <- grid::unit(sum(n_lines_per_row[i_header]) * 1.2, "lines")+ #' @inheritParams argument_convention |
||
| 953 | +13 |
-
+ #' @inheritParams survival_coxph_pairwise |
|
| 954 | -2x | +||
| 14 | +
- nc_g <- nc + 2 # number of columns incl. row names and forest+ #' @param df (`list`)\cr list of data frames containing all analysis variables. List should be |
||
| 955 | +15 |
-
+ #' created using [extract_survival_subgroups()]. |
|
| 956 | -2x | +||
| 16 | +
- vp_tbl <- grid::vpTree(+ #' @param vars (`character`)\cr the names of statistics to be reported among: |
||
| 957 | -2x | +||
| 17 | +
- parent = grid::viewport(+ #' * `n_tot_events`: Total number of events per group. |
||
| 958 | -2x | +||
| 18 | +
- name = "vp_table_layout",+ #' * `n_events`: Number of events per group. |
||
| 959 | -2x | +||
| 19 | +
- layout = grid::grid.layout(+ #' * `n_tot`: Total number of observations per group. |
||
| 960 | -2x | +||
| 20 | +
- nrow = 3, ncol = 1,+ #' * `n`: Number of observations per group. |
||
| 961 | -2x | +||
| 21 | +
- heights = grid::unit.c(height_header, gap_header, height_body)+ #' * `median`: Median survival time. |
||
| 962 | +22 |
- )+ #' * `hr`: Hazard ratio. |
|
| 963 | +23 |
- ),+ #' * `ci`: Confidence interval of hazard ratio. |
|
| 964 | -2x | +||
| 24 | +
- children = grid::vpList(+ #' * `pval`: p-value of the effect. |
||
| 965 | -2x | +||
| 25 | +
- vp_forest_table_part(nr_h, nc_g, 1, 1, widths, height_header_rows, "vp_header"),+ #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` |
||
| 966 | -2x | +||
| 26 | +
- vp_forest_table_part(nr, nc_g, 3, 1, widths, height_body_rows, "vp_body"),+ #' are required. |
||
| 967 | -2x | +||
| 27 | +
- grid::viewport(name = "vp_spacer", layout.pos.row = 2, layout.pos.col = 1)+ #' @param time_unit (`string`)\cr label with unit of median survival time. Default `NULL` skips displaying unit. |
||
| 968 | +28 |
- )+ #' |
|
| 969 | +29 |
- )+ #' @details These functions create a layout starting from a data frame which contains |
|
| 970 | -2x | +||
| 30 | +
- vp_tbl+ #' the required statistics. Tables typically used as part of forest plot. |
||
| 971 | +31 |
- }+ #' |
|
| 972 | +32 |
-
+ #' @seealso [extract_survival_subgroups()] |
|
| 973 | +33 |
- #' Viewport forest plot: table part+ #' |
|
| 974 | +34 |
- #'+ #' @examples |
|
| 975 | +35 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' library(dplyr) |
|
| 976 | +36 |
#' |
|
| 977 | +37 |
- #' Prepares a viewport for the table included in the forest plot.+ #' adtte <- tern_ex_adtte |
|
| 978 | +38 | ++ |
+ #'+ |
+
| 39 |
- #'+ #' # Save variable labels before data processing steps. |
||
| 979 | +40 |
- #' @noRd+ #' adtte_labels <- formatters::var_labels(adtte) |
|
| 980 | +41 |
- #' @keywords internal+ #' |
|
| 981 | +42 |
- vp_forest_table_part <- function(nrow,+ #' adtte_f <- adtte %>% |
|
| 982 | +43 |
- ncol,+ #' filter( |
|
| 983 | +44 |
- l_row,+ #' PARAMCD == "OS", |
|
| 984 | +45 |
- l_col,+ #' ARM %in% c("B: Placebo", "A: Drug X"),
|
|
| 985 | +46 |
- widths,+ #' SEX %in% c("M", "F")
|
|
| 986 | +47 |
- heights,+ #' ) %>% |
|
| 987 | +48 |
- name) {
+ #' mutate( |
|
| 988 | -4x | +||
| 49 | +
- lifecycle::deprecate_warn(+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
||
| 989 | -4x | +||
| 50 | +
- "0.9.4", "vp_forest_table_part()",+ #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")), |
||
| 990 | -4x | +||
| 51 | +
- details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`."+ #' SEX = droplevels(SEX), |
||
| 991 | +52 |
- )+ #' AVALU = as.character(AVALU), |
|
| 992 | +53 |
-
+ #' is_event = CNSR == 0 |
|
| 993 | -4x | +||
| 54 | +
- grid::vpTree(+ #' ) |
||
| 994 | -4x | +||
| 55 | +
- grid::viewport(+ #' labels <- c( |
||
| 995 | -4x | +||
| 56 | +
- name = name,+ #' "ARM" = adtte_labels[["ARM"]], |
||
| 996 | -4x | +||
| 57 | +
- layout.pos.row = l_row,+ #' "SEX" = adtte_labels[["SEX"]], |
||
| 997 | -4x | +||
| 58 | +
- layout.pos.col = l_col,+ #' "AVALU" = adtte_labels[["AVALU"]], |
||
| 998 | -4x | +||
| 59 | +
- layout = grid::grid.layout(nrow = nrow, ncol = ncol, widths = widths, heights = heights)+ #' "is_event" = "Event Flag" |
||
| 999 | +60 |
- ),+ #' ) |
|
| 1000 | -4x | +||
| 61 | +
- children = grid::vpList(+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
||
| 1001 | -4x | +||
| 62 | +
- do.call(+ #' |
||
| 1002 | -4x | +||
| 63 | +
- grid::vpList,+ #' df <- extract_survival_subgroups( |
||
| 1003 | -4x | +||
| 64 | +
- lapply(+ #' variables = list( |
||
| 1004 | -4x | +||
| 65 | +
- seq_len(nrow), function(i) {
+ #' tte = "AVAL", |
||
| 1005 | -10x | +||
| 66 | +
- grid::viewport(layout.pos.row = i, layout.pos.col = 1, name = paste0("rowname-", i))
+ #' is_event = "is_event", |
||
| 1006 | +67 |
- }+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
|
|
| 1007 | +68 |
- )+ #' ), |
|
| 1008 | +69 |
- ),+ #' label_all = "Total Patients", |
|
| 1009 | -4x | +||
| 70 | +
- do.call(+ #' data = adtte_f |
||
| 1010 | -4x | +||
| 71 | +
- grid::vpList,+ #' ) |
||
| 1011 | -4x | +||
| 72 | +
- apply(+ #' df |
||
| 1012 | -4x | +||
| 73 | +
- expand.grid(seq_len(nrow), seq_len(ncol - 2)),+ #' |
||
| 1013 | -4x | +||
| 74 | +
- 1,+ #' df_grouped <- extract_survival_subgroups( |
||
| 1014 | -4x | +||
| 75 | +
- function(x) {
+ #' variables = list( |
||
| 1015 | -35x | +||
| 76 | +
- i <- x[1]+ #' tte = "AVAL", |
||
| 1016 | -35x | +||
| 77 | +
- j <- x[2]+ #' is_event = "is_event", |
||
| 1017 | -35x | +||
| 78 | +
- grid::viewport(layout.pos.row = i, layout.pos.col = j + 1, name = paste0("cell-", i, "-", j))
+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
|
||
| 1018 | +79 |
- }+ #' ), |
|
| 1019 | +80 |
- )+ #' data = adtte_f, |
|
| 1020 | +81 |
- ),+ #' groups_lists = list( |
|
| 1021 | -4x | +||
| 82 | +
- do.call(+ #' BMRKR2 = list( |
||
| 1022 | -4x | +||
| 83 | +
- grid::vpList,+ #' "low" = "LOW", |
||
| 1023 | -4x | +||
| 84 | +
- lapply(+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 1024 | -4x | +||
| 85 | +
- seq_len(nrow),+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 1025 | -4x | +||
| 86 | +
- function(i) {
+ #' ) |
||
| 1026 | -10x | +||
| 87 | +
- grid::viewport(layout.pos.row = i, layout.pos.col = ncol, name = paste0("forest-", i))
+ #' ) |
||
| 1027 | +88 |
- }+ #' ) |
|
| 1028 | +89 |
- )+ #' df_grouped |
|
| 1029 | +90 |
- )+ #' |
|
| 1030 | +91 |
- )+ #' @name survival_duration_subgroups |
|
| 1031 | +92 |
- )+ #' @order 1 |
|
| 1032 | +93 |
- }+ NULL |
|
| 1033 | +94 | ||
| 1034 | +95 |
- #' Forest rendering+ #' Prepare survival data for population subgroups in data frames |
|
| 1035 | +96 |
#' |
|
| 1036 | +97 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' @description `r lifecycle::badge("stable")`
|
|
| 1037 | +98 |
#' |
|
| 1038 | +99 |
- #' Renders the forest grob.+ #' Prepares estimates of median survival times and treatment hazard ratios for population subgroups in |
|
| 1039 | +100 |
- #'+ #' data frames. Simple wrapper for [h_survtime_subgroups_df()] and [h_coxph_subgroups_df()]. Result is a `list` |
|
| 1040 | +101 |
- #' @noRd+ #' of two `data.frame`s: `survtime` and `hr`. `variables` corresponds to the names of variables found in `data`, |
|
| 1041 | +102 |
- #' @keywords internal+ #' passed as a named `list` and requires elements `tte`, `is_event`, `arm` and optionally `subgroups` and `strata`. |
|
| 1042 | +103 |
- grid.forest <- function(...) { # nolint
+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
|
| 1043 | -! | +||
| 104 | +
- lifecycle::deprecate_warn(+ #' |
||
| 1044 | -! | +||
| 105 | +
- "0.9.4", "grid.forest()",+ #' @inheritParams argument_convention |
||
| 1045 | -! | +||
| 106 | +
- details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`."+ #' @inheritParams survival_duration_subgroups |
||
| 1046 | +107 |
- )+ #' @inheritParams survival_coxph_pairwise |
|
| 1047 | +108 |
-
+ #' |
|
| 1048 | -! | +||
| 109 | +
- grid::grid.draw(forest_grob(...))+ #' @return A named `list` of two elements: |
||
| 1049 | +110 |
- }+ #' * `survtime`: A `data.frame` containing columns `arm`, `n`, `n_events`, `median`, `subgroup`, `var`, |
| 1 | +111 |
- #' Summarize analysis of covariance (ANCOVA) results+ #' `var_label`, and `row_type`. |
||
| 2 | +112 |
- #'+ #' * `hr`: A `data.frame` containing columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`, `conf_level`, |
||
| 3 | +113 |
- #' @description `r lifecycle::badge("stable")`
+ #' `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`. |
||
| 4 | +114 |
#' |
||
| 5 | +115 |
- #' The analyze function [summarize_ancova()] creates a layout element to summarize ANCOVA results.+ #' @seealso [survival_duration_subgroups] |
||
| 6 | +116 |
#' |
||
| 7 | +117 |
- #' This function can be used to analyze multiple endpoints and/or multiple timepoints within the response variable(s)+ #' @export |
||
| 8 | +118 |
- #' specified as `vars`.+ extract_survival_subgroups <- function(variables, |
||
| 9 | +119 |
- #'+ data, |
||
| 10 | +120 |
- #' Additional variables for the analysis, namely an arm (grouping) variable and covariate variables, can be defined+ groups_lists = list(), |
||
| 11 | +121 |
- #' via the `variables` argument. See below for more details on how to specify `variables`. An interaction term can+ control = control_coxph(), |
||
| 12 | +122 |
- #' be implemented in the model if needed. The interaction variable that should interact with the arm variable is+ label_all = "All Patients") {
|
||
| 13 | -+ | |||
| 123 | +12x |
- #' specified via the `interaction_term` parameter, and the specific value of `interaction_term` for which to extract+ if ("strat" %in% names(variables)) {
|
||
| 14 | -+ | |||
| 124 | +! |
- #' the ANCOVA results via the `interaction_y` parameter.+ warning( |
||
| 15 | -+ | |||
| 125 | +! |
- #'+ "Warning: the `strat` element name of the `variables` list argument to `extract_survival_subgroups() ", |
||
| 16 | -+ | |||
| 126 | +! |
- #' @inheritParams h_ancova+ "was deprecated in tern 0.9.4.\n ", |
||
| 17 | -+ | |||
| 127 | +! |
- #' @inheritParams argument_convention+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 18 | +128 |
- #' @param interaction_y (`string` or `flag`)\cr a selected item inside of the `interaction_item` variable which will be+ ) |
||
| 19 | -+ | |||
| 129 | +! |
- #' used to select the specific ANCOVA results. if the interaction is not needed, the default option is `FALSE`.+ variables[["strata"]] <- variables[["strat"]] |
||
| 20 | +130 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("summarize_ancova")`
+ } |
||
| 21 | +131 |
- #' to see available statistics for this function.+ |
||
| 22 | -+ | |||
| 132 | +12x |
- #'+ df_survtime <- h_survtime_subgroups_df( |
||
| 23 | -+ | |||
| 133 | +12x |
- #' @name summarize_ancova+ variables, |
||
| 24 | -+ | |||
| 134 | +12x |
- #' @order 1+ data, |
||
| 25 | -+ | |||
| 135 | +12x |
- NULL+ groups_lists = groups_lists, |
||
| 26 | -+ | |||
| 136 | +12x |
-
+ label_all = label_all |
||
| 27 | +137 |
- #' Helper function to return results of a linear model+ ) |
||
| 28 | -+ | |||
| 138 | +12x |
- #'+ df_hr <- h_coxph_subgroups_df( |
||
| 29 | -+ | |||
| 139 | +12x |
- #' @description `r lifecycle::badge("stable")`
+ variables, |
||
| 30 | -+ | |||
| 140 | +12x |
- #'+ data, |
||
| 31 | -+ | |||
| 141 | +12x |
- #' @inheritParams argument_convention+ groups_lists = groups_lists, |
||
| 32 | -+ | |||
| 142 | +12x |
- #' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called in `.var` and `variables`.+ control = control,+ |
+ ||
| 143 | +12x | +
+ label_all = label_all |
||
| 33 | +144 |
- #' @param variables (named `list` of `string`)\cr list of additional analysis variables, with expected elements:+ ) |
||
| 34 | +145 |
- #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be+ + |
+ ||
| 146 | +12x | +
+ list(survtime = df_survtime, hr = df_hr) |
||
| 35 | +147 |
- #' summarized. Specifically, the first level of `arm` variable is taken as the reference group.+ } |
||
| 36 | +148 |
- #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as `"X1"`), and/or+ |
||
| 37 | +149 |
- #' interaction terms indicated by `"X1 * X2"`.+ #' @describeIn survival_duration_subgroups Formatted analysis function which is used as |
||
| 38 | +150 |
- #' @param interaction_item (`string` or `NULL`)\cr name of the variable that should have interactions+ #' `afun` in `tabulate_survival_subgroups()`. |
||
| 39 | +151 |
- #' with arm. if the interaction is not needed, the default option is `NULL`.+ #' |
||
| 40 | +152 |
- #'+ #' @return |
||
| 41 | +153 |
- #' @return The summary of a linear model.+ #' * `a_survival_subgroups()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 42 | +154 |
#' |
||
| 43 | +155 |
- #' @examples+ #' @keywords internal |
||
| 44 | +156 |
- #' h_ancova(+ a_survival_subgroups <- function(.formats = list( # nolint start |
||
| 45 | +157 |
- #' .var = "Sepal.Length",+ n = "xx", |
||
| 46 | +158 |
- #' .df_row = iris,+ n_events = "xx", |
||
| 47 | +159 |
- #' variables = list(arm = "Species", covariates = c("Petal.Length * Petal.Width", "Sepal.Width"))
+ n_tot_events = "xx", |
||
| 48 | +160 |
- #' )+ median = "xx.x", |
||
| 49 | +161 |
- #'+ n_tot = "xx", |
||
| 50 | +162 |
- #' @export+ hr = list(format_extreme_values(2L)), |
||
| 51 | +163 |
- h_ancova <- function(.var,+ ci = list(format_extreme_values_ci(2L)), |
||
| 52 | +164 |
- .df_row,+ pval = "x.xxxx | (<0.0001)" |
||
| 53 | +165 |
- variables,+ ), |
||
| 54 | +166 |
- interaction_item = NULL) {
+ na_str = default_na_str()) { # nolint end
|
||
| 55 | -27x | +167 | +21x |
- checkmate::assert_string(.var)+ checkmate::assert_list(.formats) |
| 56 | -27x | +168 | +21x |
- checkmate::assert_list(variables)+ checkmate::assert_subset( |
| 57 | -27x | +169 | +21x |
- checkmate::assert_subset(names(variables), c("arm", "covariates"))
+ names(.formats), |
| 58 | -27x | +170 | +21x |
- assert_df_with_variables(.df_row, list(rsp = .var))+ c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval", "riskdiff")
|
| 59 | +171 |
-
+ ) |
||
| 60 | -26x | +|||
| 172 | +
- arm <- variables$arm+ |
|||
| 61 | -26x | +173 | +21x |
- covariates <- variables$covariates+ afun_lst <- Map( |
| 62 | -26x | -
- if (!is.null(covariates) && length(covariates) > 0) {
- |
- ||
| 63 | -+ | 174 | +21x |
- # Get all covariate variable names in the model.+ function(stat, fmt, na_str) {
|
| 64 | -11x | +175 | +160x |
- var_list <- get_covariates(covariates)+ function(df, labelstr = "", ...) {
|
| 65 | -11x | -
- assert_df_with_variables(.df_row, var_list)- |
- ||
| 66 | -+ | 176 | +312x |
- }+ in_rows( |
| 67 | -+ | |||
| 177 | +312x |
-
+ .list = as.list(df[[stat]]), |
||
| 68 | -25x | +178 | +312x |
- covariates_part <- paste(covariates, collapse = " + ")+ .labels = as.character(df$subgroup), |
| 69 | -25x | +179 | +312x |
- if (covariates_part != "") {
+ .formats = fmt, |
| 70 | -10x | +180 | +312x |
- formula <- stats::as.formula(paste0(.var, " ~ ", covariates_part, " + ", arm))+ .format_na_strs = na_str |
| 71 | +181 |
- } else {
+ ) |
||
| 72 | -15x | +|||
| 182 | +
- formula <- stats::as.formula(paste0(.var, " ~ ", arm))+ } |
|||
| 73 | +183 |
- }+ }, |
||
| 74 | -+ | |||
| 184 | +21x |
-
+ stat = names(.formats), |
||
| 75 | -25x | +185 | +21x |
- if (is.null(interaction_item)) {
+ fmt = .formats, |
| 76 | +186 | 21x |
- specs <- arm+ na_str = na_str |
|
| 77 | +187 |
- } else {
+ )+ |
+ ||
| 188 | ++ | + | ||
| 78 | -4x | +189 | +21x |
- specs <- c(arm, interaction_item)+ afun_lst |
| 79 | +190 |
- }+ } |
||
| 80 | +191 | |||
| 81 | -25x | +|||
| 192 | +
- lm_fit <- stats::lm(+ #' @describeIn survival_duration_subgroups Table-creating function which creates a table |
|||
| 82 | -25x | +|||
| 193 | +
- formula = formula,+ #' summarizing survival by subgroup. This function is a wrapper for [rtables::analyze_colvars()] |
|||
| 83 | -25x | +|||
| 194 | +
- data = .df_row+ #' and [rtables::summarize_row_groups()]. |
|||
| 84 | +195 |
- )+ #' |
||
| 85 | -25x | +|||
| 196 | +
- emmeans_fit <- emmeans::emmeans(+ #' @param label_all `r lifecycle::badge("deprecated")`\cr please assign the `label_all` parameter within the
|
|||
| 86 | -25x | +|||
| 197 | +
- lm_fit,+ #' [extract_survival_subgroups()] function when creating `df`. |
|||
| 87 | +198 |
- # Specify here the group variable over which EMM are desired.+ #' @param riskdiff (`list`)\cr if a risk (proportion) difference column should be added, a list of settings to apply |
||
| 88 | -25x | +|||
| 199 | +
- specs = specs,+ #' within the column. See [control_riskdiff()] for details. If `NULL`, no risk difference column will be added. If |
|||
| 89 | +200 |
- # Pass the data again so that the factor levels of the arm variable can be inferred.+ #' `riskdiff$arm_x` and `riskdiff$arm_y` are `NULL`, the first level of `df$survtime$arm` will be used as `arm_x` |
||
| 90 | -25x | +|||
| 201 | +
- data = .df_row+ #' and the second level as `arm_y`. |
|||
| 91 | +202 |
- )+ #' |
||
| 92 | +203 |
-
+ #' @return An `rtables` table summarizing survival by subgroup. |
||
| 93 | -25x | +|||
| 204 | +
- emmeans_fit+ #' |
|||
| 94 | +205 |
- }+ #' @examples |
||
| 95 | +206 |
-
+ #' ## Table with default columns. |
||
| 96 | +207 |
- #' @describeIn summarize_ancova Statistics function that produces a named list of results+ #' basic_table() %>% |
||
| 97 | +208 |
- #' of the investigated linear model.+ #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) |
||
| 98 | +209 |
#' |
||
| 99 | +210 |
- #' @return+ #' ## Table with a manually chosen set of columns: adding "pval". |
||
| 100 | +211 |
- #' * `s_ancova()` returns a named list of 5 statistics:+ #' basic_table() %>% |
||
| 101 | +212 |
- #' * `n`: Count of complete sample size for the group.+ #' tabulate_survival_subgroups( |
||
| 102 | +213 |
- #' * `lsmean`: Estimated marginal means in the group.+ #' df = df, |
||
| 103 | +214 |
- #' * `lsmean_diff`: Difference in estimated marginal means in comparison to the reference group.+ #' vars = c("n_tot_events", "n_events", "median", "hr", "ci", "pval"),
|
||
| 104 | +215 |
- #' If working with the reference group, this will be empty.+ #' time_unit = adtte_f$AVALU[1] |
||
| 105 | +216 |
- #' * `lsmean_diff_ci`: Confidence level for difference in estimated marginal means in comparison+ #' ) |
||
| 106 | +217 |
- #' to the reference group.+ #' |
||
| 107 | +218 |
- #' * `pval`: p-value (not adjusted for multiple comparisons).+ #' @export |
||
| 108 | +219 |
- #'+ #' @order 2 |
||
| 109 | +220 |
- #' @keywords internal+ tabulate_survival_subgroups <- function(lyt, |
||
| 110 | +221 |
- s_ancova <- function(df,+ df,+ |
+ ||
| 222 | ++ |
+ vars = c("n_tot_events", "n_events", "median", "hr", "ci"),
|
||
| 111 | +223 |
- .var,+ groups_lists = list(), |
||
| 112 | +224 |
- .df_row,+ label_all = lifecycle::deprecated(), |
||
| 113 | +225 |
- variables,+ time_unit = NULL, |
||
| 114 | +226 |
- .ref_group,+ riskdiff = NULL, |
||
| 115 | +227 |
- .in_ref_col,+ na_str = default_na_str(), |
||
| 116 | +228 |
- conf_level,+ .formats = c( |
||
| 117 | +229 |
- interaction_y = FALSE,+ n = "xx", n_events = "xx", n_tot_events = "xx", median = "xx.x", n_tot = "xx", |
||
| 118 | +230 |
- interaction_item = NULL) {
+ hr = list(format_extreme_values(2L)), ci = list(format_extreme_values_ci(2L)), |
||
| 119 | -3x | +|||
| 231 | +
- emmeans_fit <- h_ancova(.var = .var, variables = variables, .df_row = .df_row, interaction_item = interaction_item)+ pval = "x.xxxx | (<0.0001)" |
|||
| 120 | +232 |
-
+ )) {
|
||
| 121 | -3x | +233 | +10x |
- sum_fit <- summary(+ checkmate::assert_list(riskdiff, null.ok = TRUE) |
| 122 | -3x | +234 | +10x |
- emmeans_fit,+ checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
|
| 123 | -3x | +235 | +10x |
- level = conf_level+ checkmate::assert_true(all(c("hr", "ci") %in% vars))
|
| 124 | +236 |
- )+ |
||
| 125 | -+ | |||
| 237 | +10x |
-
+ if (lifecycle::is_present(label_all)) {
|
||
| 126 | -3x | +238 | +1x |
- arm <- variables$arm+ lifecycle::deprecate_warn( |
| 127 | -+ | |||
| 239 | +1x |
-
+ "0.9.5", "tabulate_survival_subgroups(label_all)", |
||
| 128 | -3x | +240 | +1x |
- sum_level <- as.character(unique(df[[arm]]))+ details =+ |
+
| 241 | +1x | +
+ "Please assign the `label_all` parameter within the `extract_survival_subgroups()` function when creating `df`." |
||
| 129 | +242 |
-
+ ) |
||
| 130 | +243 |
- # Ensure that there is only one element in sum_level.+ } |
||
| 131 | -3x | +|||
| 244 | +
- checkmate::assert_scalar(sum_level)+ |
|||
| 132 | +245 |
-
+ # Create "ci" column from "lcl" and "ucl" |
||
| 133 | -2x | +246 | +10x |
- sum_fit_level <- sum_fit[sum_fit[[arm]] == sum_level, ]+ df$hr$ci <- combine_vectors(df$hr$lcl, df$hr$ucl) |
| 134 | +247 | |||
| 135 | +248 |
- # Get the index of the ref arm+ # Fill in missing formats with defaults |
||
| 136 | -2x | +249 | +10x |
- if (interaction_y != FALSE) {
+ default_fmts <- eval(formals(tabulate_survival_subgroups)$.formats) |
| 137 | -1x | +250 | +10x |
- y <- unlist(df[(df[[interaction_item]] == interaction_y), .var])+ .formats <- c(.formats, default_fmts[vars[!vars %in% names(.formats)]]) |
| 138 | +251 |
- # convert characters selected in interaction_y into the numeric order+ |
||
| 139 | -1x | +|||
| 252 | +
- interaction_y <- which(sum_fit_level[[interaction_item]] == interaction_y)+ # Extract additional parameters from df |
|||
| 140 | -1x | +253 | +10x |
- sum_fit_level <- sum_fit_level[interaction_y, ]+ conf_level <- df$hr$conf_level[1] |
| 141 | -+ | |||
| 254 | +10x |
- # if interaction is called, reset the index+ method <- df$hr$pval_label[1] |
||
| 142 | -1x | +255 | +10x |
- ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])])+ colvars <- d_survival_subgroups_colvars(vars, conf_level = conf_level, method = method, time_unit = time_unit) |
| 143 | -1x | +256 | +10x |
- ref_key <- tail(ref_key, n = 1)+ survtime_vars <- intersect(colvars$vars, c("n", "n_events", "median"))
|
| 144 | -1x | +257 | +10x |
- ref_key <- (interaction_y - 1) * length(unique(.df_row[[arm]])) + ref_key+ hr_vars <- intersect(names(colvars$labels), c("n_tot", "n_tot_events", "hr", "ci", "pval"))
|
| 145 | -+ | |||
| 258 | +10x |
- } else {
+ colvars_survtime <- list(vars = survtime_vars, labels = colvars$labels[survtime_vars]) |
||
| 146 | -1x | +259 | +10x |
- y <- df[[.var]]+ colvars_hr <- list(vars = hr_vars, labels = colvars$labels[hr_vars]) |
| 147 | +260 |
- # Get the index of the ref arm when interaction is not called+ |
||
| 148 | -1x | +261 | +10x |
- ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])])+ extra_args <- list(groups_lists = groups_lists, conf_level = conf_level, method = method) |
| 149 | -1x | +|||
| 262 | +
- ref_key <- tail(ref_key, n = 1)+ |
|||
| 150 | +263 |
- }+ # Get analysis function for each statistic+ |
+ ||
| 264 | +10x | +
+ afun_lst <- a_survival_subgroups(.formats = c(.formats, riskdiff = riskdiff$format), na_str = na_str) |
||
| 151 | +265 | |||
| 152 | -2x | +|||
| 266 | +
- if (.in_ref_col) {
+ # Add risk difference column |
|||
| 153 | -1x | +267 | +10x |
- list(+ if (!is.null(riskdiff)) {
|
| 154 | +268 | 1x |
- n = length(y[!is.na(y)]),+ if (is.null(riskdiff$arm_x)) riskdiff$arm_x <- levels(df$survtime$arm)[1] |
|
| 155 | +269 | 1x |
- lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"),+ if (is.null(riskdiff$arm_y)) riskdiff$arm_y <- levels(df$survtime$arm)[2] |
|
| 156 | +270 | 1x |
- lsmean_diff = formatters::with_label(character(), "Difference in Adjusted Means"),+ colvars_hr$vars <- c(colvars_hr$vars, "riskdiff") |
|
| 157 | +271 | 1x |
- lsmean_diff_ci = formatters::with_label(character(), f_conf_level(conf_level)),+ colvars_hr$labels <- c(colvars_hr$labels, riskdiff = riskdiff$col_label) |
|
| 158 | +272 | 1x |
- pval = formatters::with_label(character(), "p-value")+ arm_cols <- paste(rep(c("n_events", "n_events", "n", "n")), c(riskdiff$arm_x, riskdiff$arm_y), sep = "_")
|
|
| 159 | +273 |
- )+ |
||
| 160 | -+ | |||
| 274 | +1x |
- } else {
+ df_prop_diff <- df$survtime %>% |
||
| 161 | -+ | |||
| 275 | +1x |
- # Estimate the differences between the marginal means.+ dplyr::select(-"median") %>% |
||
| 162 | +276 | 1x |
- emmeans_contrasts <- emmeans::contrast(+ tidyr::pivot_wider( |
|
| 163 | +277 | 1x |
- emmeans_fit,+ id_cols = c("subgroup", "var", "var_label", "row_type"),
|
|
| 164 | -+ | |||
| 278 | +1x |
- # Compare all arms versus the control arm.+ names_from = "arm", |
||
| 165 | +279 | 1x |
- method = "trt.vs.ctrl",+ values_from = c("n", "n_events")
|
|
| 166 | +280 |
- # Take the arm factor from .ref_group as the control arm.+ ) %>% |
||
| 167 | +281 | 1x |
- ref = ref_key,+ dplyr::rowwise() %>% |
|
| 168 | +282 | 1x |
- level = conf_level+ dplyr::mutate( |
|
| 169 | -+ | |||
| 283 | +1x |
- )+ riskdiff = stat_propdiff_ci( |
||
| 170 | +284 | 1x |
- sum_contrasts <- summary(+ x = as.list(.data[[arm_cols[1]]]), |
|
| 171 | +285 | 1x |
- emmeans_contrasts,+ y = as.list(.data[[arm_cols[2]]]), |
|
| 172 | -+ | |||
| 286 | +1x |
- # Derive confidence intervals, t-tests and p-values.+ N_x = .data[[arm_cols[3]]], |
||
| 173 | +287 | 1x |
- infer = TRUE,+ N_y = .data[[arm_cols[4]]] |
|
| 174 | +288 |
- # Do not adjust the p-values for multiplicity.+ ) |
||
| 175 | -1x | +|||
| 289 | +
- adjust = "none"+ ) %>% |
|||
| 176 | -+ | |||
| 290 | +1x |
- )+ dplyr::select(-dplyr::all_of(arm_cols)) |
||
| 177 | +291 | |||
| 178 | +292 | 1x |
- contrast_lvls <- gsub(+ df$hr <- df$hr %>% |
|
| 179 | +293 | 1x |
- "^\\(|\\)$", "", gsub(paste0(" - \\(*", .ref_group[[arm]][1], ".*"), "", sum_contrasts$contrast)
+ dplyr::left_join( |
|
| 180 | -+ | |||
| 294 | +1x |
- )+ df_prop_diff, |
||
| 181 | +295 | 1x |
- if (!is.null(interaction_item)) {
+ by = c("subgroup", "var", "var_label", "row_type")
|
|
| 182 | -! | +|||
| 296 | +
- sum_contrasts_level <- sum_contrasts[grepl(sum_level, contrast_lvls, fixed = TRUE), ]+ ) |
|||
| 183 | +297 |
- } else {
+ } |
||
| 184 | -1x | +|||
| 298 | +
- sum_contrasts_level <- sum_contrasts[sum_level == contrast_lvls, ]+ |
|||
| 185 | +299 |
- }+ # Add columns from table_survtime (optional) |
||
| 186 | -1x | +300 | +10x |
- if (interaction_y != FALSE) {
+ if (length(colvars_survtime$vars) > 0) {
|
| 187 | -! | +|||
| 301 | +9x |
- sum_contrasts_level <- sum_contrasts_level[interaction_y, ]+ lyt_survtime <- split_cols_by(lyt = lyt, var = "arm") |
||
| 188 | -+ | |||
| 302 | +9x |
- }+ lyt_survtime <- split_rows_by( |
||
| 189 | -+ | |||
| 303 | +9x |
-
+ lyt = lyt_survtime, |
||
| 190 | -1x | +304 | +9x |
- list(+ var = "row_type", |
| 191 | -1x | +305 | +9x |
- n = length(y[!is.na(y)]),+ split_fun = keep_split_levels("content"),
|
| 192 | -1x | +306 | +9x |
- lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"),+ nested = FALSE |
| 193 | -1x | +|||
| 307 | +
- lsmean_diff = formatters::with_label(sum_contrasts_level$estimate, "Difference in Adjusted Means"),+ ) |
|||
| 194 | -1x | +|||
| 308 | +
- lsmean_diff_ci = formatters::with_label(+ + |
+ |||
| 309 | ++ |
+ # Add "All Patients" row |
||
| 195 | -1x | +310 | +9x |
- c(sum_contrasts_level$lower.CL, sum_contrasts_level$upper.CL),+ lyt_survtime <- summarize_row_groups( |
| 196 | -1x | +311 | +9x |
- f_conf_level(conf_level)+ lyt = lyt_survtime, |
| 197 | -+ | |||
| 312 | +9x |
- ),+ var = "var_label", |
||
| 198 | -1x | +313 | +9x |
- pval = formatters::with_label(sum_contrasts_level$p.value, "p-value")+ cfun = afun_lst[names(colvars_survtime$labels)], |
| 199 | -+ | |||
| 314 | +9x |
- )+ na_str = na_str, |
||
| 200 | -+ | |||
| 315 | +9x |
- }+ extra_args = extra_args |
||
| 201 | +316 |
- }+ ) |
||
| 202 | -+ | |||
| 317 | +9x |
-
+ lyt_survtime <- split_cols_by_multivar( |
||
| 203 | -+ | |||
| 318 | +9x |
- #' @describeIn summarize_ancova Formatted analysis function which is used as `afun` in `summarize_ancova()`.+ lyt = lyt_survtime, |
||
| 204 | -+ | |||
| 319 | +9x |
- #'+ vars = colvars_survtime$vars, |
||
| 205 | -+ | |||
| 320 | +9x |
- #' @return+ varlabels = colvars_survtime$labels |
||
| 206 | +321 |
- #' * `a_ancova()` returns the corresponding list with formatted [rtables::CellValue()].+ ) |
||
| 207 | +322 |
- #'+ |
||
| 208 | +323 |
- #' @keywords internal+ # Add analysis rows |
||
| 209 | -+ | |||
| 324 | +9x |
- a_ancova <- make_afun(+ if ("analysis" %in% df$survtime$row_type) {
|
||
| 210 | -+ | |||
| 325 | +8x |
- s_ancova,+ lyt_survtime <- split_rows_by( |
||
| 211 | -+ | |||
| 326 | +8x |
- .indent_mods = c("n" = 0L, "lsmean" = 0L, "lsmean_diff" = 0L, "lsmean_diff_ci" = 1L, "pval" = 1L),
+ lyt = lyt_survtime, |
||
| 212 | -+ | |||
| 327 | +8x |
- .formats = c(+ var = "row_type", |
||
| 213 | -+ | |||
| 328 | +8x |
- "n" = "xx",+ split_fun = keep_split_levels("analysis"),
|
||
| 214 | -+ | |||
| 329 | +8x |
- "lsmean" = "xx.xx",+ nested = FALSE, |
||
| 215 | -+ | |||
| 330 | +8x |
- "lsmean_diff" = "xx.xx",+ child_labels = "hidden" |
||
| 216 | +331 |
- "lsmean_diff_ci" = "(xx.xx, xx.xx)",+ ) |
||
| 217 | -+ | |||
| 332 | +8x |
- "pval" = "x.xxxx | (<0.0001)"+ lyt_survtime <- split_rows_by(lyt = lyt_survtime, var = "var_label", nested = TRUE) |
||
| 218 | -+ | |||
| 333 | +8x |
- ),+ lyt_survtime <- analyze_colvars( |
||
| 219 | -+ | |||
| 334 | +8x |
- .null_ref_cells = FALSE+ lyt = lyt_survtime, |
||
| 220 | -+ | |||
| 335 | +8x |
- )+ afun = afun_lst[names(colvars_survtime$labels)], |
||
| 221 | -+ | |||
| 336 | +8x |
-
+ na_str = na_str, |
||
| 222 | -+ | |||
| 337 | +8x |
- #' @describeIn summarize_ancova Layout-creating function which can take statistics function arguments+ inclNAs = TRUE, |
||
| 223 | -+ | |||
| 338 | +8x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ extra_args = extra_args |
||
| 224 | +339 |
- #'+ ) |
||
| 225 | +340 |
- #' @return+ } |
||
| 226 | +341 |
- #' * `summarize_ancova()` returns a layout object suitable for passing to further layouting functions,+ |
||
| 227 | -+ | |||
| 342 | +9x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ table_survtime <- build_table(lyt_survtime, df = df$survtime) |
||
| 228 | +343 |
- #' the statistics from `s_ancova()` to the table layout.+ } else {
|
||
| 229 | -+ | |||
| 344 | +1x |
- #'+ table_survtime <- NULL |
||
| 230 | +345 |
- #' @examples+ } |
||
| 231 | +346 |
- #' basic_table() %>%+ |
||
| 232 | +347 |
- #' split_cols_by("Species", ref_group = "setosa") %>%
+ # Add columns from table_hr ("n_tot_events" or "n_tot", "or" and "ci" required)
|
||
| 233 | -+ | |||
| 348 | +10x |
- #' add_colcounts() %>%+ lyt_hr <- split_cols_by(lyt = lyt, var = "arm") |
||
| 234 | -+ | |||
| 349 | +10x |
- #' summarize_ancova(+ lyt_hr <- split_rows_by( |
||
| 235 | -+ | |||
| 350 | +10x |
- #' vars = "Petal.Length",+ lyt = lyt_hr, |
||
| 236 | -+ | |||
| 351 | +10x |
- #' variables = list(arm = "Species", covariates = NULL),+ var = "row_type", |
||
| 237 | -+ | |||
| 352 | +10x |
- #' table_names = "unadj",+ split_fun = keep_split_levels("content"),
|
||
| 238 | -+ | |||
| 353 | +10x |
- #' conf_level = 0.95, var_labels = "Unadjusted comparison",+ nested = FALSE |
||
| 239 | +354 |
- #' .labels = c(lsmean = "Mean", lsmean_diff = "Difference in Means")+ ) |
||
| 240 | -+ | |||
| 355 | +10x |
- #' ) %>%+ lyt_hr <- summarize_row_groups( |
||
| 241 | -+ | |||
| 356 | +10x |
- #' summarize_ancova(+ lyt = lyt_hr, |
||
| 242 | -+ | |||
| 357 | +10x |
- #' vars = "Petal.Length",+ var = "var_label", |
||
| 243 | -+ | |||
| 358 | +10x |
- #' variables = list(arm = "Species", covariates = c("Sepal.Length", "Sepal.Width")),
+ cfun = afun_lst[names(colvars_hr$labels)], |
||
| 244 | -+ | |||
| 359 | +10x |
- #' table_names = "adj",+ na_str = na_str, |
||
| 245 | -+ | |||
| 360 | +10x |
- #' conf_level = 0.95, var_labels = "Adjusted comparison (covariates: Sepal.Length and Sepal.Width)"+ extra_args = extra_args |
||
| 246 | +361 |
- #' ) %>%+ ) |
||
| 247 | -+ | |||
| 362 | +10x |
- #' build_table(iris)+ lyt_hr <- split_cols_by_multivar( |
||
| 248 | -+ | |||
| 363 | +10x |
- #'+ lyt = lyt_hr, |
||
| 249 | -+ | |||
| 364 | +10x |
- #' @export+ vars = colvars_hr$vars, |
||
| 250 | -+ | |||
| 365 | +10x |
- #' @order 2+ varlabels = colvars_hr$labels |
||
| 251 | +366 |
- summarize_ancova <- function(lyt,+ ) %>% |
||
| 252 | -+ | |||
| 367 | +10x |
- vars,+ append_topleft("Baseline Risk Factors")
|
||
| 253 | +368 |
- variables,+ |
||
| 254 | +369 |
- conf_level,+ # Add analysis rows |
||
| 255 | -+ | |||
| 370 | +10x |
- interaction_y = FALSE,+ if ("analysis" %in% df$survtime$row_type) {
|
||
| 256 | -+ | |||
| 371 | +9x |
- interaction_item = NULL,+ lyt_hr <- split_rows_by( |
||
| 257 | -+ | |||
| 372 | +9x |
- var_labels,+ lyt = lyt_hr, |
||
| 258 | -+ | |||
| 373 | +9x |
- na_str = default_na_str(),+ var = "row_type", |
||
| 259 | -+ | |||
| 374 | +9x |
- nested = TRUE,+ split_fun = keep_split_levels("analysis"),
|
||
| 260 | -+ | |||
| 375 | +9x |
- ...,+ nested = FALSE, |
||
| 261 | -+ | |||
| 376 | +9x |
- show_labels = "visible",+ child_labels = "hidden" |
||
| 262 | +377 |
- table_names = vars,+ ) |
||
| 263 | -+ | |||
| 378 | +9x |
- .stats = NULL,+ lyt_hr <- split_rows_by(lyt = lyt_hr, var = "var_label", nested = TRUE) |
||
| 264 | -+ | |||
| 379 | +9x |
- .formats = NULL,+ lyt_hr <- analyze_colvars( |
||
| 265 | -+ | |||
| 380 | +9x |
- .labels = NULL,+ lyt = lyt_hr, |
||
| 266 | -+ | |||
| 381 | +9x |
- .indent_mods = NULL) {
+ afun = afun_lst[names(colvars_hr$labels)], |
||
| 267 | -7x | +382 | +9x |
- extra_args <- list(+ na_str = na_str, |
| 268 | -7x | +383 | +9x |
- variables = variables, conf_level = conf_level, interaction_y = interaction_y,+ inclNAs = TRUE, |
| 269 | -7x | +384 | +9x |
- interaction_item = interaction_item, ...+ extra_args = extra_args |
| 270 | +385 |
- )+ ) |
||
| 271 | +386 | ++ |
+ }+ |
+ |
| 387 | ||||
| 272 | -7x | +388 | +10x |
- afun <- make_afun(+ table_hr <- build_table(lyt_hr, df = df$hr) |
| 273 | -7x | +|||
| 389 | +
- a_ancova,+ |
|||
| 274 | -7x | +|||
| 390 | +
- interaction_y = interaction_y,+ # Join tables, add forest plot attributes |
|||
| 275 | -7x | +391 | +10x |
- interaction_item = interaction_item,+ n_tot_ids <- grep("^n_tot", colvars_hr$vars)
|
| 276 | -7x | +392 | +10x |
- .stats = .stats,+ if (is.null(table_survtime)) {
|
| 277 | -7x | +393 | +1x |
- .formats = .formats,+ result <- table_hr |
| 278 | -7x | +394 | +1x |
- .labels = .labels,+ hr_id <- match("hr", colvars_hr$vars)
|
| 279 | -7x | +395 | +1x |
- .indent_mods = .indent_mods+ ci_id <- match("ci", colvars_hr$vars)
|
| 280 | +396 |
- )+ } else {
|
||
| 281 | -+ | |||
| 397 | +9x |
-
+ result <- cbind_rtables(table_hr[, n_tot_ids], table_survtime, table_hr[, -n_tot_ids]) |
||
| 282 | -7x | +398 | +9x |
- analyze(+ hr_id <- length(n_tot_ids) + ncol(table_survtime) + match("hr", colvars_hr$vars[-n_tot_ids])
|
| 283 | -7x | +399 | +9x |
- lyt,+ ci_id <- length(n_tot_ids) + ncol(table_survtime) + match("ci", colvars_hr$vars[-n_tot_ids])
|
| 284 | -7x | +400 | +9x |
- vars,+ n_tot_ids <- seq_along(n_tot_ids) |
| 285 | -7x | +|||
| 401 | +
- var_labels = var_labels,+ } |
|||
| 286 | -7x | +402 | +10x |
- show_labels = show_labels,+ structure( |
| 287 | -7x | +403 | +10x |
- table_names = table_names,+ result, |
| 288 | -7x | +404 | +10x |
- afun = afun,+ forest_header = paste0(rev(levels(df$survtime$arm)), "\nBetter"), |
| 289 | -7x | +405 | +10x |
- na_str = na_str,+ col_x = hr_id, |
| 290 | -7x | +406 | +10x |
- nested = nested,+ col_ci = ci_id, |
| 291 | -7x | +407 | +10x |
- extra_args = extra_args+ col_symbol_size = n_tot_ids[1] # for scaling the symbol sizes in forest plots |
| 292 | +408 |
) |
||
| 293 | +409 |
} |
| 1 | -- |
- # Utility functions to cooperate with {rtables} package
- |
- ||
| 2 | +410 | |||
| 3 | +411 |
- #' Convert table into matrix of strings+ #' Labels for column variables in survival duration by subgroup table |
||
| 4 | +412 |
#' |
||
| 5 | +413 |
#' @description `r lifecycle::badge("stable")`
|
||
| 6 | +414 |
#' |
||
| 7 | +415 |
- #' Helper function to use mostly within tests. `with_spaces`parameter allows+ #' Internal function to check variables included in [tabulate_survival_subgroups()] and create column labels. |
||
| 8 | +416 |
- #' to test not only for content but also indentation and table structure.+ #' |
||
| 9 | +417 |
- #' `print_txt_to_copy` instead facilitate the testing development by returning a well+ #' @inheritParams tabulate_survival_subgroups |
||
| 10 | +418 |
- #' formatted text that needs only to be copied and pasted in the expected output.+ #' @inheritParams argument_convention |
||
| 11 | +419 |
- #'+ #' @param method (`string`)\cr p-value method for testing hazard ratio = 1. |
||
| 12 | +420 |
- #' @inheritParams formatters::toString+ #' |
||
| 13 | +421 |
- #' @param x (`VTableTree`)\cr `rtables` table object.+ #' @return A `list` of variables and their labels to tabulate. |
||
| 14 | +422 |
- #' @param with_spaces (`flag`)\cr whether the tested table should keep the indentation and other relevant spaces.+ #' |
||
| 15 | +423 |
- #' @param print_txt_to_copy (`flag`)\cr utility to have a way to copy the input table directly+ #' @note At least one of `n_tot` and `n_tot_events` must be provided in `vars`. |
||
| 16 | +424 |
- #' into the expected variable instead of copying it too manually.+ #' |
||
| 17 | +425 |
- #'+ #' @export |
||
| 18 | +426 |
- #' @return A `matrix` of `string`s. If `print_txt_to_copy = TRUE` the well formatted printout of the+ d_survival_subgroups_colvars <- function(vars, |
||
| 19 | +427 |
- #' table will be printed to console, ready to be copied as a expected value.+ conf_level, |
||
| 20 | +428 |
- #'+ method, |
||
| 21 | +429 |
- #' @examples+ time_unit = NULL) {
|
||
| 22 | -+ | |||
| 430 | +21x |
- #' tbl <- basic_table() %>%+ checkmate::assert_character(vars) |
||
| 23 | -+ | |||
| 431 | +21x |
- #' split_rows_by("SEX") %>%
+ checkmate::assert_string(time_unit, null.ok = TRUE) |
||
| 24 | -+ | |||
| 432 | +21x |
- #' split_cols_by("ARM") %>%
+ checkmate::assert_subset(c("hr", "ci"), vars)
|
||
| 25 | -+ | |||
| 433 | +21x |
- #' analyze("AGE") %>%
+ checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
|
||
| 26 | -+ | |||
| 434 | +21x |
- #' build_table(tern_ex_adsl)+ checkmate::assert_subset( |
||
| 27 | -+ | |||
| 435 | +21x |
- #'+ vars, |
||
| 28 | -+ | |||
| 436 | +21x |
- #' to_string_matrix(tbl, widths = ceiling(propose_column_widths(tbl) / 2))+ c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
|
||
| 29 | +437 |
- #'+ ) |
||
| 30 | +438 |
- #' @export+ |
||
| 31 | -+ | |||
| 439 | +21x |
- to_string_matrix <- function(x, widths = NULL, max_width = NULL,+ propcase_time_label <- if (!is.null(time_unit)) {
|
||
| 32 | -+ | |||
| 440 | +20x |
- hsep = formatters::default_hsep(),+ paste0("Median (", time_unit, ")")
|
||
| 33 | +441 |
- with_spaces = TRUE, print_txt_to_copy = FALSE) {
- |
- ||
| 34 | -11x | -
- checkmate::assert_flag(with_spaces)+ } else {
|
||
| 35 | -11x | +442 | +1x |
- checkmate::assert_flag(print_txt_to_copy)+ "Median" |
| 36 | -11x | +|||
| 443 | +
- checkmate::assert_int(max_width, null.ok = TRUE)+ } |
|||
| 37 | +444 | |||
| 38 | -11x | +445 | +21x |
- if (inherits(x, "MatrixPrintForm")) {
+ varlabels <- c( |
| 39 | -! | +|||
| 446 | +21x |
- tx <- x+ n = "n", |
||
| 40 | -+ | |||
| 447 | +21x |
- } else {
+ n_events = "Events", |
||
| 41 | -11x | +448 | +21x |
- tx <- matrix_form(x, TRUE)+ median = propcase_time_label, |
| 42 | -+ | |||
| 449 | +21x |
- }+ n_tot = "Total n", |
||
| 43 | -+ | |||
| 450 | +21x |
-
+ n_tot_events = "Total Events", |
||
| 44 | -11x | +451 | +21x |
- tf_wrap <- FALSE+ hr = "Hazard Ratio", |
| 45 | -11x | +452 | +21x |
- if (!is.null(max_width)) {
+ ci = paste0(100 * conf_level, "% Wald CI"), |
| 46 | -! | +|||
| 453 | +21x |
- tf_wrap <- TRUE+ pval = method |
||
| 47 | +454 |
- }+ ) |
||
| 48 | +455 | |||
| 49 | -- |
- # Producing the matrix to test- |
- ||
| 50 | -11x | +456 | +21x |
- if (with_spaces) {
+ colvars <- vars |
| 51 | -2x | +|||
| 457 | +
- out <- strsplit(toString(tx, widths = widths, tf_wrap = tf_wrap, max_width = max_width, hsep = hsep), "\n")[[1]]+ |
|||
| 52 | +458 |
- } else {
+ # The `lcl` variable is just a placeholder available in the analysis data, |
||
| 53 | -9x | +|||
| 459 | +
- out <- tx$strings+ # it is not acutally used in the tabulation. |
|||
| 54 | +460 |
- }+ # Variables used in the tabulation are lcl and ucl, see `a_survival_subgroups` for details. |
||
| 55 | -+ | |||
| 461 | +21x |
-
+ colvars[colvars == "ci"] <- "lcl" |
||
| 56 | +462 |
- # Printing to console formatted output that needs to be copied in "expected"+ |
||
| 57 | -11x | +463 | +21x |
- if (print_txt_to_copy) {
+ list( |
| 58 | -2x | +464 | +21x |
- out_tmp <- out+ vars = colvars, |
| 59 | -2x | +465 | +21x |
- if (!with_spaces) {
+ labels = varlabels[vars] |
| 60 | -1x | +|||
| 466 | +
- out_tmp <- apply(out, 1, paste0, collapse = '", "')+ ) |
|||
| 61 | +467 |
- }+ } |
||
| 62 | -2x | +
| 1 | +
- cat(paste0('c(\n "', paste0(out_tmp, collapse = '",\n "'), '"\n)'))
+ #' Estimate proportions of each level of a variable |
|||
| 63 | +2 |
- }+ #' |
||
| 64 | +3 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 65 | +4 |
- # Return values+ #' |
||
| 66 | -11x | +|||
| 5 | +
- return(out)+ #' The analyze & summarize function [estimate_multinomial_response()] creates a layout element to estimate the |
|||
| 67 | +6 |
- }+ #' proportion and proportion confidence interval for each level of a factor variable. The primary analysis variable, |
||
| 68 | +7 |
-
+ #' `var`, should be a factor variable, the values of which will be used as labels within the output table. |
||
| 69 | +8 |
- #' Blank for missing input+ #' |
||
| 70 | +9 |
- #'+ #' @inheritParams argument_convention |
||
| 71 | +10 |
- #' Helper function to use in tabulating model results.+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_multinomial_response")`
|
||
| 72 | +11 |
- #'+ #' to see available statistics for this function. |
||
| 73 | +12 |
- #' @param x (`vector`)\cr input for a cell.+ #' |
||
| 74 | +13 |
- #'+ #' @seealso Relevant description function [d_onco_rsp_label()]. |
||
| 75 | +14 |
- #' @return An empty `character` vector if all entries in `x` are missing (`NA`), otherwise+ #' |
||
| 76 | +15 |
- #' the unlisted version of `x`.+ #' @name estimate_multinomial_rsp |
||
| 77 | +16 |
- #'+ #' @order 1 |
||
| 78 | +17 |
- #' @keywords internal+ NULL |
||
| 79 | +18 |
- unlist_and_blank_na <- function(x) {
+
|
||
| 80 | -267x | +|||
| 19 | +
- unl <- unlist(x)+ #' Description of standard oncology response |
|||
| 81 | -267x | +|||
| 20 | +
- if (all(is.na(unl))) {
+ #' |
|||
| 82 | -161x | +|||
| 21 | +
- character()+ #' @description `r lifecycle::badge("stable")`
|
|||
| 83 | +22 |
- } else {
+ #' |
||
| 84 | -106x | +|||
| 23 | +
- unl+ #' Describe the oncology response in a standard way. |
|||
| 85 | +24 |
- }+ #' |
||
| 86 | +25 |
- }+ #' @param x (`character`)\cr the standard oncology codes to be described. |
||
| 87 | +26 |
-
+ #' |
||
| 88 | +27 |
- #' Constructor for content functions given a data frame with flag input+ #' @return Response labels. |
||
| 89 | +28 |
#' |
||
| 90 | +29 |
- #' This can be useful for tabulating model results.+ #' @seealso [estimate_multinomial_rsp()] |
||
| 91 | +30 |
#' |
||
| 92 | +31 |
- #' @param analysis_var (`string`)\cr variable name for the column containing values to be returned by the+ #' @examples |
||
| 93 | +32 |
- #' content function.+ #' d_onco_rsp_label( |
||
| 94 | +33 |
- #' @param flag_var (`string`)\cr variable name for the logical column identifying which row should be returned.+ #' c("CR", "PR", "SD", "NON CR/PD", "PD", "NE", "Missing", "<Missing>", "NE/Missing")
|
||
| 95 | +34 |
- #' @param format (`string`)\cr `rtables` format to use.+ #' ) |
||
| 96 | +35 |
#' |
||
| 97 | +36 |
- #' @return A content function which gives `df$analysis_var` at the row identified by+ #' # Adding some values not considered in d_onco_rsp_label |
||
| 98 | +37 |
- #' `.df_row$flag` in the given format.+ #' |
||
| 99 | +38 |
- #'+ #' d_onco_rsp_label( |
||
| 100 | +39 |
- #' @keywords internal+ #' c("CR", "PR", "hello", "hi")
|
||
| 101 | +40 |
- cfun_by_flag <- function(analysis_var,+ #' ) |
||
| 102 | +41 |
- flag_var,+ #' |
||
| 103 | +42 |
- format = "xx",+ #' @export |
||
| 104 | +43 |
- .indent_mods = NULL) {
+ d_onco_rsp_label <- function(x) {
|
||
| 105 | -61x | +44 | +2x |
- checkmate::assert_string(analysis_var)+ x <- as.character(x) |
| 106 | -61x | +45 | +2x |
- checkmate::assert_string(flag_var)+ desc <- c( |
| 107 | -61x | +46 | +2x |
- function(df, labelstr) {
+ CR = "Complete Response (CR)", |
| 108 | -265x | +47 | +2x |
- row_index <- which(df[[flag_var]])+ PR = "Partial Response (PR)", |
| 109 | -265x | +48 | +2x |
- x <- unlist_and_blank_na(df[[analysis_var]][row_index])+ MR = "Minimal/Minor Response (MR)", |
| 110 | -265x | +49 | +2x |
- formatters::with_label(+ MRD = "Minimal Residual Disease (MRD)", |
| 111 | -265x | +50 | +2x |
- rcell(x, format = format, indent_mod = .indent_mods),+ SD = "Stable Disease (SD)", |
| 112 | -265x | +51 | +2x |
- labelstr+ PD = "Progressive Disease (PD)", |
| 113 | -+ | |||
| 52 | +2x |
- )+ `NON CR/PD` = "Non-CR or Non-PD (NON CR/PD)", |
||
| 114 | -+ | |||
| 53 | +2x |
- }+ NE = "Not Evaluable (NE)", |
||
| 115 | -+ | |||
| 54 | +2x |
- }+ `NE/Missing` = "Missing or unevaluable", |
||
| 116 | -+ | |||
| 55 | +2x |
-
+ Missing = "Missing", |
||
| 117 | -+ | |||
| 56 | +2x |
- #' Content row function to add row total to labels+ `NA` = "Not Applicable (NA)", |
||
| 118 | -+ | |||
| 57 | +2x |
- #'+ ND = "Not Done (ND)" |
||
| 119 | +58 |
- #' This takes the label of the latest row split level and adds the row total from `df` in parentheses.+ ) |
||
| 120 | +59 |
- #' This function differs from [c_label_n_alt()] by taking row counts from `df` rather than+ |
||
| 121 | -+ | |||
| 60 | +2x |
- #' `alt_counts_df`, and is used by [add_rowcounts()] when `alt_counts` is set to `FALSE`.+ values_label <- vapply( |
||
| 122 | -+ | |||
| 61 | +2x |
- #'+ X = x, |
||
| 123 | -+ | |||
| 62 | +2x |
- #' @inheritParams argument_convention+ FUN.VALUE = character(1), |
||
| 124 | -+ | |||
| 63 | +2x |
- #'+ function(val) {
|
||
| 125 | -+ | |||
| 64 | +! |
- #' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label.+ if (val %in% names(desc)) desc[val] else val |
||
| 126 | +65 |
- #'+ } |
||
| 127 | +66 |
- #' @note It is important here to not use `df` but rather `.N_row` in the implementation, because+ ) |
||
| 128 | +67 |
- #' the former is already split by columns and will refer to the first column of the data only.+ |
||
| 129 | -+ | |||
| 68 | +2x |
- #'+ return(factor(values_label, levels = c(intersect(desc, values_label), setdiff(values_label, desc)))) |
||
| 130 | +69 |
- #' @seealso [c_label_n_alt()] which performs the same function but retrieves row counts from+ } |
||
| 131 | +70 |
- #' `alt_counts_df` instead of `df`.+ |
||
| 132 | +71 |
- #'+ #' @describeIn estimate_multinomial_rsp Statistics function which feeds the length of `x` as number |
||
| 133 | +72 |
- #' @keywords internal+ #' of successes, and `.N_col` as total number of successes and failures into [s_proportion()]. |
||
| 134 | +73 |
- c_label_n <- function(df,+ #' |
||
| 135 | +74 |
- labelstr,+ #' @return |
||
| 136 | +75 |
- .N_row) { # nolint
- |
- ||
| 137 | -273x | -
- label <- paste0(labelstr, " (N=", .N_row, ")")- |
- ||
| 138 | -273x | -
- in_rows(- |
- ||
| 139 | -273x | -
- .list = list(row_count = formatters::with_label(c(.N_row, .N_row), label)),- |
- ||
| 140 | -273x | -
- .formats = c(row_count = function(x, ...) "")+ #' * `s_length_proportion()` returns statistics from [s_proportion()]. |
||
| 141 | +76 |
- )+ #' |
||
| 142 | +77 |
- }+ #' @examples |
||
| 143 | +78 |
-
+ #' s_length_proportion(rep("CR", 10), .N_col = 100)
|
||
| 144 | +79 |
- #' Content row function to add `alt_counts_df` row total to labels+ #' s_length_proportion(factor(character(0)), .N_col = 100) |
||
| 145 | +80 |
#' |
||
| 146 | +81 |
- #' This takes the label of the latest row split level and adds the row total from `alt_counts_df`+ #' @export |
||
| 147 | +82 |
- #' in parentheses. This function differs from [c_label_n()] by taking row counts from `alt_counts_df`+ s_length_proportion <- function(x, |
||
| 148 | +83 |
- #' rather than `df`, and is used by [add_rowcounts()] when `alt_counts` is set to `TRUE`.+ .N_col, # nolint |
||
| 149 | +84 |
- #'+ ...) {
|
||
| 150 | -+ | |||
| 85 | +4x |
- #' @inheritParams argument_convention+ checkmate::assert_multi_class(x, classes = c("factor", "character"))
|
||
| 151 | -+ | |||
| 86 | +3x |
- #'+ checkmate::assert_vector(x, min.len = 0, max.len = .N_col) |
||
| 152 | -+ | |||
| 87 | +2x |
- #' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label.+ checkmate::assert_vector(unique(x), min.len = 0, max.len = 1) |
||
| 153 | +88 |
- #'+ |
||
| 154 | -+ | |||
| 89 | +1x |
- #' @seealso [c_label_n()] which performs the same function but retrieves row counts from `df` instead+ n_true <- length(x) |
||
| 155 | -+ | |||
| 90 | +1x |
- #' of `alt_counts_df`.+ n_false <- .N_col - n_true |
||
| 156 | -+ | |||
| 91 | +1x |
- #'+ x_logical <- rep(c(TRUE, FALSE), c(n_true, n_false)) |
||
| 157 | -+ | |||
| 92 | +1x |
- #' @keywords internal+ s_proportion(df = x_logical, ...) |
||
| 158 | +93 |
- c_label_n_alt <- function(df,+ } |
||
| 159 | +94 |
- labelstr,+ |
||
| 160 | +95 |
- .alt_df_row) {
- |
- ||
| 161 | -7x | -
- N_row_alt <- nrow(.alt_df_row) # nolint- |
- ||
| 162 | -7x | -
- label <- paste0(labelstr, " (N=", N_row_alt, ")")- |
- ||
| 163 | -7x | -
- in_rows(- |
- ||
| 164 | -7x | -
- .list = list(row_count = formatters::with_label(c(N_row_alt, N_row_alt), label)),+ #' @describeIn estimate_multinomial_rsp Formatted analysis function which is used as `afun` |
||
| 165 | -7x | +|||
| 96 | +
- .formats = c(row_count = function(x, ...) "")+ #' in `estimate_multinomial_response()`. |
|||
| 166 | +97 |
- )+ #' |
||
| 167 | +98 |
- }+ #' @return |
||
| 168 | +99 |
-
+ #' * `a_length_proportion()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 169 | +100 |
- #' Layout-creating function to add row total counts+ #' |
||
| 170 | +101 |
- #'+ #' @examples |
||
| 171 | +102 |
- #' @description `r lifecycle::badge("stable")`
+ #' a_length_proportion(rep("CR", 10), .N_col = 100)
|
||
| 172 | +103 |
- #'+ #' a_length_proportion(factor(character(0)), .N_col = 100) |
||
| 173 | +104 |
- #' This works analogously to [rtables::add_colcounts()] but on the rows. This function+ #' |
||
| 174 | +105 |
- #' is a wrapper for [rtables::summarize_row_groups()].+ #' @export |
||
| 175 | +106 |
- #'+ a_length_proportion <- make_afun( |
||
| 176 | +107 |
- #' @inheritParams argument_convention+ s_length_proportion, |
||
| 177 | +108 |
- #' @param alt_counts (`flag`)\cr whether row counts should be taken from `alt_counts_df` (`TRUE`)+ .formats = c( |
||
| 178 | +109 |
- #' or from `df` (`FALSE`). Defaults to `FALSE`.+ n_prop = "xx (xx.x%)", |
||
| 179 | +110 |
- #'+ prop_ci = "(xx.xx, xx.xx)" |
||
| 180 | +111 |
- #' @return A modified layout where the latest row split labels now have the row-wise+ ) |
||
| 181 | +112 |
- #' total counts (i.e. without column-based subsetting) attached in parentheses.+ ) |
||
| 182 | +113 |
- #'+ |
||
| 183 | +114 |
- #' @note Row count values are contained in these row count rows but are not displayed+ #' @describeIn estimate_multinomial_rsp Layout-creating function which can take statistics function arguments |
||
| 184 | +115 |
- #' so that they are not considered zero rows by default when pruning.+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()] and |
||
| 185 | +116 |
- #'+ #' [rtables::summarize_row_groups()]. |
||
| 186 | +117 |
- #' @examples+ #' |
||
| 187 | +118 |
- #' basic_table() %>%+ #' @return |
||
| 188 | +119 |
- #' split_cols_by("ARM") %>%
+ #' * `estimate_multinomial_response()` returns a layout object suitable for passing to further layouting functions, |
||
| 189 | +120 |
- #' add_colcounts() %>%+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 190 | +121 |
- #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
+ #' the statistics from `s_length_proportion()` to the table layout. |
||
| 191 | +122 |
- #' add_rowcounts() %>%+ #' |
||
| 192 | +123 |
- #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>%
+ #' @examples |
||
| 193 | +124 |
- #' build_table(DM)+ #' library(dplyr) |
||
| 194 | +125 |
#' |
||
| 195 | +126 |
- #' @export+ #' # Use of the layout creating function. |
||
| 196 | +127 |
- add_rowcounts <- function(lyt, alt_counts = FALSE) {
+ #' dta_test <- data.frame( |
||
| 197 | -7x | +|||
| 128 | +
- summarize_row_groups(+ #' USUBJID = paste0("S", 1:12),
|
|||
| 198 | -7x | +|||
| 129 | +
- lyt,+ #' ARM = factor(rep(LETTERS[1:3], each = 4)), |
|||
| 199 | -7x | +|||
| 130 | +
- cfun = if (alt_counts) c_label_n_alt else c_label_n+ #' AVAL = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0)) |
|||
| 200 | +131 |
- )+ #' ) %>% mutate( |
||
| 201 | +132 |
- }+ #' AVALC = factor(AVAL, |
||
| 202 | +133 |
-
+ #' levels = c(0, 1), |
||
| 203 | +134 |
- #' Obtain column indices+ #' labels = c("Complete Response (CR)", "Partial Response (PR)")
|
||
| 204 | +135 |
- #'+ #' ) |
||
| 205 | +136 |
- #' @description `r lifecycle::badge("stable")`
+ #' ) |
||
| 206 | +137 |
#' |
||
| 207 | +138 |
- #' Helper function to extract column indices from a `VTableTree` for a given+ #' lyt <- basic_table() %>% |
||
| 208 | +139 |
- #' vector of column names.+ #' split_cols_by("ARM") %>%
|
||
| 209 | +140 |
- #'+ #' estimate_multinomial_response(var = "AVALC") |
||
| 210 | +141 |
- #' @param table_tree (`VTableTree`)\cr `rtables` table object to extract the indices from.+ #' |
||
| 211 | +142 |
- #' @param col_names (`character`)\cr vector of column names.+ #' tbl <- build_table(lyt, dta_test) |
||
| 212 | +143 |
#' |
||
| 213 | +144 |
- #' @return A vector of column indices.+ #' tbl |
||
| 214 | +145 |
#' |
||
| 215 | +146 |
#' @export |
||
| 216 | +147 |
- h_col_indices <- function(table_tree, col_names) {
- |
- ||
| 217 | -1256x | -
- checkmate::assert_class(table_tree, "VTableNodeInfo")- |
- ||
| 218 | -1256x | -
- checkmate::assert_subset(col_names, names(attr(col_info(table_tree), "cextra_args")), empty.ok = FALSE)- |
- ||
| 219 | -1256x | -
- match(col_names, names(attr(col_info(table_tree), "cextra_args")))+ #' @order 2 |
||
| 220 | +148 |
- }+ estimate_multinomial_response <- function(lyt, |
||
| 221 | +149 |
-
+ var, |
||
| 222 | +150 |
- #' Labels or names of list elements+ na_str = default_na_str(), |
||
| 223 | +151 |
- #'+ nested = TRUE, |
||
| 224 | +152 |
- #' Internal helper function for working with nested statistic function results which typically+ ..., |
||
| 225 | +153 |
- #' don't have labels but names that we can use.+ show_labels = "hidden", |
||
| 226 | +154 |
- #'+ table_names = var, |
||
| 227 | +155 |
- #' @param x (`list`)\cr a list.+ .stats = "prop_ci", |
||
| 228 | +156 |
- #'+ .formats = NULL, |
||
| 229 | +157 |
- #' @return A `character` vector with the labels or names for the list elements.+ .labels = NULL, |
||
| 230 | +158 |
- #'+ .indent_mods = NULL) {
|
||
| 231 | -+ | |||
| 159 | +1x |
- #' @keywords internal+ extra_args <- list(...) |
||
| 232 | +160 |
- labels_or_names <- function(x) {
+
|
||
| 233 | -190x | +161 | +1x |
- checkmate::assert_multi_class(x, c("data.frame", "list"))
+ afun <- make_afun( |
| 234 | -190x | +162 | +1x |
- labs <- sapply(x, obj_label)+ a_length_proportion, |
| 235 | -190x | +163 | +1x |
- nams <- rlang::names2(x)+ .stats = .stats, |
| 236 | -190x | +164 | +1x |
- label_is_null <- sapply(labs, is.null)+ .formats = .formats, |
| 237 | -190x | +165 | +1x |
- result <- unlist(ifelse(label_is_null, nams, labs))+ .labels = .labels, |
| 238 | -190x | +166 | +1x |
- return(result)+ .indent_mods = .indent_mods |
| 239 | +167 |
- }+ )+ |
+ ||
| 168 | +1x | +
+ lyt <- split_rows_by(lyt, var = var)+ |
+ ||
| 169 | +1x | +
+ lyt <- summarize_row_groups(lyt, na_str = na_str) |
||
| 240 | +170 | |||
| 241 | -+ | |||
| 171 | +1x |
- #' Convert to `rtable`+ analyze( |
||
| 242 | -+ | |||
| 172 | +1x |
- #'+ lyt, |
||
| 243 | -+ | |||
| 173 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ vars = var, |
||
| 244 | -+ | |||
| 174 | +1x |
- #'+ afun = afun, |
||
| 245 | -+ | |||
| 175 | +1x |
- #' This is a new generic function to convert objects to `rtable` tables.+ show_labels = show_labels, |
||
| 246 | -+ | |||
| 176 | +1x |
- #'+ table_names = table_names, |
||
| 247 | -+ | |||
| 177 | +1x |
- #' @param x (`data.frame`)\cr the object which should be converted to an `rtable`.+ na_str = na_str,+ |
+ ||
| 178 | +1x | +
+ nested = nested,+ |
+ ||
| 179 | +1x | +
+ extra_args = extra_args |
||
| 248 | +180 |
- #' @param ... additional arguments for methods.+ ) |
||
| 249 | +181 |
- #'+ } |
| 250 | +1 |
- #' @return An `rtables` table object. Note that the concrete class will depend on the method used.+ #' Helper functions for incidence rate |
||
| 251 | +2 |
#' |
||
| 252 | +3 |
- #' @export+ #' @description `r lifecycle::badge("stable")`
|
||
| 253 | +4 |
- as.rtable <- function(x, ...) { # nolint
+ #' |
||
| 254 | -3x | +|||
| 5 | +
- UseMethod("as.rtable", x)
+ #' @param control (`list`)\cr parameters for estimation details, specified by using |
|||
| 255 | +6 |
- }+ #' the helper function [control_incidence_rate()]. Possible parameter options are: |
||
| 256 | +7 |
-
+ #' * `conf_level`: (`proportion`)\cr confidence level for the estimated incidence rate. |
||
| 257 | +8 |
- #' @describeIn as.rtable Method for converting a `data.frame` that contains numeric columns to `rtable`.+ #' * `conf_type`: (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar` |
||
| 258 | +9 |
- #'+ #' for confidence interval type. |
||
| 259 | +10 |
- #' @param format (`string` or `function`)\cr the format which should be used for the columns.+ #' * `input_time_unit`: (`string`)\cr `day`, `week`, `month`, or `year` (default) |
||
| 260 | +11 |
- #'+ #' indicating time unit for data input. |
||
| 261 | +12 |
- #' @method as.rtable data.frame+ #' * `num_pt_year`: (`numeric`)\cr time unit for desired output (in person-years). |
||
| 262 | +13 |
- #'+ #' @param person_years (`numeric(1)`)\cr total person-years at risk. |
||
| 263 | +14 |
- #' @examples+ #' @param alpha (`numeric(1)`)\cr two-sided alpha-level for confidence interval. |
||
| 264 | +15 |
- #' x <- data.frame(+ #' @param n_events (`integer(1)`)\cr number of events observed. |
||
| 265 | +16 |
- #' a = 1:10,+ #' |
||
| 266 | +17 |
- #' b = rnorm(10)+ #' @return Estimated incidence rate, `rate`, and associated confidence interval, `rate_ci`. |
||
| 267 | +18 |
- #' )+ #' |
||
| 268 | +19 |
- #' as.rtable(x)+ #' @seealso [incidence_rate] |
||
| 269 | +20 |
#' |
||
| 270 | +21 |
- #' @export+ #' @name h_incidence_rate |
||
| 271 | +22 |
- as.rtable.data.frame <- function(x, format = "xx.xx", ...) {
+ NULL |
||
| 272 | -3x | +|||
| 23 | +
- checkmate::assert_numeric(unlist(x))+ |
|||
| 273 | -2x | +|||
| 24 | +
- do.call(+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
|||
| 274 | -2x | +|||
| 25 | +
- rtable,+ #' associated confidence interval. |
|||
| 275 | -2x | +|||
| 26 | +
- c(+ #' |
|||
| 276 | -2x | +|||
| 27 | +
- list(+ #' @keywords internal |
|||
| 277 | -2x | +|||
| 28 | +
- header = labels_or_names(x),+ h_incidence_rate <- function(person_years, |
|||
| 278 | -2x | +|||
| 29 | +
- format = format+ n_events, |
|||
| 279 | +30 |
- ),+ control = control_incidence_rate()) {
|
||
| 280 | -2x | +31 | +18x |
- Map(+ alpha <- 1 - control$conf_level |
| 281 | -2x | +32 | +18x |
- function(row, row_name) {
+ est <- switch(control$conf_type, |
| 282 | -20x | +33 | +18x |
- do.call(+ normal = h_incidence_rate_normal(person_years, n_events, alpha), |
| 283 | -20x | +34 | +18x |
- rrow,+ normal_log = h_incidence_rate_normal_log(person_years, n_events, alpha), |
| 284 | -20x | +35 | +18x |
- c(as.list(unname(row)),+ exact = h_incidence_rate_exact(person_years, n_events, alpha), |
| 285 | -20x | -
- row.name = row_name- |
- ||
| 286 | -+ | 36 | +18x |
- )+ byar = h_incidence_rate_byar(person_years, n_events, alpha) |
| 287 | +37 |
- )+ ) |
||
| 288 | +38 |
- },+ |
||
| 289 | -2x | +39 | +18x |
- row = as.data.frame(t(x)),+ num_pt_year <- control$num_pt_year |
| 290 | -2x | +40 | +18x |
- row_name = rownames(x)+ list( |
| 291 | -+ | |||
| 41 | +18x |
- )+ rate = est$rate * num_pt_year, |
||
| 292 | -+ | |||
| 42 | +18x |
- )+ rate_ci = est$rate_ci * num_pt_year |
||
| 293 | +43 |
) |
||
| 294 | +44 |
} |
||
| 295 | +45 | |||
| 296 | +46 |
- #' Split parameters+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
||
| 297 | +47 |
- #'+ #' associated confidence interval based on the normal approximation for the |
||
| 298 | +48 |
- #' @description `r lifecycle::badge("stable")`
+ #' incidence rate. Unit is one person-year. |
||
| 299 | +49 |
#' |
||
| 300 | -- |
- #' It divides the data in the vector `param` into the groups defined by `f` based on specified `values`. It is relevant- |
- ||
| 301 | +50 |
- #' in `rtables` layers so as to distribute parameters `.stats` or' `.formats` into lists with items corresponding to+ #' @examples |
||
| 302 | +51 |
- #' specific analysis function.+ #' h_incidence_rate_normal(200, 2) |
||
| 303 | +52 |
#' |
||
| 304 | -- |
- #' @param param (`vector`)\cr the parameter to be split.- |
- ||
| 305 | -- |
- #' @param value (`vector`)\cr the value used to split.- |
- ||
| 306 | +53 |
- #' @param f (`list`)\cr the reference to make the split.+ #' @export |
||
| 307 | +54 |
- #'+ h_incidence_rate_normal <- function(person_years, |
||
| 308 | +55 |
- #' @return A named `list` with the same element names as `f`, each containing the elements specified in `.stats`.+ n_events, |
||
| 309 | +56 |
- #'+ alpha = 0.05) {
|
||
| 310 | -+ | |||
| 57 | +14x |
- #' @examples+ checkmate::assert_number(person_years) |
||
| 311 | -+ | |||
| 58 | +14x |
- #' f <- list(+ checkmate::assert_number(n_events) |
||
| 312 | -+ | |||
| 59 | +14x |
- #' surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
+ assert_proportion_value(alpha) |
||
| 313 | +60 |
- #' surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
+
|
||
| 314 | -+ | |||
| 61 | +14x |
- #' )+ est <- n_events / person_years |
||
| 315 | -+ | |||
| 62 | +14x |
- #'+ se <- sqrt(est / person_years) |
||
| 316 | -+ | |||
| 63 | +14x |
- #' .stats <- c("pt_at_risk", "rate_diff")
+ ci <- est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * se |
||
| 317 | +64 |
- #' h_split_param(.stats, .stats, f = f)+ |
||
| 318 | -+ | |||
| 65 | +14x |
- #'+ list(rate = est, rate_ci = ci) |
||
| 319 | +66 |
- #' # $surv+ } |
||
| 320 | +67 |
- #' # [1] "pt_at_risk"+ |
||
| 321 | +68 |
- #' #+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
||
| 322 | +69 |
- #' # $surv_diff+ #' associated confidence interval based on the normal approximation for the |
||
| 323 | +70 |
- #' # [1] "rate_diff"+ #' logarithm of the incidence rate. Unit is one person-year. |
||
| 324 | +71 |
#' |
||
| 325 | +72 |
- #' .formats <- c("pt_at_risk" = "xx", "event_free_rate" = "xxx")
+ #' @examples |
||
| 326 | +73 |
- #' h_split_param(.formats, names(.formats), f = f)+ #' h_incidence_rate_normal_log(200, 2) |
||
| 327 | +74 |
#' |
||
| 328 | +75 |
- #' # $surv+ #' @export |
||
| 329 | +76 |
- #' # pt_at_risk event_free_rate+ h_incidence_rate_normal_log <- function(person_years, |
||
| 330 | +77 |
- #' # "xx" "xxx"+ n_events, |
||
| 331 | +78 |
- #' #+ alpha = 0.05) {
|
||
| 332 | -+ | |||
| 79 | +6x |
- #' # $surv_diff+ checkmate::assert_number(person_years) |
||
| 333 | -+ | |||
| 80 | +6x |
- #' # NULL+ checkmate::assert_number(n_events) |
||
| 334 | -+ | |||
| 81 | +6x |
- #'+ assert_proportion_value(alpha) |
||
| 335 | +82 |
- #' @export+ |
||
| 336 | -+ | |||
| 83 | +6x |
- h_split_param <- function(param,+ rate_est <- n_events / person_years |
||
| 337 | -+ | |||
| 84 | +6x |
- value,+ rate_se <- sqrt(rate_est / person_years) |
||
| 338 | -+ | |||
| 85 | +6x |
- f) {
+ lrate_est <- log(rate_est) |
||
| 339 | -26x | +86 | +6x |
- y <- lapply(f, function(x) param[value %in% x])+ lrate_se <- rate_se / rate_est |
| 340 | -26x | +87 | +6x |
- lapply(y, function(x) if (length(x) == 0) NULL else x)+ ci <- exp(lrate_est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * lrate_se) |
| 341 | +88 |
- }+ |
||
| 342 | -+ | |||
| 89 | +6x |
-
+ list(rate = rate_est, rate_ci = ci) |
||
| 343 | +90 |
- #' Get selected statistics names+ } |
||
| 344 | +91 |
- #'+ |
||
| 345 | +92 |
- #' Helper function to be used for creating `afun`.+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
||
| 346 | +93 |
- #'+ #' associated exact confidence interval. Unit is one person-year. |
||
| 347 | +94 |
- #' @param .stats (`vector` or `NULL`)\cr input to the layout creating function. Note that `NULL` means+ #' |
||
| 348 | +95 |
- #' in this context that all default statistics should be used.+ #' @examples |
||
| 349 | +96 |
- #' @param all_stats (`character`)\cr all statistics which can be selected here potentially.+ #' h_incidence_rate_exact(200, 2) |
||
| 350 | +97 |
#' |
||
| 351 | +98 |
- #' @return A `character` vector with the selected statistics.+ #' @export |
||
| 352 | +99 |
- #'+ h_incidence_rate_exact <- function(person_years, |
||
| 353 | +100 |
- #' @keywords internal+ n_events, |
||
| 354 | +101 |
- afun_selected_stats <- function(.stats, all_stats) {
- |
- ||
| 355 | -2x | -
- checkmate::assert_character(.stats, null.ok = TRUE)+ alpha = 0.05) {
|
||
| 356 | -2x | +102 | +1x |
- checkmate::assert_character(all_stats)+ checkmate::assert_number(person_years) |
| 357 | -2x | +103 | +1x |
- if (is.null(.stats)) {
+ checkmate::assert_number(n_events) |
| 358 | +104 | 1x |
- all_stats+ assert_proportion_value(alpha) |
|
| 359 | +105 |
- } else {
+
|
||
| 360 | +106 | 1x |
- intersect(.stats, all_stats)+ est <- n_events / person_years |
|
| 361 | -+ | |||
| 107 | +1x |
- }+ lcl <- stats::qchisq(p = (alpha) / 2, df = 2 * n_events) / (2 * person_years) |
||
| 362 | -+ | |||
| 108 | +1x |
- }+ ucl <- stats::qchisq(p = 1 - (alpha) / 2, df = 2 * n_events + 2) / (2 * person_years) |
||
| 363 | +109 | |||
| 364 | -- |
- #' Add variable labels to top left corner in table- |
- ||
| 365 | -- |
- #'- |
- ||
| 366 | -+ | |||
| 110 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ list(rate = est, rate_ci = c(lcl, ucl)) |
||
| 367 | +111 |
- #'+ } |
||
| 368 | +112 |
- #' Helper layout-creating function to append the variable labels of a given variables vector+ |
||
| 369 | +113 |
- #' from a given dataset in the top left corner. If a variable label is not found then the+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
||
| 370 | +114 |
- #' variable name itself is used instead. Multiple variable labels are concatenated with slashes.+ #' associated Byar's confidence interval. Unit is one person-year. |
||
| 371 | +115 |
#' |
||
| 372 | +116 |
- #' @inheritParams argument_convention+ #' @examples |
||
| 373 | +117 |
- #' @param vars (`character`)\cr variable names of which the labels are to be looked up in `df`.+ #' h_incidence_rate_byar(200, 2) |
||
| 374 | +118 |
- #' @param indent (`integer(1)`)\cr non-negative number of nested indent space, default to 0L which means no indent.+ #' |
||
| 375 | +119 |
- #' 1L means two spaces indent, 2L means four spaces indent and so on.+ #' @export |
||
| 376 | +120 |
- #'+ h_incidence_rate_byar <- function(person_years, |
||
| 377 | +121 |
- #' @return A modified layout with the new variable label(s) added to the top-left material.+ n_events, |
||
| 378 | +122 |
- #'+ alpha = 0.05) {
|
||
| 379 | -+ | |||
| 123 | +1x |
- #' @note This is not an optimal implementation of course, since we are using here the data set+ checkmate::assert_number(person_years) |
||
| 380 | -+ | |||
| 124 | +1x |
- #' itself during the layout creation. When we have a more mature `rtables` implementation then+ checkmate::assert_number(n_events) |
||
| 381 | -+ | |||
| 125 | +1x |
- #' this will also be improved or not necessary anymore.+ assert_proportion_value(alpha) |
||
| 382 | +126 |
- #'+ |
||
| 383 | -+ | |||
| 127 | +1x |
- #' @examples+ est <- n_events / person_years |
||
| 384 | -+ | |||
| 128 | +1x |
- #' lyt <- basic_table() %>%+ seg_1 <- n_events + 0.5 |
||
| 385 | -+ | |||
| 129 | +1x |
- #' split_cols_by("ARM") %>%
+ seg_2 <- 1 - 1 / (9 * (n_events + 0.5)) |
||
| 386 | -+ | |||
| 130 | +1x |
- #' add_colcounts() %>%+ seg_3 <- stats::qnorm(1 - alpha / 2) * sqrt(1 / (n_events + 0.5)) / 3 |
||
| 387 | -+ | |||
| 131 | +1x |
- #' split_rows_by("SEX") %>%
+ lcl <- seg_1 * ((seg_2 - seg_3)^3) / person_years |
||
| 388 | -+ | |||
| 132 | +1x |
- #' append_varlabels(DM, "SEX") %>%+ ucl <- seg_1 * ((seg_2 + seg_3)^3) / person_years |
||
| 389 | +133 |
- #' analyze("AGE", afun = mean) %>%
+
+ |
+ ||
| 134 | +1x | +
+ list(rate = est, rate_ci = c(lcl, ucl)) |
||
| 390 | +135 |
- #' append_varlabels(DM, "AGE", indent = 1)+ } |
| 391 | +1 |
- #' build_table(lyt, DM)+ #' Summarize analysis of covariance (ANCOVA) results |
||
| 392 | +2 |
#' |
||
| 393 | +3 |
- #' lyt <- basic_table() %>%+ #' @description `r lifecycle::badge("stable")`
|
||
| 394 | +4 |
- #' split_cols_by("ARM") %>%
+ #' |
||
| 395 | +5 |
- #' split_rows_by("SEX") %>%
+ #' The analyze function [summarize_ancova()] creates a layout element to summarize ANCOVA results. |
||
| 396 | +6 |
- #' analyze("AGE", afun = mean) %>%
+ #' |
||
| 397 | +7 |
- #' append_varlabels(DM, c("SEX", "AGE"))
+ #' This function can be used to analyze multiple endpoints and/or multiple timepoints within the response variable(s) |
||
| 398 | +8 |
- #' build_table(lyt, DM)+ #' specified as `vars`. |
||
| 399 | +9 |
#' |
||
| 400 | +10 |
- #' @export+ #' Additional variables for the analysis, namely an arm (grouping) variable and covariate variables, can be defined |
||
| 401 | +11 |
- append_varlabels <- function(lyt, df, vars, indent = 0L) {
- |
- ||
| 402 | -3x | -
- if (checkmate::test_flag(indent)) {
- |
- ||
| 403 | -! | -
- warning("indent argument is now accepting integers. Boolean indent will be converted to integers.")
+ #' via the `variables` argument. See below for more details on how to specify `variables`. An interaction term can |
||
| 404 | -! | +|||
| 12 | +
- indent <- as.integer(indent)+ #' be implemented in the model if needed. The interaction variable that should interact with the arm variable is |
|||
| 405 | +13 |
- }+ #' specified via the `interaction_term` parameter, and the specific value of `interaction_term` for which to extract |
||
| 406 | +14 |
-
+ #' the ANCOVA results via the `interaction_y` parameter. |
||
| 407 | -3x | +|||
| 15 | +
- checkmate::assert_data_frame(df)+ #' |
|||
| 408 | -3x | +|||
| 16 | +
- checkmate::assert_character(vars)+ #' @inheritParams h_ancova |
|||
| 409 | -3x | +|||
| 17 | +
- checkmate::assert_count(indent)+ #' @inheritParams argument_convention |
|||
| 410 | +18 |
-
+ #' @param interaction_y (`string` or `flag`)\cr a selected item inside of the `interaction_item` variable which will be |
||
| 411 | -3x | +|||
| 19 | +
- lab <- formatters::var_labels(df[vars], fill = TRUE)+ #' used to select the specific ANCOVA results. if the interaction is not needed, the default option is `FALSE`. |
|||
| 412 | -3x | +|||
| 20 | +
- lab <- paste(lab, collapse = " / ")+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("summarize_ancova")`
|
|||
| 413 | -3x | +|||
| 21 | +
- space <- paste(rep(" ", indent * 2), collapse = "")
+ #' to see available statistics for this function. |
|||
| 414 | -3x | +|||
| 22 | +
- lab <- paste0(space, lab)+ #' |
|||
| 415 | +23 |
-
+ #' @name summarize_ancova |
||
| 416 | -3x | +|||
| 24 | +
- append_topleft(lyt, lab)+ #' @order 1 |
|||
| 417 | +25 |
- }+ NULL |
||
| 418 | +26 | |||
| 419 | +27 |
- #' Default string replacement for `NA` values+ #' Helper function to return results of a linear model |
||
| 420 | +28 |
#' |
||
| 421 | +29 |
#' @description `r lifecycle::badge("stable")`
|
||
| 422 | +30 |
#' |
||
| 423 | +31 |
- #' The default string used to represent `NA` values. This value is used as the default+ #' @inheritParams argument_convention |
||
| 424 | +32 |
- #' value for the `na_str` argument throughout the `tern` package, and printed in place+ #' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called in `.var` and `variables`. |
||
| 425 | +33 |
- #' of `NA` values in output tables. If not specified for each `tern` function by the user+ #' @param variables (named `list` of `string`)\cr list of additional analysis variables, with expected elements: |
||
| 426 | +34 |
- #' via the `na_str` argument, or in the R environment options via [set_default_na_str()],+ #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be |
||
| 427 | +35 |
- #' then `NA` is used.+ #' summarized. Specifically, the first level of `arm` variable is taken as the reference group. |
||
| 428 | +36 |
- #'+ #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as `"X1"`), and/or |
||
| 429 | +37 |
- #' @param na_str (`string`)\cr single string value to set in the R environment options as+ #' interaction terms indicated by `"X1 * X2"`. |
||
| 430 | +38 |
- #' the default value to replace `NA`s. Use `getOption("tern_default_na_str")` to check the
+ #' @param interaction_item (`string` or `NULL`)\cr name of the variable that should have interactions |
||
| 431 | +39 |
- #' current value set in the R environment (defaults to `NULL` if not set).+ #' with arm. if the interaction is not needed, the default option is `NULL`. |
||
| 432 | +40 |
#' |
||
| 433 | +41 |
- #' @name default_na_str+ #' @return The summary of a linear model. |
||
| 434 | +42 |
- NULL+ #' |
||
| 435 | +43 |
-
+ #' @examples |
||
| 436 | +44 |
- #' @describeIn default_na_str Accessor for default `NA` value replacement string.+ #' h_ancova( |
||
| 437 | +45 |
- #'+ #' .var = "Sepal.Length", |
||
| 438 | +46 |
- #' @return+ #' .df_row = iris, |
||
| 439 | +47 |
- #' * `default_na_str` returns the current value if an R environment option has been set+ #' variables = list(arm = "Species", covariates = c("Petal.Length * Petal.Width", "Sepal.Width"))
|
||
| 440 | +48 |
- #' for `"tern_default_na_str"`, or `NA_character_` otherwise.+ #' ) |
||
| 441 | +49 |
#' |
||
| 442 | +50 |
- #' @examples+ #' @export |
||
| 443 | +51 |
- #' # Default settings+ h_ancova <- function(.var, |
||
| 444 | +52 |
- #' default_na_str()+ .df_row, |
||
| 445 | +53 |
- #' getOption("tern_default_na_str")
+ variables, |
||
| 446 | +54 |
- #'+ interaction_item = NULL) {
|
||
| 447 | -+ | |||
| 55 | +27x |
- #' # Set custom value+ checkmate::assert_string(.var) |
||
| 448 | -+ | |||
| 56 | +27x |
- #' set_default_na_str("<Missing>")
+ checkmate::assert_list(variables) |
||
| 449 | -+ | |||
| 57 | +27x |
- #'+ checkmate::assert_subset(names(variables), c("arm", "covariates"))
|
||
| 450 | -+ | |||
| 58 | +27x |
- #' # Settings after value has been set+ assert_df_with_variables(.df_row, list(rsp = .var)) |
||
| 451 | +59 |
- #' default_na_str()+ |
||
| 452 | -+ | |||
| 60 | +26x |
- #' getOption("tern_default_na_str")
+ arm <- variables$arm |
||
| 453 | -+ | |||
| 61 | +26x |
- #'+ covariates <- variables$covariates |
||
| 454 | -+ | |||
| 62 | +26x |
- #' @export+ if (!is.null(covariates) && length(covariates) > 0) {
|
||
| 455 | +63 |
- default_na_str <- function() {
+ # Get all covariate variable names in the model. |
||
| 456 | -331x | +64 | +11x |
- getOption("tern_default_na_str", default = NA_character_)
+ var_list <- get_covariates(covariates) |
| 457 | -+ | |||
| 65 | +11x |
- }+ assert_df_with_variables(.df_row, var_list) |
||
| 458 | +66 |
-
+ } |
||
| 459 | +67 |
- #' @describeIn default_na_str Setter for default `NA` value replacement string. Sets the+ |
||
| 460 | -+ | |||
| 68 | +25x |
- #' option `"tern_default_na_str"` within the R environment.+ covariates_part <- paste(covariates, collapse = " + ") |
||
| 461 | -+ | |||
| 69 | +25x |
- #'+ if (covariates_part != "") {
|
||
| 462 | -+ | |||
| 70 | +10x |
- #' @return+ formula <- stats::as.formula(paste0(.var, " ~ ", covariates_part, " + ", arm)) |
||
| 463 | +71 |
- #' * `set_default_na_str` has no return value.+ } else {
|
||
| 464 | -+ | |||
| 72 | +15x |
- #'+ formula <- stats::as.formula(paste0(.var, " ~ ", arm)) |
||
| 465 | +73 |
- #' @export+ } |
||
| 466 | +74 |
- set_default_na_str <- function(na_str) {
+
|
||
| 467 | -3x | +75 | +25x |
- checkmate::assert_character(na_str, len = 1, null.ok = TRUE)+ if (is.null(interaction_item)) {
|
| 468 | -3x | +76 | +21x |
- options("tern_default_na_str" = na_str)
+ specs <- arm |
| 469 | +77 |
- }+ } else {
|
| 1 | -+ | |||
| 78 | +4x |
- #' Split function to configure risk difference column+ specs <- c(arm, interaction_item) |
||
| 2 | +79 |
- #'+ } |
||
| 3 | +80 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 4 | -+ | |||
| 81 | +25x |
- #'+ lm_fit <- stats::lm( |
||
| 5 | -+ | |||
| 82 | +25x |
- #' Wrapper function for [rtables::add_combo_levels()] which configures settings for the risk difference+ formula = formula, |
||
| 6 | -+ | |||
| 83 | +25x |
- #' column to be added to an `rtables` object. To add a risk difference column to a table, this function+ data = .df_row |
||
| 7 | +84 |
- #' should be used as `split_fun` in calls to [rtables::split_cols_by()], followed by setting argument+ ) |
||
| 8 | -+ | |||
| 85 | +25x |
- #' `riskdiff` to `TRUE` in all following analyze function calls.+ emmeans_fit <- emmeans::emmeans( |
||
| 9 | -+ | |||
| 86 | +25x |
- #'+ lm_fit, |
||
| 10 | +87 |
- #' @param arm_x (`string`)\cr name of reference arm to use in risk difference calculations.+ # Specify here the group variable over which EMM are desired. |
||
| 11 | -+ | |||
| 88 | +25x |
- #' @param arm_y (`character`)\cr names of one or more arms to compare to reference arm in risk difference+ specs = specs, |
||
| 12 | +89 |
- #' calculations. A new column will be added for each value of `arm_y`.+ # Pass the data again so that the factor levels of the arm variable can be inferred. |
||
| 13 | -+ | |||
| 90 | +25x |
- #' @param col_label (`character`)\cr labels to use when rendering the risk difference column within the table.+ data = .df_row |
||
| 14 | +91 |
- #' If more than one comparison arm is specified in `arm_y`, default labels will specify which two arms are+ ) |
||
| 15 | +92 |
- #' being compared (reference arm vs. comparison arm).+ |
||
| 16 | -+ | |||
| 93 | +25x |
- #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`.+ emmeans_fit |
||
| 17 | +94 |
- #'+ } |
||
| 18 | +95 |
- #' @return A closure suitable for use as a split function (`split_fun`) within [rtables::split_cols_by()]+ |
||
| 19 | +96 |
- #' when creating a table layout.+ #' @describeIn summarize_ancova Statistics function that produces a named list of results |
||
| 20 | +97 |
- #'+ #' of the investigated linear model. |
||
| 21 | +98 |
- #' @seealso [stat_propdiff_ci()] for details on risk difference calculation.+ #' |
||
| 22 | +99 |
- #'+ #' @return |
||
| 23 | +100 |
- #' @examples+ #' * `s_ancova()` returns a named list of 5 statistics: |
||
| 24 | +101 |
- #' adae <- tern_ex_adae+ #' * `n`: Count of complete sample size for the group. |
||
| 25 | +102 |
- #' adae$AESEV <- factor(adae$AESEV)+ #' * `lsmean`: Estimated marginal means in the group. |
||
| 26 | +103 |
- #'+ #' * `lsmean_diff`: Difference in estimated marginal means in comparison to the reference group. |
||
| 27 | +104 |
- #' lyt <- basic_table() %>%+ #' If working with the reference group, this will be empty. |
||
| 28 | +105 |
- #' split_cols_by("ARMCD", split_fun = add_riskdiff(arm_x = "ARM A", arm_y = c("ARM B", "ARM C"))) %>%
+ #' * `lsmean_diff_ci`: Confidence level for difference in estimated marginal means in comparison |
||
| 29 | +106 |
- #' count_occurrences_by_grade(+ #' to the reference group. |
||
| 30 | +107 |
- #' var = "AESEV",+ #' * `pval`: p-value (not adjusted for multiple comparisons). |
||
| 31 | +108 |
- #' riskdiff = TRUE+ #' |
||
| 32 | +109 |
- #' )+ #' @keywords internal |
||
| 33 | +110 |
- #'+ s_ancova <- function(df, |
||
| 34 | +111 |
- #' tbl <- build_table(lyt, df = adae)+ .var, |
||
| 35 | +112 |
- #' tbl+ .df_row, |
||
| 36 | +113 |
- #'+ variables, |
||
| 37 | +114 |
- #' @export+ .ref_group, |
||
| 38 | +115 |
- add_riskdiff <- function(arm_x,+ .in_ref_col, |
||
| 39 | +116 |
- arm_y,+ conf_level, |
||
| 40 | +117 |
- col_label = paste0(+ interaction_y = FALSE, |
||
| 41 | +118 |
- "Risk Difference (%) (95% CI)", if (length(arm_y) > 1) paste0("\n", arm_x, " vs. ", arm_y)
+ interaction_item = NULL) {
|
||
| 42 | -+ | |||
| 119 | +3x |
- ),+ emmeans_fit <- h_ancova(.var = .var, variables = variables, .df_row = .df_row, interaction_item = interaction_item) |
||
| 43 | +120 |
- pct = TRUE) {
+
|
||
| 44 | -17x | +121 | +3x |
- checkmate::assert_character(arm_x, len = 1)+ sum_fit <- summary( |
| 45 | -17x | +122 | +3x |
- checkmate::assert_character(arm_y, min.len = 1)+ emmeans_fit, |
| 46 | -17x | +123 | +3x |
- checkmate::assert_character(col_label, len = length(arm_y))+ level = conf_level |
| 47 | +124 |
-
+ ) |
||
| 48 | -17x | +|||
| 125 | +
- combodf <- tibble::tribble(~valname, ~label, ~levelcombo, ~exargs)+ |
|||
| 49 | -17x | +126 | +3x |
- for (i in seq_len(length(arm_y))) {
+ arm <- variables$arm |
| 50 | -18x | +|||
| 127 | +
- combodf <- rbind(+ |
|||
| 51 | -18x | +128 | +3x |
- combodf,+ sum_level <- as.character(unique(df[[arm]])) |
| 52 | -18x | +|||
| 129 | +
- tibble::tribble(+ |
|||
| 53 | -18x | +|||
| 130 | +
- ~valname, ~label, ~levelcombo, ~exargs,+ # Ensure that there is only one element in sum_level. |
|||
| 54 | -18x | +131 | +3x |
- paste("riskdiff", arm_x, arm_y[i], sep = "_"), col_label[i], c(arm_x, arm_y[i]), list()
+ checkmate::assert_scalar(sum_level) |
| 55 | +132 |
- )+ + |
+ ||
| 133 | +2x | +
+ sum_fit_level <- sum_fit[sum_fit[[arm]] == sum_level, ] |
||
| 56 | +134 |
- )+ |
||
| 57 | +135 |
- }+ # Get the index of the ref arm |
||
| 58 | -17x | +136 | +2x |
- if (pct) combodf$valname <- paste0(combodf$valname, "_pct")+ if (interaction_y != FALSE) {
|
| 59 | -17x | +137 | +1x |
- add_combo_levels(combodf)+ y <- unlist(df[(df[[interaction_item]] == interaction_y), .var]) |
| 60 | +138 |
- }+ # convert characters selected in interaction_y into the numeric order |
||
| 61 | -+ | |||
| 139 | +1x |
-
+ interaction_y <- which(sum_fit_level[[interaction_item]] == interaction_y) |
||
| 62 | -+ | |||
| 140 | +1x |
- #' Analysis function to calculate risk difference column values+ sum_fit_level <- sum_fit_level[interaction_y, ] |
||
| 63 | +141 |
- #'+ # if interaction is called, reset the index |
||
| 64 | -+ | |||
| 142 | +1x |
- #' In the risk difference column, this function uses the statistics function associated with `afun` to+ ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])]) |
||
| 65 | -+ | |||
| 143 | +1x |
- #' calculates risk difference values from arm X (reference group) and arm Y. These arms are specified+ ref_key <- tail(ref_key, n = 1) |
||
| 66 | -+ | |||
| 144 | +1x |
- #' when configuring the risk difference column which is done using the [add_riskdiff()] split function in+ ref_key <- (interaction_y - 1) * length(unique(.df_row[[arm]])) + ref_key |
||
| 67 | +145 |
- #' the previous call to [rtables::split_cols_by()]. For all other columns, applies `afun` as usual. This+ } else {
|
||
| 68 | -+ | |||
| 146 | +1x |
- #' function utilizes the [stat_propdiff_ci()] function to perform risk difference calculations.+ y <- df[[.var]] |
||
| 69 | +147 |
- #'+ # Get the index of the ref arm when interaction is not called |
||
| 70 | -+ | |||
| 148 | +1x |
- #' @inheritParams argument_convention+ ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])]) |
||
| 71 | -+ | |||
| 149 | +1x |
- #' @param afun (named `list`)\cr a named list containing one name-value pair where the name corresponds to+ ref_key <- tail(ref_key, n = 1) |
||
| 72 | +150 |
- #' the name of the statistics function that should be used in calculations and the value is the corresponding+ } |
||
| 73 | +151 |
- #' analysis function.+ |
||
| 74 | -+ | |||
| 152 | +2x |
- #' @param s_args (named `list`)\cr additional arguments to be passed to the statistics function and analysis+ if (.in_ref_col) {
|
||
| 75 | -+ | |||
| 153 | +1x |
- #' function supplied in `afun`.+ list( |
||
| 76 | -+ | |||
| 154 | +1x |
- #'+ n = length(y[!is.na(y)]), |
||
| 77 | -+ | |||
| 155 | +1x |
- #' @return A list of formatted [rtables::CellValue()].+ lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"),+ |
+ ||
| 156 | +1x | +
+ lsmean_diff = formatters::with_label(character(), "Difference in Adjusted Means"),+ |
+ ||
| 157 | +1x | +
+ lsmean_diff_ci = formatters::with_label(character(), f_conf_level(conf_level)),+ |
+ ||
| 158 | +1x | +
+ pval = formatters::with_label(character(), "p-value") |
||
| 78 | +159 |
- #'+ ) |
||
| 79 | +160 |
- #' @seealso+ } else {
|
||
| 80 | +161 |
- #' * [stat_propdiff_ci()] for details on risk difference calculation.+ # Estimate the differences between the marginal means.+ |
+ ||
| 162 | +1x | +
+ emmeans_contrasts <- emmeans::contrast(+ |
+ ||
| 163 | +1x | +
+ emmeans_fit, |
||
| 81 | +164 |
- #' * Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()] with+ # Compare all arms versus the control arm. |
||
| 82 | -+ | |||
| 165 | +1x |
- #' `riskdiff` argument set to `TRUE` in subsequent analyze functions calls, adds a risk difference column+ method = "trt.vs.ctrl", |
||
| 83 | +166 |
- #' to a table layout.+ # Take the arm factor from .ref_group as the control arm. |
||
| 84 | -+ | |||
| 167 | +1x |
- #'+ ref = ref_key, |
||
| 85 | -+ | |||
| 168 | +1x |
- #' @keywords internal+ level = conf_level |
||
| 86 | +169 |
- afun_riskdiff <- function(df,+ ) |
||
| 87 | -+ | |||
| 170 | +1x |
- labelstr = "",+ sum_contrasts <- summary( |
||
| 88 | -+ | |||
| 171 | +1x |
- .var,+ emmeans_contrasts, |
||
| 89 | +172 |
- .N_col, # nolint+ # Derive confidence intervals, t-tests and p-values. |
||
| 90 | -+ | |||
| 173 | +1x |
- .N_row, # nolint+ infer = TRUE, |
||
| 91 | +174 |
- .df_row,+ # Do not adjust the p-values for multiplicity. |
||
| 92 | -+ | |||
| 175 | +1x |
- .spl_context,+ adjust = "none" |
||
| 93 | +176 |
- .all_col_counts,+ ) |
||
| 94 | +177 |
- .stats,+ |
||
| 95 | -+ | |||
| 178 | +1x |
- .formats = NULL,+ contrast_lvls <- gsub( |
||
| 96 | -+ | |||
| 179 | +1x |
- .labels = NULL,+ "^\\(|\\)$", "", gsub(paste0(" - \\(*", .ref_group[[arm]][1], ".*"), "", sum_contrasts$contrast)
|
||
| 97 | +180 |
- .indent_mods = NULL,+ ) |
||
| 98 | -+ | |||
| 181 | +1x |
- na_str = default_na_str(),+ if (!is.null(interaction_item)) {
|
||
| 99 | -+ | |||
| 182 | +! |
- afun,+ sum_contrasts_level <- sum_contrasts[grepl(sum_level, contrast_lvls, fixed = TRUE), ] |
||
| 100 | +183 |
- s_args = list()) {
+ } else {
|
||
| 101 | -130x | +184 | +1x |
- if (!any(grepl("riskdiff", names(.spl_context)))) {
+ sum_contrasts_level <- sum_contrasts[sum_level == contrast_lvls, ] |
| 102 | -! | +|||
| 185 | +
- stop(+ } |
|||
| 103 | -! | +|||
| 186 | +1x |
- "Please set up levels to use in risk difference calculations using the `add_riskdiff` ",+ if (interaction_y != FALSE) {
|
||
| 104 | +187 | ! |
- "split function within `split_cols_by`. See ?add_riskdiff for details."+ sum_contrasts_level <- sum_contrasts_level[interaction_y, ] |
|
| 105 | +188 |
- )+ } |
||
| 106 | +189 |
- }+ |
||
| 107 | -130x | +190 | +1x |
- checkmate::assert_list(afun, len = 1, types = "function")+ list( |
| 108 | -130x | +191 | +1x |
- checkmate::assert_named(afun)+ n = length(y[!is.na(y)]), |
| 109 | -130x | +192 | +1x |
- afun_args <- list(+ lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"), |
| 110 | -130x | +193 | +1x |
- .var = .var, .df_row = .df_row, .N_row = .N_row, denom = "N_col", labelstr = labelstr,+ lsmean_diff = formatters::with_label(sum_contrasts_level$estimate, "Difference in Adjusted Means"), |
| 111 | -130x | -
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str- |
- ||
| 112 | -+ | 194 | +1x |
- )+ lsmean_diff_ci = formatters::with_label( |
| 113 | -130x | +195 | +1x |
- afun_args <- afun_args[intersect(names(afun_args), names(as.list(args(afun[[1]]))))]+ c(sum_contrasts_level$lower.CL, sum_contrasts_level$upper.CL), |
| 114 | -! | +|||
| 196 | +1x |
- if ("denom" %in% names(s_args)) afun_args[["denom"]] <- NULL
+ f_conf_level(conf_level) |
||
| 115 | +197 | - - | -||
| 116 | -130x | -
- cur_split <- tail(.spl_context$cur_col_split_val[[1]], 1)+ ), |
||
| 117 | -130x | +198 | +1x |
- if (!grepl("^riskdiff", cur_split)) {
+ pval = formatters::with_label(sum_contrasts_level$p.value, "p-value") |
| 118 | +199 |
- # Apply basic afun (no risk difference) in all other columns+ ) |
||
| 119 | -96x | +|||
| 200 | +
- do.call(afun[[1]], args = c(list(df = df, .N_col = .N_col), afun_args, s_args))+ } |
|||
| 120 | +201 |
- } else {
+ } |
||
| 121 | -34x | +|||
| 202 | +
- arm_x <- strsplit(cur_split, "_")[[1]][2]+ |
|||
| 122 | -34x | +|||
| 203 | +
- arm_y <- strsplit(cur_split, "_")[[1]][3]+ #' @describeIn summarize_ancova Formatted analysis function which is used as `afun` in `summarize_ancova()`. |
|||
| 123 | -34x | +|||
| 204 | +
- if (length(.spl_context$cur_col_split[[1]]) > 1) { # Different split name for nested column splits
+ #' |
|||
| 124 | -8x | +|||
| 205 | +
- arm_spl_x <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 2)], collapse = ""))
+ #' @return |
|||
| 125 | -8x | +|||
| 206 | +
- arm_spl_y <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 3)], collapse = ""))
+ #' * `a_ancova()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 126 | +207 |
- } else {
+ #' |
||
| 127 | -26x | +|||
| 208 | +
- arm_spl_x <- arm_x+ #' @keywords internal |
|||
| 128 | -26x | +|||
| 209 | +
- arm_spl_y <- arm_y+ a_ancova <- make_afun( |
|||
| 129 | +210 |
- }+ s_ancova, |
||
| 130 | -34x | +|||
| 211 | +
- N_col_x <- .all_col_counts[[arm_spl_x]] # nolint+ .indent_mods = c("n" = 0L, "lsmean" = 0L, "lsmean_diff" = 0L, "lsmean_diff_ci" = 1L, "pval" = 1L),
|
|||
| 131 | -34x | +|||
| 212 | +
- N_col_y <- .all_col_counts[[arm_spl_y]] # nolint+ .formats = c( |
|||
| 132 | -34x | +|||
| 213 | +
- cur_var <- tail(.spl_context$cur_col_split[[1]], 1)+ "n" = "xx", |
|||
| 133 | +214 |
-
+ "lsmean" = "xx.xx", |
||
| 134 | +215 |
- # Apply statistics function to arm X and arm Y data+ "lsmean_diff" = "xx.xx", |
||
| 135 | -34x | +|||
| 216 | +
- s_args <- c(s_args, afun_args[intersect(names(afun_args), names(as.list(args(names(afun)))))])+ "lsmean_diff_ci" = "(xx.xx, xx.xx)", |
|||
| 136 | -34x | +|||
| 217 | +
- s_x <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_x, ], .N_col = N_col_x), s_args))+ "pval" = "x.xxxx | (<0.0001)" |
|||
| 137 | -34x | +|||
| 218 | +
- s_y <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_y, ], .N_col = N_col_y), s_args))+ ), |
|||
| 138 | +219 |
-
+ .null_ref_cells = FALSE |
||
| 139 | +220 |
- # Get statistic name and row names+ ) |
||
| 140 | -34x | +|||
| 221 | +
- stat <- ifelse("count_fraction" %in% names(s_x), "count_fraction", "unique")
+
|
|||
| 141 | -34x | +|||
| 222 | +
- if ("flag_variables" %in% names(s_args)) {
+ #' @describeIn summarize_ancova Layout-creating function which can take statistics function arguments |
|||
| 142 | -2x | +|||
| 223 | +
- var_nms <- s_args$flag_variables+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 143 | -32x | +|||
| 224 | +
- } else if (!is.null(names(s_x[[stat]]))) {
+ #' |
|||
| 144 | -20x | +|||
| 225 | +
- var_nms <- names(s_x[[stat]])+ #' @return |
|||
| 145 | +226 |
- } else {
+ #' * `summarize_ancova()` returns a layout object suitable for passing to further layouting functions, |
||
| 146 | -12x | +|||
| 227 | +
- var_nms <- ""+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 147 | -12x | +|||
| 228 | +
- s_x[[stat]] <- list(s_x[[stat]])+ #' the statistics from `s_ancova()` to the table layout. |
|||
| 148 | -12x | +|||
| 229 | +
- s_y[[stat]] <- list(s_y[[stat]])+ #' |
|||
| 149 | +230 |
- }+ #' @examples |
||
| 150 | +231 |
-
+ #' basic_table() %>% |
||
| 151 | +232 |
- # Calculate risk difference for each row, repeated if multiple statistics in table+ #' split_cols_by("Species", ref_group = "setosa") %>%
|
||
| 152 | -34x | +|||
| 233 | +
- pct <- tail(strsplit(cur_split, "_")[[1]], 1) == "pct"+ #' add_colcounts() %>% |
|||
| 153 | -34x | +|||
| 234 | +
- rd_ci <- rep(stat_propdiff_ci(+ #' summarize_ancova( |
|||
| 154 | -34x | +|||
| 235 | +
- lapply(s_x[[stat]], `[`, 1), lapply(s_y[[stat]], `[`, 1),+ #' vars = "Petal.Length", |
|||
| 155 | -34x | +|||
| 236 | +
- N_col_x, N_col_y,+ #' variables = list(arm = "Species", covariates = NULL), |
|||
| 156 | -34x | +|||
| 237 | +
- list_names = var_nms,+ #' table_names = "unadj", |
|||
| 157 | -34x | +|||
| 238 | +
- pct = pct+ #' conf_level = 0.95, var_labels = "Unadjusted comparison", |
|||
| 158 | -34x | +|||
| 239 | +
- ), max(1, length(.stats)))+ #' .labels = c(lsmean = "Mean", lsmean_diff = "Difference in Means") |
|||
| 159 | +240 |
-
+ #' ) %>% |
||
| 160 | -34x | +|||
| 241 | +
- in_rows(.list = rd_ci, .formats = "xx.x (xx.x - xx.x)", .indent_mods = .indent_mods)+ #' summarize_ancova( |
|||
| 161 | +242 |
- }+ #' vars = "Petal.Length", |
||
| 162 | +243 |
- }+ #' variables = list(arm = "Species", covariates = c("Sepal.Length", "Sepal.Width")),
|
||
| 163 | +244 |
-
+ #' table_names = "adj", |
||
| 164 | +245 |
- #' Control function for risk difference column+ #' conf_level = 0.95, var_labels = "Adjusted comparison (covariates: Sepal.Length and Sepal.Width)" |
||
| 165 | +246 |
- #'+ #' ) %>% |
||
| 166 | +247 |
- #' @description `r lifecycle::badge("stable")`
+ #' build_table(iris) |
||
| 167 | +248 |
#' |
||
| 168 | +249 |
- #' Sets a list of parameters to use when generating a risk (proportion) difference column. Used as input to the+ #' @export |
||
| 169 | +250 |
- #' `riskdiff` parameter of [tabulate_rsp_subgroups()] and [tabulate_survival_subgroups()].+ #' @order 2 |
||
| 170 | +251 |
- #'+ summarize_ancova <- function(lyt, |
||
| 171 | +252 |
- #' @inheritParams add_riskdiff+ vars, |
||
| 172 | +253 |
- #' @param format (`string` or `function`)\cr the format label (string) or formatting function to apply to the risk+ variables, |
||
| 173 | +254 |
- #' difference statistic. See the `3d` string options in [formatters::list_valid_format_labels()] for possible format+ conf_level, |
||
| 174 | +255 |
- #' strings. Defaults to `"xx.x (xx.x - xx.x)"`.+ interaction_y = FALSE, |
||
| 175 | +256 |
- #'+ interaction_item = NULL, |
||
| 176 | +257 |
- #' @return A `list` of items with names corresponding to the arguments.+ var_labels, |
||
| 177 | +258 |
- #'+ na_str = default_na_str(), |
||
| 178 | +259 |
- #' @seealso [add_riskdiff()], [tabulate_rsp_subgroups()], and [tabulate_survival_subgroups()].+ nested = TRUE, |
||
| 179 | +260 |
- #'+ ..., |
||
| 180 | +261 |
- #' @examples+ show_labels = "visible", |
||
| 181 | +262 |
- #' control_riskdiff()+ table_names = vars, |
||
| 182 | +263 |
- #' control_riskdiff(arm_x = "ARM A", arm_y = "ARM B")+ .stats = NULL, |
||
| 183 | +264 |
- #'+ .formats = NULL, |
||
| 184 | +265 |
- #' @export+ .labels = NULL, |
||
| 185 | +266 |
- control_riskdiff <- function(arm_x = NULL,+ .indent_mods = NULL) {
+ |
+ ||
| 267 | +7x | +
+ extra_args <- list(+ |
+ ||
| 268 | +7x | +
+ variables = variables, conf_level = conf_level, interaction_y = interaction_y,+ |
+ ||
| 269 | +7x | +
+ interaction_item = interaction_item, ... |
||
| 186 | +270 |
- arm_y = NULL,+ ) |
||
| 187 | +271 |
- format = "xx.x (xx.x - xx.x)",+ + |
+ ||
| 272 | +7x | +
+ afun <- make_afun(+ |
+ ||
| 273 | +7x | +
+ a_ancova,+ |
+ ||
| 274 | +7x | +
+ interaction_y = interaction_y,+ |
+ ||
| 275 | +7x | +
+ interaction_item = interaction_item,+ |
+ ||
| 276 | +7x | +
+ .stats = .stats,+ |
+ ||
| 277 | +7x | +
+ .formats = .formats,+ |
+ ||
| 278 | +7x | +
+ .labels = .labels,+ |
+ ||
| 279 | +7x | +
+ .indent_mods = .indent_mods |
||
| 188 | +280 |
- col_label = "Risk Difference (%) (95% CI)",+ ) |
||
| 189 | +281 |
- pct = TRUE) {
+
|
||
| 190 | -2x | +282 | +7x |
- checkmate::assert_character(arm_x, len = 1, null.ok = TRUE)+ analyze( |
| 191 | -2x | +283 | +7x |
- checkmate::assert_character(arm_y, min.len = 1, null.ok = TRUE)+ lyt, |
| 192 | -2x | +284 | +7x |
- checkmate::assert_character(format, len = 1)+ vars, |
| 193 | -2x | +285 | +7x |
- checkmate::assert_character(col_label)+ var_labels = var_labels, |
| 194 | -2x | +286 | +7x |
- checkmate::assert_flag(pct)+ show_labels = show_labels, |
| 195 | -+ | |||
| 287 | +7x |
-
+ table_names = table_names, |
||
| 196 | -2x | +288 | +7x |
- list(arm_x = arm_x, arm_y = arm_y, format = format, col_label = col_label, pct = pct)+ afun = afun,+ |
+
| 289 | +7x | +
+ na_str = na_str,+ |
+ ||
| 290 | +7x | +
+ nested = nested,+ |
+ ||
| 291 | +7x | +
+ extra_args = extra_args |
||
| 197 | +292 | ++ |
+ )+ |
+ |
| 293 |
}@@ -65212,14 +66262,14 @@ tern coverage - 95.64% |
| 1 |
- #' Count patients with abnormal analysis range values by baseline status+ #' Helper function for deriving analysis datasets for select laboratory tables |
||
| 5 |
- #' The analyze function [count_abnormal_by_baseline()] creates a layout element to count patients with abnormal+ #' Helper function that merges ADSL and ADLB datasets so that missing lab test records are inserted in the |
||
| 6 |
- #' analysis range values, categorized by baseline status.+ #' 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 abnormal range results. Additional+ #' |
||
| 9 |
- #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to+ #' @param adsl (`data.frame`)\cr ADSL data frame. |
||
| 10 |
- #' `USUBJID`), a variable to indicate unique subject identifiers, and `baseline` (defaults to `BNRIND`), a+ #' @param adlb (`data.frame`)\cr ADLB data frame. |
||
| 11 |
- #' variable to indicate baseline reference ranges.+ #' @param worst_flag (named `character`)\cr worst post-baseline lab flag variable. See how this is implemented in the |
||
| 12 |
- #'+ #' following examples. |
||
| 13 |
- #' For each direction specified via the `abnormal` parameter (e.g. High or Low), we condition on baseline+ #' @param by_visit (`flag`)\cr defaults to `FALSE` to generate worst grade per patient. |
||
| 14 |
- #' range result and count patients in the numerator and denominator as follows for each of the following+ #' If worst grade per patient per visit is specified for `worst_flag`, then |
||
| 15 |
- #' categories:+ #' `by_visit` should be `TRUE` to generate worst grade patient per visit. |
||
| 16 |
- #' * `Not <abnormality>`+ #' @param no_fillin_visits (named `character`)\cr visits that are not considered for post-baseline worst toxicity |
||
| 17 |
- #' * `num`: The number of patients without abnormality at baseline (excluding those with missing baseline)+ #' grade. Defaults to `c("SCREENING", "BASELINE")`.
|
||
| 18 |
- #' and with at least one abnormality post-baseline.+ #' |
||
| 19 |
- #' * `denom`: The number of patients without abnormality at baseline (excluding those with missing baseline).+ #' @return `df` containing variables shared between `adlb` and `adsl` along with variables `PARAM`, `PARAMCD`, |
||
| 20 |
- #' * `<Abnormality>`+ #' `ATOXGR`, and `BTOXGR` relevant for analysis. Optionally, `AVISIT` are `AVISITN` are included when |
||
| 21 |
- #' * `num`: The number of patients with abnormality as baseline and at least one abnormality post-baseline.+ #' `by_visit = TRUE` and `no_fillin_visits = c("SCREENING", "BASELINE")`.
|
||
| 22 |
- #' * `denom`: The number of patients with abnormality at baseline.+ #' |
||
| 23 |
- #' * `Total`+ #' @details In the result data missing records will be created for the following situations: |
||
| 24 |
- #' * `num`: The number of patients with at least one post-baseline record and at least one abnormality+ #' * Patients who are present in `adsl` but have no lab data in `adlb` (both baseline and post-baseline). |
||
| 25 |
- #' post-baseline.+ #' * Patients who do not have any post-baseline lab values. |
||
| 26 |
- #' * `denom`: The number of patients with at least one post-baseline record.+ #' * Patients without any post-baseline values flagged as the worst. |
||
| 28 |
- #' This function assumes that `df` has been filtered to only include post-baseline records.+ #' @examples |
||
| 29 |
- #'+ #' # `h_adsl_adlb_merge_using_worst_flag` |
||
| 30 |
- #' @inheritParams argument_convention+ #' adlb_out <- h_adsl_adlb_merge_using_worst_flag( |
||
| 31 |
- #' @param abnormal (`character`)\cr values identifying the abnormal range level(s) in `.var`.+ #' tern_ex_adsl, |
||
| 32 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal_by_baseline")`
+ #' tern_ex_adlb, |
||
| 33 |
- #' to see available statistics for this function.+ #' worst_flag = c("WGRHIFL" = "Y")
|
||
| 34 |
- #'+ #' ) |
||
| 35 |
- #' @note+ #' |
||
| 36 |
- #' * `df` should be filtered to include only post-baseline records.+ #' # `h_adsl_adlb_merge_using_worst_flag` by visit example |
||
| 37 |
- #' * If the baseline variable or analysis variable contains `NA` records, it is expected that `df` has been+ #' adlb_out_by_visit <- h_adsl_adlb_merge_using_worst_flag( |
||
| 38 |
- #' pre-processed using [df_explicit_na()] or [explicit_na()].+ #' tern_ex_adsl, |
||
| 39 |
- #'+ #' tern_ex_adlb, |
||
| 40 |
- #' @seealso Relevant description function [d_count_abnormal_by_baseline()].+ #' worst_flag = c("WGRLOVFL" = "Y"),
|
||
| 41 |
- #'+ #' by_visit = TRUE |
||
| 42 |
- #' @name abnormal_by_baseline+ #' ) |
||
| 43 |
- #' @order 1+ #' |
||
| 44 |
- NULL+ #' @export |
||
| 45 |
-
+ h_adsl_adlb_merge_using_worst_flag <- function(adsl, # nolint |
||
| 46 |
- #' Description function for `s_count_abnormal_by_baseline()`+ adlb, |
||
| 47 |
- #'+ worst_flag = c("WGRHIFL" = "Y"),
|
||
| 48 |
- #' @description `r lifecycle::badge("stable")`
+ by_visit = FALSE, |
||
| 49 |
- #'+ no_fillin_visits = c("SCREENING", "BASELINE")) {
|
||
| 50 | -+ | 5x |
- #' Description function that produces the labels for [s_count_abnormal_by_baseline()].+ col_names <- names(worst_flag) |
| 51 | -+ | 5x |
- #'+ filter_values <- worst_flag |
| 52 |
- #' @inheritParams abnormal_by_baseline+ |
||
| 53 | -+ | 5x |
- #'+ temp <- Map( |
| 54 | -+ | 5x |
- #' @return Abnormal category labels for [s_count_abnormal_by_baseline()].+ function(x, y) which(adlb[[x]] == y), |
| 55 | -+ | 5x |
- #'+ col_names, |
| 56 | -+ | 5x |
- #' @examples+ filter_values |
| 57 |
- #' d_count_abnormal_by_baseline("LOW")
+ ) |
||
| 58 |
- #'+ |
||
| 59 | -+ | 5x |
- #' @export+ position_satisfy_filters <- Reduce(intersect, temp) |
| 60 |
- d_count_abnormal_by_baseline <- function(abnormal) {
+
|
||
| 61 | -9x | +5x |
- not_abn_name <- paste("Not", tolower(abnormal))
+ adsl_adlb_common_columns <- intersect(colnames(adsl), colnames(adlb)) |
| 62 | -9x | +5x |
- abn_name <- paste0(toupper(substr(abnormal, 1, 1)), tolower(substring(abnormal, 2)))+ columns_from_adlb <- c("USUBJID", "PARAM", "PARAMCD", "AVISIT", "AVISITN", "ATOXGR", "BTOXGR")
|
| 63 | -9x | +
- total_name <- "Total"+ |
|
| 64 | -+ | 5x |
-
+ adlb_f <- adlb[position_satisfy_filters, ] %>% |
| 65 | -9x | +5x |
- list(+ dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) |
| 66 | -9x | +5x |
- not_abnormal = not_abn_name,+ adlb_f <- adlb_f[, columns_from_adlb] |
| 67 | -9x | +
- abnormal = abn_name,+ |
|
| 68 | -9x | +5x |
- total = total_name+ avisits_grid <- adlb %>% |
| 69 | -+ | 5x |
- )+ dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) %>% |
| 70 | -+ | 5x |
- }+ dplyr::pull(.data[["AVISIT"]]) %>% |
| 71 | -+ | 5x |
-
+ unique() |
| 72 |
- #' @describeIn abnormal_by_baseline Statistics function for a single `abnormal` level.+ |
||
| 73 | -+ | 5x |
- #'+ if (by_visit) {
|
| 74 | -+ | 1x |
- #' @param na_str (`string`)\cr the explicit `na_level` argument you used in the pre-processing steps (maybe with+ adsl_lb <- expand.grid( |
| 75 | -+ | 1x |
- #' [df_explicit_na()]). The default is `"<Missing>"`.+ USUBJID = unique(adsl$USUBJID), |
| 76 | -+ | 1x |
- #'+ AVISIT = avisits_grid, |
| 77 | -+ | 1x |
- #' @return+ PARAMCD = unique(adlb$PARAMCD) |
| 78 |
- #' * `s_count_abnormal_by_baseline()` returns statistic `fraction` which is a named list with 3 labeled elements:+ ) |
||
| 79 |
- #' `not_abnormal`, `abnormal`, and `total`. Each element contains a vector with `num` and `denom` patient counts.+ |
||
| 80 | -+ | 1x |
- #'+ adsl_lb <- adsl_lb %>% |
| 81 | -+ | 1x |
- #' @keywords internal+ dplyr::left_join(unique(adlb[c("AVISIT", "AVISITN")]), by = "AVISIT") %>%
|
| 82 | -+ | 1x |
- s_count_abnormal_by_baseline <- function(df,+ dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
|
| 83 |
- .var,+ |
||
| 84 | -+ | 1x |
- abnormal,+ adsl1 <- adsl[, adsl_adlb_common_columns] |
| 85 | -+ | 1x |
- na_str = "<Missing>",+ adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID") |
| 86 |
- variables = list(id = "USUBJID", baseline = "BNRIND")) {
+
|
||
| 87 | -7x | +1x |
- checkmate::assert_string(.var)+ by_variables_from_adlb <- c("USUBJID", "AVISIT", "AVISITN", "PARAMCD", "PARAM")
|
| 88 | -7x | +
- checkmate::assert_string(abnormal)+ |
|
| 89 | -7x | +1x |
- checkmate::assert_string(na_str)+ adlb_btoxgr <- adlb %>% |
| 90 | -7x | +1x |
- assert_df_with_variables(df, c(range = .var, variables))+ dplyr::select(c("USUBJID", "PARAMCD", "BTOXGR")) %>%
|
| 91 | -7x | +1x |
- checkmate::assert_subset(names(variables), c("id", "baseline"))
+ unique() %>% |
| 92 | -7x | +1x |
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ dplyr::rename("BTOXGR_MAP" = "BTOXGR")
|
| 93 | -7x | +
- checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
+
|
|
| 94 | -7x | +1x |
- checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
+ adlb_out <- merge( |
| 95 | -+ | 1x |
-
+ adlb_f, |
| 96 | -+ | 1x |
- # If input is passed as character, changed to factor+ adsl_lb, |
| 97 | -7x | +1x |
- df[[.var]] <- as_factor_keep_attributes(df[[.var]], na_level = na_str)+ by = by_variables_from_adlb, |
| 98 | -7x | +1x |
- df[[variables$baseline]] <- as_factor_keep_attributes(df[[variables$baseline]], na_level = na_str)+ all = TRUE, |
| 99 | -+ | 1x |
-
+ sort = FALSE |
| 100 | -7x | +
- assert_valid_factor(df[[.var]], any.missing = FALSE)+ ) |
|
| 101 | -6x | +1x |
- assert_valid_factor(df[[variables$baseline]], any.missing = FALSE)+ adlb_out <- adlb_out %>% |
| 102 | -+ | 1x |
-
+ dplyr::left_join(adlb_btoxgr, by = c("USUBJID", "PARAMCD")) %>%
|
| 103 | -+ | 1x |
- # Keep only records with valid analysis value.+ dplyr::mutate(BTOXGR = .data$BTOXGR_MAP) %>% |
| 104 | -5x | +1x |
- df <- df[df[[.var]] != na_str, ]+ dplyr::select(-"BTOXGR_MAP") |
| 106 | -5x | +1x |
- anl <- data.frame(+ adlb_var_labels <- c( |
| 107 | -5x | +1x |
- id = df[[variables$id]],+ formatters::var_labels(adlb[by_variables_from_adlb]), |
| 108 | -5x | +1x |
- var = df[[.var]],+ formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]), |
| 109 | -5x | +1x |
- baseline = df[[variables$baseline]],+ formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]]) |
| 110 | -5x | +
- stringsAsFactors = FALSE+ ) |
|
| 111 |
- )+ } else {
|
||
| 112 | -+ | 4x |
-
+ adsl_lb <- expand.grid( |
| 113 | -+ | 4x |
- # Total:+ USUBJID = unique(adsl$USUBJID), |
| 114 | -+ | 4x |
- # - Patients in denominator: have at least one valid measurement post-baseline.+ PARAMCD = unique(adlb$PARAMCD) |
| 115 |
- # - Patients in numerator: have at least one abnormality.+ ) |
||
| 116 | -5x | +
- total_denom <- length(unique(anl$id))+ |
|
| 117 | -5x | +4x |
- total_num <- length(unique(anl$id[anl$var == abnormal]))+ adsl_lb <- adsl_lb %>% dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
|
| 119 | -+ | 4x |
- # Baseline NA records are counted only in total rows.+ adsl1 <- adsl[, adsl_adlb_common_columns] |
| 120 | -5x | +4x |
- anl <- anl[anl$baseline != na_str, ]+ adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID") |
| 122 | -+ | 4x |
- # Abnormal:+ by_variables_from_adlb <- c("USUBJID", "PARAMCD", "PARAM")
|
| 123 |
- # - Patients in denominator: have abnormality at baseline.+ |
||
| 124 | -+ | 4x |
- # - Patients in numerator: have abnormality at baseline AND+ adlb_out <- merge( |
| 125 | -+ | 4x |
- # have at least one abnormality post-baseline.+ adlb_f, |
| 126 | -5x | +4x |
- abn_denom <- length(unique(anl$id[anl$baseline == abnormal]))+ adsl_lb, |
| 127 | -5x | +4x |
- abn_num <- length(unique(anl$id[anl$baseline == abnormal & anl$var == abnormal]))+ by = by_variables_from_adlb, |
| 128 | -+ | 4x |
-
+ all = TRUE, |
| 129 | -+ | 4x |
- # Not abnormal:+ sort = FALSE |
| 130 |
- # - Patients in denominator: do not have abnormality at baseline.+ ) |
||
| 131 |
- # - Patients in numerator: do not have abnormality at baseline AND+ |
||
| 132 | -+ | 4x |
- # have at least one abnormality post-baseline.+ adlb_var_labels <- c( |
| 133 | -5x | +4x |
- not_abn_denom <- length(unique(anl$id[anl$baseline != abnormal]))+ formatters::var_labels(adlb[by_variables_from_adlb]), |
| 134 | -5x | +4x |
- not_abn_num <- length(unique(anl$id[anl$baseline != abnormal & anl$var == abnormal]))+ 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 | -5x | +
- labels <- d_count_abnormal_by_baseline(abnormal)+ ) |
|
| 137 | -5x | +
- list(fraction = list(+ } |
|
| 138 | -5x | +
- not_abnormal = formatters::with_label(c(num = not_abn_num, denom = not_abn_denom), labels$not_abnormal),+ |
|
| 139 | 5x |
- abnormal = formatters::with_label(c(num = abn_num, denom = abn_denom), labels$abnormal),+ adlb_out$ATOXGR <- as.factor(adlb_out$ATOXGR) |
|
| 140 | 5x |
- total = formatters::with_label(c(num = total_num, denom = total_denom), labels$total)+ adlb_out$BTOXGR <- as.factor(adlb_out$BTOXGR) |
|
| 141 |
- ))+ |
||
| 142 | -+ | 5x |
- }+ formatters::var_labels(adlb_out) <- adlb_var_labels |
| 144 | -+ | 5x |
- #' @describeIn abnormal_by_baseline Formatted analysis function which is used as `afun`+ adlb_out |
| 145 |
- #' in `count_abnormal_by_baseline()`.+ } |
| 146 | +1 |
- #'+ #' Stack multiple grobs |
||
| 147 | +2 |
- #' @return+ #' |
||
| 148 | +3 |
- #' * `a_count_abnormal_by_baseline()` returns the corresponding list with formatted [rtables::CellValue()].+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 149 | +4 |
#' |
||
| 150 | +5 |
- #' @keywords internal+ #' Stack grobs as a new grob with 1 column and multiple rows layout. |
||
| 151 | +6 |
- a_count_abnormal_by_baseline <- make_afun(+ #' |
||
| 152 | +7 |
- s_count_abnormal_by_baseline,+ #' @param ... grobs. |
||
| 153 | +8 |
- .formats = c(fraction = format_fraction)+ #' @param grobs (`list` of `grob`)\cr a list of grobs. |
||
| 154 | +9 |
- )+ #' @param padding (`grid::unit`)\cr unit of length 1, space between each grob. |
||
| 155 | +10 |
-
+ #' @param vp (`viewport` or `NULL`)\cr a [viewport()] object (or `NULL`). |
||
| 156 | +11 |
- #' @describeIn abnormal_by_baseline Layout-creating function which can take statistics function arguments+ #' @param name (`string`)\cr a character identifier for the grob. |
||
| 157 | +12 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' @param gp (`gpar`)\cr a [gpar()] object. |
||
| 158 | +13 |
#' |
||
| 159 | +14 |
- #' @return+ #' @return A `grob`. |
||
| 160 | +15 |
- #' * `count_abnormal_by_baseline()` returns a layout object suitable for passing to further layouting functions,+ #' |
||
| 161 | +16 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' @examples |
||
| 162 | +17 |
- #' the statistics from `s_count_abnormal_by_baseline()` to the table layout.+ #' library(grid) |
||
| 163 | +18 |
#' |
||
| 164 | +19 |
- #' @examples+ #' g1 <- circleGrob(gp = gpar(col = "blue")) |
||
| 165 | +20 |
- #' df <- data.frame(+ #' g2 <- circleGrob(gp = gpar(col = "red")) |
||
| 166 | +21 |
- #' USUBJID = as.character(c(1:6)),+ #' g3 <- textGrob("TEST TEXT")
|
||
| 167 | +22 |
- #' ANRIND = factor(c(rep("LOW", 4), "NORMAL", "HIGH")),
+ #' grid.newpage() |
||
| 168 | +23 |
- #' BNRIND = factor(c("LOW", "NORMAL", "HIGH", NA, "LOW", "NORMAL"))
+ #' grid.draw(stack_grobs(g1, g2, g3)) |
||
| 169 | +24 |
- #' )+ #' |
||
| 170 | +25 |
- #' df <- df_explicit_na(df)+ #' showViewport() |
||
| 171 | +26 |
#' |
||
| 172 | +27 |
- #' # Layout creating function.+ #' grid.newpage() |
||
| 173 | +28 |
- #' basic_table() %>%+ #' pushViewport(viewport(layout = grid.layout(1, 2))) |
||
| 174 | +29 |
- #' count_abnormal_by_baseline(var = "ANRIND", abnormal = c(High = "HIGH")) %>%+ #' vp1 <- viewport(layout.pos.row = 1, layout.pos.col = 2) |
||
| 175 | +30 |
- #' build_table(df)+ #' grid.draw(stack_grobs(g1, g2, g3, vp = vp1, name = "test")) |
||
| 176 | +31 |
#' |
||
| 177 | -- |
- #' # Passing of statistics function and formatting arguments.- |
- ||
| 178 | -- |
- #' df2 <- data.frame(- |
- ||
| 179 | -- |
- #' ID = as.character(c(1, 2, 3, 4)),- |
- ||
| 180 | +32 |
- #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
+ #' showViewport() |
||
| 181 | +33 |
- #' BLRANGE = factor(c("LOW", "HIGH", "HIGH", "NORMAL"))
+ #' grid.ls(grobs = TRUE, viewports = TRUE, print = FALSE) |
||
| 182 | +34 |
- #' )+ #' |
||
| 183 | +35 |
- #'+ #' @export |
||
| 184 | +36 |
- #' basic_table() %>%+ stack_grobs <- function(..., |
||
| 185 | +37 |
- #' count_abnormal_by_baseline(+ grobs = list(...), |
||
| 186 | +38 |
- #' var = "RANGE",+ padding = grid::unit(2, "line"), |
||
| 187 | +39 |
- #' abnormal = c(Low = "LOW"),+ vp = NULL, |
||
| 188 | +40 |
- #' variables = list(id = "ID", baseline = "BLRANGE"),+ gp = NULL, |
||
| 189 | +41 |
- #' .formats = c(fraction = "xx / xx"),+ name = NULL) {
|
||
| 190 | -+ | |||
| 42 | +4x |
- #' .indent_mods = c(fraction = 2L)+ lifecycle::deprecate_warn( |
||
| 191 | -+ | |||
| 43 | +4x |
- #' ) %>%+ "0.9.4", |
||
| 192 | -+ | |||
| 44 | +4x |
- #' build_table(df2)+ "stack_grobs()", |
||
| 193 | -+ | |||
| 45 | +4x |
- #'+ details = "`tern` plotting functions no longer generate `grob` objects." |
||
| 194 | +46 |
- #' @export+ ) |
||
| 195 | +47 |
- #' @order 2+ |
||
| 196 | -+ | |||
| 48 | +4x |
- count_abnormal_by_baseline <- function(lyt,+ checkmate::assert_true( |
||
| 197 | -+ | |||
| 49 | +4x |
- var,+ all(vapply(grobs, grid::is.grob, logical(1))) |
||
| 198 | +50 |
- abnormal,+ ) |
||
| 199 | +51 |
- variables = list(id = "USUBJID", baseline = "BNRIND"),+ |
||
| 200 | -+ | |||
| 52 | +4x |
- na_str = "<Missing>",+ if (length(grobs) == 1) {
|
||
| 201 | -+ | |||
| 53 | +1x |
- nested = TRUE,+ return(grobs[[1]]) |
||
| 202 | +54 |
- ...,+ } |
||
| 203 | +55 |
- table_names = abnormal,+ |
||
| 204 | -+ | |||
| 56 | +3x |
- .stats = NULL,+ n_layout <- 2 * length(grobs) - 1 |
||
| 205 | -+ | |||
| 57 | +3x |
- .formats = NULL,+ hts <- lapply( |
||
| 206 | -+ | |||
| 58 | +3x |
- .labels = NULL,+ seq(1, n_layout), |
||
| 207 | -+ | |||
| 59 | +3x |
- .indent_mods = NULL) {
+ function(i) {
|
||
| 208 | -2x | +60 | +39x |
- checkmate::assert_character(abnormal, len = length(table_names), names = "named")+ if (i %% 2 != 0) {
|
| 209 | -2x | +61 | +21x |
- checkmate::assert_string(var)+ grid::unit(1, "null") |
| 210 | +62 |
-
+ } else {
|
||
| 211 | -2x | +63 | +18x |
- extra_args <- list(abnormal = abnormal, variables = variables, na_str = na_str, ...)+ padding |
| 212 | +64 | - - | -||
| 213 | -2x | -
- afun <- make_afun(+ } |
||
| 214 | -2x | +|||
| 65 | +
- a_count_abnormal_by_baseline,+ } |
|||
| 215 | -2x | +|||
| 66 | +
- .stats = .stats,+ ) |
|||
| 216 | -2x | +67 | +3x |
- .formats = .formats,+ hts <- do.call(grid::unit.c, hts) |
| 217 | -2x | +|||
| 68 | +
- .labels = .labels,+ |
|||
| 218 | -2x | +69 | +3x |
- .indent_mods = .indent_mods,+ main_vp <- grid::viewport( |
| 219 | -2x | +70 | +3x |
- .ungroup_stats = "fraction"+ layout = grid::grid.layout(nrow = n_layout, ncol = 1, heights = hts) |
| 220 | +71 |
) |
||
| 221 | -2x | -
- for (i in seq_along(abnormal)) {
- |
- ||
| 222 | -4x | -
- extra_args[["abnormal"]] <- abnormal[i]- |
- ||
| 223 | +72 | |||
| 224 | -4x | +73 | +3x |
- lyt <- analyze(+ nested_grobs <- Map(function(g, i) {
|
| 225 | -4x | +74 | +21x |
- lyt = lyt,+ grid::gTree( |
| 226 | -4x | +75 | +21x |
- vars = var,+ children = grid::gList(g), |
| 227 | -4x | +76 | +21x |
- var_labels = names(abnormal[i]),+ vp = grid::viewport(layout.pos.row = i, layout.pos.col = 1) |
| 228 | -4x | +|||
| 77 | +
- afun = afun,+ ) |
|||
| 229 | -4x | +78 | +3x |
- na_str = na_str,+ }, grobs, seq_along(grobs) * 2 - 1) |
| 230 | -4x | +|||
| 79 | +
- nested = nested,+ |
|||
| 231 | -4x | +80 | +3x |
- table_names = table_names[i],+ grobs_mainvp <- grid::gTree( |
| 232 | -4x | +81 | +3x |
- extra_args = extra_args,+ children = do.call(grid::gList, nested_grobs), |
| 233 | -4x | +82 | +3x |
- show_labels = "visible"+ vp = main_vp |
| 234 | +83 |
- )+ ) |
||
| 235 | +84 |
- }+ |
||
| 236 | -2x | +85 | +3x |
- lyt+ grid::gTree( |
| 237 | -+ | |||
| 86 | +3x |
- }+ children = grid::gList(grobs_mainvp), |
| 1 | -+ | |||
| 87 | +3x |
- #' Cox proportional hazards regression+ vp = vp, |
||
| 2 | -+ | |||
| 88 | +3x |
- #'+ gp = gp, |
||
| 3 | -+ | |||
| 89 | +3x |
- #' @description `r lifecycle::badge("stable")`
+ name = name |
||
| 4 | +90 |
- #'+ ) |
||
| 5 | +91 |
- #' Fits a Cox regression model and estimates hazard ratio to describe the effect size in a survival analysis.+ } |
||
| 6 | +92 |
- #'+ |
||
| 7 | +93 |
- #' @inheritParams argument_convention+ #' Arrange multiple grobs |
||
| 8 | +94 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("summarize_coxreg")`
+ #' |
||
| 9 | +95 |
- #' to see available statistics for this function.+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 10 | +96 |
#' |
||
| 11 | +97 |
- #' @details Cox models are the most commonly used methods to estimate the magnitude of+ #' Arrange grobs as a new grob with `n * m (rows * cols)` layout. |
||
| 12 | +98 |
- #' the effect in survival analysis. It assumes proportional hazards: the ratio+ #' |
||
| 13 | +99 |
- #' of the hazards between groups (e.g., two arms) is constant over time.+ #' @inheritParams stack_grobs |
||
| 14 | +100 |
- #' This ratio is referred to as the "hazard ratio" (HR) and is one of the+ #' @param ncol (`integer(1)`)\cr number of columns in layout. |
||
| 15 | +101 |
- #' most commonly reported metrics to describe the effect size in survival+ #' @param nrow (`integer(1)`)\cr number of rows in layout. |
||
| 16 | +102 |
- #' analysis (NEST Team, 2020).+ #' @param padding_ht (`grid::unit`)\cr unit of length 1, vertical space between each grob. |
||
| 17 | +103 |
- #'+ #' @param padding_wt (`grid::unit`)\cr unit of length 1, horizontal space between each grob. |
||
| 18 | +104 |
- #' @seealso [fit_coxreg] for relevant fitting functions, [h_cox_regression] for relevant+ #' |
||
| 19 | +105 |
- #' helper functions, and [tidy_coxreg] for custom tidy methods.+ #' @return A `grob`. |
||
| 20 | +106 |
#' |
||
| 21 | +107 |
#' @examples |
||
| 22 | +108 |
- #' library(survival)+ #' library(grid) |
||
| 23 | +109 |
#' |
||
| 24 | +110 |
- #' # Testing dataset [survival::bladder].+ #' \donttest{
|
||
| 25 | +111 |
- #' set.seed(1, kind = "Mersenne-Twister")+ #' num <- lapply(1:9, textGrob) |
||
| 26 | +112 |
- #' dta_bladder <- with(+ #' grid::grid.newpage() |
||
| 27 | +113 |
- #' data = bladder[bladder$enum < 5, ],+ #' grid.draw(arrange_grobs(grobs = num, ncol = 2)) |
||
| 28 | +114 |
- #' tibble::tibble(+ #' |
||
| 29 | +115 |
- #' TIME = stop,+ #' showViewport() |
||
| 30 | +116 |
- #' STATUS = event,+ #' |
||
| 31 | +117 |
- #' ARM = as.factor(rx),+ #' g1 <- circleGrob(gp = gpar(col = "blue")) |
||
| 32 | +118 |
- #' COVAR1 = as.factor(enum) %>% formatters::with_label("A Covariate Label"),
+ #' g2 <- circleGrob(gp = gpar(col = "red")) |
||
| 33 | +119 |
- #' COVAR2 = factor(+ #' g3 <- textGrob("TEST TEXT")
|
||
| 34 | +120 |
- #' sample(as.factor(enum)),+ #' grid::grid.newpage() |
||
| 35 | +121 |
- #' levels = 1:4, labels = c("F", "F", "M", "M")
+ #' grid.draw(arrange_grobs(g1, g2, g3, nrow = 2)) |
||
| 36 | +122 |
- #' ) %>% formatters::with_label("Sex (F/M)")
+ #' |
||
| 37 | +123 |
- #' )+ #' showViewport() |
||
| 38 | +124 |
- #' )+ #' |
||
| 39 | +125 |
- #' dta_bladder$AGE <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ #' grid::grid.newpage() |
||
| 40 | +126 |
- #' dta_bladder$STUDYID <- factor("X")
+ #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 3)) |
||
| 41 | +127 |
#' |
||
| 42 | +128 |
- #' u1_variables <- list(+ #' grid::grid.newpage() |
||
| 43 | +129 |
- #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
+ #' grid::pushViewport(grid::viewport(layout = grid::grid.layout(1, 2))) |
||
| 44 | +130 |
- #' )+ #' vp1 <- grid::viewport(layout.pos.row = 1, layout.pos.col = 2) |
||
| 45 | +131 |
- #'+ #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 2, vp = vp1)) |
||
| 46 | +132 |
- #' u2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
+ #' |
||
| 47 | +133 |
- #'+ #' showViewport() |
||
| 48 | +134 |
- #' m1_variables <- list(+ #' } |
||
| 49 | +135 |
- #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
+ #' @export |
||
| 50 | +136 |
- #' )+ arrange_grobs <- function(..., |
||
| 51 | +137 |
- #'+ grobs = list(...), |
||
| 52 | +138 |
- #' m2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
+ ncol = NULL, nrow = NULL, |
||
| 53 | +139 |
- #'+ padding_ht = grid::unit(2, "line"), |
||
| 54 | +140 |
- #' @name cox_regression+ padding_wt = grid::unit(2, "line"), |
||
| 55 | +141 |
- #' @order 1+ vp = NULL, |
||
| 56 | +142 |
- NULL+ gp = NULL, |
||
| 57 | +143 |
-
+ name = NULL) {
|
||
| 58 | -+ | |||
| 144 | +5x |
- #' @describeIn cox_regression Statistics function that transforms results tabulated+ lifecycle::deprecate_warn( |
||
| 59 | -+ | |||
| 145 | +5x |
- #' from [fit_coxreg_univar()] or [fit_coxreg_multivar()] into a list.+ "0.9.4", |
||
| 60 | -+ | |||
| 146 | +5x |
- #'+ "arrange_grobs()", |
||
| 61 | -+ | |||
| 147 | +5x |
- #' @param model_df (`data.frame`)\cr contains the resulting model fit from a [fit_coxreg]+ details = "`tern` plotting functions no longer generate `grob` objects." |
||
| 62 | +148 |
- #' function with tidying applied via [broom::tidy()].+ ) |
||
| 63 | +149 |
- #' @param .stats (`character`)\cr the names of statistics to be reported among:+ |
||
| 64 | -+ | |||
| 150 | +5x |
- #' * `n`: number of observations (univariate only)+ checkmate::assert_true( |
||
| 65 | -+ | |||
| 151 | +5x |
- #' * `hr`: hazard ratio+ all(vapply(grobs, grid::is.grob, logical(1))) |
||
| 66 | +152 |
- #' * `ci`: confidence interval+ ) |
||
| 67 | +153 |
- #' * `pval`: p-value of the treatment effect+ |
||
| 68 | -+ | |||
| 154 | +5x |
- #' * `pval_inter`: p-value of the interaction effect between the treatment and the covariate (univariate only)+ if (length(grobs) == 1) {
|
||
| 69 | -+ | |||
| 155 | +1x |
- #' @param .which_vars (`character`)\cr which rows should statistics be returned for from the given model.+ return(grobs[[1]]) |
||
| 70 | +156 |
- #' Defaults to `"all"`. Other options include `"var_main"` for main effects, `"inter"` for interaction effects,+ } |
||
| 71 | +157 |
- #' and `"multi_lvl"` for multivariate model covariate level rows. When `.which_vars` is `"all"`, specific+ |
||
| 72 | -+ | |||
| 158 | +4x |
- #' variables can be selected by specifying `.var_nms`.+ if (is.null(ncol) && is.null(nrow)) {
|
||
| 73 | -+ | |||
| 159 | +1x |
- #' @param .var_nms (`character`)\cr the `term` value of rows in `df` for which `.stats` should be returned. Typically+ ncol <- 1 |
||
| 74 | -+ | |||
| 160 | +1x |
- #' this is the name of a variable. If using variable labels, `var` should be a vector of both the desired+ nrow <- ceiling(length(grobs) / ncol) |
||
| 75 | -+ | |||
| 161 | +3x |
- #' variable name and the variable label in that order to see all `.stats` related to that variable. When `.which_vars`+ } else if (!is.null(ncol) && is.null(nrow)) {
|
||
| 76 | -+ | |||
| 162 | +1x |
- #' is `"var_main"`, `.var_nms` should be only the variable name.+ nrow <- ceiling(length(grobs) / ncol) |
||
| 77 | -+ | |||
| 163 | +2x |
- #'+ } else if (is.null(ncol) && !is.null(nrow)) {
|
||
| 78 | -+ | |||
| 164 | +! |
- #' @return+ ncol <- ceiling(length(grobs) / nrow) |
||
| 79 | +165 |
- #' * `s_coxreg()` returns the selected statistic for from the Cox regression model for the selected variable(s).+ } |
||
| 80 | +166 |
- #'+ |
||
| 81 | -+ | |||
| 167 | +4x |
- #' @examples+ if (ncol * nrow < length(grobs)) {
|
||
| 82 | -+ | |||
| 168 | +1x |
- #' # s_coxreg+ stop("specififed ncol and nrow are not enough for arranging the grobs ")
|
||
| 83 | +169 |
- #'+ } |
||
| 84 | +170 |
- #' # Univariate+ |
||
| 85 | -+ | |||
| 171 | +3x |
- #' univar_model <- fit_coxreg_univar(variables = u1_variables, data = dta_bladder)+ if (ncol == 1) {
|
||
| 86 | -+ | |||
| 172 | +2x |
- #' df1 <- broom::tidy(univar_model)+ return(stack_grobs(grobs = grobs, padding = padding_ht, vp = vp, gp = gp, name = name)) |
||
| 87 | +173 |
- #'+ } |
||
| 88 | +174 |
- #' s_coxreg(model_df = df1, .stats = "hr")+ |
||
| 89 | -+ | |||
| 175 | +1x |
- #'+ n_col <- 2 * ncol - 1 |
||
| 90 | -+ | |||
| 176 | +1x |
- #' # Univariate with interactions+ n_row <- 2 * nrow - 1 |
||
| 91 | -+ | |||
| 177 | +1x |
- #' univar_model_inter <- fit_coxreg_univar(+ hts <- lapply( |
||
| 92 | -+ | |||
| 178 | +1x |
- #' variables = u1_variables, control = control_coxreg(interaction = TRUE), data = dta_bladder+ seq(1, n_row), |
||
| 93 | -+ | |||
| 179 | +1x |
- #' )+ function(i) {
|
||
| 94 | -+ | |||
| 180 | +5x |
- #' df1_inter <- broom::tidy(univar_model_inter)+ if (i %% 2 != 0) {
|
||
| 95 | -+ | |||
| 181 | +3x |
- #'+ grid::unit(1, "null") |
||
| 96 | +182 |
- #' s_coxreg(model_df = df1_inter, .stats = "hr", .which_vars = "inter", .var_nms = "COVAR1")+ } else {
|
||
| 97 | -+ | |||
| 183 | +2x |
- #'+ padding_ht |
||
| 98 | +184 |
- #' # Univariate without treatment arm - only "COVAR2" covariate effects+ } |
||
| 99 | +185 |
- #' univar_covs_model <- fit_coxreg_univar(variables = u2_variables, data = dta_bladder)+ } |
||
| 100 | +186 |
- #' df1_covs <- broom::tidy(univar_covs_model)+ ) |
||
| 101 | -+ | |||
| 187 | +1x |
- #'+ hts <- do.call(grid::unit.c, hts) |
||
| 102 | +188 |
- #' s_coxreg(model_df = df1_covs, .stats = "hr", .var_nms = c("COVAR2", "Sex (F/M)"))
+
|
||
| 103 | -+ | |||
| 189 | +1x |
- #'+ wts <- lapply( |
||
| 104 | -+ | |||
| 190 | +1x |
- #' # Multivariate.+ seq(1, n_col), |
||
| 105 | -+ | |||
| 191 | +1x |
- #' multivar_model <- fit_coxreg_multivar(variables = m1_variables, data = dta_bladder)+ function(i) {
|
||
| 106 | -+ | |||
| 192 | +5x |
- #' df2 <- broom::tidy(multivar_model)+ if (i %% 2 != 0) {
|
||
| 107 | -+ | |||
| 193 | +3x |
- #'+ grid::unit(1, "null") |
||
| 108 | +194 |
- #' s_coxreg(model_df = df2, .stats = "pval", .which_vars = "var_main", .var_nms = "COVAR1")+ } else {
|
||
| 109 | -+ | |||
| 195 | +2x |
- #' s_coxreg(+ padding_wt |
||
| 110 | +196 |
- #' model_df = df2, .stats = "pval", .which_vars = "multi_lvl",+ } |
||
| 111 | +197 |
- #' .var_nms = c("COVAR1", "A Covariate Label")
+ } |
||
| 112 | +198 |
- #' )+ ) |
||
| 113 | -+ | |||
| 199 | +1x |
- #'+ wts <- do.call(grid::unit.c, wts) |
||
| 114 | +200 |
- #' # Multivariate without treatment arm - only "COVAR1" main effect+ |
||
| 115 | -+ | |||
| 201 | +1x |
- #' multivar_covs_model <- fit_coxreg_multivar(variables = m2_variables, data = dta_bladder)+ main_vp <- grid::viewport( |
||
| 116 | -+ | |||
| 202 | +1x |
- #' df2_covs <- broom::tidy(multivar_covs_model)+ layout = grid::grid.layout(nrow = n_row, ncol = n_col, widths = wts, heights = hts) |
||
| 117 | +203 |
- #'+ ) |
||
| 118 | +204 |
- #' s_coxreg(model_df = df2_covs, .stats = "hr")+ |
||
| 119 | -+ | |||
| 205 | +1x |
- #'+ nested_grobs <- list() |
||
| 120 | -+ | |||
| 206 | +1x |
- #' @export+ k <- 0 |
||
| 121 | -+ | |||
| 207 | +1x |
- s_coxreg <- function(model_df, .stats, .which_vars = "all", .var_nms = NULL) {
+ for (i in seq(nrow) * 2 - 1) {
|
||
| 122 | -291x | +208 | +3x |
- assert_df_with_variables(model_df, list(term = "term", stat = .stats))+ for (j in seq(ncol) * 2 - 1) {
|
| 123 | -291x | +209 | +9x |
- checkmate::assert_multi_class(model_df$term, classes = c("factor", "character"))
+ k <- k + 1 |
| 124 | -291x | +210 | +9x |
- model_df$term <- as.character(model_df$term)+ if (k <= length(grobs)) {
|
| 125 | -291x | +211 | +9x |
- .var_nms <- .var_nms[!is.na(.var_nms)]+ nested_grobs <- c( |
| 126 | -+ | |||
| 212 | +9x |
-
+ nested_grobs, |
||
| 127 | -289x | +213 | +9x |
- if (length(.var_nms) > 0) model_df <- model_df[model_df$term %in% .var_nms, ]+ list(grid::gTree( |
| 128 | -69x | +214 | +9x |
- if (.which_vars == "multi_lvl") model_df$term <- tail(.var_nms, 1)+ children = grid::gList(grobs[[k]]), |
| 129 | -+ | |||
| 215 | +9x |
-
+ vp = grid::viewport(layout.pos.row = i, layout.pos.col = j) |
||
| 130 | +216 |
- # We need a list with names corresponding to the stats to display of equal length to the list of stats.+ )) |
||
| 131 | -291x | +|||
| 217 | +
- y <- split(model_df, f = model_df$term, drop = FALSE)+ ) |
|||
| 132 | -291x | +|||
| 218 | +
- y <- stats::setNames(y, nm = rep(.stats, length(y)))+ } |
|||
| 133 | +219 |
-
+ } |
||
| 134 | -291x | +|||
| 220 | +
- if (.which_vars == "var_main") {
+ } |
|||
| 135 | -128x | +221 | +1x |
- y <- lapply(y, function(x) x[1, ]) # only main effect+ grobs_mainvp <- grid::gTree( |
| 136 | -163x | +222 | +1x |
- } else if (.which_vars %in% c("inter", "multi_lvl")) {
+ children = do.call(grid::gList, nested_grobs), |
| 137 | -120x | +223 | +1x |
- y <- lapply(y, function(x) if (nrow(y[[1]]) > 1) x[-1, ] else x) # exclude main effect+ vp = main_vp |
| 138 | +224 |
- }+ ) |
||
| 139 | +225 | |||
| 140 | -291x | +226 | +1x |
- lapply(+ grid::gTree( |
| 141 | -291x | +227 | +1x |
- X = y,+ children = grid::gList(grobs_mainvp), |
| 142 | -291x | +228 | +1x |
- FUN = function(x) {
+ vp = vp, |
| 143 | -295x | +229 | +1x |
- z <- as.list(x[[.stats]])+ gp = gp, |
| 144 | -295x | -
- stats::setNames(z, nm = x$term_label)- |
- ||
| 145 | -+ | 230 | +1x |
- }+ name = name |
| 146 | +231 |
) |
||
| 147 | +232 |
} |
||
| 148 | +233 | |||
| 149 | +234 |
- #' @describeIn cox_regression Analysis function which is used as `afun` in [rtables::analyze()]+ #' Draw `grob` |
||
| 150 | +235 |
- #' and `cfun` in [rtables::summarize_row_groups()] within `summarize_coxreg()`.+ #' |
||
| 151 | +236 |
- #'+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 152 | +237 |
- #' @param eff (`flag`)\cr whether treatment effect should be calculated. Defaults to `FALSE`.+ #' |
||
| 153 | +238 |
- #' @param var_main (`flag`)\cr whether main effects should be calculated. Defaults to `FALSE`.+ #' Draw grob on device page. |
||
| 154 | +239 |
- #' @param na_str (`string`)\cr custom string to replace all `NA` values with. Defaults to `""`.+ #' |
||
| 155 | +240 |
- #' @param cache_env (`environment`)\cr an environment object used to cache the regression model in order to+ #' @param grob (`grob`)\cr grid object. |
||
| 156 | +241 |
- #' avoid repeatedly fitting the same model for every row in the table. Defaults to `NULL` (no caching).+ #' @param newpage (`flag`)\cr draw on a new page. |
||
| 157 | +242 |
- #' @param varlabels (`list`)\cr a named list corresponds to the names of variables found in data, passed+ #' @param vp (`viewport` or `NULL`)\cr a [viewport()] object (or `NULL`). |
||
| 158 | +243 |
- #' as a named list and corresponding to time, event, arm, strata, and covariates terms. If arm is missing+ #' |
||
| 159 | +244 |
- #' from variables, then only Cox model(s) including the covariates will be fitted and the corresponding+ #' @return A `grob`. |
||
| 160 | +245 |
- #' effect estimates will be tabulated later.+ #' |
||
| 161 | +246 |
- #'+ #' @examples |
||
| 162 | +247 |
- #' @return+ #' library(dplyr) |
||
| 163 | +248 |
- #' * `a_coxreg()` returns formatted [rtables::CellValue()].+ #' library(grid) |
||
| 164 | +249 |
#' |
||
| 165 | +250 |
- #' @examples+ #' \donttest{
|
||
| 166 | +251 |
- #' a_coxreg(+ #' rect <- rectGrob(width = grid::unit(0.5, "npc"), height = grid::unit(0.5, "npc")) |
||
| 167 | +252 |
- #' df = dta_bladder,+ #' rect %>% draw_grob(vp = grid::viewport(angle = 45)) |
||
| 168 | +253 |
- #' labelstr = "Label 1",+ #' |
||
| 169 | +254 |
- #' variables = u1_variables,+ #' num <- lapply(1:10, textGrob) |
||
| 170 | +255 |
- #' .spl_context = list(value = "COVAR1"),+ #' num %>% |
||
| 171 | +256 |
- #' .stats = "n",+ #' arrange_grobs(grobs = .) %>% |
||
| 172 | +257 |
- #' .formats = "xx"+ #' draw_grob() |
||
| 173 | +258 |
- #' )+ #' showViewport() |
||
| 174 | +259 |
- #'+ #' } |
||
| 175 | +260 |
- #' a_coxreg(+ #' |
||
| 176 | +261 |
- #' df = dta_bladder,+ #' @export |
||
| 177 | +262 |
- #' labelstr = "",+ draw_grob <- function(grob, newpage = TRUE, vp = NULL) {
|
||
| 178 | -+ | |||
| 263 | +3x |
- #' variables = u1_variables,+ lifecycle::deprecate_warn( |
||
| 179 | -+ | |||
| 264 | +3x |
- #' .spl_context = list(value = "COVAR2"),+ "0.9.4", |
||
| 180 | -+ | |||
| 265 | +3x |
- #' .stats = "pval",+ "draw_grob()", |
||
| 181 | -+ | |||
| 266 | +3x |
- #' .formats = "xx.xxxx"+ details = "`tern` plotting functions no longer generate `grob` objects." |
||
| 182 | +267 |
- #' )+ ) |
||
| 183 | +268 |
- #'+ |
||
| 184 | -+ | |||
| 269 | +3x |
- #' @export+ if (newpage) {
|
||
| 185 | -+ | |||
| 270 | +3x |
- a_coxreg <- function(df,+ grid::grid.newpage() |
||
| 186 | +271 |
- labelstr,+ } |
||
| 187 | -+ | |||
| 272 | +3x |
- eff = FALSE,+ if (!is.null(vp)) {
|
||
| 188 | -+ | |||
| 273 | +1x |
- var_main = FALSE,+ grid::pushViewport(vp) |
||
| 189 | +274 |
- multivar = FALSE,+ } |
||
| 190 | -+ | |||
| 275 | +3x |
- variables,+ grid::grid.draw(grob) |
||
| 191 | +276 |
- at = list(),+ } |
||
| 192 | +277 |
- control = control_coxreg(),+ |
||
| 193 | +278 |
- .spl_context,+ tern_grob <- function(x) {
|
||
| 194 | -+ | |||
| 279 | +! |
- .stats,+ class(x) <- unique(c("ternGrob", class(x)))
|
||
| 195 | -+ | |||
| 280 | +! |
- .formats,+ x |
||
| 196 | +281 |
- .indent_mods = NULL,+ } |
||
| 197 | +282 |
- na_str = "",+ |
||
| 198 | +283 |
- cache_env = NULL) {
- |
- ||
| 199 | -288x | -
- cov_no_arm <- !multivar && !"arm" %in% names(variables) && control$interaction # special case: univar no arm- |
- ||
| 200 | -288x | -
- cov <- tail(.spl_context$value, 1) # current variable/covariate- |
- ||
| 201 | -288x | -
- var_lbl <- formatters::var_labels(df)[cov] # check for df labels- |
- ||
| 202 | -288x | -
- if (length(labelstr) > 1) {
+ #' @keywords internal |
||
| 203 | -8x | +|||
| 284 | +
- labelstr <- if (cov %in% names(labelstr)) labelstr[[cov]] else var_lbl # use df labels if none+ print.ternGrob <- function(x, ...) {
|
|||
| 204 | -280x | +|||
| 285 | +! |
- } else if (!is.na(var_lbl) && labelstr == cov && cov %in% variables$covariates) {
+ grid::grid.newpage() |
||
| 205 | -67x | +|||
| 286 | +! |
- labelstr <- var_lbl+ grid::grid.draw(x) |
||
| 206 | +287 |
- }- |
- ||
| 207 | -288x | -
- if (eff || multivar || cov_no_arm) {
+ } |
||
| 208 | -143x | +
| 1 | +
- control$interaction <- FALSE+ # Utility functions to cooperate with {rtables} package
|
|||
| 209 | +2 |
- } else {
+
|
||
| 210 | -145x | +|||
| 3 | +
- variables$covariates <- cov+ #' Convert table into matrix of strings |
|||
| 211 | -50x | +|||
| 4 | +
- if (var_main) control$interaction <- TRUE+ #' |
|||
| 212 | +5 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 213 | +6 |
-
+ #' |
||
| 214 | -288x | +|||
| 7 | +
- if (is.null(cache_env[[cov]])) {
+ #' Helper function to use mostly within tests. `with_spaces`parameter allows |
|||
| 215 | -47x | +|||
| 8 | +
- if (!multivar) {
+ #' to test not only for content but also indentation and table structure. |
|||
| 216 | -32x | +|||
| 9 | +
- model <- fit_coxreg_univar(variables = variables, data = df, at = at, control = control) %>% broom::tidy()+ #' `print_txt_to_copy` instead facilitate the testing development by returning a well |
|||
| 217 | +10 |
- } else {
+ #' formatted text that needs only to be copied and pasted in the expected output. |
||
| 218 | -15x | +|||
| 11 | +
- model <- fit_coxreg_multivar(variables = variables, data = df, control = control) %>% broom::tidy()+ #' |
|||
| 219 | +12 |
- }+ #' @inheritParams formatters::toString |
||
| 220 | -47x | +|||
| 13 | +
- cache_env[[cov]] <- model+ #' @param x (`VTableTree`)\cr `rtables` table object. |
|||
| 221 | +14 |
- } else {
+ #' @param with_spaces (`flag`)\cr whether the tested table should keep the indentation and other relevant spaces. |
||
| 222 | -241x | +|||
| 15 | +
- model <- cache_env[[cov]]+ #' @param print_txt_to_copy (`flag`)\cr utility to have a way to copy the input table directly |
|||
| 223 | +16 |
- }+ #' into the expected variable instead of copying it too manually. |
||
| 224 | -148x | +|||
| 17 | +
- if (!multivar && !var_main) model[, "pval_inter"] <- NA_real_+ #' |
|||
| 225 | +18 |
-
+ #' @return A `matrix` of `string`s. If `print_txt_to_copy = TRUE` the well formatted printout of the |
||
| 226 | -288x | +|||
| 19 | +
- if (cov_no_arm || (!cov_no_arm && !"arm" %in% names(variables) && is.numeric(df[[cov]]))) {
+ #' table will be printed to console, ready to be copied as a expected value. |
|||
| 227 | -15x | +|||
| 20 | +
- multivar <- TRUE+ #' |
|||
| 228 | -3x | +|||
| 21 | +
- if (!cov_no_arm) var_main <- TRUE+ #' @examples |
|||
| 229 | +22 |
- }+ #' tbl <- basic_table() %>% |
||
| 230 | +23 |
-
+ #' split_rows_by("SEX") %>%
|
||
| 231 | -288x | +|||
| 24 | +
- vars_coxreg <- list(which_vars = "all", var_nms = NULL)+ #' split_cols_by("ARM") %>%
|
|||
| 232 | -288x | +|||
| 25 | +
- if (eff) {
+ #' analyze("AGE") %>%
|
|||
| 233 | -65x | +|||
| 26 | +
- if (multivar && !var_main) { # multivar treatment level
+ #' build_table(tern_ex_adsl) |
|||
| 234 | -12x | +|||
| 27 | +
- var_lbl_arm <- formatters::var_labels(df)[[variables$arm]]+ #' |
|||
| 235 | -12x | +|||
| 28 | +
- vars_coxreg[c("var_nms", "which_vars")] <- list(c(variables$arm, var_lbl_arm), "multi_lvl")
+ #' to_string_matrix(tbl, widths = ceiling(propose_column_widths(tbl) / 2)) |
|||
| 236 | +29 |
- } else { # treatment effect
+ #' |
||
| 237 | -53x | +|||
| 30 | +
- vars_coxreg["var_nms"] <- variables$arm+ #' @export |
|||
| 238 | -12x | +|||
| 31 | +
- if (var_main) vars_coxreg["which_vars"] <- "var_main"+ to_string_matrix <- function(x, widths = NULL, max_width = NULL, |
|||
| 239 | +32 |
- }+ hsep = formatters::default_hsep(), |
||
| 240 | +33 |
- } else {
+ with_spaces = TRUE, print_txt_to_copy = FALSE) {
|
||
| 241 | -223x | +34 | +11x |
- if (!multivar || (multivar && var_main && !is.numeric(df[[cov]]))) { # covariate effect/level
+ checkmate::assert_flag(with_spaces) |
| 242 | -166x | +35 | +11x |
- vars_coxreg[c("var_nms", "which_vars")] <- list(cov, "var_main")
+ checkmate::assert_flag(print_txt_to_copy) |
| 243 | -57x | +36 | +11x |
- } else if (multivar) { # multivar covariate level
+ checkmate::assert_int(max_width, null.ok = TRUE) |
| 244 | -57x | +|||
| 37 | +
- vars_coxreg[c("var_nms", "which_vars")] <- list(c(cov, var_lbl), "multi_lvl")
+
|
|||
| 245 | -12x | +38 | +11x |
- if (var_main) model[cov, .stats] <- NA_real_+ if (inherits(x, "MatrixPrintForm")) {
+ |
+
| 39 | +! | +
+ tx <- x |
||
| 246 | +40 |
- }+ } else {
|
||
| 247 | -50x | +41 | +11x |
- if (!multivar && !var_main && control$interaction) vars_coxreg["which_vars"] <- "inter" # interaction effect+ tx <- matrix_form(x, TRUE) |
| 248 | +42 |
} |
||
| 249 | -288x | +|||
| 43 | +
- var_vals <- s_coxreg(model, .stats, .which_vars = vars_coxreg$which_vars, .var_nms = vars_coxreg$var_nms)[[1]]+ |
|||
| 250 | -288x | +44 | +11x |
- var_names <- if (all(grepl("\\(reference = ", names(var_vals))) && labelstr != tail(.spl_context$value, 1)) {
+ tf_wrap <- FALSE |
| 251 | -27x | +45 | +11x |
- paste(c(labelstr, tail(strsplit(names(var_vals), " ")[[1]], 3)), collapse = " ") # "reference" main effect labels+ if (!is.null(max_width)) {
|
| 252 | -288x | +|||
| 46 | +! |
- } else if ((!multivar && !eff && !(!var_main && control$interaction) && nchar(labelstr) > 0) ||+ tf_wrap <- TRUE |
||
| 253 | -288x | +|||
| 47 | +
- (multivar && var_main && is.numeric(df[[cov]]))) { # nolint
+ } |
|||
| 254 | -71x | +|||
| 48 | +
- labelstr # other main effect labels+ + |
+ |||
| 49 | ++ |
+ # Producing the matrix to test |
||
| 255 | -288x | +50 | +11x |
- } else if (multivar && !eff && !var_main && is.numeric(df[[cov]])) {
+ if (with_spaces) {
|
| 256 | -12x | +51 | +2x |
- "All" # multivar numeric covariate+ out <- strsplit(toString(tx, widths = widths, tf_wrap = tf_wrap, max_width = max_width, hsep = hsep), "\n")[[1]] |
| 257 | +52 |
} else {
|
||
| 258 | -178x | +53 | +9x |
- names(var_vals)+ out <- tx$strings |
| 259 | +54 |
} |
||
| 55 | ++ | + + | +||
| 56 | ++ |
+ # Printing to console formatted output that needs to be copied in "expected"+ |
+ ||
| 260 | -288x | +57 | +11x |
- in_rows(+ if (print_txt_to_copy) {
|
| 261 | -288x | +58 | +2x |
- .list = var_vals, .names = var_names, .labels = var_names, .indent_mods = .indent_mods,+ out_tmp <- out |
| 262 | -288x | +59 | +2x |
- .formats = stats::setNames(rep(.formats, length(var_names)), var_names),+ if (!with_spaces) {
|
| 263 | -288x | +60 | +1x |
- .format_na_strs = stats::setNames(rep(na_str, length(var_names)), var_names)+ out_tmp <- apply(out, 1, paste0, collapse = '", "') |
| 264 | +61 |
- )+ }+ |
+ ||
| 62 | +2x | +
+ cat(paste0('c(\n "', paste0(out_tmp, collapse = '",\n "'), '"\n)'))
|
||
| 265 | +63 |
- }+ } |
||
| 266 | +64 | |||
| 267 | +65 |
- #' @describeIn cox_regression Layout-creating function which creates a Cox regression summary table+ # Return values |
||
| 268 | -+ | |||
| 66 | +11x |
- #' layout. This function is a wrapper for several `rtables` layouting functions. This function+ return(out) |
||
| 269 | +67 |
- #' is a wrapper for [rtables::analyze_colvars()] and [rtables::summarize_row_groups()].+ } |
||
| 270 | +68 |
- #'+ |
||
| 271 | +69 |
- #' @inheritParams fit_coxreg_univar+ #' Blank for missing input |
||
| 272 | +70 |
- #' @param multivar (`flag`)\cr whether multivariate Cox regression should run (defaults to `FALSE`), otherwise+ #' |
||
| 273 | +71 |
- #' univariate Cox regression will run.+ #' Helper function to use in tabulating model results. |
||
| 274 | +72 |
- #' @param common_var (`string`)\cr the name of a factor variable in the dataset which takes the same value+ #' |
||
| 275 | +73 |
- #' for all rows. This should be created during pre-processing if no such variable currently exists.+ #' @param x (`vector`)\cr input for a cell. |
||
| 276 | +74 |
- #' @param .section_div (`string` or `NA`)\cr string which should be repeated as a section divider between sections.+ #' |
||
| 277 | +75 |
- #' Defaults to `NA` for no section divider. If a vector of two strings are given, the first will be used between+ #' @return An empty `character` vector if all entries in `x` are missing (`NA`), otherwise |
||
| 278 | +76 |
- #' treatment and covariate sections and the second between different covariates.+ #' the unlisted version of `x`. |
||
| 279 | +77 |
#' |
||
| 280 | +78 |
- #' @return+ #' @keywords internal |
||
| 281 | +79 |
- #' * `summarize_coxreg()` returns a layout object suitable for passing to further layouting functions,+ unlist_and_blank_na <- function(x) {
|
||
| 282 | -+ | |||
| 80 | +267x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add a Cox regression table+ unl <- unlist(x) |
||
| 283 | -+ | |||
| 81 | +267x |
- #' containing the chosen statistics to the table layout.+ if (all(is.na(unl))) {
|
||
| 284 | -+ | |||
| 82 | +161x |
- #'+ character() |
||
| 285 | +83 |
- #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()] which also take the `variables`, `data`,+ } else {
|
||
| 286 | -+ | |||
| 84 | +106x |
- #' `at` (univariate only), and `control` arguments but return unformatted univariate and multivariate+ unl |
||
| 287 | +85 |
- #' Cox regression models, respectively.+ } |
||
| 288 | +86 |
- #'+ } |
||
| 289 | +87 |
- #' @examples+ |
||
| 290 | +88 |
- #' # summarize_coxreg+ #' Constructor for content functions given a data frame with flag input |
||
| 291 | +89 |
#' |
||
| 292 | +90 |
- #' result_univar <- basic_table() %>%+ #' This can be useful for tabulating model results. |
||
| 293 | +91 |
- #' summarize_coxreg(variables = u1_variables) %>%+ #' |
||
| 294 | +92 |
- #' build_table(dta_bladder)+ #' @param analysis_var (`string`)\cr variable name for the column containing values to be returned by the |
||
| 295 | +93 |
- #' result_univar+ #' content function. |
||
| 296 | +94 |
- #'+ #' @param flag_var (`string`)\cr variable name for the logical column identifying which row should be returned. |
||
| 297 | +95 |
- #' result_univar_covs <- basic_table() %>%+ #' @param format (`string`)\cr `rtables` format to use. |
||
| 298 | +96 |
- #' summarize_coxreg(+ #' |
||
| 299 | +97 |
- #' variables = u2_variables,+ #' @return A content function which gives `df$analysis_var` at the row identified by |
||
| 300 | +98 |
- #' ) %>%+ #' `.df_row$flag` in the given format. |
||
| 301 | +99 |
- #' build_table(dta_bladder)+ #' |
||
| 302 | +100 |
- #' result_univar_covs+ #' @keywords internal |
||
| 303 | +101 |
- #'+ cfun_by_flag <- function(analysis_var, |
||
| 304 | +102 |
- #' result_multivar <- basic_table() %>%+ flag_var, |
||
| 305 | +103 |
- #' summarize_coxreg(+ format = "xx", |
||
| 306 | +104 |
- #' variables = m1_variables,+ .indent_mods = NULL) {
|
||
| 307 | -+ | |||
| 105 | +61x |
- #' multivar = TRUE,+ checkmate::assert_string(analysis_var) |
||
| 308 | -+ | |||
| 106 | +61x |
- #' ) %>%+ checkmate::assert_string(flag_var) |
||
| 309 | -+ | |||
| 107 | +61x |
- #' build_table(dta_bladder)+ function(df, labelstr) {
|
||
| 310 | -+ | |||
| 108 | +265x |
- #' result_multivar+ row_index <- which(df[[flag_var]]) |
||
| 311 | -+ | |||
| 109 | +265x |
- #'+ x <- unlist_and_blank_na(df[[analysis_var]][row_index]) |
||
| 312 | -+ | |||
| 110 | +265x |
- #' result_multivar_covs <- basic_table() %>%+ formatters::with_label( |
||
| 313 | -+ | |||
| 111 | +265x |
- #' summarize_coxreg(+ rcell(x, format = format, indent_mod = .indent_mods),+ |
+ ||
| 112 | +265x | +
+ labelstr |
||
| 314 | +113 |
- #' variables = m2_variables,+ ) |
||
| 315 | +114 |
- #' multivar = TRUE,+ } |
||
| 316 | +115 |
- #' varlabels = c("Covariate 1", "Covariate 2") # custom labels
+ } |
||
| 317 | +116 |
- #' ) %>%+ |
||
| 318 | +117 |
- #' build_table(dta_bladder)+ #' Content row function to add row total to labels |
||
| 319 | +118 |
- #' result_multivar_covs+ #' |
||
| 320 | +119 |
- #'+ #' This takes the label of the latest row split level and adds the row total from `df` in parentheses. |
||
| 321 | +120 |
- #' @export+ #' This function differs from [c_label_n_alt()] by taking row counts from `df` rather than |
||
| 322 | +121 |
- #' @order 2+ #' `alt_counts_df`, and is used by [add_rowcounts()] when `alt_counts` is set to `FALSE`. |
||
| 323 | +122 |
- summarize_coxreg <- function(lyt,+ #' |
||
| 324 | +123 |
- variables,+ #' @inheritParams argument_convention |
||
| 325 | +124 |
- control = control_coxreg(),+ #' |
||
| 326 | +125 |
- at = list(),+ #' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label. |
||
| 327 | +126 |
- multivar = FALSE,+ #' |
||
| 328 | +127 |
- common_var = "STUDYID",+ #' @note It is important here to not use `df` but rather `.N_row` in the implementation, because |
||
| 329 | +128 |
- .stats = c("n", "hr", "ci", "pval", "pval_inter"),
+ #' the former is already split by columns and will refer to the first column of the data only. |
||
| 330 | +129 |
- .formats = c(+ #' |
||
| 331 | +130 |
- n = "xx", hr = "xx.xx", ci = "(xx.xx, xx.xx)",+ #' @seealso [c_label_n_alt()] which performs the same function but retrieves row counts from |
||
| 332 | +131 |
- pval = "x.xxxx | (<0.0001)", pval_inter = "x.xxxx | (<0.0001)"+ #' `alt_counts_df` instead of `df`. |
||
| 333 | +132 |
- ),+ #' |
||
| 334 | +133 |
- varlabels = NULL,+ #' @keywords internal |
||
| 335 | +134 |
- .indent_mods = NULL,+ c_label_n <- function(df, |
||
| 336 | +135 |
- na_str = "",+ labelstr, |
||
| 337 | +136 |
- .section_div = NA_character_) {
+ .N_row) { # nolint
|
||
| 338 | -16x | +137 | +273x |
- if (multivar && control$interaction) {
+ label <- paste0(labelstr, " (N=", .N_row, ")") |
| 339 | -1x | +138 | +273x |
- warning(paste(+ in_rows( |
| 340 | -1x | +139 | +273x |
- "Interactions are not available for multivariate cox regression using summarize_coxreg.",+ .list = list(row_count = formatters::with_label(c(.N_row, .N_row), label)), |
| 341 | -1x | +140 | +273x |
- "The model will be calculated without interaction effects."+ .formats = c(row_count = function(x, ...) "") |
| 342 | +141 |
- ))+ ) |
||
| 343 | +142 |
- }- |
- ||
| 344 | -16x | -
- if (control$interaction && !"arm" %in% names(variables)) {
+ } |
||
| 345 | -1x | +|||
| 143 | +
- stop("To include interactions please specify 'arm' in variables.")
+
|
|||
| 346 | +144 |
- }+ #' Content row function to add `alt_counts_df` row total to labels |
||
| 347 | +145 |
-
+ #' |
||
| 348 | -15x | +|||
| 146 | +
- .stats <- if (!"arm" %in% names(variables) || multivar) { # only valid statistics
+ #' This takes the label of the latest row split level and adds the row total from `alt_counts_df` |
|||
| 349 | -6x | +|||
| 147 | +
- intersect(c("hr", "ci", "pval"), .stats)
+ #' in parentheses. This function differs from [c_label_n()] by taking row counts from `alt_counts_df` |
|||
| 350 | -15x | +|||
| 148 | +
- } else if (control$interaction) {
+ #' rather than `df`, and is used by [add_rowcounts()] when `alt_counts` is set to `TRUE`. |
|||
| 351 | -5x | +|||
| 149 | +
- intersect(c("n", "hr", "ci", "pval", "pval_inter"), .stats)
+ #' |
|||
| 352 | +150 |
- } else {
+ #' @inheritParams argument_convention |
||
| 353 | -4x | +|||
| 151 | +
- intersect(c("n", "hr", "ci", "pval"), .stats)
+ #' |
|||
| 354 | +152 |
- }+ #' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label. |
||
| 355 | -15x | +|||
| 153 | +
- stat_labels <- c(+ #' |
|||
| 356 | -15x | +|||
| 154 | +
- n = "n", hr = "Hazard Ratio", ci = paste0(control$conf_level * 100, "% CI"),+ #' @seealso [c_label_n()] which performs the same function but retrieves row counts from `df` instead |
|||
| 357 | -15x | +|||
| 155 | +
- pval = "p-value", pval_inter = "Interaction p-value"+ #' of `alt_counts_df`. |
|||
| 358 | +156 |
- )+ #' |
||
| 359 | -15x | +|||
| 157 | +
- stat_labels <- stat_labels[names(stat_labels) %in% .stats]+ #' @keywords internal |
|||
| 360 | -15x | +|||
| 158 | +
- .formats <- .formats[names(.formats) %in% .stats]+ c_label_n_alt <- function(df, |
|||
| 361 | -15x | +|||
| 159 | +
- env <- new.env() # create caching environment+ labelstr, |
|||
| 362 | +160 |
-
+ .alt_df_row) {
|
||
| 363 | -15x | +161 | +7x |
- lyt <- lyt %>%+ N_row_alt <- nrow(.alt_df_row) # nolint |
| 364 | -15x | +162 | +7x |
- split_cols_by_multivar(+ label <- paste0(labelstr, " (N=", N_row_alt, ")") |
| 365 | -15x | +163 | +7x |
- vars = rep(common_var, length(.stats)),+ in_rows( |
| 366 | -15x | +164 | +7x |
- varlabels = stat_labels,+ .list = list(row_count = formatters::with_label(c(N_row_alt, N_row_alt), label)), |
| 367 | -15x | +165 | +7x |
- extra_args = list(+ .formats = c(row_count = function(x, ...) "") |
| 368 | -15x | +|||
| 166 | +
- .stats = .stats, .formats = .formats, .indent_mods = .indent_mods, na_str = rep(na_str, length(.stats)),+ ) |
|||
| 369 | -15x | +|||
| 167 | +
- cache_env = replicate(length(.stats), list(env))+ } |
|||
| 370 | +168 |
- )+ |
||
| 371 | +169 |
- )+ #' Layout-creating function to add row total counts |
||
| 372 | +170 |
-
+ #' |
||
| 373 | -15x | +|||
| 171 | +
- if ("arm" %in% names(variables)) { # treatment effect
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 374 | -13x | +|||
| 172 | +
- lyt <- lyt %>%+ #' |
|||
| 375 | -13x | +|||
| 173 | +
- split_rows_by(+ #' This works analogously to [rtables::add_colcounts()] but on the rows. This function |
|||
| 376 | -13x | +|||
| 174 | +
- common_var,+ #' is a wrapper for [rtables::summarize_row_groups()]. |
|||
| 377 | -13x | +|||
| 175 | +
- split_label = "Treatment:",+ #' |
|||
| 378 | -13x | +|||
| 176 | +
- label_pos = "visible",+ #' @inheritParams argument_convention |
|||
| 379 | -13x | +|||
| 177 | +
- child_labels = "hidden",+ #' @param alt_counts (`flag`)\cr whether row counts should be taken from `alt_counts_df` (`TRUE`) |
|||
| 380 | -13x | +|||
| 178 | +
- section_div = head(.section_div, 1)+ #' or from `df` (`FALSE`). Defaults to `FALSE`. |
|||
| 381 | +179 |
- )+ #' |
||
| 382 | -13x | +|||
| 180 | +
- if (!multivar) {
+ #' @return A modified layout where the latest row split labels now have the row-wise |
|||
| 383 | -9x | +|||
| 181 | +
- lyt <- lyt %>%+ #' total counts (i.e. without column-based subsetting) attached in parentheses. |
|||
| 384 | -9x | +|||
| 182 | +
- analyze_colvars(+ #' |
|||
| 385 | -9x | +|||
| 183 | +
- afun = a_coxreg,+ #' @note Row count values are contained in these row count rows but are not displayed |
|||
| 386 | -9x | +|||
| 184 | +
- na_str = na_str,+ #' so that they are not considered zero rows by default when pruning. |
|||
| 387 | -9x | +|||
| 185 | +
- extra_args = list(+ #' |
|||
| 388 | -9x | +|||
| 186 | +
- variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar,+ #' @examples |
|||
| 389 | -9x | +|||
| 187 | +
- labelstr = ""+ #' basic_table() %>% |
|||
| 390 | +188 |
- )+ #' split_cols_by("ARM") %>%
|
||
| 391 | +189 |
- )+ #' add_colcounts() %>% |
||
| 392 | +190 |
- } else { # treatment level effects
+ #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
|
||
| 393 | -4x | +|||
| 191 | +
- lyt <- lyt %>%+ #' add_rowcounts() %>% |
|||
| 394 | -4x | +|||
| 192 | +
- summarize_row_groups(+ #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>%
|
|||
| 395 | -4x | +|||
| 193 | +
- cfun = a_coxreg,+ #' build_table(DM)+ |
+ |||
| 194 | ++ |
+ #'+ |
+ ||
| 195 | ++ |
+ #' @export+ |
+ ||
| 196 | ++ |
+ add_rowcounts <- function(lyt, alt_counts = FALSE) {
|
||
| 396 | -4x | +197 | +7x |
- na_str = na_str,+ summarize_row_groups( |
| 397 | -4x | +198 | +7x |
- extra_args = list(+ lyt, |
| 398 | -4x | +199 | +7x |
- variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar+ cfun = if (alt_counts) c_label_n_alt else c_label_n |
| 399 | +200 |
- )+ ) |
||
| 400 | +201 |
- ) %>%+ } |
||
| 401 | -4x | +|||
| 202 | +
- analyze_colvars(+ |
|||
| 402 | -4x | +|||
| 203 | +
- afun = a_coxreg,+ #' Obtain column indices |
|||
| 403 | -4x | +|||
| 204 | +
- na_str = na_str,+ #' |
|||
| 404 | -4x | +|||
| 205 | +
- extra_args = list(eff = TRUE, control = control, variables = variables, multivar = multivar, labelstr = "")+ #' @description `r lifecycle::badge("stable")`
|
|||
| 405 | +206 |
- )+ #'+ |
+ ||
| 207 | ++ |
+ #' Helper function to extract column indices from a `VTableTree` for a given |
||
| 406 | +208 |
- }+ #' vector of column names. |
||
| 407 | +209 |
- }+ #' |
||
| 408 | +210 |
-
+ #' @param table_tree (`VTableTree`)\cr `rtables` table object to extract the indices from. |
||
| 409 | -15x | +|||
| 211 | +
- if ("covariates" %in% names(variables)) { # covariate main effects
+ #' @param col_names (`character`)\cr vector of column names. |
|||
| 410 | -15x | +|||
| 212 | +
- lyt <- lyt %>%+ #' |
|||
| 411 | -15x | +|||
| 213 | +
- split_rows_by_multivar(+ #' @return A vector of column indices. |
|||
| 412 | -15x | +|||
| 214 | +
- vars = variables$covariates,+ #' |
|||
| 413 | -15x | +|||
| 215 | +
- varlabels = varlabels,+ #' @export |
|||
| 414 | -15x | +|||
| 216 | +
- split_label = "Covariate:",+ h_col_indices <- function(table_tree, col_names) {
|
|||
| 415 | -15x | +217 | +1256x |
- nested = FALSE,+ checkmate::assert_class(table_tree, "VTableNodeInfo") |
| 416 | -15x | +218 | +1256x |
- child_labels = if (multivar || control$interaction || !"arm" %in% names(variables)) "default" else "hidden",+ checkmate::assert_subset(col_names, names(attr(col_info(table_tree), "cextra_args")), empty.ok = FALSE) |
| 417 | -15x | +219 | +1256x |
- section_div = tail(.section_div, 1)+ match(col_names, names(attr(col_info(table_tree), "cextra_args"))) |
| 418 | +220 |
- )+ } |
||
| 419 | -15x | +|||
| 221 | +
- if (multivar || control$interaction || !"arm" %in% names(variables)) {
+
|
|||
| 420 | -11x | +|||
| 222 | +
- lyt <- lyt %>%+ #' Labels or names of list elements |
|||
| 421 | -11x | +|||
| 223 | +
- summarize_row_groups(+ #' |
|||
| 422 | -11x | +|||
| 224 | +
- cfun = a_coxreg,+ #' Internal helper function for working with nested statistic function results which typically |
|||
| 423 | -11x | +|||
| 225 | +
- na_str = na_str,+ #' don't have labels but names that we can use. |
|||
| 424 | -11x | +|||
| 226 | +
- extra_args = list(+ #' |
|||
| 425 | -11x | +|||
| 227 | +
- variables = variables, at = at, control = control, multivar = multivar,+ #' @param x (`list`)\cr a list. |
|||
| 426 | -11x | +|||
| 228 | +
- var_main = if (multivar) multivar else control$interaction+ #' |
|||
| 427 | +229 |
- )+ #' @return A `character` vector with the labels or names for the list elements. |
||
| 428 | +230 |
- )+ #' |
||
| 429 | +231 |
- } else {
+ #' @keywords internal |
||
| 430 | -1x | +|||
| 232 | +
- if (!is.null(varlabels)) names(varlabels) <- variables$covariates+ labels_or_names <- function(x) {
|
|||
| 431 | -4x | +233 | +190x |
- lyt <- lyt %>%+ checkmate::assert_multi_class(x, c("data.frame", "list"))
|
| 432 | -4x | +234 | +190x |
- analyze_colvars(+ labs <- sapply(x, obj_label) |
| 433 | -4x | +235 | +190x |
- afun = a_coxreg,+ nams <- rlang::names2(x) |
| 434 | -4x | +236 | +190x |
- na_str = na_str,+ label_is_null <- sapply(labs, is.null) |
| 435 | -4x | +237 | +190x |
- extra_args = list(+ result <- unlist(ifelse(label_is_null, nams, labs)) |
| 436 | -4x | +238 | +190x |
- variables = variables, at = at, control = control, multivar = multivar,+ return(result) |
| 437 | -4x | +|||
| 239 | +
- var_main = if (multivar) multivar else control$interaction,+ } |
|||
| 438 | -4x | +|||
| 240 | +
- labelstr = if (is.null(varlabels)) "" else varlabels+ |
|||
| 439 | +241 |
- )+ #' Convert to `rtable` |
||
| 440 | +242 |
- )+ #' |
||
| 441 | +243 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 442 | +244 |
-
+ #' |
||
| 443 | -2x | +|||
| 245 | +
- if (!"arm" %in% names(variables)) control$interaction <- TRUE # special case: univar no arm+ #' This is a new generic function to convert objects to `rtable` tables. |
|||
| 444 | -15x | +|||
| 246 | +
- if (multivar || control$interaction) { # covariate level effects
+ #' |
|||
| 445 | -11x | +|||
| 247 | +
- lyt <- lyt %>%+ #' @param x (`data.frame`)\cr the object which should be converted to an `rtable`. |
|||
| 446 | -11x | +|||
| 248 | +
- analyze_colvars(+ #' @param ... additional arguments for methods. |
|||
| 447 | -11x | +|||
| 249 | +
- afun = a_coxreg,+ #' |
|||
| 448 | -11x | +|||
| 250 | +
- na_str = na_str,+ #' @return An `rtables` table object. Note that the concrete class will depend on the method used. |
|||
| 449 | -11x | +|||
| 251 | +
- extra_args = list(variables = variables, at = at, control = control, multivar = multivar, labelstr = ""),+ #' |
|||
| 450 | -11x | +|||
| 252 | +
- indent_mod = if (!"arm" %in% names(variables) || multivar) 0L else -1L+ #' @export |
|||
| 451 | +253 |
- )+ as.rtable <- function(x, ...) { # nolint
|
||
| 452 | -+ | |||
| 254 | +3x |
- }+ UseMethod("as.rtable", x)
|
||
| 453 | +255 |
- }+ } |
||
| 454 | +256 | |||
| 455 | -15x | +|||
| 257 | +
- lyt+ #' @describeIn as.rtable Method for converting a `data.frame` that contains numeric columns to `rtable`. |
|||
| 456 | +258 |
- }+ #' |
| 1 | +259 |
- #' Re-implemented `range()` default S3 method for numerical objects+ #' @param format (`string` or `function`)\cr the format which should be used for the columns. |
||
| 2 | +260 |
#' |
||
| 3 | +261 |
- #' This function returns `c(NA, NA)` instead of `c(-Inf, Inf)` for zero-length data+ #' @method as.rtable data.frame |
||
| 4 | +262 |
- #' without any warnings.+ #' |
||
| 5 | +263 |
- #'+ #' @examples |
||
| 6 | +264 |
- #' @param x (`numeric`)\cr a sequence of numbers for which the range is computed.+ #' x <- data.frame( |
||
| 7 | +265 |
- #' @param na.rm (`flag`)\cr flag indicating if `NA` should be omitted.+ #' a = 1:10, |
||
| 8 | +266 |
- #' @param finite (`flag`)\cr flag indicating if non-finite elements should be removed.+ #' b = rnorm(10) |
||
| 9 | +267 |
- #'+ #' ) |
||
| 10 | +268 |
- #' @return A 2-element vector of class `numeric`.+ #' as.rtable(x) |
||
| 11 | +269 |
#' |
||
| 12 | +270 |
- #' @keywords internal+ #' @export |
||
| 13 | +271 |
- range_noinf <- function(x, na.rm = FALSE, finite = FALSE) { # nolint
+ as.rtable.data.frame <- function(x, format = "xx.xx", ...) {
|
||
| 14 | -+ | |||
| 272 | +3x |
-
+ checkmate::assert_numeric(unlist(x)) |
||
| 15 | -1842x | +273 | +2x |
- checkmate::assert_numeric(x)+ do.call( |
| 16 | -+ | |||
| 274 | +2x |
-
+ rtable, |
||
| 17 | -1842x | +275 | +2x |
- if (finite) {
+ c( |
| 18 | -24x | +276 | +2x |
- x <- x[is.finite(x)] # removes NAs too+ list( |
| 19 | -1818x | +277 | +2x |
- } else if (na.rm) {
+ header = labels_or_names(x), |
| 20 | -708x | +278 | +2x |
- x <- x[!is.na(x)]+ format = format |
| 21 | +279 |
- }+ ), |
||
| 22 | -+ | |||
| 280 | +2x |
-
+ Map( |
||
| 23 | -1842x | +281 | +2x |
- if (length(x) == 0) {
+ function(row, row_name) {
|
| 24 | -111x | +282 | +20x |
- rval <- c(NA, NA)+ do.call( |
| 25 | -111x | +283 | +20x |
- mode(rval) <- typeof(x)+ rrow, |
| 26 | -+ | |||
| 284 | +20x |
- } else {
+ c(as.list(unname(row)), |
||
| 27 | -1731x | +285 | +20x |
- rval <- c(min(x, na.rm = FALSE), max(x, na.rm = FALSE))+ row.name = row_name |
| 28 | +286 |
- }+ ) |
||
| 29 | +287 |
-
+ )+ |
+ ||
| 288 | ++ |
+ }, |
||
| 30 | -1842x | +289 | +2x |
- return(rval)+ row = as.data.frame(t(x)), |
| 31 | -+ | |||
| 290 | +2x |
- }+ row_name = rownames(x) |
||
| 32 | +291 |
-
+ ) |
||
| 33 | +292 |
- #' Utility function to create label for confidence interval+ ) |
||
| 34 | +293 |
- #'+ ) |
||
| 35 | +294 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 36 | +295 |
- #'+ |
||
| 37 | +296 |
- #' @inheritParams argument_convention+ #' Split parameters |
||
| 38 | +297 |
#' |
||
| 39 | +298 |
- #' @return A `string`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 40 | +299 |
#' |
||
| 41 | +300 |
- #' @export+ #' It divides the data in the vector `param` into the groups defined by `f` based on specified `values`. It is relevant |
||
| 42 | +301 |
- f_conf_level <- function(conf_level) {
+ #' in `rtables` layers so as to distribute parameters `.stats` or' `.formats` into lists with items corresponding to |
||
| 43 | -3860x | +|||
| 302 | +
- assert_proportion_value(conf_level)+ #' specific analysis function. |
|||
| 44 | -3858x | +|||
| 303 | +
- paste0(conf_level * 100, "% CI")+ #' |
|||
| 45 | +304 |
- }+ #' @param param (`vector`)\cr the parameter to be split. |
||
| 46 | +305 |
-
+ #' @param value (`vector`)\cr the value used to split. |
||
| 47 | +306 |
- #' Utility function to create label for p-value+ #' @param f (`list`)\cr the reference to make the split. |
||
| 48 | +307 |
#' |
||
| 49 | +308 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return A named `list` with the same element names as `f`, each containing the elements specified in `.stats`. |
||
| 50 | +309 |
#' |
||
| 51 | +310 |
- #' @param test_mean (`numeric(1)`)\cr mean value to test under the null hypothesis.+ #' @examples |
||
| 52 | +311 |
- #'+ #' f <- list( |
||
| 53 | +312 |
- #' @return A `string`.+ #' surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
|
||
| 54 | +313 |
- #'+ #' surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
|
||
| 55 | +314 |
- #' @export+ #' ) |
||
| 56 | +315 |
- f_pval <- function(test_mean) {
+ #' |
||
| 57 | -1103x | +|||
| 316 | +
- checkmate::assert_numeric(test_mean, len = 1)+ #' .stats <- c("pt_at_risk", "rate_diff")
|
|||
| 58 | -1101x | +|||
| 317 | +
- paste0("p-value (H0: mean = ", test_mean, ")")
+ #' h_split_param(.stats, .stats, f = f) |
|||
| 59 | +318 |
- }+ #' |
||
| 60 | +319 |
-
+ #' # $surv |
||
| 61 | +320 |
- #' Utility function to return a named list of covariate names+ #' # [1] "pt_at_risk" |
||
| 62 | +321 |
- #'+ #' # |
||
| 63 | +322 |
- #' @param covariates (`character`)\cr a vector that can contain single variable names (such as+ #' # $surv_diff |
||
| 64 | +323 |
- #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`.+ #' # [1] "rate_diff" |
||
| 65 | +324 |
#' |
||
| 66 | +325 |
- #' @return A named `list` of `character` vector.+ #' .formats <- c("pt_at_risk" = "xx", "event_free_rate" = "xxx")
|
||
| 67 | +326 |
- #'+ #' h_split_param(.formats, names(.formats), f = f) |
||
| 68 | +327 |
- #' @keywords internal+ #' |
||
| 69 | +328 |
- get_covariates <- function(covariates) {
+ #' # $surv |
||
| 70 | -14x | +|||
| 329 | +
- checkmate::assert_character(covariates)+ #' # pt_at_risk event_free_rate |
|||
| 71 | -12x | +|||
| 330 | +
- cov_vars <- unique(trimws(unlist(strsplit(covariates, "\\*"))))+ #' # "xx" "xxx" |
|||
| 72 | -12x | +|||
| 331 | +
- stats::setNames(as.list(cov_vars), cov_vars)+ #' # |
|||
| 73 | +332 |
- }+ #' # $surv_diff |
||
| 74 | +333 |
-
+ #' # NULL |
||
| 75 | +334 |
- #' Replicate entries of a vector if required+ #' |
||
| 76 | +335 |
- #'+ #' @export |
||
| 77 | +336 |
- #' @description `r lifecycle::badge("stable")`
+ h_split_param <- function(param, |
||
| 78 | +337 |
- #'+ value, |
||
| 79 | +338 |
- #' Replicate entries of a vector if required.+ f) {
+ |
+ ||
| 339 | +26x | +
+ y <- lapply(f, function(x) param[value %in% x])+ |
+ ||
| 340 | +26x | +
+ lapply(y, function(x) if (length(x) == 0) NULL else x) |
||
| 80 | +341 |
- #'+ } |
||
| 81 | +342 |
- #' @inheritParams argument_convention+ |
||
| 82 | +343 |
- #' @param n (`integer(1)`)\cr number of entries that are needed.+ #' Get selected statistics names |
||
| 83 | +344 |
#' |
||
| 84 | +345 |
- #' @return `x` if it has the required length already or is `NULL`,+ #' Helper function to be used for creating `afun`. |
||
| 85 | +346 |
- #' otherwise if it is scalar the replicated version of it with `n` entries.+ #' |
||
| 86 | +347 |
- #'+ #' @param .stats (`vector` or `NULL`)\cr input to the layout creating function. Note that `NULL` means |
||
| 87 | +348 |
- #' @note This function will fail if `x` is not of length `n` and/or is not a scalar.+ #' in this context that all default statistics should be used. |
||
| 88 | +349 | ++ |
+ #' @param all_stats (`character`)\cr all statistics which can be selected here potentially.+ |
+ |
| 350 |
#' |
|||
| 89 | +351 |
- #' @export+ #' @return A `character` vector with the selected statistics. |
||
| 90 | +352 |
- to_n <- function(x, n) {
+ #' |
||
| 91 | -5x | +|||
| 353 | +
- if (is.null(x)) {
+ #' @keywords internal |
|||
| 92 | -1x | +|||
| 354 | +
- NULL+ afun_selected_stats <- function(.stats, all_stats) {
|
|||
| 93 | -4x | +355 | +2x |
- } else if (length(x) == 1) {
+ checkmate::assert_character(.stats, null.ok = TRUE) |
| 94 | -1x | +356 | +2x |
- rep(x, n)+ checkmate::assert_character(all_stats) |
| 95 | -3x | +357 | +2x |
- } else if (length(x) == n) {
+ if (is.null(.stats)) {
|
| 96 | -2x | +358 | +1x |
- x+ all_stats |
| 97 | +359 |
} else {
|
||
| 98 | +360 | 1x |
- stop("dimension mismatch")
+ intersect(.stats, all_stats) |
|
| 99 | +361 |
} |
||
| 100 | +362 |
} |
||
| 101 | +363 | |||
| 102 | +364 |
- #' Check element dimension+ #' Add variable labels to top left corner in table |
||
| 103 | +365 |
#' |
||
| 104 | +366 |
- #' Checks if the elements in `...` have the same dimension.+ #' @description `r lifecycle::badge("stable")`
|
||
| 105 | +367 |
#' |
||
| 106 | +368 |
- #' @param ... (`data.frame` or `vector`)\cr any data frames or vectors.+ #' Helper layout-creating function to append the variable labels of a given variables vector |
||
| 107 | +369 |
- #' @param omit_null (`flag`)\cr whether `NULL` elements in `...` should be omitted from the check.+ #' from a given dataset in the top left corner. If a variable label is not found then the |
||
| 108 | +370 |
- #'+ #' variable name itself is used instead. Multiple variable labels are concatenated with slashes. |
||
| 109 | +371 |
- #' @return A `logical` value.+ #' |
||
| 110 | +372 |
- #'+ #' @inheritParams argument_convention |
||
| 111 | +373 |
- #' @keywords internal+ #' @param vars (`character`)\cr variable names of which the labels are to be looked up in `df`. |
||
| 112 | +374 |
- check_same_n <- function(..., omit_null = TRUE) {
- |
- ||
| 113 | -2x | -
- dots <- list(...)+ #' @param indent (`integer(1)`)\cr non-negative number of nested indent space, default to 0L which means no indent. |
||
| 114 | +375 | - - | -||
| 115 | -2x | -
- n_list <- Map(- |
- ||
| 116 | -2x | -
- function(x, name) {
- |
- ||
| 117 | -5x | -
- if (is.null(x)) {
- |
- ||
| 118 | -! | -
- if (omit_null) {
- |
- ||
| 119 | -2x | -
- NA_integer_+ #' 1L means two spaces indent, 2L means four spaces indent and so on. |
||
| 120 | +376 |
- } else {
- |
- ||
| 121 | -! | -
- stop("arg", name, "is not supposed to be NULL")
+ #' |
||
| 122 | +377 |
- }- |
- ||
| 123 | -5x | -
- } else if (is.data.frame(x)) {
- |
- ||
| 124 | -! | -
- nrow(x)- |
- ||
| 125 | -5x | -
- } else if (is.atomic(x)) {
- |
- ||
| 126 | -5x | -
- length(x)+ #' @return A modified layout with the new variable label(s) added to the top-left material. |
||
| 127 | +378 |
- } else {
- |
- ||
| 128 | -! | -
- stop("data structure for ", name, "is currently not supported")
+ #' |
||
| 129 | +379 |
- }+ #' @note This is not an optimal implementation of course, since we are using here the data set |
||
| 130 | +380 |
- },- |
- ||
| 131 | -2x | -
- dots, names(dots)+ #' itself during the layout creation. When we have a more mature `rtables` implementation then |
||
| 132 | +381 |
- )+ #' this will also be improved or not necessary anymore. |
||
| 133 | +382 | - - | -||
| 134 | -2x | -
- n <- stats::na.omit(unlist(n_list))+ #' |
||
| 135 | +383 | - - | -||
| 136 | -2x | -
- if (length(unique(n)) > 1) {
+ #' @examples |
||
| 137 | -! | +|||
| 384 | +
- sel <- which(n != n[1])+ #' lyt <- basic_table() %>% |
|||
| 138 | -! | +|||
| 385 | +
- stop("Dimension mismatch:", paste(names(n)[sel], collapse = ", "), " do not have N=", n[1])
+ #' split_cols_by("ARM") %>%
|
|||
| 139 | +386 |
- }+ #' add_colcounts() %>% |
||
| 140 | +387 |
-
+ #' split_rows_by("SEX") %>%
|
||
| 141 | -2x | +|||
| 388 | +
- TRUE+ #' append_varlabels(DM, "SEX") %>% |
|||
| 142 | +389 |
- }+ #' analyze("AGE", afun = mean) %>%
|
||
| 143 | +390 |
-
+ #' append_varlabels(DM, "AGE", indent = 1) |
||
| 144 | +391 |
- #' Utility function to check if a float value is equal to another float value+ #' build_table(lyt, DM) |
||
| 145 | +392 |
#' |
||
| 146 | +393 |
- #' Uses `.Machine$double.eps` as the tolerance for the comparison.+ #' lyt <- basic_table() %>% |
||
| 147 | +394 |
- #'+ #' split_cols_by("ARM") %>%
|
||
| 148 | +395 |
- #' @param x (`numeric(1)`)\cr a float number.+ #' split_rows_by("SEX") %>%
|
||
| 149 | +396 |
- #' @param y (`numeric(1)`)\cr a float number.+ #' analyze("AGE", afun = mean) %>%
|
||
| 150 | +397 |
- #'+ #' append_varlabels(DM, c("SEX", "AGE"))
|
||
| 151 | +398 |
- #' @return `TRUE` if identical, otherwise `FALSE`.+ #' build_table(lyt, DM) |
||
| 152 | +399 |
#' |
||
| 153 | +400 |
- #' @keywords internal+ #' @export |
||
| 154 | +401 |
- .is_equal_float <- function(x, y) {
+ append_varlabels <- function(lyt, df, vars, indent = 0L) {
|
||
| 155 | -2820x | +402 | +3x |
- checkmate::assert_number(x)+ if (checkmate::test_flag(indent)) {
|
| 156 | -2820x | +|||
| 403 | +! |
- checkmate::assert_number(y)+ warning("indent argument is now accepting integers. Boolean indent will be converted to integers.")
+ |
+ ||
| 404 | +! | +
+ indent <- as.integer(indent) |
||
| 157 | +405 |
-
+ } |
||
| 158 | +406 |
- # Define a tolerance+ |
||
| 159 | -2820x | +407 | +3x |
- tolerance <- .Machine$double.eps+ checkmate::assert_data_frame(df)+ |
+
| 408 | +3x | +
+ checkmate::assert_character(vars)+ |
+ ||
| 409 | +3x | +
+ checkmate::assert_count(indent) |
||
| 160 | +410 | |||
| 411 | +3x | +
+ lab <- formatters::var_labels(df[vars], fill = TRUE)+ |
+ ||
| 412 | +3x | +
+ lab <- paste(lab, collapse = " / ")+ |
+ ||
| 413 | +3x | +
+ space <- paste(rep(" ", indent * 2), collapse = "")
+ |
+ ||
| 414 | +3x | +
+ lab <- paste0(space, lab)+ |
+ ||
| 161 | +415 |
- # Check if x is close enough to y+ |
||
| 162 | -2820x | +416 | +3x |
- abs(x - y) < tolerance+ append_topleft(lyt, lab) |
| 163 | +417 |
} |
||
| 164 | +418 | |||
| 165 | +419 |
- #' Make names without dots+ #' Default string replacement for `NA` values |
||
| 166 | +420 |
#' |
||
| 167 | +421 |
- #' @param nams (`character`)\cr vector of original names.+ #' @description `r lifecycle::badge("stable")`
|
||
| 168 | +422 |
#' |
||
| 169 | +423 |
- #' @return A `character` `vector` of proper names, which does not use dots in contrast to [make.names()].+ #' The default string used to represent `NA` values. This value is used as the default |
||
| 170 | +424 |
- #'+ #' value for the `na_str` argument throughout the `tern` package, and printed in place |
||
| 171 | +425 |
- #' @keywords internal+ #' of `NA` values in output tables. If not specified for each `tern` function by the user |
||
| 172 | +426 |
- make_names <- function(nams) {
+ #' via the `na_str` argument, or in the R environment options via [set_default_na_str()], |
||
| 173 | -6x | +|||
| 427 | +
- orig <- make.names(nams)+ #' then `NA` is used. |
|||
| 174 | -6x | +|||
| 428 | +
- gsub(".", "", x = orig, fixed = TRUE)
+ #' |
|||
| 175 | +429 |
- }+ #' @param na_str (`string`)\cr single string value to set in the R environment options as |
||
| 176 | +430 |
-
+ #' the default value to replace `NA`s. Use `getOption("tern_default_na_str")` to check the
|
||
| 177 | +431 |
- #' Conversion of months to days+ #' current value set in the R environment (defaults to `NULL` if not set). |
||
| 178 | +432 |
#' |
||
| 179 | +433 |
- #' @description `r lifecycle::badge("stable")`
+ #' @name default_na_str |
||
| 180 | +434 |
- #'+ NULL |
||
| 181 | +435 |
- #' Conversion of months to days. This is an approximative calculation because it+ |
||
| 182 | +436 |
- #' considers each month as having an average of 30.4375 days.+ #' @describeIn default_na_str Accessor for default `NA` value replacement string. |
||
| 183 | +437 |
#' |
||
| 184 | +438 |
- #' @param x (`numeric(1)`)\cr time in months.+ #' @return |
||
| 185 | +439 |
- #'+ #' * `default_na_str` returns the current value if an R environment option has been set |
||
| 186 | +440 |
- #' @return A `numeric` vector with the time in days.+ #' for `"tern_default_na_str"`, or `NA_character_` otherwise. |
||
| 187 | +441 |
#' |
||
| 188 | +442 |
#' @examples |
||
| 189 | +443 |
- #' x <- c(13.25, 8.15, 1, 2.834)+ #' # Default settings |
||
| 190 | +444 |
- #' month2day(x)+ #' default_na_str() |
||
| 191 | +445 |
- #'+ #' getOption("tern_default_na_str")
|
||
| 192 | +446 |
- #' @export+ #' |
||
| 193 | +447 |
- month2day <- function(x) {
+ #' # Set custom value |
||
| 194 | -1x | +|||
| 448 | +
- checkmate::assert_numeric(x)+ #' set_default_na_str("<Missing>")
|
|||
| 195 | -1x | +|||
| 449 | +
- x * 30.4375+ #' |
|||
| 196 | +450 |
- }+ #' # Settings after value has been set |
||
| 197 | +451 |
-
+ #' default_na_str() |
||
| 198 | +452 |
- #' Conversion of days to months+ #' getOption("tern_default_na_str")
|
||
| 199 | +453 |
#' |
||
| 200 | +454 |
- #' @param x (`numeric(1)`)\cr time in days.+ #' @export |
||
| 201 | +455 |
- #'+ default_na_str <- function() {
+ |
+ ||
| 456 | +331x | +
+ getOption("tern_default_na_str", default = NA_character_)
|
||
| 202 | +457 |
- #' @return A `numeric` vector with the time in months.+ } |
||
| 203 | +458 |
- #'+ |
||
| 204 | +459 |
- #' @examples+ #' @describeIn default_na_str Setter for default `NA` value replacement string. Sets the |
||
| 205 | +460 |
- #' x <- c(403, 248, 30, 86)+ #' option `"tern_default_na_str"` within the R environment. |
||
| 206 | +461 |
- #' day2month(x)+ #' |
||
| 207 | +462 | ++ |
+ #' @return+ |
+ |
| 463 | ++ |
+ #' * `set_default_na_str` has no return value.+ |
+ ||
| 464 |
#' |
|||
| 208 | +465 |
#' @export |
||
| 209 | +466 |
- day2month <- function(x) {
+ set_default_na_str <- function(na_str) {
|
||
| 210 | -19x | +467 | +3x |
- checkmate::assert_numeric(x)+ checkmate::assert_character(na_str, len = 1, null.ok = TRUE) |
| 211 | -19x | +468 | +3x |
- x / 30.4375+ options("tern_default_na_str" = na_str)
|
| 212 | +469 |
} |
| 213 | +1 |
-
+ #' Difference test for two proportions |
||
| 214 | +2 |
- #' Return an empty numeric if all elements are `NA`.+ #' |
||
| 215 | +3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+ |
| 4 |
#' |
|||
| 216 | +5 |
- #' @param x (`numeric`)\cr vector.+ #' The analyze function [test_proportion_diff()] creates a layout element to test the difference between two |
||
| 217 | +6 |
- #'+ #' proportions. The primary analysis variable, `vars`, indicates whether a response has occurred for each record. See |
||
| 218 | +7 |
- #' @return An empty `numeric` if all elements of `x` are `NA`, otherwise `x`.+ #' the `method` parameter for options of methods to use to calculate the p-value. Additionally, a stratification |
||
| 219 | +8 | ++ |
+ #' variable can be supplied via the `strata` element of the `variables` argument.+ |
+ |
| 9 |
#' |
|||
| 220 | +10 |
- #' @examples+ #' @inheritParams argument_convention |
||
| 221 | +11 |
- #' x <- c(NA, NA, NA)+ #' @param method (`string`)\cr one of `chisq`, `cmh`, `fisher`, or `schouten`; specifies the test used |
||
| 222 | +12 |
- #' # Internal function - empty_vector_if_na+ #' to calculate the p-value. |
||
| 223 | +13 |
- #' @keywords internal+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("test_proportion_diff")`
|
||
| 224 | +14 |
- empty_vector_if_na <- function(x) {
+ #' to see available statistics for this function. |
||
| 225 | -1017x | +|||
| 15 | +
- if (all(is.na(x))) {
+ #' |
|||
| 226 | -310x | +|||
| 16 | +
- numeric()+ #' @seealso [h_prop_diff_test] |
|||
| 227 | +17 |
- } else {
+ #' |
||
| 228 | -707x | +|||
| 18 | +
- x+ #' @name prop_diff_test |
|||
| 229 | +19 |
- }+ #' @order 1 |
||
| 230 | +20 |
- }+ NULL |
||
| 231 | +21 | |||
| 232 | +22 |
- #' Element-wise combination of two vectors+ #' @describeIn prop_diff_test Statistics function which tests the difference between two proportions. |
||
| 233 | +23 |
#' |
||
| 234 | +24 |
- #' @param x (`vector`)\cr first vector to combine.+ #' @return |
||
| 235 | +25 |
- #' @param y (`vector`)\cr second vector to combine.+ #' * `s_test_proportion_diff()` returns a named `list` with a single item `pval` with an attribute `label` |
||
| 236 | +26 | ++ |
+ #' describing the method used. The p-value tests the null hypothesis that proportions in two groups are the same.+ |
+ |
| 27 |
#' |
|||
| 237 | +28 |
- #' @return A `list` where each element combines corresponding elements of `x` and `y`.+ #' @keywords internal |
||
| 238 | +29 |
- #'+ s_test_proportion_diff <- function(df, |
||
| 239 | +30 |
- #' @examples+ .var, |
||
| 240 | +31 |
- #' combine_vectors(1:3, 4:6)+ .ref_group, |
||
| 241 | +32 |
- #'+ .in_ref_col, |
||
| 242 | +33 |
- #' @export+ variables = list(strata = NULL), |
||
| 243 | +34 |
- combine_vectors <- function(x, y) {
+ method = c("chisq", "schouten", "fisher", "cmh")) {
|
||
| 244 | -51x | +35 | +45x |
- checkmate::assert_vector(x)+ method <- match.arg(method) |
| 245 | -51x | +36 | +45x |
- checkmate::assert_vector(y, len = length(x))+ y <- list(pval = "") |
| 246 | +37 | |||
| 247 | -51x | +38 | +45x |
- result <- lapply(as.data.frame(rbind(x, y)), `c`)+ if (!.in_ref_col) {
|
| 248 | -51x | +39 | +45x |
- names(result) <- NULL+ assert_df_with_variables(df, list(rsp = .var)) |
| 249 | -51x | +40 | +45x |
- result+ assert_df_with_variables(.ref_group, list(rsp = .var)) |
| 250 | -+ | |||
| 41 | +45x |
- }+ rsp <- factor( |
||
| 251 | -+ | |||
| 42 | +45x |
-
+ c(.ref_group[[.var]], df[[.var]]), |
||
| 252 | -+ | |||
| 43 | +45x |
- #' Extract elements by name+ levels = c("TRUE", "FALSE")
|
||
| 253 | +44 |
- #'+ ) |
||
| 254 | -+ | |||
| 45 | +45x |
- #' This utility function extracts elements from a vector `x` by `names`.+ grp <- factor( |
||
| 255 | -+ | |||
| 46 | +45x |
- #' Differences to the standard `[` function are:+ rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
|
||
| 256 | -+ | |||
| 47 | +45x |
- #'+ levels = c("ref", "Not-ref")
|
||
| 257 | +48 |
- #' - If `x` is `NULL`, then still always `NULL` is returned (same as in base function).+ ) |
||
| 258 | +49 |
- #' - If `x` is not `NULL`, then the intersection of its names is made with `names` and those+ |
||
| 259 | -+ | |||
| 50 | +45x |
- #' elements are returned. That is, `names` which don't appear in `x` are not returned as `NA`s.+ if (!is.null(variables$strata) || method == "cmh") {
|
||
| 260 | -+ | |||
| 51 | +12x |
- #'+ strata <- variables$strata |
||
| 261 | -+ | |||
| 52 | +12x |
- #' @param x (named `vector`)\cr where to extract named elements from.+ checkmate::assert_false(is.null(strata)) |
||
| 262 | -+ | |||
| 53 | +12x |
- #' @param names (`character`)\cr vector of names to extract.+ strata_vars <- stats::setNames(as.list(strata), strata) |
||
| 263 | -+ | |||
| 54 | +12x |
- #'+ assert_df_with_variables(df, strata_vars) |
||
| 264 | -+ | |||
| 55 | +12x |
- #' @return `NULL` if `x` is `NULL`, otherwise the extracted elements from `x`.+ assert_df_with_variables(.ref_group, strata_vars) |
||
| 265 | -+ | |||
| 56 | +12x |
- #'+ strata <- c(interaction(.ref_group[strata]), interaction(df[strata])) |
||
| 266 | +57 |
- #' @keywords internal+ } |
||
| 267 | +58 |
- extract_by_name <- function(x, names) {
+
|
||
| 268 | -3x | +59 | +45x |
- if (is.null(x)) {
+ tbl <- switch(method, |
| 269 | -1x | +60 | +45x |
- return(NULL)+ cmh = table(grp, rsp, strata),+ |
+
| 61 | +45x | +
+ table(grp, rsp) |
||
| 270 | +62 |
- }+ )+ |
+ ||
| 63 | ++ | + | ||
| 271 | -2x | +64 | +45x |
- checkmate::assert_named(x)+ y$pval <- switch(method, |
| 272 | -2x | +65 | +45x |
- checkmate::assert_character(names)+ chisq = prop_chisq(tbl), |
| 273 | -2x | +66 | +45x |
- which_extract <- intersect(names(x), names)+ cmh = prop_cmh(tbl), |
| 274 | -2x | +67 | +45x |
- if (length(which_extract) > 0) {
+ fisher = prop_fisher(tbl), |
| 275 | -1x | +68 | +45x |
- x[which_extract]+ schouten = prop_schouten(tbl) |
| 276 | +69 |
- } else {
+ ) |
||
| 277 | -1x | +|||
| 70 | +
- NULL+ } |
|||
| 278 | +71 |
- }+ + |
+ ||
| 72 | +45x | +
+ y$pval <- formatters::with_label(y$pval, d_test_proportion_diff(method))+ |
+ ||
| 73 | +45x | +
+ y |
||
| 279 | +74 |
} |
||
| 280 | +75 | |||
| 281 | +76 |
- #' Labels for adverse event baskets+ #' Description of the difference test between two proportions |
||
| 282 | +77 |
#' |
||
| 283 | +78 |
#' @description `r lifecycle::badge("stable")`
|
||
| 284 | +79 |
#' |
||
| 285 | +80 |
- #' @param aesi (`character`)\cr vector with standardized MedDRA query name (e.g. `SMQxxNAM`) or customized query+ #' This is an auxiliary function that describes the analysis in `s_test_proportion_diff`. |
||
| 286 | +81 |
- #' name (e.g. `CQxxNAM`).+ #' |
||
| 287 | +82 |
- #' @param scope (`character`)\cr vector with scope of query (e.g. `SMQxxSC`).+ #' @inheritParams s_test_proportion_diff |
||
| 288 | +83 |
#' |
||
| 289 | +84 |
- #' @return A `string` with the standard label for the AE basket.+ #' @return A `string` describing the test from which the p-value is derived. |
||
| 290 | +85 |
#' |
||
| 291 | +86 |
- #' @examples+ #' @export |
||
| 292 | +87 |
- #' adae <- tern_ex_adae+ d_test_proportion_diff <- function(method) {
|
||
| 293 | -+ | |||
| 88 | +59x |
- #'+ checkmate::assert_string(method) |
||
| 294 | -+ | |||
| 89 | +59x |
- #' # Standardized query label includes scope.+ meth_part <- switch(method, |
||
| 295 | -+ | |||
| 90 | +59x |
- #' aesi_label(adae$SMQ01NAM, scope = adae$SMQ01SC)+ "schouten" = "Chi-Squared Test with Schouten Correction",+ |
+ ||
| 91 | +59x | +
+ "chisq" = "Chi-Squared Test",+ |
+ ||
| 92 | +59x | +
+ "cmh" = "Cochran-Mantel-Haenszel Test",+ |
+ ||
| 93 | +59x | +
+ "fisher" = "Fisher's Exact Test",+ |
+ ||
| 94 | +59x | +
+ stop(paste(method, "does not have a description")) |
||
| 296 | +95 |
- #'+ )+ |
+ ||
| 96 | +59x | +
+ paste0("p-value (", meth_part, ")")
|
||
| 297 | +97 |
- #' # Customized query label.+ } |
||
| 298 | +98 |
- #' aesi_label(adae$CQ01NAM)+ |
||
| 299 | +99 |
- #'+ #' @describeIn prop_diff_test Formatted analysis function which is used as `afun` in `test_proportion_diff()`. |
||
| 300 | +100 |
- #' @export+ #' |
||
| 301 | +101 |
- aesi_label <- function(aesi, scope = NULL) {
+ #' @return |
||
| 302 | -4x | +|||
| 102 | +
- checkmate::assert_character(aesi)+ #' * `a_test_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 303 | -4x | +|||
| 103 | +
- checkmate::assert_character(scope, null.ok = TRUE)+ #' |
|||
| 304 | -4x | +|||
| 104 | +
- aesi_label <- obj_label(aesi)+ #' @keywords internal |
|||
| 305 | -4x | +|||
| 105 | +
- aesi <- sas_na(aesi)+ a_test_proportion_diff <- make_afun( |
|||
| 306 | -4x | +|||
| 106 | +
- aesi <- unique(aesi)[!is.na(unique(aesi))]+ s_test_proportion_diff, |
|||
| 307 | +107 |
-
+ .formats = c(pval = "x.xxxx | (<0.0001)"), |
||
| 308 | -4x | +|||
| 108 | +
- lbl <- if (length(aesi) == 1 && !is.null(scope)) {
+ .indent_mods = c(pval = 1L) |
|||
| 309 | -1x | +|||
| 109 | +
- scope <- sas_na(scope)+ ) |
|||
| 310 | -1x | +|||
| 110 | +
- scope <- unique(scope)[!is.na(unique(scope))]+ |
|||
| 311 | -1x | +|||
| 111 | +
- checkmate::assert_string(scope)+ #' @describeIn prop_diff_test Layout-creating function which can take statistics function arguments |
|||
| 312 | -1x | +|||
| 112 | +
- paste0(aesi, " (", scope, ")")
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 313 | -4x | +|||
| 113 | +
- } else if (length(aesi) == 1 && is.null(scope)) {
+ #' |
|||
| 314 | -1x | +|||
| 114 | +
- aesi+ #' @return |
|||
| 315 | +115 |
- } else {
+ #' * `test_proportion_diff()` returns a layout object suitable for passing to further layouting functions, |
||
| 316 | -2x | +|||
| 116 | +
- aesi_label+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 317 | +117 |
- }+ #' the statistics from `s_test_proportion_diff()` to the table layout. |
||
| 318 | +118 |
-
+ #' |
||
| 319 | -4x | +|||
| 119 | +
- lbl+ #' @examples |
|||
| 320 | +120 |
- }+ #' dta <- data.frame( |
||
| 321 | +121 |
-
+ #' rsp = sample(c(TRUE, FALSE), 100, TRUE), |
||
| 322 | +122 |
- #' Indicate study arm variable in formula+ #' grp = factor(rep(c("A", "B"), each = 50)),
|
||
| 323 | +123 |
- #'+ #' strata = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20))
|
||
| 324 | +124 |
- #' We use `study_arm` to indicate the study arm variable in `tern` formulas.+ #' ) |
||
| 325 | +125 |
#' |
||
| 326 | +126 |
- #' @param x arm information+ #' # With `rtables` pipelines. |
||
| 327 | +127 |
- #'+ #' l <- basic_table() %>% |
||
| 328 | +128 |
- #' @return `x`+ #' split_cols_by(var = "grp", ref_group = "B") %>% |
||
| 329 | +129 |
- #'+ #' test_proportion_diff( |
||
| 330 | +130 |
- #' @keywords internal+ #' vars = "rsp", |
||
| 331 | +131 |
- study_arm <- function(x) {
+ #' method = "cmh", variables = list(strata = "strata") |
||
| 332 | -! | +|||
| 132 | +
- structure(x, varname = deparse(substitute(x)))+ #' ) |
|||
| 333 | +133 |
- }+ #' |
||
| 334 | +134 |
-
+ #' build_table(l, df = dta) |
||
| 335 | +135 |
- #' Smooth function with optional grouping+ #' |
||
| 336 | +136 |
- #'+ #' @export |
||
| 337 | +137 |
- #' @description `r lifecycle::badge("stable")`
+ #' @order 2 |
||
| 338 | +138 |
- #'+ test_proportion_diff <- function(lyt, |
||
| 339 | +139 |
- #' This produces `loess` smoothed estimates of `y` with Student confidence intervals.+ vars, |
||
| 340 | +140 |
- #'+ variables = list(strata = NULL), |
||
| 341 | +141 |
- #' @param df (`data.frame`)\cr data set containing all analysis variables.+ method = c("chisq", "schouten", "fisher", "cmh"),
|
||
| 342 | +142 |
- #' @param x (`string`)\cr x column name.+ na_str = default_na_str(), |
||
| 343 | +143 |
- #' @param y (`string`)\cr y column name.+ nested = TRUE, |
||
| 344 | +144 |
- #' @param groups (`character` or `NULL`)\cr vector with optional grouping variables names.+ ..., |
||
| 345 | +145 |
- #' @param level (`proportion`)\cr level of confidence interval to use (0.95 by default).+ var_labels = vars, |
||
| 346 | +146 |
- #'+ show_labels = "hidden", |
||
| 347 | +147 |
- #' @return A `data.frame` with original `x`, smoothed `y`, `ylow`, and `yhigh`, and+ table_names = vars, |
||
| 348 | +148 |
- #' optional `groups` variables formatted as `factor` type.+ .stats = NULL, |
||
| 349 | +149 |
- #'+ .formats = NULL, |
||
| 350 | +150 |
- #' @export+ .labels = NULL, |
||
| 351 | +151 |
- get_smooths <- function(df, x, y, groups = NULL, level = 0.95) {
+ .indent_mods = NULL) {
|
||
| 352 | -5x | +152 | +6x |
- checkmate::assert_data_frame(df)+ extra_args <- list(variables = variables, method = method, ...) |
| 353 | -5x | +|||
| 153 | +
- df_cols <- colnames(df)+ |
|||
| 354 | -5x | +154 | +6x |
- checkmate::assert_string(x)+ afun <- make_afun( |
| 355 | -5x | +155 | +6x |
- checkmate::assert_subset(x, df_cols)+ a_test_proportion_diff, |
| 356 | -5x | +156 | +6x |
- checkmate::assert_numeric(df[[x]])+ .stats = .stats, |
| 357 | -5x | +157 | +6x |
- checkmate::assert_string(y)+ .formats = .formats, |
| 358 | -5x | +158 | +6x |
- checkmate::assert_subset(y, df_cols)+ .labels = .labels, |
| 359 | -5x | +159 | +6x |
- checkmate::assert_numeric(df[[y]])+ .indent_mods = .indent_mods |
| 360 | +160 |
-
+ ) |
||
| 361 | -5x | +161 | +6x |
- if (!is.null(groups)) {
+ analyze( |
| 362 | -4x | +162 | +6x |
- checkmate::assert_character(groups)+ lyt, |
| 363 | -4x | -
- checkmate::assert_subset(groups, df_cols)- |
- ||
| 364 | -- |
- }- |
- ||
| 365 | -+ | 163 | +6x |
-
+ vars, |
| 366 | -5x | +164 | +6x |
- smooths <- function(x, y) {
+ afun = afun, |
| 367 | -18x | -
- stats::predict(stats::loess(y ~ x), se = TRUE)- |
- ||
| 368 | -+ | 165 | +6x |
- }+ var_labels = var_labels, |
| 369 | -+ | |||
| 166 | +6x |
-
+ na_str = na_str, |
||
| 370 | -5x | +167 | +6x |
- if (!is.null(groups)) {
+ nested = nested, |
| 371 | -4x | +168 | +6x |
- cc <- stats::complete.cases(df[c(x, y, groups)])+ extra_args = extra_args, |
| 372 | -4x | +169 | +6x |
- df_c <- df[cc, c(x, y, groups)]+ show_labels = show_labels, |
| 373 | -4x | +170 | +6x |
- df_c_ordered <- df_c[do.call("order", as.list(df_c[, groups, drop = FALSE])), , drop = FALSE]
+ table_names = table_names |
| 374 | -4x | +|||
| 171 | +
- df_c_g <- data.frame(Map(as.factor, df_c_ordered[groups]))+ ) |
|||
| 375 | +172 |
-
+ } |
||
| 376 | -4x | +|||
| 173 | +
- df_smooth_raw <-+ |
|||
| 377 | -4x | +|||
| 174 | +
- by(df_c_ordered, df_c_g, function(d) {
+ #' Helper functions to test proportion differences |
|||
| 378 | -17x | +|||
| 175 | +
- plx <- smooths(d[[x]], d[[y]])+ #' |
|||
| 379 | -17x | +|||
| 176 | +
- data.frame(+ #' Helper functions to implement various tests on the difference between two proportions. |
|||
| 380 | -17x | +|||
| 177 | +
- x = d[[x]],+ #' |
|||
| 381 | -17x | +|||
| 178 | +
- y = plx$fit,+ #' @param tbl (`matrix`)\cr matrix with two groups in rows and the binary response (`TRUE`/`FALSE`) in columns. |
|||
| 382 | -17x | +|||
| 179 | +
- ylow = plx$fit - stats::qt(level, plx$df) * plx$se.fit,+ #' |
|||
| 383 | -17x | +|||
| 180 | +
- yhigh = plx$fit + stats::qt(level, plx$df) * plx$se.fit+ #' @return A p-value. |
|||
| 384 | +181 |
- )+ #' |
||
| 385 | +182 |
- })+ #' @seealso [prop_diff_test()] for implementation of these helper functions. |
||
| 386 | +183 |
-
+ #' |
||
| 387 | -4x | +|||
| 184 | +
- df_smooth <- do.call(rbind, df_smooth_raw)+ #' @name h_prop_diff_test |
|||
| 388 | -4x | +|||
| 185 | +
- df_smooth[groups] <- df_c_g+ NULL |
|||
| 389 | +186 | |||
| 390 | -4x | +|||
| 187 | +
- df_smooth+ #' @describeIn h_prop_diff_test Performs Chi-Squared test. Internally calls [stats::prop.test()]. |
|||
| 391 | +188 |
- } else {
+ #' |
||
| 392 | -1x | +|||
| 189 | +
- cc <- stats::complete.cases(df[c(x, y)])+ #' @keywords internal |
|||
| 393 | -1x | +|||
| 190 | +
- df_c <- df[cc, ]+ prop_chisq <- function(tbl) {
|
|||
| 394 | -1x | -
- plx <- smooths(df_c[[x]], df_c[[y]])- |
- ||
| 395 | -+ | 191 | +41x |
-
+ checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2) |
| 396 | -1x | +192 | +41x |
- df_smooth <- data.frame(+ tbl <- tbl[, c("TRUE", "FALSE")]
|
| 397 | -1x | +193 | +41x |
- x = df_c[[x]],+ if (any(colSums(tbl) == 0)) {
|
| 398 | -1x | +194 | +2x |
- y = plx$fit,+ return(1) |
| 399 | -1x | +|||
| 195 | +
- ylow = plx$fit - stats::qt(level, plx$df) * plx$se.fit,+ } |
|||
| 400 | -1x | +196 | +39x |
- yhigh = plx$fit + stats::qt(level, plx$df) * plx$se.fit+ stats::prop.test(tbl, correct = FALSE)$p.value |
| 401 | +197 |
- )+ } |
||
| 402 | +198 | |||
| 403 | -1x | +|||
| 199 | +
- df_smooth+ #' @describeIn h_prop_diff_test Performs stratified Cochran-Mantel-Haenszel test. Internally calls |
|||
| 404 | +200 |
- }+ #' [stats::mantelhaen.test()]. Note that strata with less than two observations are automatically discarded. |
||
| 405 | +201 |
- }+ #' |
||
| 406 | +202 |
-
+ #' @param ary (`array`, 3 dimensions)\cr array with two groups in rows, the binary response |
||
| 407 | +203 |
- #' Number of available (non-missing entries) in a vector+ #' (`TRUE`/`FALSE`) in columns, and the strata in the third dimension. |
||
| 408 | +204 |
#' |
||
| 409 | +205 |
- #' Small utility function for better readability.+ #' @keywords internal |
||
| 410 | +206 |
- #'+ prop_cmh <- function(ary) {
|
||
| 411 | -+ | |||
| 207 | +16x |
- #' @param x (`vector`)\cr vector in which to count non-missing values.+ checkmate::assert_array(ary) |
||
| 412 | -+ | |||
| 208 | +16x |
- #'+ checkmate::assert_integer(c(ncol(ary), nrow(ary)), lower = 2, upper = 2) |
||
| 413 | -+ | |||
| 209 | +16x |
- #' @return Number of non-missing values.+ checkmate::assert_integer(length(dim(ary)), lower = 3, upper = 3) |
||
| 414 | -+ | |||
| 210 | +16x |
- #'+ strata_sizes <- apply(ary, MARGIN = 3, sum)+ |
+ ||
| 211 | +16x | +
+ if (any(strata_sizes < 5)) {
+ |
+ ||
| 212 | +1x | +
+ warning("<5 data points in some strata. CMH test may be incorrect.")
+ |
+ ||
| 213 | +1x | +
+ ary <- ary[, , strata_sizes > 1] |
||
| 415 | +214 |
- #' @keywords internal+ } |
||
| 416 | +215 |
- n_available <- function(x) {
+
|
||
| 417 | -351x | +216 | +16x |
- sum(!is.na(x))+ stats::mantelhaen.test(ary, correct = FALSE)$p.value |
| 418 | +217 |
} |
||
| 419 | +218 | |||
| 420 | +219 |
- #' Reapply variable labels+ #' @describeIn h_prop_diff_test Performs the Chi-Squared test with Schouten correction. |
||
| 421 | +220 |
#' |
||
| 422 | +221 |
- #' This is a helper function that is used in tests.+ #' @seealso Schouten correction is based upon \insertCite{Schouten1980-kd;textual}{tern}.
|
||
| 423 | +222 |
#' |
||
| 424 | +223 |
- #' @param x (`vector`)\cr vector of elements that needs new labels.+ #' @keywords internal |
||
| 425 | +224 |
- #' @param varlabels (`character`)\cr vector of labels for `x`.+ prop_schouten <- function(tbl) {
|
||
| 426 | -+ | |||
| 225 | +100x |
- #' @param ... further parameters to be added to the list.+ checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2) |
||
| 427 | -+ | |||
| 226 | +100x |
- #'+ tbl <- tbl[, c("TRUE", "FALSE")]
+ |
+ ||
| 227 | +100x | +
+ if (any(colSums(tbl) == 0)) {
+ |
+ ||
| 228 | +1x | +
+ return(1) |
||
| 428 | +229 |
- #' @return `x` with variable labels reapplied.+ } |
||
| 429 | +230 |
- #'+ + |
+ ||
| 231 | +99x | +
+ n <- sum(tbl)+ |
+ ||
| 232 | +99x | +
+ n1 <- sum(tbl[1, ])+ |
+ ||
| 233 | +99x | +
+ n2 <- sum(tbl[2, ]) |
||
| 430 | +234 |
- #' @export+ + |
+ ||
| 235 | +99x | +
+ ad <- diag(tbl)+ |
+ ||
| 236 | +99x | +
+ bc <- diag(apply(tbl, 2, rev))+ |
+ ||
| 237 | +99x | +
+ ac <- tbl[, 1]+ |
+ ||
| 238 | +99x | +
+ bd <- tbl[, 2] |
||
| 431 | +239 |
- reapply_varlabels <- function(x, varlabels, ...) {
+
|
||
| 432 | -11x | +240 | +99x |
- named_labels <- c(as.list(varlabels), list(...))+ t_schouten <- (n - 1) * |
| 433 | -11x | +241 | +99x |
- formatters::var_labels(x)[names(named_labels)] <- as.character(named_labels)+ (abs(prod(ad) - prod(bc)) - 0.5 * min(n1, n2))^2 / |
| 434 | -11x | +242 | +99x |
- x+ (n1 * n2 * sum(ac) * sum(bd)) |
| 435 | +243 | ++ | + + | +|
| 244 | +99x | +
+ 1 - stats::pchisq(t_schouten, df = 1)+ |
+ ||
| 245 |
} |
|||
| 436 | +246 | |||
| 437 | +247 |
- # Wrapper function of survival::clogit so that when model fitting failed, a more useful message would show+ #' @describeIn h_prop_diff_test Performs the Fisher's exact test. Internally calls [stats::fisher.test()]. |
||
| 438 | +248 |
- clogit_with_tryCatch <- function(formula, data, ...) { # nolint
+ #' |
||
| 439 | -33x | +|||
| 249 | +
- tryCatch(+ #' @keywords internal+ |
+ |||
| 250 | ++ |
+ prop_fisher <- function(tbl) {
|
||
| 440 | -33x | +251 | +2x |
- survival::clogit(formula = formula, data = data, ...),+ checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2) |
| 441 | -33x | +252 | +2x |
- error = function(e) stop("model not built successfully with survival::clogit")
+ tbl <- tbl[, c("TRUE", "FALSE")]
|
| 442 | -+ | |||
| 253 | +2x |
- )+ stats::fisher.test(tbl)$p.value |
||
| 443 | +254 |
}@@ -73182,14 +74371,14 @@ tern coverage - 95.64% |
| 1 |
- #' Stack multiple grobs+ #' Proportion estimation |
||
| 3 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' @description `r lifecycle::badge("stable")`
|
||
| 5 |
- #' Stack grobs as a new grob with 1 column and multiple rows layout.+ #' 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 |
- #' @param ... grobs.+ #' each record. See the `method` parameter for options of methods to use when constructing the confidence interval of |
||
| 8 |
- #' @param grobs (`list` of `grob`)\cr a list of grobs.+ #' the proportion. Additionally, a stratification variable can be supplied via the `strata` element of the `variables` |
||
| 9 |
- #' @param padding (`grid::unit`)\cr unit of length 1, space between each grob.+ #' argument. |
||
| 10 |
- #' @param vp (`viewport` or `NULL`)\cr a [viewport()] object (or `NULL`).+ #' |
||
| 11 |
- #' @param name (`string`)\cr a character identifier for the grob.+ #' @inheritParams prop_strat_wilson |
||
| 12 |
- #' @param gp (`gpar`)\cr a [gpar()] object.+ #' @inheritParams argument_convention |
||
| 13 |
- #'+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_proportion")`
|
||
| 14 |
- #' @return A `grob`.+ #' to see available statistics for this function. |
||
| 15 |
- #'+ #' @param method (`string`)\cr the method used to construct the confidence interval |
||
| 16 |
- #' @examples+ #' for proportion of successful outcomes; one of `waldcc`, `wald`, `clopper-pearson`, |
||
| 17 |
- #' library(grid)+ #' `wilson`, `wilsonc`, `strat_wilson`, `strat_wilsonc`, `agresti-coull` or `jeffreys`. |
||
| 18 |
- #'+ #' @param long (`flag`)\cr whether a long description is required. |
||
| 19 |
- #' g1 <- circleGrob(gp = gpar(col = "blue"))+ #' |
||
| 20 |
- #' g2 <- circleGrob(gp = gpar(col = "red"))+ #' @seealso [h_proportions] |
||
| 21 |
- #' g3 <- textGrob("TEST TEXT")
+ #' |
||
| 22 |
- #' grid.newpage()+ #' @name estimate_proportion |
||
| 23 |
- #' grid.draw(stack_grobs(g1, g2, g3))+ #' @order 1 |
||
| 24 |
- #'+ NULL |
||
| 25 |
- #' showViewport()+ |
||
| 26 |
- #'+ #' @describeIn estimate_proportion Statistics function estimating a |
||
| 27 |
- #' grid.newpage()+ #' proportion along with its confidence interval. |
||
| 28 |
- #' pushViewport(viewport(layout = grid.layout(1, 2)))+ #' |
||
| 29 |
- #' vp1 <- viewport(layout.pos.row = 1, layout.pos.col = 2)+ #' @param df (`logical` or `data.frame`)\cr if only a logical vector is used, |
||
| 30 |
- #' grid.draw(stack_grobs(g1, g2, g3, vp = vp1, name = "test"))+ #' it indicates whether each subject is a responder or not. `TRUE` represents |
||
| 31 |
- #'+ #' a successful outcome. If a `data.frame` is provided, also the `strata` variable |
||
| 32 |
- #' showViewport()+ #' names must be provided in `variables` as a list element with the strata strings. |
||
| 33 |
- #' grid.ls(grobs = TRUE, viewports = TRUE, print = FALSE)+ #' In the case of `data.frame`, the logical vector of responses must be indicated as a |
||
| 34 |
- #'+ #' variable name in `.var`. |
||
| 35 |
- #' @export+ #' |
||
| 36 |
- stack_grobs <- function(...,+ #' @return |
||
| 37 |
- grobs = list(...),+ #' * `s_proportion()` returns statistics `n_prop` (`n` and proportion) and `prop_ci` (proportion CI) for a |
||
| 38 |
- padding = grid::unit(2, "line"),+ #' given variable. |
||
| 39 |
- vp = NULL,+ #' |
||
| 40 |
- gp = NULL,+ #' @examples |
||
| 41 |
- name = NULL) {
+ #' # Case with only logical vector. |
||
| 42 | -4x | +
- lifecycle::deprecate_warn(+ #' rsp_v <- c(1, 0, 1, 0, 1, 1, 0, 0) |
|
| 43 | -4x | +
- "0.9.4",+ #' s_proportion(rsp_v) |
|
| 44 | -4x | +
- "stack_grobs()",+ #' |
|
| 45 | -4x | +
- details = "`tern` plotting functions no longer generate `grob` objects."+ #' # Example for Stratified Wilson CI |
|
| 46 |
- )+ #' nex <- 100 # Number of example rows |
||
| 47 |
-
+ #' dta <- data.frame( |
||
| 48 | -4x | +
- checkmate::assert_true(+ #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE), |
|
| 49 | -4x | +
- all(vapply(grobs, grid::is.grob, logical(1)))+ #' "grp" = sample(c("A", "B"), nex, TRUE),
|
|
| 50 |
- )+ #' "f1" = sample(c("a1", "a2"), nex, TRUE),
|
||
| 51 |
-
+ #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
|
||
| 52 | -4x | +
- if (length(grobs) == 1) {
+ #' stringsAsFactors = TRUE |
|
| 53 | -1x | +
- return(grobs[[1]])+ #' ) |
|
| 54 |
- }+ #' |
||
| 55 |
-
+ #' s_proportion( |
||
| 56 | -3x | +
- n_layout <- 2 * length(grobs) - 1+ #' df = dta, |
|
| 57 | -3x | +
- hts <- lapply(+ #' .var = "rsp", |
|
| 58 | -3x | +
- seq(1, n_layout),+ #' variables = list(strata = c("f1", "f2")),
|
|
| 59 | -3x | +
- function(i) {
+ #' conf_level = 0.90, |
|
| 60 | -39x | +
- if (i %% 2 != 0) {
+ #' method = "strat_wilson" |
|
| 61 | -21x | +
- grid::unit(1, "null")+ #' ) |
|
| 62 |
- } else {
+ #' |
||
| 63 | -18x | +
- padding+ #' @export |
|
| 64 |
- }+ s_proportion <- function(df, |
||
| 65 |
- }+ .var, |
||
| 66 |
- )+ conf_level = 0.95, |
||
| 67 | -3x | +
- hts <- do.call(grid::unit.c, hts)+ method = c( |
|
| 68 |
-
+ "waldcc", "wald", "clopper-pearson", |
||
| 69 | -3x | +
- main_vp <- grid::viewport(+ "wilson", "wilsonc", "strat_wilson", "strat_wilsonc", |
|
| 70 | -3x | +
- layout = grid::grid.layout(nrow = n_layout, ncol = 1, heights = hts)+ "agresti-coull", "jeffreys" |
|
| 71 |
- )+ ), |
||
| 72 |
-
+ weights = NULL, |
||
| 73 | -3x | +
- nested_grobs <- Map(function(g, i) {
+ max_iterations = 50, |
|
| 74 | -21x | +
- grid::gTree(+ variables = list(strata = NULL), |
|
| 75 | -21x | +
- children = grid::gList(g),+ long = FALSE) {
|
|
| 76 | -21x | +167x |
- vp = grid::viewport(layout.pos.row = i, layout.pos.col = 1)+ method <- match.arg(method) |
| 77 | -+ | 167x |
- )+ checkmate::assert_flag(long) |
| 78 | -3x | +167x |
- }, grobs, seq_along(grobs) * 2 - 1)+ assert_proportion_value(conf_level) |
| 80 | -3x | +167x |
- grobs_mainvp <- grid::gTree(+ if (!is.null(variables$strata)) {
|
| 81 | -3x | +
- children = do.call(grid::gList, nested_grobs),+ # Checks for strata |
|
| 82 | -3x | +! |
- vp = main_vp+ if (missing(df)) stop("When doing stratified analysis a data.frame with specific columns is needed.")
|
| 83 | -+ | ! |
- )+ strata_colnames <- variables$strata |
| 84 | -+ | ! |
-
+ checkmate::assert_character(strata_colnames, null.ok = FALSE) |
| 85 | -3x | +! |
- grid::gTree(+ strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames) |
| 86 | -3x | +! |
- children = grid::gList(grobs_mainvp),+ assert_df_with_variables(df, strata_vars) |
| 87 | -3x | +
- vp = vp,+ |
|
| 88 | -3x | +! |
- gp = gp,+ strata <- interaction(df[strata_colnames]) |
| 89 | -3x | +! |
- name = name+ strata <- as.factor(strata) |
| 90 |
- )+ |
||
| 91 |
- }+ # Pushing down checks to prop_strat_wilson |
||
| 92 | -+ | 167x |
-
+ } else if (checkmate::test_subset(method, c("strat_wilson", "strat_wilsonc"))) {
|
| 93 | -+ | ! |
- #' Arrange multiple grobs+ stop("To use stratified methods you need to specify the strata variables.")
|
| 94 |
- #'+ } |
||
| 95 | -+ | 167x |
- #' @description `r lifecycle::badge("deprecated")`
+ if (checkmate::test_atomic_vector(df)) {
|
| 96 | -+ | 167x |
- #'+ rsp <- as.logical(df) |
| 97 |
- #' Arrange grobs as a new grob with `n * m (rows * cols)` layout.+ } else {
|
||
| 98 | -+ | ! |
- #'+ rsp <- as.logical(df[[.var]]) |
| 99 |
- #' @inheritParams stack_grobs+ } |
||
| 100 | -+ | 167x |
- #' @param ncol (`integer(1)`)\cr number of columns in layout.+ n <- sum(rsp) |
| 101 | -+ | 167x |
- #' @param nrow (`integer(1)`)\cr number of rows in layout.+ p_hat <- mean(rsp) |
| 102 |
- #' @param padding_ht (`grid::unit`)\cr unit of length 1, vertical space between each grob.+ |
||
| 103 | -+ | 167x |
- #' @param padding_wt (`grid::unit`)\cr unit of length 1, horizontal space between each grob.+ prop_ci <- switch(method, |
| 104 | -+ | 167x |
- #'+ "clopper-pearson" = prop_clopper_pearson(rsp, conf_level), |
| 105 | -+ | 167x |
- #' @return A `grob`.+ "wilson" = prop_wilson(rsp, conf_level), |
| 106 | -+ | 167x |
- #'+ "wilsonc" = prop_wilson(rsp, conf_level, correct = TRUE), |
| 107 | -+ | 167x |
- #' @examples+ "strat_wilson" = prop_strat_wilson(rsp, |
| 108 | -+ | 167x |
- #' library(grid)+ strata, |
| 109 | -+ | 167x |
- #'+ weights, |
| 110 | -+ | 167x |
- #' \donttest{
+ conf_level, |
| 111 | -+ | 167x |
- #' num <- lapply(1:9, textGrob)+ max_iterations, |
| 112 | -+ | 167x |
- #' grid::grid.newpage()+ correct = FALSE |
| 113 | -+ | 167x |
- #' grid.draw(arrange_grobs(grobs = num, ncol = 2))+ )$conf_int, |
| 114 | -+ | 167x |
- #'+ "strat_wilsonc" = prop_strat_wilson(rsp, |
| 115 | -+ | 167x |
- #' showViewport()+ strata, |
| 116 | -+ | 167x |
- #'+ weights, |
| 117 | -+ | 167x |
- #' g1 <- circleGrob(gp = gpar(col = "blue"))+ conf_level, |
| 118 | -+ | 167x |
- #' g2 <- circleGrob(gp = gpar(col = "red"))+ max_iterations, |
| 119 | -+ | 167x |
- #' g3 <- textGrob("TEST TEXT")
+ correct = TRUE |
| 120 | -+ | 167x |
- #' grid::grid.newpage()+ )$conf_int, |
| 121 | -+ | 167x |
- #' grid.draw(arrange_grobs(g1, g2, g3, nrow = 2))+ "wald" = prop_wald(rsp, conf_level), |
| 122 | -+ | 167x |
- #'+ "waldcc" = prop_wald(rsp, conf_level, correct = TRUE), |
| 123 | -+ | 167x |
- #' showViewport()+ "agresti-coull" = prop_agresti_coull(rsp, conf_level), |
| 124 | -+ | 167x |
- #'+ "jeffreys" = prop_jeffreys(rsp, conf_level) |
| 125 |
- #' grid::grid.newpage()+ ) |
||
| 126 |
- #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 3))+ |
||
| 127 | -+ | 167x |
- #'+ list( |
| 128 | -+ | 167x |
- #' grid::grid.newpage()+ "n_prop" = formatters::with_label(c(n, p_hat), "Responders"), |
| 129 | -+ | 167x |
- #' grid::pushViewport(grid::viewport(layout = grid::grid.layout(1, 2)))+ "prop_ci" = formatters::with_label( |
| 130 | -+ | 167x |
- #' vp1 <- grid::viewport(layout.pos.row = 1, layout.pos.col = 2)+ x = 100 * prop_ci, label = d_proportion(conf_level, method, long = long) |
| 131 |
- #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 2, vp = vp1))+ ) |
||
| 132 |
- #'+ ) |
||
| 133 |
- #' showViewport()+ } |
||
| 134 |
- #' }+ |
||
| 135 |
- #' @export+ #' @describeIn estimate_proportion Formatted analysis function which is used as `afun` |
||
| 136 |
- arrange_grobs <- function(...,+ #' in `estimate_proportion()`. |
||
| 137 |
- grobs = list(...),+ #' |
||
| 138 |
- ncol = NULL, nrow = NULL,+ #' @return |
||
| 139 |
- padding_ht = grid::unit(2, "line"),+ #' * `a_proportion()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 140 |
- padding_wt = grid::unit(2, "line"),+ #' |
||
| 141 |
- vp = NULL,+ #' @export |
||
| 142 |
- gp = NULL,+ a_proportion <- make_afun( |
||
| 143 |
- name = NULL) {
+ s_proportion, |
||
| 144 | -5x | +
- lifecycle::deprecate_warn(+ .formats = c(n_prop = "xx (xx.x%)", prop_ci = "(xx.x, xx.x)") |
|
| 145 | -5x | +
- "0.9.4",+ ) |
|
| 146 | -5x | +
- "arrange_grobs()",+ |
|
| 147 | -5x | +
- details = "`tern` plotting functions no longer generate `grob` objects."+ #' @describeIn estimate_proportion Layout-creating function which can take statistics function arguments |
|
| 148 |
- )+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 149 |
-
+ #' |
||
| 150 | -5x | +
- checkmate::assert_true(+ #' @return |
|
| 151 | -5x | +
- all(vapply(grobs, grid::is.grob, logical(1)))+ #' * `estimate_proportion()` returns a layout object suitable for passing to further layouting functions, |
|
| 152 |
- )+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 153 |
-
+ #' the statistics from `s_proportion()` to the table layout. |
||
| 154 | -5x | +
- if (length(grobs) == 1) {
+ #' |
|
| 155 | -1x | +
- return(grobs[[1]])+ #' @examples |
|
| 156 |
- }+ #' dta_test <- data.frame( |
||
| 157 |
-
+ #' USUBJID = paste0("S", 1:12),
|
||
| 158 | -4x | +
- if (is.null(ncol) && is.null(nrow)) {
+ #' ARM = rep(LETTERS[1:3], each = 4), |
|
| 159 | -1x | +
- ncol <- 1+ #' AVAL = rep(LETTERS[1:3], each = 4) |
|
| 160 | -1x | +
- nrow <- ceiling(length(grobs) / ncol)+ #' ) |
|
| 161 | -3x | +
- } else if (!is.null(ncol) && is.null(nrow)) {
+ #' |
|
| 162 | -1x | +
- nrow <- ceiling(length(grobs) / ncol)+ #' basic_table() %>% |
|
| 163 | -2x | +
- } else if (is.null(ncol) && !is.null(nrow)) {
+ #' split_cols_by("ARM") %>%
|
|
| 164 | -! | +
- ncol <- ceiling(length(grobs) / nrow)+ #' estimate_proportion(vars = "AVAL") %>% |
|
| 165 |
- }+ #' build_table(df = dta_test) |
||
| 166 |
-
+ #' |
||
| 167 | -4x | +
- if (ncol * nrow < length(grobs)) {
+ #' @export |
|
| 168 | -1x | +
- stop("specififed ncol and nrow are not enough for arranging the grobs ")
+ #' @order 2 |
|
| 169 |
- }+ estimate_proportion <- function(lyt, |
||
| 170 |
-
+ vars, |
||
| 171 | -3x | +
- if (ncol == 1) {
+ conf_level = 0.95, |
|
| 172 | -2x | +
- return(stack_grobs(grobs = grobs, padding = padding_ht, vp = vp, gp = gp, name = name))+ method = c( |
|
| 173 |
- }+ "waldcc", "wald", "clopper-pearson", |
||
| 174 |
-
+ "wilson", "wilsonc", "strat_wilson", "strat_wilsonc", |
||
| 175 | -1x | +
- n_col <- 2 * ncol - 1+ "agresti-coull", "jeffreys" |
|
| 176 | -1x | +
- n_row <- 2 * nrow - 1+ ), |
|
| 177 | -1x | +
- hts <- lapply(+ weights = NULL, |
|
| 178 | -1x | +
- seq(1, n_row),+ max_iterations = 50, |
|
| 179 | -1x | +
- function(i) {
+ variables = list(strata = NULL), |
|
| 180 | -5x | +
- if (i %% 2 != 0) {
+ long = FALSE, |
|
| 181 | -3x | +
- grid::unit(1, "null")+ na_str = default_na_str(), |
|
| 182 |
- } else {
+ nested = TRUE, |
||
| 183 | -2x | +
- padding_ht+ ..., |
|
| 184 |
- }+ show_labels = "hidden", |
||
| 185 |
- }+ table_names = vars, |
||
| 186 |
- )+ .stats = NULL, |
||
| 187 | -1x | +
- hts <- do.call(grid::unit.c, hts)+ .formats = NULL, |
|
| 188 |
-
+ .labels = NULL, |
||
| 189 | -1x | +
- wts <- lapply(+ .indent_mods = NULL) {
|
|
| 190 | -1x | +3x |
- seq(1, n_col),+ extra_args <- list( |
| 191 | -1x | +3x |
- function(i) {
+ conf_level = conf_level, method = method, weights = weights, max_iterations = max_iterations, |
| 192 | -5x | +3x |
- if (i %% 2 != 0) {
+ variables = variables, long = long, ... |
| 193 | -3x | +
- grid::unit(1, "null")+ ) |
|
| 194 |
- } else {
+
|
||
| 195 | -2x | +3x |
- padding_wt+ afun <- make_afun( |
| 196 | -+ | 3x |
- }+ a_proportion, |
| 197 | -+ | 3x |
- }+ .stats = .stats, |
| 198 | -+ | 3x |
- )+ .formats = .formats, |
| 199 | -1x | +3x |
- wts <- do.call(grid::unit.c, wts)+ .labels = .labels, |
| 200 | -+ | 3x |
-
+ .indent_mods = .indent_mods |
| 201 | -1x | +
- main_vp <- grid::viewport(+ ) |
|
| 202 | -1x | +3x |
- layout = grid::grid.layout(nrow = n_row, ncol = n_col, widths = wts, heights = hts)+ analyze( |
| 203 | -+ | 3x |
- )+ lyt, |
| 204 | -+ | 3x |
-
+ vars, |
| 205 | -1x | +3x |
- nested_grobs <- list()+ afun = afun, |
| 206 | -1x | +3x |
- k <- 0+ na_str = na_str, |
| 207 | -1x | +3x |
- for (i in seq(nrow) * 2 - 1) {
+ nested = nested, |
| 208 | 3x |
- for (j in seq(ncol) * 2 - 1) {
+ extra_args = extra_args, |
|
| 209 | -9x | +3x |
- k <- k + 1+ show_labels = show_labels, |
| 210 | -9x | +3x |
- if (k <= length(grobs)) {
+ table_names = table_names |
| 211 | -9x | +
- nested_grobs <- c(+ ) |
|
| 212 | -9x | +
- nested_grobs,+ } |
|
| 213 | -9x | +
- list(grid::gTree(+ |
|
| 214 | -9x | +
- children = grid::gList(grobs[[k]]),+ #' Helper functions for calculating proportion confidence intervals |
|
| 215 | -9x | +
- vp = grid::viewport(layout.pos.row = i, layout.pos.col = j)+ #' |
|
| 216 |
- ))+ #' @description `r lifecycle::badge("stable")`
|
||
| 217 |
- )+ #' |
||
| 218 |
- }+ #' Functions to calculate different proportion confidence intervals for use in [estimate_proportion()]. |
||
| 219 |
- }+ #' |
||
| 220 |
- }+ #' @inheritParams argument_convention |
||
| 221 | -1x | +
- grobs_mainvp <- grid::gTree(+ #' @inheritParams estimate_proportion |
|
| 222 | -1x | +
- children = do.call(grid::gList, nested_grobs),+ #' |
|
| 223 | -1x | +
- vp = main_vp+ #' @return Confidence interval of a proportion. |
|
| 224 |
- )+ #' |
||
| 225 |
-
+ #' @seealso [estimate_proportion], descriptive function [d_proportion()], |
||
| 226 | -1x | +
- grid::gTree(+ #' and helper functions [strata_normal_quantile()] and [update_weights_strat_wilson()]. |
|
| 227 | -1x | +
- children = grid::gList(grobs_mainvp),+ #' |
|
| 228 | -1x | +
- vp = vp,+ #' @name h_proportions |
|
| 229 | -1x | +
- gp = gp,+ NULL |
|
| 230 | -1x | +
- name = name+ |
|
| 231 |
- )+ #' @describeIn h_proportions Calculates the Wilson interval by calling [stats::prop.test()]. |
||
| 232 |
- }+ #' Also referred to as Wilson score interval. |
||
| 233 |
-
+ #' |
||
| 234 |
- #' Draw `grob`+ #' @examples |
||
| 235 |
- #'+ #' rsp <- c( |
||
| 236 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' TRUE, TRUE, TRUE, TRUE, TRUE, |
||
| 237 |
- #'+ #' FALSE, FALSE, FALSE, FALSE, FALSE |
||
| 238 |
- #' Draw grob on device page.+ #' ) |
||
| 239 |
- #'+ #' prop_wilson(rsp, conf_level = 0.9) |
||
| 240 |
- #' @param grob (`grob`)\cr grid object.+ #' |
||
| 241 |
- #' @param newpage (`flag`)\cr draw on a new page.+ #' @export |
||
| 242 |
- #' @param vp (`viewport` or `NULL`)\cr a [viewport()] object (or `NULL`).+ prop_wilson <- function(rsp, conf_level, correct = FALSE) {
|
||
| 243 | -+ | 5x |
- #'+ y <- stats::prop.test( |
| 244 | -+ | 5x |
- #' @return A `grob`.+ sum(rsp), |
| 245 | -+ | 5x |
- #'+ length(rsp), |
| 246 | -+ | 5x |
- #' @examples+ correct = correct, |
| 247 | -+ | 5x |
- #' library(dplyr)+ conf.level = conf_level |
| 248 |
- #' library(grid)+ ) |
||
| 249 |
- #'+ |
||
| 250 | -+ | 5x |
- #' \donttest{
+ as.numeric(y$conf.int) |
| 251 |
- #' rect <- rectGrob(width = grid::unit(0.5, "npc"), height = grid::unit(0.5, "npc"))+ } |
||
| 252 |
- #' rect %>% draw_grob(vp = grid::viewport(angle = 45))+ |
||
| 253 |
- #'+ #' @describeIn h_proportions Calculates the stratified Wilson confidence |
||
| 254 |
- #' num <- lapply(1:10, textGrob)+ #' interval for unequal proportions as described in \insertCite{Yan2010-jt;textual}{tern}
|
||
| 255 |
- #' num %>%+ #' |
||
| 256 |
- #' arrange_grobs(grobs = .) %>%+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`. |
||
| 257 |
- #' draw_grob()+ #' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are |
||
| 258 |
- #' showViewport()+ #' estimated using the iterative algorithm proposed in \insertCite{Yan2010-jt;textual}{tern} that
|
||
| 259 |
- #' }+ #' minimizes the weighted squared length of the confidence interval. |
||
| 260 |
- #'+ #' @param max_iterations (`count`)\cr maximum number of iterations for the iterative procedure used |
||
| 261 |
- #' @export+ #' to find estimates of optimal weights. |
||
| 262 |
- draw_grob <- function(grob, newpage = TRUE, vp = NULL) {
- |
- ||
| 263 | -3x | -
- lifecycle::deprecate_warn(- |
- |
| 264 | -3x | -
- "0.9.4",- |
- |
| 265 | -3x | -
- "draw_grob()",- |
- |
| 266 | -3x | -
- details = "`tern` plotting functions no longer generate `grob` objects."- |
- |
| 267 | -- |
- )- |
- |
| 268 | -- | - - | -|
| 269 | -3x | -
- if (newpage) {
- |
- |
| 270 | -3x | -
- grid::grid.newpage()- |
- |
| 271 | -- |
- }- |
- |
| 272 | -3x | -
- if (!is.null(vp)) {
- |
- |
| 273 | -1x | -
- grid::pushViewport(vp)- |
- |
| 274 | -- |
- }- |
- |
| 275 | -3x | -
- grid::grid.draw(grob)- |
- |
| 276 | -- |
- }- |
- |
| 277 | -- | - - | -|
| 278 | -- |
- tern_grob <- function(x) {
- |
- |
| 279 | -! | -
- class(x) <- unique(c("ternGrob", class(x)))
- |
- |
| 280 | -! | -
- x- |
- |
| 281 | -- |
- }- |
- |
| 282 | -- | - - | -|
| 283 | -- |
- #' @keywords internal- |
- |
| 284 | -- |
- print.ternGrob <- function(x, ...) {
- |
- |
| 285 | -! | -
- grid::grid.newpage()- |
- |
| 286 | -! | -
- grid::grid.draw(x)- |
- |
| 287 | -- |
- }- |
-
| 1 | -- |
- #' Add titles, footnotes, page Number, and a bounding box to a grid grob- |
- ||
| 2 | -- |
- #'+ #' @param correct (`flag`)\cr whether to include the continuity correction. For further information, see for example |
||
| 3 | +263 |
- #' @description `r lifecycle::badge("stable")`
+ #' for [stats::prop.test()]. |
||
| 4 | +264 |
#' |
||
| 5 | +265 |
- #' This function is useful to label grid grobs (also `ggplot2`, and `lattice` plots)+ #' @references |
||
| 6 | +266 |
- #' with title, footnote, and page numbers.+ #' \insertRef{Yan2010-jt}{tern}
|
||
| 7 | +267 |
#' |
||
| 8 | +268 |
- #' @inheritParams grid::grob+ #' @examples |
||
| 9 | +269 |
- #' @param grob (`grob`)\cr a grid grob object, optionally `NULL` if only a `grob` with the decoration should be shown.+ #' # Stratified Wilson confidence interval with unequal probabilities |
||
| 10 | +270 |
- #' @param titles (`character`)\cr titles given as a vector of strings that are each separated by a newline and wrapped+ #' |
||
| 11 | +271 |
- #' according to the page width.+ #' set.seed(1) |
||
| 12 | +272 |
- #' @param footnotes (`character`)\cr footnotes. Uses the same formatting rules as `titles`.+ #' rsp <- sample(c(TRUE, FALSE), 100, TRUE) |
||
| 13 | +273 |
- #' @param page (`string` or `NULL`)\cr page numeration. If `NULL` then no page number is displayed.+ #' strata_data <- data.frame( |
||
| 14 | +274 |
- #' @param width_titles (`grid::unit`)\cr width of titles. Usually defined as all the available space+ #' "f1" = sample(c("a", "b"), 100, TRUE),
|
||
| 15 | +275 |
- #' `grid::unit(1, "npc")`, it is affected by the parameter `outer_margins`. Right margins (`outer_margins[4]`)+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
||
| 16 | +276 |
- #' need to be subtracted to the allowed width.+ #' stringsAsFactors = TRUE |
||
| 17 | +277 |
- #' @param width_footnotes (`grid::unit`)\cr width of footnotes. Same default and margin correction as `width_titles`.+ #' ) |
||
| 18 | +278 |
- #' @param border (`flag`)\cr whether a border should be drawn around the plot or not.+ #' strata <- interaction(strata_data) |
||
| 19 | +279 |
- #' @param padding (`grid::unit`)\cr padding. A unit object of length 4. Innermost margin between the plot (`grob`)+ #' n_strata <- ncol(table(rsp, strata)) # Number of strata |
||
| 20 | +280 |
- #' and, possibly, the border of the plot. Usually expressed in 4 identical values (usually `"lines"`). It defaults+ #' |
||
| 21 | +281 |
- #' to `grid::unit(rep(1, 4), "lines")`.+ #' prop_strat_wilson( |
||
| 22 | +282 |
- #' @param margins (`grid::unit`)\cr margins. A unit object of length 4. Margins between the plot and the other+ #' rsp = rsp, strata = strata, |
||
| 23 | +283 |
- #' elements in the list (e.g. titles, plot, and footers). This is usually expressed in 4 `"lines"`, where the+ #' conf_level = 0.90 |
||
| 24 | +284 |
- #' lateral ones are 0s, while top and bottom are 1s. It defaults to `grid::unit(c(1, 0, 1, 0), "lines")`.+ #' ) |
||
| 25 | +285 |
- #' @param outer_margins (`grid::unit`)\cr outer margins. A unit object of length 4. It defines the general margin of+ #' |
||
| 26 | +286 |
- #' the plot, considering also decorations like titles, footnotes, and page numbers. It defaults to+ #' # Not automatic setting of weights |
||
| 27 | +287 |
- #' `grid::unit(c(2, 1.5, 3, 1.5), "cm")`.+ #' prop_strat_wilson( |
||
| 28 | +288 |
- #' @param gp_titles (`gpar`)\cr a `gpar` object. Mainly used to set different `"fontsize"`.+ #' rsp = rsp, strata = strata, |
||
| 29 | +289 |
- #' @param gp_footnotes (`gpar`)\cr a `gpar` object. Mainly used to set different `"fontsize"`.+ #' weights = rep(1 / n_strata, n_strata), |
||
| 30 | +290 |
- #'+ #' conf_level = 0.90 |
||
| 31 | +291 |
- #' @return A grid grob (`gTree`).+ #' ) |
||
| 32 | +292 |
#' |
||
| 33 | +293 |
- #' @details The titles and footnotes will be ragged, i.e. each title will be wrapped individually.+ #' @export |
||
| 34 | +294 |
- #'+ prop_strat_wilson <- function(rsp, |
||
| 35 | +295 |
- #' @examples+ strata, |
||
| 36 | +296 |
- #' library(grid)+ weights = NULL, |
||
| 37 | +297 |
- #'+ conf_level = 0.95, |
||
| 38 | +298 |
- #' titles <- c(+ max_iterations = NULL, |
||
| 39 | +299 |
- #' "Edgar Anderson's Iris Data",+ correct = FALSE) {
|
||
| 40 | -+ | |||
| 300 | +20x |
- #' paste(+ checkmate::assert_logical(rsp, any.missing = FALSE) |
||
| 41 | -+ | |||
| 301 | +20x |
- #' "This famous (Fisher's or Anderson's) iris data set gives the measurements",+ checkmate::assert_factor(strata, len = length(rsp)) |
||
| 42 | -+ | |||
| 302 | +20x |
- #' "in centimeters of the variables sepal length and width and petal length",+ assert_proportion_value(conf_level) |
||
| 43 | +303 |
- #' "and width, respectively, for 50 flowers from each of 3 species of iris."+ |
||
| 44 | -+ | |||
| 304 | +20x |
- #' )+ tbl <- table(rsp, strata) |
||
| 45 | -+ | |||
| 305 | +20x |
- #' )+ n_strata <- length(unique(strata)) |
||
| 46 | +306 |
- #'+ |
||
| 47 | +307 |
- #' footnotes <- c(+ # Checking the weights and maximum number of iterations. |
||
| 48 | -+ | |||
| 308 | +20x |
- #' "The species are Iris setosa, versicolor, and virginica.",+ do_iter <- FALSE |
||
| 49 | -+ | |||
| 309 | +20x |
- #' paste(+ if (is.null(weights)) {
|
||
| 50 | -+ | |||
| 310 | +6x |
- #' "iris is a data frame with 150 cases (rows) and 5 variables (columns) named",+ weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure |
||
| 51 | -+ | |||
| 311 | +6x |
- #' "Sepal.Length, Sepal.Width, Petal.Length, Petal.Width, and Species."+ do_iter <- TRUE |
||
| 52 | +312 |
- #' )+ |
||
| 53 | +313 |
- #' )+ # Iteration parameters |
||
| 54 | -+ | |||
| 314 | +2x |
- #'+ if (is.null(max_iterations)) max_iterations <- 10 |
||
| 55 | -+ | |||
| 315 | +6x |
- #' ## empty plot+ checkmate::assert_int(max_iterations, na.ok = FALSE, null.ok = FALSE, lower = 1) |
||
| 56 | +316 |
- #' grid.newpage()+ } |
||
| 57 | -+ | |||
| 317 | +20x |
- #'+ checkmate::assert_numeric(weights, lower = 0, upper = 1, any.missing = FALSE, len = n_strata) |
||
| 58 | -+ | |||
| 318 | +20x |
- #' grid.draw(+ sum_weights <- checkmate::assert_int(sum(weights)) |
||
| 59 | -+ | |||
| 319 | +! |
- #' decorate_grob(+ if (as.integer(sum_weights + 0.5) != 1L) stop("Sum of weights must be 1L.")
|
||
| 60 | +320 |
- #' NULL,+ |
||
| 61 | -+ | |||
| 321 | +20x |
- #' titles = titles,+ xs <- tbl["TRUE", ] |
||
| 62 | -+ | |||
| 322 | +20x |
- #' footnotes = footnotes,+ ns <- colSums(tbl) |
||
| 63 | -+ | |||
| 323 | +20x |
- #' page = "Page 4 of 10"+ use_stratum <- (ns > 0) |
||
| 64 | -+ | |||
| 324 | +20x |
- #' )+ ns <- ns[use_stratum] |
||
| 65 | -+ | |||
| 325 | +20x |
- #' )+ xs <- xs[use_stratum] |
||
| 66 | -+ | |||
| 326 | +20x |
- #'+ ests <- xs / ns |
||
| 67 | -+ | |||
| 327 | +20x |
- #' # grid+ vars <- ests * (1 - ests) / ns |
||
| 68 | +328 |
- #' p <- gTree(+ |
||
| 69 | -+ | |||
| 329 | +20x |
- #' children = gList(+ strata_qnorm <- strata_normal_quantile(vars, weights, conf_level) |
||
| 70 | +330 |
- #' rectGrob(),+ |
||
| 71 | +331 |
- #' xaxisGrob(),+ # Iterative setting of weights if they were not set externally |
||
| 72 | -+ | |||
| 332 | +20x |
- #' yaxisGrob(),+ weights_new <- if (do_iter) {
|
||
| 73 | -+ | |||
| 333 | +6x |
- #' textGrob("Sepal.Length", y = unit(-4, "lines")),
+ update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max_iterations, conf_level)$weights |
||
| 74 | +334 |
- #' textGrob("Petal.Length", x = unit(-3.5, "lines"), rot = 90),
+ } else {
|
||
| 75 | -+ | |||
| 335 | +14x |
- #' pointsGrob(iris$Sepal.Length, iris$Petal.Length, gp = gpar(col = iris$Species), pch = 16)+ weights |
||
| 76 | +336 |
- #' ),+ } |
||
| 77 | +337 |
- #' vp = vpStack(plotViewport(), dataViewport(xData = iris$Sepal.Length, yData = iris$Petal.Length))+ |
||
| 78 | -+ | |||
| 338 | +20x |
- #' )+ strata_conf_level <- 2 * stats::pnorm(strata_qnorm) - 1 |
||
| 79 | +339 |
- #' grid.newpage()+ |
||
| 80 | -+ | |||
| 340 | +20x |
- #' grid.draw(p)+ ci_by_strata <- Map( |
||
| 81 | -+ | |||
| 341 | +20x |
- #'+ function(x, n) {
|
||
| 82 | +342 |
- #' grid.newpage()+ # Classic Wilson's confidence interval |
||
| 83 | -+ | |||
| 343 | +139x |
- #' grid.draw(+ suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf_level)$conf.int) |
||
| 84 | +344 |
- #' decorate_grob(+ }, |
||
| 85 | -+ | |||
| 345 | +20x |
- #' grob = p,+ x = xs, |
||
| 86 | -+ | |||
| 346 | +20x |
- #' titles = titles,+ n = ns |
||
| 87 | +347 |
- #' footnotes = footnotes,+ ) |
||
| 88 | -+ | |||
| 348 | +20x |
- #' page = "Page 6 of 129"+ lower_by_strata <- sapply(ci_by_strata, "[", 1L) |
||
| 89 | -+ | |||
| 349 | +20x |
- #' )+ upper_by_strata <- sapply(ci_by_strata, "[", 2L) |
||
| 90 | +350 |
- #' )+ |
||
| 91 | -+ | |||
| 351 | +20x |
- #'+ lower <- sum(weights_new * lower_by_strata) |
||
| 92 | -+ | |||
| 352 | +20x |
- #' ## with ggplot2+ upper <- sum(weights_new * upper_by_strata) |
||
| 93 | +353 |
- #' library(ggplot2)+ |
||
| 94 | +354 |
- #'+ # Return values |
||
| 95 | -+ | |||
| 355 | +20x |
- #' p_gg <- ggplot2::ggplot(iris, aes(Sepal.Length, Sepal.Width, col = Species)) ++ if (do_iter) {
|
||
| 96 | -+ | |||
| 356 | +6x |
- #' ggplot2::geom_point()+ list( |
||
| 97 | -+ | |||
| 357 | +6x |
- #' p_gg+ conf_int = c( |
||
| 98 | -+ | |||
| 358 | +6x |
- #' p <- ggplotGrob(p_gg)+ lower = lower, |
||
| 99 | -+ | |||
| 359 | +6x |
- #' grid.newpage()+ upper = upper |
||
| 100 | +360 |
- #' grid.draw(+ ), |
||
| 101 | -+ | |||
| 361 | +6x |
- #' decorate_grob(+ weights = weights_new |
||
| 102 | +362 |
- #' grob = p,+ ) |
||
| 103 | +363 |
- #' titles = titles,+ } else {
|
||
| 104 | -+ | |||
| 364 | +14x |
- #' footnotes = footnotes,+ list( |
||
| 105 | -+ | |||
| 365 | +14x |
- #' page = "Page 6 of 129"+ conf_int = c( |
||
| 106 | -+ | |||
| 366 | +14x |
- #' )+ lower = lower, |
||
| 107 | -+ | |||
| 367 | +14x |
- #' )+ upper = upper |
||
| 108 | +368 |
- #'+ ) |
||
| 109 | +369 |
- #' ## with lattice+ ) |
||
| 110 | +370 |
- #' library(lattice)+ } |
||
| 111 | +371 |
- #'+ } |
||
| 112 | +372 |
- #' xyplot(Sepal.Length ~ Petal.Length, data = iris, col = iris$Species)+ |
||
| 113 | +373 |
- #' p <- grid.grab()+ #' @describeIn h_proportions Calculates the Clopper-Pearson interval by calling [stats::binom.test()]. |
||
| 114 | +374 |
- #' grid.newpage()+ #' Also referred to as the `exact` method. |
||
| 115 | +375 |
- #' grid.draw(+ #' |
||
| 116 | +376 |
- #' decorate_grob(+ #' @examples |
||
| 117 | +377 |
- #' grob = p,+ #' prop_clopper_pearson(rsp, conf_level = .95) |
||
| 118 | +378 |
- #' titles = titles,+ #' |
||
| 119 | +379 |
- #' footnotes = footnotes,+ #' @export |
||
| 120 | +380 |
- #' page = "Page 6 of 129"+ prop_clopper_pearson <- function(rsp, |
||
| 121 | +381 |
- #' )+ conf_level) {
|
||
| 122 | -+ | |||
| 382 | +1x |
- #' )+ y <- stats::binom.test( |
||
| 123 | -+ | |||
| 383 | +1x |
- #'+ x = sum(rsp), |
||
| 124 | -+ | |||
| 384 | +1x |
- #' # with gridExtra - no borders+ n = length(rsp), |
||
| 125 | -+ | |||
| 385 | +1x |
- #' library(gridExtra)+ conf.level = conf_level |
||
| 126 | +386 |
- #' grid.newpage()+ )+ |
+ ||
| 387 | +1x | +
+ as.numeric(y$conf.int) |
||
| 127 | +388 |
- #' grid.draw(+ } |
||
| 128 | +389 |
- #' decorate_grob(+ |
||
| 129 | +390 |
- #' tableGrob(+ #' @describeIn h_proportions Calculates the Wald interval by following the usual textbook definition |
||
| 130 | +391 |
- #' head(mtcars)+ #' for a single proportion confidence interval using the normal approximation. |
||
| 131 | +392 |
- #' ),+ #' |
||
| 132 | +393 |
- #' titles = "title",+ #' @param correct (`flag`)\cr whether to apply continuity correction. |
||
| 133 | +394 |
- #' footnotes = "footnote",+ #' |
||
| 134 | +395 |
- #' border = FALSE+ #' @examples |
||
| 135 | +396 |
- #' )+ #' prop_wald(rsp, conf_level = 0.95) |
||
| 136 | +397 |
- #' )+ #' prop_wald(rsp, conf_level = 0.95, correct = TRUE) |
||
| 137 | +398 |
#' |
||
| 138 | +399 |
#' @export |
||
| 139 | +400 |
- decorate_grob <- function(grob,+ prop_wald <- function(rsp, conf_level, correct = FALSE) {
|
||
| 140 | -+ | |||
| 401 | +163x |
- titles,+ n <- length(rsp) |
||
| 141 | -+ | |||
| 402 | +163x |
- footnotes,+ p_hat <- mean(rsp) |
||
| 142 | -+ | |||
| 403 | +163x |
- page = "",+ z <- stats::qnorm((1 + conf_level) / 2) |
||
| 143 | -+ | |||
| 404 | +163x |
- width_titles = grid::unit(1, "npc"),+ q_hat <- 1 - p_hat+ |
+ ||
| 405 | +163x | +
+ correct <- if (correct) 1 / (2 * n) else 0 |
||
| 144 | +406 |
- width_footnotes = grid::unit(1, "npc"),+ + |
+ ||
| 407 | +163x | +
+ err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correct+ |
+ ||
| 408 | +163x | +
+ l_ci <- max(0, p_hat - err)+ |
+ ||
| 409 | +163x | +
+ u_ci <- min(1, p_hat + err) |
||
| 145 | +410 |
- border = TRUE,+ + |
+ ||
| 411 | +163x | +
+ c(l_ci, u_ci) |
||
| 146 | +412 |
- padding = grid::unit(rep(1, 4), "lines"),+ } |
||
| 147 | +413 |
- margins = grid::unit(c(1, 0, 1, 0), "lines"),+ |
||
| 148 | +414 |
- outer_margins = grid::unit(c(2, 1.5, 3, 1.5), "cm"),+ #' @describeIn h_proportions Calculates the Agresti-Coull interval. Constructed (for 95% CI) by adding two successes |
||
| 149 | +415 |
- gp_titles = grid::gpar(),+ #' and two failures to the data and then using the Wald formula to construct a CI. |
||
| 150 | +416 |
- gp_footnotes = grid::gpar(fontsize = 8),+ #' |
||
| 151 | +417 |
- name = NULL,+ #' @examples |
||
| 152 | +418 |
- gp = grid::gpar(),+ #' prop_agresti_coull(rsp, conf_level = 0.95) |
||
| 153 | +419 |
- vp = NULL) {
+ #' |
||
| 154 | +420 |
- # External margins need to be taken into account when defining the width of titles and footers+ #' @export |
||
| 155 | +421 |
- # because the text is split in advance depending on only the width of the viewport.+ prop_agresti_coull <- function(rsp, conf_level) {
|
||
| 156 | -9x | +422 | +3x |
- if (any(as.numeric(outer_margins) > 0)) {
+ n <- length(rsp) |
| 157 | -9x | +423 | +3x |
- width_titles <- width_titles - outer_margins[4]+ x_sum <- sum(rsp) |
| 158 | -9x | +424 | +3x |
- width_footnotes <- width_footnotes - outer_margins[4]+ z <- stats::qnorm((1 + conf_level) / 2) |
| 159 | +425 |
- }+ |
||
| 160 | +426 |
-
+ # Add here both z^2 / 2 successes and failures. |
||
| 161 | -9x | +427 | +3x |
- st_titles <- split_text_grob(+ x_sum_tilde <- x_sum + z^2 / 2 |
| 162 | -9x | +428 | +3x |
- titles,+ n_tilde <- n + z^2 |
| 163 | -9x | +|||
| 429 | +
- x = 0, y = 1,+ + |
+ |||
| 430 | ++ |
+ # Then proceed as with the Wald interval. |
||
| 164 | -9x | +431 | +3x |
- just = c("left", "top"),
+ p_tilde <- x_sum_tilde / n_tilde |
| 165 | -9x | +432 | +3x |
- width = width_titles,+ q_tilde <- 1 - p_tilde |
| 166 | -9x | +433 | +3x |
- vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 1),+ err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde) |
| 167 | -9x | +434 | +3x |
- gp = gp_titles+ l_ci <- max(0, p_tilde - err) |
| 168 | -+ | |||
| 435 | +3x |
- )+ u_ci <- min(1, p_tilde + err) |
||
| 169 | +436 | |||
| 170 | -9x | -
- st_footnotes <- split_text_grob(- |
- ||
| 171 | -9x | +437 | +3x |
- footnotes,+ c(l_ci, u_ci) |
| 172 | -9x | +|||
| 438 | +
- x = 0, y = 1,+ } |
|||
| 173 | -9x | +|||
| 439 | +
- just = c("left", "top"),
+
|
|||
| 174 | -9x | +|||
| 440 | +
- width = width_footnotes,+ #' @describeIn h_proportions Calculates the Jeffreys interval, an equal-tailed interval based on the |
|||
| 175 | -9x | +|||
| 441 | +
- vp = grid::viewport(layout.pos.row = 3, layout.pos.col = 1),+ #' non-informative Jeffreys prior for a binomial proportion. |
|||
| 176 | -9x | +|||
| 442 | +
- gp = gp_footnotes+ #' |
|||
| 177 | +443 |
- )+ #' @examples |
||
| 178 | +444 |
-
+ #' prop_jeffreys(rsp, conf_level = 0.95) |
||
| 179 | -9x | +|||
| 445 | +
- pg_footnote <- grid::textGrob(+ #' |
|||
| 180 | -9x | +|||
| 446 | +
- paste("\n", page),
+ #' @export |
|||
| 181 | -9x | +|||
| 447 | +
- x = 1, y = 0,+ prop_jeffreys <- function(rsp, |
|||
| 182 | -9x | +|||
| 448 | +
- just = c("right", "bottom"),
+ conf_level) {
|
|||
| 183 | -9x | +449 | +5x |
- vp = grid::viewport(layout.pos.row = 4, layout.pos.col = 1),+ n <- length(rsp) |
| 184 | -9x | +450 | +5x |
- gp = gp_footnotes+ x_sum <- sum(rsp) |
| 185 | +451 |
- )+ |
||
| 186 | -+ | |||
| 452 | +5x |
-
+ alpha <- 1 - conf_level |
||
| 187 | -+ | |||
| 453 | +5x |
- # Initial decoration of the grob -> border, paddings, and margins are used here+ l_ci <- ifelse( |
||
| 188 | -9x | +454 | +5x |
- main_plot <- grid::gTree(+ x_sum == 0, |
| 189 | -9x | +455 | +5x |
- children = grid::gList(+ 0, |
| 190 | -9x | +456 | +5x |
- if (border) grid::rectGrob(),+ stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5) |
| 191 | -9x | +|||
| 457 | +
- grid::gTree(+ )+ |
+ |||
| 458 | ++ | + | ||
| 192 | -9x | +459 | +5x |
- children = grid::gList(+ u_ci <- ifelse( |
| 193 | -9x | +460 | +5x |
- grob+ x_sum == n, |
| 194 | -+ | |||
| 461 | +5x |
- ),+ 1, |
||
| 195 | -9x | +462 | +5x |
- vp = grid::plotViewport(margins = padding) # innermost margins of the grob plot+ stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5) |
| 196 | +463 |
- )+ ) |
||
| 197 | +464 |
- ),+ |
||
| 198 | -9x | +465 | +5x |
- vp = grid::vpStack(+ c(l_ci, u_ci) |
| 199 | -9x | +|||
| 466 | +
- grid::viewport(layout.pos.row = 2, layout.pos.col = 1),+ } |
|||
| 200 | -9x | +|||
| 467 | +
- grid::plotViewport(margins = margins) # margins around the border plot+ |
|||
| 201 | +468 |
- )+ #' Description of the proportion summary |
||
| 202 | +469 |
- )+ #' |
||
| 203 | +470 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 204 | -9x | +|||
| 471 | +
- grid::gTree(+ #' |
|||
| 205 | -9x | +|||
| 472 | +
- grob = grob,+ #' This is a helper function that describes the analysis in [s_proportion()]. |
|||
| 206 | -9x | +|||
| 473 | +
- titles = titles,+ #' |
|||
| 207 | -9x | +|||
| 474 | +
- footnotes = footnotes,+ #' @inheritParams s_proportion |
|||
| 208 | -9x | +|||
| 475 | +
- page = page,+ #' @param long (`flag`)\cr whether a long or a short (default) description is required. |
|||
| 209 | -9x | +|||
| 476 | +
- width_titles = width_titles,+ #' |
|||
| 210 | -9x | +|||
| 477 | +
- width_footnotes = width_footnotes,+ #' @return String describing the analysis. |
|||
| 211 | -9x | +|||
| 478 | +
- outer_margins = outer_margins,+ #' |
|||
| 212 | -9x | +|||
| 479 | +
- gp_titles = gp_titles,+ #' @export |
|||
| 213 | -9x | +|||
| 480 | +
- gp_footnotes = gp_footnotes,+ d_proportion <- function(conf_level, |
|||
| 214 | -9x | +|||
| 481 | +
- children = grid::gList(+ method, |
|||
| 215 | -9x | +|||
| 482 | +
- grid::gTree(+ long = FALSE) {
|
|||
| 216 | -9x | +483 | +179x |
- children = grid::gList(+ label <- paste0(conf_level * 100, "% CI") |
| 217 | -9x | +|||
| 484 | +
- st_titles,+ |
|||
| 218 | -9x | +|||
| 485 | +! |
- main_plot, # main plot with border, padding, and margins+ if (long) label <- paste(label, "for Response Rates") |
||
| 219 | -9x | +|||
| 486 | +
- st_footnotes,+ |
|||
| 220 | -9x | +487 | +179x |
- pg_footnote+ method_part <- switch(method, |
| 221 | -+ | |||
| 488 | +179x |
- ),+ "clopper-pearson" = "Clopper-Pearson", |
||
| 222 | -9x | +489 | +179x |
- childrenvp = NULL,+ "waldcc" = "Wald, with correction", |
| 223 | -9x | +490 | +179x |
- name = "titles_grob_footnotes",+ "wald" = "Wald, without correction", |
| 224 | -9x | +491 | +179x |
- vp = grid::vpStack(+ "wilson" = "Wilson, without correction", |
| 225 | -9x | +492 | +179x |
- grid::plotViewport(margins = outer_margins), # Main external margins+ "strat_wilson" = "Stratified Wilson, without correction", |
| 226 | -9x | +493 | +179x |
- grid::viewport(+ "wilsonc" = "Wilson, with correction", |
| 227 | -9x | +494 | +179x |
- layout = grid::grid.layout(+ "strat_wilsonc" = "Stratified Wilson, with correction", |
| 228 | -9x | +495 | +179x |
- nrow = 4, ncol = 1,+ "agresti-coull" = "Agresti-Coull", |
| 229 | -9x | +496 | +179x |
- heights = grid::unit.c(+ "jeffreys" = "Jeffreys", |
| 230 | -9x | +497 | +179x |
- grid::grobHeight(st_titles),+ stop(paste(method, "does not have a description")) |
| 231 | -9x | +|||
| 498 | +
- grid::unit(1, "null"),+ ) |
|||
| 232 | -9x | +|||
| 499 | +
- grid::grobHeight(st_footnotes),+ |
|||
| 233 | -9x | +500 | +179x |
- grid::grobHeight(pg_footnote)+ paste0(label, " (", method_part, ")")
|
| 234 | +501 |
- )+ } |
||
| 235 | +502 |
- )+ |
||
| 236 | +503 |
- )+ #' Helper function for the estimation of stratified quantiles |
||
| 237 | +504 |
- )+ #' |
||
| 238 | +505 |
- )+ #' @description `r lifecycle::badge("stable")`
|
||
| 239 | +506 |
- ),+ #' |
||
| 240 | -9x | +|||
| 507 | +
- name = name,+ #' This function wraps the estimation of stratified percentiles when we assume |
|||
| 241 | -9x | +|||
| 508 | +
- gp = gp,+ #' the approximation for large numbers. This is necessary only in the case |
|||
| 242 | -9x | +|||
| 509 | +
- vp = vp,+ #' proportions for each strata are unequal. |
|||
| 243 | -9x | +|||
| 510 | +
- cl = "decoratedGrob"+ #' |
|||
| 244 | +511 |
- )+ #' @inheritParams argument_convention |
||
| 245 | +512 |
- }+ #' @inheritParams prop_strat_wilson |
||
| 246 | +513 |
-
+ #' |
||
| 247 | +514 |
- # nocov start+ #' @return Stratified quantile. |
||
| 248 | +515 |
- #' @importFrom grid validDetails+ #' |
||
| 249 | +516 |
- #' @noRd+ #' @seealso [prop_strat_wilson()] |
||
| 250 | +517 |
- validDetails.decoratedGrob <- function(x) {
+ #' |
||
| 251 | +518 |
- checkmate::assert_character(x$titles)+ #' @examples |
||
| 252 | +519 |
- checkmate::assert_character(x$footnotes)+ #' strata_data <- table(data.frame( |
||
| 253 | +520 |
-
+ #' "f1" = sample(c(TRUE, FALSE), 100, TRUE), |
||
| 254 | +521 |
- if (!is.null(x$grob)) {
+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
||
| 255 | +522 |
- checkmate::assert_true(grid::is.grob(x$grob))+ #' stringsAsFactors = TRUE |
||
| 256 | +523 |
- }+ #' )) |
||
| 257 | +524 |
- if (length(x$page) == 1) {
+ #' ns <- colSums(strata_data) |
||
| 258 | +525 |
- checkmate::assert_character(x$page)+ #' ests <- strata_data["TRUE", ] / ns |
||
| 259 | +526 |
- }+ #' vars <- ests * (1 - ests) / ns |
||
| 260 | +527 |
- if (!grid::is.unit(x$outer_margins)) {
+ #' weights <- rep(1 / length(ns), length(ns)) |
||
| 261 | +528 |
- checkmate::assert_vector(x$outer_margins, len = 4)+ #' |
||
| 262 | +529 |
- }+ #' strata_normal_quantile(vars, weights, 0.95) |
||
| 263 | +530 |
- if (!grid::is.unit(x$margins)) {
+ #' |
||
| 264 | +531 |
- checkmate::assert_vector(x$margins, len = 4)+ #' @export |
||
| 265 | +532 |
- }+ strata_normal_quantile <- function(vars, weights, conf_level) {
|
||
| 266 | -+ | |||
| 533 | +43x |
- if (!grid::is.unit(x$padding)) {
+ summands <- weights^2 * vars |
||
| 267 | +534 |
- checkmate::assert_vector(x$padding, len = 4)+ # Stratified quantile+ |
+ ||
| 535 | +43x | +
+ sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf_level) / 2) |
||
| 268 | +536 |
- }+ } |
||
| 269 | +537 | |||
| 270 | +538 |
- x+ #' Helper function for the estimation of weights for `prop_strat_wilson()` |
||
| 271 | +539 |
- }+ #' |
||
| 272 | +540 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 273 | +541 |
- #' @importFrom grid widthDetails+ #' |
||
| 274 | +542 |
- #' @noRd+ #' This function wraps the iteration procedure that allows you to estimate |
||
| 275 | +543 |
- widthDetails.decoratedGrob <- function(x) {
+ #' the weights for each proportional strata. This assumes to minimize the |
||
| 276 | +544 |
- grid::unit(1, "null")+ #' weighted squared length of the confidence interval. |
||
| 277 | +545 |
- }+ #' |
||
| 278 | +546 |
-
+ #' @inheritParams prop_strat_wilson |
||
| 279 | +547 |
- #' @importFrom grid heightDetails+ #' @param vars (`numeric`)\cr normalized proportions for each strata. |
||
| 280 | +548 |
- #' @noRd+ #' @param strata_qnorm (`numeric(1)`)\cr initial estimation with identical weights of the quantiles. |
||
| 281 | +549 |
- heightDetails.decoratedGrob <- function(x) {
+ #' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can |
||
| 282 | +550 |
- grid::unit(1, "null")+ #' be optimized in the future if we need to estimate better initial weights. |
||
| 283 | +551 |
- }+ #' @param n_per_strata (`numeric`)\cr number of elements in each strata. |
||
| 284 | +552 |
-
+ #' @param max_iterations (`integer(1)`)\cr maximum number of iterations to be tried. Convergence is always checked. |
||
| 285 | +553 |
- #' Split text according to available text width+ #' @param tol (`numeric(1)`)\cr tolerance threshold for convergence. |
||
| 286 | +554 |
#' |
||
| 287 | +555 |
- #' Dynamically wrap text.+ #' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`. |
||
| 288 | +556 |
#' |
||
| 289 | +557 |
- #' @inheritParams grid::grid.text+ #' @seealso For references and details see [prop_strat_wilson()]. |
||
| 290 | +558 |
- #' @param text (`string`)\cr the text to wrap.+ #' |
||
| 291 | +559 |
- #' @param width (`grid::unit`)\cr a unit object specifying maximum width of text.+ #' @examples |
||
| 292 | +560 |
- #'+ #' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018) |
||
| 293 | +561 |
- #' @return A text `grob`.+ #' sq <- 0.674 |
||
| 294 | +562 |
- #'+ #' ws <- rep(1 / length(vs), length(vs)) |
||
| 295 | +563 |
- #' @details This code is taken from `R Graphics by Paul Murell, 2nd edition`+ #' ns <- c(22, 18, 17, 17, 14, 12) |
||
| 296 | +564 |
#' |
||
| 297 | +565 |
- #' @keywords internal+ #' update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001) |
||
| 298 | +566 |
- split_text_grob <- function(text,+ #' |
||
| 299 | +567 |
- x = grid::unit(0.5, "npc"),+ #' @export |
||
| 300 | +568 |
- y = grid::unit(0.5, "npc"),+ update_weights_strat_wilson <- function(vars, |
||
| 301 | +569 |
- width = grid::unit(1, "npc"),+ strata_qnorm, |
||
| 302 | +570 |
- just = "centre",+ initial_weights, |
||
| 303 | +571 |
- hjust = NULL,+ n_per_strata, |
||
| 304 | +572 |
- vjust = NULL,+ max_iterations = 50, |
||
| 305 | +573 |
- default.units = "npc", # nolint+ conf_level = 0.95, |
||
| 306 | +574 |
- name = NULL,+ tol = 0.001) {
|
||
| 307 | -+ | |||
| 575 | +9x |
- gp = grid::gpar(),+ it <- 0 |
||
| 308 | -+ | |||
| 576 | +9x |
- vp = NULL) {
+ diff_v <- NULL |
||
| 309 | +577 |
- text <- gsub("\\\\n", "\n", text) # fixing cases of mixed behavior (\n and \\n)
+
|
||
| 310 | -+ | |||
| 578 | +9x |
-
+ while (it < max_iterations) {
|
||
| 311 | -+ | |||
| 579 | +21x |
- if (!grid::is.unit(x)) x <- grid::unit(x, default.units)+ it <- it + 1 |
||
| 312 | -+ | |||
| 580 | +21x |
- if (!grid::is.unit(y)) y <- grid::unit(y, default.units)+ weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2 |
||
| 313 | -+ | |||
| 581 | +21x |
- if (!grid::is.unit(width)) width <- grid::unit(width, default.units)+ weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2)) |
||
| 314 | -+ | |||
| 582 | +21x |
- if (grid::unitType(x) %in% c("sum", "min", "max")) x <- grid::convertUnit(x, default.units)
+ weights_new <- weights_new_t / weights_new_b |
||
| 315 | -+ | |||
| 583 | +21x |
- if (grid::unitType(y) %in% c("sum", "min", "max")) y <- grid::convertUnit(y, default.units)
+ weights_new <- weights_new / sum(weights_new) |
||
| 316 | -+ | |||
| 584 | +21x |
- if (grid::unitType(width) %in% c("sum", "min", "max")) width <- grid::convertUnit(width, default.units)
+ strata_qnorm <- strata_normal_quantile(vars, weights_new, conf_level) |
||
| 317 | -+ | |||
| 585 | +21x |
-
+ diff_v <- c(diff_v, sum(abs(weights_new - initial_weights))) |
||
| 318 | -+ | |||
| 586 | +8x |
- if (length(gp) > 0) { # account for effect of gp on text width -> it was bugging when text was empty
+ if (diff_v[length(diff_v)] < tol) break |
||
| 319 | -+ | |||
| 587 | +13x |
- horizontal_npc_width_no_gp <- grid::convertWidth(+ initial_weights <- weights_new |
||
| 320 | +588 |
- grid::grobWidth(+ } |
||
| 321 | +589 |
- grid::textGrob(+ |
||
| 322 | -+ | |||
| 590 | +9x |
- paste0(text, collapse = "\n")+ if (it == max_iterations) {
|
||
| 323 | -+ | |||
| 591 | +1x |
- )+ warning("The heuristic to find weights did not converge with max_iterations = ", max_iterations)
|
||
| 324 | +592 |
- ), "npc",+ } |
||
| 325 | +593 |
- valueOnly = TRUE+ |
||
| 326 | -+ | |||
| 594 | +9x |
- )+ list( |
||
| 327 | -+ | |||
| 595 | +9x |
- horizontal_npc_width_with_gp <- grid::convertWidth(grid::grobWidth(+ "n_it" = it, |
||
| 328 | -+ | |||
| 596 | +9x |
- grid::textGrob(+ "weights" = weights_new,+ |
+ ||
| 597 | +9x | +
+ "diff_v" = diff_v |
||
| 329 | +598 |
- paste0(text, collapse = "\n"),+ ) |
||
| 330 | +599 |
- gp = gp+ } |
| 331 | +1 |
- )+ #' Control functions for Kaplan-Meier plot annotation tables |
||
| 332 | +2 |
- ), "npc", valueOnly = TRUE)+ #' |
||
| 333 | +3 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 334 | +4 |
- # Adapting width to the input gpar (it is normalized so does not matter what is text)+ #' |
||
| 335 | +5 |
- width <- width * horizontal_npc_width_no_gp / horizontal_npc_width_with_gp+ #' Auxiliary functions for controlling arguments for formatting the annotation tables that can be added to plots |
||
| 336 | +6 |
- }+ #' generated via [g_km()]. |
||
| 337 | +7 |
-
+ #' |
||
| 338 | +8 |
- ## if it is a fixed unit then we do not need to recalculate when viewport resized+ #' @param x (`proportion`)\cr x-coordinate for center of annotation table. |
||
| 339 | +9 |
- if (!inherits(width, "unit.arithmetic") && !is.null(attr(width, "unit")) &&+ #' @param y (`proportion`)\cr y-coordinate for center of annotation table. |
||
| 340 | +10 |
- attr(width, "unit") %in% c("cm", "inches", "mm", "points", "picas", "bigpts", "dida", "cicero", "scaledpts")) { # nolint
+ #' @param w (`proportion`)\cr relative width of the annotation table. |
||
| 341 | +11 |
- attr(text, "fixed_text") <- paste(vapply(text, split_string, character(1), width = width), collapse = "\n")+ #' @param h (`proportion`)\cr relative height of the annotation table. |
||
| 342 | +12 |
- }+ #' @param fill (`flag` or `character`)\cr whether the annotation table should have a background fill color. |
||
| 343 | +13 |
-
+ #' Can also be a color code to use as the background fill color. If `TRUE`, color code defaults to `"#00000020"`. |
||
| 344 | +14 |
- # Fix for split_string in case of residual \n (otherwise is counted as character)+ #' |
||
| 345 | +15 |
- text2 <- unlist(+ #' @return A list of components with the same names as the arguments. |
||
| 346 | +16 |
- strsplit(+ #' |
||
| 347 | +17 |
- paste0(text, collapse = "\n"), # for "" cases+ #' @seealso [g_km()] |
||
| 348 | +18 |
- "\n"+ #' |
||
| 349 | +19 |
- )+ #' @name control_annot |
||
| 350 | +20 |
- )+ NULL |
||
| 351 | +21 | |||
| 352 | +22 |
- # Final grid text with cat-friendly split_string+ #' @describeIn control_annot Control function for formatting the median survival time annotation table. This annotation |
||
| 353 | +23 |
- grid::grid.text(+ #' table can be added in [g_km()] by setting `annot_surv_med=TRUE`, and can be configured using the |
||
| 354 | +24 |
- label = split_string(text2, width),+ #' `control_surv_med_annot()` function by setting it as the `control_annot_surv_med` argument. |
||
| 355 | +25 |
- x = x, y = y,+ #' |
||
| 356 | +26 |
- just = just,+ #' @examples |
||
| 357 | +27 |
- hjust = hjust,+ #' control_surv_med_annot() |
||
| 358 | +28 |
- vjust = vjust,+ #' |
||
| 359 | +29 |
- rot = 0,+ #' @export |
||
| 360 | +30 |
- check.overlap = FALSE,+ control_surv_med_annot <- function(x = 0.8, y = 0.85, w = 0.32, h = 0.16, fill = TRUE) {
|
||
| 361 | -+ | |||
| 31 | +22x |
- name = name,+ assert_proportion_value(x) |
||
| 362 | -+ | |||
| 32 | +22x |
- gp = gp,+ assert_proportion_value(y) |
||
| 363 | -+ | |||
| 33 | +22x |
- vp = vp,+ assert_proportion_value(w) |
||
| 364 | -+ | |||
| 34 | +22x |
- draw = FALSE+ assert_proportion_value(h) |
||
| 365 | +35 |
- )+ |
||
| 366 | -+ | |||
| 36 | +22x |
- }+ list(x = x, y = y, w = w, h = h, fill = fill) |
||
| 367 | +37 |
-
+ } |
||
| 368 | +38 |
- #' @importFrom grid validDetails+ |
||
| 369 | +39 |
- #' @noRd+ #' @describeIn control_annot Control function for formatting the Cox-PH annotation table. This annotation table can be |
||
| 370 | +40 |
- validDetails.dynamicSplitText <- function(x) {
+ #' added in [g_km()] by setting `annot_coxph=TRUE`, and can be configured using the `control_coxph_annot()` function |
||
| 371 | +41 |
- checkmate::assert_character(x$text)+ #' by setting it as the `control_annot_coxph` argument. |
||
| 372 | +42 |
- checkmate::assert_true(grid::is.unit(x$width))+ #' |
||
| 373 | +43 |
- checkmate::assert_vector(x$width, len = 1)+ #' @param ref_lbls (`flag`)\cr whether the reference group should be explicitly printed in labels for the |
||
| 374 | +44 |
- x+ #' annotation table. If `FALSE` (default), only comparison groups will be printed in the table labels. |
||
| 375 | +45 |
- }+ #' |
||
| 376 | +46 |
-
+ #' @examples |
||
| 377 | +47 |
- #' @importFrom grid heightDetails+ #' control_coxph_annot() |
||
| 378 | +48 |
- #' @noRd+ #' |
||
| 379 | +49 |
- heightDetails.dynamicSplitText <- function(x) {
+ #' @export |
||
| 380 | +50 |
- txt <- if (!is.null(attr(x$text, "fixed_text"))) {
+ control_coxph_annot <- function(x = 0.29, y = 0.51, w = 0.4, h = 0.125, fill = TRUE, ref_lbls = FALSE) {
|
||
| 381 | -+ | |||
| 51 | +11x |
- attr(x$text, "fixed_text")+ checkmate::assert_logical(ref_lbls, any.missing = FALSE) |
||
| 382 | +52 |
- } else {
+
|
||
| 383 | -+ | |||
| 53 | +11x |
- paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n")+ res <- c(control_surv_med_annot(x = x, y = y, w = w, h = h), list(ref_lbls = ref_lbls)) |
||
| 384 | -+ | |||
| 54 | +11x |
- }+ res |
||
| 385 | +55 |
- grid::stringHeight(txt)+ } |
||
| 386 | +56 |
- }+ |
||
| 387 | +57 |
-
+ #' Helper function to calculate x-tick positions |
||
| 388 | +58 |
- #' @importFrom grid widthDetails+ #' |
||
| 389 | +59 |
- #' @noRd+ #' @description `r lifecycle::badge("stable")`
|
||
| 390 | +60 |
- widthDetails.dynamicSplitText <- function(x) {
+ #' |
||
| 391 | +61 |
- x$width+ #' Calculate the positions of ticks on the x-axis. However, if `xticks` already |
||
| 392 | +62 |
- }+ #' exists it is kept as is. It is based on the same function `ggplot2` relies on, |
||
| 393 | +63 |
-
+ #' and is required in the graphic and the patient-at-risk annotation table. |
||
| 394 | +64 |
- #' @importFrom grid drawDetails+ #' |
||
| 395 | +65 |
- #' @noRd+ #' @inheritParams g_km |
||
| 396 | +66 |
- drawDetails.dynamicSplitText <- function(x, recording) {
+ #' @inheritParams h_ggkm |
||
| 397 | +67 |
- txt <- if (!is.null(attr(x$text, "fixed_text"))) {
+ #' |
||
| 398 | +68 |
- attr(x$text, "fixed_text")+ #' @return A vector of positions to use for x-axis ticks on a `ggplot` object. |
||
| 399 | +69 |
- } else {
+ #' |
||
| 400 | +70 |
- paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n")+ #' @examples |
||
| 401 | +71 |
- }+ #' library(dplyr) |
||
| 402 | +72 |
-
+ #' library(survival) |
||
| 403 | +73 |
- x$width <- NULL+ #' |
||
| 404 | +74 |
- x$label <- txt+ #' data <- tern_ex_adtte %>% |
||
| 405 | +75 |
- x$text <- NULL+ #' filter(PARAMCD == "OS") %>% |
||
| 406 | +76 |
- class(x) <- c("text", class(x)[-1])
+ #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
||
| 407 | +77 |
-
+ #' h_data_plot() |
||
| 408 | +78 |
- grid::grid.draw(x)+ #' |
||
| 409 | +79 |
- }+ #' h_xticks(data) |
||
| 410 | +80 |
- # nocov end+ #' h_xticks(data, xticks = seq(0, 3000, 500)) |
||
| 411 | +81 |
-
+ #' h_xticks(data, xticks = 500) |
||
| 412 | +82 |
- # Adapted from Paul Murell R Graphics 2nd Edition+ #' h_xticks(data, xticks = 500, max_time = 6000) |
||
| 413 | +83 |
- # https://www.stat.auckland.ac.nz/~paul/RG2e/interactgrid-splittext.R+ #' h_xticks(data, xticks = c(0, 500), max_time = 300) |
||
| 414 | +84 |
- split_string <- function(text, width) {
+ #' h_xticks(data, xticks = 500, max_time = 300) |
||
| 415 | -26x | +|||
| 85 | +
- strings <- strsplit(text, " ")+ #' |
|||
| 416 | -26x | +|||
| 86 | +
- out_string <- NA+ #' @export |
|||
| 417 | -26x | +|||
| 87 | +
- for (string_i in seq_along(strings)) {
+ h_xticks <- function(data, xticks = NULL, max_time = NULL) {
|
|||
| 418 | -48x | +88 | +18x |
- newline_str <- strings[[string_i]]+ if (is.null(xticks)) {
|
| 419 | -6x | +89 | +13x |
- if (length(newline_str) == 0) newline_str <- ""+ if (is.null(max_time)) {
|
| 420 | -48x | +90 | +11x |
- if (is.na(out_string[string_i])) {
+ labeling::extended(range(data$time)[1], range(data$time)[2], m = 5) |
| 421 | -48x | +|||
| 91 | +
- out_string[string_i] <- newline_str[[1]][[1]]+ } else {
|
|||
| 422 | -48x | +92 | +2x |
- linewidth <- grid::stringWidth(out_string[string_i])+ labeling::extended(range(data$time)[1], max(range(data$time)[2], max_time), m = 5) |
| 423 | +93 |
} |
||
| 424 | -48x | +94 | +5x |
- gapwidth <- grid::stringWidth(" ")
+ } else if (checkmate::test_number(xticks)) {
|
| 425 | -48x | +95 | +2x |
- availwidth <- as.numeric(width)+ if (is.null(max_time)) {
|
| 426 | -48x | +96 | +1x |
- if (length(newline_str) > 1) {
+ seq(0, max(data$time), xticks) |
| 427 | -12x | +|||
| 97 | +
- for (i in seq(2, length(newline_str))) {
+ } else {
|
|||
| 428 | -184x | +98 | +1x |
- width_i <- grid::stringWidth(newline_str[i])+ seq(0, max(data$time, max_time), xticks) |
| 429 | +99 |
- # Main conversion of allowed text width -> npc units are 0<npc<1. External viewport is used for conversion+ } |
||
| 430 | -184x | +100 | +3x |
- if (grid::convertWidth(linewidth + gapwidth + width_i, grid::unitType(width), valueOnly = TRUE) < availwidth) {
+ } else if (is.numeric(xticks)) {
|
| 431 | -177x | +101 | +2x |
- sep <- " "+ xticks |
| 432 | -177x | +|||
| 102 | +
- linewidth <- linewidth + gapwidth + width_i+ } else {
|
|||
| 433 | -+ | |||
| 103 | +1x |
- } else {
+ stop( |
||
| 434 | -7x | +104 | +1x |
- sep <- "\n"+ paste( |
| 435 | -7x | +105 | +1x |
- linewidth <- width_i+ "xticks should be either `NULL`", |
| 436 | -+ | |||
| 106 | +1x |
- }+ "or a single number (interval between x ticks)", |
||
| 437 | -184x | +107 | +1x |
- out_string[string_i] <- paste(out_string[string_i], newline_str[i], sep = sep)+ "or a numeric vector (position of ticks on the x axis)" |
| 438 | +108 |
- }+ ) |
||
| 439 | +109 |
- }+ ) |
||
| 440 | +110 |
} |
||
| 441 | -26x | -
- paste(out_string, collapse = "\n")- |
- ||
| 442 | +111 |
} |
||
| 443 | +112 | |||
| 444 | +113 |
- #' Update page number+ #' Helper function for survival estimations |
||
| 445 | +114 |
#' |
||
| 446 | +115 |
- #' Automatically updates page number.+ #' @description `r lifecycle::badge("stable")`
|
||
| 447 | +116 |
#' |
||
| 448 | +117 |
- #' @param npages (`numeric(1)`)\cr total number of pages.+ #' Transform a survival fit to a table with groups in rows characterized by N, median and confidence interval. |
||
| 449 | +118 |
- #' @param ... arguments passed on to [decorate_grob()].+ #' |
||
| 450 | +119 |
- #'+ #' @inheritParams h_data_plot |
||
| 451 | +120 |
- #' @return Closure that increments the page number.+ #' |
||
| 452 | +121 |
- #'+ #' @return A summary table with statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`). |
||
| 453 | +122 |
- #' @keywords internal+ #' |
||
| 454 | +123 |
- decorate_grob_factory <- function(npages, ...) {
+ #' @examples |
||
| 455 | -2x | +|||
| 124 | +
- current_page <- 0+ #' library(dplyr) |
|||
| 456 | -2x | +|||
| 125 | +
- function(grob) {
+ #' library(survival) |
|||
| 457 | -7x | +|||
| 126 | +
- current_page <<- current_page + 1+ #' |
|||
| 458 | -7x | +|||
| 127 | +
- if (current_page > npages) {
+ #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "OS") |
|||
| 459 | -1x | +|||
| 128 | +
- stop(paste("current page is", current_page, "but max.", npages, "specified."))
+ #' fit <- survfit( |
|||
| 460 | +129 |
- }+ #' formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, |
||
| 461 | -6x | +|||
| 130 | +
- decorate_grob(grob = grob, page = paste("Page", current_page, "of", npages), ...)
+ #' data = adtte |
|||
| 462 | +131 |
- }+ #' ) |
||
| 463 | +132 |
- }+ #' h_tbl_median_surv(fit_km = fit) |
||
| 464 | +133 |
-
+ #' |
||
| 465 | +134 |
- #' Decorate set of `grob`s and add page numbering+ #' @export |
||
| 466 | +135 |
- #'+ h_tbl_median_surv <- function(fit_km, armval = "All") {
|
||
| 467 | -+ | |||
| 136 | +10x |
- #' @description `r lifecycle::badge("stable")`
+ y <- if (is.null(fit_km$strata)) {
|
||
| 468 | -+ | |||
| 137 | +! |
- #'+ as.data.frame(t(summary(fit_km)$table), row.names = armval) |
||
| 469 | +138 |
- #' Note that this uses the [decorate_grob_factory()] function.+ } else {
|
||
| 470 | -+ | |||
| 139 | +10x |
- #'+ tbl <- summary(fit_km)$table |
||
| 471 | -+ | |||
| 140 | +10x |
- #' @param grobs (`list` of `grob`)\cr a list of grid grobs.+ rownames_lst <- strsplit(sub("=", "equals", rownames(tbl)), "equals")
|
||
| 472 | -+ | |||
| 141 | +10x |
- #' @param ... arguments passed on to [decorate_grob()].+ rownames(tbl) <- matrix(unlist(rownames_lst), ncol = 2, byrow = TRUE)[, 2] |
||
| 473 | -+ | |||
| 142 | +10x |
- #'+ as.data.frame(tbl) |
||
| 474 | +143 |
- #' @return A decorated grob.+ } |
||
| 475 | -+ | |||
| 144 | +10x |
- #'+ conf.int <- summary(fit_km)$conf.int # nolint |
||
| 476 | -+ | |||
| 145 | +10x |
- #' @examples+ y$records <- round(y$records) |
||
| 477 | -+ | |||
| 146 | +10x |
- #' library(ggplot2)+ y$median <- signif(y$median, 4) |
||
| 478 | -+ | |||
| 147 | +10x |
- #' library(grid)+ y$`CI` <- paste0(+ |
+ ||
| 148 | +10x | +
+ "(", signif(y[[paste0(conf.int, "LCL")]], 4), ", ", signif(y[[paste0(conf.int, "UCL")]], 4), ")"
|
||
| 479 | +149 |
- #' g <- with(data = iris, {
+ )+ |
+ ||
| 150 | +10x | +
+ stats::setNames(+ |
+ ||
| 151 | +10x | +
+ y[c("records", "median", "CI")],
+ |
+ ||
| 152 | +10x | +
+ c("N", "Median", f_conf_level(conf.int))
|
||
| 480 | +153 |
- #' list(+ ) |
||
| 481 | +154 |
- #' ggplot2::ggplotGrob(+ } |
||
| 482 | +155 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Length, Sepal.Width, col = Species)) ++ |
||
| 483 | +156 |
- #' ggplot2::geom_point()+ #' Helper function for generating a pairwise Cox-PH table |
||
| 484 | +157 |
- #' ),+ #' |
||
| 485 | +158 |
- #' ggplot2::ggplotGrob(+ #' @description `r lifecycle::badge("stable")`
|
||
| 486 | +159 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Length, col = Species)) ++ #' |
||
| 487 | +160 |
- #' ggplot2::geom_point()+ #' Create a `data.frame` of pairwise stratified or unstratified Cox-PH analysis results. |
||
| 488 | +161 |
- #' ),+ #' |
||
| 489 | +162 |
- #' ggplot2::ggplotGrob(+ #' @inheritParams g_km |
||
| 490 | +163 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Width, col = Species)) ++ #' @param annot_coxph_ref_lbls (`flag`)\cr whether the reference group should be explicitly printed in labels for the |
||
| 491 | +164 |
- #' ggplot2::geom_point()+ #' `annot_coxph` table. If `FALSE` (default), only comparison groups will be printed in `annot_coxph` table labels. |
||
| 492 | +165 |
- #' ),+ #' |
||
| 493 | +166 |
- #' ggplot2::ggplotGrob(+ #' @return A `data.frame` containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`), |
||
| 494 | +167 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Length, col = Species)) ++ #' and `p-value (log-rank)`. |
||
| 495 | +168 |
- #' ggplot2::geom_point()+ #' |
||
| 496 | +169 |
- #' ),+ #' @examples |
||
| 497 | +170 |
- #' ggplot2::ggplotGrob(+ #' library(dplyr) |
||
| 498 | +171 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Width, col = Species)) ++ #' |
||
| 499 | +172 |
- #' ggplot2::geom_point()+ #' adtte <- tern_ex_adtte %>% |
||
| 500 | +173 |
- #' ),+ #' filter(PARAMCD == "OS") %>% |
||
| 501 | +174 |
- #' ggplot2::ggplotGrob(+ #' mutate(is_event = CNSR == 0) |
||
| 502 | +175 |
- #' ggplot2::ggplot(mapping = aes(Petal.Length, Petal.Width, col = Species)) ++ #' |
||
| 503 | +176 |
- #' ggplot2::geom_point()+ #' h_tbl_coxph_pairwise( |
||
| 504 | +177 |
- #' )+ #' df = adtte, |
||
| 505 | +178 |
- #' )+ #' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARM"), |
||
| 506 | +179 |
- #' })+ #' control_coxph_pw = control_coxph(conf_level = 0.9) |
||
| 507 | +180 |
- #' lg <- decorate_grob_set(grobs = g, titles = "Hello\nOne\nTwo\nThree", footnotes = "")+ #' ) |
||
| 508 | +181 |
#' |
||
| 509 | +182 |
- #' draw_grob(lg[[1]])+ #' @export |
||
| 510 | +183 |
- #' draw_grob(lg[[2]])+ h_tbl_coxph_pairwise <- function(df, |
||
| 511 | +184 |
- #' draw_grob(lg[[6]])+ variables, |
||
| 512 | +185 |
- #'+ ref_group_coxph = NULL, |
||
| 513 | +186 |
- #' @export+ control_coxph_pw = control_coxph(), |
||
| 514 | +187 |
- decorate_grob_set <- function(grobs, ...) {
+ annot_coxph_ref_lbls = FALSE) {
|
||
| 515 | -1x | +188 | +4x |
- n <- length(grobs)+ if ("strat" %in% names(variables)) {
|
| 516 | -1x | +|||
| 189 | +! |
- lgf <- decorate_grob_factory(npages = n, ...)+ warning( |
||
| 517 | -1x | +|||
| 190 | +! |
- lapply(grobs, lgf)+ "Warning: the `strat` element name of the `variables` list argument to `h_tbl_coxph_pairwise() ", |
||
| 518 | -+ | |||
| 191 | +! |
- }+ "was deprecated in tern 0.9.4.\n ", |
| 1 | -+ | |||
| 192 | +! |
- #' Tabulate biomarker effects on binary response by subgroup+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 2 | +193 |
- #'+ ) |
||
| 3 | -+ | |||
| 194 | +! |
- #' @description `r lifecycle::badge("stable")`
+ variables[["strata"]] <- variables[["strat"]] |
||
| 4 | +195 |
- #'+ } |
||
| 5 | +196 |
- #' The [tabulate_rsp_biomarkers()] function creates a layout element to tabulate the estimated biomarker effects on a+ |
||
| 6 | -+ | |||
| 197 | +4x |
- #' binary response endpoint across subgroups, returning statistics including response rate and odds ratio for each+ assert_df_with_variables(df, variables) |
||
| 7 | -+ | |||
| 198 | +4x |
- #' population subgroup. The table is created from `df`, a list of data frames returned by [extract_rsp_biomarkers()],+ checkmate::assert_choice(ref_group_coxph, levels(df[[variables$arm]]), null.ok = TRUE) |
||
| 8 | -+ | |||
| 199 | +4x |
- #' with the statistics to include specified via the `vars` parameter.+ checkmate::assert_flag(annot_coxph_ref_lbls) |
||
| 9 | +200 |
- #'+ |
||
| 10 | -+ | |||
| 201 | +4x |
- #' A forest plot can be created from the resulting table using the [g_forest()] function.+ arm <- variables$arm |
||
| 11 | -+ | |||
| 202 | +4x |
- #'+ df[[arm]] <- factor(df[[arm]]) |
||
| 12 | +203 |
- #' @inheritParams argument_convention+ |
||
| 13 | -+ | |||
| 204 | +4x |
- #' @param df (`data.frame`)\cr containing all analysis variables, as returned by+ ref_group <- if (!is.null(ref_group_coxph)) ref_group_coxph else levels(df[[variables$arm]])[1] |
||
| 14 | -+ | |||
| 205 | +4x |
- #' [extract_rsp_biomarkers()].+ comp_group <- setdiff(levels(df[[arm]]), ref_group) |
||
| 15 | +206 |
- #' @param vars (`character`)\cr the names of statistics to be reported among:+ |
||
| 16 | -+ | |||
| 207 | +4x |
- #' * `n_tot`: Total number of patients per group.+ results <- Map(function(comp) {
|
||
| 17 | -+ | |||
| 208 | +8x |
- #' * `n_rsp`: Total number of responses per group.+ res <- s_coxph_pairwise( |
||
| 18 | -+ | |||
| 209 | +8x |
- #' * `prop`: Total response proportion per group.+ df = df[df[[arm]] == comp, , drop = FALSE], |
||
| 19 | -+ | |||
| 210 | +8x |
- #' * `or`: Odds ratio.+ .ref_group = df[df[[arm]] == ref_group, , drop = FALSE], |
||
| 20 | -+ | |||
| 211 | +8x |
- #' * `ci`: Confidence interval of odds ratio.+ .in_ref_col = FALSE, |
||
| 21 | -+ | |||
| 212 | +8x |
- #' * `pval`: p-value of the effect.+ .var = variables$tte, |
||
| 22 | -+ | |||
| 213 | +8x |
- #' Note, the statistics `n_tot`, `or` and `ci` are required.+ is_event = variables$is_event, |
||
| 23 | -+ | |||
| 214 | +8x |
- #'+ strata = variables$strata, |
||
| 24 | -+ | |||
| 215 | +8x |
- #' @return An `rtables` table summarizing biomarker effects on binary response by subgroup.+ control = control_coxph_pw |
||
| 25 | +216 |
- #'+ ) |
||
| 26 | -+ | |||
| 217 | +8x |
- #' @details These functions create a layout starting from a data frame which contains+ res_df <- data.frame( |
||
| 27 | -+ | |||
| 218 | +8x |
- #' the required statistics. The tables are then typically used as input for forest plots.+ hr = format(round(res$hr, 2), nsmall = 2), |
||
| 28 | -+ | |||
| 219 | +8x |
- #'+ hr_ci = paste0( |
||
| 29 | -+ | |||
| 220 | +8x |
- #' @note In contrast to [tabulate_rsp_subgroups()] this tabulation function does+ "(", format(round(res$hr_ci[1], 2), nsmall = 2), ", ",
|
||
| 30 | -+ | |||
| 221 | +8x |
- #' not start from an input layout `lyt`. This is because internally the table is+ format(round(res$hr_ci[2], 2), nsmall = 2), ")" |
||
| 31 | +222 |
- #' created by combining multiple subtables.+ ), |
||
| 32 | -+ | |||
| 223 | +8x |
- #'+ pvalue = if (res$pvalue < 0.0001) "<0.0001" else format(round(res$pvalue, 4), 4), |
||
| 33 | -+ | |||
| 224 | +8x |
- #' @seealso [h_tab_rsp_one_biomarker()] which is used internally, [extract_rsp_biomarkers()].+ stringsAsFactors = FALSE |
||
| 34 | +225 |
- #'+ ) |
||
| 35 | -+ | |||
| 226 | +8x |
- #' @examples+ colnames(res_df) <- c("HR", vapply(res[c("hr_ci", "pvalue")], obj_label, FUN.VALUE = "character"))
|
||
| 36 | -+ | |||
| 227 | +8x |
- #' library(dplyr)+ row.names(res_df) <- comp |
||
| 37 | -+ | |||
| 228 | +8x |
- #' library(forcats)+ res_df |
||
| 38 | -+ | |||
| 229 | +4x |
- #'+ }, comp_group)+ |
+ ||
| 230 | +1x | +
+ if (annot_coxph_ref_lbls) names(results) <- paste(comp_group, "vs.", ref_group) |
||
| 39 | +231 |
- #' adrs <- tern_ex_adrs+ + |
+ ||
| 232 | +4x | +
+ do.call(rbind, results) |
||
| 40 | +233 |
- #' adrs_labels <- formatters::var_labels(adrs)+ } |
||
| 41 | +234 |
- #'+ |
||
| 42 | +235 |
- #' adrs_f <- adrs %>%+ #' Helper function to tidy survival fit data |
||
| 43 | +236 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' |
||
| 44 | +237 |
- #' mutate(rsp = AVALC == "CR")+ #' @description `r lifecycle::badge("stable")`
|
||
| 45 | +238 |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ #' |
||
| 46 | +239 |
- #'+ #' Convert the survival fit data into a data frame designed for plotting |
||
| 47 | +240 |
- #' df <- extract_rsp_biomarkers(+ #' within `g_km`. |
||
| 48 | +241 |
- #' variables = list(+ #' |
||
| 49 | +242 |
- #' rsp = "rsp",+ #' This starts from the [broom::tidy()] result, and then: |
||
| 50 | +243 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' * Post-processes the `strata` column into a factor. |
||
| 51 | +244 |
- #' covariates = "SEX",+ #' * Extends each stratum by an additional first row with time 0 and probability 1 so that |
||
| 52 | +245 |
- #' subgroups = "BMRKR2"+ #' downstream plot lines start at those coordinates. |
||
| 53 | +246 |
- #' ),+ #' * Adds a `censor` column. |
||
| 54 | +247 |
- #' data = adrs_f+ #' * Filters the rows before `max_time`. |
||
| 55 | +248 |
- #' )+ #' |
||
| 56 | +249 |
- #'+ #' @inheritParams g_km |
||
| 57 | +250 |
- #' \donttest{
+ #' @param fit_km (`survfit`)\cr result of [survival::survfit()]. |
||
| 58 | +251 |
- #' ## Table with default columns.+ #' @param armval (`string`)\cr used as strata name when treatment arm variable only has one level. Default is `"All"`. |
||
| 59 | +252 |
- #' tabulate_rsp_biomarkers(df)+ #' |
||
| 60 | +253 |
- #'+ #' @return A `tibble` with columns `time`, `n.risk`, `n.event`, `n.censor`, `estimate`, `std.error`, `conf.high`, |
||
| 61 | +254 |
- #' ## Table with a manually chosen set of columns: leave out "pval", reorder.+ #' `conf.low`, `strata`, and `censor`. |
||
| 62 | +255 |
- #' tab <- tabulate_rsp_biomarkers(+ #' |
||
| 63 | +256 |
- #' df = df,+ #' @examples |
||
| 64 | +257 |
- #' vars = c("n_rsp", "ci", "n_tot", "prop", "or")
+ #' library(dplyr) |
||
| 65 | +258 |
- #' )+ #' library(survival) |
||
| 66 | +259 |
#' |
||
| 67 | +260 |
- #' ## Finally produce the forest plot.+ #' # Test with multiple arms |
||
| 68 | +261 |
- #' g_forest(tab, xlim = c(0.7, 1.4))+ #' tern_ex_adtte %>% |
||
| 69 | +262 |
- #' }+ #' filter(PARAMCD == "OS") %>% |
||
| 70 | +263 |
- #'+ #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
||
| 71 | +264 |
- #' @export+ #' h_data_plot() |
||
| 72 | +265 |
- #' @name response_biomarkers_subgroups+ #' |
||
| 73 | +266 |
- tabulate_rsp_biomarkers <- function(df,+ #' # Test with single arm |
||
| 74 | +267 |
- vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
+ #' tern_ex_adtte %>% |
||
| 75 | +268 |
- na_str = default_na_str(),+ #' filter(PARAMCD == "OS", ARMCD == "ARM B") %>% |
||
| 76 | +269 |
- .indent_mods = 0L) {
+ #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
||
| 77 | -4x | +|||
| 270 | +
- checkmate::assert_data_frame(df)+ #' h_data_plot(armval = "ARM B") |
|||
| 78 | -4x | +|||
| 271 | +
- checkmate::assert_character(df$biomarker)+ #' |
|||
| 79 | -4x | +|||
| 272 | +
- checkmate::assert_character(df$biomarker_label)+ #' @export |
|||
| 80 | -4x | +|||
| 273 | +
- checkmate::assert_subset(vars, get_stats("tabulate_rsp_biomarkers"))
+ h_data_plot <- function(fit_km, |
|||
| 81 | +274 |
-
+ armval = "All", |
||
| 82 | +275 |
- # Create "ci" column from "lcl" and "ucl"+ max_time = NULL) {
|
||
| 83 | -4x | +276 | +18x |
- df$ci <- combine_vectors(df$lcl, df$ucl)+ y <- broom::tidy(fit_km) |
| 84 | +277 | |||
| 85 | -4x | +278 | +18x |
- df_subs <- split(df, f = df$biomarker)+ if (!is.null(fit_km$strata)) {
|
| 86 | -4x | +279 | +18x |
- tabs <- lapply(df_subs, FUN = function(df_sub) {
+ fit_km_var_level <- strsplit(sub("=", "equals", names(fit_km$strata)), "equals")
|
| 87 | -7x | +280 | +18x |
- tab_sub <- h_tab_rsp_one_biomarker(+ strata_levels <- vapply(fit_km_var_level, FUN = "[", FUN.VALUE = "a", i = 2) |
| 88 | -7x | +281 | +18x |
- df = df_sub,+ strata_var_level <- strsplit(sub("=", "equals", y$strata), "equals")
|
| 89 | -7x | +282 | +18x |
- vars = vars,+ y$strata <- factor( |
| 90 | -7x | +283 | +18x |
- na_str = na_str,+ vapply(strata_var_level, FUN = "[", FUN.VALUE = "a", i = 2), |
| 91 | -7x | +284 | +18x |
- .indent_mods = .indent_mods+ levels = strata_levels |
| 92 | +285 |
) |
||
| 93 | +286 |
- # Insert label row as first row in table.+ } else {
|
||
| 94 | -7x | +|||
| 287 | +! |
- label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1]+ y$strata <- armval |
||
| 95 | -7x | +|||
| 288 | +
- tab_sub+ } |
|||
| 96 | +289 |
- })+ |
||
| 97 | -4x | +290 | +18x |
- result <- do.call(rbind, tabs)+ y_by_strata <- split(y, y$strata) |
| 98 | -+ | |||
| 291 | +18x |
-
+ y_by_strata_extended <- lapply( |
||
| 99 | -4x | +292 | +18x |
- n_id <- grep("n_tot", vars)
+ y_by_strata, |
| 100 | -4x | +293 | +18x |
- or_id <- match("or", vars)
+ FUN = function(tbl) {
|
| 101 | -4x | +294 | +53x |
- ci_id <- match("ci", vars)
+ first_row <- tbl[1L, ] |
| 102 | -4x | +295 | +53x |
- structure(+ first_row$time <- 0 |
| 103 | -4x | +296 | +53x |
- result,+ first_row$n.risk <- sum(first_row[, c("n.risk", "n.event", "n.censor")])
|
| 104 | -4x | +297 | +53x |
- forest_header = paste0(c("Lower", "Higher"), "\nBetter"),
+ first_row$n.event <- first_row$n.censor <- 0 |
| 105 | -4x | +298 | +53x |
- col_x = or_id,+ first_row$estimate <- first_row$conf.high <- first_row$conf.low <- 1 |
| 106 | -4x | +299 | +53x |
- col_ci = ci_id,+ first_row$std.error <- 0 |
| 107 | -4x | +300 | +53x |
- col_symbol_size = n_id+ rbind( |
| 108 | -+ | |||
| 301 | +53x |
- )+ first_row, |
||
| 109 | -+ | |||
| 302 | +53x |
- }+ tbl |
||
| 110 | +303 |
-
+ ) |
||
| 111 | +304 |
- #' Prepare response data estimates for multiple biomarkers in a single data frame+ } |
||
| 112 | +305 |
- #'+ ) |
||
| 113 | -+ | |||
| 306 | +18x |
- #' @description `r lifecycle::badge("stable")`
+ y <- do.call(rbind, y_by_strata_extended) |
||
| 114 | +307 |
- #'+ |
||
| 115 | -+ | |||
| 308 | +18x |
- #' Prepares estimates for number of responses, patients and overall response rate,+ y$censor <- ifelse(y$n.censor > 0, y$estimate, NA) |
||
| 116 | -+ | |||
| 309 | +18x |
- #' as well as odds ratio estimates, confidence intervals and p-values,+ if (!is.null(max_time)) {
+ |
+ ||
| 310 | +1x | +
+ y <- y[y$time <= max(max_time), ] |
||
| 117 | +311 |
- #' for multiple biomarkers across population subgroups in a single data frame.+ }+ |
+ ||
| 312 | +18x | +
+ y |
||
| 118 | +313 |
- #' `variables` corresponds to the names of variables found in `data`, passed as a+ } |
||
| 119 | +314 |
- #' named list and requires elements `rsp` and `biomarkers` (vector of continuous+ |
||
| 120 | +315 |
- #' biomarker variables) and optionally `covariates`, `subgroups` and `strata`.+ ## Deprecated Functions ---- |
||
| 121 | +316 |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ |
||
| 122 | +317 |
- #'+ #' Helper function to create a KM plot |
||
| 123 | +318 |
- #' @inheritParams argument_convention+ #' |
||
| 124 | +319 |
- #' @inheritParams response_subgroups+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 125 | +320 |
- #' @param control (named `list`)\cr controls for the response definition and the+ #' |
||
| 126 | +321 |
- #' confidence level produced by [control_logistic()].+ #' Draw the Kaplan-Meier plot using `ggplot2`. |
||
| 127 | +322 |
#' |
||
| 128 | +323 |
- #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_rsp`,+ #' @inheritParams g_km |
||
| 129 | +324 |
- #' `prop`, `or`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`,+ #' @param data (`data.frame`)\cr survival data as pre-processed by `h_data_plot`. |
||
| 130 | +325 |
- #' `var_label`, and `row_type`.+ #' |
||
| 131 | +326 |
- #'+ #' @return A `ggplot` object. |
||
| 132 | +327 |
- #' @note You can also specify a continuous variable in `rsp` and then use the+ #' |
||
| 133 | +328 |
- #' `response_definition` control to convert that internally to a logical+ #' @examples |
||
| 134 | +329 |
- #' variable reflecting binary response.+ #' \donttest{
|
||
| 135 | +330 |
- #'+ #' library(dplyr) |
||
| 136 | +331 |
- #' @seealso [h_logistic_mult_cont_df()] which is used internally.+ #' library(survival) |
||
| 137 | +332 |
#' |
||
| 138 | +333 |
- #' @examples+ #' fit_km <- tern_ex_adtte %>% |
||
| 139 | +334 |
- #' library(dplyr)+ #' filter(PARAMCD == "OS") %>% |
||
| 140 | +335 |
- #' library(forcats)+ #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
||
| 141 | +336 |
- #'+ #' data_plot <- h_data_plot(fit_km = fit_km) |
||
| 142 | +337 |
- #' adrs <- tern_ex_adrs+ #' xticks <- h_xticks(data = data_plot) |
||
| 143 | +338 |
- #' adrs_labels <- formatters::var_labels(adrs)+ #' gg <- h_ggkm( |
||
| 144 | +339 |
- #'+ #' data = data_plot, |
||
| 145 | +340 |
- #' adrs_f <- adrs %>%+ #' censor_show = TRUE, |
||
| 146 | +341 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' xticks = xticks, |
||
| 147 | +342 |
- #' mutate(rsp = AVALC == "CR")+ #' xlab = "Days", |
||
| 148 | +343 |
- #'+ #' yval = "Survival", |
||
| 149 | +344 |
- #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`,+ #' ylab = "Survival Probability", |
||
| 150 | +345 |
- #' # in logistic regression models with one covariate `RACE`. The subgroups+ #' title = "Survival" |
||
| 151 | +346 |
- #' # are defined by the levels of `BMRKR2`.+ #' ) |
||
| 152 | +347 |
- #' df <- extract_rsp_biomarkers(+ #' gg |
||
| 153 | +348 |
- #' variables = list(+ #' } |
||
| 154 | +349 |
- #' rsp = "rsp",+ #' |
||
| 155 | +350 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' @export |
||
| 156 | +351 |
- #' covariates = "SEX",+ h_ggkm <- function(data, |
||
| 157 | +352 |
- #' subgroups = "BMRKR2"+ xticks = NULL, |
||
| 158 | +353 |
- #' ),+ yval = "Survival", |
||
| 159 | +354 |
- #' data = adrs_f+ censor_show, |
||
| 160 | +355 |
- #' )+ xlab, |
||
| 161 | +356 |
- #' df+ ylab, |
||
| 162 | +357 |
- #'+ ylim = NULL, |
||
| 163 | +358 |
- #' # Here we group the levels of `BMRKR2` manually, and we add a stratification+ title, |
||
| 164 | +359 |
- #' # variable `STRATA1`. We also here use a continuous variable `EOSDY`+ footnotes = NULL, |
||
| 165 | +360 |
- #' # which is then binarized internally (response is defined as this variable+ max_time = NULL, |
||
| 166 | +361 |
- #' # being larger than 750).+ lwd = 1, |
||
| 167 | +362 |
- #' df_grouped <- extract_rsp_biomarkers(+ lty = NULL, |
||
| 168 | +363 |
- #' variables = list(+ pch = 3, |
||
| 169 | +364 |
- #' rsp = "EOSDY",+ size = 2, |
||
| 170 | +365 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ col = NULL, |
||
| 171 | +366 |
- #' covariates = "SEX",+ ci_ribbon = FALSE, |
||
| 172 | +367 |
- #' subgroups = "BMRKR2",+ ggtheme = nestcolor::theme_nest()) {
|
||
| 173 | -+ | |||
| 368 | +1x |
- #' strata = "STRATA1"+ lifecycle::deprecate_warn( |
||
| 174 | -+ | |||
| 369 | +1x |
- #' ),+ "0.9.4", |
||
| 175 | -+ | |||
| 370 | +1x |
- #' data = adrs_f,+ "h_ggkm()", |
||
| 176 | -+ | |||
| 371 | +1x |
- #' groups_lists = list(+ details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
||
| 177 | +372 |
- #' BMRKR2 = list(+ ) |
||
| 178 | -+ | |||
| 373 | +1x |
- #' "low" = "LOW",+ checkmate::assert_numeric(lty, null.ok = TRUE) |
||
| 179 | -+ | |||
| 374 | +1x |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ checkmate::assert_character(col, null.ok = TRUE) |
||
| 180 | +375 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+
|
||
| 181 | -+ | |||
| 376 | +1x |
- #' )+ if (is.null(ylim)) {
|
||
| 182 | -+ | |||
| 377 | +1x |
- #' ),+ data_lims <- data |
||
| 183 | -+ | |||
| 378 | +! |
- #' control = control_logistic(+ if (yval == "Failure") data_lims[["estimate"]] <- 1 - data_lims[["estimate"]] |
||
| 184 | -+ | |||
| 379 | +1x |
- #' response_definition = "I(response > 750)"+ if (!is.null(max_time)) {
|
||
| 185 | -+ | |||
| 380 | +! |
- #' )+ y_lwr <- min(data_lims[data_lims$time < max_time, ][["estimate"]]) |
||
| 186 | -+ | |||
| 381 | +! |
- #' )+ y_upr <- max(data_lims[data_lims$time < max_time, ][["estimate"]]) |
||
| 187 | +382 |
- #' df_grouped+ } else {
|
||
| 188 | -+ | |||
| 383 | +1x |
- #'+ y_lwr <- min(data_lims[["estimate"]]) |
||
| 189 | -+ | |||
| 384 | +1x |
- #' @export+ y_upr <- max(data_lims[["estimate"]]) |
||
| 190 | +385 |
- extract_rsp_biomarkers <- function(variables,+ } |
||
| 191 | -+ | |||
| 386 | +1x |
- data,+ ylim <- c(y_lwr, y_upr) |
||
| 192 | +387 |
- groups_lists = list(),+ }+ |
+ ||
| 388 | +1x | +
+ checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE) |
||
| 193 | +389 |
- control = control_logistic(),+ |
||
| 194 | +390 |
- label_all = "All Patients") {
+ # change estimates of survival to estimates of failure (1 - survival) |
||
| 195 | -5x | +391 | +1x |
- if ("strat" %in% names(variables)) {
+ if (yval == "Failure") {
|
| 196 | +392 | ! |
- warning(+ data$estimate <- 1 - data$estimate |
|
| 197 | +393 | ! |
- "Warning: the `strat` element name of the `variables` list argument to `extract_rsp_biomarkers() ",+ data[c("conf.high", "conf.low")] <- list(1 - data$conf.low, 1 - data$conf.high)
|
|
| 198 | +394 | ! |
- "was deprecated in tern 0.9.4.\n ",+ data$censor <- 1 - data$censor |
|
| 199 | -! | +|||
| 395 | +
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ } |
|||
| 200 | +396 |
- )+ |
||
| 201 | -! | +|||
| 397 | +1x |
- variables[["strata"]] <- variables[["strat"]]+ gg <- {
|
||
| 202 | -+ | |||
| 398 | +1x |
- }+ ggplot2::ggplot( |
||
| 203 | -+ | |||
| 399 | +1x |
-
+ data = data, |
||
| 204 | -5x | +400 | +1x |
- assert_list_of_variables(variables)+ mapping = ggplot2::aes( |
| 205 | -5x | +401 | +1x |
- checkmate::assert_string(variables$rsp)+ x = .data[["time"]], |
| 206 | -5x | +402 | +1x |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ y = .data[["estimate"]], |
| 207 | -5x | +403 | +1x |
- checkmate::assert_string(label_all)+ ymin = .data[["conf.low"]],+ |
+
| 404 | +1x | +
+ ymax = .data[["conf.high"]],+ |
+ ||
| 405 | +1x | +
+ color = .data[["strata"]],+ |
+ ||
| 406 | +1x | +
+ fill = .data[["strata"]] |
||
| 208 | +407 |
-
+ ) |
||
| 209 | +408 |
- # Start with all patients.+ ) + |
||
| 210 | -5x | +409 | +1x |
- result_all <- h_logistic_mult_cont_df(+ ggplot2::geom_hline(yintercept = 0) |
| 211 | -5x | +|||
| 410 | +
- variables = variables,+ } |
|||
| 212 | -5x | +|||
| 411 | +
- data = data,+ |
|||
| 213 | -5x | +412 | +1x |
- control = control+ if (ci_ribbon) {
+ |
+
| 413 | +! | +
+ gg <- gg + ggplot2::geom_ribbon(alpha = .3, lty = 0) |
||
| 214 | +414 |
- )+ } |
||
| 215 | -5x | +|||
| 415 | +
- result_all$subgroup <- label_all+ |
|||
| 216 | -5x | +416 | +1x |
- result_all$var <- "ALL"+ gg <- if (is.null(lty)) {
|
| 217 | -5x | +417 | +1x |
- result_all$var_label <- label_all+ gg + |
| 218 | -5x | +418 | +1x |
- result_all$row_type <- "content"+ ggplot2::geom_step(linewidth = lwd) |
| 219 | -5x | +419 | +1x |
- if (is.null(variables$subgroups)) {
+ } else if (checkmate::test_number(lty)) {
|
| 220 | -+ | |||
| 420 | +! |
- # Only return result for all patients.+ gg ++ |
+ ||
| 421 | +! | +
+ ggplot2::geom_step(linewidth = lwd, lty = lty) |
||
| 221 | +422 | 1x |
- result_all+ } else if (is.numeric(lty)) {
|
|
| 222 | -+ | |||
| 423 | +! |
- } else {
+ gg ++ |
+ ||
| 424 | +! | +
+ ggplot2::geom_step(mapping = ggplot2::aes(linetype = .data[["strata"]]), linewidth = lwd) ++ |
+ ||
| 425 | +! | +
+ ggplot2::scale_linetype_manual(values = lty) |
||
| 223 | +426 |
- # Add subgroups results.+ } |
||
| 224 | -4x | +|||
| 427 | +
- l_data <- h_split_by_subgroups(+ |
|||
| 225 | -4x | +428 | +1x |
- data,+ gg <- gg + |
| 226 | -4x | +429 | +1x |
- variables$subgroups,+ ggplot2::coord_cartesian(ylim = ylim) + |
| 227 | -4x | +430 | +1x |
- groups_lists = groups_lists+ ggplot2::labs(x = xlab, y = ylab, title = title, caption = footnotes) |
| 228 | +431 |
- )+ |
||
| 229 | -4x | +432 | +1x |
- l_result <- lapply(l_data, function(grp) {
+ if (!is.null(col)) {
|
| 230 | -20x | +|||
| 433 | +! |
- result <- h_logistic_mult_cont_df(+ gg <- gg + |
||
| 231 | -20x | +|||
| 434 | +! |
- variables = variables,+ ggplot2::scale_color_manual(values = col) + |
||
| 232 | -20x | +|||
| 435 | +! |
- data = grp$df,+ ggplot2::scale_fill_manual(values = col) |
||
| 233 | -20x | +|||
| 436 | +
- control = control+ } |
|||
| 234 | -+ | |||
| 437 | +1x |
- )+ if (censor_show) {
|
||
| 235 | -20x | +438 | +1x |
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ dt <- data[data$n.censor != 0, ] |
| 236 | -20x | +439 | +1x |
- cbind(result, result_labels)+ dt$censor_lbl <- factor("Censored")
|
| 237 | +440 |
- })+ |
||
| 238 | -4x | +441 | +1x |
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ gg <- gg + ggplot2::geom_point( |
| 239 | -4x | +442 | +1x |
- result_subgroups$row_type <- "analysis"+ data = dt, |
| 240 | -4x | +443 | +1x |
- rbind(+ ggplot2::aes( |
| 241 | -4x | +444 | +1x |
- result_all,+ x = .data[["time"]], |
| 242 | -4x | +445 | +1x |
- result_subgroups+ y = .data[["censor"]], |
| 243 | -+ | |||
| 446 | +1x |
- )+ shape = .data[["censor_lbl"]] |
||
| 244 | +447 |
- }+ ), |
||
| 245 | -+ | |||
| 448 | +1x |
- }+ size = size, |
| 1 | -+ | |||
| 449 | +1x |
- # summarize_glm_count ----------------------------------------------------------+ show.legend = TRUE, |
||
| 2 | -+ | |||
| 450 | +1x |
- #' Summarize Poisson negative binomial regression+ inherit.aes = TRUE |
||
| 3 | +451 |
- #'+ ) + |
||
| 4 | -+ | |||
| 452 | +1x |
- #' @description `r lifecycle::badge("experimental")`
+ ggplot2::scale_shape_manual(name = NULL, values = pch) + |
||
| 5 | -+ | |||
| 453 | +1x |
- #'+ ggplot2::guides( |
||
| 6 | -+ | |||
| 454 | +1x |
- #' Summarize results of a Poisson negative binomial regression.+ shape = ggplot2::guide_legend(override.aes = list(linetype = NA)), |
||
| 7 | -+ | |||
| 455 | +1x |
- #' This can be used to analyze count and/or frequency data using a linear model.+ fill = ggplot2::guide_legend(override.aes = list(shape = NA)) |
||
| 8 | +456 |
- #' It is specifically useful for analyzing count data (using the Poisson or Negative+ ) |
||
| 9 | +457 |
- #' Binomial distribution) that is result of a generalized linear model of one (e.g. arm) or more+ } |
||
| 10 | +458 |
- #' covariates.+ |
||
| 11 | -+ | |||
| 459 | +1x |
- #'+ if (!is.null(max_time) && !is.null(xticks)) {
|
||
| 12 | -+ | |||
| 460 | +! |
- #' @inheritParams h_glm_count+ gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, xticks), max(c(xticks, max_time)))) |
||
| 13 | -+ | |||
| 461 | +1x |
- #' @inheritParams argument_convention+ } else if (!is.null(xticks)) {
|
||
| 14 | -+ | |||
| 462 | +1x |
- #' @param rate_mean_method (`character(1)`)\cr method used to estimate the mean odds ratio. Defaults to `emmeans`.+ if (max(data$time) <= max(xticks)) {
|
||
| 15 | -+ | |||
| 463 | +1x |
- #' see details for more information.+ gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, min(xticks)), max(xticks))) |
||
| 16 | +464 |
- #' @param scale (`numeric(1)`)\cr linear scaling factor for rate and confidence intervals. Defaults to `1`.+ } else {
|
||
| 17 | -+ | |||
| 465 | +! |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("summarize_glm_count")`
+ gg <- gg + ggplot2::scale_x_continuous(breaks = xticks) |
||
| 18 | +466 |
- #' to see available statistics for this function.+ } |
||
| 19 | -+ | |||
| 467 | +! |
- #'+ } else if (!is.null(max_time)) {
|
||
| 20 | -+ | |||
| 468 | +! |
- #' @details+ gg <- gg + ggplot2::scale_x_continuous(limits = c(0, max_time)) |
||
| 21 | +469 |
- #' `summarize_glm_count()` uses `s_glm_count()` to calculate the statistics for the table. This+ } |
||
| 22 | +470 |
- #' analysis function uses [h_glm_count()] to estimate the GLM with [stats::glm()] for Poisson and Quasi-Poisson+ |
||
| 23 | -+ | |||
| 471 | +1x |
- #' distributions or [MASS::glm.nb()] for Negative Binomial distribution. All methods assume a+ if (!is.null(ggtheme)) {
|
||
| 24 | -+ | |||
| 472 | +1x |
- #' logarithmic link function.+ gg <- gg + ggtheme |
||
| 25 | +473 |
- #'+ } |
||
| 26 | +474 |
- #' At this point, rates and confidence intervals are estimated from the model using+ |
||
| 27 | -+ | |||
| 475 | +1x |
- #' either [emmeans::emmeans()] when `rate_mean_method = "emmeans"` or [h_ppmeans()]+ gg + ggplot2::theme( |
||
| 28 | -+ | |||
| 476 | +1x |
- #' when `rate_mean_method = "ppmeans"`.+ legend.position = "bottom", |
||
| 29 | -+ | |||
| 477 | +1x |
- #'+ legend.title = ggplot2::element_blank(), |
||
| 30 | -+ | |||
| 478 | +1x |
- #' If a reference group is specified while building the table with `split_cols_by(ref_group)`,+ legend.key.height = unit(0.02, "npc"), |
||
| 31 | -+ | |||
| 479 | +1x |
- #' no rate ratio or `p-value` are calculated. Otherwise, we use [emmeans::contrast()] to+ panel.grid.major.x = ggplot2::element_line(linewidth = 2) |
||
| 32 | +480 |
- #' calculate the rate ratio and `p-value` for the reference group. Values are always estimated+ ) |
||
| 33 | +481 |
- #' with `method = "trt.vs.ctrl"` and `ref` equal to the first `arm` value.+ } |
||
| 34 | +482 |
- #'+ |
||
| 35 | +483 |
- #' @name summarize_glm_count+ #' `ggplot` decomposition |
||
| 36 | +484 |
- NULL+ #' |
||
| 37 | +485 |
-
+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 38 | +486 |
- #' @describeIn summarize_glm_count Layout-creating function which can take statistics function arguments+ #' |
||
| 39 | +487 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' The elements composing the `ggplot` are extracted and organized in a `list`. |
||
| 40 | +488 |
#' |
||
| 41 | +489 |
- #' @return+ #' @param gg (`ggplot`)\cr a graphic to decompose. |
||
| 42 | +490 |
- #' * `summarize_glm_count()` returns a layout object suitable for passing to further layouting functions,+ #' |
||
| 43 | +491 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' @return A named `list` with elements: |
||
| 44 | +492 |
- #' the statistics from `s_glm_count()` to the table layout.+ #' * `panel`: The panel. |
||
| 45 | +493 |
- #'+ #' * `yaxis`: The y-axis. |
||
| 46 | +494 |
- #' @examples+ #' * `xaxis`: The x-axis. |
||
| 47 | +495 |
- #' library(dplyr)+ #' * `xlab`: The x-axis label. |
||
| 48 | +496 |
- #'+ #' * `ylab`: The y-axis label. |
||
| 49 | +497 |
- #' anl <- tern_ex_adtte %>% filter(PARAMCD == "TNE")+ #' * `guide`: The legend. |
||
| 50 | +498 |
- #' anl$AVAL_f <- as.factor(anl$AVAL)+ #' |
||
| 51 | +499 |
- #'+ #' @examples |
||
| 52 | +500 |
- #' lyt <- basic_table() %>%+ #' \donttest{
|
||
| 53 | +501 |
- #' split_cols_by("ARM", ref_group = "B: Placebo") %>%
+ #' library(dplyr) |
||
| 54 | +502 |
- #' add_colcounts() %>%+ #' library(survival) |
||
| 55 | +503 |
- #' analyze_vars(+ #' library(grid) |
||
| 56 | +504 |
- #' "AVAL_f",+ #' |
||
| 57 | +505 |
- #' var_labels = "Number of exacerbations per patient",+ #' fit_km <- tern_ex_adtte %>% |
||
| 58 | +506 |
- #' .stats = c("count_fraction"),
+ #' filter(PARAMCD == "OS") %>% |
||
| 59 | +507 |
- #' .formats = c("count_fraction" = "xx (xx.xx%)"),
+ #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
||
| 60 | +508 |
- #' .labels = c("Number of exacerbations per patient")
+ #' data_plot <- h_data_plot(fit_km = fit_km) |
||
| 61 | +509 |
- #' ) %>%+ #' xticks <- h_xticks(data = data_plot) |
||
| 62 | +510 |
- #' summarize_glm_count(+ #' gg <- h_ggkm( |
||
| 63 | +511 |
- #' vars = "AVAL",+ #' data = data_plot, |
||
| 64 | +512 |
- #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = NULL),+ #' yval = "Survival", |
||
| 65 | +513 |
- #' conf_level = 0.95,+ #' censor_show = TRUE, |
||
| 66 | +514 |
- #' distribution = "poisson",+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
||
| 67 | +515 |
- #' rate_mean_method = "emmeans",+ #' title = "tt", |
||
| 68 | +516 |
- #' var_labels = "Adjusted (P) exacerbation rate (per year)",+ #' footnotes = "ff" |
||
| 69 | +517 |
- #' table_names = "adjP",+ #' ) |
||
| 70 | +518 |
- #' .stats = c("rate"),
+ #' |
||
| 71 | +519 |
- #' .labels = c(rate = "Rate")+ #' g_el <- h_decompose_gg(gg) |
||
| 72 | +520 |
- #' ) %>%+ #' grid::grid.newpage() |
||
| 73 | +521 |
- #' summarize_glm_count(+ #' grid.rect(gp = grid::gpar(lty = 1, col = "red", fill = "gray85", lwd = 5)) |
||
| 74 | +522 |
- #' vars = "AVAL",+ #' grid::grid.draw(g_el$panel) |
||
| 75 | +523 |
- #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = c("REGION1")),
+ #' |
||
| 76 | +524 |
- #' conf_level = 0.95,+ #' grid::grid.newpage() |
||
| 77 | +525 |
- #' distribution = "quasipoisson",+ #' grid.rect(gp = grid::gpar(lty = 1, col = "royalblue", fill = "gray85", lwd = 5)) |
||
| 78 | +526 |
- #' rate_mean_method = "ppmeans",+ #' grid::grid.draw(with(g_el, cbind(ylab, yaxis))) |
||
| 79 | +527 |
- #' var_labels = "Adjusted (QP) exacerbation rate (per year)",+ #' } |
||
| 80 | +528 |
- #' table_names = "adjQP",+ #' |
||
| 81 | +529 |
- #' .stats = c("rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
+ #' @export |
||
| 82 | +530 |
- #' .labels = c(+ h_decompose_gg <- function(gg) {
|
||
| 83 | -+ | |||
| 531 | +1x |
- #' rate = "Rate", rate_ci = "Rate CI", rate_ratio = "Rate Ratio",+ lifecycle::deprecate_warn( |
||
| 84 | -+ | |||
| 532 | +1x |
- #' rate_ratio_ci = "Rate Ratio CI", pval = "p value"+ "0.9.4", |
||
| 85 | -+ | |||
| 533 | +1x |
- #' )+ "h_decompose_gg()", |
||
| 86 | -+ | |||
| 534 | +1x |
- #' )+ details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
||
| 87 | +535 |
- #'+ ) |
||
| 88 | -+ | |||
| 536 | +1x |
- #' build_table(lyt = lyt, df = anl)+ g_el <- ggplot2::ggplotGrob(gg) |
||
| 89 | -+ | |||
| 537 | +1x |
- #'+ y <- c( |
||
| 90 | -+ | |||
| 538 | +1x |
- #' @export+ panel = "panel", |
||
| 91 | -+ | |||
| 539 | +1x |
- summarize_glm_count <- function(lyt,+ yaxis = "axis-l", |
||
| 92 | -+ | |||
| 540 | +1x |
- vars,+ xaxis = "axis-b", |
||
| 93 | -+ | |||
| 541 | +1x |
- variables,+ xlab = "xlab-b", |
||
| 94 | -+ | |||
| 542 | +1x |
- distribution,+ ylab = "ylab-l", |
||
| 95 | -+ | |||
| 543 | +1x |
- conf_level,+ guide = "guide" |
||
| 96 | +544 |
- rate_mean_method = c("emmeans", "ppmeans")[1],
+ ) |
||
| 97 | -+ | |||
| 545 | +1x |
- weights = stats::weights,+ lapply(X = y, function(x) gtable::gtable_filter(g_el, x)) |
||
| 98 | +546 |
- scale = 1,+ } |
||
| 99 | +547 |
- var_labels,+ |
||
| 100 | +548 |
- na_str = default_na_str(),+ #' Helper function to prepare a KM layout |
||
| 101 | +549 |
- nested = TRUE,+ #' |
||
| 102 | +550 |
- ...,+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 103 | +551 |
- show_labels = "visible",+ #' |
||
| 104 | +552 |
- table_names = vars,+ #' Prepares a (5 rows) x (2 cols) layout for the Kaplan-Meier curve. |
||
| 105 | +553 |
- .stats = get_stats("summarize_glm_count"),
+ #' |
||
| 106 | +554 |
- .formats = NULL,+ #' @inheritParams g_km |
||
| 107 | +555 |
- .labels = NULL,+ #' @inheritParams h_ggkm |
||
| 108 | +556 |
- .indent_mods = c(+ #' @param g_el (`list` of `gtable`)\cr list as obtained by `h_decompose_gg()`. |
||
| 109 | +557 |
- "n" = 0L,+ #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of |
||
| 110 | +558 |
- "rate" = 0L,+ #' patient at risk matching the main grid of the Kaplan-Meier curve. |
||
| 111 | +559 |
- "rate_ci" = 1L,+ #' |
||
| 112 | +560 |
- "rate_ratio" = 0L,+ #' @return A grid layout. |
||
| 113 | +561 |
- "rate_ratio_ci" = 1L,+ #' |
||
| 114 | +562 |
- "pval" = 1L+ #' @details The layout corresponds to a grid of two columns and five rows of unequal dimensions. Most of the |
||
| 115 | +563 |
- )) {
- |
- ||
| 116 | -3x | -
- checkmate::assert_choice(rate_mean_method, c("emmeans", "ppmeans"))
+ #' dimension are fixed, only the curve is flexible and will accommodate with the remaining free space. |
||
| 117 | +564 | - - | -||
| 118 | -3x | -
- extra_args <- list(- |
- ||
| 119 | -3x | -
- variables = variables, distribution = distribution, conf_level = conf_level,- |
- ||
| 120 | -3x | -
- rate_mean_method = rate_mean_method, weights = weights, scale = scale, ...+ #' * The left column gets the annotation of the `ggplot` (y-axis) and the names of the strata for the patient |
||
| 121 | +565 |
- )+ #' at risk tabulation. The main constraint is about the width of the columns which must allow the writing of |
||
| 122 | +566 |
-
+ #' the strata name. |
||
| 123 | +567 |
- # Selecting parameters following the statistics- |
- ||
| 124 | -3x | -
- .formats <- get_formats_from_stats(.stats, formats_in = .formats)- |
- ||
| 125 | -3x | -
- .labels <- get_labels_from_stats(.stats, labels_in = .labels)- |
- ||
| 126 | -3x | -
- .indent_mods <- get_indents_from_stats(.stats, indents_in = .indent_mods)+ #' * The right column receive the `ggplot`, the legend, the x-axis and the patient at risk table. |
||
| 127 | +568 | - - | -||
| 128 | -3x | -
- afun <- make_afun(- |
- ||
| 129 | -3x | -
- s_glm_count,- |
- ||
| 130 | -3x | -
- .stats = .stats,- |
- ||
| 131 | -3x | -
- .formats = .formats,- |
- ||
| 132 | -3x | -
- .labels = .labels,- |
- ||
| 133 | -3x | -
- .indent_mods = .indent_mods,- |
- ||
| 134 | -3x | -
- .null_ref_cells = FALSE+ #' |
||
| 135 | +569 |
- )+ #' @examples |
||
| 136 | +570 | - - | -||
| 137 | -3x | -
- analyze(- |
- ||
| 138 | -3x | -
- lyt,- |
- ||
| 139 | -3x | -
- vars,- |
- ||
| 140 | -3x | -
- var_labels = var_labels,- |
- ||
| 141 | -3x | -
- show_labels = show_labels,- |
- ||
| 142 | -3x | -
- table_names = table_names,+ #' \donttest{
|
||
| 143 | -3x | +|||
| 571 | +
- afun = afun,+ #' library(dplyr) |
|||
| 144 | -3x | +|||
| 572 | +
- na_str = na_str,+ #' library(survival) |
|||
| 145 | -3x | +|||
| 573 | +
- nested = nested,+ #' library(grid) |
|||
| 146 | -3x | +|||
| 574 | +
- extra_args = extra_args+ #' |
|||
| 147 | +575 |
- )+ #' fit_km <- tern_ex_adtte %>% |
||
| 148 | +576 |
- }+ #' filter(PARAMCD == "OS") %>% |
||
| 149 | +577 |
-
+ #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
||
| 150 | +578 |
- #' @describeIn summarize_glm_count Statistics function that produces a named list of results+ #' data_plot <- h_data_plot(fit_km = fit_km) |
||
| 151 | +579 |
- #' of the investigated Poisson model.+ #' xticks <- h_xticks(data = data_plot) |
||
| 152 | +580 |
- #'+ #' gg <- h_ggkm( |
||
| 153 | +581 |
- #' @return+ #' data = data_plot, |
||
| 154 | +582 |
- #' * `s_glm_count()` returns a named `list` of 5 statistics:+ #' censor_show = TRUE, |
||
| 155 | +583 |
- #' * `n`: Count of complete sample size for the group.+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
||
| 156 | +584 |
- #' * `rate`: Estimated event rate per follow-up time.+ #' title = "tt", footnotes = "ff", yval = "Survival" |
||
| 157 | +585 |
- #' * `rate_ci`: Confidence level for estimated rate per follow-up time.+ #' ) |
||
| 158 | +586 |
- #' * `rate_ratio`: Ratio of event rates in each treatment arm to the reference arm.+ #' g_el <- h_decompose_gg(gg) |
||
| 159 | +587 |
- #' * `rate_ratio_ci`: Confidence level for the rate ratio.+ #' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f") |
||
| 160 | +588 |
- #' * `pval`: p-value.+ #' grid.show.layout(lyt) |
||
| 161 | +589 |
- #'+ #' } |
||
| 162 | +590 |
- #' @keywords internal+ #' |
||
| 163 | +591 |
- s_glm_count <- function(df,+ #' @export |
||
| 164 | +592 |
- .var,+ h_km_layout <- function(data, g_el, title, footnotes, annot_at_risk = TRUE, annot_at_risk_title = TRUE) {
|
||
| 165 | -+ | |||
| 593 | +1x |
- .df_row,+ lifecycle::deprecate_warn( |
||
| 166 | -+ | |||
| 594 | +1x |
- variables,+ "0.9.4", |
||
| 167 | -+ | |||
| 595 | +1x |
- .ref_group,+ "h_km_layout()", |
||
| 168 | -+ | |||
| 596 | +1x |
- .in_ref_col,+ details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
||
| 169 | +597 |
- distribution,+ ) |
||
| 170 | -+ | |||
| 598 | +1x |
- conf_level,+ txtlines <- levels(as.factor(data$strata)) |
||
| 171 | -+ | |||
| 599 | +1x |
- rate_mean_method,+ nlines <- nlevels(as.factor(data$strata)) |
||
| 172 | -+ | |||
| 600 | +1x |
- weights,+ col_annot_width <- max( |
||
| 173 | -+ | |||
| 601 | +1x |
- scale = 1) {
+ c( |
||
| 174 | -14x | +602 | +1x |
- arm <- variables$arm+ as.numeric(grid::convertX(g_el$yaxis$widths + g_el$ylab$widths, "pt")), |
| 175 | -+ | |||
| 603 | +1x |
-
+ as.numeric( |
||
| 176 | -14x | +604 | +1x |
- y <- df[[.var]]+ grid::convertX( |
| 177 | -13x | +605 | +1x |
- smry_level <- as.character(unique(df[[arm]]))+ grid::stringWidth(txtlines) + grid::unit(7, "pt"), "pt" |
| 178 | +606 |
-
+ ) |
||
| 179 | +607 |
- # ensure there is only 1 value+ ) |
||
| 180 | -13x | +|||
| 608 | +
- checkmate::assert_scalar(smry_level)+ ) |
|||
| 181 | +609 |
-
+ ) |
||
| 182 | -13x | +|||
| 610 | +
- results <- h_glm_count(+ |
|||
| 183 | -13x | +611 | +1x |
- .var = .var,+ ttl_row <- as.numeric(!is.null(title)) |
| 184 | -13x | +612 | +1x |
- .df_row = .df_row,+ foot_row <- as.numeric(!is.null(footnotes)) |
| 185 | -13x | +613 | +1x |
- variables = variables,+ no_tbl_ind <- c() |
| 186 | -13x | +614 | +1x |
- distribution = distribution,+ ht_x <- c() |
| 187 | -13x | -
- weights- |
- ||
| 188 | -+ | 615 | +1x |
- )+ ht_units <- c() |
| 189 | +616 | |||
| 190 | -13x | +617 | +1x |
- if (rate_mean_method == "emmeans") {
+ if (ttl_row == 1) {
|
| 191 | -13x | +618 | +1x |
- emmeans_smry <- summary(results$emmeans_fit, level = conf_level)+ no_tbl_ind <- c(no_tbl_ind, TRUE) |
| 192 | -! | +|||
| 619 | +1x |
- } else if (rate_mean_method == "ppmeans") {
+ ht_x <- c(ht_x, 2) |
||
| 193 | -! | +|||
| 620 | +1x |
- emmeans_smry <- h_ppmeans(results$glm_fit, .df_row, arm, conf_level)+ ht_units <- c(ht_units, "lines") |
||
| 194 | +621 |
} |
||
| 195 | +622 | |||
| 196 | -13x | +623 | +1x |
- emmeans_smry_level <- emmeans_smry[emmeans_smry[[arm]] == smry_level, ]+ no_tbl_ind <- c(no_tbl_ind, rep(TRUE, 3), rep(FALSE, 2)) |
| 197 | -+ | |||
| 624 | +1x |
-
+ ht_x <- c( |
||
| 198 | -+ | |||
| 625 | +1x |
- # This happens if there is a reference col. No Ratio is calculated?+ ht_x, |
||
| 199 | -13x | +626 | +1x |
- if (.in_ref_col) {
+ 1, |
| 200 | -5x | +627 | +1x |
- list(+ grid::convertX(with(g_el, xaxis$heights + ylab$widths), "pt") + grid::unit(5, "pt"), |
| 201 | -5x | +628 | +1x |
- n = length(y[!is.na(y)]),+ grid::convertX(g_el$guide$heights, "pt") + grid::unit(2, "pt"), |
| 202 | -5x | +629 | +1x |
- rate = formatters::with_label(+ 1, |
| 203 | -5x | +630 | +1x |
- ifelse(distribution == "negbin", emmeans_smry_level$response * scale, emmeans_smry_level$rate * scale),+ nlines + 0.5, |
| 204 | -5x | +631 | +1x |
- "Adjusted Rate"+ grid::convertX(with(g_el, xaxis$heights + ylab$widths), "pt") |
| 205 | +632 |
- ),+ ) |
||
| 206 | -5x | +633 | +1x |
- rate_ci = formatters::with_label(+ ht_units <- c( |
| 207 | -5x | +634 | +1x |
- c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale),+ ht_units, |
| 208 | -5x | +635 | +1x |
- f_conf_level(conf_level)+ "null", |
| 209 | -+ | |||
| 636 | +1x |
- ),+ "pt", |
||
| 210 | -5x | +637 | +1x |
- rate_ratio = formatters::with_label(character(), "Adjusted Rate Ratio"),+ "pt", |
| 211 | -5x | +638 | +1x |
- rate_ratio_ci = formatters::with_label(character(), f_conf_level(conf_level)),+ "lines", |
| 212 | -5x | +639 | +1x |
- pval = formatters::with_label(character(), "p-value")+ "lines", |
| 213 | -+ | |||
| 640 | +1x |
- )+ "pt" |
||
| 214 | +641 |
- } else {
- |
- ||
| 215 | -8x | -
- emmeans_contrasts <- emmeans::contrast(+ ) |
||
| 216 | -8x | +|||
| 642 | +
- results$emmeans_fit,+ |
|||
| 217 | -8x | +643 | +1x |
- method = "trt.vs.ctrl",+ if (foot_row == 1) {
|
| 218 | -8x | +644 | +1x |
- ref = grep(+ no_tbl_ind <- c(no_tbl_ind, TRUE) |
| 219 | -8x | +645 | +1x |
- as.character(unique(.ref_group[[arm]])),+ ht_x <- c(ht_x, 1) |
| 220 | -8x | -
- as.data.frame(results$emmeans_fit)[[arm]]- |
- ||
| 221 | -- |
- )- |
- ||
| 222 | -+ | 646 | +1x |
- )+ ht_units <- c(ht_units, "lines") |
| 223 | +647 |
-
+ } |
||
| 224 | -8x | +648 | +1x |
- contrasts_smry <- summary(+ if (annot_at_risk) {
|
| 225 | -8x | +649 | +1x |
- emmeans_contrasts,+ no_at_risk_tbl <- rep(TRUE, 6 + ttl_row + foot_row) |
| 226 | -8x | +650 | +1x |
- infer = TRUE,+ if (!annot_at_risk_title) {
|
| 227 | -8x | +|||
| 651 | +! |
- adjust = "none"+ no_at_risk_tbl[length(no_at_risk_tbl) - 2 - foot_row] <- FALSE |
||
| 228 | +652 |
- )+ } |
||
| 229 | +653 |
-
+ } else {
|
||
| 230 | -8x | +|||
| 654 | +! |
- smry_contrasts_level <- contrasts_smry[grepl(smry_level, contrasts_smry$contrast), ]+ no_at_risk_tbl <- no_tbl_ind |
||
| 231 | +655 |
-
+ } |
||
| 232 | -8x | +|||
| 656 | +
- list(+ |
|||
| 233 | -8x | +657 | +1x |
- n = length(y[!is.na(y)]),+ grid::grid.layout( |
| 234 | -8x | +658 | +1x |
- rate = formatters::with_label(+ nrow = sum(no_at_risk_tbl), ncol = 2, |
| 235 | -8x | +659 | +1x |
- ifelse(distribution == "negbin",+ widths = grid::unit(c(col_annot_width, 1), c("pt", "null")),
|
| 236 | -8x | +660 | +1x |
- emmeans_smry_level$response * scale,+ heights = grid::unit( |
| 237 | -8x | -
- emmeans_smry_level$rate * scale- |
- ||
| 238 | -+ | 661 | +1x |
- ),+ x = ht_x[no_at_risk_tbl], |
| 239 | -8x | +662 | +1x |
- "Adjusted Rate"+ units = ht_units[no_at_risk_tbl] |
| 240 | +663 |
- ),- |
- ||
| 241 | -8x | -
- rate_ci = formatters::with_label(+ ) |
||
| 242 | -8x | +|||
| 664 | +
- c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale),+ ) |
|||
| 243 | -8x | +|||
| 665 | +
- f_conf_level(conf_level)+ } |
|||
| 244 | +666 |
- ),+ |
||
| 245 | -8x | +|||
| 667 | +
- rate_ratio = formatters::with_label(+ #' Helper function to create patient-at-risk grobs |
|||
| 246 | -8x | +|||
| 668 | +
- smry_contrasts_level$ratio,+ #' |
|||
| 247 | -8x | +|||
| 669 | +
- "Adjusted Rate Ratio"+ #' @description `r lifecycle::badge("deprecated")`
|
|||
| 248 | +670 |
- ),+ #' |
||
| 249 | -8x | +|||
| 671 | +
- rate_ratio_ci = formatters::with_label(+ #' Two graphical objects are obtained, one corresponding to row labeling and the second to the table of |
|||
| 250 | -8x | +|||
| 672 | +
- c(smry_contrasts_level$asymp.LCL, smry_contrasts_level$asymp.UCL),+ #' numbers of patients at risk. If `title = TRUE`, a third object corresponding to the table title is |
|||
| 251 | -8x | +|||
| 673 | +
- f_conf_level(conf_level)+ #' also obtained. |
|||
| 252 | +674 |
- ),+ #' |
||
| 253 | -8x | +|||
| 675 | +
- pval = formatters::with_label(+ #' @inheritParams g_km |
|||
| 254 | -8x | +|||
| 676 | +
- smry_contrasts_level$p.value,+ #' @inheritParams h_ggkm |
|||
| 255 | -8x | +|||
| 677 | +
- "p-value"+ #' @param annot_tbl (`data.frame`)\cr annotation as prepared by [survival::summary.survfit()] which |
|||
| 256 | +678 |
- )+ #' includes the number of patients at risk at given time points. |
||
| 257 | +679 |
- )+ #' @param xlim (`numeric(1)`)\cr the maximum value on the x-axis (used to ensure the at risk table aligns with the KM |
||
| 258 | +680 |
- }+ #' graph). |
||
| 259 | +681 |
- }+ #' @param title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk` |
||
| 260 | +682 |
- # h_glm_count ------------------------------------------------------------------+ #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`. |
||
| 261 | +683 |
- #' Helper functions for Poisson models+ #' |
||
| 262 | +684 |
- #'+ #' @return A named `list` of two `gTree` objects if `title = FALSE`: `at_risk` and `label`, or three |
||
| 263 | +685 |
- #' @description `r lifecycle::badge("experimental")`
+ #' `gTree` objects if `title = TRUE`: `at_risk`, `label`, and `title`. |
||
| 264 | +686 |
#' |
||
| 265 | +687 |
- #' Helper functions that returns the results of [stats::glm()] when Poisson or Quasi-Poisson+ #' @examples |
||
| 266 | +688 |
- #' distributions are needed (see `family` parameter), or [MASS::glm.nb()] for Negative Binomial+ #' \donttest{
|
||
| 267 | +689 |
- #' distributions. Link function for the GLM is `log`.+ #' library(dplyr) |
||
| 268 | +690 |
- #'+ #' library(survival) |
||
| 269 | +691 |
- #' @inheritParams argument_convention+ #' library(grid) |
||
| 270 | +692 |
#' |
||
| 271 | +693 |
- #' @seealso [summarize_glm_count]+ #' fit_km <- tern_ex_adtte %>% |
||
| 272 | +694 |
- #'+ #' filter(PARAMCD == "OS") %>% |
||
| 273 | +695 |
- #' @name h_glm_count+ #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
||
| 274 | +696 |
- NULL+ #' |
||
| 275 | +697 |
-
+ #' data_plot <- h_data_plot(fit_km = fit_km) |
||
| 276 | +698 |
- #' @describeIn h_glm_count Helper function to return the results of the+ #' |
||
| 277 | +699 |
- #' selected model (Poisson, Quasi-Poisson, negative binomial).+ #' xticks <- h_xticks(data = data_plot) |
||
| 278 | +700 |
#' |
||
| 279 | +701 |
- #' @param .df_row (`data.frame`)\cr dataset that includes all the variables that are called+ #' gg <- h_ggkm( |
||
| 280 | +702 |
- #' in `.var` and `variables`.+ #' data = data_plot, |
||
| 281 | +703 |
- #' @param variables (named `list` of `string`)\cr list of additional analysis variables, with+ #' censor_show = TRUE, |
||
| 282 | +704 |
- #' expected elements:+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
||
| 283 | +705 |
- #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple+ #' title = "tt", footnotes = "ff", yval = "Survival" |
||
| 284 | +706 |
- #' groups will be summarized. Specifically, the first level of `arm` variable is taken as the+ #' ) |
||
| 285 | +707 |
- #' reference group.+ #' |
||
| 286 | +708 |
- #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as+ #' # The annotation table reports the patient at risk for a given strata and |
||
| 287 | +709 |
- #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`.+ #' # times (`xticks`). |
||
| 288 | +710 |
- #' * `offset` (`numeric`)\cr a numeric vector or scalar adding an offset.+ #' annot_tbl <- summary(fit_km, times = xticks) |
||
| 289 | +711 |
- #' @param distribution (`character`)\cr a character value specifying the distribution+ #' if (is.null(fit_km$strata)) {
|
||
| 290 | +712 |
- #' used in the regression (Poisson, Quasi-Poisson, negative binomial).+ #' annot_tbl <- with(annot_tbl, data.frame(n.risk = n.risk, time = time, strata = "All")) |
||
| 291 | +713 |
- #' @param weights (`character`)\cr a character vector specifying weights used+ #' } else {
|
||
| 292 | +714 |
- #' in averaging predictions. Number of weights must equal the number of levels included in the covariates.+ #' strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
|
||
| 293 | +715 |
- #' Weights option passed to [emmeans::emmeans()].+ #' levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2] |
||
| 294 | +716 |
- #'+ #' annot_tbl <- data.frame( |
||
| 295 | +717 |
- #' @return+ #' n.risk = annot_tbl$n.risk, |
||
| 296 | +718 |
- #' * `h_glm_count()` returns the results of the selected model.+ #' time = annot_tbl$time, |
||
| 297 | +719 |
- #'+ #' strata = annot_tbl$strata |
||
| 298 | +720 |
- #' @keywords internal+ #' ) |
||
| 299 | +721 |
- h_glm_count <- function(.var,+ #' } |
||
| 300 | +722 |
- .df_row,+ #' |
||
| 301 | +723 |
- variables,+ #' # The annotation table is transformed into a grob. |
||
| 302 | +724 |
- distribution,+ #' tbl <- h_grob_tbl_at_risk(data = data_plot, annot_tbl = annot_tbl, xlim = max(xticks)) |
||
| 303 | +725 |
- weights) {
+ #' |
||
| 304 | -21x | +|||
| 726 | +
- checkmate::assert_subset(distribution, c("poisson", "quasipoisson", "negbin"), empty.ok = FALSE)
+ #' # For the representation, the layout is estimated for which the decomposition |
|||
| 305 | -19x | +|||
| 727 | +
- switch(distribution,+ #' # of the graphic element is necessary. |
|||
| 306 | -13x | +|||
| 728 | +
- poisson = h_glm_poisson(.var, .df_row, variables, weights),+ #' g_el <- h_decompose_gg(gg) |
|||
| 307 | -1x | +|||
| 729 | +
- quasipoisson = h_glm_quasipoisson(.var, .df_row, variables, weights),+ #' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f") |
|||
| 308 | -5x | +|||
| 730 | +
- negbin = h_glm_negbin(.var, .df_row, variables, weights)+ #' |
|||
| 309 | +731 |
- )+ #' grid::grid.newpage() |
||
| 310 | +732 |
- }+ #' pushViewport(viewport(layout = lyt, height = .95, width = .95)) |
||
| 311 | +733 |
-
+ #' grid.rect(gp = grid::gpar(lty = 1, col = "purple", fill = "gray85", lwd = 1)) |
||
| 312 | +734 |
- #' @describeIn h_glm_count Helper function to return results of a Poisson model.+ #' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 2)) |
||
| 313 | +735 |
- #'+ #' grid.rect(gp = grid::gpar(lty = 1, col = "orange", fill = "gray85", lwd = 1)) |
||
| 314 | +736 |
- #' @return+ #' grid::grid.draw(tbl$at_risk) |
||
| 315 | +737 |
- #' * `h_glm_poisson()` returns the results of a Poisson model.+ #' popViewport() |
||
| 316 | +738 |
- #'+ #' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 1)) |
||
| 317 | +739 |
- #' @keywords internal+ #' grid.rect(gp = grid::gpar(lty = 1, col = "green3", fill = "gray85", lwd = 1)) |
||
| 318 | +740 |
- h_glm_poisson <- function(.var,+ #' grid::grid.draw(tbl$label) |
||
| 319 | +741 |
- .df_row,+ #' } |
||
| 320 | +742 |
- variables,+ #' |
||
| 321 | +743 |
- weights) {
+ #' @export |
||
| 322 | -17x | +|||
| 744 | +
- arm <- variables$arm+ h_grob_tbl_at_risk <- function(data, annot_tbl, xlim, title = TRUE) {
|
|||
| 323 | -17x | +745 | +1x |
- covariates <- variables$covariates+ lifecycle::deprecate_warn( |
| 324 | -17x | -
- offset <- .df_row[[variables$offset]]- |
- ||
| 325 | -+ | 746 | +1x |
-
+ "0.9.4", |
| 326 | -15x | +747 | +1x |
- formula <- stats::as.formula(paste0(+ "h_grob_tbl_at_risk()", |
| 327 | -15x | +748 | +1x |
- .var, " ~ ",+ details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
| 328 | +749 |
- " + ",+ ) |
||
| 329 | -15x | -
- paste(covariates, collapse = " + "),- |
- ||
| 330 | -+ | 750 | +1x |
- " + ",+ txtlines <- levels(as.factor(data$strata)) |
| 331 | -15x | +751 | +1x |
- arm+ nlines <- nlevels(as.factor(data$strata)) |
| 332 | -+ | |||
| 752 | +1x |
- ))+ y_int <- annot_tbl$time[2] - annot_tbl$time[1] |
||
| 333 | -+ | |||
| 753 | +1x |
-
+ annot_tbl <- expand.grid( |
||
| 334 | -15x | +754 | +1x |
- glm_fit <- stats::glm(+ time = seq(0, xlim, y_int), |
| 335 | -15x | +755 | +1x |
- formula = formula,+ strata = unique(annot_tbl$strata) |
| 336 | -15x | +756 | +1x |
- offset = offset,+ ) %>% dplyr::left_join(annot_tbl, by = c("time", "strata"))
|
| 337 | -15x | +757 | +1x |
- data = .df_row,+ annot_tbl[is.na(annot_tbl)] <- 0 |
| 338 | -15x | +758 | +1x |
- family = stats::poisson(link = "log")+ y_str_unit <- as.numeric(annot_tbl$strata) |
| 339 | -+ | |||
| 759 | +1x |
- )+ vp_table <- grid::plotViewport(margins = grid::unit(c(0, 0, 0, 0), "lines")) |
||
| 340 | -+ | |||
| 760 | +1x |
-
+ if (title) {
|
||
| 341 | -15x | +761 | +1x |
- emmeans_fit <- emmeans::emmeans(+ gb_table_title <- grid::gList( |
| 342 | -15x | +762 | +1x |
- glm_fit,+ grid::textGrob( |
| 343 | -15x | +763 | +1x |
- specs = arm,+ label = "Patients at Risk:", |
| 344 | -15x | +764 | +1x |
- data = .df_row,+ x = 1, |
| 345 | -15x | +765 | +1x |
- type = "response",+ y = grid::unit(0.2, "native"), |
| 346 | -15x | +766 | +1x |
- offset = 0,+ gp = grid::gpar(fontface = "bold", fontsize = 10) |
| 347 | -15x | +|||
| 767 | +
- weights = weights+ ) |
|||
| 348 | +768 |
- )+ ) |
||
| 349 | +769 |
-
+ } |
||
| 350 | -15x | +770 | +1x |
- list(+ gb_table_left_annot <- grid::gList( |
| 351 | -15x | +771 | +1x |
- glm_fit = glm_fit,+ grid::rectGrob( |
| 352 | -15x | +772 | +1x |
- emmeans_fit = emmeans_fit+ x = 0, y = grid::unit(c(1:nlines) - 1, "lines"), |
| 353 | -+ | |||
| 773 | +1x |
- )+ gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
|
||
| 354 | -+ | |||
| 774 | +1x |
- }+ height = grid::unit(1, "lines"), just = "bottom", hjust = 0 |
||
| 355 | +775 |
-
+ ), |
||
| 356 | -+ | |||
| 776 | +1x |
- #' @describeIn h_glm_count Helper function to return results of a Quasi-Poisson model.+ grid::textGrob( |
||
| 357 | -+ | |||
| 777 | +1x |
- #'+ label = unique(annot_tbl$strata), |
||
| 358 | -+ | |||
| 778 | +1x |
- #' @return+ x = 0.5, |
||
| 359 | -+ | |||
| 779 | +1x |
- #' * `h_glm_quasipoisson()` returns the results of a Quasi-Poisson model.+ y = grid::unit( |
||
| 360 | -+ | |||
| 780 | +1x |
- #'+ (max(unique(y_str_unit)) - unique(y_str_unit)) + 0.75, |
||
| 361 | -+ | |||
| 781 | +1x |
- #' @keywords internal+ "native" |
||
| 362 | +782 |
- h_glm_quasipoisson <- function(.var,+ ), |
||
| 363 | -+ | |||
| 783 | +1x |
- .df_row,+ gp = grid::gpar(fontface = "italic", fontsize = 10) |
||
| 364 | +784 |
- variables,+ ) |
||
| 365 | +785 |
- weights) {
+ ) |
||
| 366 | -5x | +786 | +1x |
- arm <- variables$arm+ gb_patient_at_risk <- grid::gList( |
| 367 | -5x | +787 | +1x |
- covariates <- variables$covariates+ grid::rectGrob( |
| 368 | -5x | -
- offset <- .df_row[[variables$offset]]- |
- ||
| 369 | -+ | 788 | +1x |
-
+ x = 0, y = grid::unit(c(1:nlines) - 1, "lines"), |
| 370 | -3x | +789 | +1x |
- formula <- stats::as.formula(paste0(+ gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
|
| 371 | -3x | +790 | +1x |
- .var, " ~ ",+ height = grid::unit(1, "lines"), just = "bottom", hjust = 0 |
| 372 | +791 |
- " + ",+ ), |
||
| 373 | -3x | -
- paste(covariates, collapse = " + "),- |
- ||
| 374 | -+ | 792 | +1x |
- " + ",+ grid::textGrob( |
| 375 | -3x | -
- arm- |
- ||
| 376 | -+ | 793 | +1x |
- ))+ label = annot_tbl$n.risk, |
| 377 | -+ | |||
| 794 | +1x |
-
+ x = grid::unit(annot_tbl$time, "native"), |
||
| 378 | -3x | +795 | +1x |
- glm_fit <- stats::glm(+ y = grid::unit( |
| 379 | -3x | +796 | +1x |
- formula = formula,+ (max(y_str_unit) - y_str_unit) + .5, |
| 380 | -3x | +797 | +1x |
- offset = offset,+ "line" |
| 381 | -3x | +798 | +1x |
- data = .df_row,+ ) # maybe native |
| 382 | -3x | +|||
| 799 | +
- family = stats::quasipoisson(link = "log")+ ) |
|||
| 383 | +800 |
) |
||
| 384 | +801 | |||
| 385 | -3x | +802 | +1x |
- emmeans_fit <- emmeans::emmeans(+ ret <- list( |
| 386 | -3x | +803 | +1x |
- glm_fit,+ at_risk = grid::gList( |
| 387 | -3x | +804 | +1x |
- specs = arm,+ grid::gTree( |
| 388 | -3x | +805 | +1x |
- data = .df_row,+ vp = vp_table, |
| 389 | -3x | +806 | +1x |
- type = "response",+ children = grid::gList( |
| 390 | -3x | +807 | +1x |
- offset = 0,+ grid::gTree( |
| 391 | -3x | -
- weights = weights- |
- ||
| 392 | -- |
- )- |
- ||
| 393 | -+ | 808 | +1x |
-
+ vp = grid::dataViewport( |
| 394 | -3x | +809 | +1x |
- list(+ xscale = c(0, xlim) + c(-0.05, 0.05) * xlim, |
| 395 | -3x | +810 | +1x |
- glm_fit = glm_fit,+ yscale = c(0, nlines + 1), |
| 396 | -3x | +811 | +1x |
- emmeans_fit = emmeans_fit+ extension = c(0.05, 0) |
| 397 | +812 |
- )+ ), |
||
| 398 | -+ | |||
| 813 | +1x |
- }+ children = grid::gList(gb_patient_at_risk) |
||
| 399 | +814 |
-
+ ) |
||
| 400 | +815 |
- #' @describeIn h_glm_count Helper function to return results of a negative binomial model.+ ) |
||
| 401 | +816 |
- #'+ ) |
||
| 402 | +817 |
- #' @return+ ), |
||
| 403 | -+ | |||
| 818 | +1x |
- #' * `h_glm_negbin()` returns the results of a negative binomial model.+ label = grid::gList( |
||
| 404 | -+ | |||
| 819 | +1x |
- #'+ grid::gTree( |
||
| 405 | -+ | |||
| 820 | +1x |
- #' @keywords internal+ vp = grid::viewport(width = max(grid::stringWidth(txtlines))), |
||
| 406 | -+ | |||
| 821 | +1x |
- h_glm_negbin <- function(.var,+ children = grid::gList( |
||
| 407 | -+ | |||
| 822 | +1x |
- .df_row,+ grid::gTree( |
||
| 408 | -+ | |||
| 823 | +1x |
- variables,+ vp = grid::dataViewport( |
||
| 409 | -+ | |||
| 824 | +1x |
- weights) {
+ xscale = 0:1, |
||
| 410 | -9x | +825 | +1x |
- arm <- variables$arm+ yscale = c(0, nlines + 1), |
| 411 | -9x | +826 | +1x |
- covariates <- variables$covariates+ extension = c(0.0, 0) |
| 412 | +827 | - - | -||
| 413 | -9x | -
- formula <- stats::as.formula(paste0(+ ), |
||
| 414 | -9x | +828 | +1x |
- .var, " ~ ",+ children = grid::gList(gb_table_left_annot) |
| 415 | +829 |
- " + ",+ ) |
||
| 416 | -9x | +|||
| 830 | +
- paste(covariates, collapse = " + "),+ ) |
|||
| 417 | +831 |
- " + ",+ ) |
||
| 418 | -9x | +|||
| 832 | +
- arm+ ) |
|||
| 419 | +833 |
- ))+ ) |
||
| 420 | +834 | |||
| 421 | -9x | +835 | +1x |
- glm_fit <- MASS::glm.nb(+ if (title) {
|
| 422 | -9x | +836 | +1x |
- formula = formula,+ ret[["title"]] <- grid::gList( |
| 423 | -9x | +837 | +1x |
- data = .df_row,+ grid::gTree( |
| 424 | -9x | +838 | +1x |
- link = "log"+ vp = grid::viewport(width = max(grid::stringWidth(txtlines))), |
| 425 | -+ | |||
| 839 | +1x |
- )+ children = grid::gList( |
||
| 426 | -+ | |||
| 840 | +1x |
-
+ grid::gTree( |
||
| 427 | -7x | +841 | +1x |
- emmeans_fit <- emmeans::emmeans(+ vp = grid::dataViewport( |
| 428 | -7x | +842 | +1x |
- glm_fit,+ xscale = 0:1, |
| 429 | -7x | +843 | +1x |
- specs = arm,+ yscale = c(0, 1), |
| 430 | -7x | +844 | +1x |
- data = .df_row,+ extension = c(0, 0) |
| 431 | -7x | +|||
| 845 | +
- type = "response",+ ), |
|||
| 432 | -7x | +846 | +1x |
- offset = 0,+ children = grid::gList(gb_table_title) |
| 433 | -7x | +|||
| 847 | +
- weights = weights+ ) |
|||
| 434 | +848 |
- )+ ) |
||
| 435 | +849 |
-
+ ) |
||
| 436 | -7x | +|||
| 850 | +
- list(+ ) |
|||
| 437 | -7x | +|||
| 851 | +
- glm_fit = glm_fit,+ }+ |
+ |||
| 852 | ++ | + | ||
| 438 | -7x | +853 | +1x |
- emmeans_fit = emmeans_fit+ ret |
| 439 | +854 |
- )+ } |
||
| 440 | +855 |
- }+ |
||
| 441 | +856 |
-
+ #' Helper function to create survival estimation grobs |
||
| 442 | +857 |
- # h_ppmeans --------------------------------------------------------------------+ #' |
||
| 443 | +858 |
- #' Function to return the estimated means using predicted probabilities+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 444 | +859 |
#' |
||
| 445 | +860 |
- #' @description+ #' The survival fit is transformed in a grob containing a table with groups in |
||
| 446 | +861 |
- #' For each arm level, the predicted mean rate is calculated using the fitted model object, with `newdata`+ #' rows characterized by N, median and 95% confidence interval. |
||
| 447 | +862 |
- #' set to the result of `stats::model.frame`, a reconstructed data or the original data, depending on the+ #' |
||
| 448 | +863 |
- #' object formula (coming from the fit). The confidence interval is derived using the `conf_level` parameter.+ #' @inheritParams g_km |
||
| 449 | +864 |
- #'+ #' @inheritParams h_data_plot |
||
| 450 | +865 |
- #' @param obj (`glm.fit`)\cr fitted model object used to derive the mean rate estimates in each treatment arm.+ #' @param ttheme (`list`)\cr see [gridExtra::ttheme_default()]. |
||
| 451 | +866 |
- #' @param .df_row (`data.frame`)\cr dataset that includes all the variables that are called in `.var` and `variables`.+ #' @param x (`proportion`)\cr a value between 0 and 1 specifying x-location. |
||
| 452 | +867 |
- #' @param arm (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be+ #' @param y (`proportion`)\cr a value between 0 and 1 specifying y-location. |
||
| 453 | +868 |
- #' summarized. Specifically, the first level of `arm` variable is taken as the reference group.+ #' @param width (`grid::unit`)\cr width (as a unit) to use when printing the grob. |
||
| 454 | +869 |
- #' @param conf_level (`proportion`)\cr value used to derive the confidence interval for the rate.+ #' |
||
| 455 | +870 | ++ |
+ #' @return A `grob` of a table containing statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`).+ |
+ |
| 871 |
#' |
|||
| 456 | +872 |
- #' @return+ #' @examples |
||
| 457 | +873 |
- #' * `h_ppmeans()` returns the estimated means.+ #' \donttest{
|
||
| 458 | +874 |
- #'+ #' library(dplyr) |
||
| 459 | +875 |
- #' @seealso [summarize_glm_count()].+ #' library(survival) |
||
| 460 | +876 |
- #'+ #' library(grid) |
||
| 461 | +877 |
- #' @export+ #' |
||
| 462 | +878 |
- h_ppmeans <- function(obj, .df_row, arm, conf_level) {
+ #' grid::grid.newpage() |
||
| 463 | -1x | +|||
| 879 | +
- alpha <- 1 - conf_level+ #' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1)) |
|||
| 464 | -1x | +|||
| 880 | +
- p <- 1 - alpha / 2+ #' tern_ex_adtte %>% |
|||
| 465 | +881 |
-
+ #' filter(PARAMCD == "OS") %>% |
||
| 466 | -1x | +|||
| 882 | +
- arm_levels <- levels(.df_row[[arm]])+ #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
|||
| 467 | +883 |
-
+ #' h_grob_median_surv() %>% |
||
| 468 | -1x | +|||
| 884 | +
- out <- lapply(arm_levels, function(lev) {
+ #' grid::grid.draw() |
|||
| 469 | -3x | +|||
| 885 | +
- temp <- .df_row+ #' } |
|||
| 470 | -3x | +|||
| 886 | +
- temp[[arm]] <- factor(lev, levels = arm_levels)+ #' |
|||
| 471 | +887 |
-
+ #' @export |
||
| 472 | -3x | +|||
| 888 | +
- mf <- stats::model.frame(obj$formula, data = temp)+ h_grob_median_surv <- function(fit_km, |
|||
| 473 | -3x | +|||
| 889 | +
- X <- stats::model.matrix(obj$formula, data = mf) # nolint+ armval = "All", |
|||
| 474 | +890 |
-
+ x = 0.9, |
||
| 475 | -3x | +|||
| 891 | +
- rate <- stats::predict(obj, newdata = mf, type = "response")+ y = 0.9, |
|||
| 476 | -3x | +|||
| 892 | +
- rate_hat <- mean(rate)+ width = grid::unit(0.3, "npc"), |
|||
| 477 | +893 |
-
+ ttheme = gridExtra::ttheme_default()) {
|
||
| 478 | -3x | +894 | +1x |
- zz <- colMeans(rate * X)+ lifecycle::deprecate_warn( |
| 479 | -3x | +895 | +1x |
- se <- sqrt(as.numeric(t(zz) %*% stats::vcov(obj) %*% zz))+ "0.9.4", |
| 480 | -3x | +896 | +1x |
- rate_lwr <- rate_hat * exp(-stats::qnorm(p) * se / rate_hat)+ "h_grob_median_surv()", |
| 481 | -3x | +897 | +1x |
- rate_upr <- rate_hat * exp(stats::qnorm(p) * se / rate_hat)+ details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
| 482 | +898 |
-
+ ) |
||
| 483 | -3x | +899 | +1x |
- c(rate_hat, rate_lwr, rate_upr)+ data <- h_tbl_median_surv(fit_km, armval = armval) |
| 484 | +900 |
- })+ |
||
| 485 | -+ | |||
| 901 | +1x |
-
+ width <- grid::convertUnit(grid::unit(as.numeric(width), grid::unitType(width)), "in") |
||
| 486 | +902 | 1x |
- names(out) <- arm_levels+ height <- width * (nrow(data) + 1) / 12+ |
+ |
| 903 | ++ | + | ||
| 487 | +904 | 1x |
- out <- do.call(rbind, out)+ w <- paste(" ", c(
|
|
| 488 | +905 | 1x |
- if ("negbin" %in% class(obj)) {
+ rownames(data)[which.max(nchar(rownames(data)))], |
|
| 489 | -! | +|||
| 906 | +1x |
- colnames(out) <- c("response", "asymp.LCL", "asymp.UCL")
+ sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))]) |
||
| 490 | +907 |
- } else {
+ )) |
||
| 491 | +908 | 1x |
- colnames(out) <- c("rate", "asymp.LCL", "asymp.UCL")
+ w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE) |
|
| 492 | +909 |
- }+ |
||
| 493 | +910 | 1x |
- out <- as.data.frame(out)+ w_txt <- sapply(1:64, function(x) {
|
|
| 494 | -1x | +911 | +64x |
- out[[arm]] <- rownames(out)+ graphics::par(ps = x) |
| 495 | -1x | -
- out- |
- ||
| 496 | -+ | 912 | +64x |
- }+ graphics::strwidth(w[4], units = "in") |
| 1 | +913 |
- #' Create a STEP graph+ }) |
||
| 2 | -+ | |||
| 914 | +1x |
- #'+ f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]]) |
||
| 3 | +915 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 4 | -+ | |||
| 916 | +1x |
- #'+ h_txt <- sapply(1:64, function(x) {
|
||
| 5 | -+ | |||
| 917 | +64x |
- #' Based on the STEP results, creates a `ggplot` graph showing the estimated HR or OR+ graphics::par(ps = x) |
||
| 6 | -+ | |||
| 918 | +64x |
- #' along the continuous biomarker value subgroups.+ graphics::strheight(grid::stringHeight("X"), units = "in")
|
||
| 7 | +919 |
- #'+ }) |
||
| 8 | -+ | |||
| 920 | +1x |
- #' @param df (`tibble`)\cr result of [tidy.step()].+ f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))]) |
||
| 9 | +921 |
- #' @param use_percentile (`flag`)\cr whether to use percentiles for the x axis or actual+ |
||
| 10 | -+ | |||
| 922 | +1x |
- #' biomarker values.+ if (ttheme$core$fg_params$fontsize == 12) {
|
||
| 11 | -+ | |||
| 923 | +1x |
- #' @param est (named `list`)\cr `col` and `lty` settings for estimate line.+ ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h) |
||
| 12 | -+ | |||
| 924 | +1x |
- #' @param ci_ribbon (named `list` or `NULL`)\cr `fill` and `alpha` settings for the confidence interval+ ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h) |
||
| 13 | -+ | |||
| 925 | +1x |
- #' ribbon area, or `NULL` to not plot a CI ribbon.+ ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h) |
||
| 14 | +926 |
- #' @param col (`character`)\cr color(s).+ } |
||
| 15 | +927 |
- #'+ |
||
| 16 | -+ | |||
| 928 | +1x |
- #' @return A `ggplot` STEP graph.+ gt <- gridExtra::tableGrob( |
||
| 17 | -+ | |||
| 929 | +1x |
- #'+ d = data, |
||
| 18 | -+ | |||
| 930 | +1x |
- #' @seealso Custom tidy method [tidy.step()].+ theme = ttheme |
||
| 19 | +931 |
- #'+ ) |
||
| 20 | -+ | |||
| 932 | +1x |
- #' @examples+ gt$widths <- ((w_unit / sum(w_unit)) * width) |
||
| 21 | -+ | |||
| 933 | +1x |
- #' library(nestcolor)+ gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt)) |
||
| 22 | +934 |
- #' library(survival)+ |
||
| 23 | -+ | |||
| 935 | +1x |
- #' lung$sex <- factor(lung$sex)+ vp <- grid::viewport( |
||
| 24 | -+ | |||
| 936 | +1x |
- #'+ x = grid::unit(x, "npc") + grid::unit(1, "lines"), |
||
| 25 | -+ | |||
| 937 | +1x |
- #' # Survival example.+ y = grid::unit(y, "npc") + grid::unit(1.5, "lines"), |
||
| 26 | -+ | |||
| 938 | +1x |
- #' vars <- list(+ height = height, |
||
| 27 | -+ | |||
| 939 | +1x |
- #' time = "time",+ width = width, |
||
| 28 | -+ | |||
| 940 | +1x |
- #' event = "status",+ just = c("right", "top")
|
||
| 29 | +941 |
- #' arm = "sex",+ ) |
||
| 30 | +942 |
- #' biomarker = "age"+ |
||
| 31 | -+ | |||
| 943 | +1x |
- #' )+ grid::gList( |
||
| 32 | -+ | |||
| 944 | +1x |
- #'+ grid::gTree( |
||
| 33 | -+ | |||
| 945 | +1x |
- #' step_matrix <- fit_survival_step(+ vp = vp, |
||
| 34 | -+ | |||
| 946 | +1x |
- #' variables = vars,+ children = grid::gList(gt) |
||
| 35 | +947 |
- #' data = lung,+ ) |
||
| 36 | +948 |
- #' control = c(control_coxph(), control_step(num_points = 10, degree = 2))+ ) |
||
| 37 | +949 |
- #' )+ } |
||
| 38 | +950 |
- #' step_data <- broom::tidy(step_matrix)+ |
||
| 39 | +951 |
- #'+ #' Helper function to create grid object with y-axis annotation |
||
| 40 | +952 |
- #' # Default plot.+ #' |
||
| 41 | +953 |
- #' g_step(step_data)+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 42 | +954 |
#' |
||
| 43 | +955 |
- #' # Add the reference 1 horizontal line.+ #' Build the y-axis annotation from a decomposed `ggplot`. |
||
| 44 | +956 |
- #' library(ggplot2)+ #' |
||
| 45 | +957 |
- #' g_step(step_data) ++ #' @param ylab (`gtable`)\cr the y-lab as a graphical object derived from a `ggplot`. |
||
| 46 | +958 |
- #' ggplot2::geom_hline(ggplot2::aes(yintercept = 1), linetype = 2)+ #' @param yaxis (`gtable`)\cr the y-axis as a graphical object derived from a `ggplot`. |
||
| 47 | +959 |
#' |
||
| 48 | -- |
- #' # Use actual values instead of percentiles, different color for estimate and no CI,- |
- ||
| 49 | +960 |
- #' # use log scale for y axis.+ #' @return A `gTree` object containing the y-axis annotation from a `ggplot`. |
||
| 50 | +961 |
- #' g_step(+ #' |
||
| 51 | +962 |
- #' step_data,+ #' @examples |
||
| 52 | +963 |
- #' use_percentile = FALSE,+ #' \donttest{
|
||
| 53 | +964 |
- #' est = list(col = "blue", lty = 1),+ #' library(dplyr) |
||
| 54 | +965 |
- #' ci_ribbon = NULL+ #' library(survival) |
||
| 55 | +966 |
- #' ) + scale_y_log10()+ #' library(grid) |
||
| 56 | +967 |
#' |
||
| 57 | +968 |
- #' # Adding another curve based on additional column.+ #' fit_km <- tern_ex_adtte %>% |
||
| 58 | +969 |
- #' step_data$extra <- exp(step_data$`Percentile Center`)+ #' filter(PARAMCD == "OS") %>% |
||
| 59 | +970 |
- #' g_step(step_data) ++ #' survfit(formula = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
||
| 60 | +971 |
- #' ggplot2::geom_line(ggplot2::aes(y = extra), linetype = 2, color = "green")+ #' data_plot <- h_data_plot(fit_km = fit_km) |
||
| 61 | +972 |
- #'+ #' xticks <- h_xticks(data = data_plot) |
||
| 62 | +973 |
- #' # Response example.+ #' gg <- h_ggkm( |
||
| 63 | +974 |
- #' vars <- list(+ #' data = data_plot, |
||
| 64 | +975 |
- #' response = "status",+ #' censor_show = TRUE, |
||
| 65 | +976 |
- #' arm = "sex",+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
||
| 66 | +977 |
- #' biomarker = "age"+ #' title = "title", footnotes = "footnotes", yval = "Survival" |
||
| 67 | +978 |
#' ) |
||
| 68 | +979 |
#' |
||
| 69 | +980 |
- #' step_matrix <- fit_rsp_step(+ #' g_el <- h_decompose_gg(gg) |
||
| 70 | +981 |
- #' variables = vars,+ #' |
||
| 71 | +982 |
- #' data = lung,+ #' grid::grid.newpage() |
||
| 72 | +983 |
- #' control = c(+ #' pvp <- grid::plotViewport(margins = c(5, 4, 2, 20)) |
||
| 73 | +984 |
- #' control_logistic(response_definition = "I(response == 2)"),+ #' pushViewport(pvp) |
||
| 74 | +985 |
- #' control_step()+ #' grid::grid.draw(h_grob_y_annot(ylab = g_el$ylab, yaxis = g_el$yaxis)) |
||
| 75 | +986 |
- #' )+ #' grid.rect(gp = grid::gpar(lty = 1, col = "gray35", fill = NA)) |
||
| 76 | +987 |
- #' )+ #' } |
||
| 77 | +988 |
- #' step_data <- broom::tidy(step_matrix)+ #' |
||
| 78 | +989 |
- #' g_step(step_data)+ #' @export |
||
| 79 | +990 |
- #'+ h_grob_y_annot <- function(ylab, yaxis) {
|
||
| 80 | -+ | |||
| 991 | +1x |
- #' @export+ lifecycle::deprecate_warn( |
||
| 81 | -+ | |||
| 992 | +1x |
- g_step <- function(df,+ "0.9.4", |
||
| 82 | -+ | |||
| 993 | +1x |
- use_percentile = "Percentile Center" %in% names(df),+ "h_grob_y_annot()", |
||
| 83 | -+ | |||
| 994 | +1x |
- est = list(col = "blue", lty = 1),+ details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
||
| 84 | +995 |
- ci_ribbon = list(fill = getOption("ggplot2.discrete.colour")[1], alpha = 0.5),
+ ) |
||
| 85 | -+ | |||
| 996 | +1x |
- col = getOption("ggplot2.discrete.colour")) {
+ grid::gList( |
||
| 86 | -2x | +997 | +1x |
- checkmate::assert_tibble(df)+ grid::gTree( |
| 87 | -2x | +998 | +1x |
- checkmate::assert_flag(use_percentile)+ vp = grid::viewport( |
| 88 | -2x | +999 | +1x |
- checkmate::assert_character(col, null.ok = TRUE)+ width = grid::convertX(yaxis$widths + ylab$widths, "pt"), |
| 89 | -2x | +1000 | +1x |
- checkmate::assert_list(est, names = "named")+ x = grid::unit(1, "npc"), |
| 90 | -2x | +1001 | +1x |
- checkmate::assert_list(ci_ribbon, names = "named", null.ok = TRUE)+ just = "right" |
| 91 | +1002 |
-
+ ), |
||
| 92 | -2x | +1003 | +1x |
- x_var <- ifelse(use_percentile, "Percentile Center", "Interval Center")+ children = grid::gList(cbind(ylab, yaxis)) |
| 93 | -2x | +|||
| 1004 | +
- df$x <- df[[x_var]]+ ) |
|||
| 94 | -2x | +|||
| 1005 | +
- attrs <- attributes(df)+ ) |
|||
| 95 | -2x | +|||
| 1006 | +
- df$y <- df[[attrs$estimate]]+ } |
|||
| 96 | +1007 | |||
| 97 | +1008 |
- # Set legend names. To be modified also at call level+ #' Helper function to create Cox-PH grobs |
||
| 98 | -2x | +|||
| 1009 | +
- legend_names <- c("Estimate", "CI 95%")
+ #' |
|||
| 99 | +1010 |
-
+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 100 | -2x | +|||
| 1011 | +
- p <- ggplot2::ggplot(df, ggplot2::aes(x = .data[["x"]], y = .data[["y"]]))+ #' |
|||
| 101 | +1012 |
-
+ #' Grob of `rtable` output from [h_tbl_coxph_pairwise()] |
||
| 102 | -2x | +|||
| 1013 | +
- if (!is.null(col)) {
+ #' |
|||
| 103 | -2x | +|||
| 1014 | +
- p <- p ++ #' @inheritParams h_grob_median_surv |
|||
| 104 | -2x | +|||
| 1015 | +
- ggplot2::scale_color_manual(values = col)+ #' @param ... arguments to pass to [h_tbl_coxph_pairwise()]. |
|||
| 105 | +1016 |
- }+ #' @param x (`proportion`)\cr a value between 0 and 1 specifying x-location. |
||
| 106 | +1017 |
-
+ #' @param y (`proportion`)\cr a value between 0 and 1 specifying y-location. |
||
| 107 | -2x | +|||
| 1018 | +
- if (!is.null(ci_ribbon)) {
+ #' @param width (`grid::unit`)\cr width (as a unit) to use when printing the grob. |
|||
| 108 | -1x | +|||
| 1019 | +
- if (is.null(ci_ribbon$fill)) {
+ #' |
|||
| 109 | -! | +|||
| 1020 | +
- ci_ribbon$fill <- "lightblue"+ #' @return A `grob` of a table containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`), |
|||
| 110 | +1021 |
- }+ #' and `p-value (log-rank)`. |
||
| 111 | -1x | +|||
| 1022 | +
- p <- p + ggplot2::geom_ribbon(+ #' |
|||
| 112 | -1x | +|||
| 1023 | +
- ggplot2::aes(+ #' @examples |
|||
| 113 | -1x | +|||
| 1024 | +
- ymin = .data[["ci_lower"]], ymax = .data[["ci_upper"]],+ #' \donttest{
|
|||
| 114 | -1x | +|||
| 1025 | +
- fill = legend_names[2]+ #' library(dplyr) |
|||
| 115 | +1026 |
- ),+ #' library(survival) |
||
| 116 | -1x | +|||
| 1027 | +
- alpha = ci_ribbon$alpha+ #' library(grid) |
|||
| 117 | +1028 |
- ) ++ #' |
||
| 118 | -1x | +|||
| 1029 | +
- scale_fill_manual(+ #' grid::grid.newpage() |
|||
| 119 | -1x | +|||
| 1030 | +
- name = "", values = c("CI 95%" = ci_ribbon$fill)
+ #' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1)) |
|||
| 120 | +1031 |
- )+ #' data <- tern_ex_adtte %>% |
||
| 121 | +1032 |
- }+ #' filter(PARAMCD == "OS") %>% |
||
| 122 | -2x | +|||
| 1033 | +
- suppressMessages(p <- p ++ #' mutate(is_event = CNSR == 0) |
|||
| 123 | -2x | +|||
| 1034 | +
- ggplot2::geom_line(+ #' tbl_grob <- h_grob_coxph( |
|||
| 124 | -2x | +|||
| 1035 | +
- ggplot2::aes(y = .data[["y"]], color = legend_names[1]),+ #' df = data, |
|||
| 125 | -2x | +|||
| 1036 | +
- linetype = est$lty+ #' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARMCD"), |
|||
| 126 | +1037 |
- ) ++ #' control_coxph_pw = control_coxph(conf_level = 0.9), x = 0.5, y = 0.5 |
||
| 127 | -2x | +|||
| 1038 | +
- scale_colour_manual(+ #' ) |
|||
| 128 | -2x | +|||
| 1039 | +
- name = "", values = c("Estimate" = "blue")
+ #' grid::grid.draw(tbl_grob) |
|||
| 129 | +1040 |
- ))+ #' } |
||
| 130 | +1041 |
-
+ #' |
||
| 131 | -2x | +|||
| 1042 | +
- p <- p + ggplot2::labs(x = attrs$biomarker, y = attrs$estimate)+ #' @export |
|||
| 132 | -2x | +|||
| 1043 | +
- if (use_percentile) {
+ h_grob_coxph <- function(..., |
|||
| 133 | -1x | +|||
| 1044 | +
- p <- p + ggplot2::scale_x_continuous(labels = scales::percent)+ x = 0, |
|||
| 134 | +1045 |
- }+ y = 0, |
||
| 135 | -2x | +|||
| 1046 | +
- p+ width = grid::unit(0.4, "npc"), |
|||
| 136 | +1047 |
- }+ ttheme = gridExtra::ttheme_default( |
||
| 137 | +1048 |
-
+ padding = grid::unit(c(1, .5), "lines"), |
||
| 138 | +1049 |
- #' Custom tidy method for STEP results+ core = list(bg_params = list(fill = c("grey95", "grey90"), alpha = .5))
|
||
| 139 | +1050 |
- #'+ )) {
|
||
| 140 | -+ | |||
| 1051 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ lifecycle::deprecate_warn( |
||
| 141 | -+ | |||
| 1052 | +1x |
- #'+ "0.9.4", |
||
| 142 | -+ | |||
| 1053 | +1x |
- #' Tidy the STEP results into a `tibble` format ready for plotting.+ "h_grob_coxph()", |
||
| 143 | -+ | |||
| 1054 | +1x |
- #'+ details = "`g_km` now generates `ggplot` objects. This function is no longer used within `tern`." |
||
| 144 | +1055 |
- #' @param x (`matrix`)\cr results from [fit_survival_step()].+ ) |
||
| 145 | -+ | |||
| 1056 | +1x |
- #' @param ... not used.+ data <- h_tbl_coxph_pairwise(...) |
||
| 146 | +1057 |
- #'+ |
||
| 147 | -+ | |||
| 1058 | +1x |
- #' @return A `tibble` with one row per STEP subgroup. The estimates and CIs are on the HR or OR scale,+ width <- grid::convertUnit(grid::unit(as.numeric(width), grid::unitType(width)), "in") |
||
| 148 | -+ | |||
| 1059 | +1x |
- #' respectively. Additional attributes carry metadata also used for plotting.+ height <- width * (nrow(data) + 1) / 12 |
||
| 149 | +1060 |
- #'+ |
||
| 150 | -+ | |||
| 1061 | +1x |
- #' @seealso [g_step()] which consumes the result from this function.+ w <- paste(" ", c(
|
||
| 151 | -+ | |||
| 1062 | +1x |
- #'+ rownames(data)[which.max(nchar(rownames(data)))], |
||
| 152 | -+ | |||
| 1063 | +1x |
- #' @method tidy step+ sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))]) |
||
| 153 | +1064 |
- #'+ )) |
||
| 154 | -+ | |||
| 1065 | +1x |
- #' @examples+ w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE) |
||
| 155 | +1066 |
- #' library(survival)+ |
||
| 156 | -+ | |||
| 1067 | +1x |
- #' lung$sex <- factor(lung$sex)+ w_txt <- sapply(1:64, function(x) {
|
||
| 157 | -+ | |||
| 1068 | +64x |
- #' vars <- list(+ graphics::par(ps = x) |
||
| 158 | -+ | |||
| 1069 | +64x |
- #' time = "time",+ graphics::strwidth(w[4], units = "in") |
||
| 159 | +1070 |
- #' event = "status",+ }) |
||
| 160 | -+ | |||
| 1071 | +1x |
- #' arm = "sex",+ f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]]) |
||
| 161 | +1072 |
- #' biomarker = "age"+ |
||
| 162 | -+ | |||
| 1073 | +1x |
- #' )+ h_txt <- sapply(1:64, function(x) {
|
||
| 163 | -+ | |||
| 1074 | +64x |
- #' step_matrix <- fit_survival_step(+ graphics::par(ps = x) |
||
| 164 | -+ | |||
| 1075 | +64x |
- #' variables = vars,+ graphics::strheight(grid::stringHeight("X"), units = "in")
|
||
| 165 | +1076 |
- #' data = lung,+ }) |
||
| 166 | -+ | |||
| 1077 | +1x |
- #' control = c(control_coxph(), control_step(num_points = 10, degree = 2))+ f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))]) |
||
| 167 | +1078 |
- #' )+ |
||
| 168 | -+ | |||
| 1079 | +1x |
- #' broom::tidy(step_matrix)+ if (ttheme$core$fg_params$fontsize == 12) {
|
||
| 169 | -+ | |||
| 1080 | +1x |
- #'+ ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h) |
||
| 170 | -+ | |||
| 1081 | +1x |
- #' @export+ ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ |
+ ||
| 1082 | +1x | +
+ ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h) |
||
| 171 | +1083 |
- tidy.step <- function(x, ...) { # nolint
+ } |
||
| 172 | -7x | +|||
| 1084 | +
- checkmate::assert_class(x, "step")+ |
|||
| 173 | -7x | +1085 | +1x |
- dat <- as.data.frame(x)+ tryCatch( |
| 174 | -7x | +1086 | +1x |
- nams <- names(dat)+ expr = {
|
| 175 | -7x | +1087 | +1x |
- is_surv <- "loghr" %in% names(dat)+ gt <- gridExtra::tableGrob( |
| 176 | -7x | +1088 | +1x |
- est_var <- ifelse(is_surv, "loghr", "logor")+ d = data, |
| 177 | -7x | +1089 | +1x |
- new_est_var <- ifelse(is_surv, "Hazard Ratio", "Odds Ratio")+ theme = ttheme |
| 178 | -7x | +1090 | +1x |
- new_y_vars <- c(new_est_var, c("ci_lower", "ci_upper"))
+ ) # ERROR 'data' must be of a vector type, was 'NULL' |
| 179 | -7x | +1091 | +1x |
- names(dat)[match(est_var, nams)] <- new_est_var+ gt$widths <- ((w_unit / sum(w_unit)) * width) |
| 180 | -7x | +1092 | +1x |
- dat[, new_y_vars] <- exp(dat[, new_y_vars])+ gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt)) |
| 181 | -7x | +1093 | +1x |
- any_is_na <- any(is.na(dat[, new_y_vars]))+ vp <- grid::viewport( |
| 182 | -7x | +1094 | +1x |
- any_is_very_large <- any(abs(dat[, new_y_vars]) > 1e10, na.rm = TRUE)+ x = grid::unit(x, "npc") + grid::unit(1, "lines"), |
| 183 | -7x | +1095 | +1x |
- if (any_is_na) {
+ y = grid::unit(y, "npc") + grid::unit(1.5, "lines"), |
| 184 | -2x | +1096 | +1x |
- warning(paste(+ height = height, |
| 185 | -2x | +1097 | +1x |
- "Missing values in the point estimate or CI columns,",+ width = width, |
| 186 | -2x | +1098 | +1x |
- "this will lead to holes in the `g_step()` plot"+ just = c("left", "bottom")
|
| 187 | +1099 |
- ))+ ) |
||
| 188 | -+ | |||
| 1100 | +1x |
- }+ grid::gList( |
||
| 189 | -7x | +1101 | +1x |
- if (any_is_very_large) {
+ grid::gTree( |
| 190 | -2x | +1102 | +1x |
- warning(paste(+ vp = vp, |
| 191 | -2x | +1103 | +1x |
- "Very large absolute values in the point estimate or CI columns,",+ children = grid::gList(gt) |
| 192 | -2x | +|||
| 1104 | +
- "consider adding `scale_y_log10()` to the `g_step()` result for plotting"+ ) |
|||
| 193 | +1105 |
- ))+ ) |
||
| 194 | +1106 |
- }+ }, |
||
| 195 | -7x | +1107 | +1x |
- if (any_is_na || any_is_very_large) {
+ error = function(w) {
|
| 196 | -4x | +|||
| 1108 | +! |
- warning("Consider using larger `bandwidth`, less `num_points` in `control_step()` settings for fitting")
+ message(paste(+ |
+ ||
| 1109 | +! | +
+ "Warning: Cox table will not be displayed as there is",+ |
+ ||
| 1110 | +! | +
+ "not any level to be compared in the arm variable." |
||
| 197 | +1111 |
- }+ )) |
||
| 198 | -7x | +|||
| 1112 | +! |
- structure(+ return( |
||
| 199 | -7x | +|||
| 1113 | +! |
- tibble::as_tibble(dat),+ grid::gList( |
||
| 200 | -7x | +|||
| 1114 | +! |
- estimate = new_est_var,+ grid::gTree( |
||
| 201 | -7x | +|||
| 1115 | +! |
- biomarker = attr(x, "variables")$biomarker,+ vp = NULL, |
||
| 202 | -7x | +|||
| 1116 | +! |
- ci = f_conf_level(attr(x, "control")$conf_level)+ children = NULL |
||
| 203 | +1117 | ++ |
+ )+ |
+ |
| 1118 | ++ |
+ )+ |
+ ||
| 1119 | ++ |
+ )+ |
+ ||
| 1120 | ++ |
+ }+ |
+ ||
| 1121 |
) |
|||
| 204 | +1122 |
}@@ -85462,14 +86430,14 @@ tern coverage - 95.64% |
| 1 |
- #' Control function for Cox regression+ #' Incidence rate estimation |
||
| 5 |
- #' Sets a list of parameters for Cox regression fit. Used internally.+ #' The analyze function [estimate_incidence_rate()] creates a layout element to estimate an event rate adjusted for |
||
| 6 |
- #'+ #' person-years at risk, otherwise known as incidence rate. The primary analysis variable specified via `vars` is |
||
| 7 |
- #' @inheritParams argument_convention+ #' the person-years at risk. In addition to this variable, the `n_events` variable for number of events observed (where |
||
| 8 |
- #' @param pval_method (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`.+ #' a value of 1 means an event was observed and 0 means that no event was observed) must also be specified. |
||
| 9 |
- #' @param interaction (`flag`)\cr if `TRUE`, the model includes the interaction between the studied+ #' |
||
| 10 |
- #' treatment and candidate covariate. Note that for univariate models without treatment arm, and+ #' @inheritParams argument_convention |
||
| 11 |
- #' multivariate models, no interaction can be used so that this needs to be `FALSE`.+ #' @param control (`list`)\cr parameters for estimation details, specified by using |
||
| 12 |
- #' @param ties (`string`)\cr among `exact` (equivalent to `DISCRETE` in SAS), `efron` and `breslow`,+ #' the helper function [control_incidence_rate()]. Possible parameter options are: |
||
| 13 |
- #' see [survival::coxph()]. Note: there is no equivalent of SAS `EXACT` method in R.+ #' * `conf_level` (`proportion`)\cr confidence level for the estimated incidence rate. |
||
| 14 |
- #'+ #' * `conf_type` (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar` |
||
| 15 |
- #' @return A `list` of items with names corresponding to the arguments.+ #' for confidence interval type. |
||
| 16 |
- #'+ #' * `input_time_unit` (`string`)\cr `day`, `week`, `month`, or `year` (default) |
||
| 17 |
- #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()].+ #' indicating time unit for data input. |
||
| 18 |
- #'+ #' * `num_pt_year` (`numeric`)\cr time unit for desired output (in person-years). |
||
| 19 |
- #' @examples+ #' @param n_events (`string`)\cr name of integer variable indicating whether an event has been observed (1) or not (0). |
||
| 20 |
- #' control_coxreg()+ #' @param id_var (`string`)\cr name of variable used as patient identifier if `"n_unique"` is included in `.stats`. |
||
| 21 |
- #'+ #' Defaults to `"USUBJID"`. |
||
| 22 |
- #' @export+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_incidence_rate")`
|
||
| 23 |
- control_coxreg <- function(pval_method = c("wald", "likelihood"),
+ #' to see available statistics for this function. |
||
| 24 |
- ties = c("exact", "efron", "breslow"),
+ #' @param summarize (`flag`)\cr whether the function should act as an analyze function (`summarize = FALSE`), or a |
||
| 25 |
- conf_level = 0.95,+ #' summarize function (`summarize = TRUE`). Defaults to `FALSE`. |
||
| 26 |
- interaction = FALSE) {
+ #' @param label_fmt (`string`)\cr how labels should be formatted after a row split occurs if `summarize = TRUE`. The |
||
| 27 | -55x | +
- pval_method <- match.arg(pval_method)+ #' string should use `"%s"` to represent row split levels, and `"%.labels"` to represent labels supplied to the |
|
| 28 | -55x | +
- ties <- match.arg(ties)+ #' `.labels` argument. Defaults to `"%s - %.labels"`. |
|
| 29 | -55x | +
- checkmate::assert_flag(interaction)+ #' |
|
| 30 | -55x | +
- assert_proportion_value(conf_level)+ #' @seealso [control_incidence_rate()] and helper functions [h_incidence_rate]. |
|
| 31 | -55x | +
- list(+ #' |
|
| 32 | -55x | +
- pval_method = pval_method,+ #' @examples |
|
| 33 | -55x | +
- ties = ties,+ #' df <- data.frame( |
|
| 34 | -55x | +
- conf_level = conf_level,+ #' USUBJID = as.character(seq(6)), |
|
| 35 | -55x | +
- interaction = interaction+ #' CNSR = c(0, 1, 1, 0, 0, 0), |
|
| 36 |
- )+ #' AVAL = c(10.1, 20.4, 15.3, 20.8, 18.7, 23.4), |
||
| 37 |
- }+ #' ARM = factor(c("A", "A", "A", "B", "B", "B")),
|
||
| 38 |
-
+ #' STRATA1 = factor(c("X", "Y", "Y", "X", "X", "Y"))
|
||
| 39 |
- #' Custom tidy methods for Cox regression+ #' ) |
||
| 40 |
- #'+ #' df$n_events <- 1 - df$CNSR |
||
| 41 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 42 |
- #'+ #' @name incidence_rate |
||
| 43 |
- #' @inheritParams argument_convention+ #' @order 1 |
||
| 44 |
- #' @param x (`list`)\cr result of the Cox regression model fitted by [fit_coxreg_univar()] (for univariate models)+ NULL |
||
| 45 |
- #' or [fit_coxreg_multivar()] (for multivariate models).+ |
||
| 46 |
- #'+ #' @describeIn incidence_rate Statistics function which estimates the incidence rate and the |
||
| 47 |
- #' @return [broom::tidy()] returns:+ #' associated confidence interval. |
||
| 48 |
- #' * For `summary.coxph` objects, a `data.frame` with columns: `Pr(>|z|)`, `exp(coef)`, `exp(-coef)`, `lower .95`,+ #' |
||
| 49 |
- #' `upper .95`, `level`, and `n`.+ #' @return |
||
| 50 |
- #' * For `coxreg.univar` objects, a `data.frame` with columns: `effect`, `term`, `term_label`, `level`, `n`, `hr`,+ #' * `s_incidence_rate()` returns the following statistics: |
||
| 51 |
- #' `lcl`, `ucl`, `pval`, and `ci`.+ #' - `person_years`: Total person-years at risk. |
||
| 52 |
- #' * For `coxreg.multivar` objects, a `data.frame` with columns: `term`, `pval`, `term_label`, `hr`, `lcl`, `ucl`,+ #' - `n_events`: Total number of events observed. |
||
| 53 |
- #' `level`, and `ci`.+ #' - `rate`: Estimated incidence rate. |
||
| 54 |
- #'+ #' - `rate_ci`: Confidence interval for the incidence rate. |
||
| 55 |
- #' @seealso [cox_regression]+ #' - `n_unique`: Total number of patients with at least one event observed. |
||
| 56 |
- #'+ #' - `n_rate`: Total number of events observed & estimated incidence rate. |
||
| 57 |
- #' @name tidy_coxreg+ #' |
||
| 58 |
- NULL+ #' @keywords internal |
||
| 59 |
-
+ s_incidence_rate <- function(df, |
||
| 60 |
- #' @describeIn tidy_coxreg Custom tidy method for [survival::coxph()] summary results.+ .var, |
||
| 61 |
- #'+ n_events, |
||
| 62 |
- #' Tidy the [survival::coxph()] results into a `data.frame` to extract model results.+ is_event = lifecycle::deprecated(), |
||
| 63 |
- #'+ id_var = "USUBJID", |
||
| 64 |
- #' @method tidy summary.coxph+ control = control_incidence_rate()) {
|
||
| 65 | -+ | 17x |
- #'+ if (lifecycle::is_present(is_event)) {
|
| 66 | -+ | ! |
- #' @examples+ checkmate::assert_string(is_event) |
| 67 | -+ | ! |
- #' library(survival)+ lifecycle::deprecate_warn( |
| 68 | -+ | ! |
- #' library(broom)+ "0.9.6", "s_incidence_rate(is_event)", "s_incidence_rate(n_events)" |
| 69 |
- #'+ ) |
||
| 70 | -+ | ! |
- #' set.seed(1, kind = "Mersenne-Twister")+ n_events <- is_event |
| 71 | -+ | ! |
- #'+ df[[n_events]] <- as.numeric(df[[is_event]]) |
| 72 |
- #' dta_bladder <- with(+ } |
||
| 73 |
- #' data = bladder[bladder$enum < 5, ],+ |
||
| 74 | -+ | 17x |
- #' data.frame(+ assert_df_with_variables(df, list(tte = .var, n_events = n_events)) |
| 75 | -+ | 17x |
- #' time = stop,+ checkmate::assert_string(.var) |
| 76 | -+ | 17x |
- #' status = event,+ checkmate::assert_string(n_events) |
| 77 | -+ | 17x |
- #' armcd = as.factor(rx),+ checkmate::assert_string(id_var) |
| 78 | -+ | 17x |
- #' covar1 = as.factor(enum),+ checkmate::assert_numeric(df[[.var]], any.missing = FALSE) |
| 79 | -+ | 17x |
- #' covar2 = factor(+ checkmate::assert_integerish(df[[n_events]], any.missing = FALSE) |
| 80 |
- #' sample(as.factor(enum)),+ |
||
| 81 | -+ | 17x |
- #' levels = 1:4, labels = c("F", "F", "M", "M")
+ n_unique <- n_available(unique(df[[id_var]][df[[n_events]] == 1])) |
| 82 | -+ | 17x |
- #' )+ input_time_unit <- control$input_time_unit |
| 83 | -+ | 17x |
- #' )+ num_pt_year <- control$num_pt_year |
| 84 | -+ | 17x |
- #' )+ conf_level <- control$conf_level |
| 85 | -+ | 17x |
- #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
+ person_years <- sum(df[[.var]], na.rm = TRUE) * ( |
| 86 | -+ | 17x |
- #' formatters::var_labels(dta_bladder)[names(labels)] <- labels+ 1 * (input_time_unit == "year") + |
| 87 | -+ | 17x |
- #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ 1 / 12 * (input_time_unit == "month") + |
| 88 | -+ | 17x |
- #'+ 1 / 52.14 * (input_time_unit == "week") + |
| 89 | -+ | 17x |
- #' formula <- "survival::Surv(time, status) ~ armcd + covar1"+ 1 / 365.24 * (input_time_unit == "day") |
| 90 |
- #' msum <- summary(coxph(stats::as.formula(formula), data = dta_bladder))+ ) |
||
| 91 | -+ | 17x |
- #' tidy(msum)+ n_events <- sum(df[[n_events]], na.rm = TRUE) |
| 92 |
- #'+ |
||
| 93 | -+ | 17x |
- #' @export+ result <- h_incidence_rate( |
| 94 | -+ | 17x |
- tidy.summary.coxph <- function(x, # nolint+ person_years, |
| 95 | -+ | 17x |
- ...) {
+ n_events, |
| 96 | -199x | +17x |
- checkmate::assert_class(x, "summary.coxph")+ control |
| 97 | -199x | +
- pval <- x$coefficients+ ) |
|
| 98 | -199x | +17x |
- confint <- x$conf.int+ list( |
| 99 | -199x | +17x |
- levels <- rownames(pval)+ person_years = formatters::with_label(person_years, "Total patient-years at risk"), |
| 100 | -+ | 17x |
-
+ n_events = formatters::with_label(n_events, "Number of adverse events observed"), |
| 101 | -199x | +17x |
- pval <- tibble::as_tibble(pval)+ rate = formatters::with_label(result$rate, paste("AE rate per", num_pt_year, "patient-years")),
|
| 102 | -199x | +17x |
- confint <- tibble::as_tibble(confint)+ rate_ci = formatters::with_label(result$rate_ci, f_conf_level(conf_level)), |
| 103 | -+ | 17x |
-
+ n_unique = formatters::with_label(n_unique, "Total number of patients with at least one adverse event"), |
| 104 | -199x | +17x |
- ret <- cbind(pval[, grepl("Pr", names(pval))], confint)
+ n_rate = formatters::with_label( |
| 105 | -199x | +17x |
- ret$level <- levels+ c(n_events, result$rate), |
| 106 | -199x | +17x |
- ret$n <- x[["n"]]+ paste("Number of adverse events observed (AE rate per", num_pt_year, "patient-years)")
|
| 107 | -199x | +
- ret+ ) |
|
| 108 |
- }+ ) |
||
| 109 |
-
+ } |
||
| 110 |
- #' @describeIn tidy_coxreg Custom tidy method for a univariate Cox regression.+ |
||
| 111 |
- #'+ #' @describeIn incidence_rate Formatted analysis function which is used as `afun` in `estimate_incidence_rate()`. |
||
| 112 |
- #' Tidy up the result of a Cox regression model fitted by [fit_coxreg_univar()].+ #' |
||
| 113 |
- #'+ #' @return |
||
| 114 |
- #' @method tidy coxreg.univar+ #' * `a_incidence_rate()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 117 |
- #' ## Cox regression: arm + 1 covariate.+ #' a_incidence_rate( |
||
| 118 |
- #' mod1 <- fit_coxreg_univar(+ #' df, |
||
| 119 |
- #' variables = list(+ #' .var = "AVAL", |
||
| 120 |
- #' time = "time", event = "status", arm = "armcd",+ #' .df_row = df, |
||
| 121 |
- #' covariates = "covar1"+ #' n_events = "n_events" |
||
| 122 |
- #' ),+ #' ) |
||
| 123 |
- #' data = dta_bladder,+ #' |
||
| 124 |
- #' control = control_coxreg(conf_level = 0.91)+ #' @export |
||
| 125 |
- #' )+ a_incidence_rate <- function(df, |
||
| 126 |
- #'+ labelstr = "", |
||
| 127 |
- #' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates.+ .var, |
||
| 128 |
- #' mod2 <- fit_coxreg_univar(+ .df_row, |
||
| 129 |
- #' variables = list(+ n_events, |
||
| 130 |
- #' time = "time", event = "status", arm = "armcd",+ id_var = "USUBJID", |
||
| 131 |
- #' covariates = c("covar1", "covar2")
+ control = control_incidence_rate(), |
||
| 132 |
- #' ),+ .stats = NULL, |
||
| 133 |
- #' data = dta_bladder,+ .formats = c( |
||
| 134 |
- #' control = control_coxreg(conf_level = 0.91, interaction = TRUE)+ "person_years" = "xx.x", |
||
| 135 |
- #' )+ "n_events" = "xx", |
||
| 136 |
- #'+ "rate" = "xx.xx", |
||
| 137 |
- #' tidy(mod1)+ "rate_ci" = "(xx.xx, xx.xx)", |
||
| 138 |
- #' tidy(mod2)+ "n_unique" = "xx", |
||
| 139 |
- #'+ "n_rate" = "xx (xx.x)" |
||
| 140 |
- #' @export+ ), |
||
| 141 |
- tidy.coxreg.univar <- function(x, # nolint+ .labels = NULL, |
||
| 142 |
- ...) {
+ .indent_mods = NULL, |
||
| 143 | -38x | +
- checkmate::assert_class(x, "coxreg.univar")+ na_str = default_na_str(), |
|
| 144 | -38x | +
- mod <- x$mod+ label_fmt = "%s - %.labels") {
|
|
| 145 | -38x | +16x |
- vars <- c(x$vars$arm, x$vars$covariates)+ checkmate::assert_string(label_fmt) |
| 146 | -38x | +
- has_arm <- "arm" %in% names(x$vars)+ |
|
| 147 | -+ | 16x |
-
+ x_stats <- s_incidence_rate( |
| 148 | -38x | +16x |
- result <- if (!has_arm) {
+ df = df, .var = .var, n_events = n_events, id_var = id_var, control = control |
| 149 | -5x | +
- Map(+ ) |
|
| 150 | -5x | +16x |
- mod = mod, vars = vars,+ if (is.null(unlist(x_stats))) {
|
| 151 | -5x | +! |
- f = function(mod, vars) {
+ return(NULL) |
| 152 | -6x | +
- h_coxreg_multivar_extract(+ } |
|
| 153 | -6x | +
- var = vars,+ |
|
| 154 | -6x | +
- data = x$data,+ # Fill in with defaults |
|
| 155 | -6x | +16x |
- mod = mod,+ formats_def <- formals()$.formats %>% eval() |
| 156 | -6x | +16x |
- control = x$control+ .formats <- c(.formats, formats_def)[!duplicated(names(c(.formats, formats_def)))] |
| 157 | -+ | 16x |
- )+ labels_def <- sapply(x_stats, \(x) attributes(x)$label) |
| 158 | -+ | 16x |
- }+ .labels <- c(.labels, labels_def)[!duplicated(names(c(.labels, labels_def)))] |
| 159 | -+ | 16x |
- )+ if (nzchar(labelstr) > 0) {
|
| 160 | -38x | +8x |
- } else if (x$control$interaction) {
+ .labels <- sapply(.labels, \(x) gsub("%.labels", x, gsub("%s", labelstr, label_fmt)))
|
| 161 | -12x | +
- Map(+ } |
|
| 162 | -12x | +
- mod = mod, covar = vars,+ |
|
| 163 | -12x | +
- f = function(mod, covar) {
+ # Fill in with formatting defaults if needed |
|
| 164 | -26x | +16x |
- h_coxreg_extract_interaction(+ .stats <- get_stats("estimate_incidence_rate", stats_in = .stats)
|
| 165 | -26x | +16x |
- effect = x$vars$arm, covar = covar, mod = mod, data = x$data,+ .formats <- get_formats_from_stats(.stats, .formats) |
| 166 | -26x | +16x |
- at = x$at, control = x$control+ .labels <- get_labels_from_stats(.stats, .labels) |
| 167 | -+ | 16x |
- )+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods) |
| 168 |
- }+ |
||
| 169 | -+ | 16x |
- )+ x_stats <- x_stats[.stats] |
| 170 |
- } else {
+
|
||
| 171 | -21x | +16x |
- Map(+ in_rows( |
| 172 | -21x | +16x |
- mod = mod, vars = vars,+ .list = x_stats, |
| 173 | -21x | +16x |
- f = function(mod, vars) {
+ .formats = .formats, |
| 174 | -53x | +16x |
- h_coxreg_univar_extract(+ .labels = .labels, |
| 175 | -53x | +16x |
- effect = x$vars$arm, covar = vars, data = x$data, mod = mod,+ .indent_mods = .indent_mods, |
| 176 | -53x | +16x |
- control = x$control+ .format_na_strs = na_str |
| 177 |
- )+ ) |
||
| 178 |
- }+ } |
||
| 179 |
- )+ |
||
| 180 |
- }+ #' @describeIn incidence_rate Layout-creating function which can take statistics function arguments |
||
| 181 | -38x | +
- result <- do.call(rbind, result)+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
| 182 |
-
+ #' |
||
| 183 | -38x | +
- result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl))+ #' @return |
|
| 184 | -38x | +
- result$n <- lapply(result$n, empty_vector_if_na)+ #' * `estimate_incidence_rate()` returns a layout object suitable for passing to further layouting functions, |
|
| 185 | -38x | +
- result$ci <- lapply(result$ci, empty_vector_if_na)+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
| 186 | -38x | +
- result$hr <- lapply(result$hr, empty_vector_if_na)+ #' the statistics from `s_incidence_rate()` to the table layout. |
|
| 187 | -38x | +
- if (x$control$interaction) {
+ #' |
|
| 188 | -12x | +
- result$pval_inter <- lapply(result$pval_inter, empty_vector_if_na)+ #' @examples |
|
| 189 |
- # Remove interaction p-values due to change in specifications.+ #' basic_table(show_colcounts = TRUE) %>% |
||
| 190 | -12x | +
- result$pval[result$effect != "Treatment:"] <- NA+ #' split_cols_by("ARM") %>%
|
|
| 191 |
- }+ #' estimate_incidence_rate( |
||
| 192 | -38x | +
- result$pval <- lapply(result$pval, empty_vector_if_na)+ #' vars = "AVAL", |
|
| 193 | -38x | +
- attr(result, "conf_level") <- x$control$conf_level+ #' n_events = "n_events", |
|
| 194 | -38x | +
- result+ #' control = control_incidence_rate( |
|
| 195 |
- }+ #' input_time_unit = "month", |
||
| 196 |
-
+ #' num_pt_year = 100 |
||
| 197 |
- #' @describeIn tidy_coxreg Custom tidy method for a multivariate Cox regression.+ #' ) |
||
| 198 |
- #'+ #' ) %>% |
||
| 199 |
- #' Tidy up the result of a Cox regression model fitted by [fit_coxreg_multivar()].+ #' build_table(df) |
||
| 201 |
- #' @method tidy coxreg.multivar+ #' # summarize = TRUE |
||
| 202 |
- #'+ #' basic_table(show_colcounts = TRUE) %>% |
||
| 203 |
- #' @examples+ #' split_cols_by("ARM") %>%
|
||
| 204 |
- #' multivar_model <- fit_coxreg_multivar(+ #' split_rows_by("STRATA1", child_labels = "visible") %>%
|
||
| 205 |
- #' variables = list(+ #' estimate_incidence_rate( |
||
| 206 |
- #' time = "time", event = "status", arm = "armcd",+ #' vars = "AVAL", |
||
| 207 |
- #' covariates = c("covar1", "covar2")
+ #' n_events = "n_events", |
||
| 208 |
- #' ),+ #' .stats = c("n_unique", "n_rate"),
|
||
| 209 |
- #' data = dta_bladder+ #' summarize = TRUE, |
||
| 210 |
- #' )+ #' label_fmt = "%.labels" |
||
| 211 |
- #' broom::tidy(multivar_model)+ #' ) %>% |
||
| 212 |
- #'+ #' build_table(df) |
||
| 213 |
- #' @export+ #' |
||
| 214 |
- tidy.coxreg.multivar <- function(x, # nolint+ #' @export |
||
| 215 |
- ...) {
+ #' @order 2 |
||
| 216 | -16x | +
- checkmate::assert_class(x, "coxreg.multivar")+ estimate_incidence_rate <- function(lyt, |
|
| 217 | -16x | +
- vars <- c(x$vars$arm, x$vars$covariates)+ vars, |
|
| 218 |
-
+ n_events, |
||
| 219 |
- # Convert the model summaries to data.+ id_var = "USUBJID", |
||
| 220 | -16x | +
- result <- Map(+ control = control_incidence_rate(), |
|
| 221 | -16x | +
- vars = vars,+ na_str = default_na_str(), |
|
| 222 | -16x | +
- f = function(vars) {
+ nested = TRUE, |
|
| 223 | -60x | +
- h_coxreg_multivar_extract(+ summarize = FALSE, |
|
| 224 | -60x | +
- var = vars, data = x$data,+ label_fmt = "%s - %.labels", |
|
| 225 | -60x | +
- mod = x$mod, control = x$control+ ..., |
|
| 226 |
- )+ show_labels = "hidden", |
||
| 227 |
- }+ table_names = vars, |
||
| 228 |
- )+ .stats = c("person_years", "n_events", "rate", "rate_ci"),
|
||
| 229 | -16x | +
- result <- do.call(rbind, result)+ .formats = NULL, |
|
| 230 |
-
+ .labels = NULL, |
||
| 231 | -16x | +
- result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl))+ .indent_mods = NULL) {
|
|
| 232 | -16x | +5x |
- result$ci <- lapply(result$ci, empty_vector_if_na)+ extra_args <- c( |
| 233 | -16x | +5x |
- result$hr <- lapply(result$hr, empty_vector_if_na)+ list(.stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str), |
| 234 | -16x | +5x |
- result$pval <- lapply(result$pval, empty_vector_if_na)+ list(n_events = n_events, id_var = id_var, control = control, label_fmt = label_fmt, ...) |
| 235 | -16x | +
- result <- result[, names(result) != "n"]+ ) |
|
| 236 | -16x | +
- attr(result, "conf_level") <- x$control$conf_level+ |
|
| 237 | -+ | 5x |
-
+ if (!summarize) {
|
| 238 | -16x | +3x |
- result+ analyze( |
| 239 | -+ | 3x |
- }+ lyt, |
| 240 | -+ | 3x |
-
+ vars, |
| 241 | -+ | 3x |
- #' Fitting functions for Cox proportional hazards regression+ show_labels = show_labels, |
| 242 | -+ | 3x |
- #'+ table_names = table_names, |
| 243 | -+ | 3x |
- #' @description `r lifecycle::badge("stable")`
+ afun = a_incidence_rate, |
| 244 | -+ | 3x |
- #'+ na_str = na_str, |
| 245 | -+ | 3x |
- #' Fitting functions for univariate and multivariate Cox regression models.+ nested = nested, |
| 246 | -+ | 3x |
- #'+ extra_args = extra_args |
| 247 |
- #' @param variables (named `list`)\cr the names of the variables found in `data`, passed as a named list and+ ) |
||
| 248 |
- #' corresponding to the `time`, `event`, `arm`, `strata`, and `covariates` terms. If `arm` is missing from+ } else {
|
||
| 249 | -+ | 2x |
- #' `variables`, then only Cox model(s) including the `covariates` will be fitted and the corresponding effect+ summarize_row_groups( |
| 250 | -+ | 2x |
- #' estimates will be tabulated later.+ lyt, |
| 251 | -+ | 2x |
- #' @param data (`data.frame`)\cr the dataset containing the variables to fit the models.+ vars, |
| 252 | -+ | 2x |
- #' @param at (`list` of `numeric`)\cr when the candidate covariate is a `numeric`, use `at` to specify+ cfun = a_incidence_rate, |
| 253 | -+ | 2x |
- #' the value of the covariate at which the effect should be estimated.+ na_str = na_str, |
| 254 | -+ | 2x |
- #' @param control (`list`)\cr a list of parameters as returned by the helper function [control_coxreg()].+ extra_args = extra_args |
| 255 |
- #'+ ) |
||
| 256 |
- #' @seealso [h_cox_regression] for relevant helper functions, [cox_regression].+ } |
||
| 257 |
- #'+ } |
| 258 | +1 |
- #' @examples+ #' Count patients with marked laboratory abnormalities |
||
| 259 | +2 |
- #' library(survival)+ #' |
||
| 260 | +3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+ |
| 4 |
#' |
|||
| 261 | +5 |
- #' set.seed(1, kind = "Mersenne-Twister")+ #' The analyze function [count_abnormal_by_marked()] creates a layout element to count patients with marked laboratory |
||
| 262 | +6 |
- #'+ #' abnormalities for each direction of abnormality, categorized by parameter value. |
||
| 263 | +7 |
- #' # Testing dataset [survival::bladder].+ #' |
||
| 264 | +8 |
- #' dta_bladder <- with(+ #' This function analyzes primary analysis variable `var` which indicates whether a single, replicated, |
||
| 265 | +9 |
- #' data = bladder[bladder$enum < 5, ],+ #' or last marked laboratory abnormality was observed. Levels of `var` to include for each marked lab |
||
| 266 | +10 |
- #' data.frame(+ #' abnormality (`single` and `last_replicated`) can be supplied via the `category` parameter. Additional |
||
| 267 | +11 |
- #' time = stop,+ #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults |
||
| 268 | +12 |
- #' status = event,+ #' to `USUBJID`), a variable to indicate unique subject identifiers, `param` (defaults to `PARAM`), a |
||
| 269 | +13 |
- #' armcd = as.factor(rx),+ #' variable to indicate parameter values, and `direction` (defaults to `abn_dir`), a variable to indicate |
||
| 270 | +14 |
- #' covar1 = as.factor(enum),+ #' abnormality directions. |
||
| 271 | +15 |
- #' covar2 = factor(+ #' |
||
| 272 | +16 |
- #' sample(as.factor(enum)),+ #' For each combination of `param` and `direction` levels, marked lab abnormality counts are calculated |
||
| 273 | +17 |
- #' levels = 1:4, labels = c("F", "F", "M", "M")
+ #' as follows: |
||
| 274 | +18 |
- #' )+ #' * `Single, not last` & `Last or replicated`: The number of patients with `Single, not last` |
||
| 275 | +19 |
- #' )+ #' and `Last or replicated` values, respectively. |
||
| 276 | +20 |
- #' )+ #' * `Any`: The number of patients with either single or replicated marked abnormalities. |
||
| 277 | +21 |
- #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
+ #' |
||
| 278 | +22 |
- #' formatters::var_labels(dta_bladder)[names(labels)] <- labels+ #' Fractions are calculated by dividing the above counts by the number of patients with at least one |
||
| 279 | +23 |
- #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ #' valid measurement recorded during the analysis. |
||
| 280 | +24 |
#' |
||
| 281 | +25 |
- #' plot(+ #' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create two |
||
| 282 | +26 |
- #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder),+ #' row splits, one on variable `param` and one on variable `direction`. |
||
| 283 | +27 |
- #' lty = 2:4,+ #' |
||
| 284 | +28 |
- #' xlab = "Months",+ #' @inheritParams argument_convention |
||
| 285 | +29 |
- #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
+ #' @param category (`list`)\cr a list with different marked category names for single |
||
| 286 | +30 |
- #' )+ #' and last or replicated. |
||
| 287 | +31 |
- #'+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal_by_marked")`
|
||
| 288 | +32 |
- #' @name fit_coxreg+ #' to see available statistics for this function. |
||
| 289 | +33 |
- NULL+ #' |
||
| 290 | +34 |
-
+ #' @note `Single, not last` and `Last or replicated` levels are mutually exclusive. If a patient has |
||
| 291 | +35 |
- #' @describeIn fit_coxreg Fit a series of univariate Cox regression models given the inputs.+ #' abnormalities that meet both the `Single, not last` and `Last or replicated` criteria, then the |
||
| 292 | +36 |
- #'+ #' patient will be counted only under the `Last or replicated` category. |
||
| 293 | +37 |
- #' @return+ #' |
||
| 294 | +38 |
- #' * `fit_coxreg_univar()` returns a `coxreg.univar` class object which is a named `list`+ #' @name abnormal_by_marked |
||
| 295 | +39 |
- #' with 5 elements:+ #' @order 1 |
||
| 296 | +40 |
- #' * `mod`: Cox regression models fitted by [survival::coxph()].+ NULL |
||
| 297 | +41 |
- #' * `data`: The original data frame input.+ |
||
| 298 | +42 |
- #' * `control`: The original control input.+ #' @describeIn abnormal_by_marked Statistics function for patients with marked lab abnormalities. |
||
| 299 | +43 |
- #' * `vars`: The variables used in the model.+ #' |
||
| 300 | +44 |
- #' * `at`: Value of the covariate at which the effect should be estimated.+ #' @return |
||
| 301 | +45 |
- #'+ #' * `s_count_abnormal_by_marked()` returns statistic `count_fraction` with `Single, not last`, |
||
| 302 | +46 |
- #' @note When using `fit_coxreg_univar` there should be two study arms.+ #' `Last or replicated`, and `Any` results. |
||
| 303 | +47 |
#' |
||
| 304 | +48 |
- #' @examples+ #' @keywords internal |
||
| 305 | +49 |
- #' # fit_coxreg_univar+ s_count_abnormal_by_marked <- function(df, |
||
| 306 | +50 |
- #'+ .var = "AVALCAT1", |
||
| 307 | +51 |
- #' ## Cox regression: arm + 1 covariate.+ .spl_context, |
||
| 308 | +52 |
- #' mod1 <- fit_coxreg_univar(+ category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
|
||
| 309 | +53 |
- #' variables = list(+ variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir")) {
|
||
| 310 | -+ | |||
| 54 | +3x |
- #' time = "time", event = "status", arm = "armcd",+ checkmate::assert_string(.var) |
||
| 311 | -+ | |||
| 55 | +3x |
- #' covariates = "covar1"+ checkmate::assert_list(variables) |
||
| 312 | -+ | |||
| 56 | +3x |
- #' ),+ checkmate::assert_list(category) |
||
| 313 | -+ | |||
| 57 | +3x |
- #' data = dta_bladder,+ checkmate::assert_subset(names(category), c("single", "last_replicated"))
|
||
| 314 | -+ | |||
| 58 | +3x |
- #' control = control_coxreg(conf_level = 0.91)+ checkmate::assert_subset(names(variables), c("id", "param", "direction"))
|
||
| 315 | -+ | |||
| 59 | +3x |
- #' )+ checkmate::assert_vector(unique(df[[variables$direction]]), max.len = 1) |
||
| 316 | +60 |
- #'+ |
||
| 317 | -+ | |||
| 61 | +2x |
- #' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates.+ assert_df_with_variables(df, c(aval = .var, variables)) |
||
| 318 | -+ | |||
| 62 | +2x |
- #' mod2 <- fit_coxreg_univar(+ checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
|
||
| 319 | -+ | |||
| 63 | +2x |
- #' variables = list(+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
||
| 320 | +64 |
- #' time = "time", event = "status", arm = "armcd",+ |
||
| 321 | +65 |
- #' covariates = c("covar1", "covar2")
+
|
||
| 322 | -+ | |||
| 66 | +2x |
- #' ),+ first_row <- .spl_context[.spl_context$split == variables[["param"]], ] |
||
| 323 | +67 |
- #' data = dta_bladder,+ # Patients in the denominator have at least one post-baseline visit. |
||
| 324 | -+ | |||
| 68 | +2x |
- #' control = control_coxreg(conf_level = 0.91, interaction = TRUE)+ subj <- first_row$full_parent_df[[1]][[variables[["id"]]]] |
||
| 325 | -+ | |||
| 69 | +2x |
- #' )+ subj_cur_col <- subj[first_row$cur_col_subset[[1]]] |
||
| 326 | +70 |
- #'+ # Some subjects may have a record for high and low directions but |
||
| 327 | +71 |
- #' ## Cox regression: arm + 1 covariate, stratified analysis.+ # should be counted only once. |
||
| 328 | -+ | |||
| 72 | +2x |
- #' mod3 <- fit_coxreg_univar(+ denom <- length(unique(subj_cur_col)) |
||
| 329 | +73 |
- #' variables = list(+ |
||
| 330 | -+ | |||
| 74 | +2x |
- #' time = "time", event = "status", arm = "armcd", strata = "covar2",+ if (denom != 0) {
|
||
| 331 | -+ | |||
| 75 | +2x |
- #' covariates = c("covar1")
+ subjects_last_replicated <- unique( |
||
| 332 | -+ | |||
| 76 | +2x |
- #' ),+ df[df[[.var]] %in% category[["last_replicated"]], variables$id, drop = TRUE] |
||
| 333 | +77 |
- #' data = dta_bladder,+ ) |
||
| 334 | -+ | |||
| 78 | +2x |
- #' control = control_coxreg(conf_level = 0.91)+ subjects_single <- unique( |
||
| 335 | -+ | |||
| 79 | +2x |
- #' )+ df[df[[.var]] %in% category[["single"]], variables$id, drop = TRUE] |
||
| 336 | +80 |
- #'+ ) |
||
| 337 | +81 |
- #' ## Cox regression: no arm, only covariates.+ # Subjects who have both single and last/replicated abnormalities are counted in only the last/replicated group.+ |
+ ||
| 82 | +2x | +
+ subjects_single <- setdiff(subjects_single, subjects_last_replicated)+ |
+ ||
| 83 | +2x | +
+ n_single <- length(subjects_single)+ |
+ ||
| 84 | +2x | +
+ n_last_replicated <- length(subjects_last_replicated)+ |
+ ||
| 85 | +2x | +
+ n_any <- n_single + n_last_replicated+ |
+ ||
| 86 | +2x | +
+ result <- list(count_fraction = list(+ |
+ ||
| 87 | +2x | +
+ "Single, not last" = c(n_single, n_single / denom),+ |
+ ||
| 88 | +2x | +
+ "Last or replicated" = c(n_last_replicated, n_last_replicated / denom),+ |
+ ||
| 89 | +2x | +
+ "Any Abnormality" = c(n_any, n_any / denom) |
||
| 338 | +90 |
- #' mod4 <- fit_coxreg_univar(+ )) |
||
| 339 | +91 |
- #' variables = list(+ } else {
+ |
+ ||
| 92 | +! | +
+ result <- list(count_fraction = list(+ |
+ ||
| 93 | +! | +
+ "Single, not last" = c(0, 0),+ |
+ ||
| 94 | +! | +
+ "Last or replicated" = c(0, 0),+ |
+ ||
| 95 | +! | +
+ "Any Abnormality" = c(0, 0) |
||
| 340 | +96 |
- #' time = "time", event = "status",+ )) |
||
| 341 | +97 |
- #' covariates = c("covar1", "covar2")
+ } |
||
| 342 | +98 |
- #' ),+ + |
+ ||
| 99 | +2x | +
+ result |
||
| 343 | +100 |
- #' data = dta_bladder+ } |
||
| 344 | +101 |
- #' )+ |
||
| 345 | +102 |
- #'+ #' @describeIn abnormal_by_marked Formatted analysis function which is used as `afun` |
||
| 346 | +103 |
- #' @export+ #' in `count_abnormal_by_marked()`. |
||
| 347 | +104 |
- fit_coxreg_univar <- function(variables,+ #' |
||
| 348 | +105 |
- data,+ #' @return |
||
| 349 | +106 |
- at = list(),+ #' * `a_count_abnormal_by_marked()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 350 | +107 |
- control = control_coxreg()) {
+ #' |
||
| 351 | -43x | +|||
| 108 | +
- checkmate::assert_list(variables, names = "named")+ #' @keywords internal |
- |||
| 352 | -43x | +|||
| 109 | +
- has_arm <- "arm" %in% names(variables)+ a_count_abnormal_by_marked <- make_afun( |
|||
| 353 | -43x | +|||
| 110 | +
- arm_name <- if (has_arm) "arm" else NULL+ s_count_abnormal_by_marked, |
|||
| 354 | +111 |
-
+ .formats = c(count_fraction = format_count_fraction) |
||
| 355 | -43x | +|||
| 112 | +
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ ) |
|||
| 356 | +113 | |||
| 357 | -43x | +|||
| 114 | +
- assert_df_with_variables(data, variables)+ #' @describeIn abnormal_by_marked Layout-creating function which can take statistics function arguments |
|||
| 358 | -43x | +|||
| 115 | +
- assert_list_of_variables(variables[c(arm_name, "event", "time")])+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 359 | +116 |
-
+ #' |
||
| 360 | -43x | +|||
| 117 | +
- if (!is.null(variables$strata)) {
+ #' @return |
|||
| 361 | -4x | +|||
| 118 | +
- checkmate::assert_disjunct(control$pval_method, "likelihood")+ #' * `count_abnormal_by_marked()` returns a layout object suitable for passing to further layouting functions, |
|||
| 362 | +119 |
- }+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 363 | -42x | +|||
| 120 | +
- if (has_arm) {
+ #' the statistics from `s_count_abnormal_by_marked()` to the table layout. |
|||
| 364 | -36x | +|||
| 121 | +
- assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ #' |
|||
| 365 | +122 |
- }+ #' @examples |
||
| 366 | -41x | +|||
| 123 | +
- vars <- unlist(variables[c(arm_name, "covariates", "strata")], use.names = FALSE)+ #' library(dplyr) |
|||
| 367 | -41x | +|||
| 124 | +
- for (i in vars) {
+ #' |
|||
| 368 | -94x | +|||
| 125 | +
- if (is.factor(data[[i]])) {
+ #' df <- data.frame( |
|||
| 369 | -82x | +|||
| 126 | +
- attr(data[[i]], "levels") <- levels(droplevels(data[[i]]))+ #' USUBJID = as.character(c(rep(1, 5), rep(2, 5), rep(1, 5), rep(2, 5))), |
|||
| 370 | +127 |
- }+ #' ARMCD = factor(c(rep("ARM A", 5), rep("ARM B", 5), rep("ARM A", 5), rep("ARM B", 5))),
|
||
| 371 | +128 |
- }+ #' ANRIND = factor(c( |
||
| 372 | -41x | +|||
| 129 | +
- forms <- h_coxreg_univar_formulas(variables, interaction = control$interaction)+ #' "NORMAL", "HIGH", "HIGH", "HIGH HIGH", "HIGH", |
|||
| 373 | -41x | +|||
| 130 | +
- mod <- lapply(+ #' "HIGH", "HIGH", "HIGH HIGH", "NORMAL", "HIGH HIGH", "NORMAL", "LOW", "LOW", "LOW LOW", "LOW", |
|||
| 374 | -41x | +|||
| 131 | +
- forms, function(x) {
+ #' "LOW", "LOW", "LOW LOW", "NORMAL", "LOW LOW" |
|||
| 375 | -90x | +|||
| 132 | +
- survival::coxph(formula = stats::as.formula(x), data = data, ties = control$ties)+ #' )), |
|||
| 376 | +133 |
- }+ #' ONTRTFL = rep(c("", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y"), 2),
|
||
| 377 | +134 |
- )+ #' PARAMCD = factor(c(rep("CRP", 10), rep("ALT", 10))),
|
||
| 378 | -41x | +|||
| 135 | +
- structure(+ #' AVALCAT1 = factor(rep(c("", "", "", "SINGLE", "REPLICATED", "", "", "LAST", "", "SINGLE"), 2)),
|
|||
| 379 | -41x | +|||
| 136 | +
- list(+ #' stringsAsFactors = FALSE |
|||
| 380 | -41x | +|||
| 137 | +
- mod = mod,+ #' ) |
|||
| 381 | -41x | +|||
| 138 | +
- data = data,+ #' |
|||
| 382 | -41x | +|||
| 139 | +
- control = control,+ #' df <- df %>% |
|||
| 383 | -41x | +|||
| 140 | +
- vars = variables,+ #' mutate(abn_dir = factor( |
|||
| 384 | -41x | +|||
| 141 | +
- at = at+ #' case_when( |
|||
| 385 | +142 |
- ),+ #' ANRIND == "LOW LOW" ~ "Low", |
||
| 386 | -41x | +|||
| 143 | +
- class = "coxreg.univar"+ #' ANRIND == "HIGH HIGH" ~ "High", |
|||
| 387 | +144 |
- )+ #' TRUE ~ "" |
||
| 388 | +145 |
- }+ #' ), |
||
| 389 | +146 |
-
+ #' levels = c("Low", "High")
|
||
| 390 | +147 |
- #' @describeIn fit_coxreg Fit a multivariate Cox regression model.+ #' )) |
||
| 391 | +148 |
#' |
||
| 392 | +149 |
- #' @return+ #' # Select only post-baseline records. |
||
| 393 | +150 |
- #' * `fit_coxreg_multivar()` returns a `coxreg.multivar` class object which is a named list+ #' df <- df %>% filter(ONTRTFL == "Y") |
||
| 394 | +151 |
- #' with 4 elements:+ #' df_crp <- df %>% |
||
| 395 | +152 |
- #' * `mod`: Cox regression model fitted by [survival::coxph()].+ #' filter(PARAMCD == "CRP") %>% |
||
| 396 | +153 |
- #' * `data`: The original data frame input.+ #' droplevels() |
||
| 397 | +154 |
- #' * `control`: The original control input.+ #' full_parent_df <- list(df_crp, "not_needed") |
||
| 398 | +155 |
- #' * `vars`: The variables used in the model.+ #' cur_col_subset <- list(rep(TRUE, nrow(df_crp)), "not_needed") |
||
| 399 | +156 |
- #'+ #' spl_context <- data.frame( |
||
| 400 | +157 |
- #' @examples+ #' split = c("PARAMCD", "GRADE_DIR"),
|
||
| 401 | +158 |
- #' # fit_coxreg_multivar+ #' full_parent_df = I(full_parent_df), |
||
| 402 | +159 |
- #'+ #' cur_col_subset = I(cur_col_subset) |
||
| 403 | +160 |
- #' ## Cox regression: multivariate Cox regression.+ #' ) |
||
| 404 | +161 |
- #' multivar_model <- fit_coxreg_multivar(+ #' |
||
| 405 | +162 |
- #' variables = list(+ #' map <- unique( |
||
| 406 | +163 |
- #' time = "time", event = "status", arm = "armcd",+ #' df[df$abn_dir %in% c("Low", "High") & df$AVALCAT1 != "", c("PARAMCD", "abn_dir")]
|
||
| 407 | +164 |
- #' covariates = c("covar1", "covar2")
+ #' ) %>% |
||
| 408 | +165 |
- #' ),+ #' lapply(as.character) %>% |
||
| 409 | +166 |
- #' data = dta_bladder+ #' as.data.frame() %>% |
||
| 410 | +167 |
- #' )+ #' arrange(PARAMCD, abn_dir) |
||
| 411 | +168 |
#' |
||
| 412 | +169 |
- #' # Example without treatment arm.+ #' basic_table() %>% |
||
| 413 | +170 |
- #' multivar_covs_model <- fit_coxreg_multivar(+ #' split_cols_by("ARMCD") %>%
|
||
| 414 | +171 |
- #' variables = list(+ #' split_rows_by("PARAMCD") %>%
|
||
| 415 | +172 |
- #' time = "time", event = "status",+ #' summarize_num_patients( |
||
| 416 | +173 |
- #' covariates = c("covar1", "covar2")
+ #' var = "USUBJID", |
||
| 417 | +174 |
- #' ),+ #' .stats = "unique_count" |
||
| 418 | +175 |
- #' data = dta_bladder+ #' ) %>% |
||
| 419 | +176 |
- #' )+ #' split_rows_by( |
||
| 420 | +177 |
- #'+ #' "abn_dir", |
||
| 421 | +178 |
- #' @export+ #' split_fun = trim_levels_to_map(map) |
||
| 422 | +179 |
- fit_coxreg_multivar <- function(variables,+ #' ) %>% |
||
| 423 | +180 |
- data,+ #' count_abnormal_by_marked( |
||
| 424 | +181 |
- control = control_coxreg()) {
+ #' var = "AVALCAT1", |
||
| 425 | -83x | +|||
| 182 | +
- checkmate::assert_list(variables, names = "named")+ #' variables = list( |
|||
| 426 | -83x | +|||
| 183 | +
- has_arm <- "arm" %in% names(variables)+ #' id = "USUBJID", |
|||
| 427 | -83x | +|||
| 184 | +
- arm_name <- if (has_arm) "arm" else NULL+ #' param = "PARAMCD", |
|||
| 428 | +185 |
-
+ #' direction = "abn_dir" |
||
| 429 | -83x | +|||
| 186 | +
- if (!is.null(variables$covariates)) {
+ #' ) |
|||
| 430 | -21x | +|||
| 187 | +
- checkmate::assert_character(variables$covariates)+ #' ) %>% |
|||
| 431 | +188 |
- }+ #' build_table(df = df) |
||
| 432 | +189 |
-
+ #' |
||
| 433 | -83x | +|||
| 190 | +
- checkmate::assert_false(control$interaction)+ #' basic_table() %>% |
|||
| 434 | -83x | +|||
| 191 | +
- assert_df_with_variables(data, variables)+ #' split_cols_by("ARMCD") %>%
|
|||
| 435 | -83x | +|||
| 192 | +
- assert_list_of_variables(variables[c(arm_name, "event", "time")])+ #' split_rows_by("PARAMCD") %>%
|
|||
| 436 | +193 |
-
+ #' summarize_num_patients( |
||
| 437 | -83x | +|||
| 194 | +
- if (!is.null(variables$strata)) {
+ #' var = "USUBJID", |
|||
| 438 | -3x | +|||
| 195 | +
- checkmate::assert_disjunct(control$pval_method, "likelihood")+ #' .stats = "unique_count" |
|||
| 439 | +196 |
- }+ #' ) %>% |
||
| 440 | +197 |
-
+ #' split_rows_by( |
||
| 441 | -82x | +|||
| 198 | +
- form <- h_coxreg_multivar_formula(variables)+ #' "abn_dir", |
|||
| 442 | -82x | +|||
| 199 | +
- mod <- survival::coxph(+ #' split_fun = trim_levels_in_group("abn_dir")
|
|||
| 443 | -82x | +|||
| 200 | +
- formula = stats::as.formula(form),+ #' ) %>% |
|||
| 444 | -82x | +|||
| 201 | +
- data = data,+ #' count_abnormal_by_marked( |
|||
| 445 | -82x | +|||
| 202 | +
- ties = control$ties+ #' var = "AVALCAT1", |
|||
| 446 | +203 |
- )+ #' variables = list( |
||
| 447 | -82x | +|||
| 204 | +
- structure(+ #' id = "USUBJID", |
|||
| 448 | -82x | +|||
| 205 | +
- list(+ #' param = "PARAMCD", |
|||
| 449 | -82x | +|||
| 206 | +
- mod = mod,+ #' direction = "abn_dir" |
|||
| 450 | -82x | +|||
| 207 | +
- data = data,+ #' ) |
|||
| 451 | -82x | +|||
| 208 | +
- control = control,+ #' ) %>% |
|||
| 452 | -82x | +|||
| 209 | +
- vars = variables+ #' build_table(df = df) |
|||
| 453 | +210 |
- ),+ #' |
||
| 454 | -82x | +|||
| 211 | +
- class = "coxreg.multivar"+ #' @export |
|||
| 455 | +212 |
- )+ #' @order 2 |
||
| 456 | +213 |
- }+ count_abnormal_by_marked <- function(lyt, |
||
| 457 | +214 |
-
+ var, |
||
| 458 | +215 |
- #' Muffled `car::Anova`+ category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
|
||
| 459 | +216 |
- #'+ variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir"), |
||
| 460 | +217 |
- #' Applied on survival models, [car::Anova()] signal that the `strata` terms is dropped from the model formula when+ na_str = default_na_str(), |
||
| 461 | +218 |
- #' present, this function deliberately muffles this message.+ nested = TRUE, |
||
| 462 | +219 |
- #'+ ..., |
||
| 463 | +220 |
- #' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()].+ .stats = NULL, |
||
| 464 | +221 |
- #' @param test_statistic (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`.+ .formats = NULL, |
||
| 465 | +222 |
- #'+ .labels = NULL, |
||
| 466 | +223 |
- #' @return The output of [car::Anova()], with convergence message muffled.+ .indent_mods = NULL) {
|
||
| 467 | -+ | |||
| 224 | +1x |
- #'+ checkmate::assert_string(var) |
||
| 468 | +225 |
- #' @keywords internal+ + |
+ ||
| 226 | +1x | +
+ extra_args <- list(category = category, variables = variables, ...) |
||
| 469 | +227 |
- muffled_car_anova <- function(mod, test_statistic) {
+
|
||
| 470 | -219x | +228 | +1x |
- tryCatch(+ afun <- make_afun( |
| 471 | -219x | +229 | +1x |
- withCallingHandlers(+ a_count_abnormal_by_marked, |
| 472 | -219x | +230 | +1x |
- expr = {
+ .stats = .stats, |
| 473 | -219x | +231 | +1x |
- car::Anova(+ .formats = .formats, |
| 474 | -219x | +232 | +1x |
- mod,+ .labels = .labels, |
| 475 | -219x | +233 | +1x |
- test.statistic = test_statistic,+ .indent_mods = .indent_mods, |
| 476 | -219x | +234 | +1x |
- type = "III"+ .ungroup_stats = "count_fraction" |
| 477 | +235 |
- )+ ) |
||
| 478 | +236 |
- },+ |
||
| 479 | -219x | +237 | +1x |
- message = function(m) invokeRestart("muffleMessage"),
+ lyt <- analyze( |
| 480 | -219x | +238 | +1x |
- error = function(e) {
+ lyt = lyt, |
| 481 | +239 | 1x |
- stop(paste(+ vars = var, |
|
| 482 | +240 | 1x |
- "the model seems to have convergence problems, please try to change",+ afun = afun, |
|
| 483 | +241 | 1x |
- "the configuration of covariates or strata variables, e.g.",+ na_str = na_str, |
|
| 484 | +242 | 1x |
- "- original error:", e+ nested = nested, |
|
| 485 | -+ | |||
| 243 | +1x |
- ))+ show_labels = "hidden", |
||
| 486 | -+ | |||
| 244 | +1x |
- }+ extra_args = extra_args |
||
| 487 | +245 |
- )+ ) |
||
| 488 | -+ | |||
| 246 | +1x |
- )+ lyt |
||
| 489 | +247 |
}@@ -88891,14 +89970,14 @@ tern coverage - 95.64% |
| 1 |
- #' Count number of patients+ #' Cox regression helper function for interactions |
|||
| 5 |
- #' The analyze function [analyze_num_patients()] creates a layout element to count total numbers of unique or+ #' Test and estimate the effect of a treatment in interaction with a covariate. |
|||
| 6 |
- #' non-unique patients. The primary analysis variable `vars` is used to uniquely identify patients.+ #' The effect is estimated as the HR of the tested treatment for a given level |
|||
| 7 |
- #'+ #' of the covariate, in comparison to the treatment control. |
|||
| 8 |
- #' The `count_by` variable can be used to identify non-unique patients such that the number of patients with a unique+ #' |
|||
| 9 |
- #' combination of values in `vars` and `count_by` will be returned instead as the `nonunique` statistic. The `required`+ #' @inheritParams argument_convention |
|||
| 10 |
- #' variable can be used to specify a variable required to be non-missing for the record to be included in the counts.+ #' @param x (`numeric` or `factor`)\cr the values of the covariate to be tested. |
|||
| 11 |
- #'+ #' @param effect (`string`)\cr the name of the effect to be tested and estimated. |
|||
| 12 |
- #' The summarize function [summarize_num_patients()] performs the same function as [analyze_num_patients()] except it+ #' @param covar (`string`)\cr the name of the covariate in the model. |
|||
| 13 |
- #' creates content rows, not data rows, to summarize the current table row/column context and operates on the level of+ #' @param mod (`coxph`)\cr the Cox regression model. |
|||
| 14 |
- #' the latest row split or the root of the table if no row splits have occurred.+ #' @param label (`string`)\cr the label to be returned as `term_label`. |
|||
| 15 |
- #'+ #' @param control (`list`)\cr a list of controls as returned by [control_coxreg()]. |
|||
| 16 |
- #' @inheritParams argument_convention+ #' @param ... see methods. |
|||
| 17 |
- #' @param required (`character` or `NULL`)\cr name of a variable that is required to be non-missing.+ #' |
|||
| 18 |
- #' @param count_by (`character` or `NULL`)\cr name of a variable to be combined with `vars` when counting+ #' @examples |
|||
| 19 |
- #' `nonunique` records.+ #' library(survival) |
|||
| 20 |
- #' @param unique_count_suffix (`flag`)\cr whether the `"(n)"` suffix should be added to `unique_count` labels.+ #' |
|||
| 21 |
- #' Defaults to `TRUE`.+ #' set.seed(1, kind = "Mersenne-Twister") |
|||
| 22 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("summarize_num_patients")`
+ #' |
|||
| 23 |
- #' to see available statistics for this function.+ #' # Testing dataset [survival::bladder]. |
|||
| 24 |
- #'+ #' dta_bladder <- with( |
|||
| 25 |
- #' @name summarize_num_patients+ #' data = bladder[bladder$enum < 5, ], |
|||
| 26 |
- #' @order 1+ #' data.frame( |
|||
| 27 |
- NULL+ #' time = stop, |
|||
| 28 |
-
+ #' status = event, |
|||
| 29 |
- #' @describeIn summarize_num_patients Statistics function which counts the number of+ #' armcd = as.factor(rx), |
|||
| 30 |
- #' unique patients, the corresponding percentage taken with respect to the+ #' covar1 = as.factor(enum), |
|||
| 31 |
- #' total number of patients, and the number of non-unique patients.+ #' covar2 = factor( |
|||
| 32 |
- #'+ #' sample(as.factor(enum)), |
|||
| 33 |
- #' @param x (`character` or `factor`)\cr vector of patient IDs.+ #' levels = 1:4, |
|||
| 34 |
- #'+ #' labels = c("F", "F", "M", "M")
|
|||
| 35 |
- #' @return+ #' ) |
|||
| 36 |
- #' * `s_num_patients()` returns a named `list` of 3 statistics:+ #' ) |
|||
| 37 |
- #' * `unique`: Vector of counts and percentages.+ #' ) |
|||
| 38 |
- #' * `nonunique`: Vector of counts.+ #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
|
|||
| 39 |
- #' * `unique_count`: Counts.+ #' formatters::var_labels(dta_bladder)[names(labels)] <- labels |
|||
| 40 |
- #'+ #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
|||
| 41 |
- #' @examples+ #' |
|||
| 42 |
- #' # Use the statistics function to count number of unique and nonunique patients.+ #' plot( |
|||
| 43 |
- #' s_num_patients(x = as.character(c(1, 1, 1, 2, 4, NA)), labelstr = "", .N_col = 6L)+ #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder), |
|||
| 44 |
- #' s_num_patients(+ #' lty = 2:4, |
|||
| 45 |
- #' x = as.character(c(1, 1, 1, 2, 4, NA)),+ #' xlab = "Months", |
|||
| 46 |
- #' labelstr = "",+ #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
|
|||
| 47 |
- #' .N_col = 6L,+ #' ) |
|||
| 48 |
- #' count_by = c(1, 1, 2, 1, 1, 1)+ #' |
|||
| 49 |
- #' )+ #' @name cox_regression_inter |
|||
| 50 |
- #'+ NULL |
|||
| 51 |
- #' @export+ |
|||
| 52 |
- s_num_patients <- function(x, labelstr, .N_col, count_by = NULL, unique_count_suffix = TRUE) { # nolint
+ #' @describeIn cox_regression_inter S3 generic helper function to determine interaction effect. |
|||
| 53 |
-
+ #' |
|||
| 54 | -146x | +
- checkmate::assert_string(labelstr)+ #' @return |
||
| 55 | -146x | +
- checkmate::assert_count(.N_col)+ #' * `h_coxreg_inter_effect()` returns a `data.frame` of covariate interaction effects consisting of the following |
||
| 56 | -146x | +
- checkmate::assert_multi_class(x, classes = c("factor", "character"))
+ #' variables: `effect`, `term`, `term_label`, `level`, `n`, `hr`, `lcl`, `ucl`, `pval`, and `pval_inter`. |
||
| 57 | -146x | +
- checkmate::assert_flag(unique_count_suffix)+ #' |
||
| 58 |
-
+ #' @export |
|||
| 59 | -146x | +
- count1 <- n_available(unique(x))+ h_coxreg_inter_effect <- function(x, |
||
| 60 | -146x | +
- count2 <- n_available(x)+ effect, |
||
| 61 |
-
+ covar, |
|||
| 62 | -146x | +
- if (!is.null(count_by)) {
+ mod, |
||
| 63 | -16x | +
- checkmate::assert_vector(count_by, len = length(x))+ label, |
||
| 64 | -16x | +
- count2 <- n_available(unique(interaction(x, count_by)))+ control, |
||
| 65 |
- }+ ...) {
|
|||
| 66 | -+ | 29x |
-
+ UseMethod("h_coxreg_inter_effect", x)
|
|
| 67 | -146x | +
- out <- list(+ } |
||
| 68 | -146x | +
- unique = formatters::with_label(c(count1, ifelse(count1 == 0 && .N_col == 0, 0, count1 / .N_col)), labelstr),+ |
||
| 69 | -146x | +
- nonunique = formatters::with_label(count2, labelstr),+ #' @describeIn cox_regression_inter Method for `numeric` class. Estimates the interaction with a `numeric` covariate. |
||
| 70 | -146x | +
- unique_count = formatters::with_label(+ #' |
||
| 71 | -146x | +
- count1, ifelse(unique_count_suffix, paste0(labelstr, if (nzchar(labelstr)) " ", "(n)"), labelstr)+ #' @method h_coxreg_inter_effect numeric |
||
| 72 |
- )+ #' |
|||
| 73 |
- )+ #' @param at (`list`)\cr a list with items named after the covariate, every |
|||
| 74 |
-
+ #' item is a vector of levels at which the interaction should be estimated. |
|||
| 75 | -146x | +
- out+ #' |
||
| 76 |
- }+ #' @export |
|||
| 77 |
-
+ h_coxreg_inter_effect.numeric <- function(x, |
|||
| 78 |
- #' @describeIn summarize_num_patients Statistics function which counts the number of unique patients+ effect, |
|||
| 79 |
- #' in a column (variable), the corresponding percentage taken with respect to the total number of+ covar, |
|||
| 80 |
- #' patients, and the number of non-unique patients in the column.+ mod, |
|||
| 81 |
- #'+ label, |
|||
| 82 |
- #' @return+ control, |
|||
| 83 |
- #' * `s_num_patients_content()` returns the same values as `s_num_patients()`.+ at, |
|||
| 84 |
- #'+ ...) {
|
|||
| 85 | -+ | 7x |
- #' @examples+ betas <- stats::coef(mod) |
|
| 86 | -+ | 7x |
- #' # Count number of unique and non-unique patients.+ attrs <- attr(stats::terms(mod), "term.labels") |
|
| 87 | -+ | 7x |
- #'+ term_indices <- grep( |
|
| 88 | -+ | 7x |
- #' df <- data.frame(+ pattern = effect, |
|
| 89 | -+ | 7x |
- #' USUBJID = as.character(c(1, 2, 1, 4, NA)),+ x = attrs[!grepl("strata\\(", attrs)]
|
|
| 90 |
- #' EVENT = as.character(c(10, 15, 10, 17, 8))+ ) |
|||
| 91 | -+ | 7x |
- #' )+ checkmate::assert_vector(term_indices, len = 2) |
|
| 92 | -+ | 7x |
- #' s_num_patients_content(df, .N_col = 5, .var = "USUBJID")+ betas <- betas[term_indices] |
|
| 93 | -+ | 7x |
- #'+ betas_var <- diag(stats::vcov(mod))[term_indices] |
|
| 94 | -+ | 7x |
- #' df_by_event <- data.frame(+ betas_cov <- stats::vcov(mod)[term_indices[1], term_indices[2]] |
|
| 95 | -+ | 7x |
- #' USUBJID = as.character(c(1, 2, 1, 4, NA)),+ xval <- if (is.null(at[[covar]])) {
|
|
| 96 | -+ | 6x |
- #' EVENT = c(10, 15, 10, 17, 8)+ stats::median(x) |
|
| 97 |
- #' )+ } else {
|
|||
| 98 | -+ | 1x |
- #' s_num_patients_content(df_by_event, .N_col = 5, .var = "USUBJID", count_by = "EVENT")+ at[[covar]] |
|
| 99 |
- #'+ } |
|||
| 100 | -+ | 7x |
- #' @export+ effect_index <- !grepl(covar, names(betas)) |
|
| 101 | -+ | 7x |
- s_num_patients_content <- function(df,+ coef_hat <- betas[effect_index] + xval * betas[!effect_index] |
|
| 102 | -+ | 7x |
- labelstr = "",+ coef_se <- sqrt( |
|
| 103 | -+ | 7x |
- .N_col, # nolint+ betas_var[effect_index] + |
|
| 104 | -+ | 7x |
- .var,+ xval ^ 2 * betas_var[!effect_index] + # styler: off |
|
| 105 | -+ | 7x |
- required = NULL,+ 2 * xval * betas_cov |
|
| 106 |
- count_by = NULL,+ ) |
|||
| 107 | -+ | 7x |
- unique_count_suffix = TRUE) {
+ q_norm <- stats::qnorm((1 + control$conf_level) / 2) |
|
| 108 | -56x | +7x |
- checkmate::assert_string(.var)+ data.frame( |
|
| 109 | -56x | +7x |
- checkmate::assert_data_frame(df)+ effect = "Covariate:", |
|
| 110 | -56x | +7x |
- if (is.null(count_by)) {
+ term = rep(covar, length(xval)), |
|
| 111 | -53x | +7x |
- assert_df_with_variables(df, list(id = .var))+ term_label = paste0(" ", xval),
|
|
| 112 | -+ | 7x |
- } else {
+ level = as.character(xval), |
|
| 113 | -3x | +7x |
- assert_df_with_variables(df, list(id = .var, count_by = count_by))+ n = NA, |
|
| 114 | -+ | 7x |
- }+ hr = exp(coef_hat), |
|
| 115 | -56x | +7x |
- if (!is.null(required)) {
+ lcl = exp(coef_hat - q_norm * coef_se), |
|
| 116 | -! | +7x |
- checkmate::assert_string(required)+ ucl = exp(coef_hat + q_norm * coef_se), |
|
| 117 | -! | +7x |
- assert_df_with_variables(df, list(required = required))+ pval = NA, |
|
| 118 | -! | +7x |
- df <- df[!is.na(df[[required]]), , drop = FALSE]+ pval_inter = NA, |
|
| 119 | -+ | 7x |
- }+ stringsAsFactors = FALSE |
|
| 120 |
-
+ ) |
|||
| 121 | -56x | +
- x <- df[[.var]]+ } |
||
| 122 | -56x | +
- y <- if (is.null(count_by)) NULL else df[[count_by]]+ |
||
| 123 |
-
+ #' @describeIn cox_regression_inter Method for `factor` class. Estimate the interaction with a `factor` covariate. |
|||
| 124 | -56x | +
- s_num_patients(+ #' |
||
| 125 | -56x | +
- x = x,+ #' @method h_coxreg_inter_effect factor |
||
| 126 | -56x | +
- labelstr = labelstr,+ #' |
||
| 127 | -56x | +
- .N_col = .N_col,+ #' @param data (`data.frame`)\cr the data frame on which the model was fit. |
||
| 128 | -56x | +
- count_by = y,+ #' |
||
| 129 | -56x | +
- unique_count_suffix = unique_count_suffix+ #' @export |
||
| 130 |
- )+ h_coxreg_inter_effect.factor <- function(x, |
|||
| 131 |
- }+ effect, |
|||
| 132 |
-
+ covar, |
|||
| 133 |
- c_num_patients <- make_afun(+ mod, |
|||
| 134 |
- s_num_patients_content,+ label, |
|||
| 135 |
- .stats = c("unique", "nonunique", "unique_count"),
+ control, |
|||
| 136 |
- .formats = c(unique = format_count_fraction_fixed_dp, nonunique = "xx", unique_count = "xx")+ data, |
|||
| 137 |
- )+ ...) {
|
|||
| 138 | -+ | 17x |
-
+ lvl_given <- levels(x) |
|
| 139 | -+ | 17x |
- #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments+ y <- h_coxreg_inter_estimations( |
|
| 140 | -+ | 17x |
- #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ variable = effect, given = covar, |
|
| 141 | -+ | 17x |
- #'+ lvl_var = levels(data[[effect]]), |
|
| 142 | -+ | 17x |
- #' @return+ lvl_given = lvl_given, |
|
| 143 | -+ | 17x |
- #' * `summarize_num_patients()` returns a layout object suitable for passing to further layouting functions,+ mod = mod, |
|
| 144 | -+ | 17x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ conf_level = 0.95 |
|
| 145 | -+ | 17x |
- #' the statistics from `s_num_patients_content()` to the table layout.+ )[[1]] |
|
| 146 |
- #'+ |
|||
| 147 | -+ | 17x |
- #' @examples+ data.frame( |
|
| 148 | -+ | 17x |
- #' # summarize_num_patients+ effect = "Covariate:", |
|
| 149 | -+ | 17x |
- #' tbl <- basic_table() %>%+ term = rep(covar, nrow(y)), |
|
| 150 | -+ | 17x |
- #' split_cols_by("ARM") %>%
+ term_label = paste0(" ", lvl_given),
|
|
| 151 | -+ | 17x |
- #' split_rows_by("SEX") %>%
+ level = lvl_given, |
|
| 152 | -+ | 17x |
- #' summarize_num_patients("USUBJID", .stats = "unique_count") %>%
+ n = NA, |
|
| 153 | -+ | 17x |
- #' build_table(df)+ hr = y[, "hr"], |
|
| 154 | -+ | 17x |
- #'+ lcl = y[, "lcl"], |
|
| 155 | -+ | 17x |
- #' tbl+ ucl = y[, "ucl"], |
|
| 156 | -+ | 17x |
- #'+ pval = NA, |
|
| 157 | -+ | 17x |
- #' @export+ pval_inter = NA, |
|
| 158 | -+ | 17x |
- #' @order 3+ stringsAsFactors = FALSE |
|
| 159 |
- summarize_num_patients <- function(lyt,+ ) |
|||
| 160 |
- var,+ } |
|||
| 161 |
- required = NULL,+ |
|||
| 162 |
- count_by = NULL,+ #' @describeIn cox_regression_inter Method for `character` class. Estimate the interaction with a `character` covariate. |
|||
| 163 |
- unique_count_suffix = TRUE,+ #' This makes an automatic conversion to `factor` and then forwards to the method for factors. |
|||
| 164 |
- na_str = default_na_str(),+ #' |
|||
| 165 |
- .stats = NULL,+ #' @method h_coxreg_inter_effect character |
|||
| 166 |
- .formats = NULL,+ #' |
|||
| 167 |
- .labels = c(+ #' @note |
|||
| 168 |
- unique = "Number of patients with at least one event",+ #' * Automatic conversion of character to factor does not guarantee results can be generated correctly. It is |
|||
| 169 |
- nonunique = "Number of events"+ #' therefore better to always pre-process the dataset such that factors are manually created from character |
|||
| 170 |
- ),+ #' variables before passing the dataset to [rtables::build_table()]. |
|||
| 171 |
- .indent_mods = 0L,+ #' |
|||
| 172 |
- riskdiff = FALSE,+ #' @export |
|||
| 173 |
- ...) {
+ h_coxreg_inter_effect.character <- function(x, |
|||
| 174 | -16x | +
- checkmate::assert_flag(riskdiff)+ effect, |
||
| 175 |
-
+ covar, |
|||
| 176 | -5x | +
- if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
+ mod, |
||
| 177 | -8x | +
- if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats]+ label, |
||
| 178 |
-
+ control, |
|||
| 179 | -16x | +
- s_args <- list(required = required, count_by = count_by, unique_count_suffix = unique_count_suffix, ...)+ data, |
||
| 180 |
-
+ ...) {
|
|||
| 181 | -16x | +5x |
- cfun <- make_afun(+ y <- as.factor(x) |
|
| 182 | -16x | +
- c_num_patients,+ |
||
| 183 | -16x | +5x |
- .stats = .stats,+ h_coxreg_inter_effect( |
|
| 184 | -16x | +5x |
- .formats = .formats,+ x = y, |
|
| 185 | -16x | +5x |
- .labels = .labels+ effect = effect, |
|
| 186 | -+ | 5x |
- )+ covar = covar, |
|
| 187 | -+ | 5x |
-
+ mod = mod, |
|
| 188 | -16x | +5x |
- extra_args <- if (isFALSE(riskdiff)) {
+ label = label, |
|
| 189 | -14x | +5x |
- s_args+ control = control, |
|
| 190 | -+ | 5x |
- } else {
+ data = data, |
|
| 191 | -2x | +
- list(+ ... |
||
| 192 | -2x | +
- afun = list("s_num_patients_content" = cfun),
+ ) |
||
| 193 | -2x | +
- .stats = .stats,+ } |
||
| 194 | -2x | +
- .indent_mods = .indent_mods,+ |
||
| 195 | -2x | +
- s_args = s_args+ #' @describeIn cox_regression_inter A higher level function to get |
||
| 196 |
- )+ #' the results of the interaction test and the estimated values. |
|||
| 197 |
- }+ #' |
|||
| 198 |
-
+ #' @return |
|||
| 199 | -16x | +
- summarize_row_groups(+ #' * `h_coxreg_extract_interaction()` returns the result of an interaction test and the estimated values. If |
||
| 200 | -16x | +
- lyt = lyt,+ #' no interaction, [h_coxreg_univar_extract()] is applied instead. |
||
| 201 | -16x | +
- var = var,+ #' |
||
| 202 | -16x | +
- cfun = ifelse(isFALSE(riskdiff), cfun, afun_riskdiff),+ #' @examples |
||
| 203 | -16x | +
- na_str = na_str,+ #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder) |
||
| 204 | -16x | +
- extra_args = extra_args,+ #' h_coxreg_extract_interaction( |
||
| 205 | -16x | +
- indent_mod = .indent_mods+ #' mod = mod, effect = "armcd", covar = "covar1", data = dta_bladder, |
||
| 206 |
- )+ #' control = control_coxreg() |
|||
| 207 |
- }+ #' ) |
|||
| 208 |
-
+ #' |
|||
| 209 |
- #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments+ #' @export |
|||
| 210 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ h_coxreg_extract_interaction <- function(effect, |
|||
| 211 |
- #'+ covar, |
|||
| 212 |
- #' @return+ mod, |
|||
| 213 |
- #' * `analyze_num_patients()` returns a layout object suitable for passing to further layouting functions,+ data, |
|||
| 214 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ at, |
|||
| 215 |
- #' the statistics from `s_num_patients_content()` to the table layout.+ control) {
|
|||
| 216 | -+ | 31x |
- #'+ if (!any(attr(stats::terms(mod), "order") == 2)) {
|
|
| 217 | -+ | 12x |
- #' @details In general, functions that starts with `analyze*` are expected to+ y <- h_coxreg_univar_extract( |
|
| 218 | -+ | 12x |
- #' work like [rtables::analyze()], while functions that starts with `summarize*`+ effect = effect, covar = covar, mod = mod, data = data, control = control |
|
| 219 |
- #' are based upon [rtables::summarize_row_groups()]. The latter provides a+ ) |
|||
| 220 | -+ | 12x |
- #' value for each dividing split in the row and column space, but, being it+ y$pval_inter <- NA |
|
| 221 | -+ | 12x |
- #' bound to the fundamental splits, it is repeated by design in every page+ y |
|
| 222 |
- #' when pagination is involved.+ } else {
|
|||
| 223 | -+ | 19x |
- #'+ test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method] |
|
| 224 |
- #' @note As opposed to [summarize_num_patients()], this function does not repeat the produced rows.+ |
|||
| 225 |
- #'+ # Test the main treatment effect. |
|||
| 226 | -+ | 19x |
- #' @examples+ mod_aov <- muffled_car_anova(mod, test_statistic) |
|
| 227 | -+ | 19x |
- #' df <- data.frame(+ sum_anova <- broom::tidy(mod_aov) |
|
| 228 | -+ | 19x |
- #' USUBJID = as.character(c(1, 2, 1, 4, NA, 6, 6, 8, 9)),+ pval <- sum_anova[sum_anova$term == effect, ][["p.value"]] |
|
| 229 |
- #' ARM = c("A", "A", "A", "A", "A", "B", "B", "B", "B"),
+
|
|||
| 230 |
- #' AGE = c(10, 15, 10, 17, 8, 11, 11, 19, 17),+ # Test the interaction effect. |
|||
| 231 | -+ | 19x |
- #' SEX = c("M", "M", "M", "F", "F", "F", "M", "F", "M")
+ pval_inter <- sum_anova[grep(":", sum_anova$term), ][["p.value"]]
|
|
| 232 | -+ | 19x |
- #' )+ covar_test <- data.frame( |
|
| 233 | -+ | 19x |
- #'+ effect = "Covariate:", |
|
| 234 | -+ | 19x |
- #' # analyze_num_patients+ term = covar, |
|
| 235 | -+ | 19x |
- #' tbl <- basic_table() %>%+ term_label = unname(labels_or_names(data[covar])), |
|
| 236 | -+ | 19x |
- #' split_cols_by("ARM") %>%
+ level = "", |
|
| 237 | -+ | 19x |
- #' add_colcounts() %>%+ n = mod$n, hr = NA, lcl = NA, ucl = NA, pval = pval, |
|
| 238 | -+ | 19x |
- #' analyze_num_patients("USUBJID", .stats = c("unique")) %>%
+ pval_inter = pval_inter, |
|
| 239 | -+ | 19x |
- #' build_table(df)+ stringsAsFactors = FALSE |
|
| 240 | - |
- #'- |
- ||
| 241 | -- |
- #' tbl- |
- ||
| 242 | -- |
- #'- |
- ||
| 243 | -- |
- #' @export- |
- ||
| 244 | -- |
- #' @order 2- |
- ||
| 245 | -- |
- analyze_num_patients <- function(lyt,- |
- ||
| 246 | -- |
- vars,- |
- ||
| 247 | -- |
- required = NULL,- |
- ||
| 248 | -- |
- count_by = NULL,- |
- ||
| 249 | -- |
- unique_count_suffix = TRUE,- |
- ||
| 250 | -- |
- na_str = default_na_str(),- |
- ||
| 251 | -- |
- nested = TRUE,- |
- ||
| 252 | -- |
- .stats = NULL,- |
- ||
| 253 | -- |
- .formats = NULL,- |
- ||
| 254 | -- |
- .labels = c(- |
- ||
| 255 | -- |
- unique = "Number of patients with at least one event",- |
- ||
| 256 | -- |
- nonunique = "Number of events"- |
- ||
| 257 | -- |
- ),- |
- ||
| 258 | -- |
- show_labels = c("default", "visible", "hidden"),
- |
- ||
| 259 | -- |
- .indent_mods = 0L,- |
- ||
| 260 | -- |
- riskdiff = FALSE,- |
- ||
| 261 | -- |
- ...) {
- |
- ||
| 262 | -4x | -
- checkmate::assert_flag(riskdiff)- |
- ||
| 263 | -- | - - | -||
| 264 | -1x | -
- if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
- |
- ||
| 265 | -! | -
- if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats]- |
- ||
| 266 | -- | - - | -||
| 267 | -4x | -
- s_args <- list(required = required, count_by = count_by, unique_count_suffix = unique_count_suffix, ...)- |
- ||
| 268 | -- | - - | -||
| 269 | -4x | -
- afun <- make_afun(- |
- ||
| 270 | -4x | -
- c_num_patients,- |
- ||
| 271 | -4x | -
- .stats = .stats,- |
- ||
| 272 | -4x | -
- .formats = .formats,- |
- ||
| 273 | -4x | -
- .labels = .labels- |
- ||
| 274 | -- |
- )- |
- ||
| 275 | -- | - - | -||
| 276 | -4x | -
- extra_args <- if (isFALSE(riskdiff)) {
- |
- ||
| 277 | -2x | -
- s_args- |
- ||
| 278 | -- |
- } else {
- |
- ||
| 279 | -2x | -
- list(- |
- ||
| 280 | -2x | -
- afun = list("s_num_patients_content" = afun),
- |
- ||
| 281 | -2x | -
- .stats = .stats,- |
- ||
| 282 | -2x | -
- .indent_mods = .indent_mods,- |
- ||
| 283 | -2x | -
- s_args = s_args- |
- ||
| 284 | -
) |
|||
| 285 | -- |
- }- |
- ||
| 286 | +241 |
-
+ # Estimate the interaction. |
||
| 287 | -4x | +242 | +19x |
- analyze(+ y <- h_coxreg_inter_effect( |
| 288 | -4x | +243 | +19x |
- afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ data[[covar]], |
| 289 | -4x | +244 | +19x |
- lyt = lyt,+ covar = covar, |
| 290 | -4x | +245 | +19x |
- vars = vars,+ effect = effect, |
| 291 | -4x | +246 | +19x |
- na_str = na_str,+ mod = mod, |
| 292 | -4x | +247 | +19x |
- nested = nested,+ label = unname(labels_or_names(data[covar])), |
| 293 | -4x | +248 | +19x |
- extra_args = extra_args,+ at = at, |
| 294 | -4x | +249 | +19x |
- show_labels = show_labels,+ control = control, |
| 295 | -4x | +250 | +19x |
- indent_mod = .indent_mods+ data = data |
| 296 | +251 |
- )+ )+ |
+ ||
| 252 | +19x | +
+ rbind(covar_test, y) |
||
| 297 | +253 |
- }+ } |
| 1 | +254 |
- #' Occurrence table pruning+ } |
||
| 2 | +255 |
- #'+ |
||
| 3 | +256 |
- #' @description `r lifecycle::badge("stable")`
+ #' @describeIn cox_regression_inter Hazard ratio estimation in interactions. |
||
| 4 | +257 |
#' |
||
| 5 | +258 |
- #' Family of constructor and condition functions to flexibly prune occurrence tables.+ #' @param variable,given (`string`)\cr the name of variables in interaction. We seek the estimation |
||
| 6 | +259 |
- #' The condition functions always return whether the row result is higher than the threshold.+ #' of the levels of `variable` given the levels of `given`. |
||
| 7 | +260 |
- #' Since they are of class [CombinationFunction()] they can be logically combined with other condition+ #' @param lvl_var,lvl_given (`character`)\cr corresponding levels as given by [levels()]. |
||
| 8 | +261 |
- #' functions.+ #' @param mod (`coxph`)\cr a fitted Cox regression model (see [survival::coxph()]). |
||
| 9 | +262 |
#' |
||
| 10 | +263 |
- #' @note Since most table specifications are worded positively, we name our constructor and condition+ #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A) |
||
| 11 | +264 |
- #' functions positively, too. However, note that the result of [keep_rows()] says what+ #' and Sex (F, M; reference Female) and the model being abbreviated: y ~ Arm + Sex + Arm:Sex. |
||
| 12 | +265 |
- #' should be pruned, to conform with the [rtables::prune_table()] interface.+ #' The cox regression estimates the coefficients along with a variance-covariance matrix for: |
||
| 13 | +266 |
#' |
||
| 14 | +267 |
- #' @examples+ #' - b1 (arm b), b2 (arm c) |
||
| 15 | +268 |
- #' \donttest{
+ #' - b3 (sex m) |
||
| 16 | +269 |
- #' tab <- basic_table() %>%+ #' - b4 (arm b: sex m), b5 (arm c: sex m) |
||
| 17 | +270 |
- #' split_cols_by("ARM") %>%
+ #' |
||
| 18 | +271 |
- #' split_rows_by("RACE") %>%
+ #' The estimation of the Hazard Ratio for arm C/sex M is given in reference |
||
| 19 | +272 |
- #' split_rows_by("STRATA1") %>%
+ #' to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5). |
||
| 20 | +273 |
- #' summarize_row_groups() %>%+ #' The interaction coefficient is deduced by b2 + b5 while the standard error |
||
| 21 | +274 |
- #' analyze_vars("COUNTRY", .stats = "count_fraction") %>%
+ #' is obtained as $sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$. |
||
| 22 | +275 |
- #' build_table(DM)+ #' |
||
| 23 | +276 |
- #' }+ #' @return |
||
| 24 | +277 |
- #'+ #' * `h_coxreg_inter_estimations()` returns a list of matrices (one per level of variable) with rows corresponding |
||
| 25 | +278 |
- #' @name prune_occurrences+ #' to the combinations of `variable` and `given`, with columns: |
||
| 26 | +279 |
- NULL+ #' * `coef_hat`: Estimation of the coefficient. |
||
| 27 | +280 |
-
+ #' * `coef_se`: Standard error of the estimation. |
||
| 28 | +281 |
- #' @describeIn prune_occurrences Constructor for creating pruning functions based on+ #' * `hr`: Hazard ratio. |
||
| 29 | +282 |
- #' a row condition function. This removes all analysis rows (`TableRow`) that should be+ #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio. |
||
| 30 | +283 |
- #' pruned, i.e., don't fulfill the row condition. It removes the sub-tree if there are no+ #' |
||
| 31 | +284 |
- #' children left.+ #' @examples |
||
| 32 | +285 |
- #'+ #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder) |
||
| 33 | +286 |
- #' @param row_condition (`CombinationFunction`)\cr condition function which works on individual+ #' result <- h_coxreg_inter_estimations( |
||
| 34 | +287 |
- #' analysis rows and flags whether these should be kept in the pruned table.+ #' variable = "armcd", given = "covar1", |
||
| 35 | +288 |
- #'+ #' lvl_var = levels(dta_bladder$armcd), |
||
| 36 | +289 |
- #' @return+ #' lvl_given = levels(dta_bladder$covar1), |
||
| 37 | +290 |
- #' * `keep_rows()` returns a pruning function that can be used with [rtables::prune_table()]+ #' mod = mod, conf_level = .95 |
||
| 38 | +291 |
- #' to prune an `rtables` table.+ #' ) |
||
| 39 | +292 |
- #'+ #' result |
||
| 40 | +293 |
- #' @examples+ #' |
||
| 41 | +294 |
- #' \donttest{
+ #' @export |
||
| 42 | +295 |
- #' # `keep_rows`+ h_coxreg_inter_estimations <- function(variable, |
||
| 43 | +296 |
- #' is_non_empty <- !CombinationFunction(all_zero_or_na)+ given, |
||
| 44 | +297 |
- #' prune_table(tab, keep_rows(is_non_empty))+ lvl_var, |
||
| 45 | +298 |
- #' }+ lvl_given, |
||
| 46 | +299 |
- #'+ mod, |
||
| 47 | +300 |
- #' @export+ conf_level = 0.95) {
|
||
| 48 | -+ | |||
| 301 | +18x |
- keep_rows <- function(row_condition) {
+ var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level |
||
| 49 | -6x | +302 | +18x |
- checkmate::assert_function(row_condition)+ giv_lvl <- paste0(given, lvl_given) |
| 50 | -6x | +303 | +18x |
- function(table_tree) {
+ design_mat <- expand.grid(variable = var_lvl, given = giv_lvl) |
| 51 | -2256x | +304 | +18x |
- if (inherits(table_tree, "TableRow")) {
+ design_mat <- design_mat[order(design_mat$variable, design_mat$given), ] |
| 52 | -1872x | +305 | +18x |
- return(!row_condition(table_tree))+ design_mat <- within( |
| 53 | -+ | |||
| 306 | +18x |
- }+ data = design_mat, |
||
| 54 | -384x | +307 | +18x |
- children <- tree_children(table_tree)+ expr = {
|
| 55 | -384x | +308 | +18x |
- identical(length(children), 0L)+ inter <- paste0(variable, ":", given) |
| 56 | -+ | |||
| 309 | +18x |
- }+ rev_inter <- paste0(given, ":", variable) |
||
| 57 | +310 |
- }+ } |
||
| 58 | +311 |
-
+ ) |
||
| 59 | -+ | |||
| 312 | +18x |
- #' @describeIn prune_occurrences Constructor for creating pruning functions based on+ split_by_variable <- design_mat$variable |
||
| 60 | -+ | |||
| 313 | +18x |
- #' a condition for the (first) content row in leaf tables. This removes all leaf tables where+ interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/") |
||
| 61 | +314 |
- #' the first content row does not fulfill the condition. It does not check individual rows.+ |
||
| 62 | -+ | |||
| 315 | +18x |
- #' It then proceeds recursively by removing the sub tree if there are no children left.+ mmat <- stats::model.matrix(mod)[1, ] |
||
| 63 | -+ | |||
| 316 | +18x |
- #'+ mmat[!mmat == 0] <- 0 |
||
| 64 | +317 |
- #' @param content_row_condition (`CombinationFunction`)\cr condition function which works on individual+ |
||
| 65 | -+ | |||
| 318 | +18x |
- #' first content rows of leaf tables and flags whether these leaf tables should be kept in the pruned table.+ design_mat <- apply( |
||
| 66 | -+ | |||
| 319 | +18x |
- #'+ X = design_mat, MARGIN = 1, FUN = function(x) {
|
||
| 67 | -+ | |||
| 320 | +52x |
- #' @return+ mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1 |
||
| 68 | -+ | |||
| 321 | +52x |
- #' * `keep_content_rows()` returns a pruning function that checks the condition on the first content+ mmat |
||
| 69 | +322 |
- #' row of leaf tables in the table.+ } |
||
| 70 | +323 |
- #'+ ) |
||
| 71 | -+ | |||
| 324 | +18x |
- #' @examples+ colnames(design_mat) <- interaction_names |
||
| 72 | +325 |
- #' # `keep_content_rows`+ |
||
| 73 | -+ | |||
| 326 | +18x |
- #' \donttest{
+ coef <- stats::coef(mod) |
||
| 74 | -+ | |||
| 327 | +18x |
- #' more_than_twenty <- has_count_in_cols(atleast = 20L, col_names = names(tab))+ vcov <- stats::vcov(mod) |
||
| 75 | -+ | |||
| 328 | +18x |
- #' prune_table(tab, keep_content_rows(more_than_twenty))+ betas <- as.matrix(coef) |
||
| 76 | -+ | |||
| 329 | +18x |
- #' }+ coef_hat <- t(design_mat) %*% betas |
||
| 77 | -+ | |||
| 330 | +18x |
- #'+ dimnames(coef_hat)[2] <- "coef" |
||
| 78 | -+ | |||
| 331 | +18x |
- #' @export+ coef_se <- apply( |
||
| 79 | -+ | |||
| 332 | +18x |
- keep_content_rows <- function(content_row_condition) {
+ design_mat, 2, |
||
| 80 | -1x | +333 | +18x |
- checkmate::assert_function(content_row_condition)+ function(x) {
|
| 81 | -1x | +334 | +52x |
- function(table_tree) {
+ vcov_el <- as.logical(x) |
| 82 | -166x | +335 | +52x |
- if (is_leaf_table(table_tree)) {
+ y <- vcov[vcov_el, vcov_el] |
| 83 | -24x | +336 | +52x |
- content_row <- h_content_first_row(table_tree)+ y <- sum(y) |
| 84 | -24x | +337 | +52x |
- return(!content_row_condition(content_row))+ y <- sqrt(y)+ |
+
| 338 | +52x | +
+ return(y) |
||
| 85 | +339 |
} |
||
| 86 | -142x | +|||
| 340 | +
- if (inherits(table_tree, "DataRow")) {
+ ) |
|||
| 87 | -120x | +341 | +18x |
- return(FALSE)+ q_norm <- stats::qnorm((1 + conf_level) / 2) |
| 88 | -+ | |||
| 342 | +18x |
- }+ y <- cbind(coef_hat, `se(coef)` = coef_se) |
||
| 89 | -22x | +343 | +18x |
- children <- tree_children(table_tree)+ y <- apply(y, 1, function(x) {
|
| 90 | -22x | +344 | +52x |
- identical(length(children), 0L)+ x["hr"] <- exp(x["coef"]) |
| 91 | -+ | |||
| 345 | +52x |
- }+ x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"]) |
||
| 92 | -+ | |||
| 346 | +52x |
- }+ x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"]) |
||
| 93 | -+ | |||
| 347 | +52x |
-
+ x |
||
| 94 | +348 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on total counts in the specified columns.+ }) |
||
| 95 | -+ | |||
| 349 | +18x |
- #'+ y <- t(y) |
||
| 96 | -+ | |||
| 350 | +18x |
- #' @param atleast (`numeric(1)`)\cr threshold which should be met in order to keep the row.+ y <- by(y, split_by_variable, identity) |
||
| 97 | -+ | |||
| 351 | +18x |
- #' @param ... arguments for row or column access, see [`rtables_access`]: either `col_names` (`character`) including+ y <- lapply(y, as.matrix) |
||
| 98 | -+ | |||
| 352 | +18x |
- #' the names of the columns which should be used, or alternatively `col_indices` (`integer`) giving the indices+ attr(y, "details") <- paste0( |
||
| 99 | -+ | |||
| 353 | +18x |
- #' directly instead.+ "Estimations of ", variable, |
||
| 100 | -+ | |||
| 354 | +18x |
- #'+ " hazard ratio given the level of ", given, " compared to ", |
||
| 101 | -+ | |||
| 355 | +18x |
- #' @return+ variable, " level ", lvl_var[1], "." |
||
| 102 | +356 |
- #' * `has_count_in_cols()` returns a condition function that sums the counts in the specified column.+ ) |
||
| 103 | -+ | |||
| 357 | +18x |
- #'+ y |
||
| 104 | +358 |
- #' @examples+ } |
| 105 | +1 |
- #' \donttest{
+ # summarize_glm_count ---------------------------------------------------------- |
||
| 106 | +2 |
- #' more_than_one <- has_count_in_cols(atleast = 1L, col_names = names(tab))+ #' Summarize Poisson negative binomial regression |
||
| 107 | +3 |
- #' prune_table(tab, keep_rows(more_than_one))+ #' |
||
| 108 | +4 |
- #' }+ #' @description `r lifecycle::badge("experimental")`
|
||
| 109 | +5 |
#' |
||
| 110 | +6 |
- #' @export+ #' Summarize results of a Poisson negative binomial regression. |
||
| 111 | +7 |
- has_count_in_cols <- function(atleast, ...) {
- |
- ||
| 112 | -6x | -
- checkmate::assert_count(atleast)- |
- ||
| 113 | -6x | -
- CombinationFunction(function(table_row) {
+ #' This can be used to analyze count and/or frequency data using a linear model. |
||
| 114 | -337x | +|||
| 8 | +
- row_counts <- h_row_counts(table_row, ...)+ #' It is specifically useful for analyzing count data (using the Poisson or Negative |
|||
| 115 | -337x | +|||
| 9 | +
- total_count <- sum(row_counts)+ #' Binomial distribution) that is result of a generalized linear model of one (e.g. arm) or more |
|||
| 116 | -337x | +|||
| 10 | +
- total_count >= atleast+ #' covariates. |
|||
| 117 | +11 |
- })+ #' |
||
| 118 | +12 |
- }+ #' @inheritParams h_glm_count |
||
| 119 | +13 |
-
+ #' @inheritParams argument_convention |
||
| 120 | +14 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on any of the counts in+ #' @param rate_mean_method (`character(1)`)\cr method used to estimate the mean odds ratio. Defaults to `emmeans`. |
||
| 121 | +15 |
- #' the specified columns satisfying a threshold.+ #' see details for more information. |
||
| 122 | +16 |
- #'+ #' @param scale (`numeric(1)`)\cr linear scaling factor for rate and confidence intervals. Defaults to `1`. |
||
| 123 | +17 |
- #' @param atleast (`numeric(1)`)\cr threshold which should be met in order to keep the row.+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("summarize_glm_count")`
|
||
| 124 | +18 |
- #'+ #' to see available statistics for this function. |
||
| 125 | +19 |
- #' @return+ #' |
||
| 126 | +20 |
- #' * `has_count_in_any_col()` returns a condition function that compares the counts in the+ #' @details |
||
| 127 | +21 |
- #' specified columns with the threshold.+ #' `summarize_glm_count()` uses `s_glm_count()` to calculate the statistics for the table. This |
||
| 128 | +22 |
- #'+ #' analysis function uses [h_glm_count()] to estimate the GLM with [stats::glm()] for Poisson and Quasi-Poisson |
||
| 129 | +23 |
- #' @examples+ #' distributions or [MASS::glm.nb()] for Negative Binomial distribution. All methods assume a |
||
| 130 | +24 |
- #' \donttest{
+ #' logarithmic link function. |
||
| 131 | +25 |
- #' # `has_count_in_any_col`+ #' |
||
| 132 | +26 |
- #' any_more_than_one <- has_count_in_any_col(atleast = 1L, col_names = names(tab))+ #' At this point, rates and confidence intervals are estimated from the model using |
||
| 133 | +27 |
- #' prune_table(tab, keep_rows(any_more_than_one))+ #' either [emmeans::emmeans()] when `rate_mean_method = "emmeans"` or [h_ppmeans()] |
||
| 134 | +28 |
- #' }+ #' when `rate_mean_method = "ppmeans"`. |
||
| 135 | +29 |
#' |
||
| 136 | +30 |
- #' @export+ #' If a reference group is specified while building the table with `split_cols_by(ref_group)`, |
||
| 137 | +31 |
- has_count_in_any_col <- function(atleast, ...) {
- |
- ||
| 138 | -3x | -
- checkmate::assert_count(atleast)+ #' no rate ratio or `p-value` are calculated. Otherwise, we use [emmeans::contrast()] to |
||
| 139 | -3x | +|||
| 32 | +
- CombinationFunction(function(table_row) {
+ #' calculate the rate ratio and `p-value` for the reference group. Values are always estimated |
|||
| 140 | -3x | +|||
| 33 | +
- row_counts <- h_row_counts(table_row, ...)+ #' with `method = "trt.vs.ctrl"` and `ref` equal to the first `arm` value. |
|||
| 141 | -3x | +|||
| 34 | +
- any(row_counts >= atleast)+ #' |
|||
| 142 | +35 |
- })+ #' @name summarize_glm_count |
||
| 143 | +36 |
- }+ NULL |
||
| 144 | +37 | |||
| 145 | +38 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on total fraction in+ #' @describeIn summarize_glm_count Layout-creating function which can take statistics function arguments |
||
| 146 | +39 |
- #' the specified columns.+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 147 | +40 |
#' |
||
| 148 | +41 |
#' @return |
||
| 149 | +42 |
- #' * `has_fraction_in_cols()` returns a condition function that sums the counts in the+ #' * `summarize_glm_count()` returns a layout object suitable for passing to further layouting functions, |
||
| 150 | +43 |
- #' specified column, and computes the fraction by dividing by the total column counts.+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 151 | +44 |
- #'+ #' the statistics from `s_glm_count()` to the table layout. |
||
| 152 | +45 |
- #' @examples+ #' |
||
| 153 | +46 |
- #' \donttest{
+ #' @examples |
||
| 154 | +47 |
- #' # `has_fraction_in_cols`+ #' library(dplyr) |
||
| 155 | +48 |
- #' more_than_five_percent <- has_fraction_in_cols(atleast = 0.05, col_names = names(tab))+ #' |
||
| 156 | +49 |
- #' prune_table(tab, keep_rows(more_than_five_percent))+ #' anl <- tern_ex_adtte %>% filter(PARAMCD == "TNE") |
||
| 157 | +50 |
- #' }+ #' anl$AVAL_f <- as.factor(anl$AVAL) |
||
| 158 | +51 |
#' |
||
| 159 | +52 |
- #' @export+ #' lyt <- basic_table() %>% |
||
| 160 | +53 |
- has_fraction_in_cols <- function(atleast, ...) {
- |
- ||
| 161 | -4x | -
- assert_proportion_value(atleast, include_boundaries = TRUE)- |
- ||
| 162 | -4x | -
- CombinationFunction(function(table_row) {
- |
- ||
| 163 | -306x | -
- row_counts <- h_row_counts(table_row, ...)- |
- ||
| 164 | -306x | -
- total_count <- sum(row_counts)- |
- ||
| 165 | -306x | -
- col_counts <- h_col_counts(table_row, ...)- |
- ||
| 166 | -306x | -
- total_n <- sum(col_counts)- |
- ||
| 167 | -306x | -
- total_percent <- total_count / total_n- |
- ||
| 168 | -306x | -
- total_percent >= atleast+ #' split_cols_by("ARM", ref_group = "B: Placebo") %>%
|
||
| 169 | +54 |
- })+ #' add_colcounts() %>% |
||
| 170 | +55 |
- }+ #' analyze_vars( |
||
| 171 | +56 |
-
+ #' "AVAL_f", |
||
| 172 | +57 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on any fraction in+ #' var_labels = "Number of exacerbations per patient", |
||
| 173 | +58 |
- #' the specified columns.+ #' .stats = c("count_fraction"),
|
||
| 174 | +59 |
- #'+ #' .formats = c("count_fraction" = "xx (xx.xx%)"),
|
||
| 175 | +60 |
- #' @return+ #' .labels = c("Number of exacerbations per patient")
|
||
| 176 | +61 |
- #' * `has_fraction_in_any_col()` returns a condition function that looks at the fractions+ #' ) %>% |
||
| 177 | +62 |
- #' in the specified columns and checks whether any of them fulfill the threshold.+ #' summarize_glm_count( |
||
| 178 | +63 |
- #'+ #' vars = "AVAL", |
||
| 179 | +64 |
- #' @examples+ #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = NULL), |
||
| 180 | +65 |
- #' \donttest{
+ #' conf_level = 0.95, |
||
| 181 | +66 |
- #' # `has_fraction_in_any_col`+ #' distribution = "poisson", |
||
| 182 | +67 |
- #' any_atleast_five_percent <- has_fraction_in_any_col(atleast = 0.05, col_names = names(tab))+ #' rate_mean_method = "emmeans", |
||
| 183 | +68 |
- #' prune_table(tab, keep_rows(any_atleast_five_percent))+ #' var_labels = "Adjusted (P) exacerbation rate (per year)", |
||
| 184 | +69 |
- #' }+ #' table_names = "adjP", |
||
| 185 | +70 |
- #'+ #' .stats = c("rate"),
|
||
| 186 | +71 |
- #' @export+ #' .labels = c(rate = "Rate") |
||
| 187 | +72 |
- 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 | +73 |
- })+ #' summarize_glm_count( |
||
| 193 | +74 |
- }+ #' vars = "AVAL", |
||
| 194 | +75 |
-
+ #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = c("REGION1")),
|
||
| 195 | +76 |
- #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference+ #' conf_level = 0.95, |
||
| 196 | +77 |
- #' between the fractions reported in each specified column.+ #' distribution = "quasipoisson", |
||
| 197 | +78 |
- #'+ #' rate_mean_method = "ppmeans", |
||
| 198 | +79 |
- #' @return+ #' var_labels = "Adjusted (QP) exacerbation rate (per year)", |
||
| 199 | +80 |
- #' * `has_fractions_difference()` returns a condition function that extracts the fractions of each+ #' table_names = "adjQP", |
||
| 200 | +81 |
- #' specified column, and computes the difference of the minimum and maximum.+ #' .stats = c("rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
|
||
| 201 | +82 |
- #'+ #' .labels = c( |
||
| 202 | +83 |
- #' @examples+ #' rate = "Rate", rate_ci = "Rate CI", rate_ratio = "Rate Ratio", |
||
| 203 | +84 |
- #' \donttest{
+ #' rate_ratio_ci = "Rate Ratio CI", pval = "p value" |
||
| 204 | +85 |
- #' # `has_fractions_difference`+ #' ) |
||
| 205 | +86 |
- #' more_than_five_percent_diff <- has_fractions_difference(atleast = 0.05, col_names = names(tab))+ #' ) |
||
| 206 | +87 |
- #' prune_table(tab, keep_rows(more_than_five_percent_diff))+ #' |
||
| 207 | +88 |
- #' }+ #' build_table(lyt = lyt, df = anl) |
||
| 208 | +89 |
#' |
||
| 209 | +90 |
#' @export |
||
| 210 | +91 |
- has_fractions_difference <- function(atleast, ...) {
+ summarize_glm_count <- function(lyt, |
||
| 211 | -4x | +|||
| 92 | +
- assert_proportion_value(atleast, include_boundaries = TRUE)+ vars, |
|||
| 212 | -4x | +|||
| 93 | +
- CombinationFunction(function(table_row) {
+ variables, |
|||
| 213 | -246x | +|||
| 94 | +
- fractions <- h_row_fractions(table_row, ...)+ distribution, |
|||
| 214 | -246x | +|||
| 95 | +
- difference <- diff(range(fractions))+ conf_level, |
|||
| 215 | -246x | +|||
| 96 | +
- difference >= atleast+ rate_mean_method = c("emmeans", "ppmeans")[1],
|
|||
| 216 | +97 |
- })+ weights = stats::weights, |
||
| 217 | +98 |
- }+ scale = 1, |
||
| 218 | +99 |
-
+ var_labels, |
||
| 219 | +100 |
- #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference+ na_str = default_na_str(), |
||
| 220 | +101 |
- #' between the counts reported in each specified column.+ nested = TRUE, |
||
| 221 | +102 |
- #'+ ..., |
||
| 222 | +103 |
- #' @return+ show_labels = "visible", |
||
| 223 | +104 |
- #' * `has_counts_difference()` returns a condition function that extracts the counts of each+ table_names = vars, |
||
| 224 | +105 |
- #' specified column, and computes the difference of the minimum and maximum.+ .stats = get_stats("summarize_glm_count"),
|
||
| 225 | +106 |
- #'+ .formats = NULL, |
||
| 226 | +107 |
- #' @examples+ .labels = NULL, |
||
| 227 | +108 |
- #' \donttest{
+ .indent_mods = c( |
||
| 228 | +109 |
- #' more_than_one_diff <- has_counts_difference(atleast = 1L, col_names = names(tab))+ "n" = 0L, |
||
| 229 | +110 |
- #' prune_table(tab, keep_rows(more_than_one_diff))+ "rate" = 0L, |
||
| 230 | +111 |
- #' }+ "rate_ci" = 1L, |
||
| 231 | +112 |
- #'+ "rate_ratio" = 0L, |
||
| 232 | +113 |
- #' @export+ "rate_ratio_ci" = 1L, |
||
| 233 | +114 |
- has_counts_difference <- function(atleast, ...) {
+ "pval" = 1L |
||
| 234 | -4x | +|||
| 115 | +
- checkmate::assert_count(atleast)+ )) {
|
|||
| 235 | -4x | +116 | +3x |
- CombinationFunction(function(table_row) {
+ checkmate::assert_choice(rate_mean_method, c("emmeans", "ppmeans"))
+ |
+
| 117 | ++ | + | ||
| 236 | -30x | +118 | +3x |
- counts <- h_row_counts(table_row, ...)+ extra_args <- list( |
| 237 | -30x | +119 | +3x |
- difference <- diff(range(counts))+ variables = variables, distribution = distribution, conf_level = conf_level, |
| 238 | -30x | +120 | +3x |
- difference >= atleast+ rate_mean_method = rate_mean_method, weights = weights, scale = scale, ... |
| 239 | +121 |
- })+ ) |
||
| 240 | +122 |
- }+ |
| 1 | +123 |
- #' Helper functions for tabulating survival duration by subgroup+ # Selecting parameters following the statistics |
||
| 2 | -+ | |||
| 124 | +3x |
- #'+ .formats <- get_formats_from_stats(.stats, formats_in = .formats) |
||
| 3 | -+ | |||
| 125 | +3x |
- #' @description `r lifecycle::badge("stable")`
+ .labels <- get_labels_from_stats(.stats, labels_in = .labels) |
||
| 4 | -+ | |||
| 126 | +3x |
- #'+ .indent_mods <- get_indents_from_stats(.stats, indents_in = .indent_mods) |
||
| 5 | +127 |
- #' Helper functions that tabulate in a data frame statistics such as median survival+ |
||
| 6 | -+ | |||
| 128 | +3x |
- #' time and hazard ratio for population subgroups.+ afun <- make_afun( |
||
| 7 | -+ | |||
| 129 | +3x |
- #'+ s_glm_count, |
||
| 8 | -+ | |||
| 130 | +3x |
- #' @inheritParams argument_convention+ .stats = .stats, |
||
| 9 | -+ | |||
| 131 | +3x |
- #' @inheritParams survival_coxph_pairwise+ .formats = .formats, |
||
| 10 | -+ | |||
| 132 | +3x |
- #' @inheritParams survival_duration_subgroups+ .labels = .labels, |
||
| 11 | -+ | |||
| 133 | +3x |
- #' @param arm (`factor`)\cr the treatment group variable.+ .indent_mods = .indent_mods, |
||
| 12 | -+ | |||
| 134 | +3x |
- #'+ .null_ref_cells = FALSE |
||
| 13 | +135 |
- #' @details Main functionality is to prepare data for use in a layout-creating function.+ ) |
||
| 14 | +136 |
- #'+ |
||
| 15 | -+ | |||
| 137 | +3x |
- #' @examples+ analyze( |
||
| 16 | -+ | |||
| 138 | +3x |
- #' library(dplyr)+ lyt, |
||
| 17 | -+ | |||
| 139 | +3x |
- #' library(forcats)+ vars, |
||
| 18 | -+ | |||
| 140 | +3x |
- #'+ var_labels = var_labels, |
||
| 19 | -+ | |||
| 141 | +3x |
- #' adtte <- tern_ex_adtte+ show_labels = show_labels, |
||
| 20 | -+ | |||
| 142 | +3x |
- #'+ table_names = table_names, |
||
| 21 | -+ | |||
| 143 | +3x |
- #' # Save variable labels before data processing steps.+ afun = afun, |
||
| 22 | -+ | |||
| 144 | +3x |
- #' adtte_labels <- formatters::var_labels(adtte)+ na_str = na_str, |
||
| 23 | -+ | |||
| 145 | +3x |
- #'+ nested = nested,+ |
+ ||
| 146 | +3x | +
+ extra_args = extra_args |
||
| 24 | +147 |
- #' adtte_f <- adtte %>%+ ) |
||
| 25 | +148 |
- #' filter(+ } |
||
| 26 | +149 |
- #' PARAMCD == "OS",+ |
||
| 27 | +150 |
- #' ARM %in% c("B: Placebo", "A: Drug X"),
+ #' @describeIn summarize_glm_count Statistics function that produces a named list of results |
||
| 28 | +151 |
- #' SEX %in% c("M", "F")
+ #' of the investigated Poisson model. |
||
| 29 | +152 |
- #' ) %>%+ #' |
||
| 30 | +153 |
- #' mutate(+ #' @return |
||
| 31 | +154 |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ #' * `s_glm_count()` returns a named `list` of 5 statistics: |
||
| 32 | +155 |
- #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),+ #' * `n`: Count of complete sample size for the group. |
||
| 33 | +156 |
- #' SEX = droplevels(SEX),+ #' * `rate`: Estimated event rate per follow-up time. |
||
| 34 | +157 |
- #' is_event = CNSR == 0+ #' * `rate_ci`: Confidence level for estimated rate per follow-up time. |
||
| 35 | +158 |
- #' )+ #' * `rate_ratio`: Ratio of event rates in each treatment arm to the reference arm. |
||
| 36 | +159 |
- #' labels <- c("ARM" = adtte_labels[["ARM"]], "SEX" = adtte_labels[["SEX"]], "is_event" = "Event Flag")
+ #' * `rate_ratio_ci`: Confidence level for the rate ratio. |
||
| 37 | +160 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ #' * `pval`: p-value. |
||
| 38 | +161 |
#' |
||
| 39 | +162 |
- #' @name h_survival_duration_subgroups+ #' @keywords internal |
||
| 40 | +163 |
- NULL+ s_glm_count <- function(df, |
||
| 41 | +164 |
-
+ .var, |
||
| 42 | +165 |
- #' @describeIn h_survival_duration_subgroups Helper to prepare a data frame of median survival times by arm.+ .df_row, |
||
| 43 | +166 |
- #'+ variables, |
||
| 44 | +167 |
- #' @return+ .ref_group, |
||
| 45 | +168 |
- #' * `h_survtime_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, and `median`.+ .in_ref_col, |
||
| 46 | +169 |
- #'+ distribution, |
||
| 47 | +170 |
- #' @examples+ conf_level, |
||
| 48 | +171 |
- #' # Extract median survival time for one group.+ rate_mean_method, |
||
| 49 | +172 |
- #' h_survtime_df(+ weights, |
||
| 50 | +173 |
- #' tte = adtte_f$AVAL,+ scale = 1) {
|
||
| 51 | -+ | |||
| 174 | +14x |
- #' is_event = adtte_f$is_event,+ arm <- variables$arm |
||
| 52 | +175 |
- #' arm = adtte_f$ARM+ |
||
| 53 | -+ | |||
| 176 | +14x |
- #' )+ y <- df[[.var]]+ |
+ ||
| 177 | +13x | +
+ smry_level <- as.character(unique(df[[arm]])) |
||
| 54 | +178 |
- #'+ |
||
| 55 | +179 |
- #' @export+ # ensure there is only 1 value+ |
+ ||
| 180 | +13x | +
+ checkmate::assert_scalar(smry_level) |
||
| 56 | +181 |
- h_survtime_df <- function(tte, is_event, arm) {
+
|
||
| 57 | -79x | +182 | +13x |
- checkmate::assert_numeric(tte)+ results <- h_glm_count( |
| 58 | -78x | +183 | +13x |
- checkmate::assert_logical(is_event, len = length(tte))+ .var = .var, |
| 59 | -78x | +184 | +13x |
- assert_valid_factor(arm, len = length(tte))+ .df_row = .df_row,+ |
+
| 185 | +13x | +
+ variables = variables,+ |
+ ||
| 186 | +13x | +
+ distribution = distribution,+ |
+ ||
| 187 | +13x | +
+ weights |
||
| 60 | +188 | ++ |
+ )+ |
+ |
| 189 | ||||
| 61 | -78x | +190 | +13x |
- df_tte <- data.frame(+ if (rate_mean_method == "emmeans") {
|
| 62 | -78x | +191 | +13x |
- tte = tte,+ emmeans_smry <- summary(results$emmeans_fit, level = conf_level) |
| 63 | -78x | +|||
| 192 | +! |
- is_event = is_event,+ } else if (rate_mean_method == "ppmeans") {
|
||
| 64 | -78x | +|||
| 193 | +! |
- stringsAsFactors = FALSE+ emmeans_smry <- h_ppmeans(results$glm_fit, .df_row, arm, conf_level) |
||
| 65 | +194 |
- )+ } |
||
| 66 | +195 | |||
| 196 | +13x | +
+ emmeans_smry_level <- emmeans_smry[emmeans_smry[[arm]] == smry_level, ]+ |
+ ||
| 67 | +197 |
- # Delete NAs+ |
||
| 68 | -78x | +|||
| 198 | +
- non_missing_rows <- stats::complete.cases(df_tte)+ # This happens if there is a reference col. No Ratio is calculated? |
|||
| 69 | -78x | +199 | +13x |
- df_tte <- df_tte[non_missing_rows, ]+ if (.in_ref_col) {
|
| 70 | -78x | +200 | +5x |
- arm <- arm[non_missing_rows]+ list( |
| 71 | -+ | |||
| 201 | +5x |
-
+ n = length(y[!is.na(y)]), |
||
| 72 | -78x | +202 | +5x |
- lst_tte <- split(df_tte, arm)+ rate = formatters::with_label( |
| 73 | -78x | +203 | +5x |
- lst_results <- Map(function(x, arm) {
+ ifelse(distribution == "negbin", emmeans_smry_level$response * scale, emmeans_smry_level$rate * scale), |
| 74 | -156x | +204 | +5x |
- if (nrow(x) > 0) {
+ "Adjusted Rate"+ |
+
| 205 | ++ |
+ ), |
||
| 75 | -152x | +206 | +5x |
- s_surv <- s_surv_time(x, .var = "tte", is_event = "is_event")+ rate_ci = formatters::with_label( |
| 76 | -152x | +207 | +5x |
- median_est <- unname(as.numeric(s_surv$median))+ c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale), |
| 77 | -152x | +208 | +5x |
- n_events <- sum(x$is_event)+ f_conf_level(conf_level) |
| 78 | +209 |
- } else {
+ ), |
||
| 79 | -4x | +210 | +5x |
- median_est <- NA+ rate_ratio = formatters::with_label(character(), "Adjusted Rate Ratio"), |
| 80 | -4x | +211 | +5x |
- n_events <- NA+ rate_ratio_ci = formatters::with_label(character(), f_conf_level(conf_level)),+ |
+
| 212 | +5x | +
+ pval = formatters::with_label(character(), "p-value") |
||
| 81 | +213 |
- }+ ) |
||
| 82 | +214 |
-
+ } else {
|
||
| 83 | -156x | +215 | +8x |
- data.frame(+ emmeans_contrasts <- emmeans::contrast( |
| 84 | -156x | +216 | +8x |
- arm = arm,+ results$emmeans_fit, |
| 85 | -156x | +217 | +8x |
- n = nrow(x),+ method = "trt.vs.ctrl", |
| 86 | -156x | +218 | +8x |
- n_events = n_events,+ ref = grep( |
| 87 | -156x | +219 | +8x |
- median = median_est,+ as.character(unique(.ref_group[[arm]])), |
| 88 | -156x | +220 | +8x |
- stringsAsFactors = FALSE+ as.data.frame(results$emmeans_fit)[[arm]] |
| 89 | +221 |
- )+ ) |
||
| 90 | -78x | +|||
| 222 | +
- }, lst_tte, names(lst_tte))+ ) |
|||
| 91 | +223 | |||
| 92 | -78x | +224 | +8x |
- df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE))+ contrasts_smry <- summary( |
| 93 | -78x | +225 | +8x |
- df$arm <- factor(df$arm, levels = levels(arm))+ emmeans_contrasts, |
| 94 | -78x | +226 | +8x |
- df+ infer = TRUE,+ |
+
| 227 | +8x | +
+ adjust = "none" |
||
| 95 | +228 |
- }+ ) |
||
| 96 | +229 | |||
| 97 | -+ | |||
| 230 | +8x |
- #' @describeIn h_survival_duration_subgroups Summarizes median survival times by arm and across subgroups+ smry_contrasts_level <- contrasts_smry[grepl(smry_level, contrasts_smry$contrast), ] |
||
| 98 | +231 |
- #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and+ |
||
| 99 | -+ | |||
| 232 | +8x |
- #' requires elements `tte`, `is_event`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies+ list( |
||
| 100 | -+ | |||
| 233 | +8x |
- #' groupings for `subgroups` variables.+ n = length(y[!is.na(y)]), |
||
| 101 | -+ | |||
| 234 | +8x |
- #'+ rate = formatters::with_label( |
||
| 102 | -+ | |||
| 235 | +8x |
- #' @return+ ifelse(distribution == "negbin", |
||
| 103 | -+ | |||
| 236 | +8x |
- #' * `h_survtime_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, `median`, `subgroup`,+ emmeans_smry_level$response * scale, |
||
| 104 | -+ | |||
| 237 | +8x |
- #' `var`, `var_label`, and `row_type`.+ emmeans_smry_level$rate * scale |
||
| 105 | +238 |
- #'+ ), |
||
| 106 | -+ | |||
| 239 | +8x |
- #' @examples+ "Adjusted Rate" |
||
| 107 | +240 |
- #' # Extract median survival time for multiple groups.+ ), |
||
| 108 | -+ | |||
| 241 | +8x |
- #' h_survtime_subgroups_df(+ rate_ci = formatters::with_label( |
||
| 109 | -+ | |||
| 242 | +8x |
- #' variables = list(+ c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale), |
||
| 110 | -+ | |||
| 243 | +8x |
- #' tte = "AVAL",+ f_conf_level(conf_level) |
||
| 111 | +244 |
- #' is_event = "is_event",+ ), |
||
| 112 | -+ | |||
| 245 | +8x |
- #' arm = "ARM",+ rate_ratio = formatters::with_label( |
||
| 113 | -+ | |||
| 246 | +8x |
- #' subgroups = c("SEX", "BMRKR2")
+ smry_contrasts_level$ratio, |
||
| 114 | -+ | |||
| 247 | +8x |
- #' ),+ "Adjusted Rate Ratio" |
||
| 115 | +248 |
- #' data = adtte_f+ ), |
||
| 116 | -+ | |||
| 249 | +8x |
- #' )+ rate_ratio_ci = formatters::with_label( |
||
| 117 | -+ | |||
| 250 | +8x |
- #'+ c(smry_contrasts_level$asymp.LCL, smry_contrasts_level$asymp.UCL), |
||
| 118 | -+ | |||
| 251 | +8x |
- #' # Define groupings for BMRKR2 levels.+ f_conf_level(conf_level) |
||
| 119 | +252 |
- #' h_survtime_subgroups_df(+ ), |
||
| 120 | -+ | |||
| 253 | +8x |
- #' variables = list(+ pval = formatters::with_label( |
||
| 121 | -+ | |||
| 254 | +8x |
- #' tte = "AVAL",+ smry_contrasts_level$p.value, |
||
| 122 | -+ | |||
| 255 | +8x |
- #' is_event = "is_event",+ "p-value" |
||
| 123 | +256 |
- #' arm = "ARM",+ ) |
||
| 124 | +257 |
- #' subgroups = c("SEX", "BMRKR2")
+ ) |
||
| 125 | +258 |
- #' ),+ } |
||
| 126 | +259 |
- #' data = adtte_f,+ } |
||
| 127 | +260 |
- #' groups_lists = list(+ # h_glm_count ------------------------------------------------------------------ |
||
| 128 | +261 |
- #' BMRKR2 = list(+ #' Helper functions for Poisson models |
||
| 129 | +262 |
- #' "low" = "LOW",+ #' |
||
| 130 | +263 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' @description `r lifecycle::badge("experimental")`
|
||
| 131 | +264 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ #' |
||
| 132 | +265 |
- #' )+ #' Helper functions that returns the results of [stats::glm()] when Poisson or Quasi-Poisson |
||
| 133 | +266 |
- #' )+ #' distributions are needed (see `family` parameter), or [MASS::glm.nb()] for Negative Binomial |
||
| 134 | +267 |
- #' )+ #' distributions. Link function for the GLM is `log`. |
||
| 135 | +268 |
#' |
||
| 136 | +269 |
- #' @export+ #' @inheritParams argument_convention |
||
| 137 | +270 |
- h_survtime_subgroups_df <- function(variables,+ #' |
||
| 138 | +271 |
- data,+ #' @seealso [summarize_glm_count] |
||
| 139 | +272 |
- groups_lists = list(),+ #' |
||
| 140 | +273 |
- label_all = "All Patients") {
- |
- ||
| 141 | -15x | -
- checkmate::assert_character(variables$tte)- |
- ||
| 142 | -15x | -
- checkmate::assert_character(variables$is_event)- |
- ||
| 143 | -15x | -
- checkmate::assert_character(variables$arm)- |
- ||
| 144 | -15x | -
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ #' @name h_glm_count |
||
| 145 | +274 | - - | -||
| 146 | -15x | -
- assert_df_with_variables(data, variables)+ NULL |
||
| 147 | +275 | |||
| 148 | -15x | +|||
| 276 | +
- checkmate::assert_string(label_all)+ #' @describeIn h_glm_count Helper function to return the results of the |
|||
| 149 | +277 |
-
+ #' selected model (Poisson, Quasi-Poisson, negative binomial). |
||
| 150 | +278 |
- # Add All Patients.+ #' |
||
| 151 | -15x | +|||
| 279 | +
- result_all <- h_survtime_df(data[[variables$tte]], data[[variables$is_event]], data[[variables$arm]])+ #' @param .df_row (`data.frame`)\cr dataset that includes all the variables that are called |
|||
| 152 | -15x | +|||
| 280 | +
- result_all$subgroup <- label_all+ #' in `.var` and `variables`. |
|||
| 153 | -15x | +|||
| 281 | +
- result_all$var <- "ALL"+ #' @param variables (named `list` of `string`)\cr list of additional analysis variables, with |
|||
| 154 | -15x | +|||
| 282 | +
- result_all$var_label <- label_all+ #' expected elements: |
|||
| 155 | -15x | +|||
| 283 | +
- result_all$row_type <- "content"+ #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple |
|||
| 156 | +284 |
-
+ #' groups will be summarized. Specifically, the first level of `arm` variable is taken as the |
||
| 157 | +285 |
- # Add Subgroups.+ #' reference group. |
||
| 158 | -15x | +|||
| 286 | +
- if (is.null(variables$subgroups)) {
+ #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as |
|||
| 159 | -3x | +|||
| 287 | +
- result_all+ #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`. |
|||
| 160 | +288 |
- } else {
+ #' * `offset` (`numeric`)\cr a numeric vector or scalar adding an offset. |
||
| 161 | -12x | +|||
| 289 | +
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ #' @param distribution (`character`)\cr a character value specifying the distribution |
|||
| 162 | -12x | +|||
| 290 | +
- l_result <- lapply(l_data, function(grp) {
+ #' used in the regression (Poisson, Quasi-Poisson, negative binomial). |
|||
| 163 | -60x | +|||
| 291 | +
- result <- h_survtime_df(grp$df[[variables$tte]], grp$df[[variables$is_event]], grp$df[[variables$arm]])+ #' @param weights (`character`)\cr a character vector specifying weights used |
|||
| 164 | -60x | +|||
| 292 | +
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ #' in averaging predictions. Number of weights must equal the number of levels included in the covariates. |
|||
| 165 | -60x | +|||
| 293 | +
- cbind(result, result_labels)+ #' Weights option passed to [emmeans::emmeans()]. |
|||
| 166 | +294 |
- })+ #' |
||
| 167 | -12x | +|||
| 295 | +
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ #' @return |
|||
| 168 | -12x | +|||
| 296 | +
- result_subgroups$row_type <- "analysis"+ #' * `h_glm_count()` returns the results of the selected model. |
|||
| 169 | -12x | +|||
| 297 | +
- rbind(+ #' |
|||
| 170 | -12x | +|||
| 298 | +
- result_all,+ #' @keywords internal |
|||
| 171 | -12x | +|||
| 299 | +
- result_subgroups+ h_glm_count <- function(.var, |
|||
| 172 | +300 |
- )+ .df_row, |
||
| 173 | +301 |
- }+ variables, |
||
| 174 | +302 |
- }+ distribution, |
||
| 175 | +303 |
-
+ weights) {
|
||
| 176 | -+ | |||
| 304 | +21x |
- #' @describeIn h_survival_duration_subgroups Helper to prepare a data frame with estimates of+ checkmate::assert_subset(distribution, c("poisson", "quasipoisson", "negbin"), empty.ok = FALSE)
|
||
| 177 | -+ | |||
| 305 | +19x |
- #' treatment hazard ratio.+ switch(distribution, |
||
| 178 | -+ | |||
| 306 | +13x |
- #'+ poisson = h_glm_poisson(.var, .df_row, variables, weights), |
||
| 179 | -+ | |||
| 307 | +1x |
- #' @param strata_data (`factor`, `data.frame`, or `NULL`)\cr required if stratified analysis is performed.+ quasipoisson = h_glm_quasipoisson(.var, .df_row, variables, weights), |
||
| 180 | -+ | |||
| 308 | +5x |
- #'+ negbin = h_glm_negbin(.var, .df_row, variables, weights) |
||
| 181 | +309 |
- #' @return+ ) |
||
| 182 | +310 |
- #' * `h_coxph_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`,+ } |
||
| 183 | +311 |
- #' `conf_level`, `pval` and `pval_label`.+ |
||
| 184 | +312 |
- #'+ #' @describeIn h_glm_count Helper function to return results of a Poisson model. |
||
| 185 | +313 |
- #' @examples+ #' |
||
| 186 | +314 |
- #' # Extract hazard ratio for one group.+ #' @return |
||
| 187 | +315 |
- #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM)+ #' * `h_glm_poisson()` returns the results of a Poisson model. |
||
| 188 | +316 |
#' |
||
| 189 | +317 |
- #' # Extract hazard ratio for one group with stratification factor.+ #' @keywords internal |
||
| 190 | +318 |
- #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM, strata_data = adtte_f$STRATA1)+ h_glm_poisson <- function(.var, |
||
| 191 | +319 |
- #'+ .df_row, |
||
| 192 | +320 |
- #' @export+ variables, |
||
| 193 | +321 |
- h_coxph_df <- function(tte, is_event, arm, strata_data = NULL, control = control_coxph()) {
+ weights) {
|
||
| 194 | -85x | +322 | +17x |
- checkmate::assert_numeric(tte)+ arm <- variables$arm |
| 195 | -85x | +323 | +17x |
- checkmate::assert_logical(is_event, len = length(tte))+ covariates <- variables$covariates |
| 196 | -85x | +324 | +17x |
- assert_valid_factor(arm, n.levels = 2, len = length(tte))+ offset <- .df_row[[variables$offset]] |
| 197 | +325 | |||
| 198 | -85x | +326 | +15x |
- df_tte <- data.frame(tte = tte, is_event = is_event)+ formula <- stats::as.formula(paste0( |
| 199 | -85x | +327 | +15x |
- strata_vars <- NULL+ .var, " ~ ", |
| 200 | +328 |
-
+ " + ", |
||
| 201 | -85x | +329 | +15x |
- if (!is.null(strata_data)) {
+ paste(covariates, collapse = " + "), |
| 202 | -5x | +|||
| 330 | +
- if (is.data.frame(strata_data)) {
+ " + ", |
|||
| 203 | -4x | +331 | +15x |
- strata_vars <- names(strata_data)+ arm |
| 204 | -4x | +|||
| 332 | +
- checkmate::assert_data_frame(strata_data, nrows = nrow(df_tte))+ )) |
|||
| 205 | -4x | +|||
| 333 | +
- assert_df_with_factors(strata_data, as.list(stats::setNames(strata_vars, strata_vars)))+ |
|||
| 206 | -+ | |||
| 334 | +15x |
- } else {
+ glm_fit <- stats::glm( |
||
| 207 | -1x | +335 | +15x |
- assert_valid_factor(strata_data, len = nrow(df_tte))+ formula = formula, |
| 208 | -1x | +336 | +15x |
- strata_vars <- "strata_data"+ offset = offset, |
| 209 | -+ | |||
| 337 | +15x |
- }+ data = .df_row, |
||
| 210 | -5x | +338 | +15x |
- df_tte[strata_vars] <- strata_data+ family = stats::poisson(link = "log") |
| 211 | +339 |
- }+ ) |
||
| 212 | +340 | |||
| 213 | -85x | +341 | +15x |
- l_df <- split(df_tte, arm)+ emmeans_fit <- emmeans::emmeans( |
| 214 | -+ | |||
| 342 | +15x |
-
+ glm_fit, |
||
| 215 | -85x | +343 | +15x |
- if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
+ specs = arm, |
| 216 | -+ | |||
| 344 | +15x |
- # Hazard ratio and CI.+ data = .df_row, |
||
| 217 | -79x | +345 | +15x |
- result <- s_coxph_pairwise(+ type = "response", |
| 218 | -79x | +346 | +15x |
- df = l_df[[2]],+ offset = 0, |
| 219 | -79x | +347 | +15x |
- .ref_group = l_df[[1]],+ weights = weights |
| 220 | -79x | +|||
| 348 | +
- .in_ref_col = FALSE,+ ) |
|||
| 221 | -79x | +|||
| 349 | +
- .var = "tte",+ |
|||
| 222 | -79x | +350 | +15x |
- is_event = "is_event",+ list( |
| 223 | -79x | +351 | +15x |
- strata = strata_vars,+ glm_fit = glm_fit, |
| 224 | -79x | +352 | +15x |
- control = control+ emmeans_fit = emmeans_fit |
| 225 | +353 |
- )+ ) |
||
| 226 | +354 | - - | -||
| 227 | -79x | -
- df <- data.frame(+ } |
||
| 228 | +355 |
- # Dummy column needed downstream to create a nested header.- |
- ||
| 229 | -79x | -
- arm = " ",+ |
||
| 230 | -79x | +|||
| 356 | +
- n_tot = unname(as.numeric(result$n_tot)),+ #' @describeIn h_glm_count Helper function to return results of a Quasi-Poisson model. |
|||
| 231 | -79x | +|||
| 357 | +
- n_tot_events = unname(as.numeric(result$n_tot_events)),+ #' |
|||
| 232 | -79x | +|||
| 358 | +
- hr = unname(as.numeric(result$hr)),+ #' @return |
|||
| 233 | -79x | +|||
| 359 | +
- lcl = unname(result$hr_ci[1]),+ #' * `h_glm_quasipoisson()` returns the results of a Quasi-Poisson model. |
|||
| 234 | -79x | +|||
| 360 | +
- ucl = unname(result$hr_ci[2]),+ #' |
|||
| 235 | -79x | +|||
| 361 | +
- conf_level = control[["conf_level"]],+ #' @keywords internal |
|||
| 236 | -79x | +|||
| 362 | +
- pval = as.numeric(result$pvalue),+ h_glm_quasipoisson <- function(.var, |
|||
| 237 | -79x | +|||
| 363 | +
- pval_label = obj_label(result$pvalue),+ .df_row, |
|||
| 238 | -79x | +|||
| 364 | +
- stringsAsFactors = FALSE+ variables, |
|||
| 239 | +365 |
- )+ weights) {
|
||
| 240 | -+ | |||
| 366 | +5x |
- } else if (+ arm <- variables$arm |
||
| 241 | -6x | +367 | +5x |
- (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) ||+ covariates <- variables$covariates |
| 242 | -6x | +368 | +5x |
- (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0)+ offset <- .df_row[[variables$offset]] |
| 243 | +369 |
- ) {
+
|
||
| 244 | -6x | +370 | +3x |
- df_tte_complete <- df_tte[stats::complete.cases(df_tte), ]+ formula <- stats::as.formula(paste0( |
| 245 | -6x | +371 | +3x |
- df <- data.frame(+ .var, " ~ ", |
| 246 | +372 |
- # Dummy column needed downstream to create a nested header.+ " + ", |
||
| 247 | -6x | +373 | +3x |
- arm = " ",+ paste(covariates, collapse = " + "), |
| 248 | -6x | +|||
| 374 | +
- n_tot = nrow(df_tte_complete),+ " + ", |
|||
| 249 | -6x | +375 | +3x |
- n_tot_events = sum(df_tte_complete$is_event),+ arm |
| 250 | -6x | +|||
| 376 | +
- hr = NA,+ )) |
|||
| 251 | -6x | +|||
| 377 | +
- lcl = NA,+ |
|||
| 252 | -6x | +378 | +3x |
- ucl = NA,+ glm_fit <- stats::glm( |
| 253 | -6x | +379 | +3x |
- conf_level = control[["conf_level"]],+ formula = formula, |
| 254 | -6x | +380 | +3x |
- pval = NA,+ offset = offset, |
| 255 | -6x | +381 | +3x |
- pval_label = NA,+ data = .df_row, |
| 256 | -6x | -
- stringsAsFactors = FALSE- |
- ||
| 257 | -+ | 382 | +3x |
- )+ family = stats::quasipoisson(link = "log") |
| 258 | +383 |
- } else {
- |
- ||
| 259 | -! | -
- df <- data.frame(+ ) |
||
| 260 | +384 |
- # Dummy column needed downstream to create a nested header.- |
- ||
| 261 | -! | -
- arm = " ",- |
- ||
| 262 | -! | -
- n_tot = 0L,- |
- ||
| 263 | -! | -
- n_tot_events = 0L,+ |
||
| 264 | -! | +|||
| 385 | +3x |
- hr = NA,+ emmeans_fit <- emmeans::emmeans( |
||
| 265 | -! | +|||
| 386 | +3x |
- lcl = NA,+ glm_fit, |
||
| 266 | -! | +|||
| 387 | +3x |
- ucl = NA,+ specs = arm, |
||
| 267 | -! | +|||
| 388 | +3x |
- conf_level = control[["conf_level"]],+ data = .df_row, |
||
| 268 | -! | +|||
| 389 | +3x |
- pval = NA,+ type = "response", |
||
| 269 | -! | +|||
| 390 | +3x |
- pval_label = NA,+ offset = 0, |
||
| 270 | -! | +|||
| 391 | +3x |
- stringsAsFactors = FALSE+ weights = weights |
||
| 271 | +392 |
- )+ ) |
||
| 272 | +393 |
- }+ |
||
| 273 | -+ | |||
| 394 | +3x |
-
+ list( |
||
| 274 | -85x | +395 | +3x |
- df+ glm_fit = glm_fit, |
| 275 | -+ | |||
| 396 | +3x |
- }+ emmeans_fit = emmeans_fit |
||
| 276 | +397 |
-
+ ) |
||
| 277 | +398 |
- #' @describeIn h_survival_duration_subgroups Summarizes estimates of the treatment hazard ratio+ } |
||
| 278 | +399 |
- #' across subgroups in a data frame. `variables` corresponds to the names of variables found in+ |
||
| 279 | +400 |
- #' `data`, passed as a named list and requires elements `tte`, `is_event`, `arm` and+ #' @describeIn h_glm_count Helper function to return results of a negative binomial model. |
||
| 280 | +401 |
- #' optionally `subgroups` and `strata`. `groups_lists` optionally specifies+ #' |
||
| 281 | +402 |
- #' groupings for `subgroups` variables.+ #' @return |
||
| 282 | +403 |
- #'+ #' * `h_glm_negbin()` returns the results of a negative binomial model. |
||
| 283 | +404 |
- #' @return+ #' |
||
| 284 | +405 |
- #' * `h_coxph_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`,+ #' @keywords internal |
||
| 285 | +406 |
- #' `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`.+ h_glm_negbin <- function(.var, |
||
| 286 | +407 |
- #'+ .df_row, |
||
| 287 | +408 |
- #' @examples+ variables, |
||
| 288 | +409 |
- #' # Extract hazard ratio for multiple groups.+ weights) {
|
||
| 289 | -+ | |||
| 410 | +9x |
- #' h_coxph_subgroups_df(+ arm <- variables$arm |
||
| 290 | -+ | |||
| 411 | +9x |
- #' variables = list(+ covariates <- variables$covariates |
||
| 291 | +412 |
- #' tte = "AVAL",+ |
||
| 292 | -+ | |||
| 413 | +9x |
- #' is_event = "is_event",+ formula <- stats::as.formula(paste0( |
||
| 293 | -+ | |||
| 414 | +9x |
- #' arm = "ARM",+ .var, " ~ ", |
||
| 294 | +415 |
- #' subgroups = c("SEX", "BMRKR2")
+ " + ", |
||
| 295 | -+ | |||
| 416 | +9x |
- #' ),+ paste(covariates, collapse = " + "), |
||
| 296 | +417 |
- #' data = adtte_f+ " + ", |
||
| 297 | -+ | |||
| 418 | +9x |
- #' )+ arm |
||
| 298 | +419 |
- #'+ )) |
||
| 299 | +420 |
- #' # Define groupings of BMRKR2 levels.+ |
||
| 300 | -+ | |||
| 421 | +9x |
- #' h_coxph_subgroups_df(+ glm_fit <- MASS::glm.nb( |
||
| 301 | -+ | |||
| 422 | +9x |
- #' variables = list(+ formula = formula, |
||
| 302 | -+ | |||
| 423 | +9x |
- #' tte = "AVAL",+ data = .df_row, |
||
| 303 | -+ | |||
| 424 | +9x |
- #' is_event = "is_event",+ link = "log" |
||
| 304 | +425 |
- #' arm = "ARM",+ ) |
||
| 305 | +426 |
- #' subgroups = c("SEX", "BMRKR2")
+
|
||
| 306 | -+ | |||
| 427 | +7x |
- #' ),+ emmeans_fit <- emmeans::emmeans( |
||
| 307 | -+ | |||
| 428 | +7x |
- #' data = adtte_f,+ glm_fit, |
||
| 308 | -+ | |||
| 429 | +7x |
- #' groups_lists = list(+ specs = arm, |
||
| 309 | -+ | |||
| 430 | +7x |
- #' BMRKR2 = list(+ data = .df_row, |
||
| 310 | -+ | |||
| 431 | +7x |
- #' "low" = "LOW",+ type = "response", |
||
| 311 | -+ | |||
| 432 | +7x |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ offset = 0, |
||
| 312 | -+ | |||
| 433 | +7x |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ weights = weights |
||
| 313 | +434 |
- #' )+ ) |
||
| 314 | +435 |
- #' )+ |
||
| 315 | -+ | |||
| 436 | +7x |
- #' )+ list( |
||
| 316 | -+ | |||
| 437 | +7x |
- #'+ glm_fit = glm_fit, |
||
| 317 | -+ | |||
| 438 | +7x |
- #' # Extract hazard ratio for multiple groups with stratification factors.+ emmeans_fit = emmeans_fit |
||
| 318 | +439 |
- #' h_coxph_subgroups_df(+ ) |
||
| 319 | +440 |
- #' variables = list(+ } |
||
| 320 | +441 |
- #' tte = "AVAL",+ |
||
| 321 | +442 |
- #' is_event = "is_event",+ # h_ppmeans -------------------------------------------------------------------- |
||
| 322 | +443 |
- #' arm = "ARM",+ #' Function to return the estimated means using predicted probabilities |
||
| 323 | +444 |
- #' subgroups = c("SEX", "BMRKR2"),
+ #' |
||
| 324 | +445 |
- #' strata = c("STRATA1", "STRATA2")
+ #' @description |
||
| 325 | +446 |
- #' ),+ #' For each arm level, the predicted mean rate is calculated using the fitted model object, with `newdata` |
||
| 326 | +447 |
- #' data = adtte_f+ #' set to the result of `stats::model.frame`, a reconstructed data or the original data, depending on the |
||
| 327 | +448 |
- #' )+ #' object formula (coming from the fit). The confidence interval is derived using the `conf_level` parameter. |
||
| 328 | +449 |
#' |
||
| 329 | +450 |
- #' @export+ #' @param obj (`glm.fit`)\cr fitted model object used to derive the mean rate estimates in each treatment arm. |
||
| 330 | +451 |
- h_coxph_subgroups_df <- function(variables,+ #' @param .df_row (`data.frame`)\cr dataset that includes all the variables that are called in `.var` and `variables`. |
||
| 331 | +452 |
- data,+ #' @param arm (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be |
||
| 332 | +453 |
- groups_lists = list(),+ #' summarized. Specifically, the first level of `arm` variable is taken as the reference group. |
||
| 333 | +454 |
- control = control_coxph(),+ #' @param conf_level (`proportion`)\cr value used to derive the confidence interval for the rate. |
||
| 334 | +455 |
- label_all = "All Patients") {
- |
- ||
| 335 | -17x | -
- if ("strat" %in% names(variables)) {
- |
- ||
| 336 | -! | -
- warning(+ #' |
||
| 337 | -! | +|||
| 456 | +
- "Warning: the `strat` element name of the `variables` list argument to `h_coxph_subgroups_df() ",+ #' @return |
|||
| 338 | -! | +|||
| 457 | +
- "was deprecated in tern 0.9.4.\n ",+ #' * `h_ppmeans()` returns the estimated means. |
|||
| 339 | -! | +|||
| 458 | +
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ #' |
|||
| 340 | +459 |
- )+ #' @seealso [summarize_glm_count()]. |
||
| 341 | -! | +|||
| 460 | +
- variables[["strata"]] <- variables[["strat"]]+ #' |
|||
| 342 | +461 |
- }+ #' @export |
||
| 343 | +462 |
-
+ h_ppmeans <- function(obj, .df_row, arm, conf_level) {
|
||
| 344 | -17x | +463 | +1x |
- checkmate::assert_character(variables$tte)+ alpha <- 1 - conf_level |
| 345 | -17x | +464 | +1x |
- checkmate::assert_character(variables$is_event)+ p <- 1 - alpha / 2 |
| 346 | -17x | +|||
| 465 | +
- checkmate::assert_character(variables$arm)+ |
|||
| 347 | -17x | +466 | +1x |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ arm_levels <- levels(.df_row[[arm]]) |
| 348 | -17x | +|||
| 467 | +
- checkmate::assert_character(variables$strata, null.ok = TRUE)+ |
|||
| 349 | -17x | +468 | +1x |
- assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ out <- lapply(arm_levels, function(lev) {
|
| 350 | -17x | +469 | +3x |
- assert_df_with_variables(data, variables)+ temp <- .df_row |
| 351 | -17x | +470 | +3x |
- checkmate::assert_string(label_all)+ temp[[arm]] <- factor(lev, levels = arm_levels) |
| 352 | +471 | |||
| 353 | -- |
- # Add All Patients.- |
- ||
| 354 | -17x | -
- result_all <- h_coxph_df(- |
- ||
| 355 | -17x | +472 | +3x |
- tte = data[[variables$tte]],+ mf <- stats::model.frame(obj$formula, data = temp) |
| 356 | -17x | +473 | +3x |
- is_event = data[[variables$is_event]],+ X <- stats::model.matrix(obj$formula, data = mf) # nolint |
| 357 | -17x | +|||
| 474 | +
- arm = data[[variables$arm]],+ |
|||
| 358 | -17x | +475 | +3x |
- strata_data = if (is.null(variables$strata)) NULL else data[variables$strata],+ rate <- stats::predict(obj, newdata = mf, type = "response") |
| 359 | -17x | +476 | +3x |
- control = control+ rate_hat <- mean(rate) |
| 360 | +477 |
- )+ |
||
| 361 | -17x | +478 | +3x |
- result_all$subgroup <- label_all+ zz <- colMeans(rate * X) |
| 362 | -17x | +479 | +3x |
- result_all$var <- "ALL"+ se <- sqrt(as.numeric(t(zz) %*% stats::vcov(obj) %*% zz)) |
| 363 | -17x | +480 | +3x |
- result_all$var_label <- label_all+ rate_lwr <- rate_hat * exp(-stats::qnorm(p) * se / rate_hat) |
| 364 | -17x | +481 | +3x |
- result_all$row_type <- "content"+ rate_upr <- rate_hat * exp(stats::qnorm(p) * se / rate_hat) |
| 365 | +482 | |||
| 366 | -- |
- # Add Subgroups.- |
- ||
| 367 | -17x | -
- if (is.null(variables$subgroups)) {
- |
- ||
| 368 | +483 | 3x |
- result_all+ c(rate_hat, rate_lwr, rate_upr) |
|
| 369 | +484 |
- } else {
- |
- ||
| 370 | -14x | -
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ }) |
||
| 371 | +485 | |||
| 372 | -14x | -
- l_result <- lapply(l_data, function(grp) {
- |
- ||
| 373 | -64x | -
- result <- h_coxph_df(- |
- ||
| 374 | -64x | -
- tte = grp$df[[variables$tte]],- |
- ||
| 375 | -64x | +486 | +1x |
- is_event = grp$df[[variables$is_event]],+ names(out) <- arm_levels |
| 376 | -64x | +487 | +1x |
- arm = grp$df[[variables$arm]],+ out <- do.call(rbind, out) |
| 377 | -64x | +488 | +1x |
- strata_data = if (is.null(variables$strata)) NULL else grp$df[variables$strata],+ if ("negbin" %in% class(obj)) {
|
| 378 | -64x | +|||
| 489 | +! |
- control = control+ colnames(out) <- c("response", "asymp.LCL", "asymp.UCL")
|
||
| 379 | +490 |
- )- |
- ||
| 380 | -64x | -
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ } else {
|
||
| 381 | -64x | +491 | +1x |
- cbind(result, result_labels)+ colnames(out) <- c("rate", "asymp.LCL", "asymp.UCL")
|
| 382 | +492 |
- })+ } |
||
| 383 | -+ | |||
| 493 | +1x |
-
+ out <- as.data.frame(out) |
||
| 384 | -14x | +494 | +1x |
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ out[[arm]] <- rownames(out) |
| 385 | -14x | +495 | +1x |
- result_subgroups$row_type <- "analysis"+ out |
| 386 | +496 | - - | -||
| 387 | -14x | -
- rbind(- |
- ||
| 388 | -14x | -
- result_all,+ } |
||
| 389 | -14x | +
| 1 | +
- result_subgroups+ #' Helper functions for tabulating binary response by subgroup |
|||
| 390 | +2 |
- )+ #' |
||
| 391 | +3 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 392 | +4 |
- }+ #' |
||
| 393 | +5 |
-
+ #' Helper functions that tabulate in a data frame statistics such as response rate |
||
| 394 | +6 |
- #' Split data frame by subgroups+ #' and odds ratio for population subgroups. |
||
| 395 | +7 |
#' |
||
| 396 | +8 |
- #' @description `r lifecycle::badge("stable")`
+ #' @inheritParams argument_convention |
||
| 397 | +9 |
- #'+ #' @inheritParams response_subgroups |
||
| 398 | +10 |
- #' Split a data frame into a non-nested list of subsets.+ #' @param arm (`factor`)\cr the treatment group variable. |
||
| 399 | +11 |
#' |
||
| 400 | +12 |
- #' @inheritParams argument_convention+ #' @details Main functionality is to prepare data for use in a layout-creating function. |
||
| 401 | +13 |
- #' @inheritParams survival_duration_subgroups+ #' |
||
| 402 | +14 |
- #' @param data (`data.frame`)\cr dataset to split.+ #' @examples |
||
| 403 | +15 |
- #' @param subgroups (`character`)\cr names of factor variables from `data` used to create subsets.+ #' library(dplyr) |
||
| 404 | +16 |
- #' Unused levels not present in `data` are dropped. Note that the order in this vector+ #' library(forcats) |
||
| 405 | +17 |
- #' determines the order in the downstream table.+ #' |
||
| 406 | +18 |
- #'+ #' adrs <- tern_ex_adrs |
||
| 407 | +19 |
- #' @return A list with subset data (`df`) and metadata about the subset (`df_labels`).+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 408 | +20 |
#' |
||
| 409 | +21 |
- #' @details Main functionality is to prepare data for use in forest plot layouts.+ #' adrs_f <- adrs %>% |
||
| 410 | +22 |
- #'+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 411 | +23 |
- #' @examples+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
|
||
| 412 | +24 |
- #' df <- data.frame(+ #' droplevels() %>% |
||
| 413 | +25 |
- #' x = c(1:5),+ #' mutate( |
||
| 414 | +26 |
- #' y = factor(c("A", "B", "A", "B", "A"), levels = c("A", "B", "C")),
+ #' # Reorder levels of factor to make the placebo group the reference arm. |
||
| 415 | +27 |
- #' z = factor(c("C", "C", "D", "D", "D"), levels = c("D", "C"))
+ #' ARM = fct_relevel(ARM, "B: Placebo"), |
||
| 416 | +28 |
- #' )+ #' rsp = AVALC == "CR" |
||
| 417 | +29 |
- #' formatters::var_labels(df) <- paste("label for", names(df))
+ #' ) |
||
| 418 | +30 |
- #'+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
||
| 419 | +31 |
- #' h_split_by_subgroups(+ #' |
||
| 420 | +32 |
- #' data = df,+ #' @name h_response_subgroups |
||
| 421 | +33 |
- #' subgroups = c("y", "z")
+ NULL |
||
| 422 | +34 |
- #' )+ |
||
| 423 | +35 |
- #'+ #' @describeIn h_response_subgroups Helper to prepare a data frame of binary responses by arm. |
||
| 424 | +36 |
- #' h_split_by_subgroups(+ #' |
||
| 425 | +37 |
- #' data = df,+ #' @return |
||
| 426 | +38 |
- #' subgroups = c("y", "z"),
+ #' * `h_proportion_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, and `prop`. |
||
| 427 | +39 |
- #' groups_lists = list(+ #' |
||
| 428 | +40 |
- #' y = list("AB" = c("A", "B"), "C" = "C")
+ #' @examples |
||
| 429 | +41 |
- #' )+ #' h_proportion_df( |
||
| 430 | +42 |
- #' )+ #' c(TRUE, FALSE, FALSE), |
||
| 431 | +43 |
- #'+ #' arm = factor(c("A", "A", "B"), levels = c("A", "B"))
|
||
| 432 | +44 |
- #' @export+ #' ) |
||
| 433 | +45 |
- h_split_by_subgroups <- function(data,+ #' |
||
| 434 | +46 |
- subgroups,+ #' @export |
||
| 435 | +47 |
- groups_lists = list()) {
- |
- ||
| 436 | -66x | -
- checkmate::assert_character(subgroups, min.len = 1, any.missing = FALSE)- |
- ||
| 437 | -66x | -
- checkmate::assert_list(groups_lists, names = "named")+ h_proportion_df <- function(rsp, arm) {
|
||
| 438 | -66x | +48 | +79x |
- checkmate::assert_subset(names(groups_lists), subgroups)+ checkmate::assert_logical(rsp) |
| 439 | -66x | -
- assert_df_with_factors(data, as.list(stats::setNames(subgroups, subgroups)))- |
- ||
| 440 | -+ | 49 | +78x |
-
+ assert_valid_factor(arm, len = length(rsp)) |
| 441 | -66x | +50 | +78x |
- data_labels <- unname(formatters::var_labels(data))+ non_missing_rsp <- !is.na(rsp) |
| 442 | -66x | +51 | +78x |
- df_subgroups <- data[, subgroups, drop = FALSE]+ rsp <- rsp[non_missing_rsp] |
| 443 | -66x | +52 | +78x |
- subgroup_labels <- formatters::var_labels(df_subgroups, fill = TRUE)+ arm <- arm[non_missing_rsp] |
| 444 | +53 | |||
| 445 | -66x | -
- l_labels <- Map(function(grp_i, name_i) {
- |
- ||
| 446 | -120x | -
- existing_levels <- levels(droplevels(grp_i))- |
- ||
| 447 | -120x | -
- grp_levels <- if (name_i %in% names(groups_lists)) {
- |
- ||
| 448 | -- |
- # For this variable groupings are defined. We check which groups are contained in the data.- |
- ||
| 449 | -11x | +54 | +78x |
- group_list_i <- groups_lists[[name_i]]+ lst_rsp <- split(rsp, arm) |
| 450 | -11x | +55 | +78x |
- group_has_levels <- vapply(group_list_i, function(lvls) any(lvls %in% existing_levels), TRUE)+ lst_results <- Map(function(x, arm) {
|
| 451 | -11x | -
- names(which(group_has_levels))- |
- ||
| 452 | -+ | 56 | +156x |
- } else {
+ if (length(x) > 0) {
|
| 453 | -109x | -
- existing_levels- |
- ||
| 454 | -+ | 57 | +154x |
- }+ s_prop <- s_proportion(df = x) |
| 455 | -120x | +58 | +154x |
- df_labels <- data.frame(+ data.frame( |
| 456 | -120x | +59 | +154x |
- subgroup = grp_levels,+ arm = arm, |
| 457 | -120x | +60 | +154x |
- var = name_i,+ n = length(x), |
| 458 | -120x | +61 | +154x |
- var_label = unname(subgroup_labels[name_i]),+ n_rsp = unname(s_prop$n_prop[1]), |
| 459 | -120x | -
- stringsAsFactors = FALSE # Rationale is that subgroups may not be unique.- |
- ||
| 460 | -+ | 62 | +154x |
- )+ prop = unname(s_prop$n_prop[2]), |
| 461 | -66x | +63 | +154x |
- }, df_subgroups, names(df_subgroups))+ stringsAsFactors = FALSE |
| 462 | +64 |
-
+ ) |
||
| 463 | +65 |
- # Create a data frame with one row per subgroup.+ } else {
|
||
| 464 | -66x | +66 | +2x |
- df_labels <- do.call(rbind, args = c(l_labels, make.row.names = FALSE))+ data.frame( |
| 465 | -66x | +67 | +2x |
- row_label <- paste0(df_labels$var, ".", df_labels$subgroup)+ arm = arm, |
| 466 | -66x | -
- row_split_var <- factor(row_label, levels = row_label)- |
- ||
| 467 | -- | - - | -||
| 468 | -+ | 68 | +2x |
- # Create a list of data subsets.+ n = 0L, |
| 469 | -66x | +69 | +2x |
- lapply(split(df_labels, row_split_var), function(row_i) {
+ n_rsp = NA, |
| 470 | -294x | +70 | +2x |
- which_row <- if (row_i$var %in% names(groups_lists)) {
+ prop = NA, |
| 471 | -31x | +71 | +2x |
- data[[row_i$var]] %in% groups_lists[[row_i$var]][[row_i$subgroup]]+ stringsAsFactors = FALSE |
| 472 | +72 |
- } else {
- |
- ||
| 473 | -263x | -
- data[[row_i$var]] == row_i$subgroup+ ) |
||
| 474 | +73 |
} |
||
| 475 | -294x | -
- df <- data[which_row, ]- |
- ||
| 476 | -294x | -
- rownames(df) <- NULL- |
- ||
| 477 | -294x | +74 | +78x |
- formatters::var_labels(df) <- data_labels+ }, lst_rsp, names(lst_rsp)) |
| 478 | +75 | |||
| 479 | -294x | +76 | +78x |
- list(+ df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE)) |
| 480 | -294x | +77 | +78x |
- df = df,+ df$arm <- factor(df$arm, levels = levels(arm)) |
| 481 | -294x | -
- df_labels = data.frame(row_i, row.names = NULL)- |
- ||
| 482 | -- |
- )- |
- ||
| 483 | -- |
- })- |
- ||
| 484 | -+ | 78 | +78x |
- }+ df |
| 1 | +79 |
- #' Tabulate survival duration by subgroup+ } |
||
| 2 | +80 |
- #'+ |
||
| 3 | +81 |
- #' @description `r lifecycle::badge("stable")`
+ #' @describeIn h_response_subgroups Summarizes proportion of binary responses by arm and across subgroups |
||
| 4 | +82 |
- #'+ #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and |
||
| 5 | +83 |
- #' The [tabulate_survival_subgroups()] function creates a layout element to tabulate survival duration by subgroup,+ #' requires elements `rsp`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies |
||
| 6 | +84 |
- #' returning statistics including median survival time and hazard ratio for each population subgroup. The table is+ #' groupings for `subgroups` variables. |
||
| 7 | +85 |
- #' created from `df`, a list of data frames returned by [extract_survival_subgroups()], with the statistics to include+ #' |
||
| 8 | +86 |
- #' specified via the `vars` parameter.+ #' @return |
||
| 9 | +87 |
- #'+ #' * `h_proportion_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`, |
||
| 10 | +88 |
- #' A forest plot can be created from the resulting table using the [g_forest()] function.+ #' `var`, `var_label`, and `row_type`. |
||
| 11 | +89 |
#' |
||
| 12 | +90 |
- #' @inheritParams argument_convention+ #' @examples |
||
| 13 | +91 |
- #' @inheritParams survival_coxph_pairwise+ #' h_proportion_subgroups_df( |
||
| 14 | +92 |
- #' @param df (`list`)\cr list of data frames containing all analysis variables. List should be+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
||
| 15 | +93 |
- #' created using [extract_survival_subgroups()].+ #' data = adrs_f |
||
| 16 | +94 |
- #' @param vars (`character`)\cr the names of statistics to be reported among:+ #' ) |
||
| 17 | +95 |
- #' * `n_tot_events`: Total number of events per group.+ #' |
||
| 18 | +96 |
- #' * `n_events`: Number of events per group.+ #' # Define groupings for BMRKR2 levels. |
||
| 19 | +97 |
- #' * `n_tot`: Total number of observations per group.+ #' h_proportion_subgroups_df( |
||
| 20 | +98 |
- #' * `n`: Number of observations per group.+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
||
| 21 | +99 |
- #' * `median`: Median survival time.+ #' data = adrs_f, |
||
| 22 | +100 |
- #' * `hr`: Hazard ratio.+ #' groups_lists = list( |
||
| 23 | +101 |
- #' * `ci`: Confidence interval of hazard ratio.+ #' BMRKR2 = list( |
||
| 24 | +102 |
- #' * `pval`: p-value of the effect.+ #' "low" = "LOW", |
||
| 25 | +103 |
- #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci`+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 26 | +104 |
- #' are required.+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 27 | +105 |
- #' @param time_unit (`string`)\cr label with unit of median survival time. Default `NULL` skips displaying unit.+ #' ) |
||
| 28 | +106 |
- #'+ #' ) |
||
| 29 | +107 |
- #' @details These functions create a layout starting from a data frame which contains+ #' ) |
||
| 30 | +108 |
- #' the required statistics. Tables typically used as part of forest plot.+ #' |
||
| 31 | +109 |
- #'+ #' @export |
||
| 32 | +110 |
- #' @seealso [extract_survival_subgroups()]+ h_proportion_subgroups_df <- function(variables, |
||
| 33 | +111 |
- #'+ data, |
||
| 34 | +112 |
- #' @examples+ groups_lists = list(), |
||
| 35 | +113 |
- #' library(dplyr)+ label_all = "All Patients") {
|
||
| 36 | -+ | |||
| 114 | +17x |
- #'+ checkmate::assert_character(variables$rsp) |
||
| 37 | -+ | |||
| 115 | +17x |
- #' adtte <- tern_ex_adtte+ checkmate::assert_character(variables$arm) |
||
| 38 | -+ | |||
| 116 | +17x |
- #'+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
||
| 39 | -+ | |||
| 117 | +17x |
- #' # Save variable labels before data processing steps.+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2) |
||
| 40 | -+ | |||
| 118 | +17x |
- #' adtte_labels <- formatters::var_labels(adtte)+ assert_df_with_variables(data, variables) |
||
| 41 | -+ | |||
| 119 | +17x |
- #'+ checkmate::assert_string(label_all) |
||
| 42 | +120 |
- #' adtte_f <- adtte %>%+ |
||
| 43 | +121 |
- #' filter(+ # Add All Patients. |
||
| 44 | -+ | |||
| 122 | +17x |
- #' PARAMCD == "OS",+ result_all <- h_proportion_df(data[[variables$rsp]], data[[variables$arm]]) |
||
| 45 | -+ | |||
| 123 | +17x |
- #' ARM %in% c("B: Placebo", "A: Drug X"),
+ result_all$subgroup <- label_all |
||
| 46 | -+ | |||
| 124 | +17x |
- #' SEX %in% c("M", "F")
+ result_all$var <- "ALL" |
||
| 47 | -+ | |||
| 125 | +17x |
- #' ) %>%+ result_all$var_label <- label_all |
||
| 48 | -+ | |||
| 126 | +17x |
- #' mutate(+ result_all$row_type <- "content" |
||
| 49 | +127 |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ |
||
| 50 | +128 |
- #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")),+ # Add Subgroups. |
||
| 51 | -+ | |||
| 129 | +17x |
- #' SEX = droplevels(SEX),+ if (is.null(variables$subgroups)) {
|
||
| 52 | -+ | |||
| 130 | +3x |
- #' AVALU = as.character(AVALU),+ result_all |
||
| 53 | +131 |
- #' is_event = CNSR == 0+ } else {
|
||
| 54 | -+ | |||
| 132 | +14x |
- #' )+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
||
| 55 | +133 |
- #' labels <- c(+ |
||
| 56 | -+ | |||
| 134 | +14x |
- #' "ARM" = adtte_labels[["ARM"]],+ l_result <- lapply(l_data, function(grp) {
|
||
| 57 | -+ | |||
| 135 | +58x |
- #' "SEX" = adtte_labels[["SEX"]],+ result <- h_proportion_df(grp$df[[variables$rsp]], grp$df[[variables$arm]]) |
||
| 58 | -+ | |||
| 136 | +58x |
- #' "AVALU" = adtte_labels[["AVALU"]],+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
||
| 59 | -+ | |||
| 137 | +58x |
- #' "is_event" = "Event Flag"+ cbind(result, result_labels) |
||
| 60 | +138 |
- #' )+ }) |
||
| 61 | -+ | |||
| 139 | +14x |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
||
| 62 | -+ | |||
| 140 | +14x |
- #'+ result_subgroups$row_type <- "analysis" |
||
| 63 | +141 |
- #' df <- extract_survival_subgroups(+ |
||
| 64 | -+ | |||
| 142 | +14x |
- #' variables = list(+ rbind( |
||
| 65 | -+ | |||
| 143 | +14x |
- #' tte = "AVAL",+ result_all, |
||
| 66 | -+ | |||
| 144 | +14x |
- #' is_event = "is_event",+ result_subgroups |
||
| 67 | +145 |
- #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ ) |
||
| 68 | +146 |
- #' ),+ } |
||
| 69 | +147 |
- #' label_all = "Total Patients",+ } |
||
| 70 | +148 |
- #' data = adtte_f+ |
||
| 71 | +149 |
- #' )+ #' @describeIn h_response_subgroups Helper to prepare a data frame with estimates of |
||
| 72 | +150 |
- #' df+ #' the odds ratio between a treatment and a control arm. |
||
| 73 | +151 |
#' |
||
| 74 | +152 |
- #' df_grouped <- extract_survival_subgroups(+ #' @inheritParams response_subgroups |
||
| 75 | +153 |
- #' variables = list(+ #' @param strata_data (`factor`, `data.frame`, or `NULL`)\cr required if stratified analysis is performed. |
||
| 76 | +154 |
- #' tte = "AVAL",+ #' |
||
| 77 | +155 |
- #' is_event = "is_event",+ #' @return |
||
| 78 | +156 |
- #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ #' * `h_odds_ratio_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`, and |
||
| 79 | +157 |
- #' ),+ #' optionally `pval` and `pval_label`. |
||
| 80 | +158 |
- #' data = adtte_f,+ #' |
||
| 81 | +159 |
- #' groups_lists = list(+ #' @examples |
||
| 82 | +160 |
- #' BMRKR2 = list(+ #' # Unstratatified analysis. |
||
| 83 | +161 |
- #' "low" = "LOW",+ #' h_odds_ratio_df( |
||
| 84 | +162 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' c(TRUE, FALSE, FALSE, TRUE), |
||
| 85 | +163 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ #' arm = factor(c("A", "A", "B", "B"), levels = c("A", "B"))
|
||
| 86 | +164 |
- #' )+ #' ) |
||
| 87 | +165 |
- #' )+ #' |
||
| 88 | +166 |
- #' )+ #' # Include p-value. |
||
| 89 | +167 |
- #' df_grouped+ #' h_odds_ratio_df(adrs_f$rsp, adrs_f$ARM, method = "chisq") |
||
| 90 | +168 |
#' |
||
| 91 | +169 |
- #' @name survival_duration_subgroups+ #' # Stratatified analysis. |
||
| 92 | +170 |
- #' @order 1+ #' h_odds_ratio_df( |
||
| 93 | +171 |
- NULL+ #' rsp = adrs_f$rsp, |
||
| 94 | +172 |
-
+ #' arm = adrs_f$ARM, |
||
| 95 | +173 |
- #' Prepare survival data for population subgroups in data frames+ #' strata_data = adrs_f[, c("STRATA1", "STRATA2")],
|
||
| 96 | +174 |
- #'+ #' method = "cmh" |
||
| 97 | +175 |
- #' @description `r lifecycle::badge("stable")`
+ #' ) |
||
| 98 | +176 |
#' |
||
| 99 | +177 |
- #' Prepares estimates of median survival times and treatment hazard ratios for population subgroups in+ #' @export |
||
| 100 | +178 |
- #' data frames. Simple wrapper for [h_survtime_subgroups_df()] and [h_coxph_subgroups_df()]. Result is a `list`+ h_odds_ratio_df <- function(rsp, arm, strata_data = NULL, conf_level = 0.95, method = NULL) {
|
||
| 101 | -+ | |||
| 179 | +84x |
- #' of two `data.frame`s: `survtime` and `hr`. `variables` corresponds to the names of variables found in `data`,+ assert_valid_factor(arm, n.levels = 2, len = length(rsp)) |
||
| 102 | +180 |
- #' passed as a named `list` and requires elements `tte`, `is_event`, `arm` and optionally `subgroups` and `strata`.+ |
||
| 103 | -+ | |||
| 181 | +84x |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ df_rsp <- data.frame( |
||
| 104 | -+ | |||
| 182 | +84x |
- #'+ rsp = rsp, |
||
| 105 | -+ | |||
| 183 | +84x |
- #' @inheritParams argument_convention+ arm = arm |
||
| 106 | +184 |
- #' @inheritParams survival_duration_subgroups+ ) |
||
| 107 | +185 |
- #' @inheritParams survival_coxph_pairwise+ |
||
| 108 | -+ | |||
| 186 | +84x |
- #'+ if (!is.null(strata_data)) {
|
||
| 109 | -+ | |||
| 187 | +11x |
- #' @return A named `list` of two elements:+ strata_var <- interaction(strata_data, drop = TRUE) |
||
| 110 | -+ | |||
| 188 | +11x |
- #' * `survtime`: A `data.frame` containing columns `arm`, `n`, `n_events`, `median`, `subgroup`, `var`,+ strata_name <- "strata" |
||
| 111 | +189 |
- #' `var_label`, and `row_type`.+ |
||
| 112 | -+ | |||
| 190 | +11x |
- #' * `hr`: A `data.frame` containing columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`, `conf_level`,+ assert_valid_factor(strata_var, len = nrow(df_rsp)) |
||
| 113 | +191 |
- #' `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`.+ |
||
| 114 | -+ | |||
| 192 | +11x |
- #'+ df_rsp[[strata_name]] <- strata_var |
||
| 115 | +193 |
- #' @seealso [survival_duration_subgroups]+ } else {
|
||
| 116 | -+ | |||
| 194 | +73x |
- #'+ strata_name <- NULL |
||
| 117 | +195 |
- #' @export+ } |
||
| 118 | +196 |
- extract_survival_subgroups <- function(variables,+ |
||
| 119 | -+ | |||
| 197 | +84x |
- data,+ l_df <- split(df_rsp, arm) |
||
| 120 | +198 |
- groups_lists = list(),+ |
||
| 121 | -+ | |||
| 199 | +84x |
- control = control_coxph(),+ if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
|
||
| 122 | +200 |
- label_all = "All Patients") {
+ # Odds ratio and CI. |
||
| 123 | -12x | +201 | +82x |
- if ("strat" %in% names(variables)) {
+ result_odds_ratio <- s_odds_ratio( |
| 124 | -! | +|||
| 202 | +82x |
- warning(+ df = l_df[[2]], |
||
| 125 | -! | +|||
| 203 | +82x |
- "Warning: the `strat` element name of the `variables` list argument to `extract_survival_subgroups() ",+ .var = "rsp", |
||
| 126 | -! | +|||
| 204 | +82x |
- "was deprecated in tern 0.9.4.\n ",+ .ref_group = l_df[[1]], |
||
| 127 | -! | +|||
| 205 | +82x |
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ .in_ref_col = FALSE, |
||
| 128 | -+ | |||
| 206 | +82x |
- )+ .df_row = df_rsp, |
||
| 129 | -! | +|||
| 207 | +82x |
- variables[["strata"]] <- variables[["strat"]]+ variables = list(arm = "arm", strata = strata_name),+ |
+ ||
| 208 | +82x | +
+ conf_level = conf_level |
||
| 130 | +209 |
- }+ ) |
||
| 131 | +210 | |||
| 132 | -12x | +211 | +82x |
- df_survtime <- h_survtime_subgroups_df(+ df <- data.frame(+ |
+
| 212 | ++ |
+ # Dummy column needed downstream to create a nested header. |
||
| 133 | -12x | +213 | +82x |
- variables,+ arm = " ", |
| 134 | -12x | +214 | +82x |
- data,+ n_tot = unname(result_odds_ratio$n_tot["n_tot"]), |
| 135 | -12x | +215 | +82x |
- groups_lists = groups_lists,+ or = unname(result_odds_ratio$or_ci["est"]), |
| 136 | -12x | +216 | +82x |
- label_all = label_all+ lcl = unname(result_odds_ratio$or_ci["lcl"]),+ |
+
| 217 | +82x | +
+ ucl = unname(result_odds_ratio$or_ci["ucl"]),+ |
+ ||
| 218 | +82x | +
+ conf_level = conf_level,+ |
+ ||
| 219 | +82x | +
+ stringsAsFactors = FALSE |
||
| 137 | +220 |
- )+ ) |
||
| 138 | -12x | +|||
| 221 | +
- df_hr <- h_coxph_subgroups_df(+ |
|||
| 139 | -12x | +222 | +82x |
- variables,+ if (!is.null(method)) {
+ |
+
| 223 | ++ |
+ # Test for difference. |
||
| 140 | -12x | +224 | +44x |
- data,+ result_test <- s_test_proportion_diff( |
| 141 | -12x | +225 | +44x |
- groups_lists = groups_lists,+ df = l_df[[2]], |
| 142 | -12x | +226 | +44x |
- control = control,+ .var = "rsp", |
| 143 | -12x | +227 | +44x |
- label_all = label_all+ .ref_group = l_df[[1]], |
| 144 | -+ | |||
| 228 | +44x |
- )+ .in_ref_col = FALSE, |
||
| 145 | -+ | |||
| 229 | +44x |
-
+ variables = list(strata = strata_name), |
||
| 146 | -12x | +230 | +44x |
- list(survtime = df_survtime, hr = df_hr)+ method = method |
| 147 | +231 |
- }+ ) |
||
| 148 | +232 | |||
| 149 | -+ | |||
| 233 | +44x |
- #' @describeIn survival_duration_subgroups Formatted analysis function which is used as+ df$pval <- as.numeric(result_test$pval) |
||
| 150 | -+ | |||
| 234 | +44x |
- #' `afun` in `tabulate_survival_subgroups()`.+ df$pval_label <- obj_label(result_test$pval) |
||
| 151 | +235 |
- #'+ } |
||
| 152 | +236 |
- #' @return+ |
||
| 153 | +237 |
- #' * `a_survival_subgroups()` returns the corresponding list with formatted [rtables::CellValue()].+ # In those cases cannot go through the model so will obtain n_tot from data. |
||
| 154 | +238 |
- #'+ } else if ( |
||
| 155 | -+ | |||
| 239 | +2x |
- #' @keywords internal+ (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) || |
||
| 156 | -+ | |||
| 240 | +2x |
- a_survival_subgroups <- function(.formats = list( # nolint start+ (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0) |
||
| 157 | +241 |
- n = "xx",+ ) {
|
||
| 158 | -+ | |||
| 242 | +2x |
- n_events = "xx",+ df <- data.frame( |
||
| 159 | +243 |
- n_tot_events = "xx",+ # Dummy column needed downstream to create a nested header. |
||
| 160 | -+ | |||
| 244 | +2x |
- median = "xx.x",+ arm = " ", |
||
| 161 | -+ | |||
| 245 | +2x |
- n_tot = "xx",+ n_tot = sum(stats::complete.cases(df_rsp)), |
||
| 162 | -+ | |||
| 246 | +2x |
- hr = list(format_extreme_values(2L)),+ or = NA, |
||
| 163 | -+ | |||
| 247 | +2x |
- ci = list(format_extreme_values_ci(2L)),+ lcl = NA, |
||
| 164 | -+ | |||
| 248 | +2x |
- pval = "x.xxxx | (<0.0001)"+ ucl = NA, |
||
| 165 | -+ | |||
| 249 | +2x |
- ),+ conf_level = conf_level, |
||
| 166 | -+ | |||
| 250 | +2x |
- na_str = default_na_str()) { # nolint end
+ stringsAsFactors = FALSE |
||
| 167 | -21x | +|||
| 251 | +
- checkmate::assert_list(.formats)+ ) |
|||
| 168 | -21x | +252 | +2x |
- checkmate::assert_subset(+ if (!is.null(method)) {
|
| 169 | -21x | +253 | +2x |
- names(.formats),+ df$pval <- NA |
| 170 | -21x | +254 | +2x |
- c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval", "riskdiff")
+ df$pval_label <- NA |
| 171 | +255 |
- )+ } |
||
| 172 | +256 |
-
+ } else {
|
||
| 173 | -21x | +|||
| 257 | +! |
- afun_lst <- Map(+ df <- data.frame( |
||
| 174 | -21x | +|||
| 258 | +
- function(stat, fmt, na_str) {
+ # Dummy column needed downstream to create a nested header. |
|||
| 175 | -160x | +|||
| 259 | +! |
- function(df, labelstr = "", ...) {
+ arm = " ", |
||
| 176 | -312x | +|||
| 260 | +! |
- in_rows(+ n_tot = 0L, |
||
| 177 | -312x | +|||
| 261 | +! |
- .list = as.list(df[[stat]]),+ or = NA, |
||
| 178 | -312x | +|||
| 262 | +! | +
+ lcl = NA,+ |
+ ||
| 263 | +! |
- .labels = as.character(df$subgroup),+ ucl = NA, |
||
| 179 | -312x | +|||
| 264 | +! |
- .formats = fmt,+ conf_level = conf_level, |
||
| 180 | -312x | +|||
| 265 | +! |
- .format_na_strs = na_str+ stringsAsFactors = FALSE |
||
| 181 | +266 |
- )+ ) |
||
| 182 | +267 |
- }+ |
||
| 183 | -+ | |||
| 268 | +! |
- },+ if (!is.null(method)) {
|
||
| 184 | -21x | +|||
| 269 | +! |
- stat = names(.formats),+ df$pval <- NA |
||
| 185 | -21x | +|||
| 270 | +! |
- fmt = .formats,+ df$pval_label <- NA |
||
| 186 | -21x | +|||
| 271 | +
- na_str = na_str+ } |
|||
| 187 | +272 |
- )+ } |
||
| 188 | +273 | |||
| 189 | -21x | +274 | +84x |
- afun_lst+ df |
| 190 | +275 |
} |
||
| 191 | +276 | |||
| 192 | +277 |
- #' @describeIn survival_duration_subgroups Table-creating function which creates a table+ #' @describeIn h_response_subgroups Summarizes estimates of the odds ratio between a treatment and a control |
||
| 193 | +278 |
- #' summarizing survival by subgroup. This function is a wrapper for [rtables::analyze_colvars()]+ #' arm across subgroups in a data frame. `variables` corresponds to the names of variables found in |
||
| 194 | +279 |
- #' and [rtables::summarize_row_groups()].+ #' `data`, passed as a named list and requires elements `rsp`, `arm` and optionally `subgroups` |
||
| 195 | +280 |
- #'+ #' and `strata`. `groups_lists` optionally specifies groupings for `subgroups` variables. |
||
| 196 | +281 |
- #' @param label_all `r lifecycle::badge("deprecated")`\cr please assign the `label_all` parameter within the
+ #' |
||
| 197 | +282 |
- #' [extract_survival_subgroups()] function when creating `df`.+ #' @return |
||
| 198 | +283 |
- #' @param riskdiff (`list`)\cr if a risk (proportion) difference column should be added, a list of settings to apply+ #' * `h_odds_ratio_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, |
||
| 199 | +284 |
- #' within the column. See [control_riskdiff()] for details. If `NULL`, no risk difference column will be added. If+ #' `conf_level`, `subgroup`, `var`, `var_label`, and `row_type`. |
||
| 200 | +285 |
- #' `riskdiff$arm_x` and `riskdiff$arm_y` are `NULL`, the first level of `df$survtime$arm` will be used as `arm_x`+ #' |
||
| 201 | +286 |
- #' and the second level as `arm_y`.+ #' @examples |
||
| 202 | +287 |
- #'+ #' # Unstratified analysis. |
||
| 203 | +288 |
- #' @return An `rtables` table summarizing survival by subgroup.+ #' h_odds_ratio_subgroups_df( |
||
| 204 | +289 |
- #'+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
||
| 205 | +290 |
- #' @examples+ #' data = adrs_f |
||
| 206 | +291 |
- #' ## Table with default columns.+ #' ) |
||
| 207 | +292 |
- #' basic_table() %>%+ #' |
||
| 208 | +293 |
- #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1])+ #' # Stratified analysis. |
||
| 209 | +294 |
- #'+ #' h_odds_ratio_subgroups_df( |
||
| 210 | +295 |
- #' ## Table with a manually chosen set of columns: adding "pval".+ #' variables = list( |
||
| 211 | +296 |
- #' basic_table() %>%+ #' rsp = "rsp", |
||
| 212 | +297 |
- #' tabulate_survival_subgroups(+ #' arm = "ARM", |
||
| 213 | +298 |
- #' df = df,+ #' subgroups = c("SEX", "BMRKR2"),
|
||
| 214 | +299 |
- #' vars = c("n_tot_events", "n_events", "median", "hr", "ci", "pval"),
+ #' strata = c("STRATA1", "STRATA2")
|
||
| 215 | +300 |
- #' time_unit = adtte_f$AVALU[1]+ #' ), |
||
| 216 | +301 |
- #' )+ #' data = adrs_f |
||
| 217 | +302 |
- #'+ #' ) |
||
| 218 | +303 |
- #' @export+ #' |
||
| 219 | +304 |
- #' @order 2+ #' # Define groupings of BMRKR2 levels. |
||
| 220 | +305 |
- tabulate_survival_subgroups <- function(lyt,+ #' h_odds_ratio_subgroups_df( |
||
| 221 | +306 |
- df,+ #' variables = list( |
||
| 222 | +307 |
- vars = c("n_tot_events", "n_events", "median", "hr", "ci"),
+ #' rsp = "rsp", |
||
| 223 | +308 |
- groups_lists = list(),+ #' arm = "ARM", |
||
| 224 | +309 |
- label_all = lifecycle::deprecated(),+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 225 | +310 |
- time_unit = NULL,+ #' ), |
||
| 226 | +311 |
- riskdiff = NULL,+ #' data = adrs_f, |
||
| 227 | +312 |
- na_str = default_na_str(),+ #' groups_lists = list( |
||
| 228 | +313 |
- .formats = c(+ #' BMRKR2 = list( |
||
| 229 | +314 |
- n = "xx", n_events = "xx", n_tot_events = "xx", median = "xx.x", n_tot = "xx",+ #' "low" = "LOW", |
||
| 230 | +315 |
- hr = list(format_extreme_values(2L)), ci = list(format_extreme_values_ci(2L)),+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 231 | +316 |
- pval = "x.xxxx | (<0.0001)"+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 232 | +317 |
- )) {
- |
- ||
| 233 | -10x | -
- checkmate::assert_list(riskdiff, null.ok = TRUE)+ #' ) |
||
| 234 | -10x | +|||
| 318 | +
- checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
+ #' ) |
|||
| 235 | -10x | +|||
| 319 | +
- checkmate::assert_true(all(c("hr", "ci") %in% vars))
+ #' ) |
|||
| 236 | +320 |
-
+ #' |
||
| 237 | -10x | +|||
| 321 | +
- if (lifecycle::is_present(label_all)) {
+ #' @export |
|||
| 238 | -1x | +|||
| 322 | +
- lifecycle::deprecate_warn(+ h_odds_ratio_subgroups_df <- function(variables, |
|||
| 239 | -1x | +|||
| 323 | +
- "0.9.5", "tabulate_survival_subgroups(label_all)",+ data, |
|||
| 240 | -1x | +|||
| 324 | +
- details =+ groups_lists = list(), |
|||
| 241 | -1x | +|||
| 325 | +
- "Please assign the `label_all` parameter within the `extract_survival_subgroups()` function when creating `df`."+ conf_level = 0.95, |
|||
| 242 | +326 |
- )+ method = NULL, |
||
| 243 | +327 |
- }+ label_all = "All Patients") {
|
||
| 244 | -+ | |||
| 328 | +18x |
-
+ if ("strat" %in% names(variables)) {
|
||
| 245 | -+ | |||
| 329 | +! |
- # Create "ci" column from "lcl" and "ucl"+ warning( |
||
| 246 | -10x | +|||
| 330 | +! |
- df$hr$ci <- combine_vectors(df$hr$lcl, df$hr$ucl)+ "Warning: the `strat` element name of the `variables` list argument to `h_odds_ratio_subgroups_df() ", |
||
| 247 | -+ | |||
| 331 | +! |
-
+ "was deprecated in tern 0.9.4.\n ", |
||
| 248 | -+ | |||
| 332 | +! |
- # Fill in missing formats with defaults+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 249 | -10x | +|||
| 333 | +
- default_fmts <- eval(formals(tabulate_survival_subgroups)$.formats)+ ) |
|||
| 250 | -10x | +|||
| 334 | +! |
- .formats <- c(.formats, default_fmts[vars[!vars %in% names(.formats)]])+ variables[["strata"]] <- variables[["strat"]] |
||
| 251 | +335 |
-
+ } |
||
| 252 | +336 |
- # Extract additional parameters from df+ |
||
| 253 | -10x | +337 | +18x |
- conf_level <- df$hr$conf_level[1]+ checkmate::assert_character(variables$rsp) |
| 254 | -10x | +338 | +18x |
- method <- df$hr$pval_label[1]+ checkmate::assert_character(variables$arm) |
| 255 | -10x | +339 | +18x |
- colvars <- d_survival_subgroups_colvars(vars, conf_level = conf_level, method = method, time_unit = time_unit)+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 256 | -10x | +340 | +18x |
- survtime_vars <- intersect(colvars$vars, c("n", "n_events", "median"))
+ checkmate::assert_character(variables$strata, null.ok = TRUE) |
| 257 | -10x | +341 | +18x |
- hr_vars <- intersect(names(colvars$labels), c("n_tot", "n_tot_events", "hr", "ci", "pval"))
+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2) |
| 258 | -10x | +342 | +18x |
- colvars_survtime <- list(vars = survtime_vars, labels = colvars$labels[survtime_vars])+ assert_df_with_variables(data, variables) |
| 259 | -10x | +343 | +18x |
- colvars_hr <- list(vars = hr_vars, labels = colvars$labels[hr_vars])+ checkmate::assert_string(label_all) |
| 260 | +344 | |||
| 261 | -10x | +345 | +18x |
- extra_args <- list(groups_lists = groups_lists, conf_level = conf_level, method = method)+ strata_data <- if (is.null(variables$strata)) {
|
| 262 | -+ | |||
| 346 | +16x |
-
+ NULL |
||
| 263 | +347 |
- # Get analysis function for each statistic+ } else {
|
||
| 264 | -10x | +348 | +2x |
- afun_lst <- a_survival_subgroups(.formats = c(.formats, riskdiff = riskdiff$format), na_str = na_str)+ data[, variables$strata, drop = FALSE] |
| 265 | +349 | ++ |
+ }+ |
+ |
| 350 | ||||
| 266 | +351 |
- # Add risk difference column+ # Add All Patients. |
||
| 267 | -10x | +352 | +18x |
- if (!is.null(riskdiff)) {
+ result_all <- h_odds_ratio_df( |
| 268 | -1x | +353 | +18x |
- if (is.null(riskdiff$arm_x)) riskdiff$arm_x <- levels(df$survtime$arm)[1]+ rsp = data[[variables$rsp]], |
| 269 | -1x | +354 | +18x |
- if (is.null(riskdiff$arm_y)) riskdiff$arm_y <- levels(df$survtime$arm)[2]+ arm = data[[variables$arm]], |
| 270 | -1x | +355 | +18x |
- colvars_hr$vars <- c(colvars_hr$vars, "riskdiff")+ strata_data = strata_data, |
| 271 | -1x | +356 | +18x |
- colvars_hr$labels <- c(colvars_hr$labels, riskdiff = riskdiff$col_label)+ conf_level = conf_level, |
| 272 | -1x | +357 | +18x |
- arm_cols <- paste(rep(c("n_events", "n_events", "n", "n")), c(riskdiff$arm_x, riskdiff$arm_y), sep = "_")
+ method = method |
| 273 | +358 |
-
+ ) |
||
| 274 | -1x | +359 | +18x |
- df_prop_diff <- df$survtime %>%+ result_all$subgroup <- label_all |
| 275 | -1x | +360 | +18x |
- dplyr::select(-"median") %>%+ result_all$var <- "ALL" |
| 276 | -1x | +361 | +18x |
- tidyr::pivot_wider(+ result_all$var_label <- label_all |
| 277 | -1x | +362 | +18x |
- id_cols = c("subgroup", "var", "var_label", "row_type"),
+ result_all$row_type <- "content"+ |
+
| 363 | ++ | + | ||
| 278 | -1x | +364 | +18x |
- names_from = "arm",+ if (is.null(variables$subgroups)) {
|
| 279 | -1x | +365 | +3x |
- values_from = c("n", "n_events")
+ result_all |
| 280 | +366 |
- ) %>%+ } else {
|
||
| 281 | -1x | +367 | +15x |
- dplyr::rowwise() %>%+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
| 282 | -1x | +|||
| 368 | +
- dplyr::mutate(+ |
|||
| 283 | -1x | +369 | +15x |
- riskdiff = stat_propdiff_ci(+ l_result <- lapply(l_data, function(grp) {
|
| 284 | -1x | +370 | +62x |
- x = as.list(.data[[arm_cols[1]]]),+ grp_strata_data <- if (is.null(variables$strata)) {
|
| 285 | -1x | +371 | +54x |
- y = as.list(.data[[arm_cols[2]]]),+ NULL |
| 286 | -1x | +|||
| 372 | +
- N_x = .data[[arm_cols[3]]],+ } else {
|
|||
| 287 | -1x | +373 | +8x |
- N_y = .data[[arm_cols[4]]]+ grp$df[, variables$strata, drop = FALSE] |
| 288 | +374 |
- )+ } |
||
| 289 | +375 |
- ) %>%+ |
||
| 290 | -1x | +376 | +62x |
- dplyr::select(-dplyr::all_of(arm_cols))+ result <- h_odds_ratio_df( |
| 291 | -+ | |||
| 377 | +62x |
-
+ rsp = grp$df[[variables$rsp]], |
||
| 292 | -1x | +378 | +62x |
- df$hr <- df$hr %>%+ arm = grp$df[[variables$arm]], |
| 293 | -1x | +379 | +62x |
- dplyr::left_join(+ strata_data = grp_strata_data, |
| 294 | -1x | +380 | +62x |
- df_prop_diff,+ conf_level = conf_level, |
| 295 | -1x | +381 | +62x |
- by = c("subgroup", "var", "var_label", "row_type")
+ method = method |
| 296 | +382 |
) |
||
| 297 | -+ | |||
| 383 | +62x |
- }+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
||
| 298 | -+ | |||
| 384 | +62x |
-
+ cbind(result, result_labels) |
||
| 299 | +385 |
- # Add columns from table_survtime (optional)+ }) |
||
| 300 | -10x | +|||
| 386 | +
- if (length(colvars_survtime$vars) > 0) {
+
|
|||
| 301 | -9x | +387 | +15x |
- lyt_survtime <- split_cols_by(lyt = lyt, var = "arm")+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 302 | -9x | +388 | +15x |
- lyt_survtime <- split_rows_by(+ result_subgroups$row_type <- "analysis" |
| 303 | -9x | +|||
| 389 | +
- lyt = lyt_survtime,+ |
|||
| 304 | -9x | +390 | +15x |
- var = "row_type",+ rbind( |
| 305 | -9x | +391 | +15x |
- split_fun = keep_split_levels("content"),
+ result_all, |
| 306 | -9x | +392 | +15x |
- nested = FALSE+ result_subgroups |
| 307 | +393 |
) |
||
| 308 | +394 |
-
+ } |
||
| 309 | +395 |
- # Add "All Patients" row+ } |
||
| 310 | -9x | +
| 1 | +
- lyt_survtime <- summarize_row_groups(+ #' Individual patient plots |
|||
| 311 | -9x | +|||
| 2 | +
- lyt = lyt_survtime,+ #' |
|||
| 312 | -9x | +|||
| 3 | +
- var = "var_label",+ #' @description `r lifecycle::badge("stable")`
|
|||
| 313 | -9x | +|||
| 4 | +
- cfun = afun_lst[names(colvars_survtime$labels)],+ #' |
|||
| 314 | -9x | +|||
| 5 | +
- na_str = na_str,+ #' Line plot(s) displaying trend in patients' parameter values over time is rendered. |
|||
| 315 | -9x | +|||
| 6 | +
- extra_args = extra_args+ #' Patients' individual baseline values can be added to the plot(s) as reference. |
|||
| 316 | +7 |
- )+ #' |
||
| 317 | -9x | +|||
| 8 | +
- lyt_survtime <- split_cols_by_multivar(+ #' @inheritParams argument_convention |
|||
| 318 | -9x | +|||
| 9 | +
- lyt = lyt_survtime,+ #' @param xvar (`string`)\cr time point variable to be plotted on x-axis. |
|||
| 319 | -9x | +|||
| 10 | +
- vars = colvars_survtime$vars,+ #' @param yvar (`string`)\cr continuous analysis variable to be plotted on y-axis. |
|||
| 320 | -9x | +|||
| 11 | +
- varlabels = colvars_survtime$labels+ #' @param xlab (`string`)\cr plot label for x-axis. |
|||
| 321 | +12 |
- )+ #' @param ylab (`string`)\cr plot label for y-axis. |
||
| 322 | +13 |
-
+ #' @param id_var (`string`)\cr variable used as patient identifier. |
||
| 323 | +14 |
- # Add analysis rows+ #' @param title (`string`)\cr title for plot. |
||
| 324 | -9x | +|||
| 15 | +
- if ("analysis" %in% df$survtime$row_type) {
+ #' @param subtitle (`string`)\cr subtitle for plot. |
|||
| 325 | -8x | +|||
| 16 | +
- lyt_survtime <- split_rows_by(+ #' @param add_baseline_hline (`flag`)\cr adds horizontal line at baseline y-value on |
|||
| 326 | -8x | +|||
| 17 | +
- lyt = lyt_survtime,+ #' plot when `TRUE`. |
|||
| 327 | -8x | +|||
| 18 | +
- var = "row_type",+ #' @param yvar_baseline (`string`)\cr variable with baseline values only. |
|||
| 328 | -8x | +|||
| 19 | +
- split_fun = keep_split_levels("analysis"),
+ #' Ignored when `add_baseline_hline` is `FALSE`. |
|||
| 329 | -8x | +|||
| 20 | +
- nested = FALSE,+ #' @param ggtheme (`theme`)\cr optional graphical theme function as provided |
|||
| 330 | -8x | +|||
| 21 | +
- child_labels = "hidden"+ #' by `ggplot2` to control outlook of plot. Use `ggplot2::theme()` to tweak the display. |
|||
| 331 | +22 |
- )+ #' @param plotting_choices (`string`)\cr specifies options for displaying |
||
| 332 | -8x | +|||
| 23 | +
- lyt_survtime <- split_rows_by(lyt = lyt_survtime, var = "var_label", nested = TRUE)+ #' plots. Must be one of `"all_in_one"`, `"split_by_max_obs"`, or `"separate_by_obs"`. |
|||
| 333 | -8x | +|||
| 24 | +
- lyt_survtime <- analyze_colvars(+ #' @param max_obs_per_plot (`integer(1)`)\cr number of observations to be plotted on one |
|||
| 334 | -8x | +|||
| 25 | +
- lyt = lyt_survtime,+ #' plot. Ignored if `plotting_choices` is not `"separate_by_obs"`. |
|||
| 335 | -8x | +|||
| 26 | +
- afun = afun_lst[names(colvars_survtime$labels)],+ #' @param caption (`string`)\cr optional caption below the plot. |
|||
| 336 | -8x | +|||
| 27 | +
- na_str = na_str,+ #' @param col (`character`)\cr line colors. |
|||
| 337 | -8x | +|||
| 28 | +
- inclNAs = TRUE,+ #' |
|||
| 338 | -8x | +|||
| 29 | +
- extra_args = extra_args+ #' @seealso Relevant helper function [h_g_ipp()]. |
|||
| 339 | +30 |
- )+ #' |
||
| 340 | +31 |
- }+ #' @name g_ipp |
||
| 341 | +32 |
-
+ #' @aliases individual_patient_plot |
||
| 342 | -9x | +|||
| 33 | +
- table_survtime <- build_table(lyt_survtime, df = df$survtime)+ NULL |
|||
| 343 | +34 |
- } else {
+
|
||
| 344 | -1x | +|||
| 35 | +
- table_survtime <- NULL+ #' Helper function to create simple line plot over time |
|||
| 345 | +36 |
- }+ #' |
||
| 346 | +37 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 347 | +38 |
- # Add columns from table_hr ("n_tot_events" or "n_tot", "or" and "ci" required)
+ #' |
||
| 348 | -10x | +|||
| 39 | +
- lyt_hr <- split_cols_by(lyt = lyt, var = "arm")+ #' Function that generates a simple line plot displaying parameter trends over time. |
|||
| 349 | -10x | +|||
| 40 | +
- lyt_hr <- split_rows_by(+ #' |
|||
| 350 | -10x | +|||
| 41 | +
- lyt = lyt_hr,+ #' @inheritParams argument_convention |
|||
| 351 | -10x | +|||
| 42 | +
- var = "row_type",+ #' @inheritParams g_ipp |
|||
| 352 | -10x | +|||
| 43 | +
- split_fun = keep_split_levels("content"),
+ #' |
|||
| 353 | -10x | +|||
| 44 | +
- nested = FALSE+ #' @return A `ggplot` line plot. |
|||
| 354 | +45 |
- )+ #' |
||
| 355 | -10x | +|||
| 46 | +
- lyt_hr <- summarize_row_groups(+ #' @seealso [g_ipp()] which uses this function. |
|||
| 356 | -10x | +|||
| 47 | +
- lyt = lyt_hr,+ #' |
|||
| 357 | -10x | +|||
| 48 | +
- var = "var_label",+ #' @examples |
|||
| 358 | -10x | +|||
| 49 | +
- cfun = afun_lst[names(colvars_hr$labels)],+ #' library(dplyr) |
|||
| 359 | -10x | +|||
| 50 | +
- na_str = na_str,+ #' library(nestcolor) |
|||
| 360 | -10x | +|||
| 51 | +
- extra_args = extra_args+ #' |
|||
| 361 | +52 |
- )+ #' # Select a small sample of data to plot. |
||
| 362 | -10x | +|||
| 53 | +
- lyt_hr <- split_cols_by_multivar(+ #' adlb <- tern_ex_adlb %>% |
|||
| 363 | -10x | +|||
| 54 | +
- lyt = lyt_hr,+ #' filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
|
|||
| 364 | -10x | +|||
| 55 | +
- vars = colvars_hr$vars,+ #' slice(1:36) |
|||
| 365 | -10x | +|||
| 56 | +
- varlabels = colvars_hr$labels+ #' |
|||
| 366 | +57 |
- ) %>%+ #' p <- h_g_ipp( |
||
| 367 | -10x | +|||
| 58 | +
- append_topleft("Baseline Risk Factors")
+ #' df = adlb, |
|||
| 368 | +59 |
-
+ #' xvar = "AVISIT", |
||
| 369 | +60 |
- # Add analysis rows+ #' yvar = "AVAL", |
||
| 370 | -10x | +|||
| 61 | +
- if ("analysis" %in% df$survtime$row_type) {
+ #' xlab = "Visit", |
|||
| 371 | -9x | +|||
| 62 | +
- lyt_hr <- split_rows_by(+ #' id_var = "USUBJID", |
|||
| 372 | -9x | +|||
| 63 | +
- lyt = lyt_hr,+ #' ylab = "SGOT/ALT (U/L)", |
|||
| 373 | -9x | +|||
| 64 | +
- var = "row_type",+ #' add_baseline_hline = TRUE |
|||
| 374 | -9x | +|||
| 65 | +
- split_fun = keep_split_levels("analysis"),
+ #' ) |
|||
| 375 | -9x | +|||
| 66 | +
- nested = FALSE,+ #' p |
|||
| 376 | -9x | +|||
| 67 | +
- child_labels = "hidden"+ #' |
|||
| 377 | +68 |
- )+ #' @export |
||
| 378 | -9x | +|||
| 69 | +
- lyt_hr <- split_rows_by(lyt = lyt_hr, var = "var_label", nested = TRUE)+ h_g_ipp <- function(df, |
|||
| 379 | -9x | +|||
| 70 | +
- lyt_hr <- analyze_colvars(+ xvar, |
|||
| 380 | -9x | +|||
| 71 | +
- lyt = lyt_hr,+ yvar, |
|||
| 381 | -9x | +|||
| 72 | +
- afun = afun_lst[names(colvars_hr$labels)],+ xlab, |
|||
| 382 | -9x | +|||
| 73 | +
- na_str = na_str,+ ylab, |
|||
| 383 | -9x | +|||
| 74 | +
- inclNAs = TRUE,+ id_var, |
|||
| 384 | -9x | +|||
| 75 | +
- extra_args = extra_args+ title = "Individual Patient Plots", |
|||
| 385 | +76 |
- )+ subtitle = "", |
||
| 386 | +77 |
- }+ caption = NULL, |
||
| 387 | +78 |
-
+ add_baseline_hline = FALSE, |
||
| 388 | -10x | +|||
| 79 | +
- table_hr <- build_table(lyt_hr, df = df$hr)+ yvar_baseline = "BASE", |
|||
| 389 | +80 |
-
+ ggtheme = nestcolor::theme_nest(), |
||
| 390 | +81 |
- # Join tables, add forest plot attributes+ col = NULL) {
|
||
| 391 | -10x | +82 | +13x |
- n_tot_ids <- grep("^n_tot", colvars_hr$vars)
+ checkmate::assert_string(xvar) |
| 392 | -10x | +83 | +13x |
- if (is.null(table_survtime)) {
+ checkmate::assert_string(yvar) |
| 393 | -1x | +84 | +13x |
- result <- table_hr+ checkmate::assert_string(yvar_baseline) |
| 394 | -1x | +85 | +13x |
- hr_id <- match("hr", colvars_hr$vars)
+ checkmate::assert_string(id_var) |
| 395 | -1x | +86 | +13x |
- ci_id <- match("ci", colvars_hr$vars)
+ checkmate::assert_string(xlab) |
| 396 | -+ | |||
| 87 | +13x |
- } else {
+ checkmate::assert_string(ylab) |
||
| 397 | -9x | +88 | +13x |
- result <- cbind_rtables(table_hr[, n_tot_ids], table_survtime, table_hr[, -n_tot_ids])+ checkmate::assert_string(title) |
| 398 | -9x | +89 | +13x |
- hr_id <- length(n_tot_ids) + ncol(table_survtime) + match("hr", colvars_hr$vars[-n_tot_ids])
+ checkmate::assert_string(subtitle) |
| 399 | -9x | +90 | +13x |
- ci_id <- length(n_tot_ids) + ncol(table_survtime) + match("ci", colvars_hr$vars[-n_tot_ids])
+ checkmate::assert_subset(c(xvar, yvar, yvar_baseline, id_var), colnames(df)) |
| 400 | -9x | +91 | +13x |
- n_tot_ids <- seq_along(n_tot_ids)+ checkmate::assert_data_frame(df) |
| 401 | -+ | |||
| 92 | +13x |
- }+ checkmate::assert_flag(add_baseline_hline) |
||
| 402 | -10x | +93 | +13x |
- structure(+ checkmate::assert_character(col, null.ok = TRUE) |
| 403 | -10x | +|||
| 94 | +
- result,+ |
|||
| 404 | -10x | +95 | +13x |
- forest_header = paste0(rev(levels(df$survtime$arm)), "\nBetter"),+ p <- ggplot2::ggplot( |
| 405 | -10x | +96 | +13x |
- col_x = hr_id,+ data = df, |
| 406 | -10x | +97 | +13x |
- col_ci = ci_id,+ mapping = ggplot2::aes( |
| 407 | -10x | +98 | +13x |
- col_symbol_size = n_tot_ids[1] # for scaling the symbol sizes in forest plots+ x = .data[[xvar]], |
| 408 | -+ | |||
| 99 | +13x |
- )+ y = .data[[yvar]], |
||
| 409 | -+ | |||
| 100 | +13x |
- }+ group = .data[[id_var]], |
||
| 410 | -+ | |||
| 101 | +13x |
-
+ colour = .data[[id_var]] |
||
| 411 | +102 |
- #' Labels for column variables in survival duration by subgroup table+ ) |
||
| 412 | +103 |
- #'+ ) + |
||
| 413 | -+ | |||
| 104 | +13x |
- #' @description `r lifecycle::badge("stable")`
+ ggplot2::geom_line(linewidth = 0.4) + |
||
| 414 | -+ | |||
| 105 | +13x |
- #'+ ggplot2::geom_point(size = 2) + |
||
| 415 | -+ | |||
| 106 | +13x |
- #' Internal function to check variables included in [tabulate_survival_subgroups()] and create column labels.+ ggplot2::labs( |
||
| 416 | -+ | |||
| 107 | +13x |
- #'+ x = xlab, |
||
| 417 | -+ | |||
| 108 | +13x |
- #' @inheritParams tabulate_survival_subgroups+ y = ylab, |
||
| 418 | -+ | |||
| 109 | +13x |
- #' @inheritParams argument_convention+ title = title, |
||
| 419 | -+ | |||
| 110 | +13x |
- #' @param method (`string`)\cr p-value method for testing hazard ratio = 1.+ subtitle = subtitle, |
||
| 420 | -+ | |||
| 111 | +13x |
- #'+ caption = caption |
||
| 421 | +112 |
- #' @return A `list` of variables and their labels to tabulate.+ ) + |
||
| 422 | -+ | |||
| 113 | +13x |
- #'+ ggtheme |
||
| 423 | +114 |
- #' @note At least one of `n_tot` and `n_tot_events` must be provided in `vars`.+ |
||
| 424 | -+ | |||
| 115 | +13x |
- #'+ if (add_baseline_hline) {
|
||
| 425 | -+ | |||
| 116 | +12x |
- #' @export+ baseline_df <- df[, c(id_var, yvar_baseline)] |
||
| 426 | -+ | |||
| 117 | +12x |
- d_survival_subgroups_colvars <- function(vars,+ baseline_df <- unique(baseline_df) |
||
| 427 | +118 |
- conf_level,+ |
||
| 428 | -+ | |||
| 119 | +12x |
- method,+ p <- p + |
||
| 429 | -+ | |||
| 120 | +12x |
- time_unit = NULL) {
+ ggplot2::geom_hline( |
||
| 430 | -21x | +121 | +12x |
- checkmate::assert_character(vars)+ data = baseline_df, |
| 431 | -21x | +122 | +12x |
- checkmate::assert_string(time_unit, null.ok = TRUE)+ mapping = ggplot2::aes( |
| 432 | -21x | +123 | +12x |
- checkmate::assert_subset(c("hr", "ci"), vars)
+ yintercept = .data[[yvar_baseline]], |
| 433 | -21x | +124 | +12x |
- checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
+ colour = .data[[id_var]] |
| 434 | -21x | +|||
| 125 | +
- checkmate::assert_subset(+ ), |
|||
| 435 | -21x | +126 | +12x |
- vars,+ linetype = "dotdash", |
| 436 | -21x | +127 | +12x |
- c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
+ linewidth = 0.4 |
| 437 | +128 |
- )+ ) + |
||
| 438 | -+ | |||
| 129 | +12x |
-
+ ggplot2::geom_text( |
||
| 439 | -21x | +130 | +12x |
- propcase_time_label <- if (!is.null(time_unit)) {
+ data = baseline_df, |
| 440 | -20x | +131 | +12x |
- paste0("Median (", time_unit, ")")
+ mapping = ggplot2::aes( |
| 441 | -+ | |||
| 132 | +12x |
- } else {
+ x = 1, |
||
| 442 | -1x | +133 | +12x |
- "Median"+ y = .data[[yvar_baseline]], |
| 443 | -+ | |||
| 134 | +12x |
- }+ label = .data[[id_var]], |
||
| 444 | -+ | |||
| 135 | +12x |
-
+ colour = .data[[id_var]] |
||
| 445 | -21x | +|||
| 136 | +
- varlabels <- c(+ ), |
|||
| 446 | -21x | +137 | +12x |
- n = "n",+ nudge_y = 0.025 * (max(df[, yvar], na.rm = TRUE) - min(df[, yvar], na.rm = TRUE)), |
| 447 | -21x | +138 | +12x |
- n_events = "Events",+ vjust = "right", |
| 448 | -21x | +139 | +12x |
- median = propcase_time_label,+ size = 2 |
| 449 | -21x | +|||
| 140 | +
- n_tot = "Total n",+ ) |
|||
| 450 | -21x | +|||
| 141 | +
- n_tot_events = "Total Events",+ |
|||
| 451 | -21x | +142 | +12x |
- hr = "Hazard Ratio",+ if (!is.null(col)) {
|
| 452 | -21x | +143 | +1x |
- ci = paste0(100 * conf_level, "% Wald CI"),+ p <- p + |
| 453 | -21x | +144 | +1x |
- pval = method+ ggplot2::scale_color_manual(values = col) |
| 454 | +145 |
- )+ } |
||
| 455 | +146 |
-
+ } |
||
| 456 | -21x | +147 | +13x |
- colvars <- vars+ p |
| 457 | +148 |
-
+ } |
||
| 458 | +149 |
- # The `lcl` variable is just a placeholder available in the analysis data,+ |
||
| 459 | +150 |
- # it is not acutally used in the tabulation.+ #' @describeIn g_ipp Plotting function for individual patient plots which, depending on user |
||
| 460 | +151 |
- # Variables used in the tabulation are lcl and ucl, see `a_survival_subgroups` for details.+ #' preference, renders a single graphic or compiles a list of graphics that show trends in individual's parameter |
||
| 461 | -21x | +|||
| 152 | +
- colvars[colvars == "ci"] <- "lcl"+ #' values over time. |
|||
| 462 | +153 |
-
+ #' |
||
| 463 | -21x | +|||
| 154 | +
- list(+ #' @return A `ggplot` object or a list of `ggplot` objects. |
|||
| 464 | -21x | +|||
| 155 | +
- vars = colvars,+ #' |
|||
| 465 | -21x | +|||
| 156 | +
- labels = varlabels[vars]+ #' @examples |
|||
| 466 | +157 |
- )+ #' library(dplyr) |
||
| 467 | +158 |
- }+ #' library(nestcolor) |
| 1 | +159 |
- #' Line plot with optional table+ #' |
|
| 2 | +160 |
- #'+ #' # Select a small sample of data to plot. |
|
| 3 | +161 |
- #' @description `r lifecycle::badge("stable")`
+ #' adlb <- tern_ex_adlb %>% |
|
| 4 | +162 |
- #'+ #' filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
|
|
| 5 | +163 |
- #' Line plot with the optional table.+ #' slice(1:36) |
|
| 6 | +164 |
#' |
|
| 7 | +165 |
- #' @inheritParams argument_convention+ #' plot_list <- g_ipp( |
|
| 8 | +166 |
- #' @param alt_counts_df (`data.frame` or `NULL`)\cr data set that will be used (only)+ #' df = adlb, |
|
| 9 | +167 |
- #' to counts objects in groups for stratification.+ #' xvar = "AVISIT", |
|
| 10 | +168 |
- #' @param variables (named `character`) vector of variable names in `df` which should include:+ #' yvar = "AVAL", |
|
| 11 | +169 |
- #' * `x` (`string`)\cr name of x-axis variable.+ #' xlab = "Visit", |
|
| 12 | +170 |
- #' * `y` (`string`)\cr name of y-axis variable.+ #' ylab = "SGOT/ALT (U/L)", |
|
| 13 | +171 |
- #' * `group_var` (`string` or `NULL`)\cr name of grouping variable (or strata), i.e. treatment arm.+ #' title = "Individual Patient Plots", |
|
| 14 | +172 |
- #' Can be `NA` to indicate lack of groups.+ #' add_baseline_hline = TRUE, |
|
| 15 | +173 |
- #' * `subject_var` (`string` or `NULL`)\cr name of subject variable. Only applies if `group_var` is+ #' plotting_choices = "split_by_max_obs", |
|
| 16 | +174 |
- #' not NULL.+ #' max_obs_per_plot = 5 |
|
| 17 | +175 |
- #' * `paramcd` (`string` or `NA`)\cr name of the variable for parameter's code. Used for y-axis label and plot's+ #' ) |
|
| 18 | +176 |
- #' subtitle. Can be `NA` if `paramcd` is not to be added to the y-axis label or subtitle.+ #' plot_list |
|
| 19 | +177 |
- #' * `y_unit` (`string` or `NA`)\cr name of variable with units of `y`. Used for y-axis label and plot's subtitle.+ #' |
|
| 20 | +178 |
- #' Can be `NA` if y unit is not to be added to the y-axis label or subtitle.+ #' @export |
|
| 21 | +179 |
- #' * `facet_var` (`string` or `NA`)\cr name of the secondary grouping variable used for plot faceting, i.e. treatment+ g_ipp <- function(df, |
|
| 22 | +180 |
- #' arm. Can be `NA` to indicate lack of groups.+ xvar, |
|
| 23 | +181 |
- #' @param mid (`character` or `NULL`)\cr names of the statistics that will be plotted as midpoints.+ yvar, |
|
| 24 | +182 |
- #' All the statistics indicated in `mid` variable must be present in the object returned by `sfun`,+ xlab, |
|
| 25 | +183 |
- #' and be of a `double` or `numeric` type vector of length one.+ ylab, |
|
| 26 | +184 |
- #' @param interval (`character` or `NULL`)\cr names of the statistics that will be plotted as intervals.+ id_var = "USUBJID", |
|
| 27 | +185 |
- #' All the statistics indicated in `interval` variable must be present in the object returned by `sfun`,+ title = "Individual Patient Plots", |
|
| 28 | +186 |
- #' and be of a `double` or `numeric` type vector of length two. Set `interval = NULL` if intervals should not be+ subtitle = "", |
|
| 29 | +187 |
- #' added to the plot.+ caption = NULL, |
|
| 30 | +188 |
- #' @param whiskers (`character`)\cr names of the interval whiskers that will be plotted. Names must match names+ add_baseline_hline = FALSE, |
|
| 31 | +189 |
- #' of the list element `interval` that will be returned by `sfun` (e.g. `mean_ci_lwr` element of+ yvar_baseline = "BASE", |
|
| 32 | +190 |
- #' `sfun(x)[["mean_ci"]]`). It is possible to specify one whisker only, or to suppress all whiskers by setting+ ggtheme = nestcolor::theme_nest(), |
|
| 33 | +191 |
- #' `interval = NULL`.+ plotting_choices = c("all_in_one", "split_by_max_obs", "separate_by_obs"),
|
|
| 34 | +192 |
- #' @param table (`character` or `NULL`)\cr names of the statistics that will be displayed in the table below the plot.+ max_obs_per_plot = 4, |
|
| 35 | +193 |
- #' All the statistics indicated in `table` variable must be present in the object returned by `sfun`.+ col = NULL) {
|
|
| 36 | -+ | ||
| 194 | +3x |
- #' @param sfun (`function`)\cr the function to compute the values of required statistics. It must return a named `list`+ checkmate::assert_count(max_obs_per_plot) |
|
| 37 | -+ | ||
| 195 | +3x |
- #' with atomic vectors. The names of the `list` elements refer to the names of the statistics and are used by `mid`,+ checkmate::assert_subset(plotting_choices, c("all_in_one", "split_by_max_obs", "separate_by_obs"))
+ |
+ |
| 196 | +3x | +
+ checkmate::assert_character(col, null.ok = TRUE) |
|
| 38 | +197 |
- #' `interval`, `table`. It must be able to accept as input a vector with data for which statistics are computed.+ + |
+ |
| 198 | +3x | +
+ plotting_choices <- match.arg(plotting_choices) |
|
| 39 | +199 |
- #' @param ... optional arguments to `sfun`.+ + |
+ |
| 200 | +3x | +
+ if (plotting_choices == "all_in_one") {
+ |
+ |
| 201 | +1x | +
+ p <- h_g_ipp(+ |
+ |
| 202 | +1x | +
+ df = df,+ |
+ |
| 203 | +1x | +
+ xvar = xvar,+ |
+ |
| 204 | +1x | +
+ yvar = yvar,+ |
+ |
| 205 | +1x | +
+ xlab = xlab,+ |
+ |
| 206 | +1x | +
+ ylab = ylab,+ |
+ |
| 207 | +1x | +
+ id_var = id_var,+ |
+ |
| 208 | +1x | +
+ title = title,+ |
+ |
| 209 | +1x | +
+ subtitle = subtitle,+ |
+ |
| 210 | +1x | +
+ caption = caption,+ |
+ |
| 211 | +1x | +
+ add_baseline_hline = add_baseline_hline,+ |
+ |
| 212 | +1x | +
+ yvar_baseline = yvar_baseline, |
|
| 40 | -+ | ||
| 213 | +1x |
- #' @param mid_type (`string`)\cr controls the type of the `mid` plot, it can be point (`"p"`), line (`"l"`),+ ggtheme = ggtheme, |
|
| 41 | -+ | ||
| 214 | +1x |
- #' or point and line (`"pl"`).+ col = col |
|
| 42 | +215 |
- #' @param mid_point_size (`numeric(1)`)\cr font size of the `mid` plot points.+ ) |
|
| 43 | +216 |
- #' @param position (`character` or `call`)\cr geom element position adjustment, either as a string, or the result of+ |
|
| 44 | -+ | ||
| 217 | +1x |
- #' a call to a position adjustment function.+ return(p) |
|
| 45 | -+ | ||
| 218 | +2x |
- #' @param legend_title (`string`)\cr legend title.+ } else if (plotting_choices == "split_by_max_obs") {
|
|
| 46 | -+ | ||
| 219 | +1x |
- #' @param legend_position (`string`)\cr the position of the plot legend (`"none"`, `"left"`, `"right"`, `"bottom"`,+ id_vec <- unique(df[[id_var]]) |
|
| 47 | -+ | ||
| 220 | +1x |
- #' `"top"`, or a two-element numeric vector).+ id_list <- split( |
|
| 48 | -+ | ||
| 221 | +1x |
- #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot.+ id_vec, |
|
| 49 | -+ | ||
| 222 | +1x |
- #' @param xticks (`numeric` or `NULL`)\cr numeric vector of tick positions or a single number with spacing+ rep(1:ceiling(length(id_vec) / max_obs_per_plot), |
|
| 50 | -+ | ||
| 223 | +1x |
- #' between ticks on the x-axis, for use when `variables$x` is numeric. If `NULL` (default), [labeling::extended()] is+ each = max_obs_per_plot, |
|
| 51 | -+ | ||
| 224 | +1x |
- #' used to determine optimal tick positions on the x-axis. If `variables$x` is not numeric, this argument is ignored.+ length.out = length(id_vec) |
|
| 52 | +225 |
- #' @param x_lab (`string` or `NULL`)\cr x-axis label. If `NULL` then no label will be added.+ ) |
|
| 53 | +226 |
- #' @param y_lab (`string` or `NULL`)\cr y-axis label. If `NULL` then no label will be added.+ ) |
|
| 54 | +227 |
- #' @param y_lab_add_paramcd (`flag`)\cr whether `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` should be added+ |
|
| 55 | -+ | ||
| 228 | +1x |
- #' to the y-axis label (`y_lab`).+ df_list <- list() |
|
| 56 | -+ | ||
| 229 | +1x |
- #' @param y_lab_add_unit (`flag`)\cr whether y-axis unit, i.e. `unique(df[[variables["y_unit"]]])` should be added+ plot_list <- list() |
|
| 57 | +230 |
- #' to the y-axis label (`y_lab`).+ |
|
| 58 | -+ | ||
| 231 | +1x |
- #' @param title (`string`)\cr plot title.+ for (i in seq_along(id_list)) {
|
|
| 59 | -+ | ||
| 232 | +2x |
- #' @param subtitle (`string`)\cr plot subtitle.+ df_list[[i]] <- df[df[[id_var]] %in% id_list[[i]], ] |
|
| 60 | +233 |
- #' @param subtitle_add_paramcd (`flag`)\cr whether `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` should be+ |
|
| 61 | -+ | ||
| 234 | +2x |
- #' added to the plot's subtitle (`subtitle`).+ plots <- h_g_ipp( |
|
| 62 | -+ | ||
| 235 | +2x |
- #' @param subtitle_add_unit (`flag`)\cr whether the y-axis unit, i.e. `unique(df[[variables["y_unit"]]])` should be+ df = df_list[[i]], |
|
| 63 | -+ | ||
| 236 | +2x |
- #' added to the plot's subtitle (`subtitle`).+ xvar = xvar, |
|
| 64 | -+ | ||
| 237 | +2x |
- #' @param caption (`string`)\cr optional caption below the plot.+ yvar = yvar, |
|
| 65 | -+ | ||
| 238 | +2x |
- #' @param table_format (named `character` or `NULL`)\cr format patterns for descriptive statistics used in the+ xlab = xlab, |
|
| 66 | -+ | ||
| 239 | +2x |
- #' (optional) table appended to the plot. It is passed directly to the `h_format_row` function through the `format`+ ylab = ylab, |
|
| 67 | -+ | ||
| 240 | +2x |
- #' parameter. Names of `table_format` must match the names of statistics returned by `sfun` function.+ id_var = id_var, |
|
| 68 | -+ | ||
| 241 | +2x |
- #' @param table_labels (named `character` or `NULL`)\cr labels for descriptive statistics used in the (optional) table+ title = title, |
|
| 69 | -+ | ||
| 242 | +2x |
- #' appended to the plot. Names of `table_labels` must match the names of statistics returned by `sfun` function.+ subtitle = subtitle, |
|
| 70 | -+ | ||
| 243 | +2x |
- #' @param table_font_size (`numeric(1)`)\cr font size of the text in the table.+ caption = caption, |
|
| 71 | -+ | ||
| 244 | +2x |
- #' @param newpage `r lifecycle::badge("deprecated")` not used.
+ add_baseline_hline = add_baseline_hline, |
|
| 72 | -+ | ||
| 245 | +2x |
- #' @param col (`character`)\cr color(s). See `?ggplot2::aes_colour_fill_alpha` for example values.+ yvar_baseline = yvar_baseline, |
|
| 73 | -+ | ||
| 246 | +2x |
- #' @param linetype (`character`)\cr line type(s). See `?ggplot2::aes_linetype_size_shape` for example values.+ ggtheme = ggtheme, |
|
| 74 | -+ | ||
| 247 | +2x |
- #' @param errorbar_width (`numeric(1)`)\cr width of the error bars.+ col = col |
|
| 75 | +248 |
- #'+ ) |
|
| 76 | +249 |
- #' @return A `ggplot` line plot (and statistics table if applicable).+ |
|
| 77 | -+ | ||
| 250 | +2x |
- #'+ plot_list[[i]] <- plots |
|
| 78 | +251 |
- #' @examples+ } |
|
| 79 | -+ | ||
| 252 | +1x |
- #' library(nestcolor)+ return(plot_list) |
|
| 80 | +253 |
- #'+ } else {
|
|
| 81 | -+ | ||
| 254 | +1x |
- #' adsl <- tern_ex_adsl+ ind_df <- split(df, df[[id_var]]) |
|
| 82 | -+ | ||
| 255 | +1x |
- #' adlb <- tern_ex_adlb %>% dplyr::filter(ANL01FL == "Y", PARAMCD == "ALT", AVISIT != "SCREENING")+ plot_list <- lapply( |
|
| 83 | -+ | ||
| 256 | +1x |
- #' adlb$AVISIT <- droplevels(adlb$AVISIT)+ ind_df, |
|
| 84 | -+ | ||
| 257 | +1x |
- #' adlb <- dplyr::mutate(adlb, AVISIT = forcats::fct_reorder(AVISIT, AVISITN, min))+ function(x) {
|
|
| 85 | -+ | ||
| 258 | +8x |
- #'+ h_g_ipp( |
|
| 86 | -+ | ||
| 259 | +8x |
- #' # Mean with CI+ df = x, |
|
| 87 | -+ | ||
| 260 | +8x |
- #' g_lineplot(adlb, adsl, subtitle = "Laboratory Test:")+ xvar = xvar, |
|
| 88 | -+ | ||
| 261 | +8x |
- #'+ yvar = yvar, |
|
| 89 | -+ | ||
| 262 | +8x |
- #' # Mean with CI, no stratification with group_var+ xlab = xlab, |
|
| 90 | -+ | ||
| 263 | +8x |
- #' g_lineplot(adlb, variables = control_lineplot_vars(group_var = NA))+ ylab = ylab, |
|
| 91 | -+ | ||
| 264 | +8x |
- #'+ id_var = id_var, |
|
| 92 | -+ | ||
| 265 | +8x |
- #' # Mean, upper whisker of CI, no group_var(strata) counts N+ title = title, |
|
| 93 | -+ | ||
| 266 | +8x |
- #' g_lineplot(+ subtitle = subtitle, |
|
| 94 | -+ | ||
| 267 | +8x |
- #' adlb,+ caption = caption, |
|
| 95 | -+ | ||
| 268 | +8x |
- #' whiskers = "mean_ci_upr",+ add_baseline_hline = add_baseline_hline, |
|
| 96 | -+ | ||
| 269 | +8x |
- #' title = "Plot of Mean and Upper 95% Confidence Limit by Visit"+ yvar_baseline = yvar_baseline, |
|
| 97 | -+ | ||
| 270 | +8x |
- #' )+ ggtheme = ggtheme, |
|
| 98 | -+ | ||
| 271 | +8x |
- #'+ col = col |
|
| 99 | +272 |
- #' # Median with CI+ ) |
|
| 100 | +273 |
- #' g_lineplot(+ } |
|
| 101 | +274 |
- #' adlb,+ ) |
|
| 102 | +275 |
- #' adsl,+ |
|
| 103 | -+ | ||
| 276 | +1x |
- #' mid = "median",+ return(plot_list) |
|
| 104 | +277 |
- #' interval = "median_ci",+ } |
|
| 105 | +278 |
- #' whiskers = c("median_ci_lwr", "median_ci_upr"),
+ } |
| 106 | +1 |
- #' title = "Plot of Median and 95% Confidence Limits by Visit"+ #' Helper functions for Cox proportional hazards regression |
||
| 107 | +2 |
- #' )+ #' |
||
| 108 | +3 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 109 | +4 |
- #' # Mean, +/- SD+ #' |
||
| 110 | +5 |
- #' g_lineplot(adlb, adsl,+ #' Helper functions used in [fit_coxreg_univar()] and [fit_coxreg_multivar()]. |
||
| 111 | +6 |
- #' interval = "mean_sdi",+ #' |
||
| 112 | +7 |
- #' whiskers = c("mean_sdi_lwr", "mean_sdi_upr"),
+ #' @inheritParams argument_convention |
||
| 113 | +8 |
- #' title = "Plot of Median +/- SD by Visit"+ #' @inheritParams h_coxreg_univar_extract |
||
| 114 | +9 |
- #' )+ #' @inheritParams cox_regression_inter |
||
| 115 | +10 |
- #'+ #' @inheritParams control_coxreg |
||
| 116 | +11 |
- #' # Mean with CI plot with stats table+ #' |
||
| 117 | +12 |
- #' g_lineplot(adlb, adsl, table = c("n", "mean", "mean_ci"))
+ #' @seealso [cox_regression] |
||
| 118 | +13 |
#' |
||
| 119 | +14 |
- #' # Mean with CI, table and customized confidence level+ #' @name h_cox_regression |
||
| 120 | +15 |
- #' g_lineplot(+ NULL |
||
| 121 | +16 |
- #' adlb,+ |
||
| 122 | +17 |
- #' adsl,+ #' @describeIn h_cox_regression Helper for Cox regression formula. Creates a list of formulas. It is used |
||
| 123 | +18 |
- #' table = c("n", "mean", "mean_ci"),
+ #' internally by [fit_coxreg_univar()] for the comparison of univariate Cox regression models. |
||
| 124 | +19 |
- #' control = control_analyze_vars(conf_level = 0.80),+ #' |
||
| 125 | +20 |
- #' title = "Plot of Mean and 80% Confidence Limits by Visit"+ #' @return |
||
| 126 | +21 |
- #' )+ #' * `h_coxreg_univar_formulas()` returns a `character` vector coercible into formulas (e.g [stats::as.formula()]). |
||
| 127 | +22 |
#' |
||
| 128 | +23 |
- #' # Mean with CI, table, filtered data+ #' @examples |
||
| 129 | +24 |
- #' adlb_f <- dplyr::filter(adlb, ARMCD != "ARM A" | AVISIT == "BASELINE")+ #' # `h_coxreg_univar_formulas` |
||
| 130 | +25 |
- #' g_lineplot(adlb_f, table = c("n", "mean"))
+ #' |
||
| 131 | +26 |
- #'+ #' ## Simple formulas. |
||
| 132 | +27 |
- #' @export+ #' h_coxreg_univar_formulas( |
||
| 133 | +28 |
- g_lineplot <- function(df,+ #' variables = list( |
||
| 134 | +29 |
- alt_counts_df = NULL,+ #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y")
|
||
| 135 | +30 |
- variables = control_lineplot_vars(),+ #' ) |
||
| 136 | +31 |
- mid = "mean",+ #' ) |
||
| 137 | +32 |
- interval = "mean_ci",+ #' |
||
| 138 | +33 |
- whiskers = c("mean_ci_lwr", "mean_ci_upr"),
+ #' ## Addition of an optional strata. |
||
| 139 | +34 |
- table = NULL,+ #' h_coxreg_univar_formulas( |
||
| 140 | +35 |
- sfun = s_summary,+ #' variables = list( |
||
| 141 | +36 |
- ...,+ #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
|
||
| 142 | +37 |
- mid_type = "pl",+ #' strata = "SITE" |
||
| 143 | +38 |
- mid_point_size = 2,+ #' ) |
||
| 144 | +39 |
- position = ggplot2::position_dodge(width = 0.4),+ #' ) |
||
| 145 | +40 |
- legend_title = NULL,+ #' |
||
| 146 | +41 |
- legend_position = "bottom",+ #' ## Inclusion of the interaction term. |
||
| 147 | +42 |
- ggtheme = nestcolor::theme_nest(),+ #' h_coxreg_univar_formulas( |
||
| 148 | +43 |
- xticks = NULL,+ #' variables = list( |
||
| 149 | +44 |
- xlim = NULL,+ #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
|
||
| 150 | +45 |
- ylim = NULL,+ #' strata = "SITE" |
||
| 151 | +46 |
- x_lab = obj_label(df[[variables[["x"]]]]),+ #' ), |
||
| 152 | +47 |
- y_lab = NULL,+ #' interaction = TRUE |
||
| 153 | +48 |
- y_lab_add_paramcd = TRUE,+ #' ) |
||
| 154 | +49 |
- y_lab_add_unit = TRUE,+ #' |
||
| 155 | +50 |
- title = "Plot of Mean and 95% Confidence Limits by Visit",+ #' ## Only covariates fitted in separate models. |
||
| 156 | +51 |
- subtitle = "",+ #' h_coxreg_univar_formulas( |
||
| 157 | +52 |
- subtitle_add_paramcd = TRUE,+ #' variables = list( |
||
| 158 | +53 |
- subtitle_add_unit = TRUE,+ #' time = "time", event = "status", covariates = c("X", "y")
|
||
| 159 | +54 |
- caption = NULL,+ #' ) |
||
| 160 | +55 |
- table_format = NULL,+ #' ) |
||
| 161 | +56 |
- table_labels = NULL,+ #' |
||
| 162 | +57 |
- table_font_size = 3,+ #' @export |
||
| 163 | +58 |
- errorbar_width = 0.45,+ h_coxreg_univar_formulas <- function(variables, |
||
| 164 | +59 |
- newpage = lifecycle::deprecated(),+ interaction = FALSE) {
|
||
| 165 | -+ | |||
| 60 | +50x |
- col = NULL,+ checkmate::assert_list(variables, names = "named") |
||
| 166 | -+ | |||
| 61 | +50x |
- linetype = NULL) {
+ has_arm <- "arm" %in% names(variables) |
||
| 167 | -12x | +62 | +50x |
- checkmate::assert_character(variables, any.missing = TRUE)+ arm_name <- if (has_arm) "arm" else NULL |
| 168 | -12x | +|||
| 63 | +
- checkmate::assert_character(mid, null.ok = TRUE)+ |
|||
| 169 | -12x | +64 | +50x |
- checkmate::assert_character(interval, null.ok = TRUE)+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
| 170 | -12x | +|||
| 65 | +
- checkmate::assert_character(col, null.ok = TRUE)+ |
|||
| 171 | -12x | +66 | +50x |
- checkmate::assert_character(linetype, null.ok = TRUE)+ checkmate::assert_flag(interaction) |
| 172 | -12x | +|||
| 67 | +
- checkmate::assert_numeric(xticks, null.ok = TRUE)+ |
|||
| 173 | -12x | +68 | +50x |
- checkmate::assert_numeric(xlim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE)+ if (!has_arm || is.null(variables$covariates)) {
|
| 174 | -12x | +69 | +10x |
- checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE)+ checkmate::assert_false(interaction) |
| 175 | -12x | +|||
| 70 | +
- checkmate::assert_number(errorbar_width, lower = 0)+ } |
|||
| 176 | -12x | +|||
| 71 | +
- checkmate::assert_string(title, null.ok = TRUE)+ |
|||
| 177 | -12x | +72 | +48x |
- checkmate::assert_string(subtitle, null.ok = TRUE)+ assert_list_of_variables(variables[c(arm_name, "event", "time")]) |
| 178 | +73 | |||
| 179 | -12x | +74 | +48x |
- if (!is.null(table)) {
+ if (!is.null(variables$covariates)) {
|
| 180 | -4x | +75 | +47x |
- table_format <- get_formats_from_stats(table)+ forms <- paste0( |
| 181 | -4x | +76 | +47x |
- table_labels <- get_labels_from_stats(table)+ "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
|
| 182 | -+ | |||
| 77 | +47x |
- }+ ifelse(has_arm, variables$arm, "1"), |
||
| 183 | -+ | |||
| 78 | +47x |
-
+ ifelse(interaction, " * ", " + "), |
||
| 184 | -12x | +79 | +47x |
- extra_args <- list(...)+ variables$covariates, |
| 185 | -12x | +80 | +47x |
- if ("control" %in% names(extra_args)) {
+ ifelse( |
| 186 | -4x | +81 | +47x |
- if (!is.null(table) && all(table_labels == get_labels_from_stats(table))) {
+ !is.null(variables$strata), |
| 187 | -3x | +82 | +47x |
- table_labels <- table_labels %>% labels_use_control(extra_args[["control"]])+ paste0(" + strata(", paste0(variables$strata, collapse = ", "), ")"),
|
| 188 | +83 |
- }+ "" |
||
| 189 | +84 |
- }+ ) |
||
| 190 | +85 |
-
+ ) |
||
| 191 | -12x | +|||
| 86 | +
- if (is.character(interval)) {
+ } else {
|
|||
| 192 | -12x | +87 | +1x |
- checkmate::assert_vector(whiskers, min.len = 0, max.len = 2)+ forms <- NULL |
| 193 | +88 |
} |
||
| 194 | -+ | |||
| 89 | +48x |
-
+ nams <- variables$covariates |
||
| 195 | -12x | +90 | +48x |
- if (length(whiskers) == 1) {
+ if (has_arm) {
|
| 196 | -! | +|||
| 91 | +41x |
- checkmate::assert_character(mid)+ ref <- paste0( |
||
| 197 | -+ | |||
| 92 | +41x |
- }+ "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
|
||
| 198 | -+ | |||
| 93 | +41x |
-
+ variables$arm, |
||
| 199 | -12x | +94 | +41x |
- if (is.character(mid)) {
+ ifelse( |
| 200 | -12x | +95 | +41x |
- checkmate::assert_scalar(mid_type)+ !is.null(variables$strata), |
| 201 | -12x | +96 | +41x |
- checkmate::assert_subset(mid_type, c("pl", "p", "l"))
+ paste0(+ |
+
| 97 | +41x | +
+ " + strata(", paste0(variables$strata, collapse = ", "), ")"
|
||
| 202 | +98 |
- }+ ), |
||
| 203 | +99 |
-
+ "" |
||
| 204 | -12x | +|||
| 100 | +
- x <- variables[["x"]]+ ) |
|||
| 205 | -12x | +|||
| 101 | +
- y <- variables[["y"]]+ ) |
|||
| 206 | -12x | +102 | +41x |
- paramcd <- variables["paramcd"] # NA if paramcd == NA or it is not in variables+ forms <- c(ref, forms) |
| 207 | -12x | +103 | +41x |
- y_unit <- variables["y_unit"] # NA if y_unit == NA or it is not in variables+ nams <- c("ref", nams)
|
| 208 | -12x | +|||
| 104 | +
- if (is.na(variables["group_var"])) {
+ } |
|||
| 209 | -1x | +105 | +48x |
- group_var <- NULL # NULL if group_var == NA or it is not in variables+ stats::setNames(forms, nams) |
| 210 | +106 |
- } else {
+ } |
||
| 211 | -11x | +|||
| 107 | +
- group_var <- variables[["group_var"]]+ |
|||
| 212 | -11x | +|||
| 108 | +
- subject_var <- variables[["subject_var"]]+ #' @describeIn h_cox_regression Helper for multivariate Cox regression formula. Creates a formulas |
|||
| 213 | +109 |
- }+ #' string. It is used internally by [fit_coxreg_multivar()] for the comparison of multivariate Cox |
||
| 214 | -12x | +|||
| 110 | +
- if (is.na(variables["facet_var"])) {
+ #' regression models. Interactions will not be included in multivariate Cox regression model. |
|||
| 215 | -11x | +|||
| 111 | +
- facet_var <- NULL # NULL if facet_var == NA or it is not in variables+ #' |
|||
| 216 | +112 |
- } else {
+ #' @return |
||
| 217 | -1x | +|||
| 113 | +
- facet_var <- variables[["facet_var"]]+ #' * `h_coxreg_multivar_formula()` returns a `string` coercible into a formula (e.g [stats::as.formula()]). |
|||
| 218 | +114 |
- }+ #' |
||
| 219 | -12x | +|||
| 115 | +
- checkmate::assert_flag(y_lab_add_paramcd, null.ok = TRUE)+ #' @examples |
|||
| 220 | -12x | +|||
| 116 | +
- checkmate::assert_flag(subtitle_add_paramcd, null.ok = TRUE)+ #' # `h_coxreg_multivar_formula` |
|||
| 221 | -12x | +|||
| 117 | +
- if ((!is.null(y_lab) && y_lab_add_paramcd) || (!is.null(subtitle) && subtitle_add_paramcd)) {
+ #' |
|||
| 222 | -12x | +|||
| 118 | +
- checkmate::assert_false(is.na(paramcd))+ #' h_coxreg_multivar_formula( |
|||
| 223 | -12x | +|||
| 119 | +
- checkmate::assert_scalar(unique(df[[paramcd]]))+ #' variables = list( |
|||
| 224 | +120 |
- }+ #' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE")
|
||
| 225 | +121 |
-
+ #' ) |
||
| 226 | -12x | +|||
| 122 | +
- checkmate::assert_flag(y_lab_add_unit, null.ok = TRUE)+ #' ) |
|||
| 227 | -12x | +|||
| 123 | +
- checkmate::assert_flag(subtitle_add_unit, null.ok = TRUE)+ #' |
|||
| 228 | -12x | +|||
| 124 | +
- if ((!is.null(y_lab) && y_lab_add_unit) || (!is.null(subtitle) && subtitle_add_unit)) {
+ #' # Addition of an optional strata. |
|||
| 229 | -12x | +|||
| 125 | +
- checkmate::assert_false(is.na(y_unit))+ #' h_coxreg_multivar_formula( |
|||
| 230 | -12x | +|||
| 126 | +
- checkmate::assert_scalar(unique(df[[y_unit]]))+ #' variables = list( |
|||
| 231 | +127 |
- }+ #' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE"),
|
||
| 232 | +128 |
-
+ #' strata = "SITE" |
||
| 233 | -12x | +|||
| 129 | +
- if (!is.null(group_var) && !is.null(alt_counts_df)) {
+ #' ) |
|||
| 234 | -7x | +|||
| 130 | +
- checkmate::assert_set_equal(unique(alt_counts_df[[group_var]]), unique(df[[group_var]]))+ #' ) |
|||
| 235 | +131 |
- }+ #' |
||
| 236 | +132 |
-
+ #' # Example without treatment arm. |
||
| 237 | +133 |
- ####################################### |+ #' h_coxreg_multivar_formula( |
||
| 238 | +134 |
- # ---- Compute required statistics ----+ #' variables = list( |
||
| 239 | +135 |
- ####################################### |+ #' time = "AVAL", event = "event", covariates = c("RACE", "AGE"),
|
||
| 240 | +136 |
- # Remove unused levels for x-axis+ #' strata = "SITE" |
||
| 241 | -12x | +|||
| 137 | +
- if (is.factor(df[[x]])) {
+ #' ) |
|||
| 242 | -11x | +|||
| 138 | +
- df[[x]] <- droplevels(df[[x]])+ #' ) |
|||
| 243 | +139 |
- }+ #' |
||
| 244 | +140 |
-
+ #' @export |
||
| 245 | -12x | +|||
| 141 | +
- if (!is.null(facet_var) && !is.null(group_var)) {
+ h_coxreg_multivar_formula <- function(variables) {
|
|||
| 246 | -1x | +142 | +89x |
- df_grp <- tidyr::expand(df, .data[[facet_var]], .data[[group_var]], .data[[x]]) # expand based on levels of factors+ checkmate::assert_list(variables, names = "named") |
| 247 | -11x | +143 | +89x |
- } else if (!is.null(group_var)) {
+ has_arm <- "arm" %in% names(variables) |
| 248 | -10x | +144 | +89x |
- df_grp <- tidyr::expand(df, .data[[group_var]], .data[[x]]) # expand based on levels of factors+ arm_name <- if (has_arm) "arm" else NULL |
| 249 | +145 |
- } else {
+
|
||
| 250 | -1x | +146 | +89x |
- df_grp <- tidyr::expand(df, NULL, .data[[x]])+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
| 251 | +147 |
- }+ + |
+ ||
| 148 | +89x | +
+ assert_list_of_variables(variables[c(arm_name, "event", "time")]) |
||
| 252 | +149 | |||
| 253 | -12x | +150 | +89x |
- df_grp <- df_grp %>%+ y <- paste0( |
| 254 | -12x | +151 | +89x |
- dplyr::full_join(y = df[, c(facet_var, group_var, x, y)], by = c(facet_var, group_var, x), multiple = "all") %>%+ "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
|
| 255 | -12x | +152 | +89x |
- dplyr::group_by_at(c(facet_var, group_var, x))+ ifelse(has_arm, variables$arm, "1") |
| 256 | +153 |
-
+ ) |
||
| 257 | -12x | +154 | +89x |
- df_stats <- df_grp %>%+ if (length(variables$covariates) > 0) {
|
| 258 | -12x | +155 | +26x |
- dplyr::summarise(+ y <- paste(y, paste(variables$covariates, collapse = " + "), sep = " + ") |
| 259 | -12x | +|||
| 156 | +
- data.frame(t(do.call(c, unname(sfun(.data[[y]])[c(mid, interval)])))),+ } |
|||
| 260 | -12x | +157 | +89x |
- .groups = "drop"+ if (!is.null(variables$strata)) {
|
| 261 | -+ | |||
| 158 | +5x |
- )+ y <- paste0(y, " + strata(", paste0(variables$strata, collapse = ", "), ")")
|
||
| 262 | +159 |
-
+ } |
||
| 263 | -12x | +160 | +89x |
- df_stats <- df_stats[!is.na(df_stats[[mid]]), ]+ y |
| 264 | +161 |
-
+ } |
||
| 265 | +162 |
- # add number of objects N in group_var (strata)- |
- ||
| 266 | -12x | -
- if (!is.null(group_var) && !is.null(alt_counts_df)) {
- |
- ||
| 267 | -7x | -
- strata_N <- paste0(group_var, "_N") # nolint+ |
||
| 268 | +163 | - - | -||
| 269 | -7x | -
- 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- |
- ||
| 270 | -7x | -
- colnames(df_N) <- c(group_var, "N") # nolint- |
- ||
| 271 | -7x | -
- df_N[[strata_N]] <- paste0(df_N[[group_var]], " (N = ", df_N$N, ")") # nolint+ #' @describeIn h_cox_regression Utility function to help tabulate the result of |
||
| 272 | +164 |
-
+ #' a univariate Cox regression model. |
||
| 273 | +165 |
- # keep strata factor levels+ #' |
||
| 274 | -7x | +|||
| 166 | +
- matches <- sapply(unique(df_N[[group_var]]), function(x) {
+ #' @param effect (`string`)\cr the treatment variable. |
|||
| 275 | -19x | +|||
| 167 | +
- regex_pattern <- gsub("([][(){}^$.|*+?\\\\])", "\\\\\\1", x)
+ #' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()]. |
|||
| 276 | -19x | +|||
| 168 | +
- unique(df_N[[paste0(group_var, "_N")]])[grepl(+ #' |
|||
| 277 | -19x | +|||
| 169 | +
- paste0("^", regex_pattern),
+ #' @return |
|||
| 278 | -19x | +|||
| 170 | +
- unique(df_N[[paste0(group_var, "_N")]])+ #' * `h_coxreg_univar_extract()` returns a `data.frame` with variables `effect`, `term`, `term_label`, `level`, |
|||
| 279 | +171 |
- )]+ #' `n`, `hr`, `lcl`, `ucl`, and `pval`. |
||
| 280 | +172 |
- })+ #' |
||
| 281 | -7x | +|||
| 173 | +
- df_N[[paste0(group_var, "_N")]] <- factor(df_N[[group_var]]) # nolint+ #' @examples |
|||
| 282 | -7x | +|||
| 174 | +
- levels(df_N[[paste0(group_var, "_N")]]) <- unlist(matches) # nolint+ #' library(survival) |
|||
| 283 | +175 |
-
+ #' |
||
| 284 | +176 |
- # strata_N should not be in colnames(df_stats)+ #' dta_simple <- data.frame( |
||
| 285 | -7x | +|||
| 177 | +
- checkmate::assert_disjunct(strata_N, colnames(df_stats))+ #' time = c(5, 5, 10, 10, 5, 5, 10, 10), |
|||
| 286 | +178 |
-
+ #' status = c(0, 0, 1, 0, 0, 1, 1, 1), |
||
| 287 | -7x | +|||
| 179 | +
- df_stats <- merge(x = df_stats, y = df_N[, c(group_var, strata_N)], by = group_var)+ #' armcd = factor(LETTERS[c(1, 1, 1, 1, 2, 2, 2, 2)], levels = c("A", "B")),
|
|||
| 288 | -5x | +|||
| 180 | +
- } else if (!is.null(group_var)) {
+ #' var1 = c(45, 55, 65, 75, 55, 65, 85, 75), |
|||
| 289 | -4x | +|||
| 181 | +
- strata_N <- group_var # nolint+ #' var2 = c("F", "M", "F", "M", "F", "M", "F", "U")
|
|||
| 290 | +182 |
- } else {
+ #' ) |
||
| 291 | -1x | +|||
| 183 | +
- strata_N <- NULL # nolint+ #' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple) |
|||
| 292 | +184 |
- }+ #' result <- h_coxreg_univar_extract( |
||
| 293 | +185 |
-
+ #' effect = "armcd", covar = "armcd", mod = mod, data = dta_simple |
||
| 294 | +186 |
- ############################################### |+ #' ) |
||
| 295 | +187 |
- # ---- Prepare certain plot's properties. ----+ #' result |
||
| 296 | +188 |
- ############################################### |+ #' |
||
| 297 | +189 |
- # legend title+ #' @export |
||
| 298 | -12x | +|||
| 190 | +
- if (is.null(legend_title) && !is.null(group_var) && legend_position != "none") {
+ h_coxreg_univar_extract <- function(effect, |
|||
| 299 | -11x | +|||
| 191 | +
- legend_title <- attr(df[[group_var]], "label")+ covar, |
|||
| 300 | +192 |
- }+ data, |
||
| 301 | +193 |
-
+ mod, |
||
| 302 | +194 |
- # y label+ control = control_coxreg()) {
|
||
| 303 | -12x | +195 | +66x |
- if (!is.null(y_lab)) {
+ checkmate::assert_string(covar) |
| 304 | -4x | +196 | +66x |
- if (y_lab_add_paramcd) {
+ checkmate::assert_string(effect) |
| 305 | -4x | +197 | +66x |
- y_lab <- paste(y_lab, unique(df[[paramcd]]))+ checkmate::assert_class(mod, "coxph") |
| 306 | -+ | |||
| 198 | +66x |
- }+ test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method] |
||
| 307 | +199 | |||
| 308 | -4x | +200 | +66x |
- if (y_lab_add_unit) {
+ mod_aov <- muffled_car_anova(mod, test_statistic) |
| 309 | -4x | +201 | +66x |
- y_lab <- paste0(y_lab, " (", unique(df[[y_unit]]), ")")
+ msum <- summary(mod, conf.int = control$conf_level)+ |
+
| 202 | +66x | +
+ sum_cox <- broom::tidy(msum) |
||
| 310 | +203 |
- }+ |
||
| 311 | +204 |
-
+ # Combine results together. |
||
| 312 | -4x | +205 | +66x |
- y_lab <- trimws(y_lab)+ effect_aov <- mod_aov[effect, , drop = TRUE] |
| 313 | -+ | |||
| 206 | +66x |
- }+ pval <- effect_aov[[grep(pattern = "Pr", x = names(effect_aov)), drop = TRUE]] |
||
| 314 | -+ | |||
| 207 | +66x |
-
+ sum_main <- sum_cox[grepl(effect, sum_cox$level), ] |
||
| 315 | +208 |
- # subtitle+ |
||
| 316 | -12x | +209 | +66x |
- if (!is.null(subtitle)) {
+ term_label <- if (effect == covar) {
|
| 317 | -12x | +210 | +34x |
- if (subtitle_add_paramcd) {
+ paste0( |
| 318 | -12x | -
- subtitle <- paste(subtitle, unique(df[[paramcd]]))- |
- ||
| 319 | -+ | 211 | +34x |
- }+ levels(data[[covar]])[2], |
| 320 | -+ | |||
| 212 | +34x |
-
+ " vs control (",
|
||
| 321 | -12x | +213 | +34x |
- if (subtitle_add_unit) {
+ levels(data[[covar]])[1], |
| 322 | -12x | +|||
| 214 | +
- subtitle <- paste0(subtitle, " (", unique(df[[y_unit]]), ")")
+ ")" |
|||
| 323 | +215 |
- }+ ) |
||
| 324 | +216 |
-
+ } else {
|
||
| 325 | -12x | +217 | +32x |
- subtitle <- trimws(subtitle)+ unname(labels_or_names(data[covar])) |
| 326 | +218 |
} |
||
| 327 | -+ | |||
| 219 | +66x |
-
+ data.frame( |
||
| 328 | -+ | |||
| 220 | +66x |
- ############################### |+ effect = ifelse(covar == effect, "Treatment:", "Covariate:"), |
||
| 329 | -+ | |||
| 221 | +66x |
- # ---- Build plot object. ----+ term = covar, |
||
| 330 | -+ | |||
| 222 | +66x |
- ############################### |+ term_label = term_label, |
||
| 331 | -12x | +223 | +66x |
- p <- ggplot2::ggplot(+ level = levels(data[[effect]])[2], |
| 332 | -12x | +224 | +66x |
- data = df_stats,+ n = mod[["n"]], |
| 333 | -12x | +225 | +66x |
- mapping = ggplot2::aes(+ hr = unname(sum_main["exp(coef)"]), |
| 334 | -12x | +226 | +66x |
- x = .data[[x]], y = .data[[mid]],+ lcl = unname(sum_main[grep("lower", names(sum_main))]),
|
| 335 | -12x | +227 | +66x |
- color = if (is.null(strata_N)) NULL else .data[[strata_N]],+ ucl = unname(sum_main[grep("upper", names(sum_main))]),
|
| 336 | -12x | +228 | +66x |
- shape = if (is.null(strata_N)) NULL else .data[[strata_N]],+ pval = pval, |
| 337 | -12x | +229 | +66x |
- lty = if (is.null(strata_N)) NULL else .data[[strata_N]],+ stringsAsFactors = FALSE |
| 338 | -12x | +|||
| 230 | +
- group = if (is.null(strata_N)) NULL else .data[[strata_N]]+ ) |
|||
| 339 | +231 |
- )+ } |
||
| 340 | +232 |
- )+ |
||
| 341 | +233 |
-
+ #' @describeIn h_cox_regression Tabulation of multivariate Cox regressions. Utility function to help |
||
| 342 | -12x | +|||
| 234 | +
- if (!is.null(group_var) && nlevels(df_stats[[strata_N]]) > 6) {
+ #' tabulate the result of a multivariate Cox regression model for a treatment/covariate variable. |
|||
| 343 | -1x | +|||
| 235 | +
- p <- p ++ #' |
|||
| 344 | -1x | +|||
| 236 | +
- scale_shape_manual(values = seq(15, 15 + nlevels(df_stats[[strata_N]])))+ #' @return |
|||
| 345 | +237 |
- }+ #' * `h_coxreg_multivar_extract()` returns a `data.frame` with variables `pval`, `hr`, `lcl`, `ucl`, `level`, |
||
| 346 | +238 |
-
+ #' `n`, `term`, and `term_label`. |
||
| 347 | -12x | +|||
| 239 | +
- if (!is.null(mid)) {
+ #' |
|||
| 348 | +240 |
- # points+ #' @examples |
||
| 349 | -12x | +|||
| 241 | +
- if (grepl("p", mid_type, fixed = TRUE)) {
+ #' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple) |
|||
| 350 | -12x | +|||
| 242 | +
- p <- p + ggplot2::geom_point(position = position, size = mid_point_size, na.rm = TRUE)+ #' result <- h_coxreg_multivar_extract( |
|||
| 351 | +243 |
- }+ #' var = "var1", mod = mod, data = dta_simple |
||
| 352 | +244 |
-
+ #' ) |
||
| 353 | +245 |
- # lines - plotted only if there is a strata grouping (group_var)+ #' result |
||
| 354 | -12x | +|||
| 246 | +
- if (grepl("l", mid_type, fixed = TRUE) && !is.null(strata_N)) { # nolint
+ #' |
|||
| 355 | -11x | +|||
| 247 | +
- p <- p + ggplot2::geom_line(position = position, na.rm = TRUE)+ #' @export |
|||
| 356 | +248 |
- }+ h_coxreg_multivar_extract <- function(var, |
||
| 357 | +249 |
- }+ data, |
||
| 358 | +250 |
-
+ mod, |
||
| 359 | +251 |
- # interval+ control = control_coxreg()) {
|
||
| 360 | -12x | +252 | +132x |
- if (!is.null(interval)) {
+ test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method] |
| 361 | -12x | +253 | +132x |
- p <- p ++ mod_aov <- muffled_car_anova(mod, test_statistic) |
| 362 | -12x | +|||
| 254 | +
- ggplot2::geom_errorbar(+ |
|||
| 363 | -12x | +255 | +132x |
- ggplot2::aes(ymin = .data[[whiskers[1]]], ymax = .data[[whiskers[max(1, length(whiskers))]]]),+ msum <- summary(mod, conf.int = control$conf_level) |
| 364 | -12x | +256 | +132x |
- width = errorbar_width,+ sum_anova <- broom::tidy(mod_aov) |
| 365 | -12x | +257 | +132x |
- position = position+ sum_cox <- broom::tidy(msum) |
| 366 | +258 |
- )+ |
||
| 367 | -+ | |||
| 259 | +132x |
-
+ ret_anova <- sum_anova[sum_anova$term == var, c("term", "p.value")]
|
||
| 368 | -12x | +260 | +132x |
- if (length(whiskers) == 1) { # lwr or upr only; mid is then required
+ names(ret_anova)[2] <- "pval" |
| 369 | -+ | |||
| 261 | +132x |
- # workaround as geom_errorbar does not provide single-direction whiskers+ if (is.factor(data[[var]])) {
|
||
| 370 | -! | +|||
| 262 | +53x |
- p <- p ++ ret_cox <- sum_cox[startsWith(prefix = var, x = sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")] |
||
| 371 | -! | +|||
| 263 | +
- ggplot2::geom_linerange(+ } else {
|
|||
| 372 | -! | +|||
| 264 | +79x |
- data = df_stats[!is.na(df_stats[[whiskers]]), ], # as na.rm =TRUE does not suppress warnings+ ret_cox <- sum_cox[(var == sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")] |
||
| 373 | -! | +|||
| 265 | +
- ggplot2::aes(ymin = .data[[mid]], ymax = .data[[whiskers]]),+ } |
|||
| 374 | -! | +|||
| 266 | +132x |
- position = position,+ names(ret_cox)[1:4] <- c("pval", "hr", "lcl", "ucl")
|
||
| 375 | -! | +|||
| 267 | +132x |
- na.rm = TRUE,+ varlab <- unname(labels_or_names(data[var])) |
||
| 376 | -! | +|||
| 268 | +132x |
- show.legend = FALSE+ ret_cox$term <- varlab |
||
| 377 | +269 |
- )+ |
||
| 378 | -+ | |||
| 270 | +132x |
- }+ if (is.numeric(data[[var]])) {
|
||
| 379 | -+ | |||
| 271 | +79x |
- }+ ret <- ret_cox |
||
| 380 | -+ | |||
| 272 | +79x | +
+ ret$term_label <- ret$term+ |
+ ||
| 273 | +53x | +
+ } else if (length(levels(data[[var]])) <= 2) {
+ |
+ ||
| 274 | +34x |
-
+ ret_anova$pval <- NA |
||
| 381 | -12x | +275 | +34x |
- if (is.numeric(df_stats[[x]])) {
+ ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")") |
| 382 | -1x | +276 | +34x |
- if (length(xticks) == 1) xticks <- seq(from = min(df_stats[[x]]), to = max(df_stats[[x]]), by = xticks)+ ret_cox$level <- gsub(var, "", ret_cox$level) |
| 383 | -1x | +277 | +34x |
- p <- p + ggplot2::scale_x_continuous(breaks = if (!is.null(xticks)) xticks else waiver(), limits = xlim)+ ret_cox$term_label <- ret_cox$level |
| 384 | -+ | |||
| 278 | +34x |
- }+ ret <- dplyr::bind_rows(ret_anova, ret_cox) |
||
| 385 | +279 |
-
+ } else {
|
||
| 386 | -12x | +280 | +19x |
- p <- p ++ ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")") |
| 387 | -12x | +281 | +19x |
- ggplot2::scale_y_continuous(labels = scales::comma, limits = ylim) ++ ret_cox$level <- gsub(var, "", ret_cox$level) |
| 388 | -12x | +282 | +19x |
- ggplot2::labs(+ ret_cox$term_label <- ret_cox$level |
| 389 | -12x | +283 | +19x |
- title = title,+ ret <- dplyr::bind_rows(ret_anova, ret_cox) |
| 390 | -12x | +|||
| 284 | +
- subtitle = subtitle,+ } |
|||
| 391 | -12x | +|||
| 285 | +
- caption = caption,+ |
|||
| 392 | -12x | +286 | +132x |
- color = legend_title,+ as.data.frame(ret) |
| 393 | -12x | +|||
| 287 | +
- lty = legend_title,+ } |
|||
| 394 | -12x | +
| 1 | +
- shape = legend_title,+ #' Cumulative counts of numeric variable by thresholds |
|||
| 395 | -12x | +|||
| 2 | +
- x = x_lab,+ #' |
|||
| 396 | -12x | +|||
| 3 | +
- y = y_lab+ #' @description `r lifecycle::badge("stable")`
|
|||
| 397 | +4 |
- )+ #' |
||
| 398 | +5 |
-
+ #' The analyze function [count_cumulative()] creates a layout element to calculate cumulative counts of values in a |
||
| 399 | -12x | +|||
| 6 | +
- if (!is.null(col)) {
+ #' numeric variable that are less than, less or equal to, greater than, or greater or equal to user-specified |
|||
| 400 | -1x | +|||
| 7 | +
- p <- p ++ #' threshold values. |
|||
| 401 | -1x | +|||
| 8 | +
- ggplot2::scale_color_manual(values = col)+ #' |
|||
| 402 | +9 |
- }+ #' This function analyzes numeric variable `vars` against the threshold values supplied to the `thresholds` |
||
| 403 | -12x | +|||
| 10 | +
- if (!is.null(linetype)) {
+ #' argument as a numeric vector. Whether counts should include the threshold values, and whether to count |
|||
| 404 | -1x | +|||
| 11 | +
- p <- p ++ #' values lower or higher than the threshold values can be set via the `include_eq` and `lower_tail` |
|||
| 405 | -1x | +|||
| 12 | +
- ggplot2::scale_linetype_manual(values = linetype)+ #' parameters, respectively. |
|||
| 406 | +13 |
- }+ #' |
||
| 407 | +14 |
-
+ #' @inheritParams h_count_cumulative |
||
| 408 | -12x | +|||
| 15 | +
- if (!is.null(facet_var)) {
+ #' @inheritParams argument_convention |
|||
| 409 | -1x | +|||
| 16 | +
- p <- p ++ #' @param thresholds (`numeric`)\cr vector of cutoff values for the counts. |
|||
| 410 | -1x | +|||
| 17 | +
- facet_grid(cols = vars(df_stats[[facet_var]]))+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_cumulative")`
|
|||
| 411 | +18 |
- }+ #' to see available statistics for this function. |
||
| 412 | +19 |
-
+ #' |
||
| 413 | -12x | +|||
| 20 | +
- if (!is.null(ggtheme)) {
+ #' @seealso Relevant helper function [h_count_cumulative()], and descriptive function [d_count_cumulative()]. |
|||
| 414 | -12x | +|||
| 21 | +
- p <- p + ggtheme+ #' |
|||
| 415 | +22 |
- } else {
+ #' @name count_cumulative |
||
| 416 | -! | +|||
| 23 | +
- p <- p ++ #' @order 1 |
|||
| 417 | -! | +|||
| 24 | +
- ggplot2::theme_bw() ++ NULL |
|||
| 418 | -! | +|||
| 25 | +
- ggplot2::theme(+ |
|||
| 419 | -! | +|||
| 26 | +
- legend.key.width = grid::unit(1, "cm"),+ #' Helper function for `s_count_cumulative()` |
|||
| 420 | -! | +|||
| 27 | +
- legend.position = legend_position,+ #' |
|||
| 421 | -! | +|||
| 28 | +
- legend.direction = ifelse(+ #' @description `r lifecycle::badge("stable")`
|
|||
| 422 | -! | +|||
| 29 | +
- legend_position %in% c("top", "bottom"),
+ #' |
|||
| 423 | -! | +|||
| 30 | +
- "horizontal",+ #' Helper function to calculate count and fraction of `x` values in the lower or upper tail given a threshold. |
|||
| 424 | -! | +|||
| 31 | +
- "vertical"+ #' |
|||
| 425 | +32 |
- )+ #' @inheritParams argument_convention |
||
| 426 | +33 |
- )+ #' @param threshold (`numeric(1)`)\cr a cutoff value as threshold to count values of `x`. |
||
| 427 | +34 |
- }+ #' @param lower_tail (`flag`)\cr whether to count lower tail, default is `TRUE`. |
||
| 428 | +35 |
-
+ #' @param include_eq (`flag`)\cr whether to include value equal to the `threshold` in |
||
| 429 | +36 |
- ############################################################# |+ #' count, default is `TRUE`. |
||
| 430 | +37 |
- # ---- Optionally, add table to the bottom of the plot. ----+ #' |
||
| 431 | +38 |
- ############################################################# |+ #' @return A named vector with items: |
||
| 432 | -12x | +|||
| 39 | +
- if (!is.null(table)) {
+ #' * `count`: the count of values less than, less or equal to, greater than, or greater or equal to a threshold |
|||
| 433 | -4x | +|||
| 40 | +
- df_stats_table <- df_grp %>%+ #' of user specification. |
|||
| 434 | -4x | +|||
| 41 | +
- dplyr::summarise(+ #' * `fraction`: the fraction of the count. |
|||
| 435 | -4x | +|||
| 42 | +
- h_format_row(+ #' |
|||
| 436 | -4x | +|||
| 43 | +
- x = sfun(.data[[y]], ...)[table],+ #' @seealso [count_cumulative] |
|||
| 437 | -4x | +|||
| 44 | +
- format = table_format,+ #' |
|||
| 438 | -4x | +|||
| 45 | +
- labels = table_labels+ #' @examples |
|||
| 439 | +46 |
- ),+ #' set.seed(1, kind = "Mersenne-Twister") |
||
| 440 | -4x | +|||
| 47 | +
- .groups = "drop"+ #' x <- c(sample(1:10, 10), NA) |
|||
| 441 | +48 |
- )+ #' .N_col <- length(x) |
||
| 442 | +49 |
-
+ #' |
||
| 443 | -4x | +|||
| 50 | +
- stats_lev <- rev(setdiff(colnames(df_stats_table), c(group_var, x)))+ #' h_count_cumulative(x, 5, .N_col = .N_col) |
|||
| 444 | +51 |
-
+ #' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na.rm = FALSE, .N_col = .N_col) |
||
| 445 | -4x | +|||
| 52 | +
- df_stats_table <- df_stats_table %>%+ #' h_count_cumulative(x, 0, lower_tail = FALSE, .N_col = .N_col) |
|||
| 446 | -4x | +|||
| 53 | +
- tidyr::pivot_longer(+ #' h_count_cumulative(x, 100, lower_tail = FALSE, .N_col = .N_col) |
|||
| 447 | -4x | +|||
| 54 | +
- cols = -dplyr::all_of(c(group_var, x)),+ #' |
|||
| 448 | -4x | +|||
| 55 | +
- names_to = "stat",+ #' @export |
|||
| 449 | -4x | +|||
| 56 | +
- values_to = "value",+ h_count_cumulative <- function(x, |
|||
| 450 | -4x | +|||
| 57 | +
- names_ptypes = list(stat = factor(levels = stats_lev))+ threshold, |
|||
| 451 | +58 |
- )+ lower_tail = TRUE, |
||
| 452 | +59 |
-
+ include_eq = TRUE, |
||
| 453 | -4x | +|||
| 60 | +
- tbl <- ggplot2::ggplot(+ na.rm = TRUE, # nolint |
|||
| 454 | -4x | +|||
| 61 | +
- df_stats_table,+ .N_col) { # nolint
|
|||
| 455 | -4x | +62 | +20x |
- ggplot2::aes(x = .data[[x]], y = .data[["stat"]], label = .data[["value"]])+ checkmate::assert_numeric(x) |
| 456 | -+ | |||
| 63 | +20x |
- ) ++ checkmate::assert_numeric(threshold) |
||
| 457 | -4x | +64 | +20x |
- ggplot2::geom_text(size = table_font_size) ++ checkmate::assert_numeric(.N_col) |
| 458 | -4x | +65 | +20x |
- ggplot2::theme_bw() ++ checkmate::assert_flag(lower_tail) |
| 459 | -4x | +66 | +20x |
- ggplot2::theme(+ checkmate::assert_flag(include_eq) |
| 460 | -4x | +67 | +20x |
- panel.border = ggplot2::element_blank(),+ checkmate::assert_flag(na.rm) |
| 461 | -4x | +|||
| 68 | +
- panel.grid.major = ggplot2::element_blank(),+ |
|||
| 462 | -4x | +69 | +20x |
- panel.grid.minor = ggplot2::element_blank(),+ is_keep <- if (na.rm) !is.na(x) else rep(TRUE, length(x)) |
| 463 | -4x | +70 | +20x |
- axis.ticks = ggplot2::element_blank(),+ count <- if (lower_tail && include_eq) {
|
| 464 | -4x | +71 | +7x |
- axis.title = ggplot2::element_blank(),+ length(x[is_keep & x <= threshold]) |
| 465 | -4x | +72 | +20x |
- axis.text.x = ggplot2::element_blank(),+ } else if (lower_tail && !include_eq) {
|
| 466 | -4x | +|||
| 73 | +! |
- axis.text.y = ggplot2::element_text(margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 5)),+ length(x[is_keep & x < threshold]) |
||
| 467 | -4x | +74 | +20x |
- strip.text = ggplot2::element_text(hjust = 0),+ } else if (!lower_tail && include_eq) {
|
| 468 | -4x | +75 | +6x |
- strip.text.x = ggplot2::element_text(margin = ggplot2::margin(1.5, 0, 1.5, 0, "pt")),+ length(x[is_keep & x >= threshold]) |
| 469 | -4x | +76 | +20x |
- strip.background = ggplot2::element_rect(fill = "grey95", color = NA),+ } else if (!lower_tail && !include_eq) {
|
| 470 | -4x | +77 | +7x |
- legend.position = "none"+ length(x[is_keep & x > threshold]) |
| 471 | +78 |
- )+ } |
||
| 472 | +79 | |||
| 473 | -4x | +80 | +20x |
- if (!is.null(group_var)) {
+ result <- c(count = count, fraction = count / .N_col) |
| 474 | -4x | +81 | +20x |
- tbl <- tbl + ggplot2::facet_wrap(facets = group_var, ncol = 1)+ result |
| 475 | +82 |
- }+ } |
||
| 476 | +83 | |||
| 477 | +84 |
- # align plot and table- |
- ||
| 478 | -4x | -
- cowplot::plot_grid(p, tbl, ncol = 1, align = "v", axis = "tblr")+ #' Description of cumulative count |
||
| 479 | +85 |
- } else {
+ #' |
||
| 480 | -8x | +|||
| 86 | +
- p+ #' @description `r lifecycle::badge("stable")`
|
|||
| 481 | +87 |
- }+ #' |
||
| 482 | +88 |
- }+ #' This is a helper function that describes the analysis in [s_count_cumulative()]. |
||
| 483 | +89 |
-
+ #' |
||
| 484 | +90 |
- #' Helper function to format the optional `g_lineplot` table+ #' @inheritParams h_count_cumulative |
||
| 485 | +91 |
#' |
||
| 486 | +92 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return Labels for [s_count_cumulative()]. |
||
| 487 | +93 |
#' |
||
| 488 | +94 |
- #' @param x (named `list`)\cr list of numerical values to be formatted and optionally labeled.+ #' @export |
||
| 489 | +95 |
- #' Elements of `x` must be `numeric` vectors.+ d_count_cumulative <- function(threshold, lower_tail = TRUE, include_eq = TRUE) {
|
||
| 490 | -+ | |||
| 96 | +18x |
- #' @param format (named `character` or `NULL`)\cr format patterns for `x`. Names of the `format` must+ checkmate::assert_numeric(threshold) |
||
| 491 | -+ | |||
| 97 | +18x |
- #' match the names of `x`. This parameter is passed directly to the `rtables::format_rcell`+ lg <- if (lower_tail) "<" else ">" |
||
| 492 | -+ | |||
| 98 | +18x |
- #' function through the `format` parameter.+ eq <- if (include_eq) "=" else ""+ |
+ ||
| 99 | +18x | +
+ paste0(lg, eq, " ", threshold) |
||
| 493 | +100 |
- #' @param labels (named `character` or `NULL`)\cr optional labels for `x`. Names of the `labels` must+ } |
||
| 494 | +101 |
- #' match the names of `x`. When a label is not specified for an element of `x`,+ |
||
| 495 | +102 |
- #' then this function tries to use `label` or `names` (in this order) attribute of that element+ #' @describeIn count_cumulative Statistics function that produces a named list given a numeric vector of thresholds. |
||
| 496 | +103 |
- #' (depending on which one exists and it is not `NULL` or `NA` or `NaN`). If none of these attributes+ #' |
||
| 497 | +104 |
- #' are attached to a given element of `x`, then the label is automatically generated.+ #' @return |
||
| 498 | +105 |
- #'+ #' * `s_count_cumulative()` returns a named list of `count_fraction`s: a list with each `thresholds` value as a |
||
| 499 | +106 |
- #' @return A single row `data.frame` object.+ #' component, each component containing a vector for the count and fraction. |
||
| 500 | +107 |
#' |
||
| 501 | +108 |
- #' @examples+ #' @keywords internal |
||
| 502 | +109 |
- #' mean_ci <- c(48, 51)+ s_count_cumulative <- function(x, |
||
| 503 | +110 |
- #' x <- list(mean = 50, mean_ci = mean_ci)+ thresholds, |
||
| 504 | +111 |
- #' format <- c(mean = "xx.x", mean_ci = "(xx.xx, xx.xx)")+ lower_tail = TRUE, |
||
| 505 | +112 |
- #' labels <- c(mean = "My Mean")+ include_eq = TRUE, |
||
| 506 | +113 |
- #' h_format_row(x, format, labels)+ .N_col, # nolint |
||
| 507 | +114 |
- #'+ ...) {
|
||
| 508 | -+ | |||
| 115 | +5x |
- #' attr(mean_ci, "label") <- "Mean 95% CI"+ checkmate::assert_numeric(thresholds, min.len = 1, any.missing = FALSE) |
||
| 509 | +116 |
- #' x <- list(mean = 50, mean_ci = mean_ci)+ |
||
| 510 | -+ | |||
| 117 | +5x |
- #' h_format_row(x, format, labels)+ count_fraction_list <- Map(function(thres) {
|
||
| 511 | -+ | |||
| 118 | +10x |
- #'+ result <- h_count_cumulative(x, thres, lower_tail, include_eq, .N_col = .N_col, ...)+ |
+ ||
| 119 | +10x | +
+ label <- d_count_cumulative(thres, lower_tail, include_eq)+ |
+ ||
| 120 | +10x | +
+ formatters::with_label(result, label)+ |
+ ||
| 121 | +5x | +
+ }, thresholds) |
||
| 512 | +122 |
- #' @export+ + |
+ ||
| 123 | +5x | +
+ names(count_fraction_list) <- thresholds+ |
+ ||
| 124 | +5x | +
+ list(count_fraction = count_fraction_list) |
||
| 513 | +125 |
- h_format_row <- function(x, format, labels = NULL) {
+ } |
||
| 514 | +126 |
- # cell: one row, one column data.frame+ |
||
| 515 | -74x | +|||
| 127 | +
- format_cell <- function(x, format, label = NULL) {
+ #' @describeIn count_cumulative Formatted analysis function which is used as `afun` |
|||
| 516 | -184x | +|||
| 128 | +
- fc <- format_rcell(x = x, format = unlist(format))+ #' in `count_cumulative()`. |
|||
| 517 | -184x | +|||
| 129 | +
- if (is.na(fc)) {
+ #' |
|||
| 518 | -! | +|||
| 130 | +
- fc <- "NA"+ #' @return |
|||
| 519 | +131 |
- }+ #' * `a_count_cumulative()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 520 | -184x | +|||
| 132 | +
- x_label <- attr(x, "label")+ #' |
|||
| 521 | -184x | +|||
| 133 | +
- if (!is.null(label) && !is.na(label)) {
+ #' @keywords internal |
|||
| 522 | -182x | +|||
| 134 | +
- names(fc) <- label+ a_count_cumulative <- make_afun( |
|||
| 523 | -2x | +|||
| 135 | +
- } else if (!is.null(x_label) && !is.na(x_label)) {
+ s_count_cumulative, |
|||
| 524 | -1x | +|||
| 136 | +
- names(fc) <- x_label+ .formats = c(count_fraction = format_count_fraction) |
|||
| 525 | -1x | +|||
| 137 | +
- } else if (length(x) == length(fc)) {
+ ) |
|||
| 526 | -! | +|||
| 138 | +
- names(fc) <- names(x)+ |
|||
| 527 | +139 |
- }+ #' @describeIn count_cumulative Layout-creating function which can take statistics function arguments |
||
| 528 | -184x | +|||
| 140 | +
- as.data.frame(t(fc))+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 529 | +141 |
- }+ #' |
||
| 530 | +142 |
-
+ #' @return |
||
| 531 | -74x | +|||
| 143 | +
- row <- do.call(+ #' * `count_cumulative()` returns a layout object suitable for passing to further layouting functions, |
|||
| 532 | -74x | +|||
| 144 | +
- cbind,+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 533 | -74x | +|||
| 145 | +
- lapply(+ #' the statistics from `s_count_cumulative()` to the table layout. |
|||
| 534 | -74x | +|||
| 146 | +
- names(x), function(xn) format_cell(x[[xn]], format = format[xn], label = labels[xn])+ #' |
|||
| 535 | +147 |
- )+ #' @examples |
||
| 536 | +148 |
- )+ #' basic_table() %>% |
||
| 537 | +149 |
-
+ #' split_cols_by("ARM") %>%
|
||
| 538 | -74x | +|||
| 150 | +
- row+ #' add_colcounts() %>% |
|||
| 539 | +151 |
- }+ #' count_cumulative( |
||
| 540 | +152 |
-
+ #' vars = "AGE", |
||
| 541 | +153 |
- #' Control function for `g_lineplot()`+ #' thresholds = c(40, 60) |
||
| 542 | +154 |
- #'+ #' ) %>% |
||
| 543 | +155 |
- #' @description `r lifecycle::badge("stable")`
+ #' build_table(tern_ex_adsl) |
||
| 544 | +156 |
#' |
||
| 545 | +157 |
- #' Default values for `variables` parameter in `g_lineplot` function.+ #' @export |
||
| 546 | +158 |
- #' A variable's default value can be overwritten for any variable.+ #' @order 2 |
||
| 547 | +159 |
- #'+ count_cumulative <- function(lyt, |
||
| 548 | +160 |
- #' @param x (`string`)\cr x-variable name.+ vars, |
||
| 549 | +161 |
- #' @param y (`string`)\cr y-variable name.+ thresholds, |
||
| 550 | +162 |
- #' @param group_var (`string` or `NA`)\cr group variable name.+ lower_tail = TRUE, |
||
| 551 | +163 |
- #' @param subject_var (`string` or `NA`)\cr subject variable name.+ include_eq = TRUE, |
||
| 552 | +164 |
- #' @param facet_var (`string` or `NA`)\cr faceting variable name.+ var_labels = vars, |
||
| 553 | +165 |
- #' @param paramcd (`string` or `NA`)\cr parameter code variable name.+ show_labels = "visible", |
||
| 554 | +166 |
- #' @param y_unit (`string` or `NA`)\cr y-axis unit variable name.+ na_str = default_na_str(), |
||
| 555 | +167 |
- #'+ nested = TRUE, |
||
| 556 | +168 |
- #' @return A named character vector of variable names.+ ..., |
||
| 557 | +169 |
- #'+ table_names = vars, |
||
| 558 | +170 |
- #' @examples+ .stats = NULL, |
||
| 559 | +171 |
- #' control_lineplot_vars()+ .formats = NULL, |
||
| 560 | +172 |
- #' control_lineplot_vars(group_var = NA)+ .labels = NULL, |
||
| 561 | +173 |
- #'+ .indent_mods = NULL) {
|
||
| 562 | -+ | |||
| 174 | +2x |
- #' @export+ extra_args <- list(thresholds = thresholds, lower_tail = lower_tail, include_eq = include_eq, ...) |
||
| 563 | +175 |
- control_lineplot_vars <- function(x = "AVISIT",+ |
||
| 564 | -+ | |||
| 176 | +2x |
- y = "AVAL",+ afun <- make_afun( |
||
| 565 | -+ | |||
| 177 | +2x |
- group_var = "ARM",+ a_count_cumulative, |
||
| 566 | -+ | |||
| 178 | +2x |
- facet_var = NA,+ .stats = .stats, |
||
| 567 | -+ | |||
| 179 | +2x |
- paramcd = "PARAMCD",+ .formats = .formats, |
||
| 568 | -+ | |||
| 180 | +2x |
- y_unit = "AVALU",+ .labels = .labels, |
||
| 569 | -+ | |||
| 181 | +2x |
- subject_var = "USUBJID") {
+ .indent_mods = .indent_mods, |
||
| 570 | -15x | +182 | +2x |
- checkmate::assert_string(x)+ .ungroup_stats = "count_fraction"+ |
+
| 183 | ++ |
+ ) |
||
| 571 | -15x | +184 | +2x |
- checkmate::assert_string(y)+ analyze( |
| 572 | -15x | +185 | +2x |
- checkmate::assert_string(group_var, na.ok = TRUE, null.ok = TRUE)+ lyt, |
| 573 | -15x | +186 | +2x |
- checkmate::assert_string(facet_var, na.ok = TRUE, null.ok = TRUE)+ vars, |
| 574 | -15x | +187 | +2x |
- checkmate::assert_string(subject_var, na.ok = TRUE, null.ok = TRUE)+ afun = afun, |
| 575 | -15x | +188 | +2x |
- checkmate::assert_string(paramcd, na.ok = TRUE, null.ok = TRUE)+ na_str = na_str, |
| 576 | -15x | +189 | +2x |
- checkmate::assert_string(y_unit, na.ok = TRUE, null.ok = TRUE)+ table_names = table_names, |
| 577 | -+ | |||
| 190 | +2x |
-
+ var_labels = var_labels, |
||
| 578 | -15x | +191 | +2x |
- variables <- c(+ show_labels = show_labels, |
| 579 | -15x | +192 | +2x |
- x = x, y = y, group_var = group_var, paramcd = paramcd,+ nested = nested, |
| 580 | -15x | +193 | +2x |
- y_unit = y_unit, subject_var = subject_var, facet_var = facet_var+ extra_args = extra_args |
| 581 | +194 |
) |
||
| 582 | -15x | -
- return(variables)- |
- ||
| 583 | +195 |
}@@ -103418,14 +104069,14 @@ tern coverage - 95.64% |
| 1 |
- #' Odds ratio estimation+ #' Helper function to create a new SMQ variable in ADAE by stacking SMQ and/or CQ records. |
||
| 5 |
- #' The analyze function [estimate_odds_ratio()] creates a layout element to compare bivariate responses between+ #' Helper function to create a new SMQ variable in ADAE that consists of all adverse events belonging to |
||
| 6 |
- #' two groups by estimating an odds ratio and its confidence interval.+ #' selected Standardized/Customized queries. The new dataset will only contain records of the adverse events |
||
| 7 |
- #'+ #' belonging to any of the selected baskets. Remember that `na_str` must match the needed pre-processing |
||
| 8 |
- #' The primary analysis variable specified by `vars` is the group variable. Additional variables can be included in the+ #' done with [df_explicit_na()] to have the desired output. |
||
| 9 |
- #' analysis via the `variables` argument, which accepts `arm`, an arm variable, and `strata`, a stratification variable.+ #' |
||
| 10 |
- #' If more than two arm levels are present, they can be combined into two groups using the `groups_list` argument.+ #' @inheritParams argument_convention |
||
| 11 |
- #'+ #' @param baskets (`character`)\cr variable names of the selected Standardized/Customized queries. |
||
| 12 |
- #' @inheritParams split_cols_by_groups+ #' @param smq_varlabel (`string`)\cr a label for the new variable created. |
||
| 13 |
- #' @inheritParams argument_convention+ #' @param keys (`character`)\cr names of the key variables to be returned along with the new variable created. |
||
| 14 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_odds_ratio")`
+ #' @param aag_summary (`data.frame`)\cr containing the SMQ baskets and the levels of interest for the final SMQ |
||
| 15 |
- #' to see available statistics for this function.+ #' variable. This is useful when there are some levels of interest that are not observed in the `df` dataset. |
||
| 16 |
- #' @param method (`string`)\cr whether to use the correct (`"exact"`) calculation in the conditional likelihood or one+ #' The two columns of this dataset should be named `basket` and `basket_name`. |
||
| 17 |
- #' of the approximations. See [survival::clogit()] for details.+ #' |
||
| 18 |
- #'+ #' @return A `data.frame` with variables in `keys` taken from `df` and new variable SMQ containing |
||
| 19 |
- #' @note+ #' records belonging to the baskets selected via the `baskets` argument. |
||
| 20 |
- #' * This function uses logistic regression for unstratified analyses, and conditional logistic regression for+ #' |
||
| 21 |
- #' stratified analyses. The Wald confidence interval is calculated with the specified confidence level.+ #' @examples |
||
| 22 |
- #' * For stratified analyses, there is currently no implementation for conditional likelihood confidence intervals,+ #' adae <- tern_ex_adae[1:20, ] %>% df_explicit_na() |
||
| 23 |
- #' therefore the likelihood confidence interval is not available as an option.+ #' h_stack_by_baskets(df = adae) |
||
| 24 |
- #' * When `vars` contains only responders or non-responders no odds ratio estimation is possible so the returned+ #' |
||
| 25 |
- #' values will be `NA`.+ #' aag <- data.frame( |
||
| 26 |
- #'+ #' NAMVAR = c("CQ01NAM", "CQ02NAM", "SMQ01NAM", "SMQ02NAM"),
|
||
| 27 |
- #' @seealso Relevant helper function [h_odds_ratio()].+ #' REFNAME = c( |
||
| 28 |
- #'+ #' "D.2.1.5.3/A.1.1.1.1 aesi", "X.9.9.9.9/Y.8.8.8.8 aesi", |
||
| 29 |
- #' @name odds_ratio+ #' "C.1.1.1.3/B.2.2.3.1 aesi", "C.1.1.1.3/B.3.3.3.3 aesi" |
||
| 30 |
- #' @order 1+ #' ), |
||
| 31 |
- NULL+ #' SCOPE = c("", "", "BROAD", "BROAD"),
|
||
| 32 |
-
+ #' stringsAsFactors = FALSE |
||
| 33 |
- #' @describeIn odds_ratio Statistics function which estimates the odds ratio+ #' ) |
||
| 34 |
- #' between a treatment and a control. A `variables` list with `arm` and `strata`+ #' |
||
| 35 |
- #' variable names must be passed if a stratified analysis is required.+ #' basket_name <- character(nrow(aag)) |
||
| 36 |
- #'+ #' cq_pos <- grep("^(CQ).+NAM$", aag$NAMVAR)
|
||
| 37 |
- #' @return+ #' smq_pos <- grep("^(SMQ).+NAM$", aag$NAMVAR)
|
||
| 38 |
- #' * `s_odds_ratio()` returns a named list with the statistics `or_ci`+ #' basket_name[cq_pos] <- aag$REFNAME[cq_pos] |
||
| 39 |
- #' (containing `est`, `lcl`, and `ucl`) and `n_tot`.+ #' basket_name[smq_pos] <- paste0( |
||
| 40 |
- #'+ #' aag$REFNAME[smq_pos], "(", aag$SCOPE[smq_pos], ")"
|
||
| 41 |
- #' @examples+ #' ) |
||
| 42 |
- #' # Unstratified analysis.+ #' |
||
| 43 |
- #' s_odds_ratio(+ #' aag_summary <- data.frame( |
||
| 44 |
- #' df = subset(dta, grp == "A"),+ #' basket = aag$NAMVAR, |
||
| 45 |
- #' .var = "rsp",+ #' basket_name = basket_name, |
||
| 46 |
- #' .ref_group = subset(dta, grp == "B"),+ #' stringsAsFactors = TRUE |
||
| 47 |
- #' .in_ref_col = FALSE,+ #' ) |
||
| 48 |
- #' .df_row = dta+ #' |
||
| 49 |
- #' )+ #' result <- h_stack_by_baskets(df = adae, aag_summary = aag_summary) |
||
| 50 |
- #'+ #' all(levels(aag_summary$basket_name) %in% levels(result$SMQ)) |
||
| 51 |
- #' # Stratified analysis.+ #' |
||
| 52 |
- #' s_odds_ratio(+ #' h_stack_by_baskets( |
||
| 53 |
- #' df = subset(dta, grp == "A"),+ #' df = adae, |
||
| 54 |
- #' .var = "rsp",+ #' aag_summary = NULL, |
||
| 55 |
- #' .ref_group = subset(dta, grp == "B"),+ #' keys = c("STUDYID", "USUBJID", "AEDECOD", "ARM"),
|
||
| 56 |
- #' .in_ref_col = FALSE,+ #' baskets = "SMQ01NAM" |
||
| 57 |
- #' .df_row = dta,+ #' ) |
||
| 58 |
- #' variables = list(arm = "grp", strata = "strata")+ #' |
||
| 59 |
- #' )+ #' @export |
||
| 60 |
- #'+ h_stack_by_baskets <- function(df, |
||
| 61 |
- #' @export+ baskets = grep("^(SMQ|CQ).+NAM$", names(df), value = TRUE),
|
||
| 62 |
- s_odds_ratio <- function(df,+ smq_varlabel = "Standardized MedDRA Query", |
||
| 63 |
- .var,+ keys = c("STUDYID", "USUBJID", "ASTDTM", "AEDECOD", "AESEQ"),
|
||
| 64 |
- .ref_group,+ aag_summary = NULL, |
||
| 65 |
- .in_ref_col,+ na_str = "<Missing>") {
|
||
| 66 | -+ | 5x |
- .df_row,+ smq_nam <- baskets[startsWith(baskets, "SMQ")] |
| 67 |
- variables = list(arm = NULL, strata = NULL),+ # SC corresponding to NAM |
||
| 68 | -+ | 5x |
- conf_level = 0.95,+ smq_sc <- gsub(pattern = "NAM", replacement = "SC", x = smq_nam, fixed = TRUE) |
| 69 | -+ | 5x |
- groups_list = NULL,+ smq <- stats::setNames(smq_sc, smq_nam) |
| 70 |
- method = "exact") {
+
|
||
| 71 | -87x | +5x |
- y <- list(or_ci = "", n_tot = "")+ checkmate::assert_character(baskets) |
| 72 | -+ | 5x |
-
+ checkmate::assert_string(smq_varlabel) |
| 73 | -87x | +5x |
- if (!.in_ref_col) {
+ checkmate::assert_data_frame(df) |
| 74 | -87x | +5x |
- assert_proportion_value(conf_level)+ checkmate::assert_true(all(startsWith(baskets, "SMQ") | startsWith(baskets, "CQ"))) |
| 75 | -87x | +4x |
- assert_df_with_variables(df, list(rsp = .var))+ checkmate::assert_true(all(endsWith(baskets, "NAM"))) |
| 76 | -87x | +3x |
- assert_df_with_variables(.ref_group, list(rsp = .var))+ checkmate::assert_subset(baskets, names(df)) |
| 77 | -+ | 3x |
-
+ checkmate::assert_subset(keys, names(df)) |
| 78 | -87x | +3x |
- if (is.null(variables$strata)) {
+ checkmate::assert_subset(smq_sc, names(df)) |
| 79 | -72x | +3x |
- data <- data.frame(+ checkmate::assert_string(na_str) |
| 80 | -72x | +
- rsp = c(.ref_group[[.var]], df[[.var]]),+ |
|
| 81 | -72x | +3x |
- grp = factor(+ if (!is.null(aag_summary)) {
|
| 82 | -72x | +1x |
- rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
+ assert_df_with_variables( |
| 83 | -72x | +1x |
- levels = c("ref", "Not-ref")
+ df = aag_summary, |
| 84 | -+ | 1x |
- )+ variables = list(val = c("basket", "basket_name"))
|
| 85 |
- )+ ) |
||
| 86 | -72x | +
- y <- or_glm(data, conf_level = conf_level)+ # Warning in case there is no match between `aag_summary$basket` and `baskets` argument. |
|
| 87 |
- } else {
+ # Honestly, I think those should completely match. Target baskets should be the same. |
||
| 88 | -15x | +1x |
- assert_df_with_variables(.df_row, c(list(rsp = .var), variables))+ if (length(intersect(baskets, unique(aag_summary$basket))) == 0) {
|
| 89 | -15x | +! |
- checkmate::assert_subset(method, c("exact", "approximate", "efron", "breslow"), empty.ok = FALSE)
+ warning("There are 0 baskets in common between aag_summary$basket and `baskets` argument.")
|
| 90 |
-
+ } |
||
| 91 |
- # The group variable prepared for clogit must be synchronised with combination groups definition.+ } |
||
| 92 | -15x | +
- if (is.null(groups_list)) {
+
|
|
| 93 | -14x | +3x |
- ref_grp <- as.character(unique(.ref_group[[variables$arm]]))+ var_labels <- c(formatters::var_labels(df[, keys]), "SMQ" = smq_varlabel) |
| 94 | -14x | +
- trt_grp <- as.character(unique(df[[variables$arm]]))+ |
|
| 95 | -14x | +
- grp <- stats::relevel(factor(.df_row[[variables$arm]]), ref = ref_grp)+ # convert `na_str` records from baskets to NA for the later loop and from wide to long steps |
|
| 96 | -+ | 3x |
- } else {
+ df[, c(baskets, smq_sc)][df[, c(baskets, smq_sc)] == na_str] <- NA |
| 97 |
- # If more than one level in reference col.+ |
||
| 98 | -1x | +3x |
- reference <- as.character(unique(.ref_group[[variables$arm]]))+ if (all(is.na(df[, baskets]))) { # in case there is no level for the target baskets
|
| 99 | 1x |
- grp_ref_flag <- vapply(+ df_long <- df[-seq_len(nrow(df)), keys] # we just need an empty data frame keeping all factor levels |
|
| 100 | -1x | +
- X = groups_list,+ } else {
|
|
| 101 | -1x | +
- FUN.VALUE = TRUE,+ # Concatenate SMQxxxNAM with corresponding SMQxxxSC |
|
| 102 | -1x | +2x |
- FUN = function(x) all(reference %in% x)+ df_cnct <- df[, c(keys, baskets[startsWith(baskets, "CQ")])] |
| 103 |
- )+ |
||
| 104 | -1x | +2x |
- ref_grp <- names(groups_list)[grp_ref_flag]+ for (nam in names(smq)) {
|
| 105 | -+ | 4x |
-
+ sc <- smq[nam] # SMQxxxSC corresponding to SMQxxxNAM |
| 106 | -+ | 4x |
- # If more than one level in treatment col.+ nam_notna <- !is.na(df[[nam]]) |
| 107 | -1x | +4x |
- treatment <- as.character(unique(df[[variables$arm]]))+ new_colname <- paste(nam, sc, sep = "_") |
| 108 | -1x | +4x |
- grp_trt_flag <- vapply(+ df_cnct[nam_notna, new_colname] <- paste0(df[[nam]], "(", df[[sc]], ")")[nam_notna]
|
| 109 | -1x | +
- X = groups_list,+ } |
|
| 110 | -1x | +
- FUN.VALUE = TRUE,+ |
|
| 111 | -1x | +2x |
- FUN = function(x) all(treatment %in% x)+ df_cnct$unique_id <- seq(1, nrow(df_cnct)) |
| 112 | -+ | 2x |
- )+ var_cols <- names(df_cnct)[!(names(df_cnct) %in% c(keys, "unique_id"))] |
| 113 | -1x | +
- trt_grp <- names(groups_list)[grp_trt_flag]+ # have to convert df_cnct from tibble to data frame |
|
| 114 |
-
+ # as it throws a warning otherwise about rownames. |
||
| 115 | -1x | +
- grp <- combine_levels(.df_row[[variables$arm]], levels = reference, new_level = ref_grp)+ # tibble do not support rownames and reshape creates rownames |
|
| 116 | -1x | +
- grp <- combine_levels(grp, levels = treatment, new_level = trt_grp)+ |
|
| 117 | -+ | 2x |
- }+ df_long <- stats::reshape( |
| 118 | -+ | 2x |
-
+ data = as.data.frame(df_cnct), |
| 119 | -+ | 2x |
- # The reference level in `grp` must be the same as in the `rtables` column split.+ varying = var_cols, |
| 120 | -15x | +2x |
- data <- data.frame(+ v.names = "SMQ", |
| 121 | -15x | +2x |
- rsp = .df_row[[.var]],+ idvar = names(df_cnct)[names(df_cnct) %in% c(keys, "unique_id")], |
| 122 | -15x | +2x |
- grp = grp,+ direction = "long", |
| 123 | -15x | +2x |
- strata = interaction(.df_row[variables$strata])+ new.row.names = seq(prod(length(var_cols), nrow(df_cnct))) |
| 124 |
- )+ ) |
||
| 125 | -15x | +
- y_all <- or_clogit(data, conf_level = conf_level, method = method)+ |
|
| 126 | -15x | +2x |
- checkmate::assert_string(trt_grp)+ df_long <- df_long[!is.na(df_long[, "SMQ"]), !(names(df_long) %in% c("time", "unique_id"))]
|
| 127 | -15x | +2x |
- checkmate::assert_subset(trt_grp, names(y_all$or_ci))+ df_long$SMQ <- as.factor(df_long$SMQ) |
| 128 | -14x | +
- y$or_ci <- y_all$or_ci[[trt_grp]]+ } |
|
| 129 | -14x | +
- y$n_tot <- y_all$n_tot+ |
|
| 130 | -+ | 3x |
- }+ smq_levels <- setdiff(levels(df_long[["SMQ"]]), na_str) |
| 131 |
- }+ |
||
| 132 | -+ | 3x |
-
+ if (!is.null(aag_summary)) {
|
| 133 | -86x | +
- if ("est" %in% names(y$or_ci) && is.na(y$or_ci[["est"]]) && method != "approximate") {
+ # A warning in case there is no match between df and aag_summary records |
|
| 134 | 1x |
- warning(+ if (length(intersect(smq_levels, unique(aag_summary$basket_name))) == 0) {
|
|
| 135 | 1x |
- "Unable to compute the odds ratio estimate. Please try re-running the function with ",+ warning("There are 0 basket levels in common between aag_summary$basket_name and df.")
|
|
| 136 | -1x | +
- 'parameter `method` set to "approximate".'+ } |
|
| 137 | -+ | 1x |
- )+ df_long[["SMQ"]] <- factor( |
| 138 | -+ | 1x |
- }+ df_long[["SMQ"]], |
| 139 | -+ | 1x |
-
+ levels = sort( |
| 140 | -86x | +1x |
- y$or_ci <- formatters::with_label(+ c( |
| 141 | -86x | +1x |
- x = y$or_ci,+ smq_levels, |
| 142 | -86x | +1x |
- label = paste0("Odds Ratio (", 100 * conf_level, "% CI)")
+ setdiff(unique(aag_summary$basket_name), smq_levels) |
| 143 |
- )+ ) |
||
| 144 |
-
+ ) |
||
| 145 | -86x | +
- y$n_tot <- formatters::with_label(+ ) |
|
| 146 | -86x | +
- x = y$n_tot,+ } else {
|
|
| 147 | -86x | +2x |
- label = "Total n"+ all_na_basket_flag <- vapply(df[, baskets], function(x) {
|
| 148 | -+ | 6x |
- )+ all(is.na(x)) |
| 149 | -+ | 2x |
-
+ }, FUN.VALUE = logical(1)) |
| 150 | -86x | +2x |
- y+ all_na_basket <- baskets[all_na_basket_flag] |
| 151 | + | + + | +|
| 152 | +2x | +
+ df_long[["SMQ"]] <- factor(+ |
+ |
| 153 | +2x | +
+ df_long[["SMQ"]],+ |
+ |
| 154 | +2x | +
+ levels = sort(c(smq_levels, all_na_basket))+ |
+ |
| 155 | ++ |
+ )+ |
+ |
| 156 | ++ |
+ }+ |
+ |
| 157 | +3x | +
+ formatters::var_labels(df_long) <- var_labels+ |
+ |
| 158 | +3x | +
+ tibble::tibble(df_long)+ |
+ |
| 159 | +
} |
| 152 | +1 |
-
+ #' Tabulate biomarker effects on binary response by subgroup |
||
| 153 | +2 |
- #' @describeIn odds_ratio Formatted analysis function which is used as `afun` in `estimate_odds_ratio()`.+ #' |
||
| 154 | +3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+ |
| 4 |
#' |
|||
| 155 | +5 |
- #' @return+ #' The [tabulate_rsp_biomarkers()] function creates a layout element to tabulate the estimated biomarker effects on a |
||
| 156 | +6 |
- #' * `a_odds_ratio()` returns the corresponding list with formatted [rtables::CellValue()].+ #' binary response endpoint across subgroups, returning statistics including response rate and odds ratio for each |
||
| 157 | +7 | ++ |
+ #' population subgroup. The table is created from `df`, a list of data frames returned by [extract_rsp_biomarkers()],+ |
+ |
| 8 | ++ |
+ #' with the statistics to include specified via the `vars` parameter.+ |
+ ||
| 9 |
#' |
|||
| 158 | +10 |
- #' @examples+ #' A forest plot can be created from the resulting table using the [g_forest()] function. |
||
| 159 | +11 |
- #' a_odds_ratio(+ #' |
||
| 160 | +12 |
- #' df = subset(dta, grp == "A"),+ #' @inheritParams argument_convention |
||
| 161 | +13 |
- #' .var = "rsp",+ #' @param df (`data.frame`)\cr containing all analysis variables, as returned by |
||
| 162 | +14 |
- #' .ref_group = subset(dta, grp == "B"),+ #' [extract_rsp_biomarkers()]. |
||
| 163 | +15 |
- #' .in_ref_col = FALSE,+ #' @param vars (`character`)\cr the names of statistics to be reported among: |
||
| 164 | +16 |
- #' .df_row = dta+ #' * `n_tot`: Total number of patients per group. |
||
| 165 | +17 |
- #' )+ #' * `n_rsp`: Total number of responses per group. |
||
| 166 | +18 | ++ |
+ #' * `prop`: Total response proportion per group.+ |
+ |
| 19 | ++ |
+ #' * `or`: Odds ratio.+ |
+ ||
| 20 | ++ |
+ #' * `ci`: Confidence interval of odds ratio.+ |
+ ||
| 21 | ++ |
+ #' * `pval`: p-value of the effect.+ |
+ ||
| 22 | ++ |
+ #' Note, the statistics `n_tot`, `or` and `ci` are required.+ |
+ ||
| 23 |
#' |
|||
| 167 | +24 |
- #' @export+ #' @return An `rtables` table summarizing biomarker effects on binary response by subgroup. |
||
| 168 | +25 |
- a_odds_ratio <- make_afun(+ #' |
||
| 169 | +26 |
- s_odds_ratio,+ #' @details These functions create a layout starting from a data frame which contains |
||
| 170 | +27 |
- .formats = c(or_ci = "xx.xx (xx.xx - xx.xx)"),+ #' the required statistics. The tables are then typically used as input for forest plots. |
||
| 171 | +28 |
- .indent_mods = c(or_ci = 1L)+ #' |
||
| 172 | +29 |
- )+ #' @note In contrast to [tabulate_rsp_subgroups()] this tabulation function does |
||
| 173 | +30 |
-
+ #' not start from an input layout `lyt`. This is because internally the table is |
||
| 174 | +31 |
- #' @describeIn odds_ratio Layout-creating function which can take statistics function arguments+ #' created by combining multiple subtables. |
||
| 175 | +32 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' |
||
| 176 | +33 | ++ |
+ #' @seealso [h_tab_rsp_one_biomarker()] which is used internally, [extract_rsp_biomarkers()].+ |
+ |
| 34 |
#' |
|||
| 177 | +35 |
- #' @return+ #' @examples |
||
| 178 | +36 |
- #' * `estimate_odds_ratio()` returns a layout object suitable for passing to further layouting functions,+ #' library(dplyr) |
||
| 179 | +37 | ++ |
+ #' library(forcats)+ |
+ |
| 38 | ++ |
+ #'+ |
+ ||
| 39 | ++ |
+ #' adrs <- tern_ex_adrs+ |
+ ||
| 40 | ++ |
+ #' adrs_labels <- formatters::var_labels(adrs)+ |
+ ||
| 41 | ++ |
+ #'+ |
+ ||
| 42 | ++ |
+ #' adrs_f <- adrs %>%+ |
+ ||
| 43 | ++ |
+ #' filter(PARAMCD == "BESRSPI") %>%+ |
+ ||
| 44 | ++ |
+ #' mutate(rsp = AVALC == "CR")+ |
+ ||
| 45 | ++ |
+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ |
+ ||
| 46 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
|||
| 180 | +47 |
- #' the statistics from `s_odds_ratio()` to the table layout.+ #' df <- extract_rsp_biomarkers( |
||
| 181 | +48 |
- #'+ #' variables = list( |
||
| 182 | +49 |
- #' @examples+ #' rsp = "rsp", |
||
| 183 | +50 |
- #' set.seed(12)+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 184 | +51 |
- #' dta <- data.frame(+ #' covariates = "SEX", |
||
| 185 | +52 |
- #' rsp = sample(c(TRUE, FALSE), 100, TRUE),+ #' subgroups = "BMRKR2" |
||
| 186 | +53 |
- #' grp = factor(rep(c("A", "B"), each = 50), levels = c("A", "B")),
+ #' ), |
||
| 187 | +54 |
- #' strata = factor(sample(c("C", "D"), 100, TRUE))
+ #' data = adrs_f |
||
| 188 | +55 |
#' ) |
||
| 189 | +56 |
#' |
||
| 190 | +57 |
- #' l <- basic_table() %>%+ #' \donttest{
|
||
| 191 | +58 |
- #' split_cols_by(var = "grp", ref_group = "B") %>%+ #' ## Table with default columns. |
||
| 192 | +59 |
- #' estimate_odds_ratio(vars = "rsp")+ #' tabulate_rsp_biomarkers(df) |
||
| 193 | +60 |
#' |
||
| 194 | +61 |
- #' build_table(l, df = dta)+ #' ## Table with a manually chosen set of columns: leave out "pval", reorder. |
||
| 195 | +62 |
- #'+ #' tab <- tabulate_rsp_biomarkers( |
||
| 196 | +63 |
- #' @export+ #' df = df, |
||
| 197 | +64 |
- #' @order 2+ #' vars = c("n_rsp", "ci", "n_tot", "prop", "or")
|
||
| 198 | +65 |
- estimate_odds_ratio <- function(lyt,+ #' ) |
||
| 199 | +66 |
- vars,+ #' |
||
| 200 | +67 |
- variables = list(arm = NULL, strata = NULL),+ #' ## Finally produce the forest plot. |
||
| 201 | +68 |
- conf_level = 0.95,+ #' g_forest(tab, xlim = c(0.7, 1.4)) |
||
| 202 | +69 |
- groups_list = NULL,+ #' } |
||
| 203 | +70 |
- na_str = default_na_str(),+ #' |
||
| 204 | +71 |
- nested = TRUE,+ #' @export |
||
| 205 | +72 |
- method = "exact",+ #' @name response_biomarkers_subgroups |
||
| 206 | +73 |
- show_labels = "hidden",+ tabulate_rsp_biomarkers <- function(df, |
||
| 207 | +74 |
- table_names = vars,+ vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
|
||
| 208 | +75 |
- var_labels = vars,+ na_str = default_na_str(), |
||
| 209 | +76 |
- .stats = "or_ci",+ .indent_mods = 0L) {
|
||
| 210 | -+ | |||
| 77 | +4x |
- .formats = NULL,+ checkmate::assert_data_frame(df)+ |
+ ||
| 78 | +4x | +
+ checkmate::assert_character(df$biomarker)+ |
+ ||
| 79 | +4x | +
+ checkmate::assert_character(df$biomarker_label)+ |
+ ||
| 80 | +4x | +
+ checkmate::assert_subset(vars, get_stats("tabulate_rsp_biomarkers"))
|
||
| 211 | +81 |
- .labels = NULL,+ |
||
| 212 | +82 |
- .indent_mods = NULL) {
+ # Create "ci" column from "lcl" and "ucl" |
||
| 213 | -5x | +83 | +4x |
- extra_args <- list(variables = variables, conf_level = conf_level, groups_list = groups_list, method = method)+ df$ci <- combine_vectors(df$lcl, df$ucl) |
| 214 | +84 | |||
| 215 | -5x | +85 | +4x |
- afun <- make_afun(+ df_subs <- split(df, f = df$biomarker) |
| 216 | -5x | +86 | +4x |
- a_odds_ratio,+ tabs <- lapply(df_subs, FUN = function(df_sub) {
|
| 217 | -5x | +87 | +7x |
- .stats = .stats,+ tab_sub <- h_tab_rsp_one_biomarker( |
| 218 | -5x | +88 | +7x |
- .formats = .formats,+ df = df_sub, |
| 219 | -5x | +89 | +7x |
- .labels = .labels,+ vars = vars, |
| 220 | -5x | +90 | +7x |
- .indent_mods = .indent_mods+ na_str = na_str,+ |
+
| 91 | +7x | +
+ .indent_mods = .indent_mods |
||
| 221 | +92 |
- )+ ) |
||
| 222 | +93 |
-
+ # Insert label row as first row in table. |
||
| 223 | -5x | +94 | +7x |
- analyze(+ label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1] |
| 224 | -5x | +95 | +7x |
- lyt,+ tab_sub+ |
+
| 96 | ++ |
+ }) |
||
| 225 | -5x | +97 | +4x |
- vars,+ result <- do.call(rbind, tabs)+ |
+
| 98 | ++ | + | ||
| 226 | -5x | +99 | +4x |
- afun = afun,+ n_id <- grep("n_tot", vars)
|
| 227 | -5x | +100 | +4x |
- var_labels = var_labels,+ or_id <- match("or", vars)
|
| 228 | -5x | +101 | +4x |
- na_str = na_str,+ ci_id <- match("ci", vars)
|
| 229 | -5x | +102 | +4x |
- nested = nested,+ structure( |
| 230 | -5x | +103 | +4x |
- extra_args = extra_args,+ result, |
| 231 | -5x | +104 | +4x |
- show_labels = show_labels,+ forest_header = paste0(c("Lower", "Higher"), "\nBetter"),
|
| 232 | -5x | +105 | +4x |
- table_names = table_names+ col_x = or_id,+ |
+
| 106 | +4x | +
+ col_ci = ci_id,+ |
+ ||
| 107 | +4x | +
+ col_symbol_size = n_id |
||
| 233 | +108 |
) |
||
| 234 | +109 |
} |
||
| 235 | +110 | |||
| 236 | +111 |
- #' Helper functions for odds ratio estimation+ #' Prepare response data estimates for multiple biomarkers in a single data frame |
||
| 237 | +112 |
#' |
||
| 238 | +113 |
#' @description `r lifecycle::badge("stable")`
|
||
| 239 | +114 |
#' |
||
| 240 | +115 |
- #' Functions to calculate odds ratios in [estimate_odds_ratio()].+ #' Prepares estimates for number of responses, patients and overall response rate, |
||
| 241 | +116 |
- #'+ #' as well as odds ratio estimates, confidence intervals and p-values, |
||
| 242 | +117 |
- #' @inheritParams odds_ratio+ #' for multiple biomarkers across population subgroups in a single data frame. |
||
| 243 | +118 |
- #' @inheritParams argument_convention+ #' `variables` corresponds to the names of variables found in `data`, passed as a |
||
| 244 | +119 |
- #' @param data (`data.frame`)\cr data frame containing at least the variables `rsp` and `grp`, and optionally+ #' named list and requires elements `rsp` and `biomarkers` (vector of continuous |
||
| 245 | +120 |
- #' `strata` for [or_clogit()].+ #' biomarker variables) and optionally `covariates`, `subgroups` and `strata`. |
||
| 246 | +121 | ++ |
+ #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ |
+ |
| 122 |
#' |
|||
| 247 | +123 |
- #' @return A named `list` of elements `or_ci` and `n_tot`.+ #' @inheritParams argument_convention |
||
| 248 | +124 |
- #'+ #' @inheritParams response_subgroups |
||
| 249 | +125 |
- #' @seealso [odds_ratio]+ #' @param control (named `list`)\cr controls for the response definition and the |
||
| 250 | +126 | ++ |
+ #' confidence level produced by [control_logistic()].+ |
+ |
| 127 |
#' |
|||
| 251 | +128 |
- #' @name h_odds_ratio+ #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_rsp`, |
||
| 252 | +129 |
- NULL+ #' `prop`, `or`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`, |
||
| 253 | +130 |
-
+ #' `var_label`, and `row_type`. |
||
| 254 | +131 |
- #' @describeIn h_odds_ratio Estimates the odds ratio based on [stats::glm()]. Note that there must be+ #' |
||
| 255 | +132 |
- #' exactly 2 groups in `data` as specified by the `grp` variable.+ #' @note You can also specify a continuous variable in `rsp` and then use the |
||
| 256 | +133 | ++ |
+ #' `response_definition` control to convert that internally to a logical+ |
+ |
| 134 | ++ |
+ #' variable reflecting binary response.+ |
+ ||
| 135 |
#' |
|||
| 257 | +136 |
- #' @examples+ #' @seealso [h_logistic_mult_cont_df()] which is used internally. |
||
| 258 | +137 |
- #' # Data with 2 groups.+ #' |
||
| 259 | +138 |
- #' data <- data.frame(+ #' @examples |
||
| 260 | +139 |
- #' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1)),+ #' library(dplyr) |
||
| 261 | +140 |
- #' grp = letters[c(1, 1, 1, 2, 2, 2, 1, 2)],+ #' library(forcats) |
||
| 262 | +141 |
- #' strata = letters[c(1, 2, 1, 2, 2, 2, 1, 2)],+ #' |
||
| 263 | +142 |
- #' stringsAsFactors = TRUE+ #' adrs <- tern_ex_adrs |
||
| 264 | +143 |
- #' )+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 265 | +144 |
#' |
||
| 266 | +145 |
- #' # Odds ratio based on glm.+ #' adrs_f <- adrs %>% |
||
| 267 | +146 |
- #' or_glm(data, conf_level = 0.95)+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 268 | +147 |
- #'+ #' mutate(rsp = AVALC == "CR") |
||
| 269 | +148 |
- #' @export+ #' |
||
| 270 | +149 |
- or_glm <- function(data, conf_level) {
+ #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`, |
||
| 271 | -77x | +|||
| 150 | +
- checkmate::assert_logical(data$rsp)+ #' # in logistic regression models with one covariate `RACE`. The subgroups |
|||
| 272 | -77x | +|||
| 151 | +
- assert_proportion_value(conf_level)+ #' # are defined by the levels of `BMRKR2`. |
|||
| 273 | -77x | +|||
| 152 | +
- assert_df_with_variables(data, list(rsp = "rsp", grp = "grp"))+ #' df <- extract_rsp_biomarkers( |
|||
| 274 | -77x | +|||
| 153 | +
- checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
+ #' variables = list( |
|||
| 275 | +154 |
-
+ #' rsp = "rsp", |
||
| 276 | -77x | +|||
| 155 | +
- data$grp <- as_factor_keep_attributes(data$grp)+ #' biomarkers = c("BMRKR1", "AGE"),
|
|||
| 277 | -77x | +|||
| 156 | +
- assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2)+ #' covariates = "SEX", |
|||
| 278 | -77x | +|||
| 157 | +
- formula <- stats::as.formula("rsp ~ grp")
+ #' subgroups = "BMRKR2" |
|||
| 279 | -77x | +|||
| 158 | +
- model_fit <- stats::glm(+ #' ), |
|||
| 280 | -77x | +|||
| 159 | +
- formula = formula, data = data,+ #' data = adrs_f |
|||
| 281 | -77x | +|||
| 160 | +
- family = stats::binomial(link = "logit")+ #' ) |
|||
| 282 | +161 |
- )+ #' df |
||
| 283 | +162 |
-
+ #' |
||
| 284 | +163 |
- # Note that here we need to discard the intercept.+ #' # Here we group the levels of `BMRKR2` manually, and we add a stratification |
||
| 285 | -77x | +|||
| 164 | +
- or <- exp(stats::coef(model_fit)[-1])+ #' # variable `STRATA1`. We also here use a continuous variable `EOSDY` |
|||
| 286 | -77x | +|||
| 165 | +
- or_ci <- exp(+ #' # which is then binarized internally (response is defined as this variable |
|||
| 287 | -77x | +|||
| 166 | +
- stats::confint.default(model_fit, level = conf_level)[-1, , drop = FALSE]+ #' # being larger than 750). |
|||
| 288 | +167 |
- )+ #' df_grouped <- extract_rsp_biomarkers( |
||
| 289 | +168 |
-
+ #' variables = list( |
||
| 290 | -77x | +|||
| 169 | +
- values <- stats::setNames(c(or, or_ci), c("est", "lcl", "ucl"))
+ #' rsp = "EOSDY", |
|||
| 291 | -77x | +|||
| 170 | +
- n_tot <- stats::setNames(nrow(model_fit$model), "n_tot")+ #' biomarkers = c("BMRKR1", "AGE"),
|
|||
| 292 | +171 |
-
+ #' covariates = "SEX", |
||
| 293 | -77x | +|||
| 172 | +
- list(or_ci = values, n_tot = n_tot)+ #' subgroups = "BMRKR2", |
|||
| 294 | +173 |
- }+ #' strata = "STRATA1" |
||
| 295 | +174 |
-
+ #' ), |
||
| 296 | +175 |
- #' @describeIn h_odds_ratio Estimates the odds ratio based on [survival::clogit()]. This is done for+ #' data = adrs_f, |
||
| 297 | +176 |
- #' the whole data set including all groups, since the results are not the same as when doing+ #' groups_lists = list( |
||
| 298 | +177 |
- #' pairwise comparisons between the groups.+ #' BMRKR2 = list( |
||
| 299 | +178 |
- #'+ #' "low" = "LOW", |
||
| 300 | +179 |
- #' @examples+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 301 | +180 |
- #' # Data with 3 groups.+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 302 | +181 |
- #' data <- data.frame(+ #' ) |
||
| 303 | +182 |
- #' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0)),+ #' ), |
||
| 304 | +183 |
- #' grp = letters[c(1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3)],+ #' control = control_logistic( |
||
| 305 | +184 |
- #' strata = LETTERS[c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)],+ #' response_definition = "I(response > 750)" |
||
| 306 | +185 |
- #' stringsAsFactors = TRUE+ #' ) |
||
| 307 | +186 |
#' ) |
||
| 308 | +187 | ++ |
+ #' df_grouped+ |
+ |
| 188 |
#' |
|||
| 309 | +189 |
- #' # Odds ratio based on stratified estimation by conditional logistic regression.+ #' @export |
||
| 310 | +190 |
- #' or_clogit(data, conf_level = 0.95)+ extract_rsp_biomarkers <- function(variables, |
||
| 311 | +191 |
- #'+ data, |
||
| 312 | +192 |
- #' @export+ groups_lists = list(), |
||
| 313 | +193 |
- or_clogit <- function(data, conf_level, method = "exact") {
+ control = control_logistic(), |
||
| 314 | -19x | +|||
| 194 | +
- checkmate::assert_logical(data$rsp)+ label_all = "All Patients") {
|
|||
| 315 | -19x | +195 | +5x |
- assert_proportion_value(conf_level)+ if ("strat" %in% names(variables)) {
+ |
+
| 196 | +! | +
+ warning(+ |
+ ||
| 197 | +! | +
+ "Warning: the `strat` element name of the `variables` list argument to `extract_rsp_biomarkers() ",+ |
+ ||
| 198 | +! | +
+ "was deprecated in tern 0.9.4.\n ",+ |
+ ||
| 199 | +! | +
+ "Please use the name `strata` instead of `strat` in the `variables` argument."+ |
+ ||
| 200 | ++ |
+ )+ |
+ ||
| 201 | +! | +
+ variables[["strata"]] <- variables[["strat"]]+ |
+ ||
| 202 | ++ |
+ }+ |
+ ||
| 203 | ++ | + | ||
| 316 | -19x | +204 | +5x |
- assert_df_with_variables(data, list(rsp = "rsp", grp = "grp", strata = "strata"))+ assert_list_of_variables(variables) |
| 317 | -19x | +205 | +5x |
- checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
+ checkmate::assert_string(variables$rsp) |
| 318 | -19x | +206 | +5x |
- checkmate::assert_multi_class(data$strata, classes = c("factor", "character"))
+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 319 | -19x | +207 | +5x |
- checkmate::assert_subset(method, c("exact", "approximate", "efron", "breslow"), empty.ok = FALSE)
+ checkmate::assert_string(label_all) |
| 320 | +208 | |||
| 209 | ++ |
+ # Start with all patients.+ |
+ ||
| 321 | -19x | +210 | +5x |
- data$grp <- as_factor_keep_attributes(data$grp)+ result_all <- h_logistic_mult_cont_df( |
| 322 | -19x | +211 | +5x |
- data$strata <- as_factor_keep_attributes(data$strata)+ variables = variables, |
| 323 | -+ | |||
| 212 | +5x |
-
+ data = data,+ |
+ ||
| 213 | +5x | +
+ control = control |
||
| 324 | +214 |
- # Deviation from convention: `survival::strata` must be simply `strata`.+ ) |
||
| 325 | -19x | +215 | +5x |
- formula <- stats::as.formula("rsp ~ grp + strata(strata)")
+ result_all$subgroup <- label_all |
| 326 | -19x | +216 | +5x |
- model_fit <- clogit_with_tryCatch(formula = formula, data = data, method = method)+ result_all$var <- "ALL"+ |
+
| 217 | +5x | +
+ result_all$var_label <- label_all+ |
+ ||
| 218 | +5x | +
+ result_all$row_type <- "content"+ |
+ ||
| 219 | +5x | +
+ if (is.null(variables$subgroups)) {
|
||
| 327 | +220 |
-
+ # Only return result for all patients.+ |
+ ||
| 221 | +1x | +
+ result_all |
||
| 328 | +222 |
- # Create a list with one set of OR estimates and CI per coefficient, i.e.+ } else {
|
||
| 329 | +223 |
- # comparison of one group vs. the reference group.+ # Add subgroups results. |
||
| 330 | -19x | +224 | +4x |
- coef_est <- stats::coef(model_fit)+ l_data <- h_split_by_subgroups( |
| 331 | -19x | +225 | +4x |
- ci_est <- stats::confint(model_fit, level = conf_level)+ data, |
| 332 | -19x | +226 | +4x |
- or_ci <- list()+ variables$subgroups, |
| 333 | -19x | +227 | +4x |
- for (coef_name in names(coef_est)) {
+ groups_lists = groups_lists+ |
+
| 228 | ++ |
+ ) |
||
| 334 | -21x | +229 | +4x |
- grp_name <- gsub("^grp", "", x = coef_name)
+ l_result <- lapply(l_data, function(grp) {
|
| 335 | -21x | +230 | +20x |
- or_ci[[grp_name]] <- stats::setNames(+ result <- h_logistic_mult_cont_df( |
| 336 | -21x | +231 | +20x |
- object = exp(c(coef_est[coef_name], ci_est[coef_name, , drop = TRUE])),+ variables = variables, |
| 337 | -21x | +232 | +20x |
- nm = c("est", "lcl", "ucl")
+ data = grp$df,+ |
+
| 233 | +20x | +
+ control = control |
||
| 338 | +234 |
- )+ )+ |
+ ||
| 235 | +20x | +
+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ |
+ ||
| 236 | +20x | +
+ cbind(result, result_labels) |
||
| 339 | +237 |
- }+ }) |
||
| 340 | -19x | +238 | +4x |
- list(or_ci = or_ci, n_tot = c(n_tot = model_fit$n))+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ |
+
| 239 | +4x | +
+ result_subgroups$row_type <- "analysis"+ |
+ ||
| 240 | +4x | +
+ rbind(+ |
+ ||
| 241 | +4x | +
+ result_all,+ |
+ ||
| 242 | +4x | +
+ result_subgroups |
||
| 341 | +243 | ++ |
+ )+ |
+ |
| 244 | ++ |
+ }+ |
+ ||
| 245 |
}@@ -105811,14 +106909,14 @@ tern coverage - 95.64% |
| 1 |
- #' Count the number of patients with particular flags+ #' Line plot with optional table |
||
| 5 |
- #' The analyze function [count_patients_with_flags()] creates a layout element to calculate counts of patients for+ #' Line plot with the optional table. |
||
| 6 |
- #' which user-specified flags are present.+ #' |
||
| 7 |
- #'+ #' @inheritParams argument_convention |
||
| 8 |
- #' This function analyzes primary analysis variable `var` which indicates unique subject identifiers. Flags+ #' @param alt_counts_df (`data.frame` or `NULL`)\cr data set that will be used (only) |
||
| 9 |
- #' variables to analyze are specified by the user via the `flag_variables` argument, and must either take value+ #' to counts objects in groups for stratification. |
||
| 10 |
- #' `TRUE` (flag present) or `FALSE` (flag absent) for each record.+ #' @param variables (named `character`) vector of variable names in `df` which should include: |
||
| 11 |
- #'+ #' * `x` (`string`)\cr name of x-axis variable. |
||
| 12 |
- #' If there are multiple records with the same flag present for a patient, only one occurrence is counted.+ #' * `y` (`string`)\cr name of y-axis variable. |
||
| 13 |
- #'+ #' * `group_var` (`string` or `NULL`)\cr name of grouping variable (or strata), i.e. treatment arm. |
||
| 14 |
- #' @inheritParams argument_convention+ #' Can be `NA` to indicate lack of groups. |
||
| 15 |
- #' @param flag_variables (`character`)\cr a vector specifying the names of `logical` variables from analysis dataset+ #' * `subject_var` (`string` or `NULL`)\cr name of subject variable. Only applies if `group_var` is |
||
| 16 |
- #' used for counting the number of unique identifiers.+ #' not NULL. |
||
| 17 |
- #' @param flag_labels (`character`)\cr vector of labels to use for flag variables.+ #' * `paramcd` (`string` or `NA`)\cr name of the variable for parameter's code. Used for y-axis label and plot's |
||
| 18 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_patients_with_flags")`
+ #' subtitle. Can be `NA` if `paramcd` is not to be added to the y-axis label or subtitle. |
||
| 19 |
- #' to see available statistics for this function.+ #' * `y_unit` (`string` or `NA`)\cr name of variable with units of `y`. Used for y-axis label and plot's subtitle. |
||
| 20 |
- #'+ #' Can be `NA` if y unit is not to be added to the y-axis label or subtitle. |
||
| 21 |
- #' @seealso [count_patients_with_event]+ #' * `facet_var` (`string` or `NA`)\cr name of the secondary grouping variable used for plot faceting, i.e. treatment |
||
| 22 |
- #'+ #' arm. Can be `NA` to indicate lack of groups. |
||
| 23 |
- #' @name count_patients_with_flags+ #' @param mid (`character` or `NULL`)\cr names of the statistics that will be plotted as midpoints. |
||
| 24 |
- #' @order 1+ #' All the statistics indicated in `mid` variable must be present in the object returned by `sfun`, |
||
| 25 |
- NULL+ #' and be of a `double` or `numeric` type vector of length one. |
||
| 26 |
-
+ #' @param interval (`character` or `NULL`)\cr names of the statistics that will be plotted as intervals. |
||
| 27 |
- #' @describeIn count_patients_with_flags Statistics function which counts the number of patients for which+ #' All the statistics indicated in `interval` variable must be present in the object returned by `sfun`, |
||
| 28 |
- #' a particular flag variable is `TRUE`.+ #' and be of a `double` or `numeric` type vector of length two. Set `interval = NULL` if intervals should not be |
||
| 29 |
- #'+ #' added to the plot. |
||
| 30 |
- #' @inheritParams analyze_variables+ #' @param whiskers (`character`)\cr names of the interval whiskers that will be plotted. Names must match names |
||
| 31 |
- #' @param .var (`string`)\cr name of the column that contains the unique identifier.+ #' of the list element `interval` that will be returned by `sfun` (e.g. `mean_ci_lwr` element of |
||
| 32 |
- #'+ #' `sfun(x)[["mean_ci"]]`). It is possible to specify one whisker only, or to suppress all whiskers by setting |
||
| 33 |
- #' @note If `flag_labels` is not specified, variables labels will be extracted from `df`. If variables are not+ #' `interval = NULL`. |
||
| 34 |
- #' labeled, variable names will be used instead. Alternatively, a named `vector` can be supplied to+ #' @param table (`character` or `NULL`)\cr names of the statistics that will be displayed in the table below the plot. |
||
| 35 |
- #' `flag_variables` such that within each name-value pair the name corresponds to the variable name and the value is+ #' All the statistics indicated in `table` variable must be present in the object returned by `sfun`. |
||
| 36 |
- #' the label to use for this variable.+ #' @param sfun (`function`)\cr the function to compute the values of required statistics. It must return a named `list` |
||
| 37 |
- #'+ #' with atomic vectors. The names of the `list` elements refer to the names of the statistics and are used by `mid`, |
||
| 38 |
- #' @return+ #' `interval`, `table`. It must be able to accept as input a vector with data for which statistics are computed. |
||
| 39 |
- #' * `s_count_patients_with_flags()` returns the count and the fraction of unique identifiers with each particular+ #' @param ... optional arguments to `sfun`. |
||
| 40 |
- #' flag as a list of statistics `n`, `count`, `count_fraction`, and `n_blq`, with one element per flag.+ #' @param mid_type (`string`)\cr controls the type of the `mid` plot, it can be point (`"p"`), line (`"l"`), |
||
| 41 |
- #'+ #' or point and line (`"pl"`). |
||
| 42 |
- #' @examples+ #' @param mid_point_size (`numeric(1)`)\cr font size of the `mid` plot points. |
||
| 43 |
- #' # `s_count_patients_with_flags()`+ #' @param position (`character` or `call`)\cr geom element position adjustment, either as a string, or the result of |
||
| 44 |
- #'+ #' a call to a position adjustment function. |
||
| 45 |
- #' s_count_patients_with_flags(+ #' @param legend_title (`string`)\cr legend title. |
||
| 46 |
- #' adae,+ #' @param legend_position (`string`)\cr the position of the plot legend (`"none"`, `"left"`, `"right"`, `"bottom"`, |
||
| 47 |
- #' "SUBJID",+ #' `"top"`, or a two-element numeric vector). |
||
| 48 |
- #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
+ #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot. |
||
| 49 |
- #' denom = "N_col",+ #' @param xticks (`numeric` or `NULL`)\cr numeric vector of tick positions or a single number with spacing |
||
| 50 |
- #' .N_col = 1000+ #' between ticks on the x-axis, for use when `variables$x` is numeric. If `NULL` (default), [labeling::extended()] is |
||
| 51 |
- #' )+ #' used to determine optimal tick positions on the x-axis. If `variables$x` is not numeric, this argument is ignored. |
||
| 52 |
- #'+ #' @param x_lab (`string` or `NULL`)\cr x-axis label. If `NULL` then no label will be added. |
||
| 53 |
- #' @export+ #' @param y_lab (`string` or `NULL`)\cr y-axis label. If `NULL` then no label will be added. |
||
| 54 |
- s_count_patients_with_flags <- function(df,+ #' @param y_lab_add_paramcd (`flag`)\cr whether `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` should be added |
||
| 55 |
- .var,+ #' to the y-axis label (`y_lab`). |
||
| 56 |
- flag_variables,+ #' @param y_lab_add_unit (`flag`)\cr whether y-axis unit, i.e. `unique(df[[variables["y_unit"]]])` should be added |
||
| 57 |
- flag_labels = NULL,+ #' to the y-axis label (`y_lab`). |
||
| 58 |
- .N_col, # nolint+ #' @param title (`string`)\cr plot title. |
||
| 59 |
- .N_row, # nolint+ #' @param subtitle (`string`)\cr plot subtitle. |
||
| 60 |
- denom = c("n", "N_row", "N_col")) {
+ #' @param subtitle_add_paramcd (`flag`)\cr whether `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` should be |
||
| 61 | -10x | +
- checkmate::assert_character(flag_variables)+ #' added to the plot's subtitle (`subtitle`). |
|
| 62 | -10x | +
- if (!is.null(flag_labels)) {
+ #' @param subtitle_add_unit (`flag`)\cr whether the y-axis unit, i.e. `unique(df[[variables["y_unit"]]])` should be |
|
| 63 | -1x | +
- checkmate::assert_character(flag_labels, len = length(flag_variables), any.missing = FALSE)+ #' added to the plot's subtitle (`subtitle`). |
|
| 64 | -1x | +
- flag_names <- flag_labels+ #' @param caption (`string`)\cr optional caption below the plot. |
|
| 65 |
- } else {
+ #' @param table_format (named `character` or `NULL`)\cr format patterns for descriptive statistics used in the |
||
| 66 | -9x | +
- if (is.null(names(flag_variables))) {
+ #' (optional) table appended to the plot. It is passed directly to the `h_format_row` function through the `format` |
|
| 67 | -8x | +
- flag_names <- formatters::var_labels(df[flag_variables], fill = TRUE)+ #' parameter. Names of `table_format` must match the names of statistics returned by `sfun` function. |
|
| 68 |
- } else {
+ #' @param table_labels (named `character` or `NULL`)\cr labels for descriptive statistics used in the (optional) table |
||
| 69 | -1x | +
- flag_names <- unname(flag_variables)+ #' appended to the plot. Names of `table_labels` must match the names of statistics returned by `sfun` function. |
|
| 70 | -1x | +
- flag_variables <- names(flag_variables)+ #' @param table_font_size (`numeric(1)`)\cr font size of the text in the table. |
|
| 71 |
- }+ #' @param newpage `r lifecycle::badge("deprecated")` not used.
|
||
| 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. |
||
| 74 | -10x | +
- checkmate::assert_subset(flag_variables, colnames(df))+ #' @param errorbar_width (`numeric(1)`)\cr width of the error bars. |
|
| 75 | -10x | +
- temp <- sapply(flag_variables, function(x) {
+ #' |
|
| 76 | -27x | +
- tmp <- Map(function(y) which(df[[y]]), x)+ #' @return A `ggplot` line plot (and statistics table if applicable). |
|
| 77 | -27x | +
- position_satisfy_flags <- Reduce(intersect, tmp)+ #' |
|
| 78 | -27x | +
- id_satisfy_flags <- as.character(unique(df[position_satisfy_flags, ][[.var]]))+ #' @examples |
|
| 79 | -27x | +
- s_count_values(+ #' library(nestcolor) |
|
| 80 | -27x | +
- as.character(unique(df[[.var]])),+ #' |
|
| 81 | -27x | +
- id_satisfy_flags,+ #' adsl <- tern_ex_adsl |
|
| 82 | -27x | +
- denom = denom,+ #' adlb <- tern_ex_adlb %>% dplyr::filter(ANL01FL == "Y", PARAMCD == "ALT", AVISIT != "SCREENING") |
|
| 83 | -27x | +
- .N_col = .N_col,+ #' adlb$AVISIT <- droplevels(adlb$AVISIT) |
|
| 84 | -27x | +
- .N_row = .N_row+ #' adlb <- dplyr::mutate(adlb, AVISIT = forcats::fct_reorder(AVISIT, AVISITN, min)) |
|
| 85 |
- )+ #' |
||
| 86 |
- })+ #' # Mean with CI |
||
| 87 | -10x | +
- colnames(temp) <- flag_names+ #' g_lineplot(adlb, adsl, subtitle = "Laboratory Test:") |
|
| 88 | -10x | +
- temp <- data.frame(t(temp))+ #' |
|
| 89 | -10x | +
- result <- temp %>% as.list()+ #' # Mean with CI, no stratification with group_var |
|
| 90 | -10x | +
- if (length(flag_variables) == 1) {
+ #' g_lineplot(adlb, variables = control_lineplot_vars(group_var = NA)) |
|
| 91 | -1x | +
- for (i in 1:3) names(result[[i]]) <- flag_names[1]+ #' |
|
| 92 |
- }+ #' # Mean, upper whisker of CI, no group_var(strata) counts N |
||
| 93 | -10x | +
- result+ #' g_lineplot( |
|
| 94 |
- }+ #' adlb, |
||
| 95 |
-
+ #' whiskers = "mean_ci_upr", |
||
| 96 |
- #' @describeIn count_patients_with_flags Formatted analysis function which is used as `afun`+ #' title = "Plot of Mean and Upper 95% Confidence Limit by Visit" |
||
| 97 |
- #' in `count_patients_with_flags()`.+ #' ) |
||
| 99 |
- #' @return+ #' # Median with CI |
||
| 100 |
- #' * `a_count_patients_with_flags()` returns the corresponding list with formatted [rtables::CellValue()].+ #' g_lineplot( |
||
| 101 |
- #'+ #' adlb, |
||
| 102 |
- #' @examples+ #' adsl, |
||
| 103 |
- #' # We need to ungroup `count_fraction` first so that the `rtables` formatting+ #' mid = "median", |
||
| 104 |
- #' # function `format_count_fraction()` can be applied correctly.+ #' interval = "median_ci", |
||
| 105 |
- #'+ #' whiskers = c("median_ci_lwr", "median_ci_upr"),
|
||
| 106 |
- #' # `a_count_patients_with_flags()`+ #' title = "Plot of Median and 95% Confidence Limits by Visit" |
||
| 107 |
- #'+ #' ) |
||
| 108 |
- #' afun <- make_afun(a_count_patients_with_flags,+ #' |
||
| 109 |
- #' .stats = "count_fraction",+ #' # Mean, +/- SD |
||
| 110 |
- #' .ungroup_stats = "count_fraction"+ #' g_lineplot(adlb, adsl, |
||
| 111 |
- #' )+ #' interval = "mean_sdi", |
||
| 112 |
- #' afun(+ #' whiskers = c("mean_sdi_lwr", "mean_sdi_upr"),
|
||
| 113 |
- #' adae,+ #' title = "Plot of Median +/- SD by Visit" |
||
| 114 |
- #' .N_col = 10L,+ #' ) |
||
| 115 |
- #' .N_row = 10L,+ #' |
||
| 116 |
- #' .var = "USUBJID",+ #' # Mean with CI plot with stats table |
||
| 117 |
- #' flag_variables = c("fl1", "fl2", "fl3", "fl4")
+ #' g_lineplot(adlb, adsl, table = c("n", "mean", "mean_ci"))
|
||
| 118 |
- #' )+ #' |
||
| 119 |
- #'+ #' # Mean with CI, table and customized confidence level |
||
| 120 |
- #' @export+ #' g_lineplot( |
||
| 121 |
- a_count_patients_with_flags <- make_afun(+ #' adlb, |
||
| 122 |
- s_count_patients_with_flags,+ #' adsl, |
||
| 123 |
- .formats = c("count_fraction" = format_count_fraction_fixed_dp)
+ #' table = c("n", "mean", "mean_ci"),
|
||
| 124 |
- )+ #' control = control_analyze_vars(conf_level = 0.80), |
||
| 125 |
-
+ #' title = "Plot of Mean and 80% Confidence Limits by Visit" |
||
| 126 |
- #' @describeIn count_patients_with_flags Layout-creating function which can take statistics function+ #' ) |
||
| 127 |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' |
||
| 128 |
- #'+ #' # Mean with CI, table, filtered data |
||
| 129 |
- #' @return+ #' adlb_f <- dplyr::filter(adlb, ARMCD != "ARM A" | AVISIT == "BASELINE") |
||
| 130 |
- #' * `count_patients_with_flags()` returns a layout object suitable for passing to further layouting functions,+ #' g_lineplot(adlb_f, table = c("n", "mean"))
|
||
| 131 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 132 |
- #' the statistics from `s_count_patients_with_flags()` to the table layout.+ #' @export |
||
| 133 |
- #'+ g_lineplot <- function(df, |
||
| 134 |
- #' @examples+ alt_counts_df = NULL, |
||
| 135 |
- #' library(dplyr)+ variables = control_lineplot_vars(), |
||
| 136 |
- #'+ mid = "mean", |
||
| 137 |
- #' # Add labelled flag variables to analysis dataset.+ interval = "mean_ci", |
||
| 138 |
- #' adae <- tern_ex_adae %>%+ whiskers = c("mean_ci_lwr", "mean_ci_upr"),
|
||
| 139 |
- #' mutate(+ table = NULL, |
||
| 140 |
- #' fl1 = TRUE %>% with_label("Total AEs"),
+ sfun = s_summary, |
||
| 141 |
- #' fl2 = (TRTEMFL == "Y") %>%+ ..., |
||
| 142 |
- #' with_label("Total number of patients with at least one adverse event"),
+ mid_type = "pl", |
||
| 143 |
- #' fl3 = (TRTEMFL == "Y" & AEOUT == "FATAL") %>%+ mid_point_size = 2, |
||
| 144 |
- #' with_label("Total number of patients with fatal AEs"),
+ position = ggplot2::position_dodge(width = 0.4), |
||
| 145 |
- #' fl4 = (TRTEMFL == "Y" & AEOUT == "FATAL" & AEREL == "Y") %>%+ legend_title = NULL, |
||
| 146 |
- #' with_label("Total number of patients with related fatal AEs")
+ legend_position = "bottom", |
||
| 147 |
- #' )+ ggtheme = nestcolor::theme_nest(), |
||
| 148 |
- #'+ xticks = NULL, |
||
| 149 |
- #' # `count_patients_with_flags()`+ xlim = NULL, |
||
| 150 |
- #'+ ylim = NULL, |
||
| 151 |
- #' lyt2 <- basic_table() %>%+ x_lab = obj_label(df[[variables[["x"]]]]), |
||
| 152 |
- #' split_cols_by("ARM") %>%
+ y_lab = NULL, |
||
| 153 |
- #' add_colcounts() %>%+ y_lab_add_paramcd = TRUE, |
||
| 154 |
- #' count_patients_with_flags(+ y_lab_add_unit = TRUE, |
||
| 155 |
- #' "SUBJID",+ title = "Plot of Mean and 95% Confidence Limits by Visit", |
||
| 156 |
- #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
+ subtitle = "", |
||
| 157 |
- #' denom = "N_col"+ subtitle_add_paramcd = TRUE, |
||
| 158 |
- #' )+ subtitle_add_unit = TRUE, |
||
| 159 |
- #'+ caption = NULL, |
||
| 160 |
- #' build_table(lyt2, adae, alt_counts_df = tern_ex_adsl)+ table_format = NULL, |
||
| 161 |
- #'+ table_labels = NULL, |
||
| 162 |
- #' @export+ table_font_size = 3, |
||
| 163 |
- #' @order 2+ errorbar_width = 0.45, |
||
| 164 |
- count_patients_with_flags <- function(lyt,+ newpage = lifecycle::deprecated(), |
||
| 165 |
- var,+ col = NULL, |
||
| 166 |
- flag_variables,+ linetype = NULL) {
|
||
| 167 | -+ | 12x |
- flag_labels = NULL,+ checkmate::assert_character(variables, any.missing = TRUE) |
| 168 | -+ | 12x |
- var_labels = var,+ checkmate::assert_character(mid, null.ok = TRUE) |
| 169 | -+ | 12x |
- show_labels = "hidden",+ checkmate::assert_character(interval, null.ok = TRUE) |
| 170 | -+ | 12x |
- riskdiff = FALSE,+ checkmate::assert_character(col, null.ok = TRUE) |
| 171 | -+ | 12x |
- na_str = default_na_str(),+ checkmate::assert_character(linetype, null.ok = TRUE) |
| 172 | -+ | 12x |
- nested = TRUE,+ checkmate::assert_numeric(xticks, null.ok = TRUE) |
| 173 | -+ | 12x |
- ...,+ checkmate::assert_numeric(xlim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE) |
| 174 | -+ | 12x |
- table_names = paste0("tbl_flags_", var),
+ checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE) |
| 175 | -+ | 12x |
- .stats = "count_fraction",+ checkmate::assert_number(errorbar_width, lower = 0) |
| 176 | -+ | 12x |
- .formats = NULL,+ checkmate::assert_string(title, null.ok = TRUE) |
| 177 | -+ | 12x |
- .indent_mods = NULL) {
+ checkmate::assert_string(subtitle, null.ok = TRUE) |
| 178 | -10x | +
- checkmate::assert_flag(riskdiff)+ |
|
| 179 | -+ | 12x |
-
+ if (!is.null(table)) {
|
| 180 | -10x | +4x |
- s_args <- list(flag_variables = flag_variables, flag_labels = flag_labels, ...)+ table_format <- get_formats_from_stats(table) |
| 181 | -+ | 4x |
-
+ table_labels <- get_labels_from_stats(table) |
| 182 | -10x | +
- afun <- make_afun(+ } |
|
| 183 | -10x | +
- a_count_patients_with_flags,+ |
|
| 184 | -10x | +12x |
- .stats = .stats,+ extra_args <- list(...) |
| 185 | -10x | +12x |
- .formats = .formats,+ if ("control" %in% names(extra_args)) {
|
| 186 | -10x | +4x |
- .indent_mods = .indent_mods,+ if (!is.null(table) && all(table_labels == get_labels_from_stats(table))) {
|
| 187 | -10x | +3x |
- .ungroup_stats = .stats+ table_labels <- table_labels %>% labels_use_control(extra_args[["control"]]) |
| 188 |
- )+ } |
||
| 189 |
-
+ } |
||
| 190 | -10x | +
- extra_args <- if (isFALSE(riskdiff)) {
+
|
|
| 191 | -8x | +12x |
- s_args+ if (is.character(interval)) {
|
| 192 | -+ | 12x |
- } else {
+ checkmate::assert_vector(whiskers, min.len = 0, max.len = 2) |
| 193 | -2x | +
- list(+ } |
|
| 194 | -2x | +
- afun = list("s_count_patients_with_flags" = afun),
+
|
|
| 195 | -2x | +12x |
- .stats = .stats,+ if (length(whiskers) == 1) {
|
| 196 | -2x | +! |
- .indent_mods = .indent_mods,+ checkmate::assert_character(mid) |
| 197 | -2x | +
- s_args = s_args+ } |
|
| 198 |
- )+ |
||
| 199 | -+ | 12x |
- }+ if (is.character(mid)) {
|
| 200 | -+ | 12x |
-
+ checkmate::assert_scalar(mid_type) |
| 201 | -10x | +12x |
- lyt <- analyze(+ checkmate::assert_subset(mid_type, c("pl", "p", "l"))
|
| 202 | -10x | +
- lyt = lyt,+ } |
|
| 203 | -10x | +
- vars = var,+ |
|
| 204 | -10x | +12x |
- var_labels = var_labels,+ x <- variables[["x"]] |
| 205 | -10x | +12x |
- show_labels = show_labels,+ y <- variables[["y"]] |
| 206 | -10x | +12x |
- afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ paramcd <- variables["paramcd"] # NA if paramcd == NA or it is not in variables |
| 207 | -10x | +12x |
- table_names = table_names,+ y_unit <- variables["y_unit"] # NA if y_unit == NA or it is not in variables |
| 208 | -10x | +12x |
- na_str = na_str,+ if (is.na(variables["group_var"])) {
|
| 209 | -10x | +1x |
- nested = nested,+ group_var <- NULL # NULL if group_var == NA or it is not in variables |
| 210 | -10x | +
- extra_args = extra_args+ } else {
|
|
| 211 | -+ | 11x |
- )+ group_var <- variables[["group_var"]] |
| 212 | -+ | 11x |
-
+ subject_var <- variables[["subject_var"]] |
| 213 | -10x | +
- lyt+ } |
|
| 214 | -+ | 12x |
- }+ if (is.na(variables["facet_var"])) {
|
| 1 | -+ | |||
| 215 | +11x |
- #' Difference test for two proportions+ facet_var <- NULL # NULL if facet_var == NA or it is not in variables |
||
| 2 | +216 |
- #'+ } else {
|
||
| 3 | -+ | |||
| 217 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ facet_var <- variables[["facet_var"]] |
||
| 4 | +218 |
- #'+ } |
||
| 5 | -+ | |||
| 219 | +12x |
- #' The analyze function [test_proportion_diff()] creates a layout element to test the difference between two+ checkmate::assert_flag(y_lab_add_paramcd, null.ok = TRUE) |
||
| 6 | -+ | |||
| 220 | +12x |
- #' proportions. The primary analysis variable, `vars`, indicates whether a response has occurred for each record. See+ checkmate::assert_flag(subtitle_add_paramcd, null.ok = TRUE) |
||
| 7 | -+ | |||
| 221 | +12x |
- #' the `method` parameter for options of methods to use to calculate the p-value. Additionally, a stratification+ if ((!is.null(y_lab) && y_lab_add_paramcd) || (!is.null(subtitle) && subtitle_add_paramcd)) {
|
||
| 8 | -+ | |||
| 222 | +12x |
- #' variable can be supplied via the `strata` element of the `variables` argument.+ checkmate::assert_false(is.na(paramcd)) |
||
| 9 | -+ | |||
| 223 | +12x |
- #'+ checkmate::assert_scalar(unique(df[[paramcd]])) |
||
| 10 | +224 |
- #' @inheritParams argument_convention+ } |
||
| 11 | +225 |
- #' @param method (`string`)\cr one of `chisq`, `cmh`, `fisher`, or `schouten`; specifies the test used+ |
||
| 12 | -+ | |||
| 226 | +12x |
- #' to calculate the p-value.+ checkmate::assert_flag(y_lab_add_unit, null.ok = TRUE) |
||
| 13 | -+ | |||
| 227 | +12x |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("test_proportion_diff")`
+ checkmate::assert_flag(subtitle_add_unit, null.ok = TRUE) |
||
| 14 | -+ | |||
| 228 | +12x |
- #' to see available statistics for this function.+ if ((!is.null(y_lab) && y_lab_add_unit) || (!is.null(subtitle) && subtitle_add_unit)) {
|
||
| 15 | -+ | |||
| 229 | +12x |
- #'+ checkmate::assert_false(is.na(y_unit)) |
||
| 16 | -+ | |||
| 230 | +12x |
- #' @seealso [h_prop_diff_test]+ checkmate::assert_scalar(unique(df[[y_unit]])) |
||
| 17 | +231 |
- #'+ } |
||
| 18 | +232 |
- #' @name prop_diff_test+ |
||
| 19 | -+ | |||
| 233 | +12x |
- #' @order 1+ if (!is.null(group_var) && !is.null(alt_counts_df)) {
+ |
+ ||
| 234 | +7x | +
+ checkmate::assert_set_equal(unique(alt_counts_df[[group_var]]), unique(df[[group_var]])) |
||
| 20 | +235 |
- NULL+ } |
||
| 21 | +236 | |||
| 22 | +237 |
- #' @describeIn prop_diff_test Statistics function which tests the difference between two proportions.+ ####################################### | |
||
| 23 | +238 |
- #'+ # ---- Compute required statistics ---- |
||
| 24 | +239 |
- #' @return+ ####################################### | |
||
| 25 | +240 |
- #' * `s_test_proportion_diff()` returns a named `list` with a single item `pval` with an attribute `label`+ # Remove unused levels for x-axis |
||
| 26 | -+ | |||
| 241 | +12x |
- #' describing the method used. The p-value tests the null hypothesis that proportions in two groups are the same.+ if (is.factor(df[[x]])) {
|
||
| 27 | -+ | |||
| 242 | +11x |
- #'+ df[[x]] <- droplevels(df[[x]]) |
||
| 28 | +243 |
- #' @keywords internal+ } |
||
| 29 | +244 |
- s_test_proportion_diff <- function(df,+ |
||
| 30 | -+ | |||
| 245 | +12x |
- .var,+ if (!is.null(facet_var) && !is.null(group_var)) {
|
||
| 31 | -+ | |||
| 246 | +1x |
- .ref_group,+ df_grp <- tidyr::expand(df, .data[[facet_var]], .data[[group_var]], .data[[x]]) # expand based on levels of factors |
||
| 32 | -+ | |||
| 247 | +11x |
- .in_ref_col,+ } else if (!is.null(group_var)) {
|
||
| 33 | -+ | |||
| 248 | +10x |
- variables = list(strata = NULL),+ df_grp <- tidyr::expand(df, .data[[group_var]], .data[[x]]) # expand based on levels of factors |
||
| 34 | +249 |
- method = c("chisq", "schouten", "fisher", "cmh")) {
+ } else {
|
||
| 35 | -45x | +250 | +1x |
- method <- match.arg(method)+ df_grp <- tidyr::expand(df, NULL, .data[[x]]) |
| 36 | -45x | +|||
| 251 | +
- y <- list(pval = "")+ } |
|||
| 37 | +252 | |||
| 38 | -45x | +253 | +12x |
- if (!.in_ref_col) {
+ df_grp <- df_grp %>% |
| 39 | -45x | +254 | +12x |
- assert_df_with_variables(df, list(rsp = .var))+ dplyr::full_join(y = df[, c(facet_var, group_var, x, y)], by = c(facet_var, group_var, x), multiple = "all") %>% |
| 40 | -45x | +255 | +12x |
- assert_df_with_variables(.ref_group, list(rsp = .var))+ dplyr::group_by_at(c(facet_var, group_var, x)) |
| 41 | -45x | +|||
| 256 | +
- rsp <- factor(+ |
|||
| 42 | -45x | +257 | +12x |
- c(.ref_group[[.var]], df[[.var]]),+ df_stats <- df_grp %>% |
| 43 | -45x | -
- levels = c("TRUE", "FALSE")
- |
- ||
| 44 | -+ | 258 | +12x |
- )+ dplyr::summarise( |
| 45 | -45x | +259 | +12x |
- grp <- factor(+ data.frame(t(do.call(c, unname(sfun(.data[[y]])[c(mid, interval)])))), |
| 46 | -45x | +260 | +12x |
- rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
+ .groups = "drop" |
| 47 | -45x | +|||
| 261 | +
- levels = c("ref", "Not-ref")
+ ) |
|||
| 48 | +262 |
- )+ + |
+ ||
| 263 | +12x | +
+ df_stats <- df_stats[!is.na(df_stats[[mid]]), ] |
||
| 49 | +264 | |||
| 50 | -45x | +|||
| 265 | +
- if (!is.null(variables$strata) || method == "cmh") {
+ # add number of objects N in group_var (strata) |
|||
| 51 | +266 | 12x |
- strata <- variables$strata+ if (!is.null(group_var) && !is.null(alt_counts_df)) {
|
|
| 52 | -12x | +267 | +7x |
- checkmate::assert_false(is.null(strata))+ strata_N <- paste0(group_var, "_N") # nolint |
| 53 | -12x | +|||
| 268 | +
- strata_vars <- stats::setNames(as.list(strata), strata)+ |
|||
| 54 | -12x | +269 | +7x |
- assert_df_with_variables(df, strata_vars)+ 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 |
| 55 | -12x | +270 | +7x |
- assert_df_with_variables(.ref_group, strata_vars)+ colnames(df_N) <- c(group_var, "N") # nolint |
| 56 | -12x | +271 | +7x |
- strata <- c(interaction(.ref_group[strata]), interaction(df[strata]))+ df_N[[strata_N]] <- paste0(df_N[[group_var]], " (N = ", df_N$N, ")") # nolint |
| 57 | +272 |
- }+ |
||
| 58 | +273 |
-
+ # keep strata factor levels |
||
| 59 | -45x | +274 | +7x |
- tbl <- switch(method,+ matches <- sapply(unique(df_N[[group_var]]), function(x) {
|
| 60 | -45x | +275 | +19x |
- cmh = table(grp, rsp, strata),+ regex_pattern <- gsub("([][(){}^$.|*+?\\\\])", "\\\\\\1", x)
|
| 61 | -45x | -
- table(grp, rsp)- |
- ||
| 62 | -+ | 276 | +19x |
- )+ unique(df_N[[paste0(group_var, "_N")]])[grepl( |
| 63 | -+ | |||
| 277 | +19x |
-
+ paste0("^", regex_pattern),
|
||
| 64 | -45x | +278 | +19x |
- y$pval <- switch(method,+ unique(df_N[[paste0(group_var, "_N")]]) |
| 65 | -45x | +|||
| 279 | +
- chisq = prop_chisq(tbl),+ )] |
|||
| 66 | -45x | +|||
| 280 | +
- cmh = prop_cmh(tbl),+ }) |
|||
| 67 | -45x | +281 | +7x |
- fisher = prop_fisher(tbl),+ df_N[[paste0(group_var, "_N")]] <- factor(df_N[[group_var]]) # nolint |
| 68 | -45x | +282 | +7x |
- schouten = prop_schouten(tbl)+ levels(df_N[[paste0(group_var, "_N")]]) <- unlist(matches) # nolint |
| 69 | +283 |
- )+ |
||
| 70 | +284 |
- }+ # strata_N should not be in colnames(df_stats)+ |
+ ||
| 285 | +7x | +
+ checkmate::assert_disjunct(strata_N, colnames(df_stats)) |
||
| 71 | +286 | |||
| 72 | -45x | +287 | +7x |
- y$pval <- formatters::with_label(y$pval, d_test_proportion_diff(method))+ df_stats <- merge(x = df_stats, y = df_N[, c(group_var, strata_N)], by = group_var) |
| 73 | -45x | +288 | +5x |
- y+ } else if (!is.null(group_var)) {
|
| 74 | -+ | |||
| 289 | +4x |
- }+ strata_N <- group_var # nolint |
||
| 75 | +290 |
-
+ } else {
|
||
| 76 | -+ | |||
| 291 | +1x |
- #' Description of the difference test between two proportions+ strata_N <- NULL # nolint |
||
| 77 | +292 |
- #'+ } |
||
| 78 | +293 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 79 | +294 |
- #'+ ############################################### | |
||
| 80 | +295 |
- #' This is an auxiliary function that describes the analysis in `s_test_proportion_diff`.+ # ---- Prepare certain plot's properties. ---- |
||
| 81 | +296 |
- #'+ ############################################### | |
||
| 82 | +297 |
- #' @inheritParams s_test_proportion_diff+ # legend title |
||
| 83 | -+ | |||
| 298 | +12x |
- #'+ if (is.null(legend_title) && !is.null(group_var) && legend_position != "none") {
|
||
| 84 | -+ | |||
| 299 | +11x |
- #' @return A `string` describing the test from which the p-value is derived.+ legend_title <- attr(df[[group_var]], "label") |
||
| 85 | +300 |
- #'+ } |
||
| 86 | +301 |
- #' @export+ |
||
| 87 | +302 |
- d_test_proportion_diff <- function(method) {
+ # y label |
||
| 88 | -59x | +303 | +12x |
- checkmate::assert_string(method)+ if (!is.null(y_lab)) {
|
| 89 | -59x | +304 | +4x |
- meth_part <- switch(method,+ if (y_lab_add_paramcd) {
|
| 90 | -59x | +305 | +4x |
- "schouten" = "Chi-Squared Test with Schouten Correction",+ y_lab <- paste(y_lab, unique(df[[paramcd]])) |
| 91 | -59x | +|||
| 306 | +
- "chisq" = "Chi-Squared Test",+ } |
|||
| 92 | -59x | +|||
| 307 | +
- "cmh" = "Cochran-Mantel-Haenszel Test",+ |
|||
| 93 | -59x | +308 | +4x |
- "fisher" = "Fisher's Exact Test",+ if (y_lab_add_unit) {
|
| 94 | -59x | +309 | +4x |
- stop(paste(method, "does not have a description"))+ y_lab <- paste0(y_lab, " (", unique(df[[y_unit]]), ")")
|
| 95 | +310 |
- )+ }+ |
+ ||
| 311 | ++ | + | ||
| 96 | -59x | +312 | +4x |
- paste0("p-value (", meth_part, ")")
+ y_lab <- trimws(y_lab) |
| 97 | +313 |
- }+ } |
||
| 98 | +314 | |||
| 99 | +315 |
- #' @describeIn prop_diff_test Formatted analysis function which is used as `afun` in `test_proportion_diff()`.+ # subtitle |
||
| 100 | -+ | |||
| 316 | +12x |
- #'+ if (!is.null(subtitle)) {
|
||
| 101 | -+ | |||
| 317 | +12x |
- #' @return+ if (subtitle_add_paramcd) {
|
||
| 102 | -+ | |||
| 318 | +12x |
- #' * `a_test_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()].+ subtitle <- paste(subtitle, unique(df[[paramcd]])) |
||
| 103 | +319 |
- #'+ } |
||
| 104 | +320 |
- #' @keywords internal+ |
||
| 105 | -+ | |||
| 321 | +12x |
- a_test_proportion_diff <- make_afun(+ if (subtitle_add_unit) {
|
||
| 106 | -+ | |||
| 322 | +12x |
- s_test_proportion_diff,+ subtitle <- paste0(subtitle, " (", unique(df[[y_unit]]), ")")
|
||
| 107 | +323 |
- .formats = c(pval = "x.xxxx | (<0.0001)"),+ } |
||
| 108 | +324 |
- .indent_mods = c(pval = 1L)+ + |
+ ||
| 325 | +12x | +
+ subtitle <- trimws(subtitle) |
||
| 109 | +326 |
- )+ } |
||
| 110 | +327 | |||
| 111 | +328 |
- #' @describeIn prop_diff_test Layout-creating function which can take statistics function arguments+ ############################### | |
||
| 112 | +329 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ # ---- Build plot object. ---- |
||
| 113 | +330 |
- #'+ ############################### | |
||
| 114 | -+ | |||
| 331 | +12x |
- #' @return+ p <- ggplot2::ggplot( |
||
| 115 | -+ | |||
| 332 | +12x |
- #' * `test_proportion_diff()` returns a layout object suitable for passing to further layouting functions,+ data = df_stats, |
||
| 116 | -+ | |||
| 333 | +12x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ mapping = ggplot2::aes( |
||
| 117 | -+ | |||
| 334 | +12x |
- #' the statistics from `s_test_proportion_diff()` to the table layout.+ x = .data[[x]], y = .data[[mid]], |
||
| 118 | -+ | |||
| 335 | +12x |
- #'+ color = if (is.null(strata_N)) NULL else .data[[strata_N]], |
||
| 119 | -+ | |||
| 336 | +12x |
- #' @examples+ shape = if (is.null(strata_N)) NULL else .data[[strata_N]], |
||
| 120 | -+ | |||
| 337 | +12x |
- #' dta <- data.frame(+ lty = if (is.null(strata_N)) NULL else .data[[strata_N]],+ |
+ ||
| 338 | +12x | +
+ group = if (is.null(strata_N)) NULL else .data[[strata_N]] |
||
| 121 | +339 |
- #' rsp = sample(c(TRUE, FALSE), 100, TRUE),+ ) |
||
| 122 | +340 |
- #' grp = factor(rep(c("A", "B"), each = 50)),
+ ) |
||
| 123 | +341 |
- #' strata = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20))
+
+ |
+ ||
| 342 | +12x | +
+ if (!is.null(group_var) && nlevels(df_stats[[strata_N]]) > 6) {
+ |
+ ||
| 343 | +1x | +
+ p <- p ++ |
+ ||
| 344 | +1x | +
+ scale_shape_manual(values = seq(15, 15 + nlevels(df_stats[[strata_N]]))) |
||
| 124 | +345 |
- #' )+ } |
||
| 125 | +346 |
- #'+ + |
+ ||
| 347 | +12x | +
+ if (!is.null(mid)) {
|
||
| 126 | +348 |
- #' # With `rtables` pipelines.+ # points+ |
+ ||
| 349 | +12x | +
+ if (grepl("p", mid_type, fixed = TRUE)) {
+ |
+ ||
| 350 | +12x | +
+ p <- p + ggplot2::geom_point(position = position, size = mid_point_size, na.rm = TRUE) |
||
| 127 | +351 |
- #' l <- basic_table() %>%+ } |
||
| 128 | +352 |
- #' split_cols_by(var = "grp", ref_group = "B") %>%+ |
||
| 129 | +353 |
- #' test_proportion_diff(+ # lines - plotted only if there is a strata grouping (group_var)+ |
+ ||
| 354 | +12x | +
+ if (grepl("l", mid_type, fixed = TRUE) && !is.null(strata_N)) { # nolint
+ |
+ ||
| 355 | +11x | +
+ p <- p + ggplot2::geom_line(position = position, na.rm = TRUE) |
||
| 130 | +356 |
- #' vars = "rsp",+ } |
||
| 131 | +357 |
- #' method = "cmh", variables = list(strata = "strata")+ } |
||
| 132 | +358 |
- #' )+ |
||
| 133 | +359 |
- #'+ # interval+ |
+ ||
| 360 | +12x | +
+ if (!is.null(interval)) {
|
||
| 134 | -+ | |||
| 361 | +12x |
- #' build_table(l, df = dta)+ p <- p + |
||
| 135 | -+ | |||
| 362 | +12x |
- #'+ ggplot2::geom_errorbar( |
||
| 136 | -+ | |||
| 363 | +12x |
- #' @export+ ggplot2::aes(ymin = .data[[whiskers[1]]], ymax = .data[[whiskers[max(1, length(whiskers))]]]), |
||
| 137 | -+ | |||
| 364 | +12x |
- #' @order 2+ width = errorbar_width, |
||
| 138 | -+ | |||
| 365 | +12x |
- test_proportion_diff <- function(lyt,+ position = position |
||
| 139 | +366 |
- vars,+ ) |
||
| 140 | +367 |
- variables = list(strata = NULL),+ |
||
| 141 | -+ | |||
| 368 | +12x |
- method = c("chisq", "schouten", "fisher", "cmh"),
+ if (length(whiskers) == 1) { # lwr or upr only; mid is then required
|
||
| 142 | +369 |
- na_str = default_na_str(),+ # workaround as geom_errorbar does not provide single-direction whiskers |
||
| 143 | -+ | |||
| 370 | +! |
- nested = TRUE,+ p <- p + |
||
| 144 | -+ | |||
| 371 | +! |
- ...,+ ggplot2::geom_linerange( |
||
| 145 | -+ | |||
| 372 | +! |
- var_labels = vars,+ data = df_stats[!is.na(df_stats[[whiskers]]), ], # as na.rm =TRUE does not suppress warnings |
||
| 146 | -+ | |||
| 373 | +! |
- show_labels = "hidden",+ ggplot2::aes(ymin = .data[[mid]], ymax = .data[[whiskers]]), |
||
| 147 | -+ | |||
| 374 | +! |
- table_names = vars,+ position = position, |
||
| 148 | -+ | |||
| 375 | +! |
- .stats = NULL,+ na.rm = TRUE, |
||
| 149 | -+ | |||
| 376 | +! |
- .formats = NULL,+ show.legend = FALSE |
||
| 150 | +377 |
- .labels = NULL,+ ) |
||
| 151 | +378 |
- .indent_mods = NULL) {
+ } |
||
| 152 | -6x | +|||
| 379 | +
- extra_args <- list(variables = variables, method = method, ...)+ } |
|||
| 153 | +380 | |||
| 154 | -6x | +381 | +12x |
- afun <- make_afun(+ if (is.numeric(df_stats[[x]])) {
|
| 155 | -6x | +382 | +1x |
- a_test_proportion_diff,+ if (length(xticks) == 1) xticks <- seq(from = min(df_stats[[x]]), to = max(df_stats[[x]]), by = xticks) |
| 156 | -6x | +383 | +1x |
- .stats = .stats,+ p <- p + ggplot2::scale_x_continuous(breaks = if (!is.null(xticks)) xticks else waiver(), limits = xlim) |
| 157 | -6x | +|||
| 384 | +
- .formats = .formats,+ } |
|||
| 158 | -6x | +|||
| 385 | +
- .labels = .labels,+ |
|||
| 159 | -6x | -
- .indent_mods = .indent_mods- |
- ||
| 160 | -+ | 386 | +12x |
- )+ p <- p + |
| 161 | -6x | +387 | +12x |
- analyze(+ ggplot2::scale_y_continuous(labels = scales::comma, limits = ylim) + |
| 162 | -6x | +388 | +12x |
- lyt,+ ggplot2::labs( |
| 163 | -6x | +389 | +12x |
- vars,+ title = title, |
| 164 | -6x | +390 | +12x |
- afun = afun,+ subtitle = subtitle, |
| 165 | -6x | +391 | +12x |
- var_labels = var_labels,+ caption = caption, |
| 166 | -6x | +392 | +12x |
- na_str = na_str,+ color = legend_title, |
| 167 | -6x | +393 | +12x |
- nested = nested,+ lty = legend_title, |
| 168 | -6x | +394 | +12x |
- extra_args = extra_args,+ shape = legend_title, |
| 169 | -6x | +395 | +12x |
- show_labels = show_labels,+ x = x_lab, |
| 170 | -6x | +396 | +12x |
- table_names = table_names+ y = y_lab |
| 171 | +397 |
- )+ ) |
||
| 172 | +398 |
- }+ |
||
| 173 | -+ | |||
| 399 | +12x |
-
+ if (!is.null(col)) {
|
||
| 174 | -+ | |||
| 400 | +1x |
- #' Helper functions to test proportion differences+ p <- p + |
||
| 175 | -+ | |||
| 401 | +1x |
- #'+ ggplot2::scale_color_manual(values = col) |
||
| 176 | +402 |
- #' Helper functions to implement various tests on the difference between two proportions.+ } |
||
| 177 | -+ | |||
| 403 | +12x |
- #'+ if (!is.null(linetype)) {
|
||
| 178 | -+ | |||
| 404 | +1x |
- #' @param tbl (`matrix`)\cr matrix with two groups in rows and the binary response (`TRUE`/`FALSE`) in columns.+ p <- p + |
||
| 179 | -+ | |||
| 405 | +1x |
- #'+ ggplot2::scale_linetype_manual(values = linetype) |
||
| 180 | +406 |
- #' @return A p-value.+ } |
||
| 181 | +407 |
- #'+ |
||
| 182 | -+ | |||
| 408 | +12x |
- #' @seealso [prop_diff_test()] for implementation of these helper functions.+ if (!is.null(facet_var)) {
|
||
| 183 | -+ | |||
| 409 | +1x |
- #'+ p <- p + |
||
| 184 | -+ | |||
| 410 | +1x |
- #' @name h_prop_diff_test+ facet_grid(cols = vars(df_stats[[facet_var]])) |
||
| 185 | +411 |
- NULL+ } |
||
| 186 | +412 | |||
| 187 | -+ | |||
| 413 | +12x |
- #' @describeIn h_prop_diff_test Performs Chi-Squared test. Internally calls [stats::prop.test()].+ if (!is.null(ggtheme)) {
|
||
| 188 | -+ | |||
| 414 | +12x |
- #'+ p <- p + ggtheme |
||
| 189 | +415 |
- #' @keywords internal+ } else {
|
||
| 190 | -+ | |||
| 416 | +! |
- prop_chisq <- function(tbl) {
+ p <- p + |
||
| 191 | -41x | +|||
| 417 | +! |
- checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)+ ggplot2::theme_bw() + |
||
| 192 | -41x | +|||
| 418 | +! |
- tbl <- tbl[, c("TRUE", "FALSE")]
+ ggplot2::theme( |
||
| 193 | -41x | +|||
| 419 | +! |
- if (any(colSums(tbl) == 0)) {
+ legend.key.width = grid::unit(1, "cm"), |
||
| 194 | -2x | +|||
| 420 | +! |
- return(1)+ legend.position = legend_position, |
||
| 195 | -+ | |||
| 421 | +! |
- }+ legend.direction = ifelse( |
||
| 196 | -39x | +|||
| 422 | +! |
- stats::prop.test(tbl, correct = FALSE)$p.value+ legend_position %in% c("top", "bottom"),
|
||
| 197 | -+ | |||
| 423 | +! |
- }+ "horizontal", |
||
| 198 | -+ | |||
| 424 | +! |
-
+ "vertical" |
||
| 199 | +425 |
- #' @describeIn h_prop_diff_test Performs stratified Cochran-Mantel-Haenszel test. Internally calls+ ) |
||
| 200 | +426 |
- #' [stats::mantelhaen.test()]. Note that strata with less than two observations are automatically discarded.+ ) |
||
| 201 | +427 |
- #'+ } |
||
| 202 | +428 |
- #' @param ary (`array`, 3 dimensions)\cr array with two groups in rows, the binary response+ |
||
| 203 | +429 |
- #' (`TRUE`/`FALSE`) in columns, and the strata in the third dimension.+ ############################################################# | |
||
| 204 | +430 |
- #'+ # ---- Optionally, add table to the bottom of the plot. ---- |
||
| 205 | +431 |
- #' @keywords internal+ ############################################################# | |
||
| 206 | -+ | |||
| 432 | +12x |
- prop_cmh <- function(ary) {
+ if (!is.null(table)) {
|
||
| 207 | -16x | +433 | +4x |
- checkmate::assert_array(ary)+ df_stats_table <- df_grp %>% |
| 208 | -16x | +434 | +4x |
- checkmate::assert_integer(c(ncol(ary), nrow(ary)), lower = 2, upper = 2)+ dplyr::summarise( |
| 209 | -16x | +435 | +4x |
- checkmate::assert_integer(length(dim(ary)), lower = 3, upper = 3)+ h_format_row( |
| 210 | -16x | +436 | +4x |
- strata_sizes <- apply(ary, MARGIN = 3, sum)+ x = sfun(.data[[y]], ...)[table], |
| 211 | -16x | +437 | +4x |
- if (any(strata_sizes < 5)) {
+ format = table_format, |
| 212 | -1x | +438 | +4x |
- warning("<5 data points in some strata. CMH test may be incorrect.")
+ labels = table_labels+ |
+
| 439 | ++ |
+ ), |
||
| 213 | -1x | +440 | +4x |
- ary <- ary[, , strata_sizes > 1]+ .groups = "drop" |
| 214 | +441 |
- }+ ) |
||
| 215 | +442 | |||
| 216 | -16x | +443 | +4x |
- stats::mantelhaen.test(ary, correct = FALSE)$p.value+ stats_lev <- rev(setdiff(colnames(df_stats_table), c(group_var, x))) |
| 217 | +444 |
- }+ |
||
| 218 | -+ | |||
| 445 | +4x |
-
+ df_stats_table <- df_stats_table %>% |
||
| 219 | -+ | |||
| 446 | +4x |
- #' @describeIn h_prop_diff_test Performs the Chi-Squared test with Schouten correction.+ tidyr::pivot_longer( |
||
| 220 | -+ | |||
| 447 | +4x |
- #'+ cols = -dplyr::all_of(c(group_var, x)), |
||
| 221 | -+ | |||
| 448 | +4x |
- #' @seealso Schouten correction is based upon \insertCite{Schouten1980-kd;textual}{tern}.
+ names_to = "stat", |
||
| 222 | -+ | |||
| 449 | +4x |
- #'+ values_to = "value", |
||
| 223 | -+ | |||
| 450 | +4x |
- #' @keywords internal+ names_ptypes = list(stat = factor(levels = stats_lev)) |
||
| 224 | +451 |
- prop_schouten <- function(tbl) {
+ ) |
||
| 225 | -100x | +|||
| 452 | +
- checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)+ |
|||
| 226 | -100x | +453 | +4x |
- tbl <- tbl[, c("TRUE", "FALSE")]
+ tbl <- ggplot2::ggplot( |
| 227 | -100x | +454 | +4x |
- if (any(colSums(tbl) == 0)) {
+ df_stats_table, |
| 228 | -1x | -
- return(1)- |
- ||
| 229 | -+ | 455 | +4x |
- }+ ggplot2::aes(x = .data[[x]], y = .data[["stat"]], label = .data[["value"]]) |
| 230 | +456 |
-
+ ) + |
||
| 231 | -99x | +457 | +4x |
- n <- sum(tbl)+ ggplot2::geom_text(size = table_font_size) + |
| 232 | -99x | +458 | +4x |
- n1 <- sum(tbl[1, ])+ ggplot2::theme_bw() + |
| 233 | -99x | +459 | +4x |
- n2 <- sum(tbl[2, ])+ ggplot2::theme( |
| 234 | -+ | |||
| 460 | +4x |
-
+ panel.border = ggplot2::element_blank(), |
||
| 235 | -99x | +461 | +4x |
- ad <- diag(tbl)+ panel.grid.major = ggplot2::element_blank(), |
| 236 | -99x | +462 | +4x |
- bc <- diag(apply(tbl, 2, rev))+ panel.grid.minor = ggplot2::element_blank(), |
| 237 | -99x | +463 | +4x |
- ac <- tbl[, 1]+ axis.ticks = ggplot2::element_blank(), |
| 238 | -99x | +464 | +4x |
- bd <- tbl[, 2]+ axis.title = ggplot2::element_blank(), |
| 239 | -+ | |||
| 465 | +4x |
-
+ axis.text.x = ggplot2::element_blank(), |
||
| 240 | -99x | +466 | +4x |
- t_schouten <- (n - 1) *+ axis.text.y = ggplot2::element_text(margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 5)), |
| 241 | -99x | +467 | +4x |
- (abs(prod(ad) - prod(bc)) - 0.5 * min(n1, n2))^2 /+ strip.text = ggplot2::element_text(hjust = 0), |
| 242 | -99x | +468 | +4x |
- (n1 * n2 * sum(ac) * sum(bd))+ strip.text.x = ggplot2::element_text(margin = ggplot2::margin(1.5, 0, 1.5, 0, "pt")), |
| 243 | -+ | |||
| 469 | +4x |
-
+ strip.background = ggplot2::element_rect(fill = "grey95", color = NA), |
||
| 244 | -99x | +470 | +4x |
- 1 - stats::pchisq(t_schouten, df = 1)+ legend.position = "none" |
| 245 | +471 |
- }+ ) |
||
| 246 | +472 | |||
| 247 | -+ | |||
| 473 | +4x |
- #' @describeIn h_prop_diff_test Performs the Fisher's exact test. Internally calls [stats::fisher.test()].+ if (!is.null(group_var)) {
+ |
+ ||
| 474 | +4x | +
+ tbl <- tbl + ggplot2::facet_wrap(facets = group_var, ncol = 1) |
||
| 248 | +475 |
- #'+ } |
||
| 249 | +476 |
- #' @keywords internal+ |
||
| 250 | +477 |
- prop_fisher <- function(tbl) {
+ # align plot and table |
||
| 251 | -2x | +478 | +4x |
- checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)+ cowplot::plot_grid(p, tbl, ncol = 1, align = "v", axis = "tblr") |
| 252 | -2x | +|||
| 479 | +
- tbl <- tbl[, c("TRUE", "FALSE")]
+ } else {
|
|||
| 253 | -2x | +480 | +8x |
- stats::fisher.test(tbl)$p.value+ p |
| 254 | +481 |
- }+ } |
| 1 | +482 |
- #' Count occurrences+ } |
||
| 2 | +483 |
- #'+ |
||
| 3 | +484 |
- #' @description `r lifecycle::badge("stable")`
+ #' Helper function to format the optional `g_lineplot` table |
||
| 4 | +485 |
#' |
||
| 5 | +486 |
- #' The analyze function [count_occurrences()] creates a layout element to calculate occurrence counts for patients.+ #' @description `r lifecycle::badge("stable")`
|
||
| 6 | +487 |
#' |
||
| 7 | +488 |
- #' This function analyzes the variable(s) supplied to `vars` and returns a table of occurrence counts for+ #' @param x (named `list`)\cr list of numerical values to be formatted and optionally labeled. |
||
| 8 | +489 |
- #' each unique value (or level) of the variable(s). This variable (or variables) must be+ #' Elements of `x` must be `numeric` vectors. |
||
| 9 | +490 |
- #' non-numeric. The `id` variable is used to indicate unique subject identifiers (defaults to `USUBJID`).+ #' @param format (named `character` or `NULL`)\cr format patterns for `x`. Names of the `format` must |
||
| 10 | +491 |
- #'+ #' match the names of `x`. This parameter is passed directly to the `rtables::format_rcell` |
||
| 11 | +492 |
- #' If there are multiple occurrences of the same value recorded for a patient, the value is only counted once.+ #' function through the `format` parameter. |
||
| 12 | +493 |
- #'+ #' @param labels (named `character` or `NULL`)\cr optional labels for `x`. Names of the `labels` must |
||
| 13 | +494 |
- #' The summarize function [summarize_occurrences()] performs the same function as [count_occurrences()] except it+ #' match the names of `x`. When a label is not specified for an element of `x`, |
||
| 14 | +495 |
- #' creates content rows, not data rows, to summarize the current table row/column context and operates on the level of+ #' then this function tries to use `label` or `names` (in this order) attribute of that element |
||
| 15 | +496 |
- #' the latest row split or the root of the table if no row splits have occurred.+ #' (depending on which one exists and it is not `NULL` or `NA` or `NaN`). If none of these attributes |
||
| 16 | +497 |
- #'+ #' are attached to a given element of `x`, then the label is automatically generated. |
||
| 17 | +498 |
- #' @inheritParams argument_convention+ #' |
||
| 18 | +499 |
- #' @param drop (`flag`)\cr whether non-appearing occurrence levels should be dropped from the resulting table.+ #' @return A single row `data.frame` object. |
||
| 19 | +500 |
- #' Note that in that case the remaining occurrence levels in the table are sorted alphabetically.+ #' |
||
| 20 | +501 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_occurrences")`
+ #' @examples |
||
| 21 | +502 |
- #' to see available statistics for this function.+ #' mean_ci <- c(48, 51) |
||
| 22 | +503 |
- #'+ #' x <- list(mean = 50, mean_ci = mean_ci) |
||
| 23 | +504 |
- #' @note By default, occurrences which don't appear in a given row split are dropped from the table and+ #' format <- c(mean = "xx.x", mean_ci = "(xx.xx, xx.xx)") |
||
| 24 | +505 |
- #' the occurrences in the table are sorted alphabetically per row split. Therefore, the corresponding layout+ #' labels <- c(mean = "My Mean") |
||
| 25 | +506 |
- #' needs to use `split_fun = drop_split_levels` in the `split_rows_by` calls. Use `drop = FALSE` if you would+ #' h_format_row(x, format, labels) |
||
| 26 | +507 |
- #' like to show all occurrences.+ #' |
||
| 27 | +508 |
- #'+ #' attr(mean_ci, "label") <- "Mean 95% CI" |
||
| 28 | +509 |
- #' @examples+ #' x <- list(mean = 50, mean_ci = mean_ci) |
||
| 29 | +510 |
- #' library(dplyr)+ #' h_format_row(x, format, labels) |
||
| 30 | +511 |
- #' df <- data.frame(+ #' |
||
| 31 | +512 |
- #' USUBJID = as.character(c(+ #' @export |
||
| 32 | +513 |
- #' 1, 1, 2, 4, 4, 4,+ h_format_row <- function(x, format, labels = NULL) {
|
||
| 33 | +514 |
- #' 6, 6, 6, 7, 7, 8+ # cell: one row, one column data.frame |
||
| 34 | -+ | |||
| 515 | +74x |
- #' )),+ format_cell <- function(x, format, label = NULL) {
|
||
| 35 | -+ | |||
| 516 | +184x |
- #' MHDECOD = c(+ fc <- format_rcell(x = x, format = unlist(format)) |
||
| 36 | -+ | |||
| 517 | +184x |
- #' "MH1", "MH2", "MH1", "MH1", "MH1", "MH3",+ if (is.na(fc)) {
|
||
| 37 | -+ | |||
| 518 | +! |
- #' "MH2", "MH2", "MH3", "MH1", "MH2", "MH4"+ fc <- "NA" |
||
| 38 | +519 |
- #' ),+ } |
||
| 39 | -+ | |||
| 520 | +184x |
- #' ARM = rep(c("A", "B"), each = 6),
+ x_label <- attr(x, "label") |
||
| 40 | -+ | |||
| 521 | +184x |
- #' SEX = c("F", "F", "M", "M", "M", "M", "F", "F", "F", "M", "M", "F")
+ if (!is.null(label) && !is.na(label)) {
+ |
+ ||
| 522 | +182x | +
+ names(fc) <- label+ |
+ ||
| 523 | +2x | +
+ } else if (!is.null(x_label) && !is.na(x_label)) {
+ |
+ ||
| 524 | +1x | +
+ names(fc) <- x_label+ |
+ ||
| 525 | +1x | +
+ } else if (length(x) == length(fc)) {
+ |
+ ||
| 526 | +! | +
+ names(fc) <- names(x) |
||
| 41 | +527 |
- #' )+ }+ |
+ ||
| 528 | +184x | +
+ as.data.frame(t(fc)) |
||
| 42 | +529 |
- #' df_adsl <- df %>%+ } |
||
| 43 | +530 |
- #' select(USUBJID, ARM) %>%+ + |
+ ||
| 531 | +74x | +
+ row <- do.call(+ |
+ ||
| 532 | +74x | +
+ cbind, |
||
| 44 | -+ | |||
| 533 | +74x |
- #' unique()+ lapply( |
||
| 45 | -+ | |||
| 534 | +74x |
- #'+ names(x), function(xn) format_cell(x[[xn]], format = format[xn], label = labels[xn]) |
||
| 46 | +535 |
- #' @name count_occurrences+ ) |
||
| 47 | +536 |
- #' @order 1+ ) |
||
| 48 | +537 |
- NULL+ |
||
| 49 | -+ | |||
| 538 | +74x |
-
+ row |
||
| 50 | +539 |
- #' @describeIn count_occurrences Statistics function which counts number of patients that report an+ } |
||
| 51 | +540 |
- #' occurrence.+ |
||
| 52 | +541 |
- #'+ #' Control function for `g_lineplot()` |
||
| 53 | +542 |
- #' @param denom (`string`)\cr choice of denominator for patient proportions. Can be:+ #' |
||
| 54 | +543 |
- #' - `N_col`: total number of patients in this column across rows+ #' @description `r lifecycle::badge("stable")`
|
||
| 55 | +544 |
- #' - `n`: number of patients with any occurrences+ #' |
||
| 56 | +545 |
- #'+ #' Default values for `variables` parameter in `g_lineplot` function. |
||
| 57 | +546 |
- #' @return+ #' A variable's default value can be overwritten for any variable. |
||
| 58 | +547 |
- #' * `s_count_occurrences()` returns a list with:+ #' |
||
| 59 | +548 |
- #' * `count`: list of counts with one element per occurrence.+ #' @param x (`string`)\cr x-variable name. |
||
| 60 | +549 |
- #' * `count_fraction`: list of counts and fractions with one element per occurrence.+ #' @param y (`string`)\cr y-variable name. |
||
| 61 | +550 |
- #' * `fraction`: list of numerators and denominators with one element per occurrence.+ #' @param group_var (`string` or `NA`)\cr group variable name. |
||
| 62 | +551 |
- #'+ #' @param subject_var (`string` or `NA`)\cr subject variable name. |
||
| 63 | +552 |
- #' @examples+ #' @param facet_var (`string` or `NA`)\cr faceting variable name. |
||
| 64 | +553 |
- #' # Count unique occurrences per subject.+ #' @param paramcd (`string` or `NA`)\cr parameter code variable name. |
||
| 65 | +554 |
- #' s_count_occurrences(+ #' @param y_unit (`string` or `NA`)\cr y-axis unit variable name. |
||
| 66 | +555 |
- #' df,+ #' |
||
| 67 | +556 |
- #' .N_col = 4L,+ #' @return A named character vector of variable names. |
||
| 68 | +557 |
- #' .df_row = df,+ #' |
||
| 69 | +558 |
- #' .var = "MHDECOD",+ #' @examples |
||
| 70 | +559 |
- #' id = "USUBJID"+ #' control_lineplot_vars() |
||
| 71 | +560 |
- #' )+ #' control_lineplot_vars(group_var = NA) |
||
| 72 | +561 |
#' |
||
| 73 | +562 |
#' @export |
||
| 74 | +563 |
- s_count_occurrences <- function(df,+ control_lineplot_vars <- function(x = "AVISIT", |
||
| 75 | +564 |
- denom = c("N_col", "n"),
+ y = "AVAL", |
||
| 76 | +565 |
- .N_col, # nolint+ group_var = "ARM", |
||
| 77 | +566 |
- .df_row,+ facet_var = NA, |
||
| 78 | +567 |
- drop = TRUE,+ paramcd = "PARAMCD", |
||
| 79 | +568 |
- .var = "MHDECOD",+ y_unit = "AVALU", |
||
| 80 | +569 |
- id = "USUBJID") {
+ subject_var = "USUBJID") {
|
||
| 81 | -126x | +570 | +15x |
- checkmate::assert_flag(drop)+ checkmate::assert_string(x) |
| 82 | -126x | +571 | +15x |
- assert_df_with_variables(df, list(range = .var, id = id))+ checkmate::assert_string(y) |
| 83 | -126x | +572 | +15x |
- checkmate::assert_count(.N_col)+ checkmate::assert_string(group_var, na.ok = TRUE, null.ok = TRUE) |
| 84 | -126x | +573 | +15x |
- checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
+ checkmate::assert_string(facet_var, na.ok = TRUE, null.ok = TRUE) |
| 85 | -126x | +574 | +15x |
- checkmate::assert_multi_class(df[[id]], classes = c("factor", "character"))
+ checkmate::assert_string(subject_var, na.ok = TRUE, null.ok = TRUE) |
| 86 | -126x | -
- denom <- match.arg(denom)- |
- ||
| 87 | -+ | 575 | +15x |
-
+ checkmate::assert_string(paramcd, na.ok = TRUE, null.ok = TRUE) |
| 88 | -126x | -
- occurrences <- if (drop) {
- |
- ||
| 89 | -+ | 576 | +15x |
- # Note that we don't try to preserve original level order here since a) that would required+ checkmate::assert_string(y_unit, na.ok = TRUE, null.ok = TRUE) |
| 90 | +577 |
- # more time to look up in large original levels and b) that would fail for character input variable.+ |
||
| 91 | -115x | +578 | +15x |
- occurrence_levels <- sort(unique(.df_row[[.var]]))+ variables <- c( |
| 92 | -115x | +579 | +15x |
- if (length(occurrence_levels) == 0) {
+ x = x, y = y, group_var = group_var, paramcd = paramcd, |
| 93 | -1x | +580 | +15x |
- stop(+ y_unit = y_unit, subject_var = subject_var, facet_var = facet_var |
| 94 | -1x | +|||
| 581 | +
- "no empty `.df_row` input allowed when `drop = TRUE`,",+ ) |
|||
| 95 | -1x | +582 | +15x |
- " please use `split_fun = drop_split_levels` in the `rtables` `split_rows_by` calls"+ return(variables) |
| 96 | +583 |
- )+ } |
| 97 | +1 |
- }- |
- ||
| 98 | -114x | -
- factor(df[[.var]], levels = occurrence_levels)+ #' Custom split functions |
||
| 99 | +2 |
- } else {
- |
- ||
| 100 | -11x | -
- df[[.var]]+ #' |
||
| 101 | +3 |
- }- |
- ||
| 102 | -125x | -
- ids <- factor(df[[id]])+ #' @description `r lifecycle::badge("stable")`
|
||
| 103 | -125x | +|||
| 4 | +
- dn <- switch(denom,+ #' |
|||
| 104 | -125x | +|||
| 5 | +
- n = nlevels(ids),+ #' Collection of useful functions that are expanding on the core list of functions |
|||
| 105 | -125x | +|||
| 6 | +
- N_col = .N_col+ #' provided by `rtables`. See [rtables::custom_split_funs] and [rtables::make_split_fun()] |
|||
| 106 | +7 |
- )+ #' for more information on how to make a custom split function. All these functions |
||
| 107 | -125x | +|||
| 8 | +
- has_occurrence_per_id <- table(occurrences, ids) > 0+ #' work with [rtables::split_rows_by()] argument `split_fun` to modify the way the split |
|||
| 108 | -125x | +|||
| 9 | +
- n_ids_per_occurrence <- as.list(rowSums(has_occurrence_per_id))+ #' happens. For other split functions, consider consulting [`rtables::split_funcs`]. |
|||
| 109 | -125x | +|||
| 10 | +
- list(+ #' |
|||
| 110 | -125x | +|||
| 11 | +
- count = n_ids_per_occurrence,+ #' @seealso [rtables::make_split_fun()] |
|||
| 111 | -125x | +|||
| 12 | +
- count_fraction = lapply(+ #' |
|||
| 112 | -125x | +|||
| 13 | +
- n_ids_per_occurrence,+ #' @name utils_split_funs |
|||
| 113 | -125x | +|||
| 14 | +
- function(i, denom) {
+ NULL |
|||
| 114 | -514x | +|||
| 15 | +
- if (i == 0 && denom == 0) {
+
|
|||
| 115 | -! | +|||
| 16 | +
- c(0, 0)+ #' @describeIn utils_split_funs Split function to place reference group facet at a specific position |
|||
| 116 | +17 |
- } else {
+ #' during post-processing stage. |
||
| 117 | -514x | +|||
| 18 | +
- c(i, i / denom)+ #' |
|||
| 118 | +19 |
- }+ #' @param position (`string` or `integer`)\cr position to use for the reference group facet. Can be `"first"`, |
||
| 119 | +20 |
- },+ #' `"last"`, or a specific position. |
||
| 120 | -125x | +|||
| 21 | +
- denom = dn+ #' |
|||
| 121 | +22 |
- ),+ #' @return |
||
| 122 | -125x | +|||
| 23 | +
- fraction = lapply(+ #' * `ref_group_position()` returns an utility function that puts the reference group |
|||
| 123 | -125x | +|||
| 24 | +
- n_ids_per_occurrence,+ #' as first, last or at a certain position and needs to be assigned to `split_fun`. |
|||
| 124 | -125x | +|||
| 25 | +
- function(i, denom) c("num" = i, "denom" = denom),
+ #' |
|||
| 125 | -125x | +|||
| 26 | +
- denom = dn+ #' @examples |
|||
| 126 | +27 |
- )+ #' library(dplyr) |
||
| 127 | +28 |
- )+ #' |
||
| 128 | +29 |
- }+ #' dat <- data.frame( |
||
| 129 | +30 |
-
+ #' x = factor(letters[1:5], levels = letters[5:1]), |
||
| 130 | +31 |
- #' @describeIn count_occurrences Formatted analysis function which is used as `afun`+ #' y = 1:5 |
||
| 131 | +32 |
- #' in `count_occurrences()`.+ #' ) |
||
| 132 | +33 |
#' |
||
| 133 | +34 |
- #' @return+ #' # With rtables layout functions |
||
| 134 | +35 |
- #' * `a_count_occurrences()` returns the corresponding list with formatted [rtables::CellValue()].+ #' basic_table() %>% |
||
| 135 | +36 |
- #'+ #' split_cols_by("x", ref_group = "c", split_fun = ref_group_position("last")) %>%
|
||
| 136 | +37 |
- #' @examples+ #' analyze("y") %>%
|
||
| 137 | +38 |
- #' a_count_occurrences(+ #' build_table(dat) |
||
| 138 | +39 |
- #' df,+ #' |
||
| 139 | +40 |
- #' .N_col = 4L,+ #' # With tern layout funcitons |
||
| 140 | +41 |
- #' .df_row = df,+ #' adtte_f <- tern_ex_adtte %>% |
||
| 141 | +42 |
- #' .var = "MHDECOD",+ #' filter(PARAMCD == "OS") %>% |
||
| 142 | +43 |
- #' id = "USUBJID"+ #' mutate( |
||
| 143 | +44 |
- #' )+ #' AVAL = day2month(AVAL), |
||
| 144 | +45 |
- #'+ #' is_event = CNSR == 0 |
||
| 145 | +46 |
- #' @export+ #' ) |
||
| 146 | +47 |
- a_count_occurrences <- function(df,+ #' |
||
| 147 | +48 |
- labelstr = "",+ #' basic_table() %>% |
||
| 148 | +49 |
- id = "USUBJID",+ #' split_cols_by(var = "ARMCD", ref_group = "ARM B", split_fun = ref_group_position("first")) %>%
|
||
| 149 | +50 |
- denom = c("N_col", "n"),
+ #' add_colcounts() %>% |
||
| 150 | +51 |
- drop = TRUE,+ #' surv_time( |
||
| 151 | +52 |
- .N_col, # nolint+ #' vars = "AVAL", |
||
| 152 | +53 |
- .var = NULL,+ #' var_labels = "Survival Time (Months)", |
||
| 153 | +54 |
- .df_row = NULL,+ #' is_event = "is_event", |
||
| 154 | +55 |
- .stats = NULL,+ #' ) %>% |
||
| 155 | +56 |
- .formats = NULL,+ #' build_table(df = adtte_f) |
||
| 156 | +57 |
- .labels = NULL,+ #' |
||
| 157 | +58 |
- .indent_mods = NULL,+ #' basic_table() %>% |
||
| 158 | +59 |
- na_str = default_na_str()) {
- |
- ||
| 159 | -85x | -
- denom <- match.arg(denom)+ #' split_cols_by(var = "ARMCD", ref_group = "ARM B", split_fun = ref_group_position(2)) %>% |
||
| 160 | -85x | +|||
| 60 | +
- x_stats <- s_count_occurrences(+ #' add_colcounts() %>% |
|||
| 161 | -85x | +|||
| 61 | +
- df = df, denom = denom, .N_col = .N_col, .df_row = .df_row, drop = drop, .var = .var, id = id+ #' surv_time( |
|||
| 162 | +62 |
- )+ #' vars = "AVAL", |
||
| 163 | -85x | +|||
| 63 | +
- if (is.null(unlist(x_stats))) {
+ #' var_labels = "Survival Time (Months)", |
|||
| 164 | -3x | +|||
| 64 | +
- return(NULL)+ #' is_event = "is_event", |
|||
| 165 | +65 |
- }+ #' ) %>% |
||
| 166 | -82x | +|||
| 66 | +
- x_lvls <- names(x_stats[[1]])+ #' build_table(df = adtte_f) |
|||
| 167 | +67 |
-
+ #' |
||
| 168 | +68 |
- # Fill in with formatting defaults if needed+ #' @export |
||
| 169 | -82x | +|||
| 69 | +
- .stats <- get_stats("count_occurrences", stats_in = .stats)
+ ref_group_position <- function(position = "first") {
|
|||
| 170 | -82x | +70 | +20x |
- .formats <- get_formats_from_stats(.stats, .formats)+ make_split_fun( |
| 171 | -82x | +71 | +20x |
- .labels <- get_labels_from_stats(.stats, .labels, row_nms = x_lvls)+ post = list( |
| 172 | -82x | -
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods, row_nms = x_lvls)- |
- ||
| 173 | -+ | 72 | +20x |
-
+ function(splret, spl, fulldf) {
|
| 174 | -81x | +73 | +57x |
- if ("count_fraction_fixed_dp" %in% .stats) x_stats[["count_fraction_fixed_dp"]] <- x_stats[["count_fraction"]]
+ if (!"ref_group_value" %in% methods::slotNames(spl)) {
|
| 175 | -82x | +74 | +1x |
- x_stats <- x_stats[.stats]+ stop("Reference group is undefined.")
|
| 176 | +75 |
-
+ } |
||
| 177 | +76 |
- # Ungroup statistics with values for each level of x+ |
||
| 178 | -82x | +77 | +56x |
- x_ungrp <- ungroup_stats(x_stats, .formats, list(), list())+ spl_var <- rtables:::spl_payload(spl) |
| 179 | -82x | +78 | +56x |
- x_stats <- x_ungrp[["x"]]+ fulldf[[spl_var]] <- factor(fulldf[[spl_var]]) |
| 180 | -82x | +79 | +56x |
- .formats <- x_ungrp[[".formats"]]+ init_lvls <- levels(fulldf[[spl_var]]) |
| 181 | +80 | |||
| 182 | -+ | |||
| 81 | +56x |
- # Auto format handling+ if (!all(names(splret$values) %in% init_lvls)) {
|
||
| 183 | -82x | +|||
| 82 | +! |
- .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)+ stop("This split function does not work with combination facets.")
|
||
| 184 | +83 |
-
+ } |
||
| 185 | -82x | +|||
| 84 | +
- in_rows(+ |
|||
| 186 | -82x | +85 | +56x |
- .list = x_stats,+ ref_group_pos <- which(init_lvls == rtables:::spl_ref_group(spl)) |
| 187 | -82x | +86 | +56x |
- .formats = .formats,+ pos_choices <- c("first", "last")
|
| 188 | -82x | +87 | +56x |
- .names = .labels,+ if (checkmate::test_choice(position, pos_choices) && position == "first") {
|
| 189 | -82x | +88 | +41x |
- .labels = .labels,+ pos <- 0 |
| 190 | -82x | +89 | +15x |
- .indent_mods = .indent_mods,+ } else if (checkmate::test_choice(position, pos_choices) && position == "last") {
|
| 191 | -82x | -
- .format_na_strs = na_str- |
- ||
| 192 | -+ | 90 | +12x |
- )+ pos <- length(init_lvls) |
| 193 | -+ | |||
| 91 | +3x |
- }+ } else if (checkmate::test_int(position, lower = 1, upper = length(init_lvls))) {
|
||
| 194 | -+ | |||
| 92 | +3x |
-
+ pos <- position - 1 |
||
| 195 | +93 |
- #' @describeIn count_occurrences Layout-creating function which can take statistics function arguments+ } else {
|
||
| 196 | -+ | |||
| 94 | +! |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ stop("Wrong input for ref group position. It must be 'first', 'last', or a integer.")
|
||
| 197 | +95 |
- #'+ } |
||
| 198 | +96 |
- #' @return+ |
||
| 199 | -+ | |||
| 97 | +56x |
- #' * `count_occurrences()` returns a layout object suitable for passing to further layouting functions,+ reord_lvls <- append(init_lvls[-ref_group_pos], init_lvls[ref_group_pos], after = pos) |
||
| 200 | -+ | |||
| 98 | +56x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ ord <- match(reord_lvls, names(splret$values)) |
||
| 201 | +99 |
- #' the statistics from `s_count_occurrences()` to the table layout.+ |
||
| 202 | -+ | |||
| 100 | +56x |
- #'+ make_split_result( |
||
| 203 | -+ | |||
| 101 | +56x |
- #' @examples+ splret$values[ord], |
||
| 204 | -+ | |||
| 102 | +56x |
- #' # Create table layout+ splret$datasplit[ord], |
||
| 205 | -+ | |||
| 103 | +56x |
- #' lyt <- basic_table() %>%+ splret$labels[ord] |
||
| 206 | +104 |
- #' split_cols_by("ARM") %>%
+ ) |
||
| 207 | +105 |
- #' add_colcounts() %>%+ } |
||
| 208 | +106 |
- #' count_occurrences(vars = "MHDECOD", .stats = c("count_fraction"))
+ ) |
||
| 209 | +107 |
- #'+ ) |
||
| 210 | +108 |
- #' # Apply table layout to data and produce `rtable` object+ } |
||
| 211 | +109 |
- #' tbl <- lyt %>%+ |
||
| 212 | +110 |
- #' build_table(df, alt_counts_df = df_adsl) %>%+ #' @describeIn utils_split_funs Split function to change level order based on an `integer` |
||
| 213 | +111 |
- #' prune_table()+ #' vector or a `character` vector that represent the split variable's factor levels. |
||
| 214 | +112 |
#' |
||
| 215 | +113 |
- #' tbl+ #' @param order (`character` or `numeric`)\cr vector of ordering indices for the split facets. |
||
| 216 | +114 |
#' |
||
| 217 | -- |
- #' @export- |
- ||
| 218 | -- |
- #' @order 2- |
- ||
| 219 | -- |
- count_occurrences <- function(lyt,- |
- ||
| 220 | -- |
- vars,- |
- ||
| 221 | +115 |
- id = "USUBJID",+ #' @return |
||
| 222 | +116 |
- drop = TRUE,+ #' * `level_order()` returns an utility function that changes the original levels' order, |
||
| 223 | +117 |
- var_labels = vars,+ #' depending on input `order` and split levels. |
||
| 224 | +118 |
- show_labels = "hidden",+ #' |
||
| 225 | +119 |
- riskdiff = FALSE,+ #' @examples |
||
| 226 | +120 |
- na_str = default_na_str(),+ #' # level_order -------- |
||
| 227 | +121 |
- nested = TRUE,+ #' # Even if default would bring ref_group first, the original order puts it last |
||
| 228 | +122 |
- ...,+ #' basic_table() %>% |
||
| 229 | +123 |
- table_names = vars,+ #' split_cols_by("Species", split_fun = level_order(c(1, 3, 2))) %>%
|
||
| 230 | +124 |
- .stats = "count_fraction_fixed_dp",+ #' analyze("Sepal.Length") %>%
|
||
| 231 | +125 |
- .formats = NULL,+ #' build_table(iris) |
||
| 232 | +126 |
- .labels = NULL,+ #' |
||
| 233 | +127 |
- .indent_mods = NULL) {
- |
- ||
| 234 | -9x | -
- checkmate::assert_flag(riskdiff)+ #' # character vector |
||
| 235 | +128 | - - | -||
| 236 | -9x | -
- extra_args <- list(- |
- ||
| 237 | -9x | -
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str+ #' new_order <- level_order(levels(iris$Species)[c(1, 3, 2)]) |
||
| 238 | +129 |
- )+ #' basic_table() %>% |
||
| 239 | -9x | +|||
| 130 | +
- s_args <- list(id = id, drop = drop, ...)+ #' split_cols_by("Species", ref_group = "virginica", split_fun = new_order) %>%
|
|||
| 240 | +131 |
-
+ #' analyze("Sepal.Length") %>%
|
||
| 241 | -9x | +|||
| 132 | +
- if (isFALSE(riskdiff)) {
+ #' build_table(iris) |
|||
| 242 | -6x | +|||
| 133 | +
- extra_args <- c(extra_args, s_args)+ #' |
|||
| 243 | +134 |
- } else {
+ #' @export |
||
| 244 | -3x | +|||
| 135 | +
- extra_args <- c(+ level_order <- function(order) {
|
|||
| 245 | -3x | +136 | +2x |
- extra_args,+ make_split_fun( |
| 246 | -3x | +137 | +2x |
- list(+ post = list( |
| 247 | -3x | +138 | +2x |
- afun = list("s_count_occurrences" = a_count_occurrences),
+ function(splret, spl, fulldf) {
|
| 248 | -3x | +139 | +4x |
- s_args = s_args+ if (checkmate::test_integerish(order)) {
|
| 249 | -+ | |||
| 140 | +1x |
- )+ checkmate::assert_integerish(order, lower = 1, upper = length(splret$values)) |
||
| 250 | -+ | |||
| 141 | +1x |
- )+ ord <- order |
||
| 251 | +142 |
- }+ } else {
|
||
| 252 | -+ | |||
| 143 | +3x |
-
+ checkmate::assert_character(order, len = length(splret$values)) |
||
| 253 | -9x | +144 | +3x |
- analyze(+ checkmate::assert_set_equal(order, names(splret$values), ordered = FALSE) |
| 254 | -9x | +145 | +3x |
- lyt = lyt,+ ord <- match(order, names(splret$values)) |
| 255 | -9x | +|||
| 146 | +
- vars = vars,+ } |
|||
| 256 | -9x | +147 | +4x |
- afun = ifelse(isFALSE(riskdiff), a_count_occurrences, afun_riskdiff),+ make_split_result( |
| 257 | -9x | +148 | +4x |
- var_labels = var_labels,+ splret$values[ord], |
| 258 | -9x | +149 | +4x |
- show_labels = show_labels,+ splret$datasplit[ord], |
| 259 | -9x | +150 | +4x |
- table_names = table_names,+ splret$labels[ord] |
| 260 | -9x | +|||
| 151 | +
- na_str = na_str,+ ) |
|||
| 261 | -9x | +|||
| 152 | +
- nested = nested,+ } |
|||
| 262 | -9x | +|||
| 153 | +
- extra_args = extra_args+ ) |
|||
| 263 | +154 |
) |
||
| 264 | +155 |
} |
| 265 | +1 |
-
+ #' Additional assertions to use with `checkmate` |
||
| 266 | +2 |
- #' @describeIn count_occurrences Layout-creating function which can take content function arguments+ #' |
||
| 267 | +3 |
- #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ #' Additional assertion functions which can be used together with the `checkmate` package. |
||
| 268 | +4 |
#' |
||
| 269 | +5 |
- #' @return+ #' @inheritParams checkmate::assert_factor |
||
| 270 | +6 |
- #' * `summarize_occurrences()` returns a layout object suitable for passing to further layouting functions,+ #' @param x (`any`)\cr object to test. |
||
| 271 | +7 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows+ #' @param df (`data.frame`)\cr data set to test. |
||
| 272 | +8 |
- #' containing the statistics from `s_count_occurrences()` to the table layout.+ #' @param variables (named `list` of `character`)\cr list of variables to test. |
||
| 273 | +9 |
- #'+ #' @param include_boundaries (`flag`)\cr whether to include boundaries when testing |
||
| 274 | +10 |
- #' @examples+ #' for proportions. |
||
| 275 | +11 |
- #' # Layout creating function with custom format.+ #' @param na_level (`string`)\cr the string you have been using to represent NA or |
||
| 276 | +12 |
- #' basic_table() %>%+ #' missing data. For `NA` values please consider using directly [is.na()] or |
||
| 277 | +13 |
- #' add_colcounts() %>%+ #' similar approaches. |
||
| 278 | +14 |
- #' split_rows_by("SEX", child_labels = "visible") %>%
+ #' |
||
| 279 | +15 |
- #' summarize_occurrences(+ #' @return Nothing if assertion passes, otherwise prints the error message. |
||
| 280 | +16 |
- #' var = "MHDECOD",+ #' |
||
| 281 | +17 |
- #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
+ #' @name assertions |
||
| 282 | +18 |
- #' ) %>%+ NULL |
||
| 283 | +19 |
- #' build_table(df, alt_counts_df = df_adsl)+ |
||
| 284 | +20 |
- #'+ check_list_of_variables <- function(x) {
|
||
| 285 | +21 |
- #' @export+ # drop NULL elements in list |
||
| 286 | -+ | |||
| 22 | +2927x |
- #' @order 3+ x <- Filter(Negate(is.null), x) |
||
| 287 | +23 |
- summarize_occurrences <- function(lyt,+ |
||
| 288 | -+ | |||
| 24 | +2927x |
- var,+ res <- checkmate::check_list(x,+ |
+ ||
| 25 | +2927x | +
+ names = "named",+ |
+ ||
| 26 | +2927x | +
+ min.len = 1,+ |
+ ||
| 27 | +2927x | +
+ any.missing = FALSE,+ |
+ ||
| 28 | +2927x | +
+ types = "character" |
||
| 289 | +29 |
- id = "USUBJID",+ ) |
||
| 290 | +30 |
- drop = TRUE,+ # no empty strings allowed+ |
+ ||
| 31 | +2927x | +
+ if (isTRUE(res)) {
+ |
+ ||
| 32 | +2922x | +
+ res <- checkmate::check_character(unlist(x), min.chars = 1) |
||
| 291 | +33 |
- riskdiff = FALSE,+ }+ |
+ ||
| 34 | +2927x | +
+ return(res) |
||
| 292 | +35 |
- na_str = default_na_str(),+ } |
||
| 293 | +36 |
- ...,+ #' @describeIn assertions Checks whether `x` is a valid list of variable names. |
||
| 294 | +37 |
- .stats = "count_fraction_fixed_dp",+ #' `NULL` elements of the list `x` are dropped with `Filter(Negate(is.null), x)`. |
||
| 295 | +38 |
- .formats = NULL,+ #' |
||
| 296 | +39 |
- .indent_mods = NULL,+ #' @keywords internal |
||
| 297 | +40 |
- .labels = NULL) {
+ assert_list_of_variables <- checkmate::makeAssertionFunction(check_list_of_variables) |
||
| 298 | -5x | +|||
| 41 | +
- checkmate::assert_flag(riskdiff)+ |
|||
| 299 | +42 |
-
+ check_df_with_variables <- function(df, variables, na_level = NULL) {
|
||
| 300 | -5x | +43 | +2610x |
- extra_args <- list(+ checkmate::assert_data_frame(df) |
| 301 | -5x | +44 | +2608x |
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str+ assert_list_of_variables(variables) |
| 302 | +45 |
- )- |
- ||
| 303 | -5x | -
- s_args <- list(id = id, drop = drop, ...)+ |
||
| 304 | +46 |
-
+ # flag for equal variables and column names |
||
| 305 | -5x | +47 | +2606x |
- if (isFALSE(riskdiff)) {
+ err_flag <- all(unlist(variables) %in% colnames(df)) |
| 306 | -1x | +48 | +2606x |
- extra_args <- c(extra_args, s_args)+ checkmate::assert_flag(err_flag) |
| 307 | +49 |
- } else {
+
|
||
| 308 | -4x | +50 | +2606x |
- extra_args <- c(+ if (isFALSE(err_flag)) {
|
| 309 | -4x | +51 | +5x |
- extra_args,+ vars <- setdiff(unlist(variables), colnames(df)) |
| 310 | -4x | +52 | +5x |
- list(+ return(paste( |
| 311 | -4x | +53 | +5x |
- afun = list("s_count_occurrences" = a_count_occurrences),
+ deparse(substitute(df)), |
| 312 | -4x | +54 | +5x |
- s_args = s_args+ "does not contain all specified variables as column names. Missing from data frame:", |
| 313 | -+ | |||
| 55 | +5x |
- )+ paste(vars, collapse = ", ") |
||
| 314 | +56 |
- )+ )) |
||
| 315 | +57 |
} |
||
| 316 | +58 |
-
+ # checking if na_level is present and in which column |
||
| 317 | -5x | +59 | +2601x |
- summarize_row_groups(+ if (!is.null(na_level)) {
|
| 318 | -5x | +60 | +9x |
- lyt = lyt,+ checkmate::assert_string(na_level) |
| 319 | -5x | +61 | +9x |
- var = var,+ res <- unlist(lapply(as.list(df)[unlist(variables)], function(x) any(x == na_level))) |
| 320 | -5x | +62 | +9x |
- cfun = ifelse(isFALSE(riskdiff), a_count_occurrences, afun_riskdiff),+ if (any(res)) {
|
| 321 | -5x | +63 | +1x |
- na_str = na_str,+ return(paste0( |
| 322 | -5x | +64 | +1x |
- extra_args = extra_args+ deparse(substitute(df)), " contains explicit na_level (", na_level,
|
| 323 | -+ | |||
| 65 | +1x |
- )+ ") in the following columns: ", paste0(unlist(variables)[res],+ |
+ ||
| 66 | +1x | +
+ collapse = ", " |
||
| 324 | +67 |
- }+ ) |
| 1 | +68 |
- #' Summarize variables in columns+ )) |
||||
| 2 | +69 |
- #'+ } |
||||
| 3 | +70 |
- #' @description `r lifecycle::badge("stable")`
+ }+ |
+ ||||
| 71 | +2600x | +
+ return(TRUE) |
||||
| 4 | +72 |
- #'+ } |
||||
| 5 | +73 |
- #' The analyze function [summarize_colvars()] uses the statistics function [s_summary()] to analyze variables that are+ #' @describeIn assertions Check whether `df` is a data frame with the analysis `variables`. |
||||
| 6 | +74 |
- #' arranged in columns. The variables to analyze should be specified in the table layout via column splits (see+ #' Please notice how this produces an error when not all variables are present in the |
||||
| 7 | +75 |
- #' [rtables::split_cols_by()] and [rtables::split_cols_by_multivar()]) prior to using [summarize_colvars()].+ #' data.frame while the opposite is not required. |
||||
| 8 | +76 |
#' |
||||
| 9 | +77 |
- #' The function is a minimal wrapper for [rtables::analyze_colvars()], a function typically used to apply different+ #' @keywords internal |
||||
| 10 | +78 |
- #' analysis methods in rows for each column variable. To use the analysis methods as column labels, please refer to+ assert_df_with_variables <- checkmate::makeAssertionFunction(check_df_with_variables) |
||||
| 11 | +79 |
- #' the [analyze_vars_in_cols()] function.+ |
||||
| 12 | +80 |
- #'+ check_valid_factor <- function(x, |
||||
| 13 | +81 |
- #' @inheritParams argument_convention+ min.levels = 1, # nolint |
||||
| 14 | +82 |
- #' @param ... arguments passed to [s_summary()].+ max.levels = NULL, # nolint |
||||
| 15 | +83 |
- #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ null.ok = TRUE, # nolint |
||||
| 16 | +84 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ any.missing = TRUE, # nolint |
||||
| 17 | +85 |
- #' for that statistic's row label.+ n.levels = NULL, # nolint |
||||
| 18 | +86 |
- #'+ len = NULL) {
|
||||
| 19 | +87 |
- #' @return+ # checks on levels insertion |
||||
| 20 | -+ | |||||
| 88 | +1081x |
- #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()].+ checkmate::assert_int(min.levels, lower = 1) |
||||
| 21 | +89 |
- #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output+ |
||||
| 22 | +90 |
- #' in columns, and add it to the table layout.+ # main factor check |
||||
| 23 | -+ | |||||
| 91 | +1081x |
- #'+ res <- checkmate::check_factor(x, |
||||
| 24 | -+ | |||||
| 92 | +1081x |
- #' @seealso [rtables::split_cols_by_multivar()] and [`analyze_colvars_functions`].+ min.levels = min.levels, |
||||
| 25 | -+ | |||||
| 93 | +1081x |
- #'+ null.ok = null.ok, |
||||
| 26 | -+ | |||||
| 94 | +1081x |
- #' @examples+ max.levels = max.levels,+ |
+ ||||
| 95 | +1081x | +
+ any.missing = any.missing,+ |
+ ||||
| 96 | +1081x | +
+ n.levels = n.levels |
||||
| 27 | +97 |
- #' dta_test <- data.frame(+ ) |
||||
| 28 | +98 |
- #' USUBJID = rep(1:6, each = 3),+ |
||||
| 29 | +99 |
- #' PARAMCD = rep("lab", 6 * 3),
+ # no empty strings allowed+ |
+ ||||
| 100 | +1081x | +
+ if (isTRUE(res)) {
+ |
+ ||||
| 101 | +1067x | +
+ res <- checkmate::check_character(levels(x), min.chars = 1) |
||||
| 30 | +102 |
- #' AVISIT = rep(paste0("V", 1:3), 6),
+ } |
||||
| 31 | +103 |
- #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ + |
+ ||||
| 104 | +1081x | +
+ return(res) |
||||
| 32 | +105 |
- #' AVAL = c(9:1, rep(NA, 9)),+ } |
||||
| 33 | +106 |
- #' CHG = c(1:9, rep(NA, 9))+ #' @describeIn assertions Check whether `x` is a valid factor (i.e. has levels and no empty |
||||
| 34 | +107 |
- #' )+ #' string levels). Note that `NULL` and `NA` elements are allowed. |
||||
| 35 | +108 |
#' |
||||
| 36 | +109 |
- #' ## Default output within a `rtables` pipeline.+ #' @keywords internal |
||||
| 37 | +110 |
- #' basic_table() %>%+ assert_valid_factor <- checkmate::makeAssertionFunction(check_valid_factor) |
||||
| 38 | +111 |
- #' split_cols_by("ARM") %>%
+
|
||||
| 39 | +112 |
- #' split_rows_by("AVISIT") %>%
+ check_df_with_factors <- function(df, |
||||
| 40 | +113 |
- #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
+ variables, |
||||
| 41 | +114 |
- #' summarize_colvars() %>%+ min.levels = 1, # nolint |
||||
| 42 | +115 |
- #' build_table(dta_test)+ max.levels = NULL, # nolint |
||||
| 43 | +116 |
- #'+ any.missing = TRUE, # nolint |
||||
| 44 | +117 |
- #' ## Selection of statistics, formats and labels also work.+ na_level = NULL) {
|
||||
| 45 | -+ | |||||
| 118 | +254x |
- #' basic_table() %>%+ res <- check_df_with_variables(df, variables, na_level) |
||||
| 46 | +119 |
- #' split_cols_by("ARM") %>%
+ # checking if all the columns specified by variables are valid factors |
||||
| 47 | -+ | |||||
| 120 | +253x |
- #' split_rows_by("AVISIT") %>%
+ if (isTRUE(res)) {
|
||||
| 48 | +121 |
- #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
+ # searching the data.frame with selected columns (variables) as a list |
||||
| 49 | -+ | |||||
| 122 | +251x |
- #' summarize_colvars(+ res <- lapply( |
||||
| 50 | -+ | |||||
| 123 | +251x |
- #' .stats = c("n", "mean_sd"),
+ X = as.list(df)[unlist(variables)], |
||||
| 51 | -+ | |||||
| 124 | +251x |
- #' .formats = c("mean_sd" = "xx.x, xx.x"),
+ FUN = check_valid_factor, |
||||
| 52 | -+ | |||||
| 125 | +251x |
- #' .labels = c(n = "n", mean_sd = "Mean, SD")+ min.levels = min.levels, |
||||
| 53 | -+ | |||||
| 126 | +251x |
- #' ) %>%+ max.levels = max.levels, |
||||
| 54 | -+ | |||||
| 127 | +251x |
- #' build_table(dta_test)+ any.missing = any.missing |
||||
| 55 | +128 |
- #'+ ) |
||||
| 56 | -+ | |||||
| 129 | +251x |
- #' ## Use arguments interpreted by `s_summary`.+ res_lo <- unlist(vapply(res, Negate(isTRUE), logical(1))) |
||||
| 57 | -+ | |||||
| 130 | +251x |
- #' basic_table() %>%+ if (any(res_lo)) {
|
||||
| 58 | -+ | |||||
| 131 | +6x |
- #' split_cols_by("ARM") %>%
+ return(paste0(+ |
+ ||||
| 132 | +6x | +
+ deparse(substitute(df)), " does not contain only factor variables among:",+ |
+ ||||
| 133 | +6x | +
+ "\n* Column `", paste0(unlist(variables)[res_lo],+ |
+ ||||
| 134 | +6x | +
+ "` of the data.frame -> ", res[res_lo],+ |
+ ||||
| 135 | +6x | +
+ collapse = "\n* " |
||||
| 59 | +136 |
- #' split_rows_by("AVISIT") %>%
+ ) |
||||
| 60 | +137 |
- #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
+ )) |
||||
| 61 | +138 |
- #' summarize_colvars(na.rm = FALSE) %>%+ } else {
+ |
+ ||||
| 139 | +245x | +
+ res <- TRUE |
||||
| 62 | +140 |
- #' build_table(dta_test)+ } |
||||
| 63 | +141 |
- #'+ }+ |
+ ||||
| 142 | +247x | +
+ return(res) |
||||
| 64 | +143 |
- #' @export+ } |
||||
| 65 | +144 |
- summarize_colvars <- function(lyt,+ |
||||
| 66 | +145 |
- ...,+ #' @describeIn assertions Check whether `df` is a data frame where the analysis `variables` |
||||
| 67 | +146 |
- na_str = default_na_str(),+ #' are all factors. Note that the creation of `NA` by direct call of `factor()` will |
||||
| 68 | +147 |
- .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
+ #' trim `NA` levels out of the vector list itself. |
||||
| 69 | +148 |
- .formats = NULL,+ #' |
||||
| 70 | +149 |
- .labels = NULL,+ #' @keywords internal |
||||
| 71 | +150 |
- .indent_mods = NULL) {
+ assert_df_with_factors <- checkmate::makeAssertionFunction(check_df_with_factors) |
||||
| 72 | -3x | +|||||
| 151 | +
- extra_args <- list(.stats = .stats, na_str = na_str, ...)+ |
|||||
| 73 | -1x | +|||||
| 152 | +
- if (!is.null(.formats)) extra_args[[".formats"]] <- .formats+ #' @describeIn assertions Check whether `x` is a proportion: number between 0 and 1. |
|||||
| 74 | -1x | +|||||
| 153 | +
- if (!is.null(.labels)) extra_args[[".labels"]] <- .labels+ #' |
|||||
| 75 | -1x | +|||||
| 154 | +
- if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods+ #' @keywords internal |
|||||
| 76 | +155 |
-
+ assert_proportion_value <- function(x, include_boundaries = FALSE) {
|
||||
| 77 | -3x | +156 | +13912x |
- analyze_colvars(+ checkmate::assert_number(x, lower = 0, upper = 1) |
||
| 78 | -3x | +157 | +13900x |
- lyt,+ checkmate::assert_flag(include_boundaries) |
||
| 79 | -3x | +158 | +13900x |
- afun = a_summary,+ if (isFALSE(include_boundaries)) {
|
||
| 80 | -3x | +159 | +8381x |
- na_str = na_str,+ checkmate::assert_true(x > 0) |
||
| 81 | -3x | +160 | +8379x |
- extra_args = extra_args+ checkmate::assert_true(x < 1) |
||
| 82 | +161 |
- )+ } |
||||
| 83 | +162 |
}@@ -113080,4140 +114347,2789 @@ tern coverage - 95.64% | 160 |
- arm = "ARMCD",- |
- ||
| 161 | -- |
- covariates = NULL,- |
- ||||
| 162 | -- |
- interaction = NULL,- |
- ||||
| 163 | -- |
- strata = NULL- |
- ||||
| 164 | -- |
- ),- |
- ||||
| 165 | -- |
- 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 | -
- checkmate::assert_string(response_definition)- |
- ||||
| 169 | -75x | -
- checkmate::assert_true(grepl("response", response_definition))
- |
- ||||
| 170 | -- | - - | -||||
| 171 | -75x | -
- response_definition <- sub(- |
- ||||
| 172 | -75x | -
- pattern = "response",- |
- ||||
| 173 | -75x | -
- replacement = variables$response,- |
- ||||
| 174 | -75x | -
- x = response_definition,- |
- ||||
| 175 | -75x | -
- fixed = TRUE- |
- ||||
| 176 | -- |
- )- |
- ||||
| 177 | -75x | -
- form <- paste0(response_definition, " ~ ", variables$arm)- |
- ||||
| 178 | -75x | -
- if (!is.null(variables$covariates)) {
- |
- ||||
| 179 | -29x | -
- form <- paste0(form, " + ", paste(variables$covariates, collapse = " + "))- |
- ||||
| 180 | -- |
- }- |
- ||||
| 181 | -75x | -
- if (!is.null(variables$interaction)) {
- |
- ||||
| 182 | -18x | -
- checkmate::assert_string(variables$interaction)- |
- ||||
| 183 | -18x | -
- checkmate::assert_subset(variables$interaction, variables$covariates)- |
- ||||
| 184 | -18x | -
- form <- paste0(form, " + ", variables$arm, ":", variables$interaction)- |
- ||||
| 185 | -- |
- }- |
- ||||
| 186 | -75x | -
- if (!is.null(variables$strata)) {
- |
- ||||
| 187 | -14x | -
- strata_arg <- if (length(variables$strata) > 1) {
- |
- ||||
| 188 | -7x | -
- paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
- |
- ||||
| 189 | -- |
- } else {
- |
- ||||
| 190 | -7x | -
- variables$strata- |
- ||||
| 191 | -- |
- }- |
- ||||
| 192 | -14x | -
- form <- paste0(form, "+ strata(", strata_arg, ")")
- |
- ||||
| 193 | -- |
- }- |
- ||||
| 194 | -75x | -
- formula <- stats::as.formula(form)- |
- ||||
| 195 | -75x | -
- if (is.null(variables$strata)) {
- |
- ||||
| 196 | -61x | -
- stats::glm(- |
- ||||
| 197 | -61x | -
- formula = formula,- |
- ||||
| 198 | -61x | -
- data = data,- |
- ||||
| 199 | -61x | -
- family = stats::binomial("logit")
- |
- ||||
| 200 | -- |
- )- |
- ||||
| 201 | -- |
- } else {
- |
- ||||
| 202 | -14x | -
- clogit_with_tryCatch(- |
- ||||
| 203 | -14x | -
- formula = formula,- |
- ||||
| 204 | -14x | -
- data = data,- |
- ||||
| 205 | -14x | -
- x = TRUE- |
- ||||
| 206 | -- |
- )- |
- ||||
| 207 | -- |
- }- |
- ||||
| 208 | -- |
- }- |
- ||||
| 209 | -- | - - | -||||
| 210 | -- |
- #' Custom tidy method for binomial GLM results- |
- ||||
| 211 | -- |
- #'- |
- ||||
| 212 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- ||||
| 213 | -- |
- #'- |
- ||||
| 214 | -- |
- #' Helper method (for [broom::tidy()]) to prepare a data frame from a `glm` object- |
- ||||
| 215 | -- |
- #' with `binomial` family.- |
- ||||
| 216 | -- |
- #'- |
- ||||
| 217 | -- |
- #' @inheritParams argument_convention- |
- ||||
| 218 | -- |
- #' @param at (`numeric` or `NULL`)\cr optional values for the interaction variable. Otherwise the median is used.- |
- ||||
| 219 | -- |
- #' @param x (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family.- |
- ||||
| 220 | -- |
- #'- |
- ||||
| 221 | -- |
- #' @return A `data.frame` containing the tidied model.- |
- ||||
| 222 | -- |
- #'- |
- ||||
| 223 | -- |
- #' @method tidy glm- |
- ||||
| 224 | -- |
- #'- |
- ||||
| 225 | -- |
- #' @seealso [h_logistic_regression] for relevant helper functions.- |
- ||||
| 226 | -- |
- #'- |
- ||||
| 227 | -- |
- #' @examples- |
- ||||
| 228 | -- |
- #' library(dplyr)- |
- ||||
| 229 | -- |
- #' library(broom)- |
- ||||
| 230 | -- |
- #'- |
- ||||
| 231 | -- |
- #' adrs_f <- tern_ex_adrs %>%- |
- ||||
| 232 | -- |
- #' filter(PARAMCD == "BESRSPI") %>%- |
- ||||
| 233 | -- |
- #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
- |
- ||||
| 234 | -- |
- #' mutate(- |
- ||||
| 235 | -- |
- #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
- |
- ||||
| 236 | -- |
- #' RACE = factor(RACE),- |
- ||||
| 237 | -- |
- #' SEX = factor(SEX)- |
- ||||
| 238 | -- |
- #' )- |
- ||||
| 239 | -- |
- #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")- |
- ||||
| 240 | -- |
- #' mod1 <- fit_logistic(- |
- ||||
| 241 | -- |
- #' data = adrs_f,- |
- ||||
| 242 | -- |
- #' variables = list(- |
- ||||
| 243 | -- |
- #' response = "Response",- |
- ||||
| 244 | -- |
- #' arm = "ARMCD",- |
- ||||
| 245 | -- |
- #' covariates = c("AGE", "RACE")
- |
- ||||
| 246 | -- |
- #' )- |
- ||||
| 247 | -- |
- #' )- |
- ||||
| 248 | -- |
- #' mod2 <- fit_logistic(- |
- ||||
| 249 | -- |
- #' data = adrs_f,- |
- ||||
| 250 | -- |
- #' variables = list(- |
- ||||
| 251 | -- |
- #' response = "Response",- |
- ||||
| 252 | -- |
- #' arm = "ARMCD",- |
- ||||
| 253 | -- |
- #' covariates = c("AGE", "RACE"),
- |
- ||||
| 254 | -- |
- #' interaction = "AGE"- |
- ||||
| 255 | -- |
- #' )- |
- ||||
| 256 | -- |
- #' )- |
- ||||
| 257 | -- |
- #'- |
- ||||
| 258 | -- |
- #' df <- tidy(mod1, conf_level = 0.99)- |
- ||||
| 259 | -- |
- #' df2 <- tidy(mod2, conf_level = 0.99)- |
- ||||
| 260 | -- |
- #'- |
- ||||
| 261 | -- |
- #' @export- |
- ||||
| 262 | -- |
- tidy.glm <- function(x, # nolint- |
- ||||
| 263 | -- |
- conf_level = 0.95,- |
- ||||
| 264 | -- |
- at = NULL,- |
- ||||
| 265 | -- |
- ...) {
- |
- ||||
| 266 | -5x | -
- checkmate::assert_class(x, "glm")- |
- ||||
| 267 | -5x | -
- checkmate::assert_set_equal(x$family$family, "binomial")- |
- ||||
| 268 | -- | - - | -||||
| 269 | -5x | -
- terms_name <- attr(stats::terms(x), "term.labels")- |
- ||||
| 270 | -5x | -
- xs_class <- attr(x$terms, "dataClasses")- |
- ||||
| 271 | -5x | -
- interaction <- terms_name[which(!terms_name %in% names(xs_class))]- |
- ||||
| 272 | -5x | -
- df <- if (length(interaction) == 0) {
- |
- ||||
| 273 | -2x | -
- h_logistic_simple_terms(- |
- ||||
| 274 | -2x | -
- x = terms_name,- |
- ||||
| 275 | -2x | -
- fit_glm = x,- |
- ||||
| 276 | -2x | -
- conf_level = conf_level- |
- ||||
| 277 | -- |
- )- |
- ||||
| 278 | -- |
- } 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- |
- ||||
| 284 | -- |
- )- |
- ||||
| 285 | -- |
- }- |
- ||||
| 286 | -5x | -
- for (var in c("variable", "term", "interaction", "reference")) {
- |
- ||||
| 287 | -20x | -
- df[[var]] <- factor(df[[var]], levels = unique(df[[var]]))- |
- ||||
| 288 | -- |
- }- |
- ||||
| 289 | -5x | -
- df- |
- ||||
| 290 | -- |
- }- |
- ||||
| 291 | -- | - - | -||||
| 292 | -- |
- #' Logistic regression multivariate column layout function- |
- ||||
| 293 | -- |
- #'- |
- ||||
| 294 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- ||||
| 295 | -- |
- #'- |
- ||||
| 296 | -- |
- #' Layout-creating function which creates a multivariate column layout summarizing logistic- |
- ||||
| 297 | -- |
- #' regression results. This function is a wrapper for [rtables::split_cols_by_multivar()].- |
- ||||
| 298 | -- |
- #'- |
- ||||
| 299 | -- |
- #' @inheritParams argument_convention- |
- ||||
| 300 | -- |
- #'- |
- ||||
| 301 | -- |
- #' @return A layout object suitable for passing to further layouting functions. Adding this- |
- ||||
| 302 | -- |
- #' function to an `rtable` layout will split the table into columns corresponding to- |
- ||||
| 303 | -- |
- #' statistics `df`, `estimate`, `std_error`, `odds_ratio`, `ci`, and `pvalue`.- |
- ||||
| 304 | -- |
- #'- |
- ||||
| 305 | -- |
- #' @export- |
- ||||
| 306 | -- |
- logistic_regression_cols <- function(lyt,+ arm = "ARMCD", |
||||
| 307 | +161 |
- conf_level = 0.95) {
+ covariates = NULL, |
||||
| 308 | -4x | +|||||
| 162 | +
- vars <- c("df", "estimate", "std_error", "odds_ratio", "ci", "pvalue")
+ interaction = NULL, |
|||||
| 309 | -4x | +|||||
| 163 | +
- var_labels <- c(+ strata = NULL |
|||||
| 310 | -4x | +|||||
| 164 | +
- df = "Degrees of Freedom",+ ), |
|||||
| 311 | -4x | +|||||
| 165 | +
- estimate = "Parameter Estimate",+ response_definition = "response") {
|
|||||
| 312 | -4x | +166 | +75x |
- std_error = "Standard Error",+ assert_df_with_variables(data, variables) |
||
| 313 | -4x | +167 | +75x |
- odds_ratio = "Odds Ratio",+ checkmate::assert_subset(names(variables), c("response", "arm", "covariates", "interaction", "strata"))
|
||
| 314 | -4x | +168 | +75x |
- ci = paste("Wald", f_conf_level(conf_level)),
+ checkmate::assert_string(response_definition) |
||
| 315 | -4x | +169 | +75x |
- pvalue = "p-value"+ checkmate::assert_true(grepl("response", response_definition))
|
||
| 316 | +170 |
- )+ |
||||
| 317 | -4x | +171 | +75x |
- split_cols_by_multivar(+ response_definition <- sub( |
||
| 318 | -4x | +172 | +75x |
- lyt = lyt,+ pattern = "response", |
||
| 319 | -4x | +173 | +75x |
- vars = vars,+ replacement = variables$response, |
||
| 320 | -4x | -
- varlabels = var_labels- |
- ||||
| 321 | -+ | 174 | +75x |
- )+ x = response_definition, |
||
| 322 | -+ | |||||
| 175 | +75x |
- }+ fixed = TRUE |
||||
| 323 | +176 |
-
+ ) |
||||
| 324 | -+ | |||||
| 177 | +75x |
- #' Logistic regression summary table+ form <- paste0(response_definition, " ~ ", variables$arm) |
||||
| 325 | -+ | |||||
| 178 | +75x |
- #'+ if (!is.null(variables$covariates)) {
|
||||
| 326 | -+ | |||||
| 179 | +29x |
- #' @description `r lifecycle::badge("stable")`
+ form <- paste0(form, " + ", paste(variables$covariates, collapse = " + ")) |
||||
| 327 | +180 |
- #'+ } |
||||
| 328 | -+ | |||||
| 181 | +75x |
- #' Constructor for content functions to be used in [`summarize_logistic()`] to summarize+ if (!is.null(variables$interaction)) {
|
||||
| 329 | -+ | |||||
| 182 | +18x |
- #' logistic regression results. This function is a wrapper for [rtables::summarize_row_groups()].+ checkmate::assert_string(variables$interaction) |
||||
| 330 | -+ | |||||
| 183 | +18x |
- #'+ checkmate::assert_subset(variables$interaction, variables$covariates) |
||||
| 331 | -+ | |||||
| 184 | +18x |
- #' @inheritParams argument_convention+ form <- paste0(form, " + ", variables$arm, ":", variables$interaction) |
||||
| 332 | +185 |
- #' @param flag_var (`string`)\cr variable name identifying which row should be used in this+ } |
||||
| 333 | -+ | |||||
| 186 | +75x |
- #' content function.+ if (!is.null(variables$strata)) {
|
||||
| 334 | -+ | |||||
| 187 | +14x |
- #'+ strata_arg <- if (length(variables$strata) > 1) {
|
||||
| 335 | -+ | |||||
| 188 | +7x |
- #' @return A content function.+ paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
|
||||
| 336 | +189 |
- #'+ } else {
|
||||
| 337 | -+ | |||||
| 190 | +7x |
- #' @export+ variables$strata |
||||
| 338 | +191 |
- logistic_summary_by_flag <- function(flag_var, na_str = default_na_str(), .indent_mods = NULL) {
+ } |
||||
| 339 | -10x | +192 | +14x |
- checkmate::assert_string(flag_var)+ form <- paste0(form, "+ strata(", strata_arg, ")")
|
||
| 340 | -10x | +|||||
| 193 | +
- function(lyt) {
+ } |
|||||
| 341 | -10x | +194 | +75x |
- cfun_list <- list(+ formula <- stats::as.formula(form) |
||
| 342 | -10x | +195 | +75x |
- df = cfun_by_flag("df", flag_var, format = "xx.", .indent_mods = .indent_mods),
+ if (is.null(variables$strata)) {
|
||
| 343 | -10x | +196 | +61x |
- estimate = cfun_by_flag("estimate", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
+ stats::glm( |
||
| 344 | -10x | +197 | +61x |
- std_error = cfun_by_flag("std_error", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
+ formula = formula, |
||
| 345 | -10x | +198 | +61x |
- odds_ratio = cfun_by_flag("odds_ratio", flag_var, format = ">999.99", .indent_mods = .indent_mods),
+ data = data, |
||
| 346 | -10x | +199 | +61x |
- ci = cfun_by_flag("ci", flag_var, format = format_extreme_values_ci(2L), .indent_mods = .indent_mods),
+ family = stats::binomial("logit")
|
||
| 347 | -10x | +|||||
| 200 | +
- pvalue = cfun_by_flag("pvalue", flag_var, format = "x.xxxx | (<0.0001)", .indent_mods = .indent_mods)
+ ) |
|||||
| 348 | +201 |
- )+ } else {
|
||||
| 349 | -10x | +202 | +14x |
- summarize_row_groups(+ clogit_with_tryCatch( |
||
| 350 | -10x | +203 | +14x |
- lyt = lyt,+ formula = formula, |
||
| 351 | -10x | +204 | +14x |
- cfun = cfun_list,+ data = data, |
||
| 352 | -10x | +205 | +14x |
- na_str = na_str+ x = TRUE |
||
| 353 | +206 |
) |
||||
| 354 | +207 |
} |
||||
| 355 | +208 |
} |
| 1 | +209 |
- #' Helper functions for tabulating binary response by subgroup+ |
||
| 2 | +210 | ++ |
+ #' Custom tidy method for binomial GLM results+ |
+ |
| 211 |
#' |
|||
| 3 | +212 |
#' @description `r lifecycle::badge("stable")`
|
||
| 4 | +213 |
#' |
||
| 5 | +214 |
- #' Helper functions that tabulate in a data frame statistics such as response rate+ #' Helper method (for [broom::tidy()]) to prepare a data frame from a `glm` object |
||
| 6 | +215 |
- #' and odds ratio for population subgroups.+ #' with `binomial` family. |
||
| 7 | +216 |
#' |
||
| 8 | +217 |
#' @inheritParams argument_convention |
||
| 9 | +218 |
- #' @inheritParams response_subgroups+ #' @param at (`numeric` or `NULL`)\cr optional values for the interaction variable. Otherwise the median is used. |
||
| 10 | +219 |
- #' @param arm (`factor`)\cr the treatment group variable.+ #' @param x (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family. |
||
| 11 | +220 |
#' |
||
| 12 | +221 |
- #' @details Main functionality is to prepare data for use in a layout-creating function.+ #' @return A `data.frame` containing the tidied model. |
||
| 13 | +222 |
#' |
||
| 14 | +223 |
- #' @examples+ #' @method tidy glm |
||
| 15 | +224 |
- #' library(dplyr)+ #' |
||
| 16 | +225 |
- #' library(forcats)+ #' @seealso [h_logistic_regression] for relevant helper functions. |
||
| 17 | +226 |
#' |
||
| 18 | +227 |
- #' adrs <- tern_ex_adrs+ #' @examples |
||
| 19 | +228 |
- #' adrs_labels <- formatters::var_labels(adrs)+ #' library(dplyr) |
||
| 20 | +229 |
- #'+ #' library(broom) |
||
| 21 | +230 |
- #' adrs_f <- adrs %>%+ #' |
||
| 22 | +231 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' adrs_f <- tern_ex_adrs %>% |
||
| 23 | +232 |
- #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 24 | +233 |
- #' droplevels() %>%+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
|
||
| 25 | +234 |
#' mutate( |
||
| 26 | +235 |
- #' # Reorder levels of factor to make the placebo group the reference arm.+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
||
| 27 | +236 |
- #' ARM = fct_relevel(ARM, "B: Placebo"),+ #' RACE = factor(RACE), |
||
| 28 | +237 |
- #' rsp = AVALC == "CR"+ #' SEX = factor(SEX) |
||
| 29 | +238 |
#' ) |
||
| 30 | +239 |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
||
| 31 | +240 |
- #'+ #' mod1 <- fit_logistic( |
||
| 32 | +241 |
- #' @name h_response_subgroups+ #' data = adrs_f, |
||
| 33 | +242 |
- NULL+ #' variables = list( |
||
| 34 | +243 |
-
+ #' response = "Response", |
||
| 35 | +244 |
- #' @describeIn h_response_subgroups Helper to prepare a data frame of binary responses by arm.+ #' arm = "ARMCD", |
||
| 36 | +245 |
- #'+ #' covariates = c("AGE", "RACE")
|
||
| 37 | +246 |
- #' @return+ #' ) |
||
| 38 | +247 |
- #' * `h_proportion_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, and `prop`.+ #' ) |
||
| 39 | +248 |
- #'+ #' mod2 <- fit_logistic( |
||
| 40 | +249 |
- #' @examples+ #' data = adrs_f, |
||
| 41 | +250 |
- #' h_proportion_df(+ #' variables = list( |
||
| 42 | +251 |
- #' c(TRUE, FALSE, FALSE),+ #' response = "Response", |
||
| 43 | +252 |
- #' arm = factor(c("A", "A", "B"), levels = c("A", "B"))
+ #' arm = "ARMCD", |
||
| 44 | +253 |
- #' )+ #' covariates = c("AGE", "RACE"),
|
||
| 45 | +254 |
- #'+ #' interaction = "AGE" |
||
| 46 | +255 |
- #' @export+ #' ) |
||
| 47 | +256 |
- h_proportion_df <- function(rsp, arm) {
- |
- ||
| 48 | -79x | -
- checkmate::assert_logical(rsp)- |
- ||
| 49 | -78x | -
- assert_valid_factor(arm, len = length(rsp))+ #' ) |
||
| 50 | -78x | +|||
| 257 | +
- non_missing_rsp <- !is.na(rsp)+ #' |
|||
| 51 | -78x | +|||
| 258 | +
- rsp <- rsp[non_missing_rsp]+ #' df <- tidy(mod1, conf_level = 0.99) |
|||
| 52 | -78x | +|||
| 259 | +
- arm <- arm[non_missing_rsp]+ #' df2 <- tidy(mod2, conf_level = 0.99) |
|||
| 53 | +260 |
-
+ #' |
||
| 54 | -78x | +|||
| 261 | +
- lst_rsp <- split(rsp, arm)+ #' @export |
|||
| 55 | -78x | +|||
| 262 | +
- lst_results <- Map(function(x, arm) {
+ tidy.glm <- function(x, # nolint |
|||
| 56 | -156x | +|||
| 263 | +
- if (length(x) > 0) {
+ conf_level = 0.95, |
|||
| 57 | -154x | +|||
| 264 | +
- s_prop <- s_proportion(df = x)+ at = NULL, |
|||
| 58 | -154x | +|||
| 265 | +
- data.frame(+ ...) {
|
|||
| 59 | -154x | +266 | +5x |
- arm = arm,+ checkmate::assert_class(x, "glm") |
| 60 | -154x | +267 | +5x |
- n = length(x),+ checkmate::assert_set_equal(x$family$family, "binomial") |
| 61 | -154x | +|||
| 268 | +
- n_rsp = unname(s_prop$n_prop[1]),+ |
|||
| 62 | -154x | +269 | +5x |
- prop = unname(s_prop$n_prop[2]),+ terms_name <- attr(stats::terms(x), "term.labels") |
| 63 | -154x | -
- stringsAsFactors = FALSE- |
- ||
| 64 | -- |
- )- |
- ||
| 65 | -+ | 270 | +5x |
- } else {
+ xs_class <- attr(x$terms, "dataClasses") |
| 66 | -2x | +271 | +5x |
- data.frame(+ interaction <- terms_name[which(!terms_name %in% names(xs_class))] |
| 67 | -2x | +272 | +5x |
- arm = arm,+ df <- if (length(interaction) == 0) {
|
| 68 | +273 | 2x |
- n = 0L,+ h_logistic_simple_terms( |
|
| 69 | +274 | 2x |
- n_rsp = NA,+ x = terms_name, |
|
| 70 | +275 | 2x |
- prop = NA,+ fit_glm = x, |
|
| 71 | +276 | 2x |
- stringsAsFactors = FALSE+ conf_level = conf_level |
|
| 72 | +277 |
- )+ ) |
||
| 73 | +278 |
- }+ } else {
|
||
| 74 | -78x | -
- }, lst_rsp, names(lst_rsp))- |
- ||
| 75 | -+ | 279 | +3x |
-
+ h_logistic_inter_terms( |
| 76 | -78x | +280 | +3x |
- df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE))+ x = terms_name, |
| 77 | -78x | +281 | +3x |
- df$arm <- factor(df$arm, levels = levels(arm))+ fit_glm = x, |
| 78 | -78x | +282 | +3x |
- df+ conf_level = conf_level, |
| 79 | -+ | |||
| 283 | +3x |
- }+ at = at |
||
| 80 | +284 |
-
+ ) |
||
| 81 | +285 |
- #' @describeIn h_response_subgroups Summarizes proportion of binary responses by arm and across subgroups+ } |
||
| 82 | -+ | |||
| 286 | +5x |
- #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and+ for (var in c("variable", "term", "interaction", "reference")) {
|
||
| 83 | -+ | |||
| 287 | +20x |
- #' requires elements `rsp`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies+ df[[var]] <- factor(df[[var]], levels = unique(df[[var]])) |
||
| 84 | +288 |
- #' groupings for `subgroups` variables.+ } |
||
| 85 | -+ | |||
| 289 | +5x |
- #'+ df |
||
| 86 | +290 |
- #' @return+ } |
||
| 87 | +291 |
- #' * `h_proportion_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`,+ |
||
| 88 | +292 |
- #' `var`, `var_label`, and `row_type`.+ #' Logistic regression multivariate column layout function |
||
| 89 | +293 |
#' |
||
| 90 | -- |
- #' @examples- |
- ||
| 91 | -- |
- #' h_proportion_subgroups_df(- |
- ||
| 92 | -- |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
- |
- ||
| 93 | -- |
- #' data = adrs_f- |
- ||
| 94 | +294 |
- #' )+ #' @description `r lifecycle::badge("stable")`
|
||
| 95 | +295 |
#' |
||
| 96 | -- |
- #' # Define groupings for BMRKR2 levels.- |
- ||
| 97 | -- |
- #' h_proportion_subgroups_df(- |
- ||
| 98 | -- |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
- |
- ||
| 99 | -- |
- #' data = adrs_f,- |
- ||
| 100 | +296 |
- #' groups_lists = list(+ #' Layout-creating function which creates a multivariate column layout summarizing logistic |
||
| 101 | +297 |
- #' BMRKR2 = list(+ #' regression results. This function is a wrapper for [rtables::split_cols_by_multivar()]. |
||
| 102 | +298 |
- #' "low" = "LOW",+ #' |
||
| 103 | +299 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' @inheritParams argument_convention |
||
| 104 | +300 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ #' |
||
| 105 | +301 |
- #' )+ #' @return A layout object suitable for passing to further layouting functions. Adding this |
||
| 106 | +302 |
- #' )+ #' function to an `rtable` layout will split the table into columns corresponding to |
||
| 107 | +303 |
- #' )+ #' statistics `df`, `estimate`, `std_error`, `odds_ratio`, `ci`, and `pvalue`. |
||
| 108 | +304 |
#' |
||
| 109 | +305 |
#' @export |
||
| 110 | -- |
- h_proportion_subgroups_df <- function(variables,- |
- ||
| 111 | -- |
- data,- |
- ||
| 112 | -- |
- groups_lists = list(),- |
- ||
| 113 | -- |
- label_all = "All Patients") {
- |
- ||
| 114 | -17x | -
- checkmate::assert_character(variables$rsp)- |
- ||
| 115 | -17x | -
- 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 | -
- checkmate::assert_string(label_all)- |
- ||
| 120 | -- | - - | -||
| 121 | -- |
- # Add All Patients.- |
- ||
| 122 | -17x | -
- result_all <- h_proportion_df(data[[variables$rsp]], data[[variables$arm]])- |
- ||
| 123 | -17x | -
- result_all$subgroup <- label_all- |
- ||
| 124 | -17x | -
- result_all$var <- "ALL"- |
- ||
| 125 | -17x | -
- result_all$var_label <- label_all- |
- ||
| 126 | -17x | -
- result_all$row_type <- "content"- |
- ||
| 127 | +306 |
-
+ logistic_regression_cols <- function(lyt, |
||
| 128 | +307 |
- # Add Subgroups.- |
- ||
| 129 | -17x | -
- if (is.null(variables$subgroups)) {
+ conf_level = 0.95) {
|
||
| 130 | -3x | -
- result_all- |
- ||
| 131 | -+ | 308 | +4x |
- } else {
+ vars <- c("df", "estimate", "std_error", "odds_ratio", "ci", "pvalue")
|
| 132 | -14x | -
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)- |
- ||
| 133 | -+ | 309 | +4x |
-
+ var_labels <- c( |
| 134 | -14x | +310 | +4x |
- l_result <- lapply(l_data, function(grp) {
+ df = "Degrees of Freedom", |
| 135 | -58x | +311 | +4x |
- result <- h_proportion_df(grp$df[[variables$rsp]], grp$df[[variables$arm]])+ estimate = "Parameter Estimate", |
| 136 | -58x | +312 | +4x |
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ std_error = "Standard Error", |
| 137 | -58x | -
- cbind(result, result_labels)- |
- ||
| 138 | -+ | 313 | +4x |
- })+ odds_ratio = "Odds Ratio", |
| 139 | -14x | +314 | +4x |
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ ci = paste("Wald", f_conf_level(conf_level)),
|
| 140 | -14x | +315 | +4x |
- result_subgroups$row_type <- "analysis"+ pvalue = "p-value" |
| 141 | +316 |
-
+ ) |
||
| 142 | -14x | +317 | +4x |
- rbind(+ split_cols_by_multivar( |
| 143 | -14x | +318 | +4x |
- result_all,+ lyt = lyt, |
| 144 | -14x | +319 | +4x |
- result_subgroups+ vars = vars, |
| 145 | -+ | |||
| 320 | +4x |
- )+ varlabels = var_labels |
||
| 146 | +321 |
- }+ ) |
||
| 147 | +322 |
} |
||
| 148 | +323 | |||
| 149 | +324 |
- #' @describeIn h_response_subgroups Helper to prepare a data frame with estimates of+ #' Logistic regression summary table |
||
| 150 | +325 |
- #' the odds ratio between a treatment and a control arm.+ #' |
||
| 151 | +326 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+ |
| 327 |
#' |
|||
| 152 | +328 |
- #' @inheritParams response_subgroups+ #' Constructor for content functions to be used in [`summarize_logistic()`] to summarize |
||
| 153 | +329 |
- #' @param strata_data (`factor`, `data.frame`, or `NULL`)\cr required if stratified analysis is performed.+ #' logistic regression results. This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 154 | +330 |
#' |
||
| 155 | +331 |
- #' @return+ #' @inheritParams argument_convention |
||
| 156 | +332 |
- #' * `h_odds_ratio_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`, and+ #' @param flag_var (`string`)\cr variable name identifying which row should be used in this |
||
| 157 | +333 |
- #' optionally `pval` and `pval_label`.+ #' content function. |
||
| 158 | +334 |
#' |
||
| 159 | +335 |
- #' @examples+ #' @return A content function. |
||
| 160 | +336 |
- #' # Unstratatified analysis.+ #' |
||
| 161 | +337 |
- #' h_odds_ratio_df(+ #' @export |
||
| 162 | +338 |
- #' c(TRUE, FALSE, FALSE, TRUE),+ logistic_summary_by_flag <- function(flag_var, na_str = default_na_str(), .indent_mods = NULL) {
|
||
| 163 | -+ | |||
| 339 | +10x |
- #' arm = factor(c("A", "A", "B", "B"), levels = c("A", "B"))
+ checkmate::assert_string(flag_var) |
||
| 164 | -+ | |||
| 340 | +10x |
- #' )+ function(lyt) {
|
||
| 165 | -+ | |||
| 341 | +10x |
- #'+ cfun_list <- list( |
||
| 166 | -+ | |||
| 342 | +10x |
- #' # Include p-value.+ df = cfun_by_flag("df", flag_var, format = "xx.", .indent_mods = .indent_mods),
|
||
| 167 | -+ | |||
| 343 | +10x |
- #' h_odds_ratio_df(adrs_f$rsp, adrs_f$ARM, method = "chisq")+ estimate = cfun_by_flag("estimate", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
|
||
| 168 | -+ | |||
| 344 | +10x |
- #'+ std_error = cfun_by_flag("std_error", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
|
||
| 169 | -+ | |||
| 345 | +10x |
- #' # Stratatified analysis.+ odds_ratio = cfun_by_flag("odds_ratio", flag_var, format = ">999.99", .indent_mods = .indent_mods),
|
||
| 170 | -+ | |||
| 346 | +10x |
- #' h_odds_ratio_df(+ ci = cfun_by_flag("ci", flag_var, format = format_extreme_values_ci(2L), .indent_mods = .indent_mods),
|
||
| 171 | -+ | |||
| 347 | +10x |
- #' rsp = adrs_f$rsp,+ pvalue = cfun_by_flag("pvalue", flag_var, format = "x.xxxx | (<0.0001)", .indent_mods = .indent_mods)
|
||
| 172 | +348 |
- #' arm = adrs_f$ARM,+ ) |
||
| 173 | -+ | |||
| 349 | +10x |
- #' strata_data = adrs_f[, c("STRATA1", "STRATA2")],
+ summarize_row_groups( |
||
| 174 | -+ | |||
| 350 | +10x |
- #' method = "cmh"+ lyt = lyt, |
||
| 175 | -+ | |||
| 351 | +10x |
- #' )+ cfun = cfun_list, |
||
| 176 | -+ | |||
| 352 | +10x |
- #'+ na_str = na_str |
||
| 177 | +353 |
- #' @export+ ) |
||
| 178 | +354 |
- h_odds_ratio_df <- function(rsp, arm, strata_data = NULL, conf_level = 0.95, method = NULL) {
+ } |
||
| 179 | -84x | +|||
| 355 | +
- assert_valid_factor(arm, n.levels = 2, len = length(rsp))+ } |
| 180 | +1 |
-
+ #' Count the number of patients with a particular event |
||
| 181 | -84x | +|||
| 2 | +
- df_rsp <- data.frame(+ #' |
|||
| 182 | -84x | +|||
| 3 | +
- rsp = rsp,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 183 | -84x | +|||
| 4 | +
- arm = arm+ #' |
|||
| 184 | +5 |
- )+ #' The analyze function [count_patients_with_event()] creates a layout element to calculate patient counts for a |
||
| 185 | +6 |
-
+ #' user-specified set of events. |
||
| 186 | -84x | +|||
| 7 | +
- if (!is.null(strata_data)) {
+ #' |
|||
| 187 | -11x | +|||
| 8 | +
- strata_var <- interaction(strata_data, drop = TRUE)+ #' This function analyzes primary analysis variable `vars` which indicates unique subject identifiers. Events |
|||
| 188 | -11x | +|||
| 9 | +
- strata_name <- "strata"+ #' are defined by the user as a named vector via the `filters` argument, where each name corresponds to a |
|||
| 189 | +10 |
-
+ #' variable and each value is the value(s) that that variable takes for the event. |
||
| 190 | -11x | +|||
| 11 | +
- assert_valid_factor(strata_var, len = nrow(df_rsp))+ #' |
|||
| 191 | +12 |
-
+ #' If there are multiple records with the same event recorded for a patient, only one occurrence is counted. |
||
| 192 | -11x | +|||
| 13 | +
- df_rsp[[strata_name]] <- strata_var+ #' |
|||
| 193 | +14 |
- } else {
+ #' @inheritParams argument_convention |
||
| 194 | -73x | +|||
| 15 | +
- strata_name <- NULL+ #' @param filters (`character`)\cr a character vector specifying the column names and flag variables |
|||
| 195 | +16 |
- }+ #' to be used for counting the number of unique identifiers satisfying such conditions. |
||
| 196 | +17 |
-
+ #' Multiple column names and flags are accepted in this format |
||
| 197 | -84x | +|||
| 18 | +
- l_df <- split(df_rsp, arm)+ #' `c("column_name1" = "flag1", "column_name2" = "flag2")`.
|
|||
| 198 | +19 |
-
+ #' Note that only equality is being accepted as condition. |
||
| 199 | -84x | +|||
| 20 | +
- if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_patients_with_event")`
|
|||
| 200 | +21 |
- # Odds ratio and CI.+ #' to see available statistics for this function. |
||
| 201 | -82x | +|||
| 22 | +
- result_odds_ratio <- s_odds_ratio(+ #' |
|||
| 202 | -82x | +|||
| 23 | +
- df = l_df[[2]],+ #' @seealso [count_patients_with_flags] |
|||
| 203 | -82x | +|||
| 24 | +
- .var = "rsp",+ #' |
|||
| 204 | -82x | +|||
| 25 | +
- .ref_group = l_df[[1]],+ #' @name count_patients_with_event |
|||
| 205 | -82x | +|||
| 26 | +
- .in_ref_col = FALSE,+ #' @order 1 |
|||
| 206 | -82x | +|||
| 27 | +
- .df_row = df_rsp,+ NULL |
|||
| 207 | -82x | +|||
| 28 | +
- variables = list(arm = "arm", strata = strata_name),+ |
|||
| 208 | -82x | +|||
| 29 | +
- conf_level = conf_level+ #' @describeIn count_patients_with_event Statistics function which counts the number of patients for which |
|||
| 209 | +30 |
- )+ #' the defined event has occurred. |
||
| 210 | +31 |
-
+ #' |
||
| 211 | -82x | +|||
| 32 | +
- df <- data.frame(+ #' @inheritParams analyze_variables |
|||
| 212 | +33 |
- # Dummy column needed downstream to create a nested header.+ #' @param .var (`string`)\cr name of the column that contains the unique identifier. |
||
| 213 | -82x | +|||
| 34 | +
- arm = " ",+ #' |
|||
| 214 | -82x | +|||
| 35 | +
- n_tot = unname(result_odds_ratio$n_tot["n_tot"]),+ #' @return |
|||
| 215 | -82x | +|||
| 36 | +
- or = unname(result_odds_ratio$or_ci["est"]),+ #' * `s_count_patients_with_event()` returns the count and fraction of unique identifiers with the defined event. |
|||
| 216 | -82x | +|||
| 37 | +
- lcl = unname(result_odds_ratio$or_ci["lcl"]),+ #' |
|||
| 217 | -82x | +|||
| 38 | +
- ucl = unname(result_odds_ratio$or_ci["ucl"]),+ #' @examples |
|||
| 218 | -82x | +|||
| 39 | +
- conf_level = conf_level,+ #' # `s_count_patients_with_event()` |
|||
| 219 | -82x | +|||
| 40 | +
- stringsAsFactors = FALSE+ #' |
|||
| 220 | +41 |
- )+ #' s_count_patients_with_event( |
||
| 221 | +42 |
-
+ #' tern_ex_adae, |
||
| 222 | -82x | +|||
| 43 | +
- if (!is.null(method)) {
+ #' .var = "SUBJID", |
|||
| 223 | +44 |
- # Test for difference.+ #' filters = c("TRTEMFL" = "Y")
|
||
| 224 | -44x | +|||
| 45 | +
- result_test <- s_test_proportion_diff(+ #' ) |
|||
| 225 | -44x | +|||
| 46 | +
- df = l_df[[2]],+ #' |
|||
| 226 | -44x | +|||
| 47 | +
- .var = "rsp",+ #' s_count_patients_with_event( |
|||
| 227 | -44x | +|||
| 48 | +
- .ref_group = l_df[[1]],+ #' tern_ex_adae, |
|||
| 228 | -44x | +|||
| 49 | +
- .in_ref_col = FALSE,+ #' .var = "SUBJID", |
|||
| 229 | -44x | +|||
| 50 | +
- variables = list(strata = strata_name),+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL")
|
|||
| 230 | -44x | +|||
| 51 | +
- method = method+ #' ) |
|||
| 231 | +52 |
- )+ #' |
||
| 232 | +53 |
-
+ #' s_count_patients_with_event( |
||
| 233 | -44x | +|||
| 54 | +
- df$pval <- as.numeric(result_test$pval)+ #' tern_ex_adae, |
|||
| 234 | -44x | +|||
| 55 | +
- df$pval_label <- obj_label(result_test$pval)+ #' .var = "SUBJID", |
|||
| 235 | +56 |
- }+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
|
||
| 236 | +57 |
-
+ #' denom = "N_col", |
||
| 237 | +58 |
- # In those cases cannot go through the model so will obtain n_tot from data.+ #' .N_col = 456 |
||
| 238 | +59 |
- } else if (+ #' ) |
||
| 239 | -2x | +|||
| 60 | +
- (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) ||+ #' |
|||
| 240 | -2x | +|||
| 61 | +
- (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0)+ #' @export |
|||
| 241 | +62 |
- ) {
+ s_count_patients_with_event <- function(df, |
||
| 242 | -2x | +|||
| 63 | +
- df <- data.frame(+ .var, |
|||
| 243 | +64 |
- # Dummy column needed downstream to create a nested header.+ filters, |
||
| 244 | -2x | +|||
| 65 | +
- arm = " ",+ .N_col, # nolint |
|||
| 245 | -2x | +|||
| 66 | +
- n_tot = sum(stats::complete.cases(df_rsp)),+ .N_row, # nolint |
|||
| 246 | -2x | +|||
| 67 | +
- or = NA,+ denom = c("n", "N_row", "N_col")) {
|
|||
| 247 | -2x | +68 | +32x |
- lcl = NA,+ col_names <- names(filters) |
| 248 | -2x | +69 | +32x |
- ucl = NA,+ filter_values <- filters |
| 249 | -2x | +|||
| 70 | +
- conf_level = conf_level,+ |
|||
| 250 | -2x | +71 | +32x |
- stringsAsFactors = FALSE+ checkmate::assert_subset(col_names, colnames(df)) |
| 251 | +72 |
- )+ |
||
| 252 | -2x | +73 | +32x |
- if (!is.null(method)) {
+ temp <- Map( |
| 253 | -2x | +74 | +32x |
- df$pval <- NA+ function(x, y) which(df[[x]] == y), |
| 254 | -2x | -
- df$pval_label <- NA- |
- ||
| 255 | -- |
- }- |
- ||
| 256 | -+ | 75 | +32x |
- } else {
+ col_names, |
| 257 | -! | +|||
| 76 | +32x |
- df <- data.frame(+ filter_values |
||
| 258 | +77 |
- # Dummy column needed downstream to create a nested header.+ ) |
||
| 259 | -! | +|||
| 78 | +32x |
- arm = " ",+ position_satisfy_filters <- Reduce(intersect, temp) |
||
| 260 | -! | +|||
| 79 | +32x |
- n_tot = 0L,+ id_satisfy_filters <- as.character(unique(df[position_satisfy_filters, ][[.var]])) |
||
| 261 | -! | +|||
| 80 | +32x |
- or = NA,+ result <- s_count_values( |
||
| 262 | -! | +|||
| 81 | +32x |
- lcl = NA,+ as.character(unique(df[[.var]])), |
||
| 263 | -! | +|||
| 82 | +32x |
- ucl = NA,+ id_satisfy_filters, |
||
| 264 | -! | +|||
| 83 | +32x |
- conf_level = conf_level,+ denom = denom, |
||
| 265 | -! | +|||
| 84 | +32x |
- stringsAsFactors = FALSE+ .N_col = .N_col, |
||
| 266 | -+ | |||
| 85 | +32x |
- )+ .N_row = .N_row |
||
| 267 | +86 | - - | -||
| 268 | -! | -
- if (!is.null(method)) {
- |
- ||
| 269 | -! | -
- df$pval <- NA+ ) |
||
| 270 | -! | +|||
| 87 | +32x |
- df$pval_label <- NA+ result |
||
| 271 | +88 |
- }+ } |
||
| 272 | +89 |
- }+ |
||
| 273 | +90 |
-
+ #' @describeIn count_patients_with_event Formatted analysis function which is used as `afun` |
||
| 274 | -84x | +|||
| 91 | +
- df+ #' in `count_patients_with_event()`. |
|||
| 275 | +92 |
- }+ #' |
||
| 276 | +93 |
-
+ #' @return |
||
| 277 | +94 |
- #' @describeIn h_response_subgroups Summarizes estimates of the odds ratio between a treatment and a control+ #' * `a_count_patients_with_event()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 278 | +95 |
- #' arm across subgroups in a data frame. `variables` corresponds to the names of variables found in+ #' |
||
| 279 | +96 |
- #' `data`, passed as a named list and requires elements `rsp`, `arm` and optionally `subgroups`+ #' @examples |
||
| 280 | +97 |
- #' and `strata`. `groups_lists` optionally specifies groupings for `subgroups` variables.+ #' # `a_count_patients_with_event()` |
||
| 281 | +98 |
#' |
||
| 282 | +99 |
- #' @return+ #' a_count_patients_with_event( |
||
| 283 | +100 |
- #' * `h_odds_ratio_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`,+ #' tern_ex_adae, |
||
| 284 | +101 |
- #' `conf_level`, `subgroup`, `var`, `var_label`, and `row_type`.+ #' .var = "SUBJID", |
||
| 285 | +102 |
- #'+ #' filters = c("TRTEMFL" = "Y"),
|
||
| 286 | +103 |
- #' @examples+ #' .N_col = 100, |
||
| 287 | +104 |
- #' # Unstratified analysis.+ #' .N_row = 100 |
||
| 288 | +105 |
- #' h_odds_ratio_subgroups_df(+ #' ) |
||
| 289 | +106 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ #' |
||
| 290 | +107 |
- #' data = adrs_f+ #' @export |
||
| 291 | +108 |
- #' )+ a_count_patients_with_event <- make_afun( |
||
| 292 | +109 |
- #'+ s_count_patients_with_event, |
||
| 293 | +110 |
- #' # Stratified analysis.+ .formats = c(count_fraction = format_count_fraction_fixed_dp) |
||
| 294 | +111 |
- #' h_odds_ratio_subgroups_df(+ ) |
||
| 295 | +112 |
- #' variables = list(+ |
||
| 296 | +113 |
- #' rsp = "rsp",+ #' @describeIn count_patients_with_event Layout-creating function which can take statistics function |
||
| 297 | +114 |
- #' arm = "ARM",+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 298 | +115 |
- #' subgroups = c("SEX", "BMRKR2"),
+ #' |
||
| 299 | +116 |
- #' strata = c("STRATA1", "STRATA2")
+ #' @return |
||
| 300 | +117 |
- #' ),+ #' * `count_patients_with_event()` returns a layout object suitable for passing to further layouting functions, |
||
| 301 | +118 |
- #' data = adrs_f+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 302 | +119 |
- #' )+ #' the statistics from `s_count_patients_with_event()` to the table layout. |
||
| 303 | +120 |
#' |
||
| 304 | +121 |
- #' # Define groupings of BMRKR2 levels.+ #' @examples |
||
| 305 | +122 |
- #' h_odds_ratio_subgroups_df(+ #' # `count_patients_with_event()` |
||
| 306 | +123 |
- #' variables = list(+ #' |
||
| 307 | +124 |
- #' rsp = "rsp",+ #' lyt <- basic_table() %>% |
||
| 308 | +125 |
- #' arm = "ARM",+ #' split_cols_by("ARM") %>%
|
||
| 309 | +126 |
- #' subgroups = c("SEX", "BMRKR2")
+ #' add_colcounts() %>% |
||
| 310 | +127 |
- #' ),+ #' count_values( |
||
| 311 | +128 |
- #' data = adrs_f,+ #' "STUDYID", |
||
| 312 | +129 |
- #' groups_lists = list(+ #' values = "AB12345", |
||
| 313 | +130 |
- #' BMRKR2 = list(+ #' .stats = "count", |
||
| 314 | +131 |
- #' "low" = "LOW",+ #' .labels = c(count = "Total AEs") |
||
| 315 | +132 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' ) %>% |
||
| 316 | +133 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ #' count_patients_with_event( |
||
| 317 | +134 |
- #' )+ #' "SUBJID", |
||
| 318 | +135 |
- #' )+ #' filters = c("TRTEMFL" = "Y"),
|
||
| 319 | +136 |
- #' )+ #' .labels = c(count_fraction = "Total number of patients with at least one adverse event"), |
||
| 320 | +137 |
- #'+ #' table_names = "tbl_all" |
||
| 321 | +138 |
- #' @export+ #' ) %>% |
||
| 322 | +139 |
- h_odds_ratio_subgroups_df <- function(variables,+ #' count_patients_with_event( |
||
| 323 | +140 |
- data,+ #' "SUBJID", |
||
| 324 | +141 |
- groups_lists = list(),+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
|
||
| 325 | +142 |
- conf_level = 0.95,+ #' .labels = c(count_fraction = "Total number of patients with fatal AEs"), |
||
| 326 | +143 |
- method = NULL,+ #' table_names = "tbl_fatal" |
||
| 327 | +144 |
- label_all = "All Patients") {
+ #' ) %>% |
||
| 328 | -18x | +|||
| 145 | +
- if ("strat" %in% names(variables)) {
+ #' count_patients_with_event( |
|||
| 329 | -! | +|||
| 146 | +
- warning(+ #' "SUBJID", |
|||
| 330 | -! | +|||
| 147 | +
- "Warning: the `strat` element name of the `variables` list argument to `h_odds_ratio_subgroups_df() ",+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL", "AEREL" = "Y"),
|
|||
| 331 | -! | +|||
| 148 | +
- "was deprecated in tern 0.9.4.\n ",+ #' .labels = c(count_fraction = "Total number of patients with related fatal AEs"), |
|||
| 332 | -! | +|||
| 149 | +
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ #' .indent_mods = c(count_fraction = 2L), |
|||
| 333 | +150 |
- )+ #' table_names = "tbl_rel_fatal" |
||
| 334 | -! | +|||
| 151 | +
- variables[["strata"]] <- variables[["strat"]]+ #' ) |
|||
| 335 | +152 |
- }+ #' |
||
| 336 | +153 |
-
+ #' build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl) |
||
| 337 | -18x | +|||
| 154 | +
- checkmate::assert_character(variables$rsp)+ #' |
|||
| 338 | -18x | +|||
| 155 | +
- checkmate::assert_character(variables$arm)+ #' @export |
|||
| 339 | -18x | +|||
| 156 | +
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ #' @order 2 |
|||
| 340 | -18x | +|||
| 157 | +
- checkmate::assert_character(variables$strata, null.ok = TRUE)+ count_patients_with_event <- function(lyt, |
|||
| 341 | -18x | +|||
| 158 | +
- assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ vars, |
|||
| 342 | -18x | +|||
| 159 | +
- assert_df_with_variables(data, variables)+ filters, |
|||
| 343 | -18x | +|||
| 160 | +
- checkmate::assert_string(label_all)+ riskdiff = FALSE, |
|||
| 344 | +161 |
-
+ na_str = default_na_str(), |
||
| 345 | -18x | +|||
| 162 | +
- strata_data <- if (is.null(variables$strata)) {
+ nested = TRUE, |
|||
| 346 | -16x | +|||
| 163 | +
- NULL+ ..., |
|||
| 347 | +164 |
- } else {
+ table_names = vars, |
||
| 348 | -2x | +|||
| 165 | +
- data[, variables$strata, drop = FALSE]+ .stats = "count_fraction", |
|||
| 349 | +166 |
- }+ .formats = NULL, |
||
| 350 | +167 |
-
+ .labels = NULL, |
||
| 351 | +168 |
- # Add All Patients.+ .indent_mods = NULL) {
|
||
| 352 | -18x | +169 | +7x |
- result_all <- h_odds_ratio_df(+ checkmate::assert_flag(riskdiff) |
| 353 | -18x | +|||
| 170 | +
- rsp = data[[variables$rsp]],+ |
|||
| 354 | -18x | +171 | +7x |
- arm = data[[variables$arm]],+ s_args <- list(filters = filters, ...) |
| 355 | -18x | +|||
| 172 | +
- strata_data = strata_data,+ |
|||
| 356 | -18x | +173 | +7x |
- conf_level = conf_level,+ afun <- make_afun( |
| 357 | -18x | +174 | +7x |
- method = method+ a_count_patients_with_event, |
| 358 | -+ | |||
| 175 | +7x |
- )+ .stats = .stats, |
||
| 359 | -18x | +176 | +7x |
- result_all$subgroup <- label_all+ .formats = .formats, |
| 360 | -18x | +177 | +7x |
- result_all$var <- "ALL"+ .labels = .labels, |
| 361 | -18x | +178 | +7x |
- result_all$var_label <- label_all+ .indent_mods = .indent_mods |
| 362 | -18x | +|||
| 179 | +
- result_all$row_type <- "content"+ ) |
|||
| 363 | +180 | |||
| 364 | -18x | +181 | +7x |
- if (is.null(variables$subgroups)) {
+ extra_args <- if (isFALSE(riskdiff)) {
|
| 365 | -3x | +182 | +5x |
- result_all+ s_args |
| 366 | +183 |
} else {
|
||
| 367 | -15x | +184 | +2x |
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ list( |
| 368 | -+ | |||
| 185 | +2x |
-
+ afun = list("s_count_patients_with_event" = afun),
|
||
| 369 | -15x | +186 | +2x |
- l_result <- lapply(l_data, function(grp) {
+ .stats = .stats, |
| 370 | -62x | +187 | +2x |
- grp_strata_data <- if (is.null(variables$strata)) {
+ .indent_mods = .indent_mods, |
| 371 | -54x | +188 | +2x |
- NULL+ s_args = s_args |
| 372 | +189 |
- } else {
- |
- ||
| 373 | -8x | -
- grp$df[, variables$strata, drop = FALSE]+ ) |
||
| 374 | +190 |
- }+ } |
||
| 375 | +191 | |||
| 376 | -62x | -
- result <- h_odds_ratio_df(- |
- ||
| 377 | -62x | -
- rsp = grp$df[[variables$rsp]],- |
- ||
| 378 | -62x | -
- arm = grp$df[[variables$arm]],- |
- ||
| 379 | -62x | -
- strata_data = grp_strata_data,- |
- ||
| 380 | -62x | +192 | +7x |
- conf_level = conf_level,+ analyze( |
| 381 | -62x | -
- method = method- |
- ||
| 382 | -+ | 193 | +7x |
- )+ lyt, |
| 383 | -62x | +194 | +7x |
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ vars, |
| 384 | -62x | -
- cbind(result, result_labels)- |
- ||
| 385 | -- |
- })- |
- ||
| 386 | -+ | 195 | +7x |
-
+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff), |
| 387 | -15x | +196 | +7x |
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ na_str = na_str, |
| 388 | -15x | -
- result_subgroups$row_type <- "analysis"- |
- ||
| 389 | -+ | 197 | +7x |
-
+ nested = nested, |
| 390 | -15x | +198 | +7x |
- rbind(+ extra_args = extra_args, |
| 391 | -15x | +199 | +7x |
- result_all,+ show_labels = ifelse(length(vars) > 1, "visible", "hidden"), |
| 392 | -15x | -
- result_subgroups- |
- ||
| 393 | -+ | 200 | +7x |
- )+ table_names = table_names |
| 394 | +201 |
- }+ ) |
||
| 395 | +202 |
}@@ -117222,14 +117138,14 @@ tern coverage - 95.64% |
| 1 |
- #' Missing data+ #' Create a STEP graph |
||
| 5 |
- #' Substitute missing data with a string or factor level.+ #' Based on the STEP results, creates a `ggplot` graph showing the estimated HR or OR |
||
| 6 |
- #'+ #' along the continuous biomarker value subgroups. |
||
| 7 |
- #' @param x (`factor` or `character`)\cr values for which any missing values should be substituted.+ #' |
||
| 8 |
- #' @param label (`string`)\cr string that missing data should be replaced with.+ #' @param df (`tibble`)\cr result of [tidy.step()]. |
||
| 9 |
- #'+ #' @param use_percentile (`flag`)\cr whether to use percentiles for the x axis or actual |
||
| 10 |
- #' @return `x` with any `NA` values substituted by `label`.+ #' biomarker values. |
||
| 11 |
- #'+ #' @param est (named `list`)\cr `col` and `lty` settings for estimate line. |
||
| 12 |
- #' @examples+ #' @param ci_ribbon (named `list` or `NULL`)\cr `fill` and `alpha` settings for the confidence interval |
||
| 13 |
- #' explicit_na(c(NA, "a", "b"))+ #' ribbon area, or `NULL` to not plot a CI ribbon. |
||
| 14 |
- #' is.na(explicit_na(c(NA, "a", "b")))+ #' @param col (`character`)\cr color(s). |
||
| 16 |
- #' explicit_na(factor(c(NA, "a", "b")))+ #' @return A `ggplot` STEP graph. |
||
| 17 |
- #' is.na(explicit_na(factor(c(NA, "a", "b"))))+ #' |
||
| 18 |
- #'+ #' @seealso Custom tidy method [tidy.step()]. |
||
| 19 |
- #' explicit_na(sas_na(c("a", "")))
+ #' |
||
| 20 |
- #'+ #' @examples |
||
| 21 |
- #' @export+ #' library(nestcolor) |
||
| 22 |
- explicit_na <- function(x, label = "<Missing>") {
+ #' library(survival) |
||
| 23 | -254x | +
- checkmate::assert_string(label)+ #' lung$sex <- factor(lung$sex) |
|
| 24 |
-
+ #' |
||
| 25 | -254x | +
- if (is.factor(x)) {
+ #' # Survival example. |
|
| 26 | -151x | +
- x <- forcats::fct_na_value_to_level(x, label)+ #' vars <- list( |
|
| 27 | -151x | +
- forcats::fct_drop(x, only = label)+ #' time = "time", |
|
| 28 | -103x | +
- } else if (is.character(x)) {
+ #' event = "status", |
|
| 29 | -103x | +
- x[is.na(x)] <- label+ #' arm = "sex", |
|
| 30 | -103x | +
- x+ #' biomarker = "age" |
|
| 31 |
- } else {
+ #' ) |
||
| 32 | -! | +
- stop("only factors and character vectors allowed")
+ #' |
|
| 33 |
- }+ #' step_matrix <- fit_survival_step( |
||
| 34 |
- }+ #' variables = vars, |
||
| 35 |
-
+ #' data = lung, |
||
| 36 |
- #' Convert strings to `NA`+ #' control = c(control_coxph(), control_step(num_points = 10, degree = 2)) |
||
| 37 |
- #'+ #' ) |
||
| 38 |
- #' @description `r lifecycle::badge("stable")`
+ #' step_data <- broom::tidy(step_matrix) |
||
| 40 |
- #' SAS imports missing data as empty strings or strings with whitespaces only. This helper function can be used to+ #' # Default plot. |
||
| 41 |
- #' convert these values to `NA`s.+ #' g_step(step_data) |
||
| 43 |
- #' @inheritParams explicit_na+ #' # Add the reference 1 horizontal line. |
||
| 44 |
- #' @param empty (`flag`)\cr if `TRUE`, empty strings get replaced by `NA`.+ #' library(ggplot2) |
||
| 45 |
- #' @param whitespaces (`flag`)\cr if `TRUE`, strings made from only whitespaces get replaced with `NA`.+ #' g_step(step_data) + |
||
| 46 |
- #'+ #' ggplot2::geom_hline(ggplot2::aes(yintercept = 1), linetype = 2) |
||
| 47 |
- #' @return `x` with `""` and/or whitespace-only values substituted by `NA`, depending on the values of+ #' |
||
| 48 |
- #' `empty` and `whitespaces`.+ #' # Use actual values instead of percentiles, different color for estimate and no CI, |
||
| 49 |
- #'+ #' # use log scale for y axis. |
||
| 50 |
- #' @examples+ #' g_step( |
||
| 51 |
- #' sas_na(c("1", "", " ", " ", "b"))
+ #' step_data, |
||
| 52 |
- #' sas_na(factor(c("", " ", "b")))
+ #' use_percentile = FALSE, |
||
| 53 |
- #'+ #' est = list(col = "blue", lty = 1), |
||
| 54 |
- #' is.na(sas_na(c("1", "", " ", " ", "b")))
+ #' ci_ribbon = NULL |
||
| 55 |
- #'+ #' ) + scale_y_log10() |
||
| 56 | - |
- #' @export- |
- |
| 57 | -- |
- sas_na <- function(x, empty = TRUE, whitespaces = TRUE) {
- |
- |
| 58 | -243x | -
- checkmate::assert_flag(empty)- |
- |
| 59 | -243x | -
- checkmate::assert_flag(whitespaces)- |
- |
| 60 | -- | - - | -|
| 61 | -243x | -
- if (is.factor(x)) {
- |
- |
| 62 | -135x | -
- empty_levels <- levels(x) == ""- |
- |
| 63 | -11x | -
- if (empty && any(empty_levels)) levels(x)[empty_levels] <- NA- |
- |
| 64 | -- | - - | -|
| 65 | -135x | -
- ws_levels <- grepl("^\\s+$", levels(x))
- |
- |
| 66 | -! | -
- if (whitespaces && any(ws_levels)) levels(x)[ws_levels] <- NA- |
- |
| 67 | -- | - - | -|
| 68 | -135x | -
- x- |
- |
| 69 | -108x | -
- } else if (is.character(x)) {
- |
- |
| 70 | -108x | -
- if (empty) x[x == ""] <- NA_character_- |
- |
| 71 | -- | - - | -|
| 72 | -108x | -
- if (whitespaces) x[grepl("^\\s+$", x)] <- NA_character_
- |
- |
| 73 | -- | - - | -|
| 74 | -108x | -
- x- |
- |
| 75 | -- |
- } else {
- |
- |
| 76 | -! | -
- stop("only factors and character vectors allowed")
- |
- |
| 77 | -- |
- }- |
- |
| 78 | -- |
- }- |
-
| 1 | -- |
- #' Helper function to create a new SMQ variable in ADAE by stacking SMQ and/or CQ records.- |
- ||
| 2 | -- |
- #'- |
- ||
| 3 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- ||
| 4 | -
#' |
|||
| 5 | +57 |
- #' Helper function to create a new SMQ variable in ADAE that consists of all adverse events belonging to+ #' # Adding another curve based on additional column. |
||
| 6 | +58 |
- #' selected Standardized/Customized queries. The new dataset will only contain records of the adverse events+ #' step_data$extra <- exp(step_data$`Percentile Center`) |
||
| 7 | +59 |
- #' belonging to any of the selected baskets. Remember that `na_str` must match the needed pre-processing+ #' g_step(step_data) + |
||
| 8 | +60 |
- #' done with [df_explicit_na()] to have the desired output.+ #' ggplot2::geom_line(ggplot2::aes(y = extra), linetype = 2, color = "green") |
||
| 9 | +61 |
#' |
||
| 10 | -- |
- #' @inheritParams argument_convention- |
- ||
| 11 | -- |
- #' @param baskets (`character`)\cr variable names of the selected Standardized/Customized queries.- |
- ||
| 12 | -- |
- #' @param smq_varlabel (`string`)\cr a label for the new variable created.- |
- ||
| 13 | -- |
- #' @param keys (`character`)\cr names of the key variables to be returned along with the new variable created.- |
- ||
| 14 | +62 |
- #' @param aag_summary (`data.frame`)\cr containing the SMQ baskets and the levels of interest for the final SMQ+ #' # Response example. |
||
| 15 | +63 |
- #' variable. This is useful when there are some levels of interest that are not observed in the `df` dataset.+ #' vars <- list( |
||
| 16 | +64 |
- #' The two columns of this dataset should be named `basket` and `basket_name`.+ #' response = "status", |
||
| 17 | +65 |
- #'+ #' arm = "sex", |
||
| 18 | +66 |
- #' @return A `data.frame` with variables in `keys` taken from `df` and new variable SMQ containing+ #' biomarker = "age" |
||
| 19 | +67 |
- #' records belonging to the baskets selected via the `baskets` argument.+ #' ) |
||
| 20 | +68 |
#' |
||
| 21 | -- |
- #' @examples- |
- ||
| 22 | -- |
- #' adae <- tern_ex_adae[1:20, ] %>% df_explicit_na()- |
- ||
| 23 | -- |
- #' h_stack_by_baskets(df = adae)- |
- ||
| 24 | +69 |
- #'+ #' step_matrix <- fit_rsp_step( |
||
| 25 | +70 |
- #' aag <- data.frame(+ #' variables = vars, |
||
| 26 | +71 |
- #' NAMVAR = c("CQ01NAM", "CQ02NAM", "SMQ01NAM", "SMQ02NAM"),
+ #' data = lung, |
||
| 27 | +72 |
- #' REFNAME = c(+ #' control = c( |
||
| 28 | +73 |
- #' "D.2.1.5.3/A.1.1.1.1 aesi", "X.9.9.9.9/Y.8.8.8.8 aesi",+ #' control_logistic(response_definition = "I(response == 2)"), |
||
| 29 | +74 |
- #' "C.1.1.1.3/B.2.2.3.1 aesi", "C.1.1.1.3/B.3.3.3.3 aesi"+ #' control_step() |
||
| 30 | +75 |
- #' ),+ #' ) |
||
| 31 | +76 |
- #' SCOPE = c("", "", "BROAD", "BROAD"),
+ #' ) |
||
| 32 | +77 |
- #' stringsAsFactors = FALSE+ #' step_data <- broom::tidy(step_matrix) |
||
| 33 | +78 |
- #' )+ #' g_step(step_data) |
||
| 34 | +79 |
#' |
||
| 35 | +80 |
- #' basket_name <- character(nrow(aag))+ #' @export |
||
| 36 | +81 |
- #' cq_pos <- grep("^(CQ).+NAM$", aag$NAMVAR)
+ g_step <- function(df, |
||
| 37 | +82 |
- #' smq_pos <- grep("^(SMQ).+NAM$", aag$NAMVAR)
+ use_percentile = "Percentile Center" %in% names(df), |
||
| 38 | +83 |
- #' basket_name[cq_pos] <- aag$REFNAME[cq_pos]+ est = list(col = "blue", lty = 1), |
||
| 39 | +84 |
- #' basket_name[smq_pos] <- paste0(+ ci_ribbon = list(fill = getOption("ggplot2.discrete.colour")[1], alpha = 0.5),
|
||
| 40 | +85 |
- #' aag$REFNAME[smq_pos], "(", aag$SCOPE[smq_pos], ")"
+ col = getOption("ggplot2.discrete.colour")) {
|
||
| 41 | -+ | |||
| 86 | +2x |
- #' )+ checkmate::assert_tibble(df) |
||
| 42 | -+ | |||
| 87 | +2x |
- #'+ checkmate::assert_flag(use_percentile) |
||
| 43 | -+ | |||
| 88 | +2x |
- #' aag_summary <- data.frame(+ checkmate::assert_character(col, null.ok = TRUE) |
||
| 44 | -+ | |||
| 89 | +2x |
- #' basket = aag$NAMVAR,+ checkmate::assert_list(est, names = "named") |
||
| 45 | -+ | |||
| 90 | +2x |
- #' basket_name = basket_name,+ checkmate::assert_list(ci_ribbon, names = "named", null.ok = TRUE) |
||
| 46 | +91 |
- #' stringsAsFactors = TRUE+ |
||
| 47 | -+ | |||
| 92 | +2x |
- #' )+ x_var <- ifelse(use_percentile, "Percentile Center", "Interval Center") |
||
| 48 | -+ | |||
| 93 | +2x |
- #'+ df$x <- df[[x_var]] |
||
| 49 | -+ | |||
| 94 | +2x |
- #' result <- h_stack_by_baskets(df = adae, aag_summary = aag_summary)+ attrs <- attributes(df) |
||
| 50 | -+ | |||
| 95 | +2x |
- #' all(levels(aag_summary$basket_name) %in% levels(result$SMQ))+ df$y <- df[[attrs$estimate]] |
||
| 51 | +96 |
- #'+ |
||
| 52 | +97 |
- #' h_stack_by_baskets(+ # Set legend names. To be modified also at call level |
||
| 53 | -+ | |||
| 98 | +2x |
- #' df = adae,+ legend_names <- c("Estimate", "CI 95%")
|
||
| 54 | +99 |
- #' aag_summary = NULL,+ |
||
| 55 | -+ | |||
| 100 | +2x |
- #' keys = c("STUDYID", "USUBJID", "AEDECOD", "ARM"),
+ p <- ggplot2::ggplot(df, ggplot2::aes(x = .data[["x"]], y = .data[["y"]])) |
||
| 56 | +101 |
- #' baskets = "SMQ01NAM"+ |
||
| 57 | -+ | |||
| 102 | +2x |
- #' )+ if (!is.null(col)) {
|
||
| 58 | -+ | |||
| 103 | +2x |
- #'+ p <- p + |
||
| 59 | -+ | |||
| 104 | +2x |
- #' @export+ ggplot2::scale_color_manual(values = col) |
||
| 60 | +105 |
- h_stack_by_baskets <- function(df,+ } |
||
| 61 | +106 |
- baskets = grep("^(SMQ|CQ).+NAM$", names(df), value = TRUE),
+
|
||
| 62 | -+ | |||
| 107 | +2x |
- smq_varlabel = "Standardized MedDRA Query",+ if (!is.null(ci_ribbon)) {
|
||
| 63 | -+ | |||
| 108 | +1x |
- keys = c("STUDYID", "USUBJID", "ASTDTM", "AEDECOD", "AESEQ"),
+ if (is.null(ci_ribbon$fill)) {
|
||
| 64 | -+ | |||
| 109 | +! |
- aag_summary = NULL,+ ci_ribbon$fill <- "lightblue" |
||
| 65 | +110 |
- na_str = "<Missing>") {
+ } |
||
| 66 | -5x | +111 | +1x |
- smq_nam <- baskets[startsWith(baskets, "SMQ")]+ p <- p + ggplot2::geom_ribbon( |
| 67 | -+ | |||
| 112 | +1x |
- # SC corresponding to NAM+ ggplot2::aes( |
||
| 68 | -5x | +113 | +1x |
- smq_sc <- gsub(pattern = "NAM", replacement = "SC", x = smq_nam, fixed = TRUE)+ ymin = .data[["ci_lower"]], ymax = .data[["ci_upper"]], |
| 69 | -5x | +114 | +1x |
- smq <- stats::setNames(smq_sc, smq_nam)+ fill = legend_names[2] |
| 70 | +115 |
-
+ ), |
||
| 71 | -5x | +116 | +1x |
- checkmate::assert_character(baskets)+ alpha = ci_ribbon$alpha |
| 72 | -5x | +|||
| 117 | +
- checkmate::assert_string(smq_varlabel)+ ) + |
|||
| 73 | -5x | +118 | +1x |
- checkmate::assert_data_frame(df)+ scale_fill_manual( |
| 74 | -5x | +119 | +1x |
- checkmate::assert_true(all(startsWith(baskets, "SMQ") | startsWith(baskets, "CQ")))+ name = "", values = c("CI 95%" = ci_ribbon$fill)
|
| 75 | -4x | +|||
| 120 | +
- checkmate::assert_true(all(endsWith(baskets, "NAM")))+ ) |
|||
| 76 | -3x | +|||
| 121 | +
- checkmate::assert_subset(baskets, names(df))+ } |
|||
| 77 | -3x | +122 | +2x |
- checkmate::assert_subset(keys, names(df))+ suppressMessages(p <- p + |
| 78 | -3x | +123 | +2x |
- checkmate::assert_subset(smq_sc, names(df))+ ggplot2::geom_line( |
| 79 | -3x | -
- checkmate::assert_string(na_str)- |
- ||
| 80 | -+ | 124 | +2x |
-
+ ggplot2::aes(y = .data[["y"]], color = legend_names[1]), |
| 81 | -3x | +125 | +2x |
- if (!is.null(aag_summary)) {
+ linetype = est$lty |
| 82 | -1x | +|||
| 126 | +
- assert_df_with_variables(+ ) + |
|||
| 83 | -1x | +127 | +2x |
- df = aag_summary,+ scale_colour_manual( |
| 84 | -1x | +128 | +2x |
- variables = list(val = c("basket", "basket_name"))
+ name = "", values = c("Estimate" = "blue")
|
| 85 | +129 |
- )+ )) |
||
| 86 | +130 |
- # Warning in case there is no match between `aag_summary$basket` and `baskets` argument.+ |
||
| 87 | -+ | |||
| 131 | +2x |
- # Honestly, I think those should completely match. Target baskets should be the same.+ p <- p + ggplot2::labs(x = attrs$biomarker, y = attrs$estimate) |
||
| 88 | -1x | +132 | +2x |
- if (length(intersect(baskets, unique(aag_summary$basket))) == 0) {
+ if (use_percentile) {
|
| 89 | -! | +|||
| 133 | +1x |
- warning("There are 0 baskets in common between aag_summary$basket and `baskets` argument.")
+ p <- p + ggplot2::scale_x_continuous(labels = scales::percent) |
||
| 90 | +134 |
- }+ } |
||
| 91 | -+ | |||
| 135 | +2x |
- }+ p |
||
| 92 | +136 | - - | -||
| 93 | -3x | -
- var_labels <- c(formatters::var_labels(df[, keys]), "SMQ" = smq_varlabel)+ } |
||
| 94 | +137 | |||
| 95 | +138 |
- # convert `na_str` records from baskets to NA for the later loop and from wide to long steps- |
- ||
| 96 | -3x | -
- df[, c(baskets, smq_sc)][df[, c(baskets, smq_sc)] == na_str] <- NA+ #' Custom tidy method for STEP results |
||
| 97 | +139 |
-
+ #' |
||
| 98 | -3x | +|||
| 140 | +
- if (all(is.na(df[, baskets]))) { # in case there is no level for the target baskets
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 99 | -1x | +|||
| 141 | +
- df_long <- df[-seq_len(nrow(df)), keys] # we just need an empty data frame keeping all factor levels+ #' |
|||
| 100 | +142 |
- } else {
+ #' Tidy the STEP results into a `tibble` format ready for plotting. |
||
| 101 | +143 |
- # Concatenate SMQxxxNAM with corresponding SMQxxxSC+ #' |
||
| 102 | -2x | +|||
| 144 | +
- df_cnct <- df[, c(keys, baskets[startsWith(baskets, "CQ")])]+ #' @param x (`matrix`)\cr results from [fit_survival_step()]. |
|||
| 103 | +145 |
-
+ #' @param ... not used. |
||
| 104 | -2x | +|||
| 146 | +
- for (nam in names(smq)) {
+ #' |
|||
| 105 | -4x | +|||
| 147 | +
- sc <- smq[nam] # SMQxxxSC corresponding to SMQxxxNAM+ #' @return A `tibble` with one row per STEP subgroup. The estimates and CIs are on the HR or OR scale, |
|||
| 106 | -4x | +|||
| 148 | +
- nam_notna <- !is.na(df[[nam]])+ #' respectively. Additional attributes carry metadata also used for plotting. |
|||
| 107 | -4x | +|||
| 149 | +
- new_colname <- paste(nam, sc, sep = "_")+ #' |
|||
| 108 | -4x | +|||
| 150 | +
- df_cnct[nam_notna, new_colname] <- paste0(df[[nam]], "(", df[[sc]], ")")[nam_notna]
+ #' @seealso [g_step()] which consumes the result from this function. |
|||
| 109 | +151 |
- }+ #' |
||
| 110 | +152 |
-
+ #' @method tidy step |
||
| 111 | -2x | +|||
| 153 | +
- df_cnct$unique_id <- seq(1, nrow(df_cnct))+ #' |
|||
| 112 | -2x | +|||
| 154 | +
- var_cols <- names(df_cnct)[!(names(df_cnct) %in% c(keys, "unique_id"))]+ #' @examples |
|||
| 113 | +155 |
- # have to convert df_cnct from tibble to data frame+ #' library(survival) |
||
| 114 | +156 |
- # as it throws a warning otherwise about rownames.+ #' lung$sex <- factor(lung$sex) |
||
| 115 | +157 |
- # tibble do not support rownames and reshape creates rownames+ #' vars <- list( |
||
| 116 | +158 |
-
+ #' time = "time", |
||
| 117 | -2x | +|||
| 159 | +
- df_long <- stats::reshape(+ #' event = "status", |
|||
| 118 | -2x | +|||
| 160 | +
- data = as.data.frame(df_cnct),+ #' arm = "sex", |
|||
| 119 | -2x | +|||
| 161 | +
- varying = var_cols,+ #' biomarker = "age" |
|||
| 120 | -2x | +|||
| 162 | +
- v.names = "SMQ",+ #' ) |
|||
| 121 | -2x | +|||
| 163 | +
- idvar = names(df_cnct)[names(df_cnct) %in% c(keys, "unique_id")],+ #' step_matrix <- fit_survival_step( |
|||
| 122 | -2x | +|||
| 164 | +
- direction = "long",+ #' variables = vars, |
|||
| 123 | -2x | +|||
| 165 | +
- new.row.names = seq(prod(length(var_cols), nrow(df_cnct)))+ #' data = lung, |
|||
| 124 | +166 |
- )+ #' control = c(control_coxph(), control_step(num_points = 10, degree = 2)) |
||
| 125 | +167 |
-
+ #' ) |
||
| 126 | -2x | +|||
| 168 | +
- df_long <- df_long[!is.na(df_long[, "SMQ"]), !(names(df_long) %in% c("time", "unique_id"))]
+ #' broom::tidy(step_matrix) |
|||
| 127 | -2x | +|||
| 169 | +
- df_long$SMQ <- as.factor(df_long$SMQ)+ #' |
|||
| 128 | +170 |
- }+ #' @export |
||
| 129 | +171 |
-
+ tidy.step <- function(x, ...) { # nolint
|
||
| 130 | -3x | +172 | +7x |
- smq_levels <- setdiff(levels(df_long[["SMQ"]]), na_str)+ checkmate::assert_class(x, "step") |
| 131 | -+ | |||
| 173 | +7x |
-
+ dat <- as.data.frame(x) |
||
| 132 | -3x | +174 | +7x |
- if (!is.null(aag_summary)) {
+ nams <- names(dat) |
| 133 | -+ | |||
| 175 | +7x |
- # A warning in case there is no match between df and aag_summary records+ is_surv <- "loghr" %in% names(dat) |
||
| 134 | -1x | +176 | +7x |
- if (length(intersect(smq_levels, unique(aag_summary$basket_name))) == 0) {
+ est_var <- ifelse(is_surv, "loghr", "logor") |
| 135 | -1x | +177 | +7x |
- warning("There are 0 basket levels in common between aag_summary$basket_name and df.")
+ new_est_var <- ifelse(is_surv, "Hazard Ratio", "Odds Ratio") |
| 136 | -+ | |||
| 178 | +7x |
- }+ new_y_vars <- c(new_est_var, c("ci_lower", "ci_upper"))
|
||
| 137 | -1x | +179 | +7x |
- df_long[["SMQ"]] <- factor(+ names(dat)[match(est_var, nams)] <- new_est_var |
| 138 | -1x | +180 | +7x |
- df_long[["SMQ"]],+ dat[, new_y_vars] <- exp(dat[, new_y_vars]) |
| 139 | -1x | +181 | +7x |
- levels = sort(+ any_is_na <- any(is.na(dat[, new_y_vars])) |
| 140 | -1x | +182 | +7x |
- c(+ any_is_very_large <- any(abs(dat[, new_y_vars]) > 1e10, na.rm = TRUE) |
| 141 | -1x | +183 | +7x |
- smq_levels,+ if (any_is_na) {
|
| 142 | -1x | +184 | +2x |
- setdiff(unique(aag_summary$basket_name), smq_levels)+ warning(paste( |
| 143 | -+ | |||
| 185 | +2x |
- )+ "Missing values in the point estimate or CI columns,", |
||
| 144 | -+ | |||
| 186 | +2x |
- )+ "this will lead to holes in the `g_step()` plot" |
||
| 145 | +187 |
- )+ )) |
||
| 146 | +188 |
- } else {
+ } |
||
| 147 | -2x | +189 | +7x |
- all_na_basket_flag <- vapply(df[, baskets], function(x) {
+ if (any_is_very_large) {
|
| 148 | -6x | +190 | +2x |
- all(is.na(x))+ warning(paste( |
| 149 | +191 | 2x |
- }, FUN.VALUE = logical(1))+ "Very large absolute values in the point estimate or CI columns,", |
|
| 150 | +192 | 2x |
- all_na_basket <- baskets[all_na_basket_flag]+ "consider adding `scale_y_log10()` to the `g_step()` result for plotting" |
|
| 151 | +193 |
-
+ )) |
||
| 152 | -2x | +|||
| 194 | +
- df_long[["SMQ"]] <- factor(+ } |
|||
| 153 | -2x | +195 | +7x |
- df_long[["SMQ"]],+ if (any_is_na || any_is_very_large) {
|
| 154 | -2x | +196 | +4x |
- levels = sort(c(smq_levels, all_na_basket))+ warning("Consider using larger `bandwidth`, less `num_points` in `control_step()` settings for fitting")
|
| 155 | +197 |
- )+ } |
||
| 156 | -+ | |||
| 198 | +7x |
- }+ structure( |
||
| 157 | -3x | +199 | +7x |
- formatters::var_labels(df_long) <- var_labels+ tibble::as_tibble(dat), |
| 158 | -3x | +200 | +7x |
- tibble::tibble(df_long)+ estimate = new_est_var,+ |
+
| 201 | +7x | +
+ biomarker = attr(x, "variables")$biomarker,+ |
+ ||
| 202 | +7x | +
+ ci = f_conf_level(attr(x, "control")$conf_level) |
||
| 159 | +203 | ++ |
+ )+ |
+ |
| 204 |
}@@ -118893,14 +118572,14 @@ tern coverage - 95.64% |
| 1 |
- #' Bland-Altman analysis+ #' Survival time analysis |
||
| 3 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @description `r lifecycle::badge("stable")`
|
||
| 5 |
- #' Functions that use the Bland-Altman method to assess the agreement between two numerical vectors.+ #' The analyze function [surv_time()] creates a layout element to analyze survival time by calculating survival time |
||
| 6 |
- #'+ #' median, median confidence interval, quantiles, and range (for all, censored, or event patients). The primary |
||
| 7 |
- #' @inheritParams argument_convention+ #' analysis variable `vars` is the time variable and the secondary analysis variable `is_event` indicates whether or |
||
| 8 |
- #' @param y (`numeric`)\cr vector of numbers we want to analyze, to be compared with `x`.+ #' not an event has occurred. |
||
| 10 |
- #' @name bland_altman+ #' @inheritParams argument_convention |
||
| 11 |
- NULL+ #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function |
||
| 12 |
-
+ #' [control_surv_time()]. Some possible parameter options are: |
||
| 13 |
- #' @describeIn bland_altman Statistics function that compares two numeric vectors using the Bland-Altman method+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival time. |
||
| 14 |
- #' and calculates a variety of statistics.+ #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", or "log-log", |
||
| 15 |
- #'+ #' see more in [survival::survfit()]. Note option "none" is not supported. |
||
| 16 |
- #' @return+ #' * `quantiles` (`numeric`)\cr vector of length two to specify the quantiles of survival time. |
||
| 17 |
- #' * `s_bland_altman()` returns a named list of the following elements: `df`, `difference_mean`, `ci_mean`,+ #' @param ref_fn_censor (`flag`)\cr whether referential footnotes indicating censored observations should be printed |
||
| 18 |
- #' `difference_sd`, `difference_se`, `upper_agreement_limit`, `lower_agreement_limit`, `agreement_limit_se`,+ #' when the `range` statistic is included. |
||
| 19 |
- #' `upper_agreement_limit_ci`, `lower_agreement_limit_ci`, `t_value`, and `n`.+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("surv_time")`
|
||
| 20 |
- #'+ #' to see available statistics for this function. |
||
| 21 |
- #' @examples+ #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 22 |
- #' x <- seq(1, 60, 5)+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
||
| 23 |
- #' y <- seq(5, 50, 4)+ #' for that statistic's row label. |
||
| 24 |
- #' conf_level <- 0.9+ #' |
||
| 25 |
- #'+ #' @examples |
||
| 26 |
- #' # Derive statistics that are needed for Bland-Altman plot+ #' library(dplyr) |
||
| 27 |
- #' s_bland_altman(x, y, conf_level = conf_level)+ #' |
||
| 28 |
- #'+ #' adtte_f <- tern_ex_adtte %>% |
||
| 29 |
- #' @export+ #' filter(PARAMCD == "OS") %>% |
||
| 30 |
- s_bland_altman <- function(x, y, conf_level = 0.95) {
+ #' mutate( |
||
| 31 | -7x | +
- checkmate::assert_numeric(x, min.len = 1, any.missing = TRUE)+ #' AVAL = day2month(AVAL), |
|
| 32 | -6x | +
- checkmate::assert_numeric(y, len = length(x), any.missing = TRUE)+ #' is_event = CNSR == 0 |
|
| 33 | -5x | +
- checkmate::assert_numeric(conf_level, lower = 0, upper = 1, any.missing = TRUE)+ #' ) |
|
| 34 |
-
+ #' df <- adtte_f %>% filter(ARMCD == "ARM A") |
||
| 35 | -4x | +
- alpha <- 1 - conf_level+ #' |
|
| 36 |
-
+ #' @name survival_time |
||
| 37 | -4x | +
- ind <- complete.cases(x, y) # use only pairwise complete observations, and check if x and y have the same length+ #' @order 1 |
|
| 38 | -4x | +
- x <- x[ind]+ NULL |
|
| 39 | -4x | +
- y <- y[ind]+ |
|
| 40 | -4x | +
- n <- sum(ind) # number of 'observations'+ #' @describeIn survival_time Statistics function which analyzes survival times. |
|
| 41 |
-
+ #' |
||
| 42 | -4x | +
- if (n == 0) {
+ #' @return |
|
| 43 | -! | +
- stop("there is no valid paired data")
+ #' * `s_surv_time()` returns the statistics: |
|
| 44 |
- }+ #' * `median`: Median survival time. |
||
| 45 |
-
+ #' * `median_ci`: Confidence interval for median time. |
||
| 46 | -4x | +
- difference <- x - y # vector of differences+ #' * `quantiles`: Survival time for two specified quantiles. |
|
| 47 | -4x | +
- average <- (x + y) / 2 # vector of means+ #' * `range_censor`: Survival time range for censored observations. |
|
| 48 | -4x | +
- difference_mean <- mean(difference) # mean difference+ #' * `range_event`: Survival time range for observations with events. |
|
| 49 | -4x | +
- difference_sd <- sd(difference) # SD of differences+ #' * `range`: Survival time range for all observations. |
|
| 50 | -4x | +
- al <- qnorm(1 - alpha / 2) * difference_sd+ #' |
|
| 51 | -4x | +
- upper_agreement_limit <- difference_mean + al # agreement limits+ #' @keywords internal |
|
| 52 | -4x | +
- lower_agreement_limit <- difference_mean - al+ s_surv_time <- function(df, |
|
| 53 |
-
+ .var, |
||
| 54 | -4x | +
- difference_se <- difference_sd / sqrt(n) # standard error of the mean+ is_event, |
|
| 55 | -4x | +
- al_se <- difference_sd * sqrt(3) / sqrt(n) # standard error of the agreement limit+ control = control_surv_time()) {
|
|
| 56 | -4x | +232x |
- tvalue <- qt(1 - alpha / 2, n - 1) # t value for 95% CI calculation+ checkmate::assert_string(.var) |
| 57 | -4x | +232x |
- difference_mean_ci <- difference_se * tvalue+ assert_df_with_variables(df, list(tte = .var, is_event = is_event)) |
| 58 | -4x | +232x |
- al_ci <- al_se * tvalue+ checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE) |
| 59 | -4x | +232x |
- upper_agreement_limit_ci <- c(upper_agreement_limit - al_ci, upper_agreement_limit + al_ci)+ checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE) |
| 60 | -4x | +
- lower_agreement_limit_ci <- c(lower_agreement_limit - al_ci, lower_agreement_limit + al_ci)+ |
|
| 61 | -+ | 232x |
-
+ conf_type <- control$conf_type |
| 62 | -4x | +232x |
- list(+ conf_level <- control$conf_level |
| 63 | -4x | +232x |
- df = data.frame(average, difference),+ quantiles <- control$quantiles |
| 64 | -4x | +
- difference_mean = difference_mean,+ |
|
| 65 | -4x | +232x |
- ci_mean = difference_mean + c(-1, 1) * difference_mean_ci,+ formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
|
| 66 | -4x | +232x |
- difference_sd = difference_sd,+ srv_fit <- survival::survfit( |
| 67 | -4x | +232x |
- difference_se = difference_se,+ formula = formula, |
| 68 | -4x | +232x |
- upper_agreement_limit = upper_agreement_limit,+ data = df, |
| 69 | -4x | +232x |
- lower_agreement_limit = lower_agreement_limit,+ conf.int = conf_level, |
| 70 | -4x | +232x |
- agreement_limit_se = al_se,+ conf.type = conf_type |
| 71 | -4x | +
- upper_agreement_limit_ci = upper_agreement_limit_ci,+ ) |
|
| 72 | -4x | +232x |
- lower_agreement_limit_ci = lower_agreement_limit_ci,+ srv_tab <- summary(srv_fit, extend = TRUE)$table |
| 73 | -4x | +232x |
- t_value = tvalue,+ srv_qt_tab <- stats::quantile(srv_fit, probs = quantiles)$quantile |
| 74 | -4x | +232x |
- n = n+ range_censor <- range_noinf(df[[.var]][!df[[is_event]]], na.rm = TRUE) |
| 75 | -+ | 232x |
- )+ range_event <- range_noinf(df[[.var]][df[[is_event]]], na.rm = TRUE) |
| 76 | -+ | 232x |
- }+ range <- range_noinf(df[[.var]], na.rm = TRUE) |
| 77 | -+ | 232x |
-
+ list( |
| 78 | -+ | 232x |
- #' @describeIn bland_altman Graphing function that produces a Bland-Altman plot.+ median = formatters::with_label(unname(srv_tab["median"]), "Median"), |
| 79 | -+ | 232x |
- #'+ median_ci = formatters::with_label( |
| 80 | -+ | 232x |
- #' @return+ unname(srv_tab[paste0(srv_fit$conf.int, c("LCL", "UCL"))]), f_conf_level(conf_level)
|
| 81 |
- #' * `g_bland_altman()` returns a `ggplot` Bland-Altman plot.+ ), |
||
| 82 | -+ | 232x |
- #'+ quantiles = formatters::with_label( |
| 83 | -+ | 232x |
- #' @examples+ unname(srv_qt_tab), paste0(quantiles[1] * 100, "% and ", quantiles[2] * 100, "%-ile") |
| 84 |
- #' # Create a Bland-Altman plot+ ), |
||
| 85 | -+ | 232x |
- #' g_bland_altman(x = x, y = y, conf_level = conf_level)+ range_censor = formatters::with_label(range_censor, "Range (censored)"), |
| 86 | -+ | 232x |
- #'+ range_event = formatters::with_label(range_event, "Range (event)"), |
| 87 | -+ | 232x |
- #' @export+ range = formatters::with_label(range, "Range") |
| 88 |
- g_bland_altman <- function(x, y, conf_level = 0.95) {
+ ) |
||
| 89 | -1x | +
- result_tem <- s_bland_altman(x, y, conf_level = conf_level)+ } |
|
| 90 | -1x | +
- xpos <- max(result_tem$df$average) * 0.9 + min(result_tem$df$average) * 0.1+ |
|
| 91 | -1x | +
- yrange <- diff(range(result_tem$df$difference))+ #' @describeIn survival_time Formatted analysis function which is used as `afun` in `surv_time()`. |
|
| 92 |
-
+ #' |
||
| 93 | -1x | +
- p <- ggplot(result_tem$df) ++ #' @return |
|
| 94 | -1x | +
- geom_point(aes(x = average, y = difference), color = "blue") ++ #' * `a_surv_time()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 95 | -1x | +
- geom_hline(yintercept = result_tem$difference_mean, color = "blue", linetype = 1) ++ #' |
|
| 96 | -1x | +
- geom_hline(yintercept = 0, color = "blue", linetype = 2) ++ #' @examples |
|
| 97 | -1x | +
- geom_hline(yintercept = result_tem$lower_agreement_limit, color = "red", linetype = 2) ++ #' a_surv_time( |
|
| 98 | -1x | +
- geom_hline(yintercept = result_tem$upper_agreement_limit, color = "red", linetype = 2) ++ #' df, |
|
| 99 | -1x | +
- annotate(+ #' .df_row = df, |
|
| 100 | -1x | +
- "text",+ #' .var = "AVAL", |
|
| 101 | -1x | +
- x = xpos,+ #' is_event = "is_event" |
|
| 102 | -1x | +
- y = result_tem$lower_agreement_limit + 0.03 * yrange,+ #' ) |
|
| 103 | -1x | +
- label = "lower limits of agreement",+ #' |
|
| 104 | -1x | +
- color = "red"+ #' @export |
|
| 105 |
- ) ++ a_surv_time <- function(df, |
||
| 106 | -1x | +
- annotate(+ labelstr = "", |
|
| 107 | -1x | +
- "text",+ .var = NULL, |
|
| 108 | -1x | +
- x = xpos,+ .df_row = NULL, |
|
| 109 | -1x | +
- y = result_tem$upper_agreement_limit + 0.03 * yrange,+ is_event, |
|
| 110 | -1x | +
- label = "upper limits of agreement",+ control = control_surv_time(), |
|
| 111 | -1x | +
- color = "red"+ ref_fn_censor = TRUE, |
|
| 112 |
- ) ++ .stats = NULL, |
||
| 113 | -1x | +
- annotate(+ .formats = NULL, |
|
| 114 | -1x | +
- "text",+ .labels = NULL, |
|
| 115 | -1x | +
- x = xpos,+ .indent_mods = NULL, |
|
| 116 | -1x | +
- y = result_tem$difference_mean + 0.03 * yrange,+ na_str = default_na_str()) {
|
|
| 117 | -1x | +14x |
- label = "mean of difference between two measures",+ x_stats <- s_surv_time( |
| 118 | -1x | +14x |
- color = "blue"+ df = df, .var = .var, is_event = is_event, control = control |
| 119 |
- ) ++ ) |
||
| 120 | -1x | +14x |
- annotate(+ rng_censor_lwr <- x_stats[["range_censor"]][1] |
| 121 | -1x | +14x |
- "text",+ rng_censor_upr <- x_stats[["range_censor"]][2] |
| 122 | -1x | +
- x = xpos,+ |
|
| 123 | -1x | +
- y = result_tem$lower_agreement_limit - 0.03 * yrange,+ # Use method-specific defaults |
|
| 124 | -1x | +14x |
- label = sprintf("%.2f", result_tem$lower_agreement_limit),
+ fmts <- c(median_ci = "(xx.x, xx.x)", quantiles = "xx.x, xx.x", range = "xx.x to xx.x") |
| 125 | -1x | +14x |
- color = "red"+ lbls <- c(median_ci = "95% CI", range = "Range", range_censor = "Range (censored)", range_event = "Range (event)") |
| 126 | -+ | 14x |
- ) ++ lbls_custom <- .labels |
| 127 | -1x | +14x |
- annotate(+ .formats <- c(.formats, fmts[setdiff(names(fmts), names(.formats))]) |
| 128 | -1x | +14x |
- "text",+ .labels <- c(.labels, lbls[setdiff(names(lbls), names(lbls_custom))]) |
| 129 | -1x | +
- x = xpos,+ |
|
| 130 | -1x | +
- y = result_tem$upper_agreement_limit - 0.03 * yrange,+ # Fill in with formatting defaults if needed |
|
| 131 | -1x | +14x |
- label = sprintf("%.2f", result_tem$upper_agreement_limit),
+ .stats <- get_stats("surv_time", stats_in = .stats)
|
| 132 | -1x | +14x |
- color = "red"+ .formats <- get_formats_from_stats(.stats, .formats) |
| 133 | -+ | 14x |
- ) ++ .labels <- get_labels_from_stats(.stats, .labels) %>% labels_use_control(control, lbls_custom) |
| 134 | -1x | +14x |
- annotate(+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods) |
| 135 | -1x | +
- "text",+ |
|
| 136 | -1x | +14x |
- x = xpos,+ x_stats <- x_stats[.stats] |
| 137 | -1x | +
- y = result_tem$difference_mean - 0.03 * yrange,+ |
|
| 138 | -1x | +
- label = sprintf("%.2f", result_tem$difference_meanm),
+ # Auto format handling |
|
| 139 | -1x | +14x |
- color = "blue"+ .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var) |
| 140 |
- ) ++ |
||
| 141 | -1x | +14x |
- xlab("Average of two measures") +
+ cell_fns <- setNames(vector("list", length = length(x_stats)), .labels)
|
| 142 | -1x | +14x |
- ylab("Difference between two measures")
+ if ("range" %in% names(x_stats) && ref_fn_censor) {
|
| 143 | -+ | 14x |
-
+ if (identical(x_stats[["range"]][1], rng_censor_lwr) && identical(x_stats[["range"]][2], rng_censor_upr)) {
|
| 144 | -1x | +2x |
- return(p)+ cell_fns[[.labels[["range"]]]] <- "Censored observations: range minimum & maximum" |
| 145 | -- |
- }- |
-
| 1 | -- |
- #' Helper functions for Cox proportional hazards regression- |
- ||
| 2 | -- |
- #'- |
- ||
| 3 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- ||
| 4 | -- |
- #'- |
- ||
| 5 | -+ | 12x |
- #' Helper functions used in [fit_coxreg_univar()] and [fit_coxreg_multivar()].+ } else if (identical(x_stats[["range"]][1], rng_censor_lwr)) {
|
|
| 6 | -+ | |||
| 146 | +2x |
- #'+ cell_fns[[.labels[["range"]]]] <- "Censored observation: range minimum" |
||
| 7 | -+ | |||
| 147 | +10x |
- #' @inheritParams argument_convention+ } else if (identical(x_stats[["range"]][2], rng_censor_upr)) {
|
||
| 8 | -+ | |||
| 148 | +1x |
- #' @inheritParams h_coxreg_univar_extract+ cell_fns[[.labels[["range"]]]] <- "Censored observation: range maximum" |
||
| 9 | +149 |
- #' @inheritParams cox_regression_inter+ } |
||
| 10 | +150 |
- #' @inheritParams control_coxreg+ } |
||
| 11 | +151 |
- #'+ |
||
| 12 | -+ | |||
| 152 | +14x |
- #' @seealso [cox_regression]+ in_rows( |
||
| 13 | -+ | |||
| 153 | +14x |
- #'+ .list = x_stats, |
||
| 14 | -+ | |||
| 154 | +14x |
- #' @name h_cox_regression+ .formats = .formats, |
||
| 15 | -+ | |||
| 155 | +14x |
- NULL+ .names = .labels, |
||
| 16 | -+ | |||
| 156 | +14x |
-
+ .labels = .labels, |
||
| 17 | -+ | |||
| 157 | +14x |
- #' @describeIn h_cox_regression Helper for Cox regression formula. Creates a list of formulas. It is used+ .indent_mods = .indent_mods, |
||
| 18 | -+ | |||
| 158 | +14x |
- #' internally by [fit_coxreg_univar()] for the comparison of univariate Cox regression models.+ .format_na_strs = na_str, |
||
| 19 | -+ | |||
| 159 | +14x |
- #'+ .cell_footnotes = cell_fns |
||
| 20 | +160 |
- #' @return+ ) |
||
| 21 | +161 |
- #' * `h_coxreg_univar_formulas()` returns a `character` vector coercible into formulas (e.g [stats::as.formula()]).+ } |
||
| 22 | +162 |
- #'+ |
||
| 23 | +163 |
- #' @examples+ #' @describeIn survival_time Layout-creating function which can take statistics function arguments |
||
| 24 | +164 |
- #' # `h_coxreg_univar_formulas`+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 25 | +165 |
#' |
||
| 26 | -- |
- #' ## Simple formulas.- |
- ||
| 27 | -- |
- #' h_coxreg_univar_formulas(- |
- ||
| 28 | +166 |
- #' variables = list(+ #' @return |
||
| 29 | +167 |
- #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y")
+ #' * `surv_time()` returns a layout object suitable for passing to further layouting functions, |
||
| 30 | +168 |
- #' )+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 31 | +169 |
- #' )+ #' the statistics from `s_surv_time()` to the table layout. |
||
| 32 | +170 |
#' |
||
| 33 | +171 |
- #' ## Addition of an optional strata.+ #' @examples |
||
| 34 | +172 |
- #' h_coxreg_univar_formulas(+ #' basic_table() %>% |
||
| 35 | +173 |
- #' variables = list(+ #' split_cols_by(var = "ARMCD") %>% |
||
| 36 | +174 |
- #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
+ #' add_colcounts() %>% |
||
| 37 | +175 |
- #' strata = "SITE"+ #' surv_time( |
||
| 38 | +176 |
- #' )+ #' vars = "AVAL", |
||
| 39 | +177 |
- #' )+ #' var_labels = "Survival Time (Months)", |
||
| 40 | +178 |
- #'+ #' is_event = "is_event", |
||
| 41 | +179 |
- #' ## Inclusion of the interaction term.+ #' control = control_surv_time(conf_level = 0.9, conf_type = "log-log") |
||
| 42 | +180 |
- #' h_coxreg_univar_formulas(+ #' ) %>% |
||
| 43 | +181 |
- #' variables = list(+ #' build_table(df = adtte_f) |
||
| 44 | +182 |
- #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
+ #' |
||
| 45 | +183 |
- #' strata = "SITE"+ #' @export |
||
| 46 | +184 |
- #' ),+ #' @order 2 |
||
| 47 | +185 |
- #' interaction = TRUE+ surv_time <- function(lyt, |
||
| 48 | +186 |
- #' )+ vars, |
||
| 49 | +187 |
- #'+ is_event, |
||
| 50 | +188 |
- #' ## Only covariates fitted in separate models.+ control = control_surv_time(), |
||
| 51 | +189 |
- #' h_coxreg_univar_formulas(+ ref_fn_censor = TRUE, |
||
| 52 | +190 |
- #' variables = list(+ na_str = default_na_str(), |
||
| 53 | +191 |
- #' time = "time", event = "status", covariates = c("X", "y")
+ nested = TRUE, |
||
| 54 | +192 |
- #' )+ ..., |
||
| 55 | +193 |
- #' )+ var_labels = "Time to Event", |
||
| 56 | +194 |
- #'+ show_labels = "visible", |
||
| 57 | +195 |
- #' @export+ table_names = vars, |
||
| 58 | +196 |
- h_coxreg_univar_formulas <- function(variables,+ .stats = c("median", "median_ci", "quantiles", "range"),
|
||
| 59 | +197 |
- interaction = FALSE) {
- |
- ||
| 60 | -50x | -
- checkmate::assert_list(variables, names = "named")- |
- ||
| 61 | -50x | -
- has_arm <- "arm" %in% names(variables)- |
- ||
| 62 | -50x | -
- arm_name <- if (has_arm) "arm" else NULL+ .formats = NULL, |
||
| 63 | +198 | - - | -||
| 64 | -50x | -
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ .labels = NULL, |
||
| 65 | +199 |
-
+ .indent_mods = c(median_ci = 1L)) {
|
||
| 66 | -50x | -
- checkmate::assert_flag(interaction)- |
- ||
| 67 | -+ | 200 | +3x |
-
+ extra_args <- list( |
| 68 | -50x | +201 | +3x |
- if (!has_arm || is.null(variables$covariates)) {
+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str, |
| 69 | -10x | +202 | +3x |
- checkmate::assert_false(interaction)+ is_event = is_event, control = control, ref_fn_censor = ref_fn_censor, ... |
| 70 | +203 |
- }+ ) |
||
| 71 | +204 | |||
| 72 | -48x | -
- assert_list_of_variables(variables[c(arm_name, "event", "time")])- |
- ||
| 73 | -+ | 205 | +3x |
-
+ analyze( |
| 74 | -48x | +206 | +3x |
- if (!is.null(variables$covariates)) {
+ lyt = lyt, |
| 75 | -47x | +207 | +3x |
- forms <- paste0(+ vars = vars, |
| 76 | -47x | +208 | +3x |
- "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
+ afun = a_surv_time, |
| 77 | -47x | +209 | +3x |
- ifelse(has_arm, variables$arm, "1"),+ var_labels = var_labels, |
| 78 | -47x | +210 | +3x |
- ifelse(interaction, " * ", " + "),+ show_labels = show_labels, |
| 79 | -47x | +211 | +3x |
- variables$covariates,+ table_names = table_names, |
| 80 | -47x | +212 | +3x |
- ifelse(+ na_str = na_str, |
| 81 | -47x | +213 | +3x |
- !is.null(variables$strata),+ nested = nested, |
| 82 | -47x | -
- paste0(" + strata(", paste0(variables$strata, collapse = ", "), ")"),
- |
- ||
| 83 | -- |
- ""- |
- ||
| 84 | -- |
- )- |
- ||
| 85 | -+ | 214 | +3x |
- )+ extra_args = extra_args |
| 86 | +215 |
- } else {
- |
- ||
| 87 | -1x | -
- forms <- NULL+ ) |
||
| 88 | +216 |
- }- |
- ||
| 89 | -48x | -
- nams <- variables$covariates- |
- ||
| 90 | -48x | -
- if (has_arm) {
- |
- ||
| 91 | -41x | -
- ref <- paste0(- |
- ||
| 92 | -41x | -
- "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
- |
- ||
| 93 | -41x | -
- variables$arm,- |
- ||
| 94 | -41x | -
- ifelse(- |
- ||
| 95 | -41x | -
- !is.null(variables$strata),- |
- ||
| 96 | -41x | -
- paste0(- |
- ||
| 97 | -41x | -
- " + strata(", paste0(variables$strata, collapse = ", "), ")"
+ } |
| 98 | +1 |
- ),+ #' Count occurrences by grade |
||
| 99 | +2 |
- ""+ #' |
||
| 100 | +3 |
- )+ #' @description `r lifecycle::badge("stable")`
|
||
| 101 | +4 |
- )- |
- ||
| 102 | -41x | -
- forms <- c(ref, forms)- |
- ||
| 103 | -41x | -
- nams <- c("ref", nams)
+ #' |
||
| 104 | +5 |
- }- |
- ||
| 105 | -48x | -
- stats::setNames(forms, nams)+ #' The analyze function [count_occurrences_by_grade()] creates a layout element to calculate occurrence counts by grade. |
||
| 106 | +6 |
- }+ #' |
||
| 107 | +7 |
-
+ #' This function analyzes primary analysis variable `var` which indicates toxicity grades. The `id` variable |
||
| 108 | +8 |
- #' @describeIn h_cox_regression Helper for multivariate Cox regression formula. Creates a formulas+ #' is used to indicate unique subject identifiers (defaults to `USUBJID`). The user can also supply a list of |
||
| 109 | +9 |
- #' string. It is used internally by [fit_coxreg_multivar()] for the comparison of multivariate Cox+ #' custom groups of grades to analyze via the `grade_groups` parameter. The `remove_single` argument will |
||
| 110 | +10 |
- #' regression models. Interactions will not be included in multivariate Cox regression model.+ #' remove single grades from the analysis so that *only* grade groups are analyzed. |
||
| 111 | +11 |
#' |
||
| 112 | -- |
- #' @return- |
- ||
| 113 | +12 |
- #' * `h_coxreg_multivar_formula()` returns a `string` coercible into a formula (e.g [stats::as.formula()]).+ #' If there are multiple grades recorded for one patient only the highest grade level is counted. |
||
| 114 | +13 |
#' |
||
| 115 | -- |
- #' @examples- |
- ||
| 116 | +14 |
- #' # `h_coxreg_multivar_formula`+ #' The summarize function [summarize_occurrences_by_grade()] performs the same function as |
||
| 117 | +15 |
- #'+ #' [count_occurrences_by_grade()] except it creates content rows, not data rows, to summarize the current table |
||
| 118 | +16 |
- #' h_coxreg_multivar_formula(+ #' row/column context and operates on the level of the latest row split or the root of the table if no row splits have |
||
| 119 | +17 |
- #' variables = list(+ #' occurred. |
||
| 120 | +18 |
- #' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE")
+ #' |
||
| 121 | +19 |
- #' )+ #' @inheritParams argument_convention |
||
| 122 | +20 |
- #' )+ #' @param grade_groups (named `list` of `character`)\cr list containing groupings of grades. |
||
| 123 | +21 |
- #'+ #' @param remove_single (`flag`)\cr `TRUE` to not include the elements of one-element grade groups |
||
| 124 | +22 |
- #' # Addition of an optional strata.+ #' in the the output list; in this case only the grade groups names will be included in the output. If |
||
| 125 | +23 |
- #' h_coxreg_multivar_formula(+ #' `only_grade_groups` is set to `TRUE` this argument is ignored. |
||
| 126 | +24 |
- #' variables = list(+ #' @param only_grade_groups (`flag`)\cr whether only the specified grade groups should be |
||
| 127 | +25 |
- #' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE"),
+ #' included, with individual grade rows removed (`TRUE`), or all grades and grade groups |
||
| 128 | +26 |
- #' strata = "SITE"+ #' should be displayed (`FALSE`). |
||
| 129 | +27 |
- #' )+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_occurrences_by_grade")`
|
||
| 130 | +28 |
- #' )+ #' to see available statistics for this function. |
||
| 131 | +29 |
#' |
||
| 132 | +30 |
- #' # Example without treatment arm.+ #' @seealso Relevant helper function [h_append_grade_groups()]. |
||
| 133 | +31 |
- #' h_coxreg_multivar_formula(+ #' |
||
| 134 | +32 |
- #' variables = list(+ #' @name count_occurrences_by_grade |
||
| 135 | +33 |
- #' time = "AVAL", event = "event", covariates = c("RACE", "AGE"),
+ #' @order 1 |
||
| 136 | +34 |
- #' strata = "SITE"+ NULL |
||
| 137 | +35 |
- #' )+ |
||
| 138 | +36 |
- #' )+ #' Helper function for `s_count_occurrences_by_grade()` |
||
| 139 | +37 |
#' |
||
| 140 | +38 |
- #' @export+ #' @description `r lifecycle::badge("stable")`
|
||
| 141 | +39 |
- h_coxreg_multivar_formula <- function(variables) {
- |
- ||
| 142 | -89x | -
- checkmate::assert_list(variables, names = "named")- |
- ||
| 143 | -89x | -
- has_arm <- "arm" %in% names(variables)- |
- ||
| 144 | -89x | -
- arm_name <- if (has_arm) "arm" else NULL+ #' |
||
| 145 | +40 |
-
+ #' Helper function for [s_count_occurrences_by_grade()] to insert grade groupings into list with |
||
| 146 | -89x | +|||
| 41 | +
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ #' individual grade frequencies. The order of the final result follows the order of `grade_groups`. |
|||
| 147 | +42 |
-
+ #' The elements under any-grade group (if any), i.e. the grade group equal to `refs` will be moved to |
||
| 148 | -89x | +|||
| 43 | +
- assert_list_of_variables(variables[c(arm_name, "event", "time")])+ #' the end. Grade groups names must be unique. |
|||
| 149 | +44 |
-
+ #' |
||
| 150 | -89x | +|||
| 45 | +
- y <- paste0(+ #' @inheritParams count_occurrences_by_grade |
|||
| 151 | -89x | +|||
| 46 | +
- "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
+ #' @param refs (named `list` of `numeric`)\cr named list where each name corresponds to a reference grade level |
|||
| 152 | -89x | +|||
| 47 | +
- ifelse(has_arm, variables$arm, "1")+ #' and each entry represents a count. |
|||
| 153 | +48 |
- )+ #' |
||
| 154 | -89x | +|||
| 49 | +
- if (length(variables$covariates) > 0) {
+ #' @return Formatted list of grade groupings. |
|||
| 155 | -26x | +|||
| 50 | +
- y <- paste(y, paste(variables$covariates, collapse = " + "), sep = " + ")+ #' |
|||
| 156 | +51 |
- }+ #' @examples |
||
| 157 | -89x | +|||
| 52 | +
- if (!is.null(variables$strata)) {
+ #' h_append_grade_groups( |
|||
| 158 | -5x | +|||
| 53 | +
- y <- paste0(y, " + strata(", paste0(variables$strata, collapse = ", "), ")")
+ #' list( |
|||
| 159 | +54 |
- }+ #' "Any Grade" = as.character(1:5), |
||
| 160 | -89x | +|||
| 55 | +
- y+ #' "Grade 1-2" = c("1", "2"),
|
|||
| 161 | +56 |
- }+ #' "Grade 3-4" = c("3", "4")
|
||
| 162 | +57 |
-
+ #' ), |
||
| 163 | +58 |
- #' @describeIn h_cox_regression Utility function to help tabulate the result of+ #' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
|
||
| 164 | +59 |
- #' a univariate Cox regression model.+ #' ) |
||
| 165 | +60 |
#' |
||
| 166 | +61 |
- #' @param effect (`string`)\cr the treatment variable.+ #' h_append_grade_groups( |
||
| 167 | +62 |
- #' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()].+ #' list( |
||
| 168 | +63 |
- #'+ #' "Any Grade" = as.character(5:1), |
||
| 169 | +64 |
- #' @return+ #' "Grade A" = "5", |
||
| 170 | +65 |
- #' * `h_coxreg_univar_extract()` returns a `data.frame` with variables `effect`, `term`, `term_label`, `level`,+ #' "Grade B" = c("4", "3")
|
||
| 171 | +66 |
- #' `n`, `hr`, `lcl`, `ucl`, and `pval`.+ #' ), |
||
| 172 | +67 |
- #'+ #' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
|
||
| 173 | +68 |
- #' @examples+ #' ) |
||
| 174 | +69 |
- #' library(survival)+ #' |
||
| 175 | +70 |
- #'+ #' h_append_grade_groups( |
||
| 176 | +71 |
- #' dta_simple <- data.frame(+ #' list( |
||
| 177 | +72 |
- #' time = c(5, 5, 10, 10, 5, 5, 10, 10),+ #' "Any Grade" = as.character(1:5), |
||
| 178 | +73 |
- #' status = c(0, 0, 1, 0, 0, 1, 1, 1),+ #' "Grade 1-2" = c("1", "2"),
|
||
| 179 | +74 |
- #' armcd = factor(LETTERS[c(1, 1, 1, 1, 2, 2, 2, 2)], levels = c("A", "B")),
+ #' "Grade 3-4" = c("3", "4")
|
||
| 180 | +75 |
- #' var1 = c(45, 55, 65, 75, 55, 65, 85, 75),+ #' ), |
||
| 181 | +76 |
- #' var2 = c("F", "M", "F", "M", "F", "M", "F", "U")
+ #' list("1" = 10, "2" = 5, "3" = 0)
|
||
| 182 | +77 |
#' ) |
||
| 183 | +78 |
- #' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple)+ #' |
||
| 184 | +79 |
- #' result <- h_coxreg_univar_extract(+ #' @export |
||
| 185 | +80 |
- #' effect = "armcd", covar = "armcd", mod = mod, data = dta_simple+ h_append_grade_groups <- function(grade_groups, refs, remove_single = TRUE, only_grade_groups = FALSE) {
|
||
| 186 | -+ | |||
| 81 | +22x |
- #' )+ checkmate::assert_list(grade_groups) |
||
| 187 | -+ | |||
| 82 | +22x |
- #' result+ checkmate::assert_list(refs) |
||
| 188 | -+ | |||
| 83 | +22x |
- #'+ refs_orig <- refs |
||
| 189 | -+ | |||
| 84 | +22x |
- #' @export+ elements <- unique(unlist(grade_groups)) |
||
| 190 | +85 |
- h_coxreg_univar_extract <- function(effect,+ |
||
| 191 | +86 |
- covar,+ ### compute sums in groups+ |
+ ||
| 87 | +22x | +
+ grp_sum <- lapply(grade_groups, function(i) do.call(sum, refs[i]))+ |
+ ||
| 88 | +22x | +
+ if (!checkmate::test_subset(elements, names(refs))) {
+ |
+ ||
| 89 | +2x | +
+ padding_el <- setdiff(elements, names(refs))+ |
+ ||
| 90 | +2x | +
+ refs[padding_el] <- 0 |
||
| 192 | +91 |
- data,+ }+ |
+ ||
| 92 | +22x | +
+ result <- c(grp_sum, refs) |
||
| 193 | +93 |
- mod,+ |
||
| 194 | +94 |
- control = control_coxreg()) {
+ ### order result while keeping grade_groups's ordering |
||
| 195 | -66x | +95 | +22x |
- checkmate::assert_string(covar)+ ordr <- grade_groups |
| 196 | -66x | +|||
| 96 | +
- checkmate::assert_string(effect)+ + |
+ |||
| 97 | ++ |
+ # elements of any-grade group (if any) will be moved to the end |
||
| 197 | -66x | +98 | +22x |
- checkmate::assert_class(mod, "coxph")+ is_any <- sapply(grade_groups, setequal, y = names(refs)) |
| 198 | -66x | +99 | +22x |
- test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]+ ordr[is_any] <- list(character(0)) # hide elements under any-grade group |
| 199 | +100 | |||
| 200 | -66x | +|||
| 101 | +
- mod_aov <- muffled_car_anova(mod, test_statistic)+ # groups-elements combined sequence |
|||
| 201 | -66x | +102 | +22x |
- msum <- summary(mod, conf.int = control$conf_level)+ ordr <- c(lapply(names(ordr), function(g) c(g, ordr[[g]])), recursive = TRUE, use.names = FALSE) |
| 202 | -66x | +103 | +22x |
- sum_cox <- broom::tidy(msum)+ ordr <- ordr[!duplicated(ordr)] |
| 203 | +104 | |||
| 204 | +105 |
- # Combine results together.+ # append remaining elements (if any) |
||
| 205 | -66x | +106 | +22x |
- effect_aov <- mod_aov[effect, , drop = TRUE]+ ordr <- union(ordr, unlist(grade_groups[is_any])) # from any-grade group |
| 206 | -66x | +107 | +22x |
- pval <- effect_aov[[grep(pattern = "Pr", x = names(effect_aov)), drop = TRUE]]+ ordr <- union(ordr, names(refs)) # from refs |
| 207 | -66x | +|||
| 108 | +
- sum_main <- sum_cox[grepl(effect, sum_cox$level), ]+ |
|||
| 208 | +109 |
-
+ # remove elements of single-element groups, if any |
||
| 209 | -66x | +110 | +22x |
- term_label <- if (effect == covar) {
+ if (only_grade_groups) {
|
| 210 | -34x | +111 | +3x |
- paste0(+ ordr <- intersect(ordr, names(grade_groups)) |
| 211 | -34x | +112 | +19x |
- levels(data[[covar]])[2],+ } else if (remove_single) {
|
| 212 | -34x | +113 | +19x |
- " vs control (",
+ is_single <- sapply(grade_groups, length) == 1L |
| 213 | -34x | +114 | +19x |
- levels(data[[covar]])[1],+ ordr <- setdiff(ordr, unlist(grade_groups[is_single])) |
| 214 | +115 |
- ")"+ } |
||
| 215 | +116 |
- )+ |
||
| 216 | +117 |
- } else {
+ # apply the order |
||
| 217 | -32x | +118 | +22x |
- unname(labels_or_names(data[covar]))+ result <- result[ordr] |
| 218 | +119 |
- }+ |
||
| 219 | -66x | +|||
| 120 | +
- data.frame(+ # remove groups without any elements in the original refs |
|||
| 220 | -66x | +|||
| 121 | +
- effect = ifelse(covar == effect, "Treatment:", "Covariate:"),+ # note: it's OK if groups have 0 value |
|||
| 221 | -66x | +122 | +22x |
- term = covar,+ keep_grp <- vapply(grade_groups, function(x, rf) {
|
| 222 | -66x | +123 | +54x |
- term_label = term_label,+ any(x %in% rf) |
| 223 | -66x | +124 | +22x |
- level = levels(data[[effect]])[2],+ }, rf = names(refs_orig), logical(1)) |
| 224 | -66x | +|||
| 125 | +
- n = mod[["n"]],+ |
|||
| 225 | -66x | +126 | +22x |
- hr = unname(sum_main["exp(coef)"]),+ keep_el <- names(result) %in% names(refs_orig) | names(result) %in% names(keep_grp)[keep_grp] |
| 226 | -66x | +127 | +22x |
- lcl = unname(sum_main[grep("lower", names(sum_main))]),
+ result <- result[keep_el] |
| 227 | -66x | +|||
| 128 | +
- ucl = unname(sum_main[grep("upper", names(sum_main))]),
+
|
|||
| 228 | -66x | +129 | +22x |
- pval = pval,+ result |
| 229 | -66x | +|||
| 130 | +
- stringsAsFactors = FALSE+ } |
|||
| 230 | +131 |
- )+ |
||
| 231 | +132 |
- }+ #' @describeIn count_occurrences_by_grade Statistics function which counts the |
||
| 232 | +133 |
-
+ #' number of patients by highest grade. |
||
| 233 | +134 |
- #' @describeIn h_cox_regression Tabulation of multivariate Cox regressions. Utility function to help+ #' |
||
| 234 | +135 |
- #' tabulate the result of a multivariate Cox regression model for a treatment/covariate variable.+ #' @return |
||
| 235 | +136 |
- #'+ #' * `s_count_occurrences_by_grade()` returns a list of counts and fractions with one element per grade level or |
||
| 236 | +137 |
- #' @return+ #' grade level grouping. |
||
| 237 | +138 |
- #' * `h_coxreg_multivar_extract()` returns a `data.frame` with variables `pval`, `hr`, `lcl`, `ucl`, `level`,+ #' |
||
| 238 | +139 |
- #' `n`, `term`, and `term_label`.+ #' @examples |
||
| 239 | +140 |
- #'+ #' s_count_occurrences_by_grade( |
||
| 240 | +141 |
- #' @examples+ #' df, |
||
| 241 | +142 |
- #' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple)+ #' .N_col = 10L, |
||
| 242 | +143 |
- #' result <- h_coxreg_multivar_extract(+ #' .var = "AETOXGR", |
||
| 243 | +144 |
- #' var = "var1", mod = mod, data = dta_simple+ #' id = "USUBJID", |
||
| 244 | +145 |
- #' )+ #' grade_groups = list("ANY" = levels(df$AETOXGR))
|
||
| 245 | +146 |
- #' result+ #' ) |
||
| 246 | +147 |
#' |
||
| 247 | +148 |
#' @export |
||
| 248 | +149 |
- h_coxreg_multivar_extract <- function(var,+ s_count_occurrences_by_grade <- function(df, |
||
| 249 | +150 |
- data,+ .var, |
||
| 250 | +151 |
- mod,+ .N_col, # nolint |
||
| 251 | +152 |
- control = control_coxreg()) {
+ id = "USUBJID", |
||
| 252 | -132x | +|||
| 153 | +
- test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]+ grade_groups = list(), |
|||
| 253 | -132x | +|||
| 154 | +
- mod_aov <- muffled_car_anova(mod, test_statistic)+ remove_single = TRUE, |
|||
| 254 | +155 |
-
+ only_grade_groups = FALSE, |
||
| 255 | -132x | +|||
| 156 | +
- msum <- summary(mod, conf.int = control$conf_level)+ labelstr = "") {
|
|||
| 256 | -132x | +157 | +11x |
- sum_anova <- broom::tidy(mod_aov)+ assert_valid_factor(df[[.var]]) |
| 257 | -132x | +158 | +11x |
- sum_cox <- broom::tidy(msum)+ assert_df_with_variables(df, list(grade = .var, id = id)) |
| 258 | +159 | |||
| 259 | -132x | +160 | +11x |
- ret_anova <- sum_anova[sum_anova$term == var, c("term", "p.value")]
+ if (nrow(df) < 1) {
|
| 260 | -132x | +161 | +2x |
- names(ret_anova)[2] <- "pval"+ grade_levels <- levels(df[[.var]]) |
| 261 | -132x | +162 | +2x |
- if (is.factor(data[[var]])) {
+ l_count <- as.list(rep(0, length(grade_levels))) |
| 262 | -53x | +163 | +2x |
- ret_cox <- sum_cox[startsWith(prefix = var, x = sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")]+ names(l_count) <- grade_levels |
| 263 | +164 |
} else {
|
||
| 264 | -79x | +165 | +9x |
- ret_cox <- sum_cox[(var == sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")]+ if (isTRUE(is.factor(df[[id]]))) {
+ |
+
| 166 | +! | +
+ assert_valid_factor(df[[id]], any.missing = FALSE) |
||
| 265 | +167 |
- }+ } else {
|
||
| 266 | -132x | +168 | +9x |
- names(ret_cox)[1:4] <- c("pval", "hr", "lcl", "ucl")
+ checkmate::assert_character(df[[id]], min.chars = 1, any.missing = FALSE) |
| 267 | -132x | +|||
| 169 | +
- varlab <- unname(labels_or_names(data[var]))+ } |
|||
| 268 | -132x | +170 | +9x |
- ret_cox$term <- varlab+ checkmate::assert_count(.N_col) |
| 269 | +171 | |||
| 270 | -132x | +172 | +9x |
- if (is.numeric(data[[var]])) {
+ id <- df[[id]] |
| 271 | -79x | +173 | +9x |
- ret <- ret_cox+ grade <- df[[.var]]+ |
+
| 174 | ++ | + | ||
| 272 | -79x | +175 | +9x |
- ret$term_label <- ret$term+ if (!is.ordered(grade)) {
|
| 273 | -53x | +176 | +9x |
- } else if (length(levels(data[[var]])) <= 2) {
+ grade_lbl <- obj_label(grade) |
| 274 | -34x | +177 | +9x |
- ret_anova$pval <- NA+ lvls <- levels(grade) |
| 275 | -34x | +178 | +9x |
- ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")")+ if (sum(grepl("^\\d+$", lvls)) %in% c(0, length(lvls))) {
|
| 276 | -34x | +179 | +8x |
- ret_cox$level <- gsub(var, "", ret_cox$level)+ lvl_ord <- lvls+ |
+
| 180 | ++ |
+ } else {
|
||
| 277 | -34x | +181 | +1x |
- ret_cox$term_label <- ret_cox$level+ lvls[!grepl("^\\d+$", lvls)] <- min(as.numeric(lvls[grepl("^\\d+$", lvls)])) - 1
|
| 278 | -34x | +182 | +1x |
- ret <- dplyr::bind_rows(ret_anova, ret_cox)+ lvl_ord <- levels(grade)[order(as.numeric(lvls))] |
| 279 | +183 |
- } else {
+ } |
||
| 280 | -19x | +184 | +9x |
- ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")")+ grade <- formatters::with_label(factor(grade, levels = lvl_ord, ordered = TRUE), grade_lbl)+ |
+
| 185 | ++ |
+ }+ |
+ ||
| 186 | ++ | + | ||
| 281 | -19x | +187 | +9x |
- ret_cox$level <- gsub(var, "", ret_cox$level)+ missing_lvl <- grepl("missing", tolower(levels(grade)))
|
| 282 | -19x | +188 | +9x |
- ret_cox$term_label <- ret_cox$level+ if (any(missing_lvl)) {
|
| 283 | -19x | +189 | +1x |
- ret <- dplyr::bind_rows(ret_anova, ret_cox)+ grade <- factor( |
| 284 | -+ | |||
| 190 | +1x |
- }+ grade, |
||
| 285 | -+ | |||
| 191 | +1x |
-
+ levels = c(levels(grade)[!missing_lvl], levels(grade)[missing_lvl]), |
||
| 286 | -132x | +192 | +1x |
- as.data.frame(ret)+ ordered = is.ordered(grade) |
| 287 | +193 |
- }+ ) |
| 1 | +194 |
- #' Count number of patients and sum exposure across all patients in columns+ } |
||
| 2 | -+ | |||
| 195 | +9x |
- #'+ df_max <- stats::aggregate(grade ~ id, FUN = max, drop = FALSE) |
||
| 3 | -+ | |||
| 196 | +9x |
- #' @description `r lifecycle::badge("stable")`
+ l_count <- as.list(table(df_max$grade)) |
||
| 4 | +197 |
- #'+ } |
||
| 5 | +198 |
- #' The analyze function [analyze_patients_exposure_in_cols()] creates a layout element to count total numbers of+ |
||
| 6 | -+ | |||
| 199 | +11x |
- #' patients and sum an analysis value (i.e. exposure) across all patients in columns.+ if (length(grade_groups) > 0) {
|
||
| 7 | -+ | |||
| 200 | +6x |
- #'+ l_count <- h_append_grade_groups(grade_groups, l_count, remove_single, only_grade_groups) |
||
| 8 | +201 |
- #' The primary analysis variable `ex_var` is the exposure variable used to calculate the `sum_exposure` statistic. The+ } |
||
| 9 | +202 |
- #' `id` variable is used to uniquely identify patients in the data such that only unique patients are counted in the+ |
||
| 10 | -+ | |||
| 203 | +11x |
- #' `n_patients` statistic, and the `var` variable is used to create a row split if needed. The percentage returned as+ l_count_fraction <- lapply(l_count, function(i, denom) c(i, i / denom), denom = .N_col) |
||
| 11 | +204 |
- #' part of the `n_patients` statistic is the proportion of all records that correspond to a unique patient.+ + |
+ ||
| 205 | +11x | +
+ list(+ |
+ ||
| 206 | +11x | +
+ count_fraction = l_count_fraction |
||
| 12 | +207 |
- #'+ ) |
||
| 13 | +208 |
- #' The summarize function [summarize_patients_exposure_in_cols()] performs the same function as+ } |
||
| 14 | +209 |
- #' [analyze_patients_exposure_in_cols()] except it creates content rows, not data rows, to summarize the current table+ |
||
| 15 | +210 |
- #' row/column context and operates on the level of the latest row split or the root of the table if no row splits have+ #' @describeIn count_occurrences_by_grade Formatted analysis function which is used as `afun` |
||
| 16 | +211 |
- #' occurred.+ #' in `count_occurrences_by_grade()`. |
||
| 17 | +212 |
#' |
||
| 18 | +213 |
- #' If a column split has not yet been performed in the table, `col_split` must be set to `TRUE` for the first call of+ #' @return |
||
| 19 | +214 |
- #' [analyze_patients_exposure_in_cols()] or [summarize_patients_exposure_in_cols()].+ #' * `a_count_occurrences_by_grade()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 20 | +215 |
#' |
||
| 21 | +216 |
- #' @inheritParams argument_convention+ #' @examples |
||
| 22 | +217 |
- #' @param ex_var (`string`)\cr name of the variable in `df` containing exposure values.+ #' # We need to ungroup `count_fraction` first so that the `rtables` formatting |
||
| 23 | +218 |
- #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty, this will be used as label.+ #' # function `format_count_fraction()` can be applied correctly. |
||
| 24 | +219 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run+ #' afun <- make_afun(a_count_occurrences_by_grade, .ungroup_stats = "count_fraction") |
||
| 25 | +220 |
- #' `get_stats("analyze_patients_exposure_in_cols")` to see available statistics for this function.
+ #' afun( |
||
| 26 | +221 |
- #'+ #' df, |
||
| 27 | +222 |
- #' @name summarize_patients_exposure_in_cols+ #' .N_col = 10L, |
||
| 28 | +223 |
- #' @order 1+ #' .var = "AETOXGR", |
||
| 29 | +224 |
- NULL+ #' id = "USUBJID", |
||
| 30 | +225 |
-
+ #' grade_groups = list("ANY" = levels(df$AETOXGR))
|
||
| 31 | +226 |
- #' @describeIn summarize_patients_exposure_in_cols Statistics function which counts numbers+ #' ) |
||
| 32 | +227 |
- #' of patients and the sum of exposure across all patients.+ #' |
||
| 33 | +228 |
- #'+ #' @export |
||
| 34 | +229 |
- #' @return+ a_count_occurrences_by_grade <- make_afun( |
||
| 35 | +230 |
- #' * `s_count_patients_sum_exposure()` returns a named `list` with the statistics:+ s_count_occurrences_by_grade, |
||
| 36 | +231 |
- #' * `n_patients`: Number of unique patients in `df`.+ .formats = c("count_fraction" = format_count_fraction_fixed_dp)
|
||
| 37 | +232 |
- #' * `sum_exposure`: Sum of `ex_var` across all patients in `df`.+ ) |
||
| 38 | +233 |
- #'+ + |
+ ||
| 234 | ++ |
+ #' @describeIn count_occurrences_by_grade Layout-creating function which can take statistics function |
||
| 39 | +235 |
- #' @keywords internal+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 40 | +236 |
- s_count_patients_sum_exposure <- function(df,+ #' |
||
| 41 | +237 |
- ex_var = "AVAL",+ #' @return |
||
| 42 | +238 |
- id = "USUBJID",+ #' * `count_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions, |
||
| 43 | +239 |
- labelstr = "",+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 44 | +240 |
- .stats = c("n_patients", "sum_exposure"),
+ #' the statistics from `s_count_occurrences_by_grade()` to the table layout. |
||
| 45 | +241 |
- .N_col, # nolint+ #' |
||
| 46 | +242 |
- custom_label = NULL) {
+ #' @examples |
||
| 47 | -56x | +|||
| 243 | +
- assert_df_with_variables(df, list(ex_var = ex_var, id = id))+ #' library(dplyr) |
|||
| 48 | -56x | +|||
| 244 | +
- checkmate::assert_string(id)+ #' |
|||
| 49 | -56x | +|||
| 245 | +
- checkmate::assert_string(labelstr)+ #' df <- data.frame( |
|||
| 50 | -56x | +|||
| 246 | +
- checkmate::assert_string(custom_label, null.ok = TRUE)+ #' USUBJID = as.character(c(1:6, 1)), |
|||
| 51 | -56x | +|||
| 247 | +
- checkmate::assert_numeric(df[[ex_var]])+ #' ARM = factor(c("A", "A", "A", "B", "B", "B", "A"), levels = c("A", "B")),
|
|||
| 52 | -56x | +|||
| 248 | +
- checkmate::assert_true(all(.stats %in% c("n_patients", "sum_exposure")))
+ #' AETOXGR = factor(c(1, 2, 3, 4, 1, 2, 3), levels = c(1:5)), |
|||
| 53 | +249 |
-
+ #' AESEV = factor( |
||
| 54 | -56x | +|||
| 250 | +
- row_label <- if (labelstr != "") {
+ #' x = c("MILD", "MODERATE", "SEVERE", "MILD", "MILD", "MODERATE", "SEVERE"),
|
|||
| 55 | -! | +|||
| 251 | +
- labelstr+ #' levels = c("MILD", "MODERATE", "SEVERE")
|
|||
| 56 | -56x | +|||
| 252 | +
- } else if (!is.null(custom_label)) {
+ #' ), |
|||
| 57 | -48x | +|||
| 253 | +
- custom_label+ #' stringsAsFactors = FALSE |
|||
| 58 | +254 |
- } else {
+ #' ) |
||
| 59 | -8x | +|||
| 255 | +
- "Total patients numbers/person time"+ #' |
|||
| 60 | +256 |
- }+ #' df_adsl <- df %>% |
||
| 61 | +257 |
-
+ #' select(USUBJID, ARM) %>% |
||
| 62 | -56x | +|||
| 258 | +
- y <- list()+ #' unique() |
|||
| 63 | +259 |
-
+ #' |
||
| 64 | -56x | +|||
| 260 | +
- if ("n_patients" %in% .stats) {
+ #' # Layout creating function with custom format. |
|||
| 65 | -23x | +|||
| 261 | +
- y$n_patients <-+ #' basic_table() %>% |
|||
| 66 | -23x | +|||
| 262 | +
- formatters::with_label(+ #' split_cols_by("ARM") %>%
|
|||
| 67 | -23x | +|||
| 263 | +
- s_num_patients_content(+ #' add_colcounts() %>% |
|||
| 68 | -23x | +|||
| 264 | +
- df = df,+ #' count_occurrences_by_grade( |
|||
| 69 | -23x | +|||
| 265 | +
- .N_col = .N_col, # nolint+ #' var = "AESEV", |
|||
| 70 | -23x | +|||
| 266 | +
- .var = id,+ #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
|
|||
| 71 | -23x | +|||
| 267 | +
- labelstr = ""+ #' ) %>% |
|||
| 72 | -23x | +|||
| 268 | +
- )$unique,+ #' build_table(df, alt_counts_df = df_adsl) |
|||
| 73 | -23x | +|||
| 269 | +
- row_label+ #' |
|||
| 74 | +270 |
- )+ #' # Define additional grade groupings. |
||
| 75 | +271 |
- }+ #' grade_groups <- list( |
||
| 76 | -56x | +|||
| 272 | +
- if ("sum_exposure" %in% .stats) {
+ #' "-Any-" = c("1", "2", "3", "4", "5"),
|
|||
| 77 | -34x | +|||
| 273 | +
- y$sum_exposure <- formatters::with_label(sum(df[[ex_var]]), row_label)+ #' "Grade 1-2" = c("1", "2"),
|
|||
| 78 | +274 |
- }+ #' "Grade 3-5" = c("3", "4", "5")
|
||
| 79 | -56x | +|||
| 275 | +
- y+ #' ) |
|||
| 80 | +276 |
- }+ #' |
||
| 81 | +277 |
-
+ #' basic_table() %>% |
||
| 82 | +278 |
- #' @describeIn summarize_patients_exposure_in_cols Analysis function which is used as `afun` in+ #' split_cols_by("ARM") %>%
|
||
| 83 | +279 |
- #' [rtables::analyze_colvars()] within `analyze_patients_exposure_in_cols()` and as `cfun` in+ #' add_colcounts() %>% |
||
| 84 | +280 |
- #' [rtables::summarize_row_groups()] within `summarize_patients_exposure_in_cols()`.+ #' count_occurrences_by_grade( |
||
| 85 | +281 |
- #'+ #' var = "AETOXGR", |
||
| 86 | +282 |
- #' @return+ #' grade_groups = grade_groups, |
||
| 87 | +283 |
- #' * `a_count_patients_sum_exposure()` returns formatted [rtables::CellValue()].+ #' only_grade_groups = TRUE |
||
| 88 | +284 |
- #'+ #' ) %>% |
||
| 89 | +285 |
- #' @examples+ #' build_table(df, alt_counts_df = df_adsl) |
||
| 90 | +286 |
- #' a_count_patients_sum_exposure(+ #' |
||
| 91 | +287 |
- #' df = df,+ #' @export |
||
| 92 | +288 |
- #' var = "SEX",+ #' @order 2 |
||
| 93 | +289 |
- #' .N_col = nrow(df),+ count_occurrences_by_grade <- function(lyt, |
||
| 94 | +290 |
- #' .stats = "n_patients"+ var, |
||
| 95 | +291 |
- #' )+ id = "USUBJID", |
||
| 96 | +292 |
- #'+ grade_groups = list(), |
||
| 97 | +293 |
- #' @export+ remove_single = TRUE, |
||
| 98 | +294 |
- a_count_patients_sum_exposure <- function(df,+ only_grade_groups = FALSE, |
||
| 99 | +295 |
- var = NULL,+ var_labels = var, |
||
| 100 | +296 |
- ex_var = "AVAL",+ show_labels = "default", |
||
| 101 | +297 |
- id = "USUBJID",+ riskdiff = FALSE, |
||
| 102 | +298 |
- add_total_level = FALSE,+ na_str = default_na_str(), |
||
| 103 | +299 |
- custom_label = NULL,+ nested = TRUE, |
||
| 104 | +300 |
- labelstr = "",+ ..., |
||
| 105 | +301 |
- .N_col, # nolint+ table_names = var, |
||
| 106 | +302 |
- .stats,+ .stats = NULL, |
||
| 107 | +303 |
- .formats = list(n_patients = "xx (xx.x%)", sum_exposure = "xx")) {
+ .formats = NULL, |
||
| 108 | -32x | +|||
| 304 | +
- checkmate::assert_flag(add_total_level)+ .indent_mods = NULL, |
|||
| 109 | +305 |
-
+ .labels = NULL) {
|
||
| 110 | -32x | +306 | +11x |
- if (!is.null(var)) {
+ checkmate::assert_flag(riskdiff) |
| 111 | -21x | +307 | +11x |
- assert_df_with_variables(df, list(var = var))+ s_args <- list( |
| 112 | -21x | +308 | +11x |
- df[[var]] <- as.factor(df[[var]])+ id = id, grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups, ... |
| 113 | +309 |
- }+ ) |
||
| 114 | +310 | |||
| 115 | -32x | -
- y <- list()- |
- ||
| 116 | -32x | +311 | +11x |
- if (is.null(var)) {
+ afun <- make_afun( |
| 117 | +312 | 11x |
- y[[.stats]] <- list(Total = s_count_patients_sum_exposure(+ a_count_occurrences_by_grade, |
|
| 118 | +313 | 11x |
- df = df,+ .stats = .stats, |
|
| 119 | +314 | 11x |
- ex_var = ex_var,+ .formats = .formats, |
|
| 120 | +315 | 11x |
- id = id,+ .indent_mods = .indent_mods, |
|
| 121 | +316 | 11x |
- labelstr = labelstr,+ .ungroup_stats = "count_fraction" |
|
| 122 | -11x | +|||
| 317 | +
- .N_col = .N_col,+ ) |
|||
| 123 | -11x | +|||
| 318 | +
- .stats = .stats,+ |
|||
| 124 | +319 | 11x |
- custom_label = custom_label+ extra_args <- if (isFALSE(riskdiff)) {
|
|
| 125 | -11x | +320 | +9x |
- )[[.stats]])+ s_args |
| 126 | +321 |
} else {
|
||
| 127 | -21x | -
- for (lvl in levels(df[[var]])) {
- |
- ||
| 128 | -42x | -
- y[[.stats]][[lvl]] <- s_count_patients_sum_exposure(- |
- ||
| 129 | -42x | -
- df = subset(df, get(var) == lvl),- |
- ||
| 130 | -42x | +322 | +2x |
- ex_var = ex_var,+ list( |
| 131 | -42x | +323 | +2x |
- id = id,+ afun = list("s_count_occurrences_by_grade" = afun),
|
| 132 | -42x | +324 | +2x |
- labelstr = labelstr,+ .stats = .stats, |
| 133 | -42x | +325 | +2x |
- .N_col = .N_col,+ .indent_mods = .indent_mods, |
| 134 | -42x | +326 | +2x |
- .stats = .stats,+ s_args = s_args |
| 135 | -42x | +|||
| 327 | +
- custom_label = lvl+ ) |
|||
| 136 | -42x | +|||
| 328 | +
- )[[.stats]]+ } |
|||
| 137 | +329 |
- }+ |
||
| 138 | -21x | +330 | +11x |
- if (add_total_level) {
+ analyze( |
| 139 | -2x | +331 | +11x |
- y[[.stats]][["Total"]] <- s_count_patients_sum_exposure(+ lyt = lyt, |
| 140 | -2x | +332 | +11x |
- df = df,+ vars = var, |
| 141 | -2x | +333 | +11x |
- ex_var = ex_var,+ var_labels = var_labels, |
| 142 | -2x | +334 | +11x |
- id = id,+ show_labels = show_labels, |
| 143 | -2x | +335 | +11x |
- labelstr = labelstr,+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff), |
| 144 | -2x | +336 | +11x |
- .N_col = .N_col,+ table_names = table_names, |
| 145 | -2x | +337 | +11x |
- .stats = .stats,+ na_str = na_str, |
| 146 | -2x | +338 | +11x |
- custom_label = custom_label+ nested = nested, |
| 147 | -2x | +339 | +11x |
- )[[.stats]]+ extra_args = extra_args |
| 148 | +340 |
- }+ ) |
||
| 149 | +341 |
- }+ } |
||
| 150 | +342 | |||
| 151 | -32x | -
- in_rows(.list = y[[.stats]], .formats = .formats[[.stats]])- |
- ||
| 152 | +343 |
- }+ #' @describeIn count_occurrences_by_grade Layout-creating function which can take content function arguments |
||
| 153 | +344 |
-
+ #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 154 | +345 |
- #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics+ #' |
||
| 155 | +346 |
- #' function arguments and additional format arguments. This function is a wrapper for+ #' @return |
||
| 156 | +347 |
- #' [rtables::split_cols_by_multivar()] and [rtables::summarize_row_groups()].+ #' * `summarize_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions, |
||
| 157 | +348 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows |
||
| 158 | +349 |
- #' @return+ #' containing the statistics from `s_count_occurrences_by_grade()` to the table layout. |
||
| 159 | +350 |
- #' * `summarize_patients_exposure_in_cols()` returns a layout object suitable for passing to further+ #' |
||
| 160 | +351 |
- #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will+ #' @examples |
||
| 161 | +352 |
- #' add formatted content rows, with the statistics from `s_count_patients_sum_exposure()` arranged in+ #' # Layout creating function with custom format. |
||
| 162 | +353 |
- #' columns, to the table layout.+ #' basic_table() %>% |
||
| 163 | +354 |
- #'+ #' add_colcounts() %>% |
||
| 164 | +355 |
- #' @examples+ #' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
|
||
| 165 | +356 |
- #' lyt5 <- basic_table() %>%+ #' summarize_occurrences_by_grade( |
||
| 166 | +357 |
- #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE)+ #' var = "AESEV", |
||
| 167 | +358 |
- #'+ #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
|
||
| 168 | +359 |
- #' result5 <- build_table(lyt5, df = df, alt_counts_df = adsl)+ #' ) %>% |
||
| 169 | +360 |
- #' result5+ #' build_table(df, alt_counts_df = df_adsl) |
||
| 170 | +361 |
#' |
||
| 171 | +362 |
- #' lyt6 <- basic_table() %>%+ #' basic_table() %>% |
||
| 172 | +363 |
- #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE, .stats = "sum_exposure")+ #' add_colcounts() %>% |
||
| 173 | +364 |
- #'+ #' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
|
||
| 174 | +365 |
- #' result6 <- build_table(lyt6, df = df, alt_counts_df = adsl)+ #' summarize_occurrences_by_grade( |
||
| 175 | +366 |
- #' result6+ #' var = "AETOXGR", |
||
| 176 | +367 |
- #'+ #' grade_groups = grade_groups |
||
| 177 | +368 |
- #' @export+ #' ) %>% |
||
| 178 | +369 |
- #' @order 3+ #' build_table(df, alt_counts_df = df_adsl) |
||
| 179 | +370 |
- summarize_patients_exposure_in_cols <- function(lyt, # nolint+ #' |
||
| 180 | +371 |
- var,+ #' @export |
||
| 181 | +372 |
- ex_var = "AVAL",+ #' @order 3 |
||
| 182 | +373 |
- id = "USUBJID",+ summarize_occurrences_by_grade <- function(lyt, |
||
| 183 | +374 |
- add_total_level = FALSE,+ var, |
||
| 184 | +375 |
- custom_label = NULL,+ id = "USUBJID", |
||
| 185 | +376 |
- col_split = TRUE,+ grade_groups = list(), |
||
| 186 | +377 |
- na_str = default_na_str(),+ remove_single = TRUE, |
||
| 187 | +378 |
- ...,+ only_grade_groups = FALSE, |
||
| 188 | +379 |
- .stats = c("n_patients", "sum_exposure"),
+ na_str = default_na_str(), |
||
| 189 | +380 |
- .labels = c(n_patients = "Patients", sum_exposure = "Person time"),+ ..., |
||
| 190 | +381 |
- .indent_mods = NULL) {
- |
- ||
| 191 | -3x | -
- extra_args <- list(ex_var = ex_var, id = id, add_total_level = add_total_level, custom_label = custom_label, ...)+ .stats = NULL, |
||
| 192 | +382 | - - | -||
| 193 | -3x | -
- if (col_split) {
- |
- ||
| 194 | -3x | -
- lyt <- split_cols_by_multivar(+ .formats = NULL, |
||
| 195 | -3x | +|||
| 383 | +
- lyt = lyt,+ .indent_mods = NULL, |
|||
| 196 | -3x | +|||
| 384 | +
- vars = rep(var, length(.stats)),+ .labels = NULL) {
|
|||
| 197 | +385 | 3x |
- varlabels = .labels[.stats],+ extra_args <- list( |
|
| 198 | +386 | 3x |
- extra_args = list(.stats = .stats)+ id = id, grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups, ... |
|
| 199 | +387 |
- )+ ) |
||
| 200 | +388 |
- }+ |
||
| 201 | +389 | 3x |
- summarize_row_groups(+ cfun <- make_afun( |
|
| 202 | +390 | 3x |
- lyt = lyt,+ a_count_occurrences_by_grade, |
|
| 203 | +391 | 3x |
- var = var,+ .stats = .stats, |
|
| 204 | +392 | 3x |
- cfun = a_count_patients_sum_exposure,+ .formats = .formats, |
|
| 205 | +393 | 3x |
- na_str = na_str,+ .labels = .labels, |
|
| 206 | +394 | 3x |
- extra_args = extra_args+ .indent_mods = .indent_mods, |
|
| 207 | -+ | |||
| 395 | +3x |
- )+ .ungroup_stats = "count_fraction" |
||
| 208 | +396 |
- }+ ) |
||
| 209 | +397 | |||
| 210 | -- |
- #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics- |
- ||
| 211 | -- |
- #' function arguments and additional format arguments. This function is a wrapper for- |
- ||
| 212 | -- |
- #' [rtables::split_cols_by_multivar()] and [rtables::analyze_colvars()].- |
- ||
| 213 | -- |
- #'- |
- ||
| 214 | -- |
- #' @param col_split (`flag`)\cr whether the columns should be split. Set to `FALSE` when the required- |
- ||
| 215 | -- |
- #' column split has been done already earlier in the layout pipe.- |
- ||
| 216 | -- |
- #'- |
- ||
| 217 | -- |
- #' @return- |
- ||
| 218 | -- |
- #' * `analyze_patients_exposure_in_cols()` returns a layout object suitable for passing to further- |
- ||
| 219 | -- |
- #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will- |
- ||
| 220 | -- |
- #' add formatted data rows, with the statistics from `s_count_patients_sum_exposure()` arranged in- |
- ||
| 221 | -- |
- #' columns, to the table layout.- |
- ||
| 222 | -- |
- #'- |
- ||
| 223 | -- |
- #' @note As opposed to [summarize_patients_exposure_in_cols()] which generates content rows,- |
- ||
| 224 | -- |
- #' `analyze_patients_exposure_in_cols()` generates data rows which will _not_ be repeated on multiple- |
- ||
| 225 | -- |
- #' pages when pagination is used.- |
- ||
| 226 | -- |
- #'- |
- ||
| 227 | -- |
- #' @examples- |
- ||
| 228 | -- |
- #' set.seed(1)- |
- ||
| 229 | -+ | |||
| 398 | +3x |
- #' df <- data.frame(+ summarize_row_groups( |
||
| 230 | -+ | |||
| 399 | +3x |
- #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
- |
- ||
| 231 | -+ | |||
| 400 | +3x |
- #' ARMCD = c(rep("ARM A", 6), rep("ARM B", 6)),
+ var = var, |
||
| 232 | -+ | |||
| 401 | +3x |
- #' SEX = c(rep("Female", 6), rep("Male", 6)),
+ cfun = cfun, |
||
| 233 | -+ | |||
| 402 | +3x |
- #' AVAL = as.numeric(sample(seq(1, 20), 12)),+ na_str = na_str, |
||
| 234 | -+ | |||
| 403 | +3x |
- #' stringsAsFactors = TRUE+ extra_args = extra_args |
||
| 235 | +404 |
- #' )+ ) |
||
| 236 | +405 |
- #' adsl <- data.frame(+ } |
| 237 | +1 |
- #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
+ #' Control function for subgroup treatment effect pattern (STEP) calculations |
||
| 238 | +2 |
- #' ARMCD = c(rep("ARM A", 2), rep("ARM B", 2)),
+ #' |
||
| 239 | +3 |
- #' SEX = c(rep("Female", 2), rep("Male", 2)),
+ #' @description `r lifecycle::badge("stable")`
|
||
| 240 | +4 |
- #' stringsAsFactors = TRUE+ #' |
||
| 241 | +5 |
- #' )+ #' This is an auxiliary function for controlling arguments for STEP calculations. |
||
| 242 | +6 |
#' |
||
| 243 | +7 |
- #' lyt <- basic_table() %>%+ #' @param biomarker (`numeric` or `NULL`)\cr optional provision of the numeric biomarker variable, which |
||
| 244 | +8 |
- #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
+ #' could be used to infer `bandwidth`, see below. |
||
| 245 | +9 |
- #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) %>%+ #' @param use_percentile (`flag`)\cr if `TRUE`, the running windows are created according to |
||
| 246 | +10 |
- #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE)+ #' quantiles rather than actual values, i.e. the bandwidth refers to the percentage of data |
||
| 247 | +11 |
- #' result <- build_table(lyt, df = df, alt_counts_df = adsl)+ #' covered in each window. Suggest `TRUE` if the biomarker variable is not uniformly |
||
| 248 | +12 |
- #' result+ #' distributed. |
||
| 249 | +13 |
- #'+ #' @param bandwidth (`numeric(1)` or `NULL`)\cr indicating the bandwidth of each window. |
||
| 250 | +14 |
- #' lyt2 <- basic_table() %>%+ #' Depending on the argument `use_percentile`, it can be either the length of actual-value |
||
| 251 | +15 |
- #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
+ #' windows on the real biomarker scale, or percentage windows. |
||
| 252 | +16 |
- #' summarize_patients_exposure_in_cols(+ #' If `use_percentile = TRUE`, it should be a number between 0 and 1. |
||
| 253 | +17 |
- #' var = "AVAL", col_split = TRUE,+ #' If `NULL`, treat the bandwidth to be infinity, which means only one global model will be fitted. |
||
| 254 | +18 |
- #' .stats = "n_patients", custom_label = "some custom label"+ #' By default, `0.25` is used for percentage windows and one quarter of the range of the `biomarker` |
||
| 255 | +19 |
- #' ) %>%+ #' variable for actual-value windows. |
||
| 256 | +20 |
- #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE, ex_var = "AVAL")+ #' @param degree (`integer(1)`)\cr the degree of polynomial function of the biomarker as an interaction term |
||
| 257 | +21 |
- #' result2 <- build_table(lyt2, df = df, alt_counts_df = adsl)+ #' with the treatment arm fitted at each window. If 0 (default), then the biomarker variable |
||
| 258 | +22 |
- #' result2+ #' is not included in the model fitted in each biomarker window. |
||
| 259 | +23 |
- #'+ #' @param num_points (`integer(1)`)\cr the number of points at which the hazard ratios are estimated. The |
||
| 260 | +24 |
- #' lyt3 <- basic_table() %>%+ #' smallest number is 2. |
||
| 261 | +25 |
- #' analyze_patients_exposure_in_cols(var = "SEX", col_split = TRUE, ex_var = "AVAL")+ #' |
||
| 262 | +26 |
- #' result3 <- build_table(lyt3, df = df, alt_counts_df = adsl)+ #' @return A list of components with the same names as the arguments, except `biomarker` which is |
||
| 263 | +27 |
- #' result3+ #' just used to calculate the `bandwidth` in case that actual biomarker windows are requested. |
||
| 264 | +28 |
#' |
||
| 265 | +29 |
- #' # Adding total levels and custom label+ #' @examples |
||
| 266 | +30 |
- #' lyt4 <- basic_table(+ #' # Provide biomarker values and request actual values to be used, |
||
| 267 | +31 |
- #' show_colcounts = TRUE+ #' # so that bandwidth is chosen from range. |
||
| 268 | +32 |
- #' ) %>%+ #' control_step(biomarker = 1:10, use_percentile = FALSE) |
||
| 269 | +33 |
- #' analyze_patients_exposure_in_cols(+ #' |
||
| 270 | +34 |
- #' var = "ARMCD",+ #' # Use a global model with quadratic biomarker interaction term. |
||
| 271 | +35 |
- #' col_split = TRUE,+ #' control_step(bandwidth = NULL, degree = 2) |
||
| 272 | +36 |
- #' add_total_level = TRUE,+ #' |
||
| 273 | +37 |
- #' custom_label = "TOTAL"+ #' # Reduce number of points to be used. |
||
| 274 | +38 |
- #' ) %>%+ #' control_step(num_points = 10) |
||
| 275 | +39 |
- #' append_topleft(c("", "Sex"))
+ #' |
||
| 276 | +40 |
- #'+ #' @export |
||
| 277 | +41 |
- #' result4 <- build_table(lyt4, df = df, alt_counts_df = adsl)+ control_step <- function(biomarker = NULL, |
||
| 278 | +42 |
- #' result4+ use_percentile = TRUE, |
||
| 279 | +43 |
- #'+ bandwidth, |
||
| 280 | +44 |
- #' @export+ degree = 0L, |
||
| 281 | +45 |
- #' @order 2+ num_points = 39L) {
|
||
| 282 | -+ | |||
| 46 | +31x |
- analyze_patients_exposure_in_cols <- function(lyt, # nolint+ checkmate::assert_numeric(biomarker, null.ok = TRUE) |
||
| 283 | -+ | |||
| 47 | +30x |
- var = NULL,+ checkmate::assert_flag(use_percentile) |
||
| 284 | -+ | |||
| 48 | +30x |
- ex_var = "AVAL",+ checkmate::assert_int(num_points, lower = 2) |
||
| 285 | -+ | |||
| 49 | +29x |
- id = "USUBJID",+ checkmate::assert_count(degree) |
||
| 286 | +50 |
- add_total_level = FALSE,+ |
||
| 287 | -+ | |||
| 51 | +29x |
- custom_label = NULL,+ if (missing(bandwidth)) {
|
||
| 288 | +52 |
- col_split = TRUE,+ # Infer bandwidth |
||
| 289 | -+ | |||
| 53 | +21x |
- na_str = default_na_str(),+ bandwidth <- if (use_percentile) {
|
||
| 290 | -+ | |||
| 54 | +18x |
- .stats = c("n_patients", "sum_exposure"),
+ 0.25 |
||
| 291 | -+ | |||
| 55 | +21x |
- .labels = c(n_patients = "Patients", sum_exposure = "Person time"),+ } else if (!is.null(biomarker)) {
|
||
| 292 | -+ | |||
| 56 | +3x |
- .indent_mods = 0L,+ diff(range(biomarker, na.rm = TRUE)) / 4 |
||
| 293 | +57 |
- ...) {
+ } else {
|
||
| 294 | -6x | +|||
| 58 | +! |
- extra_args <- list(+ NULL |
||
| 295 | -6x | +|||
| 59 | +
- var = var, ex_var = ex_var, id = id, add_total_level = add_total_level, custom_label = custom_label, ...+ } |
|||
| 296 | +60 |
- )+ } else {
|
||
| 297 | +61 |
-
+ # Check bandwidth |
||
| 298 | -6x | +62 | +8x |
- if (col_split) {
+ if (!is.null(bandwidth)) {
|
| 299 | -4x | +63 | +5x |
- lyt <- split_cols_by_multivar(+ if (use_percentile) {
|
| 300 | +64 | 4x |
- lyt = lyt,+ assert_proportion_value(bandwidth) |
|
| 301 | -4x | +|||
| 65 | +
- vars = rep(ex_var, length(.stats)),+ } else {
|
|||
| 302 | -4x | +66 | +1x |
- varlabels = .labels[.stats],+ checkmate::assert_scalar(bandwidth) |
| 303 | -4x | +67 | +1x |
- extra_args = list(.stats = .stats)+ checkmate::assert_true(bandwidth > 0) |
| 304 | +68 |
- )+ } |
||
| 305 | +69 | ++ |
+ }+ |
+ |
| 70 |
} |
|||
| 306 | -6x | +71 | +28x |
- lyt <- lyt %>% analyze_colvars(+ list( |
| 307 | -6x | +72 | +28x |
- afun = a_count_patients_sum_exposure,+ use_percentile = use_percentile, |
| 308 | -6x | +73 | +28x |
- indent_mod = .indent_mods,+ bandwidth = bandwidth, |
| 309 | -6x | +74 | +28x |
- na_str = na_str,+ degree = as.integer(degree), |
| 310 | -6x | +75 | +28x |
- extra_args = extra_args+ num_points = as.integer(num_points) |
| 311 | +76 |
) |
||
| 312 | -6x | -
- lyt- |
- ||
| 313 | +77 |
}@@ -124126,14 +123476,14 @@ tern coverage - 95.64% |
| 1 |
- #' Survival time point analysis+ #' Univariate formula special term |
|||
| 5 |
- #' The analyze function [surv_timepoint()] creates a layout element to analyze patient survival rates and difference+ #' The special term `univariate` indicate that the model should be fitted individually for |
|||
| 6 |
- #' of survival rates between groups at a given time point. The primary analysis variable `vars` is the time variable.+ #' every variable included in univariate. |
|||
| 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+ #' @param x (`character`)\cr a vector of variable names separated by commas. |
|||
| 9 |
- #' survival estimations (`"surv"`), difference in survival with the control (`"surv_diff"`), or both of these+ #' |
|||
| 10 |
- #' (`"both"`).+ #' @return When used within a model formula, produces univariate models for each variable provided. |
|||
| 12 |
- #' @inheritParams argument_convention+ #' @details |
|||
| 13 |
- #' @inheritParams s_surv_time+ #' If provided alongside with pairwise specification, the model |
|||
| 14 |
- #' @param time_point (`numeric(1)`)\cr survival time point of interest.+ #' `y ~ ARM + univariate(SEX, AGE, RACE)` lead to the study and comparison of the models |
|||
| 15 |
- #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function+ #' + `y ~ ARM` |
|||
| 16 |
- #' [control_surv_timepoint()]. Some possible parameter options are:+ #' + `y ~ ARM + SEX` |
|||
| 17 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate.+ #' + `y ~ ARM + AGE` |
|||
| 18 |
- #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log",+ #' + `y ~ ARM + RACE` |
|||
| 19 |
- #' see more in [survival::survfit()]. Note option "none" is no longer supported.+ #' |
|||
| 20 |
- #' @param method (`string`)\cr `"surv"` (survival estimations), `"surv_diff"` (difference in survival with the+ #' @export |
|||
| 21 |
- #' control), or `"both"`.+ univariate <- function(x) {
|
|||
| 22 | -+ | 2x |
- #' @param table_names_suffix (`string`)\cr optional suffix for the `table_names` used for the `rtables` to+ structure(x, varname = deparse(substitute(x))) |
|
| 23 |
- #' avoid warnings from duplicate table names.+ } |
|||
| 24 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("surv_timepoint")`
+
|
|||
| 25 |
- #' to see available statistics for this function.+ # Get the right-hand-term of a formula |
|||
| 26 |
- #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector+ rht <- function(x) {
|
|||
| 27 | -+ | 4x |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ checkmate::assert_formula(x) |
|
| 28 | -+ | 4x |
- #' for that statistic's row label.+ y <- as.character(rev(x)[[1]]) |
|
| 29 | -+ | 4x |
- #'+ return(y) |
|
| 30 |
- #' @name survival_timepoint+ } |
|||
| 31 |
- #' @order 1+ |
|||
| 32 |
- NULL+ #' Hazard ratio estimation in interactions |
|||
| 33 |
-
+ #' |
|||
| 34 |
- #' @describeIn survival_timepoint Statistics function which analyzes survival rate.+ #' This function estimates the hazard ratios between arms when an interaction variable is given with |
|||
| 35 |
- #'+ #' specific values. |
|||
| 36 |
- #' @return+ #' |
|||
| 37 |
- #' * `s_surv_timepoint()` returns the statistics:+ #' @param variable,given (`character(2)`)\cr names of the two variables in the interaction. We seek the estimation of |
|||
| 38 |
- #' * `pt_at_risk`: Patients remaining at risk.+ #' the levels of `variable` given the levels of `given`. |
|||
| 39 |
- #' * `event_free_rate`: Event-free rate (%).+ #' @param lvl_var,lvl_given (`character`)\cr corresponding levels given by [levels()]. |
|||
| 40 |
- #' * `rate_se`: Standard error of event free rate.+ #' @param mmat (named `numeric`) a vector filled with `0`s used as a template to obtain the design matrix. |
|||
| 41 |
- #' * `rate_ci`: Confidence interval for event free rate.+ #' @param coef (`numeric`)\cr vector of estimated coefficients. |
|||
| 42 |
- #'+ #' @param vcov (`matrix`)\cr variance-covariance matrix of underlying model. |
|||
| 43 |
- #' @keywords internal+ #' @param conf_level (`proportion`)\cr confidence level of estimate intervals. |
|||
| 44 |
- s_surv_timepoint <- function(df,+ #' |
|||
| 45 |
- .var,+ #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A) |
|||
| 46 |
- time_point,+ #' and Sex (F, M; reference Female). The model is abbreviated: y ~ Arm + Sex + Arm x Sex. |
|||
| 47 |
- is_event,+ #' The cox regression estimates the coefficients along with a variance-covariance matrix for: |
|||
| 48 |
- control = control_surv_timepoint()) {
+ #' |
|||
| 49 | -23x | +
- checkmate::assert_string(.var)+ #' - b1 (arm b), b2 (arm c) |
||
| 50 | -23x | +
- assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ #' - b3 (sex m) |
||
| 51 | -23x | +
- checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE)+ #' - b4 (arm b: sex m), b5 (arm c: sex m) |
||
| 52 | -23x | +
- checkmate::assert_number(time_point)+ #' |
||
| 53 | -23x | +
- checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)+ #' 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 | -23x | +
- conf_type <- control$conf_type+ #' therefore the interaction coefficient is given by b2 + b5 while the standard error is obtained |
||
| 56 | -23x | +
- conf_level <- control$conf_level+ #' as $1.96 * sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$ for a confidence level of 0.95. |
||
| 57 |
-
+ #' |
|||
| 58 | -23x | +
- formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
+ #' @return A list of matrices (one per level of variable) with rows corresponding to the combinations of |
||
| 59 | -23x | +
- srv_fit <- survival::survfit(+ #' `variable` and `given`, with columns: |
||
| 60 | -23x | +
- formula = formula,+ #' * `coef_hat`: Estimation of the coefficient. |
||
| 61 | -23x | +
- data = df,+ #' * `coef_se`: Standard error of the estimation. |
||
| 62 | -23x | +
- conf.int = conf_level,+ #' * `hr`: Hazard ratio. |
||
| 63 | -23x | +
- conf.type = conf_type+ #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio. |
||
| 64 |
- )+ #' |
|||
| 65 | -23x | +
- s_srv_fit <- summary(srv_fit, times = time_point, extend = TRUE)+ #' @seealso [s_cox_multivariate()]. |
||
| 66 | -23x | +
- df_srv_fit <- as.data.frame(s_srv_fit[c("time", "n.risk", "surv", "lower", "upper", "std.err")])
+ #' |
||
| 67 | -23x | +
- if (df_srv_fit[["n.risk"]] == 0) {
+ #' @examples |
||
| 68 | -1x | +
- pt_at_risk <- event_free_rate <- rate_se <- NA_real_+ #' library(dplyr) |
||
| 69 | -1x | +
- rate_ci <- c(NA_real_, NA_real_)+ #' library(survival) |
||
| 70 |
- } else {
+ #' |
|||
| 71 | -22x | +
- pt_at_risk <- df_srv_fit$n.risk+ #' ADSL <- tern_ex_adsl %>% |
||
| 72 | -22x | +
- event_free_rate <- df_srv_fit$surv+ #' filter(SEX %in% c("F", "M"))
|
||
| 73 | -22x | +
- rate_se <- df_srv_fit$std.err+ #' |
||
| 74 | -22x | +
- rate_ci <- c(df_srv_fit$lower, df_srv_fit$upper)+ #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "PFS") |
||
| 75 |
- }+ #' adtte$ARMCD <- droplevels(adtte$ARMCD) |
|||
| 76 | -23x | +
- list(+ #' adtte$SEX <- droplevels(adtte$SEX) |
||
| 77 | -23x | +
- pt_at_risk = formatters::with_label(pt_at_risk, "Patients remaining at risk"),+ #' |
||
| 78 | -23x | +
- event_free_rate = formatters::with_label(event_free_rate * 100, "Event Free Rate (%)"),+ #' mod <- coxph( |
||
| 79 | -23x | +
- rate_se = formatters::with_label(rate_se * 100, "Standard Error of Event Free Rate"),+ #' formula = Surv(time = AVAL, event = 1 - CNSR) ~ (SEX + ARMCD)^2, |
||
| 80 | -23x | +
- rate_ci = formatters::with_label(rate_ci * 100, f_conf_level(conf_level))+ #' data = adtte |
||
| 81 |
- )+ #' ) |
|||
| 82 |
- }+ #' |
|||
| 83 |
-
+ #' mmat <- stats::model.matrix(mod)[1, ] |
|||
| 84 |
- #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()`+ #' mmat[!mmat == 0] <- 0 |
|||
| 85 |
- #' when `method = "surv"`.+ #' |
|||
| 86 |
- #'+ #' @keywords internal |
|||
| 87 |
- #' @return+ estimate_coef <- function(variable, given, |
|||
| 88 |
- #' * `a_surv_timepoint()` returns the corresponding list with formatted [rtables::CellValue()].+ lvl_var, lvl_given, |
|||
| 89 |
- #'+ coef, |
|||
| 90 |
- #' @keywords internal+ mmat, |
|||
| 91 |
- a_surv_timepoint <- make_afun(+ vcov, |
|||
| 92 |
- s_surv_timepoint,+ conf_level = 0.95) {
|
|||
| 93 | -+ | 8x |
- .indent_mods = c(+ var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level |
|
| 94 | -+ | 8x |
- pt_at_risk = 0L,+ giv_lvl <- paste0(given, lvl_given) |
|
| 95 |
- event_free_rate = 0L,+ |
|||
| 96 | -+ | 8x |
- rate_se = 1L,+ design_mat <- expand.grid(variable = var_lvl, given = giv_lvl) |
|
| 97 | -+ | 8x |
- rate_ci = 1L+ design_mat <- design_mat[order(design_mat$variable, design_mat$given), ] |
|
| 98 | -+ | 8x |
- ),+ design_mat <- within( |
|
| 99 | -+ | 8x |
- .formats = c(+ data = design_mat, |
|
| 100 | -+ | 8x |
- pt_at_risk = "xx",+ expr = {
|
|
| 101 | -+ | 8x |
- event_free_rate = "xx.xx",+ inter <- paste0(variable, ":", given) |
|
| 102 | -+ | 8x |
- rate_se = "xx.xx",+ rev_inter <- paste0(given, ":", variable) |
|
| 103 |
- rate_ci = "(xx.xx, xx.xx)"+ } |
|||
| 105 |
- )+ |
|||
| 106 | -+ | 8x |
-
+ split_by_variable <- design_mat$variable |
|
| 107 | -+ | 8x |
- #' @describeIn survival_timepoint Statistics function which analyzes difference between two survival rates.+ interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/") |
|
| 108 |
- #'+ |
|||
| 109 | -+ | 8x |
- #' @return+ design_mat <- apply( |
|
| 110 | -+ | 8x |
- #' * `s_surv_timepoint_diff()` returns the statistics:+ X = design_mat, MARGIN = 1, FUN = function(x) {
|
|
| 111 | -+ | 27x |
- #' * `rate_diff`: Event-free rate difference between two groups.+ mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1 |
|
| 112 | -+ | 27x |
- #' * `rate_diff_ci`: Confidence interval for the difference.+ return(mmat) |
|
| 113 |
- #' * `ztest_pval`: p-value to test the difference is 0.+ } |
|||
| 114 |
- #'+ ) |
|||
| 115 | -+ | 8x |
- #' @keywords internal+ colnames(design_mat) <- interaction_names |
|
| 116 |
- s_surv_timepoint_diff <- function(df,+ |
|||
| 117 | -+ | 8x |
- .var,+ betas <- as.matrix(coef) |
|
| 118 |
- .ref_group,+ |
|||
| 119 | -+ | 8x |
- .in_ref_col,+ coef_hat <- t(design_mat) %*% betas |
|
| 120 | -+ | 8x |
- time_point,+ dimnames(coef_hat)[2] <- "coef" |
|
| 121 |
- control = control_surv_timepoint(),+ |
|||
| 122 | -+ | 8x |
- ...) {
+ coef_se <- apply(design_mat, 2, function(x) {
|
|
| 123 | -2x | +27x |
- if (.in_ref_col) {
+ vcov_el <- as.logical(x) |
|
| 124 | -! | +27x |
- return(+ y <- vcov[vcov_el, vcov_el] |
|
| 125 | -! | +27x |
- list(+ y <- sum(y) |
|
| 126 | -! | +27x |
- rate_diff = formatters::with_label("", "Difference in Event Free Rate"),
+ y <- sqrt(y) |
|
| 127 | -! | +27x |
- rate_diff_ci = formatters::with_label("", f_conf_level(control$conf_level)),
+ return(y) |
|
| 128 | -! | +
- ztest_pval = formatters::with_label("", "p-value (Z-test)")
+ }) |
||
| 129 |
- )+ |
|||
| 130 | -+ | 8x |
- )+ q_norm <- stats::qnorm((1 + conf_level) / 2) |
|
| 131 | -+ | 8x |
- }+ y <- cbind(coef_hat, `se(coef)` = coef_se) |
|
| 132 | -2x | +
- data <- rbind(.ref_group, df)+ |
||
| 133 | -2x | +8x |
- group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
+ y <- apply(y, 1, function(x) {
|
|
| 134 | -2x | +27x |
- res_per_group <- lapply(split(data, group), function(x) {
+ x["hr"] <- exp(x["coef"]) |
|
| 135 | -4x | +27x |
- s_surv_timepoint(df = x, .var = .var, time_point = time_point, control = control, ...)+ x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"]) |
|
| 136 | -+ | 27x |
- })+ x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"]) |
|
| 138 | -2x | +27x |
- res_x <- res_per_group[[2]]+ return(x) |
|
| 139 | -2x | +
- res_ref <- res_per_group[[1]]+ }) |
||
| 140 | -2x | +
- rate_diff <- res_x$event_free_rate - res_ref$event_free_rate+ |
||
| 141 | -2x | +8x |
- se_diff <- sqrt(res_x$rate_se^2 + res_ref$rate_se^2)+ y <- t(y) |
|
| 142 | -+ | 8x |
-
+ y <- by(y, split_by_variable, identity) |
|
| 143 | -2x | +8x |
- qs <- c(-1, 1) * stats::qnorm(1 - (1 - control$conf_level) / 2)+ y <- lapply(y, as.matrix) |
|
| 144 | -2x | +
- rate_diff_ci <- rate_diff + qs * se_diff+ |
||
| 145 | -2x | +8x |
- ztest_pval <- if (is.na(rate_diff)) {
+ attr(y, "details") <- paste0( |
|
| 146 | -2x | +8x |
- NA+ "Estimations of ", variable, |
|
| 147 | -+ | 8x |
- } else {
+ " hazard ratio given the level of ", given, " compared to ", |
|
| 148 | -2x | +8x |
- 2 * (1 - stats::pnorm(abs(rate_diff) / se_diff))+ variable, " level ", lvl_var[1], "." |
|
| 149 |
- }+ ) |
|||
| 150 | -2x | +8x |
- list(+ return(y) |
|
| 151 | -2x | +
- rate_diff = formatters::with_label(rate_diff, "Difference in Event Free Rate"),+ } |
||
| 152 | -2x | +
- rate_diff_ci = formatters::with_label(rate_diff_ci, f_conf_level(control$conf_level)),+ |
||
| 153 | -2x | +
- ztest_pval = formatters::with_label(ztest_pval, "p-value (Z-test)")+ #' `tryCatch` around `car::Anova` |
||
| 154 |
- )+ #' |
|||
| 155 |
- }+ #' Captures warnings when executing [car::Anova]. |
|||
| 156 |
-
+ #' |
|||
| 157 |
- #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()`+ #' @inheritParams car::Anova |
|||
| 158 |
- #' when `method = "surv_diff"`.+ #' |
|||
| 159 |
- #'+ #' @return A list with item `aov` for the result of the model and `error_text` for the captured warnings. |
|||
| 160 |
- #' @return+ #' |
|||
| 161 |
- #' * `a_surv_timepoint_diff()` returns the corresponding list with formatted [rtables::CellValue()].+ #' @examples |
|||
| 162 |
- #'+ #' # `car::Anova` on cox regression model including strata and expected |
|||
| 163 |
- #' @keywords internal+ #' # a likelihood ratio test triggers a warning as only Wald method is |
|||
| 164 |
- a_surv_timepoint_diff <- make_afun(+ #' # accepted. |
|||
| 165 |
- s_surv_timepoint_diff,+ #' |
|||
| 166 |
- .formats = c(+ #' library(survival) |
|||
| 167 |
- rate_diff = "xx.xx",+ #' |
|||
| 168 |
- rate_diff_ci = "(xx.xx, xx.xx)",+ #' mod <- coxph( |
|||
| 169 |
- ztest_pval = "x.xxxx | (<0.0001)"+ #' formula = Surv(time = futime, event = fustat) ~ factor(rx) + strata(ecog.ps), |
|||
| 170 |
- )+ #' data = ovarian |
|||
| 171 |
- )+ #' ) |
|||
| 172 |
-
+ #' |
|||
| 173 |
- #' @describeIn survival_timepoint Layout-creating function which can take statistics function arguments+ #' @keywords internal |
|||
| 174 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ try_car_anova <- function(mod, |
|||
| 175 |
- #'+ test.statistic) { # nolint
|
|||
| 176 | -+ | 2x |
- #' @return+ y <- tryCatch( |
|
| 177 | -+ | 2x |
- #' * `surv_timepoint()` returns a layout object suitable for passing to further layouting functions,+ withCallingHandlers( |
|
| 178 | -+ | 2x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ expr = {
|
|
| 179 | -+ | 2x |
- #' the statistics from `s_surv_timepoint()` and/or `s_surv_timepoint_diff()` to the table layout depending on+ warn_text <- c() |
|
| 180 | -+ | 2x |
- #' the value of `method`.+ list( |
|
| 181 | -+ | 2x |
- #'+ aov = car::Anova( |
|
| 182 | -+ | 2x |
- #' @examples+ mod, |
|
| 183 | -+ | 2x |
- #' library(dplyr)+ test.statistic = test.statistic, |
|
| 184 | -+ | 2x |
- #'+ type = "III" |
|
| 185 |
- #' adtte_f <- tern_ex_adtte %>%+ ), |
|||
| 186 | -+ | 2x |
- #' filter(PARAMCD == "OS") %>%+ warn_text = warn_text |
|
| 187 |
- #' mutate(+ ) |
|||
| 188 |
- #' AVAL = day2month(AVAL),+ }, |
|||
| 189 | -+ | 2x |
- #' is_event = CNSR == 0+ warning = function(w) {
|
|
| 190 |
- #' )+ # If a warning is detected it is handled as "w". |
|||
| 191 | -+ | ! |
- #'+ warn_text <<- trimws(paste0("Warning in `try_car_anova`: ", w))
|
|
| 192 |
- #' # Survival at given time points.+ |
|||
| 193 |
- #' basic_table() %>%+ # A warning is sometimes expected, then, we want to restart |
|||
| 194 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ # the execution while ignoring the warning. |
|||
| 195 | -+ | ! |
- #' add_colcounts() %>%+ invokeRestart("muffleWarning")
|
|
| 196 |
- #' surv_timepoint(+ } |
|||
| 197 |
- #' vars = "AVAL",+ ), |
|||
| 198 | -+ | 2x |
- #' var_labels = "Months",+ finally = {
|
|
| 199 |
- #' is_event = "is_event",+ } |
|||
| 200 |
- #' time_point = 7+ ) |
|||
| 201 |
- #' ) %>%+ |
|||
| 202 | -+ | 2x |
- #' build_table(df = adtte_f)+ return(y) |
|
| 203 |
- #'+ } |
|||
| 204 |
- #' # Difference in survival at given time points.+ |
|||
| 205 |
- #' basic_table() %>%+ #' Fit a Cox regression model and ANOVA |
|||
| 206 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ #' |
|||
| 207 |
- #' add_colcounts() %>%+ #' The functions derives the effect p-values using [car::Anova()] from [survival::coxph()] results. |
|||
| 208 |
- #' surv_timepoint(+ #' |
|||
| 209 |
- #' vars = "AVAL",+ #' @inheritParams t_coxreg |
|||
| 210 |
- #' var_labels = "Months",+ #' |
|||
| 211 |
- #' is_event = "is_event",+ #' @return A list with items `mod` (results of [survival::coxph()]), `msum` (result of `summary`) and |
|||
| 212 |
- #' time_point = 9,+ #' `aov` (result of [car::Anova()]). |
|||
| 213 |
- #' method = "surv_diff",+ #' |
|||
| 214 |
- #' .indent_mods = c("rate_diff" = 0L, "rate_diff_ci" = 2L, "ztest_pval" = 2L)
+ #' @noRd |
|||
| 215 |
- #' ) %>%+ fit_n_aov <- function(formula, |
|||
| 216 |
- #' build_table(df = adtte_f)+ data = data, |
|||
| 217 |
- #'+ conf_level = conf_level, |
|||
| 218 |
- #' # Survival and difference in survival at given time points.+ pval_method = c("wald", "likelihood"),
|
|||
| 219 |
- #' basic_table() %>%+ ...) {
|
|||
| 220 | -+ | 1x |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ pval_method <- match.arg(pval_method) |
|
| 221 |
- #' add_colcounts() %>%+ |
|||
| 222 | -+ | 1x |
- #' surv_timepoint(+ environment(formula) <- environment() |
|
| 223 | -+ | 1x |
- #' vars = "AVAL",+ suppressWarnings({
|
|
| 224 |
- #' var_labels = "Months",+ # We expect some warnings due to coxph which fails strict programming. |
|||
| 225 | -+ | 1x |
- #' is_event = "is_event",+ mod <- survival::coxph(formula, data = data, ...) |
|
| 226 | -+ | 1x |
- #' time_point = 9,+ msum <- summary(mod, conf.int = conf_level) |
|
| 227 |
- #' method = "both"+ }) |
|||
| 228 |
- #' ) %>%+ |
|||
| 229 | -+ | 1x |
- #' build_table(df = adtte_f)+ aov <- try_car_anova( |
|
| 230 | -+ | 1x |
- #'+ mod, |
|
| 231 | -+ | 1x |
- #' @export+ test.statistic = switch(pval_method, |
|
| 232 | -+ | 1x |
- #' @order 2+ "wald" = "Wald", |
|
| 233 | -+ | 1x |
- surv_timepoint <- function(lyt,+ "likelihood" = "LR" |
|
| 234 |
- vars,+ ) |
|||
| 235 |
- time_point,+ ) |
|||
| 236 |
- is_event,+ |
|||
| 237 | -+ | 1x |
- control = control_surv_timepoint(),+ warn_attr <- aov$warn_text |
|
| 238 | -+ | ! |
- method = c("surv", "surv_diff", "both"),
+ if (!is.null(aov$warn_text)) message(warn_attr) |
|
| 239 |
- na_str = default_na_str(),+ |
|||
| 240 | -+ | 1x |
- nested = TRUE,+ aov <- aov$aov |
|
| 241 | -+ | 1x |
- ...,+ y <- list(mod = mod, msum = msum, aov = aov) |
|
| 242 | -+ | 1x |
- table_names_suffix = "",+ attr(y, "message") <- warn_attr |
|
| 243 |
- var_labels = "Time",+ |
|||
| 244 | -+ | 1x |
- show_labels = "visible",+ return(y) |
|
| 245 |
- .stats = c(+ } |
|||
| 246 |
- "pt_at_risk", "event_free_rate", "rate_ci",+ |
|||
| 247 |
- "rate_diff", "rate_diff_ci", "ztest_pval"+ # argument_checks |
|||
| 248 |
- ),+ check_formula <- function(formula) {
|
|||
| 249 | -+ | 1x |
- .formats = NULL,+ if (!(inherits(formula, "formula"))) {
|
|
| 250 | -+ | 1x |
- .labels = NULL,+ stop("Check `formula`. A formula should resemble `Surv(time = AVAL, event = 1 - CNSR) ~ study_arm(ARMCD)`.")
|
|
| 251 |
- .indent_mods = if (method == "both") {
+ } |
|||
| 252 | -2x | +
- c(rate_diff = 1L, rate_diff_ci = 2L, ztest_pval = 2L)+ |
||
| 253 | -+ | ! |
- } else {
+ invisible() |
|
| 254 | -4x | +
- c(rate_diff_ci = 1L, ztest_pval = 1L)+ } |
||
| 255 |
- }) {
+
|
|||
| 256 | -6x | +
- method <- match.arg(method)+ check_covariate_formulas <- function(covariates) {
|
||
| 257 | -6x | +1x |
- checkmate::assert_string(table_names_suffix)+ 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 | -6x | +
- extra_args <- list(time_point = time_point, is_event = is_event, control = control, ...)+ } |
||
| 261 | -6x | +! |
- f <- list(+ invisible() |
|
| 262 | -6x | +
- surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
+ } |
||
| 263 | -6x | +
- surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
+
|
||
| 264 |
- )+ name_covariate_names <- function(covariates) {
|
|||
| 265 | -6x | +1x |
- .stats <- h_split_param(.stats, .stats, f = f)+ miss_names <- names(covariates) == "" |
|
| 266 | -6x | +1x |
- .formats <- h_split_param(.formats, names(.formats), f = f)+ no_names <- is.null(names(covariates)) |
|
| 267 | -6x | +! |
- .labels <- h_split_param(.labels, names(.labels), f = f)+ if (any(miss_names)) names(covariates)[miss_names] <- vapply(covariates[miss_names], FUN = rht, FUN.VALUE = "name") |
|
| 268 | -6x | +! |
- .indent_mods <- h_split_param(.indent_mods, names(.indent_mods), f = f)+ if (no_names) names(covariates) <- vapply(covariates, FUN = rht, FUN.VALUE = "name") |
|
| 269 | -+ | 1x |
-
+ return(covariates) |
|
| 270 | -6x | +
- afun_surv <- make_afun(+ } |
||
| 271 | -6x | +
- a_surv_timepoint,+ |
||
| 272 | -6x | +
- .stats = .stats$surv,+ check_increments <- function(increments, covariates) {
|
||
| 273 | -6x | +1x |
- .formats = .formats$surv,+ if (!is.null(increments)) {
|
|
| 274 | -6x | +1x |
- .labels = .labels$surv,+ covariates <- vapply(covariates, FUN = rht, FUN.VALUE = "name") |
|
| 275 | -6x | +1x |
- .indent_mods = .indent_mods$surv+ lapply( |
|
| 276 | -+ | 1x |
- )+ X = names(increments), FUN = function(x) {
|
|
| 277 | -+ | 3x |
-
+ if (!x %in% covariates) {
|
|
| 278 | -6x | +1x |
- afun_surv_diff <- make_afun(+ warning( |
|
| 279 | -6x | +1x |
- a_surv_timepoint_diff,+ paste( |
|
| 280 | -6x | +1x |
- .stats = .stats$surv_diff,+ "Check `increments`, the `increment` for ", x, |
|
| 281 | -6x | -
- .formats = .formats$surv_diff,- |
- ||
| 282 | -6x | -
- .labels = .labels$surv_diff,- |
- ||
| 283 | -6x | +1x |
- .indent_mods = .indent_mods$surv_diff+ "doesn't match any names in investigated covariate(s)." |
|
| 284 | +282 |
- )+ ) |
||
| 285 | +283 | - - | -||
| 286 | -6x | -
- time_point <- extra_args$time_point+ ) |
||
| 287 | +284 | - - | -||
| 288 | -6x | -
- for (i in seq_along(time_point)) {
- |
- ||
| 289 | -6x | -
- extra_args[["time_point"]] <- time_point[i]+ } |
||
| 290 | +285 | - - | -||
| 291 | -6x | -
- if (method %in% c("surv", "both")) {
- |
- ||
| 292 | -4x | -
- lyt <- analyze(- |
- ||
| 293 | -4x | -
- lyt,- |
- ||
| 294 | -4x | -
- vars,- |
- ||
| 295 | -4x | -
- var_labels = paste(time_point[i], var_labels),- |
- ||
| 296 | -4x | -
- table_names = paste0("surv_", time_point[i], table_names_suffix),
- |
- ||
| 297 | -4x | -
- show_labels = show_labels,- |
- ||
| 298 | -4x | -
- afun = afun_surv,- |
- ||
| 299 | -4x | -
- na_str = na_str,- |
- ||
| 300 | -4x | -
- nested = nested,- |
- ||
| 301 | -4x | -
- extra_args = extra_args+ } |
||
| 302 | +286 |
- )+ ) |
||
| 303 | +287 |
- }+ } |
||
| 304 | +288 | |||
| 305 | -6x | -
- if (method %in% c("surv_diff", "both")) {
- |
- ||
| 306 | -4x | -
- lyt <- analyze(- |
- ||
| 307 | -4x | -
- lyt,- |
- ||
| 308 | -4x | -
- vars,- |
- ||
| 309 | -4x | -
- var_labels = paste(time_point[i], var_labels),- |
- ||
| 310 | -4x | -
- table_names = paste0("surv_diff_", time_point[i], table_names_suffix),
- |
- ||
| 311 | -4x | -
- show_labels = ifelse(method == "both", "hidden", show_labels),- |
- ||
| 312 | -4x | -
- afun = afun_surv_diff,- |
- ||
| 313 | -4x | -
- na_str = na_str,- |
- ||
| 314 | -4x | -
- nested = nested,- |
- ||
| 315 | -4x | -
- extra_args = extra_args- |
- ||
| 316 | -- |
- )- |
- ||
| 317 | -- |
- }- |
- ||
| 318 | -- |
- }- |
- ||
| 319 | -6x | +289 | +1x |
- lyt+ invisible() |
| 320 | +290 |
} |
| 1 | -- |
- #' Encode categorical missing values in a data frame- |
- ||
| 2 | +291 |
- #'+ |
||
| 3 | +292 |
- #' @description `r lifecycle::badge("stable")`
+ #' Multivariate Cox model - summarized results |
||
| 4 | +293 |
#' |
||
| 5 | -- |
- #' This is a helper function to encode missing entries across groups of categorical- |
- ||
| 6 | +294 |
- #' variables in a data frame.+ #' Analyses based on multivariate Cox model are usually not performed for the Controlled Substance Reporting or |
||
| 7 | +295 |
- #'+ #' regulatory documents but serve exploratory purposes only (e.g., for publication). In practice, the model usually |
||
| 8 | +296 |
- #' @details Missing entries are those with `NA` or empty strings and will+ #' includes only the main effects (without interaction terms). It produces the hazard ratio estimates for each of the |
||
| 9 | +297 |
- #' be replaced with a specified value. If factor variables include missing+ #' covariates included in the model. |
||
| 10 | +298 |
- #' values, the missing value will be inserted as the last level.+ #' The analysis follows the same principles (e.g., stratified vs. unstratified analysis and tie handling) as the |
||
| 11 | +299 |
- #' Similarly, in case character or logical variables should be converted to factors+ #' usual Cox model analysis. Since there is usually no pre-specified hypothesis testing for such analysis, |
||
| 12 | +300 |
- #' with the `char_as_factor` or `logical_as_factor` options, the missing values will+ #' the p.values need to be interpreted with caution. (**Statistical Analysis of Clinical Trials Data with R**, |
||
| 13 | +301 |
- #' be set as the last level.+ #' `NEST's bookdown`) |
||
| 14 | +302 |
#' |
||
| 15 | -- |
- #' @param data (`data.frame`)\cr data set.- |
- ||
| 16 | -- |
- #' @param omit_columns (`character`)\cr names of variables from `data` that should- |
- ||
| 17 | -- |
- #' not be modified by this function.- |
- ||
| 18 | +303 |
- #' @param char_as_factor (`flag`)\cr whether to convert character variables+ #' @param formula (`formula`)\cr a formula corresponding to the investigated [survival::Surv()] survival model |
||
| 19 | +304 |
- #' in `data` to factors.+ #' including covariates. |
||
| 20 | +305 |
- #' @param logical_as_factor (`flag`)\cr whether to convert logical variables+ #' @param data (`data.frame`)\cr a data frame which includes the variable in formula and covariates. |
||
| 21 | +306 |
- #' in `data` to factors.+ #' @param conf_level (`proportion`)\cr the confidence level for the hazard ratio interval estimations. Default is 0.95. |
||
| 22 | +307 |
- #' @param na_level (`string`)\cr string used to replace all `NA` or empty+ #' @param pval_method (`string`)\cr the method used for the estimation of p-values, should be one of |
||
| 23 | +308 |
- #' values inside non-`omit_columns` columns.+ #' `"wald"` (default) or `"likelihood"`. |
||
| 24 | +309 |
- #'+ #' @param ... optional parameters passed to [survival::coxph()]. Can include `ties`, a character string specifying the |
||
| 25 | +310 |
- #' @return A `data.frame` with the chosen modifications applied.+ #' method for tie handling, one of `exact` (default), `efron`, `breslow`. |
||
| 26 | +311 |
#' |
||
| 27 | +312 |
- #' @seealso [sas_na()] and [explicit_na()] for other missing data helper functions.+ #' @return A `list` with elements `mod`, `msum`, `aov`, and `coef_inter`. |
||
| 28 | +313 |
#' |
||
| 29 | -- |
- #' @examples- |
- ||
| 30 | -- |
- #' my_data <- data.frame(- |
- ||
| 31 | -- |
- #' u = c(TRUE, FALSE, NA, TRUE),- |
- ||
| 32 | -- |
- #' v = factor(c("A", NA, NA, NA), levels = c("Z", "A")),
- |
- ||
| 33 | -- |
- #' w = c("A", "B", NA, "C"),
- |
- ||
| 34 | -- |
- #' x = c("D", "E", "F", NA),
- |
- ||
| 35 | -- |
- #' y = c("G", "H", "I", ""),
- |
- ||
| 36 | +314 |
- #' z = c(1, 2, 3, 4),+ #' @details The output is limited to single effect terms. Work in ongoing for estimation of interaction terms |
||
| 37 | +315 |
- #' stringsAsFactors = FALSE+ #' but is out of scope as defined by the Global Data Standards Repository |
||
| 38 | +316 |
- #' )+ #' (**`GDS_Standard_TLG_Specs_Tables_2.doc`**). |
||
| 39 | +317 |
#' |
||
| 40 | -- |
- #' # Example 1- |
- ||
| 41 | -- |
- #' # Encode missing values in all character or factor columns.- |
- ||
| 42 | -- |
- #' df_explicit_na(my_data)- |
- ||
| 43 | -- |
- #' # Also convert logical columns to factor columns.- |
- ||
| 44 | -- |
- #' df_explicit_na(my_data, logical_as_factor = TRUE)- |
- ||
| 45 | -- |
- #' # Encode missing values in a subset of columns.- |
- ||
| 46 | +318 |
- #' df_explicit_na(my_data, omit_columns = c("x", "y"))
+ #' @seealso [estimate_coef()]. |
||
| 47 | +319 |
#' |
||
| 48 | -- |
- #' # Example 2- |
- ||
| 49 | -- |
- #' # Here we purposefully convert all `M` values to `NA` in the `SEX` variable.- |
- ||
| 50 | -- |
- #' # After running `df_explicit_na` the `NA` values are encoded as `<Missing>` but they are not- |
- ||
| 51 | -- |
- #' # included when generating `rtables`.- |
- ||
| 52 | -- |
- #' adsl <- tern_ex_adsl- |
- ||
| 53 | +320 |
- #' adsl$SEX[adsl$SEX == "M"] <- NA+ #' @examples |
||
| 54 | +321 |
- #' adsl <- df_explicit_na(adsl)+ #' library(dplyr) |
||
| 55 | +322 |
#' |
||
| 56 | -- |
- #' # If you want the `Na` values to be displayed in the table use the `na_level` argument.- |
- ||
| 57 | -- |
- #' adsl <- tern_ex_adsl- |
- ||
| 58 | +323 |
- #' adsl$SEX[adsl$SEX == "M"] <- NA+ #' adtte <- tern_ex_adtte |
||
| 59 | +324 |
- #' adsl <- df_explicit_na(adsl, na_level = "Missing Values")+ #' adtte_f <- subset(adtte, PARAMCD == "OS") # _f: filtered |
||
| 60 | +325 |
- #'+ #' adtte_f <- filter( |
||
| 61 | +326 |
- #' # Example 3+ #' adtte_f, |
||
| 62 | +327 |
- #' # Numeric variables that have missing values are not altered. This means that any `NA` value in+ #' PARAMCD == "OS" & |
||
| 63 | +328 |
- #' # a numeric variable will not be included in the summary statistics, nor will they be included+ #' SEX %in% c("F", "M") &
|
||
| 64 | +329 |
- #' # in the denominator value for calculating the percent values.+ #' RACE %in% c("ASIAN", "BLACK OR AFRICAN AMERICAN", "WHITE")
|
||
| 65 | +330 |
- #' adsl <- tern_ex_adsl+ #' ) |
||
| 66 | +331 |
- #' adsl$AGE[adsl$AGE < 30] <- NA+ #' adtte_f$SEX <- droplevels(adtte_f$SEX) |
||
| 67 | +332 |
- #' adsl <- df_explicit_na(adsl)+ #' adtte_f$RACE <- droplevels(adtte_f$RACE) |
||
| 68 | +333 |
#' |
||
| 69 | +334 |
- #' @export+ #' @keywords internal |
||
| 70 | +335 |
- df_explicit_na <- function(data,+ s_cox_multivariate <- function(formula, data, |
||
| 71 | +336 |
- omit_columns = NULL,+ conf_level = 0.95, |
||
| 72 | +337 |
- char_as_factor = TRUE,+ pval_method = c("wald", "likelihood"),
|
||
| 73 | +338 |
- logical_as_factor = FALSE,+ ...) {
|
||
| 74 | -+ | |||
| 339 | +1x |
- na_level = "<Missing>") {
+ tf <- stats::terms(formula, specials = c("strata"))
|
||
| 75 | -24x | +340 | +1x |
- checkmate::assert_character(omit_columns, null.ok = TRUE, min.len = 1, any.missing = FALSE)+ covariates <- rownames(attr(tf, "factors"))[-c(1, unlist(attr(tf, "specials")))] |
| 76 | -23x | +341 | +1x |
- checkmate::assert_data_frame(data)+ lapply( |
| 77 | -22x | +342 | +1x |
- checkmate::assert_flag(char_as_factor)+ X = covariates, |
| 78 | -21x | +343 | +1x |
- checkmate::assert_flag(logical_as_factor)+ FUN = function(x) {
|
| 79 | -21x | +344 | +3x |
- checkmate::assert_string(na_level)+ if (is.character(data[[x]])) {
+ |
+
| 345 | +1x | +
+ data[[x]] <<- as.factor(data[[x]]) |
||
| 80 | +346 |
-
+ } |
||
| 81 | -19x | +347 | +3x |
- target_vars <- if (is.null(omit_columns)) {
+ invisible() |
| 82 | -17x | +|||
| 348 | +
- names(data)+ } |
|||
| 83 | +349 |
- } else {
+ ) |
||
| 84 | -2x | +350 | +1x |
- setdiff(names(data), omit_columns) # May have duplicates.+ pval_method <- match.arg(pval_method) |
| 85 | +351 |
- }+ + |
+ ||
| 352 | ++ |
+ # Results directly exported from environment(fit_n_aov) to environment(s_function_draft) |
||
| 86 | -19x | +353 | +1x |
- if (length(target_vars) == 0) {
+ y <- fit_n_aov( |
| 87 | +354 | 1x |
- return(data)+ formula = formula, |
|
| 88 | -+ | |||
| 355 | +1x |
- }+ data = data, |
||
| 89 | -+ | |||
| 356 | +1x |
-
+ conf_level = conf_level, |
||
| 90 | -18x | +357 | +1x |
- l_target_vars <- split(target_vars, target_vars)+ pval_method = pval_method, |
| 91 | +358 |
-
+ ... |
||
| 92 | +359 |
- # Makes sure target_vars exist in data and names are not duplicated.+ ) |
||
| 93 | -18x | +360 | +1x |
- assert_df_with_variables(data, l_target_vars)+ mod <- y$mod+ |
+
| 361 | +1x | +
+ aov <- y$aov+ |
+ ||
| 362 | +1x | +
+ msum <- y$msum+ |
+ ||
| 363 | +1x | +
+ list2env(as.list(y), environment()) |
||
| 94 | +364 | |||
| 95 | -18x | +365 | +1x |
- for (x in target_vars) {
+ all_term_labs <- attr(mod$terms, "term.labels") |
| 96 | -306x | +366 | +1x |
- xi <- data[[x]]+ term_labs <- all_term_labs[which(attr(mod$terms, "order") == 1)] |
| 97 | -306x | +367 | +1x |
- xi_label <- obj_label(xi)+ names(term_labs) <- term_labs |
| 98 | +368 | |||
| 99 | -+ | |||
| 369 | +1x |
- # Determine whether to convert character or logical input.+ coef_inter <- NULL |
||
| 100 | -306x | +370 | +1x |
- do_char_conversion <- is.character(xi) && char_as_factor+ if (any(attr(mod$terms, "order") > 1)) {
|
| 101 | -306x | +371 | +1x |
- do_logical_conversion <- is.logical(xi) && logical_as_factor+ for_inter <- all_term_labs[attr(mod$terms, "order") > 1] |
| 102 | -+ | |||
| 372 | +1x |
-
+ names(for_inter) <- for_inter |
||
| 103 | -+ | |||
| 373 | +1x |
- # Pre-convert logical to character to deal correctly with replacing NA+ mmat <- stats::model.matrix(mod)[1, ] |
||
| 104 | -+ | |||
| 374 | +1x |
- # values below.+ mmat[!mmat == 0] <- 0 |
||
| 105 | -306x | +375 | +1x |
- if (do_logical_conversion) {
+ mcoef <- stats::coef(mod) |
| 106 | -2x | +376 | +1x |
- xi <- as.character(xi)+ mvcov <- stats::vcov(mod) |
| 107 | +377 |
- }+ |
||
| 108 | -+ | |||
| 378 | +1x |
-
+ estimate_coef_local <- function(variable, given) {
|
||
| 109 | -306x | +379 | +6x |
- if (is.factor(xi) || is.character(xi)) {
+ estimate_coef( |
| 110 | -+ | |||
| 380 | +6x |
- # Handle empty strings and NA values.+ variable, given, |
||
| 111 | -219x | +381 | +6x |
- xi <- explicit_na(sas_na(xi), label = na_level)+ coef = mcoef, mmat = mmat, vcov = mvcov, conf_level = conf_level, |
| 112 | -+ | |||
| 382 | +6x |
-
+ lvl_var = levels(data[[variable]]), lvl_given = levels(data[[given]]) |
||
| 113 | +383 |
- # Convert to factors if requested for the original type,+ ) |
||
| 114 | +384 |
- # set na_level as the last value.+ } |
||
| 115 | -219x | +|||
| 385 | +
- if (do_char_conversion || do_logical_conversion) {
+
|
|||
| 116 | -78x | +386 | +1x |
- levels_xi <- setdiff(sort(unique(xi)), na_level)+ coef_inter <- lapply( |
| 117 | -78x | +387 | +1x |
- if (na_level %in% unique(xi)) {
+ for_inter, function(x) {
|
| 118 | -18x | -
- levels_xi <- c(levels_xi, na_level)- |
- ||
| 119 | -+ | 388 | +3x |
- }+ y <- attr(mod$terms, "factors")[, x] |
| 120 | -+ | |||
| 389 | +3x |
-
+ y <- names(y[y > 0]) |
||
| 121 | -78x | +390 | +3x |
- xi <- factor(xi, levels = levels_xi)+ Map(estimate_coef_local, variable = y, given = rev(y)) |
| 122 | +391 |
} |
||
| 123 | +392 | - - | -||
| 124 | -219x | -
- data[, x] <- formatters::with_label(xi, label = xi_label)+ ) |
||
| 125 | +393 |
- }+ } |
||
| 126 | +394 |
- }+ |
||
| 127 | -18x | +395 | +1x |
- return(data)+ list(mod = mod, msum = msum, aov = aov, coef_inter = coef_inter) |
| 128 | +396 |
}@@ -127274,14 +126254,14 @@ tern coverage - 95.64% |
| 1 |
- #' Analyze numeric variables in columns+ #' Add titles, footnotes, page Number, and a bounding box to a grid grob |
||
| 3 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @description `r lifecycle::badge("stable")`
|
||
| 5 |
- #' The layout-creating function [analyze_vars_in_cols()] creates a layout element to generate a column-wise+ #' This function is useful to label grid grobs (also `ggplot2`, and `lattice` plots) |
||
| 6 |
- #' analysis table.+ #' with title, footnote, and page numbers. |
||
| 8 |
- #' This function sets the analysis methods as column labels and is a wrapper for [rtables::analyze_colvars()].+ #' @inheritParams grid::grob |
||
| 9 |
- #' It was designed principally for PK tables.+ #' @param grob (`grob`)\cr a grid grob object, optionally `NULL` if only a `grob` with the decoration should be shown. |
||
| 10 |
- #'+ #' @param titles (`character`)\cr titles given as a vector of strings that are each separated by a newline and wrapped |
||
| 11 |
- #' @inheritParams argument_convention+ #' according to the page width. |
||
| 12 |
- #' @inheritParams rtables::analyze_colvars+ #' @param footnotes (`character`)\cr footnotes. Uses the same formatting rules as `titles`. |
||
| 13 |
- #' @param imp_rule (`string` or `NULL`)\cr imputation rule setting. Defaults to `NULL` for no imputation rule. Can+ #' @param page (`string` or `NULL`)\cr page numeration. If `NULL` then no page number is displayed. |
||
| 14 |
- #' also be `"1/3"` to implement 1/3 imputation rule or `"1/2"` to implement 1/2 imputation rule. In order+ #' @param width_titles (`grid::unit`)\cr width of titles. Usually defined as all the available space |
||
| 15 |
- #' to use an imputation rule, the `avalcat_var` argument must be specified. See [imputation_rule()]+ #' `grid::unit(1, "npc")`, it is affected by the parameter `outer_margins`. Right margins (`outer_margins[4]`) |
||
| 16 |
- #' for more details on imputation.+ #' need to be subtracted to the allowed width. |
||
| 17 |
- #' @param avalcat_var (`string`)\cr if `imp_rule` is not `NULL`, name of variable that indicates whether a+ #' @param width_footnotes (`grid::unit`)\cr width of footnotes. Same default and margin correction as `width_titles`. |
||
| 18 |
- #' row in the data corresponds to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of+ #' @param border (`flag`)\cr whether a border should be drawn around the plot or not. |
||
| 19 |
- #' the above (defaults to `"AVALCAT1"`). Variable must be present in the data and should match the variable+ #' @param padding (`grid::unit`)\cr padding. A unit object of length 4. Innermost margin between the plot (`grob`) |
||
| 20 |
- #' used to calculate the `n_blq` statistic (if included in `.stats`).+ #' and, possibly, the border of the plot. Usually expressed in 4 identical values (usually `"lines"`). It defaults |
||
| 21 |
- #' @param cache (`flag`)\cr whether to store computed values in a temporary caching environment. This will+ #' to `grid::unit(rep(1, 4), "lines")`. |
||
| 22 |
- #' speed up calculations in large tables, but should be set to `FALSE` if the same `rtable` layout is+ #' @param margins (`grid::unit`)\cr margins. A unit object of length 4. Margins between the plot and the other |
||
| 23 |
- #' used for multiple tables with different data. Defaults to `FALSE`.+ #' elements in the list (e.g. titles, plot, and footers). This is usually expressed in 4 `"lines"`, where the |
||
| 24 |
- #' @param row_labels (`character`)\cr as this function works in columns space, usually `.labels`+ #' lateral ones are 0s, while top and bottom are 1s. It defaults to `grid::unit(c(1, 0, 1, 0), "lines")`. |
||
| 25 |
- #' character vector applies on the column space. You can change the row labels by defining this+ #' @param outer_margins (`grid::unit`)\cr outer margins. A unit object of length 4. It defines the general margin of |
||
| 26 |
- #' parameter to a named character vector with names corresponding to the split values. It defaults+ #' the plot, considering also decorations like titles, footnotes, and page numbers. It defaults to |
||
| 27 |
- #' to `NULL` and if it contains only one `string`, it will duplicate that as a row label.+ #' `grid::unit(c(2, 1.5, 3, 1.5), "cm")`. |
||
| 28 |
- #' @param do_summarize_row_groups (`flag`)\cr defaults to `FALSE` and applies the analysis to the current+ #' @param gp_titles (`gpar`)\cr a `gpar` object. Mainly used to set different `"fontsize"`. |
||
| 29 |
- #' label rows. This is a wrapper of [rtables::summarize_row_groups()] and it can accept `labelstr`+ #' @param gp_footnotes (`gpar`)\cr a `gpar` object. Mainly used to set different `"fontsize"`. |
||
| 30 |
- #' to define row labels. This behavior is not supported as we never need to overload row labels.+ #' |
||
| 31 |
- #' @param split_col_vars (`flag`)\cr defaults to `TRUE` and puts the analysis results onto the columns.+ #' @return A grid grob (`gTree`). |
||
| 32 |
- #' This option allows you to add multiple instances of this functions, also in a nested fashion,+ #' |
||
| 33 |
- #' without adding more splits. This split must happen only one time on a single layout.+ #' @details The titles and footnotes will be ragged, i.e. each title will be wrapped individually. |
||
| 35 |
- #' @return+ #' @examples |
||
| 36 |
- #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()].+ #' library(grid) |
||
| 37 |
- #' 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.+ #' titles <- c( |
||
| 39 |
- #'+ #' "Edgar Anderson's Iris Data", |
||
| 40 |
- #' @note+ #' paste( |
||
| 41 |
- #' * This is an experimental implementation of [rtables::summarize_row_groups()] and [rtables::analyze_colvars()]+ #' "This famous (Fisher's or Anderson's) iris data set gives the measurements", |
||
| 42 |
- #' that may be subjected to changes as `rtables` extends its support to more complex analysis pipelines in the+ #' "in centimeters of the variables sepal length and width and petal length", |
||
| 43 |
- #' column space. We encourage users to read the examples carefully and file issues for different use cases.+ #' "and width, respectively, for 50 flowers from each of 3 species of iris." |
||
| 44 |
- #' * In this function, `labelstr` behaves atypically. If `labelstr = NULL` (the default), row labels are assigned+ #' ) |
||
| 45 |
- #' 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 |
- #'+ #' footnotes <- c( |
||
| 48 |
- #' @seealso [analyze_vars()], [rtables::analyze_colvars()].+ #' "The species are Iris setosa, versicolor, and virginica.", |
||
| 49 |
- #'+ #' paste( |
||
| 50 |
- #' @examples+ #' "iris is a data frame with 150 cases (rows) and 5 variables (columns) named", |
||
| 51 |
- #' library(dplyr)+ #' "Sepal.Length, Sepal.Width, Petal.Length, Petal.Width, and Species." |
||
| 52 |
- #'+ #' ) |
||
| 53 |
- #' # Data preparation+ #' ) |
||
| 54 |
- #' adpp <- tern_ex_adpp %>% h_pkparam_sort()+ #' |
||
| 55 |
- #'+ #' ## empty plot |
||
| 56 |
- #' lyt <- basic_table() %>%+ #' grid.newpage() |
||
| 57 |
- #' split_rows_by(var = "STRATA1", label_pos = "topleft") %>%+ #' |
||
| 58 |
- #' split_rows_by(+ #' grid.draw( |
||
| 59 |
- #' var = "SEX",+ #' decorate_grob( |
||
| 60 |
- #' label_pos = "topleft",+ #' NULL, |
||
| 61 |
- #' child_labels = "hidden"+ #' titles = titles, |
||
| 62 |
- #' ) %>% # Removes duplicated labels+ #' footnotes = footnotes, |
||
| 63 |
- #' analyze_vars_in_cols(vars = "AGE")+ #' page = "Page 4 of 10" |
||
| 64 |
- #' result <- build_table(lyt = lyt, df = adpp)+ #' ) |
||
| 65 |
- #' result+ #' ) |
||
| 67 |
- #' # By selecting just some statistics and ad-hoc labels+ #' # grid |
||
| 68 |
- #' lyt <- basic_table() %>%+ #' p <- gTree( |
||
| 69 |
- #' split_rows_by(var = "ARM", label_pos = "topleft") %>%+ #' children = gList( |
||
| 70 |
- #' split_rows_by(+ #' rectGrob(), |
||
| 71 |
- #' var = "SEX",+ #' xaxisGrob(), |
||
| 72 |
- #' label_pos = "topleft",+ #' yaxisGrob(), |
||
| 73 |
- #' child_labels = "hidden",+ #' textGrob("Sepal.Length", y = unit(-4, "lines")),
|
||
| 74 |
- #' split_fun = drop_split_levels+ #' textGrob("Petal.Length", x = unit(-3.5, "lines"), rot = 90),
|
||
| 75 |
- #' ) %>%+ #' pointsGrob(iris$Sepal.Length, iris$Petal.Length, gp = gpar(col = iris$Species), pch = 16) |
||
| 76 |
- #' analyze_vars_in_cols(+ #' ), |
||
| 77 |
- #' vars = "AGE",+ #' vp = vpStack(plotViewport(), dataViewport(xData = iris$Sepal.Length, yData = iris$Petal.Length)) |
||
| 78 |
- #' .stats = c("n", "cv", "geom_mean"),
+ #' ) |
||
| 79 |
- #' .labels = c(+ #' grid.newpage() |
||
| 80 |
- #' n = "aN",+ #' grid.draw(p) |
||
| 81 |
- #' cv = "aCV",+ #' |
||
| 82 |
- #' geom_mean = "aGeomMean"+ #' grid.newpage() |
||
| 83 |
- #' )+ #' grid.draw( |
||
| 84 |
- #' )+ #' decorate_grob( |
||
| 85 |
- #' result <- build_table(lyt = lyt, df = adpp)+ #' grob = p, |
||
| 86 |
- #' result+ #' titles = titles, |
||
| 87 |
- #'+ #' footnotes = footnotes, |
||
| 88 |
- #' # Changing row labels+ #' page = "Page 6 of 129" |
||
| 89 |
- #' lyt <- basic_table() %>%+ #' ) |
||
| 90 |
- #' analyze_vars_in_cols(+ #' ) |
||
| 91 |
- #' vars = "AGE",+ #' |
||
| 92 |
- #' row_labels = "some custom label"+ #' ## with ggplot2 |
||
| 93 |
- #' )+ #' library(ggplot2) |
||
| 94 |
- #' result <- build_table(lyt, df = adpp)+ #' |
||
| 95 |
- #' result+ #' p_gg <- ggplot2::ggplot(iris, aes(Sepal.Length, Sepal.Width, col = Species)) + |
||
| 96 |
- #'+ #' ggplot2::geom_point() |
||
| 97 |
- #' # Pharmacokinetic parameters+ #' p_gg |
||
| 98 |
- #' lyt <- basic_table() %>%+ #' p <- ggplotGrob(p_gg) |
||
| 99 |
- #' split_rows_by(+ #' grid.newpage() |
||
| 100 |
- #' var = "TLG_DISPLAY",+ #' grid.draw( |
||
| 101 |
- #' split_label = "PK Parameter",+ #' decorate_grob( |
||
| 102 |
- #' label_pos = "topleft",+ #' grob = p, |
||
| 103 |
- #' child_labels = "hidden"+ #' titles = titles, |
||
| 104 |
- #' ) %>%+ #' footnotes = footnotes, |
||
| 105 |
- #' analyze_vars_in_cols(+ #' page = "Page 6 of 129" |
||
| 106 |
- #' vars = "AVAL"+ #' ) |
||
| 107 |
- #' )+ #' ) |
||
| 108 |
- #' result <- build_table(lyt, df = adpp)+ #' |
||
| 109 |
- #' result+ #' ## with lattice |
||
| 110 |
- #'+ #' library(lattice) |
||
| 111 |
- #' # Multiple calls (summarize label and analyze underneath)+ #' |
||
| 112 |
- #' lyt <- basic_table() %>%+ #' xyplot(Sepal.Length ~ Petal.Length, data = iris, col = iris$Species) |
||
| 113 |
- #' split_rows_by(+ #' p <- grid.grab() |
||
| 114 |
- #' var = "TLG_DISPLAY",+ #' grid.newpage() |
||
| 115 |
- #' split_label = "PK Parameter",+ #' grid.draw( |
||
| 116 |
- #' label_pos = "topleft"+ #' decorate_grob( |
||
| 117 |
- #' ) %>%+ #' grob = p, |
||
| 118 |
- #' analyze_vars_in_cols(+ #' titles = titles, |
||
| 119 |
- #' vars = "AVAL",+ #' footnotes = footnotes, |
||
| 120 |
- #' do_summarize_row_groups = TRUE # does a summarize level+ #' page = "Page 6 of 129" |
||
| 121 |
- #' ) %>%+ #' ) |
||
| 122 |
- #' split_rows_by("SEX",
+ #' ) |
||
| 123 |
- #' child_labels = "hidden",+ #' |
||
| 124 |
- #' label_pos = "topleft"+ #' # with gridExtra - no borders |
||
| 125 |
- #' ) %>%+ #' library(gridExtra) |
||
| 126 |
- #' analyze_vars_in_cols(+ #' grid.newpage() |
||
| 127 |
- #' vars = "AVAL",+ #' grid.draw( |
||
| 128 |
- #' split_col_vars = FALSE # avoids re-splitting the columns+ #' decorate_grob( |
||
| 129 |
- #' )+ #' tableGrob( |
||
| 130 |
- #' result <- build_table(lyt, df = adpp)+ #' head(mtcars) |
||
| 131 |
- #' result+ #' ), |
||
| 132 |
- #'+ #' titles = "title", |
||
| 133 |
- #' @export+ #' footnotes = "footnote", |
||
| 134 |
- analyze_vars_in_cols <- function(lyt,+ #' border = FALSE |
||
| 135 |
- vars,+ #' ) |
||
| 136 |
- ...,+ #' ) |
||
| 137 |
- .stats = c(+ #' |
||
| 138 |
- "n",+ #' @export |
||
| 139 |
- "mean",+ decorate_grob <- function(grob, |
||
| 140 |
- "sd",+ titles, |
||
| 141 |
- "se",+ footnotes, |
||
| 142 |
- "cv",+ page = "", |
||
| 143 |
- "geom_cv"+ width_titles = grid::unit(1, "npc"), |
||
| 144 |
- ),+ width_footnotes = grid::unit(1, "npc"), |
||
| 145 |
- .labels = c(+ border = TRUE, |
||
| 146 |
- n = "n",+ padding = grid::unit(rep(1, 4), "lines"), |
||
| 147 |
- mean = "Mean",+ margins = grid::unit(c(1, 0, 1, 0), "lines"), |
||
| 148 |
- sd = "SD",+ outer_margins = grid::unit(c(2, 1.5, 3, 1.5), "cm"), |
||
| 149 |
- se = "SE",+ gp_titles = grid::gpar(), |
||
| 150 |
- cv = "CV (%)",+ gp_footnotes = grid::gpar(fontsize = 8), |
||
| 151 |
- geom_cv = "CV % Geometric Mean"+ name = NULL, |
||
| 152 |
- ),+ gp = grid::gpar(), |
||
| 153 |
- row_labels = NULL,+ vp = NULL) {
|
||
| 154 |
- do_summarize_row_groups = FALSE,+ # External margins need to be taken into account when defining the width of titles and footers |
||
| 155 |
- split_col_vars = TRUE,+ # because the text is split in advance depending on only the width of the viewport. |
||
| 156 | -+ | 9x |
- imp_rule = NULL,+ if (any(as.numeric(outer_margins) > 0)) {
|
| 157 | -+ | 9x |
- avalcat_var = "AVALCAT1",+ width_titles <- width_titles - outer_margins[4] |
| 158 | -+ | 9x |
- cache = FALSE,+ width_footnotes <- width_footnotes - outer_margins[4] |
| 159 |
- .indent_mods = NULL,+ } |
||
| 160 |
- na_str = default_na_str(),+ |
||
| 161 | -+ | 9x |
- nested = TRUE,+ st_titles <- split_text_grob( |
| 162 | -+ | 9x |
- .formats = NULL,+ titles, |
| 163 | -+ | 9x |
- .aligns = NULL) {
+ x = 0, y = 1, |
| 164 | -26x | +9x |
- extra_args <- list(...)+ just = c("left", "top"),
|
| 165 | -+ | 9x |
-
+ width = width_titles, |
| 166 | -26x | +9x |
- checkmate::assert_string(na_str, na.ok = TRUE, null.ok = TRUE)+ vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 1), |
| 167 | -26x | +9x |
- checkmate::assert_character(row_labels, null.ok = TRUE)+ gp = gp_titles |
| 168 | -26x | +
- checkmate::assert_int(.indent_mods, null.ok = TRUE)+ ) |
|
| 169 | -26x | +
- checkmate::assert_flag(nested)+ |
|
| 170 | -26x | +9x |
- checkmate::assert_flag(split_col_vars)+ st_footnotes <- split_text_grob( |
| 171 | -26x | +9x |
- checkmate::assert_flag(do_summarize_row_groups)+ footnotes, |
| 172 | -+ | 9x |
-
+ x = 0, y = 1, |
| 173 | -+ | 9x |
- # Filtering+ just = c("left", "top"),
|
| 174 | -26x | +9x |
- met_grps <- paste0("analyze_vars", c("_numeric", "_counts"))
+ width = width_footnotes, |
| 175 | -26x | +9x |
- .stats <- get_stats(met_grps, stats_in = .stats)+ vp = grid::viewport(layout.pos.row = 3, layout.pos.col = 1), |
| 176 | -26x | +9x |
- formats_v <- get_formats_from_stats(stats = .stats, formats_in = .formats)+ gp = gp_footnotes |
| 177 | -26x | +
- 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 | -+ | 9x |
-
+ pg_footnote <- grid::textGrob( |
| 180 | -+ | 9x |
- # Check for vars in the case that one or more are used+ paste("\n", page),
|
| 181 | -26x | +9x |
- if (length(vars) == 1) {
+ x = 1, y = 0, |
| 182 | -21x | +9x |
- vars <- rep(vars, length(.stats))+ just = c("right", "bottom"),
|
| 183 | -5x | +9x |
- } else if (length(vars) != length(.stats)) {
+ vp = grid::viewport(layout.pos.row = 4, layout.pos.col = 1), |
| 184 | -1x | +9x |
- stop(+ gp = gp_footnotes |
| 185 | -1x | +
- "Analyzed variables (vars) does not have the same ",+ ) |
|
| 186 | -1x | +
- "number of elements of specified statistics (.stats)."+ |
|
| 187 |
- )+ # Initial decoration of the grob -> border, paddings, and margins are used here |
||
| 188 | -+ | 9x |
- }+ main_plot <- grid::gTree( |
| 189 | -+ | 9x |
-
+ children = grid::gList( |
| 190 | -25x | +9x |
- if (split_col_vars) {
+ if (border) grid::rectGrob(), |
| 191 | -+ | 9x |
- # Checking there is not a previous identical column split+ grid::gTree( |
| 192 | -21x | +9x |
- clyt <- tail(clayout(lyt), 1)[[1]]+ children = grid::gList( |
| 193 | -+ | 9x |
-
+ grob |
| 194 | -21x | +
- dummy_lyt <- split_cols_by_multivar(+ ), |
|
| 195 | -21x | +9x |
- lyt = basic_table(),+ vp = grid::plotViewport(margins = padding) # innermost margins of the grob plot |
| 196 | -21x | +
- vars = vars,+ ) |
|
| 197 | -21x | +
- varlabels = labels_v+ ), |
|
| 198 | -+ | 9x |
- )+ vp = grid::vpStack( |
| 199 | -+ | 9x |
-
+ grid::viewport(layout.pos.row = 2, layout.pos.col = 1), |
| 200 | -21x | +9x |
- if (any(sapply(clyt, identical, y = get_last_col_split(dummy_lyt)))) {
+ grid::plotViewport(margins = margins) # margins around the border plot |
| 201 | -2x | +
- stop(+ ) |
|
| 202 | -2x | +
- "Column split called again with the same values. ",+ ) |
|
| 203 | -2x | +
- "This can create many unwanted columns. Please consider adding ",+ |
|
| 204 | -2x | +9x |
- "split_col_vars = FALSE to the last call of ",+ grid::gTree( |
| 205 | -2x | +9x |
- deparse(sys.calls()[[sys.nframe() - 1]]), "."+ grob = grob, |
| 206 | -+ | 9x |
- )+ titles = titles, |
| 207 | -+ | 9x |
- }+ footnotes = footnotes, |
| 208 | -+ | 9x |
-
+ page = page, |
| 209 | -+ | 9x |
- # Main col split+ width_titles = width_titles, |
| 210 | -19x | +9x |
- lyt <- split_cols_by_multivar(+ width_footnotes = width_footnotes, |
| 211 | -19x | +9x |
- lyt = lyt,+ outer_margins = outer_margins, |
| 212 | -19x | +9x |
- vars = vars,+ gp_titles = gp_titles, |
| 213 | -19x | +9x |
- varlabels = labels_v+ gp_footnotes = gp_footnotes, |
| 214 | -+ | 9x |
- )+ children = grid::gList( |
| 215 | -+ | 9x |
- }+ grid::gTree( |
| 216 | -+ | 9x |
-
+ children = grid::gList( |
| 217 | -23x | +9x |
- env <- new.env() # create caching environment+ st_titles, |
| 218 | -+ | 9x |
-
+ main_plot, # main plot with border, padding, and margins |
| 219 | -23x | +9x |
- if (do_summarize_row_groups) {
+ st_footnotes, |
| 220 | -8x | +9x |
- if (length(unique(vars)) > 1) {
+ pg_footnote |
| 221 | -! | +
- stop("When using do_summarize_row_groups only one label level var should be inserted.")
+ ), |
|
| 222 | -+ | 9x |
- }+ childrenvp = NULL, |
| 223 | -+ | 9x |
-
+ name = "titles_grob_footnotes", |
| 224 | -+ | 9x |
- # Function list for do_summarize_row_groups. Slightly different handling of labels+ vp = grid::vpStack( |
| 225 | -8x | +9x |
- cfun_list <- Map(+ grid::plotViewport(margins = outer_margins), # Main external margins |
| 226 | -8x | +9x |
- function(stat, use_cache, cache_env) {
+ grid::viewport( |
| 227 | -48x | +9x |
- function(u, .spl_context, labelstr, .df_row, ...) {
+ layout = grid::grid.layout( |
| 228 | -+ | 9x |
- # Statistic+ nrow = 4, ncol = 1, |
| 229 | -152x | +9x |
- var_row_val <- paste(+ heights = grid::unit.c( |
| 230 | -152x | +9x |
- gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
+ grid::grobHeight(st_titles), |
| 231 | -152x | +9x |
- paste(.spl_context$value, collapse = "_"),+ grid::unit(1, "null"), |
| 232 | -152x | +9x |
- sep = "_"+ grid::grobHeight(st_footnotes), |
| 233 | -+ | 9x |
- )+ grid::grobHeight(pg_footnote) |
| 234 | -152x | +
- if (use_cache) {
+ ) |
|
| 235 | -! | +
- if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...)+ ) |
|
| 236 | -! | +
- x_stats <- cache_env[[var_row_val]]+ ) |
|
| 237 |
- } else {
+ ) |
||
| 238 | -152x | +
- x_stats <- s_summary(u, ...)+ ) |
|
| 239 |
- }+ ), |
||
| 240 | -+ | 9x |
-
+ name = name, |
| 241 | -152x | +9x |
- if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
+ gp = gp, |
| 242 | -152x | +9x |
- res <- x_stats[[stat]]+ vp = vp, |
| 243 | -+ | 9x |
- } else {
+ cl = "decoratedGrob" |
| 244 | -! | +
- timept <- as.numeric(gsub(".*?([0-9\\.]+).*", "\\1", tail(.spl_context$value, 1)))
+ ) |
|
| 245 | -! | +
- res_imp <- imputation_rule(+ } |
|
| 246 | -! | +
- .df_row, x_stats, stat,+ |
|
| 247 | -! | +
- imp_rule = imp_rule,+ # nocov start |
|
| 248 | -! | +
- post = grepl("Predose", tail(.spl_context$value, 1)) || timept > 0,
+ #' @importFrom grid validDetails |
|
| 249 | -! | +
- avalcat_var = avalcat_var+ #' @noRd |
|
| 250 |
- )+ validDetails.decoratedGrob <- function(x) {
|
||
| 251 | -! | +
- res <- res_imp[["val"]]+ checkmate::assert_character(x$titles) |
|
| 252 | -! | +
- na_str <- res_imp[["na_str"]]+ checkmate::assert_character(x$footnotes) |
|
| 253 |
- }+ |
||
| 254 |
-
+ if (!is.null(x$grob)) {
|
||
| 255 |
- # Label check and replacement+ checkmate::assert_true(grid::is.grob(x$grob)) |
||
| 256 | -152x | +
- if (length(row_labels) > 1) {
+ } |
|
| 257 | -32x | +
- if (!(labelstr %in% names(row_labels))) {
+ if (length(x$page) == 1) {
|
|
| 258 | -2x | +
- stop(+ checkmate::assert_character(x$page) |
|
| 259 | -2x | +
- "Replacing the labels in do_summarize_row_groups needs a named vector",+ } |
|
| 260 | -2x | +
- "that contains the split values. In the current split variable ",+ if (!grid::is.unit(x$outer_margins)) {
|
|
| 261 | -2x | +
- .spl_context$split[nrow(.spl_context)],+ checkmate::assert_vector(x$outer_margins, len = 4) |
|
| 262 | -2x | +
- " the labelstr value (split value by default) ", labelstr, " is not in",+ } |
|
| 263 | -2x | +
- " row_labels names: ", names(row_labels)+ if (!grid::is.unit(x$margins)) {
|
|
| 264 |
- )+ checkmate::assert_vector(x$margins, len = 4) |
||
| 265 |
- }+ } |
||
| 266 | -30x | +
- lbl <- unlist(row_labels[labelstr])+ if (!grid::is.unit(x$padding)) {
|
|
| 267 |
- } else {
+ checkmate::assert_vector(x$padding, len = 4) |
||
| 268 | -120x | +
- lbl <- labelstr+ } |
|
| 269 |
- }+ |
||
| 270 |
-
+ x |
||
| 271 |
- # Cell creation+ } |
||
| 272 | -150x | +
- rcell(res,+ |
|
| 273 | -150x | +
- label = lbl,+ #' @importFrom grid widthDetails |
|
| 274 | -150x | +
- format = formats_v[names(formats_v) == stat][[1]],+ #' @noRd |
|
| 275 | -150x | +
- format_na_str = na_str,+ widthDetails.decoratedGrob <- function(x) {
|
|
| 276 | -150x | +
- indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods),+ grid::unit(1, "null") |
|
| 277 | -150x | +
- align = .aligns+ } |
|
| 278 |
- )+ |
||
| 279 |
- }+ #' @importFrom grid heightDetails |
||
| 280 |
- },+ #' @noRd |
||
| 281 | -8x | +
- stat = .stats,+ heightDetails.decoratedGrob <- function(x) {
|
|
| 282 | -8x | +
- use_cache = cache,+ grid::unit(1, "null") |
|
| 283 | -8x | +
- cache_env = replicate(length(.stats), env)+ } |
|
| 284 |
- )+ |
||
| 285 |
-
+ #' Split text according to available text width |
||
| 286 |
- # Main call to rtables+ #' |
||
| 287 | -8x | +
- summarize_row_groups(+ #' Dynamically wrap text. |
|
| 288 | -8x | +
- lyt = lyt,+ #' |
|
| 289 | -8x | +
- var = unique(vars),+ #' @inheritParams grid::grid.text |
|
| 290 | -8x | +
- cfun = cfun_list,+ #' @param text (`string`)\cr the text to wrap. |
|
| 291 | -8x | +
- na_str = na_str,+ #' @param width (`grid::unit`)\cr a unit object specifying maximum width of text. |
|
| 292 | -8x | +
- extra_args = extra_args+ #' |
|
| 293 |
- )+ #' @return A text `grob`. |
||
| 294 |
- } else {
+ #' |
||
| 295 |
- # Function list for analyze_colvars+ #' @details This code is taken from `R Graphics by Paul Murell, 2nd edition` |
||
| 296 | -15x | +
- afun_list <- Map(+ #' |
|
| 297 | -15x | +
- function(stat, use_cache, cache_env) {
+ #' @keywords internal |
|
| 298 | -76x | +
- function(u, .spl_context, .df_row, ...) {
+ split_text_grob <- function(text, |
|
| 299 |
- # Main statistics+ x = grid::unit(0.5, "npc"), |
||
| 300 | -468x | +
- var_row_val <- paste(+ y = grid::unit(0.5, "npc"), |
|
| 301 | -468x | +
- gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
+ width = grid::unit(1, "npc"), |
|
| 302 | -468x | +
- paste(.spl_context$value, collapse = "_"),+ just = "centre", |
|
| 303 | -468x | +
- sep = "_"+ hjust = NULL, |
|
| 304 |
- )+ vjust = NULL, |
||
| 305 | -468x | +
- if (use_cache) {
+ default.units = "npc", # nolint |
|
| 306 | -16x | +
- if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...)+ name = NULL, |
|
| 307 | -56x | +
- x_stats <- cache_env[[var_row_val]]+ gp = grid::gpar(), |
|
| 308 |
- } else {
+ vp = NULL) {
|
||
| 309 | -412x | +
- x_stats <- s_summary(u, ...)+ text <- gsub("\\\\n", "\n", text) # fixing cases of mixed behavior (\n and \\n)
|
|
| 310 |
- }+ |
||
| 311 |
-
+ if (!grid::is.unit(x)) x <- grid::unit(x, default.units) |
||
| 312 | -468x | +
- if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
+ if (!grid::is.unit(y)) y <- grid::unit(y, default.units) |
|
| 313 | -348x | +
- res <- x_stats[[stat]]+ if (!grid::is.unit(width)) width <- grid::unit(width, default.units) |
|
| 314 |
- } else {
+ if (grid::unitType(x) %in% c("sum", "min", "max")) x <- grid::convertUnit(x, default.units)
|
||
| 315 | -120x | +
- timept <- as.numeric(gsub(".*?([0-9\\.]+).*", "\\1", tail(.spl_context$value, 1)))
+ if (grid::unitType(y) %in% c("sum", "min", "max")) y <- grid::convertUnit(y, default.units)
|
|
| 316 | -120x | +
- res_imp <- imputation_rule(+ if (grid::unitType(width) %in% c("sum", "min", "max")) width <- grid::convertUnit(width, default.units)
|
|
| 317 | -120x | +
- .df_row, x_stats, stat,+ |
|
| 318 | -120x | +
- imp_rule = imp_rule,+ if (length(gp) > 0) { # account for effect of gp on text width -> it was bugging when text was empty
|
|
| 319 | -120x | +
- post = grepl("Predose", tail(.spl_context$value, 1)) || timept > 0,
+ horizontal_npc_width_no_gp <- grid::convertWidth( |
|
| 320 | -120x | +
- avalcat_var = avalcat_var+ grid::grobWidth( |
|
| 321 |
- )+ grid::textGrob( |
||
| 322 | -120x | +
- res <- res_imp[["val"]]+ paste0(text, collapse = "\n") |
|
| 323 | -120x | +
- na_str <- res_imp[["na_str"]]+ ) |
|
| 324 |
- }+ ), "npc", |
||
| 325 |
-
+ valueOnly = TRUE |
||
| 326 | -468x | +
- if (is.list(res)) {
+ ) |
|
| 327 | -19x | +
- if (length(res) > 1) {
+ horizontal_npc_width_with_gp <- grid::convertWidth(grid::grobWidth( |
|
| 328 | -1x | +
- stop("The analyzed column produced more than one category of results.")
+ grid::textGrob( |
|
| 329 |
- } else {
+ paste0(text, collapse = "\n"), |
||
| 330 | -18x | +
- res <- unlist(res)+ gp = gp |
|
| 331 |
- }+ ) |
||
| 332 |
- }+ ), "npc", valueOnly = TRUE) |
||
| 334 |
- # Label from context+ # Adapting width to the input gpar (it is normalized so does not matter what is text) |
||
| 335 | -467x | +
- label_from_context <- .spl_context$value[nrow(.spl_context)]+ width <- width * horizontal_npc_width_no_gp / horizontal_npc_width_with_gp |
|
| 336 |
-
+ } |
||
| 337 |
- # Label switcher+ |
||
| 338 | -467x | +
- if (is.null(row_labels)) {
+ ## if it is a fixed unit then we do not need to recalculate when viewport resized |
|
| 339 | -387x | +
- lbl <- label_from_context+ if (!inherits(width, "unit.arithmetic") && !is.null(attr(width, "unit")) && |
|
| 340 |
- } else {
+ attr(width, "unit") %in% c("cm", "inches", "mm", "points", "picas", "bigpts", "dida", "cicero", "scaledpts")) { # nolint
|
||
| 341 | -80x | +
- if (length(row_labels) > 1) {
+ attr(text, "fixed_text") <- paste(vapply(text, split_string, character(1), width = width), collapse = "\n") |
|
| 342 | -68x | +
- if (!(label_from_context %in% names(row_labels))) {
+ } |
|
| 343 | -2x | +
- stop(+ |
|
| 344 | -2x | +
- "Replacing the labels in do_summarize_row_groups needs a named vector",+ # Fix for split_string in case of residual \n (otherwise is counted as character) |
|
| 345 | -2x | +
- "that contains the split values. In the current split variable ",+ text2 <- unlist( |
|
| 346 | -2x | +
- .spl_context$split[nrow(.spl_context)],+ strsplit( |
|
| 347 | -2x | +
- " the split value ", label_from_context, " is not in",+ paste0(text, collapse = "\n"), # for "" cases |
|
| 348 | -2x | +
- " row_labels names: ", names(row_labels)+ "\n" |
|
| 349 |
- )+ ) |
||
| 350 |
- }+ ) |
||
| 351 | -66x | +
- lbl <- unlist(row_labels[label_from_context])+ |
|
| 352 |
- } else {
+ # Final grid text with cat-friendly split_string |
||
| 353 | -12x | +
- lbl <- row_labels+ grid::grid.text( |
|
| 354 |
- }+ label = split_string(text2, width), |
||
| 355 |
- }+ x = x, y = y, |
||
| 356 |
-
+ just = just, |
||
| 357 |
- # Cell creation+ hjust = hjust, |
||
| 358 | -465x | +
- rcell(res,+ vjust = vjust, |
|
| 359 | -465x | +
- label = lbl,+ rot = 0, |
|
| 360 | -465x | +
- format = formats_v[names(formats_v) == stat][[1]],+ check.overlap = FALSE, |
|
| 361 | -465x | +
- format_na_str = na_str,+ name = name, |
|
| 362 | -465x | +
- indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods),+ gp = gp, |
|
| 363 | -465x | +
- align = .aligns+ vp = vp, |
|
| 364 |
- )+ draw = FALSE |
||
| 365 |
- }+ ) |
||
| 366 |
- },+ } |
||
| 367 | -15x | +
- stat = .stats,+ |
|
| 368 | -15x | +
- use_cache = cache,+ #' @importFrom grid validDetails |
|
| 369 | -15x | +
- cache_env = replicate(length(.stats), env)+ #' @noRd |
|
| 370 |
- )+ validDetails.dynamicSplitText <- function(x) {
|
||
| 371 |
-
+ checkmate::assert_character(x$text) |
||
| 372 |
- # Main call to rtables+ checkmate::assert_true(grid::is.unit(x$width)) |
||
| 373 | -15x | +
- analyze_colvars(lyt,+ checkmate::assert_vector(x$width, len = 1) |
|
| 374 | -15x | +
- afun = afun_list,+ x |
|
| 375 | -15x | +
- na_str = na_str,+ } |
|
| 376 | -15x | +
- nested = nested,+ |
|
| 377 | -15x | +
- extra_args = extra_args+ #' @importFrom grid heightDetails |
|
| 378 |
- )+ #' @noRd |
||
| 379 |
- }+ heightDetails.dynamicSplitText <- function(x) {
|
||
| 380 |
- }+ txt <- if (!is.null(attr(x$text, "fixed_text"))) {
|
||
| 381 |
-
+ attr(x$text, "fixed_text") |
||
| 382 |
- # Helper function+ } else {
|
||
| 383 |
- get_last_col_split <- function(lyt) {
+ paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n") |
||
| 384 | -3x | +
- tail(tail(clayout(lyt), 1)[[1]], 1)[[1]]+ } |
|
| 385 |
- }+ grid::stringHeight(txt) |
| 1 | +386 |
- #' Subgroup treatment effect pattern (STEP) fit for survival outcome+ } |
||
| 2 | +387 |
- #'+ |
||
| 3 | +388 |
- #' @description `r lifecycle::badge("stable")`
+ #' @importFrom grid widthDetails |
||
| 4 | +389 |
- #'+ #' @noRd |
||
| 5 | +390 |
- #' This fits the subgroup treatment effect pattern (STEP) models for a survival outcome. The treatment arm+ widthDetails.dynamicSplitText <- function(x) {
|
||
| 6 | +391 |
- #' variable must have exactly 2 levels, where the first one is taken as reference and the estimated+ x$width |
||
| 7 | +392 |
- #' hazard ratios are for the comparison of the second level vs. the first one.+ } |
||
| 8 | +393 |
- #'+ |
||
| 9 | +394 |
- #' The model which is fit is:+ #' @importFrom grid drawDetails |
||
| 10 | +395 |
- #'+ #' @noRd |
||
| 11 | +396 |
- #' `Surv(time, event) ~ arm * poly(biomarker, degree) + covariates + strata(strata)`+ drawDetails.dynamicSplitText <- function(x, recording) {
|
||
| 12 | +397 |
- #'+ txt <- if (!is.null(attr(x$text, "fixed_text"))) {
|
||
| 13 | +398 |
- #' where `degree` is specified by `control_step()`.+ attr(x$text, "fixed_text") |
||
| 14 | +399 |
- #'+ } else {
|
||
| 15 | +400 |
- #' @inheritParams argument_convention+ paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n") |
||
| 16 | +401 |
- #' @param variables (named `list` of `character`)\cr list of analysis variables: needs `time`, `event`,+ } |
||
| 17 | +402 |
- #' `arm`, `biomarker`, and optional `covariates` and `strata`.+ |
||
| 18 | +403 |
- #' @param control (named `list`)\cr combined control list from [control_step()] and [control_coxph()].+ x$width <- NULL |
||
| 19 | +404 |
- #'+ x$label <- txt |
||
| 20 | +405 |
- #' @return A matrix of class `step`. The first part of the columns describe the subgroup intervals used+ x$text <- NULL |
||
| 21 | +406 |
- #' for the biomarker variable, including where the center of the intervals are and their bounds. The+ class(x) <- c("text", class(x)[-1])
|
||
| 22 | +407 |
- #' second part of the columns contain the estimates for the treatment arm comparison.+ |
||
| 23 | +408 |
- #'+ grid::grid.draw(x) |
||
| 24 | +409 |
- #' @note For the default degree 0 the `biomarker` variable is not included in the model.+ } |
||
| 25 | +410 |
- #'+ # nocov end |
||
| 26 | +411 |
- #' @seealso [control_step()] and [control_coxph()] for the available customization options.+ |
||
| 27 | +412 |
- #'+ # Adapted from Paul Murell R Graphics 2nd Edition |
||
| 28 | +413 |
- #' @examples+ # https://www.stat.auckland.ac.nz/~paul/RG2e/interactgrid-splittext.R |
||
| 29 | +414 |
- #' # Testing dataset with just two treatment arms.+ split_string <- function(text, width) {
|
||
| 30 | -+ | |||
| 415 | +26x |
- #' library(dplyr)+ strings <- strsplit(text, " ") |
||
| 31 | -+ | |||
| 416 | +26x |
- #'+ out_string <- NA+ |
+ ||
| 417 | +26x | +
+ for (string_i in seq_along(strings)) {
+ |
+ ||
| 418 | +48x | +
+ newline_str <- strings[[string_i]]+ |
+ ||
| 419 | +6x | +
+ if (length(newline_str) == 0) newline_str <- ""+ |
+ ||
| 420 | +48x | +
+ if (is.na(out_string[string_i])) {
+ |
+ ||
| 421 | +48x | +
+ out_string[string_i] <- newline_str[[1]][[1]]+ |
+ ||
| 422 | +48x | +
+ linewidth <- grid::stringWidth(out_string[string_i]) |
||
| 32 | +423 |
- #' adtte_f <- tern_ex_adtte %>%+ }+ |
+ ||
| 424 | +48x | +
+ gapwidth <- grid::stringWidth(" ")
+ |
+ ||
| 425 | +48x | +
+ availwidth <- as.numeric(width)+ |
+ ||
| 426 | +48x | +
+ if (length(newline_str) > 1) {
+ |
+ ||
| 427 | +12x | +
+ for (i in seq(2, length(newline_str))) {
+ |
+ ||
| 428 | +184x | +
+ width_i <- grid::stringWidth(newline_str[i]) |
||
| 33 | +429 |
- #' filter(+ # Main conversion of allowed text width -> npc units are 0<npc<1. External viewport is used for conversion+ |
+ ||
| 430 | +184x | +
+ if (grid::convertWidth(linewidth + gapwidth + width_i, grid::unitType(width), valueOnly = TRUE) < availwidth) {
+ |
+ ||
| 431 | +177x | +
+ sep <- " "+ |
+ ||
| 432 | +177x | +
+ linewidth <- linewidth + gapwidth + width_i |
||
| 34 | +433 |
- #' PARAMCD == "OS",+ } else {
+ |
+ ||
| 434 | +7x | +
+ sep <- "\n"+ |
+ ||
| 435 | +7x | +
+ linewidth <- width_i |
||
| 35 | +436 |
- #' ARM %in% c("B: Placebo", "A: Drug X")
+ }+ |
+ ||
| 437 | +184x | +
+ out_string[string_i] <- paste(out_string[string_i], newline_str[i], sep = sep) |
||
| 36 | +438 |
- #' ) %>%+ } |
||
| 37 | +439 |
- #' mutate(+ } |
||
| 38 | +440 |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ }+ |
+ ||
| 441 | +26x | +
+ paste(out_string, collapse = "\n") |
||
| 39 | +442 |
- #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")),+ } |
||
| 40 | +443 |
- #' is_event = CNSR == 0+ |
||
| 41 | +444 |
- #' )+ #' Update page number |
||
| 42 | +445 |
- #' labels <- c("ARM" = "Treatment Arm", "is_event" = "Event Flag")
+ #' |
||
| 43 | +446 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ #' Automatically updates page number. |
||
| 44 | +447 |
#' |
||
| 45 | +448 |
- #' variables <- list(+ #' @param npages (`numeric(1)`)\cr total number of pages. |
||
| 46 | +449 |
- #' arm = "ARM",+ #' @param ... arguments passed on to [decorate_grob()]. |
||
| 47 | +450 |
- #' biomarker = "BMRKR1",+ #' |
||
| 48 | +451 |
- #' covariates = c("AGE", "BMRKR2"),
+ #' @return Closure that increments the page number. |
||
| 49 | +452 |
- #' event = "is_event",+ #' |
||
| 50 | +453 |
- #' time = "AVAL"+ #' @keywords internal |
||
| 51 | +454 |
- #' )+ decorate_grob_factory <- function(npages, ...) {
|
||
| 52 | -+ | |||
| 455 | +2x |
- #'+ current_page <- 0 |
||
| 53 | -+ | |||
| 456 | +2x |
- #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup.+ function(grob) {
|
||
| 54 | -+ | |||
| 457 | +7x |
- #' step_matrix <- fit_survival_step(+ current_page <<- current_page + 1 |
||
| 55 | -+ | |||
| 458 | +7x |
- #' variables = variables,+ if (current_page > npages) {
|
||
| 56 | -+ | |||
| 459 | +1x |
- #' data = adtte_f+ stop(paste("current page is", current_page, "but max.", npages, "specified."))
|
||
| 57 | +460 |
- #' )+ } |
||
| 58 | -+ | |||
| 461 | +6x |
- #' dim(step_matrix)+ decorate_grob(grob = grob, page = paste("Page", current_page, "of", npages), ...)
|
||
| 59 | +462 |
- #' head(step_matrix)+ } |
||
| 60 | +463 |
- #'+ } |
||
| 61 | +464 |
- #' # Specify different polynomial degree for the biomarker interaction to use more flexible local+ |
||
| 62 | +465 |
- #' # models. Or specify different Cox regression options.+ #' Decorate set of `grob`s and add page numbering |
||
| 63 | +466 |
- #' step_matrix2 <- fit_survival_step(+ #' |
||
| 64 | +467 |
- #' variables = variables,+ #' @description `r lifecycle::badge("stable")`
|
||
| 65 | +468 |
- #' data = adtte_f,+ #' |
||
| 66 | +469 |
- #' control = c(control_coxph(conf_level = 0.9), control_step(degree = 2))+ #' Note that this uses the [decorate_grob_factory()] function. |
||
| 67 | +470 |
- #' )+ #' |
||
| 68 | +471 |
- #'+ #' @param grobs (`list` of `grob`)\cr a list of grid grobs. |
||
| 69 | +472 |
- #' # Use a global model with cubic interaction and only 5 points.+ #' @param ... arguments passed on to [decorate_grob()]. |
||
| 70 | +473 |
- #' step_matrix3 <- fit_survival_step(+ #' |
||
| 71 | +474 |
- #' variables = variables,+ #' @return A decorated grob. |
||
| 72 | +475 |
- #' data = adtte_f,+ #' |
||
| 73 | +476 |
- #' control = c(control_coxph(), control_step(bandwidth = NULL, degree = 3, num_points = 5L))+ #' @examples |
||
| 74 | +477 |
- #' )+ #' library(ggplot2) |
||
| 75 | +478 |
- #'+ #' library(grid) |
||
| 76 | +479 |
- #' @export+ #' g <- with(data = iris, {
|
||
| 77 | +480 |
- fit_survival_step <- function(variables,+ #' list( |
||
| 78 | +481 |
- data,+ #' ggplot2::ggplotGrob( |
||
| 79 | +482 |
- control = c(control_step(), control_coxph())) {
- |
- ||
| 80 | -4x | -
- checkmate::assert_list(control)+ #' ggplot2::ggplot(mapping = aes(Sepal.Length, Sepal.Width, col = Species)) + |
||
| 81 | -4x | +|||
| 483 | +
- assert_df_with_variables(data, variables)+ #' ggplot2::geom_point() |
|||
| 82 | -4x | +|||
| 484 | +
- data <- data[!is.na(data[[variables$biomarker]]), ]+ #' ), |
|||
| 83 | -4x | +|||
| 485 | +
- window_sel <- h_step_window(x = data[[variables$biomarker]], control = control)+ #' ggplot2::ggplotGrob( |
|||
| 84 | -4x | +|||
| 486 | +
- interval_center <- window_sel$interval[, "Interval Center"]+ #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Length, col = Species)) + |
|||
| 85 | -4x | +|||
| 487 | +
- form <- h_step_survival_formula(variables = variables, control = control)+ #' ggplot2::geom_point() |
|||
| 86 | -4x | +|||
| 488 | +
- estimates <- if (is.null(control$bandwidth)) {
+ #' ), |
|||
| 87 | -1x | +|||
| 489 | +
- h_step_survival_est(+ #' ggplot2::ggplotGrob( |
|||
| 88 | -1x | +|||
| 490 | +
- formula = form,+ #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Width, col = Species)) + |
|||
| 89 | -1x | +|||
| 491 | +
- data = data,+ #' ggplot2::geom_point() |
|||
| 90 | -1x | +|||
| 492 | +
- variables = variables,+ #' ), |
|||
| 91 | -1x | +|||
| 493 | +
- x = interval_center,+ #' ggplot2::ggplotGrob( |
|||
| 92 | -1x | +|||
| 494 | +
- control = control+ #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Length, col = Species)) + |
|||
| 93 | +495 |
- )+ #' ggplot2::geom_point() |
||
| 94 | +496 |
- } else {
+ #' ), |
||
| 95 | -3x | +|||
| 497 | +
- tmp <- mapply(+ #' ggplot2::ggplotGrob( |
|||
| 96 | -3x | +|||
| 498 | +
- FUN = h_step_survival_est,+ #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Width, col = Species)) + |
|||
| 97 | -3x | +|||
| 499 | +
- x = interval_center,+ #' ggplot2::geom_point() |
|||
| 98 | -3x | +|||
| 500 | +
- subset = as.list(as.data.frame(window_sel$sel)),+ #' ), |
|||
| 99 | -3x | +|||
| 501 | +
- MoreArgs = list(+ #' ggplot2::ggplotGrob( |
|||
| 100 | -3x | +|||
| 502 | +
- formula = form,+ #' ggplot2::ggplot(mapping = aes(Petal.Length, Petal.Width, col = Species)) + |
|||
| 101 | -3x | +|||
| 503 | +
- data = data,+ #' ggplot2::geom_point() |
|||
| 102 | -3x | +|||
| 504 | +
- variables = variables,+ #' ) |
|||
| 103 | -3x | +|||
| 505 | +
- control = control+ #' ) |
|||
| 104 | +506 |
- )+ #' }) |
||
| 105 | +507 |
- )+ #' lg <- decorate_grob_set(grobs = g, titles = "Hello\nOne\nTwo\nThree", footnotes = "") |
||
| 106 | +508 |
- # Maybe we find a more elegant solution than this.+ #' |
||
| 107 | -3x | +|||
| 509 | +
- rownames(tmp) <- c("n", "events", "loghr", "se", "ci_lower", "ci_upper")
+ #' draw_grob(lg[[1]]) |
|||
| 108 | -3x | +|||
| 510 | +
- t(tmp)+ #' draw_grob(lg[[2]]) |
|||
| 109 | +511 |
- }+ #' draw_grob(lg[[6]]) |
||
| 110 | -4x | +|||
| 512 | +
- result <- cbind(window_sel$interval, estimates)+ #' |
|||
| 111 | -4x | +|||
| 513 | +
- structure(+ #' @export |
|||
| 112 | -4x | +|||
| 514 | +
- result,+ decorate_grob_set <- function(grobs, ...) {
|
|||
| 113 | -4x | +515 | +1x |
- class = c("step", "matrix"),
+ n <- length(grobs) |
| 114 | -4x | +516 | +1x |
- variables = variables,+ lgf <- decorate_grob_factory(npages = n, ...) |
| 115 | -4x | -
- control = control- |
- ||
| 116 | -+ | 517 | +1x |
- )+ lapply(grobs, lgf) |
| 117 | +518 |
}@@ -130800,14 +129886,14 @@ tern coverage - 95.64% |
| 1 |
- #' Helper function to create a map data frame for `trim_levels_to_map()`+ #' Survival time point analysis |
||
| 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 [surv_timepoint()] creates a layout element to analyze patient survival rates and difference |
||
| 6 |
- #' `trim_levels_to_map` split function. Based on different method, the map is constructed differently.+ #' of survival rates between groups at a given time point. The primary analysis variable `vars` is the time variable. |
||
| 7 |
- #'+ #' Other required inputs are `time_point`, the numeric time point of interest, and `is_event`, a variable that |
||
| 8 |
- #' @inheritParams argument_convention+ #' indicates whether or not an event has occurred. The `method` argument is used to specify whether you want to analyze |
||
| 9 |
- #' @param abnormal (named `list`)\cr identifying the abnormal range level(s) in `df`. Based on the levels of+ #' survival estimations (`"surv"`), difference in survival with the control (`"surv_diff"`), or both of these |
||
| 10 |
- #' abnormality of the input dataset, it can be something like `list(Low = "LOW LOW", High = "HIGH HIGH")` or+ #' (`"both"`). |
||
| 11 |
- #' `abnormal = list(Low = "LOW", High = "HIGH"))`+ #' |
||
| 12 |
- #' @param method (`string`)\cr indicates how the returned map will be constructed. Can be `"default"` or `"range"`.+ #' @inheritParams argument_convention |
||
| 13 |
- #'+ #' @inheritParams s_surv_time |
||
| 14 |
- #' @return A map `data.frame`.+ #' @param time_point (`numeric(1)`)\cr survival time point of interest. |
||
| 15 |
- #'+ #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function |
||
| 16 |
- #' @note If method is `"default"`, the returned map will only have the abnormal directions that are observed in the+ #' [control_surv_timepoint()]. Some possible parameter options are: |
||
| 17 |
- #' `df`, and records with all normal values will be excluded to avoid error in creating layout. If method is+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate. |
||
| 18 |
- #' `"range"`, the returned map will be based on the rule that at least one observation with low range > 0+ #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log", |
||
| 19 |
- #' for low direction and at least one observation with high range is not missing for high direction.+ #' see more in [survival::survfit()]. Note option "none" is no longer supported. |
||
| 20 |
- #'+ #' @param method (`string`)\cr `"surv"` (survival estimations), `"surv_diff"` (difference in survival with the |
||
| 21 |
- #' @examples+ #' control), or `"both"`. |
||
| 22 |
- #' adlb <- df_explicit_na(tern_ex_adlb)+ #' @param table_names_suffix (`string`)\cr optional suffix for the `table_names` used for the `rtables` to |
||
| 23 |
- #'+ #' avoid warnings from duplicate table names. |
||
| 24 |
- #' h_map_for_count_abnormal(+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("surv_timepoint")`
|
||
| 25 |
- #' df = adlb,+ #' to see available statistics for this function. |
||
| 26 |
- #' variables = list(anl = "ANRIND", split_rows = c("LBCAT", "PARAM")),
+ #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 27 |
- #' abnormal = list(low = c("LOW"), high = c("HIGH")),
+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
||
| 28 |
- #' method = "default",+ #' for that statistic's row label. |
||
| 29 |
- #' na_str = "<Missing>"+ #' |
||
| 30 |
- #' )+ #' @name survival_timepoint |
||
| 31 |
- #'+ #' @order 1 |
||
| 32 |
- #' df <- data.frame(+ NULL |
||
| 33 |
- #' USUBJID = c(rep("1", 4), rep("2", 4), rep("3", 4)),
+
|
||
| 34 |
- #' AVISIT = c(+ #' @describeIn survival_timepoint Statistics function which analyzes survival rate. |
||
| 35 |
- #' rep("WEEK 1", 2),
+ #' |
||
| 36 |
- #' rep("WEEK 2", 2),
+ #' @return |
||
| 37 |
- #' rep("WEEK 1", 2),
+ #' * `s_surv_timepoint()` returns the statistics: |
||
| 38 |
- #' rep("WEEK 2", 2),
+ #' * `pt_at_risk`: Patients remaining at risk. |
||
| 39 |
- #' rep("WEEK 1", 2),
+ #' * `event_free_rate`: Event-free rate (%). |
||
| 40 |
- #' rep("WEEK 2", 2)
+ #' * `rate_se`: Standard error of event free rate. |
||
| 41 |
- #' ),+ #' * `rate_ci`: Confidence interval for event free rate. |
||
| 42 |
- #' PARAM = rep(c("ALT", "CPR"), 6),
+ #' |
||
| 43 |
- #' ANRIND = c(+ #' @keywords internal |
||
| 44 |
- #' "NORMAL", "NORMAL", "LOW",+ s_surv_timepoint <- function(df, |
||
| 45 |
- #' "HIGH", "LOW", "LOW", "HIGH", "HIGH", rep("NORMAL", 4)
+ .var, |
||
| 46 |
- #' ),+ time_point, |
||
| 47 |
- #' ANRLO = rep(5, 12),+ is_event, |
||
| 48 |
- #' ANRHI = rep(20, 12)+ control = control_surv_timepoint()) {
|
||
| 49 | -+ | 23x |
- #' )+ checkmate::assert_string(.var) |
| 50 | -+ | 23x |
- #' df$ANRIND <- factor(df$ANRIND, levels = c("LOW", "HIGH", "NORMAL"))
+ assert_df_with_variables(df, list(tte = .var, is_event = is_event)) |
| 51 | -+ | 23x |
- #' h_map_for_count_abnormal(+ checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE) |
| 52 | -+ | 23x |
- #' df = df,+ checkmate::assert_number(time_point) |
| 53 | -+ | 23x |
- #' variables = list(+ checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE) |
| 54 |
- #' anl = "ANRIND",+ |
||
| 55 | -+ | 23x |
- #' split_rows = c("PARAM"),
+ conf_type <- control$conf_type |
| 56 | -+ | 23x |
- #' range_low = "ANRLO",+ conf_level <- control$conf_level |
| 57 |
- #' range_high = "ANRHI"+ |
||
| 58 | -+ | 23x |
- #' ),+ formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
|
| 59 | -+ | 23x |
- #' abnormal = list(low = c("LOW"), high = c("HIGH")),
+ srv_fit <- survival::survfit( |
| 60 | -+ | 23x |
- #' method = "range",+ formula = formula, |
| 61 | -+ | 23x |
- #' na_str = "<Missing>"+ data = df, |
| 62 | -+ | 23x |
- #' )+ conf.int = conf_level, |
| 63 | -+ | 23x |
- #'+ conf.type = conf_type |
| 64 |
- #' @export+ ) |
||
| 65 | -+ | 23x |
- h_map_for_count_abnormal <- function(df,+ s_srv_fit <- summary(srv_fit, times = time_point, extend = TRUE) |
| 66 | -+ | 23x |
- variables = list(+ df_srv_fit <- as.data.frame(s_srv_fit[c("time", "n.risk", "surv", "lower", "upper", "std.err")])
|
| 67 | -+ | 23x |
- anl = "ANRIND",+ if (df_srv_fit[["n.risk"]] == 0) {
|
| 68 | -+ | 1x |
- split_rows = c("PARAM"),
+ pt_at_risk <- event_free_rate <- rate_se <- NA_real_ |
| 69 | -+ | 1x |
- range_low = "ANRLO",+ rate_ci <- c(NA_real_, NA_real_) |
| 70 |
- range_high = "ANRHI"+ } else {
|
||
| 71 | -+ | 22x |
- ),+ pt_at_risk <- df_srv_fit$n.risk |
| 72 | -+ | 22x |
- abnormal = list(low = c("LOW", "LOW LOW"), high = c("HIGH", "HIGH HIGH")),
+ event_free_rate <- df_srv_fit$surv |
| 73 | -+ | 22x |
- method = c("default", "range"),
+ rate_se <- df_srv_fit$std.err |
| 74 | -+ | 22x |
- na_str = "<Missing>") {
+ rate_ci <- c(df_srv_fit$lower, df_srv_fit$upper) |
| 75 | -7x | +
- method <- match.arg(method)+ } |
|
| 76 | -7x | +23x |
- checkmate::assert_subset(c("anl", "split_rows"), names(variables))
+ list( |
| 77 | -7x | +23x |
- checkmate::assert_false(anyNA(df[variables$split_rows]))+ pt_at_risk = formatters::with_label(pt_at_risk, "Patients remaining at risk"), |
| 78 | -7x | +23x |
- assert_df_with_variables(df,+ event_free_rate = formatters::with_label(event_free_rate * 100, "Event Free Rate (%)"), |
| 79 | -7x | +23x |
- variables = list(anl = variables$anl, split_rows = variables$split_rows),+ rate_se = formatters::with_label(rate_se * 100, "Standard Error of Event Free Rate"), |
| 80 | -7x | +23x |
- na_level = na_str+ rate_ci = formatters::with_label(rate_ci * 100, f_conf_level(conf_level)) |
| 82 | -7x | +
- assert_df_with_factors(df, list(val = variables$anl))+ } |
|
| 83 | -7x | +
- assert_valid_factor(df[[variables$anl]], any.missing = FALSE)+ |
|
| 84 | -7x | +
- assert_list_of_variables(variables)+ #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()` |
|
| 85 | -7x | +
- checkmate::assert_list(abnormal, types = "character", len = 2)+ #' when `method = "surv"`. |
|
| 86 |
-
+ #' |
||
| 87 |
- # Drop usued levels from df as they are not supposed to be in the final map+ #' @return |
||
| 88 | -7x | +
- df <- droplevels(df)+ #' * `a_surv_timepoint()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 89 |
-
+ #' |
||
| 90 | -7x | +
- normal_value <- setdiff(levels(df[[variables$anl]]), unlist(abnormal))+ #' @keywords internal |
|
| 91 |
-
+ a_surv_timepoint <- make_afun( |
||
| 92 |
- # Based on the understanding of clinical data, there should only be one level of normal which is "NORMAL"+ s_surv_timepoint, |
||
| 93 | -7x | +
- checkmate::assert_vector(normal_value, len = 1)+ .indent_mods = c( |
|
| 94 |
-
+ pt_at_risk = 0L, |
||
| 95 |
- # Default method will only have what is observed in the df, and records with all normal values will be excluded to+ event_free_rate = 0L, |
||
| 96 |
- # avoid error in layout building.+ rate_se = 1L, |
||
| 97 | -7x | +
- if (method == "default") {
+ rate_ci = 1L |
|
| 98 | -3x | +
- df_abnormal <- subset(df, df[[variables$anl]] %in% unlist(abnormal))+ ), |
|
| 99 | -3x | +
- map <- unique(df_abnormal[c(variables$split_rows, variables$anl)])+ .formats = c( |
|
| 100 | -3x | +
- map_normal <- unique(subset(map, select = variables$split_rows))+ pt_at_risk = "xx", |
|
| 101 | -3x | +
- map_normal[[variables$anl]] <- normal_value+ event_free_rate = "xx.xx", |
|
| 102 | -3x | +
- map <- rbind(map, map_normal)+ rate_se = "xx.xx", |
|
| 103 | -4x | +
- } else if (method == "range") {
+ rate_ci = "(xx.xx, xx.xx)" |
|
| 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))
+
|
|
| 107 | -4x | +
- checkmate::assert_subset(c("LOW", "HIGH"), toupper(names(abnormal)))
+ #' @describeIn survival_timepoint Statistics function which analyzes difference between two survival rates. |
|
| 108 |
-
+ #' |
||
| 109 | -4x | +
- assert_df_with_variables(df,+ #' @return |
|
| 110 | -4x | +
- variables = list(+ #' * `s_surv_timepoint_diff()` returns the statistics: |
|
| 111 | -4x | +
- range_low = variables$range_low,+ #' * `rate_diff`: Event-free rate difference between two groups. |
|
| 112 | -4x | +
- range_high = variables$range_high+ #' * `rate_diff_ci`: Confidence interval for the difference. |
|
| 113 |
- )+ #' * `ztest_pval`: p-value to test the difference is 0. |
||
| 114 |
- )+ #' |
||
| 115 |
-
+ #' @keywords internal |
||
| 116 |
- # Define low direction of map+ s_surv_timepoint_diff <- function(df, |
||
| 117 | -4x | +
- df_low <- subset(df, df[[variables$range_low]] > 0)+ .var, |
|
| 118 | -4x | +
- map_low <- unique(df_low[variables$split_rows])+ .ref_group, |
|
| 119 | -4x | +
- low_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "LOW"]))+ .in_ref_col, |
|
| 120 | -4x | +
- low_levels_df <- as.data.frame(low_levels)+ time_point, |
|
| 121 | -4x | +
- colnames(low_levels_df) <- variables$anl+ control = control_surv_timepoint(), |
|
| 122 | -4x | +
- low_levels_df <- do.call("rbind", replicate(nrow(map_low), low_levels_df, simplify = FALSE))
+ ...) {
|
|
| 123 | -4x | +2x |
- rownames(map_low) <- NULL # Just to avoid strange row index in case upstream functions changed+ if (.in_ref_col) {
|
| 124 | -4x | +! |
- map_low <- map_low[rep(seq_len(nrow(map_low)), each = length(low_levels)), , drop = FALSE]+ return( |
| 125 | -4x | +! |
- map_low <- cbind(map_low, low_levels_df)+ list( |
| 126 | -+ | ! |
-
+ rate_diff = formatters::with_label("", "Difference in Event Free Rate"),
|
| 127 | -+ | ! |
- # Define high direction of map+ rate_diff_ci = formatters::with_label("", f_conf_level(control$conf_level)),
|
| 128 | -4x | +! |
- df_high <- subset(df, df[[variables$range_high]] != na_str | !is.na(df[[variables$range_high]]))+ ztest_pval = formatters::with_label("", "p-value (Z-test)")
|
| 129 | -4x | +
- map_high <- unique(df_high[variables$split_rows])+ ) |
|
| 130 | -4x | +
- high_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "HIGH"]))+ ) |
|
| 131 | -4x | +
- high_levels_df <- as.data.frame(high_levels)+ } |
|
| 132 | -4x | +2x |
- colnames(high_levels_df) <- variables$anl+ data <- rbind(.ref_group, df) |
| 133 | -4x | +2x |
- high_levels_df <- do.call("rbind", replicate(nrow(map_high), high_levels_df, simplify = FALSE))
+ group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
|
| 134 | -4x | +2x |
- rownames(map_high) <- NULL+ res_per_group <- lapply(split(data, group), function(x) {
|
| 135 | 4x |
- map_high <- map_high[rep(seq_len(nrow(map_high)), each = length(high_levels)), , drop = FALSE]+ s_surv_timepoint(df = x, .var = .var, time_point = time_point, control = control, ...) |
|
| 136 | -4x | +
- map_high <- cbind(map_high, high_levels_df)+ }) |
|
| 138 | -+ | 2x |
- # Define normal of map+ res_x <- res_per_group[[2]] |
| 139 | -4x | +2x |
- map_normal <- unique(rbind(map_low, map_high)[variables$split_rows])+ res_ref <- res_per_group[[1]] |
| 140 | -4x | +2x |
- map_normal[variables$anl] <- normal_value+ rate_diff <- res_x$event_free_rate - res_ref$event_free_rate |
| 141 | -+ | 2x |
-
+ se_diff <- sqrt(res_x$rate_se^2 + res_ref$rate_se^2) |
| 142 | -4x | +
- map <- rbind(map_low, map_high, map_normal)+ |
|
| 143 | -+ | 2x |
- }+ qs <- c(-1, 1) * stats::qnorm(1 - (1 - control$conf_level) / 2) |
| 144 | -+ | 2x |
-
+ rate_diff_ci <- rate_diff + qs * se_diff |
| 145 | -+ | 2x |
- # map should be all characters+ ztest_pval <- if (is.na(rate_diff)) {
|
| 146 | -7x | +2x |
- map <- data.frame(lapply(map, as.character), stringsAsFactors = FALSE)+ NA |
| 147 |
-
+ } else {
|
||
| 148 | -+ | 2x |
- # sort the map final output by split_rows variables+ 2 * (1 - stats::pnorm(abs(rate_diff) / se_diff)) |
| 149 | -7x | +
- for (i in rev(seq_len(length(variables$split_rows)))) {
+ } |
|
| 150 | -7x | +2x |
- map <- map[order(map[[i]]), ]+ list( |
| 151 | -+ | 2x |
- }+ rate_diff = formatters::with_label(rate_diff, "Difference in Event Free Rate"), |
| 152 | -7x | +2x |
- map+ rate_diff_ci = formatters::with_label(rate_diff_ci, f_conf_level(control$conf_level)), |
| 153 | -+ | 2x |
- }+ ztest_pval = formatters::with_label(ztest_pval, "p-value (Z-test)") |
| 1 | +154 |
- #' Subgroup treatment effect pattern (STEP) fit for binary (response) outcome+ ) |
||
| 2 | +155 |
- #'+ } |
||
| 3 | +156 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 4 | +157 |
- #'+ #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()` |
||
| 5 | +158 |
- #' This fits the Subgroup Treatment Effect Pattern logistic regression models for a binary+ #' when `method = "surv_diff"`. |
||
| 6 | +159 |
- #' (response) outcome. The treatment arm variable must have exactly 2 levels,+ #' |
||
| 7 | +160 |
- #' where the first one is taken as reference and the estimated odds ratios are+ #' @return |
||
| 8 | +161 |
- #' for the comparison of the second level vs. the first one.+ #' * `a_surv_timepoint_diff()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 9 | +162 |
#' |
||
| 10 | +163 |
- #' The (conditional) logistic regression model which is fit is:+ #' @keywords internal |
||
| 11 | +164 |
- #'+ a_surv_timepoint_diff <- make_afun( |
||
| 12 | +165 |
- #' `response ~ arm * poly(biomarker, degree) + covariates + strata(strata)`+ s_surv_timepoint_diff, |
||
| 13 | +166 |
- #'+ .formats = c( |
||
| 14 | +167 |
- #' where `degree` is specified by `control_step()`.+ rate_diff = "xx.xx", |
||
| 15 | +168 |
- #'+ rate_diff_ci = "(xx.xx, xx.xx)", |
||
| 16 | +169 |
- #' @inheritParams argument_convention+ ztest_pval = "x.xxxx | (<0.0001)" |
||
| 17 | +170 |
- #' @param variables (named `list` of `character`)\cr list of analysis variables:+ ) |
||
| 18 | +171 |
- #' needs `response`, `arm`, `biomarker`, and optional `covariates` and `strata`.+ ) |
||
| 19 | +172 |
- #' @param control (named `list`)\cr combined control list from [control_step()]+ |
||
| 20 | +173 |
- #' and [control_logistic()].+ #' @describeIn survival_timepoint Layout-creating function which can take statistics function arguments |
||
| 21 | +174 |
- #'+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 22 | +175 |
- #' @return A matrix of class `step`. The first part of the columns describe the+ #' |
||
| 23 | +176 |
- #' subgroup intervals used for the biomarker variable, including where the+ #' @return |
||
| 24 | +177 |
- #' center of the intervals are and their bounds. The second part of the+ #' * `surv_timepoint()` returns a layout object suitable for passing to further layouting functions, |
||
| 25 | +178 |
- #' columns contain the estimates for the treatment arm comparison.+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 26 | +179 |
- #'+ #' the statistics from `s_surv_timepoint()` and/or `s_surv_timepoint_diff()` to the table layout depending on |
||
| 27 | +180 |
- #' @note For the default degree 0 the `biomarker` variable is not included in the model.+ #' the value of `method`. |
||
| 28 | +181 |
#' |
||
| 29 | +182 |
- #' @seealso [control_step()] and [control_logistic()] for the available+ #' @examples |
||
| 30 | +183 |
- #' customization options.+ #' library(dplyr) |
||
| 31 | +184 |
#' |
||
| 32 | -- |
- #' @examples- |
- ||
| 33 | +185 |
- #' # Testing dataset with just two treatment arms.+ #' adtte_f <- tern_ex_adtte %>% |
||
| 34 | +186 |
- #' library(survival)+ #' filter(PARAMCD == "OS") %>% |
||
| 35 | +187 |
- #' library(dplyr)+ #' mutate( |
||
| 36 | +188 |
- #'+ #' AVAL = day2month(AVAL), |
||
| 37 | +189 |
- #' adrs_f <- tern_ex_adrs %>%+ #' is_event = CNSR == 0 |
||
| 38 | +190 |
- #' filter(+ #' ) |
||
| 39 | +191 |
- #' PARAMCD == "BESRSPI",+ #' |
||
| 40 | +192 |
- #' ARM %in% c("B: Placebo", "A: Drug X")
+ #' # Survival at given time points. |
||
| 41 | +193 |
- #' ) %>%+ #' basic_table() %>% |
||
| 42 | +194 |
- #' mutate(+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
||
| 43 | +195 |
- #' # Reorder levels of ARM to have Placebo as reference arm for Odds Ratio calculations.+ #' add_colcounts() %>% |
||
| 44 | +196 |
- #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")),+ #' surv_timepoint( |
||
| 45 | +197 |
- #' RSP = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ #' vars = "AVAL", |
||
| 46 | +198 |
- #' SEX = factor(SEX)+ #' var_labels = "Months", |
||
| 47 | +199 |
- #' )+ #' is_event = "is_event", |
||
| 48 | +200 |
- #'+ #' time_point = 7 |
||
| 49 | +201 |
- #' variables <- list(+ #' ) %>% |
||
| 50 | +202 |
- #' arm = "ARM",+ #' build_table(df = adtte_f) |
||
| 51 | +203 |
- #' biomarker = "BMRKR1",+ #' |
||
| 52 | +204 |
- #' covariates = "AGE",+ #' # Difference in survival at given time points. |
||
| 53 | +205 |
- #' response = "RSP"+ #' basic_table() %>% |
||
| 54 | +206 |
- #' )+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
||
| 55 | +207 |
- #'+ #' add_colcounts() %>% |
||
| 56 | +208 |
- #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup.+ #' surv_timepoint( |
||
| 57 | +209 |
- #' # We use a large enough bandwidth to avoid too small subgroups and linear separation in those.+ #' vars = "AVAL", |
||
| 58 | +210 |
- #' step_matrix <- fit_rsp_step(+ #' var_labels = "Months", |
||
| 59 | +211 |
- #' variables = variables,+ #' is_event = "is_event", |
||
| 60 | +212 |
- #' data = adrs_f,+ #' time_point = 9, |
||
| 61 | +213 |
- #' control = c(control_logistic(), control_step(bandwidth = 0.9))+ #' method = "surv_diff", |
||
| 62 | +214 |
- #' )+ #' .indent_mods = c("rate_diff" = 0L, "rate_diff_ci" = 2L, "ztest_pval" = 2L)
|
||
| 63 | +215 |
- #' dim(step_matrix)+ #' ) %>% |
||
| 64 | +216 |
- #' head(step_matrix)+ #' build_table(df = adtte_f) |
||
| 65 | +217 |
#' |
||
| 66 | +218 |
- #' # Specify different polynomial degree for the biomarker interaction to use more flexible local+ #' # Survival and difference in survival at given time points. |
||
| 67 | +219 |
- #' # models. Or specify different logistic regression options, including confidence level.+ #' basic_table() %>% |
||
| 68 | +220 |
- #' step_matrix2 <- fit_rsp_step(+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
||
| 69 | +221 |
- #' variables = variables,+ #' add_colcounts() %>% |
||
| 70 | +222 |
- #' data = adrs_f,+ #' surv_timepoint( |
||
| 71 | +223 |
- #' control = c(control_logistic(conf_level = 0.9), control_step(bandwidth = NULL, degree = 1))+ #' vars = "AVAL", |
||
| 72 | +224 |
- #' )+ #' var_labels = "Months", |
||
| 73 | +225 |
- #'+ #' is_event = "is_event", |
||
| 74 | +226 |
- #' # Use a global constant model. This is helpful as a reference for the subgroup models.+ #' time_point = 9, |
||
| 75 | +227 |
- #' step_matrix3 <- fit_rsp_step(+ #' method = "both" |
||
| 76 | +228 |
- #' variables = variables,+ #' ) %>% |
||
| 77 | +229 |
- #' data = adrs_f,+ #' build_table(df = adtte_f) |
||
| 78 | +230 |
- #' control = c(control_logistic(), control_step(bandwidth = NULL, num_points = 2L))+ #' |
||
| 79 | +231 |
- #' )+ #' @export |
||
| 80 | +232 |
- #'+ #' @order 2 |
||
| 81 | +233 |
- #' # It is also possible to use strata, i.e. use conditional logistic regression models.+ surv_timepoint <- function(lyt, |
||
| 82 | +234 |
- #' variables2 <- list(+ vars, |
||
| 83 | +235 |
- #' arm = "ARM",+ time_point, |
||
| 84 | +236 |
- #' biomarker = "BMRKR1",+ is_event, |
||
| 85 | +237 |
- #' covariates = "AGE",+ control = control_surv_timepoint(), |
||
| 86 | +238 |
- #' response = "RSP",+ method = c("surv", "surv_diff", "both"),
|
||
| 87 | +239 |
- #' strata = c("STRATA1", "STRATA2")
+ na_str = default_na_str(), |
||
| 88 | +240 |
- #' )+ nested = TRUE, |
||
| 89 | +241 |
- #'+ ..., |
||
| 90 | +242 |
- #' step_matrix4 <- fit_rsp_step(+ table_names_suffix = "", |
||
| 91 | +243 |
- #' variables = variables2,+ var_labels = "Time", |
||
| 92 | +244 |
- #' data = adrs_f,+ show_labels = "visible", |
||
| 93 | +245 |
- #' control = c(control_logistic(), control_step(bandwidth = NULL))+ .stats = c( |
||
| 94 | +246 |
- #' )+ "pt_at_risk", "event_free_rate", "rate_ci", |
||
| 95 | +247 |
- #'+ "rate_diff", "rate_diff_ci", "ztest_pval" |
||
| 96 | +248 |
- #' @export+ ), |
||
| 97 | +249 |
- fit_rsp_step <- function(variables,+ .formats = NULL, |
||
| 98 | +250 |
- data,+ .labels = NULL, |
||
| 99 | +251 |
- control = c(control_step(), control_logistic())) {
- |
- ||
| 100 | -5x | -
- assert_df_with_variables(data, variables)+ .indent_mods = if (method == "both") {
|
||
| 101 | -5x | +252 | +2x |
- checkmate::assert_list(control, names = "named")+ c(rate_diff = 1L, rate_diff_ci = 2L, ztest_pval = 2L) |
| 102 | -5x | +|||
| 253 | +
- data <- data[!is.na(data[[variables$biomarker]]), ]+ } else {
|
|||
| 103 | -5x | +254 | +4x |
- window_sel <- h_step_window(x = data[[variables$biomarker]], control = control)+ c(rate_diff_ci = 1L, ztest_pval = 1L) |
| 104 | -5x | +|||
| 255 | +
- interval_center <- window_sel$interval[, "Interval Center"]+ }) {
|
|||
| 105 | -5x | +256 | +6x |
- form <- h_step_rsp_formula(variables = variables, control = control)+ method <- match.arg(method) |
| 106 | -5x | +257 | +6x |
- estimates <- if (is.null(control$bandwidth)) {
+ checkmate::assert_string(table_names_suffix) |
| 107 | -1x | +|||
| 258 | +
- h_step_rsp_est(+ |
|||
| 108 | -1x | +259 | +6x |
- formula = form,+ extra_args <- list(time_point = time_point, is_event = is_event, control = control, ...) |
| 109 | -1x | +|||
| 260 | +
- data = data,+ |
|||
| 110 | -1x | +261 | +6x |
- variables = variables,+ f <- list( |
| 111 | -1x | +262 | +6x |
- x = interval_center,+ surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
|
| 112 | -1x | -
- control = control- |
- ||
| 113 | -+ | 263 | +6x |
- )+ surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
|
| 114 | +264 |
- } else {
+ ) |
||
| 115 | -4x | +265 | +6x |
- tmp <- mapply(+ .stats <- h_split_param(.stats, .stats, f = f) |
| 116 | -4x | +266 | +6x |
- FUN = h_step_rsp_est,+ .formats <- h_split_param(.formats, names(.formats), f = f) |
| 117 | -4x | +267 | +6x |
- x = interval_center,+ .labels <- h_split_param(.labels, names(.labels), f = f) |
| 118 | -4x | +268 | +6x |
- subset = as.list(as.data.frame(window_sel$sel)),+ .indent_mods <- h_split_param(.indent_mods, names(.indent_mods), f = f) |
| 119 | -4x | +|||
| 269 | +
- MoreArgs = list(+ |
|||
| 120 | -4x | +270 | +6x |
- formula = form,+ afun_surv <- make_afun( |
| 121 | -4x | +271 | +6x |
- data = data,+ a_surv_timepoint, |
| 122 | -4x | +272 | +6x |
- variables = variables,+ .stats = .stats$surv, |
| 123 | -4x | +273 | +6x |
- control = control+ .formats = .formats$surv, |
| 124 | -+ | |||
| 274 | +6x |
- )+ .labels = .labels$surv, |
||
| 125 | -+ | |||
| 275 | +6x |
- )+ .indent_mods = .indent_mods$surv |
||
| 126 | +276 |
- # Maybe we find a more elegant solution than this.- |
- ||
| 127 | -4x | -
- rownames(tmp) <- c("n", "logor", "se", "ci_lower", "ci_upper")
- |
- ||
| 128 | -4x | -
- t(tmp)+ ) |
||
| 129 | +277 |
- }+ |
||
| 130 | -5x | +278 | +6x |
- result <- cbind(window_sel$interval, estimates)+ afun_surv_diff <- make_afun( |
| 131 | -5x | +279 | +6x |
- structure(+ a_surv_timepoint_diff, |
| 132 | -5x | +280 | +6x |
- result,+ .stats = .stats$surv_diff, |
| 133 | -5x | +281 | +6x |
- class = c("step", "matrix"),
+ .formats = .formats$surv_diff, |
| 134 | -5x | +282 | +6x |
- variables = variables,+ .labels = .labels$surv_diff, |
| 135 | -5x | +283 | +6x |
- control = control+ .indent_mods = .indent_mods$surv_diff |
| 136 | +284 |
) |
||
| 137 | -- |
- }- |
-
| 1 | -- |
- #' Helper functions for tabulating biomarker effects on survival by subgroup- |
- ||
| 2 | -- |
- #'- |
- ||
| 3 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- ||
| 4 | -- |
- #'- |
- ||
| 5 | -- |
- #' Helper functions which are documented here separately to not confuse the user- |
- ||
| 6 | -- |
- #' when reading about the user-facing functions.- |
- ||
| 7 | -- |
- #'- |
- ||
| 8 | -- |
- #' @inheritParams survival_biomarkers_subgroups- |
- ||
| 9 | -- |
- #' @inheritParams argument_convention- |
- ||
| 10 | -- |
- #' @inheritParams fit_coxreg_multivar- |
- ||
| 11 | -- |
- #'- |
- ||
| 12 | -- |
- #' @examples- |
- ||
| 13 | -- |
- #' library(dplyr)- |
- ||
| 14 | -- |
- #' library(forcats)- |
- ||
| 15 | -- |
- #'- |
- ||
| 16 | -- |
- #' adtte <- tern_ex_adtte- |
- ||
| 17 | -- |
- #'- |
- ||
| 18 | -- |
- #' # Save variable labels before data processing steps.- |
- ||
| 19 | -- |
- #' adtte_labels <- formatters::var_labels(adtte, fill = FALSE)- |
- ||
| 20 | -- |
- #'- |
- ||
| 21 | -- |
- #' adtte_f <- adtte %>%- |
- ||
| 22 | -- |
- #' filter(PARAMCD == "OS") %>%- |
- ||
| 23 | -- |
- #' mutate(- |
- ||
| 24 | -- |
- #' AVALU = as.character(AVALU),- |
- ||
| 25 | -- |
- #' is_event = CNSR == 0- |
- ||
| 26 | -- |
- #' )- |
- ||
| 27 | -- |
- #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
- |
- ||
| 28 | -- |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels- |
- ||
| 29 | -- |
- #'- |
- ||
| 30 | -- |
- #' @name h_survival_biomarkers_subgroups- |
- ||
| 31 | -- |
- NULL- |
- ||
| 32 | +285 | |||
| 33 | -- |
- #' @describeIn h_survival_biomarkers_subgroups Helps with converting the "survival" function variable list- |
- ||
| 34 | -- |
- #' to the "Cox regression" variable list. The reason is that currently there is an inconsistency between the variable- |
- ||
| 35 | -- |
- #' names accepted by `extract_survival_subgroups()` and `fit_coxreg_multivar()`.- |
- ||
| 36 | -- |
- #'- |
- ||
| 37 | -+ | |||
| 286 | +6x |
- #' @param biomarker (`string`)\cr the name of the biomarker variable.+ time_point <- extra_args$time_point |
||
| 38 | +287 |
- #'+ |
||
| 39 | -+ | |||
| 288 | +6x |
- #' @return+ for (i in seq_along(time_point)) {
|
||
| 40 | -+ | |||
| 289 | +6x |
- #' * `h_surv_to_coxreg_variables()` returns a named `list` of elements `time`, `event`, `arm`,+ extra_args[["time_point"]] <- time_point[i] |
||
| 41 | +290 |
- #' `covariates`, and `strata`.+ |
||
| 42 | -+ | |||
| 291 | +6x |
- #'+ if (method %in% c("surv", "both")) {
|
||
| 43 | -+ | |||
| 292 | +4x |
- #' @examples+ lyt <- analyze( |
||
| 44 | -+ | |||
| 293 | +4x |
- #' # This is how the variable list is converted internally.+ lyt, |
||
| 45 | -+ | |||
| 294 | +4x |
- #' h_surv_to_coxreg_variables(+ vars, |
||
| 46 | -+ | |||
| 295 | +4x |
- #' variables = list(+ var_labels = paste(time_point[i], var_labels), |
||
| 47 | -+ | |||
| 296 | +4x |
- #' tte = "AVAL",+ table_names = paste0("surv_", time_point[i], table_names_suffix),
|
||
| 48 | -+ | |||
| 297 | +4x |
- #' is_event = "EVNT",+ show_labels = show_labels, |
||
| 49 | -+ | |||
| 298 | +4x |
- #' covariates = c("A", "B"),
+ afun = afun_surv, |
||
| 50 | -+ | |||
| 299 | +4x |
- #' strata = "D"+ na_str = na_str, |
||
| 51 | -+ | |||
| 300 | +4x |
- #' ),+ nested = nested, |
||
| 52 | -+ | |||
| 301 | +4x |
- #' biomarker = "AGE"+ extra_args = extra_args |
||
| 53 | +302 |
- #' )+ ) |
||
| 54 | +303 |
- #'+ } |
||
| 55 | +304 |
- #' @export+ |
||
| 56 | -+ | |||
| 305 | +6x |
- h_surv_to_coxreg_variables <- function(variables, biomarker) {
+ if (method %in% c("surv_diff", "both")) {
|
||
| 57 | -65x | +306 | +4x |
- checkmate::assert_list(variables)+ lyt <- analyze( |
| 58 | -65x | +307 | +4x |
- checkmate::assert_string(variables$tte)+ lyt, |
| 59 | -65x | +308 | +4x |
- checkmate::assert_string(variables$is_event)+ vars, |
| 60 | -65x | +309 | +4x |
- checkmate::assert_string(biomarker)+ var_labels = paste(time_point[i], var_labels), |
| 61 | -65x | +310 | +4x |
- list(+ table_names = paste0("surv_diff_", time_point[i], table_names_suffix),
|
| 62 | -65x | +311 | +4x |
- time = variables$tte,+ show_labels = ifelse(method == "both", "hidden", show_labels), |
| 63 | -65x | +312 | +4x |
- event = variables$is_event,+ afun = afun_surv_diff, |
| 64 | -65x | +313 | +4x |
- arm = biomarker,+ na_str = na_str, |
| 65 | -65x | +314 | +4x |
- covariates = variables$covariates,+ nested = nested, |
| 66 | -65x | +315 | +4x |
- strata = variables$strata+ extra_args = extra_args |
| 67 | +316 |
- )+ ) |
||
| 68 | +317 |
- }+ } |
||
| 69 | +318 |
-
+ } |
||
| 70 | -+ | |||
| 319 | +6x |
- #' @describeIn h_survival_biomarkers_subgroups Prepares estimates for number of events, patients and median survival+ lyt |
||
| 71 | +320 |
- #' times, as well as hazard ratio estimates, confidence intervals and p-values, for multiple biomarkers+ } |
| 72 | +1 |
- #' in a given single data set.+ #' Tabulate binary response by subgroup |
||
| 73 | +2 |
- #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements+ #' |
||
| 74 | +3 |
- #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables) and optionally `subgroups` and `strata`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 75 | +4 |
#' |
||
| 76 | +5 |
- #' @return+ #' The [tabulate_rsp_subgroups()] function creates a layout element to tabulate binary response by subgroup, returning |
||
| 77 | +6 |
- #' * `h_coxreg_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers.+ #' statistics including response rate and odds ratio for each population subgroup. The table is created from `df`, a |
||
| 78 | +7 |
- #'+ #' list of data frames returned by [extract_rsp_subgroups()], with the statistics to include specified via the `vars` |
||
| 79 | +8 |
- #' @examples+ #' parameter. |
||
| 80 | +9 |
- #' # For a single population, estimate separately the effects+ #' |
||
| 81 | +10 |
- #' # of two biomarkers.+ #' A forest plot can be created from the resulting table using the [g_forest()] function. |
||
| 82 | +11 |
- #' df <- h_coxreg_mult_cont_df(+ #' |
||
| 83 | +12 |
- #' variables = list(+ #' @inheritParams extract_rsp_subgroups |
||
| 84 | +13 |
- #' tte = "AVAL",+ #' @inheritParams argument_convention |
||
| 85 | +14 |
- #' is_event = "is_event",+ #' |
||
| 86 | +15 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' @details These functions create a layout starting from a data frame which contains |
||
| 87 | +16 |
- #' covariates = "SEX",+ #' the required statistics. Tables typically used as part of forest plot. |
||
| 88 | +17 |
- #' strata = c("STRATA1", "STRATA2")
+ #' |
||
| 89 | +18 |
- #' ),+ #' @seealso [extract_rsp_subgroups()] |
||
| 90 | +19 |
- #' data = adtte_f+ #' |
||
| 91 | +20 |
- #' )+ #' @examples |
||
| 92 | +21 |
- #' df+ #' library(dplyr) |
||
| 93 | +22 |
- #'+ #' library(forcats) |
||
| 94 | +23 |
- #' # If the data set is empty, still the corresponding rows with missings are returned.+ #' |
||
| 95 | +24 |
- #' h_coxreg_mult_cont_df(+ #' adrs <- tern_ex_adrs |
||
| 96 | +25 |
- #' variables = list(+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 97 | +26 |
- #' tte = "AVAL",+ #' |
||
| 98 | +27 |
- #' is_event = "is_event",+ #' adrs_f <- adrs %>% |
||
| 99 | +28 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 100 | +29 |
- #' covariates = "REGION1",+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
|
||
| 101 | +30 |
- #' strata = c("STRATA1", "STRATA2")
+ #' droplevels() %>% |
||
| 102 | +31 |
- #' ),+ #' mutate( |
||
| 103 | +32 |
- #' data = adtte_f[NULL, ]+ #' # Reorder levels of factor to make the placebo group the reference arm. |
||
| 104 | +33 |
- #' )+ #' ARM = fct_relevel(ARM, "B: Placebo"), |
||
| 105 | +34 |
- #'+ #' rsp = AVALC == "CR" |
||
| 106 | +35 |
- #' @export+ #' ) |
||
| 107 | +36 |
- h_coxreg_mult_cont_df <- function(variables,+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
||
| 108 | +37 |
- data,+ #' |
||
| 109 | +38 |
- control = control_coxreg()) {
- |
- ||
| 110 | -33x | -
- if ("strat" %in% names(variables)) {
- |
- ||
| 111 | -! | -
- warning(- |
- ||
| 112 | -! | -
- "Warning: the `strat` element name of the `variables` list argument to `h_coxreg_mult_cont_df() ",- |
- ||
| 113 | -! | -
- "was deprecated in tern 0.9.4.\n ",- |
- ||
| 114 | -! | -
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ #' # Unstratified analysis. |
||
| 115 | +39 |
- )- |
- ||
| 116 | -! | -
- variables[["strata"]] <- variables[["strat"]]+ #' df <- extract_rsp_subgroups( |
||
| 117 | +40 |
- }+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
||
| 118 | +41 | - - | -||
| 119 | -33x | -
- assert_df_with_variables(data, variables)- |
- ||
| 120 | -33x | -
- checkmate::assert_list(control, names = "named")- |
- ||
| 121 | -33x | -
- checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE)- |
- ||
| 122 | -33x | -
- conf_level <- control[["conf_level"]]- |
- ||
| 123 | -33x | -
- pval_label <- paste0(+ #' data = adrs_f |
||
| 124 | +42 |
- # the regex capitalizes the first letter of the string / senetence.- |
- ||
| 125 | -33x | -
- "p-value (", gsub("(^[a-z])", "\\U\\1", trimws(control[["pval_method"]]), perl = TRUE), ")"
+ #' ) |
||
| 126 | +43 |
- )+ #' df |
||
| 127 | +44 |
- # If there is any data, run model, otherwise return empty results.- |
- ||
| 128 | -33x | -
- if (nrow(data) > 0) {
- |
- ||
| 129 | -32x | -
- bm_cols <- match(variables$biomarkers, names(data))- |
- ||
| 130 | -32x | -
- l_result <- lapply(variables$biomarkers, function(bm) {
- |
- ||
| 131 | -64x | -
- coxreg_list <- fit_coxreg_multivar(- |
- ||
| 132 | -64x | -
- variables = h_surv_to_coxreg_variables(variables, bm),- |
- ||
| 133 | -64x | -
- data = data,- |
- ||
| 134 | -64x | -
- control = control+ #' |
||
| 135 | +45 |
- )- |
- ||
| 136 | -64x | -
- result <- do.call(- |
- ||
| 137 | -64x | -
- h_coxreg_multivar_extract,- |
- ||
| 138 | -64x | -
- c(list(var = bm), coxreg_list[c("mod", "data", "control")])
+ #' # Stratified analysis. |
||
| 139 | +46 |
- )- |
- ||
| 140 | -64x | -
- data_fit <- as.data.frame(as.matrix(coxreg_list$mod$y))- |
- ||
| 141 | -64x | -
- data_fit$status <- as.logical(data_fit$status)- |
- ||
| 142 | -64x | -
- median <- s_surv_time(- |
- ||
| 143 | -64x | -
- df = data_fit,- |
- ||
| 144 | -64x | -
- .var = "time",- |
- ||
| 145 | -64x | -
- is_event = "status"- |
- ||
| 146 | -64x | -
- )$median+ #' df_strat <- extract_rsp_subgroups( |
||
| 147 | -64x | +|||
| 47 | +
- data.frame(+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2"), strata = "STRATA1"),
|
|||
| 148 | +48 |
- # Dummy column needed downstream to create a nested header.+ #' data = adrs_f |
||
| 149 | -64x | +|||
| 49 | +
- biomarker = bm,+ #' ) |
|||
| 150 | -64x | +|||
| 50 | +
- biomarker_label = formatters::var_labels(data[bm], fill = TRUE),+ #' df_strat |
|||
| 151 | -64x | +|||
| 51 | +
- n_tot = coxreg_list$mod$n,+ #' |
|||
| 152 | -64x | +|||
| 52 | +
- n_tot_events = coxreg_list$mod$nevent,+ #' # Grouping of the BMRKR2 levels. |
|||
| 153 | -64x | +|||
| 53 | +
- median = as.numeric(median),+ #' df_grouped <- extract_rsp_subgroups( |
|||
| 154 | -64x | +|||
| 54 | +
- result[1L, c("hr", "lcl", "ucl")],
+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
|||
| 155 | -64x | +|||
| 55 | +
- conf_level = conf_level,+ #' data = adrs_f, |
|||
| 156 | -64x | +|||
| 56 | +
- pval = result[1L, "pval"],+ #' groups_lists = list( |
|||
| 157 | -64x | +|||
| 57 | +
- pval_label = pval_label,+ #' BMRKR2 = list( |
|||
| 158 | -64x | +|||
| 58 | +
- stringsAsFactors = FALSE+ #' "low" = "LOW", |
|||
| 159 | +59 |
- )+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 160 | +60 |
- })+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 161 | -32x | +|||
| 61 | +
- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ #' ) |
|||
| 162 | +62 |
- } else {
+ #' ) |
||
| 163 | -1x | +|||
| 63 | +
- data.frame(+ #' ) |
|||
| 164 | -1x | +|||
| 64 | +
- biomarker = variables$biomarkers,+ #' df_grouped |
|||
| 165 | -1x | +|||
| 65 | +
- biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE),+ #' |
|||
| 166 | -1x | +|||
| 66 | +
- n_tot = 0L,+ #' @name response_subgroups |
|||
| 167 | -1x | +|||
| 67 | +
- n_tot_events = 0L,+ #' @order 1 |
|||
| 168 | -1x | +|||
| 68 | +
- median = NA,+ NULL |
|||
| 169 | -1x | +|||
| 69 | +
- hr = NA,+ |
|||
| 170 | -1x | +|||
| 70 | +
- lcl = NA,+ #' Prepare response data for population subgroups in data frames |
|||
| 171 | -1x | +|||
| 71 | +
- ucl = NA,+ #' |
|||
| 172 | -1x | +|||
| 72 | +
- conf_level = conf_level,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 173 | -1x | +|||
| 73 | +
- pval = NA,+ #' |
|||
| 174 | -1x | +|||
| 74 | +
- pval_label = pval_label,+ #' Prepares response rates and odds ratios for population subgroups in data frames. Simple wrapper |
|||
| 175 | -1x | +|||
| 75 | +
- row.names = seq_along(variables$biomarkers),+ #' for [h_odds_ratio_subgroups_df()] and [h_proportion_subgroups_df()]. Result is a list of two |
|||
| 176 | -1x | +|||
| 76 | +
- stringsAsFactors = FALSE+ #' `data.frames`: `prop` and `or`. `variables` corresponds to the names of variables found in `data`, |
|||
| 177 | +77 |
- )+ #' passed as a named `list` and requires elements `rsp`, `arm` and optionally `subgroups` and `strata`. |
||
| 178 | +78 |
- }+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
||
| 179 | +79 |
- }+ #' |
||
| 180 | +80 |
-
+ #' @inheritParams argument_convention |
||
| 181 | +81 |
- #' @describeIn h_survival_biomarkers_subgroups Prepares a single sub-table given a `df_sub` containing+ #' @inheritParams response_subgroups |
||
| 182 | +82 |
- #' the results for a single biomarker.+ #' @param label_all (`string`)\cr label for the total population analysis. |
||
| 183 | +83 |
#' |
||
| 184 | +84 |
- #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is+ #' @return A named list of two elements: |
||
| 185 | +85 |
- #' returned by [extract_survival_biomarkers()] (it needs a couple of columns which are+ #' * `prop`: A `data.frame` containing columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`, `var`, |
||
| 186 | +86 |
- #' added by that high-level function relative to what is returned by [h_coxreg_mult_cont_df()],+ #' `var_label`, and `row_type`. |
||
| 187 | +87 |
- #' see the example).+ #' * `or`: A `data.frame` containing columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`, |
||
| 188 | +88 |
- #'+ #' `subgroup`, `var`, `var_label`, and `row_type`. |
||
| 189 | +89 |
- #' @return+ #' |
||
| 190 | +90 |
- #' * `h_tab_surv_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns.+ #' @seealso [response_subgroups] |
||
| 191 | +91 |
#' |
||
| 192 | +92 |
- #' @examples+ #' @export |
||
| 193 | +93 |
- #' # Starting from above `df`, zoom in on one biomarker and add required columns.+ extract_rsp_subgroups <- function(variables, |
||
| 194 | +94 |
- #' df1 <- df[1, ]+ data, |
||
| 195 | +95 |
- #' df1$subgroup <- "All patients"+ groups_lists = list(), |
||
| 196 | +96 |
- #' df1$row_type <- "content"+ conf_level = 0.95, |
||
| 197 | +97 |
- #' df1$var <- "ALL"+ method = NULL, |
||
| 198 | +98 |
- #' df1$var_label <- "All patients"+ label_all = "All Patients") {
|
||
| 199 | -+ | |||
| 99 | +14x |
- #' h_tab_surv_one_biomarker(+ if ("strat" %in% names(variables)) {
|
||
| 200 | -+ | |||
| 100 | +! |
- #' df1,+ warning( |
||
| 201 | -+ | |||
| 101 | +! |
- #' vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
+ "Warning: the `strat` element name of the `variables` list argument to `extract_rsp_subgroups() ", |
||
| 202 | -+ | |||
| 102 | +! |
- #' time_unit = "days"+ "was deprecated in tern 0.9.4.\n ", |
||
| 203 | -+ | |||
| 103 | +! |
- #' )+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 204 | +104 |
- #'+ ) |
||
| 205 | -+ | |||
| 105 | +! |
- #' @export+ variables[["strata"]] <- variables[["strat"]] |
||
| 206 | +106 |
- h_tab_surv_one_biomarker <- function(df,+ } |
||
| 207 | +107 |
- vars,+ |
||
| 208 | -+ | |||
| 108 | +14x |
- time_unit,+ df_prop <- h_proportion_subgroups_df( |
||
| 209 | -+ | |||
| 109 | +14x |
- na_str = default_na_str(),+ variables, |
||
| 210 | -+ | |||
| 110 | +14x |
- .indent_mods = 0L,+ data, |
||
| 211 | -+ | |||
| 111 | +14x |
- ...) {
+ groups_lists = groups_lists, |
||
| 212 | -10x | +112 | +14x |
- afuns <- a_survival_subgroups(na_str = na_str)[vars]+ label_all = label_all |
| 213 | -10x | +|||
| 113 | +
- colvars <- d_survival_subgroups_colvars(+ ) |
|||
| 214 | -10x | +114 | +14x |
- vars,+ df_or <- h_odds_ratio_subgroups_df( |
| 215 | -10x | +115 | +14x |
- conf_level = df$conf_level[1],+ variables, |
| 216 | -10x | +116 | +14x |
- method = df$pval_label[1],+ data, |
| 217 | -10x | +117 | +14x |
- time_unit = time_unit+ groups_lists = groups_lists, |
| 218 | -+ | |||
| 118 | +14x |
- )+ conf_level = conf_level, |
||
| 219 | -10x | +119 | +14x |
- h_tab_one_biomarker(+ method = method, |
| 220 | -10x | +120 | +14x |
- df = df,+ label_all = label_all |
| 221 | -10x | +|||
| 121 | +
- afuns = afuns,+ ) |
|||
| 222 | -10x | +|||
| 122 | +
- colvars = colvars,+ |
|||
| 223 | -10x | +123 | +14x |
- na_str = na_str,+ list(prop = df_prop, or = df_or) |
| 224 | -10x | +|||
| 124 | +
- .indent_mods = .indent_mods,+ } |
|||
| 225 | +125 |
- ...+ |
||
| 226 | +126 |
- )+ #' @describeIn response_subgroups Formatted analysis function which is used as `afun` in `tabulate_rsp_subgroups()`. |
||
| 227 | +127 |
- }+ #' |
| 1 | +128 |
- #' Additional assertions to use with `checkmate`+ #' @return |
||
| 2 | +129 | ++ |
+ #' * `a_response_subgroups()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+ |
| 130 |
#' |
|||
| 3 | +131 |
- #' Additional assertion functions which can be used together with the `checkmate` package.+ #' @keywords internal |
||
| 4 | +132 |
- #'+ a_response_subgroups <- function(.formats = list( |
||
| 5 | +133 |
- #' @inheritParams checkmate::assert_factor+ n = "xx", # nolint start |
||
| 6 | +134 |
- #' @param x (`any`)\cr object to test.+ n_rsp = "xx", |
||
| 7 | +135 |
- #' @param df (`data.frame`)\cr data set to test.+ prop = "xx.x%", |
||
| 8 | +136 |
- #' @param variables (named `list` of `character`)\cr list of variables to test.+ n_tot = "xx", |
||
| 9 | +137 |
- #' @param include_boundaries (`flag`)\cr whether to include boundaries when testing+ or = list(format_extreme_values(2L)), |
||
| 10 | +138 |
- #' for proportions.+ ci = list(format_extreme_values_ci(2L)), |
||
| 11 | +139 |
- #' @param na_level (`string`)\cr the string you have been using to represent NA or+ pval = "x.xxxx | (<0.0001)", |
||
| 12 | +140 |
- #' missing data. For `NA` values please consider using directly [is.na()] or+ riskdiff = "xx.x (xx.x - xx.x)" # nolint end |
||
| 13 | +141 |
- #' similar approaches.+ ), |
||
| 14 | +142 |
- #'+ na_str = default_na_str()) {
|
||
| 15 | -+ | |||
| 143 | +22x |
- #' @return Nothing if assertion passes, otherwise prints the error message.+ checkmate::assert_list(.formats) |
||
| 16 | -+ | |||
| 144 | +22x |
- #'+ checkmate::assert_subset( |
||
| 17 | -+ | |||
| 145 | +22x |
- #' @name assertions+ names(.formats), |
||
| 18 | -+ | |||
| 146 | +22x |
- NULL+ c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval", "riskdiff")
|
||
| 19 | +147 |
-
+ ) |
||
| 20 | +148 |
- check_list_of_variables <- function(x) {
+
|
||
| 21 | -+ | |||
| 149 | +22x |
- # drop NULL elements in list+ afun_lst <- Map( |
||
| 22 | -2927x | +150 | +22x |
- x <- Filter(Negate(is.null), x)+ function(stat, fmt, na_str) {
|
| 23 | -+ | |||
| 151 | +157x |
-
+ function(df, labelstr = "", ...) {
|
||
| 24 | -2927x | +152 | +349x |
- res <- checkmate::check_list(x,+ in_rows( |
| 25 | -2927x | +153 | +349x |
- names = "named",+ .list = as.list(df[[stat]]), |
| 26 | -2927x | +154 | +349x |
- min.len = 1,+ .labels = as.character(df$subgroup), |
| 27 | -2927x | +155 | +349x |
- any.missing = FALSE,+ .formats = fmt, |
| 28 | -2927x | +156 | +349x |
- types = "character"+ .format_na_strs = na_str |
| 29 | +157 |
- )+ ) |
||
| 30 | +158 |
- # no empty strings allowed+ }+ |
+ ||
| 159 | ++ |
+ }, |
||
| 31 | -2927x | +160 | +22x |
- if (isTRUE(res)) {
+ stat = names(.formats), |
| 32 | -2922x | +161 | +22x |
- res <- checkmate::check_character(unlist(x), min.chars = 1)+ fmt = .formats,+ |
+
| 162 | +22x | +
+ na_str = na_str |
||
| 33 | +163 |
- }+ )+ |
+ ||
| 164 | ++ | + | ||
| 34 | -2927x | +165 | +22x |
- return(res)+ afun_lst |
| 35 | +166 |
} |
||
| 36 | +167 |
- #' @describeIn assertions Checks whether `x` is a valid list of variable names.+ |
||
| 37 | +168 |
- #' `NULL` elements of the list `x` are dropped with `Filter(Negate(is.null), x)`.+ #' @describeIn response_subgroups Table-creating function which creates a table |
||
| 38 | +169 | ++ |
+ #' summarizing binary response by subgroup. This function is a wrapper for [rtables::analyze_colvars()]+ |
+ |
| 170 | ++ |
+ #' and [rtables::summarize_row_groups()].+ |
+ ||
| 171 |
#' |
|||
| 39 | +172 |
- #' @keywords internal+ #' @param df (`list`)\cr a list of data frames containing all analysis variables. List should be |
||
| 40 | +173 |
- assert_list_of_variables <- checkmate::makeAssertionFunction(check_list_of_variables)+ #' created using [extract_rsp_subgroups()]. |
||
| 41 | +174 |
-
+ #' @param vars (`character`)\cr the names of statistics to be reported among: |
||
| 42 | +175 |
- check_df_with_variables <- function(df, variables, na_level = NULL) {
+ #' * `n`: Total number of observations per group. |
||
| 43 | -2610x | +|||
| 176 | +
- checkmate::assert_data_frame(df)+ #' * `n_rsp`: Number of responders per group. |
|||
| 44 | -2608x | +|||
| 177 | +
- assert_list_of_variables(variables)+ #' * `prop`: Proportion of responders. |
|||
| 45 | +178 |
-
+ #' * `n_tot`: Total number of observations. |
||
| 46 | +179 |
- # flag for equal variables and column names+ #' * `or`: Odds ratio. |
||
| 47 | -2606x | +|||
| 180 | +
- err_flag <- all(unlist(variables) %in% colnames(df))+ #' * `ci` : Confidence interval of odds ratio. |
|||
| 48 | -2606x | +|||
| 181 | +
- checkmate::assert_flag(err_flag)+ #' * `pval`: p-value of the effect. |
|||
| 49 | +182 |
-
+ #' Note, the statistics `n_tot`, `or`, and `ci` are required. |
||
| 50 | -2606x | +|||
| 183 | +
- if (isFALSE(err_flag)) {
+ #' @param riskdiff (`list`)\cr if a risk (proportion) difference column should be added, a list of settings to apply |
|||
| 51 | -5x | +|||
| 184 | +
- vars <- setdiff(unlist(variables), colnames(df))+ #' within the column. See [control_riskdiff()] for details. If `NULL`, no risk difference column will be added. If |
|||
| 52 | -5x | +|||
| 185 | +
- return(paste(+ #' `riskdiff$arm_x` and `riskdiff$arm_y` are `NULL`, the first level of `df$prop$arm` will be used as `arm_x` and |
|||
| 53 | -5x | +|||
| 186 | +
- deparse(substitute(df)),+ #' the second level as `arm_y`. |
|||
| 54 | -5x | +|||
| 187 | +
- "does not contain all specified variables as column names. Missing from data frame:",+ #' |
|||
| 55 | -5x | +|||
| 188 | +
- paste(vars, collapse = ", ")+ #' @return An `rtables` table summarizing binary response by subgroup. |
|||
| 56 | +189 |
- ))+ #' |
||
| 57 | +190 |
- }+ #' @examples |
||
| 58 | +191 |
- # checking if na_level is present and in which column+ #' # Table with default columns |
||
| 59 | -2601x | +|||
| 192 | +
- if (!is.null(na_level)) {
+ #' basic_table() %>% |
|||
| 60 | -9x | +|||
| 193 | +
- checkmate::assert_string(na_level)+ #' tabulate_rsp_subgroups(df) |
|||
| 61 | -9x | +|||
| 194 | +
- res <- unlist(lapply(as.list(df)[unlist(variables)], function(x) any(x == na_level)))+ #' |
|||
| 62 | -9x | +|||
| 195 | +
- if (any(res)) {
+ #' # Table with selected columns |
|||
| 63 | -1x | +|||
| 196 | +
- return(paste0(+ #' basic_table() %>% |
|||
| 64 | -1x | +|||
| 197 | +
- deparse(substitute(df)), " contains explicit na_level (", na_level,
+ #' tabulate_rsp_subgroups( |
|||
| 65 | -1x | +|||
| 198 | +
- ") in the following columns: ", paste0(unlist(variables)[res],+ #' df = df, |
|||
| 66 | -1x | +|||
| 199 | +
- collapse = ", "+ #' vars = c("n_tot", "n", "n_rsp", "prop", "or", "ci")
|
|||
| 67 | +200 |
- )+ #' ) |
||
| 68 | +201 |
- ))+ #' |
||
| 69 | +202 |
- }+ #' # Table with risk difference column added |
||
| 70 | +203 |
- }+ #' basic_table() %>% |
||
| 71 | -2600x | +|||
| 204 | +
- return(TRUE)+ #' tabulate_rsp_subgroups( |
|||
| 72 | +205 |
- }+ #' df, |
||
| 73 | +206 |
- #' @describeIn assertions Check whether `df` is a data frame with the analysis `variables`.+ #' riskdiff = control_riskdiff( |
||
| 74 | +207 |
- #' Please notice how this produces an error when not all variables are present in the+ #' arm_x = levels(df$prop$arm)[1], |
||
| 75 | +208 |
- #' data.frame while the opposite is not required.+ #' arm_y = levels(df$prop$arm)[2] |
||
| 76 | +209 | ++ |
+ #' )+ |
+ |
| 210 | ++ |
+ #' )+ |
+ ||
| 211 |
#' |
|||
| 77 | +212 |
- #' @keywords internal+ #' @export |
||
| 78 | +213 |
- assert_df_with_variables <- checkmate::makeAssertionFunction(check_df_with_variables)+ #' @order 2 |
||
| 79 | +214 |
-
+ tabulate_rsp_subgroups <- function(lyt, |
||
| 80 | +215 |
- check_valid_factor <- function(x,+ df, |
||
| 81 | +216 |
- min.levels = 1, # nolint+ vars = c("n_tot", "n", "prop", "or", "ci"),
|
||
| 82 | +217 |
- max.levels = NULL, # nolint+ groups_lists = list(), |
||
| 83 | +218 |
- null.ok = TRUE, # nolint+ label_all = "All Patients", |
||
| 84 | +219 |
- any.missing = TRUE, # nolint+ riskdiff = NULL, |
||
| 85 | +220 |
- n.levels = NULL, # nolint+ na_str = default_na_str(), |
||
| 86 | +221 |
- len = NULL) {
+ .formats = c( |
||
| 87 | +222 |
- # checks on levels insertion+ n = "xx", n_rsp = "xx", prop = "xx.x%", n_tot = "xx", |
||
| 88 | -1081x | +|||
| 223 | +
- checkmate::assert_int(min.levels, lower = 1)+ or = list(format_extreme_values(2L)), ci = list(format_extreme_values_ci(2L)), |
|||
| 89 | +224 |
-
+ pval = "x.xxxx | (<0.0001)" |
||
| 90 | +225 |
- # main factor check+ )) {
|
||
| 91 | -1081x | +226 | +13x |
- res <- checkmate::check_factor(x,+ checkmate::assert_list(riskdiff, null.ok = TRUE) |
| 92 | -1081x | +227 | +13x |
- min.levels = min.levels,+ checkmate::assert_true(all(c("n_tot", "or", "ci") %in% vars))
|
| 93 | -1081x | +228 | +13x |
- null.ok = null.ok,+ if ("pval" %in% vars && !"pval" %in% names(df$or)) {
|
| 94 | -1081x | +229 | +1x |
- max.levels = max.levels,+ warning( |
| 95 | -1081x | +230 | +1x |
- any.missing = any.missing,+ 'The "pval" statistic has been selected but is not present in "df" so it will not be included in the output ', |
| 96 | -1081x | +231 | +1x |
- n.levels = n.levels+ 'table. To include the "pval" statistic, please specify a p-value test when generating "df" via ',+ |
+
| 232 | +1x | +
+ 'the "method" argument to `extract_rsp_subgroups()`. If method = "cmh", strata must also be specified via the ',+ |
+ ||
| 233 | +1x | +
+ '"variables" argument to `extract_rsp_subgroups()`.' |
||
| 97 | +234 |
- )+ ) |
||
| 98 | +235 |
-
+ } |
||
| 99 | +236 |
- # no empty strings allowed+ |
||
| 100 | -1081x | +|||
| 237 | +
- if (isTRUE(res)) {
+ # Create "ci" column from "lcl" and "ucl" |
|||
| 101 | -1067x | +238 | +13x |
- res <- checkmate::check_character(levels(x), min.chars = 1)+ df$or$ci <- combine_vectors(df$or$lcl, df$or$ucl) |
| 102 | +239 |
- }+ |
||
| 103 | +240 |
-
+ # Fill in missing formats with defaults |
||
| 104 | -1081x | +241 | +13x |
- return(res)+ default_fmts <- eval(formals(tabulate_rsp_subgroups)$.formats) |
| 105 | -+ | |||
| 242 | +13x |
- }+ .formats <- c(.formats, default_fmts[vars[!vars %in% names(.formats)]]) |
||
| 106 | +243 |
- #' @describeIn assertions Check whether `x` is a valid factor (i.e. has levels and no empty+ |
||
| 107 | +244 |
- #' string levels). Note that `NULL` and `NA` elements are allowed.+ # Extract additional parameters from df |
||
| 108 | -+ | |||
| 245 | +13x |
- #'+ conf_level <- df$or$conf_level[1] |
||
| 109 | -+ | |||
| 246 | +13x |
- #' @keywords internal+ method <- if ("pval_label" %in% names(df$or)) df$or$pval_label[1] else NULL
|
||
| 110 | -+ | |||
| 247 | +13x |
- assert_valid_factor <- checkmate::makeAssertionFunction(check_valid_factor)+ colvars <- d_rsp_subgroups_colvars(vars, conf_level = conf_level, method = method)+ |
+ ||
| 248 | +13x | +
+ prop_vars <- intersect(colvars$vars, c("n", "prop", "n_rsp"))
+ |
+ ||
| 249 | +13x | +
+ or_vars <- intersect(names(colvars$labels), c("n_tot", "or", "ci", "pval"))
+ |
+ ||
| 250 | +13x | +
+ colvars_prop <- list(vars = prop_vars, labels = colvars$labels[prop_vars])+ |
+ ||
| 251 | +13x | +
+ colvars_or <- list(vars = or_vars, labels = colvars$labels[or_vars]) |
||
| 111 | +252 | |||
| 112 | -+ | |||
| 253 | +13x |
- check_df_with_factors <- function(df,+ extra_args <- list(groups_lists = groups_lists, conf_level = conf_level, method = method, label_all = label_all) |
||
| 113 | +254 |
- variables,+ |
||
| 114 | +255 |
- min.levels = 1, # nolint+ # Get analysis function for each statistic |
||
| 115 | -+ | |||
| 256 | +13x |
- max.levels = NULL, # nolint+ afun_lst <- a_response_subgroups(.formats = c(.formats, riskdiff = riskdiff$format), na_str = na_str) |
||
| 116 | +257 |
- any.missing = TRUE, # nolint+ |
||
| 117 | +258 |
- na_level = NULL) {
+ # Add risk difference column |
||
| 118 | -254x | +259 | +13x |
- res <- check_df_with_variables(df, variables, na_level)+ if (!is.null(riskdiff)) {
|
| 119 | -+ | |||
| 260 | +! |
- # checking if all the columns specified by variables are valid factors+ 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] |
||
| 120 | -253x | +262 | +1x |
- if (isTRUE(res)) {
+ colvars_or$vars <- c(colvars_or$vars, "riskdiff")+ |
+
| 263 | +1x | +
+ colvars_or$labels <- c(colvars_or$labels, riskdiff = riskdiff$col_label)+ |
+ ||
| 264 | +1x | +
+ arm_cols <- paste(rep(c("n_rsp", "n_rsp", "n", "n")), c(riskdiff$arm_x, riskdiff$arm_y), sep = "_")
|
||
| 121 | +265 |
- # searching the data.frame with selected columns (variables) as a list+ |
||
| 122 | -251x | +266 | +1x |
- res <- lapply(+ df_prop_diff <- df$prop %>% |
| 123 | -251x | +267 | +1x |
- X = as.list(df)[unlist(variables)],+ dplyr::select(-"prop") %>% |
| 124 | -251x | +268 | +1x |
- FUN = check_valid_factor,+ tidyr::pivot_wider( |
| 125 | -251x | +269 | +1x |
- min.levels = min.levels,+ id_cols = c("subgroup", "var", "var_label", "row_type"),
|
| 126 | -251x | +270 | +1x |
- max.levels = max.levels,+ names_from = "arm", |
| 127 | -251x | +271 | +1x |
- any.missing = any.missing+ values_from = c("n", "n_rsp")
|
| 128 | +272 |
- )+ ) %>% |
||
| 129 | -251x | +273 | +1x |
- res_lo <- unlist(vapply(res, Negate(isTRUE), logical(1)))+ dplyr::rowwise() %>% |
| 130 | -251x | +274 | +1x |
- if (any(res_lo)) {
+ dplyr::mutate( |
| 131 | -6x | +275 | +1x |
- return(paste0(+ riskdiff = stat_propdiff_ci( |
| 132 | -6x | +276 | +1x |
- deparse(substitute(df)), " does not contain only factor variables among:",+ x = as.list(.data[[arm_cols[1]]]), |
| 133 | -6x | +277 | +1x |
- "\n* Column `", paste0(unlist(variables)[res_lo],+ y = as.list(.data[[arm_cols[2]]]), |
| 134 | -6x | +278 | +1x |
- "` of the data.frame -> ", res[res_lo],+ N_x = .data[[arm_cols[3]]], |
| 135 | -6x | +279 | +1x |
- collapse = "\n* "+ N_y = .data[[arm_cols[4]]] |
| 136 | +280 |
) |
||
| 137 | +281 |
- ))+ ) %>%+ |
+ ||
| 282 | +1x | +
+ dplyr::select(-dplyr::all_of(arm_cols)) |
||
| 138 | +283 |
- } else {
+
|
||
| 139 | -245x | +284 | +1x |
- res <- TRUE+ df$or <- df$or %>% |
| 140 | -+ | |||
| 285 | +1x |
- }+ dplyr::left_join( |
||
| 141 | -+ | |||
| 286 | +1x |
- }+ df_prop_diff, |
||
| 142 | -247x | +287 | +1x |
- return(res)+ by = c("subgroup", "var", "var_label", "row_type")
|
| 143 | +288 |
- }+ ) |
||
| 144 | +289 |
-
+ } |
||
| 145 | +290 |
- #' @describeIn assertions Check whether `df` is a data frame where the analysis `variables`+ |
||
| 146 | +291 |
- #' are all factors. Note that the creation of `NA` by direct call of `factor()` will+ # Add columns from table_prop (optional) |
||
| 147 | -+ | |||
| 292 | +13x |
- #' trim `NA` levels out of the vector list itself.+ if (length(colvars_prop$vars) > 0) {
|
||
| 148 | -+ | |||
| 293 | +12x |
- #'+ lyt_prop <- split_cols_by(lyt = lyt, var = "arm") |
||
| 149 | -+ | |||
| 294 | +12x |
- #' @keywords internal+ lyt_prop <- split_cols_by_multivar( |
||
| 150 | -+ | |||
| 295 | +12x |
- assert_df_with_factors <- checkmate::makeAssertionFunction(check_df_with_factors)+ lyt = lyt_prop, |
||
| 151 | -+ | |||
| 296 | +12x |
-
+ vars = colvars_prop$vars, |
||
| 152 | -+ | |||
| 297 | +12x |
- #' @describeIn assertions Check whether `x` is a proportion: number between 0 and 1.+ varlabels = colvars_prop$labels |
||
| 153 | +298 |
- #'+ ) |
||
| 154 | +299 |
- #' @keywords internal+ |
||
| 155 | +300 |
- assert_proportion_value <- function(x, include_boundaries = FALSE) {
+ # Add "All Patients" row |
||
| 156 | -13912x | +301 | +12x |
- checkmate::assert_number(x, lower = 0, upper = 1)+ lyt_prop <- split_rows_by( |
| 157 | -13900x | +302 | +12x |
- checkmate::assert_flag(include_boundaries)+ lyt = lyt_prop, |
| 158 | -13900x | +303 | +12x |
- if (isFALSE(include_boundaries)) {
+ var = "row_type", |
| 159 | -8381x | +304 | +12x |
- checkmate::assert_true(x > 0)+ split_fun = keep_split_levels("content"),
|
| 160 | -8379x | -
- checkmate::assert_true(x < 1)- |
- ||
| 161 | -+ | 305 | +12x |
- }+ nested = FALSE, |
| 162 | -+ | |||
| 306 | +12x |
- }+ child_labels = "hidden" |
| 1 | +307 |
- #' Get default statistical methods and their associated formats, labels, and indent modifiers+ ) |
||
| 2 | -+ | |||
| 308 | +12x |
- #'+ lyt_prop <- analyze_colvars( |
||
| 3 | -+ | |||
| 309 | +12x |
- #' @description `r lifecycle::badge("stable")`
+ lyt = lyt_prop, |
||
| 4 | -+ | |||
| 310 | +12x |
- #'+ afun = afun_lst[names(colvars_prop$labels)], |
||
| 5 | -+ | |||
| 311 | +12x |
- #' Utility functions to get valid statistic methods for different method groups+ na_str = na_str, |
||
| 6 | -+ | |||
| 312 | +12x |
- #' (`.stats`) and their associated formats (`.formats`), labels (`.labels`), and indent modifiers+ extra_args = extra_args |
||
| 7 | +313 |
- #' (`.indent_mods`). This utility is used across `tern`, but some of its working principles can be+ ) |
||
| 8 | +314 |
- #' seen in [analyze_vars()]. See notes to understand why this is experimental.+ |
||
| 9 | +315 |
- #'+ # Add analysis rows |
||
| 10 | -+ | |||
| 316 | +12x |
- #' @param stats (`character`)\cr statistical methods to get defaults for.+ if ("analysis" %in% df$prop$row_type) {
|
||
| 11 | -+ | |||
| 317 | +11x |
- #'+ lyt_prop <- split_rows_by( |
||
| 12 | -+ | |||
| 318 | +11x |
- #' @details+ lyt = lyt_prop, |
||
| 13 | -+ | |||
| 319 | +11x |
- #' Current choices for `type` are `counts` and `numeric` for [analyze_vars()] and affect `get_stats()`.+ var = "row_type", |
||
| 14 | -+ | |||
| 320 | +11x |
- #'+ split_fun = keep_split_levels("analysis"),
|
||
| 15 | -+ | |||
| 321 | +11x |
- #' @note+ nested = FALSE, |
||
| 16 | -+ | |||
| 322 | +11x |
- #' These defaults are experimental because we use the names of functions to retrieve the default+ child_labels = "hidden" |
||
| 17 | +323 |
- #' statistics. This should be generalized in groups of methods according to more reasonable groupings.+ ) |
||
| 18 | -+ | |||
| 324 | +11x |
- #'+ lyt_prop <- split_rows_by(lyt = lyt_prop, var = "var_label", nested = TRUE) |
||
| 19 | -+ | |||
| 325 | +11x |
- #' @name default_stats_formats_labels+ lyt_prop <- analyze_colvars( |
||
| 20 | -+ | |||
| 326 | +11x |
- NULL+ lyt = lyt_prop, |
||
| 21 | -+ | |||
| 327 | +11x |
-
+ afun = afun_lst[names(colvars_prop$labels)], |
||
| 22 | -+ | |||
| 328 | +11x |
- #' @describeIn default_stats_formats_labels Get statistics available for a given method+ na_str = na_str, |
||
| 23 | -+ | |||
| 329 | +11x |
- #' group (analyze function). To check available defaults see `tern::tern_default_stats` list.+ inclNAs = TRUE, |
||
| 24 | -+ | |||
| 330 | +11x |
- #'+ extra_args = extra_args |
||
| 25 | +331 |
- #' @param method_groups (`character`)\cr indicates the statistical method group (`tern` analyze function)+ ) |
||
| 26 | +332 |
- #' to retrieve default statistics for. A character vector can be used to specify more than one statistical+ } |
||
| 27 | +333 |
- #' method group.+ |
||
| 28 | -+ | |||
| 334 | +12x |
- #' @param stats_in (`character`)\cr statistics to retrieve for the selected method group.+ table_prop <- build_table(lyt_prop, df = df$prop) |
||
| 29 | +335 |
- #' @param add_pval (`flag`)\cr should `"pval"` (or `"pval_counts"` if `method_groups` contains+ } else {
|
||
| 30 | -+ | |||
| 336 | +1x |
- #' `"analyze_vars_counts"`) be added to the statistical methods?+ table_prop <- NULL |
||
| 31 | +337 |
- #'+ } |
||
| 32 | +338 |
- #' @return+ |
||
| 33 | +339 |
- #' * `get_stats()` returns a `character` vector of statistical methods.+ # Add columns from table_or ("n_tot", "or", and "ci" required)
|
||
| 34 | -+ | |||
| 340 | +13x |
- #'+ lyt_or <- split_cols_by(lyt = lyt, var = "arm") |
||
| 35 | -+ | |||
| 341 | +13x |
- #' @examples+ lyt_or <- split_cols_by_multivar( |
||
| 36 | -+ | |||
| 342 | +13x |
- #' # analyze_vars is numeric+ lyt = lyt_or, |
||
| 37 | -+ | |||
| 343 | +13x |
- #' num_stats <- get_stats("analyze_vars_numeric") # also the default
+ vars = colvars_or$vars, |
||
| 38 | -+ | |||
| 344 | +13x |
- #'+ varlabels = colvars_or$labels |
||
| 39 | +345 |
- #' # Other type+ ) |
||
| 40 | +346 |
- #' cnt_stats <- get_stats("analyze_vars_counts")
+
|
||
| 41 | +347 |
- #'+ # Add "All Patients" row |
||
| 42 | -+ | |||
| 348 | +13x |
- #' # Weirdly taking the pval from count_occurrences+ lyt_or <- split_rows_by( |
||
| 43 | -+ | |||
| 349 | +13x |
- #' only_pval <- get_stats("count_occurrences", add_pval = TRUE, stats_in = "pval")
+ lyt = lyt_or, |
||
| 44 | -+ | |||
| 350 | +13x |
- #'+ var = "row_type", |
||
| 45 | -+ | |||
| 351 | +13x |
- #' # All count_occurrences+ split_fun = keep_split_levels("content"),
|
||
| 46 | -+ | |||
| 352 | +13x |
- #' all_cnt_occ <- get_stats("count_occurrences")
+ nested = FALSE, |
||
| 47 | -+ | |||
| 353 | +13x |
- #'+ child_labels = "hidden" |
||
| 48 | +354 |
- #' # Multiple+ ) |
||
| 49 | -+ | |||
| 355 | +13x |
- #' get_stats(c("count_occurrences", "analyze_vars_counts"))
+ lyt_or <- analyze_colvars( |
||
| 50 | -+ | |||
| 356 | +13x |
- #'+ lyt = lyt_or, |
||
| 51 | -+ | |||
| 357 | +13x |
- #' @export+ afun = afun_lst[names(colvars_or$labels)], |
||
| 52 | -+ | |||
| 358 | +13x |
- get_stats <- function(method_groups = "analyze_vars_numeric", stats_in = NULL, add_pval = FALSE) {
+ na_str = na_str, |
||
| 53 | -505x | +359 | +13x |
- checkmate::assert_character(method_groups)+ extra_args = extra_args |
| 54 | -505x | +|||
| 360 | +
- checkmate::assert_character(stats_in, null.ok = TRUE)+ ) %>% |
|||
| 55 | -505x | +361 | +13x |
- checkmate::assert_flag(add_pval)+ append_topleft("Baseline Risk Factors")
|
| 56 | +362 | |||
| 57 | +363 |
- # Default is still numeric+ # Add analysis rows |
||
| 58 | -505x | +364 | +13x |
- if (any(method_groups == "analyze_vars")) {
+ if ("analysis" %in% df$or$row_type) {
|
| 59 | -3x | +365 | +12x |
- method_groups[method_groups == "analyze_vars"] <- "analyze_vars_numeric"+ lyt_or <- split_rows_by( |
| 60 | -+ | |||
| 366 | +12x |
- }+ lyt = lyt_or, |
||
| 61 | -+ | |||
| 367 | +12x |
-
+ var = "row_type", |
||
| 62 | -505x | +368 | +12x |
- type_tmp <- ifelse(any(grepl("counts", method_groups)), "counts", "numeric") # for pval checks
+ split_fun = keep_split_levels("analysis"),
|
| 63 | -+ | |||
| 369 | +12x |
-
+ nested = FALSE,+ |
+ ||
| 370 | +12x | +
+ child_labels = "hidden" |
||
| 64 | +371 |
- # Defaults for loop+ ) |
||
| 65 | -505x | +372 | +12x |
- out <- NULL+ lyt_or <- split_rows_by(lyt = lyt_or, var = "var_label", nested = TRUE) |
| 66 | -+ | |||
| 373 | +12x |
-
+ lyt_or <- analyze_colvars( |
||
| 67 | -+ | |||
| 374 | +12x |
- # Loop for multiple method groups+ lyt = lyt_or, |
||
| 68 | -505x | +375 | +12x |
- for (mgi in method_groups) {
+ afun = afun_lst[names(colvars_or$labels)], |
| 69 | -532x | +376 | +12x |
- out_tmp <- if (mgi %in% names(tern_default_stats)) {
+ na_str = na_str, |
| 70 | -531x | +377 | +12x |
- tern_default_stats[[mgi]]+ inclNAs = TRUE,+ |
+
| 378 | +12x | +
+ extra_args = extra_args |
||
| 71 | +379 |
- } else {
+ ) |
||
| 72 | -1x | +|||
| 380 | +
- stop("The selected method group (", mgi, ") has no default statistical method.")
+ } |
|||
| 73 | +381 |
- }+ |
||
| 74 | -531x | +382 | +13x |
- out <- unique(c(out, out_tmp))+ table_or <- build_table(lyt_or, df = df$or) |
| 75 | +383 |
- }+ |
||
| 76 | +384 |
-
+ # Join tables, add forest plot attributes |
||
| 77 | -+ | |||
| 385 | +13x |
- # If you added pval to the stats_in you certainly want it+ n_tot_id <- match("n_tot", colvars_or$vars)
|
||
| 78 | -504x | +386 | +13x |
- if (!is.null(stats_in) && any(grepl("^pval", stats_in))) {
+ if (is.null(table_prop)) {
|
| 79 | -22x | +387 | +1x |
- stats_in_pval_value <- stats_in[grepl("^pval", stats_in)]
+ result <- table_or |
| 80 | -+ | |||
| 388 | +1x |
-
+ or_id <- match("or", colvars_or$vars)
+ |
+ ||
| 389 | +1x | +
+ ci_id <- match("ci", colvars_or$vars)
|
||
| 81 | +390 |
- # Must be only one value between choices+ } else {
|
||
| 82 | -22x | +391 | +12x |
- checkmate::assert_choice(stats_in_pval_value, c("pval", "pval_counts"))
+ result <- cbind_rtables(table_or[, n_tot_id], table_prop, table_or[, -n_tot_id]) |
| 83 | -+ | |||
| 392 | +12x |
-
+ or_id <- 1L + ncol(table_prop) + match("or", colvars_or$vars[-n_tot_id])
+ |
+ ||
| 393 | +12x | +
+ ci_id <- 1L + ncol(table_prop) + match("ci", colvars_or$vars[-n_tot_id])
+ |
+ ||
| 394 | +12x | +
+ n_tot_id <- 1L |
||
| 84 | +395 |
- # Mismatch with counts and numeric+ } |
||
| 85 | -21x | +396 | +13x |
- if (any(grepl("counts", method_groups)) && stats_in_pval_value != "pval_counts" ||
+ structure( |
| 86 | -21x | +397 | +13x |
- any(grepl("numeric", method_groups)) && stats_in_pval_value != "pval") { # nolint
+ result, |
| 87 | -2x | +398 | +13x |
- stop(+ forest_header = paste0(levels(df$prop$arm), "\nBetter"), |
| 88 | -2x | +399 | +13x |
- "Inserted p-value (", stats_in_pval_value, ") is not valid for type ",
+ col_x = or_id, |
| 89 | -2x | +400 | +13x |
- type_tmp, ". Use ", paste(ifelse(stats_in_pval_value == "pval", "pval_counts", "pval")),+ col_ci = ci_id, |
| 90 | -2x | +401 | +13x |
- " instead."+ col_symbol_size = n_tot_id |
| 91 | +402 |
- )+ ) |
||
| 92 | +403 |
- }+ } |
||
| 93 | +404 | |||
| 94 | +405 |
- # Lets add it even if present (thanks to unique)- |
- ||
| 95 | -19x | -
- add_pval <- TRUE+ #' Labels for column variables in binary response by subgroup table |
||
| 96 | +406 |
- }+ #' |
||
| 97 | +407 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 98 | +408 |
- # Mainly used in "analyze_vars" but it could be necessary elsewhere- |
- ||
| 99 | -501x | -
- if (isTRUE(add_pval)) {
- |
- ||
| 100 | -29x | -
- if (any(grepl("counts", method_groups))) {
- |
- ||
| 101 | -16x | -
- out <- unique(c(out, "pval_counts"))+ #' |
||
| 102 | +409 |
- } else {
+ #' Internal function to check variables included in [tabulate_rsp_subgroups()] and create column labels. |
||
| 103 | -13x | +|||
| 410 | +
- out <- unique(c(out, "pval"))+ #' |
|||
| 104 | +411 |
- }+ #' @inheritParams argument_convention |
||
| 105 | +412 |
- }+ #' @inheritParams tabulate_rsp_subgroups |
||
| 106 | +413 |
-
+ #' |
||
| 107 | +414 |
- # Filtering for stats_in (character vector)+ #' @return A `list` of variables to tabulate and their labels. |
||
| 108 | -501x | +|||
| 415 | +
- if (!is.null(stats_in)) {
+ #' |
|||
| 109 | -452x | +|||
| 416 | +
- out <- intersect(stats_in, out) # It orders them too+ #' @export |
|||
| 110 | +417 |
- }+ d_rsp_subgroups_colvars <- function(vars, |
||
| 111 | +418 |
-
+ conf_level = NULL, |
||
| 112 | +419 |
- # If intersect did not find matches (and no pval?) -> error+ method = NULL) {
|
||
| 113 | -501x | +420 | +22x |
- if (length(out) == 0) {
+ checkmate::assert_character(vars) |
| 114 | -2x | +421 | +22x |
- stop(+ checkmate::assert_subset(c("n_tot", "or", "ci"), vars)
|
| 115 | -2x | +422 | +22x |
- "The selected method group(s) (", paste0(method_groups, collapse = ", "), ")",
+ checkmate::assert_subset( |
| 116 | -2x | +423 | +22x |
- " do not have the required default statistical methods:\n",+ vars, |
| 117 | -2x | -
- paste0(stats_in, collapse = " ")- |
- ||
| 118 | -+ | 424 | +22x |
- )+ c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
|
| 119 | +425 |
- }+ ) |
||
| 120 | +426 | |||
| 121 | -499x | +427 | +22x |
- out+ varlabels <- c( |
| 122 | -+ | |||
| 428 | +22x |
- }+ n = "n", |
||
| 123 | -+ | |||
| 429 | +22x |
-
+ n_rsp = "Responders", |
||
| 124 | -+ | |||
| 430 | +22x |
- #' @describeIn default_stats_formats_labels Get formats corresponding to a list of statistics.+ prop = "Response (%)", |
||
| 125 | -+ | |||
| 431 | +22x |
- #' To check available defaults see `tern::tern_default_formats` list.+ n_tot = "Total n", |
||
| 126 | -+ | |||
| 432 | +22x |
- #'+ or = "Odds Ratio" |
||
| 127 | +433 |
- #' @param formats_in (named `vector`)\cr inserted formats to replace defaults. It can be a+ ) |
||
| 128 | -+ | |||
| 434 | +22x |
- #' character vector from [formatters::list_valid_format_labels()] or a custom format function.+ colvars <- vars |
||
| 129 | +435 |
- #'+ |
||
| 130 | -+ | |||
| 436 | +22x |
- #' @return+ if ("ci" %in% colvars) {
|
||
| 131 | -+ | |||
| 437 | +22x |
- #' * `get_formats_from_stats()` returns a named vector of formats (if present in either+ checkmate::assert_false(is.null(conf_level)) |
||
| 132 | +438 |
- #' `tern_default_formats` or `formats_in`, otherwise `NULL`). Values can be taken from+ |
||
| 133 | -+ | |||
| 439 | +22x |
- #' [formatters::list_valid_format_labels()] or a custom function (e.g. [formatting_functions]).+ varlabels <- c( |
||
| 134 | -+ | |||
| 440 | +22x |
- #'+ varlabels, |
||
| 135 | -+ | |||
| 441 | +22x |
- #' @note Formats in `tern` and `rtables` can be functions that take in the table cell value and+ ci = paste0(100 * conf_level, "% CI") |
||
| 136 | +442 |
- #' return a string. This is well documented in `vignette("custom_appearance", package = "rtables")`.
+ ) |
||
| 137 | +443 |
- #'+ |
||
| 138 | +444 |
- #' @examples+ # The `lcl`` variable is just a placeholder available in the analysis data, |
||
| 139 | +445 |
- #' # Defaults formats+ # it is not acutally used in the tabulation. |
||
| 140 | +446 |
- #' get_formats_from_stats(num_stats)+ # Variables used in the tabulation are lcl and ucl, see `a_response_subgroups` for details. |
||
| 141 | -+ | |||
| 447 | +22x |
- #' get_formats_from_stats(cnt_stats)+ colvars[colvars == "ci"] <- "lcl" |
||
| 142 | +448 |
- #' get_formats_from_stats(only_pval)+ } |
||
| 143 | +449 |
- #' get_formats_from_stats(all_cnt_occ)+ |
||
| 144 | -+ | |||
| 450 | +22x |
- #'+ if ("pval" %in% colvars) {
|
||
| 145 | -+ | |||
| 451 | +16x |
- #' # Addition of customs+ varlabels <- c( |
||
| 146 | -+ | |||
| 452 | +16x |
- #' get_formats_from_stats(all_cnt_occ, formats_in = c("fraction" = c("xx")))
+ varlabels, |
||
| 147 | -+ | |||
| 453 | +16x |
- #' get_formats_from_stats(all_cnt_occ, formats_in = list("fraction" = c("xx.xx", "xx")))
+ pval = method |
||
| 148 | +454 |
- #'+ ) |
||
| 149 | +455 |
- #' @seealso [formatting_functions]+ } |
||
| 150 | +456 |
- #'+ |
||
| 151 | -+ | |||
| 457 | +22x |
- #' @export+ list( |
||
| 152 | -+ | |||
| 458 | +22x |
- get_formats_from_stats <- function(stats, formats_in = NULL) {
+ vars = colvars, |
||
| 153 | -494x | +459 | +22x |
- checkmate::assert_character(stats, min.len = 1)+ labels = varlabels[vars] |
| 154 | +460 |
- # It may be a list if there is a function in the formats+ ) |
||
| 155 | -494x | +|||
| 461 | +
- if (checkmate::test_list(formats_in, null.ok = TRUE)) {
+ } |
|||
| 156 | -432x | +
| 1 | +
- checkmate::assert_list(formats_in, null.ok = TRUE)+ #' Count number of patients |
|||
| 157 | +2 |
- # Or it may be a vector of characters+ #' |
||
| 158 | +3 |
- } else {
+ #' @description `r lifecycle::badge("stable")`
|
||
| 159 | -62x | +|||
| 4 | +
- checkmate::assert_character(formats_in, null.ok = TRUE)+ #' |
|||
| 160 | +5 |
- }+ #' The analyze function [analyze_num_patients()] creates a layout element to count total numbers of unique or |
||
| 161 | +6 |
-
+ #' non-unique patients. The primary analysis variable `vars` is used to uniquely identify patients. |
||
| 162 | +7 |
- # Extract global defaults+ #' |
||
| 163 | -494x | +|||
| 8 | +
- which_fmt <- match(stats, names(tern_default_formats))+ #' The `count_by` variable can be used to identify non-unique patients such that the number of patients with a unique |
|||
| 164 | +9 |
-
+ #' combination of values in `vars` and `count_by` will be returned instead as the `nonunique` statistic. The `required` |
||
| 165 | +10 |
- # Select only needed formats from stats+ #' variable can be used to specify a variable required to be non-missing for the record to be included in the counts. |
||
| 166 | -494x | +|||
| 11 | +
- ret <- vector("list", length = length(stats)) # Returning a list is simpler
+ #' |
|||
| 167 | -494x | +|||
| 12 | +
- ret[!is.na(which_fmt)] <- tern_default_formats[which_fmt[!is.na(which_fmt)]]+ #' The summarize function [summarize_num_patients()] performs the same function as [analyze_num_patients()] except it |
|||
| 168 | +13 |
-
+ #' creates content rows, not data rows, to summarize the current table row/column context and operates on the level of |
||
| 169 | -494x | +|||
| 14 | +
- out <- setNames(ret, stats)+ #' the latest row split or the root of the table if no row splits have occurred. |
|||
| 170 | +15 |
-
+ #' |
||
| 171 | +16 |
- # Modify some with custom formats+ #' @inheritParams argument_convention |
||
| 172 | -494x | +|||
| 17 | +
- if (!is.null(formats_in)) {
+ #' @param required (`character` or `NULL`)\cr name of a variable that is required to be non-missing. |
|||
| 173 | +18 |
- # Stats is the main+ #' @param count_by (`character` or `NULL`)\cr name of a variable to be combined with `vars` when counting |
||
| 174 | -64x | +|||
| 19 | +
- common_names <- intersect(names(out), names(formats_in))+ #' `nonunique` records. |
|||
| 175 | -64x | +|||
| 20 | +
- out[common_names] <- formats_in[common_names]+ #' @param unique_count_suffix (`flag`)\cr whether the `"(n)"` suffix should be added to `unique_count` labels. |
|||
| 176 | +21 |
- }+ #' Defaults to `TRUE`. |
||
| 177 | +22 |
-
+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("summarize_num_patients")`
|
||
| 178 | -494x | +|||
| 23 | +
- out+ #' to see available statistics for this function. |
|||
| 179 | +24 |
- }+ #' |
||
| 180 | +25 |
-
+ #' @name summarize_num_patients |
||
| 181 | +26 |
- #' @describeIn default_stats_formats_labels Get labels corresponding to a list of statistics.+ #' @order 1 |
||
| 182 | +27 |
- #' To check for available defaults see `tern::tern_default_labels` list. If not available there,+ NULL |
||
| 183 | +28 |
- #' the statistics name will be used as label.+ |
||
| 184 | +29 |
- #'+ #' @describeIn summarize_num_patients Statistics function which counts the number of |
||
| 185 | +30 |
- #' @param labels_in (named `character`)\cr inserted labels to replace defaults.+ #' unique patients, the corresponding percentage taken with respect to the |
||
| 186 | +31 |
- #' @param row_nms (`character`)\cr row names. Levels of a `factor` or `character` variable, each+ #' total number of patients, and the number of non-unique patients. |
||
| 187 | +32 |
- #' of which the statistics in `.stats` will be calculated for. If this parameter is set, these+ #' |
||
| 188 | +33 |
- #' variable levels will be used as the defaults, and the names of the given custom values should+ #' @param x (`character` or `factor`)\cr vector of patient IDs. |
||
| 189 | +34 |
- #' correspond to levels (or have format `statistic.level`) instead of statistics. Can also be+ #' |
||
| 190 | +35 |
- #' variable names if rows correspond to different variables instead of levels. Defaults to `NULL`.+ #' @return |
||
| 191 | +36 |
- #'+ #' * `s_num_patients()` returns a named `list` of 3 statistics: |
||
| 192 | +37 |
- #' @return+ #' * `unique`: Vector of counts and percentages. |
||
| 193 | +38 |
- #' * `get_labels_from_stats()` returns a named `character` vector of labels (if present in either+ #' * `nonunique`: Vector of counts. |
||
| 194 | +39 |
- #' `tern_default_labels` or `labels_in`, otherwise `NULL`).+ #' * `unique_count`: Counts. |
||
| 195 | +40 |
#' |
||
| 196 | +41 |
#' @examples |
||
| 197 | +42 |
- #' # Defaults labels+ #' # Use the statistics function to count number of unique and nonunique patients. |
||
| 198 | +43 |
- #' get_labels_from_stats(num_stats)+ #' s_num_patients(x = as.character(c(1, 1, 1, 2, 4, NA)), labelstr = "", .N_col = 6L) |
||
| 199 | +44 |
- #' get_labels_from_stats(cnt_stats)+ #' s_num_patients( |
||
| 200 | +45 |
- #' get_labels_from_stats(only_pval)+ #' x = as.character(c(1, 1, 1, 2, 4, NA)), |
||
| 201 | +46 |
- #' get_labels_from_stats(all_cnt_occ)+ #' labelstr = "", |
||
| 202 | +47 |
- #'+ #' .N_col = 6L, |
||
| 203 | +48 |
- #' # Addition of customs+ #' count_by = c(1, 1, 2, 1, 1, 1) |
||
| 204 | +49 |
- #' get_labels_from_stats(all_cnt_occ, labels_in = c("fraction" = "Fraction"))
+ #' ) |
||
| 205 | +50 |
- #' get_labels_from_stats(all_cnt_occ, labels_in = list("fraction" = c("Some more fractions")))
+ #' |
||
| 206 | +51 |
- #'+ #' @export |
||
| 207 | +52 |
- #' @export+ s_num_patients <- function(x, labelstr, .N_col, count_by = NULL, unique_count_suffix = TRUE) { # nolint
|
||
| 208 | +53 |
- get_labels_from_stats <- function(stats, labels_in = NULL, row_nms = NULL) {
+
|
||
| 209 | -483x | +54 | +146x |
- checkmate::assert_character(stats, min.len = 1)+ checkmate::assert_string(labelstr) |
| 210 | -483x | -
- checkmate::assert_character(row_nms, null.ok = TRUE)- |
- ||
| 211 | -+ | 55 | +146x |
- # It may be a list+ checkmate::assert_count(.N_col) |
| 212 | -483x | +56 | +146x |
- if (checkmate::test_list(labels_in, null.ok = TRUE)) {
+ checkmate::assert_multi_class(x, classes = c("factor", "character"))
|
| 213 | -392x | +57 | +146x |
- checkmate::assert_list(labels_in, null.ok = TRUE)+ checkmate::assert_flag(unique_count_suffix) |
| 214 | +58 |
- # Or it may be a vector of characters+ |
||
| 215 | -+ | |||
| 59 | +146x |
- } else {
+ count1 <- n_available(unique(x)) |
||
| 216 | -91x | +60 | +146x |
- checkmate::assert_character(labels_in, null.ok = TRUE)+ count2 <- n_available(x) |
| 217 | +61 |
- }+ |
||
| 218 | -+ | |||
| 62 | +146x |
-
+ if (!is.null(count_by)) {
|
||
| 219 | -483x | +63 | +16x |
- if (!is.null(row_nms)) {
+ checkmate::assert_vector(count_by, len = length(x)) |
| 220 | -83x | +64 | +16x |
- ret <- rep(row_nms, length(stats))+ count2 <- n_available(unique(interaction(x, count_by))) |
| 221 | -83x | +|||
| 65 | +
- out <- setNames(ret, paste(rep(stats, each = length(row_nms)), ret, sep = "."))+ } |
|||
| 222 | +66 | |||
| 223 | -83x | +67 | +146x |
- if (!is.null(labels_in)) {
+ out <- list( |
| 224 | -2x | +68 | +146x |
- lvl_lbls <- intersect(names(labels_in), row_nms)+ unique = formatters::with_label(c(count1, ifelse(count1 == 0 && .N_col == 0, 0, count1 / .N_col)), labelstr), |
| 225 | -2x | +69 | +146x |
- for (i in lvl_lbls) out[paste(stats, i, sep = ".")] <- labels_in[[i]]+ nonunique = formatters::with_label(count2, labelstr), |
| 226 | -+ | |||
| 70 | +146x |
- }+ unique_count = formatters::with_label(+ |
+ ||
| 71 | +146x | +
+ count1, ifelse(unique_count_suffix, paste0(labelstr, if (nzchar(labelstr)) " ", "(n)"), labelstr) |
||
| 227 | +72 |
- } else {
+ ) |
||
| 228 | -400x | +|||
| 73 | +
- which_lbl <- match(stats, names(tern_default_labels))+ ) |
|||
| 229 | +74 | |||
| 230 | -400x | +75 | +146x |
- ret <- stats # The default+ out |
| 231 | -400x | +|||
| 76 | +
- ret[!is.na(which_lbl)] <- tern_default_labels[which_lbl[!is.na(which_lbl)]]+ } |
|||
| 232 | +77 | |||
| 233 | -400x | +|||
| 78 | +
- out <- setNames(ret, stats)+ #' @describeIn summarize_num_patients Statistics function which counts the number of unique patients |
|||
| 234 | +79 |
- }+ #' in a column (variable), the corresponding percentage taken with respect to the total number of |
||
| 235 | +80 |
-
+ #' patients, and the number of non-unique patients in the column. |
||
| 236 | +81 |
- # Modify some with custom labels+ #' |
||
| 237 | -483x | +|||
| 82 | +
- if (!is.null(labels_in)) {
+ #' @return |
|||
| 238 | +83 |
- # Stats is the main+ #' * `s_num_patients_content()` returns the same values as `s_num_patients()`. |
||
| 239 | -93x | +|||
| 84 | +
- common_names <- intersect(names(out), names(labels_in))+ #' |
|||
| 240 | -93x | +|||
| 85 | +
- out[common_names] <- labels_in[common_names]+ #' @examples |
|||
| 241 | +86 |
- }+ #' # Count number of unique and non-unique patients. |
||
| 242 | +87 |
-
+ #' |
||
| 243 | -483x | +|||
| 88 | +
- out+ #' df <- data.frame( |
|||
| 244 | +89 |
- }+ #' USUBJID = as.character(c(1, 2, 1, 4, NA)), |
||
| 245 | +90 |
-
+ #' EVENT = as.character(c(10, 15, 10, 17, 8)) |
||
| 246 | +91 |
- #' @describeIn default_stats_formats_labels Format indent modifiers for a given vector/list of statistics.+ #' ) |
||
| 247 | +92 |
- #' It defaults to 0L for all values.+ #' s_num_patients_content(df, .N_col = 5, .var = "USUBJID") |
||
| 248 | +93 |
#' |
||
| 249 | +94 |
- #' @param indents_in (named `vector`)\cr inserted indent modifiers to replace defaults (default is `0L`).+ #' df_by_event <- data.frame( |
||
| 250 | +95 |
- #'+ #' USUBJID = as.character(c(1, 2, 1, 4, NA)), |
||
| 251 | +96 |
- #' @return+ #' EVENT = c(10, 15, 10, 17, 8) |
||
| 252 | +97 |
- #' * `get_indents_from_stats()` returns a single indent modifier value to apply to all rows+ #' ) |
||
| 253 | +98 |
- #' or a named numeric vector of indent modifiers (if present, otherwise `NULL`).+ #' s_num_patients_content(df_by_event, .N_col = 5, .var = "USUBJID", count_by = "EVENT") |
||
| 254 | +99 |
#' |
||
| 255 | +100 |
- #' @examples+ #' @export |
||
| 256 | +101 |
- #' get_indents_from_stats(all_cnt_occ, indents_in = 3L)+ s_num_patients_content <- function(df, |
||
| 257 | +102 |
- #' get_indents_from_stats(all_cnt_occ, indents_in = list(count = 2L, count_fraction = 5L))+ labelstr = "", |
||
| 258 | +103 |
- #' get_indents_from_stats(+ .N_col, # nolint |
||
| 259 | +104 |
- #' all_cnt_occ,+ .var, |
||
| 260 | +105 |
- #' indents_in = list(a = 2L, count.a = 1L, count.b = 5L), row_nms = c("a", "b")
+ required = NULL, |
||
| 261 | +106 |
- #' )+ count_by = NULL, |
||
| 262 | +107 |
- #'+ unique_count_suffix = TRUE) {
|
||
| 263 | -+ | |||
| 108 | +56x |
- #' @export+ checkmate::assert_string(.var) |
||
| 264 | -+ | |||
| 109 | +56x |
- get_indents_from_stats <- function(stats, indents_in = NULL, row_nms = NULL) {
+ checkmate::assert_data_frame(df) |
||
| 265 | -444x | +110 | +56x |
- checkmate::assert_character(stats, min.len = 1)+ if (is.null(count_by)) {
|
| 266 | -444x | +111 | +53x |
- checkmate::assert_character(row_nms, null.ok = TRUE)+ assert_df_with_variables(df, list(id = .var)) |
| 267 | +112 |
- # It may be a list+ } else {
|
||
| 268 | -444x | +113 | +3x |
- if (checkmate::test_list(indents_in, null.ok = TRUE)) {
+ assert_df_with_variables(df, list(id = .var, count_by = count_by))+ |
+
| 114 | ++ |
+ } |
||
| 269 | -402x | +115 | +56x |
- checkmate::assert_list(indents_in, null.ok = TRUE)+ if (!is.null(required)) {
|
| 270 | -+ | |||
| 116 | +! |
- # Or it may be a vector of integers+ checkmate::assert_string(required) |
||
| 271 | -+ | |||
| 117 | +! |
- } else {
+ assert_df_with_variables(df, list(required = required)) |
||
| 272 | -42x | +|||
| 118 | +! |
- checkmate::assert_integerish(indents_in, null.ok = TRUE)+ df <- df[!is.na(df[[required]]), , drop = FALSE] |
||
| 273 | +119 |
} |
||
| 274 | +120 | |||
| 275 | -444x | +121 | +56x |
- if (is.null(names(indents_in)) && length(indents_in) == 1) {
+ x <- df[[.var]] |
| 276 | -9x | +122 | +56x |
- out <- rep(indents_in, length(stats) * if (!is.null(row_nms)) length(row_nms) else 1)+ y <- if (is.null(count_by)) NULL else df[[count_by]]+ |
+
| 123 | ++ | + | ||
| 277 | -9x | +124 | +56x |
- return(out)+ s_num_patients( |
| 278 | -+ | |||
| 125 | +56x |
- }+ x = x, |
||
| 279 | -+ | |||
| 126 | +56x |
-
+ labelstr = labelstr, |
||
| 280 | -435x | +127 | +56x |
- if (!is.null(row_nms)) {
+ .N_col = .N_col, |
| 281 | -77x | +128 | +56x |
- ret <- rep(0L, length(stats) * length(row_nms))+ count_by = y, |
| 282 | -77x | +129 | +56x |
- out <- setNames(ret, paste(rep(stats, each = length(row_nms)), rep(row_nms, length(stats)), sep = "."))+ unique_count_suffix = unique_count_suffix |
| 283 | +130 |
-
+ ) |
||
| 284 | -77x | +|||
| 131 | +
- if (!is.null(indents_in)) {
+ } |
|||
| 285 | -2x | +|||
| 132 | +
- lvl_lbls <- intersect(names(indents_in), row_nms)+ |
|||
| 286 | -2x | +|||
| 133 | +
- for (i in lvl_lbls) out[paste(stats, i, sep = ".")] <- indents_in[[i]]+ c_num_patients <- make_afun( |
|||
| 287 | +134 |
- }+ s_num_patients_content, |
||
| 288 | +135 |
- } else {
+ .stats = c("unique", "nonunique", "unique_count"),
|
||
| 289 | -358x | +|||
| 136 | +
- ret <- rep(0L, length(stats))+ .formats = c(unique = format_count_fraction_fixed_dp, nonunique = "xx", unique_count = "xx") |
|||
| 290 | -358x | +|||
| 137 | +
- out <- setNames(ret, stats)+ ) |
|||
| 291 | +138 |
- }+ |
||
| 292 | +139 |
-
+ #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments |
||
| 293 | +140 |
- # Modify some with custom labels+ #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 294 | -435x | +|||
| 141 | +
- if (!is.null(indents_in)) {
+ #' |
|||
| 295 | +142 |
- # Stats is the main+ #' @return |
||
| 296 | -34x | +|||
| 143 | +
- common_names <- intersect(names(out), names(indents_in))+ #' * `summarize_num_patients()` returns a layout object suitable for passing to further layouting functions, |
|||
| 297 | -34x | +|||
| 144 | +
- out[common_names] <- indents_in[common_names]+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 298 | +145 |
- }+ #' the statistics from `s_num_patients_content()` to the table layout. |
||
| 299 | +146 |
-
+ #' |
||
| 300 | -435x | +|||
| 147 | +
- out+ #' @examples |
|||
| 301 | +148 |
- }+ #' # summarize_num_patients |
||
| 302 | +149 |
-
+ #' tbl <- basic_table() %>% |
||
| 303 | +150 |
- #' Update labels according to control specifications+ #' split_cols_by("ARM") %>%
|
||
| 304 | +151 |
- #'+ #' split_rows_by("SEX") %>%
|
||
| 305 | +152 |
- #' @description `r lifecycle::badge("stable")`
+ #' summarize_num_patients("USUBJID", .stats = "unique_count") %>%
|
||
| 306 | +153 |
- #'+ #' build_table(df) |
||
| 307 | +154 |
- #' Given a list of statistic labels and and a list of control parameters, updates labels with a relevant+ #' |
||
| 308 | +155 |
- #' control specification. For example, if control has element `conf_level` set to `0.9`, the default+ #' tbl |
||
| 309 | +156 |
- #' label for statistic `mean_ci` will be updated to `"Mean 90% CI"`. Any labels that are supplied+ #' |
||
| 310 | +157 |
- #' via `labels_custom` will not be updated regardless of `control`.+ #' @export |
||
| 311 | +158 |
- #'+ #' @order 3 |
||
| 312 | +159 |
- #' @param labels_default (named `character`)\cr a named vector of statistic labels to modify+ summarize_num_patients <- function(lyt, |
||
| 313 | +160 |
- #' according to the control specifications. Labels that are explicitly defined in `labels_custom` will+ var, |
||
| 314 | +161 |
- #' not be affected.+ required = NULL, |
||
| 315 | +162 |
- #' @param labels_custom (named `character`)\cr named vector of labels that are customized by+ count_by = NULL, |
||
| 316 | +163 |
- #' the user and should not be affected by `control`.+ unique_count_suffix = TRUE, |
||
| 317 | +164 |
- #' @param control (named `list`)\cr list of control parameters to apply to adjust default labels.+ na_str = default_na_str(), |
||
| 318 | +165 |
- #'+ .stats = NULL, |
||
| 319 | +166 |
- #' @return A named character vector of labels with control specifications applied to relevant labels.+ .formats = NULL, |
||
| 320 | +167 |
- #'+ .labels = c( |
||
| 321 | +168 |
- #' @examples+ unique = "Number of patients with at least one event", |
||
| 322 | +169 |
- #' control <- list(conf_level = 0.80, quantiles = c(0.1, 0.83), test_mean = 0.57)+ nonunique = "Number of events" |
||
| 323 | +170 |
- #' get_labels_from_stats(c("mean_ci", "quantiles", "mean_pval")) %>%
+ ), |
||
| 324 | +171 |
- #' labels_use_control(control = control)+ .indent_mods = 0L, |
||
| 325 | +172 |
- #'+ riskdiff = FALSE, |
||
| 326 | +173 |
- #' @export+ ...) {
+ |
+ ||
| 174 | +16x | +
+ checkmate::assert_flag(riskdiff) |
||
| 327 | +175 |
- labels_use_control <- function(labels_default, control, labels_custom = NULL) {
+
|
||
| 328 | -20x | +176 | +5x |
- if ("conf_level" %in% names(control)) {
+ if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
|
| 329 | -20x | +177 | +8x |
- labels_default <- sapply(+ if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats]+ |
+
| 178 | ++ | + | ||
| 330 | -20x | +179 | +16x |
- names(labels_default),+ s_args <- list(required = required, count_by = count_by, unique_count_suffix = unique_count_suffix, ...)+ |
+
| 180 | ++ | + | ||
| 331 | -20x | +181 | +16x |
- function(x) {
+ cfun <- make_afun( |
| 332 | -91x | +182 | +16x |
- if (!x %in% names(labels_custom)) {
+ c_num_patients, |
| 333 | -88x | +183 | +16x |
- gsub(labels_default[[x]], pattern = "[0-9]+% CI", replacement = f_conf_level(control[["conf_level"]]))+ .stats = .stats, |
| 334 | -+ | |||
| 184 | +16x |
- } else {
+ .formats = .formats, |
||
| 335 | -3x | +185 | +16x |
- labels_default[[x]]+ .labels = .labels |
| 336 | +186 |
- }+ ) |
||
| 337 | +187 |
- }+ |
||
| 338 | -+ | |||
| 188 | +16x |
- )+ extra_args <- if (isFALSE(riskdiff)) {
+ |
+ ||
| 189 | +14x | +
+ s_args |
||
| 339 | +190 |
- }+ } else {
|
||
| 340 | -20x | +191 | +2x |
- if ("quantiles" %in% names(control) && "quantiles" %in% names(labels_default) &&
+ list( |
| 341 | -20x | +192 | +2x |
- !"quantiles" %in% names(labels_custom)) { # nolint
+ afun = list("s_num_patients_content" = cfun),
|
| 342 | -16x | +193 | +2x |
- labels_default["quantiles"] <- gsub(+ .stats = .stats, |
| 343 | -16x | +194 | +2x |
- "[0-9]+% and [0-9]+", paste0(control[["quantiles"]][1] * 100, "% and ", control[["quantiles"]][2] * 100, ""),+ .indent_mods = .indent_mods, |
| 344 | -16x | +195 | +2x |
- labels_default["quantiles"]+ s_args = s_args |
| 345 | +196 |
) |
||
| 346 | +197 |
} |
||
| 198 | ++ | + + | +||
| 347 | -20x | +199 | +16x |
- if ("test_mean" %in% names(control) && "mean_pval" %in% names(labels_default) &&
+ summarize_row_groups( |
| 348 | -20x | +200 | +16x |
- !"mean_pval" %in% names(labels_custom)) { # nolint
+ lyt = lyt, |
| 349 | -2x | +201 | +16x |
- labels_default["mean_pval"] <- gsub(+ var = var, |
| 350 | -2x | +202 | +16x |
- "p-value \\(H0: mean = [0-9\\.]+\\)", f_pval(control[["test_mean"]]), labels_default["mean_pval"]+ cfun = ifelse(isFALSE(riskdiff), cfun, afun_riskdiff),+ |
+
| 203 | +16x | +
+ na_str = na_str,+ |
+ ||
| 204 | +16x | +
+ extra_args = extra_args,+ |
+ ||
| 205 | +16x | +
+ indent_mod = .indent_mods |
||
| 351 | +206 |
- )+ ) |
||
| 352 | +207 |
- }+ } |
||
| 353 | +208 | |||
| 354 | -20x | -
- labels_default- |
- ||
| 355 | +209 |
- }+ #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments |
||
| 356 | +210 |
-
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 357 | +211 |
- #' @describeIn default_stats_formats_labels Named list of available statistics by method group for `tern`.+ #' |
||
| 358 | +212 |
- #'+ #' @return |
||
| 359 | +213 |
- #' @format+ #' * `analyze_num_patients()` returns a layout object suitable for passing to further layouting functions, |
||
| 360 | +214 |
- #' * `tern_default_stats` is a named list of available statistics, with each element+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 361 | +215 |
- #' named for their corresponding statistical method group.+ #' the statistics from `s_num_patients_content()` to the table layout. |
||
| 362 | +216 |
#' |
||
| 363 | +217 |
- #' @export+ #' @details In general, functions that starts with `analyze*` are expected to |
||
| 364 | +218 |
- tern_default_stats <- list(+ #' work like [rtables::analyze()], while functions that starts with `summarize*` |
||
| 365 | +219 |
- abnormal = c("fraction"),
+ #' are based upon [rtables::summarize_row_groups()]. The latter provides a |
||
| 366 | +220 |
- abnormal_by_baseline = c("fraction"),
+ #' value for each dividing split in the row and column space, but, being it |
||
| 367 | +221 |
- abnormal_by_marked = c("count_fraction", "count_fraction_fixed_dp"),
+ #' bound to the fundamental splits, it is repeated by design in every page |
||
| 368 | +222 |
- abnormal_by_worst_grade = c("count_fraction", "count_fraction_fixed_dp"),
+ #' when pagination is involved. |
||
| 369 | +223 |
- abnormal_by_worst_grade_worsen = c("fraction"),
+ #' |
||
| 370 | +224 |
- analyze_patients_exposure_in_cols = c("n_patients", "sum_exposure"),
+ #' @note As opposed to [summarize_num_patients()], this function does not repeat the produced rows. |
||
| 371 | +225 |
- analyze_vars_counts = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "fraction", "n_blq"),
+ #' |
||
| 372 | +226 |
- analyze_vars_numeric = c(+ #' @examples |
||
| 373 | +227 |
- "n", "sum", "mean", "sd", "se", "mean_sd", "mean_se", "mean_ci", "mean_sei", "mean_sdi", "mean_pval",+ #' df <- data.frame( |
||
| 374 | +228 |
- "median", "mad", "median_ci", "quantiles", "iqr", "range", "min", "max", "median_range", "cv",+ #' USUBJID = as.character(c(1, 2, 1, 4, NA, 6, 6, 8, 9)), |
||
| 375 | +229 |
- "geom_mean", "geom_mean_ci", "geom_cv"+ #' ARM = c("A", "A", "A", "A", "A", "B", "B", "B", "B"),
|
||
| 376 | +230 |
- ),+ #' AGE = c(10, 15, 10, 17, 8, 11, 11, 19, 17), |
||
| 377 | +231 |
- count_cumulative = c("count_fraction", "count_fraction_fixed_dp"),
+ #' SEX = c("M", "M", "M", "F", "F", "F", "M", "F", "M")
|
||
| 378 | +232 |
- count_missed_doses = c("n", "count_fraction", "count_fraction_fixed_dp"),
+ #' ) |
||
| 379 | +233 |
- count_occurrences = c("count", "count_fraction", "count_fraction_fixed_dp", "fraction"),
+ #' |
||
| 380 | +234 |
- count_occurrences_by_grade = c("count_fraction", "count_fraction_fixed_dp"),
+ #' # analyze_num_patients |
||
| 381 | +235 |
- count_patients_with_event = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
+ #' tbl <- basic_table() %>% |
||
| 382 | +236 |
- count_patients_with_flags = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
+ #' split_cols_by("ARM") %>%
|
||
| 383 | +237 |
- count_values = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
+ #' add_colcounts() %>% |
||
| 384 | +238 |
- coxph_pairwise = c("pvalue", "hr", "hr_ci", "n_tot", "n_tot_events"),
+ #' analyze_num_patients("USUBJID", .stats = c("unique")) %>%
|
||
| 385 | +239 |
- estimate_incidence_rate = c("person_years", "n_events", "rate", "rate_ci", "n_unique", "n_rate"),
+ #' build_table(df) |
||
| 386 | +240 |
- estimate_multinomial_response = c("n_prop", "prop_ci"),
+ #' |
||
| 387 | +241 |
- estimate_odds_ratio = c("or_ci", "n_tot"),
+ #' tbl |
||
| 388 | +242 |
- estimate_proportion = c("n_prop", "prop_ci"),
+ #' |
||
| 389 | +243 |
- estimate_proportion_diff = c("diff", "diff_ci"),
+ #' @export |
||
| 390 | +244 |
- summarize_ancova = c("n", "lsmean", "lsmean_diff", "lsmean_diff_ci", "pval"),
+ #' @order 2 |
||
| 391 | +245 |
- summarize_coxreg = c("n", "hr", "ci", "pval", "pval_inter"),
+ analyze_num_patients <- function(lyt, |
||
| 392 | +246 |
- summarize_glm_count = c("n", "rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
+ vars, |
||
| 393 | +247 |
- summarize_num_patients = c("unique", "nonunique", "unique_count"),
+ required = NULL, |
||
| 394 | +248 |
- summarize_patients_events_in_cols = c("unique", "all"),
+ count_by = NULL, |
||
| 395 | +249 |
- surv_time = c("median", "median_ci", "quantiles", "range_censor", "range_event", "range"),
+ unique_count_suffix = TRUE, |
||
| 396 | +250 |
- surv_timepoint = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci", "rate_diff", "rate_diff_ci", "ztest_pval"),
+ na_str = default_na_str(), |
||
| 397 | +251 |
- tabulate_rsp_biomarkers = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
+ nested = TRUE, |
||
| 398 | +252 |
- tabulate_rsp_subgroups = c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval"),
+ .stats = NULL, |
||
| 399 | +253 |
- tabulate_survival_biomarkers = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
+ .formats = NULL, |
||
| 400 | +254 |
- tabulate_survival_subgroups = c("n_tot_events", "n_events", "n_tot", "n", "median", "hr", "ci", "pval"),
+ .labels = c( |
||
| 401 | +255 |
- test_proportion_diff = c("pval")
+ unique = "Number of patients with at least one event", |
||
| 402 | +256 |
- )+ nonunique = "Number of events" |
||
| 403 | +257 |
-
+ ), |
||
| 404 | +258 |
- #' @describeIn default_stats_formats_labels Named vector of default formats for `tern`.+ show_labels = c("default", "visible", "hidden"),
|
||
| 405 | +259 |
- #'+ .indent_mods = 0L, |
||
| 406 | +260 |
- #' @format+ riskdiff = FALSE, |
||
| 407 | +261 |
- #' * `tern_default_formats` is a named vector of available default formats, with each element+ ...) {
|
||
| 408 | -+ | |||
| 262 | +4x |
- #' named for their corresponding statistic.+ checkmate::assert_flag(riskdiff) |
||
| 409 | +263 |
- #'+ |
||
| 410 | -+ | |||
| 264 | +1x |
- #' @export+ if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
|
||
| 411 | -+ | |||
| 265 | +! |
- tern_default_formats <- c(+ if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats] |
||
| 412 | +266 |
- fraction = format_fraction_fixed_dp,+ |
||
| 413 | -+ | |||
| 267 | +4x |
- unique = format_count_fraction_fixed_dp,+ s_args <- list(required = required, count_by = count_by, unique_count_suffix = unique_count_suffix, ...) |
||
| 414 | +268 |
- nonunique = "xx",+ |
||
| 415 | -+ | |||
| 269 | +4x |
- unique_count = "xx",+ afun <- make_afun( |
||
| 416 | -+ | |||
| 270 | +4x |
- n = "xx.",+ c_num_patients, |
||
| 417 | -+ | |||
| 271 | +4x |
- count = "xx.",+ .stats = .stats, |
||
| 418 | -+ | |||
| 272 | +4x |
- count_fraction = format_count_fraction,+ .formats = .formats, |
||
| 419 | -+ | |||
| 273 | +4x |
- count_fraction_fixed_dp = format_count_fraction_fixed_dp,+ .labels = .labels |
||
| 420 | +274 |
- n_blq = "xx.",+ ) |
||
| 421 | +275 |
- sum = "xx.x",+ |
||
| 422 | -+ | |||
| 276 | +4x |
- mean = "xx.x",+ extra_args <- if (isFALSE(riskdiff)) {
|
||
| 423 | -+ | |||
| 277 | +2x |
- sd = "xx.x",+ s_args |
||
| 424 | +278 |
- se = "xx.x",+ } else {
|
||
| 425 | -+ | |||
| 279 | +2x |
- mean_sd = "xx.x (xx.x)",+ list(+ |
+ ||
| 280 | +2x | +
+ afun = list("s_num_patients_content" = afun),
+ |
+ ||
| 281 | +2x | +
+ .stats = .stats,+ |
+ ||
| 282 | +2x | +
+ .indent_mods = .indent_mods,+ |
+ ||
| 283 | +2x | +
+ s_args = s_args |
||
| 426 | +284 |
- mean_se = "xx.x (xx.x)",+ ) |
||
| 427 | +285 |
- mean_ci = "(xx.xx, xx.xx)",+ } |
||
| 428 | +286 |
- mean_sei = "(xx.xx, xx.xx)",+ + |
+ ||
| 287 | +4x | +
+ analyze(+ |
+ ||
| 288 | +4x | +
+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ |
+ ||
| 289 | +4x | +
+ lyt = lyt,+ |
+ ||
| 290 | +4x | +
+ vars = vars,+ |
+ ||
| 291 | +4x | +
+ na_str = na_str,+ |
+ ||
| 292 | +4x | +
+ nested = nested,+ |
+ ||
| 293 | +4x | +
+ extra_args = extra_args,+ |
+ ||
| 294 | +4x | +
+ show_labels = show_labels,+ |
+ ||
| 295 | +4x | +
+ indent_mod = .indent_mods |
||
| 429 | +296 |
- mean_sdi = "(xx.xx, xx.xx)",+ ) |
||
| 430 | +297 |
- mean_pval = "x.xxxx | (<0.0001)",+ } |
| 431 | +1 |
- median = "xx.x",+ #' Bland-Altman analysis |
||
| 432 | +2 |
- mad = "xx.x",+ #' |
||
| 433 | +3 |
- median_ci = "(xx.xx, xx.xx)",+ #' @description `r lifecycle::badge("experimental")`
|
||
| 434 | +4 |
- quantiles = "xx.x - xx.x",+ #' |
||
| 435 | +5 |
- iqr = "xx.x",+ #' Statistics function that uses the Bland-Altman method to assess the agreement between two numerical vectors |
||
| 436 | +6 |
- range = "xx.x - xx.x",+ #' and calculates a variety of statistics. |
||
| 437 | +7 |
- min = "xx.x",+ #' |
||
| 438 | +8 |
- max = "xx.x",+ #' @inheritParams argument_convention |
||
| 439 | +9 |
- median_range = "xx.x (xx.x - xx.x)",+ #' @param y (`numeric`)\cr vector of numbers we want to analyze, to be compared with `x`. |
||
| 440 | +10 |
- cv = "xx.x",+ #' |
||
| 441 | +11 |
- geom_mean = "xx.x",+ #' @return |
||
| 442 | +12 |
- geom_mean_ci = "(xx.xx, xx.xx)",+ #' A named list of the following elements: |
||
| 443 | +13 |
- geom_cv = "xx.x",+ #' * `df` |
||
| 444 | +14 |
- pval = "x.xxxx | (<0.0001)",+ #' * `difference_mean` |
||
| 445 | +15 |
- pval_counts = "x.xxxx | (<0.0001)",+ #' * `ci_mean` |
||
| 446 | +16 |
- range_censor = "xx.x to xx.x",+ #' * `difference_sd` |
||
| 447 | +17 |
- range_event = "xx.x to xx.x",+ #' * `difference_se` |
||
| 448 | +18 |
- rate = "xx.xxxx",+ #' * `upper_agreement_limit` |
||
| 449 | +19 |
- rate_ci = "(xx.xxxx, xx.xxxx)",+ #' * `lower_agreement_limit` |
||
| 450 | +20 |
- rate_ratio = "xx.xxxx",+ #' * `agreement_limit_se` |
||
| 451 | +21 |
- rate_ratio_ci = "(xx.xxxx, xx.xxxx)"+ #' * `upper_agreement_limit_ci` |
||
| 452 | +22 |
- )+ #' * `lower_agreement_limit_ci` |
||
| 453 | +23 |
-
+ #' * `t_value` |
||
| 454 | +24 |
- #' @describeIn default_stats_formats_labels Named `character` vector of default labels for `tern`.+ #' * `n` |
||
| 455 | +25 |
#' |
||
| 456 | +26 |
- #' @format+ #' @examples |
||
| 457 | +27 |
- #' * `tern_default_labels` is a named `character` vector of available default labels, with each element+ #' x <- seq(1, 60, 5) |
||
| 458 | +28 |
- #' named for their corresponding statistic.+ #' y <- seq(5, 50, 4) |
||
| 459 | +29 |
#' |
||
| 460 | +30 |
- #' @export+ #' s_bland_altman(x, y, conf_level = 0.9) |
||
| 461 | +31 |
- tern_default_labels <- c(+ #' |
||
| 462 | +32 |
- fraction = "fraction",+ #' @export |
||
| 463 | +33 |
- unique = "Number of patients with at least one event",+ s_bland_altman <- function(x, y, conf_level = 0.95) {
|
||
| 464 | -+ | |||
| 34 | +7x |
- nonunique = "Number of events",+ checkmate::assert_numeric(x, min.len = 1, any.missing = TRUE) |
||
| 465 | -+ | |||
| 35 | +6x |
- n = "n",+ checkmate::assert_numeric(y, len = length(x), any.missing = TRUE) |
||
| 466 | -+ | |||
| 36 | +5x |
- count = "count",+ checkmate::assert_numeric(conf_level, lower = 0, upper = 1, any.missing = TRUE) |
||
| 467 | +37 |
- count_fraction = "count_fraction",+ |
||
| 468 | -+ | |||
| 38 | +4x |
- count_fraction_fixed_dp = "count_fraction",+ alpha <- 1 - conf_level |
||
| 469 | +39 |
- n_blq = "n_blq",+ |
||
| 470 | -+ | |||
| 40 | +4x |
- sum = "Sum",+ ind <- complete.cases(x, y) # use only pairwise complete observations, and check if x and y have the same length |
||
| 471 | -+ | |||
| 41 | +4x |
- mean = "Mean",+ x <- x[ind] |
||
| 472 | -+ | |||
| 42 | +4x |
- sd = "SD",+ y <- y[ind]+ |
+ ||
| 43 | +4x | +
+ n <- sum(ind) # number of 'observations' |
||
| 473 | +44 |
- se = "SE",+ + |
+ ||
| 45 | +4x | +
+ if (n == 0) {
+ |
+ ||
| 46 | +! | +
+ stop("there is no valid paired data")
|
||
| 474 | +47 |
- mean_sd = "Mean (SD)",+ } |
||
| 475 | +48 |
- mean_se = "Mean (SE)",+ + |
+ ||
| 49 | +4x | +
+ difference <- x - y # vector of differences+ |
+ ||
| 50 | +4x | +
+ average <- (x + y) / 2 # vector of means+ |
+ ||
| 51 | +4x | +
+ difference_mean <- mean(difference) # mean difference+ |
+ ||
| 52 | +4x | +
+ difference_sd <- sd(difference) # SD of differences+ |
+ ||
| 53 | +4x | +
+ al <- qnorm(1 - alpha / 2) * difference_sd+ |
+ ||
| 54 | +4x | +
+ upper_agreement_limit <- difference_mean + al # agreement limits+ |
+ ||
| 55 | +4x | +
+ lower_agreement_limit <- difference_mean - al |
||
| 476 | +56 |
- mean_ci = "Mean 95% CI",+ + |
+ ||
| 57 | +4x | +
+ difference_se <- difference_sd / sqrt(n) # standard error of the mean+ |
+ ||
| 58 | +4x | +
+ al_se <- difference_sd * sqrt(3) / sqrt(n) # standard error of the agreement limit+ |
+ ||
| 59 | +4x | +
+ tvalue <- qt(1 - alpha / 2, n - 1) # t value for 95% CI calculation+ |
+ ||
| 60 | +4x | +
+ difference_mean_ci <- difference_se * tvalue+ |
+ ||
| 61 | +4x | +
+ al_ci <- al_se * tvalue+ |
+ ||
| 62 | +4x | +
+ upper_agreement_limit_ci <- c(upper_agreement_limit - al_ci, upper_agreement_limit + al_ci)+ |
+ ||
| 63 | +4x | +
+ lower_agreement_limit_ci <- c(lower_agreement_limit - al_ci, lower_agreement_limit + al_ci) |
||
| 477 | +64 |
- mean_sei = "Mean -/+ 1xSE",+ + |
+ ||
| 65 | +4x | +
+ list(+ |
+ ||
| 66 | +4x | +
+ df = data.frame(average, difference),+ |
+ ||
| 67 | +4x | +
+ difference_mean = difference_mean,+ |
+ ||
| 68 | +4x | +
+ ci_mean = difference_mean + c(-1, 1) * difference_mean_ci,+ |
+ ||
| 69 | +4x | +
+ difference_sd = difference_sd,+ |
+ ||
| 70 | +4x | +
+ difference_se = difference_se,+ |
+ ||
| 71 | +4x | +
+ upper_agreement_limit = upper_agreement_limit,+ |
+ ||
| 72 | +4x | +
+ lower_agreement_limit = lower_agreement_limit,+ |
+ ||
| 73 | +4x | +
+ agreement_limit_se = al_se,+ |
+ ||
| 74 | +4x | +
+ upper_agreement_limit_ci = upper_agreement_limit_ci,+ |
+ ||
| 75 | +4x | +
+ lower_agreement_limit_ci = lower_agreement_limit_ci,+ |
+ ||
| 76 | +4x | +
+ t_value = tvalue,+ |
+ ||
| 77 | +4x | +
+ n = n |
||
| 478 | +78 |
- mean_sdi = "Mean -/+ 1xSD",+ ) |
||
| 479 | +79 |
- mean_pval = "Mean p-value (H0: mean = 0)",+ } |
||
| 480 | +80 |
- median = "Median",+ |
||
| 481 | +81 |
- mad = "Median Absolute Deviation",+ #' Bland-Altman plot |
||
| 482 | +82 |
- median_ci = "Median 95% CI",+ #' |
||
| 483 | +83 |
- quantiles = "25% and 75%-ile",+ #' @description `r lifecycle::badge("experimental")`
|
||
| 484 | +84 |
- iqr = "IQR",+ #' |
||
| 485 | +85 |
- range = "Min - Max",+ #' Graphing function that produces a Bland-Altman plot. |
||
| 486 | +86 |
- min = "Minimum",+ #' |
||
| 487 | +87 |
- max = "Maximum",+ #' @inheritParams s_bland_altman |
||
| 488 | +88 |
- median_range = "Median (Min - Max)",+ #' |
||
| 489 | +89 |
- cv = "CV (%)",+ #' @return A `ggplot` Bland-Altman plot. |
||
| 490 | +90 |
- geom_mean = "Geometric Mean",+ #' |
||
| 491 | +91 |
- geom_mean_ci = "Geometric Mean 95% CI",+ #' @examples |
||
| 492 | +92 |
- geom_cv = "CV % Geometric Mean",+ #' x <- seq(1, 60, 5) |
||
| 493 | +93 |
- pval = "p-value (t-test)", # Default for numeric+ #' y <- seq(5, 50, 4) |
||
| 494 | +94 |
- pval_counts = "p-value (chi-squared test)", # Default for counts+ #' |
||
| 495 | +95 |
- rate = "Adjusted Rate",+ #' g_bland_altman(x = x, y = y, conf_level = 0.9) |
||
| 496 | +96 |
- rate_ratio = "Adjusted Rate Ratio"+ #' |
||
| 497 | +97 |
- )+ #' @export |
||
| 498 | +98 |
-
+ #' @aliases bland_altman |
||
| 499 | +99 |
- # To deprecate ---------+ g_bland_altman <- function(x, y, conf_level = 0.95) {
+ |
+ ||
| 100 | +1x | +
+ result_tem <- s_bland_altman(x, y, conf_level = conf_level)+ |
+ ||
| 101 | +1x | +
+ xpos <- max(result_tem$df$average) * 0.9 + min(result_tem$df$average) * 0.1+ |
+ ||
| 102 | +1x | +
+ yrange <- diff(range(result_tem$df$difference)) |
||
| 500 | +103 | |||
| 501 | -+ | |||
| 104 | +1x |
- #' @describeIn default_stats_formats_labels `r lifecycle::badge("deprecated")`
+ p <- ggplot(result_tem$df) + |
||
| 502 | -+ | |||
| 105 | +1x |
- #' Quick function to retrieve default formats for summary statistics:+ geom_point(aes(x = average, y = difference), color = "blue") ++ |
+ ||
| 106 | +1x | +
+ geom_hline(yintercept = result_tem$difference_mean, color = "blue", linetype = 1) ++ |
+ ||
| 107 | +1x | +
+ geom_hline(yintercept = 0, color = "blue", linetype = 2) ++ |
+ ||
| 108 | +1x | +
+ geom_hline(yintercept = result_tem$lower_agreement_limit, color = "red", linetype = 2) ++ |
+ ||
| 109 | +1x | +
+ geom_hline(yintercept = result_tem$upper_agreement_limit, color = "red", linetype = 2) ++ |
+ ||
| 110 | +1x | +
+ annotate( |
||
| 503 | -+ | |||
| 111 | +1x |
- #' [analyze_vars()] and [analyze_vars_in_cols()] principally.+ "text", |
||
| 504 | -+ | |||
| 112 | +1x |
- #'+ x = xpos, |
||
| 505 | -+ | |||
| 113 | +1x |
- #' @param type (`string`)\cr `"numeric"` or `"counts"`.+ y = result_tem$lower_agreement_limit + 0.03 * yrange, |
||
| 506 | -+ | |||
| 114 | +1x |
- #'+ label = "lower limits of agreement", |
||
| 507 | -+ | |||
| 115 | +1x |
- #' @return+ color = "red" |
||
| 508 | +116 |
- #' * `summary_formats()` returns a named `vector` of default statistic formats for the given data type.+ ) + |
||
| 509 | -+ | |||
| 117 | +1x |
- #'+ annotate( |
||
| 510 | -+ | |||
| 118 | +1x |
- #' @examples+ "text", |
||
| 511 | -+ | |||
| 119 | +1x |
- #' summary_formats()+ x = xpos, |
||
| 512 | -+ | |||
| 120 | +1x |
- #' summary_formats(type = "counts", include_pval = TRUE)+ y = result_tem$upper_agreement_limit + 0.03 * yrange, |
||
| 513 | -+ | |||
| 121 | +1x |
- #'+ label = "upper limits of agreement", |
||
| 514 | -+ | |||
| 122 | +1x |
- #' @export+ color = "red" |
||
| 515 | +123 |
- summary_formats <- function(type = "numeric", include_pval = FALSE) {
+ ) + |
||
| 516 | -2x | +124 | +1x |
- lifecycle::deprecate_warn(+ annotate( |
| 517 | -2x | +125 | +1x |
- "0.9.6", "summary_formats()",+ "text", |
| 518 | -2x | +126 | +1x |
- details = 'Use get_formats_from_stats(get_stats("analyze_vars_numeric", add_pval = include_pval)) instead'
+ x = xpos, |
| 519 | -+ | |||
| 127 | +1x |
- )+ y = result_tem$difference_mean + 0.03 * yrange, |
||
| 520 | -2x | +128 | +1x |
- met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ label = "mean of difference between two measures", |
| 521 | -2x | +129 | +1x |
- get_formats_from_stats(get_stats(met_grp, add_pval = include_pval))+ color = "blue" |
| 522 | +130 |
- }+ ) + |
||
| 523 | -+ | |||
| 131 | +1x |
-
+ annotate( |
||
| 524 | -+ | |||
| 132 | +1x |
- #' @describeIn default_stats_formats_labels `r lifecycle::badge("deprecated")`
+ "text", |
||
| 525 | -+ | |||
| 133 | +1x |
- #' Quick function to retrieve default labels for summary statistics.+ x = xpos, |
||
| 526 | -+ | |||
| 134 | +1x |
- #' Returns labels of descriptive statistics which are understood by `rtables`. Similar to `summary_formats`.+ y = result_tem$lower_agreement_limit - 0.03 * yrange, |
||
| 527 | -+ | |||
| 135 | +1x |
- #'+ label = sprintf("%.2f", result_tem$lower_agreement_limit),
|
||
| 528 | -+ | |||
| 136 | +1x |
- #' @param include_pval (`flag`)\cr same as the `add_pval` argument in [get_stats()].+ color = "red" |
||
| 529 | +137 |
- #'+ ) + |
||
| 530 | -+ | |||
| 138 | +1x |
- #' @return+ annotate( |
||
| 531 | -+ | |||
| 139 | +1x |
- #' * `summary_labels` returns a named `vector` of default statistic labels for the given data type.+ "text", |
||
| 532 | -+ | |||
| 140 | +1x |
- #'+ x = xpos, |
||
| 533 | -+ | |||
| 141 | +1x |
- #' @examples+ y = result_tem$upper_agreement_limit - 0.03 * yrange, |
||
| 534 | -+ | |||
| 142 | +1x |
- #' summary_labels()+ label = sprintf("%.2f", result_tem$upper_agreement_limit),
|
||
| 535 | -+ | |||
| 143 | +1x |
- #' summary_labels(type = "counts", include_pval = TRUE)+ color = "red" |
||
| 536 | +144 |
- #'+ ) + |
||
| 537 | -+ | |||
| 145 | +1x |
- #' @export+ annotate( |
||
| 538 | -+ | |||
| 146 | +1x |
- summary_labels <- function(type = "numeric", include_pval = FALSE) {
+ "text", |
||
| 539 | -2x | +147 | +1x |
- lifecycle::deprecate_warn(+ x = xpos, |
| 540 | -2x | +148 | +1x |
- "0.9.6", "summary_formats()",+ y = result_tem$difference_mean - 0.03 * yrange, |
| 541 | -2x | +149 | +1x |
- details = 'Use get_labels_from_stats(get_stats("analyze_vars_numeric", add_pval = include_pval)) instead'
+ label = sprintf("%.2f", result_tem$difference_meanm),
+ |
+
| 150 | +1x | +
+ color = "blue" |
||
| 542 | +151 |
- )+ ) + |
||
| 543 | -2x | +152 | +1x |
- met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ xlab("Average of two measures") +
|
| 544 | -2x | +153 | +1x |
- get_labels_from_stats(get_stats(met_grp, add_pval = include_pval))+ ylab("Difference between two measures")
|
| 545 | +154 | ++ | + + | +|
| 155 | +1x | +
+ return(p)+ |
+ ||
| 156 |
}@@ -139398,14 +138548,14 @@ tern coverage - 95.64% |
| 1 |
- #' Convert `rtable` objects to `ggplot` objects+ #' Combine factor levels |
||
| 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+ #' Combine specified old factor Levels in a single new level. |
||
| 6 |
- #' functions from the `ggplot2` package. Any table titles and/or footnotes are ignored.+ #' |
||
| 7 |
- #'+ #' @param x (`factor`)\cr factor variable. |
||
| 8 |
- #' @param tbl (`VTableTree`)\cr `rtables` table object.+ #' @param levels (`character`)\cr level names to be combined. |
||
| 9 |
- #' @param fontsize (`numeric(1)`)\cr font size.+ #' @param new_level (`string`)\cr name of new level. |
||
| 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+ #' @return A `factor` with the new levels. |
||
| 12 |
- #' are calculated according to maximum number of characters per column.+ #' |
||
| 13 |
- #' @param lbl_col_padding (`numeric`)\cr additional padding to use when calculating spacing between+ #' @examples |
||
| 14 |
- #' the first (label) column and the second column of `tbl`. If `colwidths` is specified,+ #' x <- factor(letters[1:5], levels = letters[5:1]) |
||
| 15 |
- #' the width of the first column becomes `colwidths[1] + lbl_col_padding`. Defaults to 0.+ #' combine_levels(x, levels = c("a", "b"))
|
||
| 17 |
- #' @return A `ggplot` object.+ #' combine_levels(x, c("e", "b"))
|
||
| 19 |
- #' @examples+ #' @export |
||
| 20 |
- #' dta <- data.frame(+ combine_levels <- function(x, levels, new_level = paste(levels, collapse = "/")) {
|
||
| 21 | -+ | 4x |
- #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ checkmate::assert_factor(x) |
| 22 | -+ | 4x |
- #' AVISIT = rep(paste0("V", 1:3), 6),
+ checkmate::assert_subset(levels, levels(x)) |
| 23 |
- #' AVAL = c(9:1, rep(NA, 9))+ |
||
| 24 | -+ | 4x |
- #' )+ lvls <- levels(x) |
| 25 |
- #'+ |
||
| 26 | -+ | 4x |
- #' lyt <- basic_table() %>%+ lvls[lvls %in% levels] <- new_level |
| 27 |
- #' split_cols_by(var = "ARM") %>%+ |
||
| 28 | -+ | 4x |
- #' split_rows_by(var = "AVISIT") %>%+ levels(x) <- lvls |
| 29 |
- #' analyze_vars(vars = "AVAL")+ |
||
| 30 | -+ | 4x |
- #'+ x |
| 31 |
- #' tbl <- build_table(lyt, df = dta)+ } |
||
| 32 |
- #'+ |
||
| 33 |
- #' rtable2gg(tbl)+ #' Conversion of a vector to a factor |
||
| 35 |
- #' rtable2gg(tbl, fontsize = 15, colwidths = c(2, 1, 1, 1))+ #' Converts `x` to a factor and keeps its attributes. Warns appropriately such that the user |
||
| 36 |
- #'+ #' can decide whether they prefer converting to factor manually (e.g. for full control of |
||
| 37 |
- #' @export+ #' factor levels). |
||
| 38 |
- rtable2gg <- function(tbl, fontsize = 12, colwidths = NULL, lbl_col_padding = 0) {
+ #' |
||
| 39 | -6x | +
- mat <- rtables::matrix_form(tbl, indent_rownames = TRUE)+ #' @param x (`vector`)\cr object to convert. |
|
| 40 | -6x | +
- mat_strings <- formatters::mf_strings(mat)+ #' @param x_name (`string`)\cr name of `x`. |
|
| 41 | -6x | +
- mat_aligns <- formatters::mf_aligns(mat)+ #' @param na_level (`string`)\cr the explicit missing level which should be used when converting a character vector. |
|
| 42 | -6x | +
- mat_indent <- formatters::mf_rinfo(mat)$indent+ #' @param verbose (`flag`)\cr defaults to `TRUE`. It prints out warnings and messages. |
|
| 43 | -6x | +
- mat_display <- formatters::mf_display(mat)+ #' |
|
| 44 | -6x | +
- nlines_hdr <- formatters::mf_nlheader(mat)+ #' @return A `factor` with same attributes (except class) as `x`. Does not modify `x` if already a `factor`. |
|
| 45 | -6x | +
- shared_hdr_rows <- which(apply(mat_display, 1, function(x) (any(!x))))+ #' |
|
| 46 |
-
+ #' @keywords internal |
||
| 47 | -6x | +
- tbl_df <- data.frame(mat_strings)+ as_factor_keep_attributes <- function(x, |
|
| 48 | -6x | +
- body_rows <- seq(nlines_hdr + 1, nrow(tbl_df))+ x_name = deparse(substitute(x)), |
|
| 49 | -6x | +
- mat_aligns <- apply(mat_aligns, 1:2, function(x) if (x == "left") 0 else if (x == "right") 1 else 0.5)+ na_level = "<Missing>", |
|
| 50 |
-
+ verbose = TRUE) {
|
||
| 51 | -+ | 205x |
- # Apply indentation in first column+ checkmate::assert_atomic(x) |
| 52 | -6x | +205x |
- tbl_df[body_rows, 1] <- sapply(body_rows, function(i) {
+ checkmate::assert_string(x_name) |
| 53 | -42x | +205x |
- ind_i <- mat_indent[i - nlines_hdr] * 4+ checkmate::assert_string(na_level) |
| 54 | -18x | +205x |
- if (ind_i > 0) paste0(paste(rep(" ", ind_i), collapse = ""), tbl_df[i, 1]) else tbl_df[i, 1]
+ checkmate::assert_flag(verbose) |
| 55 | -+ | 205x |
- })+ if (is.factor(x)) {
|
| 56 | -+ | 186x |
-
+ return(x) |
| 57 |
- # Get column widths+ } |
||
| 58 | -6x | +19x |
- if (is.null(colwidths)) {
+ x_class <- class(x)[1] |
| 59 | -6x | +19x |
- colwidths <- apply(tbl_df, 2, function(x) max(nchar(x))) + 1+ if (verbose) {
|
| 60 | -+ | 15x |
- }+ warning(paste( |
| 61 | -6x | +15x |
- tot_width <- sum(colwidths) + lbl_col_padding+ "automatically converting", x_class, "variable", x_name, |
| 62 | -+ | 15x |
-
+ "to factor, better manually convert to factor to avoid failures" |
| 63 | -6x | +
- if (length(shared_hdr_rows) > 0) {
+ )) |
|
| 64 | -5x | +
- tbl_df <- tbl_df[-shared_hdr_rows, ]+ } |
|
| 65 | -5x | +19x |
- mat_aligns <- mat_aligns[-shared_hdr_rows, ]+ if (identical(length(x), 0L)) {
|
| 66 | -+ | 1x |
- }+ warning(paste( |
| 67 | -+ | 1x |
-
+ x_name, "has length 0, this can lead to tabulation failures, better convert to factor" |
| 68 | -6x | +
- res <- ggplot(data = tbl_df) ++ )) |
|
| 69 | -6x | +
- theme_void() ++ } |
|
| 70 | -6x | +19x |
- scale_x_continuous(limits = c(0, tot_width)) ++ if (is.character(x)) {
|
| 71 | -6x | +19x |
- scale_y_continuous(limits = c(0, nrow(mat_strings))) ++ x_no_na <- explicit_na(sas_na(x), label = na_level) |
| 72 | -6x | +19x |
- annotate(+ if (any(na_level %in% x_no_na)) {
|
| 73 | -6x | +3x |
- "segment",+ do.call( |
| 74 | -6x | +3x |
- x = 0, xend = tot_width,+ structure, |
| 75 | -6x | +3x |
- y = nrow(mat_strings) - nlines_hdr + 0.5, yend = nrow(mat_strings) - nlines_hdr + 0.5+ c( |
| 76 | -+ | 3x |
- )+ list(.Data = forcats::fct_relevel(x_no_na, na_level, after = Inf)), |
| 77 | -+ | 3x |
-
+ attributes(x) |
| 78 |
- # If header content spans multiple columns, center over these columns+ ) |
||
| 79 | -6x | +
- if (length(shared_hdr_rows) > 0) {
+ ) |
|
| 80 | -5x | +
- mat_strings[shared_hdr_rows, ] <- trimws(mat_strings[shared_hdr_rows, ])+ } else {
|
|
| 81 | -5x | +16x |
- for (hr in shared_hdr_rows) {
+ do.call(structure, c(list(.Data = as.factor(x)), attributes(x))) |
| 82 | -6x | +
- hdr_lbls <- mat_strings[1:hr, mat_display[hr, -1]]+ } |
|
| 83 | -6x | +
- hdr_lbls <- matrix(hdr_lbls[nzchar(hdr_lbls)], nrow = hr)+ } else {
|
|
| 84 | -6x | +! |
- for (idx_hl in seq_len(ncol(hdr_lbls))) {
+ do.call(structure, c(list(.Data = as.factor(x)), attributes(x))) |
| 85 | -13x | +
- cur_lbl <- tail(hdr_lbls[, idx_hl], 1)+ } |
|
| 86 | -13x | +
- which_cols <- if (hr == 1) {
+ } |
|
| 87 | -9x | +
- which(mat_strings[hr, ] == hdr_lbls[idx_hl])+ |
|
| 88 | -13x | +
- } else { # for >2 col splits, only print labels for each unique combo of nested columns
+ #' Labels for bins in percent |
|
| 89 | -4x | +
- which(+ #' |
|
| 90 | -4x | +
- apply(mat_strings[1:hr, ], 2, function(x) all(x == hdr_lbls[1:hr, idx_hl]))+ #' This creates labels for quantile based bins in percent. This assumes the right-closed |
|
| 91 |
- )+ #' intervals as produced by [cut_quantile_bins()]. |
||
| 92 |
- }+ #' |
||
| 93 | -13x | +
- line_pos <- c(+ #' @param probs (`numeric`)\cr the probabilities identifying the quantiles. |
|
| 94 | -13x | +
- sum(colwidths[1:(which_cols[1] - 1)]) + 1 + lbl_col_padding,+ #' This is a sorted vector of unique `proportion` values, i.e. between 0 and 1, where |
|
| 95 | -13x | +
- sum(colwidths[1:max(which_cols)]) - 1 + lbl_col_padding+ #' the boundaries 0 and 1 must not be included. |
|
| 96 |
- )+ #' @param digits (`integer(1)`)\cr number of decimal places to round the percent numbers. |
||
| 97 |
-
+ #' |
||
| 98 | -13x | +
- res <- res ++ #' @return A `character` vector with labels in the format `[0%,20%]`, `(20%,50%]`, etc. |
|
| 99 | -13x | +
- annotate(+ #' |
|
| 100 | -13x | +
- "text",+ #' @keywords internal |
|
| 101 | -13x | +
- x = mean(line_pos),+ bins_percent_labels <- function(probs, |
|
| 102 | -13x | +
- y = nrow(mat_strings) + 1 - hr,+ digits = 0) {
|
|
| 103 | -13x | +3x |
- label = cur_lbl,+ if (isFALSE(0 %in% probs)) probs <- c(0, probs) |
| 104 | -13x | +3x |
- size = fontsize / .pt+ if (isFALSE(1 %in% probs)) probs <- c(probs, 1) |
| 105 | -+ | 10x |
- ) ++ checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE) |
| 106 | -13x | +10x |
- annotate(+ percent <- round(probs * 100, digits = digits) |
| 107 | -13x | +10x |
- "segment",+ left <- paste0(utils::head(percent, -1), "%") |
| 108 | -13x | +10x |
- x = line_pos[1],+ right <- paste0(utils::tail(percent, -1), "%") |
| 109 | -13x | +10x |
- xend = line_pos[2],+ without_left_bracket <- paste0(left, ",", right, "]") |
| 110 | -13x | +10x |
- y = nrow(mat_strings) - hr + 0.5,+ with_left_bracket <- paste0("[", utils::head(without_left_bracket, 1))
|
| 111 | -13x | +10x |
- yend = nrow(mat_strings) - hr + 0.5+ if (length(without_left_bracket) > 1) {
|
| 112 | -+ | 7x |
- )+ with_left_bracket <- c( |
| 113 | -+ | 7x |
- }+ with_left_bracket, |
| 114 | -+ | 7x |
- }+ paste0("(", utils::tail(without_left_bracket, -1))
|
| 115 |
- }+ ) |
||
| 116 |
-
+ } |
||
| 117 | -+ | 10x |
- # Add table columns+ with_left_bracket |
| 118 | -6x | +
- for (i in seq_len(ncol(tbl_df))) {
+ } |
|
| 119 | -40x | +
- res <- res + annotate(+ |
|
| 120 | -40x | +
- "text",+ #' Cut numeric vector into empirical quantile bins |
|
| 121 | -40x | +
- x = if (i == 1) 0 else sum(colwidths[1:i]) - 0.5 * colwidths[i] + lbl_col_padding,+ #' |
|
| 122 | -40x | +
- y = rev(seq_len(nrow(tbl_df))),+ #' @description `r lifecycle::badge("stable")`
|
|
| 123 | -40x | +
- label = tbl_df[, i],+ #' |
|
| 124 | -40x | +
- hjust = mat_aligns[, i],+ #' This cuts a numeric vector into sample quantile bins. |
|
| 125 | -40x | +
- size = fontsize / .pt+ #' |
|
| 126 |
- )+ #' @inheritParams bins_percent_labels |
||
| 127 |
- }+ #' @param x (`numeric`)\cr the continuous variable values which should be cut into |
||
| 128 |
-
+ #' quantile bins. This may contain `NA` values, which are then |
||
| 129 | -6x | +
- res+ #' not used for the quantile calculations, but included in the return vector. |
|
| 130 |
- }+ #' @param labels (`character`)\cr the unique labels for the quantile bins. When there are `n` |
||
| 131 |
-
+ #' probabilities in `probs`, then this must be `n + 1` long. |
||
| 132 |
- #' Convert `data.frame` object to `ggplot` object+ #' @param type (`integer(1)`)\cr type of quantiles to use, see [stats::quantile()] for details. |
||
| 133 |
- #'+ #' @param ordered (`flag`)\cr should the result be an ordered factor. |
||
| 134 |
- #' @description `r lifecycle::badge("experimental")`
+ #' |
||
| 135 |
- #'+ #' @return A `factor` variable with appropriately-labeled bins as levels. |
||
| 136 |
- #' Given a `data.frame` object, performs basic conversion to a [ggplot2::ggplot()] object built using+ #' |
||
| 137 |
- #' functions from the `ggplot2` package.+ #' @note Intervals are closed on the right side. That is, the first bin is the interval |
||
| 138 |
- #'+ #' `[-Inf, q1]` where `q1` is the first quantile, the second bin is then `(q1, q2]`, etc., |
||
| 139 |
- #' @param df (`data.frame`)\cr a data frame.+ #' and the last bin is `(qn, +Inf]` where `qn` is the last quantile. |
||
| 140 |
- #' @param colwidths (`numeric` or `NULL`)\cr a vector of column widths. Each element's position in+ #' |
||
| 141 |
- #' `colwidths` corresponds to the column of `df` in the same position. If `NULL`, column widths+ #' @examples |
||
| 142 |
- #' are calculated according to maximum number of characters per column.+ #' # Default is to cut into quartile bins. |
||
| 143 |
- #' @param font_size (`numeric(1)`)\cr font size.+ #' cut_quantile_bins(cars$speed) |
||
| 144 |
- #' @param col_labels (`flag`)\cr whether the column names (labels) of `df` should be used as the first row+ #' |
||
| 145 |
- #' of the output table.+ #' # Use custom quantiles. |
||
| 146 |
- #' @param col_lab_fontface (`string`)\cr font face to apply to the first row (of column labels+ #' cut_quantile_bins(cars$speed, probs = c(0.1, 0.2, 0.6, 0.88)) |
||
| 147 |
- #' if `col_labels = TRUE`). Defaults to `"bold"`.+ #' |
||
| 148 |
- #' @param hline (`flag`)\cr whether a horizontal line should be printed below the first row of the table.+ #' # Use custom labels. |
||
| 149 |
- #' @param bg_fill (`string`)\cr table background fill color.+ #' cut_quantile_bins(cars$speed, labels = paste0("Q", 1:4))
|
||
| 151 |
- #' @return A `ggplot` object.+ #' # NAs are preserved in result factor. |
||
| 152 |
- #'+ #' ozone_binned <- cut_quantile_bins(airquality$Ozone) |
||
| 153 |
- #' @examples+ #' which(is.na(ozone_binned)) |
||
| 154 |
- #' \dontrun{
+ #' # So you might want to make these explicit. |
||
| 155 |
- #' df2gg(head(iris, 5))+ #' explicit_na(ozone_binned) |
||
| 157 |
- #' df2gg(head(iris, 5), font_size = 15, colwidths = c(1, 1, 1, 1, 1))+ #' @export |
||
| 158 |
- #' }+ cut_quantile_bins <- function(x, |
||
| 159 |
- #' @keywords internal+ probs = c(0.25, 0.5, 0.75), |
||
| 160 |
- df2gg <- function(df,+ labels = NULL, |
||
| 161 |
- colwidths = NULL,+ type = 7, |
||
| 162 |
- font_size = 10,+ ordered = TRUE) {
|
||
| 163 | -+ | 8x |
- col_labels = TRUE,+ checkmate::assert_flag(ordered) |
| 164 | -+ | 8x |
- col_lab_fontface = "bold",+ checkmate::assert_numeric(x) |
| 165 | -+ | 7x |
- hline = TRUE,+ if (isFALSE(0 %in% probs)) probs <- c(0, probs) |
| 166 | -+ | 7x |
- bg_fill = NULL) {
+ if (isFALSE(1 %in% probs)) probs <- c(probs, 1) |
| 167 | -+ | 8x |
- # convert to text+ checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE) |
| 168 | -19x | +7x |
- df <- as.data.frame(apply(df, 1:2, function(x) if (is.na(x)) "NA" else as.character(x)))+ if (is.null(labels)) labels <- bins_percent_labels(probs) |
| 169 | -+ | 8x |
-
+ checkmate::assert_character(labels, len = length(probs) - 1, any.missing = FALSE, unique = TRUE) |
| 170 | -19x | +
- if (col_labels) {
+
|
|
| 171 | -10x | +8x |
- df <- as.matrix(df)+ if (all(is.na(x))) {
|
| 172 | -10x | +
- df <- rbind(colnames(df), df)+ # Early return if there are only NAs in input. |
|
| 173 | -+ | 1x |
- }+ return(factor(x, ordered = ordered, levels = labels)) |
| 174 |
-
+ } |
||
| 175 |
- # Get column widths+ |
||
| 176 | -19x | +7x |
- if (is.null(colwidths)) {
+ quantiles <- stats::quantile( |
| 177 | -1x | +7x |
- colwidths <- apply(df, 2, function(x) max(nchar(x), na.rm = TRUE))+ x, |
| 178 | -+ | 7x |
- }+ probs = probs, |
| 179 | -19x | +7x |
- tot_width <- sum(colwidths)+ type = type, |
| 180 | -+ | 7x |
-
+ na.rm = TRUE |
| 181 | -19x | +
- res <- ggplot(data = df) ++ ) |
|
| 182 | -19x | +
- theme_void() ++ |
|
| 183 | -19x | +7x |
- scale_x_continuous(limits = c(0, tot_width)) ++ checkmate::assert_numeric(quantiles, unique = TRUE) |
| 184 | -19x | +
- scale_y_continuous(limits = c(1, nrow(df)))+ |
|
| 185 | -+ | 6x |
-
+ cut( |
| 186 | -9x | +6x |
- if (!is.null(bg_fill)) res <- res + theme(plot.background = element_rect(fill = bg_fill))+ x, |
| 187 | -+ | 6x |
-
+ breaks = quantiles, |
| 188 | -19x | +6x |
- if (hline) {
+ labels = labels, |
| 189 | -10x | +6x |
- res <- res ++ ordered_result = ordered, |
| 190 | -10x | +6x |
- annotate(+ include.lowest = TRUE, |
| 191 | -10x | +6x |
- "segment",+ right = TRUE |
| 192 | -10x | +
- x = 0 + 0.2 * colwidths[2], xend = tot_width - 0.1 * tail(colwidths, 1),+ ) |
|
| 193 | -10x | +
- y = nrow(df) - 0.5, yend = nrow(df) - 0.5+ } |
|
| 194 |
- )+ |
||
| 195 |
- }+ #' Discard specified levels of a factor |
||
| 196 |
-
+ #' |
||
| 197 | -19x | +
- for (i in seq_len(ncol(df))) {
+ #' @description `r lifecycle::badge("stable")`
|
|
| 198 | -86x | +
- line_pos <- c(+ #' |
|
| 199 | -86x | +
- if (i == 1) 0 else sum(colwidths[1:(i - 1)]),+ #' This discards the observations as well as the levels specified from a factor. |
|
| 200 | -86x | +
- sum(colwidths[1:i])+ #' |
|
| 201 |
- )+ #' @param x (`factor`)\cr the original factor. |
||
| 202 | -86x | +
- res <- res ++ #' @param discard (`character`)\cr levels to discard. |
|
| 203 | -86x | +
- annotate(+ #' |
|
| 204 | -86x | +
- "text",+ #' @return A modified `factor` with observations as well as levels from `discard` dropped. |
|
| 205 | -86x | +
- x = mean(line_pos),+ #' |
|
| 206 | -86x | +
- y = rev(seq_len(nrow(df))),+ #' @examples |
|
| 207 | -86x | +
- label = df[, i],+ #' fct_discard(factor(c("a", "b", "c")), "c")
|
|
| 208 | -86x | +
- size = font_size / .pt,+ #' |
|
| 209 | -86x | +
- fontface = if (col_labels) {
+ #' @export |
|
| 210 | -32x | +
- c(col_lab_fontface, rep("plain", nrow(df) - 1))
+ fct_discard <- function(x, discard) {
|
|
| 211 | -+ | 319x |
- } else {
+ checkmate::assert_factor(x) |
| 212 | -54x | +319x |
- rep("plain", nrow(df))
+ 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) |
| 216 |
-
+ } |
||
| 217 | -19x | +
- res+ |
|
| 218 |
- }+ #' Insertion of explicit missing values in a factor |
| 1 | +219 |
- #' Survival time analysis+ #' |
||
| 2 | +220 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+ |
| 221 |
#' |
|||
| 3 | +222 |
- #' @description `r lifecycle::badge("stable")`
+ #' This inserts explicit missing values in a factor based on a condition. Additionally, |
||
| 4 | +223 |
- #'+ #' existing `NA` values will be explicitly converted to given `na_level`. |
||
| 5 | +224 |
- #' The analyze function [surv_time()] creates a layout element to analyze survival time by calculating survival time+ #' |
||
| 6 | +225 |
- #' median, median confidence interval, quantiles, and range (for all, censored, or event patients). The primary+ #' @param x (`factor`)\cr the original factor. |
||
| 7 | +226 |
- #' analysis variable `vars` is the time variable and the secondary analysis variable `is_event` indicates whether or+ #' @param condition (`logical`)\cr positions at which to insert missing values. |
||
| 8 | +227 |
- #' not an event has occurred.+ #' @param na_level (`string`)\cr which level to use for missing values. |
||
| 9 | +228 |
#' |
||
| 10 | +229 |
- #' @inheritParams argument_convention+ #' @return A modified `factor` with inserted and existing `NA` converted to `na_level`. |
||
| 11 | +230 |
- #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function+ #' |
||
| 12 | +231 |
- #' [control_surv_time()]. Some possible parameter options are:+ #' @seealso [forcats::fct_na_value_to_level()] which is used internally. |
||
| 13 | +232 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival time.+ #' |
||
| 14 | +233 |
- #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", or "log-log",+ #' @examples |
||
| 15 | +234 |
- #' see more in [survival::survfit()]. Note option "none" is not supported.+ #' fct_explicit_na_if(factor(c("a", "b", NA)), c(TRUE, FALSE, FALSE))
|
||
| 16 | +235 |
- #' * `quantiles` (`numeric`)\cr vector of length two to specify the quantiles of survival time.+ #' |
||
| 17 | +236 |
- #' @param ref_fn_censor (`flag`)\cr whether referential footnotes indicating censored observations should be printed+ #' @export |
||
| 18 | +237 |
- #' when the `range` statistic is included.+ fct_explicit_na_if <- function(x, condition, na_level = "<Missing>") {
+ |
+ ||
| 238 | +1x | +
+ checkmate::assert_factor(x, len = length(condition))+ |
+ ||
| 239 | +1x | +
+ checkmate::assert_logical(condition)+ |
+ ||
| 240 | +1x | +
+ x[condition] <- NA+ |
+ ||
| 241 | +1x | +
+ x <- forcats::fct_na_value_to_level(x, level = na_level)+ |
+ ||
| 242 | +1x | +
+ forcats::fct_drop(x, only = na_level) |
||
| 19 | +243 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("surv_time")`
+ } |
||
| 20 | +244 |
- #' to see available statistics for this function.+ |
||
| 21 | +245 |
- #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector+ #' Collapse factor levels and keep only those new group levels |
||
| 22 | +246 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ #' |
||
| 23 | +247 |
- #' for that statistic's row label.+ #' @description `r lifecycle::badge("stable")`
|
||
| 24 | +248 |
#' |
||
| 25 | +249 |
- #' @examples+ #' This collapses levels and only keeps those new group levels, in the order provided. |
||
| 26 | +250 |
- #' library(dplyr)+ #' The returned factor has levels in the order given, with the possible missing level last (this will |
||
| 27 | +251 | ++ |
+ #' only be included if there are missing values).+ |
+ |
| 252 |
#' |
|||
| 28 | +253 |
- #' adtte_f <- tern_ex_adtte %>%+ #' @param .f (`factor` or `character`)\cr original vector. |
||
| 29 | +254 |
- #' filter(PARAMCD == "OS") %>%+ #' @param ... (named `character`)\cr levels in each vector provided will be collapsed into |
||
| 30 | +255 |
- #' mutate(+ #' the new level given by the respective name. |
||
| 31 | +256 |
- #' AVAL = day2month(AVAL),+ #' @param .na_level (`string`)\cr which level to use for other levels, which should be missing in the |
||
| 32 | +257 |
- #' is_event = CNSR == 0+ #' new factor. Note that this level must not be contained in the new levels specified in `...`. |
||
| 33 | +258 |
- #' )+ #' |
||
| 34 | +259 |
- #' df <- adtte_f %>% filter(ARMCD == "ARM A")+ #' @return A modified `factor` with collapsed levels. Values and levels which are not included |
||
| 35 | +260 |
- #'+ #' in the given `character` vector input will be set to the missing level `.na_level`. |
||
| 36 | +261 |
- #' @name survival_time+ #' |
||
| 37 | +262 |
- #' @order 1+ #' @note Any existing `NA`s in the input vector will not be replaced by the missing level. If needed, |
||
| 38 | +263 |
- NULL+ #' [explicit_na()] can be called separately on the result. |
||
| 39 | +264 |
-
+ #' |
||
| 40 | +265 |
- #' @describeIn survival_time Statistics function which analyzes survival times.+ #' @seealso [forcats::fct_collapse()], [forcats::fct_relevel()] which are used internally. |
||
| 41 | +266 |
#' |
||
| 42 | +267 |
- #' @return+ #' @examples |
||
| 43 | +268 |
- #' * `s_surv_time()` returns the statistics:+ #' fct_collapse_only(factor(c("a", "b", "c", "d")), TRT = "b", CTRL = c("c", "d"))
|
||
| 44 | +269 |
- #' * `median`: Median survival time.+ #' |
||
| 45 | +270 |
- #' * `median_ci`: Confidence interval for median time.+ #' @export |
||
| 46 | +271 |
- #' * `quantiles`: Survival time for two specified quantiles.+ fct_collapse_only <- function(.f, ..., .na_level = "<Missing>") {
+ |
+ ||
| 272 | +4x | +
+ new_lvls <- names(list(...))+ |
+ ||
| 273 | +4x | +
+ if (checkmate::test_subset(.na_level, new_lvls)) {
+ |
+ ||
| 274 | +1x | +
+ stop(paste0(".na_level currently set to '", .na_level, "' must not be contained in the new levels"))
|
||
| 47 | +275 |
- #' * `range_censor`: Survival time range for censored observations.+ }+ |
+ ||
| 276 | +3x | +
+ x <- forcats::fct_collapse(.f, ..., other_level = .na_level)+ |
+ ||
| 277 | +3x | +
+ do.call(forcats::fct_relevel, args = c(list(.f = x), as.list(new_lvls))) |
||
| 48 | +278 |
- #' * `range_event`: Survival time range for observations with events.+ } |
||
| 49 | +279 |
- #' * `range`: Survival time range for all observations.+ |
||
| 50 | +280 |
- #'+ #' Ungroup non-numeric statistics |
||
| 51 | +281 |
- #' @keywords internal+ #' |
||
| 52 | +282 |
- s_surv_time <- function(df,+ #' Ungroups grouped non-numeric statistics within input vectors `.formats`, `.labels`, and `.indent_mods`. |
||
| 53 | +283 |
- .var,+ #' |
||
| 54 | +284 |
- is_event,+ #' @inheritParams argument_convention |
||
| 55 | +285 |
- control = control_surv_time()) {
+ #' @param x (named `list` of `numeric`)\cr list of numeric statistics containing the statistics to ungroup. |
||
| 56 | -232x | +|||
| 286 | +
- checkmate::assert_string(.var)+ #' |
|||
| 57 | -232x | +|||
| 287 | +
- assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ #' @return A `list` with modified elements `x`, `.formats`, `.labels`, and `.indent_mods`. |
|||
| 58 | -232x | +|||
| 288 | +
- checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE)+ #' |
|||
| 59 | -232x | +|||
| 289 | +
- checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)+ #' @seealso [a_summary()] which uses this function internally. |
|||
| 60 | +290 |
-
+ #' |
||
| 61 | -232x | +|||
| 291 | +
- conf_type <- control$conf_type+ #' @keywords internal |
|||
| 62 | -232x | +|||
| 292 | +
- conf_level <- control$conf_level+ ungroup_stats <- function(x, |
|||
| 63 | -232x | +|||
| 293 | +
- quantiles <- control$quantiles+ .formats, |
|||
| 64 | +294 |
-
+ .labels, |
||
| 65 | -232x | +|||
| 295 | +
- formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
+ .indent_mods) {
|
|||
| 66 | -232x | +296 | +316x |
- srv_fit <- survival::survfit(+ checkmate::assert_list(x) |
| 67 | -232x | +297 | +316x |
- formula = formula,+ empty_pval <- "pval" %in% names(x) && length(x[["pval"]]) == 0 |
| 68 | -232x | +298 | +316x |
- data = df,+ empty_pval_counts <- "pval_counts" %in% names(x) && length(x[["pval_counts"]]) == 0 |
| 69 | -232x | +299 | +316x |
- conf.int = conf_level,+ x <- unlist(x, recursive = FALSE) |
| 70 | -232x | +|||
| 300 | +
- conf.type = conf_type+ |
|||
| 71 | +301 |
- )+ # If p-value is empty it is removed by unlist and needs to be re-added |
||
| 72 | -232x | +|||
| 302 | +! |
- srv_tab <- summary(srv_fit, extend = TRUE)$table+ if (empty_pval) x[["pval"]] <- character() |
||
| 73 | -232x | +303 | +3x |
- srv_qt_tab <- stats::quantile(srv_fit, probs = quantiles)$quantile+ if (empty_pval_counts) x[["pval_counts"]] <- character() |
| 74 | -232x | +304 | +316x |
- range_censor <- range_noinf(df[[.var]][!df[[is_event]]], na.rm = TRUE)+ .stats <- names(x) |
| 75 | -232x | +|||
| 305 | +
- range_event <- range_noinf(df[[.var]][df[[is_event]]], na.rm = TRUE)+ |
|||
| 76 | -232x | +|||
| 306 | +
- range <- range_noinf(df[[.var]], na.rm = TRUE)+ # Ungroup stats |
|||
| 77 | -232x | +307 | +316x |
- list(+ .formats <- lapply(.stats, function(x) {
|
| 78 | -232x | +308 | +2644x |
- median = formatters::with_label(unname(srv_tab["median"]), "Median"),+ .formats[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
+ |
+
| 309 | ++ |
+ }) |
||
| 79 | -232x | +310 | +316x |
- median_ci = formatters::with_label(+ .indent_mods <- sapply(.stats, function(x) {
|
| 80 | -232x | +311 | +2644x |
- unname(srv_tab[paste0(srv_fit$conf.int, c("LCL", "UCL"))]), f_conf_level(conf_level)
+ .indent_mods[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
|
| 81 | +312 |
- ),+ }) |
||
| 82 | -232x | +313 | +316x |
- quantiles = formatters::with_label(+ .labels <- sapply(.stats, function(x) {
|
| 83 | -232x | +314 | +2575x |
- unname(srv_qt_tab), paste0(quantiles[1] * 100, "% and ", quantiles[2] * 100, "%-ile")+ if (!grepl("\\.", x)) .labels[[x]] else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][2]
|
| 84 | +315 |
- ),+ })+ |
+ ||
| 316 | ++ | + | ||
| 85 | -232x | +317 | +316x |
- range_censor = formatters::with_label(range_censor, "Range (censored)"),+ list( |
| 86 | -232x | +318 | +316x |
- range_event = formatters::with_label(range_event, "Range (event)"),+ x = x, |
| 87 | -232x | +319 | +316x |
- range = formatters::with_label(range, "Range")+ .formats = .formats, |
| 88 | -+ | |||
| 320 | +316x |
- )+ .labels = .labels, |
||
| 89 | -+ | |||
| 321 | +316x |
- }+ .indent_mods = .indent_mods |
||
| 90 | +322 |
-
+ ) |
||
| 91 | +323 |
- #' @describeIn survival_time Formatted analysis function which is used as `afun` in `surv_time()`.+ } |
| 92 | +1 |
- #'+ #' Convert `rtable` objects to `ggplot` objects |
||
| 93 | +2 |
- #' @return+ #' |
||
| 94 | +3 |
- #' * `a_surv_time()` returns the corresponding list with formatted [rtables::CellValue()].+ #' @description `r lifecycle::badge("experimental")`
|
||
| 95 | +4 |
#' |
||
| 96 | +5 |
- #' @examples+ #' Given a [rtables::rtable()] object, performs basic conversion to a [ggplot2::ggplot()] object built using |
||
| 97 | +6 |
- #' a_surv_time(+ #' functions from the `ggplot2` package. Any table titles and/or footnotes are ignored. |
||
| 98 | +7 |
- #' df,+ #' |
||
| 99 | +8 |
- #' .df_row = df,+ #' @param tbl (`VTableTree`)\cr `rtables` table object. |
||
| 100 | +9 |
- #' .var = "AVAL",+ #' @param fontsize (`numeric(1)`)\cr font size. |
||
| 101 | +10 |
- #' is_event = "is_event"+ #' @param colwidths (`numeric` or `NULL`)\cr a vector of column widths. Each element's position in |
||
| 102 | +11 |
- #' )+ #' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths |
||
| 103 | +12 |
- #'+ #' are calculated according to maximum number of characters per column. |
||
| 104 | +13 |
- #' @export+ #' @param lbl_col_padding (`numeric`)\cr additional padding to use when calculating spacing between |
||
| 105 | +14 |
- a_surv_time <- function(df,+ #' the first (label) column and the second column of `tbl`. If `colwidths` is specified, |
||
| 106 | +15 |
- labelstr = "",+ #' the width of the first column becomes `colwidths[1] + lbl_col_padding`. Defaults to 0. |
||
| 107 | +16 |
- .var = NULL,+ #' |
||
| 108 | +17 |
- .df_row = NULL,+ #' @return A `ggplot` object. |
||
| 109 | +18 |
- is_event,+ #' |
||
| 110 | +19 |
- control = control_surv_time(),+ #' @examples |
||
| 111 | +20 |
- ref_fn_censor = TRUE,+ #' dta <- data.frame( |
||
| 112 | +21 |
- .stats = NULL,+ #' ARM = rep(LETTERS[1:3], rep(6, 3)), |
||
| 113 | +22 |
- .formats = NULL,+ #' AVISIT = rep(paste0("V", 1:3), 6),
|
||
| 114 | +23 |
- .labels = NULL,+ #' AVAL = c(9:1, rep(NA, 9)) |
||
| 115 | +24 |
- .indent_mods = NULL,+ #' ) |
||
| 116 | +25 |
- na_str = default_na_str()) {
- |
- ||
| 117 | -14x | -
- x_stats <- s_surv_time(- |
- ||
| 118 | -14x | -
- df = df, .var = .var, is_event = is_event, control = control+ #' |
||
| 119 | +26 |
- )- |
- ||
| 120 | -14x | -
- rng_censor_lwr <- x_stats[["range_censor"]][1]- |
- ||
| 121 | -14x | -
- rng_censor_upr <- x_stats[["range_censor"]][2]+ #' lyt <- basic_table() %>% |
||
| 122 | +27 |
-
+ #' split_cols_by(var = "ARM") %>% |
||
| 123 | +28 |
- # Use method-specific defaults- |
- ||
| 124 | -14x | -
- fmts <- c(median_ci = "(xx.x, xx.x)", quantiles = "xx.x, xx.x", range = "xx.x to xx.x")- |
- ||
| 125 | -14x | -
- lbls <- c(median_ci = "95% CI", range = "Range", range_censor = "Range (censored)", range_event = "Range (event)")- |
- ||
| 126 | -14x | -
- lbls_custom <- .labels- |
- ||
| 127 | -14x | -
- .formats <- c(.formats, fmts[setdiff(names(fmts), names(.formats))])- |
- ||
| 128 | -14x | -
- .labels <- c(.labels, lbls[setdiff(names(lbls), names(lbls_custom))])+ #' split_rows_by(var = "AVISIT") %>% |
||
| 129 | +29 |
-
+ #' analyze_vars(vars = "AVAL") |
||
| 130 | +30 |
- # Fill in with formatting defaults if needed- |
- ||
| 131 | -14x | -
- .stats <- get_stats("surv_time", stats_in = .stats)
- |
- ||
| 132 | -14x | -
- .formats <- get_formats_from_stats(.stats, .formats)- |
- ||
| 133 | -14x | -
- .labels <- get_labels_from_stats(.stats, .labels) %>% labels_use_control(control, lbls_custom)- |
- ||
| 134 | -14x | -
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods)+ #' |
||
| 135 | +31 |
-
+ #' tbl <- build_table(lyt, df = dta) |
||
| 136 | -14x | +|||
| 32 | +
- x_stats <- x_stats[.stats]+ #' |
|||
| 137 | +33 |
-
+ #' rtable2gg(tbl) |
||
| 138 | +34 |
- # Auto format handling+ #' |
||
| 139 | -14x | +|||
| 35 | +
- .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)+ #' rtable2gg(tbl, fontsize = 15, colwidths = c(2, 1, 1, 1)) |
|||
| 140 | +36 |
-
+ #' |
||
| 141 | -14x | +|||
| 37 | +
- cell_fns <- setNames(vector("list", length = length(x_stats)), .labels)
+ #' @export |
|||
| 142 | -14x | +|||
| 38 | +
- if ("range" %in% names(x_stats) && ref_fn_censor) {
+ rtable2gg <- function(tbl, fontsize = 12, colwidths = NULL, lbl_col_padding = 0) {
|
|||
| 143 | -14x | +39 | +6x |
- if (identical(x_stats[["range"]][1], rng_censor_lwr) && identical(x_stats[["range"]][2], rng_censor_upr)) {
+ mat <- rtables::matrix_form(tbl, indent_rownames = TRUE) |
| 144 | -2x | +40 | +6x |
- cell_fns[[.labels[["range"]]]] <- "Censored observations: range minimum & maximum"+ mat_strings <- formatters::mf_strings(mat) |
| 145 | -12x | +41 | +6x |
- } else if (identical(x_stats[["range"]][1], rng_censor_lwr)) {
+ mat_aligns <- formatters::mf_aligns(mat) |
| 146 | -2x | +42 | +6x |
- cell_fns[[.labels[["range"]]]] <- "Censored observation: range minimum"+ mat_indent <- formatters::mf_rinfo(mat)$indent |
| 147 | -10x | +43 | +6x |
- } else if (identical(x_stats[["range"]][2], rng_censor_upr)) {
+ mat_display <- formatters::mf_display(mat) |
| 148 | -1x | -
- cell_fns[[.labels[["range"]]]] <- "Censored observation: range maximum"- |
- ||
| 149 | -+ | 44 | +6x |
- }+ nlines_hdr <- formatters::mf_nlheader(mat) |
| 150 | -+ | |||
| 45 | +6x |
- }+ shared_hdr_rows <- which(apply(mat_display, 1, function(x) (any(!x)))) |
||
| 151 | +46 | |||
| 152 | -14x | +47 | +6x |
- in_rows(+ tbl_df <- data.frame(mat_strings) |
| 153 | -14x | +48 | +6x |
- .list = x_stats,+ body_rows <- seq(nlines_hdr + 1, nrow(tbl_df)) |
| 154 | -14x | +49 | +6x |
- .formats = .formats,+ mat_aligns <- apply(mat_aligns, 1:2, function(x) if (x == "left") 0 else if (x == "right") 1 else 0.5) |
| 155 | -14x | +|||
| 50 | +
- .names = .labels,+ |
|||
| 156 | -14x | +|||
| 51 | +
- .labels = .labels,+ # Apply indentation in first column |
|||
| 157 | -14x | +52 | +6x |
- .indent_mods = .indent_mods,+ tbl_df[body_rows, 1] <- sapply(body_rows, function(i) {
|
| 158 | -14x | +53 | +42x |
- .format_na_strs = na_str,+ ind_i <- mat_indent[i - nlines_hdr] * 4 |
| 159 | -14x | -
- .cell_footnotes = cell_fns- |
- ||
| 160 | -+ | 54 | +18x |
- )+ if (ind_i > 0) paste0(paste(rep(" ", ind_i), collapse = ""), tbl_df[i, 1]) else tbl_df[i, 1]
|
| 161 | +55 |
- }+ }) |
||
| 162 | +56 | |||
| 163 | -- |
- #' @describeIn survival_time Layout-creating function which can take statistics function arguments- |
- ||
| 164 | +57 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ # Get column widths |
||
| 165 | -+ | |||
| 58 | +6x |
- #'+ if (is.null(colwidths)) {
|
||
| 166 | -+ | |||
| 59 | +6x |
- #' @return+ colwidths <- apply(tbl_df, 2, function(x) max(nchar(x))) + 1 |
||
| 167 | +60 |
- #' * `surv_time()` returns a layout object suitable for passing to further layouting functions,+ } |
||
| 168 | -+ | |||
| 61 | +6x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ tot_width <- sum(colwidths) + lbl_col_padding |
||
| 169 | +62 |
- #' the statistics from `s_surv_time()` to the table layout.+ |
||
| 170 | -+ | |||
| 63 | +6x |
- #'+ if (length(shared_hdr_rows) > 0) {
|
||
| 171 | -+ | |||
| 64 | +5x |
- #' @examples+ tbl_df <- tbl_df[-shared_hdr_rows, ] |
||
| 172 | -+ | |||
| 65 | +5x |
- #' basic_table() %>%+ mat_aligns <- mat_aligns[-shared_hdr_rows, ] |
||
| 173 | +66 |
- #' split_cols_by(var = "ARMCD") %>%+ } |
||
| 174 | +67 |
- #' add_colcounts() %>%+ |
||
| 175 | -+ | |||
| 68 | +6x |
- #' surv_time(+ res <- ggplot(data = tbl_df) + |
||
| 176 | -+ | |||
| 69 | +6x |
- #' vars = "AVAL",+ theme_void() + |
||
| 177 | -+ | |||
| 70 | +6x |
- #' var_labels = "Survival Time (Months)",+ scale_x_continuous(limits = c(0, tot_width)) + |
||
| 178 | -+ | |||
| 71 | +6x |
- #' is_event = "is_event",+ scale_y_continuous(limits = c(0, nrow(mat_strings))) + |
||
| 179 | -+ | |||
| 72 | +6x |
- #' control = control_surv_time(conf_level = 0.9, conf_type = "log-log")+ annotate( |
||
| 180 | -+ | |||
| 73 | +6x |
- #' ) %>%+ "segment", |
||
| 181 | -+ | |||
| 74 | +6x |
- #' build_table(df = adtte_f)+ x = 0, xend = tot_width, |
||
| 182 | -+ | |||
| 75 | +6x |
- #'+ y = nrow(mat_strings) - nlines_hdr + 0.5, yend = nrow(mat_strings) - nlines_hdr + 0.5 |
||
| 183 | +76 |
- #' @export+ ) |
||
| 184 | +77 |
- #' @order 2+ |
||
| 185 | +78 |
- surv_time <- function(lyt,+ # If header content spans multiple columns, center over these columns |
||
| 186 | -+ | |||
| 79 | +6x |
- vars,+ if (length(shared_hdr_rows) > 0) {
|
||
| 187 | -+ | |||
| 80 | +5x |
- is_event,+ mat_strings[shared_hdr_rows, ] <- trimws(mat_strings[shared_hdr_rows, ]) |
||
| 188 | -+ | |||
| 81 | +5x |
- control = control_surv_time(),+ for (hr in shared_hdr_rows) {
|
||
| 189 | -+ | |||
| 82 | +6x |
- ref_fn_censor = TRUE,+ hdr_lbls <- mat_strings[1:hr, mat_display[hr, -1]] |
||
| 190 | -+ | |||
| 83 | +6x |
- na_str = default_na_str(),+ hdr_lbls <- matrix(hdr_lbls[nzchar(hdr_lbls)], nrow = hr) |
||
| 191 | -+ | |||
| 84 | +6x |
- nested = TRUE,+ for (idx_hl in seq_len(ncol(hdr_lbls))) {
|
||
| 192 | -+ | |||
| 85 | +13x |
- ...,+ cur_lbl <- tail(hdr_lbls[, idx_hl], 1) |
||
| 193 | -+ | |||
| 86 | +13x |
- var_labels = "Time to Event",+ which_cols <- if (hr == 1) {
|
||
| 194 | -+ | |||
| 87 | +9x |
- show_labels = "visible",+ which(mat_strings[hr, ] == hdr_lbls[idx_hl]) |
||
| 195 | -+ | |||
| 88 | +13x |
- table_names = vars,+ } else { # for >2 col splits, only print labels for each unique combo of nested columns
|
||
| 196 | -+ | |||
| 89 | +4x |
- .stats = c("median", "median_ci", "quantiles", "range"),
+ which( |
||
| 197 | -+ | |||
| 90 | +4x |
- .formats = NULL,+ apply(mat_strings[1:hr, ], 2, function(x) all(x == hdr_lbls[1:hr, idx_hl])) |
||
| 198 | +91 |
- .labels = NULL,+ ) |
||
| 199 | +92 |
- .indent_mods = c(median_ci = 1L)) {
+ } |
||
| 200 | -3x | +93 | +13x |
- extra_args <- list(+ line_pos <- c( |
| 201 | -3x | +94 | +13x |
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str,+ sum(colwidths[1:(which_cols[1] - 1)]) + 1 + lbl_col_padding, |
| 202 | -3x | +95 | +13x |
- is_event = is_event, control = control, ref_fn_censor = ref_fn_censor, ...+ sum(colwidths[1:max(which_cols)]) - 1 + lbl_col_padding |
| 203 | +96 |
- )+ ) |
||
| 204 | +97 | |||
| 205 | -3x | +98 | +13x |
- analyze(+ res <- res + |
| 206 | -3x | +99 | +13x |
- lyt = lyt,+ annotate( |
| 207 | -3x | +100 | +13x |
- vars = vars,+ "text", |
| 208 | -3x | +101 | +13x |
- afun = a_surv_time,+ x = mean(line_pos), |
| 209 | -3x | +102 | +13x |
- var_labels = var_labels,+ y = nrow(mat_strings) + 1 - hr, |
| 210 | -3x | +103 | +13x |
- show_labels = show_labels,+ label = cur_lbl, |
| 211 | -3x | +104 | +13x |
- table_names = table_names,+ size = fontsize / .pt |
| 212 | -3x | +|||
| 105 | +
- na_str = na_str,+ ) + |
|||
| 213 | -3x | +106 | +13x |
- nested = nested,+ annotate( |
| 214 | -3x | +107 | +13x |
- extra_args = extra_args+ "segment", |
| 215 | -+ | |||
| 108 | +13x |
- )+ x = line_pos[1], |
||
| 216 | -+ | |||
| 109 | +13x |
- }+ xend = line_pos[2], |
| 1 | -+ | |||
| 110 | +13x |
- #' Control function for descriptive statistics+ y = nrow(mat_strings) - hr + 0.5, |
||
| 2 | -+ | |||
| 111 | +13x |
- #'+ yend = nrow(mat_strings) - hr + 0.5 |
||
| 3 | +112 |
- #' @description `r lifecycle::badge("stable")`
+ ) |
||
| 4 | +113 |
- #'+ } |
||
| 5 | +114 |
- #' Sets a list of parameters for summaries of descriptive statistics. Typically used internally to specify+ } |
||
| 6 | +115 |
- #' details for [s_summary()]. This function family is mainly used by [analyze_vars()].+ } |
||
| 7 | +116 |
- #'+ |
||
| 8 | +117 |
- #' @inheritParams argument_convention+ # Add table columns |
||
| 9 | -+ | |||
| 118 | +6x |
- #' @param quantiles (`numeric(2)`)\cr vector of length two to specify the quantiles to calculate.+ for (i in seq_len(ncol(tbl_df))) {
|
||
| 10 | -+ | |||
| 119 | +40x |
- #' @param quantile_type (`numeric(1)`)\cr number between 1 and 9 selecting quantile algorithms to be used.+ res <- res + annotate( |
||
| 11 | -+ | |||
| 120 | +40x |
- #' Default is set to 2 as this matches the default quantile algorithm in SAS `proc univariate` set by `QNTLDEF=5`.+ "text", |
||
| 12 | -+ | |||
| 121 | +40x |
- #' This differs from R's default. See more about `type` in [stats::quantile()].+ x = if (i == 1) 0 else sum(colwidths[1:i]) - 0.5 * colwidths[i] + lbl_col_padding, |
||
| 13 | -+ | |||
| 122 | +40x |
- #' @param test_mean (`numeric(1)`)\cr number to test against the mean under the null hypothesis when calculating+ y = rev(seq_len(nrow(tbl_df))), |
||
| 14 | -+ | |||
| 123 | +40x |
- #' p-value.+ label = tbl_df[, i], |
||
| 15 | -+ | |||
| 124 | +40x |
- #'+ hjust = mat_aligns[, i], |
||
| 16 | -+ | |||
| 125 | +40x |
- #' @return A list of components with the same names as the arguments.+ size = fontsize / .pt |
||
| 17 | +126 |
- #'+ ) |
||
| 18 | +127 |
- #' @export+ } |
||
| 19 | +128 |
- control_analyze_vars <- function(conf_level = 0.95,+ |
||
| 20 | -+ | |||
| 129 | +6x |
- quantiles = c(0.25, 0.75),+ res |
||
| 21 | +130 |
- quantile_type = 2,+ } |
||
| 22 | +131 |
- test_mean = 0) {
- |
- ||
| 23 | -1055x | -
- checkmate::assert_vector(quantiles, len = 2)- |
- ||
| 24 | -1055x | -
- checkmate::assert_int(quantile_type, lower = 1, upper = 9)- |
- ||
| 25 | -1055x | -
- checkmate::assert_numeric(test_mean)+ |
||
| 26 | -1055x | +|||
| 132 | +
- lapply(quantiles, assert_proportion_value)+ #' Convert `data.frame` object to `ggplot` object |
|||
| 27 | -1054x | +|||
| 133 | +
- assert_proportion_value(conf_level)+ #' |
|||
| 28 | -1053x | +|||
| 134 | +
- list(conf_level = conf_level, quantiles = quantiles, quantile_type = quantile_type, test_mean = test_mean)+ #' @description `r lifecycle::badge("experimental")`
|
|||
| 29 | +135 |
- }+ #' |
||
| 30 | +136 |
-
+ #' Given a `data.frame` object, performs basic conversion to a [ggplot2::ggplot()] object built using |
||
| 31 | +137 |
- #' Analyze variables+ #' functions from the `ggplot2` package. |
||
| 32 | +138 |
#' |
||
| 33 | +139 |
- #' @description `r lifecycle::badge("stable")`
+ #' @param df (`data.frame`)\cr a data frame. |
||
| 34 | +140 |
- #'+ #' @param colwidths (`numeric` or `NULL`)\cr a vector of column widths. Each element's position in |
||
| 35 | +141 |
- #' The analyze function [analyze_vars()] creates a layout element to summarize one or more variables, using the S3+ #' `colwidths` corresponds to the column of `df` in the same position. If `NULL`, column widths |
||
| 36 | +142 |
- #' generic function [s_summary()] to calculate a list of summary statistics. A list of all available statistics for+ #' are calculated according to maximum number of characters per column. |
||
| 37 | +143 |
- #' numeric variables can be viewed by running `get_stats("analyze_vars_numeric")` and for non-numeric variables by
+ #' @param font_size (`numeric(1)`)\cr font size. |
||
| 38 | +144 |
- #' running `get_stats("analyze_vars_counts")`. Use the `.stats` parameter to specify the statistics to include in your
+ #' @param col_labels (`flag`)\cr whether the column names (labels) of `df` should be used as the first row |
||
| 39 | +145 |
- #' output summary table.+ #' of the output table. |
||
| 40 | +146 |
- #'+ #' @param col_lab_fontface (`string`)\cr font face to apply to the first row (of column labels |
||
| 41 | +147 |
- #' @details+ #' if `col_labels = TRUE`). Defaults to `"bold"`. |
||
| 42 | +148 |
- #' **Automatic digit formatting:** The number of digits to display can be automatically determined from the analyzed+ #' @param hline (`flag`)\cr whether a horizontal line should be printed below the first row of the table. |
||
| 43 | +149 |
- #' variable(s) (`vars`) for certain statistics by setting the statistic format to `"auto"` in `.formats`.+ #' @param bg_fill (`string`)\cr table background fill color. |
||
| 44 | +150 |
- #' This utilizes the [format_auto()] formatting function. Note that only data for the current row & variable (for all+ #' |
||
| 45 | +151 |
- #' columns) will be considered (`.df_row[[.var]]`, see [`rtables::additional_fun_params`]) and not the whole dataset.+ #' @return A `ggplot` object. |
||
| 46 | +152 |
#' |
||
| 47 | +153 |
- #' @inheritParams argument_convention+ #' @examples |
||
| 48 | +154 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("analyze_vars_numeric")` to see
+ #' \dontrun{
|
||
| 49 | +155 |
- #' statistics available for numeric variables, and `get_stats("analyze_vars_counts")` for statistics available
+ #' df2gg(head(iris, 5)) |
||
| 50 | +156 |
- #' for non-numeric variables.+ #' |
||
| 51 | +157 |
- #'+ #' df2gg(head(iris, 5), font_size = 15, colwidths = c(1, 1, 1, 1, 1)) |
||
| 52 | +158 |
- #' @name analyze_variables+ #' } |
||
| 53 | +159 |
- #' @order 1+ #' @keywords internal |
||
| 54 | +160 |
- NULL+ df2gg <- function(df, |
||
| 55 | +161 |
-
+ colwidths = NULL, |
||
| 56 | +162 |
- #' @describeIn analyze_variables S3 generic function to produces a variable summary.+ font_size = 10, |
||
| 57 | +163 |
- #'+ col_labels = TRUE, |
||
| 58 | +164 |
- #' @return+ col_lab_fontface = "bold", |
||
| 59 | +165 |
- #' * `s_summary()` returns different statistics depending on the class of `x`.+ hline = TRUE, |
||
| 60 | +166 |
- #'+ bg_fill = NULL) {
|
||
| 61 | +167 |
- #' @export+ # convert to text |
||
| 62 | -+ | |||
| 168 | +19x |
- s_summary <- function(x,+ df <- as.data.frame(apply(df, 1:2, function(x) if (is.na(x)) "NA" else as.character(x))) |
||
| 63 | +169 |
- na.rm = TRUE, # nolint+ |
||
| 64 | -+ | |||
| 170 | +19x |
- denom,+ if (col_labels) {
|
||
| 65 | -+ | |||
| 171 | +10x |
- .N_row, # nolint+ df <- as.matrix(df)+ |
+ ||
| 172 | +10x | +
+ df <- rbind(colnames(df), df) |
||
| 66 | +173 |
- .N_col, # nolint+ } |
||
| 67 | +174 |
- .var,+ |
||
| 68 | +175 |
- ...) {
+ # Get column widths |
||
| 69 | -1559x | +176 | +19x |
- checkmate::assert_flag(na.rm)+ if (is.null(colwidths)) {
|
| 70 | -1559x | +177 | +1x |
- UseMethod("s_summary", x)
+ colwidths <- apply(df, 2, function(x) max(nchar(x), na.rm = TRUE)) |
| 71 | +178 |
- }+ }+ |
+ ||
| 179 | +19x | +
+ tot_width <- sum(colwidths) |
||
| 72 | +180 | |||
| 73 | -+ | |||
| 181 | +19x |
- #' @describeIn analyze_variables Method for `numeric` class.+ res <- ggplot(data = df) + |
||
| 74 | -+ | |||
| 182 | +19x |
- #'+ theme_void() + |
||
| 75 | -+ | |||
| 183 | +19x |
- #' @param control (`list`)\cr parameters for descriptive statistics details, specified by using+ scale_x_continuous(limits = c(0, tot_width)) + |
||
| 76 | -+ | |||
| 184 | +19x |
- #' the helper function [control_analyze_vars()]. Some possible parameter options are:+ scale_y_continuous(limits = c(1, nrow(df))) |
||
| 77 | +185 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for mean and median.+ |
||
| 78 | -+ | |||
| 186 | +9x |
- #' * `quantiles` (`numeric(2)`)\cr vector of length two to specify the quantiles.+ if (!is.null(bg_fill)) res <- res + theme(plot.background = element_rect(fill = bg_fill)) |
||
| 79 | +187 |
- #' * `quantile_type` (`numeric(1)`)\cr between 1 and 9 selecting quantile algorithms to be used.+ |
||
| 80 | -+ | |||
| 188 | +19x |
- #' See more about `type` in [stats::quantile()].+ if (hline) {
|
||
| 81 | -+ | |||
| 189 | +10x |
- #' * `test_mean` (`numeric(1)`)\cr value to test against the mean under the null hypothesis when calculating p-value.+ res <- res + |
||
| 82 | -+ | |||
| 190 | +10x |
- #'+ annotate( |
||
| 83 | -+ | |||
| 191 | +10x |
- #' @return+ "segment", |
||
| 84 | -+ | |||
| 192 | +10x |
- #' * If `x` is of class `numeric`, returns a `list` with the following named `numeric` items:+ x = 0 + 0.2 * colwidths[2], xend = tot_width - 0.1 * tail(colwidths, 1), |
||
| 85 | -+ | |||
| 193 | +10x |
- #' * `n`: The [length()] of `x`.+ y = nrow(df) - 0.5, yend = nrow(df) - 0.5 |
||
| 86 | +194 |
- #' * `sum`: The [sum()] of `x`.+ ) |
||
| 87 | +195 |
- #' * `mean`: The [mean()] of `x`.+ } |
||
| 88 | +196 |
- #' * `sd`: The [stats::sd()] of `x`.+ |
||
| 89 | -+ | |||
| 197 | +19x |
- #' * `se`: The standard error of `x` mean, i.e.: (`sd(x) / sqrt(length(x))`).+ for (i in seq_len(ncol(df))) {
|
||
| 90 | -+ | |||
| 198 | +86x |
- #' * `mean_sd`: The [mean()] and [stats::sd()] of `x`.+ line_pos <- c( |
||
| 91 | -+ | |||
| 199 | +86x |
- #' * `mean_se`: The [mean()] of `x` and its standard error (see above).+ if (i == 1) 0 else sum(colwidths[1:(i - 1)]), |
||
| 92 | -+ | |||
| 200 | +86x |
- #' * `mean_ci`: The CI for the mean of `x` (from [stat_mean_ci()]).+ sum(colwidths[1:i]) |
||
| 93 | +201 |
- #' * `mean_sei`: The SE interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()] / [sqrt()]).+ ) |
||
| 94 | -+ | |||
| 202 | +86x |
- #' * `mean_sdi`: The SD interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()]).+ res <- res + |
||
| 95 | -+ | |||
| 203 | +86x |
- #' * `mean_pval`: The two-sided p-value of the mean of `x` (from [stat_mean_pval()]).+ annotate( |
||
| 96 | -+ | |||
| 204 | +86x |
- #' * `median`: The [stats::median()] of `x`.+ "text", |
||
| 97 | -+ | |||
| 205 | +86x |
- #' * `mad`: The median absolute deviation of `x`, i.e.: ([stats::median()] of `xc`,+ x = mean(line_pos), |
||
| 98 | -+ | |||
| 206 | +86x |
- #' where `xc` = `x` - [stats::median()]).+ y = rev(seq_len(nrow(df))), |
||
| 99 | -+ | |||
| 207 | +86x |
- #' * `median_ci`: The CI for the median of `x` (from [stat_median_ci()]).+ label = df[, i], |
||
| 100 | -+ | |||
| 208 | +86x |
- #' * `quantiles`: Two sample quantiles of `x` (from [stats::quantile()]).+ size = font_size / .pt, |
||
| 101 | -+ | |||
| 209 | +86x |
- #' * `iqr`: The [stats::IQR()] of `x`.+ fontface = if (col_labels) {
|
||
| 102 | -+ | |||
| 210 | +32x |
- #' * `range`: The [range_noinf()] of `x`.+ c(col_lab_fontface, rep("plain", nrow(df) - 1))
|
||
| 103 | +211 |
- #' * `min`: The [max()] of `x`.+ } else {
|
||
| 104 | -+ | |||
| 212 | +54x |
- #' * `max`: The [min()] of `x`.+ rep("plain", nrow(df))
|
||
| 105 | +213 |
- #' * `median_range`: The [median()] and [range_noinf()] of `x`.+ } |
||
| 106 | +214 |
- #' * `cv`: The coefficient of variation of `x`, i.e.: ([stats::sd()] / [mean()] * 100).+ ) |
||
| 107 | +215 |
- #' * `geom_mean`: The geometric mean of `x`, i.e.: (`exp(mean(log(x)))`).+ } |
||
| 108 | +216 |
- #' * `geom_cv`: The geometric coefficient of variation of `x`, i.e.: (`sqrt(exp(sd(log(x)) ^ 2) - 1) * 100`).+ |
||
| 109 | -+ | |||
| 217 | +19x |
- #'+ res |
||
| 110 | +218 |
- #' @note+ } |
| 111 | +1 |
- #' * If `x` is an empty vector, `NA` is returned. This is the expected feature so as to return `rcell` content in+ #' Analyze numeric variables in columns |
||
| 112 | +2 |
- #' `rtables` when the intersection of a column and a row delimits an empty data selection.+ #' |
||
| 113 | +3 |
- #' * When the `mean` function is applied to an empty vector, `NA` will be returned instead of `NaN`, the latter+ #' @description `r lifecycle::badge("experimental")`
|
||
| 114 | +4 |
- #' being standard behavior in R.+ #' |
||
| 115 | +5 |
- #'+ #' The layout-creating function [analyze_vars_in_cols()] creates a layout element to generate a column-wise |
||
| 116 | +6 |
- #' @method s_summary numeric+ #' analysis table. |
||
| 117 | +7 |
#' |
||
| 118 | +8 |
- #' @examples+ #' This function sets the analysis methods as column labels and is a wrapper for [rtables::analyze_colvars()]. |
||
| 119 | +9 |
- #' # `s_summary.numeric`+ #' It was designed principally for PK tables. |
||
| 120 | +10 |
#' |
||
| 121 | +11 |
- #' ## Basic usage: empty numeric returns NA-filled items.+ #' @inheritParams argument_convention |
||
| 122 | +12 |
- #' s_summary(numeric())+ #' @inheritParams rtables::analyze_colvars |
||
| 123 | +13 |
- #'+ #' @param imp_rule (`string` or `NULL`)\cr imputation rule setting. Defaults to `NULL` for no imputation rule. Can |
||
| 124 | +14 |
- #' ## Management of NA values.+ #' also be `"1/3"` to implement 1/3 imputation rule or `"1/2"` to implement 1/2 imputation rule. In order |
||
| 125 | +15 |
- #' x <- c(NA_real_, 1)+ #' to use an imputation rule, the `avalcat_var` argument must be specified. See [imputation_rule()] |
||
| 126 | +16 |
- #' s_summary(x, na.rm = TRUE)+ #' for more details on imputation. |
||
| 127 | +17 |
- #' s_summary(x, na.rm = FALSE)+ #' @param avalcat_var (`string`)\cr if `imp_rule` is not `NULL`, name of variable that indicates whether a |
||
| 128 | +18 |
- #'+ #' row in the data corresponds to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of |
||
| 129 | +19 |
- #' x <- c(NA_real_, 1, 2)+ #' the above (defaults to `"AVALCAT1"`). Variable must be present in the data and should match the variable |
||
| 130 | +20 |
- #' s_summary(x, stats = NULL)+ #' used to calculate the `n_blq` statistic (if included in `.stats`). |
||
| 131 | +21 |
- #'+ #' @param cache (`flag`)\cr whether to store computed values in a temporary caching environment. This will |
||
| 132 | +22 |
- #' ## Benefits in `rtables` contructions:+ #' speed up calculations in large tables, but should be set to `FALSE` if the same `rtable` layout is |
||
| 133 | +23 |
- #' dta_test <- data.frame(+ #' used for multiple tables with different data. Defaults to `FALSE`. |
||
| 134 | +24 |
- #' Group = rep(LETTERS[1:3], each = 2),+ #' @param row_labels (`character`)\cr as this function works in columns space, usually `.labels` |
||
| 135 | +25 |
- #' sub_group = rep(letters[1:2], each = 3),+ #' character vector applies on the column space. You can change the row labels by defining this |
||
| 136 | +26 |
- #' x = 1:6+ #' parameter to a named character vector with names corresponding to the split values. It defaults |
||
| 137 | +27 |
- #' )+ #' to `NULL` and if it contains only one `string`, it will duplicate that as a row label. |
||
| 138 | +28 |
- #'+ #' @param do_summarize_row_groups (`flag`)\cr defaults to `FALSE` and applies the analysis to the current |
||
| 139 | +29 |
- #' ## The summary obtained in with `rtables`:+ #' label rows. This is a wrapper of [rtables::summarize_row_groups()] and it can accept `labelstr` |
||
| 140 | +30 |
- #' basic_table() %>%+ #' to define row labels. This behavior is not supported as we never need to overload row labels. |
||
| 141 | +31 |
- #' split_cols_by(var = "Group") %>%+ #' @param split_col_vars (`flag`)\cr defaults to `TRUE` and puts the analysis results onto the columns. |
||
| 142 | +32 |
- #' split_rows_by(var = "sub_group") %>%+ #' This option allows you to add multiple instances of this functions, also in a nested fashion, |
||
| 143 | +33 |
- #' analyze(vars = "x", afun = s_summary) %>%+ #' without adding more splits. This split must happen only one time on a single layout. |
||
| 144 | +34 |
- #' build_table(df = dta_test)+ #' |
||
| 145 | +35 |
- #'+ #' @return |
||
| 146 | +36 |
- #' ## By comparison with `lapply`:+ #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()]. |
||
| 147 | +37 |
- #' X <- split(dta_test, f = with(dta_test, interaction(Group, sub_group)))+ #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output |
||
| 148 | +38 |
- #' lapply(X, function(x) s_summary(x$x))+ #' in columns, and add it to the table layout. |
||
| 149 | +39 |
#' |
||
| 150 | +40 |
- #' @export+ #' @note |
||
| 151 | +41 |
- s_summary.numeric <- function(x,+ #' * This is an experimental implementation of [rtables::summarize_row_groups()] and [rtables::analyze_colvars()] |
||
| 152 | +42 |
- na.rm = TRUE, # nolint+ #' that may be subjected to changes as `rtables` extends its support to more complex analysis pipelines in the |
||
| 153 | +43 |
- denom,+ #' column space. We encourage users to read the examples carefully and file issues for different use cases. |
||
| 154 | +44 |
- .N_row, # nolint+ #' * In this function, `labelstr` behaves atypically. If `labelstr = NULL` (the default), row labels are assigned |
||
| 155 | +45 |
- .N_col, # nolint+ #' automatically as the split values if `do_summarize_row_groups = FALSE` (the default), and as the group label |
||
| 156 | +46 |
- .var,+ #' if `do_summarize_row_groups = TRUE`. |
||
| 157 | +47 |
- control = control_analyze_vars(),+ #' |
||
| 158 | +48 |
- ...) {
- |
- ||
| 159 | -1098x | -
- checkmate::assert_numeric(x)+ #' @seealso [analyze_vars()], [rtables::analyze_colvars()]. |
||
| 160 | +49 | - - | -||
| 161 | -1098x | -
- if (na.rm) {
- |
- ||
| 162 | -1096x | -
- x <- x[!is.na(x)]+ #' |
||
| 163 | +50 |
- }+ #' @examples |
||
| 164 | +51 | - - | -||
| 165 | -1098x | -
- y <- list()+ #' library(dplyr) |
||
| 166 | +52 | - - | -||
| 167 | -1098x | -
- y$n <- c("n" = length(x))
+ #' |
||
| 168 | +53 | - - | -||
| 169 | -1098x | -
- y$sum <- c("sum" = ifelse(length(x) == 0, NA_real_, sum(x, na.rm = FALSE)))
+ #' # Data preparation |
||
| 170 | +54 | - - | -||
| 171 | -1098x | -
- y$mean <- c("mean" = ifelse(length(x) == 0, NA_real_, mean(x, na.rm = FALSE)))
+ #' adpp <- tern_ex_adpp %>% h_pkparam_sort() |
||
| 172 | +55 | - - | -||
| 173 | -1098x | -
- y$sd <- c("sd" = stats::sd(x, na.rm = FALSE))
+ #' |
||
| 174 | +56 | - - | -||
| 175 | -1098x | -
- y$se <- c("se" = stats::sd(x, na.rm = FALSE) / sqrt(length(stats::na.omit(x))))
+ #' lyt <- basic_table() %>% |
||
| 176 | +57 | - - | -||
| 177 | -1098x | -
- y$mean_sd <- c(y$mean, "sd" = stats::sd(x, na.rm = FALSE))+ #' split_rows_by(var = "STRATA1", label_pos = "topleft") %>% |
||
| 178 | +58 | - - | -||
| 179 | -1098x | -
- y$mean_se <- c(y$mean, y$se)+ #' split_rows_by( |
||
| 180 | +59 | - - | -||
| 181 | -1098x | -
- mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE)- |
- ||
| 182 | -1098x | -
- y$mean_ci <- formatters::with_label(mean_ci, paste("Mean", f_conf_level(control$conf_level)))
+ #' var = "SEX", |
||
| 183 | +60 | - - | -||
| 184 | -1098x | -
- mean_sei <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE) / sqrt(y$n)- |
- ||
| 185 | -1098x | -
- names(mean_sei) <- c("mean_sei_lwr", "mean_sei_upr")
- |
- ||
| 186 | -1098x | -
- y$mean_sei <- formatters::with_label(mean_sei, "Mean -/+ 1xSE")+ #' label_pos = "topleft", |
||
| 187 | +61 | - - | -||
| 188 | -1098x | -
- mean_sdi <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE)- |
- ||
| 189 | -1098x | -
- names(mean_sdi) <- c("mean_sdi_lwr", "mean_sdi_upr")
+ #' child_labels = "hidden" |
||
| 190 | -1098x | +|||
| 62 | +
- y$mean_sdi <- formatters::with_label(mean_sdi, "Mean -/+ 1xSD")+ #' ) %>% # Removes duplicated labels |
|||
| 191 | +63 |
-
+ #' analyze_vars_in_cols(vars = "AGE") |
||
| 192 | -1098x | +|||
| 64 | +
- mean_pval <- stat_mean_pval(x, test_mean = control$test_mean, na.rm = FALSE, n_min = 2)+ #' result <- build_table(lyt = lyt, df = adpp) |
|||
| 193 | -1098x | +|||
| 65 | +
- y$mean_pval <- formatters::with_label(mean_pval, paste("Mean", f_pval(control$test_mean)))
+ #' result |
|||
| 194 | +66 |
-
+ #' |
||
| 195 | -1098x | +|||
| 67 | +
- y$median <- c("median" = stats::median(x, na.rm = FALSE))
+ #' # By selecting just some statistics and ad-hoc labels |
|||
| 196 | +68 |
-
+ #' lyt <- basic_table() %>% |
||
| 197 | -1098x | +|||
| 69 | +
- y$mad <- c("mad" = stats::median(x - y$median, na.rm = FALSE))
+ #' split_rows_by(var = "ARM", label_pos = "topleft") %>% |
|||
| 198 | +70 |
-
+ #' split_rows_by( |
||
| 199 | -1098x | +|||
| 71 | +
- median_ci <- stat_median_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE)+ #' var = "SEX", |
|||
| 200 | -1098x | +|||
| 72 | +
- y$median_ci <- formatters::with_label(median_ci, paste("Median", f_conf_level(control$conf_level)))
+ #' label_pos = "topleft", |
|||
| 201 | +73 |
-
+ #' child_labels = "hidden", |
||
| 202 | -1098x | +|||
| 74 | +
- q <- control$quantiles+ #' split_fun = drop_split_levels |
|||
| 203 | -1098x | +|||
| 75 | +
- if (any(is.na(x))) {
+ #' ) %>% |
|||
| 204 | -2x | +|||
| 76 | +
- qnts <- rep(NA_real_, length(q))+ #' analyze_vars_in_cols( |
|||
| 205 | +77 |
- } else {
+ #' vars = "AGE", |
||
| 206 | -1096x | +|||
| 78 | +
- qnts <- stats::quantile(x, probs = q, type = control$quantile_type, na.rm = FALSE)+ #' .stats = c("n", "cv", "geom_mean"),
|
|||
| 207 | +79 |
- }+ #' .labels = c( |
||
| 208 | -1098x | +|||
| 80 | +
- names(qnts) <- paste("quantile", q, sep = "_")
+ #' n = "aN", |
|||
| 209 | -1098x | +|||
| 81 | +
- y$quantiles <- formatters::with_label(qnts, paste0(paste(paste0(q * 100, "%"), collapse = " and "), "-ile"))+ #' cv = "aCV", |
|||
| 210 | +82 |
-
+ #' geom_mean = "aGeomMean" |
||
| 211 | -1098x | +|||
| 83 | +
- y$iqr <- c("iqr" = ifelse(
+ #' ) |
|||
| 212 | -1098x | +|||
| 84 | +
- any(is.na(x)),+ #' ) |
|||
| 213 | -1098x | +|||
| 85 | +
- NA_real_,+ #' result <- build_table(lyt = lyt, df = adpp) |
|||
| 214 | -1098x | +|||
| 86 | +
- stats::IQR(x, na.rm = FALSE, type = control$quantile_type)+ #' result |
|||
| 215 | +87 |
- ))+ #' |
||
| 216 | +88 |
-
+ #' # Changing row labels |
||
| 217 | -1098x | +|||
| 89 | +
- y$range <- stats::setNames(range_noinf(x, na.rm = FALSE), c("min", "max"))
+ #' lyt <- basic_table() %>% |
|||
| 218 | -1098x | +|||
| 90 | +
- y$min <- y$range[1]+ #' analyze_vars_in_cols( |
|||
| 219 | -1098x | +|||
| 91 | +
- y$max <- y$range[2]+ #' vars = "AGE", |
|||
| 220 | +92 |
-
+ #' row_labels = "some custom label" |
||
| 221 | -1098x | +|||
| 93 | +
- y$median_range <- formatters::with_label(c(y$median, y$range), "Median (Min - Max)")+ #' ) |
|||
| 222 | +94 |
-
+ #' result <- build_table(lyt, df = adpp) |
||
| 223 | -1098x | +|||
| 95 | +
- y$cv <- c("cv" = unname(y$sd) / unname(y$mean) * 100)
+ #' result |
|||
| 224 | +96 |
-
+ #' |
||
| 225 | +97 |
- # Convert negative values to NA for log calculation.+ #' # Pharmacokinetic parameters |
||
| 226 | -1098x | +|||
| 98 | +
- x_no_negative_vals <- x+ #' lyt <- basic_table() %>% |
|||
| 227 | -1098x | +|||
| 99 | +
- x_no_negative_vals[x_no_negative_vals <= 0] <- NA+ #' split_rows_by( |
|||
| 228 | -1098x | +|||
| 100 | +
- y$geom_mean <- c("geom_mean" = exp(mean(log(x_no_negative_vals), na.rm = FALSE)))
+ #' var = "TLG_DISPLAY", |
|||
| 229 | -1098x | +|||
| 101 | +
- geom_mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE, geom_mean = TRUE)+ #' split_label = "PK Parameter", |
|||
| 230 | -1098x | +|||
| 102 | +
- y$geom_mean_ci <- formatters::with_label(geom_mean_ci, paste("Geometric Mean", f_conf_level(control$conf_level)))
+ #' label_pos = "topleft", |
|||
| 231 | +103 |
-
+ #' child_labels = "hidden" |
||
| 232 | -1098x | +|||
| 104 | +
- y$geom_cv <- c("geom_cv" = sqrt(exp(stats::sd(log(x_no_negative_vals), na.rm = FALSE) ^ 2) - 1) * 100) # styler: off
+ #' ) %>% |
|||
| 233 | +105 |
-
+ #' analyze_vars_in_cols( |
||
| 234 | -1098x | +|||
| 106 | +
- y+ #' vars = "AVAL" |
|||
| 235 | +107 |
- }+ #' ) |
||
| 236 | +108 |
-
+ #' result <- build_table(lyt, df = adpp) |
||
| 237 | +109 |
- #' @describeIn analyze_variables Method for `factor` class.+ #' result |
||
| 238 | +110 |
#' |
||
| 239 | +111 |
- #' @param denom (`string`)\cr choice of denominator for factor proportions. Options are:+ #' # Multiple calls (summarize label and analyze underneath) |
||
| 240 | +112 |
- #' * `n`: number of values in this row and column intersection.+ #' lyt <- basic_table() %>% |
||
| 241 | +113 |
- #' * `N_row`: total number of values in this row across columns.+ #' split_rows_by( |
||
| 242 | +114 |
- #' * `N_col`: total number of values in this column across rows.+ #' var = "TLG_DISPLAY", |
||
| 243 | +115 |
- #'+ #' split_label = "PK Parameter", |
||
| 244 | +116 |
- #' @return+ #' label_pos = "topleft" |
||
| 245 | +117 |
- #' * If `x` is of class `factor` or converted from `character`, returns a `list` with named `numeric` items:+ #' ) %>% |
||
| 246 | +118 |
- #' * `n`: The [length()] of `x`.+ #' analyze_vars_in_cols( |
||
| 247 | +119 |
- #' * `count`: A list with the number of cases for each level of the factor `x`.+ #' vars = "AVAL", |
||
| 248 | +120 |
- #' * `count_fraction`: Similar to `count` but also includes the proportion of cases for each level of the+ #' do_summarize_row_groups = TRUE # does a summarize level |
||
| 249 | +121 |
- #' factor `x` relative to the denominator, or `NA` if the denominator is zero.+ #' ) %>% |
||
| 250 | +122 |
- #'+ #' split_rows_by("SEX",
|
||
| 251 | +123 |
- #' @note+ #' child_labels = "hidden", |
||
| 252 | +124 |
- #' * If `x` is an empty `factor`, a list is still returned for `counts` with one element+ #' label_pos = "topleft" |
||
| 253 | +125 |
- #' per factor level. If there are no levels in `x`, the function fails.+ #' ) %>% |
||
| 254 | +126 |
- #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values+ #' analyze_vars_in_cols( |
||
| 255 | +127 |
- #' set `na.rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit+ #' vars = "AVAL", |
||
| 256 | +128 |
- #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the+ #' split_col_vars = FALSE # avoids re-splitting the columns |
||
| 257 | +129 |
- #' default `na_level` (`"<Missing>"`) will also be excluded when `na.rm` is set to `TRUE`.+ #' ) |
||
| 258 | +130 |
- #'+ #' result <- build_table(lyt, df = adpp) |
||
| 259 | +131 |
- #' @method s_summary factor+ #' result |
||
| 260 | +132 |
#' |
||
| 261 | +133 |
- #' @examples+ #' @export |
||
| 262 | +134 |
- #' # `s_summary.factor`+ analyze_vars_in_cols <- function(lyt, |
||
| 263 | +135 |
- #'+ vars, |
||
| 264 | +136 |
- #' ## Basic usage:+ ..., |
||
| 265 | +137 |
- #' s_summary(factor(c("a", "a", "b", "c", "a")))
+ .stats = c( |
||
| 266 | +138 |
- #'+ "n", |
||
| 267 | +139 |
- #' # Empty factor returns zero-filled items.+ "mean", |
||
| 268 | +140 |
- #' s_summary(factor(levels = c("a", "b", "c")))
+ "sd", |
||
| 269 | +141 |
- #'+ "se", |
||
| 270 | +142 |
- #' ## Management of NA values.+ "cv", |
||
| 271 | +143 |
- #' x <- factor(c(NA, "Female"))+ "geom_cv" |
||
| 272 | +144 |
- #' x <- explicit_na(x)+ ), |
||
| 273 | +145 |
- #' s_summary(x, na.rm = TRUE)+ .labels = c( |
||
| 274 | +146 |
- #' s_summary(x, na.rm = FALSE)+ n = "n", |
||
| 275 | +147 |
- #'+ mean = "Mean", |
||
| 276 | +148 |
- #' ## Different denominators.+ sd = "SD", |
||
| 277 | +149 |
- #' x <- factor(c("a", "a", "b", "c", "a"))
+ se = "SE", |
||
| 278 | +150 |
- #' s_summary(x, denom = "N_row", .N_row = 10L)+ cv = "CV (%)", |
||
| 279 | +151 |
- #' s_summary(x, denom = "N_col", .N_col = 20L)+ geom_cv = "CV % Geometric Mean" |
||
| 280 | +152 |
- #'+ ), |
||
| 281 | +153 |
- #' @export+ row_labels = NULL, |
||
| 282 | +154 |
- s_summary.factor <- function(x,+ do_summarize_row_groups = FALSE, |
||
| 283 | +155 |
- na.rm = TRUE, # nolint+ split_col_vars = TRUE, |
||
| 284 | +156 |
- denom = c("n", "N_row", "N_col"),
+ imp_rule = NULL, |
||
| 285 | +157 |
- .N_row, # nolint+ avalcat_var = "AVALCAT1", |
||
| 286 | +158 |
- .N_col, # nolint+ cache = FALSE, |
||
| 287 | +159 |
- ...) {
- |
- ||
| 288 | -302x | -
- assert_valid_factor(x)- |
- ||
| 289 | -299x | -
- denom <- match.arg(denom)+ .indent_mods = NULL, |
||
| 290 | +160 | - - | -||
| 291 | -299x | -
- if (na.rm) {
- |
- ||
| 292 | -290x | -
- x <- x[!is.na(x)] %>% fct_discard("<Missing>")
+ na_str = default_na_str(), |
||
| 293 | +161 |
- } else {
- |
- ||
| 294 | -9x | -
- x <- x %>% explicit_na(label = "NA")+ nested = TRUE, |
||
| 295 | +162 |
- }+ .formats = NULL, |
||
| 296 | +163 |
-
+ .aligns = NULL) {
|
||
| 297 | -299x | +164 | +26x |
- y <- list()+ extra_args <- list(...) |
| 298 | +165 | |||
| 299 | -299x | +166 | +26x |
- y$n <- length(x)+ checkmate::assert_string(na_str, na.ok = TRUE, null.ok = TRUE) |
| 300 | -+ | |||
| 167 | +26x |
-
+ checkmate::assert_character(row_labels, null.ok = TRUE) |
||
| 301 | -299x | +168 | +26x |
- y$count <- as.list(table(x, useNA = "ifany"))+ checkmate::assert_int(.indent_mods, null.ok = TRUE) |
| 302 | -299x | +169 | +26x |
- dn <- switch(denom,+ checkmate::assert_flag(nested) |
| 303 | -299x | +170 | +26x |
- n = length(x),+ checkmate::assert_flag(split_col_vars) |
| 304 | -299x | +171 | +26x |
- N_row = .N_row,+ checkmate::assert_flag(do_summarize_row_groups) |
| 305 | -299x | +|||
| 172 | +
- N_col = .N_col+ |
|||
| 306 | +173 |
- )+ # Filtering |
||
| 307 | -299x | +174 | +26x |
- y$count_fraction <- lapply(+ met_grps <- paste0("analyze_vars", c("_numeric", "_counts"))
|
| 308 | -299x | +175 | +26x |
- y$count,+ .stats <- get_stats(met_grps, stats_in = .stats) |
| 309 | -299x | +176 | +26x |
- function(x) {
+ formats_v <- get_formats_from_stats(stats = .stats, formats_in = .formats) |
| 310 | -2172x | +177 | +26x |
- c(x, ifelse(dn > 0, x / dn, 0))+ 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)
|
||
| 311 | +179 |
- }+ |
||
| 312 | +180 |
- )+ # Check for vars in the case that one or more are used |
||
| 313 | -299x | +181 | +26x |
- y$fraction <- lapply(+ if (length(vars) == 1) {
|
| 314 | -299x | +182 | +21x |
- y$count,+ vars <- rep(vars, length(.stats)) |
| 315 | -299x | +183 | +5x |
- function(count) c("num" = count, "denom" = dn)
+ } else if (length(vars) != length(.stats)) {
|
| 316 | -+ | |||
| 184 | +1x |
- )+ stop( |
||
| 317 | -+ | |||
| 185 | +1x |
-
+ "Analyzed variables (vars) does not have the same ", |
||
| 318 | -299x | +186 | +1x |
- y$n_blq <- sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", x))
+ "number of elements of specified statistics (.stats)." |
| 319 | +187 | - - | -||
| 320 | -299x | -
- y+ ) |
||
| 321 | +188 |
- }+ } |
||
| 322 | +189 | |||
| 323 | -+ | |||
| 190 | +25x |
- #' @describeIn analyze_variables Method for `character` class. This makes an automatic+ if (split_col_vars) {
|
||
| 324 | +191 |
- #' conversion to factor (with a warning) and then forwards to the method for factors.+ # Checking there is not a previous identical column split |
||
| 325 | -+ | |||
| 192 | +21x |
- #'+ clyt <- tail(clayout(lyt), 1)[[1]] |
||
| 326 | +193 |
- #' @param verbose (`flag`)\cr defaults to `TRUE`, which prints out warnings and messages. It is mainly used+ |
||
| 327 | -+ | |||
| 194 | +21x |
- #' to print out information about factor casting.+ dummy_lyt <- split_cols_by_multivar( |
||
| 328 | -+ | |||
| 195 | +21x |
- #'+ lyt = basic_table(), |
||
| 329 | -+ | |||
| 196 | +21x |
- #' @note+ vars = vars, |
||
| 330 | -+ | |||
| 197 | +21x |
- #' * Automatic conversion of character to factor does not guarantee that the table+ varlabels = labels_v |
||
| 331 | +198 |
- #' can be generated correctly. In particular for sparse tables this very likely can fail.+ ) |
||
| 332 | +199 |
- #' It is therefore better to always pre-process the dataset such that factors are manually+ |
||
| 333 | -+ | |||
| 200 | +21x |
- #' created from character variables before passing the dataset to [rtables::build_table()].+ if (any(sapply(clyt, identical, y = get_last_col_split(dummy_lyt)))) {
|
||
| 334 | -+ | |||
| 201 | +2x |
- #'+ stop( |
||
| 335 | -+ | |||
| 202 | +2x |
- #' @method s_summary character+ "Column split called again with the same values. ", |
||
| 336 | -+ | |||
| 203 | +2x |
- #'+ "This can create many unwanted columns. Please consider adding ", |
||
| 337 | -+ | |||
| 204 | +2x |
- #' @examples+ "split_col_vars = FALSE to the last call of ", |
||
| 338 | -+ | |||
| 205 | +2x |
- #' # `s_summary.character`+ deparse(sys.calls()[[sys.nframe() - 1]]), "." |
||
| 339 | +206 |
- #'+ ) |
||
| 340 | +207 |
- #' ## Basic usage:+ } |
||
| 341 | +208 |
- #' s_summary(c("a", "a", "b", "c", "a"), .var = "x", verbose = FALSE)
+
|
||
| 342 | +209 |
- #' s_summary(c("a", "a", "b", "c", "a", ""), .var = "x", na.rm = FALSE, verbose = FALSE)
+ # Main col split |
||
| 343 | -+ | |||
| 210 | +19x |
- #'+ lyt <- split_cols_by_multivar( |
||
| 344 | -+ | |||
| 211 | +19x |
- #' @export+ lyt = lyt, |
||
| 345 | -+ | |||
| 212 | +19x |
- s_summary.character <- function(x,+ vars = vars, |
||
| 346 | -+ | |||
| 213 | +19x |
- na.rm = TRUE, # nolint+ varlabels = labels_v |
||
| 347 | +214 |
- denom = c("n", "N_row", "N_col"),
+ ) |
||
| 348 | +215 |
- .N_row, # nolint+ } |
||
| 349 | +216 |
- .N_col, # nolint+ |
||
| 350 | -+ | |||
| 217 | +23x |
- .var,+ env <- new.env() # create caching environment |
||
| 351 | +218 |
- verbose = TRUE,+ |
||
| 352 | -+ | |||
| 219 | +23x |
- ...) {
+ if (do_summarize_row_groups) {
|
||
| 353 | +220 | 8x |
- if (na.rm) {
+ if (length(unique(vars)) > 1) {
|
|
| 354 | -7x | +|||
| 221 | +! |
- y <- as_factor_keep_attributes(x, verbose = verbose)+ stop("When using do_summarize_row_groups only one label level var should be inserted.")
|
||
| 355 | +222 |
- } else {
- |
- ||
| 356 | -1x | -
- y <- as_factor_keep_attributes(x, verbose = verbose, na_level = "NA")+ } |
||
| 357 | +223 |
- }+ |
||
| 358 | +224 |
-
+ # Function list for do_summarize_row_groups. Slightly different handling of labels |
||
| 359 | +225 | 8x |
- s_summary(+ cfun_list <- Map( |
|
| 360 | +226 | 8x |
- x = y,+ function(stat, use_cache, cache_env) {
|
|
| 361 | -8x | +227 | +48x |
- na.rm = na.rm,+ function(u, .spl_context, labelstr, .df_row, ...) {
|
| 362 | -8x | +|||
| 228 | +
- denom = denom,+ # Statistic |
|||
| 363 | -8x | +229 | +152x |
- .N_row = .N_row,+ var_row_val <- paste( |
| 364 | -8x | +230 | +152x |
- .N_col = .N_col,+ gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
|
| 365 | -+ | |||
| 231 | +152x |
- ...+ paste(.spl_context$value, collapse = "_"), |
||
| 366 | -+ | |||
| 232 | +152x |
- )+ sep = "_" |
||
| 367 | +233 |
- }+ ) |
||
| 368 | -+ | |||
| 234 | +152x |
-
+ if (use_cache) {
|
||
| 369 | -+ | |||
| 235 | +! |
- #' @describeIn analyze_variables Method for `logical` class.+ if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...) |
||
| 370 | -+ | |||
| 236 | +! |
- #'+ x_stats <- cache_env[[var_row_val]] |
||
| 371 | +237 |
- #' @param denom (`string`)\cr choice of denominator for proportion. Options are:+ } else {
|
||
| 372 | -+ | |||
| 238 | +152x |
- #' * `n`: number of values in this row and column intersection.+ x_stats <- s_summary(u, ...) |
||
| 373 | +239 |
- #' * `N_row`: total number of values in this row across columns.+ } |
||
| 374 | +240 |
- #' * `N_col`: total number of values in this column across rows.+ |
||
| 375 | -+ | |||
| 241 | +152x |
- #'+ if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
|
||
| 376 | -+ | |||
| 242 | +152x |
- #' @return+ res <- x_stats[[stat]] |
||
| 377 | +243 |
- #' * If `x` is of class `logical`, returns a `list` with named `numeric` items:+ } else {
|
||
| 378 | -+ | |||
| 244 | +! |
- #' * `n`: The [length()] of `x` (possibly after removing `NA`s).+ timept <- as.numeric(gsub(".*?([0-9\\.]+).*", "\\1", tail(.spl_context$value, 1)))
|
||
| 379 | -+ | |||
| 245 | +! |
- #' * `count`: Count of `TRUE` in `x`.+ res_imp <- imputation_rule( |
||
| 380 | -+ | |||
| 246 | +! |
- #' * `count_fraction`: Count and proportion of `TRUE` in `x` relative to the denominator, or `NA` if the+ .df_row, x_stats, stat, |
||
| 381 | -+ | |||
| 247 | +! |
- #' denominator is zero. Note that `NA`s in `x` are never counted or leading to `NA` here.+ imp_rule = imp_rule, |
||
| 382 | -+ | |||
| 248 | +! |
- #'+ post = grepl("Predose", tail(.spl_context$value, 1)) || timept > 0,
|
||
| 383 | -+ | |||
| 249 | +! |
- #' @method s_summary logical+ avalcat_var = avalcat_var |
||
| 384 | +250 |
- #'+ ) |
||
| 385 | -+ | |||
| 251 | +! |
- #' @examples+ res <- res_imp[["val"]] |
||
| 386 | -+ | |||
| 252 | +! |
- #' # `s_summary.logical`+ na_str <- res_imp[["na_str"]] |
||
| 387 | +253 |
- #'+ } |
||
| 388 | +254 |
- #' ## Basic usage:+ |
||
| 389 | +255 |
- #' s_summary(c(TRUE, FALSE, TRUE, TRUE))+ # Label check and replacement |
||
| 390 | -+ | |||
| 256 | +152x |
- #'+ if (length(row_labels) > 1) {
|
||
| 391 | -+ | |||
| 257 | +32x |
- #' # Empty factor returns zero-filled items.+ if (!(labelstr %in% names(row_labels))) {
|
||
| 392 | -+ | |||
| 258 | +2x |
- #' s_summary(as.logical(c()))+ stop( |
||
| 393 | -+ | |||
| 259 | +2x |
- #'+ "Replacing the labels in do_summarize_row_groups needs a named vector", |
||
| 394 | -+ | |||
| 260 | +2x |
- #' ## Management of NA values.+ "that contains the split values. In the current split variable ", |
||
| 395 | -+ | |||
| 261 | +2x |
- #' x <- c(NA, TRUE, FALSE)+ .spl_context$split[nrow(.spl_context)], |
||
| 396 | -+ | |||
| 262 | +2x |
- #' s_summary(x, na.rm = TRUE)+ " the labelstr value (split value by default) ", labelstr, " is not in", |
||
| 397 | -+ | |||
| 263 | +2x |
- #' s_summary(x, na.rm = FALSE)+ " row_labels names: ", names(row_labels) |
||
| 398 | +264 |
- #'+ ) |
||
| 399 | +265 |
- #' ## Different denominators.+ } |
||
| 400 | -+ | |||
| 266 | +30x |
- #' x <- c(TRUE, FALSE, TRUE, TRUE)+ lbl <- unlist(row_labels[labelstr]) |
||
| 401 | +267 |
- #' s_summary(x, denom = "N_row", .N_row = 10L)+ } else {
|
||
| 402 | -+ | |||
| 268 | +120x |
- #' s_summary(x, denom = "N_col", .N_col = 20L)+ lbl <- labelstr |
||
| 403 | +269 |
- #'+ } |
||
| 404 | +270 |
- #' @export+ |
||
| 405 | +271 |
- s_summary.logical <- function(x,+ # Cell creation |
||
| 406 | -+ | |||
| 272 | +150x |
- na.rm = TRUE, # nolint+ rcell(res, |
||
| 407 | -+ | |||
| 273 | +150x |
- denom = c("n", "N_row", "N_col"),
+ label = lbl, |
||
| 408 | -+ | |||
| 274 | +150x |
- .N_row, # nolint+ format = formats_v[names(formats_v) == stat][[1]], |
||
| 409 | -+ | |||
| 275 | +150x |
- .N_col, # nolint+ format_na_str = na_str, |
||
| 410 | -+ | |||
| 276 | +150x |
- ...) {
+ indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods), |
||
| 411 | -184x | +277 | +150x |
- denom <- match.arg(denom)+ align = .aligns |
| 412 | -182x | +|||
| 278 | +
- if (na.rm) x <- x[!is.na(x)]+ ) |
|||
| 413 | -184x | +|||
| 279 | +
- y <- list()+ } |
|||
| 414 | -184x | +|||
| 280 | +
- y$n <- length(x)+ }, |
|||
| 415 | -184x | +281 | +8x |
- count <- sum(x, na.rm = TRUE)+ stat = .stats, |
| 416 | -184x | +282 | +8x |
- dn <- switch(denom,+ use_cache = cache, |
| 417 | -184x | +283 | +8x |
- n = length(x),+ cache_env = replicate(length(.stats), env) |
| 418 | -184x | +|||
| 284 | +
- N_row = .N_row,+ ) |
|||
| 419 | -184x | +|||
| 285 | +
- N_col = .N_col+ |
|||
| 420 | +286 |
- )+ # Main call to rtables |
||
| 421 | -184x | +287 | +8x |
- y$count <- count+ summarize_row_groups( |
| 422 | -184x | +288 | +8x |
- y$count_fraction <- c(count, ifelse(dn > 0, count / dn, 0))+ lyt = lyt, |
| 423 | -184x | +289 | +8x |
- y$n_blq <- 0L+ var = unique(vars), |
| 424 | -184x | +290 | +8x |
- y+ cfun = cfun_list, |
| 425 | -+ | |||
| 291 | +8x |
- }+ na_str = na_str, |
||
| 426 | -+ | |||
| 292 | +8x |
-
+ extra_args = extra_args |
||
| 427 | +293 |
- #' @describeIn analyze_variables Formatted analysis function which is used as `afun` in `analyze_vars()` and+ ) |
||
| 428 | +294 |
- #' `compare_vars()` and as `cfun` in `summarize_colvars()`.+ } else {
|
||
| 429 | +295 |
- #'+ # Function list for analyze_colvars |
||
| 430 | -+ | |||
| 296 | +15x |
- #' @param compare (`flag`)\cr whether comparison statistics should be analyzed instead of summary statistics+ afun_list <- Map( |
||
| 431 | -+ | |||
| 297 | +15x |
- #' (`compare = TRUE` adds `pval` statistic comparing against reference group).+ function(stat, use_cache, cache_env) {
|
||
| 432 | -+ | |||
| 298 | +76x |
- #'+ function(u, .spl_context, .df_row, ...) {
|
||
| 433 | +299 |
- #' @return+ # Main statistics |
||
| 434 | -+ | |||
| 300 | +468x |
- #' * `a_summary()` returns the corresponding list with formatted [rtables::CellValue()].+ var_row_val <- paste( |
||
| 435 | -+ | |||
| 301 | +468x |
- #'+ gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
|
||
| 436 | -+ | |||
| 302 | +468x |
- #' @note+ paste(.spl_context$value, collapse = "_"), |
||
| 437 | -+ | |||
| 303 | +468x |
- #' * To use for comparison (with additional p-value statistic), parameter `compare` must be set to `TRUE`.+ sep = "_" |
||
| 438 | +304 |
- #' * Ensure that either all `NA` values are converted to an explicit `NA` level or all `NA` values are left as is.+ ) |
||
| 439 | -+ | |||
| 305 | +468x |
- #'+ if (use_cache) {
|
||
| 440 | -+ | |||
| 306 | +16x |
- #' @examples+ if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...) |
||
| 441 | -+ | |||
| 307 | +56x |
- #' a_summary(factor(c("a", "a", "b", "c", "a")), .N_row = 10, .N_col = 10)
+ x_stats <- cache_env[[var_row_val]] |
||
| 442 | +308 |
- #' a_summary(+ } else {
|
||
| 443 | -+ | |||
| 309 | +412x |
- #' factor(c("a", "a", "b", "c", "a")),
+ x_stats <- s_summary(u, ...) |
||
| 444 | +310 |
- #' .ref_group = factor(c("a", "a", "b", "c")), compare = TRUE
+ } |
||
| 445 | +311 |
- #' )+ |
||
| 446 | -+ | |||
| 312 | +468x |
- #'+ if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
|
||
| 447 | -+ | |||
| 313 | +348x |
- #' a_summary(c("A", "B", "A", "C"), .var = "x", .N_col = 10, .N_row = 10, verbose = FALSE)
+ res <- x_stats[[stat]] |
||
| 448 | +314 |
- #' a_summary(+ } else {
|
||
| 449 | -+ | |||
| 315 | +120x |
- #' c("A", "B", "A", "C"),
+ timept <- as.numeric(gsub(".*?([0-9\\.]+).*", "\\1", tail(.spl_context$value, 1)))
|
||
| 450 | -+ | |||
| 316 | +120x |
- #' .ref_group = c("B", "A", "C"), .var = "x", compare = TRUE, verbose = FALSE
+ res_imp <- imputation_rule( |
||
| 451 | -+ | |||
| 317 | +120x |
- #' )+ .df_row, x_stats, stat, |
||
| 452 | -+ | |||
| 318 | +120x |
- #'+ imp_rule = imp_rule, |
||
| 453 | -+ | |||
| 319 | +120x |
- #' a_summary(c(TRUE, FALSE, FALSE, TRUE, TRUE), .N_row = 10, .N_col = 10)+ post = grepl("Predose", tail(.spl_context$value, 1)) || timept > 0,
|
||
| 454 | -+ | |||
| 320 | +120x |
- #' a_summary(+ avalcat_var = avalcat_var |
||
| 455 | +321 |
- #' c(TRUE, FALSE, FALSE, TRUE, TRUE),+ ) |
||
| 456 | -+ | |||
| 322 | +120x |
- #' .ref_group = c(TRUE, FALSE), .in_ref_col = TRUE, compare = TRUE+ res <- res_imp[["val"]] |
||
| 457 | -+ | |||
| 323 | +120x |
- #' )+ na_str <- res_imp[["na_str"]] |
||
| 458 | +324 |
- #'+ } |
||
| 459 | +325 |
- #' a_summary(rnorm(10), .N_col = 10, .N_row = 20, .var = "bla")+ |
||
| 460 | -+ | |||
| 326 | +468x |
- #' a_summary(rnorm(10, 5, 1), .ref_group = rnorm(20, -5, 1), .var = "bla", compare = TRUE)+ if (is.list(res)) {
|
||
| 461 | -+ | |||
| 327 | +19x |
- #'+ if (length(res) > 1) {
|
||
| 462 | -+ | |||
| 328 | +1x |
- #' @export+ stop("The analyzed column produced more than one category of results.")
|
||
| 463 | +329 |
- a_summary <- function(x,+ } else {
|
||
| 464 | -+ | |||
| 330 | +18x |
- .N_col, # nolint+ res <- unlist(res) |
||
| 465 | +331 |
- .N_row, # nolint+ } |
||
| 466 | +332 |
- .var = NULL,+ } |
||
| 467 | +333 |
- .df_row = NULL,+ |
||
| 468 | +334 |
- .ref_group = NULL,+ # Label from context |
||
| 469 | -+ | |||
| 335 | +467x |
- .in_ref_col = FALSE,+ label_from_context <- .spl_context$value[nrow(.spl_context)] |
||
| 470 | +336 |
- compare = FALSE,+ |
||
| 471 | +337 |
- .stats = NULL,+ # Label switcher |
||
| 472 | -+ | |||
| 338 | +467x |
- .formats = NULL,+ if (is.null(row_labels)) {
|
||
| 473 | -+ | |||
| 339 | +387x |
- .labels = NULL,+ lbl <- label_from_context |
||
| 474 | +340 |
- .indent_mods = NULL,+ } else {
|
||
| 475 | -+ | |||
| 341 | +80x |
- na.rm = TRUE, # nolint+ if (length(row_labels) > 1) {
|
||
| 476 | -+ | |||
| 342 | +68x |
- na_str = default_na_str(),+ if (!(label_from_context %in% names(row_labels))) {
|
||
| 477 | -+ | |||
| 343 | +2x |
- ...) {
+ stop( |
||
| 478 | -324x | +344 | +2x |
- extra_args <- list(...)+ "Replacing the labels in do_summarize_row_groups needs a named vector", |
| 479 | -324x | +345 | +2x |
- if (is.numeric(x)) {
+ "that contains the split values. In the current split variable ", |
| 480 | -86x | +346 | +2x |
- type <- "numeric"+ .spl_context$split[nrow(.spl_context)], |
| 481 | -86x | +347 | +2x |
- if (!is.null(.stats) && any(grepl("^pval", .stats))) {
+ " the split value ", label_from_context, " is not in", |
| 482 | -10x | +348 | +2x |
- .stats[grepl("^pval", .stats)] <- "pval" # tmp fix xxx
+ " row_labels names: ", names(row_labels) |
| 483 | +349 |
- }+ ) |
||
| 484 | +350 |
- } else {
+ } |
||
| 485 | -238x | +351 | +66x |
- type <- "counts"+ lbl <- unlist(row_labels[label_from_context]) |
| 486 | -238x | +|||
| 352 | +
- if (!is.null(.stats) && any(grepl("^pval", .stats))) {
+ } else {
|
|||
| 487 | -9x | +353 | +12x |
- .stats[grepl("^pval", .stats)] <- "pval_counts" # tmp fix xxx
+ lbl <- row_labels |
| 488 | +354 |
- }+ } |
||
| 489 | +355 |
- }+ } |
||
| 490 | +356 | |||
| 491 | -- |
- # If one col has NA vals, must add NA row to other cols (using placeholder lvl `fill-na-level`)- |
- ||
| 492 | -! | -
- if (any(is.na(.df_row[[.var]])) && !any(is.na(x)) && !na.rm) levels(x) <- c(levels(x), "fill-na-level")- |
- ||
| 493 | +357 |
-
+ # Cell creation |
||
| 494 | -324x | +358 | +465x |
- x_stats <- if (!compare) {
+ rcell(res, |
| 495 | -300x | +359 | +465x |
- s_summary(x = x, .N_col = .N_col, .N_row = .N_row, na.rm = na.rm, ...)+ label = lbl, |
| 496 | -+ | |||
| 360 | +465x |
- } else {
+ format = formats_v[names(formats_v) == stat][[1]], |
||
| 497 | -24x | +361 | +465x |
- s_compare(+ format_na_str = na_str, |
| 498 | -24x | +362 | +465x |
- x = x, .N_col = .N_col, .N_row = .N_row, na.rm = na.rm, .ref_group = .ref_group, .in_ref_col = .in_ref_col, ...+ indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods), |
| 499 | -+ | |||
| 363 | +465x |
- )+ align = .aligns |
||
| 500 | +364 |
- }+ ) |
||
| 501 | +365 |
-
+ } |
||
| 502 | +366 |
- # Fill in with formatting defaults if needed+ }, |
||
| 503 | -324x | +367 | +15x |
- met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ stat = .stats, |
| 504 | -324x | +368 | +15x |
- .stats <- get_stats(met_grp, stats_in = .stats, add_pval = compare)+ use_cache = cache, |
| 505 | -324x | +369 | +15x |
- .formats <- get_formats_from_stats(.stats, .formats)+ cache_env = replicate(length(.stats), env) |
| 506 | -324x | +|||
| 370 | +
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods)+ ) |
|||
| 507 | +371 | |||
| 508 | -324x | -
- lbls <- get_labels_from_stats(.stats, .labels)- |
- ||
| 509 | +372 |
- # Check for custom labels from control_analyze_vars+ # Main call to rtables |
||
| 510 | -324x | +373 | +15x |
- .labels <- if ("control" %in% names(extra_args)) {
+ analyze_colvars(lyt, |
| 511 | -1x | +374 | +15x |
- lbls %>% labels_use_control(extra_args[["control"]], .labels)+ afun = afun_list, |
| 512 | -+ | |||
| 375 | +15x |
- } else {
+ na_str = na_str, |
||
| 513 | -323x | +376 | +15x |
- lbls+ nested = nested, |
| 514 | -+ | |||
| 377 | +15x |
- }+ extra_args = extra_args |
||
| 515 | +378 |
-
+ ) |
||
| 516 | -11x | +|||
| 379 | +
- if ("count_fraction_fixed_dp" %in% .stats) x_stats[["count_fraction_fixed_dp"]] <- x_stats[["count_fraction"]]
+ } |
|||
| 517 | -324x | +|||
| 380 | +
- x_stats <- x_stats[.stats]+ } |
|||
| 518 | +381 | |||
| 519 | -324x | -
- if (is.factor(x) || is.character(x)) {
- |
- ||
| 520 | +382 |
- # Ungroup statistics with values for each level of x- |
- ||
| 521 | -234x | -
- x_ungrp <- ungroup_stats(x_stats, .formats, .labels, .indent_mods)- |
- ||
| 522 | -234x | -
- x_stats <- x_ungrp[["x"]]+ # Helper function |
||
| 523 | -234x | +|||
| 383 | +
- .formats <- x_ungrp[[".formats"]]+ get_last_col_split <- function(lyt) {
|
|||
| 524 | -234x | +384 | +3x |
- .labels <- gsub("fill-na-level", "NA", x_ungrp[[".labels"]])
+ tail(tail(clayout(lyt), 1)[[1]], 1)[[1]] |
| 525 | -234x | +|||
| 385 | +
- .indent_mods <- x_ungrp[[".indent_mods"]]+ } |
| 526 | +1 |
- }+ #' Encode categorical missing values in a data frame |
||
| 527 | +2 |
-
+ #' |
||
| 528 | +3 |
- # Auto format handling+ #' @description `r lifecycle::badge("stable")`
|
||
| 529 | -324x | +|||
| 4 | +
- .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)+ #' |
|||
| 530 | +5 |
-
+ #' This is a helper function to encode missing entries across groups of categorical |
||
| 531 | -324x | +|||
| 6 | +
- in_rows(+ #' variables in a data frame. |
|||
| 532 | -324x | +|||
| 7 | +
- .list = x_stats,+ #' |
|||
| 533 | -324x | +|||
| 8 | +
- .formats = .formats,+ #' @details Missing entries are those with `NA` or empty strings and will |
|||
| 534 | -324x | +|||
| 9 | +
- .names = names(.labels),+ #' be replaced with a specified value. If factor variables include missing |
|||
| 535 | -324x | +|||
| 10 | +
- .labels = .labels,+ #' values, the missing value will be inserted as the last level. |
|||
| 536 | -324x | +|||
| 11 | +
- .indent_mods = .indent_mods,+ #' Similarly, in case character or logical variables should be converted to factors |
|||
| 537 | -324x | +|||
| 12 | +
- .format_na_strs = na_str+ #' with the `char_as_factor` or `logical_as_factor` options, the missing values will |
|||
| 538 | +13 |
- )+ #' be set as the last level. |
||
| 539 | +14 |
- }+ #' |
||
| 540 | +15 |
-
+ #' @param data (`data.frame`)\cr data set. |
||
| 541 | +16 |
- #' @describeIn analyze_variables Layout-creating function which can take statistics function arguments+ #' @param omit_columns (`character`)\cr names of variables from `data` that should |
||
| 542 | +17 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' not be modified by this function. |
||
| 543 | +18 |
- #'+ #' @param char_as_factor (`flag`)\cr whether to convert character variables |
||
| 544 | +19 |
- #' @param ... arguments passed to `s_summary()`.+ #' in `data` to factors. |
||
| 545 | +20 |
- #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector+ #' @param logical_as_factor (`flag`)\cr whether to convert logical variables |
||
| 546 | +21 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ #' in `data` to factors. |
||
| 547 | +22 |
- #' for that statistic's row label.+ #' @param na_level (`string`)\cr string used to replace all `NA` or empty |
||
| 548 | +23 |
- #'+ #' values inside non-`omit_columns` columns. |
||
| 549 | +24 |
- #' @return+ #' |
||
| 550 | +25 |
- #' * `analyze_vars()` returns a layout object suitable for passing to further layouting functions,+ #' @return A `data.frame` with the chosen modifications applied. |
||
| 551 | +26 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 552 | +27 |
- #' the statistics from `s_summary()` to the table layout.+ #' @seealso [sas_na()] and [explicit_na()] for other missing data helper functions. |
||
| 553 | +28 |
#' |
||
| 554 | +29 |
#' @examples |
||
| 555 | +30 |
- #' ## Fabricated dataset.+ #' my_data <- data.frame( |
||
| 556 | +31 |
- #' dta_test <- data.frame(+ #' u = c(TRUE, FALSE, NA, TRUE), |
||
| 557 | +32 |
- #' USUBJID = rep(1:6, each = 3),+ #' v = factor(c("A", NA, NA, NA), levels = c("Z", "A")),
|
||
| 558 | +33 |
- #' PARAMCD = rep("lab", 6 * 3),
+ #' w = c("A", "B", NA, "C"),
|
||
| 559 | +34 |
- #' AVISIT = rep(paste0("V", 1:3), 6),
+ #' x = c("D", "E", "F", NA),
|
||
| 560 | +35 |
- #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ #' y = c("G", "H", "I", ""),
|
||
| 561 | +36 |
- #' AVAL = c(9:1, rep(NA, 9))+ #' z = c(1, 2, 3, 4), |
||
| 562 | +37 |
- #' )+ #' stringsAsFactors = FALSE |
||
| 563 | +38 |
- #'+ #' ) |
||
| 564 | +39 |
- #' # `analyze_vars()` in `rtables` pipelines+ #' |
||
| 565 | +40 |
- #' ## Default output within a `rtables` pipeline.+ #' # Example 1 |
||
| 566 | +41 |
- #' l <- basic_table() %>%+ #' # Encode missing values in all character or factor columns. |
||
| 567 | +42 |
- #' split_cols_by(var = "ARM") %>%+ #' df_explicit_na(my_data) |
||
| 568 | +43 |
- #' split_rows_by(var = "AVISIT") %>%+ #' # Also convert logical columns to factor columns. |
||
| 569 | +44 |
- #' analyze_vars(vars = "AVAL")+ #' df_explicit_na(my_data, logical_as_factor = TRUE) |
||
| 570 | +45 |
- #'+ #' # Encode missing values in a subset of columns. |
||
| 571 | +46 |
- #' build_table(l, df = dta_test)+ #' df_explicit_na(my_data, omit_columns = c("x", "y"))
|
||
| 572 | +47 |
#' |
||
| 573 | +48 |
- #' ## Select and format statistics output.+ #' # Example 2 |
||
| 574 | +49 |
- #' l <- basic_table() %>%+ #' # Here we purposefully convert all `M` values to `NA` in the `SEX` variable. |
||
| 575 | +50 |
- #' split_cols_by(var = "ARM") %>%+ #' # After running `df_explicit_na` the `NA` values are encoded as `<Missing>` but they are not |
||
| 576 | +51 |
- #' split_rows_by(var = "AVISIT") %>%+ #' # included when generating `rtables`. |
||
| 577 | +52 |
- #' analyze_vars(+ #' adsl <- tern_ex_adsl |
||
| 578 | +53 |
- #' vars = "AVAL",+ #' adsl$SEX[adsl$SEX == "M"] <- NA |
||
| 579 | +54 |
- #' .stats = c("n", "mean_sd", "quantiles"),
+ #' adsl <- df_explicit_na(adsl) |
||
| 580 | +55 |
- #' .formats = c("mean_sd" = "xx.x, xx.x"),
+ #' |
||
| 581 | +56 |
- #' .labels = c(n = "n", mean_sd = "Mean, SD", quantiles = c("Q1 - Q3"))
+ #' # If you want the `Na` values to be displayed in the table use the `na_level` argument. |
||
| 582 | +57 |
- #' )+ #' adsl <- tern_ex_adsl |
||
| 583 | +58 |
- #'+ #' adsl$SEX[adsl$SEX == "M"] <- NA |
||
| 584 | +59 |
- #' build_table(l, df = dta_test)+ #' adsl <- df_explicit_na(adsl, na_level = "Missing Values") |
||
| 585 | +60 |
#' |
||
| 586 | +61 |
- #' ## Use arguments interpreted by `s_summary`.+ #' # Example 3 |
||
| 587 | +62 |
- #' l <- basic_table() %>%+ #' # Numeric variables that have missing values are not altered. This means that any `NA` value in |
||
| 588 | +63 |
- #' split_cols_by(var = "ARM") %>%+ #' # a numeric variable will not be included in the summary statistics, nor will they be included |
||
| 589 | +64 |
- #' split_rows_by(var = "AVISIT") %>%+ #' # in the denominator value for calculating the percent values. |
||
| 590 | +65 |
- #' analyze_vars(vars = "AVAL", na.rm = FALSE)+ #' adsl <- tern_ex_adsl |
||
| 591 | +66 |
- #'+ #' adsl$AGE[adsl$AGE < 30] <- NA |
||
| 592 | +67 |
- #' build_table(l, df = dta_test)+ #' adsl <- df_explicit_na(adsl) |
||
| 593 | +68 |
#' |
||
| 594 | +69 |
- #' ## Handle `NA` levels first when summarizing factors.+ #' @export |
||
| 595 | +70 |
- #' dta_test$AVISIT <- NA_character_+ df_explicit_na <- function(data, |
||
| 596 | +71 |
- #' dta_test <- df_explicit_na(dta_test)+ omit_columns = NULL, |
||
| 597 | +72 |
- #' l <- basic_table() %>%+ char_as_factor = TRUE, |
||
| 598 | +73 |
- #' split_cols_by(var = "ARM") %>%+ logical_as_factor = FALSE, |
||
| 599 | +74 |
- #' analyze_vars(vars = "AVISIT", na.rm = FALSE)+ na_level = "<Missing>") {
|
||
| 600 | -+ | |||
| 75 | +24x |
- #'+ checkmate::assert_character(omit_columns, null.ok = TRUE, min.len = 1, any.missing = FALSE) |
||
| 601 | -+ | |||
| 76 | +23x |
- #' build_table(l, df = dta_test)+ checkmate::assert_data_frame(data) |
||
| 602 | -+ | |||
| 77 | +22x |
- #'+ checkmate::assert_flag(char_as_factor) |
||
| 603 | -+ | |||
| 78 | +21x |
- #' # auto format+ checkmate::assert_flag(logical_as_factor) |
||
| 604 | -+ | |||
| 79 | +21x |
- #' dt <- data.frame("VAR" = c(0.001, 0.2, 0.0011000, 3, 4))
+ checkmate::assert_string(na_level) |
||
| 605 | +80 |
- #' basic_table() %>%+ |
||
| 606 | -+ | |||
| 81 | +19x |
- #' analyze_vars(+ target_vars <- if (is.null(omit_columns)) {
|
||
| 607 | -+ | |||
| 82 | +17x |
- #' vars = "VAR",+ names(data) |
||
| 608 | +83 |
- #' .stats = c("n", "mean", "mean_sd", "range"),
+ } else {
|
||
| 609 | -+ | |||
| 84 | +2x |
- #' .formats = c("mean_sd" = "auto", "range" = "auto")
+ setdiff(names(data), omit_columns) # May have duplicates. |
||
| 610 | +85 |
- #' ) %>%+ } |
||
| 611 | -+ | |||
| 86 | +19x |
- #' build_table(dt)+ if (length(target_vars) == 0) {
|
||
| 612 | -+ | |||
| 87 | +1x |
- #'+ return(data) |
||
| 613 | +88 |
- #' @export+ } |
||
| 614 | +89 |
- #' @order 2+ |
||
| 615 | -+ | |||
| 90 | +18x |
- analyze_vars <- function(lyt,+ l_target_vars <- split(target_vars, target_vars) |
||
| 616 | +91 |
- vars,+ |
||
| 617 | +92 |
- var_labels = vars,+ # Makes sure target_vars exist in data and names are not duplicated. |
||
| 618 | -+ | |||
| 93 | +18x |
- na_str = default_na_str(),+ assert_df_with_variables(data, l_target_vars) |
||
| 619 | +94 |
- nested = TRUE,+ |
||
| 620 | -+ | |||
| 95 | +18x |
- ...,+ for (x in target_vars) {
|
||
| 621 | -+ | |||
| 96 | +306x |
- na.rm = TRUE, # nolint+ xi <- data[[x]]+ |
+ ||
| 97 | +306x | +
+ xi_label <- obj_label(xi) |
||
| 622 | +98 |
- show_labels = "default",+ |
||
| 623 | +99 |
- table_names = vars,+ # Determine whether to convert character or logical input.+ |
+ ||
| 100 | +306x | +
+ do_char_conversion <- is.character(xi) && char_as_factor+ |
+ ||
| 101 | +306x | +
+ do_logical_conversion <- is.logical(xi) && logical_as_factor |
||
| 624 | +102 |
- section_div = NA_character_,+ |
||
| 625 | +103 |
- .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
+ # Pre-convert logical to character to deal correctly with replacing NA |
||
| 626 | +104 |
- .formats = NULL,+ # values below.+ |
+ ||
| 105 | +306x | +
+ if (do_logical_conversion) {
+ |
+ ||
| 106 | +2x | +
+ xi <- as.character(xi) |
||
| 627 | +107 |
- .labels = NULL,+ } |
||
| 628 | +108 |
- .indent_mods = NULL) {
+
|
||
| 629 | -30x | +109 | +306x |
- extra_args <- list(.stats = .stats, na.rm = na.rm, na_str = na_str, ...)+ if (is.factor(xi) || is.character(xi)) {
|
| 630 | -4x | +|||
| 110 | +
- if (!is.null(.formats)) extra_args[[".formats"]] <- .formats+ # Handle empty strings and NA values. |
|||
| 631 | -2x | +111 | +219x |
- if (!is.null(.labels)) extra_args[[".labels"]] <- .labels+ xi <- explicit_na(sas_na(xi), label = na_level) |
| 632 | -! | +|||
| 112 | +
- if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods+ |
|||
| 633 | +113 |
-
+ # Convert to factors if requested for the original type, |
||
| 634 | -30x | +|||
| 114 | +
- analyze(+ # set na_level as the last value. |
|||
| 635 | -30x | +115 | +219x |
- lyt = lyt,+ if (do_char_conversion || do_logical_conversion) {
|
| 636 | -30x | +116 | +78x |
- vars = vars,+ levels_xi <- setdiff(sort(unique(xi)), na_level) |
| 637 | -30x | +117 | +78x |
- var_labels = var_labels,+ if (na_level %in% unique(xi)) {
|
| 638 | -30x | +118 | +18x |
- afun = a_summary,+ levels_xi <- c(levels_xi, na_level) |
| 639 | -30x | +|||
| 119 | +
- na_str = na_str,+ } |
|||
| 640 | -30x | +|||
| 120 | +
- nested = nested,+ |
|||
| 641 | -30x | +121 | +78x |
- extra_args = extra_args,+ xi <- factor(xi, levels = levels_xi) |
| 642 | -30x | +|||
| 122 | +
- inclNAs = TRUE,+ } |
|||
| 643 | -30x | +|||
| 123 | +
- show_labels = show_labels,+ |
|||
| 644 | -30x | +124 | +219x |
- table_names = table_names,+ data[, x] <- formatters::with_label(xi, label = xi_label) |
| 645 | -30x | +|||
| 125 | +
- section_div = section_div+ } |
|||
| 646 | +126 |
- )+ }+ |
+ ||
| 127 | +18x | +
+ return(data) |
||
| 647 | +128 |
}@@ -146983,14 +145950,14 @@ tern coverage - 95.64% |
| 1 |
- #' Kaplan-Meier plot+ #' Compare variables between groups |
|||
| 5 |
- #' From a survival model, a graphic is rendered along with tabulated annotation+ #' The analyze function [compare_vars()] creates a layout element to summarize and compare one or more variables, using |
|||
| 6 |
- #' including the number of patient at risk at given time and the median survival+ #' the S3 generic function [s_summary()] to calculate a list of summary statistics. A list of all available statistics |
|||
| 7 |
- #' per group.+ #' for numeric variables can be viewed by running `get_stats("analyze_vars_numeric", add_pval = TRUE)` and for
|
|||
| 8 |
- #'+ #' non-numeric variables by running `get_stats("analyze_vars_counts", add_pval = TRUE)`. Use the `.stats` parameter to
|
|||
| 9 |
- #' @inheritParams argument_convention+ #' specify the statistics to include in your output summary table. |
|||
| 10 |
- #' @param variables (named `list`)\cr variable names. Details are:+ #' |
|||
| 11 |
- #' * `tte` (`numeric`)\cr variable indicating time-to-event duration values.+ #' Prior to using this function in your table layout you must use [rtables::split_cols_by()] to create a column |
|||
| 12 |
- #' * `is_event` (`logical`)\cr event variable. `TRUE` if event, `FALSE` if time to event is censored.+ #' split on the variable to be used in comparisons, and specify a reference group via the `ref_group` parameter. |
|||
| 13 |
- #' * `arm` (`factor`)\cr the treatment group variable.+ #' Comparisons can be performed for each group (column) against the specified reference group by including the p-value |
|||
| 14 |
- #' * `strata` (`character` or `NULL`)\cr variable names indicating stratification factors.+ #' statistic. |
|||
| 15 |
- #' @param control_surv (`list`)\cr parameters for comparison details, specified by using+ #' |
|||
| 16 |
- #' the helper function [control_surv_timepoint()]. Some possible parameter options are:+ #' @inheritParams argument_convention |
|||
| 17 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate.+ #' @param .stats (`character`)\cr statistics to select for the table. Run |
|||
| 18 |
- #' * `conf_type` (`string`)\cr `"plain"` (default), `"log"`, `"log-log"` for confidence interval type,+ #' `get_stats("analyze_vars_numeric", add_pval = TRUE)` to see statistics available for numeric variables, and
|
|||
| 19 |
- #' see more in [survival::survfit()]. Note that the option "none" is no longer supported.+ #' `get_stats("analyze_vars_counts", add_pval = TRUE)` for statistics available for non-numeric variables.
|
|||
| 20 |
- #' @param col (`character`)\cr lines colors. Length of a vector should be equal+ #' |
|||
| 21 |
- #' to number of strata from [survival::survfit()].+ #' @note |
|||
| 22 |
- #' @param lty (`numeric`)\cr line type. If a vector is given, its length should be equal to the number of strata from+ #' * For factor variables, `denom` for factor proportions can only be `n` since the purpose is to compare proportions |
|||
| 23 |
- #' [survival::survfit()].+ #' between columns, therefore a row-based proportion would not make sense. Proportion based on `N_col` would |
|||
| 24 |
- #' @param lwd (`numeric`)\cr line width. If a vector is given, its length should be equal to the number of strata from+ #' be difficult since we use counts for the chi-squared test statistic, therefore missing values should be accounted |
|||
| 25 |
- #' [survival::survfit()].+ #' for as explicit factor levels. |
|||
| 26 |
- #' @param censor_show (`flag`)\cr whether to show censored observations.+ #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values |
|||
| 27 |
- #' @param pch (`string`)\cr name of symbol or character to use as point symbol to indicate censored cases.+ #' set `na.rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit |
|||
| 28 |
- #' @param size (`numeric(1)`)\cr size of censored point symbols.+ #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the |
|||
| 29 |
- #' @param max_time (`numeric(1)`)\cr maximum value to show on x-axis. Only data values less than or up to+ #' default `na_level` (`"<Missing>"`) will also be excluded when `na.rm` is set to `TRUE`. |
|||
| 30 |
- #' this threshold value will be plotted (defaults to `NULL`).+ #' * For character variables, automatic conversion to factor does not guarantee that the table |
|||
| 31 |
- #' @param xticks (`numeric` or `NULL`)\cr numeric vector of tick positions or a single number with spacing+ #' will be generated correctly. In particular for sparse tables this very likely can fail. |
|||
| 32 |
- #' between ticks on the x-axis. If `NULL` (default), [labeling::extended()] is used to determine+ #' Therefore it is always better to manually convert character variables to factors during pre-processing. |
|||
| 33 |
- #' optimal tick positions on the x-axis.+ #' * For `compare_vars()`, the column split must define a reference group via `ref_group` so that the comparison |
|||
| 34 |
- #' @param xlab (`string`)\cr x-axis label.+ #' is well defined. |
|||
| 35 |
- #' @param yval (`string`)\cr type of plot, to be plotted on the y-axis. Options are `Survival` (default) and `Failure`+ #' |
|||
| 36 |
- #' probability.+ #' @seealso [s_summary()] which is used internally to compute a summary within `s_compare()`, and [a_summary()] |
|||
| 37 |
- #' @param ylab (`string`)\cr y-axis label.+ #' which is used (with `compare = TRUE`) as the analysis function for `compare_vars()`. |
|||
| 38 |
- #' @param title (`string`)\cr plot title.+ #' |
|||
| 39 |
- #' @param footnotes (`string`)\cr plot footnotes.+ #' @name compare_variables |
|||
| 40 |
- #' @param font_size (`numeric(1)`)\cr font size to use for all text.+ #' @include analyze_variables.R |
|||
| 41 |
- #' @param ci_ribbon (`flag`)\cr whether the confidence interval should be drawn around the Kaplan-Meier curve.+ #' @order 1 |
|||
| 42 |
- #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of patient at risk+ NULL |
|||
| 43 |
- #' matching the main grid of the Kaplan-Meier curve.+ |
|||
| 44 |
- #' @param annot_at_risk_title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk`+ #' @describeIn compare_variables S3 generic function to produce a comparison summary. |
|||
| 45 |
- #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`.+ #' |
|||
| 46 |
- #' @param annot_surv_med (`flag`)\cr compute and add the annotation table on the Kaplan-Meier curve estimating the+ #' @return |
|||
| 47 |
- #' median survival time per group.+ #' * `s_compare()` returns output of [s_summary()] and comparisons versus the reference group in the form of p-values. |
|||
| 48 |
- #' @param annot_coxph (`flag`)\cr whether to add the annotation table from a [survival::coxph()] model.+ #' |
|||
| 49 |
- #' @param annot_stats (`string` or `NULL`)\cr statistics annotations to add to the plot. Options are+ #' @export |
|||
| 50 |
- #' `median` (median survival follow-up time) and `min` (minimum survival follow-up time).+ s_compare <- function(x, |
|||
| 51 |
- #' @param annot_stats_vlines (`flag`)\cr add vertical lines corresponding to each of the statistics+ .ref_group, |
|||
| 52 |
- #' specified by `annot_stats`. If `annot_stats` is `NULL` no lines will be added.+ .in_ref_col, |
|||
| 53 |
- #' @param control_coxph_pw (`list`)\cr parameters for comparison details, specified using the helper function+ ...) {
|
|||
| 54 | -+ | 35x |
- #' [control_coxph()]. Some possible parameter options are:+ UseMethod("s_compare", x)
|
|
| 55 |
- #' * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1.+ } |
|||
| 56 |
- #' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`.+ |
|||
| 57 |
- #' * `ties` (`string`)\cr method for tie handling. Default is `"efron"`,+ #' @describeIn compare_variables Method for `numeric` class. This uses the standard t-test |
|||
| 58 |
- #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()]+ #' to calculate the p-value. |
|||
| 59 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR.+ #' |
|||
| 60 |
- #' @param ref_group_coxph (`string` or `NULL`)\cr level of arm variable to use as reference group in calculations for+ #' @method s_compare numeric |
|||
| 61 |
- #' `annot_coxph` table. If `NULL` (default), uses the first level of the arm variable.+ #' |
|||
| 62 |
- #' @param control_annot_surv_med (`list`)\cr parameters to control the position and size of the annotation table added+ #' @examples |
|||
| 63 |
- #' to the plot when `annot_surv_med = TRUE`, specified using the [control_surv_med_annot()] function. Parameter+ #' # `s_compare.numeric` |
|||
| 64 |
- #' options are: `x`, `y`, `w`, `h`, and `fill`. See [control_surv_med_annot()] for details.+ #' |
|||
| 65 |
- #' @param control_annot_coxph (`list`)\cr parameters to control the position and size of the annotation table added+ #' ## Usual case where both this and the reference group vector have more than 1 value. |
|||
| 66 |
- #' to the plot when `annot_coxph = TRUE`, specified using the [control_coxph_annot()] function. Parameter+ #' s_compare(rnorm(10, 5, 1), .ref_group = rnorm(5, -5, 1), .in_ref_col = FALSE) |
|||
| 67 |
- #' options are: `x`, `y`, `w`, `h`, `fill`, and `ref_lbls`. See [control_coxph_annot()] for details.+ #' |
|||
| 68 |
- #' @param legend_pos (`numeric(2)` or `NULL`)\cr vector containing x- and y-coordinates, respectively, for the legend+ #' ## If one group has not more than 1 value, then p-value is not calculated. |
|||
| 69 |
- #' position relative to the KM plot area. If `NULL` (default), the legend is positioned in the bottom right corner of+ #' s_compare(rnorm(10, 5, 1), .ref_group = 1, .in_ref_col = FALSE) |
|||
| 70 |
- #' the plot, or the middle right of the plot if needed to prevent overlapping.+ #' |
|||
| 71 |
- #' @param rel_height_plot (`proportion`)\cr proportion of total figure height to allocate to the Kaplan-Meier plot.+ #' ## Empty numeric does not fail, it returns NA-filled items and no p-value. |
|||
| 72 |
- #' Relative height of patients at risk table is then `1 - rel_height_plot`. If `annot_at_risk = FALSE` or+ #' s_compare(numeric(), .ref_group = numeric(), .in_ref_col = FALSE) |
|||
| 73 |
- #' `as_list = TRUE`, this parameter is ignored.+ #' |
|||
| 74 |
- #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to format the Kaplan-Meier plot.+ #' @export |
|||
| 75 |
- #' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list when `annot_at_risk = TRUE`.+ s_compare.numeric <- function(x, |
|||
| 76 |
- #' If `TRUE`, a named list with two elements, `plot` and `table`, will be returned. If `FALSE` (default) the patients+ .ref_group, |
|||
| 77 |
- #' at risk table is printed below the plot via [cowplot::plot_grid()].+ .in_ref_col, |
|||
| 78 |
- #' @param draw `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+ ...) {
|
|||
| 79 | -+ | 13x |
- #' @param newpage `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+ checkmate::assert_numeric(x) |
|
| 80 | -+ | 13x |
- #' @param gp `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+ checkmate::assert_numeric(.ref_group) |
|
| 81 | -+ | 13x |
- #' @param vp `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+ checkmate::assert_flag(.in_ref_col) |
|
| 82 |
- #' @param name `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+
|
|||
| 83 | -+ | 13x |
- #' @param annot_coxph_ref_lbls `r lifecycle::badge("deprecated")` Please use the `ref_lbls` element of
+ y <- s_summary.numeric(x = x, ...) |
|
| 84 |
- #' `control_annot_coxph` instead.+ |
|||
| 85 | -+ | 13x |
- #' @param position_coxph `r lifecycle::badge("deprecated")` Please use the `x` and `y` elements of
+ y$pval <- if (!.in_ref_col && n_available(x) > 1 && n_available(.ref_group) > 1) {
|
|
| 86 | -+ | 9x |
- #' `control_annot_coxph` instead.+ stats::t.test(x, .ref_group)$p.value |
|
| 87 |
- #' @param position_surv_med `r lifecycle::badge("deprecated")` Please use the `x` and `y` elements of
+ } else {
|
|||
| 88 | -+ | 4x |
- #' `control_annot_surv_med` instead.+ character() |
|
| 89 |
- #' @param width_annots `r lifecycle::badge("deprecated")` Please use the `w` element of `control_annot_surv_med`
+ } |
|||
| 90 |
- #' (for `surv_med`) and `control_annot_coxph` (for `coxph`)."+ |
|||
| 91 | -+ | 13x |
- #'+ y |
|
| 92 |
- #' @return A `ggplot` Kaplan-Meier plot and (optionally) summary table.+ } |
|||
| 93 |
- #'+ |
|||
| 94 |
- #' @examples+ #' @describeIn compare_variables Method for `factor` class. This uses the chi-squared test |
|||
| 95 |
- #' library(dplyr)+ #' to calculate the p-value. |
|||
| 96 |
- #' library(nestcolor)+ #' |
|||
| 97 |
- #'+ #' @param denom (`string`)\cr choice of denominator for factor proportions, |
|||
| 98 |
- #' df <- tern_ex_adtte %>%+ #' can only be `n` (number of values in this row and column intersection). |
|||
| 99 |
- #' filter(PARAMCD == "OS") %>%+ #' |
|||
| 100 |
- #' mutate(is_event = CNSR == 0)+ #' @method s_compare factor |
|||
| 101 |
- #' variables <- list(tte = "AVAL", is_event = "is_event", arm = "ARMCD")+ #' |
|||
| 102 |
- #'+ #' @examples |
|||
| 103 |
- #' # Basic examples+ #' # `s_compare.factor` |
|||
| 104 |
- #' g_km(df = df, variables = variables)+ #' |
|||
| 105 |
- #' g_km(df = df, variables = variables, yval = "Failure")+ #' ## Basic usage: |
|||
| 106 |
- #'+ #' x <- factor(c("a", "a", "b", "c", "a"))
|
|||
| 107 |
- #' # Examples with customization parameters applied+ #' y <- factor(c("a", "b", "c"))
|
|||
| 108 |
- #' g_km(+ #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE) |
|||
| 109 |
- #' df = df,+ #' |
|||
| 110 |
- #' variables = variables,+ #' ## Management of NA values. |
|||
| 111 |
- #' control_surv = control_surv_timepoint(conf_level = 0.9),+ #' x <- explicit_na(factor(c("a", "a", "b", "c", "a", NA, NA)))
|
|||
| 112 |
- #' col = c("grey25", "grey50", "grey75"),
+ #' y <- explicit_na(factor(c("a", "b", "c", NA)))
|
|||
| 113 |
- #' annot_at_risk_title = FALSE,+ #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE) |
|||
| 114 |
- #' lty = 1:3,+ #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE) |
|||
| 115 |
- #' font_size = 8+ #' |
|||
| 116 |
- #' )+ #' @export |
|||
| 117 |
- #' g_km(+ s_compare.factor <- function(x, |
|||
| 118 |
- #' df = df,+ .ref_group, |
|||
| 119 |
- #' variables = variables,+ .in_ref_col, |
|||
| 120 |
- #' annot_stats = c("min", "median"),
+ denom = "n", |
|||
| 121 |
- #' annot_stats_vlines = TRUE,+ na.rm = TRUE, # nolint |
|||
| 122 |
- #' max_time = 3000,+ ...) {
|
|||
| 123 | -+ | 16x |
- #' ggtheme = ggplot2::theme_minimal()+ checkmate::assert_flag(.in_ref_col) |
|
| 124 | -+ | 16x |
- #' )+ assert_valid_factor(x) |
|
| 125 | -+ | 16x |
- #'+ assert_valid_factor(.ref_group) |
|
| 126 | -+ | 16x |
- #' # Example with pairwise Cox-PH analysis annotation table, adjusted annotation tables+ denom <- match.arg(denom) |
|
| 127 |
- #' g_km(+ |
|||
| 128 | -+ | 16x |
- #' df = df, variables = variables,+ y <- s_summary.factor( |
|
| 129 | -+ | 16x |
- #' annot_coxph = TRUE,+ x = x, |
|
| 130 | -+ | 16x |
- #' control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99),+ denom = denom, |
|
| 131 | -+ | 16x |
- #' control_annot_coxph = control_coxph_annot(x = 0.26, w = 0.35),+ na.rm = na.rm, |
|
| 132 |
- #' control_annot_surv_med = control_surv_med_annot(x = 0.8, y = 0.9, w = 0.35)+ ... |
|||
| 133 |
- #' )+ ) |
|||
| 134 |
- #'+ |
|||
| 135 | -+ | 16x |
- #' @aliases kaplan_meier+ if (na.rm) {
|
|
| 136 | -+ | 14x |
- #' @export+ x <- x[!is.na(x)] %>% fct_discard("<Missing>")
|
|
| 137 | -+ | 14x |
- g_km <- function(df,+ .ref_group <- .ref_group[!is.na(.ref_group)] %>% fct_discard("<Missing>")
|
|
| 138 |
- variables,+ } else {
|
|||
| 139 | -+ | 2x |
- control_surv = control_surv_timepoint(),+ x <- x %>% explicit_na(label = "NA") |
|
| 140 | -+ | 2x |
- col = NULL,+ .ref_group <- .ref_group %>% explicit_na(label = "NA") |
|
| 141 |
- lty = NULL,+ } |
|||
| 142 |
- lwd = 0.5,+ |
|||
| 143 | -+ | 1x |
- censor_show = TRUE,+ if ("NA" %in% levels(x)) levels(.ref_group) <- c(levels(.ref_group), "NA")
|
|
| 144 | -+ | 16x |
- pch = 3,+ checkmate::assert_factor(x, levels = levels(.ref_group), min.levels = 2) |
|
| 145 |
- size = 2,+ |
|||
| 146 | -+ | 16x |
- max_time = NULL,+ y$pval_counts <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
|
|
| 147 | -+ | 13x |
- xticks = NULL,+ tab <- rbind(table(x), table(.ref_group)) |
|
| 148 | -+ | 13x |
- xlab = "Days",+ res <- suppressWarnings(stats::chisq.test(tab)) |
|
| 149 | -+ | 13x |
- yval = c("Survival", "Failure"),
+ res$p.value |
|
| 150 |
- ylab = paste(yval, "Probability"),+ } else {
|
|||
| 151 | -+ | 3x |
- ylim = NULL,+ character() |
|
| 152 |
- title = NULL,+ } |
|||
| 153 |
- footnotes = NULL,+ |
|||
| 154 | -+ | 16x |
- font_size = 10,+ y |
|
| 155 |
- ci_ribbon = FALSE,+ } |
|||
| 156 |
- annot_at_risk = TRUE,+ |
|||
| 157 |
- annot_at_risk_title = TRUE,+ #' @describeIn compare_variables Method for `character` class. This makes an automatic |
|||
| 158 |
- annot_surv_med = TRUE,+ #' conversion to `factor` (with a warning) and then forwards to the method for factors. |
|||
| 159 |
- annot_coxph = FALSE,+ #' |
|||
| 160 |
- annot_stats = NULL,+ #' @param verbose (`flag`)\cr whether warnings and messages should be printed. Mainly used |
|||
| 161 |
- annot_stats_vlines = FALSE,+ #' to print out information about factor casting. Defaults to `TRUE`. |
|||
| 162 |
- control_coxph_pw = control_coxph(),+ #' |
|||
| 163 |
- ref_group_coxph = NULL,+ #' @method s_compare character |
|||
| 164 |
- control_annot_surv_med = control_surv_med_annot(),+ #' |
|||
| 165 |
- control_annot_coxph = control_coxph_annot(),+ #' @examples |
|||
| 166 |
- legend_pos = NULL,+ #' # `s_compare.character` |
|||
| 167 |
- rel_height_plot = 0.75,+ #' |
|||
| 168 |
- ggtheme = NULL,+ #' ## Basic usage: |
|||
| 169 |
- as_list = FALSE,+ #' x <- c("a", "a", "b", "c", "a")
|
|||
| 170 |
- draw = lifecycle::deprecated(),+ #' y <- c("a", "b", "c")
|
|||
| 171 |
- newpage = lifecycle::deprecated(),+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, .var = "x", verbose = FALSE) |
|||
| 172 |
- gp = lifecycle::deprecated(),+ #' |
|||
| 173 |
- vp = lifecycle::deprecated(),+ #' ## Note that missing values handling can make a large difference: |
|||
| 174 |
- name = lifecycle::deprecated(),+ #' x <- c("a", "a", "b", "c", "a", NA)
|
|||
| 175 |
- annot_coxph_ref_lbls = lifecycle::deprecated(),+ #' y <- c("a", "b", "c", rep(NA, 20))
|
|||
| 176 |
- position_coxph = lifecycle::deprecated(),+ #' s_compare(x, |
|||
| 177 |
- position_surv_med = lifecycle::deprecated(),+ #' .ref_group = y, .in_ref_col = FALSE, |
|||
| 178 |
- width_annots = lifecycle::deprecated()) {
+ #' .var = "x", verbose = FALSE |
|||
| 179 |
- # Deprecated argument warnings+ #' ) |
|||
| 180 | -10x | +
- if (lifecycle::is_present(draw)) {
+ #' s_compare(x, |
||
| 181 | -1x | +
- lifecycle::deprecate_warn(+ #' .ref_group = y, .in_ref_col = FALSE, .var = "x", |
||
| 182 | -1x | +
- "0.9.4", "g_km(draw)",+ #' na.rm = FALSE, verbose = FALSE |
||
| 183 | -1x | +
- details = "This argument is no longer used since the plot is now generated as a `ggplot2` object."+ #' ) |
||
| 184 |
- )+ #' |
|||
| 185 |
- }+ #' @export |
|||
| 186 | -10x | +
- if (lifecycle::is_present(newpage)) {
+ s_compare.character <- function(x, |
||
| 187 | -1x | +
- lifecycle::deprecate_warn(+ .ref_group, |
||
| 188 | -1x | +
- "0.9.4", "g_km(newpage)",+ .in_ref_col, |
||
| 189 | -1x | +
- details = "This argument is no longer used since the plot is now generated as a `ggplot2` object."+ denom = "n", |
||
| 190 |
- )+ na.rm = TRUE, # nolint |
|||
| 191 |
- }+ .var, |
|||
| 192 | -10x | +
- if (lifecycle::is_present(gp)) {
+ verbose = TRUE, |
||
| 193 | -1x | +
- lifecycle::deprecate_warn(+ ...) {
|
||
| 194 | -1x | +2x |
- "0.9.4", "g_km(gp)",+ x <- as_factor_keep_attributes(x, verbose = verbose) |
|
| 195 | -1x | +2x |
- details = "This argument is no longer used since the plot is now generated as a `ggplot2` object."+ .ref_group <- as_factor_keep_attributes(.ref_group, verbose = verbose) |
|
| 196 | -+ | 2x |
- )+ s_compare( |
|
| 197 | -+ | 2x |
- }+ x = x, |
|
| 198 | -10x | +2x |
- if (lifecycle::is_present(vp)) {
+ .ref_group = .ref_group, |
|
| 199 | -1x | +2x |
- lifecycle::deprecate_warn(+ .in_ref_col = .in_ref_col, |
|
| 200 | -1x | +2x |
- "0.9.4", "g_km(vp)",+ denom = denom, |
|
| 201 | -1x | +2x |
- details = "This argument is no longer used since the plot is now generated as a `ggplot2` object."+ na.rm = na.rm, |
|
| 202 |
- )+ ... |
|||
| 203 |
- }+ ) |
|||
| 204 | -10x | +
- if (lifecycle::is_present(name)) {
+ } |
||
| 205 | -1x | +
- lifecycle::deprecate_warn(+ |
||
| 206 | -1x | +
- "0.9.4", "g_km(name)",+ #' @describeIn compare_variables Method for `logical` class. A chi-squared test |
||
| 207 | -1x | +
- details = "This argument is no longer used since the plot is now generated as a `ggplot2` object."+ #' is used. If missing values are not removed, then they are counted as `FALSE`. |
||
| 208 |
- )+ #' |
|||
| 209 |
- }+ #' @method s_compare logical |
|||
| 210 | -10x | +
- if (lifecycle::is_present(annot_coxph_ref_lbls)) {
+ #' |
||
| 211 | -1x | +
- lifecycle::deprecate_warn(+ #' @examples |
||
| 212 | -1x | +
- "0.9.4", "g_km(annot_coxph_ref_lbls)",+ #' # `s_compare.logical` |
||
| 213 | -1x | +
- details = "Please specify this setting using the 'ref_lbls' element of control_annot_coxph."+ #' |
||
| 214 |
- )+ #' ## Basic usage: |
|||
| 215 | -1x | +
- control_annot_coxph[["ref_lbls"]] <- annot_coxph_ref_lbls+ #' x <- c(TRUE, FALSE, TRUE, TRUE) |
||
| 216 |
- }+ #' y <- c(FALSE, FALSE, TRUE) |
|||
| 217 | -10x | +
- if (lifecycle::is_present(position_coxph)) {
+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE) |
||
| 218 | -1x | +
- lifecycle::deprecate_warn(+ #' |
||
| 219 | -1x | +
- "0.9.4", "g_km(position_coxph)",+ #' ## Management of NA values. |
||
| 220 | -1x | +
- details = "Please specify this setting using the 'x' and 'y' elements of control_annot_coxph."+ #' x <- c(NA, TRUE, FALSE) |
||
| 221 |
- )+ #' y <- c(NA, NA, NA, NA, FALSE) |
|||
| 222 | -1x | +
- control_annot_coxph[["x"]] <- position_coxph[1]+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE) |
||
| 223 | -1x | +
- control_annot_coxph[["y"]] <- position_coxph[2]+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE) |
||
| 224 |
- }+ #' |
|||
| 225 | -10x | +
- if (lifecycle::is_present(position_surv_med)) {
+ #' @export |
||
| 226 | -1x | +
- lifecycle::deprecate_warn(+ s_compare.logical <- function(x, |
||
| 227 | -1x | +
- "0.9.4", "g_km(position_surv_med)",+ .ref_group, |
||
| 228 | -1x | +
- details = "Please specify this setting using the 'x' and 'y' elements of control_annot_surv_med."+ .in_ref_col, |
||
| 229 |
- )+ na.rm = TRUE, # nolint |
|||
| 230 | -1x | +
- control_annot_surv_med[["x"]] <- position_surv_med[1]+ denom = "n", |
||
| 231 | -1x | +
- control_annot_surv_med[["y"]] <- position_surv_med[2]+ ...) {
|
||
| 232 | -+ | 4x |
- }+ denom <- match.arg(denom) |
|
| 233 | -10x | +
- if (lifecycle::is_present(width_annots)) {
+
|
||
| 234 | -1x | +4x |
- lifecycle::deprecate_warn(+ y <- s_summary.logical( |
|
| 235 | -1x | +4x |
- "0.9.4", "g_km(width_annots)",+ x = x, |
|
| 236 | -1x | +4x |
- details = paste(+ na.rm = na.rm, |
|
| 237 | -1x | +4x |
- "Please specify widths of annotation tables relative to the plot area using the 'w' element of",+ denom = denom, |
|
| 238 | -1x | +
- "control_annot_surv_med (for surv_med) and control_annot_coxph (for coxph)."+ ... |
||
| 239 |
- )+ ) |
|||
| 240 |
- )+ |
|||
| 241 | -1x | +4x |
- control_annot_surv_med[["w"]] <- as.numeric(width_annots[["surv_med"]])+ if (na.rm) {
|
|
| 242 | -1x | +3x |
- control_annot_coxph[["w"]] <- as.numeric(width_annots[["coxph"]])+ x <- stats::na.omit(x) |
|
| 243 | -+ | 3x |
- }+ .ref_group <- stats::na.omit(.ref_group) |
|
| 244 |
-
+ } else {
|
|||
| 245 | -10x | +1x |
- checkmate::assert_list(variables)+ x[is.na(x)] <- FALSE |
|
| 246 | -10x | +1x |
- checkmate::assert_subset(c("tte", "arm", "is_event"), names(variables))
+ .ref_group[is.na(.ref_group)] <- FALSE |
|
| 247 | -10x | +
- checkmate::assert_logical(censor_show, len = 1)+ } |
||
| 248 | -10x | +
- checkmate::assert_numeric(size, len = 1)+ |
||
| 249 | -10x | +4x |
- checkmate::assert_numeric(max_time, len = 1, null.ok = TRUE)+ y$pval_counts <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
|
|
| 250 | -10x | +4x |
- checkmate::assert_numeric(xticks, null.ok = TRUE)+ x <- factor(x, levels = c(TRUE, FALSE)) |
|
| 251 | -10x | +4x |
- checkmate::assert_character(xlab, len = 1, null.ok = TRUE)+ .ref_group <- factor(.ref_group, levels = c(TRUE, FALSE)) |
|
| 252 | -10x | +4x |
- checkmate::assert_character(yval)+ tbl <- rbind(table(x), table(.ref_group)) |
|
| 253 | -10x | -
- checkmate::assert_character(ylab, null.ok = TRUE)- |
- ||
| 254 | -10x | -
- checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE)- |
- ||
| 255 | -10x | -
- checkmate::assert_character(title, len = 1, null.ok = TRUE)- |
- ||
| 256 | -10x | -
- checkmate::assert_character(footnotes, len = 1, null.ok = TRUE)- |
- ||
| 257 | -10x | -
- checkmate::assert_numeric(font_size, len = 1)- |
- ||
| 258 | -10x | -
- checkmate::assert_logical(ci_ribbon, len = 1)- |
- ||
| 259 | -10x | -
- checkmate::assert_logical(annot_at_risk, len = 1)- |
- ||
| 260 | -10x | -
- checkmate::assert_logical(annot_at_risk_title, len = 1)- |
- ||
| 261 | -10x | -
- checkmate::assert_logical(annot_surv_med, len = 1)- |
- ||
| 262 | -10x | -
- checkmate::assert_logical(annot_coxph, len = 1)- |
- ||
| 263 | -10x | -
- checkmate::assert_subset(annot_stats, c("median", "min"))
- |
- ||
| 264 | -10x | -
- checkmate::assert_logical(annot_stats_vlines)- |
- ||
| 265 | -10x | -
- checkmate::assert_list(control_coxph_pw)- |
- ||
| 266 | -10x | -
- checkmate::assert_character(ref_group_coxph, len = 1, null.ok = TRUE)- |
- ||
| 267 | -10x | -
- checkmate::assert_list(control_annot_surv_med)- |
- ||
| 268 | -10x | -
- checkmate::assert_list(control_annot_coxph)- |
- ||
| 269 | -10x | -
- checkmate::assert_numeric(legend_pos, finite = TRUE, any.missing = FALSE, len = 2, null.ok = TRUE)- |
- ||
| 270 | -10x | -
- assert_proportion_value(rel_height_plot)- |
- ||
| 271 | -10x | -
- checkmate::assert_logical(as_list)- |
- ||
| 272 | -- | - - | -||
| 273 | -10x | -
- tte <- variables$tte- |
- ||
| 274 | -10x | -
- is_event <- variables$is_event- |
- ||
| 275 | -10x | -
- arm <- variables$arm- |
- ||
| 276 | -10x | -
- assert_valid_factor(df[[arm]])- |
- ||
| 277 | -10x | -
- armval <- as.character(unique(df[[arm]]))- |
- ||
| 278 | -10x | -
- assert_df_with_variables(df, list(tte = tte, is_event = is_event, arm = arm))- |
- ||
| 279 | -10x | -
- checkmate::assert_logical(df[[is_event]], min.len = 1)- |
- ||
| 280 | -10x | -
- checkmate::assert_numeric(df[[tte]], min.len = 1)- |
- ||
| 281 | -10x | -
- checkmate::assert_vector(col, len = length(armval), null.ok = TRUE)- |
- ||
| 282 | -10x | -
- checkmate::assert_vector(lty, null.ok = TRUE)- |
- ||
| 283 | -10x | -
- checkmate::assert_numeric(lwd, len = 1, null.ok = TRUE)- |
- ||
| 284 | -- | - - | -||
| 285 | -10x | -
- if (annot_coxph && length(armval) < 2) {
- |
- ||
| 286 | -! | -
- stop(paste(- |
- ||
| 287 | -! | -
- "When `annot_coxph` = TRUE, `df` must contain at least 2 levels of `variables$arm`",- |
- ||
| 288 | -! | -
- "in order to calculate the hazard ratio."- |
- ||
| 289 | -- |
- ))- |
- ||
| 290 | -- |
- }- |
- ||
| 291 | -- | - - | -||
| 292 | -- |
- # process model- |
- ||
| 293 | -10x | -
- yval <- match.arg(yval)- |
- ||
| 294 | -10x | -
- formula <- stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", arm))
- |
- ||
| 295 | -10x | -
- fit_km <- survival::survfit(- |
- ||
| 296 | -10x | -
- formula = formula,- |
- ||
| 297 | -10x | -
- data = df,- |
- ||
| 298 | -10x | -
- conf.int = control_surv$conf_level,- |
- ||
| 299 | -10x | -
- conf.type = control_surv$conf_type- |
- ||
| 300 | -- |
- )- |
- ||
| 301 | -10x | -
- data <- h_data_plot(fit_km, armval = armval, max_time = max_time)- |
- ||
| 302 | -- | - - | -||
| 303 | -- |
- # calculate x-ticks- |
- ||
| 304 | -10x | -
- xticks <- h_xticks(data = data, xticks = xticks, max_time = max_time)- |
- ||
| 305 | -+ | 4x |
-
+ suppressWarnings(prop_chisq(tbl)) |
|
| 306 | +254 |
- # change estimates of survival to estimates of failure (1 - survival)- |
- ||
| 307 | -10x | -
- if (yval == "Failure") {
- |
- ||
| 308 | -! | -
- data[c("estimate", "conf.low", "conf.high", "censor")] <- list(
+ } else {
|
||
| 309 | +255 | ! |
- 1 - data$estimate, 1 - data$conf.low, 1 - data$conf.high, 1 - data$censor- |
- |
| 310 | -- |
- )+ character() |
||
| 311 | +256 |
} |
||
| 312 | +257 | |||
| 313 | -- |
- # derive y-axis limits- |
- ||
| 314 | -10x | -
- if (is.null(ylim)) {
- |
- ||
| 315 | -10x | -
- if (!is.null(max_time)) {
- |
- ||
| 316 | -1x | -
- y_lwr <- min(data[data$time < max_time, ][["estimate"]])- |
- ||
| 317 | -1x | -
- y_upr <- max(data[data$time < max_time, ][["estimate"]])- |
- ||
| 318 | -- |
- } else {
- |
- ||
| 319 | -9x | -
- y_lwr <- min(data[["estimate"]])- |
- ||
| 320 | -9x | -
- y_upr <- max(data[["estimate"]])- |
- ||
| 321 | -- |
- }- |
- ||
| 322 | -10x | +258 | +4x |
- ylim <- c(y_lwr, y_upr)+ y |
| 323 | +259 |
- }+ } |
||
| 324 | +260 | |||
| 325 | +261 |
- # initialize ggplot+ #' @describeIn compare_variables Layout-creating function which can take statistics function arguments |
||
| 326 | -10x | +|||
| 262 | +
- gg_plt <- ggplot(+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 327 | -10x | +|||
| 263 | +
- data = data,+ #' |
|||
| 328 | -10x | +|||
| 264 | +
- mapping = aes(+ #' @param ... arguments passed to `s_compare()`. |
|||
| 329 | -10x | +|||
| 265 | +
- x = .data[["time"]],+ #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector |
|||
| 330 | -10x | +|||
| 266 | +
- y = .data[["estimate"]],+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
|||
| 331 | -10x | +|||
| 267 | +
- ymin = .data[["conf.low"]],+ #' for that statistic's row label. |
|||
| 332 | -10x | +|||
| 268 | +
- ymax = .data[["conf.high"]],+ #' |
|||
| 333 | -10x | +|||
| 269 | +
- color = .data[["strata"]],+ #' @return |
|||
| 334 | -10x | +|||
| 270 | +
- fill = .data[["strata"]]+ #' * `compare_vars()` returns a layout object suitable for passing to further layouting functions, |
|||
| 335 | +271 |
- )+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 336 | +272 |
- ) ++ #' the statistics from `s_compare()` to the table layout. |
||
| 337 | -10x | +|||
| 273 | +
- theme_bw(base_size = font_size) ++ #' |
|||
| 338 | -10x | +|||
| 274 | +
- scale_y_continuous(limits = ylim, expand = c(0.025, 0)) ++ #' @examples |
|||
| 339 | -10x | +|||
| 275 | +
- labs(title = title, x = xlab, y = ylab, caption = footnotes) ++ #' # `compare_vars()` in `rtables` pipelines |
|||
| 340 | -10x | +|||
| 276 | +
- theme(+ #' |
|||
| 341 | -10x | +|||
| 277 | +
- axis.text = element_text(size = font_size),+ #' ## Default output within a `rtables` pipeline. |
|||
| 342 | -10x | +|||
| 278 | +
- axis.title = element_text(size = font_size),+ #' lyt <- basic_table() %>% |
|||
| 343 | -10x | +|||
| 279 | +
- legend.title = element_blank(),+ #' split_cols_by("ARMCD", ref_group = "ARM B") %>%
|
|||
| 344 | -10x | +|||
| 280 | +
- legend.text = element_text(size = font_size),+ #' compare_vars(c("AGE", "SEX"))
|
|||
| 345 | -10x | +|||
| 281 | +
- legend.box.background = element_rect(fill = "white", linewidth = 0.5),+ #' build_table(lyt, tern_ex_adsl) |
|||
| 346 | -10x | +|||
| 282 | +
- legend.background = element_blank(),+ #' |
|||
| 347 | -10x | +|||
| 283 | +
- legend.position = "inside",+ #' ## Select and format statistics output. |
|||
| 348 | -10x | +|||
| 284 | +
- legend.spacing.y = unit(-0.02, "npc"),+ #' lyt <- basic_table() %>% |
|||
| 349 | -10x | +|||
| 285 | +
- panel.grid.major = element_blank(),+ #' split_cols_by("ARMCD", ref_group = "ARM C") %>%
|
|||
| 350 | -10x | +|||
| 286 | +
- panel.grid.minor = element_blank()+ #' compare_vars( |
|||
| 351 | +287 |
- )+ #' vars = "AGE", |
||
| 352 | +288 |
-
+ #' .stats = c("mean_sd", "pval"),
|
||
| 353 | +289 |
- # derive x-axis limits+ #' .formats = c(mean_sd = "xx.x, xx.x"), |
||
| 354 | -10x | +|||
| 290 | +
- if (!is.null(max_time) && !is.null(xticks)) {
+ #' .labels = c(mean_sd = "Mean, SD") |
|||
| 355 | -1x | +|||
| 291 | +
- gg_plt <- gg_plt + scale_x_continuous(+ #' ) |
|||
| 356 | -1x | +|||
| 292 | +
- breaks = xticks, limits = c(min(0, xticks), max(c(xticks, max_time))), expand = c(0.025, 0)+ #' build_table(lyt, df = tern_ex_adsl) |
|||
| 357 | +293 |
- )+ #' |
||
| 358 | -9x | +|||
| 294 | +
- } else if (!is.null(xticks)) {
+ #' @export |
|||
| 359 | -9x | +|||
| 295 | +
- if (max(data$time) <= max(xticks)) {
+ #' @order 2 |
|||
| 360 | -9x | +|||
| 296 | +
- gg_plt <- gg_plt + scale_x_continuous(+ compare_vars <- function(lyt, |
|||
| 361 | -9x | +|||
| 297 | +
- breaks = xticks, limits = c(min(0, min(xticks)), max(xticks)), expand = c(0.025, 0)+ vars, |
|||
| 362 | +298 |
- )+ var_labels = vars, |
||
| 363 | +299 |
- } else {
+ na_str = default_na_str(), |
||
| 364 | -! | +|||
| 300 | +
- gg_plt <- gg_plt + scale_x_continuous(breaks = xticks, expand = c(0.025, 0))+ nested = TRUE, |
|||
| 365 | +301 |
- }+ ..., |
||
| 366 | -! | +|||
| 302 | +
- } else if (!is.null(max_time)) {
+ na.rm = TRUE, # nolint |
|||
| 367 | -! | +|||
| 303 | +
- gg_plt <- gg_plt + scale_x_continuous(limits = c(0, max_time), expand = c(0.025, 0))+ show_labels = "default", |
|||
| 368 | +304 |
- }+ table_names = vars, |
||
| 369 | +305 |
-
+ section_div = NA_character_, |
||
| 370 | +306 |
- # set legend position+ .stats = c("n", "mean_sd", "count_fraction", "pval"),
|
||
| 371 | -10x | +|||
| 307 | +
- if (!is.null(legend_pos)) {
+ .formats = NULL, |
|||
| 372 | -2x | +|||
| 308 | +
- gg_plt <- gg_plt + theme(legend.position.inside = legend_pos)+ .labels = NULL, |
|||
| 373 | +309 |
- } else {
+ .indent_mods = NULL) {
|
||
| 374 | -8x | +310 | +4x |
- max_time2 <- sort(+ extra_args <- list(.stats = .stats, na.rm = na.rm, na_str = na_str, compare = TRUE, ...) |
| 375 | -8x | +|||
| 311 | +
- data$time,+ |
|||
| 376 | -8x | +312 | +1x |
- partial = nrow(data) - length(armval) - 1+ if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
| 377 | -8x | -
- )[nrow(data) - length(armval) - 1]- |
- ||
| 378 | -+ | 313 | +1x |
-
+ if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
| 379 | -8x | +|||
| 314 | +! |
- y_rng <- ylim[2] - ylim[1]+ if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
||
| 380 | +315 | |||
| 381 | -8x | +316 | +4x |
- if (yval == "Survival" && all(data$estimate[data$time == max_time2] > ylim[1] + 0.09 * y_rng) &&+ analyze( |
| 382 | -8x | +317 | +4x |
- all(data$estimate[data$time == max_time2] < ylim[1] + 0.5 * y_rng)) { # nolint
+ lyt = lyt, |
| 383 | -1x | +318 | +4x |
- gg_plt <- gg_plt ++ vars = vars, |
| 384 | -1x | +319 | +4x |
- theme(+ var_labels = var_labels, |
| 385 | -1x | +320 | +4x |
- legend.position.inside = c(1, 0.5),+ afun = a_summary, |
| 386 | -1x | +321 | +4x |
- legend.justification = c(1.1, 0.6)+ na_str = na_str, |
| 387 | -+ | |||
| 322 | +4x |
- )+ nested = nested, |
||
| 388 | -+ | |||
| 323 | +4x |
- } else {
+ extra_args = extra_args, |
||
| 389 | -7x | +324 | +4x |
- gg_plt <- gg_plt ++ inclNAs = TRUE, |
| 390 | -7x | +325 | +4x |
- theme(+ show_labels = show_labels, |
| 391 | -7x | +326 | +4x |
- legend.position.inside = c(1, 0),+ table_names = table_names, |
| 392 | -7x | +327 | +4x |
- legend.justification = c(1.1, -0.4)+ section_div = section_div |
| 393 | +328 |
- )+ ) |
||
| 394 | +329 |
- }+ } |
| 395 | +1 |
- }+ #' Count number of patients and sum exposure across all patients in columns |
||
| 396 | +2 |
-
+ #' |
||
| 397 | +3 |
- # add lines+ #' @description `r lifecycle::badge("stable")`
|
||
| 398 | -10x | +|||
| 4 | +
- gg_plt <- if (is.null(lty)) {
+ #' |
|||
| 399 | -9x | +|||
| 5 | +
- gg_plt + geom_step(linewidth = lwd, na.rm = TRUE)+ #' The analyze function [analyze_patients_exposure_in_cols()] creates a layout element to count total numbers of |
|||
| 400 | -10x | +|||
| 6 | +
- } else if (length(lty) == 1) {
+ #' patients and sum an analysis value (i.e. exposure) across all patients in columns. |
|||
| 401 | -! | +|||
| 7 | +
- gg_plt + geom_step(linewidth = lwd, lty = lty, na.rm = TRUE)+ #' |
|||
| 402 | +8 |
- } else {
+ #' The primary analysis variable `ex_var` is the exposure variable used to calculate the `sum_exposure` statistic. The |
||
| 403 | -1x | +|||
| 9 | +
- gg_plt ++ #' `id` variable is used to uniquely identify patients in the data such that only unique patients are counted in the |
|||
| 404 | -1x | +|||
| 10 | +
- geom_step(aes(lty = .data[["strata"]]), linewidth = lwd, na.rm = TRUE) ++ #' `n_patients` statistic, and the `var` variable is used to create a row split if needed. The percentage returned as |
|||
| 405 | -1x | +|||
| 11 | +
- scale_linetype_manual(values = lty)+ #' part of the `n_patients` statistic is the proportion of all records that correspond to a unique patient. |
|||
| 406 | +12 |
- }+ #' |
||
| 407 | +13 |
-
+ #' The summarize function [summarize_patients_exposure_in_cols()] performs the same function as |
||
| 408 | +14 |
- # add censor marks+ #' [analyze_patients_exposure_in_cols()] except it creates content rows, not data rows, to summarize the current table |
||
| 409 | -10x | +|||
| 15 | +
- if (censor_show) {
+ #' row/column context and operates on the level of the latest row split or the root of the table if no row splits have |
|||
| 410 | -10x | +|||
| 16 | +
- gg_plt <- gg_plt + geom_point(+ #' occurred. |
|||
| 411 | -10x | +|||
| 17 | +
- data = data[data$n.censor != 0, ],+ #' |
|||
| 412 | -10x | +|||
| 18 | +
- aes(x = .data[["time"]], y = .data[["censor"]], shape = "Censored"),+ #' If a column split has not yet been performed in the table, `col_split` must be set to `TRUE` for the first call of |
|||
| 413 | -10x | +|||
| 19 | +
- size = size,+ #' [analyze_patients_exposure_in_cols()] or [summarize_patients_exposure_in_cols()]. |
|||
| 414 | -10x | +|||
| 20 | +
- na.rm = TRUE+ #' |
|||
| 415 | +21 |
- ) ++ #' @inheritParams argument_convention |
||
| 416 | -10x | +|||
| 22 | +
- scale_shape_manual(name = NULL, values = pch) ++ #' @param ex_var (`string`)\cr name of the variable in `df` containing exposure values. |
|||
| 417 | -10x | +|||
| 23 | +
- guides(fill = guide_legend(override.aes = list(shape = NA)))+ #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty, this will be used as label. |
|||
| 418 | +24 |
- }+ #' @param .stats (`character`)\cr statistics to select for the table. Run |
||
| 419 | +25 |
-
+ #' `get_stats("analyze_patients_exposure_in_cols")` to see available statistics for this function.
|
||
| 420 | +26 |
- # add ci ribbon+ #' |
||
| 421 | -1x | +|||
| 27 | +
- if (ci_ribbon) gg_plt <- gg_plt + geom_ribbon(alpha = 0.3, lty = 0, na.rm = TRUE)+ #' @name summarize_patients_exposure_in_cols |
|||
| 422 | +28 |
-
+ #' @order 1 |
||
| 423 | +29 |
- # control aesthetics+ NULL |
||
| 424 | -10x | +|||
| 30 | +
- if (!is.null(col)) {
+
|
|||
| 425 | -1x | +|||
| 31 | +
- gg_plt <- gg_plt ++ #' @describeIn summarize_patients_exposure_in_cols Statistics function which counts numbers |
|||
| 426 | -1x | +|||
| 32 | +
- scale_color_manual(values = col) ++ #' of patients and the sum of exposure across all patients. |
|||
| 427 | -1x | +|||
| 33 | +
- scale_fill_manual(values = col)+ #' |
|||
| 428 | +34 |
- }+ #' @return |
||
| 429 | -! | +|||
| 35 | +
- if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme+ #' * `s_count_patients_sum_exposure()` returns a named `list` with the statistics: |
|||
| 430 | +36 |
-
+ #' * `n_patients`: Number of unique patients in `df`. |
||
| 431 | +37 |
- # annotate with stats (text/vlines)+ #' * `sum_exposure`: Sum of `ex_var` across all patients in `df`. |
||
| 432 | -10x | +|||
| 38 | +
- if (!is.null(annot_stats)) {
+ #' |
|||
| 433 | -! | +|||
| 39 | +
- if ("median" %in% annot_stats) {
+ #' @keywords internal |
|||
| 434 | -! | +|||
| 40 | +
- fit_km_all <- survival::survfit(+ s_count_patients_sum_exposure <- function(df, |
|||
| 435 | -! | +|||
| 41 | +
- formula = stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", 1)),
+ ex_var = "AVAL", |
|||
| 436 | -! | +|||
| 42 | +
- data = df,+ id = "USUBJID", |
|||
| 437 | -! | +|||
| 43 | +
- conf.int = control_surv$conf_level,+ labelstr = "", |
|||
| 438 | -! | +|||
| 44 | +
- conf.type = control_surv$conf_type+ .stats = c("n_patients", "sum_exposure"),
|
|||
| 439 | +45 |
- )+ .N_col, # nolint |
||
| 440 | -! | +|||
| 46 | +
- gg_plt <- gg_plt ++ custom_label = NULL) {
|
|||
| 441 | -! | +|||
| 47 | +56x |
- annotate(+ assert_df_with_variables(df, list(ex_var = ex_var, id = id)) |
||
| 442 | -! | +|||
| 48 | +56x |
- "text",+ checkmate::assert_string(id) |
||
| 443 | -! | +|||
| 49 | +56x |
- size = font_size / .pt, col = 1, lineheight = 0.95,+ checkmate::assert_string(labelstr) |
||
| 444 | -! | +|||
| 50 | +56x |
- x = stats::median(fit_km_all) + 0.07 * max(data$time),+ checkmate::assert_string(custom_label, null.ok = TRUE) |
||
| 445 | -! | +|||
| 51 | +56x |
- y = ifelse(yval == "Survival", 0.65, 0.35),+ checkmate::assert_numeric(df[[ex_var]]) |
||
| 446 | -! | +|||
| 52 | +56x |
- label = paste("Median F/U:\n", round(stats::median(fit_km_all), 1), tolower(df$AVALU[1]))
+ checkmate::assert_true(all(.stats %in% c("n_patients", "sum_exposure")))
|
||
| 447 | +53 |
- )+ |
||
| 448 | -! | +|||
| 54 | +56x |
- if (annot_stats_vlines) {
+ row_label <- if (labelstr != "") {
|
||
| 449 | +55 | ! |
- gg_plt <- gg_plt ++ labelstr |
|
| 450 | -! | +|||
| 56 | +56x |
- annotate(+ } else if (!is.null(custom_label)) {
|
||
| 451 | -! | +|||
| 57 | +48x |
- "segment",+ custom_label |
||
| 452 | -! | +|||
| 58 | +
- x = stats::median(fit_km_all), xend = stats::median(fit_km_all), y = -Inf, yend = Inf,+ } else {
|
|||
| 453 | -! | +|||
| 59 | +8x |
- linetype = 2, col = "darkgray"+ "Total patients numbers/person time" |
||
| 454 | +60 |
- )+ } |
||
| 455 | +61 |
- }+ + |
+ ||
| 62 | +56x | +
+ y <- list() |
||
| 456 | +63 |
- }+ |
||
| 457 | -! | +|||
| 64 | +56x |
- if ("min" %in% annot_stats) {
+ if ("n_patients" %in% .stats) {
|
||
| 458 | -! | +|||
| 65 | +23x |
- min_fu <- min(df[[tte]])+ y$n_patients <- |
||
| 459 | -! | +|||
| 66 | +23x |
- gg_plt <- gg_plt ++ formatters::with_label( |
||
| 460 | -! | +|||
| 67 | +23x |
- annotate(+ s_num_patients_content( |
||
| 461 | -! | +|||
| 68 | +23x |
- "text",+ df = df, |
||
| 462 | -! | +|||
| 69 | +23x |
- size = font_size / .pt, col = 1, lineheight = 0.95,+ .N_col = .N_col, # nolint |
||
| 463 | -! | +|||
| 70 | +23x |
- x = min_fu + max(data$time) * 0.07,+ .var = id, |
||
| 464 | -! | +|||
| 71 | +23x |
- y = ifelse(yval == "Survival", 0.96, 0.05),+ labelstr = "" |
||
| 465 | -! | +|||
| 72 | +23x |
- label = paste("Min. F/U:\n", round(min_fu, 1), tolower(df$AVALU[1]))
+ )$unique,+ |
+ ||
| 73 | +23x | +
+ row_label |
||
| 466 | +74 |
- )+ ) |
||
| 467 | -! | +|||
| 75 | +
- if (annot_stats_vlines) {
+ } |
|||
| 468 | -! | +|||
| 76 | +56x |
- gg_plt <- gg_plt ++ if ("sum_exposure" %in% .stats) {
|
||
| 469 | -! | +|||
| 77 | +34x |
- annotate(+ y$sum_exposure <- formatters::with_label(sum(df[[ex_var]]), row_label) |
||
| 470 | -! | +|||
| 78 | +
- "segment",+ } |
|||
| 471 | -! | +|||
| 79 | +56x | +
+ y+ |
+ ||
| 80 | ++ |
+ }+ |
+ ||
| 81 | ++ | + + | +||
| 82 | +
- linetype = 2, col = "darkgray",+ #' @describeIn summarize_patients_exposure_in_cols Analysis function which is used as `afun` in |
|||
| 472 | -! | +|||
| 83 | +
- x = min_fu, xend = min_fu, y = Inf, yend = -Inf+ #' [rtables::analyze_colvars()] within `analyze_patients_exposure_in_cols()` and as `cfun` in |
|||
| 473 | +84 |
- )+ #' [rtables::summarize_row_groups()] within `summarize_patients_exposure_in_cols()`. |
||
| 474 | +85 |
- }+ #' |
||
| 475 | +86 |
- }+ #' @return |
||
| 476 | -! | +|||
| 87 | +
- gg_plt <- gg_plt + guides(fill = guide_legend(override.aes = list(shape = NA, label = "")))+ #' * `a_count_patients_sum_exposure()` returns formatted [rtables::CellValue()]. |
|||
| 477 | +88 |
- }+ #' |
||
| 478 | +89 |
-
+ #' @examples |
||
| 479 | +90 |
- # add at risk annotation table+ #' a_count_patients_sum_exposure( |
||
| 480 | -10x | +|||
| 91 | +
- if (annot_at_risk) {
+ #' df = df, |
|||
| 481 | -9x | +|||
| 92 | +
- annot_tbl <- summary(fit_km, times = xticks, extend = TRUE)+ #' var = "SEX", |
|||
| 482 | -9x | +|||
| 93 | +
- annot_tbl <- if (is.null(fit_km$strata)) {
+ #' .N_col = nrow(df), |
|||
| 483 | -! | +|||
| 94 | +
- data.frame(+ #' .stats = "n_patients" |
|||
| 484 | -! | +|||
| 95 | +
- n.risk = annot_tbl$n.risk,+ #' ) |
|||
| 485 | -! | +|||
| 96 | +
- time = annot_tbl$time,+ #' |
|||
| 486 | -! | +|||
| 97 | +
- strata = armval+ #' @export |
|||
| 487 | +98 |
- )+ a_count_patients_sum_exposure <- function(df, |
||
| 488 | +99 |
- } else {
+ var = NULL, |
||
| 489 | -9x | +|||
| 100 | +
- strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
+ ex_var = "AVAL", |
|||
| 490 | -9x | +|||
| 101 | +
- levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2]+ id = "USUBJID", |
|||
| 491 | -9x | +|||
| 102 | +
- data.frame(+ add_total_level = FALSE, |
|||
| 492 | -9x | +|||
| 103 | +
- n.risk = annot_tbl$n.risk,+ custom_label = NULL, |
|||
| 493 | -9x | +|||
| 104 | +
- time = annot_tbl$time,+ labelstr = "", |
|||
| 494 | -9x | +|||
| 105 | +
- strata = annot_tbl$strata+ .N_col, # nolint |
|||
| 495 | +106 |
- )+ .stats, |
||
| 496 | +107 |
- }+ .formats = list(n_patients = "xx (xx.x%)", sum_exposure = "xx")) {
+ |
+ ||
| 108 | +32x | +
+ checkmate::assert_flag(add_total_level) |
||
| 497 | +109 | |||
| 498 | -9x | +110 | +32x |
- at_risk_tbl <- as.data.frame(tidyr::pivot_wider(annot_tbl, names_from = "time", values_from = "n.risk")[, -1])+ if (!is.null(var)) {
|
| 499 | -9x | +111 | +21x |
- at_risk_tbl[is.na(at_risk_tbl)] <- 0+ assert_df_with_variables(df, list(var = var)) |
| 500 | -9x | +112 | +21x |
- rownames(at_risk_tbl) <- levels(annot_tbl$strata)+ df[[var]] <- as.factor(df[[var]]) |
| 501 | +113 | ++ |
+ }+ |
+ |
| 114 | ||||
| 502 | -9x | +115 | +32x |
- gg_at_risk <- df2gg(+ y <- list() |
| 503 | -9x | +116 | +32x |
- at_risk_tbl,+ if (is.null(var)) {
|
| 504 | -9x | +117 | +11x |
- font_size = font_size, col_labels = FALSE, hline = FALSE,+ y[[.stats]] <- list(Total = s_count_patients_sum_exposure( |
| 505 | -9x | +118 | +11x |
- colwidths = rep(1, ncol(at_risk_tbl))+ df = df, |
| 506 | -+ | |||
| 119 | +11x |
- ) ++ ex_var = ex_var, |
||
| 507 | -9x | +120 | +11x |
- labs(title = if (annot_at_risk_title) "Patients at Risk:" else NULL, x = xlab) ++ id = id, |
| 508 | -9x | +121 | +11x |
- theme_bw(base_size = font_size) ++ labelstr = labelstr, |
| 509 | -9x | +122 | +11x |
- theme(+ .N_col = .N_col, |
| 510 | -9x | +123 | +11x |
- plot.title = element_text(size = font_size, vjust = 3, face = "bold"),+ .stats = .stats, |
| 511 | -9x | +124 | +11x |
- panel.border = element_blank(),+ custom_label = custom_label |
| 512 | -9x | +125 | +11x |
- panel.grid = element_blank(),+ )[[.stats]]) |
| 513 | -9x | +|||
| 126 | +
- axis.title.y = element_blank(),+ } else {
|
|||
| 514 | -9x | +127 | +21x |
- axis.ticks.y = element_blank(),+ for (lvl in levels(df[[var]])) {
|
| 515 | -9x | +128 | +42x |
- axis.text.y = element_text(size = font_size, face = "italic", hjust = 1),+ y[[.stats]][[lvl]] <- s_count_patients_sum_exposure( |
| 516 | -9x | +129 | +42x |
- axis.text.x = element_text(size = font_size),+ df = subset(df, get(var) == lvl), |
| 517 | -9x | +130 | +42x |
- axis.line.x = element_line()+ ex_var = ex_var, |
| 518 | -+ | |||
| 131 | +42x |
- ) ++ id = id, |
||
| 519 | -9x | +132 | +42x |
- coord_cartesian(clip = "off", ylim = c(0.5, nrow(at_risk_tbl)))+ labelstr = labelstr, |
| 520 | -9x | +133 | +42x |
- gg_at_risk <- suppressMessages(+ .N_col = .N_col, |
| 521 | -9x | +134 | +42x |
- gg_at_risk ++ .stats = .stats, |
| 522 | -9x | +135 | +42x |
- scale_x_continuous(expand = c(0.025, 0), breaks = seq_along(at_risk_tbl) - 0.5, labels = xticks) ++ custom_label = lvl |
| 523 | -9x | +136 | +42x |
- scale_y_continuous(labels = rev(levels(annot_tbl$strata)), breaks = seq_len(nrow(at_risk_tbl)))+ )[[.stats]] |
| 524 | +137 |
- )+ } |
||
| 525 | -+ | |||
| 138 | +21x |
-
+ if (add_total_level) {
|
||
| 526 | -9x | +139 | +2x |
- if (!as_list) {
+ y[[.stats]][["Total"]] <- s_count_patients_sum_exposure( |
| 527 | -8x | +140 | +2x |
- gg_plt <- cowplot::plot_grid(+ df = df, |
| 528 | -8x | +141 | +2x |
- gg_plt,+ ex_var = ex_var, |
| 529 | -8x | +142 | +2x |
- gg_at_risk,+ id = id, |
| 530 | -8x | +143 | +2x |
- align = "v",+ labelstr = labelstr, |
| 531 | -8x | +144 | +2x |
- axis = "tblr",+ .N_col = .N_col, |
| 532 | -8x | +145 | +2x |
- ncol = 1,+ .stats = .stats, |
| 533 | -8x | +146 | +2x |
- rel_heights = c(rel_height_plot, 1 - rel_height_plot)+ custom_label = custom_label |
| 534 | -+ | |||
| 147 | +2x |
- )+ )[[.stats]] |
||
| 535 | +148 |
} |
||
| 536 | +149 |
} |
||
| 537 | +150 | |||
| 538 | -- |
- # add median survival time annotation table- |
- ||
| 539 | -10x | -
- if (annot_surv_med) {
- |
- ||
| 540 | -8x | +151 | +32x |
- surv_med_tbl <- h_tbl_median_surv(fit_km = fit_km, armval = armval)+ in_rows(.list = y[[.stats]], .formats = .formats[[.stats]]) |
| 541 | -8x | +|||
| 152 | +
- bg_fill <- if (isTRUE(control_annot_surv_med[["fill"]])) "#00000020" else control_annot_surv_med[["fill"]]+ } |
|||
| 542 | +153 | |||
| 543 | -8x | +|||
| 154 | +
- gg_surv_med <- df2gg(surv_med_tbl, font_size = font_size, colwidths = c(1, 1, 2), bg_fill = bg_fill) ++ #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics |
|||
| 544 | -8x | +|||
| 155 | +
- theme(+ #' function arguments and additional format arguments. This function is a wrapper for |
|||
| 545 | -8x | +|||
| 156 | +
- axis.text.y = element_text(size = font_size, face = "italic", hjust = 1),+ #' [rtables::split_cols_by_multivar()] and [rtables::summarize_row_groups()]. |
|||
| 546 | -8x | +|||
| 157 | +
- plot.margin = margin(0, 2, 0, 5)+ #' |
|||
| 547 | +158 |
- ) ++ #' @return |
||
| 548 | -8x | +|||
| 159 | +
- coord_cartesian(clip = "off", ylim = c(0.5, nrow(surv_med_tbl) + 1.5))+ #' * `summarize_patients_exposure_in_cols()` returns a layout object suitable for passing to further |
|||
| 549 | -8x | +|||
| 160 | +
- gg_surv_med <- suppressMessages(+ #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will |
|||
| 550 | -8x | +|||
| 161 | +
- gg_surv_med ++ #' add formatted content rows, with the statistics from `s_count_patients_sum_exposure()` arranged in |
|||
| 551 | -8x | +|||
| 162 | +
- scale_x_continuous(expand = c(0.025, 0)) ++ #' columns, to the table layout. |
|||
| 552 | -8x | +|||
| 163 | +
- scale_y_continuous(labels = rev(rownames(surv_med_tbl)), breaks = seq_len(nrow(surv_med_tbl)))+ #' |
|||
| 553 | +164 |
- )+ #' @examples |
||
| 554 | +165 |
-
+ #' lyt5 <- basic_table() %>% |
||
| 555 | -8x | +|||
| 166 | +
- gg_plt <- cowplot::ggdraw(gg_plt) ++ #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) |
|||
| 556 | -8x | +|||
| 167 | +
- cowplot::draw_plot(+ #' |
|||
| 557 | -8x | +|||
| 168 | +
- gg_surv_med,+ #' result5 <- build_table(lyt5, df = df, alt_counts_df = adsl) |
|||
| 558 | -8x | +|||
| 169 | +
- control_annot_surv_med[["x"]],+ #' result5 |
|||
| 559 | -8x | +|||
| 170 | +
- control_annot_surv_med[["y"]],+ #' |
|||
| 560 | -8x | +|||
| 171 | +
- width = control_annot_surv_med[["w"]],+ #' lyt6 <- basic_table() %>% |
|||
| 561 | -8x | +|||
| 172 | +
- height = control_annot_surv_med[["h"]],+ #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE, .stats = "sum_exposure") |
|||
| 562 | -8x | +|||
| 173 | +
- vjust = 0.5,+ #' |
|||
| 563 | -8x | +|||
| 174 | +
- hjust = 0.5+ #' result6 <- build_table(lyt6, df = df, alt_counts_df = adsl) |
|||
| 564 | +175 |
- )+ #' result6 |
||
| 565 | +176 |
- }+ #' |
||
| 566 | +177 |
-
+ #' @export |
||
| 567 | +178 |
- # add coxph annotation table+ #' @order 3 |
||
| 568 | -10x | +|||
| 179 | +
- if (annot_coxph) {
+ summarize_patients_exposure_in_cols <- function(lyt, # nolint |
|||
| 569 | -1x | +|||
| 180 | +
- coxph_tbl <- h_tbl_coxph_pairwise(+ var, |
|||
| 570 | -1x | +|||
| 181 | +
- df = df,+ ex_var = "AVAL", |
|||
| 571 | -1x | +|||
| 182 | +
- variables = variables,+ id = "USUBJID", |
|||
| 572 | -1x | +|||
| 183 | +
- ref_group_coxph = ref_group_coxph,+ add_total_level = FALSE, |
|||
| 573 | -1x | +|||
| 184 | +
- control_coxph_pw = control_coxph_pw,+ custom_label = NULL, |
|||
| 574 | -1x | +|||
| 185 | +
- annot_coxph_ref_lbls = control_annot_coxph[["ref_lbls"]]+ col_split = TRUE, |
|||
| 575 | +186 |
- )+ na_str = default_na_str(), |
||
| 576 | -1x | +|||
| 187 | +
- bg_fill <- if (isTRUE(control_annot_coxph[["fill"]])) "#00000020" else control_annot_coxph[["fill"]]+ ..., |
|||
| 577 | +188 |
-
+ .stats = c("n_patients", "sum_exposure"),
|
||
| 578 | -1x | +|||
| 189 | +
- gg_coxph <- df2gg(coxph_tbl, font_size = font_size, colwidths = c(1.1, 1, 3), bg_fill = bg_fill) ++ .labels = c(n_patients = "Patients", sum_exposure = "Person time"), |
|||
| 579 | -1x | +|||
| 190 | +
- theme(+ .indent_mods = NULL) {
|
|||
| 580 | -1x | +191 | +3x |
- axis.text.y = element_text(size = font_size, face = "italic", hjust = 1),+ extra_args <- list(ex_var = ex_var, id = id, add_total_level = add_total_level, custom_label = custom_label, ...) |
| 581 | -1x | +|||
| 192 | +
- plot.margin = margin(0, 2, 0, 5)+ |
|||
| 582 | -+ | |||
| 193 | +3x |
- ) ++ if (col_split) {
|
||
| 583 | -1x | +194 | +3x |
- coord_cartesian(clip = "off", ylim = c(0.5, nrow(coxph_tbl) + 1.5))+ lyt <- split_cols_by_multivar( |
| 584 | -1x | +195 | +3x |
- gg_coxph <- suppressMessages(+ lyt = lyt, |
| 585 | -1x | +196 | +3x |
- gg_coxph ++ vars = rep(var, length(.stats)), |
| 586 | -1x | +197 | +3x |
- scale_x_continuous(expand = c(0.025, 0)) ++ varlabels = .labels[.stats], |
| 587 | -1x | +198 | +3x |
- scale_y_continuous(labels = rev(rownames(coxph_tbl)), breaks = seq_len(nrow(coxph_tbl)))+ extra_args = list(.stats = .stats) |
| 588 | +199 |
) |
||
| 589 | +200 | - - | -||
| 590 | -1x | -
- gg_plt <- cowplot::ggdraw(gg_plt) +- |
- ||
| 591 | -1x | -
- cowplot::draw_plot(+ } |
||
| 592 | -1x | +201 | +3x |
- gg_coxph,+ summarize_row_groups( |
| 593 | -1x | +202 | +3x |
- control_annot_coxph[["x"]],+ lyt = lyt, |
| 594 | -1x | +203 | +3x |
- control_annot_coxph[["y"]],+ var = var, |
| 595 | -1x | +204 | +3x |
- width = control_annot_coxph[["w"]],+ cfun = a_count_patients_sum_exposure, |
| 596 | -1x | +205 | +3x |
- height = control_annot_coxph[["h"]],+ na_str = na_str, |
| 597 | -1x | +206 | +3x |
- vjust = 0.5,+ extra_args = extra_args |
| 598 | -1x | +|||
| 207 | +
- hjust = 0.5+ ) |
|||
| 599 | +208 |
- )+ } |
||
| 600 | +209 |
- }+ |
||
| 601 | +210 |
-
+ #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics |
||
| 602 | -10x | +|||
| 211 | +
- if (as_list) {
+ #' function arguments and additional format arguments. This function is a wrapper for |
|||
| 603 | -1x | +|||
| 212 | +
- list(plot = gg_plt, table = gg_at_risk)+ #' [rtables::split_cols_by_multivar()] and [rtables::analyze_colvars()]. |
|||
| 604 | +213 |
- } else {
+ #' |
||
| 605 | -9x | +|||
| 214 | +
- gg_plt+ #' @param col_split (`flag`)\cr whether the columns should be split. Set to `FALSE` when the required |
|||
| 606 | +215 |
- }+ #' column split has been done already earlier in the layout pipe. |
||
| 607 | +216 |
- }+ #' |
| 1 | +217 |
- #' Analyze a pairwise Cox-PH model+ #' @return |
||
| 2 | +218 |
- #'+ #' * `analyze_patients_exposure_in_cols()` returns a layout object suitable for passing to further |
||
| 3 | +219 |
- #' @description `r lifecycle::badge("stable")`
+ #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will |
||
| 4 | +220 |
- #'+ #' add formatted data rows, with the statistics from `s_count_patients_sum_exposure()` arranged in |
||
| 5 | +221 |
- #' The analyze function [coxph_pairwise()] creates a layout element to analyze a pairwise Cox-PH model.+ #' columns, to the table layout. |
||
| 6 | +222 |
#' |
||
| 7 | +223 |
- #' This function can return statistics including p-value, hazard ratio (HR), and HR confidence intervals from both+ #' @note As opposed to [summarize_patients_exposure_in_cols()] which generates content rows, |
||
| 8 | +224 |
- #' stratified and unstratified Cox-PH models. The variable(s) to be analyzed is specified via the `vars` argument and+ #' `analyze_patients_exposure_in_cols()` generates data rows which will _not_ be repeated on multiple |
||
| 9 | +225 |
- #' any stratification factors via the `strata` argument.+ #' pages when pagination is used. |
||
| 10 | +226 |
#' |
||
| 11 | +227 |
- #' @inheritParams argument_convention+ #' @examples |
||
| 12 | +228 |
- #' @inheritParams s_surv_time+ #' set.seed(1) |
||
| 13 | +229 |
- #' @param strata (`character` or `NULL`)\cr variable names indicating stratification factors.+ #' df <- data.frame( |
||
| 14 | +230 |
- #' @param strat `r lifecycle::badge("deprecated")` Please use the `strata` argument instead.
+ #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
|
||
| 15 | +231 |
- #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function+ #' ARMCD = c(rep("ARM A", 6), rep("ARM B", 6)),
|
||
| 16 | +232 |
- #' [control_coxph()]. Some possible parameter options are:+ #' SEX = c(rep("Female", 6), rep("Male", 6)),
|
||
| 17 | +233 |
- #' * `pval_method` (`string`)\cr p-value method for testing the null hypothesis that hazard ratio = 1. Default+ #' AVAL = as.numeric(sample(seq(1, 20), 12)), |
||
| 18 | +234 |
- #' method is `"log-rank"` which comes from [survival::survdiff()], can also be set to `"wald"` or `"likelihood"`+ #' stringsAsFactors = TRUE |
||
| 19 | +235 |
- #' (from [survival::coxph()]).+ #' ) |
||
| 20 | +236 |
- #' * `ties` (`string`)\cr specifying the method for tie handling. Default is `"efron"`,+ #' adsl <- data.frame( |
||
| 21 | +237 |
- #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()].+ #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
|
||
| 22 | +238 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR.+ #' ARMCD = c(rep("ARM A", 2), rep("ARM B", 2)),
|
||
| 23 | +239 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("coxph_pairwise")`
+ #' SEX = c(rep("Female", 2), rep("Male", 2)),
|
||
| 24 | +240 |
- #' to see available statistics for this function.+ #' stringsAsFactors = TRUE |
||
| 25 | +241 |
- #'+ #' ) |
||
| 26 | +242 |
- #' @name survival_coxph_pairwise+ #' |
||
| 27 | +243 |
- #' @order 1+ #' lyt <- basic_table() %>% |
||
| 28 | +244 |
- NULL+ #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
|
||
| 29 | +245 |
-
+ #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) %>% |
||
| 30 | +246 |
- #' @describeIn survival_coxph_pairwise Statistics function which analyzes HR, CIs of HR, and p-value of a Cox-PH model.+ #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE) |
||
| 31 | +247 |
- #'+ #' result <- build_table(lyt, df = df, alt_counts_df = adsl) |
||
| 32 | +248 |
- #' @return+ #' result |
||
| 33 | +249 |
- #' * `s_coxph_pairwise()` returns the statistics:+ #' |
||
| 34 | +250 |
- #' * `pvalue`: p-value to test the null hypothesis that hazard ratio = 1.+ #' lyt2 <- basic_table() %>% |
||
| 35 | +251 |
- #' * `hr`: Hazard ratio.+ #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
|
||
| 36 | +252 |
- #' * `hr_ci`: Confidence interval for hazard ratio.+ #' summarize_patients_exposure_in_cols( |
||
| 37 | +253 |
- #' * `n_tot`: Total number of observations.+ #' var = "AVAL", col_split = TRUE, |
||
| 38 | +254 |
- #' * `n_tot_events`: Total number of events.+ #' .stats = "n_patients", custom_label = "some custom label" |
||
| 39 | +255 |
- #'+ #' ) %>% |
||
| 40 | +256 |
- #' @keywords internal+ #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE, ex_var = "AVAL") |
||
| 41 | +257 |
- s_coxph_pairwise <- function(df,+ #' result2 <- build_table(lyt2, df = df, alt_counts_df = adsl) |
||
| 42 | +258 |
- .ref_group,+ #' result2 |
||
| 43 | +259 |
- .in_ref_col,+ #' |
||
| 44 | +260 |
- .var,+ #' lyt3 <- basic_table() %>% |
||
| 45 | +261 |
- is_event,+ #' analyze_patients_exposure_in_cols(var = "SEX", col_split = TRUE, ex_var = "AVAL") |
||
| 46 | +262 |
- strata = NULL,+ #' result3 <- build_table(lyt3, df = df, alt_counts_df = adsl) |
||
| 47 | +263 |
- strat = lifecycle::deprecated(),+ #' result3 |
||
| 48 | +264 |
- control = control_coxph()) {
+ #' |
||
| 49 | -92x | +|||
| 265 | +
- if (lifecycle::is_present(strat)) {
+ #' # Adding total levels and custom label |
|||
| 50 | -! | +|||
| 266 | +
- lifecycle::deprecate_warn("0.9.4", "s_coxph_pairwise(strat)", "s_coxph_pairwise(strata)")
+ #' lyt4 <- basic_table( |
|||
| 51 | -! | +|||
| 267 | +
- strata <- strat+ #' show_colcounts = TRUE |
|||
| 52 | +268 |
- }+ #' ) %>% |
||
| 53 | +269 |
-
+ #' analyze_patients_exposure_in_cols( |
||
| 54 | -92x | +|||
| 270 | +
- checkmate::assert_string(.var)+ #' var = "ARMCD", |
|||
| 55 | -92x | +|||
| 271 | +
- checkmate::assert_numeric(df[[.var]])+ #' col_split = TRUE, |
|||
| 56 | -92x | +|||
| 272 | +
- checkmate::assert_logical(df[[is_event]])+ #' add_total_level = TRUE, |
|||
| 57 | -92x | +|||
| 273 | +
- assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ #' custom_label = "TOTAL" |
|||
| 58 | -92x | +|||
| 274 | +
- pval_method <- control$pval_method+ #' ) %>% |
|||
| 59 | -92x | +|||
| 275 | +
- ties <- control$ties+ #' append_topleft(c("", "Sex"))
|
|||
| 60 | -92x | +|||
| 276 | +
- conf_level <- control$conf_level+ #' |
|||
| 61 | +277 |
-
+ #' result4 <- build_table(lyt4, df = df, alt_counts_df = adsl) |
||
| 62 | -92x | +|||
| 278 | +
- if (.in_ref_col) {
+ #' result4 |
|||
| 63 | -! | +|||
| 279 | +
- return(+ #' |
|||
| 64 | -! | +|||
| 280 | +
- list(+ #' @export |
|||
| 65 | -! | +|||
| 281 | +
- pvalue = formatters::with_label("", paste0("p-value (", pval_method, ")")),
+ #' @order 2 |
|||
| 66 | -! | +|||
| 282 | +
- hr = formatters::with_label("", "Hazard Ratio"),
+ analyze_patients_exposure_in_cols <- function(lyt, # nolint |
|||
| 67 | -! | +|||
| 283 | +
- hr_ci = formatters::with_label("", f_conf_level(conf_level)),
+ var = NULL, |
|||
| 68 | -! | +|||
| 284 | +
- n_tot = formatters::with_label("", "Total n"),
+ ex_var = "AVAL", |
|||
| 69 | -! | +|||
| 285 | +
- n_tot_events = formatters::with_label("", "Total events")
+ id = "USUBJID", |
|||
| 70 | +286 |
- )+ add_total_level = FALSE, |
||
| 71 | +287 |
- )+ custom_label = NULL, |
||
| 72 | +288 |
- }+ col_split = TRUE, |
||
| 73 | -92x | +|||
| 289 | +
- data <- rbind(.ref_group, df)+ na_str = default_na_str(), |
|||
| 74 | -92x | +|||
| 290 | +
- group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
+ .stats = c("n_patients", "sum_exposure"),
|
|||
| 75 | +291 |
-
+ .labels = c(n_patients = "Patients", sum_exposure = "Person time"), |
||
| 76 | -92x | +|||
| 292 | +
- df_cox <- data.frame(+ .indent_mods = 0L, |
|||
| 77 | -92x | +|||
| 293 | +
- tte = data[[.var]],+ ...) {
|
|||
| 78 | -92x | +294 | +6x |
- is_event = data[[is_event]],+ extra_args <- list( |
| 79 | -92x | +295 | +6x |
- arm = group+ var = var, ex_var = ex_var, id = id, add_total_level = add_total_level, custom_label = custom_label, ... |
| 80 | +296 |
) |
||
| 81 | -92x | -
- if (is.null(strata)) {
- |
- ||
| 82 | -83x | -
- formula_cox <- survival::Surv(tte, is_event) ~ arm- |
- ||
| 83 | +297 |
- } else {
+
|
||
| 84 | -9x | +298 | +6x |
- formula_cox <- stats::as.formula(+ if (col_split) {
|
| 85 | -9x | +299 | +4x |
- paste0(+ lyt <- split_cols_by_multivar( |
| 86 | -9x | +300 | +4x |
- "survival::Surv(tte, is_event) ~ arm + strata(",
+ lyt = lyt, |
| 87 | -9x | +301 | +4x |
- paste(strata, collapse = ","),+ vars = rep(ex_var, length(.stats)), |
| 88 | -+ | |||
| 302 | +4x |
- ")"+ varlabels = .labels[.stats], |
||
| 89 | -+ | |||
| 303 | +4x |
- )+ extra_args = list(.stats = .stats) |
||
| 90 | +304 |
) |
||
| 91 | -9x | -
- df_cox <- cbind(df_cox, data[strata])- |
- ||
| 92 | +305 |
} |
||
| 93 | -92x | -
- cox_fit <- survival::coxph(- |
- ||
| 94 | -92x | -
- formula = formula_cox,- |
- ||
| 95 | -92x | -
- data = df_cox,- |
- ||
| 96 | -92x | -
- ties = ties- |
- ||
| 97 | -+ | 306 | +6x |
- )+ lyt <- lyt %>% analyze_colvars( |
| 98 | -92x | +307 | +6x |
- sum_cox <- summary(cox_fit, conf.int = conf_level, extend = TRUE)+ afun = a_count_patients_sum_exposure, |
| 99 | -92x | +308 | +6x |
- orginal_survdiff <- survival::survdiff(+ indent_mod = .indent_mods, |
| 100 | -92x | +309 | +6x |
- formula_cox,+ na_str = na_str, |
| 101 | -92x | +310 | +6x |
- data = df_cox+ extra_args = extra_args |
| 102 | +311 |
) |
||
| 103 | -92x | +312 | +6x |
- log_rank_pvalue <- 1 - pchisq(orginal_survdiff$chisq, length(orginal_survdiff$n) - 1)+ lyt |
| 104 | +313 |
-
+ } |
||
| 105 | -92x | +
| 1 | +
- pval <- switch(pval_method,+ #' Odds ratio estimation |
|||
| 106 | -92x | +|||
| 2 | +
- "wald" = sum_cox$waldtest["pvalue"],+ #' |
|||
| 107 | -92x | +|||
| 3 | +
- "log-rank" = log_rank_pvalue, # pvalue from original log-rank test survival::survdiff()+ #' @description `r lifecycle::badge("stable")`
|
|||
| 108 | -92x | +|||
| 4 | +
- "likelihood" = sum_cox$logtest["pvalue"]+ #' |
|||
| 109 | +5 |
- )+ #' The analyze function [estimate_odds_ratio()] creates a layout element to compare bivariate responses between |
||
| 110 | -92x | +|||
| 6 | +
- list(+ #' two groups by estimating an odds ratio and its confidence interval. |
|||
| 111 | -92x | +|||
| 7 | +
- pvalue = formatters::with_label(unname(pval), paste0("p-value (", pval_method, ")")),
+ #' |
|||
| 112 | -92x | +|||
| 8 | +
- hr = formatters::with_label(sum_cox$conf.int[1, 1], "Hazard Ratio"),+ #' The primary analysis variable specified by `vars` is the group variable. Additional variables can be included in the |
|||
| 113 | -92x | +|||
| 9 | +
- hr_ci = formatters::with_label(unname(sum_cox$conf.int[1, 3:4]), f_conf_level(conf_level)),+ #' analysis via the `variables` argument, which accepts `arm`, an arm variable, and `strata`, a stratification variable. |
|||
| 114 | -92x | +|||
| 10 | +
- n_tot = formatters::with_label(sum_cox$n, "Total n"),+ #' If more than two arm levels are present, they can be combined into two groups using the `groups_list` argument. |
|||
| 115 | -92x | +|||
| 11 | +
- n_tot_events = formatters::with_label(sum_cox$nevent, "Total events")+ #' |
|||
| 116 | +12 |
- )+ #' @inheritParams split_cols_by_groups |
||
| 117 | +13 |
- }+ #' @inheritParams argument_convention |
||
| 118 | +14 |
-
+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_odds_ratio")`
|
||
| 119 | +15 |
- #' @describeIn survival_coxph_pairwise Formatted analysis function which is used as `afun` in `coxph_pairwise()`.+ #' to see available statistics for this function. |
||
| 120 | +16 |
- #'+ #' @param method (`string`)\cr whether to use the correct (`"exact"`) calculation in the conditional likelihood or one |
||
| 121 | +17 |
- #' @return+ #' of the approximations. See [survival::clogit()] for details. |
||
| 122 | +18 |
- #' * `a_coxph_pairwise()` returns the corresponding list with formatted [rtables::CellValue()].+ #' |
||
| 123 | +19 |
- #'+ #' @note |
||
| 124 | +20 |
- #' @keywords internal+ #' * This function uses logistic regression for unstratified analyses, and conditional logistic regression for |
||
| 125 | +21 |
- a_coxph_pairwise <- make_afun(+ #' stratified analyses. The Wald confidence interval is calculated with the specified confidence level. |
||
| 126 | +22 |
- s_coxph_pairwise,+ #' * For stratified analyses, there is currently no implementation for conditional likelihood confidence intervals, |
||
| 127 | +23 |
- .indent_mods = c(pvalue = 0L, hr = 0L, hr_ci = 1L, n_tot = 0L, n_tot_events = 0L),+ #' therefore the likelihood confidence interval is not available as an option. |
||
| 128 | +24 |
- .formats = c(+ #' * When `vars` contains only responders or non-responders no odds ratio estimation is possible so the returned |
||
| 129 | +25 |
- pvalue = "x.xxxx | (<0.0001)",+ #' values will be `NA`. |
||
| 130 | +26 |
- hr = "xx.xx",+ #' |
||
| 131 | +27 |
- hr_ci = "(xx.xx, xx.xx)",+ #' @seealso Relevant helper function [h_odds_ratio()]. |
||
| 132 | +28 |
- n_tot = "xx.xx",+ #' |
||
| 133 | +29 |
- n_tot_events = "xx.xx"+ #' @name odds_ratio |
||
| 134 | +30 |
- )+ #' @order 1 |
||
| 135 | +31 |
- )+ NULL |
||
| 136 | +32 | |||
| 137 | +33 |
- #' @describeIn survival_coxph_pairwise Layout-creating function which can take statistics function arguments+ #' @describeIn odds_ratio Statistics function which estimates the odds ratio |
||
| 138 | +34 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' between a treatment and a control. A `variables` list with `arm` and `strata` |
||
| 139 | +35 |
- #'+ #' variable names must be passed if a stratified analysis is required. |
||
| 140 | +36 |
- #' @return+ #' |
||
| 141 | +37 |
- #' * `coxph_pairwise()` returns a layout object suitable for passing to further layouting functions,+ #' @return |
||
| 142 | +38 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' * `s_odds_ratio()` returns a named list with the statistics `or_ci` |
||
| 143 | +39 |
- #' the statistics from `s_coxph_pairwise()` to the table layout.+ #' (containing `est`, `lcl`, and `ucl`) and `n_tot`. |
||
| 144 | +40 |
#' |
||
| 145 | +41 |
#' @examples |
||
| 146 | +42 |
- #' library(dplyr)+ #' # Unstratified analysis. |
||
| 147 | +43 |
- #'+ #' s_odds_ratio( |
||
| 148 | +44 |
- #' adtte_f <- tern_ex_adtte %>%+ #' df = subset(dta, grp == "A"), |
||
| 149 | +45 |
- #' filter(PARAMCD == "OS") %>%+ #' .var = "rsp", |
||
| 150 | +46 |
- #' mutate(is_event = CNSR == 0)+ #' .ref_group = subset(dta, grp == "B"), |
||
| 151 | +47 |
- #'+ #' .in_ref_col = FALSE, |
||
| 152 | +48 |
- #' df <- adtte_f %>% filter(ARMCD == "ARM A")+ #' .df_row = dta |
||
| 153 | +49 |
- #' df_ref_group <- adtte_f %>% filter(ARMCD == "ARM B")+ #' ) |
||
| 154 | +50 |
#' |
||
| 155 | +51 |
- #' basic_table() %>%+ #' # Stratified analysis. |
||
| 156 | +52 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ #' s_odds_ratio( |
||
| 157 | +53 |
- #' add_colcounts() %>%+ #' df = subset(dta, grp == "A"), |
||
| 158 | +54 |
- #' coxph_pairwise(+ #' .var = "rsp", |
||
| 159 | +55 |
- #' vars = "AVAL",+ #' .ref_group = subset(dta, grp == "B"), |
||
| 160 | +56 |
- #' is_event = "is_event",+ #' .in_ref_col = FALSE, |
||
| 161 | +57 |
- #' var_labels = "Unstratified Analysis"+ #' .df_row = dta, |
||
| 162 | +58 |
- #' ) %>%+ #' variables = list(arm = "grp", strata = "strata") |
||
| 163 | +59 |
- #' build_table(df = adtte_f)+ #' ) |
||
| 164 | +60 |
#' |
||
| 165 | +61 |
- #' basic_table() %>%+ #' @export |
||
| 166 | +62 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ s_odds_ratio <- function(df, |
||
| 167 | +63 |
- #' add_colcounts() %>%+ .var, |
||
| 168 | +64 |
- #' coxph_pairwise(+ .ref_group, |
||
| 169 | +65 |
- #' vars = "AVAL",+ .in_ref_col, |
||
| 170 | +66 |
- #' is_event = "is_event",+ .df_row, |
||
| 171 | +67 |
- #' var_labels = "Stratified Analysis",+ variables = list(arm = NULL, strata = NULL), |
||
| 172 | +68 |
- #' strata = "SEX",+ conf_level = 0.95, |
||
| 173 | +69 |
- #' control = control_coxph(pval_method = "wald")+ groups_list = NULL, |
||
| 174 | +70 |
- #' ) %>%+ method = "exact") {
|
||
| 175 | -+ | |||
| 71 | +87x |
- #' build_table(df = adtte_f)+ y <- list(or_ci = "", n_tot = "") |
||
| 176 | +72 |
- #'+ |
||
| 177 | -+ | |||
| 73 | +87x |
- #' @export+ if (!.in_ref_col) {
|
||
| 178 | -+ | |||
| 74 | +87x |
- #' @order 2+ assert_proportion_value(conf_level) |
||
| 179 | -+ | |||
| 75 | +87x |
- coxph_pairwise <- function(lyt,+ assert_df_with_variables(df, list(rsp = .var)) |
||
| 180 | -+ | |||
| 76 | +87x |
- vars,+ assert_df_with_variables(.ref_group, list(rsp = .var)) |
||
| 181 | +77 |
- strata = NULL,+ |
||
| 182 | -+ | |||
| 78 | +87x |
- control = control_coxph(),+ if (is.null(variables$strata)) {
|
||
| 183 | -+ | |||
| 79 | +72x |
- na_str = default_na_str(),+ data <- data.frame( |
||
| 184 | -+ | |||
| 80 | +72x |
- nested = TRUE,+ rsp = c(.ref_group[[.var]], df[[.var]]), |
||
| 185 | -+ | |||
| 81 | +72x |
- ...,+ grp = factor( |
||
| 186 | -+ | |||
| 82 | +72x |
- var_labels = "CoxPH",+ rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
|
||
| 187 | -+ | |||
| 83 | +72x |
- show_labels = "visible",+ levels = c("ref", "Not-ref")
|
||
| 188 | +84 |
- table_names = vars,+ ) |
||
| 189 | +85 |
- .stats = c("pvalue", "hr", "hr_ci"),
+ ) |
||
| 190 | -+ | |||
| 86 | +72x |
- .formats = NULL,+ y <- or_glm(data, conf_level = conf_level) |
||
| 191 | +87 |
- .labels = NULL,+ } else {
|
||
| 192 | -+ | |||
| 88 | +15x |
- .indent_mods = NULL) {
+ assert_df_with_variables(.df_row, c(list(rsp = .var), variables)) |
||
| 193 | -5x | +89 | +15x |
- extra_args <- list(strata = strata, control = control, ...)+ checkmate::assert_subset(method, c("exact", "approximate", "efron", "breslow"), empty.ok = FALSE)
|
| 194 | +90 | |||
| 195 | -5x | +|||
| 91 | +
- afun <- make_afun(+ # The group variable prepared for clogit must be synchronised with combination groups definition. |
|||
| 196 | -5x | +92 | +15x |
- a_coxph_pairwise,+ if (is.null(groups_list)) {
|
| 197 | -5x | +93 | +14x |
- .stats = .stats,+ ref_grp <- as.character(unique(.ref_group[[variables$arm]])) |
| 198 | -5x | +94 | +14x |
- .formats = .formats,+ trt_grp <- as.character(unique(df[[variables$arm]])) |
| 199 | -5x | +95 | +14x |
- .labels = .labels,+ grp <- stats::relevel(factor(.df_row[[variables$arm]]), ref = ref_grp) |
| 200 | -5x | +|||
| 96 | +
- .indent_mods = .indent_mods+ } else {
|
|||
| 201 | +97 |
- )+ # If more than one level in reference col. |
||
| 202 | -5x | +98 | +1x |
- analyze(+ reference <- as.character(unique(.ref_group[[variables$arm]])) |
| 203 | -5x | +99 | +1x |
- lyt,+ grp_ref_flag <- vapply( |
| 204 | -5x | +100 | +1x |
- vars,+ X = groups_list, |
| 205 | -5x | +101 | +1x |
- var_labels = var_labels,+ FUN.VALUE = TRUE, |
| 206 | -5x | +102 | +1x |
- show_labels = show_labels,+ FUN = function(x) all(reference %in% x) |
| 207 | -5x | +|||
| 103 | +
- table_names = table_names,+ ) |
|||
| 208 | -5x | +104 | +1x |
- afun = afun,+ ref_grp <- names(groups_list)[grp_ref_flag] |
| 209 | -5x | +|||
| 105 | +
- na_str = na_str,+ + |
+ |||
| 106 | ++ |
+ # If more than one level in treatment col. |
||
| 210 | -5x | +107 | +1x |
- nested = nested,+ treatment <- as.character(unique(df[[variables$arm]])) |
| 211 | -5x | +108 | +1x |
- extra_args = extra_args+ grp_trt_flag <- vapply( |
| 212 | -+ | |||
| 109 | +1x |
- )+ X = groups_list, |
||
| 213 | -+ | |||
| 110 | +1x |
- }+ FUN.VALUE = TRUE, |
| 1 | -+ | |||
| 111 | +1x |
- #' Tabulate binary response by subgroup+ FUN = function(x) all(treatment %in% x) |
||
| 2 | +112 |
- #'+ ) |
||
| 3 | -+ | |||
| 113 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ trt_grp <- names(groups_list)[grp_trt_flag] |
||
| 4 | +114 |
- #'+ |
||
| 5 | -+ | |||
| 115 | +1x |
- #' The [tabulate_rsp_subgroups()] function creates a layout element to tabulate binary response by subgroup, returning+ grp <- combine_levels(.df_row[[variables$arm]], levels = reference, new_level = ref_grp) |
||
| 6 | -+ | |||
| 116 | +1x |
- #' statistics including response rate and odds ratio for each population subgroup. The table is created from `df`, a+ grp <- combine_levels(grp, levels = treatment, new_level = trt_grp) |
||
| 7 | +117 |
- #' list of data frames returned by [extract_rsp_subgroups()], with the statistics to include specified via the `vars`+ } |
||
| 8 | +118 |
- #' parameter.+ |
||
| 9 | +119 |
- #'+ # The reference level in `grp` must be the same as in the `rtables` column split. |
||
| 10 | -+ | |||
| 120 | +15x |
- #' A forest plot can be created from the resulting table using the [g_forest()] function.+ data <- data.frame( |
||
| 11 | -+ | |||
| 121 | +15x |
- #'+ rsp = .df_row[[.var]], |
||
| 12 | -+ | |||
| 122 | +15x |
- #' @inheritParams extract_rsp_subgroups+ grp = grp, |
||
| 13 | -+ | |||
| 123 | +15x |
- #' @inheritParams argument_convention+ strata = interaction(.df_row[variables$strata]) |
||
| 14 | +124 |
- #'+ ) |
||
| 15 | -+ | |||
| 125 | +15x |
- #' @details These functions create a layout starting from a data frame which contains+ y_all <- or_clogit(data, conf_level = conf_level, method = method) |
||
| 16 | -+ | |||
| 126 | +15x |
- #' the required statistics. Tables typically used as part of forest plot.+ checkmate::assert_string(trt_grp) |
||
| 17 | -+ | |||
| 127 | +15x |
- #'+ checkmate::assert_subset(trt_grp, names(y_all$or_ci)) |
||
| 18 | -+ | |||
| 128 | +14x |
- #' @seealso [extract_rsp_subgroups()]+ y$or_ci <- y_all$or_ci[[trt_grp]] |
||
| 19 | -+ | |||
| 129 | +14x |
- #'+ y$n_tot <- y_all$n_tot |
||
| 20 | +130 |
- #' @examples+ } |
||
| 21 | +131 |
- #' library(dplyr)+ } |
||
| 22 | +132 |
- #' library(forcats)+ |
||
| 23 | -+ | |||
| 133 | +86x |
- #'+ if ("est" %in% names(y$or_ci) && is.na(y$or_ci[["est"]]) && method != "approximate") {
|
||
| 24 | -+ | |||
| 134 | +1x |
- #' adrs <- tern_ex_adrs+ warning( |
||
| 25 | -+ | |||
| 135 | +1x |
- #' adrs_labels <- formatters::var_labels(adrs)+ "Unable to compute the odds ratio estimate. Please try re-running the function with ", |
||
| 26 | -+ | |||
| 136 | +1x |
- #'+ 'parameter `method` set to "approximate".' |
||
| 27 | +137 |
- #' adrs_f <- adrs %>%+ ) |
||
| 28 | +138 |
- #' filter(PARAMCD == "BESRSPI") %>%+ } |
||
| 29 | +139 |
- #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+
|
||
| 30 | -+ | |||
| 140 | +86x |
- #' droplevels() %>%+ y$or_ci <- formatters::with_label( |
||
| 31 | -+ | |||
| 141 | +86x |
- #' mutate(+ x = y$or_ci, |
||
| 32 | -+ | |||
| 142 | +86x |
- #' # Reorder levels of factor to make the placebo group the reference arm.+ label = paste0("Odds Ratio (", 100 * conf_level, "% CI)")
|
||
| 33 | +143 |
- #' ARM = fct_relevel(ARM, "B: Placebo"),+ ) |
||
| 34 | +144 |
- #' rsp = AVALC == "CR"+ |
||
| 35 | -+ | |||
| 145 | +86x |
- #' )+ y$n_tot <- formatters::with_label( |
||
| 36 | -+ | |||
| 146 | +86x |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ x = y$n_tot, |
||
| 37 | -+ | |||
| 147 | +86x |
- #'+ label = "Total n" |
||
| 38 | +148 |
- #' # Unstratified analysis.+ ) |
||
| 39 | +149 |
- #' df <- extract_rsp_subgroups(+ |
||
| 40 | -+ | |||
| 150 | +86x |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ y |
||
| 41 | +151 |
- #' data = adrs_f+ } |
||
| 42 | +152 |
- #' )+ |
||
| 43 | +153 |
- #' df+ #' @describeIn odds_ratio Formatted analysis function which is used as `afun` in `estimate_odds_ratio()`. |
||
| 44 | +154 |
#' |
||
| 45 | +155 |
- #' # Stratified analysis.+ #' @return |
||
| 46 | +156 |
- #' df_strat <- extract_rsp_subgroups(+ #' * `a_odds_ratio()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 47 | +157 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2"), strata = "STRATA1"),
+ #' |
||
| 48 | +158 |
- #' data = adrs_f+ #' @examples |
||
| 49 | +159 |
- #' )+ #' a_odds_ratio( |
||
| 50 | +160 |
- #' df_strat+ #' df = subset(dta, grp == "A"), |
||
| 51 | +161 |
- #'+ #' .var = "rsp", |
||
| 52 | +162 |
- #' # Grouping of the BMRKR2 levels.+ #' .ref_group = subset(dta, grp == "B"), |
||
| 53 | +163 |
- #' df_grouped <- extract_rsp_subgroups(+ #' .in_ref_col = FALSE, |
||
| 54 | +164 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ #' .df_row = dta |
||
| 55 | +165 |
- #' data = adrs_f,+ #' ) |
||
| 56 | +166 |
- #' groups_lists = list(+ #' |
||
| 57 | +167 |
- #' BMRKR2 = list(+ #' @export |
||
| 58 | +168 |
- #' "low" = "LOW",+ a_odds_ratio <- make_afun( |
||
| 59 | +169 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ s_odds_ratio, |
||
| 60 | +170 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ .formats = c(or_ci = "xx.xx (xx.xx - xx.xx)"), |
||
| 61 | +171 |
- #' )+ .indent_mods = c(or_ci = 1L) |
||
| 62 | +172 |
- #' )+ ) |
||
| 63 | +173 |
- #' )+ |
||
| 64 | +174 |
- #' df_grouped+ #' @describeIn odds_ratio Layout-creating function which can take statistics function arguments |
||
| 65 | +175 |
- #'+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 66 | +176 |
- #' @name response_subgroups+ #' |
||
| 67 | +177 |
- #' @order 1+ #' @return |
||
| 68 | +178 |
- NULL+ #' * `estimate_odds_ratio()` returns a layout object suitable for passing to further layouting functions, |
||
| 69 | +179 |
-
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 70 | +180 |
- #' Prepare response data for population subgroups in data frames+ #' the statistics from `s_odds_ratio()` to the table layout. |
||
| 71 | +181 |
#' |
||
| 72 | +182 |
- #' @description `r lifecycle::badge("stable")`
+ #' @examples |
||
| 73 | +183 |
- #'+ #' set.seed(12) |
||
| 74 | +184 |
- #' Prepares response rates and odds ratios for population subgroups in data frames. Simple wrapper+ #' dta <- data.frame( |
||
| 75 | +185 |
- #' for [h_odds_ratio_subgroups_df()] and [h_proportion_subgroups_df()]. Result is a list of two+ #' rsp = sample(c(TRUE, FALSE), 100, TRUE), |
||
| 76 | +186 |
- #' `data.frames`: `prop` and `or`. `variables` corresponds to the names of variables found in `data`,+ #' grp = factor(rep(c("A", "B"), each = 50), levels = c("A", "B")),
|
||
| 77 | +187 |
- #' passed as a named `list` and requires elements `rsp`, `arm` and optionally `subgroups` and `strata`.+ #' strata = factor(sample(c("C", "D"), 100, TRUE))
|
||
| 78 | +188 |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ #' ) |
||
| 79 | +189 |
#' |
||
| 80 | +190 |
- #' @inheritParams argument_convention+ #' l <- basic_table() %>% |
||
| 81 | +191 |
- #' @inheritParams response_subgroups+ #' split_cols_by(var = "grp", ref_group = "B") %>% |
||
| 82 | +192 |
- #' @param label_all (`string`)\cr label for the total population analysis.+ #' estimate_odds_ratio(vars = "rsp") |
||
| 83 | +193 |
#' |
||
| 84 | +194 |
- #' @return A named list of two elements:+ #' build_table(l, df = dta) |
||
| 85 | +195 |
- #' * `prop`: A `data.frame` containing columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`, `var`,+ #' |
||
| 86 | +196 |
- #' `var_label`, and `row_type`.+ #' @export |
||
| 87 | +197 |
- #' * `or`: A `data.frame` containing columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`,+ #' @order 2 |
||
| 88 | +198 |
- #' `subgroup`, `var`, `var_label`, and `row_type`.+ estimate_odds_ratio <- function(lyt, |
||
| 89 | +199 |
- #'+ vars, |
||
| 90 | +200 |
- #' @seealso [response_subgroups]+ variables = list(arm = NULL, strata = NULL), |
||
| 91 | +201 |
- #'+ conf_level = 0.95, |
||
| 92 | +202 |
- #' @export+ groups_list = NULL, |
||
| 93 | +203 |
- extract_rsp_subgroups <- function(variables,+ na_str = default_na_str(), |
||
| 94 | +204 |
- data,+ nested = TRUE, |
||
| 95 | +205 |
- groups_lists = list(),+ method = "exact", |
||
| 96 | +206 |
- conf_level = 0.95,+ show_labels = "hidden", |
||
| 97 | +207 |
- method = NULL,+ table_names = vars, |
||
| 98 | +208 |
- label_all = "All Patients") {
- |
- ||
| 99 | -14x | -
- if ("strat" %in% names(variables)) {
- |
- ||
| 100 | -! | -
- warning(+ var_labels = vars, |
||
| 101 | -! | +|||
| 209 | +
- "Warning: the `strat` element name of the `variables` list argument to `extract_rsp_subgroups() ",+ .stats = "or_ci", |
|||
| 102 | -! | +|||
| 210 | +
- "was deprecated in tern 0.9.4.\n ",+ .formats = NULL, |
|||
| 103 | -! | +|||
| 211 | +
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ .labels = NULL, |
|||
| 104 | +212 |
- )+ .indent_mods = NULL) {
|
||
| 105 | -! | +|||
| 213 | +5x |
- variables[["strata"]] <- variables[["strat"]]+ extra_args <- list(variables = variables, conf_level = conf_level, groups_list = groups_list, method = method) |
||
| 106 | +214 |
- }+ |
||
| 107 | -+ | |||
| 215 | +5x |
-
+ afun <- make_afun( |
||
| 108 | -14x | +216 | +5x |
- df_prop <- h_proportion_subgroups_df(+ a_odds_ratio, |
| 109 | -14x | +217 | +5x |
- variables,+ .stats = .stats, |
| 110 | -14x | +218 | +5x |
- data,+ .formats = .formats, |
| 111 | -14x | +219 | +5x |
- groups_lists = groups_lists,+ .labels = .labels, |
| 112 | -14x | +220 | +5x |
- label_all = label_all+ .indent_mods = .indent_mods |
| 113 | +221 |
) |
||
| 114 | -14x | +|||
| 222 | +
- df_or <- h_odds_ratio_subgroups_df(+ |
|||
| 115 | -14x | +223 | +5x |
- variables,+ analyze( |
| 116 | -14x | +224 | +5x |
- data,+ lyt, |
| 117 | -14x | +225 | +5x |
- groups_lists = groups_lists,+ vars, |
| 118 | -14x | +226 | +5x |
- conf_level = conf_level,+ afun = afun, |
| 119 | -14x | +227 | +5x |
- method = method,+ var_labels = var_labels, |
| 120 | -14x | -
- label_all = label_all- |
- ||
| 121 | -+ | 228 | +5x |
- )+ na_str = na_str, |
| 122 | -+ | |||
| 229 | +5x |
-
+ nested = nested, |
||
| 123 | -14x | +230 | +5x |
- list(prop = df_prop, or = df_or)+ extra_args = extra_args, |
| 124 | -+ | |||
| 231 | +5x |
- }+ show_labels = show_labels, |
||
| 125 | -+ | |||
| 232 | +5x |
-
+ table_names = table_names |
||
| 126 | +233 |
- #' @describeIn response_subgroups Formatted analysis function which is used as `afun` in `tabulate_rsp_subgroups()`.+ ) |
||
| 127 | +234 |
- #'+ } |
||
| 128 | +235 |
- #' @return+ |
||
| 129 | +236 |
- #' * `a_response_subgroups()` returns the corresponding list with formatted [rtables::CellValue()].+ #' Helper functions for odds ratio estimation |
||
| 130 | +237 |
#' |
||
| 131 | -- |
- #' @keywords internal- |
- ||
| 132 | -- |
- a_response_subgroups <- function(.formats = list(- |
- ||
| 133 | -- |
- n = "xx", # nolint start- |
- ||
| 134 | +238 |
- n_rsp = "xx",+ #' @description `r lifecycle::badge("stable")`
|
||
| 135 | +239 |
- prop = "xx.x%",+ #' |
||
| 136 | +240 |
- n_tot = "xx",+ #' Functions to calculate odds ratios in [estimate_odds_ratio()]. |
||
| 137 | +241 |
- or = list(format_extreme_values(2L)),+ #' |
||
| 138 | +242 |
- ci = list(format_extreme_values_ci(2L)),+ #' @inheritParams odds_ratio |
||
| 139 | +243 |
- pval = "x.xxxx | (<0.0001)",+ #' @inheritParams argument_convention |
||
| 140 | +244 |
- riskdiff = "xx.x (xx.x - xx.x)" # nolint end+ #' @param data (`data.frame`)\cr data frame containing at least the variables `rsp` and `grp`, and optionally |
||
| 141 | +245 |
- ),+ #' `strata` for [or_clogit()]. |
||
| 142 | +246 |
- 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")
+ #' |
||
| 147 | +247 |
- )+ #' @return A named `list` of elements `or_ci` and `n_tot`. |
||
| 148 | +248 | - - | -||
| 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+ #' |
||
| 157 | +249 |
- )+ #' @seealso [odds_ratio] |
||
| 158 | +250 |
- }+ #' |
||
| 159 | +251 |
- },- |
- ||
| 160 | -22x | -
- stat = names(.formats),- |
- ||
| 161 | -22x | -
- fmt = .formats,- |
- ||
| 162 | -22x | -
- na_str = na_str+ #' @name h_odds_ratio |
||
| 163 | +252 |
- )+ NULL |
||
| 164 | +253 | |||
| 165 | -22x | -
- afun_lst- |
- ||
| 166 | +254 |
- }+ #' @describeIn h_odds_ratio Estimates the odds ratio based on [stats::glm()]. Note that there must be |
||
| 167 | +255 |
-
+ #' exactly 2 groups in `data` as specified by the `grp` variable. |
||
| 168 | +256 |
- #' @describeIn response_subgroups Table-creating function which creates a table+ #' |
||
| 169 | +257 |
- #' summarizing binary response by subgroup. This function is a wrapper for [rtables::analyze_colvars()]+ #' @examples |
||
| 170 | +258 |
- #' and [rtables::summarize_row_groups()].+ #' # Data with 2 groups. |
||
| 171 | +259 |
- #'+ #' data <- data.frame( |
||
| 172 | +260 |
- #' @param df (`list`)\cr a list of data frames containing all analysis variables. List should be+ #' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1)), |
||
| 173 | +261 |
- #' created using [extract_rsp_subgroups()].+ #' grp = letters[c(1, 1, 1, 2, 2, 2, 1, 2)], |
||
| 174 | +262 |
- #' @param vars (`character`)\cr the names of statistics to be reported among:+ #' strata = letters[c(1, 2, 1, 2, 2, 2, 1, 2)], |
||
| 175 | +263 |
- #' * `n`: Total number of observations per group.+ #' stringsAsFactors = TRUE |
||
| 176 | +264 |
- #' * `n_rsp`: Number of responders per group.+ #' ) |
||
| 177 | +265 |
- #' * `prop`: Proportion of responders.+ #' |
||
| 178 | +266 |
- #' * `n_tot`: Total number of observations.+ #' # Odds ratio based on glm. |
||
| 179 | +267 |
- #' * `or`: Odds ratio.+ #' or_glm(data, conf_level = 0.95) |
||
| 180 | +268 |
- #' * `ci` : Confidence interval of odds ratio.+ #' |
||
| 181 | +269 |
- #' * `pval`: p-value of the effect.+ #' @export |
||
| 182 | +270 |
- #' Note, the statistics `n_tot`, `or`, and `ci` are required.+ or_glm <- function(data, conf_level) {
|
||
| 183 | -+ | |||
| 271 | +77x |
- #' @param riskdiff (`list`)\cr if a risk (proportion) difference column should be added, a list of settings to apply+ checkmate::assert_logical(data$rsp) |
||
| 184 | -+ | |||
| 272 | +77x |
- #' within the column. See [control_riskdiff()] for details. If `NULL`, no risk difference column will be added. If+ assert_proportion_value(conf_level) |
||
| 185 | -+ | |||
| 273 | +77x |
- #' `riskdiff$arm_x` and `riskdiff$arm_y` are `NULL`, the first level of `df$prop$arm` will be used as `arm_x` and+ assert_df_with_variables(data, list(rsp = "rsp", grp = "grp")) |
||
| 186 | -+ | |||
| 274 | +77x |
- #' the second level as `arm_y`.+ checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
|
||
| 187 | +275 |
- #'+ |
||
| 188 | -+ | |||
| 276 | +77x |
- #' @return An `rtables` table summarizing binary response by subgroup.+ data$grp <- as_factor_keep_attributes(data$grp) |
||
| 189 | -+ | |||
| 277 | +77x |
- #'+ assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2) |
||
| 190 | -+ | |||
| 278 | +77x |
- #' @examples+ formula <- stats::as.formula("rsp ~ grp")
|
||
| 191 | -+ | |||
| 279 | +77x |
- #' # Table with default columns+ model_fit <- stats::glm( |
||
| 192 | -+ | |||
| 280 | +77x |
- #' basic_table() %>%+ formula = formula, data = data, |
||
| 193 | -+ | |||
| 281 | +77x |
- #' tabulate_rsp_subgroups(df)+ family = stats::binomial(link = "logit") |
||
| 194 | +282 |
- #'+ ) |
||
| 195 | +283 |
- #' # Table with selected columns+ |
||
| 196 | +284 |
- #' basic_table() %>%+ # Note that here we need to discard the intercept. |
||
| 197 | -+ | |||
| 285 | +77x |
- #' tabulate_rsp_subgroups(+ or <- exp(stats::coef(model_fit)[-1]) |
||
| 198 | -+ | |||
| 286 | +77x |
- #' df = df,+ or_ci <- exp( |
||
| 199 | -+ | |||
| 287 | +77x |
- #' vars = c("n_tot", "n", "n_rsp", "prop", "or", "ci")
+ stats::confint.default(model_fit, level = conf_level)[-1, , drop = FALSE] |
||
| 200 | +288 |
- #' )+ ) |
||
| 201 | +289 |
- #'+ |
||
| 202 | -+ | |||
| 290 | +77x |
- #' # Table with risk difference column added+ values <- stats::setNames(c(or, or_ci), c("est", "lcl", "ucl"))
|
||
| 203 | -+ | |||
| 291 | +77x |
- #' basic_table() %>%+ n_tot <- stats::setNames(nrow(model_fit$model), "n_tot") |
||
| 204 | +292 |
- #' tabulate_rsp_subgroups(+ |
||
| 205 | -+ | |||
| 293 | +77x |
- #' df,+ list(or_ci = values, n_tot = n_tot) |
||
| 206 | +294 |
- #' riskdiff = control_riskdiff(+ } |
||
| 207 | +295 |
- #' arm_x = levels(df$prop$arm)[1],+ |
||
| 208 | +296 |
- #' arm_y = levels(df$prop$arm)[2]+ #' @describeIn h_odds_ratio Estimates the odds ratio based on [survival::clogit()]. This is done for |
||
| 209 | +297 |
- #' )+ #' the whole data set including all groups, since the results are not the same as when doing |
||
| 210 | +298 |
- #' )+ #' pairwise comparisons between the groups. |
||
| 211 | +299 |
#' |
||
| 212 | +300 |
- #' @export+ #' @examples |
||
| 213 | +301 |
- #' @order 2+ #' # Data with 3 groups. |
||
| 214 | +302 |
- tabulate_rsp_subgroups <- function(lyt,+ #' data <- data.frame( |
||
| 215 | +303 |
- df,+ #' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0)), |
||
| 216 | +304 |
- vars = c("n_tot", "n", "prop", "or", "ci"),
+ #' grp = letters[c(1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3)], |
||
| 217 | +305 |
- groups_lists = list(),+ #' strata = LETTERS[c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)], |
||
| 218 | +306 |
- label_all = "All Patients",+ #' stringsAsFactors = TRUE |
||
| 219 | +307 |
- riskdiff = NULL,+ #' ) |
||
| 220 | +308 |
- na_str = default_na_str(),+ #' |
||
| 221 | +309 |
- .formats = c(+ #' # Odds ratio based on stratified estimation by conditional logistic regression. |
||
| 222 | +310 |
- n = "xx", n_rsp = "xx", prop = "xx.x%", n_tot = "xx",+ #' or_clogit(data, conf_level = 0.95) |
||
| 223 | +311 |
- or = list(format_extreme_values(2L)), ci = list(format_extreme_values_ci(2L)),+ #' |
||
| 224 | +312 |
- pval = "x.xxxx | (<0.0001)"+ #' @export |
||
| 225 | +313 |
- )) {
- |
- ||
| 226 | -13x | -
- checkmate::assert_list(riskdiff, null.ok = TRUE)- |
- ||
| 227 | -13x | -
- checkmate::assert_true(all(c("n_tot", "or", "ci") %in% vars))
+ or_clogit <- function(data, conf_level, method = "exact") {
|
||
| 228 | -13x | +314 | +19x |
- if ("pval" %in% vars && !"pval" %in% names(df$or)) {
+ checkmate::assert_logical(data$rsp) |
| 229 | -1x | +315 | +19x |
- warning(+ assert_proportion_value(conf_level) |
| 230 | -1x | +316 | +19x |
- 'The "pval" statistic has been selected but is not present in "df" so it will not be included in the output ',+ assert_df_with_variables(data, list(rsp = "rsp", grp = "grp", strata = "strata")) |
| 231 | -1x | +317 | +19x |
- 'table. To include the "pval" statistic, please specify a p-value test when generating "df" via ',+ checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
|
| 232 | -1x | +318 | +19x |
- 'the "method" argument to `extract_rsp_subgroups()`. If method = "cmh", strata must also be specified via the ',+ checkmate::assert_multi_class(data$strata, classes = c("factor", "character"))
|
| 233 | -1x | -
- '"variables" argument to `extract_rsp_subgroups()`.'- |
- ||
| 234 | -- |
- )- |
- ||
| 235 | -+ | 319 | +19x |
- }+ checkmate::assert_subset(method, c("exact", "approximate", "efron", "breslow"), empty.ok = FALSE)
|
| 236 | +320 | |||
| 237 | -+ | |||
| 321 | +19x |
- # Create "ci" column from "lcl" and "ucl"+ data$grp <- as_factor_keep_attributes(data$grp) |
||
| 238 | -13x | +322 | +19x |
- df$or$ci <- combine_vectors(df$or$lcl, df$or$ucl)+ data$strata <- as_factor_keep_attributes(data$strata) |
| 239 | +323 | |||
| 240 | +324 |
- # Fill in missing formats with defaults+ # Deviation from convention: `survival::strata` must be simply `strata`. |
||
| 241 | -13x | +325 | +19x |
- default_fmts <- eval(formals(tabulate_rsp_subgroups)$.formats)+ formula <- stats::as.formula("rsp ~ grp + strata(strata)")
|
| 242 | -13x | +326 | +19x |
- .formats <- c(.formats, default_fmts[vars[!vars %in% names(.formats)]])+ model_fit <- clogit_with_tryCatch(formula = formula, data = data, method = method) |
| 243 | +327 | |||
| 244 | +328 |
- # Extract additional parameters from df+ # Create a list with one set of OR estimates and CI per coefficient, i.e. |
||
| 245 | -13x | +|||
| 329 | +
- conf_level <- df$or$conf_level[1]+ # comparison of one group vs. the reference group. |
|||
| 246 | -13x | +330 | +19x |
- method <- if ("pval_label" %in% names(df$or)) df$or$pval_label[1] else NULL
+ coef_est <- stats::coef(model_fit) |
| 247 | -13x | +331 | +19x |
- colvars <- d_rsp_subgroups_colvars(vars, conf_level = conf_level, method = method)+ ci_est <- stats::confint(model_fit, level = conf_level) |
| 248 | -13x | +332 | +19x |
- prop_vars <- intersect(colvars$vars, c("n", "prop", "n_rsp"))
+ or_ci <- list() |
| 249 | -13x | +333 | +19x |
- or_vars <- intersect(names(colvars$labels), c("n_tot", "or", "ci", "pval"))
+ for (coef_name in names(coef_est)) {
|
| 250 | -13x | +334 | +21x |
- colvars_prop <- list(vars = prop_vars, labels = colvars$labels[prop_vars])+ grp_name <- gsub("^grp", "", x = coef_name)
|
| 251 | -13x | +335 | +21x |
- colvars_or <- list(vars = or_vars, labels = colvars$labels[or_vars])+ or_ci[[grp_name]] <- stats::setNames( |
| 252 | -+ | |||
| 336 | +21x |
-
+ object = exp(c(coef_est[coef_name], ci_est[coef_name, , drop = TRUE])), |
||
| 253 | -13x | +337 | +21x |
- extra_args <- list(groups_lists = groups_lists, conf_level = conf_level, method = method, label_all = label_all)+ nm = c("est", "lcl", "ucl")
|
| 254 | +338 |
-
+ ) |
||
| 255 | +339 |
- # Get analysis function for each statistic+ } |
||
| 256 | -13x | +340 | +19x |
- afun_lst <- a_response_subgroups(.formats = c(.formats, riskdiff = riskdiff$format), na_str = na_str)+ list(or_ci = or_ci, n_tot = c(n_tot = model_fit$n)) |
| 257 | +341 |
-
+ } |
| 258 | +1 |
- # Add risk difference column- |
- ||
| 259 | -13x | -
- 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]- |
- ||
| 262 | -1x | -
- colvars_or$vars <- c(colvars_or$vars, "riskdiff")- |
- ||
| 263 | -1x | -
- colvars_or$labels <- c(colvars_or$labels, riskdiff = riskdiff$col_label)- |
- ||
| 264 | -1x | -
- arm_cols <- paste(rep(c("n_rsp", "n_rsp", "n", "n")), c(riskdiff$arm_x, riskdiff$arm_y), sep = "_")
+ #' Control function for Cox regression |
||
| 265 | +2 | - - | -||
| 266 | -1x | -
- df_prop_diff <- df$prop %>%- |
- ||
| 267 | -1x | -
- dplyr::select(-"prop") %>%- |
- ||
| 268 | -1x | -
- tidyr::pivot_wider(- |
- ||
| 269 | -1x | -
- id_cols = c("subgroup", "var", "var_label", "row_type"),
- |
- ||
| 270 | -1x | -
- names_from = "arm",+ #' |
||
| 271 | -1x | +|||
| 3 | +
- values_from = c("n", "n_rsp")
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 272 | +4 |
- ) %>%+ #' |
||
| 273 | -1x | +|||
| 5 | +
- dplyr::rowwise() %>%+ #' Sets a list of parameters for Cox regression fit. Used internally. |
|||
| 274 | -1x | +|||
| 6 | +
- dplyr::mutate(+ #' |
|||
| 275 | -1x | +|||
| 7 | +
- riskdiff = stat_propdiff_ci(+ #' @inheritParams argument_convention |
|||
| 276 | -1x | +|||
| 8 | +
- x = as.list(.data[[arm_cols[1]]]),+ #' @param pval_method (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`. |
|||
| 277 | -1x | +|||
| 9 | +
- y = as.list(.data[[arm_cols[2]]]),+ #' @param interaction (`flag`)\cr if `TRUE`, the model includes the interaction between the studied |
|||
| 278 | -1x | +|||
| 10 | +
- N_x = .data[[arm_cols[3]]],+ #' treatment and candidate covariate. Note that for univariate models without treatment arm, and |
|||
| 279 | -1x | +|||
| 11 | +
- N_y = .data[[arm_cols[4]]]+ #' multivariate models, no interaction can be used so that this needs to be `FALSE`. |
|||
| 280 | +12 |
- )+ #' @param ties (`string`)\cr among `exact` (equivalent to `DISCRETE` in SAS), `efron` and `breslow`, |
||
| 281 | +13 |
- ) %>%+ #' see [survival::coxph()]. Note: there is no equivalent of SAS `EXACT` method in R. |
||
| 282 | -1x | +|||
| 14 | +
- dplyr::select(-dplyr::all_of(arm_cols))+ #' |
|||
| 283 | +15 |
-
+ #' @return A `list` of items with names corresponding to the arguments. |
||
| 284 | -1x | +|||
| 16 | +
- df$or <- df$or %>%+ #' |
|||
| 285 | -1x | +|||
| 17 | +
- dplyr::left_join(+ #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()]. |
|||
| 286 | -1x | +|||
| 18 | +
- df_prop_diff,+ #' |
|||
| 287 | -1x | +|||
| 19 | +
- by = c("subgroup", "var", "var_label", "row_type")
+ #' @examples |
|||
| 288 | +20 |
- )+ #' control_coxreg() |
||
| 289 | +21 |
- }+ #' |
||
| 290 | +22 |
-
+ #' @export |
||
| 291 | +23 |
- # Add columns from table_prop (optional)+ control_coxreg <- function(pval_method = c("wald", "likelihood"),
|
||
| 292 | -13x | +|||
| 24 | +
- if (length(colvars_prop$vars) > 0) {
+ ties = c("exact", "efron", "breslow"),
|
|||
| 293 | -12x | +|||
| 25 | +
- lyt_prop <- split_cols_by(lyt = lyt, var = "arm")+ conf_level = 0.95, |
|||
| 294 | -12x | +|||
| 26 | +
- lyt_prop <- split_cols_by_multivar(+ interaction = FALSE) {
|
|||
| 295 | -12x | +27 | +55x |
- lyt = lyt_prop,+ pval_method <- match.arg(pval_method) |
| 296 | -12x | +28 | +55x |
- vars = colvars_prop$vars,+ ties <- match.arg(ties) |
| 297 | -12x | -
- varlabels = colvars_prop$labels- |
- ||
| 298 | -- |
- )- |
- ||
| 299 | -- | - - | -||
| 300 | -+ | 29 | +55x |
- # Add "All Patients" row+ checkmate::assert_flag(interaction) |
| 301 | -12x | +30 | +55x |
- lyt_prop <- split_rows_by(+ assert_proportion_value(conf_level) |
| 302 | -12x | +31 | +55x |
- lyt = lyt_prop,+ list( |
| 303 | -12x | +32 | +55x |
- var = "row_type",+ pval_method = pval_method, |
| 304 | -12x | +33 | +55x |
- split_fun = keep_split_levels("content"),
+ ties = ties, |
| 305 | -12x | +34 | +55x |
- nested = FALSE,+ conf_level = conf_level, |
| 306 | -12x | +35 | +55x |
- child_labels = "hidden"+ interaction = interaction |
| 307 | +36 |
- )+ ) |
||
| 308 | -12x | +|||
| 37 | +
- lyt_prop <- analyze_colvars(+ } |
|||
| 309 | -12x | +|||
| 38 | +
- lyt = lyt_prop,+ |
|||
| 310 | -12x | +|||
| 39 | +
- afun = afun_lst[names(colvars_prop$labels)],+ #' Custom tidy methods for Cox regression |
|||
| 311 | -12x | +|||
| 40 | +
- na_str = na_str,+ #' |
|||
| 312 | -12x | +|||
| 41 | +
- extra_args = extra_args+ #' @description `r lifecycle::badge("stable")`
|
|||
| 313 | +42 |
- )+ #' |
||
| 314 | +43 |
-
+ #' @inheritParams argument_convention |
||
| 315 | +44 |
- # Add analysis rows+ #' @param x (`list`)\cr result of the Cox regression model fitted by [fit_coxreg_univar()] (for univariate models) |
||
| 316 | -12x | +|||
| 45 | +
- if ("analysis" %in% df$prop$row_type) {
+ #' or [fit_coxreg_multivar()] (for multivariate models). |
|||
| 317 | -11x | +|||
| 46 | +
- lyt_prop <- split_rows_by(+ #' |
|||
| 318 | -11x | +|||
| 47 | +
- lyt = lyt_prop,+ #' @return [broom::tidy()] returns: |
|||
| 319 | -11x | +|||
| 48 | +
- var = "row_type",+ #' * For `summary.coxph` objects, a `data.frame` with columns: `Pr(>|z|)`, `exp(coef)`, `exp(-coef)`, `lower .95`, |
|||
| 320 | -11x | +|||
| 49 | +
- split_fun = keep_split_levels("analysis"),
+ #' `upper .95`, `level`, and `n`. |
|||
| 321 | -11x | +|||
| 50 | +
- nested = FALSE,+ #' * For `coxreg.univar` objects, a `data.frame` with columns: `effect`, `term`, `term_label`, `level`, `n`, `hr`, |
|||
| 322 | -11x | +|||
| 51 | +
- child_labels = "hidden"+ #' `lcl`, `ucl`, `pval`, and `ci`. |
|||
| 323 | +52 |
- )+ #' * For `coxreg.multivar` objects, a `data.frame` with columns: `term`, `pval`, `term_label`, `hr`, `lcl`, `ucl`, |
||
| 324 | -11x | +|||
| 53 | +
- lyt_prop <- split_rows_by(lyt = lyt_prop, var = "var_label", nested = TRUE)+ #' `level`, and `ci`. |
|||
| 325 | -11x | +|||
| 54 | +
- lyt_prop <- analyze_colvars(+ #' |
|||
| 326 | -11x | +|||
| 55 | +
- lyt = lyt_prop,+ #' @seealso [cox_regression] |
|||
| 327 | -11x | +|||
| 56 | +
- afun = afun_lst[names(colvars_prop$labels)],+ #' |
|||
| 328 | -11x | +|||
| 57 | +
- na_str = na_str,+ #' @name tidy_coxreg |
|||
| 329 | -11x | +|||
| 58 | +
- inclNAs = TRUE,+ NULL |
|||
| 330 | -11x | +|||
| 59 | +
- extra_args = extra_args+ |
|||
| 331 | +60 |
- )+ #' @describeIn tidy_coxreg Custom tidy method for [survival::coxph()] summary results. |
||
| 332 | +61 |
- }+ #' |
||
| 333 | +62 |
-
+ #' Tidy the [survival::coxph()] results into a `data.frame` to extract model results. |
||
| 334 | -12x | +|||
| 63 | +
- table_prop <- build_table(lyt_prop, df = df$prop)+ #' |
|||
| 335 | +64 |
- } else {
+ #' @method tidy summary.coxph |
||
| 336 | -1x | +|||
| 65 | +
- table_prop <- NULL+ #' |
|||
| 337 | +66 |
- }+ #' @examples |
||
| 338 | +67 |
-
+ #' library(survival) |
||
| 339 | +68 |
- # Add columns from table_or ("n_tot", "or", and "ci" required)
+ #' library(broom) |
||
| 340 | -13x | +|||
| 69 | +
- lyt_or <- split_cols_by(lyt = lyt, var = "arm")+ #' |
|||
| 341 | -13x | +|||
| 70 | +
- lyt_or <- split_cols_by_multivar(+ #' set.seed(1, kind = "Mersenne-Twister") |
|||
| 342 | -13x | +|||
| 71 | +
- lyt = lyt_or,+ #' |
|||
| 343 | -13x | +|||
| 72 | +
- vars = colvars_or$vars,+ #' dta_bladder <- with( |
|||
| 344 | -13x | +|||
| 73 | +
- varlabels = colvars_or$labels+ #' data = bladder[bladder$enum < 5, ], |
|||
| 345 | +74 |
- )+ #' data.frame( |
||
| 346 | +75 |
-
+ #' time = stop, |
||
| 347 | +76 |
- # Add "All Patients" row+ #' status = event, |
||
| 348 | -13x | +|||
| 77 | +
- lyt_or <- split_rows_by(+ #' armcd = as.factor(rx), |
|||
| 349 | -13x | +|||
| 78 | +
- lyt = lyt_or,+ #' covar1 = as.factor(enum), |
|||
| 350 | -13x | +|||
| 79 | +
- var = "row_type",+ #' covar2 = factor( |
|||
| 351 | -13x | +|||
| 80 | +
- split_fun = keep_split_levels("content"),
+ #' sample(as.factor(enum)), |
|||
| 352 | -13x | +|||
| 81 | +
- nested = FALSE,+ #' levels = 1:4, labels = c("F", "F", "M", "M")
|
|||
| 353 | -13x | +|||
| 82 | +
- child_labels = "hidden"+ #' ) |
|||
| 354 | +83 |
- )+ #' ) |
||
| 355 | -13x | +|||
| 84 | +
- lyt_or <- analyze_colvars(+ #' ) |
|||
| 356 | -13x | +|||
| 85 | +
- lyt = lyt_or,+ #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
|
|||
| 357 | -13x | +|||
| 86 | +
- afun = afun_lst[names(colvars_or$labels)],+ #' formatters::var_labels(dta_bladder)[names(labels)] <- labels |
|||
| 358 | -13x | +|||
| 87 | +
- na_str = na_str,+ #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
|||
| 359 | -13x | +|||
| 88 | +
- extra_args = extra_args+ #' |
|||
| 360 | +89 |
- ) %>%+ #' formula <- "survival::Surv(time, status) ~ armcd + covar1" |
||
| 361 | -13x | +|||
| 90 | +
- append_topleft("Baseline Risk Factors")
+ #' msum <- summary(coxph(stats::as.formula(formula), data = dta_bladder)) |
|||
| 362 | +91 |
-
+ #' tidy(msum) |
||
| 363 | +92 |
- # Add analysis rows+ #' |
||
| 364 | -13x | +|||
| 93 | +
- if ("analysis" %in% df$or$row_type) {
+ #' @export |
|||
| 365 | -12x | +|||
| 94 | +
- lyt_or <- split_rows_by(+ tidy.summary.coxph <- function(x, # nolint |
|||
| 366 | -12x | +|||
| 95 | +
- lyt = lyt_or,+ ...) {
|
|||
| 367 | -12x | +96 | +199x |
- var = "row_type",+ checkmate::assert_class(x, "summary.coxph") |
| 368 | -12x | +97 | +199x |
- split_fun = keep_split_levels("analysis"),
+ pval <- x$coefficients |
| 369 | -12x | +98 | +199x |
- nested = FALSE,+ confint <- x$conf.int |
| 370 | -12x | +99 | +199x |
- child_labels = "hidden"+ levels <- rownames(pval) |
| 371 | +100 |
- )+ |
||
| 372 | -12x | +101 | +199x |
- lyt_or <- split_rows_by(lyt = lyt_or, var = "var_label", nested = TRUE)+ pval <- tibble::as_tibble(pval) |
| 373 | -12x | +102 | +199x |
- lyt_or <- analyze_colvars(+ confint <- tibble::as_tibble(confint) |
| 374 | -12x | +|||
| 103 | +
- lyt = lyt_or,+ |
|||
| 375 | -12x | +104 | +199x |
- afun = afun_lst[names(colvars_or$labels)],+ ret <- cbind(pval[, grepl("Pr", names(pval))], confint)
|
| 376 | -12x | +105 | +199x |
- na_str = na_str,+ ret$level <- levels |
| 377 | -12x | +106 | +199x |
- inclNAs = TRUE,+ ret$n <- x[["n"]] |
| 378 | -12x | +107 | +199x |
- extra_args = extra_args+ ret |
| 379 | +108 |
- )+ } |
||
| 380 | +109 |
- }+ |
||
| 381 | +110 | - - | -||
| 382 | -13x | -
- table_or <- build_table(lyt_or, df = df$or)+ #' @describeIn tidy_coxreg Custom tidy method for a univariate Cox regression. |
||
| 383 | +111 |
-
+ #' |
||
| 384 | +112 |
- # Join tables, add forest plot attributes- |
- ||
| 385 | -13x | -
- n_tot_id <- match("n_tot", colvars_or$vars)
- |
- ||
| 386 | -13x | -
- if (is.null(table_prop)) {
- |
- ||
| 387 | -1x | -
- result <- table_or- |
- ||
| 388 | -1x | -
- or_id <- match("or", colvars_or$vars)
+ #' Tidy up the result of a Cox regression model fitted by [fit_coxreg_univar()]. |
||
| 389 | -1x | +|||
| 113 | +
- ci_id <- match("ci", colvars_or$vars)
+ #' |
|||
| 390 | +114 |
- } else {
+ #' @method tidy coxreg.univar |
||
| 391 | -12x | +|||
| 115 | +
- result <- cbind_rtables(table_or[, n_tot_id], table_prop, table_or[, -n_tot_id])+ #' |
|||
| 392 | -12x | +|||
| 116 | +
- or_id <- 1L + ncol(table_prop) + match("or", colvars_or$vars[-n_tot_id])
+ #' @examples |
|||
| 393 | -12x | +|||
| 117 | +
- ci_id <- 1L + ncol(table_prop) + match("ci", colvars_or$vars[-n_tot_id])
+ #' ## Cox regression: arm + 1 covariate. |
|||
| 394 | -12x | +|||
| 118 | +
- n_tot_id <- 1L+ #' mod1 <- fit_coxreg_univar( |
|||
| 395 | +119 |
- }+ #' variables = list( |
||
| 396 | -13x | +|||
| 120 | +
- structure(+ #' time = "time", event = "status", arm = "armcd", |
|||
| 397 | -13x | +|||
| 121 | +
- result,+ #' covariates = "covar1" |
|||
| 398 | -13x | +|||
| 122 | +
- forest_header = paste0(levels(df$prop$arm), "\nBetter"),+ #' ), |
|||
| 399 | -13x | +|||
| 123 | +
- col_x = or_id,+ #' data = dta_bladder, |
|||
| 400 | -13x | +|||
| 124 | +
- col_ci = ci_id,+ #' control = control_coxreg(conf_level = 0.91) |
|||
| 401 | -13x | +|||
| 125 | +
- col_symbol_size = n_tot_id+ #' ) |
|||
| 402 | +126 |
- )+ #' |
||
| 403 | +127 |
- }+ #' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates. |
||
| 404 | +128 |
-
+ #' mod2 <- fit_coxreg_univar( |
||
| 405 | +129 |
- #' Labels for column variables in binary response by subgroup table+ #' variables = list( |
||
| 406 | +130 |
- #'+ #' time = "time", event = "status", arm = "armcd", |
||
| 407 | +131 |
- #' @description `r lifecycle::badge("stable")`
+ #' covariates = c("covar1", "covar2")
|
||
| 408 | +132 |
- #'+ #' ), |
||
| 409 | +133 |
- #' Internal function to check variables included in [tabulate_rsp_subgroups()] and create column labels.+ #' data = dta_bladder, |
||
| 410 | +134 |
- #'+ #' control = control_coxreg(conf_level = 0.91, interaction = TRUE) |
||
| 411 | +135 |
- #' @inheritParams argument_convention+ #' ) |
||
| 412 | +136 |
- #' @inheritParams tabulate_rsp_subgroups+ #' |
||
| 413 | +137 |
- #'+ #' tidy(mod1) |
||
| 414 | +138 |
- #' @return A `list` of variables to tabulate and their labels.+ #' tidy(mod2) |
||
| 415 | +139 |
#' |
||
| 416 | +140 |
#' @export |
||
| 417 | +141 |
- d_rsp_subgroups_colvars <- function(vars,+ tidy.coxreg.univar <- function(x, # nolint |
||
| 418 | +142 |
- conf_level = NULL,+ ...) {
|
||
| 419 | -+ | |||
| 143 | +38x |
- method = NULL) {
+ checkmate::assert_class(x, "coxreg.univar") |
||
| 420 | -22x | +144 | +38x |
- checkmate::assert_character(vars)+ mod <- x$mod |
| 421 | -22x | +145 | +38x |
- checkmate::assert_subset(c("n_tot", "or", "ci"), vars)
+ vars <- c(x$vars$arm, x$vars$covariates) |
| 422 | -22x | +146 | +38x |
- checkmate::assert_subset(+ has_arm <- "arm" %in% names(x$vars) |
| 423 | -22x | +|||
| 147 | +
- vars,+ |
|||
| 424 | -22x | +148 | +38x |
- c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
+ result <- if (!has_arm) {
|
| 425 | -+ | |||
| 149 | +5x |
- )+ Map( |
||
| 426 | -+ | |||
| 150 | +5x |
-
+ mod = mod, vars = vars, |
||
| 427 | -22x | +151 | +5x |
- varlabels <- c(+ f = function(mod, vars) {
|
| 428 | -22x | +152 | +6x |
- n = "n",+ h_coxreg_multivar_extract( |
| 429 | -22x | +153 | +6x |
- n_rsp = "Responders",+ var = vars, |
| 430 | -22x | +154 | +6x |
- prop = "Response (%)",+ data = x$data, |
| 431 | -22x | +155 | +6x |
- n_tot = "Total n",+ mod = mod, |
| 432 | -22x | +156 | +6x |
- or = "Odds Ratio"+ control = x$control |
| 433 | +157 |
- )+ ) |
||
| 434 | -22x | +|||
| 158 | +
- colvars <- vars+ } |
|||
| 435 | +159 |
-
+ ) |
||
| 436 | -22x | +160 | +38x |
- if ("ci" %in% colvars) {
+ } else if (x$control$interaction) {
|
| 437 | -22x | +161 | +12x |
- checkmate::assert_false(is.null(conf_level))+ Map( |
| 438 | -+ | |||
| 162 | +12x |
-
+ mod = mod, covar = vars, |
||
| 439 | -22x | +163 | +12x |
- varlabels <- c(+ f = function(mod, covar) {
|
| 440 | -22x | +164 | +26x |
- varlabels,+ h_coxreg_extract_interaction( |
| 441 | -22x | +165 | +26x |
- ci = paste0(100 * conf_level, "% CI")+ effect = x$vars$arm, covar = covar, mod = mod, data = x$data, |
| 442 | -+ | |||
| 166 | +26x |
- )+ at = x$at, control = x$control |
||
| 443 | +167 |
-
+ ) |
||
| 444 | +168 |
- # The `lcl`` variable is just a placeholder available in the analysis data,+ } |
||
| 445 | +169 |
- # it is not acutally used in the tabulation.+ ) |
||
| 446 | +170 |
- # Variables used in the tabulation are lcl and ucl, see `a_response_subgroups` for details.+ } else {
|
||
| 447 | -22x | +171 | +21x |
- colvars[colvars == "ci"] <- "lcl"+ Map( |
| 448 | -+ | |||
| 172 | +21x |
- }+ mod = mod, vars = vars, |
||
| 449 | -+ | |||
| 173 | +21x |
-
+ f = function(mod, vars) {
|
||
| 450 | -22x | +174 | +53x |
- if ("pval" %in% colvars) {
+ h_coxreg_univar_extract( |
| 451 | -16x | +175 | +53x |
- varlabels <- c(+ effect = x$vars$arm, covar = vars, data = x$data, mod = mod, |
| 452 | -16x | +176 | +53x |
- varlabels,+ control = x$control |
| 453 | -16x | +|||
| 177 | +
- pval = method+ ) |
|||
| 454 | +178 | ++ |
+ }+ |
+ |
| 179 |
) |
|||
| 455 | +180 |
} |
||
| 181 | +38x | +
+ result <- do.call(rbind, result)+ |
+ ||
| 456 | +182 | |||
| 457 | -22x | +183 | +38x |
- list(+ result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl)) |
| 458 | -22x | +184 | +38x |
- vars = colvars,+ result$n <- lapply(result$n, empty_vector_if_na) |
| 459 | -22x | +185 | +38x |
- labels = varlabels[vars]+ result$ci <- lapply(result$ci, empty_vector_if_na) |
| 460 | -+ | |||
| 186 | +38x |
- )+ result$hr <- lapply(result$hr, empty_vector_if_na) |
||
| 461 | -+ | |||
| 187 | +38x |
- }+ if (x$control$interaction) {
|
| 1 | -+ | |||
| 188 | +12x |
- #' Count patients by most extreme post-baseline toxicity grade per direction of abnormality+ result$pval_inter <- lapply(result$pval_inter, empty_vector_if_na) |
||
| 2 | +189 |
- #'+ # Remove interaction p-values due to change in specifications. |
||
| 3 | -+ | |||
| 190 | +12x |
- #' @description `r lifecycle::badge("stable")`
+ result$pval[result$effect != "Treatment:"] <- NA |
||
| 4 | +191 |
- #'+ } |
||
| 5 | -+ | |||
| 192 | +38x |
- #' The analyze function [count_abnormal_by_worst_grade()] creates a layout element to count patients by highest (worst)+ result$pval <- lapply(result$pval, empty_vector_if_na) |
||
| 6 | -+ | |||
| 193 | +38x |
- #' analysis toxicity grade post-baseline for each direction, categorized by parameter value.+ attr(result, "conf_level") <- x$control$conf_level |
||
| 7 | -+ | |||
| 194 | +38x |
- #'+ result |
||
| 8 | +195 |
- #' This function analyzes primary analysis variable `var` which indicates toxicity grades. Additional+ } |
||
| 9 | +196 |
- #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to+ |
||
| 10 | +197 |
- #' `USUBJID`), a variable to indicate unique subject identifiers, `param` (defaults to `PARAM`), a variable+ #' @describeIn tidy_coxreg Custom tidy method for a multivariate Cox regression. |
||
| 11 | +198 |
- #' to indicate parameter values, and `grade_dir` (defaults to `GRADE_DIR`), a variable to indicate directions+ #' |
||
| 12 | +199 |
- #' (e.g. High or Low) for each toxicity grade supplied in `var`.+ #' Tidy up the result of a Cox regression model fitted by [fit_coxreg_multivar()]. |
||
| 13 | +200 |
#' |
||
| 14 | +201 |
- #' For each combination of `param` and `grade_dir` levels, patient counts by worst+ #' @method tidy coxreg.multivar |
||
| 15 | +202 |
- #' grade are calculated as follows:+ #' |
||
| 16 | +203 |
- #' * `1` to `4`: The number of patients with worst grades 1-4, respectively.+ #' @examples |
||
| 17 | +204 |
- #' * `Any`: The number of patients with at least one abnormality (i.e. grade is not 0).+ #' multivar_model <- fit_coxreg_multivar( |
||
| 18 | +205 |
- #'+ #' variables = list( |
||
| 19 | +206 |
- #' Fractions are calculated by dividing the above counts by the number of patients with at least one+ #' time = "time", event = "status", arm = "armcd", |
||
| 20 | +207 |
- #' valid measurement recorded during treatment.+ #' covariates = c("covar1", "covar2")
|
||
| 21 | +208 |
- #'+ #' ), |
||
| 22 | +209 |
- #' Pre-processing is crucial when using this function and can be done automatically using the+ #' data = dta_bladder |
||
| 23 | +210 |
- #' [h_adlb_abnormal_by_worst_grade()] helper function. See the description of this function for details on the+ #' ) |
||
| 24 | +211 |
- #' necessary pre-processing steps.+ #' broom::tidy(multivar_model) |
||
| 25 | +212 |
#' |
||
| 26 | +213 |
- #' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create two row+ #' @export |
||
| 27 | +214 |
- #' splits, one on variable `param` and one on variable `grade_dir`.+ tidy.coxreg.multivar <- function(x, # nolint |
||
| 28 | +215 |
- #'+ ...) {
|
||
| 29 | -+ | |||
| 216 | +16x |
- #' @inheritParams argument_convention+ checkmate::assert_class(x, "coxreg.multivar") |
||
| 30 | -+ | |||
| 217 | +16x |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal_by_worst_grade")`
+ vars <- c(x$vars$arm, x$vars$covariates) |
||
| 31 | +218 |
- #' to see available statistics for this function.+ |
||
| 32 | +219 |
- #'+ # Convert the model summaries to data. |
||
| 33 | -+ | |||
| 220 | +16x |
- #' @seealso [h_adlb_abnormal_by_worst_grade()] which pre-processes ADLB data frames to be used in+ result <- Map( |
||
| 34 | -+ | |||
| 221 | +16x |
- #' [count_abnormal_by_worst_grade()].+ vars = vars, |
||
| 35 | -+ | |||
| 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 |
||
| 36 | +226 |
- #' @name abnormal_by_worst_grade+ ) |
||
| 37 | +227 |
- #' @order 1+ } |
||
| 38 | +228 |
- NULL+ )+ |
+ ||
| 229 | +16x | +
+ result <- do.call(rbind, result) |
||
| 39 | +230 | |||
| 40 | -+ | |||
| 231 | +16x |
- #' @describeIn abnormal_by_worst_grade Statistics function which counts patients by worst grade.+ result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl)) |
||
| 41 | -+ | |||
| 232 | +16x |
- #'+ result$ci <- lapply(result$ci, empty_vector_if_na) |
||
| 42 | -+ | |||
| 233 | +16x |
- #' @return+ result$hr <- lapply(result$hr, empty_vector_if_na) |
||
| 43 | -+ | |||
| 234 | +16x |
- #' * `s_count_abnormal_by_worst_grade()` returns the single statistic `count_fraction` with grades 1 to 4 and+ result$pval <- lapply(result$pval, empty_vector_if_na) |
||
| 44 | -+ | |||
| 235 | +16x |
- #' "Any" results.+ result <- result[, names(result) != "n"]+ |
+ ||
| 236 | +16x | +
+ attr(result, "conf_level") <- x$control$conf_level |
||
| 45 | +237 |
- #'+ + |
+ ||
| 238 | +16x | +
+ result |
||
| 46 | +239 |
- #' @keywords internal+ } |
||
| 47 | +240 |
- s_count_abnormal_by_worst_grade <- function(df, # nolint+ |
||
| 48 | +241 |
- .var = "GRADE_ANL",+ #' Fitting functions for Cox proportional hazards regression |
||
| 49 | +242 |
- .spl_context,+ #' |
||
| 50 | +243 |
- variables = list(+ #' @description `r lifecycle::badge("stable")`
|
||
| 51 | +244 |
- id = "USUBJID",+ #' |
||
| 52 | +245 |
- param = "PARAM",+ #' Fitting functions for univariate and multivariate Cox regression models. |
||
| 53 | +246 |
- grade_dir = "GRADE_DIR"+ #' |
||
| 54 | +247 |
- )) {
+ #' @param variables (named `list`)\cr the names of the variables found in `data`, passed as a named list and |
||
| 55 | -1x | +|||
| 248 | +
- checkmate::assert_string(.var)+ #' corresponding to the `time`, `event`, `arm`, `strata`, and `covariates` terms. If `arm` is missing from |
|||
| 56 | -1x | +|||
| 249 | +
- assert_valid_factor(df[[.var]])+ #' `variables`, then only Cox model(s) including the `covariates` will be fitted and the corresponding effect |
|||
| 57 | -1x | +|||
| 250 | +
- assert_valid_factor(df[[variables$param]])+ #' estimates will be tabulated later. |
|||
| 58 | -1x | +|||
| 251 | +
- assert_valid_factor(df[[variables$grade_dir]])+ #' @param data (`data.frame`)\cr the dataset containing the variables to fit the models. |
|||
| 59 | -1x | +|||
| 252 | +
- assert_df_with_variables(df, c(a = .var, variables))+ #' @param at (`list` of `numeric`)\cr when the candidate covariate is a `numeric`, use `at` to specify |
|||
| 60 | -1x | +|||
| 253 | +
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ #' the value of the covariate at which the effect should be estimated. |
|||
| 61 | +254 |
-
+ #' @param control (`list`)\cr a list of parameters as returned by the helper function [control_coxreg()]. |
||
| 62 | +255 |
- # To verify that the `split_rows_by` are performed with correct variables.+ #' |
||
| 63 | -1x | +|||
| 256 | +
- checkmate::assert_subset(c(variables[["param"]], variables[["grade_dir"]]), .spl_context$split)+ #' @seealso [h_cox_regression] for relevant helper functions, [cox_regression]. |
|||
| 64 | -1x | +|||
| 257 | +
- first_row <- .spl_context[.spl_context$split == variables[["param"]], ]+ #' |
|||
| 65 | -1x | +|||
| 258 | +
- x_lvls <- c(setdiff(levels(df[[.var]]), "0"), "Any")+ #' @examples |
|||
| 66 | -1x | +|||
| 259 | +
- result <- split(numeric(0), factor(x_lvls))+ #' library(survival) |
|||
| 67 | +260 |
-
+ #' |
||
| 68 | -1x | +|||
| 261 | +
- subj <- first_row$full_parent_df[[1]][[variables[["id"]]]]+ #' set.seed(1, kind = "Mersenne-Twister") |
|||
| 69 | -1x | +|||
| 262 | +
- subj_cur_col <- subj[first_row$cur_col_subset[[1]]]+ #' |
|||
| 70 | +263 |
- # Some subjects may have a record for high and low directions but+ #' # Testing dataset [survival::bladder]. |
||
| 71 | +264 |
- # should be counted only once.+ #' dta_bladder <- with( |
||
| 72 | -1x | +|||
| 265 | +
- denom <- length(unique(subj_cur_col))+ #' data = bladder[bladder$enum < 5, ], |
|||
| 73 | +266 |
-
+ #' data.frame( |
||
| 74 | -1x | +|||
| 267 | +
- for (lvl in x_lvls) {
+ #' time = stop, |
|||
| 75 | -5x | +|||
| 268 | +
- if (lvl != "Any") {
+ #' status = event, |
|||
| 76 | -4x | +|||
| 269 | +
- df_lvl <- df[df[[.var]] == lvl, ]+ #' armcd = as.factor(rx), |
|||
| 77 | +270 |
- } else {
+ #' covar1 = as.factor(enum), |
||
| 78 | -1x | +|||
| 271 | +
- df_lvl <- df[df[[.var]] != 0, ]+ #' covar2 = factor( |
|||
| 79 | +272 |
- }+ #' sample(as.factor(enum)), |
||
| 80 | -5x | +|||
| 273 | +
- num <- length(unique(df_lvl[[variables[["id"]]]]))+ #' levels = 1:4, labels = c("F", "F", "M", "M")
|
|||
| 81 | -5x | +|||
| 274 | +
- fraction <- ifelse(denom == 0, 0, num / denom)+ #' ) |
|||
| 82 | -5x | +|||
| 275 | +
- result[[lvl]] <- formatters::with_label(c(count = num, fraction = fraction), lvl)+ #' ) |
|||
| 83 | +276 |
- }+ #' ) |
||
| 84 | +277 |
-
+ #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
|
||
| 85 | -1x | +|||
| 278 | +
- result <- list(count_fraction = result)+ #' formatters::var_labels(dta_bladder)[names(labels)] <- labels |
|||
| 86 | -1x | +|||
| 279 | +
- result+ #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
|||
| 87 | +280 |
- }+ #' |
||
| 88 | +281 |
-
+ #' plot( |
||
| 89 | +282 |
- #' @describeIn abnormal_by_worst_grade Formatted analysis function which is used as `afun`+ #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder), |
||
| 90 | +283 |
- #' in `count_abnormal_by_worst_grade()`.+ #' lty = 2:4, |
||
| 91 | +284 |
- #'+ #' xlab = "Months", |
||
| 92 | +285 |
- #' @return+ #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
|
||
| 93 | +286 |
- #' * `a_count_abnormal_by_worst_grade()` returns the corresponding list with formatted [rtables::CellValue()].+ #' ) |
||
| 94 | +287 |
#' |
||
| 95 | +288 |
- #' @keywords internal+ #' @name fit_coxreg |
||
| 96 | +289 |
- a_count_abnormal_by_worst_grade <- make_afun( # nolint+ NULL |
||
| 97 | +290 |
- s_count_abnormal_by_worst_grade,+ |
||
| 98 | +291 |
- .formats = c(count_fraction = format_count_fraction)+ #' @describeIn fit_coxreg Fit a series of univariate Cox regression models given the inputs. |
||
| 99 | +292 |
- )+ #' |
||
| 100 | +293 |
-
+ #' @return |
||
| 101 | +294 |
- #' @describeIn abnormal_by_worst_grade Layout-creating function which can take statistics function arguments+ #' * `fit_coxreg_univar()` returns a `coxreg.univar` class object which is a named `list` |
||
| 102 | +295 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' with 5 elements: |
||
| 103 | +296 |
- #'+ #' * `mod`: Cox regression models fitted by [survival::coxph()]. |
||
| 104 | +297 |
- #' @return+ #' * `data`: The original data frame input. |
||
| 105 | +298 |
- #' * `count_abnormal_by_worst_grade()` returns a layout object suitable for passing to further layouting functions,+ #' * `control`: The original control input. |
||
| 106 | +299 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' * `vars`: The variables used in the model. |
||
| 107 | +300 |
- #' the statistics from `s_count_abnormal_by_worst_grade()` to the table layout.+ #' * `at`: Value of the covariate at which the effect should be estimated. |
||
| 108 | +301 |
#' |
||
| 109 | +302 |
- #' @examples+ #' @note When using `fit_coxreg_univar` there should be two study arms. |
||
| 110 | +303 |
- #' library(dplyr)+ #' |
||
| 111 | +304 |
- #' library(forcats)+ #' @examples |
||
| 112 | +305 |
- #' adlb <- tern_ex_adlb+ #' # fit_coxreg_univar |
||
| 113 | +306 |
#' |
||
| 114 | +307 |
- #' # Data is modified in order to have some parameters with grades only in one direction+ #' ## Cox regression: arm + 1 covariate. |
||
| 115 | +308 |
- #' # and simulate the real data.+ #' mod1 <- fit_coxreg_univar( |
||
| 116 | +309 |
- #' adlb$ATOXGR[adlb$PARAMCD == "ALT" & adlb$ATOXGR %in% c("1", "2", "3", "4")] <- "-1"
+ #' variables = list( |
||
| 117 | +310 |
- #' adlb$ANRIND[adlb$PARAMCD == "ALT" & adlb$ANRIND == "HIGH"] <- "LOW"+ #' time = "time", event = "status", arm = "armcd", |
||
| 118 | +311 |
- #' adlb$WGRHIFL[adlb$PARAMCD == "ALT"] <- ""+ #' covariates = "covar1" |
||
| 119 | +312 |
- #'+ #' ), |
||
| 120 | +313 |
- #' adlb$ATOXGR[adlb$PARAMCD == "IGA" & adlb$ATOXGR %in% c("-1", "-2", "-3", "-4")] <- "1"
+ #' data = dta_bladder, |
||
| 121 | +314 |
- #' adlb$ANRIND[adlb$PARAMCD == "IGA" & adlb$ANRIND == "LOW"] <- "HIGH"+ #' control = control_coxreg(conf_level = 0.91) |
||
| 122 | +315 |
- #' adlb$WGRLOFL[adlb$PARAMCD == "IGA"] <- ""+ #' ) |
||
| 123 | +316 |
#' |
||
| 124 | +317 |
- #' # Pre-processing+ #' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates. |
||
| 125 | +318 |
- #' adlb_f <- adlb %>% h_adlb_abnormal_by_worst_grade()+ #' mod2 <- fit_coxreg_univar( |
||
| 126 | +319 |
- #'+ #' variables = list( |
||
| 127 | +320 |
- #' # Map excludes records without abnormal grade since they should not be displayed+ #' time = "time", event = "status", arm = "armcd", |
||
| 128 | +321 |
- #' # in the table.+ #' covariates = c("covar1", "covar2")
|
||
| 129 | +322 |
- #' map <- unique(adlb_f[adlb_f$GRADE_DIR != "ZERO", c("PARAM", "GRADE_DIR", "GRADE_ANL")]) %>%
+ #' ), |
||
| 130 | +323 |
- #' lapply(as.character) %>%+ #' data = dta_bladder, |
||
| 131 | +324 |
- #' as.data.frame() %>%+ #' control = control_coxreg(conf_level = 0.91, interaction = TRUE) |
||
| 132 | +325 |
- #' arrange(PARAM, desc(GRADE_DIR), GRADE_ANL)+ #' ) |
||
| 133 | +326 |
#' |
||
| 134 | +327 |
- #' basic_table() %>%+ #' ## Cox regression: arm + 1 covariate, stratified analysis. |
||
| 135 | +328 |
- #' split_cols_by("ARMCD") %>%
+ #' mod3 <- fit_coxreg_univar( |
||
| 136 | +329 |
- #' split_rows_by("PARAM") %>%
+ #' variables = list( |
||
| 137 | +330 |
- #' split_rows_by("GRADE_DIR", split_fun = trim_levels_to_map(map)) %>%
+ #' time = "time", event = "status", arm = "armcd", strata = "covar2", |
||
| 138 | +331 |
- #' count_abnormal_by_worst_grade(+ #' covariates = c("covar1")
|
||
| 139 | +332 |
- #' var = "GRADE_ANL",+ #' ), |
||
| 140 | +333 |
- #' variables = list(id = "USUBJID", param = "PARAM", grade_dir = "GRADE_DIR")+ #' data = dta_bladder, |
||
| 141 | +334 |
- #' ) %>%+ #' control = control_coxreg(conf_level = 0.91) |
||
| 142 | +335 |
- #' build_table(df = adlb_f)+ #' ) |
||
| 143 | +336 |
#' |
||
| 144 | +337 |
- #' @export+ #' ## Cox regression: no arm, only covariates. |
||
| 145 | +338 |
- #' @order 2+ #' mod4 <- fit_coxreg_univar( |
||
| 146 | +339 |
- count_abnormal_by_worst_grade <- function(lyt,+ #' variables = list( |
||
| 147 | +340 |
- var,+ #' time = "time", event = "status", |
||
| 148 | +341 |
- variables = list(+ #' covariates = c("covar1", "covar2")
|
||
| 149 | +342 |
- id = "USUBJID",+ #' ), |
||
| 150 | +343 |
- param = "PARAM",+ #' data = dta_bladder |
||
| 151 | +344 |
- grade_dir = "GRADE_DIR"+ #' ) |
||
| 152 | +345 |
- ),+ #' |
||
| 153 | +346 |
- na_str = default_na_str(),+ #' @export |
||
| 154 | +347 |
- nested = TRUE,+ fit_coxreg_univar <- function(variables, |
||
| 155 | +348 |
- ...,+ data, |
||
| 156 | +349 |
- .stats = NULL,+ at = list(), |
||
| 157 | +350 |
- .formats = NULL,+ control = control_coxreg()) {
+ |
+ ||
| 351 | +43x | +
+ checkmate::assert_list(variables, names = "named")+ |
+ ||
| 352 | +43x | +
+ has_arm <- "arm" %in% names(variables)+ |
+ ||
| 353 | +43x | +
+ arm_name <- if (has_arm) "arm" else NULL |
||
| 158 | +354 |
- .labels = NULL,+ + |
+ ||
| 355 | +43x | +
+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
||
| 159 | +356 |
- .indent_mods = NULL) {
+
|
||
| 160 | -2x | +357 | +43x |
- extra_args <- list(variables = variables, ...)+ assert_df_with_variables(data, variables)+ |
+
| 358 | +43x | +
+ assert_list_of_variables(variables[c(arm_name, "event", "time")]) |
||
| 161 | +359 | |||
| 162 | -2x | +360 | +43x |
- afun <- make_afun(+ if (!is.null(variables$strata)) {
|
| 163 | -2x | +361 | +4x |
- a_count_abnormal_by_worst_grade,+ checkmate::assert_disjunct(control$pval_method, "likelihood")+ |
+
| 362 | ++ |
+ } |
||
| 164 | -2x | +363 | +42x |
- .stats = .stats,+ if (has_arm) {
|
| 165 | -2x | +364 | +36x |
- .formats = .formats,+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ |
+
| 365 | ++ |
+ } |
||
| 166 | -2x | +366 | +41x |
- .labels = .labels,+ vars <- unlist(variables[c(arm_name, "covariates", "strata")], use.names = FALSE) |
| 167 | -2x | +367 | +41x |
- .indent_mods = .indent_mods,+ for (i in vars) {
|
| 168 | -2x | +368 | +94x |
- .ungroup_stats = "count_fraction"+ if (is.factor(data[[i]])) {
+ |
+
| 369 | +82x | +
+ attr(data[[i]], "levels") <- levels(droplevels(data[[i]])) |
||
| 169 | +370 | ++ |
+ }+ |
+ |
| 371 | ++ |
+ }+ |
+ ||
| 372 | +41x | +
+ forms <- h_coxreg_univar_formulas(variables, interaction = control$interaction)+ |
+ ||
| 373 | +41x | +
+ mod <- lapply(+ |
+ ||
| 374 | +41x | +
+ forms, function(x) {
+ |
+ ||
| 375 | +90x | +
+ survival::coxph(formula = stats::as.formula(x), data = data, ties = control$ties)+ |
+ ||
| 376 | ++ |
+ }+ |
+ ||
| 377 |
) |
|||
| 170 | -2x | +378 | +41x |
- analyze(+ structure( |
| 171 | -2x | +379 | +41x |
- lyt = lyt,+ list( |
| 172 | -2x | +380 | +41x |
- vars = var,+ mod = mod, |
| 173 | -2x | +381 | +41x |
- afun = afun,+ data = data, |
| 174 | -2x | +382 | +41x |
- na_str = na_str,+ control = control, |
| 175 | -2x | +383 | +41x |
- nested = nested,+ vars = variables, |
| 176 | -2x | +384 | +41x |
- extra_args = extra_args,+ at = at+ |
+
| 385 | ++ |
+ ), |
||
| 177 | -2x | +386 | +41x |
- show_labels = "hidden"+ class = "coxreg.univar" |
| 178 | +387 |
) |
||
| 179 | +388 |
} |
||
| 180 | +389 | |||
| 181 | +390 |
- #' Helper function to prepare ADLB for `count_abnormal_by_worst_grade()`+ #' @describeIn fit_coxreg Fit a multivariate Cox regression model. |
||
| 182 | +391 |
#' |
||
| 183 | +392 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return |
||
| 184 | +393 |
- #'+ #' * `fit_coxreg_multivar()` returns a `coxreg.multivar` class object which is a named list |
||
| 185 | +394 |
- #' Helper function to prepare an ADLB data frame to be used as input in+ #' with 4 elements: |
||
| 186 | +395 |
- #' [count_abnormal_by_worst_grade()]. The following pre-processing steps are applied:+ #' * `mod`: Cox regression model fitted by [survival::coxph()]. |
||
| 187 | +396 | ++ |
+ #' * `data`: The original data frame input.+ |
+ |
| 397 | ++ |
+ #' * `control`: The original control input.+ |
+ ||
| 398 | ++ |
+ #' * `vars`: The variables used in the model.+ |
+ ||
| 399 |
#' |
|||
| 188 | +400 |
- #' 1. `adlb` is filtered on variable `avisit` to only include post-baseline visits.+ #' @examples |
||
| 189 | +401 |
- #' 2. `adlb` is filtered on variables `worst_flag_low` and `worst_flag_high` so that only+ #' # fit_coxreg_multivar |
||
| 190 | +402 |
- #' worst grades (in either direction) are included.+ #' |
||
| 191 | +403 |
- #' 3. From the standard lab grade variable `atoxgr`, the following two variables are derived+ #' ## Cox regression: multivariate Cox regression. |
||
| 192 | +404 |
- #' and added to `adlb`:+ #' multivar_model <- fit_coxreg_multivar( |
||
| 193 | +405 |
- #' * A grade direction variable (e.g. `GRADE_DIR`). The variable takes value `"HIGH"` when+ #' variables = list( |
||
| 194 | +406 |
- #' `atoxgr > 0`, `"LOW"` when `atoxgr < 0`, and `"ZERO"` otherwise.+ #' time = "time", event = "status", arm = "armcd", |
||
| 195 | +407 |
- #' * A toxicity grade variable (e.g. `GRADE_ANL`) where all negative values from `atoxgr` are+ #' covariates = c("covar1", "covar2")
|
||
| 196 | +408 |
- #' replaced by their absolute values.+ #' ), |
||
| 197 | +409 |
- #' 4. Unused factor levels are dropped from `adlb` via [droplevels()].+ #' data = dta_bladder |
||
| 198 | +410 | ++ |
+ #' )+ |
+ |
| 411 |
#' |
|||
| 199 | +412 |
- #' @param adlb (`data.frame`)\cr ADLB data frame.+ #' # Example without treatment arm. |
||
| 200 | +413 |
- #' @param atoxgr (`string`)\cr name of the analysis toxicity grade variable. This must be a `factor`+ #' multivar_covs_model <- fit_coxreg_multivar( |
||
| 201 | +414 |
- #' variable.+ #' variables = list( |
||
| 202 | +415 |
- #' @param avisit (`string`)\cr name of the analysis visit variable.+ #' time = "time", event = "status", |
||
| 203 | +416 |
- #' @param worst_flag_low (`string`)\cr name of the worst low lab grade flag variable. This variable is+ #' covariates = c("covar1", "covar2")
|
||
| 204 | +417 |
- #' set to `"Y"` when indicating records of worst low lab grades.+ #' ), |
||
| 205 | +418 |
- #' @param worst_flag_high (`string`)\cr name of the worst high lab grade flag variable. This variable is+ #' data = dta_bladder |
||
| 206 | +419 |
- #' set to `"Y"` when indicating records of worst high lab grades.+ #' ) |
||
| 207 | +420 |
#' |
||
| 208 | +421 |
- #' @return `h_adlb_abnormal_by_worst_grade()` returns the `adlb` data frame with two new+ #' @export |
||
| 209 | +422 |
- #' variables: `GRADE_DIR` and `GRADE_ANL`.+ fit_coxreg_multivar <- function(variables, |
||
| 210 | +423 |
- #'+ data, |
||
| 211 | +424 |
- #' @seealso [abnormal_by_worst_grade]+ control = control_coxreg()) {
+ |
+ ||
| 425 | +83x | +
+ checkmate::assert_list(variables, names = "named")+ |
+ ||
| 426 | +83x | +
+ has_arm <- "arm" %in% names(variables)+ |
+ ||
| 427 | +83x | +
+ arm_name <- if (has_arm) "arm" else NULL |
||
| 212 | +428 |
- #'+ + |
+ ||
| 429 | +83x | +
+ if (!is.null(variables$covariates)) {
+ |
+ ||
| 430 | +21x | +
+ checkmate::assert_character(variables$covariates) |
||
| 213 | +431 |
- #' @examples+ } |
||
| 214 | +432 |
- #' h_adlb_abnormal_by_worst_grade(tern_ex_adlb) %>%+ + |
+ ||
| 433 | +83x | +
+ checkmate::assert_false(control$interaction)+ |
+ ||
| 434 | +83x | +
+ assert_df_with_variables(data, variables)+ |
+ ||
| 435 | +83x | +
+ assert_list_of_variables(variables[c(arm_name, "event", "time")]) |
||
| 215 | +436 |
- #' dplyr::select(ATOXGR, GRADE_DIR, GRADE_ANL) %>%+ + |
+ ||
| 437 | +83x | +
+ if (!is.null(variables$strata)) {
+ |
+ ||
| 438 | +3x | +
+ checkmate::assert_disjunct(control$pval_method, "likelihood") |
||
| 216 | +439 |
- #' head(10)+ } |
||
| 217 | +440 | ++ | + + | +|
| 441 | +82x | +
+ form <- h_coxreg_multivar_formula(variables)+ |
+ ||
| 442 | +82x | +
+ mod <- survival::coxph(+ |
+ ||
| 443 | +82x | +
+ formula = stats::as.formula(form),+ |
+ ||
| 444 | +82x | +
+ data = data,+ |
+ ||
| 445 | +82x | +
+ ties = control$ties+ |
+ ||
| 446 | ++ |
+ )+ |
+ ||
| 447 | +82x | +
+ structure(+ |
+ ||
| 448 | +82x | +
+ list(+ |
+ ||
| 449 | +82x | +
+ mod = mod,+ |
+ ||
| 450 | +82x | +
+ data = data,+ |
+ ||
| 451 | +82x | +
+ control = control,+ |
+ ||
| 452 | +82x | +
+ vars = variables+ |
+ ||
| 453 | ++ |
+ ),+ |
+ ||
| 454 | +82x | +
+ class = "coxreg.multivar"+ |
+ ||
| 455 | ++ |
+ )+ |
+ ||
| 456 | ++ |
+ }+ |
+ ||
| 457 | ++ | + + | +||
| 458 | ++ |
+ #' Muffled `car::Anova`+ |
+ ||
| 459 |
#' |
|||
| 218 | +460 |
- #' @export+ #' Applied on survival models, [car::Anova()] signal that the `strata` terms is dropped from the model formula when |
||
| 219 | +461 |
- h_adlb_abnormal_by_worst_grade <- function(adlb,+ #' present, this function deliberately muffles this message. |
||
| 220 | +462 |
- atoxgr = "ATOXGR",+ #' |
||
| 221 | +463 |
- avisit = "AVISIT",+ #' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()]. |
||
| 222 | +464 |
- worst_flag_low = "WGRLOFL",+ #' @param test_statistic (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`. |
||
| 223 | +465 |
- worst_flag_high = "WGRHIFL") {
+ #' |
||
| 224 | -1x | +|||
| 466 | +
- adlb %>%+ #' @return The output of [car::Anova()], with convergence message muffled. |
|||
| 225 | -1x | +|||
| 467 | +
- dplyr::filter(+ #'+ |
+ |||
| 468 | ++ |
+ #' @keywords internal+ |
+ ||
| 469 | ++ |
+ muffled_car_anova <- function(mod, test_statistic) {
|
||
| 226 | -1x | +470 | +219x |
- !.data[[avisit]] %in% c("SCREENING", "BASELINE"),
+ tryCatch( |
| 227 | -1x | +471 | +219x |
- .data[[worst_flag_low]] == "Y" | .data[[worst_flag_high]] == "Y"+ withCallingHandlers( |
| 228 | -+ | |||
| 472 | +219x |
- ) %>%+ expr = {
|
||
| 229 | -1x | +473 | +219x |
- dplyr::mutate(+ car::Anova( |
| 230 | -1x | +474 | +219x |
- GRADE_DIR = factor(+ mod, |
| 231 | -1x | +475 | +219x |
- dplyr::case_when(+ test.statistic = test_statistic, |
| 232 | -1x | +476 | +219x | +
+ type = "III"+ |
+
| 477 | +
- .data[[atoxgr]] %in% c("-1", "-2", "-3", "-4") ~ "LOW",
+ ) |
|||
| 233 | -1x | +|||
| 478 | +
- .data[[atoxgr]] == "0" ~ "ZERO",+ }, |
|||
| 234 | -1x | +479 | +219x |
- .data[[atoxgr]] %in% c("1", "2", "3", "4") ~ "HIGH"
+ message = function(m) invokeRestart("muffleMessage"),
|
| 235 | -+ | |||
| 480 | +219x |
- ),+ error = function(e) {
|
||
| 236 | +481 | 1x |
- levels = c("LOW", "ZERO", "HIGH")
+ stop(paste( |
|
| 237 | -+ | |||
| 482 | +1x |
- ),+ "the model seems to have convergence problems, please try to change", |
||
| 238 | +483 | 1x |
- GRADE_ANL = forcats::fct_relevel(+ "the configuration of covariates or strata variables, e.g.", |
|
| 239 | +484 | 1x |
- forcats::fct_recode(.data[[atoxgr]], `1` = "-1", `2` = "-2", `3` = "-3", `4` = "-4"),+ "- original error:", e |
|
| 240 | -1x | +|||
| 485 | +
- c("0", "1", "2", "3", "4")
+ )) |
|||
| 241 | +486 |
- )+ } |
||
| 242 | +487 |
- ) %>%+ ) |
||
| 243 | -1x | +|||
| 488 | +
- droplevels()+ ) |
|||
| 244 | +489 |
}@@ -157682,14 +156278,14 @@ tern coverage - 95.64% |
| 1 |
- #' Count patients with abnormal range values+ #' Helper functions for tabulating biomarker effects on survival by subgroup |
|||
| 5 |
- #' The analyze function [count_abnormal()] creates a layout element to count patients with abnormal analysis range+ #' Helper functions which are documented here separately to not confuse the user |
|||
| 6 |
- #' values in each direction.+ #' when reading about the user-facing functions. |
|||
| 8 |
- #' This function analyzes primary analysis variable `var` which indicates abnormal range results.+ #' @inheritParams survival_biomarkers_subgroups |
|||
| 9 |
- #' Additional analysis variables that can be supplied as a list via the `variables` parameter are+ #' @inheritParams argument_convention |
|||
| 10 |
- #' `id` (defaults to `USUBJID`), a variable to indicate unique subject identifiers, and `baseline`+ #' @inheritParams fit_coxreg_multivar |
|||
| 11 |
- #' (defaults to `BNRIND`), a variable to indicate baseline reference ranges.+ #' |
|||
| 12 |
- #'+ #' @examples |
|||
| 13 |
- #' For each direction specified via the `abnormal` parameter (e.g. High or Low), a fraction of+ #' library(dplyr) |
|||
| 14 |
- #' patient counts is returned, with numerator and denominator calculated as follows:+ #' library(forcats) |
|||
| 15 |
- #' * `num`: The number of patients with this abnormality recorded while on treatment.+ #' |
|||
| 16 |
- #' * `denom`: The total number of patients with at least one post-baseline assessment.+ #' adtte <- tern_ex_adtte |
|||
| 18 |
- #' This function assumes that `df` has been filtered to only include post-baseline records.+ #' # Save variable labels before data processing steps. |
|||
| 19 |
- #'+ #' adtte_labels <- formatters::var_labels(adtte, fill = FALSE) |
|||
| 20 |
- #' @inheritParams argument_convention+ #' |
|||
| 21 |
- #' @param abnormal (named `list`)\cr list identifying the abnormal range level(s) in `var`. Defaults to+ #' adtte_f <- adtte %>% |
|||
| 22 |
- #' `list(Low = "LOW", High = "HIGH")` but you can also group different levels into the named list,+ #' filter(PARAMCD == "OS") %>% |
|||
| 23 |
- #' for example, `abnormal = list(Low = c("LOW", "LOW LOW"), High = c("HIGH", "HIGH HIGH"))`.
+ #' mutate( |
|||
| 24 |
- #' @param exclude_base_abn (`flag`)\cr whether to exclude subjects with baseline abnormality+ #' AVALU = as.character(AVALU), |
|||
| 25 |
- #' from numerator and denominator.+ #' is_event = CNSR == 0 |
|||
| 26 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal")`
+ #' ) |
|||
| 27 |
- #' to see available statistics for this function.+ #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
|
|||
| 28 |
- #'+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
|||
| 29 |
- #' @note+ #' |
|||
| 30 |
- #' * `count_abnormal()` only considers a single variable that contains multiple abnormal levels.+ #' @name h_survival_biomarkers_subgroups |
|||
| 31 |
- #' * `df` should be filtered to only include post-baseline records.+ NULL |
|||
| 32 |
- #' * The denominator includes patients that may have other abnormal levels at baseline,+ |
|||
| 33 |
- #' and patients missing baseline records. Patients with these abnormalities at+ #' @describeIn h_survival_biomarkers_subgroups Helps with converting the "survival" function variable list |
|||
| 34 |
- #' baseline can be optionally excluded from numerator and denominator via the+ #' to the "Cox regression" variable list. The reason is that currently there is an inconsistency between the variable |
|||
| 35 |
- #' `exclude_base_abn` parameter.+ #' names accepted by `extract_survival_subgroups()` and `fit_coxreg_multivar()`. |
|||
| 37 |
- #' @name abnormal+ #' @param biomarker (`string`)\cr the name of the biomarker variable. |
|||
| 38 |
- #' @include formatting_functions.R+ #' |
|||
| 39 |
- #' @order 1+ #' @return |
|||
| 40 |
- NULL+ #' * `h_surv_to_coxreg_variables()` returns a named `list` of elements `time`, `event`, `arm`, |
|||
| 41 |
-
+ #' `covariates`, and `strata`. |
|||
| 42 |
- #' @describeIn abnormal Statistics function which counts patients with abnormal range values+ #' |
|||
| 43 |
- #' for a single `abnormal` level.+ #' @examples |
|||
| 44 |
- #'+ #' # This is how the variable list is converted internally. |
|||
| 45 |
- #' @return+ #' h_surv_to_coxreg_variables( |
|||
| 46 |
- #' * `s_count_abnormal()` returns the statistic `fraction` which is a vector with `num` and `denom` counts of patients.+ #' variables = list( |
|||
| 47 |
- #'+ #' tte = "AVAL", |
|||
| 48 |
- #' @keywords internal+ #' is_event = "EVNT", |
|||
| 49 |
- s_count_abnormal <- function(df,+ #' covariates = c("A", "B"),
|
|||
| 50 |
- .var,+ #' strata = "D" |
|||
| 51 |
- abnormal = list(Low = "LOW", High = "HIGH"),+ #' ), |
|||
| 52 |
- variables = list(id = "USUBJID", baseline = "BNRIND"),+ #' biomarker = "AGE" |
|||
| 53 |
- exclude_base_abn = FALSE) {
+ #' ) |
|||
| 54 | -4x | +
- checkmate::assert_list(abnormal, types = "character", names = "named", len = 2, any.missing = FALSE)+ #' |
||
| 55 | -4x | +
- checkmate::assert_true(any(unlist(abnormal) %in% levels(df[[.var]])))+ #' @export |
||
| 56 | -4x | +
- checkmate::assert_factor(df[[.var]])+ h_surv_to_coxreg_variables <- function(variables, biomarker) {
|
||
| 57 | -4x | +65x |
- checkmate::assert_flag(exclude_base_abn)+ checkmate::assert_list(variables) |
|
| 58 | -4x | +65x |
- assert_df_with_variables(df, c(range = .var, variables))+ checkmate::assert_string(variables$tte) |
|
| 59 | -4x | +65x |
- checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
+ checkmate::assert_string(variables$is_event) |
|
| 60 | -4x | +65x |
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ checkmate::assert_string(biomarker) |
|
| 61 | -+ | 65x |
-
+ list( |
|
| 62 | -4x | +65x |
- count_abnormal_single <- function(abn_name, abn) {
+ time = variables$tte, |
|
| 63 | -+ | 65x |
- # Patients in the denominator fulfill:+ event = variables$is_event, |
|
| 64 | -+ | 65x |
- # - have at least one post-baseline visit+ arm = biomarker, |
|
| 65 | -+ | 65x |
- # - their baseline must not be abnormal if `exclude_base_abn`.+ covariates = variables$covariates, |
|
| 66 | -8x | +65x |
- if (exclude_base_abn) {
+ strata = variables$strata |
|
| 67 | -4x | +
- denom_select <- !(df[[variables$baseline]] %in% abn)+ ) |
||
| 68 |
- } else {
+ } |
|||
| 69 | -4x | +
- denom_select <- TRUE+ |
||
| 70 |
- }+ #' @describeIn h_survival_biomarkers_subgroups Prepares estimates for number of events, patients and median survival |
|||
| 71 | -8x | +
- denom <- length(unique(df[denom_select, variables$id, drop = TRUE]))+ #' times, as well as hazard ratio estimates, confidence intervals and p-values, for multiple biomarkers |
||
| 72 |
-
+ #' in a given single data set. |
|||
| 73 |
- # Patients in the numerator fulfill:+ #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements |
|||
| 74 |
- # - have at least one post-baseline visit with the required abnormality level+ #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables) and optionally `subgroups` and `strata`. |
|||
| 75 |
- # - are part of the denominator patients.+ #' |
|||
| 76 | -8x | +
- num_select <- (df[[.var]] %in% abn) & denom_select+ #' @return |
||
| 77 | -8x | +
- num <- length(unique(df[num_select, variables$id, drop = TRUE]))+ #' * `h_coxreg_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers. |
||
| 78 |
-
+ #' |
|||
| 79 | -8x | +
- formatters::with_label(c(num = num, denom = denom), abn_name)+ #' @examples |
||
| 80 |
- }+ #' # For a single population, estimate separately the effects |
|||
| 81 |
-
+ #' # of two biomarkers. |
|||
| 82 |
- # This will define the abnormal levels theoretically possible for a specific lab parameter+ #' df <- h_coxreg_mult_cont_df( |
|||
| 83 |
- # within a split level of a layout.+ #' variables = list( |
|||
| 84 | -4x | +
- abnormal_lev <- lapply(abnormal, intersect, levels(df[[.var]]))+ #' tte = "AVAL", |
||
| 85 | -4x | +
- abnormal_lev <- abnormal_lev[vapply(abnormal_lev, function(x) length(x) > 0, logical(1))]+ #' is_event = "is_event", |
||
| 86 |
-
+ #' biomarkers = c("BMRKR1", "AGE"),
|
|||
| 87 | -4x | +
- result <- sapply(names(abnormal_lev), function(i) count_abnormal_single(i, abnormal_lev[[i]]), simplify = FALSE)+ #' covariates = "SEX", |
||
| 88 | -4x | +
- result <- list(fraction = result)+ #' strata = c("STRATA1", "STRATA2")
|
||
| 89 | -4x | +
- result+ #' ), |
||
| 90 |
- }+ #' data = adtte_f |
|||
| 91 |
-
+ #' ) |
|||
| 92 |
- #' @describeIn abnormal Formatted analysis function which is used as `afun` in `count_abnormal()`.+ #' df |
|||
| 94 |
- #' @return+ #' # If the data set is empty, still the corresponding rows with missings are returned. |
|||
| 95 |
- #' * `a_count_abnormal()` returns the corresponding list with formatted [rtables::CellValue()].+ #' h_coxreg_mult_cont_df( |
|||
| 96 |
- #'+ #' variables = list( |
|||
| 97 |
- #' @keywords internal+ #' tte = "AVAL", |
|||
| 98 |
- a_count_abnormal <- make_afun(+ #' is_event = "is_event", |
|||
| 99 |
- s_count_abnormal,+ #' biomarkers = c("BMRKR1", "AGE"),
|
|||
| 100 |
- .formats = c(fraction = format_fraction)+ #' covariates = "REGION1", |
|||
| 101 |
- )+ #' strata = c("STRATA1", "STRATA2")
|
|||
| 102 |
-
+ #' ), |
|||
| 103 |
- #' @describeIn abnormal Layout-creating function which can take statistics function arguments+ #' data = adtte_f[NULL, ] |
|||
| 104 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' ) |
|||
| 106 |
- #' @return+ #' @export |
|||
| 107 |
- #' * `count_abnormal()` returns a layout object suitable for passing to further layouting functions,+ h_coxreg_mult_cont_df <- function(variables, |
|||
| 108 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ data, |
|||
| 109 |
- #' the statistics from `s_count_abnormal()` to the table layout.+ control = control_coxreg()) {
|
|||
| 110 | -+ | 33x |
- #'+ if ("strat" %in% names(variables)) {
|
|
| 111 | -+ | ! |
- #' @examples+ warning( |
|
| 112 | -+ | ! |
- #' library(dplyr)+ "Warning: the `strat` element name of the `variables` list argument to `h_coxreg_mult_cont_df() ", |
|
| 113 | -+ | ! |
- #'+ "was deprecated in tern 0.9.4.\n ", |
|
| 114 | -+ | ! |
- #' df <- data.frame(+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
|
| 115 |
- #' USUBJID = as.character(c(1, 1, 2, 2)),+ ) |
|||
| 116 | -+ | ! |
- #' ANRIND = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
+ variables[["strata"]] <- variables[["strat"]] |
|
| 117 |
- #' BNRIND = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
+ } |
|||
| 118 |
- #' ONTRTFL = c("", "Y", "", "Y"),
+
|
|||
| 119 | -+ | 33x |
- #' stringsAsFactors = FALSE+ assert_df_with_variables(data, variables) |
|
| 120 | -+ | 33x |
- #' )+ checkmate::assert_list(control, names = "named") |
|
| 121 | -+ | 33x |
- #'+ checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE) |
|
| 122 | -+ | 33x |
- #' # Select only post-baseline records.+ conf_level <- control[["conf_level"]] |
|
| 123 | -+ | 33x |
- #' df <- df %>%+ pval_label <- paste0( |
|
| 124 |
- #' filter(ONTRTFL == "Y")+ # the regex capitalizes the first letter of the string / senetence. |
|||
| 125 | -+ | 33x |
- #'+ "p-value (", gsub("(^[a-z])", "\\U\\1", trimws(control[["pval_method"]]), perl = TRUE), ")"
|
|
| 126 |
- #' # Layout creating function.+ ) |
|||
| 127 |
- #' basic_table() %>%+ # If there is any data, run model, otherwise return empty results. |
|||
| 128 | -+ | 33x |
- #' count_abnormal(var = "ANRIND", abnormal = list(high = "HIGH", low = "LOW")) %>%+ if (nrow(data) > 0) {
|
|
| 129 | -+ | 32x |
- #' build_table(df)+ bm_cols <- match(variables$biomarkers, names(data)) |
|
| 130 | -+ | 32x |
- #'+ l_result <- lapply(variables$biomarkers, function(bm) {
|
|
| 131 | -+ | 64x |
- #' # Passing of statistics function and formatting arguments.+ coxreg_list <- fit_coxreg_multivar( |
|
| 132 | -+ | 64x |
- #' df2 <- data.frame(+ variables = h_surv_to_coxreg_variables(variables, bm), |
|
| 133 | -+ | 64x |
- #' ID = as.character(c(1, 1, 2, 2)),+ data = data, |
|
| 134 | -+ | 64x |
- #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
+ control = control |
|
| 135 |
- #' BL_RANGE = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
+ ) |
|||
| 136 | -+ | 64x |
- #' ONTRTFL = c("", "Y", "", "Y"),
+ result <- do.call( |
|
| 137 | -+ | 64x |
- #' stringsAsFactors = FALSE+ h_coxreg_multivar_extract, |
|
| 138 | -+ | 64x |
- #' )+ c(list(var = bm), coxreg_list[c("mod", "data", "control")])
|
|
| 139 |
- #'+ ) |
|||
| 140 | -+ | 64x |
- #' # Select only post-baseline records.+ data_fit <- as.data.frame(as.matrix(coxreg_list$mod$y)) |
|
| 141 | +64x | +
+ data_fit$status <- as.logical(data_fit$status)+ |
+ ||
| 142 | +64x | +
+ median <- s_surv_time(+ |
+ ||
| 143 | +64x | +
+ df = data_fit,+ |
+ ||
| 144 | +64x | +
+ .var = "time",+ |
+ ||
| 145 | +64x | +
+ is_event = "status"+ |
+ ||
| 146 | +64x | +
+ )$median+ |
+ ||
| 147 | +64x | +
+ data.frame(+ |
+ ||
| 148 |
- #' df2 <- df2 %>%+ # Dummy column needed downstream to create a nested header.+ |
+ |||
| 149 | +64x | +
+ biomarker = bm,+ |
+ ||
| 150 | +64x | +
+ biomarker_label = formatters::var_labels(data[bm], fill = TRUE),+ |
+ ||
| 151 | +64x | +
+ n_tot = coxreg_list$mod$n,+ |
+ ||
| 152 | +64x | +
+ n_tot_events = coxreg_list$mod$nevent,+ |
+ ||
| 153 | +64x | +
+ median = as.numeric(median),+ |
+ ||
| 154 | +64x | +
+ result[1L, c("hr", "lcl", "ucl")],
+ |
+ ||
| 155 | +64x | +
+ conf_level = conf_level,+ |
+ ||
| 156 | +64x | +
+ pval = result[1L, "pval"],+ |
+ ||
| 157 | +64x | +
+ pval_label = pval_label,+ |
+ ||
| 158 | +64x | +
+ stringsAsFactors = FALSE |
||
| 142 | +159 |
- #' filter(ONTRTFL == "Y")+ ) |
||
| 143 | +160 |
- #'+ })+ |
+ ||
| 161 | +32x | +
+ do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
||
| 144 | +162 |
- #' basic_table() %>%+ } else {
+ |
+ ||
| 163 | +1x | +
+ data.frame(+ |
+ ||
| 164 | +1x | +
+ biomarker = variables$biomarkers,+ |
+ ||
| 165 | +1x | +
+ biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE),+ |
+ ||
| 166 | +1x | +
+ n_tot = 0L,+ |
+ ||
| 167 | +1x | +
+ n_tot_events = 0L,+ |
+ ||
| 168 | +1x | +
+ median = NA,+ |
+ ||
| 169 | +1x | +
+ hr = NA,+ |
+ ||
| 170 | +1x | +
+ lcl = NA,+ |
+ ||
| 171 | +1x | +
+ ucl = NA,+ |
+ ||
| 172 | +1x | +
+ conf_level = conf_level,+ |
+ ||
| 173 | +1x | +
+ pval = NA,+ |
+ ||
| 174 | +1x | +
+ pval_label = pval_label,+ |
+ ||
| 175 | +1x | +
+ row.names = seq_along(variables$biomarkers),+ |
+ ||
| 176 | +1x | +
+ stringsAsFactors = FALSE |
||
| 145 | +177 |
- #' count_abnormal(+ ) |
||
| 146 | +178 |
- #' var = "RANGE",+ } |
||
| 147 | +179 |
- #' abnormal = list(low = "LOW", high = "HIGH"),+ } |
||
| 148 | +180 |
- #' variables = list(id = "ID", baseline = "BL_RANGE")+ |
||
| 149 | +181 |
- #' ) %>%+ #' @describeIn h_survival_biomarkers_subgroups Prepares a single sub-table given a `df_sub` containing |
||
| 150 | +182 |
- #' build_table(df2)+ #' the results for a single biomarker. |
||
| 151 | +183 |
#' |
||
| 152 | +184 |
- #' @export+ #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is |
||
| 153 | +185 |
- #' @order 2+ #' returned by [extract_survival_biomarkers()] (it needs a couple of columns which are |
||
| 154 | +186 |
- count_abnormal <- function(lyt,+ #' added by that high-level function relative to what is returned by [h_coxreg_mult_cont_df()], |
||
| 155 | +187 |
- var,+ #' see the example). |
||
| 156 | +188 |
- abnormal = list(Low = "LOW", High = "HIGH"),+ #' |
||
| 157 | +189 |
- variables = list(id = "USUBJID", baseline = "BNRIND"),+ #' @return |
||
| 158 | +190 |
- exclude_base_abn = FALSE,+ #' * `h_tab_surv_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns. |
||
| 159 | +191 |
- na_str = default_na_str(),+ #' |
||
| 160 | +192 |
- nested = TRUE,+ #' @examples |
||
| 161 | +193 |
- ...,+ #' # Starting from above `df`, zoom in on one biomarker and add required columns. |
||
| 162 | +194 |
- table_names = var,+ #' df1 <- df[1, ] |
||
| 163 | +195 |
- .stats = NULL,+ #' df1$subgroup <- "All patients" |
||
| 164 | +196 |
- .formats = NULL,+ #' df1$row_type <- "content" |
||
| 165 | +197 |
- .labels = NULL,+ #' df1$var <- "ALL" |
||
| 166 | +198 |
- .indent_mods = NULL) {
+ #' df1$var_label <- "All patients" |
||
| 167 | -3x | +|||
| 199 | +
- extra_args <- list(abnormal = abnormal, variables = variables, exclude_base_abn = exclude_base_abn, ...)+ #' h_tab_surv_one_biomarker( |
|||
| 168 | +200 |
-
+ #' df1, |
||
| 169 | -3x | +|||
| 201 | +
- afun <- make_afun(+ #' vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
|
|||
| 170 | -3x | +|||
| 202 | +
- a_count_abnormal,+ #' time_unit = "days" |
|||
| 171 | -3x | +|||
| 203 | +
- .stats = .stats,+ #' ) |
|||
| 172 | -3x | +|||
| 204 | +
- .formats = .formats,+ #' |
|||
| 173 | -3x | +|||
| 205 | +
- .labels = .labels,+ #' @export |
|||
| 174 | -3x | +|||
| 206 | +
- .indent_mods = .indent_mods,+ h_tab_surv_one_biomarker <- function(df, |
|||
| 175 | -3x | +|||
| 207 | +
- .ungroup_stats = "fraction"+ vars, |
|||
| 176 | +208 |
- )+ time_unit, |
||
| 177 | +209 |
-
+ na_str = default_na_str(), |
||
| 178 | -3x | +|||
| 210 | +
- checkmate::assert_string(var)+ .indent_mods = 0L, |
|||
| 179 | +211 |
-
+ ...) {
|
||
| 180 | -3x | +212 | +10x |
- analyze(+ afuns <- a_survival_subgroups(na_str = na_str)[vars] |
| 181 | -3x | +213 | +10x |
- lyt = lyt,+ colvars <- d_survival_subgroups_colvars( |
| 182 | -3x | +214 | +10x |
- vars = var,+ vars, |
| 183 | -3x | +215 | +10x |
- afun = afun,+ conf_level = df$conf_level[1], |
| 184 | -3x | +216 | +10x |
- na_str = na_str,+ method = df$pval_label[1], |
| 185 | -3x | +217 | +10x |
- nested = nested,+ time_unit = time_unit+ |
+
| 218 | ++ |
+ ) |
||
| 186 | -3x | +219 | +10x |
- table_names = table_names,+ h_tab_one_biomarker( |
| 187 | -3x | +220 | +10x |
- extra_args = extra_args,+ df = df, |
| 188 | -3x | +221 | +10x |
- show_labels = "hidden"+ afuns = afuns,+ |
+
| 222 | +10x | +
+ colvars = colvars,+ |
+ ||
| 223 | +10x | +
+ na_str = na_str,+ |
+ ||
| 224 | +10x | +
+ .indent_mods = .indent_mods, |
||
| 189 | +225 | ++ |
+ ...+ |
+ |
| 226 |
) |
|||
| 190 | +227 |
}@@ -159018,14 +157873,14 @@ tern coverage - 95.64% |
| 1 |
- #' Compare variables between groups+ #' Helper functions for tabulating biomarker effects on binary response by subgroup |
||
| 5 |
- #' The analyze function [compare_vars()] creates a layout element to summarize and compare one or more variables, using+ #' Helper functions which are documented here separately to not confuse the user |
||
| 6 |
- #' the S3 generic function [s_summary()] to calculate a list of summary statistics. A list of all available statistics+ #' when reading about the user-facing functions. |
||
| 7 |
- #' for numeric variables can be viewed by running `get_stats("analyze_vars_numeric", add_pval = TRUE)` and for
+ #' |
||
| 8 |
- #' non-numeric variables by running `get_stats("analyze_vars_counts", add_pval = TRUE)`. Use the `.stats` parameter to
+ #' @inheritParams response_biomarkers_subgroups |
||
| 9 |
- #' specify the statistics to include in your output summary table.+ #' @inheritParams extract_rsp_biomarkers |
||
| 10 |
- #'+ #' @inheritParams argument_convention |
||
| 11 |
- #' Prior to using this function in your table layout you must use [rtables::split_cols_by()] to create a column+ #' |
||
| 12 |
- #' split on the variable to be used in comparisons, and specify a reference group via the `ref_group` parameter.+ #' @examples |
||
| 13 |
- #' Comparisons can be performed for each group (column) against the specified reference group by including the p-value+ #' library(dplyr) |
||
| 14 |
- #' statistic.+ #' library(forcats) |
||
| 16 |
- #' @inheritParams argument_convention+ #' adrs <- tern_ex_adrs |
||
| 17 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 18 |
- #' `get_stats("analyze_vars_numeric", add_pval = TRUE)` to see statistics available for numeric variables, and
+ #' |
||
| 19 |
- #' `get_stats("analyze_vars_counts", add_pval = TRUE)` for statistics available for non-numeric variables.
+ #' adrs_f <- adrs %>% |
||
| 20 |
- #'+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 21 |
- #' @note+ #' mutate(rsp = AVALC == "CR") |
||
| 22 |
- #' * For factor variables, `denom` for factor proportions can only be `n` since the purpose is to compare proportions+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
||
| 23 |
- #' between columns, therefore a row-based proportion would not make sense. Proportion based on `N_col` would+ #' |
||
| 24 |
- #' be difficult since we use counts for the chi-squared test statistic, therefore missing values should be accounted+ #' @name h_response_biomarkers_subgroups |
||
| 25 |
- #' for as explicit factor levels.+ NULL |
||
| 26 |
- #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values+ |
||
| 27 |
- #' set `na.rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit+ #' @describeIn h_response_biomarkers_subgroups helps with converting the "response" function variable list |
||
| 28 |
- #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the+ #' to the "logistic regression" variable list. The reason is that currently there is an |
||
| 29 |
- #' default `na_level` (`"<Missing>"`) will also be excluded when `na.rm` is set to `TRUE`.+ #' inconsistency between the variable names accepted by `extract_rsp_subgroups()` and `fit_logistic()`. |
||
| 30 |
- #' * For character variables, automatic conversion to factor does not guarantee that the table+ #' |
||
| 31 |
- #' will be generated correctly. In particular for sparse tables this very likely can fail.+ #' @param biomarker (`string`)\cr the name of the biomarker variable. |
||
| 32 |
- #' Therefore it is always better to manually convert character variables to factors during pre-processing.+ #' |
||
| 33 |
- #' * For `compare_vars()`, the column split must define a reference group via `ref_group` so that the comparison+ #' @return |
||
| 34 |
- #' is well defined.+ #' * `h_rsp_to_logistic_variables()` returns a named `list` of elements `response`, `arm`, `covariates`, and `strata`. |
||
| 36 |
- #' @seealso [s_summary()] which is used internally to compute a summary within `s_compare()`, and [a_summary()]+ #' @examples |
||
| 37 |
- #' which is used (with `compare = TRUE`) as the analysis function for `compare_vars()`.+ #' # This is how the variable list is converted internally. |
||
| 38 |
- #'+ #' h_rsp_to_logistic_variables( |
||
| 39 |
- #' @name compare_variables+ #' variables = list( |
||
| 40 |
- #' @include analyze_variables.R+ #' rsp = "RSP", |
||
| 41 |
- #' @order 1+ #' covariates = c("A", "B"),
|
||
| 42 |
- NULL+ #' strata = "D" |
||
| 43 |
-
+ #' ), |
||
| 44 |
- #' @describeIn compare_variables S3 generic function to produce a comparison summary.+ #' biomarker = "AGE" |
||
| 45 |
- #'+ #' ) |
||
| 46 |
- #' @return+ #' |
||
| 47 |
- #' * `s_compare()` returns output of [s_summary()] and comparisons versus the reference group in the form of p-values.+ #' @export |
||
| 48 |
- #'+ h_rsp_to_logistic_variables <- function(variables, biomarker) {
|
||
| 49 | -+ | 49x |
- #' @export+ if ("strat" %in% names(variables)) {
|
| 50 | -+ | ! |
- s_compare <- function(x,+ warning( |
| 51 | -+ | ! |
- .ref_group,+ "Warning: the `strat` element name of the `variables` list argument to `h_rsp_to_logistic_variables() ", |
| 52 | -+ | ! |
- .in_ref_col,+ "was deprecated in tern 0.9.4.\n ", |
| 53 | -+ | ! |
- ...) {
+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
| 54 | -35x | +
- UseMethod("s_compare", x)
+ ) |
|
| 55 | -+ | ! |
- }+ variables[["strata"]] <- variables[["strat"]] |
| 56 |
-
+ } |
||
| 57 | -+ | 49x |
- #' @describeIn compare_variables Method for `numeric` class. This uses the standard t-test+ checkmate::assert_list(variables) |
| 58 | -+ | 49x |
- #' to calculate the p-value.+ checkmate::assert_string(variables$rsp) |
| 59 | -+ | 49x |
- #'+ checkmate::assert_string(biomarker) |
| 60 | -+ | 49x |
- #' @method s_compare numeric+ list( |
| 61 | -+ | 49x |
- #'+ response = variables$rsp, |
| 62 | -+ | 49x |
- #' @examples+ arm = biomarker, |
| 63 | -+ | 49x |
- #' # `s_compare.numeric`+ covariates = variables$covariates, |
| 64 | -+ | 49x |
- #'+ strata = variables$strata |
| 65 |
- #' ## Usual case where both this and the reference group vector have more than 1 value.+ ) |
||
| 66 |
- #' s_compare(rnorm(10, 5, 1), .ref_group = rnorm(5, -5, 1), .in_ref_col = FALSE)+ } |
||
| 67 |
- #'+ |
||
| 68 |
- #' ## If one group has not more than 1 value, then p-value is not calculated.+ #' @describeIn h_response_biomarkers_subgroups prepares estimates for number of responses, patients and |
||
| 69 |
- #' s_compare(rnorm(10, 5, 1), .ref_group = 1, .in_ref_col = FALSE)+ #' overall response rate, as well as odds ratio estimates, confidence intervals and p-values, for multiple |
||
| 70 |
- #'+ #' biomarkers in a given single data set. |
||
| 71 |
- #' ## Empty numeric does not fail, it returns NA-filled items and no p-value.+ #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements |
||
| 72 |
- #' s_compare(numeric(), .ref_group = numeric(), .in_ref_col = FALSE)+ #' `rsp` and `biomarkers` (vector of continuous biomarker variables) and optionally `covariates` |
||
| 73 |
- #'+ #' and `strata`. |
||
| 74 |
- #' @export+ #' |
||
| 75 |
- s_compare.numeric <- function(x,+ #' @return |
||
| 76 |
- .ref_group,+ #' * `h_logistic_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers. |
||
| 77 |
- .in_ref_col,+ #' |
||
| 78 |
- ...) {
+ #' @examples |
||
| 79 | -13x | +
- checkmate::assert_numeric(x)+ #' # For a single population, estimate separately the effects |
|
| 80 | -13x | +
- checkmate::assert_numeric(.ref_group)+ #' # of two biomarkers. |
|
| 81 | -13x | +
- checkmate::assert_flag(.in_ref_col)+ #' df <- h_logistic_mult_cont_df( |
|
| 82 |
-
+ #' variables = list( |
||
| 83 | -13x | +
- y <- s_summary.numeric(x = x, ...)+ #' rsp = "rsp", |
|
| 84 |
-
+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 85 | -13x | +
- y$pval <- if (!.in_ref_col && n_available(x) > 1 && n_available(.ref_group) > 1) {
+ #' covariates = "SEX" |
|
| 86 | -9x | +
- stats::t.test(x, .ref_group)$p.value+ #' ), |
|
| 87 |
- } else {
+ #' data = adrs_f |
||
| 88 | -4x | +
- character()+ #' ) |
|
| 89 |
- }+ #' df |
||
| 90 |
-
+ #' |
||
| 91 | -13x | +
- y+ #' # If the data set is empty, still the corresponding rows with missings are returned. |
|
| 92 |
- }+ #' h_coxreg_mult_cont_df( |
||
| 93 |
-
+ #' variables = list( |
||
| 94 |
- #' @describeIn compare_variables Method for `factor` class. This uses the chi-squared test+ #' rsp = "rsp", |
||
| 95 |
- #' to calculate the p-value.+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 96 |
- #'+ #' covariates = "SEX", |
||
| 97 |
- #' @param denom (`string`)\cr choice of denominator for factor proportions,+ #' strata = "STRATA1" |
||
| 98 |
- #' can only be `n` (number of values in this row and column intersection).+ #' ), |
||
| 99 |
- #'+ #' data = adrs_f[NULL, ] |
||
| 100 |
- #' @method s_compare factor+ #' ) |
||
| 102 |
- #' @examples+ #' @export |
||
| 103 |
- #' # `s_compare.factor`+ h_logistic_mult_cont_df <- function(variables, |
||
| 104 |
- #'+ data, |
||
| 105 |
- #' ## Basic usage:+ control = control_logistic()) {
|
||
| 106 | -+ | 28x |
- #' x <- factor(c("a", "a", "b", "c", "a"))
+ if ("strat" %in% names(variables)) {
|
| 107 | -+ | ! |
- #' y <- factor(c("a", "b", "c"))
+ warning( |
| 108 | -+ | ! |
- #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE)+ "Warning: the `strat` element name of the `variables` list argument to `h_logistic_mult_cont_df() ", |
| 109 | -+ | ! |
- #'+ "was deprecated in tern 0.9.4.\n ", |
| 110 | -+ | ! |
- #' ## Management of NA values.+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
| 111 |
- #' x <- explicit_na(factor(c("a", "a", "b", "c", "a", NA, NA)))
+ ) |
||
| 112 | -+ | ! |
- #' y <- explicit_na(factor(c("a", "b", "c", NA)))
+ variables[["strata"]] <- variables[["strat"]] |
| 113 |
- #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE)+ } |
||
| 114 | -+ | 28x |
- #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE)+ assert_df_with_variables(data, variables) |
| 115 |
- #'+ |
||
| 116 | -+ | 28x |
- #' @export+ checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE) |
| 117 | -+ | 28x |
- s_compare.factor <- function(x,+ checkmate::assert_list(control, names = "named") |
| 118 |
- .ref_group,+ |
||
| 119 | -+ | 28x |
- .in_ref_col,+ conf_level <- control[["conf_level"]] |
| 120 | -+ | 28x |
- denom = "n",+ pval_label <- "p-value (Wald)" |
| 121 |
- na.rm = TRUE, # nolint+ |
||
| 122 |
- ...) {
+ # If there is any data, run model, otherwise return empty results. |
||
| 123 | -16x | +28x |
- checkmate::assert_flag(.in_ref_col)+ if (nrow(data) > 0) {
|
| 124 | -16x | +27x |
- assert_valid_factor(x)+ bm_cols <- match(variables$biomarkers, names(data)) |
| 125 | -16x | +27x |
- assert_valid_factor(.ref_group)+ l_result <- lapply(variables$biomarkers, function(bm) {
|
| 126 | -16x | +48x |
- denom <- match.arg(denom)+ model_fit <- fit_logistic( |
| 127 | -+ | 48x |
-
+ variables = h_rsp_to_logistic_variables(variables, bm), |
| 128 | -16x | +48x |
- y <- s_summary.factor(+ data = data, |
| 129 | -16x | +48x |
- x = x,+ response_definition = control$response_definition |
| 130 | -16x | +
- denom = denom,+ ) |
|
| 131 | -16x | +48x |
- na.rm = na.rm,+ result <- h_logistic_simple_terms( |
| 132 | -+ | 48x |
- ...+ x = bm, |
| 133 | -+ | 48x |
- )+ fit_glm = model_fit, |
| 134 | -+ | 48x |
-
+ conf_level = control$conf_level |
| 135 | -16x | +
- if (na.rm) {
+ ) |
|
| 136 | -14x | +48x |
- x <- x[!is.na(x)] %>% fct_discard("<Missing>")
+ resp_vector <- if (inherits(model_fit, "glm")) {
|
| 137 | -14x | +38x |
- .ref_group <- .ref_group[!is.na(.ref_group)] %>% fct_discard("<Missing>")
+ model_fit$model[[variables$rsp]] |
| 138 |
- } else {
+ } else {
|
||
| 139 | -2x | +10x |
- x <- x %>% explicit_na(label = "NA")+ as.logical(as.matrix(model_fit$y)[, "status"]) |
| 140 | -2x | +
- .ref_group <- .ref_group %>% explicit_na(label = "NA")+ } |
|
| 141 | -+ | 48x |
- }+ data.frame( |
| 142 |
-
+ # Dummy column needed downstream to create a nested header. |
||
| 143 | -1x | +48x |
- if ("NA" %in% levels(x)) levels(.ref_group) <- c(levels(.ref_group), "NA")
+ biomarker = bm, |
| 144 | -16x | +48x |
- checkmate::assert_factor(x, levels = levels(.ref_group), min.levels = 2)+ biomarker_label = formatters::var_labels(data[bm], fill = TRUE), |
| 145 | -+ | 48x |
-
+ n_tot = length(resp_vector), |
| 146 | -16x | +48x |
- y$pval_counts <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
+ n_rsp = sum(resp_vector), |
| 147 | -13x | +48x |
- tab <- rbind(table(x), table(.ref_group))+ prop = mean(resp_vector), |
| 148 | -13x | +48x |
- res <- suppressWarnings(stats::chisq.test(tab))+ or = as.numeric(result[1L, "odds_ratio"]), |
| 149 | -13x | +48x |
- res$p.value+ lcl = as.numeric(result[1L, "lcl"]), |
| 150 | -+ | 48x |
- } else {
+ ucl = as.numeric(result[1L, "ucl"]), |
| 151 | -3x | +48x |
- character()+ conf_level = conf_level, |
| 152 | -+ | 48x |
- }+ pval = as.numeric(result[1L, "pvalue"]), |
| 153 | -+ | 48x |
-
+ pval_label = pval_label, |
| 154 | -16x | +48x |
- y+ stringsAsFactors = FALSE |
| 155 |
- }+ ) |
||
| 156 |
-
+ }) |
||
| 157 | -+ | 27x |
- #' @describeIn compare_variables Method for `character` class. This makes an automatic+ do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 158 |
- #' conversion to `factor` (with a warning) and then forwards to the method for factors.+ } else {
|
||
| 159 | -+ | 1x |
- #'+ data.frame( |
| 160 | -+ | 1x |
- #' @param verbose (`flag`)\cr whether warnings and messages should be printed. Mainly used+ biomarker = variables$biomarkers, |
| 161 | -+ | 1x |
- #' to print out information about factor casting. Defaults to `TRUE`.+ biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE), |
| 162 | -+ | 1x |
- #'+ n_tot = 0L, |
| 163 | -+ | 1x |
- #' @method s_compare character+ n_rsp = 0L, |
| 164 | -+ | 1x |
- #'+ prop = NA, |
| 165 | -+ | 1x |
- #' @examples+ or = NA, |
| 166 | -+ | 1x |
- #' # `s_compare.character`+ lcl = NA, |
| 167 | -+ | 1x |
- #'+ ucl = NA, |
| 168 | -+ | 1x |
- #' ## Basic usage:+ conf_level = conf_level, |
| 169 | -+ | 1x |
- #' x <- c("a", "a", "b", "c", "a")
+ pval = NA, |
| 170 | -+ | 1x |
- #' y <- c("a", "b", "c")
+ pval_label = pval_label, |
| 171 | -+ | 1x |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, .var = "x", verbose = FALSE)+ row.names = seq_along(variables$biomarkers), |
| 172 | -+ | 1x |
- #'+ stringsAsFactors = FALSE |
| 173 |
- #' ## Note that missing values handling can make a large difference:+ ) |
||
| 174 |
- #' x <- c("a", "a", "b", "c", "a", NA)
+ } |
||
| 175 |
- #' y <- c("a", "b", "c", rep(NA, 20))
+ } |
||
| 176 |
- #' s_compare(x,+ |
||
| 177 |
- #' .ref_group = y, .in_ref_col = FALSE,+ #' @describeIn h_response_biomarkers_subgroups Prepares a single sub-table given a `df_sub` containing |
||
| 178 |
- #' .var = "x", verbose = FALSE+ #' the results for a single biomarker. |
||
| 179 |
- #' )+ #' |
||
| 180 |
- #' s_compare(x,+ #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is |
||
| 181 |
- #' .ref_group = y, .in_ref_col = FALSE, .var = "x",+ #' returned by [extract_rsp_biomarkers()] (it needs a couple of columns which are |
||
| 182 |
- #' na.rm = FALSE, verbose = FALSE+ #' added by that high-level function relative to what is returned by [h_logistic_mult_cont_df()], |
||
| 183 |
- #' )+ #' see the example). |
||
| 185 |
- #' @export+ #' @return |
||
| 186 |
- s_compare.character <- function(x,+ #' * `h_tab_rsp_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns. |
||
| 187 |
- .ref_group,+ #' |
||
| 188 |
- .in_ref_col,+ #' @examples |
||
| 189 |
- denom = "n",+ #' # Starting from above `df`, zoom in on one biomarker and add required columns. |
||
| 190 |
- na.rm = TRUE, # nolint+ #' df1 <- df[1, ] |
||
| 191 |
- .var,+ #' df1$subgroup <- "All patients" |
||
| 192 |
- verbose = TRUE,+ #' df1$row_type <- "content" |
||
| 193 |
- ...) {
+ #' df1$var <- "ALL" |
||
| 194 | -2x | +
- x <- as_factor_keep_attributes(x, verbose = verbose)+ #' df1$var_label <- "All patients" |
|
| 195 | -2x | +
- .ref_group <- as_factor_keep_attributes(.ref_group, verbose = verbose)+ #' |
|
| 196 | -2x | +
- s_compare(+ #' h_tab_rsp_one_biomarker( |
|
| 197 | -2x | +
- x = x,+ #' df1, |
|
| 198 | -2x | +
- .ref_group = .ref_group,+ #' vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval")
|
|
| 199 | -2x | +
- .in_ref_col = .in_ref_col,+ #' ) |
|
| 200 | -2x | +
- denom = denom,+ #' |
|
| 201 | -2x | +
- na.rm = na.rm,+ #' @export |
|
| 202 |
- ...+ h_tab_rsp_one_biomarker <- function(df, |
||
| 203 |
- )+ vars, |
||
| 204 |
- }+ na_str = default_na_str(), |
||
| 205 |
-
+ .indent_mods = 0L) {
|
||
| 206 | -+ | 8x |
- #' @describeIn compare_variables Method for `logical` class. A chi-squared test+ afuns <- a_response_subgroups(na_str = na_str)[vars] |
| 207 | -+ | 8x |
- #' is used. If missing values are not removed, then they are counted as `FALSE`.+ colvars <- d_rsp_subgroups_colvars( |
| 208 | -+ | 8x |
- #'+ vars, |
| 209 | -+ | 8x |
- #' @method s_compare logical+ conf_level = df$conf_level[1], |
| 210 | -+ | 8x |
- #'+ method = df$pval_label[1] |
| 211 |
- #' @examples+ ) |
||
| 212 | -+ | 8x |
- #' # `s_compare.logical`+ h_tab_one_biomarker( |
| 213 | -+ | 8x |
- #'+ df = df, |
| 214 | -+ | 8x |
- #' ## Basic usage:+ afuns = afuns, |
| 215 | -+ | 8x |
- #' x <- c(TRUE, FALSE, TRUE, TRUE)+ colvars = colvars, |
| 216 | -+ | 8x |
- #' y <- c(FALSE, FALSE, TRUE)+ na_str = na_str, |
| 217 | -+ | 8x |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE)+ .indent_mods = .indent_mods |
| 218 |
- #'+ ) |
||
| 219 |
- #' ## Management of NA values.+ } |
| 220 | +1 |
- #' x <- c(NA, TRUE, FALSE)+ #' Count patient events in columns |
||
| 221 | +2 |
- #' y <- c(NA, NA, NA, NA, FALSE)+ #' |
||
| 222 | +3 |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE)+ #' @description `r lifecycle::badge("stable")`
|
||
| 223 | +4 |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE)+ #' |
||
| 224 | +5 |
- #'+ #' The summarize function [summarize_patients_events_in_cols()] creates a layout element to summarize patient |
||
| 225 | +6 |
- #' @export+ #' event counts in columns. |
||
| 226 | +7 |
- s_compare.logical <- function(x,+ #' |
||
| 227 | +8 |
- .ref_group,+ #' This function analyzes the elements (events) supplied via the `filters_list` parameter and returns a row |
||
| 228 | +9 |
- .in_ref_col,+ #' with counts of number of patients for each event as well as the total numbers of patients and events. |
||
| 229 | +10 |
- na.rm = TRUE, # nolint+ #' The `id` variable is used to indicate unique subject identifiers (defaults to `USUBJID`). |
||
| 230 | +11 |
- denom = "n",+ #' |
||
| 231 | +12 |
- ...) {
- |
- ||
| 232 | -4x | -
- denom <- match.arg(denom)+ #' If there are multiple occurrences of the same event recorded for a patient, the event is only counted once. |
||
| 233 | +13 | - - | -||
| 234 | -4x | -
- y <- s_summary.logical(- |
- ||
| 235 | -4x | -
- x = x,- |
- ||
| 236 | -4x | -
- na.rm = na.rm,- |
- ||
| 237 | -4x | -
- denom = denom,+ #' |
||
| 238 | +14 |
- ...+ #' @inheritParams argument_convention |
||
| 239 | +15 |
- )+ #' @param filters_list (named `list` of `character`)\cr list where each element in this list describes one |
||
| 240 | +16 | - - | -||
| 241 | -4x | -
- if (na.rm) {
- |
- ||
| 242 | -3x | -
- x <- stats::na.omit(x)- |
- ||
| 243 | -3x | -
- .ref_group <- stats::na.omit(.ref_group)+ #' type of event describe by filters, in the same format as [s_count_patients_with_event()]. |
||
| 244 | +17 |
- } else {
- |
- ||
| 245 | -1x | -
- x[is.na(x)] <- FALSE- |
- ||
| 246 | -1x | -
- .ref_group[is.na(.ref_group)] <- FALSE+ #' If it has a label, then this will be used for the column title. |
||
| 247 | +18 |
- }+ #' @param empty_stats (`character`)\cr optional names of the statistics that should be returned empty such |
||
| 248 | +19 | - - | -||
| 249 | -4x | -
- y$pval_counts <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
- |
- ||
| 250 | -4x | -
- x <- factor(x, levels = c(TRUE, FALSE))- |
- ||
| 251 | -4x | -
- .ref_group <- factor(.ref_group, levels = c(TRUE, FALSE))- |
- ||
| 252 | -4x | -
- tbl <- rbind(table(x), table(.ref_group))- |
- ||
| 253 | -4x | -
- suppressWarnings(prop_chisq(tbl))+ #' that corresponding table cells will stay blank. |
||
| 254 | +20 |
- } else {
- |
- ||
| 255 | -! | -
- character()+ #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will |
||
| 256 | +21 |
- }+ #' be used as label. |
||
| 257 | +22 | - - | -||
| 258 | -4x | -
- y+ #' @param .stats (`character`)\cr statistics to select for the table. Run |
||
| 259 | +23 |
- }+ #' `get_stats("summarize_patients_events_in_cols")` to see available statistics for this function, in addition
|
||
| 260 | +24 |
-
+ #' to any added using `filters_list`. |
||
| 261 | +25 |
- #' @describeIn compare_variables Layout-creating function which can take statistics function arguments+ #' |
||
| 262 | +26 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' @name count_patients_events_in_cols |
||
| 263 | +27 |
- #'+ #' @order 1 |
||
| 264 | +28 |
- #' @param ... arguments passed to `s_compare()`.+ NULL |
||
| 265 | +29 |
- #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector+ |
||
| 266 | +30 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ #' @describeIn count_patients_events_in_cols Statistics function which counts numbers of patients and multiple |
||
| 267 | +31 |
- #' for that statistic's row label.+ #' events defined by filters. Used as analysis function `afun` in `summarize_patients_events_in_cols()`. |
||
| 268 | +32 |
#' |
||
| 269 | +33 |
#' @return |
||
| 270 | +34 |
- #' * `compare_vars()` returns a layout object suitable for passing to further layouting functions,+ #' * `s_count_patients_and_multiple_events()` returns a list with the statistics: |
||
| 271 | +35 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' - `unique`: number of unique patients in `df`. |
||
| 272 | +36 |
- #' the statistics from `s_compare()` to the table layout.+ #' - `all`: number of rows in `df`. |
||
| 273 | +37 |
- #'+ #' - one element with the same name as in `filters_list`: number of rows in `df`, |
||
| 274 | +38 |
- #' @examples+ #' i.e. events, fulfilling the filter condition. |
||
| 275 | +39 |
- #' # `compare_vars()` in `rtables` pipelines+ #' |
||
| 276 | +40 |
- #'+ #' @keywords internal |
||
| 277 | +41 |
- #' ## Default output within a `rtables` pipeline.+ s_count_patients_and_multiple_events <- function(df, # nolint |
||
| 278 | +42 |
- #' lyt <- basic_table() %>%+ id, |
||
| 279 | +43 |
- #' split_cols_by("ARMCD", ref_group = "ARM B") %>%
+ filters_list, |
||
| 280 | +44 |
- #' compare_vars(c("AGE", "SEX"))
+ empty_stats = character(), |
||
| 281 | +45 |
- #' build_table(lyt, tern_ex_adsl)+ labelstr = "", |
||
| 282 | +46 |
- #'+ custom_label = NULL) {
|
||
| 283 | -+ | |||
| 47 | +9x |
- #' ## Select and format statistics output.+ checkmate::assert_list(filters_list, names = "named") |
||
| 284 | -+ | |||
| 48 | +9x |
- #' lyt <- basic_table() %>%+ checkmate::assert_data_frame(df) |
||
| 285 | -+ | |||
| 49 | +9x |
- #' split_cols_by("ARMCD", ref_group = "ARM C") %>%
+ checkmate::assert_string(id) |
||
| 286 | -+ | |||
| 50 | +9x |
- #' compare_vars(+ checkmate::assert_disjunct(c("unique", "all"), names(filters_list))
|
||
| 287 | -+ | |||
| 51 | +9x |
- #' vars = "AGE",+ checkmate::assert_character(empty_stats) |
||
| 288 | -+ | |||
| 52 | +9x |
- #' .stats = c("mean_sd", "pval"),
+ checkmate::assert_string(labelstr) |
||
| 289 | -+ | |||
| 53 | +9x |
- #' .formats = c(mean_sd = "xx.x, xx.x"),+ checkmate::assert_string(custom_label, null.ok = TRUE) |
||
| 290 | +54 |
- #' .labels = c(mean_sd = "Mean, SD")+ |
||
| 291 | +55 |
- #' )+ # Below we want to count each row in `df` once, therefore introducing this helper index column. |
||
| 292 | -+ | |||
| 56 | +9x |
- #' build_table(lyt, df = tern_ex_adsl)+ df$.row_index <- as.character(seq_len(nrow(df))) |
||
| 293 | -+ | |||
| 57 | +9x |
- #'+ y <- list() |
||
| 294 | -+ | |||
| 58 | +9x |
- #' @export+ row_label <- if (labelstr != "") {
|
||
| 295 | -+ | |||
| 59 | +! |
- #' @order 2+ labelstr |
||
| 296 | -+ | |||
| 60 | +9x |
- compare_vars <- function(lyt,+ } else if (!is.null(custom_label)) {
|
||
| 297 | -+ | |||
| 61 | +2x |
- vars,+ custom_label |
||
| 298 | +62 |
- var_labels = vars,+ } else {
|
||
| 299 | -+ | |||
| 63 | +7x |
- na_str = default_na_str(),+ "counts" |
||
| 300 | +64 |
- nested = TRUE,+ } |
||
| 301 | -+ | |||
| 65 | +9x |
- ...,+ y$unique <- formatters::with_label( |
||
| 302 | -+ | |||
| 66 | +9x |
- na.rm = TRUE, # nolint+ s_num_patients_content(df = df, .N_col = 1, .var = id, required = NULL)$unique[1L], |
||
| 303 | -+ | |||
| 67 | +9x |
- show_labels = "default",+ row_label |
||
| 304 | +68 |
- table_names = vars,+ ) |
||
| 305 | -+ | |||
| 69 | +9x |
- section_div = NA_character_,+ y$all <- formatters::with_label( |
||
| 306 | -+ | |||
| 70 | +9x |
- .stats = c("n", "mean_sd", "count_fraction", "pval"),
+ nrow(df), |
||
| 307 | -+ | |||
| 71 | +9x |
- .formats = NULL,+ row_label |
||
| 308 | +72 |
- .labels = NULL,+ ) |
||
| 309 | -+ | |||
| 73 | +9x |
- .indent_mods = NULL) {
+ events <- Map( |
||
| 310 | -4x | +74 | +9x |
- extra_args <- list(.stats = .stats, na.rm = na.rm, na_str = na_str, compare = TRUE, ...)+ function(filters) {
|
| 311 | -+ | |||
| 75 | +25x |
-
+ formatters::with_label( |
||
| 312 | -1x | +76 | +25x |
- if (!is.null(.formats)) extra_args[[".formats"]] <- .formats+ s_count_patients_with_event(df = df, .var = ".row_index", filters = filters, .N_col = 1, .N_row = 1)$count, |
| 313 | -1x | +77 | +25x |
- if (!is.null(.labels)) extra_args[[".labels"]] <- .labels+ row_label |
| 314 | -! | +|||
| 78 | +
- if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods+ ) |
|||
| 315 | +79 |
-
+ }, |
||
| 316 | -4x | +80 | +9x |
- analyze(+ filters = filters_list |
| 317 | -4x | +|||
| 81 | +
- lyt = lyt,+ ) |
|||
| 318 | -4x | +82 | +9x |
- vars = vars,+ y_complete <- c(y, events) |
| 319 | -4x | +83 | +9x |
- var_labels = var_labels,+ y <- if (length(empty_stats) > 0) {
|
| 320 | -4x | +84 | +3x |
- afun = a_summary,+ y_reduced <- y_complete |
| 321 | -4x | +85 | +3x |
- na_str = na_str,+ for (stat in intersect(names(y_complete), empty_stats)) {
|
| 322 | +86 | 4x |
- nested = nested,+ y_reduced[[stat]] <- formatters::with_label(character(), obj_label(y_reduced[[stat]])) |
|
| 323 | -4x | +|||
| 87 | +
- extra_args = extra_args,+ } |
|||
| 324 | -4x | +88 | +3x |
- inclNAs = TRUE,+ y_reduced |
| 325 | -4x | +|||
| 89 | +
- show_labels = show_labels,+ } else {
|
|||
| 326 | -4x | +90 | +6x |
- table_names = table_names,+ y_complete+ |
+
| 91 | ++ |
+ } |
||
| 327 | -4x | +92 | +9x |
- section_div = section_div+ y |
| 328 | +93 |
- )+ } |
||
| 329 | +94 |
- }+ |
| 1 | +95 |
- #' Convert list of groups to a data frame+ #' @describeIn count_patients_events_in_cols Layout-creating function which can take statistics function |
||
| 2 | +96 | ++ |
+ #' arguments and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ |
+ |
| 97 |
#' |
|||
| 3 | +98 |
- #' This converts a list of group levels into a data frame format which is expected by [rtables::add_combo_levels()].+ #' @param col_split (`flag`)\cr whether the columns should be split. |
||
| 4 | +99 | ++ |
+ #' Set to `FALSE` when the required column split has been done already earlier in the layout pipe.+ |
+ |
| 100 |
#' |
|||
| 5 | +101 |
- #' @param groups_list (named `list` of `character`)\cr specifies the new group levels via the names and the+ #' @return |
||
| 6 | +102 |
- #' levels that belong to it in the character vectors that are elements of the list.+ #' * `summarize_patients_events_in_cols()` returns a layout object suitable for passing to further layouting functions, |
||
| 7 | +103 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows |
||
| 8 | +104 |
- #' @return A `tibble` in the required format.+ #' containing the statistics from `s_count_patients_and_multiple_events()` to the table layout. |
||
| 9 | +105 |
#' |
||
| 10 | +106 |
#' @examples |
||
| 11 | +107 |
- #' grade_groups <- list(+ #' df <- data.frame( |
||
| 12 | +108 |
- #' "Any Grade (%)" = c("1", "2", "3", "4", "5"),
+ #' USUBJID = rep(c("id1", "id2", "id3", "id4"), c(2, 3, 1, 1)),
|
||
| 13 | +109 |
- #' "Grade 3-4 (%)" = c("3", "4"),
+ #' ARM = c("A", "A", "B", "B", "B", "B", "A"),
|
||
| 14 | +110 |
- #' "Grade 5 (%)" = "5"+ #' AESER = rep("Y", 7),
|
||
| 15 | +111 |
- #' )+ #' AESDTH = c("Y", "Y", "N", "Y", "Y", "N", "N"),
|
||
| 16 | +112 |
- #' groups_list_to_df(grade_groups)+ #' AEREL = c("Y", "Y", "N", "Y", "Y", "N", "Y"),
|
||
| 17 | +113 |
- #'+ #' AEDECOD = c("A", "A", "A", "B", "B", "C", "D"),
|
||
| 18 | +114 |
- #' @export+ #' AEBODSYS = rep(c("SOC1", "SOC2", "SOC3"), c(3, 3, 1))
|
||
| 19 | +115 |
- groups_list_to_df <- function(groups_list) {
- |
- ||
| 20 | -5x | -
- checkmate::assert_list(groups_list, names = "named")+ #' ) |
||
| 21 | -5x | +|||
| 116 | +
- lapply(groups_list, checkmate::assert_character)+ #' |
|||
| 22 | -5x | +|||
| 117 | +
- tibble::tibble(+ #' # `summarize_patients_events_in_cols()` |
|||
| 23 | -5x | +|||
| 118 | +
- valname = make_names(names(groups_list)),+ #' basic_table() %>% |
|||
| 24 | -5x | +|||
| 119 | +
- label = names(groups_list),+ #' summarize_patients_events_in_cols( |
|||
| 25 | -5x | +|||
| 120 | +
- levelcombo = unname(groups_list),+ #' filters_list = list( |
|||
| 26 | -5x | +|||
| 121 | +
- exargs = replicate(length(groups_list), list())+ #' related = formatters::with_label(c(AEREL = "Y"), "Events (Related)"), |
|||
| 27 | +122 |
- )+ #' fatal = c(AESDTH = "Y"), |
||
| 28 | +123 |
- }+ #' fatal_related = c(AEREL = "Y", AESDTH = "Y") |
||
| 29 | +124 |
-
+ #' ), |
||
| 30 | +125 |
- #' Reference and treatment group combination+ #' custom_label = "%s Total number of patients and events" |
||
| 31 | +126 |
- #'+ #' ) %>% |
||
| 32 | +127 |
- #' @description `r lifecycle::badge("stable")`
+ #' build_table(df) |
||
| 33 | +128 |
#' |
||
| 34 | +129 |
- #' Facilitate the re-combination of groups divided as reference and treatment groups; it helps in arranging groups of+ #' @export |
||
| 35 | +130 |
- #' columns in the `rtables` framework and teal modules.+ #' @order 2 |
||
| 36 | +131 |
- #'+ summarize_patients_events_in_cols <- function(lyt, # nolint |
||
| 37 | +132 |
- #' @param fct (`factor`)\cr the variable with levels which needs to be grouped.+ id = "USUBJID", |
||
| 38 | +133 |
- #' @param ref (`character`)\cr the reference level(s).+ filters_list = list(), |
||
| 39 | +134 |
- #' @param collapse (`string`)\cr a character string to separate `fct` and `ref`.+ empty_stats = character(), |
||
| 40 | +135 |
- #'+ na_str = default_na_str(), |
||
| 41 | +136 |
- #' @return A `list` with first item `ref` (reference) and second item `trt` (treatment).+ ..., |
||
| 42 | +137 |
- #'+ .stats = c( |
||
| 43 | +138 |
- #' @examples+ "unique", |
||
| 44 | +139 |
- #' groups <- combine_groups(+ "all", |
||
| 45 | +140 |
- #' fct = DM$ARM,+ names(filters_list) |
||
| 46 | +141 |
- #' ref = c("B: Placebo")
+ ), |
||
| 47 | +142 |
- #' )+ .labels = c( |
||
| 48 | +143 |
- #'+ unique = "Patients (All)", |
||
| 49 | +144 |
- #' basic_table() %>%+ all = "Events (All)", |
||
| 50 | +145 |
- #' split_cols_by_groups("ARM", groups) %>%
+ labels_or_names(filters_list) |
||
| 51 | +146 |
- #' add_colcounts() %>%+ ), |
||
| 52 | +147 |
- #' analyze_vars("AGE") %>%
+ col_split = TRUE) {
|
||
| 53 | -+ | |||
| 148 | +2x |
- #' build_table(DM)+ extra_args <- list(id = id, filters_list = filters_list, empty_stats = empty_stats, ...) |
||
| 54 | +149 |
- #'+ |
||
| 55 | -+ | |||
| 150 | +2x |
- #' @export+ afun_list <- Map( |
||
| 56 | -+ | |||
| 151 | +2x |
- combine_groups <- function(fct,+ function(stat) {
|
||
| 57 | -+ | |||
| 152 | +7x |
- ref = NULL,+ make_afun( |
||
| 58 | -+ | |||
| 153 | +7x |
- collapse = "/") {
+ s_count_patients_and_multiple_events, |
||
| 59 | -10x | +154 | +7x |
- checkmate::assert_string(collapse)+ .stats = stat, |
| 60 | -10x | +155 | +7x |
- checkmate::assert_character(ref, min.chars = 1, any.missing = FALSE, null.ok = TRUE)+ .formats = "xx." |
| 61 | -10x | +|||
| 156 | +
- checkmate::assert_multi_class(fct, classes = c("factor", "character"))
+ ) |
|||
| 62 | +157 |
-
+ }, |
||
| 63 | -10x | +158 | +2x |
- fct <- as_factor_keep_attributes(fct)+ stat = .stats |
| 64 | +159 |
-
+ ) |
||
| 65 | -10x | +160 | +2x |
- group_levels <- levels(fct)+ if (col_split) {
|
| 66 | -10x | +161 | +2x |
- if (is.null(ref)) {
+ lyt <- split_cols_by_multivar( |
| 67 | -6x | +162 | +2x |
- ref <- group_levels[1]+ lyt = lyt, |
| 68 | -+ | |||
| 163 | +2x |
- } else {
+ vars = rep(id, length(.stats)), |
||
| 69 | -4x | +164 | +2x |
- checkmate::assert_subset(ref, group_levels)+ varlabels = .labels[.stats] |
| 70 | +165 |
- }+ ) |
||
| 71 | +166 |
-
+ } |
||
| 72 | -10x | +167 | +2x |
- groups <- list(+ summarize_row_groups( |
| 73 | -10x | +168 | +2x |
- ref = group_levels[group_levels %in% ref],+ lyt = lyt, |
| 74 | -10x | +169 | +2x |
- trt = group_levels[!group_levels %in% ref]+ cfun = afun_list, |
| 75 | -+ | |||
| 170 | +2x |
- )+ na_str = na_str, |
||
| 76 | -10x | +171 | +2x |
- stats::setNames(groups, nm = lapply(groups, paste, collapse = collapse))+ extra_args = extra_args |
| 77 | +172 |
- }+ ) |
||
| 78 | +173 |
-
+ } |
| 79 | +1 |
- #' Split columns by groups of levels+ #' Count patients with abnormal range values |
||
| 80 | +2 |
#' |
||
| 81 | +3 |
#' @description `r lifecycle::badge("stable")`
|
||
| 82 | +4 |
#' |
||
| 83 | +5 |
- #' @inheritParams argument_convention+ #' The analyze function [count_abnormal()] creates a layout element to count patients with abnormal analysis range |
||
| 84 | +6 |
- #' @inheritParams groups_list_to_df+ #' values in each direction. |
||
| 85 | +7 |
- #' @param ... additional arguments to [rtables::split_cols_by()] in order. For instance, to+ #' |
||
| 86 | +8 |
- #' control formats (`format`), add a joint column for all groups (`incl_all`).+ #' This function analyzes primary analysis variable `var` which indicates abnormal range results. |
||
| 87 | +9 |
- #'+ #' Additional analysis variables that can be supplied as a list via the `variables` parameter are |
||
| 88 | +10 |
- #' @return A layout object suitable for passing to further layouting functions. Adding+ #' `id` (defaults to `USUBJID`), a variable to indicate unique subject identifiers, and `baseline` |
||
| 89 | +11 |
- #' this function to an `rtable` layout will add a column split including the given+ #' (defaults to `BNRIND`), a variable to indicate baseline reference ranges. |
||
| 90 | +12 |
- #' groups to the table layout.+ #' |
||
| 91 | +13 |
- #'+ #' For each direction specified via the `abnormal` parameter (e.g. High or Low), a fraction of |
||
| 92 | +14 |
- #' @seealso [rtables::split_cols_by()]+ #' patient counts is returned, with numerator and denominator calculated as follows: |
||
| 93 | +15 |
- #'+ #' * `num`: The number of patients with this abnormality recorded while on treatment. |
||
| 94 | +16 |
- #' @examples+ #' * `denom`: The total number of patients with at least one post-baseline assessment. |
||
| 95 | +17 |
- #' # 1 - Basic use+ #' |
||
| 96 | +18 |
- #'+ #' This function assumes that `df` has been filtered to only include post-baseline records. |
||
| 97 | +19 |
- #' # Without group combination `split_cols_by_groups` is+ #' |
||
| 98 | +20 |
- #' # equivalent to [rtables::split_cols_by()].+ #' @inheritParams argument_convention |
||
| 99 | +21 |
- #' basic_table() %>%+ #' @param abnormal (named `list`)\cr list identifying the abnormal range level(s) in `var`. Defaults to |
||
| 100 | +22 |
- #' split_cols_by_groups("ARM") %>%
+ #' `list(Low = "LOW", High = "HIGH")` but you can also group different levels into the named list, |
||
| 101 | +23 |
- #' add_colcounts() %>%+ #' for example, `abnormal = list(Low = c("LOW", "LOW LOW"), High = c("HIGH", "HIGH HIGH"))`.
|
||
| 102 | +24 |
- #' analyze("AGE") %>%
+ #' @param exclude_base_abn (`flag`)\cr whether to exclude subjects with baseline abnormality |
||
| 103 | +25 |
- #' build_table(DM)+ #' from numerator and denominator. |
||
| 104 | +26 |
- #'+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal")`
|
||
| 105 | +27 |
- #' # Add a reference column.+ #' to see available statistics for this function. |
||
| 106 | +28 |
- #' basic_table() %>%+ #' |
||
| 107 | +29 |
- #' split_cols_by_groups("ARM", ref_group = "B: Placebo") %>%
+ #' @note |
||
| 108 | +30 |
- #' add_colcounts() %>%+ #' * `count_abnormal()` only considers a single variable that contains multiple abnormal levels. |
||
| 109 | +31 |
- #' analyze(+ #' * `df` should be filtered to only include post-baseline records. |
||
| 110 | +32 |
- #' "AGE",+ #' * The denominator includes patients that may have other abnormal levels at baseline, |
||
| 111 | +33 |
- #' afun = function(x, .ref_group, .in_ref_col) {
+ #' and patients missing baseline records. Patients with these abnormalities at |
||
| 112 | +34 |
- #' if (.in_ref_col) {
+ #' baseline can be optionally excluded from numerator and denominator via the |
||
| 113 | +35 |
- #' in_rows("Diff Mean" = rcell(NULL))
+ #' `exclude_base_abn` parameter. |
||
| 114 | +36 |
- #' } else {
+ #' |
||
| 115 | +37 |
- #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+ #' @name abnormal |
||
| 116 | +38 |
- #' }+ #' @include formatting_functions.R |
||
| 117 | +39 |
- #' }+ #' @order 1 |
||
| 118 | +40 |
- #' ) %>%+ NULL |
||
| 119 | +41 |
- #' build_table(DM)+ |
||
| 120 | +42 |
- #'+ #' @describeIn abnormal Statistics function which counts patients with abnormal range values |
||
| 121 | +43 |
- #' # 2 - Adding group specification+ #' for a single `abnormal` level. |
||
| 122 | +44 |
#' |
||
| 123 | +45 |
- #' # Manual preparation of the groups.+ #' @return |
||
| 124 | +46 |
- #' groups <- list(+ #' * `s_count_abnormal()` returns the statistic `fraction` which is a vector with `num` and `denom` counts of patients. |
||
| 125 | +47 |
- #' "Arms A+B" = c("A: Drug X", "B: Placebo"),
+ #' |
||
| 126 | +48 |
- #' "Arms A+C" = c("A: Drug X", "C: Combination")
+ #' @keywords internal |
||
| 127 | +49 |
- #' )+ s_count_abnormal <- function(df, |
||
| 128 | +50 |
- #'+ .var, |
||
| 129 | +51 |
- #' # Use of split_cols_by_groups without reference column.+ abnormal = list(Low = "LOW", High = "HIGH"), |
||
| 130 | +52 |
- #' basic_table() %>%+ variables = list(id = "USUBJID", baseline = "BNRIND"), |
||
| 131 | +53 |
- #' split_cols_by_groups("ARM", groups) %>%
+ exclude_base_abn = FALSE) {
|
||
| 132 | -+ | |||
| 54 | +4x |
- #' add_colcounts() %>%+ checkmate::assert_list(abnormal, types = "character", names = "named", len = 2, any.missing = FALSE) |
||
| 133 | -+ | |||
| 55 | +4x |
- #' analyze("AGE") %>%
+ checkmate::assert_true(any(unlist(abnormal) %in% levels(df[[.var]]))) |
||
| 134 | -+ | |||
| 56 | +4x |
- #' build_table(DM)+ checkmate::assert_factor(df[[.var]]) |
||
| 135 | -+ | |||
| 57 | +4x |
- #'+ checkmate::assert_flag(exclude_base_abn) |
||
| 136 | -+ | |||
| 58 | +4x |
- #' # Including differentiated output in the reference column.+ assert_df_with_variables(df, c(range = .var, variables)) |
||
| 137 | -+ | |||
| 59 | +4x |
- #' basic_table() %>%+ checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
|
||
| 138 | -+ | |||
| 60 | +4x |
- #' split_cols_by_groups("ARM", groups_list = groups, ref_group = "Arms A+B") %>%
+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
||
| 139 | +61 |
- #' analyze(+ |
||
| 140 | -+ | |||
| 62 | +4x |
- #' "AGE",+ count_abnormal_single <- function(abn_name, abn) {
|
||
| 141 | +63 |
- #' afun = function(x, .ref_group, .in_ref_col) {
+ # Patients in the denominator fulfill: |
||
| 142 | +64 |
- #' if (.in_ref_col) {
+ # - have at least one post-baseline visit |
||
| 143 | +65 |
- #' in_rows("Diff. of Averages" = rcell(NULL))
+ # - their baseline must not be abnormal if `exclude_base_abn`. |
||
| 144 | -+ | |||
| 66 | +8x |
- #' } else {
+ if (exclude_base_abn) {
|
||
| 145 | -+ | |||
| 67 | +4x |
- #' in_rows("Diff. of Averages" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+ denom_select <- !(df[[variables$baseline]] %in% abn) |
||
| 146 | +68 |
- #' }+ } else {
|
||
| 147 | -+ | |||
| 69 | +4x |
- #' }+ denom_select <- TRUE |
||
| 148 | +70 |
- #' ) %>%+ } |
||
| 149 | -+ | |||
| 71 | +8x |
- #' build_table(DM)+ denom <- length(unique(df[denom_select, variables$id, drop = TRUE])) |
||
| 150 | +72 |
- #'+ |
||
| 151 | +73 |
- #' # 3 - Binary list dividing factor levels into reference and treatment+ # Patients in the numerator fulfill: |
||
| 152 | +74 |
- #'+ # - have at least one post-baseline visit with the required abnormality level |
||
| 153 | +75 |
- #' # `combine_groups` defines reference and treatment.+ # - are part of the denominator patients. |
||
| 154 | -+ | |||
| 76 | +8x |
- #' groups <- combine_groups(+ num_select <- (df[[.var]] %in% abn) & denom_select |
||
| 155 | -+ | |||
| 77 | +8x |
- #' fct = DM$ARM,+ num <- length(unique(df[num_select, variables$id, drop = TRUE])) |
||
| 156 | +78 |
- #' ref = c("A: Drug X", "B: Placebo")
+
|
||
| 157 | -+ | |||
| 79 | +8x |
- #' )+ formatters::with_label(c(num = num, denom = denom), abn_name) |
||
| 158 | +80 |
- #' groups+ } |
||
| 159 | +81 |
- #'+ |
||
| 160 | +82 |
- #' # Use group definition without reference column.+ # This will define the abnormal levels theoretically possible for a specific lab parameter |
||
| 161 | +83 |
- #' basic_table() %>%+ # within a split level of a layout. |
||
| 162 | -+ | |||
| 84 | +4x |
- #' split_cols_by_groups("ARM", groups_list = groups) %>%
+ abnormal_lev <- lapply(abnormal, intersect, levels(df[[.var]])) |
||
| 163 | -+ | |||
| 85 | +4x |
- #' add_colcounts() %>%+ abnormal_lev <- abnormal_lev[vapply(abnormal_lev, function(x) length(x) > 0, logical(1))] |
||
| 164 | +86 |
- #' analyze("AGE") %>%
+
|
||
| 165 | -+ | |||
| 87 | +4x |
- #' build_table(DM)+ result <- sapply(names(abnormal_lev), function(i) count_abnormal_single(i, abnormal_lev[[i]]), simplify = FALSE) |
||
| 166 | -+ | |||
| 88 | +4x |
- #'+ result <- list(fraction = result) |
||
| 167 | -+ | |||
| 89 | +4x |
- #' # Use group definition with reference column (first item of groups).+ result |
||
| 168 | +90 |
- #' basic_table() %>%+ } |
||
| 169 | +91 |
- #' split_cols_by_groups("ARM", groups, ref_group = names(groups)[1]) %>%
+
|
||
| 170 | +92 |
- #' add_colcounts() %>%+ #' @describeIn abnormal Formatted analysis function which is used as `afun` in `count_abnormal()`. |
||
| 171 | +93 |
- #' analyze(+ #' |
||
| 172 | +94 |
- #' "AGE",+ #' @return |
||
| 173 | +95 |
- #' afun = function(x, .ref_group, .in_ref_col) {
+ #' * `a_count_abnormal()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 174 | +96 |
- #' if (.in_ref_col) {
+ #' |
||
| 175 | +97 |
- #' in_rows("Diff Mean" = rcell(NULL))
+ #' @keywords internal |
||
| 176 | +98 |
- #' } else {
+ a_count_abnormal <- make_afun( |
||
| 177 | +99 |
- #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+ s_count_abnormal, |
||
| 178 | +100 |
- #' }+ .formats = c(fraction = format_fraction) |
||
| 179 | +101 |
- #' }+ ) |
||
| 180 | +102 |
- #' ) %>%+ |
||
| 181 | +103 |
- #' build_table(DM)+ #' @describeIn abnormal Layout-creating function which can take statistics function arguments |
||
| 182 | +104 |
- #'+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 183 | +105 |
- #' @export+ #' |
||
| 184 | +106 |
- split_cols_by_groups <- function(lyt,+ #' @return |
||
| 185 | +107 |
- var,+ #' * `count_abnormal()` returns a layout object suitable for passing to further layouting functions, |
||
| 186 | +108 |
- groups_list = NULL,+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 187 | +109 |
- ref_group = NULL,+ #' the statistics from `s_count_abnormal()` to the table layout. |
||
| 188 | +110 |
- ...) {
+ #' |
||
| 189 | -6x | +|||
| 111 | +
- if (is.null(groups_list)) {
+ #' @examples |
|||
| 190 | -2x | +|||
| 112 | +
- split_cols_by(+ #' library(dplyr) |
|||
| 191 | -2x | +|||
| 113 | +
- lyt = lyt,+ #' |
|||
| 192 | -2x | +|||
| 114 | +
- var = var,+ #' df <- data.frame( |
|||
| 193 | -2x | +|||
| 115 | +
- ref_group = ref_group,+ #' USUBJID = as.character(c(1, 1, 2, 2)), |
|||
| 194 | +116 |
- ...+ #' ANRIND = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
|
||
| 195 | +117 |
- )+ #' BNRIND = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
|
||
| 196 | +118 |
- } else {
+ #' ONTRTFL = c("", "Y", "", "Y"),
|
||
| 197 | -4x | +|||
| 119 | +
- groups_df <- groups_list_to_df(groups_list)+ #' stringsAsFactors = FALSE |
|||
| 198 | -4x | +|||
| 120 | +
- if (!is.null(ref_group)) {
+ #' ) |
|||
| 199 | -3x | +|||
| 121 | +
- ref_group <- groups_df$valname[groups_df$label == ref_group]+ #' |
|||
| 200 | +122 |
- }+ #' # Select only post-baseline records. |
||
| 201 | -4x | +|||
| 123 | +
- split_cols_by(+ #' df <- df %>% |
|||
| 202 | -4x | +|||
| 124 | +
- lyt = lyt,+ #' filter(ONTRTFL == "Y") |
|||
| 203 | -4x | +|||
| 125 | +
- var = var,+ #' |
|||
| 204 | -4x | +|||
| 126 | +
- split_fun = add_combo_levels(groups_df, keep_levels = groups_df$valname),+ #' # Layout creating function. |
|||
| 205 | -4x | +|||
| 127 | +
- ref_group = ref_group,+ #' basic_table() %>% |
|||
| 206 | +128 |
- ...+ #' count_abnormal(var = "ANRIND", abnormal = list(high = "HIGH", low = "LOW")) %>% |
||
| 207 | +129 |
- )+ #' build_table(df) |
||
| 208 | +130 |
- }+ #' |
||
| 209 | +131 |
- }+ #' # Passing of statistics function and formatting arguments. |
||
| 210 | +132 |
-
+ #' df2 <- data.frame( |
||
| 211 | +133 |
- #' Combine counts+ #' ID = as.character(c(1, 1, 2, 2)), |
||
| 212 | +134 |
- #'+ #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
|
||
| 213 | +135 |
- #' Simplifies the estimation of column counts, especially when group combination is required.+ #' BL_RANGE = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
|
||
| 214 | +136 |
- #'+ #' ONTRTFL = c("", "Y", "", "Y"),
|
||
| 215 | +137 |
- #' @inheritParams combine_groups+ #' stringsAsFactors = FALSE |
||
| 216 | +138 |
- #' @inheritParams groups_list_to_df+ #' ) |
||
| 217 | +139 |
#' |
||
| 218 | +140 |
- #' @return A `vector` of column counts.+ #' # Select only post-baseline records. |
||
| 219 | +141 |
- #'+ #' df2 <- df2 %>% |
||
| 220 | +142 |
- #' @seealso [combine_groups()]+ #' filter(ONTRTFL == "Y") |
||
| 221 | +143 |
#' |
||
| 222 | +144 |
- #' @examples+ #' basic_table() %>% |
||
| 223 | +145 |
- #' ref <- c("A: Drug X", "B: Placebo")
+ #' count_abnormal( |
||
| 224 | +146 |
- #' groups <- combine_groups(fct = DM$ARM, ref = ref)+ #' var = "RANGE", |
||
| 225 | +147 |
- #'+ #' abnormal = list(low = "LOW", high = "HIGH"), |
||
| 226 | +148 |
- #' col_counts <- combine_counts(+ #' variables = list(id = "ID", baseline = "BL_RANGE") |
||
| 227 | +149 |
- #' fct = DM$ARM,+ #' ) %>% |
||
| 228 | +150 |
- #' groups_list = groups+ #' build_table(df2) |
||
| 229 | +151 |
- #' )+ #' |
||
| 230 | +152 |
- #'+ #' @export |
||
| 231 | +153 |
- #' basic_table() %>%+ #' @order 2 |
||
| 232 | +154 |
- #' split_cols_by_groups("ARM", groups) %>%
+ count_abnormal <- function(lyt, |
||
| 233 | +155 |
- #' add_colcounts() %>%+ var, |
||
| 234 | +156 |
- #' analyze_vars("AGE") %>%
+ abnormal = list(Low = "LOW", High = "HIGH"), |
||
| 235 | +157 |
- #' build_table(DM, col_counts = col_counts)+ variables = list(id = "USUBJID", baseline = "BNRIND"), |
||
| 236 | +158 |
- #'+ exclude_base_abn = FALSE, |
||
| 237 | +159 |
- #' ref <- "A: Drug X"+ na_str = default_na_str(), |
||
| 238 | +160 |
- #' groups <- combine_groups(fct = DM$ARM, ref = ref)+ nested = TRUE, |
||
| 239 | +161 |
- #' col_counts <- combine_counts(+ ..., |
||
| 240 | +162 |
- #' fct = DM$ARM,+ table_names = var, |
||
| 241 | +163 |
- #' groups_list = groups+ .stats = NULL, |
||
| 242 | +164 |
- #' )+ .formats = NULL, |
||
| 243 | +165 |
- #'+ .labels = NULL, |
||
| 244 | +166 |
- #' basic_table() %>%+ .indent_mods = NULL) {
|
||
| 245 | -+ | |||
| 167 | +3x |
- #' split_cols_by_groups("ARM", groups) %>%
+ extra_args <- list(abnormal = abnormal, variables = variables, exclude_base_abn = exclude_base_abn, ...) |
||
| 246 | +168 |
- #' add_colcounts() %>%+ |
||
| 247 | -+ | |||
| 169 | +3x |
- #' analyze_vars("AGE") %>%
+ afun <- make_afun( |
||
| 248 | -+ | |||
| 170 | +3x |
- #' build_table(DM, col_counts = col_counts)+ a_count_abnormal, |
||
| 249 | -+ | |||
| 171 | +3x |
- #'+ .stats = .stats, |
||
| 250 | -+ | |||
| 172 | +3x |
- #' @export+ .formats = .formats, |
||
| 251 | -+ | |||
| 173 | +3x |
- combine_counts <- function(fct, groups_list = NULL) {
+ .labels = .labels, |
||
| 252 | -4x | +174 | +3x |
- checkmate::assert_multi_class(fct, classes = c("factor", "character"))
+ .indent_mods = .indent_mods,+ |
+
| 175 | +3x | +
+ .ungroup_stats = "fraction" |
||
| 253 | +176 | ++ |
+ )+ |
+ |
| 177 | ||||
| 254 | -4x | +178 | +3x |
- fct <- as_factor_keep_attributes(fct)+ checkmate::assert_string(var) |
| 255 | +179 | |||
| 256 | -4x | +180 | +3x |
- if (is.null(groups_list)) {
+ analyze( |
| 257 | -1x | +181 | +3x |
- y <- table(fct)+ lyt = lyt, |
| 258 | -1x | +182 | +3x |
- y <- stats::setNames(as.numeric(y), nm = dimnames(y)[[1]])+ vars = var, |
| 259 | -+ | |||
| 183 | +3x |
- } else {
+ afun = afun, |
||
| 260 | +184 | 3x |
- y <- vapply(+ na_str = na_str, |
|
| 261 | +185 | 3x |
- X = groups_list,+ nested = nested, |
|
| 262 | +186 | 3x |
- FUN = function(x) sum(table(fct)[x]),+ table_names = table_names, |
|
| 263 | +187 | 3x |
- FUN.VALUE = 1+ extra_args = extra_args, |
|
| 264 | -+ | |||
| 188 | +3x |
- )+ show_labels = "hidden" |
||
| 265 | +189 |
- }- |
- ||
| 266 | -4x | -
- y+ ) |
||
| 267 | +190 |
}@@ -163202,14 +161965,14 @@ tern coverage - 95.64% |
| 1 |
- #' Incidence rate estimation+ #' Count the number of patients with particular flags |
|||
| 5 |
- #' The analyze function [estimate_incidence_rate()] creates a layout element to estimate an event rate adjusted for+ #' The analyze function [count_patients_with_flags()] creates a layout element to calculate counts of patients for |
|||
| 6 |
- #' person-years at risk, otherwise known as incidence rate. The primary analysis variable specified via `vars` is+ #' which user-specified flags are present. |
|||
| 7 |
- #' the person-years at risk. In addition to this variable, the `n_events` variable for number of events observed (where+ #' |
|||
| 8 |
- #' a value of 1 means an event was observed and 0 means that no event was observed) must also be specified.+ #' 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 |
|||
| 10 |
- #' @inheritParams argument_convention+ #' `TRUE` (flag present) or `FALSE` (flag absent) for each record. |
|||
| 11 |
- #' @param control (`list`)\cr parameters for estimation details, specified by using+ #' |
|||
| 12 |
- #' the helper function [control_incidence_rate()]. Possible parameter options are:+ #' If there are multiple records with the same flag present for a patient, only one occurrence is counted. |
|||
| 13 |
- #' * `conf_level` (`proportion`)\cr confidence level for the estimated incidence rate.+ #' |
|||
| 14 |
- #' * `conf_type` (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`+ #' @inheritParams argument_convention |
|||
| 15 |
- #' for confidence interval type.+ #' @param flag_variables (`character`)\cr a vector specifying the names of `logical` variables from analysis dataset |
|||
| 16 |
- #' * `input_time_unit` (`string`)\cr `day`, `week`, `month`, or `year` (default)+ #' used for counting the number of unique identifiers. |
|||
| 17 |
- #' indicating time unit for data input.+ #' @param flag_labels (`character`)\cr vector of labels to use for flag variables. |
|||
| 18 |
- #' * `num_pt_year` (`numeric`)\cr time unit for desired output (in person-years).+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_patients_with_flags")`
|
|||
| 19 |
- #' @param n_events (`string`)\cr name of integer variable indicating whether an event has been observed (1) or not (0).+ #' to see available statistics for this function. |
|||
| 20 |
- #' @param id_var (`string`)\cr name of variable used as patient identifier if `"n_unique"` is included in `.stats`.+ #' |
|||
| 21 |
- #' Defaults to `"USUBJID"`.+ #' @seealso [count_patients_with_event] |
|||
| 22 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_incidence_rate")`
+ #' |
|||
| 23 |
- #' to see available statistics for this function.+ #' @name count_patients_with_flags |
|||
| 24 |
- #' @param summarize (`flag`)\cr whether the function should act as an analyze function (`summarize = FALSE`), or a+ #' @order 1 |
|||
| 25 |
- #' summarize function (`summarize = TRUE`). Defaults to `FALSE`.+ NULL |
|||
| 26 |
- #' @param label_fmt (`string`)\cr how labels should be formatted after a row split occurs if `summarize = TRUE`. The+ |
|||
| 27 |
- #' string should use `"%s"` to represent row split levels, and `"%.labels"` to represent labels supplied to the+ #' @describeIn count_patients_with_flags Statistics function which counts the number of patients for which |
|||
| 28 |
- #' `.labels` argument. Defaults to `"%s - %.labels"`.+ #' a particular flag variable is `TRUE`. |
|||
| 30 |
- #' @seealso [control_incidence_rate()] and helper functions [h_incidence_rate].+ #' @inheritParams analyze_variables |
|||
| 31 |
- #'+ #' @param .var (`string`)\cr name of the column that contains the unique identifier. |
|||
| 32 |
- #' @examples+ #' |
|||
| 33 |
- #' df <- data.frame(+ #' @note If `flag_labels` is not specified, variables labels will be extracted from `df`. If variables are not |
|||
| 34 |
- #' USUBJID = as.character(seq(6)),+ #' labeled, variable names will be used instead. Alternatively, a named `vector` can be supplied to |
|||
| 35 |
- #' CNSR = c(0, 1, 1, 0, 0, 0),+ #' `flag_variables` such that within each name-value pair the name corresponds to the variable name and the value is |
|||
| 36 |
- #' AVAL = c(10.1, 20.4, 15.3, 20.8, 18.7, 23.4),+ #' the label to use for this variable. |
|||
| 37 |
- #' ARM = factor(c("A", "A", "A", "B", "B", "B")),
+ #' |
|||
| 38 |
- #' STRATA1 = factor(c("X", "Y", "Y", "X", "X", "Y"))
+ #' @return |
|||
| 39 |
- #' )+ #' * `s_count_patients_with_flags()` returns the count and the fraction of unique identifiers with each particular |
|||
| 40 |
- #' df$n_events <- 1 - df$CNSR+ #' flag as a list of statistics `n`, `count`, `count_fraction`, and `n_blq`, with one element per flag. |
|||
| 42 |
- #' @name incidence_rate+ #' @examples |
|||
| 43 |
- #' @order 1+ #' # `s_count_patients_with_flags()` |
|||
| 44 |
- NULL+ #' |
|||
| 45 |
-
+ #' s_count_patients_with_flags( |
|||
| 46 |
- #' @describeIn incidence_rate Statistics function which estimates the incidence rate and the+ #' adae, |
|||
| 47 |
- #' associated confidence interval.+ #' "SUBJID", |
|||
| 48 |
- #'+ #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
|
|||
| 49 |
- #' @return+ #' denom = "N_col", |
|||
| 50 |
- #' * `s_incidence_rate()` returns the following statistics:+ #' .N_col = 1000 |
|||
| 51 |
- #' - `person_years`: Total person-years at risk.+ #' ) |
|||
| 52 |
- #' - `n_events`: Total number of events observed.+ #' |
|||
| 53 |
- #' - `rate`: Estimated incidence rate.+ #' @export |
|||
| 54 |
- #' - `rate_ci`: Confidence interval for the incidence rate.+ s_count_patients_with_flags <- function(df, |
|||
| 55 |
- #' - `n_unique`: Total number of patients with at least one event observed.+ .var, |
|||
| 56 |
- #' - `n_rate`: Total number of events observed & estimated incidence rate.+ flag_variables, |
|||
| 57 |
- #'+ flag_labels = NULL, |
|||
| 58 |
- #' @keywords internal+ .N_col, # nolint |
|||
| 59 |
- s_incidence_rate <- function(df,+ .N_row, # nolint |
|||
| 60 |
- .var,+ denom = c("n", "N_row", "N_col")) {
|
|||
| 61 | -+ | 10x |
- n_events,+ checkmate::assert_character(flag_variables) |
|
| 62 | -+ | 10x |
- is_event = lifecycle::deprecated(),+ if (!is.null(flag_labels)) {
|
|
| 63 | -+ | 1x |
- id_var = "USUBJID",+ checkmate::assert_character(flag_labels, len = length(flag_variables), any.missing = FALSE) |
|
| 64 | -+ | 1x |
- control = control_incidence_rate()) {
+ flag_names <- flag_labels |
|
| 65 | -17x | +
- if (lifecycle::is_present(is_event)) {
+ } else {
|
||
| 66 | -! | +9x |
- checkmate::assert_string(is_event)+ if (is.null(names(flag_variables))) {
|
|
| 67 | -! | +8x |
- lifecycle::deprecate_warn(+ flag_names <- formatters::var_labels(df[flag_variables], fill = TRUE) |
|
| 68 | -! | +
- "0.9.6", "s_incidence_rate(is_event)", "s_incidence_rate(n_events)"+ } else {
|
||
| 69 | -+ | 1x |
- )+ flag_names <- unname(flag_variables) |
|
| 70 | -! | +1x |
- n_events <- is_event+ flag_variables <- names(flag_variables) |
|
| 71 | -! | +
- df[[n_events]] <- as.numeric(df[[is_event]])+ } |
||
| 74 | -17x | +10x |
- assert_df_with_variables(df, list(tte = .var, n_events = n_events))+ checkmate::assert_subset(flag_variables, colnames(df)) |
|
| 75 | -17x | +10x |
- checkmate::assert_string(.var)+ temp <- sapply(flag_variables, function(x) {
|
|
| 76 | -17x | +27x |
- checkmate::assert_string(n_events)+ tmp <- Map(function(y) which(df[[y]]), x) |
|
| 77 | -17x | +27x |
- checkmate::assert_string(id_var)+ position_satisfy_flags <- Reduce(intersect, tmp) |
|
| 78 | -17x | +27x |
- checkmate::assert_numeric(df[[.var]], any.missing = FALSE)+ id_satisfy_flags <- as.character(unique(df[position_satisfy_flags, ][[.var]])) |
|
| 79 | -17x | +27x |
- checkmate::assert_integerish(df[[n_events]], any.missing = FALSE)+ s_count_values( |
|
| 80 | -+ | 27x |
-
+ as.character(unique(df[[.var]])), |
|
| 81 | -17x | +27x |
- n_unique <- n_available(unique(df[[id_var]][df[[n_events]] == 1]))+ id_satisfy_flags, |
|
| 82 | -17x | +27x |
- input_time_unit <- control$input_time_unit+ denom = denom, |
|
| 83 | -17x | +27x |
- num_pt_year <- control$num_pt_year+ .N_col = .N_col, |
|
| 84 | -17x | +27x |
- conf_level <- control$conf_level+ .N_row = .N_row |
|
| 85 | -17x | +
- person_years <- sum(df[[.var]], na.rm = TRUE) * (+ ) |
||
| 86 | -17x | +
- 1 * (input_time_unit == "year") ++ }) |
||
| 87 | -17x | +10x |
- 1 / 12 * (input_time_unit == "month") ++ colnames(temp) <- flag_names |
|
| 88 | -17x | +10x |
- 1 / 52.14 * (input_time_unit == "week") ++ temp <- data.frame(t(temp)) |
|
| 89 | -17x | +10x |
- 1 / 365.24 * (input_time_unit == "day")+ result <- temp %>% as.list() |
|
| 90 | -+ | 10x |
- )+ if (length(flag_variables) == 1) {
|
|
| 91 | -17x | +1x |
- n_events <- sum(df[[n_events]], na.rm = TRUE)+ for (i in 1:3) names(result[[i]]) <- flag_names[1] |
|
| 92 |
-
+ } |
|||
| 93 | -17x | -
- result <- h_incidence_rate(- |
- ||
| 94 | -17x | -
- person_years,- |
- ||
| 95 | -17x | -
- n_events,- |
- ||
| 96 | -17x | -
- control- |
- ||
| 97 | -- |
- )- |
- ||
| 98 | -17x | -
- list(- |
- ||
| 99 | -17x | -
- person_years = formatters::with_label(person_years, "Total patient-years at risk"),- |
- ||
| 100 | -17x | -
- n_events = formatters::with_label(n_events, "Number of adverse events observed"),- |
- ||
| 101 | -17x | -
- rate = formatters::with_label(result$rate, paste("AE rate per", num_pt_year, "patient-years")),
- |
- ||
| 102 | -17x | -
- rate_ci = formatters::with_label(result$rate_ci, f_conf_level(conf_level)),- |
- ||
| 103 | -17x | -
- n_unique = formatters::with_label(n_unique, "Total number of patients with at least one adverse event"),- |
- ||
| 104 | -17x | -
- n_rate = formatters::with_label(- |
- ||
| 105 | -17x | -
- c(n_events, result$rate),- |
- ||
| 106 | -17x | -
- paste("Number of adverse events observed (AE rate per", num_pt_year, "patient-years)")
- |
- ||
| 107 | -+ | 10x |
- )+ result |
|
| 108 | +94 |
- )+ } |
||
| 109 | +95 |
- }+ |
||
| 110 | +96 |
-
+ #' @describeIn count_patients_with_flags Formatted analysis function which is used as `afun` |
||
| 111 | +97 |
- #' @describeIn incidence_rate Formatted analysis function which is used as `afun` in `estimate_incidence_rate()`.+ #' in `count_patients_with_flags()`. |
||
| 112 | +98 |
#' |
||
| 113 | +99 |
#' @return |
||
| 114 | +100 |
- #' * `a_incidence_rate()` returns the corresponding list with formatted [rtables::CellValue()].+ #' * `a_count_patients_with_flags()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 115 | +101 |
#' |
||
| 116 | +102 |
#' @examples |
||
| 117 | -- |
- #' a_incidence_rate(- |
- ||
| 118 | -- |
- #' df,- |
- ||
| 119 | -- |
- #' .var = "AVAL",- |
- ||
| 120 | -- |
- #' .df_row = df,- |
- ||
| 121 | +103 |
- #' n_events = "n_events"+ #' # We need to ungroup `count_fraction` first so that the `rtables` formatting |
||
| 122 | +104 |
- #' )+ #' # function `format_count_fraction()` can be applied correctly. |
||
| 123 | +105 |
#' |
||
| 124 | -- |
- #' @export- |
- ||
| 125 | -- |
- a_incidence_rate <- function(df,- |
- ||
| 126 | -- |
- labelstr = "",- |
- ||
| 127 | -- |
- .var,- |
- ||
| 128 | -- |
- .df_row,- |
- ||
| 129 | -- |
- n_events,- |
- ||
| 130 | -- |
- id_var = "USUBJID",- |
- ||
| 131 | -- |
- control = control_incidence_rate(),- |
- ||
| 132 | -- |
- .stats = NULL,- |
- ||
| 133 | -- |
- .formats = c(- |
- ||
| 134 | -- |
- "person_years" = "xx.x",- |
- ||
| 135 | -- |
- "n_events" = "xx",- |
- ||
| 136 | -- |
- "rate" = "xx.xx",- |
- ||
| 137 | -- |
- "rate_ci" = "(xx.xx, xx.xx)",- |
- ||
| 138 | +106 |
- "n_unique" = "xx",+ #' # `a_count_patients_with_flags()` |
||
| 139 | +107 |
- "n_rate" = "xx (xx.x)"+ #' |
||
| 140 | +108 |
- ),+ #' afun <- make_afun(a_count_patients_with_flags, |
||
| 141 | +109 |
- .labels = NULL,+ #' .stats = "count_fraction", |
||
| 142 | +110 |
- .indent_mods = NULL,+ #' .ungroup_stats = "count_fraction" |
||
| 143 | +111 |
- na_str = default_na_str(),+ #' ) |
||
| 144 | +112 |
- label_fmt = "%s - %.labels") {
- |
- ||
| 145 | -16x | -
- checkmate::assert_string(label_fmt)+ #' afun( |
||
| 146 | +113 | - - | -||
| 147 | -16x | -
- x_stats <- s_incidence_rate(- |
- ||
| 148 | -16x | -
- df = df, .var = .var, n_events = n_events, id_var = id_var, control = control+ #' adae, |
||
| 149 | +114 |
- )- |
- ||
| 150 | -16x | -
- if (is.null(unlist(x_stats))) {
- |
- ||
| 151 | -! | -
- return(NULL)+ #' .N_col = 10L, |
||
| 152 | +115 |
- }+ #' .N_row = 10L, |
||
| 153 | +116 |
-
+ #' .var = "USUBJID", |
||
| 154 | +117 |
- # Fill in with defaults- |
- ||
| 155 | -16x | -
- formats_def <- formals()$.formats %>% eval()- |
- ||
| 156 | -16x | -
- .formats <- c(.formats, formats_def)[!duplicated(names(c(.formats, formats_def)))]- |
- ||
| 157 | -16x | -
- labels_def <- sapply(x_stats, \(x) attributes(x)$label)- |
- ||
| 158 | -16x | -
- .labels <- c(.labels, labels_def)[!duplicated(names(c(.labels, labels_def)))]- |
- ||
| 159 | -16x | -
- if (nzchar(labelstr) > 0) {
- |
- ||
| 160 | -8x | -
- .labels <- sapply(.labels, \(x) gsub("%.labels", x, gsub("%s", labelstr, label_fmt)))
+ #' flag_variables = c("fl1", "fl2", "fl3", "fl4")
|
||
| 161 | +118 |
- }+ #' ) |
||
| 162 | +119 |
-
+ #' |
||
| 163 | +120 |
- # Fill in with formatting defaults if needed- |
- ||
| 164 | -16x | -
- .stats <- get_stats("estimate_incidence_rate", stats_in = .stats)
- |
- ||
| 165 | -16x | -
- .formats <- get_formats_from_stats(.stats, .formats)- |
- ||
| 166 | -16x | -
- .labels <- get_labels_from_stats(.stats, .labels)- |
- ||
| 167 | -16x | -
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods)+ #' @export |
||
| 168 | +121 | - - | -||
| 169 | -16x | -
- x_stats <- x_stats[.stats]+ a_count_patients_with_flags <- make_afun( |
||
| 170 | +122 | - - | -||
| 171 | -16x | -
- in_rows(- |
- ||
| 172 | -16x | -
- .list = x_stats,- |
- ||
| 173 | -16x | -
- .formats = .formats,- |
- ||
| 174 | -16x | -
- .labels = .labels,- |
- ||
| 175 | -16x | -
- .indent_mods = .indent_mods,- |
- ||
| 176 | -16x | -
- .format_na_strs = na_str+ s_count_patients_with_flags, |
||
| 177 | +123 |
- )+ .formats = c("count_fraction" = format_count_fraction_fixed_dp)
|
||
| 178 | +124 |
- }+ ) |
||
| 179 | +125 | |||
| 180 | +126 |
- #' @describeIn incidence_rate Layout-creating function which can take statistics function arguments+ #' @describeIn count_patients_with_flags Layout-creating function which can take statistics function |
||
| 181 | +127 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 182 | +128 |
#' |
||
| 183 | +129 |
#' @return |
||
| 184 | +130 |
- #' * `estimate_incidence_rate()` returns a layout object suitable for passing to further layouting functions,+ #' * `count_patients_with_flags()` returns a layout object suitable for passing to further layouting functions, |
||
| 185 | +131 |
#' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 186 | +132 |
- #' the statistics from `s_incidence_rate()` to the table layout.+ #' the statistics from `s_count_patients_with_flags()` to the table layout. |
||
| 187 | +133 |
#' |
||
| 188 | +134 |
#' @examples |
||
| 189 | +135 |
- #' basic_table(show_colcounts = TRUE) %>%+ #' library(dplyr) |
||
| 190 | +136 |
- #' split_cols_by("ARM") %>%
+ #' |
||
| 191 | +137 |
- #' estimate_incidence_rate(+ #' # Add labelled flag variables to analysis dataset. |
||
| 192 | +138 |
- #' vars = "AVAL",+ #' adae <- tern_ex_adae %>% |
||
| 193 | +139 |
- #' n_events = "n_events",+ #' mutate( |
||
| 194 | +140 |
- #' control = control_incidence_rate(+ #' fl1 = TRUE %>% with_label("Total AEs"),
|
||
| 195 | +141 |
- #' input_time_unit = "month",+ #' fl2 = (TRTEMFL == "Y") %>% |
||
| 196 | +142 |
- #' num_pt_year = 100+ #' with_label("Total number of patients with at least one adverse event"),
|
||
| 197 | +143 |
- #' )+ #' fl3 = (TRTEMFL == "Y" & AEOUT == "FATAL") %>% |
||
| 198 | +144 |
- #' ) %>%+ #' with_label("Total number of patients with fatal AEs"),
|
||
| 199 | +145 |
- #' build_table(df)+ #' fl4 = (TRTEMFL == "Y" & AEOUT == "FATAL" & AEREL == "Y") %>% |
||
| 200 | +146 | ++ |
+ #' with_label("Total number of patients with related fatal AEs")
+ |
+ |
| 147 | ++ |
+ #' )+ |
+ ||
| 148 |
#' |
|||
| 201 | +149 |
- #' # summarize = TRUE+ #' # `count_patients_with_flags()` |
||
| 202 | +150 |
- #' basic_table(show_colcounts = TRUE) %>%+ #' |
||
| 203 | +151 |
- #' split_cols_by("ARM") %>%
+ #' lyt2 <- basic_table() %>% |
||
| 204 | +152 |
- #' split_rows_by("STRATA1", child_labels = "visible") %>%
+ #' split_cols_by("ARM") %>%
|
||
| 205 | +153 |
- #' estimate_incidence_rate(+ #' add_colcounts() %>% |
||
| 206 | +154 |
- #' vars = "AVAL",+ #' count_patients_with_flags( |
||
| 207 | +155 |
- #' n_events = "n_events",+ #' "SUBJID", |
||
| 208 | +156 |
- #' .stats = c("n_unique", "n_rate"),
+ #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
|
||
| 209 | +157 |
- #' summarize = TRUE,+ #' denom = "N_col" |
||
| 210 | +158 |
- #' label_fmt = "%.labels"+ #' ) |
||
| 211 | +159 |
- #' ) %>%+ #' |
||
| 212 | +160 |
- #' build_table(df)+ #' build_table(lyt2, adae, alt_counts_df = tern_ex_adsl) |
||
| 213 | +161 |
#' |
||
| 214 | +162 |
#' @export |
||
| 215 | +163 |
#' @order 2 |
||
| 216 | +164 |
- estimate_incidence_rate <- function(lyt,+ count_patients_with_flags <- function(lyt, |
||
| 217 | +165 |
- vars,+ var, |
||
| 218 | +166 |
- n_events,+ flag_variables, |
||
| 219 | +167 |
- id_var = "USUBJID",+ flag_labels = NULL, |
||
| 220 | +168 |
- control = control_incidence_rate(),+ var_labels = var, |
||
| 221 | +169 |
- na_str = default_na_str(),+ show_labels = "hidden", |
||
| 222 | +170 |
- nested = TRUE,+ riskdiff = FALSE, |
||
| 223 | +171 |
- summarize = FALSE,+ na_str = default_na_str(), |
||
| 224 | +172 |
- label_fmt = "%s - %.labels",+ nested = TRUE, |
||
| 225 | +173 |
- ...,+ ..., |
||
| 226 | +174 |
- show_labels = "hidden",+ table_names = paste0("tbl_flags_", var),
|
||
| 227 | +175 |
- table_names = vars,+ .stats = "count_fraction", |
||
| 228 | +176 |
- .stats = c("person_years", "n_events", "rate", "rate_ci"),
+ .formats = NULL, |
||
| 229 | +177 |
- .formats = NULL,+ .indent_mods = NULL) {
+ |
+ ||
| 178 | +10x | +
+ checkmate::assert_flag(riskdiff) |
||
| 230 | +179 |
- .labels = NULL,+ + |
+ ||
| 180 | +10x | +
+ s_args <- list(flag_variables = flag_variables, flag_labels = flag_labels, ...) |
||
| 231 | +181 |
- .indent_mods = NULL) {
+
|
||
| 232 | -5x | +182 | +10x |
- extra_args <- c(+ afun <- make_afun( |
| 233 | -5x | +183 | +10x |
- list(.stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str),+ a_count_patients_with_flags, |
| 234 | -5x | +184 | +10x |
- list(n_events = n_events, id_var = id_var, control = control, label_fmt = label_fmt, ...)+ .stats = .stats,+ |
+
| 185 | +10x | +
+ .formats = .formats,+ |
+ ||
| 186 | +10x | +
+ .indent_mods = .indent_mods,+ |
+ ||
| 187 | +10x | +
+ .ungroup_stats = .stats |
||
| 235 | +188 |
) |
||
| 236 | +189 | |||
| 237 | -5x | +190 | +10x |
- if (!summarize) {
+ extra_args <- if (isFALSE(riskdiff)) {
|
| 238 | -3x | +191 | +8x |
- analyze(+ s_args |
| 239 | -3x | +|||
| 192 | +
- lyt,+ } else {
|
|||
| 240 | -3x | +193 | +2x |
- vars,+ list( |
| 241 | -3x | +194 | +2x |
- show_labels = show_labels,+ afun = list("s_count_patients_with_flags" = afun),
|
| 242 | -3x | +195 | +2x |
- table_names = table_names,+ .stats = .stats, |
| 243 | -3x | +196 | +2x |
- afun = a_incidence_rate,+ .indent_mods = .indent_mods, |
| 244 | -3x | +197 | +2x |
- na_str = na_str,+ s_args = s_args |
| 245 | -3x | +|||
| 198 | +
- nested = nested,+ ) |
|||
| 246 | -3x | +|||
| 199 | +
- extra_args = extra_args+ } |
|||
| 247 | +200 |
- )+ |
||
| 248 | -+ | |||
| 201 | +10x |
- } else {
+ lyt <- analyze( |
||
| 249 | -2x | +202 | +10x |
- summarize_row_groups(+ lyt = lyt, |
| 250 | -2x | +203 | +10x |
- lyt,+ vars = var, |
| 251 | -2x | +204 | +10x |
- vars,+ var_labels = var_labels, |
| 252 | -2x | +205 | +10x |
- cfun = a_incidence_rate,+ show_labels = show_labels, |
| 253 | -2x | +206 | +10x |
- na_str = na_str,+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff), |
| 254 | -2x | +207 | +10x |
- extra_args = extra_args+ table_names = table_names,+ |
+
| 208 | +10x | +
+ na_str = na_str,+ |
+ ||
| 209 | +10x | +
+ nested = nested,+ |
+ ||
| 210 | +10x | +
+ extra_args = extra_args |
||
| 255 | +211 |
- )+ ) |
||
| 256 | +212 |
- }+ + |
+ ||
| 213 | +10x | +
+ lyt |
||
| 257 | +214 |
}@@ -165007,14 +163469,14 @@ tern coverage - 95.64% |
| 1 |
- #' Occurrence table sorting+ #' Convert list of groups to a data frame |
||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' This converts a list of group levels into a data frame format which is expected by [rtables::add_combo_levels()]. |
||
| 5 |
- #' Functions to score occurrence table subtables and rows which can be used in the+ #' @param groups_list (named `list` of `character`)\cr specifies the new group levels via the names and the |
||
| 6 |
- #' sorting of occurrence tables.+ #' levels that belong to it in the character vectors that are elements of the list. |
||
| 8 |
- #' @name score_occurrences+ #' @return A `tibble` in the required format. |
||
| 9 |
- NULL+ #' |
||
| 10 |
-
+ #' @examples |
||
| 11 |
- #' @describeIn score_occurrences Scoring function which sums the counts across all+ #' grade_groups <- list( |
||
| 12 |
- #' columns. It will fail if anything else but counts are used.+ #' "Any Grade (%)" = c("1", "2", "3", "4", "5"),
|
||
| 13 |
- #'+ #' "Grade 3-4 (%)" = c("3", "4"),
|
||
| 14 |
- #' @inheritParams rtables_access+ #' "Grade 5 (%)" = "5" |
||
| 15 |
- #'+ #' ) |
||
| 16 |
- #' @return+ #' groups_list_to_df(grade_groups) |
||
| 17 |
- #' * `score_occurrences()` returns the sum of counts across all columns of a table row.+ #' |
||
| 18 |
- #'+ #' @export |
||
| 19 |
- #' @seealso [h_row_first_values()]+ groups_list_to_df <- function(groups_list) {
|
||
| 20 | -+ | 5x |
- #'+ checkmate::assert_list(groups_list, names = "named") |
| 21 | -+ | 5x |
- #' @examples+ lapply(groups_list, checkmate::assert_character) |
| 22 | -+ | 5x |
- #' lyt <- basic_table() %>%+ tibble::tibble( |
| 23 | -+ | 5x |
- #' split_cols_by("ARM") %>%
+ valname = make_names(names(groups_list)), |
| 24 | -+ | 5x |
- #' add_colcounts() %>%+ label = names(groups_list), |
| 25 | -+ | 5x |
- #' analyze_num_patients(+ levelcombo = unname(groups_list), |
| 26 | -+ | 5x |
- #' vars = "USUBJID",+ exargs = replicate(length(groups_list), list()) |
| 27 |
- #' .stats = c("unique"),
+ ) |
||
| 28 |
- #' .labels = c("Total number of patients with at least one event")
+ } |
||
| 29 |
- #' ) %>%+ |
||
| 30 |
- #' split_rows_by("AEBODSYS", child_labels = "visible", nested = FALSE) %>%
+ #' Reference and treatment group combination |
||
| 31 |
- #' summarize_num_patients(+ #' |
||
| 32 |
- #' var = "USUBJID",+ #' @description `r lifecycle::badge("stable")`
|
||
| 33 |
- #' .stats = c("unique", "nonunique"),
+ #' |
||
| 34 |
- #' .labels = c(+ #' Facilitate the re-combination of groups divided as reference and treatment groups; it helps in arranging groups of |
||
| 35 |
- #' "Total number of patients with at least one event",+ #' columns in the `rtables` framework and teal modules. |
||
| 36 |
- #' "Total number of events"+ #' |
||
| 37 |
- #' )+ #' @param fct (`factor`)\cr the variable with levels which needs to be grouped. |
||
| 38 |
- #' ) %>%+ #' @param ref (`character`)\cr the reference level(s). |
||
| 39 |
- #' count_occurrences(vars = "AEDECOD")+ #' @param collapse (`string`)\cr a character string to separate `fct` and `ref`. |
||
| 41 |
- #' tbl <- build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl) %>%+ #' @return A `list` with first item `ref` (reference) and second item `trt` (treatment). |
||
| 42 |
- #' prune_table()+ #' |
||
| 43 |
- #'+ #' @examples |
||
| 44 |
- #' tbl_sorted <- tbl %>%+ #' groups <- combine_groups( |
||
| 45 |
- #' sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_occurrences)
+ #' fct = DM$ARM, |
||
| 46 |
- #'+ #' ref = c("B: Placebo")
|
||
| 47 |
- #' tbl_sorted+ #' ) |
||
| 49 |
- #' @export+ #' basic_table() %>% |
||
| 50 |
- score_occurrences <- function(table_row) {
+ #' split_cols_by_groups("ARM", groups) %>%
|
||
| 51 | -37x | +
- row_counts <- h_row_counts(table_row)+ #' add_colcounts() %>% |
|
| 52 | -37x | +
- sum(row_counts)+ #' analyze_vars("AGE") %>%
|
|
| 53 |
- }+ #' build_table(DM) |
||
| 54 |
-
+ #' |
||
| 55 |
- #' @describeIn score_occurrences Scoring functions can be produced by this constructor to only include+ #' @export |
||
| 56 |
- #' specific columns in the scoring. See [h_row_counts()] for further information.+ combine_groups <- function(fct, |
||
| 57 |
- #'+ ref = NULL, |
||
| 58 |
- #' @inheritParams has_count_in_cols+ collapse = "/") {
|
||
| 59 | -+ | 10x |
- #'+ checkmate::assert_string(collapse) |
| 60 | -+ | 10x |
- #' @return+ checkmate::assert_character(ref, min.chars = 1, any.missing = FALSE, null.ok = TRUE) |
| 61 | -+ | 10x |
- #' * `score_occurrences_cols()` returns a function that sums counts across all specified columns+ checkmate::assert_multi_class(fct, classes = c("factor", "character"))
|
| 62 |
- #' of a table row.+ |
||
| 63 | -+ | 10x |
- #'+ fct <- as_factor_keep_attributes(fct) |
| 64 |
- #' @seealso [h_row_counts()]+ |
||
| 65 | -+ | 10x |
- #'+ group_levels <- levels(fct) |
| 66 | -+ | 10x |
- #' @examples+ if (is.null(ref)) {
|
| 67 | -+ | 6x |
- #' score_cols_a_and_b <- score_occurrences_cols(col_names = c("A: Drug X", "B: Placebo"))
+ ref <- group_levels[1] |
| 68 |
- #'+ } else {
|
||
| 69 | -+ | 4x |
- #' # Note that this here just sorts the AEDECOD inside the AEBODSYS. The AEBODSYS are not sorted.+ checkmate::assert_subset(ref, group_levels) |
| 70 |
- #' # That would require a second pass of `sort_at_path`.+ } |
||
| 71 |
- #' tbl_sorted <- tbl %>%+ |
||
| 72 | -+ | 10x |
- #' sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_cols_a_and_b)
+ groups <- list( |
| 73 | -+ | 10x |
- #'+ ref = group_levels[group_levels %in% ref], |
| 74 | -+ | 10x |
- #' tbl_sorted+ trt = group_levels[!group_levels %in% ref] |
| 75 |
- #'+ ) |
||
| 76 | -+ | 10x |
- #' @export+ stats::setNames(groups, nm = lapply(groups, paste, collapse = collapse)) |
| 77 |
- score_occurrences_cols <- function(...) {
+ } |
||
| 78 | -4x | +
- function(table_row) {
+
|
|
| 79 | -20x | +
- row_counts <- h_row_counts(table_row, ...)+ #' Split columns by groups of levels |
|
| 80 | -20x | +
- sum(row_counts)+ #' |
|
| 81 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 82 |
- }+ #' |
||
| 83 |
-
+ #' @inheritParams argument_convention |
||
| 84 |
- #' @describeIn score_occurrences Scoring functions produced by this constructor can be used on+ #' @inheritParams groups_list_to_df |
||
| 85 |
- #' subtables: They sum up all specified column counts in the subtable. This is useful when+ #' @param ... additional arguments to [rtables::split_cols_by()] in order. For instance, to |
||
| 86 |
- #' there is no available content row summing up these counts.+ #' control formats (`format`), add a joint column for all groups (`incl_all`). |
||
| 88 |
- #' @return+ #' @return A layout object suitable for passing to further layouting functions. Adding |
||
| 89 |
- #' * `score_occurrences_subtable()` returns a function that sums counts in each subtable+ #' this function to an `rtable` layout will add a column split including the given |
||
| 90 |
- #' across all specified columns.+ #' groups to the table layout. |
||
| 92 |
- #' @examples+ #' @seealso [rtables::split_cols_by()] |
||
| 93 |
- #' score_subtable_all <- score_occurrences_subtable(col_names = names(tbl))+ #' |
||
| 94 |
- #'+ #' @examples |
||
| 95 |
- #' # Note that this code just sorts the AEBODSYS, not the AEDECOD within AEBODSYS. That+ #' # 1 - Basic use |
||
| 96 |
- #' # would require a second pass of `sort_at_path`.+ #' |
||
| 97 |
- #' tbl_sorted <- tbl %>%+ #' # Without group combination `split_cols_by_groups` is |
||
| 98 |
- #' sort_at_path(path = c("AEBODSYS"), scorefun = score_subtable_all, decreasing = FALSE)
+ #' # equivalent to [rtables::split_cols_by()]. |
||
| 99 |
- #'+ #' basic_table() %>% |
||
| 100 |
- #' tbl_sorted+ #' split_cols_by_groups("ARM") %>%
|
||
| 101 |
- #'+ #' add_colcounts() %>% |
||
| 102 |
- #' @export+ #' analyze("AGE") %>%
|
||
| 103 |
- score_occurrences_subtable <- function(...) {
+ #' build_table(DM) |
||
| 104 | -1x | +
- score_table_row <- score_occurrences_cols(...)+ #' |
|
| 105 | -1x | +
- function(table_tree) {
+ #' # Add a reference column. |
|
| 106 | -2x | +
- table_rows <- collect_leaves(table_tree)+ #' basic_table() %>% |
|
| 107 | -2x | +
- counts <- vapply(table_rows, score_table_row, numeric(1))+ #' split_cols_by_groups("ARM", ref_group = "B: Placebo") %>%
|
|
| 108 | -2x | +
- sum(counts)+ #' add_colcounts() %>% |
|
| 109 |
- }+ #' analyze( |
||
| 110 |
- }+ #' "AGE", |
||
| 111 |
-
+ #' afun = function(x, .ref_group, .in_ref_col) {
|
||
| 112 |
- #' @describeIn score_occurrences Produces a score function for sorting table by summing the first content row in+ #' if (.in_ref_col) {
|
||
| 113 |
- #' specified columns. Note that this is extending [rtables::cont_n_onecol()] and [rtables::cont_n_allcols()].+ #' in_rows("Diff Mean" = rcell(NULL))
|
||
| 114 |
- #'+ #' } else {
|
||
| 115 |
- #' @return+ #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
|
||
| 116 |
- #' * `score_occurrences_cont_cols()` returns a function that sums counts in the first content row in+ #' } |
||
| 117 |
- #' specified columns.+ #' } |
||
| 118 |
- #'+ #' ) %>% |
||
| 119 |
- #' @export+ #' build_table(DM) |
||
| 120 |
- score_occurrences_cont_cols <- function(...) {
+ #' |
||
| 121 | -1x | +
- score_table_row <- score_occurrences_cols(...)+ #' # 2 - Adding group specification |
|
| 122 | -1x | +
- function(table_tree) {
+ #' |
|
| 123 | -2x | +
- if (inherits(table_tree, "ContentRow")) {
+ #' # Manual preparation of the groups. |
|
| 124 | -! | +
- return(NA)+ #' groups <- list( |
|
| 125 |
- }+ #' "Arms A+B" = c("A: Drug X", "B: Placebo"),
|
||
| 126 | -2x | +
- content_row <- h_content_first_row(table_tree)+ #' "Arms A+C" = c("A: Drug X", "C: Combination")
|
|
| 127 | -2x | +
- score_table_row(content_row)+ #' ) |
|
| 128 |
- }+ #' |
||
| 129 |
- }+ #' # Use of split_cols_by_groups without reference column. |
| 1 | +130 |
- #' Estimate proportions of each level of a variable+ #' basic_table() %>% |
||
| 2 | +131 | ++ |
+ #' split_cols_by_groups("ARM", groups) %>%
+ |
+ |
| 132 | ++ |
+ #' add_colcounts() %>%+ |
+ ||
| 133 | ++ |
+ #' analyze("AGE") %>%
+ |
+ ||
| 134 | ++ |
+ #' build_table(DM)+ |
+ ||
| 135 | ++ |
+ #'+ |
+ ||
| 136 | ++ |
+ #' # Including differentiated output in the reference column.+ |
+ ||
| 137 | ++ |
+ #' basic_table() %>%+ |
+ ||
| 138 | ++ |
+ #' split_cols_by_groups("ARM", groups_list = groups, ref_group = "Arms A+B") %>%
+ |
+ ||
| 139 | ++ |
+ #' analyze(+ |
+ ||
| 140 | ++ |
+ #' "AGE",+ |
+ ||
| 141 | ++ |
+ #' afun = function(x, .ref_group, .in_ref_col) {
+ |
+ ||
| 142 | ++ |
+ #' if (.in_ref_col) {
+ |
+ ||
| 143 | ++ |
+ #' in_rows("Diff. of Averages" = rcell(NULL))
+ |
+ ||
| 144 | ++ |
+ #' } else {
+ |
+ ||
| 145 | ++ |
+ #' in_rows("Diff. of Averages" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+ |
+ ||
| 146 | ++ |
+ #' }+ |
+ ||
| 147 | ++ |
+ #' }+ |
+ ||
| 148 | ++ |
+ #' ) %>%+ |
+ ||
| 149 | ++ |
+ #' build_table(DM)+ |
+ ||
| 150 | ++ |
+ #'+ |
+ ||
| 151 | ++ |
+ #' # 3 - Binary list dividing factor levels into reference and treatment+ |
+ ||
| 152 | ++ |
+ #'+ |
+ ||
| 153 | ++ |
+ #' # `combine_groups` defines reference and treatment.+ |
+ ||
| 154 | ++ |
+ #' groups <- combine_groups(+ |
+ ||
| 155 | ++ |
+ #' fct = DM$ARM,+ |
+ ||
| 156 | ++ |
+ #' ref = c("A: Drug X", "B: Placebo")
+ |
+ ||
| 157 | ++ |
+ #' )+ |
+ ||
| 158 | ++ |
+ #' groups+ |
+ ||
| 159 |
#' |
|||
| 3 | +160 | ++ |
+ #' # Use group definition without reference column.+ |
+ |
| 161 |
- #' @description `r lifecycle::badge("stable")`
+ #' basic_table() %>% |
|||
| 4 | +162 |
- #'+ #' split_cols_by_groups("ARM", groups_list = groups) %>%
|
||
| 5 | +163 |
- #' The analyze & summarize function [estimate_multinomial_response()] creates a layout element to estimate the+ #' add_colcounts() %>% |
||
| 6 | +164 |
- #' proportion and proportion confidence interval for each level of a factor variable. The primary analysis variable,+ #' analyze("AGE") %>%
|
||
| 7 | +165 |
- #' `var`, should be a factor variable, the values of which will be used as labels within the output table.+ #' build_table(DM) |
||
| 8 | +166 |
#' |
||
| 9 | +167 |
- #' @inheritParams argument_convention+ #' # Use group definition with reference column (first item of groups). |
||
| 10 | +168 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("estimate_multinomial_response")`
+ #' basic_table() %>% |
||
| 11 | +169 |
- #' to see available statistics for this function.+ #' split_cols_by_groups("ARM", groups, ref_group = names(groups)[1]) %>%
|
||
| 12 | +170 |
- #'+ #' add_colcounts() %>% |
||
| 13 | +171 |
- #' @seealso Relevant description function [d_onco_rsp_label()].+ #' analyze( |
||
| 14 | +172 |
- #'+ #' "AGE", |
||
| 15 | +173 |
- #' @name estimate_multinomial_rsp+ #' afun = function(x, .ref_group, .in_ref_col) {
|
||
| 16 | +174 |
- #' @order 1+ #' if (.in_ref_col) {
|
||
| 17 | +175 |
- NULL+ #' in_rows("Diff Mean" = rcell(NULL))
|
||
| 18 | +176 |
-
+ #' } else {
|
||
| 19 | +177 |
- #' Description of standard oncology response+ #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
|
||
| 20 | +178 |
- #'+ #' } |
||
| 21 | +179 |
- #' @description `r lifecycle::badge("stable")`
+ #' } |
||
| 22 | +180 |
- #'+ #' ) %>% |
||
| 23 | +181 |
- #' Describe the oncology response in a standard way.+ #' build_table(DM) |
||
| 24 | +182 |
#' |
||
| 25 | +183 |
- #' @param x (`character`)\cr the standard oncology codes to be described.+ #' @export |
||
| 26 | +184 |
- #'+ split_cols_by_groups <- function(lyt, |
||
| 27 | +185 |
- #' @return Response labels.+ var, |
||
| 28 | +186 |
- #'+ groups_list = NULL, |
||
| 29 | +187 |
- #' @seealso [estimate_multinomial_rsp()]+ ref_group = NULL, |
||
| 30 | +188 |
- #'+ ...) {
|
||
| 31 | -+ | |||
| 189 | +6x |
- #' @examples+ if (is.null(groups_list)) {
|
||
| 32 | -+ | |||
| 190 | +2x |
- #' d_onco_rsp_label(+ split_cols_by(+ |
+ ||
| 191 | +2x | +
+ lyt = lyt,+ |
+ ||
| 192 | +2x | +
+ var = var,+ |
+ ||
| 193 | +2x | +
+ ref_group = ref_group, |
||
| 33 | +194 |
- #' c("CR", "PR", "SD", "NON CR/PD", "PD", "NE", "Missing", "<Missing>", "NE/Missing")
+ ... |
||
| 34 | +195 |
- #' )+ ) |
||
| 35 | +196 |
- #'+ } else {
+ |
+ ||
| 197 | +4x | +
+ groups_df <- groups_list_to_df(groups_list)+ |
+ ||
| 198 | +4x | +
+ if (!is.null(ref_group)) {
+ |
+ ||
| 199 | +3x | +
+ ref_group <- groups_df$valname[groups_df$label == ref_group] |
||
| 36 | +200 |
- #' # Adding some values not considered in d_onco_rsp_label+ }+ |
+ ||
| 201 | +4x | +
+ split_cols_by(+ |
+ ||
| 202 | +4x | +
+ lyt = lyt,+ |
+ ||
| 203 | +4x | +
+ var = var,+ |
+ ||
| 204 | +4x | +
+ split_fun = add_combo_levels(groups_df, keep_levels = groups_df$valname),+ |
+ ||
| 205 | +4x | +
+ ref_group = ref_group, |
||
| 37 | +206 |
- #'+ ... |
||
| 38 | +207 |
- #' d_onco_rsp_label(+ ) |
||
| 39 | +208 |
- #' c("CR", "PR", "hello", "hi")
+ } |
||
| 40 | +209 |
- #' )+ } |
||
| 41 | +210 |
- #'+ |
||
| 42 | +211 |
- #' @export+ #' Combine counts |
||
| 43 | +212 |
- d_onco_rsp_label <- function(x) {
+ #' |
||
| 44 | -2x | +|||
| 213 | +
- x <- as.character(x)+ #' Simplifies the estimation of column counts, especially when group combination is required. |
|||
| 45 | -2x | +|||
| 214 | +
- desc <- c(+ #' |
|||
| 46 | -2x | +|||
| 215 | +
- CR = "Complete Response (CR)",+ #' @inheritParams combine_groups |
|||
| 47 | -2x | +|||
| 216 | +
- PR = "Partial Response (PR)",+ #' @inheritParams groups_list_to_df |
|||
| 48 | -2x | +|||
| 217 | +
- MR = "Minimal/Minor Response (MR)",+ #' |
|||
| 49 | -2x | +|||
| 218 | +
- MRD = "Minimal Residual Disease (MRD)",+ #' @return A `vector` of column counts. |
|||
| 50 | -2x | +|||
| 219 | +
- SD = "Stable Disease (SD)",+ #' |
|||
| 51 | -2x | +|||
| 220 | +
- PD = "Progressive Disease (PD)",+ #' @seealso [combine_groups()] |
|||
| 52 | -2x | +|||
| 221 | +
- `NON CR/PD` = "Non-CR or Non-PD (NON CR/PD)",+ #' |
|||
| 53 | -2x | +|||
| 222 | +
- NE = "Not Evaluable (NE)",+ #' @examples |
|||
| 54 | -2x | +|||
| 223 | +
- `NE/Missing` = "Missing or unevaluable",+ #' ref <- c("A: Drug X", "B: Placebo")
|
|||
| 55 | -2x | +|||
| 224 | +
- Missing = "Missing",+ #' groups <- combine_groups(fct = DM$ARM, ref = ref) |
|||
| 56 | -2x | +|||
| 225 | +
- `NA` = "Not Applicable (NA)",+ #' |
|||
| 57 | -2x | +|||
| 226 | +
- ND = "Not Done (ND)"+ #' col_counts <- combine_counts( |
|||
| 58 | +227 |
- )+ #' fct = DM$ARM, |
||
| 59 | +228 |
-
+ #' groups_list = groups |
||
| 60 | -2x | +|||
| 229 | +
- values_label <- vapply(+ #' ) |
|||
| 61 | -2x | +|||
| 230 | +
- X = x,+ #' |
|||
| 62 | -2x | +|||
| 231 | +
- FUN.VALUE = character(1),+ #' basic_table() %>% |
|||
| 63 | -2x | +|||
| 232 | +
- function(val) {
+ #' split_cols_by_groups("ARM", groups) %>%
|
|||
| 64 | -! | +|||
| 233 | +
- if (val %in% names(desc)) desc[val] else val+ #' add_colcounts() %>% |
|||
| 65 | +234 |
- }+ #' analyze_vars("AGE") %>%
|
||
| 66 | +235 |
- )+ #' build_table(DM, col_counts = col_counts) |
||
| 67 | +236 |
-
+ #' |
||
| 68 | -2x | +|||
| 237 | +
- return(factor(values_label, levels = c(intersect(desc, values_label), setdiff(values_label, desc))))+ #' ref <- "A: Drug X" |
|||
| 69 | +238 |
- }+ #' groups <- combine_groups(fct = DM$ARM, ref = ref) |
||
| 70 | +239 |
-
+ #' col_counts <- combine_counts( |
||
| 71 | +240 |
- #' @describeIn estimate_multinomial_rsp Statistics function which feeds the length of `x` as number+ #' fct = DM$ARM, |
||
| 72 | +241 |
- #' of successes, and `.N_col` as total number of successes and failures into [s_proportion()].+ #' groups_list = groups |
||
| 73 | +242 |
- #'+ #' ) |
||
| 74 | +243 |
- #' @return+ #' |
||
| 75 | +244 |
- #' * `s_length_proportion()` returns statistics from [s_proportion()].+ #' basic_table() %>% |
||
| 76 | +245 |
- #'+ #' split_cols_by_groups("ARM", groups) %>%
|
||
| 77 | +246 |
- #' @examples+ #' add_colcounts() %>% |
||
| 78 | +247 |
- #' s_length_proportion(rep("CR", 10), .N_col = 100)
+ #' analyze_vars("AGE") %>%
|
||
| 79 | +248 |
- #' s_length_proportion(factor(character(0)), .N_col = 100)+ #' build_table(DM, col_counts = col_counts) |
||
| 80 | +249 |
#' |
||
| 81 | +250 |
#' @export |
||
| 82 | +251 |
- s_length_proportion <- function(x,+ combine_counts <- function(fct, groups_list = NULL) {
+ |
+ ||
| 252 | +4x | +
+ checkmate::assert_multi_class(fct, classes = c("factor", "character"))
|
||
| 83 | +253 |
- .N_col, # nolint+ + |
+ ||
| 254 | +4x | +
+ fct <- as_factor_keep_attributes(fct) |
||
| 84 | +255 |
- ...) {
+
|
||
| 85 | +256 | 4x |
- checkmate::assert_multi_class(x, classes = c("factor", "character"))
+ if (is.null(groups_list)) {
|
|
| 86 | -3x | +257 | +1x |
- checkmate::assert_vector(x, min.len = 0, max.len = .N_col)+ y <- table(fct) |
| 87 | -2x | +258 | +1x |
- checkmate::assert_vector(unique(x), min.len = 0, max.len = 1)+ y <- stats::setNames(as.numeric(y), nm = dimnames(y)[[1]]) |
| 88 | +259 |
-
+ } else {
|
||
| 89 | -1x | +260 | +3x |
- n_true <- length(x)+ y <- vapply( |
| 90 | -1x | +261 | +3x |
- n_false <- .N_col - n_true+ X = groups_list, |
| 91 | -1x | +262 | +3x |
- x_logical <- rep(c(TRUE, FALSE), c(n_true, n_false))+ FUN = function(x) sum(table(fct)[x]), |
| 92 | -1x | +263 | +3x |
- s_proportion(df = x_logical, ...)+ FUN.VALUE = 1 |
| 93 | +264 |
- }+ ) |
||
| 94 | +265 |
-
+ } |
||
| 95 | -+ | |||
| 266 | +4x |
- #' @describeIn estimate_multinomial_rsp Formatted analysis function which is used as `afun`+ y |
||
| 96 | +267 |
- #' in `estimate_multinomial_response()`.+ } |
| 97 | +1 |
- #'+ #' Summarize variables in columns |
||
| 98 | +2 |
- #' @return+ #' |
||
| 99 | +3 |
- #' * `a_length_proportion()` returns the corresponding list with formatted [rtables::CellValue()].+ #' @description `r lifecycle::badge("stable")`
|
||
| 100 | +4 |
#' |
||
| 101 | +5 |
- #' @examples+ #' The analyze function [summarize_colvars()] uses the statistics function [s_summary()] to analyze variables that are |
||
| 102 | +6 |
- #' a_length_proportion(rep("CR", 10), .N_col = 100)
+ #' arranged in columns. The variables to analyze should be specified in the table layout via column splits (see |
||
| 103 | +7 |
- #' a_length_proportion(factor(character(0)), .N_col = 100)+ #' [rtables::split_cols_by()] and [rtables::split_cols_by_multivar()]) prior to using [summarize_colvars()]. |
||
| 104 | +8 |
#' |
||
| 105 | +9 |
- #' @export+ #' The function is a minimal wrapper for [rtables::analyze_colvars()], a function typically used to apply different |
||
| 106 | +10 |
- a_length_proportion <- make_afun(+ #' analysis methods in rows for each column variable. To use the analysis methods as column labels, please refer to |
||
| 107 | +11 |
- s_length_proportion,+ #' the [analyze_vars_in_cols()] function. |
||
| 108 | +12 |
- .formats = c(+ #' |
||
| 109 | +13 |
- n_prop = "xx (xx.x%)",+ #' @inheritParams argument_convention |
||
| 110 | +14 |
- prop_ci = "(xx.xx, xx.xx)"+ #' @param ... arguments passed to [s_summary()]. |
||
| 111 | +15 |
- )+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 112 | +16 |
- )+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
||
| 113 | +17 |
-
+ #' for that statistic's row label. |
||
| 114 | +18 |
- #' @describeIn estimate_multinomial_rsp Layout-creating function which can take statistics function arguments+ #' |
||
| 115 | +19 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()] and+ #' @return |
||
| 116 | +20 |
- #' [rtables::summarize_row_groups()].+ #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()]. |
||
| 117 | +21 |
- #'+ #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output |
||
| 118 | +22 |
- #' @return+ #' in columns, and add it to the table layout. |
||
| 119 | +23 |
- #' * `estimate_multinomial_response()` returns a layout object suitable for passing to further layouting functions,+ #' |
||
| 120 | +24 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' @seealso [rtables::split_cols_by_multivar()] and [`analyze_colvars_functions`]. |
||
| 121 | +25 |
- #' the statistics from `s_length_proportion()` to the table layout.+ #' |
||
| 122 | +26 |
- #'+ #' @examples |
||
| 123 | +27 |
- #' @examples+ #' dta_test <- data.frame( |
||
| 124 | +28 |
- #' library(dplyr)+ #' USUBJID = rep(1:6, each = 3), |
||
| 125 | +29 |
- #'+ #' PARAMCD = rep("lab", 6 * 3),
|
||
| 126 | +30 |
- #' # Use of the layout creating function.+ #' AVISIT = rep(paste0("V", 1:3), 6),
|
||
| 127 | +31 |
- #' dta_test <- data.frame(+ #' ARM = rep(LETTERS[1:3], rep(6, 3)), |
||
| 128 | +32 |
- #' USUBJID = paste0("S", 1:12),
+ #' AVAL = c(9:1, rep(NA, 9)), |
||
| 129 | +33 |
- #' ARM = factor(rep(LETTERS[1:3], each = 4)),+ #' CHG = c(1:9, rep(NA, 9)) |
||
| 130 | +34 |
- #' AVAL = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0))+ #' ) |
||
| 131 | +35 |
- #' ) %>% mutate(+ #' |
||
| 132 | +36 |
- #' AVALC = factor(AVAL,+ #' ## Default output within a `rtables` pipeline. |
||
| 133 | +37 |
- #' levels = c(0, 1),+ #' basic_table() %>% |
||
| 134 | +38 |
- #' labels = c("Complete Response (CR)", "Partial Response (PR)")
+ #' split_cols_by("ARM") %>%
|
||
| 135 | +39 |
- #' )+ #' split_rows_by("AVISIT") %>%
|
||
| 136 | +40 |
- #' )+ #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
|
||
| 137 | +41 |
- #'+ #' summarize_colvars() %>% |
||
| 138 | +42 |
- #' lyt <- basic_table() %>%+ #' build_table(dta_test) |
||
| 139 | +43 |
- #' split_cols_by("ARM") %>%
+ #' |
||
| 140 | +44 |
- #' estimate_multinomial_response(var = "AVALC")+ #' ## Selection of statistics, formats and labels also work. |
||
| 141 | +45 |
- #'+ #' basic_table() %>% |
||
| 142 | +46 |
- #' tbl <- build_table(lyt, dta_test)+ #' split_cols_by("ARM") %>%
|
||
| 143 | +47 |
- #'+ #' split_rows_by("AVISIT") %>%
|
||
| 144 | +48 |
- #' tbl+ #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
|
||
| 145 | +49 |
- #'+ #' summarize_colvars( |
||
| 146 | +50 |
- #' @export+ #' .stats = c("n", "mean_sd"),
|
||
| 147 | +51 |
- #' @order 2+ #' .formats = c("mean_sd" = "xx.x, xx.x"),
|
||
| 148 | +52 |
- estimate_multinomial_response <- function(lyt,+ #' .labels = c(n = "n", mean_sd = "Mean, SD") |
||
| 149 | +53 |
- var,+ #' ) %>% |
||
| 150 | +54 |
- na_str = default_na_str(),+ #' build_table(dta_test) |
||
| 151 | +55 |
- nested = TRUE,+ #' |
||
| 152 | +56 |
- ...,+ #' ## Use arguments interpreted by `s_summary`. |
||
| 153 | +57 |
- show_labels = "hidden",+ #' basic_table() %>% |
||
| 154 | +58 |
- table_names = var,+ #' split_cols_by("ARM") %>%
|
||
| 155 | +59 |
- .stats = "prop_ci",+ #' split_rows_by("AVISIT") %>%
|
||
| 156 | +60 |
- .formats = NULL,+ #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
|
||
| 157 | +61 |
- .labels = NULL,+ #' summarize_colvars(na.rm = FALSE) %>% |
||
| 158 | +62 |
- .indent_mods = NULL) {
+ #' build_table(dta_test) |
||
| 159 | -1x | +|||
| 63 | +
- extra_args <- list(...)+ #' |
|||
| 160 | +64 |
-
+ #' @export |
||
| 161 | -1x | +|||
| 65 | +
- afun <- make_afun(+ summarize_colvars <- function(lyt, |
|||
| 162 | -1x | +|||
| 66 | +
- a_length_proportion,+ ..., |
|||
| 163 | -1x | +|||
| 67 | +
- .stats = .stats,+ na_str = default_na_str(), |
|||
| 164 | -1x | +|||
| 68 | +
- .formats = .formats,+ .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
|
|||
| 165 | -1x | +|||
| 69 | +
- .labels = .labels,+ .formats = NULL, |
|||
| 166 | -1x | +|||
| 70 | +
- .indent_mods = .indent_mods+ .labels = NULL, |
|||
| 167 | +71 |
- )+ .indent_mods = NULL) {
|
||
| 168 | -1x | +72 | +3x |
- lyt <- split_rows_by(lyt, var = var)+ extra_args <- list(.stats = .stats, na_str = na_str, ...) |
| 169 | +73 | 1x |
- lyt <- summarize_row_groups(lyt, na_str = na_str)- |
- |
| 170 | -- |
-
+ if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
||
| 171 | +74 | 1x |
- analyze(+ if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
|
| 172 | +75 | 1x |
- lyt,+ if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
|
| 173 | -1x | +|||
| 76 | +
- vars = var,+ |
|||
| 174 | -1x | +77 | +3x |
- afun = afun,+ analyze_colvars( |
| 175 | -1x | +78 | +3x |
- show_labels = show_labels,+ lyt, |
| 176 | -1x | +79 | +3x |
- table_names = table_names,+ afun = a_summary, |
| 177 | -1x | +80 | +3x |
na_str = na_str, |
| 178 | -1x | -
- nested = nested,- |
- ||
| 179 | -1x | +81 | +3x |
extra_args = extra_args |
| 180 | +82 |
) |
||
| 181 | +83 |
}@@ -167189,14 +165931,14 @@ tern coverage - 95.64% |
| 1 |
- #' Custom split functions+ #' Tabulate biomarker effects on survival by subgroup |
||
| 5 |
- #' Collection of useful functions that are expanding on the core list of functions+ #' The [tabulate_survival_biomarkers()] function creates a layout element to tabulate the estimated effects of multiple |
||
| 6 |
- #' provided by `rtables`. See [rtables::custom_split_funs] and [rtables::make_split_fun()]+ #' continuous biomarker variables on survival across subgroups, returning statistics including median survival time and |
||
| 7 |
- #' for more information on how to make a custom split function. All these functions+ #' hazard ratio for each population subgroup. The table is created from `df`, a list of data frames returned by |
||
| 8 |
- #' work with [rtables::split_rows_by()] argument `split_fun` to modify the way the split+ #' [extract_survival_biomarkers()], with the statistics to include specified via the `vars` parameter. |
||
| 9 |
- #' happens. For other split functions, consider consulting [`rtables::split_funcs`].+ #' |
||
| 10 |
- #'+ #' A forest plot can be created from the resulting table using the [g_forest()] function. |
||
| 11 |
- #' @seealso [rtables::make_split_fun()]+ #' |
||
| 12 |
- #'+ #' @inheritParams fit_coxreg_multivar |
||
| 13 |
- #' @name utils_split_funs+ #' @inheritParams survival_duration_subgroups |
||
| 14 |
- NULL+ #' @inheritParams argument_convention |
||
| 15 |
-
+ #' @param df (`data.frame`)\cr containing all analysis variables, as returned by |
||
| 16 |
- #' @describeIn utils_split_funs Split function to place reference group facet at a specific position+ #' [extract_survival_biomarkers()]. |
||
| 17 |
- #' during post-processing stage.+ #' @param vars (`character`)\cr the names of statistics to be reported among: |
||
| 18 |
- #'+ #' * `n_tot_events`: Total number of events per group. |
||
| 19 |
- #' @param position (`string` or `integer`)\cr position to use for the reference group facet. Can be `"first"`,+ #' * `n_tot`: Total number of observations per group. |
||
| 20 |
- #' `"last"`, or a specific position.+ #' * `median`: Median survival time. |
||
| 21 |
- #'+ #' * `hr`: Hazard ratio. |
||
| 22 |
- #' @return+ #' * `ci`: Confidence interval of hazard ratio. |
||
| 23 |
- #' * `ref_group_position()` returns an utility function that puts the reference group+ #' * `pval`: p-value of the effect. |
||
| 24 |
- #' as first, last or at a certain position and needs to be assigned to `split_fun`.+ #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` are required. |
||
| 26 |
- #' @examples+ #' @details These functions create a layout starting from a data frame which contains |
||
| 27 |
- #' library(dplyr)+ #' the required statistics. The tables are then typically used as input for forest plots. |
||
| 29 |
- #' dat <- data.frame(+ #' @examples |
||
| 30 |
- #' x = factor(letters[1:5], levels = letters[5:1]),+ #' library(dplyr) |
||
| 31 |
- #' y = 1:5+ #' |
||
| 32 |
- #' )+ #' adtte <- tern_ex_adtte |
||
| 34 |
- #' # With rtables layout functions+ #' # Save variable labels before data processing steps. |
||
| 35 |
- #' basic_table() %>%+ #' adtte_labels <- formatters::var_labels(adtte) |
||
| 36 |
- #' split_cols_by("x", ref_group = "c", split_fun = ref_group_position("last")) %>%
+ #' |
||
| 37 |
- #' analyze("y") %>%
+ #' adtte_f <- adtte %>% |
||
| 38 |
- #' build_table(dat)+ #' filter(PARAMCD == "OS") %>% |
||
| 39 |
- #'+ #' mutate( |
||
| 40 |
- #' # With tern layout funcitons+ #' AVALU = as.character(AVALU), |
||
| 41 |
- #' adtte_f <- tern_ex_adtte %>%+ #' is_event = CNSR == 0 |
||
| 42 |
- #' filter(PARAMCD == "OS") %>%+ #' ) |
||
| 43 |
- #' mutate(+ #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
|
||
| 44 |
- #' AVAL = day2month(AVAL),+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
||
| 45 |
- #' is_event = CNSR == 0+ #' |
||
| 46 |
- #' )+ #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`, |
||
| 47 |
- #'+ #' # in multiple regression models containing one covariate `RACE`, |
||
| 48 |
- #' basic_table() %>%+ #' # as well as one stratification variable `STRATA1`. The subgroups |
||
| 49 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM B", split_fun = ref_group_position("first")) %>%
+ #' # are defined by the levels of `BMRKR2`. |
||
| 50 |
- #' add_colcounts() %>%+ #' |
||
| 51 |
- #' surv_time(+ #' df <- extract_survival_biomarkers( |
||
| 52 |
- #' vars = "AVAL",+ #' variables = list( |
||
| 53 |
- #' var_labels = "Survival Time (Months)",+ #' tte = "AVAL", |
||
| 55 |
- #' ) %>%+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 56 |
- #' build_table(df = adtte_f)+ #' strata = "STRATA1", |
||
| 57 |
- #'+ #' covariates = "SEX", |
||
| 58 |
- #' basic_table() %>%+ #' subgroups = "BMRKR2" |
||
| 59 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM B", split_fun = ref_group_position(2)) %>%+ #' ), |
||
| 60 |
- #' add_colcounts() %>%+ #' label_all = "Total Patients", |
||
| 61 |
- #' surv_time(+ #' data = adtte_f |
||
| 62 |
- #' vars = "AVAL",+ #' ) |
||
| 63 |
- #' var_labels = "Survival Time (Months)",+ #' df |
||
| 64 |
- #' is_event = "is_event",+ #' |
||
| 65 |
- #' ) %>%+ #' # Here we group the levels of `BMRKR2` manually. |
||
| 66 |
- #' build_table(df = adtte_f)+ #' df_grouped <- extract_survival_biomarkers( |
||
| 67 |
- #'+ #' variables = list( |
||
| 68 |
- #' @export+ #' tte = "AVAL", |
||
| 69 |
- ref_group_position <- function(position = "first") {
+ #' is_event = "is_event", |
||
| 70 | -20x | +
- make_split_fun(+ #' biomarkers = c("BMRKR1", "AGE"),
|
|
| 71 | -20x | +
- post = list(+ #' strata = "STRATA1", |
|
| 72 | -20x | +
- function(splret, spl, fulldf) {
+ #' covariates = "SEX", |
|
| 73 | -57x | +
- if (!"ref_group_value" %in% methods::slotNames(spl)) {
+ #' subgroups = "BMRKR2" |
|
| 74 | -1x | +
- stop("Reference group is undefined.")
+ #' ), |
|
| 75 |
- }+ #' data = adtte_f, |
||
| 76 |
-
+ #' groups_lists = list( |
||
| 77 | -56x | +
- spl_var <- rtables:::spl_payload(spl)+ #' BMRKR2 = list( |
|
| 78 | -56x | +
- fulldf[[spl_var]] <- factor(fulldf[[spl_var]])+ #' "low" = "LOW", |
|
| 79 | -56x | +
- init_lvls <- levels(fulldf[[spl_var]])+ #' "low/medium" = c("LOW", "MEDIUM"),
|
|
| 80 |
-
+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 81 | -56x | +
- if (!all(names(splret$values) %in% init_lvls)) {
+ #' ) |
|
| 82 | -! | +
- stop("This split function does not work with combination facets.")
+ #' ) |
|
| 83 |
- }+ #' ) |
||
| 84 |
-
+ #' df_grouped |
||
| 85 | -56x | +
- ref_group_pos <- which(init_lvls == rtables:::spl_ref_group(spl))+ #' |
|
| 86 | -56x | +
- pos_choices <- c("first", "last")
+ #' @name survival_biomarkers_subgroups |
|
| 87 | -56x | +
- if (checkmate::test_choice(position, pos_choices) && position == "first") {
+ #' @order 1 |
|
| 88 | -41x | +
- pos <- 0+ NULL |
|
| 89 | -15x | +
- } else if (checkmate::test_choice(position, pos_choices) && position == "last") {
+
|
|
| 90 | -12x | +
- pos <- length(init_lvls)+ #' Prepare survival data estimates for multiple biomarkers in a single data frame |
|
| 91 | -3x | +
- } else if (checkmate::test_int(position, lower = 1, upper = length(init_lvls))) {
+ #' |
|
| 92 | -3x | +
- pos <- position - 1+ #' @description `r lifecycle::badge("stable")`
|
|
| 93 |
- } else {
+ #' |
||
| 94 | -! | +
- stop("Wrong input for ref group position. It must be 'first', 'last', or a integer.")
+ #' Prepares estimates for number of events, patients and median survival times, as well as hazard ratio estimates, |
|
| 95 |
- }+ #' confidence intervals and p-values, for multiple biomarkers across population subgroups in a single data frame. |
||
| 96 |
-
+ #' `variables` corresponds to the names of variables found in `data`, passed as a named `list` and requires elements |
||
| 97 | -56x | +
- reord_lvls <- append(init_lvls[-ref_group_pos], init_lvls[ref_group_pos], after = pos)+ #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables), and optionally `subgroups` and `strata`. |
|
| 98 | -56x | +
- ord <- match(reord_lvls, names(splret$values))+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
|
| 99 |
-
+ #' |
||
| 100 | -56x | +
- make_split_result(+ #' @inheritParams argument_convention |
|
| 101 | -56x | +
- splret$values[ord],+ #' @inheritParams fit_coxreg_multivar |
|
| 102 | -56x | +
- splret$datasplit[ord],+ #' @inheritParams survival_duration_subgroups |
|
| 103 | -56x | +
- splret$labels[ord]+ #' |
|
| 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 |
- )+ #' `var_label`, and `row_type`. |
||
| 107 |
- )+ #' |
||
| 108 |
- }+ #' @seealso [h_coxreg_mult_cont_df()] which is used internally, [tabulate_survival_biomarkers()]. |
||
| 109 |
-
+ #' |
||
| 110 |
- #' @describeIn utils_split_funs Split function to change level order based on an `integer`+ #' @export |
||
| 111 |
- #' vector or a `character` vector that represent the split variable's factor levels.+ extract_survival_biomarkers <- function(variables, |
||
| 112 |
- #'+ data, |
||
| 113 |
- #' @param order (`character` or `numeric`)\cr vector of ordering indices for the split facets.+ groups_lists = list(), |
||
| 114 |
- #'+ control = control_coxreg(), |
||
| 115 |
- #' @return+ label_all = "All Patients") {
|
||
| 116 | -+ | 6x |
- #' * `level_order()` returns an utility function that changes the original levels' order,+ if ("strat" %in% names(variables)) {
|
| 117 | -+ | ! |
- #' depending on input `order` and split levels.+ warning( |
| 118 | -+ | ! |
- #'+ "Warning: the `strat` element name of the `variables` list argument to `extract_survival_biomarkers() ", |
| 119 | -+ | ! |
- #' @examples+ "was deprecated in tern 0.9.4.\n ", |
| 120 | -+ | ! |
- #' # level_order --------+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
| 121 |
- #' # Even if default would bring ref_group first, the original order puts it last+ ) |
||
| 122 | -+ | ! |
- #' basic_table() %>%+ variables[["strata"]] <- variables[["strat"]] |
| 123 |
- #' split_cols_by("Species", split_fun = level_order(c(1, 3, 2))) %>%
+ } |
||
| 124 |
- #' analyze("Sepal.Length") %>%
+
|
||
| 125 | -+ | 6x |
- #' build_table(iris)+ checkmate::assert_list(variables) |
| 126 | -+ | 6x |
- #'+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 127 | -+ | 6x |
- #' # character vector+ checkmate::assert_string(label_all) |
| 128 |
- #' new_order <- level_order(levels(iris$Species)[c(1, 3, 2)])+ |
||
| 129 |
- #' basic_table() %>%+ # Start with all patients. |
||
| 130 | -+ | 6x |
- #' split_cols_by("Species", ref_group = "virginica", split_fun = new_order) %>%
+ result_all <- h_coxreg_mult_cont_df( |
| 131 | -+ | 6x |
- #' analyze("Sepal.Length") %>%
+ variables = variables, |
| 132 | -+ | 6x |
- #' build_table(iris)+ data = data, |
| 133 | -+ | 6x |
- #'+ control = control |
| 134 |
- #' @export+ ) |
||
| 135 | -+ | 6x |
- level_order <- function(order) {
+ result_all$subgroup <- label_all |
| 136 | -2x | +6x |
- make_split_fun(+ result_all$var <- "ALL" |
| 137 | -2x | +6x |
- post = list(+ result_all$var_label <- label_all |
| 138 | -2x | +6x |
- function(splret, spl, fulldf) {
+ result_all$row_type <- "content" |
| 139 | -4x | +6x |
- if (checkmate::test_integerish(order)) {
+ if (is.null(variables$subgroups)) {
|
| 140 | -1x | +
- checkmate::assert_integerish(order, lower = 1, upper = length(splret$values))+ # Only return result for all patients. |
|
| 141 | 1x |
- ord <- order+ result_all |
|
| 142 |
- } else {
+ } else {
|
||
| 143 | -3x | +
- checkmate::assert_character(order, len = length(splret$values))+ # Add subgroups results. |
|
| 144 | -3x | +5x |
- checkmate::assert_set_equal(order, names(splret$values), ordered = FALSE)+ l_data <- h_split_by_subgroups( |
| 145 | -3x | +5x |
- ord <- match(order, names(splret$values))+ data, |
| 146 | -+ | 5x |
- }+ variables$subgroups, |
| 147 | -4x | +5x |
- make_split_result(+ groups_lists = groups_lists |
| 148 | -4x | +
- splret$values[ord],+ ) |
|
| 149 | -4x | +5x |
- splret$datasplit[ord],+ l_result <- lapply(l_data, function(grp) {
|
| 150 | -4x | +25x |
- splret$labels[ord]+ result <- h_coxreg_mult_cont_df( |
| 151 | -+ | 25x |
- )+ variables = variables, |
| 152 | -+ | 25x |
- }+ data = grp$df, |
| 153 | -+ | 25x |
- )+ control = control |
| 154 |
- )+ ) |
||
| 155 | -+ | 25x |
- }+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
| 1 | -+ | |||
| 156 | +25x |
- #' Count patient events in columns+ cbind(result, result_labels) |
||
| 2 | +157 |
- #'+ }) |
||
| 3 | -+ | |||
| 158 | +5x |
- #' @description `r lifecycle::badge("stable")`
+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
||
| 4 | -+ | |||
| 159 | +5x |
- #'+ result_subgroups$row_type <- "analysis" |
||
| 5 | -+ | |||
| 160 | +5x |
- #' The summarize function [summarize_patients_events_in_cols()] creates a layout element to summarize patient+ rbind( |
||
| 6 | -+ | |||
| 161 | +5x |
- #' event counts in columns.+ result_all, |
||
| 7 | -+ | |||
| 162 | +5x |
- #'+ result_subgroups |
||
| 8 | +163 |
- #' This function analyzes the elements (events) supplied via the `filters_list` parameter and returns a row+ ) |
||
| 9 | +164 |
- #' with counts of number of patients for each event as well as the total numbers of patients and events.+ } |
||
| 10 | +165 |
- #' The `id` variable is used to indicate unique subject identifiers (defaults to `USUBJID`).+ } |
||
| 11 | +166 |
- #'+ |
||
| 12 | +167 |
- #' If there are multiple occurrences of the same event recorded for a patient, the event is only counted once.+ #' @describeIn survival_biomarkers_subgroups Table-creating function which creates a table |
||
| 13 | +168 |
- #'+ #' summarizing biomarker effects on survival by subgroup. |
||
| 14 | +169 |
- #' @inheritParams argument_convention+ #' |
||
| 15 | +170 |
- #' @param filters_list (named `list` of `character`)\cr list where each element in this list describes one+ #' @param label_all `r lifecycle::badge("deprecated")`\cr please assign the `label_all` parameter within the
|
||
| 16 | +171 |
- #' type of event describe by filters, in the same format as [s_count_patients_with_event()].+ #' [extract_survival_biomarkers()] function when creating `df`. |
||
| 17 | +172 |
- #' If it has a label, then this will be used for the column title.+ #' |
||
| 18 | +173 |
- #' @param empty_stats (`character`)\cr optional names of the statistics that should be returned empty such+ #' @return An `rtables` table summarizing biomarker effects on survival by subgroup. |
||
| 19 | +174 |
- #' that corresponding table cells will stay blank.+ #' |
||
| 20 | +175 |
- #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will+ #' @note In contrast to [tabulate_survival_subgroups()] this tabulation function does |
||
| 21 | +176 |
- #' be used as label.+ #' not start from an input layout `lyt`. This is because internally the table is |
||
| 22 | +177 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run+ #' created by combining multiple subtables. |
||
| 23 | +178 |
- #' `get_stats("summarize_patients_events_in_cols")` to see available statistics for this function, in addition
+ #' |
||
| 24 | +179 |
- #' to any added using `filters_list`.+ #' @seealso [h_tab_surv_one_biomarker()] which is used internally, [extract_survival_biomarkers()]. |
||
| 25 | +180 |
#' |
||
| 26 | +181 |
- #' @name count_patients_events_in_cols+ #' @examples |
||
| 27 | +182 |
- #' @order 1+ #' ## Table with default columns. |
||
| 28 | +183 |
- NULL+ #' tabulate_survival_biomarkers(df) |
||
| 29 | +184 |
-
+ #' |
||
| 30 | +185 |
- #' @describeIn count_patients_events_in_cols Statistics function which counts numbers of patients and multiple+ #' ## Table with a manually chosen set of columns: leave out "pval", reorder. |
||
| 31 | +186 |
- #' events defined by filters. Used as analysis function `afun` in `summarize_patients_events_in_cols()`.+ #' tab <- tabulate_survival_biomarkers( |
||
| 32 | +187 |
- #'+ #' df = df, |
||
| 33 | +188 |
- #' @return+ #' vars = c("n_tot_events", "ci", "n_tot", "median", "hr"),
|
||
| 34 | +189 |
- #' * `s_count_patients_and_multiple_events()` returns a list with the statistics:+ #' time_unit = as.character(adtte_f$AVALU[1]) |
||
| 35 | +190 |
- #' - `unique`: number of unique patients in `df`.+ #' ) |
||
| 36 | +191 |
- #' - `all`: number of rows in `df`.+ #' |
||
| 37 | +192 |
- #' - one element with the same name as in `filters_list`: number of rows in `df`,+ #' ## Finally produce the forest plot. |
||
| 38 | +193 |
- #' i.e. events, fulfilling the filter condition.+ #' \donttest{
|
||
| 39 | +194 |
- #'+ #' g_forest(tab, xlim = c(0.8, 1.2)) |
||
| 40 | +195 |
- #' @keywords internal+ #' } |
||
| 41 | +196 |
- s_count_patients_and_multiple_events <- function(df, # nolint+ #' |
||
| 42 | +197 |
- id,+ #' @export |
||
| 43 | +198 |
- filters_list,+ #' @order 2 |
||
| 44 | +199 |
- empty_stats = character(),+ tabulate_survival_biomarkers <- function(df, |
||
| 45 | +200 |
- labelstr = "",+ vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
|
||
| 46 | +201 |
- custom_label = NULL) {
- |
- ||
| 47 | -9x | -
- checkmate::assert_list(filters_list, names = "named")- |
- ||
| 48 | -9x | -
- checkmate::assert_data_frame(df)- |
- ||
| 49 | -9x | -
- checkmate::assert_string(id)- |
- ||
| 50 | -9x | -
- checkmate::assert_disjunct(c("unique", "all"), names(filters_list))
- |
- ||
| 51 | -9x | -
- checkmate::assert_character(empty_stats)- |
- ||
| 52 | -9x | -
- checkmate::assert_string(labelstr)- |
- ||
| 53 | -9x | -
- checkmate::assert_string(custom_label, null.ok = TRUE)+ groups_lists = list(), |
||
| 54 | +202 |
-
+ control = control_coxreg(), |
||
| 55 | +203 |
- # Below we want to count each row in `df` once, therefore introducing this helper index column.- |
- ||
| 56 | -9x | -
- df$.row_index <- as.character(seq_len(nrow(df)))- |
- ||
| 57 | -9x | -
- y <- list()- |
- ||
| 58 | -9x | -
- row_label <- if (labelstr != "") {
- |
- ||
| 59 | -! | -
- labelstr- |
- ||
| 60 | -9x | -
- } else if (!is.null(custom_label)) {
- |
- ||
| 61 | -2x | -
- custom_label+ label_all = lifecycle::deprecated(), |
||
| 62 | +204 |
- } else {
- |
- ||
| 63 | -7x | -
- "counts"+ time_unit = NULL, |
||
| 64 | +205 |
- }- |
- ||
| 65 | -9x | -
- y$unique <- formatters::with_label(- |
- ||
| 66 | -9x | -
- s_num_patients_content(df = df, .N_col = 1, .var = id, required = NULL)$unique[1L],- |
- ||
| 67 | -9x | -
- row_label+ na_str = default_na_str(), |
||
| 68 | +206 |
- )- |
- ||
| 69 | -9x | -
- y$all <- formatters::with_label(- |
- ||
| 70 | -9x | -
- nrow(df),+ .indent_mods = 0L) {
|
||
| 71 | -9x | -
- row_label- |
- ||
| 72 | -+ | 207 | +5x |
- )+ if (lifecycle::is_present(label_all)) {
|
| 73 | -9x | +208 | +1x |
- events <- Map(+ lifecycle::deprecate_warn( |
| 74 | -9x | +209 | +1x |
- function(filters) {
+ "0.9.5", "tabulate_survival_biomarkers(label_all)", |
| 75 | -25x | +210 | +1x |
- formatters::with_label(+ details = paste( |
| 76 | -25x | +211 | +1x |
- s_count_patients_with_event(df = df, .var = ".row_index", filters = filters, .N_col = 1, .N_row = 1)$count,+ "Please assign the `label_all` parameter within the", |
| 77 | -25x | +212 | +1x |
- row_label+ "`extract_survival_biomarkers()` function when creating `df`." |
| 78 | +213 |
) |
||
| 79 | +214 |
- },- |
- ||
| 80 | -9x | -
- filters = filters_list+ ) |
||
| 81 | +215 |
- )+ } |
||
| 82 | -9x | +|||
| 216 | +
- y_complete <- c(y, events)+ |
|||
| 83 | -9x | +217 | +5x |
- y <- if (length(empty_stats) > 0) {
+ checkmate::assert_data_frame(df) |
| 84 | -3x | +218 | +5x |
- y_reduced <- y_complete+ checkmate::assert_character(df$biomarker) |
| 85 | -3x | +219 | +5x |
- for (stat in intersect(names(y_complete), empty_stats)) {
+ checkmate::assert_character(df$biomarker_label) |
| 86 | -4x | +220 | +5x |
- y_reduced[[stat]] <- formatters::with_label(character(), obj_label(y_reduced[[stat]]))+ checkmate::assert_subset(vars, get_stats("tabulate_survival_biomarkers"))
|
| 87 | +221 |
- }+ |
||
| 88 | -3x | +222 | +5x |
- y_reduced+ extra_args <- list(groups_lists = groups_lists, control = control) |
| 89 | +223 |
- } else {
+
|
||
| 90 | -6x | +224 | +5x |
- y_complete+ df_subs <- split(df, f = df$biomarker) |
| 91 | -+ | |||
| 225 | +5x |
- }+ tabs <- lapply(df_subs, FUN = function(df_sub) {
|
||
| 92 | +226 | 9x |
- y- |
- |
| 93 | -- |
- }- |
- ||
| 94 | -- | - - | -||
| 95 | -- |
- #' @describeIn count_patients_events_in_cols Layout-creating function which can take statistics function- |
- ||
| 96 | -- |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].- |
- ||
| 97 | -- |
- #'- |
- ||
| 98 | -- |
- #' @param col_split (`flag`)\cr whether the columns should be split.- |
- ||
| 99 | -- |
- #' Set to `FALSE` when the required column split has been done already earlier in the layout pipe.- |
- ||
| 100 | -- |
- #'- |
- ||
| 101 | -- |
- #' @return+ tab_sub <- h_tab_surv_one_biomarker( |
||
| 102 | -+ | |||
| 227 | +9x |
- #' * `summarize_patients_events_in_cols()` returns a layout object suitable for passing to further layouting functions,+ df = df_sub, |
||
| 103 | -+ | |||
| 228 | +9x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows+ vars = vars, |
||
| 104 | -+ | |||
| 229 | +9x |
- #' containing the statistics from `s_count_patients_and_multiple_events()` to the table layout.+ time_unit = time_unit, |
||
| 105 | -+ | |||
| 230 | +9x |
- #'+ na_str = na_str, |
||
| 106 | -+ | |||
| 231 | +9x |
- #' @examples+ .indent_mods = .indent_mods, |
||
| 107 | -+ | |||
| 232 | +9x |
- #' df <- data.frame(+ extra_args = extra_args |
||
| 108 | +233 |
- #' USUBJID = rep(c("id1", "id2", "id3", "id4"), c(2, 3, 1, 1)),
+ ) |
||
| 109 | +234 |
- #' ARM = c("A", "A", "B", "B", "B", "B", "A"),
+ # Insert label row as first row in table. |
||
| 110 | -+ | |||
| 235 | +9x |
- #' AESER = rep("Y", 7),
+ label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1] |
||
| 111 | -+ | |||
| 236 | +9x |
- #' AESDTH = c("Y", "Y", "N", "Y", "Y", "N", "N"),
+ tab_sub |
||
| 112 | +237 |
- #' AEREL = c("Y", "Y", "N", "Y", "Y", "N", "Y"),
+ }) |
||
| 113 | -+ | |||
| 238 | +5x |
- #' AEDECOD = c("A", "A", "A", "B", "B", "C", "D"),
+ result <- do.call(rbind, tabs) |
||
| 114 | +239 |
- #' AEBODSYS = rep(c("SOC1", "SOC2", "SOC3"), c(3, 3, 1))
+
|
||
| 115 | -+ | |||
| 240 | +5x |
- #' )+ n_tot_ids <- grep("^n_tot", vars)
|
||
| 116 | -+ | |||
| 241 | +5x |
- #'+ hr_id <- match("hr", vars)
|
||
| 117 | -+ | |||
| 242 | +5x |
- #' # `summarize_patients_events_in_cols()`+ ci_id <- match("ci", vars)
|
||
| 118 | -+ | |||
| 243 | +5x |
- #' basic_table() %>%+ structure( |
||
| 119 | -+ | |||
| 244 | +5x |
- #' summarize_patients_events_in_cols(+ result, |
||
| 120 | -+ | |||
| 245 | +5x |
- #' filters_list = list(+ forest_header = paste0(c("Higher", "Lower"), "\nBetter"),
|
||
| 121 | -+ | |||
| 246 | +5x |
- #' related = formatters::with_label(c(AEREL = "Y"), "Events (Related)"),+ col_x = hr_id, |
||
| 122 | -+ | |||
| 247 | +5x |
- #' fatal = c(AESDTH = "Y"),+ col_ci = ci_id, |
||
| 123 | -+ | |||
| 248 | +5x |
- #' fatal_related = c(AEREL = "Y", AESDTH = "Y")+ col_symbol_size = n_tot_ids[1] |
||
| 124 | +249 |
- #' ),+ ) |
||
| 125 | +250 |
- #' custom_label = "%s Total number of patients and events"+ } |
| 126 | +1 |
- #' ) %>%+ #' Missing data |
||
| 127 | +2 |
- #' build_table(df)+ #' |
||
| 128 | +3 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 129 | +4 |
- #' @export+ #' |
||
| 130 | +5 |
- #' @order 2+ #' Substitute missing data with a string or factor level. |
||
| 131 | +6 |
- summarize_patients_events_in_cols <- function(lyt, # nolint+ #' |
||
| 132 | +7 |
- id = "USUBJID",+ #' @param x (`factor` or `character`)\cr values for which any missing values should be substituted. |
||
| 133 | +8 |
- filters_list = list(),+ #' @param label (`string`)\cr string that missing data should be replaced with. |
||
| 134 | +9 |
- empty_stats = character(),+ #' |
||
| 135 | +10 |
- na_str = default_na_str(),+ #' @return `x` with any `NA` values substituted by `label`. |
||
| 136 | +11 |
- ...,+ #' |
||
| 137 | +12 |
- .stats = c(+ #' @examples |
||
| 138 | +13 |
- "unique",+ #' explicit_na(c(NA, "a", "b")) |
||
| 139 | +14 |
- "all",+ #' is.na(explicit_na(c(NA, "a", "b"))) |
||
| 140 | +15 |
- names(filters_list)+ #' |
||
| 141 | +16 |
- ),+ #' explicit_na(factor(c(NA, "a", "b"))) |
||
| 142 | +17 |
- .labels = c(+ #' is.na(explicit_na(factor(c(NA, "a", "b")))) |
||
| 143 | +18 |
- unique = "Patients (All)",+ #' |
||
| 144 | +19 |
- all = "Events (All)",+ #' explicit_na(sas_na(c("a", "")))
|
||
| 145 | +20 |
- labels_or_names(filters_list)+ #' |
||
| 146 | +21 |
- ),+ #' @export |
||
| 147 | +22 |
- col_split = TRUE) {
+ explicit_na <- function(x, label = "<Missing>") {
|
||
| 148 | -2x | +23 | +254x |
- extra_args <- list(id = id, filters_list = filters_list, empty_stats = empty_stats, ...)+ checkmate::assert_string(label) |
| 149 | +24 | |||
| 150 | -2x | +25 | +254x |
- afun_list <- Map(+ if (is.factor(x)) {
|
| 151 | -2x | +26 | +151x |
- function(stat) {
+ x <- forcats::fct_na_value_to_level(x, label) |
| 152 | -7x | +27 | +151x |
- make_afun(+ forcats::fct_drop(x, only = label) |
| 153 | -7x | +28 | +103x |
- s_count_patients_and_multiple_events,+ } else if (is.character(x)) {
|
| 154 | -7x | +29 | +103x |
- .stats = stat,+ x[is.na(x)] <- label |
| 155 | -7x | -
- .formats = "xx."- |
- ||
| 156 | -+ | 30 | +103x |
- )+ x |
| 157 | +31 |
- },+ } else {
|
||
| 158 | -2x | +|||
| 32 | +! |
- stat = .stats+ stop("only factors and character vectors allowed")
|
||
| 159 | +33 |
- )- |
- ||
| 160 | -2x | -
- if (col_split) {
- |
- ||
| 161 | -2x | -
- lyt <- split_cols_by_multivar(- |
- ||
| 162 | -2x | -
- lyt = lyt,- |
- ||
| 163 | -2x | -
- vars = rep(id, length(.stats)),- |
- ||
| 164 | -2x | -
- varlabels = .labels[.stats]+ } |
||
| 165 | +34 |
- )+ } |
||
| 166 | +35 |
- }- |
- ||
| 167 | -2x | -
- summarize_row_groups(- |
- ||
| 168 | -2x | -
- lyt = lyt,+ |
||
| 169 | -2x | +|||
| 36 | +
- cfun = afun_list,+ #' Convert strings to `NA` |
|||
| 170 | -2x | +|||
| 37 | +
- na_str = na_str,+ #' |
|||
| 171 | -2x | +|||
| 38 | +
- extra_args = extra_args+ #' @description `r lifecycle::badge("stable")`
|
|||
| 172 | +39 |
- )+ #' |
||
| 173 | +40 |
- }+ #' SAS imports missing data as empty strings or strings with whitespaces only. This helper function can be used to |
| 1 | +41 |
- #' Sort pharmacokinetic data by `PARAM` variable+ #' convert these values to `NA`s. |
||
| 2 | +42 |
#' |
||
| 3 | +43 |
- #' @description `r lifecycle::badge("stable")`
+ #' @inheritParams explicit_na |
||
| 4 | +44 |
- #'+ #' @param empty (`flag`)\cr if `TRUE`, empty strings get replaced by `NA`. |
||
| 5 | +45 |
- #' @param pk_data (`data.frame`)\cr pharmacokinetic data frame.+ #' @param whitespaces (`flag`)\cr if `TRUE`, strings made from only whitespaces get replaced with `NA`. |
||
| 6 | +46 |
- #' @param key_var (`string`)\cr key variable used to merge pk_data and metadata created by [d_pkparam()].+ #' |
||
| 7 | +47 |
- #'+ #' @return `x` with `""` and/or whitespace-only values substituted by `NA`, depending on the values of |
||
| 8 | +48 |
- #' @return A pharmacokinetic `data.frame` sorted by a `PARAM` variable.+ #' `empty` and `whitespaces`. |
||
| 9 | +49 |
#' |
||
| 10 | +50 |
#' @examples |
||
| 11 | +51 |
- #' library(dplyr)+ #' sas_na(c("1", "", " ", " ", "b"))
|
||
| 12 | +52 |
- #'+ #' sas_na(factor(c("", " ", "b")))
|
||
| 13 | +53 |
- #' adpp <- tern_ex_adpp %>% mutate(PKPARAM = factor(paste0(PARAM, " (", AVALU, ")")))
+ #' |
||
| 14 | +54 |
- #' pk_ordered_data <- h_pkparam_sort(adpp)+ #' is.na(sas_na(c("1", "", " ", " ", "b")))
|
||
| 15 | +55 |
#' |
||
| 16 | +56 |
#' @export |
||
| 17 | +57 |
- h_pkparam_sort <- function(pk_data, key_var = "PARAMCD") {
+ sas_na <- function(x, empty = TRUE, whitespaces = TRUE) {
|
||
| 18 | -4x | +58 | +243x |
- assert_df_with_variables(pk_data, list(key_var = key_var))+ checkmate::assert_flag(empty) |
| 19 | -4x | +59 | +243x |
- pk_data$PARAMCD <- pk_data[[key_var]]+ checkmate::assert_flag(whitespaces) |
| 20 | +60 | |||
| 21 | -4x | -
- ordered_pk_data <- d_pkparam()- |
- ||
| 22 | -- | - - | -||
| 23 | -+ | 61 | +243x |
- # Add the numeric values from ordered_pk_data to pk_data+ if (is.factor(x)) {
|
| 24 | -4x | -
- joined_data <- merge(pk_data, ordered_pk_data, by = "PARAMCD", suffixes = c("", ".y"))
- |
- ||
| 25 | -+ | 62 | +135x |
-
+ empty_levels <- levels(x) == "" |
| 26 | -4x | +63 | +11x |
- joined_data <- joined_data[, -grep(".*.y$", colnames(joined_data))]
+ if (empty && any(empty_levels)) levels(x)[empty_levels] <- NA |
| 27 | +64 | |||
| 28 | -4x | +65 | +135x |
- joined_data$TLG_ORDER <- as.numeric(joined_data$TLG_ORDER)+ ws_levels <- grepl("^\\s+$", levels(x))
|
| 29 | -+ | |||
| 66 | +! |
-
+ if (whitespaces && any(ws_levels)) levels(x)[ws_levels] <- NA |
||
| 30 | +67 |
- # Then order PARAM based on this column+ |
||
| 31 | -4x | +68 | +135x |
- joined_data$PARAM <- factor(joined_data$PARAM,+ x |
| 32 | -4x | +69 | +108x |
- levels = unique(joined_data$PARAM[order(joined_data$TLG_ORDER)]),+ } else if (is.character(x)) {
|
| 33 | -4x | -
- ordered = TRUE- |
- ||
| 34 | -+ | 70 | +108x |
- )+ if (empty) x[x == ""] <- NA_character_ |
| 35 | +71 | |||
| 36 | -4x | +72 | +108x |
- joined_data$TLG_DISPLAY <- factor(joined_data$TLG_DISPLAY,+ if (whitespaces) x[grepl("^\\s+$", x)] <- NA_character_
|
| 37 | -4x | +|||
| 73 | +
- levels = unique(joined_data$TLG_DISPLAY[order(joined_data$TLG_ORDER)]),+ |
|||
| 38 | -4x | +74 | +108x |
- ordered = TRUE+ x |
| 39 | +75 |
- )+ } else {
|
||
| 40 | -+ | |||
| 76 | +! |
-
+ stop("only factors and character vectors allowed")
|
||
| 41 | -4x | +|||
| 77 | +
- joined_data+ } |
|||
| 42 | +78 |
}@@ -169797,14 +168239,14 @@ tern coverage - 95.64% |
| 1 |
- #' Combine factor levels+ #' Occurrence table sorting |
|||
| 5 |
- #' Combine specified old factor Levels in a single new level.+ #' Functions to score occurrence table subtables and rows which can be used in the |
|||
| 6 |
- #'+ #' sorting of occurrence tables. |
|||
| 7 |
- #' @param x (`factor`)\cr factor variable.+ #' |
|||
| 8 |
- #' @param levels (`character`)\cr level names to be combined.+ #' @name score_occurrences |
|||
| 9 |
- #' @param new_level (`string`)\cr name of new level.+ NULL |
|||
| 10 |
- #'+ |
|||
| 11 |
- #' @return A `factor` with the new levels.+ #' @describeIn score_occurrences Scoring function which sums the counts across all |
|||
| 12 |
- #'+ #' columns. It will fail if anything else but counts are used. |
|||
| 13 |
- #' @examples+ #' |
|||
| 14 |
- #' x <- factor(letters[1:5], levels = letters[5:1])+ #' @inheritParams rtables_access |
|||
| 15 |
- #' combine_levels(x, levels = c("a", "b"))
+ #' |
|||
| 16 |
- #'+ #' @return |
|||
| 17 |
- #' combine_levels(x, c("e", "b"))
+ #' * `score_occurrences()` returns the sum of counts across all columns of a table row. |
|||
| 19 |
- #' @export+ #' @seealso [h_row_first_values()] |
|||
| 20 |
- combine_levels <- function(x, levels, new_level = paste(levels, collapse = "/")) {
+ #' |
|||
| 21 | -4x | +
- checkmate::assert_factor(x)+ #' @examples |
||
| 22 | -4x | +
- checkmate::assert_subset(levels, levels(x))+ #' lyt <- basic_table() %>% |
||
| 23 |
-
+ #' split_cols_by("ARM") %>%
|
|||
| 24 | -4x | +
- lvls <- levels(x)+ #' add_colcounts() %>% |
||
| 25 |
-
+ #' analyze_num_patients( |
|||
| 26 | -4x | +
- lvls[lvls %in% levels] <- new_level+ #' vars = "USUBJID", |
||
| 27 |
-
+ #' .stats = c("unique"),
|
|||
| 28 | -4x | +
- levels(x) <- lvls+ #' .labels = c("Total number of patients with at least one event")
|
||
| 29 |
-
+ #' ) %>% |
|||
| 30 | -4x | +
- x+ #' split_rows_by("AEBODSYS", child_labels = "visible", nested = FALSE) %>%
|
||
| 31 |
- }+ #' summarize_num_patients( |
|||
| 32 |
-
+ #' var = "USUBJID", |
|||
| 33 |
- #' Conversion of a vector to a factor+ #' .stats = c("unique", "nonunique"),
|
|||
| 34 |
- #'+ #' .labels = c( |
|||
| 35 |
- #' Converts `x` to a factor and keeps its attributes. Warns appropriately such that the user+ #' "Total number of patients with at least one event", |
|||
| 36 |
- #' can decide whether they prefer converting to factor manually (e.g. for full control of+ #' "Total number of events" |
|||
| 37 |
- #' factor levels).+ #' ) |
|||
| 38 |
- #'+ #' ) %>% |
|||
| 39 |
- #' @param x (`vector`)\cr object to convert.+ #' count_occurrences(vars = "AEDECOD") |
|||
| 40 |
- #' @param x_name (`string`)\cr name of `x`.+ #' |
|||
| 41 |
- #' @param na_level (`string`)\cr the explicit missing level which should be used when converting a character vector.+ #' tbl <- build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl) %>% |
|||
| 42 |
- #' @param verbose (`flag`)\cr defaults to `TRUE`. It prints out warnings and messages.+ #' prune_table() |
|||
| 44 |
- #' @return A `factor` with same attributes (except class) as `x`. Does not modify `x` if already a `factor`.+ #' tbl_sorted <- tbl %>% |
|||
| 45 |
- #'+ #' sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_occurrences)
|
|||
| 46 |
- #' @keywords internal+ #' |
|||
| 47 |
- as_factor_keep_attributes <- function(x,+ #' tbl_sorted |
|||
| 48 |
- x_name = deparse(substitute(x)),+ #' |
|||
| 49 |
- na_level = "<Missing>",+ #' @export |
|||
| 50 |
- verbose = TRUE) {
+ score_occurrences <- function(table_row) {
|
|||
| 51 | -205x | +37x |
- checkmate::assert_atomic(x)+ row_counts <- h_row_counts(table_row) |
|
| 52 | -205x | +37x |
- checkmate::assert_string(x_name)+ sum(row_counts) |
|
| 53 | -205x | +
- checkmate::assert_string(na_level)+ } |
||
| 54 | -205x | +
- checkmate::assert_flag(verbose)+ |
||
| 55 | -205x | +
- if (is.factor(x)) {
+ #' @describeIn score_occurrences Scoring functions can be produced by this constructor to only include |
||
| 56 | -186x | +
- return(x)+ #' specific columns in the scoring. See [h_row_counts()] for further information. |
||
| 57 |
- }+ #' |
|||
| 58 | -19x | +
- x_class <- class(x)[1]+ #' @inheritParams has_count_in_cols |
||
| 59 | -19x | +
- if (verbose) {
+ #' |
||
| 60 | -15x | +
- warning(paste(+ #' @return |
||
| 61 | -15x | +
- "automatically converting", x_class, "variable", x_name,+ #' * `score_occurrences_cols()` returns a function that sums counts across all specified columns |
||
| 62 | -15x | +
- "to factor, better manually convert to factor to avoid failures"+ #' of a table row. |
||
| 63 |
- ))+ #' |
|||
| 64 |
- }+ #' @seealso [h_row_counts()] |
|||
| 65 | -19x | +
- if (identical(length(x), 0L)) {
+ #' |
||
| 66 | -1x | +
- warning(paste(+ #' @examples |
||
| 67 | -1x | +
- x_name, "has length 0, this can lead to tabulation failures, better convert to factor"+ #' score_cols_a_and_b <- score_occurrences_cols(col_names = c("A: Drug X", "B: Placebo"))
|
||
| 68 |
- ))+ #' |
|||
| 69 |
- }+ #' # Note that this here just sorts the AEDECOD inside the AEBODSYS. The AEBODSYS are not sorted. |
|||
| 70 | -19x | +
- if (is.character(x)) {
+ #' # That would require a second pass of `sort_at_path`. |
||
| 71 | -19x | +
- x_no_na <- explicit_na(sas_na(x), label = na_level)+ #' tbl_sorted <- tbl %>% |
||
| 72 | -19x | +
- if (any(na_level %in% x_no_na)) {
+ #' sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_cols_a_and_b)
|
||
| 73 | -3x | +
- do.call(+ #' |
||
| 74 | -3x | +
- structure,+ #' tbl_sorted |
||
| 75 | -3x | +
- c(+ #' |
||
| 76 | -3x | +
- list(.Data = forcats::fct_relevel(x_no_na, na_level, after = Inf)),+ #' @export |
||
| 77 | -3x | +
- attributes(x)+ score_occurrences_cols <- function(...) {
|
||
| 78 | -+ | 4x |
- )+ function(table_row) {
|
|
| 79 | -+ | 20x |
- )+ row_counts <- h_row_counts(table_row, ...) |
|
| 80 | -+ | 20x |
- } else {
+ sum(row_counts) |
|
| 81 | -16x | +
- do.call(structure, c(list(.Data = as.factor(x)), attributes(x)))+ } |
||
| 82 |
- }+ } |
|||
| 83 |
- } else {
+
|
|||
| 84 | -! | +
- do.call(structure, c(list(.Data = as.factor(x)), attributes(x)))+ #' @describeIn score_occurrences Scoring functions produced by this constructor can be used on |
||
| 85 |
- }+ #' subtables: They sum up all specified column counts in the subtable. This is useful when |
|||
| 86 |
- }+ #' there is no available content row summing up these counts. |
|||
| 87 |
-
+ #' |
|||
| 88 |
- #' Labels for bins in percent+ #' @return |
|||
| 89 |
- #'+ #' * `score_occurrences_subtable()` returns a function that sums counts in each subtable |
|||
| 90 |
- #' This creates labels for quantile based bins in percent. This assumes the right-closed+ #' across all specified columns. |
|||
| 91 |
- #' intervals as produced by [cut_quantile_bins()].+ #' |
|||
| 92 |
- #'+ #' @examples |
|||
| 93 |
- #' @param probs (`numeric`)\cr the probabilities identifying the quantiles.+ #' score_subtable_all <- score_occurrences_subtable(col_names = names(tbl)) |
|||
| 94 |
- #' This is a sorted vector of unique `proportion` values, i.e. between 0 and 1, where+ #' |
|||
| 95 |
- #' the boundaries 0 and 1 must not be included.+ #' # Note that this code just sorts the AEBODSYS, not the AEDECOD within AEBODSYS. That |
|||
| 96 |
- #' @param digits (`integer(1)`)\cr number of decimal places to round the percent numbers.+ #' # would require a second pass of `sort_at_path`. |
|||
| 97 |
- #'+ #' tbl_sorted <- tbl %>% |
|||
| 98 |
- #' @return A `character` vector with labels in the format `[0%,20%]`, `(20%,50%]`, etc.+ #' sort_at_path(path = c("AEBODSYS"), scorefun = score_subtable_all, decreasing = FALSE)
|
|||
| 100 |
- #' @keywords internal+ #' tbl_sorted |
|||
| 101 |
- bins_percent_labels <- function(probs,+ #' |
|||
| 102 |
- digits = 0) {
+ #' @export+ |
+ |||
| 103 | ++ |
+ score_occurrences_subtable <- function(...) {
+ |
+ ||
| 104 | +1x | +
+ score_table_row <- score_occurrences_cols(...)+ |
+ ||
| 105 | +1x | +
+ function(table_tree) {
+ |
+ ||
| 106 | +2x | +
+ table_rows <- collect_leaves(table_tree)+ |
+ ||
| 107 | +2x | +
+ counts <- vapply(table_rows, score_table_row, numeric(1))+ |
+ ||
| 108 | +2x | +
+ sum(counts)+ |
+ ||
| 109 | ++ |
+ }+ |
+ ||
| 110 | ++ |
+ }+ |
+ ||
| 111 | ++ | + + | +||
| 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 | ++ |
+ #' specified columns.+ |
+ ||
| 118 | ++ |
+ #'+ |
+ ||
| 119 | ++ |
+ #' @export+ |
+ ||
| 120 | ++ |
+ score_occurrences_cont_cols <- function(...) {
|
||
| 103 | -3x | +121 | +1x |
- if (isFALSE(0 %in% probs)) probs <- c(0, probs)+ score_table_row <- score_occurrences_cols(...) |
| 104 | -3x | +122 | +1x |
- if (isFALSE(1 %in% probs)) probs <- c(probs, 1)+ function(table_tree) {
|
| 105 | -10x | +123 | +2x |
- checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE)+ if (inherits(table_tree, "ContentRow")) {
|
| 106 | -10x | +|||
| 124 | +! |
- percent <- round(probs * 100, digits = digits)+ return(NA) |
||
| 107 | -10x | +|||
| 125 | +
- left <- paste0(utils::head(percent, -1), "%")+ } |
|||
| 108 | -10x | +126 | +2x |
- right <- paste0(utils::tail(percent, -1), "%")+ content_row <- h_content_first_row(table_tree) |
| 109 | -10x | +127 | +2x |
- without_left_bracket <- paste0(left, ",", right, "]")+ score_table_row(content_row) |
| 110 | -10x | +|||
| 128 | +
- with_left_bracket <- paste0("[", utils::head(without_left_bracket, 1))
+ } |
|||
| 111 | -10x | +|||
| 129 | +
- if (length(without_left_bracket) > 1) {
+ } |
|||
| 112 | -7x | +
| 1 | +
- with_left_bracket <- c(+ #' Analyze a pairwise Cox-PH model |
|||
| 113 | -7x | +|||
| 2 | +
- with_left_bracket,+ #' |
|||
| 114 | -7x | +|||
| 3 | +
- paste0("(", utils::tail(without_left_bracket, -1))
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 115 | +4 |
- )+ #' |
||
| 116 | +5 |
- }+ #' The analyze function [coxph_pairwise()] creates a layout element to analyze a pairwise Cox-PH model. |
||
| 117 | -10x | +|||
| 6 | +
- with_left_bracket+ #' |
|||
| 118 | +7 |
- }+ #' This function can return statistics including p-value, hazard ratio (HR), and HR confidence intervals from both |
||
| 119 | +8 |
-
+ #' stratified and unstratified Cox-PH models. The variable(s) to be analyzed is specified via the `vars` argument and |
||
| 120 | +9 |
- #' Cut numeric vector into empirical quantile bins+ #' any stratification factors via the `strata` argument. |
||
| 121 | +10 |
#' |
||
| 122 | +11 |
- #' @description `r lifecycle::badge("stable")`
+ #' @inheritParams argument_convention |
||
| 123 | +12 |
- #'+ #' @inheritParams s_surv_time |
||
| 124 | +13 |
- #' This cuts a numeric vector into sample quantile bins.+ #' @param strata (`character` or `NULL`)\cr variable names indicating stratification factors. |
||
| 125 | +14 |
- #'+ #' @param strat `r lifecycle::badge("deprecated")` Please use the `strata` argument instead.
|
||
| 126 | +15 |
- #' @inheritParams bins_percent_labels+ #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function |
||
| 127 | +16 |
- #' @param x (`numeric`)\cr the continuous variable values which should be cut into+ #' [control_coxph()]. Some possible parameter options are: |
||
| 128 | +17 |
- #' quantile bins. This may contain `NA` values, which are then+ #' * `pval_method` (`string`)\cr p-value method for testing the null hypothesis that hazard ratio = 1. Default |
||
| 129 | +18 |
- #' not used for the quantile calculations, but included in the return vector.+ #' method is `"log-rank"` which comes from [survival::survdiff()], can also be set to `"wald"` or `"likelihood"` |
||
| 130 | +19 |
- #' @param labels (`character`)\cr the unique labels for the quantile bins. When there are `n`+ #' (from [survival::coxph()]). |
||
| 131 | +20 |
- #' probabilities in `probs`, then this must be `n + 1` long.+ #' * `ties` (`string`)\cr specifying the method for tie handling. Default is `"efron"`, |
||
| 132 | +21 |
- #' @param type (`integer(1)`)\cr type of quantiles to use, see [stats::quantile()] for details.+ #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()]. |
||
| 133 | +22 |
- #' @param ordered (`flag`)\cr should the result be an ordered factor.+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR. |
||
| 134 | +23 |
- #'+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("coxph_pairwise")`
|
||
| 135 | +24 |
- #' @return A `factor` variable with appropriately-labeled bins as levels.+ #' to see available statistics for this function. |
||
| 136 | +25 |
#' |
||
| 137 | +26 |
- #' @note Intervals are closed on the right side. That is, the first bin is the interval+ #' @name survival_coxph_pairwise |
||
| 138 | +27 |
- #' `[-Inf, q1]` where `q1` is the first quantile, the second bin is then `(q1, q2]`, etc.,+ #' @order 1 |
||
| 139 | +28 |
- #' and the last bin is `(qn, +Inf]` where `qn` is the last quantile.+ NULL |
||
| 140 | +29 |
- #'+ |
||
| 141 | +30 |
- #' @examples+ #' @describeIn survival_coxph_pairwise Statistics function which analyzes HR, CIs of HR, and p-value of a Cox-PH model. |
||
| 142 | +31 |
- #' # Default is to cut into quartile bins.+ #' |
||
| 143 | +32 |
- #' cut_quantile_bins(cars$speed)+ #' @return |
||
| 144 | +33 |
- #'+ #' * `s_coxph_pairwise()` returns the statistics: |
||
| 145 | +34 |
- #' # Use custom quantiles.+ #' * `pvalue`: p-value to test the null hypothesis that hazard ratio = 1. |
||
| 146 | +35 |
- #' cut_quantile_bins(cars$speed, probs = c(0.1, 0.2, 0.6, 0.88))+ #' * `hr`: Hazard ratio. |
||
| 147 | +36 |
- #'+ #' * `hr_ci`: Confidence interval for hazard ratio. |
||
| 148 | +37 |
- #' # Use custom labels.+ #' * `n_tot`: Total number of observations. |
||
| 149 | +38 |
- #' cut_quantile_bins(cars$speed, labels = paste0("Q", 1:4))
+ #' * `n_tot_events`: Total number of events. |
||
| 150 | +39 |
#' |
||
| 151 | +40 |
- #' # NAs are preserved in result factor.+ #' @keywords internal |
||
| 152 | +41 |
- #' ozone_binned <- cut_quantile_bins(airquality$Ozone)+ s_coxph_pairwise <- function(df, |
||
| 153 | +42 |
- #' which(is.na(ozone_binned))+ .ref_group, |
||
| 154 | +43 |
- #' # So you might want to make these explicit.+ .in_ref_col, |
||
| 155 | +44 |
- #' explicit_na(ozone_binned)+ .var, |
||
| 156 | +45 |
- #'+ is_event, |
||
| 157 | +46 |
- #' @export+ strata = NULL, |
||
| 158 | +47 |
- cut_quantile_bins <- function(x,+ strat = lifecycle::deprecated(), |
||
| 159 | +48 |
- probs = c(0.25, 0.5, 0.75),+ control = control_coxph()) {
|
||
| 160 | -+ | |||
| 49 | +92x |
- labels = NULL,+ if (lifecycle::is_present(strat)) {
+ |
+ ||
| 50 | +! | +
+ lifecycle::deprecate_warn("0.9.4", "s_coxph_pairwise(strat)", "s_coxph_pairwise(strata)")
+ |
+ ||
| 51 | +! | +
+ strata <- strat |
||
| 161 | +52 |
- type = 7,+ } |
||
| 162 | +53 |
- ordered = TRUE) {
+
|
||
| 163 | -8x | +54 | +92x |
- checkmate::assert_flag(ordered)+ checkmate::assert_string(.var) |
| 164 | -8x | +55 | +92x |
- checkmate::assert_numeric(x)+ checkmate::assert_numeric(df[[.var]]) |
| 165 | -7x | +56 | +92x |
- if (isFALSE(0 %in% probs)) probs <- c(0, probs)+ checkmate::assert_logical(df[[is_event]]) |
| 166 | -7x | +57 | +92x |
- if (isFALSE(1 %in% probs)) probs <- c(probs, 1)+ assert_df_with_variables(df, list(tte = .var, is_event = is_event)) |
| 167 | -8x | +58 | +92x |
- checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE)+ pval_method <- control$pval_method |
| 168 | -7x | +59 | +92x |
- if (is.null(labels)) labels <- bins_percent_labels(probs)+ ties <- control$ties |
| 169 | -8x | +60 | +92x |
- checkmate::assert_character(labels, len = length(probs) - 1, any.missing = FALSE, unique = TRUE)+ conf_level <- control$conf_level |
| 170 | +61 | |||
| 171 | -8x | +62 | +92x |
- if (all(is.na(x))) {
+ if (.in_ref_col) {
|
| 172 | -+ | |||
| 63 | +! |
- # Early return if there are only NAs in input.+ return( |
||
| 173 | -1x | +|||
| 64 | +! |
- return(factor(x, ordered = ordered, levels = labels))+ list( |
||
| 174 | -+ | |||
| 65 | +! |
- }+ pvalue = formatters::with_label("", paste0("p-value (", pval_method, ")")),
|
||
| 175 | -+ | |||
| 66 | +! |
-
+ hr = formatters::with_label("", "Hazard Ratio"),
|
||
| 176 | -7x | +|||
| 67 | +! |
- quantiles <- stats::quantile(+ hr_ci = formatters::with_label("", f_conf_level(conf_level)),
|
||
| 177 | -7x | +|||
| 68 | +! |
- x,+ n_tot = formatters::with_label("", "Total n"),
|
||
| 178 | -7x | +|||
| 69 | +! |
- probs = probs,+ n_tot_events = formatters::with_label("", "Total events")
|
||
| 179 | -7x | +|||
| 70 | +
- type = type,+ ) |
|||
| 180 | -7x | +|||
| 71 | +
- na.rm = TRUE+ ) |
|||
| 181 | +72 |
- )+ } |
||
| 182 | -+ | |||
| 73 | +92x |
-
+ data <- rbind(.ref_group, df) |
||
| 183 | -7x | +74 | +92x |
- checkmate::assert_numeric(quantiles, unique = TRUE)+ group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
|
| 184 | +75 | |||
| 185 | -6x | +76 | +92x |
- cut(+ df_cox <- data.frame( |
| 186 | -6x | +77 | +92x |
- x,+ tte = data[[.var]], |
| 187 | -6x | +78 | +92x |
- breaks = quantiles,+ is_event = data[[is_event]], |
| 188 | -6x | +79 | +92x |
- labels = labels,+ arm = group |
| 189 | -6x | +|||
| 80 | +
- ordered_result = ordered,+ ) |
|||
| 190 | -6x | +81 | +92x |
- include.lowest = TRUE,+ if (is.null(strata)) {
|
| 191 | -6x | +82 | +83x |
- right = TRUE+ formula_cox <- survival::Surv(tte, is_event) ~ arm |
| 192 | +83 |
- )+ } else {
|
||
| 193 | -+ | |||
| 84 | +9x |
- }+ formula_cox <- stats::as.formula( |
||
| 194 | -+ | |||
| 85 | +9x |
-
+ paste0( |
||
| 195 | -+ | |||
| 86 | +9x |
- #' Discard specified levels of a factor+ "survival::Surv(tte, is_event) ~ arm + strata(",
|
||
| 196 | -+ | |||
| 87 | +9x |
- #'+ paste(strata, collapse = ","), |
||
| 197 | +88 |
- #' @description `r lifecycle::badge("stable")`
+ ")" |
||
| 198 | +89 |
- #'+ ) |
||
| 199 | +90 |
- #' This discards the observations as well as the levels specified from a factor.+ ) |
||
| 200 | -+ | |||
| 91 | +9x |
- #'+ df_cox <- cbind(df_cox, data[strata]) |
||
| 201 | +92 |
- #' @param x (`factor`)\cr the original factor.+ } |
||
| 202 | -+ | |||
| 93 | +92x |
- #' @param discard (`character`)\cr levels to discard.+ cox_fit <- survival::coxph( |
||
| 203 | -+ | |||
| 94 | +92x |
- #'+ formula = formula_cox, |
||
| 204 | -+ | |||
| 95 | +92x |
- #' @return A modified `factor` with observations as well as levels from `discard` dropped.+ data = df_cox, |
||
| 205 | -+ | |||
| 96 | +92x |
- #'+ ties = ties |
||
| 206 | +97 |
- #' @examples+ ) |
||
| 207 | -+ | |||
| 98 | +92x |
- #' fct_discard(factor(c("a", "b", "c")), "c")
+ sum_cox <- summary(cox_fit, conf.int = conf_level, extend = TRUE) |
||
| 208 | -+ | |||
| 99 | +92x |
- #'+ orginal_survdiff <- survival::survdiff( |
||
| 209 | -+ | |||
| 100 | +92x |
- #' @export+ formula_cox,+ |
+ ||
| 101 | +92x | +
+ data = df_cox |
||
| 210 | +102 |
- fct_discard <- function(x, discard) {
+ ) |
||
| 211 | -319x | +103 | +92x |
- checkmate::assert_factor(x)+ log_rank_pvalue <- 1 - pchisq(orginal_survdiff$chisq, length(orginal_survdiff$n) - 1)+ |
+
| 104 | ++ | + | ||
| 212 | -319x | +105 | +92x |
- checkmate::assert_character(discard, any.missing = FALSE)+ pval <- switch(pval_method, |
| 213 | -319x | +106 | +92x |
- new_obs <- x[!(x %in% discard)]+ "wald" = sum_cox$waldtest["pvalue"], |
| 214 | -319x | +107 | +92x |
- new_levels <- setdiff(levels(x), discard)+ "log-rank" = log_rank_pvalue, # pvalue from original log-rank test survival::survdiff() |
| 215 | -319x | +108 | +92x |
- factor(new_obs, levels = new_levels)+ "likelihood" = sum_cox$logtest["pvalue"] |
| 216 | +109 |
- }+ ) |
||
| 217 | -+ | |||
| 110 | +92x |
-
+ list( |
||
| 218 | -+ | |||
| 111 | +92x |
- #' Insertion of explicit missing values in a factor+ pvalue = formatters::with_label(unname(pval), paste0("p-value (", pval_method, ")")),
|
||
| 219 | -+ | |||
| 112 | +92x |
- #'+ hr = formatters::with_label(sum_cox$conf.int[1, 1], "Hazard Ratio"), |
||
| 220 | -+ | |||
| 113 | +92x |
- #' @description `r lifecycle::badge("stable")`
+ hr_ci = formatters::with_label(unname(sum_cox$conf.int[1, 3:4]), f_conf_level(conf_level)), |
||
| 221 | -+ | |||
| 114 | +92x |
- #'+ n_tot = formatters::with_label(sum_cox$n, "Total n"), |
||
| 222 | -+ | |||
| 115 | +92x |
- #' This inserts explicit missing values in a factor based on a condition. Additionally,+ n_tot_events = formatters::with_label(sum_cox$nevent, "Total events") |
||
| 223 | +116 |
- #' existing `NA` values will be explicitly converted to given `na_level`.+ ) |
||
| 224 | +117 |
- #'+ } |
||
| 225 | +118 |
- #' @param x (`factor`)\cr the original factor.+ |
||
| 226 | +119 |
- #' @param condition (`logical`)\cr positions at which to insert missing values.+ #' @describeIn survival_coxph_pairwise Formatted analysis function which is used as `afun` in `coxph_pairwise()`. |
||
| 227 | +120 |
- #' @param na_level (`string`)\cr which level to use for missing values.+ #' |
||
| 228 | +121 |
- #'+ #' @return |
||
| 229 | +122 |
- #' @return A modified `factor` with inserted and existing `NA` converted to `na_level`.+ #' * `a_coxph_pairwise()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 230 | +123 |
#' |
||
| 231 | +124 |
- #' @seealso [forcats::fct_na_value_to_level()] which is used internally.+ #' @keywords internal |
||
| 232 | +125 |
- #'+ a_coxph_pairwise <- make_afun( |
||
| 233 | +126 |
- #' @examples+ s_coxph_pairwise, |
||
| 234 | +127 |
- #' fct_explicit_na_if(factor(c("a", "b", NA)), c(TRUE, FALSE, FALSE))
+ .indent_mods = c(pvalue = 0L, hr = 0L, hr_ci = 1L, n_tot = 0L, n_tot_events = 0L), |
||
| 235 | +128 |
- #'+ .formats = c( |
||
| 236 | +129 |
- #' @export+ pvalue = "x.xxxx | (<0.0001)", |
||
| 237 | +130 |
- fct_explicit_na_if <- function(x, condition, na_level = "<Missing>") {
+ hr = "xx.xx", |
||
| 238 | -1x | +|||
| 131 | +
- checkmate::assert_factor(x, len = length(condition))+ hr_ci = "(xx.xx, xx.xx)", |
|||
| 239 | -1x | +|||
| 132 | +
- checkmate::assert_logical(condition)+ n_tot = "xx.xx", |
|||
| 240 | -1x | +|||
| 133 | +
- x[condition] <- NA+ n_tot_events = "xx.xx" |
|||
| 241 | -1x | +|||
| 134 | +
- x <- forcats::fct_na_value_to_level(x, level = na_level)+ ) |
|||
| 242 | -1x | +|||
| 135 | +
- forcats::fct_drop(x, only = na_level)+ ) |
|||
| 243 | +136 |
- }+ |
||
| 244 | +137 |
-
+ #' @describeIn survival_coxph_pairwise Layout-creating function which can take statistics function arguments |
||
| 245 | +138 |
- #' Collapse factor levels and keep only those new group levels+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 246 | +139 |
#' |
||
| 247 | +140 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return |
||
| 248 | +141 |
- #'+ #' * `coxph_pairwise()` returns a layout object suitable for passing to further layouting functions, |
||
| 249 | +142 |
- #' This collapses levels and only keeps those new group levels, in the order provided.+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 250 | +143 |
- #' The returned factor has levels in the order given, with the possible missing level last (this will+ #' the statistics from `s_coxph_pairwise()` to the table layout. |
||
| 251 | +144 |
- #' only be included if there are missing values).+ #' |
||
| 252 | +145 |
- #'+ #' @examples |
||
| 253 | +146 |
- #' @param .f (`factor` or `character`)\cr original vector.+ #' library(dplyr) |
||
| 254 | +147 |
- #' @param ... (named `character`)\cr levels in each vector provided will be collapsed into+ #' |
||
| 255 | +148 |
- #' the new level given by the respective name.+ #' adtte_f <- tern_ex_adtte %>% |
||
| 256 | +149 |
- #' @param .na_level (`string`)\cr which level to use for other levels, which should be missing in the+ #' filter(PARAMCD == "OS") %>% |
||
| 257 | +150 |
- #' new factor. Note that this level must not be contained in the new levels specified in `...`.+ #' mutate(is_event = CNSR == 0) |
||
| 258 | +151 |
#' |
||
| 259 | +152 |
- #' @return A modified `factor` with collapsed levels. Values and levels which are not included+ #' df <- adtte_f %>% filter(ARMCD == "ARM A") |
||
| 260 | +153 |
- #' in the given `character` vector input will be set to the missing level `.na_level`.+ #' df_ref_group <- adtte_f %>% filter(ARMCD == "ARM B") |
||
| 261 | +154 |
#' |
||
| 262 | +155 |
- #' @note Any existing `NA`s in the input vector will not be replaced by the missing level. If needed,+ #' basic_table() %>% |
||
| 263 | +156 |
- #' [explicit_na()] can be called separately on the result.+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
||
| 264 | +157 |
- #'+ #' add_colcounts() %>% |
||
| 265 | +158 |
- #' @seealso [forcats::fct_collapse()], [forcats::fct_relevel()] which are used internally.+ #' coxph_pairwise( |
||
| 266 | +159 |
- #'+ #' vars = "AVAL", |
||
| 267 | +160 |
- #' @examples+ #' is_event = "is_event", |
||
| 268 | +161 |
- #' fct_collapse_only(factor(c("a", "b", "c", "d")), TRT = "b", CTRL = c("c", "d"))
+ #' var_labels = "Unstratified Analysis" |
||
| 269 | +162 |
- #'+ #' ) %>% |
||
| 270 | +163 |
- #' @export+ #' build_table(df = adtte_f) |
||
| 271 | +164 |
- fct_collapse_only <- function(.f, ..., .na_level = "<Missing>") {
- |
- ||
| 272 | -4x | -
- new_lvls <- names(list(...))- |
- ||
| 273 | -4x | -
- if (checkmate::test_subset(.na_level, new_lvls)) {
- |
- ||
| 274 | -1x | -
- stop(paste0(".na_level currently set to '", .na_level, "' must not be contained in the new levels"))
+ #' |
||
| 275 | +165 |
- }- |
- ||
| 276 | -3x | -
- x <- forcats::fct_collapse(.f, ..., other_level = .na_level)+ #' basic_table() %>% |
||
| 277 | -3x | +|||
| 166 | +
- do.call(forcats::fct_relevel, args = c(list(.f = x), as.list(new_lvls)))+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
|||
| 278 | +167 |
- }+ #' add_colcounts() %>% |
||
| 279 | +168 |
-
+ #' coxph_pairwise( |
||
| 280 | +169 |
- #' Ungroup non-numeric statistics+ #' vars = "AVAL", |
||
| 281 | +170 |
- #'+ #' is_event = "is_event", |
||
| 282 | +171 |
- #' Ungroups grouped non-numeric statistics within input vectors `.formats`, `.labels`, and `.indent_mods`.+ #' var_labels = "Stratified Analysis", |
||
| 283 | +172 |
- #'+ #' strata = "SEX", |
||
| 284 | +173 |
- #' @inheritParams argument_convention+ #' control = control_coxph(pval_method = "wald") |
||
| 285 | +174 |
- #' @param x (named `list` of `numeric`)\cr list of numeric statistics containing the statistics to ungroup.+ #' ) %>% |
||
| 286 | +175 |
- #'+ #' build_table(df = adtte_f) |
||
| 287 | +176 |
- #' @return A `list` with modified elements `x`, `.formats`, `.labels`, and `.indent_mods`.+ #' |
||
| 288 | +177 |
- #'+ #' @export |
||
| 289 | +178 |
- #' @seealso [a_summary()] which uses this function internally.+ #' @order 2 |
||
| 290 | +179 |
- #'+ coxph_pairwise <- function(lyt, |
||
| 291 | +180 |
- #' @keywords internal+ vars, |
||
| 292 | +181 |
- ungroup_stats <- function(x,+ strata = NULL, |
||
| 293 | +182 |
- .formats,+ control = control_coxph(), |
||
| 294 | +183 |
- .labels,+ na_str = default_na_str(), |
||
| 295 | +184 |
- .indent_mods) {
+ nested = TRUE, |
||
| 296 | -316x | +|||
| 185 | +
- checkmate::assert_list(x)+ ..., |
|||
| 297 | -316x | +|||
| 186 | +
- empty_pval <- "pval" %in% names(x) && length(x[["pval"]]) == 0+ var_labels = "CoxPH", |
|||
| 298 | -316x | +|||
| 187 | +
- empty_pval_counts <- "pval_counts" %in% names(x) && length(x[["pval_counts"]]) == 0+ show_labels = "visible", |
|||
| 299 | -316x | +|||
| 188 | +
- x <- unlist(x, recursive = FALSE)+ table_names = vars, |
|||
| 300 | +189 |
-
+ .stats = c("pvalue", "hr", "hr_ci"),
|
||
| 301 | +190 |
- # If p-value is empty it is removed by unlist and needs to be re-added+ .formats = NULL, |
||
| 302 | -! | +|||
| 191 | +
- if (empty_pval) x[["pval"]] <- character()+ .labels = NULL, |
|||
| 303 | -3x | +|||
| 192 | +
- if (empty_pval_counts) x[["pval_counts"]] <- character()+ .indent_mods = NULL) {
|
|||
| 304 | -316x | +193 | +5x |
- .stats <- names(x)+ extra_args <- list(strata = strata, control = control, ...) |
| 305 | +194 | |||
| 306 | -+ | |||
| 195 | +5x |
- # Ungroup stats+ afun <- make_afun( |
||
| 307 | -316x | +196 | +5x |
- .formats <- lapply(.stats, function(x) {
+ a_coxph_pairwise, |
| 308 | -2644x | +197 | +5x |
- .formats[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
+ .stats = .stats, |
| 309 | -+ | |||
| 198 | +5x |
- })+ .formats = .formats, |
||
| 310 | -316x | +199 | +5x |
- .indent_mods <- sapply(.stats, function(x) {
+ .labels = .labels, |
| 311 | -2644x | +200 | +5x |
- .indent_mods[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
+ .indent_mods = .indent_mods |
| 312 | +201 |
- })+ ) |
||
| 313 | -316x | +202 | +5x |
- .labels <- sapply(.stats, function(x) {
+ analyze( |
| 314 | -2575x | +203 | +5x |
- if (!grepl("\\.", x)) .labels[[x]] else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][2]
+ lyt, |
| 315 | -+ | |||
| 204 | +5x |
- })+ vars, |
||
| 316 | -+ | |||
| 205 | +5x |
-
+ var_labels = var_labels, |
||
| 317 | -316x | +206 | +5x |
- list(+ show_labels = show_labels, |
| 318 | -316x | +207 | +5x |
- x = x,+ table_names = table_names, |
| 319 | -316x | +208 | +5x |
- .formats = .formats,+ afun = afun, |
| 320 | -316x | +209 | +5x |
- .labels = .labels,+ na_str = na_str, |
| 321 | -316x | +210 | +5x |
- .indent_mods = .indent_mods+ nested = nested,+ |
+
| 211 | +5x | +
+ extra_args = extra_args |
||
| 322 | +212 |
) |
||
| 323 | +213 |
}@@ -172064,14 +170645,14 @@ tern coverage - 95.64% |
| 1 |
- #' Helper functions for accessing information from `rtables`+ #' Split function to configure risk difference column |
||
| 5 |
- #' These are a couple of functions that help with accessing the data in `rtables` objects.+ #' Wrapper function for [rtables::add_combo_levels()] which configures settings for the risk difference |
||
| 6 |
- #' Currently these work for occurrence tables, which are defined as having a count as the first+ #' column to be added to an `rtables` object. To add a risk difference column to a table, this function |
||
| 7 |
- #' element and a fraction as the second element in each cell.+ #' should be used as `split_fun` in calls to [rtables::split_cols_by()], followed by setting argument |
||
| 8 |
- #'+ #' `riskdiff` to `TRUE` in all following analyze function calls. |
||
| 9 |
- #' @seealso [prune_occurrences] for usage of these functions.+ #' |
||
| 10 |
- #'+ #' @param arm_x (`string`)\cr name of reference arm to use in risk difference calculations. |
||
| 11 |
- #' @name rtables_access+ #' @param arm_y (`character`)\cr names of one or more arms to compare to reference arm in risk difference |
||
| 12 |
- NULL+ #' calculations. A new column will be added for each value of `arm_y`. |
||
| 13 |
-
+ #' @param col_label (`character`)\cr labels to use when rendering the risk difference column within the table. |
||
| 14 |
- #' @describeIn rtables_access Helper function to extract the first values from each content+ #' If more than one comparison arm is specified in `arm_y`, default labels will specify which two arms are |
||
| 15 |
- #' cell and from specified columns in a `TableRow`. Defaults to all columns.+ #' being compared (reference arm vs. comparison arm). |
||
| 16 |
- #'+ #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`. |
||
| 17 |
- #' @param table_row (`TableRow`)\cr an analysis row in a occurrence table.+ #' |
||
| 18 |
- #' @param col_names (`character`)\cr the names of the columns to extract from.+ #' @return A closure suitable for use as a split function (`split_fun`) within [rtables::split_cols_by()] |
||
| 19 |
- #' @param col_indices (`integer`)\cr the indices of the columns to extract from. If `col_names` are provided,+ #' when creating a table layout. |
||
| 20 |
- #' then these are inferred from the names of `table_row`. Note that this currently only works well with a single+ #' |
||
| 21 |
- #' column split.+ #' @seealso [stat_propdiff_ci()] for details on risk difference calculation. |
||
| 23 |
- #' @return+ #' @examples |
||
| 24 |
- #' * `h_row_first_values()` returns a `vector` of numeric values.+ #' adae <- tern_ex_adae |
||
| 25 |
- #'+ #' adae$AESEV <- factor(adae$AESEV) |
||
| 26 |
- #' @examples+ #' |
||
| 27 |
- #' tbl <- basic_table() %>%+ #' lyt <- basic_table() %>% |
||
| 28 |
- #' split_cols_by("ARM") %>%
+ #' split_cols_by("ARMCD", split_fun = add_riskdiff(arm_x = "ARM A", arm_y = c("ARM B", "ARM C"))) %>%
|
||
| 29 |
- #' split_rows_by("RACE") %>%
+ #' count_occurrences_by_grade( |
||
| 30 |
- #' analyze("AGE", function(x) {
+ #' var = "AESEV", |
||
| 31 |
- #' list(+ #' riskdiff = TRUE |
||
| 32 |
- #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.x (xx.x)"),+ #' ) |
||
| 33 |
- #' "n" = length(x),+ #' |
||
| 34 |
- #' "frac" = rcell(c(0.1, 0.1), format = "xx (xx)")+ #' tbl <- build_table(lyt, df = adae) |
||
| 35 |
- #' )+ #' tbl |
||
| 36 |
- #' }) %>%+ #' |
||
| 37 |
- #' build_table(tern_ex_adsl) %>%+ #' @export |
||
| 38 |
- #' prune_table()+ add_riskdiff <- function(arm_x, |
||
| 39 |
- #' tree_row_elem <- collect_leaves(tbl[2, ])[[1]]+ arm_y, |
||
| 40 |
- #' result <- max(h_row_first_values(tree_row_elem))+ col_label = paste0( |
||
| 41 |
- #' result+ "Risk Difference (%) (95% CI)", if (length(arm_y) > 1) paste0("\n", arm_x, " vs. ", arm_y)
|
||
| 42 |
- #'+ ), |
||
| 43 |
- #' @export+ pct = TRUE) {
|
||
| 44 | -+ | 17x |
- h_row_first_values <- function(table_row,+ checkmate::assert_character(arm_x, len = 1) |
| 45 | -+ | 17x |
- col_names = NULL,+ checkmate::assert_character(arm_y, min.len = 1) |
| 46 | -+ | 17x |
- col_indices = NULL) {
+ checkmate::assert_character(col_label, len = length(arm_y)) |
| 47 | -745x | +
- col_indices <- check_names_indices(table_row, col_names, col_indices)+ |
|
| 48 | -744x | +17x |
- checkmate::assert_integerish(col_indices)+ combodf <- tibble::tribble(~valname, ~label, ~levelcombo, ~exargs) |
| 49 | -744x | +17x |
- checkmate::assert_subset(col_indices, seq_len(ncol(table_row)))+ for (i in seq_len(length(arm_y))) {
|
| 50 | -+ | 18x |
-
+ combodf <- rbind( |
| 51 | -+ | 18x |
- # Main values are extracted+ combodf, |
| 52 | -744x | +18x |
- row_vals <- row_values(table_row)[col_indices]+ tibble::tribble( |
| 53 | -+ | 18x |
-
+ ~valname, ~label, ~levelcombo, ~exargs, |
| 54 | -+ | 18x |
- # Main return+ paste("riskdiff", arm_x, arm_y[i], sep = "_"), col_label[i], c(arm_x, arm_y[i]), list()
|
| 55 | -744x | +
- vapply(row_vals, function(rv) {
+ ) |
|
| 56 | -2096x | +
- if (is.null(rv)) {
+ ) |
|
| 57 | -744x | +
- NA_real_+ } |
|
| 58 | -+ | 17x |
- } else {
+ if (pct) combodf$valname <- paste0(combodf$valname, "_pct") |
| 59 | -2090x | +17x |
- rv[1L]+ add_combo_levels(combodf) |
| 60 |
- }+ } |
||
| 61 | -744x | +
- }, FUN.VALUE = numeric(1))+ |
|
| 62 |
- }+ #' Analysis function to calculate risk difference column values |
||
| 63 |
-
+ #' |
||
| 64 |
- #' @describeIn rtables_access Helper function that extracts row values and checks if they are+ #' In the risk difference column, this function uses the statistics function associated with `afun` to |
||
| 65 |
- #' convertible to integers (`integerish` values).+ #' 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 |
- #' @return+ #' the previous call to [rtables::split_cols_by()]. For all other columns, applies `afun` as usual. This |
||
| 68 |
- #' * `h_row_counts()` returns a `vector` of numeric values.+ #' function utilizes the [stat_propdiff_ci()] function to perform risk difference calculations. |
||
| 70 |
- #' @examples+ #' @inheritParams argument_convention |
||
| 71 |
- #' # Row counts (integer values)+ #' @param afun (named `list`)\cr a named list containing one name-value pair where the name corresponds to |
||
| 72 |
- #' # h_row_counts(tree_row_elem) # Fails because there are no integers+ #' the name of the statistics function that should be used in calculations and the value is the corresponding |
||
| 73 |
- #' # Using values with integers+ #' analysis function. |
||
| 74 |
- #' tree_row_elem <- collect_leaves(tbl[3, ])[[1]]+ #' @param s_args (named `list`)\cr additional arguments to be passed to the statistics function and analysis |
||
| 75 |
- #' result <- h_row_counts(tree_row_elem)+ #' function supplied in `afun`. |
||
| 76 |
- #' # result+ #' |
||
| 77 |
- #'+ #' @return A list of formatted [rtables::CellValue()]. |
||
| 78 |
- #' @export+ #' |
||
| 79 |
- h_row_counts <- function(table_row,+ #' @seealso |
||
| 80 |
- col_names = NULL,+ #' * [stat_propdiff_ci()] for details on risk difference calculation. |
||
| 81 |
- col_indices = NULL) {
+ #' * Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()] with |
||
| 82 | -741x | +
- counts <- h_row_first_values(table_row, col_names, col_indices)+ #' `riskdiff` argument set to `TRUE` in subsequent analyze functions calls, adds a risk difference column |
|
| 83 | -741x | +
- checkmate::assert_integerish(counts)+ #' to a table layout. |
|
| 84 | -741x | +
- counts+ #' |
|
| 85 |
- }+ #' @keywords internal |
||
| 86 |
-
+ afun_riskdiff <- function(df, |
||
| 87 |
- #' @describeIn rtables_access Helper function to extract fractions from specified columns in a `TableRow`.+ labelstr = "", |
||
| 88 |
- #' More specifically it extracts the second values from each content cell and checks it is a fraction.+ .var, |
||
| 89 |
- #'+ .N_col, # nolint |
||
| 90 |
- #' @return+ .N_row, # nolint |
||
| 91 |
- #' * `h_row_fractions()` returns a `vector` of proportions.+ .df_row, |
||
| 92 |
- #'+ .spl_context, |
||
| 93 |
- #' @examples+ .all_col_counts, |
||
| 94 |
- #' # Row fractions+ .stats, |
||
| 95 |
- #' tree_row_elem <- collect_leaves(tbl[4, ])[[1]]+ .formats = NULL, |
||
| 96 |
- #' h_row_fractions(tree_row_elem)+ .labels = NULL, |
||
| 97 |
- #'+ .indent_mods = NULL, |
||
| 98 |
- #' @export+ na_str = default_na_str(), |
||
| 99 |
- h_row_fractions <- function(table_row,+ afun, |
||
| 100 |
- col_names = NULL,+ s_args = list()) {
|
||
| 101 | -+ | 130x |
- col_indices = NULL) {
+ if (!any(grepl("riskdiff", names(.spl_context)))) {
|
| 102 | -250x | +! |
- col_indices <- check_names_indices(table_row, col_names, col_indices)+ stop( |
| 103 | -250x | +! |
- row_vals <- row_values(table_row)[col_indices]+ "Please set up levels to use in risk difference calculations using the `add_riskdiff` ", |
| 104 | -250x | +! |
- fractions <- sapply(row_vals, "[", 2L)+ "split function within `split_cols_by`. See ?add_riskdiff for details." |
| 105 | -250x | +
- checkmate::assert_numeric(fractions, lower = 0, upper = 1)+ ) |
|
| 106 | -250x | +
- fractions+ } |
|
| 107 | -+ | 130x |
- }+ checkmate::assert_list(afun, len = 1, types = "function") |
| 108 | -+ | 130x |
-
+ checkmate::assert_named(afun) |
| 109 | -+ | 130x |
- #' @describeIn rtables_access Helper function to extract column counts from specified columns in a table.+ afun_args <- list( |
| 110 | -+ | 130x |
- #'+ .var = .var, .df_row = .df_row, .N_row = .N_row, denom = "N_col", labelstr = labelstr, |
| 111 | -+ | 130x |
- #' @param table (`VTableNodeInfo`)\cr an occurrence table or row.+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str |
| 112 |
- #'+ ) |
||
| 113 | -+ | 130x |
- #' @return+ afun_args <- afun_args[intersect(names(afun_args), names(as.list(args(afun[[1]]))))] |
| 114 | -+ | ! |
- #' * `h_col_counts()` returns a `vector` of column counts.+ if ("denom" %in% names(s_args)) afun_args[["denom"]] <- NULL
|
| 115 |
- #'+ |
||
| 116 | -+ | 130x |
- #' @export+ cur_split <- tail(.spl_context$cur_col_split_val[[1]], 1) |
| 117 | -+ | 130x |
- h_col_counts <- function(table,+ if (!grepl("^riskdiff", cur_split)) {
|
| 118 |
- col_names = NULL,+ # Apply basic afun (no risk difference) in all other columns |
||
| 119 | -+ | 96x |
- col_indices = NULL) {
+ do.call(afun[[1]], args = c(list(df = df, .N_col = .N_col), afun_args, s_args)) |
| 120 | -307x | +
- col_indices <- check_names_indices(table, col_names, col_indices)+ } else {
|
|
| 121 | -307x | +34x |
- counts <- col_counts(table)[col_indices]+ arm_x <- strsplit(cur_split, "_")[[1]][2] |
| 122 | -307x | +34x |
- stats::setNames(counts, col_names)+ arm_y <- strsplit(cur_split, "_")[[1]][3] |
| 123 | -+ | 34x |
- }+ if (length(.spl_context$cur_col_split[[1]]) > 1) { # Different split name for nested column splits
|
| 124 | -+ | 8x |
-
+ arm_spl_x <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 2)], collapse = ""))
|
| 125 | -+ | 8x |
- #' @describeIn rtables_access Helper function to get first row of content table of current table.+ arm_spl_y <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 3)], collapse = ""))
|
| 126 |
- #'+ } else {
|
||
| 127 | -+ | 26x |
- #' @return+ arm_spl_x <- arm_x |
| 128 | -+ | 26x |
- #' * `h_content_first_row()` returns a row from an `rtables` table.+ arm_spl_y <- arm_y |
| 129 |
- #'+ } |
||
| 130 | -+ | 34x |
- #' @export+ N_col_x <- .all_col_counts[[arm_spl_x]] # nolint |
| 131 | -+ | 34x |
- h_content_first_row <- function(table) {
+ N_col_y <- .all_col_counts[[arm_spl_y]] # nolint |
| 132 | -27x | +34x |
- ct <- content_table(table)+ cur_var <- tail(.spl_context$cur_col_split[[1]], 1) |
| 133 | -27x | +
- tree_children(ct)[[1]]+ |
|
| 134 |
- }+ # Apply statistics function to arm X and arm Y data |
||
| 135 | -+ | 34x |
-
+ s_args <- c(s_args, afun_args[intersect(names(afun_args), names(as.list(args(names(afun)))))]) |
| 136 | -+ | 34x |
- #' @describeIn rtables_access Helper function which says whether current table is a leaf in the tree.+ s_x <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_x, ], .N_col = N_col_x), s_args)) |
| 137 | -+ | 34x |
- #'+ s_y <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_y, ], .N_col = N_col_y), s_args)) |
| 138 |
- #' @return+ |
||
| 139 |
- #' * `is_leaf_table()` returns a `logical` value indicating whether current table is a leaf.+ # Get statistic name and row names |
||
| 140 | -+ | 34x |
- #'+ stat <- ifelse("count_fraction" %in% names(s_x), "count_fraction", "unique")
|
| 141 | -+ | 34x |
- #' @keywords internal+ if ("flag_variables" %in% names(s_args)) {
|
| 142 | -+ | 2x |
- is_leaf_table <- function(table) {
+ var_nms <- s_args$flag_variables |
| 143 | -168x | +32x |
- children <- tree_children(table)+ } else if (!is.null(names(s_x[[stat]]))) {
|
| 144 | -168x | +20x |
- child_classes <- unique(sapply(children, class))+ var_nms <- names(s_x[[stat]]) |
| 145 | -168x | +
- identical(child_classes, "ElementaryTable")+ } else {
|
|
| 146 | -+ | 12x |
- }+ var_nms <- "" |
| 147 | -+ | 12x |
-
+ s_x[[stat]] <- list(s_x[[stat]]) |
| 148 | -+ | 12x |
- #' @describeIn rtables_access Internal helper function that tests standard inputs for column indices.+ s_y[[stat]] <- list(s_y[[stat]]) |
| 149 |
- #'+ } |
||
| 150 |
- #' @return+ |
||
| 151 |
- #' * `check_names_indices` returns column indices.+ # Calculate risk difference for each row, repeated if multiple statistics in table |
||
| 152 | -+ | 34x |
- #'+ pct <- tail(strsplit(cur_split, "_")[[1]], 1) == "pct" |
| 153 | -+ | 34x |
- #' @keywords internal+ rd_ci <- rep(stat_propdiff_ci( |
| 154 | -+ | 34x |
- check_names_indices <- function(table_row,+ lapply(s_x[[stat]], `[`, 1), lapply(s_y[[stat]], `[`, 1), |
| 155 | -+ | 34x |
- col_names = NULL,+ N_col_x, N_col_y, |
| 156 | -+ | 34x |
- col_indices = NULL) {
+ list_names = var_nms, |
| 157 | -1302x | +34x |
- if (!is.null(col_names)) {
+ pct = pct |
| 158 | -1256x | +34x |
- if (!is.null(col_indices)) {
+ ), max(1, length(.stats))) |
| 159 | -1x | +
- stop(+ |
|
| 160 | -1x | +34x |
- "Inserted both col_names and col_indices when selecting row values. ",+ in_rows(.list = rd_ci, .formats = "xx.x (xx.x - xx.x)", .indent_mods = .indent_mods) |
| 161 | -1x | +
- "Please choose one."+ } |
|
| 162 |
- )+ } |
||
| 163 |
- }+ |
||
| 164 | -1255x | +
- col_indices <- h_col_indices(table_row, col_names)+ #' Control function for risk difference column |
|
| 165 |
- }+ #' |
||
| 166 | -1301x | +
- if (is.null(col_indices)) {
+ #' @description `r lifecycle::badge("stable")`
|
|
| 167 | -39x | +
- ll <- ifelse(is.null(ncol(table_row)), length(table_row), ncol(table_row))+ #' |
|
| 168 | -39x | +
- col_indices <- seq_len(ll)+ #' 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 | -1301x | +
- return(col_indices)+ #' @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 | ++ |
+ control_riskdiff <- function(arm_x = NULL,+ |
+ |
| 186 | ++ |
+ arm_y = NULL,+ |
+ |
| 187 | ++ |
+ format = "xx.x (xx.x - xx.x)",+ |
+ |
| 188 | ++ |
+ col_label = "Risk Difference (%) (95% CI)",+ |
+ |
| 189 | ++ |
+ 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 | +
+ checkmate::assert_character(format, len = 1)+ |
+ |
| 193 | +2x | +
+ checkmate::assert_character(col_label)+ |
+ |
| 194 | +2x | +
+ checkmate::assert_flag(pct)+ |
+ |
| 195 | ++ | + + | +|
| 196 | +2x | +
+ list(arm_x = arm_x, arm_y = arm_y, format = format, col_label = col_label, pct = pct)+ |
+ |
| 197 | +
} |
@@ -173274,14 +172030,14 @@
| 1 |
- #' Horizontal waterfall plot+ #' Subgroup treatment effect pattern (STEP) fit for binary (response) outcome |
||
| 5 |
- #' This basic waterfall plot visualizes a quantity `height` ordered by value with some markup.+ #' This fits the Subgroup Treatment Effect Pattern logistic regression models for a binary |
||
| 6 |
- #'+ #' (response) outcome. The treatment arm variable must have exactly 2 levels, |
||
| 7 |
- #' @param height (`numeric`)\cr vector containing values to be plotted as the waterfall bars.+ #' where the first one is taken as reference and the estimated odds ratios are |
||
| 8 |
- #' @param id (`character`)\cr vector containing identifiers to use as the x-axis label for the waterfall bars.+ #' for the comparison of the second level vs. the first one. |
||
| 9 |
- #' @param col (`character`)\cr color(s).+ #' |
||
| 10 |
- #' @param col_var (`factor`, `character`, or `NULL`)\cr categorical variable for bar coloring. `NULL` by default.+ #' The (conditional) logistic regression model which is fit is: |
||
| 11 |
- #' @param xlab (`string`)\cr x label. Default is `"ID"`.+ #' |
||
| 12 |
- #' @param ylab (`string`)\cr y label. Default is `"Value"`.+ #' `response ~ arm * poly(biomarker, degree) + covariates + strata(strata)` |
||
| 13 |
- #' @param title (`string`)\cr text to be displayed as plot title.+ #' |
||
| 14 |
- #' @param col_legend_title (`string`)\cr text to be displayed as legend title.+ #' where `degree` is specified by `control_step()`. |
||
| 16 |
- #' @return A `ggplot` waterfall plot.+ #' @inheritParams argument_convention |
||
| 17 |
- #'+ #' @param variables (named `list` of `character`)\cr list of analysis variables: |
||
| 18 |
- #' @examples+ #' needs `response`, `arm`, `biomarker`, and optional `covariates` and `strata`. |
||
| 19 |
- #' library(dplyr)+ #' @param control (named `list`)\cr combined control list from [control_step()] |
||
| 20 |
- #' library(nestcolor)+ #' and [control_logistic()]. |
||
| 22 |
- #' g_waterfall(height = c(3, 5, -1), id = letters[1:3])+ #' @return A matrix of class `step`. The first part of the columns describe the |
||
| 23 |
- #'+ #' subgroup intervals used for the biomarker variable, including where the |
||
| 24 |
- #' g_waterfall(+ #' center of the intervals are and their bounds. The second part of the |
||
| 25 |
- #' height = c(3, 5, -1),+ #' columns contain the estimates for the treatment arm comparison. |
||
| 26 |
- #' id = letters[1:3],+ #' |
||
| 27 |
- #' col_var = letters[1:3]+ #' @note For the default degree 0 the `biomarker` variable is not included in the model. |
||
| 28 |
- #' )+ #' |
||
| 29 |
- #'+ #' @seealso [control_step()] and [control_logistic()] for the available |
||
| 30 |
- #' adsl_f <- tern_ex_adsl %>%+ #' customization options. |
||
| 31 |
- #' select(USUBJID, STUDYID, ARM, ARMCD, SEX)+ #' |
||
| 32 |
- #'+ #' @examples |
||
| 33 |
- #' adrs_f <- tern_ex_adrs %>%+ #' # Testing dataset with just two treatment arms. |
||
| 34 |
- #' filter(PARAMCD == "OVRINV") %>%+ #' library(survival) |
||
| 35 |
- #' mutate(pchg = rnorm(n(), 10, 50))+ #' library(dplyr) |
||
| 37 |
- #' adrs_f <- head(adrs_f, 30)+ #' adrs_f <- tern_ex_adrs %>% |
||
| 38 |
- #' adrs_f <- adrs_f[!duplicated(adrs_f$USUBJID), ]+ #' filter( |
||
| 39 |
- #' head(adrs_f)+ #' PARAMCD == "BESRSPI", |
||
| 40 |
- #'+ #' ARM %in% c("B: Placebo", "A: Drug X")
|
||
| 41 |
- #' g_waterfall(+ #' ) %>% |
||
| 42 |
- #' height = adrs_f$pchg,+ #' mutate( |
||
| 43 |
- #' id = adrs_f$USUBJID,+ #' # Reorder levels of ARM to have Placebo as reference arm for Odds Ratio calculations. |
||
| 44 |
- #' col_var = adrs_f$AVALC+ #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")), |
||
| 45 |
- #' )+ #' RSP = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
||
| 46 |
- #'+ #' SEX = factor(SEX) |
||
| 47 |
- #' g_waterfall(+ #' ) |
||
| 48 |
- #' height = adrs_f$pchg,+ #' |
||
| 49 |
- #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
+ #' variables <- list( |
||
| 50 |
- #' col_var = adrs_f$SEX+ #' arm = "ARM", |
||
| 51 |
- #' )+ #' biomarker = "BMRKR1", |
||
| 52 |
- #'+ #' covariates = "AGE", |
||
| 53 |
- #' g_waterfall(+ #' response = "RSP" |
||
| 54 |
- #' height = adrs_f$pchg,+ #' ) |
||
| 55 |
- #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
+ #' |
||
| 56 |
- #' xlab = "ID",+ #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup. |
||
| 57 |
- #' ylab = "Percentage Change",+ #' # We use a large enough bandwidth to avoid too small subgroups and linear separation in those. |
||
| 58 |
- #' title = "Waterfall plot"+ #' step_matrix <- fit_rsp_step( |
||
| 59 |
- #' )+ #' variables = variables, |
||
| 60 |
- #'+ #' data = adrs_f, |
||
| 61 |
- #' @export+ #' control = c(control_logistic(), control_step(bandwidth = 0.9)) |
||
| 62 |
- g_waterfall <- function(height,+ #' ) |
||
| 63 |
- id,+ #' dim(step_matrix) |
||
| 64 |
- col_var = NULL,+ #' head(step_matrix) |
||
| 65 |
- col = getOption("ggplot2.discrete.colour"),
+ #' |
||
| 66 |
- xlab = NULL,+ #' # Specify different polynomial degree for the biomarker interaction to use more flexible local |
||
| 67 |
- ylab = NULL,+ #' # models. Or specify different logistic regression options, including confidence level. |
||
| 68 |
- col_legend_title = NULL,+ #' step_matrix2 <- fit_rsp_step( |
||
| 69 |
- title = NULL) {
+ #' variables = variables, |
||
| 70 | -2x | +
- if (!is.null(col_var)) {
+ #' data = adrs_f, |
|
| 71 | -1x | +
- check_same_n(height = height, id = id, col_var = col_var)+ #' control = c(control_logistic(conf_level = 0.9), control_step(bandwidth = NULL, degree = 1)) |
|
| 72 |
- } else {
+ #' ) |
||
| 73 | -1x | +
- check_same_n(height = height, id = id)+ #' |
|
| 74 |
- }+ #' # Use a global constant model. This is helpful as a reference for the subgroup models. |
||
| 75 |
-
+ #' step_matrix3 <- fit_rsp_step( |
||
| 76 | -2x | +
- checkmate::assert_multi_class(col_var, c("character", "factor"), null.ok = TRUE)
+ #' variables = variables, |
|
| 77 | -2x | +
- checkmate::assert_character(col, null.ok = TRUE)+ #' data = adrs_f, |
|
| 78 |
-
+ #' control = c(control_logistic(), control_step(bandwidth = NULL, num_points = 2L)) |
||
| 79 | -2x | +
- xlabel <- deparse(substitute(id))+ #' ) |
|
| 80 | -2x | +
- ylabel <- deparse(substitute(height))+ #' |
|
| 81 |
-
+ #' # It is also possible to use strata, i.e. use conditional logistic regression models. |
||
| 82 | -2x | +
- col_label <- if (!missing(col_var)) {
+ #' variables2 <- list( |
|
| 83 | -1x | +
- deparse(substitute(col_var))+ #' arm = "ARM", |
|
| 84 |
- }+ #' biomarker = "BMRKR1", |
||
| 85 |
-
+ #' covariates = "AGE", |
||
| 86 | -2x | +
- xlab <- if (is.null(xlab)) xlabel else xlab+ #' response = "RSP", |
|
| 87 | -2x | +
- ylab <- if (is.null(ylab)) ylabel else ylab+ #' strata = c("STRATA1", "STRATA2")
|
|
| 88 | -2x | +
- col_legend_title <- if (is.null(col_legend_title)) col_label else col_legend_title+ #' ) |
|
| 89 |
-
+ #' |
||
| 90 | -2x | +
- plot_data <- data.frame(+ #' step_matrix4 <- fit_rsp_step( |
|
| 91 | -2x | +
- height = height,+ #' variables = variables2, |
|
| 92 | -2x | +
- id = as.character(id),+ #' data = adrs_f, |
|
| 93 | -2x | +
- col_var = if (is.null(col_var)) "x" else to_n(col_var, length(height)),+ #' control = c(control_logistic(), control_step(bandwidth = NULL)) |
|
| 94 | -2x | +
- stringsAsFactors = FALSE+ #' ) |
|
| 95 |
- )+ #' |
||
| 96 |
-
+ #' @export |
||
| 97 | -2x | +
- plot_data_ord <- plot_data[order(plot_data$height, decreasing = TRUE), ]+ fit_rsp_step <- function(variables, |
|
| 98 |
-
+ data, |
||
| 99 | -2x | +
- p <- ggplot2::ggplot(plot_data_ord, ggplot2::aes(x = factor(id, levels = id), y = height)) ++ control = c(control_step(), control_logistic())) {
|
|
| 100 | -2x | +5x |
- ggplot2::geom_col() ++ assert_df_with_variables(data, variables) |
| 101 | -2x | +5x |
- ggplot2::geom_text(+ checkmate::assert_list(control, names = "named") |
| 102 | -2x | +5x |
- label = format(plot_data_ord$height, digits = 2),+ data <- data[!is.na(data[[variables$biomarker]]), ] |
| 103 | -2x | +5x |
- vjust = ifelse(plot_data_ord$height >= 0, -0.5, 1.5)+ window_sel <- h_step_window(x = data[[variables$biomarker]], control = control) |
| 104 | -+ | 5x |
- ) ++ interval_center <- window_sel$interval[, "Interval Center"] |
| 105 | -2x | +5x |
- ggplot2::xlab(xlab) ++ form <- h_step_rsp_formula(variables = variables, control = control) |
| 106 | -2x | +5x |
- ggplot2::ylab(ylab) ++ estimates <- if (is.null(control$bandwidth)) {
|
| 107 | -2x | +1x |
- ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 0, vjust = .5))+ h_step_rsp_est( |
| 108 | -+ | 1x |
-
+ formula = form, |
| 109 | -2x | +1x |
- if (!is.null(col_var)) {
+ data = data, |
| 110 | 1x |
- p <- p ++ variables = variables, |
|
| 111 | 1x |
- ggplot2::aes(fill = col_var) ++ x = interval_center, |
|
| 112 | 1x |
- ggplot2::labs(fill = col_legend_title) ++ control = control |
|
| 113 | -1x | +
- ggplot2::theme(+ ) |
|
| 114 | -1x | +
- legend.position = "bottom",+ } else {
|
|
| 115 | -1x | +4x |
- legend.background = ggplot2::element_blank(),+ tmp <- mapply( |
| 116 | -1x | +4x |
- legend.title = ggplot2::element_text(face = "bold"),+ FUN = h_step_rsp_est, |
| 117 | -1x | +4x |
- legend.box.background = ggplot2::element_rect(colour = "black")+ x = interval_center, |
| 118 | -+ | 4x |
- )+ subset = as.list(as.data.frame(window_sel$sel)), |
| 119 | -+ | 4x |
- }+ MoreArgs = list( |
| 120 | -+ | 4x |
-
+ formula = form, |
| 121 | -2x | +4x |
- if (!is.null(col)) {
+ data = data, |
| 122 | -1x | +4x |
- p <- p ++ variables = variables, |
| 123 | -1x | +4x |
- ggplot2::scale_fill_manual(values = col)+ control = control |
| 124 |
- }+ ) |
||
| 125 |
-
+ ) |
||
| 126 | -2x | +
- if (!is.null(title)) {
+ # Maybe we find a more elegant solution than this. |
|
| 127 | -1x | +4x |
- p <- p ++ rownames(tmp) <- c("n", "logor", "se", "ci_lower", "ci_upper")
|
| 128 | -1x | +4x |
- ggplot2::labs(title = title) ++ t(tmp) |
| 129 | -1x | +
- ggplot2::theme(plot.title = ggplot2::element_text(face = "bold"))+ } |
|
| 130 | -+ | 5x |
- }+ result <- cbind(window_sel$interval, estimates) |
| 131 | -+ | 5x |
-
+ structure( |
| 132 | -2x | +5x |
- p+ result, |
| 133 | +5x | +
+ class = c("step", "matrix"),
+ |
+ |
| 134 | +5x | +
+ variables = variables,+ |
+ |
| 135 | +5x | +
+ control = control+ |
+ |
| 136 | ++ |
+ )+ |
+ |
| 137 |
}@@ -174211,14 +172995,14 @@ tern coverage - 95.64% |
| 1 |
- #' Cox regression helper function for interactions+ #' Count specific values |
|||
| 5 |
- #' Test and estimate the effect of a treatment in interaction with a covariate.+ #' The analyze function [count_values()] creates a layout element to calculate counts of specific values within a |
|||
| 6 |
- #' The effect is estimated as the HR of the tested treatment for a given level+ #' variable of interest. |
|||
| 7 |
- #' of the covariate, in comparison to the treatment control.+ #' |
|||
| 8 |
- #'+ #' This function analyzes one or more variables of interest supplied as a vector to `vars`. Values to |
|||
| 9 |
- #' @inheritParams argument_convention+ #' count for variable(s) in `vars` can be given as a vector via the `values` argument. One row of |
|||
| 10 |
- #' @param x (`numeric` or `factor`)\cr the values of the covariate to be tested.+ #' counts will be generated for each variable. |
|||
| 11 |
- #' @param effect (`string`)\cr the name of the effect to be tested and estimated.+ #' |
|||
| 12 |
- #' @param covar (`string`)\cr the name of the covariate in the model.+ #' @inheritParams argument_convention |
|||
| 13 |
- #' @param mod (`coxph`)\cr the Cox regression model.+ #' @param values (`character`)\cr specific values that should be counted. |
|||
| 14 |
- #' @param label (`string`)\cr the label to be returned as `term_label`.+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_values")`
|
|||
| 15 |
- #' @param control (`list`)\cr a list of controls as returned by [control_coxreg()].+ #' to see available statistics for this function. |
|||
| 16 |
- #' @param ... see methods.+ #' |
|||
| 17 |
- #'+ #' @note |
|||
| 18 |
- #' @examples+ #' * For `factor` variables, `s_count_values` checks whether `values` are all included in the levels of `x` |
|||
| 19 |
- #' library(survival)+ #' and fails otherwise. |
|||
| 20 |
- #'+ #' * For `count_values()`, variable labels are shown when there is more than one element in `vars`, |
|||
| 21 |
- #' set.seed(1, kind = "Mersenne-Twister")+ #' otherwise they are hidden. |
|||
| 23 |
- #' # Testing dataset [survival::bladder].+ #' @name count_values |
|||
| 24 |
- #' dta_bladder <- with(+ #' @order 1 |
|||
| 25 |
- #' data = bladder[bladder$enum < 5, ],+ NULL |
|||
| 26 |
- #' data.frame(+ |
|||
| 27 |
- #' time = stop,+ #' @describeIn count_values S3 generic function to count values. |
|||
| 28 |
- #' status = event,+ #' |
|||
| 29 |
- #' armcd = as.factor(rx),+ #' @inheritParams s_summary.logical |
|||
| 30 |
- #' covar1 = as.factor(enum),+ #' |
|||
| 31 |
- #' covar2 = factor(+ #' @return |
|||
| 32 |
- #' sample(as.factor(enum)),+ #' * `s_count_values()` returns output of [s_summary()] for specified values of a non-numeric variable. |
|||
| 33 |
- #' levels = 1:4,+ #' |
|||
| 34 |
- #' labels = c("F", "F", "M", "M")
+ #' @export |
|||
| 35 |
- #' )+ s_count_values <- function(x, |
|||
| 36 |
- #' )+ values, |
|||
| 37 |
- #' )+ na.rm = TRUE, # nolint |
|||
| 38 |
- #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
+ .N_col, # nolint |
|||
| 39 |
- #' formatters::var_labels(dta_bladder)[names(labels)] <- labels+ .N_row, # nolint |
|||
| 40 |
- #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ denom = c("n", "N_row", "N_col")) {
|
|||
| 41 | -+ | 175x |
- #'+ UseMethod("s_count_values", x)
|
|
| 42 |
- #' plot(+ } |
|||
| 43 |
- #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder),+ |
|||
| 44 |
- #' lty = 2:4,+ #' @describeIn count_values Method for `character` class. |
|||
| 45 |
- #' xlab = "Months",+ #' |
|||
| 46 |
- #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
+ #' @method s_count_values character |
|||
| 47 |
- #' )+ #' |
|||
| 48 |
- #'+ #' @examples |
|||
| 49 |
- #' @name cox_regression_inter+ #' # `s_count_values.character` |
|||
| 50 |
- NULL+ #' s_count_values(x = c("a", "b", "a"), values = "a")
|
|||
| 51 |
-
+ #' s_count_values(x = c("a", "b", "a", NA, NA), values = "b", na.rm = FALSE)
|
|||
| 52 |
- #' @describeIn cox_regression_inter S3 generic helper function to determine interaction effect.+ #' |
|||
| 53 |
- #'+ #' @export |
|||
| 54 |
- #' @return+ s_count_values.character <- function(x, |
|||
| 55 |
- #' * `h_coxreg_inter_effect()` returns a `data.frame` of covariate interaction effects consisting of the following+ values = "Y", |
|||
| 56 |
- #' variables: `effect`, `term`, `term_label`, `level`, `n`, `hr`, `lcl`, `ucl`, `pval`, and `pval_inter`.+ na.rm = TRUE, # nolint |
|||
| 57 |
- #'+ ...) {
|
|||
| 58 | -+ | 173x |
- #' @export+ checkmate::assert_character(values) |
|
| 59 |
- h_coxreg_inter_effect <- function(x,+ |
|||
| 60 | -+ | 173x |
- effect,+ if (na.rm) {
|
|
| 61 | -+ | 172x |
- covar,+ x <- x[!is.na(x)] |
|
| 62 |
- mod,+ } |
|||
| 63 |
- label,+ |
|||
| 64 | -+ | 173x |
- control,+ is_in_values <- x %in% values |
|
| 65 |
- ...) {
+
|
|||
| 66 | -29x | +173x |
- UseMethod("h_coxreg_inter_effect", x)
+ s_summary(is_in_values, ...) |
|
| 69 |
- #' @describeIn cox_regression_inter Method for `numeric` class. Estimates the interaction with a `numeric` covariate.+ #' @describeIn count_values Method for `factor` class. This makes an automatic |
|||
| 70 |
- #'+ #' conversion to `character` and then forwards to the method for characters. |
|||
| 71 |
- #' @method h_coxreg_inter_effect numeric+ #' |
|||
| 72 |
- #'+ #' @method s_count_values factor |
|||
| 73 |
- #' @param at (`list`)\cr a list with items named after the covariate, every+ #' |
|||
| 74 |
- #' item is a vector of levels at which the interaction should be estimated.+ #' @examples |
|||
| 75 |
- #'+ #' # `s_count_values.factor` |
|||
| 76 |
- #' @export+ #' s_count_values(x = factor(c("a", "b", "a")), values = "a")
|
|||
| 77 |
- h_coxreg_inter_effect.numeric <- function(x,+ #' |
|||
| 78 |
- effect,+ #' @export |
|||
| 79 |
- covar,+ s_count_values.factor <- function(x, |
|||
| 80 |
- mod,+ values = "Y", |
|||
| 81 |
- label,+ ...) {
|
|||
| 82 | -+ | 3x |
- control,+ s_count_values(as.character(x), values = as.character(values), ...) |
|
| 83 |
- at,+ } |
|||
| 84 |
- ...) {
+
|
|||
| 85 | -7x | +
- betas <- stats::coef(mod)+ #' @describeIn count_values Method for `logical` class. |
||
| 86 | -7x | +
- attrs <- attr(stats::terms(mod), "term.labels")+ #' |
||
| 87 | -7x | +
- term_indices <- grep(+ #' @method s_count_values logical |
||
| 88 | -7x | +
- pattern = effect,+ #' |
||
| 89 | -7x | +
- x = attrs[!grepl("strata\\(", attrs)]
+ #' @examples |
||
| 90 |
- )+ #' # `s_count_values.logical` |
|||
| 91 | -7x | +
- checkmate::assert_vector(term_indices, len = 2)+ #' s_count_values(x = c(TRUE, FALSE, TRUE)) |
||
| 92 | -7x | +
- betas <- betas[term_indices]+ #' |
||
| 93 | -7x | +
- betas_var <- diag(stats::vcov(mod))[term_indices]+ #' @export |
||
| 94 | -7x | +
- betas_cov <- stats::vcov(mod)[term_indices[1], term_indices[2]]+ s_count_values.logical <- function(x, values = TRUE, ...) {
|
||
| 95 | -7x | +3x |
- xval <- if (is.null(at[[covar]])) {
+ checkmate::assert_logical(values) |
|
| 96 | -6x | +3x |
- stats::median(x)+ s_count_values(as.character(x), values = as.character(values), ...) |
|
| 97 |
- } else {
+ } |
|||
| 98 | -1x | +
- at[[covar]]+ |
||
| 99 |
- }+ #' @describeIn count_values Formatted analysis function which is used as `afun` |
|||
| 100 | -7x | +
- effect_index <- !grepl(covar, names(betas))+ #' in `count_values()`. |
||
| 101 | -7x | +
- coef_hat <- betas[effect_index] + xval * betas[!effect_index]+ #' |
||
| 102 | -7x | +
- coef_se <- sqrt(+ #' @return |
||
| 103 | -7x | +
- betas_var[effect_index] ++ #' * `a_count_values()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 104 | -7x | +
- xval ^ 2 * betas_var[!effect_index] + # styler: off+ #' |
||
| 105 | -7x | +
- 2 * xval * betas_cov+ #' @examples |
||
| 106 | + |
+ #' # `a_count_values`+ |
+ ||
| 107 | ++ |
+ #' a_count_values(x = factor(c("a", "b", "a")), values = "a", .N_col = 10, .N_row = 10)
+ |
+ ||
| 108 | ++ |
+ #'+ |
+ ||
| 109 | ++ |
+ #' @export+ |
+ ||
| 110 | ++ |
+ a_count_values <- make_afun(+ |
+ ||
| 111 | ++ |
+ s_count_values,+ |
+ ||
| 112 | ++ |
+ .formats = c(count_fraction = "xx (xx.xx%)", count = "xx")+ |
+ ||
| 113 | ++ |
+ )+ |
+ ||
| 114 | ++ | + + | +||
| 115 | ++ |
+ #' @describeIn count_values Layout-creating function which can take statistics function arguments+ |
+ ||
| 116 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+ ||
| 117 | ++ |
+ #'+ |
+ ||
| 118 | ++ |
+ #' @return+ |
+ ||
| 119 | ++ |
+ #' * `count_values()` 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+ |
+ ||
| 121 | ++ |
+ #' the statistics from `s_count_values()` to the table layout.+ |
+ ||
| 122 | ++ |
+ #'+ |
+ ||
| 123 | ++ |
+ #' @examples+ |
+ ||
| 124 | ++ |
+ #' # `count_values`+ |
+ ||
| 125 | ++ |
+ #' basic_table() %>%+ |
+ ||
| 126 | ++ |
+ #' count_values("Species", values = "setosa") %>%
+ |
+ ||
| 127 | ++ |
+ #' build_table(iris)+ |
+ ||
| 128 | ++ |
+ #'+ |
+ ||
| 129 | ++ |
+ #' @export+ |
+ ||
| 130 | ++ |
+ #' @order 2+ |
+ ||
| 131 | ++ |
+ count_values <- function(lyt,+ |
+ ||
| 132 | ++ |
+ vars,+ |
+ ||
| 133 | ++ |
+ values,+ |
+ ||
| 134 | ++ |
+ na_str = default_na_str(),+ |
+ ||
| 135 | ++ |
+ nested = TRUE,+ |
+ ||
| 136 | ++ |
+ ...,+ |
+ ||
| 137 | ++ |
+ table_names = vars,+ |
+ ||
| 138 | ++ |
+ .stats = "count_fraction",+ |
+ ||
| 139 | ++ |
+ .formats = NULL,+ |
+ ||
| 140 | ++ |
+ .labels = c(count_fraction = paste(values, collapse = ", ")),+ |
+ ||
| 141 | ++ |
+ .indent_mods = NULL) {
+ |
+ ||
| 142 | +3x | +
+ extra_args <- list(values = values, ...)+ |
+ ||
| 143 | ++ | + + | +||
| 144 | +3x | +
+ afun <- make_afun(+ |
+ ||
| 145 | +3x | +
+ a_count_values,+ |
+ ||
| 146 | +3x | +
+ .stats = .stats,+ |
+ ||
| 147 | +3x | +
+ .formats = .formats,+ |
+ ||
| 148 | +3x | +
+ .labels = .labels,+ |
+ ||
| 149 | +3x | +
+ .indent_mods = .indent_mods+ |
+ ||
| 150 | +
) |
|||
| 107 | -7x | +151 | +3x |
- q_norm <- stats::qnorm((1 + control$conf_level) / 2)+ analyze(+ |
+
| 152 | +3x | +
+ lyt,+ |
+ ||
| 153 | +3x | +
+ vars,+ |
+ ||
| 154 | +3x | +
+ afun = afun,+ |
+ ||
| 155 | +3x | +
+ na_str = na_str,+ |
+ ||
| 156 | +3x | +
+ nested = nested, |
||
| 108 | -7x | +157 | +3x |
- data.frame(+ extra_args = extra_args, |
| 109 | -7x | +158 | +3x |
- effect = "Covariate:",+ show_labels = ifelse(length(vars) > 1, "visible", "hidden"), |
| 110 | -7x | +159 | +3x |
- term = rep(covar, length(xval)),+ table_names = table_names |
| 111 | -7x | +|||
| 160 | +
- term_label = paste0(" ", xval),
+ ) |
|||
| 112 | -7x | +|||
| 161 | +
- level = as.character(xval),+ } |
|||
| 113 | -7x | +
| 1 | +
- n = NA,+ #' Horizontal waterfall plot |
|||
| 114 | -7x | +|||
| 2 | +
- hr = exp(coef_hat),+ #' |
|||
| 115 | -7x | +|||
| 3 | +
- lcl = exp(coef_hat - q_norm * coef_se),+ #' @description `r lifecycle::badge("stable")`
|
|||
| 116 | -7x | +|||
| 4 | +
- ucl = exp(coef_hat + q_norm * coef_se),+ #' |
|||
| 117 | -7x | +|||
| 5 | +
- pval = NA,+ #' This basic waterfall plot visualizes a quantity `height` ordered by value with some markup. |
|||
| 118 | -7x | +|||
| 6 | +
- pval_inter = NA,+ #' |
|||
| 119 | -7x | +|||
| 7 | +
- stringsAsFactors = FALSE+ #' @param height (`numeric`)\cr vector containing values to be plotted as the waterfall bars. |
|||
| 120 | +8 |
- )+ #' @param id (`character`)\cr vector containing identifiers to use as the x-axis label for the waterfall bars. |
||
| 121 | +9 |
- }+ #' @param col (`character`)\cr color(s). |
||
| 122 | +10 |
-
+ #' @param col_var (`factor`, `character`, or `NULL`)\cr categorical variable for bar coloring. `NULL` by default. |
||
| 123 | +11 |
- #' @describeIn cox_regression_inter Method for `factor` class. Estimate the interaction with a `factor` covariate.+ #' @param xlab (`string`)\cr x label. Default is `"ID"`. |
||
| 124 | +12 |
- #'+ #' @param ylab (`string`)\cr y label. Default is `"Value"`. |
||
| 125 | +13 |
- #' @method h_coxreg_inter_effect factor+ #' @param title (`string`)\cr text to be displayed as plot title. |
||
| 126 | +14 | ++ |
+ #' @param col_legend_title (`string`)\cr text to be displayed as legend title.+ |
+ |
| 15 |
#' |
|||
| 127 | +16 |
- #' @param data (`data.frame`)\cr the data frame on which the model was fit.+ #' @return A `ggplot` waterfall plot. |
||
| 128 | +17 |
#' |
||
| 129 | +18 |
- #' @export+ #' @examples |
||
| 130 | +19 |
- h_coxreg_inter_effect.factor <- function(x,+ #' library(dplyr) |
||
| 131 | +20 |
- effect,+ #' library(nestcolor) |
||
| 132 | +21 |
- covar,+ #' |
||
| 133 | +22 |
- mod,+ #' g_waterfall(height = c(3, 5, -1), id = letters[1:3]) |
||
| 134 | +23 |
- label,+ #' |
||
| 135 | +24 |
- control,+ #' g_waterfall( |
||
| 136 | +25 |
- data,+ #' height = c(3, 5, -1), |
||
| 137 | +26 |
- ...) {
+ #' id = letters[1:3], |
||
| 138 | -17x | +|||
| 27 | +
- lvl_given <- levels(x)+ #' col_var = letters[1:3] |
|||
| 139 | -17x | +|||
| 28 | +
- y <- h_coxreg_inter_estimations(+ #' ) |
|||
| 140 | -17x | +|||
| 29 | +
- variable = effect, given = covar,+ #' |
|||
| 141 | -17x | +|||
| 30 | +
- lvl_var = levels(data[[effect]]),+ #' adsl_f <- tern_ex_adsl %>% |
|||
| 142 | -17x | +|||
| 31 | +
- lvl_given = lvl_given,+ #' select(USUBJID, STUDYID, ARM, ARMCD, SEX) |
|||
| 143 | -17x | +|||
| 32 | +
- mod = mod,+ #' |
|||
| 144 | -17x | +|||
| 33 | +
- conf_level = 0.95+ #' adrs_f <- tern_ex_adrs %>% |
|||
| 145 | -17x | +|||
| 34 | +
- )[[1]]+ #' filter(PARAMCD == "OVRINV") %>% |
|||
| 146 | +35 |
-
+ #' mutate(pchg = rnorm(n(), 10, 50)) |
||
| 147 | -17x | +|||
| 36 | +
- data.frame(+ #' |
|||
| 148 | -17x | +|||
| 37 | +
- effect = "Covariate:",+ #' adrs_f <- head(adrs_f, 30) |
|||
| 149 | -17x | +|||
| 38 | +
- term = rep(covar, nrow(y)),+ #' adrs_f <- adrs_f[!duplicated(adrs_f$USUBJID), ] |
|||
| 150 | -17x | +|||
| 39 | +
- term_label = paste0(" ", lvl_given),
+ #' head(adrs_f) |
|||
| 151 | -17x | +|||
| 40 | +
- level = lvl_given,+ #' |
|||
| 152 | -17x | +|||
| 41 | +
- n = NA,+ #' g_waterfall( |
|||
| 153 | -17x | +|||
| 42 | +
- hr = y[, "hr"],+ #' height = adrs_f$pchg, |
|||
| 154 | -17x | +|||
| 43 | +
- lcl = y[, "lcl"],+ #' id = adrs_f$USUBJID, |
|||
| 155 | -17x | +|||
| 44 | +
- ucl = y[, "ucl"],+ #' col_var = adrs_f$AVALC |
|||
| 156 | -17x | +|||
| 45 | +
- pval = NA,+ #' ) |
|||
| 157 | -17x | +|||
| 46 | +
- pval_inter = NA,+ #' |
|||
| 158 | -17x | +|||
| 47 | +
- stringsAsFactors = FALSE+ #' g_waterfall( |
|||
| 159 | +48 |
- )+ #' height = adrs_f$pchg, |
||
| 160 | +49 |
- }+ #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
|
||
| 161 | +50 |
-
+ #' col_var = adrs_f$SEX |
||
| 162 | +51 |
- #' @describeIn cox_regression_inter Method for `character` class. Estimate the interaction with a `character` covariate.+ #' ) |
||
| 163 | +52 |
- #' This makes an automatic conversion to `factor` and then forwards to the method for factors.+ #' |
||
| 164 | +53 |
- #'+ #' g_waterfall( |
||
| 165 | +54 |
- #' @method h_coxreg_inter_effect character+ #' height = adrs_f$pchg, |
||
| 166 | +55 |
- #'+ #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
|
||
| 167 | +56 |
- #' @note+ #' xlab = "ID", |
||
| 168 | +57 |
- #' * Automatic conversion of character to factor does not guarantee results can be generated correctly. It is+ #' ylab = "Percentage Change", |
||
| 169 | +58 |
- #' therefore better to always pre-process the dataset such that factors are manually created from character+ #' title = "Waterfall plot" |
||
| 170 | +59 |
- #' variables before passing the dataset to [rtables::build_table()].+ #' ) |
||
| 171 | +60 |
#' |
||
| 172 | +61 |
#' @export |
||
| 173 | +62 |
- h_coxreg_inter_effect.character <- function(x,+ g_waterfall <- function(height, |
||
| 174 | +63 |
- effect,+ id, |
||
| 175 | +64 |
- covar,+ col_var = NULL, |
||
| 176 | +65 |
- mod,+ col = getOption("ggplot2.discrete.colour"),
|
||
| 177 | +66 |
- label,+ xlab = NULL, |
||
| 178 | +67 |
- control,+ ylab = NULL, |
||
| 179 | +68 |
- data,+ col_legend_title = NULL, |
||
| 180 | +69 |
- ...) {
+ title = NULL) {
|
||
| 181 | -5x | +70 | +2x |
- y <- as.factor(x)+ if (!is.null(col_var)) {
+ |
+
| 71 | +1x | +
+ check_same_n(height = height, id = id, col_var = col_var) |
||
| 182 | +72 |
-
+ } else {
|
||
| 183 | -5x | +73 | +1x |
- h_coxreg_inter_effect(+ check_same_n(height = height, id = id) |
| 184 | -5x | +|||
| 74 | +
- x = y,+ } |
|||
| 185 | -5x | +|||
| 75 | +
- effect = effect,+ |
|||
| 186 | -5x | +76 | +2x |
- covar = covar,+ checkmate::assert_multi_class(col_var, c("character", "factor"), null.ok = TRUE)
|
| 187 | -5x | +77 | +2x |
- mod = mod,+ checkmate::assert_character(col, null.ok = TRUE) |
| 188 | -5x | +|||
| 78 | +
- label = label,+ |
|||
| 189 | -5x | +79 | +2x |
- control = control,+ xlabel <- deparse(substitute(id)) |
| 190 | -5x | +80 | +2x |
- data = data,+ ylabel <- deparse(substitute(height)) |
| 191 | +81 |
- ...+ |
||
| 192 | -+ | |||
| 82 | +2x |
- )+ col_label <- if (!missing(col_var)) {
+ |
+ ||
| 83 | +1x | +
+ deparse(substitute(col_var)) |
||
| 193 | +84 |
- }+ } |
||
| 194 | +85 | |||
| 195 | -+ | |||
| 86 | +2x |
- #' @describeIn cox_regression_inter A higher level function to get+ xlab <- if (is.null(xlab)) xlabel else xlab |
||
| 196 | -+ | |||
| 87 | +2x |
- #' the results of the interaction test and the estimated values.+ ylab <- if (is.null(ylab)) ylabel else ylab |
||
| 197 | -+ | |||
| 88 | +2x |
- #'+ col_legend_title <- if (is.null(col_legend_title)) col_label else col_legend_title |
||
| 198 | +89 |
- #' @return+ |
||
| 199 | -+ | |||
| 90 | +2x |
- #' * `h_coxreg_extract_interaction()` returns the result of an interaction test and the estimated values. If+ plot_data <- data.frame( |
||
| 200 | -+ | |||
| 91 | +2x |
- #' no interaction, [h_coxreg_univar_extract()] is applied instead.+ height = height, |
||
| 201 | -+ | |||
| 92 | +2x |
- #'+ id = as.character(id), |
||
| 202 | -+ | |||
| 93 | +2x |
- #' @examples+ col_var = if (is.null(col_var)) "x" else to_n(col_var, length(height)), |
||
| 203 | -+ | |||
| 94 | +2x |
- #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder)+ stringsAsFactors = FALSE |
||
| 204 | +95 |
- #' h_coxreg_extract_interaction(+ ) |
||
| 205 | +96 |
- #' mod = mod, effect = "armcd", covar = "covar1", data = dta_bladder,+ |
||
| 206 | -+ | |||
| 97 | +2x |
- #' control = control_coxreg()+ plot_data_ord <- plot_data[order(plot_data$height, decreasing = TRUE), ] |
||
| 207 | +98 |
- #' )+ |
||
| 208 | -+ | |||
| 99 | +2x |
- #'+ p <- ggplot2::ggplot(plot_data_ord, ggplot2::aes(x = factor(id, levels = id), y = height)) + |
||
| 209 | -+ | |||
| 100 | +2x |
- #' @export+ ggplot2::geom_col() + |
||
| 210 | -+ | |||
| 101 | +2x |
- h_coxreg_extract_interaction <- function(effect,+ ggplot2::geom_text( |
||
| 211 | -+ | |||
| 102 | +2x |
- covar,+ label = format(plot_data_ord$height, digits = 2), |
||
| 212 | -+ | |||
| 103 | +2x |
- mod,+ vjust = ifelse(plot_data_ord$height >= 0, -0.5, 1.5) |
||
| 213 | +104 |
- data,+ ) + |
||
| 214 | -+ | |||
| 105 | +2x |
- at,+ ggplot2::xlab(xlab) ++ |
+ ||
| 106 | +2x | +
+ ggplot2::ylab(ylab) ++ |
+ ||
| 107 | +2x | +
+ ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 0, vjust = .5)) |
||
| 215 | +108 |
- control) {
+
|
||
| 216 | -31x | +109 | +2x |
- if (!any(attr(stats::terms(mod), "order") == 2)) {
+ if (!is.null(col_var)) {
|
| 217 | -12x | +110 | +1x |
- y <- h_coxreg_univar_extract(+ p <- p + |
| 218 | -12x | +111 | +1x |
- effect = effect, covar = covar, mod = mod, data = data, control = control+ ggplot2::aes(fill = col_var) + |
| 219 | -+ | |||
| 112 | +1x |
- )+ ggplot2::labs(fill = col_legend_title) + |
||
| 220 | -12x | +113 | +1x |
- y$pval_inter <- NA+ ggplot2::theme( |
| 221 | -12x | +114 | +1x |
- y+ legend.position = "bottom", |
| 222 | -+ | |||
| 115 | +1x |
- } else {
+ legend.background = ggplot2::element_blank(), |
||
| 223 | -19x | +116 | +1x |
- test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]+ legend.title = ggplot2::element_text(face = "bold"),+ |
+
| 117 | +1x | +
+ legend.box.background = ggplot2::element_rect(colour = "black") |
||
| 224 | +118 |
-
+ ) |
||
| 225 | +119 |
- # Test the main treatment effect.+ }+ |
+ ||
| 120 | ++ | + | ||
| 226 | -19x | +121 | +2x |
- mod_aov <- muffled_car_anova(mod, test_statistic)+ if (!is.null(col)) {
|
| 227 | -19x | +122 | +1x |
- sum_anova <- broom::tidy(mod_aov)+ p <- p + |
| 228 | -19x | +123 | +1x |
- pval <- sum_anova[sum_anova$term == effect, ][["p.value"]]+ ggplot2::scale_fill_manual(values = col) |
| 229 | +124 |
-
+ } |
||
| 230 | +125 |
- # Test the interaction effect.+ |
||
| 231 | -19x | +126 | +2x |
- pval_inter <- sum_anova[grep(":", sum_anova$term), ][["p.value"]]
+ if (!is.null(title)) {
|
| 232 | -19x | +127 | +1x |
- covar_test <- data.frame(+ p <- p + |
| 233 | -19x | +128 | +1x |
- effect = "Covariate:",+ ggplot2::labs(title = title) + |
| 234 | -19x | +129 | +1x |
- term = covar,+ ggplot2::theme(plot.title = ggplot2::element_text(face = "bold")) |
| 235 | -19x | +|||
| 130 | +
- term_label = unname(labels_or_names(data[covar])),+ } |
|||
| 236 | -19x | +|||
| 131 | +
- level = "",+ |
|||
| 237 | -19x | +132 | +2x |
- n = mod$n, hr = NA, lcl = NA, ucl = NA, pval = pval,+ p |
| 238 | -19x | +|||
| 133 | +
- pval_inter = pval_inter,+ } |
|||
| 239 | -19x | +
| 1 | +
- stringsAsFactors = FALSE+ #' Count patients with toxicity grades that have worsened from baseline by highest grade post-baseline |
|||
| 240 | +2 |
- )+ #' |
||
| 241 | +3 |
- # Estimate the interaction.+ #' @description `r lifecycle::badge("stable")`
|
||
| 242 | -19x | +|||
| 4 | +
- y <- h_coxreg_inter_effect(+ #' |
|||
| 243 | -19x | +|||
| 5 | +
- data[[covar]],+ #' The analyze function [count_abnormal_lab_worsen_by_baseline()] creates a layout element to count patients with |
|||
| 244 | -19x | +|||
| 6 | +
- covar = covar,+ #' analysis toxicity grades which have worsened from baseline, categorized by highest (worst) grade post-baseline. |
|||
| 245 | -19x | +|||
| 7 | +
- effect = effect,+ #' |
|||
| 246 | -19x | +|||
| 8 | +
- mod = mod,+ #' This function analyzes primary analysis variable `var` which indicates analysis toxicity grades. Additional |
|||
| 247 | -19x | +|||
| 9 | +
- label = unname(labels_or_names(data[covar])),+ #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to `USUBJID`), |
|||
| 248 | -19x | +|||
| 10 | +
- at = at,+ #' a variable to indicate unique subject identifiers, `baseline_var` (defaults to `BTOXGR`), a variable to indicate |
|||
| 249 | -19x | +|||
| 11 | +
- control = control,+ #' baseline toxicity grades, and `direction_var` (defaults to `GRADDIR`), a variable to indicate toxicity grade |
|||
| 250 | -19x | +|||
| 12 | +
- data = data+ #' directions of interest to include (e.g. `"H"` (high), `"L"` (low), or `"B"` (both)). |
|||
| 251 | +13 |
- )+ #' |
||
| 252 | -19x | +|||
| 14 | +
- rbind(covar_test, y)+ #' For the direction(s) specified in `direction_var`, patient counts by worst grade for patients who have |
|||
| 253 | +15 |
- }+ #' worsened from baseline are calculated as follows: |
||
| 254 | +16 |
- }+ #' * `1` to `4`: The number of patients who have worsened from their baseline grades with worst |
||
| 255 | +17 |
-
+ #' grades 1-4, respectively. |
||
| 256 | +18 |
- #' @describeIn cox_regression_inter Hazard ratio estimation in interactions.+ #' * `Any`: The total number of patients who have worsened from their baseline grades. |
||
| 257 | +19 |
#' |
||
| 258 | +20 |
- #' @param variable,given (`string`)\cr the name of variables in interaction. We seek the estimation+ #' Fractions are calculated by dividing the above counts by the number of patients who's analysis toxicity grades |
||
| 259 | +21 |
- #' of the levels of `variable` given the levels of `given`.+ #' have worsened from baseline toxicity grades during treatment. |
||
| 260 | +22 |
- #' @param lvl_var,lvl_given (`character`)\cr corresponding levels as given by [levels()].+ #' |
||
| 261 | +23 |
- #' @param mod (`coxph`)\cr a fitted Cox regression model (see [survival::coxph()]).+ #' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create a row |
||
| 262 | +24 | ++ |
+ #' split on variable `direction_var`.+ |
+ |
| 25 |
#' |
|||
| 263 | +26 |
- #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A)+ #' @inheritParams argument_convention |
||
| 264 | +27 |
- #' and Sex (F, M; reference Female) and the model being abbreviated: y ~ Arm + Sex + Arm:Sex.+ #' @param variables (named `list` of `string`)\cr list of additional analysis variables including: |
||
| 265 | +28 |
- #' The cox regression estimates the coefficients along with a variance-covariance matrix for:+ #' * `id` (`string`)\cr subject variable name. |
||
| 266 | +29 |
- #'+ #' * `baseline_var` (`string`)\cr name of the data column containing baseline toxicity variable. |
||
| 267 | +30 |
- #' - b1 (arm b), b2 (arm c)+ #' * `direction_var` (`string`)\cr see `direction_var` for more details. |
||
| 268 | +31 |
- #' - b3 (sex m)+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal_by_worst_grade_worsen")`
|
||
| 269 | +32 |
- #' - b4 (arm b: sex m), b5 (arm c: sex m)+ #' to see all available statistics.+ |
+ ||
| 33 | ++ |
+ #'+ |
+ ||
| 34 | ++ |
+ #' @seealso Relevant helper functions [h_adlb_worsen()] and [h_worsen_counter()] which are used within+ |
+ ||
| 35 | ++ |
+ #' [s_count_abnormal_lab_worsen_by_baseline()] to process input data. |
||
| 270 | +36 |
#' |
||
| 271 | +37 |
- #' The estimation of the Hazard Ratio for arm C/sex M is given in reference+ #' @name abnormal_by_worst_grade_worsen |
||
| 272 | +38 |
- #' to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5).+ #' @order 1 |
||
| 273 | +39 |
- #' The interaction coefficient is deduced by b2 + b5 while the standard error+ NULL |
||
| 274 | +40 |
- #' is obtained as $sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$.+ |
||
| 275 | +41 |
- #'+ #' Helper function to prepare ADLB with worst labs |
||
| 276 | +42 |
- #' @return+ #' |
||
| 277 | +43 |
- #' * `h_coxreg_inter_estimations()` returns a list of matrices (one per level of variable) with rows corresponding+ #' @description `r lifecycle::badge("stable")`
|
||
| 278 | +44 |
- #' to the combinations of `variable` and `given`, with columns:+ #' |
||
| 279 | +45 |
- #' * `coef_hat`: Estimation of the coefficient.+ #' Helper function to prepare a `df` for generate the patient count shift table. |
||
| 280 | +46 |
- #' * `coef_se`: Standard error of the estimation.+ #' |
||
| 281 | +47 |
- #' * `hr`: Hazard ratio.+ #' @param adlb (`data.frame`)\cr ADLB data frame. |
||
| 282 | +48 |
- #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio.+ #' @param worst_flag_low (named `vector`)\cr worst low post-baseline lab grade flag variable. See how this is |
||
| 283 | +49 |
- #'+ #' implemented in the following examples. |
||
| 284 | +50 |
- #' @examples+ #' @param worst_flag_high (named `vector`)\cr worst high post-baseline lab grade flag variable. See how this is |
||
| 285 | +51 |
- #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder)+ #' implemented in the following examples. |
||
| 286 | +52 |
- #' result <- h_coxreg_inter_estimations(+ #' @param direction_var (`string`)\cr name of the direction variable specifying the direction of the shift table of |
||
| 287 | +53 |
- #' variable = "armcd", given = "covar1",+ #' interest. Only lab records flagged by `L`, `H` or `B` are included in the shift table. |
||
| 288 | +54 |
- #' lvl_var = levels(dta_bladder$armcd),+ #' * `L`: low direction only |
||
| 289 | +55 |
- #' lvl_given = levels(dta_bladder$covar1),+ #' * `H`: high direction only |
||
| 290 | +56 |
- #' mod = mod, conf_level = .95+ #' * `B`: both low and high directions |
||
| 291 | +57 |
- #' )+ #' |
||
| 292 | +58 |
- #' result+ #' @return `h_adlb_worsen()` returns the `adlb` `data.frame` containing only the |
||
| 293 | +59 |
- #'+ #' worst labs specified according to `worst_flag_low` or `worst_flag_high` for the |
||
| 294 | +60 |
- #' @export+ #' direction specified according to `direction_var`. For instance, for a lab that is |
||
| 295 | +61 |
- h_coxreg_inter_estimations <- function(variable,+ #' needed for the low direction only, only records flagged by `worst_flag_low` are |
||
| 296 | +62 |
- given,+ #' selected. For a lab that is needed for both low and high directions, the worst |
||
| 297 | +63 |
- lvl_var,+ #' low records are selected for the low direction, and the worst high record are selected |
||
| 298 | +64 |
- lvl_given,+ #' for the high direction. |
||
| 299 | +65 |
- mod,+ #' |
||
| 300 | +66 |
- conf_level = 0.95) {
- |
- ||
| 301 | -18x | -
- var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level+ #' @seealso [abnormal_by_worst_grade_worsen] |
||
| 302 | -18x | +|||
| 67 | +
- giv_lvl <- paste0(given, lvl_given)+ #' |
|||
| 303 | -18x | +|||
| 68 | +
- design_mat <- expand.grid(variable = var_lvl, given = giv_lvl)+ #' @examples |
|||
| 304 | -18x | +|||
| 69 | +
- design_mat <- design_mat[order(design_mat$variable, design_mat$given), ]+ #' library(dplyr) |
|||
| 305 | -18x | +|||
| 70 | +
- design_mat <- within(+ #' |
|||
| 306 | -18x | +|||
| 71 | +
- data = design_mat,+ #' # The direction variable, GRADDR, is based on metadata |
|||
| 307 | -18x | +|||
| 72 | +
- expr = {
+ #' adlb <- tern_ex_adlb %>% |
|||
| 308 | -18x | +|||
| 73 | +
- inter <- paste0(variable, ":", given)+ #' mutate( |
|||
| 309 | -18x | +|||
| 74 | +
- rev_inter <- paste0(given, ":", variable)+ #' GRADDR = case_when( |
|||
| 310 | +75 |
- }+ #' PARAMCD == "ALT" ~ "B", |
||
| 311 | +76 |
- )+ #' PARAMCD == "CRP" ~ "L", |
||
| 312 | -18x | +|||
| 77 | +
- split_by_variable <- design_mat$variable+ #' PARAMCD == "IGA" ~ "H" |
|||
| 313 | -18x | +|||
| 78 | +
- interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/")+ #' ) |
|||
| 314 | +79 |
-
+ #' ) %>% |
||
| 315 | -18x | +|||
| 80 | +
- mmat <- stats::model.matrix(mod)[1, ]+ #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "") |
|||
| 316 | -18x | +|||
| 81 | +
- mmat[!mmat == 0] <- 0+ #' |
|||
| 317 | +82 |
-
+ #' df <- h_adlb_worsen( |
||
| 318 | -18x | +|||
| 83 | +
- design_mat <- apply(+ #' adlb, |
|||
| 319 | -18x | +|||
| 84 | +
- X = design_mat, MARGIN = 1, FUN = function(x) {
+ #' worst_flag_low = c("WGRLOFL" = "Y"),
|
|||
| 320 | -52x | +|||
| 85 | +
- mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1+ #' worst_flag_high = c("WGRHIFL" = "Y"),
|
|||
| 321 | -52x | +|||
| 86 | +
- mmat+ #' direction_var = "GRADDR" |
|||
| 322 | +87 |
- }+ #' ) |
||
| 323 | +88 |
- )+ #' |
||
| 324 | -18x | +|||
| 89 | +
- colnames(design_mat) <- interaction_names+ #' @export |
|||
| 325 | +90 |
-
+ h_adlb_worsen <- function(adlb, |
||
| 326 | -18x | +|||
| 91 | +
- coef <- stats::coef(mod)+ worst_flag_low = NULL, |
|||
| 327 | -18x | +|||
| 92 | +
- vcov <- stats::vcov(mod)+ worst_flag_high = NULL, |
|||
| 328 | -18x | +|||
| 93 | +
- betas <- as.matrix(coef)+ direction_var) {
|
|||
| 329 | -18x | +94 | +5x |
- coef_hat <- t(design_mat) %*% betas+ checkmate::assert_string(direction_var) |
| 330 | -18x | +95 | +5x |
- dimnames(coef_hat)[2] <- "coef"+ checkmate::assert_subset(as.character(unique(adlb[[direction_var]])), c("B", "L", "H"))
|
| 331 | -18x | +96 | +5x |
- coef_se <- apply(+ assert_df_with_variables(adlb, list("Col" = direction_var))
|
| 332 | -18x | +|||
| 97 | +
- design_mat, 2,+ |
|||
| 333 | -18x | +98 | +5x |
- function(x) {
+ if (any(unique(adlb[[direction_var]]) == "H")) {
|
| 334 | -52x | +99 | +4x |
- vcov_el <- as.logical(x)+ assert_df_with_variables(adlb, list("High" = names(worst_flag_high)))
|
| 335 | -52x | +|||
| 100 | +
- y <- vcov[vcov_el, vcov_el]+ } |
|||
| 336 | -52x | +|||
| 101 | +
- y <- sum(y)+ |
|||
| 337 | -52x | +102 | +5x |
- y <- sqrt(y)+ if (any(unique(adlb[[direction_var]]) == "L")) {
|
| 338 | -52x | +103 | +4x |
- return(y)+ assert_df_with_variables(adlb, list("Low" = names(worst_flag_low)))
|
| 339 | +104 |
- }+ } |
||
| 340 | +105 |
- )+ |
||
| 341 | -18x | +106 | +5x |
- q_norm <- stats::qnorm((1 + conf_level) / 2)+ if (any(unique(adlb[[direction_var]]) == "B")) {
|
| 342 | -18x | +107 | +3x |
- y <- cbind(coef_hat, `se(coef)` = coef_se)+ assert_df_with_variables( |
| 343 | -18x | +108 | +3x |
- y <- apply(y, 1, function(x) {
+ adlb, |
| 344 | -52x | +109 | +3x |
- x["hr"] <- exp(x["coef"])+ list( |
| 345 | -52x | +110 | +3x |
- x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"])+ "Low" = names(worst_flag_low), |
| 346 | -52x | +111 | +3x |
- x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"])+ "High" = names(worst_flag_high) |
| 347 | -52x | +|||
| 112 | +
- x+ ) |
|||
| 348 | +113 |
- })+ ) |
||
| 349 | -18x | +|||
| 114 | +
- y <- t(y)+ } |
|||
| 350 | -18x | +|||
| 115 | +
- y <- by(y, split_by_variable, identity)+ |
|||
| 351 | -18x | +|||
| 116 | +
- y <- lapply(y, as.matrix)+ # extract patients with worst post-baseline lab, either low or high or both |
|||
| 352 | -18x | +117 | +5x |
- attr(y, "details") <- paste0(+ worst_flag <- c(worst_flag_low, worst_flag_high) |
| 353 | -18x | +118 | +5x |
- "Estimations of ", variable,+ col_names <- names(worst_flag) |
| 354 | -18x | +119 | +5x |
- " hazard ratio given the level of ", given, " compared to ",+ filter_values <- worst_flag |
| 355 | -18x | -
- variable, " level ", lvl_var[1], "."- |
- ||
| 356 | -+ | 120 | +5x |
- )+ temp <- Map( |
| 357 | -18x | +121 | +5x |
- y+ function(x, y) which(adlb[[x]] == y), |
| 358 | -+ | |||
| 122 | +5x |
- }+ col_names, |
| 1 | -+ | |||
| 123 | +5x |
- #' Helper functions for tabulating biomarker effects on binary response by subgroup+ filter_values |
||
| 2 | +124 |
- #'+ ) |
||
| 3 | -+ | |||
| 125 | +5x |
- #' @description `r lifecycle::badge("stable")`
+ position_satisfy_filters <- Reduce(union, temp) |
||
| 4 | +126 |
- #'+ |
||
| 5 | +127 |
- #' Helper functions which are documented here separately to not confuse the user+ # select variables of interest |
||
| 6 | -+ | |||
| 128 | +5x |
- #' when reading about the user-facing functions.+ adlb_f <- adlb[position_satisfy_filters, ] |
||
| 7 | +129 |
- #'+ |
||
| 8 | +130 |
- #' @inheritParams response_biomarkers_subgroups+ # generate subsets for different directionality |
||
| 9 | -+ | |||
| 131 | +5x |
- #' @inheritParams extract_rsp_biomarkers+ adlb_f_h <- adlb_f[which(adlb_f[[direction_var]] == "H"), ] |
||
| 10 | -+ | |||
| 132 | +5x |
- #' @inheritParams argument_convention+ adlb_f_l <- adlb_f[which(adlb_f[[direction_var]] == "L"), ] |
||
| 11 | -+ | |||
| 133 | +5x |
- #'+ adlb_f_b <- adlb_f[which(adlb_f[[direction_var]] == "B"), ] |
||
| 12 | +134 |
- #' @examples+ |
||
| 13 | +135 |
- #' library(dplyr)+ # for labs requiring both high and low, data is duplicated and will be stacked on top of each other |
||
| 14 | -+ | |||
| 136 | +5x |
- #' library(forcats)+ adlb_f_b_h <- adlb_f_b |
||
| 15 | -+ | |||
| 137 | +5x |
- #'+ adlb_f_b_l <- adlb_f_b |
||
| 16 | +138 |
- #' adrs <- tern_ex_adrs+ |
||
| 17 | +139 |
- #' adrs_labels <- formatters::var_labels(adrs)+ # extract data with worst lab |
||
| 18 | -+ | |||
| 140 | +5x |
- #'+ if (!is.null(worst_flag_high) && !is.null(worst_flag_low)) {
|
||
| 19 | +141 |
- #' adrs_f <- adrs %>%+ # change H to High, L to Low |
||
| 20 | -+ | |||
| 142 | +3x |
- #' filter(PARAMCD == "BESRSPI") %>%+ adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
|
||
| 21 | -+ | |||
| 143 | +3x |
- #' mutate(rsp = AVALC == "CR")+ adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
|
||
| 22 | +144 |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ |
||
| 23 | +145 |
- #'+ # change, B to High and Low |
||
| 24 | -+ | |||
| 146 | +3x |
- #' @name h_response_biomarkers_subgroups+ adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
|
||
| 25 | -+ | |||
| 147 | +3x |
- NULL+ adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
|
||
| 26 | +148 | |||
| 27 | -- |
- #' @describeIn h_response_biomarkers_subgroups helps with converting the "response" function variable list- |
- ||
| 28 | -+ | |||
| 149 | +3x |
- #' to the "logistic regression" variable list. The reason is that currently there is an+ adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ] |
||
| 29 | -+ | |||
| 150 | +3x |
- #' inconsistency between the variable names accepted by `extract_rsp_subgroups()` and `fit_logistic()`.+ adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ] |
||
| 30 | -+ | |||
| 151 | +3x |
- #'+ adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ] |
||
| 31 | -+ | |||
| 152 | +3x |
- #' @param biomarker (`string`)\cr the name of the biomarker variable.+ adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ] |
||
| 32 | +153 |
- #'+ |
||
| 33 | -+ | |||
| 154 | +3x |
- #' @return+ out <- rbind(adlb_out_h, adlb_out_b_h, adlb_out_l, adlb_out_b_l) |
||
| 34 | -+ | |||
| 155 | +2x |
- #' * `h_rsp_to_logistic_variables()` returns a named `list` of elements `response`, `arm`, `covariates`, and `strata`.+ } else if (!is.null(worst_flag_high)) {
|
||
| 35 | -+ | |||
| 156 | +1x |
- #'+ adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
|
||
| 36 | -+ | |||
| 157 | +1x |
- #' @examples+ adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
|
||
| 37 | +158 |
- #' # This is how the variable list is converted internally.+ |
||
| 38 | -+ | |||
| 159 | +1x |
- #' h_rsp_to_logistic_variables(+ adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ] |
||
| 39 | -+ | |||
| 160 | +1x |
- #' variables = list(+ adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ] |
||
| 40 | +161 |
- #' rsp = "RSP",+ |
||
| 41 | -+ | |||
| 162 | +1x |
- #' covariates = c("A", "B"),
+ out <- rbind(adlb_out_h, adlb_out_b_h) |
||
| 42 | -+ | |||
| 163 | +1x |
- #' strata = "D"+ } else if (!is.null(worst_flag_low)) {
|
||
| 43 | -+ | |||
| 164 | +1x |
- #' ),+ adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
|
||
| 44 | -+ | |||
| 165 | +1x |
- #' biomarker = "AGE"+ adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
|
||
| 45 | +166 |
- #' )+ |
||
| 46 | -+ | |||
| 167 | +1x |
- #'+ adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ] |
||
| 47 | -+ | |||
| 168 | +1x |
- #' @export+ adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ] |
||
| 48 | +169 |
- h_rsp_to_logistic_variables <- function(variables, biomarker) {
+
|
||
| 49 | -49x | -
- if ("strat" %in% names(variables)) {
- |
- ||
| 50 | -! | -
- warning(- |
- ||
| 51 | -! | -
- "Warning: the `strat` element name of the `variables` list argument to `h_rsp_to_logistic_variables() ",- |
- ||
| 52 | -! | -
- "was deprecated in tern 0.9.4.\n ",- |
- ||
| 53 | -! | +170 | +1x |
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ out <- rbind(adlb_out_l, adlb_out_b_l) |
| 54 | +171 |
- )- |
- ||
| 55 | -! | -
- variables[["strata"]] <- variables[["strat"]]+ } |
||
| 56 | +172 |
- }+ |
||
| 57 | -49x | +|||
| 173 | +
- checkmate::assert_list(variables)+ # label |
|||
| 58 | -49x | +174 | +5x |
- checkmate::assert_string(variables$rsp)+ formatters::var_labels(out) <- formatters::var_labels(adlb_f, fill = FALSE) |
| 59 | -49x | +|||
| 175 | +
- checkmate::assert_string(biomarker)+ # NA |
|||
| 60 | -49x | +176 | +5x |
- list(+ out |
| 61 | -49x | +|||
| 177 | +
- response = variables$rsp,+ } |
|||
| 62 | -49x | +|||
| 178 | +
- arm = biomarker,+ |
|||
| 63 | -49x | +|||
| 179 | +
- covariates = variables$covariates,+ #' Helper function to analyze patients for `s_count_abnormal_lab_worsen_by_baseline()` |
|||
| 64 | -49x | +|||
| 180 | +
- strata = variables$strata+ #' |
|||
| 65 | +181 |
- )+ #' @description `r lifecycle::badge("stable")`
|
||
| 66 | +182 |
- }+ #' |
||
| 67 | +183 |
-
+ #' Helper function to count the number of patients and the fraction of patients according to |
||
| 68 | +184 |
- #' @describeIn h_response_biomarkers_subgroups prepares estimates for number of responses, patients and+ #' highest post-baseline lab grade variable `.var`, baseline lab grade variable `baseline_var`, |
||
| 69 | +185 |
- #' overall response rate, as well as odds ratio estimates, confidence intervals and p-values, for multiple+ #' and the direction of interest specified in `direction_var`. |
||
| 70 | +186 |
- #' biomarkers in a given single data set.+ #' |
||
| 71 | +187 |
- #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements+ #' @inheritParams argument_convention |
||
| 72 | +188 |
- #' `rsp` and `biomarkers` (vector of continuous biomarker variables) and optionally `covariates`+ #' @inheritParams h_adlb_worsen |
||
| 73 | +189 |
- #' and `strata`.+ #' @param baseline_var (`string`)\cr name of the baseline lab grade variable. |
||
| 74 | +190 |
#' |
||
| 75 | +191 |
- #' @return+ #' @return The counts and fraction of patients |
||
| 76 | +192 |
- #' * `h_logistic_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers.+ #' whose worst post-baseline lab grades are worse than their baseline grades, for |
||
| 77 | +193 |
- #'+ #' post-baseline worst grades "1", "2", "3", "4" and "Any". |
||
| 78 | +194 |
- #' @examples+ #' |
||
| 79 | +195 |
- #' # For a single population, estimate separately the effects+ #' @seealso [abnormal_by_worst_grade_worsen] |
||
| 80 | +196 |
- #' # of two biomarkers.+ #' |
||
| 81 | +197 |
- #' df <- h_logistic_mult_cont_df(+ #' @examples |
||
| 82 | +198 |
- #' variables = list(+ #' library(dplyr) |
||
| 83 | +199 |
- #' rsp = "rsp",+ #' |
||
| 84 | +200 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' # The direction variable, GRADDR, is based on metadata |
||
| 85 | +201 |
- #' covariates = "SEX"+ #' adlb <- tern_ex_adlb %>% |
||
| 86 | +202 |
- #' ),+ #' mutate( |
||
| 87 | +203 |
- #' data = adrs_f+ #' GRADDR = case_when( |
||
| 88 | +204 |
- #' )+ #' PARAMCD == "ALT" ~ "B", |
||
| 89 | +205 |
- #' df+ #' PARAMCD == "CRP" ~ "L", |
||
| 90 | +206 |
- #'+ #' PARAMCD == "IGA" ~ "H" |
||
| 91 | +207 |
- #' # If the data set is empty, still the corresponding rows with missings are returned.+ #' ) |
||
| 92 | +208 |
- #' h_coxreg_mult_cont_df(+ #' ) %>% |
||
| 93 | +209 |
- #' variables = list(+ #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "") |
||
| 94 | +210 |
- #' rsp = "rsp",+ #' |
||
| 95 | +211 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' df <- h_adlb_worsen( |
||
| 96 | +212 |
- #' covariates = "SEX",+ #' adlb, |
||
| 97 | +213 |
- #' strata = "STRATA1"+ #' worst_flag_low = c("WGRLOFL" = "Y"),
|
||
| 98 | +214 |
- #' ),+ #' worst_flag_high = c("WGRHIFL" = "Y"),
|
||
| 99 | +215 |
- #' data = adrs_f[NULL, ]+ #' direction_var = "GRADDR" |
||
| 100 | +216 |
#' ) |
||
| 101 | +217 |
#' |
||
| 102 | +218 |
- #' @export+ #' # `h_worsen_counter` |
||
| 103 | +219 |
- h_logistic_mult_cont_df <- function(variables,+ #' h_worsen_counter( |
||
| 104 | +220 |
- data,+ #' df %>% filter(PARAMCD == "CRP" & GRADDR == "Low"), |
||
| 105 | +221 |
- control = control_logistic()) {
- |
- ||
| 106 | -28x | -
- if ("strat" %in% names(variables)) {
+ #' id = "USUBJID", |
||
| 107 | -! | +|||
| 222 | +
- warning(+ #' .var = "ATOXGR", |
|||
| 108 | -! | +|||
| 223 | +
- "Warning: the `strat` element name of the `variables` list argument to `h_logistic_mult_cont_df() ",+ #' baseline_var = "BTOXGR", |
|||
| 109 | -! | +|||
| 224 | +
- "was deprecated in tern 0.9.4.\n ",+ #' direction_var = "GRADDR" |
|||
| 110 | -! | +|||
| 225 | +
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ #' ) |
|||
| 111 | +226 |
- )+ #' |
||
| 112 | -! | +|||
| 227 | +
- variables[["strata"]] <- variables[["strat"]]+ #' @export |
|||
| 113 | +228 |
- }+ h_worsen_counter <- function(df, id, .var, baseline_var, direction_var) {
|
||
| 114 | -28x | -
- assert_df_with_variables(data, variables)- |
- ||
| 115 | -+ | 229 | +17x |
-
+ checkmate::assert_string(id) |
| 116 | -28x | +230 | +17x |
- checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE)+ checkmate::assert_string(.var) |
| 117 | -28x | +231 | +17x |
- checkmate::assert_list(control, names = "named")+ checkmate::assert_string(baseline_var) |
| 118 | -+ | |||
| 232 | +17x |
-
+ checkmate::assert_scalar(unique(df[[direction_var]])) |
||
| 119 | -28x | +233 | +17x |
- conf_level <- control[["conf_level"]]+ checkmate::assert_subset(unique(df[[direction_var]]), c("High", "Low"))
|
| 120 | -28x | +234 | +17x |
- pval_label <- "p-value (Wald)"+ assert_df_with_variables(df, list(val = c(id, .var, baseline_var, direction_var))) |
| 121 | +235 | |||
| 122 | +236 |
- # If there is any data, run model, otherwise return empty results.+ # remove post-baseline missing |
||
| 123 | -28x | +237 | +17x |
- if (nrow(data) > 0) {
+ df <- df[df[[.var]] != "<Missing>", ] |
| 124 | -27x | +|||
| 238 | +
- bm_cols <- match(variables$biomarkers, names(data))+ |
|||
| 125 | -27x | +|||
| 239 | +
- l_result <- lapply(variables$biomarkers, function(bm) {
+ # obtain directionality |
|||
| 126 | -48x | +240 | +17x |
- model_fit <- fit_logistic(+ direction <- unique(df[[direction_var]]) |
| 127 | -48x | +|||
| 241 | +
- variables = h_rsp_to_logistic_variables(variables, bm),+ |
|||
| 128 | -48x | +242 | +17x |
- data = data,+ if (direction == "Low") {
|
| 129 | -48x | +243 | +10x |
- response_definition = control$response_definition+ grade <- -1:-4 |
| 130 | -+ | |||
| 244 | +10x |
- )+ worst_grade <- -4 |
||
| 131 | -48x | +245 | +7x |
- result <- h_logistic_simple_terms(+ } else if (direction == "High") {
|
| 132 | -48x | +246 | +7x |
- x = bm,+ grade <- 1:4 |
| 133 | -48x | +247 | +7x |
- fit_glm = model_fit,+ worst_grade <- 4 |
| 134 | -48x | +|||
| 248 | +
- conf_level = control$conf_level+ } |
|||
| 135 | +249 |
- )+ |
||
| 136 | -48x | +250 | +17x |
- resp_vector <- if (inherits(model_fit, "glm")) {
+ if (nrow(df) > 0) {
|
| 137 | -38x | +251 | +17x |
- model_fit$model[[variables$rsp]]+ by_grade <- lapply(grade, function(i) {
|
| 138 | +252 |
- } else {
+ # filter baseline values that is less than i or <Missing> |
||
| 139 | -10x | +253 | +68x |
- as.logical(as.matrix(model_fit$y)[, "status"])+ df_temp <- df[df[[baseline_var]] %in% c((i + sign(i) * -1):(-1 * worst_grade), "<Missing>"), ] |
| 140 | +254 |
- }+ # num: number of patients with post-baseline worst lab equal to i |
||
| 141 | -48x | +255 | +68x |
- data.frame(+ num <- length(unique(df_temp[df_temp[[.var]] %in% i, id, drop = TRUE])) |
| 142 | +256 |
- # Dummy column needed downstream to create a nested header.+ # denom: number of patients with baseline values less than i or <missing> and post-baseline in the same direction |
||
| 143 | -48x | +257 | +68x |
- biomarker = bm,+ denom <- length(unique(df_temp[[id]])) |
| 144 | -48x | +258 | +68x |
- biomarker_label = formatters::var_labels(data[bm], fill = TRUE),+ rm(df_temp) |
| 145 | -48x | +259 | +68x |
- n_tot = length(resp_vector),+ c(num = num, denom = denom) |
| 146 | -48x | +|||
| 260 | +
- n_rsp = sum(resp_vector),+ }) |
|||
| 147 | -48x | +|||
| 261 | +
- prop = mean(resp_vector),+ } else {
|
|||
| 148 | -48x | +|||
| 262 | +! |
- or = as.numeric(result[1L, "odds_ratio"]),+ by_grade <- lapply(1, function(i) {
|
||
| 149 | -48x | +|||
| 263 | +! |
- lcl = as.numeric(result[1L, "lcl"]),+ c(num = 0, denom = 0) |
||
| 150 | -48x | +|||
| 264 | +
- ucl = as.numeric(result[1L, "ucl"]),+ }) |
|||
| 151 | -48x | +|||
| 265 | +
- conf_level = conf_level,+ } |
|||
| 152 | -48x | +|||
| 266 | +
- pval = as.numeric(result[1L, "pvalue"]),+ |
|||
| 153 | -48x | +267 | +17x |
- pval_label = pval_label,+ names(by_grade) <- as.character(seq_along(by_grade))+ |
+
| 268 | ++ | + + | +||
| 269 | ++ |
+ # baseline grade less 4 or missing |
||
| 154 | -48x | +270 | +17x |
- stringsAsFactors = FALSE+ df_temp <- df[!df[[baseline_var]] %in% worst_grade, ] |
| 155 | +271 |
- )+ |
||
| 156 | +272 |
- })+ # denom: number of patients with baseline values less than 4 or <missing> and post-baseline in the same direction |
||
| 157 | -27x | +273 | +17x |
- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ denom <- length(unique(df_temp[, id, drop = TRUE])) |
| 158 | +274 |
- } else {
+
|
||
| 159 | -1x | +|||
| 275 | +
- data.frame(+ # condition 1: missing baseline and in the direction of abnormality |
|||
| 160 | -1x | +276 | +17x |
- biomarker = variables$biomarkers,+ con1 <- which(df_temp[[baseline_var]] == "<Missing>" & df_temp[[.var]] %in% grade) |
| 161 | -1x | +277 | +17x |
- biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE),+ df_temp_nm <- df_temp[which(df_temp[[baseline_var]] != "<Missing>" & df_temp[[.var]] %in% grade), ] |
| 162 | -1x | +|||
| 278 | +
- n_tot = 0L,+ |
|||
| 163 | -1x | +|||
| 279 | +
- n_rsp = 0L,+ # condition 2: if post-baseline values are present then post-baseline values must be worse than baseline |
|||
| 164 | -1x | +280 | +17x |
- prop = NA,+ if (direction == "Low") {
|
| 165 | -1x | +281 | +10x |
- or = NA,+ con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) < as.numeric(as.character(df_temp_nm[[baseline_var]]))) |
| 166 | -1x | +|||
| 282 | +
- lcl = NA,+ } else {
|
|||
| 167 | -1x | +283 | +7x |
- ucl = NA,+ con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) > as.numeric(as.character(df_temp_nm[[baseline_var]]))) |
| 168 | -1x | +|||
| 284 | +
- conf_level = conf_level,+ } |
|||
| 169 | -1x | +|||
| 285 | +
- pval = NA,+ |
|||
| 170 | -1x | +|||
| 286 | +
- pval_label = pval_label,+ # number of patients satisfy either conditions 1 or 2 |
|||
| 171 | -1x | +287 | +17x |
- row.names = seq_along(variables$biomarkers),+ num <- length(unique(df_temp[union(con1, con2), id, drop = TRUE]))+ |
+
| 288 | ++ | + | ||
| 172 | -1x | +289 | +17x |
- stringsAsFactors = FALSE+ list(fraction = c(by_grade, list("Any" = c(num = num, denom = denom))))
|
| 173 | +290 |
- )+ } |
||
| 174 | +291 |
- }+ |
||
| 175 | +292 |
- }+ #' @describeIn abnormal_by_worst_grade_worsen Statistics function for patients whose worst post-baseline |
||
| 176 | +293 |
-
+ #' lab grades are worse than their baseline grades. |
||
| 177 | +294 |
- #' @describeIn h_response_biomarkers_subgroups Prepares a single sub-table given a `df_sub` containing+ #' |
||
| 178 | +295 |
- #' the results for a single biomarker.+ #' @return |
||
| 179 | +296 |
- #'+ #' * `s_count_abnormal_lab_worsen_by_baseline()` returns the counts and fraction of patients whose worst |
||
| 180 | +297 |
- #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is+ #' post-baseline lab grades are worse than their baseline grades, for post-baseline worst grades |
||
| 181 | +298 |
- #' returned by [extract_rsp_biomarkers()] (it needs a couple of columns which are+ #' "1", "2", "3", "4" and "Any". |
||
| 182 | +299 |
- #' added by that high-level function relative to what is returned by [h_logistic_mult_cont_df()],+ #' |
||
| 183 | +300 |
- #' see the example).+ #' @keywords internal |
||
| 184 | +301 |
- #'+ s_count_abnormal_lab_worsen_by_baseline <- function(df, # nolint |
||
| 185 | +302 |
- #' @return+ .var = "ATOXGR", |
||
| 186 | +303 |
- #' * `h_tab_rsp_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns.+ variables = list( |
||
| 187 | +304 |
- #'+ id = "USUBJID", |
||
| 188 | +305 |
- #' @examples+ baseline_var = "BTOXGR", |
||
| 189 | +306 |
- #' # Starting from above `df`, zoom in on one biomarker and add required columns.+ direction_var = "GRADDR" |
||
| 190 | +307 |
- #' df1 <- df[1, ]+ )) {
+ |
+ ||
| 308 | +1x | +
+ checkmate::assert_string(.var)+ |
+ ||
| 309 | +1x | +
+ checkmate::assert_set_equal(names(variables), c("id", "baseline_var", "direction_var"))
+ |
+ ||
| 310 | +1x | +
+ checkmate::assert_string(variables$id)+ |
+ ||
| 311 | +1x | +
+ checkmate::assert_string(variables$baseline_var)+ |
+ ||
| 312 | +1x | +
+ checkmate::assert_string(variables$direction_var)+ |
+ ||
| 313 | +1x | +
+ assert_df_with_variables(df, c(aval = .var, variables[1:3]))+ |
+ ||
| 314 | +1x | +
+ assert_list_of_variables(variables) |
||
| 191 | +315 |
- #' df1$subgroup <- "All patients"+ + |
+ ||
| 316 | +1x | +
+ h_worsen_counter(df, variables$id, .var, variables$baseline_var, variables$direction_var) |
||
| 192 | +317 |
- #' df1$row_type <- "content"+ } |
||
| 193 | +318 |
- #' df1$var <- "ALL"+ |
||
| 194 | +319 |
- #' df1$var_label <- "All patients"+ #' @describeIn abnormal_by_worst_grade_worsen Formatted analysis function which is used as `afun` |
||
| 195 | +320 |
- #'+ #' in `count_abnormal_lab_worsen_by_baseline()`. |
||
| 196 | +321 |
- #' h_tab_rsp_one_biomarker(+ #' |
||
| 197 | +322 |
- #' df1,+ #' @return |
||
| 198 | +323 |
- #' vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval")
+ #' * `a_count_abnormal_lab_worsen_by_baseline()` returns the corresponding list with |
||
| 199 | +324 |
- #' )+ #' formatted [rtables::CellValue()]. |
||
| 200 | +325 |
#' |
||
| 201 | +326 |
- #' @export+ #' @keywords internal |
||
| 202 | +327 |
- h_tab_rsp_one_biomarker <- function(df,+ a_count_abnormal_lab_worsen_by_baseline <- make_afun( # nolint |
||
| 203 | +328 |
- vars,+ s_count_abnormal_lab_worsen_by_baseline, |
||
| 204 | +329 |
- na_str = default_na_str(),+ .formats = c(fraction = format_fraction), |
||
| 205 | +330 |
- .indent_mods = 0L) {
+ .ungroup_stats = "fraction" |
||
| 206 | -8x | +|||
| 331 | +
- afuns <- a_response_subgroups(na_str = na_str)[vars]+ ) |
|||
| 207 | -8x | +|||
| 332 | +
- colvars <- d_rsp_subgroups_colvars(+ |
|||
| 208 | -8x | +|||
| 333 | +
- vars,+ #' @describeIn abnormal_by_worst_grade_worsen Layout-creating function which can take statistics function |
|||
| 209 | -8x | +|||
| 334 | +
- conf_level = df$conf_level[1],+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 210 | -8x | +|||
| 335 | +
- method = df$pval_label[1]+ #' |
|||
| 211 | +336 |
- )+ #' @return |
||
| 212 | -8x | +|||
| 337 | +
- h_tab_one_biomarker(+ #' * `count_abnormal_lab_worsen_by_baseline()` returns a layout object suitable for passing to further layouting |
|||
| 213 | -8x | +|||
| 338 | +
- df = df,+ #' functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted |
|||
| 214 | -8x | +|||
| 339 | +
- afuns = afuns,+ #' rows containing the statistics from `s_count_abnormal_lab_worsen_by_baseline()` to the table layout. |
|||
| 215 | -8x | +|||
| 340 | +
- colvars = colvars,+ #' |
|||
| 216 | -8x | +|||
| 341 | +
- na_str = na_str,+ #' @examples |
|||
| 217 | -8x | +|||
| 342 | +
- .indent_mods = .indent_mods+ #' library(dplyr) |
|||
| 218 | +343 |
- )+ #' |
||
| 219 | +344 |
- }+ #' # The direction variable, GRADDR, is based on metadata |
| 1 | +345 |
- #' Confidence interval for mean+ #' adlb <- tern_ex_adlb %>% |
||
| 2 | +346 |
- #'+ #' mutate( |
||
| 3 | +347 |
- #' @description `r lifecycle::badge("stable")`
+ #' GRADDR = case_when( |
||
| 4 | +348 |
- #'+ #' PARAMCD == "ALT" ~ "B", |
||
| 5 | +349 |
- #' Convenient function for calculating the mean confidence interval. It calculates the arithmetic as well as the+ #' PARAMCD == "CRP" ~ "L", |
||
| 6 | +350 |
- #' geometric mean. It can be used as a `ggplot` helper function for plotting.+ #' PARAMCD == "IGA" ~ "H" |
||
| 7 | +351 |
- #'+ #' ) |
||
| 8 | +352 |
- #' @inheritParams argument_convention+ #' ) %>% |
||
| 9 | +353 |
- #' @param n_min (`numeric(1)`)\cr a minimum number of non-missing `x` to estimate the confidence interval for mean.+ #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "") |
||
| 10 | +354 |
- #' @param gg_helper (`flag`)\cr whether output should be aligned for use with `ggplot`s.+ #' |
||
| 11 | +355 |
- #' @param geom_mean (`flag`)\cr whether the geometric mean should be calculated.+ #' df <- h_adlb_worsen( |
||
| 12 | +356 |
- #'+ #' adlb, |
||
| 13 | +357 |
- #' @return A named `vector` of values `mean_ci_lwr` and `mean_ci_upr`.+ #' worst_flag_low = c("WGRLOFL" = "Y"),
|
||
| 14 | +358 |
- #'+ #' worst_flag_high = c("WGRHIFL" = "Y"),
|
||
| 15 | +359 |
- #' @examples+ #' direction_var = "GRADDR" |
||
| 16 | +360 |
- #' stat_mean_ci(sample(10), gg_helper = FALSE)+ #' ) |
||
| 17 | +361 |
#' |
||
| 18 | +362 |
- #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) ++ #' basic_table() %>% |
||
| 19 | +363 |
- #' ggplot2::geom_point()+ #' split_cols_by("ARMCD") %>%
|
||
| 20 | +364 |
- #'+ #' add_colcounts() %>% |
||
| 21 | +365 |
- #' p + ggplot2::stat_summary(+ #' split_rows_by("PARAMCD") %>%
|
||
| 22 | +366 |
- #' fun.data = stat_mean_ci,+ #' split_rows_by("GRADDR") %>%
|
||
| 23 | +367 |
- #' geom = "errorbar"+ #' count_abnormal_lab_worsen_by_baseline( |
||
| 24 | +368 |
- #' )+ #' var = "ATOXGR", |
||
| 25 | +369 |
- #'+ #' variables = list( |
||
| 26 | +370 |
- #' p + ggplot2::stat_summary(+ #' id = "USUBJID", |
||
| 27 | +371 |
- #' fun.data = stat_mean_ci,+ #' baseline_var = "BTOXGR", |
||
| 28 | +372 |
- #' fun.args = list(conf_level = 0.5),+ #' direction_var = "GRADDR" |
||
| 29 | +373 |
- #' geom = "errorbar"+ #' ) |
||
| 30 | +374 |
- #' )+ #' ) %>% |
||
| 31 | +375 |
- #'+ #' append_topleft("Direction of Abnormality") %>%
|
||
| 32 | +376 |
- #' p + ggplot2::stat_summary(+ #' build_table(df = df, alt_counts_df = tern_ex_adsl) |
||
| 33 | +377 |
- #' fun.data = stat_mean_ci,+ #' |
||
| 34 | +378 |
- #' fun.args = list(conf_level = 0.5, geom_mean = TRUE),+ #' @export |
||
| 35 | +379 |
- #' geom = "errorbar"+ #' @order 2 |
||
| 36 | +380 |
- #' )+ count_abnormal_lab_worsen_by_baseline <- function(lyt, # nolint |
||
| 37 | +381 |
- #'+ var, |
||
| 38 | +382 |
- #' @export+ variables = list( |
||
| 39 | +383 |
- stat_mean_ci <- function(x,+ id = "USUBJID", |
||
| 40 | +384 |
- conf_level = 0.95,+ baseline_var = "BTOXGR", |
||
| 41 | +385 |
- na.rm = TRUE, # nolint+ direction_var = "GRADDR" |
||
| 42 | +386 |
- n_min = 2,+ ), |
||
| 43 | +387 |
- gg_helper = TRUE,+ na_str = default_na_str(), |
||
| 44 | +388 |
- geom_mean = FALSE) {
+ nested = TRUE, |
||
| 45 | -2211x | +|||
| 389 | +
- if (na.rm) {
+ ..., |
|||
| 46 | -10x | +|||
| 390 | +
- x <- stats::na.omit(x)+ table_names = NULL, |
|||
| 47 | +391 |
- }+ .stats = NULL, |
||
| 48 | -2211x | +|||
| 392 | +
- n <- length(x)+ .formats = NULL, |
|||
| 49 | +393 |
-
+ .labels = NULL, |
||
| 50 | -2211x | +|||
| 394 | +
- if (!geom_mean) {
+ .indent_mods = NULL) {
|
|||
| 51 | -1113x | +395 | +1x |
- m <- mean(x)+ checkmate::assert_string(var) |
| 52 | +396 |
- } else {
+
|
||
| 53 | -1098x | +397 | +1x |
- negative_values_exist <- any(is.na(x[!is.na(x)]) <- x[!is.na(x)] <= 0)+ extra_args <- list(variables = variables, ...)+ |
+
| 398 | ++ | + | ||
| 54 | -1098x | +399 | +1x |
- if (negative_values_exist) {
+ afun <- make_afun( |
| 55 | -22x | +400 | +1x |
- m <- NA_real_+ a_count_abnormal_lab_worsen_by_baseline, |
| 56 | -+ | |||
| 401 | +1x |
- } else {
+ .stats = .stats, |
||
| 57 | -1076x | +402 | +1x |
- x <- log(x)+ .formats = .formats, |
| 58 | -1076x | +403 | +1x |
- m <- mean(x)+ .labels = .labels, |
| 59 | -+ | |||
| 404 | +1x |
- }+ .indent_mods = .indent_mods |
||
| 60 | +405 |
- }+ ) |
||
| 61 | +406 | |||
| 62 | -2211x | +407 | +1x |
- if (n < n_min || is.na(m)) {
+ lyt <- analyze( |
| 63 | -302x | +408 | +1x |
- ci <- c(mean_ci_lwr = NA_real_, mean_ci_upr = NA_real_)+ lyt = lyt, |
| 64 | -+ | |||
| 409 | +1x |
- } else {
+ vars = var, |
||
| 65 | -1909x | +410 | +1x |
- hci <- stats::qt((1 + conf_level) / 2, df = n - 1) * stats::sd(x) / sqrt(n)+ afun = afun, |
| 66 | -1909x | +411 | +1x |
- ci <- c(mean_ci_lwr = m - hci, mean_ci_upr = m + hci)+ na_str = na_str, |
| 67 | -1909x | +412 | +1x |
- if (geom_mean) {
+ nested = nested, |
| 68 | -945x | +413 | +1x |
- ci <- exp(ci)+ extra_args = extra_args, |
| 69 | -+ | |||
| 414 | +1x |
- }+ show_labels = "hidden" |
||
| 70 | +415 |
- }+ ) |
||
| 71 | +416 | |||
| 72 | -2211x | -
- if (gg_helper) {
- |
- ||
| 73 | -4x | +417 | +1x |
- m <- ifelse(is.na(m), NA_real_, m)+ lyt |
| 74 | -4x | +|||
| 418 | +
- ci <- data.frame(y = ifelse(geom_mean, exp(m), m), ymin = ci[[1]], ymax = ci[[2]])+ } |
| 75 | +1 |
- }+ #' Apply 1/3 or 1/2 imputation rule to data |
||
| 76 | +2 |
-
+ #' |
||
| 77 | -2211x | +|||
| 3 | +
- return(ci)+ #' @description `r lifecycle::badge("stable")`
|
|||
| 78 | +4 |
- }+ #' |
||
| 79 | +5 |
-
+ #' @inheritParams argument_convention |
||
| 80 | +6 |
- #' Confidence interval for median+ #' @param x_stats (named `list`)\cr a named list of statistics, typically the results of [s_summary()]. |
||
| 81 | +7 |
- #'+ #' @param stat (`string`)\cr statistic to return the value/NA level of according to the imputation |
||
| 82 | +8 |
- #' @description `r lifecycle::badge("stable")`
+ #' rule applied. |
||
| 83 | +9 |
- #'+ #' @param imp_rule (`string`)\cr imputation rule setting. Set to `"1/3"` to implement 1/3 imputation |
||
| 84 | +10 |
- #' Convenient function for calculating the median confidence interval. It can be used as a `ggplot` helper+ #' rule or `"1/2"` to implement 1/2 imputation rule. |
||
| 85 | +11 |
- #' function for plotting.+ #' @param post (`flag`)\cr whether the data corresponds to a post-dose time-point (defaults to `FALSE`). |
||
| 86 | +12 |
- #'+ #' This parameter is only used when `imp_rule` is set to `"1/3"`. |
||
| 87 | +13 |
- #' @inheritParams argument_convention+ #' @param avalcat_var (`string`)\cr name of variable that indicates whether a row in `df` corresponds |
||
| 88 | +14 |
- #' @param gg_helper (`flag`)\cr whether output should be aligned for use with `ggplot`s.+ #' to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of the above |
||
| 89 | +15 |
- #'+ #' (defaults to `"AVALCAT1"`). Variable `avalcat_var` must be present in `df`. |
||
| 90 | +16 |
- #' @details This function was adapted from `DescTools/versions/0.99.35/source`+ #' |
||
| 91 | +17 |
- #'+ #' @return A `list` containing statistic value (`val`) and NA level (`na_str`) that should be displayed |
||
| 92 | +18 |
- #' @return A named `vector` of values `median_ci_lwr` and `median_ci_upr`.+ #' according to the specified imputation rule. |
||
| 93 | +19 |
#' |
||
| 94 | +20 |
- #' @examples+ #' @seealso [analyze_vars_in_cols()] where this function can be implemented by setting the `imp_rule` |
||
| 95 | +21 |
- #' stat_median_ci(sample(10), gg_helper = FALSE)+ #' argument. |
||
| 96 | +22 |
#' |
||
| 97 | +23 |
- #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) ++ #' @examples |
||
| 98 | +24 |
- #' ggplot2::geom_point()+ #' set.seed(1) |
||
| 99 | +25 |
- #' p + ggplot2::stat_summary(+ #' df <- data.frame( |
||
| 100 | +26 |
- #' fun.data = stat_median_ci,+ #' AVAL = runif(50, 0, 1), |
||
| 101 | +27 |
- #' geom = "errorbar"+ #' AVALCAT1 = sample(c(1, "BLQ"), 50, replace = TRUE) |
||
| 102 | +28 |
#' ) |
||
| 103 | +29 |
- #'+ #' x_stats <- s_summary(df$AVAL) |
||
| 104 | +30 |
- #' @export+ #' imputation_rule(df, x_stats, "max", "1/3") |
||
| 105 | +31 |
- stat_median_ci <- function(x,+ #' imputation_rule(df, x_stats, "geom_mean", "1/3") |
||
| 106 | +32 |
- conf_level = 0.95,+ #' imputation_rule(df, x_stats, "mean", "1/2") |
||
| 107 | +33 |
- na.rm = TRUE, # nolint+ #' |
||
| 108 | +34 |
- gg_helper = TRUE) {
+ #' @export |
||
| 109 | -1111x | +|||
| 35 | +
- x <- unname(x)+ imputation_rule <- function(df, x_stats, stat, imp_rule, post = FALSE, avalcat_var = "AVALCAT1") {
|
|||
| 110 | -1111x | +36 | +128x |
- if (na.rm) {
+ checkmate::assert_choice(avalcat_var, names(df)) |
| 111 | -9x | +37 | +128x |
- x <- x[!is.na(x)]+ checkmate::assert_choice(imp_rule, c("1/3", "1/2"))
|
| 112 | -+ | |||
| 38 | +128x |
- }+ n_blq <- sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", df[[avalcat_var]]))
|
||
| 113 | -1111x | +39 | +128x |
- n <- length(x)+ ltr_blq_ratio <- n_blq / max(1, nrow(df)) |
| 114 | -1111x | +|||
| 40 | +
- med <- stats::median(x)+ |
|||
| 115 | +41 |
-
+ # defaults |
||
| 116 | -1111x | +42 | +128x |
- k <- stats::qbinom(p = (1 - conf_level) / 2, size = n, prob = 0.5, lower.tail = TRUE)+ val <- x_stats[[stat]] |
| 117 | -+ | |||
| 43 | +128x |
-
+ na_str <- "NE" |
||
| 118 | +44 |
- # k == 0 - for small samples (e.g. n <= 5) ci can be outside the observed range+ |
||
| 119 | -1111x | +45 | +128x |
- if (k == 0 || is.na(med)) {
+ if (imp_rule == "1/3") {
|
| 120 | -242x | +46 | +2x |
- ci <- c(median_ci_lwr = NA_real_, median_ci_upr = NA_real_)+ if (!post && stat == "geom_mean") val <- NA # 1/3_pre_LT, 1/3_pre_GT |
| 121 | -242x | -
- empir_conf_level <- NA_real_- |
- ||
| 122 | -+ | 47 | +84x |
- } else {
+ if (ltr_blq_ratio > 1 / 3) {
|
| 123 | -869x | +48 | +63x |
- x_sort <- sort(x)+ if (stat != "geom_mean") na_str <- "ND" # 1/3_pre_GT, 1/3_post_GT |
| 124 | -869x | +49 | +9x |
- ci <- c(median_ci_lwr = x_sort[k], median_ci_upr = x_sort[n - k + 1])+ if (!post && !stat %in% c("median", "max")) val <- NA # 1/3_pre_GT
|
| 125 | -869x | +50 | +39x |
- empir_conf_level <- 1 - 2 * stats::pbinom(k - 1, size = n, prob = 0.5)+ if (post && !stat %in% c("median", "max", "geom_mean")) val <- NA # 1/3_post_GT
|
| 126 | +51 |
- }+ } |
||
| 127 | -+ | |||
| 52 | +44x |
-
+ } else if (imp_rule == "1/2") {
|
||
| 128 | -1111x | +53 | +44x |
- if (gg_helper) {
+ if (ltr_blq_ratio > 1 / 2 && !stat == "max") {
|
| 129 | -4x | +54 | +12x |
- ci <- data.frame(y = med, ymin = ci[[1]], ymax = ci[[2]])+ val <- NA # 1/2_GT |
| 130 | -+ | |||
| 55 | +12x |
- }+ na_str <- "ND" # 1/2_GT |
||
| 131 | +56 |
-
+ } |
||
| 132 | -1111x | +|||
| 57 | +
- attr(ci, "conf_level") <- empir_conf_level+ } |
|||
| 133 | +58 | |||
| 134 | -1111x | +59 | +128x |
- return(ci)+ list(val = val, na_str = na_str) |
| 135 | +60 |
} |
| 136 | +1 |
-
+ #' Control function for incidence rate |
||
| 137 | +2 |
- #' p-Value of the mean+ #' |
||
| 138 | +3 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 139 | +4 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 140 | +5 |
- #'+ #' This is an auxiliary function for controlling arguments for the incidence rate, used |
||
| 141 | +6 |
- #' Convenient function for calculating the two-sided p-value of the mean.+ #' internally to specify details in `s_incidence_rate()`. |
||
| 142 | +7 |
#' |
||
| 143 | +8 |
#' @inheritParams argument_convention |
||
| 144 | +9 |
- #' @param n_min (`numeric(1)`)\cr a minimum number of non-missing `x` to estimate the p-value of the mean.+ #' @param conf_type (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar` |
||
| 145 | +10 |
- #' @param test_mean (`numeric(1)`)\cr mean value to test under the null hypothesis.+ #' for confidence interval type. |
||
| 146 | +11 |
- #'+ #' @param input_time_unit (`string`)\cr `day`, `week`, `month`, or `year` (default) |
||
| 147 | +12 |
- #' @return A p-value.+ #' indicating time unit for data input. |
||
| 148 | +13 |
- #'+ #' @param num_pt_year (`numeric(1)`)\cr number of patient-years to use when calculating adverse event rates. |
||
| 149 | +14 |
- #' @examples+ #' |
||
| 150 | +15 |
- #' stat_mean_pval(sample(10))+ #' @return A list of components with the same names as the arguments. |
||
| 151 | +16 |
#' |
||
| 152 | +17 |
- #' stat_mean_pval(rnorm(10), test_mean = 0.5)+ #' @seealso [incidence_rate] |
||
| 153 | +18 |
#' |
||
| 154 | +19 |
- #' @export+ #' @examples |
||
| 155 | +20 |
- stat_mean_pval <- function(x,+ #' control_incidence_rate(0.9, "exact", "month", 100) |
||
| 156 | +21 |
- na.rm = TRUE, # nolint+ #' |
||
| 157 | +22 |
- n_min = 2,+ #' @export |
||
| 158 | +23 |
- test_mean = 0) {
- |
- ||
| 159 | -1111x | -
- if (na.rm) {
- |
- ||
| 160 | -9x | -
- x <- stats::na.omit(x)+ control_incidence_rate <- function(conf_level = 0.95, |
||
| 161 | +24 |
- }+ conf_type = c("normal", "normal_log", "exact", "byar"),
|
||
| 162 | -1111x | +|||
| 25 | +
- n <- length(x)+ input_time_unit = c("year", "day", "week", "month"),
|
|||
| 163 | +26 |
-
+ num_pt_year = 100) {
|
||
| 164 | -1111x | +27 | +14x |
- x_mean <- mean(x)+ conf_type <- match.arg(conf_type) |
| 165 | -1111x | -
- x_sd <- stats::sd(x)- |
- ||
| 166 | -+ | 28 | +13x |
-
+ input_time_unit <- match.arg(input_time_unit) |
| 167 | -1111x | +29 | +12x |
- if (n < n_min) {
+ checkmate::assert_number(num_pt_year) |
| 168 | -140x | +30 | +11x |
- pv <- c(p_value = NA_real_)+ assert_proportion_value(conf_level) |
| 169 | +31 |
- } else {
+
|
||
| 170 | -971x | +32 | +10x |
- x_se <- stats::sd(x) / sqrt(n)+ list( |
| 171 | -971x | +33 | +10x |
- ttest <- (x_mean - test_mean) / x_se+ conf_level = conf_level, |
| 172 | -971x | -
- pv <- c(p_value = 2 * stats::pt(-abs(ttest), df = n - 1))- |
- ||
| 173 | -+ | 34 | +10x |
- }+ conf_type = conf_type, |
| 174 | -+ | |||
| 35 | +10x |
-
+ input_time_unit = input_time_unit, |
||
| 175 | -1111x | +36 | +10x |
- return(pv)+ num_pt_year = num_pt_year |
| 176 | +37 |
- }+ ) |
||
| 177 | +38 |
-
+ } |
| 178 | +1 |
- #' Proportion difference and confidence interval+ #' Summarize change from baseline values or absolute baseline values |
||
| 179 | +2 |
#' |
||
| 180 | +3 |
#' @description `r lifecycle::badge("stable")`
|
||
| 181 | +4 |
#' |
||
| 182 | +5 |
- #' Function for calculating the proportion (or risk) difference and confidence interval between arm+ #' The analyze function [summarize_change()] creates a layout element to summarize the change from baseline or absolute |
||
| 183 | +6 |
- #' X (reference group) and arm Y. Risk difference is calculated by subtracting cumulative incidence+ #' baseline values. The primary analysis variable `vars` indicates the numerical change from baseline results. |
||
| 184 | +7 |
- #' in arm Y from cumulative incidence in arm X.+ #' |
||
| 185 | +8 |
- #'+ #' Required secondary analysis variables `value` and `baseline_flag` can be supplied to the function via |
||
| 186 | +9 |
- #' @inheritParams argument_convention+ #' the `variables` argument. The `value` element should be the name of the analysis value variable, and the |
||
| 187 | +10 |
- #' @param x (`list` of `integer`)\cr list of number of occurrences in arm X (reference group).+ #' `baseline_flag` element should be the name of the flag variable that indicates whether or not records contain |
||
| 188 | +11 |
- #' @param y (`list` of `integer`)\cr list of number of occurrences in arm Y. Must be of equal length to `x`.+ #' baseline values. Depending on the baseline flag given, either the absolute baseline values (at baseline) |
||
| 189 | +12 |
- #' @param N_x (`numeric(1)`)\cr total number of records in arm X.+ #' or the change from baseline values (post-baseline) are then summarized. |
||
| 190 | +13 |
- #' @param N_y (`numeric(1)`)\cr total number of records in arm Y.+ #' |
||
| 191 | +14 |
- #' @param list_names (`character`)\cr names of each variable/level corresponding to pair of proportions in+ #' @inheritParams argument_convention |
||
| 192 | +15 |
- #' `x` and `y`. Must be of equal length to `x` and `y`.+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("analyze_vars_numeric)`
|
||
| 193 | +16 |
- #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`.+ #' to see available statistics for this function. |
||
| 194 | +17 |
#' |
||
| 195 | +18 |
- #' @return List of proportion differences and CIs corresponding to each pair of number of occurrences in `x` and+ #' @name summarize_change |
||
| 196 | +19 |
- #' `y`. Each list element consists of 3 statistics: proportion difference, CI lower bound, and CI upper bound.+ #' @order 1 |
||
| 197 | +20 |
- #'+ NULL |
||
| 198 | +21 |
- #' @seealso Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()]+ |
||
| 199 | +22 |
- #' with `riskdiff` argument is set to `TRUE` in subsequent analyze functions, adds a column containing+ #' @describeIn summarize_change Statistics function that summarizes baseline or post-baseline visits. |
||
| 200 | +23 |
- #' proportion (risk) difference to an `rtables` layout.+ #' |
||
| 201 | +24 |
- #'+ #' @return |
||
| 202 | +25 |
- #' @examples+ #' * `s_change_from_baseline()` returns the same values returned by [s_summary.numeric()]. |
||
| 203 | +26 |
- #' stat_propdiff_ci(+ #' |
||
| 204 | +27 |
- #' x = list(0.375), y = list(0.01), N_x = 5, N_y = 5, list_names = "x", conf_level = 0.9+ #' @note The data in `df` must be either all be from baseline or post-baseline visits. Otherwise |
||
| 205 | +28 |
- #' )+ #' an error will be thrown. |
||
| 206 | +29 |
#' |
||
| 207 | +30 |
- #' stat_propdiff_ci(+ #' @keywords internal |
||
| 208 | +31 |
- #' x = list(0.5, 0.75, 1), y = list(0.25, 0.05, 0.5), N_x = 10, N_y = 20, pct = FALSE+ s_change_from_baseline <- function(df, |
||
| 209 | +32 |
- #' )+ .var, |
||
| 210 | +33 |
- #'+ variables, |
||
| 211 | +34 |
- #' @export+ na.rm = TRUE, # nolint |
||
| 212 | +35 |
- stat_propdiff_ci <- function(x,+ ...) {
|
||
| 213 | -+ | |||
| 36 | +4x |
- y,+ checkmate::assert_numeric(df[[variables$value]]) |
||
| 214 | -+ | |||
| 37 | +4x |
- N_x, # nolint+ checkmate::assert_numeric(df[[.var]]) |
||
| 215 | -+ | |||
| 38 | +4x |
- N_y, # nolint+ checkmate::assert_logical(df[[variables$baseline_flag]]) |
||
| 216 | -+ | |||
| 39 | +4x |
- list_names = NULL,+ checkmate::assert_vector(unique(df[[variables$baseline_flag]]), max.len = 1) |
||
| 217 | -+ | |||
| 40 | +4x |
- conf_level = 0.95,+ assert_df_with_variables(df, c(variables, list(chg = .var))) |
||
| 218 | +41 |
- pct = TRUE) {
+
|
||
| 219 | -47x | +42 | +4x |
- checkmate::assert_list(x, types = "numeric")+ combined <- ifelse( |
| 220 | -47x | +43 | +4x |
- checkmate::assert_list(y, types = "numeric", len = length(x))+ df[[variables$baseline_flag]], |
| 221 | -47x | +44 | +4x |
- checkmate::assert_character(list_names, len = length(x), null.ok = TRUE)+ df[[variables$value]], |
| 222 | -47x | +45 | +4x |
- rd_list <- lapply(seq_along(x), function(i) {
+ df[[.var]] |
| 223 | -120x | +|||
| 46 | +
- p_x <- x[[i]] / N_x+ ) |
|||
| 224 | -120x | +47 | +4x |
- p_y <- y[[i]] / N_y+ if (is.logical(combined) && identical(length(combined), 0L)) {
|
| 225 | -120x | +48 | +1x |
- rd_ci <- p_x - p_y + c(-1, 1) * stats::qnorm((1 + conf_level) / 2) *+ combined <- numeric(0) |
| 226 | -120x | +|||
| 49 | +
- sqrt(p_x * (1 - p_x) / N_x + p_y * (1 - p_y) / N_y)+ } |
|||
| 227 | -120x | +50 | +4x |
- c(p_x - p_y, rd_ci) * ifelse(pct, 100, 1)+ s_summary(combined, na.rm = na.rm, ...) |
| 228 | +51 |
- })+ } |
||
| 229 | -47x | +|||
| 52 | +
- names(rd_list) <- list_names+ |
|||
| 230 | -47x | +|||
| 53 | +
- rd_list+ #' @describeIn summarize_change Formatted analysis function which is used as `afun` in `summarize_change()`. |
|||
| 231 | +54 |
- }+ #' |
| 1 | +55 |
- #' Class for `CombinationFunction`+ #' @return |
||
| 2 | +56 | ++ |
+ #' * `a_change_from_baseline()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+ |
| 57 |
#' |
|||
| 3 | +58 |
- #' @description `r lifecycle::badge("stable")`
+ #' @keywords internal |
||
| 4 | +59 |
- #'+ a_change_from_baseline <- make_afun( |
||
| 5 | +60 |
- #' `CombinationFunction` is an S4 class which extends standard functions. These are special functions that+ s_change_from_baseline, |
||
| 6 | +61 |
- #' can be combined and negated with the logical operators.+ .formats = c( |
||
| 7 | +62 |
- #'+ n = "xx", |
||
| 8 | +63 |
- #' @param e1 (`CombinationFunction`)\cr left hand side of logical operator.+ mean_sd = "xx.xx (xx.xx)", |
||
| 9 | +64 |
- #' @param e2 (`CombinationFunction`)\cr right hand side of logical operator.+ mean_se = "xx.xx (xx.xx)", |
||
| 10 | +65 |
- #' @param x (`CombinationFunction`)\cr the function which should be negated.+ median = "xx.xx", |
||
| 11 | +66 |
- #'+ range = "xx.xx - xx.xx", |
||
| 12 | +67 |
- #' @return A logical value indicating whether the left hand side of the equation equals the right hand side.+ mean_ci = "(xx.xx, xx.xx)", |
||
| 13 | +68 |
- #'+ median_ci = "(xx.xx, xx.xx)", |
||
| 14 | +69 |
- #' @examples+ mean_pval = "xx.xx" |
||
| 15 | +70 |
- #' higher <- function(a) {
+ ), |
||
| 16 | +71 |
- #' force(a)+ .labels = c( |
||
| 17 | +72 | ++ |
+ mean_sd = "Mean (SD)",+ |
+ |
| 73 | ++ |
+ mean_se = "Mean (SE)",+ |
+ ||
| 74 | ++ |
+ median = "Median",+ |
+ ||
| 75 | ++ |
+ range = "Min - Max"+ |
+ ||
| 76 | ++ |
+ )+ |
+ ||
| 77 |
- #' CombinationFunction(+ ) |
|||
| 18 | +78 |
- #' function(x) {
+
|
||
| 19 | +79 |
- #' x > a+ #' @describeIn summarize_change Layout-creating function which can take statistics function arguments |
||
| 20 | +80 |
- #' }+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 21 | +81 |
- #' )+ #' |
||
| 22 | +82 |
- #' }+ #' @return |
||
| 23 | +83 |
- #'+ #' * `summarize_change()` returns a layout object suitable for passing to further layouting functions, |
||
| 24 | +84 |
- #' lower <- function(b) {
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 25 | +85 |
- #' force(b)+ #' the statistics from `s_change_from_baseline()` to the table layout. |
||
| 26 | +86 |
- #' CombinationFunction(+ #' |
||
| 27 | +87 |
- #' function(x) {
+ #' @note To be used after a split on visits in the layout, such that each data subset only contains |
||
| 28 | +88 |
- #' x < b+ #' either baseline or post-baseline data. |
||
| 29 | +89 |
- #' }+ #' |
||
| 30 | +90 |
- #' )+ #' @examples |
||
| 31 | +91 |
- #' }+ #' library(dplyr) |
||
| 32 | +92 |
#' |
||
| 33 | +93 |
- #' c1 <- higher(5)+ #' ## Fabricate dataset |
||
| 34 | +94 |
- #' c2 <- lower(10)+ #' dta_test <- data.frame( |
||
| 35 | +95 |
- #' c3 <- higher(5) & lower(10)+ #' USUBJID = rep(1:6, each = 3), |
||
| 36 | +96 |
- #' c3(7)+ #' AVISIT = rep(paste0("V", 1:3), 6),
|
||
| 37 | +97 |
- #'+ #' ARM = rep(LETTERS[1:3], rep(6, 3)), |
||
| 38 | +98 |
- #' @name combination_function+ #' AVAL = c(9:1, rep(NA, 9)) |
||
| 39 | +99 |
- #' @aliases CombinationFunction-class+ #' ) %>% |
||
| 40 | +100 |
- #' @exportClass CombinationFunction+ #' mutate(ABLFLL = AVISIT == "V1") %>% |
||
| 41 | +101 |
- #' @export CombinationFunction+ #' group_by(USUBJID) %>% |
||
| 42 | +102 |
- CombinationFunction <- methods::setClass("CombinationFunction", contains = "function") # nolint
+ #' mutate( |
||
| 43 | +103 |
-
+ #' BLVAL = AVAL[ABLFLL], |
||
| 44 | +104 |
- #' @describeIn combination_function Logical "AND" combination of `CombinationFunction` functions.+ #' CHG = AVAL - BLVAL |
||
| 45 | +105 |
- #' The resulting object is of the same class, and evaluates the two argument functions. The result+ #' ) %>% |
||
| 46 | +106 |
- #' is then the "AND" of the two individual results.+ #' ungroup() |
||
| 47 | +107 |
#' |
||
| 48 | +108 |
- #' @export+ #' results <- basic_table() %>% |
||
| 49 | +109 |
- methods::setMethod(+ #' split_cols_by("ARM") %>%
|
||
| 50 | +110 |
- "&",+ #' split_rows_by("AVISIT") %>%
|
||
| 51 | +111 |
- signature = c(e1 = "CombinationFunction", e2 = "CombinationFunction"),+ #' summarize_change("CHG", variables = list(value = "AVAL", baseline_flag = "ABLFLL")) %>%
|
||
| 52 | +112 |
- definition = function(e1, e2) {
+ #' build_table(dta_test) |
||
| 53 | -4x | +|||
| 113 | +
- CombinationFunction(function(...) {
+ #' |
|||
| 54 | -490x | +|||
| 114 | +
- e1(...) && e2(...)+ #' results |
|||
| 55 | +115 |
- })+ #' |
||
| 56 | +116 |
- }+ #' @export |
||
| 57 | +117 |
- )+ #' @order 2 |
||
| 58 | +118 |
-
+ summarize_change <- function(lyt, |
||
| 59 | +119 |
- #' @describeIn combination_function Logical "OR" combination of `CombinationFunction` functions.+ vars, |
||
| 60 | +120 |
- #' The resulting object is of the same class, and evaluates the two argument functions. The result+ variables, |
||
| 61 | +121 |
- #' is then the "OR" of the two individual results.+ na_str = default_na_str(), |
||
| 62 | +122 |
- #'+ nested = TRUE, |
||
| 63 | +123 |
- #' @export+ ..., |
||
| 64 | +124 |
- methods::setMethod(+ table_names = vars, |
||
| 65 | +125 |
- "|",+ .stats = c("n", "mean_sd", "median", "range"),
|
||
| 66 | +126 |
- signature = c(e1 = "CombinationFunction", e2 = "CombinationFunction"),+ .formats = NULL, |
||
| 67 | +127 |
- definition = function(e1, e2) {
+ .labels = NULL, |
||
| 68 | -2x | +|||
| 128 | +
- CombinationFunction(function(...) {
+ .indent_mods = NULL) {
|
|||
| 69 | -4x | +129 | +1x |
- e1(...) || e2(...)+ extra_args <- list(variables = variables, ...) |
| 70 | +130 |
- })+ |
||
| 71 | -+ | |||
| 131 | +1x |
- }+ afun <- make_afun( |
||
| 72 | -+ | |||
| 132 | +1x |
- )+ a_change_from_baseline, |
||
| 73 | -+ | |||
| 133 | +1x |
-
+ .stats = .stats, |
||
| 74 | -+ | |||
| 134 | +1x |
- #' @describeIn combination_function Logical negation of `CombinationFunction` functions.+ .formats = .formats, |
||
| 75 | -+ | |||
| 135 | +1x |
- #' The resulting object is of the same class, and evaluates the original function. The result+ .labels = .labels, |
||
| 76 | -+ | |||
| 136 | +1x |
- #' is then the opposite of this results.+ .indent_mods = .indent_mods |
||
| 77 | +137 |
- #'+ ) |
||
| 78 | +138 |
- #' @export+ |
||
| 79 | -+ | |||
| 139 | +1x |
- methods::setMethod(+ analyze( |
||
| 80 | -+ | |||
| 140 | +1x |
- "!",+ lyt, |
||
| 81 | -+ | |||
| 141 | +1x |
- signature = c(x = "CombinationFunction"),+ vars, |
||
| 82 | -+ | |||
| 142 | +1x |
- definition = function(x) {
+ afun = afun, |
||
| 83 | -2x | +143 | +1x |
- CombinationFunction(function(...) {
+ na_str = na_str, |
| 84 | -305x | +144 | +1x |
- !x(...)+ nested = nested, |
| 85 | -+ | |||
| 145 | +1x |
- })+ extra_args = extra_args,+ |
+ ||
| 146 | +1x | +
+ table_names = table_names |
||
| 86 | +147 |
- }+ ) |
||
| 87 | +148 |
- )+ } |
| 1 |
- #' Apply 1/3 or 1/2 imputation rule to data+ #' Count patients with abnormal analysis range values by baseline status |
||
| 5 |
- #' @inheritParams argument_convention+ #' The analyze function [count_abnormal_by_baseline()] creates a layout element to count patients with abnormal |
||
| 6 |
- #' @param x_stats (named `list`)\cr a named list of statistics, typically the results of [s_summary()].+ #' analysis range values, categorized by baseline status. |
||
| 7 |
- #' @param stat (`string`)\cr statistic to return the value/NA level of according to the imputation+ #' |
||
| 8 |
- #' rule applied.+ #' This function analyzes primary analysis variable `var` which indicates abnormal range results. Additional |
||
| 9 |
- #' @param imp_rule (`string`)\cr imputation rule setting. Set to `"1/3"` to implement 1/3 imputation+ #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to |
||
| 10 |
- #' rule or `"1/2"` to implement 1/2 imputation rule.+ #' `USUBJID`), a variable to indicate unique subject identifiers, and `baseline` (defaults to `BNRIND`), a |
||
| 11 |
- #' @param post (`flag`)\cr whether the data corresponds to a post-dose time-point (defaults to `FALSE`).+ #' variable to indicate baseline reference ranges. |
||
| 12 |
- #' This parameter is only used when `imp_rule` is set to `"1/3"`.+ #' |
||
| 13 |
- #' @param avalcat_var (`string`)\cr name of variable that indicates whether a row in `df` corresponds+ #' For each direction specified via the `abnormal` parameter (e.g. High or Low), we condition on baseline |
||
| 14 |
- #' to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of the above+ #' range result and count patients in the numerator and denominator as follows for each of the following |
||
| 15 |
- #' (defaults to `"AVALCAT1"`). Variable `avalcat_var` must be present in `df`.+ #' categories: |
||
| 16 |
- #'+ #' * `Not <abnormality>` |
||
| 17 |
- #' @return A `list` containing statistic value (`val`) and NA level (`na_str`) that should be displayed+ #' * `num`: The number of patients without abnormality at baseline (excluding those with missing baseline) |
||
| 18 |
- #' according to the specified imputation rule.+ #' and with at least one abnormality post-baseline. |
||
| 19 |
- #'+ #' * `denom`: The number of patients without abnormality at baseline (excluding those with missing baseline). |
||
| 20 |
- #' @seealso [analyze_vars_in_cols()] where this function can be implemented by setting the `imp_rule`+ #' * `<Abnormality>` |
||
| 21 |
- #' argument.+ #' * `num`: The number of patients with abnormality as baseline and at least one abnormality post-baseline. |
||
| 22 |
- #'+ #' * `denom`: The number of patients with abnormality at baseline. |
||
| 23 |
- #' @examples+ #' * `Total` |
||
| 24 |
- #' set.seed(1)+ #' * `num`: The number of patients with at least one post-baseline record and at least one abnormality |
||
| 25 |
- #' df <- data.frame(+ #' post-baseline. |
||
| 26 |
- #' AVAL = runif(50, 0, 1),+ #' * `denom`: The number of patients with at least one post-baseline record. |
||
| 27 |
- #' AVALCAT1 = sample(c(1, "BLQ"), 50, replace = TRUE)+ #' |
||
| 28 |
- #' )+ #' This function assumes that `df` has been filtered to only include post-baseline records. |
||
| 29 |
- #' x_stats <- s_summary(df$AVAL)+ #' |
||
| 30 |
- #' imputation_rule(df, x_stats, "max", "1/3")+ #' @inheritParams argument_convention |
||
| 31 |
- #' imputation_rule(df, x_stats, "geom_mean", "1/3")+ #' @param abnormal (`character`)\cr values identifying the abnormal range level(s) in `.var`. |
||
| 32 |
- #' imputation_rule(df, x_stats, "mean", "1/2")+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal_by_baseline")`
|
||
| 33 |
- #'+ #' to see available statistics for this function. |
||
| 34 |
- #' @export+ #' |
||
| 35 |
- imputation_rule <- function(df, x_stats, stat, imp_rule, post = FALSE, avalcat_var = "AVALCAT1") {
+ #' @note |
||
| 36 | -128x | +
- checkmate::assert_choice(avalcat_var, names(df))+ #' * `df` should be filtered to include only post-baseline records. |
|
| 37 | -128x | +
- checkmate::assert_choice(imp_rule, c("1/3", "1/2"))
+ #' * If the baseline variable or analysis variable contains `NA` records, it is expected that `df` has been |
|
| 38 | -128x | +
- n_blq <- sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", df[[avalcat_var]]))
+ #' pre-processed using [df_explicit_na()] or [explicit_na()]. |
|
| 39 | -128x | +
- ltr_blq_ratio <- n_blq / max(1, nrow(df))+ #' |
|
| 40 |
-
+ #' @seealso Relevant description function [d_count_abnormal_by_baseline()]. |
||
| 41 |
- # defaults+ #' |
||
| 42 | -128x | +
- val <- x_stats[[stat]]+ #' @name abnormal_by_baseline |
|
| 43 | -128x | +
- na_str <- "NE"+ #' @order 1 |
|
| 44 |
-
+ NULL |
||
| 45 | -128x | +
- if (imp_rule == "1/3") {
+
|
|
| 46 | -2x | +
- if (!post && stat == "geom_mean") val <- NA # 1/3_pre_LT, 1/3_pre_GT+ #' Description function for `s_count_abnormal_by_baseline()` |
|
| 47 | -84x | +
- if (ltr_blq_ratio > 1 / 3) {
+ #' |
|
| 48 | -63x | +
- if (stat != "geom_mean") na_str <- "ND" # 1/3_pre_GT, 1/3_post_GT+ #' @description `r lifecycle::badge("stable")`
|
|
| 49 | -9x | +
- if (!post && !stat %in% c("median", "max")) val <- NA # 1/3_pre_GT
+ #' |
|
| 50 | -39x | +
- if (post && !stat %in% c("median", "max", "geom_mean")) val <- NA # 1/3_post_GT
+ #' Description function that produces the labels for [s_count_abnormal_by_baseline()]. |
|
| 51 |
- }+ #' |
||
| 52 | -44x | +
- } else if (imp_rule == "1/2") {
+ #' @inheritParams abnormal_by_baseline |
|
| 53 | -44x | +
- if (ltr_blq_ratio > 1 / 2 && !stat == "max") {
+ #' |
|
| 54 | -12x | +
- val <- NA # 1/2_GT+ #' @return Abnormal category labels for [s_count_abnormal_by_baseline()]. |
|
| 55 | -12x | +
- na_str <- "ND" # 1/2_GT+ #' |
|
| 56 |
- }+ #' @examples |
||
| 57 |
- }+ #' d_count_abnormal_by_baseline("LOW")
|
||
| 58 |
-
+ #' |
||
| 59 | -128x | +
- list(val = val, na_str = na_str)+ #' @export |
|
| 60 |
- }+ d_count_abnormal_by_baseline <- function(abnormal) {
|
| 1 | -+ | |||
| 61 | +9x |
- #' Summarize change from baseline values or absolute baseline values+ not_abn_name <- paste("Not", tolower(abnormal))
|
||
| 2 | -+ | |||
| 62 | +9x |
- #'+ abn_name <- paste0(toupper(substr(abnormal, 1, 1)), tolower(substring(abnormal, 2))) |
||
| 3 | -+ | |||
| 63 | +9x |
- #' @description `r lifecycle::badge("stable")`
+ total_name <- "Total" |
||
| 4 | +64 |
- #'+ |
||
| 5 | -+ | |||
| 65 | +9x |
- #' The analyze function [summarize_change()] creates a layout element to summarize the change from baseline or absolute+ list(+ |
+ ||
| 66 | +9x | +
+ not_abnormal = not_abn_name,+ |
+ ||
| 67 | +9x | +
+ abnormal = abn_name,+ |
+ ||
| 68 | +9x | +
+ total = total_name |
||
| 6 | +69 |
- #' baseline values. The primary analysis variable `vars` indicates the numerical change from baseline results.+ ) |
||
| 7 | +70 |
- #'+ } |
||
| 8 | +71 |
- #' Required secondary analysis variables `value` and `baseline_flag` can be supplied to the function via+ |
||
| 9 | +72 |
- #' the `variables` argument. The `value` element should be the name of the analysis value variable, and the+ #' @describeIn abnormal_by_baseline Statistics function for a single `abnormal` level. |
||
| 10 | +73 |
- #' `baseline_flag` element should be the name of the flag variable that indicates whether or not records contain+ #' |
||
| 11 | +74 |
- #' baseline values. Depending on the baseline flag given, either the absolute baseline values (at baseline)+ #' @param na_str (`string`)\cr the explicit `na_level` argument you used in the pre-processing steps (maybe with |
||
| 12 | +75 |
- #' or the change from baseline values (post-baseline) are then summarized.+ #' [df_explicit_na()]). The default is `"<Missing>"`. |
||
| 13 | +76 |
#' |
||
| 14 | +77 |
- #' @inheritParams argument_convention+ #' @return |
||
| 15 | +78 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("analyze_vars_numeric)`
+ #' * `s_count_abnormal_by_baseline()` returns statistic `fraction` which is a named list with 3 labeled elements: |
||
| 16 | +79 |
- #' to see available statistics for this function.+ #' `not_abnormal`, `abnormal`, and `total`. Each element contains a vector with `num` and `denom` patient counts. |
||
| 17 | +80 |
#' |
||
| 18 | +81 |
- #' @name summarize_change+ #' @keywords internal |
||
| 19 | +82 |
- #' @order 1+ s_count_abnormal_by_baseline <- function(df, |
||
| 20 | +83 |
- NULL+ .var, |
||
| 21 | +84 |
-
+ abnormal, |
||
| 22 | +85 |
- #' @describeIn summarize_change Statistics function that summarizes baseline or post-baseline visits.+ na_str = "<Missing>", |
||
| 23 | +86 |
- #'+ variables = list(id = "USUBJID", baseline = "BNRIND")) {
|
||
| 24 | -+ | |||
| 87 | +7x |
- #' @return+ checkmate::assert_string(.var) |
||
| 25 | -+ | |||
| 88 | +7x |
- #' * `s_change_from_baseline()` returns the same values returned by [s_summary.numeric()].+ checkmate::assert_string(abnormal) |
||
| 26 | -+ | |||
| 89 | +7x |
- #'+ checkmate::assert_string(na_str) |
||
| 27 | -+ | |||
| 90 | +7x |
- #' @note The data in `df` must be either all be from baseline or post-baseline visits. Otherwise+ assert_df_with_variables(df, c(range = .var, variables)) |
||
| 28 | -+ | |||
| 91 | +7x |
- #' an error will be thrown.+ checkmate::assert_subset(names(variables), c("id", "baseline"))
|
||
| 29 | -+ | |||
| 92 | +7x |
- #'+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ |
+ ||
| 93 | +7x | +
+ checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
+ |
+ ||
| 94 | +7x | +
+ checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
|
||
| 30 | +95 |
- #' @keywords internal+ |
||
| 31 | +96 |
- s_change_from_baseline <- function(df,+ # If input is passed as character, changed to factor+ |
+ ||
| 97 | +7x | +
+ df[[.var]] <- as_factor_keep_attributes(df[[.var]], na_level = na_str)+ |
+ ||
| 98 | +7x | +
+ df[[variables$baseline]] <- as_factor_keep_attributes(df[[variables$baseline]], na_level = na_str) |
||
| 32 | +99 |
- .var,+ + |
+ ||
| 100 | +7x | +
+ assert_valid_factor(df[[.var]], any.missing = FALSE)+ |
+ ||
| 101 | +6x | +
+ assert_valid_factor(df[[variables$baseline]], any.missing = FALSE) |
||
| 33 | +102 |
- variables,+ |
||
| 34 | +103 |
- na.rm = TRUE, # nolint+ # Keep only records with valid analysis value.+ |
+ ||
| 104 | +5x | +
+ df <- df[df[[.var]] != na_str, ] |
||
| 35 | +105 |
- ...) {
+
|
||
| 36 | -4x | +106 | +5x |
- checkmate::assert_numeric(df[[variables$value]])+ anl <- data.frame( |
| 37 | -4x | +107 | +5x |
- checkmate::assert_numeric(df[[.var]])+ id = df[[variables$id]], |
| 38 | -4x | +108 | +5x |
- checkmate::assert_logical(df[[variables$baseline_flag]])+ var = df[[.var]], |
| 39 | -4x | +109 | +5x |
- checkmate::assert_vector(unique(df[[variables$baseline_flag]]), max.len = 1)+ baseline = df[[variables$baseline]], |
| 40 | -4x | +110 | +5x |
- assert_df_with_variables(df, c(variables, list(chg = .var)))+ stringsAsFactors = FALSE |
| 41 | +111 | ++ |
+ )+ |
+ |
| 112 | ||||
| 42 | -4x | +|||
| 113 | +
- combined <- ifelse(+ # Total: |
|||
| 43 | -4x | +|||
| 114 | +
- df[[variables$baseline_flag]],+ # - Patients in denominator: have at least one valid measurement post-baseline.+ |
+ |||
| 115 | ++ |
+ # - Patients in numerator: have at least one abnormality. |
||
| 44 | -4x | +116 | +5x |
- df[[variables$value]],+ total_denom <- length(unique(anl$id)) |
| 45 | -4x | +117 | +5x |
- df[[.var]]+ total_num <- length(unique(anl$id[anl$var == abnormal])) |
| 46 | +118 |
- )+ |
||
| 47 | -4x | +|||
| 119 | +
- if (is.logical(combined) && identical(length(combined), 0L)) {
+ # Baseline NA records are counted only in total rows. |
|||
| 48 | -1x | +120 | +5x |
- combined <- numeric(0)+ anl <- anl[anl$baseline != na_str, ] |
| 49 | +121 |
- }+ |
||
| 50 | -4x | +|||
| 122 | +
- s_summary(combined, na.rm = na.rm, ...)+ # Abnormal: |
|||
| 51 | +123 |
- }+ # - Patients in denominator: have abnormality at baseline. |
||
| 52 | +124 |
-
+ # - Patients in numerator: have abnormality at baseline AND |
||
| 53 | +125 |
- #' @describeIn summarize_change Formatted analysis function which is used as `afun` in `summarize_change()`.+ # have at least one abnormality post-baseline.+ |
+ ||
| 126 | +5x | +
+ abn_denom <- length(unique(anl$id[anl$baseline == abnormal]))+ |
+ ||
| 127 | +5x | +
+ abn_num <- length(unique(anl$id[anl$baseline == abnormal & anl$var == abnormal])) |
||
| 54 | +128 |
- #'+ |
||
| 55 | +129 |
- #' @return+ # Not abnormal: |
||
| 56 | +130 |
- #' * `a_change_from_baseline()` returns the corresponding list with formatted [rtables::CellValue()].+ # - Patients in denominator: do not have abnormality at baseline. |
||
| 57 | +131 |
- #'+ # - Patients in numerator: do not have abnormality at baseline AND |
||
| 58 | +132 |
- #' @keywords internal+ # have at least one abnormality post-baseline.+ |
+ ||
| 133 | +5x | +
+ not_abn_denom <- length(unique(anl$id[anl$baseline != abnormal]))+ |
+ ||
| 134 | +5x | +
+ not_abn_num <- length(unique(anl$id[anl$baseline != abnormal & anl$var == abnormal])) |
||
| 59 | +135 |
- a_change_from_baseline <- make_afun(+ + |
+ ||
| 136 | +5x | +
+ labels <- d_count_abnormal_by_baseline(abnormal)+ |
+ ||
| 137 | +5x | +
+ list(fraction = list(+ |
+ ||
| 138 | +5x | +
+ not_abnormal = formatters::with_label(c(num = not_abn_num, denom = not_abn_denom), labels$not_abnormal),+ |
+ ||
| 139 | +5x | +
+ abnormal = formatters::with_label(c(num = abn_num, denom = abn_denom), labels$abnormal),+ |
+ ||
| 140 | +5x | +
+ total = formatters::with_label(c(num = total_num, denom = total_denom), labels$total) |
||
| 60 | +141 |
- s_change_from_baseline,+ )) |
||
| 61 | +142 |
- .formats = c(+ } |
||
| 62 | +143 |
- n = "xx",+ |
||
| 63 | +144 |
- mean_sd = "xx.xx (xx.xx)",+ #' @describeIn abnormal_by_baseline Formatted analysis function which is used as `afun` |
||
| 64 | +145 |
- mean_se = "xx.xx (xx.xx)",+ #' in `count_abnormal_by_baseline()`. |
||
| 65 | +146 |
- median = "xx.xx",+ #' |
||
| 66 | +147 |
- range = "xx.xx - xx.xx",+ #' @return |
||
| 67 | +148 | ++ |
+ #' * `a_count_abnormal_by_baseline()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+ |
| 149 |
- mean_ci = "(xx.xx, xx.xx)",+ #' |
|||
| 68 | +150 |
- median_ci = "(xx.xx, xx.xx)",+ #' @keywords internal |
||
| 69 | +151 |
- mean_pval = "xx.xx"+ a_count_abnormal_by_baseline <- make_afun( |
||
| 70 | +152 |
- ),+ s_count_abnormal_by_baseline, |
||
| 71 | +153 |
- .labels = c(+ .formats = c(fraction = format_fraction) |
||
| 72 | +154 |
- mean_sd = "Mean (SD)",+ ) |
||
| 73 | +155 |
- mean_se = "Mean (SE)",+ |
||
| 74 | +156 |
- median = "Median",+ #' @describeIn abnormal_by_baseline Layout-creating function which can take statistics function arguments |
||
| 75 | +157 |
- range = "Min - Max"+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 76 | +158 |
- )+ #' |
||
| 77 | +159 |
- )+ #' @return |
||
| 78 | +160 |
-
+ #' * `count_abnormal_by_baseline()` returns a layout object suitable for passing to further layouting functions, |
||
| 79 | +161 |
- #' @describeIn summarize_change Layout-creating function which can take statistics function arguments+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 80 | +162 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' the statistics from `s_count_abnormal_by_baseline()` to the table layout. |
||
| 81 | +163 |
#' |
||
| 82 | +164 |
- #' @return+ #' @examples |
||
| 83 | +165 |
- #' * `summarize_change()` returns a layout object suitable for passing to further layouting functions,+ #' df <- data.frame( |
||
| 84 | +166 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' USUBJID = as.character(c(1:6)), |
||
| 85 | +167 |
- #' the statistics from `s_change_from_baseline()` to the table layout.+ #' ANRIND = factor(c(rep("LOW", 4), "NORMAL", "HIGH")),
|
||
| 86 | +168 |
- #'+ #' BNRIND = factor(c("LOW", "NORMAL", "HIGH", NA, "LOW", "NORMAL"))
|
||
| 87 | +169 |
- #' @note To be used after a split on visits in the layout, such that each data subset only contains+ #' ) |
||
| 88 | +170 |
- #' either baseline or post-baseline data.+ #' df <- df_explicit_na(df) |
||
| 89 | +171 |
#' |
||
| 90 | +172 |
- #' @examples+ #' # Layout creating function. |
||
| 91 | +173 |
- #' library(dplyr)+ #' basic_table() %>% |
||
| 92 | +174 |
- #'+ #' count_abnormal_by_baseline(var = "ANRIND", abnormal = c(High = "HIGH")) %>% |
||
| 93 | +175 |
- #' ## Fabricate dataset+ #' build_table(df) |
||
| 94 | +176 |
- #' dta_test <- data.frame(+ #' |
||
| 95 | +177 |
- #' USUBJID = rep(1:6, each = 3),+ #' # Passing of statistics function and formatting arguments. |
||
| 96 | +178 |
- #' AVISIT = rep(paste0("V", 1:3), 6),
+ #' df2 <- data.frame( |
||
| 97 | +179 |
- #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ #' ID = as.character(c(1, 2, 3, 4)), |
||
| 98 | +180 |
- #' AVAL = c(9:1, rep(NA, 9))+ #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
|
||
| 99 | +181 |
- #' ) %>%+ #' BLRANGE = factor(c("LOW", "HIGH", "HIGH", "NORMAL"))
|
||
| 100 | +182 |
- #' mutate(ABLFLL = AVISIT == "V1") %>%+ #' ) |
||
| 101 | +183 |
- #' group_by(USUBJID) %>%+ #' |
||
| 102 | +184 |
- #' mutate(+ #' basic_table() %>% |
||
| 103 | +185 |
- #' BLVAL = AVAL[ABLFLL],+ #' count_abnormal_by_baseline( |
||
| 104 | +186 |
- #' CHG = AVAL - BLVAL+ #' var = "RANGE", |
||
| 105 | +187 |
- #' ) %>%+ #' abnormal = c(Low = "LOW"), |
||
| 106 | +188 |
- #' ungroup()+ #' variables = list(id = "ID", baseline = "BLRANGE"), |
||
| 107 | +189 |
- #'+ #' .formats = c(fraction = "xx / xx"), |
||
| 108 | +190 |
- #' results <- basic_table() %>%+ #' .indent_mods = c(fraction = 2L) |
||
| 109 | +191 |
- #' split_cols_by("ARM") %>%
+ #' ) %>% |
||
| 110 | +192 |
- #' split_rows_by("AVISIT") %>%
+ #' build_table(df2) |
||
| 111 | +193 |
- #' summarize_change("CHG", variables = list(value = "AVAL", baseline_flag = "ABLFLL")) %>%
+ #' |
||
| 112 | +194 |
- #' build_table(dta_test)+ #' @export |
||
| 113 | +195 |
- #'+ #' @order 2 |
||
| 114 | +196 |
- #' results+ count_abnormal_by_baseline <- function(lyt, |
||
| 115 | +197 |
- #'+ var, |
||
| 116 | +198 |
- #' @export+ abnormal, |
||
| 117 | +199 |
- #' @order 2+ variables = list(id = "USUBJID", baseline = "BNRIND"), |
||
| 118 | +200 |
- summarize_change <- function(lyt,+ na_str = "<Missing>", |
||
| 119 | +201 |
- vars,+ nested = TRUE, |
||
| 120 | +202 |
- variables,+ ..., |
||
| 121 | +203 |
- na_str = default_na_str(),+ table_names = abnormal, |
||
| 122 | +204 |
- nested = TRUE,+ .stats = NULL, |
||
| 123 | +205 |
- ...,+ .formats = NULL, |
||
| 124 | +206 |
- table_names = vars,+ .labels = NULL, |
||
| 125 | +207 |
- .stats = c("n", "mean_sd", "median", "range"),
+ .indent_mods = NULL) {
|
||
| 126 | -+ | |||
| 208 | +2x |
- .formats = NULL,+ checkmate::assert_character(abnormal, len = length(table_names), names = "named") |
||
| 127 | -+ | |||
| 209 | +2x |
- .labels = NULL,+ checkmate::assert_string(var) |
||
| 128 | +210 |
- .indent_mods = NULL) {
+
|
||
| 129 | -1x | +211 | +2x |
- extra_args <- list(variables = variables, ...)+ extra_args <- list(abnormal = abnormal, variables = variables, na_str = na_str, ...) |
| 130 | +212 | |||
| 131 | -1x | +213 | +2x |
afun <- make_afun( |
| 132 | -1x | +214 | +2x |
- a_change_from_baseline,+ a_count_abnormal_by_baseline, |
| 133 | -1x | +215 | +2x |
.stats = .stats, |
| 134 | -1x | +216 | +2x |
.formats = .formats, |
| 135 | -1x | +217 | +2x |
.labels = .labels, |
| 136 | -1x | +218 | +2x |
- .indent_mods = .indent_mods+ .indent_mods = .indent_mods,+ |
+
| 219 | +2x | +
+ .ungroup_stats = "fraction" |
||
| 137 | +220 |
) |
||
| 221 | +2x | +
+ for (i in seq_along(abnormal)) {
+ |
+ ||
| 222 | +4x | +
+ extra_args[["abnormal"]] <- abnormal[i]+ |
+ ||
| 138 | +223 | |||
| 139 | -1x | +224 | +4x |
- analyze(+ lyt <- analyze( |
| 140 | -1x | +225 | +4x |
- lyt,+ lyt = lyt, |
| 141 | -1x | +226 | +4x |
- vars,+ vars = var, |
| 142 | -1x | +227 | +4x |
- afun = afun,+ var_labels = names(abnormal[i]), |
| 143 | -1x | +228 | +4x |
- na_str = na_str,+ afun = afun, |
| 144 | -1x | +229 | +4x |
- nested = nested,+ na_str = na_str, |
| 145 | -1x | +230 | +4x |
- extra_args = extra_args,+ nested = nested, |
| 146 | -1x | +231 | +4x |
- table_names = table_names+ table_names = table_names[i],+ |
+
| 232 | +4x | +
+ extra_args = extra_args,+ |
+ ||
| 233 | +4x | +
+ show_labels = "visible" |
||
| 147 | +234 |
- )+ ) |
||
| 148 | +235 | ++ |
+ }+ |
+ |
| 236 | +2x | +
+ lyt+ |
+ ||
| 237 |
}@@ -181968,14 +181402,14 @@ tern coverage - 95.64% |
| 1 |
- #' Count number of patients with missed doses by thresholds+ #' Control function for Cox-PH model |
||
| 5 |
- #' The analyze function creates a layout element to calculate cumulative counts of patients with number of missed+ #' This is an auxiliary function for controlling arguments for Cox-PH model, typically used internally to specify |
||
| 6 |
- #' doses at least equal to user-specified threshold values.+ #' details of Cox-PH model for [s_coxph_pairwise()]. `conf_level` refers to Hazard Ratio estimation. |
||
| 8 |
- #' This function analyzes numeric variable `vars`, a variable with numbers of missed doses,+ #' @inheritParams argument_convention |
||
| 9 |
- #' against the threshold values supplied to the `thresholds` argument as a numeric vector. This function+ #' @param pval_method (`string`)\cr p-value method for testing hazard ratio = 1. |
||
| 10 |
- #' assumes that every row of the given data frame corresponds to a unique patient.+ #' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`. |
||
| 11 |
- #'+ #' @param ties (`string`)\cr string specifying the method for tie handling. Default is `"efron"`, |
||
| 12 |
- #' @inheritParams s_count_cumulative+ #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()]. |
||
| 13 |
- #' @inheritParams argument_convention+ #' |
||
| 14 |
- #' @param thresholds (`numeric`)\cr minimum number of missed doses the patients had.+ #' @return A list of components with the same names as the arguments. |
||
| 15 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_missed_doses")`
+ #' |
||
| 16 |
- #' to see available statistics for this function.+ #' @export |
||
| 17 |
- #'+ control_coxph <- function(pval_method = c("log-rank", "wald", "likelihood"),
|
||
| 18 |
- #' @seealso+ ties = c("efron", "breslow", "exact"),
|
||
| 19 |
- #' * Relevant description function [d_count_missed_doses()] which generates labels for [count_missed_doses()].+ conf_level = 0.95) {
|
||
| 20 | -+ | 52x |
- #' * Similar analyze function [count_cumulative()] which more generally counts cumulative values and has more+ pval_method <- match.arg(pval_method) |
| 21 | -+ | 51x |
- #' options for threshold handling, but uses different labels.+ ties <- match.arg(ties) |
| 22 | -+ | 51x |
- #'+ assert_proportion_value(conf_level) |
| 23 |
- #' @name count_missed_doses+ |
||
| 24 | -+ | 50x |
- #' @order 1+ list(pval_method = pval_method, ties = ties, conf_level = conf_level) |
| 25 |
- NULL+ } |
||
| 27 |
- #' @describeIn count_missed_doses Statistics function to count non-missing values.+ #' Control function for `survfit` models for survival time |
||
| 29 |
- #' @return+ #' @description `r lifecycle::badge("stable")`
|
||
| 30 |
- #' * `s_count_nonmissing()` returns the statistic `n` which is the count of non-missing values in `x`.+ #' |
||
| 31 |
- #'+ #' This is an auxiliary function for controlling arguments for `survfit` model, typically used internally to specify |
||
| 32 |
- #' @keywords internal+ #' details of `survfit` model for [s_surv_time()]. `conf_level` refers to survival time estimation. |
||
| 33 |
- s_count_nonmissing <- function(x) {
+ #' |
||
| 34 | -5x | +
- list(n = n_available(x))+ #' @inheritParams argument_convention |
|
| 35 |
- }+ #' @param conf_type (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log", |
||
| 36 |
-
+ #' see more in [survival::survfit()]. Note option "none" is no longer supported. |
||
| 37 |
- #' Description function that calculates labels for `s_count_missed_doses()`+ #' @param quantiles (`numeric(2)`)\cr vector of length two specifying the quantiles of survival time. |
||
| 39 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return A list of components with the same names as the arguments. |
||
| 41 |
- #' @inheritParams s_count_missed_doses+ #' @export |
||
| 42 |
- #'+ control_surv_time <- function(conf_level = 0.95, |
||
| 43 |
- #' @return [d_count_missed_doses()] returns a named `character` vector with the labels.+ conf_type = c("plain", "log", "log-log"),
|
||
| 44 |
- #'+ quantiles = c(0.25, 0.75)) {
|
||
| 45 | -+ | 229x |
- #' @seealso [s_count_missed_doses()]+ conf_type <- match.arg(conf_type) |
| 46 | -+ | 228x |
- #'+ checkmate::assert_numeric(quantiles, lower = 0, upper = 1, len = 2, unique = TRUE, sorted = TRUE) |
| 47 | -+ | 227x |
- #' @export+ nullo <- lapply(quantiles, assert_proportion_value) |
| 48 | -+ | 227x |
- d_count_missed_doses <- function(thresholds) {
+ assert_proportion_value(conf_level) |
| 49 | -4x | +226x |
- paste0("At least ", thresholds, " missed dose", ifelse(thresholds > 1, "s", ""))
+ list(conf_level = conf_level, conf_type = conf_type, quantiles = quantiles) |
| 52 |
- #' @describeIn count_missed_doses Statistics function to count patients with missed doses.+ #' Control function for `survfit` models for patients' survival rate at time points |
||
| 54 |
- #' @return+ #' @description `r lifecycle::badge("stable")`
|
||
| 55 |
- #' * `s_count_missed_doses()` returns the statistics `n` and `count_fraction` with one element for each threshold.+ #' |
||
| 56 |
- #'+ #' This is an auxiliary function for controlling arguments for `survfit` model, typically used internally to specify |
||
| 57 |
- #' @keywords internal+ #' details of `survfit` model for [s_surv_timepoint()]. `conf_level` refers to patient risk estimation at a time point. |
||
| 58 |
- s_count_missed_doses <- function(x,+ #' |
||
| 59 |
- thresholds,+ #' @inheritParams argument_convention |
||
| 60 |
- .N_col) { # nolint
+ #' @inheritParams control_surv_time |
||
| 61 | -1x | +
- stat <- s_count_cumulative(+ #' |
|
| 62 | -1x | +
- x = x,+ #' @return A list of components with the same names as the arguments. |
|
| 63 | -1x | +
- thresholds = thresholds,+ #' |
|
| 64 | -1x | +
- lower_tail = FALSE,+ #' @export |
|
| 65 | -1x | +
- include_eq = TRUE,+ control_surv_timepoint <- function(conf_level = 0.95, |
|
| 66 | -1x | +
- .N_col = .N_col+ conf_type = c("plain", "log", "log-log")) {
|
|
| 67 | -+ | 24x |
- )+ conf_type <- match.arg(conf_type) |
| 68 | -1x | +23x |
- labels <- d_count_missed_doses(thresholds)+ assert_proportion_value(conf_level) |
| 69 | -1x | +22x |
- for (i in seq_along(stat$count_fraction)) {
+ list( |
| 70 | -2x | +22x |
- stat$count_fraction[[i]] <- formatters::with_label(stat$count_fraction[[i]], label = labels[i])+ conf_level = conf_level, |
| 71 | -+ | 22x |
- }+ conf_type = conf_type |
| 72 | -1x | +
- n_stat <- s_count_nonmissing(x)+ ) |
|
| 73 | -1x | +
- c(n_stat, stat)+ } |
| 74 | +1 |
- }+ #' Subgroup treatment effect pattern (STEP) fit for survival outcome |
||
| 75 | +2 |
-
+ #' |
||
| 76 | +3 |
- #' @describeIn count_missed_doses Formatted analysis function which is used as `afun`+ #' @description `r lifecycle::badge("stable")`
|
||
| 77 | +4 |
- #' in `count_missed_doses()`.+ #' |
||
| 78 | +5 |
- #'+ #' This fits the subgroup treatment effect pattern (STEP) models for a survival outcome. The treatment arm |
||
| 79 | +6 |
- #' @return+ #' variable must have exactly 2 levels, where the first one is taken as reference and the estimated |
||
| 80 | +7 |
- #' * `a_count_missed_doses()` returns the corresponding list with formatted [rtables::CellValue()].+ #' hazard ratios are for the comparison of the second level vs. the first one. |
||
| 81 | +8 |
#' |
||
| 82 | +9 |
- #' @keywords internal+ #' The model which is fit is: |
||
| 83 | +10 |
- a_count_missed_doses <- make_afun(+ #' |
||
| 84 | +11 |
- s_count_missed_doses,+ #' `Surv(time, event) ~ arm * poly(biomarker, degree) + covariates + strata(strata)` |
||
| 85 | +12 |
- .formats = c(n = "xx", count_fraction = format_count_fraction)+ #' |
||
| 86 | +13 |
- )+ #' where `degree` is specified by `control_step()`. |
||
| 87 | +14 |
-
+ #' |
||
| 88 | +15 |
- #' @describeIn count_missed_doses Layout-creating function which can take statistics function arguments+ #' @inheritParams argument_convention |
||
| 89 | +16 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' @param variables (named `list` of `character`)\cr list of analysis variables: needs `time`, `event`, |
||
| 90 | +17 | ++ |
+ #' `arm`, `biomarker`, and optional `covariates` and `strata`.+ |
+ |
| 18 | ++ |
+ #' @param control (named `list`)\cr combined control list from [control_step()] and [control_coxph()].+ |
+ ||
| 19 |
#' |
|||
| 91 | +20 |
- #' @return+ #' @return A matrix of class `step`. The first part of the columns describe the subgroup intervals used |
||
| 92 | +21 |
- #' * `count_missed_doses()` returns a layout object suitable for passing to further layouting functions,+ #' for the biomarker variable, including where the center of the intervals are and their bounds. The |
||
| 93 | +22 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' second part of the columns contain the estimates for the treatment arm comparison. |
||
| 94 | +23 |
- #' the statistics from `s_count_missed_doses()` to the table layout.+ #' |
||
| 95 | +24 | ++ |
+ #' @note For the default degree 0 the `biomarker` variable is not included in the model.+ |
+ |
| 25 |
#' |
|||
| 96 | +26 | ++ |
+ #' @seealso [control_step()] and [control_coxph()] for the available customization options.+ |
+ |
| 27 | ++ |
+ #'+ |
+ ||
| 28 |
#' @examples |
|||
| 97 | +29 | ++ |
+ #' # Testing dataset with just two treatment arms.+ |
+ |
| 30 |
#' library(dplyr) |
|||
| 98 | +31 |
#' |
||
| 99 | +32 |
- #' anl <- tern_ex_adsl %>%+ #' adtte_f <- tern_ex_adtte %>% |
||
| 100 | +33 |
- #' distinct(STUDYID, USUBJID, ARM) %>%+ #' filter( |
||
| 101 | +34 |
- #' mutate(+ #' PARAMCD == "OS", |
||
| 102 | +35 |
- #' PARAMCD = "TNDOSMIS",+ #' ARM %in% c("B: Placebo", "A: Drug X")
|
||
| 103 | +36 |
- #' PARAM = "Total number of missed doses during study",+ #' ) %>% |
||
| 104 | +37 |
- #' AVAL = sample(0:20, size = nrow(tern_ex_adsl), replace = TRUE),+ #' mutate( |
||
| 105 | +38 |
- #' AVALC = ""+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
||
| 106 | +39 | ++ |
+ #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")),+ |
+ |
| 40 | ++ |
+ #' is_event = CNSR == 0+ |
+ ||
| 41 |
#' ) |
|||
| 107 | +42 | ++ |
+ #' labels <- c("ARM" = "Treatment Arm", "is_event" = "Event Flag")
+ |
+ |
| 43 | ++ |
+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ |
+ ||
| 44 |
#' |
|||
| 108 | +45 |
- #' basic_table() %>%+ #' variables <- list( |
||
| 109 | +46 |
- #' split_cols_by("ARM") %>%
+ #' arm = "ARM", |
||
| 110 | +47 |
- #' add_colcounts() %>%+ #' biomarker = "BMRKR1", |
||
| 111 | +48 |
- #' count_missed_doses("AVAL", thresholds = c(1, 5, 10, 15), var_labels = "Missed Doses") %>%
+ #' covariates = c("AGE", "BMRKR2"),
|
||
| 112 | +49 |
- #' build_table(anl, alt_counts_df = tern_ex_adsl)+ #' event = "is_event", |
||
| 113 | +50 | ++ |
+ #' time = "AVAL"+ |
+ |
| 51 | ++ |
+ #' )+ |
+ ||
| 52 | ++ |
+ #'+ |
+ ||
| 53 | ++ |
+ #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup.+ |
+ ||
| 54 | ++ |
+ #' step_matrix <- fit_survival_step(+ |
+ ||
| 55 | ++ |
+ #' variables = variables,+ |
+ ||
| 56 | ++ |
+ #' data = adtte_f+ |
+ ||
| 57 | ++ |
+ #' )+ |
+ ||
| 58 | ++ |
+ #' dim(step_matrix)+ |
+ ||
| 59 | ++ |
+ #' head(step_matrix)+ |
+ ||
| 60 | ++ |
+ #'+ |
+ ||
| 61 | ++ |
+ #' # Specify different polynomial degree for the biomarker interaction to use more flexible local+ |
+ ||
| 62 | ++ |
+ #' # models. Or specify different Cox regression options.+ |
+ ||
| 63 | ++ |
+ #' step_matrix2 <- fit_survival_step(+ |
+ ||
| 64 | ++ |
+ #' variables = variables,+ |
+ ||
| 65 | ++ |
+ #' data = adtte_f,+ |
+ ||
| 66 | ++ |
+ #' control = c(control_coxph(conf_level = 0.9), control_step(degree = 2))+ |
+ ||
| 67 | ++ |
+ #' )+ |
+ ||
| 68 | ++ |
+ #'+ |
+ ||
| 69 | ++ |
+ #' # Use a global model with cubic interaction and only 5 points.+ |
+ ||
| 70 | ++ |
+ #' step_matrix3 <- fit_survival_step(+ |
+ ||
| 71 | ++ |
+ #' variables = variables,+ |
+ ||
| 72 | ++ |
+ #' data = adtte_f,+ |
+ ||
| 73 | ++ |
+ #' control = c(control_coxph(), control_step(bandwidth = NULL, degree = 3, num_points = 5L))+ |
+ ||
| 74 | ++ |
+ #' )+ |
+ ||
| 75 |
#' |
|||
| 114 | -+ | |||
| 76 | ++ |
+ #' @export+ |
+ ||
| 77 | ++ |
+ fit_survival_step <- function(variables,+ |
+ ||
| 78 | ++ |
+ data,+ |
+ ||
| 79 | ++ |
+ control = c(control_step(), control_coxph())) {
+ |
+ ||
| 80 | +4x |
- #' @export+ checkmate::assert_list(control) |
||
| 115 | -+ | |||
| 81 | +4x |
- #' @order 2+ assert_df_with_variables(data, variables) |
||
| 116 | -+ | |||
| 82 | +4x |
- count_missed_doses <- function(lyt,+ data <- data[!is.na(data[[variables$biomarker]]), ] |
||
| 117 | -+ | |||
| 83 | +4x |
- vars,+ window_sel <- h_step_window(x = data[[variables$biomarker]], control = control) |
||
| 118 | -+ | |||
| 84 | +4x |
- thresholds,+ interval_center <- window_sel$interval[, "Interval Center"] |
||
| 119 | -+ | |||
| 85 | +4x |
- var_labels = vars,+ form <- h_step_survival_formula(variables = variables, control = control) |
||
| 120 | -+ | |||
| 86 | +4x |
- show_labels = "visible",+ estimates <- if (is.null(control$bandwidth)) {
|
||
| 121 | -+ | |||
| 87 | +1x |
- na_str = default_na_str(),+ h_step_survival_est( |
||
| 122 | -+ | |||
| 88 | +1x |
- nested = TRUE,+ formula = form, |
||
| 123 | -+ | |||
| 89 | +1x |
- ...,+ data = data, |
||
| 124 | -+ | |||
| 90 | +1x |
- table_names = vars,+ variables = variables, |
||
| 125 | -+ | |||
| 91 | +1x |
- .stats = NULL,+ x = interval_center, |
||
| 126 | -+ | |||
| 92 | +1x |
- .formats = NULL,+ control = control |
||
| 127 | +93 |
- .labels = NULL,+ ) |
||
| 128 | +94 |
- .indent_mods = NULL) {
+ } else {
|
||
| 129 | -1x | +95 | +3x |
- extra_args <- list(thresholds = thresholds, ...)+ tmp <- mapply( |
| 130 | -+ | |||
| 96 | +3x |
-
+ FUN = h_step_survival_est, |
||
| 131 | -1x | +97 | +3x |
- afun <- make_afun(+ x = interval_center, |
| 132 | -1x | +98 | +3x |
- a_count_missed_doses,+ subset = as.list(as.data.frame(window_sel$sel)), |
| 133 | -1x | +99 | +3x |
- .stats = .stats,+ MoreArgs = list( |
| 134 | -1x | +100 | +3x |
- .formats = .formats,+ formula = form, |
| 135 | -1x | +101 | +3x |
- .labels = .labels,+ data = data, |
| 136 | -1x | +102 | +3x |
- .indent_mods = .indent_mods,+ variables = variables, |
| 137 | -1x | +103 | +3x |
- .ungroup_stats = "count_fraction"+ control = control |
| 138 | +104 |
- )+ ) |
||
| 139 | -1x | +|||
| 105 | +
- analyze(+ ) |
|||
| 140 | -1x | +|||
| 106 | +
- lyt = lyt,+ # Maybe we find a more elegant solution than this. |
|||
| 141 | -1x | +107 | +3x |
- vars = vars,+ rownames(tmp) <- c("n", "events", "loghr", "se", "ci_lower", "ci_upper")
|
| 142 | -1x | +108 | +3x |
- afun = afun,+ t(tmp)+ |
+
| 109 | ++ |
+ } |
||
| 143 | -1x | +110 | +4x |
- var_labels = var_labels,+ result <- cbind(window_sel$interval, estimates) |
| 144 | -1x | +111 | +4x |
- table_names = table_names,+ structure( |
| 145 | -1x | +112 | +4x |
- show_labels = show_labels,+ result, |
| 146 | -1x | +113 | +4x |
- na_str = na_str,+ class = c("step", "matrix"),
|
| 147 | -1x | +114 | +4x |
- nested = nested,+ variables = variables, |
| 148 | -1x | +115 | +4x |
- extra_args = extra_args+ control = control |
| 149 | +116 |
) |
||
| 150 | +117 |
}@@ -183024,14 +182744,14 @@ tern coverage - 95.64% |
| 1 |
- #' Count specific values+ #' Count patients by most extreme post-baseline toxicity grade per direction of abnormality |
||
| 5 |
- #' The analyze function [count_values()] creates a layout element to calculate counts of specific values within a+ #' The analyze function [count_abnormal_by_worst_grade()] creates a layout element to count patients by highest (worst) |
||
| 6 |
- #' variable of interest.+ #' analysis toxicity grade post-baseline for each direction, categorized by parameter value. |
||
| 8 |
- #' This function analyzes one or more variables of interest supplied as a vector to `vars`. Values to+ #' This function analyzes primary analysis variable `var` which indicates toxicity grades. Additional |
||
| 9 |
- #' count for variable(s) in `vars` can be given as a vector via the `values` argument. One row of+ #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to |
||
| 10 |
- #' counts will be generated for each variable.+ #' `USUBJID`), a variable to indicate unique subject identifiers, `param` (defaults to `PARAM`), a variable |
||
| 11 |
- #'+ #' to indicate parameter values, and `grade_dir` (defaults to `GRADE_DIR`), a variable to indicate directions |
||
| 12 |
- #' @inheritParams argument_convention+ #' (e.g. High or Low) for each toxicity grade supplied in `var`. |
||
| 13 |
- #' @param values (`character`)\cr specific values that should be counted.+ #' |
||
| 14 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_values")`
+ #' For each combination of `param` and `grade_dir` levels, patient counts by worst |
||
| 15 |
- #' to see available statistics for this function.+ #' grade are calculated as follows: |
||
| 16 |
- #'+ #' * `1` to `4`: The number of patients with worst grades 1-4, respectively. |
||
| 17 |
- #' @note+ #' * `Any`: The number of patients with at least one abnormality (i.e. grade is not 0). |
||
| 18 |
- #' * For `factor` variables, `s_count_values` checks whether `values` are all included in the levels of `x`+ #' |
||
| 19 |
- #' and fails otherwise.+ #' Fractions are calculated by dividing the above counts by the number of patients with at least one |
||
| 20 |
- #' * For `count_values()`, variable labels are shown when there is more than one element in `vars`,+ #' valid measurement recorded during treatment. |
||
| 21 |
- #' otherwise they are hidden.+ #' |
||
| 22 |
- #'+ #' Pre-processing is crucial when using this function and can be done automatically using the |
||
| 23 |
- #' @name count_values+ #' [h_adlb_abnormal_by_worst_grade()] helper function. See the description of this function for details on the |
||
| 24 |
- #' @order 1+ #' necessary pre-processing steps. |
||
| 25 |
- NULL+ #' |
||
| 26 |
-
+ #' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create two row |
||
| 27 |
- #' @describeIn count_values S3 generic function to count values.+ #' splits, one on variable `param` and one on variable `grade_dir`. |
||
| 29 |
- #' @inheritParams s_summary.logical+ #' @inheritParams argument_convention |
||
| 30 |
- #'+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("abnormal_by_worst_grade")`
|
||
| 31 |
- #' @return+ #' to see available statistics for this function. |
||
| 32 |
- #' * `s_count_values()` returns output of [s_summary()] for specified values of a non-numeric variable.+ #' |
||
| 33 |
- #'+ #' @seealso [h_adlb_abnormal_by_worst_grade()] which pre-processes ADLB data frames to be used in |
||
| 34 |
- #' @export+ #' [count_abnormal_by_worst_grade()]. |
||
| 35 |
- s_count_values <- function(x,+ #' |
||
| 36 |
- values,+ #' @name abnormal_by_worst_grade |
||
| 37 |
- na.rm = TRUE, # nolint+ #' @order 1 |
||
| 38 |
- .N_col, # nolint+ NULL |
||
| 39 |
- .N_row, # nolint+ |
||
| 40 |
- denom = c("n", "N_row", "N_col")) {
+ #' @describeIn abnormal_by_worst_grade Statistics function which counts patients by worst grade. |
||
| 41 | -175x | +
- UseMethod("s_count_values", x)
+ #' |
|
| 42 |
- }+ #' @return |
||
| 43 |
-
+ #' * `s_count_abnormal_by_worst_grade()` returns the single statistic `count_fraction` with grades 1 to 4 and |
||
| 44 |
- #' @describeIn count_values Method for `character` class.+ #' "Any" results. |
||
| 46 |
- #' @method s_count_values character+ #' @keywords internal |
||
| 47 |
- #'+ s_count_abnormal_by_worst_grade <- function(df, # nolint |
||
| 48 |
- #' @examples+ .var = "GRADE_ANL", |
||
| 49 |
- #' # `s_count_values.character`+ .spl_context, |
||
| 50 |
- #' s_count_values(x = c("a", "b", "a"), values = "a")
+ variables = list( |
||
| 51 |
- #' s_count_values(x = c("a", "b", "a", NA, NA), values = "b", na.rm = FALSE)
+ id = "USUBJID", |
||
| 52 |
- #'+ param = "PARAM", |
||
| 53 |
- #' @export+ grade_dir = "GRADE_DIR" |
||
| 54 |
- s_count_values.character <- function(x,+ )) {
|
||
| 55 | -+ | 1x |
- values = "Y",+ checkmate::assert_string(.var) |
| 56 | -+ | 1x |
- na.rm = TRUE, # nolint+ assert_valid_factor(df[[.var]]) |
| 57 | -+ | 1x |
- ...) {
+ assert_valid_factor(df[[variables$param]]) |
| 58 | -173x | +1x |
- checkmate::assert_character(values)+ assert_valid_factor(df[[variables$grade_dir]]) |
| 59 | -+ | 1x |
-
+ assert_df_with_variables(df, c(a = .var, variables)) |
| 60 | -173x | +1x |
- if (na.rm) {
+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
| 61 | -172x | +
- x <- x[!is.na(x)]+ |
|
| 62 |
- }+ # To verify that the `split_rows_by` are performed with correct variables. |
||
| 63 | -+ | 1x |
-
+ checkmate::assert_subset(c(variables[["param"]], variables[["grade_dir"]]), .spl_context$split) |
| 64 | -173x | +1x |
- is_in_values <- x %in% values+ first_row <- .spl_context[.spl_context$split == variables[["param"]], ] |
| 65 | -+ | 1x |
-
+ x_lvls <- c(setdiff(levels(df[[.var]]), "0"), "Any") |
| 66 | -173x | +1x |
- s_summary(is_in_values, ...)+ result <- split(numeric(0), factor(x_lvls)) |
| 67 |
- }+ |
||
| 68 | -+ | 1x |
-
+ subj <- first_row$full_parent_df[[1]][[variables[["id"]]]] |
| 69 | -+ | 1x |
- #' @describeIn count_values Method for `factor` class. This makes an automatic+ subj_cur_col <- subj[first_row$cur_col_subset[[1]]] |
| 70 |
- #' conversion to `character` and then forwards to the method for characters.+ # Some subjects may have a record for high and low directions but |
||
| 71 |
- #'+ # should be counted only once. |
||
| 72 | -+ | 1x |
- #' @method s_count_values factor+ denom <- length(unique(subj_cur_col)) |
| 73 |
- #'+ |
||
| 74 | -+ | 1x |
- #' @examples+ for (lvl in x_lvls) {
|
| 75 | -+ | 5x |
- #' # `s_count_values.factor`+ if (lvl != "Any") {
|
| 76 | -+ | 4x |
- #' s_count_values(x = factor(c("a", "b", "a")), values = "a")
+ df_lvl <- df[df[[.var]] == lvl, ] |
| 77 |
- #'+ } else {
|
||
| 78 | -+ | 1x |
- #' @export+ df_lvl <- df[df[[.var]] != 0, ] |
| 79 |
- s_count_values.factor <- function(x,+ } |
||
| 80 | -+ | 5x |
- values = "Y",+ num <- length(unique(df_lvl[[variables[["id"]]]])) |
| 81 | -+ | 5x |
- ...) {
+ fraction <- ifelse(denom == 0, 0, num / denom) |
| 82 | -3x | +5x |
- s_count_values(as.character(x), values = as.character(values), ...)+ result[[lvl]] <- formatters::with_label(c(count = num, fraction = fraction), lvl) |
| 83 |
- }+ } |
||
| 85 | -+ | 1x |
- #' @describeIn count_values Method for `logical` class.+ result <- list(count_fraction = result) |
| 86 | -+ | 1x |
- #'+ result |
| 87 |
- #' @method s_count_values logical+ } |
||
| 88 |
- #'+ |
||
| 89 |
- #' @examples+ #' @describeIn abnormal_by_worst_grade Formatted analysis function which is used as `afun` |
||
| 90 |
- #' # `s_count_values.logical`+ #' in `count_abnormal_by_worst_grade()`. |
||
| 91 |
- #' s_count_values(x = c(TRUE, FALSE, TRUE))+ #' |
||
| 92 |
- #'+ #' @return |
||
| 93 |
- #' @export+ #' * `a_count_abnormal_by_worst_grade()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 94 |
- s_count_values.logical <- function(x, values = TRUE, ...) {
+ #' |
||
| 95 | -3x | +
- checkmate::assert_logical(values)+ #' @keywords internal |
|
| 96 | -3x | +
- s_count_values(as.character(x), values = as.character(values), ...)+ a_count_abnormal_by_worst_grade <- make_afun( # nolint |
|
| 97 |
- }+ s_count_abnormal_by_worst_grade, |
||
| 98 |
-
+ .formats = c(count_fraction = format_count_fraction) |
||
| 99 |
- #' @describeIn count_values Formatted analysis function which is used as `afun`+ ) |
||
| 100 |
- #' in `count_values()`.+ |
||
| 101 |
- #'+ #' @describeIn abnormal_by_worst_grade Layout-creating function which can take statistics function arguments |
||
| 102 |
- #' @return+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 103 |
- #' * `a_count_values()` returns the corresponding list with formatted [rtables::CellValue()].+ #' |
||
| 104 |
- #'+ #' @return |
||
| 105 |
- #' @examples+ #' * `count_abnormal_by_worst_grade()` returns a layout object suitable for passing to further layouting functions, |
||
| 106 |
- #' # `a_count_values`+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 107 |
- #' a_count_values(x = factor(c("a", "b", "a")), values = "a", .N_col = 10, .N_row = 10)
+ #' the statistics from `s_count_abnormal_by_worst_grade()` to the table layout. |
||
| 109 |
- #' @export+ #' @examples |
||
| 110 |
- a_count_values <- make_afun(+ #' library(dplyr) |
||
| 111 |
- s_count_values,+ #' library(forcats) |
||
| 112 |
- .formats = c(count_fraction = "xx (xx.xx%)", count = "xx")+ #' adlb <- tern_ex_adlb |
||
| 113 |
- )+ #' |
||
| 114 |
-
+ #' # Data is modified in order to have some parameters with grades only in one direction |
||
| 115 |
- #' @describeIn count_values Layout-creating function which can take statistics function arguments+ #' # and simulate the real data. |
||
| 116 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' adlb$ATOXGR[adlb$PARAMCD == "ALT" & adlb$ATOXGR %in% c("1", "2", "3", "4")] <- "-1"
|
||
| 117 |
- #'+ #' adlb$ANRIND[adlb$PARAMCD == "ALT" & adlb$ANRIND == "HIGH"] <- "LOW" |
||
| 118 |
- #' @return+ #' adlb$WGRHIFL[adlb$PARAMCD == "ALT"] <- "" |
||
| 119 |
- #' * `count_values()` 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+ #' adlb$ATOXGR[adlb$PARAMCD == "IGA" & adlb$ATOXGR %in% c("-1", "-2", "-3", "-4")] <- "1"
|
||
| 121 |
- #' the statistics from `s_count_values()` to the table layout.+ #' adlb$ANRIND[adlb$PARAMCD == "IGA" & adlb$ANRIND == "LOW"] <- "HIGH" |
||
| 122 |
- #'+ #' adlb$WGRLOFL[adlb$PARAMCD == "IGA"] <- "" |
||
| 123 |
- #' @examples+ #' |
||
| 124 |
- #' # `count_values`+ #' # Pre-processing |
||
| 125 |
- #' basic_table() %>%+ #' adlb_f <- adlb %>% h_adlb_abnormal_by_worst_grade() |
||
| 126 |
- #' count_values("Species", values = "setosa") %>%
+ #' |
||
| 127 |
- #' build_table(iris)+ #' # Map excludes records without abnormal grade since they should not be displayed |
||
| 128 |
- #'+ #' # in the table. |
||
| 129 |
- #' @export+ #' map <- unique(adlb_f[adlb_f$GRADE_DIR != "ZERO", c("PARAM", "GRADE_DIR", "GRADE_ANL")]) %>%
|
||
| 130 |
- #' @order 2+ #' lapply(as.character) %>% |
||
| 131 |
- count_values <- function(lyt,+ #' as.data.frame() %>% |
||
| 132 |
- vars,+ #' arrange(PARAM, desc(GRADE_DIR), GRADE_ANL) |
||
| 133 |
- values,+ #' |
||
| 134 |
- na_str = default_na_str(),+ #' basic_table() %>% |
||
| 135 |
- nested = TRUE,+ #' split_cols_by("ARMCD") %>%
|
||
| 136 |
- ...,+ #' split_rows_by("PARAM") %>%
|
||
| 137 |
- table_names = vars,+ #' split_rows_by("GRADE_DIR", split_fun = trim_levels_to_map(map)) %>%
|
||
| 138 |
- .stats = "count_fraction",+ #' count_abnormal_by_worst_grade( |
||
| 139 |
- .formats = NULL,+ #' var = "GRADE_ANL", |
||
| 140 |
- .labels = c(count_fraction = paste(values, collapse = ", ")),+ #' variables = list(id = "USUBJID", param = "PARAM", grade_dir = "GRADE_DIR") |
||
| 141 |
- .indent_mods = NULL) {
+ #' ) %>% |
||
| 142 | -3x | +
- extra_args <- list(values = values, ...)+ #' build_table(df = adlb_f) |
|
| 143 |
-
+ #' |
||
| 144 | -3x | +
- afun <- make_afun(+ #' @export |
|
| 145 | -3x | +
- a_count_values,+ #' @order 2 |
|
| 146 | -3x | +
- .stats = .stats,+ count_abnormal_by_worst_grade <- function(lyt, |
|
| 147 | -3x | +
- .formats = .formats,+ var, |
|
| 148 | -3x | +
- .labels = .labels,+ variables = list( |
|
| 149 | -3x | +
- .indent_mods = .indent_mods+ id = "USUBJID", |
|
| 150 |
- )+ param = "PARAM", |
||
| 151 | -3x | +
- analyze(+ grade_dir = "GRADE_DIR" |
|
| 152 | -3x | +
- lyt,+ ), |
|
| 153 | -3x | +
- vars,+ na_str = default_na_str(), |
|
| 154 | -3x | +
- afun = afun,+ nested = TRUE, |
|
| 155 | -3x | +
- na_str = na_str,+ ..., |
|
| 156 | -3x | +
- nested = nested,+ .stats = NULL, |
|
| 157 | -3x | +
- extra_args = extra_args,+ .formats = NULL, |
|
| 158 | -3x | +
- show_labels = ifelse(length(vars) > 1, "visible", "hidden"),+ .labels = NULL, |
|
| 159 | -3x | +
- table_names = table_names+ .indent_mods = NULL) {
|
|
| 160 | -+ | 2x |
- )+ extra_args <- list(variables = variables, ...) |
| 161 |
- }+ |
| 1 | -+ | |||
| 162 | +2x |
- #' Control function for Cox-PH model+ afun <- make_afun( |
||
| 2 | -+ | |||
| 163 | +2x |
- #'+ a_count_abnormal_by_worst_grade, |
||
| 3 | -+ | |||
| 164 | +2x |
- #' @description `r lifecycle::badge("stable")`
+ .stats = .stats, |
||
| 4 | -+ | |||
| 165 | +2x |
- #'+ .formats = .formats, |
||
| 5 | -+ | |||
| 166 | +2x |
- #' This is an auxiliary function for controlling arguments for Cox-PH model, typically used internally to specify+ .labels = .labels, |
||
| 6 | -+ | |||
| 167 | +2x |
- #' details of Cox-PH model for [s_coxph_pairwise()]. `conf_level` refers to Hazard Ratio estimation.+ .indent_mods = .indent_mods, |
||
| 7 | -+ | |||
| 168 | +2x |
- #'+ .ungroup_stats = "count_fraction" |
||
| 8 | +169 |
- #' @inheritParams argument_convention+ ) |
||
| 9 | -+ | |||
| 170 | +2x |
- #' @param pval_method (`string`)\cr p-value method for testing hazard ratio = 1.+ analyze( |
||
| 10 | -+ | |||
| 171 | +2x |
- #' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`.+ lyt = lyt, |
||
| 11 | -+ | |||
| 172 | +2x |
- #' @param ties (`string`)\cr string specifying the method for tie handling. Default is `"efron"`,+ vars = var, |
||
| 12 | -+ | |||
| 173 | +2x |
- #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()].+ afun = afun, |
||
| 13 | -+ | |||
| 174 | +2x |
- #'+ na_str = na_str,+ |
+ ||
| 175 | +2x | +
+ nested = nested,+ |
+ ||
| 176 | +2x | +
+ extra_args = extra_args,+ |
+ ||
| 177 | +2x | +
+ show_labels = "hidden" |
||
| 14 | +178 |
- #' @return A list of components with the same names as the arguments.+ ) |
||
| 15 | +179 |
- #'+ } |
||
| 16 | +180 |
- #' @export+ |
||
| 17 | +181 |
- control_coxph <- function(pval_method = c("log-rank", "wald", "likelihood"),
+ #' Helper function to prepare ADLB for `count_abnormal_by_worst_grade()` |
||
| 18 | +182 |
- ties = c("efron", "breslow", "exact"),
+ #' |
||
| 19 | +183 |
- conf_level = 0.95) {
+ #' @description `r lifecycle::badge("stable")`
|
||
| 20 | -52x | +|||
| 184 | +
- pval_method <- match.arg(pval_method)+ #' |
|||
| 21 | -51x | +|||
| 185 | +
- ties <- match.arg(ties)+ #' Helper function to prepare an ADLB data frame to be used as input in |
|||
| 22 | -51x | +|||
| 186 | +
- assert_proportion_value(conf_level)+ #' [count_abnormal_by_worst_grade()]. The following pre-processing steps are applied: |
|||
| 23 | +187 |
-
+ #' |
||
| 24 | -50x | +|||
| 188 | +
- list(pval_method = pval_method, ties = ties, conf_level = conf_level)+ #' 1. `adlb` is filtered on variable `avisit` to only include post-baseline visits. |
|||
| 25 | +189 |
- }+ #' 2. `adlb` is filtered on variables `worst_flag_low` and `worst_flag_high` so that only |
||
| 26 | +190 |
-
+ #' worst grades (in either direction) are included. |
||
| 27 | +191 |
- #' Control function for `survfit` models for survival time+ #' 3. From the standard lab grade variable `atoxgr`, the following two variables are derived |
||
| 28 | +192 |
- #'+ #' and added to `adlb`: |
||
| 29 | +193 |
- #' @description `r lifecycle::badge("stable")`
+ #' * A grade direction variable (e.g. `GRADE_DIR`). The variable takes value `"HIGH"` when |
||
| 30 | +194 |
- #'+ #' `atoxgr > 0`, `"LOW"` when `atoxgr < 0`, and `"ZERO"` otherwise. |
||
| 31 | +195 |
- #' This is an auxiliary function for controlling arguments for `survfit` model, typically used internally to specify+ #' * A toxicity grade variable (e.g. `GRADE_ANL`) where all negative values from `atoxgr` are |
||
| 32 | +196 |
- #' details of `survfit` model for [s_surv_time()]. `conf_level` refers to survival time estimation.+ #' replaced by their absolute values. |
||
| 33 | +197 |
- #'+ #' 4. Unused factor levels are dropped from `adlb` via [droplevels()]. |
||
| 34 | +198 |
- #' @inheritParams argument_convention+ #' |
||
| 35 | +199 |
- #' @param conf_type (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log",+ #' @param adlb (`data.frame`)\cr ADLB data frame. |
||
| 36 | +200 |
- #' see more in [survival::survfit()]. Note option "none" is no longer supported.+ #' @param atoxgr (`string`)\cr name of the analysis toxicity grade variable. This must be a `factor` |
||
| 37 | +201 |
- #' @param quantiles (`numeric(2)`)\cr vector of length two specifying the quantiles of survival time.+ #' variable. |
||
| 38 | +202 |
- #'+ #' @param avisit (`string`)\cr name of the analysis visit variable. |
||
| 39 | +203 |
- #' @return A list of components with the same names as the arguments.+ #' @param worst_flag_low (`string`)\cr name of the worst low lab grade flag variable. This variable is |
||
| 40 | +204 |
- #'+ #' set to `"Y"` when indicating records of worst low lab grades. |
||
| 41 | +205 |
- #' @export+ #' @param worst_flag_high (`string`)\cr name of the worst high lab grade flag variable. This variable is |
||
| 42 | +206 |
- control_surv_time <- function(conf_level = 0.95,+ #' set to `"Y"` when indicating records of worst high lab grades. |
||
| 43 | +207 |
- conf_type = c("plain", "log", "log-log"),
+ #' |
||
| 44 | +208 |
- quantiles = c(0.25, 0.75)) {
+ #' @return `h_adlb_abnormal_by_worst_grade()` returns the `adlb` data frame with two new |
||
| 45 | -229x | +|||
| 209 | +
- conf_type <- match.arg(conf_type)+ #' variables: `GRADE_DIR` and `GRADE_ANL`. |
|||
| 46 | -228x | +|||
| 210 | +
- checkmate::assert_numeric(quantiles, lower = 0, upper = 1, len = 2, unique = TRUE, sorted = TRUE)+ #' |
|||
| 47 | -227x | +|||
| 211 | +
- nullo <- lapply(quantiles, assert_proportion_value)+ #' @seealso [abnormal_by_worst_grade] |
|||
| 48 | -227x | +|||
| 212 | +
- assert_proportion_value(conf_level)+ #' |
|||
| 49 | -226x | +|||
| 213 | +
- list(conf_level = conf_level, conf_type = conf_type, quantiles = quantiles)+ #' @examples |
|||
| 50 | +214 |
- }+ #' h_adlb_abnormal_by_worst_grade(tern_ex_adlb) %>% |
||
| 51 | +215 |
-
+ #' dplyr::select(ATOXGR, GRADE_DIR, GRADE_ANL) %>% |
||
| 52 | +216 |
- #' Control function for `survfit` models for patients' survival rate at time points+ #' head(10) |
||
| 53 | +217 |
#' |
||
| 54 | +218 |
- #' @description `r lifecycle::badge("stable")`
+ #' @export |
||
| 55 | +219 |
- #'+ h_adlb_abnormal_by_worst_grade <- function(adlb, |
||
| 56 | +220 |
- #' This is an auxiliary function for controlling arguments for `survfit` model, typically used internally to specify+ atoxgr = "ATOXGR", |
||
| 57 | +221 |
- #' details of `survfit` model for [s_surv_timepoint()]. `conf_level` refers to patient risk estimation at a time point.+ avisit = "AVISIT", |
||
| 58 | +222 |
- #'+ worst_flag_low = "WGRLOFL", |
||
| 59 | +223 |
- #' @inheritParams argument_convention+ worst_flag_high = "WGRHIFL") {
|
||
| 60 | -+ | |||
| 224 | +1x |
- #' @inheritParams control_surv_time+ adlb %>% |
||
| 61 | -+ | |||
| 225 | +1x |
- #'+ dplyr::filter( |
||
| 62 | -+ | |||
| 226 | +1x |
- #' @return A list of components with the same names as the arguments.+ !.data[[avisit]] %in% c("SCREENING", "BASELINE"),
|
||
| 63 | -+ | |||
| 227 | +1x |
- #'+ .data[[worst_flag_low]] == "Y" | .data[[worst_flag_high]] == "Y" |
||
| 64 | +228 |
- #' @export+ ) %>% |
||
| 65 | -+ | |||
| 229 | +1x |
- control_surv_timepoint <- function(conf_level = 0.95,+ dplyr::mutate(+ |
+ ||
| 230 | +1x | +
+ GRADE_DIR = factor(+ |
+ ||
| 231 | +1x | +
+ dplyr::case_when(+ |
+ ||
| 232 | +1x | +
+ .data[[atoxgr]] %in% c("-1", "-2", "-3", "-4") ~ "LOW",
+ |
+ ||
| 233 | +1x | +
+ .data[[atoxgr]] == "0" ~ "ZERO",+ |
+ ||
| 234 | +1x | +
+ .data[[atoxgr]] %in% c("1", "2", "3", "4") ~ "HIGH"
|
||
| 66 | +235 |
- conf_type = c("plain", "log", "log-log")) {
+ ), |
||
| 67 | -24x | +236 | +1x |
- conf_type <- match.arg(conf_type)+ levels = c("LOW", "ZERO", "HIGH")
|
| 68 | -23x | +|||
| 237 | +
- assert_proportion_value(conf_level)+ ), |
|||
| 69 | -22x | +238 | +1x |
- list(+ GRADE_ANL = forcats::fct_relevel( |
| 70 | -22x | +239 | +1x |
- conf_level = conf_level,+ forcats::fct_recode(.data[[atoxgr]], `1` = "-1", `2` = "-2", `3` = "-3", `4` = "-4"), |
| 71 | -22x | +240 | +1x |
- conf_type = conf_type+ c("0", "1", "2", "3", "4")
|
| 72 | +241 |
- )+ ) |
||
| 73 | +242 | ++ |
+ ) %>%+ |
+ |
| 243 | +1x | +
+ droplevels()+ |
+ ||
| 244 |
}@@ -184674,14 +184458,14 @@ tern coverage - 95.64% |
| 1 |
- #' Helper function for tabulation of a single biomarker result+ #' Count number of patients with missed doses by thresholds |
||
| 5 |
- #' Please see [h_tab_surv_one_biomarker()] and [h_tab_rsp_one_biomarker()], which use this function for examples.+ #' The analyze function creates a layout element to calculate cumulative counts of patients with number of missed |
||
| 6 |
- #' This function is a wrapper for [rtables::summarize_row_groups()].+ #' doses at least equal to user-specified threshold values. |
||
| 8 |
- #' @inheritParams argument_convention+ #' This function analyzes numeric variable `vars`, a variable with numbers of missed doses, |
||
| 9 |
- #' @param df (`data.frame`)\cr results for a single biomarker.+ #' against the threshold values supplied to the `thresholds` argument as a numeric vector. This function |
||
| 10 |
- #' @param afuns (named `list` of `function`)\cr analysis functions.+ #' assumes that every row of the given data frame corresponds to a unique patient. |
||
| 11 |
- #' @param colvars (named `list`)\cr named list with elements `vars` (variables to tabulate) and `labels` (their labels).+ #' |
||
| 12 |
- #'+ #' @inheritParams s_count_cumulative |
||
| 13 |
- #' @return An `rtables` table object with statistics in columns.+ #' @inheritParams argument_convention |
||
| 14 |
- #'+ #' @param thresholds (`numeric`)\cr minimum number of missed doses the patients had. |
||
| 15 |
- #' @export+ #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_missed_doses")`
|
||
| 16 |
- h_tab_one_biomarker <- function(df,+ #' to see available statistics for this function. |
||
| 17 |
- afuns,+ #' |
||
| 18 |
- colvars,+ #' @seealso |
||
| 19 |
- na_str = default_na_str(),+ #' * Relevant description function [d_count_missed_doses()] which generates labels for [count_missed_doses()]. |
||
| 20 |
- .indent_mods = 0L,+ #' * Similar analyze function [count_cumulative()] which more generally counts cumulative values and has more |
||
| 21 |
- ...) {
+ #' options for threshold handling, but uses different labels. |
||
| 22 | -18x | +
- extra_args <- list(...)+ #' |
|
| 23 |
-
+ #' @name count_missed_doses |
||
| 24 |
- # Create "ci" column from "lcl" and "ucl"+ #' @order 1 |
||
| 25 | -18x | +
- df$ci <- combine_vectors(df$lcl, df$ucl)+ NULL |
|
| 27 | -18x | +
- lyt <- basic_table()+ #' @describeIn count_missed_doses Statistics function to count non-missing values. |
|
| 28 |
-
+ #' |
||
| 29 |
- # Row split by row type - only keep the content rows here.+ #' @return |
||
| 30 | -18x | +
- lyt <- split_rows_by(+ #' * `s_count_nonmissing()` returns the statistic `n` which is the count of non-missing values in `x`. |
|
| 31 | -18x | +
- lyt = lyt,+ #' |
|
| 32 | -18x | +
- var = "row_type",+ #' @keywords internal |
|
| 33 | -18x | +
- split_fun = keep_split_levels("content"),
+ s_count_nonmissing <- function(x) {
|
|
| 34 | -18x | +5x |
- nested = FALSE+ list(n = n_available(x)) |
| 35 |
- )+ } |
||
| 37 |
- # Summarize rows with all patients.+ #' Description function that calculates labels for `s_count_missed_doses()` |
||
| 38 | -18x | +
- lyt <- summarize_row_groups(+ #' |
|
| 39 | -18x | +
- lyt = lyt,+ #' @description `r lifecycle::badge("stable")`
|
|
| 40 | -18x | +
- var = "var_label",+ #' |
|
| 41 | -18x | +
- cfun = afuns,+ #' @inheritParams s_count_missed_doses |
|
| 42 | -18x | +
- na_str = na_str,+ #' |
|
| 43 | -18x | +
- indent_mod = .indent_mods,+ #' @return [d_count_missed_doses()] returns a named `character` vector with the labels. |
|
| 44 | -18x | +
- extra_args = extra_args+ #' |
|
| 45 |
- )+ #' @seealso [s_count_missed_doses()] |
||
| 46 |
-
+ #' |
||
| 47 |
- # Split cols by the multiple variables to populate into columns.+ #' @export |
||
| 48 | -18x | +
- lyt <- split_cols_by_multivar(+ d_count_missed_doses <- function(thresholds) {
|
|
| 49 | -18x | +4x |
- lyt = lyt,+ paste0("At least ", thresholds, " missed dose", ifelse(thresholds > 1, "s", ""))
|
| 50 | -18x | +
- vars = colvars$vars,+ } |
|
| 51 | -18x | +
- varlabels = colvars$labels+ |
|
| 52 |
- )+ #' @describeIn count_missed_doses Statistics function to count patients with missed doses. |
||
| 53 |
-
+ #' |
||
| 54 |
- # If there is any subgroup variables, we extend the layout accordingly.+ #' @return |
||
| 55 | -18x | +
- if ("analysis" %in% df$row_type) {
+ #' * `s_count_missed_doses()` returns the statistics `n` and `count_fraction` with one element for each threshold. |
|
| 56 |
- # Now only continue with the subgroup rows.+ #' |
||
| 57 | -10x | +
- lyt <- split_rows_by(+ #' @keywords internal |
|
| 58 | -10x | +
- lyt = lyt,+ s_count_missed_doses <- function(x, |
|
| 59 | -10x | +
- var = "row_type",+ thresholds, |
|
| 60 | -10x | +
- split_fun = keep_split_levels("analysis"),
+ .N_col) { # nolint
|
|
| 61 | -10x | +1x |
- nested = FALSE,+ stat <- s_count_cumulative( |
| 62 | -10x | +1x |
- child_labels = "hidden"+ x = x, |
| 63 | -+ | 1x |
- )+ thresholds = thresholds, |
| 64 | -+ | 1x |
-
+ lower_tail = FALSE, |
| 65 | -+ | 1x |
- # Split by the subgroup variable.+ include_eq = TRUE, |
| 66 | -10x | +1x |
- lyt <- split_rows_by(+ .N_col = .N_col |
| 67 | -10x | +
- lyt = lyt,+ ) |
|
| 68 | -10x | +1x |
- var = "var",+ labels <- d_count_missed_doses(thresholds) |
| 69 | -10x | +1x |
- labels_var = "var_label",+ for (i in seq_along(stat$count_fraction)) {
|
| 70 | -10x | +2x |
- nested = TRUE,+ stat$count_fraction[[i]] <- formatters::with_label(stat$count_fraction[[i]], label = labels[i]) |
| 71 | -10x | +
- child_labels = "visible",+ } |
|
| 72 | -10x | +1x |
- indent_mod = .indent_mods * 2+ n_stat <- s_count_nonmissing(x) |
| 73 | -+ | 1x |
- )+ c(n_stat, stat) |
| 74 |
-
+ } |
||
| 75 |
- # Then analyze colvars for each subgroup.+ |
||
| 76 | -10x | +
- lyt <- summarize_row_groups(+ #' @describeIn count_missed_doses Formatted analysis function which is used as `afun` |
|
| 77 | -10x | +
- lyt = lyt,+ #' in `count_missed_doses()`. |
|
| 78 | -10x | +
- cfun = afuns,+ #' |
|
| 79 | -10x | +
- var = "subgroup",+ #' @return |
|
| 80 | -10x | +
- na_str = na_str,+ #' * `a_count_missed_doses()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 81 | -10x | +
- extra_args = extra_args+ #' |
|
| 82 |
- )+ #' @keywords internal |
||
| 83 |
- }+ a_count_missed_doses <- make_afun( |
||
| 84 | -18x | +
- build_table(lyt, df = df)+ s_count_missed_doses, |
|
| 85 |
- }+ .formats = c(n = "xx", count_fraction = format_count_fraction) |
| 1 | +86 |
- #' Count the number of patients with a particular event+ ) |
|
| 2 | +87 |
- #'+ |
|
| 3 | +88 |
- #' @description `r lifecycle::badge("stable")`
+ #' @describeIn count_missed_doses Layout-creating function which can take statistics function arguments |
|
| 4 | +89 |
- #'+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
| 5 | +90 |
- #' The analyze function [count_patients_with_event()] creates a layout element to calculate patient counts for a+ #' |
|
| 6 | +91 |
- #' user-specified set of events.+ #' @return |
|
| 7 | +92 |
- #'+ #' * `count_missed_doses()` returns a layout object suitable for passing to further layouting functions, |
|
| 8 | +93 |
- #' This function analyzes primary analysis variable `vars` which indicates unique subject identifiers. Events+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
| 9 | +94 |
- #' are defined by the user as a named vector via the `filters` argument, where each name corresponds to a+ #' the statistics from `s_count_missed_doses()` to the table layout. |
|
| 10 | +95 |
- #' variable and each value is the value(s) that that variable takes for the event.+ #' |
|
| 11 | +96 |
- #'+ #' @examples |
|
| 12 | +97 |
- #' If there are multiple records with the same event recorded for a patient, only one occurrence is counted.+ #' library(dplyr) |
|
| 13 | +98 |
#' |
|
| 14 | +99 |
- #' @inheritParams argument_convention+ #' anl <- tern_ex_adsl %>% |
|
| 15 | +100 |
- #' @param filters (`character`)\cr a character vector specifying the column names and flag variables+ #' distinct(STUDYID, USUBJID, ARM) %>% |
|
| 16 | +101 |
- #' to be used for counting the number of unique identifiers satisfying such conditions.+ #' mutate( |
|
| 17 | +102 |
- #' Multiple column names and flags are accepted in this format+ #' PARAMCD = "TNDOSMIS", |
|
| 18 | +103 |
- #' `c("column_name1" = "flag1", "column_name2" = "flag2")`.
+ #' PARAM = "Total number of missed doses during study", |
|
| 19 | +104 |
- #' Note that only equality is being accepted as condition.+ #' AVAL = sample(0:20, size = nrow(tern_ex_adsl), replace = TRUE), |
|
| 20 | +105 |
- #' @param .stats (`character`)\cr statistics to select for the table. Run `get_stats("count_patients_with_event")`
+ #' AVALC = "" |
|
| 21 | +106 |
- #' to see available statistics for this function.+ #' ) |
|
| 22 | +107 |
#' |
|
| 23 | +108 |
- #' @seealso [count_patients_with_flags]+ #' basic_table() %>% |
|
| 24 | +109 |
- #'+ #' split_cols_by("ARM") %>%
|
|
| 25 | +110 |
- #' @name count_patients_with_event+ #' add_colcounts() %>% |
|
| 26 | +111 |
- #' @order 1+ #' count_missed_doses("AVAL", thresholds = c(1, 5, 10, 15), var_labels = "Missed Doses") %>%
|
|
| 27 | +112 |
- NULL+ #' build_table(anl, alt_counts_df = tern_ex_adsl) |
|
| 28 | +113 |
-
+ #' |
|
| 29 | +114 |
- #' @describeIn count_patients_with_event Statistics function which counts the number of patients for which+ #' @export |
|
| 30 | +115 |
- #' the defined event has occurred.+ #' @order 2 |
|
| 31 | +116 |
- #'+ count_missed_doses <- function(lyt, |
|
| 32 | +117 |
- #' @inheritParams analyze_variables+ vars, |
|
| 33 | +118 |
- #' @param .var (`string`)\cr name of the column that contains the unique identifier.+ thresholds, |
|
| 34 | +119 |
- #'+ var_labels = vars, |
|
| 35 | +120 |
- #' @return+ show_labels = "visible", |
|
| 36 | +121 |
- #' * `s_count_patients_with_event()` returns the count and fraction of unique identifiers with the defined event.+ na_str = default_na_str(), |
|
| 37 | +122 |
- #'+ nested = TRUE, |
|
| 38 | +123 |
- #' @examples+ ..., |
|
| 39 | +124 |
- #' # `s_count_patients_with_event()`+ table_names = vars, |
|
| 40 | +125 |
- #'+ .stats = NULL, |
|
| 41 | +126 |
- #' s_count_patients_with_event(+ .formats = NULL, |
|
| 42 | +127 |
- #' tern_ex_adae,+ .labels = NULL, |
|
| 43 | +128 |
- #' .var = "SUBJID",+ .indent_mods = NULL) {
|
|
| 44 | -+ | ||
| 129 | +1x |
- #' filters = c("TRTEMFL" = "Y")
+ extra_args <- list(thresholds = thresholds, ...) |
|
| 45 | +130 |
- #' )+ |
|
| 46 | -+ | ||
| 131 | +1x |
- #'+ afun <- make_afun( |
|
| 47 | -+ | ||
| 132 | +1x |
- #' s_count_patients_with_event(+ a_count_missed_doses,+ |
+ |
| 133 | +1x | +
+ .stats = .stats,+ |
+ |
| 134 | +1x | +
+ .formats = .formats,+ |
+ |
| 135 | +1x | +
+ .labels = .labels,+ |
+ |
| 136 | +1x | +
+ .indent_mods = .indent_mods,+ |
+ |
| 137 | +1x | +
+ .ungroup_stats = "count_fraction" |
|
| 48 | +138 |
- #' tern_ex_adae,+ )+ |
+ |
| 139 | +1x | +
+ analyze(+ |
+ |
| 140 | +1x | +
+ lyt = lyt,+ |
+ |
| 141 | +1x | +
+ vars = vars,+ |
+ |
| 142 | +1x | +
+ afun = afun,+ |
+ |
| 143 | +1x | +
+ var_labels = var_labels,+ |
+ |
| 144 | +1x | +
+ table_names = table_names,+ |
+ |
| 145 | +1x | +
+ show_labels = show_labels,+ |
+ |
| 146 | +1x | +
+ na_str = na_str,+ |
+ |
| 147 | +1x | +
+ nested = nested,+ |
+ |
| 148 | +1x | +
+ extra_args = extra_args |
|
| 49 | +149 |
- #' .var = "SUBJID",+ ) |
|
| 50 | +150 |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL")
+ } |
| 51 | +1 |
- #' )+ #' Control function for logistic regression model fitting |
||
| 52 | +2 |
#' |
||
| 53 | +3 |
- #' s_count_patients_with_event(+ #' @description `r lifecycle::badge("stable")`
|
||
| 54 | +4 |
- #' tern_ex_adae,+ #' |
||
| 55 | +5 |
- #' .var = "SUBJID",+ #' This is an auxiliary function for controlling arguments for logistic regression models. |
||
| 56 | +6 |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
+ #' `conf_level` refers to the confidence level used for the Odds Ratio CIs. |
||
| 57 | +7 |
- #' denom = "N_col",+ #' |
||
| 58 | +8 |
- #' .N_col = 456+ #' @inheritParams argument_convention |
||
| 59 | +9 |
- #' )+ #' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`. |
||
| 60 | +10 |
- #'+ #' This will be used when fitting the logistic regression model on the left hand side of the formula. |
||
| 61 | +11 |
- #' @export+ #' Note that the evaluated expression should result in either a logical vector or a factor with 2 |
||
| 62 | +12 |
- s_count_patients_with_event <- function(df,+ #' levels. By default this is just `"response"` such that the original response variable is used |
||
| 63 | +13 |
- .var,+ #' and not modified further. |
||
| 64 | +14 |
- filters,+ #' |
||
| 65 | +15 |
- .N_col, # nolint+ #' @return A list of components with the same names as the arguments. |
||
| 66 | +16 |
- .N_row, # nolint+ #' |
||
| 67 | +17 |
- denom = c("n", "N_row", "N_col")) {
+ #' @examples |
||
| 68 | -32x | +|||
| 18 | +
- col_names <- names(filters)+ #' # Standard options. |
|||
| 69 | -32x | +|||
| 19 | +
- filter_values <- filters+ #' control_logistic() |
|||
| 70 | +20 |
-
+ #' |
||
| 71 | -32x | +|||
| 21 | +
- checkmate::assert_subset(col_names, colnames(df))+ #' # Modify confidence level. |
|||
| 72 | +22 |
-
+ #' control_logistic(conf_level = 0.9) |
||
| 73 | -32x | +|||
| 23 | +
- temp <- Map(+ #' |
|||
| 74 | -32x | +|||
| 24 | +
- function(x, y) which(df[[x]] == y),+ #' # Use a different response definition. |
|||
| 75 | -32x | +|||
| 25 | +
- col_names,+ #' control_logistic(response_definition = "I(response %in% c('CR', 'PR'))")
|
|||
| 76 | -32x | +|||
| 26 | +
- filter_values+ #' |
|||
| 77 | +27 |
- )+ #' @export |
||
| 78 | -32x | +|||
| 28 | +
- position_satisfy_filters <- Reduce(intersect, temp)+ control_logistic <- function(response_definition = "response", |
|||
| 79 | -32x | +|||
| 29 | +
- id_satisfy_filters <- as.character(unique(df[position_satisfy_filters, ][[.var]]))+ conf_level = 0.95) {
|
|||
| 80 | -32x | +30 | +29x |
- result <- s_count_values(+ checkmate::assert_true(grepl("response", response_definition))
|
| 81 | -32x | +31 | +28x |
- as.character(unique(df[[.var]])),+ checkmate::assert_string(response_definition) |
| 82 | -32x | +32 | +28x |
- id_satisfy_filters,+ assert_proportion_value(conf_level) |
| 83 | -32x | +33 | +27x |
- denom = denom,+ list( |
| 84 | -32x | +34 | +27x |
- .N_col = .N_col,+ response_definition = response_definition, |
| 85 | -32x | +35 | +27x |
- .N_row = .N_row+ conf_level = conf_level |
| 86 | +36 |
) |
||
| 87 | -32x | +|||
| 37 | +
- result+ }+ |
+
| 1 | ++ |
+ #' Sort pharmacokinetic data by `PARAM` variable |
|
| 88 | +2 |
- }+ #' |
|
| 89 | +3 |
-
+ #' @description `r lifecycle::badge("stable")`
|
|
| 90 | +4 |
- #' @describeIn count_patients_with_event Formatted analysis function which is used as `afun`+ #' |
|
| 91 | +5 |
- #' in `count_patients_with_event()`.+ #' @param pk_data (`data.frame`)\cr pharmacokinetic data frame. |
|
| 92 | +6 |
- #'+ #' @param key_var (`string`)\cr key variable used to merge pk_data and metadata created by [d_pkparam()]. |
|
| 93 | +7 |
- #' @return+ #' |
|
| 94 | +8 |
- #' * `a_count_patients_with_event()` returns the corresponding list with formatted [rtables::CellValue()].+ #' @return A pharmacokinetic `data.frame` sorted by a `PARAM` variable. |
|
| 95 | +9 |
#' |
|
| 96 | +10 |
#' @examples |
|
| 97 | +11 |
- #' # `a_count_patients_with_event()`+ #' library(dplyr) |
|
| 98 | +12 |
#' |
|
| 99 | +13 |
- #' a_count_patients_with_event(+ #' adpp <- tern_ex_adpp %>% mutate(PKPARAM = factor(paste0(PARAM, " (", AVALU, ")")))
|
|
| 100 | +14 |
- #' tern_ex_adae,+ #' pk_ordered_data <- h_pkparam_sort(adpp) |
|
| 101 | +15 |
- #' .var = "SUBJID",+ #' |
|
| 102 | +16 |
- #' filters = c("TRTEMFL" = "Y"),
+ #' @export |
|
| 103 | +17 |
- #' .N_col = 100,+ h_pkparam_sort <- function(pk_data, key_var = "PARAMCD") {
+ |
+ |
| 18 | +4x | +
+ assert_df_with_variables(pk_data, list(key_var = key_var))+ |
+ |
| 19 | +4x | +
+ pk_data$PARAMCD <- pk_data[[key_var]] |
|
| 104 | +20 |
- #' .N_row = 100+ + |
+ |
| 21 | +4x | +
+ ordered_pk_data <- d_pkparam() |
|
| 105 | +22 |
- #' )+ |
|
| 106 | +23 |
- #'+ # Add the numeric values from ordered_pk_data to pk_data+ |
+ |
| 24 | +4x | +
+ joined_data <- merge(pk_data, ordered_pk_data, by = "PARAMCD", suffixes = c("", ".y"))
|
|
| 107 | +25 |
- #' @export+ + |
+ |
| 26 | +4x | +
+ joined_data <- joined_data[, -grep(".*.y$", colnames(joined_data))]
|
|
| 108 | +27 |
- a_count_patients_with_event <- make_afun(+ + |
+ |
| 28 | +4x | +
+ joined_data$TLG_ORDER <- as.numeric(joined_data$TLG_ORDER) |
|
| 109 | +29 |
- s_count_patients_with_event,+ |
|
| 110 | +30 |
- .formats = c(count_fraction = format_count_fraction_fixed_dp)+ # Then order PARAM based on this column+ |
+ |
| 31 | +4x | +
+ joined_data$PARAM <- factor(joined_data$PARAM,+ |
+ |
| 32 | +4x | +
+ levels = unique(joined_data$PARAM[order(joined_data$TLG_ORDER)]),+ |
+ |
| 33 | +4x | +
+ ordered = TRUE |
|
| 111 | +34 |
- )+ ) |
|
| 112 | +35 | ||
| 113 | -+ | ||
| 36 | +4x |
- #' @describeIn count_patients_with_event Layout-creating function which can take statistics function+ joined_data$TLG_DISPLAY <- factor(joined_data$TLG_DISPLAY,+ |
+ |
| 37 | +4x | +
+ levels = unique(joined_data$TLG_DISPLAY[order(joined_data$TLG_ORDER)]),+ |
+ |
| 38 | +4x | +
+ ordered = TRUE |
|
| 114 | +39 |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ ) |
|
| 115 | +40 |
- #'+ + |
+ |
| 41 | +4x | +
+ joined_data |
|
| 116 | +42 |
- #' @return+ } |
| 117 | +1 |
- #' * `count_patients_with_event()` returns a layout object suitable for passing to further layouting functions,+ #' Class for `CombinationFunction` |
||
| 118 | +2 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 119 | +3 |
- #' the statistics from `s_count_patients_with_event()` to the table layout.+ #' @description `r lifecycle::badge("stable")`
|
||
| 120 | +4 |
#' |
||
| 121 | +5 |
- #' @examples+ #' `CombinationFunction` is an S4 class which extends standard functions. These are special functions that |
||
| 122 | +6 |
- #' # `count_patients_with_event()`+ #' can be combined and negated with the logical operators. |
||
| 123 | +7 |
#' |
||
| 124 | +8 |
- #' lyt <- basic_table() %>%+ #' @param e1 (`CombinationFunction`)\cr left hand side of logical operator. |
||
| 125 | +9 |
- #' split_cols_by("ARM") %>%
+ #' @param e2 (`CombinationFunction`)\cr right hand side of logical operator. |
||
| 126 | +10 |
- #' add_colcounts() %>%+ #' @param x (`CombinationFunction`)\cr the function which should be negated. |
||
| 127 | +11 |
- #' count_values(+ #' |
||
| 128 | +12 |
- #' "STUDYID",+ #' @return A logical value indicating whether the left hand side of the equation equals the right hand side. |
||
| 129 | +13 |
- #' values = "AB12345",+ #' |
||
| 130 | +14 |
- #' .stats = "count",+ #' @examples |
||
| 131 | +15 |
- #' .labels = c(count = "Total AEs")+ #' higher <- function(a) {
|
||
| 132 | +16 |
- #' ) %>%+ #' force(a) |
||
| 133 | +17 |
- #' count_patients_with_event(+ #' CombinationFunction( |
||
| 134 | +18 |
- #' "SUBJID",+ #' function(x) {
|
||
| 135 | +19 |
- #' filters = c("TRTEMFL" = "Y"),
+ #' x > a |
||
| 136 | +20 |
- #' .labels = c(count_fraction = "Total number of patients with at least one adverse event"),+ #' } |
||
| 137 | +21 |
- #' table_names = "tbl_all"+ #' ) |
||
| 138 | +22 |
- #' ) %>%+ #' } |
||
| 139 | +23 |
- #' count_patients_with_event(+ #' |
||
| 140 | +24 |
- #' "SUBJID",+ #' lower <- function(b) {
|
||
| 141 | +25 |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
+ #' force(b) |
||
| 142 | +26 |
- #' .labels = c(count_fraction = "Total number of patients with fatal AEs"),+ #' CombinationFunction( |
||
| 143 | +27 |
- #' table_names = "tbl_fatal"+ #' function(x) {
|
||
| 144 | +28 |
- #' ) %>%+ #' x < b |
||
| 145 | +29 |
- #' count_patients_with_event(+ #' } |
||
| 146 | +30 |
- #' "SUBJID",+ #' ) |
||
| 147 | +31 |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL", "AEREL" = "Y"),
+ #' } |
||
| 148 | +32 |
- #' .labels = c(count_fraction = "Total number of patients with related fatal AEs"),+ #' |
||
| 149 | +33 |
- #' .indent_mods = c(count_fraction = 2L),+ #' c1 <- higher(5) |
||
| 150 | +34 |
- #' table_names = "tbl_rel_fatal"+ #' c2 <- lower(10) |
||
| 151 | +35 |
- #' )+ #' c3 <- higher(5) & lower(10) |
||
| 152 | +36 |
- #'+ #' c3(7) |
||
| 153 | +37 |
- #' build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl)+ #' |
||
| 154 | +38 |
- #'+ #' @name combination_function |
||
| 155 | +39 |
- #' @export+ #' @aliases CombinationFunction-class |
||
| 156 | +40 |
- #' @order 2+ #' @exportClass CombinationFunction |
||
| 157 | +41 |
- count_patients_with_event <- function(lyt,+ #' @export CombinationFunction |
||
| 158 | +42 |
- vars,+ CombinationFunction <- methods::setClass("CombinationFunction", contains = "function") # nolint
|
||
| 159 | +43 |
- filters,+ |
||
| 160 | +44 |
- riskdiff = FALSE,+ #' @describeIn combination_function Logical "AND" combination of `CombinationFunction` functions. |
||
| 161 | +45 |
- na_str = default_na_str(),+ #' The resulting object is of the same class, and evaluates the two argument functions. The result |
||
| 162 | +46 |
- nested = TRUE,+ #' is then the "AND" of the two individual results. |
||
| 163 | +47 |
- ...,+ #' |
||
| 164 | +48 |
- table_names = vars,+ #' @export |
||
| 165 | +49 |
- .stats = "count_fraction",+ methods::setMethod( |
||
| 166 | +50 |
- .formats = NULL,+ "&", |
||
| 167 | +51 |
- .labels = NULL,+ signature = c(e1 = "CombinationFunction", e2 = "CombinationFunction"), |
||
| 168 | +52 |
- .indent_mods = NULL) {
+ definition = function(e1, e2) {
|
||
| 169 | -7x | +53 | +4x |
- checkmate::assert_flag(riskdiff)+ CombinationFunction(function(...) {
|
| 170 | -+ | |||
| 54 | +490x |
-
+ e1(...) && e2(...) |
||
| 171 | -7x | +|||
| 55 | +
- s_args <- list(filters = filters, ...)+ }) |
|||
| 172 | +56 |
-
+ } |
||
| 173 | -7x | +|||
| 57 | +
- afun <- make_afun(+ ) |
|||
| 174 | -7x | +|||
| 58 | +
- a_count_patients_with_event,+ |
|||
| 175 | -7x | +|||
| 59 | +
- .stats = .stats,+ #' @describeIn combination_function Logical "OR" combination of `CombinationFunction` functions. |
|||
| 176 | -7x | +|||
| 60 | +
- .formats = .formats,+ #' The resulting object is of the same class, and evaluates the two argument functions. The result |
|||
| 177 | -7x | +|||
| 61 | +
- .labels = .labels,+ #' is then the "OR" of the two individual results. |
|||
| 178 | -7x | +|||
| 62 | +
- .indent_mods = .indent_mods+ #' |
|||
| 179 | +63 |
- )+ #' @export |
||
| 180 | +64 |
-
+ methods::setMethod( |
||
| 181 | -7x | +|||
| 65 | +
- extra_args <- if (isFALSE(riskdiff)) {
+ "|", |
|||
| 182 | -5x | +|||
| 66 | +
- s_args+ signature = c(e1 = "CombinationFunction", e2 = "CombinationFunction"), |
|||
| 183 | +67 |
- } else {
+ definition = function(e1, e2) {
|
||
| 184 | +68 | 2x |
- list(+ CombinationFunction(function(...) {
|
|
| 185 | -2x | +69 | +4x |
- afun = list("s_count_patients_with_event" = afun),
+ e1(...) || e2(...) |
| 186 | -2x | +|||
| 70 | +
- .stats = .stats,+ }) |
|||
| 187 | -2x | +|||
| 71 | +
- .indent_mods = .indent_mods,+ } |
|||
| 188 | -2x | +|||
| 72 | +
- s_args = s_args+ ) |
|||
| 189 | +73 |
- )+ |
||
| 190 | +74 |
- }+ #' @describeIn combination_function Logical negation of `CombinationFunction` functions. |
||
| 191 | +75 |
-
+ #' The resulting object is of the same class, and evaluates the original function. The result |
||
| 192 | -7x | +|||
| 76 | +
- analyze(+ #' is then the opposite of this results. |
|||
| 193 | -7x | +|||
| 77 | +
- lyt,+ #' |
|||
| 194 | -7x | +|||
| 78 | +
- vars,+ #' @export |
|||
| 195 | -7x | +|||
| 79 | +
- afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ methods::setMethod( |
|||
| 196 | -7x | +|||
| 80 | +
- na_str = na_str,+ "!", |
|||
| 197 | -7x | +|||
| 81 | +
- nested = nested,+ signature = c(x = "CombinationFunction"), |
|||
| 198 | -7x | +|||
| 82 | +
- extra_args = extra_args,+ definition = function(x) {
|
|||
| 199 | -7x | +83 | +2x |
- show_labels = ifelse(length(vars) > 1, "visible", "hidden"),+ CombinationFunction(function(...) {
|
| 200 | -7x | +84 | +305x |
- table_names = table_names+ !x(...) |
| 201 | +85 |
- )+ }) |
||
| 202 | +86 |
- }+ }+ |
+ ||
| 87 | ++ |
+ ) |
| 1 |
- #' Control function for logistic regression model fitting+ #' Helper function for tabulation of a single biomarker result |
||
| 5 |
- #' This is an auxiliary function for controlling arguments for logistic regression models.+ #' Please see [h_tab_surv_one_biomarker()] and [h_tab_rsp_one_biomarker()], which use this function for examples. |
||
| 6 |
- #' `conf_level` refers to the confidence level used for the Odds Ratio CIs.+ #' This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 9 |
- #' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`.+ #' @param df (`data.frame`)\cr results for a single biomarker. |
||
| 10 |
- #' This will be used when fitting the logistic regression model on the left hand side of the formula.+ #' @param afuns (named `list` of `function`)\cr analysis functions. |
||
| 11 |
- #' Note that the evaluated expression should result in either a logical vector or a factor with 2+ #' @param colvars (named `list`)\cr named list with elements `vars` (variables to tabulate) and `labels` (their labels). |
||
| 12 |
- #' levels. By default this is just `"response"` such that the original response variable is used+ #' |
||
| 13 |
- #' and not modified further.+ #' @return An `rtables` table object with statistics in columns. |
||
| 15 |
- #' @return A list of components with the same names as the arguments.+ #' @export |
||
| 16 |
- #'+ h_tab_one_biomarker <- function(df, |
||
| 17 |
- #' @examples+ afuns, |
||
| 18 |
- #' # Standard options.+ colvars, |
||
| 19 |
- #' control_logistic()+ na_str = default_na_str(), |
||
| 20 |
- #'+ .indent_mods = 0L, |
||
| 21 |
- #' # Modify confidence level.+ ...) {
|
||
| 22 | -+ | 18x |
- #' control_logistic(conf_level = 0.9)+ extra_args <- list(...) |
| 23 |
- #'+ |
||
| 24 |
- #' # Use a different response definition.+ # Create "ci" column from "lcl" and "ucl" |
||
| 25 | -+ | 18x |
- #' control_logistic(response_definition = "I(response %in% c('CR', 'PR'))")
+ df$ci <- combine_vectors(df$lcl, df$ucl) |
| 26 |
- #'+ |
||
| 27 | -+ | 18x |
- #' @export+ lyt <- basic_table() |
| 28 |
- control_logistic <- function(response_definition = "response",+ |
||
| 29 |
- conf_level = 0.95) {
+ # Row split by row type - only keep the content rows here. |
||
| 30 | -29x | +18x |
- checkmate::assert_true(grepl("response", response_definition))
+ lyt <- split_rows_by( |
| 31 | -28x | +18x |
- checkmate::assert_string(response_definition)+ lyt = lyt, |
| 32 | -28x | +18x |
- assert_proportion_value(conf_level)+ var = "row_type", |
| 33 | -27x | +18x |
- list(+ split_fun = keep_split_levels("content"),
|
| 34 | -27x | +18x |
- response_definition = response_definition,+ nested = FALSE |
| 35 | -27x | +
- conf_level = conf_level+ ) |
|
| 36 |
- )+ |
||
| 37 |
- }+ # Summarize rows with all patients. |
| 1 | -+ | |||
| 38 | +18x |
- #' Control function for incidence rate+ lyt <- summarize_row_groups( |
||
| 2 | -+ | |||
| 39 | +18x |
- #'+ lyt = lyt, |
||
| 3 | -+ | |||
| 40 | +18x |
- #' @description `r lifecycle::badge("stable")`
+ var = "var_label", |
||
| 4 | -+ | |||
| 41 | +18x |
- #'+ cfun = afuns, |
||
| 5 | -+ | |||
| 42 | +18x |
- #' This is an auxiliary function for controlling arguments for the incidence rate, used+ na_str = na_str, |
||
| 6 | -+ | |||
| 43 | +18x |
- #' internally to specify details in `s_incidence_rate()`.+ indent_mod = .indent_mods, |
||
| 7 | -+ | |||
| 44 | +18x |
- #'+ extra_args = extra_args |
||
| 8 | +45 |
- #' @inheritParams argument_convention+ ) |
||
| 9 | +46 |
- #' @param conf_type (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`+ |
||
| 10 | +47 |
- #' for confidence interval type.+ # Split cols by the multiple variables to populate into columns. |
||
| 11 | -+ | |||
| 48 | +18x |
- #' @param input_time_unit (`string`)\cr `day`, `week`, `month`, or `year` (default)+ lyt <- split_cols_by_multivar( |
||
| 12 | -+ | |||
| 49 | +18x |
- #' indicating time unit for data input.+ lyt = lyt, |
||
| 13 | -+ | |||
| 50 | +18x |
- #' @param num_pt_year (`numeric(1)`)\cr number of patient-years to use when calculating adverse event rates.+ vars = colvars$vars, |
||
| 14 | -+ | |||
| 51 | +18x |
- #'+ varlabels = colvars$labels |
||
| 15 | +52 |
- #' @return A list of components with the same names as the arguments.+ ) |
||
| 16 | +53 |
- #'+ |
||
| 17 | +54 |
- #' @seealso [incidence_rate]+ # If there is any subgroup variables, we extend the layout accordingly. |
||
| 18 | -+ | |||
| 55 | +18x |
- #'+ if ("analysis" %in% df$row_type) {
|
||
| 19 | +56 |
- #' @examples+ # Now only continue with the subgroup rows. |
||
| 20 | -+ | |||
| 57 | +10x |
- #' control_incidence_rate(0.9, "exact", "month", 100)+ lyt <- split_rows_by( |
||
| 21 | -+ | |||
| 58 | +10x |
- #'+ lyt = lyt, |
||
| 22 | -+ | |||
| 59 | +10x |
- #' @export+ var = "row_type", |
||
| 23 | -+ | |||
| 60 | +10x |
- control_incidence_rate <- function(conf_level = 0.95,+ split_fun = keep_split_levels("analysis"),
+ |
+ ||
| 61 | +10x | +
+ nested = FALSE,+ |
+ ||
| 62 | +10x | +
+ child_labels = "hidden" |
||
| 24 | +63 |
- conf_type = c("normal", "normal_log", "exact", "byar"),
+ ) |
||
| 25 | +64 |
- input_time_unit = c("year", "day", "week", "month"),
+
|
||
| 26 | +65 |
- num_pt_year = 100) {
+ # Split by the subgroup variable. |
||
| 27 | -14x | +66 | +10x |
- conf_type <- match.arg(conf_type)+ lyt <- split_rows_by( |
| 28 | -13x | +67 | +10x |
- input_time_unit <- match.arg(input_time_unit)+ lyt = lyt, |
| 29 | -12x | +68 | +10x |
- checkmate::assert_number(num_pt_year)+ var = "var", |
| 30 | -11x | +69 | +10x |
- assert_proportion_value(conf_level)+ labels_var = "var_label",+ |
+
| 70 | +10x | +
+ nested = TRUE,+ |
+ ||
| 71 | +10x | +
+ child_labels = "visible",+ |
+ ||
| 72 | +10x | +
+ indent_mod = .indent_mods * 2 |
||
| 31 | +73 | ++ |
+ )+ |
+ |
| 74 | ||||
| 75 | ++ |
+ # Then analyze colvars for each subgroup.+ |
+ ||
| 32 | +76 | 10x |
- list(+ lyt <- summarize_row_groups( |
|
| 33 | +77 | 10x |
- conf_level = conf_level,+ lyt = lyt, |
|
| 34 | +78 | 10x |
- conf_type = conf_type,+ cfun = afuns, |
|
| 35 | +79 | 10x |
- input_time_unit = input_time_unit,+ var = "subgroup", |
|
| 36 | +80 | 10x |
- num_pt_year = num_pt_year+ na_str = na_str,+ |
+ |
| 81 | +10x | +
+ extra_args = extra_args |
||
| 37 | +82 |
- )+ ) |
||
| 38 | +83 | ++ |
+ }+ |
+ |
| 84 | +18x | +
+ build_table(lyt, df = df)+ |
+ ||
| 85 |
} |