| 1 |
- #' Add Titles, Footnotes, Page Number, and a Bounding Box to a Grid Grob+ #' Create a STEP Graph |
||
| 5 |
- #' This function is useful to label grid grobs (also `ggplot2`, and `lattice` plots)+ #' Based on the STEP results, creates a `ggplot` graph showing the estimated HR or OR |
||
| 6 |
- #' with title, footnote, and page numbers.+ #' along the continuous biomarker value subgroups. |
||
| 8 |
- #' @inheritParams grid::grob+ #' @param df (`tibble`)\cr result of [tidy.step()]. |
||
| 9 |
- #' @param grob a grid grob object, optionally `NULL` if only a `grob` with the decoration should be shown.+ #' @param use_percentile (`flag`)\cr whether to use percentiles for the x axis or actual |
||
| 10 |
- #' @param titles vector of character strings. Vector elements are separated by a newline and strings are wrapped+ #' biomarker values. |
||
| 11 |
- #' according to the page width.+ #' @param est (named `list`)\cr `col` and `lty` settings for estimate line. |
||
| 12 |
- #' @param footnotes vector of character string. Same rules as for `titles`.+ #' @param ci_ribbon (named `list` or `NULL`)\cr `fill` and `alpha` settings for the confidence interval |
||
| 13 |
- #' @param page string with page numeration, if `NULL` then no page number is displayed.+ #' ribbon area, or `NULL` to not plot a CI ribbon. |
||
| 14 |
- #' @param width_titles unit object+ #' @param col (`character`)\cr colors. |
||
| 15 |
- #' @param width_footnotes unit object+ #' |
||
| 16 |
- #' @param border boolean, whether a a border should be drawn around the plot or not.+ #' @return A `ggplot` STEP graph. |
||
| 17 |
- #' @param margins unit object of length 4+ #' |
||
| 18 |
- #' @param padding unit object of length 4+ #' @seealso Custom tidy method [tidy.step()]. |
||
| 19 |
- #' @param outer_margins unit object of length 4+ #' |
||
| 20 |
- #' @param gp_titles a `gpar` object+ #' @examples |
||
| 21 |
- #' @param gp_footnotes a `gpar` object+ #' library(nestcolor) |
||
| 22 |
- #'+ #' library(survival) |
||
| 23 |
- #' @return A grid grob (`gTree`).+ #' lung$sex <- factor(lung$sex) |
||
| 25 |
- #' @details The titles and footnotes will be ragged, i.e. each title will be wrapped individually.+ #' # Survival example. |
||
| 26 |
- #'+ #' vars <- list( |
||
| 27 |
- #' @examples+ #' time = "time", |
||
| 28 |
- #' library(grid)+ #' event = "status", |
||
| 29 |
- #'+ #' arm = "sex", |
||
| 30 |
- #' titles <- c(+ #' biomarker = "age" |
||
| 31 |
- #' "Edgar Anderson's Iris Data",+ #' ) |
||
| 32 |
- #' paste(+ #' |
||
| 33 |
- #' "This famous (Fisher's or Anderson's) iris data set gives the measurements",+ #' step_matrix <- fit_survival_step( |
||
| 34 |
- #' "in centimeters of the variables sepal length and width and petal length",+ #' variables = vars, |
||
| 35 |
- #' "and width, respectively, for 50 flowers from each of 3 species of iris."+ #' data = lung, |
||
| 36 |
- #' )+ #' control = c(control_coxph(), control_step(num_points = 10, degree = 2)) |
||
| 38 |
- #'+ #' step_data <- broom::tidy(step_matrix) |
||
| 39 |
- #' footnotes <- c(+ #' |
||
| 40 |
- #' "The species are Iris setosa, versicolor, and virginica.",+ #' # Default plot. |
||
| 41 |
- #' paste(+ #' g_step(step_data) |
||
| 42 |
- #' "iris is a data frame with 150 cases (rows) and 5 variables (columns) named",+ #' |
||
| 43 |
- #' "Sepal.Length, Sepal.Width, Petal.Length, Petal.Width, and Species."+ #' # Add the reference 1 horizontal line. |
||
| 44 |
- #' )+ #' library(ggplot2) |
||
| 45 |
- #' )+ #' g_step(step_data) + |
||
| 46 |
- #'+ #' ggplot2::geom_hline(ggplot2::aes(yintercept = 1), linetype = 2) |
||
| 47 |
- #' ## empty plot+ #' |
||
| 48 |
- #' grid.newpage()+ #' # Use actual values instead of percentiles, different color for estimate and no CI, |
||
| 49 |
- #'+ #' # use log scale for y axis. |
||
| 50 |
- #' grid.draw(+ #' g_step( |
||
| 51 |
- #' decorate_grob(+ #' step_data, |
||
| 52 |
- #' NULL,+ #' use_percentile = FALSE, |
||
| 53 |
- #' titles = titles,+ #' est = list(col = "blue", lty = 1), |
||
| 54 |
- #' footnotes = footnotes,+ #' ci_ribbon = NULL |
||
| 55 |
- #' page = "Page 4 of 10"+ #' ) + scale_y_log10() |
||
| 56 |
- #' )+ #' |
||
| 57 |
- #' )+ #' # Adding another curve based on additional column. |
||
| 58 |
- #'+ #' step_data$extra <- exp(step_data$`Percentile Center`) |
||
| 59 |
- #' # grid+ #' g_step(step_data) + |
||
| 60 |
- #' p <- gTree(+ #' ggplot2::geom_line(ggplot2::aes(y = extra), linetype = 2, color = "green") |
||
| 61 |
- #' children = gList(+ #' |
||
| 62 |
- #' rectGrob(),+ #' # Response example. |
||
| 63 |
- #' xaxisGrob(),+ #' vars <- list( |
||
| 64 |
- #' yaxisGrob(),+ #' response = "status", |
||
| 65 |
- #' textGrob("Sepal.Length", y = unit(-4, "lines")),
+ #' arm = "sex", |
||
| 66 |
- #' textGrob("Petal.Length", x = unit(-3.5, "lines"), rot = 90),
+ #' biomarker = "age" |
||
| 67 |
- #' pointsGrob(iris$Sepal.Length, iris$Petal.Length, gp = gpar(col = iris$Species), pch = 16)+ #' ) |
||
| 68 |
- #' ),+ #' |
||
| 69 |
- #' vp = vpStack(plotViewport(), dataViewport(xData = iris$Sepal.Length, yData = iris$Petal.Length))+ #' step_matrix <- fit_rsp_step( |
||
| 70 |
- #' )+ #' variables = vars, |
||
| 71 |
- #' grid.newpage()+ #' data = lung, |
||
| 72 |
- #' grid.draw(p)+ #' control = c( |
||
| 73 |
- #'+ #' control_logistic(response_definition = "I(response == 2)"), |
||
| 74 |
- #' grid.newpage()+ #' control_step() |
||
| 75 |
- #' grid.draw(+ #' ) |
||
| 76 |
- #' decorate_grob(+ #' ) |
||
| 77 |
- #' grob = p,+ #' step_data <- broom::tidy(step_matrix) |
||
| 78 |
- #' titles = titles,+ #' g_step(step_data) |
||
| 79 |
- #' footnotes = footnotes,+ #' |
||
| 80 |
- #' page = "Page 6 of 129"+ #' @export |
||
| 81 |
- #' )+ g_step <- function(df, |
||
| 82 |
- #' )+ use_percentile = "Percentile Center" %in% names(df), |
||
| 83 |
- #'+ est = list(col = "blue", lty = 1), |
||
| 84 |
- #' ## with ggplot2+ ci_ribbon = list(fill = getOption("ggplot2.discrete.colour")[1], alpha = 0.5),
|
||
| 85 |
- #' library(ggplot2)+ col = getOption("ggplot2.discrete.colour")) {
|
||
| 86 | -+ | 2x |
- #'+ checkmate::assert_tibble(df) |
| 87 | -+ | 2x |
- #' p_gg <- ggplot2::ggplot(iris, aes(Sepal.Length, Sepal.Width, col = Species)) ++ checkmate::assert_flag(use_percentile) |
| 88 | -+ | 2x |
- #' ggplot2::geom_point()+ checkmate::assert_character(col, null.ok = TRUE) |
| 89 | -+ | 2x |
- #' p_gg+ checkmate::assert_list(est, names = "named") |
| 90 | -+ | 2x |
- #' p <- ggplotGrob(p_gg)+ checkmate::assert_list(ci_ribbon, names = "named", null.ok = TRUE) |
| 91 |
- #' grid.newpage()+ |
||
| 92 | -+ | 2x |
- #' grid.draw(+ x_var <- ifelse(use_percentile, "Percentile Center", "Interval Center") |
| 93 | -+ | 2x |
- #' decorate_grob(+ df$x <- df[[x_var]] |
| 94 | -+ | 2x |
- #' grob = p,+ attrs <- attributes(df) |
| 95 | -+ | 2x |
- #' titles = titles,+ df$y <- df[[attrs$estimate]] |
| 96 |
- #' footnotes = footnotes,+ |
||
| 97 |
- #' page = "Page 6 of 129"+ # Set legend names. To be modified also at call level |
||
| 98 | -+ | 2x |
- #' )+ legend_names <- c("Estimate", "CI 95%")
|
| 99 |
- #' )+ |
||
| 100 | -+ | 2x |
- #'+ p <- ggplot2::ggplot(df, ggplot2::aes(x = .data[["x"]], y = .data[["y"]])) |
| 101 |
- #' ## with lattice+ |
||
| 102 | -+ | 2x |
- #' library(lattice)+ if (!is.null(col)) {
|
| 103 | -+ | 2x |
- #'+ p <- p + |
| 104 | -+ | 2x |
- #' xyplot(Sepal.Length ~ Petal.Length, data = iris, col = iris$Species)+ ggplot2::scale_color_manual(values = col) |
| 105 |
- #' p <- grid.grab()+ } |
||
| 106 |
- #' grid.newpage()+ |
||
| 107 | -+ | 2x |
- #' grid.draw(+ if (!is.null(ci_ribbon)) {
|
| 108 | -+ | 1x |
- #' decorate_grob(+ if (is.null(ci_ribbon$fill)) {
|
| 109 | -+ | ! |
- #' grob = p,+ ci_ribbon$fill <- "lightblue" |
| 110 |
- #' titles = titles,+ } |
||
| 111 | -+ | 1x |
- #' footnotes = footnotes,+ p <- p + ggplot2::geom_ribbon( |
| 112 | -+ | 1x |
- #' page = "Page 6 of 129"+ ggplot2::aes( |
| 113 | -+ | 1x |
- #' )+ ymin = .data[["ci_lower"]], ymax = .data[["ci_upper"]], |
| 114 | -+ | 1x |
- #' )+ fill = legend_names[2] |
| 115 |
- #'+ ), |
||
| 116 | -+ | 1x |
- #' # with gridExtra - no borders+ alpha = ci_ribbon$alpha |
| 117 |
- #' library(gridExtra)+ ) + |
||
| 118 | -+ | 1x |
- #' grid.newpage()+ scale_fill_manual( |
| 119 | -+ | 1x |
- #' grid.draw(+ name = "", values = c("CI 95%" = ci_ribbon$fill)
|
| 120 |
- #' decorate_grob(+ ) |
||
| 121 |
- #' tableGrob(+ } |
||
| 122 | -+ | 2x |
- #' head(mtcars)+ suppressMessages(p <- p + |
| 123 | -+ | 2x |
- #' ),+ ggplot2::geom_line( |
| 124 | -+ | 2x |
- #' titles = "title",+ ggplot2::aes(y = .data[["y"]], color = legend_names[1]), |
| 125 | -+ | 2x |
- #' footnotes = "footnote",+ linetype = est$lty |
| 126 |
- #' border = FALSE+ ) + |
||
| 127 | -+ | 2x |
- #' )+ scale_colour_manual( |
| 128 | -+ | 2x |
- #' )+ name = "", values = c("Estimate" = "blue")
|
| 129 |
- #'+ )) |
||
| 130 |
- #' @export+ |
||
| 131 | -+ | 2x |
- decorate_grob <- function(grob,+ p <- p + ggplot2::labs(x = attrs$biomarker, y = attrs$estimate) |
| 132 | -+ | 2x |
- titles,+ if (use_percentile) {
|
| 133 | -+ | 1x |
- footnotes,+ p <- p + ggplot2::scale_x_continuous(labels = scales::percent) |
| 134 |
- page = "",+ } |
||
| 135 | -+ | 2x |
- width_titles = grid::unit(1, "npc") - grid::stringWidth(page),+ p |
| 136 |
- width_footnotes = grid::unit(1, "npc") - grid::stringWidth(page),+ } |
||
| 137 |
- border = TRUE,+ |
||
| 138 |
- margins = grid::unit(c(1, 0, 1, 0), "lines"),+ #' Custom Tidy Method for STEP Results |
||
| 139 |
- padding = grid::unit(rep(1, 4), "lines"),+ #' |
||
| 140 |
- outer_margins = grid::unit(c(2, 1.5, 3, 1.5), "cm"),+ #' @description `r lifecycle::badge("stable")`
|
||
| 141 |
- gp_titles = grid::gpar(),+ #' |
||
| 142 |
- gp_footnotes = grid::gpar(fontsize = 8),+ #' Tidy the STEP results into a `tibble` format ready for plotting. |
||
| 143 |
- name = NULL,+ #' |
||
| 144 |
- gp = grid::gpar(),+ #' @param x (`step` matrix)\cr results from [fit_survival_step()]. |
||
| 145 |
- vp = NULL) {
+ #' @param ... not used here. |
||
| 146 | -8x | +
- st_titles <- split_text_grob(+ #' |
|
| 147 | -8x | +
- titles,+ #' @return A `tibble` with one row per STEP subgroup. The estimates and CIs are on the HR or OR scale, |
|
| 148 | -8x | +
- x = 0, y = 1,+ #' respectively. Additional attributes carry metadata also used for plotting. |
|
| 149 | -8x | +
- just = c("left", "top"),
+ #' |
|
| 150 | -8x | +
- width = width_titles,+ #' @seealso [g_step()] which consumes the result from this function. |
|
| 151 | -8x | +
- vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 1),+ #' |
|
| 152 | -8x | +
- gp = gp_titles+ #' @method tidy step |
|
| 153 |
- )+ #' |
||
| 154 |
-
+ #' @examples |
||
| 155 | -8x | +
- st_footnotes <- split_text_grob(+ #' library(survival) |
|
| 156 | -8x | +
- footnotes,+ #' lung$sex <- factor(lung$sex) |
|
| 157 | -8x | +
- x = 0, y = 1,+ #' vars <- list( |
|
| 158 | -8x | +
- just = c("left", "top"),
+ #' time = "time", |
|
| 159 | -8x | +
- width = width_footnotes,+ #' event = "status", |
|
| 160 | -8x | +
- vp = grid::viewport(layout.pos.row = 3, layout.pos.col = 1),+ #' arm = "sex", |
|
| 161 | -8x | +
- gp = gp_footnotes+ #' biomarker = "age" |
|
| 162 |
- )+ #' ) |
||
| 163 |
-
+ #' step_matrix <- fit_survival_step( |
||
| 164 | -8x | +
- grid::gTree(+ #' variables = vars, |
|
| 165 | -8x | +
- grob = grob,+ #' data = lung, |
|
| 166 | -8x | +
- titles = titles,+ #' control = c(control_coxph(), control_step(num_points = 10, degree = 2)) |
|
| 167 | -8x | +
- footnotes = footnotes,+ #' ) |
|
| 168 | -8x | +
- page = page,+ #' broom::tidy(step_matrix) |
|
| 169 | -8x | +
- width_titles = width_titles,+ #' |
|
| 170 | -8x | +
- width_footnotes = width_footnotes,+ #' @export |
|
| 171 | -8x | +
- border = border,+ tidy.step <- function(x, ...) { # nolint
|
|
| 172 | -8x | +7x |
- margins = margins,+ checkmate::assert_class(x, "step") |
| 173 | -8x | +7x |
- padding = padding,+ dat <- as.data.frame(x) |
| 174 | -8x | +7x |
- outer_margins = outer_margins,+ nams <- names(dat) |
| 175 | -8x | +7x |
- gp_titles = gp_titles,+ is_surv <- "loghr" %in% names(dat) |
| 176 | -8x | +7x |
- gp_footnotes = gp_footnotes,+ est_var <- ifelse(is_surv, "loghr", "logor") |
| 177 | -8x | +7x |
- children = grid::gList(+ new_est_var <- ifelse(is_surv, "Hazard Ratio", "Odds Ratio") |
| 178 | -8x | +7x |
- grid::gTree(+ new_y_vars <- c(new_est_var, c("ci_lower", "ci_upper"))
|
| 179 | -8x | +7x |
- children = grid::gList(+ names(dat)[match(est_var, nams)] <- new_est_var |
| 180 | -8x | +7x |
- st_titles,+ dat[, new_y_vars] <- exp(dat[, new_y_vars]) |
| 181 | -8x | +7x |
- grid::gTree(+ any_is_na <- any(is.na(dat[, new_y_vars])) |
| 182 | -8x | +7x |
- children = grid::gList(+ any_is_very_large <- any(abs(dat[, new_y_vars]) > 1e10, na.rm = TRUE) |
| 183 | -8x | +7x |
- if (border) grid::rectGrob(),+ if (any_is_na) {
|
| 184 | -8x | +2x |
- grid::gTree(+ warning(paste( |
| 185 | -8x | +2x |
- children = grid::gList(+ "Missing values in the point estimate or CI columns,", |
| 186 | -8x | +2x |
- grob+ "this will lead to holes in the `g_step()` plot" |
| 187 |
- ),+ )) |
||
| 188 | -8x | +
- vp = grid::plotViewport(margins = padding)+ } |
|
| 189 | -+ | 7x |
- )+ if (any_is_very_large) {
|
| 190 | -+ | 2x |
- ),+ warning(paste( |
| 191 | -8x | +2x |
- vp = grid::vpStack(+ "Very large absolute values in the point estimate or CI columns,", |
| 192 | -8x | +2x |
- grid::viewport(layout.pos.row = 2, layout.pos.col = 1),+ "consider adding `scale_y_log10()` to the `g_step()` result for plotting" |
| 193 | -8x | +
- grid::plotViewport(margins = margins)+ )) |
|
| 194 |
- )+ } |
||
| 195 | -+ | 7x |
- ),+ if (any_is_na || any_is_very_large) {
|
| 196 | -8x | +4x |
- st_footnotes,+ warning("Consider using larger `bandwidth`, less `num_points` in `control_step()` settings for fitting")
|
| 197 | -8x | +
- grid::textGrob(+ } |
|
| 198 | -8x | +7x |
- page,+ structure( |
| 199 | -8x | +7x |
- x = 1, y = 0,+ tibble::as_tibble(dat), |
| 200 | -8x | +7x |
- just = c("right", "bottom"),
+ estimate = new_est_var, |
| 201 | -8x | +7x |
- vp = grid::viewport(layout.pos.row = 3, layout.pos.col = 1),+ biomarker = attr(x, "variables")$biomarker, |
| 202 | -8x | +7x |
- gp = gp_footnotes+ ci = f_conf_level(attr(x, "control")$conf_level) |
| 203 |
- )+ ) |
||
| 204 |
- ),- |
- ||
| 205 | -8x | -
- childrenvp = NULL,+ } |
|
| 206 | -8x | +
| 1 | +
- name = "titles_grob_footnotes",+ #' Incidence Rate |
|||
| 207 | -8x | +|||
| 2 | +
- vp = grid::vpStack(+ #' |
|||
| 208 | -8x | +|||
| 3 | +
- grid::plotViewport(margins = outer_margins),+ #' @description `r lifecycle::badge("stable")`
|
|||
| 209 | -8x | +|||
| 4 | +
- grid::viewport(+ #' |
|||
| 210 | -8x | +|||
| 5 | +
- layout = grid::grid.layout(+ #' Estimate the event rate adjusted for person-years at risk, otherwise known |
|||
| 211 | -8x | +|||
| 6 | +
- nrow = 3, ncol = 1,+ #' as incidence rate. Primary analysis variable is the person-years at risk. |
|||
| 212 | -8x | +|||
| 7 | +
- heights = grid::unit.c(+ #' |
|||
| 213 | -8x | +|||
| 8 | +
- grid::grobHeight(st_titles),+ #' @inheritParams argument_convention |
|||
| 214 | -8x | +|||
| 9 | +
- grid::unit(1, "null"),+ #' @param control (`list`)\cr parameters for estimation details, specified by using |
|||
| 215 | -8x | +|||
| 10 | +
- grid::grobHeight(st_footnotes)+ #' the helper function [control_incidence_rate()]. Possible parameter options are: |
|||
| 216 | +11 |
- )+ #' * `conf_level` (`proportion`)\cr confidence level for the estimated incidence rate. |
||
| 217 | +12 |
- )+ #' * `conf_type` (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar` |
||
| 218 | +13 |
- )+ #' for confidence interval type. |
||
| 219 | +14 |
- )+ #' * `input_time_unit` (`string`)\cr `day`, `week`, `month`, or `year` (default) |
||
| 220 | +15 |
- )+ #' indicating time unit for data input. |
||
| 221 | +16 |
- ),+ #' * `num_pt_year` (`numeric`)\cr time unit for desired output (in person-years). |
||
| 222 | -8x | +|||
| 17 | +
- name = name,+ #' @param n_events (`integer`)\cr number of events observed. |
|||
| 223 | -8x | +|||
| 18 | +
- gp = gp,+ #' |
|||
| 224 | -8x | +|||
| 19 | +
- vp = vp,+ #' @seealso [control_incidence_rate()] and helper functions [h_incidence_rate]. |
|||
| 225 | -8x | +|||
| 20 | +
- cl = "decoratedGrob"+ #' |
|||
| 226 | +21 |
- )+ #' @name incidence_rate |
||
| 227 | +22 |
- }+ NULL |
||
| 228 | +23 | |||
| 229 | +24 |
- #' @importFrom grid validDetails+ #' @describeIn incidence_rate Statistics function which estimates the incidence rate and the |
||
| 230 | +25 |
- #' @noRd+ #' associated confidence interval. |
||
| 231 | +26 |
- validDetails.decoratedGrob <- function(x) {
+ #' |
||
| 232 | -! | +|||
| 27 | +
- checkmate::assert_character(x$titles)+ #' @return |
|||
| 233 | -! | +|||
| 28 | +
- checkmate::assert_character(x$footnotes)+ #' * `s_incidence_rate()` returns the following statistics: |
|||
| 234 | +29 |
-
+ #' - `person_years`: Total person-years at risk. |
||
| 235 | -! | +|||
| 30 | +
- if (!is.null(x$grob)) {
+ #' - `n_events`: Total number of events observed. |
|||
| 236 | -! | +|||
| 31 | +
- checkmate::assert_true(grid::is.grob(x$grob))+ #' - `rate`: Estimated incidence rate. |
|||
| 237 | +32 |
- }+ #' - `rate_ci`: Confidence interval for the incidence rate. |
||
| 238 | -! | +|||
| 33 | +
- if (length(x$page) == 1) {
+ #' |
|||
| 239 | -! | +|||
| 34 | +
- checkmate::assert_character(x$page)+ #' @examples |
|||
| 240 | +35 |
- }+ #' library(dplyr) |
||
| 241 | -! | +|||
| 36 | +
- if (!grid::is.unit(x$outer_margins)) {
+ #' |
|||
| 242 | -! | +|||
| 37 | +
- checkmate::assert_vector(x$outer_margins, len = 4)+ #' df <- data.frame( |
|||
| 243 | +38 |
- }+ #' USUBJID = as.character(seq(6)), |
||
| 244 | -! | +|||
| 39 | +
- if (!grid::is.unit(x$margins)) {
+ #' CNSR = c(0, 1, 1, 0, 0, 0), |
|||
| 245 | -! | +|||
| 40 | +
- checkmate::assert_vector(x$margins, len = 4)+ #' AVAL = c(10.1, 20.4, 15.3, 20.8, 18.7, 23.4), |
|||
| 246 | +41 |
- }+ #' ARM = factor(c("A", "A", "A", "B", "B", "B"))
|
||
| 247 | -! | +|||
| 42 | +
- if (!grid::is.unit(x$padding)) {
+ #' ) %>% |
|||
| 248 | -! | +|||
| 43 | +
- checkmate::assert_vector(x$padding, len = 4)+ #' mutate(is_event = CNSR == 0) %>% |
|||
| 249 | +44 |
- }+ #' mutate(n_events = as.integer(is_event)) |
||
| 250 | +45 |
-
+ #' |
||
| 251 | -! | +|||
| 46 | +
- x+ #' @keywords internal |
|||
| 252 | +47 |
- }+ s_incidence_rate <- function(df, |
||
| 253 | +48 |
-
+ .var, |
||
| 254 | +49 |
- #' @importFrom grid widthDetails+ n_events, |
||
| 255 | +50 |
- #' @noRd+ is_event, |
||
| 256 | +51 |
- widthDetails.decoratedGrob <- function(x) {
+ control = control_incidence_rate()) {
|
||
| 257 | -! | +|||
| 52 | +1x |
- grid::unit(1, "null")+ if (!missing(is_event)) {
|
||
| 258 | -+ | |||
| 53 | +! |
- }+ warning("argument is_event will be deprecated. Please use n_events.")
|
||
| 259 | +54 | |||
| 260 | -+ | |||
| 55 | +! |
- #' @importFrom grid heightDetails+ if (missing(n_events)) {
|
||
| 261 | -+ | |||
| 56 | +! |
- #' @noRd+ assert_df_with_variables(df, list(tte = .var, is_event = is_event)) |
||
| 262 | -+ | |||
| 57 | +! |
- heightDetails.decoratedGrob <- function(x) {
+ checkmate::assert_string(.var) |
||
| 263 | +58 | ! |
- grid::unit(1, "null")+ checkmate::assert_logical(df[[is_event]], any.missing = FALSE) |
|
| 264 | -+ | |||
| 59 | +! |
- }+ checkmate::assert_numeric(df[[.var]], any.missing = FALSE) |
||
| 265 | -+ | |||
| 60 | +! |
-
+ n_events <- is_event |
||
| 266 | +61 |
- # Adapted from Paul Murell R Graphics 2nd Edition+ } |
||
| 267 | +62 |
- # https://www.stat.auckland.ac.nz/~paul/RG2e/interactgrid-splittext.R+ } else {
|
||
| 268 | -+ | |||
| 63 | +1x |
- split_string <- function(text, width) {
+ assert_df_with_variables(df, list(tte = .var, n_events = n_events)) |
||
| 269 | -17x | +64 | +1x |
- strings <- strsplit(text, " ")+ checkmate::assert_string(.var) |
| 270 | -17x | +65 | +1x |
- out_string <- NA+ checkmate::assert_numeric(df[[.var]], any.missing = FALSE) |
| 271 | -17x | +66 | +1x |
- for (string_i in seq_along(strings)) {
+ checkmate::assert_integer(df[[n_events]], any.missing = FALSE) |
| 272 | -17x | +|||
| 67 | +
- newline_str <- strings[[string_i]]+ } |
|||
| 273 | -6x | +|||
| 68 | +
- if (length(newline_str) == 0) newline_str <- ""+ |
|||
| 274 | -17x | +69 | +1x |
- if (is.na(out_string[string_i])) {
+ input_time_unit <- control$input_time_unit |
| 275 | -17x | +70 | +1x |
- out_string[string_i] <- newline_str[[1]][[1]]+ num_pt_year <- control$num_pt_year |
| 276 | -17x | +71 | +1x |
- linewidth <- grid::stringWidth(out_string[string_i])+ conf_level <- control$conf_level |
| 277 | -+ | |||
| 72 | +1x |
- }+ person_years <- sum(df[[.var]], na.rm = TRUE) * ( |
||
| 278 | -17x | +73 | +1x |
- gapwidth <- grid::stringWidth(" ")
+ 1 * (input_time_unit == "year") + |
| 279 | -17x | +74 | +1x |
- availwidth <- as.numeric(width)+ 1 / 12 * (input_time_unit == "month") + |
| 280 | -17x | +75 | +1x |
- if (length(newline_str) > 1) {
+ 1 / 52.14 * (input_time_unit == "week") + |
| 281 | -5x | +76 | +1x |
- for (i in seq(2, length(newline_str))) {
+ 1 / 365.24 * (input_time_unit == "day") |
| 282 | -27x | +|||
| 77 | +
- width_i <- grid::stringWidth(newline_str[i])+ ) |
|||
| 283 | -27x | +78 | +1x |
- if (grid::convertWidth(linewidth + gapwidth + width_i, grid::unitType(width), valueOnly = TRUE) < availwidth) {
+ n_events <- sum(df[[n_events]], na.rm = TRUE) |
| 284 | -25x | +|||
| 79 | +
- sep <- " "+ |
|||
| 285 | -25x | +80 | +1x |
- linewidth <- linewidth + gapwidth + width_i+ result <- h_incidence_rate( |
| 286 | -+ | |||
| 81 | +1x |
- } else {
+ person_years, |
||
| 287 | -2x | +82 | +1x |
- sep <- "\n"+ n_events, |
| 288 | -2x | +83 | +1x |
- linewidth <- width_i+ control |
| 289 | +84 |
- }+ ) |
||
| 290 | -27x | +85 | +1x |
- out_string[string_i] <- paste(out_string[string_i], newline_str[i], sep = sep)+ list( |
| 291 | -+ | |||
| 86 | +1x |
- }+ person_years = formatters::with_label(person_years, "Total patient-years at risk"), |
||
| 292 | -+ | |||
| 87 | +1x |
- }+ n_events = formatters::with_label(n_events, "Number of adverse events observed"), |
||
| 293 | -+ | |||
| 88 | +1x |
- }+ rate = formatters::with_label(result$rate, paste("AE rate per", num_pt_year, "patient-years")),
|
||
| 294 | -17x | +89 | +1x |
- paste(out_string, collapse = "\n")+ rate_ci = formatters::with_label(result$rate_ci, f_conf_level(conf_level)) |
| 295 | +90 |
- }+ ) |
||
| 296 | +91 |
-
+ } |
||
| 297 | +92 |
- #' Split Text According To Available Text Width+ |
||
| 298 | +93 |
- #'+ #' @describeIn incidence_rate Formatted analysis function which is used as `afun` |
||
| 299 | +94 |
- #' Dynamically wrap text.+ #' in `estimate_incidence_rate()`. |
||
| 300 | +95 |
#' |
||
| 301 | +96 |
- #' @inheritParams grid::grid.text+ #' @return |
||
| 302 | +97 |
- #' @param text character string+ #' * `a_incidence_rate()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 303 | +98 |
- #' @param width a unit object specifying max width of text+ #' |
||
| 304 | +99 |
#' |
||
| 305 | +100 |
- #' @return A text grob.+ #' @keywords internal |
||
| 306 | +101 |
- #'+ a_incidence_rate <- make_afun( |
||
| 307 | +102 |
- #' @details This code is taken from `R Graphics by Paul Murell, 2nd edition`+ s_incidence_rate, |
||
| 308 | +103 |
- #'+ .formats = c( |
||
| 309 | +104 |
- #' @keywords internal+ "person_years" = "xx.x", |
||
| 310 | +105 |
- split_text_grob <- function(text,+ "n_events" = "xx", |
||
| 311 | +106 |
- x = grid::unit(0.5, "npc"),+ "rate" = "xx.xx", |
||
| 312 | +107 |
- y = grid::unit(0.5, "npc"),+ "rate_ci" = "(xx.xx, xx.xx)" |
||
| 313 | +108 |
- width = grid::unit(1, "npc"),+ ) |
||
| 314 | +109 |
- just = "centre",+ ) |
||
| 315 | +110 |
- hjust = NULL,+ |
||
| 316 | +111 |
- vjust = NULL,+ #' @describeIn incidence_rate Layout-creating function which can take statistics function arguments |
||
| 317 | +112 |
- default.units = "npc", # nolint+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 318 | +113 |
- name = NULL,+ #' |
||
| 319 | +114 |
- gp = grid::gpar(),+ #' @return |
||
| 320 | +115 |
- vp = NULL) {
- |
- ||
| 321 | -16x | -
- if (!grid::is.unit(x)) x <- grid::unit(x, default.units)+ #' * `estimate_incidence_rate()` returns a layout object suitable for passing to further layouting functions, |
||
| 322 | -16x | +|||
| 116 | +
- if (!grid::is.unit(y)) y <- grid::unit(y, default.units)+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 323 | -! | +|||
| 117 | +
- if (!grid::is.unit(width)) width <- grid::unit(width, default.units)+ #' the statistics from `s_incidence_rate()` to the table layout. |
|||
| 324 | -! | +|||
| 118 | +
- if (grid::unitType(x) %in% c("sum", "min", "max")) x <- grid::convertUnit(x, default.units)
+ #' |
|||
| 325 | -! | +|||
| 119 | +
- if (grid::unitType(y) %in% c("sum", "min", "max")) y <- grid::convertUnit(y, default.units)
+ #' @examples |
|||
| 326 | -16x | +|||
| 120 | +
- if (grid::unitType(width) %in% c("sum", "min", "max")) width <- grid::convertUnit(width, default.units)
+ #' basic_table() %>% |
|||
| 327 | +121 |
-
+ #' split_cols_by("ARM") %>%
|
||
| 328 | +122 |
- ## if it is a fixed unit then we do not need to recalculate when viewport resized+ #' add_colcounts() %>% |
||
| 329 | -16x | +|||
| 123 | +
- if (!inherits(width, "unit.arithmetic") &&+ #' estimate_incidence_rate( |
|||
| 330 | -16x | +|||
| 124 | +
- !is.null(attr(width, "unit")) &&+ #' vars = "AVAL", |
|||
| 331 | -16x | +|||
| 125 | +
- attr(width, "unit") %in% c("cm", "inches", "mm", "points", "picas", "bigpts", "dida", "cicero", "scaledpts")) {
+ #' n_events = "n_events", |
|||
| 332 | -! | +|||
| 126 | +
- attr(text, "fixed_text") <- paste(vapply(text, split_string, character(1), width = width), collapse = "\n")+ #' control = control_incidence_rate( |
|||
| 333 | +127 |
- }+ #' input_time_unit = "month", |
||
| 334 | +128 |
-
+ #' num_pt_year = 100 |
||
| 335 | -16x | +|||
| 129 | +
- grid::grid.text(+ #' ) |
|||
| 336 | -16x | +|||
| 130 | +
- label = split_string(text, width),+ #' ) %>% |
|||
| 337 | -16x | +|||
| 131 | +
- x = x, y = y,+ #' build_table(df) |
|||
| 338 | -16x | +|||
| 132 | +
- just = just,+ #' |
|||
| 339 | -16x | +|||
| 133 | +
- hjust = hjust,+ #' @export |
|||
| 340 | -16x | +|||
| 134 | +
- vjust = vjust,+ estimate_incidence_rate <- function(lyt, |
|||
| 341 | -16x | +|||
| 135 | +
- rot = 0,+ vars, |
|||
| 342 | -16x | +|||
| 136 | +
- check.overlap = FALSE,+ na_str = NA_character_, |
|||
| 343 | -16x | +|||
| 137 | +
- name = name,+ nested = TRUE, |
|||
| 344 | -16x | +|||
| 138 | +
- gp = gp,+ ..., |
|||
| 345 | -16x | +|||
| 139 | +
- vp = vp,+ show_labels = "hidden", |
|||
| 346 | -16x | +|||
| 140 | +
- draw = FALSE+ table_names = vars, |
|||
| 347 | +141 |
- )+ .stats = NULL, |
||
| 348 | +142 |
- }+ .formats = NULL, |
||
| 349 | +143 |
-
+ .labels = NULL, |
||
| 350 | +144 |
- #' @importFrom grid validDetails+ .indent_mods = NULL) {
|
||
| 351 | -+ | |||
| 145 | +1x |
- #' @noRd+ afun <- make_afun( |
||
| 352 | -+ | |||
| 146 | +1x |
- validDetails.dynamicSplitText <- function(x) {
+ a_incidence_rate, |
||
| 353 | -! | +|||
| 147 | +1x |
- checkmate::assert_character(x$text)+ .stats = .stats, |
||
| 354 | -! | +|||
| 148 | +1x |
- checkmate::assert_true(grid::is.unit(x$width))+ .formats = .formats, |
||
| 355 | -! | +|||
| 149 | +1x |
- checkmate::assert_vector(x$width, len = 1)+ .labels = .labels, |
||
| 356 | -! | +|||
| 150 | +1x |
- x+ .indent_mods = .indent_mods |
||
| 357 | +151 |
- }+ ) |
||
| 358 | +152 | |||
| 359 | -+ | |||
| 153 | +1x |
- #' @importFrom grid heightDetails+ analyze( |
||
| 360 | -+ | |||
| 154 | +1x |
- #' @noRd+ lyt, |
||
| 361 | -+ | |||
| 155 | +1x |
- heightDetails.dynamicSplitText <- function(x) {
+ vars, |
||
| 362 | -! | +|||
| 156 | +1x |
- txt <- if (!is.null(attr(x$text, "fixed_text"))) {
+ show_labels = show_labels, |
||
| 363 | -! | +|||
| 157 | +1x |
- attr(x$text, "fixed_text")+ table_names = table_names, |
||
| 364 | -+ | |||
| 158 | +1x |
- } else {
+ afun = afun, |
||
| 365 | -! | +|||
| 159 | +1x |
- paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n")+ na_str = na_str, |
||
| 366 | -+ | |||
| 160 | +1x |
- }+ nested = nested, |
||
| 367 | -! | +|||
| 161 | +1x |
- grid::stringHeight(txt)+ extra_args = list(...) |
||
| 368 | +162 | ++ |
+ )+ |
+ |
| 163 |
} |
|||
| 369 | +164 | |||
| 370 | +165 |
- #' @importFrom grid widthDetails+ #' Helper Functions for Incidence Rate |
||
| 371 | +166 |
- #' @noRd+ #' |
||
| 372 | +167 |
- widthDetails.dynamicSplitText <- function(x) {
+ #' @description `r lifecycle::badge("stable")`
|
||
| 373 | -! | +|||
| 168 | +
- x$width+ #' |
|||
| 374 | +169 |
- }+ #' @param control (`list`)\cr parameters for estimation details, specified by using |
||
| 375 | +170 |
-
+ #' the helper function [control_incidence_rate()]. Possible parameter options are: |
||
| 376 | +171 |
- #' @importFrom grid drawDetails+ #' * `conf_level`: (`proportion`)\cr confidence level for the estimated incidence rate. |
||
| 377 | +172 |
- #' @noRd+ #' * `conf_type`: (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar` |
||
| 378 | +173 |
- drawDetails.dynamicSplitText <- function(x, recording) {
+ #' for confidence interval type. |
||
| 379 | -! | +|||
| 174 | +
- txt <- if (!is.null(attr(x$text, "fixed_text"))) {
+ #' * `input_time_unit`: (`string`)\cr `day`, `week`, `month`, or `year` (default) |
|||
| 380 | -! | +|||
| 175 | +
- attr(x$text, "fixed_text")+ #' indicating time unit for data input. |
|||
| 381 | +176 |
- } else {
+ #' * `num_pt_year`: (`numeric`)\cr time unit for desired output (in person-years). |
||
| 382 | -! | +|||
| 177 | +
- paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n")+ #' @param person_years (`numeric`)\cr total person-years at risk. |
|||
| 383 | +178 |
- }+ #' @param alpha (`numeric`)\cr two-sided alpha-level for confidence interval. |
||
| 384 | +179 |
-
+ #' @param n_events (`integer`)\cr number of events observed. |
||
| 385 | -! | +|||
| 180 | +
- x$width <- NULL+ #' |
|||
| 386 | -! | +|||
| 181 | +
- x$label <- txt+ #' @return Estimated incidence rate `rate` and associated confidence interval `rate_ci`. |
|||
| 387 | -! | +|||
| 182 | +
- x$text <- NULL+ #' |
|||
| 388 | -! | +|||
| 183 | +
- class(x) <- c("text", class(x)[-1])
+ #' @seealso [incidence_rate] |
|||
| 389 | +184 |
-
+ #' |
||
| 390 | -! | +|||
| 185 | +
- grid::grid.draw(x)+ #' @name h_incidence_rate |
|||
| 391 | +186 |
- }+ NULL |
||
| 392 | +187 | |||
| 393 | +188 |
- #' Update Page Number+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
||
| 394 | +189 |
- #'+ #' associated confidence interval based on the normal approximation for the |
||
| 395 | +190 |
- #' Automatically updates page number.+ #' incidence rate. Unit is one person-year. |
||
| 396 | +191 |
#' |
||
| 397 | +192 |
- #' @param npages number of pages in total+ #' @examples |
||
| 398 | +193 |
- #' @param ... passed on to [decorate_grob()]+ #' h_incidence_rate_normal(200, 2) |
||
| 399 | +194 |
#' |
||
| 400 | +195 |
- #' @return Closure that increments the page number.+ #' @export |
||
| 401 | +196 |
- #'+ h_incidence_rate_normal <- function(person_years, |
||
| 402 | +197 |
- #' @keywords internal+ n_events, |
||
| 403 | +198 |
- decorate_grob_factory <- function(npages, ...) {
+ alpha = 0.05) {
|
||
| 404 | -2x | +199 | +1x |
- current_page <- 0+ checkmate::assert_number(person_years) |
| 405 | -2x | +200 | +1x |
- function(grob) {
+ checkmate::assert_number(n_events) |
| 406 | -7x | +201 | +1x |
- current_page <<- current_page + 1+ assert_proportion_value(alpha) |
| 407 | -7x | +|||
| 202 | +
- if (current_page > npages) {
+
|
|||
| 408 | +203 | 1x |
- stop(paste("current page is", current_page, "but max.", npages, "specified."))
+ est <- n_events / person_years |
|
| 409 | -+ | |||
| 204 | +1x |
- }+ se <- sqrt(est / person_years) |
||
| 410 | -6x | +205 | +1x |
- decorate_grob(grob = grob, page = paste("Page", current_page, "of", npages), ...)
+ ci <- est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * se |
| 411 | +206 |
- }+ + |
+ ||
| 207 | +1x | +
+ list(rate = est, rate_ci = ci) |
||
| 412 | +208 |
} |
||
| 413 | +209 | |||
| 414 | +210 |
- #' Decorate Set of `grobs` and Add Page Numbering+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
||
| 415 | +211 |
- #'+ #' associated confidence interval based on the normal approximation for the |
||
| 416 | +212 |
- #' @description `r lifecycle::badge("stable")`
+ #' logarithm of the incidence rate. Unit is one person-year. |
||
| 417 | +213 |
#' |
||
| 418 | +214 |
- #' Note that this uses the [decorate_grob_factory()] function.+ #' @examples |
||
| 419 | +215 |
- #'+ #' h_incidence_rate_normal_log(200, 2) |
||
| 420 | +216 |
- #' @param grobs a list of grid grobs+ #' |
||
| 421 | +217 |
- #' @param ... arguments passed on to [decorate_grob()].+ #' @export |
||
| 422 | +218 |
- #'+ h_incidence_rate_normal_log <- function(person_years, |
||
| 423 | +219 |
- #' @return A decorated grob.+ n_events, |
||
| 424 | +220 |
- #'+ alpha = 0.05) {
|
||
| 425 | -+ | |||
| 221 | +5x |
- #' @examples+ checkmate::assert_number(person_years) |
||
| 426 | -+ | |||
| 222 | +5x |
- #' library(ggplot2)+ checkmate::assert_number(n_events) |
||
| 427 | -+ | |||
| 223 | +5x |
- #' library(grid)+ assert_proportion_value(alpha) |
||
| 428 | +224 |
- #' g <- with(data = iris, {
+
|
||
| 429 | -+ | |||
| 225 | +5x |
- #' list(+ rate_est <- n_events / person_years |
||
| 430 | -+ | |||
| 226 | +5x |
- #' ggplot2::ggplotGrob(+ rate_se <- sqrt(rate_est / person_years) |
||
| 431 | -+ | |||
| 227 | +5x |
- #' ggplot2::ggplot(mapping = aes(Sepal.Length, Sepal.Width, col = Species)) ++ lrate_est <- log(rate_est) |
||
| 432 | -+ | |||
| 228 | +5x |
- #' ggplot2::geom_point()+ lrate_se <- rate_se / rate_est |
||
| 433 | -+ | |||
| 229 | +5x |
- #' ),+ ci <- exp(lrate_est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * lrate_se) |
||
| 434 | +230 |
- #' ggplot2::ggplotGrob(+ |
||
| 435 | -+ | |||
| 231 | +5x |
- #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Length, col = Species)) ++ list(rate = rate_est, rate_ci = ci) |
||
| 436 | +232 |
- #' ggplot2::geom_point()+ } |
||
| 437 | +233 |
- #' ),+ |
||
| 438 | +234 |
- #' ggplot2::ggplotGrob(+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
||
| 439 | +235 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Width, col = Species)) ++ #' associated exact confidence interval. Unit is one person-year. |
||
| 440 | +236 |
- #' ggplot2::geom_point()+ #' |
||
| 441 | +237 |
- #' ),+ #' @examples |
||
| 442 | +238 |
- #' ggplot2::ggplotGrob(+ #' h_incidence_rate_exact(200, 2) |
||
| 443 | +239 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Length, col = Species)) ++ #' |
||
| 444 | +240 |
- #' ggplot2::geom_point()+ #' @export |
||
| 445 | +241 |
- #' ),+ h_incidence_rate_exact <- function(person_years, |
||
| 446 | +242 |
- #' ggplot2::ggplotGrob(+ n_events, |
||
| 447 | +243 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Width, col = Species)) ++ alpha = 0.05) {
+ |
+ ||
| 244 | +1x | +
+ checkmate::assert_number(person_years)+ |
+ ||
| 245 | +1x | +
+ checkmate::assert_number(n_events)+ |
+ ||
| 246 | +1x | +
+ assert_proportion_value(alpha) |
||
| 448 | +247 |
- #' ggplot2::geom_point()+ + |
+ ||
| 248 | +1x | +
+ est <- n_events / person_years+ |
+ ||
| 249 | +1x | +
+ lcl <- stats::qchisq(p = (alpha) / 2, df = 2 * n_events) / (2 * person_years)+ |
+ ||
| 250 | +1x | +
+ ucl <- stats::qchisq(p = 1 - (alpha) / 2, df = 2 * n_events + 2) / (2 * person_years) |
||
| 449 | +251 |
- #' ),+ + |
+ ||
| 252 | +1x | +
+ list(rate = est, rate_ci = c(lcl, ucl)) |
||
| 450 | +253 |
- #' ggplot2::ggplotGrob(+ } |
||
| 451 | +254 |
- #' ggplot2::ggplot(mapping = aes(Petal.Length, Petal.Width, col = Species)) ++ |
||
| 452 | +255 |
- #' ggplot2::geom_point()+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
||
| 453 | +256 |
- #' )+ #' associated `Byar`'s confidence interval. Unit is one person-year. |
||
| 454 | +257 |
- #' )+ #' |
||
| 455 | +258 |
- #' })+ #' @examples |
||
| 456 | +259 |
- #' lg <- decorate_grob_set(grobs = g, titles = "Hello\nOne\nTwo\nThree", footnotes = "")+ #' h_incidence_rate_byar(200, 2) |
||
| 457 | +260 |
#' |
||
| 458 | +261 |
- #' draw_grob(lg[[1]])+ #' @export |
||
| 459 | +262 |
- #' draw_grob(lg[[2]])+ h_incidence_rate_byar <- function(person_years, |
||
| 460 | +263 |
- #' draw_grob(lg[[6]])+ n_events, |
||
| 461 | +264 |
- #'+ alpha = 0.05) {
|
||
| 462 | -+ | |||
| 265 | +1x |
- #' @export+ checkmate::assert_number(person_years)+ |
+ ||
| 266 | +1x | +
+ checkmate::assert_number(n_events)+ |
+ ||
| 267 | +1x | +
+ assert_proportion_value(alpha) |
||
| 463 | +268 |
- decorate_grob_set <- function(grobs, ...) {
+
|
||
| 464 | +269 | 1x |
- n <- length(grobs)+ est <- n_events / person_years |
|
| 465 | +270 | 1x |
- lgf <- decorate_grob_factory(npages = n, ...)+ seg_1 <- n_events + 0.5 |
|
| 466 | +271 | 1x |
- lapply(grobs, lgf)+ seg_2 <- 1 - 1 / (9 * (n_events + 0.5))+ |
+ |
| 272 | +1x | +
+ seg_3 <- stats::qnorm(1 - alpha / 2) * sqrt(1 / (n_events + 0.5)) / 3+ |
+ ||
| 273 | +1x | +
+ lcl <- seg_1 * ((seg_2 - seg_3)^3) / person_years+ |
+ ||
| 274 | +1x | +
+ ucl <- seg_1 * ((seg_2 + seg_3) ^ 3) / person_years # styler: off |
||
| 467 | +275 | ++ | + + | +|
| 276 | +1x | +
+ list(rate = est, rate_ci = c(lcl, ucl))+ |
+ ||
| 277 | ++ |
+ }+ |
+ ||
| 278 | ++ | + + | +||
| 279 | ++ |
+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ |
+ ||
| 280 | ++ |
+ #' associated confidence interval.+ |
+ ||
| 281 | ++ |
+ #'+ |
+ ||
| 282 | ++ |
+ #'+ |
+ ||
| 283 | ++ |
+ #' @keywords internal+ |
+ ||
| 284 | ++ |
+ h_incidence_rate <- function(person_years,+ |
+ ||
| 285 | ++ |
+ n_events,+ |
+ ||
| 286 | ++ |
+ control = control_incidence_rate()) {
+ |
+ ||
| 287 | +4x | +
+ alpha <- 1 - control$conf_level+ |
+ ||
| 288 | +4x | +
+ est <- switch(control$conf_type,+ |
+ ||
| 289 | +4x | +
+ normal = h_incidence_rate_normal(person_years, n_events, alpha),+ |
+ ||
| 290 | +4x | +
+ normal_log = h_incidence_rate_normal_log(person_years, n_events, alpha),+ |
+ ||
| 291 | +4x | +
+ exact = h_incidence_rate_exact(person_years, n_events, alpha),+ |
+ ||
| 292 | +4x | +
+ byar = h_incidence_rate_byar(person_years, n_events, alpha)+ |
+ ||
| 293 | ++ |
+ )+ |
+ ||
| 294 | ++ | + + | +||
| 295 | +4x | +
+ num_pt_year <- control$num_pt_year+ |
+ ||
| 296 | +4x | +
+ list(+ |
+ ||
| 297 | +4x | +
+ rate = est$rate * num_pt_year,+ |
+ ||
| 298 | +4x | +
+ rate_ci = est$rate_ci * num_pt_year+ |
+ ||
| 299 | ++ |
+ )+ |
+ ||
| 300 |
}@@ -3386,14 +3651,14 @@ tern coverage - 94.83% |
| 1 |
- #' Helper Functions for Tabulating Survival Duration by Subgroup+ #' Helper Functions for Cox Proportional Hazards Regression |
||
| 5 |
- #' Helper functions that tabulate in a data frame statistics such as median survival+ #' Helper functions used in [fit_coxreg_univar()] and [fit_coxreg_multivar()]. |
||
| 6 |
- #' time and hazard ratio for population subgroups.+ #' |
||
| 7 |
- #'+ #' @inheritParams argument_convention |
||
| 8 |
- #' @inheritParams argument_convention+ #' @inheritParams h_coxreg_univar_extract |
||
| 9 |
- #' @inheritParams survival_coxph_pairwise+ #' @inheritParams cox_regression_inter |
||
| 10 |
- #' @inheritParams survival_duration_subgroups+ #' @inheritParams control_coxreg |
||
| 11 |
- #' @param arm (`factor`)\cr the treatment group variable.+ #' |
||
| 12 |
- #'+ #' @seealso [cox_regression] |
||
| 13 |
- #' @details Main functionality is to prepare data for use in a layout-creating function.+ #' |
||
| 14 |
- #'+ #' @name h_cox_regression |
||
| 15 |
- #' @examples+ NULL |
||
| 16 |
- #' library(dplyr)+ |
||
| 17 |
- #' library(forcats)+ #' @describeIn h_cox_regression Helper for Cox regression formula. Creates a list of formulas. It is used |
||
| 18 |
- #'+ #' internally by [fit_coxreg_univar()] for the comparison of univariate Cox regression models. |
||
| 19 |
- #' adtte <- tern_ex_adtte+ #' |
||
| 20 |
- #'+ #' @return |
||
| 21 |
- #' # Save variable labels before data processing steps.+ #' * `h_coxreg_univar_formulas()` returns a `character` vector coercible into formulas (e.g [stats::as.formula()]). |
||
| 22 |
- #' adtte_labels <- formatters::var_labels(adtte)+ #' |
||
| 23 |
- #'+ #' @examples |
||
| 24 |
- #' adtte_f <- adtte %>%+ #' # `h_coxreg_univar_formulas` |
||
| 25 |
- #' filter(+ #' |
||
| 26 |
- #' PARAMCD == "OS",+ #' ## Simple formulas. |
||
| 27 |
- #' ARM %in% c("B: Placebo", "A: Drug X"),
+ #' h_coxreg_univar_formulas( |
||
| 28 |
- #' SEX %in% c("M", "F")
+ #' variables = list( |
||
| 29 |
- #' ) %>%+ #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y")
|
||
| 30 |
- #' mutate(+ #' ) |
||
| 31 |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ #' ) |
||
| 32 |
- #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),+ #' |
||
| 33 |
- #' SEX = droplevels(SEX),+ #' ## Addition of an optional strata. |
||
| 34 |
- #' is_event = CNSR == 0+ #' h_coxreg_univar_formulas( |
||
| 35 |
- #' )+ #' variables = list( |
||
| 36 |
- #' labels <- c("ARM" = adtte_labels[["ARM"]], "SEX" = adtte_labels[["SEX"]], "is_event" = "Event Flag")
+ #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
|
||
| 37 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ #' strata = "SITE" |
||
| 38 |
- #'+ #' ) |
||
| 39 |
- #' @name h_survival_duration_subgroups+ #' ) |
||
| 40 |
- NULL+ #' |
||
| 41 |
-
+ #' ## Inclusion of the interaction term. |
||
| 42 |
- #' @describeIn h_survival_duration_subgroups helper to prepare a data frame of median survival times by arm.+ #' h_coxreg_univar_formulas( |
||
| 43 |
- #'+ #' variables = list( |
||
| 44 |
- #' @return+ #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
|
||
| 45 |
- #' * `h_survtime_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, and `median`.+ #' strata = "SITE" |
||
| 46 |
- #'+ #' ), |
||
| 47 |
- #' @examples+ #' interaction = TRUE |
||
| 48 |
- #' # Extract median survival time for one group.+ #' ) |
||
| 49 |
- #' h_survtime_df(+ #' |
||
| 50 |
- #' tte = adtte_f$AVAL,+ #' ## Only covariates fitted in separate models. |
||
| 51 |
- #' is_event = adtte_f$is_event,+ #' h_coxreg_univar_formulas( |
||
| 52 |
- #' arm = adtte_f$ARM+ #' variables = list( |
||
| 53 |
- #' )+ #' time = "time", event = "status", covariates = c("X", "y")
|
||
| 54 |
- #'+ #' ) |
||
| 55 |
- #' @export+ #' ) |
||
| 56 |
- h_survtime_df <- function(tte, is_event, arm) {
+ #' |
||
| 57 | -55x | +
- checkmate::assert_numeric(tte)+ #' @export |
|
| 58 | -54x | +
- checkmate::assert_logical(is_event, len = length(tte))+ h_coxreg_univar_formulas <- function(variables, |
|
| 59 | -54x | +
- assert_valid_factor(arm, len = length(tte))+ interaction = FALSE) {
|
|
| 60 | -+ | 41x |
-
+ checkmate::assert_list(variables, names = "named") |
| 61 | -54x | +41x |
- df_tte <- data.frame(+ has_arm <- "arm" %in% names(variables) |
| 62 | -54x | +41x |
- tte = tte,+ arm_name <- if (has_arm) "arm" else NULL |
| 63 | -54x | +
- is_event = is_event,+ |
|
| 64 | -54x | +41x |
- stringsAsFactors = FALSE+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
| 65 |
- )+ |
||
| 66 | -+ | 41x |
-
+ checkmate::assert_flag(interaction) |
| 67 |
- # Delete NAs+ |
||
| 68 | -54x | +41x |
- non_missing_rows <- stats::complete.cases(df_tte)+ if (!has_arm || is.null(variables$covariates)) {
|
| 69 | -54x | +10x |
- df_tte <- df_tte[non_missing_rows, ]+ checkmate::assert_false(interaction) |
| 70 | -54x | +
- arm <- arm[non_missing_rows]+ } |
|
| 72 | -54x | +39x |
- lst_tte <- split(df_tte, arm)+ assert_list_of_variables(variables[c(arm_name, "event", "time")]) |
| 73 | -54x | +
- lst_results <- Map(function(x, arm) {
+
|
|
| 74 | -108x | +39x |
- if (nrow(x) > 0) {
+ if (!is.null(variables$covariates)) {
|
| 75 | -104x | +38x |
- s_surv <- s_surv_time(x, .var = "tte", is_event = "is_event")+ forms <- paste0( |
| 76 | -104x | +38x |
- median_est <- unname(as.numeric(s_surv$median))+ "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
|
| 77 | -104x | +38x |
- n_events <- sum(x$is_event)+ ifelse(has_arm, variables$arm, "1"), |
| 78 | -+ | 38x |
- } else {
+ ifelse(interaction, " * ", " + "), |
| 79 | -4x | +38x |
- median_est <- NA+ variables$covariates, |
| 80 | -4x | +38x |
- n_events <- NA+ ifelse( |
| 81 | -+ | 38x |
- }+ !is.null(variables$strata), |
| 82 | -+ | 38x |
-
+ paste0(" + strata(", paste0(variables$strata, collapse = ", "), ")"),
|
| 83 | -108x | +
- data.frame(+ "" |
|
| 84 | -108x | +
- arm = arm,+ ) |
|
| 85 | -108x | +
- n = nrow(x),+ ) |
|
| 86 | -108x | +
- n_events = n_events,+ } else {
|
|
| 87 | -108x | +1x |
- median = median_est,+ forms <- NULL |
| 88 | -108x | +
- stringsAsFactors = FALSE+ } |
|
| 89 | -+ | 39x |
- )+ nams <- variables$covariates |
| 90 | -54x | +39x |
- }, lst_tte, names(lst_tte))+ if (has_arm) {
|
| 91 | -+ | 32x |
-
+ ref <- paste0( |
| 92 | -54x | +32x |
- df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE))+ "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
|
| 93 | -54x | +32x |
- df$arm <- factor(df$arm, levels = levels(arm))+ variables$arm, |
| 94 | -54x | +32x |
- df+ ifelse( |
| 95 | -+ | 32x |
- }+ !is.null(variables$strata), |
| 96 | -+ | 32x |
-
+ paste0( |
| 97 | -+ | 32x |
- #' @describeIn h_survival_duration_subgroups summarizes median survival times by arm and across subgroups+ " + strata(", paste0(variables$strata, collapse = ", "), ")"
|
| 98 |
- #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and+ ), |
||
| 99 |
- #' requires elements `tte`, `is_event`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies+ "" |
||
| 100 |
- #' groupings for `subgroups` variables.+ ) |
||
| 101 |
- #'+ ) |
||
| 102 | -+ | 32x |
- #' @return+ forms <- c(ref, forms) |
| 103 | -+ | 32x |
- #' * `h_survtime_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, `median`, `subgroup`,+ nams <- c("ref", nams)
|
| 104 |
- #' `var`, `var_label`, and `row_type`.+ } |
||
| 105 | -+ | 39x |
- #'+ stats::setNames(forms, nams) |
| 106 |
- #' @examples+ } |
||
| 107 |
- #' # Extract median survival time for multiple groups.+ |
||
| 108 |
- #' h_survtime_subgroups_df(+ #' @describeIn h_cox_regression Helper for multivariate Cox regression formula. Creates a formulas |
||
| 109 |
- #' variables = list(+ #' string. It is used internally by [fit_coxreg_multivar()] for the comparison of multivariate Cox |
||
| 110 |
- #' tte = "AVAL",+ #' regression models. Interactions will not be included in multivariate Cox regression model. |
||
| 111 |
- #' is_event = "is_event",+ #' |
||
| 112 |
- #' arm = "ARM",+ #' @return |
||
| 113 |
- #' subgroups = c("SEX", "BMRKR2")
+ #' * `h_coxreg_multivar_formula()` returns a `string` coercible into a formula (e.g [stats::as.formula()]). |
||
| 114 |
- #' ),+ #' |
||
| 115 |
- #' data = adtte_f+ #' @examples |
||
| 116 |
- #' )+ #' # `h_coxreg_multivar_formula` |
||
| 118 |
- #' # Define groupings for BMRKR2 levels.+ #' h_coxreg_multivar_formula( |
||
| 119 |
- #' h_survtime_subgroups_df(+ #' variables = list( |
||
| 120 |
- #' variables = list(+ #' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE")
|
||
| 121 |
- #' tte = "AVAL",+ #' ) |
||
| 122 |
- #' is_event = "is_event",+ #' ) |
||
| 123 |
- #' arm = "ARM",+ #' |
||
| 124 |
- #' subgroups = c("SEX", "BMRKR2")
+ #' # Addition of an optional strata. |
||
| 125 |
- #' ),+ #' h_coxreg_multivar_formula( |
||
| 126 |
- #' data = adtte_f,+ #' variables = list( |
||
| 127 |
- #' groups_lists = list(+ #' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE"),
|
||
| 128 |
- #' BMRKR2 = list(+ #' strata = "SITE" |
||
| 129 |
- #' "low" = "LOW",+ #' ) |
||
| 130 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' ) |
||
| 131 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ #' |
||
| 132 |
- #' )+ #' # Example without treatment arm. |
||
| 133 |
- #' )+ #' h_coxreg_multivar_formula( |
||
| 134 |
- #' )+ #' variables = list( |
||
| 135 |
- #'+ #' time = "AVAL", event = "event", covariates = c("RACE", "AGE"),
|
||
| 136 |
- #' @export+ #' strata = "SITE" |
||
| 137 |
- h_survtime_subgroups_df <- function(variables,+ #' ) |
||
| 138 |
- data,+ #' ) |
||
| 139 |
- groups_lists = list(),+ #' |
||
| 140 |
- label_all = "All Patients") {
+ #' @export |
||
| 141 | -11x | +
- checkmate::assert_character(variables$tte)+ h_coxreg_multivar_formula <- function(variables) {
|
|
| 142 | -11x | +57x |
- checkmate::assert_character(variables$is_event)+ checkmate::assert_list(variables, names = "named") |
| 143 | -11x | +57x |
- checkmate::assert_character(variables$arm)+ has_arm <- "arm" %in% names(variables) |
| 144 | -11x | +57x |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ arm_name <- if (has_arm) "arm" else NULL |
| 146 | -11x | +57x |
- assert_df_with_variables(data, variables)+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
| 148 | -11x | +57x |
- checkmate::assert_string(label_all)+ assert_list_of_variables(variables[c(arm_name, "event", "time")]) |
| 150 | -+ | 57x |
- # Add All Patients.+ y <- paste0( |
| 151 | -11x | +57x |
- result_all <- h_survtime_df(data[[variables$tte]], data[[variables$is_event]], data[[variables$arm]])+ "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
|
| 152 | -11x | +57x |
- result_all$subgroup <- label_all+ ifelse(has_arm, variables$arm, "1") |
| 153 | -11x | +
- result_all$var <- "ALL"+ ) |
|
| 154 | -11x | +57x |
- result_all$var_label <- label_all+ if (length(variables$covariates) > 0) {
|
| 155 | -11x | +18x |
- result_all$row_type <- "content"+ y <- paste(y, paste(variables$covariates, collapse = " + "), sep = " + ") |
| 156 |
-
+ } |
||
| 157 | -+ | 57x |
- # Add Subgroups.+ if (!is.null(variables$strata)) {
|
| 158 | -11x | +5x |
- if (is.null(variables$subgroups)) {
+ y <- paste0(y, " + strata(", paste0(variables$strata, collapse = ", "), ")")
|
| 159 | -3x | +
- result_all+ } |
|
| 160 | -+ | 57x |
- } else {
+ y |
| 161 | -8x | +
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ } |
|
| 162 | -8x | +
- l_result <- lapply(l_data, function(grp) {
+
|
|
| 163 | -40x | +
- result <- h_survtime_df(grp$df[[variables$tte]], grp$df[[variables$is_event]], grp$df[[variables$arm]])+ #' @describeIn h_cox_regression Utility function to help tabulate the result of |
|
| 164 | -40x | +
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ #' a univariate Cox regression model. |
|
| 165 | -40x | +
- cbind(result, result_labels)+ #' |
|
| 166 |
- })+ #' @param effect (`string`)\cr the treatment variable. |
||
| 167 | -8x | +
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ #' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()]. |
|
| 168 | -8x | +
- result_subgroups$row_type <- "analysis"+ #' |
|
| 169 | -8x | +
- rbind(+ #' @return |
|
| 170 | -8x | +
- result_all,+ #' * `h_coxreg_univar_extract()` returns a `data.frame` with variables `effect`, `term`, `term_label`, `level`, |
|
| 171 | -8x | +
- result_subgroups+ #' `n`, `hr`, `lcl`, `ucl`, and `pval`. |
|
| 172 |
- )+ #' |
||
| 173 |
- }+ #' @examples |
||
| 174 |
- }+ #' library(survival) |
||
| 175 |
-
+ #' |
||
| 176 |
- #' @describeIn h_survival_duration_subgroups helper to prepare a data frame with estimates of+ #' dta_simple <- data.frame( |
||
| 177 |
- #' treatment hazard ratio.+ #' time = c(5, 5, 10, 10, 5, 5, 10, 10), |
||
| 178 |
- #'+ #' status = c(0, 0, 1, 0, 0, 1, 1, 1), |
||
| 179 |
- #' @param strata_data (`factor`, `data.frame` or `NULL`)\cr required if stratified analysis is performed.+ #' armcd = factor(LETTERS[c(1, 1, 1, 1, 2, 2, 2, 2)], levels = c("A", "B")),
|
||
| 180 |
- #'+ #' var1 = c(45, 55, 65, 75, 55, 65, 85, 75), |
||
| 181 |
- #' @return+ #' var2 = c("F", "M", "F", "M", "F", "M", "F", "U")
|
||
| 182 |
- #' * `h_coxph_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`,+ #' ) |
||
| 183 |
- #' `conf_level`, `pval` and `pval_label`.+ #' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple) |
||
| 184 |
- #'+ #' result <- h_coxreg_univar_extract( |
||
| 185 |
- #' @examples+ #' effect = "armcd", covar = "armcd", mod = mod, data = dta_simple |
||
| 186 |
- #' # Extract hazard ratio for one group.+ #' ) |
||
| 187 |
- #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM)+ #' result |
||
| 189 |
- #' # Extract hazard ratio for one group with stratification factor.+ #' @export |
||
| 190 |
- #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM, strata_data = adtte_f$STRATA1)+ h_coxreg_univar_extract <- function(effect, |
||
| 191 |
- #'+ covar, |
||
| 192 |
- #' @export+ data, |
||
| 193 |
- h_coxph_df <- function(tte, is_event, arm, strata_data = NULL, control = control_coxph()) {
+ mod, |
||
| 194 | -58x | +
- checkmate::assert_numeric(tte)+ control = control_coxreg()) {
|
|
| 195 | -58x | +47x |
- checkmate::assert_logical(is_event, len = length(tte))+ checkmate::assert_string(covar) |
| 196 | -58x | +47x |
- assert_valid_factor(arm, n.levels = 2, len = length(tte))+ checkmate::assert_string(effect) |
| 197 | -+ | 47x |
-
+ checkmate::assert_class(mod, "coxph") |
| 198 | -58x | +47x |
- df_tte <- data.frame(tte = tte, is_event = is_event)+ test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method] |
| 199 | -58x | +
- strata_vars <- NULL+ |
|
| 200 | -+ | 47x |
-
+ mod_aov <- muffled_car_anova(mod, test_statistic) |
| 201 | -58x | +47x |
- if (!is.null(strata_data)) {
+ msum <- summary(mod, conf.int = control$conf_level) |
| 202 | -5x | +47x |
- if (is.data.frame(strata_data)) {
+ sum_cox <- broom::tidy(msum) |
| 203 | -4x | +
- strata_vars <- names(strata_data)+ |
|
| 204 | -4x | +
- checkmate::assert_data_frame(strata_data, nrows = nrow(df_tte))+ # Combine results together. |
|
| 205 | -4x | +47x |
- assert_df_with_factors(strata_data, as.list(stats::setNames(strata_vars, strata_vars)))+ effect_aov <- mod_aov[effect, , drop = TRUE] |
| 206 | -+ | 47x |
- } else {
+ pval <- effect_aov[[grep(pattern = "Pr", x = names(effect_aov)), drop = TRUE]] |
| 207 | -1x | +47x |
- assert_valid_factor(strata_data, len = nrow(df_tte))+ sum_main <- sum_cox[grepl(effect, sum_cox$level), ] |
| 208 | -1x | +
- strata_vars <- "strata_data"+ |
|
| 209 | -+ | 47x |
- }+ term_label <- if (effect == covar) {
|
| 210 | -5x | +25x |
- df_tte[strata_vars] <- strata_data+ paste0( |
| 211 | -+ | 25x |
- }+ levels(data[[covar]])[2], |
| 212 | -+ | 25x |
-
+ " vs control (",
|
| 213 | -58x | +25x |
- l_df <- split(df_tte, arm)+ levels(data[[covar]])[1], |
| 214 |
-
+ ")" |
||
| 215 | -58x | +
- if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
+ ) |
|
| 216 |
- # Hazard ratio and CI.+ } else {
|
||
| 217 | -54x | +22x |
- result <- s_coxph_pairwise(+ unname(labels_or_names(data[covar])) |
| 218 | -54x | +
- df = l_df[[2]],+ } |
|
| 219 | -54x | +47x |
- .ref_group = l_df[[1]],+ data.frame( |
| 220 | -54x | +47x |
- .in_ref_col = FALSE,+ effect = ifelse(covar == effect, "Treatment:", "Covariate:"), |
| 221 | -54x | +47x |
- .var = "tte",+ term = covar, |
| 222 | -54x | +47x |
- is_event = "is_event",+ term_label = term_label, |
| 223 | -54x | +47x |
- strat = strata_vars,+ level = levels(data[[effect]])[2], |
| 224 | -54x | +47x |
- control = control+ n = mod[["n"]], |
| 225 | -+ | 47x |
- )+ hr = unname(sum_main["exp(coef)"]), |
| 226 | -+ | 47x |
-
+ lcl = unname(sum_main[grep("lower", names(sum_main))]),
|
| 227 | -54x | +47x |
- df <- data.frame(+ ucl = unname(sum_main[grep("upper", names(sum_main))]),
|
| 228 | -+ | 47x |
- # Dummy column needed downstream to create a nested header.+ pval = pval, |
| 229 | -54x | +47x |
- arm = " ",+ stringsAsFactors = FALSE |
| 230 | -54x | +
- n_tot = unname(as.numeric(result$n_tot)),+ ) |
|
| 231 | -54x | +
- n_tot_events = unname(as.numeric(result$n_tot_events)),+ } |
|
| 232 | -54x | +
- hr = unname(as.numeric(result$hr)),+ |
|
| 233 | -54x | +
- lcl = unname(result$hr_ci[1]),+ #' @describeIn h_cox_regression Tabulation of multivariate Cox regressions. Utility function to help |
|
| 234 | -54x | +
- ucl = unname(result$hr_ci[2]),+ #' tabulate the result of a multivariate Cox regression model for a treatment/covariate variable. |
|
| 235 | -54x | +
- conf_level = control[["conf_level"]],+ #' |
|
| 236 | -54x | +
- pval = as.numeric(result$pvalue),+ #' @return |
|
| 237 | -54x | +
- pval_label = obj_label(result$pvalue),+ #' * `h_coxreg_multivar_extract()` returns a `data.frame` with variables `pval`, `hr`, `lcl`, `ucl`, `level`, |
|
| 238 | -54x | +
- stringsAsFactors = FALSE+ #' `n`, `term`, and `term_label`. |
|
| 239 |
- )+ #' |
||
| 240 |
- } else if (+ #' @examples |
||
| 241 | -4x | +
- (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) ||+ #' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple) |
|
| 242 | -4x | +
- (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0)+ #' result <- h_coxreg_multivar_extract( |
|
| 243 |
- ) {
+ #' var = "var1", mod = mod, data = dta_simple |
||
| 244 | -4x | +
- df_tte_complete <- df_tte[stats::complete.cases(df_tte), ]+ #' ) |
|
| 245 | -4x | +
- df <- data.frame(+ #' result |
|
| 246 |
- # Dummy column needed downstream to create a nested header.+ #' |
||
| 247 | -4x | +
- arm = " ",+ #' @export |
|
| 248 | -4x | +
- n_tot = nrow(df_tte_complete),+ h_coxreg_multivar_extract <- function(var, |
|
| 249 | -4x | +
- n_tot_events = sum(df_tte_complete$is_event),+ data, |
|
| 250 | -4x | +
- hr = NA,+ mod, |
|
| 251 | -4x | +
- lcl = NA,+ control = control_coxreg()) {
|
|
| 252 | -4x | +76x |
- ucl = NA,+ test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method] |
| 253 | -4x | +76x |
- conf_level = control[["conf_level"]],+ mod_aov <- muffled_car_anova(mod, test_statistic) |
| 254 | -4x | +
- pval = NA,+ |
|
| 255 | -4x | +76x |
- pval_label = NA,+ msum <- summary(mod, conf.int = control$conf_level) |
| 256 | -4x | +76x |
- stringsAsFactors = FALSE+ sum_anova <- broom::tidy(mod_aov) |
| 257 | -+ | 76x |
- )+ sum_cox <- broom::tidy(msum) |
| 258 |
- } else {
+
|
||
| 259 | -! | +76x |
- df <- data.frame(+ ret_anova <- sum_anova[sum_anova$term == var, c("term", "p.value")]
|
| 260 | -+ | 76x |
- # Dummy column needed downstream to create a nested header.+ names(ret_anova)[2] <- "pval" |
| 261 | -! | +76x |
- arm = " ",+ if (is.factor(data[[var]])) {
|
| 262 | -! | +29x |
- n_tot = 0L,+ ret_cox <- sum_cox[startsWith(prefix = var, x = sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")] |
| 263 | -! | +
- n_tot_events = 0L,+ } else {
|
|
| 264 | -! | +47x |
- hr = NA,+ ret_cox <- sum_cox[(var == sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")] |
| 265 | -! | +
- lcl = NA,+ } |
|
| 266 | -! | +76x |
- ucl = NA,+ names(ret_cox)[1:4] <- c("pval", "hr", "lcl", "ucl")
|
| 267 | -! | +76x |
- conf_level = control[["conf_level"]],+ varlab <- unname(labels_or_names(data[var])) |
| 268 | -! | +76x |
- pval = NA,+ ret_cox$term <- varlab |
| 269 | -! | +
- pval_label = NA,+ |
|
| 270 | -! | +76x |
- stringsAsFactors = FALSE+ if (is.numeric(data[[var]])) {
|
| 271 | -+ | 47x |
- )+ ret <- ret_cox |
| 272 | -+ | 47x |
- }+ ret$term_label <- ret$term |
| 273 | -+ | 29x |
-
+ } else if (length(levels(data[[var]])) <= 2) {
|
| 274 | -58x | +18x |
- df+ ret_anova$pval <- NA |
| 275 | -+ | 18x |
- }+ ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")") |
| 276 | -+ | 18x |
-
+ ret_cox$level <- gsub(var, "", ret_cox$level) |
| 277 | -+ | 18x |
- #' @describeIn h_survival_duration_subgroups summarizes estimates of the treatment hazard ratio+ ret_cox$term_label <- ret_cox$level |
| 278 | -+ | 18x |
- #' across subgroups in a data frame. `variables` corresponds to the names of variables found in+ ret <- dplyr::bind_rows(ret_anova, ret_cox) |
| 279 |
- #' `data`, passed as a named list and requires elements `tte`, `is_event`, `arm` and+ } else {
|
||
| 280 | -+ | 11x |
- #' optionally `subgroups` and `strat`. `groups_lists` optionally specifies+ ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")") |
| 281 | -+ | 11x |
- #' groupings for `subgroups` variables.+ ret_cox$level <- gsub(var, "", ret_cox$level) |
| 282 | -+ | 11x |
- #'+ ret_cox$term_label <- ret_cox$level |
| 283 | -+ | 11x |
- #' @return+ ret <- dplyr::bind_rows(ret_anova, ret_cox) |
| 284 |
- #' * `h_coxph_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`,+ } |
||
| 285 |
- #' `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`.+ |
||
| 286 | -+ | 76x |
- #'+ as.data.frame(ret) |
| 287 |
- #' @examples+ } |
| 288 | +1 |
- #' # Extract hazard ratio for multiple groups.+ #' Confidence Intervals for a Difference of Binomials |
||
| 289 | +2 |
- #' h_coxph_subgroups_df(+ #' |
||
| 290 | +3 |
- #' variables = list(+ #' @description `r lifecycle::badge("experimental")`
|
||
| 291 | +4 |
- #' tte = "AVAL",+ #' |
||
| 292 | +5 |
- #' is_event = "is_event",+ #' Several confidence intervals for the difference between proportions. |
||
| 293 | +6 |
- #' arm = "ARM",+ #' |
||
| 294 | +7 |
- #' subgroups = c("SEX", "BMRKR2")
+ #' @name desctools_binom |
||
| 295 | +8 |
- #' ),+ NULL |
||
| 296 | +9 |
- #' data = adtte_f+ |
||
| 297 | +10 |
- #' )+ #' Recycle List of Parameters |
||
| 298 | +11 |
#' |
||
| 299 | +12 |
- #' # Define groupings of BMRKR2 levels.+ #' This function recycles all supplied elements to the maximal dimension. |
||
| 300 | +13 |
- #' h_coxph_subgroups_df(+ #' |
||
| 301 | +14 |
- #' variables = list(+ #' @param ... (`any`)\cr Elements to recycle. |
||
| 302 | +15 |
- #' tte = "AVAL",+ #' |
||
| 303 | +16 |
- #' is_event = "is_event",+ #' @return A `list`. |
||
| 304 | +17 |
- #' arm = "ARM",+ #' |
||
| 305 | +18 |
- #' subgroups = c("SEX", "BMRKR2")
+ #' @keywords internal |
||
| 306 | +19 |
- #' ),+ #' @noRd |
||
| 307 | +20 |
- #' data = adtte_f,+ h_recycle <- function(...) {
|
||
| 308 | -+ | |||
| 21 | +60x |
- #' groups_lists = list(+ lst <- list(...) |
||
| 309 | -+ | |||
| 22 | +60x |
- #' BMRKR2 = list(+ maxdim <- max(lengths(lst)) |
||
| 310 | -+ | |||
| 23 | +60x |
- #' "low" = "LOW",+ res <- lapply(lst, rep, length.out = maxdim) |
||
| 311 | -+ | |||
| 24 | +60x |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ attr(res, "maxdim") <- maxdim |
||
| 312 | -+ | |||
| 25 | +60x |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ return(res) |
||
| 313 | +26 |
- #' )+ } |
||
| 314 | +27 |
- #' )+ |
||
| 315 | +28 |
- #' )+ #' @describeIn desctools_binom Several confidence intervals for the difference between proportions. |
||
| 316 | +29 |
#' |
||
| 317 | +30 |
- #' # Extract hazard ratio for multiple groups with stratification factors.+ #' @return A `matrix` of 3 values: |
||
| 318 | +31 |
- #' h_coxph_subgroups_df(+ #' * `est`: estimate of proportion difference. |
||
| 319 | +32 |
- #' variables = list(+ #' * `lwr.ci`: estimate of lower end of the confidence interval. |
||
| 320 | +33 |
- #' tte = "AVAL",+ #' * `upr.ci`: estimate of upper end of the confidence interval. |
||
| 321 | +34 |
- #' is_event = "is_event",+ #' |
||
| 322 | +35 |
- #' arm = "ARM",+ #' @keywords internal |
||
| 323 | +36 |
- #' subgroups = c("SEX", "BMRKR2"),
+ desctools_binom <- function(x1, n1, x2, n2, conf.level = 0.95, sides = c( # nolint |
||
| 324 | +37 |
- #' strat = c("STRATA1", "STRATA2")
+ "two.sided", |
||
| 325 | +38 |
- #' ),+ "left", "right" |
||
| 326 | +39 |
- #' data = adtte_f+ ), method = c( |
||
| 327 | +40 |
- #' )+ "ac", "wald", "waldcc", "score", |
||
| 328 | +41 |
- #'+ "scorecc", "mn", "mee", "blj", "ha", "hal", "jp" |
||
| 329 | +42 |
- #' @export+ )) {
|
||
| 330 | -+ | |||
| 43 | +18x |
- h_coxph_subgroups_df <- function(variables,+ if (missing(sides)) {
|
||
| 331 | -+ | |||
| 44 | +18x |
- data,+ sides <- match.arg(sides) |
||
| 332 | +45 |
- groups_lists = list(),+ } |
||
| 333 | -+ | |||
| 46 | +18x |
- control = control_coxph(),+ if (missing(method)) {
+ |
+ ||
| 47 | +1x | +
+ method <- match.arg(method) |
||
| 334 | +48 |
- label_all = "All Patients") {
+ } |
||
| 335 | -12x | +49 | +18x |
- checkmate::assert_character(variables$tte)+ iBinomDiffCI <- function(x1, n1, x2, n2, conf.level, sides, # nolint |
| 336 | -12x | +50 | +18x |
- checkmate::assert_character(variables$is_event)+ method) {
|
| 337 | -12x | +51 | +18x |
- checkmate::assert_character(variables$arm)+ if (sides != "two.sided") {
|
| 338 | -12x | +|||
| 52 | +! |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ conf.level <- 1 - 2 * (1 - conf.level) # nolint |
||
| 339 | -12x | +|||
| 53 | +
- checkmate::assert_character(variables$strat, null.ok = TRUE)+ } |
|||
| 340 | -12x | +54 | +18x |
- assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ alpha <- 1 - conf.level |
| 341 | -12x | +55 | +18x |
- assert_df_with_variables(data, variables)+ kappa <- stats::qnorm(1 - alpha / 2) |
| 342 | -12x | +56 | +18x |
- checkmate::assert_string(label_all)+ p1_hat <- x1 / n1 |
| 343 | -+ | |||
| 57 | +18x |
-
+ p2_hat <- x2 / n2 |
||
| 344 | -+ | |||
| 58 | +18x |
- # Add All Patients.+ est <- p1_hat - p2_hat |
||
| 345 | -12x | +59 | +18x |
- result_all <- h_coxph_df(+ switch(method, |
| 346 | -12x | +60 | +18x |
- tte = data[[variables$tte]],+ wald = {
|
| 347 | -12x | +61 | +2x |
- is_event = data[[variables$is_event]],+ vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2 |
| 348 | -12x | +62 | +2x |
- arm = data[[variables$arm]],+ term2 <- kappa * sqrt(vd) |
| 349 | -12x | +63 | +2x |
- strata_data = if (is.null(variables$strat)) NULL else data[variables$strat],+ ci_lwr <- max(-1, est - term2) |
| 350 | -12x | +64 | +2x |
- control = control+ ci_upr <- min(1, est + term2) |
| 351 | +65 |
- )+ }, |
||
| 352 | -12x | +66 | +18x |
- result_all$subgroup <- label_all+ waldcc = {
|
| 353 | -12x | +67 | +2x |
- result_all$var <- "ALL"+ vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2 |
| 354 | -12x | +68 | +2x |
- result_all$var_label <- label_all+ term2 <- kappa * sqrt(vd) |
| 355 | -12x | -
- result_all$row_type <- "content"- |
- ||
| 356 | -- | - - | -||
| 357 | -+ | 69 | +2x |
- # Add Subgroups.+ term2 <- term2 + 0.5 * (1 / n1 + 1 / n2) |
| 358 | -12x | +70 | +2x |
- if (is.null(variables$subgroups)) {
+ ci_lwr <- max(-1, est - term2) |
| 359 | -3x | +71 | +2x |
- result_all+ ci_upr <- min(1, est + term2) |
| 360 | +72 |
- } else {
+ }, |
||
| 361 | -9x | +73 | +18x |
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ ac = {
|
| 362 | -+ | |||
| 74 | +2x |
-
+ n1 <- n1 + 2 |
||
| 363 | -9x | +75 | +2x |
- l_result <- lapply(l_data, function(grp) {
+ n2 <- n2 + 2 |
| 364 | -42x | +76 | +2x |
- result <- h_coxph_df(+ x1 <- x1 + 1 |
| 365 | -42x | +77 | +2x |
- tte = grp$df[[variables$tte]],+ x2 <- x2 + 1 |
| 366 | -42x | +78 | +2x |
- is_event = grp$df[[variables$is_event]],+ p1_hat <- x1 / n1 |
| 367 | -42x | +79 | +2x |
- arm = grp$df[[variables$arm]],+ p2_hat <- x2 / n2 |
| 368 | -42x | +80 | +2x |
- strata_data = if (is.null(variables$strat)) NULL else grp$df[variables$strat],+ est1 <- p1_hat - p2_hat |
| 369 | -42x | +81 | +2x |
- control = control+ vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2 |
| 370 | -+ | |||
| 82 | +2x |
- )+ term2 <- kappa * sqrt(vd) |
||
| 371 | -42x | +83 | +2x |
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ ci_lwr <- max(-1, est1 - term2) |
| 372 | -42x | +84 | +2x |
- cbind(result, result_labels)+ ci_upr <- min(1, est1 + term2) |
| 373 | +85 |
- })+ }, |
||
| 374 | -+ | |||
| 86 | +18x |
-
+ exact = {
|
||
| 375 | -9x | +|||
| 87 | +! |
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ ci_lwr <- NA |
||
| 376 | -9x | +|||
| 88 | +! |
- result_subgroups$row_type <- "analysis"+ ci_upr <- NA |
||
| 377 | +89 |
-
+ }, |
||
| 378 | -9x | +90 | +18x |
- rbind(+ score = {
|
| 379 | -9x | +91 | +2x |
- result_all,+ w1 <- desctools_binomci( |
| 380 | -9x | +92 | +2x |
- result_subgroups+ x = x1, n = n1, conf.level = conf.level, |
| 381 | -+ | |||
| 93 | +2x |
- )+ method = "wilson" |
||
| 382 | +94 |
- }+ ) |
||
| 383 | -+ | |||
| 95 | +2x |
- }+ w2 <- desctools_binomci( |
||
| 384 | -+ | |||
| 96 | +2x |
-
+ x = x2, n = n2, conf.level = conf.level, |
||
| 385 | -+ | |||
| 97 | +2x |
- #' Split Dataframe by Subgroups+ method = "wilson" |
||
| 386 | +98 |
- #'+ ) |
||
| 387 | -+ | |||
| 99 | +2x |
- #' @description `r lifecycle::badge("stable")`
+ l1 <- w1[2] |
||
| 388 | -+ | |||
| 100 | +2x |
- #'+ u1 <- w1[3] |
||
| 389 | -+ | |||
| 101 | +2x |
- #' Split a dataframe into a non-nested list of subsets.+ l2 <- w2[2] |
||
| 390 | -+ | |||
| 102 | +2x |
- #'+ u2 <- w2[3] |
||
| 391 | -+ | |||
| 103 | +2x |
- #' @inheritParams argument_convention+ ci_lwr <- est - kappa * sqrt(l1 * (1 - l1) / n1 + |
||
| 392 | -+ | |||
| 104 | +2x |
- #' @inheritParams survival_duration_subgroups+ u2 * (1 - u2) / n2) |
||
| 393 | -+ | |||
| 105 | +2x |
- #' @param data (`data.frame`)\cr dataset to split.+ ci_upr <- est + kappa * sqrt(u1 * (1 - u1) / n1 + |
||
| 394 | -+ | |||
| 106 | +2x |
- #' @param subgroups (`character`)\cr names of factor variables from `data` used to create subsets.+ l2 * (1 - l2) / n2) |
||
| 395 | +107 |
- #' Unused levels not present in `data` are dropped. Note that the order in this vector+ }, |
||
| 396 | -+ | |||
| 108 | +18x |
- #' determines the order in the downstream table.+ scorecc = {
|
||
| 397 | -+ | |||
| 109 | +1x |
- #'+ w1 <- desctools_binomci( |
||
| 398 | -+ | |||
| 110 | +1x |
- #' @return A list with subset data (`df`) and metadata about the subset (`df_labels`).+ x = x1, n = n1, conf.level = conf.level, |
||
| 399 | -+ | |||
| 111 | +1x |
- #'+ method = "wilsoncc" |
||
| 400 | +112 |
- #' @details Main functionality is to prepare data for use in forest plot layouts.+ ) |
||
| 401 | -+ | |||
| 113 | +1x |
- #'+ w2 <- desctools_binomci( |
||
| 402 | -+ | |||
| 114 | +1x |
- #' @examples+ x = x2, n = n2, conf.level = conf.level, |
||
| 403 | -+ | |||
| 115 | +1x |
- #' df <- data.frame(+ method = "wilsoncc" |
||
| 404 | +116 |
- #' x = c(1:5),+ ) |
||
| 405 | -+ | |||
| 117 | +1x |
- #' y = factor(c("A", "B", "A", "B", "A"), levels = c("A", "B", "C")),
+ l1 <- w1[2] |
||
| 406 | -+ | |||
| 118 | +1x |
- #' z = factor(c("C", "C", "D", "D", "D"), levels = c("D", "C"))
+ u1 <- w1[3]+ |
+ ||
| 119 | +1x | +
+ l2 <- w2[2]+ |
+ ||
| 120 | +1x | +
+ u2 <- w2[3]+ |
+ ||
| 121 | +1x | +
+ ci_lwr <- max(-1, est - sqrt((p1_hat - l1)^2 ++ |
+ ||
| 122 | +1x | +
+ (u2 - p2_hat)^2))+ |
+ ||
| 123 | +1x | +
+ ci_upr <- min(1, est + sqrt((u1 - p1_hat)^2 + (p2_hat -+ |
+ ||
| 124 | +1x | +
+ l2)^2)) |
||
| 407 | +125 |
- #' )+ },+ |
+ ||
| 126 | +18x | +
+ mee = {
+ |
+ ||
| 127 | +1x | +
+ .score <- function(p1, n1, p2, n2, dif) {
+ |
+ ||
| 128 | +! | +
+ if (dif > 1) dif <- 1+ |
+ ||
| 129 | +! | +
+ if (dif < -1) dif <- -1+ |
+ ||
| 130 | +24x | +
+ diff <- p1 - p2 - dif+ |
+ ||
| 131 | +24x | +
+ if (abs(diff) == 0) {
+ |
+ ||
| 132 | +! | +
+ res <- 0 |
||
| 408 | +133 |
- #' formatters::var_labels(df) <- paste("label for", names(df))
+ } else {
+ |
+ ||
| 134 | +24x | +
+ t <- n2 / n1+ |
+ ||
| 135 | +24x | +
+ a <- 1 + t+ |
+ ||
| 136 | +24x | +
+ b <- -(1 + t + p1 + t * p2 + dif * (t + 2))+ |
+ ||
| 137 | +24x | +
+ c <- dif * dif + dif * (2 * p1 + t + 1) + p1 ++ |
+ ||
| 138 | +24x | +
+ t * p2+ |
+ ||
| 139 | +24x | +
+ d <- -p1 * dif * (1 + dif)+ |
+ ||
| 140 | +24x | +
+ v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2+ |
+ ||
| 141 | +24x | +
+ if (abs(v) < .Machine$double.eps) v <- 0+ |
+ ||
| 142 | +24x | +
+ s <- sqrt((b / a / 3)^2 - c / a / 3)+ |
+ ||
| 143 | +24x | +
+ u <- ifelse(v > 0, 1, -1) * s+ |
+ ||
| 144 | +24x | +
+ w <- (3.141592654 + acos(v / u^3)) / 3+ |
+ ||
| 145 | +24x | +
+ p1d <- 2 * u * cos(w) - b / a / 3+ |
+ ||
| 146 | +24x | +
+ p2d <- p1d - dif+ |
+ ||
| 147 | +24x | +
+ n <- n1 + n2+ |
+ ||
| 148 | +24x | +
+ res <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2) |
||
| 409 | +149 |
- #'+ }+ |
+ ||
| 150 | +24x | +
+ return(sqrt(res)) |
||
| 410 | +151 |
- #' h_split_by_subgroups(+ }+ |
+ ||
| 152 | +1x | +
+ pval <- function(delta) {
+ |
+ ||
| 153 | +24x | +
+ z <- (est - delta) / .score(+ |
+ ||
| 154 | +24x | +
+ p1_hat, n1, p2_hat,+ |
+ ||
| 155 | +24x | +
+ n2, delta |
||
| 411 | +156 |
- #' data = df,+ )+ |
+ ||
| 157 | +24x | +
+ 2 * min(stats::pnorm(z), 1 - stats::pnorm(z)) |
||
| 412 | +158 |
- #' subgroups = c("y", "z")
+ }+ |
+ ||
| 159 | +1x | +
+ ci_lwr <- max(-1, stats::uniroot(function(delta) {
+ |
+ ||
| 160 | +12x | +
+ pval(delta) -+ |
+ ||
| 161 | +12x | +
+ alpha+ |
+ ||
| 162 | +1x | +
+ }, interval = c(-1 + 1e-06, est - 1e-06))$root)+ |
+ ||
| 163 | +1x | +
+ ci_upr <- min(1, stats::uniroot(function(delta) {
+ |
+ ||
| 164 | +12x | +
+ pval(delta) -+ |
+ ||
| 165 | +12x | +
+ alpha+ |
+ ||
| 166 | +1x | +
+ }, interval = c(est + 1e-06, 1 - 1e-06))$root) |
||
| 413 | +167 |
- #' )+ },+ |
+ ||
| 168 | +18x | +
+ blj = {
+ |
+ ||
| 169 | +1x | +
+ p1_dash <- (x1 + 0.5) / (n1 + 1)+ |
+ ||
| 170 | +1x | +
+ p2_dash <- (x2 + 0.5) / (n2 + 1)+ |
+ ||
| 171 | +1x | +
+ vd <- p1_dash * (1 - p1_dash) / n1 + p2_dash * (1 -+ |
+ ||
| 172 | +1x | +
+ p2_dash) / n2+ |
+ ||
| 173 | +1x | +
+ term2 <- kappa * sqrt(vd)+ |
+ ||
| 174 | +1x | +
+ est_dash <- p1_dash - p2_dash+ |
+ ||
| 175 | +1x | +
+ ci_lwr <- max(-1, est_dash - term2)+ |
+ ||
| 176 | +1x | +
+ ci_upr <- min(1, est_dash + term2) |
||
| 414 | +177 |
- #'+ },+ |
+ ||
| 178 | +18x | +
+ ha = {
+ |
+ ||
| 179 | +4x | +
+ term2 <- 1 / (2 * min(n1, n2)) + kappa * sqrt(p1_hat *+ |
+ ||
| 180 | +4x | +
+ (1 - p1_hat) / (n1 - 1) + p2_hat * (1 - p2_hat) / (n2 -+ |
+ ||
| 181 | +4x | +
+ 1))+ |
+ ||
| 182 | +4x | +
+ ci_lwr <- max(-1, est - term2)+ |
+ ||
| 183 | +4x | +
+ ci_upr <- min(1, est + term2) |
||
| 415 | +184 |
- #' h_split_by_subgroups(+ },+ |
+ ||
| 185 | +18x | +
+ mn = {
+ |
+ ||
| 186 | +1x | +
+ .conf <- function(x1, n1, x2, n2, z, lower = FALSE) {
+ |
+ ||
| 187 | +2x | +
+ p1 <- x1 / n1+ |
+ ||
| 188 | +2x | +
+ p2 <- x2 / n2+ |
+ ||
| 189 | +2x | +
+ p_hat <- p1 - p2+ |
+ ||
| 190 | +2x | +
+ dp <- 1 + ifelse(lower, 1, -1) * p_hat+ |
+ ||
| 191 | +2x | +
+ i <- 1+ |
+ ||
| 192 | +2x | +
+ while (i <= 50) {
+ |
+ ||
| 193 | +46x | +
+ dp <- 0.5 * dp+ |
+ ||
| 194 | +46x | +
+ y <- p_hat + ifelse(lower, -1, 1) * dp+ |
+ ||
| 195 | +46x | +
+ score <- .score(p1, n1, p2, n2, y)+ |
+ ||
| 196 | +46x | +
+ if (score < z) {
+ |
+ ||
| 197 | +20x | +
+ p_hat <- y |
||
| 416 | +198 |
- #' data = df,+ }+ |
+ ||
| 199 | +46x | +
+ if ((dp < 1e-07) || (abs(z - score) < 1e-06)) {
+ |
+ ||
| 200 | +2x | +
+ (break)() |
||
| 417 | +201 |
- #' subgroups = c("y", "z"),
+ } else {
+ |
+ ||
| 202 | +44x | +
+ i <- i ++ |
+ ||
| 203 | +44x | +
+ 1 |
||
| 418 | +204 |
- #' groups_lists = list(+ } |
||
| 419 | +205 |
- #' y = list("AB" = c("A", "B"), "C" = "C")
+ }+ |
+ ||
| 206 | +2x | +
+ return(y) |
||
| 420 | +207 |
- #' )+ }+ |
+ ||
| 208 | +1x | +
+ .score <- function(p1, n1, p2, n2, dif) {
+ |
+ ||
| 209 | +46x | +
+ diff <- p1 - p2 - dif+ |
+ ||
| 210 | +46x | +
+ if (abs(diff) == 0) {
+ |
+ ||
| 211 | +! | +
+ res <- 0 |
||
| 421 | +212 |
- #' )+ } else {
+ |
+ ||
| 213 | +46x | +
+ t <- n2 / n1+ |
+ ||
| 214 | +46x | +
+ a <- 1 + t+ |
+ ||
| 215 | +46x | +
+ b <- -(1 + t + p1 + t * p2 + dif * (t + 2))+ |
+ ||
| 216 | +46x | +
+ c <- dif * dif + dif * (2 * p1 + t + 1) + p1 ++ |
+ ||
| 217 | +46x | +
+ t * p2+ |
+ ||
| 218 | +46x | +
+ d <- -p1 * dif * (1 + dif)+ |
+ ||
| 219 | +46x | +
+ v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2+ |
+ ||
| 220 | +46x | +
+ s <- sqrt((b / a / 3)^2 - c / a / 3)+ |
+ ||
| 221 | +46x | +
+ u <- ifelse(v > 0, 1, -1) * s+ |
+ ||
| 222 | +46x | +
+ w <- (3.141592654 + acos(v / u^3)) / 3+ |
+ ||
| 223 | +46x | +
+ p1d <- 2 * u * cos(w) - b / a / 3+ |
+ ||
| 224 | +46x | +
+ p2d <- p1d - dif+ |
+ ||
| 225 | +46x | +
+ n <- n1 + n2+ |
+ ||
| 226 | +46x | +
+ var <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2) *+ |
+ ||
| 227 | +46x | +
+ n / (n - 1)+ |
+ ||
| 228 | +46x | +
+ res <- diff^2 / var |
||
| 422 | +229 |
- #'+ }+ |
+ ||
| 230 | +46x | +
+ return(res) |
||
| 423 | +231 |
- #' @export+ }+ |
+ ||
| 232 | +1x | +
+ z <- stats::qchisq(conf.level, 1)+ |
+ ||
| 233 | +1x | +
+ ci_lwr <- max(-1, .conf(x1, n1, x2, n2, z, TRUE))+ |
+ ||
| 234 | +1x | +
+ ci_upr <- min(1, .conf(x1, n1, x2, n2, z, FALSE)) |
||
| 424 | +235 |
- h_split_by_subgroups <- function(data,+ },+ |
+ ||
| 236 | +18x | +
+ beal = {
+ |
+ ||
| 237 | +! | +
+ a <- p1_hat + p2_hat+ |
+ ||
| 238 | +! | +
+ b <- p1_hat - p2_hat+ |
+ ||
| 239 | +! | +
+ u <- ((1 / n1) + (1 / n2)) / 4+ |
+ ||
| 240 | +! | +
+ v <- ((1 / n1) - (1 / n2)) / 4+ |
+ ||
| 241 | +! | +
+ V <- u * ((2 - a) * a - b^2) + 2 * v * (1 - a) * b # nolint+ |
+ ||
| 242 | +! | +
+ z <- stats::qchisq(p = 1 - alpha / 2, df = 1)+ |
+ ||
| 243 | +! | +
+ A <- sqrt(z * (V + z * u^2 * (2 - a) * a + z * v^2 * (1 - a)^2)) # nolint+ |
+ ||
| 244 | +! | +
+ B <- (b + z * v * (1 - a)) / (1 + z * u) # nolint+ |
+ ||
| 245 | +! | +
+ ci_lwr <- max(-1, B - A / (1 + z * u))+ |
+ ||
| 246 | +! | +
+ ci_upr <- min(1, B + A / (1 + z * u)) |
||
| 425 | +247 |
- subgroups,+ },+ |
+ ||
| 248 | +18x | +
+ hal = {
+ |
+ ||
| 249 | +1x | +
+ psi <- (p1_hat + p2_hat) / 2+ |
+ ||
| 250 | +1x | +
+ u <- (1 / n1 + 1 / n2) / 4+ |
+ ||
| 251 | +1x | +
+ v <- (1 / n1 - 1 / n2) / 4+ |
+ ||
| 252 | +1x | +
+ z <- kappa+ |
+ ||
| 253 | +1x | +
+ theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 *+ |
+ ||
| 254 | +1x | +
+ psi)) / (1 + z^2 * u)+ |
+ ||
| 255 | +1x | +
+ w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) -+ |
+ ||
| 256 | +1x | +
+ (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) *+ |
+ ||
| 257 | +1x | +
+ (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) *+ |
+ ||
| 258 | +1x | +
+ psi + z^2 * v^2 * (1 - 2 * psi)^2)+ |
+ ||
| 259 | +1x | +
+ c(theta + w, theta - w)+ |
+ ||
| 260 | +1x | +
+ ci_lwr <- max(-1, theta - w)+ |
+ ||
| 261 | +1x | +
+ ci_upr <- min(1, theta + w) |
||
| 426 | +262 |
- groups_lists = list()) {
+ }, |
||
| 427 | -46x | +263 | +18x |
- checkmate::assert_character(subgroups, min.len = 1, any.missing = FALSE)+ jp = {
|
| 428 | -46x | +264 | +1x |
- checkmate::assert_list(groups_lists, names = "named")+ psi <- 0.5 * ((x1 + 0.5) / (n1 + 1) + (x2 + 0.5) / (n2 + |
| 429 | -46x | +265 | +1x |
- checkmate::assert_subset(names(groups_lists), subgroups)+ 1)) |
| 430 | -46x | +266 | +1x |
- assert_df_with_factors(data, as.list(stats::setNames(subgroups, subgroups)))+ u <- (1 / n1 + 1 / n2) / 4+ |
+
| 267 | +1x | +
+ v <- (1 / n1 - 1 / n2) / 4+ |
+ ||
| 268 | +1x | +
+ z <- kappa+ |
+ ||
| 269 | +1x | +
+ theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 *+ |
+ ||
| 270 | +1x | +
+ psi)) / (1 + z^2 * u)+ |
+ ||
| 271 | +1x | +
+ w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) -+ |
+ ||
| 272 | +1x | +
+ (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) *+ |
+ ||
| 273 | +1x | +
+ (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) *+ |
+ ||
| 274 | +1x | +
+ psi + z^2 * v^2 * (1 - 2 * psi)^2)+ |
+ ||
| 275 | +1x | +
+ c(theta + w, theta - w)+ |
+ ||
| 276 | +1x | +
+ ci_lwr <- max(-1, theta - w)+ |
+ ||
| 277 | +1x | +
+ ci_upr <- min(1, theta + w) |
||
| 431 | +278 |
-
+ },+ |
+ ||
| 279 | ++ |
+ ) |
||
| 432 | -46x | +280 | +18x |
- data_labels <- unname(formatters::var_labels(data))+ ci <- c( |
| 433 | -46x | +281 | +18x |
- df_subgroups <- data[, subgroups, drop = FALSE]+ est = est, lwr.ci = min(ci_lwr, ci_upr), |
| 434 | -46x | +282 | +18x |
- subgroup_labels <- formatters::var_labels(df_subgroups, fill = TRUE)+ upr.ci = max(ci_lwr, ci_upr) |
| 435 | +283 |
-
+ ) |
||
| 436 | -46x | +284 | +18x | +
+ if (sides == "left") {
+ |
+
| 285 | +! | +
+ ci[3] <- 1+ |
+ ||
| 286 | +18x | +
+ } else if (sides == "right") {
+ |
+ ||
| 287 | +! |
- l_labels <- Map(function(grp_i, name_i) {
+ ci[2] <- -1 |
||
| 437 | -81x | +|||
| 288 | +
- existing_levels <- levels(droplevels(grp_i))+ } |
|||
| 438 | -81x | +289 | +18x |
- grp_levels <- if (name_i %in% names(groups_lists)) {
+ return(ci) |
| 439 | +290 |
- # For this variable groupings are defined. We check which groups are contained in the data.+ } |
||
| 440 | -11x | +291 | +18x |
- group_list_i <- groups_lists[[name_i]]+ method <- match.arg(arg = method, several.ok = TRUE) |
| 441 | -11x | +292 | +18x |
- group_has_levels <- vapply(group_list_i, function(lvls) any(lvls %in% existing_levels), TRUE)+ sides <- match.arg(arg = sides, several.ok = TRUE) |
| 442 | -11x | +293 | +18x |
- names(which(group_has_levels))+ lst <- h_recycle( |
| 443 | -+ | |||
| 294 | +18x |
- } else {
+ x1 = x1, n1 = n1, x2 = x2, n2 = n2, conf.level = conf.level, |
||
| 444 | -70x | +295 | +18x |
- existing_levels+ sides = sides, method = method |
| 445 | +296 |
- }+ ) |
||
| 446 | -81x | +297 | +18x |
- df_labels <- data.frame(+ res <- t(sapply(1:attr(lst, "maxdim"), function(i) {
|
| 447 | -81x | +298 | +18x |
- subgroup = grp_levels,+ iBinomDiffCI( |
| 448 | -81x | +299 | +18x |
- var = name_i,+ x1 = lst$x1[i], |
| 449 | -81x | +300 | +18x |
- var_label = unname(subgroup_labels[name_i]),+ n1 = lst$n1[i], x2 = lst$x2[i], n2 = lst$n2[i], conf.level = lst$conf.level[i], |
| 450 | -81x | +301 | +18x |
- stringsAsFactors = FALSE # Rationale is that subgroups may not be unique.+ sides = lst$sides[i], method = lst$method[i] |
| 451 | +302 |
) |
||
| 303 | ++ |
+ }))+ |
+ ||
| 452 | -46x | +304 | +18x |
- }, df_subgroups, names(df_subgroups))+ lgn <- h_recycle(x1 = if (is.null(names(x1))) {
|
| 453 | -+ | |||
| 305 | +18x |
-
+ paste("x1", seq_along(x1), sep = ".")
|
||
| 454 | +306 |
- # Create a dataframe with one row per subgroup.+ } else {
|
||
| 455 | -46x | +|||
| 307 | +! |
- df_labels <- do.call(rbind, args = c(l_labels, make.row.names = FALSE))+ names(x1) |
||
| 456 | -46x | +308 | +18x |
- row_label <- paste0(df_labels$var, ".", df_labels$subgroup)+ }, n1 = if (is.null(names(n1))) {
|
| 457 | -46x | +309 | +18x |
- row_split_var <- factor(row_label, levels = row_label)+ paste("n1", seq_along(n1), sep = ".")
|
| 458 | +310 |
-
+ } else {
|
||
| 459 | -+ | |||
| 311 | +! |
- # Create a list of data subsets.+ names(n1) |
||
| 460 | -46x | +312 | +18x |
- lapply(split(df_labels, row_split_var), function(row_i) {
+ }, x2 = if (is.null(names(x2))) {
|
| 461 | -205x | +313 | +18x |
- which_row <- if (row_i$var %in% names(groups_lists)) {
+ paste("x2", seq_along(x2), sep = ".")
|
| 462 | -31x | +|||
| 314 | +
- data[[row_i$var]] %in% groups_lists[[row_i$var]][[row_i$subgroup]]+ } else {
|
|||
| 463 | -+ | |||
| 315 | +! |
- } else {
+ names(x2) |
||
| 464 | -174x | +316 | +18x |
- data[[row_i$var]] == row_i$subgroup+ }, n2 = if (is.null(names(n2))) {
+ |
+
| 317 | +18x | +
+ paste("n2", seq_along(n2), sep = ".")
|
||
| 465 | +318 |
- }+ } else {
|
||
| 466 | -205x | +|||
| 319 | +! |
- df <- data[which_row, ]+ names(n2) |
||
| 467 | -205x | +320 | +18x |
- rownames(df) <- NULL+ }, conf.level = conf.level, sides = sides, method = method) |
| 468 | -205x | +321 | +18x |
- formatters::var_labels(df) <- data_labels+ xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
|
| 469 | -+ | |||
| 322 | +126x |
-
+ length(unique(x)) != |
||
| 470 | -205x | +323 | +126x |
- list(+ 1 |
| 471 | -205x | +324 | +18x |
- df = df,+ })]), 1, paste, collapse = ":") |
| 472 | -205x | +325 | +18x |
- df_labels = data.frame(row_i, row.names = NULL)+ rownames(res) <- xn |
| 473 | -+ | |||
| 326 | +18x |
- )+ return(res) |
||
| 474 | +327 |
- })+ } |
||
| 475 | +328 |
- }+ |
| 1 | +329 |
- #' Tabulate Binary Response by Subgroup+ #' @describeIn desctools_binom Compute confidence intervals for binomial proportions. |
||
| 2 | +330 |
#' |
||
| 3 | +331 |
- #' @description `r lifecycle::badge("stable")`
+ #' @param x (`count`)\cr number of successes |
||
| 4 | +332 |
- #'+ #' @param n (`count`)\cr number of trials |
||
| 5 | +333 |
- #' Tabulate statistics such as response rate and odds ratio for population subgroups.+ #' @param conf.level (`proportion`)\cr confidence level, defaults to 0.95. |
||
| 6 | +334 |
- #'+ #' @param sides (`character`)\cr side of the confidence interval to compute. Must be one of `"two-sided"` (default), |
||
| 7 | +335 |
- #' @inheritParams argument_convention+ #' `"left"`, or `"right"`. |
||
| 8 | +336 |
- #'+ #' @param method (`character`)\cr method to use. Can be one out of: `"wald"`, `"wilson"`, `"wilsoncc"`, |
||
| 9 | +337 |
- #' @details These functions create a layout starting from a data frame which contains+ #' `"agresti-coull"`, `"jeffreys"`, `"modified wilson"`, `"modified jeffreys"`, `"clopper-pearson"`, `"arcsine"`, |
||
| 10 | +338 |
- #' the required statistics. Tables typically used as part of forest plot.+ #' `"logit"`, `"witting"`, `"pratt"`, `"midp"`, `"lik"`, and `"blaker"`. |
||
| 11 | +339 |
#' |
||
| 12 | +340 |
- #' @seealso [extract_rsp_subgroups()]+ #' @return A `matrix` with 3 columns containing: |
||
| 13 | +341 |
- #'+ #' * `est`: estimate of proportion difference. |
||
| 14 | +342 |
- #' @examples+ #' * `lwr.ci`: lower end of the confidence interval. |
||
| 15 | +343 |
- #' library(dplyr)+ #' * `upr.ci`: upper end of the confidence interval. |
||
| 16 | +344 |
- #' library(forcats)+ #' |
||
| 17 | +345 |
- #'+ #' @keywords internal |
||
| 18 | +346 |
- #' adrs <- tern_ex_adrs+ desctools_binomci <- function(x, |
||
| 19 | +347 |
- #' adrs_labels <- formatters::var_labels(adrs)+ n, |
||
| 20 | +348 |
- #'+ conf.level = 0.95, # nolint |
||
| 21 | +349 |
- #' adrs_f <- adrs %>%+ sides = c("two.sided", "left", "right"),
|
||
| 22 | +350 |
- #' filter(PARAMCD == "BESRSPI") %>%+ method = c( |
||
| 23 | +351 |
- #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+ "wilson", "wald", "waldcc", "agresti-coull", |
||
| 24 | +352 |
- #' droplevels() %>%+ "jeffreys", "modified wilson", "wilsoncc", "modified jeffreys", |
||
| 25 | +353 |
- #' mutate(+ "clopper-pearson", "arcsine", "logit", "witting", "pratt", |
||
| 26 | +354 |
- #' # Reorder levels of factor to make the placebo group the reference arm.+ "midp", "lik", "blaker" |
||
| 27 | +355 |
- #' ARM = fct_relevel(ARM, "B: Placebo"),+ ), |
||
| 28 | +356 |
- #' rsp = AVALC == "CR"+ rand = 123, |
||
| 29 | +357 |
- #' )+ tol = 1e-05) {
|
||
| 30 | -+ | |||
| 358 | +24x |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ if (missing(method)) {
|
||
| 31 | -+ | |||
| 359 | +1x |
- #'+ method <- "wilson" |
||
| 32 | +360 |
- #' # Unstratified analysis.+ } |
||
| 33 | -+ | |||
| 361 | +24x |
- #' df <- extract_rsp_subgroups(+ if (missing(sides)) {
|
||
| 34 | -+ | |||
| 362 | +23x |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ sides <- "two.sided" |
||
| 35 | +363 |
- #' data = adrs_f+ } |
||
| 36 | -+ | |||
| 364 | +24x |
- #' )+ iBinomCI <- function(x, n, conf.level = 0.95, sides = c( # nolint |
||
| 37 | -+ | |||
| 365 | +24x |
- #' df+ "two.sided", |
||
| 38 | -+ | |||
| 366 | +24x |
- #'+ "left", "right" |
||
| 39 | -+ | |||
| 367 | +24x |
- #' @name response_subgroups+ ), method = c( |
||
| 40 | -+ | |||
| 368 | +24x |
- NULL+ "wilson", "wilsoncc", "wald", |
||
| 41 | -+ | |||
| 369 | +24x |
-
+ "waldcc", "agresti-coull", "jeffreys", "modified wilson", |
||
| 42 | -+ | |||
| 370 | +24x |
- #' Prepares Response Data for Population Subgroups in Data Frames+ "modified jeffreys", "clopper-pearson", "arcsine", "logit", |
||
| 43 | -+ | |||
| 371 | +24x |
- #'+ "witting", "pratt", "midp", "lik", "blaker" |
||
| 44 | -+ | |||
| 372 | +24x |
- #' @description `r lifecycle::badge("stable")`
+ ), rand = 123, |
||
| 45 | -+ | |||
| 373 | +24x |
- #'+ tol = 1e-05) {
|
||
| 46 | -+ | |||
| 374 | +24x |
- #' Prepares response rates and odds ratios for population subgroups in data frames. Simple wrapper+ if (length(x) != 1) {
|
||
| 47 | -+ | |||
| 375 | +! |
- #' for [h_odds_ratio_subgroups_df()] and [h_proportion_subgroups_df()]. Result is a list of two+ stop("'x' has to be of length 1 (number of successes)")
|
||
| 48 | +376 |
- #' `data.frames`: `prop` and `or`. `variables` corresponds to the names of variables found in `data`,+ } |
||
| 49 | -+ | |||
| 377 | +24x |
- #' passed as a named `list` and requires elements `rsp`, `arm` and optionally `subgroups` and `strat`.+ if (length(n) != 1) {
|
||
| 50 | -+ | |||
| 378 | +! |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ stop("'n' has to be of length 1 (number of trials)")
|
||
| 51 | +379 |
- #'+ } |
||
| 52 | -+ | |||
| 380 | +24x |
- #' @inheritParams argument_convention+ if (length(conf.level) != 1) {
|
||
| 53 | -+ | |||
| 381 | +! |
- #' @inheritParams response_subgroups+ stop("'conf.level' has to be of length 1 (confidence level)")
|
||
| 54 | +382 |
- #' @param label_all (`string`)\cr label for the total population analysis.+ } |
||
| 55 | -+ | |||
| 383 | +24x |
- #'+ if (conf.level < 0.5 || conf.level > 1) {
|
||
| 56 | -+ | |||
| 384 | +! |
- #' @return A named list of two elements:+ stop("'conf.level' has to be in [0.5, 1]")
|
||
| 57 | +385 |
- #' * `prop`: A `data.frame` containing columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`, `var`,+ } |
||
| 58 | -+ | |||
| 386 | +24x |
- #' `var_label`, and `row_type`.+ sides <- match.arg(sides, choices = c( |
||
| 59 | -+ | |||
| 387 | +24x |
- #' * `or`: A `data.frame` containing columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`,+ "two.sided", "left", |
||
| 60 | -+ | |||
| 388 | +24x |
- #' `subgroup`, `var`, `var_label`, and `row_type`.+ "right" |
||
| 61 | -+ | |||
| 389 | +24x |
- #'+ ), several.ok = FALSE) |
||
| 62 | -+ | |||
| 390 | +24x |
- #' @seealso [response_subgroups]+ if (sides != "two.sided") {
|
||
| 63 | -+ | |||
| 391 | +1x |
- #'+ conf.level <- 1 - 2 * (1 - conf.level) # nolint |
||
| 64 | +392 |
- #' @examples+ } |
||
| 65 | -+ | |||
| 393 | +24x |
- #' library(dplyr)+ alpha <- 1 - conf.level |
||
| 66 | -+ | |||
| 394 | +24x |
- #' library(forcats)+ kappa <- stats::qnorm(1 - alpha / 2) |
||
| 67 | -+ | |||
| 395 | +24x |
- #'+ p_hat <- x / n |
||
| 68 | -+ | |||
| 396 | +24x |
- #' adrs <- tern_ex_adrs+ q_hat <- 1 - p_hat |
||
| 69 | -+ | |||
| 397 | +24x |
- #' adrs_labels <- formatters::var_labels(adrs)+ est <- p_hat |
||
| 70 | -+ | |||
| 398 | +24x |
- #'+ switch(match.arg(arg = method, choices = c( |
||
| 71 | -+ | |||
| 399 | +24x |
- #' adrs_f <- adrs %>%+ "wilson", |
||
| 72 | -+ | |||
| 400 | +24x |
- #' filter(PARAMCD == "BESRSPI") %>%+ "wald", "waldcc", "wilsoncc", "agresti-coull", "jeffreys", |
||
| 73 | -+ | |||
| 401 | +24x |
- #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+ "modified wilson", "modified jeffreys", "clopper-pearson", |
||
| 74 | -+ | |||
| 402 | +24x |
- #' droplevels() %>%+ "arcsine", "logit", "witting", "pratt", "midp", "lik", |
||
| 75 | -+ | |||
| 403 | +24x |
- #' mutate(+ "blaker" |
||
| 76 | +404 |
- #' # Reorder levels of factor to make the placebo group the reference arm.+ )), |
||
| 77 | -+ | |||
| 405 | +24x |
- #' ARM = fct_relevel(ARM, "B: Placebo"),+ wald = {
|
||
| 78 | -+ | |||
| 406 | +1x |
- #' rsp = AVALC == "CR"+ term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n) |
||
| 79 | -+ | |||
| 407 | +1x |
- #' )+ ci_lwr <- max(0, p_hat - term2) |
||
| 80 | -+ | |||
| 408 | +1x |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ ci_upr <- min(1, p_hat + term2) |
||
| 81 | +409 |
- #'+ }, |
||
| 82 | -+ | |||
| 410 | +24x |
- #' # Unstratified analysis.+ waldcc = {
|
||
| 83 | -+ | |||
| 411 | +1x |
- #' df <- extract_rsp_subgroups(+ term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n) |
||
| 84 | -+ | |||
| 412 | +1x |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ term2 <- term2 + 1 / (2 * n) |
||
| 85 | -+ | |||
| 413 | +1x |
- #' data = adrs_f+ ci_lwr <- max(0, p_hat - term2) |
||
| 86 | -+ | |||
| 414 | +1x |
- #' )+ ci_upr <- min(1, p_hat + term2) |
||
| 87 | +415 |
- #' df+ }, |
||
| 88 | -+ | |||
| 416 | +24x |
- #'+ wilson = {
|
||
| 89 | -+ | |||
| 417 | +6x |
- #' # Stratified analysis.+ term1 <- (x + kappa^2 / 2) / (n + kappa^2) |
||
| 90 | -+ | |||
| 418 | +6x |
- #' df_strat <- extract_rsp_subgroups(+ term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat * |
||
| 91 | -+ | |||
| 419 | +6x |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2"), strat = "STRATA1"),
+ q_hat + kappa^2 / (4 * n))+ |
+ ||
| 420 | +6x | +
+ ci_lwr <- max(0, term1 - term2)+ |
+ ||
| 421 | +6x | +
+ ci_upr <- min(1, term1 + term2) |
||
| 92 | +422 |
- #' data = adrs_f+ },+ |
+ ||
| 423 | +24x | +
+ wilsoncc = {
+ |
+ ||
| 424 | +3x | +
+ lci <- (2 * x + kappa^2 - 1 - kappa * sqrt(kappa^2 -+ |
+ ||
| 425 | +3x | +
+ 2 - 1 / n + 4 * p_hat * (n * q_hat + 1))) / (2 *+ |
+ ||
| 426 | +3x | +
+ (n + kappa^2))+ |
+ ||
| 427 | +3x | +
+ uci <- (2 * x + kappa^2 + 1 + kappa * sqrt(kappa^2 ++ |
+ ||
| 428 | +3x | +
+ 2 - 1 / n + 4 * p_hat * (n * q_hat - 1))) / (2 *+ |
+ ||
| 429 | +3x | +
+ (n + kappa^2))+ |
+ ||
| 430 | +3x | +
+ ci_lwr <- max(0, ifelse(p_hat == 0, 0, lci))+ |
+ ||
| 431 | +3x | +
+ ci_upr <- min(1, ifelse(p_hat == 1, 1, uci)) |
||
| 93 | +432 |
- #' )+ },+ |
+ ||
| 433 | +24x | +
+ `agresti-coull` = {
+ |
+ ||
| 434 | +1x | +
+ x_tilde <- x + kappa^2 / 2+ |
+ ||
| 435 | +1x | +
+ n_tilde <- n + kappa^2+ |
+ ||
| 436 | +1x | +
+ p_tilde <- x_tilde / n_tilde+ |
+ ||
| 437 | +1x | +
+ q_tilde <- 1 - p_tilde+ |
+ ||
| 438 | +1x | +
+ est <- p_tilde+ |
+ ||
| 439 | +1x | +
+ term2 <- kappa * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)+ |
+ ||
| 440 | +1x | +
+ ci_lwr <- max(0, p_tilde - term2)+ |
+ ||
| 441 | +1x | +
+ ci_upr <- min(1, p_tilde + term2) |
||
| 94 | +442 |
- #' df_strat+ },+ |
+ ||
| 443 | +24x | +
+ jeffreys = {
+ |
+ ||
| 444 | +1x | +
+ if (x == 0) {
+ |
+ ||
| 445 | +! | +
+ ci_lwr <- 0 |
||
| 95 | +446 |
- #'+ } else {
+ |
+ ||
| 447 | +1x | +
+ ci_lwr <- stats::qbeta(+ |
+ ||
| 448 | +1x | +
+ alpha / 2,+ |
+ ||
| 449 | +1x | +
+ x + 0.5, n - x + 0.5 |
||
| 96 | +450 |
- #' # Grouping of the BMRKR2 levels.+ ) |
||
| 97 | +451 |
- #' df_grouped <- extract_rsp_subgroups(+ } |
||
| 98 | -+ | |||
| 452 | +1x |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ if (x == n) {
|
||
| 99 | -+ | |||
| 453 | +! |
- #' data = adrs_f,+ ci_upr <- 1 |
||
| 100 | +454 |
- #' groups_lists = list(+ } else {
|
||
| 101 | -+ | |||
| 455 | +1x |
- #' BMRKR2 = list(+ ci_upr <- stats::qbeta(1 - |
||
| 102 | -+ | |||
| 456 | +1x |
- #' "low" = "LOW",+ alpha / 2, x + 0.5, n - x + 0.5) |
||
| 103 | +457 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ } |
||
| 104 | +458 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ }, |
||
| 105 | -+ | |||
| 459 | +24x |
- #' )+ `modified wilson` = {
|
||
| 106 | -+ | |||
| 460 | +1x |
- #' )+ term1 <- (x + kappa^2 / 2) / (n + kappa^2) |
||
| 107 | -+ | |||
| 461 | +1x |
- #' )+ term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat * |
||
| 108 | -+ | |||
| 462 | +1x |
- #' df_grouped+ q_hat + kappa^2 / (4 * n)) |
||
| 109 | -+ | |||
| 463 | +1x |
- #'+ if ((n <= 50 & x %in% c(1, 2)) | (n >= 51 & x %in% |
||
| 110 | -+ | |||
| 464 | +1x |
- #' @export+ c(1:3))) {
|
||
| 111 | -+ | |||
| 465 | +! |
- extract_rsp_subgroups <- function(variables,+ ci_lwr <- 0.5 * stats::qchisq(alpha, 2 * |
||
| 112 | -+ | |||
| 466 | +! |
- data,+ x) / n |
||
| 113 | +467 |
- groups_lists = list(),+ } else {
|
||
| 114 | -+ | |||
| 468 | +1x |
- conf_level = 0.95,+ ci_lwr <- max(0, term1 - term2) |
||
| 115 | +469 |
- method = NULL,+ } |
||
| 116 | -+ | |||
| 470 | +1x |
- label_all = "All Patients") {
+ if ((n <= 50 & x %in% c(n - 1, n - 2)) | (n >= 51 & |
||
| 117 | -10x | +471 | +1x |
- df_prop <- h_proportion_subgroups_df(+ x %in% c(n - (1:3)))) {
|
| 118 | -10x | +|||
| 472 | +! |
- variables,+ ci_upr <- 1 - 0.5 * stats::qchisq( |
||
| 119 | -10x | +|||
| 473 | +! |
- data,+ alpha, |
||
| 120 | -10x | +|||
| 474 | +! |
- groups_lists = groups_lists,+ 2 * (n - x) |
||
| 121 | -10x | +|||
| 475 | +! |
- label_all = label_all+ ) / n |
||
| 122 | +476 |
- )+ } else {
|
||
| 123 | -10x | +477 | +1x |
- df_or <- h_odds_ratio_subgroups_df(+ ci_upr <- min(1, term1 + |
| 124 | -10x | +478 | +1x |
- variables,+ term2) |
| 125 | -10x | +|||
| 479 | +
- data,+ } |
|||
| 126 | -10x | +|||
| 480 | +
- groups_lists = groups_lists,+ }, |
|||
| 127 | -10x | +481 | +24x |
- conf_level = conf_level,+ `modified jeffreys` = {
|
| 128 | -10x | +482 | +1x |
- method = method,+ if (x == n) {
|
| 129 | -10x | +|||
| 483 | +! |
- label_all = label_all+ ci_lwr <- (alpha / 2)^(1 / n) |
||
| 130 | +484 |
- )+ } else {
|
||
| 131 | -+ | |||
| 485 | +1x |
-
+ if (x <= 1) {
|
||
| 132 | -10x | +|||
| 486 | +! |
- list(prop = df_prop, or = df_or)+ ci_lwr <- 0 |
||
| 133 | +487 |
- }+ } else {
|
||
| 134 | -+ | |||
| 488 | +1x |
-
+ ci_lwr <- stats::qbeta( |
||
| 135 | -+ | |||
| 489 | +1x |
- #' @describeIn response_subgroups Formatted analysis function which is used as `afun` in `tabulate_rsp_subgroups()`.+ alpha / 2, |
||
| 136 | -+ | |||
| 490 | +1x |
- #'+ x + 0.5, n - x + 0.5 |
||
| 137 | +491 |
- #' @return+ ) |
||
| 138 | +492 |
- #' * `a_response_subgroups()` returns the corresponding list with formatted [rtables::CellValue()].+ } |
||
| 139 | +493 |
- #'+ } |
||
| 140 | -+ | |||
| 494 | +1x |
- #' @keywords internal+ if (x == 0) {
|
||
| 141 | -+ | |||
| 495 | +! |
- a_response_subgroups <- function(.formats = list(+ ci_upr <- 1 - (alpha / 2)^(1 / n) |
||
| 142 | +496 |
- n = "xx",+ } else {
|
||
| 143 | -+ | |||
| 497 | +1x |
- n_rsp = "xx",+ if (x >= n - 1) {
|
||
| 144 | -+ | |||
| 498 | +! |
- prop = "xx.x%",+ ci_upr <- 1 |
||
| 145 | +499 |
- n_tot = "xx",+ } else {
|
||
| 146 | -+ | |||
| 500 | +1x |
- or = list(format_extreme_values(2L)),+ ci_upr <- stats::qbeta(1 - |
||
| 147 | -+ | |||
| 501 | +1x |
- ci = list(format_extreme_values_ci(2L)),+ alpha / 2, x + 0.5, n - x + 0.5) |
||
| 148 | +502 |
- pval = "x.xxxx | (<0.0001)"+ } |
||
| 149 | +503 |
- )) {
+ } |
||
| 150 | -13x | +|||
| 504 | +
- checkmate::assert_list(.formats)+ }, |
|||
| 151 | -13x | +505 | +24x |
- checkmate::assert_subset(+ `clopper-pearson` = {
|
| 152 | -13x | +506 | +1x |
- names(.formats),+ ci_lwr <- stats::qbeta(alpha / 2, x, n - x + 1) |
| 153 | -13x | +507 | +1x |
- c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
+ ci_upr <- stats::qbeta(1 - alpha / 2, x + 1, n - x) |
| 154 | +508 |
- )+ }, |
||
| 155 | -+ | |||
| 509 | +24x |
-
+ arcsine = {
|
||
| 156 | -13x | +510 | +1x |
- afun_lst <- Map(+ p_tilde <- (x + 0.375) / (n + 0.75) |
| 157 | -13x | +511 | +1x |
- function(stat, fmt) {
+ est <- p_tilde |
| 158 | -86x | +512 | +1x |
- if (stat == "ci") {
+ ci_lwr <- sin(asin(sqrt(p_tilde)) - 0.5 * kappa / sqrt(n))^2 |
| 159 | -12x | +513 | +1x |
- function(df, labelstr = "", ...) {
+ ci_upr <- sin(asin(sqrt(p_tilde)) + 0.5 * kappa / sqrt(n))^2+ |
+
| 514 | ++ |
+ }, |
||
| 160 | +515 | 24x |
- in_rows(.list = combine_vectors(df$lcl, df$ucl), .labels = as.character(df$subgroup), .formats = fmt)+ logit = {
|
|
| 161 | -+ | |||
| 516 | +1x |
- }+ lambda_hat <- log(x / (n - x)) |
||
| 162 | -+ | |||
| 517 | +1x |
- } else {
+ V_hat <- n / (x * (n - x)) # nolint |
||
| 163 | -74x | +518 | +1x |
- function(df, labelstr = "", ...) {
+ lambda_lower <- lambda_hat - kappa * sqrt(V_hat) |
| 164 | -142x | +519 | +1x |
- in_rows(.list = as.list(df[[stat]]), .labels = as.character(df$subgroup), .formats = fmt)+ lambda_upper <- lambda_hat + kappa * sqrt(V_hat) |
| 165 | -+ | |||
| 520 | +1x |
- }+ ci_lwr <- exp(lambda_lower) / (1 + exp(lambda_lower)) |
||
| 166 | -+ | |||
| 521 | +1x |
- }+ ci_upr <- exp(lambda_upper) / (1 + exp(lambda_upper)) |
||
| 167 | +522 |
}, |
||
| 168 | -13x | +523 | +24x |
- stat = names(.formats),+ witting = {
|
| 169 | -13x | +524 | +1x |
- fmt = .formats+ set.seed(rand) |
| 170 | -+ | |||
| 525 | +1x |
- )+ x_tilde <- x + stats::runif(1, min = 0, max = 1) |
||
| 171 | -+ | |||
| 526 | +1x |
-
+ pbinom_abscont <- function(q, size, prob) {
|
||
| 172 | -13x | +527 | +22x |
- afun_lst+ v <- trunc(q) |
| 173 | -+ | |||
| 528 | +22x |
- }+ term1 <- stats::pbinom(v - 1, size = size, prob = prob) |
||
| 174 | -+ | |||
| 529 | +22x |
-
+ term2 <- (q - v) * stats::dbinom(v, size = size, prob = prob) |
||
| 175 | -+ | |||
| 530 | +22x |
- #' @describeIn response_subgroups Table-creating function which creates a table+ return(term1 + term2) |
||
| 176 | +531 |
- #' summarizing binary response by subgroup. This function is a wrapper for [rtables::analyze_colvars()]+ } |
||
| 177 | -+ | |||
| 532 | +1x |
- #' and [rtables::summarize_row_groups()].+ qbinom_abscont <- function(p, size, x) {
|
||
| 178 | -+ | |||
| 533 | +2x |
- #'+ fun <- function(prob, size, x, p) {
|
||
| 179 | -+ | |||
| 534 | +22x |
- #' @param df (`list`)\cr of data frames containing all analysis variables. List should be+ pbinom_abscont(x, size, prob) - p |
||
| 180 | +535 |
- #' created using [extract_rsp_subgroups()].+ } |
||
| 181 | -+ | |||
| 536 | +2x |
- #' @param vars (`character`)\cr the names of statistics to be reported among:+ stats::uniroot(fun, |
||
| 182 | -+ | |||
| 537 | +2x |
- #' * `n`: Total number of observations per group.+ interval = c(0, 1), size = size, |
||
| 183 | -+ | |||
| 538 | +2x |
- #' * `n_rsp`: Number of responders per group.+ x = x, p = p |
||
| 184 | -+ | |||
| 539 | +2x |
- #' * `prop`: Proportion of responders.+ )$root |
||
| 185 | +540 |
- #' * `n_tot`: Total number of observations.+ } |
||
| 186 | -+ | |||
| 541 | +1x |
- #' * `or`: Odds ratio.+ ci_lwr <- qbinom_abscont(1 - alpha, size = n, x = x_tilde) |
||
| 187 | -+ | |||
| 542 | +1x |
- #' * `ci` : Confidence interval of odds ratio.+ ci_upr <- qbinom_abscont(alpha, size = n, x = x_tilde) |
||
| 188 | +543 |
- #' * `pval`: p-value of the effect.+ }, |
||
| 189 | -+ | |||
| 544 | +24x |
- #' Note, the statistics `n_tot`, `or` and `ci` are required.+ pratt = {
|
||
| 190 | -+ | |||
| 545 | +1x |
- #'+ if (x == 0) {
|
||
| 191 | -+ | |||
| 546 | +! |
- #' @return An `rtables` table summarizing binary response by subgroup.+ ci_lwr <- 0 |
||
| 192 | -+ | |||
| 547 | +! |
- #'+ ci_upr <- 1 - alpha^(1 / n) |
||
| 193 | -+ | |||
| 548 | +1x |
- #' @examples+ } else if (x == 1) {
|
||
| 194 | -+ | |||
| 549 | +! |
- #' ## Table with default columns.+ ci_lwr <- 1 - (1 - alpha / 2)^(1 / n) |
||
| 195 | -+ | |||
| 550 | +! |
- #' basic_table() %>%+ ci_upr <- 1 - (alpha / 2)^(1 / n) |
||
| 196 | -+ | |||
| 551 | +1x |
- #' tabulate_rsp_subgroups(df)+ } else if (x == (n - 1)) {
|
||
| 197 | -+ | |||
| 552 | +! |
- #'+ ci_lwr <- (alpha / 2)^(1 / n) |
||
| 198 | -+ | |||
| 553 | +! |
- #' ## Table with selected columns.+ ci_upr <- (1 - alpha / 2)^(1 / n) |
||
| 199 | -+ | |||
| 554 | +1x |
- #' basic_table() %>%+ } else if (x == n) {
|
||
| 200 | -+ | |||
| 555 | +! |
- #' tabulate_rsp_subgroups(+ ci_lwr <- alpha^(1 / n) |
||
| 201 | -+ | |||
| 556 | +! |
- #' df = df,+ ci_upr <- 1 |
||
| 202 | +557 |
- #' vars = c("n_tot", "n", "n_rsp", "prop", "or", "ci")
+ } else {
|
||
| 203 | -+ | |||
| 558 | +1x |
- #' )+ z <- stats::qnorm(1 - alpha / 2) |
||
| 204 | -+ | |||
| 559 | +1x |
- #'+ A <- ((x + 1) / (n - x))^2 # nolint |
||
| 205 | -+ | |||
| 560 | +1x |
- #' @export+ B <- 81 * (x + 1) * (n - x) - 9 * n - 8 # nolint |
||
| 206 | -+ | |||
| 561 | +1x |
- tabulate_rsp_subgroups <- function(lyt,+ C <- (0 - 3) * z * sqrt(9 * (x + 1) * (n - x) * (9 * n + 5 - z^2) + n + 1) # nolint |
||
| 207 | -+ | |||
| 562 | +1x |
- df,+ D <- 81 * (x + 1)^2 - 9 * (x + 1) * (2 + z^2) + 1 # nolint |
||
| 208 | -+ | |||
| 563 | +1x |
- vars = c("n_tot", "n", "prop", "or", "ci")) {
+ E <- 1 + A * ((B + C) / D)^3 # nolint |
||
| 209 | -6x | +564 | +1x |
- conf_level <- df$or$conf_level[1]+ ci_upr <- 1 / E |
| 210 | -6x | +565 | +1x |
- method <- if ("pval_label" %in% names(df$or)) {
+ A <- (x / (n - x - 1))^2 # nolint |
| 211 | -4x | +566 | +1x |
- df$or$pval_label[1]+ B <- 81 * x * (n - x - 1) - 9 * n - 8 # nolint |
| 212 | -+ | |||
| 567 | +1x |
- } else {
+ C <- 3 * z * sqrt(9 * x * (n - x - 1) * (9 * n + 5 - z^2) + n + 1) # nolint |
||
| 213 | -2x | +568 | +1x |
- NULL+ D <- 81 * x^2 - 9 * x * (2 + z^2) + 1 # nolint+ |
+
| 569 | +1x | +
+ E <- 1 + A * ((B + C) / D)^3 # nolint+ |
+ ||
| 570 | +1x | +
+ ci_lwr <- 1 / E |
||
| 214 | +571 |
- }+ } |
||
| 215 | +572 |
-
+ }, |
||
| 216 | -6x | +573 | +24x |
- afun_lst <- a_response_subgroups()+ midp = {
|
| 217 | -6x | +574 | +1x |
- colvars <- d_rsp_subgroups_colvars(vars, conf_level = conf_level, method = method)+ f_low <- function(pi, x, n) {
|
| 218 | -+ | |||
| 575 | +12x |
-
+ 1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x, |
||
| 219 | -6x | +576 | +12x |
- colvars_prop <- list(+ size = n, prob = pi, lower.tail = FALSE |
| 220 | -6x | +|||
| 577 | +
- vars = colvars$vars[names(colvars$labels) %in% c("n", "prop", "n_rsp")],
+ ) - |
|||
| 221 | -6x | +578 | +12x |
- labels = colvars$labels[names(colvars$labels) %in% c("n", "prop", "n_rsp")]
+ (1 - conf.level) / 2 |
| 222 | +579 |
- )+ } |
||
| 223 | -6x | +580 | +1x |
- colvars_or <- list(+ f_up <- function(pi, x, n) {
|
| 224 | -6x | +581 | +12x |
- vars = colvars$vars[names(colvars$labels) %in% c("n_tot", "or", "ci", "pval")],
+ 1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x - |
| 225 | -6x | -
- labels = colvars$labels[names(colvars$labels) %in% c("n_tot", "or", "ci", "pval")]
- |
- ||
| 226 | -+ | 582 | +12x |
- )+ 1, size = n, prob = pi) - (1 - conf.level) / 2 |
| 227 | +583 |
-
+ } |
||
| 228 | -+ | |||
| 584 | +1x |
- # Columns from table_prop are optional.+ ci_lwr <- 0 |
||
| 229 | -6x | +585 | +1x |
- if (length(colvars_prop$vars) > 0) {
+ ci_upr <- 1 |
| 230 | -6x | +586 | +1x |
- lyt_prop <- split_cols_by(lyt = lyt, var = "arm")+ if (x != 0) {
|
| 231 | -6x | +587 | +1x |
- lyt_prop <- split_cols_by_multivar(+ ci_lwr <- stats::uniroot(f_low, |
| 232 | -6x | +588 | +1x |
- lyt = lyt_prop,+ interval = c(0, p_hat), |
| 233 | -6x | +589 | +1x |
- vars = colvars_prop$vars,+ x = x, n = n |
| 234 | -6x | +590 | +1x |
- varlabels = colvars_prop$labels+ )$root |
| 235 | +591 |
- )+ } |
||
| 236 | -+ | |||
| 592 | +1x |
-
+ if (x != n) {
|
||
| 237 | -+ | |||
| 593 | +1x |
- # "All Patients" row+ ci_upr <- stats::uniroot(f_up, interval = c( |
||
| 238 | -6x | +594 | +1x |
- lyt_prop <- split_rows_by(+ p_hat, |
| 239 | -6x | +595 | +1x |
- lyt = lyt_prop,+ 1 |
| 240 | -6x | +596 | +1x |
- var = "row_type",+ ), x = x, n = n)$root |
| 241 | -6x | +|||
| 597 | +
- split_fun = keep_split_levels("content"),
+ } |
|||
| 242 | -6x | +|||
| 598 | +
- nested = FALSE,+ }, |
|||
| 243 | -6x | +599 | +24x |
- child_labels = "hidden"+ lik = {
|
| 244 | -+ | |||
| 600 | +2x |
- )+ ci_lwr <- 0 |
||
| 245 | -6x | +601 | +2x |
- lyt_prop <- analyze_colvars(+ ci_upr <- 1 |
| 246 | -6x | +|||
| 602 | +2x |
- lyt = lyt_prop,+ z <- stats::qnorm(1 - alpha * 0.5) |
||
| 247 | -6x | +603 | +2x |
- afun = afun_lst[names(colvars_prop$labels)]+ tol <- .Machine$double.eps^0.5 |
| 248 | -+ | |||
| 604 | +2x |
- )+ BinDev <- function(y, x, mu, wt, bound = 0, tol = .Machine$double.eps^0.5, # nolint |
||
| 249 | +605 |
-
+ ...) {
|
||
| 250 | -6x | +606 | +40x |
- if ("analysis" %in% df$prop$row_type) {
+ ll_y <- ifelse(y %in% c(0, 1), 0, stats::dbinom(x, wt, |
| 251 | -5x | +607 | +40x |
- lyt_prop <- split_rows_by(+ y, |
| 252 | -5x | +608 | +40x |
- lyt = lyt_prop,+ log = TRUE |
| 253 | -5x | +|||
| 609 | +
- var = "row_type",+ )) |
|||
| 254 | -5x | +610 | +40x |
- split_fun = keep_split_levels("analysis"),
+ ll_mu <- ifelse(mu %in% c(0, 1), 0, stats::dbinom(x, |
| 255 | -5x | +611 | +40x |
- nested = FALSE,+ wt, mu, |
| 256 | -5x | +612 | +40x |
- child_labels = "hidden"+ log = TRUE |
| 257 | +613 |
- )+ )) |
||
| 258 | -5x | +614 | +40x |
- lyt_prop <- split_rows_by(lyt = lyt_prop, var = "var_label", nested = TRUE)+ res <- ifelse(abs(y - mu) < tol, 0, sign(y - |
| 259 | -5x | +615 | +40x |
- lyt_prop <- analyze_colvars(+ mu) * sqrt(-2 * (ll_y - ll_mu))) |
| 260 | -5x | +616 | +40x |
- lyt = lyt_prop,+ return(res - bound) |
| 261 | -5x | +|||
| 617 | +
- afun = afun_lst[names(colvars_prop$labels)],+ } |
|||
| 262 | -5x | +618 | +2x |
- inclNAs = TRUE+ if (x != 0 && tol < p_hat) {
|
| 263 | -+ | |||
| 619 | +2x |
- )+ ci_lwr <- if (BinDev( |
||
| 264 | -+ | |||
| 620 | +2x |
- }+ tol, x, p_hat, n, -z, |
||
| 265 | -+ | |||
| 621 | +2x |
-
+ tol |
||
| 266 | -6x | +622 | +2x |
- table_prop <- build_table(lyt_prop, df = df$prop)+ ) <= 0) {
|
| 267 | -+ | |||
| 623 | +2x |
- } else {
+ stats::uniroot( |
||
| 268 | -! | +|||
| 624 | +2x |
- table_prop <- NULL+ f = BinDev, interval = c(tol, if (p_hat < |
||
| 269 | -+ | |||
| 625 | +2x |
- }+ tol || p_hat == 1) {
|
||
| 270 | -+ | |||
| 626 | +! |
-
+ 1 - tol |
||
| 271 | +627 |
- # Columns "n_tot", "or", "ci" in table_or are required.- |
- ||
| 272 | -6x | -
- lyt_or <- split_cols_by(lyt = lyt, var = "arm")+ } else {
|
||
| 273 | -6x | +628 | +2x |
- lyt_or <- split_cols_by_multivar(+ p_hat |
| 274 | -6x | +629 | +2x |
- lyt = lyt_or,+ }), bound = -z, |
| 275 | -6x | +630 | +2x |
- vars = colvars_or$vars,+ x = x, mu = p_hat, wt = n |
| 276 | -6x | +631 | +2x |
- varlabels = colvars_or$labels+ )$root |
| 277 | +632 |
- )+ } |
||
| 278 | +633 |
-
+ } |
||
| 279 | -+ | |||
| 634 | +2x |
- # "All Patients" row+ if (x != n && p_hat < (1 - tol)) {
|
||
| 280 | -6x | +635 | +2x |
- lyt_or <- split_rows_by(+ ci_upr <- if (BinDev(y = 1 - tol, x = x, mu = ifelse(p_hat > |
| 281 | -6x | +636 | +2x |
- lyt = lyt_or,+ 1 - tol, tol, p_hat), wt = n, bound = z, tol = tol) < |
| 282 | -6x | +637 | +2x |
- var = "row_type",+ 0) {
|
| 283 | -6x | +|||
| 638 | +! |
- split_fun = keep_split_levels("content"),
+ ci_lwr <- if (BinDev( |
||
| 284 | -6x | +|||
| 639 | +! |
- nested = FALSE,+ tol, x, if (p_hat < |
||
| 285 | -6x | +|||
| 640 | +! |
- child_labels = "hidden"+ tol || p_hat == 1) {
+ |
+ ||
| 641 | +! | +
+ 1 - tol |
||
| 286 | +642 |
- )+ } else {
|
||
| 287 | -6x | +|||
| 643 | +! |
- lyt_or <- analyze_colvars(+ p_hat |
||
| 288 | -6x | +|||
| 644 | +! |
- lyt = lyt_or,+ }, n, |
||
| 289 | -6x | +|||
| 645 | +! |
- afun = afun_lst[names(colvars_or$labels)]+ -z, tol |
||
| 290 | -+ | |||
| 646 | +! |
- ) %>%+ ) <= 0) {
|
||
| 291 | -6x | +|||
| 647 | +! |
- append_topleft("Baseline Risk Factors")
+ stats::uniroot( |
||
| 292 | -+ | |||
| 648 | +! |
-
+ f = BinDev, interval = c(tol, p_hat), |
||
| 293 | -6x | +|||
| 649 | +! |
- if ("analysis" %in% df$or$row_type) {
+ bound = -z, x = x, mu = p_hat, wt = n |
||
| 294 | -5x | +|||
| 650 | +! |
- lyt_or <- split_rows_by(+ )$root |
||
| 295 | -5x | +|||
| 651 | +
- lyt = lyt_or,+ } |
|||
| 296 | -5x | +|||
| 652 | +
- var = "row_type",+ } else {
|
|||
| 297 | -5x | +653 | +2x |
- split_fun = keep_split_levels("analysis"),
+ stats::uniroot( |
| 298 | -5x | +654 | +2x |
- nested = FALSE,+ f = BinDev, interval = c(if (p_hat > |
| 299 | -5x | +655 | +2x |
- child_labels = "hidden"+ 1 - tol) {
|
| 300 | -+ | |||
| 656 | +! |
- )+ tol |
||
| 301 | -5x | +|||
| 657 | +
- lyt_or <- split_rows_by(lyt = lyt_or, var = "var_label", nested = TRUE)+ } else {
|
|||
| 302 | -5x | +658 | +2x |
- lyt_or <- analyze_colvars(+ p_hat |
| 303 | -5x | +659 | +2x |
- lyt = lyt_or,+ }, 1 - tol), bound = z, |
| 304 | -5x | +660 | +2x |
- afun = afun_lst[names(colvars_or$labels)],+ x = x, mu = p_hat, wt = n |
| 305 | -5x | +661 | +2x |
- inclNAs = TRUE+ )$root |
| 306 | +662 |
- )+ } |
||
| 307 | +663 |
- }- |
- ||
| 308 | -6x | -
- table_or <- build_table(lyt_or, df = df$or)+ } |
||
| 309 | +664 |
-
+ }, |
||
| 310 | -6x | +665 | +24x |
- n_tot_id <- match("n_tot", colvars_or$vars)
+ blaker = {
|
| 311 | -6x | +666 | +1x |
- if (is.null(table_prop)) {
+ acceptbin <- function(x, n, p) {
|
| 312 | -! | +|||
| 667 | +3954x |
- result <- table_or+ p1 <- 1 - stats::pbinom(x - 1, n, p) |
||
| 313 | -! | +|||
| 668 | +3954x |
- or_id <- match("or", colvars_or$vars)
+ p2 <- stats::pbinom(x, n, p) |
||
| 314 | -! | +|||
| 669 | +3954x |
- ci_id <- match("lcl", colvars_or$vars)
+ a1 <- p1 + stats::pbinom(stats::qbinom(p1, n, p) - 1, n, p) |
||
| 315 | -+ | |||
| 670 | +3954x |
- } else {
+ a2 <- p2 + 1 - stats::pbinom( |
||
| 316 | -6x | +671 | +3954x |
- result <- cbind_rtables(table_or[, n_tot_id], table_prop, table_or[, -n_tot_id])+ stats::qbinom(1 - p2, n, p), n, |
| 317 | -6x | +672 | +3954x |
- or_id <- 1L + ncol(table_prop) + match("or", colvars_or$vars[-n_tot_id])
+ p |
| 318 | -6x | +|||
| 673 | +
- ci_id <- 1L + ncol(table_prop) + match("lcl", colvars_or$vars[-n_tot_id])
+ ) |
|||
| 319 | -6x | +674 | +3954x |
- n_tot_id <- 1L+ return(min(a1, a2)) |
| 320 | +675 |
- }+ } |
||
| 321 | -6x | +676 | +1x |
- structure(+ ci_lwr <- 0 |
| 322 | -6x | +677 | +1x |
- result,+ ci_upr <- 1 |
| 323 | -6x | +678 | +1x |
- forest_header = paste0(levels(df$prop$arm), "\nBetter"),+ if (x != 0) {
|
| 324 | -6x | +679 | +1x |
- col_x = or_id,+ ci_lwr <- stats::qbeta((1 - conf.level) / 2, x, n - |
| 325 | -6x | +680 | +1x |
- col_ci = ci_id,+ x + 1) |
| 326 | -6x | +681 | +1x |
- col_symbol_size = n_tot_id+ while (acceptbin(x, n, ci_lwr + tol) < (1 - |
| 327 | -+ | |||
| 682 | +1x |
- )+ conf.level)) {
|
||
| 328 | -+ | |||
| 683 | +1976x |
- }+ ci_lwr <- ci_lwr + tol |
||
| 329 | +684 |
-
+ } |
||
| 330 | +685 |
- #' Labels for Column Variables in Binary Response by Subgroup Table+ } |
||
| 331 | -+ | |||
| 686 | +1x |
- #'+ if (x != n) {
|
||
| 332 | -+ | |||
| 687 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ ci_upr <- stats::qbeta(1 - (1 - conf.level) / 2, x + |
||
| 333 | -+ | |||
| 688 | +1x |
- #'+ 1, n - x) |
||
| 334 | -+ | |||
| 689 | +1x |
- #' Internal function to check variables included in [tabulate_rsp_subgroups()] and create column labels.+ while (acceptbin(x, n, ci_upr - tol) < (1 - |
||
| 335 | -+ | |||
| 690 | +1x |
- #'+ conf.level)) {
|
||
| 336 | -+ | |||
| 691 | +1976x |
- #' @inheritParams argument_convention+ ci_upr <- ci_upr - tol |
||
| 337 | +692 |
- #' @inheritParams tabulate_rsp_subgroups+ } |
||
| 338 | +693 |
- #'+ } |
||
| 339 | +694 |
- #' @return A `list` of variables to tabulate and their labels.+ } |
||
| 340 | +695 |
- #'+ ) |
||
| 341 | -+ | |||
| 696 | +24x |
- #' @export+ ci <- c(est = est, lwr.ci = max(0, ci_lwr), upr.ci = min( |
||
| 342 | -+ | |||
| 697 | +24x |
- d_rsp_subgroups_colvars <- function(vars,+ 1, |
||
| 343 | -+ | |||
| 698 | +24x |
- conf_level = NULL,+ ci_upr |
||
| 344 | +699 |
- method = NULL) {
- |
- ||
| 345 | -13x | -
- checkmate::assert_character(vars)- |
- ||
| 346 | -13x | -
- checkmate::assert_subset(c("n_tot", "or", "ci"), vars)
+ )) |
||
| 347 | -13x | +700 | +24x |
- checkmate::assert_subset(+ if (sides == "left") {
|
| 348 | -13x | +701 | +1x |
- vars,+ ci[3] <- 1 |
| 349 | -13x | +702 | +23x |
- c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
+ } else if (sides == "right") {
|
| 350 | -+ | |||
| 703 | +! |
- )+ ci[2] <- 0 |
||
| 351 | +704 | - - | -||
| 352 | -13x | -
- varlabels <- c(+ } |
||
| 353 | -13x | +705 | +24x |
- n = "n",+ return(ci) |
| 354 | -13x | +|||
| 706 | +
- n_rsp = "Responders",+ } |
|||
| 355 | -13x | +707 | +24x |
- prop = "Response (%)",+ lst <- list( |
| 356 | -13x | +708 | +24x |
- n_tot = "Total n",+ x = x, n = n, conf.level = conf.level, sides = sides, |
| 357 | -13x | +709 | +24x |
- or = "Odds Ratio"+ method = method, rand = rand |
| 358 | +710 |
) |
||
| 359 | -13x | +711 | +24x |
- colvars <- vars+ maxdim <- max(unlist(lapply(lst, length))) |
| 360 | -+ | |||
| 712 | +24x |
-
+ lgp <- lapply(lst, rep, length.out = maxdim) |
||
| 361 | -13x | +713 | +24x |
- if ("ci" %in% colvars) {
+ lgn <- h_recycle(x = if (is.null(names(x))) {
|
| 362 | -13x | +714 | +24x |
- checkmate::assert_false(is.null(conf_level))+ paste("x", seq_along(x), sep = ".")
|
| 363 | +715 |
-
+ } else {
|
||
| 364 | -13x | +|||
| 716 | +! |
- varlabels <- c(+ names(x) |
||
| 365 | -13x | +717 | +24x |
- varlabels,+ }, n = if (is.null(names(n))) {
|
| 366 | -13x | +718 | +24x |
- ci = paste0(100 * conf_level, "% CI")+ paste("n", seq_along(n), sep = ".")
|
| 367 | +719 |
- )+ } else {
|
||
| 368 | -+ | |||
| 720 | +! |
-
+ names(n) |
||
| 369 | -+ | |||
| 721 | +24x |
- # The `lcl`` variable is just a placeholder available in the analysis data,+ }, conf.level = conf.level, sides = sides, method = method) |
||
| 370 | -+ | |||
| 722 | +24x |
- # it is not acutally used in the tabulation.+ xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
|
||
| 371 | -+ | |||
| 723 | +120x |
- # Variables used in the tabulation are lcl and ucl, see `a_response_subgroups` for details.+ length(unique(x)) != |
||
| 372 | -13x | +724 | +120x |
- colvars[colvars == "ci"] <- "lcl"+ 1 |
| 373 | -+ | |||
| 725 | +24x |
- }+ })]), 1, paste, collapse = ":") |
||
| 374 | -+ | |||
| 726 | +24x |
-
+ res <- t(sapply(1:maxdim, function(i) {
|
||
| 375 | -13x | +727 | +24x |
- if ("pval" %in% colvars) {
+ iBinomCI( |
| 376 | -10x | +728 | +24x |
- varlabels <- c(+ x = lgp$x[i], |
| 377 | -10x | +729 | +24x |
- varlabels,+ n = lgp$n[i], conf.level = lgp$conf.level[i], sides = lgp$sides[i], |
| 378 | -10x | +730 | +24x |
- pval = method+ method = lgp$method[i], rand = lgp$rand[i] |
| 379 | +731 |
) |
||
| 380 | -- |
- }- |
- ||
| 381 | +732 |
-
+ })) |
||
| 382 | -13x | +733 | +24x |
- list(+ colnames(res)[1] <- c("est")
|
| 383 | -13x | +734 | +24x |
- vars = colvars,+ rownames(res) <- xn |
| 384 | -13x | -
- labels = varlabels[vars]- |
- ||
| 385 | -+ | 735 | +24x |
- )+ return(res) |
| 386 | +736 |
}@@ -9425,14 +10824,14 @@ tern coverage - 94.83% |
| 1 |
- #' Helper Functions for Multivariate Logistic Regression+ #' Kaplan-Meier Plot |
|||
| 5 |
- #' Helper functions used in calculations for logistic regression.+ #' From a survival model, a graphic is rendered along with tabulated annotation |
|||
| 6 |
- #'+ #' including the number of patient at risk at given time and the median survival |
|||
| 7 |
- #' @inheritParams argument_convention+ #' per group. |
|||
| 8 |
- #' @param fit_glm (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family.+ #' |
|||
| 9 |
- #' Limited functionality is also available for conditional logistic regression models fitted by+ #' @inheritParams grid::gTree |
|||
| 10 |
- #' [survival::clogit()], currently this is used only by [extract_rsp_biomarkers()].+ #' @inheritParams argument_convention |
|||
| 11 |
- #' @param x (`string` or `character`)\cr a variable or interaction term in `fit_glm` (depending on the+ #' @param df (`data.frame`)\cr data set containing all analysis variables. |
|||
| 12 |
- #' helper function).+ #' @param variables (named `list`)\cr variable names. Details are: |
|||
| 13 |
- #'+ #' * `tte` (`numeric`)\cr variable indicating time-to-event duration values. |
|||
| 14 |
- #' @examples+ #' * `is_event` (`logical`)\cr event variable. `TRUE` if event, `FALSE` if time to event is censored. |
|||
| 15 |
- #' library(dplyr)+ #' * `arm` (`factor`)\cr the treatment group variable. |
|||
| 16 |
- #' library(broom)+ #' * `strat` (`character` or `NULL`)\cr variable names indicating stratification factors. |
|||
| 17 |
- #'+ #' @param control_surv (`list`)\cr parameters for comparison details, specified by using |
|||
| 18 |
- #' adrs_f <- tern_ex_adrs %>%+ #' the helper function [control_surv_timepoint()]. Some possible parameter options are: |
|||
| 19 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate. |
|||
| 20 |
- #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ #' * `conf_type` (`string`)\cr `"plain"` (default), `"log"`, `"log-log"` for confidence interval type, |
|||
| 21 |
- #' mutate(+ #' see more in [survival::survfit()]. Note that the option "none" is no longer supported. |
|||
| 22 |
- #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ #' @param xticks (`numeric`, `number`, or `NULL`)\cr numeric vector of ticks or single number with spacing |
|||
| 23 |
- #' RACE = factor(RACE),+ #' between ticks on the x axis. If `NULL` (default), [labeling::extended()] is used to determine |
|||
| 24 |
- #' SEX = factor(SEX)+ #' an optimal tick position on the x axis. |
|||
| 25 |
- #' )+ #' @param yval (`string`)\cr value of y-axis. Options are `Survival` (default) and `Failure` probability. |
|||
| 26 |
- #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ #' @param censor_show (`flag`)\cr whether to show censored. |
|||
| 27 |
- #' mod1 <- fit_logistic(+ #' @param xlab (`string`)\cr label of x-axis. |
|||
| 28 |
- #' data = adrs_f,+ #' @param ylab (`string`)\cr label of y-axis. |
|||
| 29 |
- #' variables = list(+ #' @param ylim (`vector` of `numeric`)\cr vector of length 2 containing lower and upper limits for the y-axis. |
|||
| 30 |
- #' response = "Response",+ #' If `NULL` (default), the minimum and maximum y-values displayed are used as limits. |
|||
| 31 |
- #' arm = "ARMCD",+ #' @param title (`string`)\cr title for plot. |
|||
| 32 |
- #' covariates = c("AGE", "RACE")
+ #' @param footnotes (`string`)\cr footnotes for plot. |
|||
| 33 |
- #' )+ #' @param col (`character`)\cr lines colors. Length of a vector should be equal |
|||
| 34 |
- #' )+ #' to number of strata from [survival::survfit()]. |
|||
| 35 |
- #' mod2 <- fit_logistic(+ #' @param lty (`numeric`)\cr line type. Length of a vector should be equal |
|||
| 36 |
- #' data = adrs_f,+ #' to number of strata from [survival::survfit()]. |
|||
| 37 |
- #' variables = list(+ #' @param lwd (`numeric`)\cr line width. Length of a vector should be equal |
|||
| 38 |
- #' response = "Response",+ #' to number of strata from [survival::survfit()]. |
|||
| 39 |
- #' arm = "ARMCD",+ #' @param pch (`numeric`, `string`)\cr value or character of points symbol to indicate censored cases. |
|||
| 40 |
- #' covariates = c("AGE", "RACE"),
+ #' @param size (`numeric`)\cr size of censored point, a class of `unit`. |
|||
| 41 |
- #' interaction = "AGE"+ #' @param max_time (`numeric`)\cr maximum value to show on X axis. Only data values less than or up to |
|||
| 42 |
- #' )+ #' this threshold value will be plotted (defaults to `NULL`). |
|||
| 43 |
- #' )+ #' @param font_size (`number`)\cr font size to be used. |
|||
| 44 |
- #'+ #' @param ci_ribbon (`flag`)\cr draw the confidence interval around the Kaplan-Meier curve. |
|||
| 45 |
- #' @name h_logistic_regression+ #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control outlook of the Kaplan-Meier curve. |
|||
| 46 |
- NULL+ #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of patient at risk |
|||
| 47 |
-
+ #' matching the main grid of the Kaplan-Meier curve. |
|||
| 48 |
- #' @describeIn h_logistic_regression Helper function to extract interaction variable names from a fitted+ #' @param annot_at_risk_title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk` |
|||
| 49 |
- #' model assuming only one interaction term.+ #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`. |
|||
| 50 |
- #'+ #' @param annot_surv_med (`flag`)\cr compute and add the annotation table on the Kaplan-Meier curve estimating the |
|||
| 51 |
- #' @return Vector of names of interaction variables.+ #' median survival time per group. |
|||
| 52 |
- #'+ #' @param annot_coxph (`flag`)\cr add the annotation table from a [survival::coxph()] model. |
|||
| 53 |
- #' @export+ #' @param annot_stats (`string`)\cr statistics annotations to add to the plot. Options are |
|||
| 54 |
- h_get_interaction_vars <- function(fit_glm) {
+ #' `median` (median survival follow-up time) and `min` (minimum survival follow-up time). |
|||
| 55 | -27x | +
- checkmate::assert_class(fit_glm, "glm")+ #' @param annot_stats_vlines (`flag`)\cr add vertical lines corresponding to each of the statistics |
||
| 56 | -27x | +
- terms_name <- attr(stats::terms(fit_glm), "term.labels")+ #' specified by `annot_stats`. If `annot_stats` is `NULL` no lines will be added. |
||
| 57 | -27x | +
- terms_order <- attr(stats::terms(fit_glm), "order")+ #' @param control_coxph_pw (`list`)\cr parameters for comparison details, specified by using |
||
| 58 | -27x | +
- interaction_term <- terms_name[terms_order == 2]+ #' the helper function [control_coxph()]. Some possible parameter options are: |
||
| 59 | -27x | +
- checkmate::assert_string(interaction_term)+ #' * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1. |
||
| 60 | -27x | +
- strsplit(interaction_term, split = ":")[[1]]+ #' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`. |
||
| 61 |
- }+ #' * `ties` (`string`)\cr method for tie handling. Default is `"efron"`, |
|||
| 62 |
-
+ #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()] |
|||
| 63 |
- #' @describeIn h_logistic_regression Helper function to get the right coefficient name from the+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR. |
|||
| 64 |
- #' interaction variable names and the given levels. The main value here is that the order+ #' @param position_coxph (`numeric`)\cr x and y positions for plotting [survival::coxph()] model. |
|||
| 65 |
- #' of first and second variable is checked in the `interaction_vars` input.+ #' @param position_surv_med (`numeric`)\cr x and y positions for plotting annotation table estimating median survival |
|||
| 66 |
- #'+ #' time per group. |
|||
| 67 |
- #' @param interaction_vars (`character` of length 2)\cr interaction variable names.+ #' @param width_annots (named `list` of `unit`s)\cr a named list of widths for annotation tables with names `surv_med` |
|||
| 68 |
- #' @param first_var_with_level (`character` of length 2)\cr the first variable name with+ #' (median survival time table) and `coxph` ([survival::coxph()] model table), where each value is the width |
|||
| 69 |
- #' the interaction level.+ #' (in units) to implement when printing the annotation table. |
|||
| 70 |
- #' @param second_var_with_level (`character` of length 2)\cr the second variable name with+ #' |
|||
| 71 |
- #' the interaction level.+ #' @return A `grob` of class `gTree`. |
|||
| 73 |
- #' @return Name of coefficient.+ #' @examples |
|||
| 74 |
- #'+ #' \donttest{
|
|||
| 75 |
- #' @export+ #' library(dplyr) |
|||
| 76 |
- h_interaction_coef_name <- function(interaction_vars,+ #' library(ggplot2) |
|||
| 77 |
- first_var_with_level,+ #' library(survival) |
|||
| 78 |
- second_var_with_level) {
+ #' library(grid) |
|||
| 79 | -45x | +
- checkmate::assert_character(interaction_vars, len = 2, any.missing = FALSE)+ #' library(nestcolor) |
||
| 80 | -45x | +
- checkmate::assert_character(first_var_with_level, len = 2, any.missing = FALSE)+ #' |
||
| 81 | -45x | +
- checkmate::assert_character(second_var_with_level, len = 2, any.missing = FALSE)+ #' df <- tern_ex_adtte %>% |
||
| 82 | -45x | +
- checkmate::assert_subset(c(first_var_with_level[1], second_var_with_level[1]), interaction_vars)+ #' filter(PARAMCD == "OS") %>% |
||
| 83 |
-
+ #' mutate(is_event = CNSR == 0) |
|||
| 84 | -45x | +
- first_name <- paste(first_var_with_level, collapse = "")+ #' variables <- list(tte = "AVAL", is_event = "is_event", arm = "ARMCD") |
||
| 85 | -45x | +
- second_name <- paste(second_var_with_level, collapse = "")+ #' |
||
| 86 | -45x | +
- if (first_var_with_level[1] == interaction_vars[1]) {
+ #' # 1. Example - basic option |
||
| 87 | -34x | +
- paste(first_name, second_name, sep = ":")+ #' |
||
| 88 | -11x | +
- } else if (second_var_with_level[1] == interaction_vars[1]) {
+ #' res <- g_km(df = df, variables = variables) |
||
| 89 | -11x | +
- paste(second_name, first_name, sep = ":")+ #' res <- g_km(df = df, variables = variables, yval = "Failure") |
||
| 90 |
- }+ #' res <- g_km( |
|||
| 91 |
- }+ #' df = df, |
|||
| 92 |
-
+ #' variables = variables, |
|||
| 93 |
- #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ #' control_surv = control_surv_timepoint(conf_level = 0.9), |
|||
| 94 |
- #' for the case when both the odds ratio and the interaction variable are categorical.+ #' col = c("grey25", "grey50", "grey75"),
|
|||
| 95 |
- #'+ #' annot_at_risk_title = FALSE |
|||
| 96 |
- #' @param odds_ratio_var (`string`)\cr the odds ratio variable.+ #' ) |
|||
| 97 |
- #' @param interaction_var (`string`)\cr the interaction variable.+ #' res <- g_km(df = df, variables = variables, ggtheme = theme_minimal()) |
|||
| 98 |
- #'+ #' res <- g_km(df = df, variables = variables, ggtheme = theme_minimal(), lty = 1:3) |
|||
| 99 |
- #' @return Odds ratio.+ #' res <- g_km(df = df, variables = variables, max = 2000) |
|||
| 100 |
- #'+ #' res <- g_km( |
|||
| 101 |
- #' @export+ #' df = df, |
|||
| 102 |
- h_or_cat_interaction <- function(odds_ratio_var,+ #' variables = variables, |
|||
| 103 |
- interaction_var,+ #' annot_stats = c("min", "median"),
|
|||
| 104 |
- fit_glm,+ #' annot_stats_vlines = TRUE |
|||
| 105 |
- conf_level = 0.95) {
+ #' ) |
|||
| 106 | -7x | +
- interaction_vars <- h_get_interaction_vars(fit_glm)+ #' |
||
| 107 | -7x | +
- checkmate::assert_string(odds_ratio_var)+ #' # 2. Example - Arrange several KM curve on a single graph device |
||
| 108 | -7x | +
- checkmate::assert_string(interaction_var)+ #' |
||
| 109 | -7x | +
- checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars)+ #' # 2.1 Use case: A general graph on the top, a zoom on the bottom. |
||
| 110 | -7x | +
- checkmate::assert_vector(interaction_vars, len = 2)+ #' grid.newpage() |
||
| 111 |
-
+ #' lyt <- grid.layout(nrow = 2, ncol = 1) %>% |
|||
| 112 | -7x | +
- xs_level <- fit_glm$xlevels+ #' viewport(layout = .) %>% |
||
| 113 | -7x | +
- xs_coef <- stats::coef(fit_glm)+ #' pushViewport() |
||
| 114 | -7x | +
- xs_vcov <- stats::vcov(fit_glm)+ #' |
||
| 115 | -7x | +
- y <- list()+ #' res <- g_km( |
||
| 116 | -7x | +
- for (var_level in xs_level[[odds_ratio_var]][-1]) {
+ #' df = df, variables = variables, newpage = FALSE, annot_surv_med = FALSE, |
||
| 117 | -12x | +
- x <- list()+ #' vp = viewport(layout.pos.row = 1, layout.pos.col = 1) |
||
| 118 | -12x | +
- for (ref_level in xs_level[[interaction_var]]) {
+ #' ) |
||
| 119 | -32x | +
- coef_names <- paste0(odds_ratio_var, var_level)+ #' res <- g_km( |
||
| 120 | -32x | +
- if (ref_level != xs_level[[interaction_var]][1]) {
+ #' df = df, variables = variables, max = 1000, newpage = FALSE, annot_surv_med = FALSE, |
||
| 121 | -20x | +
- interaction_coef_name <- h_interaction_coef_name(+ #' ggtheme = theme_dark(), |
||
| 122 | -20x | +
- interaction_vars,+ #' vp = viewport(layout.pos.row = 2, layout.pos.col = 1) |
||
| 123 | -20x | +
- c(odds_ratio_var, var_level),+ #' ) |
||
| 124 | -20x | +
- c(interaction_var, ref_level)+ #' |
||
| 125 |
- )+ #' # 2.1 Use case: No annotations on top, annotated graph on bottom |
|||
| 126 | -20x | +
- coef_names <- c(+ #' grid.newpage() |
||
| 127 | -20x | +
- coef_names,+ #' lyt <- grid.layout(nrow = 2, ncol = 1) %>% |
||
| 128 | -20x | +
- interaction_coef_name+ #' viewport(layout = .) %>% |
||
| 129 |
- )+ #' pushViewport() |
|||
| 130 |
- }+ #' |
|||
| 131 | -32x | +
- if (length(coef_names) > 1) {
+ #' res <- g_km( |
||
| 132 | -20x | +
- ones <- t(c(1, 1))+ #' df = df, variables = variables, newpage = FALSE, |
||
| 133 | -20x | +
- est <- as.numeric(ones %*% xs_coef[coef_names])+ #' annot_surv_med = FALSE, annot_at_risk = FALSE, |
||
| 134 | -20x | +
- se <- sqrt(as.numeric(ones %*% xs_vcov[coef_names, coef_names] %*% t(ones)))+ #' vp = viewport(layout.pos.row = 1, layout.pos.col = 1) |
||
| 135 |
- } else {
+ #' ) |
|||
| 136 | -12x | +
- est <- xs_coef[coef_names]+ #' res <- g_km( |
||
| 137 | -12x | +
- se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ #' df = df, variables = variables, max = 2000, newpage = FALSE, annot_surv_med = FALSE, |
||
| 138 |
- }+ #' annot_at_risk = TRUE, |
|||
| 139 | -32x | +
- or <- exp(est)+ #' ggtheme = theme_dark(), |
||
| 140 | -32x | +
- ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ #' vp = viewport(layout.pos.row = 2, layout.pos.col = 1) |
||
| 141 | -32x | +
- x[[ref_level]] <- list(or = or, ci = ci)+ #' ) |
||
| 142 |
- }+ #' |
|||
| 143 | -12x | +
- y[[var_level]] <- x+ #' # Add annotation from a pairwise coxph analysis |
||
| 144 |
- }+ #' g_km( |
|||
| 145 | -7x | +
- y+ #' df = df, variables = variables, |
||
| 146 |
- }+ #' annot_coxph = TRUE |
|||
| 147 |
-
+ #' ) |
|||
| 148 |
- #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ #' |
|||
| 149 |
- #' for the case when either the odds ratio or the interaction variable is continuous.+ #' # Change widths/sizes of surv_med and coxph annotation tables. |
|||
| 150 |
- #'+ #' g_km( |
|||
| 151 |
- #' @param at (`NULL` or `numeric`)\cr optional values for the interaction variable. Otherwise+ #' df = df, variables = c(variables, list(strat = "SEX")), |
|||
| 152 |
- #' the median is used.+ #' annot_coxph = TRUE, |
|||
| 153 |
- #'+ #' width_annots = list(surv_med = grid::unit(2, "in"), coxph = grid::unit(3, "in")) |
|||
| 154 |
- #' @return Odds ratio.+ #' ) |
|||
| 156 |
- #' @note We don't provide a function for the case when both variables are continuous because+ #' g_km( |
|||
| 157 |
- #' this does not arise in this table, as the treatment arm variable will always be involved+ #' df = df, variables = c(variables, list(strat = "SEX")), |
|||
| 158 |
- #' and categorical.+ #' font_size = 15, |
|||
| 159 |
- #'+ #' annot_coxph = TRUE, |
|||
| 160 |
- #' @export+ #' control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99), |
|||
| 161 |
- h_or_cont_interaction <- function(odds_ratio_var,+ #' position_coxph = c(0.5, 0.5) |
|||
| 162 |
- interaction_var,+ #' ) |
|||
| 163 |
- fit_glm,+ #' |
|||
| 164 |
- at = NULL,+ #' # Change position of the treatment group annotation table. |
|||
| 165 |
- conf_level = 0.95) {
+ #' g_km( |
|||
| 166 | -9x | +
- interaction_vars <- h_get_interaction_vars(fit_glm)+ #' df = df, variables = c(variables, list(strat = "SEX")), |
||
| 167 | -9x | +
- checkmate::assert_string(odds_ratio_var)+ #' font_size = 15, |
||
| 168 | -9x | +
- checkmate::assert_string(interaction_var)+ #' annot_coxph = TRUE, |
||
| 169 | -9x | +
- checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars)+ #' control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99), |
||
| 170 | -9x | +
- checkmate::assert_vector(interaction_vars, len = 2)+ #' position_surv_med = c(1, 0.7) |
||
| 171 | -9x | +
- checkmate::assert_numeric(at, min.len = 1, null.ok = TRUE, any.missing = FALSE)+ #' ) |
||
| 172 | -9x | +
- xs_level <- fit_glm$xlevels+ #' } |
||
| 173 | -9x | +
- xs_coef <- stats::coef(fit_glm)+ #' |
||
| 174 | -9x | +
- xs_vcov <- stats::vcov(fit_glm)+ #' @export |
||
| 175 | -9x | +
- xs_class <- attr(fit_glm$terms, "dataClasses")+ g_km <- function(df, |
||
| 176 | -9x | +
- model_data <- fit_glm$model+ variables, |
||
| 177 | -9x | +
- if (!is.null(at)) {
+ control_surv = control_surv_timepoint(), |
||
| 178 | -2x | +
- checkmate::assert_set_equal(xs_class[interaction_var], "numeric")+ col = NULL, |
||
| 179 |
- }+ lty = NULL, |
|||
| 180 | -9x | +
- y <- list()+ lwd = .5, |
||
| 181 | -9x | +
- if (xs_class[interaction_var] == "numeric") {
+ censor_show = TRUE, |
||
| 182 | -6x | +
- if (is.null(at)) {
+ pch = 3, |
||
| 183 | -4x | +
- at <- ceiling(stats::median(model_data[[interaction_var]]))+ size = 2, |
||
| 184 |
- }+ max_time = NULL, |
|||
| 185 |
-
+ xticks = NULL, |
|||
| 186 | -6x | +
- for (var_level in xs_level[[odds_ratio_var]][-1]) {
+ xlab = "Days", |
||
| 187 | -12x | +
- x <- list()+ yval = c("Survival", "Failure"),
|
||
| 188 | -12x | +
- for (increment in at) {
+ ylab = paste(yval, "Probability"), |
||
| 189 | -18x | +
- coef_names <- paste0(odds_ratio_var, var_level)+ ylim = NULL, |
||
| 190 | -18x | +
- if (increment != 0) {
+ title = NULL, |
||
| 191 | -18x | +
- interaction_coef_name <- h_interaction_coef_name(+ footnotes = NULL, |
||
| 192 | -18x | +
- interaction_vars,+ draw = TRUE, |
||
| 193 | -18x | +
- c(odds_ratio_var, var_level),+ newpage = TRUE, |
||
| 194 | -18x | +
- c(interaction_var, "")+ gp = NULL, |
||
| 195 |
- )+ vp = NULL, |
|||
| 196 | -18x | +
- coef_names <- c(+ name = NULL, |
||
| 197 | -18x | +
- coef_names,+ font_size = 12, |
||
| 198 | -18x | +
- interaction_coef_name+ ci_ribbon = FALSE, |
||
| 199 |
- )+ ggtheme = nestcolor::theme_nest(), |
|||
| 200 |
- }+ annot_at_risk = TRUE, |
|||
| 201 | -18x | +
- if (length(coef_names) > 1) {
+ annot_at_risk_title = TRUE, |
||
| 202 | -18x | +
- xvec <- t(c(1, increment))+ annot_surv_med = TRUE, |
||
| 203 | -18x | +
- est <- as.numeric(xvec %*% xs_coef[coef_names])+ annot_coxph = FALSE, |
||
| 204 | -18x | +
- se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec)))+ annot_stats = NULL, |
||
| 205 |
- } else {
+ annot_stats_vlines = FALSE, |
|||
| 206 | -! | +
- est <- xs_coef[coef_names]+ control_coxph_pw = control_coxph(), |
||
| 207 | -! | +
- se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ position_coxph = c(-0.03, -0.02), |
||
| 208 |
- }+ position_surv_med = c(0.95, 0.9), |
|||
| 209 | -18x | +
- or <- exp(est)+ width_annots = list(surv_med = grid::unit(0.3, "npc"), coxph = grid::unit(0.4, "npc"))) {
|
||
| 210 | -18x | +8x |
- ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ checkmate::assert_list(variables) |
|
| 211 | -18x | +8x |
- x[[as.character(increment)]] <- list(or = or, ci = ci)+ checkmate::assert_subset(c("tte", "arm", "is_event"), names(variables))
|
|
| 212 | -+ | 8x |
- }+ checkmate::assert_string(title, null.ok = TRUE) |
|
| 213 | -12x | +8x |
- y[[var_level]] <- x+ checkmate::assert_string(footnotes, null.ok = TRUE) |
|
| 214 | -+ | 8x |
- }+ checkmate::assert_character(col, null.ok = TRUE) |
|
| 215 | -+ | 8x |
- } else {
+ checkmate::assert_subset(annot_stats, c("median", "min"))
|
|
| 216 | -3x | +8x |
- checkmate::assert_set_equal(xs_class[odds_ratio_var], "numeric")+ checkmate::assert_logical(annot_stats_vlines) |
|
| 217 | -3x | +8x |
- checkmate::assert_set_equal(xs_class[interaction_var], "factor")+ checkmate::assert_true(all(sapply(width_annots, grid::is.unit))) |
|
| 218 | -3x | +
- for (var_level in xs_level[[interaction_var]]) {
+
|
||
| 219 | -9x | +8x |
- coef_names <- odds_ratio_var+ tte <- variables$tte |
|
| 220 | -9x | +8x |
- if (var_level != xs_level[[interaction_var]][1]) {
+ is_event <- variables$is_event |
|
| 221 | -6x | +8x |
- interaction_coef_name <- h_interaction_coef_name(+ arm <- variables$arm |
|
| 222 | -6x | +
- interaction_vars,+ |
||
| 223 | -6x | +8x |
- c(odds_ratio_var, ""),+ assert_valid_factor(df[[arm]]) |
|
| 224 | -6x | +8x |
- c(interaction_var, var_level)+ assert_df_with_variables(df, list(tte = tte, is_event = is_event, arm = arm)) |
|
| 225 | -+ | 8x |
- )+ checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE) |
|
| 226 | -6x | +8x |
- coef_names <- c(+ checkmate::assert_numeric(df[[tte]], min.len = 1, any.missing = FALSE) |
|
| 227 | -6x | +
- coef_names,+ |
||
| 228 | -6x | +8x |
- interaction_coef_name+ armval <- as.character(unique(df[[arm]])) |
|
| 229 | -+ | 8x |
- )+ if (annot_coxph && length(armval) < 2) {
|
|
| 230 | -+ | ! |
- }+ stop(paste( |
|
| 231 | -9x | +! |
- if (length(coef_names) > 1) {
+ "When `annot_coxph` = TRUE, `df` must contain at least 2 levels of `variables$arm`", |
|
| 232 | -6x | +! |
- xvec <- t(c(1, 1))+ "in order to calculate the hazard ratio." |
|
| 233 | -6x | +
- est <- as.numeric(xvec %*% xs_coef[coef_names])+ )) |
||
| 234 | -6x | +8x |
- se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec)))+ } else if (length(armval) > 1) {
|
|
| 235 | -+ | 8x |
- } else {
+ armval <- NULL |
|
| 236 | -3x | +
- est <- xs_coef[coef_names]+ } |
||
| 237 | -3x | +8x |
- se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ yval <- match.arg(yval) |
|
| 238 | -+ | 8x |
- }+ formula <- stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", arm))
|
|
| 239 | -9x | +8x |
- or <- exp(est)+ fit_km <- survival::survfit( |
|
| 240 | -9x | +8x |
- ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ formula = formula, |
|
| 241 | -9x | +8x |
- y[[var_level]] <- list(or = or, ci = ci)+ data = df, |
|
| 242 | -+ | 8x |
- }+ conf.int = control_surv$conf_level, |
|
| 243 | -+ | 8x |
- }+ conf.type = control_surv$conf_type |
|
| 244 | -9x | +
- y+ ) |
||
| 245 | -+ | 8x |
- }+ data_plot <- h_data_plot( |
|
| 246 | -+ | 8x |
-
+ fit_km = fit_km, |
|
| 247 | -+ | 8x |
- #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ armval = armval, |
|
| 248 | -+ | 8x |
- #' in case of an interaction. This is a wrapper for [h_or_cont_interaction()] and+ max_time = max_time |
|
| 249 |
- #' [h_or_cat_interaction()].+ ) |
|||
| 250 |
- #'+ |
|||
| 251 | -+ | 8x |
- #' @return Odds ratio.+ xticks <- h_xticks(data = data_plot, xticks = xticks, max_time = max_time) |
|
| 252 | -+ | 8x |
- #'+ gg <- h_ggkm( |
|
| 253 | -+ | 8x |
- #' @export+ data = data_plot, |
|
| 254 | -+ | 8x |
- h_or_interaction <- function(odds_ratio_var,+ censor_show = censor_show, |
|
| 255 | -+ | 8x |
- interaction_var,+ pch = pch, |
|
| 256 | -+ | 8x |
- fit_glm,+ size = size, |
|
| 257 | -+ | 8x |
- at = NULL,+ xticks = xticks, |
|
| 258 | -+ | 8x |
- conf_level = 0.95) {
+ xlab = xlab, |
|
| 259 | -13x | +8x |
- xs_class <- attr(fit_glm$terms, "dataClasses")+ yval = yval, |
|
| 260 | -13x | +8x |
- if (any(xs_class[c(odds_ratio_var, interaction_var)] == "numeric")) {
+ ylab = ylab, |
|
| 261 | -7x | +8x |
- h_or_cont_interaction(+ ylim = ylim, |
|
| 262 | -7x | +8x |
- odds_ratio_var,+ title = title, |
|
| 263 | -7x | +8x |
- interaction_var,+ footnotes = footnotes, |
|
| 264 | -7x | +8x |
- fit_glm,+ max_time = max_time, |
|
| 265 | -7x | +8x |
- at = at,+ lwd = lwd, |
|
| 266 | -7x | +8x |
- conf_level = conf_level+ lty = lty, |
|
| 267 | -+ | 8x |
- )+ col = col, |
|
| 268 | -6x | +8x |
- } else if (all(xs_class[c(odds_ratio_var, interaction_var)] == "factor")) {
+ ggtheme = ggtheme, |
|
| 269 | -6x | +8x |
- h_or_cat_interaction(+ ci_ribbon = ci_ribbon |
|
| 270 | -6x | +
- odds_ratio_var,+ ) |
||
| 271 | -6x | +
- interaction_var,+ |
||
| 272 | -6x | +8x |
- fit_glm,+ if (!is.null(annot_stats)) {
|
|
| 273 | -6x | +! |
- conf_level = conf_level+ if ("median" %in% annot_stats) {
|
|
| 274 | -+ | ! |
- )+ fit_km_all <- survival::survfit( |
|
| 275 | -+ | ! |
- } else {
+ formula = stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", 1)),
|
|
| 276 | ! |
- stop("wrong interaction variable class, the interaction variable is not a numeric nor a factor")
+ data = df, |
||
| 277 | -+ | ! |
- }+ conf.int = control_surv$conf_level, |
|
| 278 | -+ | ! |
- }+ conf.type = control_surv$conf_type |
|
| 279 |
-
+ ) |
|||
| 280 | -+ | ! |
- #' @describeIn h_logistic_regression Helper function to construct term labels from simple terms and the table+ gg <- gg + |
|
| 281 | -+ | ! |
- #' of numbers of patients.+ geom_text( |
|
| 282 | -+ | ! |
- #'+ size = 8 / ggplot2::.pt, col = 1, |
|
| 283 | -+ | ! |
- #' @param terms (`character`)\cr simple terms.+ x = stats::median(fit_km_all) + 0.065 * max(data_plot$time), |
|
| 284 | -+ | ! |
- #' @param table (`table`)\cr table containing numbers for terms.+ y = ifelse(yval == "Survival", 0.62, 0.38), |
|
| 285 | -+ | ! |
- #'+ label = paste("Median F/U:\n", round(stats::median(fit_km_all), 1), tolower(df$AVALU[1]))
|
|
| 286 |
- #' @return Term labels containing numbers of patients.+ ) |
|||
| 287 | -+ | ! |
- #'+ if (annot_stats_vlines) {
|
|
| 288 | -+ | ! |
- #' @export+ gg <- gg + |
|
| 289 | -+ | ! |
- h_simple_term_labels <- function(terms,+ geom_segment(aes(x = stats::median(fit_km_all), xend = stats::median(fit_km_all), y = -Inf, yend = Inf), |
|
| 290 | -+ | ! |
- table) {
+ linetype = 2, col = "darkgray" |
|
| 291 | -45x | +
- checkmate::assert_true(is.table(table))+ ) |
||
| 292 | -45x | +
- checkmate::assert_multi_class(terms, classes = c("factor", "character"))
+ } |
||
| 293 | -45x | +
- terms <- as.character(terms)+ } |
||
| 294 | -45x | +! |
- term_n <- table[terms]+ if ("min" %in% annot_stats) {
|
|
| 295 | -45x | +! |
- paste0(terms, ", n = ", term_n)+ min_fu <- min(df[[tte]]) |
|
| 296 | -+ | ! |
- }+ gg <- gg + |
|
| 297 | -+ | ! |
-
+ geom_text( |
|
| 298 | -+ | ! |
- #' @describeIn h_logistic_regression Helper function to construct term labels from interaction terms and the table+ size = 8 / ggplot2::.pt, col = 1, |
|
| 299 | -+ | ! |
- #' of numbers of patients.+ x = min_fu + max(data_plot$time) * ifelse(yval == "Survival", 0.05, 0.07), |
|
| 300 | -+ | ! |
- #'+ y = ifelse(yval == "Survival", 1.0, 0.05), |
|
| 301 | -+ | ! |
- #' @param terms1 (`character`)\cr terms for first dimension (rows).+ label = paste("Min. F/U:\n", round(min_fu, 1), tolower(df$AVALU[1]))
|
|
| 302 |
- #' @param terms2 (`character`)\cr terms for second dimension (rows).+ ) |
|||
| 303 | -+ | ! |
- #' @param any (`flag`)\cr whether any of `term1` and `term2` can be fulfilled to count the+ if (annot_stats_vlines) {
|
|
| 304 | -+ | ! |
- #' number of patients. In that case they can only be scalar (strings).+ gg <- gg + |
|
| 305 | -+ | ! |
- #'+ geom_segment(aes(x = min_fu, xend = min_fu, y = Inf, yend = -Inf), linetype = 2, col = "darkgray") |
|
| 306 |
- #' @return Term labels containing numbers of patients.+ } |
|||
| 307 |
- #'+ } |
|||
| 308 | -+ | ! |
- #' @export+ gg <- gg + ggplot2::guides(fill = ggplot2::guide_legend(override.aes = list(shape = NA, label = ""))) |
|
| 309 |
- h_interaction_term_labels <- function(terms1,+ } |
|||
| 310 |
- terms2,+ |
|||
| 311 | -+ | 8x |
- table,+ g_el <- h_decompose_gg(gg) |
|
| 312 |
- any = FALSE) {
+
|
|||
| 313 | 8x |
- checkmate::assert_true(is.table(table))+ if (annot_at_risk) {
|
||
| 314 | -8x | +
- checkmate::assert_flag(any)+ # This is the content of the table that will be below the graph. |
||
| 315 | -8x | +6x |
- checkmate::assert_multi_class(terms1, classes = c("factor", "character"))
+ annot_tbl <- summary(fit_km, time = xticks) |
|
| 316 | -8x | +6x |
- checkmate::assert_multi_class(terms2, classes = c("factor", "character"))
+ annot_tbl <- if (is.null(fit_km$strata)) {
|
|
| 317 | -8x | +! |
- terms1 <- as.character(terms1)+ data.frame( |
|
| 318 | -8x | +! |
- terms2 <- as.character(terms2)+ n.risk = annot_tbl$n.risk, |
|
| 319 | -8x | +! |
- if (any) {
+ time = annot_tbl$time, |
|
| 320 | -4x | +! |
- checkmate::assert_scalar(terms1)+ strata = as.factor(armval) |
|
| 321 | -4x | +
- checkmate::assert_scalar(terms2)+ ) |
||
| 322 | -4x | +
- paste0(+ } else {
|
||
| 323 | -4x | +6x |
- terms1, " or ", terms2, ", n = ",+ strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
|
|
| 324 | -+ | 6x |
- # Note that we double count in the initial sum the cell [terms1, terms2], therefore subtract.+ levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2] |
|
| 325 | -4x | +6x |
- sum(c(table[terms1, ], table[, terms2])) - table[terms1, terms2]+ data.frame( |
|
| 326 | -+ | 6x |
- )+ n.risk = annot_tbl$n.risk, |
|
| 327 | -+ | 6x |
- } else {
+ time = annot_tbl$time, |
|
| 328 | -4x | +6x |
- term_n <- table[cbind(terms1, terms2)]+ strata = annot_tbl$strata |
|
| 329 | -4x | +
- paste0(terms1, " * ", terms2, ", n = ", term_n)+ ) |
||
| 330 |
- }+ } |
|||
| 331 |
- }+ |
|||
| 332 | -+ | 6x |
-
+ grobs_patient <- h_grob_tbl_at_risk( |
|
| 333 | -+ | 6x |
- #' @describeIn h_logistic_regression Helper function to tabulate the main effect+ data = data_plot, |
|
| 334 | -+ | 6x |
- #' results of a (conditional) logistic regression model.+ annot_tbl = annot_tbl, |
|
| 335 | -+ | 6x |
- #'+ xlim = max(max_time, data_plot$time, xticks), |
|
| 336 | -+ | 6x |
- #' @return Tabulated main effect results from a logistic regression model.+ title = annot_at_risk_title |
|
| 337 |
- #'+ ) |
|||
| 338 |
- #' @examples+ } |
|||
| 339 |
- #' h_glm_simple_term_extract("AGE", mod1)
+
|
|||
| 340 | -+ | 8x |
- #' h_glm_simple_term_extract("ARMCD", mod1)
+ if (annot_at_risk || annot_surv_med || annot_coxph) {
|
|
| 341 | -+ | 6x |
- #'+ lyt <- h_km_layout( |
|
| 342 | -+ | 6x |
- #' @export+ data = data_plot, g_el = g_el, title = title, footnotes = footnotes, |
|
| 343 | -+ | 6x |
- h_glm_simple_term_extract <- function(x, fit_glm) {
+ annot_at_risk = annot_at_risk, annot_at_risk_title = annot_at_risk_title |
|
| 344 | -61x | +
- checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
+ ) |
||
| 345 | -61x | +6x |
- checkmate::assert_string(x)+ at_risk_ttl <- as.numeric(annot_at_risk_title) |
|
| 346 | -+ | 6x |
-
+ ttl_row <- as.numeric(!is.null(title)) |
|
| 347 | -61x | +6x |
- xs_class <- attr(fit_glm$terms, "dataClasses")+ foot_row <- as.numeric(!is.null(footnotes)) |
|
| 348 | -61x | +6x |
- xs_level <- fit_glm$xlevels+ km_grob <- grid::gTree( |
|
| 349 | -61x | +6x |
- xs_coef <- summary(fit_glm)$coefficients+ vp = grid::viewport(layout = lyt, height = .95, width = .95), |
|
| 350 | -61x | +6x |
- stats <- if (inherits(fit_glm, "glm")) {
+ children = grid::gList( |
|
| 351 | -49x | +
- c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
+ # Title. |
||
| 352 | -+ | 6x |
- } else {
+ if (ttl_row == 1) {
|
|
| 353 | -12x | +1x |
- c("estimate" = "coef", "std_error" = "se(coef)", "pvalue" = "Pr(>|z|)")
+ grid::gTree( |
|
| 354 | -+ | 1x |
- }+ vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 2), |
|
| 355 | -+ | 1x |
- # Make sure x is not an interaction term.+ children = grid::gList(grid::textGrob(label = title, x = grid::unit(0, "npc"), hjust = 0)) |
|
| 356 | -61x | +
- checkmate::assert_subset(x, names(xs_class))+ ) |
||
| 357 | -61x | +
- x_sel <- if (xs_class[x] == "numeric") x else paste0(x, xs_level[[x]][-1])+ }, |
||
| 358 | -61x | +
- x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE)+ |
||
| 359 | -61x | +
- colnames(x_stats) <- names(stats)+ # The Kaplan - Meier curve (top-right corner). |
||
| 360 | -61x | +6x |
- x_stats$estimate <- as.list(x_stats$estimate)+ grid::gTree( |
|
| 361 | -61x | +6x |
- x_stats$std_error <- as.list(x_stats$std_error)+ vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 2), |
|
| 362 | -61x | +6x |
- x_stats$pvalue <- as.list(x_stats$pvalue)+ children = grid::gList(g_el$panel) |
|
| 363 | -61x | +
- x_stats$df <- as.list(1)+ ), |
||
| 364 | -61x | +
- if (xs_class[x] == "numeric") {
+
|
||
| 365 | -46x | +
- x_stats$term <- x+ # Survfit summary table (top-right corner). |
||
| 366 | -46x | +6x |
- x_stats$term_label <- if (inherits(fit_glm, "glm")) {
+ if (annot_surv_med) {
|
|
| 367 | -34x | +5x |
- formatters::var_labels(fit_glm$data[x], fill = TRUE)+ grid::gTree( |
|
| 368 | -+ | 5x |
- } else {
+ vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 2), |
|
| 369 | -+ | 5x |
- # We just fill in here with the `term` itself as we don't have the data available.+ children = h_grob_median_surv( |
|
| 370 | -12x | +5x |
- x+ fit_km = fit_km, |
|
| 371 | -+ | 5x |
- }+ armval = armval, |
|
| 372 | -46x | +5x |
- x_stats$is_variable_summary <- FALSE+ x = position_surv_med[1], |
|
| 373 | -46x | +5x |
- x_stats$is_term_summary <- TRUE+ y = position_surv_med[2], |
|
| 374 | -+ | 5x |
- } else {
+ width = if (!is.null(width_annots[["surv_med"]])) width_annots[["surv_med"]] else grid::unit(0.3, "npc"), |
|
| 375 | -15x | +5x |
- checkmate::assert_class(fit_glm, "glm")+ ttheme = gridExtra::ttheme_default(base_size = font_size) |
|
| 376 |
- # The reason is that we don't have the original data set in the `clogit` object+ ) |
|||
| 377 |
- # and therefore cannot determine the `x_numbers` here.+ ) |
|||
| 378 | -15x | +
- x_numbers <- table(fit_glm$data[[x]])+ }, |
||
| 379 | -15x | +6x |
- x_stats$term <- xs_level[[x]][-1]+ if (annot_coxph) {
|
|
| 380 | -15x | +1x |
- x_stats$term_label <- h_simple_term_labels(x_stats$term, x_numbers)+ grid::gTree( |
|
| 381 | -15x | +1x |
- x_stats$is_variable_summary <- FALSE+ vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 2), |
|
| 382 | -15x | +1x |
- x_stats$is_term_summary <- TRUE+ children = h_grob_coxph( |
|
| 383 | -15x | +1x |
- main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald")+ df = df, |
|
| 384 | -15x | +1x |
- x_main <- data.frame(+ variables = variables, |
|
| 385 | -15x | +1x |
- pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE],+ control_coxph_pw = control_coxph_pw, |
|
| 386 | -15x | +1x |
- term = xs_level[[x]][1],+ x = position_coxph[1], |
|
| 387 | -15x | +1x |
- term_label = paste("Reference", h_simple_term_labels(xs_level[[x]][1], x_numbers)),
+ y = position_coxph[2], |
|
| 388 | -15x | +1x |
- df = main_effects[x, "Df", drop = TRUE],+ width = if (!is.null(width_annots[["coxph"]])) width_annots[["coxph"]] else grid::unit(0.4, "npc"), |
|
| 389 | -15x | +1x |
- stringsAsFactors = FALSE+ ttheme = gridExtra::ttheme_default( |
|
| 390 | -+ | 1x |
- )+ base_size = font_size, |
|
| 391 | -15x | +1x |
- x_main$pvalue <- as.list(x_main$pvalue)+ padding = grid::unit(c(1, .5), "lines"), |
|
| 392 | -15x | -
- x_main$df <- as.list(x_main$df)- |
- ||
| 393 | -15x | -
- x_main$estimate <- list(numeric(0))- |
- ||
| 394 | -15x | -
- x_main$std_error <- list(numeric(0))- |
- ||
| 395 | -15x | -
- if (length(xs_level[[x]][-1]) == 1) {
- |
- ||
| 396 | -6x | -
- x_main$pvalue <- list(numeric(0))- |
- ||
| 397 | -6x | -
- x_main$df <- list(numeric(0))- |
- ||
| 398 | -- |
- }- |
- ||
| 399 | -15x | -
- x_main$is_variable_summary <- TRUE- |
- ||
| 400 | -15x | -
- x_main$is_term_summary <- FALSE- |
- ||
| 401 | -15x | -
- x_stats <- rbind(x_main, x_stats)- |
- ||
| 402 | -- |
- }- |
- ||
| 403 | -61x | -
- x_stats$variable <- x- |
- ||
| 404 | -61x | -
- x_stats$variable_label <- if (inherits(fit_glm, "glm")) {
- |
- ||
| 405 | -49x | +1x |
- formatters::var_labels(fit_glm$data[x], fill = TRUE)+ core = list(bg_params = list(fill = c("grey95", "grey90"), alpha = .5))
|
|
| 406 | +393 |
- } else {
- |
- ||
| 407 | -12x | -
- x+ ) |
||
| 408 | +394 |
- }- |
- ||
| 409 | -61x | -
- x_stats$interaction <- ""- |
- ||
| 410 | -61x | -
- x_stats$interaction_label <- ""- |
- ||
| 411 | -61x | -
- x_stats$reference <- ""- |
- ||
| 412 | -61x | -
- x_stats$reference_label <- ""- |
- ||
| 413 | -61x | -
- rownames(x_stats) <- NULL- |
- ||
| 414 | -61x | -
- x_stats[c(- |
- ||
| 415 | -61x | -
- "variable",- |
- ||
| 416 | -61x | -
- "variable_label",- |
- ||
| 417 | -61x | -
- "term",- |
- ||
| 418 | -61x | -
- "term_label",- |
- ||
| 419 | -61x | -
- "interaction",- |
- ||
| 420 | -61x | -
- "interaction_label",- |
- ||
| 421 | -61x | -
- "reference",- |
- ||
| 422 | -61x | -
- "reference_label",- |
- ||
| 423 | -61x | -
- "estimate",- |
- ||
| 424 | -61x | -
- "std_error",- |
- ||
| 425 | -61x | -
- "df",- |
- ||
| 426 | -61x | -
- "pvalue",- |
- ||
| 427 | -61x | -
- "is_variable_summary",- |
- ||
| 428 | -61x | -
- "is_term_summary"+ ) |
||
| 429 | +395 |
- )]+ ) |
||
| 430 | +396 |
- }+ }, |
||
| 431 | +397 | |||
| 432 | -- |
- #' @describeIn h_logistic_regression Helper function to tabulate the interaction term- |
- ||
| 433 | -- |
- #' results of a logistic regression model.- |
- ||
| 434 | -- |
- #'- |
- ||
| 435 | -- |
- #' @return Tabulated interaction term results from a logistic regression model.- |
- ||
| 436 | -- |
- #'- |
- ||
| 437 | -- |
- #' @examples- |
- ||
| 438 | -- |
- #' h_glm_interaction_extract("ARMCD:AGE", mod2)
- |
- ||
| 439 | -- |
- #'- |
- ||
| 440 | -- |
- #' @export- |
- ||
| 441 | +398 |
- h_glm_interaction_extract <- function(x, fit_glm) {
+ # Add the y-axis annotation (top-left corner). |
||
| 442 | +399 | 6x |
- vars <- h_get_interaction_vars(fit_glm)+ grid::gTree( |
|
| 443 | +400 | 6x |
- xs_class <- attr(fit_glm$terms, "dataClasses")- |
- |
| 444 | -- |
-
+ vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 1), |
||
| 445 | +401 | 6x |
- checkmate::assert_string(x)- |
- |
| 446 | -- |
-
+ children = h_grob_y_annot(ylab = g_el$ylab, yaxis = g_el$yaxis) |
||
| 447 | +402 |
- # Only take two-way interaction- |
- ||
| 448 | -6x | -
- checkmate::assert_vector(vars, len = 2)+ ), |
||
| 449 | +403 | |||
| 450 | -- |
- # Only consider simple case: first variable in interaction is arm, a categorical variable- |
- ||
| 451 | -6x | -
- checkmate::assert_disjunct(xs_class[vars[1]], "numeric")- |
- ||
| 452 | +404 | - - | -||
| 453 | -6x | -
- xs_level <- fit_glm$xlevels- |
- ||
| 454 | -6x | -
- xs_coef <- summary(fit_glm)$coefficients- |
- ||
| 455 | -6x | -
- main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald")- |
- ||
| 456 | -6x | -
- stats <- c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
- |
- ||
| 457 | -6x | -
- v1_comp <- xs_level[[vars[1]]][-1]+ # Add the x-axis annotation (second row below the Kaplan Meier Curve). |
||
| 458 | +405 | 6x |
- if (xs_class[vars[2]] == "numeric") {
- |
- |
| 459 | -3x | -
- x_stats <- as.data.frame(- |
- ||
| 460 | -3x | -
- xs_coef[paste0(vars[1], v1_comp, ":", vars[2]), stats, drop = FALSE],- |
- ||
| 461 | -3x | -
- stringsAsFactors = FALSE- |
- ||
| 462 | -- |
- )- |
- ||
| 463 | -3x | -
- colnames(x_stats) <- names(stats)- |
- ||
| 464 | -3x | -
- x_stats$term <- v1_comp- |
- ||
| 465 | -3x | -
- x_numbers <- table(fit_glm$data[[vars[1]]])- |
- ||
| 466 | -3x | -
- x_stats$term_label <- h_simple_term_labels(v1_comp, x_numbers)- |
- ||
| 467 | -3x | -
- v1_ref <- xs_level[[vars[1]]][1]- |
- ||
| 468 | -3x | -
- term_main <- v1_ref- |
- ||
| 469 | -3x | -
- ref_label <- h_simple_term_labels(v1_ref, x_numbers)- |
- ||
| 470 | -3x | -
- } else if (xs_class[vars[2]] != "numeric") {
- |
- ||
| 471 | -3x | -
- v2_comp <- xs_level[[vars[2]]][-1]- |
- ||
| 472 | -3x | -
- v1_v2_grid <- expand.grid(v1 = v1_comp, v2 = v2_comp)+ grid::gTree( |
||
| 473 | -3x | +406 | +6x |
- x_sel <- paste(+ vp = grid::viewport(layout.pos.row = 2 + ttl_row, layout.pos.col = 2), |
| 474 | -3x | +407 | +6x |
- paste0(vars[1], v1_v2_grid$v1),+ children = grid::gList(rbind(g_el$xaxis, g_el$xlab)) |
| 475 | -3x | +|||
| 408 | +
- paste0(vars[2], v1_v2_grid$v2),+ ), |
|||
| 476 | -3x | +|||
| 409 | +
- sep = ":"+ |
|||
| 477 | +410 |
- )+ # Add the legend. |
||
| 478 | -3x | +411 | +6x |
- x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE)+ grid::gTree( |
| 479 | -3x | +412 | +6x |
- colnames(x_stats) <- names(stats)+ vp = grid::viewport(layout.pos.row = 3 + ttl_row, layout.pos.col = 2), |
| 480 | -3x | +413 | +6x |
- x_stats$term <- paste(v1_v2_grid$v1, "*", v1_v2_grid$v2)+ children = grid::gList(g_el$guide) |
| 481 | -3x | +|||
| 414 | +
- x_numbers <- table(fit_glm$data[[vars[1]]], fit_glm$data[[vars[2]]])+ ), |
|||
| 482 | -3x | +|||
| 415 | +
- x_stats$term_label <- h_interaction_term_labels(v1_v2_grid$v1, v1_v2_grid$v2, x_numbers)+ + |
+ |||
| 416 | ++ |
+ # Add the table with patient-at-risk numbers. |
||
| 483 | -3x | +417 | +6x |
- v1_ref <- xs_level[[vars[1]]][1]+ if (annot_at_risk && annot_at_risk_title) {
|
| 484 | -3x | +418 | +6x |
- v2_ref <- xs_level[[vars[2]]][1]+ grid::gTree( |
| 485 | -3x | +419 | +6x |
- term_main <- paste(vars[1], vars[2], sep = " * ")+ vp = grid::viewport(layout.pos.row = 4 + ttl_row, layout.pos.col = 1), |
| 486 | -3x | +420 | +6x |
- ref_label <- h_interaction_term_labels(v1_ref, v2_ref, x_numbers, any = TRUE)+ children = grobs_patient$title |
| 487 | +421 |
- }+ ) |
||
| 488 | -6x | +|||
| 422 | +
- x_stats$df <- as.list(1)+ }, |
|||
| 489 | +423 | 6x |
- x_stats$pvalue <- as.list(x_stats$pvalue)+ if (annot_at_risk) {
|
|
| 490 | +424 | 6x |
- x_stats$is_variable_summary <- FALSE+ grid::gTree( |
|
| 491 | +425 | 6x |
- x_stats$is_term_summary <- TRUE+ vp = grid::viewport(layout.pos.row = 4 + at_risk_ttl + ttl_row, layout.pos.col = 2), |
|
| 492 | +426 | 6x |
- x_main <- data.frame(+ children = grobs_patient$at_risk |
|
| 493 | -6x | +|||
| 427 | +
- pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE],+ )+ |
+ |||
| 428 | ++ |
+ }, |
||
| 494 | +429 | 6x |
- term = term_main,+ if (annot_at_risk) {
|
|
| 495 | +430 | 6x |
- term_label = paste("Reference", ref_label),
+ grid::gTree( |
|
| 496 | +431 | 6x |
- df = main_effects[x, "Df", drop = TRUE],+ vp = grid::viewport(layout.pos.row = 4 + at_risk_ttl + ttl_row, layout.pos.col = 1), |
|
| 497 | +432 | 6x |
- stringsAsFactors = FALSE+ children = grobs_patient$label |
|
| 498 | +433 |
- )+ ) |
||
| 499 | -6x | +|||
| 434 | +
- x_main$pvalue <- as.list(x_main$pvalue)+ }, |
|||
| 500 | +435 | 6x |
- x_main$df <- as.list(x_main$df)+ if (annot_at_risk) {
|
|
| 501 | -6x | +|||
| 436 | +
- x_main$estimate <- list(numeric(0))+ # Add the x-axis for the table. |
|||
| 502 | +437 | 6x |
- x_main$std_error <- list(numeric(0))+ grid::gTree( |
|
| 503 | +438 | 6x |
- x_main$is_variable_summary <- TRUE+ vp = grid::viewport(layout.pos.row = 5 + at_risk_ttl + ttl_row, layout.pos.col = 2), |
|
| 504 | +439 | 6x |
- x_main$is_term_summary <- FALSE+ children = grid::gList(rbind(g_el$xaxis, g_el$xlab)) |
|
| 505 | +440 | ++ |
+ )+ |
+ |
| 441 | ++ |
+ },+ |
+ ||
| 442 | ||||
| 443 | ++ |
+ # Footnotes.+ |
+ ||
| 506 | +444 | 6x |
- x_stats <- rbind(x_main, x_stats)+ if (foot_row == 1) {
|
|
| 507 | -6x | +445 | +1x |
- x_stats$variable <- x+ grid::gTree( |
| 508 | -6x | +446 | +1x |
- x_stats$variable_label <- paste(+ vp = grid::viewport( |
| 509 | -6x | +447 | +1x |
- "Interaction of",+ layout.pos.row = ifelse(annot_at_risk, 6 + at_risk_ttl + ttl_row, 4 + ttl_row), |
| 510 | -6x | +448 | +1x |
- formatters::var_labels(fit_glm$data[vars[1]], fill = TRUE),+ layout.pos.col = 2 |
| 511 | +449 |
- "*",+ ), |
||
| 512 | -6x | +450 | +1x |
- formatters::var_labels(fit_glm$data[vars[2]], fill = TRUE)+ children = grid::gList(grid::textGrob(label = footnotes, x = grid::unit(0, "npc"), hjust = 0)) |
| 513 | +451 |
- )+ ) |
||
| 514 | -6x | +|||
| 452 | +
- x_stats$interaction <- ""+ } |
|||
| 515 | -6x | +|||
| 453 | +
- x_stats$interaction_label <- ""+ ) |
|||
| 516 | -6x | +|||
| 454 | +
- x_stats$reference <- ""+ ) |
|||
| 517 | -6x | +|||
| 455 | +
- x_stats$reference_label <- ""+ |
|||
| 518 | +456 | 6x |
- rownames(x_stats) <- NULL+ result <- grid::gTree( |
|
| 519 | +457 | 6x |
- x_stats[c(+ vp = vp, |
|
| 520 | +458 | 6x |
- "variable",+ gp = gp, |
|
| 521 | +459 | 6x |
- "variable_label",+ name = name, |
|
| 522 | +460 | 6x |
- "term",+ children = grid::gList(km_grob) |
|
| 523 | -6x | +|||
| 461 | +
- "term_label",+ ) |
|||
| 524 | -6x | +|||
| 462 | +
- "interaction",+ } else {
|
|||
| 525 | -6x | +463 | +2x |
- "interaction_label",+ result <- grid::gTree( |
| 526 | -6x | +464 | +2x |
- "reference",+ vp = vp, |
| 527 | -6x | +465 | +2x |
- "reference_label",+ gp = gp, |
| 528 | -6x | +466 | +2x |
- "estimate",+ name = name, |
| 529 | -6x | +467 | +2x |
- "std_error",+ children = grid::gList(ggplot2::ggplotGrob(gg)) |
| 530 | -6x | +|||
| 468 | +
- "df",+ )+ |
+ |||
| 469 | ++ |
+ }+ |
+ ||
| 470 | ++ | + | ||
| 531 | -6x | +471 | +5x |
- "pvalue",+ if (newpage && draw) grid::grid.newpage() |
| 532 | -6x | +472 | +5x |
- "is_variable_summary",+ if (draw) grid::grid.draw(result) |
| 533 | -6x | +473 | +8x |
- "is_term_summary"+ invisible(result) |
| 534 | +474 |
- )]+ } |
||
| 535 | +475 |
- }+ |
||
| 536 | +476 |
-
+ #' Helper function: tidy survival fit |
||
| 537 | +477 |
- #' @describeIn h_logistic_regression Helper function to tabulate the interaction+ #' |
||
| 538 | +478 |
- #' results of a logistic regression model. This basically is a wrapper for+ #' @description `r lifecycle::badge("stable")`
|
||
| 539 | +479 |
- #' [h_or_interaction()] and [h_glm_simple_term_extract()] which puts the results+ #' |
||
| 540 | +480 |
- #' in the right data frame format.+ #' Convert the survival fit data into a data frame designed for plotting |
||
| 541 | +481 | ++ |
+ #' within `g_km`.+ |
+ |
| 482 |
#' |
|||
| 542 | +483 |
- #' @return A `data.frame` of tabulated interaction term results from a logistic regression model.+ #' This starts from the [broom::tidy()] result, and then: |
||
| 543 | +484 |
- #'+ #' * Post-processes the `strata` column into a factor. |
||
| 544 | +485 |
- #' @examples+ #' * Extends each stratum by an additional first row with time 0 and probability 1 so that |
||
| 545 | +486 |
- #' h_glm_inter_term_extract("AGE", "ARMCD", mod2)
+ #' downstream plot lines start at those coordinates. |
||
| 546 | +487 |
- #'+ #' * Adds a `censor` column. |
||
| 547 | +488 |
- #' @export+ #' * Filters the rows before `max_time`. |
||
| 548 | +489 |
- h_glm_inter_term_extract <- function(odds_ratio_var,+ #' |
||
| 549 | +490 |
- interaction_var,+ #' @inheritParams g_km |
||
| 550 | +491 |
- fit_glm,+ #' @param fit_km (`survfit`)\cr result of [survival::survfit()]. |
||
| 551 | +492 |
- ...) {
+ #' @param armval (`string`)\cr used as strata name when treatment arm variable only has one level. Default is `"All"`. |
||
| 552 | +493 |
- # First obtain the main effects.+ #' |
||
| 553 | -11x | +|||
| 494 | +
- main_stats <- h_glm_simple_term_extract(odds_ratio_var, fit_glm)+ #' @return A `tibble` with columns `time`, `n.risk`, `n.event`, `n.censor`, `estimate`, `std.error`, `conf.high`, |
|||
| 554 | -11x | +|||
| 495 | +
- main_stats$is_reference_summary <- FALSE+ #' `conf.low`, `strata`, and `censor`. |
|||
| 555 | -11x | +|||
| 496 | +
- main_stats$odds_ratio <- NA+ #' |
|||
| 556 | -11x | +|||
| 497 | +
- main_stats$lcl <- NA+ #' @examples |
|||
| 557 | -11x | +|||
| 498 | +
- main_stats$ucl <- NA+ #' \donttest{
|
|||
| 558 | +499 |
-
+ #' library(dplyr) |
||
| 559 | +500 |
- # Then we get the odds ratio estimates and put into df form.+ #' library(survival) |
||
| 560 | -11x | +|||
| 501 | +
- or_numbers <- h_or_interaction(odds_ratio_var, interaction_var, fit_glm, ...)+ #' |
|||
| 561 | -11x | +|||
| 502 | +
- is_num_or_var <- attr(fit_glm$terms, "dataClasses")[odds_ratio_var] == "numeric"+ #' # Test with multiple arms |
|||
| 562 | +503 |
-
+ #' tern_ex_adtte %>% |
||
| 563 | -11x | +|||
| 504 | +
- if (is_num_or_var) {
+ #' filter(PARAMCD == "OS") %>% |
|||
| 564 | +505 |
- # Numeric OR variable case.+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
||
| 565 | -3x | +|||
| 506 | +
- references <- names(or_numbers)+ #' h_data_plot() |
|||
| 566 | -3x | +|||
| 507 | +
- n_ref <- length(references)+ #' |
|||
| 567 | +508 |
-
+ #' # Test with single arm |
||
| 568 | -3x | +|||
| 509 | +
- extract_from_list <- function(l, name, pos = 1) {
+ #' tern_ex_adtte %>% |
|||
| 569 | -9x | +|||
| 510 | +
- unname(unlist(+ #' filter(PARAMCD == "OS", ARMCD == "ARM B") %>% |
|||
| 570 | -9x | +|||
| 511 | +
- lapply(or_numbers, function(x) {
+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
|||
| 571 | -27x | +|||
| 512 | +
- x[[name]][pos]+ #' h_data_plot(armval = "ARM B") |
|||
| 572 | +513 |
- })+ #' } |
||
| 573 | +514 |
- ))+ #' |
||
| 574 | +515 |
- }+ #' @export |
||
| 575 | -3x | +|||
| 516 | +
- or_stats <- data.frame(+ h_data_plot <- function(fit_km, |
|||
| 576 | -3x | +|||
| 517 | +
- variable = odds_ratio_var,+ armval = "All", |
|||
| 577 | -3x | +|||
| 518 | +
- variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),+ max_time = NULL) {
|
|||
| 578 | -3x | +519 | +15x |
- term = odds_ratio_var,+ y <- broom::tidy(fit_km) |
| 579 | -3x | +|||
| 520 | +
- term_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),+ |
|||
| 580 | -3x | +521 | +15x |
- interaction = interaction_var,+ if (!is.null(fit_km$strata)) {
|
| 581 | -3x | +522 | +15x |
- interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)),+ fit_km_var_level <- strsplit(sub("=", "equals", names(fit_km$strata)), "equals")
|
| 582 | -3x | +523 | +15x |
- reference = references,+ strata_levels <- vapply(fit_km_var_level, FUN = "[", FUN.VALUE = "a", i = 2) |
| 583 | -3x | +524 | +15x |
- reference_label = references,+ strata_var_level <- strsplit(sub("=", "equals", y$strata), "equals")
|
| 584 | -3x | +525 | +15x |
- estimate = NA,+ y$strata <- factor( |
| 585 | -3x | +526 | +15x |
- std_error = NA,+ vapply(strata_var_level, FUN = "[", FUN.VALUE = "a", i = 2), |
| 586 | -3x | +527 | +15x |
- odds_ratio = extract_from_list(or_numbers, "or"),+ levels = strata_levels |
| 587 | -3x | +|||
| 528 | +
- lcl = extract_from_list(or_numbers, "ci", pos = "lcl"),+ ) |
|||
| 588 | -3x | +|||
| 529 | +
- ucl = extract_from_list(or_numbers, "ci", pos = "ucl"),+ } else {
|
|||
| 589 | -3x | +|||
| 530 | +! |
- df = NA,+ y$strata <- armval |
||
| 590 | -3x | +|||
| 531 | +
- pvalue = NA,+ }+ |
+ |||
| 532 | ++ | + | ||
| 591 | -3x | +533 | +15x |
- is_variable_summary = FALSE,+ y_by_strata <- split(y, y$strata) |
| 592 | -3x | +534 | +15x |
- is_term_summary = FALSE,+ y_by_strata_extended <- lapply( |
| 593 | -3x | +535 | +15x |
- is_reference_summary = TRUE+ y_by_strata, |
| 594 | -+ | |||
| 536 | +15x |
- )+ FUN = function(tbl) {
|
||
| 595 | -+ | |||
| 537 | +44x |
- } else {
+ first_row <- tbl[1L, ] |
||
| 596 | -+ | |||
| 538 | +44x |
- # Categorical OR variable case.+ first_row$time <- 0 |
||
| 597 | -8x | +539 | +44x |
- references <- names(or_numbers[[1]])+ first_row$n.risk <- sum(first_row[, c("n.risk", "n.event", "n.censor")])
|
| 598 | -8x | +540 | +44x |
- n_ref <- length(references)+ first_row$n.event <- first_row$n.censor <- 0 |
| 599 | -+ | |||
| 541 | +44x |
-
+ first_row$estimate <- first_row$conf.high <- first_row$conf.low <- 1 |
||
| 600 | -8x | +542 | +44x |
- extract_from_list <- function(l, name, pos = 1) {
+ first_row$std.error <- 0 |
| 601 | -24x | +543 | +44x |
- unname(unlist(+ rbind( |
| 602 | -24x | +544 | +44x |
- lapply(or_numbers, function(x) {
+ first_row, |
| 603 | -42x | +545 | +44x |
- lapply(x, function(y) y[[name]][pos])+ tbl |
| 604 | +546 |
- })+ ) |
||
| 605 | +547 |
- ))+ } |
||
| 606 | +548 |
- }+ ) |
||
| 607 | -8x | +549 | +15x |
- or_stats <- data.frame(+ y <- do.call(rbind, y_by_strata_extended) |
| 608 | -8x | +|||
| 550 | +
- variable = odds_ratio_var,+ |
|||
| 609 | -8x | +551 | +15x |
- variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),+ y$censor <- ifelse(y$n.censor > 0, y$estimate, NA) |
| 610 | -8x | +552 | +15x |
- term = rep(names(or_numbers), each = n_ref),+ if (!is.null(max_time)) {
|
| 611 | -8x | +553 | +3x |
- term_label = h_simple_term_labels(rep(names(or_numbers), each = n_ref), table(fit_glm$data[[odds_ratio_var]])),+ y <- y[y$time <= max(max_time), ] |
| 612 | -8x | +|||
| 554 | +
- interaction = interaction_var,+ } |
|||
| 613 | -8x | +555 | +15x |
- interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)),+ y |
| 614 | -8x | +|||
| 556 | +
- reference = unlist(lapply(or_numbers, names)),+ } |
|||
| 615 | -8x | +|||
| 557 | +
- reference_label = unlist(lapply(or_numbers, names)),+ |
|||
| 616 | -8x | +|||
| 558 | +
- estimate = NA,+ #' Helper function: x tick positions |
|||
| 617 | -8x | +|||
| 559 | +
- std_error = NA,+ #' |
|||
| 618 | -8x | +|||
| 560 | +
- odds_ratio = extract_from_list(or_numbers, "or"),+ #' @description `r lifecycle::badge("stable")`
|
|||
| 619 | -8x | +|||
| 561 | +
- lcl = extract_from_list(or_numbers, "ci", pos = "lcl"),+ #' |
|||
| 620 | -8x | +|||
| 562 | +
- ucl = extract_from_list(or_numbers, "ci", pos = "ucl"),+ #' Calculate the positions of ticks on the x-axis. However, if `xticks` already |
|||
| 621 | -8x | +|||
| 563 | +
- df = NA,+ #' exists it is kept as is. It is based on the same function `ggplot2` relies on, |
|||
| 622 | -8x | +|||
| 564 | +
- pvalue = NA,+ #' and is required in the graphic and the patient-at-risk annotation table. |
|||
| 623 | -8x | +|||
| 565 | +
- is_variable_summary = FALSE,+ #' |
|||
| 624 | -8x | +|||
| 566 | +
- is_term_summary = FALSE,+ #' @inheritParams g_km |
|||
| 625 | -8x | +|||
| 567 | +
- is_reference_summary = TRUE+ #' @inheritParams h_ggkm |
|||
| 626 | +568 |
- )+ #' |
||
| 627 | +569 |
- }+ #' @return A vector of positions to use for x-axis ticks on a `ggplot` object. |
||
| 628 | +570 |
-
+ #' |
||
| 629 | -11x | +|||
| 571 | +
- df <- rbind(+ #' @examples |
|||
| 630 | -11x | +|||
| 572 | ++ |
+ #' \donttest{
+ |
+ ||
| 573 | ++ |
+ #' library(dplyr)+ |
+ ||
| 574 | ++ |
+ #' library(survival)+ |
+ ||
| 575 | +
- main_stats[, names(or_stats)],+ #' |
|||
| 631 | -11x | +|||
| 576 | +
- or_stats+ #' data <- tern_ex_adtte %>% |
|||
| 632 | +577 |
- )+ #' filter(PARAMCD == "OS") %>% |
||
| 633 | -11x | +|||
| 578 | +
- df[order(-df$is_variable_summary, df$term, -df$is_term_summary, df$reference), ]+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
|||
| 634 | +579 |
- }+ #' h_data_plot() |
||
| 635 | +580 |
-
+ #' |
||
| 636 | +581 |
- #' @describeIn h_logistic_regression Helper function to tabulate the results including+ #' h_xticks(data) |
||
| 637 | +582 |
- #' odds ratios and confidence intervals of simple terms.+ #' h_xticks(data, xticks = seq(0, 3000, 500)) |
||
| 638 | +583 |
- #'+ #' h_xticks(data, xticks = 500) |
||
| 639 | +584 |
- #' @return Tabulated statistics for the given variable(s) from the logistic regression model.+ #' h_xticks(data, xticks = 500, max_time = 6000) |
||
| 640 | +585 |
- #'+ #' h_xticks(data, xticks = c(0, 500), max_time = 300) |
||
| 641 | +586 |
- #' @examples+ #' h_xticks(data, xticks = 500, max_time = 300) |
||
| 642 | +587 |
- #' h_logistic_simple_terms("AGE", mod1)
+ #' } |
||
| 643 | +588 |
#' |
||
| 644 | +589 |
#' @export |
||
| 645 | +590 |
- h_logistic_simple_terms <- function(x, fit_glm, conf_level = 0.95) {
+ h_xticks <- function(data, xticks = NULL, max_time = NULL) {
|
||
| 646 | -40x | +591 | +15x |
- checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
+ if (is.null(xticks)) {
|
| 647 | -40x | +592 | +9x |
- if (inherits(fit_glm, "glm")) {
+ if (is.null(max_time)) {
|
| 648 | -29x | +593 | +7x |
- checkmate::assert_set_equal(fit_glm$family$family, "binomial")+ labeling::extended(range(data$time)[1], range(data$time)[2], m = 5) |
| 649 | +594 |
- }+ } else {
|
||
| 650 | -40x | +595 | +2x |
- terms_name <- attr(stats::terms(fit_glm), "term.labels")+ labeling::extended(range(data$time)[1], max(range(data$time)[2], max_time), m = 5) |
| 651 | -40x | +|||
| 596 | +
- xs_class <- attr(fit_glm$terms, "dataClasses")+ } |
|||
| 652 | -40x | +597 | +6x |
- interaction <- terms_name[which(!terms_name %in% names(xs_class))]+ } else if (checkmate::test_number(xticks)) {
|
| 653 | -40x | +598 | +3x |
- checkmate::assert_subset(x, terms_name)+ if (is.null(max_time)) {
|
| 654 | -40x | +599 | +2x |
- if (length(interaction) != 0) {
+ seq(0, max(data$time), xticks) |
| 655 | +600 |
- # Make sure any item in x is not part of interaction term+ } else {
|
||
| 656 | +601 | 1x |
- checkmate::assert_disjunct(x, unlist(strsplit(interaction, ":")))+ seq(0, max(data$time, max_time), xticks) |
|
| 657 | +602 |
- }+ } |
||
| 658 | -40x | +603 | +3x |
- x_stats <- lapply(x, h_glm_simple_term_extract, fit_glm)+ } else if (is.numeric(xticks)) {
|
| 659 | -40x | +604 | +2x |
- x_stats <- do.call(rbind, x_stats)+ xticks |
| 660 | -40x | +|||
| 605 | +
- q_norm <- stats::qnorm((1 + conf_level) / 2)+ } else {
|
|||
| 661 | -40x | +606 | +1x |
- x_stats$odds_ratio <- lapply(x_stats$estimate, exp)+ stop( |
| 662 | -40x | +607 | +1x |
- x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error)+ paste( |
| 663 | -40x | +608 | +1x |
- x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error)+ "xticks should be either `NULL`", |
| 664 | -40x | +609 | +1x |
- x_stats$ci <- Map(function(lcl, ucl) c(lcl, ucl), lcl = x_stats$lcl, ucl = x_stats$ucl)+ "or a single number (interval between x ticks)", |
| 665 | -40x | +610 | +1x |
- x_stats+ "or a numeric vector (position of ticks on the x axis)" |
| 666 | +611 |
- }+ ) |
||
| 667 | +612 |
-
+ ) |
||
| 668 | +613 |
- #' @describeIn h_logistic_regression Helper function to tabulate the results including+ } |
||
| 669 | +614 |
- #' odds ratios and confidence intervals of interaction terms.+ } |
||
| 670 | +615 |
- #'+ |
||
| 671 | +616 |
- #' @return Tabulated statistics for the given variable(s) from the logistic regression model.+ #' Helper function: KM plot |
||
| 672 | +617 |
#' |
||
| 673 | +618 |
- #' @examples+ #' @description `r lifecycle::badge("stable")`
|
||
| 674 | +619 |
- #' h_logistic_inter_terms(c("RACE", "AGE", "ARMCD", "AGE:ARMCD"), mod2)
+ #' |
||
| 675 | +620 |
- #'+ #' Draw the Kaplan-Meier plot using `ggplot2`. |
||
| 676 | +621 |
- #' @export+ #' |
||
| 677 | +622 |
- h_logistic_inter_terms <- function(x,+ #' @inheritParams g_km |
||
| 678 | +623 |
- fit_glm,+ #' @param data (`data.frame`)\cr survival data as pre-processed by `h_data_plot`. |
||
| 679 | +624 |
- conf_level = 0.95,+ #' |
||
| 680 | +625 |
- at = NULL) {
+ #' @return A `ggplot` object. |
||
| 681 | +626 |
- # Find out the interaction variables and interaction term.- |
- ||
| 682 | -4x | -
- inter_vars <- h_get_interaction_vars(fit_glm)- |
- ||
| 683 | -4x | -
- checkmate::assert_vector(inter_vars, len = 2)+ #' |
||
| 684 | +627 |
-
+ #' @examples |
||
| 685 | +628 | - - | -||
| 686 | -4x | -
- inter_term_index <- intersect(grep(inter_vars[1], x), grep(inter_vars[2], x))- |
- ||
| 687 | -4x | -
- inter_term <- x[inter_term_index]+ #' \donttest{
|
||
| 688 | +629 |
-
+ #' library(dplyr) |
||
| 689 | +630 |
- # For the non-interaction vars we need the standard stuff.- |
- ||
| 690 | -4x | -
- normal_terms <- setdiff(x, union(inter_vars, inter_term))+ #' library(survival) |
||
| 691 | +631 | - - | -||
| 692 | -4x | -
- x_stats <- lapply(normal_terms, h_glm_simple_term_extract, fit_glm)- |
- ||
| 693 | -4x | -
- x_stats <- do.call(rbind, x_stats)- |
- ||
| 694 | -4x | -
- q_norm <- stats::qnorm((1 + conf_level) / 2)- |
- ||
| 695 | -4x | -
- x_stats$odds_ratio <- lapply(x_stats$estimate, exp)- |
- ||
| 696 | -4x | -
- x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error)- |
- ||
| 697 | -4x | -
- x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error)- |
- ||
| 698 | -4x | -
- normal_stats <- x_stats- |
- ||
| 699 | -4x | -
- normal_stats$is_reference_summary <- FALSE+ #' |
||
| 700 | +632 |
-
+ #' fit_km <- tern_ex_adtte %>% |
||
| 701 | +633 |
- # Now the interaction term itself.- |
- ||
| 702 | -4x | -
- inter_term_stats <- h_glm_interaction_extract(inter_term, fit_glm)- |
- ||
| 703 | -4x | -
- inter_term_stats$odds_ratio <- NA+ #' filter(PARAMCD == "OS") %>% |
||
| 704 | -4x | +|||
| 634 | +
- inter_term_stats$lcl <- NA+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
|||
| 705 | -4x | +|||
| 635 | +
- inter_term_stats$ucl <- NA+ #' data_plot <- h_data_plot(fit_km = fit_km) |
|||
| 706 | -4x | +|||
| 636 | +
- inter_term_stats$is_reference_summary <- FALSE+ #' xticks <- h_xticks(data = data_plot) |
|||
| 707 | +637 |
-
+ #' gg <- h_ggkm( |
||
| 708 | -4x | +|||
| 638 | +
- is_intervar1_numeric <- attr(fit_glm$terms, "dataClasses")[inter_vars[1]] == "numeric"+ #' data = data_plot, |
|||
| 709 | +639 |
-
+ #' censor_show = TRUE, |
||
| 710 | +640 |
- # Interaction stuff.+ #' xticks = xticks, |
||
| 711 | -4x | +|||
| 641 | +
- inter_stats_one <- h_glm_inter_term_extract(+ #' xlab = "Days", |
|||
| 712 | -4x | +|||
| 642 | +
- inter_vars[1],+ #' yval = "Survival", |
|||
| 713 | -4x | +|||
| 643 | +
- inter_vars[2],+ #' ylab = "Survival Probability", |
|||
| 714 | -4x | +|||
| 644 | +
- fit_glm,+ #' title = "Survival" |
|||
| 715 | -4x | +|||
| 645 | +
- conf_level = conf_level,+ #' ) |
|||
| 716 | -4x | +|||
| 646 | +
- at = `if`(is_intervar1_numeric, NULL, at)+ #' gg |
|||
| 717 | +647 |
- )+ #' } |
||
| 718 | -4x | +|||
| 648 | +
- inter_stats_two <- h_glm_inter_term_extract(+ #' |
|||
| 719 | -4x | +|||
| 649 | +
- inter_vars[2],+ #' @export |
|||
| 720 | -4x | +|||
| 650 | +
- inter_vars[1],+ h_ggkm <- function(data, |
|||
| 721 | -4x | +|||
| 651 | +
- fit_glm,+ xticks = NULL, |
|||
| 722 | -4x | +|||
| 652 | +
- conf_level = conf_level,+ yval = "Survival", |
|||
| 723 | -4x | +|||
| 653 | +
- at = `if`(is_intervar1_numeric, at, NULL)+ censor_show, |
|||
| 724 | +654 |
- )+ xlab, |
||
| 725 | +655 |
-
+ ylab, |
||
| 726 | +656 |
- # Now just combine everything in one data frame.+ ylim = NULL, |
||
| 727 | -4x | +|||
| 657 | +
- col_names <- c(+ title, |
|||
| 728 | -4x | +|||
| 658 | +
- "variable",+ footnotes = NULL, |
|||
| 729 | -4x | +|||
| 659 | +
- "variable_label",+ max_time = NULL, |
|||
| 730 | -4x | +|||
| 660 | +
- "term",+ lwd = 1, |
|||
| 731 | -4x | +|||
| 661 | +
- "term_label",+ lty = NULL, |
|||
| 732 | -4x | +|||
| 662 | +
- "interaction",+ pch = 3, |
|||
| 733 | -4x | +|||
| 663 | +
- "interaction_label",+ size = 2, |
|||
| 734 | -4x | +|||
| 664 | +
- "reference",+ col = NULL, |
|||
| 735 | -4x | +|||
| 665 | +
- "reference_label",+ ci_ribbon = FALSE, |
|||
| 736 | -4x | +|||
| 666 | +
- "estimate",+ ggtheme = nestcolor::theme_nest()) {
|
|||
| 737 | -4x | +667 | +8x |
- "std_error",+ checkmate::assert_numeric(lty, null.ok = TRUE) |
| 738 | -4x | +668 | +8x |
- "df",+ checkmate::assert_character(col, null.ok = TRUE) |
| 739 | -4x | +|||
| 669 | +
- "pvalue",+ |
|||
| 740 | -4x | +670 | +8x |
- "odds_ratio",+ if (is.null(ylim)) {
|
| 741 | -4x | +671 | +8x |
- "lcl",+ data_lims <- data |
| 742 | -4x | +672 | +1x |
- "ucl",+ if (yval == "Failure") data_lims[["estimate"]] <- 1 - data_lims[["estimate"]] |
| 743 | -4x | +673 | +8x |
- "is_variable_summary",+ if (!is.null(max_time)) {
|
| 744 | -4x | +674 | +1x |
- "is_term_summary",+ y_lwr <- min(data_lims[data_lims$time < max_time, ][["estimate"]]) |
| 745 | -4x | +675 | +1x |
- "is_reference_summary"+ y_upr <- max(data_lims[data_lims$time < max_time, ][["estimate"]]) |
| 746 | +676 |
- )- |
- ||
| 747 | -4x | -
- df <- rbind(- |
- ||
| 748 | -4x | -
- inter_stats_one[, col_names],+ } else {
|
||
| 749 | -4x | +677 | +7x |
- inter_stats_two[, col_names],+ y_lwr <- min(data_lims[["estimate"]]) |
| 750 | -4x | +678 | +7x |
- inter_term_stats[, col_names]+ y_upr <- max(data_lims[["estimate"]]) |
| 751 | +679 |
- )- |
- ||
| 752 | -4x | -
- if (length(normal_terms) > 0) {
- |
- ||
| 753 | -4x | -
- df <- rbind(- |
- ||
| 754 | -4x | -
- normal_stats[, col_names],+ } |
||
| 755 | -4x | -
- df- |
- ||
| 756 | -+ | 680 | +8x |
- )+ ylim <- c(y_lwr, y_upr) |
| 757 | +681 |
} |
||
| 758 | -4x | -
- df$ci <- combine_vectors(df$lcl, df$ucl)- |
- ||
| 759 | -4x | -
- df- |
- ||
| 760 | -- |
- }- |
-
| 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 | -+ | 682 | +8x |
- #'+ checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE) |
| 5 | +683 |
- #' Helper Function to create a new `SMQ` variable in `ADAE` that consists of all adverse events belonging to+ |
||
| 6 | +684 |
- #' selected Standardized/Customized queries. The new dataset will only contain records of the adverse events+ # change estimates of survival to estimates of failure (1 - survival) |
||
| 7 | -+ | |||
| 685 | +8x |
- #' belonging to any of the selected baskets. Remember that `na_level` must match the needed pre-processing+ if (yval == "Failure") {
|
||
| 8 | -+ | |||
| 686 | +1x |
- #' done with [df_explicit_na()] to have the desired output.+ data$estimate <- 1 - data$estimate |
||
| 9 | -+ | |||
| 687 | +1x |
- #'+ data[c("conf.high", "conf.low")] <- list(1 - data$conf.low, 1 - data$conf.high)
|
||
| 10 | -+ | |||
| 688 | +1x |
- #' @inheritParams argument_convention+ data$censor <- 1 - data$censor |
||
| 11 | +689 |
- #' @param baskets (`character`)\cr variable names of the selected Standardized/Customized queries.+ } |
||
| 12 | +690 |
- #' @param smq_varlabel (`string`)\cr a label for the new variable created.+ |
||
| 13 | -+ | |||
| 691 | +8x |
- #' @param keys (`character`)\cr names of the key variables to be returned along with the new variable created.+ gg <- {
|
||
| 14 | -+ | |||
| 692 | +8x |
- #' @param aag_summary (`data.frame`)\cr containing the `SMQ` baskets and the levels of interest for the final `SMQ`+ ggplot2::ggplot( |
||
| 15 | -+ | |||
| 693 | +8x |
- #' variable. This is useful when there are some levels of interest that are not observed in the `df` dataset.+ data = data, |
||
| 16 | -+ | |||
| 694 | +8x |
- #' The two columns of this dataset should be named `basket` and `basket_name`.+ mapping = ggplot2::aes( |
||
| 17 | -+ | |||
| 695 | +8x |
- #'+ x = .data[["time"]], |
||
| 18 | -+ | |||
| 696 | +8x |
- #' @return `data.frame` with variables in `keys` taken from `df` and new variable `SMQ` containing+ y = .data[["estimate"]], |
||
| 19 | -+ | |||
| 697 | +8x |
- #' records belonging to the baskets selected via the `baskets` argument.+ ymin = .data[["conf.low"]], |
||
| 20 | -+ | |||
| 698 | +8x |
- #'+ ymax = .data[["conf.high"]], |
||
| 21 | -+ | |||
| 699 | +8x |
- #' @examples+ color = .data[["strata"]], |
||
| 22 | -+ | |||
| 700 | +8x |
- #' adae <- tern_ex_adae[1:20, ] %>% df_explicit_na()+ fill = .data[["strata"]] |
||
| 23 | +701 |
- #' h_stack_by_baskets(df = adae)+ ) |
||
| 24 | +702 |
- #'+ ) + |
||
| 25 | -+ | |||
| 703 | +8x |
- #' aag <- data.frame(+ ggplot2::geom_hline(yintercept = 0) |
||
| 26 | +704 |
- #' NAMVAR = c("CQ01NAM", "CQ02NAM", "SMQ01NAM", "SMQ02NAM"),
+ } |
||
| 27 | +705 |
- #' REFNAME = c(+ |
||
| 28 | -+ | |||
| 706 | +8x |
- #' "D.2.1.5.3/A.1.1.1.1 AESI", "X.9.9.9.9/Y.8.8.8.8 AESI",+ if (ci_ribbon) {
|
||
| 29 | -+ | |||
| 707 | +1x |
- #' "C.1.1.1.3/B.2.2.3.1 AESI", "C.1.1.1.3/B.3.3.3.3 AESI"+ gg <- gg + ggplot2::geom_ribbon(alpha = .3, lty = 0) |
||
| 30 | +708 |
- #' ),+ } |
||
| 31 | +709 |
- #' SCOPE = c("", "", "BROAD", "BROAD"),
+
|
||
| 32 | -+ | |||
| 710 | +8x |
- #' stringsAsFactors = FALSE+ gg <- if (is.null(lty)) {
|
||
| 33 | -+ | |||
| 711 | +7x |
- #' )+ gg + |
||
| 34 | -+ | |||
| 712 | +7x |
- #'+ ggplot2::geom_step(linewidth = lwd) |
||
| 35 | -+ | |||
| 713 | +8x |
- #' basket_name <- character(nrow(aag))+ } else if (checkmate::test_number(lty)) {
|
||
| 36 | -+ | |||
| 714 | +1x |
- #' cq_pos <- grep("^(CQ).+NAM$", aag$NAMVAR)
+ gg + |
||
| 37 | -+ | |||
| 715 | +1x |
- #' smq_pos <- grep("^(SMQ).+NAM$", aag$NAMVAR)
+ ggplot2::geom_step(linewidth = lwd, lty = lty) |
||
| 38 | -+ | |||
| 716 | +8x |
- #' basket_name[cq_pos] <- aag$REFNAME[cq_pos]+ } else if (is.numeric(lty)) {
|
||
| 39 | -+ | |||
| 717 | +! |
- #' basket_name[smq_pos] <- paste0(+ gg + |
||
| 40 | -+ | |||
| 718 | +! |
- #' aag$REFNAME[smq_pos], "(", aag$SCOPE[smq_pos], ")"
+ ggplot2::geom_step(mapping = ggplot2::aes(linetype = .data[["strata"]]), linewidth = lwd) + |
||
| 41 | -+ | |||
| 719 | +! |
- #' )+ ggplot2::scale_linetype_manual(values = lty) |
||
| 42 | +720 |
- #'+ } |
||
| 43 | +721 |
- #' aag_summary <- data.frame(+ |
||
| 44 | -+ | |||
| 722 | +8x |
- #' basket = aag$NAMVAR,+ gg <- gg + |
||
| 45 | -+ | |||
| 723 | +8x |
- #' basket_name = basket_name,+ ggplot2::coord_cartesian(ylim = ylim) + |
||
| 46 | -+ | |||
| 724 | +8x |
- #' stringsAsFactors = TRUE+ ggplot2::labs(x = xlab, y = ylab, title = title, caption = footnotes) |
||
| 47 | +725 |
- #' )+ |
||
| 48 | -+ | |||
| 726 | +8x |
- #'+ if (!is.null(col)) {
|
||
| 49 | -+ | |||
| 727 | +! |
- #' result <- h_stack_by_baskets(df = adae, aag_summary = aag_summary)+ gg <- gg + |
||
| 50 | -+ | |||
| 728 | +! |
- #' all(levels(aag_summary$basket_name) %in% levels(result$SMQ))+ ggplot2::scale_color_manual(values = col) + |
||
| 51 | -+ | |||
| 729 | +! |
- #'+ ggplot2::scale_fill_manual(values = col) |
||
| 52 | +730 |
- #' h_stack_by_baskets(+ } |
||
| 53 | -+ | |||
| 731 | +8x |
- #' df = adae,+ if (censor_show) {
|
||
| 54 | -+ | |||
| 732 | +8x |
- #' aag_summary = NULL,+ dt <- data[data$n.censor != 0, ] |
||
| 55 | -+ | |||
| 733 | +8x |
- #' keys = c("STUDYID", "USUBJID", "AEDECOD", "ARM"),
+ dt$censor_lbl <- factor("Censored")
|
||
| 56 | +734 |
- #' baskets = "SMQ01NAM"+ |
||
| 57 | -+ | |||
| 735 | +8x |
- #' )+ gg <- gg + ggplot2::geom_point( |
||
| 58 | -+ | |||
| 736 | +8x |
- #'+ data = dt, |
||
| 59 | -+ | |||
| 737 | +8x |
- #' @export+ ggplot2::aes( |
||
| 60 | -+ | |||
| 738 | +8x |
- h_stack_by_baskets <- function(df,+ x = .data[["time"]], |
||
| 61 | -+ | |||
| 739 | +8x |
- baskets = grep("^(SMQ|CQ).+NAM$", names(df), value = TRUE),
+ y = .data[["censor"]], |
||
| 62 | -+ | |||
| 740 | +8x |
- smq_varlabel = "Standardized MedDRA Query",+ shape = .data[["censor_lbl"]] |
||
| 63 | +741 |
- keys = c("STUDYID", "USUBJID", "ASTDTM", "AEDECOD", "AESEQ"),
+ ), |
||
| 64 | -+ | |||
| 742 | +8x |
- aag_summary = NULL,+ size = size, |
||
| 65 | -+ | |||
| 743 | +8x |
- na_level = "<Missing>") {
+ show.legend = TRUE, |
||
| 66 | -5x | +744 | +8x |
- smq_nam <- baskets[startsWith(baskets, "SMQ")]+ inherit.aes = TRUE |
| 67 | +745 |
- # SC corresponding to NAM+ ) + |
||
| 68 | -5x | +746 | +8x |
- smq_sc <- gsub(pattern = "NAM", replacement = "SC", x = smq_nam, fixed = TRUE)+ ggplot2::scale_shape_manual(name = NULL, values = pch) + |
| 69 | -5x | +747 | +8x |
- smq <- stats::setNames(smq_sc, smq_nam)+ ggplot2::guides( |
| 70 | -+ | |||
| 748 | +8x |
-
+ shape = ggplot2::guide_legend(override.aes = list(linetype = NA)), |
||
| 71 | -5x | +749 | +8x |
- checkmate::assert_character(baskets)+ fill = ggplot2::guide_legend(override.aes = list(shape = NA)) |
| 72 | -5x | +|||
| 750 | +
- checkmate::assert_string(smq_varlabel)+ ) |
|||
| 73 | -5x | +|||
| 751 | +
- checkmate::assert_data_frame(df)+ } |
|||
| 74 | -5x | +|||
| 752 | +
- checkmate::assert_true(all(startsWith(baskets, "SMQ") | startsWith(baskets, "CQ")))+ |
|||
| 75 | -4x | +753 | +8x |
- checkmate::assert_true(all(endsWith(baskets, "NAM")))+ if (!is.null(max_time) && !is.null(xticks)) {
|
| 76 | -3x | +754 | +1x |
- checkmate::assert_subset(baskets, names(df))+ gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, xticks), max(c(xticks, max_time)))) |
| 77 | -3x | +755 | +7x |
- checkmate::assert_subset(keys, names(df))+ } else if (!is.null(xticks)) {
|
| 78 | -3x | +756 | +7x |
- checkmate::assert_subset(smq_sc, names(df))+ if (max(data$time) <= max(xticks)) {
|
| 79 | -3x | +757 | +6x |
- checkmate::assert_string(na_level)+ gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, min(xticks)), max(xticks))) |
| 80 | +758 | - - | -||
| 81 | -3x | -
- if (!is.null(aag_summary)) {
+ } else {
|
||
| 82 | +759 | 1x |
- assert_df_with_variables(+ gg <- gg + ggplot2::scale_x_continuous(breaks = xticks) |
|
| 83 | -1x | +|||
| 760 | +
- df = aag_summary,+ } |
|||
| 84 | -1x | +|||
| 761 | +! |
- variables = list(val = c("basket", "basket_name"))
+ } else if (!is.null(max_time)) {
|
||
| 85 | -+ | |||
| 762 | +! |
- )+ gg <- gg + ggplot2::scale_x_continuous(limits = c(0, max_time)) |
||
| 86 | +763 |
- # Warning in case there is no match between `aag_summary$basket` and `baskets` argument.+ } |
||
| 87 | +764 |
- # Honestly, I think those should completely match. Target baskets should be the same.+ |
||
| 88 | -1x | +765 | +8x |
- if (length(intersect(baskets, unique(aag_summary$basket))) == 0) {
+ if (!is.null(ggtheme)) {
|
| 89 | -! | +|||
| 766 | +8x |
- warning("There are 0 baskets in common between aag_summary$basket and `baskets` argument.")
+ gg <- gg + ggtheme |
||
| 90 | +767 |
- }+ } |
||
| 91 | +768 |
- }+ |
||
| 92 | -+ | |||
| 769 | +8x |
-
+ gg + ggplot2::theme( |
||
| 93 | -3x | +770 | +8x |
- var_labels <- c(formatters::var_labels(df[, keys]), "SMQ" = smq_varlabel)+ legend.position = "bottom", |
| 94 | -+ | |||
| 771 | +8x |
-
+ legend.title = ggplot2::element_blank(), |
||
| 95 | -+ | |||
| 772 | +8x |
- # convert `na_level` records from baskets to NA for the later loop and from wide to long steps+ legend.key.height = unit(0.02, "npc"), |
||
| 96 | -3x | +773 | +8x |
- df[, c(baskets, smq_sc)][df[, c(baskets, smq_sc)] == na_level] <- NA+ panel.grid.major.x = ggplot2::element_line(linewidth = 2) |
| 97 | +774 |
-
+ ) |
||
| 98 | -3x | +|||
| 775 | +
- if (all(is.na(df[, baskets]))) { # in case there is no level for the target baskets
+ } |
|||
| 99 | -1x | +|||
| 776 | +
- df_long <- df[-seq_len(nrow(df)), keys] # we just need an empty dataframe keeping all factor levels+ |
|||
| 100 | +777 |
- } else {
+ #' `ggplot` Decomposition |
||
| 101 | +778 |
- # Concatenate SMQxxxNAM with corresponding SMQxxxSC+ #' |
||
| 102 | -2x | +|||
| 779 | +
- df_cnct <- df[, c(keys, baskets[startsWith(baskets, "CQ")])]+ #' @description `r lifecycle::badge("stable")`
|
|||
| 103 | +780 |
-
+ #' |
||
| 104 | -2x | +|||
| 781 | +
- for (nam in names(smq)) {
+ #' The elements composing the `ggplot` are extracted and organized in a `list`. |
|||
| 105 | -4x | +|||
| 782 | +
- sc <- smq[nam] # SMQxxxSC corresponding to SMQxxxNAM+ #' |
|||
| 106 | -4x | +|||
| 783 | +
- nam_notna <- !is.na(df[[nam]])+ #' @param gg (`ggplot`)\cr a graphic to decompose. |
|||
| 107 | -4x | +|||
| 784 | +
- new_colname <- paste(nam, sc, sep = "_")+ #' |
|||
| 108 | -4x | +|||
| 785 | +
- df_cnct[nam_notna, new_colname] <- paste0(df[[nam]], "(", df[[sc]], ")")[nam_notna]
+ #' @return A named `list` with elements: |
|||
| 109 | +786 |
- }+ #' * `panel`: The panel. |
||
| 110 | +787 |
-
+ #' * `yaxis`: The y-axis. |
||
| 111 | -2x | +|||
| 788 | +
- df_cnct$unique_id <- seq(1, nrow(df_cnct))+ #' * `xaxis`: The x-axis. |
|||
| 112 | -2x | +|||
| 789 | +
- var_cols <- names(df_cnct)[!(names(df_cnct) %in% c(keys, "unique_id"))]+ #' * `xlab`: The x-axis label. |
|||
| 113 | +790 |
- # have to convert df_cnct from tibble to dataframe+ #' * `ylab`: The y-axis label. |
||
| 114 | +791 |
- # as it throws a warning otherwise about rownames.+ #' * `guide`: The legend. |
||
| 115 | +792 |
- # tibble do not support rownames and reshape creates rownames+ #' |
||
| 116 | +793 |
-
+ #' @examples |
||
| 117 | -2x | +|||
| 794 | +
- df_long <- stats::reshape(+ #' \donttest{
|
|||
| 118 | -2x | +|||
| 795 | +
- data = as.data.frame(df_cnct),+ #' library(dplyr) |
|||
| 119 | -2x | +|||
| 796 | +
- varying = var_cols,+ #' library(survival) |
|||
| 120 | -2x | +|||
| 797 | +
- v.names = "SMQ",+ #' library(grid) |
|||
| 121 | -2x | +|||
| 798 | +
- idvar = names(df_cnct)[names(df_cnct) %in% c(keys, "unique_id")],+ #' |
|||
| 122 | -2x | +|||
| 799 | +
- direction = "long",+ #' fit_km <- tern_ex_adtte %>% |
|||
| 123 | -2x | +|||
| 800 | +
- new.row.names = seq(prod(length(var_cols), nrow(df_cnct)))+ #' filter(PARAMCD == "OS") %>% |
|||
| 124 | +801 |
- )+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
||
| 125 | +802 |
-
+ #' data_plot <- h_data_plot(fit_km = fit_km) |
||
| 126 | -2x | +|||
| 803 | +
- df_long <- df_long[!is.na(df_long[, "SMQ"]), !(names(df_long) %in% c("time", "unique_id"))]
+ #' xticks <- h_xticks(data = data_plot) |
|||
| 127 | -2x | +|||
| 804 | +
- df_long$SMQ <- as.factor(df_long$SMQ)+ #' gg <- h_ggkm( |
|||
| 128 | +805 |
- }+ #' data = data_plot, |
||
| 129 | +806 |
-
+ #' yval = "Survival", |
||
| 130 | -3x | +|||
| 807 | +
- smq_levels <- setdiff(levels(df_long[["SMQ"]]), na_level)+ #' censor_show = TRUE, |
|||
| 131 | +808 |
-
+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
||
| 132 | -3x | +|||
| 809 | +
- if (!is.null(aag_summary)) {
+ #' title = "tt", |
|||
| 133 | +810 |
- # A warning in case there is no match between df and aag_summary records+ #' footnotes = "ff" |
||
| 134 | -1x | +|||
| 811 | +
- if (length(intersect(smq_levels, unique(aag_summary$basket_name))) == 0) {
+ #' ) |
|||
| 135 | -1x | +|||
| 812 | +
- warning("There are 0 basket levels in common between aag_summary$basket_name and df.")
+ #' |
|||
| 136 | +813 |
- }+ #' g_el <- h_decompose_gg(gg) |
||
| 137 | -1x | +|||
| 814 | +
- df_long[["SMQ"]] <- factor(+ #' grid::grid.newpage() |
|||
| 138 | -1x | +|||
| 815 | +
- df_long[["SMQ"]],+ #' grid.rect(gp = grid::gpar(lty = 1, col = "red", fill = "gray85", lwd = 5)) |
|||
| 139 | -1x | +|||
| 816 | +
- levels = sort(+ #' grid::grid.draw(g_el$panel) |
|||
| 140 | -1x | +|||
| 817 | +
- c(+ #' |
|||
| 141 | -1x | +|||
| 818 | +
- smq_levels,+ #' grid::grid.newpage() |
|||
| 142 | -1x | +|||
| 819 | +
- setdiff(unique(aag_summary$basket_name), smq_levels)+ #' grid.rect(gp = grid::gpar(lty = 1, col = "royalblue", fill = "gray85", lwd = 5)) |
|||
| 143 | +820 |
- )+ #' grid::grid.draw(with(g_el, cbind(ylab, yaxis))) |
||
| 144 | +821 |
- )+ #' } |
||
| 145 | +822 |
- )+ #' |
||
| 146 | +823 |
- } else {
+ #' @export |
||
| 147 | -2x | +|||
| 824 | +
- all_na_basket_flag <- vapply(df[, baskets], function(x) {
+ h_decompose_gg <- function(gg) {
|
|||
| 148 | -6x | +825 | +8x |
- all(is.na(x))+ g_el <- ggplot2::ggplotGrob(gg) |
| 149 | -2x | +826 | +8x |
- }, FUN.VALUE = logical(1))+ y <- c( |
| 150 | -2x | +827 | +8x |
- all_na_basket <- baskets[all_na_basket_flag]+ panel = "panel", |
| 151 | -+ | |||
| 828 | +8x |
-
+ yaxis = "axis-l", |
||
| 152 | -2x | +829 | +8x |
- df_long[["SMQ"]] <- factor(+ xaxis = "axis-b", |
| 153 | -2x | +830 | +8x |
- df_long[["SMQ"]],+ xlab = "xlab-b", |
| 154 | -2x | +831 | +8x |
- levels = sort(c(smq_levels, all_na_basket))+ ylab = "ylab-l", |
| 155 | -+ | |||
| 832 | +8x |
- )+ guide = "guide" |
||
| 156 | +833 |
- }+ ) |
||
| 157 | -3x | +834 | +8x |
- formatters::var_labels(df_long) <- var_labels+ lapply(X = y, function(x) gtable::gtable_filter(g_el, x)) |
| 158 | -3x | +|||
| 835 | +
- tibble::tibble(df_long)+ } |
|||
| 159 | +836 |
- }+ |
| 1 | +837 |
- #' Helper Function to create a map dataframe that can be used in `trim_levels_to_map` split function.+ #' Helper: KM Layout |
||
| 2 | +838 |
#' |
||
| 3 | +839 |
#' @description `r lifecycle::badge("stable")`
|
||
| 4 | +840 |
#' |
||
| 5 | +841 |
- #' Helper Function to create a map dataframe from the input dataset, which can be used as an argument in the+ #' Prepares a (5 rows) x (2 cols) layout for the Kaplan-Meier curve. |
||
| 6 | +842 |
- #' `trim_levels_to_map` split function. Based on different method, the map is constructed differently.+ #' |
||
| 7 | +843 |
- #'+ #' @inheritParams g_km |
||
| 8 | +844 |
- #' @inheritParams argument_convention+ #' @inheritParams h_ggkm |
||
| 9 | +845 |
- #' @param abnormal (named `list`)\cr identifying the abnormal range level(s) in `df`. Based on the levels of+ #' @param g_el (`list` of `gtable`)\cr list as obtained by `h_decompose_gg()`. |
||
| 10 | +846 |
- #' abnormality of the input dataset, it can be something like `list(Low = "LOW LOW", High = "HIGH HIGH")` or+ #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of |
||
| 11 | +847 |
- #' `abnormal = list(Low = "LOW", High = "HIGH"))`+ #' patient at risk matching the main grid of the Kaplan-Meier curve. |
||
| 12 | +848 |
- #' @param method (`string`)\cr indicates how the returned map will be constructed. Can be `"default"` or `"range"`.+ #' |
||
| 13 | +849 | ++ |
+ #' @return A grid layout.+ |
+ |
| 850 |
#' |
|||
| 14 | +851 |
- #' @return A map `data.frame`.+ #' @details The layout corresponds to a grid of two columns and five rows of unequal dimensions. Most of the |
||
| 15 | +852 |
- #'+ #' dimension are fixed, only the curve is flexible and will accommodate with the remaining free space. |
||
| 16 | +853 |
- #' @note If method is `"default"`, the returned map will only have the abnormal directions that are observed in the+ #' * The left column gets the annotation of the `ggplot` (y-axis) and the names of the strata for the patient |
||
| 17 | +854 |
- #' `df`, and records with all normal values will be excluded to avoid error in creating layout. If method is+ #' at risk tabulation. The main constraint is about the width of the columns which must allow the writing of |
||
| 18 | +855 |
- #' `"range"`, the returned map will be based on the rule that at least one observation with low range > 0+ #' the strata name. |
||
| 19 | +856 |
- #' for low direction and at least one observation with high range is not missing for high direction.+ #' * The right column receive the `ggplot`, the legend, the x-axis and the patient at risk table. |
||
| 20 | +857 |
#' |
||
| 21 | +858 |
#' @examples |
||
| 22 | +859 |
- #' adlb <- df_explicit_na(tern_ex_adlb)+ #' \donttest{
|
||
| 23 | +860 |
- #'+ #' library(dplyr) |
||
| 24 | +861 |
- #' h_map_for_count_abnormal(+ #' library(survival) |
||
| 25 | +862 |
- #' df = adlb,+ #' library(grid) |
||
| 26 | +863 |
- #' variables = list(anl = "ANRIND", split_rows = c("LBCAT", "PARAM")),
+ #' |
||
| 27 | +864 |
- #' abnormal = list(low = c("LOW"), high = c("HIGH")),
+ #' fit_km <- tern_ex_adtte %>% |
||
| 28 | +865 |
- #' method = "default",+ #' filter(PARAMCD == "OS") %>% |
||
| 29 | +866 |
- #' na_level = "<Missing>"+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
||
| 30 | +867 |
- #' )+ #' data_plot <- h_data_plot(fit_km = fit_km) |
||
| 31 | +868 |
- #'+ #' xticks <- h_xticks(data = data_plot) |
||
| 32 | +869 |
- #' df <- data.frame(+ #' gg <- h_ggkm( |
||
| 33 | +870 |
- #' USUBJID = c(rep("1", 4), rep("2", 4), rep("3", 4)),
+ #' data = data_plot, |
||
| 34 | +871 |
- #' AVISIT = c(+ #' censor_show = TRUE, |
||
| 35 | +872 |
- #' rep("WEEK 1", 2),
+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
||
| 36 | +873 |
- #' rep("WEEK 2", 2),
+ #' title = "tt", footnotes = "ff", yval = "Survival" |
||
| 37 | +874 |
- #' rep("WEEK 1", 2),
+ #' ) |
||
| 38 | +875 |
- #' rep("WEEK 2", 2),
+ #' g_el <- h_decompose_gg(gg) |
||
| 39 | +876 |
- #' rep("WEEK 1", 2),
+ #' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f") |
||
| 40 | +877 |
- #' rep("WEEK 2", 2)
+ #' grid.show.layout(lyt) |
||
| 41 | +878 |
- #' ),+ #' } |
||
| 42 | +879 |
- #' PARAM = rep(c("ALT", "CPR"), 6),
+ #' |
||
| 43 | +880 |
- #' ANRIND = c(+ #' @export |
||
| 44 | +881 |
- #' "NORMAL", "NORMAL", "LOW",+ h_km_layout <- function(data, g_el, title, footnotes, annot_at_risk = TRUE, annot_at_risk_title = TRUE) {
|
||
| 45 | -+ | |||
| 882 | +6x |
- #' "HIGH", "LOW", "LOW", "HIGH", "HIGH", rep("NORMAL", 4)
+ txtlines <- levels(as.factor(data$strata))+ |
+ ||
| 883 | +6x | +
+ nlines <- nlevels(as.factor(data$strata))+ |
+ ||
| 884 | +6x | +
+ col_annot_width <- max(+ |
+ ||
| 885 | +6x | +
+ c(+ |
+ ||
| 886 | +6x | +
+ as.numeric(grid::convertX(g_el$yaxis$width + g_el$ylab$width, "pt")),+ |
+ ||
| 887 | +6x | +
+ as.numeric(+ |
+ ||
| 888 | +6x | +
+ grid::convertX(+ |
+ ||
| 889 | +6x | +
+ grid::stringWidth(txtlines) + grid::unit(7, "pt"), "pt" |
||
| 46 | +890 |
- #' ),+ ) |
||
| 47 | +891 |
- #' ANRLO = rep(5, 12),+ ) |
||
| 48 | +892 |
- #' ANRHI = rep(20, 12)+ ) |
||
| 49 | +893 |
- #' )+ ) |
||
| 50 | +894 |
- #' df$ANRIND <- factor(df$ANRIND, levels = c("LOW", "HIGH", "NORMAL"))
+
|
||
| 51 | -+ | |||
| 895 | +6x |
- #' h_map_for_count_abnormal(+ ttl_row <- as.numeric(!is.null(title)) |
||
| 52 | -+ | |||
| 896 | +6x |
- #' df = df,+ foot_row <- as.numeric(!is.null(footnotes)) |
||
| 53 | -+ | |||
| 897 | +6x |
- #' variables = list(+ no_tbl_ind <- c() |
||
| 54 | -+ | |||
| 898 | +6x |
- #' anl = "ANRIND",+ ht_x <- c() |
||
| 55 | -+ | |||
| 899 | +6x |
- #' split_rows = c("PARAM"),
+ ht_units <- c() |
||
| 56 | +900 |
- #' range_low = "ANRLO",+ |
||
| 57 | -+ | |||
| 901 | +6x |
- #' range_high = "ANRHI"+ if (ttl_row == 1) {
|
||
| 58 | -+ | |||
| 902 | +1x |
- #' ),+ no_tbl_ind <- c(no_tbl_ind, TRUE) |
||
| 59 | -+ | |||
| 903 | +1x |
- #' abnormal = list(low = c("LOW"), high = c("HIGH")),
+ ht_x <- c(ht_x, 2) |
||
| 60 | -+ | |||
| 904 | +1x |
- #' method = "range",+ ht_units <- c(ht_units, "lines") |
||
| 61 | +905 |
- #' na_level = "<Missing>"+ } |
||
| 62 | +906 |
- #' )+ |
||
| 63 | -+ | |||
| 907 | +6x |
- #'+ no_tbl_ind <- c(no_tbl_ind, rep(TRUE, 3), rep(FALSE, 2)) |
||
| 64 | -+ | |||
| 908 | +6x |
- #' @export+ ht_x <- c( |
||
| 65 | -+ | |||
| 909 | +6x |
- h_map_for_count_abnormal <- function(df,+ ht_x, |
||
| 66 | -+ | |||
| 910 | +6x |
- variables = list(+ 1, |
||
| 67 | -+ | |||
| 911 | +6x |
- anl = "ANRIND",+ grid::convertX(with(g_el, xaxis$height + ylab$width), "pt") + grid::unit(5, "pt"), |
||
| 68 | -+ | |||
| 912 | +6x |
- split_rows = c("PARAM"),
+ grid::convertX(g_el$guide$heights, "pt") + grid::unit(2, "pt"), |
||
| 69 | -+ | |||
| 913 | +6x |
- range_low = "ANRLO",+ 1, |
||
| 70 | -+ | |||
| 914 | +6x |
- range_high = "ANRHI"+ nlines + 0.5, |
||
| 71 | -+ | |||
| 915 | +6x |
- ),+ grid::convertX(with(g_el, xaxis$height + ylab$width), "pt") |
||
| 72 | +916 |
- abnormal = list(low = c("LOW", "LOW LOW"), high = c("HIGH", "HIGH HIGH")),
+ ) |
||
| 73 | -+ | |||
| 917 | +6x |
- method = c("default", "range"),
+ ht_units <- c( |
||
| 74 | -+ | |||
| 918 | +6x |
- na_level = "<Missing>") {
+ ht_units, |
||
| 75 | -7x | +919 | +6x |
- method <- match.arg(method)+ "null", |
| 76 | -7x | +920 | +6x |
- checkmate::assert_subset(c("anl", "split_rows"), names(variables))
+ "pt", |
| 77 | -7x | +921 | +6x |
- checkmate::assert_false(anyNA(df[variables$split_rows]))+ "pt", |
| 78 | -7x | +922 | +6x |
- assert_df_with_variables(df,+ "lines", |
| 79 | -7x | +923 | +6x |
- variables = list(anl = variables$anl, split_rows = variables$split_rows),+ "lines", |
| 80 | -7x | +924 | +6x |
- na_level = na_level+ "pt" |
| 81 | +925 |
) |
||
| 82 | -7x | +|||
| 926 | +
- assert_df_with_factors(df, list(val = variables$anl))+ |
|||
| 83 | -7x | +927 | +6x |
- assert_valid_factor(df[[variables$anl]], any.missing = FALSE)+ if (foot_row == 1) {
|
| 84 | -7x | +928 | +1x |
- assert_list_of_variables(variables)+ no_tbl_ind <- c(no_tbl_ind, TRUE) |
| 85 | -7x | +929 | +1x |
- checkmate::assert_list(abnormal, types = "character", len = 2)+ ht_x <- c(ht_x, 1) |
| 86 | -+ | |||
| 930 | +1x |
-
+ ht_units <- c(ht_units, "lines") |
||
| 87 | +931 |
- # Drop usued levels from df as they are not supposed to be in the final map+ } |
||
| 88 | -7x | +932 | +6x |
- df <- droplevels(df)+ if (annot_at_risk) {
|
| 89 | -+ | |||
| 933 | +6x |
-
+ no_at_risk_tbl <- rep(TRUE, 6 + ttl_row + foot_row) |
||
| 90 | -7x | +934 | +6x |
- normal_value <- setdiff(levels(df[[variables$anl]]), unlist(abnormal))+ if (!annot_at_risk_title) {
|
| 91 | -+ | |||
| 935 | +! |
-
+ no_at_risk_tbl[length(no_at_risk_tbl) - 2 - foot_row] <- FALSE |
||
| 92 | +936 |
- # Based on the understanding of clinical data, there should only be one level of normal which is "NORMAL"- |
- ||
| 93 | -7x | -
- checkmate::assert_vector(normal_value, len = 1)+ } |
||
| 94 | +937 |
-
+ } else {
|
||
| 95 | -+ | |||
| 938 | +! |
- # Default method will only have what is observed in the df, and records with all normal values will be excluded to+ no_at_risk_tbl <- no_tbl_ind |
||
| 96 | +939 |
- # avoid error in layout building.+ } |
||
| 97 | -7x | +|||
| 940 | +
- if (method == "default") {
+
|
|||
| 98 | -3x | +941 | +6x |
- df_abnormal <- subset(df, df[[variables$anl]] %in% unlist(abnormal))+ grid::grid.layout( |
| 99 | -3x | +942 | +6x |
- map <- unique(df_abnormal[c(variables$split_rows, variables$anl)])+ nrow = sum(no_at_risk_tbl), ncol = 2, |
| 100 | -3x | +943 | +6x |
- map_normal <- unique(subset(map, select = variables$split_rows))+ widths = grid::unit(c(col_annot_width, 1), c("pt", "null")),
|
| 101 | -3x | +944 | +6x |
- map_normal[[variables$anl]] <- normal_value+ heights = grid::unit( |
| 102 | -3x | +945 | +6x |
- map <- rbind(map, map_normal)+ x = ht_x[no_at_risk_tbl], |
| 103 | -4x | +946 | +6x |
- } else if (method == "range") {
+ units = ht_units[no_at_risk_tbl] |
| 104 | +947 |
- # range method follows the rule that at least one observation with ANRLO > 0 for low+ ) |
||
| 105 | +948 |
- # direction and at least one observation with ANRHI is not missing for high direction.+ ) |
||
| 106 | -4x | +|||
| 949 | +
- checkmate::assert_subset(c("range_low", "range_high"), names(variables))
+ } |
|||
| 107 | -4x | +|||
| 950 | +
- checkmate::assert_subset(c("LOW", "HIGH"), toupper(names(abnormal)))
+
|
|||
| 108 | +951 |
-
+ #' Helper: Patient-at-Risk Grobs |
||
| 109 | -4x | +|||
| 952 | +
- assert_df_with_variables(df,+ #' |
|||
| 110 | -4x | +|||
| 953 | +
- variables = list(+ #' @description `r lifecycle::badge("stable")`
|
|||
| 111 | -4x | +|||
| 954 | +
- range_low = variables$range_low,+ #' |
|||
| 112 | -4x | +|||
| 955 | +
- range_high = variables$range_high+ #' Two graphical objects are obtained, one corresponding to row labeling and the second to the table of |
|||
| 113 | +956 |
- )+ #' numbers of patients at risk. If `title = TRUE`, a third object corresponding to the table title is |
||
| 114 | +957 |
- )+ #' also obtained. |
||
| 115 | +958 |
-
+ #' |
||
| 116 | +959 |
- # Define low direction of map+ #' @inheritParams g_km |
||
| 117 | -4x | +|||
| 960 | +
- df_low <- subset(df, df[[variables$range_low]] > 0)+ #' @inheritParams h_ggkm |
|||
| 118 | -4x | +|||
| 961 | +
- map_low <- unique(df_low[variables$split_rows])+ #' @param annot_tbl (`data.frame`)\cr annotation as prepared by [survival::summary.survfit()] which |
|||
| 119 | -4x | +|||
| 962 | +
- low_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "LOW"]))+ #' includes the number of patients at risk at given time points. |
|||
| 120 | -4x | +|||
| 963 | +
- low_levels_df <- as.data.frame(low_levels)+ #' @param xlim (`numeric`)\cr the maximum value on the x-axis (used to |
|||
| 121 | -4x | +|||
| 964 | +
- colnames(low_levels_df) <- variables$anl+ #' ensure the at risk table aligns with the KM graph). |
|||
| 122 | -4x | +|||
| 965 | +
- low_levels_df <- do.call("rbind", replicate(nrow(map_low), low_levels_df, simplify = FALSE))
+ #' @param title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk` |
|||
| 123 | -4x | +|||
| 966 | +
- rownames(map_low) <- NULL # Just to avoid strange row index in case upstream functions changed+ #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`. |
|||
| 124 | -4x | +|||
| 967 | +
- map_low <- map_low[rep(seq_len(nrow(map_low)), each = length(low_levels)), , drop = FALSE]+ #' |
|||
| 125 | -4x | +|||
| 968 | +
- map_low <- cbind(map_low, low_levels_df)+ #' @return A named `list` of two `gTree` objects if `title = FALSE`: `at_risk` and `label`, or three |
|||
| 126 | +969 |
-
+ #' `gTree` objects if `title = TRUE`: `at_risk`, `label`, and `title`. |
||
| 127 | +970 |
- # Define high direction of map+ #' |
||
| 128 | -4x | +|||
| 971 | +
- df_high <- subset(df, df[[variables$range_high]] != na_level | !is.na(df[[variables$range_high]]))+ #' @examples |
|||
| 129 | -4x | +|||
| 972 | +
- map_high <- unique(df_high[variables$split_rows])+ #' \donttest{
|
|||
| 130 | -4x | +|||
| 973 | +
- high_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "HIGH"]))+ #' library(dplyr) |
|||
| 131 | -4x | +|||
| 974 | +
- high_levels_df <- as.data.frame(high_levels)+ #' library(survival) |
|||
| 132 | -4x | +|||
| 975 | +
- colnames(high_levels_df) <- variables$anl+ #' library(grid) |
|||
| 133 | -4x | +|||
| 976 | +
- high_levels_df <- do.call("rbind", replicate(nrow(map_high), high_levels_df, simplify = FALSE))
+ #' |
|||
| 134 | -4x | +|||
| 977 | +
- rownames(map_high) <- NULL+ #' fit_km <- tern_ex_adtte %>% |
|||
| 135 | -4x | +|||
| 978 | +
- map_high <- map_high[rep(seq_len(nrow(map_high)), each = length(high_levels)), , drop = FALSE]+ #' filter(PARAMCD == "OS") %>% |
|||
| 136 | -4x | +|||
| 979 | +
- map_high <- cbind(map_high, high_levels_df)+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
|||
| 137 | +980 |
-
+ #' |
||
| 138 | +981 |
- # Define normal of map+ #' data_plot <- h_data_plot(fit_km = fit_km) |
||
| 139 | -4x | +|||
| 982 | +
- map_normal <- unique(rbind(map_low, map_high)[variables$split_rows])+ #' |
|||
| 140 | -4x | +|||
| 983 | +
- map_normal[variables$anl] <- normal_value+ #' xticks <- h_xticks(data = data_plot) |
|||
| 141 | +984 |
-
+ #' |
||
| 142 | -4x | +|||
| 985 | +
- map <- rbind(map_low, map_high, map_normal)+ #' gg <- h_ggkm( |
|||
| 143 | +986 |
- }+ #' data = data_plot, |
||
| 144 | +987 |
-
+ #' censor_show = TRUE, |
||
| 145 | +988 |
- # map should be all characters+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
||
| 146 | -7x | +|||
| 989 | +
- map <- data.frame(lapply(map, as.character), stringsAsFactors = FALSE)+ #' title = "tt", footnotes = "ff", yval = "Survival" |
|||
| 147 | +990 |
-
+ #' ) |
||
| 148 | +991 |
- # sort the map final output by split_rows variables+ #' |
||
| 149 | -7x | +|||
| 992 | +
- for (i in rev(seq_len(length(variables$split_rows)))) {
+ #' # The annotation table reports the patient at risk for a given strata and |
|||
| 150 | -7x | +|||
| 993 | +
- map <- map[order(map[[i]]), ]+ #' # time (`xticks`). |
|||
| 151 | +994 |
- }+ #' annot_tbl <- summary(fit_km, time = xticks) |
||
| 152 | -7x | +|||
| 995 | +
- map+ #' if (is.null(fit_km$strata)) {
|
|||
| 153 | +996 |
- }+ #' annot_tbl <- with(annot_tbl, data.frame(n.risk = n.risk, time = time, strata = "All")) |
| 1 | +997 |
- #' Helper Functions for Cox Proportional Hazards Regression+ #' } else {
|
||
| 2 | +998 |
- #'+ #' strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
|
||
| 3 | +999 |
- #' @description `r lifecycle::badge("stable")`
+ #' levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2] |
||
| 4 | +1000 |
- #'+ #' annot_tbl <- data.frame( |
||
| 5 | +1001 |
- #' Helper functions used in [fit_coxreg_univar()] and [fit_coxreg_multivar()].+ #' n.risk = annot_tbl$n.risk, |
||
| 6 | +1002 |
- #'+ #' time = annot_tbl$time, |
||
| 7 | +1003 |
- #' @inheritParams argument_convention+ #' strata = annot_tbl$strata |
||
| 8 | +1004 |
- #' @inheritParams h_coxreg_univar_extract+ #' ) |
||
| 9 | +1005 |
- #' @inheritParams cox_regression_inter+ #' } |
||
| 10 | +1006 |
- #' @inheritParams control_coxreg+ #' |
||
| 11 | +1007 |
- #'+ #' # The annotation table is transformed into a grob. |
||
| 12 | +1008 |
- #' @seealso [cox_regression]+ #' tbl <- h_grob_tbl_at_risk(data = data_plot, annot_tbl = annot_tbl, xlim = max(xticks)) |
||
| 13 | +1009 |
#' |
||
| 14 | +1010 |
- #' @name h_cox_regression+ #' # For the representation, the layout is estimated for which the decomposition |
||
| 15 | +1011 |
- NULL+ #' # of the graphic element is necessary. |
||
| 16 | +1012 |
-
+ #' g_el <- h_decompose_gg(gg) |
||
| 17 | +1013 |
- #' @describeIn h_cox_regression Helper for Cox regression formula. Creates a list of formulas. It is used+ #' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f") |
||
| 18 | +1014 |
- #' internally by [fit_coxreg_univar()] for the comparison of univariate Cox regression models.+ #' |
||
| 19 | +1015 |
- #'+ #' grid::grid.newpage() |
||
| 20 | +1016 |
- #' @return+ #' pushViewport(viewport(layout = lyt, height = .95, width = .95)) |
||
| 21 | +1017 |
- #' * `h_coxreg_univar_formulas()` returns a `character` vector coercible into formulas (e.g [stats::as.formula()]).+ #' grid.rect(gp = grid::gpar(lty = 1, col = "purple", fill = "gray85", lwd = 1)) |
||
| 22 | +1018 |
- #'+ #' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 2)) |
||
| 23 | +1019 |
- #' @examples+ #' grid.rect(gp = grid::gpar(lty = 1, col = "orange", fill = "gray85", lwd = 1)) |
||
| 24 | +1020 |
- #' # `h_coxreg_univar_formulas`+ #' grid::grid.draw(tbl$at_risk) |
||
| 25 | +1021 |
- #'+ #' popViewport() |
||
| 26 | +1022 |
- #' ## Simple formulas.+ #' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 1)) |
||
| 27 | +1023 |
- #' h_coxreg_univar_formulas(+ #' grid.rect(gp = grid::gpar(lty = 1, col = "green3", fill = "gray85", lwd = 1)) |
||
| 28 | +1024 |
- #' variables = list(+ #' grid::grid.draw(tbl$label) |
||
| 29 | +1025 |
- #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y")
+ #' } |
||
| 30 | +1026 |
- #' )+ #' |
||
| 31 | +1027 |
- #' )+ #' @export |
||
| 32 | +1028 |
- #'+ h_grob_tbl_at_risk <- function(data, annot_tbl, xlim, title = TRUE) {
+ |
+ ||
| 1029 | +6x | +
+ txtlines <- levels(as.factor(data$strata))+ |
+ ||
| 1030 | +6x | +
+ nlines <- nlevels(as.factor(data$strata))+ |
+ ||
| 1031 | +6x | +
+ y_int <- annot_tbl$time[2] - annot_tbl$time[1]+ |
+ ||
| 1032 | +6x | +
+ annot_tbl <- expand.grid(+ |
+ ||
| 1033 | +6x | +
+ time = seq(0, xlim, y_int),+ |
+ ||
| 1034 | +6x | +
+ strata = unique(annot_tbl$strata)+ |
+ ||
| 1035 | +6x | +
+ ) %>% dplyr::left_join(annot_tbl, by = c("time", "strata"))
+ |
+ ||
| 1036 | +6x | +
+ annot_tbl[is.na(annot_tbl)] <- 0+ |
+ ||
| 1037 | +6x | +
+ y_str_unit <- as.numeric(annot_tbl$strata)+ |
+ ||
| 1038 | +6x | +
+ vp_table <- grid::plotViewport(margins = grid::unit(c(0, 0, 0, 0), "lines"))+ |
+ ||
| 1039 | +6x | +
+ if (title) {
+ |
+ ||
| 1040 | +6x | +
+ gb_table_title <- grid::gList(+ |
+ ||
| 1041 | +6x | +
+ grid::textGrob(+ |
+ ||
| 1042 | +6x | +
+ label = "Patients at Risk:",+ |
+ ||
| 1043 | +6x | +
+ x = 1,+ |
+ ||
| 1044 | +6x | +
+ y = grid::unit(0.2, "native"),+ |
+ ||
| 1045 | +6x | +
+ gp = grid::gpar(fontface = "bold", fontsize = 10) |
||
| 33 | +1046 |
- #' ## Addition of an optional strata.+ ) |
||
| 34 | +1047 |
- #' h_coxreg_univar_formulas(+ ) |
||
| 35 | +1048 |
- #' variables = list(+ }+ |
+ ||
| 1049 | +6x | +
+ gb_table_left_annot <- grid::gList(+ |
+ ||
| 1050 | +6x | +
+ grid::rectGrob(+ |
+ ||
| 1051 | +6x | +
+ x = 0, y = grid::unit(c(1:nlines) - 1, "lines"),+ |
+ ||
| 1052 | +6x | +
+ gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
+ |
+ ||
| 1053 | +6x | +
+ height = grid::unit(1, "lines"), just = "bottom", hjust = 0 |
||
| 36 | +1054 |
- #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
+ ),+ |
+ ||
| 1055 | +6x | +
+ grid::textGrob(+ |
+ ||
| 1056 | +6x | +
+ label = unique(annot_tbl$strata),+ |
+ ||
| 1057 | +6x | +
+ x = 0.5,+ |
+ ||
| 1058 | +6x | +
+ y = grid::unit(+ |
+ ||
| 1059 | +6x | +
+ (max(unique(y_str_unit)) - unique(y_str_unit)) + 0.75,+ |
+ ||
| 1060 | +6x | +
+ "native" |
||
| 37 | +1061 |
- #' strata = "SITE"+ ), |
||
| 38 | -+ | |||
| 1062 | +6x |
- #' )+ gp = grid::gpar(fontface = "italic", fontsize = 10) |
||
| 39 | +1063 |
- #' )+ ) |
||
| 40 | +1064 |
- #'+ ) |
||
| 41 | -+ | |||
| 1065 | +6x |
- #' ## Inclusion of the interaction term.+ gb_patient_at_risk <- grid::gList( |
||
| 42 | -+ | |||
| 1066 | +6x |
- #' h_coxreg_univar_formulas(+ grid::rectGrob( |
||
| 43 | -+ | |||
| 1067 | +6x |
- #' variables = list(+ x = 0, y = grid::unit(c(1:nlines) - 1, "lines"), |
||
| 44 | -+ | |||
| 1068 | +6x |
- #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
+ gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
|
||
| 45 | -+ | |||
| 1069 | +6x |
- #' strata = "SITE"+ height = grid::unit(1, "lines"), just = "bottom", hjust = 0 |
||
| 46 | +1070 |
- #' ),+ ), |
||
| 47 | -+ | |||
| 1071 | +6x |
- #' interaction = TRUE+ grid::textGrob( |
||
| 48 | -+ | |||
| 1072 | +6x |
- #' )+ label = annot_tbl$n.risk, |
||
| 49 | -+ | |||
| 1073 | +6x |
- #'+ x = grid::unit(annot_tbl$time, "native"), |
||
| 50 | -+ | |||
| 1074 | +6x |
- #' ## Only covariates fitted in separate models.+ y = grid::unit( |
||
| 51 | -+ | |||
| 1075 | +6x |
- #' h_coxreg_univar_formulas(+ (max(y_str_unit) - y_str_unit) + .5, |
||
| 52 | -+ | |||
| 1076 | +6x |
- #' variables = list(+ "line" |
||
| 53 | -+ | |||
| 1077 | +6x |
- #' time = "time", event = "status", covariates = c("X", "y")
+ ) # maybe native |
||
| 54 | +1078 |
- #' )+ ) |
||
| 55 | +1079 |
- #' )+ ) |
||
| 56 | +1080 |
- #'+ |
||
| 57 | -+ | |||
| 1081 | +6x |
- #' @export+ ret <- list( |
||
| 58 | -+ | |||
| 1082 | +6x |
- h_coxreg_univar_formulas <- function(variables,+ at_risk = grid::gList( |
||
| 59 | -+ | |||
| 1083 | +6x |
- interaction = FALSE) {
+ grid::gTree( |
||
| 60 | -41x | +1084 | +6x |
- checkmate::assert_list(variables, names = "named")+ vp = vp_table, |
| 61 | -41x | +1085 | +6x |
- has_arm <- "arm" %in% names(variables)+ children = grid::gList( |
| 62 | -41x | +1086 | +6x |
- arm_name <- if (has_arm) "arm" else NULL+ grid::gTree( |
| 63 | -+ | |||
| 1087 | +6x |
-
+ vp = grid::dataViewport( |
||
| 64 | -41x | +1088 | +6x |
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ xscale = c(0, xlim) + c(-0.05, 0.05) * xlim, |
| 65 | -+ | |||
| 1089 | +6x |
-
+ yscale = c(0, nlines + 1), |
||
| 66 | -41x | +1090 | +6x |
- checkmate::assert_flag(interaction)+ extension = c(0.05, 0) |
| 67 | +1091 |
-
+ ), |
||
| 68 | -41x | +1092 | +6x |
- if (!has_arm || is.null(variables$covariates)) {
+ children = grid::gList(gb_patient_at_risk) |
| 69 | -10x | +|||
| 1093 | +
- checkmate::assert_false(interaction)+ ) |
|||
| 70 | +1094 |
- }+ ) |
||
| 71 | +1095 |
-
+ ) |
||
| 72 | -39x | +|||
| 1096 | +
- assert_list_of_variables(variables[c(arm_name, "event", "time")])+ ), |
|||
| 73 | -+ | |||
| 1097 | +6x |
-
+ label = grid::gList( |
||
| 74 | -39x | +1098 | +6x |
- if (!is.null(variables$covariates)) {
+ grid::gTree( |
| 75 | -38x | +1099 | +6x |
- forms <- paste0(+ vp = grid::viewport(width = max(grid::stringWidth(txtlines))), |
| 76 | -38x | +1100 | +6x |
- "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
+ children = grid::gList( |
| 77 | -38x | +1101 | +6x |
- ifelse(has_arm, variables$arm, "1"),+ grid::gTree( |
| 78 | -38x | +1102 | +6x |
- ifelse(interaction, " * ", " + "),+ vp = grid::dataViewport( |
| 79 | -38x | +1103 | +6x |
- variables$covariates,+ xscale = 0:1, |
| 80 | -38x | +1104 | +6x |
- ifelse(+ yscale = c(0, nlines + 1), |
| 81 | -38x | +1105 | +6x |
- !is.null(variables$strata),+ extension = c(0.0, 0)+ |
+
| 1106 | ++ |
+ ), |
||
| 82 | -38x | +1107 | +6x |
- paste0(" + strata(", paste0(variables$strata, collapse = ", "), ")"),
+ children = grid::gList(gb_table_left_annot) |
| 83 | +1108 |
- ""+ ) |
||
| 84 | +1109 |
- )+ ) |
||
| 85 | +1110 |
- )+ ) |
||
| 86 | +1111 |
- } else {
+ ) |
||
| 87 | -1x | +|||
| 1112 | +
- forms <- NULL+ ) |
|||
| 88 | +1113 |
- }+ |
||
| 89 | -39x | +1114 | +6x |
- nams <- variables$covariates+ if (title) {
|
| 90 | -39x | +1115 | +6x |
- if (has_arm) {
+ ret[["title"]] <- grid::gList( |
| 91 | -32x | +1116 | +6x |
- ref <- paste0(+ grid::gTree( |
| 92 | -32x | +1117 | +6x |
- "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
+ vp = grid::viewport(width = max(grid::stringWidth(txtlines))), |
| 93 | -32x | +1118 | +6x |
- variables$arm,+ children = grid::gList( |
| 94 | -32x | +1119 | +6x |
- ifelse(+ grid::gTree( |
| 95 | -32x | +1120 | +6x |
- !is.null(variables$strata),+ vp = grid::dataViewport( |
| 96 | -32x | +1121 | +6x |
- paste0(+ xscale = 0:1, |
| 97 | -32x | +1122 | +6x |
- " + strata(", paste0(variables$strata, collapse = ", "), ")"
+ yscale = c(0, 1),+ |
+
| 1123 | +6x | +
+ extension = c(0, 0) |
||
| 98 | +1124 |
- ),+ ),+ |
+ ||
| 1125 | +6x | +
+ children = grid::gList(gb_table_title) |
||
| 99 | +1126 |
- ""+ ) |
||
| 100 | +1127 |
- )+ ) |
||
| 101 | +1128 |
- )+ ) |
||
| 102 | -32x | +|||
| 1129 | +
- forms <- c(ref, forms)+ ) |
|||
| 103 | -32x | +|||
| 1130 | +
- nams <- c("ref", nams)
+ } |
|||
| 104 | +1131 |
- }+ |
||
| 105 | -39x | +1132 | +6x |
- stats::setNames(forms, nams)+ ret |
| 106 | +1133 |
} |
||
| 107 | +1134 | |||
| 108 | +1135 |
- #' @describeIn h_cox_regression Helper for multivariate Cox regression formula. Creates a formulas+ #' Helper Function: Survival Estimations |
||
| 109 | +1136 |
- #' string. It is used internally by [fit_coxreg_multivar()] for the comparison of multivariate Cox+ #' |
||
| 110 | +1137 |
- #' regression models. Interactions will not be included in multivariate Cox regression model.+ #' @description `r lifecycle::badge("stable")`
|
||
| 111 | +1138 |
#' |
||
| 112 | -- |
- #' @return- |
- ||
| 113 | +1139 |
- #' * `h_coxreg_multivar_formula()` returns a `string` coercible into a formula (e.g [stats::as.formula()]).+ #' Transform a survival fit to a table with groups in rows characterized by N, median and confidence interval. |
||
| 114 | +1140 |
#' |
||
| 115 | +1141 |
- #' @examples+ #' @inheritParams h_data_plot |
||
| 116 | +1142 |
- #' # `h_coxreg_multivar_formula`+ #' |
||
| 117 | +1143 |
- #'+ #' @return A summary table with statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`). |
||
| 118 | +1144 |
- #' h_coxreg_multivar_formula(+ #' |
||
| 119 | +1145 |
- #' variables = list(+ #' @examples |
||
| 120 | +1146 |
- #' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE")
+ #' \donttest{
|
||
| 121 | +1147 |
- #' )+ #' library(dplyr) |
||
| 122 | +1148 |
- #' )+ #' library(survival) |
||
| 123 | +1149 |
#' |
||
| 124 | +1150 |
- #' # Addition of an optional strata.+ #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "OS") |
||
| 125 | +1151 |
- #' h_coxreg_multivar_formula(+ #' fit <- survfit( |
||
| 126 | +1152 |
- #' variables = list(+ #' form = Surv(AVAL, 1 - CNSR) ~ ARMCD, |
||
| 127 | +1153 |
- #' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE"),
+ #' data = adtte |
||
| 128 | +1154 |
- #' strata = "SITE"+ #' ) |
||
| 129 | +1155 |
- #' )+ #' h_tbl_median_surv(fit_km = fit) |
||
| 130 | +1156 |
- #' )+ #' } |
||
| 131 | +1157 |
#' |
||
| 132 | +1158 |
- #' # Example without treatment arm.+ #' @export |
||
| 133 | +1159 |
- #' h_coxreg_multivar_formula(+ h_tbl_median_surv <- function(fit_km, armval = "All") {
|
||
| 134 | -+ | |||
| 1160 | +6x |
- #' variables = list(+ y <- if (is.null(fit_km$strata)) {
|
||
| 135 | -+ | |||
| 1161 | +! |
- #' time = "AVAL", event = "event", covariates = c("RACE", "AGE"),
+ as.data.frame(t(summary(fit_km)$table), row.names = armval) |
||
| 136 | +1162 |
- #' strata = "SITE"+ } else {
|
||
| 137 | -+ | |||
| 1163 | +6x |
- #' )+ tbl <- summary(fit_km)$table |
||
| 138 | -+ | |||
| 1164 | +6x |
- #' )+ rownames_lst <- strsplit(sub("=", "equals", rownames(tbl)), "equals")
|
||
| 139 | -+ | |||
| 1165 | +6x |
- #'+ rownames(tbl) <- matrix(unlist(rownames_lst), ncol = 2, byrow = TRUE)[, 2] |
||
| 140 | -+ | |||
| 1166 | +6x |
- #' @export+ as.data.frame(tbl) |
||
| 141 | +1167 |
- h_coxreg_multivar_formula <- function(variables) {
+ } |
||
| 142 | -57x | +1168 | +6x |
- checkmate::assert_list(variables, names = "named")+ conf.int <- summary(fit_km)$conf.int # nolint |
| 143 | -57x | +1169 | +6x |
- has_arm <- "arm" %in% names(variables)+ y$records <- round(y$records) |
| 144 | -57x | +1170 | +6x |
- arm_name <- if (has_arm) "arm" else NULL+ y$median <- signif(y$median, 4) |
| 145 | -+ | |||
| 1171 | +6x |
-
+ y$`CI` <- paste0( |
||
| 146 | -57x | +1172 | +6x |
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ "(", signif(y[[paste0(conf.int, "LCL")]], 4), ", ", signif(y[[paste0(conf.int, "UCL")]], 4), ")"
|
| 147 | +1173 |
-
+ ) |
||
| 148 | -57x | -
- assert_list_of_variables(variables[c(arm_name, "event", "time")])- |
- ||
| 149 | -+ | 1174 | +6x |
-
+ stats::setNames( |
| 150 | -57x | +1175 | +6x |
- y <- paste0(+ y[c("records", "median", "CI")],
|
| 151 | -57x | +1176 | +6x |
- "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
+ c("N", "Median", f_conf_level(conf.int))
|
| 152 | -57x | +|||
| 1177 | +
- ifelse(has_arm, variables$arm, "1")+ ) |
|||
| 153 | +1178 |
- )+ } |
||
| 154 | -57x | +|||
| 1179 | +
- if (length(variables$covariates) > 0) {
+
|
|||
| 155 | -18x | +|||
| 1180 | +
- y <- paste(y, paste(variables$covariates, collapse = " + "), sep = " + ")+ #' Helper Function: Survival Estimation Grob |
|||
| 156 | +1181 |
- }+ #' |
||
| 157 | -57x | +|||
| 1182 | +
- if (!is.null(variables$strata)) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 158 | -5x | +|||
| 1183 | +
- y <- paste0(y, " + strata(", paste0(variables$strata, collapse = ", "), ")")
+ #' |
|||
| 159 | +1184 |
- }+ #' The survival fit is transformed in a grob containing a table with groups in |
||
| 160 | -57x | +|||
| 1185 | +
- y+ #' rows characterized by N, median and 95% confidence interval. |
|||
| 161 | +1186 |
- }+ #' |
||
| 162 | +1187 |
-
+ #' @inheritParams g_km |
||
| 163 | +1188 |
- #' @describeIn h_cox_regression Utility function to help tabulate the result of+ #' @inheritParams h_data_plot |
||
| 164 | +1189 |
- #' a univariate Cox regression model.+ #' @param ttheme (`list`)\cr see [gridExtra::ttheme_default()]. |
||
| 165 | +1190 |
- #'+ #' @param x (`numeric`)\cr a value between 0 and 1 specifying x-location. |
||
| 166 | +1191 |
- #' @param effect (`string`)\cr the treatment variable.+ #' @param y (`numeric`)\cr a value between 0 and 1 specifying y-location. |
||
| 167 | +1192 |
- #' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()].+ #' @param width (`unit`)\cr width (as a unit) to use when printing the grob. |
||
| 168 | +1193 |
#' |
||
| 169 | +1194 |
- #' @return+ #' @return A `grob` of a table containing statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`). |
||
| 170 | +1195 |
- #' * `h_coxreg_univar_extract()` returns a `data.frame` with variables `effect`, `term`, `term_label`, `level`,+ #' |
||
| 171 | +1196 |
- #' `n`, `hr`, `lcl`, `ucl`, and `pval`.+ #' @examples |
||
| 172 | +1197 |
- #'+ #' \donttest{
|
||
| 173 | +1198 |
- #' @examples+ #' library(dplyr) |
||
| 174 | +1199 |
#' library(survival) |
||
| 175 | +1200 |
- #'+ #' library(grid) |
||
| 176 | +1201 |
- #' dta_simple <- data.frame(+ #' |
||
| 177 | +1202 |
- #' time = c(5, 5, 10, 10, 5, 5, 10, 10),+ #' grid::grid.newpage() |
||
| 178 | +1203 |
- #' status = c(0, 0, 1, 0, 0, 1, 1, 1),+ #' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1)) |
||
| 179 | +1204 |
- #' armcd = factor(LETTERS[c(1, 1, 1, 1, 2, 2, 2, 2)], levels = c("A", "B")),
+ #' tern_ex_adtte %>% |
||
| 180 | +1205 |
- #' var1 = c(45, 55, 65, 75, 55, 65, 85, 75),+ #' filter(PARAMCD == "OS") %>% |
||
| 181 | +1206 |
- #' var2 = c("F", "M", "F", "M", "F", "M", "F", "U")
+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>% |
||
| 182 | +1207 |
- #' )+ #' h_grob_median_surv() %>% |
||
| 183 | +1208 |
- #' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple)+ #' grid::grid.draw() |
||
| 184 | +1209 |
- #' result <- h_coxreg_univar_extract(+ #' } |
||
| 185 | +1210 |
- #' effect = "armcd", covar = "armcd", mod = mod, data = dta_simple+ #' |
||
| 186 | +1211 |
- #' )+ #' @export |
||
| 187 | +1212 |
- #' result+ h_grob_median_surv <- function(fit_km, |
||
| 188 | +1213 |
- #'+ armval = "All", |
||
| 189 | +1214 |
- #' @export+ x = 0.9, |
||
| 190 | +1215 |
- h_coxreg_univar_extract <- function(effect,+ y = 0.9, |
||
| 191 | +1216 |
- covar,+ width = grid::unit(0.3, "npc"), |
||
| 192 | +1217 |
- data,+ ttheme = gridExtra::ttheme_default()) {
+ |
+ ||
| 1218 | +5x | +
+ data <- h_tbl_median_surv(fit_km, armval = armval) |
||
| 193 | +1219 |
- mod,+ + |
+ ||
| 1220 | +5x | +
+ width <- grid::convertUnit(width, "in")+ |
+ ||
| 1221 | +5x | +
+ height <- width * (nrow(data) + 1) / 12 |
||
| 194 | +1222 |
- control = control_coxreg()) {
+
|
||
| 195 | -47x | +1223 | +5x |
- checkmate::assert_string(covar)+ w <- paste(" ", c(
|
| 196 | -47x | +1224 | +5x |
- checkmate::assert_string(effect)+ rownames(data)[which.max(nchar(rownames(data)))], |
| 197 | -47x | +1225 | +5x |
- checkmate::assert_class(mod, "coxph")+ sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))])+ |
+
| 1226 | ++ |
+ )) |
||
| 198 | -47x | +1227 | +5x |
- test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]+ w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE) |
| 199 | +1228 | |||
| 200 | -47x | +1229 | +5x |
- mod_aov <- muffled_car_anova(mod, test_statistic)+ w_txt <- sapply(1:64, function(x) {
|
| 201 | -47x | +1230 | +320x |
- msum <- summary(mod, conf.int = control$conf_level)+ graphics::par(ps = x) |
| 202 | -47x | +1231 | +320x |
- sum_cox <- broom::tidy(msum)+ graphics::strwidth(w[4], units = "in") |
| 203 | +1232 |
-
+ })+ |
+ ||
| 1233 | +5x | +
+ f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]]) |
||
| 204 | +1234 |
- # Combine results together.+ |
||
| 205 | -47x | +1235 | +5x |
- effect_aov <- mod_aov[effect, , drop = TRUE]+ h_txt <- sapply(1:64, function(x) {
|
| 206 | -47x | +1236 | +320x |
- pval <- effect_aov[[grep(pattern = "Pr", x = names(effect_aov)), drop = TRUE]]+ graphics::par(ps = x) |
| 207 | -47x | +1237 | +320x |
- sum_main <- sum_cox[grepl(effect, sum_cox$level), ]+ graphics::strheight(grid::stringHeight("X"), units = "in")
|
| 208 | +1238 | ++ |
+ })+ |
+ |
| 1239 | +5x | +
+ f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))])+ |
+ ||
| 1240 | ||||
| 209 | -47x | +1241 | +5x |
- term_label <- if (effect == covar) {
+ if (ttheme$core$fg_params$fontsize == 12) {
|
| 210 | -25x | +1242 | +5x |
- paste0(+ ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h) |
| 211 | -25x | +1243 | +5x |
- levels(data[[covar]])[2],+ ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h) |
| 212 | -25x | +1244 | +5x |
- " vs control (",
+ ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ |
+
| 1245 | ++ |
+ }+ |
+ ||
| 1246 | ++ | + + | +||
| 1247 | +5x | +
+ gt <- gridExtra::tableGrob( |
||
| 213 | -25x | +1248 | +5x |
- levels(data[[covar]])[1],+ d = data, |
| 214 | -+ | |||
| 1249 | +5x |
- ")"+ theme = ttheme |
||
| 215 | +1250 |
- )+ ) |
||
| 216 | -+ | |||
| 1251 | +5x |
- } else {
+ gt$widths <- ((w_unit / sum(w_unit)) * width) |
||
| 217 | -22x | +1252 | +5x |
- unname(labels_or_names(data[covar]))+ gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt)) |
| 218 | +1253 |
- }+ |
||
| 219 | -47x | +1254 | +5x |
- data.frame(+ vp <- grid::viewport( |
| 220 | -47x | +1255 | +5x |
- effect = ifelse(covar == effect, "Treatment:", "Covariate:"),+ x = grid::unit(x, "npc") + grid::unit(1, "lines"), |
| 221 | -47x | +1256 | +5x |
- term = covar,+ y = grid::unit(y, "npc") + grid::unit(1.5, "lines"), |
| 222 | -47x | +1257 | +5x |
- term_label = term_label,+ height = height, |
| 223 | -47x | +1258 | +5x |
- level = levels(data[[effect]])[2],+ width = width, |
| 224 | -47x | +1259 | +5x |
- n = mod[["n"]],+ just = c("right", "top")
|
| 225 | -47x | +|||
| 1260 | +
- hr = unname(sum_main["exp(coef)"]),+ )+ |
+ |||
| 1261 | ++ | + | ||
| 226 | -47x | +1262 | +5x |
- lcl = unname(sum_main[grep("lower", names(sum_main))]),
+ grid::gList( |
| 227 | -47x | +1263 | +5x |
- ucl = unname(sum_main[grep("upper", names(sum_main))]),
+ grid::gTree( |
| 228 | -47x | +1264 | +5x |
- pval = pval,+ vp = vp, |
| 229 | -47x | +1265 | +5x |
- stringsAsFactors = FALSE+ children = grid::gList(gt) |
| 230 | +1266 | ++ |
+ )+ |
+ |
| 1267 |
) |
|||
| 231 | +1268 |
} |
||
| 232 | +1269 | |||
| 233 | +1270 |
- #' @describeIn h_cox_regression Tabulation of multivariate Cox regressions. Utility function to help+ #' Helper: Grid Object with y-axis Annotation |
||
| 234 | +1271 |
- #' tabulate the result of a multivariate Cox regression model for a treatment/covariate variable.+ #' |
||
| 235 | +1272 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 236 | +1273 |
- #' @return+ #' |
||
| 237 | +1274 |
- #' * `h_coxreg_multivar_extract()` returns a `data.frame` with variables `pval`, `hr`, `lcl`, `ucl`, `level`,+ #' Build the y-axis annotation from a decomposed `ggplot`. |
||
| 238 | +1275 |
- #' `n`, `term`, and `term_label`.+ #' |
||
| 239 | +1276 |
- #'+ #' @param ylab (`gtable`)\cr the y-lab as a graphical object derived from a `ggplot`. |
||
| 240 | +1277 |
- #' @examples+ #' @param yaxis (`gtable`)\cr the y-axis as a graphical object derived from a `ggplot`. |
||
| 241 | +1278 |
- #' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple)+ #' |
||
| 242 | +1279 |
- #' result <- h_coxreg_multivar_extract(+ #' @return a `gTree` object containing the y-axis annotation from a `ggplot`. |
||
| 243 | +1280 |
- #' var = "var1", mod = mod, data = dta_simple+ #' |
||
| 244 | +1281 |
- #' )+ #' @examples |
||
| 245 | +1282 |
- #' result+ #' \donttest{
|
||
| 246 | +1283 |
- #'+ #' library(dplyr) |
||
| 247 | +1284 |
- #' @export+ #' library(survival) |
||
| 248 | +1285 |
- h_coxreg_multivar_extract <- function(var,+ #' library(grid) |
||
| 249 | +1286 |
- data,+ #' |
||
| 250 | +1287 |
- mod,+ #' fit_km <- tern_ex_adtte %>% |
||
| 251 | +1288 |
- control = control_coxreg()) {
+ #' filter(PARAMCD == "OS") %>% |
||
| 252 | -76x | +|||
| 1289 | +
- test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) |
|||
| 253 | -76x | +|||
| 1290 | +
- mod_aov <- muffled_car_anova(mod, test_statistic)+ #' data_plot <- h_data_plot(fit_km = fit_km) |
|||
| 254 | +1291 |
-
+ #' xticks <- h_xticks(data = data_plot) |
||
| 255 | -76x | +|||
| 1292 | +
- msum <- summary(mod, conf.int = control$conf_level)+ #' gg <- h_ggkm( |
|||
| 256 | -76x | +|||
| 1293 | +
- sum_anova <- broom::tidy(mod_aov)+ #' data = data_plot, |
|||
| 257 | -76x | +|||
| 1294 | +
- sum_cox <- broom::tidy(msum)+ #' censor_show = TRUE, |
|||
| 258 | +1295 |
-
+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability", |
||
| 259 | -76x | +|||
| 1296 | +
- ret_anova <- sum_anova[sum_anova$term == var, c("term", "p.value")]
+ #' title = "title", footnotes = "footnotes", yval = "Survival" |
|||
| 260 | -76x | +|||
| 1297 | +
- names(ret_anova)[2] <- "pval"+ #' ) |
|||
| 261 | -76x | +|||
| 1298 | +
- if (is.factor(data[[var]])) {
+ #' |
|||
| 262 | -29x | +|||
| 1299 | +
- ret_cox <- sum_cox[startsWith(prefix = var, x = sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")]+ #' g_el <- h_decompose_gg(gg) |
|||
| 263 | +1300 |
- } else {
+ #' |
||
| 264 | -47x | +|||
| 1301 | +
- ret_cox <- sum_cox[(var == sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")]+ #' grid::grid.newpage() |
|||
| 265 | +1302 |
- }+ #' pvp <- grid::plotViewport(margins = c(5, 4, 2, 20)) |
||
| 266 | -76x | +|||
| 1303 | +
- names(ret_cox)[1:4] <- c("pval", "hr", "lcl", "ucl")
+ #' pushViewport(pvp) |
|||
| 267 | -76x | +|||
| 1304 | +
- varlab <- unname(labels_or_names(data[var]))+ #' grid::grid.draw(h_grob_y_annot(ylab = g_el$ylab, yaxis = g_el$yaxis)) |
|||
| 268 | -76x | +|||
| 1305 | +
- ret_cox$term <- varlab+ #' grid.rect(gp = grid::gpar(lty = 1, col = "gray35", fill = NA)) |
|||
| 269 | +1306 |
-
+ #' } |
||
| 270 | -76x | +|||
| 1307 | +
- if (is.numeric(data[[var]])) {
+ #' |
|||
| 271 | -47x | +|||
| 1308 | +
- ret <- ret_cox+ #' @export |
|||
| 272 | -47x | +|||
| 1309 | +
- ret$term_label <- ret$term+ h_grob_y_annot <- function(ylab, yaxis) {
|
|||
| 273 | -29x | +1310 | +6x |
- } else if (length(levels(data[[var]])) <= 2) {
+ grid::gList( |
| 274 | -18x | +1311 | +6x |
- ret_anova$pval <- NA+ grid::gTree( |
| 275 | -18x | +1312 | +6x |
- ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")")+ vp = grid::viewport( |
| 276 | -18x | +1313 | +6x |
- ret_cox$level <- gsub(var, "", ret_cox$level)+ width = grid::convertX(yaxis$width + ylab$width, "pt"), |
| 277 | -18x | +1314 | +6x |
- ret_cox$term_label <- ret_cox$level+ x = grid::unit(1, "npc"), |
| 278 | -18x | +1315 | +6x |
- ret <- dplyr::bind_rows(ret_anova, ret_cox)+ just = "right" |
| 279 | +1316 |
- } else {
- |
- ||
| 280 | -11x | -
- ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")")+ ), |
||
| 281 | -11x | +1317 | +6x |
- ret_cox$level <- gsub(var, "", ret_cox$level)+ children = grid::gList(cbind(ylab, yaxis)) |
| 282 | -11x | +|||
| 1318 | +
- ret_cox$term_label <- ret_cox$level+ ) |
|||
| 283 | -11x | +|||
| 1319 | +
- ret <- dplyr::bind_rows(ret_anova, ret_cox)+ ) |
|||
| 284 | +1320 |
- }+ } |
||
| 285 | +1321 | |||
| 286 | -76x | +|||
| 1322 | +
- as.data.frame(ret)+ #' Helper Function: Pairwise `CoxPH` table |
|||
| 287 | +1323 |
- }+ #' |
| 1 | +1324 |
- #' Defaults for statistical method names and their associated formats & labels+ #' @description `r lifecycle::badge("stable")`
|
||
| 2 | +1325 |
#' |
||
| 3 | +1326 |
- #' @description `r lifecycle::badge("experimental")`
+ #' Create a `data.frame` of pairwise stratified or unstratified `CoxPH` analysis results. |
||
| 4 | +1327 |
#' |
||
| 5 | +1328 |
- #' Utility functions to get valid statistic methods for different method groups+ #' @inheritParams g_km |
||
| 6 | +1329 |
- #' (`.stats`) and their associated formats (`.formats`) and labels (`.labels`). This utility+ #' |
||
| 7 | +1330 |
- #' is used across `tern`, but some of its working principles can be seen in [analyze_vars()].+ #' @return A `data.frame` containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`), |
||
| 8 | +1331 |
- #' See notes to understand why this is experimental.+ #' and `p-value (log-rank)`. |
||
| 9 | +1332 |
#' |
||
| 10 | +1333 |
- #' @param stats (`character`)\cr statistical methods to get defaults formats or labels for.+ #' @examples |
||
| 11 | +1334 |
- #'+ #' \donttest{
|
||
| 12 | +1335 |
- #' @details+ #' library(dplyr) |
||
| 13 | +1336 |
- #' Current choices for `type` are `counts` and `numeric` for [analyze_vars()] and affect `get_stats()`.+ #' |
||
| 14 | +1337 |
- #'+ #' adtte <- tern_ex_adtte %>% |
||
| 15 | +1338 |
- #' @note+ #' filter(PARAMCD == "OS") %>% |
||
| 16 | +1339 |
- #' These defaults are experimental because we use the names of functions to retrieve the default+ #' mutate(is_event = CNSR == 0) |
||
| 17 | +1340 |
- #' statistics. This should be generalized in groups of methods according to more reasonable groupings.+ #' |
||
| 18 | +1341 |
- #'+ #' h_tbl_coxph_pairwise( |
||
| 19 | +1342 |
- #' @name default_stats_formats_labels+ #' df = adtte, |
||
| 20 | +1343 |
- NULL+ #' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARM"), |
||
| 21 | +1344 |
-
+ #' control_coxph_pw = control_coxph(conf_level = 0.9) |
||
| 22 | +1345 |
- #' @describeIn default_stats_formats_labels Get defaults statistical methods for different+ #' ) |
||
| 23 | +1346 |
- #' groups of methods.+ #' } |
||
| 24 | +1347 |
#' |
||
| 25 | +1348 |
- #' @param method_groups (`character`)\cr indicates the group of statistical methods that+ #' @export |
||
| 26 | +1349 |
- #' we need the defaults from. A character vector can be used to collect more than one group of statistical+ h_tbl_coxph_pairwise <- function(df, |
||
| 27 | +1350 |
- #' methods.+ variables, |
||
| 28 | +1351 |
- #' @param stats_in (`character`)\cr desired stats to be picked out from the selected method group.+ control_coxph_pw = control_coxph()) {
|
||
| 29 | -+ | |||
| 1352 | +3x |
- #' @param add_pval (`flag`)\cr should `"pval"` or `"pval_counts"` (if `method_groups` contains+ assert_df_with_variables(df, variables) |
||
| 30 | -+ | |||
| 1353 | +3x |
- #' `"analyze_vars_counts"`) be added to the statistical methods?+ arm <- variables$arm |
||
| 31 | -+ | |||
| 1354 | +3x |
- #'+ df[[arm]] <- factor(df[[arm]]) |
||
| 32 | -+ | |||
| 1355 | +3x |
- #' @return+ ref_group <- levels(df[[arm]])[1] |
||
| 33 | -+ | |||
| 1356 | +3x |
- #' * `get_stats()` returns a character vector with all default statistical methods.+ comp_group <- levels(df[[arm]])[-1] |
||
| 34 | -+ | |||
| 1357 | +3x |
- #'+ results <- Map(function(comp) {
|
||
| 35 | -+ | |||
| 1358 | +6x |
- #' @examples+ res <- s_coxph_pairwise( |
||
| 36 | -+ | |||
| 1359 | +6x |
- #' # analyze_vars is numeric+ df = df[df[[arm]] == comp, , drop = FALSE], |
||
| 37 | -+ | |||
| 1360 | +6x |
- #' num_stats <- get_stats("analyze_vars_numeric") # also the default
+ .ref_group = df[df[[arm]] == ref_group, , drop = FALSE], |
||
| 38 | -+ | |||
| 1361 | +6x |
- #'+ .in_ref_col = FALSE, |
||
| 39 | -+ | |||
| 1362 | +6x |
- #' # Other type+ .var = variables$tte, |
||
| 40 | -+ | |||
| 1363 | +6x |
- #' cnt_stats <- get_stats("analyze_vars_counts")
+ is_event = variables$is_event, |
||
| 41 | -+ | |||
| 1364 | +6x |
- #'+ strat = variables$strat, |
||
| 42 | -+ | |||
| 1365 | +6x |
- #' # Weirdly taking the pval from count_occurrences+ control = control_coxph_pw |
||
| 43 | +1366 |
- #' only_pval <- get_stats("count_occurrences", add_pval = TRUE, stats_in = "pval")
+ ) |
||
| 44 | -+ | |||
| 1367 | +6x |
- #'+ res_df <- data.frame(+ |
+ ||
| 1368 | +6x | +
+ hr = format(round(res$hr, 2), nsmall = 2),+ |
+ ||
| 1369 | +6x | +
+ hr_ci = paste0(+ |
+ ||
| 1370 | +6x | +
+ "(", format(round(res$hr_ci[1], 2), nsmall = 2), ", ",
+ |
+ ||
| 1371 | +6x | +
+ format(round(res$hr_ci[2], 2), nsmall = 2), ")" |
||
| 45 | +1372 |
- #' # All count_occurrences+ ),+ |
+ ||
| 1373 | +6x | +
+ pvalue = if (res$pvalue < 0.0001) "<0.0001" else format(round(res$pvalue, 4), 4),+ |
+ ||
| 1374 | +6x | +
+ stringsAsFactors = FALSE |
||
| 46 | +1375 |
- #' all_cnt_occ <- get_stats("count_occurrences")
+ )+ |
+ ||
| 1376 | +6x | +
+ colnames(res_df) <- c("HR", vapply(res[c("hr_ci", "pvalue")], obj_label, FUN.VALUE = "character"))
+ |
+ ||
| 1377 | +6x | +
+ row.names(res_df) <- comp+ |
+ ||
| 1378 | +6x | +
+ res_df+ |
+ ||
| 1379 | +3x | +
+ }, comp_group)+ |
+ ||
| 1380 | +3x | +
+ do.call(rbind, results) |
||
| 47 | +1381 |
- #'+ } |
||
| 48 | +1382 |
- #' # Multiple+ |
||
| 49 | +1383 |
- #' get_stats(c("count_occurrences", "analyze_vars_counts"))
+ #' Helper Function: `CoxPH` Grob |
||
| 50 | +1384 |
#' |
||
| 51 | +1385 |
- #' @export+ #' @description `r lifecycle::badge("stable")`
|
||
| 52 | +1386 |
- get_stats <- function(method_groups = "analyze_vars_numeric", stats_in = NULL, add_pval = FALSE) {
+ #' |
||
| 53 | -321x | +|||
| 1387 | +
- checkmate::assert_character(method_groups)+ #' Grob of `rtable` output from [h_tbl_coxph_pairwise()] |
|||
| 54 | -321x | +|||
| 1388 | +
- checkmate::assert_character(stats_in, null.ok = TRUE)+ #' |
|||
| 55 | -321x | +|||
| 1389 | +
- checkmate::assert_flag(add_pval)+ #' @inheritParams h_grob_median_surv |
|||
| 56 | +1390 |
-
+ #' @param ... arguments will be passed to [h_tbl_coxph_pairwise()]. |
||
| 57 | +1391 |
- # Default is still numeric+ #' @param x (`numeric`)\cr a value between 0 and 1 specifying x-location. |
||
| 58 | -321x | +|||
| 1392 | +
- if (any(method_groups == "analyze_vars")) {
+ #' @param y (`numeric`)\cr a value between 0 and 1 specifying y-location. |
|||
| 59 | -2x | +|||
| 1393 | +
- method_groups[method_groups == "analyze_vars"] <- "analyze_vars_numeric"+ #' @param width (`unit`)\cr width (as a unit) to use when printing the grob. |
|||
| 60 | +1394 |
- }+ #' |
||
| 61 | +1395 |
-
+ #' @return A `grob` of a table containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`), |
||
| 62 | -321x | +|||
| 1396 | +
- type_tmp <- ifelse(any(grepl("counts", method_groups)), "counts", "numeric") # for pval checks
+ #' and `p-value (log-rank)`. |
|||
| 63 | +1397 |
-
+ #' |
||
| 64 | +1398 |
- # Defaults for loop+ #' @examples |
||
| 65 | -321x | +|||
| 1399 | +
- out <- NULL+ #' \donttest{
|
|||
| 66 | +1400 |
-
+ #' library(dplyr) |
||
| 67 | +1401 |
- # Loop for multiple method groups+ #' library(survival) |
||
| 68 | -321x | +|||
| 1402 | +
- for (mgi in method_groups) {
+ #' library(grid) |
|||
| 69 | +1403 |
- # Main switcher+ #' |
||
| 70 | -331x | +|||
| 1404 | +
- out_tmp <- switch(mgi,+ #' grid::grid.newpage() |
|||
| 71 | -331x | +|||
| 1405 | +
- "count_occurrences" = c("count", "count_fraction_fixed_dp", "fraction"),
+ #' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1)) |
|||
| 72 | -331x | +|||
| 1406 | +
- "summarize_num_patients" = c("unique", "nonunique", "unique_count"),
+ #' data <- tern_ex_adtte %>% |
|||
| 73 | -331x | +|||
| 1407 | +
- "analyze_vars_counts" = c("n", "count", "count_fraction", "n_blq"),
+ #' filter(PARAMCD == "OS") %>% |
|||
| 74 | -331x | +|||
| 1408 | +
- "analyze_vars_numeric" = c(+ #' mutate(is_event = CNSR == 0) |
|||
| 75 | -331x | +|||
| 1409 | +
- "n", "sum", "mean", "sd", "se", "mean_sd", "mean_se", "mean_ci", "mean_sei",+ #' tbl_grob <- h_grob_coxph( |
|||
| 76 | -331x | +|||
| 1410 | +
- "mean_sdi", "mean_pval", "median", "mad", "median_ci", "quantiles", "iqr",+ #' df = data, |
|||
| 77 | -331x | +|||
| 1411 | +
- "range", "min", "max", "median_range", "cv", "geom_mean", "geom_mean_ci",+ #' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARMCD"), |
|||
| 78 | -331x | +|||
| 1412 | +
- "geom_cv"+ #' control_coxph_pw = control_coxph(conf_level = 0.9), x = 0.5, y = 0.5 |
|||
| 79 | +1413 |
- ),+ #' ) |
||
| 80 | -331x | +|||
| 1414 | +
- stop(+ #' grid::grid.draw(tbl_grob) |
|||
| 81 | -331x | +|||
| 1415 | +
- "The selected method group (", mgi, ") has no default statistical method."
+ #' } |
|||
| 82 | +1416 |
- )+ #' |
||
| 83 | +1417 |
- )+ #' @export |
||
| 84 | -331x | +|||
| 1418 | +
- out <- unique(c(out, out_tmp))+ h_grob_coxph <- function(..., |
|||
| 85 | +1419 |
- }+ x = 0, |
||
| 86 | +1420 |
-
+ y = 0, |
||
| 87 | +1421 |
- # If you added pval to the stats_in you certainly want it+ width = grid::unit(0.4, "npc"), |
||
| 88 | -321x | +|||
| 1422 | +
- if (!is.null(stats_in) && any(grepl("^pval", stats_in))) {
+ ttheme = gridExtra::ttheme_default( |
|||
| 89 | -21x | +|||
| 1423 | +
- stats_in_pval_value <- stats_in[grepl("^pval", stats_in)]
+ padding = grid::unit(c(1, .5), "lines"), |
|||
| 90 | +1424 |
-
+ core = list(bg_params = list(fill = c("grey95", "grey90"), alpha = .5))
|
||
| 91 | +1425 |
- # Must be only one value between choices+ )) {
|
||
| 92 | -21x | +1426 | +2x |
- checkmate::assert_choice(stats_in_pval_value, c("pval", "pval_counts"))
+ data <- h_tbl_coxph_pairwise(...) |
| 93 | +1427 | |||
| 94 | -- |
- # Mismatch with counts and numeric- |
- ||
| 95 | -20x | +1428 | +2x |
- if (any(grepl("counts", method_groups)) && stats_in_pval_value != "pval_counts" ||
+ width <- grid::convertUnit(width, "in") |
| 96 | -20x | +1429 | +2x |
- any(grepl("numeric", method_groups)) && stats_in_pval_value != "pval") {
+ height <- width * (nrow(data) + 1) / 12 |
| 97 | -2x | +|||
| 1430 | +
- stop(+ |
|||
| 98 | +1431 | 2x |
- "Inserted p-value (", stats_in_pval_value, ") is not valid for type ",
+ w <- paste(" ", c(
|
|
| 99 | +1432 | 2x |
- type_tmp, ". Use ", paste(ifelse(stats_in_pval_value == "pval", "pval_counts", "pval")),+ rownames(data)[which.max(nchar(rownames(data)))], |
|
| 100 | +1433 | 2x |
- " instead."+ sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))]) |
|
| 101 | +1434 |
- )+ )) |
||
| 102 | -+ | |||
| 1435 | +2x |
- }+ w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE) |
||
| 103 | +1436 | |||
| 104 | -+ | |||
| 1437 | +2x |
- # Lets add it even if present (thanks to unique)+ w_txt <- sapply(1:64, function(x) {
|
||
| 105 | -18x | +1438 | +128x |
- add_pval <- TRUE+ graphics::par(ps = x) |
| 106 | -+ | |||
| 1439 | +128x |
- }+ graphics::strwidth(w[4], units = "in") |
||
| 107 | +1440 |
-
+ })+ |
+ ||
| 1441 | +2x | +
+ f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]]) |
||
| 108 | +1442 |
- # Mainly used in "analyze_vars" but it could be necessary elsewhere+ |
||
| 109 | -318x | +1443 | +2x |
- if (isTRUE(add_pval)) {
+ h_txt <- sapply(1:64, function(x) {
|
| 110 | -22x | +1444 | +128x |
- if (any(grepl("counts", method_groups))) {
+ graphics::par(ps = x) |
| 111 | -10x | +1445 | +128x |
- out <- unique(c(out, "pval_counts"))+ graphics::strheight(grid::stringHeight("X"), units = "in")
|
| 112 | +1446 |
- } else {
+ }) |
||
| 113 | -12x | -
- out <- unique(c(out, "pval"))- |
- ||
| 114 | -+ | 1447 | +2x |
- }+ f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))]) |
| 115 | +1448 |
- }+ |
||
| 116 | -+ | |||
| 1449 | +2x |
-
+ if (ttheme$core$fg_params$fontsize == 12) {
|
||
| 117 | -+ | |||
| 1450 | +2x |
- # Filtering for stats_in (character vector)+ ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h) |
||
| 118 | -318x | +1451 | +2x |
- if (!is.null(stats_in)) {
+ ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h) |
| 119 | -304x | +1452 | +2x |
- out <- intersect(stats_in, out) # It orders them too+ ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h) |
| 120 | +1453 |
} |
||
| 121 | +1454 | |||
| 122 | -+ | |||
| 1455 | +2x |
- # If intersect did not find matches (and no pval?) -> error+ tryCatch( |
||
| 123 | -318x | +1456 | +2x |
- if (length(out) == 0) {
+ expr = {
|
| 124 | +1457 | 2x |
- stop(+ gt <- gridExtra::tableGrob( |
|
| 125 | +1458 | 2x |
- "The selected method group(s) (", paste0(method_groups, collapse = ", "), ")",
+ d = data, |
|
| 126 | +1459 | 2x |
- " do not have the required default statistical methods:\n",+ theme = ttheme |
|
| 127 | +1460 | 2x |
- paste0(stats_in, collapse = " ")+ ) # ERROR 'data' must be of a vector type, was 'NULL' |
|
| 128 | -+ | |||
| 1461 | +2x |
- )+ gt$widths <- ((w_unit / sum(w_unit)) * width) |
||
| 129 | -+ | |||
| 1462 | +2x |
- }+ gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt)) |
||
| 130 | -+ | |||
| 1463 | +2x |
-
+ vp <- grid::viewport( |
||
| 131 | -316x | +1464 | +2x |
- out+ x = grid::unit(x, "npc") + grid::unit(1, "lines"), |
| 132 | -+ | |||
| 1465 | +2x |
- }+ y = grid::unit(y, "npc") + grid::unit(1.5, "lines"), |
||
| 133 | -+ | |||
| 1466 | +2x |
-
+ height = height, |
||
| 134 | -+ | |||
| 1467 | +2x |
- #' @describeIn default_stats_formats_labels Get formats from vector of statistical methods. If not+ width = width, |
||
| 135 | -+ | |||
| 1468 | +2x |
- #' present `NULL` is returned.+ just = c("left", "bottom")
|
||
| 136 | +1469 |
- #'+ ) |
||
| 137 | -+ | |||
| 1470 | +2x |
- #' @param formats_in (named `vector`) \cr inserted formats to replace defaults. It can be a+ grid::gList( |
||
| 138 | -+ | |||
| 1471 | +2x |
- #' character vector from [formatters::list_valid_format_labels()] or a custom format function.+ grid::gTree( |
||
| 139 | -+ | |||
| 1472 | +2x |
- #'+ vp = vp, |
||
| 140 | -+ | |||
| 1473 | +2x |
- #' @return+ children = grid::gList(gt) |
||
| 141 | +1474 |
- #' * `get_formats_from_stats()` returns a named list of formats, they being a value from+ ) |
||
| 142 | +1475 |
- #' [formatters::list_valid_format_labels()] or a custom function (e.g. [formatting_functions]).+ ) |
||
| 143 | +1476 |
- #'+ }, |
||
| 144 | -+ | |||
| 1477 | +2x |
- #' @note Formats in `tern` and `rtables` can be functions that take in the table cell value and+ error = function(w) {
|
||
| 145 | -+ | |||
| 1478 | +! |
- #' return a string. This is well documented in `vignette("custom_appearance", package = "rtables")`.
+ message(paste( |
||
| 146 | -+ | |||
| 1479 | +! |
- #'+ "Warning: Cox table will not be displayed as there is", |
||
| 147 | -+ | |||
| 1480 | +! |
- #' @examples+ "not any level to be compared in the arm variable." |
||
| 148 | +1481 |
- #' # Defaults formats+ )) |
||
| 149 | -+ | |||
| 1482 | +! |
- #' get_formats_from_stats(num_stats)+ return( |
||
| 150 | -+ | |||
| 1483 | +! |
- #' get_formats_from_stats(cnt_stats)+ grid::gList( |
||
| 151 | -+ | |||
| 1484 | +! |
- #' get_formats_from_stats(only_pval)+ grid::gTree( |
||
| 152 | -+ | |||
| 1485 | +! |
- #' get_formats_from_stats(all_cnt_occ)+ vp = NULL, |
||
| 153 | -+ | |||
| 1486 | +! |
- #'+ children = NULL |
||
| 154 | +1487 |
- #' # Addition of customs+ ) |
||
| 155 | +1488 |
- #' get_formats_from_stats(all_cnt_occ, formats_in = c("fraction" = c("xx")))
+ ) |
||
| 156 | +1489 |
- #' get_formats_from_stats(all_cnt_occ, formats_in = list("fraction" = c("xx.xx", "xx")))
+ ) |
||
| 157 | +1490 |
- #'+ } |
||
| 158 | +1491 |
- #' @seealso [formatting_functions]+ ) |
||
| 159 | +1492 |
- #'+ } |
| 160 | +1 |
- #' @export+ #' Add Titles, Footnotes, Page Number, and a Bounding Box to a Grid Grob |
||
| 161 | +2 |
- get_formats_from_stats <- function(stats, formats_in = NULL) {
- |
- ||
| 162 | -322x | -
- checkmate::assert_character(stats, min.len = 1)+ #' |
||
| 163 | +3 |
- # It may be a list if there is a function in the formats- |
- ||
| 164 | -322x | -
- if (checkmate::test_list(formats_in, null.ok = TRUE)) {
- |
- ||
| 165 | -279x | -
- checkmate::assert_list(formats_in, null.ok = TRUE)+ #' @description `r lifecycle::badge("stable")`
|
||
| 166 | +4 |
- # Or it may be a vector of characters+ #' |
||
| 167 | +5 |
- } else {
- |
- ||
| 168 | -43x | -
- checkmate::assert_character(formats_in, null.ok = TRUE)+ #' This function is useful to label grid grobs (also `ggplot2`, and `lattice` plots) |
||
| 169 | +6 |
- }+ #' with title, footnote, and page numbers. |
||
| 170 | +7 |
-
+ #' |
||
| 171 | +8 |
- # Extract global defaults- |
- ||
| 172 | -322x | -
- which_fmt <- match(stats, names(tern_default_formats))+ #' @inheritParams grid::grob |
||
| 173 | +9 |
-
+ #' @param grob a grid grob object, optionally `NULL` if only a `grob` with the decoration should be shown. |
||
| 174 | +10 |
- # Select only needed formats from stats- |
- ||
| 175 | -322x | -
- ret <- vector("list", length = length(stats)) # Returning a list is simpler
- |
- ||
| 176 | -322x | -
- ret[!is.na(which_fmt)] <- tern_default_formats[which_fmt[!is.na(which_fmt)]]+ #' @param titles vector of character strings. Vector elements are separated by a newline and strings are wrapped |
||
| 177 | +11 | - - | -||
| 178 | -322x | -
- out <- setNames(ret, stats)+ #' according to the page width. |
||
| 179 | +12 |
-
+ #' @param footnotes vector of character string. Same rules as for `titles`. |
||
| 180 | +13 |
- # Modify some with custom formats- |
- ||
| 181 | -322x | -
- if (!is.null(formats_in)) {
+ #' @param page string with page numeration, if `NULL` then no page number is displayed. |
||
| 182 | +14 |
- # Stats is the main- |
- ||
| 183 | -45x | -
- common_names <- intersect(names(out), names(formats_in))- |
- ||
| 184 | -45x | -
- out[common_names] <- formats_in[common_names]+ #' @param width_titles unit object |
||
| 185 | +15 |
- }+ #' @param width_footnotes unit object |
||
| 186 | +16 | - - | -||
| 187 | -322x | -
- out+ #' @param border boolean, whether a a border should be drawn around the plot or not. |
||
| 188 | +17 |
- }+ #' @param margins unit object of length 4 |
||
| 189 | +18 |
-
+ #' @param padding unit object of length 4 |
||
| 190 | +19 |
- #' @describeIn default_stats_formats_labels Get labels from vector of statistical methods.+ #' @param outer_margins unit object of length 4 |
||
| 191 | +20 |
- #'+ #' @param gp_titles a `gpar` object |
||
| 192 | +21 |
- #' @param labels_in (named `vector`) \cr inserted labels to replace defaults.+ #' @param gp_footnotes a `gpar` object |
||
| 193 | +22 |
#' |
||
| 194 | +23 |
- #' @return+ #' @return A grid grob (`gTree`). |
||
| 195 | +24 |
- #' * `get_labels_from_stats()` returns a named character vector of default labels (if present+ #' |
||
| 196 | +25 |
- #' otherwise `NULL`).+ #' @details The titles and footnotes will be ragged, i.e. each title will be wrapped individually. |
||
| 197 | +26 |
#' |
||
| 198 | +27 |
#' @examples |
||
| 199 | +28 |
- #' # Defaults labels+ #' library(grid) |
||
| 200 | +29 |
- #' get_labels_from_stats(num_stats)+ #' |
||
| 201 | +30 |
- #' get_labels_from_stats(cnt_stats)+ #' titles <- c( |
||
| 202 | +31 |
- #' get_labels_from_stats(only_pval)+ #' "Edgar Anderson's Iris Data", |
||
| 203 | +32 |
- #' get_labels_from_stats(all_cnt_occ)+ #' paste( |
||
| 204 | +33 |
- #'+ #' "This famous (Fisher's or Anderson's) iris data set gives the measurements", |
||
| 205 | +34 |
- #' # Addition of customs+ #' "in centimeters of the variables sepal length and width and petal length", |
||
| 206 | +35 |
- #' get_labels_from_stats(all_cnt_occ, labels_in = c("fraction" = "Fraction"))
+ #' "and width, respectively, for 50 flowers from each of 3 species of iris." |
||
| 207 | +36 |
- #' get_labels_from_stats(all_cnt_occ, labels_in = list("fraction" = c("Some more fractions")))
+ #' ) |
||
| 208 | +37 |
- #'+ #' ) |
||
| 209 | +38 |
- #' @export+ #' |
||
| 210 | +39 |
- get_labels_from_stats <- function(stats, labels_in = NULL) {
- |
- ||
| 211 | -375x | -
- checkmate::assert_character(stats, min.len = 1)+ #' footnotes <- c( |
||
| 212 | +40 |
- # It may be a list- |
- ||
| 213 | -375x | -
- if (checkmate::test_list(labels_in, null.ok = TRUE)) {
- |
- ||
| 214 | -324x | -
- checkmate::assert_list(labels_in, null.ok = TRUE)+ #' "The species are Iris setosa, versicolor, and virginica.", |
||
| 215 | +41 |
- # Or it may be a vector of characters+ #' paste( |
||
| 216 | +42 |
- } else {
- |
- ||
| 217 | -51x | -
- checkmate::assert_character(labels_in, null.ok = TRUE)+ #' "iris is a data frame with 150 cases (rows) and 5 variables (columns) named", |
||
| 218 | +43 |
- }+ #' "Sepal.Length, Sepal.Width, Petal.Length, Petal.Width, and Species." |
||
| 219 | +44 | - - | -||
| 220 | -375x | -
- which_lbl <- match(stats, names(tern_default_labels))+ #' ) |
||
| 221 | +45 |
-
+ #' ) |
||
| 222 | -375x | +|||
| 46 | +
- ret <- vector("character", length = length(stats)) # it needs to be a character vector
+ #' |
|||
| 223 | -375x | +|||
| 47 | +
- ret[!is.na(which_lbl)] <- tern_default_labels[which_lbl[!is.na(which_lbl)]]+ #' ## empty plot |
|||
| 224 | +48 |
-
+ #' grid.newpage() |
||
| 225 | -375x | +|||
| 49 | +
- out <- setNames(ret, stats)+ #' |
|||
| 226 | +50 |
-
+ #' grid.draw( |
||
| 227 | +51 |
- # Modify some with custom labels+ #' decorate_grob( |
||
| 228 | -375x | +|||
| 52 | +
- if (!is.null(labels_in)) {
+ #' NULL, |
|||
| 229 | +53 |
- # Stats is the main+ #' titles = titles, |
||
| 230 | -51x | +|||
| 54 | +
- common_names <- intersect(names(out), names(labels_in))+ #' footnotes = footnotes, |
|||
| 231 | -51x | +|||
| 55 | +
- out[common_names] <- labels_in[common_names]+ #' page = "Page 4 of 10" |
|||
| 232 | +56 |
- }+ #' ) |
||
| 233 | +57 |
-
+ #' ) |
||
| 234 | -375x | +|||
| 58 | +
- out+ #' |
|||
| 235 | +59 |
- }+ #' # grid |
||
| 236 | +60 |
-
+ #' p <- gTree( |
||
| 237 | +61 |
- #' @describeIn default_stats_formats_labels Named list of default formats for `tern`.+ #' children = gList( |
||
| 238 | +62 |
- #' @format+ #' rectGrob(), |
||
| 239 | +63 |
- #' * `tern_default_formats` is a list of available formats, named after their relevant+ #' xaxisGrob(), |
||
| 240 | +64 |
- #' statistic.+ #' yaxisGrob(), |
||
| 241 | +65 |
- #' @export+ #' textGrob("Sepal.Length", y = unit(-4, "lines")),
|
||
| 242 | +66 |
- tern_default_formats <- c(+ #' textGrob("Petal.Length", x = unit(-3.5, "lines"), rot = 90),
|
||
| 243 | +67 |
- fraction = format_fraction_fixed_dp,+ #' pointsGrob(iris$Sepal.Length, iris$Petal.Length, gp = gpar(col = iris$Species), pch = 16) |
||
| 244 | +68 |
- unique = format_count_fraction_fixed_dp,+ #' ), |
||
| 245 | +69 |
- nonunique = "xx",+ #' vp = vpStack(plotViewport(), dataViewport(xData = iris$Sepal.Length, yData = iris$Petal.Length)) |
||
| 246 | +70 |
- unique_count = "xx",+ #' ) |
||
| 247 | +71 |
- n = "xx.",+ #' grid.newpage() |
||
| 248 | +72 |
- count = "xx.",+ #' grid.draw(p) |
||
| 249 | +73 |
- count_fraction = format_count_fraction,+ #' |
||
| 250 | +74 |
- count_fraction_fixed_dp = format_count_fraction_fixed_dp,+ #' grid.newpage() |
||
| 251 | +75 |
- n_blq = "xx.",+ #' grid.draw( |
||
| 252 | +76 |
- sum = "xx.x",+ #' decorate_grob( |
||
| 253 | +77 |
- mean = "xx.x",+ #' grob = p, |
||
| 254 | +78 |
- sd = "xx.x",+ #' titles = titles, |
||
| 255 | +79 |
- se = "xx.x",+ #' footnotes = footnotes, |
||
| 256 | +80 |
- mean_sd = "xx.x (xx.x)",+ #' page = "Page 6 of 129" |
||
| 257 | +81 |
- mean_se = "xx.x (xx.x)",+ #' ) |
||
| 258 | +82 |
- mean_ci = "(xx.xx, xx.xx)",+ #' ) |
||
| 259 | +83 |
- mean_sei = "(xx.xx, xx.xx)",+ #' |
||
| 260 | +84 |
- mean_sdi = "(xx.xx, xx.xx)",+ #' ## with ggplot2 |
||
| 261 | +85 |
- mean_pval = "xx.xx",+ #' library(ggplot2) |
||
| 262 | +86 |
- median = "xx.x",+ #' |
||
| 263 | +87 |
- mad = "xx.x",+ #' p_gg <- ggplot2::ggplot(iris, aes(Sepal.Length, Sepal.Width, col = Species)) + |
||
| 264 | +88 |
- median_ci = "(xx.xx, xx.xx)",+ #' ggplot2::geom_point() |
||
| 265 | +89 |
- quantiles = "xx.x - xx.x",+ #' p_gg |
||
| 266 | +90 |
- iqr = "xx.x",+ #' p <- ggplotGrob(p_gg) |
||
| 267 | +91 |
- range = "xx.x - xx.x",+ #' grid.newpage() |
||
| 268 | +92 |
- min = "xx.x",+ #' grid.draw( |
||
| 269 | +93 |
- max = "xx.x",+ #' decorate_grob( |
||
| 270 | +94 |
- median_range = "xx.x (xx.x - xx.x)",+ #' grob = p, |
||
| 271 | +95 |
- cv = "xx.x",+ #' titles = titles, |
||
| 272 | +96 |
- geom_mean = "xx.x",+ #' footnotes = footnotes, |
||
| 273 | +97 |
- geom_mean_ci = "(xx.xx, xx.xx)",+ #' page = "Page 6 of 129" |
||
| 274 | +98 |
- geom_cv = "xx.x",+ #' ) |
||
| 275 | +99 |
- pval = "x.xxxx | (<0.0001)",+ #' ) |
||
| 276 | +100 |
- pval_counts = "x.xxxx | (<0.0001)"+ #' |
||
| 277 | +101 |
- )+ #' ## with lattice |
||
| 278 | +102 |
-
+ #' library(lattice) |
||
| 279 | +103 |
- #' @describeIn default_stats_formats_labels `character` vector that contains default labels+ #' |
||
| 280 | +104 |
- #' for `tern`.+ #' xyplot(Sepal.Length ~ Petal.Length, data = iris, col = iris$Species) |
||
| 281 | +105 |
- #' @format+ #' p <- grid.grab() |
||
| 282 | +106 |
- #' * `tern_default_labels` is a character vector of available labels, named after their relevant+ #' grid.newpage() |
||
| 283 | +107 |
- #' statistic.+ #' grid.draw( |
||
| 284 | +108 |
- #' @export+ #' decorate_grob( |
||
| 285 | +109 |
- tern_default_labels <- c(+ #' grob = p, |
||
| 286 | +110 |
- # list of labels -> sorted? xxx it should be not relevant due to match+ #' titles = titles, |
||
| 287 | +111 |
- unique = "Number of patients with at least one event",+ #' footnotes = footnotes, |
||
| 288 | +112 |
- nonunique = "Number of events",+ #' page = "Page 6 of 129" |
||
| 289 | +113 |
- n = "n",+ #' ) |
||
| 290 | +114 |
- count = "count",+ #' ) |
||
| 291 | +115 |
- count_fraction = "count_fraction",+ #' |
||
| 292 | +116 |
- n_blq = "n_blq",+ #' # with gridExtra - no borders |
||
| 293 | +117 |
- sum = "Sum",+ #' library(gridExtra) |
||
| 294 | +118 |
- mean = "Mean",+ #' grid.newpage() |
||
| 295 | +119 |
- sd = "SD",+ #' grid.draw( |
||
| 296 | +120 |
- se = "SE",+ #' decorate_grob( |
||
| 297 | +121 |
- mean_sd = "Mean (SD)",+ #' tableGrob( |
||
| 298 | +122 |
- mean_se = "Mean (SE)",+ #' head(mtcars) |
||
| 299 | +123 |
- mean_ci = "Mean 95% CI",+ #' ), |
||
| 300 | +124 |
- mean_sei = "Mean -/+ 1xSE",+ #' titles = "title", |
||
| 301 | +125 |
- mean_sdi = "Mean -/+ 1xSD",+ #' footnotes = "footnote", |
||
| 302 | +126 |
- mean_pval = "Mean p-value (H0: mean = 0)",+ #' border = FALSE |
||
| 303 | +127 |
- median = "Median",+ #' ) |
||
| 304 | +128 |
- mad = "Median Absolute Deviation",+ #' ) |
||
| 305 | +129 |
- median_ci = "Median 95% CI",+ #' |
||
| 306 | +130 |
- quantiles = "25% and 75%-ile",+ #' @export |
||
| 307 | +131 |
- iqr = "IQR",+ decorate_grob <- function(grob, |
||
| 308 | +132 |
- range = "Min - Max",+ titles, |
||
| 309 | +133 |
- min = "Minimum",+ footnotes, |
||
| 310 | +134 |
- max = "Maximum",+ page = "", |
||
| 311 | +135 |
- median_range = "Median (Min - Max)",+ width_titles = grid::unit(1, "npc") - grid::stringWidth(page), |
||
| 312 | +136 |
- cv = "CV (%)",+ width_footnotes = grid::unit(1, "npc") - grid::stringWidth(page), |
||
| 313 | +137 |
- geom_mean = "Geometric Mean",+ border = TRUE, |
||
| 314 | +138 |
- geom_mean_ci = "Geometric Mean 95% CI",+ margins = grid::unit(c(1, 0, 1, 0), "lines"), |
||
| 315 | +139 |
- geom_cv = "CV % Geometric Mean",+ padding = grid::unit(rep(1, 4), "lines"), |
||
| 316 | +140 |
- pval = "p-value (t-test)", # Default for numeric+ outer_margins = grid::unit(c(2, 1.5, 3, 1.5), "cm"), |
||
| 317 | +141 |
- pval_counts = "p-value (chi-squared test)" # Default for counts+ gp_titles = grid::gpar(), |
||
| 318 | +142 |
- )+ gp_footnotes = grid::gpar(fontsize = 8), |
||
| 319 | +143 |
-
+ name = NULL, |
||
| 320 | +144 |
- # To deprecate ---------+ gp = grid::gpar(), |
||
| 321 | +145 |
-
+ vp = NULL) {
|
||
| 322 | -+ | |||
| 146 | +8x |
- #' @describeIn default_stats_formats_labels Quick function to retrieve default formats for summary statistics:+ st_titles <- split_text_grob( |
||
| 323 | -+ | |||
| 147 | +8x |
- #' [analyze_vars()] and [analyze_vars_in_cols()] principally.+ titles, |
||
| 324 | -+ | |||
| 148 | +8x |
- #'+ x = 0, y = 1, |
||
| 325 | -+ | |||
| 149 | +8x |
- #' @param type (`flag`)\cr is it going to be `"numeric"` or `"counts"`?+ just = c("left", "top"),
|
||
| 326 | -+ | |||
| 150 | +8x |
- #'+ width = width_titles, |
||
| 327 | -+ | |||
| 151 | +8x |
- #' @return+ vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 1), |
||
| 328 | -+ | |||
| 152 | +8x |
- #' * `summary_formats()` returns a named `vector` of default statistic formats for the given data type.+ gp = gp_titles |
||
| 329 | +153 |
- #'+ ) |
||
| 330 | +154 |
- #' @examples+ |
||
| 331 | -+ | |||
| 155 | +8x |
- #' summary_formats()+ st_footnotes <- split_text_grob( |
||
| 332 | -+ | |||
| 156 | +8x |
- #' summary_formats(type = "counts", include_pval = TRUE)+ footnotes, |
||
| 333 | -+ | |||
| 157 | +8x |
- #'+ x = 0, y = 1, |
||
| 334 | -+ | |||
| 158 | +8x |
- #' @export+ just = c("left", "top"),
|
||
| 335 | -+ | |||
| 159 | +8x |
- summary_formats <- function(type = "numeric", include_pval = FALSE) {
+ width = width_footnotes, |
||
| 336 | -2x | +160 | +8x |
- met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ vp = grid::viewport(layout.pos.row = 3, layout.pos.col = 1), |
| 337 | -2x | +161 | +8x |
- get_formats_from_stats(get_stats(met_grp, add_pval = include_pval))+ gp = gp_footnotes |
| 338 | +162 |
- }+ ) |
||
| 339 | +163 | |||
| 340 | -+ | |||
| 164 | +8x |
- #' @describeIn default_stats_formats_labels Quick function to retrieve default labels for summary statistics.+ grid::gTree( |
||
| 341 | -+ | |||
| 165 | +8x |
- #' Returns labels of descriptive statistics which are understood by `rtables`. Similar to `summary_formats`+ grob = grob, |
||
| 342 | -+ | |||
| 166 | +8x |
- #'+ titles = titles, |
||
| 343 | -+ | |||
| 167 | +8x |
- #' @param include_pval (`flag`)\cr deprecated parameter. Same as `add_pval`.+ footnotes = footnotes, |
||
| 344 | -+ | |||
| 168 | +8x |
- #' @return+ page = page, |
||
| 345 | -+ | |||
| 169 | +8x |
- #' * `summary_labels` returns a named `vector` of default statistic labels for the given data type.+ width_titles = width_titles, |
||
| 346 | -+ | |||
| 170 | +8x |
- #'+ width_footnotes = width_footnotes, |
||
| 347 | -+ | |||
| 171 | +8x |
- #' @examples+ border = border, |
||
| 348 | -+ | |||
| 172 | +8x |
- #' summary_labels()+ margins = margins, |
||
| 349 | -+ | |||
| 173 | +8x |
- #' summary_labels(type = "counts", include_pval = TRUE)+ padding = padding, |
||
| 350 | -+ | |||
| 174 | +8x |
- #'+ outer_margins = outer_margins, |
||
| 351 | -+ | |||
| 175 | +8x |
- #' @export+ gp_titles = gp_titles, |
||
| 352 | -+ | |||
| 176 | +8x |
- summary_labels <- function(type = "numeric", include_pval = FALSE) {
+ gp_footnotes = gp_footnotes, |
||
| 353 | -2x | +177 | +8x |
- met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ children = grid::gList( |
| 354 | -2x | +178 | +8x |
- get_labels_from_stats(get_stats(met_grp, add_pval = include_pval))+ grid::gTree( |
| 355 | -+ | |||
| 179 | +8x |
- }+ children = grid::gList( |
||
| 356 | -+ | |||
| 180 | +8x |
-
+ st_titles, |
||
| 357 | -+ | |||
| 181 | +8x |
- #' @describeIn default_stats_formats_labels `r lifecycle::badge("deprecated")` Function to
+ grid::gTree( |
||
| 358 | -+ | |||
| 182 | +8x |
- #' configure settings for default or custom summary statistics for a given data type. In+ children = grid::gList( |
||
| 359 | -+ | |||
| 183 | +8x |
- #' addition to selecting a custom subset of statistics, the user can also set custom+ if (border) grid::rectGrob(), |
||
| 360 | -+ | |||
| 184 | +8x |
- #' formats, labels, and indent modifiers for any of these statistics.+ grid::gTree( |
||
| 361 | -+ | |||
| 185 | +8x |
- #'+ children = grid::gList( |
||
| 362 | -+ | |||
| 186 | +8x |
- #' @param stats_custom (`named vector` of `character`)\cr vector of statistics to include if+ grob |
||
| 363 | +187 |
- #' not the defaults. This argument overrides `include_pval` and other custom value arguments+ ), |
||
| 364 | -+ | |||
| 188 | +8x |
- #' such that only settings for these statistics will be returned.+ vp = grid::plotViewport(margins = padding) |
||
| 365 | +189 |
- #' @param formats_custom (`named vector` of `character`)\cr vector of custom statistics formats+ ) |
||
| 366 | +190 |
- #' to use in place of the defaults defined in [`summary_formats()`]. Names should be a subset+ ), |
||
| 367 | -+ | |||
| 191 | +8x |
- #' of the statistics defined in `stats_custom` (or default statistics if this is `NULL`).+ vp = grid::vpStack( |
||
| 368 | -+ | |||
| 192 | +8x |
- #' @param labels_custom (`named vector` of `character`)\cr vector of custom statistics labels+ grid::viewport(layout.pos.row = 2, layout.pos.col = 1), |
||
| 369 | -+ | |||
| 193 | +8x |
- #' to use in place of the defaults defined in [`summary_labels()`]. Names should be a subset+ grid::plotViewport(margins = margins) |
||
| 370 | +194 |
- #' of the statistics defined in `stats_custom` (or default statistics if this is `NULL`).+ ) |
||
| 371 | +195 |
- #' @param indent_mods_custom (`integer` or `named vector` of `integer`)\cr vector of custom+ ), |
||
| 372 | -+ | |||
| 196 | +8x |
- #' indentation modifiers for statistics to use instead of the default of `0L` for all statistics.+ st_footnotes, |
||
| 373 | -+ | |||
| 197 | +8x |
- #' Names should be a subset of the statistics defined in `stats_custom` (or default statistics+ grid::textGrob( |
||
| 374 | -+ | |||
| 198 | +8x |
- #' if this is `NULL`). Alternatively, the same indentation modifier can be applied to all+ page, |
||
| 375 | -+ | |||
| 199 | +8x |
- #' statistics by setting `indent_mods_custom` to a single integer value.+ x = 1, y = 0, |
||
| 376 | -+ | |||
| 200 | +8x |
- #'+ just = c("right", "bottom"),
|
||
| 377 | -+ | |||
| 201 | +8x |
- #' @return+ vp = grid::viewport(layout.pos.row = 3, layout.pos.col = 1), |
||
| 378 | -+ | |||
| 202 | +8x |
- #' * `summary_custom` returns a `list` of 4 named elements: `stats`, `formats`, `labels`,+ gp = gp_footnotes |
||
| 379 | +203 |
- #' and `indent_mods`.+ ) |
||
| 380 | +204 |
- #'+ ), |
||
| 381 | -+ | |||
| 205 | +8x |
- #' @examples+ childrenvp = NULL, |
||
| 382 | -+ | |||
| 206 | +8x |
- #' summary_custom()+ name = "titles_grob_footnotes", |
||
| 383 | -+ | |||
| 207 | +8x |
- #' summary_custom(type = "counts", include_pval = TRUE)+ vp = grid::vpStack( |
||
| 384 | -+ | |||
| 208 | +8x |
- #' summary_custom(+ grid::plotViewport(margins = outer_margins), |
||
| 385 | -+ | |||
| 209 | +8x |
- #' include_pval = TRUE, stats_custom = c("n", "mean", "sd", "pval"),
+ grid::viewport( |
||
| 386 | -+ | |||
| 210 | +8x |
- #' labels_custom = c(sd = "Std. Dev."), indent_mods_custom = 3L+ layout = grid::grid.layout( |
||
| 387 | -+ | |||
| 211 | +8x |
- #' )+ nrow = 3, ncol = 1, |
||
| 388 | -+ | |||
| 212 | +8x |
- #'+ heights = grid::unit.c( |
||
| 389 | -+ | |||
| 213 | +8x |
- #' @export+ grid::grobHeight(st_titles),+ |
+ ||
| 214 | +8x | +
+ grid::unit(1, "null"),+ |
+ ||
| 215 | +8x | +
+ grid::grobHeight(st_footnotes) |
||
| 390 | +216 |
- summary_custom <- function(type = "numeric",+ ) |
||
| 391 | +217 |
- include_pval = FALSE,+ ) |
||
| 392 | +218 |
- stats_custom = NULL,+ ) |
||
| 393 | +219 |
- formats_custom = NULL,+ ) |
||
| 394 | +220 |
- labels_custom = NULL,+ ) |
||
| 395 | +221 |
- indent_mods_custom = NULL) {
+ ), |
||
| 396 | -1x | +222 | +8x |
- lifecycle::deprecate_warn(+ name = name, |
| 397 | -1x | +223 | +8x |
- "0.9.0.9001",+ gp = gp, |
| 398 | -1x | +224 | +8x |
- "summary_custom()",+ vp = vp, |
| 399 | -1x | +225 | +8x |
- details = "Please use `get_stats`, `get_formats_from_stats`, and `get_labels_from_stats` directly instead."+ cl = "decoratedGrob" |
| 400 | +226 |
) |
||
| 401 | -1x | +|||
| 227 | +
- met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ } |
|||
| 402 | -1x | +|||
| 228 | +
- .stats <- get_stats(met_grp, stats_custom, add_pval = include_pval)+ |
|||
| 403 | -1x | +|||
| 229 | +
- .formats <- get_formats_from_stats(.stats, formats_custom)+ #' @importFrom grid validDetails |
|||
| 404 | -1x | +|||
| 230 | +
- .labels <- get_labels_from_stats(.stats, labels_custom)+ #' @noRd |
|||
| 405 | -1x | +|||
| 231 | +
- .indent_mods <- stats::setNames(rep(0L, length(.stats)), .stats)+ validDetails.decoratedGrob <- function(x) {
+ |
+ |||
| 232 | +! | +
+ checkmate::assert_character(x$titles)+ |
+ ||
| 233 | +! | +
+ checkmate::assert_character(x$footnotes) |
||
| 406 | +234 | |||
| 407 | -1x | +|||
| 235 | +! |
- if (!is.null(indent_mods_custom)) {
+ if (!is.null(x$grob)) {
|
||
| 408 | +236 | ! |
- if (is.null(names(indent_mods_custom)) && length(indent_mods_custom) == 1) {
+ checkmate::assert_true(grid::is.grob(x$grob))+ |
+ |
| 237 | ++ |
+ } |
||
| 409 | +238 | ! |
- .indent_mods[names(.indent_mods)] <- indent_mods_custom+ if (length(x$page) == 1) {
+ |
+ |
| 239 | +! | +
+ checkmate::assert_character(x$page) |
||
| 410 | +240 |
- } else {
+ } |
||
| 411 | +241 | ! |
- .indent_mods[names(indent_mods_custom)] <- indent_mods_custom+ if (!grid::is.unit(x$outer_margins)) {
|
|
| 412 | -+ | |||
| 242 | +! |
- }+ checkmate::assert_vector(x$outer_margins, len = 4) |
||
| 413 | +243 |
} |
||
| 244 | +! | +
+ if (!grid::is.unit(x$margins)) {
+ |
+ ||
| 245 | +! | +
+ checkmate::assert_vector(x$margins, len = 4)+ |
+ ||
| 414 | +246 |
-
+ } |
||
| 415 | -1x | +|||
| 247 | +! |
- list(+ if (!grid::is.unit(x$padding)) {
|
||
| 416 | -1x | +|||
| 248 | +! |
- stats = .stats,+ checkmate::assert_vector(x$padding, len = 4) |
||
| 417 | -1x | +|||
| 249 | +
- formats = .formats,+ } |
|||
| 418 | -1x | +|||
| 250 | +
- labels = .labels,+ |
|||
| 419 | -1x | +|||
| 251 | +! |
- indent_mods = .indent_mods[.stats]+ x |
||
| 420 | +252 |
- )+ } |
||
| 421 | +253 |
- }+ |
| 1 | +254 |
- #' Pairwise `CoxPH` model+ #' @importFrom grid widthDetails |
||
| 2 | +255 |
- #'+ #' @noRd |
||
| 3 | +256 |
- #' @description `r lifecycle::badge("stable")`
+ widthDetails.decoratedGrob <- function(x) {
+ |
+ ||
| 257 | +! | +
+ grid::unit(1, "null") |
||
| 4 | +258 |
- #'+ } |
||
| 5 | +259 |
- #' Summarize p-value, HR and CIs from stratified or unstratified `CoxPH` model.+ |
||
| 6 | +260 |
- #'+ #' @importFrom grid heightDetails |
||
| 7 | +261 |
- #' @inheritParams argument_convention+ #' @noRd |
||
| 8 | +262 |
- #' @inheritParams s_surv_time+ heightDetails.decoratedGrob <- function(x) {
+ |
+ ||
| 263 | +! | +
+ grid::unit(1, "null") |
||
| 9 | +264 |
- #' @param strat (`character` or `NULL`)\cr variable names indicating stratification factors.+ } |
||
| 10 | +265 |
- #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function+ |
||
| 11 | +266 |
- #' [control_coxph()]. Some possible parameter options are:+ # Adapted from Paul Murell R Graphics 2nd Edition |
||
| 12 | +267 |
- #' * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1. Default method is `"log-rank"` which+ # https://www.stat.auckland.ac.nz/~paul/RG2e/interactgrid-splittext.R |
||
| 13 | +268 |
- #' comes from [survival::survdiff()], can also be set to `"wald"` or `"likelihood"` (from [survival::coxph()]).+ split_string <- function(text, width) {
+ |
+ ||
| 269 | +17x | +
+ strings <- strsplit(text, " ")+ |
+ ||
| 270 | +17x | +
+ out_string <- NA+ |
+ ||
| 271 | +17x | +
+ for (string_i in seq_along(strings)) {
+ |
+ ||
| 272 | +17x | +
+ newline_str <- strings[[string_i]]+ |
+ ||
| 273 | +6x | +
+ if (length(newline_str) == 0) newline_str <- ""+ |
+ ||
| 274 | +17x | +
+ if (is.na(out_string[string_i])) {
+ |
+ ||
| 275 | +17x | +
+ out_string[string_i] <- newline_str[[1]][[1]]+ |
+ ||
| 276 | +17x | +
+ linewidth <- grid::stringWidth(out_string[string_i]) |
||
| 14 | +277 |
- #' * `ties` (`string`)\cr specifying the method for tie handling. Default is `"efron"`,+ }+ |
+ ||
| 278 | +17x | +
+ gapwidth <- grid::stringWidth(" ")
+ |
+ ||
| 279 | +17x | +
+ availwidth <- as.numeric(width)+ |
+ ||
| 280 | +17x | +
+ if (length(newline_str) > 1) {
+ |
+ ||
| 281 | +5x | +
+ for (i in seq(2, length(newline_str))) {
+ |
+ ||
| 282 | +27x | +
+ width_i <- grid::stringWidth(newline_str[i])+ |
+ ||
| 283 | +27x | +
+ if (grid::convertWidth(linewidth + gapwidth + width_i, grid::unitType(width), valueOnly = TRUE) < availwidth) {
+ |
+ ||
| 284 | +25x | +
+ sep <- " "+ |
+ ||
| 285 | +25x | +
+ linewidth <- linewidth + gapwidth + width_i |
||
| 15 | +286 |
- #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()]+ } else {
|
||
| 16 | -+ | |||
| 287 | +2x |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR.+ sep <- "\n" |
||
| 17 | -+ | |||
| 288 | +2x |
- #'+ linewidth <- width_i |
||
| 18 | +289 |
- #' @name survival_coxph_pairwise+ } |
||
| 19 | -+ | |||
| 290 | +27x |
- NULL+ out_string[string_i] <- paste(out_string[string_i], newline_str[i], sep = sep) |
||
| 20 | +291 |
-
+ } |
||
| 21 | +292 |
- #' @describeIn survival_coxph_pairwise Statistics function which analyzes HR, CIs of HR and p-value of a `coxph` model.+ } |
||
| 22 | +293 |
- #'+ } |
||
| 23 | -+ | |||
| 294 | +17x |
- #' @return+ paste(out_string, collapse = "\n") |
||
| 24 | +295 |
- #' * `s_coxph_pairwise()` returns the statistics:+ } |
||
| 25 | +296 |
- #' * `pvalue`: p-value to test HR = 1.+ |
||
| 26 | +297 |
- #' * `hr`: Hazard ratio.+ #' Split Text According To Available Text Width |
||
| 27 | +298 |
- #' * `hr_ci`: Confidence interval for hazard ratio.+ #' |
||
| 28 | +299 |
- #' * `n_tot`: Total number of observations.+ #' Dynamically wrap text. |
||
| 29 | +300 |
- #' * `n_tot_events`: Total number of events.+ #' |
||
| 30 | +301 |
- #'+ #' @inheritParams grid::grid.text |
||
| 31 | +302 |
- #' @examples+ #' @param text character string |
||
| 32 | +303 |
- #' library(dplyr)+ #' @param width a unit object specifying max width of text |
||
| 33 | +304 |
#' |
||
| 34 | +305 |
- #' adtte_f <- tern_ex_adtte %>%+ #' @return A text grob. |
||
| 35 | +306 |
- #' filter(PARAMCD == "OS") %>%+ #' |
||
| 36 | +307 |
- #' mutate(is_event = CNSR == 0)+ #' @details This code is taken from `R Graphics by Paul Murell, 2nd edition` |
||
| 37 | +308 |
- #' df <- adtte_f %>%+ #' |
||
| 38 | +309 |
- #' filter(ARMCD == "ARM A")+ #' @keywords internal |
||
| 39 | +310 |
- #' df_ref_group <- adtte_f %>%+ split_text_grob <- function(text, |
||
| 40 | +311 |
- #' filter(ARMCD == "ARM B")+ x = grid::unit(0.5, "npc"), |
||
| 41 | +312 |
- #'+ y = grid::unit(0.5, "npc"), |
||
| 42 | +313 |
- #' @keywords internal+ width = grid::unit(1, "npc"), |
||
| 43 | +314 |
- s_coxph_pairwise <- function(df,+ just = "centre", |
||
| 44 | +315 |
- .ref_group,+ hjust = NULL, |
||
| 45 | +316 |
- .in_ref_col,+ vjust = NULL, |
||
| 46 | +317 |
- .var,+ default.units = "npc", # nolint |
||
| 47 | +318 |
- is_event,+ name = NULL, |
||
| 48 | +319 |
- strat = NULL,+ gp = grid::gpar(), |
||
| 49 | +320 |
- control = control_coxph()) {
+ vp = NULL) {
|
||
| 50 | -65x | +321 | +16x |
- checkmate::assert_string(.var)+ if (!grid::is.unit(x)) x <- grid::unit(x, default.units) |
| 51 | -65x | +322 | +16x |
- checkmate::assert_numeric(df[[.var]])+ if (!grid::is.unit(y)) y <- grid::unit(y, default.units) |
| 52 | -65x | +|||
| 323 | +! |
- checkmate::assert_logical(df[[is_event]])+ if (!grid::is.unit(width)) width <- grid::unit(width, default.units) |
||
| 53 | -65x | +|||
| 324 | +! |
- assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ if (grid::unitType(x) %in% c("sum", "min", "max")) x <- grid::convertUnit(x, default.units)
|
||
| 54 | -65x | +|||
| 325 | +! |
- pval_method <- control$pval_method+ if (grid::unitType(y) %in% c("sum", "min", "max")) y <- grid::convertUnit(y, default.units)
|
||
| 55 | -65x | +326 | +16x |
- ties <- control$ties+ if (grid::unitType(width) %in% c("sum", "min", "max")) width <- grid::convertUnit(width, default.units)
|
| 56 | -65x | +|||
| 327 | +
- conf_level <- control$conf_level+ |
|||
| 57 | +328 |
-
+ ## if it is a fixed unit then we do not need to recalculate when viewport resized |
||
| 58 | -65x | +329 | +16x |
- if (.in_ref_col) {
+ if (!inherits(width, "unit.arithmetic") && |
| 59 | -! | +|||
| 330 | +16x |
- return(+ !is.null(attr(width, "unit")) && |
||
| 60 | -! | +|||
| 331 | +16x |
- list(+ attr(width, "unit") %in% c("cm", "inches", "mm", "points", "picas", "bigpts", "dida", "cicero", "scaledpts")) {
|
||
| 61 | +332 | ! |
- pvalue = formatters::with_label("", paste0("p-value (", pval_method, ")")),
+ attr(text, "fixed_text") <- paste(vapply(text, split_string, character(1), width = width), collapse = "\n") |
|
| 62 | -! | +|||
| 333 | +
- hr = formatters::with_label("", "Hazard Ratio"),
+ } |
|||
| 63 | -! | +|||
| 334 | +
- hr_ci = formatters::with_label("", f_conf_level(conf_level)),
+
|
|||
| 64 | -! | +|||
| 335 | +16x |
- n_tot = formatters::with_label("", "Total n"),
+ grid::grid.text( |
||
| 65 | -! | +|||
| 336 | +16x |
- n_tot_events = formatters::with_label("", "Total events")
+ label = split_string(text, width), |
||
| 66 | -+ | |||
| 337 | +16x |
- )+ x = x, y = y, |
||
| 67 | -+ | |||
| 338 | +16x |
- )+ just = just, |
||
| 68 | -+ | |||
| 339 | +16x |
- }+ hjust = hjust, |
||
| 69 | -65x | +340 | +16x |
- data <- rbind(.ref_group, df)+ vjust = vjust, |
| 70 | -65x | +341 | +16x |
- group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
+ rot = 0, |
| 71 | -+ | |||
| 342 | +16x |
-
+ check.overlap = FALSE, |
||
| 72 | -65x | +343 | +16x |
- df_cox <- data.frame(+ name = name, |
| 73 | -65x | +344 | +16x |
- tte = data[[.var]],+ gp = gp, |
| 74 | -65x | +345 | +16x |
- is_event = data[[is_event]],+ vp = vp, |
| 75 | -65x | +346 | +16x |
- arm = group+ draw = FALSE |
| 76 | +347 |
) |
||
| 77 | -65x | +|||
| 348 | +
- if (is.null(strat)) {
+ } |
|||
| 78 | -58x | +|||
| 349 | +
- formula_cox <- survival::Surv(tte, is_event) ~ arm+ |
|||
| 79 | +350 |
- } else {
+ #' @importFrom grid validDetails |
||
| 80 | -7x | +|||
| 351 | +
- formula_cox <- stats::as.formula(+ #' @noRd |
|||
| 81 | -7x | +|||
| 352 | +
- paste0(+ validDetails.dynamicSplitText <- function(x) {
|
|||
| 82 | -7x | +|||
| 353 | +! |
- "survival::Surv(tte, is_event) ~ arm + strata(",
+ checkmate::assert_character(x$text) |
||
| 83 | -7x | +|||
| 354 | +! |
- paste(strat, collapse = ","),+ checkmate::assert_true(grid::is.unit(x$width)) |
||
| 84 | -+ | |||
| 355 | +! |
- ")"+ checkmate::assert_vector(x$width, len = 1) |
||
| 85 | -+ | |||
| 356 | +! |
- )+ x |
||
| 86 | +357 |
- )+ } |
||
| 87 | -7x | +|||
| 358 | +
- df_cox <- cbind(df_cox, data[strat])+ |
|||
| 88 | +359 |
- }+ #' @importFrom grid heightDetails |
||
| 89 | -65x | +|||
| 360 | +
- cox_fit <- survival::coxph(+ #' @noRd |
|||
| 90 | -65x | +|||
| 361 | +
- formula = formula_cox,+ heightDetails.dynamicSplitText <- function(x) {
|
|||
| 91 | -65x | +|||
| 362 | +! |
- data = df_cox,+ txt <- if (!is.null(attr(x$text, "fixed_text"))) {
|
||
| 92 | -65x | +|||
| 363 | +! |
- ties = ties+ attr(x$text, "fixed_text") |
||
| 93 | +364 |
- )+ } else {
|
||
| 94 | -65x | +|||
| 365 | +! |
- sum_cox <- summary(cox_fit, conf.int = conf_level, extend = TRUE)+ paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n") |
||
| 95 | -65x | +|||
| 366 | +
- orginal_survdiff <- survival::survdiff(+ } |
|||
| 96 | -65x | +|||
| 367 | +! |
- formula_cox,+ grid::stringHeight(txt) |
||
| 97 | -65x | +|||
| 368 | +
- data = df_cox+ } |
|||
| 98 | +369 |
- )+ |
||
| 99 | -65x | +|||
| 370 | +
- log_rank_pvalue <- 1 - pchisq(orginal_survdiff$chisq, length(orginal_survdiff$n) - 1)+ #' @importFrom grid widthDetails |
|||
| 100 | +371 |
-
+ #' @noRd |
||
| 101 | -65x | +|||
| 372 | +
- pval <- switch(pval_method,+ widthDetails.dynamicSplitText <- function(x) {
|
|||
| 102 | -65x | +|||
| 373 | +! |
- "wald" = sum_cox$waldtest["pvalue"],+ x$width |
||
| 103 | -65x | +|||
| 374 | +
- "log-rank" = log_rank_pvalue, # pvalue from original log-rank test survival::survdiff()+ } |
|||
| 104 | -65x | +|||
| 375 | +
- "likelihood" = sum_cox$logtest["pvalue"]+ |
|||
| 105 | +376 |
- )+ #' @importFrom grid drawDetails |
||
| 106 | -65x | +|||
| 377 | +
- list(+ #' @noRd |
|||
| 107 | -65x | +|||
| 378 | +
- pvalue = formatters::with_label(unname(pval), paste0("p-value (", pval_method, ")")),
+ drawDetails.dynamicSplitText <- function(x, recording) {
|
|||
| 108 | -65x | +|||
| 379 | +! |
- hr = formatters::with_label(sum_cox$conf.int[1, 1], "Hazard Ratio"),+ txt <- if (!is.null(attr(x$text, "fixed_text"))) {
|
||
| 109 | -65x | +|||
| 380 | +! |
- hr_ci = formatters::with_label(unname(sum_cox$conf.int[1, 3:4]), f_conf_level(conf_level)),+ attr(x$text, "fixed_text") |
||
| 110 | -65x | +|||
| 381 | +
- n_tot = formatters::with_label(sum_cox$n, "Total n"),+ } else {
|
|||
| 111 | -65x | +|||
| 382 | +! |
- n_tot_events = formatters::with_label(sum_cox$nevent, "Total events")+ paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n") |
||
| 112 | +383 |
- )+ } |
||
| 113 | +384 |
- }+ |
||
| 114 | -+ | |||
| 385 | +! |
-
+ x$width <- NULL |
||
| 115 | -+ | |||
| 386 | +! |
- #' @describeIn survival_coxph_pairwise Formatted analysis function which is used as `afun` in `coxph_pairwise()`.+ x$label <- txt+ |
+ ||
| 387 | +! | +
+ x$text <- NULL+ |
+ ||
| 388 | +! | +
+ class(x) <- c("text", class(x)[-1])
|
||
| 116 | +389 |
- #'+ + |
+ ||
| 390 | +! | +
+ grid::grid.draw(x) |
||
| 117 | +391 |
- #' @return+ } |
||
| 118 | +392 |
- #' * `a_coxph_pairwise()` returns the corresponding list with formatted [rtables::CellValue()].+ |
||
| 119 | +393 |
- #'+ #' Update Page Number |
||
| 120 | +394 |
#' |
||
| 121 | +395 |
- #' @keywords internal+ #' Automatically updates page number. |
||
| 122 | +396 |
- a_coxph_pairwise <- make_afun(+ #' |
||
| 123 | +397 |
- s_coxph_pairwise,+ #' @param npages number of pages in total |
||
| 124 | +398 |
- .indent_mods = c(pvalue = 0L, hr = 0L, hr_ci = 1L, n_tot = 0L, n_tot_events = 0L),+ #' @param ... passed on to [decorate_grob()] |
||
| 125 | +399 |
- .formats = c(+ #' |
||
| 126 | +400 |
- pvalue = "x.xxxx | (<0.0001)",+ #' @return Closure that increments the page number. |
||
| 127 | +401 |
- hr = "xx.xx",+ #' |
||
| 128 | +402 |
- hr_ci = "(xx.xx, xx.xx)",+ #' @keywords internal |
||
| 129 | +403 |
- n_tot = "xx.xx",+ decorate_grob_factory <- function(npages, ...) {
|
||
| 130 | -+ | |||
| 404 | +2x |
- n_tot_events = "xx.xx"+ current_page <- 0 |
||
| 131 | -+ | |||
| 405 | +2x |
- )+ function(grob) {
|
||
| 132 | -+ | |||
| 406 | +7x |
- )+ current_page <<- current_page + 1 |
||
| 133 | -+ | |||
| 407 | +7x |
-
+ if (current_page > npages) {
|
||
| 134 | -+ | |||
| 408 | +1x |
- #' @describeIn survival_coxph_pairwise Layout-creating function which can take statistics function arguments+ stop(paste("current page is", current_page, "but max.", npages, "specified."))
|
||
| 135 | +409 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ } |
||
| 136 | -+ | |||
| 410 | +6x |
- #'+ decorate_grob(grob = grob, page = paste("Page", current_page, "of", npages), ...)
|
||
| 137 | +411 |
- #' @return+ } |
||
| 138 | +412 |
- #' * `coxph_pairwise()` returns a layout object suitable for passing to further layouting functions,+ } |
||
| 139 | +413 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
||
| 140 | +414 |
- #' the statistics from `s_coxph_pairwise()` to the table layout.+ #' Decorate Set of `grobs` and Add Page Numbering |
||
| 141 | +415 |
#' |
||
| 142 | +416 |
- #' @examples+ #' @description `r lifecycle::badge("stable")`
|
||
| 143 | +417 |
- #' basic_table() %>%+ #' |
||
| 144 | +418 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ #' Note that this uses the [decorate_grob_factory()] function. |
||
| 145 | +419 |
- #' add_colcounts() %>%+ #' |
||
| 146 | +420 |
- #' coxph_pairwise(+ #' @param grobs a list of grid grobs |
||
| 147 | +421 |
- #' vars = "AVAL",+ #' @param ... arguments passed on to [decorate_grob()]. |
||
| 148 | +422 |
- #' is_event = "is_event",+ #' |
||
| 149 | +423 |
- #' var_labels = "Unstratified Analysis"+ #' @return A decorated grob. |
||
| 150 | +424 |
- #' ) %>%+ #' |
||
| 151 | +425 |
- #' build_table(df = adtte_f)+ #' @examples |
||
| 152 | +426 |
- #'+ #' library(ggplot2) |
||
| 153 | +427 |
- #' basic_table() %>%+ #' library(grid) |
||
| 154 | +428 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ #' g <- with(data = iris, {
|
||
| 155 | +429 |
- #' add_colcounts() %>%+ #' list( |
||
| 156 | +430 |
- #' coxph_pairwise(+ #' ggplot2::ggplotGrob( |
||
| 157 | +431 |
- #' vars = "AVAL",+ #' ggplot2::ggplot(mapping = aes(Sepal.Length, Sepal.Width, col = Species)) + |
||
| 158 | +432 |
- #' is_event = "is_event",+ #' ggplot2::geom_point() |
||
| 159 | +433 |
- #' var_labels = "Stratified Analysis",+ #' ), |
||
| 160 | +434 |
- #' strat = "SEX",+ #' ggplot2::ggplotGrob( |
||
| 161 | +435 |
- #' control = control_coxph(pval_method = "wald")+ #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Length, col = Species)) + |
||
| 162 | +436 |
- #' ) %>%+ #' ggplot2::geom_point() |
||
| 163 | +437 |
- #' build_table(df = adtte_f)+ #' ), |
||
| 164 | +438 |
- #'+ #' ggplot2::ggplotGrob( |
||
| 165 | +439 |
- #' @export+ #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Width, col = Species)) + |
||
| 166 | +440 |
- coxph_pairwise <- function(lyt,+ #' ggplot2::geom_point() |
||
| 167 | +441 |
- vars,+ #' ), |
||
| 168 | +442 |
- nested = TRUE,+ #' ggplot2::ggplotGrob( |
||
| 169 | +443 |
- ...,+ #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Length, col = Species)) + |
||
| 170 | +444 |
- var_labels = "CoxPH",+ #' ggplot2::geom_point() |
||
| 171 | +445 |
- show_labels = "visible",+ #' ), |
||
| 172 | +446 |
- table_names = vars,+ #' ggplot2::ggplotGrob( |
||
| 173 | +447 |
- .stats = c("pvalue", "hr", "hr_ci"),
+ #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Width, col = Species)) + |
||
| 174 | +448 |
- .formats = NULL,+ #' ggplot2::geom_point() |
||
| 175 | +449 |
- .labels = NULL,+ #' ), |
||
| 176 | +450 |
- .indent_mods = NULL) {
+ #' ggplot2::ggplotGrob( |
||
| 177 | -4x | +|||
| 451 | +
- afun <- make_afun(+ #' ggplot2::ggplot(mapping = aes(Petal.Length, Petal.Width, col = Species)) + |
|||
| 178 | -4x | +|||
| 452 | +
- a_coxph_pairwise,+ #' ggplot2::geom_point() |
|||
| 179 | -4x | +|||
| 453 | +
- .stats = .stats,+ #' ) |
|||
| 180 | -4x | +|||
| 454 | +
- .formats = .formats,+ #' ) |
|||
| 181 | -4x | +|||
| 455 | +
- .labels = .labels,+ #' }) |
|||
| 182 | -4x | +|||
| 456 | +
- .indent_mods = .indent_mods+ #' lg <- decorate_grob_set(grobs = g, titles = "Hello\nOne\nTwo\nThree", footnotes = "") |
|||
| 183 | +457 |
- )+ #' |
||
| 184 | -4x | +|||
| 458 | +
- analyze(+ #' draw_grob(lg[[1]]) |
|||
| 185 | -4x | +|||
| 459 | +
- lyt,+ #' draw_grob(lg[[2]]) |
|||
| 186 | -4x | +|||
| 460 | +
- vars,+ #' draw_grob(lg[[6]]) |
|||
| 187 | -4x | +|||
| 461 | +
- var_labels = var_labels,+ #' |
|||
| 188 | -4x | +|||
| 462 | +
- show_labels = show_labels,+ #' @export |
|||
| 189 | -4x | +|||
| 463 | +
- table_names = table_names,+ decorate_grob_set <- function(grobs, ...) {
|
|||
| 190 | -4x | +464 | +1x |
- afun = afun,+ n <- length(grobs) |
| 191 | -4x | +465 | +1x |
- nested = nested,+ lgf <- decorate_grob_factory(npages = n, ...) |
| 192 | -4x | -
- extra_args = list(...)- |
- ||
| 193 | -+ | 466 | +1x |
- )+ lapply(grobs, lgf) |
| 194 | +467 |
}@@ -23279,14 +24549,14 @@ tern coverage - 94.83% |
| 1 |
- #' Kaplan-Meier Plot+ #' Tabulate Binary Response by Subgroup |
|||
| 5 |
- #' From a survival model, a graphic is rendered along with tabulated annotation+ #' Tabulate statistics such as response rate and odds ratio for population subgroups. |
|||
| 6 |
- #' including the number of patient at risk at given time and the median survival+ #' |
|||
| 7 |
- #' per group.+ #' @inheritParams argument_convention |
|||
| 9 |
- #' @inheritParams grid::gTree+ #' @details These functions create a layout starting from a data frame which contains |
|||
| 10 |
- #' @inheritParams argument_convention+ #' the required statistics. Tables typically used as part of forest plot. |
|||
| 11 |
- #' @param df (`data.frame`)\cr data set containing all analysis variables.+ #' |
|||
| 12 |
- #' @param variables (named `list`)\cr variable names. Details are:+ #' @seealso [extract_rsp_subgroups()] |
|||
| 13 |
- #' * `tte` (`numeric`)\cr variable indicating time-to-event duration values.+ #' |
|||
| 14 |
- #' * `is_event` (`logical`)\cr event variable. `TRUE` if event, `FALSE` if time to event is censored.+ #' @examples |
|||
| 15 |
- #' * `arm` (`factor`)\cr the treatment group variable.+ #' library(dplyr) |
|||
| 16 |
- #' * `strat` (`character` or `NULL`)\cr variable names indicating stratification factors.+ #' library(forcats) |
|||
| 17 |
- #' @param control_surv (`list`)\cr parameters for comparison details, specified by using+ #' |
|||
| 18 |
- #' the helper function [control_surv_timepoint()]. Some possible parameter options are:+ #' adrs <- tern_ex_adrs |
|||
| 19 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate.+ #' adrs_labels <- formatters::var_labels(adrs) |
|||
| 20 |
- #' * `conf_type` (`string`)\cr `"plain"` (default), `"log"`, `"log-log"` for confidence interval type,+ #' |
|||
| 21 |
- #' see more in [survival::survfit()]. Note that the option "none" is no longer supported.+ #' adrs_f <- adrs %>% |
|||
| 22 |
- #' @param xticks (`numeric`, `number`, or `NULL`)\cr numeric vector of ticks or single number with spacing+ #' filter(PARAMCD == "BESRSPI") %>% |
|||
| 23 |
- #' between ticks on the x axis. If `NULL` (default), [labeling::extended()] is used to determine+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
|
|||
| 24 |
- #' an optimal tick position on the x axis.+ #' droplevels() %>% |
|||
| 25 |
- #' @param yval (`string`)\cr value of y-axis. Options are `Survival` (default) and `Failure` probability.+ #' mutate( |
|||
| 26 |
- #' @param censor_show (`flag`)\cr whether to show censored.+ #' # Reorder levels of factor to make the placebo group the reference arm. |
|||
| 27 |
- #' @param xlab (`string`)\cr label of x-axis.+ #' ARM = fct_relevel(ARM, "B: Placebo"), |
|||
| 28 |
- #' @param ylab (`string`)\cr label of y-axis.+ #' rsp = AVALC == "CR" |
|||
| 29 |
- #' @param ylim (`vector` of `numeric`)\cr vector of length 2 containing lower and upper limits for the y-axis.+ #' ) |
|||
| 30 |
- #' If `NULL` (default), the minimum and maximum y-values displayed are used as limits.+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
|||
| 31 |
- #' @param title (`string`)\cr title for plot.+ #' |
|||
| 32 |
- #' @param footnotes (`string`)\cr footnotes for plot.+ #' # Unstratified analysis. |
|||
| 33 |
- #' @param col (`character`)\cr lines colors. Length of a vector should be equal+ #' df <- extract_rsp_subgroups( |
|||
| 34 |
- #' to number of strata from [survival::survfit()].+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
|||
| 35 |
- #' @param lty (`numeric`)\cr line type. Length of a vector should be equal+ #' data = adrs_f |
|||
| 36 |
- #' to number of strata from [survival::survfit()].+ #' ) |
|||
| 37 |
- #' @param lwd (`numeric`)\cr line width. Length of a vector should be equal+ #' df |
|||
| 38 |
- #' to number of strata from [survival::survfit()].+ #' |
|||
| 39 |
- #' @param pch (`numeric`, `string`)\cr value or character of points symbol to indicate censored cases.+ #' @name response_subgroups |
|||
| 40 |
- #' @param size (`numeric`)\cr size of censored point, a class of `unit`.+ NULL |
|||
| 41 |
- #' @param max_time (`numeric`)\cr maximum value to show on X axis. Only data values less than or up to+ |
|||
| 42 |
- #' this threshold value will be plotted (defaults to `NULL`).+ #' Prepares Response Data for Population Subgroups in Data Frames |
|||
| 43 |
- #' @param font_size (`number`)\cr font size to be used.+ #' |
|||
| 44 |
- #' @param ci_ribbon (`flag`)\cr draw the confidence interval around the Kaplan-Meier curve.+ #' @description `r lifecycle::badge("stable")`
|
|||
| 45 |
- #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control outlook of the Kaplan-Meier curve.+ #' |
|||
| 46 |
- #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of patient at risk+ #' Prepares response rates and odds ratios for population subgroups in data frames. Simple wrapper |
|||
| 47 |
- #' matching the main grid of the Kaplan-Meier curve.+ #' for [h_odds_ratio_subgroups_df()] and [h_proportion_subgroups_df()]. Result is a list of two |
|||
| 48 |
- #' @param annot_at_risk_title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk`+ #' `data.frames`: `prop` and `or`. `variables` corresponds to the names of variables found in `data`, |
|||
| 49 |
- #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`.+ #' passed as a named `list` and requires elements `rsp`, `arm` and optionally `subgroups` and `strat`. |
|||
| 50 |
- #' @param annot_surv_med (`flag`)\cr compute and add the annotation table on the Kaplan-Meier curve estimating the+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
|||
| 51 |
- #' median survival time per group.+ #' |
|||
| 52 |
- #' @param annot_coxph (`flag`)\cr add the annotation table from a [survival::coxph()] model.+ #' @inheritParams argument_convention |
|||
| 53 |
- #' @param annot_stats (`string`)\cr statistics annotations to add to the plot. Options are+ #' @inheritParams response_subgroups |
|||
| 54 |
- #' `median` (median survival follow-up time) and `min` (minimum survival follow-up time).+ #' @param label_all (`string`)\cr label for the total population analysis. |
|||
| 55 |
- #' @param annot_stats_vlines (`flag`)\cr add vertical lines corresponding to each of the statistics+ #' |
|||
| 56 |
- #' specified by `annot_stats`. If `annot_stats` is `NULL` no lines will be added.+ #' @return A named list of two elements: |
|||
| 57 |
- #' @param control_coxph_pw (`list`)\cr parameters for comparison details, specified by using+ #' * `prop`: A `data.frame` containing columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`, `var`, |
|||
| 58 |
- #' the helper function [control_coxph()]. Some possible parameter options are:+ #' `var_label`, and `row_type`. |
|||
| 59 |
- #' * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1.+ #' * `or`: A `data.frame` containing columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`, |
|||
| 60 |
- #' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`.+ #' `subgroup`, `var`, `var_label`, and `row_type`. |
|||
| 61 |
- #' * `ties` (`string`)\cr method for tie handling. Default is `"efron"`,+ #' |
|||
| 62 |
- #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()]+ #' @seealso [response_subgroups] |
|||
| 63 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR.+ #' |
|||
| 64 |
- #' @param position_coxph (`numeric`)\cr x and y positions for plotting [survival::coxph()] model.+ #' @examples |
|||
| 65 |
- #' @param position_surv_med (`numeric`)\cr x and y positions for plotting annotation table estimating median survival+ #' library(dplyr) |
|||
| 66 |
- #' time per group.+ #' library(forcats) |
|||
| 67 |
- #' @param width_annots (named `list` of `unit`s)\cr a named list of widths for annotation tables with names `surv_med`+ #' |
|||
| 68 |
- #' (median survival time table) and `coxph` ([survival::coxph()] model table), where each value is the width+ #' adrs <- tern_ex_adrs |
|||
| 69 |
- #' (in units) to implement when printing the annotation table.+ #' adrs_labels <- formatters::var_labels(adrs) |
|||
| 71 |
- #' @return A `grob` of class `gTree`.+ #' adrs_f <- adrs %>% |
|||
| 72 |
- #'+ #' filter(PARAMCD == "BESRSPI") %>% |
|||
| 73 |
- #' @examples+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
|
|||
| 74 |
- #' \donttest{
+ #' droplevels() %>% |
|||
| 75 |
- #' library(dplyr)+ #' mutate( |
|||
| 76 |
- #' library(ggplot2)+ #' # Reorder levels of factor to make the placebo group the reference arm. |
|||
| 77 |
- #' library(survival)+ #' ARM = fct_relevel(ARM, "B: Placebo"), |
|||
| 78 |
- #' library(grid)+ #' rsp = AVALC == "CR" |
|||
| 79 |
- #' library(nestcolor)+ #' ) |
|||
| 80 |
- #'+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
|||
| 81 |
- #' df <- tern_ex_adtte %>%+ #' |
|||
| 82 |
- #' filter(PARAMCD == "OS") %>%+ #' # Unstratified analysis. |
|||
| 83 |
- #' mutate(is_event = CNSR == 0)+ #' df <- extract_rsp_subgroups( |
|||
| 84 |
- #' variables <- list(tte = "AVAL", is_event = "is_event", arm = "ARMCD")+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
|||
| 85 |
- #'+ #' data = adrs_f |
|||
| 86 |
- #' # 1. Example - basic option+ #' ) |
|||
| 87 |
- #'+ #' df |
|||
| 88 |
- #' res <- g_km(df = df, variables = variables)+ #' |
|||
| 89 |
- #' res <- g_km(df = df, variables = variables, yval = "Failure")+ #' # Stratified analysis. |
|||
| 90 |
- #' res <- g_km(+ #' df_strat <- extract_rsp_subgroups( |
|||
| 91 |
- #' df = df,+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2"), strat = "STRATA1"),
|
|||
| 92 |
- #' variables = variables,+ #' data = adrs_f |
|||
| 93 |
- #' control_surv = control_surv_timepoint(conf_level = 0.9),+ #' ) |
|||
| 94 |
- #' col = c("grey25", "grey50", "grey75"),
+ #' df_strat |
|||
| 95 |
- #' annot_at_risk_title = FALSE+ #' |
|||
| 96 |
- #' )+ #' # Grouping of the BMRKR2 levels. |
|||
| 97 |
- #' res <- g_km(df = df, variables = variables, ggtheme = theme_minimal())+ #' df_grouped <- extract_rsp_subgroups( |
|||
| 98 |
- #' res <- g_km(df = df, variables = variables, ggtheme = theme_minimal(), lty = 1:3)+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
|||
| 99 |
- #' res <- g_km(df = df, variables = variables, max = 2000)+ #' data = adrs_f, |
|||
| 100 |
- #' res <- g_km(+ #' groups_lists = list( |
|||
| 101 |
- #' df = df,+ #' BMRKR2 = list( |
|||
| 102 |
- #' variables = variables,+ #' "low" = "LOW", |
|||
| 103 |
- #' annot_stats = c("min", "median"),
+ #' "low/medium" = c("LOW", "MEDIUM"),
|
|||
| 104 |
- #' annot_stats_vlines = TRUE+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
|||
| 105 |
- #' )+ #' ) |
|||
| 106 |
- #'+ #' ) |
|||
| 107 |
- #' # 2. Example - Arrange several KM curve on a single graph device+ #' ) |
|||
| 108 |
- #'+ #' df_grouped |
|||
| 109 |
- #' # 2.1 Use case: A general graph on the top, a zoom on the bottom.+ #' |
|||
| 110 |
- #' grid.newpage()+ #' @export |
|||
| 111 |
- #' lyt <- grid.layout(nrow = 2, ncol = 1) %>%+ extract_rsp_subgroups <- function(variables, |
|||
| 112 |
- #' viewport(layout = .) %>%+ data, |
|||
| 113 |
- #' pushViewport()+ groups_lists = list(), |
|||
| 114 |
- #'+ conf_level = 0.95, |
|||
| 115 |
- #' res <- g_km(+ method = NULL, |
|||
| 116 |
- #' df = df, variables = variables, newpage = FALSE, annot_surv_med = FALSE,+ label_all = "All Patients") {
|
|||
| 117 | -+ | 10x |
- #' vp = viewport(layout.pos.row = 1, layout.pos.col = 1)+ df_prop <- h_proportion_subgroups_df( |
|
| 118 | -+ | 10x |
- #' )+ variables, |
|
| 119 | -+ | 10x |
- #' res <- g_km(+ data, |
|
| 120 | -+ | 10x |
- #' df = df, variables = variables, max = 1000, newpage = FALSE, annot_surv_med = FALSE,+ groups_lists = groups_lists, |
|
| 121 | -+ | 10x |
- #' ggtheme = theme_dark(),+ label_all = label_all |
|
| 122 |
- #' vp = viewport(layout.pos.row = 2, layout.pos.col = 1)+ ) |
|||
| 123 | -+ | 10x |
- #' )+ df_or <- h_odds_ratio_subgroups_df( |
|
| 124 | -+ | 10x |
- #'+ variables, |
|
| 125 | -+ | 10x |
- #' # 2.1 Use case: No annotations on top, annotated graph on bottom+ data, |
|
| 126 | -+ | 10x |
- #' grid.newpage()+ groups_lists = groups_lists, |
|
| 127 | -+ | 10x |
- #' lyt <- grid.layout(nrow = 2, ncol = 1) %>%+ conf_level = conf_level, |
|
| 128 | -+ | 10x |
- #' viewport(layout = .) %>%+ method = method, |
|
| 129 | -+ | 10x |
- #' pushViewport()+ label_all = label_all |
|
| 130 |
- #'+ ) |
|||
| 131 |
- #' res <- g_km(+ |
|||
| 132 | -+ | 10x |
- #' df = df, variables = variables, newpage = FALSE,+ list(prop = df_prop, or = df_or) |
|
| 133 |
- #' annot_surv_med = FALSE, annot_at_risk = FALSE,+ } |
|||
| 134 |
- #' vp = viewport(layout.pos.row = 1, layout.pos.col = 1)+ |
|||
| 135 |
- #' )+ #' @describeIn response_subgroups Formatted analysis function which is used as `afun` in `tabulate_rsp_subgroups()`. |
|||
| 136 |
- #' res <- g_km(+ #' |
|||
| 137 |
- #' df = df, variables = variables, max = 2000, newpage = FALSE, annot_surv_med = FALSE,+ #' @return |
|||
| 138 |
- #' annot_at_risk = TRUE,+ #' * `a_response_subgroups()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 139 |
- #' ggtheme = theme_dark(),+ #' |
|||
| 140 |
- #' vp = viewport(layout.pos.row = 2, layout.pos.col = 1)+ #' @keywords internal |
|||
| 141 |
- #' )+ a_response_subgroups <- function(.formats = list( |
|||
| 142 |
- #'+ n = "xx", |
|||
| 143 |
- #' # Add annotation from a pairwise coxph analysis+ n_rsp = "xx", |
|||
| 144 |
- #' g_km(+ prop = "xx.x%", |
|||
| 145 |
- #' df = df, variables = variables,+ n_tot = "xx", |
|||
| 146 |
- #' annot_coxph = TRUE+ or = list(format_extreme_values(2L)), |
|||
| 147 |
- #' )+ ci = list(format_extreme_values_ci(2L)), |
|||
| 148 |
- #'+ pval = "x.xxxx | (<0.0001)" |
|||
| 149 |
- #' # Change widths/sizes of surv_med and coxph annotation tables.+ )) {
|
|||
| 150 | -+ | 13x |
- #' g_km(+ checkmate::assert_list(.formats) |
|
| 151 | -+ | 13x |
- #' df = df, variables = c(variables, list(strat = "SEX")),+ checkmate::assert_subset( |
|
| 152 | -+ | 13x |
- #' annot_coxph = TRUE,+ names(.formats), |
|
| 153 | -+ | 13x |
- #' width_annots = list(surv_med = grid::unit(2, "in"), coxph = grid::unit(3, "in"))+ c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
|
|
| 154 |
- #' )+ ) |
|||
| 155 |
- #'+ |
|||
| 156 | -+ | 13x |
- #' g_km(+ afun_lst <- Map( |
|
| 157 | -+ | 13x |
- #' df = df, variables = c(variables, list(strat = "SEX")),+ function(stat, fmt) {
|
|
| 158 | -+ | 86x |
- #' font_size = 15,+ if (stat == "ci") {
|
|
| 159 | -+ | 12x |
- #' annot_coxph = TRUE,+ function(df, labelstr = "", ...) {
|
|
| 160 | -+ | 24x |
- #' control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99),+ in_rows(.list = combine_vectors(df$lcl, df$ucl), .labels = as.character(df$subgroup), .formats = fmt) |
|
| 161 |
- #' position_coxph = c(0.5, 0.5)+ } |
|||
| 162 |
- #' )+ } else {
|
|||
| 163 | -+ | 74x |
- #'+ function(df, labelstr = "", ...) {
|
|
| 164 | -+ | 142x |
- #' # Change position of the treatment group annotation table.+ in_rows(.list = as.list(df[[stat]]), .labels = as.character(df$subgroup), .formats = fmt) |
|
| 165 |
- #' g_km(+ } |
|||
| 166 |
- #' df = df, variables = c(variables, list(strat = "SEX")),+ } |
|||
| 167 |
- #' font_size = 15,+ }, |
|||
| 168 | -+ | 13x |
- #' annot_coxph = TRUE,+ stat = names(.formats), |
|
| 169 | -+ | 13x |
- #' control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99),+ fmt = .formats |
|
| 170 |
- #' position_surv_med = c(1, 0.7)+ ) |
|||
| 171 |
- #' )+ |
|||
| 172 | -+ | 13x |
- #' }+ afun_lst |
|
| 173 |
- #'+ } |
|||
| 174 |
- #' @export+ |
|||
| 175 |
- g_km <- function(df,+ #' @describeIn response_subgroups Table-creating function which creates a table |
|||
| 176 |
- variables,+ #' summarizing binary response by subgroup. This function is a wrapper for [rtables::analyze_colvars()] |
|||
| 177 |
- control_surv = control_surv_timepoint(),+ #' and [rtables::summarize_row_groups()]. |
|||
| 178 |
- col = NULL,+ #' |
|||
| 179 |
- lty = NULL,+ #' @param df (`list`)\cr of data frames containing all analysis variables. List should be |
|||
| 180 |
- lwd = .5,+ #' created using [extract_rsp_subgroups()]. |
|||
| 181 |
- censor_show = TRUE,+ #' @param vars (`character`)\cr the names of statistics to be reported among: |
|||
| 182 |
- pch = 3,+ #' * `n`: Total number of observations per group. |
|||
| 183 |
- size = 2,+ #' * `n_rsp`: Number of responders per group. |
|||
| 184 |
- max_time = NULL,+ #' * `prop`: Proportion of responders. |
|||
| 185 |
- xticks = NULL,+ #' * `n_tot`: Total number of observations. |
|||
| 186 |
- xlab = "Days",+ #' * `or`: Odds ratio. |
|||
| 187 |
- yval = c("Survival", "Failure"),
+ #' * `ci` : Confidence interval of odds ratio. |
|||
| 188 |
- ylab = paste(yval, "Probability"),+ #' * `pval`: p-value of the effect. |
|||
| 189 |
- ylim = NULL,+ #' Note, the statistics `n_tot`, `or` and `ci` are required. |
|||
| 190 |
- title = NULL,+ #' |
|||
| 191 |
- footnotes = NULL,+ #' @return An `rtables` table summarizing binary response by subgroup. |
|||
| 192 |
- draw = TRUE,+ #' |
|||
| 193 |
- newpage = TRUE,+ #' @examples |
|||
| 194 |
- gp = NULL,+ #' ## Table with default columns. |
|||
| 195 |
- vp = NULL,+ #' basic_table() %>% |
|||
| 196 |
- name = NULL,+ #' tabulate_rsp_subgroups(df) |
|||
| 197 |
- font_size = 12,+ #' |
|||
| 198 |
- ci_ribbon = FALSE,+ #' ## Table with selected columns. |
|||
| 199 |
- ggtheme = nestcolor::theme_nest(),+ #' basic_table() %>% |
|||
| 200 |
- annot_at_risk = TRUE,+ #' tabulate_rsp_subgroups( |
|||
| 201 |
- annot_at_risk_title = TRUE,+ #' df = df, |
|||
| 202 |
- annot_surv_med = TRUE,+ #' vars = c("n_tot", "n", "n_rsp", "prop", "or", "ci")
|
|||
| 203 |
- annot_coxph = FALSE,+ #' ) |
|||
| 204 |
- annot_stats = NULL,+ #' |
|||
| 205 |
- annot_stats_vlines = FALSE,+ #' @export |
|||
| 206 |
- control_coxph_pw = control_coxph(),+ tabulate_rsp_subgroups <- function(lyt, |
|||
| 207 |
- position_coxph = c(-0.03, -0.02),+ df, |
|||
| 208 |
- position_surv_med = c(0.95, 0.9),+ vars = c("n_tot", "n", "prop", "or", "ci")) {
|
|||
| 209 | -+ | 6x |
- width_annots = list(surv_med = grid::unit(0.3, "npc"), coxph = grid::unit(0.4, "npc"))) {
+ conf_level <- df$or$conf_level[1] |
|
| 210 | -8x | +6x |
- checkmate::assert_list(variables)+ method <- if ("pval_label" %in% names(df$or)) {
|
|
| 211 | -8x | +4x |
- checkmate::assert_subset(c("tte", "arm", "is_event"), names(variables))
+ df$or$pval_label[1] |
|
| 212 | -8x | +
- checkmate::assert_string(title, null.ok = TRUE)+ } else {
|
||
| 213 | -8x | +2x |
- checkmate::assert_string(footnotes, null.ok = TRUE)+ NULL |
|
| 214 | -8x | +
- checkmate::assert_character(col, null.ok = TRUE)+ } |
||
| 215 | -8x | +
- checkmate::assert_subset(annot_stats, c("median", "min"))
+
|
||
| 216 | -8x | +6x |
- checkmate::assert_logical(annot_stats_vlines)+ afun_lst <- a_response_subgroups() |
|
| 217 | -8x | +6x |
- checkmate::assert_true(all(sapply(width_annots, grid::is.unit)))+ colvars <- d_rsp_subgroups_colvars(vars, conf_level = conf_level, method = method) |
|
| 219 | -8x | +6x |
- tte <- variables$tte+ colvars_prop <- list( |
|
| 220 | -8x | +6x |
- is_event <- variables$is_event+ vars = colvars$vars[names(colvars$labels) %in% c("n", "prop", "n_rsp")],
|
|
| 221 | -8x | +6x |
- arm <- variables$arm+ labels = colvars$labels[names(colvars$labels) %in% c("n", "prop", "n_rsp")]
|
|
| 222 |
-
+ ) |
|||
| 223 | -8x | +6x |
- assert_valid_factor(df[[arm]])+ colvars_or <- list( |
|
| 224 | -8x | +6x |
- assert_df_with_variables(df, list(tte = tte, is_event = is_event, arm = arm))+ vars = colvars$vars[names(colvars$labels) %in% c("n_tot", "or", "ci", "pval")],
|
|
| 225 | -8x | +6x |
- checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)+ labels = colvars$labels[names(colvars$labels) %in% c("n_tot", "or", "ci", "pval")]
|
|
| 226 | -8x | +
- checkmate::assert_numeric(df[[tte]], min.len = 1, any.missing = FALSE)+ ) |
||
| 228 | -8x | +
- armval <- as.character(unique(df[[arm]]))+ # Columns from table_prop are optional. |
||
| 229 | -8x | +6x |
- if (annot_coxph && length(armval) < 2) {
+ if (length(colvars_prop$vars) > 0) {
|
|
| 230 | -! | +6x |
- stop(paste(+ lyt_prop <- split_cols_by(lyt = lyt, var = "arm") |
|
| 231 | -! | +6x |
- "When `annot_coxph` = TRUE, `df` must contain at least 2 levels of `variables$arm`",+ lyt_prop <- split_cols_by_multivar( |
|
| 232 | -! | +6x |
- "in order to calculate the hazard ratio."+ lyt = lyt_prop, |
|
| 233 | -+ | 6x |
- ))+ vars = colvars_prop$vars, |
|
| 234 | -8x | +6x |
- } else if (length(armval) > 1) {
+ varlabels = colvars_prop$labels |
|
| 235 | -8x | +
- armval <- NULL+ ) |
||
| 236 |
- }+ |
|||
| 237 | -8x | +
- yval <- match.arg(yval)+ # "All Patients" row |
||
| 238 | -8x | +6x |
- formula <- stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", arm))
+ lyt_prop <- split_rows_by( |
|
| 239 | -8x | +6x |
- fit_km <- survival::survfit(+ lyt = lyt_prop, |
|
| 240 | -8x | +6x |
- formula = formula,+ var = "row_type", |
|
| 241 | -8x | +6x |
- data = df,+ split_fun = keep_split_levels("content"),
|
|
| 242 | -8x | +6x |
- conf.int = control_surv$conf_level,+ nested = FALSE, |
|
| 243 | -8x | +6x |
- conf.type = control_surv$conf_type+ child_labels = "hidden" |
|
| 244 |
- )+ ) |
|||
| 245 | -8x | +6x |
- data_plot <- h_data_plot(+ lyt_prop <- analyze_colvars( |
|
| 246 | -8x | +6x |
- fit_km = fit_km,+ lyt = lyt_prop, |
|
| 247 | -8x | +6x |
- armval = armval,+ afun = afun_lst[names(colvars_prop$labels)] |
|
| 248 | -8x | +
- max_time = max_time+ ) |
||
| 249 |
- )+ |
|||
| 250 | -+ | 6x |
-
+ if ("analysis" %in% df$prop$row_type) {
|
|
| 251 | -8x | +5x |
- xticks <- h_xticks(data = data_plot, xticks = xticks, max_time = max_time)+ lyt_prop <- split_rows_by( |
|
| 252 | -8x | +5x |
- gg <- h_ggkm(+ lyt = lyt_prop, |
|
| 253 | -8x | +5x |
- data = data_plot,+ var = "row_type", |
|
| 254 | -8x | +5x |
- censor_show = censor_show,+ split_fun = keep_split_levels("analysis"),
|
|
| 255 | -8x | +5x |
- pch = pch,+ nested = FALSE, |
|
| 256 | -8x | +5x |
- size = size,+ child_labels = "hidden" |
|
| 257 | -8x | +
- xticks = xticks,+ ) |
||
| 258 | -8x | +5x |
- xlab = xlab,+ lyt_prop <- split_rows_by(lyt = lyt_prop, var = "var_label", nested = TRUE) |
|
| 259 | -8x | +5x |
- yval = yval,+ lyt_prop <- analyze_colvars( |
|
| 260 | -8x | +5x |
- ylab = ylab,+ lyt = lyt_prop, |
|
| 261 | -8x | +5x |
- ylim = ylim,+ afun = afun_lst[names(colvars_prop$labels)], |
|
| 262 | -8x | +5x |
- title = title,+ inclNAs = TRUE |
|
| 263 | -8x | +
- footnotes = footnotes,+ ) |
||
| 264 | -8x | +
- max_time = max_time,+ } |
||
| 265 | -8x | +
- lwd = lwd,+ |
||
| 266 | -8x | +6x |
- lty = lty,+ table_prop <- build_table(lyt_prop, df = df$prop) |
|
| 267 | -8x | +
- col = col,+ } else {
|
||
| 268 | -8x | +! |
- ggtheme = ggtheme,+ table_prop <- NULL |
|
| 269 | -8x | +
- ci_ribbon = ci_ribbon+ } |
||
| 270 |
- )+ |
|||
| 271 |
-
+ # Columns "n_tot", "or", "ci" in table_or are required. |
|||
| 272 | -8x | +6x |
- if (!is.null(annot_stats)) {
+ lyt_or <- split_cols_by(lyt = lyt, var = "arm") |
|
| 273 | -! | +6x |
- if ("median" %in% annot_stats) {
+ lyt_or <- split_cols_by_multivar( |
|
| 274 | -! | +6x |
- fit_km_all <- survival::survfit(+ lyt = lyt_or, |
|
| 275 | -! | +6x |
- formula = stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", 1)),
+ vars = colvars_or$vars, |
|
| 276 | -! | +6x |
- data = df,+ varlabels = colvars_or$labels |
|
| 277 | -! | +
- conf.int = control_surv$conf_level,+ ) |
||
| 278 | -! | +
- conf.type = control_surv$conf_type+ |
||
| 279 |
- )+ # "All Patients" row |
|||
| 280 | -! | +6x |
- gg <- gg ++ lyt_or <- split_rows_by( |
|
| 281 | -! | +6x |
- geom_text(+ lyt = lyt_or, |
|
| 282 | -! | +6x |
- size = 8 / ggplot2::.pt, col = 1,+ var = "row_type", |
|
| 283 | -! | +6x |
- x = stats::median(fit_km_all) + 0.065 * max(data_plot$time),+ split_fun = keep_split_levels("content"),
|
|
| 284 | -! | +6x |
- y = ifelse(yval == "Survival", 0.62, 0.38),+ nested = FALSE, |
|
| 285 | -! | +6x |
- label = paste("Median F/U:\n", round(stats::median(fit_km_all), 1), tolower(df$AVALU[1]))
+ child_labels = "hidden" |
|
| 286 |
- )+ ) |
|||
| 287 | -! | +6x |
- if (annot_stats_vlines) {
+ lyt_or <- analyze_colvars( |
|
| 288 | -! | +6x |
- gg <- gg ++ lyt = lyt_or, |
|
| 289 | -! | +6x |
- geom_segment(aes(x = stats::median(fit_km_all), xend = stats::median(fit_km_all), y = -Inf, yend = Inf),+ afun = afun_lst[names(colvars_or$labels)] |
|
| 290 | -! | +
- linetype = 2, col = "darkgray"+ ) %>% |
||
| 291 | -+ | 6x |
- )+ append_topleft("Baseline Risk Factors")
|
|
| 292 |
- }+ |
|||
| 293 | -+ | 6x |
- }+ if ("analysis" %in% df$or$row_type) {
|
|
| 294 | -! | +5x |
- if ("min" %in% annot_stats) {
+ lyt_or <- split_rows_by( |
|
| 295 | -! | +5x |
- min_fu <- min(df[[tte]])+ lyt = lyt_or, |
|
| 296 | -! | +5x |
- gg <- gg ++ var = "row_type", |
|
| 297 | -! | +5x |
- geom_text(+ split_fun = keep_split_levels("analysis"),
|
|
| 298 | -! | +5x |
- size = 8 / ggplot2::.pt, col = 1,+ nested = FALSE, |
|
| 299 | -! | +5x |
- x = min_fu + max(data_plot$time) * ifelse(yval == "Survival", 0.05, 0.07),+ child_labels = "hidden" |
|
| 300 | -! | +
- y = ifelse(yval == "Survival", 1.0, 0.05),+ ) |
||
| 301 | -! | +5x |
- label = paste("Min. F/U:\n", round(min_fu, 1), tolower(df$AVALU[1]))
+ lyt_or <- split_rows_by(lyt = lyt_or, var = "var_label", nested = TRUE) |
|
| 302 | -+ | 5x |
- )+ lyt_or <- analyze_colvars( |
|
| 303 | -! | +5x |
- if (annot_stats_vlines) {
+ lyt = lyt_or, |
|
| 304 | -! | +5x |
- gg <- gg ++ afun = afun_lst[names(colvars_or$labels)], |
|
| 305 | -! | +5x |
- geom_segment(aes(x = min_fu, xend = min_fu, y = Inf, yend = -Inf), linetype = 2, col = "darkgray")+ inclNAs = TRUE |
|
| 306 |
- }+ ) |
|||
| 307 |
- }+ } |
|||
| 308 | -! | +6x |
- gg <- gg + ggplot2::guides(fill = ggplot2::guide_legend(override.aes = list(shape = NA, label = "")))+ table_or <- build_table(lyt_or, df = df$or) |
|
| 309 |
- }+ |
|||
| 310 | -+ | 6x |
-
+ n_tot_id <- match("n_tot", colvars_or$vars)
|
|
| 311 | -8x | +6x |
- g_el <- h_decompose_gg(gg)+ if (is.null(table_prop)) {
|
|
| 312 | -+ | ! |
-
+ result <- table_or |
|
| 313 | -8x | +! |
- if (annot_at_risk) {
+ or_id <- match("or", colvars_or$vars)
|
|
| 314 | -+ | ! |
- # This is the content of the table that will be below the graph.+ ci_id <- match("lcl", colvars_or$vars)
|
|
| 315 | -6x | +
- annot_tbl <- summary(fit_km, time = xticks)+ } else {
|
||
| 316 | 6x |
- annot_tbl <- if (is.null(fit_km$strata)) {
+ result <- cbind_rtables(table_or[, n_tot_id], table_prop, table_or[, -n_tot_id]) |
||
| 317 | -! | +6x |
- data.frame(+ or_id <- 1L + ncol(table_prop) + match("or", colvars_or$vars[-n_tot_id])
|
|
| 318 | -! | +6x |
- n.risk = annot_tbl$n.risk,+ ci_id <- 1L + ncol(table_prop) + match("lcl", colvars_or$vars[-n_tot_id])
|
|
| 319 | -! | +6x |
- time = annot_tbl$time,+ n_tot_id <- 1L |
|
| 320 | -! | +
- strata = as.factor(armval)+ } |
||
| 321 | -+ | 6x |
- )+ structure( |
|
| 322 | -+ | 6x |
- } else {
+ result, |
|
| 323 | 6x |
- strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
+ forest_header = paste0(levels(df$prop$arm), "\nBetter"), |
||
| 324 | 6x |
- levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2]+ col_x = or_id, |
||
| 325 | 6x |
- data.frame(+ col_ci = ci_id, |
||
| 326 | 6x |
- n.risk = annot_tbl$n.risk,- |
- ||
| 327 | -6x | -
- time = annot_tbl$time,- |
- ||
| 328 | -6x | -
- strata = annot_tbl$strata+ col_symbol_size = n_tot_id |
||
| 329 | +327 |
- )+ ) |
||
| 330 | +328 |
- }+ } |
||
| 331 | +329 | |||
| 332 | -6x | -
- grobs_patient <- h_grob_tbl_at_risk(- |
- ||
| 333 | -6x | -
- data = data_plot,- |
- ||
| 334 | -6x | -
- annot_tbl = annot_tbl,- |
- ||
| 335 | -6x | -
- xlim = max(max_time, data_plot$time, xticks),- |
- ||
| 336 | -6x | -
- title = annot_at_risk_title- |
- ||
| 337 | +330 |
- )+ #' Labels for Column Variables in Binary Response by Subgroup Table |
||
| 338 | +331 |
- }+ #' |
||
| 339 | +332 | - - | -||
| 340 | -8x | -
- if (annot_at_risk || annot_surv_med || annot_coxph) {
- |
- ||
| 341 | -6x | -
- lyt <- h_km_layout(- |
- ||
| 342 | -6x | -
- data = data_plot, g_el = g_el, title = title, footnotes = footnotes,- |
- ||
| 343 | -6x | -
- annot_at_risk = annot_at_risk, annot_at_risk_title = annot_at_risk_title+ #' @description `r lifecycle::badge("stable")`
|
||
| 344 | +333 |
- )- |
- ||
| 345 | -6x | -
- at_risk_ttl <- as.numeric(annot_at_risk_title)- |
- ||
| 346 | -6x | -
- ttl_row <- as.numeric(!is.null(title))- |
- ||
| 347 | -6x | -
- foot_row <- as.numeric(!is.null(footnotes))- |
- ||
| 348 | -6x | -
- km_grob <- grid::gTree(- |
- ||
| 349 | -6x | -
- vp = grid::viewport(layout = lyt, height = .95, width = .95),- |
- ||
| 350 | -6x | -
- children = grid::gList(+ #' |
||
| 351 | +334 |
- # Title.- |
- ||
| 352 | -6x | -
- if (ttl_row == 1) {
- |
- ||
| 353 | -1x | -
- grid::gTree(- |
- ||
| 354 | -1x | -
- vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 2),- |
- ||
| 355 | -1x | -
- children = grid::gList(grid::textGrob(label = title, x = grid::unit(0, "npc"), hjust = 0))+ #' Internal function to check variables included in [tabulate_rsp_subgroups()] and create column labels. |
||
| 356 | +335 |
- )+ #' |
||
| 357 | +336 |
- },+ #' @inheritParams argument_convention |
||
| 358 | +337 |
-
+ #' @inheritParams tabulate_rsp_subgroups |
||
| 359 | +338 |
- # The Kaplan - Meier curve (top-right corner).- |
- ||
| 360 | -6x | -
- grid::gTree(- |
- ||
| 361 | -6x | -
- vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 2),- |
- ||
| 362 | -6x | -
- children = grid::gList(g_el$panel)+ #' |
||
| 363 | +339 |
- ),+ #' @return A `list` of variables to tabulate and their labels. |
||
| 364 | +340 |
-
+ #' |
||
| 365 | +341 |
- # Survfit summary table (top-right corner).- |
- ||
| 366 | -6x | -
- if (annot_surv_med) {
- |
- ||
| 367 | -5x | -
- grid::gTree(- |
- ||
| 368 | -5x | -
- vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 2),- |
- ||
| 369 | -5x | -
- children = h_grob_median_surv(- |
- ||
| 370 | -5x | -
- fit_km = fit_km,- |
- ||
| 371 | -5x | -
- armval = armval,- |
- ||
| 372 | -5x | -
- x = position_surv_med[1],- |
- ||
| 373 | -5x | -
- y = position_surv_med[2],- |
- ||
| 374 | -5x | -
- width = if (!is.null(width_annots[["surv_med"]])) width_annots[["surv_med"]] else grid::unit(0.3, "npc"),- |
- ||
| 375 | -5x | -
- ttheme = gridExtra::ttheme_default(base_size = font_size)+ #' @export |
||
| 376 | +342 |
- )+ d_rsp_subgroups_colvars <- function(vars, |
||
| 377 | +343 |
- )+ conf_level = NULL, |
||
| 378 | +344 |
- },- |
- ||
| 379 | -6x | -
- if (annot_coxph) {
- |
- ||
| 380 | -1x | -
- grid::gTree(- |
- ||
| 381 | -1x | -
- vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 2),- |
- ||
| 382 | -1x | -
- children = h_grob_coxph(- |
- ||
| 383 | -1x | -
- df = df,- |
- ||
| 384 | -1x | -
- variables = variables,- |
- ||
| 385 | -1x | -
- control_coxph_pw = control_coxph_pw,- |
- ||
| 386 | -1x | -
- x = position_coxph[1],- |
- ||
| 387 | -1x | -
- y = position_coxph[2],- |
- ||
| 388 | -1x | -
- width = if (!is.null(width_annots[["coxph"]])) width_annots[["coxph"]] else grid::unit(0.4, "npc"),+ method = NULL) {
|
||
| 389 | -1x | +345 | +13x |
- ttheme = gridExtra::ttheme_default(+ checkmate::assert_character(vars) |
| 390 | -1x | +346 | +13x |
- base_size = font_size,+ checkmate::assert_subset(c("n_tot", "or", "ci"), vars)
|
| 391 | -1x | +|||
| 347 | +13x |
- padding = grid::unit(c(1, .5), "lines"),+ checkmate::assert_subset( |
||
| 392 | -1x | +348 | +13x |
- core = list(bg_params = list(fill = c("grey95", "grey90"), alpha = .5))
+ vars, |
| 393 | -+ | |||
| 349 | +13x |
- )+ c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
|
||
| 394 | +350 |
- )+ ) |
||
| 395 | +351 |
- )+ |
||
| 396 | -+ | |||
| 352 | +13x |
- },+ varlabels <- c( |
||
| 397 | -+ | |||
| 353 | +13x |
-
+ n = "n", |
||
| 398 | -+ | |||
| 354 | +13x |
- # Add the y-axis annotation (top-left corner).+ n_rsp = "Responders", |
||
| 399 | -6x | +355 | +13x |
- grid::gTree(+ prop = "Response (%)", |
| 400 | -6x | +356 | +13x |
- vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 1),+ n_tot = "Total n", |
| 401 | -6x | +357 | +13x |
- children = h_grob_y_annot(ylab = g_el$ylab, yaxis = g_el$yaxis)+ or = "Odds Ratio" |
| 402 | +358 |
- ),+ )+ |
+ ||
| 359 | +13x | +
+ colvars <- vars |
||
| 403 | +360 | |||
| 361 | +13x | +
+ if ("ci" %in% colvars) {
+ |
+ ||
| 362 | +13x | +
+ checkmate::assert_false(is.null(conf_level))+ |
+ ||
| 404 | +363 |
- # Add the x-axis annotation (second row below the Kaplan Meier Curve).+ |
||
| 405 | -6x | +364 | +13x |
- grid::gTree(+ varlabels <- c( |
| 406 | -6x | +365 | +13x |
- vp = grid::viewport(layout.pos.row = 2 + ttl_row, layout.pos.col = 2),+ varlabels, |
| 407 | -6x | +366 | +13x |
- children = grid::gList(rbind(g_el$xaxis, g_el$xlab))+ ci = paste0(100 * conf_level, "% CI") |
| 408 | +367 |
- ),+ ) |
||
| 409 | +368 | |||
| 410 | +369 |
- # Add the legend.+ # The `lcl`` variable is just a placeholder available in the analysis data, |
||
| 411 | -6x | +|||
| 370 | +
- grid::gTree(+ # it is not acutally used in the tabulation. |
|||
| 412 | -6x | +|||
| 371 | +
- vp = grid::viewport(layout.pos.row = 3 + ttl_row, layout.pos.col = 2),+ # Variables used in the tabulation are lcl and ucl, see `a_response_subgroups` for details. |
|||
| 413 | -6x | +372 | +13x |
- children = grid::gList(g_el$guide)+ colvars[colvars == "ci"] <- "lcl" |
| 414 | +373 |
- ),+ } |
||
| 415 | +374 | |||
| 416 | -- |
- # Add the table with patient-at-risk numbers.- |
- ||
| 417 | -6x | +375 | +13x |
- if (annot_at_risk && annot_at_risk_title) {
+ if ("pval" %in% colvars) {
|
| 418 | -6x | +376 | +10x |
- grid::gTree(+ varlabels <- c( |
| 419 | -6x | +377 | +10x |
- vp = grid::viewport(layout.pos.row = 4 + ttl_row, layout.pos.col = 1),+ varlabels, |
| 420 | -6x | +378 | +10x |
- children = grobs_patient$title+ pval = method |
| 421 | +379 |
- )+ ) |
||
| 422 | +380 |
- },+ } |
||
| 423 | -6x | +|||
| 381 | +
- if (annot_at_risk) {
+
|
|||
| 424 | -6x | +382 | +13x |
- grid::gTree(+ list( |
| 425 | -6x | +383 | +13x |
- vp = grid::viewport(layout.pos.row = 4 + at_risk_ttl + ttl_row, layout.pos.col = 2),+ vars = colvars, |
| 426 | -6x | +384 | +13x |
- children = grobs_patient$at_risk+ labels = varlabels[vars] |
| 427 | +385 |
- )+ ) |
||
| 428 | +386 |
- },+ } |
||
| 429 | -6x | +
| 1 | +
- if (annot_at_risk) {
+ #' Create a Forest Plot based on a Table |
|||
| 430 | -6x | +|||
| 2 | +
- grid::gTree(+ #' |
|||
| 431 | -6x | +|||
| 3 | +
- vp = grid::viewport(layout.pos.row = 4 + at_risk_ttl + ttl_row, layout.pos.col = 1),+ #' Create a forest plot from any [rtables::rtable()] object that has a |
|||
| 432 | -6x | +|||
| 4 | +
- children = grobs_patient$label+ #' column with a single value and a column with 2 values. |
|||
| 433 | +5 |
- )+ #' |
||
| 434 | +6 |
- },+ #' @description `r lifecycle::badge("stable")`
|
||
| 435 | -6x | +|||
| 7 | +
- if (annot_at_risk) {
+ #' |
|||
| 436 | +8 |
- # Add the x-axis for the table.+ #' @inheritParams grid::gTree |
||
| 437 | -6x | +|||
| 9 | +
- grid::gTree(+ #' @inheritParams argument_convention |
|||
| 438 | -6x | +|||
| 10 | +
- vp = grid::viewport(layout.pos.row = 5 + at_risk_ttl + ttl_row, layout.pos.col = 2),+ #' @param tbl (`rtable`) |
|||
| 439 | -6x | +|||
| 11 | +
- children = grid::gList(rbind(g_el$xaxis, g_el$xlab))+ #' @param col_x (`integer`)\cr column index with estimator. By default tries to get this from |
|||
| 440 | +12 |
- )+ #' `tbl` attribute `col_x`, otherwise needs to be manually specified. |
||
| 441 | +13 |
- },+ #' @param col_ci (`integer`)\cr column index with confidence intervals. By default tries |
||
| 442 | +14 |
-
+ #' to get this from `tbl` attribute `col_ci`, otherwise needs to be manually specified. |
||
| 443 | +15 |
- # Footnotes.+ #' @param vline (`number`)\cr x coordinate for vertical line, if `NULL` then the line is omitted. |
||
| 444 | -6x | +|||
| 16 | +
- if (foot_row == 1) {
+ #' @param forest_header (`character`, length 2)\cr text displayed to the left and right of `vline`, respectively. |
|||
| 445 | -1x | +|||
| 17 | +
- grid::gTree(+ #' If `vline = NULL` then `forest_header` needs to be `NULL` too. |
|||
| 446 | -1x | +|||
| 18 | +
- vp = grid::viewport(+ #' By default tries to get this from `tbl` attribute `forest_header`. |
|||
| 447 | -1x | +|||
| 19 | +
- layout.pos.row = ifelse(annot_at_risk, 6 + at_risk_ttl + ttl_row, 4 + ttl_row),+ #' @param xlim (`numeric`)\cr limits for x axis. |
|||
| 448 | -1x | +|||
| 20 | +
- layout.pos.col = 2+ #' @param logx (`flag`)\cr show the x-values on logarithm scale. |
|||
| 449 | +21 |
- ),+ #' @param x_at (`numeric`)\cr x-tick locations, if `NULL` they get automatically chosen. |
||
| 450 | -1x | +|||
| 22 | +
- children = grid::gList(grid::textGrob(label = footnotes, x = grid::unit(0, "npc"), hjust = 0))+ #' @param width_row_names (`unit`)\cr width for row names. |
|||
| 451 | +23 |
- )+ #' If `NULL` the widths get automatically calculated. See [grid::unit()]. |
||
| 452 | +24 |
- }+ #' @param width_columns (`unit`)\cr widths for the table columns. |
||
| 453 | +25 |
- )+ #' If `NULL` the widths get automatically calculated. See [grid::unit()]. |
||
| 454 | +26 |
- )+ #' @param width_forest (`unit`)\cr width for the forest column. |
||
| 455 | +27 |
-
+ #' If `NULL` the widths get automatically calculated. See [grid::unit()]. |
||
| 456 | -6x | +|||
| 28 | +
- result <- grid::gTree(+ #' @param col_symbol_size (`integer`)\cr column index from `tbl` containing data to be used |
|||
| 457 | -6x | +|||
| 29 | +
- vp = vp,+ #' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional |
|||
| 458 | -6x | +|||
| 30 | +
- gp = gp,+ #' to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups. |
|||
| 459 | -6x | +|||
| 31 | +
- name = name,+ #' By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified. |
|||
| 460 | -6x | +|||
| 32 | +
- children = grid::gList(km_grob)+ #' @param col (`character`)\cr color(s). |
|||
| 461 | +33 |
- )+ #' |
||
| 462 | +34 |
- } else {
+ #' @return `gTree` object containing the forest plot and table. |
||
| 463 | -2x | +|||
| 35 | +
- result <- grid::gTree(+ #' |
|||
| 464 | -2x | +|||
| 36 | +
- vp = vp,+ #' @examples |
|||
| 465 | -2x | +|||
| 37 | +
- gp = gp,+ #' \donttest{
|
|||
| 466 | -2x | +|||
| 38 | +
- name = name,+ #' library(dplyr) |
|||
| 467 | -2x | +|||
| 39 | +
- children = grid::gList(ggplot2::ggplotGrob(gg))+ #' library(forcats) |
|||
| 468 | +40 |
- )+ #' library(nestcolor) |
||
| 469 | +41 |
- }+ #' |
||
| 470 | +42 |
-
+ #' adrs <- tern_ex_adrs |
||
| 471 | -5x | +|||
| 43 | +
- if (newpage && draw) grid::grid.newpage()+ #' n_records <- 20 |
|||
| 472 | -5x | +|||
| 44 | +
- if (draw) grid::grid.draw(result)+ #' adrs_labels <- formatters::var_labels(adrs, fill = TRUE) |
|||
| 473 | -8x | +|||
| 45 | +
- invisible(result)+ #' adrs <- adrs %>% |
|||
| 474 | +46 |
- }+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 475 | +47 |
-
+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
|
||
| 476 | +48 |
- #' Helper function: tidy survival fit+ #' slice(seq_len(n_records)) %>% |
||
| 477 | +49 |
- #'+ #' droplevels() %>% |
||
| 478 | +50 |
- #' @description `r lifecycle::badge("stable")`
+ #' mutate( |
||
| 479 | +51 |
- #'+ #' # Reorder levels of factor to make the placebo group the reference arm. |
||
| 480 | +52 |
- #' Convert the survival fit data into a data frame designed for plotting+ #' ARM = fct_relevel(ARM, "B: Placebo"), |
||
| 481 | +53 |
- #' within `g_km`.+ #' rsp = AVALC == "CR" |
||
| 482 | +54 |
- #'+ #' ) |
||
| 483 | +55 |
- #' This starts from the [broom::tidy()] result, and then:+ #' formatters::var_labels(adrs) <- c(adrs_labels, "Response") |
||
| 484 | +56 |
- #' * Post-processes the `strata` column into a factor.+ #' df <- extract_rsp_subgroups( |
||
| 485 | +57 |
- #' * Extends each stratum by an additional first row with time 0 and probability 1 so that+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")),
|
||
| 486 | +58 |
- #' downstream plot lines start at those coordinates.+ #' data = adrs |
||
| 487 | +59 |
- #' * Adds a `censor` column.+ #' ) |
||
| 488 | +60 |
- #' * Filters the rows before `max_time`.+ #' # Full commonly used response table. |
||
| 489 | +61 |
#' |
||
| 490 | +62 |
- #' @inheritParams g_km+ #' tbl <- basic_table() %>% |
||
| 491 | +63 |
- #' @param fit_km (`survfit`)\cr result of [survival::survfit()].+ #' tabulate_rsp_subgroups(df) |
||
| 492 | +64 |
- #' @param armval (`string`)\cr used as strata name when treatment arm variable only has one level. Default is `"All"`.+ #' p <- g_forest(tbl, gp = grid::gpar(fontsize = 10)) |
||
| 493 | +65 |
#' |
||
| 494 | +66 |
- #' @return A `tibble` with columns `time`, `n.risk`, `n.event`, `n.censor`, `estimate`, `std.error`, `conf.high`,+ #' draw_grob(p) |
||
| 495 | +67 |
- #' `conf.low`, `strata`, and `censor`.+ #' |
||
| 496 | +68 |
- #'+ #' # Odds ratio only table. |
||
| 497 | +69 |
- #' @examples+ #' |
||
| 498 | +70 |
- #' \donttest{
+ #' tbl_or <- basic_table() %>% |
||
| 499 | +71 |
- #' library(dplyr)+ #' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci"))
|
||
| 500 | +72 |
- #' library(survival)+ #' tbl_or |
||
| 501 | +73 |
- #'+ #' p <- g_forest( |
||
| 502 | +74 |
- #' # Test with multiple arms+ #' tbl_or, |
||
| 503 | +75 |
- #' tern_ex_adtte %>%+ #' forest_header = c("Comparison\nBetter", "Treatment\nBetter")
|
||
| 504 | +76 |
- #' filter(PARAMCD == "OS") %>%+ #' ) |
||
| 505 | +77 |
- #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ #' |
||
| 506 | +78 |
- #' h_data_plot()+ #' draw_grob(p) |
||
| 507 | +79 |
#' |
||
| 508 | +80 |
- #' # Test with single arm+ #' # Survival forest plot example. |
||
| 509 | +81 |
- #' tern_ex_adtte %>%+ #' adtte <- tern_ex_adtte |
||
| 510 | +82 |
- #' filter(PARAMCD == "OS", ARMCD == "ARM B") %>%+ #' # Save variable labels before data processing steps. |
||
| 511 | +83 |
- #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ #' adtte_labels <- formatters::var_labels(adtte, fill = TRUE) |
||
| 512 | +84 |
- #' h_data_plot(armval = "ARM B")+ #' adtte_f <- adtte %>% |
||
| 513 | +85 |
- #' }+ #' filter( |
||
| 514 | +86 |
- #'+ #' PARAMCD == "OS", |
||
| 515 | +87 |
- #' @export+ #' ARM %in% c("B: Placebo", "A: Drug X"),
|
||
| 516 | +88 |
- h_data_plot <- function(fit_km,+ #' SEX %in% c("M", "F")
|
||
| 517 | +89 |
- armval = "All",+ #' ) %>% |
||
| 518 | +90 |
- max_time = NULL) {
+ #' mutate( |
||
| 519 | -15x | +|||
| 91 | +
- y <- broom::tidy(fit_km)+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
|||
| 520 | +92 |
-
+ #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")), |
||
| 521 | -15x | +|||
| 93 | +
- if (!is.null(fit_km$strata)) {
+ #' SEX = droplevels(SEX), |
|||
| 522 | -15x | +|||
| 94 | +
- fit_km_var_level <- strsplit(sub("=", "equals", names(fit_km$strata)), "equals")
+ #' AVALU = as.character(AVALU), |
|||
| 523 | -15x | +|||
| 95 | +
- strata_levels <- vapply(fit_km_var_level, FUN = "[", FUN.VALUE = "a", i = 2)+ #' is_event = CNSR == 0 |
|||
| 524 | -15x | +|||
| 96 | +
- strata_var_level <- strsplit(sub("=", "equals", y$strata), "equals")
+ #' ) |
|||
| 525 | -15x | +|||
| 97 | +
- y$strata <- factor(+ #' labels <- list( |
|||
| 526 | -15x | +|||
| 98 | +
- vapply(strata_var_level, FUN = "[", FUN.VALUE = "a", i = 2),+ #' "ARM" = adtte_labels["ARM"], |
|||
| 527 | -15x | +|||
| 99 | +
- levels = strata_levels+ #' "SEX" = adtte_labels["SEX"], |
|||
| 528 | +100 |
- )+ #' "AVALU" = adtte_labels["AVALU"], |
||
| 529 | +101 |
- } else {
+ #' "is_event" = "Event Flag" |
||
| 530 | -! | +|||
| 102 | +
- y$strata <- armval+ #' ) |
|||
| 531 | +103 |
- }+ #' formatters::var_labels(adtte_f)[names(labels)] <- as.character(labels) |
||
| 532 | +104 |
-
+ #' df <- extract_survival_subgroups( |
||
| 533 | -15x | +|||
| 105 | +
- y_by_strata <- split(y, y$strata)+ #' variables = list( |
|||
| 534 | -15x | +|||
| 106 | +
- y_by_strata_extended <- lapply(+ #' tte = "AVAL", |
|||
| 535 | -15x | +|||
| 107 | +
- y_by_strata,+ #' is_event = "is_event", |
|||
| 536 | -15x | +|||
| 108 | +
- FUN = function(tbl) {
+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
|
|||
| 537 | -44x | +|||
| 109 | +
- first_row <- tbl[1L, ]+ #' ), |
|||
| 538 | -44x | +|||
| 110 | +
- first_row$time <- 0+ #' data = adtte_f |
|||
| 539 | -44x | +|||
| 111 | +
- first_row$n.risk <- sum(first_row[, c("n.risk", "n.event", "n.censor")])
+ #' ) |
|||
| 540 | -44x | +|||
| 112 | +
- first_row$n.event <- first_row$n.censor <- 0+ #' table_hr <- basic_table() %>% |
|||
| 541 | -44x | +|||
| 113 | +
- first_row$estimate <- first_row$conf.high <- first_row$conf.low <- 1+ #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) |
|||
| 542 | -44x | +|||
| 114 | +
- first_row$std.error <- 0+ #' g_forest(table_hr) |
|||
| 543 | -44x | +|||
| 115 | +
- rbind(+ #' # Works with any `rtable`. |
|||
| 544 | -44x | +|||
| 116 | +
- first_row,+ #' tbl <- rtable( |
|||
| 545 | -44x | +|||
| 117 | +
- tbl+ #' header = c("E", "CI", "N"),
|
|||
| 546 | +118 |
- )+ #' rrow("", 1, c(.8, 1.2), 200),
|
||
| 547 | +119 |
- }+ #' rrow("", 1.2, c(1.1, 1.4), 50)
|
||
| 548 | +120 |
- )+ #' ) |
||
| 549 | -15x | +|||
| 121 | +
- y <- do.call(rbind, y_by_strata_extended)+ #' g_forest( |
|||
| 550 | +122 |
-
+ #' tbl = tbl, |
||
| 551 | -15x | +|||
| 123 | +
- y$censor <- ifelse(y$n.censor > 0, y$estimate, NA)+ #' col_x = 1, |
|||
| 552 | -15x | +|||
| 124 | +
- if (!is.null(max_time)) {
+ #' col_ci = 2, |
|||
| 553 | -3x | +|||
| 125 | +
- y <- y[y$time <= max(max_time), ]+ #' xlim = c(0.5, 2), |
|||
| 554 | +126 |
- }+ #' x_at = c(0.5, 1, 2), |
||
| 555 | -15x | +|||
| 127 | +
- y+ #' col_symbol_size = 3 |
|||
| 556 | +128 |
- }+ #' ) |
||
| 557 | +129 |
-
+ #' tbl <- rtable( |
||
| 558 | +130 |
- #' Helper function: x tick positions+ #' header = rheader( |
||
| 559 | +131 |
- #'+ #' rrow("", rcell("A", colspan = 2)),
|
||
| 560 | +132 |
- #' @description `r lifecycle::badge("stable")`
+ #' rrow("", "c1", "c2")
|
||
| 561 | +133 |
- #'+ #' ), |
||
| 562 | +134 |
- #' Calculate the positions of ticks on the x-axis. However, if `xticks` already+ #' rrow("row 1", 1, c(.8, 1.2)),
|
||
| 563 | +135 |
- #' exists it is kept as is. It is based on the same function `ggplot2` relies on,+ #' rrow("row 2", 1.2, c(1.1, 1.4))
|
||
| 564 | +136 |
- #' and is required in the graphic and the patient-at-risk annotation table.+ #' ) |
||
| 565 | +137 |
- #'+ #' g_forest( |
||
| 566 | +138 |
- #' @inheritParams g_km+ #' tbl = tbl, |
||
| 567 | +139 |
- #' @inheritParams h_ggkm+ #' col_x = 1, |
||
| 568 | +140 |
- #'+ #' col_ci = 2, |
||
| 569 | +141 |
- #' @return A vector of positions to use for x-axis ticks on a `ggplot` object.+ #' xlim = c(0.5, 2), |
||
| 570 | +142 |
- #'+ #' x_at = c(0.5, 1, 2), |
||
| 571 | +143 |
- #' @examples+ #' vline = 1, |
||
| 572 | +144 |
- #' \donttest{
+ #' forest_header = c("Hello", "World")
|
||
| 573 | +145 |
- #' library(dplyr)+ #' ) |
||
| 574 | +146 |
- #' library(survival)+ #' } |
||
| 575 | +147 |
#' |
||
| 576 | +148 |
- #' data <- tern_ex_adtte %>%+ #' @export |
||
| 577 | +149 |
- #' filter(PARAMCD == "OS") %>%+ g_forest <- function(tbl, |
||
| 578 | +150 |
- #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ col_x = attr(tbl, "col_x"), |
||
| 579 | +151 |
- #' h_data_plot()+ col_ci = attr(tbl, "col_ci"), |
||
| 580 | +152 |
- #'+ vline = 1, |
||
| 581 | +153 |
- #' h_xticks(data)+ forest_header = attr(tbl, "forest_header"), |
||
| 582 | +154 |
- #' h_xticks(data, xticks = seq(0, 3000, 500))+ xlim = c(0.1, 10), |
||
| 583 | +155 |
- #' h_xticks(data, xticks = 500)+ logx = TRUE, |
||
| 584 | +156 |
- #' h_xticks(data, xticks = 500, max_time = 6000)+ x_at = c(0.1, 1, 10), |
||
| 585 | +157 |
- #' h_xticks(data, xticks = c(0, 500), max_time = 300)+ width_row_names = NULL, |
||
| 586 | +158 |
- #' h_xticks(data, xticks = 500, max_time = 300)+ width_columns = NULL, |
||
| 587 | +159 |
- #' }+ width_forest = grid::unit(1, "null"), |
||
| 588 | +160 |
- #'+ col_symbol_size = attr(tbl, "col_symbol_size"), |
||
| 589 | +161 |
- #' @export+ col = getOption("ggplot2.discrete.colour")[1],
|
||
| 590 | +162 |
- h_xticks <- function(data, xticks = NULL, max_time = NULL) {
+ gp = NULL, |
||
| 591 | -15x | +|||
| 163 | +
- if (is.null(xticks)) {
+ draw = TRUE, |
|||
| 592 | -9x | +|||
| 164 | +
- if (is.null(max_time)) {
+ newpage = TRUE) {
|
|||
| 593 | -7x | +165 | +2x |
- labeling::extended(range(data$time)[1], range(data$time)[2], m = 5)+ checkmate::assert_class(tbl, "VTableTree") |
| 594 | +166 |
- } else {
+
|
||
| 595 | +167 | 2x |
- labeling::extended(range(data$time)[1], max(range(data$time)[2], max_time), m = 5)- |
- |
| 596 | -- |
- }+ nr <- nrow(tbl) |
||
| 597 | -6x | +168 | +2x |
- } else if (checkmate::test_number(xticks)) {
+ nc <- ncol(tbl) |
| 598 | -3x | +169 | +2x |
- if (is.null(max_time)) {
+ if (is.null(col)) {
|
| 599 | +170 | 2x |
- seq(0, max(data$time), xticks)+ col <- "blue" |
|
| 600 | +171 |
- } else {
- |
- ||
| 601 | -1x | -
- seq(0, max(data$time, max_time), xticks)+ } |
||
| 602 | +172 |
- }+ |
||
| 603 | -3x | +173 | +2x |
- } else if (is.numeric(xticks)) {
+ checkmate::assert_number(col_x, lower = 0, upper = nc, null.ok = FALSE) |
| 604 | +174 | 2x |
- xticks+ checkmate::assert_number(col_ci, lower = 0, upper = nc, null.ok = FALSE) |
|
| 605 | -+ | |||
| 175 | +2x |
- } else {
+ checkmate::assert_number(col_symbol_size, lower = 0, upper = nc, null.ok = TRUE) |
||
| 606 | -1x | +176 | +2x |
- stop(+ checkmate::assert_true(col_x > 0) |
| 607 | -1x | +177 | +2x |
- paste(+ checkmate::assert_true(col_ci > 0) |
| 608 | -1x | +178 | +2x |
- "xticks should be either `NULL`",+ checkmate::assert_character(col) |
| 609 | -1x | +179 | +2x |
- "or a single number (interval between x ticks)",+ if (!is.null(col_symbol_size)) {
|
| 610 | +180 | 1x |
- "or a numeric vector (position of ticks on the x axis)"- |
- |
| 611 | -- |
- )- |
- ||
| 612 | -- |
- )+ checkmate::assert_true(col_symbol_size > 0) |
||
| 613 | +181 |
} |
||
| 614 | -- |
- }- |
- ||
| 615 | +182 | |||
| 616 | -- |
- #' Helper function: KM plot- |
- ||
| 617 | -- |
- #'- |
- ||
| 618 | -+ | |||
| 183 | +2x |
- #' @description `r lifecycle::badge("stable")`
+ x_e <- vapply(seq_len(nr), function(i) {
|
||
| 619 | +184 |
- #'+ # If a label row is selected NULL is returned with a warning (suppressed) |
||
| 620 | -+ | |||
| 185 | +9x |
- #' Draw the Kaplan-Meier plot using `ggplot2`.+ xi <- suppressWarnings(as.vector(tbl[i, col_x, drop = TRUE])) |
||
| 621 | +186 |
- #'+ |
||
| 622 | -+ | |||
| 187 | +9x |
- #' @inheritParams g_km+ if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) {
|
||
| 623 | -+ | |||
| 188 | +7x |
- #' @param data (`data.frame`)\cr survival data as pre-processed by `h_data_plot`.+ xi |
||
| 624 | +189 |
- #'+ } else {
|
||
| 625 | -+ | |||
| 190 | +2x |
- #' @return A `ggplot` object.+ NA_real_ |
||
| 626 | +191 |
- #'+ } |
||
| 627 | -+ | |||
| 192 | +2x |
- #' @examples+ }, numeric(1)) |
||
| 628 | +193 |
- #' \donttest{
+
|
||
| 629 | -+ | |||
| 194 | +2x |
- #' library(dplyr)+ x_ci <- lapply(seq_len(nr), function(i) {
|
||
| 630 | -+ | |||
| 195 | +9x |
- #' library(survival)+ xi <- suppressWarnings(as.vector(tbl[i, col_ci, drop = TRUE])) # as above |
||
| 631 | +196 |
- #'+ |
||
| 632 | -+ | |||
| 197 | +9x |
- #' fit_km <- tern_ex_adtte %>%+ if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) {
|
||
| 633 | -+ | |||
| 198 | +7x |
- #' filter(PARAMCD == "OS") %>%+ if (length(xi) != 2) {
|
||
| 634 | -+ | |||
| 199 | +! |
- #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ stop("ci column needs two elements")
|
||
| 635 | +200 |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ } |
||
| 636 | -+ | |||
| 201 | +7x |
- #' xticks <- h_xticks(data = data_plot)+ xi |
||
| 637 | +202 |
- #' gg <- h_ggkm(+ } else {
|
||
| 638 | -+ | |||
| 203 | +2x |
- #' data = data_plot,+ c(NA_real_, NA_real_) |
||
| 639 | +204 |
- #' censor_show = TRUE,+ } |
||
| 640 | +205 |
- #' xticks = xticks,+ }) |
||
| 641 | +206 |
- #' xlab = "Days",+ |
||
| 642 | -+ | |||
| 207 | +2x |
- #' yval = "Survival",+ lower <- vapply(x_ci, `[`, numeric(1), 1) |
||
| 643 | -+ | |||
| 208 | +2x |
- #' ylab = "Survival Probability",+ upper <- vapply(x_ci, `[`, numeric(1), 2) |
||
| 644 | +209 |
- #' title = "Survival"+ |
||
| 645 | -+ | |||
| 210 | +2x |
- #' )+ symbol_size <- if (!is.null(col_symbol_size)) {
|
||
| 646 | -+ | |||
| 211 | +1x |
- #' gg+ tmp_symbol_size <- vapply(seq_len(nr), function(i) {
|
||
| 647 | -+ | |||
| 212 | +7x |
- #' }+ suppressWarnings(xi <- as.vector(tbl[i, col_symbol_size, drop = TRUE])) |
||
| 648 | +213 |
- #'+ |
||
| 649 | -+ | |||
| 214 | +7x |
- #' @export+ if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) {
|
||
| 650 | -+ | |||
| 215 | +5x |
- h_ggkm <- function(data,+ xi |
||
| 651 | +216 |
- xticks = NULL,+ } else {
|
||
| 652 | -+ | |||
| 217 | +1x |
- yval = "Survival",+ NA_real_ |
||
| 653 | +218 |
- censor_show,+ } |
||
| 654 | -+ | |||
| 219 | +1x |
- xlab,+ }, numeric(1)) |
||
| 655 | +220 |
- ylab,+ |
||
| 656 | +221 |
- ylim = NULL,+ # Scale symbol size. |
||
| 657 | -+ | |||
| 222 | +1x |
- title,+ tmp_symbol_size <- sqrt(tmp_symbol_size) |
||
| 658 | -+ | |||
| 223 | +1x |
- footnotes = NULL,+ max_size <- max(tmp_symbol_size, na.rm = TRUE) |
||
| 659 | +224 |
- max_time = NULL,+ # Biggest points have radius is 2 * (1/3.5) lines not to overlap. |
||
| 660 | +225 |
- lwd = 1,+ # See forest_dot_line. |
||
| 661 | -+ | |||
| 226 | +1x |
- lty = NULL,+ 2 * tmp_symbol_size / max_size |
||
| 662 | +227 |
- pch = 3,+ } else {
|
||
| 663 | -+ | |||
| 228 | +1x |
- size = 2,+ NULL |
||
| 664 | +229 |
- col = NULL,+ } |
||
| 665 | +230 |
- ci_ribbon = FALSE,+ |
||
| 666 | -+ | |||
| 231 | +2x |
- ggtheme = nestcolor::theme_nest()) {
+ grob_forest <- forest_grob( |
||
| 667 | -8x | +232 | +2x |
- checkmate::assert_numeric(lty, null.ok = TRUE)+ tbl, |
| 668 | -8x | +233 | +2x |
- checkmate::assert_character(col, null.ok = TRUE)+ x_e, |
| 669 | -+ | |||
| 234 | +2x |
-
+ lower, |
||
| 670 | -8x | +235 | +2x |
- if (is.null(ylim)) {
+ upper, |
| 671 | -8x | +236 | +2x |
- data_lims <- data+ vline, |
| 672 | -1x | +237 | +2x |
- if (yval == "Failure") data_lims[["estimate"]] <- 1 - data_lims[["estimate"]]+ forest_header, |
| 673 | -8x | +238 | +2x |
- if (!is.null(max_time)) {
+ xlim, |
| 674 | -1x | +239 | +2x |
- y_lwr <- min(data_lims[data_lims$time < max_time, ][["estimate"]])+ logx, |
| 675 | -1x | +240 | +2x |
- y_upr <- max(data_lims[data_lims$time < max_time, ][["estimate"]])+ x_at, |
| 676 | -+ | |||
| 241 | +2x |
- } else {
+ width_row_names, |
||
| 677 | -7x | +242 | +2x |
- y_lwr <- min(data_lims[["estimate"]])+ width_columns, |
| 678 | -7x | +243 | +2x |
- y_upr <- max(data_lims[["estimate"]])+ width_forest, |
| 679 | -+ | |||
| 244 | +2x |
- }+ symbol_size = symbol_size, |
||
| 680 | -8x | +245 | +2x |
- ylim <- c(y_lwr, y_upr)+ col = col, |
| 681 | -+ | |||
| 246 | +2x |
- }+ gp = gp, |
||
| 682 | -8x | +247 | +2x |
- checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE)+ vp = grid::plotViewport(margins = rep(1, 4)) |
| 683 | +248 |
-
+ ) |
||
| 684 | +249 |
- # change estimates of survival to estimates of failure (1 - survival)- |
- ||
| 685 | -8x | -
- if (yval == "Failure") {
+
|
||
| 686 | -1x | +250 | +2x |
- data$estimate <- 1 - data$estimate+ if (draw) {
|
| 687 | -1x | +|||
| 251 | +! |
- data[c("conf.high", "conf.low")] <- list(1 - data$conf.low, 1 - data$conf.high)
+ if (newpage) grid::grid.newpage() |
||
| 688 | -1x | +|||
| 252 | +! |
- data$censor <- 1 - data$censor+ grid::grid.draw(grob_forest) |
||
| 689 | +253 |
} |
||
| 690 | +254 | |||
| 691 | -8x | -
- gg <- {
- |
- ||
| 692 | -8x | -
- ggplot2::ggplot(- |
- ||
| 693 | -8x | -
- data = data,- |
- ||
| 694 | -8x | -
- mapping = ggplot2::aes(- |
- ||
| 695 | -8x | -
- x = .data[["time"]],- |
- ||
| 696 | -8x | -
- y = .data[["estimate"]],- |
- ||
| 697 | -8x | -
- ymin = .data[["conf.low"]],- |
- ||
| 698 | -8x | -
- ymax = .data[["conf.high"]],- |
- ||
| 699 | -8x | +255 | +2x |
- color = .data[["strata"]],+ invisible(grob_forest) |
| 700 | -8x | +|||
| 256 | +
- fill = .data[["strata"]]+ } |
|||
| 701 | +257 |
- )+ |
||
| 702 | +258 |
- ) ++ #' Forest Plot Grob |
||
| 703 | -8x | +|||
| 259 | +
- ggplot2::geom_hline(yintercept = 0)+ #' |
|||
| 704 | +260 |
- }+ #' @inheritParams g_forest |
||
| 705 | +261 |
-
+ #' @param tbl ([rtables::rtable()]) |
||
| 706 | -8x | +|||
| 262 | +
- if (ci_ribbon) {
+ #' @param x (`numeric`)\cr coordinate of point. |
|||
| 707 | -1x | +|||
| 263 | +
- gg <- gg + ggplot2::geom_ribbon(alpha = .3, lty = 0)+ #' @param lower,upper (`numeric`)\cr lower/upper bound of the confidence interval. |
|||
| 708 | +264 |
- }+ #' @param symbol_size (`numeric`)\cr vector with relative size for plot symbol. |
||
| 709 | +265 |
-
+ #' If `NULL`, the same symbol size is used. |
||
| 710 | -8x | +|||
| 266 | +
- gg <- if (is.null(lty)) {
+ #' |
|||
| 711 | -7x | +|||
| 267 | +
- gg ++ #' @details |
|||
| 712 | -7x | +|||
| 268 | +
- ggplot2::geom_step(linewidth = lwd)+ #' The heights get automatically determined. |
|||
| 713 | -8x | +|||
| 269 | +
- } else if (checkmate::test_number(lty)) {
+ #' |
|||
| 714 | -1x | +|||
| 270 | +
- gg ++ #' @noRd |
|||
| 715 | -1x | +|||
| 271 | +
- ggplot2::geom_step(linewidth = lwd, lty = lty)+ #' |
|||
| 716 | -8x | +|||
| 272 | +
- } else if (is.numeric(lty)) {
+ #' @examples |
|||
| 717 | -! | +|||
| 273 | +
- gg ++ #' tbl <- rtable( |
|||
| 718 | -! | +|||
| 274 | +
- ggplot2::geom_step(mapping = ggplot2::aes(linetype = .data[["strata"]]), linewidth = lwd) ++ #' header = rheader( |
|||
| 719 | -! | +|||
| 275 | +
- ggplot2::scale_linetype_manual(values = lty)+ #' rrow("", "E", rcell("CI", colspan = 2), "N"),
|
|||
| 720 | +276 |
- }+ #' rrow("", "A", "B", "C", "D")
|
||
| 721 | +277 |
-
+ #' ), |
||
| 722 | -8x | +|||
| 278 | +
- gg <- gg ++ #' rrow("row 1", 1, 0.8, 1.1, 16),
|
|||
| 723 | -8x | +|||
| 279 | +
- ggplot2::coord_cartesian(ylim = ylim) ++ #' rrow("row 2", 1.4, 0.8, 1.6, 25),
|
|||
| 724 | -8x | +|||
| 280 | +
- ggplot2::labs(x = xlab, y = ylab, title = title, caption = footnotes)+ #' rrow("row 3", 1.2, 0.8, 1.6, 36)
|
|||
| 725 | +281 |
-
+ #' ) |
||
| 726 | -8x | +|||
| 282 | +
- if (!is.null(col)) {
+ #' |
|||
| 727 | -! | +|||
| 283 | +
- gg <- gg ++ #' x <- c(1, 1.4, 1.2) |
|||
| 728 | -! | +|||
| 284 | +
- ggplot2::scale_color_manual(values = col) ++ #' lower <- c(0.8, 0.8, 0.8) |
|||
| 729 | -! | +|||
| 285 | +
- ggplot2::scale_fill_manual(values = col)+ #' upper <- c(1.1, 1.6, 1.6) |
|||
| 730 | +286 |
- }+ #' # numeric vector with multiplication factor to scale each circle radius |
||
| 731 | -8x | +|||
| 287 | +
- if (censor_show) {
+ #' # default radius is 1/3.5 lines |
|||
| 732 | -8x | +|||
| 288 | +
- dt <- data[data$n.censor != 0, ]+ #' symbol_scale <- c(1, 1.25, 1.5) |
|||
| 733 | -8x | +|||
| 289 | +
- dt$censor_lbl <- factor("Censored")
+ #' |
|||
| 734 | +290 |
-
+ #' # Internal function - forest_grob |
||
| 735 | -8x | +|||
| 291 | +
- gg <- gg + ggplot2::geom_point(+ #' \donttest{
|
|||
| 736 | -8x | +|||
| 292 | +
- data = dt,+ #' p <- forest_grob(tbl, x, lower, upper, |
|||
| 737 | -8x | +|||
| 293 | +
- ggplot2::aes(+ #' vline = 1, forest_header = c("A", "B"),
|
|||
| 738 | -8x | +|||
| 294 | +
- x = .data[["time"]],+ #' x_at = c(.1, 1, 10), xlim = c(0.1, 10), logx = TRUE, symbol_size = symbol_scale, |
|||
| 739 | -8x | +|||
| 295 | +
- y = .data[["censor"]],+ #' vp = grid::plotViewport(margins = c(1, 1, 1, 1)) |
|||
| 740 | -8x | +|||
| 296 | +
- shape = .data[["censor_lbl"]]+ #' ) |
|||
| 741 | +297 |
- ),+ #' |
||
| 742 | -8x | +|||
| 298 | +
- size = size,+ #' draw_grob(p) |
|||
| 743 | -8x | +|||
| 299 | +
- show.legend = TRUE,+ #' } |
|||
| 744 | -8x | +|||
| 300 | +
- inherit.aes = TRUE+ forest_grob <- function(tbl, |
|||
| 745 | +301 |
- ) ++ x, |
||
| 746 | -8x | +|||
| 302 | +
- ggplot2::scale_shape_manual(name = NULL, values = pch) ++ lower, |
|||
| 747 | -8x | +|||
| 303 | +
- ggplot2::guides(+ upper, |
|||
| 748 | -8x | +|||
| 304 | +
- shape = ggplot2::guide_legend(override.aes = list(linetype = NA)),+ vline, |
|||
| 749 | -8x | +|||
| 305 | +
- fill = ggplot2::guide_legend(override.aes = list(shape = NA))+ forest_header, |
|||
| 750 | +306 |
- )+ xlim = NULL, |
||
| 751 | +307 |
- }+ logx = FALSE, |
||
| 752 | +308 |
-
+ x_at = NULL, |
||
| 753 | -8x | +|||
| 309 | +
- if (!is.null(max_time) && !is.null(xticks)) {
+ width_row_names = NULL, |
|||
| 754 | -1x | +|||
| 310 | +
- gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, xticks), max(c(xticks, max_time))))+ width_columns = NULL, |
|||
| 755 | -7x | +|||
| 311 | +
- } else if (!is.null(xticks)) {
+ width_forest = grid::unit(1, "null"), |
|||
| 756 | -7x | +|||
| 312 | +
- if (max(data$time) <= max(xticks)) {
+ symbol_size = NULL, |
|||
| 757 | -6x | +|||
| 313 | +
- gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, min(xticks)), max(xticks)))+ col = "blue", |
|||
| 758 | +314 |
- } else {
+ name = NULL, |
||
| 759 | -1x | +|||
| 315 | +
- gg <- gg + ggplot2::scale_x_continuous(breaks = xticks)+ gp = NULL, |
|||
| 760 | +316 |
- }+ vp = NULL) {
|
||
| 761 | -! | +|||
| 317 | +2x |
- } else if (!is.null(max_time)) {
+ nr <- nrow(tbl) |
||
| 762 | -! | +|||
| 318 | +2x |
- gg <- gg + ggplot2::scale_x_continuous(limits = c(0, max_time))+ if (is.null(vline)) {
|
||
| 763 | -+ | |||
| 319 | +! |
- }+ checkmate::assert_true(is.null(forest_header)) |
||
| 764 | +320 |
-
+ } else {
|
||
| 765 | -8x | +321 | +2x |
- if (!is.null(ggtheme)) {
+ checkmate::assert_number(vline) |
| 766 | -8x | +322 | +2x |
- gg <- gg + ggtheme+ checkmate::assert_character(forest_header, len = 2, null.ok = TRUE) |
| 767 | +323 |
} |
||
| 768 | +324 | |||
| 769 | -8x | +325 | +2x |
- gg + ggplot2::theme(+ checkmate::assert_numeric(x, len = nr) |
| 770 | -8x | +326 | +2x |
- legend.position = "bottom",+ checkmate::assert_numeric(lower, len = nr) |
| 771 | -8x | +327 | +2x |
- legend.title = ggplot2::element_blank(),+ checkmate::assert_numeric(upper, len = nr) |
| 772 | -8x | +328 | +2x |
- legend.key.height = unit(0.02, "npc"),+ checkmate::assert_numeric(symbol_size, len = nr, null.ok = TRUE) |
| 773 | -8x | +329 | +2x |
- panel.grid.major.x = ggplot2::element_line(linewidth = 2)+ checkmate::assert_character(col) |
| 774 | +330 |
- )+ |
||
| 775 | -+ | |||
| 331 | +2x |
- }+ if (is.null(symbol_size)) {
|
||
| 776 | -+ | |||
| 332 | +1x |
-
+ symbol_size <- rep(1, nr) |
||
| 777 | +333 |
- #' `ggplot` Decomposition+ } |
||
| 778 | +334 |
- #'+ |
||
| 779 | -+ | |||
| 335 | +2x |
- #' @description `r lifecycle::badge("stable")`
+ if (is.null(xlim)) {
|
||
| 780 | -+ | |||
| 336 | +! |
- #'+ r <- range(c(x, lower, upper), na.rm = TRUE) |
||
| 781 | -+ | |||
| 337 | +! |
- #' The elements composing the `ggplot` are extracted and organized in a `list`.+ xlim <- r + c(-0.05, 0.05) * diff(r) |
||
| 782 | +338 |
- #'+ } |
||
| 783 | +339 |
- #' @param gg (`ggplot`)\cr a graphic to decompose.+ |
||
| 784 | -+ | |||
| 340 | +2x |
- #'+ if (logx) {
|
||
| 785 | -+ | |||
| 341 | +2x |
- #' @return A named `list` with elements:+ if (is.null(x_at)) {
|
||
| 786 | -+ | |||
| 342 | +! |
- #' * `panel`: The panel.+ x_at <- pretty(log(stats::na.omit(c(x, lower, upper)))) |
||
| 787 | -+ | |||
| 343 | +! |
- #' * `yaxis`: The y-axis.+ x_labels <- exp(x_at) |
||
| 788 | +344 |
- #' * `xaxis`: The x-axis.+ } else {
|
||
| 789 | -+ | |||
| 345 | +2x |
- #' * `xlab`: The x-axis label.+ x_labels <- x_at |
||
| 790 | -+ | |||
| 346 | +2x |
- #' * `ylab`: The y-axis label.+ x_at <- log(x_at) |
||
| 791 | +347 |
- #' * `guide`: The legend.+ } |
||
| 792 | -+ | |||
| 348 | +2x |
- #'+ xlim <- log(xlim) |
||
| 793 | -+ | |||
| 349 | +2x |
- #' @examples+ x <- log(x) |
||
| 794 | -+ | |||
| 350 | +2x |
- #' \donttest{
+ lower <- log(lower) |
||
| 795 | -+ | |||
| 351 | +2x |
- #' library(dplyr)+ upper <- log(upper) |
||
| 796 | -+ | |||
| 352 | +2x |
- #' library(survival)+ if (!is.null(vline)) {
|
||
| 797 | -+ | |||
| 353 | +2x |
- #' library(grid)+ vline <- log(vline) |
||
| 798 | +354 |
- #'+ } |
||
| 799 | +355 |
- #' fit_km <- tern_ex_adtte %>%+ } else {
|
||
| 800 | -+ | |||
| 356 | +! |
- #' filter(PARAMCD == "OS") %>%+ x_labels <- TRUE |
||
| 801 | +357 |
- #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ } |
||
| 802 | +358 |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ |
||
| 803 | -+ | |||
| 359 | +2x |
- #' xticks <- h_xticks(data = data_plot)+ data_forest_vp <- grid::dataViewport(xlim, c(0, 1)) |
||
| 804 | +360 |
- #' gg <- h_ggkm(+ |
||
| 805 | +361 |
- #' data = data_plot,+ # Get table content as matrix form. |
||
| 806 | -+ | |||
| 362 | +2x |
- #' yval = "Survival",+ mf <- matrix_form(tbl) |
||
| 807 | +363 |
- #' censor_show = TRUE,+ |
||
| 808 | +364 |
- #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ # Use `rtables` indent_string eventually. |
||
| 809 | -+ | |||
| 365 | +2x |
- #' title = "tt",+ mf$strings[, 1] <- paste0( |
||
| 810 | -+ | |||
| 366 | +2x |
- #' footnotes = "ff"+ strrep(" ", c(rep(0, attr(mf, "nrow_header")), mf$row_info$indent)),
|
||
| 811 | -+ | |||
| 367 | +2x |
- #' )+ mf$strings[, 1] |
||
| 812 | +368 |
- #'+ ) |
||
| 813 | +369 |
- #' g_el <- h_decompose_gg(gg)+ |
||
| 814 | -+ | |||
| 370 | +2x |
- #' grid::grid.newpage()+ n_header <- attr(mf, "nrow_header") |
||
| 815 | +371 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "red", fill = "gray85", lwd = 5))+ |
||
| 816 | -+ | |||
| 372 | +! |
- #' grid::grid.draw(g_el$panel)+ if (any(mf$display[, 1] == FALSE)) stop("row names need to be always displayed")
|
||
| 817 | +373 |
- #'+ |
||
| 818 | +374 |
- #' grid::grid.newpage()+ # Pre-process the data to be used in lapply and cell_in_rows. |
||
| 819 | -+ | |||
| 375 | +2x |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "royalblue", fill = "gray85", lwd = 5))+ to_args_for_cell_in_rows_fun <- function(part = c("body", "header"),
|
||
| 820 | -+ | |||
| 376 | +2x |
- #' grid::grid.draw(with(g_el, cbind(ylab, yaxis)))+ underline_colspan = FALSE) {
|
||
| 821 | -+ | |||
| 377 | +4x |
- #' }+ part <- match.arg(part) |
||
| 822 | -+ | |||
| 378 | +4x |
- #'+ if (part == "body") {
|
||
| 823 | -+ | |||
| 379 | +2x |
- #' @export+ mat_row_indices <- seq_len(nrow(tbl)) + n_header+ |
+ ||
| 380 | +2x | +
+ row_ind_offset <- -n_header |
||
| 824 | +381 |
- h_decompose_gg <- function(gg) {
+ } else {
|
||
| 825 | -8x | +382 | +2x |
- g_el <- ggplot2::ggplotGrob(gg)+ mat_row_indices <- seq_len(n_header) |
| 826 | -8x | +383 | +2x |
- y <- c(+ row_ind_offset <- 0+ |
+
| 384 | ++ |
+ }+ |
+ ||
| 385 | ++ | + | ||
| 827 | -8x | +386 | +4x |
- panel = "panel",+ lapply(mat_row_indices, function(i) {
|
| 828 | -8x | +387 | +13x |
- yaxis = "axis-l",+ disp <- mf$display[i, -1] |
| 829 | -8x | +388 | +13x |
- xaxis = "axis-b",+ list( |
| 830 | -8x | +389 | +13x |
- xlab = "xlab-b",+ row_name = mf$strings[i, 1], |
| 831 | -8x | +390 | +13x |
- ylab = "ylab-l",+ cells = mf$strings[i, -1][disp], |
| 832 | -8x | +391 | +13x |
- guide = "guide"+ cell_spans = mf$spans[i, -1][disp], |
| 833 | -+ | |||
| 392 | +13x |
- )+ row_index = i + row_ind_offset, |
||
| 834 | -8x | +393 | +13x |
- lapply(X = y, function(x) gtable::gtable_filter(g_el, x))+ underline_colspan = underline_colspan |
| 835 | +394 |
- }+ ) |
||
| 836 | +395 |
-
+ }) |
||
| 837 | +396 |
- #' Helper: KM Layout+ } |
||
| 838 | +397 |
- #'+ |
||
| 839 | -+ | |||
| 398 | +2x |
- #' @description `r lifecycle::badge("stable")`
+ args_header <- to_args_for_cell_in_rows_fun("header", underline_colspan = TRUE)
|
||
| 840 | -+ | |||
| 399 | +2x |
- #'+ args_body <- to_args_for_cell_in_rows_fun("body", underline_colspan = FALSE)
|
||
| 841 | +400 |
- #' Prepares a (5 rows) x (2 cols) layout for the Kaplan-Meier curve.+ |
||
| 842 | -+ | |||
| 401 | +2x |
- #'+ grid::gTree( |
||
| 843 | -+ | |||
| 402 | +2x |
- #' @inheritParams g_km+ name = name, |
||
| 844 | -+ | |||
| 403 | +2x |
- #' @inheritParams h_ggkm+ children = grid::gList( |
||
| 845 | -+ | |||
| 404 | +2x |
- #' @param g_el (`list` of `gtable`)\cr list as obtained by `h_decompose_gg()`.+ grid::gTree( |
||
| 846 | -+ | |||
| 405 | +2x |
- #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of+ children = do.call(grid::gList, lapply(args_header, do.call, what = cell_in_rows)), |
||
| 847 | -+ | |||
| 406 | +2x |
- #' patient at risk matching the main grid of the Kaplan-Meier curve.+ vp = grid::vpPath("vp_table_layout", "vp_header")
|
||
| 848 | +407 |
- #'+ ), |
||
| 849 | -+ | |||
| 408 | +2x |
- #' @return A grid layout.+ grid::gTree( |
||
| 850 | -+ | |||
| 409 | +2x |
- #'+ children = do.call(grid::gList, lapply(args_body, do.call, what = cell_in_rows)), |
||
| 851 | -+ | |||
| 410 | +2x |
- #' @details The layout corresponds to a grid of two columns and five rows of unequal dimensions. Most of the+ vp = grid::vpPath("vp_table_layout", "vp_body")
|
||
| 852 | +411 |
- #' dimension are fixed, only the curve is flexible and will accommodate with the remaining free space.+ ), |
||
| 853 | -+ | |||
| 412 | +2x |
- #' * The left column gets the annotation of the `ggplot` (y-axis) and the names of the strata for the patient+ grid::linesGrob( |
||
| 854 | -+ | |||
| 413 | +2x |
- #' at risk tabulation. The main constraint is about the width of the columns which must allow the writing of+ grid::unit(c(0, 1), "npc"), |
||
| 855 | -+ | |||
| 414 | +2x |
- #' the strata name.+ y = grid::unit(c(.5, .5), "npc"), |
||
| 856 | -+ | |||
| 415 | +2x |
- #' * The right column receive the `ggplot`, the legend, the x-axis and the patient at risk table.+ vp = grid::vpPath("vp_table_layout", "vp_spacer")
|
||
| 857 | +416 |
- #'+ ), |
||
| 858 | +417 |
- #' @examples+ # forest part |
||
| 859 | -+ | |||
| 418 | +2x |
- #' \donttest{
+ if (is.null(vline)) {
|
||
| 860 | -+ | |||
| 419 | +! |
- #' library(dplyr)+ NULL |
||
| 861 | +420 |
- #' library(survival)+ } else {
|
||
| 862 | -+ | |||
| 421 | +2x |
- #' library(grid)+ grid::gTree( |
||
| 863 | -+ | |||
| 422 | +2x |
- #'+ children = grid::gList( |
||
| 864 | -+ | |||
| 423 | +2x |
- #' fit_km <- tern_ex_adtte %>%+ grid::gTree( |
||
| 865 | -+ | |||
| 424 | +2x |
- #' filter(PARAMCD == "OS") %>%+ children = grid::gList( |
||
| 866 | +425 |
- #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ # this may overflow, to fix, look here |
||
| 867 | +426 |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ # https://stackoverflow.com/questions/33623169/add-multi-line-footnote-to-tablegrob-while-using-gridextra-in-r #nolintr |
||
| 868 | -+ | |||
| 427 | +2x |
- #' xticks <- h_xticks(data = data_plot)+ grid::textGrob( |
||
| 869 | -+ | |||
| 428 | +2x |
- #' gg <- h_ggkm(+ forest_header[1], |
||
| 870 | -+ | |||
| 429 | +2x |
- #' data = data_plot,+ x = grid::unit(vline, "native") - grid::unit(1, "lines"), |
||
| 871 | -+ | |||
| 430 | +2x |
- #' censor_show = TRUE,+ just = c("right", "center")
|
||
| 872 | +431 |
- #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ ), |
||
| 873 | -+ | |||
| 432 | +2x |
- #' title = "tt", footnotes = "ff", yval = "Survival"+ grid::textGrob( |
||
| 874 | -+ | |||
| 433 | +2x |
- #' )+ forest_header[2], |
||
| 875 | -+ | |||
| 434 | +2x |
- #' g_el <- h_decompose_gg(gg)+ x = grid::unit(vline, "native") + grid::unit(1, "lines"), |
||
| 876 | -+ | |||
| 435 | +2x |
- #' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f")+ just = c("left", "center")
|
||
| 877 | +436 |
- #' grid.show.layout(lyt)+ ) |
||
| 878 | +437 |
- #' }+ ), |
||
| 879 | -+ | |||
| 438 | +2x |
- #'+ vp = grid::vpStack(grid::viewport(layout.pos.col = ncol(tbl) + 2), data_forest_vp) |
||
| 880 | +439 |
- #' @export+ ) |
||
| 881 | +440 |
- h_km_layout <- function(data, g_el, title, footnotes, annot_at_risk = TRUE, annot_at_risk_title = TRUE) {
+ ), |
||
| 882 | -6x | +441 | +2x |
- txtlines <- levels(as.factor(data$strata))+ vp = grid::vpPath("vp_table_layout", "vp_header")
|
| 883 | -6x | +|||
| 442 | +
- nlines <- nlevels(as.factor(data$strata))+ ) |
|||
| 884 | -6x | +|||
| 443 | +
- col_annot_width <- max(+ }, |
|||
| 885 | -6x | +444 | +2x |
- c(+ grid::gTree( |
| 886 | -6x | +445 | +2x |
- as.numeric(grid::convertX(g_el$yaxis$width + g_el$ylab$width, "pt")),+ children = grid::gList( |
| 887 | -6x | +446 | +2x |
- as.numeric(+ grid::gTree( |
| 888 | -6x | +447 | +2x |
- grid::convertX(+ children = grid::gList( |
| 889 | -6x | -
- grid::stringWidth(txtlines) + grid::unit(7, "pt"), "pt"- |
- ||
| 890 | -- |
- )- |
- ||
| 891 | -+ | 448 | +2x |
- )+ grid::rectGrob(gp = grid::gpar(col = "gray90", fill = "gray90")), |
| 892 | -+ | |||
| 449 | +2x |
- )+ if (is.null(vline)) {
|
||
| 893 | -+ | |||
| 450 | +! |
- )+ NULL |
||
| 894 | +451 |
-
+ } else {
|
||
| 895 | -6x | +452 | +2x |
- ttl_row <- as.numeric(!is.null(title))+ grid::linesGrob( |
| 896 | -6x | +453 | +2x |
- foot_row <- as.numeric(!is.null(footnotes))+ x = grid::unit(rep(vline, 2), "native"), |
| 897 | -6x | +454 | +2x |
- no_tbl_ind <- c()+ y = grid::unit(c(0, 1), "npc"), |
| 898 | -6x | +455 | +2x |
- ht_x <- c()+ gp = grid::gpar(lwd = 2), |
| 899 | -6x | +456 | +2x |
- ht_units <- c()+ vp = data_forest_vp |
| 900 | +457 |
-
+ ) |
||
| 901 | -6x | +|||
| 458 | +
- if (ttl_row == 1) {
+ }, |
|||
| 902 | -1x | +459 | +2x |
- no_tbl_ind <- c(no_tbl_ind, TRUE)+ grid::xaxisGrob(at = x_at, label = x_labels, vp = data_forest_vp) |
| 903 | -1x | +|||
| 460 | +
- ht_x <- c(ht_x, 2)+ ), |
|||
| 904 | -1x | +461 | +2x |
- ht_units <- c(ht_units, "lines")+ vp = grid::viewport(layout.pos.col = ncol(tbl) + 2) |
| 905 | +462 |
- }+ ) |
||
| 906 | +463 | - - | -||
| 907 | -6x | -
- no_tbl_ind <- c(no_tbl_ind, rep(TRUE, 3), rep(FALSE, 2))+ ), |
||
| 908 | -6x | +464 | +2x |
- ht_x <- c(+ vp = grid::vpPath("vp_table_layout", "vp_body")
|
| 909 | -6x | +|||
| 465 | +
- ht_x,+ ), |
|||
| 910 | -6x | +466 | +2x |
- 1,+ grid::gTree( |
| 911 | -6x | +467 | +2x |
- grid::convertX(with(g_el, xaxis$height + ylab$width), "pt") + grid::unit(5, "pt"),+ children = do.call( |
| 912 | -6x | +468 | +2x |
- grid::convertX(g_el$guide$heights, "pt") + grid::unit(2, "pt"),+ grid::gList, |
| 913 | -6x | +469 | +2x |
- 1,+ Map( |
| 914 | -6x | +470 | +2x |
- nlines + 0.5,+ function(xi, li, ui, row_index, size_i, col) {
|
| 915 | -6x | -
- grid::convertX(with(g_el, xaxis$height + ylab$width), "pt")- |
- ||
| 916 | -+ | 471 | +9x |
- )+ forest_dot_line( |
| 917 | -6x | +472 | +9x |
- ht_units <- c(+ xi, |
| 918 | -6x | +473 | +9x |
- ht_units,+ li, |
| 919 | -6x | +474 | +9x |
- "null",+ ui, |
| 920 | -6x | +475 | +9x |
- "pt",+ row_index, |
| 921 | -6x | +476 | +9x |
- "pt",+ xlim, |
| 922 | -6x | +477 | +9x |
- "lines",+ symbol_size = size_i, |
| 923 | -6x | +478 | +9x |
- "lines",+ col = col, |
| 924 | -6x | +479 | +9x |
- "pt"+ datavp = data_forest_vp |
| 925 | +480 |
- )+ ) |
||
| 926 | +481 |
-
+ }, |
||
| 927 | -6x | +482 | +2x |
- if (foot_row == 1) {
+ x, |
| 928 | -1x | +483 | +2x |
- no_tbl_ind <- c(no_tbl_ind, TRUE)+ lower, |
| 929 | -1x | +484 | +2x |
- ht_x <- c(ht_x, 1)+ upper, |
| 930 | -1x | -
- ht_units <- c(ht_units, "lines")- |
- ||
| 931 | -+ | 485 | +2x |
- }+ seq_along(x), |
| 932 | -6x | +486 | +2x |
- if (annot_at_risk) {
+ symbol_size, |
| 933 | -6x | +487 | +2x |
- no_at_risk_tbl <- rep(TRUE, 6 + ttl_row + foot_row)+ col, |
| 934 | -6x | -
- if (!annot_at_risk_title) {
- |
- ||
| 935 | -! | +488 | +2x |
- no_at_risk_tbl[length(no_at_risk_tbl) - 2 - foot_row] <- FALSE+ USE.NAMES = FALSE |
| 936 | +489 |
- }+ ) |
||
| 937 | +490 |
- } else {
+ ), |
||
| 938 | -! | +|||
| 491 | +2x |
- no_at_risk_tbl <- no_tbl_ind+ vp = grid::vpPath("vp_table_layout", "vp_body")
|
||
| 939 | +492 |
- }+ ) |
||
| 940 | +493 | - - | -||
| 941 | -6x | -
- grid::grid.layout(- |
- ||
| 942 | -6x | -
- nrow = sum(no_at_risk_tbl), ncol = 2,- |
- ||
| 943 | -6x | -
- widths = grid::unit(c(col_annot_width, 1), c("pt", "null")),
+ ), |
||
| 944 | -6x | +494 | +2x |
- heights = grid::unit(+ childrenvp = forest_viewport(tbl, width_row_names, width_columns, width_forest), |
| 945 | -6x | +495 | +2x |
- x = ht_x[no_at_risk_tbl],+ vp = vp, |
| 946 | -6x | -
- units = ht_units[no_at_risk_tbl]- |
- ||
| 947 | -+ | 496 | +2x |
- )+ gp = gp |
| 948 | +497 |
) |
||
| 949 | +498 |
} |
||
| 950 | +499 | |||
| 951 | +500 |
- #' Helper: Patient-at-Risk Grobs+ |
||
| 952 | +501 |
- #'+ cell_in_rows <- function(row_name, |
||
| 953 | +502 |
- #' @description `r lifecycle::badge("stable")`
+ cells, |
||
| 954 | +503 |
- #'+ cell_spans, |
||
| 955 | +504 |
- #' Two graphical objects are obtained, one corresponding to row labeling and the second to the table of+ row_index, |
||
| 956 | +505 |
- #' numbers of patients at risk. If `title = TRUE`, a third object corresponding to the table title is+ underline_colspan = FALSE) {
|
||
| 957 | -+ | |||
| 506 | +13x |
- #' also obtained.+ checkmate::assert_string(row_name) |
||
| 958 | -+ | |||
| 507 | +13x |
- #'+ checkmate::assert_character(cells, min.len = 1, any.missing = FALSE) |
||
| 959 | -+ | |||
| 508 | +13x |
- #' @inheritParams g_km+ checkmate::assert_numeric(cell_spans, len = length(cells), any.missing = FALSE) |
||
| 960 | -+ | |||
| 509 | +13x |
- #' @inheritParams h_ggkm+ checkmate::assert_number(row_index) |
||
| 961 | -+ | |||
| 510 | +13x |
- #' @param annot_tbl (`data.frame`)\cr annotation as prepared by [survival::summary.survfit()] which+ checkmate::assert_flag(underline_colspan) |
||
| 962 | +511 |
- #' includes the number of patients at risk at given time points.+ |
||
| 963 | -+ | |||
| 512 | +13x |
- #' @param xlim (`numeric`)\cr the maximum value on the x-axis (used to+ vp_name_rn <- paste0("rowname-", row_index)
|
||
| 964 | -+ | |||
| 513 | +13x |
- #' ensure the at risk table aligns with the KM graph).+ g_rowname <- if (!is.null(row_name) && row_name != "") {
|
||
| 965 | -+ | |||
| 514 | +10x |
- #' @param title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk`+ grid::textGrob( |
||
| 966 | -+ | |||
| 515 | +10x |
- #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`.+ name = vp_name_rn, |
||
| 967 | -+ | |||
| 516 | +10x |
- #'+ label = row_name, |
||
| 968 | -+ | |||
| 517 | +10x |
- #' @return A named `list` of two `gTree` objects if `title = FALSE`: `at_risk` and `label`, or three+ x = grid::unit(0, "npc"), |
||
| 969 | -+ | |||
| 518 | +10x |
- #' `gTree` objects if `title = TRUE`: `at_risk`, `label`, and `title`.+ just = c("left", "center"),
|
||
| 970 | -+ | |||
| 519 | +10x |
- #'+ vp = grid::vpPath(paste0("rowname-", row_index))
|
||
| 971 | +520 |
- #' @examples+ ) |
||
| 972 | +521 |
- #' \donttest{
+ } else {
|
||
| 973 | -+ | |||
| 522 | +3x |
- #' library(dplyr)+ NULL |
||
| 974 | +523 |
- #' library(survival)+ } |
||
| 975 | +524 |
- #' library(grid)+ |
||
| 976 | -+ | |||
| 525 | +13x |
- #'+ gl_cols <- if (!(length(cells) > 0)) {
|
||
| 977 | -+ | |||
| 526 | +! |
- #' fit_km <- tern_ex_adtte %>%+ list(NULL) |
||
| 978 | +527 |
- #' filter(PARAMCD == "OS") %>%+ } else {
|
||
| 979 | -+ | |||
| 528 | +13x |
- #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ j <- 1 # column index of cell |
||
| 980 | +529 |
- #'+ |
||
| 981 | -+ | |||
| 530 | +13x |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ lapply(seq_along(cells), function(k) {
|
||
| 982 | -+ | |||
| 531 | +67x |
- #'+ cell_ascii <- cells[[k]] |
||
| 983 | -+ | |||
| 532 | +67x |
- #' xticks <- h_xticks(data = data_plot)+ cs <- cell_spans[[k]] |
||
| 984 | +533 |
- #'+ |
||
| 985 | -+ | |||
| 534 | +67x |
- #' gg <- h_ggkm(+ if (is.na(cell_ascii) || is.null(cell_ascii)) {
|
||
| 986 | -+ | |||
| 535 | +! |
- #' data = data_plot,+ cell_ascii <- "NA" |
||
| 987 | +536 |
- #' censor_show = TRUE,+ } |
||
| 988 | +537 |
- #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ |
||
| 989 | -+ | |||
| 538 | +67x |
- #' title = "tt", footnotes = "ff", yval = "Survival"+ cell_name <- paste0("g-cell-", row_index, "-", j)
|
||
| 990 | +539 |
- #' )+ |
||
| 991 | -+ | |||
| 540 | +67x |
- #'+ cell_grobs <- if (identical(cell_ascii, "")) {
|
||
| 992 | -+ | |||
| 541 | +14x |
- #' # The annotation table reports the patient at risk for a given strata and+ NULL |
||
| 993 | +542 |
- #' # time (`xticks`).+ } else {
|
||
| 994 | -+ | |||
| 543 | +53x |
- #' annot_tbl <- summary(fit_km, time = xticks)+ if (cs == 1) {
|
||
| 995 | -+ | |||
| 544 | +49x |
- #' if (is.null(fit_km$strata)) {
+ grid::textGrob( |
||
| 996 | -+ | |||
| 545 | +49x |
- #' annot_tbl <- with(annot_tbl, data.frame(n.risk = n.risk, time = time, strata = "All"))+ label = cell_ascii, |
||
| 997 | -+ | |||
| 546 | +49x |
- #' } else {
+ name = cell_name, |
||
| 998 | -+ | |||
| 547 | +49x |
- #' strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
+ vp = grid::vpPath(paste0("cell-", row_index, "-", j))
|
||
| 999 | +548 |
- #' levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2]+ ) |
||
| 1000 | +549 |
- #' annot_tbl <- data.frame(+ } else {
|
||
| 1001 | +550 |
- #' n.risk = annot_tbl$n.risk,+ # +1 because of rowname |
||
| 1002 | -+ | |||
| 551 | +4x |
- #' time = annot_tbl$time,+ vp_joined_cols <- grid::viewport(layout.pos.row = row_index, layout.pos.col = seq(j + 1, j + cs)) |
||
| 1003 | +552 |
- #' strata = annot_tbl$strata+ |
||
| 1004 | -+ | |||
| 553 | +4x |
- #' )+ lab <- grid::textGrob( |
||
| 1005 | -+ | |||
| 554 | +4x |
- #' }+ label = cell_ascii, |
||
| 1006 | -+ | |||
| 555 | +4x |
- #'+ name = cell_name, |
||
| 1007 | -+ | |||
| 556 | +4x |
- #' # The annotation table is transformed into a grob.+ vp = vp_joined_cols |
||
| 1008 | +557 |
- #' tbl <- h_grob_tbl_at_risk(data = data_plot, annot_tbl = annot_tbl, xlim = max(xticks))+ ) |
||
| 1009 | +558 |
- #'+ |
||
| 1010 | -+ | |||
| 559 | +4x |
- #' # For the representation, the layout is estimated for which the decomposition+ if (!underline_colspan || grepl("^[[:space:]]*$", cell_ascii)) {
|
||
| 1011 | -+ | |||
| 560 | +1x |
- #' # of the graphic element is necessary.+ lab |
||
| 1012 | +561 |
- #' g_el <- h_decompose_gg(gg)+ } else {
|
||
| 1013 | -+ | |||
| 562 | +3x |
- #' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f")+ grid::gList( |
||
| 1014 | -+ | |||
| 563 | +3x |
- #'+ lab, |
||
| 1015 | -+ | |||
| 564 | +3x |
- #' grid::grid.newpage()+ grid::linesGrob( |
||
| 1016 | -+ | |||
| 565 | +3x |
- #' pushViewport(viewport(layout = lyt, height = .95, width = .95))+ x = grid::unit.c(grid::unit(.2, "lines"), grid::unit(1, "npc") - grid::unit(.2, "lines")), |
||
| 1017 | -+ | |||
| 566 | +3x |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "purple", fill = "gray85", lwd = 1))+ y = grid::unit(c(0, 0), "npc"), |
||
| 1018 | -+ | |||
| 567 | +3x |
- #' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 2))+ vp = vp_joined_cols |
||
| 1019 | +568 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "orange", fill = "gray85", lwd = 1))+ ) |
||
| 1020 | +569 |
- #' grid::grid.draw(tbl$at_risk)+ ) |
||
| 1021 | +570 |
- #' popViewport()+ } |
||
| 1022 | +571 |
- #' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 1))+ } |
||
| 1023 | +572 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "green3", fill = "gray85", lwd = 1))+ } |
||
| 1024 | -+ | |||
| 573 | +67x |
- #' grid::grid.draw(tbl$label)+ j <<- j + cs |
||
| 1025 | +574 |
- #' }+ |
||
| 1026 | -+ | |||
| 575 | +67x |
- #'+ cell_grobs |
||
| 1027 | +576 |
- #' @export+ }) |
||
| 1028 | +577 |
- h_grob_tbl_at_risk <- function(data, annot_tbl, xlim, title = TRUE) {
+ } |
||
| 1029 | -6x | +|||
| 578 | +
- txtlines <- levels(as.factor(data$strata))+ |
|||
| 1030 | -6x | +579 | +13x |
- nlines <- nlevels(as.factor(data$strata))+ grid::gList( |
| 1031 | -6x | +580 | +13x |
- y_int <- annot_tbl$time[2] - annot_tbl$time[1]+ g_rowname, |
| 1032 | -6x | +581 | +13x |
- annot_tbl <- expand.grid(+ do.call(grid::gList, gl_cols) |
| 1033 | -6x | +|||
| 582 | +
- time = seq(0, xlim, y_int),+ ) |
|||
| 1034 | -6x | +|||
| 583 | +
- strata = unique(annot_tbl$strata)+ } |
|||
| 1035 | -6x | +|||
| 584 | +
- ) %>% dplyr::left_join(annot_tbl, by = c("time", "strata"))
+
|
|||
| 1036 | -6x | +|||
| 585 | +
- annot_tbl[is.na(annot_tbl)] <- 0+ #' Graphic Object: Forest Dot Line |
|||
| 1037 | -6x | +|||
| 586 | +
- y_str_unit <- as.numeric(annot_tbl$strata)+ #' |
|||
| 1038 | -6x | +|||
| 587 | +
- vp_table <- grid::plotViewport(margins = grid::unit(c(0, 0, 0, 0), "lines"))+ #' Calculate the `grob` corresponding to the dot line within the forest plot. |
|||
| 1039 | -6x | +|||
| 588 | +
- if (title) {
+ #' |
|||
| 1040 | -6x | +|||
| 589 | +
- gb_table_title <- grid::gList(+ #' @noRd |
|||
| 1041 | -6x | +|||
| 590 | +
- grid::textGrob(+ forest_dot_line <- function(x, |
|||
| 1042 | -6x | +|||
| 591 | +
- label = "Patients at Risk:",+ lower, |
|||
| 1043 | -6x | +|||
| 592 | +
- x = 1,+ upper, |
|||
| 1044 | -6x | +|||
| 593 | +
- y = grid::unit(0.2, "native"),+ row_index, |
|||
| 1045 | -6x | +|||
| 594 | +
- gp = grid::gpar(fontface = "bold", fontsize = 10)+ xlim, |
|||
| 1046 | +595 |
- )+ symbol_size = 1, |
||
| 1047 | +596 |
- )+ col = "blue", |
||
| 1048 | +597 |
- }+ datavp) {
|
||
| 1049 | -6x | +598 | +9x |
- gb_table_left_annot <- grid::gList(+ ci <- c(lower, upper) |
| 1050 | -6x | +599 | +9x |
- grid::rectGrob(+ if (any(!is.na(c(x, ci)))) {
|
| 1051 | -6x | +|||
| 600 | +
- x = 0, y = grid::unit(c(1:nlines) - 1, "lines"),+ # line |
|||
| 1052 | -6x | +601 | +7x |
- gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
+ y <- grid::unit(c(0.5, 0.5), "npc")+ |
+
| 602 | ++ | + | ||
| 1053 | -6x | +603 | +7x |
- height = grid::unit(1, "lines"), just = "bottom", hjust = 0+ g_line <- if (all(!is.na(ci)) && ci[2] > xlim[1] && ci[1] < xlim[2]) {
|
| 1054 | +604 |
- ),+ # - |
||
| 1055 | -6x | +605 | +7x |
- grid::textGrob(+ if (ci[1] >= xlim[1] && ci[2] <= xlim[2]) {
|
| 1056 | -6x | +606 | +2x |
- label = unique(annot_tbl$strata),+ grid::linesGrob(x = grid::unit(c(ci[1], ci[2]), "native"), y = y) |
| 1057 | -6x | +607 | +5x |
- x = 0.5,+ } else if (ci[1] < xlim[1] && ci[2] > xlim[2]) {
|
| 1058 | -6x | +|||
| 608 | +
- y = grid::unit(+ # <-> |
|||
| 1059 | -6x | +609 | +3x |
- (max(unique(y_str_unit)) - unique(y_str_unit)) + 0.75,+ grid::linesGrob( |
| 1060 | -6x | -
- "native"- |
- ||
| 1061 | -+ | 610 | +3x |
- ),+ x = grid::unit(xlim, "native"), |
| 1062 | -6x | +611 | +3x |
- gp = grid::gpar(fontface = "italic", fontsize = 10)+ y = y, |
| 1063 | -+ | |||
| 612 | +3x |
- )+ arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "both") |
||
| 1064 | +613 |
- )+ ) |
||
| 1065 | -6x | +614 | +2x |
- gb_patient_at_risk <- grid::gList(+ } else if (ci[1] < xlim[1] && ci[2] <= xlim[2]) {
|
| 1066 | -6x | +|||
| 615 | +
- grid::rectGrob(+ # <- |
|||
| 1067 | -6x | +|||
| 616 | +! |
- x = 0, y = grid::unit(c(1:nlines) - 1, "lines"),+ grid::linesGrob( |
||
| 1068 | -6x | +|||
| 617 | +! |
- gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
+ x = grid::unit(c(xlim[1], ci[2]), "native"), |
||
| 1069 | -6x | +|||
| 618 | +! |
- height = grid::unit(1, "lines"), just = "bottom", hjust = 0+ y = y, |
||
| 1070 | -+ | |||
| 619 | +! |
- ),+ arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "first") |
||
| 1071 | -6x | +|||
| 620 | +
- grid::textGrob(+ ) |
|||
| 1072 | -6x | +621 | +2x |
- label = annot_tbl$n.risk,+ } else if (ci[1] >= xlim[1] && ci[2] > xlim[2]) {
|
| 1073 | -6x | +|||
| 622 | +
- x = grid::unit(annot_tbl$time, "native"),+ # -> |
|||
| 1074 | -6x | +623 | +2x |
- y = grid::unit(+ grid::linesGrob( |
| 1075 | -6x | +624 | +2x |
- (max(y_str_unit) - y_str_unit) + .5,+ x = grid::unit(c(ci[1], xlim[2]), "native"), |
| 1076 | -6x | +625 | +2x |
- "line"+ y = y, |
| 1077 | -6x | +626 | +2x |
- ) # maybe native+ arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "last") |
| 1078 | +627 |
- )+ ) |
||
| 1079 | +628 |
- )+ } |
||
| 1080 | +629 |
-
+ } else {
|
||
| 1081 | -6x | +|||
| 630 | +! |
- ret <- list(+ NULL |
||
| 1082 | -6x | +|||
| 631 | +
- at_risk = grid::gList(+ } |
|||
| 1083 | -6x | +|||
| 632 | +
- grid::gTree(+ |
|||
| 1084 | -6x | +633 | +7x |
- vp = vp_table,+ g_circle <- if (!is.na(x) && x >= xlim[1] && x <= xlim[2]) {
|
| 1085 | +634 | 6x |
- children = grid::gList(+ grid::circleGrob( |
|
| 1086 | +635 | 6x |
- grid::gTree(+ x = grid::unit(x, "native"), |
|
| 1087 | +636 | 6x |
- vp = grid::dataViewport(+ y = y, |
|
| 1088 | +637 | 6x |
- xscale = c(0, xlim) + c(-0.05, 0.05) * xlim,+ r = grid::unit(1 / 3.5 * symbol_size, "lines"), |
|
| 1089 | +638 | 6x |
- yscale = c(0, nlines + 1),+ name = "point" |
|
| 1090 | -6x | +|||
| 639 | +
- extension = c(0.05, 0)+ ) |
|||
| 1091 | +640 |
- ),+ } else {
|
||
| 1092 | -6x | +641 | +1x |
- children = grid::gList(gb_patient_at_risk)+ NULL |
| 1093 | +642 |
- )+ } |
||
| 1094 | +643 |
- )+ |
||
| 1095 | -+ | |||
| 644 | +7x |
- )+ grid::gTree( |
||
| 1096 | -+ | |||
| 645 | +7x |
- ),+ children = grid::gList( |
||
| 1097 | -6x | +646 | +7x |
- label = grid::gList(+ grid::gTree( |
| 1098 | -6x | +647 | +7x |
- grid::gTree(+ children = grid::gList( |
| 1099 | -6x | +648 | +7x |
- vp = grid::viewport(width = max(grid::stringWidth(txtlines))),+ grid::gList( |
| 1100 | -6x | +649 | +7x |
- children = grid::gList(+ g_line, |
| 1101 | -6x | +650 | +7x |
- grid::gTree(+ g_circle |
| 1102 | -6x | +|||
| 651 | +
- vp = grid::dataViewport(+ ) |
|||
| 1103 | -6x | +|||
| 652 | +
- xscale = 0:1,+ ), |
|||
| 1104 | -6x | +653 | +7x |
- yscale = c(0, nlines + 1),+ vp = datavp, |
| 1105 | -6x | +654 | +7x |
- extension = c(0.0, 0)+ gp = grid::gpar(col = col, fill = col) |
| 1106 | +655 |
- ),+ )+ |
+ ||
| 656 | ++ |
+ ), |
||
| 1107 | -6x | +657 | +7x |
- children = grid::gList(gb_table_left_annot)+ vp = grid::vpPath(paste0("forest-", row_index))
|
| 1108 | +658 |
- )+ ) |
||
| 1109 | +659 |
- )+ } else {
|
||
| 1110 | -+ | |||
| 660 | +2x |
- )+ NULL |
||
| 1111 | +661 |
- )+ } |
||
| 1112 | +662 |
- )+ } |
||
| 1113 | +663 | |||
| 1114 | -6x | -
- if (title) {
- |
- ||
| 1115 | -6x | +|||
| 664 | +
- ret[["title"]] <- grid::gList(+ #' Create a Viewport Tree for the Forest Plot |
|||
| 1116 | -6x | +|||
| 665 | +
- grid::gTree(+ #' @param tbl (`rtable`) |
|||
| 1117 | -6x | +|||
| 666 | +
- vp = grid::viewport(width = max(grid::stringWidth(txtlines))),+ #' @param width_row_names (`grid::unit`)\cr Width of row names |
|||
| 1118 | -6x | +|||
| 667 | +
- children = grid::gList(+ #' @param width_columns (`grid::unit`)\cr Width of column spans |
|||
| 1119 | -6x | +|||
| 668 | +
- grid::gTree(+ #' @param width_forest (`grid::unit`)\cr Width of the forest plot |
|||
| 1120 | -6x | +|||
| 669 | +
- vp = grid::dataViewport(+ #' @param gap_column (`grid::unit`)\cr Gap width between the columns |
|||
| 1121 | -6x | +|||
| 670 | +
- xscale = 0:1,+ #' @param gap_header (`grid::unit`)\cr Gap width between the header |
|||
| 1122 | -6x | +|||
| 671 | +
- yscale = c(0, 1),+ #' @param mat_form matrix print form of the table |
|||
| 1123 | -6x | +|||
| 672 | +
- extension = c(0, 0)+ #' @return A viewport tree. |
|||
| 1124 | +673 |
- ),+ #' |
||
| 1125 | -6x | +|||
| 674 | +
- children = grid::gList(gb_table_title)+ #' @examples |
|||
| 1126 | +675 |
- )+ #' library(grid) |
||
| 1127 | +676 |
- )+ #' |
||
| 1128 | +677 |
- )+ #' tbl <- rtable( |
||
| 1129 | +678 |
- )+ #' header = rheader( |
||
| 1130 | +679 |
- }+ #' rrow("", "E", rcell("CI", colspan = 2)),
|
||
| 1131 | +680 |
-
+ #' rrow("", "A", "B", "C")
|
||
| 1132 | -6x | +|||
| 681 | +
- ret+ #' ), |
|||
| 1133 | +682 |
- }+ #' rrow("row 1", 1, 0.8, 1.1),
|
||
| 1134 | +683 |
-
+ #' rrow("row 2", 1.4, 0.8, 1.6),
|
||
| 1135 | +684 |
- #' Helper Function: Survival Estimations+ #' rrow("row 3", 1.2, 0.8, 1.2)
|
||
| 1136 | +685 |
- #'+ #' ) |
||
| 1137 | +686 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 1138 | +687 |
- #'+ #' \donttest{
|
||
| 1139 | +688 |
- #' Transform a survival fit to a table with groups in rows characterized by N, median and confidence interval.+ #' v <- forest_viewport(tbl) |
||
| 1140 | +689 |
#' |
||
| 1141 | +690 |
- #' @inheritParams h_data_plot+ #' grid::grid.newpage() |
||
| 1142 | +691 |
- #'+ #' showViewport(v) |
||
| 1143 | +692 |
- #' @return A summary table with statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`).+ #' } |
||
| 1144 | +693 |
#' |
||
| 1145 | +694 |
- #' @examples+ #' @export |
||
| 1146 | +695 |
- #' \donttest{
+ forest_viewport <- function(tbl, |
||
| 1147 | +696 |
- #' library(dplyr)+ width_row_names = NULL, |
||
| 1148 | +697 |
- #' library(survival)+ width_columns = NULL, |
||
| 1149 | +698 |
- #'+ width_forest = grid::unit(1, "null"), |
||
| 1150 | +699 |
- #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "OS")+ gap_column = grid::unit(1, "lines"), |
||
| 1151 | +700 |
- #' fit <- survfit(+ gap_header = grid::unit(1, "lines"), |
||
| 1152 | +701 |
- #' form = Surv(AVAL, 1 - CNSR) ~ ARMCD,+ mat_form = NULL) {
|
||
| 1153 | -+ | |||
| 702 | +2x |
- #' data = adtte+ checkmate::assert_class(tbl, "VTableTree") |
||
| 1154 | -+ | |||
| 703 | +2x |
- #' )+ checkmate::assert_true(grid::is.unit(width_forest))+ |
+ ||
| 704 | +2x | +
+ if (!is.null(width_row_names)) {
+ |
+ ||
| 705 | +! | +
+ checkmate::assert_true(grid::is.unit(width_row_names)) |
||
| 1155 | +706 |
- #' h_tbl_median_surv(fit_km = fit)+ }+ |
+ ||
| 707 | +2x | +
+ if (!is.null(width_columns)) {
+ |
+ ||
| 708 | +! | +
+ checkmate::assert_true(grid::is.unit(width_columns)) |
||
| 1156 | +709 |
- #' }+ } |
||
| 1157 | +710 |
- #'+ + |
+ ||
| 711 | +2x | +
+ if (is.null(mat_form)) mat_form <- matrix_form(tbl) |
||
| 1158 | +712 |
- #' @export+ + |
+ ||
| 713 | +2x | +
+ mat_form$strings[!mat_form$display] <- "" |
||
| 1159 | +714 |
- h_tbl_median_surv <- function(fit_km, armval = "All") {
+
|
||
| 1160 | -6x | +715 | +2x |
- y <- if (is.null(fit_km$strata)) {
+ nr <- nrow(tbl) |
| 1161 | -! | +|||
| 716 | +2x |
- as.data.frame(t(summary(fit_km)$table), row.names = armval)+ nc <- ncol(tbl)+ |
+ ||
| 717 | +2x | +
+ nr_h <- attr(mat_form, "nrow_header") |
||
| 1162 | +718 |
- } else {
+
|
||
| 1163 | -6x | +719 | +2x |
- tbl <- summary(fit_km)$table+ if (is.null(width_row_names) || is.null(width_columns)) {
|
| 1164 | -6x | +720 | +2x |
- rownames_lst <- strsplit(sub("=", "equals", rownames(tbl)), "equals")
+ tbl_widths <- formatters::propose_column_widths(mat_form) |
| 1165 | -6x | +721 | +2x |
- rownames(tbl) <- matrix(unlist(rownames_lst), ncol = 2, byrow = TRUE)[, 2]+ strs_with_width <- strrep("x", tbl_widths) # that works for mono spaced fonts
|
| 1166 | -6x | +722 | +2x |
- as.data.frame(tbl)+ if (is.null(width_row_names)) width_row_names <- grid::stringWidth(strs_with_width[1])+ |
+
| 723 | +2x | +
+ if (is.null(width_columns)) width_columns <- grid::stringWidth(strs_with_width[-1]) |
||
| 1167 | +724 |
} |
||
| 1168 | -6x | +|||
| 725 | +
- conf.int <- summary(fit_km)$conf.int # nolint+ + |
+ |||
| 726 | ++ |
+ # Widths for row name, cols, forest. |
||
| 1169 | -6x | +727 | +2x |
- y$records <- round(y$records)+ widths <- grid::unit.c( |
| 1170 | -6x | +728 | +2x |
- y$median <- signif(y$median, 4)+ width_row_names + gap_column, |
| 1171 | -6x | +729 | +2x |
- y$`CI` <- paste0(+ width_columns + gap_column, |
| 1172 | -6x | +730 | +2x |
- "(", signif(y[[paste0(conf.int, "LCL")]], 4), ", ", signif(y[[paste0(conf.int, "UCL")]], 4), ")"
+ width_forest |
| 1173 | +731 |
) |
||
| 732 | ++ | + + | +||
| 1174 | -6x | +733 | +2x |
- stats::setNames(+ n_lines_per_row <- apply( |
| 1175 | -6x | +734 | +2x |
- y[c("records", "median", "CI")],
+ X = mat_form$strings, |
| 1176 | -6x | +735 | +2x |
- c("N", "Median", f_conf_level(conf.int))
+ MARGIN = 1,+ |
+
| 736 | +2x | +
+ FUN = function(row) {
+ |
+ ||
| 737 | +13x | +
+ tmp <- vapply(+ |
+ ||
| 738 | +13x | +
+ gregexpr("\n", row, fixed = TRUE),
+ |
+ ||
| 739 | +13x | +
+ attr, numeric(1),+ |
+ ||
| 740 | +13x | +
+ "match.length"+ |
+ ||
| 741 | +13x | +
+ ) + 1+ |
+ ||
| 742 | +13x | +
+ max(c(tmp, 1)) |
||
| 1177 | +743 |
- )+ } |
||
| 1178 | +744 |
- }+ ) |
||
| 1179 | +745 | |||
| 1180 | -+ | |||
| 746 | +2x |
- #' Helper Function: Survival Estimation Grob+ i_header <- seq_len(nr_h) |
||
| 1181 | +747 |
- #'+ |
||
| 1182 | -+ | |||
| 748 | +2x |
- #' @description `r lifecycle::badge("stable")`
+ height_body_rows <- grid::unit(n_lines_per_row[-i_header] * 1.2, "lines") |
||
| 1183 | -+ | |||
| 749 | +2x |
- #'+ height_header_rows <- grid::unit(n_lines_per_row[i_header] * 1.2, "lines") |
||
| 1184 | +750 |
- #' The survival fit is transformed in a grob containing a table with groups in+ |
||
| 1185 | -+ | |||
| 751 | +2x |
- #' rows characterized by N, median and 95% confidence interval.+ height_body <- grid::unit(sum(n_lines_per_row[-i_header]) * 1.2, "lines") |
||
| 1186 | -+ | |||
| 752 | +2x |
- #'+ height_header <- grid::unit(sum(n_lines_per_row[i_header]) * 1.2, "lines") |
||
| 1187 | +753 |
- #' @inheritParams g_km+ |
||
| 1188 | -+ | |||
| 754 | +2x |
- #' @inheritParams h_data_plot+ nc_g <- nc + 2 # number of columns incl. row names and forest |
||
| 1189 | +755 |
- #' @param ttheme (`list`)\cr see [gridExtra::ttheme_default()].+ |
||
| 1190 | -+ | |||
| 756 | +2x |
- #' @param x (`numeric`)\cr a value between 0 and 1 specifying x-location.+ vp_tbl <- grid::vpTree( |
||
| 1191 | -+ | |||
| 757 | +2x |
- #' @param y (`numeric`)\cr a value between 0 and 1 specifying y-location.+ parent = grid::viewport( |
||
| 1192 | -+ | |||
| 758 | +2x |
- #' @param width (`unit`)\cr width (as a unit) to use when printing the grob.+ name = "vp_table_layout", |
||
| 1193 | -+ | |||
| 759 | +2x |
- #'+ layout = grid::grid.layout( |
||
| 1194 | -+ | |||
| 760 | +2x |
- #' @return A `grob` of a table containing statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`).+ nrow = 3, ncol = 1, |
||
| 1195 | -+ | |||
| 761 | +2x |
- #'+ heights = grid::unit.c(height_header, gap_header, height_body) |
||
| 1196 | +762 |
- #' @examples+ ) |
||
| 1197 | +763 |
- #' \donttest{
+ ), |
||
| 1198 | -+ | |||
| 764 | +2x |
- #' library(dplyr)+ children = grid::vpList( |
||
| 1199 | -+ | |||
| 765 | +2x |
- #' library(survival)+ vp_forest_table_part(nr_h, nc_g, 1, 1, widths, height_header_rows, "vp_header"), |
||
| 1200 | -+ | |||
| 766 | +2x |
- #' library(grid)+ vp_forest_table_part(nr, nc_g, 3, 1, widths, height_body_rows, "vp_body"), |
||
| 1201 | -+ | |||
| 767 | +2x |
- #'+ grid::viewport(name = "vp_spacer", layout.pos.row = 2, layout.pos.col = 1) |
||
| 1202 | +768 |
- #' grid::grid.newpage()+ ) |
||
| 1203 | +769 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1))+ )+ |
+ ||
| 770 | +2x | +
+ vp_tbl |
||
| 1204 | +771 |
- #' tern_ex_adtte %>%+ } |
||
| 1205 | +772 |
- #' filter(PARAMCD == "OS") %>%+ |
||
| 1206 | +773 |
- #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ #' Viewport Forest Plot: Table Part |
||
| 1207 | +774 |
- #' h_grob_median_surv() %>%+ #' |
||
| 1208 | +775 |
- #' grid::grid.draw()+ #' Prepares a viewport for the table included in the forest plot. |
||
| 1209 | +776 |
- #' }+ #' |
||
| 1210 | +777 |
- #'+ #' @noRd |
||
| 1211 | +778 |
- #' @export+ vp_forest_table_part <- function(nrow, |
||
| 1212 | +779 |
- h_grob_median_surv <- function(fit_km,+ ncol, |
||
| 1213 | +780 |
- armval = "All",+ l_row, |
||
| 1214 | +781 |
- x = 0.9,+ l_col, |
||
| 1215 | +782 |
- y = 0.9,+ widths, |
||
| 1216 | +783 |
- width = grid::unit(0.3, "npc"),+ heights, |
||
| 1217 | +784 |
- ttheme = gridExtra::ttheme_default()) {
+ name) {
+ |
+ ||
| 785 | +4x | +
+ grid::vpTree(+ |
+ ||
| 786 | +4x | +
+ grid::viewport(+ |
+ ||
| 787 | +4x | +
+ name = name,+ |
+ ||
| 788 | +4x | +
+ layout.pos.row = l_row,+ |
+ ||
| 789 | +4x | +
+ layout.pos.col = l_col, |
||
| 1218 | -5x | +790 | +4x |
- data <- h_tbl_median_surv(fit_km, armval = armval)+ layout = grid::grid.layout(nrow = nrow, ncol = ncol, widths = widths, heights = heights) |
| 1219 | +791 |
-
+ ), |
||
| 1220 | -5x | +792 | +4x |
- width <- grid::convertUnit(width, "in")+ children = grid::vpList( |
| 1221 | -5x | +793 | +4x |
- height <- width * (nrow(data) + 1) / 12+ do.call( |
| 1222 | -+ | |||
| 794 | +4x |
-
+ grid::vpList, |
||
| 1223 | -5x | +795 | +4x |
- w <- paste(" ", c(
+ lapply( |
| 1224 | -5x | +796 | +4x |
- rownames(data)[which.max(nchar(rownames(data)))],+ seq_len(nrow), function(i) {
|
| 1225 | -5x | +797 | +13x |
- sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))])+ grid::viewport(layout.pos.row = i, layout.pos.col = 1, name = paste0("rowname-", i))
|
| 1226 | +798 |
- ))+ } |
||
| 1227 | -5x | +|||
| 799 | +
- w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE)+ ) |
|||
| 1228 | +800 |
-
+ ), |
||
| 1229 | -5x | +801 | +4x |
- w_txt <- sapply(1:64, function(x) {
+ do.call( |
| 1230 | -320x | +802 | +4x |
- graphics::par(ps = x)+ grid::vpList, |
| 1231 | -320x | +803 | +4x |
- graphics::strwidth(w[4], units = "in")+ apply( |
| 1232 | -+ | |||
| 804 | +4x |
- })+ expand.grid(seq_len(nrow), seq_len(ncol - 2)), |
||
| 1233 | -5x | +805 | +4x |
- f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]])+ 1, |
| 1234 | -+ | |||
| 806 | +4x |
-
+ function(x) {
|
||
| 1235 | -5x | +807 | +71x |
- h_txt <- sapply(1:64, function(x) {
+ i <- x[1] |
| 1236 | -320x | +808 | +71x |
- graphics::par(ps = x)+ j <- x[2] |
| 1237 | -320x | +809 | +71x |
- graphics::strheight(grid::stringHeight("X"), units = "in")
+ grid::viewport(layout.pos.row = i, layout.pos.col = j + 1, name = paste0("cell-", i, "-", j))
|
| 1238 | +810 |
- })+ } |
||
| 1239 | -5x | +|||
| 811 | +
- f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))])+ ) |
|||
| 1240 | +812 |
-
+ ), |
||
| 1241 | -5x | +813 | +4x |
- if (ttheme$core$fg_params$fontsize == 12) {
+ do.call( |
| 1242 | -5x | +814 | +4x |
- ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h)+ grid::vpList, |
| 1243 | -5x | +815 | +4x |
- ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ lapply( |
| 1244 | -5x | +816 | +4x |
- ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ seq_len(nrow), |
| 1245 | -+ | |||
| 817 | +4x |
- }+ function(i) {
+ |
+ ||
| 818 | +13x | +
+ grid::viewport(layout.pos.row = i, layout.pos.col = ncol, name = paste0("forest-", i))
|
||
| 1246 | +819 |
-
+ } |
||
| 1247 | -5x | +|||
| 820 | +
- gt <- gridExtra::tableGrob(+ ) |
|||
| 1248 | -5x | +|||
| 821 | +
- d = data,+ ) |
|||
| 1249 | -5x | +|||
| 822 | +
- theme = ttheme+ ) |
|||
| 1250 | +823 |
) |
||
| 1251 | -5x | +|||
| 824 | +
- gt$widths <- ((w_unit / sum(w_unit)) * width)+ } |
|||
| 1252 | -5x | +|||
| 825 | +
- gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt))+ |
|||
| 1253 | +826 |
-
+ #' Forest Rendering |
||
| 1254 | -5x | +|||
| 827 | +
- vp <- grid::viewport(+ #' |
|||
| 1255 | -5x | +|||
| 828 | +
- x = grid::unit(x, "npc") + grid::unit(1, "lines"),+ #' Renders the forest grob. |
|||
| 1256 | -5x | +|||
| 829 | +
- y = grid::unit(y, "npc") + grid::unit(1.5, "lines"),+ #' |
|||
| 1257 | -5x | +|||
| 830 | +
- height = height,+ #' @noRd |
|||
| 1258 | -5x | +|||
| 831 | +
- width = width,+ grid.forest <- function(...) { # nolint
|
|||
| 1259 | -5x | +|||
| 832 | +! |
- just = c("right", "top")
+ grid::grid.draw(forest_grob(...)) |
||
| 1260 | +833 |
- )+ } |
| 1261 | +1 |
-
+ #' Tabulate Survival Duration by Subgroup |
||
| 1262 | -5x | +|||
| 2 | +
- grid::gList(+ #' |
|||
| 1263 | -5x | +|||
| 3 | +
- grid::gTree(+ #' @description `r lifecycle::badge("stable")`
|
|||
| 1264 | -5x | +|||
| 4 | +
- vp = vp,+ #' |
|||
| 1265 | -5x | +|||
| 5 | +
- children = grid::gList(gt)+ #' Tabulate statistics such as median survival time and hazard ratio for population subgroups. |
|||
| 1266 | +6 |
- )+ #' |
||
| 1267 | +7 |
- )+ #' @inheritParams argument_convention |
||
| 1268 | +8 |
- }+ #' @inheritParams survival_coxph_pairwise |
||
| 1269 | +9 |
-
+ #' @param time_unit (`string`)\cr label with unit of median survival time. Default `NULL` skips displaying unit. |
||
| 1270 | +10 |
- #' Helper: Grid Object with y-axis Annotation+ #' |
||
| 1271 | +11 |
- #'+ #' @details These functions create a layout starting from a data frame which contains |
||
| 1272 | +12 |
- #' @description `r lifecycle::badge("stable")`
+ #' the required statistics. Tables typically used as part of forest plot. |
||
| 1273 | +13 |
#' |
||
| 1274 | +14 |
- #' Build the y-axis annotation from a decomposed `ggplot`.+ #' @seealso [extract_survival_subgroups()] |
||
| 1275 | +15 |
#' |
||
| 1276 | +16 |
- #' @param ylab (`gtable`)\cr the y-lab as a graphical object derived from a `ggplot`.+ #' @examples |
||
| 1277 | +17 |
- #' @param yaxis (`gtable`)\cr the y-axis as a graphical object derived from a `ggplot`.+ #' library(dplyr) |
||
| 1278 | +18 | ++ |
+ #' library(forcats)+ |
+ |
| 19 |
#' |
|||
| 1279 | +20 |
- #' @return a `gTree` object containing the y-axis annotation from a `ggplot`.+ #' adtte <- tern_ex_adtte |
||
| 1280 | +21 |
#' |
||
| 1281 | +22 |
- #' @examples+ #' # Save variable labels before data processing steps. |
||
| 1282 | +23 |
- #' \donttest{
+ #' adtte_labels <- formatters::var_labels(adtte) |
||
| 1283 | +24 |
- #' library(dplyr)+ #' |
||
| 1284 | +25 |
- #' library(survival)+ #' adtte_f <- adtte %>% |
||
| 1285 | +26 |
- #' library(grid)+ #' filter( |
||
| 1286 | +27 |
- #'+ #' PARAMCD == "OS", |
||
| 1287 | +28 |
- #' fit_km <- tern_ex_adtte %>%+ #' ARM %in% c("B: Placebo", "A: Drug X"),
|
||
| 1288 | +29 |
- #' filter(PARAMCD == "OS") %>%+ #' SEX %in% c("M", "F")
|
||
| 1289 | +30 |
- #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ #' ) %>% |
||
| 1290 | +31 |
- #' data_plot <- h_data_plot(fit_km = fit_km)+ #' mutate( |
||
| 1291 | +32 |
- #' xticks <- h_xticks(data = data_plot)+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
||
| 1292 | +33 |
- #' gg <- h_ggkm(+ #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")), |
||
| 1293 | +34 |
- #' data = data_plot,+ #' SEX = droplevels(SEX), |
||
| 1294 | +35 |
- #' censor_show = TRUE,+ #' AVALU = as.character(AVALU), |
||
| 1295 | +36 |
- #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ #' is_event = CNSR == 0 |
||
| 1296 | +37 |
- #' title = "title", footnotes = "footnotes", yval = "Survival"+ #' ) |
||
| 1297 | +38 |
- #' )+ #' labels <- c( |
||
| 1298 | +39 |
- #'+ #' "ARM" = adtte_labels[["ARM"]], |
||
| 1299 | +40 |
- #' g_el <- h_decompose_gg(gg)+ #' "SEX" = adtte_labels[["SEX"]], |
||
| 1300 | +41 |
- #'+ #' "AVALU" = adtte_labels[["AVALU"]], |
||
| 1301 | +42 |
- #' grid::grid.newpage()+ #' "is_event" = "Event Flag" |
||
| 1302 | +43 |
- #' pvp <- grid::plotViewport(margins = c(5, 4, 2, 20))+ #' ) |
||
| 1303 | +44 |
- #' pushViewport(pvp)+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
||
| 1304 | +45 |
- #' grid::grid.draw(h_grob_y_annot(ylab = g_el$ylab, yaxis = g_el$yaxis))+ #' |
||
| 1305 | +46 |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "gray35", fill = NA))+ #' df <- extract_survival_subgroups( |
||
| 1306 | +47 |
- #' }+ #' variables = list( |
||
| 1307 | +48 |
- #'+ #' tte = "AVAL", |
||
| 1308 | +49 |
- #' @export+ #' is_event = "is_event", |
||
| 1309 | +50 |
- h_grob_y_annot <- function(ylab, yaxis) {
+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
|
||
| 1310 | -6x | +|||
| 51 | +
- grid::gList(+ #' ), |
|||
| 1311 | -6x | +|||
| 52 | +
- grid::gTree(+ #' data = adtte_f |
|||
| 1312 | -6x | +|||
| 53 | +
- vp = grid::viewport(+ #' ) |
|||
| 1313 | -6x | +|||
| 54 | +
- width = grid::convertX(yaxis$width + ylab$width, "pt"),+ #' df |
|||
| 1314 | -6x | +|||
| 55 | +
- x = grid::unit(1, "npc"),+ #' |
|||
| 1315 | -6x | +|||
| 56 | +
- just = "right"+ #' @name survival_duration_subgroups |
|||
| 1316 | +57 |
- ),+ NULL |
||
| 1317 | -6x | +|||
| 58 | +
- children = grid::gList(cbind(ylab, yaxis))+ |
|||
| 1318 | +59 |
- )+ #' Prepares Survival Data for Population Subgroups in Data Frames |
||
| 1319 | +60 |
- )+ #' |
||
| 1320 | +61 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 1321 | +62 |
-
+ #' |
||
| 1322 | +63 |
- #' Helper Function: Pairwise `CoxPH` table+ #' Prepares estimates of median survival times and treatment hazard ratios for population subgroups in |
||
| 1323 | +64 |
- #'+ #' data frames. Simple wrapper for [h_survtime_subgroups_df()] and [h_coxph_subgroups_df()]. Result is a `list` |
||
| 1324 | +65 |
- #' @description `r lifecycle::badge("stable")`
+ #' of two `data.frame`s: `survtime` and `hr`. `variables` corresponds to the names of variables found in `data`, |
||
| 1325 | +66 |
- #'+ #' passed as a named `list` and requires elements `tte`, `is_event`, `arm` and optionally `subgroups` and `strat`. |
||
| 1326 | +67 |
- #' Create a `data.frame` of pairwise stratified or unstratified `CoxPH` analysis results.+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
||
| 1327 | +68 |
#' |
||
| 1328 | +69 |
- #' @inheritParams g_km+ #' @inheritParams argument_convention |
||
| 1329 | +70 | ++ |
+ #' @inheritParams survival_duration_subgroups+ |
+ |
| 71 | ++ |
+ #' @inheritParams survival_coxph_pairwise+ |
+ ||
| 72 |
#' |
|||
| 1330 | +73 |
- #' @return A `data.frame` containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`),+ #' @return A named `list` of two elements: |
||
| 1331 | +74 |
- #' and `p-value (log-rank)`.+ #' * `survtime`: A `data.frame` containing columns `arm`, `n`, `n_events`, `median`, `subgroup`, `var`, |
||
| 1332 | +75 |
- #'+ #' `var_label`, and `row_type`. |
||
| 1333 | +76 |
- #' @examples+ #' * `hr`: A `data.frame` containing columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`, `conf_level`, |
||
| 1334 | +77 |
- #' \donttest{
+ #' `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`. |
||
| 1335 | +78 |
- #' library(dplyr)+ #' |
||
| 1336 | +79 | ++ |
+ #' @seealso [survival_duration_subgroups]+ |
+ |
| 80 |
#' |
|||
| 1337 | +81 |
- #' adtte <- tern_ex_adtte %>%+ #' @examples |
||
| 1338 | +82 |
- #' filter(PARAMCD == "OS") %>%+ #' library(dplyr) |
||
| 1339 | +83 |
- #' mutate(is_event = CNSR == 0)+ #' library(forcats) |
||
| 1340 | +84 |
#' |
||
| 1341 | +85 |
- #' h_tbl_coxph_pairwise(+ #' adtte <- tern_ex_adtte |
||
| 1342 | +86 |
- #' df = adtte,+ #' adtte_labels <- formatters::var_labels(adtte) |
||
| 1343 | +87 |
- #' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARM"),+ #' |
||
| 1344 | +88 |
- #' control_coxph_pw = control_coxph(conf_level = 0.9)+ #' adtte_f <- adtte %>% |
||
| 1345 | +89 |
- #' )+ #' filter( |
||
| 1346 | +90 |
- #' }+ #' PARAMCD == "OS", |
||
| 1347 | +91 |
- #'+ #' ARM %in% c("B: Placebo", "A: Drug X"),
|
||
| 1348 | +92 |
- #' @export+ #' SEX %in% c("M", "F")
|
||
| 1349 | +93 |
- h_tbl_coxph_pairwise <- function(df,+ #' ) %>% |
||
| 1350 | +94 |
- variables,+ #' mutate( |
||
| 1351 | +95 |
- control_coxph_pw = control_coxph()) {
+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
||
| 1352 | -3x | +|||
| 96 | +
- assert_df_with_variables(df, variables)+ #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")), |
|||
| 1353 | -3x | +|||
| 97 | +
- arm <- variables$arm+ #' SEX = droplevels(SEX), |
|||
| 1354 | -3x | +|||
| 98 | +
- df[[arm]] <- factor(df[[arm]])+ #' AVALU = as.character(AVALU), |
|||
| 1355 | -3x | +|||
| 99 | +
- ref_group <- levels(df[[arm]])[1]+ #' is_event = CNSR == 0 |
|||
| 1356 | -3x | +|||
| 100 | +
- comp_group <- levels(df[[arm]])[-1]+ #' ) |
|||
| 1357 | -3x | +|||
| 101 | +
- results <- Map(function(comp) {
+ #' labels <- c( |
|||
| 1358 | -6x | +|||
| 102 | +
- res <- s_coxph_pairwise(+ #' "ARM" = adtte_labels[["ARM"]], |
|||
| 1359 | -6x | +|||
| 103 | +
- df = df[df[[arm]] == comp, , drop = FALSE],+ #' "SEX" = adtte_labels[["SEX"]], |
|||
| 1360 | -6x | +|||
| 104 | +
- .ref_group = df[df[[arm]] == ref_group, , drop = FALSE],+ #' "AVALU" = adtte_labels[["AVALU"]], |
|||
| 1361 | -6x | +|||
| 105 | +
- .in_ref_col = FALSE,+ #' "is_event" = "Event Flag" |
|||
| 1362 | -6x | +|||
| 106 | +
- .var = variables$tte,+ #' ) |
|||
| 1363 | -6x | +|||
| 107 | +
- is_event = variables$is_event,+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
|||
| 1364 | -6x | +|||
| 108 | +
- strat = variables$strat,+ #' |
|||
| 1365 | -6x | +|||
| 109 | +
- control = control_coxph_pw+ #' df <- extract_survival_subgroups( |
|||
| 1366 | +110 |
- )+ #' variables = list( |
||
| 1367 | -6x | +|||
| 111 | +
- res_df <- data.frame(+ #' tte = "AVAL", |
|||
| 1368 | -6x | +|||
| 112 | +
- hr = format(round(res$hr, 2), nsmall = 2),+ #' is_event = "is_event", |
|||
| 1369 | -6x | +|||
| 113 | +
- hr_ci = paste0(+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
|
|||
| 1370 | -6x | +|||
| 114 | +
- "(", format(round(res$hr_ci[1], 2), nsmall = 2), ", ",
+ #' ), |
|||
| 1371 | -6x | +|||
| 115 | +
- format(round(res$hr_ci[2], 2), nsmall = 2), ")"+ #' data = adtte_f |
|||
| 1372 | +116 |
- ),+ #' ) |
||
| 1373 | -6x | +|||
| 117 | +
- pvalue = if (res$pvalue < 0.0001) "<0.0001" else format(round(res$pvalue, 4), 4),+ #' df |
|||
| 1374 | -6x | +|||
| 118 | +
- stringsAsFactors = FALSE+ #' |
|||
| 1375 | +119 |
- )+ #' df_grouped <- extract_survival_subgroups( |
||
| 1376 | -6x | +|||
| 120 | +
- colnames(res_df) <- c("HR", vapply(res[c("hr_ci", "pvalue")], obj_label, FUN.VALUE = "character"))
+ #' variables = list( |
|||
| 1377 | -6x | +|||
| 121 | +
- row.names(res_df) <- comp+ #' tte = "AVAL", |
|||
| 1378 | -6x | +|||
| 122 | +
- res_df+ #' is_event = "is_event", |
|||
| 1379 | -3x | +|||
| 123 | +
- }, comp_group)+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
|
|||
| 1380 | -3x | +|||
| 124 | +
- do.call(rbind, results)+ #' ), |
|||
| 1381 | +125 |
- }+ #' data = adtte_f, |
||
| 1382 | +126 |
-
+ #' groups_lists = list( |
||
| 1383 | +127 |
- #' Helper Function: `CoxPH` Grob+ #' BMRKR2 = list( |
||
| 1384 | +128 |
- #'+ #' "low" = "LOW", |
||
| 1385 | +129 |
- #' @description `r lifecycle::badge("stable")`
+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 1386 | +130 |
- #'+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 1387 | +131 |
- #' Grob of `rtable` output from [h_tbl_coxph_pairwise()]+ #' ) |
||
| 1388 | +132 |
- #'+ #' ) |
||
| 1389 | +133 |
- #' @inheritParams h_grob_median_surv+ #' ) |
||
| 1390 | +134 |
- #' @param ... arguments will be passed to [h_tbl_coxph_pairwise()].+ #' df_grouped |
||
| 1391 | +135 |
- #' @param x (`numeric`)\cr a value between 0 and 1 specifying x-location.+ #' |
||
| 1392 | +136 |
- #' @param y (`numeric`)\cr a value between 0 and 1 specifying y-location.+ #' @export |
||
| 1393 | +137 |
- #' @param width (`unit`)\cr width (as a unit) to use when printing the grob.+ extract_survival_subgroups <- function(variables, |
||
| 1394 | +138 |
- #'+ data, |
||
| 1395 | +139 |
- #' @return A `grob` of a table containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`),+ groups_lists = list(), |
||
| 1396 | +140 |
- #' and `p-value (log-rank)`.+ control = control_coxph(), |
||
| 1397 | +141 |
- #'+ label_all = "All Patients") {
+ |
+ ||
| 142 | +8x | +
+ df_survtime <- h_survtime_subgroups_df(+ |
+ ||
| 143 | +8x | +
+ variables,+ |
+ ||
| 144 | +8x | +
+ data,+ |
+ ||
| 145 | +8x | +
+ groups_lists = groups_lists, |
||
| 1398 | -+ | |||
| 146 | +8x |
- #' @examples+ label_all = label_all |
||
| 1399 | +147 |
- #' \donttest{
+ ) |
||
| 1400 | -+ | |||
| 148 | +8x |
- #' library(dplyr)+ df_hr <- h_coxph_subgroups_df( |
||
| 1401 | -+ | |||
| 149 | +8x |
- #' library(survival)+ variables, |
||
| 1402 | -+ | |||
| 150 | +8x |
- #' library(grid)+ data, |
||
| 1403 | -+ | |||
| 151 | +8x |
- #'+ groups_lists = groups_lists, |
||
| 1404 | -+ | |||
| 152 | +8x |
- #' grid::grid.newpage()+ control = control, |
||
| 1405 | -+ | |||
| 153 | +8x |
- #' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1))+ label_all = label_all |
||
| 1406 | +154 |
- #' data <- tern_ex_adtte %>%+ ) |
||
| 1407 | +155 |
- #' filter(PARAMCD == "OS") %>%+ |
||
| 1408 | -+ | |||
| 156 | +8x |
- #' mutate(is_event = CNSR == 0)+ list(survtime = df_survtime, hr = df_hr) |
||
| 1409 | +157 |
- #' tbl_grob <- h_grob_coxph(+ } |
||
| 1410 | +158 |
- #' df = data,+ |
||
| 1411 | +159 |
- #' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARMCD"),+ #' @describeIn survival_duration_subgroups Formatted analysis function which is used as |
||
| 1412 | +160 |
- #' control_coxph_pw = control_coxph(conf_level = 0.9), x = 0.5, y = 0.5+ #' `afun` in `tabulate_survival_subgroups()`. |
||
| 1413 | +161 |
- #' )+ #' |
||
| 1414 | +162 |
- #' grid::grid.draw(tbl_grob)+ #' @return |
||
| 1415 | +163 |
- #' }+ #' * `a_survival_subgroups()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 1416 | +164 |
#' |
||
| 1417 | +165 |
- #' @export+ #' @keywords internal |
||
| 1418 | +166 |
- h_grob_coxph <- function(...,+ a_survival_subgroups <- function(.formats = list( # nolint start |
||
| 1419 | +167 |
- x = 0,+ n = "xx", |
||
| 1420 | +168 |
- y = 0,+ n_events = "xx", |
||
| 1421 | +169 |
- width = grid::unit(0.4, "npc"),+ n_tot_events = "xx", |
||
| 1422 | +170 |
- ttheme = gridExtra::ttheme_default(+ median = "xx.x", |
||
| 1423 | +171 |
- padding = grid::unit(c(1, .5), "lines"),+ n_tot = "xx", |
||
| 1424 | +172 |
- core = list(bg_params = list(fill = c("grey95", "grey90"), alpha = .5))
+ hr = list(format_extreme_values(2L)), |
||
| 1425 | +173 |
- )) {
- |
- ||
| 1426 | -2x | -
- data <- h_tbl_coxph_pairwise(...)+ ci = list(format_extreme_values_ci(2L)), |
||
| 1427 | +174 |
-
+ pval = "x.xxxx | (<0.0001)" |
||
| 1428 | -2x | +|||
| 175 | +
- width <- grid::convertUnit(width, "in")+ )) { # nolint end
|
|||
| 1429 | -2x | -
- height <- width * (nrow(data) + 1) / 12- |
- ||
| 1430 | -+ | 176 | +12x |
-
+ checkmate::assert_list(.formats) |
| 1431 | -2x | +177 | +12x |
- w <- paste(" ", c(
+ checkmate::assert_subset( |
| 1432 | -2x | +178 | +12x |
- rownames(data)[which.max(nchar(rownames(data)))],+ names(.formats), |
| 1433 | -2x | +179 | +12x |
- sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))])+ c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
|
| 1434 | +180 |
- ))- |
- ||
| 1435 | -2x | -
- w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE)+ ) |
||
| 1436 | +181 | |||
| 1437 | -2x | +182 | +12x |
- w_txt <- sapply(1:64, function(x) {
+ afun_lst <- Map( |
| 1438 | -128x | +183 | +12x |
- graphics::par(ps = x)+ function(stat, fmt) {
|
| 1439 | -128x | -
- graphics::strwidth(w[4], units = "in")- |
- ||
| 1440 | -+ | 184 | +90x |
- })+ if (stat == "ci") {
|
| 1441 | -2x | +185 | +11x |
- f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]])+ function(df, labelstr = "", ...) {
|
| 1442 | -+ | |||
| 186 | +20x |
-
+ in_rows( |
||
| 1443 | -2x | +187 | +20x |
- h_txt <- sapply(1:64, function(x) {
+ .list = combine_vectors(df$lcl, df$ucl), |
| 1444 | -128x | +188 | +20x |
- graphics::par(ps = x)+ .labels = as.character(df$subgroup), |
| 1445 | -128x | +189 | +20x |
- graphics::strheight(grid::stringHeight("X"), units = "in")
+ .formats = fmt |
| 1446 | +190 |
- })+ ) |
||
| 1447 | -2x | +|||
| 191 | +
- f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))])+ } |
|||
| 1448 | +192 |
-
+ } else {
|
||
| 1449 | -2x | +193 | +79x |
- if (ttheme$core$fg_params$fontsize == 12) {
+ function(df, labelstr = "", ...) {
|
| 1450 | -2x | +194 | +111x |
- ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h)+ in_rows( |
| 1451 | -2x | +195 | +111x |
- ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ .list = as.list(df[[stat]]), |
| 1452 | -2x | +196 | +111x |
- ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ .labels = as.character(df$subgroup),+ |
+
| 197 | +111x | +
+ .formats = fmt |
||
| 1453 | +198 |
- }+ ) |
||
| 1454 | +199 |
-
+ } |
||
| 1455 | -2x | +|||
| 200 | +
- tryCatch(+ } |
|||
| 1456 | -2x | +|||
| 201 | +
- expr = {
+ }, |
|||
| 1457 | -2x | +202 | +12x |
- gt <- gridExtra::tableGrob(+ stat = names(.formats), |
| 1458 | -2x | +203 | +12x |
- d = data,+ fmt = .formats |
| 1459 | -2x | +|||
| 204 | +
- theme = ttheme+ ) |
|||
| 1460 | -2x | +|||
| 205 | +
- ) # ERROR 'data' must be of a vector type, was 'NULL'+ |
|||
| 1461 | -2x | +206 | +12x |
- gt$widths <- ((w_unit / sum(w_unit)) * width)+ afun_lst |
| 1462 | -2x | +|||
| 207 | +
- gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt))+ } |
|||
| 1463 | -2x | +|||
| 208 | +
- vp <- grid::viewport(+ |
|||
| 1464 | -2x | +|||
| 209 | +
- x = grid::unit(x, "npc") + grid::unit(1, "lines"),+ #' @describeIn survival_duration_subgroups Table-creating function which creates a table |
|||
| 1465 | -2x | +|||
| 210 | +
- y = grid::unit(y, "npc") + grid::unit(1.5, "lines"),+ #' summarizing survival by subgroup. This function is a wrapper for [rtables::analyze_colvars()] |
|||
| 1466 | -2x | +|||
| 211 | +
- height = height,+ #' and [rtables::summarize_row_groups()]. |
|||
| 1467 | -2x | +|||
| 212 | +
- width = width,+ #' |
|||
| 1468 | -2x | +|||
| 213 | +
- just = c("left", "bottom")
+ #' @param df (`list`)\cr of data frames containing all analysis variables. List should be |
|||
| 1469 | +214 |
- )+ #' created using [extract_survival_subgroups()]. |
||
| 1470 | -2x | +|||
| 215 | +
- grid::gList(+ #' @param vars (`character`)\cr the name of statistics to be reported among: |
|||
| 1471 | -2x | +|||
| 216 | +
- grid::gTree(+ #' * `n_tot_events`: Total number of events per group. |
|||
| 1472 | -2x | +|||
| 217 | +
- vp = vp,+ #' * `n_events`: Number of events per group. |
|||
| 1473 | -2x | +|||
| 218 | +
- children = grid::gList(gt)+ #' * `n_tot`: Total number of observations per group. |
|||
| 1474 | +219 |
- )+ #' * `n`: Number of observations per group. |
||
| 1475 | +220 |
- )+ #' * `median`: Median survival time. |
||
| 1476 | +221 |
- },+ #' * `hr`: Hazard ratio. |
||
| 1477 | -2x | +|||
| 222 | +
- error = function(w) {
+ #' * `ci`: Confidence interval of hazard ratio. |
|||
| 1478 | -! | +|||
| 223 | +
- message(paste(+ #' * `pval`: p-value of the effect. |
|||
| 1479 | -! | +|||
| 224 | +
- "Warning: Cox table will not be displayed as there is",+ #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` |
|||
| 1480 | -! | +|||
| 225 | +
- "not any level to be compared in the arm variable."+ #' are required. |
|||
| 1481 | +226 |
- ))+ #' |
||
| 1482 | -! | +|||
| 227 | +
- return(+ #' @return An `rtables` table summarizing survival by subgroup. |
|||
| 1483 | -! | +|||
| 228 | +
- grid::gList(+ #' |
|||
| 1484 | -! | +|||
| 229 | +
- grid::gTree(+ #' @examples |
|||
| 1485 | -! | +|||
| 230 | +
- vp = NULL,+ #' ## Table with default columns. |
|||
| 1486 | -! | +|||
| 231 | +
- children = NULL+ #' basic_table() %>% |
|||
| 1487 | +232 |
- )+ #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) |
||
| 1488 | +233 |
- )+ #' |
||
| 1489 | +234 |
- )+ #' ## Table with a manually chosen set of columns: adding "pval". |
||
| 1490 | +235 |
- }+ #' basic_table() %>% |
||
| 1491 | +236 |
- )+ #' tabulate_survival_subgroups( |
||
| 1492 | +237 |
- }+ #' df = df, |
| 1 | +238 |
- #' Occurrence Counts by Grade+ #' vars = c("n_tot_events", "n_events", "median", "hr", "ci", "pval"),
|
||
| 2 | +239 |
- #'+ #' time_unit = adtte_f$AVALU[1] |
||
| 3 | +240 |
- #' @description `r lifecycle::badge("stable")`
+ #' ) |
||
| 4 | +241 |
#' |
||
| 5 | +242 |
- #' Functions for analyzing frequencies and fractions of occurrences by grade for patients+ #' @export |
||
| 6 | +243 |
- #' with occurrence data. Multiple occurrences within one individual are counted once at the+ tabulate_survival_subgroups <- function(lyt, |
||
| 7 | +244 |
- #' greatest intensity/highest grade level.+ df, |
||
| 8 | +245 |
- #'+ vars = c("n_tot_events", "n_events", "median", "hr", "ci"),
|
||
| 9 | +246 |
- #' @inheritParams argument_convention+ time_unit = NULL, |
||
| 10 | +247 |
- #' @param grade_groups (named `list` of `character`)\cr containing groupings of grades.+ na_str = NA_character_) {
|
||
| 11 | -+ | |||
| 248 | +5x |
- #' @param remove_single (`logical`)\cr `TRUE` to not include the elements of one-element grade groups+ conf_level <- df$hr$conf_level[1] |
||
| 12 | -+ | |||
| 249 | +5x |
- #' in the the output list; in this case only the grade groups names will be included in the output.+ method <- df$hr$pval_label[1] |
||
| 13 | +250 |
- #'+ |
||
| 14 | -+ | |||
| 251 | +5x |
- #' @seealso Relevant helper function [h_append_grade_groups()].+ afun_lst <- a_survival_subgroups() |
||
| 15 | -+ | |||
| 252 | +5x |
- #'+ colvars <- d_survival_subgroups_colvars( |
||
| 16 | -+ | |||
| 253 | +5x |
- #' @name count_occurrences_by_grade+ vars,+ |
+ ||
| 254 | +5x | +
+ conf_level = conf_level,+ |
+ ||
| 255 | +5x | +
+ method = method,+ |
+ ||
| 256 | +5x | +
+ time_unit = time_unit |
||
| 17 | +257 |
- NULL+ ) |
||
| 18 | +258 | |||
| 19 | -+ | |||
| 259 | +5x |
- #' Helper function for [s_count_occurrences_by_grade()]+ colvars_survtime <- list( |
||
| 20 | -+ | |||
| 260 | +5x |
- #'+ vars = colvars$vars[names(colvars$labels) %in% c("n", "n_events", "median")],
|
||
| 21 | -+ | |||
| 261 | +5x |
- #' @description `r lifecycle::badge("stable")`
+ labels = colvars$labels[names(colvars$labels) %in% c("n", "n_events", "median")]
|
||
| 22 | +262 |
- #'+ ) |
||
| 23 | -+ | |||
| 263 | +5x |
- #' Helper function for [s_count_occurrences_by_grade()] to insert grade groupings into list with+ colvars_hr <- list( |
||
| 24 | -+ | |||
| 264 | +5x |
- #' individual grade frequencies. The order of the final result follows the order of `grade_groups`.+ vars = colvars$vars[names(colvars$labels) %in% c("n_tot", "n_tot_events", "hr", "ci", "pval")],
|
||
| 25 | -+ | |||
| 265 | +5x |
- #' The elements under any-grade group (if any), i.e. the grade group equal to `refs` will be moved to+ labels = colvars$labels[names(colvars$labels) %in% c("n_tot", "n_tot_events", "hr", "ci", "pval")]
|
||
| 26 | +266 |
- #' the end. Grade groups names must be unique.+ ) |
||
| 27 | +267 |
- #'+ |
||
| 28 | +268 |
- #' @inheritParams count_occurrences_by_grade+ # Columns from table_survtime are optional. |
||
| 29 | -+ | |||
| 269 | +5x |
- #' @param refs (named `list` of `numeric`)\cr where each name corresponds to a reference grade level+ if (length(colvars_survtime$vars) > 0) {
|
||
| 30 | -+ | |||
| 270 | +4x |
- #' and each entry represents a count.+ lyt_survtime <- split_cols_by(lyt = lyt, var = "arm") |
||
| 31 | -+ | |||
| 271 | +4x |
- #'+ lyt_survtime <- split_rows_by( |
||
| 32 | -+ | |||
| 272 | +4x |
- #' @return Formatted list of grade groupings.+ lyt = lyt_survtime, |
||
| 33 | -+ | |||
| 273 | +4x |
- #'+ var = "row_type", |
||
| 34 | -+ | |||
| 274 | +4x |
- #' @examples+ split_fun = keep_split_levels("content"),
|
||
| 35 | -+ | |||
| 275 | +4x |
- #' h_append_grade_groups(+ nested = FALSE |
||
| 36 | +276 |
- #' list(+ ) |
||
| 37 | -+ | |||
| 277 | +4x |
- #' "Any Grade" = as.character(1:5),+ lyt_survtime <- summarize_row_groups( |
||
| 38 | -+ | |||
| 278 | +4x |
- #' "Grade 1-2" = c("1", "2"),
+ lyt = lyt_survtime, |
||
| 39 | -+ | |||
| 279 | +4x |
- #' "Grade 3-4" = c("3", "4")
+ var = "var_label", |
||
| 40 | -+ | |||
| 280 | +4x |
- #' ),+ cfun = afun_lst[names(colvars_survtime$labels)], |
||
| 41 | -+ | |||
| 281 | +4x |
- #' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
+ na_str = na_str |
||
| 42 | +282 |
- #' )+ ) |
||
| 43 | -+ | |||
| 283 | +4x |
- #'+ lyt_survtime <- split_cols_by_multivar( |
||
| 44 | -+ | |||
| 284 | +4x |
- #' h_append_grade_groups(+ lyt = lyt_survtime, |
||
| 45 | -+ | |||
| 285 | +4x |
- #' list(+ vars = colvars_survtime$vars, |
||
| 46 | -+ | |||
| 286 | +4x |
- #' "Any Grade" = as.character(5:1),+ varlabels = colvars_survtime$labels |
||
| 47 | +287 |
- #' "Grade A" = "5",+ ) |
||
| 48 | +288 |
- #' "Grade B" = c("4", "3")
+
|
||
| 49 | -+ | |||
| 289 | +4x |
- #' ),+ if ("analysis" %in% df$survtime$row_type) {
|
||
| 50 | -+ | |||
| 290 | +3x |
- #' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
+ lyt_survtime <- split_rows_by( |
||
| 51 | -+ | |||
| 291 | +3x |
- #' )+ lyt = lyt_survtime, |
||
| 52 | -+ | |||
| 292 | +3x |
- #'+ var = "row_type", |
||
| 53 | -+ | |||
| 293 | +3x |
- #' h_append_grade_groups(+ split_fun = keep_split_levels("analysis"),
|
||
| 54 | -+ | |||
| 294 | +3x |
- #' list(+ nested = FALSE, |
||
| 55 | -+ | |||
| 295 | +3x |
- #' "Any Grade" = as.character(1:5),+ child_labels = "hidden" |
||
| 56 | +296 |
- #' "Grade 1-2" = c("1", "2"),
+ ) |
||
| 57 | -+ | |||
| 297 | +3x |
- #' "Grade 3-4" = c("3", "4")
+ lyt_survtime <- split_rows_by(lyt = lyt_survtime, var = "var_label", nested = TRUE) |
||
| 58 | -+ | |||
| 298 | +3x |
- #' ),+ lyt_survtime <- analyze_colvars( |
||
| 59 | -+ | |||
| 299 | +3x |
- #' list("1" = 10, "2" = 5, "3" = 0)
+ lyt = lyt_survtime, |
||
| 60 | -+ | |||
| 300 | +3x |
- #' )+ afun = afun_lst[names(colvars_survtime$labels)],+ |
+ ||
| 301 | +3x | +
+ inclNAs = TRUE |
||
| 61 | +302 |
- #'+ ) |
||
| 62 | +303 |
- #' @export+ } |
||
| 63 | +304 |
- h_append_grade_groups <- function(grade_groups, refs, remove_single = TRUE) {
+
|
||
| 64 | -13x | +305 | +4x |
- checkmate::assert_list(grade_groups)+ table_survtime <- build_table(lyt_survtime, df = df$survtime) |
| 65 | -13x | +|||
| 306 | +
- checkmate::assert_list(refs)+ } else {
|
|||
| 66 | -13x | +307 | +1x |
- refs_orig <- refs+ table_survtime <- NULL |
| 67 | -13x | +|||
| 308 | +
- elements <- unique(unlist(grade_groups))+ } |
|||
| 68 | +309 | |||
| 69 | +310 |
- ### compute sums in groups+ # Columns "n_tot_events" or "n_tot", and "hr", "ci" in table_hr are required. |
||
| 70 | -13x | +311 | +5x |
- grp_sum <- lapply(grade_groups, function(i) do.call(sum, refs[i]))+ lyt_hr <- split_cols_by(lyt = lyt, var = "arm") |
| 71 | -13x | +312 | +5x |
- if (!checkmate::test_subset(elements, names(refs))) {
+ lyt_hr <- split_rows_by( |
| 72 | -2x | +313 | +5x |
- padding_el <- setdiff(elements, names(refs))+ lyt = lyt_hr, |
| 73 | -2x | -
- refs[padding_el] <- 0- |
- ||
| 74 | -+ | 314 | +5x |
- }+ var = "row_type", |
| 75 | -13x | +315 | +5x |
- result <- c(grp_sum, refs)+ split_fun = keep_split_levels("content"),
|
| 76 | -+ | |||
| 316 | +5x |
-
+ nested = FALSE |
||
| 77 | +317 |
- ### order result while keeping grade_groups's ordering+ ) |
||
| 78 | -13x | +318 | +5x |
- ordr <- grade_groups+ lyt_hr <- summarize_row_groups( |
| 79 | -+ | |||
| 319 | +5x |
-
+ lyt = lyt_hr, |
||
| 80 | -+ | |||
| 320 | +5x |
- # elements of any-grade group (if any) will be moved to the end+ var = "var_label", |
||
| 81 | -13x | +321 | +5x |
- is_any <- sapply(grade_groups, setequal, y = names(refs))+ cfun = afun_lst[names(colvars_hr$labels)], |
| 82 | -13x | +322 | +5x |
- ordr[is_any] <- list(character(0)) # hide elements under any-grade group+ na_str = na_str |
| 83 | +323 |
-
+ ) |
||
| 84 | -+ | |||
| 324 | +5x |
- # groups-elements combined sequence+ lyt_hr <- split_cols_by_multivar( |
||
| 85 | -13x | +325 | +5x |
- ordr <- c(lapply(names(ordr), function(g) c(g, ordr[[g]])), recursive = TRUE, use.names = FALSE)+ lyt = lyt_hr, |
| 86 | -13x | +326 | +5x |
- ordr <- ordr[!duplicated(ordr)]+ vars = colvars_hr$vars,+ |
+
| 327 | +5x | +
+ varlabels = colvars_hr$labels |
||
| 87 | +328 |
-
+ ) %>%+ |
+ ||
| 329 | +5x | +
+ append_topleft("Baseline Risk Factors")
|
||
| 88 | +330 |
- # append remaining elements (if any)+ |
||
| 89 | -13x | +331 | +5x |
- ordr <- union(ordr, unlist(grade_groups[is_any])) # from any-grade group+ if ("analysis" %in% df$survtime$row_type) {
|
| 90 | -13x | +332 | +4x |
- ordr <- union(ordr, names(refs)) # from refs+ lyt_hr <- split_rows_by( |
| 91 | -+ | |||
| 333 | +4x |
-
+ lyt = lyt_hr, |
||
| 92 | -+ | |||
| 334 | +4x |
- # remove elements of single-element groups, if any+ var = "row_type", |
||
| 93 | -13x | +335 | +4x |
- if (remove_single) {
+ split_fun = keep_split_levels("analysis"),
|
| 94 | -13x | +336 | +4x |
- is_single <- sapply(grade_groups, length) == 1L+ nested = FALSE, |
| 95 | -13x | +337 | +4x |
- ordr <- setdiff(ordr, unlist(grade_groups[is_single]))+ child_labels = "hidden" |
| 96 | +338 |
- }+ ) |
||
| 97 | -+ | |||
| 339 | +4x |
-
+ lyt_hr <- split_rows_by(lyt = lyt_hr, var = "var_label", nested = TRUE) |
||
| 98 | -+ | |||
| 340 | +4x |
- # apply the order+ lyt_hr <- analyze_colvars( |
||
| 99 | -13x | +341 | +4x |
- result <- result[ordr]+ lyt = lyt_hr, |
| 100 | -+ | |||
| 342 | +4x |
-
+ afun = afun_lst[names(colvars_hr$labels)], |
||
| 101 | -+ | |||
| 343 | +4x |
- # remove groups without any elements in the original refs+ inclNAs = TRUE |
||
| 102 | +344 |
- # note: it's OK if groups have 0 value- |
- ||
| 103 | -13x | -
- keep_grp <- vapply(grade_groups, function(x, rf) {
+ ) |
||
| 104 | -37x | +|||
| 345 | +
- any(x %in% rf)+ } |
|||
| 105 | -13x | +346 | +5x |
- }, rf = names(refs_orig), logical(1))+ table_hr <- build_table(lyt_hr, df = df$hr) |
| 106 | +347 | |||
| 107 | -13x | +|||
| 348 | +
- keep_el <- names(result) %in% names(refs_orig) | names(result) %in% names(keep_grp)[keep_grp]+ # There can be one or two vars starting with "n_tot". |
|||
| 108 | -13x | +349 | +5x |
- result <- result[keep_el]+ n_tot_ids <- grep("^n_tot", colvars_hr$vars)
|
| 109 | -+ | |||
| 350 | +5x |
-
+ if (is.null(table_survtime)) {
|
||
| 110 | -13x | +351 | +1x |
- result+ result <- table_hr |
| 111 | -+ | |||
| 352 | +1x |
- }+ hr_id <- match("hr", colvars_hr$vars)
|
||
| 112 | -+ | |||
| 353 | +1x |
-
+ ci_id <- match("lcl", colvars_hr$vars)
|
||
| 113 | +354 |
- #' @describeIn count_occurrences_by_grade Statistics function which counts the+ } else {
|
||
| 114 | +355 |
- #' number of patients by highest grade.+ # Reorder the table. |
||
| 115 | -+ | |||
| 356 | +4x |
- #'+ result <- cbind_rtables(table_hr[, n_tot_ids], table_survtime, table_hr[, -n_tot_ids]) |
||
| 116 | +357 |
- #' @return+ # And then calculate column indices accordingly. |
||
| 117 | -+ | |||
| 358 | +4x |
- #' * `s_count_occurrences_by_grade()` returns a list of counts and fractions with one element per grade level or+ hr_id <- length(n_tot_ids) + ncol(table_survtime) + match("hr", colvars_hr$vars[-n_tot_ids])
|
||
| 118 | -+ | |||
| 359 | +4x |
- #' grade level grouping.+ ci_id <- length(n_tot_ids) + ncol(table_survtime) + match("lcl", colvars_hr$vars[-n_tot_ids])
|
||
| 119 | -+ | |||
| 360 | +4x |
- #'+ n_tot_ids <- seq_along(n_tot_ids) |
||
| 120 | +361 |
- #' @examples+ } |
||
| 121 | +362 |
- #' library(dplyr)+ |
||
| 122 | -+ | |||
| 363 | +5x |
- #' df <- data.frame(+ structure( |
||
| 123 | -+ | |||
| 364 | +5x |
- #' USUBJID = as.character(c(1:6, 1)),+ result, |
||
| 124 | -+ | |||
| 365 | +5x |
- #' ARM = factor(c("A", "A", "A", "B", "B", "B", "A"), levels = c("A", "B")),
+ forest_header = paste0(rev(levels(df$survtime$arm)), "\nBetter"), |
||
| 125 | -+ | |||
| 366 | +5x |
- #' AETOXGR = factor(c(1, 2, 3, 4, 1, 2, 3), levels = c(1:5)),+ col_x = hr_id, |
||
| 126 | -+ | |||
| 367 | +5x |
- #' AESEV = factor(+ col_ci = ci_id, |
||
| 127 | +368 |
- #' x = c("MILD", "MODERATE", "SEVERE", "MILD", "MILD", "MODERATE", "SEVERE"),
+ # Take the first one for scaling the symbol sizes in graph. |
||
| 128 | -+ | |||
| 369 | +5x |
- #' levels = c("MILD", "MODERATE", "SEVERE")
+ col_symbol_size = n_tot_ids[1] |
||
| 129 | +370 |
- #' ),+ ) |
||
| 130 | +371 |
- #' stringsAsFactors = FALSE+ } |
||
| 131 | +372 |
- #' )+ |
||
| 132 | +373 |
- #' df_adsl <- df %>%+ #' Labels for Column Variables in Survival Duration by Subgroup Table |
||
| 133 | +374 |
- #' select(USUBJID, ARM) %>%+ #' |
||
| 134 | +375 |
- #' unique()+ #' @description `r lifecycle::badge("stable")`
|
||
| 135 | +376 |
#' |
||
| 136 | +377 |
- #' s_count_occurrences_by_grade(+ #' Internal function to check variables included in [tabulate_survival_subgroups()] and create column labels. |
||
| 137 | +378 |
- #' df,+ #' |
||
| 138 | +379 |
- #' .N_col = 10L,+ #' @inheritParams tabulate_survival_subgroups |
||
| 139 | +380 |
- #' .var = "AETOXGR",+ #' @inheritParams argument_convention |
||
| 140 | +381 |
- #' id = "USUBJID",+ #' @param method (`character`)\cr p-value method for testing hazard ratio = 1. |
||
| 141 | +382 |
- #' grade_groups = list("ANY" = levels(df$AETOXGR))
+ #' |
||
| 142 | +383 |
- #' )+ #' @return A `list` of variables and their labels to tabulate. |
||
| 143 | +384 |
#' |
||
| 144 | +385 |
- #' @export+ #' @note At least one of `n_tot` and `n_tot_events` must be provided in `vars`. |
||
| 145 | +386 |
- s_count_occurrences_by_grade <- function(df,+ #' |
||
| 146 | +387 |
- .var,+ #' @export |
||
| 147 | +388 |
- .N_col, # nolint+ d_survival_subgroups_colvars <- function(vars, |
||
| 148 | +389 |
- id = "USUBJID",+ conf_level, |
||
| 149 | +390 |
- grade_groups = list(),+ method, |
||
| 150 | +391 |
- remove_single = TRUE,+ time_unit = NULL) {
|
||
| 151 | -+ | |||
| 392 | +12x |
- labelstr = "") {
+ checkmate::assert_character(vars) |
||
| 152 | -6x | +393 | +12x |
- assert_valid_factor(df[[.var]])+ checkmate::assert_string(time_unit, null.ok = TRUE) |
| 153 | -6x | +394 | +12x |
- assert_df_with_variables(df, list(grade = .var, id = id))+ checkmate::assert_subset(c("hr", "ci"), vars)
|
| 154 | -+ | |||
| 395 | +12x |
-
+ checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
|
||
| 155 | -6x | +396 | +12x |
- if (nrow(df) < 1) {
+ checkmate::assert_subset( |
| 156 | -! | +|||
| 397 | +12x |
- grade_levels <- levels(df[[.var]])+ vars, |
||
| 157 | -! | +|||
| 398 | +12x |
- l_count <- as.list(rep(0, length(grade_levels)))+ c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
|
||
| 158 | -! | +|||
| 399 | +
- names(l_count) <- grade_levels+ ) |
|||
| 159 | +400 |
- } else {
+
|
||
| 160 | -6x | +401 | +12x |
- if (isTRUE(is.factor(df[[id]]))) {
+ propcase_time_label <- if (!is.null(time_unit)) {
|
| 161 | -! | +|||
| 402 | +11x |
- assert_valid_factor(df[[id]], any.missing = FALSE)+ paste0("Median (", time_unit, ")")
|
||
| 162 | +403 |
- } else {
+ } else {
|
||
| 163 | -6x | +404 | +1x |
- checkmate::assert_character(df[[id]], min.chars = 1, any.missing = FALSE)+ "Median" |
| 164 | +405 |
- }- |
- ||
| 165 | -6x | -
- checkmate::assert_count(.N_col)+ } |
||
| 166 | +406 | |||
| 167 | -6x | +407 | +12x |
- id <- df[[id]]+ varlabels <- c( |
| 168 | -6x | +408 | +12x |
- grade <- df[[.var]]+ n = "n", |
| 169 | -+ | |||
| 409 | +12x |
-
+ n_events = "Events", |
||
| 170 | -6x | +410 | +12x |
- if (!is.ordered(grade)) {
+ median = propcase_time_label, |
| 171 | -6x | +411 | +12x |
- grade_lbl <- obj_label(grade)+ n_tot = "Total n", |
| 172 | -6x | +412 | +12x |
- lvls <- levels(grade)+ n_tot_events = "Total Events", |
| 173 | -6x | +413 | +12x |
- if (sum(grepl("^\\d+$", lvls)) %in% c(0, length(lvls))) {
+ hr = "Hazard Ratio", |
| 174 | -5x | +414 | +12x |
- lvl_ord <- lvls+ ci = paste0(100 * conf_level, "% Wald CI"),+ |
+
| 415 | +12x | +
+ pval = method |
||
| 175 | +416 |
- } else {
+ ) |
||
| 176 | -1x | +|||
| 417 | +
- lvls[!grepl("^\\d+$", lvls)] <- min(as.numeric(lvls[grepl("^\\d+$", lvls)])) - 1
+
|
|||
| 177 | -1x | +418 | +12x |
- lvl_ord <- levels(grade)[order(as.numeric(lvls))]+ colvars <- vars |
| 178 | +419 |
- }+ |
||
| 179 | -6x | +|||
| 420 | +
- grade <- formatters::with_label(factor(grade, levels = lvl_ord, ordered = TRUE), grade_lbl)+ # The `lcl` variable is just a placeholder available in the analysis data, |
|||
| 180 | +421 |
- }+ # it is not acutally used in the tabulation. |
||
| 181 | +422 |
-
+ # Variables used in the tabulation are lcl and ucl, see `a_survival_subgroups` for details. |
||
| 182 | -6x | +423 | +12x |
- missing_lvl <- grepl("missing", tolower(levels(grade)))
+ colvars[colvars == "ci"] <- "lcl" |
| 183 | -6x | +|||
| 424 | +
- if (any(missing_lvl)) {
+
|
|||
| 184 | -1x | +425 | +12x |
- grade <- factor(+ list( |
| 185 | -1x | +426 | +12x |
- grade,+ vars = colvars, |
| 186 | -1x | +427 | +12x |
- levels = c(levels(grade)[!missing_lvl], levels(grade)[missing_lvl]),+ labels = varlabels[vars] |
| 187 | -1x | +|||
| 428 | +
- ordered = is.ordered(grade)+ ) |
|||
| 188 | +429 |
- )+ } |
| 189 | +1 |
- }+ #' Convert Table into Matrix of Strings |
||
| 190 | -6x | +|||
| 2 | +
- df_max <- stats::aggregate(grade ~ id, FUN = max, drop = FALSE)+ #' |
|||
| 191 | -6x | +|||
| 3 | +
- l_count <- as.list(table(df_max$grade))+ #' @description `r lifecycle::badge("stable")`
|
|||
| 192 | +4 |
- }+ #' |
||
| 193 | +5 |
-
+ #' Helper function to use mostly within tests. `with_spaces`parameter allows |
||
| 194 | -6x | +|||
| 6 | +
- if (length(grade_groups) > 0) {
+ #' to test not only for content but also indentation and table structure. |
|||
| 195 | -2x | +|||
| 7 | +
- l_count <- h_append_grade_groups(grade_groups, l_count, remove_single)+ #' `print_txt_to_copy` instead facilitate the testing development by returning a well |
|||
| 196 | +8 |
- }+ #' formatted text that needs only to be copied and pasted in the expected output. |
||
| 197 | +9 |
-
+ #' |
||
| 198 | -6x | +|||
| 10 | +
- l_count_fraction <- lapply(l_count, function(i, denom) c(i, i / denom), denom = .N_col)+ #' @param x `rtables` table. |
|||
| 199 | +11 |
-
+ #' @param with_spaces Should the tested table keep the indentation and other relevant spaces? |
||
| 200 | -6x | +|||
| 12 | +
- list(+ #' @param print_txt_to_copy Utility to have a way to copy the input table directly |
|||
| 201 | -6x | +|||
| 13 | +
- count_fraction = l_count_fraction+ #' into the expected variable instead of copying it too manually. |
|||
| 202 | +14 |
- )+ #' |
||
| 203 | +15 |
- }+ #' @return A `matrix` of `string`s. |
||
| 204 | +16 |
-
+ #' |
||
| 205 | +17 |
- #' @describeIn count_occurrences_by_grade Formatted analysis function which is used as `afun`+ #' @export |
||
| 206 | +18 |
- #' in `count_occurrences_by_grade()`.+ to_string_matrix <- function(x, with_spaces = FALSE, print_txt_to_copy = FALSE) {
|
||
| 207 | -+ | |||
| 19 | +5x |
- #'+ checkmate::assert_flag(with_spaces) |
||
| 208 | -+ | |||
| 20 | +5x |
- #' @return+ checkmate::assert_flag(print_txt_to_copy) |
||
| 209 | +21 |
- #' * `a_count_occurrences_by_grade()` returns the corresponding list with formatted [rtables::CellValue()].+ |
||
| 210 | +22 |
- #'+ # Producing the matrix to test |
||
| 211 | -+ | |||
| 23 | +5x |
- #' @examples+ if (with_spaces) {
|
||
| 212 | -+ | |||
| 24 | +! |
- #' # We need to ungroup `count_fraction` first so that the `rtables` formatting+ out <- strsplit(toString(matrix_form(x, TRUE)), "\\n")[[1]] |
||
| 213 | +25 |
- #' # function `format_count_fraction()` can be applied correctly.+ } else {
|
||
| 214 | -+ | |||
| 26 | +5x |
- #' afun <- make_afun(a_count_occurrences_by_grade, .ungroup_stats = "count_fraction")+ out <- matrix_form(x)$string |
||
| 215 | +27 |
- #' afun(+ } |
||
| 216 | +28 |
- #' df,+ |
||
| 217 | +29 |
- #' .N_col = 10L,+ # Printing to console formatted output that needs to be copied in "expected" |
||
| 218 | -+ | |||
| 30 | +5x |
- #' .var = "AETOXGR",+ if (print_txt_to_copy) {
|
||
| 219 | -+ | |||
| 31 | +! |
- #' id = "USUBJID",+ out_tmp <- out |
||
| 220 | -+ | |||
| 32 | +! |
- #' grade_groups = list("ANY" = levels(df$AETOXGR))
+ if (!with_spaces) {
|
||
| 221 | -+ | |||
| 33 | +! |
- #' )+ out_tmp <- apply(out, 1, paste0, collapse = '", "') |
||
| 222 | +34 |
- #'+ } |
||
| 223 | -+ | |||
| 35 | +! |
- #' @export+ cat(paste0('c(\n "', paste0(out_tmp, collapse = '",\n "'), '"\n)'))
|
||
| 224 | +36 |
- a_count_occurrences_by_grade <- make_afun(+ } |
||
| 225 | +37 |
- s_count_occurrences_by_grade,+ |
||
| 226 | +38 |
- .formats = c("count_fraction" = format_count_fraction_fixed_dp)
+ # Return values |
||
| 227 | -+ | |||
| 39 | +5x |
- )+ return(out) |
||
| 228 | +40 |
-
+ } |
||
| 229 | +41 |
- #' @describeIn count_occurrences_by_grade Layout-creating function which can take statistics function+ |
||
| 230 | +42 |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' Blank for Missing Input |
||
| 231 | +43 |
#' |
||
| 232 | +44 |
- #' @param var_labels (`character`)\cr labels to show in the result table.+ #' Helper function to use in tabulating model results. |
||
| 233 | +45 |
#' |
||
| 234 | +46 |
- #' @return+ #' @param x (`vector`)\cr input for a cell. |
||
| 235 | +47 |
- #' * `count_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions,+ #' |
||
| 236 | +48 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' @return An empty `character` vector if all entries in `x` are missing (`NA`), otherwise |
||
| 237 | +49 |
- #' the statistics from `s_count_occurrences_by_grade()` to the table layout.+ #' the unlisted version of `x`. |
||
| 238 | +50 |
#' |
||
| 239 | +51 |
- #' @examples+ #' @keywords internal |
||
| 240 | +52 |
- #' # Layout creating function with custom format.+ unlist_and_blank_na <- function(x) {
|
||
| 241 | -+ | |||
| 53 | +267x |
- #' basic_table() %>%+ unl <- unlist(x) |
||
| 242 | -+ | |||
| 54 | +267x |
- #' split_cols_by("ARM") %>%
+ if (all(is.na(unl))) {
+ |
+ ||
| 55 | +161x | +
+ character() |
||
| 243 | +56 |
- #' add_colcounts() %>%+ } else {
|
||
| 244 | -+ | |||
| 57 | +106x |
- #' count_occurrences_by_grade(+ unl |
||
| 245 | +58 |
- #' var = "AESEV",+ } |
||
| 246 | +59 |
- #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
+ } |
||
| 247 | +60 |
- #' ) %>%+ |
||
| 248 | +61 |
- #' build_table(df, alt_counts_df = df_adsl)+ #' Constructor for Content Functions given Data Frame with Flag Input |
||
| 249 | +62 |
#' |
||
| 250 | +63 |
- #' # Define additional grade groupings.+ #' This can be useful for tabulating model results. |
||
| 251 | +64 |
- #' grade_groups <- list(+ #' |
||
| 252 | +65 |
- #' "-Any-" = c("1", "2", "3", "4", "5"),
+ #' @param analysis_var (`string`)\cr variable name for the column containing values to be returned by the |
||
| 253 | +66 |
- #' "Grade 1-2" = c("1", "2"),
+ #' content function. |
||
| 254 | +67 |
- #' "Grade 3-5" = c("3", "4", "5")
+ #' @param flag_var (`string`)\cr variable name for the logical column identifying which row should be returned. |
||
| 255 | +68 |
- #' )+ #' @param format (`string`)\cr `rtables` format to use. |
||
| 256 | +69 |
#' |
||
| 257 | +70 |
- #' basic_table() %>%+ #' @return A content function which gives `df$analysis_var` at the row identified by |
||
| 258 | +71 |
- #' split_cols_by("ARM") %>%
+ #' `.df_row$flag` in the given format. |
||
| 259 | +72 |
- #' add_colcounts() %>%+ #' |
||
| 260 | +73 |
- #' count_occurrences_by_grade(+ #' @keywords internal |
||
| 261 | +74 |
- #' var = "AETOXGR",+ cfun_by_flag <- function(analysis_var, |
||
| 262 | +75 |
- #' grade_groups = grade_groups+ flag_var, |
||
| 263 | +76 |
- #' ) %>%+ format = "xx", |
||
| 264 | +77 |
- #' build_table(df, alt_counts_df = df_adsl)+ .indent_mods = NULL) {
|
||
| 265 | -+ | |||
| 78 | +61x |
- #'+ checkmate::assert_string(analysis_var) |
||
| 266 | -+ | |||
| 79 | +61x |
- #' @export+ checkmate::assert_string(flag_var) |
||
| 267 | -+ | |||
| 80 | +61x |
- count_occurrences_by_grade <- function(lyt,+ function(df, labelstr) {
|
||
| 268 | -+ | |||
| 81 | +265x |
- var,+ row_index <- which(df[[flag_var]]) |
||
| 269 | -+ | |||
| 82 | +265x |
- var_labels = var,+ x <- unlist_and_blank_na(df[[analysis_var]][row_index]) |
||
| 270 | -+ | |||
| 83 | +265x |
- show_labels = "default",+ formatters::with_label( |
||
| 271 | -+ | |||
| 84 | +265x |
- riskdiff = FALSE,+ rcell(x, format = format, indent_mod = .indent_mods), |
||
| 272 | -+ | |||
| 85 | +265x |
- nested = TRUE,+ labelstr |
||
| 273 | +86 |
- ...,+ ) |
||
| 274 | +87 |
- table_names = var,+ } |
||
| 275 | +88 |
- .stats = NULL,+ } |
||
| 276 | +89 |
- .formats = NULL,+ |
||
| 277 | +90 |
- .indent_mods = NULL,+ #' Content Row Function to Add Row Total to Labels |
||
| 278 | +91 |
- .labels = NULL) {
- |
- ||
| 279 | -8x | -
- checkmate::assert_flag(riskdiff)+ #' |
||
| 280 | +92 | - - | -||
| 281 | -8x | -
- afun <- make_afun(- |
- ||
| 282 | -8x | -
- a_count_occurrences_by_grade,+ #' This takes the label of the latest row split level and adds the row total from `df` in parentheses. |
||
| 283 | -8x | +|||
| 93 | +
- .stats = .stats,+ #' This function differs from [c_label_n_alt()] by taking row counts from `df` rather than |
|||
| 284 | -8x | +|||
| 94 | +
- .formats = .formats,+ #' `alt_counts_df`, and is used by [add_rowcounts()] when `alt_counts` is set to `FALSE`. |
|||
| 285 | -8x | +|||
| 95 | +
- .indent_mods = .indent_mods,+ #' |
|||
| 286 | -8x | +|||
| 96 | +
- .ungroup_stats = "count_fraction"+ #' @inheritParams argument_convention |
|||
| 287 | +97 |
- )+ #' |
||
| 288 | +98 |
-
+ #' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label. |
||
| 289 | -8x | +|||
| 99 | +
- extra_args <- if (isFALSE(riskdiff)) {
+ #' |
|||
| 290 | -7x | +|||
| 100 | +
- list(...)+ #' @note It is important here to not use `df` but rather `.N_row` in the implementation, because |
|||
| 291 | +101 |
- } else {
+ #' the former is already split by columns and will refer to the first column of the data only. |
||
| 292 | -1x | +|||
| 102 | +
- list(+ #' |
|||
| 293 | -1x | +|||
| 103 | +
- afun = list("s_count_occurrences_by_grade" = afun),
+ #' @seealso [c_label_n_alt()] which performs the same function but retrieves row counts from |
|||
| 294 | -1x | +|||
| 104 | +
- .stats = .stats,+ #' `alt_counts_df` instead of `df`. |
|||
| 295 | -1x | +|||
| 105 | +
- .indent_mods = .indent_mods,+ #' |
|||
| 296 | -1x | +|||
| 106 | +
- s_args = list(...)+ #' @keywords internal |
|||
| 297 | +107 |
- )+ c_label_n <- function(df, |
||
| 298 | +108 |
- }+ labelstr, |
||
| 299 | +109 |
-
+ .N_row) { # nolint
|
||
| 300 | -8x | +110 | +270x |
- analyze(+ label <- paste0(labelstr, " (N=", .N_row, ")") |
| 301 | -8x | +111 | +270x |
- lyt = lyt,+ in_rows( |
| 302 | -8x | +112 | +270x |
- vars = var,+ .list = list(row_count = formatters::with_label(c(.N_row, .N_row), label)), |
| 303 | -8x | +113 | +270x |
- var_labels = var_labels,+ .formats = c(row_count = function(x, ...) "") |
| 304 | -8x | +|||
| 114 | +
- show_labels = show_labels,+ ) |
|||
| 305 | -8x | +|||
| 115 | +
- afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ } |
|||
| 306 | -8x | +|||
| 116 | +
- table_names = table_names,+ |
|||
| 307 | -8x | +|||
| 117 | +
- nested = nested,+ #' Content Row Function to Add `alt_counts_df` Row Total to Labels |
|||
| 308 | -8x | +|||
| 118 | +
- extra_args = extra_args+ #' |
|||
| 309 | +119 |
- )+ #' This takes the label of the latest row split level and adds the row total from `alt_counts_df` |
||
| 310 | +120 |
- }+ #' in parentheses. This function differs from [c_label_n()] by taking row counts from `alt_counts_df` |
||
| 311 | +121 |
-
+ #' rather than `df`, and is used by [add_rowcounts()] when `alt_counts` is set to `TRUE`. |
||
| 312 | +122 |
- #' @describeIn count_occurrences_by_grade Layout-creating function which can take content function arguments+ #' |
||
| 313 | +123 |
- #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ #' @inheritParams argument_convention |
||
| 314 | +124 |
#' |
||
| 315 | +125 |
- #' @return+ #' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label. |
||
| 316 | +126 |
- #' * `summarize_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions,+ #' |
||
| 317 | +127 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows+ #' @seealso [c_label_n()] which performs the same function but retrieves row counts from `df` instead |
||
| 318 | +128 |
- #' containing the statistics from `s_count_occurrences_by_grade()` to the table layout.+ #' of `alt_counts_df`. |
||
| 319 | +129 |
#' |
||
| 320 | +130 |
- #' @examples+ #' @keywords internal |
||
| 321 | +131 |
- #' # Layout creating function with custom format.+ c_label_n_alt <- function(df, |
||
| 322 | +132 |
- #' basic_table() %>%+ labelstr, |
||
| 323 | +133 |
- #' add_colcounts() %>%+ .alt_df_row) {
|
||
| 324 | -+ | |||
| 134 | +7x |
- #' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
+ N_row_alt <- nrow(.alt_df_row) # nolint |
||
| 325 | -+ | |||
| 135 | +7x |
- #' summarize_occurrences_by_grade(+ label <- paste0(labelstr, " (N=", N_row_alt, ")")+ |
+ ||
| 136 | +7x | +
+ in_rows(+ |
+ ||
| 137 | +7x | +
+ .list = list(row_count = formatters::with_label(c(N_row_alt, N_row_alt), label)),+ |
+ ||
| 138 | +7x | +
+ .formats = c(row_count = function(x, ...) "") |
||
| 326 | +139 |
- #' var = "AESEV",+ ) |
||
| 327 | +140 |
- #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
+ } |
||
| 328 | +141 |
- #' ) %>%+ |
||
| 329 | +142 |
- #' build_table(df, alt_counts_df = df_adsl)+ #' Layout Creating Function to Add Row Total Counts |
||
| 330 | +143 |
#' |
||
| 331 | +144 |
- #' basic_table() %>%+ #' @description `r lifecycle::badge("stable")`
|
||
| 332 | +145 |
- #' add_colcounts() %>%+ #' |
||
| 333 | +146 |
- #' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
+ #' This works analogously to [rtables::add_colcounts()] but on the rows. This function |
||
| 334 | +147 |
- #' summarize_occurrences_by_grade(+ #' is a wrapper for [rtables::summarize_row_groups()]. |
||
| 335 | +148 |
- #' var = "AETOXGR",+ #' |
||
| 336 | +149 |
- #' grade_groups = grade_groups+ #' @inheritParams argument_convention |
||
| 337 | +150 |
- #' ) %>%+ #' @param alt_counts (`flag`)\cr whether row counts should be taken from `alt_counts_df` (`TRUE`) |
||
| 338 | +151 |
- #' build_table(df, alt_counts_df = df_adsl)+ #' or from `df` (`FALSE`). Defaults to `FALSE`. |
||
| 339 | +152 |
#' |
||
| 340 | +153 |
- #' @export+ #' @return A modified layout where the latest row split labels now have the row-wise |
||
| 341 | +154 |
- summarize_occurrences_by_grade <- function(lyt,+ #' total counts (i.e. without column-based subsetting) attached in parentheses. |
||
| 342 | +155 |
- var,+ #' |
||
| 343 | +156 |
- ...,+ #' @note Row count values are contained in these row count rows but are not displayed |
||
| 344 | +157 |
- .stats = NULL,+ #' so that they are not considered zero rows by default when pruning. |
||
| 345 | +158 |
- .formats = NULL,+ #' |
||
| 346 | +159 |
- .indent_mods = NULL,+ #' @examples |
||
| 347 | +160 |
- .labels = NULL) {
+ #' basic_table() %>% |
||
| 348 | -2x | +|||
| 161 | +
- cfun <- make_afun(+ #' split_cols_by("ARM") %>%
|
|||
| 349 | -2x | +|||
| 162 | +
- a_count_occurrences_by_grade,+ #' add_colcounts() %>% |
|||
| 350 | -2x | +|||
| 163 | +
- .stats = .stats,+ #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
|
|||
| 351 | -2x | +|||
| 164 | +
- .formats = .formats,+ #' add_rowcounts() %>% |
|||
| 352 | -2x | +|||
| 165 | +
- .labels = .labels,+ #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>%
|
|||
| 353 | -2x | +|||
| 166 | +
- .indent_mods = .indent_mods,+ #' build_table(DM) |
|||
| 354 | -2x | +|||
| 167 | +
- .ungroup_stats = "count_fraction"+ #' |
|||
| 355 | +168 |
- )+ #' @export |
||
| 356 | +169 |
-
+ add_rowcounts <- function(lyt, alt_counts = FALSE) {
|
||
| 357 | -2x | +170 | +6x |
summarize_row_groups( |
| 358 | -2x | -
- lyt = lyt,- |
- ||
| 359 | -2x | -
- var = var,- |
- ||
| 360 | -2x | +171 | +6x |
- cfun = cfun,+ lyt, |
| 361 | -2x | +172 | +6x |
- extra_args = list(...)+ cfun = if (alt_counts) c_label_n_alt else c_label_n |
| 362 | +173 |
) |
||
| 363 | +174 |
} |
| 1 | -- |
- #' Patient Counts with Abnormal Range Values- |
- ||
| 2 | +175 |
- #'+ |
||
| 3 | +176 |
- #' @description `r lifecycle::badge("stable")`
+ #' Obtain Column Indices |
||
| 4 | +177 |
#' |
||
| 5 | -- |
- #' Primary analysis variable `.var` indicates the abnormal range result (`character` or `factor`)- |
- ||
| 6 | -- |
- #' and additional analysis variables are `id` (`character` or `factor`) and `baseline` (`character` or- |
- ||
| 7 | +178 |
- #' `factor`). For each direction specified in `abnormal` (e.g. high or low) count patients in the+ #' @description `r lifecycle::badge("stable")`
|
||
| 8 | +179 |
- #' numerator and denominator as follows:+ #' |
||
| 9 | +180 |
- #' * `num` : The number of patients with this abnormality recorded while on treatment.+ #' Helper function to extract column indices from a `VTableTree` for a given |
||
| 10 | +181 |
- #' * `denom`: The number of patients with at least one post-baseline assessment.+ #' vector of column names. |
||
| 11 | +182 |
#' |
||
| 12 | +183 |
- #' @inheritParams argument_convention+ #' @param table_tree (`VTableTree`)\cr table to extract the indices from. |
||
| 13 | +184 |
- #' @param abnormal (named `list`)\cr list identifying the abnormal range level(s) in `var`. Defaults to+ #' @param col_names (`character`)\cr vector of column names. |
||
| 14 | +185 |
- #' `list(Low = "LOW", High = "HIGH")` but you can also group different levels into the named list,+ #' |
||
| 15 | +186 |
- #' for example, `abnormal = list(Low = c("LOW", "LOW LOW"), High = c("HIGH", "HIGH HIGH"))`.
+ #' @return A vector of column indices. |
||
| 16 | +187 |
#' |
||
| 17 | +188 |
- #' @note+ #' @export |
||
| 18 | +189 |
- #' * `count_abnormal()` only works with a single variable containing multiple abnormal levels.+ h_col_indices <- function(table_tree, col_names) {
|
||
| 19 | -+ | |||
| 190 | +1232x |
- #' * `df` should be filtered to include only post-baseline records.+ checkmate::assert_class(table_tree, "VTableNodeInfo") |
||
| 20 | -+ | |||
| 191 | +1232x |
- #' * the denominator includes patients that might have other abnormal levels at baseline,+ checkmate::assert_subset(col_names, names(attr(col_info(table_tree), "cextra_args")), empty.ok = FALSE) |
||
| 21 | -+ | |||
| 192 | +1232x |
- #' and patients with missing baseline. Patients with these abnormalities at+ match(col_names, names(attr(col_info(table_tree), "cextra_args"))) |
||
| 22 | +193 |
- #' baseline can be optionally excluded from numerator and denominator.+ } |
||
| 23 | +194 |
- #'+ |
||
| 24 | +195 |
- #' @name abnormal+ #' Labels or Names of List Elements |
||
| 25 | +196 |
- #' @include formatting_functions.R+ #' |
||
| 26 | +197 |
- NULL+ #' Internal helper function for working with nested statistic function results which typically |
||
| 27 | +198 |
-
+ #' don't have labels but names that we can use. |
||
| 28 | +199 |
- #' @describeIn abnormal Statistics function which counts patients with abnormal range values+ #' |
||
| 29 | +200 |
- #' for a single `abnormal` level.+ #' @param x a list |
||
| 30 | +201 |
#' |
||
| 31 | +202 |
- #' @param exclude_base_abn (`flag`)\cr whether to exclude subjects with baseline abnormality+ #' @return A `character` vector with the labels or names for the list elements. |
||
| 32 | +203 |
- #' from numerator and denominator.+ #' |
||
| 33 | +204 |
- #'+ #' @keywords internal |
||
| 34 | +205 |
- #' @return+ labels_or_names <- function(x) {
|
||
| 35 | -+ | |||
| 206 | +119x |
- #' * `s_count_abnormal()` returns the statistic `fraction` which is a vector with `num` and `denom` counts of patients.+ checkmate::assert_multi_class(x, c("data.frame", "list"))
|
||
| 36 | -+ | |||
| 207 | +119x |
- #' @examples+ labs <- sapply(x, obj_label) |
||
| 37 | -+ | |||
| 208 | +119x |
- #' library(dplyr)+ nams <- rlang::names2(x) |
||
| 38 | -+ | |||
| 209 | +119x |
- #'+ label_is_null <- sapply(labs, is.null) |
||
| 39 | -+ | |||
| 210 | +119x |
- #' df <- data.frame(+ result <- unlist(ifelse(label_is_null, nams, labs)) |
||
| 40 | -+ | |||
| 211 | +119x |
- #' USUBJID = as.character(c(1, 1, 2, 2)),+ return(result) |
||
| 41 | +212 |
- #' ANRIND = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
+ } |
||
| 42 | +213 |
- #' BNRIND = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
+
|
||
| 43 | +214 |
- #' ONTRTFL = c("", "Y", "", "Y"),
+ #' Convert to `rtable` |
||
| 44 | +215 |
- #' stringsAsFactors = FALSE+ #' |
||
| 45 | +216 |
- #' )+ #' @description `r lifecycle::badge("stable")`
|
||
| 46 | +217 |
#' |
||
| 47 | +218 |
- #' # Select only post-baseline records.+ #' This is a new generic function to convert objects to `rtable` tables. |
||
| 48 | +219 |
- #' df <- df %>%+ #' |
||
| 49 | +220 |
- #' filter(ONTRTFL == "Y")+ #' @param x the object which should be converted to an `rtable`. |
||
| 50 | +221 |
- #' @keywords internal+ #' @param ... additional arguments for methods. |
||
| 51 | +222 |
- s_count_abnormal <- function(df,+ #' |
||
| 52 | +223 |
- .var,+ #' @return An `rtables` table object. Note that the concrete class will depend on the method used. |
||
| 53 | +224 |
- abnormal = list(Low = "LOW", High = "HIGH"),+ #' |
||
| 54 | +225 |
- variables = list(id = "USUBJID", baseline = "BNRIND"),+ #' @export |
||
| 55 | +226 |
- exclude_base_abn = FALSE) {
- |
- ||
| 56 | -4x | -
- checkmate::assert_list(abnormal, types = "character", names = "named", len = 2, any.missing = FALSE)- |
- ||
| 57 | -4x | -
- checkmate::assert_true(any(unlist(abnormal) %in% levels(df[[.var]])))- |
- ||
| 58 | -4x | -
- checkmate::assert_factor(df[[.var]])- |
- ||
| 59 | -4x | -
- checkmate::assert_flag(exclude_base_abn)+ as.rtable <- function(x, ...) { # nolint
|
||
| 60 | -4x | +227 | +3x |
- assert_df_with_variables(df, c(range = .var, variables))+ UseMethod("as.rtable", x)
|
| 61 | -4x | +|||
| 228 | +
- checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
+ } |
|||
| 62 | -4x | +|||
| 229 | +
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+
|
|||
| 63 | +230 |
-
+ #' @describeIn as.rtable method for converting `data.frame` that contain numeric columns to `rtable`. |
||
| 64 | -4x | +|||
| 231 | +
- count_abnormal_single <- function(abn_name, abn) {
+ #' |
|||
| 65 | +232 |
- # Patients in the denominator fulfill:+ #' @param format the format which should be used for the columns. |
||
| 66 | +233 |
- # - have at least one post-baseline visit+ #' |
||
| 67 | +234 |
- # - their baseline must not be abnormal if `exclude_base_abn`.+ #' @method as.rtable data.frame |
||
| 68 | -8x | +|||
| 235 | +
- if (exclude_base_abn) {
+ #' |
|||
| 69 | -4x | +|||
| 236 | +
- denom_select <- !(df[[variables$baseline]] %in% abn)+ #' @examples |
|||
| 70 | +237 |
- } else {
+ #' x <- data.frame( |
||
| 71 | -4x | +|||
| 238 | +
- denom_select <- TRUE+ #' a = 1:10, |
|||
| 72 | +239 |
- }+ #' b = rnorm(10) |
||
| 73 | -8x | +|||
| 240 | +
- denom <- length(unique(df[denom_select, variables$id, drop = TRUE]))+ #' ) |
|||
| 74 | +241 |
-
+ #' as.rtable(x) |
||
| 75 | +242 |
- # Patients in the numerator fulfill:+ #' |
||
| 76 | +243 |
- # - have at least one post-baseline visit with the required abnormality level+ #' @export |
||
| 77 | +244 |
- # - are part of the denominator patients.+ as.rtable.data.frame <- function(x, format = "xx.xx", ...) {
|
||
| 78 | -8x | +245 | +3x |
- num_select <- (df[[.var]] %in% abn) & denom_select+ checkmate::assert_numeric(unlist(x)) |
| 79 | -8x | +246 | +2x |
- num <- length(unique(df[num_select, variables$id, drop = TRUE]))+ do.call( |
| 80 | -+ | |||
| 247 | +2x |
-
+ rtable, |
||
| 81 | -8x | +248 | +2x |
- formatters::with_label(c(num = num, denom = denom), abn_name)+ c( |
| 82 | -+ | |||
| 249 | +2x |
- }+ list( |
||
| 83 | -+ | |||
| 250 | +2x |
-
+ header = labels_or_names(x), |
||
| 84 | -+ | |||
| 251 | +2x |
- # This will define the abnormal levels theoretically possible for a specific lab parameter+ format = format |
||
| 85 | +252 |
- # within a split level of a layout.+ ), |
||
| 86 | -4x | +253 | +2x |
- abnormal_lev <- lapply(abnormal, intersect, levels(df[[.var]]))+ Map( |
| 87 | -4x | +254 | +2x |
- abnormal_lev <- abnormal_lev[vapply(abnormal_lev, function(x) length(x) > 0, logical(1))]+ function(row, row_name) {
|
| 88 | -+ | |||
| 255 | +20x |
-
+ do.call( |
||
| 89 | -4x | +256 | +20x |
- result <- sapply(names(abnormal_lev), function(i) count_abnormal_single(i, abnormal_lev[[i]]), simplify = FALSE)+ rrow, |
| 90 | -4x | +257 | +20x |
- result <- list(fraction = result)+ c(as.list(unname(row)), |
| 91 | -4x | +258 | +20x |
- result+ row.name = row_name |
| 92 | +259 |
- }+ ) |
||
| 93 | +260 |
-
+ ) |
||
| 94 | +261 |
- #' @describeIn abnormal Formatted analysis function which is used as `afun` in `count_abnormal()`.+ }, |
||
| 95 | -+ | |||
| 262 | +2x |
- #'+ row = as.data.frame(t(x)),+ |
+ ||
| 263 | +2x | +
+ row_name = rownames(x) |
||
| 96 | +264 |
- #' @return+ ) |
||
| 97 | +265 |
- #' * `a_count_abnormal()` returns the corresponding list with formatted [rtables::CellValue()].+ ) |
||
| 98 | +266 |
- #'+ ) |
||
| 99 | +267 |
- #' @keywords internal+ } |
||
| 100 | +268 |
- a_count_abnormal <- make_afun(+ |
||
| 101 | +269 |
- s_count_abnormal,+ #' Split parameters |
||
| 102 | +270 |
- .formats = c(fraction = format_fraction)+ #' |
||
| 103 | +271 |
- )+ #' @description `r lifecycle::badge("stable")`
|
||
| 104 | +272 |
-
+ #' |
||
| 105 | +273 |
- #' @describeIn abnormal Layout-creating function which can take statistics function arguments+ #' It divides the data in the vector `param` into the groups defined by `f` based on specified `values`. It is relevant |
||
| 106 | +274 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' in `rtables` layers so as to distribute parameters `.stats` or' `.formats` into lists with items corresponding to |
||
| 107 | +275 |
- #'+ #' specific analysis function. |
||
| 108 | +276 |
- #' @return+ #' |
||
| 109 | +277 |
- #' * `count_abnormal()` returns a layout object suitable for passing to further layouting functions,+ #' @param param (`vector`)\cr the parameter to be split. |
||
| 110 | +278 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' @param value (`vector`)\cr the value used to split. |
||
| 111 | +279 |
- #' the statistics from `s_count_abnormal()` to the table layout.+ #' @param f (`list` of `vectors`)\cr the reference to make the split |
||
| 112 | +280 |
#' |
||
| 113 | +281 |
- #' @examples+ #' @return A named `list` with the same element names as `f`, each containing the elements specified in `.stats`. |
||
| 114 | +282 |
- #' # Layout creating function.+ #' |
||
| 115 | +283 |
- #' basic_table() %>%+ #' @examples |
||
| 116 | +284 |
- #' count_abnormal(var = "ANRIND", abnormal = list(high = "HIGH", low = "LOW")) %>%+ #' f <- list( |
||
| 117 | +285 |
- #' build_table(df)+ #' surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
|
||
| 118 | +286 |
- #'+ #' surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
|
||
| 119 | +287 |
- #' # Passing of statistics function and formatting arguments.+ #' ) |
||
| 120 | +288 |
- #' df2 <- data.frame(+ #' |
||
| 121 | +289 |
- #' ID = as.character(c(1, 1, 2, 2)),+ #' .stats <- c("pt_at_risk", "rate_diff")
|
||
| 122 | +290 |
- #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
+ #' h_split_param(.stats, .stats, f = f) |
||
| 123 | +291 |
- #' BL_RANGE = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
+ #' |
||
| 124 | +292 |
- #' ONTRTFL = c("", "Y", "", "Y"),
+ #' # $surv |
||
| 125 | +293 |
- #' stringsAsFactors = FALSE+ #' # [1] "pt_at_risk" |
||
| 126 | +294 |
- #' )+ #' # |
||
| 127 | +295 |
- #'+ #' # $surv_diff |
||
| 128 | +296 |
- #' # Select only post-baseline records.+ #' # [1] "rate_diff" |
||
| 129 | +297 |
- #' df2 <- df2 %>%+ #' |
||
| 130 | +298 |
- #' filter(ONTRTFL == "Y")+ #' .formats <- c("pt_at_risk" = "xx", "event_free_rate" = "xxx")
|
||
| 131 | +299 |
- #'+ #' h_split_param(.formats, names(.formats), f = f) |
||
| 132 | +300 |
- #' basic_table() %>%+ #' |
||
| 133 | +301 |
- #' count_abnormal(+ #' # $surv |
||
| 134 | +302 |
- #' var = "RANGE",+ #' # pt_at_risk event_free_rate |
||
| 135 | +303 |
- #' abnormal = list(low = "LOW", high = "HIGH"),+ #' # "xx" "xxx" |
||
| 136 | +304 |
- #' variables = list(id = "ID", baseline = "BL_RANGE")+ #' # |
||
| 137 | +305 |
- #' ) %>%+ #' # $surv_diff |
||
| 138 | +306 |
- #' build_table(df2)+ #' # NULL |
||
| 139 | +307 |
#' |
||
| 140 | +308 |
#' @export |
||
| 141 | +309 |
- count_abnormal <- function(lyt,+ h_split_param <- function(param, |
||
| 142 | +310 |
- var,+ value, |
||
| 143 | +311 |
- nested = TRUE,+ f) {
|
||
| 144 | -+ | |||
| 312 | +21x |
- ...,+ y <- lapply(f, function(x) param[value %in% x]) |
||
| 145 | -+ | |||
| 313 | +21x |
- table_names = var,+ lapply(y, function(x) if (length(x) == 0) NULL else x) |
||
| 146 | +314 |
- .stats = NULL,+ } |
||
| 147 | +315 |
- .formats = NULL,+ |
||
| 148 | +316 |
- .labels = NULL,+ #' Get Selected Statistics Names |
||
| 149 | +317 |
- .indent_mods = NULL) {
- |
- ||
| 150 | -3x | -
- afun <- make_afun(- |
- ||
| 151 | -3x | -
- a_count_abnormal,- |
- ||
| 152 | -3x | -
- .stats = .stats,+ #' |
||
| 153 | -3x | +|||
| 318 | +
- .formats = .formats,+ #' Helper function to be used for creating `afun`. |
|||
| 154 | -3x | +|||
| 319 | +
- .labels = .labels,+ #' |
|||
| 155 | -3x | +|||
| 320 | +
- .indent_mods = .indent_mods,+ #' @param .stats (`vector` or `NULL`)\cr input to the layout creating function. Note that `NULL` means |
|||
| 156 | -3x | +|||
| 321 | +
- .ungroup_stats = "fraction"+ #' in this context that all default statistics should be used. |
|||
| 157 | +322 |
- )+ #' @param all_stats (`character`)\cr all statistics which can be selected here potentially. |
||
| 158 | +323 |
-
+ #' |
||
| 159 | -3x | +|||
| 324 | +
- checkmate::assert_string(var)+ #' @return A `character` vector with the selected statistics. |
|||
| 160 | +325 |
-
+ #' |
||
| 161 | -3x | +|||
| 326 | +
- analyze(+ #' @keywords internal |
|||
| 162 | -3x | +|||
| 327 | +
- lyt = lyt,+ afun_selected_stats <- function(.stats, all_stats) {
|
|||
| 163 | -3x | +328 | +2x |
- vars = var,+ checkmate::assert_character(.stats, null.ok = TRUE) |
| 164 | -3x | +329 | +2x |
- afun = afun,+ checkmate::assert_character(all_stats) |
| 165 | -3x | +330 | +2x |
- nested = nested,+ if (is.null(.stats)) {
|
| 166 | -3x | +331 | +1x |
- table_names = table_names,+ all_stats |
| 167 | -3x | +|||
| 332 | +
- extra_args = list(...),+ } else {
|
|||
| 168 | -3x | +333 | +1x |
- show_labels = "hidden"+ intersect(.stats, all_stats) |
| 169 | +334 |
- )+ } |
||
| 170 | +335 |
} |
| 1 | +336 |
- #' Estimation of Proportions per Level of Factor+ |
||
| 2 | +337 |
- #'+ #' Add Variable Labels to Top Left Corner in Table |
||
| 3 | +338 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 4 | +339 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 5 | +340 |
- #' Estimate the proportion along with confidence interval of a proportion+ #' |
||
| 6 | +341 |
- #' regarding the level of a factor.+ #' Helper layout creating function to just append the variable labels of a given variables vector |
||
| 7 | +342 |
- #'+ #' from a given dataset in the top left corner. If a variable label is not found then the |
||
| 8 | +343 |
- #' @inheritParams argument_convention+ #' variable name itself is used instead. Multiple variable labels are concatenated with slashes. |
||
| 9 | +344 |
#' |
||
| 10 | +345 |
- #' @seealso Relevant description function [d_onco_rsp_label()].+ #' @inheritParams argument_convention |
||
| 11 | +346 |
- #'+ #' @param vars (`character`)\cr variable names of which the labels are to be looked up in `df`. |
||
| 12 | +347 |
- #' @name estimate_multinomial_rsp+ #' @param indent (`integer`)\cr non-negative number of nested indent space, default to 0L which means no indent. |
||
| 13 | +348 |
- NULL+ #' 1L means two spaces indent, 2L means four spaces indent and so on. |
||
| 14 | +349 |
-
+ #' |
||
| 15 | +350 |
- #' Description of Standard Oncology Response+ #' @return A modified layout with the new variable label(s) added to the top-left material. |
||
| 16 | +351 |
#' |
||
| 17 | +352 |
- #' @description `r lifecycle::badge("stable")`
+ #' @note This is not an optimal implementation of course, since we are using here the data set |
||
| 18 | +353 |
- #'+ #' itself during the layout creation. When we have a more mature `rtables` implementation then |
||
| 19 | +354 |
- #' Describe the oncology response in a standard way.+ #' this will also be improved or not necessary anymore. |
||
| 20 | +355 |
#' |
||
| 21 | +356 |
- #' @param x (`character`)\cr the standard oncology code to be described.+ #' @examples |
||
| 22 | +357 |
- #'+ #' lyt <- basic_table() %>% |
||
| 23 | +358 |
- #' @return Response labels.+ #' split_cols_by("ARM") %>%
|
||
| 24 | +359 |
- #'+ #' add_colcounts() %>% |
||
| 25 | +360 |
- #' @seealso [estimate_multinomial_rsp()]+ #' split_rows_by("SEX") %>%
|
||
| 26 | +361 |
- #'+ #' append_varlabels(DM, "SEX") %>% |
||
| 27 | +362 |
- #' @examples+ #' analyze("AGE", afun = mean) %>%
|
||
| 28 | +363 |
- #' d_onco_rsp_label(+ #' append_varlabels(DM, "AGE", indent = 1) |
||
| 29 | +364 |
- #' c("CR", "PR", "SD", "NON CR/PD", "PD", "NE", "Missing", "<Missing>", "NE/Missing")
+ #' build_table(lyt, DM) |
||
| 30 | +365 |
- #' )+ #' |
||
| 31 | +366 |
- #'+ #' lyt <- basic_table() %>% |
||
| 32 | +367 |
- #' # Adding some values not considered in d_onco_rsp_label+ #' split_cols_by("ARM") %>%
|
||
| 33 | +368 |
- #'+ #' split_rows_by("SEX") %>%
|
||
| 34 | +369 |
- #' d_onco_rsp_label(+ #' analyze("AGE", afun = mean) %>%
|
||
| 35 | +370 |
- #' c("CR", "PR", "hello", "hi")
+ #' append_varlabels(DM, c("SEX", "AGE"))
|
||
| 36 | +371 |
- #' )+ #' build_table(lyt, DM) |
||
| 37 | +372 |
#' |
||
| 38 | +373 |
#' @export |
||
| 39 | +374 |
- d_onco_rsp_label <- function(x) {
- |
- ||
| 40 | -2x | -
- x <- as.character(x)+ append_varlabels <- function(lyt, df, vars, indent = 0L) {
|
||
| 41 | -2x | +375 | +3x |
- desc <- c(+ if (checkmate::test_flag(indent)) {
|
| 42 | -2x | +|||
| 376 | +! |
- CR = "Complete Response (CR)",+ warning("indent argument is now accepting integers. Boolean indent will be converted to integers.")
|
||
| 43 | -2x | +|||
| 377 | +! |
- PR = "Partial Response (PR)",+ indent <- as.integer(indent) |
||
| 44 | -2x | +|||
| 378 | +
- MR = "Minimal/Minor Response (MR)",+ } |
|||
| 45 | -2x | +|||
| 379 | +
- MRD = "Minimal Residual Disease (MRD)",+ |
|||
| 46 | -2x | +380 | +3x |
- SD = "Stable Disease (SD)",+ checkmate::assert_data_frame(df) |
| 47 | -2x | +381 | +3x |
- PD = "Progressive Disease (PD)",+ checkmate::assert_character(vars) |
| 48 | -2x | +382 | +3x |
- `NON CR/PD` = "Non-CR or Non-PD (NON CR/PD)",+ checkmate::assert_count(indent) |
| 49 | -2x | +|||
| 383 | +
- NE = "Not Evaluable (NE)",+ |
|||
| 50 | -2x | +384 | +3x |
- `NE/Missing` = "Missing or unevaluable",+ lab <- formatters::var_labels(df[vars], fill = TRUE) |
| 51 | -2x | +385 | +3x |
- Missing = "Missing",+ lab <- paste(lab, collapse = " / ") |
| 52 | -2x | +386 | +3x |
- `NA` = "Not Applicable (NA)",+ space <- paste(rep(" ", indent * 2), collapse = "")
|
| 53 | -2x | -
- ND = "Not Done (ND)"- |
- ||
| 54 | -+ | 387 | +3x |
- )+ lab <- paste0(space, lab) |
| 55 | +388 | |||
| 56 | -2x | -
- values_label <- vapply(- |
- ||
| 57 | -2x | +389 | +3x |
- X = x,+ append_topleft(lyt, lab) |
| 58 | -2x | +|||
| 390 | +
- FUN.VALUE = character(1),+ } |
|||
| 59 | -2x | +
| 1 | +
- function(val) {
+ #' Controls for Cox Regression |
|||
| 60 | -! | +|||
| 2 | +
- if (val %in% names(desc)) desc[val] else val+ #' |
|||
| 61 | +3 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 62 | +4 |
- )+ #' |
||
| 63 | +5 |
-
+ #' Sets a list of parameters for Cox regression fit. Used internally. |
||
| 64 | -2x | +|||
| 6 | +
- return(factor(values_label, levels = c(intersect(desc, values_label), setdiff(values_label, desc))))+ #' |
|||
| 65 | +7 |
- }+ #' @inheritParams argument_convention |
||
| 66 | +8 |
-
+ #' @param pval_method (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`. |
||
| 67 | +9 |
- #' @describeIn estimate_multinomial_rsp Statistics function which feeds the length of `x` as number+ #' @param interaction (`flag`)\cr if `TRUE`, the model includes the interaction between the studied |
||
| 68 | +10 |
- #' of successes, and `.N_col` as total number of successes and failures into [s_proportion()].+ #' treatment and candidate covariate. Note that for univariate models without treatment arm, and |
||
| 69 | +11 |
- #'+ #' multivariate models, no interaction can be used so that this needs to be `FALSE`. |
||
| 70 | +12 |
- #' @return+ #' @param ties (`string`)\cr among `exact` (equivalent to `DISCRETE` in SAS), `efron` and `breslow`, |
||
| 71 | +13 |
- #' * `s_length_proportion()` returns statistics from [s_proportion()].+ #' see [survival::coxph()]. Note: there is no equivalent of SAS `EXACT` method in R. |
||
| 72 | +14 |
#' |
||
| 73 | +15 |
- #' @examples+ #' @return A `list` of items with names corresponding to the arguments. |
||
| 74 | +16 |
- #' s_length_proportion(rep("CR", 10), .N_col = 100)
+ #' |
||
| 75 | +17 |
- #' s_length_proportion(factor(character(0)), .N_col = 100)+ #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()]. |
||
| 76 | +18 |
#' |
||
| 77 | +19 |
- #' @export+ #' @examples |
||
| 78 | +20 |
- s_length_proportion <- function(x,+ #' control_coxreg() |
||
| 79 | +21 |
- .N_col, # nolint+ #' |
||
| 80 | +22 |
- ...) {
+ #' @export |
||
| 81 | -4x | +|||
| 23 | +
- checkmate::assert_multi_class(x, classes = c("factor", "character"))
+ control_coxreg <- function(pval_method = c("wald", "likelihood"),
|
|||
| 82 | -3x | +|||
| 24 | +
- checkmate::assert_vector(x, min.len = 0, max.len = .N_col)+ ties = c("exact", "efron", "breslow"),
|
|||
| 83 | -2x | +|||
| 25 | +
- checkmate::assert_vector(unique(x), min.len = 0, max.len = 1)+ conf_level = 0.95, |
|||
| 84 | +26 |
-
+ interaction = FALSE) {
|
||
| 85 | -1x | +27 | +43x |
- n_true <- length(x)+ pval_method <- match.arg(pval_method) |
| 86 | -1x | +28 | +43x |
- n_false <- .N_col - n_true+ ties <- match.arg(ties) |
| 87 | -1x | +29 | +43x |
- x_logical <- rep(c(TRUE, FALSE), c(n_true, n_false))+ checkmate::assert_flag(interaction) |
| 88 | -1x | -
- s_proportion(df = x_logical, ...)- |
- ||
| 89 | -- |
- }- |
- ||
| 90 | -+ | 30 | +43x |
-
+ assert_proportion_value(conf_level) |
| 91 | -+ | |||
| 31 | +43x |
- #' @describeIn estimate_multinomial_rsp Formatted analysis function which is used as `afun`+ list( |
||
| 92 | -+ | |||
| 32 | +43x |
- #' in `estimate_multinomial_response()`.+ pval_method = pval_method, |
||
| 93 | -+ | |||
| 33 | +43x |
- #'+ ties = ties, |
||
| 94 | -+ | |||
| 34 | +43x |
- #' @return+ conf_level = conf_level, |
||
| 95 | -+ | |||
| 35 | +43x |
- #' * `a_length_proportion()` returns the corresponding list with formatted [rtables::CellValue()].+ interaction = interaction |
||
| 96 | +36 |
- #'+ ) |
||
| 97 | +37 |
- #' @examples+ } |
||
| 98 | +38 |
- #' a_length_proportion(rep("CR", 10), .N_col = 100)
+
|
||
| 99 | +39 |
- #' a_length_proportion(factor(character(0)), .N_col = 100)+ #' Custom Tidy Methods for Cox Regression |
||
| 100 | +40 |
#' |
||
| 101 | -- |
- #' @export- |
- ||
| 102 | -- |
- a_length_proportion <- make_afun(- |
- ||
| 103 | +41 |
- s_length_proportion,+ #' @description `r lifecycle::badge("stable")`
|
||
| 104 | +42 |
- .formats = c(+ #' |
||
| 105 | +43 |
- n_prop = "xx (xx.x%)",+ #' @inheritParams argument_convention |
||
| 106 | +44 |
- prop_ci = "(xx.xx, xx.xx)"+ #' @param x (`list`)\cr Result of the Cox regression model fitted by [fit_coxreg_univar()] (for univariate models) |
||
| 107 | +45 |
- )+ #' or [fit_coxreg_multivar()] (for multivariate models). |
||
| 108 | +46 |
- )+ #' |
||
| 109 | +47 |
-
+ #' @return [tidy()] returns: |
||
| 110 | +48 |
- #' @describeIn estimate_multinomial_rsp Layout-creating function which can take statistics function arguments+ #' * For `summary.coxph` objects, a `data.frame` with columns: `Pr(>|z|)`, `exp(coef)`, `exp(-coef)`, `lower .95`, |
||
| 111 | +49 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()] and+ #' `upper .95`, `level`, and `n`. |
||
| 112 | +50 |
- #' [rtables::summarize_row_groups()].+ #' * For `coxreg.univar` objects, a `data.frame` with columns: `effect`, `term`, `term_label`, `level`, `n`, `hr`, |
||
| 113 | +51 |
- #'+ #' `lcl`, `ucl`, `pval`, and `ci`. |
||
| 114 | +52 |
- #' @return+ #' * For `coxreg.multivar` objects, a `data.frame` with columns: `term`, `pval`, `term_label`, `hr`, `lcl`, `ucl`, |
||
| 115 | +53 |
- #' * `estimate_multinomial_response()` returns a layout object suitable for passing to further layouting functions,+ #' `level`, and `ci`. |
||
| 116 | +54 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 117 | +55 |
- #' the statistics from `s_length_proportion()` to the table layout.+ #' @seealso [cox_regression] |
||
| 118 | +56 |
#' |
||
| 119 | +57 |
- #' @examples+ #' @name tidy_coxreg |
||
| 120 | +58 |
- #' library(dplyr)+ NULL |
||
| 121 | +59 |
- #'+ |
||
| 122 | +60 |
- #' # Use of the layout creating function.+ #' @describeIn tidy_coxreg Custom tidy method for [survival::coxph()] summary results. |
||
| 123 | +61 |
- #' dta_test <- data.frame(+ #' |
||
| 124 | +62 |
- #' USUBJID = paste0("S", 1:12),
+ #' Tidy the [survival::coxph()] results into a `data.frame` to extract model results. |
||
| 125 | +63 |
- #' ARM = factor(rep(LETTERS[1:3], each = 4)),+ #' |
||
| 126 | +64 |
- #' AVAL = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0))+ #' @method tidy summary.coxph |
||
| 127 | +65 |
- #' ) %>% mutate(+ #' |
||
| 128 | +66 |
- #' AVALC = factor(AVAL,+ #' @examples |
||
| 129 | +67 |
- #' levels = c(0, 1),+ #' library(survival) |
||
| 130 | +68 |
- #' labels = c("Complete Response (CR)", "Partial Response (PR)")
+ #' library(broom) |
||
| 131 | +69 |
- #' )+ #' |
||
| 132 | +70 |
- #' )+ #' set.seed(1, kind = "Mersenne-Twister") |
||
| 133 | +71 |
#' |
||
| 134 | +72 |
- #' lyt <- basic_table() %>%+ #' dta_bladder <- with( |
||
| 135 | +73 |
- #' split_cols_by("ARM") %>%
+ #' data = bladder[bladder$enum < 5, ], |
||
| 136 | +74 |
- #' estimate_multinomial_response(var = "AVALC")+ #' data.frame( |
||
| 137 | +75 |
- #'+ #' time = stop, |
||
| 138 | +76 |
- #' tbl <- build_table(lyt, dta_test)+ #' status = event, |
||
| 139 | +77 |
- #'+ #' armcd = as.factor(rx), |
||
| 140 | +78 |
- #' html <- as_html(tbl)+ #' covar1 = as.factor(enum), |
||
| 141 | +79 |
- #' html+ #' covar2 = factor( |
||
| 142 | +80 |
- #' \donttest{
+ #' sample(as.factor(enum)), |
||
| 143 | +81 |
- #' Viewer(html)+ #' levels = 1:4, labels = c("F", "F", "M", "M")
|
||
| 144 | +82 |
- #' }+ #' ) |
||
| 145 | +83 |
- #'+ #' ) |
||
| 146 | +84 |
- #' @export+ #' ) |
||
| 147 | +85 |
- estimate_multinomial_response <- function(lyt,+ #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
|
||
| 148 | +86 |
- var,+ #' formatters::var_labels(dta_bladder)[names(labels)] <- labels |
||
| 149 | +87 |
- nested = TRUE,+ #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
||
| 150 | +88 |
- ...,+ #' |
||
| 151 | +89 |
- show_labels = "hidden",+ #' formula <- "survival::Surv(time, status) ~ armcd + covar1" |
||
| 152 | +90 |
- table_names = var,+ #' msum <- summary(coxph(stats::as.formula(formula), data = dta_bladder)) |
||
| 153 | +91 |
- .stats = "prop_ci",+ #' tidy(msum) |
||
| 154 | +92 |
- .formats = NULL,+ #' |
||
| 155 | +93 |
- .labels = NULL,+ #' @export |
||
| 156 | +94 |
- .indent_mods = NULL) {
- |
- ||
| 157 | -1x | -
- afun <- make_afun(+ tidy.summary.coxph <- function(x, # nolint |
||
| 158 | -1x | +|||
| 95 | +
- a_length_proportion,+ ...) {
|
|||
| 159 | -1x | +96 | +124x |
- .stats = .stats,+ checkmate::assert_class(x, "summary.coxph") |
| 160 | -1x | +97 | +124x |
- .formats = .formats,+ pval <- x$coefficients |
| 161 | -1x | +98 | +124x |
- .labels = .labels,+ confint <- x$conf.int |
| 162 | -1x | +99 | +124x |
- .indent_mods = .indent_mods+ levels <- rownames(pval) |
| 163 | +100 |
- )+ |
||
| 164 | -1x | +101 | +124x |
- lyt <- split_rows_by(lyt, var = var)+ pval <- tibble::as_tibble(pval) |
| 165 | -1x | +102 | +124x |
- lyt <- summarize_row_groups(lyt)+ confint <- tibble::as_tibble(confint) |
| 166 | +103 | |||
| 167 | -1x | -
- analyze(- |
- ||
| 168 | -1x | -
- lyt,- |
- ||
| 169 | -1x | -
- vars = var,- |
- ||
| 170 | -1x | -
- afun = afun,- |
- ||
| 171 | -1x | +104 | +124x |
- show_labels = show_labels,+ ret <- cbind(pval[, grepl("Pr", names(pval))], confint)
|
| 172 | -1x | +105 | +124x |
- table_names = table_names,+ ret$level <- levels |
| 173 | -1x | +106 | +124x |
- nested = nested,+ ret$n <- x[["n"]] |
| 174 | -1x | +107 | +124x |
- extra_args = list(...)+ ret |
| 175 | +108 |
- )+ } |
||
| 176 | +109 |
- }+ |
| 1 | +110 |
- #' Split Function to Configure Risk Difference Column+ #' @describeIn tidy_coxreg Custom tidy method for a univariate Cox regression. |
||
| 2 | +111 |
#' |
||
| 3 | +112 |
- #' @description `r lifecycle::badge("stable")`
+ #' Tidy up the result of a Cox regression model fitted by [fit_coxreg_univar()]. |
||
| 4 | +113 |
#' |
||
| 5 | +114 |
- #' Wrapper function for [rtables::add_combo_levels()] which configures settings for the risk difference+ #' @method tidy coxreg.univar |
||
| 6 | +115 |
- #' column to be added to an `rtables` object. To add a risk difference column to a table, this function+ #' |
||
| 7 | +116 |
- #' should be used as `split_fun` in calls to [rtables::split_cols_by()], followed by setting argument+ #' @examples |
||
| 8 | +117 |
- #' `riskdiff` to `TRUE` in all following analyze function calls.+ #' ## Cox regression: arm + 1 covariate. |
||
| 9 | +118 |
- #'+ #' mod1 <- fit_coxreg_univar( |
||
| 10 | +119 |
- #' @param arm_x (`character`)\cr Name of reference arm to use in risk difference calculations.+ #' variables = list( |
||
| 11 | +120 |
- #' @param arm_y (`character`)\cr Name of arm to compare to reference arm in risk difference calculations.+ #' time = "time", event = "status", arm = "armcd", |
||
| 12 | +121 |
- #' @param col_label (`character`)\cr Label to use when rendering the risk difference column within the table.+ #' covariates = "covar1" |
||
| 13 | +122 |
- #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`.+ #' ), |
||
| 14 | +123 |
- #'+ #' data = dta_bladder, |
||
| 15 | +124 |
- #' @return A closure suitable for use as a split function (`split_fun`) within [rtables::split_cols_by()]+ #' control = control_coxreg(conf_level = 0.91) |
||
| 16 | +125 |
- #' when creating a table layout.+ #' ) |
||
| 17 | +126 |
#' |
||
| 18 | +127 |
- #' @seealso [stat_propdiff_ci()] for details on risk difference calculation.+ #' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates. |
||
| 19 | +128 |
- #'+ #' mod2 <- fit_coxreg_univar( |
||
| 20 | +129 |
- #' @examples+ #' variables = list( |
||
| 21 | +130 |
- #' adae <- tern_ex_adae+ #' time = "time", event = "status", arm = "armcd", |
||
| 22 | +131 |
- #' adae$AESEV <- factor(adae$AESEV)+ #' covariates = c("covar1", "covar2")
|
||
| 23 | +132 |
- #'+ #' ), |
||
| 24 | +133 |
- #' lyt <- basic_table() %>%+ #' data = dta_bladder, |
||
| 25 | +134 |
- #' split_cols_by("ARMCD", split_fun = add_riskdiff(arm_x = "ARM A", arm_y = "ARM B")) %>%
+ #' control = control_coxreg(conf_level = 0.91, interaction = TRUE) |
||
| 26 | +135 |
- #' count_occurrences_by_grade(+ #' ) |
||
| 27 | +136 |
- #' var = "AESEV",+ #' |
||
| 28 | +137 |
- #' riskdiff = TRUE+ #' tidy(mod1) |
||
| 29 | +138 |
- #' )+ #' tidy(mod2) |
||
| 30 | +139 |
#' |
||
| 31 | +140 |
- #' tbl <- build_table(lyt, df = adae)+ #' @export |
||
| 32 | +141 |
- #' tbl+ tidy.coxreg.univar <- function(x, # nolint |
||
| 33 | +142 |
- #'+ ...) {
|
||
| 34 | -+ | |||
| 143 | +29x |
- #' @export+ checkmate::assert_class(x, "coxreg.univar") |
||
| 35 | -+ | |||
| 144 | +29x |
- add_riskdiff <- function(arm_x,+ mod <- x$mod |
||
| 36 | -+ | |||
| 145 | +29x |
- arm_y,+ vars <- c(x$vars$arm, x$vars$covariates) |
||
| 37 | -+ | |||
| 146 | +29x |
- col_label = "Risk Difference (%) (95% CI)",+ has_arm <- "arm" %in% names(x$vars) |
||
| 38 | +147 |
- pct = TRUE) {
+
|
||
| 39 | -6x | +148 | +29x |
- sapply(c(arm_x, arm_y, col_label), checkmate::assert_character, len = 1)+ result <- if (!has_arm) {
|
| 40 | -6x | +149 | +5x |
- combodf <- tibble::tribble(+ Map( |
| 41 | -6x | +150 | +5x |
- ~valname, ~label, ~levelcombo, ~exargs,+ mod = mod, vars = vars, |
| 42 | -6x | -
- paste("riskdiff", arm_x, arm_y, sep = "_"), col_label, c(arm_x, arm_y), list()
- |
- ||
| 43 | -+ | 151 | +5x |
- )+ f = function(mod, vars) {
|
| 44 | +152 | 6x |
- if (pct) combodf$valname <- paste0(combodf$valname, "_pct")+ h_coxreg_multivar_extract( |
|
| 45 | +153 | 6x |
- add_combo_levels(combodf)+ var = vars, |
|
| 46 | -+ | |||
| 154 | +6x |
- }+ data = x$data, |
||
| 47 | -+ | |||
| 155 | +6x |
-
+ mod = mod, |
||
| 48 | -+ | |||
| 156 | +6x |
- #' Analysis Function to Calculate Risk Difference Column Values+ control = x$control |
||
| 49 | +157 |
- #'+ ) |
||
| 50 | +158 |
- #' In the risk difference column, this function uses the statistics function associated with `afun` to+ } |
||
| 51 | +159 |
- #' calculates risk difference values from arm X (reference group) and arm Y. These arms are specified+ ) |
||
| 52 | -+ | |||
| 160 | +29x |
- #' when configuring the risk difference column which is done using the [add_riskdiff()] split function in+ } else if (x$control$interaction) {
|
||
| 53 | -+ | |||
| 161 | +10x |
- #' the previous call to [rtables::split_cols_by()]. For all other columns, applies `afun` as usual. This+ Map( |
||
| 54 | -+ | |||
| 162 | +10x |
- #' function utilizes the [stat_propdiff_ci()] function to perform risk difference calculations.+ mod = mod, covar = vars, |
||
| 55 | -+ | |||
| 163 | +10x |
- #'+ f = function(mod, covar) {
|
||
| 56 | -+ | |||
| 164 | +22x |
- #' @inheritParams argument_convention+ h_coxreg_extract_interaction( |
||
| 57 | -+ | |||
| 165 | +22x |
- #' @param afun (named `list`)\cr A named list containing one name-value pair where the name corresponds to+ effect = x$vars$arm, covar = covar, mod = mod, data = x$data, |
||
| 58 | -+ | |||
| 166 | +22x |
- #' the name of the statistics function that should be used in calculations and the value is the corresponding+ at = x$at, control = x$control |
||
| 59 | +167 |
- #' analysis function.+ ) |
||
| 60 | +168 |
- #' @param s_args (named `list`)\cr Additional arguments to be passed to the statistics function and analysis+ } |
||
| 61 | +169 |
- #' function supplied in `afun`.+ ) |
||
| 62 | +170 |
- #'+ } else {
|
||
| 63 | -+ | |||
| 171 | +14x |
- #' @return A list of formatted [rtables::CellValue()].+ Map( |
||
| 64 | -+ | |||
| 172 | +14x |
- #'+ mod = mod, vars = vars, |
||
| 65 | -+ | |||
| 173 | +14x |
- #' @seealso+ f = function(mod, vars) {
|
||
| 66 | -+ | |||
| 174 | +36x |
- #' * [stat_propdiff_ci()] for details on risk difference calculation.+ h_coxreg_univar_extract( |
||
| 67 | -+ | |||
| 175 | +36x |
- #' * Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()] with+ effect = x$vars$arm, covar = vars, data = x$data, mod = mod, |
||
| 68 | -+ | |||
| 176 | +36x |
- #' `riskdiff` argument set to `TRUE` in subsequent analyze functions calls, adds a risk difference column+ control = x$control |
||
| 69 | +177 |
- #' to a table layout.+ ) |
||
| 70 | +178 |
- #'+ } |
||
| 71 | +179 |
- #' @keywords internal+ ) |
||
| 72 | +180 |
- afun_riskdiff <- function(df,+ } |
||
| 73 | -+ | |||
| 181 | +29x |
- labelstr = "",+ result <- do.call(rbind, result) |
||
| 74 | +182 |
- .var,+ |
||
| 75 | -+ | |||
| 183 | +29x |
- .N_col, # nolint+ result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl)) |
||
| 76 | -+ | |||
| 184 | +29x |
- .N_row, # nolint+ result$n <- lapply(result$n, empty_vector_if_na) |
||
| 77 | -+ | |||
| 185 | +29x |
- .df_row,+ result$ci <- lapply(result$ci, empty_vector_if_na) |
||
| 78 | -+ | |||
| 186 | +29x |
- .spl_context,+ result$hr <- lapply(result$hr, empty_vector_if_na) |
||
| 79 | -+ | |||
| 187 | +29x |
- .all_col_counts,+ if (x$control$interaction) {
|
||
| 80 | -+ | |||
| 188 | +10x |
- .stats,+ result$pval_inter <- lapply(result$pval_inter, empty_vector_if_na) |
||
| 81 | +189 |
- .indent_mods,+ # Remove interaction p-values due to change in specifications. |
||
| 82 | -+ | |||
| 190 | +10x |
- afun,+ result$pval[result$effect != "Treatment:"] <- NA |
||
| 83 | +191 |
- s_args = list()) {
+ } |
||
| 84 | -36x | -
- if (!any(grepl("riskdiff", names(.spl_context)))) {
- |
- ||
| 85 | -! | +192 | +29x |
- stop(+ result$pval <- lapply(result$pval, empty_vector_if_na) |
| 86 | -! | +|||
| 193 | +29x |
- "Please set up levels to use in risk difference calculations using the `add_riskdiff` ",+ attr(result, "conf_level") <- x$control$conf_level |
||
| 87 | -! | +|||
| 194 | +29x |
- "split function within `split_cols_by`. See ?add_riskdiff for details."+ result |
||
| 88 | +195 |
- )+ } |
||
| 89 | +196 |
- }- |
- ||
| 90 | -36x | -
- checkmate::assert_list(afun, len = 1, types = "function")- |
- ||
| 91 | -36x | -
- checkmate::assert_named(afun)+ |
||
| 92 | +197 | - - | -||
| 93 | -36x | -
- afun_args <- list(.var = .var, .df_row = .df_row, .N_row = .N_row, denom = "N_col", labelstr = labelstr)- |
- ||
| 94 | -36x | -
- afun_args <- afun_args[intersect(names(afun_args), names(as.list(args(afun[[1]]))))]- |
- ||
| 95 | -! | -
- if ("denom" %in% names(s_args)) afun_args[["denom"]] <- NULL
+ #' @describeIn tidy_coxreg Custom tidy method for a multivariate Cox regression. |
||
| 96 | +198 | - - | -||
| 97 | -36x | -
- cur_split <- tail(.spl_context$cur_col_split_val[[1]], 1)- |
- ||
| 98 | -36x | -
- if (!grepl("^riskdiff", cur_split)) {
+ #' |
||
| 99 | +199 |
- # Apply basic afun (no risk difference) in all other columns+ #' Tidy up the result of a Cox regression model fitted by [fit_coxreg_multivar()]. |
||
| 100 | -27x | +|||
| 200 | +
- do.call(afun[[1]], args = c(list(df = df, .N_col = .N_col), afun_args, s_args))+ #' |
|||
| 101 | +201 |
- } else {
+ #' @method tidy coxreg.multivar |
||
| 102 | -9x | +|||
| 202 | +
- arm_x <- strsplit(cur_split, "_")[[1]][2]+ #' |
|||
| 103 | -9x | +|||
| 203 | +
- arm_y <- strsplit(cur_split, "_")[[1]][3]+ #' @examples |
|||
| 104 | -9x | +|||
| 204 | +
- if (length(.spl_context$cur_col_split[[1]]) > 1) { # Different split name for nested column splits
+ #' multivar_model <- fit_coxreg_multivar( |
|||
| 105 | -! | +|||
| 205 | +
- arm_spl_x <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 2)], collapse = ""))
+ #' variables = list( |
|||
| 106 | -! | +|||
| 206 | +
- arm_spl_y <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 3)], collapse = ""))
+ #' time = "time", event = "status", arm = "armcd", |
|||
| 107 | +207 |
- } else {
+ #' covariates = c("covar1", "covar2")
|
||
| 108 | -9x | +|||
| 208 | +
- arm_spl_x <- arm_x+ #' ), |
|||
| 109 | -9x | +|||
| 209 | +
- arm_spl_y <- arm_y+ #' data = dta_bladder |
|||
| 110 | +210 |
- }+ #' ) |
||
| 111 | -9x | +|||
| 211 | +
- N_col_x <- .all_col_counts[[arm_spl_x]] # nolint+ #' broom::tidy(multivar_model) |
|||
| 112 | -9x | +|||
| 212 | +
- N_col_y <- .all_col_counts[[arm_spl_y]] # nolint+ #' |
|||
| 113 | -9x | +|||
| 213 | +
- cur_var <- tail(.spl_context$cur_col_split[[1]], 1)+ #' @export |
|||
| 114 | +214 |
-
+ tidy.coxreg.multivar <- function(x, # nolint |
||
| 115 | +215 |
- # Apply statistics function to arm X and arm Y data+ ...) {
|
||
| 116 | -9x | +216 | +8x |
- s_x <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_x, ], .N_col = N_col_x), afun_args, s_args))+ checkmate::assert_class(x, "coxreg.multivar") |
| 117 | -9x | +217 | +8x |
- s_y <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_y, ], .N_col = N_col_y), afun_args, s_args))+ vars <- c(x$vars$arm, x$vars$covariates) |
| 118 | +218 | |||
| 119 | +219 |
- # Get statistic name and row names- |
- ||
| 120 | -9x | -
- stat <- ifelse("count_fraction" %in% names(s_x), "count_fraction", "unique")
- |
- ||
| 121 | -9x | -
- if ("flag_variables" %in% names(s_args)) {
+ # Convert the model summaries to data. |
||
| 122 | -1x | +220 | +8x |
- var_nms <- s_args$flag_variables+ result <- Map( |
| 123 | +221 | 8x |
- } else if (!is.null(names(s_x[[stat]]))) {
+ vars = vars, |
|
| 124 | -2x | -
- var_nms <- names(s_x[[stat]])- |
- ||
| 125 | -+ | 222 | +8x |
- } else {
+ f = function(vars) {
|
| 126 | -6x | +223 | +28x |
- var_nms <- ""+ h_coxreg_multivar_extract( |
| 127 | -6x | +224 | +28x |
- s_x[[stat]] <- list(s_x[[stat]])+ var = vars, data = x$data, |
| 128 | -6x | +225 | +28x |
- s_y[[stat]] <- list(s_y[[stat]])+ mod = x$mod, control = x$control |
| 129 | +226 |
- }+ ) |
||
| 130 | +227 |
-
+ } |
||
| 131 | +228 |
- # Calculate risk difference for each row, repeated if multiple statistics in table+ ) |
||
| 132 | -9x | +229 | +8x |
- pct <- tail(strsplit(cur_split, "_")[[1]], 1) == "pct"+ result <- do.call(rbind, result)+ |
+
| 230 | ++ | + | ||
| 133 | -9x | +231 | +8x |
- rd_ci <- rep(stat_propdiff_ci(+ result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl)) |
| 134 | -9x | +232 | +8x |
- lapply(s_x[[stat]], `[`, 1), lapply(s_y[[stat]], `[`, 1),+ result$ci <- lapply(result$ci, empty_vector_if_na) |
| 135 | -9x | +233 | +8x |
- N_col_x, N_col_y,+ result$hr <- lapply(result$hr, empty_vector_if_na) |
| 136 | -9x | +234 | +8x |
- list_names = var_nms,+ result$pval <- lapply(result$pval, empty_vector_if_na) |
| 137 | -9x | +235 | +8x |
- pct = pct+ result <- result[, names(result) != "n"] |
| 138 | -9x | +236 | +8x |
- ), max(1, length(.stats)))+ attr(result, "conf_level") <- x$control$conf_level |
| 139 | +237 | |||
| 140 | -9x | +238 | +8x |
- in_rows(.list = rd_ci, .formats = "xx.x (xx.x - xx.x)", .indent_mods = .indent_mods)+ result |
| 141 | +239 |
- }+ } |
||
| 142 | +240 |
- }+ |
| 1 | +241 |
- #' Count Patients with Marked Laboratory Abnormalities+ #' Fits for Cox Proportional Hazards Regression |
||
| 2 | +242 |
#' |
||
| 3 | +243 |
#' @description `r lifecycle::badge("stable")`
|
||
| 4 | +244 |
#' |
||
| 5 | +245 |
- #' Primary analysis variable `.var` indicates whether single, replicated or last marked laboratory+ #' Fitting functions for univariate and multivariate Cox regression models. |
||
| 6 | +246 |
- #' abnormality was observed (`factor`). Additional analysis variables are `id` (`character` or `factor`)+ #' |
||
| 7 | +247 |
- #' and `direction` (`factor`) indicating the direction of the abnormality. Denominator is number of+ #' @param variables (`list`)\cr a named list corresponds to the names of variables found in `data`, passed as a named |
||
| 8 | +248 |
- #' patients with at least one valid measurement during the analysis.+ #' list and corresponding to `time`, `event`, `arm`, `strata`, and `covariates` terms. If `arm` is missing from |
||
| 9 | +249 |
- #' * For `Single, not last` and `Last or replicated`: Numerator is number of patients+ #' `variables`, then only Cox model(s) including the `covariates` will be fitted and the corresponding effect |
||
| 10 | +250 |
- #' with `Single, not last` and `Last or replicated` levels, respectively.+ #' estimates will be tabulated later. |
||
| 11 | +251 |
- #' * For `Any`: Numerator is the number of patients with either single or+ #' @param data (`data.frame`)\cr the dataset containing the variables to fit the models. |
||
| 12 | +252 |
- #' replicated marked abnormalities.+ #' @param at (`list` of `numeric`)\cr when the candidate covariate is a `numeric`, use `at` to specify |
||
| 13 | +253 |
- #'+ #' the value of the covariate at which the effect should be estimated. |
||
| 14 | +254 |
- #' @inheritParams argument_convention+ #' @param control (`list`)\cr a list of parameters as returned by the helper function [control_coxreg()]. |
||
| 15 | +255 |
- #' @param category (`list`)\cr with different marked category names for single+ #' |
||
| 16 | +256 |
- #' and last or replicated.+ #' @seealso [h_cox_regression] for relevant helper functions, [cox_regression]. |
||
| 17 | +257 |
#' |
||
| 18 | +258 |
- #' @note `Single, not last` and `Last or replicated` levels are mutually exclusive. If a patient has+ #' @examples |
||
| 19 | +259 |
- #' abnormalities that meet both the `Single, not last` and `Last or replicated` criteria, then the+ #' library(survival) |
||
| 20 | +260 |
- #' patient will be counted only under the `Last or replicated` category.+ #' |
||
| 21 | +261 |
- #'+ #' set.seed(1, kind = "Mersenne-Twister") |
||
| 22 | +262 |
- #' @name abnormal_by_marked+ #' |
||
| 23 | +263 |
- NULL+ #' # Testing dataset [survival::bladder]. |
||
| 24 | +264 |
-
+ #' dta_bladder <- with( |
||
| 25 | +265 |
- #' @describeIn abnormal_by_marked Statistics function for patients with marked lab abnormalities.+ #' data = bladder[bladder$enum < 5, ], |
||
| 26 | +266 |
- #'+ #' data.frame( |
||
| 27 | +267 |
- #' @return+ #' time = stop, |
||
| 28 | +268 |
- #' * `s_count_abnormal_by_marked()` returns statistic `count_fraction` with `Single, not last`,+ #' status = event, |
||
| 29 | +269 |
- #' `Last or replicated`, and `Any` results.+ #' armcd = as.factor(rx), |
||
| 30 | +270 |
- #'+ #' covar1 = as.factor(enum), |
||
| 31 | +271 |
- #' @examples+ #' covar2 = factor( |
||
| 32 | +272 |
- #' library(dplyr)+ #' sample(as.factor(enum)), |
||
| 33 | +273 |
- #'+ #' levels = 1:4, labels = c("F", "F", "M", "M")
|
||
| 34 | +274 |
- #' df <- data.frame(+ #' ) |
||
| 35 | +275 |
- #' USUBJID = as.character(c(rep(1, 5), rep(2, 5), rep(1, 5), rep(2, 5))),+ #' ) |
||
| 36 | +276 |
- #' ARMCD = factor(c(rep("ARM A", 5), rep("ARM B", 5), rep("ARM A", 5), rep("ARM B", 5))),
+ #' ) |
||
| 37 | +277 |
- #' ANRIND = factor(c(+ #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
|
||
| 38 | +278 |
- #' "NORMAL", "HIGH", "HIGH", "HIGH HIGH", "HIGH",+ #' formatters::var_labels(dta_bladder)[names(labels)] <- labels |
||
| 39 | +279 |
- #' "HIGH", "HIGH", "HIGH HIGH", "NORMAL", "HIGH HIGH", "NORMAL", "LOW", "LOW", "LOW LOW", "LOW",+ #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
||
| 40 | +280 |
- #' "LOW", "LOW", "LOW LOW", "NORMAL", "LOW LOW"+ #' |
||
| 41 | +281 |
- #' )),+ #' plot( |
||
| 42 | +282 |
- #' ONTRTFL = rep(c("", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y"), 2),
+ #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder), |
||
| 43 | +283 |
- #' PARAMCD = factor(c(rep("CRP", 10), rep("ALT", 10))),
+ #' lty = 2:4, |
||
| 44 | +284 |
- #' AVALCAT1 = factor(rep(c("", "", "", "SINGLE", "REPLICATED", "", "", "LAST", "", "SINGLE"), 2)),
+ #' xlab = "Months", |
||
| 45 | +285 |
- #' stringsAsFactors = FALSE+ #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
|
||
| 46 | +286 |
#' ) |
||
| 47 | +287 |
#' |
||
| 48 | +288 |
- #' df <- df %>%+ #' @name fit_coxreg |
||
| 49 | +289 |
- #' mutate(abn_dir = factor(+ NULL |
||
| 50 | +290 |
- #' case_when(+ |
||
| 51 | +291 |
- #' ANRIND == "LOW LOW" ~ "Low",+ #' @describeIn fit_coxreg Fit a series of univariate Cox regression models given the inputs. |
||
| 52 | +292 |
- #' ANRIND == "HIGH HIGH" ~ "High",+ #' |
||
| 53 | +293 |
- #' TRUE ~ ""+ #' @return |
||
| 54 | +294 |
- #' ),+ #' * `fit_coxreg_univar()` returns a `coxreg.univar` class object which is a named `list` |
||
| 55 | +295 |
- #' levels = c("Low", "High")
+ #' with 5 elements: |
||
| 56 | +296 |
- #' ))+ #' * `mod`: Cox regression models fitted by [survival::coxph()]. |
||
| 57 | +297 |
- #'+ #' * `data`: The original data frame input. |
||
| 58 | +298 |
- #' # Select only post-baseline records.+ #' * `control`: The original control input. |
||
| 59 | +299 |
- #' df <- df %>% filter(ONTRTFL == "Y")+ #' * `vars`: The variables used in the model. |
||
| 60 | +300 |
- #' df_crp <- df %>%+ #' * `at`: Value of the covariate at which the effect should be estimated. |
||
| 61 | +301 |
- #' filter(PARAMCD == "CRP") %>%+ #' |
||
| 62 | +302 |
- #' droplevels()+ #' @note When using `fit_coxreg_univar` there should be two study arms. |
||
| 63 | +303 |
- #' full_parent_df <- list(df_crp, "not_needed")+ #' |
||
| 64 | +304 |
- #' cur_col_subset <- list(rep(TRUE, nrow(df_crp)), "not_needed")+ #' @examples |
||
| 65 | +305 |
- #' spl_context <- data.frame(+ #' # fit_coxreg_univar |
||
| 66 | +306 |
- #' split = c("PARAMCD", "GRADE_DIR"),
+ #' |
||
| 67 | +307 |
- #' full_parent_df = I(full_parent_df),+ #' ## Cox regression: arm + 1 covariate. |
||
| 68 | +308 |
- #' cur_col_subset = I(cur_col_subset)+ #' mod1 <- fit_coxreg_univar( |
||
| 69 | +309 |
- #' )+ #' variables = list( |
||
| 70 | +310 |
- #'+ #' time = "time", event = "status", arm = "armcd", |
||
| 71 | +311 |
- #' @keywords internal+ #' covariates = "covar1" |
||
| 72 | +312 |
- s_count_abnormal_by_marked <- function(df,+ #' ), |
||
| 73 | +313 |
- .var = "AVALCAT1",+ #' data = dta_bladder, |
||
| 74 | +314 |
- .spl_context,+ #' control = control_coxreg(conf_level = 0.91) |
||
| 75 | +315 |
- category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
+ #' ) |
||
| 76 | +316 |
- variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir")) {
- |
- ||
| 77 | -3x | -
- checkmate::assert_string(.var)- |
- ||
| 78 | -3x | -
- checkmate::assert_list(variables)- |
- ||
| 79 | -3x | -
- checkmate::assert_list(category)- |
- ||
| 80 | -3x | -
- checkmate::assert_subset(names(category), c("single", "last_replicated"))
- |
- ||
| 81 | -3x | -
- checkmate::assert_subset(names(variables), c("id", "param", "direction"))
- |
- ||
| 82 | -3x | -
- checkmate::assert_vector(unique(df[[variables$direction]]), max.len = 1)+ #' |
||
| 83 | +317 | - - | -||
| 84 | -2x | -
- assert_df_with_variables(df, c(aval = .var, variables))- |
- ||
| 85 | -2x | -
- checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
- |
- ||
| 86 | -2x | -
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ #' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates. |
||
| 87 | +318 |
-
+ #' mod2 <- fit_coxreg_univar( |
||
| 88 | +319 | - - | -||
| 89 | -2x | -
- first_row <- .spl_context[.spl_context$split == variables[["param"]], ]+ #' variables = list( |
||
| 90 | +320 |
- # Patients in the denominator have at least one post-baseline visit.- |
- ||
| 91 | -2x | -
- subj <- first_row$full_parent_df[[1]][[variables[["id"]]]]- |
- ||
| 92 | -2x | -
- subj_cur_col <- subj[first_row$cur_col_subset[[1]]]+ #' time = "time", event = "status", arm = "armcd", |
||
| 93 | +321 |
- # Some subjects may have a record for high and low directions but+ #' covariates = c("covar1", "covar2")
|
||
| 94 | +322 |
- # should be counted only once.- |
- ||
| 95 | -2x | -
- denom <- length(unique(subj_cur_col))+ #' ), |
||
| 96 | +323 | - - | -||
| 97 | -2x | -
- if (denom != 0) {
- |
- ||
| 98 | -2x | -
- subjects_last_replicated <- unique(- |
- ||
| 99 | -2x | -
- df[df[[.var]] %in% category[["last_replicated"]], variables$id, drop = TRUE]+ #' data = dta_bladder, |
||
| 100 | +324 |
- )- |
- ||
| 101 | -2x | -
- subjects_single <- unique(- |
- ||
| 102 | -2x | -
- df[df[[.var]] %in% category[["single"]], variables$id, drop = TRUE]+ #' control = control_coxreg(conf_level = 0.91, interaction = TRUE) |
||
| 103 | +325 |
- )+ #' ) |
||
| 104 | +326 |
- # Subjects who have both single and last/replicated abnormalities are counted in only the last/replicated group.- |
- ||
| 105 | -2x | -
- subjects_single <- setdiff(subjects_single, subjects_last_replicated)- |
- ||
| 106 | -2x | -
- n_single <- length(subjects_single)- |
- ||
| 107 | -2x | -
- n_last_replicated <- length(subjects_last_replicated)- |
- ||
| 108 | -2x | -
- n_any <- n_single + n_last_replicated- |
- ||
| 109 | -2x | -
- result <- list(count_fraction = list(- |
- ||
| 110 | -2x | -
- "Single, not last" = c(n_single, n_single / denom),- |
- ||
| 111 | -2x | -
- "Last or replicated" = c(n_last_replicated, n_last_replicated / denom),- |
- ||
| 112 | -2x | -
- "Any Abnormality" = c(n_any, n_any / denom)+ #' |
||
| 113 | +327 |
- ))+ #' ## Cox regression: arm + 1 covariate, stratified analysis. |
||
| 114 | +328 |
- } else {
- |
- ||
| 115 | -! | -
- result <- list(count_fraction = list(- |
- ||
| 116 | -! | -
- "Single, not last" = c(0, 0),- |
- ||
| 117 | -! | -
- "Last or replicated" = c(0, 0),- |
- ||
| 118 | -! | -
- "Any Abnormality" = c(0, 0)+ #' mod3 <- fit_coxreg_univar( |
||
| 119 | +329 |
- ))+ #' variables = list( |
||
| 120 | +330 |
- }+ #' time = "time", event = "status", arm = "armcd", strata = "covar2", |
||
| 121 | +331 | - - | -||
| 122 | -2x | -
- result+ #' covariates = c("covar1")
|
||
| 123 | +332 |
- }+ #' ), |
||
| 124 | +333 |
-
+ #' data = dta_bladder, |
||
| 125 | +334 |
- #' @describeIn abnormal_by_marked Formatted analysis function which is used as `afun`+ #' control = control_coxreg(conf_level = 0.91) |
||
| 126 | +335 |
- #' in `count_abnormal_by_marked()`.+ #' ) |
||
| 127 | +336 |
#' |
||
| 128 | -- |
- #' @return- |
- ||
| 129 | -- |
- #' * `a_count_abnormal_by_marked()` returns the corresponding list with formatted [rtables::CellValue()].- |
- ||
| 130 | +337 |
- #'+ #' ## Cox regression: no arm, only covariates. |
||
| 131 | +338 |
- #'+ #' mod4 <- fit_coxreg_univar( |
||
| 132 | +339 |
- #' @keywords internal+ #' variables = list( |
||
| 133 | +340 |
- a_count_abnormal_by_marked <- make_afun(+ #' time = "time", event = "status", |
||
| 134 | +341 |
- s_count_abnormal_by_marked,+ #' covariates = c("covar1", "covar2")
|
||
| 135 | +342 |
- .formats = c(count_fraction = format_count_fraction)+ #' ), |
||
| 136 | +343 |
- )+ #' data = dta_bladder |
||
| 137 | +344 |
-
+ #' ) |
||
| 138 | +345 |
- #' @describeIn abnormal_by_marked Layout-creating function which can take statistics function arguments+ #' |
||
| 139 | +346 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' @export |
||
| 140 | +347 |
- #'+ fit_coxreg_univar <- function(variables, |
||
| 141 | +348 |
- #' @return+ data, |
||
| 142 | +349 |
- #' * `count_abnormal_by_marked()` returns a layout object suitable for passing to further layouting functions,+ at = list(), |
||
| 143 | +350 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ control = control_coxreg()) {
|
||
| 144 | -+ | |||
| 351 | +34x |
- #' the statistics from `s_count_abnormal_by_marked()` to the table layout.+ checkmate::assert_list(variables, names = "named") |
||
| 145 | -+ | |||
| 352 | +34x |
- #'+ has_arm <- "arm" %in% names(variables) |
||
| 146 | -+ | |||
| 353 | +34x |
- #' @examples+ arm_name <- if (has_arm) "arm" else NULL |
||
| 147 | +354 |
- #' map <- unique(+ |
||
| 148 | -+ | |||
| 355 | +34x |
- #' df[df$abn_dir %in% c("Low", "High") & df$AVALCAT1 != "", c("PARAMCD", "abn_dir")]
+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
||
| 149 | +356 |
- #' ) %>%+ |
||
| 150 | -+ | |||
| 357 | +34x |
- #' lapply(as.character) %>%+ assert_df_with_variables(data, variables) |
||
| 151 | -+ | |||
| 358 | +34x |
- #' as.data.frame() %>%+ assert_list_of_variables(variables[c(arm_name, "event", "time")]) |
||
| 152 | +359 |
- #' arrange(PARAMCD, abn_dir)+ |
||
| 153 | -+ | |||
| 360 | +34x |
- #'+ if (!is.null(variables$strata)) {
|
||
| 154 | -+ | |||
| 361 | +4x |
- #' basic_table() %>%+ checkmate::assert_disjunct(control$pval_method, "likelihood") |
||
| 155 | +362 |
- #' split_cols_by("ARMCD") %>%
+ } |
||
| 156 | -+ | |||
| 363 | +33x |
- #' split_rows_by("PARAMCD") %>%
+ if (has_arm) {
|
||
| 157 | -+ | |||
| 364 | +27x |
- #' summarize_num_patients(+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2) |
||
| 158 | +365 |
- #' var = "USUBJID",+ } |
||
| 159 | -+ | |||
| 366 | +32x |
- #' .stats = "unique_count"+ vars <- unlist(variables[c(arm_name, "covariates", "strata")], use.names = FALSE) |
||
| 160 | -+ | |||
| 367 | +32x |
- #' ) %>%+ for (i in vars) {
|
||
| 161 | -+ | |||
| 368 | +73x |
- #' split_rows_by(+ if (is.factor(data[[i]])) {
|
||
| 162 | -+ | |||
| 369 | +63x |
- #' "abn_dir",+ attr(data[[i]], "levels") <- levels(droplevels(data[[i]])) |
||
| 163 | +370 |
- #' split_fun = trim_levels_to_map(map)+ } |
||
| 164 | +371 |
- #' ) %>%+ } |
||
| 165 | -+ | |||
| 372 | +32x |
- #' count_abnormal_by_marked(+ forms <- h_coxreg_univar_formulas(variables, interaction = control$interaction) |
||
| 166 | -+ | |||
| 373 | +32x |
- #' var = "AVALCAT1",+ mod <- lapply( |
||
| 167 | -+ | |||
| 374 | +32x |
- #' variables = list(+ forms, function(x) {
|
||
| 168 | -+ | |||
| 375 | +69x |
- #' id = "USUBJID",+ survival::coxph(formula = stats::as.formula(x), data = data, ties = control$ties) |
||
| 169 | +376 |
- #' param = "PARAMCD",+ } |
||
| 170 | +377 |
- #' direction = "abn_dir"+ ) |
||
| 171 | -+ | |||
| 378 | +32x |
- #' )+ structure( |
||
| 172 | -+ | |||
| 379 | +32x |
- #' ) %>%+ list( |
||
| 173 | -+ | |||
| 380 | +32x |
- #' build_table(df = df)+ mod = mod, |
||
| 174 | -+ | |||
| 381 | +32x |
- #'+ data = data, |
||
| 175 | -+ | |||
| 382 | +32x |
- #' basic_table() %>%+ control = control, |
||
| 176 | -+ | |||
| 383 | +32x |
- #' split_cols_by("ARMCD") %>%
+ vars = variables, |
||
| 177 | -+ | |||
| 384 | +32x |
- #' split_rows_by("PARAMCD") %>%
+ at = at |
||
| 178 | +385 |
- #' summarize_num_patients(+ ), |
||
| 179 | -+ | |||
| 386 | +32x |
- #' var = "USUBJID",+ class = "coxreg.univar" |
||
| 180 | +387 |
- #' .stats = "unique_count"+ ) |
||
| 181 | +388 |
- #' ) %>%+ } |
||
| 182 | +389 |
- #' split_rows_by(+ |
||
| 183 | +390 |
- #' "abn_dir",+ #' @describeIn fit_coxreg Fit a multivariate Cox regression model. |
||
| 184 | +391 |
- #' split_fun = trim_levels_in_group("abn_dir")
+ #' |
||
| 185 | +392 |
- #' ) %>%+ #' @return |
||
| 186 | +393 |
- #' count_abnormal_by_marked(+ #' * `fit_coxreg_multivar()` returns a `coxreg.multivar` class object which is a named list |
||
| 187 | +394 |
- #' var = "AVALCAT1",+ #' with 4 elements: |
||
| 188 | +395 |
- #' variables = list(+ #' * `mod`: Cox regression model fitted by [survival::coxph()]. |
||
| 189 | +396 |
- #' id = "USUBJID",+ #' * `data`: The original data frame input. |
||
| 190 | +397 |
- #' param = "PARAMCD",+ #' * `control`: The original control input. |
||
| 191 | +398 |
- #' direction = "abn_dir"+ #' * `vars`: The variables used in the model. |
||
| 192 | +399 |
- #' )+ #' |
||
| 193 | +400 |
- #' ) %>%+ #' @examples |
||
| 194 | +401 |
- #' build_table(df = df)+ #' # fit_coxreg_multivar |
||
| 195 | +402 |
#' |
||
| 196 | +403 |
- #' @export+ #' ## Cox regression: multivariate Cox regression. |
||
| 197 | +404 |
- count_abnormal_by_marked <- function(lyt,+ #' multivar_model <- fit_coxreg_multivar( |
||
| 198 | +405 |
- var,+ #' variables = list( |
||
| 199 | +406 |
- nested = TRUE,+ #' time = "time", event = "status", arm = "armcd", |
||
| 200 | +407 |
- ...,+ #' covariates = c("covar1", "covar2")
|
||
| 201 | +408 |
- .stats = NULL,+ #' ), |
||
| 202 | +409 |
- .formats = NULL,+ #' data = dta_bladder |
||
| 203 | +410 |
- .labels = NULL,+ #' ) |
||
| 204 | +411 |
- .indent_mods = NULL) {
+ #' |
||
| 205 | -1x | +|||
| 412 | +
- checkmate::assert_string(var)+ #' # Example without treatment arm. |
|||
| 206 | +413 |
-
+ #' multivar_covs_model <- fit_coxreg_multivar( |
||
| 207 | -1x | +|||
| 414 | +
- afun <- make_afun(+ #' variables = list( |
|||
| 208 | -1x | +|||
| 415 | +
- a_count_abnormal_by_marked,+ #' time = "time", event = "status", |
|||
| 209 | -1x | +|||
| 416 | +
- .stats = .stats,+ #' covariates = c("covar1", "covar2")
|
|||
| 210 | -1x | +|||
| 417 | +
- .formats = .formats,+ #' ), |
|||
| 211 | -1x | +|||
| 418 | +
- .labels = .labels,+ #' data = dta_bladder |
|||
| 212 | -1x | +|||
| 419 | +
- .indent_mods = .indent_mods,+ #' ) |
|||
| 213 | -1x | +|||
| 420 | +
- .ungroup_stats = "count_fraction"+ #' |
|||
| 214 | +421 |
- )+ #' @export |
||
| 215 | +422 |
-
+ fit_coxreg_multivar <- function(variables, |
||
| 216 | -1x | +|||
| 423 | +
- lyt <- analyze(+ data, |
|||
| 217 | -1x | +|||
| 424 | +
- lyt = lyt,+ control = control_coxreg()) {
|
|||
| 218 | -1x | +425 | +51x |
- vars = var,+ checkmate::assert_list(variables, names = "named") |
| 219 | -1x | +426 | +51x |
- afun = afun,+ has_arm <- "arm" %in% names(variables) |
| 220 | -1x | +427 | +51x |
- nested = nested,+ arm_name <- if (has_arm) "arm" else NULL |
| 221 | -1x | +|||
| 428 | +
- show_labels = "hidden",+ |
|||
| 222 | -1x | -
- extra_args = c(list(...))- |
- ||
| 223 | -+ | 429 | +51x |
- )+ if (!is.null(variables$covariates)) {
|
| 224 | -1x | +430 | +13x |
- lyt+ checkmate::assert_character(variables$covariates) |
| 225 | +431 |
- }+ } |
| 1 | +432 |
- #' Cox Proportional Hazards Regression+ |
|
| 2 | -+ | ||
| 433 | +51x |
- #'+ checkmate::assert_false(control$interaction) |
|
| 3 | -+ | ||
| 434 | +51x |
- #' @description `r lifecycle::badge("stable")`
+ assert_df_with_variables(data, variables) |
|
| 4 | -+ | ||
| 435 | +51x |
- #'+ assert_list_of_variables(variables[c(arm_name, "event", "time")]) |
|
| 5 | +436 |
- #' Fits a Cox regression model and estimates hazard ratio to describe the effect size in a survival analysis.+ |
|
| 6 | -+ | ||
| 437 | +51x |
- #'+ if (!is.null(variables$strata)) {
|
|
| 7 | -+ | ||
| 438 | +3x |
- #' @inheritParams argument_convention+ checkmate::assert_disjunct(control$pval_method, "likelihood") |
|
| 8 | +439 |
- #'+ } |
|
| 9 | +440 |
- #' @details Cox models are the most commonly used methods to estimate the magnitude of+ |
|
| 10 | -+ | ||
| 441 | +50x |
- #' the effect in survival analysis. It assumes proportional hazards: the ratio+ form <- h_coxreg_multivar_formula(variables) |
|
| 11 | -+ | ||
| 442 | +50x |
- #' of the hazards between groups (e.g., two arms) is constant over time.+ mod <- survival::coxph( |
|
| 12 | -+ | ||
| 443 | +50x |
- #' This ratio is referred to as the "hazard ratio" (HR) and is one of the+ formula = stats::as.formula(form), |
|
| 13 | -+ | ||
| 444 | +50x |
- #' most commonly reported metrics to describe the effect size in survival+ data = data, |
|
| 14 | -+ | ||
| 445 | +50x |
- #' analysis (NEST Team, 2020).+ ties = control$ties |
|
| 15 | +446 |
- #'+ ) |
|
| 16 | -+ | ||
| 447 | +50x |
- #' @seealso [fit_coxreg] for relevant fitting functions, [h_cox_regression] for relevant+ structure( |
|
| 17 | -+ | ||
| 448 | +50x |
- #' helper functions, and [tidy_coxreg] for custom tidy methods.+ list( |
|
| 18 | -+ | ||
| 449 | +50x |
- #'+ mod = mod, |
|
| 19 | -+ | ||
| 450 | +50x |
- #' @examples+ data = data, |
|
| 20 | -+ | ||
| 451 | +50x |
- #' library(survival)+ control = control, |
|
| 21 | -+ | ||
| 452 | +50x |
- #'+ vars = variables |
|
| 22 | +453 |
- #' # Testing dataset [survival::bladder].+ ), |
|
| 23 | -+ | ||
| 454 | +50x |
- #' set.seed(1, kind = "Mersenne-Twister")+ class = "coxreg.multivar" |
|
| 24 | +455 |
- #' dta_bladder <- with(+ ) |
|
| 25 | +456 |
- #' data = bladder[bladder$enum < 5, ],+ } |
|
| 26 | +457 |
- #' tibble::tibble(+ |
|
| 27 | +458 |
- #' TIME = stop,+ #' Muffled `car::Anova` |
|
| 28 | +459 |
- #' STATUS = event,+ #' |
|
| 29 | +460 |
- #' ARM = as.factor(rx),+ #' Applied on survival models, [car::Anova()] signal that the `strata` terms is dropped from the model formula when |
|
| 30 | +461 |
- #' COVAR1 = as.factor(enum) %>% formatters::with_label("A Covariate Label"),
+ #' present, this function deliberately muffles this message. |
|
| 31 | +462 |
- #' COVAR2 = factor(+ #' |
|
| 32 | +463 |
- #' sample(as.factor(enum)),+ #' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()]. |
|
| 33 | +464 |
- #' levels = 1:4, labels = c("F", "F", "M", "M")
+ #' @param test_statistic (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`. |
|
| 34 | +465 |
- #' ) %>% formatters::with_label("Sex (F/M)")
+ #' |
|
| 35 | +466 |
- #' )+ #' @return Returns the output of [car::Anova()], with convergence message muffled. |
|
| 36 | +467 |
- #' )+ #' |
|
| 37 | +468 |
- #' dta_bladder$AGE <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ #' @keywords internal |
|
| 38 | +469 |
- #' dta_bladder$STUDYID <- factor("X")
+ muffled_car_anova <- function(mod, test_statistic) {
|
|
| 39 | -+ | ||
| 470 | +142x |
- #'+ tryCatch( |
|
| 40 | -+ | ||
| 471 | +142x |
- #' plot(+ withCallingHandlers( |
|
| 41 | -+ | ||
| 472 | +142x |
- #' survfit(Surv(TIME, STATUS) ~ ARM + COVAR1, data = dta_bladder),+ expr = {
|
|
| 42 | -+ | ||
| 473 | +142x |
- #' lty = 2:4,+ car::Anova( |
|
| 43 | -+ | ||
| 474 | +142x |
- #' xlab = "Months",+ mod, |
|
| 44 | -+ | ||
| 475 | +142x |
- #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
+ test.statistic = test_statistic, |
|
| 45 | -+ | ||
| 476 | +142x |
- #' )+ type = "III" |
|
| 46 | +477 |
- #'+ ) |
|
| 47 | +478 |
- #' @name cox_regression+ }, |
|
| 48 | -+ | ||
| 479 | +142x |
- NULL+ message = function(m) invokeRestart("muffleMessage"),
|
|
| 49 | -+ | ||
| 480 | +142x |
-
+ error = function(e) {
|
|
| 50 | -+ | ||
| 481 | +1x |
- #' @describeIn cox_regression Statistics function that transforms results tabulated+ stop(paste( |
|
| 51 | -+ | ||
| 482 | +1x |
- #' from [fit_coxreg_univar()] or [fit_coxreg_multivar()] into a list.+ "the model seems to have convergence problems, please try to change", |
|
| 52 | -+ | ||
| 483 | +1x |
- #'+ "the configuration of covariates or strata variables, e.g.", |
|
| 53 | -+ | ||
| 484 | +1x |
- #' @param model_df (`data.frame`)\cr contains the resulting model fit from a [fit_coxreg]+ "- original error:", e |
|
| 54 | +485 |
- #' function with tidying applied via [broom::tidy()].+ )) |
|
| 55 | +486 |
- #' @param .stats (`character`)\cr the name of statistics to be reported among:+ } |
|
| 56 | +487 |
- #' * `n`: number of observations (univariate only)+ ) |
|
| 57 | +488 |
- #' * `hr`: hazard ratio+ ) |
|
| 58 | +489 |
- #' * `ci`: confidence interval+ } |
| 59 | +1 |
- #' * `pval`: p-value of the treatment effect+ #' Patient Counts with Abnormal Range Values |
||
| 60 | +2 |
- #' * `pval_inter`: p-value of the interaction effect between the treatment and the covariate (univariate only)+ #' |
||
| 61 | +3 |
- #' @param .which_vars (`character`)\cr which rows should statistics be returned for from the given model.+ #' @description `r lifecycle::badge("stable")`
|
||
| 62 | +4 |
- #' Defaults to "all". Other options include "var_main" for main effects, `"inter"` for interaction effects,+ #' |
||
| 63 | +5 |
- #' and `"multi_lvl"` for multivariate model covariate level rows. When `.which_vars` is "all" specific+ #' Primary analysis variable `.var` indicates the abnormal range result (`character` or `factor`) |
||
| 64 | +6 |
- #' variables can be selected by specifying `.var_nms`.+ #' and additional analysis variables are `id` (`character` or `factor`) and `baseline` (`character` or |
||
| 65 | +7 |
- #' @param .var_nms (`character`)\cr the `term` value of rows in `df` for which `.stats` should be returned. Typically+ #' `factor`). For each direction specified in `abnormal` (e.g. high or low) count patients in the |
||
| 66 | +8 |
- #' this is the name of a variable. If using variable labels, `var` should be a vector of both the desired+ #' numerator and denominator as follows: |
||
| 67 | +9 |
- #' variable name and the variable label in that order to see all `.stats` related to that variable. When `.which_vars`+ #' * `num` : The number of patients with this abnormality recorded while on treatment. |
||
| 68 | +10 |
- #' is `"var_main"` `.var_nms` should be only the variable name.+ #' * `denom`: The number of patients with at least one post-baseline assessment. |
||
| 69 | +11 |
#' |
||
| 70 | +12 |
- #' @return+ #' @inheritParams argument_convention |
||
| 71 | +13 |
- #' * `s_coxreg()` returns the selected statistic for from the Cox regression model for the selected variable(s).+ #' @param abnormal (named `list`)\cr list identifying the abnormal range level(s) in `var`. Defaults to |
||
| 72 | +14 |
- #'+ #' `list(Low = "LOW", High = "HIGH")` but you can also group different levels into the named list, |
||
| 73 | +15 |
- #' @examples+ #' for example, `abnormal = list(Low = c("LOW", "LOW LOW"), High = c("HIGH", "HIGH HIGH"))`.
|
||
| 74 | +16 |
- #' # s_coxreg+ #' |
||
| 75 | +17 |
- #'+ #' @note |
||
| 76 | +18 |
- #' # Univariate+ #' * `count_abnormal()` only works with a single variable containing multiple abnormal levels. |
||
| 77 | +19 |
- #' u1_variables <- list(+ #' * `df` should be filtered to include only post-baseline records. |
||
| 78 | +20 |
- #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
+ #' * the denominator includes patients that might have other abnormal levels at baseline, |
||
| 79 | +21 |
- #' )+ #' and patients with missing baseline. Patients with these abnormalities at |
||
| 80 | +22 |
- #' univar_model <- fit_coxreg_univar(variables = u1_variables, data = dta_bladder)+ #' baseline can be optionally excluded from numerator and denominator. |
||
| 81 | +23 |
- #' df1 <- broom::tidy(univar_model)+ #' |
||
| 82 | +24 |
- #' s_coxreg(model_df = df1, .stats = "hr")+ #' @name abnormal |
||
| 83 | +25 |
- #'+ #' @include formatting_functions.R |
||
| 84 | +26 |
- #' # Univariate with interactions+ NULL |
||
| 85 | +27 |
- #' univar_model_inter <- fit_coxreg_univar(+ |
||
| 86 | +28 |
- #' variables = u1_variables, control = control_coxreg(interaction = TRUE), data = dta_bladder+ #' @describeIn abnormal Statistics function which counts patients with abnormal range values |
||
| 87 | +29 |
- #' )+ #' for a single `abnormal` level. |
||
| 88 | +30 |
- #' df1_inter <- broom::tidy(univar_model_inter)+ #' |
||
| 89 | +31 |
- #' s_coxreg(model_df = df1_inter, .stats = "hr", .which_vars = "inter", .var_nms = "COVAR1")+ #' @param exclude_base_abn (`flag`)\cr whether to exclude subjects with baseline abnormality |
||
| 90 | +32 |
- #'+ #' from numerator and denominator. |
||
| 91 | +33 |
- #' # Univariate without treatment arm - only "COVAR2" covariate effects+ #' |
||
| 92 | +34 |
- #' u2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
+ #' @return |
||
| 93 | +35 |
- #' univar_covs_model <- fit_coxreg_univar(variables = u2_variables, data = dta_bladder)+ #' * `s_count_abnormal()` returns the statistic `fraction` which is a vector with `num` and `denom` counts of patients. |
||
| 94 | +36 |
- #' df1_covs <- broom::tidy(univar_covs_model)+ #' @examples |
||
| 95 | +37 |
- #' s_coxreg(model_df = df1_covs, .stats = "hr", .var_nms = c("COVAR2", "Sex (F/M)"))
+ #' library(dplyr) |
||
| 96 | +38 |
#' |
||
| 97 | +39 |
- #' # Multivariate.+ #' df <- data.frame( |
||
| 98 | +40 |
- #' m1_variables <- list(+ #' USUBJID = as.character(c(1, 1, 2, 2)), |
||
| 99 | +41 |
- #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
+ #' ANRIND = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
|
||
| 100 | +42 |
- #' )+ #' BNRIND = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
|
||
| 101 | +43 |
- #' multivar_model <- fit_coxreg_multivar(variables = m1_variables, data = dta_bladder)+ #' ONTRTFL = c("", "Y", "", "Y"),
|
||
| 102 | +44 |
- #' df2 <- broom::tidy(multivar_model)+ #' stringsAsFactors = FALSE |
||
| 103 | +45 |
- #' s_coxreg(model_df = df2, .stats = "pval", .which_vars = "var_main", .var_nms = "COVAR1")+ #' ) |
||
| 104 | +46 |
- #' s_coxreg(+ #' |
||
| 105 | +47 |
- #' model_df = df2, .stats = "pval", .which_vars = "multi_lvl",+ #' # Select only post-baseline records. |
||
| 106 | +48 |
- #' .var_nms = c("COVAR1", "A Covariate Label")
+ #' df <- df %>% |
||
| 107 | +49 |
- #' )+ #' filter(ONTRTFL == "Y") |
||
| 108 | +50 |
- #'+ #' @keywords internal |
||
| 109 | +51 |
- #' # Multivariate without treatment arm - only "COVAR1" main effect+ s_count_abnormal <- function(df, |
||
| 110 | +52 |
- #' m2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
+ .var, |
||
| 111 | +53 |
- #' multivar_covs_model <- fit_coxreg_multivar(variables = m2_variables, data = dta_bladder)+ abnormal = list(Low = "LOW", High = "HIGH"), |
||
| 112 | +54 |
- #' df2_covs <- broom::tidy(multivar_covs_model)+ variables = list(id = "USUBJID", baseline = "BNRIND"), |
||
| 113 | +55 |
- #' s_coxreg(model_df = df2_covs, .stats = "hr")+ exclude_base_abn = FALSE) {
|
||
| 114 | -+ | |||
| 56 | +4x |
- #'+ checkmate::assert_list(abnormal, types = "character", names = "named", len = 2, any.missing = FALSE) |
||
| 115 | -+ | |||
| 57 | +4x |
- #' @export+ checkmate::assert_true(any(unlist(abnormal) %in% levels(df[[.var]]))) |
||
| 116 | -+ | |||
| 58 | +4x |
- s_coxreg <- function(model_df, .stats, .which_vars = "all", .var_nms = NULL) {
+ checkmate::assert_factor(df[[.var]]) |
||
| 117 | -194x | +59 | +4x |
- assert_df_with_variables(model_df, list(term = "term", stat = .stats))+ checkmate::assert_flag(exclude_base_abn) |
| 118 | -194x | +60 | +4x |
- checkmate::assert_multi_class(model_df$term, classes = c("factor", "character"))
+ assert_df_with_variables(df, c(range = .var, variables)) |
| 119 | -194x | +61 | +4x |
- model_df$term <- as.character(model_df$term)+ checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
|
| 120 | -194x | +62 | +4x |
- .var_nms <- .var_nms[!is.na(.var_nms)]+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
| 121 | +63 | |||
| 122 | -192x | +64 | +4x |
- if (length(.var_nms) > 0) model_df <- model_df[model_df$term %in% .var_nms, ]+ count_abnormal_single <- function(abn_name, abn) {
|
| 123 | -39x | +|||
| 65 | +
- if (.which_vars == "multi_lvl") model_df$term <- tail(.var_nms, 1)+ # Patients in the denominator fulfill: |
|||
| 124 | +66 |
-
+ # - have at least one post-baseline visit |
||
| 125 | +67 |
- # We need a list with names corresponding to the stats to display of equal length to the list of stats.+ # - their baseline must not be abnormal if `exclude_base_abn`. |
||
| 126 | -194x | +68 | +8x |
- y <- split(model_df, f = model_df$term, drop = FALSE)+ if (exclude_base_abn) {
|
| 127 | -194x | +69 | +4x |
- y <- stats::setNames(y, nm = rep(.stats, length(y)))+ denom_select <- !(df[[variables$baseline]] %in% abn) |
| 128 | +70 | - - | -||
| 129 | -194x | -
- if (.which_vars == "var_main") {
+ } else {
|
||
| 130 | -84x | +71 | +4x |
- y <- lapply(y, function(x) x[1, ]) # only main effect+ denom_select <- TRUE |
| 131 | -110x | +|||
| 72 | +
- } else if (.which_vars %in% c("inter", "multi_lvl")) {
+ } |
|||
| 132 | -80x | +73 | +8x |
- y <- lapply(y, function(x) if (nrow(y[[1]]) > 1) x[-1, ] else x) # exclude main effect+ denom <- length(unique(df[denom_select, variables$id, drop = TRUE])) |
| 133 | +74 |
- }+ |
||
| 134 | +75 | - - | -||
| 135 | -194x | -
- lapply(+ # Patients in the numerator fulfill: |
||
| 136 | -194x | +|||
| 76 | +
- X = y,+ # - have at least one post-baseline visit with the required abnormality level |
|||
| 137 | -194x | +|||
| 77 | +
- FUN = function(x) {
+ # - are part of the denominator patients. |
|||
| 138 | -198x | +78 | +8x |
- z <- as.list(x[[.stats]])+ num_select <- (df[[.var]] %in% abn) & denom_select |
| 139 | -198x | +79 | +8x |
- stats::setNames(z, nm = x$term_label)+ num <- length(unique(df[num_select, variables$id, drop = TRUE])) |
| 140 | +80 |
- }+ |
||
| 141 | -+ | |||
| 81 | +8x |
- )+ formatters::with_label(c(num = num, denom = denom), abn_name) |
||
| 142 | +82 |
- }+ } |
||
| 143 | +83 | |||
| 144 | -- |
- #' @describeIn cox_regression Analysis function which is used as `afun` in [rtables::analyze()]- |
- ||
| 145 | +84 |
- #' and `cfun` in [rtables::summarize_row_groups()] within `summarize_coxreg()`.+ # This will define the abnormal levels theoretically possible for a specific lab parameter |
||
| 146 | +85 |
- #'+ # within a split level of a layout. |
||
| 147 | -+ | |||
| 86 | +4x |
- #' @param eff (`flag`)\cr whether treatment effect should be calculated. Defaults to `FALSE`.+ abnormal_lev <- lapply(abnormal, intersect, levels(df[[.var]])) |
||
| 148 | -+ | |||
| 87 | +4x |
- #' @param var_main (`flag`)\cr whether main effects should be calculated. Defaults to `FALSE`.+ abnormal_lev <- abnormal_lev[vapply(abnormal_lev, function(x) length(x) > 0, logical(1))] |
||
| 149 | +88 |
- #' @param na_level (`string`)\cr custom string to replace all `NA` values with. Defaults to `""`.+ |
||
| 150 | -+ | |||
| 89 | +4x |
- #' @param cache_env (`environment`)\cr an environment object used to cache the regression model in order to+ result <- sapply(names(abnormal_lev), function(i) count_abnormal_single(i, abnormal_lev[[i]]), simplify = FALSE) |
||
| 151 | -+ | |||
| 90 | +4x |
- #' avoid repeatedly fitting the same model for every row in the table. Defaults to `NULL` (no caching).+ result <- list(fraction = result) |
||
| 152 | -+ | |||
| 91 | +4x |
- #' @param varlabels (`list`)\cr a named list corresponds to the names of variables found in data, passed+ result |
||
| 153 | +92 |
- #' as a named list and corresponding to time, event, arm, strata, and covariates terms. If arm is missing+ } |
||
| 154 | +93 |
- #' from variables, then only Cox model(s) including the covariates will be fitted and the corresponding+ |
||
| 155 | +94 |
- #' effect estimates will be tabulated later.+ #' @describeIn abnormal Formatted analysis function which is used as `afun` in `count_abnormal()`. |
||
| 156 | +95 |
#' |
||
| 157 | +96 |
#' @return |
||
| 158 | +97 |
- #' * `a_coxreg()` returns formatted [rtables::CellValue()].+ #' * `a_count_abnormal()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 159 | +98 |
#' |
||
| 160 | +99 |
- #' @examples+ #' @keywords internal |
||
| 161 | +100 |
- #' a_coxreg(+ a_count_abnormal <- make_afun( |
||
| 162 | +101 |
- #' df = dta_bladder,+ s_count_abnormal, |
||
| 163 | +102 |
- #' labelstr = "Label 1",+ .formats = c(fraction = format_fraction) |
||
| 164 | +103 |
- #' variables = u1_variables,+ ) |
||
| 165 | +104 |
- #' .spl_context = list(value = "COVAR1"),+ |
||
| 166 | +105 |
- #' .stats = "n",+ #' @describeIn abnormal Layout-creating function which can take statistics function arguments |
||
| 167 | +106 |
- #' .formats = "xx"+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 168 | +107 |
- #' )+ #' |
||
| 169 | +108 |
- #'+ #' @return |
||
| 170 | +109 |
- #' a_coxreg(+ #' * `count_abnormal()` returns a layout object suitable for passing to further layouting functions, |
||
| 171 | +110 |
- #' df = dta_bladder,+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 172 | +111 |
- #' labelstr = "",+ #' the statistics from `s_count_abnormal()` to the table layout. |
||
| 173 | +112 |
- #' variables = u1_variables,+ #' |
||
| 174 | +113 |
- #' .spl_context = list(value = "COVAR2"),+ #' @examples |
||
| 175 | +114 |
- #' .stats = "pval",+ #' # Layout creating function. |
||
| 176 | +115 |
- #' .formats = "xx.xxxx"+ #' basic_table() %>% |
||
| 177 | +116 |
- #' )+ #' count_abnormal(var = "ANRIND", abnormal = list(high = "HIGH", low = "LOW")) %>% |
||
| 178 | +117 |
- #'+ #' build_table(df) |
||
| 179 | +118 |
- #' @export+ #' |
||
| 180 | +119 |
- a_coxreg <- function(df,+ #' # Passing of statistics function and formatting arguments. |
||
| 181 | +120 |
- labelstr,+ #' df2 <- data.frame( |
||
| 182 | +121 |
- eff = FALSE,+ #' ID = as.character(c(1, 1, 2, 2)), |
||
| 183 | +122 |
- var_main = FALSE,+ #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
|
||
| 184 | +123 |
- multivar = FALSE,+ #' BL_RANGE = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
|
||
| 185 | +124 |
- variables,+ #' ONTRTFL = c("", "Y", "", "Y"),
|
||
| 186 | +125 |
- at = list(),+ #' stringsAsFactors = FALSE |
||
| 187 | +126 |
- control = control_coxreg(),+ #' ) |
||
| 188 | +127 |
- .spl_context,+ #' |
||
| 189 | +128 |
- .stats,+ #' # Select only post-baseline records. |
||
| 190 | +129 |
- .formats,+ #' df2 <- df2 %>% |
||
| 191 | +130 |
- .indent_mods = NULL,+ #' filter(ONTRTFL == "Y") |
||
| 192 | +131 |
- na_level = "",+ #' |
||
| 193 | +132 |
- cache_env = NULL) {
- |
- ||
| 194 | -191x | -
- cov_no_arm <- !multivar && !"arm" %in% names(variables) && control$interaction # special case: univar no arm- |
- ||
| 195 | -191x | -
- cov <- tail(.spl_context$value, 1) # current variable/covariate- |
- ||
| 196 | -191x | -
- var_lbl <- formatters::var_labels(df)[cov] # check for df labels- |
- ||
| 197 | -191x | -
- if (length(labelstr) > 1) {
- |
- ||
| 198 | -! | -
- labelstr <- if (cov %in% names(labelstr)) labelstr[[cov]] else var_lbl # use df labels if none- |
- ||
| 199 | -191x | -
- } else if (!is.na(var_lbl) && labelstr == cov && cov %in% variables$covariates) {
- |
- ||
| 200 | -62x | -
- labelstr <- var_lbl+ #' basic_table() %>% |
||
| 201 | +133 |
- }- |
- ||
| 202 | -191x | -
- if (eff || multivar || cov_no_arm) {
- |
- ||
| 203 | -82x | -
- control$interaction <- FALSE+ #' count_abnormal( |
||
| 204 | +134 |
- } else {
- |
- ||
| 205 | -109x | -
- variables$covariates <- cov- |
- ||
| 206 | -40x | -
- if (var_main) control$interaction <- TRUE+ #' var = "RANGE", |
||
| 207 | +135 |
- }+ #' abnormal = list(low = "LOW", high = "HIGH"), |
||
| 208 | +136 | - - | -||
| 209 | -191x | -
- if (is.null(cache_env[[cov]])) {
- |
- ||
| 210 | -30x | -
- if (!multivar) {
- |
- ||
| 211 | -23x | -
- model <- fit_coxreg_univar(variables = variables, data = df, at = at, control = control) %>% broom::tidy()+ #' variables = list(id = "ID", baseline = "BL_RANGE") |
||
| 212 | +137 |
- } else {
+ #' ) %>% |
||
| 213 | -7x | +|||
| 138 | +
- model <- fit_coxreg_multivar(variables = variables, data = df, control = control) %>% broom::tidy()+ #' build_table(df2) |
|||
| 214 | +139 |
- }+ #' |
||
| 215 | -30x | +|||
| 140 | +
- cache_env[[cov]] <- model+ #' @export |
|||
| 216 | +141 |
- } else {
+ count_abnormal <- function(lyt, |
||
| 217 | -161x | +|||
| 142 | +
- model <- cache_env[[cov]]+ var, |
|||
| 218 | +143 |
- }+ na_str = NA_character_, |
||
| 219 | -109x | +|||
| 144 | +
- if (!multivar && !var_main) model[, "pval_inter"] <- NA_real_+ nested = TRUE, |
|||
| 220 | +145 |
-
+ ..., |
||
| 221 | -191x | +|||
| 146 | +
- if (cov_no_arm || (!cov_no_arm && !"arm" %in% names(variables) && is.numeric(df[[cov]]))) {
+ table_names = var, |
|||
| 222 | -15x | +|||
| 147 | +
- multivar <- TRUE+ .stats = NULL, |
|||
| 223 | -3x | +|||
| 148 | +
- if (!cov_no_arm) var_main <- TRUE+ .formats = NULL, |
|||
| 224 | +149 |
- }+ .labels = NULL, |
||
| 225 | +150 |
-
+ .indent_mods = NULL) {
|
||
| 226 | -191x | +151 | +3x |
- vars_coxreg <- list(which_vars = "all", var_nms = NULL)+ afun <- make_afun( |
| 227 | -191x | +152 | +3x |
- if (eff) {
+ a_count_abnormal, |
| 228 | -40x | +153 | +3x |
- if (multivar && !var_main) { # multivar treatment level
+ .stats = .stats, |
| 229 | -6x | +154 | +3x |
- var_lbl_arm <- formatters::var_labels(df)[[variables$arm]]+ .formats = .formats, |
| 230 | -6x | -
- vars_coxreg[c("var_nms", "which_vars")] <- list(c(variables$arm, var_lbl_arm), "multi_lvl")
- |
- ||
| 231 | -+ | 155 | +3x |
- } else { # treatment effect
+ .labels = .labels, |
| 232 | -34x | +156 | +3x |
- vars_coxreg["var_nms"] <- variables$arm+ .indent_mods = .indent_mods, |
| 233 | -6x | +157 | +3x |
- if (var_main) vars_coxreg["which_vars"] <- "var_main"+ .ungroup_stats = "fraction" |
| 234 | +158 |
- }+ ) |
||
| 235 | +159 |
- } else {
- |
- ||
| 236 | -151x | -
- if (!multivar || (multivar && var_main && !is.numeric(df[[cov]]))) { # covariate effect/level
- |
- ||
| 237 | -118x | -
- vars_coxreg[c("var_nms", "which_vars")] <- list(cov, "var_main")
- |
- ||
| 238 | -33x | -
- } else if (multivar) { # multivar covariate level
- |
- ||
| 239 | -33x | -
- vars_coxreg[c("var_nms", "which_vars")] <- list(c(cov, var_lbl), "multi_lvl")
+
|
||
| 240 | -6x | +160 | +3x |
- if (var_main) model[cov, .stats] <- NA_real_+ checkmate::assert_string(var) |
| 241 | +161 |
- }+ |
||
| 242 | -40x | -
- if (!multivar && !var_main && control$interaction) vars_coxreg["which_vars"] <- "inter" # interaction effect- |
- ||
| 243 | -+ | 162 | +3x |
- }+ analyze( |
| 244 | -191x | +163 | +3x |
- var_vals <- s_coxreg(model, .stats, .which_vars = vars_coxreg$which_vars, .var_nms = vars_coxreg$var_nms)[[1]]+ lyt = lyt, |
| 245 | -191x | +164 | +3x |
- var_names <- if (all(grepl("\\(reference = ", names(var_vals))) && labelstr != tail(.spl_context$value, 1)) {
+ vars = var, |
| 246 | -21x | +165 | +3x |
- paste(c(labelstr, tail(strsplit(names(var_vals), " ")[[1]], 3)), collapse = " ") # "reference" main effect labels+ afun = afun, |
| 247 | -191x | +166 | +3x |
- } else if ((!multivar && !eff && !(!var_main && control$interaction) && nchar(labelstr) > 0) ||+ na_str = na_str, |
| 248 | -191x | +167 | +3x |
- (multivar && var_main && is.numeric(df[[cov]]))) {
+ nested = nested, |
| 249 | -47x | +168 | +3x |
- labelstr # other main effect labels+ table_names = table_names, |
| 250 | -191x | +169 | +3x |
- } else if (multivar && !eff && !var_main && is.numeric(df[[cov]])) {
+ extra_args = list(...), |
| 251 | -6x | +170 | +3x |
- "All" # multivar numeric covariate+ show_labels = "hidden" |
| 252 | +171 |
- } else {
- |
- ||
| 253 | -117x | -
- names(var_vals)+ ) |
||
| 254 | +172 |
- }- |
- ||
| 255 | -191x | -
- in_rows(- |
- ||
| 256 | -191x | -
- .list = var_vals, .names = var_names, .labels = var_names, .indent_mods = .indent_mods,+ } |
||
| 257 | -191x | +
| 1 | +
- .formats = stats::setNames(rep(.formats, length(var_names)), var_names),+ #' Count the Number of Patients with a Particular Event |
|||
| 258 | -191x | +|||
| 2 | +
- .format_na_strs = stats::setNames(rep(na_level, length(var_names)), var_names)+ #' |
|||
| 259 | +3 |
- )+ #' @description `r lifecycle::badge("stable")`
|
||
| 260 | +4 |
- }+ #' |
||
| 261 | +5 |
-
+ #' The primary analysis variable `.var` denotes the unique patient identifier. |
||
| 262 | +6 |
- #' @describeIn cox_regression Layout-creating function which creates a Cox regression summary table+ #' |
||
| 263 | +7 |
- #' layout. This function is a wrapper for several `rtables` layouting functions. This function+ #' @inheritParams argument_convention |
||
| 264 | +8 |
- #' is a wrapper for [rtables::analyze_colvars()] and [rtables::summarize_row_groups()].+ #' |
||
| 265 | +9 |
- #'+ #' @seealso [count_patients_with_flags] |
||
| 266 | +10 |
- #' @inheritParams fit_coxreg_univar+ #' |
||
| 267 | +11 |
- #' @param multivar (`flag`)\cr Defaults to `FALSE`. If `TRUE` multivariate Cox regression will run, otherwise+ #' @name count_patients_with_event |
||
| 268 | +12 |
- #' univariate Cox regression will run.+ NULL |
||
| 269 | +13 |
- #' @param common_var (`character`)\cr the name of a factor variable in the dataset which takes the same value+ |
||
| 270 | +14 |
- #' for all rows. This should be created during pre-processing if no such variable currently exists.+ #' @describeIn count_patients_with_event Statistics function which counts the number of patients for which |
||
| 271 | +15 |
- #' @param .section_div (`character`)\cr string which should be repeated as a section divider between sections.+ #' the defined event has occurred. |
||
| 272 | +16 |
- #' Defaults to `NA` for no section divider. If a vector of two strings are given, the first will be used between+ #' |
||
| 273 | +17 |
- #' treatment and covariate sections and the second between different covariates.+ #' @inheritParams analyze_variables |
||
| 274 | +18 |
- #'+ #' @param .var (`character`)\cr name of the column that contains the unique identifier. |
||
| 275 | +19 |
- #' @return+ #' @param filters (`character`)\cr a character vector specifying the column names and flag variables |
||
| 276 | +20 |
- #' * `summarize_coxreg()` returns a layout object suitable for passing to further layouting functions,+ #' to be used for counting the number of unique identifiers satisfying such conditions. |
||
| 277 | +21 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add a Cox regression table+ #' Multiple column names and flags are accepted in this format |
||
| 278 | +22 |
- #' containing the chosen statistics to the table layout.+ #' `c("column_name1" = "flag1", "column_name2" = "flag2")`.
|
||
| 279 | +23 |
- #'+ #' Note that only equality is being accepted as condition. |
||
| 280 | +24 |
- #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()] which also take the `variables`, `data`,+ #' |
||
| 281 | +25 |
- #' `at` (univariate only), and `control` arguments but return unformatted univariate and multivariate+ #' @return |
||
| 282 | +26 |
- #' Cox regression models, respectively.+ #' * `s_count_patients_with_event()` returns the count and fraction of unique identifiers with the defined event. |
||
| 283 | +27 |
#' |
||
| 284 | +28 |
#' @examples |
||
| 285 | +29 |
- #' # summarize_coxreg+ #' library(dplyr) |
||
| 286 | +30 |
#' |
||
| 287 | +31 |
- #' result_univar <- basic_table() %>%+ #' # `s_count_patients_with_event()` |
||
| 288 | +32 |
- #' summarize_coxreg(variables = u1_variables) %>%+ #' |
||
| 289 | +33 |
- #' build_table(dta_bladder)+ #' s_count_patients_with_event( |
||
| 290 | +34 |
- #' result_univar+ #' tern_ex_adae, |
||
| 291 | +35 |
- #'+ #' .var = "SUBJID", |
||
| 292 | +36 |
- #' result_multivar <- basic_table() %>%+ #' filters = c("TRTEMFL" = "Y")
|
||
| 293 | +37 |
- #' summarize_coxreg(+ #' ) |
||
| 294 | +38 |
- #' variables = m1_variables,+ #' s_count_patients_with_event( |
||
| 295 | +39 |
- #' multivar = TRUE,+ #' tern_ex_adae, |
||
| 296 | +40 |
- #' ) %>%+ #' .var = "SUBJID", |
||
| 297 | +41 |
- #' build_table(dta_bladder)+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL")
|
||
| 298 | +42 |
- #' result_multivar+ #' ) |
||
| 299 | +43 |
- #'+ #' s_count_patients_with_event( |
||
| 300 | +44 |
- #' result_univar_covs <- basic_table() %>%+ #' tern_ex_adae, |
||
| 301 | +45 |
- #' summarize_coxreg(+ #' .var = "SUBJID", |
||
| 302 | +46 |
- #' variables = u2_variables,+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
|
||
| 303 | +47 |
- #' ) %>%+ #' denom = "N_col", |
||
| 304 | +48 |
- #' build_table(dta_bladder)+ #' .N_col = 456 |
||
| 305 | +49 |
- #' result_univar_covs+ #' ) |
||
| 306 | +50 |
#' |
||
| 307 | +51 |
- #' result_multivar_covs <- basic_table() %>%+ #' @export |
||
| 308 | +52 |
- #' summarize_coxreg(+ s_count_patients_with_event <- function(df, |
||
| 309 | +53 |
- #' variables = m2_variables,+ .var, |
||
| 310 | +54 |
- #' multivar = TRUE,+ filters, |
||
| 311 | +55 |
- #' varlabels = c("Covariate 1", "Covariate 2") # custom labels
+ .N_col, # nolint |
||
| 312 | +56 |
- #' ) %>%+ .N_row, # nolint |
||
| 313 | +57 |
- #' build_table(dta_bladder)+ denom = c("n", "N_row", "N_col")) {
|
||
| 314 | -+ | |||
| 58 | +30x |
- #' result_multivar_covs+ col_names <- names(filters) |
||
| 315 | -+ | |||
| 59 | +30x |
- #'+ filter_values <- filters |
||
| 316 | +60 |
- #' @export+ |
||
| 317 | -+ | |||
| 61 | +30x |
- summarize_coxreg <- function(lyt,+ checkmate::assert_subset(col_names, colnames(df)) |
||
| 318 | +62 |
- variables,+ |
||
| 319 | -+ | |||
| 63 | +30x |
- control = control_coxreg(),+ temp <- Map( |
||
| 320 | -+ | |||
| 64 | +30x |
- at = list(),+ function(x, y) which(df[[x]] == y), |
||
| 321 | -+ | |||
| 65 | +30x |
- multivar = FALSE,+ col_names, |
||
| 322 | -+ | |||
| 66 | +30x |
- common_var = "STUDYID",+ filter_values |
||
| 323 | +67 |
- .stats = c("n", "hr", "ci", "pval", "pval_inter"),
+ ) |
||
| 324 | -+ | |||
| 68 | +30x |
- .formats = c(+ position_satisfy_filters <- Reduce(intersect, temp) |
||
| 325 | -+ | |||
| 69 | +30x |
- n = "xx", hr = "xx.xx", ci = "(xx.xx, xx.xx)",+ id_satisfy_filters <- as.character(unique(df[position_satisfy_filters, ][[.var]])) |
||
| 326 | -+ | |||
| 70 | +30x |
- pval = "x.xxxx | (<0.0001)", pval_inter = "x.xxxx | (<0.0001)"+ result <- s_count_values( |
||
| 327 | -+ | |||
| 71 | +30x |
- ),+ as.character(unique(df[[.var]])), |
||
| 328 | -+ | |||
| 72 | +30x |
- varlabels = NULL,+ id_satisfy_filters, |
||
| 329 | -+ | |||
| 73 | +30x |
- .indent_mods = NULL,+ denom = denom, |
||
| 330 | -+ | |||
| 74 | +30x | +
+ .N_col = .N_col,+ |
+ ||
| 75 | +30x |
- na_level = "",+ .N_row = .N_row |
||
| 331 | +76 |
- .section_div = NA_character_) {
+ ) |
||
| 332 | -11x | +77 | +30x |
- if (multivar && control$interaction) {
+ result |
| 333 | -1x | +|||
| 78 | +
- warning(paste(+ } |
|||
| 334 | -1x | +|||
| 79 | +
- "Interactions are not available for multivariate cox regression using summarize_coxreg.",+ |
|||
| 335 | -1x | +|||
| 80 | +
- "The model will be calculated without interaction effects."+ #' @describeIn count_patients_with_event Formatted analysis function which is used as `afun` |
|||
| 336 | +81 |
- ))+ #' in `count_patients_with_event()`. |
||
| 337 | +82 |
- }+ #' |
||
| 338 | -11x | +|||
| 83 | +
- if (control$interaction && !"arm" %in% names(variables)) {
+ #' @return |
|||
| 339 | -1x | +|||
| 84 | +
- stop("To include interactions please specify 'arm' in variables.")
+ #' * `a_count_patients_with_event()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 340 | +85 |
- }+ #' |
||
| 341 | +86 |
-
+ #' @examples |
||
| 342 | -10x | +|||
| 87 | +
- .stats <- if (!"arm" %in% names(variables) || multivar) { # only valid statistics
+ #' # `a_count_patients_with_event()` |
|||
| 343 | -4x | +|||
| 88 | +
- intersect(c("hr", "ci", "pval"), .stats)
+ #' |
|||
| 344 | -10x | +|||
| 89 | +
- } else if (control$interaction) {
+ #' a_count_patients_with_event( |
|||
| 345 | -4x | +|||
| 90 | +
- intersect(c("n", "hr", "ci", "pval", "pval_inter"), .stats)
+ #' tern_ex_adae, |
|||
| 346 | +91 |
- } else {
+ #' .var = "SUBJID", |
||
| 347 | -2x | +|||
| 92 | ++ |
+ #' filters = c("TRTEMFL" = "Y"),
+ |
+ ||
| 93 | +
- intersect(c("n", "hr", "ci", "pval"), .stats)
+ #' .N_col = 100, |
|||
| 348 | +94 |
- }+ #' .N_row = 100 |
||
| 349 | -10x | +|||
| 95 | +
- stat_labels <- c(+ #' ) |
|||
| 350 | -10x | +|||
| 96 | +
- n = "n", hr = "Hazard Ratio", ci = paste0(control$conf_level * 100, "% CI"),+ #' |
|||
| 351 | -10x | +|||
| 97 | +
- pval = "p-value", pval_inter = "Interaction p-value"+ #' @export |
|||
| 352 | +98 |
- )+ a_count_patients_with_event <- make_afun( |
||
| 353 | -10x | +|||
| 99 | +
- stat_labels <- stat_labels[names(stat_labels) %in% .stats]+ s_count_patients_with_event, |
|||
| 354 | -10x | +|||
| 100 | +
- .formats <- .formats[names(.formats) %in% .stats]+ .formats = c(count_fraction = format_count_fraction_fixed_dp) |
|||
| 355 | -10x | +|||
| 101 | +
- env <- new.env() # create caching environment+ ) |
|||
| 356 | +102 | |||
| 357 | -10x | +|||
| 103 | +
- lyt <- lyt %>%+ #' @describeIn count_patients_with_event Layout-creating function which can take statistics function |
|||
| 358 | -10x | +|||
| 104 | +
- split_cols_by_multivar(+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 359 | -10x | +|||
| 105 | +
- vars = rep(common_var, length(.stats)),+ #' |
|||
| 360 | -10x | +|||
| 106 | +
- varlabels = stat_labels,+ #' @return |
|||
| 361 | -10x | +|||
| 107 | +
- extra_args = list(+ #' * `count_patients_with_event()` returns a layout object suitable for passing to further layouting functions, |
|||
| 362 | -10x | +|||
| 108 | +
- .stats = .stats, .formats = .formats, .indent_mods = .indent_mods, na_level = rep(na_level, length(.stats)),+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 363 | -10x | +|||
| 109 | +
- cache_env = replicate(length(.stats), list(env))+ #' the statistics from `s_count_patients_with_event()` to the table layout. |
|||
| 364 | +110 |
- )+ #' |
||
| 365 | +111 |
- )+ #' @examples |
||
| 366 | +112 |
-
+ #' # `count_patients_with_event()` |
||
| 367 | -10x | +|||
| 113 | +
- if ("arm" %in% names(variables)) { # treatment effect
+ #' |
|||
| 368 | -8x | +|||
| 114 | +
- lyt <- lyt %>%+ #' lyt <- basic_table() %>% |
|||
| 369 | -8x | +|||
| 115 | +
- split_rows_by(+ #' split_cols_by("ARM") %>%
|
|||
| 370 | -8x | +|||
| 116 | +
- common_var,+ #' add_colcounts() %>% |
|||
| 371 | -8x | +|||
| 117 | +
- split_label = "Treatment:",+ #' count_values( |
|||
| 372 | -8x | +|||
| 118 | +
- label_pos = "visible",+ #' "STUDYID", |
|||
| 373 | -8x | +|||
| 119 | +
- child_labels = "hidden",+ #' values = "AB12345", |
|||
| 374 | -8x | +|||
| 120 | +
- section_div = head(.section_div, 1)+ #' .stats = "count", |
|||
| 375 | +121 |
- )+ #' .labels = c(count = "Total AEs") |
||
| 376 | -8x | +|||
| 122 | +
- if (!multivar) {
+ #' ) %>% |
|||
| 377 | -6x | +|||
| 123 | +
- lyt <- lyt %>%+ #' count_patients_with_event( |
|||
| 378 | -6x | +|||
| 124 | +
- analyze_colvars(+ #' "SUBJID", |
|||
| 379 | -6x | +|||
| 125 | +
- afun = a_coxreg,+ #' filters = c("TRTEMFL" = "Y"),
|
|||
| 380 | -6x | +|||
| 126 | +
- extra_args = list(+ #' .labels = c(count_fraction = "Total number of patients with at least one adverse event"), |
|||
| 381 | -6x | +|||
| 127 | +
- variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar,+ #' table_names = "tbl_all" |
|||
| 382 | -6x | +|||
| 128 | +
- labelstr = ""+ #' ) %>% |
|||
| 383 | +129 |
- )+ #' count_patients_with_event( |
||
| 384 | +130 |
- )+ #' "SUBJID", |
||
| 385 | +131 |
- } else { # treatment level effects
+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
|
||
| 386 | -2x | +|||
| 132 | +
- lyt <- lyt %>%+ #' .labels = c(count_fraction = "Total number of patients with fatal AEs"), |
|||
| 387 | -2x | +|||
| 133 | +
- summarize_row_groups(+ #' table_names = "tbl_fatal" |
|||
| 388 | -2x | +|||
| 134 | +
- cfun = a_coxreg,+ #' ) %>% |
|||
| 389 | -2x | +|||
| 135 | +
- extra_args = list(+ #' count_patients_with_event( |
|||
| 390 | -2x | +|||
| 136 | +
- variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar+ #' "SUBJID", |
|||
| 391 | +137 |
- )+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL", "AEREL" = "Y"),
|
||
| 392 | +138 |
- ) %>%+ #' .labels = c(count_fraction = "Total number of patients with related fatal AEs"), |
||
| 393 | -2x | +|||
| 139 | +
- analyze_colvars(+ #' .indent_mods = c(count_fraction = 2L), |
|||
| 394 | -2x | +|||
| 140 | +
- afun = a_coxreg,+ #' table_names = "tbl_rel_fatal" |
|||
| 395 | -2x | +|||
| 141 | +
- extra_args = list(eff = TRUE, control = control, variables = variables, multivar = multivar, labelstr = "")+ #' ) |
|||
| 396 | +142 |
- )+ #' build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl) |
||
| 397 | +143 |
- }+ #' |
||
| 398 | +144 |
- }+ #' @export |
||
| 399 | +145 |
-
+ count_patients_with_event <- function(lyt, |
||
| 400 | -10x | +|||
| 146 | +
- if ("covariates" %in% names(variables)) { # covariate main effects
+ vars, |
|||
| 401 | -10x | +|||
| 147 | +
- lyt <- lyt %>%+ riskdiff = FALSE, |
|||
| 402 | -10x | +|||
| 148 | +
- split_rows_by_multivar(+ na_str = NA_character_, |
|||
| 403 | -10x | +|||
| 149 | +
- vars = variables$covariates,+ nested = TRUE, |
|||
| 404 | -10x | +|||
| 150 | +
- varlabels = varlabels,+ ..., |
|||
| 405 | -10x | +|||
| 151 | +
- split_label = "Covariate:",+ table_names = vars, |
|||
| 406 | -10x | +|||
| 152 | +
- nested = FALSE,+ .stats = "count_fraction", |
|||
| 407 | -10x | +|||
| 153 | +
- child_labels = if (multivar || control$interaction || !"arm" %in% names(variables)) "default" else "hidden",+ .formats = NULL, |
|||
| 408 | -10x | +|||
| 154 | +
- section_div = tail(.section_div, 1)+ .labels = NULL, |
|||
| 409 | +155 |
- )+ .indent_mods = NULL) {
|
||
| 410 | -10x | +156 | +6x |
- if (multivar || control$interaction || !"arm" %in% names(variables)) {
+ checkmate::assert_flag(riskdiff) |
| 411 | -8x | +|||
| 157 | +
- lyt <- lyt %>%+ |
|||
| 412 | -8x | +158 | +6x |
- summarize_row_groups(+ afun <- make_afun( |
| 413 | -8x | +159 | +6x |
- cfun = a_coxreg,+ a_count_patients_with_event, |
| 414 | -8x | +160 | +6x |
- extra_args = list(+ .stats = .stats, |
| 415 | -8x | +161 | +6x |
- variables = variables, at = at, control = control, multivar = multivar,+ .formats = .formats, |
| 416 | -8x | +162 | +6x |
- var_main = if (multivar) multivar else control$interaction+ .labels = .labels, |
| 417 | -+ | |||
| 163 | +6x |
- )+ .indent_mods = .indent_mods |
||
| 418 | +164 |
- )+ ) |
||
| 419 | +165 |
- } else {
- |
- ||
| 420 | -! | -
- if (!is.null(varlabels)) names(varlabels) <- variables$covariates+ |
||
| 421 | -2x | +166 | +6x |
- lyt <- lyt %>%+ extra_args <- if (isFALSE(riskdiff)) {
|
| 422 | -2x | +167 | +5x |
- analyze_colvars(+ list(...) |
| 423 | -2x | +|||
| 168 | +
- afun = a_coxreg,+ } else {
|
|||
| 424 | -2x | +169 | +1x |
- extra_args = list(+ list( |
| 425 | -2x | +170 | +1x |
- variables = variables, at = at, control = control, multivar = multivar,+ afun = list("s_count_patients_with_event" = afun),
|
| 426 | -2x | +171 | +1x |
- var_main = if (multivar) multivar else control$interaction,+ .stats = .stats, |
| 427 | -2x | +172 | +1x |
- labelstr = if (is.null(varlabels)) "" else varlabels+ .indent_mods = .indent_mods, |
| 428 | -+ | |||
| 173 | +1x |
- )+ s_args = list(...) |
||
| 429 | +174 |
- )+ ) |
||
| 430 | +175 |
- }+ } |
||
| 431 | +176 | |||
| 432 | -2x | +177 | +6x |
- if (!"arm" %in% names(variables)) control$interaction <- TRUE # special case: univar no arm+ analyze( |
| 433 | -10x | +178 | +6x |
- if (multivar || control$interaction) { # covariate level effects
+ lyt, |
| 434 | -8x | +179 | +6x |
- lyt <- lyt %>%+ vars, |
| 435 | -8x | +180 | +6x |
- analyze_colvars(+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff), |
| 436 | -8x | +181 | +6x |
- afun = a_coxreg,+ na_str = na_str, |
| 437 | -8x | +182 | +6x |
- extra_args = list(variables = variables, at = at, control = control, multivar = multivar, labelstr = "")+ nested = nested, |
| 438 | -+ | |||
| 183 | +6x |
- )+ extra_args = extra_args, |
||
| 439 | -+ | |||
| 184 | +6x |
- }+ show_labels = ifelse(length(vars) > 1, "visible", "hidden"), |
||
| 440 | -+ | |||
| 185 | +6x |
- }+ table_names = table_names |
||
| 441 | +186 | - - | -||
| 442 | -10x | -
- lyt+ ) |
||
| 443 | +187 |
}@@ -44398,14 +44793,14 @@ tern coverage - 94.83% |
| 1 |
- #' Confidence Intervals for a Difference of Binomials+ #' Estimation of Proportions per Level of Factor |
||
| 3 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @description `r lifecycle::badge("stable")`
|
||
| 5 |
- #' Several confidence intervals for the difference between proportions.+ #' Estimate the proportion along with confidence interval of a proportion |
||
| 6 |
- #'+ #' regarding the level of a factor. |
||
| 7 |
- #' @name desctools_binom+ #' |
||
| 8 |
- NULL+ #' @inheritParams argument_convention |
||
| 9 |
-
+ #' |
||
| 10 |
- #' Recycle List of Parameters+ #' @seealso Relevant description function [d_onco_rsp_label()]. |
||
| 12 |
- #' This function recycles all supplied elements to the maximal dimension.+ #' @name estimate_multinomial_rsp |
||
| 13 |
- #'+ NULL |
||
| 14 |
- #' @param ... (`any`)\cr Elements to recycle.+ |
||
| 15 |
- #'+ #' Description of Standard Oncology Response |
||
| 16 |
- #' @return A `list`.+ #' |
||
| 17 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 18 |
- #' @keywords internal+ #' |
||
| 19 |
- #' @noRd+ #' Describe the oncology response in a standard way. |
||
| 20 |
- h_recycle <- function(...) {
+ #' |
||
| 21 | -60x | +
- lst <- list(...)+ #' @param x (`character`)\cr the standard oncology code to be described. |
|
| 22 | -60x | +
- maxdim <- max(lengths(lst))+ #' |
|
| 23 | -60x | +
- res <- lapply(lst, rep, length.out = maxdim)+ #' @return Response labels. |
|
| 24 | -60x | +
- attr(res, "maxdim") <- maxdim+ #' |
|
| 25 | -60x | +
- return(res)+ #' @seealso [estimate_multinomial_rsp()] |
|
| 26 |
- }+ #' |
||
| 27 |
-
+ #' @examples |
||
| 28 |
- #' @describeIn desctools_binom Several confidence intervals for the difference between proportions.+ #' d_onco_rsp_label( |
||
| 29 |
- #'+ #' c("CR", "PR", "SD", "NON CR/PD", "PD", "NE", "Missing", "<Missing>", "NE/Missing")
|
||
| 30 |
- #' @return A `matrix` of 3 values:+ #' ) |
||
| 31 |
- #' * `est`: estimate of proportion difference.+ #' |
||
| 32 |
- #' * `lwr.ci`: estimate of lower end of the confidence interval.+ #' # Adding some values not considered in d_onco_rsp_label |
||
| 33 |
- #' * `upr.ci`: estimate of upper end of the confidence interval.+ #' |
||
| 34 |
- #'+ #' d_onco_rsp_label( |
||
| 35 |
- #' @keywords internal+ #' c("CR", "PR", "hello", "hi")
|
||
| 36 |
- desctools_binom <- function(x1, n1, x2, n2, conf.level = 0.95, sides = c( # nolint+ #' ) |
||
| 37 |
- "two.sided",+ #' |
||
| 38 |
- "left", "right"+ #' @export |
||
| 39 |
- ), method = c(+ d_onco_rsp_label <- function(x) {
|
||
| 40 | -+ | 2x |
- "ac", "wald", "waldcc", "score",+ x <- as.character(x) |
| 41 | -+ | 2x |
- "scorecc", "mn", "mee", "blj", "ha", "hal", "jp"+ desc <- c( |
| 42 | -+ | 2x |
- )) {
+ CR = "Complete Response (CR)", |
| 43 | -18x | +2x |
- if (missing(sides)) {
+ PR = "Partial Response (PR)", |
| 44 | -18x | +2x |
- sides <- match.arg(sides)+ MR = "Minimal/Minor Response (MR)", |
| 45 | -+ | 2x |
- }+ MRD = "Minimal Residual Disease (MRD)", |
| 46 | -18x | +2x |
- if (missing(method)) {
+ SD = "Stable Disease (SD)", |
| 47 | -1x | +2x |
- method <- match.arg(method)+ PD = "Progressive Disease (PD)", |
| 48 | -+ | 2x |
- }+ `NON CR/PD` = "Non-CR or Non-PD (NON CR/PD)", |
| 49 | -18x | +2x |
- iBinomDiffCI <- function(x1, n1, x2, n2, conf.level, sides, # nolint+ NE = "Not Evaluable (NE)", |
| 50 | -18x | +2x |
- method) {
+ `NE/Missing` = "Missing or unevaluable", |
| 51 | -18x | +2x |
- if (sides != "two.sided") {
+ Missing = "Missing", |
| 52 | -! | +2x |
- conf.level <- 1 - 2 * (1 - conf.level) # nolint+ `NA` = "Not Applicable (NA)", |
| 53 | -+ | 2x |
- }+ ND = "Not Done (ND)" |
| 54 | -18x | +
- alpha <- 1 - conf.level+ ) |
|
| 55 | -18x | +
- kappa <- stats::qnorm(1 - alpha / 2)+ |
|
| 56 | -18x | +2x |
- p1_hat <- x1 / n1+ values_label <- vapply( |
| 57 | -18x | +2x |
- p2_hat <- x2 / n2+ X = x, |
| 58 | -18x | +2x |
- est <- p1_hat - p2_hat+ FUN.VALUE = character(1), |
| 59 | -18x | +2x |
- switch(method,+ function(val) {
|
| 60 | -18x | +! |
- wald = {
+ if (val %in% names(desc)) desc[val] else val |
| 61 | -2x | +
- vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2+ } |
|
| 62 | -2x | +
- term2 <- kappa * sqrt(vd)+ ) |
|
| 63 | -2x | +
- ci_lwr <- max(-1, est - term2)+ |
|
| 64 | 2x |
- ci_upr <- min(1, est + term2)+ return(factor(values_label, levels = c(intersect(desc, values_label), setdiff(values_label, desc)))) |
|
| 65 |
- },+ } |
||
| 66 | -18x | +
- waldcc = {
+
|
|
| 67 | -2x | +
- vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2+ #' @describeIn estimate_multinomial_rsp Statistics function which feeds the length of `x` as number |
|
| 68 | -2x | +
- term2 <- kappa * sqrt(vd)+ #' of successes, and `.N_col` as total number of successes and failures into [s_proportion()]. |
|
| 69 | -2x | +
- term2 <- term2 + 0.5 * (1 / n1 + 1 / n2)+ #' |
|
| 70 | -2x | +
- ci_lwr <- max(-1, est - term2)+ #' @return |
|
| 71 | -2x | +
- ci_upr <- min(1, est + term2)+ #' * `s_length_proportion()` returns statistics from [s_proportion()]. |
|
| 72 |
- },+ #' |
||
| 73 | -18x | +
- ac = {
+ #' @examples |
|
| 74 | -2x | +
- n1 <- n1 + 2+ #' s_length_proportion(rep("CR", 10), .N_col = 100)
|
|
| 75 | -2x | +
- n2 <- n2 + 2+ #' s_length_proportion(factor(character(0)), .N_col = 100) |
|
| 76 | -2x | +
- x1 <- x1 + 1+ #' |
|
| 77 | -2x | +
- x2 <- x2 + 1+ #' @export |
|
| 78 | -2x | +
- p1_hat <- x1 / n1+ s_length_proportion <- function(x, |
|
| 79 | -2x | +
- p2_hat <- x2 / n2+ .N_col, # nolint |
|
| 80 | -2x | +
- est1 <- p1_hat - p2_hat+ ...) {
|
|
| 81 | -2x | +4x |
- vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2+ checkmate::assert_multi_class(x, classes = c("factor", "character"))
|
| 82 | -2x | +3x |
- term2 <- kappa * sqrt(vd)+ checkmate::assert_vector(x, min.len = 0, max.len = .N_col) |
| 83 | 2x |
- ci_lwr <- max(-1, est1 - term2)+ checkmate::assert_vector(unique(x), min.len = 0, max.len = 1) |
|
| 84 | -2x | +
- ci_upr <- min(1, est1 + term2)+ |
|
| 85 | -+ | 1x |
- },+ n_true <- length(x) |
| 86 | -18x | +1x |
- exact = {
+ n_false <- .N_col - n_true |
| 87 | -! | +1x |
- ci_lwr <- NA+ x_logical <- rep(c(TRUE, FALSE), c(n_true, n_false)) |
| 88 | -! | +1x |
- ci_upr <- NA+ s_proportion(df = x_logical, ...) |
| 89 |
- },+ } |
||
| 90 | -18x | +
- score = {
+
|
|
| 91 | -2x | +
- w1 <- desctools_binomci(+ #' @describeIn estimate_multinomial_rsp Formatted analysis function which is used as `afun` |
|
| 92 | -2x | +
- x = x1, n = n1, conf.level = conf.level,+ #' in `estimate_multinomial_response()`. |
|
| 93 | -2x | +
- method = "wilson"+ #' |
|
| 94 |
- )+ #' @return |
||
| 95 | -2x | +
- w2 <- desctools_binomci(+ #' * `a_length_proportion()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 96 | -2x | +
- x = x2, n = n2, conf.level = conf.level,+ #' |
|
| 97 | -2x | +
- method = "wilson"+ #' @examples |
|
| 98 |
- )+ #' a_length_proportion(rep("CR", 10), .N_col = 100)
|
||
| 99 | -2x | +
- l1 <- w1[2]+ #' a_length_proportion(factor(character(0)), .N_col = 100) |
|
| 100 | -2x | +
- u1 <- w1[3]+ #' |
|
| 101 | -2x | +
- l2 <- w2[2]+ #' @export |
|
| 102 | -2x | +
- u2 <- w2[3]+ a_length_proportion <- make_afun( |
|
| 103 | -2x | +
- ci_lwr <- est - kappa * sqrt(l1 * (1 - l1) / n1 ++ s_length_proportion, |
|
| 104 | -2x | +
- u2 * (1 - u2) / n2)+ .formats = c( |
|
| 105 | -2x | +
- ci_upr <- est + kappa * sqrt(u1 * (1 - u1) / n1 ++ n_prop = "xx (xx.x%)", |
|
| 106 | -2x | +
- l2 * (1 - l2) / n2)+ prop_ci = "(xx.xx, xx.xx)" |
|
| 107 |
- },+ ) |
||
| 108 | -18x | +
- scorecc = {
+ ) |
|
| 109 | -1x | +
- w1 <- desctools_binomci(+ |
|
| 110 | -1x | +
- x = x1, n = n1, conf.level = conf.level,+ #' @describeIn estimate_multinomial_rsp Layout-creating function which can take statistics function arguments |
|
| 111 | -1x | +
- method = "wilsoncc"+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()] and |
|
| 112 |
- )+ #' [rtables::summarize_row_groups()]. |
||
| 113 | -1x | +
- w2 <- desctools_binomci(+ #' |
|
| 114 | -1x | +
- x = x2, n = n2, conf.level = conf.level,+ #' @return |
|
| 115 | -1x | +
- method = "wilsoncc"+ #' * `estimate_multinomial_response()` returns a layout object suitable for passing to further layouting functions, |
|
| 116 |
- )+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 117 | -1x | +
- l1 <- w1[2]+ #' the statistics from `s_length_proportion()` to the table layout. |
|
| 118 | -1x | +
- u1 <- w1[3]+ #' |
|
| 119 | -1x | +
- l2 <- w2[2]+ #' @examples |
|
| 120 | -1x | +
- u2 <- w2[3]+ #' library(dplyr) |
|
| 121 | -1x | +
- ci_lwr <- max(-1, est - sqrt((p1_hat - l1)^2 ++ #' |
|
| 122 | -1x | +
- (u2 - p2_hat)^2))+ #' # Use of the layout creating function. |
|
| 123 | -1x | +
- ci_upr <- min(1, est + sqrt((u1 - p1_hat)^2 + (p2_hat -+ #' dta_test <- data.frame( |
|
| 124 | -1x | +
- l2)^2))+ #' USUBJID = paste0("S", 1:12),
|
|
| 125 |
- },+ #' ARM = factor(rep(LETTERS[1:3], each = 4)), |
||
| 126 | -18x | +
- mee = {
+ #' AVAL = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0)) |
|
| 127 | -1x | +
- .score <- function(p1, n1, p2, n2, dif) {
+ #' ) %>% mutate( |
|
| 128 | -! | +
- if (dif > 1) dif <- 1+ #' AVALC = factor(AVAL, |
|
| 129 | -! | +
- if (dif < -1) dif <- -1+ #' levels = c(0, 1), |
|
| 130 | -24x | +
- diff <- p1 - p2 - dif+ #' labels = c("Complete Response (CR)", "Partial Response (PR)")
|
|
| 131 | -24x | +
- if (abs(diff) == 0) {
+ #' ) |
|
| 132 | -! | +
- res <- 0+ #' ) |
|
| 133 |
- } else {
+ #' |
||
| 134 | -24x | +
- t <- n2 / n1+ #' lyt <- basic_table() %>% |
|
| 135 | -24x | +
- a <- 1 + t+ #' split_cols_by("ARM") %>%
|
|
| 136 | -24x | +
- b <- -(1 + t + p1 + t * p2 + dif * (t + 2))+ #' estimate_multinomial_response(var = "AVALC") |
|
| 137 | -24x | +
- c <- dif * dif + dif * (2 * p1 + t + 1) + p1 ++ #' |
|
| 138 | -24x | +
- t * p2+ #' tbl <- build_table(lyt, dta_test) |
|
| 139 | -24x | +
- d <- -p1 * dif * (1 + dif)+ #' |
|
| 140 | -24x | +
- v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2+ #' html <- as_html(tbl) |
|
| 141 | -24x | +
- if (abs(v) < .Machine$double.eps) v <- 0+ #' html |
|
| 142 | -24x | +
- s <- sqrt((b / a / 3)^2 - c / a / 3)+ #' \donttest{
|
|
| 143 | -24x | +
- u <- ifelse(v > 0, 1, -1) * s+ #' Viewer(html) |
|
| 144 | -24x | +
- w <- (3.141592654 + acos(v / u^3)) / 3+ #' } |
|
| 145 | -24x | +
- p1d <- 2 * u * cos(w) - b / a / 3+ #' |
|
| 146 | -24x | +
- p2d <- p1d - dif+ #' @export |
|
| 147 | -24x | +
- n <- n1 + n2+ estimate_multinomial_response <- function(lyt, |
|
| 148 | -24x | +
- res <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2)+ var, |
|
| 149 |
- }+ na_str = NA_character_, |
||
| 150 | -24x | +
- return(sqrt(res))+ nested = TRUE, |
|
| 151 |
- }+ ..., |
||
| 152 | -1x | +
- pval <- function(delta) {
+ show_labels = "hidden", |
|
| 153 | -24x | +
- z <- (est - delta) / .score(+ table_names = var, |
|
| 154 | -24x | +
- p1_hat, n1, p2_hat,+ .stats = "prop_ci", |
|
| 155 | -24x | +
- n2, delta+ .formats = NULL, |
|
| 156 |
- )+ .labels = NULL, |
||
| 157 | -24x | +
- 2 * min(stats::pnorm(z), 1 - stats::pnorm(z))+ .indent_mods = NULL) {
|
|
| 158 | -+ | 1x |
- }+ afun <- make_afun( |
| 159 | 1x |
- ci_lwr <- max(-1, stats::uniroot(function(delta) {
+ a_length_proportion, |
|
| 160 | -12x | +1x |
- pval(delta) -+ .stats = .stats, |
| 161 | -12x | +1x |
- alpha+ .formats = .formats, |
| 162 | 1x |
- }, interval = c(-1 + 1e-06, est - 1e-06))$root)+ .labels = .labels, |
|
| 163 | 1x |
- ci_upr <- min(1, stats::uniroot(function(delta) {
+ .indent_mods = .indent_mods |
|
| 164 | -12x | +
- pval(delta) -+ ) |
|
| 165 | -12x | +1x |
- alpha+ lyt <- split_rows_by(lyt, var = var) |
| 166 | 1x |
- }, interval = c(est + 1e-06, 1 - 1e-06))$root)+ lyt <- summarize_row_groups(lyt, na_str = na_str) |
|
| 167 |
- },+ |
||
| 168 | -18x | +1x |
- blj = {
+ analyze( |
| 169 | 1x |
- p1_dash <- (x1 + 0.5) / (n1 + 1)+ lyt, |
|
| 170 | 1x |
- p2_dash <- (x2 + 0.5) / (n2 + 1)+ vars = var, |
|
| 171 | 1x |
- vd <- p1_dash * (1 - p1_dash) / n1 + p2_dash * (1 -+ afun = afun, |
|
| 172 | 1x |
- p2_dash) / n2+ show_labels = show_labels, |
|
| 173 | 1x |
- term2 <- kappa * sqrt(vd)+ table_names = table_names, |
|
| 174 | 1x |
- est_dash <- p1_dash - p2_dash+ na_str = na_str, |
|
| 175 | 1x |
- ci_lwr <- max(-1, est_dash - term2)+ nested = nested, |
|
| 176 | 1x |
- ci_upr <- min(1, est_dash + term2)+ extra_args = list(...) |
|
| 177 |
- },+ ) |
||
| 178 | -18x | -
- ha = {
- |
- |
| 179 | -4x | -
- term2 <- 1 / (2 * min(n1, n2)) + kappa * sqrt(p1_hat *- |
- |
| 180 | -4x | -
- (1 - p1_hat) / (n1 - 1) + p2_hat * (1 - p2_hat) / (n2 -- |
- |
| 181 | -4x | -
- 1))- |
- |
| 182 | -4x | -
- ci_lwr <- max(-1, est - term2)- |
- |
| 183 | -4x | +
- ci_upr <- min(1, est + term2)+ } |
| 184 | +1 |
- },+ #' Split Function to Configure Risk Difference Column |
||
| 185 | -18x | +|||
| 2 | +
- mn = {
+ #' |
|||
| 186 | -1x | +|||
| 3 | +
- .conf <- function(x1, n1, x2, n2, z, lower = FALSE) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 187 | -2x | +|||
| 4 | +
- p1 <- x1 / n1+ #' |
|||
| 188 | -2x | +|||
| 5 | +
- p2 <- x2 / n2+ #' Wrapper function for [rtables::add_combo_levels()] which configures settings for the risk difference |
|||
| 189 | -2x | +|||
| 6 | +
- p_hat <- p1 - p2+ #' column to be added to an `rtables` object. To add a risk difference column to a table, this function |
|||
| 190 | -2x | +|||
| 7 | +
- dp <- 1 + ifelse(lower, 1, -1) * p_hat+ #' should be used as `split_fun` in calls to [rtables::split_cols_by()], followed by setting argument |
|||
| 191 | -2x | +|||
| 8 | +
- i <- 1+ #' `riskdiff` to `TRUE` in all following analyze function calls. |
|||
| 192 | -2x | +|||
| 9 | +
- while (i <= 50) {
+ #' |
|||
| 193 | -46x | +|||
| 10 | +
- dp <- 0.5 * dp+ #' @param arm_x (`character`)\cr Name of reference arm to use in risk difference calculations. |
|||
| 194 | -46x | +|||
| 11 | +
- y <- p_hat + ifelse(lower, -1, 1) * dp+ #' @param arm_y (`character`)\cr Name of arm to compare to reference arm in risk difference calculations. |
|||
| 195 | -46x | +|||
| 12 | +
- score <- .score(p1, n1, p2, n2, y)+ #' @param col_label (`character`)\cr Label to use when rendering the risk difference column within the table. |
|||
| 196 | -46x | +|||
| 13 | +
- if (score < z) {
+ #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`. |
|||
| 197 | -20x | +|||
| 14 | +
- p_hat <- y+ #' |
|||
| 198 | +15 |
- }+ #' @return A closure suitable for use as a split function (`split_fun`) within [rtables::split_cols_by()] |
||
| 199 | -46x | +|||
| 16 | +
- if ((dp < 1e-07) || (abs(z - score) < 1e-06)) {
+ #' when creating a table layout. |
|||
| 200 | -2x | +|||
| 17 | +
- (break)()+ #' |
|||
| 201 | +18 |
- } else {
+ #' @seealso [stat_propdiff_ci()] for details on risk difference calculation. |
||
| 202 | -44x | +|||
| 19 | +
- i <- i ++ #' |
|||
| 203 | -44x | +|||
| 20 | +
- 1+ #' @examples |
|||
| 204 | +21 |
- }+ #' adae <- tern_ex_adae |
||
| 205 | +22 |
- }+ #' adae$AESEV <- factor(adae$AESEV) |
||
| 206 | -2x | +|||
| 23 | +
- return(y)+ #' |
|||
| 207 | +24 |
- }+ #' lyt <- basic_table() %>% |
||
| 208 | -1x | +|||
| 25 | +
- .score <- function(p1, n1, p2, n2, dif) {
+ #' split_cols_by("ARMCD", split_fun = add_riskdiff(arm_x = "ARM A", arm_y = "ARM B")) %>%
|
|||
| 209 | -46x | +|||
| 26 | +
- diff <- p1 - p2 - dif+ #' count_occurrences_by_grade( |
|||
| 210 | -46x | +|||
| 27 | +
- if (abs(diff) == 0) {
+ #' var = "AESEV", |
|||
| 211 | -! | +|||
| 28 | +
- res <- 0+ #' riskdiff = TRUE |
|||
| 212 | +29 |
- } else {
+ #' ) |
||
| 213 | -46x | +|||
| 30 | +
- t <- n2 / n1+ #' |
|||
| 214 | -46x | +|||
| 31 | +
- a <- 1 + t+ #' tbl <- build_table(lyt, df = adae) |
|||
| 215 | -46x | +|||
| 32 | +
- b <- -(1 + t + p1 + t * p2 + dif * (t + 2))+ #' tbl |
|||
| 216 | -46x | +|||
| 33 | +
- c <- dif * dif + dif * (2 * p1 + t + 1) + p1 ++ #' |
|||
| 217 | -46x | +|||
| 34 | +
- t * p2+ #' @export |
|||
| 218 | -46x | +|||
| 35 | +
- d <- -p1 * dif * (1 + dif)+ add_riskdiff <- function(arm_x, |
|||
| 219 | -46x | +|||
| 36 | +
- v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2+ arm_y, |
|||
| 220 | -46x | +|||
| 37 | +
- s <- sqrt((b / a / 3)^2 - c / a / 3)+ col_label = "Risk Difference (%) (95% CI)", |
|||
| 221 | -46x | +|||
| 38 | +
- u <- ifelse(v > 0, 1, -1) * s+ pct = TRUE) {
|
|||
| 222 | -46x | +39 | +6x |
- w <- (3.141592654 + acos(v / u^3)) / 3+ sapply(c(arm_x, arm_y, col_label), checkmate::assert_character, len = 1) |
| 223 | -46x | +40 | +6x |
- p1d <- 2 * u * cos(w) - b / a / 3+ combodf <- tibble::tribble( |
| 224 | -46x | +41 | +6x |
- p2d <- p1d - dif+ ~valname, ~label, ~levelcombo, ~exargs, |
| 225 | -46x | +42 | +6x |
- n <- n1 + n2+ paste("riskdiff", arm_x, arm_y, sep = "_"), col_label, c(arm_x, arm_y), list()
|
| 226 | -46x | +|||
| 43 | +
- var <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2) *+ ) |
|||
| 227 | -46x | +44 | +6x |
- n / (n - 1)+ if (pct) combodf$valname <- paste0(combodf$valname, "_pct") |
| 228 | -46x | +45 | +6x |
- res <- diff^2 / var+ add_combo_levels(combodf) |
| 229 | +46 |
- }- |
- ||
| 230 | -46x | -
- return(res)+ } |
||
| 231 | +47 |
- }- |
- ||
| 232 | -1x | -
- z <- stats::qchisq(conf.level, 1)- |
- ||
| 233 | -1x | -
- ci_lwr <- max(-1, .conf(x1, n1, x2, n2, z, TRUE))- |
- ||
| 234 | -1x | -
- ci_upr <- min(1, .conf(x1, n1, x2, n2, z, FALSE))+ |
||
| 235 | +48 |
- },- |
- ||
| 236 | -18x | -
- beal = {
- |
- ||
| 237 | -! | -
- a <- p1_hat + p2_hat- |
- ||
| 238 | -! | -
- b <- p1_hat - p2_hat+ #' Analysis Function to Calculate Risk Difference Column Values |
||
| 239 | -! | +|||
| 49 | +
- u <- ((1 / n1) + (1 / n2)) / 4+ #' |
|||
| 240 | -! | +|||
| 50 | +
- v <- ((1 / n1) - (1 / n2)) / 4+ #' In the risk difference column, this function uses the statistics function associated with `afun` to |
|||
| 241 | -! | +|||
| 51 | +
- V <- u * ((2 - a) * a - b^2) + 2 * v * (1 - a) * b # nolint+ #' calculates risk difference values from arm X (reference group) and arm Y. These arms are specified |
|||
| 242 | -! | +|||
| 52 | +
- z <- stats::qchisq(p = 1 - alpha / 2, df = 1)+ #' when configuring the risk difference column which is done using the [add_riskdiff()] split function in |
|||
| 243 | -! | +|||
| 53 | +
- A <- sqrt(z * (V + z * u^2 * (2 - a) * a + z * v^2 * (1 - a)^2)) # nolint+ #' the previous call to [rtables::split_cols_by()]. For all other columns, applies `afun` as usual. This |
|||
| 244 | -! | +|||
| 54 | +
- B <- (b + z * v * (1 - a)) / (1 + z * u) # nolint+ #' function utilizes the [stat_propdiff_ci()] function to perform risk difference calculations. |
|||
| 245 | -! | +|||
| 55 | +
- ci_lwr <- max(-1, B - A / (1 + z * u))+ #' |
|||
| 246 | -! | +|||
| 56 | +
- ci_upr <- min(1, B + A / (1 + z * u))+ #' @inheritParams argument_convention |
|||
| 247 | +57 |
- },+ #' @param afun (named `list`)\cr A named list containing one name-value pair where the name corresponds to |
||
| 248 | -18x | +|||
| 58 | +
- hal = {
+ #' the name of the statistics function that should be used in calculations and the value is the corresponding |
|||
| 249 | -1x | +|||
| 59 | +
- psi <- (p1_hat + p2_hat) / 2+ #' analysis function. |
|||
| 250 | -1x | +|||
| 60 | +
- u <- (1 / n1 + 1 / n2) / 4+ #' @param s_args (named `list`)\cr Additional arguments to be passed to the statistics function and analysis |
|||
| 251 | -1x | +|||
| 61 | +
- v <- (1 / n1 - 1 / n2) / 4+ #' function supplied in `afun`. |
|||
| 252 | -1x | +|||
| 62 | +
- z <- kappa+ #' |
|||
| 253 | -1x | +|||
| 63 | +
- theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 *+ #' @return A list of formatted [rtables::CellValue()]. |
|||
| 254 | -1x | +|||
| 64 | +
- psi)) / (1 + z^2 * u)+ #' |
|||
| 255 | -1x | +|||
| 65 | +
- w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) -+ #' @seealso |
|||
| 256 | -1x | +|||
| 66 | +
- (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) *+ #' * [stat_propdiff_ci()] for details on risk difference calculation. |
|||
| 257 | -1x | +|||
| 67 | +
- (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) *+ #' * Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()] with |
|||
| 258 | -1x | +|||
| 68 | +
- psi + z^2 * v^2 * (1 - 2 * psi)^2)+ #' `riskdiff` argument set to `TRUE` in subsequent analyze functions calls, adds a risk difference column |
|||
| 259 | -1x | +|||
| 69 | +
- c(theta + w, theta - w)+ #' to a table layout. |
|||
| 260 | -1x | +|||
| 70 | +
- ci_lwr <- max(-1, theta - w)+ #' |
|||
| 261 | -1x | +|||
| 71 | +
- ci_upr <- min(1, theta + w)+ #' @keywords internal |
|||
| 262 | +72 |
- },+ afun_riskdiff <- function(df, |
||
| 263 | -18x | +|||
| 73 | +
- jp = {
+ labelstr = "", |
|||
| 264 | -1x | +|||
| 74 | +
- psi <- 0.5 * ((x1 + 0.5) / (n1 + 1) + (x2 + 0.5) / (n2 ++ .var, |
|||
| 265 | -1x | +|||
| 75 | +
- 1))+ .N_col, # nolint |
|||
| 266 | -1x | +|||
| 76 | +
- u <- (1 / n1 + 1 / n2) / 4+ .N_row, # nolint |
|||
| 267 | -1x | +|||
| 77 | +
- v <- (1 / n1 - 1 / n2) / 4+ .df_row, |
|||
| 268 | -1x | +|||
| 78 | +
- z <- kappa+ .spl_context, |
|||
| 269 | -1x | +|||
| 79 | +
- theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 *+ .all_col_counts, |
|||
| 270 | -1x | +|||
| 80 | +
- psi)) / (1 + z^2 * u)+ .stats, |
|||
| 271 | -1x | +|||
| 81 | +
- w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) -+ .indent_mods, |
|||
| 272 | -1x | +|||
| 82 | +
- (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) *+ afun, |
|||
| 273 | -1x | +|||
| 83 | +
- (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) *+ s_args = list()) {
|
|||
| 274 | -1x | +84 | +36x |
- psi + z^2 * v^2 * (1 - 2 * psi)^2)+ if (!any(grepl("riskdiff", names(.spl_context)))) {
|
| 275 | -1x | +|||
| 85 | +! |
- c(theta + w, theta - w)+ stop( |
||
| 276 | -1x | +|||
| 86 | +! |
- ci_lwr <- max(-1, theta - w)+ "Please set up levels to use in risk difference calculations using the `add_riskdiff` ", |
||
| 277 | -1x | +|||
| 87 | +! |
- ci_upr <- min(1, theta + w)+ "split function within `split_cols_by`. See ?add_riskdiff for details." |
||
| 278 | +88 |
- },+ ) |
||
| 279 | +89 |
- )+ } |
||
| 280 | -18x | +90 | +36x |
- ci <- c(+ checkmate::assert_list(afun, len = 1, types = "function") |
| 281 | -18x | +91 | +36x |
- est = est, lwr.ci = min(ci_lwr, ci_upr),+ checkmate::assert_named(afun) |
| 282 | -18x | +|||
| 92 | +
- upr.ci = max(ci_lwr, ci_upr)+ |
|||
| 283 | -+ | |||
| 93 | +36x |
- )+ afun_args <- list(.var = .var, .df_row = .df_row, .N_row = .N_row, denom = "N_col", labelstr = labelstr) |
||
| 284 | -18x | +94 | +36x |
- if (sides == "left") {
+ afun_args <- afun_args[intersect(names(afun_args), names(as.list(args(afun[[1]]))))] |
| 285 | +95 | ! |
- ci[3] <- 1+ if ("denom" %in% names(s_args)) afun_args[["denom"]] <- NULL
+ |
+ |
| 96 | ++ | + | ||
| 286 | -18x | +97 | +36x |
- } else if (sides == "right") {
+ cur_split <- tail(.spl_context$cur_col_split_val[[1]], 1) |
| 287 | -! | +|||
| 98 | +36x |
- ci[2] <- -1+ if (!grepl("^riskdiff", cur_split)) {
|
||
| 288 | +99 |
- }+ # Apply basic afun (no risk difference) in all other columns |
||
| 289 | -18x | +100 | +27x |
- return(ci)+ do.call(afun[[1]], args = c(list(df = df, .N_col = .N_col), afun_args, s_args)) |
| 290 | +101 |
- }+ } else {
|
||
| 291 | -18x | +102 | +9x |
- method <- match.arg(arg = method, several.ok = TRUE)+ arm_x <- strsplit(cur_split, "_")[[1]][2] |
| 292 | -18x | +103 | +9x |
- sides <- match.arg(arg = sides, several.ok = TRUE)+ arm_y <- strsplit(cur_split, "_")[[1]][3] |
| 293 | -18x | +104 | +9x |
- lst <- h_recycle(+ if (length(.spl_context$cur_col_split[[1]]) > 1) { # Different split name for nested column splits
|
| 294 | -18x | +|||
| 105 | +! |
- x1 = x1, n1 = n1, x2 = x2, n2 = n2, conf.level = conf.level,+ arm_spl_x <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 2)], collapse = ""))
|
||
| 295 | -18x | +|||
| 106 | +! |
- sides = sides, method = method+ arm_spl_y <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 3)], collapse = ""))
|
||
| 296 | +107 |
- )+ } else {
|
||
| 297 | -18x | +108 | +9x |
- res <- t(sapply(1:attr(lst, "maxdim"), function(i) {
+ arm_spl_x <- arm_x |
| 298 | -18x | +109 | +9x |
- iBinomDiffCI(+ arm_spl_y <- arm_y+ |
+
| 110 | ++ |
+ } |
||
| 299 | -18x | +111 | +9x |
- x1 = lst$x1[i],+ N_col_x <- .all_col_counts[[arm_spl_x]] # nolint |
| 300 | -18x | +112 | +9x |
- n1 = lst$n1[i], x2 = lst$x2[i], n2 = lst$n2[i], conf.level = lst$conf.level[i],+ N_col_y <- .all_col_counts[[arm_spl_y]] # nolint |
| 301 | -18x | +113 | +9x |
- sides = lst$sides[i], method = lst$method[i]+ cur_var <- tail(.spl_context$cur_col_split[[1]], 1) |
| 302 | +114 |
- )+ |
||
| 303 | +115 |
- }))+ # Apply statistics function to arm X and arm Y data |
||
| 304 | -18x | +116 | +9x |
- lgn <- h_recycle(x1 = if (is.null(names(x1))) {
+ s_x <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_x, ], .N_col = N_col_x), afun_args, s_args)) |
| 305 | -18x | +117 | +9x |
- paste("x1", seq_along(x1), sep = ".")
+ s_y <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_y, ], .N_col = N_col_y), afun_args, s_args)) |
| 306 | +118 |
- } else {
+
|
||
| 307 | -! | +|||
| 119 | +
- names(x1)+ # Get statistic name and row names |
|||
| 308 | -18x | +120 | +9x |
- }, n1 = if (is.null(names(n1))) {
+ stat <- ifelse("count_fraction" %in% names(s_x), "count_fraction", "unique")
|
| 309 | -18x | -
- paste("n1", seq_along(n1), sep = ".")
- |
- ||
| 310 | -+ | 121 | +9x |
- } else {
+ if ("flag_variables" %in% names(s_args)) {
|
| 311 | -! | +|||
| 122 | +1x |
- names(n1)+ var_nms <- s_args$flag_variables |
||
| 312 | -18x | +123 | +8x |
- }, x2 = if (is.null(names(x2))) {
+ } else if (!is.null(names(s_x[[stat]]))) {
|
| 313 | -18x | +124 | +2x |
- paste("x2", seq_along(x2), sep = ".")
+ var_nms <- names(s_x[[stat]]) |
| 314 | +125 |
- } else {
+ } else {
|
||
| 315 | -! | +|||
| 126 | +6x |
- names(x2)+ var_nms <- "" |
||
| 316 | -18x | +127 | +6x |
- }, n2 = if (is.null(names(n2))) {
+ s_x[[stat]] <- list(s_x[[stat]]) |
| 317 | -18x | +128 | +6x |
- paste("n2", seq_along(n2), sep = ".")
+ s_y[[stat]] <- list(s_y[[stat]]) |
| 318 | +129 |
- } else {
+ } |
||
| 319 | -! | +|||
| 130 | +
- names(n2)+ |
|||
| 320 | -18x | +|||
| 131 | +
- }, conf.level = conf.level, sides = sides, method = method)+ # Calculate risk difference for each row, repeated if multiple statistics in table |
|||
| 321 | -18x | +132 | +9x |
- xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
+ pct <- tail(strsplit(cur_split, "_")[[1]], 1) == "pct" |
| 322 | -126x | +133 | +9x |
- length(unique(x)) !=+ rd_ci <- rep(stat_propdiff_ci( |
| 323 | -126x | +134 | +9x |
- 1+ lapply(s_x[[stat]], `[`, 1), lapply(s_y[[stat]], `[`, 1), |
| 324 | -18x | +135 | +9x |
- })]), 1, paste, collapse = ":")+ N_col_x, N_col_y, |
| 325 | -18x | +136 | +9x |
- rownames(res) <- xn+ list_names = var_nms, |
| 326 | -18x | +137 | +9x |
- return(res)+ pct = pct |
| 327 | -+ | |||
| 138 | +9x |
- }+ ), max(1, length(.stats))) |
||
| 328 | +139 | |||
| 329 | -+ | |||
| 140 | +9x |
- #' @describeIn desctools_binom Compute confidence intervals for binomial proportions.+ in_rows(.list = rd_ci, .formats = "xx.x (xx.x - xx.x)", .indent_mods = .indent_mods) |
||
| 330 | +141 |
- #'+ } |
||
| 331 | +142 |
- #' @param x (`count`)\cr number of successes+ } |
| 332 | +1 |
- #' @param n (`count`)\cr number of trials+ #' Patient Counts for Laboratory Events (Worsen From Baseline) by Highest Grade Post-Baseline |
||
| 333 | +2 |
- #' @param conf.level (`proportion`)\cr confidence level, defaults to 0.95.+ #' |
||
| 334 | +3 |
- #' @param sides (`character`)\cr side of the confidence interval to compute. Must be one of `"two-sided"` (default),+ #' @description `r lifecycle::badge("stable")`
|
||
| 335 | +4 |
- #' `"left"`, or `"right"`.+ #' |
||
| 336 | +5 |
- #' @param method (`character`)\cr method to use. Can be one out of: `"wald"`, `"wilson"`, `"wilsoncc"`,+ #' Patient count and fraction for laboratory events (worsen from baseline) shift table. |
||
| 337 | +6 |
- #' `"agresti-coull"`, `"jeffreys"`, `"modified wilson"`, `"modified jeffreys"`, `"clopper-pearson"`, `"arcsine"`,+ #' |
||
| 338 | +7 |
- #' `"logit"`, `"witting"`, `"pratt"`, `"midp"`, `"lik"`, and `"blaker"`.+ #' @inheritParams argument_convention |
||
| 339 | +8 |
#' |
||
| 340 | +9 |
- #' @return A `matrix` with 3 columns containing:+ #' @seealso Relevant helper functions [h_adlb_worsen()] and [h_worsen_counter()] |
||
| 341 | +10 |
- #' * `est`: estimate of proportion difference.+ #' |
||
| 342 | +11 |
- #' * `lwr.ci`: lower end of the confidence interval.+ #' @name abnormal_by_worst_grade_worsen |
||
| 343 | +12 |
- #' * `upr.ci`: upper end of the confidence interval.+ NULL |
||
| 344 | +13 |
- #'+ |
||
| 345 | +14 |
- #' @keywords internal+ #' Helper Function to Prepare `ADLB` with Worst Labs |
||
| 346 | +15 |
- desctools_binomci <- function(x,+ #' |
||
| 347 | +16 |
- n,+ #' @description `r lifecycle::badge("stable")`
|
||
| 348 | +17 |
- conf.level = 0.95, # nolint+ #' |
||
| 349 | +18 |
- sides = c("two.sided", "left", "right"),
+ #' Helper function to prepare a `df` for generate the patient count shift table |
||
| 350 | +19 |
- method = c(+ #' |
||
| 351 | +20 |
- "wilson", "wald", "waldcc", "agresti-coull",+ #' @param adlb (`data.frame`)\cr `ADLB` dataframe |
||
| 352 | +21 |
- "jeffreys", "modified wilson", "wilsoncc", "modified jeffreys",+ #' @param worst_flag_low (named `vector`)\cr Worst low post-baseline lab grade flag variable |
||
| 353 | +22 |
- "clopper-pearson", "arcsine", "logit", "witting", "pratt",+ #' @param worst_flag_high (named `vector`)\cr Worst high post-baseline lab grade flag variable |
||
| 354 | +23 |
- "midp", "lik", "blaker"+ #' @param direction_var (`string`)\cr Direction variable specifying the direction of the shift table of interest. |
||
| 355 | +24 |
- ),+ #' Only lab records flagged by `L`, `H` or `B` are included in the shift table. |
||
| 356 | +25 |
- rand = 123,+ #' * `L`: low direction only |
||
| 357 | +26 |
- tol = 1e-05) {
- |
- ||
| 358 | -24x | -
- if (missing(method)) {
- |
- ||
| 359 | -1x | -
- method <- "wilson"+ #' * `H`: high direction only |
||
| 360 | +27 |
- }- |
- ||
| 361 | -24x | -
- if (missing(sides)) {
- |
- ||
| 362 | -23x | -
- sides <- "two.sided"+ #' * `B`: both low and high directions |
||
| 363 | +28 |
- }- |
- ||
| 364 | -24x | -
- iBinomCI <- function(x, n, conf.level = 0.95, sides = c( # nolint- |
- ||
| 365 | -24x | -
- "two.sided",- |
- ||
| 366 | -24x | -
- "left", "right"- |
- ||
| 367 | -24x | -
- ), method = c(- |
- ||
| 368 | -24x | -
- "wilson", "wilsoncc", "wald",- |
- ||
| 369 | -24x | -
- "waldcc", "agresti-coull", "jeffreys", "modified wilson",+ #' |
||
| 370 | -24x | +|||
| 29 | +
- "modified jeffreys", "clopper-pearson", "arcsine", "logit",+ #' @return `h_adlb_worsen()` returns the `adlb` `data.frame` containing only the |
|||
| 371 | -24x | +|||
| 30 | +
- "witting", "pratt", "midp", "lik", "blaker"+ #' worst labs specified according to `worst_flag_low` or `worst_flag_high` for the |
|||
| 372 | -24x | +|||
| 31 | +
- ), rand = 123,+ #' direction specified according to `direction_var`. For instance, for a lab that is |
|||
| 373 | -24x | +|||
| 32 | +
- tol = 1e-05) {
+ #' needed for the low direction only, only records flagged by `worst_flag_low` are |
|||
| 374 | -24x | +|||
| 33 | +
- if (length(x) != 1) {
+ #' selected. For a lab that is needed for both low and high directions, the worst |
|||
| 375 | -! | +|||
| 34 | +
- stop("'x' has to be of length 1 (number of successes)")
+ #' low records are selected for the low direction, and the worst high record are selected |
|||
| 376 | +35 |
- }+ #' for the high direction. |
||
| 377 | -24x | +|||
| 36 | +
- if (length(n) != 1) {
+ #' |
|||
| 378 | -! | +|||
| 37 | +
- stop("'n' has to be of length 1 (number of trials)")
+ #' @seealso [abnormal_by_worst_grade_worsen] |
|||
| 379 | +38 |
- }+ #' |
||
| 380 | -24x | +|||
| 39 | +
- if (length(conf.level) != 1) {
+ #' @examples |
|||
| 381 | -! | +|||
| 40 | +
- stop("'conf.level' has to be of length 1 (confidence level)")
+ #' library(dplyr) |
|||
| 382 | +41 |
- }+ #' |
||
| 383 | -24x | +|||
| 42 | +
- if (conf.level < 0.5 || conf.level > 1) {
+ #' # The direction variable, GRADDR, is based on metadata |
|||
| 384 | -! | +|||
| 43 | +
- stop("'conf.level' has to be in [0.5, 1]")
+ #' adlb <- tern_ex_adlb %>% |
|||
| 385 | +44 |
- }+ #' mutate( |
||
| 386 | -24x | +|||
| 45 | +
- sides <- match.arg(sides, choices = c(+ #' GRADDR = case_when( |
|||
| 387 | -24x | +|||
| 46 | +
- "two.sided", "left",+ #' PARAMCD == "ALT" ~ "B", |
|||
| 388 | -24x | +|||
| 47 | +
- "right"+ #' PARAMCD == "CRP" ~ "L", |
|||
| 389 | -24x | +|||
| 48 | +
- ), several.ok = FALSE)+ #' PARAMCD == "IGA" ~ "H" |
|||
| 390 | -24x | +|||
| 49 | +
- if (sides != "two.sided") {
+ #' ) |
|||
| 391 | -1x | +|||
| 50 | +
- conf.level <- 1 - 2 * (1 - conf.level) # nolint+ #' ) %>% |
|||
| 392 | +51 |
- }+ #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "") |
||
| 393 | -24x | +|||
| 52 | +
- alpha <- 1 - conf.level+ #' |
|||
| 394 | -24x | +|||
| 53 | +
- kappa <- stats::qnorm(1 - alpha / 2)+ #' df <- h_adlb_worsen( |
|||
| 395 | -24x | +|||
| 54 | +
- p_hat <- x / n+ #' adlb, |
|||
| 396 | -24x | +|||
| 55 | +
- q_hat <- 1 - p_hat+ #' worst_flag_low = c("WGRLOFL" = "Y"),
|
|||
| 397 | -24x | +|||
| 56 | +
- est <- p_hat+ #' worst_flag_high = c("WGRHIFL" = "Y"),
|
|||
| 398 | -24x | +|||
| 57 | +
- switch(match.arg(arg = method, choices = c(+ #' direction_var = "GRADDR" |
|||
| 399 | -24x | +|||
| 58 | +
- "wilson",+ #' ) |
|||
| 400 | -24x | +|||
| 59 | +
- "wald", "waldcc", "wilsoncc", "agresti-coull", "jeffreys",+ #' |
|||
| 401 | -24x | +|||
| 60 | +
- "modified wilson", "modified jeffreys", "clopper-pearson",+ #' @export |
|||
| 402 | -24x | +|||
| 61 | +
- "arcsine", "logit", "witting", "pratt", "midp", "lik",+ h_adlb_worsen <- function(adlb, |
|||
| 403 | -24x | +|||
| 62 | +
- "blaker"+ worst_flag_low = NULL, |
|||
| 404 | +63 |
- )),+ worst_flag_high = NULL, |
||
| 405 | -24x | +|||
| 64 | +
- wald = {
+ direction_var) {
|
|||
| 406 | -1x | +65 | +5x |
- term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n)+ checkmate::assert_string(direction_var) |
| 407 | -1x | +66 | +5x |
- ci_lwr <- max(0, p_hat - term2)+ checkmate::assert_subset(as.character(unique(adlb[[direction_var]])), c("B", "L", "H"))
|
| 408 | -1x | +67 | +5x |
- ci_upr <- min(1, p_hat + term2)+ assert_df_with_variables(adlb, list("Col" = direction_var))
|
| 409 | +68 |
- },- |
- ||
| 410 | -24x | -
- waldcc = {
- |
- ||
| 411 | -1x | -
- term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n)- |
- ||
| 412 | -1x | -
- term2 <- term2 + 1 / (2 * n)+ |
||
| 413 | -1x | +69 | +5x |
- ci_lwr <- max(0, p_hat - term2)+ if (any(unique(adlb[[direction_var]]) == "H")) {
|
| 414 | -1x | +70 | +4x |
- ci_upr <- min(1, p_hat + term2)+ assert_df_with_variables(adlb, list("High" = names(worst_flag_high)))
|
| 415 | +71 |
- },- |
- ||
| 416 | -24x | -
- wilson = {
- |
- ||
| 417 | -6x | -
- term1 <- (x + kappa^2 / 2) / (n + kappa^2)+ } |
||
| 418 | -6x | +|||
| 72 | +
- term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat *+ |
|||
| 419 | -6x | +73 | +5x |
- q_hat + kappa^2 / (4 * n))+ if (any(unique(adlb[[direction_var]]) == "L")) {
|
| 420 | -6x | +74 | +4x |
- ci_lwr <- max(0, term1 - term2)+ assert_df_with_variables(adlb, list("Low" = names(worst_flag_low)))
|
| 421 | -6x | +|||
| 75 | +
- ci_upr <- min(1, term1 + term2)+ } |
|||
| 422 | +76 |
- },+ |
||
| 423 | -24x | +77 | +5x |
- wilsoncc = {
+ if (any(unique(adlb[[direction_var]]) == "B")) {
|
| 424 | +78 | 3x |
- lci <- (2 * x + kappa^2 - 1 - kappa * sqrt(kappa^2 -+ assert_df_with_variables( |
|
| 425 | +79 | 3x |
- 2 - 1 / n + 4 * p_hat * (n * q_hat + 1))) / (2 *+ adlb, |
|
| 426 | +80 | 3x |
- (n + kappa^2))+ list( |
|
| 427 | +81 | 3x |
- uci <- (2 * x + kappa^2 + 1 + kappa * sqrt(kappa^2 ++ "Low" = names(worst_flag_low), |
|
| 428 | +82 | 3x |
- 2 - 1 / n + 4 * p_hat * (n * q_hat - 1))) / (2 *+ "High" = names(worst_flag_high) |
|
| 429 | -3x | +|||
| 83 | +
- (n + kappa^2))+ ) |
|||
| 430 | -3x | +|||
| 84 | +
- ci_lwr <- max(0, ifelse(p_hat == 0, 0, lci))+ ) |
|||
| 431 | -3x | +|||
| 85 | +
- ci_upr <- min(1, ifelse(p_hat == 1, 1, uci))+ } |
|||
| 432 | +86 | ++ | + + | +|
| 87 |
- },+ # extract patients with worst post-baseline lab, either low or high or both |
|||
| 433 | -24x | +88 | +5x |
- `agresti-coull` = {
+ worst_flag <- c(worst_flag_low, worst_flag_high) |
| 434 | -1x | +89 | +5x |
- x_tilde <- x + kappa^2 / 2+ col_names <- names(worst_flag) |
| 435 | -1x | +90 | +5x |
- n_tilde <- n + kappa^2+ filter_values <- worst_flag |
| 436 | -1x | +91 | +5x |
- p_tilde <- x_tilde / n_tilde+ temp <- Map( |
| 437 | -1x | +92 | +5x |
- q_tilde <- 1 - p_tilde+ function(x, y) which(adlb[[x]] == y), |
| 438 | -1x | +93 | +5x |
- est <- p_tilde+ col_names, |
| 439 | -1x | +94 | +5x |
- term2 <- kappa * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)+ filter_values |
| 440 | -1x | +|||
| 95 | +
- ci_lwr <- max(0, p_tilde - term2)+ ) |
|||
| 441 | -1x | +96 | +5x |
- ci_upr <- min(1, p_tilde + term2)+ position_satisfy_filters <- Reduce(union, temp) |
| 442 | +97 |
- },+ |
||
| 443 | -24x | +|||
| 98 | +
- jeffreys = {
+ # select variables of interest |
|||
| 444 | -1x | +99 | +5x |
- if (x == 0) {
+ adlb_f <- adlb[position_satisfy_filters, ] |
| 445 | -! | +|||
| 100 | +
- ci_lwr <- 0+ |
|||
| 446 | +101 |
- } else {
+ # generate subsets for different directionality |
||
| 447 | -1x | +102 | +5x |
- ci_lwr <- stats::qbeta(+ adlb_f_h <- adlb_f[which(adlb_f[[direction_var]] == "H"), ] |
| 448 | -1x | +103 | +5x |
- alpha / 2,+ adlb_f_l <- adlb_f[which(adlb_f[[direction_var]] == "L"), ] |
| 449 | -1x | +104 | +5x |
- x + 0.5, n - x + 0.5+ adlb_f_b <- adlb_f[which(adlb_f[[direction_var]] == "B"), ] |
| 450 | +105 |
- )+ |
||
| 451 | +106 |
- }+ # for labs requiring both high and low, data is duplicated and will be stacked on top of each other |
||
| 452 | -1x | +107 | +5x |
- if (x == n) {
+ adlb_f_b_h <- adlb_f_b |
| 453 | -! | +|||
| 108 | +5x |
- ci_upr <- 1+ adlb_f_b_l <- adlb_f_b |
||
| 454 | +109 |
- } else {
+
|
||
| 455 | -1x | +|||
| 110 | +
- ci_upr <- stats::qbeta(1 -+ # extract data with worst lab |
|||
| 456 | -1x | +111 | +5x |
- alpha / 2, x + 0.5, n - x + 0.5)+ if (!is.null(worst_flag_high) && !is.null(worst_flag_low)) {
|
| 457 | +112 |
- }+ # change H to High, L to Low |
||
| 458 | -+ | |||
| 113 | +3x |
- },+ adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
|
||
| 459 | -24x | +114 | +3x |
- `modified wilson` = {
+ adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
|
| 460 | -1x | +|||
| 115 | +
- term1 <- (x + kappa^2 / 2) / (n + kappa^2)+ |
|||
| 461 | -1x | +|||
| 116 | +
- term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat *+ # change, B to High and Low |
|||
| 462 | -1x | +117 | +3x |
- q_hat + kappa^2 / (4 * n))+ adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
|
| 463 | -1x | +118 | +3x |
- if ((n <= 50 & x %in% c(1, 2)) | (n >= 51 & x %in%+ adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
|
| 464 | -1x | +|||
| 119 | +
- c(1:3))) {
+
|
|||
| 465 | -! | +|||
| 120 | +3x |
- ci_lwr <- 0.5 * stats::qchisq(alpha, 2 *+ adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ] |
||
| 466 | -! | +|||
| 121 | +3x |
- x) / n+ adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ] |
||
| 467 | -+ | |||
| 122 | +3x |
- } else {
+ adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ] |
||
| 468 | -1x | +123 | +3x |
- ci_lwr <- max(0, term1 - term2)+ adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ] |
| 469 | +124 |
- }+ |
||
| 470 | -1x | +125 | +3x |
- if ((n <= 50 & x %in% c(n - 1, n - 2)) | (n >= 51 &+ out <- rbind(adlb_out_h, adlb_out_b_h, adlb_out_l, adlb_out_b_l) |
| 471 | -1x | -
- x %in% c(n - (1:3)))) {
- |
- ||
| 472 | -! | -
- ci_upr <- 1 - 0.5 * stats::qchisq(- |
- ||
| 473 | -! | +126 | +2x |
- alpha,+ } else if (!is.null(worst_flag_high)) {
|
| 474 | -! | +|||
| 127 | +1x |
- 2 * (n - x)+ adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
|
||
| 475 | -! | +|||
| 128 | +1x |
- ) / n+ adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
|
||
| 476 | +129 |
- } else {
+
|
||
| 477 | +130 | 1x |
- ci_upr <- min(1, term1 ++ adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ] |
|
| 478 | +131 | 1x |
- term2)+ adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ] |
|
| 479 | +132 |
- }+ |
||
| 480 | -+ | |||
| 133 | +1x |
- },+ out <- rbind(adlb_out_h, adlb_out_b_h) |
||
| 481 | -24x | +134 | +1x |
- `modified jeffreys` = {
+ } else if (!is.null(worst_flag_low)) {
|
| 482 | +135 | 1x |
- if (x == n) {
+ adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
|
|
| 483 | -! | +|||
| 136 | +1x |
- ci_lwr <- (alpha / 2)^(1 / n)+ adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
|
||
| 484 | +137 |
- } else {
+
|
||
| 485 | +138 | 1x |
- if (x <= 1) {
+ adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ] |
|
| 486 | -! | +|||
| 139 | +1x |
- ci_lwr <- 0+ adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ] |
||
| 487 | +140 |
- } else {
+
|
||
| 488 | +141 | 1x |
- ci_lwr <- stats::qbeta(+ out <- rbind(adlb_out_l, adlb_out_b_l) |
|
| 489 | -1x | +|||
| 142 | +
- alpha / 2,+ } |
|||
| 490 | -1x | +|||
| 143 | +
- x + 0.5, n - x + 0.5+ |
|||
| 491 | +144 |
- )+ # label |
||
| 492 | -+ | |||
| 145 | +5x |
- }+ formatters::var_labels(out) <- formatters::var_labels(adlb_f, fill = FALSE) |
||
| 493 | +146 |
- }+ # NA |
||
| 494 | -1x | +147 | +5x |
- if (x == 0) {
+ out |
| 495 | -! | +|||
| 148 | +
- ci_upr <- 1 - (alpha / 2)^(1 / n)+ } |
|||
| 496 | +149 |
- } else {
+
|
||
| 497 | -1x | +|||
| 150 | +
- if (x >= n - 1) {
+ #' Helper Function to Analyze Patients for [s_count_abnormal_lab_worsen_by_baseline()] |
|||
| 498 | -! | +|||
| 151 | +
- ci_upr <- 1+ #' |
|||
| 499 | +152 |
- } else {
+ #' @description `r lifecycle::badge("stable")`
|
||
| 500 | -1x | +|||
| 153 | +
- ci_upr <- stats::qbeta(1 -+ #' |
|||
| 501 | -1x | +|||
| 154 | +
- alpha / 2, x + 0.5, n - x + 0.5)+ #' Helper function to count the number of patients and the fraction of patients according to |
|||
| 502 | +155 |
- }+ #' highest post-baseline lab grade variable `.var`, baseline lab grade variable `baseline_var`, |
||
| 503 | +156 |
- }+ #' and the direction of interest specified in `direction_var`. |
||
| 504 | +157 |
- },+ #' |
||
| 505 | -24x | +|||
| 158 | +
- `clopper-pearson` = {
+ #' @inheritParams argument_convention |
|||
| 506 | -1x | +|||
| 159 | +
- ci_lwr <- stats::qbeta(alpha / 2, x, n - x + 1)+ #' @inheritParams h_adlb_worsen |
|||
| 507 | -1x | +|||
| 160 | +
- ci_upr <- stats::qbeta(1 - alpha / 2, x + 1, n - x)+ #' @param baseline_var (`string`)\cr baseline lab grade variable |
|||
| 508 | +161 |
- },+ #' |
||
| 509 | -24x | +|||
| 162 | +
- arcsine = {
+ #' @return `h_worsen_counter()` returns the counts and fraction of patients |
|||
| 510 | -1x | +|||
| 163 | +
- p_tilde <- (x + 0.375) / (n + 0.75)+ #' whose worst post-baseline lab grades are worse than their baseline grades, for |
|||
| 511 | -1x | +|||
| 164 | +
- est <- p_tilde+ #' post-baseline worst grades "1", "2", "3", "4" and "Any". |
|||
| 512 | -1x | +|||
| 165 | +
- ci_lwr <- sin(asin(sqrt(p_tilde)) - 0.5 * kappa / sqrt(n))^2+ #' |
|||
| 513 | -1x | +|||
| 166 | +
- ci_upr <- sin(asin(sqrt(p_tilde)) + 0.5 * kappa / sqrt(n))^2+ #' @seealso [abnormal_by_worst_grade_worsen] |
|||
| 514 | +167 |
- },+ #' |
||
| 515 | -24x | +|||
| 168 | +
- logit = {
+ #' @examples |
|||
| 516 | -1x | +|||
| 169 | +
- lambda_hat <- log(x / (n - x))+ #' library(dplyr) |
|||
| 517 | -1x | +|||
| 170 | +
- V_hat <- n / (x * (n - x)) # nolint+ #' |
|||
| 518 | -1x | +|||
| 171 | +
- lambda_lower <- lambda_hat - kappa * sqrt(V_hat)+ #' # The direction variable, GRADDR, is based on metadata |
|||
| 519 | -1x | +|||
| 172 | +
- lambda_upper <- lambda_hat + kappa * sqrt(V_hat)+ #' adlb <- tern_ex_adlb %>% |
|||
| 520 | -1x | +|||
| 173 | +
- ci_lwr <- exp(lambda_lower) / (1 + exp(lambda_lower))+ #' mutate( |
|||
| 521 | -1x | +|||
| 174 | +
- ci_upr <- exp(lambda_upper) / (1 + exp(lambda_upper))+ #' GRADDR = case_when( |
|||
| 522 | +175 |
- },+ #' PARAMCD == "ALT" ~ "B", |
||
| 523 | -24x | +|||
| 176 | +
- witting = {
+ #' PARAMCD == "CRP" ~ "L", |
|||
| 524 | -1x | +|||
| 177 | +
- set.seed(rand)+ #' PARAMCD == "IGA" ~ "H" |
|||
| 525 | -1x | +|||
| 178 | +
- x_tilde <- x + stats::runif(1, min = 0, max = 1)+ #' ) |
|||
| 526 | -1x | +|||
| 179 | +
- pbinom_abscont <- function(q, size, prob) {
+ #' ) %>% |
|||
| 527 | -22x | +|||
| 180 | +
- v <- trunc(q)+ #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "") |
|||
| 528 | -22x | +|||
| 181 | +
- term1 <- stats::pbinom(v - 1, size = size, prob = prob)+ #' |
|||
| 529 | -22x | +|||
| 182 | +
- term2 <- (q - v) * stats::dbinom(v, size = size, prob = prob)+ #' df <- h_adlb_worsen( |
|||
| 530 | -22x | +|||
| 183 | +
- return(term1 + term2)+ #' adlb, |
|||
| 531 | +184 |
- }+ #' worst_flag_low = c("WGRLOFL" = "Y"),
|
||
| 532 | -1x | +|||
| 185 | +
- qbinom_abscont <- function(p, size, x) {
+ #' worst_flag_high = c("WGRHIFL" = "Y"),
|
|||
| 533 | -2x | +|||
| 186 | +
- fun <- function(prob, size, x, p) {
+ #' direction_var = "GRADDR" |
|||
| 534 | -22x | +|||
| 187 | +
- pbinom_abscont(x, size, prob) - p+ #' ) |
|||
| 535 | +188 |
- }+ #' |
||
| 536 | -2x | +|||
| 189 | +
- stats::uniroot(fun,+ #' # `h_worsen_counter` |
|||
| 537 | -2x | +|||
| 190 | +
- interval = c(0, 1), size = size,+ #' h_worsen_counter( |
|||
| 538 | -2x | +|||
| 191 | +
- x = x, p = p+ #' df %>% filter(PARAMCD == "CRP" & GRADDR == "Low"), |
|||
| 539 | -2x | +|||
| 192 | +
- )$root+ #' id = "USUBJID", |
|||
| 540 | +193 |
- }+ #' .var = "ATOXGR", |
||
| 541 | -1x | +|||
| 194 | +
- ci_lwr <- qbinom_abscont(1 - alpha, size = n, x = x_tilde)+ #' baseline_var = "BTOXGR", |
|||
| 542 | -1x | +|||
| 195 | +
- ci_upr <- qbinom_abscont(alpha, size = n, x = x_tilde)+ #' direction_var = "GRADDR" |
|||
| 543 | +196 |
- },+ #' ) |
||
| 544 | -24x | +|||
| 197 | +
- pratt = {
+ #' |
|||
| 545 | -1x | +|||
| 198 | +
- if (x == 0) {
+ #' @export |
|||
| 546 | -! | +|||
| 199 | +
- ci_lwr <- 0+ h_worsen_counter <- function(df, id, .var, baseline_var, direction_var) {
|
|||
| 547 | -! | +|||
| 200 | +17x |
- ci_upr <- 1 - alpha^(1 / n)+ checkmate::assert_string(id) |
||
| 548 | -1x | +201 | +17x |
- } else if (x == 1) {
+ checkmate::assert_string(.var) |
| 549 | -! | +|||
| 202 | +17x |
- ci_lwr <- 1 - (1 - alpha / 2)^(1 / n)+ checkmate::assert_string(baseline_var) |
||
| 550 | -! | +|||
| 203 | +17x |
- ci_upr <- 1 - (alpha / 2)^(1 / n)+ checkmate::assert_scalar(unique(df[[direction_var]])) |
||
| 551 | -1x | +204 | +17x |
- } else if (x == (n - 1)) {
+ checkmate::assert_subset(unique(df[[direction_var]]), c("High", "Low"))
|
| 552 | -! | +|||
| 205 | +17x |
- ci_lwr <- (alpha / 2)^(1 / n)+ assert_df_with_variables(df, list(val = c(id, .var, baseline_var, direction_var))) |
||
| 553 | -! | +|||
| 206 | +
- ci_upr <- (1 - alpha / 2)^(1 / n)+ |
|||
| 554 | -1x | +|||
| 207 | +
- } else if (x == n) {
+ # remove post-baseline missing |
|||
| 555 | -! | +|||
| 208 | +17x |
- ci_lwr <- alpha^(1 / n)+ df <- df[df[[.var]] != "<Missing>", ] |
||
| 556 | -! | +|||
| 209 | +
- ci_upr <- 1+ |
|||
| 557 | +210 |
- } else {
+ # obtain directionality |
||
| 558 | -1x | +211 | +17x |
- z <- stats::qnorm(1 - alpha / 2)+ direction <- unique(df[[direction_var]]) |
| 559 | -1x | +|||
| 212 | +
- A <- ((x + 1) / (n - x))^2 # nolint+ |
|||
| 560 | -1x | +213 | +17x |
- B <- 81 * (x + 1) * (n - x) - 9 * n - 8 # nolint+ if (direction == "Low") {
|
| 561 | -1x | +214 | +10x |
- C <- (0 - 3) * z * sqrt(9 * (x + 1) * (n - x) * (9 * n + 5 - z^2) + n + 1) # nolint+ grade <- -1:-4 |
| 562 | -1x | +215 | +10x |
- D <- 81 * (x + 1)^2 - 9 * (x + 1) * (2 + z^2) + 1 # nolint+ worst_grade <- -4 |
| 563 | -1x | +216 | +7x |
- E <- 1 + A * ((B + C) / D)^3 # nolint+ } else if (direction == "High") {
|
| 564 | -1x | +217 | +7x |
- ci_upr <- 1 / E+ grade <- 1:4 |
| 565 | -1x | +218 | +7x |
- A <- (x / (n - x - 1))^2 # nolint+ worst_grade <- 4 |
| 566 | -1x | +|||
| 219 | +
- B <- 81 * x * (n - x - 1) - 9 * n - 8 # nolint+ } |
|||
| 567 | -1x | +|||
| 220 | +
- C <- 3 * z * sqrt(9 * x * (n - x - 1) * (9 * n + 5 - z^2) + n + 1) # nolint+ |
|||
| 568 | -1x | +221 | +17x |
- D <- 81 * x^2 - 9 * x * (2 + z^2) + 1 # nolint+ if (nrow(df) > 0) {
|
| 569 | -1x | +222 | +17x |
- E <- 1 + A * ((B + C) / D)^3 # nolint+ by_grade <- lapply(grade, function(i) {
|
| 570 | -1x | +|||
| 223 | +
- ci_lwr <- 1 / E+ # filter baseline values that is less than i or <Missing> |
|||
| 571 | -+ | |||
| 224 | +68x |
- }+ df_temp <- df[df[[baseline_var]] %in% c((i + sign(i) * -1):(-1 * worst_grade), "<Missing>"), ] |
||
| 572 | +225 |
- },+ # num: number of patients with post-baseline worst lab equal to i |
||
| 573 | -24x | +226 | +68x |
- midp = {
+ num <- length(unique(df_temp[df_temp[[.var]] %in% i, id, drop = TRUE])) |
| 574 | -1x | +|||
| 227 | +
- f_low <- function(pi, x, n) {
+ # denom: number of patients with baseline values less than i or <missing> and post-baseline in the same direction |
|||
| 575 | -12x | +228 | +68x |
- 1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x,+ denom <- length(unique(df_temp[[id]])) |
| 576 | -12x | -
- size = n, prob = pi, lower.tail = FALSE- |
- ||
| 577 | -+ | 229 | +68x |
- ) -+ rm(df_temp) |
| 578 | -12x | +230 | +68x |
- (1 - conf.level) / 2+ c(num = num, denom = denom) |
| 579 | +231 |
- }+ }) |
||
| 580 | -1x | +|||
| 232 | +
- f_up <- function(pi, x, n) {
+ } else {
|
|||
| 581 | -12x | +|||
| 233 | +! |
- 1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x -+ by_grade <- lapply(1, function(i) {
|
||
| 582 | -12x | +|||
| 234 | +! |
- 1, size = n, prob = pi) - (1 - conf.level) / 2+ c(num = 0, denom = 0) |
||
| 583 | +235 |
- }+ }) |
||
| 584 | -1x | +|||
| 236 | +
- ci_lwr <- 0+ } |
|||
| 585 | -1x | +|||
| 237 | +
- ci_upr <- 1+ |
|||
| 586 | -1x | +238 | +17x |
- if (x != 0) {
+ names(by_grade) <- as.character(seq_along(by_grade)) |
| 587 | -1x | +|||
| 239 | +
- ci_lwr <- stats::uniroot(f_low,+ |
|||
| 588 | -1x | +|||
| 240 | +
- interval = c(0, p_hat),+ # baseline grade less 4 or missing |
|||
| 589 | -1x | +241 | +17x |
- x = x, n = n+ df_temp <- df[!df[[baseline_var]] %in% worst_grade, ] |
| 590 | -1x | +|||
| 242 | +
- )$root+ |
|||
| 591 | +243 |
- }+ # denom: number of patients with baseline values less than 4 or <missing> and post-baseline in the same direction |
||
| 592 | -1x | +244 | +17x |
- if (x != n) {
+ denom <- length(unique(df_temp[, id, drop = TRUE])) |
| 593 | -1x | +|||
| 245 | +
- ci_upr <- stats::uniroot(f_up, interval = c(+ |
|||
| 594 | -1x | +|||
| 246 | +
- p_hat,+ # condition 1: missing baseline and in the direction of abnormality |
|||
| 595 | -1x | +247 | +17x |
- 1+ con1 <- which(df_temp[[baseline_var]] == "<Missing>" & df_temp[[.var]] %in% grade) |
| 596 | -1x | +248 | +17x |
- ), x = x, n = n)$root+ df_temp_nm <- df_temp[which(df_temp[[baseline_var]] != "<Missing>" & df_temp[[.var]] %in% grade), ] |
| 597 | +249 |
- }+ |
||
| 598 | +250 |
- },+ # condition 2: if post-baseline values are present then post-baseline values must be worse than baseline |
||
| 599 | -24x | +251 | +17x |
- lik = {
+ if (direction == "Low") {
|
| 600 | -2x | +252 | +10x |
- ci_lwr <- 0+ con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) < as.numeric(as.character(df_temp_nm[[baseline_var]]))) |
| 601 | -2x | +|||
| 253 | +
- ci_upr <- 1+ } else {
|
|||
| 602 | -2x | +254 | +7x |
- z <- stats::qnorm(1 - alpha * 0.5)+ con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) > as.numeric(as.character(df_temp_nm[[baseline_var]]))) |
| 603 | -2x | +|||
| 255 | +
- tol <- .Machine$double.eps^0.5+ } |
|||
| 604 | -2x | +|||
| 256 | +
- BinDev <- function(y, x, mu, wt, bound = 0, tol = .Machine$double.eps^0.5, # nolint+ |
|||
| 605 | +257 |
- ...) {
+ # number of patients satisfy either conditions 1 or 2 |
||
| 606 | -40x | +258 | +17x |
- ll_y <- ifelse(y %in% c(0, 1), 0, stats::dbinom(x, wt,+ num <- length(unique(df_temp[union(con1, con2), id, drop = TRUE])) |
| 607 | -40x | +|||
| 259 | +
- y,+ |
|||
| 608 | -40x | +260 | +17x |
- log = TRUE+ list(fraction = c(by_grade, list("Any" = c(num = num, denom = denom))))
|
| 609 | +261 |
- ))+ } |
||
| 610 | -40x | +|||
| 262 | +
- ll_mu <- ifelse(mu %in% c(0, 1), 0, stats::dbinom(x,+ |
|||
| 611 | -40x | +|||
| 263 | +
- wt, mu,+ #' @describeIn abnormal_by_worst_grade_worsen Statistics function for patients whose worst post-baseline |
|||
| 612 | -40x | +|||
| 264 | +
- log = TRUE+ #' lab grades are worse than their baseline grades. |
|||
| 613 | +265 |
- ))+ #' |
||
| 614 | -40x | +|||
| 266 | +
- res <- ifelse(abs(y - mu) < tol, 0, sign(y -+ #' @param variables (named `list` of `string`)\cr list of additional analysis variables including: |
|||
| 615 | -40x | +|||
| 267 | +
- mu) * sqrt(-2 * (ll_y - ll_mu)))+ #' * `id` (`string`)\cr subject variable name. |
|||
| 616 | -40x | +|||
| 268 | +
- return(res - bound)+ #' * `baseline_var` (`string`)\cr name of the data column containing baseline toxicity variable. |
|||
| 617 | +269 |
- }+ #' * `direction_var` (`string`)\cr see `direction_var` for more details. |
||
| 618 | -2x | +|||
| 270 | +
- if (x != 0 && tol < p_hat) {
+ #' |
|||
| 619 | -2x | +|||
| 271 | +
- ci_lwr <- if (BinDev(+ #' @return |
|||
| 620 | -2x | +|||
| 272 | +
- tol, x, p_hat, n, -z,+ #' * `s_count_abnormal_lab_worsen_by_baseline()` returns the counts and fraction of patients whose worst |
|||
| 621 | -2x | +|||
| 273 | +
- tol+ #' post-baseline lab grades are worse than their baseline grades, for post-baseline worst grades |
|||
| 622 | -2x | +|||
| 274 | +
- ) <= 0) {
+ #' "1", "2", "3", "4" and "Any". |
|||
| 623 | -2x | +|||
| 275 | +
- stats::uniroot(+ #' |
|||
| 624 | -2x | +|||
| 276 | +
- f = BinDev, interval = c(tol, if (p_hat <+ #' @examples |
|||
| 625 | -2x | +|||
| 277 | +
- tol || p_hat == 1) {
+ #' library(dplyr) |
|||
| 626 | -! | +|||
| 278 | +
- 1 - tol+ #' |
|||
| 627 | +279 |
- } else {
+ #' # The direction variable, GRADDR, is based on metadata |
||
| 628 | -2x | +|||
| 280 | +
- p_hat+ #' adlb <- tern_ex_adlb %>% |
|||
| 629 | -2x | +|||
| 281 | +
- }), bound = -z,+ #' mutate( |
|||
| 630 | -2x | +|||
| 282 | +
- x = x, mu = p_hat, wt = n+ #' GRADDR = case_when( |
|||
| 631 | -2x | +|||
| 283 | +
- )$root+ #' PARAMCD == "ALT" ~ "B", |
|||
| 632 | +284 |
- }+ #' PARAMCD == "CRP" ~ "L", |
||
| 633 | +285 |
- }+ #' PARAMCD == "IGA" ~ "H" |
||
| 634 | -2x | +|||
| 286 | +
- if (x != n && p_hat < (1 - tol)) {
+ #' ) |
|||
| 635 | -2x | +|||
| 287 | +
- ci_upr <- if (BinDev(y = 1 - tol, x = x, mu = ifelse(p_hat >+ #' ) %>% |
|||
| 636 | -2x | +|||
| 288 | +
- 1 - tol, tol, p_hat), wt = n, bound = z, tol = tol) <+ #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "") |
|||
| 637 | -2x | +|||
| 289 | +
- 0) {
+ #' |
|||
| 638 | -! | +|||
| 290 | +
- ci_lwr <- if (BinDev(+ #' df <- h_adlb_worsen( |
|||
| 639 | -! | +|||
| 291 | +
- tol, x, if (p_hat <+ #' adlb, |
|||
| 640 | -! | +|||
| 292 | +
- tol || p_hat == 1) {
+ #' worst_flag_low = c("WGRLOFL" = "Y"),
|
|||
| 641 | -! | +|||
| 293 | +
- 1 - tol+ #' worst_flag_high = c("WGRHIFL" = "Y"),
|
|||
| 642 | +294 |
- } else {
+ #' direction_var = "GRADDR" |
||
| 643 | -! | +|||
| 295 | +
- p_hat+ #' ) |
|||
| 644 | -! | +|||
| 296 | +
- }, n,+ #' |
|||
| 645 | -! | +|||
| 297 | +
- -z, tol+ #' @keywords internal |
|||
| 646 | -! | +|||
| 298 | +
- ) <= 0) {
+ s_count_abnormal_lab_worsen_by_baseline <- function(df, # nolint |
|||
| 647 | -! | +|||
| 299 | +
- stats::uniroot(+ .var = "ATOXGR", |
|||
| 648 | -! | +|||
| 300 | +
- f = BinDev, interval = c(tol, p_hat),+ variables = list( |
|||
| 649 | -! | +|||
| 301 | +
- bound = -z, x = x, mu = p_hat, wt = n+ id = "USUBJID", |
|||
| 650 | -! | +|||
| 302 | +
- )$root+ baseline_var = "BTOXGR", |
|||
| 651 | +303 |
- }+ direction_var = "GRADDR" |
||
| 652 | +304 |
- } else {
+ )) {
|
||
| 653 | -2x | +305 | +1x |
- stats::uniroot(+ checkmate::assert_string(.var) |
| 654 | -2x | +306 | +1x |
- f = BinDev, interval = c(if (p_hat >+ checkmate::assert_set_equal(names(variables), c("id", "baseline_var", "direction_var"))
|
| 655 | -2x | +307 | +1x |
- 1 - tol) {
+ checkmate::assert_string(variables$id) |
| 656 | -! | +|||
| 308 | +1x |
- tol+ checkmate::assert_string(variables$baseline_var) |
||
| 657 | -+ | |||
| 309 | +1x |
- } else {
+ checkmate::assert_string(variables$direction_var) |
||
| 658 | -2x | +310 | +1x |
- p_hat+ assert_df_with_variables(df, c(aval = .var, variables[1:3])) |
| 659 | -2x | +311 | +1x |
- }, 1 - tol), bound = z,+ assert_list_of_variables(variables) |
| 660 | -2x | +|||
| 312 | +
- x = x, mu = p_hat, wt = n+ |
|||
| 661 | -2x | +313 | +1x |
- )$root+ h_worsen_counter(df, variables$id, .var, variables$baseline_var, variables$direction_var) |
| 662 | +314 |
- }+ } |
||
| 663 | +315 |
- }+ |
||
| 664 | +316 |
- },+ |
||
| 665 | -24x | +|||
| 317 | +
- blaker = {
+ #' @describeIn abnormal_by_worst_grade_worsen Formatted analysis function which is used as `afun` |
|||
| 666 | -1x | +|||
| 318 | +
- acceptbin <- function(x, n, p) {
+ #' in `count_abnormal_lab_worsen_by_baseline()`. |
|||
| 667 | -3954x | +|||
| 319 | +
- p1 <- 1 - stats::pbinom(x - 1, n, p)+ #' |
|||
| 668 | -3954x | +|||
| 320 | +
- p2 <- stats::pbinom(x, n, p)+ #' @return |
|||
| 669 | -3954x | +|||
| 321 | +
- a1 <- p1 + stats::pbinom(stats::qbinom(p1, n, p) - 1, n, p)+ #' * `a_count_abnormal_lab_worsen_by_baseline()` returns the corresponding list with |
|||
| 670 | -3954x | +|||
| 322 | +
- a2 <- p2 + 1 - stats::pbinom(+ #' formatted [rtables::CellValue()]. |
|||
| 671 | -3954x | +|||
| 323 | +
- stats::qbinom(1 - p2, n, p), n,+ #' |
|||
| 672 | -3954x | +|||
| 324 | +
- p+ #' @keywords internal |
|||
| 673 | +325 |
- )+ a_count_abnormal_lab_worsen_by_baseline <- make_afun( # nolint |
||
| 674 | -3954x | +|||
| 326 | +
- return(min(a1, a2))+ s_count_abnormal_lab_worsen_by_baseline, |
|||
| 675 | +327 |
- }+ .formats = c(fraction = format_fraction), |
||
| 676 | -1x | +|||
| 328 | +
- ci_lwr <- 0+ .ungroup_stats = "fraction" |
|||
| 677 | -1x | +|||
| 329 | +
- ci_upr <- 1+ ) |
|||
| 678 | -1x | +|||
| 330 | +
- if (x != 0) {
+
|
|||
| 679 | -1x | +|||
| 331 | +
- ci_lwr <- stats::qbeta((1 - conf.level) / 2, x, n -+ #' @describeIn abnormal_by_worst_grade_worsen Layout-creating function which can take statistics function |
|||
| 680 | -1x | +|||
| 332 | +
- x + 1)+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 681 | -1x | +|||
| 333 | +
- while (acceptbin(x, n, ci_lwr + tol) < (1 -+ #' |
|||
| 682 | -1x | +|||
| 334 | +
- conf.level)) {
+ #' @return |
|||
| 683 | -1976x | +|||
| 335 | +
- ci_lwr <- ci_lwr + tol+ #' * `count_abnormal_lab_worsen_by_baseline()` returns a layout object suitable for passing to further layouting |
|||
| 684 | +336 |
- }+ #' functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted |
||
| 685 | +337 |
- }+ #' rows containing the statistics from `s_count_abnormal_lab_worsen_by_baseline()` to the table layout. |
||
| 686 | -1x | +|||
| 338 | +
- if (x != n) {
+ #' |
|||
| 687 | -1x | +|||
| 339 | +
- ci_upr <- stats::qbeta(1 - (1 - conf.level) / 2, x ++ #' @examples |
|||
| 688 | -1x | +|||
| 340 | +
- 1, n - x)+ #' basic_table() %>% |
|||
| 689 | -1x | +|||
| 341 | +
- while (acceptbin(x, n, ci_upr - tol) < (1 -+ #' split_cols_by("ARMCD") %>%
|
|||
| 690 | -1x | +|||
| 342 | +
- conf.level)) {
+ #' add_colcounts() %>% |
|||
| 691 | -1976x | +|||
| 343 | +
- ci_upr <- ci_upr - tol+ #' split_rows_by("PARAMCD") %>%
|
|||
| 692 | +344 |
- }+ #' split_rows_by("GRADDR") %>%
|
||
| 693 | +345 |
- }+ #' count_abnormal_lab_worsen_by_baseline( |
||
| 694 | +346 |
- }+ #' var = "ATOXGR", |
||
| 695 | +347 |
- )+ #' variables = list( |
||
| 696 | -24x | +|||
| 348 | +
- ci <- c(est = est, lwr.ci = max(0, ci_lwr), upr.ci = min(+ #' id = "USUBJID", |
|||
| 697 | -24x | +|||
| 349 | +
- 1,+ #' baseline_var = "BTOXGR", |
|||
| 698 | -24x | +|||
| 350 | +
- ci_upr+ #' direction_var = "GRADDR" |
|||
| 699 | +351 |
- ))+ #' ) |
||
| 700 | -24x | +|||
| 352 | +
- if (sides == "left") {
+ #' ) %>% |
|||
| 701 | -1x | +|||
| 353 | +
- ci[3] <- 1+ #' append_topleft("Direction of Abnormality") %>%
|
|||
| 702 | -23x | +|||
| 354 | +
- } else if (sides == "right") {
+ #' build_table(df = df, alt_counts_df = tern_ex_adsl) |
|||
| 703 | -! | +|||
| 355 | +
- ci[2] <- 0+ #' |
|||
| 704 | +356 |
- }+ #' @export |
||
| 705 | -24x | +|||
| 357 | +
- return(ci)+ count_abnormal_lab_worsen_by_baseline <- function(lyt, # nolint |
|||
| 706 | +358 |
- }+ var, |
||
| 707 | -24x | +|||
| 359 | +
- lst <- list(+ na_str = NA_character_, |
|||
| 708 | -24x | +|||
| 360 | +
- x = x, n = n, conf.level = conf.level, sides = sides,+ nested = TRUE, |
|||
| 709 | -24x | +|||
| 361 | +
- method = method, rand = rand+ ..., |
|||
| 710 | +362 |
- )+ table_names = NULL, |
||
| 711 | -24x | +|||
| 363 | +
- maxdim <- max(unlist(lapply(lst, length)))+ .stats = NULL, |
|||
| 712 | -24x | +|||
| 364 | +
- lgp <- lapply(lst, rep, length.out = maxdim)+ .formats = NULL, |
|||
| 713 | -24x | +|||
| 365 | +
- lgn <- h_recycle(x = if (is.null(names(x))) {
+ .labels = NULL,+ |
+ |||
| 366 | ++ |
+ .indent_mods = NULL) {
|
||
| 714 | -24x | +367 | +1x |
- paste("x", seq_along(x), sep = ".")
+ checkmate::assert_string(var) |
| 715 | +368 |
- } else {
+
|
||
| 716 | -! | +|||
| 369 | +1x |
- names(x)+ afun <- make_afun( |
||
| 717 | -24x | +370 | +1x |
- }, n = if (is.null(names(n))) {
+ a_count_abnormal_lab_worsen_by_baseline, |
| 718 | -24x | +371 | +1x |
- paste("n", seq_along(n), sep = ".")
+ .stats = .stats, |
| 719 | -+ | |||
| 372 | +1x |
- } else {
+ .formats = .formats, |
||
| 720 | -! | +|||
| 373 | +1x |
- names(n)+ .labels = .labels, |
||
| 721 | -24x | +374 | +1x |
- }, conf.level = conf.level, sides = sides, method = method)+ .indent_mods = .indent_mods |
| 722 | -24x | +|||
| 375 | +
- xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
+ ) |
|||
| 723 | -120x | +|||
| 376 | +
- length(unique(x)) !=+ |
|||
| 724 | -120x | +377 | +1x |
- 1+ lyt <- analyze( |
| 725 | -24x | +378 | +1x |
- })]), 1, paste, collapse = ":")+ lyt = lyt, |
| 726 | -24x | +379 | +1x |
- res <- t(sapply(1:maxdim, function(i) {
+ vars = var, |
| 727 | -24x | +380 | +1x |
- iBinomCI(+ afun = afun, |
| 728 | -24x | +381 | +1x |
- x = lgp$x[i],+ na_str = na_str, |
| 729 | -24x | +382 | +1x |
- n = lgp$n[i], conf.level = lgp$conf.level[i], sides = lgp$sides[i],+ nested = nested, |
| 730 | -24x | +383 | +1x |
- method = lgp$method[i], rand = lgp$rand[i]+ extra_args = list(...), |
| 731 | -+ | |||
| 384 | +1x |
- )+ show_labels = "hidden" |
||
| 732 | +385 |
- }))- |
- ||
| 733 | -24x | -
- colnames(res)[1] <- c("est")
+ ) |
||
| 734 | -24x | +|||
| 386 | +
- rownames(res) <- xn+ |
|||
| 735 | -24x | +387 | +1x |
- return(res)+ lyt |
| 736 | +388 |
}@@ -49556,14 +49767,14 @@ tern coverage - 94.83% |
| 1 |
- #' Helper Functions for Subgroup Treatment Effect Pattern (STEP) Calculations+ #' Cox Proportional Hazards Regression |
||
| 5 |
- #' Helper functions that are used internally for the STEP calculations.+ #' Fits a Cox regression model and estimates hazard ratio to describe the effect size in a survival analysis. |
||
| 9 |
- #' @name h_step+ #' @details Cox models are the most commonly used methods to estimate the magnitude of |
||
| 10 |
- #' @include control_step.R+ #' the effect in survival analysis. It assumes proportional hazards: the ratio |
||
| 11 |
- NULL+ #' of the hazards between groups (e.g., two arms) is constant over time. |
||
| 12 |
-
+ #' This ratio is referred to as the "hazard ratio" (HR) and is one of the |
||
| 13 |
- #' @describeIn h_step creates the windows for STEP, based on the control settings+ #' most commonly reported metrics to describe the effect size in survival |
||
| 14 |
- #' provided.+ #' analysis (NEST Team, 2020). |
||
| 16 |
- #' @param x (`numeric`)\cr biomarker value(s) to use (without `NA`).+ #' @seealso [fit_coxreg] for relevant fitting functions, [h_cox_regression] for relevant |
||
| 17 |
- #' @param control (named `list`)\cr output from `control_step()`.+ #' helper functions, and [tidy_coxreg] for custom tidy methods. |
||
| 19 |
- #' @return+ #' @examples |
||
| 20 |
- #' * `h_step_window()` returns a list containing the window-selection matrix `sel`+ #' library(survival) |
||
| 21 |
- #' and the interval information matrix `interval`.+ #' |
||
| 22 |
- #'+ #' # Testing dataset [survival::bladder]. |
||
| 23 |
- #' @export+ #' set.seed(1, kind = "Mersenne-Twister") |
||
| 24 |
- h_step_window <- function(x,+ #' dta_bladder <- with( |
||
| 25 |
- control = control_step()) {
+ #' data = bladder[bladder$enum < 5, ], |
||
| 26 | -12x | +
- checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)+ #' tibble::tibble( |
|
| 27 | -12x | +
- checkmate::assert_list(control, names = "named")+ #' TIME = stop, |
|
| 28 |
-
+ #' STATUS = event, |
||
| 29 | -12x | +
- sel <- matrix(FALSE, length(x), control$num_points)+ #' ARM = as.factor(rx), |
|
| 30 | -12x | +
- out <- matrix(0, control$num_points, 3)+ #' COVAR1 = as.factor(enum) %>% formatters::with_label("A Covariate Label"),
|
|
| 31 | -12x | +
- colnames(out) <- paste("Interval", c("Center", "Lower", "Upper"))
+ #' COVAR2 = factor( |
|
| 32 | -12x | +
- if (control$use_percentile) {
+ #' sample(as.factor(enum)), |
|
| 33 |
- # Create windows according to percentile cutoffs.+ #' levels = 1:4, labels = c("F", "F", "M", "M")
|
||
| 34 | -9x | +
- out <- cbind(out, out)+ #' ) %>% formatters::with_label("Sex (F/M)")
|
|
| 35 | -9x | +
- colnames(out)[1:3] <- paste("Percentile", c("Center", "Lower", "Upper"))
+ #' ) |
|
| 36 | -9x | +
- xs <- seq(0, 1, length = control$num_points + 2)[-1]+ #' ) |
|
| 37 | -9x | +
- for (i in seq_len(control$num_points)) {
+ #' dta_bladder$AGE <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
|
| 38 | -185x | +
- out[i, 2:3] <- c(+ #' dta_bladder$STUDYID <- factor("X")
|
|
| 39 | -185x | +
- max(xs[i] - control$bandwidth, 0),+ #' |
|
| 40 | -185x | +
- min(xs[i] + control$bandwidth, 1)+ #' plot( |
|
| 41 |
- )+ #' survfit(Surv(TIME, STATUS) ~ ARM + COVAR1, data = dta_bladder), |
||
| 42 | -185x | +
- out[i, 5:6] <- stats::quantile(x, out[i, 2:3])+ #' lty = 2:4, |
|
| 43 | -185x | +
- sel[, i] <- x >= out[i, 5] & x <= out[i, 6]+ #' xlab = "Months", |
|
| 44 |
- }+ #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
|
||
| 45 |
- # Center is the middle point of the percentile window.+ #' ) |
||
| 46 | -9x | +
- out[, 1] <- xs[-control$num_points - 1]+ #' |
|
| 47 | -9x | +
- out[, 4] <- stats::quantile(x, out[, 1])+ #' @name cox_regression |
|
| 48 |
- } else {
+ NULL |
||
| 49 |
- # Create windows according to cutoffs.+ |
||
| 50 | -3x | +
- m <- c(min(x), max(x))+ #' @describeIn cox_regression Statistics function that transforms results tabulated |
|
| 51 | -3x | +
- xs <- seq(m[1], m[2], length = control$num_points + 2)[-1]+ #' from [fit_coxreg_univar()] or [fit_coxreg_multivar()] into a list. |
|
| 52 | -3x | +
- for (i in seq_len(control$num_points)) {
+ #' |
|
| 53 | -11x | +
- out[i, 2:3] <- c(+ #' @param model_df (`data.frame`)\cr contains the resulting model fit from a [fit_coxreg] |
|
| 54 | -11x | +
- max(xs[i] - control$bandwidth, m[1]),+ #' function with tidying applied via [broom::tidy()]. |
|
| 55 | -11x | +
- min(xs[i] + control$bandwidth, m[2])+ #' @param .stats (`character`)\cr the name of statistics to be reported among: |
|
| 56 |
- )+ #' * `n`: number of observations (univariate only) |
||
| 57 | -11x | +
- sel[, i] <- x >= out[i, 2] & x <= out[i, 3]+ #' * `hr`: hazard ratio |
|
| 58 |
- }+ #' * `ci`: confidence interval |
||
| 59 |
- # Center is the same as the point for predicting.+ #' * `pval`: p-value of the treatment effect |
||
| 60 | -3x | +
- out[, 1] <- xs[-control$num_points - 1]+ #' * `pval_inter`: p-value of the interaction effect between the treatment and the covariate (univariate only) |
|
| 61 |
- }+ #' @param .which_vars (`character`)\cr which rows should statistics be returned for from the given model. |
||
| 62 | -12x | +
- list(sel = sel, interval = out)+ #' Defaults to "all". Other options include "var_main" for main effects, `"inter"` for interaction effects, |
|
| 63 |
- }+ #' and `"multi_lvl"` for multivariate model covariate level rows. When `.which_vars` is "all" specific |
||
| 64 |
-
+ #' variables can be selected by specifying `.var_nms`. |
||
| 65 |
- #' @describeIn h_step calculates the estimated treatment effect estimate+ #' @param .var_nms (`character`)\cr the `term` value of rows in `df` for which `.stats` should be returned. Typically |
||
| 66 |
- #' on the linear predictor scale and corresponding standard error from a STEP `model` fitted+ #' this is the name of a variable. If using variable labels, `var` should be a vector of both the desired |
||
| 67 |
- #' on `data` given `variables` specification, for a single biomarker value `x`.+ #' variable name and the variable label in that order to see all `.stats` related to that variable. When `.which_vars` |
||
| 68 |
- #' This works for both `coxph` and `glm` models, i.e. for calculating log hazard ratio or log odds+ #' is `"var_main"` `.var_nms` should be only the variable name. |
||
| 69 |
- #' ratio estimates.+ #' |
||
| 70 |
- #'+ #' @return |
||
| 71 |
- #' @param model the regression model object.+ #' * `s_coxreg()` returns the selected statistic for from the Cox regression model for the selected variable(s). |
||
| 73 |
- #' @return+ #' @examples |
||
| 74 |
- #' * `h_step_trt_effect()` returns a vector with elements `est` and `se`.+ #' # s_coxreg |
||
| 76 |
- #' @export+ #' # Univariate |
||
| 77 |
- h_step_trt_effect <- function(data,+ #' u1_variables <- list( |
||
| 78 |
- model,+ #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
|
||
| 79 |
- variables,+ #' ) |
||
| 80 |
- x) {
+ #' univar_model <- fit_coxreg_univar(variables = u1_variables, data = dta_bladder) |
||
| 81 | -208x | +
- checkmate::assert_multi_class(model, c("coxph", "glm"))
+ #' df1 <- broom::tidy(univar_model) |
|
| 82 | -208x | +
- checkmate::assert_number(x)+ #' s_coxreg(model_df = df1, .stats = "hr") |
|
| 83 | -208x | +
- assert_df_with_variables(data, variables)+ #' |
|
| 84 | -208x | +
- checkmate::assert_factor(data[[variables$arm]], n.levels = 2)+ #' # Univariate with interactions |
|
| 85 |
-
+ #' univar_model_inter <- fit_coxreg_univar( |
||
| 86 | -208x | +
- newdata <- data[c(1, 1), ]+ #' variables = u1_variables, control = control_coxreg(interaction = TRUE), data = dta_bladder |
|
| 87 | -208x | +
- newdata[, variables$biomarker] <- x+ #' ) |
|
| 88 | -208x | +
- newdata[, variables$arm] <- levels(data[[variables$arm]])+ #' df1_inter <- broom::tidy(univar_model_inter) |
|
| 89 | -208x | +
- model_terms <- stats::delete.response(stats::terms(model))+ #' s_coxreg(model_df = df1_inter, .stats = "hr", .which_vars = "inter", .var_nms = "COVAR1") |
|
| 90 | -208x | +
- model_frame <- stats::model.frame(model_terms, data = newdata, xlev = model$xlevels)+ #' |
|
| 91 | -208x | +
- mat <- stats::model.matrix(model_terms, data = model_frame, contrasts.arg = model$contrasts)+ #' # Univariate without treatment arm - only "COVAR2" covariate effects |
|
| 92 | -208x | +
- coefs <- stats::coef(model)+ #' u2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
|
|
| 93 |
- # Note: It is important to use the coef subset from matrix, otherwise intercept and+ #' univar_covs_model <- fit_coxreg_univar(variables = u2_variables, data = dta_bladder) |
||
| 94 |
- # strata are included for coxph() models.+ #' df1_covs <- broom::tidy(univar_covs_model) |
||
| 95 | -208x | +
- mat <- mat[, names(coefs)]+ #' s_coxreg(model_df = df1_covs, .stats = "hr", .var_nms = c("COVAR2", "Sex (F/M)"))
|
|
| 96 | -208x | +
- mat_diff <- diff(mat)+ #' |
|
| 97 | -208x | +
- est <- mat_diff %*% coefs+ #' # Multivariate. |
|
| 98 | -208x | +
- var <- mat_diff %*% stats::vcov(model) %*% t(mat_diff)+ #' m1_variables <- list( |
|
| 99 | -208x | +
- se <- sqrt(var)+ #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
|
|
| 100 | -208x | +
- c(+ #' ) |
|
| 101 | -208x | +
- est = est,+ #' multivar_model <- fit_coxreg_multivar(variables = m1_variables, data = dta_bladder) |
|
| 102 | -208x | +
- se = se+ #' df2 <- broom::tidy(multivar_model) |
|
| 103 |
- )+ #' s_coxreg(model_df = df2, .stats = "pval", .which_vars = "var_main", .var_nms = "COVAR1") |
||
| 104 |
- }+ #' s_coxreg( |
||
| 105 |
-
+ #' model_df = df2, .stats = "pval", .which_vars = "multi_lvl", |
||
| 106 |
- #' @describeIn h_step builds the model formula used in survival STEP calculations.+ #' .var_nms = c("COVAR1", "A Covariate Label")
|
||
| 107 |
- #'+ #' ) |
||
| 108 |
- #' @return+ #' |
||
| 109 |
- #' * `h_step_survival_formula()` returns a model formula.+ #' # Multivariate without treatment arm - only "COVAR1" main effect |
||
| 110 |
- #'+ #' m2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
|
||
| 111 |
- #' @export+ #' multivar_covs_model <- fit_coxreg_multivar(variables = m2_variables, data = dta_bladder) |
||
| 112 |
- h_step_survival_formula <- function(variables,+ #' df2_covs <- broom::tidy(multivar_covs_model) |
||
| 113 |
- control = control_step()) {
+ #' s_coxreg(model_df = df2_covs, .stats = "hr") |
||
| 114 | -10x | +
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ #' |
|
| 115 |
-
+ #' @export |
||
| 116 | -10x | +
- assert_list_of_variables(variables[c("arm", "biomarker", "event", "time")])
+ s_coxreg <- function(model_df, .stats, .which_vars = "all", .var_nms = NULL) {
|
|
| 117 | -10x | +194x |
- form <- paste0("Surv(", variables$time, ", ", variables$event, ") ~ ", variables$arm)
+ assert_df_with_variables(model_df, list(term = "term", stat = .stats)) |
| 118 | -10x | +194x |
- if (control$degree > 0) {
+ checkmate::assert_multi_class(model_df$term, classes = c("factor", "character"))
|
| 119 | -5x | +194x |
- form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
+ model_df$term <- as.character(model_df$term) |
| 120 | -+ | 194x |
- }+ .var_nms <- .var_nms[!is.na(.var_nms)] |
| 121 | -10x | +
- if (!is.null(variables$covariates)) {
+
|
|
| 122 | -6x | +192x |
- form <- paste(form, "+", paste(variables$covariates, collapse = "+"))+ if (length(.var_nms) > 0) model_df <- model_df[model_df$term %in% .var_nms, ] |
| 123 | -+ | 39x |
- }+ if (.which_vars == "multi_lvl") model_df$term <- tail(.var_nms, 1) |
| 124 | -10x | +
- if (!is.null(variables$strata)) {
+
|
|
| 125 | -2x | +
- form <- paste0(form, " + strata(", paste0(variables$strata, collapse = ", "), ")")
+ # We need a list with names corresponding to the stats to display of equal length to the list of stats. |
|
| 126 | -+ | 194x |
- }+ y <- split(model_df, f = model_df$term, drop = FALSE) |
| 127 | -10x | +194x |
- stats::as.formula(form)+ y <- stats::setNames(y, nm = rep(.stats, length(y))) |
| 128 |
- }+ |
||
| 129 | -+ | 194x |
-
+ if (.which_vars == "var_main") {
|
| 130 | -+ | 84x |
- #' @describeIn h_step estimates the model with `formula` built based on+ y <- lapply(y, function(x) x[1, ]) # only main effect |
| 131 | -+ | 110x |
- #' `variables` in `data` for a given `subset` and `control` parameters for the+ } else if (.which_vars %in% c("inter", "multi_lvl")) {
|
| 132 | -+ | 80x |
- #' Cox regression.+ y <- lapply(y, function(x) if (nrow(y[[1]]) > 1) x[-1, ] else x) # exclude main effect |
| 133 |
- #'+ } |
||
| 134 |
- #' @param formula (`formula`)\cr the regression model formula.+ |
||
| 135 | -+ | 194x |
- #' @param subset (`logical`)\cr subset vector.+ lapply( |
| 136 | -+ | 194x |
- #'+ X = y, |
| 137 | -+ | 194x |
- #' @return+ FUN = function(x) {
|
| 138 | -+ | 198x |
- #' * `h_step_survival_est()` returns a matrix of number of observations `n`,+ z <- as.list(x[[.stats]]) |
| 139 | -+ | 198x |
- #' `events`, log hazard ratio estimates `loghr`, standard error `se`,+ stats::setNames(z, nm = x$term_label) |
| 140 |
- #' and Wald confidence interval bounds `ci_lower` and `ci_upper`. One row is+ } |
||
| 141 |
- #' included for each biomarker value in `x`.+ ) |
||
| 142 |
- #'+ } |
||
| 143 |
- #' @export+ |
||
| 144 |
- h_step_survival_est <- function(formula,+ #' @describeIn cox_regression Analysis function which is used as `afun` in [rtables::analyze()] |
||
| 145 |
- data,+ #' and `cfun` in [rtables::summarize_row_groups()] within `summarize_coxreg()`. |
||
| 146 |
- variables,+ #' |
||
| 147 |
- x,+ #' @param eff (`flag`)\cr whether treatment effect should be calculated. Defaults to `FALSE`. |
||
| 148 |
- subset = rep(TRUE, nrow(data)),+ #' @param var_main (`flag`)\cr whether main effects should be calculated. Defaults to `FALSE`. |
||
| 149 |
- control = control_coxph()) {
+ #' @param na_str (`string`)\cr custom string to replace all `NA` values with. Defaults to `""`. |
||
| 150 | -55x | +
- checkmate::assert_formula(formula)+ #' @param cache_env (`environment`)\cr an environment object used to cache the regression model in order to |
|
| 151 | -55x | +
- assert_df_with_variables(data, variables)+ #' avoid repeatedly fitting the same model for every row in the table. Defaults to `NULL` (no caching). |
|
| 152 | -55x | +
- checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE)+ #' @param varlabels (`list`)\cr a named list corresponds to the names of variables found in data, passed |
|
| 153 | -55x | +
- checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)+ #' as a named list and corresponding to time, event, arm, strata, and covariates terms. If arm is missing |
|
| 154 | -55x | +
- checkmate::assert_list(control, names = "named")+ #' from variables, then only Cox model(s) including the covariates will be fitted and the corresponding |
|
| 155 |
-
+ #' effect estimates will be tabulated later. |
||
| 156 |
- # Note: `subset` in `coxph` needs to be an expression referring to `data` variables.+ #' |
||
| 157 | -55x | +
- data$.subset <- subset+ #' @return |
|
| 158 | -55x | +
- coxph_warnings <- NULL+ #' * `a_coxreg()` returns formatted [rtables::CellValue()]. |
|
| 159 | -55x | +
- tryCatch(+ #' |
|
| 160 | -55x | +
- withCallingHandlers(+ #' @examples |
|
| 161 | -55x | +
- expr = {
+ #' a_coxreg( |
|
| 162 | -55x | +
- fit <- survival::coxph(+ #' df = dta_bladder, |
|
| 163 | -55x | +
- formula = formula,+ #' labelstr = "Label 1", |
|
| 164 | -55x | +
- data = data,+ #' variables = u1_variables, |
|
| 165 | -55x | +
- subset = .subset,+ #' .spl_context = list(value = "COVAR1"), |
|
| 166 | -55x | +
- ties = control$ties+ #' .stats = "n", |
|
| 167 |
- )+ #' .formats = "xx" |
||
| 168 |
- },+ #' ) |
||
| 169 | -55x | +
- warning = function(w) {
+ #' |
|
| 170 | -1x | +
- coxph_warnings <<- c(coxph_warnings, w)+ #' a_coxreg( |
|
| 171 | -1x | +
- invokeRestart("muffleWarning")
+ #' df = dta_bladder, |
|
| 172 |
- }+ #' labelstr = "", |
||
| 173 |
- ),+ #' variables = u1_variables, |
||
| 174 | -55x | +
- finally = {
+ #' .spl_context = list(value = "COVAR2"), |
|
| 175 |
- }+ #' .stats = "pval", |
||
| 176 |
- )+ #' .formats = "xx.xxxx" |
||
| 177 | -55x | +
- if (!is.null(coxph_warnings)) {
+ #' ) |
|
| 178 | -1x | +
- warning(paste(+ #' |
|
| 179 | -1x | +
- "Fit warnings occurred, please consider using a simpler model, or",+ #' @export |
|
| 180 | -1x | +
- "larger `bandwidth`, less `num_points` in `control_step()` settings"+ a_coxreg <- function(df, |
|
| 181 |
- ))+ labelstr, |
||
| 182 |
- }+ eff = FALSE, |
||
| 183 |
- # Produce a matrix with one row per `x` and columns `est` and `se`.+ var_main = FALSE, |
||
| 184 | -55x | +
- estimates <- t(vapply(+ multivar = FALSE, |
|
| 185 | -55x | +
- X = x,+ variables, |
|
| 186 | -55x | +
- FUN = h_step_trt_effect,+ at = list(), |
|
| 187 | -55x | +
- FUN.VALUE = c(1, 2),+ control = control_coxreg(), |
|
| 188 | -55x | +
- data = data,+ .spl_context, |
|
| 189 | -55x | +
- model = fit,+ .stats, |
|
| 190 | -55x | +
- variables = variables+ .formats, |
|
| 191 |
- ))+ .indent_mods = NULL, |
||
| 192 | -55x | +
- q_norm <- stats::qnorm((1 + control$conf_level) / 2)+ na_level = lifecycle::deprecated(), |
|
| 193 | -55x | +
- cbind(+ na_str = "", |
|
| 194 | -55x | +
- n = fit$n,+ cache_env = NULL) {
|
|
| 195 | -55x | +191x |
- events = fit$nevent,+ if (lifecycle::is_present(na_level)) {
|
| 196 | -55x | +! |
- loghr = estimates[, "est"],+ lifecycle::deprecate_warn("0.9.1", "a_coxreg(na_level)", "a_coxreg(na_str)")
|
| 197 | -55x | +! |
- se = estimates[, "se"],+ na_str <- na_level |
| 198 | -55x | +
- ci_lower = estimates[, "est"] - q_norm * estimates[, "se"],+ } |
|
| 199 | -55x | +
- ci_upper = estimates[, "est"] + q_norm * estimates[, "se"]+ |
|
| 200 | -+ | 191x |
- )+ cov_no_arm <- !multivar && !"arm" %in% names(variables) && control$interaction # special case: univar no arm |
| 201 | -+ | 191x |
- }+ cov <- tail(.spl_context$value, 1) # current variable/covariate |
| 202 | -+ | 191x |
-
+ var_lbl <- formatters::var_labels(df)[cov] # check for df labels |
| 203 | -+ | 191x |
- #' @describeIn h_step builds the model formula used in response STEP calculations.+ if (length(labelstr) > 1) {
|
| 204 | -+ | ! |
- #'+ labelstr <- if (cov %in% names(labelstr)) labelstr[[cov]] else var_lbl # use df labels if none |
| 205 | -+ | 191x |
- #' @return+ } else if (!is.na(var_lbl) && labelstr == cov && cov %in% variables$covariates) {
|
| 206 | -+ | 62x |
- #' * `h_step_rsp_formula()` returns a model formula.+ labelstr <- var_lbl |
| 207 |
- #'+ } |
||
| 208 | -+ | 191x |
- #' @export+ if (eff || multivar || cov_no_arm) {
|
| 209 | -+ | 82x |
- h_step_rsp_formula <- function(variables,+ control$interaction <- FALSE |
| 210 |
- control = c(control_step(), control_logistic())) {
+ } else {
|
||
| 211 | -14x | +109x |
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ variables$covariates <- cov |
| 212 | -14x | +40x |
- assert_list_of_variables(variables[c("arm", "biomarker", "response")])
+ if (var_main) control$interaction <- TRUE |
| 213 | -14x | +
- response_definition <- sub(+ } |
|
| 214 | -14x | +
- pattern = "response",+ |
|
| 215 | -14x | +191x |
- replacement = variables$response,+ if (is.null(cache_env[[cov]])) {
|
| 216 | -14x | +30x |
- x = control$response_definition,+ if (!multivar) {
|
| 217 | -14x | +23x |
- fixed = TRUE+ model <- fit_coxreg_univar(variables = variables, data = df, at = at, control = control) %>% broom::tidy() |
| 218 |
- )+ } else {
|
||
| 219 | -14x | +7x |
- form <- paste0(response_definition, " ~ ", variables$arm)+ model <- fit_coxreg_multivar(variables = variables, data = df, control = control) %>% broom::tidy() |
| 220 | -14x | +
- if (control$degree > 0) {
+ } |
|
| 221 | -8x | +30x |
- form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
+ cache_env[[cov]] <- model |
| 222 |
- }+ } else {
|
||
| 223 | -14x | +161x |
- if (!is.null(variables$covariates)) {
+ model <- cache_env[[cov]] |
| 224 | -8x | +
- form <- paste(form, "+", paste(variables$covariates, collapse = "+"))+ } |
|
| 225 | -+ | 109x |
- }+ if (!multivar && !var_main) model[, "pval_inter"] <- NA_real_ |
| 226 | -14x | +
- if (!is.null(variables$strata)) {
+
|
|
| 227 | -5x | +191x |
- strata_arg <- if (length(variables$strata) > 1) {
+ if (cov_no_arm || (!cov_no_arm && !"arm" %in% names(variables) && is.numeric(df[[cov]]))) {
|
| 228 | -2x | +15x |
- paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
+ multivar <- TRUE |
| 229 | -+ | 3x |
- } else {
+ if (!cov_no_arm) var_main <- TRUE |
| 230 | -3x | +
- variables$strata+ } |
|
| 231 |
- }+ |
||
| 232 | -5x | +191x |
- form <- paste0(form, "+ strata(", strata_arg, ")")
+ vars_coxreg <- list(which_vars = "all", var_nms = NULL) |
| 233 | -+ | 191x |
- }+ if (eff) {
|
| 234 | -14x | +40x |
- stats::as.formula(form)+ if (multivar && !var_main) { # multivar treatment level
|
| 235 | -+ | 6x |
- }+ var_lbl_arm <- formatters::var_labels(df)[[variables$arm]] |
| 236 | -+ | 6x |
-
+ vars_coxreg[c("var_nms", "which_vars")] <- list(c(variables$arm, var_lbl_arm), "multi_lvl")
|
| 237 |
- #' @describeIn h_step estimates the model with `formula` built based on+ } else { # treatment effect
|
||
| 238 | -+ | 34x |
- #' `variables` in `data` for a given `subset` and `control` parameters for the+ vars_coxreg["var_nms"] <- variables$arm |
| 239 | -+ | 6x |
- #' logistic regression.+ if (var_main) vars_coxreg["which_vars"] <- "var_main" |
| 240 |
- #'+ } |
||
| 241 |
- #' @param formula (`formula`)\cr the regression model formula.+ } else {
|
||
| 242 | -+ | 151x |
- #' @param subset (`logical`)\cr subset vector.+ if (!multivar || (multivar && var_main && !is.numeric(df[[cov]]))) { # covariate effect/level
|
| 243 | -+ | 118x |
- #'+ vars_coxreg[c("var_nms", "which_vars")] <- list(cov, "var_main")
|
| 244 | -+ | 33x |
- #' @return+ } else if (multivar) { # multivar covariate level
|
| 245 | -+ | 33x |
- #' * `h_step_rsp_est()` returns a matrix of number of observations `n`, log odds+ vars_coxreg[c("var_nms", "which_vars")] <- list(c(cov, var_lbl), "multi_lvl")
|
| 246 | -+ | 6x |
- #' ratio estimates `logor`, standard error `se`, and Wald confidence interval bounds+ if (var_main) model[cov, .stats] <- NA_real_ |
| 247 |
- #' `ci_lower` and `ci_upper`. One row is included for each biomarker value in `x`.+ } |
||
| 248 | -+ | 40x |
- #'+ if (!multivar && !var_main && control$interaction) vars_coxreg["which_vars"] <- "inter" # interaction effect |
| 249 |
- #' @export+ } |
||
| 250 | -+ | 191x |
- h_step_rsp_est <- function(formula,+ var_vals <- s_coxreg(model, .stats, .which_vars = vars_coxreg$which_vars, .var_nms = vars_coxreg$var_nms)[[1]] |
| 251 | -+ | 191x |
- data,+ var_names <- if (all(grepl("\\(reference = ", names(var_vals))) && labelstr != tail(.spl_context$value, 1)) {
|
| 252 | -+ | 21x |
- variables,+ paste(c(labelstr, tail(strsplit(names(var_vals), " ")[[1]], 3)), collapse = " ") # "reference" main effect labels |
| 253 | -+ | 191x |
- x,+ } else if ((!multivar && !eff && !(!var_main && control$interaction) && nchar(labelstr) > 0) || |
| 254 | -+ | 191x |
- subset = rep(TRUE, nrow(data)),+ (multivar && var_main && is.numeric(df[[cov]]))) { # nolint
|
| 255 | -+ | 47x |
- control = control_logistic()) {
+ labelstr # other main effect labels |
| 256 | -58x | +191x |
- checkmate::assert_formula(formula)+ } else if (multivar && !eff && !var_main && is.numeric(df[[cov]])) {
|
| 257 | -58x | +6x |
- assert_df_with_variables(data, variables)+ "All" # multivar numeric covariate |
| 258 | -58x | +
- checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE)+ } else {
|
|
| 259 | -58x | +117x |
- checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)+ names(var_vals) |
| 260 | -58x | +
- checkmate::assert_list(control, names = "named")+ } |
|
| 261 | -+ | 191x |
- # Note: `subset` in `glm` needs to be an expression referring to `data` variables.+ in_rows( |
| 262 | -58x | +191x |
- data$.subset <- subset+ .list = var_vals, .names = var_names, .labels = var_names, .indent_mods = .indent_mods, |
| 263 | -58x | +191x |
- fit_warnings <- NULL+ .formats = stats::setNames(rep(.formats, length(var_names)), var_names), |
| 264 | -58x | +191x |
- tryCatch(+ .format_na_strs = stats::setNames(rep(na_str, length(var_names)), var_names) |
| 265 | -58x | +
- withCallingHandlers(+ ) |
|
| 266 | -58x | +
- expr = {
+ } |
|
| 267 | -58x | +
- fit <- if (is.null(variables$strata)) {
+
|
|
| 268 | -54x | +
- stats::glm(+ #' @describeIn cox_regression Layout-creating function which creates a Cox regression summary table |
|
| 269 | -54x | +
- formula = formula,+ #' layout. This function is a wrapper for several `rtables` layouting functions. This function |
|
| 270 | -54x | +
- data = data,+ #' is a wrapper for [rtables::analyze_colvars()] and [rtables::summarize_row_groups()]. |
|
| 271 | -54x | +
- subset = .subset,+ #' |
|
| 272 | -54x | +
- family = stats::binomial("logit")
+ #' @inheritParams fit_coxreg_univar |
|
| 273 |
- )+ #' @param multivar (`flag`)\cr Defaults to `FALSE`. If `TRUE` multivariate Cox regression will run, otherwise |
||
| 274 |
- } else {
+ #' univariate Cox regression will run. |
||
| 275 |
- # clogit needs coxph and strata imported+ #' @param common_var (`character`)\cr the name of a factor variable in the dataset which takes the same value |
||
| 276 | -4x | +
- survival::clogit(+ #' for all rows. This should be created during pre-processing if no such variable currently exists. |
|
| 277 | -4x | +
- formula = formula,+ #' @param .section_div (`character`)\cr string which should be repeated as a section divider between sections. |
|
| 278 | -4x | +
- data = data,+ #' Defaults to `NA` for no section divider. If a vector of two strings are given, the first will be used between |
|
| 279 | -4x | +
- subset = .subset+ #' treatment and covariate sections and the second between different covariates. |
|
| 280 |
- )+ #' |
||
| 281 |
- }+ #' @return |
||
| 282 |
- },- |
- ||
| 283 | -58x | -
- warning = function(w) {
- |
- |
| 284 | -19x | -
- fit_warnings <<- c(fit_warnings, w)- |
- |
| 285 | -19x | -
- invokeRestart("muffleWarning")
- |
- |
| 286 | -- |
- }- |
- |
| 287 | -- |
- ),- |
- |
| 288 | -58x | -
- finally = {
+ #' * `summarize_coxreg()` returns a layout object suitable for passing to further layouting functions, |
|
| 289 | +283 |
- }+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add a Cox regression table |
|
| 290 | +284 |
- )- |
- |
| 291 | -58x | -
- if (!is.null(fit_warnings)) {
- |
- |
| 292 | -13x | -
- warning(paste(- |
- |
| 293 | -13x | -
- "Fit warnings occurred, please consider using a simpler model, or",- |
- |
| 294 | -13x | -
- "larger `bandwidth`, less `num_points` in `control_step()` settings"+ #' containing the chosen statistics to the table layout. |
|
| 295 | +285 |
- ))+ #' |
|
| 296 | +286 |
- }+ #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()] which also take the `variables`, `data`, |
|
| 297 | +287 |
- # Produce a matrix with one row per `x` and columns `est` and `se`.- |
- |
| 298 | -58x | -
- estimates <- t(vapply(- |
- |
| 299 | -58x | -
- X = x,- |
- |
| 300 | -58x | -
- FUN = h_step_trt_effect,- |
- |
| 301 | -58x | -
- FUN.VALUE = c(1, 2),- |
- |
| 302 | -58x | -
- data = data,- |
- |
| 303 | -58x | -
- model = fit,- |
- |
| 304 | -58x | -
- variables = variables+ #' `at` (univariate only), and `control` arguments but return unformatted univariate and multivariate |
|
| 305 | +288 |
- ))- |
- |
| 306 | -58x | -
- q_norm <- stats::qnorm((1 + control$conf_level) / 2)- |
- |
| 307 | -58x | -
- cbind(- |
- |
| 308 | -58x | -
- n = length(fit$y),- |
- |
| 309 | -58x | -
- logor = estimates[, "est"],- |
- |
| 310 | -58x | -
- se = estimates[, "se"],- |
- |
| 311 | -58x | -
- ci_lower = estimates[, "est"] - q_norm * estimates[, "se"],- |
- |
| 312 | -58x | -
- ci_upper = estimates[, "est"] + q_norm * estimates[, "se"]+ #' Cox regression models, respectively. |
|
| 313 | +289 |
- )+ #' |
|
| 314 | +290 |
- }+ #' @examples |
| 1 | +291 |
- #' Patient Counts for Laboratory Events (Worsen From Baseline) by Highest Grade Post-Baseline+ #' # summarize_coxreg |
||
| 2 | +292 |
#' |
||
| 3 | +293 |
- #' @description `r lifecycle::badge("stable")`
+ #' result_univar <- basic_table() %>% |
||
| 4 | +294 |
- #'+ #' summarize_coxreg(variables = u1_variables) %>% |
||
| 5 | +295 |
- #' Patient count and fraction for laboratory events (worsen from baseline) shift table.+ #' build_table(dta_bladder) |
||
| 6 | +296 |
- #'+ #' result_univar |
||
| 7 | +297 |
- #' @inheritParams argument_convention+ #' |
||
| 8 | +298 |
- #'+ #' result_multivar <- basic_table() %>% |
||
| 9 | +299 |
- #' @seealso Relevant helper functions [h_adlb_worsen()] and [h_worsen_counter()]+ #' summarize_coxreg( |
||
| 10 | +300 |
- #'+ #' variables = m1_variables, |
||
| 11 | +301 |
- #' @name abnormal_by_worst_grade_worsen+ #' multivar = TRUE, |
||
| 12 | +302 |
- NULL+ #' ) %>% |
||
| 13 | +303 |
-
+ #' build_table(dta_bladder) |
||
| 14 | +304 |
- #' Helper Function to Prepare `ADLB` with Worst Labs+ #' result_multivar |
||
| 15 | +305 |
#' |
||
| 16 | +306 |
- #' @description `r lifecycle::badge("stable")`
+ #' result_univar_covs <- basic_table() %>% |
||
| 17 | +307 |
- #'+ #' summarize_coxreg( |
||
| 18 | +308 |
- #' Helper function to prepare a `df` for generate the patient count shift table+ #' variables = u2_variables, |
||
| 19 | +309 |
- #'+ #' ) %>% |
||
| 20 | +310 |
- #' @param adlb (`data.frame`)\cr `ADLB` dataframe+ #' build_table(dta_bladder) |
||
| 21 | +311 |
- #' @param worst_flag_low (named `vector`)\cr Worst low post-baseline lab grade flag variable+ #' result_univar_covs |
||
| 22 | +312 |
- #' @param worst_flag_high (named `vector`)\cr Worst high post-baseline lab grade flag variable+ #' |
||
| 23 | +313 |
- #' @param direction_var (`string`)\cr Direction variable specifying the direction of the shift table of interest.+ #' result_multivar_covs <- basic_table() %>% |
||
| 24 | +314 |
- #' Only lab records flagged by `L`, `H` or `B` are included in the shift table.+ #' summarize_coxreg( |
||
| 25 | +315 |
- #' * `L`: low direction only+ #' variables = m2_variables, |
||
| 26 | +316 |
- #' * `H`: high direction only+ #' multivar = TRUE, |
||
| 27 | +317 |
- #' * `B`: both low and high directions+ #' varlabels = c("Covariate 1", "Covariate 2") # custom labels
|
||
| 28 | +318 |
- #'+ #' ) %>% |
||
| 29 | +319 |
- #' @return `h_adlb_worsen()` returns the `adlb` `data.frame` containing only the+ #' build_table(dta_bladder) |
||
| 30 | +320 |
- #' worst labs specified according to `worst_flag_low` or `worst_flag_high` for the+ #' result_multivar_covs |
||
| 31 | +321 |
- #' direction specified according to `direction_var`. For instance, for a lab that is+ #' |
||
| 32 | +322 |
- #' needed for the low direction only, only records flagged by `worst_flag_low` are+ #' @export |
||
| 33 | +323 |
- #' selected. For a lab that is needed for both low and high directions, the worst+ summarize_coxreg <- function(lyt, |
||
| 34 | +324 |
- #' low records are selected for the low direction, and the worst high record are selected+ variables, |
||
| 35 | +325 |
- #' for the high direction.+ control = control_coxreg(), |
||
| 36 | +326 |
- #'+ at = list(), |
||
| 37 | +327 |
- #' @seealso [abnormal_by_worst_grade_worsen]+ multivar = FALSE, |
||
| 38 | +328 |
- #'+ common_var = "STUDYID", |
||
| 39 | +329 |
- #' @examples+ .stats = c("n", "hr", "ci", "pval", "pval_inter"),
|
||
| 40 | +330 |
- #' library(dplyr)+ .formats = c( |
||
| 41 | +331 |
- #'+ n = "xx", hr = "xx.xx", ci = "(xx.xx, xx.xx)", |
||
| 42 | +332 |
- #' # The direction variable, GRADDR, is based on metadata+ pval = "x.xxxx | (<0.0001)", pval_inter = "x.xxxx | (<0.0001)" |
||
| 43 | +333 |
- #' adlb <- tern_ex_adlb %>%+ ), |
||
| 44 | +334 |
- #' mutate(+ varlabels = NULL, |
||
| 45 | +335 |
- #' GRADDR = case_when(+ .indent_mods = NULL, |
||
| 46 | +336 |
- #' PARAMCD == "ALT" ~ "B",+ na_level = lifecycle::deprecated(), |
||
| 47 | +337 |
- #' PARAMCD == "CRP" ~ "L",+ na_str = "", |
||
| 48 | +338 |
- #' PARAMCD == "IGA" ~ "H"+ .section_div = NA_character_) {
|
||
| 49 | -+ | |||
| 339 | +11x |
- #' )+ if (lifecycle::is_present(na_level)) {
|
||
| 50 | -+ | |||
| 340 | +! |
- #' ) %>%+ lifecycle::deprecate_warn("0.9.1", "summarize_coxreg(na_level)", "summarize_coxreg(na_str)")
|
||
| 51 | -+ | |||
| 341 | +! |
- #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")+ na_str <- na_level |
||
| 52 | +342 |
- #'+ } |
||
| 53 | +343 |
- #' df <- h_adlb_worsen(+ |
||
| 54 | -+ | |||
| 344 | +11x |
- #' adlb,+ if (multivar && control$interaction) {
|
||
| 55 | -+ | |||
| 345 | +1x |
- #' worst_flag_low = c("WGRLOFL" = "Y"),
+ warning(paste( |
||
| 56 | -+ | |||
| 346 | +1x |
- #' worst_flag_high = c("WGRHIFL" = "Y"),
+ "Interactions are not available for multivariate cox regression using summarize_coxreg.", |
||
| 57 | -+ | |||
| 347 | +1x |
- #' direction_var = "GRADDR"+ "The model will be calculated without interaction effects." |
||
| 58 | +348 |
- #' )+ )) |
||
| 59 | +349 |
- #'+ } |
||
| 60 | -+ | |||
| 350 | +11x |
- #' @export+ if (control$interaction && !"arm" %in% names(variables)) {
|
||
| 61 | -+ | |||
| 351 | +1x |
- h_adlb_worsen <- function(adlb,+ stop("To include interactions please specify 'arm' in variables.")
|
||
| 62 | +352 |
- worst_flag_low = NULL,+ } |
||
| 63 | +353 |
- worst_flag_high = NULL,+ |
||
| 64 | -+ | |||
| 354 | +10x |
- direction_var) {
+ .stats <- if (!"arm" %in% names(variables) || multivar) { # only valid statistics
|
||
| 65 | -5x | +355 | +4x |
- checkmate::assert_string(direction_var)+ intersect(c("hr", "ci", "pval"), .stats)
|
| 66 | -5x | +356 | +10x |
- checkmate::assert_subset(as.character(unique(adlb[[direction_var]])), c("B", "L", "H"))
+ } else if (control$interaction) {
|
| 67 | -5x | +357 | +4x |
- assert_df_with_variables(adlb, list("Col" = direction_var))
+ intersect(c("n", "hr", "ci", "pval", "pval_inter"), .stats)
|
| 68 | +358 |
-
+ } else {
|
||
| 69 | -5x | +359 | +2x |
- if (any(unique(adlb[[direction_var]]) == "H")) {
+ intersect(c("n", "hr", "ci", "pval"), .stats)
+ |
+
| 360 | ++ |
+ } |
||
| 70 | -4x | +361 | +10x |
- assert_df_with_variables(adlb, list("High" = names(worst_flag_high)))
+ stat_labels <- c( |
| 71 | -+ | |||
| 362 | +10x |
- }+ n = "n", hr = "Hazard Ratio", ci = paste0(control$conf_level * 100, "% CI"),+ |
+ ||
| 363 | +10x | +
+ pval = "p-value", pval_inter = "Interaction p-value" |
||
| 72 | +364 |
-
+ ) |
||
| 73 | -5x | +365 | +10x |
- if (any(unique(adlb[[direction_var]]) == "L")) {
+ stat_labels <- stat_labels[names(stat_labels) %in% .stats] |
| 74 | -4x | +366 | +10x |
- assert_df_with_variables(adlb, list("Low" = names(worst_flag_low)))
+ .formats <- .formats[names(.formats) %in% .stats] |
| 75 | -+ | |||
| 367 | +10x |
- }+ env <- new.env() # create caching environment |
||
| 76 | +368 | |||
| 77 | -5x | +369 | +10x |
- if (any(unique(adlb[[direction_var]]) == "B")) {
+ lyt <- lyt %>% |
| 78 | -3x | +370 | +10x |
- assert_df_with_variables(+ split_cols_by_multivar( |
| 79 | -3x | +371 | +10x |
- adlb,+ vars = rep(common_var, length(.stats)), |
| 80 | -3x | +372 | +10x |
- list(+ varlabels = stat_labels, |
| 81 | -3x | +373 | +10x |
- "Low" = names(worst_flag_low),+ extra_args = list( |
| 82 | -3x | +374 | +10x |
- "High" = names(worst_flag_high)+ .stats = .stats, .formats = .formats, .indent_mods = .indent_mods, na_str = rep(na_str, length(.stats)), |
| 83 | -+ | |||
| 375 | +10x |
- )+ cache_env = replicate(length(.stats), list(env)) |
||
| 84 | +376 |
- )+ ) |
||
| 85 | +377 |
- }+ ) |
||
| 86 | +378 | |||
| 87 | -+ | |||
| 379 | +10x |
- # extract patients with worst post-baseline lab, either low or high or both+ if ("arm" %in% names(variables)) { # treatment effect
|
||
| 88 | -5x | +380 | +8x |
- worst_flag <- c(worst_flag_low, worst_flag_high)+ lyt <- lyt %>% |
| 89 | -5x | +381 | +8x |
- col_names <- names(worst_flag)+ split_rows_by( |
| 90 | -5x | +382 | +8x |
- filter_values <- worst_flag+ common_var, |
| 91 | -5x | +383 | +8x |
- temp <- Map(+ split_label = "Treatment:", |
| 92 | -5x | +384 | +8x |
- function(x, y) which(adlb[[x]] == y),+ label_pos = "visible", |
| 93 | -5x | +385 | +8x |
- col_names,+ child_labels = "hidden", |
| 94 | -5x | +386 | +8x |
- filter_values+ section_div = head(.section_div, 1) |
| 95 | +387 |
- )+ ) |
||
| 96 | -5x | +388 | +8x |
- position_satisfy_filters <- Reduce(union, temp)+ if (!multivar) {
|
| 97 | -+ | |||
| 389 | +6x |
-
+ lyt <- lyt %>% |
||
| 98 | -+ | |||
| 390 | +6x |
- # select variables of interest+ analyze_colvars( |
||
| 99 | -5x | +391 | +6x |
- adlb_f <- adlb[position_satisfy_filters, ]+ afun = a_coxreg,+ |
+
| 392 | +6x | +
+ extra_args = list(+ |
+ ||
| 393 | +6x | +
+ variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar,+ |
+ ||
| 394 | +6x | +
+ labelstr = "" |
||
| 100 | +395 |
-
+ ) |
||
| 101 | +396 |
- # generate subsets for different directionality+ ) |
||
| 102 | -5x | +|||
| 397 | +
- adlb_f_h <- adlb_f[which(adlb_f[[direction_var]] == "H"), ]+ } else { # treatment level effects
|
|||
| 103 | -5x | +398 | +2x |
- adlb_f_l <- adlb_f[which(adlb_f[[direction_var]] == "L"), ]+ lyt <- lyt %>% |
| 104 | -5x | +399 | +2x |
- adlb_f_b <- adlb_f[which(adlb_f[[direction_var]] == "B"), ]+ summarize_row_groups( |
| 105 | -+ | |||
| 400 | +2x |
-
+ cfun = a_coxreg, |
||
| 106 | -+ | |||
| 401 | +2x |
- # for labs requiring both high and low, data is duplicated and will be stacked on top of each other+ na_str = na_str, |
||
| 107 | -5x | +402 | +2x |
- adlb_f_b_h <- adlb_f_b+ extra_args = list( |
| 108 | -5x | +403 | +2x |
- adlb_f_b_l <- adlb_f_b+ variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar |
| 109 | +404 |
-
+ ) |
||
| 110 | +405 |
- # extract data with worst lab+ ) %>% |
||
| 111 | -5x | +406 | +2x |
- if (!is.null(worst_flag_high) && !is.null(worst_flag_low)) {
+ analyze_colvars( |
| 112 | -+ | |||
| 407 | +2x |
- # change H to High, L to Low+ afun = a_coxreg, |
||
| 113 | -3x | +408 | +2x |
- adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
+ extra_args = list(eff = TRUE, control = control, variables = variables, multivar = multivar, labelstr = "") |
| 114 | -3x | +|||
| 409 | +
- adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
+ ) |
|||
| 115 | +410 |
-
+ } |
||
| 116 | +411 |
- # change, B to High and Low+ }+ |
+ ||
| 412 | ++ | + | ||
| 117 | -3x | +413 | +10x |
- adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
+ if ("covariates" %in% names(variables)) { # covariate main effects
|
| 118 | -3x | +414 | +10x |
- adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
+ lyt <- lyt %>% |
| 119 | -+ | |||
| 415 | +10x |
-
+ split_rows_by_multivar( |
||
| 120 | -3x | +416 | +10x |
- adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ]+ vars = variables$covariates, |
| 121 | -3x | +417 | +10x |
- adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ]+ varlabels = varlabels, |
| 122 | -3x | +418 | +10x |
- adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ]+ split_label = "Covariate:", |
| 123 | -3x | +419 | +10x |
- adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ]+ nested = FALSE,+ |
+
| 420 | +10x | +
+ child_labels = if (multivar || control$interaction || !"arm" %in% names(variables)) "default" else "hidden",+ |
+ ||
| 421 | +10x | +
+ section_div = tail(.section_div, 1) |
||
| 124 | +422 |
-
+ ) |
||
| 125 | -3x | +423 | +10x |
- out <- rbind(adlb_out_h, adlb_out_b_h, adlb_out_l, adlb_out_b_l)+ if (multivar || control$interaction || !"arm" %in% names(variables)) {
|
| 126 | -2x | +424 | +8x |
- } else if (!is.null(worst_flag_high)) {
+ lyt <- lyt %>% |
| 127 | -1x | +425 | +8x |
- adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
+ summarize_row_groups( |
| 128 | -1x | +426 | +8x |
- adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
+ cfun = a_coxreg, |
| 129 | -+ | |||
| 427 | +8x |
-
+ na_str = na_str, |
||
| 130 | -1x | +428 | +8x |
- adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ]+ extra_args = list( |
| 131 | -1x | +429 | +8x |
- adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ]+ variables = variables, at = at, control = control, multivar = multivar,+ |
+
| 430 | +8x | +
+ var_main = if (multivar) multivar else control$interaction |
||
| 132 | +431 |
-
+ )+ |
+ ||
| 432 | ++ |
+ )+ |
+ ||
| 433 | ++ |
+ } else {
+ |
+ ||
| 434 | +! | +
+ if (!is.null(varlabels)) names(varlabels) <- variables$covariates |
||
| 133 | -1x | +435 | +2x |
- out <- rbind(adlb_out_h, adlb_out_b_h)+ lyt <- lyt %>% |
| 134 | -1x | +436 | +2x |
- } else if (!is.null(worst_flag_low)) {
+ analyze_colvars( |
| 135 | -1x | +437 | +2x |
- adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
+ afun = a_coxreg, |
| 136 | -1x | +438 | +2x |
- adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
+ extra_args = list( |
| 137 | -+ | |||
| 439 | +2x |
-
+ variables = variables, at = at, control = control, multivar = multivar, |
||
| 138 | -1x | +440 | +2x |
- adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ]+ var_main = if (multivar) multivar else control$interaction, |
| 139 | -1x | +441 | +2x |
- adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ]+ labelstr = if (is.null(varlabels)) "" else varlabels |
| 140 | +442 |
-
+ ) |
||
| 141 | -1x | +|||
| 443 | +
- out <- rbind(adlb_out_l, adlb_out_b_l)+ ) |
|||
| 142 | +444 |
- }+ } |
||
| 143 | +445 | |||
| 144 | -+ | |||
| 446 | +2x |
- # label+ if (!"arm" %in% names(variables)) control$interaction <- TRUE # special case: univar no arm |
||
| 145 | -5x | +447 | +10x |
- formatters::var_labels(out) <- formatters::var_labels(adlb_f, fill = FALSE)+ if (multivar || control$interaction) { # covariate level effects
+ |
+
| 448 | +8x | +
+ lyt <- lyt %>%+ |
+ ||
| 449 | +8x | +
+ analyze_colvars(+ |
+ ||
| 450 | +8x | +
+ afun = a_coxreg,+ |
+ ||
| 451 | +8x | +
+ extra_args = list(variables = variables, at = at, control = control, multivar = multivar, labelstr = "") |
||
| 146 | +452 |
- # NA+ ) |
||
| 147 | -5x | +|||
| 453 | +
- out+ } |
|||
| 148 | +454 |
- }+ } |
||
| 149 | +455 | |||
| 456 | +10x | +
+ lyt+ |
+ ||
| 150 | +457 |
- #' Helper Function to Analyze Patients for [s_count_abnormal_lab_worsen_by_baseline()]+ } |
| 151 | +1 | ++ |
+ #' Occurrence Counts+ |
+ |
| 2 |
#' |
|||
| 152 | +3 |
#' @description `r lifecycle::badge("stable")`
|
||
| 153 | +4 |
#' |
||
| 154 | +5 |
- #' Helper function to count the number of patients and the fraction of patients according to+ #' Functions for analyzing frequencies and fractions of occurrences for patients with occurrence |
||
| 155 | +6 |
- #' highest post-baseline lab grade variable `.var`, baseline lab grade variable `baseline_var`,+ #' data. Primary analysis variables are the dictionary terms. All occurrences are counted for total |
||
| 156 | +7 |
- #' and the direction of interest specified in `direction_var`.+ #' counts. Multiple occurrences within patient at the lowest term level displayed in the table are |
||
| 157 | +8 | ++ |
+ #' counted only once.+ |
+ |
| 9 |
#' |
|||
| 158 | +10 |
#' @inheritParams argument_convention |
||
| 159 | +11 |
- #' @inheritParams h_adlb_worsen+ #' |
||
| 160 | +12 |
- #' @param baseline_var (`string`)\cr baseline lab grade variable+ #' @note By default, occurrences which don't appear in a given row split are dropped from the table and |
||
| 161 | +13 |
- #'+ #' the occurrences in the table are sorted alphabetically per row split. Therefore, the corresponding layout |
||
| 162 | +14 |
- #' @return `h_worsen_counter()` returns the counts and fraction of patients+ #' needs to use `split_fun = drop_split_levels` in the `split_rows_by` calls. Use `drop = FALSE` if you would |
||
| 163 | +15 |
- #' whose worst post-baseline lab grades are worse than their baseline grades, for+ #' like to show all occurrences. |
||
| 164 | +16 |
- #' post-baseline worst grades "1", "2", "3", "4" and "Any".+ #' |
||
| 165 | +17 |
- #'+ #' @name count_occurrences |
||
| 166 | +18 |
- #' @seealso [abnormal_by_worst_grade_worsen]+ NULL |
||
| 167 | +19 |
- #'+ |
||
| 168 | +20 |
- #' @examples+ #' @describeIn count_occurrences Statistics function which counts number of patients that report an |
||
| 169 | +21 |
- #' library(dplyr)+ #' occurrence. |
||
| 170 | +22 |
#' |
||
| 171 | +23 |
- #' # The direction variable, GRADDR, is based on metadata+ #' @param denom (`string`)\cr choice of denominator for patient proportions. Can be: |
||
| 172 | +24 |
- #' adlb <- tern_ex_adlb %>%+ #' - `N_col`: total number of patients in this column across rows |
||
| 173 | +25 |
- #' mutate(+ #' - `n`: number of patients with any occurrences |
||
| 174 | +26 |
- #' GRADDR = case_when(+ #' |
||
| 175 | +27 |
- #' PARAMCD == "ALT" ~ "B",+ #' @return |
||
| 176 | +28 |
- #' PARAMCD == "CRP" ~ "L",+ #' * `s_count_occurrences()` returns a list with: |
||
| 177 | +29 |
- #' PARAMCD == "IGA" ~ "H"+ #' * `count`: list of counts with one element per occurrence. |
||
| 178 | +30 |
- #' )+ #' * `count_fraction`: list of counts and fractions with one element per occurrence. |
||
| 179 | +31 |
- #' ) %>%+ #' * `fraction`: list of numerators and denominators with one element per occurrence. |
||
| 180 | +32 |
- #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")+ #' |
||
| 181 | +33 |
- #'+ #' @examples |
||
| 182 | +34 |
- #' df <- h_adlb_worsen(+ #' df <- data.frame( |
||
| 183 | +35 |
- #' adlb,+ #' USUBJID = as.character(c(1, 1, 2, 4, 4, 4)), |
||
| 184 | +36 |
- #' worst_flag_low = c("WGRLOFL" = "Y"),
+ #' MHDECOD = c("MH1", "MH2", "MH1", "MH1", "MH1", "MH3")
|
||
| 185 | +37 |
- #' worst_flag_high = c("WGRHIFL" = "Y"),
+ #' ) |
||
| 186 | +38 |
- #' direction_var = "GRADDR"+ #' |
||
| 187 | +39 |
- #' )+ #' N_per_col <- 4L |
||
| 188 | +40 |
#' |
||
| 189 | +41 |
- #' # `h_worsen_counter`+ #' # Count unique occurrences per subject. |
||
| 190 | +42 |
- #' h_worsen_counter(+ #' s_count_occurrences( |
||
| 191 | +43 |
- #' df %>% filter(PARAMCD == "CRP" & GRADDR == "Low"),+ #' df, |
||
| 192 | +44 |
- #' id = "USUBJID",+ #' .N_col = N_per_col, |
||
| 193 | +45 |
- #' .var = "ATOXGR",+ #' .df_row = df, |
||
| 194 | +46 |
- #' baseline_var = "BTOXGR",+ #' .var = "MHDECOD", |
||
| 195 | +47 |
- #' direction_var = "GRADDR"+ #' id = "USUBJID" |
||
| 196 | +48 |
#' ) |
||
| 197 | +49 |
#' |
||
| 198 | +50 |
#' @export |
||
| 199 | +51 |
- h_worsen_counter <- function(df, id, .var, baseline_var, direction_var) {
- |
- ||
| 200 | -17x | -
- checkmate::assert_string(id)- |
- ||
| 201 | -17x | -
- checkmate::assert_string(.var)- |
- ||
| 202 | -17x | -
- checkmate::assert_string(baseline_var)- |
- ||
| 203 | -17x | -
- checkmate::assert_scalar(unique(df[[direction_var]]))- |
- ||
| 204 | -17x | -
- checkmate::assert_subset(unique(df[[direction_var]]), c("High", "Low"))
- |
- ||
| 205 | -17x | -
- assert_df_with_variables(df, list(val = c(id, .var, baseline_var, direction_var)))+ s_count_occurrences <- function(df, |
||
| 206 | +52 |
-
+ denom = c("N_col", "n"),
|
||
| 207 | +53 |
- # remove post-baseline missing- |
- ||
| 208 | -17x | -
- df <- df[df[[.var]] != "<Missing>", ]+ .N_col, # nolint |
||
| 209 | +54 |
-
+ .df_row, |
||
| 210 | +55 |
- # obtain directionality+ drop = TRUE, |
||
| 211 | -17x | +|||
| 56 | +
- direction <- unique(df[[direction_var]])+ .var = "MHDECOD", |
|||
| 212 | +57 |
-
+ id = "USUBJID") {
|
||
| 213 | -17x | +58 | +7x |
- if (direction == "Low") {
+ checkmate::assert_flag(drop) |
| 214 | -10x | +59 | +7x |
- grade <- -1:-4+ assert_df_with_variables(df, list(range = .var, id = id)) |
| 215 | -10x | +60 | +7x |
- worst_grade <- -4+ checkmate::assert_count(.N_col) |
| 216 | +61 | 7x |
- } else if (direction == "High") {
+ checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
|
|
| 217 | +62 | 7x |
- grade <- 1:4+ checkmate::assert_multi_class(df[[id]], classes = c("factor", "character"))
|
|
| 218 | +63 | 7x |
- worst_grade <- 4- |
- |
| 219 | -- |
- }+ denom <- match.arg(denom) |
||
| 220 | +64 | |||
| 221 | -17x | -
- if (nrow(df) > 0) {
- |
- ||
| 222 | -17x | +65 | +7x |
- by_grade <- lapply(grade, function(i) {
+ occurrences <- if (drop) {
|
| 223 | +66 |
- # filter baseline values that is less than i or <Missing>- |
- ||
| 224 | -68x | -
- df_temp <- df[df[[baseline_var]] %in% c((i + sign(i) * -1):(-1 * worst_grade), "<Missing>"), ]+ # Note that we don't try to preserve original level order here since a) that would required |
||
| 225 | +67 |
- # num: number of patients with post-baseline worst lab equal to i+ # more time to look up in large original levels and b) that would fail for character input variable. |
||
| 226 | -68x | +68 | +6x |
- num <- length(unique(df_temp[df_temp[[.var]] %in% i, id, drop = TRUE]))+ occurrence_levels <- sort(unique(.df_row[[.var]])) |
| 227 | -+ | |||
| 69 | +6x |
- # denom: number of patients with baseline values less than i or <missing> and post-baseline in the same direction+ if (length(occurrence_levels) == 0) {
|
||
| 228 | -68x | +70 | +1x |
- denom <- length(unique(df_temp[[id]]))+ stop( |
| 229 | -68x | +71 | +1x |
- rm(df_temp)+ "no empty `.df_row` input allowed when `drop = TRUE`,", |
| 230 | -68x | +72 | +1x |
- c(num = num, denom = denom)+ " please use `split_fun = drop_split_levels` in the `rtables` `split_rows_by` calls" |
| 231 | +73 |
- })+ ) |
||
| 232 | +74 |
- } else {
- |
- ||
| 233 | -! | -
- by_grade <- lapply(1, function(i) {
+ } |
||
| 234 | -! | +|||
| 75 | +5x |
- c(num = 0, denom = 0)+ factor(df[[.var]], levels = occurrence_levels) |
||
| 235 | +76 |
- })+ } else {
|
||
| 236 | -+ | |||
| 77 | +1x |
- }+ df[[.var]] |
||
| 237 | +78 |
-
+ } |
||
| 238 | -17x | -
- names(by_grade) <- as.character(seq_along(by_grade))- |
- ||
| 239 | -+ | 79 | +6x |
-
+ ids <- factor(df[[id]]) |
| 240 | -+ | |||
| 80 | +6x |
- # baseline grade less 4 or missing+ dn <- switch(denom, |
||
| 241 | -17x | +81 | +6x |
- df_temp <- df[!df[[baseline_var]] %in% worst_grade, ]+ n = nlevels(ids), |
| 242 | -+ | |||
| 82 | +6x |
-
+ N_col = .N_col |
||
| 243 | +83 |
- # denom: number of patients with baseline values less than 4 or <missing> and post-baseline in the same direction+ ) |
||
| 244 | -17x | +84 | +6x |
- denom <- length(unique(df_temp[, id, drop = TRUE]))+ has_occurrence_per_id <- table(occurrences, ids) > 0 |
| 245 | -+ | |||
| 85 | +6x |
-
+ n_ids_per_occurrence <- as.list(rowSums(has_occurrence_per_id)) |
||
| 246 | -+ | |||
| 86 | +6x |
- # condition 1: missing baseline and in the direction of abnormality+ list( |
||
| 247 | -17x | +87 | +6x |
- con1 <- which(df_temp[[baseline_var]] == "<Missing>" & df_temp[[.var]] %in% grade)+ count = n_ids_per_occurrence, |
| 248 | -17x | +88 | +6x |
- df_temp_nm <- df_temp[which(df_temp[[baseline_var]] != "<Missing>" & df_temp[[.var]] %in% grade), ]+ count_fraction = lapply( |
| 249 | -+ | |||
| 89 | +6x |
-
+ n_ids_per_occurrence, |
||
| 250 | -+ | |||
| 90 | +6x |
- # condition 2: if post-baseline values are present then post-baseline values must be worse than baseline+ function(i, denom) {
|
||
| 251 | -17x | +91 | +33x |
- if (direction == "Low") {
+ if (i == 0 && denom == 0) {
|
| 252 | -10x | +|||
| 92 | +! |
- con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) < as.numeric(as.character(df_temp_nm[[baseline_var]])))+ c(0, 0) |
||
| 253 | +93 |
- } else {
+ } else {
|
||
| 254 | -7x | -
- con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) > as.numeric(as.character(df_temp_nm[[baseline_var]])))- |
- ||
| 255 | -+ | 94 | +33x |
- }+ c(i, i / denom) |
| 256 | +95 |
-
+ } |
||
| 257 | +96 |
- # number of patients satisfy either conditions 1 or 2+ }, |
||
| 258 | -17x | +97 | +6x |
- num <- length(unique(df_temp[union(con1, con2), id, drop = TRUE]))+ denom = dn |
| 259 | +98 |
-
+ ), |
||
| 260 | -17x | +99 | +6x |
- list(fraction = c(by_grade, list("Any" = c(num = num, denom = denom))))
+ fraction = lapply( |
| 261 | -+ | |||
| 100 | +6x |
- }+ n_ids_per_occurrence, |
||
| 262 | -+ | |||
| 101 | +6x |
-
+ function(i, denom) c("num" = i, "denom" = denom),
|
||
| 263 | -+ | |||
| 102 | +6x |
- #' @describeIn abnormal_by_worst_grade_worsen Statistics function for patients whose worst post-baseline+ denom = dn |
||
| 264 | +103 |
- #' lab grades are worse than their baseline grades.+ ) |
||
| 265 | +104 |
- #'+ ) |
||
| 266 | +105 |
- #' @param variables (named `list` of `string`)\cr list of additional analysis variables including:+ } |
||
| 267 | +106 |
- #' * `id` (`string`)\cr subject variable name.+ |
||
| 268 | +107 |
- #' * `baseline_var` (`string`)\cr name of the data column containing baseline toxicity variable.+ #' @describeIn count_occurrences Formatted analysis function which is used as `afun` |
||
| 269 | +108 |
- #' * `direction_var` (`string`)\cr see `direction_var` for more details.+ #' in `count_occurrences()`. |
||
| 270 | +109 |
#' |
||
| 271 | +110 |
#' @return |
||
| 272 | -- |
- #' * `s_count_abnormal_lab_worsen_by_baseline()` returns the counts and fraction of patients whose worst- |
- ||
| 273 | -- |
- #' post-baseline lab grades are worse than their baseline grades, for post-baseline worst grades- |
- ||
| 274 | +111 |
- #' "1", "2", "3", "4" and "Any".+ #' * `a_count_occurrences()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 275 | +112 |
#' |
||
| 276 | +113 |
#' @examples |
||
| 277 | +114 |
- #' library(dplyr)+ #' # We need to ungroup `count_fraction` first so that the `rtables` formatting |
||
| 278 | +115 |
- #'+ #' # function `format_count_fraction()` can be applied correctly. |
||
| 279 | +116 |
- #' # The direction variable, GRADDR, is based on metadata+ #' afun <- make_afun(a_count_occurrences, .ungroup_stats = c("count", "count_fraction", "fraction"))
|
||
| 280 | +117 |
- #' adlb <- tern_ex_adlb %>%+ #' afun( |
||
| 281 | +118 |
- #' mutate(+ #' df, |
||
| 282 | +119 |
- #' GRADDR = case_when(+ #' .N_col = N_per_col, |
||
| 283 | +120 |
- #' PARAMCD == "ALT" ~ "B",+ #' .df_row = df, |
||
| 284 | +121 |
- #' PARAMCD == "CRP" ~ "L",+ #' .var = "MHDECOD", |
||
| 285 | +122 |
- #' PARAMCD == "IGA" ~ "H"+ #' id = "USUBJID" |
||
| 286 | +123 |
- #' )+ #' ) |
||
| 287 | +124 |
- #' ) %>%+ #' |
||
| 288 | +125 |
- #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")+ #' @export |
||
| 289 | +126 |
- #'+ a_count_occurrences <- make_afun( |
||
| 290 | +127 |
- #' df <- h_adlb_worsen(+ s_count_occurrences, |
||
| 291 | +128 |
- #' adlb,+ .formats = c(count = "xx", count_fraction = format_count_fraction_fixed_dp, fraction = format_fraction_fixed_dp) |
||
| 292 | +129 |
- #' worst_flag_low = c("WGRLOFL" = "Y"),
+ ) |
||
| 293 | +130 |
- #' worst_flag_high = c("WGRHIFL" = "Y"),
+
|
||
| 294 | +131 |
- #' direction_var = "GRADDR"+ #' @describeIn count_occurrences Layout-creating function which can take statistics function arguments |
||
| 295 | +132 |
- #' )+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 296 | +133 |
#' |
||
| 297 | -- |
- #' @keywords internal- |
- ||
| 298 | +134 |
- s_count_abnormal_lab_worsen_by_baseline <- function(df, # nolint+ #' @return |
||
| 299 | +135 |
- .var = "ATOXGR",+ #' * `count_occurrences()` returns a layout object suitable for passing to further layouting functions, |
||
| 300 | +136 |
- variables = list(+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 301 | +137 |
- id = "USUBJID",+ #' the statistics from `s_count_occurrences()` to the table layout. |
||
| 302 | +138 |
- baseline_var = "BTOXGR",+ #' |
||
| 303 | +139 |
- direction_var = "GRADDR"+ #' @examples |
||
| 304 | +140 |
- )) {
- |
- ||
| 305 | -1x | -
- checkmate::assert_string(.var)- |
- ||
| 306 | -1x | -
- checkmate::assert_set_equal(names(variables), c("id", "baseline_var", "direction_var"))
- |
- ||
| 307 | -1x | -
- checkmate::assert_string(variables$id)- |
- ||
| 308 | -1x | -
- checkmate::assert_string(variables$baseline_var)- |
- ||
| 309 | -1x | -
- checkmate::assert_string(variables$direction_var)- |
- ||
| 310 | -1x | -
- assert_df_with_variables(df, c(aval = .var, variables[1:3]))- |
- ||
| 311 | -1x | -
- assert_list_of_variables(variables)+ #' library(dplyr) |
||
| 312 | +141 | - - | -||
| 313 | -1x | -
- h_worsen_counter(df, variables$id, .var, variables$baseline_var, variables$direction_var)+ #' df <- data.frame( |
||
| 314 | +142 |
- }+ #' USUBJID = as.character(c( |
||
| 315 | +143 |
-
+ #' 1, 1, 2, 4, 4, 4, |
||
| 316 | +144 |
-
+ #' 6, 6, 6, 7, 7, 8 |
||
| 317 | +145 |
- #' @describeIn abnormal_by_worst_grade_worsen Formatted analysis function which is used as `afun`+ #' )), |
||
| 318 | +146 |
- #' in `count_abnormal_lab_worsen_by_baseline()`.+ #' MHDECOD = c( |
||
| 319 | +147 |
- #'+ #' "MH1", "MH2", "MH1", "MH1", "MH1", "MH3", |
||
| 320 | +148 |
- #' @return+ #' "MH2", "MH2", "MH3", "MH1", "MH2", "MH4" |
||
| 321 | +149 |
- #' * `a_count_abnormal_lab_worsen_by_baseline()` returns the corresponding list with+ #' ), |
||
| 322 | +150 |
- #' formatted [rtables::CellValue()].+ #' ARM = rep(c("A", "B"), each = 6)
|
||
| 323 | +151 |
- #'+ #' ) |
||
| 324 | +152 |
- #' @keywords internal+ #' df_adsl <- df %>% |
||
| 325 | +153 |
- a_count_abnormal_lab_worsen_by_baseline <- make_afun( # nolint+ #' select(USUBJID, ARM) %>% |
||
| 326 | +154 |
- s_count_abnormal_lab_worsen_by_baseline,+ #' unique() |
||
| 327 | +155 |
- .formats = c(fraction = format_fraction),+ #' |
||
| 328 | +156 |
- .ungroup_stats = "fraction"+ #' # Create table layout |
||
| 329 | +157 |
- )+ #' lyt <- basic_table() %>% |
||
| 330 | +158 |
-
+ #' split_cols_by("ARM") %>%
|
||
| 331 | +159 |
- #' @describeIn abnormal_by_worst_grade_worsen Layout-creating function which can take statistics function+ #' add_colcounts() %>% |
||
| 332 | +160 |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' count_occurrences(vars = "MHDECOD", .stats = c("count_fraction"))
|
||
| 333 | +161 |
#' |
||
| 334 | +162 |
- #' @return+ #' # Apply table layout to data and produce `rtable` object |
||
| 335 | +163 |
- #' * `count_abnormal_lab_worsen_by_baseline()` returns a layout object suitable for passing to further layouting+ #' lyt %>% |
||
| 336 | +164 |
- #' functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted+ #' build_table(df, alt_counts_df = df_adsl) %>% |
||
| 337 | +165 |
- #' rows containing the statistics from `s_count_abnormal_lab_worsen_by_baseline()` to the table layout.+ #' prune_table() |
||
| 338 | +166 |
#' |
||
| 339 | -- |
- #' @examples- |
- ||
| 340 | +167 |
- #' basic_table() %>%+ #' @export |
||
| 341 | +168 |
- #' split_cols_by("ARMCD") %>%
+ count_occurrences <- function(lyt, |
||
| 342 | +169 |
- #' add_colcounts() %>%+ vars, |
||
| 343 | +170 |
- #' split_rows_by("PARAMCD") %>%
+ var_labels = vars, |
||
| 344 | +171 |
- #' split_rows_by("GRADDR") %>%
+ show_labels = "hidden", |
||
| 345 | +172 |
- #' count_abnormal_lab_worsen_by_baseline(+ riskdiff = FALSE, |
||
| 346 | +173 |
- #' var = "ATOXGR",+ na_str = NA_character_, |
||
| 347 | +174 |
- #' variables = list(+ nested = TRUE, |
||
| 348 | +175 |
- #' id = "USUBJID",+ ..., |
||
| 349 | +176 |
- #' baseline_var = "BTOXGR",+ table_names = vars, |
||
| 350 | +177 |
- #' direction_var = "GRADDR"+ .stats = "count_fraction", |
||
| 351 | +178 |
- #' )+ .formats = NULL, |
||
| 352 | +179 |
- #' ) %>%+ .labels = NULL, |
||
| 353 | +180 |
- #' append_topleft("Direction of Abnormality") %>%
+ .indent_mods = NULL) {
|
||
| 354 | -+ | |||
| 181 | +7x |
- #' build_table(df = df, alt_counts_df = tern_ex_adsl)+ checkmate::assert_flag(riskdiff) |
||
| 355 | +182 |
- #'+ |
||
| 356 | -+ | |||
| 183 | +7x |
- #' @export+ afun <- make_afun( |
||
| 357 | -+ | |||
| 184 | +7x |
- count_abnormal_lab_worsen_by_baseline <- function(lyt, # nolint+ a_count_occurrences, |
||
| 358 | -+ | |||
| 185 | +7x |
- var,+ .stats = .stats, |
||
| 359 | -+ | |||
| 186 | +7x |
- nested = TRUE,+ .formats = .formats, |
||
| 360 | -+ | |||
| 187 | +7x |
- ...,+ .labels = .labels, |
||
| 361 | -+ | |||
| 188 | +7x |
- table_names = NULL,+ .indent_mods = .indent_mods, |
||
| 362 | -+ | |||
| 189 | +7x |
- .stats = NULL,+ .ungroup_stats = .stats |
||
| 363 | +190 |
- .formats = NULL,+ ) |
||
| 364 | +191 |
- .labels = NULL,+ |
||
| 365 | -+ | |||
| 192 | +7x |
- .indent_mods = NULL) {
+ extra_args <- if (isFALSE(riskdiff)) {
|
||
| 366 | -1x | +193 | +6x |
- checkmate::assert_string(var)+ list(...) |
| 367 | +194 |
-
+ } else {
|
||
| 368 | +195 | 1x |
- afun <- make_afun(+ list( |
|
| 369 | +196 | 1x |
- a_count_abnormal_lab_worsen_by_baseline,+ afun = list("s_count_occurrences" = afun),
|
|
| 370 | +197 | 1x |
- .stats = .stats,+ .stats = .stats, |
|
| 371 | +198 | 1x |
- .formats = .formats,+ .indent_mods = .indent_mods, |
|
| 372 | +199 | 1x |
- .labels = .labels,+ s_args = list(...) |
|
| 373 | -1x | +|||
| 200 | +
- .indent_mods = .indent_mods+ ) |
|||
| 374 | +201 |
- )+ } |
||
| 375 | +202 | |||
| 376 | -1x | +203 | +7x |
- lyt <- analyze(+ analyze( |
| 377 | -1x | +204 | +7x |
lyt = lyt, |
| 378 | -1x | +205 | +7x |
- vars = var,+ vars = vars, |
| 379 | -1x | +206 | +7x |
- afun = afun,+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff), |
| 380 | -1x | +207 | +7x |
- nested = nested,+ var_labels = var_labels, |
| 381 | -1x | +208 | +7x |
- extra_args = list(...),+ show_labels = show_labels, |
| 382 | -1x | +209 | +7x |
- show_labels = "hidden"+ table_names = table_names, |
| 383 | -+ | |||
| 210 | +7x |
- )+ na_str = na_str, |
||
| 384 | -+ | |||
| 211 | +7x |
-
+ nested = nested, |
||
| 385 | -1x | +212 | +7x |
- lyt+ extra_args = extra_args |
| 386 | +213 | ++ |
+ )+ |
+ |
| 214 |
}@@ -54468,14 +54476,14 @@ tern coverage - 94.83% |
| 1 |
- #' Patient Counts with Abnormal Range Values by Baseline Status+ #' Estimation of Proportions |
||
| 5 |
- #' Primary analysis variable `.var` indicates the abnormal range result (`character` or `factor`), and additional+ #' Estimate the proportion of responders within a studied population. |
||
| 6 |
- #' analysis variables are `id` (`character` or `factor`) and `baseline` (`character` or `factor`). For each+ #' |
||
| 7 |
- #' direction specified in `abnormal` (e.g. high or low) we condition on baseline range result and count+ #' @inheritParams argument_convention |
||
| 8 |
- #' patients in the numerator and denominator as follows:+ #' |
||
| 9 |
- #' * `Not <Abnormal>`+ #' @seealso [h_proportions] |
||
| 10 |
- #' * `denom`: the number of patients without abnormality at baseline (excluding those with missing baseline)+ #' |
||
| 11 |
- #' * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline+ #' @name estimate_proportions |
||
| 12 |
- #' * `<Abnormal>`+ NULL |
||
| 13 |
- #' * `denom`: the number of patients with abnormality at baseline+ |
||
| 14 |
- #' * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline+ #' @describeIn estimate_proportions Statistics function estimating a |
||
| 15 |
- #' * `Total`+ #' proportion along with its confidence interval. |
||
| 16 |
- #' * `denom`: the number of patients with at least one valid measurement post-baseline+ #' |
||
| 17 |
- #' * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline+ #' @inheritParams prop_strat_wilson |
||
| 18 |
- #'+ #' @param df (`logical` or `data.frame`)\cr if only a logical vector is used, |
||
| 19 |
- #' @inheritParams argument_convention+ #' it indicates whether each subject is a responder or not. `TRUE` represents |
||
| 20 |
- #' @param abnormal (`character`)\cr identifying the abnormal range level(s) in `.var`.+ #' a successful outcome. If a `data.frame` is provided, also the `strata` variable |
||
| 21 |
- #'+ #' names must be provided in `variables` as a list element with the strata strings. |
||
| 22 |
- #' @note+ #' In the case of `data.frame`, the logical vector of responses must be indicated as a |
||
| 23 |
- #' * `df` should be filtered to include only post-baseline records.+ #' variable name in `.var`. |
||
| 24 |
- #' * If the baseline variable or analysis variable contains `NA`, it is expected that `NA` has been+ #' @param method (`string`)\cr the method used to construct the confidence interval |
||
| 25 |
- #' conveyed to `na_level` appropriately beforehand with [df_explicit_na()] or [explicit_na()].+ #' for proportion of successful outcomes; one of `waldcc`, `wald`, `clopper-pearson`, |
||
| 26 |
- #'+ #' `wilson`, `wilsonc`, `strat_wilson`, `strat_wilsonc`, `agresti-coull` or `jeffreys`. |
||
| 27 |
- #' @seealso Relevant description function [d_count_abnormal_by_baseline()].+ #' @param long (`flag`)\cr a long description is required. |
||
| 29 |
- #' @name abnormal_by_baseline+ #' @return |
||
| 30 |
- NULL+ #' * `s_proportion()` returns statistics `n_prop` (`n` and proportion) and `prop_ci` (proportion CI) for a |
||
| 31 |
-
+ #' given variable. |
||
| 32 |
- #' Description Function for [s_count_abnormal_by_baseline()]+ #' |
||
| 33 |
- #'+ #' @examples |
||
| 34 |
- #' @description `r lifecycle::badge("stable")`
+ #' # Case with only logical vector. |
||
| 35 |
- #'+ #' rsp_v <- c(1, 0, 1, 0, 1, 1, 0, 0) |
||
| 36 |
- #' Description function that produces the labels for [s_count_abnormal_by_baseline()].+ #' s_proportion(rsp_v) |
||
| 38 |
- #' @inheritParams abnormal_by_baseline+ #' # Example for Stratified Wilson CI |
||
| 39 |
- #'+ #' nex <- 100 # Number of example rows |
||
| 40 |
- #' @return Abnormal category labels for [s_count_abnormal_by_baseline()].+ #' dta <- data.frame( |
||
| 41 |
- #'+ #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE), |
||
| 42 |
- #' @examples+ #' "grp" = sample(c("A", "B"), nex, TRUE),
|
||
| 43 |
- #' d_count_abnormal_by_baseline("LOW")
+ #' "f1" = sample(c("a1", "a2"), nex, TRUE),
|
||
| 44 |
- #'+ #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
|
||
| 45 |
- #' @export+ #' stringsAsFactors = TRUE |
||
| 46 |
- d_count_abnormal_by_baseline <- function(abnormal) {
+ #' ) |
||
| 47 | -7x | +
- not_abn_name <- paste("Not", tolower(abnormal))
+ #' |
|
| 48 | -7x | +
- abn_name <- paste0(toupper(substr(abnormal, 1, 1)), tolower(substring(abnormal, 2)))+ #' s_proportion( |
|
| 49 | -7x | +
- total_name <- "Total"+ #' df = dta, |
|
| 50 |
-
+ #' .var = "rsp", |
||
| 51 | -7x | +
- list(+ #' variables = list(strata = c("f1", "f2")),
|
|
| 52 | -7x | +
- not_abnormal = not_abn_name,+ #' conf_level = 0.90, |
|
| 53 | -7x | +
- abnormal = abn_name,+ #' method = "strat_wilson" |
|
| 54 | -7x | +
- total = total_name+ #' ) |
|
| 55 |
- )+ #' |
||
| 56 |
- }+ #' @export |
||
| 57 |
-
+ s_proportion <- function(df, |
||
| 58 |
- #' @describeIn abnormal_by_baseline Statistics function for a single `abnormal` level.+ .var, |
||
| 59 |
- #'+ conf_level = 0.95, |
||
| 60 |
- #' @param na_level (`string`)\cr the explicit `na_level` argument you used in the pre-processing steps (maybe with+ method = c( |
||
| 61 |
- #' [df_explicit_na()]). The default is `"<Missing>"`.+ "waldcc", "wald", "clopper-pearson", |
||
| 62 |
- #'+ "wilson", "wilsonc", "strat_wilson", "strat_wilsonc", |
||
| 63 |
- #' @return+ "agresti-coull", "jeffreys" |
||
| 64 |
- #' * `s_count_abnormal_by_baseline()` returns statistic `fraction` which is a named list with 3 labeled elements:+ ), |
||
| 65 |
- #' `not_abnormal`, `abnormal`, and `total`. Each element contains a vector with `num` and `denom` patient counts.+ weights = NULL, |
||
| 66 |
- #'+ max_iterations = 50, |
||
| 67 |
- #'+ variables = list(strata = NULL), |
||
| 68 |
- #' @keywords internal+ long = FALSE) {
|
||
| 69 | -+ | 125x |
- s_count_abnormal_by_baseline <- function(df,+ method <- match.arg(method) |
| 70 | -+ | 125x |
- .var,+ checkmate::assert_flag(long) |
| 71 | -+ | 125x |
- abnormal,+ assert_proportion_value(conf_level) |
| 72 |
- na_level = "<Missing>",+ |
||
| 73 | -+ | 125x |
- variables = list(id = "USUBJID", baseline = "BNRIND")) {
+ if (!is.null(variables$strata)) {
|
| 74 | -5x | +
- checkmate::assert_string(.var)+ # Checks for strata |
|
| 75 | -5x | +! |
- checkmate::assert_string(abnormal)+ if (missing(df)) stop("When doing stratified analysis a data.frame with specific columns is needed.")
|
| 76 | -5x | +! |
- checkmate::assert_string(na_level)+ strata_colnames <- variables$strata |
| 77 | -5x | +! |
- assert_df_with_variables(df, c(range = .var, variables))+ checkmate::assert_character(strata_colnames, null.ok = FALSE) |
| 78 | -5x | +! |
- checkmate::assert_subset(names(variables), c("id", "baseline"))
+ strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames) |
| 79 | -5x | +! |
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ assert_df_with_variables(df, strata_vars) |
| 80 | -5x | +
- checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
+
|
|
| 81 | -5x | +! |
- checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
+ strata <- interaction(df[strata_colnames]) |
| 82 | -+ | ! |
-
+ strata <- as.factor(strata) |
| 83 |
- # If input is passed as character, changed to factor+ |
||
| 84 | -5x | +
- df[[.var]] <- as_factor_keep_attributes(df[[.var]], na_level = na_level)+ # Pushing down checks to prop_strat_wilson |
|
| 85 | -5x | +125x |
- df[[variables$baseline]] <- as_factor_keep_attributes(df[[variables$baseline]], na_level = na_level)+ } else if (checkmate::test_subset(method, c("strat_wilson", "strat_wilsonc"))) {
|
| 86 | -+ | ! |
-
+ stop("To use stratified methods you need to specify the strata variables.")
|
| 87 | -5x | +
- assert_valid_factor(df[[.var]], any.missing = FALSE)+ } |
|
| 88 | -4x | +125x |
- assert_valid_factor(df[[variables$baseline]], any.missing = FALSE)+ if (checkmate::test_atomic_vector(df)) {
|
| 89 | -+ | 125x |
-
+ rsp <- as.logical(df) |
| 90 |
- # Keep only records with valid analysis value.+ } else {
|
||
| 91 | -3x | +! |
- df <- df[df[[.var]] != na_level, ]+ rsp <- as.logical(df[[.var]]) |
| 92 |
-
+ } |
||
| 93 | -3x | +125x |
- anl <- data.frame(+ n <- sum(rsp) |
| 94 | -3x | +125x |
- id = df[[variables$id]],+ p_hat <- mean(rsp) |
| 95 | -3x | +
- var = df[[.var]],+ |
|
| 96 | -3x | +125x |
- baseline = df[[variables$baseline]],+ prop_ci <- switch(method, |
| 97 | -3x | +125x |
- stringsAsFactors = FALSE+ "clopper-pearson" = prop_clopper_pearson(rsp, conf_level), |
| 98 | -+ | 125x |
- )+ "wilson" = prop_wilson(rsp, conf_level), |
| 99 | -+ | 125x |
-
+ "wilsonc" = prop_wilson(rsp, conf_level, correct = TRUE), |
| 100 | -+ | 125x |
- # Total:+ "strat_wilson" = prop_strat_wilson(rsp, |
| 101 | -+ | 125x |
- # - Patients in denominator: have at least one valid measurement post-baseline.+ strata, |
| 102 | -+ | 125x |
- # - Patients in numerator: have at least one abnormality.+ weights, |
| 103 | -3x | +125x |
- total_denom <- length(unique(anl$id))+ conf_level, |
| 104 | -3x | +125x |
- total_num <- length(unique(anl$id[anl$var == abnormal]))+ max_iterations, |
| 105 | -+ | 125x |
-
+ correct = FALSE |
| 106 | -+ | 125x |
- # Baseline NA records are counted only in total rows.+ )$conf_int, |
| 107 | -3x | +125x |
- anl <- anl[anl$baseline != na_level, ]+ "strat_wilsonc" = prop_strat_wilson(rsp, |
| 108 | -+ | 125x |
-
+ strata, |
| 109 | -+ | 125x |
- # Abnormal:+ weights, |
| 110 | -+ | 125x |
- # - Patients in denominator: have abnormality at baseline.+ conf_level, |
| 111 | -+ | 125x |
- # - Patients in numerator: have abnormality at baseline AND+ max_iterations, |
| 112 | -+ | 125x |
- # have at least one abnormality post-baseline.+ correct = TRUE |
| 113 | -3x | +125x |
- abn_denom <- length(unique(anl$id[anl$baseline == abnormal]))+ )$conf_int, |
| 114 | -3x | +125x |
- abn_num <- length(unique(anl$id[anl$baseline == abnormal & anl$var == abnormal]))+ "wald" = prop_wald(rsp, conf_level), |
| 115 | -+ | 125x |
-
+ "waldcc" = prop_wald(rsp, conf_level, correct = TRUE), |
| 116 | -+ | 125x |
- # Not abnormal:+ "agresti-coull" = prop_agresti_coull(rsp, conf_level), |
| 117 | -+ | 125x |
- # - Patients in denominator: do not have abnormality at baseline.+ "jeffreys" = prop_jeffreys(rsp, conf_level) |
| 118 |
- # - Patients in numerator: do not have abnormality at baseline AND+ ) |
||
| 119 |
- # have at least one abnormality post-baseline.+ |
||
| 120 | -3x | +125x |
- not_abn_denom <- length(unique(anl$id[anl$baseline != abnormal]))+ list( |
| 121 | -3x | +125x |
- not_abn_num <- length(unique(anl$id[anl$baseline != abnormal & anl$var == abnormal]))+ "n_prop" = formatters::with_label(c(n, p_hat), "Responders"), |
| 122 | -+ | 125x |
-
+ "prop_ci" = formatters::with_label( |
| 123 | -3x | +125x |
- labels <- d_count_abnormal_by_baseline(abnormal)+ x = 100 * prop_ci, label = d_proportion(conf_level, method, long = long) |
| 124 | -3x | +
- list(fraction = list(+ ) |
|
| 125 | -3x | +
- not_abnormal = formatters::with_label(c(num = not_abn_num, denom = not_abn_denom), labels$not_abnormal),+ ) |
|
| 126 | -3x | +
- abnormal = formatters::with_label(c(num = abn_num, denom = abn_denom), labels$abnormal),+ } |
|
| 127 | -3x | +
- total = formatters::with_label(c(num = total_num, denom = total_denom), labels$total)+ |
|
| 128 |
- ))+ #' @describeIn estimate_proportions Formatted analysis function which is used as `afun` |
||
| 129 |
- }+ #' in `estimate_proportion()`. |
||
| 130 |
-
+ #' |
||
| 131 |
- #' @describeIn abnormal_by_baseline Formatted analysis function which is used as `afun`+ #' @return |
||
| 132 |
- #' in `count_abnormal_by_baseline()`.+ #' * `a_proportion()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 134 |
- #' @return+ #' @export |
||
| 135 |
- #' * `a_count_abnormal_by_baseline()` returns the corresponding list with formatted [rtables::CellValue()].+ a_proportion <- make_afun( |
||
| 136 |
- #'+ s_proportion, |
||
| 137 |
- #'+ .formats = c(n_prop = "xx (xx.x%)", prop_ci = "(xx.x, xx.x)") |
||
| 138 |
- #' @keywords internal+ ) |
||
| 139 |
- a_count_abnormal_by_baseline <- make_afun(+ |
||
| 140 |
- s_count_abnormal_by_baseline,+ #' @describeIn estimate_proportions Layout-creating function which can take statistics function arguments |
||
| 141 |
- .formats = c(fraction = format_fraction)+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 142 |
- )+ #' |
||
| 143 |
-
+ #' @param ... other arguments are ultimately conveyed to [s_proportion()]. |
||
| 144 |
- #' @describeIn abnormal_by_baseline Layout-creating function which can take statistics function arguments+ #' |
||
| 145 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' @return |
||
| 146 |
- #'+ #' * `estimate_proportion()` returns a layout object suitable for passing to further layouting functions, |
||
| 147 |
- #' @return+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 148 |
- #' * `count_abnormal_by_baseline()` returns a layout object suitable for passing to further layouting functions,+ #' the statistics from `s_proportion()` to the table layout. |
||
| 149 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 150 |
- #' the statistics from `s_count_abnormal_by_baseline()` to the table layout.+ #' @examples |
||
| 151 |
- #'+ #' dta_test <- data.frame( |
||
| 152 |
- #' @examples+ #' USUBJID = paste0("S", 1:12),
|
||
| 153 |
- #' df <- data.frame(+ #' ARM = rep(LETTERS[1:3], each = 4), |
||
| 154 |
- #' USUBJID = as.character(c(1:6)),+ #' AVAL = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0)) |
||
| 155 |
- #' ANRIND = factor(c(rep("LOW", 4), "NORMAL", "HIGH")),
+ #' ) |
||
| 156 |
- #' BNRIND = factor(c("LOW", "NORMAL", "HIGH", NA, "LOW", "NORMAL"))
+ #' |
||
| 157 |
- #' )+ #' basic_table() %>% |
||
| 158 |
- #' df <- df_explicit_na(df)+ #' split_cols_by("ARM") %>%
|
||
| 159 |
- #'+ #' estimate_proportion(vars = "AVAL") %>% |
||
| 160 |
- #' # Layout creating function.+ #' build_table(df = dta_test) |
||
| 161 |
- #' basic_table() %>%+ #' |
||
| 162 |
- #' count_abnormal_by_baseline(var = "ANRIND", abnormal = c(High = "HIGH")) %>%+ #' @export |
||
| 163 |
- #' build_table(df)+ estimate_proportion <- function(lyt, |
||
| 164 |
- #'+ vars, |
||
| 165 |
- #' # Passing of statistics function and formatting arguments.+ na_str = NA_character_, |
||
| 166 |
- #' df2 <- data.frame(+ nested = TRUE, |
||
| 167 |
- #' ID = as.character(c(1, 2, 3, 4)),+ ..., |
||
| 168 |
- #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
+ show_labels = "hidden", |
||
| 169 |
- #' BLRANGE = factor(c("LOW", "HIGH", "HIGH", "NORMAL"))
+ table_names = vars, |
||
| 170 |
- #' )+ .stats = NULL, |
||
| 171 |
- #'+ .formats = NULL, |
||
| 172 |
- #' basic_table() %>%+ .labels = NULL, |
||
| 173 |
- #' count_abnormal_by_baseline(+ .indent_mods = NULL) {
|
||
| 174 | -+ | 3x |
- #' var = "RANGE",+ afun <- make_afun( |
| 175 | -+ | 3x |
- #' abnormal = c(Low = "LOW"),+ a_proportion, |
| 176 | -+ | 3x |
- #' variables = list(id = "ID", baseline = "BLRANGE"),+ .stats = .stats, |
| 177 | -+ | 3x |
- #' .formats = c(fraction = "xx / xx"),+ .formats = .formats, |
| 178 | -+ | 3x |
- #' .indent_mods = c(fraction = 2L)+ .labels = .labels, |
| 179 | -+ | 3x |
- #' ) %>%+ .indent_mods = .indent_mods |
| 180 |
- #' build_table(df2)+ ) |
||
| 181 | -+ | 3x |
- #'+ analyze( |
| 182 | -+ | 3x |
- #' @export+ lyt, |
| 183 | -+ | 3x |
- count_abnormal_by_baseline <- function(lyt,+ vars, |
| 184 | -+ | 3x |
- var,+ afun = afun, |
| 185 | -+ | 3x |
- abnormal,+ na_str = na_str, |
| 186 | -+ | 3x |
- nested = TRUE,+ nested = nested, |
| 187 | -+ | 3x |
- ...,+ extra_args = list(...), |
| 188 | -+ | 3x |
- table_names = abnormal,+ show_labels = show_labels, |
| 189 | -+ | 3x |
- .stats = NULL,+ table_names = table_names |
| 190 |
- .formats = NULL,+ ) |
||
| 191 |
- .labels = NULL,+ } |
||
| 192 |
- .indent_mods = NULL) {
+
|
||
| 193 | -2x | +
- checkmate::assert_character(abnormal, len = length(table_names), names = "named")+ #' Helper Functions for Calculating Proportion Confidence Intervals |
|
| 194 | -2x | +
- checkmate::assert_string(var)+ #' |
|
| 195 | -2x | +
- afun <- make_afun(+ #' @description `r lifecycle::badge("stable")`
|
|
| 196 | -2x | +
- a_count_abnormal_by_baseline,+ #' |
|
| 197 | -2x | +
- .stats = .stats,+ #' Functions to calculate different proportion confidence intervals for use in [estimate_proportion()]. |
|
| 198 | -2x | +
- .formats = .formats,+ #' |
|
| 199 | -2x | +
- .labels = .labels,+ #' @inheritParams argument_convention |
|
| 200 | -2x | +
- .indent_mods = .indent_mods,+ #' @inheritParams estimate_proportions |
|
| 201 | -2x | +
- .ungroup_stats = "fraction"+ #' |
|
| 202 |
- )+ #' @return Confidence interval of a proportion. |
||
| 203 | -2x | +
- for (i in seq_along(abnormal)) {
+ #' |
|
| 204 | -4x | +
- abn <- abnormal[i]+ #' @seealso [estimate_proportions], descriptive function [d_proportion()], |
|
| 205 | -4x | +
- lyt <- analyze(+ #' and helper functions [strata_normal_quantile()] and [update_weights_strat_wilson()]. |
|
| 206 | -4x | +
- lyt = lyt,+ #' |
|
| 207 | -4x | +
- vars = var,+ #' @name h_proportions |
|
| 208 | -4x | +
- var_labels = names(abn),+ NULL |
|
| 209 | -4x | +
- afun = afun,+ |
|
| 210 | -4x | +
- nested = nested,+ #' @describeIn h_proportions Calculates the Wilson interval by calling [stats::prop.test()]. |
|
| 211 | -4x | +
- table_names = table_names[i],+ #' Also referred to as Wilson score interval. |
|
| 212 | -4x | +
- extra_args = c(list(abnormal = abn), list(...)),+ #' |
|
| 213 | -4x | +
- show_labels = "visible"+ #' @examples |
|
| 214 |
- )+ #' rsp <- c( |
||
| 215 |
- }+ #' TRUE, TRUE, TRUE, TRUE, TRUE,+ |
+ ||
| 216 | ++ |
+ #' FALSE, FALSE, FALSE, FALSE, FALSE+ |
+ |
| 217 | ++ |
+ #' )+ |
+ |
| 218 | ++ |
+ #' prop_wilson(rsp, conf_level = 0.9)+ |
+ |
| 219 | ++ |
+ #'+ |
+ |
| 220 | ++ |
+ #' @export+ |
+ |
| 221 | ++ |
+ prop_wilson <- function(rsp, conf_level, correct = FALSE) {
+ |
+ |
| 222 | +5x | +
+ y <- stats::prop.test(+ |
+ |
| 223 | +5x | +
+ sum(rsp),+ |
+ |
| 224 | +5x | +
+ length(rsp),+ |
+ |
| 225 | +5x | +
+ correct = correct,+ |
+ |
| 226 | +5x | +
+ conf.level = conf_level+ |
+ |
| 227 | ++ |
+ )+ |
+ |
| 228 | ++ | + + | +|
| 229 | +5x | +
+ as.numeric(y$conf.int)+ |
+ |
| 230 | ++ |
+ }+ |
+ |
| 231 | ++ | + + | +|
| 232 | ++ |
+ #' @describeIn h_proportions Calculates the stratified Wilson confidence+ |
+ |
| 233 | ++ |
+ #' interval for unequal proportions as described in \insertCite{Yan2010-jt;textual}{tern}
+ |
+ |
| 234 | ++ |
+ #'+ |
+ |
| 235 | ++ |
+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ |
+ |
| 236 | ++ |
+ #' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are+ |
+ |
| 237 | ++ |
+ #' estimated using the iterative algorithm proposed in \insertCite{Yan2010-jt;textual}{tern} that
+ |
+ |
| 238 | ++ |
+ #' minimizes the weighted squared length of the confidence interval.+ |
+ |
| 239 | ++ |
+ #' @param max_iterations (`count`)\cr maximum number of iterations for the iterative procedure used+ |
+ |
| 240 | ++ |
+ #' to find estimates of optimal weights.+ |
+ |
| 241 | ++ |
+ #' @param correct (`flag`)\cr include the continuity correction. For further information, see for example+ |
+ |
| 242 | ++ |
+ #' [stats::prop.test()].+ |
+ |
| 243 | ++ |
+ #'+ |
+ |
| 244 | ++ |
+ #' @references+ |
+ |
| 245 | ++ |
+ #' \insertRef{Yan2010-jt}{tern}
+ |
+ |
| 246 | ++ |
+ #'+ |
+ |
| 247 | ++ |
+ #' @examples+ |
+ |
| 248 | ++ |
+ #' # Stratified Wilson confidence interval with unequal probabilities+ |
+ |
| 249 | ++ |
+ #'+ |
+ |
| 250 | ++ |
+ #' set.seed(1)+ |
+ |
| 251 | ++ |
+ #' rsp <- sample(c(TRUE, FALSE), 100, TRUE)+ |
+ |
| 252 | ++ |
+ #' strata_data <- data.frame(+ |
+ |
| 253 | ++ |
+ #' "f1" = sample(c("a", "b"), 100, TRUE),
+ |
+ |
| 254 | ++ |
+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ |
+ |
| 255 | ++ |
+ #' stringsAsFactors = TRUE |
|
| 216 | -2x | +||
| 256 | +
- lyt+ #' ) |
||
| 217 | +257 |
- }+ #' strata <- interaction(strata_data) |
| 1 | +258 |
- #' Create a Forest Plot based on a Table+ #' n_strata <- ncol(table(rsp, strata)) # Number of strata |
||
| 2 | +259 |
#' |
||
| 3 | +260 |
- #' Create a forest plot from any [rtables::rtable()] object that has a+ #' prop_strat_wilson( |
||
| 4 | +261 |
- #' column with a single value and a column with 2 values.+ #' rsp = rsp, strata = strata, |
||
| 5 | +262 |
- #'+ #' conf_level = 0.90 |
||
| 6 | +263 |
- #' @description `r lifecycle::badge("stable")`
+ #' ) |
||
| 7 | +264 |
#' |
||
| 8 | +265 |
- #' @inheritParams grid::gTree+ #' # Not automatic setting of weights |
||
| 9 | +266 |
- #' @inheritParams argument_convention+ #' prop_strat_wilson( |
||
| 10 | +267 |
- #' @param tbl (`rtable`)+ #' rsp = rsp, strata = strata, |
||
| 11 | +268 |
- #' @param col_x (`integer`)\cr column index with estimator. By default tries to get this from+ #' weights = rep(1 / n_strata, n_strata), |
||
| 12 | +269 |
- #' `tbl` attribute `col_x`, otherwise needs to be manually specified.+ #' conf_level = 0.90 |
||
| 13 | +270 |
- #' @param col_ci (`integer`)\cr column index with confidence intervals. By default tries+ #' ) |
||
| 14 | +271 |
- #' to get this from `tbl` attribute `col_ci`, otherwise needs to be manually specified.+ #' |
||
| 15 | +272 |
- #' @param vline (`number`)\cr x coordinate for vertical line, if `NULL` then the line is omitted.+ #' @export |
||
| 16 | +273 |
- #' @param forest_header (`character`, length 2)\cr text displayed to the left and right of `vline`, respectively.+ prop_strat_wilson <- function(rsp, |
||
| 17 | +274 |
- #' If `vline = NULL` then `forest_header` needs to be `NULL` too.+ strata, |
||
| 18 | +275 |
- #' By default tries to get this from `tbl` attribute `forest_header`.+ weights = NULL, |
||
| 19 | +276 |
- #' @param xlim (`numeric`)\cr limits for x axis.+ conf_level = 0.95, |
||
| 20 | +277 |
- #' @param logx (`flag`)\cr show the x-values on logarithm scale.+ max_iterations = NULL, |
||
| 21 | +278 |
- #' @param x_at (`numeric`)\cr x-tick locations, if `NULL` they get automatically chosen.+ correct = FALSE) {
|
||
| 22 | -+ | |||
| 279 | +20x |
- #' @param width_row_names (`unit`)\cr width for row names.+ checkmate::assert_logical(rsp, any.missing = FALSE) |
||
| 23 | -+ | |||
| 280 | +20x |
- #' If `NULL` the widths get automatically calculated. See [grid::unit()].+ checkmate::assert_factor(strata, len = length(rsp)) |
||
| 24 | -+ | |||
| 281 | +20x |
- #' @param width_columns (`unit`)\cr widths for the table columns.+ assert_proportion_value(conf_level) |
||
| 25 | +282 |
- #' If `NULL` the widths get automatically calculated. See [grid::unit()].+ |
||
| 26 | -+ | |||
| 283 | +20x |
- #' @param width_forest (`unit`)\cr width for the forest column.+ tbl <- table(rsp, strata) |
||
| 27 | -+ | |||
| 284 | +20x |
- #' If `NULL` the widths get automatically calculated. See [grid::unit()].+ n_strata <- length(unique(strata)) |
||
| 28 | +285 |
- #' @param col_symbol_size (`integer`)\cr column index from `tbl` containing data to be used+ |
||
| 29 | +286 |
- #' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional+ # Checking the weights and maximum number of iterations. |
||
| 30 | -+ | |||
| 287 | +20x |
- #' to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups.+ do_iter <- FALSE |
||
| 31 | -+ | |||
| 288 | +20x |
- #' By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified.+ if (is.null(weights)) {
|
||
| 32 | -+ | |||
| 289 | +6x |
- #' @param col (`character`)\cr color(s).+ weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure |
||
| 33 | -+ | |||
| 290 | +6x |
- #'+ do_iter <- TRUE |
||
| 34 | +291 |
- #' @return `gTree` object containing the forest plot and table.+ |
||
| 35 | +292 |
- #'+ # Iteration parameters |
||
| 36 | -+ | |||
| 293 | +2x |
- #' @examples+ if (is.null(max_iterations)) max_iterations <- 10 |
||
| 37 | -+ | |||
| 294 | +6x |
- #' \donttest{
+ checkmate::assert_int(max_iterations, na.ok = FALSE, null.ok = FALSE, lower = 1) |
||
| 38 | +295 |
- #' library(dplyr)+ } |
||
| 39 | -+ | |||
| 296 | +20x |
- #' library(forcats)+ checkmate::assert_numeric(weights, lower = 0, upper = 1, any.missing = FALSE, len = n_strata) |
||
| 40 | -+ | |||
| 297 | +20x |
- #' library(nestcolor)+ sum_weights <- checkmate::assert_int(sum(weights)) |
||
| 41 | -+ | |||
| 298 | +! |
- #'+ if (as.integer(sum_weights + 0.5) != 1L) stop("Sum of weights must be 1L.")
|
||
| 42 | +299 |
- #' adrs <- tern_ex_adrs+ |
||
| 43 | +300 |
- #' n_records <- 20+ |
||
| 44 | -+ | |||
| 301 | +20x |
- #' adrs_labels <- formatters::var_labels(adrs, fill = TRUE)+ xs <- tbl["TRUE", ] |
||
| 45 | -+ | |||
| 302 | +20x |
- #' adrs <- adrs %>%+ ns <- colSums(tbl) |
||
| 46 | -+ | |||
| 303 | +20x |
- #' filter(PARAMCD == "BESRSPI") %>%+ use_stratum <- (ns > 0) |
||
| 47 | -+ | |||
| 304 | +20x |
- #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+ ns <- ns[use_stratum] |
||
| 48 | -+ | |||
| 305 | +20x |
- #' slice(seq_len(n_records)) %>%+ xs <- xs[use_stratum] |
||
| 49 | -+ | |||
| 306 | +20x |
- #' droplevels() %>%+ ests <- xs / ns |
||
| 50 | -+ | |||
| 307 | +20x |
- #' mutate(+ vars <- ests * (1 - ests) / ns |
||
| 51 | +308 |
- #' # Reorder levels of factor to make the placebo group the reference arm.+ |
||
| 52 | -+ | |||
| 309 | +20x |
- #' ARM = fct_relevel(ARM, "B: Placebo"),+ strata_qnorm <- strata_normal_quantile(vars, weights, conf_level) |
||
| 53 | +310 |
- #' rsp = AVALC == "CR"+ |
||
| 54 | +311 |
- #' )+ # Iterative setting of weights if they were not set externally |
||
| 55 | -+ | |||
| 312 | +20x |
- #' formatters::var_labels(adrs) <- c(adrs_labels, "Response")+ weights_new <- if (do_iter) {
|
||
| 56 | -+ | |||
| 313 | +6x |
- #' df <- extract_rsp_subgroups(+ update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max_iterations, conf_level)$weights |
||
| 57 | +314 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")),
+ } else {
|
||
| 58 | -+ | |||
| 315 | +14x |
- #' data = adrs+ weights |
||
| 59 | +316 |
- #' )+ } |
||
| 60 | +317 |
- #' # Full commonly used response table.+ |
||
| 61 | -+ | |||
| 318 | +20x |
- #'+ strata_conf_level <- 2 * stats::pnorm(strata_qnorm) - 1 |
||
| 62 | +319 |
- #' tbl <- basic_table() %>%+ |
||
| 63 | -+ | |||
| 320 | +20x |
- #' tabulate_rsp_subgroups(df)+ ci_by_strata <- Map( |
||
| 64 | -+ | |||
| 321 | +20x |
- #' p <- g_forest(tbl, gp = grid::gpar(fontsize = 10))+ function(x, n) {
|
||
| 65 | +322 |
- #'+ # Classic Wilson's confidence interval |
||
| 66 | -+ | |||
| 323 | +139x |
- #' draw_grob(p)+ suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf_level)$conf.int) |
||
| 67 | +324 |
- #'+ }, |
||
| 68 | -+ | |||
| 325 | +20x |
- #' # Odds ratio only table.+ x = xs, |
||
| 69 | -+ | |||
| 326 | +20x |
- #'+ n = ns |
||
| 70 | +327 |
- #' tbl_or <- basic_table() %>%+ ) |
||
| 71 | -+ | |||
| 328 | +20x |
- #' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci"))
+ lower_by_strata <- sapply(ci_by_strata, "[", 1L) |
||
| 72 | -+ | |||
| 329 | +20x |
- #' tbl_or+ upper_by_strata <- sapply(ci_by_strata, "[", 2L) |
||
| 73 | +330 |
- #' p <- g_forest(+ |
||
| 74 | -+ | |||
| 331 | +20x |
- #' tbl_or,+ lower <- sum(weights_new * lower_by_strata) |
||
| 75 | -+ | |||
| 332 | +20x |
- #' forest_header = c("Comparison\nBetter", "Treatment\nBetter")
+ upper <- sum(weights_new * upper_by_strata) |
||
| 76 | +333 |
- #' )+ |
||
| 77 | +334 |
- #'+ # Return values |
||
| 78 | -+ | |||
| 335 | +20x |
- #' draw_grob(p)+ if (do_iter) {
|
||
| 79 | -+ | |||
| 336 | +6x |
- #'+ list( |
||
| 80 | -+ | |||
| 337 | +6x |
- #' # Survival forest plot example.+ conf_int = c( |
||
| 81 | -+ | |||
| 338 | +6x |
- #' adtte <- tern_ex_adtte+ lower = lower, |
||
| 82 | -+ | |||
| 339 | +6x |
- #' # Save variable labels before data processing steps.+ upper = upper |
||
| 83 | +340 |
- #' adtte_labels <- formatters::var_labels(adtte, fill = TRUE)+ ), |
||
| 84 | -+ | |||
| 341 | +6x |
- #' adtte_f <- adtte %>%+ weights = weights_new |
||
| 85 | +342 |
- #' filter(+ ) |
||
| 86 | +343 |
- #' PARAMCD == "OS",+ } else {
|
||
| 87 | -+ | |||
| 344 | +14x |
- #' ARM %in% c("B: Placebo", "A: Drug X"),
+ list( |
||
| 88 | -+ | |||
| 345 | +14x |
- #' SEX %in% c("M", "F")
+ conf_int = c( |
||
| 89 | -+ | |||
| 346 | +14x |
- #' ) %>%+ lower = lower, |
||
| 90 | -+ | |||
| 347 | +14x |
- #' mutate(+ upper = upper |
||
| 91 | +348 |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ ) |
||
| 92 | +349 |
- #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),+ ) |
||
| 93 | +350 |
- #' SEX = droplevels(SEX),+ } |
||
| 94 | +351 |
- #' AVALU = as.character(AVALU),+ } |
||
| 95 | +352 |
- #' is_event = CNSR == 0+ |
||
| 96 | +353 |
- #' )+ #' @describeIn h_proportions Calculates the Clopper-Pearson interval by calling [stats::binom.test()]. |
||
| 97 | +354 |
- #' labels <- list(+ #' Also referred to as the `exact` method. |
||
| 98 | +355 |
- #' "ARM" = adtte_labels["ARM"],+ #' |
||
| 99 | +356 |
- #' "SEX" = adtte_labels["SEX"],+ #' @examples |
||
| 100 | +357 |
- #' "AVALU" = adtte_labels["AVALU"],+ #' prop_clopper_pearson(rsp, conf_level = .95) |
||
| 101 | +358 |
- #' "is_event" = "Event Flag"+ #' |
||
| 102 | +359 |
- #' )+ #' @export |
||
| 103 | +360 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- as.character(labels)+ prop_clopper_pearson <- function(rsp, |
||
| 104 | +361 |
- #' df <- extract_survival_subgroups(+ conf_level) {
|
||
| 105 | -+ | |||
| 362 | +1x |
- #' variables = list(+ y <- stats::binom.test( |
||
| 106 | -+ | |||
| 363 | +1x |
- #' tte = "AVAL",+ x = sum(rsp), |
||
| 107 | -+ | |||
| 364 | +1x |
- #' is_event = "is_event",+ n = length(rsp), |
||
| 108 | -+ | |||
| 365 | +1x |
- #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ conf.level = conf_level |
||
| 109 | +366 |
- #' ),+ ) |
||
| 110 | -+ | |||
| 367 | +1x |
- #' data = adtte_f+ as.numeric(y$conf.int) |
||
| 111 | +368 |
- #' )+ } |
||
| 112 | +369 |
- #' table_hr <- basic_table() %>%+ |
||
| 113 | +370 |
- #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1])+ #' @describeIn h_proportions Calculates the Wald interval by following the usual textbook definition |
||
| 114 | +371 |
- #' g_forest(table_hr)+ #' for a single proportion confidence interval using the normal approximation. |
||
| 115 | +372 |
- #' # Works with any `rtable`.+ #' |
||
| 116 | +373 |
- #' tbl <- rtable(+ #' @param correct (`flag`)\cr apply continuity correction. |
||
| 117 | +374 |
- #' header = c("E", "CI", "N"),
+ #' |
||
| 118 | +375 |
- #' rrow("", 1, c(.8, 1.2), 200),
+ #' @examples |
||
| 119 | +376 |
- #' rrow("", 1.2, c(1.1, 1.4), 50)
+ #' prop_wald(rsp, conf_level = 0.95) |
||
| 120 | +377 |
- #' )+ #' prop_wald(rsp, conf_level = 0.95, correct = TRUE) |
||
| 121 | +378 |
- #' g_forest(+ #' |
||
| 122 | +379 |
- #' tbl = tbl,+ #' @export |
||
| 123 | +380 |
- #' col_x = 1,+ prop_wald <- function(rsp, conf_level, correct = FALSE) {
|
||
| 124 | -+ | |||
| 381 | +122x |
- #' col_ci = 2,+ n <- length(rsp) |
||
| 125 | -+ | |||
| 382 | +122x |
- #' xlim = c(0.5, 2),+ p_hat <- mean(rsp) |
||
| 126 | -+ | |||
| 383 | +122x |
- #' x_at = c(0.5, 1, 2),+ z <- stats::qnorm((1 + conf_level) / 2) |
||
| 127 | -+ | |||
| 384 | +122x |
- #' col_symbol_size = 3+ q_hat <- 1 - p_hat |
||
| 128 | -+ | |||
| 385 | +122x |
- #' )+ correct <- if (correct) 1 / (2 * n) else 0 |
||
| 129 | +386 |
- #' tbl <- rtable(+ |
||
| 130 | -+ | |||
| 387 | +122x |
- #' header = rheader(+ err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correct |
||
| 131 | -+ | |||
| 388 | +122x |
- #' rrow("", rcell("A", colspan = 2)),
+ l_ci <- max(0, p_hat - err) |
||
| 132 | -+ | |||
| 389 | +122x |
- #' rrow("", "c1", "c2")
+ u_ci <- min(1, p_hat + err) |
||
| 133 | +390 |
- #' ),+ |
||
| 134 | -+ | |||
| 391 | +122x |
- #' rrow("row 1", 1, c(.8, 1.2)),
+ c(l_ci, u_ci) |
||
| 135 | +392 |
- #' rrow("row 2", 1.2, c(1.1, 1.4))
+ } |
||
| 136 | +393 |
- #' )+ |
||
| 137 | +394 |
- #' g_forest(+ #' @describeIn h_proportions Calculates the `Agresti-Coull` interval (created by `Alan Agresti` and `Brent Coull`) by |
||
| 138 | +395 |
- #' tbl = tbl,+ #' (for 95% CI) adding two successes and two failures to the data and then using the Wald formula to construct a CI. |
||
| 139 | +396 |
- #' col_x = 1,+ #' |
||
| 140 | +397 |
- #' col_ci = 2,+ #' @examples |
||
| 141 | +398 |
- #' xlim = c(0.5, 2),+ #' prop_agresti_coull(rsp, conf_level = 0.95) |
||
| 142 | +399 |
- #' x_at = c(0.5, 1, 2),+ #' |
||
| 143 | +400 |
- #' vline = 1,+ #' @export |
||
| 144 | +401 |
- #' forest_header = c("Hello", "World")
+ prop_agresti_coull <- function(rsp, conf_level) {
|
||
| 145 | -+ | |||
| 402 | +2x |
- #' )+ n <- length(rsp) |
||
| 146 | -+ | |||
| 403 | +2x |
- #' }+ x_sum <- sum(rsp) |
||
| 147 | -+ | |||
| 404 | +2x |
- #'+ z <- stats::qnorm((1 + conf_level) / 2) |
||
| 148 | +405 |
- #' @export+ |
||
| 149 | +406 |
- g_forest <- function(tbl,+ # Add here both z^2 / 2 successes and failures. |
||
| 150 | -+ | |||
| 407 | +2x |
- col_x = attr(tbl, "col_x"),+ x_sum_tilde <- x_sum + z^2 / 2+ |
+ ||
| 408 | +2x | +
+ n_tilde <- n + z^2 |
||
| 151 | +409 |
- col_ci = attr(tbl, "col_ci"),+ |
||
| 152 | +410 |
- vline = 1,+ # Then proceed as with the Wald interval.+ |
+ ||
| 411 | +2x | +
+ p_tilde <- x_sum_tilde / n_tilde+ |
+ ||
| 412 | +2x | +
+ q_tilde <- 1 - p_tilde+ |
+ ||
| 413 | +2x | +
+ err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)+ |
+ ||
| 414 | +2x | +
+ l_ci <- max(0, p_tilde - err)+ |
+ ||
| 415 | +2x | +
+ u_ci <- min(1, p_tilde + err) |
||
| 153 | +416 |
- forest_header = attr(tbl, "forest_header"),+ + |
+ ||
| 417 | +2x | +
+ c(l_ci, u_ci) |
||
| 154 | +418 |
- xlim = c(0.1, 10),+ } |
||
| 155 | +419 |
- logx = TRUE,+ |
||
| 156 | +420 |
- x_at = c(0.1, 1, 10),+ #' @describeIn h_proportions Calculates the Jeffreys interval, an equal-tailed interval based on the |
||
| 157 | +421 |
- width_row_names = NULL,+ #' non-informative Jeffreys prior for a binomial proportion. |
||
| 158 | +422 |
- width_columns = NULL,+ #' |
||
| 159 | +423 |
- width_forest = grid::unit(1, "null"),+ #' @examples |
||
| 160 | +424 |
- col_symbol_size = attr(tbl, "col_symbol_size"),+ #' prop_jeffreys(rsp, conf_level = 0.95) |
||
| 161 | +425 |
- col = getOption("ggplot2.discrete.colour")[1],
+ #' |
||
| 162 | +426 |
- gp = NULL,+ #' @export |
||
| 163 | +427 |
- draw = TRUE,+ prop_jeffreys <- function(rsp, |
||
| 164 | +428 |
- newpage = TRUE) {
+ conf_level) {
|
||
| 165 | -2x | +429 | +4x |
- checkmate::assert_class(tbl, "VTableTree")+ n <- length(rsp)+ |
+
| 430 | +4x | +
+ x_sum <- sum(rsp) |
||
| 166 | +431 | |||
| 167 | -2x | +432 | +4x |
- nr <- nrow(tbl)+ alpha <- 1 - conf_level |
| 168 | -2x | +433 | +4x |
- nc <- ncol(tbl)+ l_ci <- ifelse( |
| 169 | -2x | +434 | +4x |
- if (is.null(col)) {
+ x_sum == 0, |
| 170 | -2x | +435 | +4x |
- col <- "blue"+ 0,+ |
+
| 436 | +4x | +
+ stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5) |
||
| 171 | +437 |
- }+ ) |
||
| 172 | +438 | |||
| 173 | -2x | +439 | +4x |
- checkmate::assert_number(col_x, lower = 0, upper = nc, null.ok = FALSE)+ u_ci <- ifelse( |
| 174 | -2x | +440 | +4x |
- checkmate::assert_number(col_ci, lower = 0, upper = nc, null.ok = FALSE)+ x_sum == n, |
| 175 | -2x | +441 | +4x |
- checkmate::assert_number(col_symbol_size, lower = 0, upper = nc, null.ok = TRUE)+ 1, |
| 176 | -2x | +442 | +4x |
- checkmate::assert_true(col_x > 0)+ stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5) |
| 177 | -2x | +|||
| 443 | +
- checkmate::assert_true(col_ci > 0)+ ) |
|||
| 178 | -2x | +|||
| 444 | +
- checkmate::assert_character(col)+ |
|||
| 179 | -2x | +445 | +4x |
- if (!is.null(col_symbol_size)) {
+ c(l_ci, u_ci) |
| 180 | -1x | +|||
| 446 | +
- checkmate::assert_true(col_symbol_size > 0)+ } |
|||
| 181 | +447 |
- }+ |
||
| 182 | +448 |
-
+ #' Description of the Proportion Summary |
||
| 183 | -2x | +|||
| 449 | +
- x_e <- vapply(seq_len(nr), function(i) {
+ #' |
|||
| 184 | +450 |
- # If a label row is selected NULL is returned with a warning (suppressed)+ #' @description `r lifecycle::badge("stable")`
|
||
| 185 | -9x | +|||
| 451 | +
- xi <- suppressWarnings(as.vector(tbl[i, col_x, drop = TRUE]))+ #' |
|||
| 186 | +452 |
-
+ #' This is a helper function that describes the analysis in [s_proportion()]. |
||
| 187 | -9x | +|||
| 453 | +
- if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) {
+ #' |
|||
| 188 | -7x | +|||
| 454 | +
- xi+ #' @inheritParams s_proportion |
|||
| 189 | +455 |
- } else {
+ #' @param long (`flag`)\cr whether a long or a short (default) description is required. |
||
| 190 | -2x | +|||
| 456 | +
- NA_real_+ #' |
|||
| 191 | +457 |
- }+ #' @return String describing the analysis. |
||
| 192 | -2x | +|||
| 458 | +
- }, numeric(1))+ #' |
|||
| 193 | +459 |
-
+ #' @export |
||
| 194 | -2x | +|||
| 460 | +
- x_ci <- lapply(seq_len(nr), function(i) {
+ d_proportion <- function(conf_level, |
|||
| 195 | -9x | +|||
| 461 | +
- xi <- suppressWarnings(as.vector(tbl[i, col_ci, drop = TRUE])) # as above+ method, |
|||
| 196 | +462 |
-
+ long = FALSE) {
|
||
| 197 | -9x | +463 | +137x |
- if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) {
+ label <- paste0(conf_level * 100, "% CI") |
| 198 | -7x | +|||
| 464 | +
- if (length(xi) != 2) {
+
|
|||
| 199 | +465 | ! |
- stop("ci column needs two elements")
+ if (long) label <- paste(label, "for Response Rates") |
|
| 200 | +466 |
- }+ |
||
| 201 | -7x | +467 | +137x |
- xi+ method_part <- switch(method, |
| 202 | -+ | |||
| 468 | +137x |
- } else {
+ "clopper-pearson" = "Clopper-Pearson", |
||
| 203 | -2x | +469 | +137x |
- c(NA_real_, NA_real_)+ "waldcc" = "Wald, with correction", |
| 204 | -+ | |||
| 470 | +137x |
- }+ "wald" = "Wald, without correction", |
||
| 205 | -+ | |||
| 471 | +137x |
- })+ "wilson" = "Wilson, without correction", |
||
| 206 | -+ | |||
| 472 | +137x |
-
+ "strat_wilson" = "Stratified Wilson, without correction", |
||
| 207 | -2x | +473 | +137x |
- lower <- vapply(x_ci, `[`, numeric(1), 1)+ "wilsonc" = "Wilson, with correction", |
| 208 | -2x | +474 | +137x |
- upper <- vapply(x_ci, `[`, numeric(1), 2)+ "strat_wilsonc" = "Stratified Wilson, with correction", |
| 209 | -+ | |||
| 475 | +137x |
-
+ "agresti-coull" = "Agresti-Coull", |
||
| 210 | -2x | +476 | +137x |
- symbol_size <- if (!is.null(col_symbol_size)) {
+ "jeffreys" = "Jeffreys", |
| 211 | -1x | +477 | +137x |
- tmp_symbol_size <- vapply(seq_len(nr), function(i) {
+ stop(paste(method, "does not have a description")) |
| 212 | -7x | +|||
| 478 | +
- suppressWarnings(xi <- as.vector(tbl[i, col_symbol_size, drop = TRUE]))+ ) |
|||
| 213 | +479 | |||
| 214 | -7x | +480 | +137x |
- if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) {
+ paste0(label, " (", method_part, ")")
|
| 215 | -5x | +|||
| 481 | +
- xi+ } |
|||
| 216 | +482 |
- } else {
+
|
||
| 217 | -1x | +|||
| 483 | +
- NA_real_+ #' Helper Function for the Estimation of Stratified Quantiles |
|||
| 218 | +484 |
- }+ #' |
||
| 219 | -1x | +|||
| 485 | +
- }, numeric(1))+ #' @description `r lifecycle::badge("stable")`
|
|||
| 220 | +486 |
-
+ #' |
||
| 221 | +487 |
- # Scale symbol size.+ #' This function wraps the estimation of stratified percentiles when we assume |
||
| 222 | -1x | +|||
| 488 | +
- tmp_symbol_size <- sqrt(tmp_symbol_size)+ #' the approximation for large numbers. This is necessary only in the case |
|||
| 223 | -1x | +|||
| 489 | +
- max_size <- max(tmp_symbol_size, na.rm = TRUE)+ #' proportions for each strata are unequal. |
|||
| 224 | +490 |
- # Biggest points have radius is 2 * (1/3.5) lines not to overlap.+ #' |
||
| 225 | +491 |
- # See forest_dot_line.+ #' @inheritParams argument_convention |
||
| 226 | -1x | +|||
| 492 | +
- 2 * tmp_symbol_size / max_size+ #' @inheritParams prop_strat_wilson |
|||
| 227 | +493 |
- } else {
+ #' |
||
| 228 | -1x | +|||
| 494 | +
- NULL+ #' @return Stratified quantile. |
|||
| 229 | +495 |
- }+ #' |
||
| 230 | +496 |
-
+ #' @seealso [prop_strat_wilson()] |
||
| 231 | -2x | +|||
| 497 | +
- grob_forest <- forest_grob(+ #' |
|||
| 232 | -2x | +|||
| 498 | +
- tbl,+ #' @examples |
|||
| 233 | -2x | +|||
| 499 | +
- x_e,+ #' strata_data <- table(data.frame( |
|||
| 234 | -2x | +|||
| 500 | +
- lower,+ #' "f1" = sample(c(TRUE, FALSE), 100, TRUE), |
|||
| 235 | -2x | +|||
| 501 | +
- upper,+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
|||
| 236 | -2x | +|||
| 502 | +
- vline,+ #' stringsAsFactors = TRUE |
|||
| 237 | -2x | +|||
| 503 | +
- forest_header,+ #' )) |
|||
| 238 | -2x | +|||
| 504 | +
- xlim,+ #' ns <- colSums(strata_data) |
|||
| 239 | -2x | +|||
| 505 | +
- logx,+ #' ests <- strata_data["TRUE", ] / ns |
|||
| 240 | -2x | +|||
| 506 | +
- x_at,+ #' vars <- ests * (1 - ests) / ns |
|||
| 241 | -2x | +|||
| 507 | +
- width_row_names,+ #' weights <- rep(1 / length(ns), length(ns)) |
|||
| 242 | -2x | +|||
| 508 | +
- width_columns,+ #' strata_normal_quantile(vars, weights, 0.95) |
|||
| 243 | -2x | +|||
| 509 | +
- width_forest,+ #' |
|||
| 244 | -2x | +|||
| 510 | +
- symbol_size = symbol_size,+ #' @export |
|||
| 245 | -2x | +|||
| 511 | +
- col = col,+ strata_normal_quantile <- function(vars, weights, conf_level) {
|
|||
| 246 | -2x | +512 | +41x |
- gp = gp,+ summands <- weights^2 * vars+ |
+
| 513 | ++ |
+ # Stratified quantile |
||
| 247 | -2x | +514 | +41x |
- vp = grid::plotViewport(margins = rep(1, 4))+ sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf_level) / 2) |
| 248 | +515 |
- )+ } |
||
| 249 | +516 | |||
| 250 | -2x | -
- if (draw) {
- |
- ||
| 251 | -! | +|||
| 517 | +
- if (newpage) grid::grid.newpage()+ #' Helper Function for the Estimation of Weights for `prop_strat_wilson` |
|||
| 252 | -! | +|||
| 518 | +
- grid::grid.draw(grob_forest)+ #' |
|||
| 253 | +519 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 254 | +520 |
-
+ #' |
||
| 255 | -2x | +|||
| 521 | +
- invisible(grob_forest)+ #' This function wraps the iteration procedure that allows you to estimate |
|||
| 256 | +522 |
- }+ #' the weights for each proportional strata. This assumes to minimize the |
||
| 257 | +523 |
-
+ #' weighted squared length of the confidence interval. |
||
| 258 | +524 |
- #' Forest Plot Grob+ #' |
||
| 259 | +525 |
- #'+ #' @inheritParams prop_strat_wilson |
||
| 260 | +526 |
- #' @inheritParams g_forest+ #' @param vars (`numeric`)\cr normalized proportions for each strata. |
||
| 261 | +527 |
- #' @param tbl ([rtables::rtable()])+ #' @param strata_qnorm (`numeric`)\cr initial estimation with identical weights of the quantiles. |
||
| 262 | +528 |
- #' @param x (`numeric`)\cr coordinate of point.+ #' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can |
||
| 263 | +529 |
- #' @param lower,upper (`numeric`)\cr lower/upper bound of the confidence interval.+ #' be optimized in the future if we need to estimate better initial weights. |
||
| 264 | +530 |
- #' @param symbol_size (`numeric`)\cr vector with relative size for plot symbol.+ #' @param n_per_strata (`numeric`)\cr number of elements in each strata. |
||
| 265 | +531 |
- #' If `NULL`, the same symbol size is used.+ #' @param max_iterations (`count`)\cr maximum number of iterations to be tried. Convergence is always checked. |
||
| 266 | +532 |
- #'+ #' @param tol (`number`)\cr tolerance threshold for convergence. |
||
| 267 | +533 |
- #' @details+ #' |
||
| 268 | +534 |
- #' The heights get automatically determined.+ #' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`. |
||
| 269 | +535 |
#' |
||
| 270 | +536 |
- #' @noRd+ #' @seealso For references and details see [prop_strat_wilson()]. |
||
| 271 | +537 |
#' |
||
| 272 | +538 |
#' @examples |
||
| 273 | +539 |
- #' tbl <- rtable(+ #' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018) |
||
| 274 | +540 |
- #' header = rheader(+ #' sq <- 0.674 |
||
| 275 | +541 |
- #' rrow("", "E", rcell("CI", colspan = 2), "N"),
+ #' ws <- rep(1 / length(vs), length(vs)) |
||
| 276 | +542 |
- #' rrow("", "A", "B", "C", "D")
+ #' ns <- c(22, 18, 17, 17, 14, 12) |
||
| 277 | +543 |
- #' ),+ #' |
||
| 278 | +544 |
- #' rrow("row 1", 1, 0.8, 1.1, 16),
+ #' update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001) |
||
| 279 | +545 |
- #' rrow("row 2", 1.4, 0.8, 1.6, 25),
+ #' |
||
| 280 | +546 |
- #' rrow("row 3", 1.2, 0.8, 1.6, 36)
+ #' @export |
||
| 281 | +547 |
- #' )+ update_weights_strat_wilson <- function(vars, |
||
| 282 | +548 |
- #'+ strata_qnorm, |
||
| 283 | +549 |
- #' x <- c(1, 1.4, 1.2)+ initial_weights, |
||
| 284 | +550 |
- #' lower <- c(0.8, 0.8, 0.8)+ n_per_strata, |
||
| 285 | +551 |
- #' upper <- c(1.1, 1.6, 1.6)+ max_iterations = 50, |
||
| 286 | +552 |
- #' # numeric vector with multiplication factor to scale each circle radius+ conf_level = 0.95, |
||
| 287 | +553 |
- #' # default radius is 1/3.5 lines+ tol = 0.001) {
|
||
| 288 | -+ | |||
| 554 | +8x |
- #' symbol_scale <- c(1, 1.25, 1.5)+ it <- 0 |
||
| 289 | -+ | |||
| 555 | +8x |
- #'+ diff_v <- NULL |
||
| 290 | +556 |
- #' # Internal function - forest_grob+ |
||
| 291 | -+ | |||
| 557 | +8x |
- #' \donttest{
+ while (it < max_iterations) {
|
||
| 292 | -+ | |||
| 558 | +19x |
- #' p <- forest_grob(tbl, x, lower, upper,+ it <- it + 1 |
||
| 293 | -+ | |||
| 559 | +19x |
- #' vline = 1, forest_header = c("A", "B"),
+ weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2 |
||
| 294 | -+ | |||
| 560 | +19x |
- #' x_at = c(.1, 1, 10), xlim = c(0.1, 10), logx = TRUE, symbol_size = symbol_scale,+ weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2)) |
||
| 295 | -+ | |||
| 561 | +19x |
- #' vp = grid::plotViewport(margins = c(1, 1, 1, 1))+ weights_new <- weights_new_t / weights_new_b |
||
| 296 | -+ | |||
| 562 | +19x |
- #' )+ weights_new <- weights_new / sum(weights_new) |
||
| 297 | -+ | |||
| 563 | +19x |
- #'+ strata_qnorm <- strata_normal_quantile(vars, weights_new, conf_level) |
||
| 298 | -+ | |||
| 564 | +19x |
- #' draw_grob(p)+ diff_v <- c(diff_v, sum(abs(weights_new - initial_weights))) |
||
| 299 | -+ | |||
| 565 | +8x |
- #' }+ if (diff_v[length(diff_v)] < tol) break |
||
| 300 | -+ | |||
| 566 | +11x |
- forest_grob <- function(tbl,+ initial_weights <- weights_new |
||
| 301 | +567 |
- x,+ } |
||
| 302 | +568 |
- lower,+ |
||
| 303 | -+ | |||
| 569 | +8x |
- upper,+ if (it == max_iterations) {
+ |
+ ||
| 570 | +! | +
+ warning("The heuristic to find weights did not converge with max_iterations = ", max_iterations)
|
||
| 304 | +571 |
- vline,+ } |
||
| 305 | +572 |
- forest_header,+ + |
+ ||
| 573 | +8x | +
+ list(+ |
+ ||
| 574 | +8x | +
+ "n_it" = it,+ |
+ ||
| 575 | +8x | +
+ "weights" = weights_new,+ |
+ ||
| 576 | +8x | +
+ "diff_v" = diff_v |
||
| 306 | +577 |
- xlim = NULL,+ ) |
||
| 307 | +578 |
- logx = FALSE,+ } |
| 308 | +1 |
- x_at = NULL,+ #' Combine Factor Levels |
||
| 309 | +2 |
- width_row_names = NULL,+ #' |
||
| 310 | +3 |
- width_columns = NULL,+ #' @description `r lifecycle::badge("stable")`
|
||
| 311 | +4 |
- width_forest = grid::unit(1, "null"),+ #' |
||
| 312 | +5 |
- symbol_size = NULL,+ #' Combine specified old factor Levels in a single new level. |
||
| 313 | +6 |
- col = "blue",+ #' |
||
| 314 | +7 |
- name = NULL,+ #' @param x factor |
||
| 315 | +8 |
- gp = NULL,+ #' @param levels level names to be combined |
||
| 316 | +9 |
- vp = NULL) {
+ #' @param new_level name of new level |
||
| 317 | -2x | +|||
| 10 | +
- nr <- nrow(tbl)+ #' |
|||
| 318 | -2x | +|||
| 11 | +
- if (is.null(vline)) {
+ #' @return A `factor` with the new levels. |
|||
| 319 | -! | +|||
| 12 | +
- checkmate::assert_true(is.null(forest_header))+ #' |
|||
| 320 | +13 |
- } else {
+ #' @examples |
||
| 321 | -2x | +|||
| 14 | +
- checkmate::assert_number(vline)+ #' x <- factor(letters[1:5], levels = letters[5:1]) |
|||
| 322 | -2x | +|||
| 15 | +
- checkmate::assert_character(forest_header, len = 2, null.ok = TRUE)+ #' combine_levels(x, levels = c("a", "b"))
|
|||
| 323 | +16 |
- }+ #' |
||
| 324 | +17 |
-
+ #' combine_levels(x, c("e", "b"))
|
||
| 325 | -2x | +|||
| 18 | +
- checkmate::assert_numeric(x, len = nr)+ #' |
|||
| 326 | -2x | +|||
| 19 | +
- checkmate::assert_numeric(lower, len = nr)+ #' @export |
|||
| 327 | -2x | +|||
| 20 | +
- checkmate::assert_numeric(upper, len = nr)+ combine_levels <- function(x, levels, new_level = paste(levels, collapse = "/")) {
|
|||
| 328 | -2x | +21 | +4x |
- checkmate::assert_numeric(symbol_size, len = nr, null.ok = TRUE)+ checkmate::assert_factor(x) |
| 329 | -2x | +22 | +4x |
- checkmate::assert_character(col)+ checkmate::assert_subset(levels, levels(x)) |
| 330 | +23 | |||
| 331 | -2x | +24 | +4x |
- if (is.null(symbol_size)) {
+ lvls <- levels(x) |
| 332 | -1x | +|||
| 25 | +
- symbol_size <- rep(1, nr)+ |
|||
| 333 | -+ | |||
| 26 | +4x |
- }+ lvls[lvls %in% levels] <- new_level |
||
| 334 | +27 | |||
| 335 | -2x | +28 | +4x |
- if (is.null(xlim)) {
+ levels(x) <- lvls |
| 336 | -! | +|||
| 29 | +
- r <- range(c(x, lower, upper), na.rm = TRUE)+ |
|||
| 337 | -! | +|||
| 30 | +4x |
- xlim <- r + c(-0.05, 0.05) * diff(r)+ x |
||
| 338 | +31 |
- }+ } |
||
| 339 | +32 | - | ||
| 340 | -2x | -
- if (logx) {
- |
- ||
| 341 | -2x | +|||
| 33 | +
- if (is.null(x_at)) {
+ #' Conversion of a Vector to a Factor |
|||
| 342 | -! | +|||
| 34 | +
- x_at <- pretty(log(stats::na.omit(c(x, lower, upper))))+ #' |
|||
| 343 | -! | +|||
| 35 | +
- x_labels <- exp(x_at)+ #' Converts `x` to a factor and keeps its attributes. Warns appropriately such that the user |
|||
| 344 | +36 |
- } else {
+ #' can decide whether they prefer converting to factor manually (e.g. for full control of |
||
| 345 | -2x | +|||
| 37 | +
- x_labels <- x_at+ #' factor levels). |
|||
| 346 | -2x | +|||
| 38 | +
- x_at <- log(x_at)+ #' |
|||
| 347 | +39 |
- }+ #' @param x (`atomic`)\cr object to convert. |
||
| 348 | -2x | +|||
| 40 | +
- xlim <- log(xlim)+ #' @param x_name (`string`)\cr name of `x`. |
|||
| 349 | -2x | +|||
| 41 | +
- x <- log(x)+ #' @param na_level (`string`)\cr the explicit missing level which should be used when converting a character vector. |
|||
| 350 | -2x | +|||
| 42 | +
- lower <- log(lower)+ #' @param verbose defaults to `TRUE`. It prints out warnings and messages. |
|||
| 351 | -2x | +|||
| 43 | +
- upper <- log(upper)+ #' |
|||
| 352 | -2x | +|||
| 44 | +
- if (!is.null(vline)) {
+ #' @return A `factor` with same attributes (except class) as `x`. Does not modify `x` if already a `factor`. |
|||
| 353 | -2x | +|||
| 45 | +
- vline <- log(vline)+ #' |
|||
| 354 | +46 |
- }+ #' @keywords internal |
||
| 355 | +47 |
- } else {
+ as_factor_keep_attributes <- function(x, |
||
| 356 | -! | +|||
| 48 | +
- x_labels <- TRUE+ x_name = deparse(substitute(x)), |
|||
| 357 | +49 |
- }+ na_level = "<Missing>", |
||
| 358 | +50 |
-
+ verbose = TRUE) {
|
||
| 359 | -2x | +51 | +159x |
- data_forest_vp <- grid::dataViewport(xlim, c(0, 1))+ checkmate::assert_atomic(x) |
| 360 | -+ | |||
| 52 | +159x |
-
+ checkmate::assert_string(x_name) |
||
| 361 | -+ | |||
| 53 | +159x |
- # Get table content as matrix form.+ checkmate::assert_string(na_level) |
||
| 362 | -2x | +54 | +159x |
- mf <- matrix_form(tbl)+ checkmate::assert_flag(verbose) |
| 363 | -+ | |||
| 55 | +159x |
-
+ if (is.factor(x)) {
+ |
+ ||
| 56 | +144x | +
+ return(x) |
||
| 364 | +57 |
- # Use `rtables` indent_string eventually.+ } |
||
| 365 | -2x | +58 | +15x |
- mf$strings[, 1] <- paste0(+ x_class <- class(x)[1] |
| 366 | -2x | +59 | +15x |
- strrep(" ", c(rep(0, attr(mf, "nrow_header")), mf$row_info$indent)),
+ if (verbose) {
|
| 367 | -2x | +60 | +15x |
- mf$strings[, 1]+ warning(paste(+ |
+
| 61 | +15x | +
+ "automatically converting", x_class, "variable", x_name,+ |
+ ||
| 62 | +15x | +
+ "to factor, better manually convert to factor to avoid failures" |
||
| 368 | +63 |
- )+ )) |
||
| 369 | +64 |
-
+ } |
||
| 370 | -2x | +65 | +15x |
- n_header <- attr(mf, "nrow_header")+ if (identical(length(x), 0L)) {
|
| 371 | -+ | |||
| 66 | +1x |
-
+ warning(paste( |
||
| 372 | -! | +|||
| 67 | +1x |
- if (any(mf$display[, 1] == FALSE)) stop("row names need to be always displayed")
+ x_name, "has length 0, this can lead to tabulation failures, better convert to factor" |
||
| 373 | +68 |
-
+ )) |
||
| 374 | +69 |
- # Pre-process the data to be used in lapply and cell_in_rows.+ } |
||
| 375 | -2x | +70 | +15x |
- to_args_for_cell_in_rows_fun <- function(part = c("body", "header"),
+ if (is.character(x)) {
|
| 376 | -2x | +71 | +15x |
- underline_colspan = FALSE) {
+ x_no_na <- explicit_na(sas_na(x), label = na_level) |
| 377 | -4x | +72 | +15x |
- part <- match.arg(part)+ if (any(na_level %in% x_no_na)) {
|
| 378 | -4x | +73 | +3x |
- if (part == "body") {
+ do.call( |
| 379 | -2x | +74 | +3x |
- mat_row_indices <- seq_len(nrow(tbl)) + n_header+ structure, |
| 380 | -2x | +75 | +3x |
- row_ind_offset <- -n_header+ c( |
| 381 | -+ | |||
| 76 | +3x |
- } else {
+ list(.Data = forcats::fct_relevel(x_no_na, na_level, after = Inf)), |
||
| 382 | -2x | +77 | +3x |
- mat_row_indices <- seq_len(n_header)+ attributes(x) |
| 383 | -2x | +|||
| 78 | +
- row_ind_offset <- 0+ ) |
|||
| 384 | +79 |
- }+ ) |
||
| 385 | +80 |
-
+ } else {
|
||
| 386 | -4x | +81 | +12x |
- lapply(mat_row_indices, function(i) {
+ do.call(structure, c(list(.Data = as.factor(x)), attributes(x))) |
| 387 | -13x | +|||
| 82 | +
- disp <- mf$display[i, -1]+ } |
|||
| 388 | -13x | +|||
| 83 | +
- list(+ } else {
|
|||
| 389 | -13x | +|||
| 84 | +! |
- row_name = mf$strings[i, 1],+ do.call(structure, c(list(.Data = as.factor(x)), attributes(x))) |
||
| 390 | -13x | +|||
| 85 | +
- cells = mf$strings[i, -1][disp],+ } |
|||
| 391 | -13x | +|||
| 86 | +
- cell_spans = mf$spans[i, -1][disp],+ } |
|||
| 392 | -13x | +|||
| 87 | +
- row_index = i + row_ind_offset,+ |
|||
| 393 | -13x | +|||
| 88 | +
- underline_colspan = underline_colspan+ #' Labels for Bins in Percent |
|||
| 394 | +89 |
- )+ #' |
||
| 395 | +90 |
- })+ #' This creates labels for quantile based bins in percent. This assumes the right-closed |
||
| 396 | +91 |
- }+ #' intervals as produced by [cut_quantile_bins()]. |
||
| 397 | +92 |
-
+ #' |
||
| 398 | -2x | +|||
| 93 | +
- args_header <- to_args_for_cell_in_rows_fun("header", underline_colspan = TRUE)
+ #' @param probs (`proportion` vector)\cr the probabilities identifying the quantiles. |
|||
| 399 | -2x | +|||
| 94 | +
- args_body <- to_args_for_cell_in_rows_fun("body", underline_colspan = FALSE)
+ #' This is a sorted vector of unique `proportion` values, i.e. between 0 and 1, where |
|||
| 400 | +95 |
-
+ #' the boundaries 0 and 1 must not be included. |
||
| 401 | -2x | +|||
| 96 | +
- grid::gTree(+ #' @param digits (`integer`)\cr number of decimal places to round the percent numbers. |
|||
| 402 | -2x | +|||
| 97 | +
- name = name,+ #' |
|||
| 403 | -2x | +|||
| 98 | +
- children = grid::gList(+ #' @return A `character` vector with labels in the format `[0%,20%]`, `(20%,50%]`, etc. |
|||
| 404 | -2x | +|||
| 99 | +
- grid::gTree(+ #' |
|||
| 405 | -2x | +|||
| 100 | +
- children = do.call(grid::gList, lapply(args_header, do.call, what = cell_in_rows)),+ #' @keywords internal |
|||
| 406 | -2x | +|||
| 101 | +
- vp = grid::vpPath("vp_table_layout", "vp_header")
+ bins_percent_labels <- function(probs, |
|||
| 407 | +102 |
- ),+ digits = 0) {
|
||
| 408 | -2x | +103 | +1x |
- grid::gTree(+ if (isFALSE(0 %in% probs)) probs <- c(0, probs) |
| 409 | -2x | +104 | +1x |
- children = do.call(grid::gList, lapply(args_body, do.call, what = cell_in_rows)),+ if (isFALSE(1 %in% probs)) probs <- c(probs, 1) |
| 410 | -2x | +105 | +8x |
- vp = grid::vpPath("vp_table_layout", "vp_body")
+ checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE) |
| 411 | -+ | |||
| 106 | +8x |
- ),+ percent <- round(probs * 100, digits = digits) |
||
| 412 | -2x | +107 | +8x |
- grid::linesGrob(+ left <- paste0(utils::head(percent, -1), "%") |
| 413 | -2x | +108 | +8x |
- grid::unit(c(0, 1), "npc"),+ right <- paste0(utils::tail(percent, -1), "%") |
| 414 | -2x | +109 | +8x |
- y = grid::unit(c(.5, .5), "npc"),+ without_left_bracket <- paste0(left, ",", right, "]") |
| 415 | -2x | +110 | +8x |
- vp = grid::vpPath("vp_table_layout", "vp_spacer")
+ with_left_bracket <- paste0("[", utils::head(without_left_bracket, 1))
|
| 416 | -+ | |||
| 111 | +8x |
- ),+ if (length(without_left_bracket) > 1) {
|
||
| 417 | -+ | |||
| 112 | +6x |
- # forest part+ with_left_bracket <- c( |
||
| 418 | -2x | +113 | +6x |
- if (is.null(vline)) {
+ with_left_bracket, |
| 419 | -! | +|||
| 114 | +6x |
- NULL+ paste0("(", utils::tail(without_left_bracket, -1))
|
||
| 420 | +115 |
- } else {
- |
- ||
| 421 | -2x | -
- grid::gTree(+ ) |
||
| 422 | -2x | +|||
| 116 | +
- children = grid::gList(+ } |
|||
| 423 | -2x | +117 | +8x |
- grid::gTree(+ with_left_bracket |
| 424 | -2x | +|||
| 118 | +
- children = grid::gList(+ } |
|||
| 425 | +119 |
- # this may overflow, to fix, look here+ |
||
| 426 | +120 |
- # https://stackoverflow.com/questions/33623169/add-multi-line-footnote-to-tablegrob-while-using-gridextra-in-r #nolintr+ #' Cutting Numeric Vector into Empirical Quantile Bins |
||
| 427 | -2x | +|||
| 121 | +
- grid::textGrob(+ #' |
|||
| 428 | -2x | +|||
| 122 | +
- forest_header[1],+ #' @description `r lifecycle::badge("stable")`
|
|||
| 429 | -2x | +|||
| 123 | +
- x = grid::unit(vline, "native") - grid::unit(1, "lines"),+ #' |
|||
| 430 | -2x | +|||
| 124 | +
- just = c("right", "center")
+ #' This cuts a numeric vector into sample quantile bins. |
|||
| 431 | +125 |
- ),+ #' |
||
| 432 | -2x | +|||
| 126 | +
- grid::textGrob(+ #' @inheritParams bins_percent_labels |
|||
| 433 | -2x | +|||
| 127 | +
- forest_header[2],+ #' @param x (`numeric`)\cr the continuous variable values which should be cut into |
|||
| 434 | -2x | +|||
| 128 | +
- x = grid::unit(vline, "native") + grid::unit(1, "lines"),+ #' quantile bins. This may contain `NA` values, which are then |
|||
| 435 | -2x | +|||
| 129 | +
- just = c("left", "center")
+ #' not used for the quantile calculations, but included in the return vector. |
|||
| 436 | +130 |
- )+ #' @param labels (`character`)\cr the unique labels for the quantile bins. When there are `n` |
||
| 437 | +131 |
- ),+ #' probabilities in `probs`, then this must be `n + 1` long. |
||
| 438 | -2x | +|||
| 132 | +
- vp = grid::vpStack(grid::viewport(layout.pos.col = ncol(tbl) + 2), data_forest_vp)+ #' @param type (`integer`)\cr type of quantiles to use, see [stats::quantile()] for details. |
|||
| 439 | +133 |
- )+ #' @param ordered (`flag`)\cr should the result be an ordered factor. |
||
| 440 | +134 |
- ),+ #' |
||
| 441 | -2x | +|||
| 135 | +
- vp = grid::vpPath("vp_table_layout", "vp_header")
+ #' @return A `factor` variable with appropriately-labeled bins as levels. |
|||
| 442 | +136 |
- )+ #' |
||
| 443 | +137 |
- },+ #' @note Intervals are closed on the right side. That is, the first bin is the interval |
||
| 444 | -2x | +|||
| 138 | +
- grid::gTree(+ #' `[-Inf, q1]` where `q1` is the first quantile, the second bin is then `(q1, q2]`, etc., |
|||
| 445 | -2x | +|||
| 139 | +
- children = grid::gList(+ #' and the last bin is `(qn, +Inf]` where `qn` is the last quantile. |
|||
| 446 | -2x | +|||
| 140 | +
- grid::gTree(+ #' |
|||
| 447 | -2x | +|||
| 141 | +
- children = grid::gList(+ #' @examples |
|||
| 448 | -2x | +|||
| 142 | +
- grid::rectGrob(gp = grid::gpar(col = "gray90", fill = "gray90")),+ #' # Default is to cut into quartile bins. |
|||
| 449 | -2x | +|||
| 143 | +
- if (is.null(vline)) {
+ #' cut_quantile_bins(cars$speed) |
|||
| 450 | -! | +|||
| 144 | +
- NULL+ #' |
|||
| 451 | +145 |
- } else {
+ #' # Use custom quantiles. |
||
| 452 | -2x | +|||
| 146 | +
- grid::linesGrob(+ #' cut_quantile_bins(cars$speed, probs = c(0.1, 0.2, 0.6, 0.88)) |
|||
| 453 | -2x | +|||
| 147 | +
- x = grid::unit(rep(vline, 2), "native"),+ #' |
|||
| 454 | -2x | +|||
| 148 | +
- y = grid::unit(c(0, 1), "npc"),+ #' # Use custom labels. |
|||
| 455 | -2x | +|||
| 149 | +
- gp = grid::gpar(lwd = 2),+ #' cut_quantile_bins(cars$speed, labels = paste0("Q", 1:4))
|
|||
| 456 | -2x | +|||
| 150 | +
- vp = data_forest_vp+ #' |
|||
| 457 | +151 |
- )+ #' # NAs are preserved in result factor. |
||
| 458 | +152 |
- },+ #' ozone_binned <- cut_quantile_bins(airquality$Ozone) |
||
| 459 | -2x | +|||
| 153 | +
- grid::xaxisGrob(at = x_at, label = x_labels, vp = data_forest_vp)+ #' which(is.na(ozone_binned)) |
|||
| 460 | +154 |
- ),+ #' # So you might want to make these explicit. |
||
| 461 | -2x | +|||
| 155 | +
- vp = grid::viewport(layout.pos.col = ncol(tbl) + 2)+ #' explicit_na(ozone_binned) |
|||
| 462 | +156 |
- )+ #' |
||
| 463 | +157 |
- ),+ #' @export |
||
| 464 | -2x | +|||
| 158 | +
- vp = grid::vpPath("vp_table_layout", "vp_body")
+ cut_quantile_bins <- function(x, |
|||
| 465 | +159 |
- ),+ probs = c(0.25, 0.5, 0.75), |
||
| 466 | -2x | +|||
| 160 | +
- grid::gTree(+ labels = NULL, |
|||
| 467 | -2x | +|||
| 161 | +
- children = do.call(+ type = 7, |
|||
| 468 | -2x | +|||
| 162 | +
- grid::gList,+ ordered = TRUE) {
|
|||
| 469 | -2x | +163 | +8x |
- Map(+ checkmate::assert_flag(ordered) |
| 470 | -2x | +164 | +8x |
- function(xi, li, ui, row_index, size_i, col) {
+ checkmate::assert_numeric(x) |
| 471 | -9x | +165 | +7x |
- forest_dot_line(+ if (isFALSE(0 %in% probs)) probs <- c(0, probs) |
| 472 | -9x | +166 | +7x |
- xi,+ if (isFALSE(1 %in% probs)) probs <- c(probs, 1) |
| 473 | -9x | +167 | +8x |
- li,+ checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE) |
| 474 | -9x | +168 | +7x |
- ui,+ if (is.null(labels)) labels <- bins_percent_labels(probs) |
| 475 | -9x | +169 | +8x |
- row_index,+ checkmate::assert_character(labels, len = length(probs) - 1, any.missing = FALSE, unique = TRUE) |
| 476 | -9x | +|||
| 170 | +
- xlim,+ |
|||
| 477 | -9x | +171 | +8x |
- symbol_size = size_i,+ if (all(is.na(x))) {
|
| 478 | -9x | +|||
| 172 | +
- col = col,+ # Early return if there are only NAs in input. |
|||
| 479 | -9x | +173 | +1x |
- datavp = data_forest_vp+ return(factor(x, ordered = ordered, levels = labels)) |
| 480 | +174 |
- )+ } |
||
| 481 | +175 |
- },+ |
||
| 482 | -2x | +176 | +7x |
- x,+ quantiles <- stats::quantile( |
| 483 | -2x | +177 | +7x |
- lower,+ x, |
| 484 | -2x | +178 | +7x |
- upper,+ probs = probs, |
| 485 | -2x | +179 | +7x |
- seq_along(x),+ type = type, |
| 486 | -2x | +180 | +7x |
- symbol_size,+ na.rm = TRUE |
| 487 | -2x | +|||
| 181 | +
- col,+ ) |
|||
| 488 | -2x | +|||
| 182 | +
- USE.NAMES = FALSE+ |
|||
| 489 | -+ | |||
| 183 | +7x |
- )+ checkmate::assert_numeric(quantiles, unique = TRUE) |
||
| 490 | +184 |
- ),+ |
||
| 491 | -2x | +185 | +6x |
- vp = grid::vpPath("vp_table_layout", "vp_body")
+ cut( |
| 492 | -+ | |||
| 186 | +6x |
- )+ x, |
||
| 493 | -+ | |||
| 187 | +6x |
- ),+ breaks = quantiles, |
||
| 494 | -2x | +188 | +6x |
- childrenvp = forest_viewport(tbl, width_row_names, width_columns, width_forest),+ labels = labels, |
| 495 | -2x | +189 | +6x | +
+ ordered_result = ordered,+ |
+
| 190 | +6x |
- vp = vp,+ include.lowest = TRUE, |
||
| 496 | -2x | +191 | +6x |
- gp = gp+ right = TRUE |
| 497 | +192 |
) |
||
| 498 | +193 |
} |
||
| 499 | +194 | |||
| 500 | +195 |
-
+ #' Discard Certain Levels from a Factor |
||
| 501 | +196 |
- cell_in_rows <- function(row_name,+ #' |
||
| 502 | +197 |
- cells,+ #' @description `r lifecycle::badge("stable")`
|
||
| 503 | +198 |
- cell_spans,+ #' |
||
| 504 | +199 |
- row_index,+ #' This discards the observations as well as the levels specified from a factor. |
||
| 505 | +200 |
- underline_colspan = FALSE) {
+ #' |
||
| 506 | -13x | +|||
| 201 | +
- checkmate::assert_string(row_name)+ #' @param x (`factor`)\cr the original factor. |
|||
| 507 | -13x | +|||
| 202 | +
- checkmate::assert_character(cells, min.len = 1, any.missing = FALSE)+ #' @param discard (`character`)\cr which levels to discard. |
|||
| 508 | -13x | +|||
| 203 | +
- checkmate::assert_numeric(cell_spans, len = length(cells), any.missing = FALSE)+ #' |
|||
| 509 | -13x | +|||
| 204 | +
- checkmate::assert_number(row_index)+ #' @return A modified `factor` with observations as well as levels from `discard` dropped. |
|||
| 510 | -13x | +|||
| 205 | +
- checkmate::assert_flag(underline_colspan)+ #' |
|||
| 511 | +206 |
-
+ #' @examples |
||
| 512 | -13x | +|||
| 207 | +
- vp_name_rn <- paste0("rowname-", row_index)
+ #' fct_discard(factor(c("a", "b", "c")), "c")
|
|||
| 513 | -13x | +|||
| 208 | +
- g_rowname <- if (!is.null(row_name) && row_name != "") {
+ #' |
|||
| 514 | -10x | +|||
| 209 | +
- grid::textGrob(+ #' @export |
|||
| 515 | -10x | +|||
| 210 | +
- name = vp_name_rn,+ fct_discard <- function(x, discard) {
|
|||
| 516 | -10x | +211 | +292x |
- label = row_name,+ checkmate::assert_factor(x) |
| 517 | -10x | +212 | +292x |
- x = grid::unit(0, "npc"),+ checkmate::assert_character(discard, any.missing = FALSE) |
| 518 | -10x | +213 | +292x |
- just = c("left", "center"),
+ new_obs <- x[!(x %in% discard)] |
| 519 | -10x | +214 | +292x |
- vp = grid::vpPath(paste0("rowname-", row_index))
+ new_levels <- setdiff(levels(x), discard) |
| 520 | -+ | |||
| 215 | +292x |
- )+ factor(new_obs, levels = new_levels) |
||
| 521 | +216 |
- } else {
+ } |
||
| 522 | -3x | +|||
| 217 | +
- NULL+ |
|||
| 523 | +218 |
- }+ #' Insertion of Explicit Missings in a Factor |
||
| 524 | +219 |
-
+ #' |
||
| 525 | -13x | +|||
| 220 | +
- gl_cols <- if (!(length(cells) > 0)) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 526 | -! | +|||
| 221 | +
- list(NULL)+ #' |
|||
| 527 | +222 |
- } else {
+ #' This inserts explicit missings in a factor based on a condition. Additionally, |
||
| 528 | -13x | +|||
| 223 | +
- j <- 1 # column index of cell+ #' existing `NA` values will be explicitly converted to given `na_level`. |
|||
| 529 | +224 |
-
+ #' |
||
| 530 | -13x | +|||
| 225 | +
- lapply(seq_along(cells), function(k) {
+ #' @param x (`factor`)\cr the original factor. |
|||
| 531 | -67x | +|||
| 226 | +
- cell_ascii <- cells[[k]]+ #' @param condition (`logical`)\cr where to insert missings. |
|||
| 532 | -67x | +|||
| 227 | +
- cs <- cell_spans[[k]]+ #' @param na_level (`string`)\cr which level to use for missings. |
|||
| 533 | +228 |
-
+ #' |
||
| 534 | -67x | +|||
| 229 | +
- if (is.na(cell_ascii) || is.null(cell_ascii)) {
+ #' @return A modified `factor` with inserted and existing `NA` converted to `na_level`. |
|||
| 535 | -! | +|||
| 230 | +
- cell_ascii <- "NA"+ #' |
|||
| 536 | +231 |
- }+ #' @seealso [forcats::fct_na_value_to_level()] which is used internally. |
||
| 537 | +232 |
-
+ #' |
||
| 538 | -67x | +|||
| 233 | +
- cell_name <- paste0("g-cell-", row_index, "-", j)
+ #' @examples |
|||
| 539 | +234 |
-
+ #' fct_explicit_na_if(factor(c("a", "b", NA)), c(TRUE, FALSE, FALSE))
|
||
| 540 | -67x | +|||
| 235 | +
- cell_grobs <- if (identical(cell_ascii, "")) {
+ #' |
|||
| 541 | -14x | +|||
| 236 | +
- NULL+ #' @export |
|||
| 542 | +237 |
- } else {
+ fct_explicit_na_if <- function(x, condition, na_level = "<Missing>") {
|
||
| 543 | -53x | +238 | +1x |
- if (cs == 1) {
+ checkmate::assert_factor(x, len = length(condition)) |
| 544 | -49x | +239 | +1x |
- grid::textGrob(+ checkmate::assert_logical(condition) |
| 545 | -49x | +240 | +1x |
- label = cell_ascii,+ x[condition] <- NA |
| 546 | -49x | +241 | +1x |
- name = cell_name,+ x <- forcats::fct_na_value_to_level(x, level = na_level) |
| 547 | -49x | +242 | +1x |
- vp = grid::vpPath(paste0("cell-", row_index, "-", j))
+ forcats::fct_drop(x, only = na_level) |
| 548 | +243 |
- )+ } |
||
| 549 | +244 |
- } else {
+
|
||
| 550 | +245 |
- # +1 because of rowname- |
- ||
| 551 | -4x | -
- vp_joined_cols <- grid::viewport(layout.pos.row = row_index, layout.pos.col = seq(j + 1, j + cs))+ #' Collapsing of Factor Levels and Keeping Only Those New Group Levels |
||
| 552 | +246 | - - | -||
| 553 | -4x | -
- lab <- grid::textGrob(+ #' |
||
| 554 | -4x | +|||
| 247 | +
- label = cell_ascii,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 555 | -4x | +|||
| 248 | +
- name = cell_name,+ #' |
|||
| 556 | -4x | +|||
| 249 | +
- vp = vp_joined_cols+ #' This collapses levels and only keeps those new group levels, in the order provided. |
|||
| 557 | +250 |
- )+ #' The returned factor has levels in the order given, with the possible missing level last (this will |
||
| 558 | +251 |
-
+ #' only be included if there are missing values). |
||
| 559 | -4x | +|||
| 252 | +
- if (!underline_colspan || grepl("^[[:space:]]*$", cell_ascii)) {
+ #' |
|||
| 560 | -1x | +|||
| 253 | +
- lab+ #' @param .f (`factor` or `character`)\cr original vector. |
|||
| 561 | +254 |
- } else {
+ #' @param ... (named `character` vectors)\cr levels in each vector provided will be collapsed into |
||
| 562 | -3x | +|||
| 255 | +
- grid::gList(+ #' the new level given by the respective name. |
|||
| 563 | -3x | +|||
| 256 | +
- lab,+ #' @param .na_level (`string`)\cr which level to use for other levels, which should be missing in the |
|||
| 564 | -3x | +|||
| 257 | +
- grid::linesGrob(+ #' new factor. Note that this level must not be contained in the new levels specified in `...`. |
|||
| 565 | -3x | +|||
| 258 | +
- x = grid::unit.c(grid::unit(.2, "lines"), grid::unit(1, "npc") - grid::unit(.2, "lines")),+ #' |
|||
| 566 | -3x | +|||
| 259 | +
- y = grid::unit(c(0, 0), "npc"),+ #' @return A modified `factor` with collapsed levels. Values and levels which are not included |
|||
| 567 | -3x | +|||
| 260 | +
- vp = vp_joined_cols+ #' in the given `character` vector input will be set to the missing level `.na_level`. |
|||
| 568 | +261 |
- )+ #' |
||
| 569 | +262 |
- )+ #' @note Any existing `NA`s in the input vector will not be replaced by the missing level. If needed, |
||
| 570 | +263 |
- }+ #' [explicit_na()] can be called separately on the result. |
||
| 571 | +264 |
- }+ #' |
||
| 572 | +265 |
- }+ #' @seealso [forcats::fct_collapse()], [forcats::fct_relevel()] which are used internally. |
||
| 573 | -67x | +|||
| 266 | +
- j <<- j + cs+ #' |
|||
| 574 | +267 |
-
+ #' @examples |
||
| 575 | -67x | +|||
| 268 | +
- cell_grobs+ #' fct_collapse_only(factor(c("a", "b", "c", "d")), TRT = "b", CTRL = c("c", "d"))
|
|||
| 576 | +269 |
- })+ #' |
||
| 577 | +270 |
- }+ #' @export |
||
| 578 | +271 |
-
+ fct_collapse_only <- function(.f, ..., .na_level = "<Missing>") {
|
||
| 579 | -13x | +272 | +4x |
- grid::gList(+ new_lvls <- names(list(...)) |
| 580 | -13x | +273 | +4x |
- g_rowname,+ if (checkmate::test_subset(.na_level, new_lvls)) {
|
| 581 | -13x | +274 | +1x |
- do.call(grid::gList, gl_cols)+ stop(paste0(".na_level currently set to '", .na_level, "' must not be contained in the new levels"))
|
| 582 | +275 |
- )+ }+ |
+ ||
| 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))) |
||
| 583 | +278 |
} |
||
| 584 | +279 | |||
| 585 | +280 |
- #' Graphic Object: Forest Dot Line+ #' Ungroup Non-Numeric Statistics |
||
| 586 | +281 |
#' |
||
| 587 | +282 |
- #' Calculate the `grob` corresponding to the dot line within the forest plot.+ #' Ungroups grouped non-numeric statistics within input vectors `.formats`, `.labels`, and `.indent_mods`. |
||
| 588 | +283 |
#' |
||
| 589 | +284 |
- #' @noRd+ #' @inheritParams argument_convention |
||
| 590 | +285 |
- forest_dot_line <- function(x,+ #' @param x (`named list` of `numeric`)\cr list of numeric statistics containing the statistics to ungroup. |
||
| 591 | +286 |
- lower,+ #' |
||
| 592 | +287 |
- upper,+ #' @return A `list` with modified elements `x`, `.formats`, `.labels`, and `.indent_mods`. |
||
| 593 | +288 |
- row_index,+ #' |
||
| 594 | +289 |
- xlim,+ #' @seealso [a_summary()] which uses this function internally. |
||
| 595 | +290 |
- symbol_size = 1,+ #' |
||
| 596 | +291 |
- col = "blue",+ #' @keywords internal |
||
| 597 | +292 |
- datavp) {
- |
- ||
| 598 | -9x | -
- ci <- c(lower, upper)- |
- ||
| 599 | -9x | -
- if (any(!is.na(c(x, ci)))) {
+ ungroup_stats <- function(x, |
||
| 600 | +293 |
- # line+ .formats, |
||
| 601 | -7x | +|||
| 294 | +
- y <- grid::unit(c(0.5, 0.5), "npc")+ .labels, |
|||
| 602 | +295 |
-
+ .indent_mods) {
|
||
| 603 | -7x | +296 | +224x |
- g_line <- if (all(!is.na(ci)) && ci[2] > xlim[1] && ci[1] < xlim[2]) {
+ checkmate::assert_list(x) |
| 604 | -+ | |||
| 297 | +224x |
- # -+ empty_pval <- "pval" %in% names(x) && length(x[["pval"]]) == 0 |
||
| 605 | -7x | +298 | +224x |
- if (ci[1] >= xlim[1] && ci[2] <= xlim[2]) {
+ empty_pval_counts <- "pval_counts" %in% names(x) && length(x[["pval_counts"]]) == 0 |
| 606 | -2x | +299 | +224x |
- grid::linesGrob(x = grid::unit(c(ci[1], ci[2]), "native"), y = y)+ x <- unlist(x, recursive = FALSE) |
| 607 | -5x | +|||
| 300 | +
- } else if (ci[1] < xlim[1] && ci[2] > xlim[2]) {
+
|
|||
| 608 | +301 |
- # <->+ # If p-value is empty it is removed by unlist and needs to be re-added |
||
| 609 | -3x | +|||
| 302 | +! |
- grid::linesGrob(+ if (empty_pval) x[["pval"]] <- character() |
||
| 610 | +303 | 3x |
- x = grid::unit(xlim, "native"),+ if (empty_pval_counts) x[["pval_counts"]] <- character() |
|
| 611 | -3x | +304 | +224x |
- y = y,+ .stats <- names(x) |
| 612 | -3x | +|||
| 305 | +
- arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "both")+ |
|||
| 613 | +306 |
- )+ # Ungroup stats |
||
| 614 | -2x | +307 | +224x |
- } else if (ci[1] < xlim[1] && ci[2] <= xlim[2]) {
+ .formats <- lapply(.stats, function(x) {
+ |
+
| 308 | +2049x | +
+ .formats[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
|
||
| 615 | +309 |
- # <-+ }) |
||
| 616 | -! | +|||
| 310 | +224x |
- grid::linesGrob(+ .indent_mods <- sapply(.stats, function(x) {
|
||
| 617 | -! | +|||
| 311 | +2049x |
- x = grid::unit(c(xlim[1], ci[2]), "native"),+ .indent_mods[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
|
||
| 618 | -! | +|||
| 312 | +
- y = y,+ }) |
|||
| 619 | -! | +|||
| 313 | +224x |
- arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "first")+ .labels <- sapply(.stats, function(x) {
|
||
| 620 | -+ | |||
| 314 | +1998x |
- )+ if (!grepl("\\.", x)) .labels[[x]] else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][2]
|
||
| 621 | -2x | +|||
| 315 | +
- } else if (ci[1] >= xlim[1] && ci[2] > xlim[2]) {
+ }) |
|||
| 622 | +316 |
- # ->+ |
||
| 623 | -2x | +317 | +224x |
- grid::linesGrob(+ list( |
| 624 | -2x | +318 | +224x |
- x = grid::unit(c(ci[1], xlim[2]), "native"),+ x = x, |
| 625 | -2x | +319 | +224x |
- y = y,+ .formats = .formats, |
| 626 | -2x | +320 | +224x |
- arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "last")+ .labels = .labels, |
| 627 | -+ | |||
| 321 | +224x |
- )+ .indent_mods = .indent_mods |
||
| 628 | +322 |
- }+ ) |
||
| 629 | +323 |
- } else {
- |
- ||
| 630 | -! | -
- NULL+ } |
| 631 | +1 |
- }+ #' Occurrence Counts by Grade |
||
| 632 | +2 | - - | -||
| 633 | -7x | -
- g_circle <- if (!is.na(x) && x >= xlim[1] && x <= xlim[2]) {
- |
- ||
| 634 | -6x | -
- grid::circleGrob(+ #' |
||
| 635 | -6x | +|||
| 3 | +
- x = grid::unit(x, "native"),+ #' @description `r lifecycle::badge("stable")`
|
|||
| 636 | -6x | +|||
| 4 | +
- y = y,+ #' |
|||
| 637 | -6x | +|||
| 5 | +
- r = grid::unit(1 / 3.5 * symbol_size, "lines"),+ #' Functions for analyzing frequencies and fractions of occurrences by grade for patients |
|||
| 638 | -6x | +|||
| 6 | +
- name = "point"+ #' with occurrence data. Multiple occurrences within one individual are counted once at the |
|||
| 639 | +7 |
- )+ #' greatest intensity/highest grade level. |
||
| 640 | +8 |
- } else {
+ #' |
||
| 641 | -1x | +|||
| 9 | +
- NULL+ #' @inheritParams argument_convention |
|||
| 642 | +10 |
- }+ #' @param grade_groups (named `list` of `character`)\cr containing groupings of grades. |
||
| 643 | +11 |
-
+ #' @param remove_single (`logical`)\cr `TRUE` to not include the elements of one-element grade groups |
||
| 644 | -7x | +|||
| 12 | +
- grid::gTree(+ #' in the the output list; in this case only the grade groups names will be included in the output. |
|||
| 645 | -7x | +|||
| 13 | +
- children = grid::gList(+ #' |
|||
| 646 | -7x | +|||
| 14 | +
- grid::gTree(+ #' @seealso Relevant helper function [h_append_grade_groups()]. |
|||
| 647 | -7x | +|||
| 15 | +
- children = grid::gList(+ #' |
|||
| 648 | -7x | +|||
| 16 | +
- grid::gList(+ #' @name count_occurrences_by_grade |
|||
| 649 | -7x | +|||
| 17 | +
- g_line,+ NULL |
|||
| 650 | -7x | +|||
| 18 | +
- g_circle+ |
|||
| 651 | +19 |
- )+ #' Helper function for [s_count_occurrences_by_grade()] |
||
| 652 | +20 |
- ),+ #' |
||
| 653 | -7x | +|||
| 21 | +
- vp = datavp,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 654 | -7x | +|||
| 22 | +
- gp = grid::gpar(col = col, fill = col)+ #' |
|||
| 655 | +23 |
- )+ #' Helper function for [s_count_occurrences_by_grade()] to insert grade groupings into list with |
||
| 656 | +24 |
- ),+ #' individual grade frequencies. The order of the final result follows the order of `grade_groups`. |
||
| 657 | -7x | +|||
| 25 | +
- vp = grid::vpPath(paste0("forest-", row_index))
+ #' The elements under any-grade group (if any), i.e. the grade group equal to `refs` will be moved to |
|||
| 658 | +26 |
- )+ #' the end. Grade groups names must be unique. |
||
| 659 | +27 |
- } else {
+ #' |
||
| 660 | -2x | +|||
| 28 | +
- NULL+ #' @inheritParams count_occurrences_by_grade |
|||
| 661 | +29 |
- }+ #' @param refs (named `list` of `numeric`)\cr where each name corresponds to a reference grade level |
||
| 662 | +30 |
- }+ #' and each entry represents a count. |
||
| 663 | +31 |
-
+ #' |
||
| 664 | +32 |
- #' Create a Viewport Tree for the Forest Plot+ #' @return Formatted list of grade groupings. |
||
| 665 | +33 |
- #' @param tbl (`rtable`)+ #' |
||
| 666 | +34 |
- #' @param width_row_names (`grid::unit`)\cr Width of row names+ #' @examples |
||
| 667 | +35 |
- #' @param width_columns (`grid::unit`)\cr Width of column spans+ #' h_append_grade_groups( |
||
| 668 | +36 |
- #' @param width_forest (`grid::unit`)\cr Width of the forest plot+ #' list( |
||
| 669 | +37 |
- #' @param gap_column (`grid::unit`)\cr Gap width between the columns+ #' "Any Grade" = as.character(1:5), |
||
| 670 | +38 |
- #' @param gap_header (`grid::unit`)\cr Gap width between the header+ #' "Grade 1-2" = c("1", "2"),
|
||
| 671 | +39 |
- #' @param mat_form matrix print form of the table+ #' "Grade 3-4" = c("3", "4")
|
||
| 672 | +40 |
- #' @return A viewport tree.+ #' ), |
||
| 673 | +41 |
- #'+ #' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
|
||
| 674 | +42 |
- #' @examples+ #' ) |
||
| 675 | +43 |
- #' library(grid)+ #' |
||
| 676 | +44 |
- #'+ #' h_append_grade_groups( |
||
| 677 | +45 |
- #' tbl <- rtable(+ #' list( |
||
| 678 | +46 |
- #' header = rheader(+ #' "Any Grade" = as.character(5:1), |
||
| 679 | +47 |
- #' rrow("", "E", rcell("CI", colspan = 2)),
+ #' "Grade A" = "5", |
||
| 680 | +48 |
- #' rrow("", "A", "B", "C")
+ #' "Grade B" = c("4", "3")
|
||
| 681 | +49 |
#' ), |
||
| 682 | +50 |
- #' rrow("row 1", 1, 0.8, 1.1),
+ #' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
|
||
| 683 | +51 |
- #' rrow("row 2", 1.4, 0.8, 1.6),
+ #' ) |
||
| 684 | +52 |
- #' rrow("row 3", 1.2, 0.8, 1.2)
+ #' |
||
| 685 | +53 |
- #' )+ #' h_append_grade_groups( |
||
| 686 | +54 |
- #'+ #' list( |
||
| 687 | +55 |
- #' \donttest{
+ #' "Any Grade" = as.character(1:5), |
||
| 688 | +56 |
- #' v <- forest_viewport(tbl)+ #' "Grade 1-2" = c("1", "2"),
|
||
| 689 | +57 |
- #'+ #' "Grade 3-4" = c("3", "4")
|
||
| 690 | +58 |
- #' grid::grid.newpage()+ #' ), |
||
| 691 | +59 |
- #' showViewport(v)+ #' list("1" = 10, "2" = 5, "3" = 0)
|
||
| 692 | +60 |
- #' }+ #' ) |
||
| 693 | +61 |
#' |
||
| 694 | +62 |
#' @export |
||
| 695 | +63 |
- forest_viewport <- function(tbl,+ h_append_grade_groups <- function(grade_groups, refs, remove_single = TRUE) {
|
||
| 696 | -+ | |||
| 64 | +13x |
- width_row_names = NULL,+ checkmate::assert_list(grade_groups) |
||
| 697 | -+ | |||
| 65 | +13x |
- width_columns = NULL,+ checkmate::assert_list(refs) |
||
| 698 | -+ | |||
| 66 | +13x |
- width_forest = grid::unit(1, "null"),+ refs_orig <- refs |
||
| 699 | -+ | |||
| 67 | +13x |
- gap_column = grid::unit(1, "lines"),+ elements <- unique(unlist(grade_groups)) |
||
| 700 | +68 |
- gap_header = grid::unit(1, "lines"),+ |
||
| 701 | +69 |
- mat_form = NULL) {
+ ### compute sums in groups |
||
| 702 | -2x | +70 | +13x |
- checkmate::assert_class(tbl, "VTableTree")+ grp_sum <- lapply(grade_groups, function(i) do.call(sum, refs[i])) |
| 703 | -2x | +71 | +13x |
- checkmate::assert_true(grid::is.unit(width_forest))+ if (!checkmate::test_subset(elements, names(refs))) {
|
| 704 | +72 | 2x |
- if (!is.null(width_row_names)) {
+ padding_el <- setdiff(elements, names(refs)) |
|
| 705 | -! | +|||
| 73 | +2x |
- checkmate::assert_true(grid::is.unit(width_row_names))+ refs[padding_el] <- 0 |
||
| 706 | +74 |
} |
||
| 707 | -2x | -
- if (!is.null(width_columns)) {
- |
- ||
| 708 | -! | +75 | +13x |
- checkmate::assert_true(grid::is.unit(width_columns))+ result <- c(grp_sum, refs) |
| 709 | +76 |
- }+ |
||
| 710 | +77 |
-
+ ### order result while keeping grade_groups's ordering |
||
| 711 | -2x | +78 | +13x |
- if (is.null(mat_form)) mat_form <- matrix_form(tbl)+ ordr <- grade_groups |
| 712 | +79 | |||
| 713 | -2x | -
- mat_form$strings[!mat_form$display] <- ""- |
- ||
| 714 | +80 |
-
+ # elements of any-grade group (if any) will be moved to the end |
||
| 715 | -2x | +81 | +13x |
- nr <- nrow(tbl)+ is_any <- sapply(grade_groups, setequal, y = names(refs)) |
| 716 | -2x | +82 | +13x |
- nc <- ncol(tbl)+ ordr[is_any] <- list(character(0)) # hide elements under any-grade group |
| 717 | -2x | +|||
| 83 | +
- nr_h <- attr(mat_form, "nrow_header")+ |
|||
| 718 | +84 |
-
+ # groups-elements combined sequence |
||
| 719 | -2x | +85 | +13x |
- if (is.null(width_row_names) || is.null(width_columns)) {
+ ordr <- c(lapply(names(ordr), function(g) c(g, ordr[[g]])), recursive = TRUE, use.names = FALSE) |
| 720 | -2x | +86 | +13x |
- tbl_widths <- formatters::propose_column_widths(mat_form)+ ordr <- ordr[!duplicated(ordr)] |
| 721 | -2x | +|||
| 87 | +
- strs_with_width <- strrep("x", tbl_widths) # that works for mono spaced fonts
+
|
|||
| 722 | -2x | +|||
| 88 | +
- if (is.null(width_row_names)) width_row_names <- grid::stringWidth(strs_with_width[1])+ # append remaining elements (if any) |
|||
| 723 | -2x | +89 | +13x |
- if (is.null(width_columns)) width_columns <- grid::stringWidth(strs_with_width[-1])+ ordr <- union(ordr, unlist(grade_groups[is_any])) # from any-grade group |
| 724 | -+ | |||
| 90 | +13x |
- }+ ordr <- union(ordr, names(refs)) # from refs |
||
| 725 | +91 | |||
| 726 | +92 |
- # Widths for row name, cols, forest.+ # remove elements of single-element groups, if any |
||
| 727 | -2x | +93 | +13x |
- widths <- grid::unit.c(+ if (remove_single) {
|
| 728 | -2x | +94 | +13x |
- width_row_names + gap_column,+ is_single <- sapply(grade_groups, length) == 1L |
| 729 | -2x | +95 | +13x |
- width_columns + gap_column,+ ordr <- setdiff(ordr, unlist(grade_groups[is_single])) |
| 730 | -2x | +|||
| 96 | +
- width_forest+ } |
|||
| 731 | +97 |
- )+ |
||
| 732 | +98 |
-
+ # apply the order |
||
| 733 | -2x | +99 | +13x |
- n_lines_per_row <- apply(+ result <- result[ordr] |
| 734 | -2x | +|||
| 100 | +
- X = mat_form$strings,+ |
|||
| 735 | -2x | +|||
| 101 | +
- MARGIN = 1,+ # remove groups without any elements in the original refs |
|||
| 736 | -2x | +|||
| 102 | +
- FUN = function(row) {
+ # note: it's OK if groups have 0 value |
|||
| 737 | +103 | 13x |
- tmp <- vapply(+ keep_grp <- vapply(grade_groups, function(x, rf) {
|
|
| 738 | -13x | +104 | +37x |
- gregexpr("\n", row, fixed = TRUE),
+ any(x %in% rf) |
| 739 | +105 | 13x |
- attr, numeric(1),+ }, rf = names(refs_orig), logical(1)) |
|
| 740 | -13x | +|||
| 106 | +
- "match.length"+ |
|||
| 741 | +107 | 13x |
- ) + 1+ keep_el <- names(result) %in% names(refs_orig) | names(result) %in% names(keep_grp)[keep_grp] |
|
| 742 | +108 | 13x |
- max(c(tmp, 1))+ result <- result[keep_el] |
|
| 743 | +109 |
- }+ + |
+ ||
| 110 | +13x | +
+ result |
||
| 744 | +111 |
- )+ } |
||
| 745 | +112 | |||
| 746 | -2x | +|||
| 113 | +
- i_header <- seq_len(nr_h)+ #' @describeIn count_occurrences_by_grade Statistics function which counts the |
|||
| 747 | +114 |
-
+ #' number of patients by highest grade. |
||
| 748 | -2x | +|||
| 115 | +
- height_body_rows <- grid::unit(n_lines_per_row[-i_header] * 1.2, "lines")+ #' |
|||
| 749 | -2x | +|||
| 116 | +
- height_header_rows <- grid::unit(n_lines_per_row[i_header] * 1.2, "lines")+ #' @return |
|||
| 750 | +117 |
-
+ #' * `s_count_occurrences_by_grade()` returns a list of counts and fractions with one element per grade level or |
||
| 751 | -2x | +|||
| 118 | +
- height_body <- grid::unit(sum(n_lines_per_row[-i_header]) * 1.2, "lines")+ #' grade level grouping. |
|||
| 752 | -2x | +|||
| 119 | +
- height_header <- grid::unit(sum(n_lines_per_row[i_header]) * 1.2, "lines")+ #' |
|||
| 753 | +120 |
-
+ #' @examples |
||
| 754 | -2x | +|||
| 121 | +
- nc_g <- nc + 2 # number of columns incl. row names and forest+ #' library(dplyr) |
|||
| 755 | +122 |
-
+ #' df <- data.frame( |
||
| 756 | -2x | +|||
| 123 | +
- vp_tbl <- grid::vpTree(+ #' USUBJID = as.character(c(1:6, 1)), |
|||
| 757 | -2x | +|||
| 124 | +
- parent = grid::viewport(+ #' ARM = factor(c("A", "A", "A", "B", "B", "B", "A"), levels = c("A", "B")),
|
|||
| 758 | -2x | +|||
| 125 | +
- name = "vp_table_layout",+ #' AETOXGR = factor(c(1, 2, 3, 4, 1, 2, 3), levels = c(1:5)), |
|||
| 759 | -2x | +|||
| 126 | +
- layout = grid::grid.layout(+ #' AESEV = factor( |
|||
| 760 | -2x | +|||
| 127 | +
- nrow = 3, ncol = 1,+ #' x = c("MILD", "MODERATE", "SEVERE", "MILD", "MILD", "MODERATE", "SEVERE"),
|
|||
| 761 | -2x | +|||
| 128 | +
- heights = grid::unit.c(height_header, gap_header, height_body)+ #' levels = c("MILD", "MODERATE", "SEVERE")
|
|||
| 762 | +129 |
- )+ #' ), |
||
| 763 | +130 |
- ),+ #' stringsAsFactors = FALSE |
||
| 764 | -2x | +|||
| 131 | +
- children = grid::vpList(+ #' ) |
|||
| 765 | -2x | +|||
| 132 | +
- vp_forest_table_part(nr_h, nc_g, 1, 1, widths, height_header_rows, "vp_header"),+ #' df_adsl <- df %>% |
|||
| 766 | -2x | +|||
| 133 | +
- vp_forest_table_part(nr, nc_g, 3, 1, widths, height_body_rows, "vp_body"),+ #' select(USUBJID, ARM) %>% |
|||
| 767 | -2x | +|||
| 134 | +
- grid::viewport(name = "vp_spacer", layout.pos.row = 2, layout.pos.col = 1)+ #' unique() |
|||
| 768 | +135 |
- )+ #' |
||
| 769 | +136 |
- )+ #' s_count_occurrences_by_grade( |
||
| 770 | -2x | +|||
| 137 | +
- vp_tbl+ #' df, |
|||
| 771 | +138 |
- }+ #' .N_col = 10L, |
||
| 772 | +139 |
-
+ #' .var = "AETOXGR", |
||
| 773 | +140 |
- #' Viewport Forest Plot: Table Part+ #' id = "USUBJID", |
||
| 774 | +141 |
- #'+ #' grade_groups = list("ANY" = levels(df$AETOXGR))
|
||
| 775 | +142 |
- #' Prepares a viewport for the table included in the forest plot.+ #' ) |
||
| 776 | +143 |
#' |
||
| 777 | +144 |
- #' @noRd+ #' @export |
||
| 778 | +145 |
- vp_forest_table_part <- function(nrow,+ s_count_occurrences_by_grade <- function(df, |
||
| 779 | +146 |
- ncol,+ .var, |
||
| 780 | +147 |
- l_row,+ .N_col, # nolint |
||
| 781 | +148 |
- l_col,+ id = "USUBJID", |
||
| 782 | +149 |
- widths,+ grade_groups = list(), |
||
| 783 | +150 |
- heights,+ remove_single = TRUE, |
||
| 784 | +151 |
- name) {
+ labelstr = "") {
|
||
| 785 | -4x | +152 | +6x |
- grid::vpTree(+ assert_valid_factor(df[[.var]]) |
| 786 | -4x | +153 | +6x |
- grid::viewport(+ assert_df_with_variables(df, list(grade = .var, id = id)) |
| 787 | -4x | +|||
| 154 | +
- name = name,+ |
|||
| 788 | -4x | +155 | +6x |
- layout.pos.row = l_row,+ if (nrow(df) < 1) {
|
| 789 | -4x | +|||
| 156 | +! |
- layout.pos.col = l_col,+ grade_levels <- levels(df[[.var]]) |
||
| 790 | -4x | +|||
| 157 | +! |
- layout = grid::grid.layout(nrow = nrow, ncol = ncol, widths = widths, heights = heights)+ l_count <- as.list(rep(0, length(grade_levels)))+ |
+ ||
| 158 | +! | +
+ names(l_count) <- grade_levels |
||
| 791 | +159 |
- ),+ } else {
|
||
| 792 | -4x | +160 | +6x |
- children = grid::vpList(+ if (isTRUE(is.factor(df[[id]]))) {
|
| 793 | -4x | +|||
| 161 | +! |
- do.call(+ assert_valid_factor(df[[id]], any.missing = FALSE) |
||
| 794 | -4x | +|||
| 162 | +
- grid::vpList,+ } else {
|
|||
| 795 | -4x | +163 | +6x |
- lapply(+ checkmate::assert_character(df[[id]], min.chars = 1, any.missing = FALSE) |
| 796 | -4x | +|||
| 164 | +
- seq_len(nrow), function(i) {
+ } |
|||
| 797 | -13x | +165 | +6x |
- grid::viewport(layout.pos.row = i, layout.pos.col = 1, name = paste0("rowname-", i))
+ checkmate::assert_count(.N_col) |
| 798 | +166 |
- }+ |
||
| 799 | -+ | |||
| 167 | +6x |
- )+ id <- df[[id]] |
||
| 800 | -+ | |||
| 168 | +6x |
- ),+ grade <- df[[.var]] |
||
| 801 | -4x | +|||
| 169 | +
- do.call(+ |
|||
| 802 | -4x | +170 | +6x |
- grid::vpList,+ if (!is.ordered(grade)) {
|
| 803 | -4x | +171 | +6x |
- apply(+ grade_lbl <- obj_label(grade) |
| 804 | -4x | +172 | +6x |
- expand.grid(seq_len(nrow), seq_len(ncol - 2)),+ lvls <- levels(grade) |
| 805 | -4x | +173 | +6x |
- 1,+ if (sum(grepl("^\\d+$", lvls)) %in% c(0, length(lvls))) {
|
| 806 | -4x | +174 | +5x |
- function(x) {
+ lvl_ord <- lvls |
| 807 | -71x | +|||
| 175 | +
- i <- x[1]+ } else {
|
|||
| 808 | -71x | +176 | +1x |
- j <- x[2]+ lvls[!grepl("^\\d+$", lvls)] <- min(as.numeric(lvls[grepl("^\\d+$", lvls)])) - 1
|
| 809 | -71x | +177 | +1x |
- grid::viewport(layout.pos.row = i, layout.pos.col = j + 1, name = paste0("cell-", i, "-", j))
+ lvl_ord <- levels(grade)[order(as.numeric(lvls))] |
| 810 | +178 |
- }+ } |
||
| 811 | -+ | |||
| 179 | +6x |
- )+ grade <- formatters::with_label(factor(grade, levels = lvl_ord, ordered = TRUE), grade_lbl) |
||
| 812 | +180 |
- ),+ } |
||
| 813 | -4x | +|||
| 181 | +
- do.call(+ |
|||
| 814 | -4x | +182 | +6x |
- grid::vpList,+ missing_lvl <- grepl("missing", tolower(levels(grade)))
|
| 815 | -4x | +183 | +6x |
- lapply(+ if (any(missing_lvl)) {
|
| 816 | -4x | +184 | +1x |
- seq_len(nrow),+ grade <- factor( |
| 817 | -4x | +185 | +1x |
- function(i) {
+ grade, |
| 818 | -13x | -
- grid::viewport(layout.pos.row = i, layout.pos.col = ncol, name = paste0("forest-", i))
- |
- ||
| 819 | -+ | 186 | +1x |
- }+ levels = c(levels(grade)[!missing_lvl], levels(grade)[missing_lvl]), |
| 820 | -+ | |||
| 187 | +1x |
- )+ ordered = is.ordered(grade) |
||
| 821 | +188 |
) |
||
| 822 | -- |
- )- |
- ||
| 823 | +189 |
- )+ } |
||
| 824 | -+ | |||
| 190 | +6x |
- }+ df_max <- stats::aggregate(grade ~ id, FUN = max, drop = FALSE) |
||
| 825 | -+ | |||
| 191 | +6x |
-
+ l_count <- as.list(table(df_max$grade)) |
||
| 826 | +192 |
- #' Forest Rendering+ } |
||
| 827 | +193 |
- #'+ |
||
| 828 | -+ | |||
| 194 | +6x |
- #' Renders the forest grob.+ if (length(grade_groups) > 0) {
|
||
| 829 | -+ | |||
| 195 | +2x |
- #'+ l_count <- h_append_grade_groups(grade_groups, l_count, remove_single) |
||
| 830 | +196 |
- #' @noRd+ } |
||
| 831 | +197 |
- grid.forest <- function(...) { # nolint
+
|
||
| 832 | -! | +|||
| 198 | +6x |
- grid::grid.draw(forest_grob(...))+ l_count_fraction <- lapply(l_count, function(i, denom) c(i, i / denom), denom = .N_col) |
||
| 833 | +199 |
- }+ |
| 1 | -+ | |||
| 200 | +6x |
- #' Cox Regression Helper: Interactions+ list( |
||
| 2 | -+ | |||
| 201 | +6x |
- #'+ count_fraction = l_count_fraction |
||
| 3 | +202 |
- #' @description `r lifecycle::badge("stable")`
+ ) |
||
| 4 | +203 |
- #'+ } |
||
| 5 | +204 |
- #' Test and estimate the effect of a treatment in interaction with a covariate.+ |
||
| 6 | +205 |
- #' The effect is estimated as the HR of the tested treatment for a given level+ #' @describeIn count_occurrences_by_grade Formatted analysis function which is used as `afun` |
||
| 7 | +206 |
- #' of the covariate, in comparison to the treatment control.+ #' in `count_occurrences_by_grade()`. |
||
| 8 | +207 |
#' |
||
| 9 | -- |
- #' @inheritParams argument_convention- |
- ||
| 10 | -- |
- #' @param x (`numeric` or `factor`)\cr the values of the covariate to be tested.- |
- ||
| 11 | +208 |
- #' @param effect (`string`)\cr the name of the effect to be tested and estimated.+ #' @return |
||
| 12 | +209 |
- #' @param covar (`string`)\cr the name of the covariate in the model.+ #' * `a_count_occurrences_by_grade()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 13 | +210 |
- #' @param mod (`coxph`)\cr the Cox regression model.+ #' |
||
| 14 | +211 |
- #' @param label (`string`)\cr the label to be returned as `term_label`.+ #' @examples |
||
| 15 | +212 |
- #' @param control (`list`)\cr a list of controls as returned by [control_coxreg()].+ #' # We need to ungroup `count_fraction` first so that the `rtables` formatting |
||
| 16 | +213 |
- #' @param ... see methods.+ #' # function `format_count_fraction()` can be applied correctly. |
||
| 17 | +214 |
- #'+ #' afun <- make_afun(a_count_occurrences_by_grade, .ungroup_stats = "count_fraction") |
||
| 18 | +215 |
- #' @examples+ #' afun( |
||
| 19 | +216 |
- #' library(survival)+ #' df, |
||
| 20 | +217 |
- #'+ #' .N_col = 10L, |
||
| 21 | +218 |
- #' set.seed(1, kind = "Mersenne-Twister")+ #' .var = "AETOXGR", |
||
| 22 | +219 |
- #'+ #' id = "USUBJID", |
||
| 23 | +220 |
- #' # Testing dataset [survival::bladder].+ #' grade_groups = list("ANY" = levels(df$AETOXGR))
|
||
| 24 | +221 |
- #' dta_bladder <- with(+ #' ) |
||
| 25 | +222 |
- #' data = bladder[bladder$enum < 5, ],+ #' |
||
| 26 | +223 |
- #' data.frame(+ #' @export |
||
| 27 | +224 |
- #' time = stop,+ a_count_occurrences_by_grade <- make_afun( |
||
| 28 | +225 |
- #' status = event,+ s_count_occurrences_by_grade, |
||
| 29 | +226 |
- #' armcd = as.factor(rx),+ .formats = c("count_fraction" = format_count_fraction_fixed_dp)
|
||
| 30 | +227 |
- #' covar1 = as.factor(enum),+ ) |
||
| 31 | +228 |
- #' covar2 = factor(+ |
||
| 32 | +229 |
- #' sample(as.factor(enum)),+ #' @describeIn count_occurrences_by_grade Layout-creating function which can take statistics function |
||
| 33 | +230 |
- #' levels = 1:4,+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 34 | +231 |
- #' labels = c("F", "F", "M", "M")
+ #' |
||
| 35 | +232 |
- #' )+ #' @param var_labels (`character`)\cr labels to show in the result table. |
||
| 36 | +233 |
- #' )+ #' |
||
| 37 | +234 |
- #' )+ #' @return |
||
| 38 | +235 |
- #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
+ #' * `count_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions, |
||
| 39 | +236 |
- #' formatters::var_labels(dta_bladder)[names(labels)] <- labels+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 40 | +237 |
- #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ #' the statistics from `s_count_occurrences_by_grade()` to the table layout. |
||
| 41 | +238 |
#' |
||
| 42 | +239 |
- #' plot(+ #' @examples |
||
| 43 | +240 |
- #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder),+ #' # Layout creating function with custom format. |
||
| 44 | +241 |
- #' lty = 2:4,+ #' basic_table() %>% |
||
| 45 | +242 |
- #' xlab = "Months",+ #' split_cols_by("ARM") %>%
|
||
| 46 | +243 |
- #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
+ #' add_colcounts() %>% |
||
| 47 | +244 |
- #' )+ #' count_occurrences_by_grade( |
||
| 48 | +245 |
- #'+ #' var = "AESEV", |
||
| 49 | +246 |
- #' @name cox_regression_inter+ #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
|
||
| 50 | +247 |
- NULL+ #' ) %>% |
||
| 51 | +248 |
-
+ #' build_table(df, alt_counts_df = df_adsl) |
||
| 52 | +249 |
- #' @describeIn cox_regression_inter S3 generic helper function to determine interaction effect.+ #' |
||
| 53 | +250 |
- #'+ #' # Define additional grade groupings. |
||
| 54 | +251 |
- #' @return+ #' grade_groups <- list( |
||
| 55 | +252 |
- #' * `h_coxreg_inter_effect()` returns a `data.frame` of covariate interaction effects consisting of the following+ #' "-Any-" = c("1", "2", "3", "4", "5"),
|
||
| 56 | +253 |
- #' variables: `effect`, `term`, `term_label`, `level`, `n`, `hr`, `lcl`, `ucl`, `pval`, and `pval_inter`.+ #' "Grade 1-2" = c("1", "2"),
|
||
| 57 | +254 |
- #'+ #' "Grade 3-5" = c("3", "4", "5")
|
||
| 58 | +255 |
- #' @export+ #' ) |
||
| 59 | +256 |
- h_coxreg_inter_effect <- function(x,+ #' |
||
| 60 | +257 |
- effect,+ #' basic_table() %>% |
||
| 61 | +258 |
- covar,+ #' split_cols_by("ARM") %>%
|
||
| 62 | +259 |
- mod,+ #' add_colcounts() %>% |
||
| 63 | +260 |
- label,+ #' count_occurrences_by_grade( |
||
| 64 | +261 |
- control,+ #' var = "AETOXGR", |
||
| 65 | +262 |
- ...) {
+ #' grade_groups = grade_groups |
||
| 66 | -26x | +|||
| 263 | +
- UseMethod("h_coxreg_inter_effect", x)
+ #' ) %>% |
|||
| 67 | +264 |
- }+ #' build_table(df, alt_counts_df = df_adsl) |
||
| 68 | +265 |
-
+ #' |
||
| 69 | +266 |
- #' @describeIn cox_regression_inter Method for `numeric` class. Estimates the interaction with a `numeric` covariate.+ #' @export |
||
| 70 | +267 |
- #'+ count_occurrences_by_grade <- function(lyt, |
||
| 71 | +268 |
- #' @method h_coxreg_inter_effect numeric+ var, |
||
| 72 | +269 |
- #'+ var_labels = var, |
||
| 73 | +270 |
- #' @param at (`list`)\cr a list with items named after the covariate, every+ show_labels = "default", |
||
| 74 | +271 |
- #' item is a vector of levels at which the interaction should be estimated.+ riskdiff = FALSE, |
||
| 75 | +272 |
- #'+ na_str = NA_character_, |
||
| 76 | +273 |
- #' @export+ nested = TRUE, |
||
| 77 | +274 |
- h_coxreg_inter_effect.numeric <- function(x,+ ..., |
||
| 78 | +275 |
- effect,+ table_names = var, |
||
| 79 | +276 |
- covar,+ .stats = NULL, |
||
| 80 | +277 |
- mod,+ .formats = NULL, |
||
| 81 | +278 |
- label,+ .indent_mods = NULL, |
||
| 82 | +279 |
- control,+ .labels = NULL) {
|
||
| 83 | -+ | |||
| 280 | +8x |
- at,+ checkmate::assert_flag(riskdiff) |
||
| 84 | +281 |
- ...) {
+
|
||
| 85 | -7x | +282 | +8x |
- betas <- stats::coef(mod)+ afun <- make_afun( |
| 86 | -7x | +283 | +8x |
- attrs <- attr(stats::terms(mod), "term.labels")+ a_count_occurrences_by_grade, |
| 87 | -7x | +284 | +8x |
- term_indices <- grep(+ .stats = .stats, |
| 88 | -7x | +285 | +8x |
- pattern = effect,+ .formats = .formats, |
| 89 | -7x | +286 | +8x |
- x = attrs[!grepl("strata\\(", attrs)]
+ .indent_mods = .indent_mods,+ |
+
| 287 | +8x | +
+ .ungroup_stats = "count_fraction" |
||
| 90 | +288 |
) |
||
| 91 | -7x | +|||
| 289 | +
- checkmate::assert_vector(term_indices, len = 2)+ |
|||
| 92 | -7x | +290 | +8x |
- betas <- betas[term_indices]+ extra_args <- if (isFALSE(riskdiff)) {
|
| 93 | +291 | 7x |
- betas_var <- diag(stats::vcov(mod))[term_indices]+ list(...)+ |
+ |
| 292 | ++ |
+ } else {
|
||
| 94 | -7x | +293 | +1x |
- betas_cov <- stats::vcov(mod)[term_indices[1], term_indices[2]]+ list( |
| 95 | -7x | +294 | +1x |
- xval <- if (is.null(at[[covar]])) {
+ afun = list("s_count_occurrences_by_grade" = afun),
|
| 96 | -6x | +295 | +1x |
- stats::median(x)+ .stats = .stats, |
| 97 | -+ | |||
| 296 | +1x |
- } else {
+ .indent_mods = .indent_mods, |
||
| 98 | +297 | 1x |
- at[[covar]]+ s_args = list(...) |
|
| 99 | +298 |
- }+ ) |
||
| 100 | -7x | +|||
| 299 | +
- effect_index <- !grepl(covar, names(betas))+ } |
|||
| 101 | -7x | +|||
| 300 | +
- coef_hat <- betas[effect_index] + xval * betas[!effect_index]+ |
|||
| 102 | -7x | +301 | +8x |
- coef_se <- sqrt(+ analyze( |
| 103 | -7x | +302 | +8x |
- betas_var[effect_index] ++ lyt = lyt, |
| 104 | -7x | +303 | +8x |
- xval ^ 2 * betas_var[!effect_index] + # styler: off+ vars = var, |
| 105 | -7x | +304 | +8x |
- 2 * xval * betas_cov+ var_labels = var_labels, |
| 106 | -+ | |||
| 305 | +8x |
- )+ show_labels = show_labels, |
||
| 107 | -7x | +306 | +8x |
- q_norm <- stats::qnorm((1 + control$conf_level) / 2)+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff), |
| 108 | -7x | +307 | +8x |
- data.frame(+ table_names = table_names, |
| 109 | -7x | +308 | +8x |
- effect = "Covariate:",+ na_str = na_str, |
| 110 | -7x | +309 | +8x |
- term = rep(covar, length(xval)),+ nested = nested, |
| 111 | -7x | +310 | +8x |
- term_label = paste0(" ", xval),
+ extra_args = extra_args |
| 112 | -7x | +|||
| 311 | +
- level = as.character(xval),+ ) |
|||
| 113 | -7x | +|||
| 312 | +
- n = NA,+ } |
|||
| 114 | -7x | +|||
| 313 | +
- hr = exp(coef_hat),+ |
|||
| 115 | -7x | +|||
| 314 | +
- lcl = exp(coef_hat - q_norm * coef_se),+ #' @describeIn count_occurrences_by_grade Layout-creating function which can take content function arguments |
|||
| 116 | -7x | +|||
| 315 | +
- ucl = exp(coef_hat + q_norm * coef_se),+ #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()]. |
|||
| 117 | -7x | +|||
| 316 | +
- pval = NA,+ #' |
|||
| 118 | -7x | +|||
| 317 | +
- pval_inter = NA,+ #' @return |
|||
| 119 | -7x | +|||
| 318 | +
- stringsAsFactors = FALSE+ #' * `summarize_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions, |
|||
| 120 | +319 |
- )+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows |
||
| 121 | +320 |
- }+ #' containing the statistics from `s_count_occurrences_by_grade()` to the table layout. |
||
| 122 | +321 |
-
+ #' |
||
| 123 | +322 |
- #' @describeIn cox_regression_inter Method for `factor` class. Estimate the interaction with a `factor` covariate.+ #' @examples |
||
| 124 | +323 |
- #'+ #' # Layout creating function with custom format. |
||
| 125 | +324 |
- #' @method h_coxreg_inter_effect factor+ #' basic_table() %>% |
||
| 126 | +325 |
- #'+ #' add_colcounts() %>% |
||
| 127 | +326 |
- #' @param data (`data.frame`)\cr the data frame on which the model was fit.+ #' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
|
||
| 128 | +327 |
- #'+ #' summarize_occurrences_by_grade( |
||
| 129 | +328 |
- #' @export+ #' var = "AESEV", |
||
| 130 | +329 |
- h_coxreg_inter_effect.factor <- function(x,+ #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
|
||
| 131 | +330 |
- effect,+ #' ) %>% |
||
| 132 | +331 |
- covar,+ #' build_table(df, alt_counts_df = df_adsl) |
||
| 133 | +332 |
- mod,+ #' |
||
| 134 | +333 |
- label,+ #' basic_table() %>% |
||
| 135 | +334 |
- control,+ #' add_colcounts() %>% |
||
| 136 | +335 |
- data,+ #' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
|
||
| 137 | +336 |
- ...) {
+ #' summarize_occurrences_by_grade( |
||
| 138 | -15x | +|||
| 337 | +
- lvl_given <- levels(x)+ #' var = "AETOXGR", |
|||
| 139 | -15x | +|||
| 338 | +
- y <- h_coxreg_inter_estimations(+ #' grade_groups = grade_groups |
|||
| 140 | -15x | +|||
| 339 | +
- variable = effect, given = covar,+ #' ) %>% |
|||
| 141 | -15x | +|||
| 340 | +
- lvl_var = levels(data[[effect]]),+ #' build_table(df, alt_counts_df = df_adsl) |
|||
| 142 | -15x | +|||
| 341 | +
- lvl_given = lvl_given,+ #' |
|||
| 143 | -15x | +|||
| 342 | +
- mod = mod,+ #' @export |
|||
| 144 | -15x | +|||
| 343 | +
- conf_level = 0.95+ summarize_occurrences_by_grade <- function(lyt, |
|||
| 145 | -15x | +|||
| 344 | +
- )[[1]]+ var, |
|||
| 146 | +345 |
-
+ na_str = NA_character_, |
||
| 147 | -15x | +|||
| 346 | +
- data.frame(+ ..., |
|||
| 148 | -15x | +|||
| 347 | +
- effect = "Covariate:",+ .stats = NULL, |
|||
| 149 | -15x | +|||
| 348 | +
- term = rep(covar, nrow(y)),+ .formats = NULL, |
|||
| 150 | -15x | +|||
| 349 | +
- term_label = paste0(" ", lvl_given),
+ .indent_mods = NULL, |
|||
| 151 | -15x | +|||
| 350 | +
- level = lvl_given,+ .labels = NULL) {
|
|||
| 152 | -15x | +351 | +2x |
- n = NA,+ cfun <- make_afun( |
| 153 | -15x | +352 | +2x |
- hr = y[, "hr"],+ a_count_occurrences_by_grade, |
| 154 | -15x | +353 | +2x |
- lcl = y[, "lcl"],+ .stats = .stats, |
| 155 | -15x | +354 | +2x |
- ucl = y[, "ucl"],+ .formats = .formats, |
| 156 | -15x | +355 | +2x |
- pval = NA,+ .labels = .labels, |
| 157 | -15x | +356 | +2x |
- pval_inter = NA,+ .indent_mods = .indent_mods, |
| 158 | -15x | +357 | +2x |
- stringsAsFactors = FALSE+ .ungroup_stats = "count_fraction" |
| 159 | +358 |
) |
||
| 160 | -- |
- }- |
- ||
| 161 | +359 | |||
| 162 | -+ | |||
| 360 | +2x |
- #' @describeIn cox_regression_inter Method for `character` class. Estimate the interaction with a `character` covariate.+ summarize_row_groups( |
||
| 163 | -+ | |||
| 361 | +2x |
- #' This makes an automatic conversion to `factor` and then forwards to the method for factors.+ lyt = lyt, |
||
| 164 | -+ | |||
| 362 | +2x |
- #'+ var = var, |
||
| 165 | -+ | |||
| 363 | +2x |
- #' @method h_coxreg_inter_effect character+ cfun = cfun, |
||
| 166 | -+ | |||
| 364 | +2x |
- #'+ na_str = na_str, |
||
| 167 | -+ | |||
| 365 | +2x |
- #' @note+ extra_args = list(...) |
||
| 168 | +366 |
- #' * Automatic conversion of character to factor does not guarantee results can be generated correctly. It is+ ) |
||
| 169 | +367 |
- #' therefore better to always pre-process the dataset such that factors are manually created from character+ } |
| 170 | +1 |
- #' variables before passing the dataset to [rtables::build_table()].+ #' Survival Time Analysis |
||
| 171 | +2 |
#' |
||
| 172 | +3 |
- #' @export+ #' @description `r lifecycle::badge("stable")`
|
||
| 173 | +4 |
- h_coxreg_inter_effect.character <- function(x,+ #' |
||
| 174 | +5 |
- effect,+ #' Summarize median survival time and CIs, percentiles of survival times, survival |
||
| 175 | +6 |
- covar,+ #' time range of censored/event patients. |
||
| 176 | +7 |
- mod,+ #' |
||
| 177 | +8 |
- label,+ #' @inheritParams argument_convention |
||
| 178 | +9 |
- control,+ #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function |
||
| 179 | +10 |
- data,+ #' [control_surv_time()]. Some possible parameter options are: |
||
| 180 | +11 |
- ...) {
- |
- ||
| 181 | -4x | -
- y <- as.factor(x)+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival time. |
||
| 182 | +12 | - - | -||
| 183 | -4x | -
- h_coxreg_inter_effect(- |
- ||
| 184 | -4x | -
- x = y,- |
- ||
| 185 | -4x | -
- effect = effect,- |
- ||
| 186 | -4x | -
- covar = covar,- |
- ||
| 187 | -4x | -
- mod = mod,- |
- ||
| 188 | -4x | -
- label = label,- |
- ||
| 189 | -4x | -
- control = control,+ #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", or "log-log", |
||
| 190 | -4x | +|||
| 13 | +
- data = data,+ #' see more in [survival::survfit()]. Note option "none" is not supported. |
|||
| 191 | +14 |
- ...+ #' * `quantiles` (`numeric`)\cr vector of length two to specify the quantiles of survival time. |
||
| 192 | +15 |
- )+ #' |
||
| 193 | +16 |
- }+ #' @name survival_time |
||
| 194 | +17 |
-
+ NULL |
||
| 195 | +18 |
- #' @describeIn cox_regression_inter A higher level function to get+ |
||
| 196 | +19 |
- #' the results of the interaction test and the estimated values.+ #' @describeIn survival_time Statistics function which analyzes survival times. |
||
| 197 | +20 |
#' |
||
| 198 | +21 |
#' @return |
||
| 199 | +22 |
- #' * `h_coxreg_extract_interaction()` returns the result of an interaction test and the estimated values. If+ #' * `s_surv_time()` returns the statistics: |
||
| 200 | +23 |
- #' no interaction, [h_coxreg_univar_extract()] is applied instead.+ #' * `median`: Median survival time. |
||
| 201 | +24 |
- #'+ #' * `median_ci`: Confidence interval for median time. |
||
| 202 | +25 |
- #' @examples+ #' * `quantiles`: Survival time for two specified quantiles. |
||
| 203 | +26 |
- #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder)+ #' * `range_censor`: Survival time range for censored observations. |
||
| 204 | +27 |
- #' h_coxreg_extract_interaction(+ #' * `range_event`: Survival time range for observations with events. |
||
| 205 | +28 |
- #' mod = mod, effect = "armcd", covar = "covar1", data = dta_bladder,+ #' * `range`: Survival time range for all observations. |
||
| 206 | +29 |
- #' control = control_coxreg()+ #' |
||
| 207 | +30 |
- #' )+ #' @examples |
||
| 208 | +31 |
- #'+ #' library(dplyr) |
||
| 209 | +32 |
- #' @export+ #' |
||
| 210 | +33 |
- h_coxreg_extract_interaction <- function(effect,+ #' adtte_f <- tern_ex_adtte %>% |
||
| 211 | +34 |
- covar,+ #' filter(PARAMCD == "OS") %>% |
||
| 212 | +35 |
- mod,+ #' mutate( |
||
| 213 | +36 |
- data,+ #' AVAL = day2month(AVAL), |
||
| 214 | +37 |
- at,+ #' is_event = CNSR == 0 |
||
| 215 | +38 |
- control) {
- |
- ||
| 216 | -27x | -
- if (!any(attr(stats::terms(mod), "order") == 2)) {
- |
- ||
| 217 | -10x | -
- y <- h_coxreg_univar_extract(- |
- ||
| 218 | -10x | -
- effect = effect, covar = covar, mod = mod, data = data, control = control+ #' ) |
||
| 219 | +39 |
- )+ #' df <- adtte_f %>% filter(ARMCD == "ARM A") |
||
| 220 | -10x | +|||
| 40 | +
- y$pval_inter <- NA+ #' |
|||
| 221 | -10x | +|||
| 41 | +
- y+ #' @keywords internal |
|||
| 222 | +42 |
- } else {
+ s_surv_time <- function(df, |
||
| 223 | -17x | +|||
| 43 | +
- test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]+ .var, |
|||
| 224 | +44 |
-
+ is_event, |
||
| 225 | +45 |
- # Test the main treatment effect.+ control = control_surv_time()) {
|
||
| 226 | -17x | +46 | +146x |
- mod_aov <- muffled_car_anova(mod, test_statistic)+ checkmate::assert_string(.var) |
| 227 | -17x | +47 | +146x |
- sum_anova <- broom::tidy(mod_aov)+ assert_df_with_variables(df, list(tte = .var, is_event = is_event)) |
| 228 | -17x | +48 | +146x |
- pval <- sum_anova[sum_anova$term == effect, ][["p.value"]]+ checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE) |
| 229 | -+ | |||
| 49 | +146x |
-
+ checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE) |
||
| 230 | +50 |
- # Test the interaction effect.+ |
||
| 231 | -17x | +51 | +146x |
- pval_inter <- sum_anova[grep(":", sum_anova$term), ][["p.value"]]
+ conf_type <- control$conf_type |
| 232 | -17x | +52 | +146x |
- covar_test <- data.frame(+ conf_level <- control$conf_level |
| 233 | -17x | +53 | +146x |
- effect = "Covariate:",+ quantiles <- control$quantiles |
| 234 | -17x | +|||
| 54 | +
- term = covar,+ |
|||
| 235 | -17x | +55 | +146x |
- term_label = unname(labels_or_names(data[covar])),+ formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
|
| 236 | -17x | +56 | +146x |
- level = "",+ srv_fit <- survival::survfit( |
| 237 | -17x | +57 | +146x |
- n = mod$n, hr = NA, lcl = NA, ucl = NA, pval = pval,+ formula = formula, |
| 238 | -17x | +58 | +146x |
- pval_inter = pval_inter,+ data = df, |
| 239 | -17x | +59 | +146x |
- stringsAsFactors = FALSE+ conf.int = conf_level, |
| 240 | -+ | |||
| 60 | +146x |
- )+ conf.type = conf_type |
||
| 241 | +61 |
- # Estimate the interaction.+ ) |
||
| 242 | -17x | +62 | +146x |
- y <- h_coxreg_inter_effect(+ srv_tab <- summary(srv_fit, extend = TRUE)$table |
| 243 | -17x | +63 | +146x |
- data[[covar]],+ srv_qt_tab <- stats::quantile(srv_fit, probs = quantiles)$quantile |
| 244 | -17x | +64 | +146x |
- covar = covar,+ range_censor <- range_noinf(df[[.var]][!df[[is_event]]], na.rm = TRUE) |
| 245 | -17x | +65 | +146x |
- effect = effect,+ range_event <- range_noinf(df[[.var]][df[[is_event]]], na.rm = TRUE) |
| 246 | -17x | +66 | +146x |
- mod = mod,+ range <- range_noinf(df[[.var]], na.rm = TRUE) |
| 247 | -17x | +67 | +146x |
- label = unname(labels_or_names(data[covar])),+ list( |
| 248 | -17x | +68 | +146x |
- at = at,+ median = formatters::with_label(unname(srv_tab["median"]), "Median"), |
| 249 | -17x | +69 | +146x |
- control = control,+ median_ci = formatters::with_label( |
| 250 | -17x | +70 | +146x |
- data = data+ unname(srv_tab[paste0(srv_fit$conf.int, c("LCL", "UCL"))]), f_conf_level(conf_level)
|
| 251 | +71 |
- )+ ), |
||
| 252 | -17x | +72 | +146x |
- rbind(covar_test, y)+ quantiles = formatters::with_label( |
| 253 | -+ | |||
| 73 | +146x |
- }+ unname(srv_qt_tab), paste0(quantiles[1] * 100, "% and ", quantiles[2] * 100, "%-ile") |
||
| 254 | +74 |
- }+ ), |
||
| 255 | -+ | |||
| 75 | +146x |
-
+ range_censor = formatters::with_label(range_censor, "Range (censored)"), |
||
| 256 | -+ | |||
| 76 | +146x |
- #' @describeIn cox_regression_inter Hazard ratio estimation in interactions.+ range_event = formatters::with_label(range_event, "Range (event)"), |
||
| 257 | -+ | |||
| 77 | +146x |
- #'+ range = formatters::with_label(range, "Range") |
||
| 258 | +78 |
- #' @param variable,given (`string`)\cr the name of variables in interaction. We seek the estimation+ ) |
||
| 259 | +79 |
- #' of the levels of `variable` given the levels of `given`.+ } |
||
| 260 | +80 |
- #' @param lvl_var,lvl_given (`character`)\cr corresponding levels has given by [levels()].+ |
||
| 261 | +81 |
- #' @param mod (`coxph`)\cr a fitted Cox regression model (see [survival::coxph()]).+ #' @describeIn survival_time Formatted analysis function which is used as `afun` in `surv_time()`. |
||
| 262 | +82 |
#' |
||
| 263 | +83 |
- #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A)+ #' @return |
||
| 264 | +84 |
- #' and Sex (F, M; reference Female) and the model being abbreviated: y ~ Arm + Sex + Arm:Sex.+ #' * `a_surv_time()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 265 | +85 |
- #' The cox regression estimates the coefficients along with a variance-covariance matrix for:+ #' |
||
| 266 | +86 |
- #'+ #' @keywords internal |
||
| 267 | +87 |
- #' - b1 (arm b), b2 (arm c)+ a_surv_time <- make_afun( |
||
| 268 | +88 |
- #' - b3 (sex m)+ s_surv_time, |
||
| 269 | +89 |
- #' - b4 (arm b: sex m), b5 (arm c: sex m)+ .formats = c( |
||
| 270 | +90 |
- #'+ "median" = "xx.x", |
||
| 271 | +91 |
- #' The estimation of the Hazard Ratio for arm C/sex M is given in reference+ "median_ci" = "(xx.x, xx.x)", |
||
| 272 | +92 |
- #' to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5).+ "quantiles" = "xx.x, xx.x", |
||
| 273 | +93 |
- #' The interaction coefficient is deduced by b2 + b5 while the standard error+ "range_censor" = "xx.x to xx.x", |
||
| 274 | +94 |
- #' is obtained as $sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$.+ "range_event" = "xx.x to xx.x", |
||
| 275 | +95 |
- #'+ "range" = "xx.x to xx.x" |
||
| 276 | +96 |
- #' @return+ ) |
||
| 277 | +97 |
- #' * `h_coxreg_inter_estimations()` returns a list of matrices (one per level of variable) with rows corresponding+ ) |
||
| 278 | +98 |
- #' to the combinations of `variable` and `given`, with columns:+ |
||
| 279 | +99 |
- #' * `coef_hat`: Estimation of the coefficient.+ #' @describeIn survival_time Layout-creating function which can take statistics function arguments |
||
| 280 | +100 |
- #' * `coef_se`: Standard error of the estimation.+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 281 | +101 |
- #' * `hr`: Hazard ratio.+ #' |
||
| 282 | +102 |
- #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio.+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 283 | +103 |
- #'+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
||
| 284 | +104 |
- #' @examples+ #' for that statistic's row label. |
||
| 285 | +105 |
- #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder)+ #' |
||
| 286 | +106 |
- #' result <- h_coxreg_inter_estimations(+ #' @return |
||
| 287 | +107 |
- #' variable = "armcd", given = "covar1",+ #' * `surv_time()` returns a layout object suitable for passing to further layouting functions, |
||
| 288 | +108 |
- #' lvl_var = levels(dta_bladder$armcd),+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 289 | +109 |
- #' lvl_given = levels(dta_bladder$covar1),+ #' the statistics from `s_surv_time()` to the table layout. |
||
| 290 | +110 |
- #' mod = mod, conf_level = .95+ #' |
||
| 291 | +111 |
- #' )+ #' @examples |
||
| 292 | +112 |
- #' result+ #' basic_table() %>% |
||
| 293 | +113 |
- #'+ #' split_cols_by(var = "ARMCD") %>% |
||
| 294 | +114 |
- #' @export+ #' add_colcounts() %>% |
||
| 295 | +115 |
- h_coxreg_inter_estimations <- function(variable,+ #' surv_time( |
||
| 296 | +116 |
- given,+ #' vars = "AVAL", |
||
| 297 | +117 |
- lvl_var,+ #' var_labels = "Survival Time (Months)", |
||
| 298 | +118 |
- lvl_given,+ #' is_event = "is_event", |
||
| 299 | +119 |
- mod,+ #' control = control_surv_time(conf_level = 0.9, conf_type = "log-log") |
||
| 300 | +120 |
- conf_level = 0.95) {
- |
- ||
| 301 | -16x | -
- var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level- |
- ||
| 302 | -16x | -
- giv_lvl <- paste0(given, lvl_given)- |
- ||
| 303 | -16x | -
- design_mat <- expand.grid(variable = var_lvl, given = giv_lvl)- |
- ||
| 304 | -16x | -
- design_mat <- design_mat[order(design_mat$variable, design_mat$given), ]- |
- ||
| 305 | -16x | -
- design_mat <- within(- |
- ||
| 306 | -16x | -
- data = design_mat,- |
- ||
| 307 | -16x | -
- expr = {
- |
- ||
| 308 | -16x | -
- inter <- paste0(variable, ":", given)- |
- ||
| 309 | -16x | -
- rev_inter <- paste0(given, ":", variable)+ #' ) %>% |
||
| 310 | +121 |
- }+ #' build_table(df = adtte_f) |
||
| 311 | +122 |
- )- |
- ||
| 312 | -16x | -
- split_by_variable <- design_mat$variable- |
- ||
| 313 | -16x | -
- interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/")+ #' |
||
| 314 | +123 | - - | -||
| 315 | -16x | -
- mmat <- stats::model.matrix(mod)[1, ]- |
- ||
| 316 | -16x | -
- mmat[!mmat == 0] <- 0+ #' @export |
||
| 317 | +124 | - - | -||
| 318 | -16x | -
- design_mat <- apply(- |
- ||
| 319 | -16x | -
- X = design_mat, MARGIN = 1, FUN = function(x) {
+ surv_time <- function(lyt, |
||
| 320 | -46x | +|||
| 125 | +
- mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1+ vars, |
|||
| 321 | -46x | +|||
| 126 | +
- mmat+ na_str = NA_character_, |
|||
| 322 | +127 |
- }+ nested = TRUE, |
||
| 323 | +128 |
- )+ ..., |
||
| 324 | -16x | +|||
| 129 | +
- colnames(design_mat) <- interaction_names+ var_labels = "Time to Event", |
|||
| 325 | +130 |
-
+ table_names = vars, |
||
| 326 | -16x | +|||
| 131 | +
- coef <- stats::coef(mod)+ .stats = c("median", "median_ci", "quantiles", "range_censor", "range_event"),
|
|||
| 327 | -16x | +|||
| 132 | +
- vcov <- stats::vcov(mod)+ .formats = NULL, |
|||
| 328 | -16x | +|||
| 133 | +
- betas <- as.matrix(coef)+ .labels = NULL, |
|||
| 329 | -16x | +|||
| 134 | +
- coef_hat <- t(design_mat) %*% betas+ .indent_mods = c( |
|||
| 330 | -16x | +|||
| 135 | +
- dimnames(coef_hat)[2] <- "coef"+ "median" = 0L, "median_ci" = 1L, "quantiles" = 0L, |
|||
| 331 | -16x | +|||
| 136 | +
- coef_se <- apply(+ "range_censor" = 0L, "range_event" = 0L, "range" = 0L |
|||
| 332 | -16x | +|||
| 137 | +
- design_mat, 2,+ )) {
|
|||
| 333 | -16x | +138 | +2x |
- function(x) {
+ afun <- make_afun( |
| 334 | -46x | +139 | +2x |
- vcov_el <- as.logical(x)+ a_surv_time, |
| 335 | -46x | +140 | +2x |
- y <- vcov[vcov_el, vcov_el]+ .stats = .stats, |
| 336 | -46x | +141 | +2x |
- y <- sum(y)+ .formats = .formats, |
| 337 | -46x | +142 | +2x |
- y <- sqrt(y)+ .labels = .labels, |
| 338 | -46x | -
- return(y)- |
- ||
| 339 | -+ | 143 | +2x |
- }+ .indent_mods = extract_by_name(.indent_mods, .stats) |
| 340 | +144 |
) |
||
| 341 | -16x | -
- q_norm <- stats::qnorm((1 + conf_level) / 2)- |
- ||
| 342 | -16x | -
- y <- cbind(coef_hat, `se(coef)` = coef_se)- |
- ||
| 343 | -16x | -
- y <- apply(y, 1, function(x) {
- |
- ||
| 344 | -46x | -
- x["hr"] <- exp(x["coef"])- |
- ||
| 345 | -46x | +145 | +2x |
- x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"])+ analyze( |
| 346 | -46x | +146 | +2x |
- x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"])+ lyt, |
| 347 | -46x | -
- x- |
- ||
| 348 | -+ | 147 | +2x |
- })+ vars, |
| 349 | -16x | +148 | +2x |
- y <- t(y)+ na_str = na_str, |
| 350 | -16x | +149 | +2x |
- y <- by(y, split_by_variable, identity)+ nested = nested, |
| 351 | -16x | +150 | +2x |
- y <- lapply(y, as.matrix)+ var_labels = var_labels, |
| 352 | -16x | +151 | +2x |
- attr(y, "details") <- paste0(+ show_labels = "visible", |
| 353 | -16x | +152 | +2x |
- "Estimations of ", variable,+ table_names = table_names, |
| 354 | -16x | +153 | +2x |
- " hazard ratio given the level of ", given, " compared to ",+ afun = afun, |
| 355 | -16x | +154 | +2x |
- variable, " level ", lvl_var[1], "."+ extra_args = list(...) |
| 356 | +155 |
) |
||
| 357 | -16x | -
- y- |
- ||
| 358 | +156 |
}@@ -64342,14 +64468,14 @@ tern coverage - 94.83% |
| 1 |
- #' Univariate Formula Special Term+ #' Survival Time Point Analysis |
|||
| 5 |
- #' The special term `univariate` indicate that the model should be fitted individually for+ #' Summarize patients' survival rate and difference of survival rates between groups at a time point. |
|||
| 6 |
- #' every variable included in univariate.+ #' |
|||
| 7 |
- #'+ #' @inheritParams argument_convention |
|||
| 8 |
- #' @param x A vector of variable name separated by commas.+ #' @inheritParams s_surv_time |
|||
| 9 |
- #'+ #' @param time_point (`number`)\cr survival time point of interest. |
|||
| 10 |
- #' @return When used within a model formula, produces univariate models for each variable provided.+ #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function |
|||
| 11 |
- #'+ #' [control_surv_timepoint()]. Some possible parameter options are: |
|||
| 12 |
- #' @details+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate. |
|||
| 13 |
- #' If provided alongside with pairwise specification, the model+ #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log", |
|||
| 14 |
- #' `y ~ ARM + univariate(SEX, AGE, RACE)` lead to the study and comparison of the models+ #' see more in [survival::survfit()]. Note option "none" is no longer supported. |
|||
| 15 |
- #' + `y ~ ARM`+ #' * `time_point` (`number`)\cr survival time point of interest. |
|||
| 16 |
- #' + `y ~ ARM + SEX`+ #' |
|||
| 17 |
- #' + `y ~ ARM + AGE`+ #' @name survival_timepoint |
|||
| 18 |
- #' + `y ~ ARM + RACE`+ NULL |
|||
| 19 |
- #'+ |
|||
| 20 |
- #' @export+ #' @describeIn survival_timepoint Statistics function which analyzes survival rate. |
|||
| 21 |
- univariate <- function(x) {
+ #' |
|||
| 22 | -1x | +
- structure(x, varname = deparse(substitute(x)))+ #' @return |
||
| 23 |
- }+ #' * `s_surv_timepoint()` returns the statistics: |
|||
| 24 |
-
+ #' * `pt_at_risk`: Patients remaining at risk. |
|||
| 25 |
- # Get the right-hand-term of a formula+ #' * `event_free_rate`: Event-free rate (%). |
|||
| 26 |
- rht <- function(x) {
+ #' * `rate_se`: Standard error of event free rate. |
|||
| 27 | -4x | +
- checkmate::assert_formula(x)+ #' * `rate_ci`: Confidence interval for event free rate. |
||
| 28 | -4x | +
- y <- as.character(rev(x)[[1]])+ #' |
||
| 29 | -4x | +
- return(y)+ #' @examples |
||
| 30 |
- }+ #' library(dplyr) |
|||
| 31 |
-
+ #' |
|||
| 32 |
- #' Hazard Ratio Estimation in Interactions+ #' adtte_f <- tern_ex_adtte %>% |
|||
| 33 |
- #'+ #' filter(PARAMCD == "OS") %>% |
|||
| 34 |
- #' This function estimates the hazard ratios between arms when an interaction variable is given with+ #' mutate( |
|||
| 35 |
- #' specific values.+ #' AVAL = day2month(AVAL), |
|||
| 36 |
- #'+ #' is_event = CNSR == 0 |
|||
| 37 |
- #' @param variable,given Names of two variable in interaction. We seek the estimation of the levels of `variable`+ #' ) |
|||
| 38 |
- #' given the levels of `given`.+ #' df <- adtte_f %>% |
|||
| 39 |
- #' @param lvl_var,lvl_given corresponding levels has given by `levels`.+ #' filter(ARMCD == "ARM A") |
|||
| 40 |
- #' @param mmat A name numeric filled with 0 used as template to obtain the design matrix.+ #' |
|||
| 41 |
- #' @param coef Numeric of estimated coefficients.+ #' @keywords internal |
|||
| 42 |
- #' @param vcov Variance-covariance matrix of underlying model.+ s_surv_timepoint <- function(df, |
|||
| 43 |
- #' @param conf_level Single numeric for the confidence level of estimate intervals.+ .var, |
|||
| 44 |
- #'+ time_point, |
|||
| 45 |
- #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A)+ is_event, |
|||
| 46 |
- #' and Sex (F, M; reference Female). The model is abbreviated: y ~ Arm + Sex + Arm x Sex.+ control = control_surv_timepoint()) {
|
|||
| 47 | -+ | 19x |
- #' The cox regression estimates the coefficients along with a variance-covariance matrix for:+ checkmate::assert_string(.var) |
|
| 48 | -+ | 19x |
- #'+ assert_df_with_variables(df, list(tte = .var, is_event = is_event)) |
|
| 49 | -+ | 19x |
- #' - b1 (arm b), b2 (arm c)+ checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE) |
|
| 50 | -+ | 19x |
- #' - b3 (sex m)+ checkmate::assert_number(time_point) |
|
| 51 | -+ | 19x |
- #' - b4 (arm b: sex m), b5 (arm c: sex m)+ checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE) |
|
| 52 |
- #'+ |
|||
| 53 | -+ | 19x |
- #' Given that I want an estimation of the Hazard Ratio for arm C/sex M, the estimation+ conf_type <- control$conf_type |
|
| 54 | -+ | 19x |
- #' will be given in reference to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5),+ conf_level <- control$conf_level |
|
| 55 |
- #' therefore the interaction coefficient is given by b2 + b5 while the standard error is obtained+ |
|||
| 56 | -+ | 19x |
- #' as $1.96 * sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$ for a confidence level of 0.95.+ formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
|
|
| 57 | -+ | 19x |
- #'+ srv_fit <- survival::survfit( |
|
| 58 | -+ | 19x |
- #' @return A list of matrix (one per level of variable) with rows corresponding to the combinations of+ formula = formula, |
|
| 59 | -+ | 19x |
- #' `variable` and `given`, with columns:+ data = df, |
|
| 60 | -+ | 19x |
- #' * `coef_hat`: Estimation of the coefficient.+ conf.int = conf_level, |
|
| 61 | -+ | 19x |
- #' * `coef_se`: Standard error of the estimation.+ conf.type = conf_type |
|
| 62 |
- #' * `hr`: Hazard ratio.+ ) |
|||
| 63 | -+ | 19x |
- #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio.+ s_srv_fit <- summary(srv_fit, times = time_point, extend = TRUE) |
|
| 64 | -+ | 19x |
- #'+ df_srv_fit <- as.data.frame(s_srv_fit[c("time", "n.risk", "surv", "lower", "upper", "std.err")])
|
|
| 65 | -+ | 19x |
- #' @seealso [s_cox_multivariate()].+ if (df_srv_fit[["n.risk"]] == 0) {
|
|
| 66 | -+ | 1x |
- #'+ pt_at_risk <- event_free_rate <- rate_se <- NA_real_ |
|
| 67 | -+ | 1x |
- #' @examples+ rate_ci <- c(NA_real_, NA_real_) |
|
| 68 |
- #' library(dplyr)+ } else {
|
|||
| 69 | -+ | 18x |
- #' library(survival)+ pt_at_risk <- df_srv_fit$n.risk |
|
| 70 | -+ | 18x |
- #'+ event_free_rate <- df_srv_fit$surv |
|
| 71 | -+ | 18x |
- #' ADSL <- tern_ex_adsl %>%+ rate_se <- df_srv_fit$std.err |
|
| 72 | -+ | 18x |
- #' filter(SEX %in% c("F", "M"))
+ rate_ci <- c(df_srv_fit$lower, df_srv_fit$upper) |
|
| 73 |
- #'+ } |
|||
| 74 | -+ | 19x |
- #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "PFS")+ list( |
|
| 75 | -+ | 19x |
- #' adtte$ARMCD <- droplevels(adtte$ARMCD)+ pt_at_risk = formatters::with_label(pt_at_risk, "Patients remaining at risk"), |
|
| 76 | -+ | 19x |
- #' adtte$SEX <- droplevels(adtte$SEX)+ event_free_rate = formatters::with_label(event_free_rate * 100, "Event Free Rate (%)"), |
|
| 77 | -+ | 19x |
- #'+ rate_se = formatters::with_label(rate_se * 100, "Standard Error of Event Free Rate"), |
|
| 78 | -+ | 19x |
- #' mod <- coxph(+ rate_ci = formatters::with_label(rate_ci * 100, f_conf_level(conf_level)) |
|
| 79 |
- #' formula = Surv(time = AVAL, event = 1 - CNSR) ~ (SEX + ARMCD)^2,+ ) |
|||
| 80 |
- #' data = adtte+ } |
|||
| 81 |
- #' )+ |
|||
| 82 |
- #'+ #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()` |
|||
| 83 |
- #' mmat <- stats::model.matrix(mod)[1, ]+ #' when `method = "surv"`. |
|||
| 84 |
- #' mmat[!mmat == 0] <- 0+ #' |
|||
| 85 |
- #'+ #' @return |
|||
| 86 |
- #' @keywords internal+ #' * `a_surv_timepoint()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 87 |
- estimate_coef <- function(variable, given,+ #' |
|||
| 88 |
- lvl_var, lvl_given,+ #' @keywords internal |
|||
| 89 |
- coef,+ a_surv_timepoint <- make_afun( |
|||
| 90 |
- mmat,+ s_surv_timepoint, |
|||
| 91 |
- vcov,+ .indent_mods = c( |
|||
| 92 |
- conf_level = 0.95) {
+ pt_at_risk = 0L, |
|||
| 93 | -8x | +
- var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level+ event_free_rate = 0L, |
||
| 94 | -8x | +
- giv_lvl <- paste0(given, lvl_given)+ rate_se = 1L, |
||
| 95 |
-
+ rate_ci = 1L |
|||
| 96 | -8x | +
- design_mat <- expand.grid(variable = var_lvl, given = giv_lvl)+ ), |
||
| 97 | -8x | +
- design_mat <- design_mat[order(design_mat$variable, design_mat$given), ]+ .formats = c( |
||
| 98 | -8x | +
- design_mat <- within(+ pt_at_risk = "xx", |
||
| 99 | -8x | +
- data = design_mat,+ event_free_rate = "xx.xx", |
||
| 100 | -8x | +
- expr = {
+ rate_se = "xx.xx", |
||
| 101 | -8x | +
- inter <- paste0(variable, ":", given)+ rate_ci = "(xx.xx, xx.xx)" |
||
| 102 | -8x | +
- rev_inter <- paste0(given, ":", variable)+ ) |
||
| 103 |
- }+ ) |
|||
| 104 |
- )+ |
|||
| 105 |
-
+ #' @describeIn survival_timepoint Statistics function which analyzes difference between two survival rates. |
|||
| 106 | -8x | +
- split_by_variable <- design_mat$variable+ #' |
||
| 107 | -8x | +
- interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/")+ #' @return |
||
| 108 |
-
+ #' * `s_surv_timepoint_diff()` returns the statistics: |
|||
| 109 | -8x | +
- design_mat <- apply(+ #' * `rate_diff`: Event-free rate difference between two groups. |
||
| 110 | -8x | +
- X = design_mat, MARGIN = 1, FUN = function(x) {
+ #' * `rate_diff_ci`: Confidence interval for the difference. |
||
| 111 | -27x | +
- mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1+ #' * `ztest_pval`: p-value to test the difference is 0. |
||
| 112 | -27x | +
- return(mmat)+ #' |
||
| 113 |
- }+ #' @examples |
|||
| 114 |
- )+ #' df_ref_group <- adtte_f %>% |
|||
| 115 | -8x | +
- colnames(design_mat) <- interaction_names+ #' filter(ARMCD == "ARM B") |
||
| 116 |
-
+ #' |
|||
| 117 | -8x | +
- betas <- as.matrix(coef)+ #' @keywords internal |
||
| 118 |
-
+ s_surv_timepoint_diff <- function(df, |
|||
| 119 | -8x | +
- coef_hat <- t(design_mat) %*% betas+ .var, |
||
| 120 | -8x | +
- dimnames(coef_hat)[2] <- "coef"+ .ref_group, |
||
| 121 |
-
+ .in_ref_col, |
|||
| 122 | -8x | +
- coef_se <- apply(design_mat, 2, function(x) {
+ time_point, |
||
| 123 | -27x | +
- vcov_el <- as.logical(x)+ control = control_surv_timepoint(), |
||
| 124 | -27x | +
- y <- vcov[vcov_el, vcov_el]+ ...) {
|
||
| 125 | -27x | +2x |
- y <- sum(y)+ if (.in_ref_col) {
|
|
| 126 | -27x | +! |
- y <- sqrt(y)+ return( |
|
| 127 | -27x | +! |
- return(y)+ list( |
|
| 128 | -+ | ! |
- })+ rate_diff = formatters::with_label("", "Difference in Event Free Rate"),
|
|
| 129 | -+ | ! |
-
+ rate_diff_ci = formatters::with_label("", f_conf_level(control$conf_level)),
|
|
| 130 | -8x | +! |
- q_norm <- stats::qnorm((1 + conf_level) / 2)+ ztest_pval = formatters::with_label("", "p-value (Z-test)")
|
|
| 131 | -8x | +
- y <- cbind(coef_hat, `se(coef)` = coef_se)+ ) |
||
| 132 |
-
+ ) |
|||
| 133 | -8x | +
- y <- apply(y, 1, function(x) {
+ } |
||
| 134 | -27x | +2x |
- x["hr"] <- exp(x["coef"])+ data <- rbind(.ref_group, df) |
|
| 135 | -27x | +2x |
- x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"])+ group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
|
|
| 136 | -27x | +2x |
- x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"])+ res_per_group <- lapply(split(data, group), function(x) {
|
|
| 137 | -+ | 4x |
-
+ s_surv_timepoint(df = x, .var = .var, time_point = time_point, control = control, ...) |
|
| 138 | -27x | +
- return(x)+ }) |
||
| 139 |
- })+ |
|||
| 140 | -+ | 2x |
-
+ res_x <- res_per_group[[2]] |
|
| 141 | -8x | +2x |
- y <- t(y)+ res_ref <- res_per_group[[1]] |
|
| 142 | -8x | +2x |
- y <- by(y, split_by_variable, identity)+ rate_diff <- res_x$event_free_rate - res_ref$event_free_rate |
|
| 143 | -8x | +2x |
- y <- lapply(y, as.matrix)+ se_diff <- sqrt(res_x$rate_se^2 + res_ref$rate_se^2) |
|
| 145 | -8x | +2x |
- attr(y, "details") <- paste0(+ qs <- c(-1, 1) * stats::qnorm(1 - (1 - control$conf_level) / 2) |
|
| 146 | -8x | +2x |
- "Estimations of ", variable,+ rate_diff_ci <- rate_diff + qs * se_diff |
|
| 147 | -8x | +2x |
- " hazard ratio given the level of ", given, " compared to ",+ ztest_pval <- if (is.na(rate_diff)) {
|
|
| 148 | -8x | +2x |
- variable, " level ", lvl_var[1], "."+ NA |
|
| 149 |
- )+ } else {
|
|||
| 150 | -8x | +2x |
- return(y)+ 2 * (1 - stats::pnorm(abs(rate_diff) / se_diff)) |
|
| 151 |
- }+ } |
|||
| 152 | -+ | 2x |
-
+ list( |
|
| 153 | -+ | 2x |
- #' `tryCatch` around `car::Anova`+ rate_diff = formatters::with_label(rate_diff, "Difference in Event Free Rate"), |
|
| 154 | -+ | 2x |
- #'+ rate_diff_ci = formatters::with_label(rate_diff_ci, f_conf_level(control$conf_level)), |
|
| 155 | -+ | 2x |
- #' Captures warnings when executing [car::Anova].+ ztest_pval = formatters::with_label(ztest_pval, "p-value (Z-test)") |
|
| 156 |
- #'+ ) |
|||
| 157 |
- #' @inheritParams car::Anova+ } |
|||
| 158 |
- #'+ |
|||
| 159 |
- #' @return A list with item `aov` for the result of the model and `error_text` for the captured warnings.+ #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()` |
|||
| 160 |
- #'+ #' when `method = "surv_diff"`. |
|||
| 161 |
- #' @examples+ #' |
|||
| 162 |
- #' # `car::Anova` on cox regression model including strata and expected+ #' @return |
|||
| 163 |
- #' # a likelihood ratio test triggers a warning as only `Wald` method is+ #' * `a_surv_timepoint_diff()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 164 |
- #' # accepted.+ #' |
|||
| 165 |
- #'+ #' @keywords internal |
|||
| 166 |
- #' library(survival)+ a_surv_timepoint_diff <- make_afun( |
|||
| 167 |
- #'+ s_surv_timepoint_diff, |
|||
| 168 |
- #' mod <- coxph(+ .formats = c( |
|||
| 169 |
- #' formula = Surv(time = futime, event = fustat) ~ factor(rx) + strata(ecog.ps),+ rate_diff = "xx.xx", |
|||
| 170 |
- #' data = ovarian+ rate_diff_ci = "(xx.xx, xx.xx)", |
|||
| 171 |
- #' )+ ztest_pval = "x.xxxx | (<0.0001)" |
|||
| 172 |
- #'+ ) |
|||
| 173 |
- #' @keywords internal+ ) |
|||
| 174 |
- try_car_anova <- function(mod,+ |
|||
| 175 |
- test.statistic) { # nolint
+ #' @describeIn survival_timepoint Layout-creating function which can take statistics function arguments |
|||
| 176 | -2x | +
- y <- tryCatch(+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 177 | -2x | +
- withCallingHandlers(+ #' |
||
| 178 | -2x | +
- expr = {
+ #' @param method (`string`)\cr either `surv` (survival estimations), |
||
| 179 | -2x | +
- warn_text <- c()+ #' `surv_diff` (difference in survival with the control) or `both`. |
||
| 180 | -2x | +
- list(+ #' @param table_names_suffix (`string`)\cr optional suffix for the `table_names` used for the `rtables` to |
||
| 181 | -2x | +
- aov = car::Anova(+ #' avoid warnings from duplicate table names. |
||
| 182 | -2x | +
- mod,+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 183 | -2x | +
- test.statistic = test.statistic,+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
||
| 184 | -2x | +
- type = "III"+ #' for that statistic's row label. |
||
| 185 |
- ),+ #' |
|||
| 186 | -2x | +
- warn_text = warn_text+ #' @return |
||
| 187 |
- )+ #' * `surv_timepoint()` returns a layout object suitable for passing to further layouting functions, |
|||
| 188 |
- },+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 189 | -2x | +
- warning = function(w) {
+ #' the statistics from `s_surv_timepoint()` and/or `s_surv_timepoint_diff()` to the table layout depending on |
||
| 190 |
- # If a warning is detected it is handled as "w".+ #' the value of `method`. |
|||
| 191 | -! | +
- warn_text <<- trimws(paste0("Warning in `try_car_anova`: ", w))
+ #' |
||
| 192 |
-
+ #' @examples |
|||
| 193 |
- # A warning is sometimes expected, then, we want to restart+ #' # Survival at given time points. |
|||
| 194 |
- # the execution while ignoring the warning.+ #' basic_table() %>% |
|||
| 195 | -! | +
- invokeRestart("muffleWarning")
+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
||
| 196 |
- }+ #' add_colcounts() %>% |
|||
| 197 |
- ),+ #' surv_timepoint( |
|||
| 198 | -2x | +
- finally = {
+ #' vars = "AVAL", |
||
| 199 |
- }+ #' var_labels = "Months", |
|||
| 200 |
- )+ #' is_event = "is_event", |
|||
| 201 |
-
+ #' time_point = 7 |
|||
| 202 | -2x | +
- return(y)+ #' ) %>% |
||
| 203 |
- }+ #' build_table(df = adtte_f) |
|||
| 204 |
-
+ #' |
|||
| 205 |
- #' Fit the Cox Regression Model and `Anova`+ #' # Difference in survival at given time points. |
|||
| 206 |
- #'+ #' basic_table() %>% |
|||
| 207 |
- #' The functions allows to derive from the [survival::coxph()] results the effect p.values using [car::Anova()].+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
|||
| 208 |
- #' This last package introduces more flexibility to get the effect p.values.+ #' add_colcounts() %>% |
|||
| 209 |
- #'+ #' surv_timepoint( |
|||
| 210 |
- #' @inheritParams t_coxreg+ #' vars = "AVAL", |
|||
| 211 |
- #'+ #' var_labels = "Months", |
|||
| 212 |
- #' @return A list with items `mod` (results of [survival::coxph()]), `msum` (result of `summary`) and+ #' is_event = "is_event", |
|||
| 213 |
- #' `aov` (result of [car::Anova()]).+ #' time_point = 9, |
|||
| 214 |
- #'+ #' method = "surv_diff", |
|||
| 215 |
- #' @noRd+ #' .indent_mods = c("rate_diff" = 0L, "rate_diff_ci" = 2L, "ztest_pval" = 2L)
|
|||
| 216 |
- fit_n_aov <- function(formula,+ #' ) %>% |
|||
| 217 |
- data = data,+ #' build_table(df = adtte_f) |
|||
| 218 |
- conf_level = conf_level,+ #' |
|||
| 219 |
- pval_method = c("wald", "likelihood"),
+ #' # Survival and difference in survival at given time points. |
|||
| 220 |
- ...) {
+ #' basic_table() %>% |
|||
| 221 | -1x | +
- pval_method <- match.arg(pval_method)+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
||
| 222 |
-
+ #' add_colcounts() %>% |
|||
| 223 | -1x | +
- environment(formula) <- environment()+ #' surv_timepoint( |
||
| 224 | -1x | +
- suppressWarnings({
+ #' vars = "AVAL", |
||
| 225 |
- # We expect some warnings due to coxph which fails strict programming.+ #' var_labels = "Months", |
|||
| 226 | -1x | +
- mod <- survival::coxph(formula, data = data, ...)+ #' is_event = "is_event", |
||
| 227 | -1x | +
- msum <- summary(mod, conf.int = conf_level)+ #' time_point = 9, |
||
| 228 |
- })+ #' method = "both" |
|||
| 229 |
-
+ #' ) %>% |
|||
| 230 | -1x | +
- aov <- try_car_anova(+ #' build_table(df = adtte_f) |
||
| 231 | -1x | +
- mod,+ #' |
||
| 232 | -1x | +
- test.statistic = switch(pval_method,+ #' @export |
||
| 233 | -1x | +
- "wald" = "Wald",+ surv_timepoint <- function(lyt, |
||
| 234 | -1x | +
- "likelihood" = "LR"+ vars, |
||
| 235 |
- )+ na_str = NA_character_, |
|||
| 236 |
- )+ nested = TRUE, |
|||
| 237 |
-
+ ..., |
|||
| 238 | -1x | +
- warn_attr <- aov$warn_text+ table_names_suffix = "", |
||
| 239 | -! | +
- if (!is.null(aov$warn_text)) message(warn_attr)+ var_labels = "Time", |
||
| 240 |
-
+ show_labels = "visible", |
|||
| 241 | -1x | +
- aov <- aov$aov+ method = c("surv", "surv_diff", "both"),
|
||
| 242 | -1x | +
- y <- list(mod = mod, msum = msum, aov = aov)+ .stats = c( |
||
| 243 | -1x | +
- attr(y, "message") <- warn_attr+ "pt_at_risk", "event_free_rate", "rate_ci", |
||
| 244 |
-
+ "rate_diff", "rate_diff_ci", "ztest_pval" |
|||
| 245 | -1x | +
- return(y)+ ), |
||
| 246 |
- }+ .formats = NULL, |
|||
| 247 |
-
+ .labels = NULL, |
|||
| 248 |
- # argument_checks+ .indent_mods = if (method == "both") {
|
|||
| 249 | -+ | 1x |
- check_formula <- function(formula) {
+ c(rate_diff = 1L, rate_diff_ci = 2L, ztest_pval = 2L) |
|
| 250 | -1x | +
- if (!(inherits(formula, "formula"))) {
+ } else {
|
||
| 251 | -1x | +4x |
- stop("Check `formula`. A formula should resemble `Surv(time = AVAL, event = 1 - CNSR) ~ study_arm(ARMCD)`.")
+ c(rate_diff_ci = 1L, ztest_pval = 1L) |
|
| 252 |
- }+ }) {
|
|||
| 253 | -+ | 5x |
-
+ method <- match.arg(method) |
|
| 254 | -! | +5x |
- invisible()+ checkmate::assert_string(table_names_suffix) |
|
| 255 |
- }+ |
|||
| 256 | -+ | 5x |
-
+ f <- list( |
|
| 257 | -+ | 5x |
- check_covariate_formulas <- function(covariates) {
+ surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
|
|
| 258 | -1x | +5x |
- if (!all(vapply(X = covariates, FUN = inherits, what = "formula", FUN.VALUE = TRUE)) || is.null(covariates)) {
+ surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
|
|
| 259 | -1x | +
- stop("Check `covariates`, it should be a list of right-hand-term formulas, e.g. list(Age = ~AGE).")
+ ) |
||
| 260 | -+ | 5x |
- }+ .stats <- h_split_param(.stats, .stats, f = f) |
|
| 261 | -+ | 5x |
-
+ .formats <- h_split_param(.formats, names(.formats), f = f) |
|
| 262 | -! | +5x |
- invisible()+ .labels <- h_split_param(.labels, names(.labels), f = f) |
|
| 263 | -+ | 5x |
- }+ .indent_mods <- h_split_param(.indent_mods, names(.indent_mods), f = f) |
|
| 265 | -+ | 5x |
- name_covariate_names <- function(covariates) {
+ afun_surv <- make_afun( |
|
| 266 | -1x | +5x |
- miss_names <- names(covariates) == ""+ a_surv_timepoint, |
|
| 267 | -1x | +5x |
- no_names <- is.null(names(covariates))+ .stats = .stats$surv, |
|
| 268 | -! | +5x |
- if (any(miss_names)) names(covariates)[miss_names] <- vapply(covariates[miss_names], FUN = rht, FUN.VALUE = "name")+ .formats = .formats$surv, |
|
| 269 | -! | +5x |
- if (no_names) names(covariates) <- vapply(covariates, FUN = rht, FUN.VALUE = "name")+ .labels = .labels$surv, |
|
| 270 | -1x | +5x |
- return(covariates)+ .indent_mods = .indent_mods$surv |
|
| 271 |
- }+ ) |
|||
| 273 | -+ | 5x |
- check_increments <- function(increments, covariates) {
+ afun_surv_diff <- make_afun( |
|
| 274 | -1x | +5x |
- if (!is.null(increments)) {
+ a_surv_timepoint_diff, |
|
| 275 | -1x | +5x |
- covariates <- vapply(covariates, FUN = rht, FUN.VALUE = "name")+ .stats = .stats$surv_diff, |
|
| 276 | -1x | +5x |
- lapply(+ .formats = .formats$surv_diff, |
|
| 277 | -1x | +5x |
- X = names(increments), FUN = function(x) {
+ .labels = .labels$surv_diff, |
|
| 278 | -3x | +5x |
- if (!x %in% covariates) {
+ .indent_mods = .indent_mods$surv_diff |
|
| 279 | -1x | +
- warning(+ ) |
||
| 280 | -1x | +
- paste(+ |
||
| 281 | -1x | +5x | +
+ time_point <- list(...)$time_point+ |
+ |
| 282 | ++ | + + | +||
| 283 | +5x | +
+ for (i in seq_along(time_point)) {
+ |
+ ||
| 284 | +5x | +
+ tpt <- time_point[i]+ |
+ ||
| 285 | ++ | + + | +||
| 286 | +5x | +
+ if (method %in% c("surv", "both")) {
+ |
+ ||
| 287 | +3x | +
+ lyt <- analyze(+ |
+ ||
| 288 | +3x | +
+ lyt,+ |
+ ||
| 289 | +3x | +
+ vars,+ |
+ ||
| 290 | +3x | +
+ var_labels = paste(tpt, var_labels),+ |
+ ||
| 291 | +3x | +
+ table_names = paste0("surv_", tpt, table_names_suffix),
+ |
+ ||
| 292 | +3x | +
+ show_labels = show_labels,+ |
+ ||
| 293 | +3x | +
+ afun = afun_surv,+ |
+ ||
| 294 | +3x | +
+ na_str = na_str,+ |
+ ||
| 295 | +3x | +
+ nested = nested,+ |
+ ||
| 296 | +3x | +
+ extra_args = list(+ |
+ ||
| 297 | +3x | +
+ is_event = list(...)$is_event,+ |
+ ||
| 298 | +3x | +
+ control = list(...)$control,+ |
+ ||
| 299 | +3x | +
+ time_point = tpt+ |
+ ||
| 300 | ++ |
+ )+ |
+ ||
| 301 | ++ |
+ )+ |
+ ||
| 302 | ++ |
+ }+ |
+ ||
| 303 | ++ | + + | +||
| 304 | +5x | +
+ if (method %in% c("surv_diff", "both")) {
+ |
+ ||
| 305 | +3x | +
+ lyt <- analyze(+ |
+ ||
| 306 | +3x | +
+ lyt,+ |
+ ||
| 307 | +3x | +
+ vars,+ |
+ ||
| 308 | +3x | +
+ var_labels = paste(tpt, var_labels),+ |
+ ||
| 309 | +3x | +
+ table_names = paste0("surv_diff_", tpt, table_names_suffix),
+ |
+ ||
| 310 | +3x | +
+ show_labels = ifelse(method == "both", "hidden", show_labels),+ |
+ ||
| 311 | +3x | +
+ afun = afun_surv_diff,+ |
+ ||
| 312 | +3x | +
+ na_str = na_str,+ |
+ ||
| 313 | +3x |
- "Check `increments`, the `increment` for ", x,+ nested = nested, |
||
| 282 | -1x | +314 | +3x |
- "doesn't match any names in investigated covariate(s)."+ extra_args = list( |
| 283 | -+ | |||
| 315 | +3x |
- )+ is_event = list(...)$is_event, |
||
| 284 | -+ | |||
| 316 | +3x |
- )+ control = list(...)$control, |
||
| 285 | -+ | |||
| 317 | +3x |
- }+ time_point = tpt |
||
| 286 | +318 |
- }+ ) |
||
| 287 | +319 |
- )+ ) |
||
| 288 | +320 |
- }+ } |
||
| 289 | +321 |
-
+ } |
||
| 290 | -1x | +322 | +5x |
- invisible()+ lyt |
| 291 | +323 |
} |
| 292 | +1 |
-
+ #' Helper Functions for Tabulating Survival Duration by Subgroup |
||
| 293 | +2 |
- #' Multivariate Cox Model - Summarized Results+ #' |
||
| 294 | +3 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 295 | +4 |
- #' Analyses based on multivariate Cox model are usually not performed for the Controlled Substance Reporting or+ #' |
||
| 296 | +5 |
- #' regulatory documents but serve exploratory purposes only (e.g., for publication). In practice, the model usually+ #' Helper functions that tabulate in a data frame statistics such as median survival |
||
| 297 | +6 |
- #' includes only the main effects (without interaction terms). It produces the hazard ratio estimates for each of the+ #' time and hazard ratio for population subgroups. |
||
| 298 | +7 |
- #' covariates included in the model.+ #' |
||
| 299 | +8 |
- #' The analysis follows the same principles (e.g., stratified vs. unstratified analysis and tie handling) as the+ #' @inheritParams argument_convention |
||
| 300 | +9 |
- #' usual Cox model analysis. Since there is usually no pre-specified hypothesis testing for such analysis,+ #' @inheritParams survival_coxph_pairwise |
||
| 301 | +10 |
- #' the p.values need to be interpreted with caution. (**Statistical Analysis of Clinical Trials Data with R**,+ #' @inheritParams survival_duration_subgroups |
||
| 302 | +11 |
- #' `NEST's bookdown`)+ #' @param arm (`factor`)\cr the treatment group variable. |
||
| 303 | +12 |
#' |
||
| 304 | +13 |
- #' @param formula (`formula`)\cr A formula corresponding to the investigated [survival::Surv()] survival model+ #' @details Main functionality is to prepare data for use in a layout-creating function. |
||
| 305 | +14 |
- #' including covariates.+ #' |
||
| 306 | +15 |
- #' @param data (`data.frame`)\cr A data frame which includes the variable in formula and covariates.+ #' @examples |
||
| 307 | +16 |
- #' @param conf_level (`proportion`)\cr The confidence level for the hazard ratio interval estimations. Default is 0.95.+ #' library(dplyr) |
||
| 308 | +17 |
- #' @param pval_method (`character`)\cr The method used for the estimation of p-values, should be one of+ #' library(forcats) |
||
| 309 | +18 |
- #' `"wald"` (default) or `"likelihood"`.+ #' |
||
| 310 | +19 |
- #' @param ... Optional parameters passed to [survival::coxph()]. Can include `ties`, a character string specifying the+ #' adtte <- tern_ex_adtte |
||
| 311 | +20 |
- #' method for tie handling, one of `exact` (default), `efron`, `breslow`.+ #' |
||
| 312 | +21 |
- #'+ #' # Save variable labels before data processing steps. |
||
| 313 | +22 |
- #' @return A `list` with elements `mod`, `msum`, `aov`, and `coef_inter`.+ #' adtte_labels <- formatters::var_labels(adtte) |
||
| 314 | +23 |
#' |
||
| 315 | +24 |
- #' @details The output is limited to single effect terms. Work in ongoing for estimation of interaction terms+ #' adtte_f <- adtte %>% |
||
| 316 | +25 |
- #' but is out of scope as defined by the Global Data Standards Repository+ #' filter( |
||
| 317 | +26 |
- #' (**`GDS_Standard_TLG_Specs_Tables_2.doc`**).+ #' PARAMCD == "OS", |
||
| 318 | +27 |
- #'+ #' ARM %in% c("B: Placebo", "A: Drug X"),
|
||
| 319 | +28 |
- #' @seealso [estimate_coef()].+ #' SEX %in% c("M", "F")
|
||
| 320 | +29 |
- #'+ #' ) %>% |
||
| 321 | +30 |
- #' @examples+ #' mutate( |
||
| 322 | +31 |
- #' library(dplyr)+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
||
| 323 | +32 |
- #'+ #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")), |
||
| 324 | +33 |
- #' adtte <- tern_ex_adtte+ #' SEX = droplevels(SEX), |
||
| 325 | +34 |
- #' adtte_f <- subset(adtte, PARAMCD == "OS") # _f: filtered+ #' is_event = CNSR == 0 |
||
| 326 | +35 |
- #' adtte_f <- filter(+ #' ) |
||
| 327 | +36 |
- #' adtte_f,+ #' labels <- c("ARM" = adtte_labels[["ARM"]], "SEX" = adtte_labels[["SEX"]], "is_event" = "Event Flag")
|
||
| 328 | +37 |
- #' PARAMCD == "OS" &+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
||
| 329 | +38 |
- #' SEX %in% c("F", "M") &
+ #' |
||
| 330 | +39 |
- #' RACE %in% c("ASIAN", "BLACK OR AFRICAN AMERICAN", "WHITE")
+ #' @name h_survival_duration_subgroups |
||
| 331 | +40 |
- #' )+ NULL |
||
| 332 | +41 |
- #' adtte_f$SEX <- droplevels(adtte_f$SEX)+ |
||
| 333 | +42 |
- #' adtte_f$RACE <- droplevels(adtte_f$RACE)+ #' @describeIn h_survival_duration_subgroups helper to prepare a data frame of median survival times by arm. |
||
| 334 | +43 |
#' |
||
| 335 | +44 |
- #' @keywords internal+ #' @return |
||
| 336 | +45 |
- s_cox_multivariate <- function(formula, data,+ #' * `h_survtime_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, and `median`. |
||
| 337 | +46 |
- conf_level = 0.95,+ #' |
||
| 338 | +47 |
- pval_method = c("wald", "likelihood"),
+ #' @examples |
||
| 339 | +48 |
- ...) {
- |
- ||
| 340 | -1x | -
- tf <- stats::terms(formula, specials = c("strata"))
- |
- ||
| 341 | -1x | -
- covariates <- rownames(attr(tf, "factors"))[-c(1, unlist(attr(tf, "specials")))]- |
- ||
| 342 | -1x | -
- lapply(- |
- ||
| 343 | -1x | -
- X = covariates,- |
- ||
| 344 | -1x | -
- FUN = function(x) {
- |
- ||
| 345 | -3x | -
- if (is.character(data[[x]])) {
- |
- ||
| 346 | -1x | -
- data[[x]] <<- as.factor(data[[x]])+ #' # Extract median survival time for one group. |
||
| 347 | +49 |
- }- |
- ||
| 348 | -3x | -
- invisible()+ #' h_survtime_df( |
||
| 349 | +50 |
- }+ #' tte = adtte_f$AVAL, |
||
| 350 | +51 |
- )+ #' is_event = adtte_f$is_event, |
||
| 351 | -1x | +|||
| 52 | +
- pval_method <- match.arg(pval_method)+ #' arm = adtte_f$ARM |
|||
| 352 | +53 |
-
+ #' ) |
||
| 353 | +54 |
- # Results directly exported from environment(fit_n_aov) to environment(s_function_draft)+ #' |
||
| 354 | -1x | +|||
| 55 | +
- y <- fit_n_aov(+ #' @export |
|||
| 355 | -1x | +|||
| 56 | +
- formula = formula,+ h_survtime_df <- function(tte, is_event, arm) {
|
|||
| 356 | -1x | +57 | +55x |
- data = data,+ checkmate::assert_numeric(tte) |
| 357 | -1x | +58 | +54x |
- conf_level = conf_level,+ checkmate::assert_logical(is_event, len = length(tte)) |
| 358 | -1x | -
- pval_method = pval_method,- |
- ||
| 359 | -+ | 59 | +54x |
- ...+ assert_valid_factor(arm, len = length(tte)) |
| 360 | +60 |
- )+ |
||
| 361 | -1x | +61 | +54x |
- mod <- y$mod+ df_tte <- data.frame( |
| 362 | -1x | +62 | +54x |
- aov <- y$aov+ tte = tte, |
| 363 | -1x | +63 | +54x |
- msum <- y$msum+ is_event = is_event, |
| 364 | -1x | +64 | +54x |
- list2env(as.list(y), environment())+ stringsAsFactors = FALSE |
| 365 | +65 | - - | -||
| 366 | -1x | -
- all_term_labs <- attr(mod$terms, "term.labels")- |
- ||
| 367 | -1x | -
- term_labs <- all_term_labs[which(attr(mod$terms, "order") == 1)]- |
- ||
| 368 | -1x | -
- names(term_labs) <- term_labs+ ) |
||
| 369 | +66 | |||
| 370 | -1x | +|||
| 67 | +
- coef_inter <- NULL+ # Delete NAs |
|||
| 371 | -1x | +68 | +54x |
- if (any(attr(mod$terms, "order") > 1)) {
+ non_missing_rows <- stats::complete.cases(df_tte) |
| 372 | -1x | +69 | +54x |
- for_inter <- all_term_labs[attr(mod$terms, "order") > 1]+ df_tte <- df_tte[non_missing_rows, ] |
| 373 | -1x | +70 | +54x |
- names(for_inter) <- for_inter+ arm <- arm[non_missing_rows] |
| 374 | -1x | +|||
| 71 | +
- mmat <- stats::model.matrix(mod)[1, ]+ |
|||
| 375 | -1x | +72 | +54x |
- mmat[!mmat == 0] <- 0+ lst_tte <- split(df_tte, arm) |
| 376 | -1x | +73 | +54x |
- mcoef <- stats::coef(mod)+ lst_results <- Map(function(x, arm) {
|
| 377 | -1x | -
- mvcov <- stats::vcov(mod)- |
- ||
| 378 | -+ | 74 | +108x |
-
+ if (nrow(x) > 0) {
|
| 379 | -1x | +75 | +104x |
- estimate_coef_local <- function(variable, given) {
+ s_surv <- s_surv_time(x, .var = "tte", is_event = "is_event") |
| 380 | -6x | +76 | +104x |
- estimate_coef(+ median_est <- unname(as.numeric(s_surv$median)) |
| 381 | -6x | +77 | +104x |
- variable, given,+ n_events <- sum(x$is_event) |
| 382 | -6x | +|||
| 78 | +
- coef = mcoef, mmat = mmat, vcov = mvcov, conf_level = conf_level,+ } else {
|
|||
| 383 | -6x | +79 | +4x |
- lvl_var = levels(data[[variable]]), lvl_given = levels(data[[given]])+ median_est <- NA |
| 384 | -+ | |||
| 80 | +4x |
- )+ n_events <- NA |
||
| 385 | +81 |
} |
||
| 386 | +82 | |||
| 387 | -1x | +83 | +108x |
- coef_inter <- lapply(+ data.frame( |
| 388 | -1x | +84 | +108x |
- for_inter, function(x) {
+ arm = arm, |
| 389 | -3x | +85 | +108x |
- y <- attr(mod$terms, "factor")[, x]+ n = nrow(x), |
| 390 | -3x | +86 | +108x |
- y <- names(y[y > 0])+ n_events = n_events, |
| 391 | -3x | +87 | +108x |
- Map(estimate_coef_local, variable = y, given = rev(y))+ median = median_est, |
| 392 | -+ | |||
| 88 | +108x |
- }+ stringsAsFactors = FALSE |
||
| 393 | +89 |
) |
||
| 394 | -+ | |||
| 90 | +54x |
- }+ }, lst_tte, names(lst_tte)) |
||
| 395 | +91 | |||
| 396 | -1x | -
- list(mod = mod, msum = msum, aov = aov, coef_inter = coef_inter)- |
- ||
| 397 | -- |
- }- |
-
| 1 | -+ | 92 | +54x |
- #' Encode Categorical Missing Values in a Data Frame+ df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE)) |
| 2 | -+ | |||
| 93 | +54x |
- #'+ df$arm <- factor(df$arm, levels = levels(arm)) |
||
| 3 | -+ | |||
| 94 | +54x |
- #' @description `r lifecycle::badge("stable")`
+ df |
||
| 4 | +95 |
- #'+ } |
||
| 5 | +96 |
- #' This is a helper function to encode missing entries across groups of categorical+ |
||
| 6 | +97 |
- #' variables in a data frame.+ #' @describeIn h_survival_duration_subgroups summarizes median survival times by arm and across subgroups |
||
| 7 | +98 |
- #'+ #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and |
||
| 8 | +99 |
- #' @details Missing entries are those with `NA` or empty strings and will+ #' requires elements `tte`, `is_event`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies |
||
| 9 | +100 |
- #' be replaced with a specified value. If factor variables include missing+ #' groupings for `subgroups` variables. |
||
| 10 | +101 |
- #' values, the missing value will be inserted as the last level.+ #' |
||
| 11 | +102 |
- #' Similarly, in case character or logical variables should be converted to factors+ #' @return |
||
| 12 | +103 |
- #' with the `char_as_factor` or `logical_as_factor` options, the missing values will+ #' * `h_survtime_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, `median`, `subgroup`, |
||
| 13 | +104 |
- #' be set as the last level.+ #' `var`, `var_label`, and `row_type`. |
||
| 14 | +105 |
#' |
||
| 15 | -- |
- #' @param data (`data.frame`)\cr data set.- |
- ||
| 16 | -- |
- #' @param omit_columns (`character`)\cr names of variables from `data` that should- |
- ||
| 17 | +106 |
- #' not be modified by this function.+ #' @examples |
||
| 18 | +107 |
- #' @param char_as_factor (`flag`)\cr whether to convert character variables+ #' # Extract median survival time for multiple groups. |
||
| 19 | +108 |
- #' in `data` to factors.+ #' h_survtime_subgroups_df( |
||
| 20 | +109 |
- #' @param logical_as_factor (`flag`)\cr whether to convert logical variables+ #' variables = list( |
||
| 21 | +110 |
- #' in `data` to factors.+ #' tte = "AVAL", |
||
| 22 | +111 |
- #' @param na_level (`string`)\cr used to replace all `NA` or empty+ #' is_event = "is_event", |
||
| 23 | +112 |
- #' values inside non-`omit_columns` columns.+ #' arm = "ARM", |
||
| 24 | +113 |
- #'+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 25 | +114 |
- #' @return A `data.frame` with the chosen modifications applied.+ #' ), |
||
| 26 | +115 |
- #'+ #' data = adtte_f |
||
| 27 | +116 |
- #' @seealso [sas_na()] and [explicit_na()] for other missing data helper functions.+ #' ) |
||
| 28 | +117 |
#' |
||
| 29 | +118 |
- #' @examples+ #' # Define groupings for BMRKR2 levels. |
||
| 30 | +119 |
- #' my_data <- data.frame(+ #' h_survtime_subgroups_df( |
||
| 31 | +120 |
- #' u = c(TRUE, FALSE, NA, TRUE),+ #' variables = list( |
||
| 32 | +121 |
- #' v = factor(c("A", NA, NA, NA), levels = c("Z", "A")),
+ #' tte = "AVAL", |
||
| 33 | +122 |
- #' w = c("A", "B", NA, "C"),
+ #' is_event = "is_event", |
||
| 34 | +123 |
- #' x = c("D", "E", "F", NA),
+ #' arm = "ARM", |
||
| 35 | +124 |
- #' y = c("G", "H", "I", ""),
+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 36 | +125 |
- #' z = c(1, 2, 3, 4),+ #' ), |
||
| 37 | +126 |
- #' stringsAsFactors = FALSE+ #' data = adtte_f, |
||
| 38 | +127 |
- #' )+ #' groups_lists = list( |
||
| 39 | +128 |
- #'+ #' BMRKR2 = list( |
||
| 40 | +129 |
- #' # Example 1+ #' "low" = "LOW", |
||
| 41 | +130 |
- #' # Encode missing values in all character or factor columns.+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 42 | +131 |
- #' df_explicit_na(my_data)+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 43 | +132 |
- #' # Also convert logical columns to factor columns.+ #' ) |
||
| 44 | +133 |
- #' df_explicit_na(my_data, logical_as_factor = TRUE)+ #' ) |
||
| 45 | +134 |
- #' # Encode missing values in a subset of columns.+ #' ) |
||
| 46 | +135 |
- #' df_explicit_na(my_data, omit_columns = c("x", "y"))
+ #' |
||
| 47 | +136 |
- #'+ #' @export |
||
| 48 | +137 |
- #' # Example 2+ h_survtime_subgroups_df <- function(variables, |
||
| 49 | +138 |
- #' # Here we purposefully convert all `M` values to `NA` in the `SEX` variable.+ data, |
||
| 50 | +139 |
- #' # After running `df_explicit_na` the `NA` values are encoded as `<Missing>` but they are not+ groups_lists = list(), |
||
| 51 | +140 |
- #' # included when generating `rtables`.+ label_all = "All Patients") {
|
||
| 52 | -+ | |||
| 141 | +11x |
- #' adsl <- tern_ex_adsl+ checkmate::assert_character(variables$tte) |
||
| 53 | -+ | |||
| 142 | +11x |
- #' adsl$SEX[adsl$SEX == "M"] <- NA+ checkmate::assert_character(variables$is_event) |
||
| 54 | -+ | |||
| 143 | +11x |
- #' adsl <- df_explicit_na(adsl)+ checkmate::assert_character(variables$arm) |
||
| 55 | -+ | |||
| 144 | +11x |
- #'+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
||
| 56 | +145 |
- #' # If you want the `Na` values to be displayed in the table use the `na_level` argument.+ |
||
| 57 | -+ | |||
| 146 | +11x |
- #' adsl <- tern_ex_adsl+ assert_df_with_variables(data, variables) |
||
| 58 | +147 |
- #' adsl$SEX[adsl$SEX == "M"] <- NA+ |
||
| 59 | -+ | |||
| 148 | +11x |
- #' adsl <- df_explicit_na(adsl, na_level = "Missing Values")+ checkmate::assert_string(label_all) |
||
| 60 | +149 |
- #'+ |
||
| 61 | +150 |
- #' # Example 3+ # Add All Patients. |
||
| 62 | -+ | |||
| 151 | +11x |
- #' # Numeric variables that have missing values are not altered. This means that any `NA` value in+ result_all <- h_survtime_df(data[[variables$tte]], data[[variables$is_event]], data[[variables$arm]]) |
||
| 63 | -+ | |||
| 152 | +11x |
- #' # a numeric variable will not be included in the summary statistics, nor will they be included+ result_all$subgroup <- label_all |
||
| 64 | -+ | |||
| 153 | +11x |
- #' # in the denominator value for calculating the percent values.+ result_all$var <- "ALL" |
||
| 65 | -+ | |||
| 154 | +11x |
- #' adsl <- tern_ex_adsl+ result_all$var_label <- label_all |
||
| 66 | -+ | |||
| 155 | +11x |
- #' adsl$AGE[adsl$AGE < 30] <- NA+ result_all$row_type <- "content" |
||
| 67 | +156 |
- #' adsl <- df_explicit_na(adsl)+ |
||
| 68 | +157 |
- #'+ # Add Subgroups. |
||
| 69 | -+ | |||
| 158 | +11x |
- #' @export+ if (is.null(variables$subgroups)) {
|
||
| 70 | -+ | |||
| 159 | +3x |
- df_explicit_na <- function(data,+ result_all |
||
| 71 | +160 |
- omit_columns = NULL,+ } else {
|
||
| 72 | -+ | |||
| 161 | +8x |
- char_as_factor = TRUE,+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
||
| 73 | -+ | |||
| 162 | +8x |
- logical_as_factor = FALSE,+ l_result <- lapply(l_data, function(grp) {
|
||
| 74 | -+ | |||
| 163 | +40x |
- na_level = "<Missing>") {
+ result <- h_survtime_df(grp$df[[variables$tte]], grp$df[[variables$is_event]], grp$df[[variables$arm]]) |
||
| 75 | -22x | +164 | +40x |
- checkmate::assert_character(omit_columns, null.ok = TRUE, min.len = 1, any.missing = FALSE)+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
| 76 | -21x | +165 | +40x |
- checkmate::assert_data_frame(data)+ cbind(result, result_labels) |
| 77 | -20x | +|||
| 166 | +
- checkmate::assert_flag(char_as_factor)+ }) |
|||
| 78 | -19x | +167 | +8x |
- checkmate::assert_flag(logical_as_factor)+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 79 | -19x | +168 | +8x |
- checkmate::assert_string(na_level)+ result_subgroups$row_type <- "analysis" |
| 80 | -+ | |||
| 169 | +8x |
-
+ rbind( |
||
| 81 | -17x | +170 | +8x |
- target_vars <- if (is.null(omit_columns)) {
+ result_all, |
| 82 | -15x | +171 | +8x |
- names(data)+ result_subgroups |
| 83 | +172 |
- } else {
+ ) |
||
| 84 | -2x | +|||
| 173 | +
- setdiff(names(data), omit_columns) # May have duplicates.+ } |
|||
| 85 | +174 |
- }+ } |
||
| 86 | -17x | +|||
| 175 | +
- if (length(target_vars) == 0) {
+
|
|||
| 87 | -1x | +|||
| 176 | +
- return(data)+ #' @describeIn h_survival_duration_subgroups helper to prepare a data frame with estimates of |
|||
| 88 | +177 |
- }+ #' treatment hazard ratio. |
||
| 89 | +178 |
-
+ #' |
||
| 90 | -16x | +|||
| 179 | +
- l_target_vars <- split(target_vars, target_vars)+ #' @param strata_data (`factor`, `data.frame` or `NULL`)\cr required if stratified analysis is performed. |
|||
| 91 | +180 |
-
+ #' |
||
| 92 | +181 |
- # Makes sure target_vars exist in data and names are not duplicated.+ #' @return |
||
| 93 | -16x | +|||
| 182 | +
- assert_df_with_variables(data, l_target_vars)+ #' * `h_coxph_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`, |
|||
| 94 | +183 |
-
+ #' `conf_level`, `pval` and `pval_label`. |
||
| 95 | -16x | +|||
| 184 | +
- for (x in target_vars) {
+ #' |
|||
| 96 | -304x | +|||
| 185 | +
- xi <- data[[x]]+ #' @examples |
|||
| 97 | -304x | +|||
| 186 | +
- xi_label <- obj_label(xi)+ #' # Extract hazard ratio for one group. |
|||
| 98 | +187 |
-
+ #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM) |
||
| 99 | +188 |
- # Determine whether to convert character or logical input.+ #' |
||
| 100 | -304x | +|||
| 189 | +
- do_char_conversion <- is.character(xi) && char_as_factor+ #' # Extract hazard ratio for one group with stratification factor. |
|||
| 101 | -304x | +|||
| 190 | +
- do_logical_conversion <- is.logical(xi) && logical_as_factor+ #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM, strata_data = adtte_f$STRATA1) |
|||
| 102 | +191 |
-
+ #' |
||
| 103 | +192 |
- # Pre-convert logical to character to deal correctly with replacing NA+ #' @export |
||
| 104 | +193 |
- # values below.+ h_coxph_df <- function(tte, is_event, arm, strata_data = NULL, control = control_coxph()) {
|
||
| 105 | -304x | +194 | +58x |
- if (do_logical_conversion) {
+ checkmate::assert_numeric(tte) |
| 106 | -2x | +195 | +58x |
- xi <- as.character(xi)+ checkmate::assert_logical(is_event, len = length(tte)) |
| 107 | -+ | |||
| 196 | +58x |
- }+ assert_valid_factor(arm, n.levels = 2, len = length(tte)) |
||
| 108 | +197 | |||
| 109 | -304x | +198 | +58x |
- if (is.factor(xi) || is.character(xi)) {
+ df_tte <- data.frame(tte = tte, is_event = is_event)+ |
+
| 199 | +58x | +
+ strata_vars <- NULL |
||
| 110 | +200 |
- # Handle empty strings and NA values.+ |
||
| 111 | -217x | +201 | +58x |
- xi <- explicit_na(sas_na(xi), label = na_level)+ if (!is.null(strata_data)) {
|
| 112 | -+ | |||
| 202 | +5x |
-
+ if (is.data.frame(strata_data)) {
|
||
| 113 | -+ | |||
| 203 | +4x |
- # Convert to factors if requested for the original type,+ strata_vars <- names(strata_data)+ |
+ ||
| 204 | +4x | +
+ checkmate::assert_data_frame(strata_data, nrows = nrow(df_tte))+ |
+ ||
| 205 | +4x | +
+ assert_df_with_factors(strata_data, as.list(stats::setNames(strata_vars, strata_vars))) |
||
| 114 | +206 |
- # set na_level as the last value.+ } else {
|
||
| 115 | -217x | +207 | +1x |
- if (do_char_conversion || do_logical_conversion) {
+ assert_valid_factor(strata_data, len = nrow(df_tte)) |
| 116 | -78x | +208 | +1x |
- levels_xi <- setdiff(sort(unique(xi)), na_level)+ strata_vars <- "strata_data" |
| 117 | -78x | +|||
| 209 | +
- if (na_level %in% unique(xi)) {
+ } |
|||
| 118 | -18x | +210 | +5x |
- levels_xi <- c(levels_xi, na_level)+ df_tte[strata_vars] <- strata_data |
| 119 | +211 |
- }+ } |
||
| 120 | +212 | |||
| 121 | -78x | +213 | +58x |
- xi <- factor(xi, levels = levels_xi)+ l_df <- split(df_tte, arm) |
| 122 | +214 |
- }+ + |
+ ||
| 215 | +58x | +
+ if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
|
||
| 123 | +216 |
-
+ # Hazard ratio and CI. |
||
| 124 | -217x | +217 | +54x |
- data[, x] <- formatters::with_label(xi, label = xi_label)+ result <- s_coxph_pairwise( |
| 125 | -+ | |||
| 218 | +54x |
- }+ df = l_df[[2]], |
||
| 126 | -+ | |||
| 219 | +54x |
- }+ .ref_group = l_df[[1]], |
||
| 127 | -16x | +220 | +54x |
- return(data)+ .in_ref_col = FALSE, |
| 128 | -+ | |||
| 221 | +54x |
- }+ .var = "tte", |
| 1 | -+ | |||
| 222 | +54x |
- #' Controls for Cox Regression+ is_event = "is_event", |
||
| 2 | -+ | |||
| 223 | +54x |
- #'+ strat = strata_vars, |
||
| 3 | -+ | |||
| 224 | +54x |
- #' @description `r lifecycle::badge("stable")`
+ control = control |
||
| 4 | +225 |
- #'+ ) |
||
| 5 | +226 |
- #' Sets a list of parameters for Cox regression fit. Used internally.+ |
||
| 6 | -+ | |||
| 227 | +54x |
- #'+ df <- data.frame( |
||
| 7 | +228 |
- #' @inheritParams argument_convention+ # Dummy column needed downstream to create a nested header. |
||
| 8 | -+ | |||
| 229 | +54x |
- #' @param pval_method (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`.+ arm = " ", |
||
| 9 | -+ | |||
| 230 | +54x |
- #' @param interaction (`flag`)\cr if `TRUE`, the model includes the interaction between the studied+ n_tot = unname(as.numeric(result$n_tot)), |
||
| 10 | -+ | |||
| 231 | +54x |
- #' treatment and candidate covariate. Note that for univariate models without treatment arm, and+ n_tot_events = unname(as.numeric(result$n_tot_events)), |
||
| 11 | -+ | |||
| 232 | +54x |
- #' multivariate models, no interaction can be used so that this needs to be `FALSE`.+ hr = unname(as.numeric(result$hr)), |
||
| 12 | -+ | |||
| 233 | +54x |
- #' @param ties (`string`)\cr among `exact` (equivalent to `DISCRETE` in SAS), `efron` and `breslow`,+ lcl = unname(result$hr_ci[1]), |
||
| 13 | -+ | |||
| 234 | +54x |
- #' see [survival::coxph()]. Note: there is no equivalent of SAS `EXACT` method in R.+ ucl = unname(result$hr_ci[2]), |
||
| 14 | -+ | |||
| 235 | +54x |
- #'+ conf_level = control[["conf_level"]], |
||
| 15 | -+ | |||
| 236 | +54x |
- #' @return A `list` of items with names corresponding to the arguments.+ pval = as.numeric(result$pvalue), |
||
| 16 | -+ | |||
| 237 | +54x |
- #'+ pval_label = obj_label(result$pvalue), |
||
| 17 | -+ | |||
| 238 | +54x |
- #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()].+ stringsAsFactors = FALSE |
||
| 18 | +239 |
- #'+ ) |
||
| 19 | +240 |
- #' @examples+ } else if ( |
||
| 20 | -+ | |||
| 241 | +4x |
- #' control_coxreg()+ (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) || |
||
| 21 | -+ | |||
| 242 | +4x |
- #'+ (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0) |
||
| 22 | +243 |
- #' @export+ ) {
|
||
| 23 | -+ | |||
| 244 | +4x |
- control_coxreg <- function(pval_method = c("wald", "likelihood"),
+ df_tte_complete <- df_tte[stats::complete.cases(df_tte), ] |
||
| 24 | -+ | |||
| 245 | +4x |
- ties = c("exact", "efron", "breslow"),
+ df <- data.frame( |
||
| 25 | +246 |
- conf_level = 0.95,+ # Dummy column needed downstream to create a nested header. |
||
| 26 | -+ | |||
| 247 | +4x |
- interaction = FALSE) {
+ arm = " ", |
||
| 27 | -43x | +248 | +4x |
- pval_method <- match.arg(pval_method)+ n_tot = nrow(df_tte_complete), |
| 28 | -43x | +249 | +4x |
- ties <- match.arg(ties)+ n_tot_events = sum(df_tte_complete$is_event), |
| 29 | -43x | +250 | +4x |
- checkmate::assert_flag(interaction)+ hr = NA, |
| 30 | -43x | +251 | +4x |
- assert_proportion_value(conf_level)+ lcl = NA, |
| 31 | -43x | +252 | +4x |
- list(+ ucl = NA, |
| 32 | -43x | +253 | +4x |
- pval_method = pval_method,+ conf_level = control[["conf_level"]], |
| 33 | -43x | +254 | +4x |
- ties = ties,+ pval = NA, |
| 34 | -43x | +255 | +4x |
- conf_level = conf_level,+ pval_label = NA, |
| 35 | -43x | +256 | +4x |
- interaction = interaction+ stringsAsFactors = FALSE |
| 36 | +257 |
- )+ ) |
||
| 37 | +258 |
- }+ } else {
|
||
| 38 | -+ | |||
| 259 | +! |
-
+ df <- data.frame( |
||
| 39 | +260 |
- #' Custom Tidy Methods for Cox Regression+ # Dummy column needed downstream to create a nested header. |
||
| 40 | -+ | |||
| 261 | +! |
- #'+ arm = " ", |
||
| 41 | -+ | |||
| 262 | +! |
- #' @description `r lifecycle::badge("stable")`
+ n_tot = 0L, |
||
| 42 | -+ | |||
| 263 | +! |
- #'+ n_tot_events = 0L, |
||
| 43 | -+ | |||
| 264 | +! |
- #' @inheritParams argument_convention+ hr = NA, |
||
| 44 | -+ | |||
| 265 | +! |
- #' @param x (`list`)\cr Result of the Cox regression model fitted by [fit_coxreg_univar()] (for univariate models)+ lcl = NA, |
||
| 45 | -+ | |||
| 266 | +! |
- #' or [fit_coxreg_multivar()] (for multivariate models).+ ucl = NA, |
||
| 46 | -+ | |||
| 267 | +! |
- #'+ conf_level = control[["conf_level"]], |
||
| 47 | -+ | |||
| 268 | +! |
- #' @return [tidy()] returns:+ pval = NA, |
||
| 48 | -+ | |||
| 269 | +! |
- #' * For `summary.coxph` objects, a `data.frame` with columns: `Pr(>|z|)`, `exp(coef)`, `exp(-coef)`, `lower .95`,+ pval_label = NA, |
||
| 49 | -+ | |||
| 270 | +! |
- #' `upper .95`, `level`, and `n`.+ stringsAsFactors = FALSE |
||
| 50 | +271 |
- #' * For `coxreg.univar` objects, a `data.frame` with columns: `effect`, `term`, `term_label`, `level`, `n`, `hr`,+ ) |
||
| 51 | +272 |
- #' `lcl`, `ucl`, `pval`, and `ci`.+ } |
||
| 52 | +273 |
- #' * For `coxreg.multivar` objects, a `data.frame` with columns: `term`, `pval`, `term_label`, `hr`, `lcl`, `ucl`,+ |
||
| 53 | -+ | |||
| 274 | +58x |
- #' `level`, and `ci`.+ df |
||
| 54 | +275 |
- #'+ } |
||
| 55 | +276 |
- #' @seealso [cox_regression]+ |
||
| 56 | +277 |
- #'+ #' @describeIn h_survival_duration_subgroups summarizes estimates of the treatment hazard ratio |
||
| 57 | +278 |
- #' @name tidy_coxreg+ #' across subgroups in a data frame. `variables` corresponds to the names of variables found in |
||
| 58 | +279 |
- NULL+ #' `data`, passed as a named list and requires elements `tte`, `is_event`, `arm` and |
||
| 59 | +280 |
-
+ #' optionally `subgroups` and `strat`. `groups_lists` optionally specifies |
||
| 60 | +281 |
- #' @describeIn tidy_coxreg Custom tidy method for [survival::coxph()] summary results.+ #' groupings for `subgroups` variables. |
||
| 61 | +282 |
#' |
||
| 62 | +283 |
- #' Tidy the [survival::coxph()] results into a `data.frame` to extract model results.+ #' @return |
||
| 63 | +284 |
- #'+ #' * `h_coxph_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`, |
||
| 64 | +285 |
- #' @method tidy summary.coxph+ #' `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`. |
||
| 65 | +286 |
#' |
||
| 66 | +287 |
#' @examples |
||
| 67 | +288 |
- #' library(survival)+ #' # Extract hazard ratio for multiple groups. |
||
| 68 | +289 |
- #' library(broom)+ #' h_coxph_subgroups_df( |
||
| 69 | +290 |
- #'+ #' variables = list( |
||
| 70 | +291 |
- #' set.seed(1, kind = "Mersenne-Twister")+ #' tte = "AVAL", |
||
| 71 | +292 |
- #'+ #' is_event = "is_event", |
||
| 72 | +293 |
- #' dta_bladder <- with(+ #' arm = "ARM", |
||
| 73 | +294 |
- #' data = bladder[bladder$enum < 5, ],+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 74 | +295 |
- #' data.frame(+ #' ), |
||
| 75 | +296 |
- #' time = stop,+ #' data = adtte_f |
||
| 76 | +297 |
- #' status = event,+ #' ) |
||
| 77 | +298 |
- #' armcd = as.factor(rx),+ #' |
||
| 78 | +299 |
- #' covar1 = as.factor(enum),+ #' # Define groupings of BMRKR2 levels. |
||
| 79 | +300 |
- #' covar2 = factor(+ #' h_coxph_subgroups_df( |
||
| 80 | +301 |
- #' sample(as.factor(enum)),+ #' variables = list( |
||
| 81 | +302 |
- #' levels = 1:4, labels = c("F", "F", "M", "M")
+ #' tte = "AVAL", |
||
| 82 | +303 |
- #' )+ #' is_event = "is_event", |
||
| 83 | +304 |
- #' )+ #' arm = "ARM", |
||
| 84 | +305 |
- #' )+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 85 | +306 |
- #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
+ #' ), |
||
| 86 | +307 |
- #' formatters::var_labels(dta_bladder)[names(labels)] <- labels+ #' data = adtte_f, |
||
| 87 | +308 |
- #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ #' groups_lists = list( |
||
| 88 | +309 |
- #'+ #' BMRKR2 = list( |
||
| 89 | +310 |
- #' formula <- "survival::Surv(time, status) ~ armcd + covar1"+ #' "low" = "LOW", |
||
| 90 | +311 |
- #' msum <- summary(coxph(stats::as.formula(formula), data = dta_bladder))+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 91 | +312 |
- #' tidy(msum)+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 92 | +313 |
- #'+ #' ) |
||
| 93 | +314 |
- #' @export+ #' ) |
||
| 94 | +315 |
- tidy.summary.coxph <- function(x, # nolint+ #' ) |
||
| 95 | +316 |
- ...) {
- |
- ||
| 96 | -124x | -
- checkmate::assert_class(x, "summary.coxph")- |
- ||
| 97 | -124x | -
- pval <- x$coefficients- |
- ||
| 98 | -124x | -
- confint <- x$conf.int- |
- ||
| 99 | -124x | -
- levels <- rownames(pval)+ #' |
||
| 100 | +317 | - - | -||
| 101 | -124x | -
- pval <- tibble::as_tibble(pval)- |
- ||
| 102 | -124x | -
- confint <- tibble::as_tibble(confint)+ #' # Extract hazard ratio for multiple groups with stratification factors. |
||
| 103 | +318 | - - | -||
| 104 | -124x | -
- ret <- cbind(pval[, grepl("Pr", names(pval))], confint)
- |
- ||
| 105 | -124x | -
- ret$level <- levels+ #' h_coxph_subgroups_df( |
||
| 106 | -124x | +|||
| 319 | +
- ret$n <- x[["n"]]+ #' variables = list( |
|||
| 107 | -124x | +|||
| 320 | +
- ret+ #' tte = "AVAL", |
|||
| 108 | +321 |
- }+ #' is_event = "is_event", |
||
| 109 | +322 |
-
+ #' arm = "ARM", |
||
| 110 | +323 |
- #' @describeIn tidy_coxreg Custom tidy method for a univariate Cox regression.+ #' subgroups = c("SEX", "BMRKR2"),
|
||
| 111 | +324 |
- #'+ #' strat = c("STRATA1", "STRATA2")
|
||
| 112 | +325 |
- #' Tidy up the result of a Cox regression model fitted by [fit_coxreg_univar()].+ #' ), |
||
| 113 | +326 |
- #'+ #' data = adtte_f |
||
| 114 | +327 |
- #' @method tidy coxreg.univar+ #' ) |
||
| 115 | +328 |
#' |
||
| 116 | +329 |
- #' @examples+ #' @export |
||
| 117 | +330 |
- #' ## Cox regression: arm + 1 covariate.+ h_coxph_subgroups_df <- function(variables, |
||
| 118 | +331 |
- #' mod1 <- fit_coxreg_univar(+ data, |
||
| 119 | +332 |
- #' variables = list(+ groups_lists = list(), |
||
| 120 | +333 |
- #' time = "time", event = "status", arm = "armcd",+ control = control_coxph(), |
||
| 121 | +334 |
- #' covariates = "covar1"+ label_all = "All Patients") {
|
||
| 122 | -+ | |||
| 335 | +12x |
- #' ),+ checkmate::assert_character(variables$tte) |
||
| 123 | -+ | |||
| 336 | +12x |
- #' data = dta_bladder,+ checkmate::assert_character(variables$is_event) |
||
| 124 | -+ | |||
| 337 | +12x |
- #' control = control_coxreg(conf_level = 0.91)+ checkmate::assert_character(variables$arm) |
||
| 125 | -+ | |||
| 338 | +12x |
- #' )+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
||
| 126 | -+ | |||
| 339 | +12x |
- #'+ checkmate::assert_character(variables$strat, null.ok = TRUE) |
||
| 127 | -+ | |||
| 340 | +12x |
- #' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates.+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2) |
||
| 128 | -+ | |||
| 341 | +12x |
- #' mod2 <- fit_coxreg_univar(+ assert_df_with_variables(data, variables)+ |
+ ||
| 342 | +12x | +
+ checkmate::assert_string(label_all) |
||
| 129 | +343 |
- #' variables = list(+ |
||
| 130 | +344 |
- #' time = "time", event = "status", arm = "armcd",+ # Add All Patients.+ |
+ ||
| 345 | +12x | +
+ result_all <- h_coxph_df( |
||
| 131 | -+ | |||
| 346 | +12x |
- #' covariates = c("covar1", "covar2")
+ tte = data[[variables$tte]], |
||
| 132 | -+ | |||
| 347 | +12x |
- #' ),+ is_event = data[[variables$is_event]], |
||
| 133 | -+ | |||
| 348 | +12x |
- #' data = dta_bladder,+ arm = data[[variables$arm]], |
||
| 134 | -+ | |||
| 349 | +12x |
- #' control = control_coxreg(conf_level = 0.91, interaction = TRUE)+ strata_data = if (is.null(variables$strat)) NULL else data[variables$strat], |
||
| 135 | -+ | |||
| 350 | +12x |
- #' )+ control = control |
||
| 136 | +351 |
- #'+ ) |
||
| 137 | -+ | |||
| 352 | +12x |
- #' tidy(mod1)+ result_all$subgroup <- label_all |
||
| 138 | -+ | |||
| 353 | +12x |
- #' tidy(mod2)+ result_all$var <- "ALL" |
||
| 139 | -+ | |||
| 354 | +12x |
- #'+ result_all$var_label <- label_all |
||
| 140 | -+ | |||
| 355 | +12x |
- #' @export+ result_all$row_type <- "content" |
||
| 141 | +356 |
- tidy.coxreg.univar <- function(x, # nolint+ |
||
| 142 | +357 |
- ...) {
+ # Add Subgroups. |
||
| 143 | -29x | +358 | +12x |
- checkmate::assert_class(x, "coxreg.univar")+ if (is.null(variables$subgroups)) {
|
| 144 | -29x | +359 | +3x |
- mod <- x$mod+ result_all |
| 145 | -29x | +|||
| 360 | +
- vars <- c(x$vars$arm, x$vars$covariates)+ } else {
|
|||
| 146 | -29x | +361 | +9x |
- has_arm <- "arm" %in% names(x$vars)+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
| 147 | +362 | |||
| 148 | -29x | +363 | +9x |
- result <- if (!has_arm) {
+ l_result <- lapply(l_data, function(grp) {
|
| 149 | -5x | +364 | +42x |
- Map(+ result <- h_coxph_df( |
| 150 | -5x | +365 | +42x |
- mod = mod, vars = vars,+ tte = grp$df[[variables$tte]], |
| 151 | -5x | +366 | +42x |
- f = function(mod, vars) {
+ is_event = grp$df[[variables$is_event]], |
| 152 | -6x | +367 | +42x |
- h_coxreg_multivar_extract(+ arm = grp$df[[variables$arm]], |
| 153 | -6x | +368 | +42x |
- var = vars,+ strata_data = if (is.null(variables$strat)) NULL else grp$df[variables$strat], |
| 154 | -6x | +369 | +42x |
- data = x$data,+ control = control |
| 155 | -6x | +|||
| 370 | +
- mod = mod,+ ) |
|||
| 156 | -6x | +371 | +42x |
- control = x$control+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
| 157 | -+ | |||
| 372 | +42x |
- )+ cbind(result, result_labels) |
||
| 158 | +373 |
- }+ }) |
||
| 159 | +374 |
- )- |
- ||
| 160 | -29x | -
- } else if (x$control$interaction) {
+
|
||
| 161 | -10x | +375 | +9x |
- Map(+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 162 | -10x | +376 | +9x |
- mod = mod, covar = vars,+ result_subgroups$row_type <- "analysis" |
| 163 | -10x | +|||
| 377 | +
- f = function(mod, covar) {
+
|
|||
| 164 | -22x | +378 | +9x |
- h_coxreg_extract_interaction(+ rbind( |
| 165 | -22x | +379 | +9x |
- effect = x$vars$arm, covar = covar, mod = mod, data = x$data,+ result_all, |
| 166 | -22x | +380 | +9x |
- at = x$at, control = x$control+ result_subgroups |
| 167 | +381 |
- )+ ) |
||
| 168 | +382 |
- }+ } |
||
| 169 | +383 |
- )+ } |
||
| 170 | +384 |
- } else {
+
|
||
| 171 | -14x | +|||
| 385 | +
- Map(+ #' Split Dataframe by Subgroups |
|||
| 172 | -14x | +|||
| 386 | +
- mod = mod, vars = vars,+ #' |
|||
| 173 | -14x | +|||
| 387 | +
- f = function(mod, vars) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 174 | -36x | +|||
| 388 | +
- h_coxreg_univar_extract(+ #' |
|||
| 175 | -36x | +|||
| 389 | +
- effect = x$vars$arm, covar = vars, data = x$data, mod = mod,+ #' Split a dataframe into a non-nested list of subsets. |
|||
| 176 | -36x | +|||
| 390 | +
- control = x$control+ #' |
|||
| 177 | +391 |
- )+ #' @inheritParams argument_convention |
||
| 178 | +392 |
- }+ #' @inheritParams survival_duration_subgroups |
||
| 179 | +393 |
- )+ #' @param data (`data.frame`)\cr dataset to split. |
||
| 180 | +394 |
- }+ #' @param subgroups (`character`)\cr names of factor variables from `data` used to create subsets. |
||
| 181 | -29x | +|||
| 395 | +
- result <- do.call(rbind, result)+ #' Unused levels not present in `data` are dropped. Note that the order in this vector |
|||
| 182 | +396 |
-
+ #' determines the order in the downstream table. |
||
| 183 | -29x | +|||
| 397 | +
- result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl))+ #' |
|||
| 184 | -29x | +|||
| 398 | +
- result$n <- lapply(result$n, empty_vector_if_na)+ #' @return A list with subset data (`df`) and metadata about the subset (`df_labels`). |
|||
| 185 | -29x | +|||
| 399 | +
- result$ci <- lapply(result$ci, empty_vector_if_na)+ #' |
|||
| 186 | -29x | +|||
| 400 | +
- result$hr <- lapply(result$hr, empty_vector_if_na)+ #' @details Main functionality is to prepare data for use in forest plot layouts. |
|||
| 187 | -29x | +|||
| 401 | +
- if (x$control$interaction) {
+ #' |
|||
| 188 | -10x | +|||
| 402 | +
- result$pval_inter <- lapply(result$pval_inter, empty_vector_if_na)+ #' @examples |
|||
| 189 | +403 |
- # Remove interaction p-values due to change in specifications.+ #' df <- data.frame( |
||
| 190 | -10x | +|||
| 404 | +
- result$pval[result$effect != "Treatment:"] <- NA+ #' x = c(1:5), |
|||
| 191 | +405 |
- }+ #' y = factor(c("A", "B", "A", "B", "A"), levels = c("A", "B", "C")),
|
||
| 192 | -29x | +|||
| 406 | +
- result$pval <- lapply(result$pval, empty_vector_if_na)+ #' z = factor(c("C", "C", "D", "D", "D"), levels = c("D", "C"))
|
|||
| 193 | -29x | +|||
| 407 | +
- attr(result, "conf_level") <- x$control$conf_level+ #' ) |
|||
| 194 | -29x | +|||
| 408 | +
- result+ #' formatters::var_labels(df) <- paste("label for", names(df))
|
|||
| 195 | +409 |
- }+ #' |
||
| 196 | +410 |
-
+ #' h_split_by_subgroups( |
||
| 197 | +411 |
- #' @describeIn tidy_coxreg Custom tidy method for a multivariate Cox regression.+ #' data = df, |
||
| 198 | +412 |
- #'+ #' subgroups = c("y", "z")
|
||
| 199 | +413 |
- #' Tidy up the result of a Cox regression model fitted by [fit_coxreg_multivar()].+ #' ) |
||
| 200 | +414 |
#' |
||
| 201 | +415 |
- #' @method tidy coxreg.multivar+ #' h_split_by_subgroups( |
||
| 202 | +416 |
- #'+ #' data = df, |
||
| 203 | +417 |
- #' @examples+ #' subgroups = c("y", "z"),
|
||
| 204 | +418 |
- #' multivar_model <- fit_coxreg_multivar(+ #' groups_lists = list( |
||
| 205 | +419 |
- #' variables = list(+ #' y = list("AB" = c("A", "B"), "C" = "C")
|
||
| 206 | +420 |
- #' time = "time", event = "status", arm = "armcd",+ #' ) |
||
| 207 | +421 |
- #' covariates = c("covar1", "covar2")
+ #' ) |
||
| 208 | +422 |
- #' ),+ #' |
||
| 209 | +423 |
- #' data = dta_bladder+ #' @export |
||
| 210 | +424 |
- #' )+ h_split_by_subgroups <- function(data, |
||
| 211 | +425 |
- #' broom::tidy(multivar_model)+ subgroups, |
||
| 212 | +426 |
- #'+ groups_lists = list()) {
|
||
| 213 | -+ | |||
| 427 | +46x |
- #' @export+ checkmate::assert_character(subgroups, min.len = 1, any.missing = FALSE)+ |
+ ||
| 428 | +46x | +
+ checkmate::assert_list(groups_lists, names = "named")+ |
+ ||
| 429 | +46x | +
+ checkmate::assert_subset(names(groups_lists), subgroups)+ |
+ ||
| 430 | +46x | +
+ assert_df_with_factors(data, as.list(stats::setNames(subgroups, subgroups))) |
||
| 214 | +431 |
- tidy.coxreg.multivar <- function(x, # nolint+ + |
+ ||
| 432 | +46x | +
+ data_labels <- unname(formatters::var_labels(data))+ |
+ ||
| 433 | +46x | +
+ df_subgroups <- data[, subgroups, drop = FALSE]+ |
+ ||
| 434 | +46x | +
+ subgroup_labels <- formatters::var_labels(df_subgroups, fill = TRUE) |
||
| 215 | +435 |
- ...) {
+
|
||
| 216 | -8x | +436 | +46x |
- checkmate::assert_class(x, "coxreg.multivar")+ l_labels <- Map(function(grp_i, name_i) {
|
| 217 | -8x | +437 | +81x |
- vars <- c(x$vars$arm, x$vars$covariates)+ existing_levels <- levels(droplevels(grp_i))+ |
+
| 438 | +81x | +
+ grp_levels <- if (name_i %in% names(groups_lists)) {
|
||
| 218 | +439 |
-
+ # For this variable groupings are defined. We check which groups are contained in the data.+ |
+ ||
| 440 | +11x | +
+ group_list_i <- groups_lists[[name_i]]+ |
+ ||
| 441 | +11x | +
+ group_has_levels <- vapply(group_list_i, function(lvls) any(lvls %in% existing_levels), TRUE)+ |
+ ||
| 442 | +11x | +
+ names(which(group_has_levels)) |
||
| 219 | +443 |
- # Convert the model summaries to data.+ } else {
|
||
| 220 | -8x | +444 | +70x |
- result <- Map(+ existing_levels+ |
+
| 445 | ++ |
+ } |
||
| 221 | -8x | +446 | +81x |
- vars = vars,+ df_labels <- data.frame( |
| 222 | -8x | +447 | +81x |
- f = function(vars) {
+ subgroup = grp_levels, |
| 223 | -28x | +448 | +81x |
- h_coxreg_multivar_extract(+ var = name_i, |
| 224 | -28x | +449 | +81x |
- var = vars, data = x$data,+ var_label = unname(subgroup_labels[name_i]), |
| 225 | -28x | +450 | +81x |
- mod = x$mod, control = x$control+ stringsAsFactors = FALSE # Rationale is that subgroups may not be unique. |
| 226 | +451 |
- )+ )+ |
+ ||
| 452 | +46x | +
+ }, df_subgroups, names(df_subgroups)) |
||
| 227 | +453 |
- }+ |
||
| 228 | +454 |
- )+ # Create a dataframe with one row per subgroup. |
||
| 229 | -8x | +455 | +46x |
- result <- do.call(rbind, result)+ df_labels <- do.call(rbind, args = c(l_labels, make.row.names = FALSE))+ |
+
| 456 | +46x | +
+ row_label <- paste0(df_labels$var, ".", df_labels$subgroup)+ |
+ ||
| 457 | +46x | +
+ row_split_var <- factor(row_label, levels = row_label) |
||
| 230 | +458 | |||
| 459 | ++ |
+ # Create a list of data subsets.+ |
+ ||
| 231 | -8x | +460 | +46x |
- result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl))+ lapply(split(df_labels, row_split_var), function(row_i) {
|
| 232 | -8x | +461 | +205x |
- result$ci <- lapply(result$ci, empty_vector_if_na)+ which_row <- if (row_i$var %in% names(groups_lists)) {
|
| 233 | -8x | +462 | +31x |
- result$hr <- lapply(result$hr, empty_vector_if_na)+ data[[row_i$var]] %in% groups_lists[[row_i$var]][[row_i$subgroup]]+ |
+
| 463 | ++ |
+ } else {
|
||
| 234 | -8x | +464 | +174x |
- result$pval <- lapply(result$pval, empty_vector_if_na)+ data[[row_i$var]] == row_i$subgroup+ |
+
| 465 | ++ |
+ } |
||
| 235 | -8x | +466 | +205x |
- result <- result[, names(result) != "n"]+ df <- data[which_row, ] |
| 236 | -8x | +467 | +205x |
- attr(result, "conf_level") <- x$control$conf_level+ rownames(df) <- NULL+ |
+
| 468 | +205x | +
+ formatters::var_labels(df) <- data_labels |
||
| 237 | +469 | |||
| 238 | -8x | +470 | +205x |
- result+ list( |
| 239 | -+ | |||
| 471 | +205x |
- }+ df = df,+ |
+ ||
| 472 | +205x | +
+ df_labels = data.frame(row_i, row.names = NULL) |
||
| 240 | +473 |
-
+ ) |
||
| 241 | +474 |
- #' Fits for Cox Proportional Hazards Regression+ }) |
||
| 242 | +475 |
- #'+ } |
| 243 | +1 |
- #' @description `r lifecycle::badge("stable")`
+ #' Helper Functions for Tabulating Binary Response by Subgroup |
||
| 244 | +2 |
#' |
||
| 245 | +3 |
- #' Fitting functions for univariate and multivariate Cox regression models.+ #' @description `r lifecycle::badge("stable")`
|
||
| 246 | +4 |
#' |
||
| 247 | +5 |
- #' @param variables (`list`)\cr a named list corresponds to the names of variables found in `data`, passed as a named+ #' Helper functions that tabulate in a data frame statistics such as response rate |
||
| 248 | +6 |
- #' list and corresponding to `time`, `event`, `arm`, `strata`, and `covariates` terms. If `arm` is missing from+ #' and odds ratio for population subgroups. |
||
| 249 | +7 |
- #' `variables`, then only Cox model(s) including the `covariates` will be fitted and the corresponding effect+ #' |
||
| 250 | +8 |
- #' estimates will be tabulated later.+ #' @inheritParams argument_convention |
||
| 251 | +9 |
- #' @param data (`data.frame`)\cr the dataset containing the variables to fit the models.+ #' @inheritParams response_subgroups |
||
| 252 | +10 |
- #' @param at (`list` of `numeric`)\cr when the candidate covariate is a `numeric`, use `at` to specify+ #' @param arm (`factor`)\cr the treatment group variable. |
||
| 253 | +11 |
- #' the value of the covariate at which the effect should be estimated.+ #' |
||
| 254 | +12 |
- #' @param control (`list`)\cr a list of parameters as returned by the helper function [control_coxreg()].+ #' @details Main functionality is to prepare data for use in a layout-creating function. |
||
| 255 | +13 |
#' |
||
| 256 | +14 |
- #' @seealso [h_cox_regression] for relevant helper functions, [cox_regression].+ #' @examples |
||
| 257 | +15 |
- #'+ #' library(dplyr) |
||
| 258 | +16 |
- #' @examples+ #' library(forcats) |
||
| 259 | +17 |
- #' library(survival)+ #' |
||
| 260 | +18 |
- #'+ #' adrs <- tern_ex_adrs |
||
| 261 | +19 |
- #' set.seed(1, kind = "Mersenne-Twister")+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 262 | +20 |
#' |
||
| 263 | +21 |
- #' # Testing dataset [survival::bladder].+ #' adrs_f <- adrs %>% |
||
| 264 | +22 |
- #' dta_bladder <- with(+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 265 | +23 |
- #' data = bladder[bladder$enum < 5, ],+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
|
||
| 266 | +24 |
- #' data.frame(+ #' droplevels() %>% |
||
| 267 | +25 |
- #' time = stop,+ #' mutate( |
||
| 268 | +26 |
- #' status = event,+ #' # Reorder levels of factor to make the placebo group the reference arm. |
||
| 269 | +27 |
- #' armcd = as.factor(rx),+ #' ARM = fct_relevel(ARM, "B: Placebo"), |
||
| 270 | +28 |
- #' covar1 = as.factor(enum),+ #' rsp = AVALC == "CR" |
||
| 271 | +29 |
- #' covar2 = factor(+ #' ) |
||
| 272 | +30 |
- #' sample(as.factor(enum)),+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
||
| 273 | +31 |
- #' levels = 1:4, labels = c("F", "F", "M", "M")
+ #' |
||
| 274 | +32 |
- #' )+ #' @name h_response_subgroups |
||
| 275 | +33 |
- #' )+ NULL |
||
| 276 | +34 |
- #' )+ |
||
| 277 | +35 |
- #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
+ #' @describeIn h_response_subgroups helper to prepare a data frame of binary responses by arm. |
||
| 278 | +36 |
- #' formatters::var_labels(dta_bladder)[names(labels)] <- labels+ #' |
||
| 279 | +37 |
- #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ #' @return |
||
| 280 | +38 |
- #'+ #' * `h_proportion_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, and `prop`. |
||
| 281 | +39 |
- #' plot(+ #' |
||
| 282 | +40 |
- #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder),+ #' @examples |
||
| 283 | +41 |
- #' lty = 2:4,+ #' h_proportion_df( |
||
| 284 | +42 |
- #' xlab = "Months",+ #' c(TRUE, FALSE, FALSE), |
||
| 285 | +43 |
- #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
+ #' arm = factor(c("A", "A", "B"), levels = c("A", "B"))
|
||
| 286 | +44 |
#' ) |
||
| 287 | +45 |
#' |
||
| 288 | +46 |
- #' @name fit_coxreg+ #' @export |
||
| 289 | +47 |
- NULL+ h_proportion_df <- function(rsp, arm) {
+ |
+ ||
| 48 | +59x | +
+ checkmate::assert_logical(rsp)+ |
+ ||
| 49 | +58x | +
+ assert_valid_factor(arm, len = length(rsp))+ |
+ ||
| 50 | +58x | +
+ non_missing_rsp <- !is.na(rsp)+ |
+ ||
| 51 | +58x | +
+ rsp <- rsp[non_missing_rsp]+ |
+ ||
| 52 | +58x | +
+ arm <- arm[non_missing_rsp] |
||
| 290 | +53 | |||
| 291 | -+ | |||
| 54 | +58x |
- #' @describeIn fit_coxreg Fit a series of univariate Cox regression models given the inputs.+ lst_rsp <- split(rsp, arm) |
||
| 292 | -+ | |||
| 55 | +58x |
- #'+ lst_results <- Map(function(x, arm) {
|
||
| 293 | -+ | |||
| 56 | +116x |
- #' @return+ if (length(x) > 0) {
|
||
| 294 | -+ | |||
| 57 | +114x |
- #' * `fit_coxreg_univar()` returns a `coxreg.univar` class object which is a named `list`+ s_prop <- s_proportion(df = x) |
||
| 295 | -+ | |||
| 58 | +114x |
- #' with 5 elements:+ data.frame( |
||
| 296 | -+ | |||
| 59 | +114x |
- #' * `mod`: Cox regression models fitted by [survival::coxph()].+ arm = arm, |
||
| 297 | -+ | |||
| 60 | +114x |
- #' * `data`: The original data frame input.+ n = length(x), |
||
| 298 | -+ | |||
| 61 | +114x |
- #' * `control`: The original control input.+ n_rsp = unname(s_prop$n_prop[1]), |
||
| 299 | -+ | |||
| 62 | +114x |
- #' * `vars`: The variables used in the model.+ prop = unname(s_prop$n_prop[2]), |
||
| 300 | -+ | |||
| 63 | +114x |
- #' * `at`: Value of the covariate at which the effect should be estimated.+ stringsAsFactors = FALSE |
||
| 301 | +64 |
- #'+ ) |
||
| 302 | +65 |
- #' @note When using `fit_coxreg_univar` there should be two study arms.+ } else {
|
||
| 303 | -+ | |||
| 66 | +2x |
- #'+ data.frame( |
||
| 304 | -+ | |||
| 67 | +2x |
- #' @examples+ arm = arm, |
||
| 305 | -+ | |||
| 68 | +2x |
- #' # fit_coxreg_univar+ n = 0L, |
||
| 306 | -+ | |||
| 69 | +2x |
- #'+ n_rsp = NA, |
||
| 307 | -+ | |||
| 70 | +2x |
- #' ## Cox regression: arm + 1 covariate.+ prop = NA, |
||
| 308 | -+ | |||
| 71 | +2x |
- #' mod1 <- fit_coxreg_univar(+ stringsAsFactors = FALSE |
||
| 309 | +72 |
- #' variables = list(+ ) |
||
| 310 | +73 |
- #' time = "time", event = "status", arm = "armcd",+ } |
||
| 311 | -+ | |||
| 74 | +58x |
- #' covariates = "covar1"+ }, lst_rsp, names(lst_rsp)) |
||
| 312 | +75 |
- #' ),+ |
||
| 313 | -+ | |||
| 76 | +58x |
- #' data = dta_bladder,+ df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE)) |
||
| 314 | -+ | |||
| 77 | +58x |
- #' control = control_coxreg(conf_level = 0.91)+ df$arm <- factor(df$arm, levels = levels(arm)) |
||
| 315 | -+ | |||
| 78 | +58x |
- #' )+ df |
||
| 316 | +79 |
- #'+ } |
||
| 317 | +80 |
- #' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates.+ |
||
| 318 | +81 |
- #' mod2 <- fit_coxreg_univar(+ #' @describeIn h_response_subgroups summarizes proportion of binary responses by arm and across subgroups |
||
| 319 | +82 |
- #' variables = list(+ #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and |
||
| 320 | +83 |
- #' time = "time", event = "status", arm = "armcd",+ #' requires elements `rsp`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies |
||
| 321 | +84 |
- #' covariates = c("covar1", "covar2")
+ #' groupings for `subgroups` variables. |
||
| 322 | +85 |
- #' ),+ #' |
||
| 323 | +86 |
- #' data = dta_bladder,+ #' @return |
||
| 324 | +87 |
- #' control = control_coxreg(conf_level = 0.91, interaction = TRUE)+ #' * `h_proportion_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`, |
||
| 325 | +88 |
- #' )+ #' `var`, `var_label`, and `row_type`. |
||
| 326 | +89 |
#' |
||
| 327 | +90 |
- #' ## Cox regression: arm + 1 covariate, stratified analysis.+ #' @examples |
||
| 328 | +91 |
- #' mod3 <- fit_coxreg_univar(+ #' h_proportion_subgroups_df( |
||
| 329 | +92 |
- #' variables = list(+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
||
| 330 | +93 |
- #' time = "time", event = "status", arm = "armcd", strata = "covar2",+ #' data = adrs_f |
||
| 331 | +94 |
- #' covariates = c("covar1")
+ #' ) |
||
| 332 | +95 |
- #' ),+ #' |
||
| 333 | +96 |
- #' data = dta_bladder,+ #' # Define groupings for BMRKR2 levels. |
||
| 334 | +97 |
- #' control = control_coxreg(conf_level = 0.91)+ #' h_proportion_subgroups_df( |
||
| 335 | +98 |
- #' )+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
||
| 336 | +99 |
- #'+ #' data = adrs_f, |
||
| 337 | +100 |
- #' ## Cox regression: no arm, only covariates.+ #' groups_lists = list( |
||
| 338 | +101 |
- #' mod4 <- fit_coxreg_univar(+ #' BMRKR2 = list( |
||
| 339 | +102 |
- #' variables = list(+ #' "low" = "LOW", |
||
| 340 | +103 |
- #' time = "time", event = "status",+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 341 | +104 |
- #' covariates = c("covar1", "covar2")
+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 342 | +105 |
- #' ),+ #' ) |
||
| 343 | +106 |
- #' data = dta_bladder+ #' ) |
||
| 344 | +107 |
#' ) |
||
| 345 | +108 |
#' |
||
| 346 | +109 |
#' @export |
||
| 347 | +110 |
- fit_coxreg_univar <- function(variables,+ h_proportion_subgroups_df <- function(variables, |
||
| 348 | +111 |
- data,+ data, |
||
| 349 | +112 |
- at = list(),+ groups_lists = list(), |
||
| 350 | +113 |
- control = control_coxreg()) {
+ label_all = "All Patients") {
|
||
| 351 | -34x | +114 | +13x |
- checkmate::assert_list(variables, names = "named")+ checkmate::assert_character(variables$rsp) |
| 352 | -34x | +115 | +13x |
- has_arm <- "arm" %in% names(variables)+ checkmate::assert_character(variables$arm) |
| 353 | -34x | -
- arm_name <- if (has_arm) "arm" else NULL- |
- ||
| 354 | -+ | 116 | +13x |
-
+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 355 | -34x | -
- checkmate::assert_character(variables$covariates, null.ok = TRUE)- |
- ||
| 356 | -+ | 117 | +13x |
-
+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2) |
| 357 | -34x | +118 | +13x |
assert_df_with_variables(data, variables) |
| 358 | -34x | +119 | +13x |
- assert_list_of_variables(variables[c(arm_name, "event", "time")])+ checkmate::assert_string(label_all) |
| 359 | +120 | |||
| 121 | ++ |
+ # Add All Patients.+ |
+ ||
| 360 | -34x | +122 | +13x |
- if (!is.null(variables$strata)) {
+ result_all <- h_proportion_df(data[[variables$rsp]], data[[variables$arm]]) |
| 361 | -4x | +123 | +13x |
- checkmate::assert_disjunct(control$pval_method, "likelihood")+ result_all$subgroup <- label_all |
| 362 | -+ | |||
| 124 | +13x |
- }+ result_all$var <- "ALL" |
||
| 363 | -33x | +125 | +13x |
- if (has_arm) {
+ result_all$var_label <- label_all |
| 364 | -27x | +126 | +13x |
- assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ result_all$row_type <- "content" |
| 365 | +127 |
- }+ |
||
| 366 | -32x | +|||
| 128 | +
- vars <- unlist(variables[c(arm_name, "covariates", "strata")], use.names = FALSE)+ # Add Subgroups. |
|||
| 367 | -32x | +129 | +13x |
- for (i in vars) {
+ if (is.null(variables$subgroups)) {
|
| 368 | -73x | +130 | +3x |
- if (is.factor(data[[i]])) {
+ result_all |
| 369 | -63x | +|||
| 131 | +
- attr(data[[i]], "levels") <- levels(droplevels(data[[i]]))+ } else {
|
|||
| 370 | -+ | |||
| 132 | +10x |
- }+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
||
| 371 | +133 |
- }+ |
||
| 372 | -32x | +134 | +10x |
- forms <- h_coxreg_univar_formulas(variables, interaction = control$interaction)+ l_result <- lapply(l_data, function(grp) {
|
| 373 | -32x | +135 | +42x |
- mod <- lapply(+ result <- h_proportion_df(grp$df[[variables$rsp]], grp$df[[variables$arm]]) |
| 374 | -32x | +136 | +42x |
- forms, function(x) {
+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
| 375 | -69x | -
- survival::coxph(formula = stats::as.formula(x), data = data, ties = control$ties)- |
- ||
| 376 | -+ | 137 | +42x |
- }+ cbind(result, result_labels) |
| 377 | +138 |
- )- |
- ||
| 378 | -32x | -
- structure(+ }) |
||
| 379 | -32x | +139 | +10x |
- list(+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 380 | -32x | +140 | +10x |
- mod = mod,+ result_subgroups$row_type <- "analysis" |
| 381 | -32x | +|||
| 141 | +
- data = data,+ |
|||
| 382 | -32x | +142 | +10x |
- control = control,+ rbind( |
| 383 | -32x | +143 | +10x |
- vars = variables,+ result_all, |
| 384 | -32x | +144 | +10x |
- at = at+ result_subgroups |
| 385 | +145 |
- ),- |
- ||
| 386 | -32x | -
- class = "coxreg.univar"+ ) |
||
| 387 | +146 |
- )+ } |
||
| 388 | +147 |
} |
||
| 389 | +148 | |||
| 390 | +149 |
- #' @describeIn fit_coxreg Fit a multivariate Cox regression model.+ #' @describeIn h_response_subgroups helper to prepare a data frame with estimates of |
||
| 391 | +150 |
- #'+ #' the odds ratio between a treatment and a control arm. |
||
| 392 | +151 |
- #' @return+ #' |
||
| 393 | +152 |
- #' * `fit_coxreg_multivar()` returns a `coxreg.multivar` class object which is a named list+ #' @inheritParams response_subgroups |
||
| 394 | +153 |
- #' with 4 elements:+ #' @param strata_data (`factor`, `data.frame` or `NULL`)\cr required if stratified analysis is performed. |
||
| 395 | +154 |
- #' * `mod`: Cox regression model fitted by [survival::coxph()].+ #' |
||
| 396 | +155 |
- #' * `data`: The original data frame input.+ #' @return |
||
| 397 | +156 |
- #' * `control`: The original control input.+ #' * `h_odds_ratio_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`, and |
||
| 398 | +157 |
- #' * `vars`: The variables used in the model.+ #' optionally `pval` and `pval_label`. |
||
| 399 | +158 |
#' |
||
| 400 | +159 |
#' @examples |
||
| 401 | +160 |
- #' # fit_coxreg_multivar+ #' # Unstratatified analysis. |
||
| 402 | +161 |
- #'+ #' h_odds_ratio_df( |
||
| 403 | +162 |
- #' ## Cox regression: multivariate Cox regression.+ #' c(TRUE, FALSE, FALSE, TRUE), |
||
| 404 | +163 |
- #' multivar_model <- fit_coxreg_multivar(+ #' arm = factor(c("A", "A", "B", "B"), levels = c("A", "B"))
|
||
| 405 | +164 |
- #' variables = list(+ #' ) |
||
| 406 | +165 |
- #' time = "time", event = "status", arm = "armcd",+ #' |
||
| 407 | +166 |
- #' covariates = c("covar1", "covar2")
+ #' # Include p-value. |
||
| 408 | +167 |
- #' ),+ #' h_odds_ratio_df(adrs_f$rsp, adrs_f$ARM, method = "chisq") |
||
| 409 | +168 |
- #' data = dta_bladder+ #' |
||
| 410 | +169 |
- #' )+ #' # Stratatified analysis. |
||
| 411 | +170 |
- #'+ #' h_odds_ratio_df( |
||
| 412 | +171 |
- #' # Example without treatment arm.+ #' rsp = adrs_f$rsp, |
||
| 413 | +172 |
- #' multivar_covs_model <- fit_coxreg_multivar(+ #' arm = adrs_f$ARM, |
||
| 414 | +173 |
- #' variables = list(+ #' strata_data = adrs_f[, c("STRATA1", "STRATA2")],
|
||
| 415 | +174 |
- #' time = "time", event = "status",+ #' method = "cmh" |
||
| 416 | +175 |
- #' covariates = c("covar1", "covar2")
+ #' ) |
||
| 417 | +176 |
- #' ),+ #' |
||
| 418 | +177 |
- #' data = dta_bladder+ #' @export |
||
| 419 | +178 |
- #' )+ h_odds_ratio_df <- function(rsp, arm, strata_data = NULL, conf_level = 0.95, method = NULL) {
|
||
| 420 | -+ | |||
| 179 | +64x |
- #'+ assert_valid_factor(arm, n.levels = 2, len = length(rsp)) |
||
| 421 | +180 |
- #' @export+ |
||
| 422 | -+ | |||
| 181 | +64x |
- fit_coxreg_multivar <- function(variables,+ df_rsp <- data.frame(+ |
+ ||
| 182 | +64x | +
+ rsp = rsp,+ |
+ ||
| 183 | +64x | +
+ arm = arm |
||
| 423 | +184 |
- data,+ ) |
||
| 424 | +185 |
- control = control_coxreg()) {
+
|
||
| 425 | -51x | +186 | +64x |
- checkmate::assert_list(variables, names = "named")+ if (!is.null(strata_data)) {
|
| 426 | -51x | +187 | +11x |
- has_arm <- "arm" %in% names(variables)+ strata_var <- interaction(strata_data, drop = TRUE) |
| 427 | -51x | +188 | +11x |
- arm_name <- if (has_arm) "arm" else NULL+ strata_name <- "strata" |
| 428 | +189 | |||
| 429 | -51x | +190 | +11x |
- if (!is.null(variables$covariates)) {
+ assert_valid_factor(strata_var, len = nrow(df_rsp))+ |
+
| 191 | ++ | + | ||
| 430 | -13x | +192 | +11x |
- checkmate::assert_character(variables$covariates)+ df_rsp[[strata_name]] <- strata_var |
| 431 | +193 | ++ |
+ } else {
+ |
+ |
| 194 | +53x | +
+ strata_name <- NULL+ |
+ ||
| 195 |
} |
|||
| 432 | +196 | |||
| 433 | -51x | +197 | +64x |
- checkmate::assert_false(control$interaction)+ l_df <- split(df_rsp, arm) |
| 434 | -51x | +|||
| 198 | +
- assert_df_with_variables(data, variables)+ |
|||
| 435 | -51x | +199 | +64x |
- assert_list_of_variables(variables[c(arm_name, "event", "time")])+ if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
|
| 436 | +200 |
-
+ # Odds ratio and CI. |
||
| 437 | -51x | +201 | +62x |
- if (!is.null(variables$strata)) {
+ result_odds_ratio <- s_odds_ratio( |
| 438 | -3x | +202 | +62x |
- checkmate::assert_disjunct(control$pval_method, "likelihood")+ df = l_df[[2]], |
| 439 | -+ | |||
| 203 | +62x |
- }+ .var = "rsp", |
||
| 440 | -+ | |||
| 204 | +62x |
-
+ .ref_group = l_df[[1]], |
||
| 441 | -50x | +205 | +62x |
- form <- h_coxreg_multivar_formula(variables)+ .in_ref_col = FALSE, |
| 442 | -50x | +206 | +62x |
- mod <- survival::coxph(+ .df_row = df_rsp, |
| 443 | -50x | +207 | +62x |
- formula = stats::as.formula(form),+ variables = list(arm = "arm", strata = strata_name), |
| 444 | -50x | +208 | +62x |
- data = data,+ conf_level = conf_level |
| 445 | -50x | +|||
| 209 | +
- ties = control$ties+ ) |
|||
| 446 | +210 |
- )+ |
||
| 447 | -50x | +211 | +62x |
- structure(+ df <- data.frame( |
| 448 | -50x | +|||
| 212 | +
- list(+ # Dummy column needed downstream to create a nested header. |
|||
| 449 | -50x | +213 | +62x |
- mod = mod,+ arm = " ", |
| 450 | -50x | +214 | +62x |
- data = data,+ n_tot = unname(result_odds_ratio$n_tot["n_tot"]), |
| 451 | -50x | +215 | +62x |
- control = control,+ or = unname(result_odds_ratio$or_ci["est"]), |
| 452 | -50x | +216 | +62x |
- vars = variables+ lcl = unname(result_odds_ratio$or_ci["lcl"]), |
| 453 | -+ | |||
| 217 | +62x |
- ),+ ucl = unname(result_odds_ratio$or_ci["ucl"]), |
||
| 454 | -50x | +218 | +62x |
- class = "coxreg.multivar"+ conf_level = conf_level, |
| 455 | -+ | |||
| 219 | +62x |
- )+ stringsAsFactors = FALSE |
||
| 456 | +220 |
- }+ ) |
||
| 457 | +221 | |||
| 458 | -+ | |||
| 222 | +62x |
- #' Muffled `car::Anova`+ if (!is.null(method)) {
|
||
| 459 | +223 |
- #'+ # Test for difference. |
||
| 460 | -+ | |||
| 224 | +29x |
- #' Applied on survival models, [car::Anova()] signal that the `strata` terms is dropped from the model formula when+ result_test <- s_test_proportion_diff( |
||
| 461 | -+ | |||
| 225 | +29x |
- #' present, this function deliberately muffles this message.+ df = l_df[[2]], |
||
| 462 | -+ | |||
| 226 | +29x |
- #'+ .var = "rsp", |
||
| 463 | -+ | |||
| 227 | +29x |
- #' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()].+ .ref_group = l_df[[1]], |
||
| 464 | -+ | |||
| 228 | +29x |
- #' @param test_statistic (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`.+ .in_ref_col = FALSE, |
||
| 465 | -+ | |||
| 229 | +29x |
- #'+ variables = list(strata = strata_name), |
||
| 466 | -+ | |||
| 230 | +29x |
- #' @return Returns the output of [car::Anova()], with convergence message muffled.+ method = method |
||
| 467 | +231 |
- #'+ ) |
||
| 468 | +232 |
- #' @keywords internal+ |
||
| 469 | -+ | |||
| 233 | +29x |
- muffled_car_anova <- function(mod, test_statistic) {
+ df$pval <- as.numeric(result_test$pval) |
||
| 470 | -142x | +234 | +29x |
- tryCatch(+ df$pval_label <- obj_label(result_test$pval) |
| 471 | -142x | +|||
| 235 | +
- withCallingHandlers(+ } |
|||
| 472 | -142x | +|||
| 236 | +
- expr = {
+
|
|||
| 473 | -142x | +|||
| 237 | +
- car::Anova(+ # In those cases cannot go through the model so will obtain n_tot from data. |
|||
| 474 | -142x | +|||
| 238 | +
- mod,+ } else if ( |
|||
| 475 | -142x | +239 | +2x |
- test.statistic = test_statistic,+ (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) || |
| 476 | -142x | +240 | +2x |
- type = "III"+ (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0) |
| 477 | +241 |
- )+ ) {
+ |
+ ||
| 242 | +2x | +
+ df <- data.frame( |
||
| 478 | +243 |
- },+ # Dummy column needed downstream to create a nested header. |
||
| 479 | -142x | +244 | +2x |
- message = function(m) invokeRestart("muffleMessage"),
+ arm = " ", |
| 480 | -142x | +245 | +2x |
- error = function(e) {
+ n_tot = sum(stats::complete.cases(df_rsp)), |
| 481 | -1x | +246 | +2x |
- stop(paste(+ or = NA, |
| 482 | -1x | +247 | +2x |
- "the model seems to have convergence problems, please try to change",+ lcl = NA, |
| 483 | -1x | +248 | +2x |
- "the configuration of covariates or strata variables, e.g.",+ ucl = NA, |
| 484 | -1x | -
- "- original error:", e- |
- ||
| 485 | -+ | 249 | +2x |
- ))+ conf_level = conf_level, |
| 486 | -+ | |||
| 250 | +2x |
- }+ stringsAsFactors = FALSE |
||
| 487 | +251 |
) |
||
| 488 | -+ | |||
| 252 | +2x |
- )+ if (!is.null(method)) {
|
||
| 489 | -+ | |||
| 253 | +2x |
- }+ df$pval <- NA |
| 1 | -+ | |||
| 254 | +2x |
- #' Estimation of Proportions+ df$pval_label <- NA |
||
| 2 | +255 |
- #'+ } |
||
| 3 | +256 |
- #' @description `r lifecycle::badge("stable")`
+ } else {
|
||
| 4 | -+ | |||
| 257 | +! |
- #'+ df <- data.frame( |
||
| 5 | +258 |
- #' Estimate the proportion of responders within a studied population.+ # Dummy column needed downstream to create a nested header. |
||
| 6 | -+ | |||
| 259 | +! |
- #'+ arm = " ", |
||
| 7 | -+ | |||
| 260 | +! |
- #' @inheritParams argument_convention+ n_tot = 0L, |
||
| 8 | -+ | |||
| 261 | +! |
- #'+ or = NA, |
||
| 9 | -+ | |||
| 262 | +! |
- #' @seealso [h_proportions]+ lcl = NA, |
||
| 10 | -+ | |||
| 263 | +! |
- #'+ ucl = NA, |
||
| 11 | -+ | |||
| 264 | +! |
- #' @name estimate_proportions+ conf_level = conf_level, |
||
| 12 | -+ | |||
| 265 | +! |
- NULL+ stringsAsFactors = FALSE |
||
| 13 | +266 |
-
+ ) |
||
| 14 | +267 |
- #' @describeIn estimate_proportions Statistics function estimating a+ |
||
| 15 | -+ | |||
| 268 | +! |
- #' proportion along with its confidence interval.+ if (!is.null(method)) {
|
||
| 16 | -+ | |||
| 269 | +! |
- #'+ df$pval <- NA |
||
| 17 | -+ | |||
| 270 | +! |
- #' @inheritParams prop_strat_wilson+ df$pval_label <- NA |
||
| 18 | +271 |
- #' @param df (`logical` or `data.frame`)\cr if only a logical vector is used,+ } |
||
| 19 | +272 |
- #' it indicates whether each subject is a responder or not. `TRUE` represents+ } |
||
| 20 | +273 |
- #' a successful outcome. If a `data.frame` is provided, also the `strata` variable+ |
||
| 21 | -+ | |||
| 274 | +64x |
- #' names must be provided in `variables` as a list element with the strata strings.+ df |
||
| 22 | +275 |
- #' In the case of `data.frame`, the logical vector of responses must be indicated as a+ } |
||
| 23 | +276 |
- #' variable name in `.var`.+ |
||
| 24 | +277 |
- #' @param method (`string`)\cr the method used to construct the confidence interval+ #' @describeIn h_response_subgroups summarizes estimates of the odds ratio between a treatment and a control |
||
| 25 | +278 |
- #' for proportion of successful outcomes; one of `waldcc`, `wald`, `clopper-pearson`,+ #' arm across subgroups in a data frame. `variables` corresponds to the names of variables found in |
||
| 26 | +279 |
- #' `wilson`, `wilsonc`, `strat_wilson`, `strat_wilsonc`, `agresti-coull` or `jeffreys`.+ #' `data`, passed as a named list and requires elements `rsp`, `arm` and optionally `subgroups` |
||
| 27 | +280 |
- #' @param long (`flag`)\cr a long description is required.+ #' and `strat`. `groups_lists` optionally specifies groupings for `subgroups` variables. |
||
| 28 | +281 |
#' |
||
| 29 | +282 |
#' @return |
||
| 30 | +283 |
- #' * `s_proportion()` returns statistics `n_prop` (`n` and proportion) and `prop_ci` (proportion CI) for a+ #' * `h_odds_ratio_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, |
||
| 31 | +284 |
- #' given variable.+ #' `conf_level`, `subgroup`, `var`, `var_label`, and `row_type`. |
||
| 32 | +285 |
#' |
||
| 33 | +286 |
#' @examples |
||
| 34 | +287 |
- #' # Case with only logical vector.+ #' # Unstratified analysis. |
||
| 35 | +288 |
- #' rsp_v <- c(1, 0, 1, 0, 1, 1, 0, 0)+ #' h_odds_ratio_subgroups_df( |
||
| 36 | +289 |
- #' s_proportion(rsp_v)+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
||
| 37 | +290 |
- #'+ #' data = adrs_f |
||
| 38 | +291 |
- #' # Example for Stratified Wilson CI+ #' ) |
||
| 39 | +292 |
- #' nex <- 100 # Number of example rows+ #' |
||
| 40 | +293 |
- #' dta <- data.frame(+ #' # Stratified analysis. |
||
| 41 | +294 |
- #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE),+ #' h_odds_ratio_subgroups_df( |
||
| 42 | +295 |
- #' "grp" = sample(c("A", "B"), nex, TRUE),
+ #' variables = list( |
||
| 43 | +296 |
- #' "f1" = sample(c("a1", "a2"), nex, TRUE),
+ #' rsp = "rsp", |
||
| 44 | +297 |
- #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
+ #' arm = "ARM", |
||
| 45 | +298 |
- #' stringsAsFactors = TRUE+ #' subgroups = c("SEX", "BMRKR2"),
|
||
| 46 | +299 |
- #' )+ #' strat = c("STRATA1", "STRATA2")
|
||
| 47 | +300 |
- #'+ #' ), |
||
| 48 | +301 |
- #' s_proportion(+ #' data = adrs_f |
||
| 49 | +302 |
- #' df = dta,+ #' ) |
||
| 50 | +303 |
- #' .var = "rsp",+ #' |
||
| 51 | +304 |
- #' variables = list(strata = c("f1", "f2")),
+ #' # Define groupings of BMRKR2 levels. |
||
| 52 | +305 |
- #' conf_level = 0.90,+ #' h_odds_ratio_subgroups_df( |
||
| 53 | +306 |
- #' method = "strat_wilson"+ #' variables = list( |
||
| 54 | +307 |
- #' )+ #' rsp = "rsp", |
||
| 55 | +308 |
- #'+ #' arm = "ARM", |
||
| 56 | +309 |
- #' @export+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 57 | +310 |
- s_proportion <- function(df,+ #' ), |
||
| 58 | +311 |
- .var,+ #' data = adrs_f, |
||
| 59 | +312 |
- conf_level = 0.95,+ #' groups_lists = list( |
||
| 60 | +313 |
- method = c(+ #' BMRKR2 = list( |
||
| 61 | +314 |
- "waldcc", "wald", "clopper-pearson",+ #' "low" = "LOW", |
||
| 62 | +315 |
- "wilson", "wilsonc", "strat_wilson", "strat_wilsonc",+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 63 | +316 |
- "agresti-coull", "jeffreys"+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 64 | +317 |
- ),+ #' ) |
||
| 65 | +318 |
- weights = NULL,+ #' ) |
||
| 66 | +319 |
- max_iterations = 50,+ #' ) |
||
| 67 | +320 |
- variables = list(strata = NULL),+ #' |
||
| 68 | +321 |
- long = FALSE) {
- |
- ||
| 69 | -125x | -
- method <- match.arg(method)- |
- ||
| 70 | -125x | -
- checkmate::assert_flag(long)- |
- ||
| 71 | -125x | -
- assert_proportion_value(conf_level)+ #' @export |
||
| 72 | +322 | - - | -||
| 73 | -125x | -
- if (!is.null(variables$strata)) {
+ h_odds_ratio_subgroups_df <- function(variables, |
||
| 74 | +323 |
- # Checks for strata- |
- ||
| 75 | -! | -
- if (missing(df)) stop("When doing stratified analysis a data.frame with specific columns is needed.")
- |
- ||
| 76 | -! | -
- strata_colnames <- variables$strata- |
- ||
| 77 | -! | -
- checkmate::assert_character(strata_colnames, null.ok = FALSE)- |
- ||
| 78 | -! | -
- strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)- |
- ||
| 79 | -! | -
- assert_df_with_variables(df, strata_vars)+ data, |
||
| 80 | +324 | - - | -||
| 81 | -! | -
- strata <- interaction(df[strata_colnames])- |
- ||
| 82 | -! | -
- strata <- as.factor(strata)+ groups_lists = list(), |
||
| 83 | +325 |
-
+ conf_level = 0.95, |
||
| 84 | +326 |
- # Pushing down checks to prop_strat_wilson- |
- ||
| 85 | -125x | -
- } else if (checkmate::test_subset(method, c("strat_wilson", "strat_wilsonc"))) {
- |
- ||
| 86 | -! | -
- stop("To use stratified methods you need to specify the strata variables.")
+ method = NULL, |
||
| 87 | +327 |
- }+ label_all = "All Patients") {
|
||
| 88 | -125x | +328 | +14x |
- if (checkmate::test_atomic_vector(df)) {
+ checkmate::assert_character(variables$rsp) |
| 89 | -125x | -
- rsp <- as.logical(df)- |
- ||
| 90 | -- |
- } else {
- |
- ||
| 91 | -! | -
- rsp <- as.logical(df[[.var]])- |
- ||
| 92 | -+ | 329 | +14x |
- }+ checkmate::assert_character(variables$arm) |
| 93 | -125x | +330 | +14x |
- n <- sum(rsp)+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 94 | -125x | -
- p_hat <- mean(rsp)- |
- ||
| 95 | -+ | 331 | +14x |
-
+ checkmate::assert_character(variables$strat, null.ok = TRUE) |
| 96 | -125x | +332 | +14x |
- prop_ci <- switch(method,+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2) |
| 97 | -125x | +333 | +14x |
- "clopper-pearson" = prop_clopper_pearson(rsp, conf_level),+ assert_df_with_variables(data, variables) |
| 98 | -125x | +334 | +14x |
- "wilson" = prop_wilson(rsp, conf_level),+ checkmate::assert_string(label_all) |
| 99 | -125x | +|||
| 335 | +
- "wilsonc" = prop_wilson(rsp, conf_level, correct = TRUE),+ |
|||
| 100 | -125x | +336 | +14x |
- "strat_wilson" = prop_strat_wilson(rsp,+ strata_data <- if (is.null(variables$strat)) {
|
| 101 | -125x | +337 | +12x |
- strata,+ NULL |
| 102 | -125x | +|||
| 338 | +
- weights,+ } else {
|
|||
| 103 | -125x | +339 | +2x |
- conf_level,+ data[, variables$strat, drop = FALSE] |
| 104 | -125x | +|||
| 340 | +
- max_iterations,+ } |
|||
| 105 | -125x | +|||
| 341 | +
- correct = FALSE+ |
|||
| 106 | -125x | +|||
| 342 | +
- )$conf_int,+ # Add All Patients. |
|||
| 107 | -125x | +343 | +14x |
- "strat_wilsonc" = prop_strat_wilson(rsp,+ result_all <- h_odds_ratio_df( |
| 108 | -125x | +344 | +14x |
- strata,+ rsp = data[[variables$rsp]], |
| 109 | -125x | +345 | +14x |
- weights,+ arm = data[[variables$arm]], |
| 110 | -125x | +346 | +14x |
- conf_level,+ strata_data = strata_data, |
| 111 | -125x | +347 | +14x |
- max_iterations,+ conf_level = conf_level, |
| 112 | -125x | +348 | +14x |
- correct = TRUE+ method = method |
| 113 | -125x | +|||
| 349 | +
- )$conf_int,+ ) |
|||
| 114 | -125x | +350 | +14x |
- "wald" = prop_wald(rsp, conf_level),+ result_all$subgroup <- label_all |
| 115 | -125x | +351 | +14x |
- "waldcc" = prop_wald(rsp, conf_level, correct = TRUE),+ result_all$var <- "ALL" |
| 116 | -125x | +352 | +14x |
- "agresti-coull" = prop_agresti_coull(rsp, conf_level),+ result_all$var_label <- label_all |
| 117 | -125x | -
- "jeffreys" = prop_jeffreys(rsp, conf_level)- |
- ||
| 118 | -+ | 353 | +14x |
- )+ result_all$row_type <- "content" |
| 119 | +354 | |||
| 120 | -125x | -
- list(- |
- ||
| 121 | -125x | -
- "n_prop" = formatters::with_label(c(n, p_hat), "Responders"),- |
- ||
| 122 | -125x | +355 | +14x |
- "prop_ci" = formatters::with_label(+ if (is.null(variables$subgroups)) {
|
| 123 | -125x | -
- x = 100 * prop_ci, label = d_proportion(conf_level, method, long = long)- |
- ||
| 124 | -+ | 356 | +3x |
- )+ result_all |
| 125 | +357 |
- )+ } else {
|
||
| 126 | -+ | |||
| 358 | +11x |
- }+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
||
| 127 | +359 | |||
| 128 | -+ | |||
| 360 | +11x |
- #' @describeIn estimate_proportions Formatted analysis function which is used as `afun`+ l_result <- lapply(l_data, function(grp) {
|
||
| 129 | -+ | |||
| 361 | +46x |
- #' in `estimate_proportion()`.+ grp_strata_data <- if (is.null(variables$strat)) {
|
||
| 130 | -+ | |||
| 362 | +38x |
- #'+ NULL |
||
| 131 | +363 |
- #' @return+ } else {
|
||
| 132 | -+ | |||
| 364 | +8x |
- #' * `a_proportion()` returns the corresponding list with formatted [rtables::CellValue()].+ grp$df[, variables$strat, drop = FALSE] |
||
| 133 | +365 |
- #'+ } |
||
| 134 | +366 |
- #' @export+ |
||
| 135 | -+ | |||
| 367 | +46x |
- a_proportion <- make_afun(+ result <- h_odds_ratio_df( |
||
| 136 | -+ | |||
| 368 | +46x |
- s_proportion,+ rsp = grp$df[[variables$rsp]], |
||
| 137 | -+ | |||
| 369 | +46x |
- .formats = c(n_prop = "xx (xx.x%)", prop_ci = "(xx.x, xx.x)")+ arm = grp$df[[variables$arm]], |
||
| 138 | -+ | |||
| 370 | +46x |
- )+ strata_data = grp_strata_data, |
||
| 139 | -+ | |||
| 371 | +46x |
-
+ conf_level = conf_level, |
||
| 140 | -+ | |||
| 372 | +46x |
- #' @describeIn estimate_proportions Layout-creating function which can take statistics function arguments+ method = method |
||
| 141 | +373 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ ) |
||
| 142 | -+ | |||
| 374 | +46x |
- #'+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
||
| 143 | -+ | |||
| 375 | +46x |
- #' @param ... other arguments are ultimately conveyed to [s_proportion()].+ cbind(result, result_labels) |
||
| 144 | +376 |
- #'+ }) |
||
| 145 | +377 |
- #' @return+ |
||
| 146 | -+ | |||
| 378 | +11x |
- #' * `estimate_proportion()` returns a layout object suitable for passing to further layouting functions,+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
||
| 147 | -+ | |||
| 379 | +11x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ result_subgroups$row_type <- "analysis" |
||
| 148 | +380 |
- #' the statistics from `s_proportion()` to the table layout.+ |
||
| 149 | -+ | |||
| 381 | +11x |
- #'+ rbind( |
||
| 150 | -+ | |||
| 382 | +11x |
- #' @examples+ result_all, |
||
| 151 | -+ | |||
| 383 | +11x |
- #' dta_test <- data.frame(+ result_subgroups |
||
| 152 | +384 |
- #' USUBJID = paste0("S", 1:12),
+ ) |
||
| 153 | +385 |
- #' ARM = rep(LETTERS[1:3], each = 4),+ } |
||
| 154 | +386 |
- #' AVAL = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0))+ } |
| 155 | +1 |
- #' )+ #' Control Function for Descriptive Statistics |
||
| 156 | +2 |
#' |
||
| 157 | +3 |
- #' basic_table() %>%+ #' @description `r lifecycle::badge("stable")`
|
||
| 158 | +4 |
- #' split_cols_by("ARM") %>%
+ #' |
||
| 159 | +5 |
- #' estimate_proportion(vars = "AVAL") %>%+ #' Sets a list of parameters for summaries of descriptive statistics. Typically used internally to specify |
||
| 160 | +6 |
- #' build_table(df = dta_test)+ #' details for [s_summary()]. This function family is mainly used by [analyze_vars()]. |
||
| 161 | +7 |
#' |
||
| 162 | -- |
- #' @export- |
- ||
| 163 | +8 |
- estimate_proportion <- function(lyt,+ #' @inheritParams argument_convention |
||
| 164 | +9 |
- vars,+ #' @param quantiles (`numeric`)\cr of length two to specify the quantiles to calculate. |
||
| 165 | +10 |
- nested = TRUE,+ #' @param quantile_type (`numeric`)\cr between 1 and 9 selecting quantile algorithms to be used. |
||
| 166 | +11 |
- ...,+ #' Default is set to 2 as this matches the default quantile algorithm in SAS `proc univariate` set by `QNTLDEF=5`. |
||
| 167 | +12 |
- show_labels = "hidden",+ #' This differs from R's default. See more about `type` in [stats::quantile()]. |
||
| 168 | +13 |
- table_names = vars,+ #' @param test_mean (`numeric`)\cr to test against the mean under the null hypothesis when calculating p-value. |
||
| 169 | +14 |
- .stats = NULL,+ #' |
||
| 170 | +15 |
- .formats = NULL,+ #' @note Deprecation cycle started for `control_summarize_vars` as it is going to renamed into |
||
| 171 | +16 |
- .labels = NULL,+ #' `control_analyze_vars`. Intention is to reflect better the core underlying `rtables` |
||
| 172 | +17 |
- .indent_mods = NULL) {
- |
- ||
| 173 | -3x | +|||
| 18 | +
- afun <- make_afun(+ #' |
|||
| 174 | -3x | +|||
| 19 | +
- a_proportion,+ #' @return A list of components with the same names as the arguments. |
|||
| 175 | -3x | +|||
| 20 | +
- .stats = .stats,+ #' |
|||
| 176 | -3x | +|||
| 21 | +
- .formats = .formats,+ #' @export control_analyze_vars control_summarize_vars |
|||
| 177 | -3x | +|||
| 22 | +
- .labels = .labels,+ #' @aliases control_summarize_vars |
|||
| 178 | -3x | +|||
| 23 | +
- .indent_mods = .indent_mods+ control_analyze_vars <- function(conf_level = 0.95, |
|||
| 179 | +24 |
- )+ quantiles = c(0.25, 0.75), |
||
| 180 | -3x | +|||
| 25 | +
- analyze(+ quantile_type = 2, |
|||
| 181 | -3x | +|||
| 26 | +
- lyt,+ test_mean = 0) {
|
|||
| 182 | -3x | +27 | +267x |
- vars,+ checkmate::assert_vector(quantiles, len = 2) |
| 183 | -3x | +28 | +267x |
- afun = afun,+ checkmate::assert_int(quantile_type, lower = 1, upper = 9) |
| 184 | -3x | +29 | +267x |
- nested = nested,+ checkmate::assert_numeric(test_mean) |
| 185 | -3x | +30 | +267x |
- extra_args = list(...),+ lapply(quantiles, assert_proportion_value) |
| 186 | -3x | +31 | +266x |
- show_labels = show_labels,+ assert_proportion_value(conf_level) |
| 187 | -3x | +32 | +265x |
- table_names = table_names+ list(conf_level = conf_level, quantiles = quantiles, quantile_type = quantile_type, test_mean = test_mean) |
| 188 | +33 |
- )+ } |
||
| 189 | +34 |
- }+ |
||
| 190 | +35 |
-
+ control_summarize_vars <- control_analyze_vars |
||
| 191 | +36 |
- #' Helper Functions for Calculating Proportion Confidence Intervals+ |
||
| 192 | +37 |
- #'+ |
||
| 193 | +38 |
- #' @description `r lifecycle::badge("stable")`
+ #' Analyze Variables |
||
| 194 | +39 |
#' |
||
| 195 | +40 |
- #' Functions to calculate different proportion confidence intervals for use in [estimate_proportion()].+ #' @description `r lifecycle::badge("stable")`
|
||
| 196 | +41 |
#' |
||
| 197 | +42 |
- #' @inheritParams argument_convention+ #' We use the S3 generic function [s_summary()] to implement summaries for different `x` objects. This |
||
| 198 | +43 |
- #' @inheritParams estimate_proportions+ #' is used as a statistics function in combination with the analyze function [analyze_vars()]. |
||
| 199 | +44 |
- #'+ #' Deprecation cycle started for `summarize_vars` as it is going to renamed into |
||
| 200 | +45 |
- #' @return Confidence interval of a proportion.+ #' `analyze_vars`. Intention is to reflect better the core underlying `rtables` |
||
| 201 | +46 |
- #'+ #' functions; in this case [rtables::analyze()]. |
||
| 202 | +47 |
- #' @seealso [estimate_proportions], descriptive function [d_proportion()],+ #' |
||
| 203 | +48 |
- #' and helper functions [strata_normal_quantile()] and [update_weights_strat_wilson()].+ #' @inheritParams argument_convention |
||
| 204 | +49 |
#' |
||
| 205 | +50 |
- #' @name h_proportions+ #' @name analyze_variables |
||
| 206 | +51 |
NULL |
||
| 207 | +52 | |||
| 208 | +53 |
- #' @describeIn h_proportions Calculates the Wilson interval by calling [stats::prop.test()].+ #' @describeIn analyze_variables S3 generic function to produces a variable summary. |
||
| 209 | +54 |
- #' Also referred to as Wilson score interval.+ #' |
||
| 210 | +55 |
- #'+ #' @return |
||
| 211 | +56 |
- #' @examples+ #' * `s_summary()` returns different statistics depending on the class of `x`. |
||
| 212 | +57 |
- #' rsp <- c(+ #' |
||
| 213 | +58 |
- #' TRUE, TRUE, TRUE, TRUE, TRUE,+ #' @export |
||
| 214 | +59 |
- #' FALSE, FALSE, FALSE, FALSE, FALSE+ s_summary <- function(x, |
||
| 215 | +60 |
- #' )+ na.rm = TRUE, # nolint |
||
| 216 | +61 |
- #' prop_wilson(rsp, conf_level = 0.9)+ denom, |
||
| 217 | +62 |
- #'+ .N_row, # nolint |
||
| 218 | +63 |
- #' @export+ .N_col, # nolint |
||
| 219 | +64 |
- prop_wilson <- function(rsp, conf_level, correct = FALSE) {
+ .var, |
||
| 220 | -5x | +|||
| 65 | +
- y <- stats::prop.test(+ ...) {
|
|||
| 221 | -5x | +66 | +663x |
- sum(rsp),+ checkmate::assert_flag(na.rm) |
| 222 | -5x | +67 | +663x |
- length(rsp),+ UseMethod("s_summary", x)
|
| 223 | -5x | +|||
| 68 | +
- correct = correct,+ } |
|||
| 224 | -5x | +|||
| 69 | +
- conf.level = conf_level+ |
|||
| 225 | +70 |
- )+ #' @describeIn analyze_variables Method for `numeric` class. |
||
| 226 | +71 |
-
+ #' |
||
| 227 | -5x | +|||
| 72 | +
- as.numeric(y$conf.int)+ #' @param control (`list`)\cr parameters for descriptive statistics details, specified by using |
|||
| 228 | +73 |
- }+ #' the helper function [control_analyze_vars()]. Some possible parameter options are: |
||
| 229 | +74 |
-
+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for mean and median. |
||
| 230 | +75 |
- #' @describeIn h_proportions Calculates the stratified Wilson confidence+ #' * `quantiles` (`numeric`)\cr vector of length two to specify the quantiles. |
||
| 231 | +76 |
- #' interval for unequal proportions as described in \insertCite{Yan2010-jt;textual}{tern}
+ #' * `quantile_type` (`numeric`)\cr between 1 and 9 selecting quantile algorithms to be used. |
||
| 232 | +77 |
- #'+ #' See more about `type` in [stats::quantile()]. |
||
| 233 | +78 |
- #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ #' * `test_mean` (`numeric`)\cr value to test against the mean under the null hypothesis when calculating p-value. |
||
| 234 | +79 |
- #' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are+ #' |
||
| 235 | +80 |
- #' estimated using the iterative algorithm proposed in \insertCite{Yan2010-jt;textual}{tern} that
+ #' @return |
||
| 236 | +81 |
- #' minimizes the weighted squared length of the confidence interval.+ #' * If `x` is of class `numeric`, returns a `list` with the following named `numeric` items: |
||
| 237 | +82 |
- #' @param max_iterations (`count`)\cr maximum number of iterations for the iterative procedure used+ #' * `n`: The [length()] of `x`. |
||
| 238 | +83 |
- #' to find estimates of optimal weights.+ #' * `sum`: The [sum()] of `x`. |
||
| 239 | +84 |
- #' @param correct (`flag`)\cr include the continuity correction. For further information, see for example+ #' * `mean`: The [mean()] of `x`. |
||
| 240 | +85 |
- #' [stats::prop.test()].+ #' * `sd`: The [stats::sd()] of `x`. |
||
| 241 | +86 |
- #'+ #' * `se`: The standard error of `x` mean, i.e.: (`sd(x) / sqrt(length(x))`). |
||
| 242 | +87 |
- #' @references+ #' * `mean_sd`: The [mean()] and [stats::sd()] of `x`. |
||
| 243 | +88 |
- #' \insertRef{Yan2010-jt}{tern}
+ #' * `mean_se`: The [mean()] of `x` and its standard error (see above). |
||
| 244 | +89 |
- #'+ #' * `mean_ci`: The CI for the mean of `x` (from [stat_mean_ci()]). |
||
| 245 | +90 |
- #' @examples+ #' * `mean_sei`: The SE interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()] / [sqrt()]). |
||
| 246 | +91 |
- #' # Stratified Wilson confidence interval with unequal probabilities+ #' * `mean_sdi`: The SD interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()]). |
||
| 247 | +92 |
- #'+ #' * `mean_pval`: The two-sided p-value of the mean of `x` (from [stat_mean_pval()]). |
||
| 248 | +93 |
- #' set.seed(1)+ #' * `median`: The [stats::median()] of `x`. |
||
| 249 | +94 |
- #' rsp <- sample(c(TRUE, FALSE), 100, TRUE)+ #' * `mad`: The median absolute deviation of `x`, i.e.: ([stats::median()] of `xc`, |
||
| 250 | +95 |
- #' strata_data <- data.frame(+ #' where `xc` = `x` - [stats::median()]). |
||
| 251 | +96 |
- #' "f1" = sample(c("a", "b"), 100, TRUE),
+ #' * `median_ci`: The CI for the median of `x` (from [stat_median_ci()]). |
||
| 252 | +97 |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ #' * `quantiles`: Two sample quantiles of `x` (from [stats::quantile()]). |
||
| 253 | +98 |
- #' stringsAsFactors = TRUE+ #' * `iqr`: The [stats::IQR()] of `x`. |
||
| 254 | +99 |
- #' )+ #' * `range`: The [range_noinf()] of `x`. |
||
| 255 | +100 |
- #' strata <- interaction(strata_data)+ #' * `min`: The [max()] of `x`. |
||
| 256 | +101 |
- #' n_strata <- ncol(table(rsp, strata)) # Number of strata+ #' * `max`: The [min()] of `x`. |
||
| 257 | +102 |
- #'+ #' * `median_range`: The [median()] and [range_noinf()] of `x`. |
||
| 258 | +103 |
- #' prop_strat_wilson(+ #' * `cv`: The coefficient of variation of `x`, i.e.: ([stats::sd()] / [mean()] * 100). |
||
| 259 | +104 |
- #' rsp = rsp, strata = strata,+ #' * `geom_mean`: The geometric mean of `x`, i.e.: (`exp(mean(log(x)))`). |
||
| 260 | +105 |
- #' conf_level = 0.90+ #' * `geom_cv`: The geometric coefficient of variation of `x`, i.e.: (`sqrt(exp(sd(log(x)) ^ 2) - 1) * 100`). |
||
| 261 | +106 |
- #' )+ #' |
||
| 262 | +107 |
- #'+ #' @note |
||
| 263 | +108 |
- #' # Not automatic setting of weights+ #' * If `x` is an empty vector, `NA` is returned. This is the expected feature so as to return `rcell` content in |
||
| 264 | +109 |
- #' prop_strat_wilson(+ #' `rtables` when the intersection of a column and a row delimits an empty data selection. |
||
| 265 | +110 |
- #' rsp = rsp, strata = strata,+ #' * When the `mean` function is applied to an empty vector, `NA` will be returned instead of `NaN`, the latter |
||
| 266 | +111 |
- #' weights = rep(1 / n_strata, n_strata),+ #' being standard behavior in R. |
||
| 267 | +112 |
- #' conf_level = 0.90+ #' |
||
| 268 | +113 |
- #' )+ #' @method s_summary numeric |
||
| 269 | +114 |
#' |
||
| 270 | +115 |
- #' @export+ #' @examples |
||
| 271 | +116 |
- prop_strat_wilson <- function(rsp,+ #' # `s_summary.numeric` |
||
| 272 | +117 |
- strata,+ #' |
||
| 273 | +118 |
- weights = NULL,+ #' ## Basic usage: empty numeric returns NA-filled items. |
||
| 274 | +119 |
- conf_level = 0.95,+ #' s_summary(numeric()) |
||
| 275 | +120 |
- max_iterations = NULL,+ #' |
||
| 276 | +121 |
- correct = FALSE) {
+ #' ## Management of NA values. |
||
| 277 | -20x | +|||
| 122 | +
- checkmate::assert_logical(rsp, any.missing = FALSE)+ #' x <- c(NA_real_, 1) |
|||
| 278 | -20x | +|||
| 123 | +
- checkmate::assert_factor(strata, len = length(rsp))+ #' s_summary(x, na.rm = TRUE) |
|||
| 279 | -20x | +|||
| 124 | +
- assert_proportion_value(conf_level)+ #' s_summary(x, na.rm = FALSE) |
|||
| 280 | +125 |
-
+ #' |
||
| 281 | -20x | +|||
| 126 | +
- tbl <- table(rsp, strata)+ #' x <- c(NA_real_, 1, 2) |
|||
| 282 | -20x | +|||
| 127 | +
- n_strata <- length(unique(strata))+ #' s_summary(x, stats = NULL) |
|||
| 283 | +128 |
-
+ #' |
||
| 284 | +129 |
- # Checking the weights and maximum number of iterations.+ #' ## Benefits in `rtables` contructions: |
||
| 285 | -20x | +|||
| 130 | +
- do_iter <- FALSE+ #' require(rtables) |
|||
| 286 | -20x | +|||
| 131 | +
- if (is.null(weights)) {
+ #' dta_test <- data.frame( |
|||
| 287 | -6x | +|||
| 132 | +
- weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure+ #' Group = rep(LETTERS[1:3], each = 2), |
|||
| 288 | -6x | +|||
| 133 | +
- do_iter <- TRUE+ #' sub_group = rep(letters[1:2], each = 3), |
|||
| 289 | +134 |
-
+ #' x = 1:6 |
||
| 290 | +135 |
- # Iteration parameters+ #' ) |
||
| 291 | -2x | +|||
| 136 | +
- if (is.null(max_iterations)) max_iterations <- 10+ #' |
|||
| 292 | -6x | +|||
| 137 | +
- checkmate::assert_int(max_iterations, na.ok = FALSE, null.ok = FALSE, lower = 1)+ #' ## The summary obtained in with `rtables`: |
|||
| 293 | +138 |
- }+ #' basic_table() %>% |
||
| 294 | -20x | +|||
| 139 | +
- checkmate::assert_numeric(weights, lower = 0, upper = 1, any.missing = FALSE, len = n_strata)+ #' split_cols_by(var = "Group") %>% |
|||
| 295 | -20x | +|||
| 140 | +
- sum_weights <- checkmate::assert_int(sum(weights))+ #' split_rows_by(var = "sub_group") %>% |
|||
| 296 | -! | +|||
| 141 | +
- if (as.integer(sum_weights + 0.5) != 1L) stop("Sum of weights must be 1L.")
+ #' analyze(vars = "x", afun = s_summary) %>% |
|||
| 297 | +142 |
-
+ #' build_table(df = dta_test) |
||
| 298 | +143 |
-
+ #' |
||
| 299 | -20x | +|||
| 144 | +
- xs <- tbl["TRUE", ]+ #' ## By comparison with `lapply`: |
|||
| 300 | -20x | +|||
| 145 | +
- ns <- colSums(tbl)+ #' X <- split(dta_test, f = with(dta_test, interaction(Group, sub_group))) |
|||
| 301 | -20x | +|||
| 146 | +
- use_stratum <- (ns > 0)+ #' lapply(X, function(x) s_summary(x$x)) |
|||
| 302 | -20x | +|||
| 147 | +
- ns <- ns[use_stratum]+ #' |
|||
| 303 | -20x | +|||
| 148 | +
- xs <- xs[use_stratum]+ #' @export |
|||
| 304 | -20x | +|||
| 149 | +
- ests <- xs / ns+ s_summary.numeric <- function(x, |
|||
| 305 | -20x | +|||
| 150 | +
- vars <- ests * (1 - ests) / ns+ na.rm = TRUE, # nolint |
|||
| 306 | +151 |
-
+ denom, |
||
| 307 | -20x | +|||
| 152 | +
- strata_qnorm <- strata_normal_quantile(vars, weights, conf_level)+ .N_row, # nolint |
|||
| 308 | +153 |
-
+ .N_col, # nolint |
||
| 309 | +154 |
- # Iterative setting of weights if they were not set externally+ .var, |
||
| 310 | -20x | +|||
| 155 | +
- weights_new <- if (do_iter) {
+ control = control_analyze_vars(),+ |
+ |||
| 156 | ++ |
+ ...) {
|
||
| 311 | -6x | +157 | +295x |
- update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max_iterations, conf_level)$weights+ checkmate::assert_numeric(x) |
| 312 | +158 |
- } else {
+
|
||
| 313 | -14x | +159 | +295x |
- weights+ if (na.rm) {
+ |
+
| 160 | +294x | +
+ x <- x[!is.na(x)] |
||
| 314 | +161 |
} |
||
| 315 | +162 | |||
| 316 | -20x | +163 | +295x |
- strata_conf_level <- 2 * stats::pnorm(strata_qnorm) - 1+ y <- list() |
| 317 | +164 | |||
| 318 | -20x | -
- ci_by_strata <- Map(- |
- ||
| 319 | -20x | +165 | +295x |
- function(x, n) {
+ y$n <- c("n" = length(x))
|
| 320 | +166 |
- # Classic Wilson's confidence interval+ |
||
| 321 | -139x | +167 | +295x |
- suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf_level)$conf.int)+ y$sum <- c("sum" = ifelse(length(x) == 0, NA_real_, sum(x, na.rm = FALSE)))
|
| 322 | +168 |
- },- |
- ||
| 323 | -20x | -
- x = xs,+ |
||
| 324 | -20x | +169 | +295x |
- n = ns+ y$mean <- c("mean" = ifelse(length(x) == 0, NA_real_, mean(x, na.rm = FALSE)))
|
| 325 | +170 |
- )- |
- ||
| 326 | -20x | -
- lower_by_strata <- sapply(ci_by_strata, "[", 1L)+ |
||
| 327 | -20x | +171 | +295x |
- upper_by_strata <- sapply(ci_by_strata, "[", 2L)+ y$sd <- c("sd" = stats::sd(x, na.rm = FALSE))
|
| 328 | +172 | |||
| 329 | -20x | -
- lower <- sum(weights_new * lower_by_strata)- |
- ||
| 330 | -20x | +173 | +295x |
- upper <- sum(weights_new * upper_by_strata)+ y$se <- c("se" = stats::sd(x, na.rm = FALSE) / sqrt(length(stats::na.omit(x))))
|
| 331 | +174 | |||
| 332 | -+ | |||
| 175 | +295x |
- # Return values+ y$mean_sd <- c(y$mean, "sd" = stats::sd(x, na.rm = FALSE)) |
||
| 333 | -20x | +|||
| 176 | +
- if (do_iter) {
+
|
|||
| 334 | -6x | +177 | +295x |
- list(+ y$mean_se <- c(y$mean, y$se) |
| 335 | -6x | +|||
| 178 | +
- conf_int = c(+ |
|||
| 336 | -6x | +179 | +295x |
- lower = lower,+ mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE) |
| 337 | -6x | +180 | +295x |
- upper = upper+ y$mean_ci <- formatters::with_label(mean_ci, paste("Mean", f_conf_level(control$conf_level)))
|
| 338 | +181 |
- ),+ |
||
| 339 | -6x | +182 | +295x |
- weights = weights_new+ mean_sei <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE) / sqrt(y$n) |
| 340 | -+ | |||
| 183 | +295x |
- )+ names(mean_sei) <- c("mean_sei_lwr", "mean_sei_upr")
|
||
| 341 | -+ | |||
| 184 | +295x |
- } else {
+ y$mean_sei <- formatters::with_label(mean_sei, "Mean -/+ 1xSE") |
||
| 342 | -14x | +|||
| 185 | +
- list(+ |
|||
| 343 | -14x | +186 | +295x |
- conf_int = c(+ mean_sdi <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE) |
| 344 | -14x | +187 | +295x |
- lower = lower,+ names(mean_sdi) <- c("mean_sdi_lwr", "mean_sdi_upr")
|
| 345 | -14x | +188 | +295x |
- upper = upper+ y$mean_sdi <- formatters::with_label(mean_sdi, "Mean -/+ 1xSD") |
| 346 | +189 |
- )+ |
||
| 347 | -+ | |||
| 190 | +295x |
- )+ mean_pval <- stat_mean_pval(x, test_mean = control$test_mean, na.rm = FALSE, n_min = 2) |
||
| 348 | -+ | |||
| 191 | +295x |
- }+ y$mean_pval <- formatters::with_label(mean_pval, paste("Mean", f_pval(control$test_mean)))
|
||
| 349 | +192 |
- }+ + |
+ ||
| 193 | +295x | +
+ y$median <- c("median" = stats::median(x, na.rm = FALSE))
|
||
| 350 | +194 | |||
| 351 | -+ | |||
| 195 | +295x |
- #' @describeIn h_proportions Calculates the Clopper-Pearson interval by calling [stats::binom.test()].+ y$mad <- c("mad" = stats::median(x - y$median, na.rm = FALSE))
|
||
| 352 | +196 |
- #' Also referred to as the `exact` method.+ |
||
| 353 | -+ | |||
| 197 | +295x |
- #'+ median_ci <- stat_median_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE) |
||
| 354 | -+ | |||
| 198 | +295x |
- #' @examples+ y$median_ci <- formatters::with_label(median_ci, paste("Median", f_conf_level(control$conf_level)))
|
||
| 355 | +199 |
- #' prop_clopper_pearson(rsp, conf_level = .95)+ |
||
| 356 | -+ | |||
| 200 | +295x |
- #'+ q <- control$quantiles |
||
| 357 | -+ | |||
| 201 | +295x |
- #' @export+ if (any(is.na(x))) {
|
||
| 358 | -+ | |||
| 202 | +1x |
- prop_clopper_pearson <- function(rsp,+ qnts <- rep(NA_real_, length(q)) |
||
| 359 | +203 |
- conf_level) {
+ } else {
|
||
| 360 | -1x | +204 | +294x |
- y <- stats::binom.test(+ qnts <- stats::quantile(x, probs = q, type = control$quantile_type, na.rm = FALSE) |
| 361 | -1x | +|||
| 205 | +
- x = sum(rsp),+ } |
|||
| 362 | -1x | +206 | +295x |
- n = length(rsp),+ names(qnts) <- paste("quantile", q, sep = "_")
|
| 363 | -1x | +207 | +295x |
- conf.level = conf_level+ y$quantiles <- formatters::with_label(qnts, paste0(paste(paste0(q * 100, "%"), collapse = " and "), "-ile")) |
| 364 | +208 |
- )+ |
||
| 365 | -1x | +209 | +295x |
- as.numeric(y$conf.int)+ y$iqr <- c("iqr" = ifelse(
|
| 366 | -+ | |||
| 210 | +295x |
- }+ any(is.na(x)), |
||
| 367 | -+ | |||
| 211 | +295x |
-
+ NA_real_, |
||
| 368 | -+ | |||
| 212 | +295x |
- #' @describeIn h_proportions Calculates the Wald interval by following the usual textbook definition+ stats::IQR(x, na.rm = FALSE, type = control$quantile_type) |
||
| 369 | +213 |
- #' for a single proportion confidence interval using the normal approximation.+ )) |
||
| 370 | +214 |
- #'+ |
||
| 371 | -+ | |||
| 215 | +295x |
- #' @param correct (`flag`)\cr apply continuity correction.+ y$range <- stats::setNames(range_noinf(x, na.rm = FALSE), c("min", "max"))
|
||
| 372 | -+ | |||
| 216 | +295x |
- #'+ y$min <- y$range[1] |
||
| 373 | -+ | |||
| 217 | +295x |
- #' @examples+ y$max <- y$range[2] |
||
| 374 | +218 |
- #' prop_wald(rsp, conf_level = 0.95)+ |
||
| 375 | -+ | |||
| 219 | +295x |
- #' prop_wald(rsp, conf_level = 0.95, correct = TRUE)+ y$median_range <- formatters::with_label(c(y$median, y$range), "Median (Min - Max)") |
||
| 376 | +220 |
- #'+ + |
+ ||
| 221 | +295x | +
+ y$cv <- c("cv" = unname(y$sd) / unname(y$mean) * 100)
|
||
| 377 | +222 |
- #' @export+ |
||
| 378 | +223 |
- prop_wald <- function(rsp, conf_level, correct = FALSE) {
+ # Convert negative values to NA for log calculation. |
||
| 379 | -122x | +224 | +295x |
- n <- length(rsp)+ x_no_negative_vals <- x |
| 380 | -122x | +225 | +295x |
- p_hat <- mean(rsp)+ x_no_negative_vals[x_no_negative_vals <= 0] <- NA |
| 381 | -122x | +226 | +295x |
- z <- stats::qnorm((1 + conf_level) / 2)+ y$geom_mean <- c("geom_mean" = exp(mean(log(x_no_negative_vals), na.rm = FALSE)))
|
| 382 | -122x | +227 | +295x |
- q_hat <- 1 - p_hat+ geom_mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE, geom_mean = TRUE) |
| 383 | -122x | +228 | +295x |
- correct <- if (correct) 1 / (2 * n) else 0+ y$geom_mean_ci <- formatters::with_label(geom_mean_ci, paste("Geometric Mean", f_conf_level(control$conf_level)))
|
| 384 | +229 | |||
| 385 | -122x | -
- err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correct- |
- ||
| 386 | -122x | -
- l_ci <- max(0, p_hat - err)- |
- ||
| 387 | -122x | +230 | +295x |
- u_ci <- min(1, p_hat + err)+ y$geom_cv <- c("geom_cv" = sqrt(exp(stats::sd(log(x_no_negative_vals), na.rm = FALSE) ^ 2) - 1) * 100) # styler: off
|
| 388 | +231 | |||
| 389 | -122x | +232 | +295x |
- c(l_ci, u_ci)+ y |
| 390 | +233 |
} |
||
| 391 | +234 | |||
| 392 | +235 |
- #' @describeIn h_proportions Calculates the `Agresti-Coull` interval (created by `Alan Agresti` and `Brent Coull`) by+ #' @describeIn analyze_variables Method for `factor` class. |
||
| 393 | +236 |
- #' (for 95% CI) adding two successes and two failures to the data and then using the Wald formula to construct a CI.+ #' |
||
| 394 | +237 |
- #'+ #' @param denom (`string`)\cr choice of denominator for factor proportions. Options are: |
||
| 395 | +238 |
- #' @examples+ #' * `n`: number of values in this row and column intersection. |
||
| 396 | +239 |
- #' prop_agresti_coull(rsp, conf_level = 0.95)+ #' * `N_row`: total number of values in this row across columns. |
||
| 397 | +240 |
- #'+ #' * `N_col`: total number of values in this column across rows. |
||
| 398 | +241 |
- #' @export+ #' |
||
| 399 | +242 |
- prop_agresti_coull <- function(rsp, conf_level) {
- |
- ||
| 400 | -2x | -
- n <- length(rsp)- |
- ||
| 401 | -2x | -
- x_sum <- sum(rsp)- |
- ||
| 402 | -2x | -
- z <- stats::qnorm((1 + conf_level) / 2)+ #' @return |
||
| 403 | +243 |
-
+ #' * If `x` is of class `factor` or converted from `character`, returns a `list` with named `numeric` items: |
||
| 404 | +244 |
- # Add here both z^2 / 2 successes and failures.- |
- ||
| 405 | -2x | -
- x_sum_tilde <- x_sum + z^2 / 2- |
- ||
| 406 | -2x | -
- n_tilde <- n + z^2+ #' * `n`: The [length()] of `x`. |
||
| 407 | +245 |
-
+ #' * `count`: A list with the number of cases for each level of the factor `x`. |
||
| 408 | +246 |
- # Then proceed as with the Wald interval.+ #' * `count_fraction`: Similar to `count` but also includes the proportion of cases for each level of the |
||
| 409 | -2x | +|||
| 247 | +
- p_tilde <- x_sum_tilde / n_tilde+ #' factor `x` relative to the denominator, or `NA` if the denominator is zero. |
|||
| 410 | -2x | +|||
| 248 | +
- q_tilde <- 1 - p_tilde+ #' |
|||
| 411 | -2x | +|||
| 249 | +
- err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)+ #' @note |
|||
| 412 | -2x | +|||
| 250 | +
- l_ci <- max(0, p_tilde - err)+ #' * If `x` is an empty `factor`, a list is still returned for `counts` with one element |
|||
| 413 | -2x | +|||
| 251 | +
- u_ci <- min(1, p_tilde + err)+ #' per factor level. If there are no levels in `x`, the function fails. |
|||
| 414 | +252 |
-
+ #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values |
||
| 415 | -2x | +|||
| 253 | +
- c(l_ci, u_ci)+ #' set `na.rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit |
|||
| 416 | +254 |
- }+ #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the |
||
| 417 | +255 |
-
+ #' default `na_level` (`"<Missing>"`) will also be excluded when `na.rm` is set to `TRUE`. |
||
| 418 | +256 |
- #' @describeIn h_proportions Calculates the Jeffreys interval, an equal-tailed interval based on the+ #' |
||
| 419 | +257 |
- #' non-informative Jeffreys prior for a binomial proportion.+ #' @method s_summary factor |
||
| 420 | +258 |
#' |
||
| 421 | +259 |
#' @examples |
||
| 422 | +260 |
- #' prop_jeffreys(rsp, conf_level = 0.95)+ #' # `s_summary.factor` |
||
| 423 | +261 |
#' |
||
| 424 | +262 |
- #' @export+ #' ## Basic usage: |
||
| 425 | +263 |
- prop_jeffreys <- function(rsp,+ #' s_summary(factor(c("a", "a", "b", "c", "a")))
|
||
| 426 | +264 |
- conf_level) {
- |
- ||
| 427 | -4x | -
- n <- length(rsp)- |
- ||
| 428 | -4x | -
- x_sum <- sum(rsp)+ #' # Empty factor returns NA-filled items. |
||
| 429 | +265 | - - | -||
| 430 | -4x | -
- alpha <- 1 - conf_level- |
- ||
| 431 | -4x | -
- l_ci <- ifelse(- |
- ||
| 432 | -4x | -
- x_sum == 0,+ #' s_summary(factor(levels = c("a", "b", "c")))
|
||
| 433 | -4x | +|||
| 266 | +
- 0,+ #' |
|||
| 434 | -4x | +|||
| 267 | +
- stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ #' ## Management of NA values. |
|||
| 435 | +268 |
- )+ #' x <- factor(c(NA, "Female")) |
||
| 436 | +269 |
-
+ #' x <- explicit_na(x) |
||
| 437 | -4x | +|||
| 270 | +
- u_ci <- ifelse(+ #' s_summary(x, na.rm = TRUE) |
|||
| 438 | -4x | +|||
| 271 | +
- x_sum == n,+ #' s_summary(x, na.rm = FALSE) |
|||
| 439 | -4x | +|||
| 272 | +
- 1,+ #' |
|||
| 440 | -4x | +|||
| 273 | +
- stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ #' ## Different denominators. |
|||
| 441 | +274 |
- )+ #' x <- factor(c("a", "a", "b", "c", "a"))
|
||
| 442 | +275 |
-
+ #' s_summary(x, denom = "N_row", .N_row = 10L) |
||
| 443 | -4x | +|||
| 276 | +
- c(l_ci, u_ci)+ #' s_summary(x, denom = "N_col", .N_col = 20L) |
|||
| 444 | +277 |
- }+ #' |
||
| 445 | +278 |
-
+ #' @export |
||
| 446 | +279 |
- #' Description of the Proportion Summary+ s_summary.factor <- function(x, |
||
| 447 | +280 |
- #'+ na.rm = TRUE, # nolint |
||
| 448 | +281 |
- #' @description `r lifecycle::badge("stable")`
+ denom = c("n", "N_row", "N_col"),
|
||
| 449 | +282 |
- #'+ .N_row, # nolint |
||
| 450 | +283 |
- #' This is a helper function that describes the analysis in [s_proportion()].+ .N_col, # nolint |
||
| 451 | +284 |
- #'+ ...) {
|
||
| 452 | -+ | |||
| 285 | +274x |
- #' @inheritParams s_proportion+ assert_valid_factor(x) |
||
| 453 | -+ | |||
| 286 | +271x |
- #' @param long (`flag`)\cr whether a long or a short (default) description is required.+ denom <- match.arg(denom) |
||
| 454 | +287 |
- #'+ |
||
| 455 | -+ | |||
| 288 | +271x |
- #' @return String describing the analysis.+ if (na.rm) {
|
||
| 456 | -+ | |||
| 289 | +267x |
- #'+ x <- x[!is.na(x)] %>% fct_discard("<Missing>")
|
||
| 457 | +290 |
- #' @export+ } else {
|
||
| 458 | -+ | |||
| 291 | +4x |
- d_proportion <- function(conf_level,+ x <- x %>% explicit_na(label = "NA") |
||
| 459 | +292 |
- method,+ } |
||
| 460 | +293 |
- long = FALSE) {
+
|
||
| 461 | -137x | +294 | +271x |
- label <- paste0(conf_level * 100, "% CI")+ y <- list() |
| 462 | +295 | |||
| 463 | -! | +|||
| 296 | +271x |
- if (long) label <- paste(label, "for Response Rates")+ y$n <- length(x) |
||
| 464 | +297 | |||
| 465 | -137x | +298 | +271x |
- method_part <- switch(method,+ y$count <- as.list(table(x, useNA = "ifany")) |
| 466 | -137x | +299 | +271x |
- "clopper-pearson" = "Clopper-Pearson",+ dn <- switch(denom, |
| 467 | -137x | +300 | +271x |
- "waldcc" = "Wald, with correction",+ n = length(x), |
| 468 | -137x | +301 | +271x |
- "wald" = "Wald, without correction",+ N_row = .N_row, |
| 469 | -137x | +302 | +271x |
- "wilson" = "Wilson, without correction",+ N_col = .N_col |
| 470 | -137x | +|||
| 303 | +
- "strat_wilson" = "Stratified Wilson, without correction",+ ) |
|||
| 471 | -137x | +304 | +271x |
- "wilsonc" = "Wilson, with correction",+ y$count_fraction <- lapply( |
| 472 | -137x | +305 | +271x |
- "strat_wilsonc" = "Stratified Wilson, with correction",+ y$count, |
| 473 | -137x | +306 | +271x |
- "agresti-coull" = "Agresti-Coull",+ function(x) {
|
| 474 | -137x | +307 | +2089x |
- "jeffreys" = "Jeffreys",+ c(x, ifelse(dn > 0, x / dn, 0)) |
| 475 | -137x | +|||
| 308 | +
- stop(paste(method, "does not have a description"))+ } |
|||
| 476 | +309 |
) |
||
| 477 | +310 | |||
| 478 | -137x | +311 | +271x |
- paste0(label, " (", method_part, ")")
+ y$n_blq <- sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", x))
|
| 479 | +312 | ++ | + + | +|
| 313 | +271x | +
+ y+ |
+ ||
| 314 |
} |
|||
| 480 | +315 | |||
| 481 | +316 |
- #' Helper Function for the Estimation of Stratified Quantiles+ #' @describeIn analyze_variables Method for `character` class. This makes an automatic |
||
| 482 | +317 | ++ |
+ #' conversion to factor (with a warning) and then forwards to the method for factors.+ |
+ |
| 318 |
#' |
|||
| 483 | +319 |
- #' @description `r lifecycle::badge("stable")`
+ #' @param verbose (`logical`)\cr Defaults to `TRUE`, which prints out warnings and messages. It is mainly used |
||
| 484 | +320 |
- #'+ #' to print out information about factor casting. |
||
| 485 | +321 |
- #' This function wraps the estimation of stratified percentiles when we assume+ #' |
||
| 486 | +322 |
- #' the approximation for large numbers. This is necessary only in the case+ #' @note |
||
| 487 | +323 |
- #' proportions for each strata are unequal.+ #' * Automatic conversion of character to factor does not guarantee that the table |
||
| 488 | +324 |
- #'+ #' can be generated correctly. In particular for sparse tables this very likely can fail. |
||
| 489 | +325 |
- #' @inheritParams argument_convention+ #' It is therefore better to always pre-process the dataset such that factors are manually |
||
| 490 | +326 |
- #' @inheritParams prop_strat_wilson+ #' created from character variables before passing the dataset to [rtables::build_table()]. |
||
| 491 | +327 |
#' |
||
| 492 | +328 |
- #' @return Stratified quantile.+ #' @method s_summary character |
||
| 493 | +329 |
#' |
||
| 494 | +330 |
- #' @seealso [prop_strat_wilson()]+ #' @examples |
||
| 495 | +331 | ++ |
+ #' # `s_summary.character`+ |
+ |
| 332 |
#' |
|||
| 496 | +333 |
- #' @examples+ #' ## Basic usage: |
||
| 497 | +334 |
- #' strata_data <- table(data.frame(+ #' s_summary(c("a", "a", "b", "c", "a"), .var = "x", verbose = FALSE)
|
||
| 498 | +335 |
- #' "f1" = sample(c(TRUE, FALSE), 100, TRUE),+ #' s_summary(c("a", "a", "b", "c", "a", ""), .var = "x", na.rm = FALSE, verbose = FALSE)
|
||
| 499 | +336 |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ #' |
||
| 500 | +337 |
- #' stringsAsFactors = TRUE+ #' @export |
||
| 501 | +338 |
- #' ))+ |
||
| 502 | +339 |
- #' ns <- colSums(strata_data)+ s_summary.character <- function(x, |
||
| 503 | +340 |
- #' ests <- strata_data["TRUE", ] / ns+ na.rm = TRUE, # nolint |
||
| 504 | +341 |
- #' vars <- ests * (1 - ests) / ns+ denom = c("n", "N_row", "N_col"),
|
||
| 505 | +342 |
- #' weights <- rep(1 / length(ns), length(ns))+ .N_row, # nolint |
||
| 506 | +343 |
- #' strata_normal_quantile(vars, weights, 0.95)+ .N_col, # nolint |
||
| 507 | +344 |
- #'+ .var, |
||
| 508 | +345 |
- #' @export+ verbose = TRUE, |
||
| 509 | +346 |
- strata_normal_quantile <- function(vars, weights, conf_level) {
+ ...) {
|
||
| 510 | -41x | +347 | +6x |
- summands <- weights^2 * vars+ if (na.rm) {
+ |
+
| 348 | +5x | +
+ y <- as_factor_keep_attributes(x, verbose = verbose) |
||
| 511 | +349 |
- # Stratified quantile+ } else {
|
||
| 512 | -41x | +350 | +1x |
- sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf_level) / 2)+ y <- as_factor_keep_attributes(x, verbose = verbose, na_level = "NA") |
| 513 | +351 |
- }+ } |
||
| 514 | +352 | |||
| 353 | +6x | +
+ s_summary(+ |
+ ||
| 354 | +6x | +
+ x = y,+ |
+ ||
| 355 | +6x | +
+ na.rm = na.rm,+ |
+ ||
| 356 | +6x | +
+ denom = denom,+ |
+ ||
| 357 | +6x | +
+ .N_row = .N_row,+ |
+ ||
| 358 | +6x | +
+ .N_col = .N_col,+ |
+ ||
| 515 | +359 |
- #' Helper Function for the Estimation of Weights for `prop_strat_wilson`+ ... |
||
| 516 | +360 |
- #'+ ) |
||
| 517 | +361 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 518 | +362 |
- #'+ |
||
| 519 | +363 |
- #' This function wraps the iteration procedure that allows you to estimate+ #' @describeIn analyze_variables Method for `logical` class. |
||
| 520 | +364 |
- #' the weights for each proportional strata. This assumes to minimize the+ #' |
||
| 521 | +365 |
- #' weighted squared length of the confidence interval.+ #' @param denom (`string`)\cr choice of denominator for proportion. Options are: |
||
| 522 | +366 |
- #'+ #' * `n`: number of values in this row and column intersection. |
||
| 523 | +367 |
- #' @inheritParams prop_strat_wilson+ #' * `N_row`: total number of values in this row across columns. |
||
| 524 | +368 |
- #' @param vars (`numeric`)\cr normalized proportions for each strata.+ #' * `N_col`: total number of values in this column across rows. |
||
| 525 | +369 |
- #' @param strata_qnorm (`numeric`)\cr initial estimation with identical weights of the quantiles.+ #' |
||
| 526 | +370 |
- #' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can+ #' @return |
||
| 527 | +371 |
- #' be optimized in the future if we need to estimate better initial weights.+ #' * If `x` is of class `logical`, returns a `list` with named `numeric` items: |
||
| 528 | +372 |
- #' @param n_per_strata (`numeric`)\cr number of elements in each strata.+ #' * `n`: The [length()] of `x` (possibly after removing `NA`s). |
||
| 529 | +373 |
- #' @param max_iterations (`count`)\cr maximum number of iterations to be tried. Convergence is always checked.+ #' * `count`: Count of `TRUE` in `x`. |
||
| 530 | +374 |
- #' @param tol (`number`)\cr tolerance threshold for convergence.+ #' * `count_fraction`: Count and proportion of `TRUE` in `x` relative to the denominator, or `NA` if the |
||
| 531 | +375 | ++ |
+ #' denominator is zero. Note that `NA`s in `x` are never counted or leading to `NA` here.+ |
+ |
| 376 |
#' |
|||
| 532 | +377 |
- #' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`.+ #' @method s_summary logical |
||
| 533 | +378 |
#' |
||
| 534 | +379 |
- #' @seealso For references and details see [prop_strat_wilson()].+ #' @examples |
||
| 535 | +380 | ++ |
+ #' # `s_summary.logical`+ |
+ |
| 381 |
#' |
|||
| 536 | +382 |
- #' @examples+ #' ## Basic usage: |
||
| 537 | +383 |
- #' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018)+ #' s_summary(c(TRUE, FALSE, TRUE, TRUE)) |
||
| 538 | +384 |
- #' sq <- 0.674+ #' |
||
| 539 | +385 |
- #' ws <- rep(1 / length(vs), length(vs))+ #' ## Management of NA values. |
||
| 540 | +386 |
- #' ns <- c(22, 18, 17, 17, 14, 12)+ #' x <- c(NA, TRUE, FALSE) |
||
| 541 | +387 |
- #'+ #' s_summary(x, na.rm = TRUE) |
||
| 542 | +388 |
- #' update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001)+ #' s_summary(x, na.rm = FALSE) |
||
| 543 | +389 |
#' |
||
| 544 | +390 |
- #' @export+ #' ## Different denominators. |
||
| 545 | +391 |
- update_weights_strat_wilson <- function(vars,+ #' x <- c(TRUE, FALSE, TRUE, TRUE) |
||
| 546 | +392 |
- strata_qnorm,+ #' s_summary(x, denom = "N_row", .N_row = 10L) |
||
| 547 | +393 |
- initial_weights,+ #' s_summary(x, denom = "N_col", .N_col = 20L) |
||
| 548 | +394 |
- n_per_strata,+ #' |
||
| 549 | +395 |
- max_iterations = 50,+ #' @export |
||
| 550 | +396 |
- conf_level = 0.95,+ s_summary.logical <- function(x, |
||
| 551 | +397 |
- tol = 0.001) {
+ na.rm = TRUE, # nolint |
||
| 552 | -8x | +|||
| 398 | +
- it <- 0+ denom = c("n", "N_row", "N_col"),
|
|||
| 553 | -8x | +|||
| 399 | +
- diff_v <- NULL+ .N_row, # nolint |
|||
| 554 | +400 |
-
+ .N_col, # nolint |
||
| 555 | -8x | +|||
| 401 | +
- while (it < max_iterations) {
+ ...) {
|
|||
| 556 | -19x | +402 | +115x |
- it <- it + 1+ denom <- match.arg(denom) |
| 557 | -19x | +403 | +113x |
- weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2+ if (na.rm) x <- x[!is.na(x)] |
| 558 | -19x | +404 | +115x |
- weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2))+ y <- list() |
| 559 | -19x | +405 | +115x |
- weights_new <- weights_new_t / weights_new_b+ y$n <- length(x) |
| 560 | -19x | +406 | +115x |
- weights_new <- weights_new / sum(weights_new)+ count <- sum(x, na.rm = TRUE) |
| 561 | -19x | +407 | +115x |
- strata_qnorm <- strata_normal_quantile(vars, weights_new, conf_level)+ dn <- switch(denom, |
| 562 | -19x | +408 | +115x |
- diff_v <- c(diff_v, sum(abs(weights_new - initial_weights)))+ n = length(x), |
| 563 | -8x | +409 | +115x |
- if (diff_v[length(diff_v)] < tol) break+ N_row = .N_row, |
| 564 | -11x | +410 | +115x |
- initial_weights <- weights_new+ N_col = .N_col |
| 565 | +411 |
- }+ ) |
||
| 566 | -+ | |||
| 412 | +115x |
-
+ y$count <- count |
||
| 567 | -8x | +413 | +115x |
- if (it == max_iterations) {
+ y$count_fraction <- c(count, ifelse(dn > 0, count / dn, NA)) |
| 568 | -! | +|||
| 414 | +115x |
- warning("The heuristic to find weights did not converge with max_iterations = ", max_iterations)
+ y$n_blq <- 0L+ |
+ ||
| 415 | +115x | +
+ y |
||
| 569 | +416 |
- }+ } |
||
| 570 | +417 | |||
| 571 | -8x | +|||
| 418 | +
- list(+ #' @describeIn analyze_variables Formatted analysis function which is used as `afun` in `analyze_vars()` and |
|||
| 572 | -8x | +|||
| 419 | +
- "n_it" = it,+ #' `compare_vars()` and as `cfun` in `summarize_colvars()`. |
|||
| 573 | -8x | +|||
| 420 | +
- "weights" = weights_new,+ #' |
|||
| 574 | -8x | +|||
| 421 | +
- "diff_v" = diff_v+ #' @param compare (`logical`)\cr Whether comparison statistics should be analyzed instead of summary statistics |
|||
| 575 | +422 |
- )+ #' (`compare = TRUE` adds `pval` statistic comparing against reference group). |
||
| 576 | +423 |
- }+ #' |
| 1 | +424 |
- #' Control Function for Descriptive Statistics+ #' @return |
||
| 2 | +425 |
- #'+ #' * `a_summary()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 3 | +426 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 4 | +427 |
- #'+ #' @note |
||
| 5 | +428 |
- #' Sets a list of parameters for summaries of descriptive statistics. Typically used internally to specify+ #' * To use for comparison (with additional p-value statistic), parameter `compare` must be set to `TRUE`. |
||
| 6 | +429 |
- #' details for [s_summary()]. This function family is mainly used by [analyze_vars()].+ #' * Ensure that either all `NA` values are converted to an explicit `NA` level or all `NA` values are left as is. |
||
| 7 | +430 |
#' |
||
| 8 | +431 |
- #' @inheritParams argument_convention+ #' @examples |
||
| 9 | +432 |
- #' @param quantiles (`numeric`)\cr of length two to specify the quantiles to calculate.+ #' a_summary(factor(c("a", "a", "b", "c", "a")), .N_row = 10, .N_col = 10)
|
||
| 10 | +433 |
- #' @param quantile_type (`numeric`)\cr between 1 and 9 selecting quantile algorithms to be used.+ #' a_summary( |
||
| 11 | +434 |
- #' Default is set to 2 as this matches the default quantile algorithm in SAS `proc univariate` set by `QNTLDEF=5`.+ #' factor(c("a", "a", "b", "c", "a")),
|
||
| 12 | +435 |
- #' This differs from R's default. See more about `type` in [stats::quantile()].+ #' .ref_group = factor(c("a", "a", "b", "c")), compare = TRUE
|
||
| 13 | +436 |
- #' @param test_mean (`numeric`)\cr to test against the mean under the null hypothesis when calculating p-value.+ #' ) |
||
| 14 | +437 |
#' |
||
| 15 | +438 |
- #' @note Deprecation cycle started for `control_summarize_vars` as it is going to renamed into+ #' a_summary(c("A", "B", "A", "C"), .var = "x", .N_col = 10, .N_row = 10, verbose = FALSE)
|
||
| 16 | +439 |
- #' `control_analyze_vars`. Intention is to reflect better the core underlying `rtables`+ #' a_summary( |
||
| 17 | +440 |
- #' functions; in this case [analyze_vars()] wraps [rtables::analyze()].+ #' c("A", "B", "A", "C"),
|
||
| 18 | +441 |
- #'+ #' .ref_group = c("B", "A", "C"), .var = "x", compare = TRUE, verbose = FALSE
|
||
| 19 | +442 |
- #' @return A list of components with the same names as the arguments.+ #' ) |
||
| 20 | +443 |
#' |
||
| 21 | +444 |
- #' @export control_analyze_vars control_summarize_vars+ #' a_summary(c(TRUE, FALSE, FALSE, TRUE, TRUE), .N_row = 10, .N_col = 10) |
||
| 22 | +445 |
- #' @aliases control_summarize_vars+ #' a_summary( |
||
| 23 | +446 |
- control_analyze_vars <- function(conf_level = 0.95,+ #' c(TRUE, FALSE, FALSE, TRUE, TRUE), |
||
| 24 | +447 |
- quantiles = c(0.25, 0.75),+ #' .ref_group = c(TRUE, FALSE), .in_ref_col = TRUE, compare = TRUE |
||
| 25 | +448 |
- quantile_type = 2,+ #' ) |
||
| 26 | +449 |
- test_mean = 0) {
+ #' |
||
| 27 | -267x | +|||
| 450 | +
- checkmate::assert_vector(quantiles, len = 2)+ #' a_summary(rnorm(10), .N_col = 10, .N_row = 20, .var = "bla") |
|||
| 28 | -267x | +|||
| 451 | +
- checkmate::assert_int(quantile_type, lower = 1, upper = 9)+ #' a_summary(rnorm(10, 5, 1), .ref_group = rnorm(20, -5, 1), .var = "bla", compare = TRUE) |
|||
| 29 | -267x | +|||
| 452 | +
- checkmate::assert_numeric(test_mean)+ #' |
|||
| 30 | -267x | +|||
| 453 | +
- lapply(quantiles, assert_proportion_value)+ |
|||
| 31 | -266x | +|||
| 454 | +
- assert_proportion_value(conf_level)+ #' @export |
|||
| 32 | -265x | +|||
| 455 | +
- list(conf_level = conf_level, quantiles = quantiles, quantile_type = quantile_type, test_mean = test_mean)+ a_summary <- function(x, |
|||
| 33 | +456 |
- }+ .N_col, # nolint |
||
| 34 | +457 |
-
+ .N_row, # nolint |
||
| 35 | +458 |
- control_summarize_vars <- control_analyze_vars+ .var = NULL, |
||
| 36 | +459 |
-
+ .df_row = NULL, |
||
| 37 | +460 |
-
+ .ref_group = NULL, |
||
| 38 | +461 |
- #' Analyze Variables+ .in_ref_col = FALSE, |
||
| 39 | +462 |
- #'+ compare = FALSE, |
||
| 40 | +463 |
- #' @description `r lifecycle::badge("stable")`
+ .stats = NULL, |
||
| 41 | +464 |
- #'+ .formats = NULL, |
||
| 42 | +465 |
- #' We use the S3 generic function [s_summary()] to implement summaries for different `x` objects. This+ .labels = NULL, |
||
| 43 | +466 |
- #' is used as a statistics function in combination with the analyze function [analyze_vars()].+ .indent_mods = NULL, |
||
| 44 | +467 |
- #' Deprecation cycle started for `summarize_vars` as it is going to renamed into+ na.rm = TRUE, # nolint |
||
| 45 | +468 |
- #' `analyze_vars`. Intention is to reflect better the core underlying `rtables`+ na_level = lifecycle::deprecated(), |
||
| 46 | +469 |
- #' functions; in this case [rtables::analyze()].+ na_str = NA_character_, |
||
| 47 | +470 |
- #'+ ...) {
|
||
| 48 | -+ | |||
| 471 | +293x |
- #' @inheritParams argument_convention+ if (lifecycle::is_present(na_level)) {
|
||
| 49 | -+ | |||
| 472 | +! |
- #'+ lifecycle::deprecate_warn("0.9.1", "a_summary(na_level)", "a_summary(na_str)")
|
||
| 50 | -+ | |||
| 473 | +! |
- #' @name analyze_variables+ na_str <- na_level |
||
| 51 | +474 |
- NULL+ } |
||
| 52 | +475 | |||
| 53 | -+ | |||
| 476 | +293x |
- #' @describeIn analyze_variables S3 generic function to produces a variable summary.+ if (is.numeric(x)) {
|
||
| 54 | -+ | |||
| 477 | +68x |
- #'+ type <- "numeric" |
||
| 55 | -+ | |||
| 478 | +68x |
- #' @return+ if (!is.null(.stats) && any(grepl("^pval", .stats))) {
|
||
| 56 | -+ | |||
| 479 | +9x |
- #' * `s_summary()` returns different statistics depending on the class of `x`.+ .stats[grepl("^pval", .stats)] <- "pval" # tmp fix xxx
|
||
| 57 | +480 |
- #'+ } |
||
| 58 | +481 |
- #' @export+ } else {
|
||
| 59 | -+ | |||
| 482 | +225x |
- s_summary <- function(x,+ type <- "counts" |
||
| 60 | -+ | |||
| 483 | +225x |
- na.rm = TRUE, # nolint+ if (!is.null(.stats) && any(grepl("^pval", .stats))) {
+ |
+ ||
| 484 | +9x | +
+ .stats[grepl("^pval", .stats)] <- "pval_counts" # tmp fix xxx
|
||
| 61 | +485 |
- denom,+ } |
||
| 62 | +486 |
- .N_row, # nolint+ } |
||
| 63 | +487 |
- .N_col, # nolint+ |
||
| 64 | +488 |
- .var,+ # If one col has NA vals, must add NA row to other cols (using placeholder lvl `fill-na-level`)+ |
+ ||
| 489 | +! | +
+ if (any(is.na(.df_row[[.var]])) && !any(is.na(x)) && !na.rm) levels(x) <- c(levels(x), "fill-na-level") |
||
| 65 | +490 |
- ...) {
+
|
||
| 66 | -663x | +491 | +293x |
- checkmate::assert_flag(na.rm)+ x_stats <- if (!compare) {
|
| 67 | -663x | +492 | +274x |
- UseMethod("s_summary", x)
+ s_summary(x = x, .N_col = .N_col, .N_row = .N_row, na.rm = na.rm, ...) |
| 68 | +493 |
- }+ } else {
|
||
| 69 | -+ | |||
| 494 | +19x |
-
+ s_compare( |
||
| 70 | -+ | |||
| 495 | +19x |
- #' @describeIn analyze_variables Method for `numeric` class.+ x = x, .N_col = .N_col, .N_row = .N_row, na.rm = na.rm, .ref_group = .ref_group, .in_ref_col = .in_ref_col, ... |
||
| 71 | +496 |
- #'+ ) |
||
| 72 | +497 |
- #' @param control (`list`)\cr parameters for descriptive statistics details, specified by using+ } |
||
| 73 | +498 |
- #' the helper function [control_analyze_vars()]. Some possible parameter options are:+ |
||
| 74 | +499 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for mean and median.+ # Fill in with formatting defaults if needed |
||
| 75 | -+ | |||
| 500 | +293x |
- #' * `quantiles` (`numeric`)\cr vector of length two to specify the quantiles.+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
|
||
| 76 | -+ | |||
| 501 | +293x |
- #' * `quantile_type` (`numeric`)\cr between 1 and 9 selecting quantile algorithms to be used.+ .stats <- get_stats(met_grp, stats_in = .stats, add_pval = compare) |
||
| 77 | -+ | |||
| 502 | +293x |
- #' See more about `type` in [stats::quantile()].+ .formats <- get_formats_from_stats(.stats, .formats) |
||
| 78 | -+ | |||
| 503 | +293x |
- #' * `test_mean` (`numeric`)\cr value to test against the mean under the null hypothesis when calculating p-value.+ .labels <- get_labels_from_stats(.stats, .labels) |
||
| 79 | +504 |
- #'+ |
||
| 80 | -+ | |||
| 505 | +293x |
- #' @return+ indent_mods_custom <- .indent_mods |
||
| 81 | -+ | |||
| 506 | +293x |
- #' * If `x` is of class `numeric`, returns a `list` with the following named `numeric` items:+ .indent_mods <- stats::setNames(rep(0L, length(.stats)), .stats) |
||
| 82 | -+ | |||
| 507 | +293x |
- #' * `n`: The [length()] of `x`.+ if (!is.null(indent_mods_custom)) {
|
||
| 83 | -+ | |||
| 508 | +32x |
- #' * `sum`: The [sum()] of `x`.+ if (is.null(names(indent_mods_custom)) && length(indent_mods_custom) == 1) {
|
||
| 84 | -+ | |||
| 509 | +2x |
- #' * `mean`: The [mean()] of `x`.+ .indent_mods[names(.indent_mods)] <- indent_mods_custom |
||
| 85 | +510 |
- #' * `sd`: The [stats::sd()] of `x`.+ } else {
|
||
| 86 | -+ | |||
| 511 | +30x |
- #' * `se`: The standard error of `x` mean, i.e.: (`sd(x) / sqrt(length(x))`).+ .indent_mods[names(indent_mods_custom)] <- indent_mods_custom |
||
| 87 | +512 |
- #' * `mean_sd`: The [mean()] and [stats::sd()] of `x`.+ } |
||
| 88 | +513 |
- #' * `mean_se`: The [mean()] of `x` and its standard error (see above).+ } |
||
| 89 | +514 |
- #' * `mean_ci`: The CI for the mean of `x` (from [stat_mean_ci()]).+ |
||
| 90 | -+ | |||
| 515 | +293x |
- #' * `mean_sei`: The SE interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()] / [sqrt()]).+ x_stats <- x_stats[.stats] |
||
| 91 | +516 |
- #' * `mean_sdi`: The SD interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()]).+ |
||
| 92 | +517 |
- #' * `mean_pval`: The two-sided p-value of the mean of `x` (from [stat_mean_pval()]).+ # Check for custom labels from control_analyze_vars |
||
| 93 | -+ | |||
| 518 | +293x |
- #' * `median`: The [stats::median()] of `x`.+ if (is.numeric(x)) {
|
||
| 94 | -+ | |||
| 519 | +68x |
- #' * `mad`: The median absolute deviation of `x`, i.e.: ([stats::median()] of `xc`,+ default_labels <- get_labels_from_stats(.stats) |
||
| 95 | -+ | |||
| 520 | +68x |
- #' where `xc` = `x` - [stats::median()]).+ for (i in intersect(.stats, c("mean_ci", "mean_pval", "median_ci", "quantiles"))) {
|
||
| 96 | -+ | |||
| 521 | +25x |
- #' * `median_ci`: The CI for the median of `x` (from [stat_median_ci()]).+ if (!i %in% names(.labels) || .labels[[i]] == default_labels[[i]]) {
|
||
| 97 | -+ | |||
| 522 | +25x |
- #' * `quantiles`: Two sample quantiles of `x` (from [stats::quantile()]).+ .labels[[i]] <- attr(x_stats[[i]], "label") |
||
| 98 | +523 |
- #' * `iqr`: The [stats::IQR()] of `x`.+ } |
||
| 99 | +524 |
- #' * `range`: The [range_noinf()] of `x`.+ } |
||
| 100 | +525 |
- #' * `min`: The [max()] of `x`.+ } |
||
| 101 | +526 |
- #' * `max`: The [min()] of `x`.+ |
||
| 102 | -+ | |||
| 527 | +293x |
- #' * `median_range`: The [median()] and [range_noinf()] of `x`.+ if (is.factor(x) || is.character(x)) {
|
||
| 103 | +528 |
- #' * `cv`: The coefficient of variation of `x`, i.e.: ([stats::sd()] / [mean()] * 100).+ # Ungroup statistics with values for each level of x |
||
| 104 | -+ | |||
| 529 | +224x |
- #' * `geom_mean`: The geometric mean of `x`, i.e.: (`exp(mean(log(x)))`).+ x_ungrp <- ungroup_stats(x_stats, .formats, .labels, .indent_mods) |
||
| 105 | -+ | |||
| 530 | +224x |
- #' * `geom_cv`: The geometric coefficient of variation of `x`, i.e.: (`sqrt(exp(sd(log(x)) ^ 2) - 1) * 100`).+ x_stats <- x_ungrp[["x"]] |
||
| 106 | -+ | |||
| 531 | +224x |
- #'+ .formats <- x_ungrp[[".formats"]] |
||
| 107 | -+ | |||
| 532 | +224x |
- #' @note+ .labels <- gsub("fill-na-level", "NA", x_ungrp[[".labels"]])
|
||
| 108 | -+ | |||
| 533 | +224x |
- #' * If `x` is an empty vector, `NA` is returned. This is the expected feature so as to return `rcell` content in+ .indent_mods <- x_ungrp[[".indent_mods"]] |
||
| 109 | +534 |
- #' `rtables` when the intersection of a column and a row delimits an empty data selection.+ } |
||
| 110 | +535 |
- #' * When the `mean` function is applied to an empty vector, `NA` will be returned instead of `NaN`, the latter+ |
||
| 111 | +536 |
- #' being standard behavior in R.+ # auto formats handling |
||
| 112 | -+ | |||
| 537 | +293x |
- #'+ fmt_is_auto <- vapply(.formats, function(ii) is.character(ii) && ii == "auto", logical(1)) |
||
| 113 | -+ | |||
| 538 | +293x |
- #' @method s_summary numeric+ if (any(fmt_is_auto)) {
|
||
| 114 | -+ | |||
| 539 | +1x |
- #'+ res_l_auto <- x_stats[fmt_is_auto] |
||
| 115 | -+ | |||
| 540 | +1x |
- #' @examples+ tmp_dt_var <- .df_row[[.var]] # xxx this can be extended for the WHOLE data or single facets |
||
| 116 | -+ | |||
| 541 | +1x |
- #' # `s_summary.numeric`+ .formats[fmt_is_auto] <- lapply(seq_along(res_l_auto), function(rla) {
|
||
| 117 | -+ | |||
| 542 | +2x |
- #'+ format_auto(tmp_dt_var, names(res_l_auto)[rla]) |
||
| 118 | +543 |
- #' ## Basic usage: empty numeric returns NA-filled items.+ }) |
||
| 119 | +544 |
- #' s_summary(numeric())+ } |
||
| 120 | +545 |
- #'+ |
||
| 121 | -+ | |||
| 546 | +293x |
- #' ## Management of NA values.+ in_rows( |
||
| 122 | -+ | |||
| 547 | +293x |
- #' x <- c(NA_real_, 1)+ .list = x_stats, |
||
| 123 | -+ | |||
| 548 | +293x |
- #' s_summary(x, na.rm = TRUE)+ .formats = .formats, |
||
| 124 | -+ | |||
| 549 | +293x |
- #' s_summary(x, na.rm = FALSE)+ .names = .labels, |
||
| 125 | -+ | |||
| 550 | +293x |
- #'+ .labels = .labels, |
||
| 126 | -+ | |||
| 551 | +293x |
- #' x <- c(NA_real_, 1, 2)+ .indent_mods = .indent_mods, |
||
| 127 | -+ | |||
| 552 | +293x |
- #' s_summary(x, stats = NULL)+ .format_na_strs = na_str |
||
| 128 | +553 |
- #'+ ) |
||
| 129 | +554 |
- #' ## Benefits in `rtables` contructions:+ } |
||
| 130 | +555 |
- #' require(rtables)+ |
||
| 131 | +556 |
- #' dta_test <- data.frame(+ #' Constructor Function for [analyze_vars()] and [summarize_colvars()] |
||
| 132 | +557 |
- #' Group = rep(LETTERS[1:3], each = 2),+ #' |
||
| 133 | +558 |
- #' sub_group = rep(letters[1:2], each = 3),+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 134 | +559 |
- #' x = 1:6+ #' |
||
| 135 | +560 |
- #' )+ #' Constructor function which creates a combined formatted analysis function. |
||
| 136 | +561 |
#' |
||
| 137 | +562 |
- #' ## The summary obtained in with `rtables`:+ #' @inheritParams argument_convention |
||
| 138 | +563 |
- #' basic_table() %>%+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 139 | +564 |
- #' split_cols_by(var = "Group") %>%+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
||
| 140 | +565 |
- #' split_rows_by(var = "sub_group") %>%+ #' for that statistic's row label. |
||
| 141 | +566 |
- #' analyze(vars = "x", afun = s_summary) %>%+ #' |
||
| 142 | +567 |
- #' build_table(df = dta_test)+ #' @return Combined formatted analysis function for use in [analyze_vars()]. |
||
| 143 | +568 |
#' |
||
| 144 | +569 |
- #' ## By comparison with `lapply`:+ #' @note This function has been deprecated in favor of direct implementation of `a_summary()`. |
||
| 145 | +570 |
- #' X <- split(dta_test, f = with(dta_test, interaction(Group, sub_group)))+ #' |
||
| 146 | +571 |
- #' lapply(X, function(x) s_summary(x$x))+ #' @seealso [analyze_vars()] |
||
| 147 | +572 |
#' |
||
| 148 | +573 |
#' @export |
||
| 149 | +574 |
- s_summary.numeric <- function(x,+ create_afun_summary <- function(.stats, .formats, .labels, .indent_mods) {
|
||
| 150 | -+ | |||
| 575 | +1x |
- na.rm = TRUE, # nolint+ lifecycle::deprecate_warn( |
||
| 151 | -+ | |||
| 576 | +1x |
- denom,+ "0.8.5.9010", |
||
| 152 | -+ | |||
| 577 | +1x |
- .N_row, # nolint+ "create_afun_summary()", |
||
| 153 | -+ | |||
| 578 | +1x |
- .N_col, # nolint+ details = "Please use a_summary() directly instead." |
||
| 154 | +579 |
- .var,+ )+ |
+ ||
| 580 | +1x | +
+ function(x,+ |
+ ||
| 581 | +1x | +
+ .ref_group,+ |
+ ||
| 582 | +1x | +
+ .in_ref_col, |
||
| 155 | +583 |
- control = control_analyze_vars(),+ ...,+ |
+ ||
| 584 | +1x | +
+ .var) {
+ |
+ ||
| 585 | +18x | +
+ a_summary(x,+ |
+ ||
| 586 | +18x | +
+ .stats = .stats,+ |
+ ||
| 587 | +18x | +
+ .formats = .formats, |
||
| 156 | -+ | |||
| 588 | +18x |
- ...) {
+ .labels = .labels, |
||
| 157 | -295x | +589 | +18x |
- checkmate::assert_numeric(x)+ .indent_mods = .indent_mods, |
| 158 | -+ | |||
| 590 | +18x |
-
+ .ref_group = .ref_group, |
||
| 159 | -295x | +591 | +18x |
- if (na.rm) {
+ .in_ref_col = .in_ref_col, |
| 160 | -294x | +592 | +18x |
- x <- x[!is.na(x)]+ .var = .var, ... |
| 161 | +593 |
- }+ ) |
||
| 162 | +594 |
-
+ } |
||
| 163 | -295x | +|||
| 595 | +
- y <- list()+ } |
|||
| 164 | +596 | |||
| 165 | -295x | +|||
| 597 | +
- y$n <- c("n" = length(x))
+ #' @describeIn analyze_variables Layout-creating function which can take statistics function arguments |
|||
| 166 | +598 |
-
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 167 | -295x | +|||
| 599 | +
- y$sum <- c("sum" = ifelse(length(x) == 0, NA_real_, sum(x, na.rm = FALSE)))
+ #' |
|||
| 168 | +600 |
-
+ #' @param ... arguments passed to `s_summary()`. |
||
| 169 | -295x | +|||
| 601 | +
- y$mean <- c("mean" = ifelse(length(x) == 0, NA_real_, mean(x, na.rm = FALSE)))
+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector |
|||
| 170 | +602 |
-
+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
||
| 171 | -295x | +|||
| 603 | +
- y$sd <- c("sd" = stats::sd(x, na.rm = FALSE))
+ #' for that statistic's row label. |
|||
| 172 | +604 |
-
+ #' |
||
| 173 | -295x | +|||
| 605 | +
- y$se <- c("se" = stats::sd(x, na.rm = FALSE) / sqrt(length(stats::na.omit(x))))
+ #' @details |
|||
| 174 | +606 |
-
+ #' It is possible to use `"auto"` for `analyze_vars` on a subset of methods. This uses [format_auto()] to |
||
| 175 | -295x | +|||
| 607 | +
- y$mean_sd <- c(y$mean, "sd" = stats::sd(x, na.rm = FALSE))+ #' determine automatically the number of digits from the analyzed variable (`.vars`), but only for the |
|||
| 176 | +608 |
-
+ #' current row data (`.df_row[[.var]]`, see `?rtables::additional_fun_params`), and not for the whole |
||
| 177 | -295x | +|||
| 609 | +
- y$mean_se <- c(y$mean, y$se)+ #' data. Also no column split is considered. |
|||
| 178 | +610 |
-
+ #' |
||
| 179 | -295x | +|||
| 611 | +
- mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE)+ #' @return |
|||
| 180 | -295x | +|||
| 612 | +
- y$mean_ci <- formatters::with_label(mean_ci, paste("Mean", f_conf_level(control$conf_level)))
+ #' * `analyze_vars()` returns a layout object suitable for passing to further layouting functions, |
|||
| 181 | +613 |
-
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 182 | -295x | +|||
| 614 | +
- mean_sei <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE) / sqrt(y$n)+ #' the statistics from `s_summary()` to the table layout. |
|||
| 183 | -295x | +|||
| 615 | +
- names(mean_sei) <- c("mean_sei_lwr", "mean_sei_upr")
+ #' |
|||
| 184 | -295x | +|||
| 616 | +
- y$mean_sei <- formatters::with_label(mean_sei, "Mean -/+ 1xSE")+ #' @examples |
|||
| 185 | +617 |
-
+ #' ## Fabricated dataset. |
||
| 186 | -295x | +|||
| 618 | +
- mean_sdi <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE)+ #' dta_test <- data.frame( |
|||
| 187 | -295x | +|||
| 619 | +
- names(mean_sdi) <- c("mean_sdi_lwr", "mean_sdi_upr")
+ #' USUBJID = rep(1:6, each = 3), |
|||
| 188 | -295x | +|||
| 620 | +
- y$mean_sdi <- formatters::with_label(mean_sdi, "Mean -/+ 1xSD")+ #' PARAMCD = rep("lab", 6 * 3),
|
|||
| 189 | +621 |
-
+ #' AVISIT = rep(paste0("V", 1:3), 6),
|
||
| 190 | -295x | +|||
| 622 | +
- mean_pval <- stat_mean_pval(x, test_mean = control$test_mean, na.rm = FALSE, n_min = 2)+ #' ARM = rep(LETTERS[1:3], rep(6, 3)), |
|||
| 191 | -295x | +|||
| 623 | +
- y$mean_pval <- formatters::with_label(mean_pval, paste("Mean", f_pval(control$test_mean)))
+ #' AVAL = c(9:1, rep(NA, 9)) |
|||
| 192 | +624 |
-
+ #' ) |
||
| 193 | -295x | +|||
| 625 | +
- y$median <- c("median" = stats::median(x, na.rm = FALSE))
+ #' |
|||
| 194 | +626 |
-
+ #' # `analyze_vars()` in `rtables` pipelines |
||
| 195 | -295x | +|||
| 627 | +
- y$mad <- c("mad" = stats::median(x - y$median, na.rm = FALSE))
+ #' ## Default output within a `rtables` pipeline. |
|||
| 196 | +628 |
-
+ #' l <- basic_table() %>% |
||
| 197 | -295x | +|||
| 629 | +
- median_ci <- stat_median_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE)+ #' split_cols_by(var = "ARM") %>% |
|||
| 198 | -295x | +|||
| 630 | +
- y$median_ci <- formatters::with_label(median_ci, paste("Median", f_conf_level(control$conf_level)))
+ #' split_rows_by(var = "AVISIT") %>% |
|||
| 199 | +631 |
-
+ #' analyze_vars(vars = "AVAL") |
||
| 200 | -295x | +|||
| 632 | +
- q <- control$quantiles+ #' |
|||
| 201 | -295x | +|||
| 633 | +
- if (any(is.na(x))) {
+ #' build_table(l, df = dta_test) |
|||
| 202 | -1x | +|||
| 634 | +
- qnts <- rep(NA_real_, length(q))+ #' |
|||
| 203 | +635 |
- } else {
+ #' ## Select and format statistics output. |
||
| 204 | -294x | +|||
| 636 | +
- qnts <- stats::quantile(x, probs = q, type = control$quantile_type, na.rm = FALSE)+ #' l <- basic_table() %>% |
|||
| 205 | +637 |
- }+ #' split_cols_by(var = "ARM") %>% |
||
| 206 | -295x | +|||
| 638 | +
- names(qnts) <- paste("quantile", q, sep = "_")
+ #' split_rows_by(var = "AVISIT") %>% |
|||
| 207 | -295x | +|||
| 639 | +
- y$quantiles <- formatters::with_label(qnts, paste0(paste(paste0(q * 100, "%"), collapse = " and "), "-ile"))+ #' analyze_vars( |
|||
| 208 | +640 |
-
+ #' vars = "AVAL", |
||
| 209 | -295x | +|||
| 641 | +
- y$iqr <- c("iqr" = ifelse(
+ #' .stats = c("n", "mean_sd", "quantiles"),
|
|||
| 210 | -295x | +|||
| 642 | +
- any(is.na(x)),+ #' .formats = c("mean_sd" = "xx.x, xx.x"),
|
|||
| 211 | -295x | +|||
| 643 | +
- NA_real_,+ #' .labels = c(n = "n", mean_sd = "Mean, SD", quantiles = c("Q1 - Q3"))
|
|||
| 212 | -295x | +|||
| 644 | +
- stats::IQR(x, na.rm = FALSE, type = control$quantile_type)+ #' ) |
|||
| 213 | +645 |
- ))+ #' |
||
| 214 | +646 |
-
+ #' build_table(l, df = dta_test) |
||
| 215 | -295x | +|||
| 647 | +
- y$range <- stats::setNames(range_noinf(x, na.rm = FALSE), c("min", "max"))
+ #' |
|||
| 216 | -295x | +|||
| 648 | +
- y$min <- y$range[1]+ #' ## Use arguments interpreted by `s_summary`. |
|||
| 217 | -295x | +|||
| 649 | +
- y$max <- y$range[2]+ #' l <- basic_table() %>% |
|||
| 218 | +650 |
-
+ #' split_cols_by(var = "ARM") %>% |
||
| 219 | -295x | +|||
| 651 | +
- y$median_range <- formatters::with_label(c(y$median, y$range), "Median (Min - Max)")+ #' split_rows_by(var = "AVISIT") %>% |
|||
| 220 | +652 |
-
+ #' analyze_vars(vars = "AVAL", na.rm = FALSE) |
||
| 221 | -295x | +|||
| 653 | +
- y$cv <- c("cv" = unname(y$sd) / unname(y$mean) * 100)
+ #' |
|||
| 222 | +654 |
-
+ #' build_table(l, df = dta_test) |
||
| 223 | +655 |
- # Convert negative values to NA for log calculation.+ #' |
||
| 224 | -295x | +|||
| 656 | +
- x_no_negative_vals <- x+ #' ## Handle `NA` levels first when summarizing factors. |
|||
| 225 | -295x | +|||
| 657 | +
- x_no_negative_vals[x_no_negative_vals <= 0] <- NA+ #' dta_test$AVISIT <- NA_character_ |
|||
| 226 | -295x | +|||
| 658 | +
- y$geom_mean <- c("geom_mean" = exp(mean(log(x_no_negative_vals), na.rm = FALSE)))
+ #' dta_test <- df_explicit_na(dta_test) |
|||
| 227 | -295x | +|||
| 659 | +
- geom_mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE, geom_mean = TRUE)+ #' l <- basic_table() %>% |
|||
| 228 | -295x | +|||
| 660 | +
- y$geom_mean_ci <- formatters::with_label(geom_mean_ci, paste("Geometric Mean", f_conf_level(control$conf_level)))
+ #' split_cols_by(var = "ARM") %>% |
|||
| 229 | +661 |
-
+ #' analyze_vars(vars = "AVISIT", na.rm = FALSE) |
||
| 230 | -295x | +|||
| 662 | +
- y$geom_cv <- c("geom_cv" = sqrt(exp(stats::sd(log(x_no_negative_vals), na.rm = FALSE) ^ 2) - 1) * 100) # styler: off
+ #' |
|||
| 231 | +663 |
-
+ #' build_table(l, df = dta_test) |
||
| 232 | -295x | +|||
| 664 | +
- y+ #' |
|||
| 233 | +665 |
- }+ #' # auto format |
||
| 234 | +666 |
-
+ #' dt <- data.frame("VAR" = c(0.001, 0.2, 0.0011000, 3, 4))
|
||
| 235 | +667 |
- #' @describeIn analyze_variables Method for `factor` class.+ #' basic_table() %>% |
||
| 236 | +668 |
- #'+ #' analyze_vars( |
||
| 237 | +669 |
- #' @param denom (`string`)\cr choice of denominator for factor proportions. Options are:+ #' vars = "VAR", |
||
| 238 | +670 |
- #' * `n`: number of values in this row and column intersection.+ #' .stats = c("n", "mean", "mean_sd", "range"),
|
||
| 239 | +671 |
- #' * `N_row`: total number of values in this row across columns.+ #' .formats = c("mean_sd" = "auto", "range" = "auto")
|
||
| 240 | +672 |
- #' * `N_col`: total number of values in this column across rows.+ #' ) %>% |
||
| 241 | +673 |
- #'+ #' build_table(dt) |
||
| 242 | +674 |
- #' @return+ #' |
||
| 243 | +675 |
- #' * If `x` is of class `factor` or converted from `character`, returns a `list` with named `numeric` items:+ #' @export analyze_vars summarize_vars |
||
| 244 | +676 |
- #' * `n`: The [length()] of `x`.+ analyze_vars <- function(lyt, |
||
| 245 | +677 |
- #' * `count`: A list with the number of cases for each level of the factor `x`.+ vars, |
||
| 246 | +678 |
- #' * `count_fraction`: Similar to `count` but also includes the proportion of cases for each level of the+ var_labels = vars, |
||
| 247 | +679 |
- #' factor `x` relative to the denominator, or `NA` if the denominator is zero.+ na_level = lifecycle::deprecated(), |
||
| 248 | +680 |
- #'+ na_str = NA_character_, |
||
| 249 | +681 |
- #' @note+ nested = TRUE, |
||
| 250 | +682 |
- #' * If `x` is an empty `factor`, a list is still returned for `counts` with one element+ ..., |
||
| 251 | +683 |
- #' per factor level. If there are no levels in `x`, the function fails.+ na.rm = TRUE, # nolint |
||
| 252 | +684 |
- #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values+ show_labels = "default", |
||
| 253 | +685 |
- #' set `na.rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit+ table_names = vars, |
||
| 254 | +686 |
- #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the+ section_div = NA_character_, |
||
| 255 | +687 |
- #' default `na_level` (`"<Missing>"`) will also be excluded when `na.rm` is set to `TRUE`.+ .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
|
||
| 256 | +688 |
- #'+ .formats = NULL, |
||
| 257 | +689 |
- #' @method s_summary factor+ .labels = NULL, |
||
| 258 | +690 |
- #'+ .indent_mods = NULL) {
|
||
| 259 | -+ | |||
| 691 | +20x |
- #' @examples+ if (lifecycle::is_present(na_level)) {
|
||
| 260 | -+ | |||
| 692 | +! |
- #' # `s_summary.factor`+ lifecycle::deprecate_warn("0.9.1", "analyze_vars(na_level)", "analyze_vars(na_str)")
|
||
| 261 | -+ | |||
| 693 | +! |
- #'+ na_str <- na_level |
||
| 262 | +694 |
- #' ## Basic usage:+ } |
||
| 263 | +695 |
- #' s_summary(factor(c("a", "a", "b", "c", "a")))
+
|
||
| 264 | -+ | |||
| 696 | +20x |
- #' # Empty factor returns NA-filled items.+ extra_args <- list(.stats = .stats, na.rm = na.rm, na_str = na_str, ...) |
||
| 265 | -+ | |||
| 697 | +2x |
- #' s_summary(factor(levels = c("a", "b", "c")))
+ if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
||
| 266 | -+ | |||
| 698 | +! |
- #'+ if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
||
| 267 | -+ | |||
| 699 | +! |
- #' ## Management of NA values.+ if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
||
| 268 | +700 |
- #' x <- factor(c(NA, "Female"))+ |
||
| 269 | -+ | |||
| 701 | +20x |
- #' x <- explicit_na(x)+ analyze( |
||
| 270 | -+ | |||
| 702 | +20x |
- #' s_summary(x, na.rm = TRUE)+ lyt = lyt, |
||
| 271 | -+ | |||
| 703 | +20x |
- #' s_summary(x, na.rm = FALSE)+ vars = vars, |
||
| 272 | -+ | |||
| 704 | +20x |
- #'+ var_labels = var_labels, |
||
| 273 | -+ | |||
| 705 | +20x |
- #' ## Different denominators.+ afun = a_summary, |
||
| 274 | -+ | |||
| 706 | +20x |
- #' x <- factor(c("a", "a", "b", "c", "a"))
+ na_str = na_str, |
||
| 275 | -+ | |||
| 707 | +20x |
- #' s_summary(x, denom = "N_row", .N_row = 10L)+ nested = nested, |
||
| 276 | -+ | |||
| 708 | +20x |
- #' s_summary(x, denom = "N_col", .N_col = 20L)+ extra_args = extra_args, |
||
| 277 | -+ | |||
| 709 | +20x |
- #'+ inclNAs = TRUE, |
||
| 278 | -+ | |||
| 710 | +20x |
- #' @export+ show_labels = show_labels, |
||
| 279 | -+ | |||
| 711 | +20x |
- s_summary.factor <- function(x,+ table_names = table_names, |
||
| 280 | -+ | |||
| 712 | +20x |
- na.rm = TRUE, # nolint+ section_div = section_div |
||
| 281 | +713 |
- denom = c("n", "N_row", "N_col"),
+ ) |
||
| 282 | +714 |
- .N_row, # nolint+ } |
||
| 283 | +715 |
- .N_col, # nolint+ #' @describeIn analyze_variables `r lifecycle::badge("deprecated")` Use `analyze_vars` instead.
|
||
| 284 | +716 |
- ...) {
+ summarize_vars <- function(...) {
|
||
| 285 | -274x | +|||
| 717 | +! |
- assert_valid_factor(x)+ lifecycle::deprecate_warn(when = "0.8.5.9010", "summarize_vars()", "analyze_vars()") |
||
| 286 | -271x | +|||
| 718 | +! |
- denom <- match.arg(denom)+ analyze_vars(...) |
||
| 287 | +719 |
-
+ } |
||
| 288 | -271x | +
| 1 | +
- if (na.rm) {
+ #' Defaults for statistical method names and their associated formats & labels |
|||
| 289 | -267x | +|||
| 2 | +
- x <- x[!is.na(x)] %>% fct_discard("<Missing>")
+ #' |
|||
| 290 | +3 |
- } else {
+ #' @description `r lifecycle::badge("experimental")`
|
||
| 291 | -4x | +|||
| 4 | +
- x <- x %>% explicit_na(label = "NA")+ #' |
|||
| 292 | +5 |
- }+ #' Utility functions to get valid statistic methods for different method groups |
||
| 293 | +6 |
-
+ #' (`.stats`) and their associated formats (`.formats`) and labels (`.labels`). This utility |
||
| 294 | -271x | +|||
| 7 | +
- y <- list()+ #' is used across `tern`, but some of its working principles can be seen in [analyze_vars()]. |
|||
| 295 | +8 |
-
+ #' See notes to understand why this is experimental. |
||
| 296 | -271x | +|||
| 9 | +
- y$n <- length(x)+ #' |
|||
| 297 | +10 |
-
+ #' @param stats (`character`)\cr statistical methods to get defaults formats or labels for. |
||
| 298 | -271x | +|||
| 11 | +
- y$count <- as.list(table(x, useNA = "ifany"))+ #' |
|||
| 299 | -271x | +|||
| 12 | +
- dn <- switch(denom,+ #' @details |
|||
| 300 | -271x | +|||
| 13 | +
- n = length(x),+ #' Current choices for `type` are `counts` and `numeric` for [analyze_vars()] and affect `get_stats()`. |
|||
| 301 | -271x | +|||
| 14 | +
- N_row = .N_row,+ #' |
|||
| 302 | -271x | +|||
| 15 | +
- N_col = .N_col+ #' @note |
|||
| 303 | +16 |
- )+ #' These defaults are experimental because we use the names of functions to retrieve the default |
||
| 304 | -271x | +|||
| 17 | +
- y$count_fraction <- lapply(+ #' statistics. This should be generalized in groups of methods according to more reasonable groupings. |
|||
| 305 | -271x | +|||
| 18 | +
- y$count,+ #' |
|||
| 306 | -271x | +|||
| 19 | +
- function(x) {
+ #' @name default_stats_formats_labels |
|||
| 307 | -2089x | +|||
| 20 | +
- c(x, ifelse(dn > 0, x / dn, 0))+ NULL |
|||
| 308 | +21 |
- }+ |
||
| 309 | +22 |
- )+ #' @describeIn default_stats_formats_labels Get defaults statistical methods for different |
||
| 310 | +23 |
-
+ #' groups of methods. |
||
| 311 | -271x | +|||
| 24 | +
- y$n_blq <- sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", x))
+ #' |
|||
| 312 | +25 |
-
+ #' @param method_groups (`character`)\cr indicates the group of statistical methods that |
||
| 313 | -271x | +|||
| 26 | +
- y+ #' we need the defaults from. A character vector can be used to collect more than one group of statistical |
|||
| 314 | +27 |
- }+ #' methods. |
||
| 315 | +28 |
-
+ #' @param stats_in (`character`)\cr desired stats to be picked out from the selected method group. |
||
| 316 | +29 |
- #' @describeIn analyze_variables Method for `character` class. This makes an automatic+ #' @param add_pval (`flag`)\cr should `"pval"` or `"pval_counts"` (if `method_groups` contains |
||
| 317 | +30 |
- #' conversion to factor (with a warning) and then forwards to the method for factors.+ #' `"analyze_vars_counts"`) be added to the statistical methods? |
||
| 318 | +31 |
#' |
||
| 319 | +32 |
- #' @param verbose (`logical`)\cr Defaults to `TRUE`, which prints out warnings and messages. It is mainly used+ #' @return |
||
| 320 | +33 |
- #' to print out information about factor casting.+ #' * `get_stats()` returns a character vector with all default statistical methods. |
||
| 321 | +34 |
#' |
||
| 322 | +35 |
- #' @note+ #' @examples |
||
| 323 | +36 |
- #' * Automatic conversion of character to factor does not guarantee that the table+ #' # analyze_vars is numeric |
||
| 324 | +37 |
- #' can be generated correctly. In particular for sparse tables this very likely can fail.+ #' num_stats <- get_stats("analyze_vars_numeric") # also the default
|
||
| 325 | +38 |
- #' It is therefore better to always pre-process the dataset such that factors are manually+ #' |
||
| 326 | +39 | ++ |
+ #' # Other type+ |
+ |
| 40 |
- #' created from character variables before passing the dataset to [rtables::build_table()].+ #' cnt_stats <- get_stats("analyze_vars_counts")
|
|||
| 327 | +41 |
#' |
||
| 328 | +42 |
- #' @method s_summary character+ #' # Weirdly taking the pval from count_occurrences |
||
| 329 | +43 |
- #'+ #' only_pval <- get_stats("count_occurrences", add_pval = TRUE, stats_in = "pval")
|
||
| 330 | +44 |
- #' @examples+ #' |
||
| 331 | +45 |
- #' # `s_summary.character`+ #' # All count_occurrences |
||
| 332 | +46 |
- #'+ #' all_cnt_occ <- get_stats("count_occurrences")
|
||
| 333 | +47 |
- #' ## Basic usage:+ #' |
||
| 334 | +48 |
- #' s_summary(c("a", "a", "b", "c", "a"), .var = "x", verbose = FALSE)
+ #' # Multiple |
||
| 335 | +49 |
- #' s_summary(c("a", "a", "b", "c", "a", ""), .var = "x", na.rm = FALSE, verbose = FALSE)
+ #' get_stats(c("count_occurrences", "analyze_vars_counts"))
|
||
| 336 | +50 |
#' |
||
| 337 | +51 |
#' @export |
||
| 338 | +52 |
-
+ get_stats <- function(method_groups = "analyze_vars_numeric", stats_in = NULL, add_pval = FALSE) {
|
||
| 339 | -+ | |||
| 53 | +321x |
- s_summary.character <- function(x,+ checkmate::assert_character(method_groups) |
||
| 340 | -+ | |||
| 54 | +321x |
- na.rm = TRUE, # nolint+ checkmate::assert_character(stats_in, null.ok = TRUE) |
||
| 341 | -+ | |||
| 55 | +321x |
- denom = c("n", "N_row", "N_col"),
+ checkmate::assert_flag(add_pval) |
||
| 342 | +56 |
- .N_row, # nolint+ |
||
| 343 | +57 |
- .N_col, # nolint+ # Default is still numeric |
||
| 344 | -+ | |||
| 58 | +321x |
- .var,+ if (any(method_groups == "analyze_vars")) {
+ |
+ ||
| 59 | +2x | +
+ method_groups[method_groups == "analyze_vars"] <- "analyze_vars_numeric" |
||
| 345 | +60 |
- verbose = TRUE,+ } |
||
| 346 | +61 |
- ...) {
+
|
||
| 347 | -6x | +62 | +321x |
- if (na.rm) {
+ type_tmp <- ifelse(any(grepl("counts", method_groups)), "counts", "numeric") # for pval checks
|
| 348 | -5x | +|||
| 63 | +
- y <- as_factor_keep_attributes(x, verbose = verbose)+ |
|||
| 349 | +64 |
- } else {
+ # Defaults for loop |
||
| 350 | -1x | +65 | +321x |
- y <- as_factor_keep_attributes(x, verbose = verbose, na_level = "NA")+ out <- NULL |
| 351 | +66 |
- }+ |
||
| 352 | +67 |
-
+ # Loop for multiple method groups |
||
| 353 | -6x | +68 | +321x |
- s_summary(+ for (mgi in method_groups) {
+ |
+
| 69 | ++ |
+ # Main switcher |
||
| 354 | -6x | +70 | +331x |
- x = y,+ out_tmp <- switch(mgi, |
| 355 | -6x | +71 | +331x |
- na.rm = na.rm,+ "count_occurrences" = c("count", "count_fraction_fixed_dp", "fraction"),
|
| 356 | -6x | +72 | +331x |
- denom = denom,+ "summarize_num_patients" = c("unique", "nonunique", "unique_count"),
|
| 357 | -6x | +73 | +331x |
- .N_row = .N_row,+ "analyze_vars_counts" = c("n", "count", "count_fraction", "n_blq"),
|
| 358 | -6x | +74 | +331x |
- .N_col = .N_col,+ "analyze_vars_numeric" = c( |
| 359 | -+ | |||
| 75 | +331x |
- ...+ "n", "sum", "mean", "sd", "se", "mean_sd", "mean_se", "mean_ci", "mean_sei", |
||
| 360 | -+ | |||
| 76 | +331x |
- )+ "mean_sdi", "mean_pval", "median", "mad", "median_ci", "quantiles", "iqr", |
||
| 361 | -+ | |||
| 77 | +331x |
- }+ "range", "min", "max", "median_range", "cv", "geom_mean", "geom_mean_ci", |
||
| 362 | -+ | |||
| 78 | +331x |
-
+ "geom_cv" |
||
| 363 | +79 |
- #' @describeIn analyze_variables Method for `logical` class.+ ), |
||
| 364 | -+ | |||
| 80 | +331x |
- #'+ stop( |
||
| 365 | -+ | |||
| 81 | +331x |
- #' @param denom (`string`)\cr choice of denominator for proportion. Options are:+ "The selected method group (", mgi, ") has no default statistical method."
|
||
| 366 | +82 |
- #' * `n`: number of values in this row and column intersection.+ ) |
||
| 367 | +83 |
- #' * `N_row`: total number of values in this row across columns.+ ) |
||
| 368 | -+ | |||
| 84 | +331x |
- #' * `N_col`: total number of values in this column across rows.+ out <- unique(c(out, out_tmp)) |
||
| 369 | +85 |
- #'+ } |
||
| 370 | +86 |
- #' @return+ |
||
| 371 | +87 |
- #' * If `x` is of class `logical`, returns a `list` with named `numeric` items:+ # If you added pval to the stats_in you certainly want it |
||
| 372 | -+ | |||
| 88 | +321x |
- #' * `n`: The [length()] of `x` (possibly after removing `NA`s).+ if (!is.null(stats_in) && any(grepl("^pval", stats_in))) {
|
||
| 373 | -+ | |||
| 89 | +21x |
- #' * `count`: Count of `TRUE` in `x`.+ stats_in_pval_value <- stats_in[grepl("^pval", stats_in)]
|
||
| 374 | +90 |
- #' * `count_fraction`: Count and proportion of `TRUE` in `x` relative to the denominator, or `NA` if the+ |
||
| 375 | +91 |
- #' denominator is zero. Note that `NA`s in `x` are never counted or leading to `NA` here.+ # Must be only one value between choices |
||
| 376 | -+ | |||
| 92 | +21x |
- #'+ checkmate::assert_choice(stats_in_pval_value, c("pval", "pval_counts"))
|
||
| 377 | +93 |
- #' @method s_summary logical+ |
||
| 378 | +94 |
- #'+ # Mismatch with counts and numeric |
||
| 379 | -+ | |||
| 95 | +20x |
- #' @examples+ if (any(grepl("counts", method_groups)) && stats_in_pval_value != "pval_counts" ||
|
||
| 380 | -+ | |||
| 96 | +20x |
- #' # `s_summary.logical`+ any(grepl("numeric", method_groups)) && stats_in_pval_value != "pval") {
|
||
| 381 | -+ | |||
| 97 | +2x |
- #'+ stop( |
||
| 382 | -+ | |||
| 98 | +2x |
- #' ## Basic usage:+ "Inserted p-value (", stats_in_pval_value, ") is not valid for type ",
|
||
| 383 | -+ | |||
| 99 | +2x |
- #' s_summary(c(TRUE, FALSE, TRUE, TRUE))+ type_tmp, ". Use ", paste(ifelse(stats_in_pval_value == "pval", "pval_counts", "pval")), |
||
| 384 | -+ | |||
| 100 | +2x |
- #'+ " instead." |
||
| 385 | +101 |
- #' ## Management of NA values.+ ) |
||
| 386 | +102 |
- #' x <- c(NA, TRUE, FALSE)+ } |
||
| 387 | +103 |
- #' s_summary(x, na.rm = TRUE)+ |
||
| 388 | +104 |
- #' s_summary(x, na.rm = FALSE)+ # Lets add it even if present (thanks to unique) |
||
| 389 | -+ | |||
| 105 | +18x |
- #'+ add_pval <- TRUE |
||
| 390 | +106 |
- #' ## Different denominators.+ } |
||
| 391 | +107 |
- #' x <- c(TRUE, FALSE, TRUE, TRUE)+ |
||
| 392 | +108 |
- #' s_summary(x, denom = "N_row", .N_row = 10L)+ # Mainly used in "analyze_vars" but it could be necessary elsewhere |
||
| 393 | -+ | |||
| 109 | +318x |
- #' s_summary(x, denom = "N_col", .N_col = 20L)+ if (isTRUE(add_pval)) {
|
||
| 394 | -+ | |||
| 110 | +22x |
- #'+ if (any(grepl("counts", method_groups))) {
|
||
| 395 | -+ | |||
| 111 | +10x |
- #' @export+ out <- unique(c(out, "pval_counts")) |
||
| 396 | +112 |
- s_summary.logical <- function(x,+ } else {
|
||
| 397 | -+ | |||
| 113 | +12x |
- na.rm = TRUE, # nolint+ out <- unique(c(out, "pval")) |
||
| 398 | +114 |
- denom = c("n", "N_row", "N_col"),
+ } |
||
| 399 | +115 |
- .N_row, # nolint+ } |
||
| 400 | +116 |
- .N_col, # nolint+ |
||
| 401 | +117 |
- ...) {
+ # Filtering for stats_in (character vector) |
||
| 402 | -115x | +118 | +318x |
- denom <- match.arg(denom)+ if (!is.null(stats_in)) {
|
| 403 | -113x | +119 | +304x |
- if (na.rm) x <- x[!is.na(x)]+ out <- intersect(stats_in, out) # It orders them too |
| 404 | -115x | +|||
| 120 | +
- y <- list()+ } |
|||
| 405 | -115x | +|||
| 121 | +
- y$n <- length(x)+ |
|||
| 406 | -115x | +|||
| 122 | +
- count <- sum(x, na.rm = TRUE)+ # If intersect did not find matches (and no pval?) -> error |
|||
| 407 | -115x | +123 | +318x |
- dn <- switch(denom,+ if (length(out) == 0) {
|
| 408 | -115x | +124 | +2x |
- n = length(x),+ stop( |
| 409 | -115x | +125 | +2x |
- N_row = .N_row,+ "The selected method group(s) (", paste0(method_groups, collapse = ", "), ")",
|
| 410 | -115x | +126 | +2x |
- N_col = .N_col+ " do not have the required default statistical methods:\n", |
| 411 | -+ | |||
| 127 | +2x |
- )+ paste0(stats_in, collapse = " ") |
||
| 412 | -115x | +|||
| 128 | +
- y$count <- count+ ) |
|||
| 413 | -115x | +|||
| 129 | +
- y$count_fraction <- c(count, ifelse(dn > 0, count / dn, NA))+ } |
|||
| 414 | -115x | +|||
| 130 | +
- y$n_blq <- 0L+ |
|||
| 415 | -115x | +131 | +316x |
- y+ out |
| 416 | +132 |
} |
||
| 417 | +133 | |||
| 418 | +134 |
- #' @describeIn analyze_variables Formatted analysis function which is used as `afun` in `analyze_vars()` and+ #' @describeIn default_stats_formats_labels Get formats from vector of statistical methods. If not |
||
| 419 | +135 |
- #' `compare_vars()` and as `cfun` in `summarize_colvars()`.+ #' present `NULL` is returned. |
||
| 420 | +136 |
#' |
||
| 421 | +137 |
- #' @param compare (`logical`)\cr Whether comparison statistics should be analyzed instead of summary statistics+ #' @param formats_in (named `vector`) \cr inserted formats to replace defaults. It can be a |
||
| 422 | +138 |
- #' (`compare = TRUE` adds `pval` statistic comparing against reference group).+ #' character vector from [formatters::list_valid_format_labels()] or a custom format function. |
||
| 423 | +139 |
#' |
||
| 424 | +140 |
#' @return |
||
| 425 | +141 |
- #' * `a_summary()` returns the corresponding list with formatted [rtables::CellValue()].+ #' * `get_formats_from_stats()` returns a named list of formats, they being a value from |
||
| 426 | +142 |
- #'+ #' [formatters::list_valid_format_labels()] or a custom function (e.g. [formatting_functions]). |
||
| 427 | +143 |
- #' @note+ #' |
||
| 428 | +144 |
- #' * To use for comparison (with additional p-value statistic), parameter `compare` must be set to `TRUE`.+ #' @note Formats in `tern` and `rtables` can be functions that take in the table cell value and |
||
| 429 | +145 |
- #' * Ensure that either all `NA` values are converted to an explicit `NA` level or all `NA` values are left as is.+ #' return a string. This is well documented in `vignette("custom_appearance", package = "rtables")`.
|
||
| 430 | +146 |
#' |
||
| 431 | +147 |
#' @examples |
||
| 432 | +148 |
- #' a_summary(factor(c("a", "a", "b", "c", "a")), .N_row = 10, .N_col = 10)
+ #' # Defaults formats |
||
| 433 | +149 |
- #' a_summary(+ #' get_formats_from_stats(num_stats) |
||
| 434 | +150 |
- #' factor(c("a", "a", "b", "c", "a")),
+ #' get_formats_from_stats(cnt_stats) |
||
| 435 | +151 |
- #' .ref_group = factor(c("a", "a", "b", "c")), compare = TRUE
+ #' get_formats_from_stats(only_pval) |
||
| 436 | +152 |
- #' )+ #' get_formats_from_stats(all_cnt_occ) |
||
| 437 | +153 |
#' |
||
| 438 | -- |
- #' a_summary(c("A", "B", "A", "C"), .var = "x", .N_col = 10, .N_row = 10, verbose = FALSE)
- |
- ||
| 439 | -- |
- #' a_summary(- |
- ||
| 440 | +154 |
- #' c("A", "B", "A", "C"),
+ #' # Addition of customs |
||
| 441 | +155 |
- #' .ref_group = c("B", "A", "C"), .var = "x", compare = TRUE, verbose = FALSE
+ #' get_formats_from_stats(all_cnt_occ, formats_in = c("fraction" = c("xx")))
|
||
| 442 | +156 |
- #' )+ #' get_formats_from_stats(all_cnt_occ, formats_in = list("fraction" = c("xx.xx", "xx")))
|
||
| 443 | +157 |
#' |
||
| 444 | -- |
- #' a_summary(c(TRUE, FALSE, FALSE, TRUE, TRUE), .N_row = 10, .N_col = 10)- |
- ||
| 445 | +158 |
- #' a_summary(+ #' @seealso [formatting_functions] |
||
| 446 | +159 |
- #' c(TRUE, FALSE, FALSE, TRUE, TRUE),+ #' |
||
| 447 | +160 |
- #' .ref_group = c(TRUE, FALSE), .in_ref_col = TRUE, compare = TRUE+ #' @export |
||
| 448 | +161 |
- #' )+ get_formats_from_stats <- function(stats, formats_in = NULL) {
|
||
| 449 | -+ | |||
| 162 | +322x |
- #'+ checkmate::assert_character(stats, min.len = 1) |
||
| 450 | +163 |
- #' a_summary(rnorm(10), .N_col = 10, .N_row = 20, .var = "bla")+ # It may be a list if there is a function in the formats |
||
| 451 | -+ | |||
| 164 | +322x |
- #' a_summary(rnorm(10, 5, 1), .ref_group = rnorm(20, -5, 1), .var = "bla", compare = TRUE)+ if (checkmate::test_list(formats_in, null.ok = TRUE)) {
|
||
| 452 | -+ | |||
| 165 | +279x |
- #'+ checkmate::assert_list(formats_in, null.ok = TRUE) |
||
| 453 | +166 |
-
+ # Or it may be a vector of characters |
||
| 454 | +167 |
- #' @export+ } else {
|
||
| 455 | -+ | |||
| 168 | +43x |
- a_summary <- function(x,+ checkmate::assert_character(formats_in, null.ok = TRUE) |
||
| 456 | +169 |
- .N_col, # nolint+ } |
||
| 457 | +170 |
- .N_row, # nolint+ |
||
| 458 | +171 |
- .var = NULL,+ # Extract global defaults |
||
| 459 | -+ | |||
| 172 | +322x |
- .df_row = NULL,+ which_fmt <- match(stats, names(tern_default_formats)) |
||
| 460 | +173 |
- .ref_group = NULL,+ |
||
| 461 | +174 |
- .in_ref_col = FALSE,+ # Select only needed formats from stats |
||
| 462 | -+ | |||
| 175 | +322x |
- compare = FALSE,+ ret <- vector("list", length = length(stats)) # Returning a list is simpler
|
||
| 463 | -+ | |||
| 176 | +322x |
- .stats = NULL,+ ret[!is.na(which_fmt)] <- tern_default_formats[which_fmt[!is.na(which_fmt)]] |
||
| 464 | +177 |
- .formats = NULL,+ |
||
| 465 | -+ | |||
| 178 | +322x |
- .labels = NULL,+ out <- setNames(ret, stats) |
||
| 466 | +179 |
- .indent_mods = NULL,+ |
||
| 467 | +180 |
- na.rm = TRUE, # nolint+ # Modify some with custom formats |
||
| 468 | -+ | |||
| 181 | +322x |
- na_level = NA_character_,+ if (!is.null(formats_in)) {
|
||
| 469 | +182 |
- ...) {
- |
- ||
| 470 | -293x | -
- if (is.numeric(x)) {
- |
- ||
| 471 | -68x | -
- type <- "numeric"+ # Stats is the main |
||
| 472 | -68x | +183 | +45x |
- if (!is.null(.stats) && any(grepl("^pval", .stats))) {
+ common_names <- intersect(names(out), names(formats_in)) |
| 473 | -9x | +184 | +45x |
- .stats[grepl("^pval", .stats)] <- "pval" # tmp fix xxx
+ out[common_names] <- formats_in[common_names] |
| 474 | +185 |
- }+ } |
||
| 475 | +186 |
- } else {
- |
- ||
| 476 | -225x | -
- type <- "counts"- |
- ||
| 477 | -225x | -
- if (!is.null(.stats) && any(grepl("^pval", .stats))) {
+
|
||
| 478 | -9x | +187 | +322x |
- .stats[grepl("^pval", .stats)] <- "pval_counts" # tmp fix xxx
+ out |
| 479 | +188 |
- }+ } |
||
| 480 | +189 |
- }+ |
||
| 481 | +190 |
-
+ #' @describeIn default_stats_formats_labels Get labels from vector of statistical methods. |
||
| 482 | +191 |
- # If one col has NA vals, must add NA row to other cols (using placeholder lvl `fill-na-level`)- |
- ||
| 483 | -! | -
- if (any(is.na(.df_row[[.var]])) && !any(is.na(x)) && !na.rm) levels(x) <- c(levels(x), "fill-na-level")+ #' |
||
| 484 | +192 |
-
+ #' @param labels_in (named `vector`) \cr inserted labels to replace defaults. |
||
| 485 | -293x | +|||
| 193 | +
- x_stats <- if (!compare) {
+ #' |
|||
| 486 | -274x | +|||
| 194 | +
- s_summary(x = x, .N_col = .N_col, .N_row = .N_row, na.rm = na.rm, ...)+ #' @return |
|||
| 487 | +195 |
- } else {
+ #' * `get_labels_from_stats()` returns a named character vector of default labels (if present |
||
| 488 | -19x | +|||
| 196 | +
- s_compare(+ #' otherwise `NULL`). |
|||
| 489 | -19x | +|||
| 197 | +
- x = x, .N_col = .N_col, .N_row = .N_row, na.rm = na.rm, .ref_group = .ref_group, .in_ref_col = .in_ref_col, ...+ #' |
|||
| 490 | +198 |
- )+ #' @examples |
||
| 491 | +199 |
- }+ #' # Defaults labels |
||
| 492 | +200 |
-
+ #' get_labels_from_stats(num_stats) |
||
| 493 | +201 |
- # Fill in with formatting defaults if needed+ #' get_labels_from_stats(cnt_stats) |
||
| 494 | -293x | +|||
| 202 | +
- met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ #' get_labels_from_stats(only_pval) |
|||
| 495 | -293x | +|||
| 203 | +
- .stats <- get_stats(met_grp, stats_in = .stats, add_pval = compare)+ #' get_labels_from_stats(all_cnt_occ) |
|||
| 496 | -293x | +|||
| 204 | +
- .formats <- get_formats_from_stats(.stats, .formats)+ #' |
|||
| 497 | -293x | +|||
| 205 | +
- .labels <- get_labels_from_stats(.stats, .labels)+ #' # Addition of customs |
|||
| 498 | +206 |
-
+ #' get_labels_from_stats(all_cnt_occ, labels_in = c("fraction" = "Fraction"))
|
||
| 499 | -293x | +|||
| 207 | +
- indent_mods_custom <- .indent_mods+ #' get_labels_from_stats(all_cnt_occ, labels_in = list("fraction" = c("Some more fractions")))
|
|||
| 500 | -293x | +|||
| 208 | +
- .indent_mods <- stats::setNames(rep(0L, length(.stats)), .stats)+ #' |
|||
| 501 | -293x | +|||
| 209 | +
- if (!is.null(indent_mods_custom)) {
+ #' @export |
|||
| 502 | -32x | +|||
| 210 | +
- if (is.null(names(indent_mods_custom)) && length(indent_mods_custom) == 1) {
+ get_labels_from_stats <- function(stats, labels_in = NULL) {
|
|||
| 503 | -2x | +211 | +375x |
- .indent_mods[names(.indent_mods)] <- indent_mods_custom+ checkmate::assert_character(stats, min.len = 1) |
| 504 | +212 |
- } else {
+ # It may be a list |
||
| 505 | -30x | +213 | +375x |
- .indent_mods[names(indent_mods_custom)] <- indent_mods_custom+ if (checkmate::test_list(labels_in, null.ok = TRUE)) {
|
| 506 | -+ | |||
| 214 | +324x |
- }+ checkmate::assert_list(labels_in, null.ok = TRUE) |
||
| 507 | +215 |
- }+ # Or it may be a vector of characters |
||
| 508 | +216 |
-
+ } else {
|
||
| 509 | -293x | -
- x_stats <- x_stats[.stats]- |
- ||
| 510 | -+ | 217 | +51x |
-
+ checkmate::assert_character(labels_in, null.ok = TRUE) |
| 511 | +218 |
- # Check for custom labels from control_analyze_vars+ } |
- ||
| 512 | -293x | +|||
| 219 | +
- if (is.numeric(x)) {
+
|
|||
| 513 | -68x | +220 | +375x |
- default_labels <- get_labels_from_stats(.stats)+ which_lbl <- match(stats, names(tern_default_labels)) |
| 514 | -68x | +|||
| 221 | +
- for (i in intersect(.stats, c("mean_ci", "mean_pval", "median_ci", "quantiles"))) {
+
|
|||
| 515 | -25x | +222 | +375x |
- if (!i %in% names(.labels) || .labels[[i]] == default_labels[[i]]) {
+ ret <- vector("character", length = length(stats)) # it needs to be a character vector
|
| 516 | -25x | +223 | +375x |
- .labels[[i]] <- attr(x_stats[[i]], "label")+ ret[!is.na(which_lbl)] <- tern_default_labels[which_lbl[!is.na(which_lbl)]] |
| 517 | +224 |
- }+ |
||
| 518 | -+ | |||
| 225 | +375x |
- }+ out <- setNames(ret, stats) |
||
| 519 | +226 |
- }+ |
||
| 520 | +227 |
-
+ # Modify some with custom labels |
||
| 521 | -293x | +228 | +375x |
- if (is.factor(x) || is.character(x)) {
+ if (!is.null(labels_in)) {
|
| 522 | +229 |
- # Ungroup statistics with values for each level of x+ # Stats is the main |
||
| 523 | -224x | +230 | +51x |
- x_ungrp <- ungroup_stats(x_stats, .formats, .labels, .indent_mods)+ common_names <- intersect(names(out), names(labels_in)) |
| 524 | -224x | +231 | +51x |
- x_stats <- x_ungrp[["x"]]+ out[common_names] <- labels_in[common_names] |
| 525 | -224x | +|||
| 232 | +
- .formats <- x_ungrp[[".formats"]]+ } |
|||
| 526 | -224x | +|||
| 233 | +
- .labels <- gsub("fill-na-level", "NA", x_ungrp[[".labels"]])
+
|
|||
| 527 | -224x | +234 | +375x |
- .indent_mods <- x_ungrp[[".indent_mods"]]+ out |
| 528 | +235 |
- }+ } |
||
| 529 | +236 | |||
| 530 | +237 |
- # auto formats handling+ #' @describeIn default_stats_formats_labels Named list of default formats for `tern`. |
||
| 531 | -293x | +|||
| 238 | +
- fmt_is_auto <- vapply(.formats, function(ii) is.character(ii) && ii == "auto", logical(1))+ #' @format |
|||
| 532 | -293x | +|||
| 239 | +
- if (any(fmt_is_auto)) {
+ #' * `tern_default_formats` is a list of available formats, named after their relevant |
|||
| 533 | -1x | +|||
| 240 | +
- res_l_auto <- x_stats[fmt_is_auto]+ #' statistic. |
|||
| 534 | -1x | +|||
| 241 | +
- tmp_dt_var <- .df_row[[.var]] # xxx this can be extended for the WHOLE data or single facets+ #' @export |
|||
| 535 | -1x | +|||
| 242 | +
- .formats[fmt_is_auto] <- lapply(seq_along(res_l_auto), function(rla) {
+ tern_default_formats <- c( |
|||
| 536 | -2x | +|||
| 243 | +
- format_auto(tmp_dt_var, names(res_l_auto)[rla])+ fraction = format_fraction_fixed_dp, |
|||
| 537 | +244 |
- })+ unique = format_count_fraction_fixed_dp, |
||
| 538 | +245 |
- }+ nonunique = "xx", |
||
| 539 | +246 |
-
+ unique_count = "xx", |
||
| 540 | -293x | +|||
| 247 | +
- in_rows(+ n = "xx.", |
|||
| 541 | -293x | +|||
| 248 | +
- .list = x_stats,+ count = "xx.", |
|||
| 542 | -293x | +|||
| 249 | +
- .formats = .formats,+ count_fraction = format_count_fraction, |
|||
| 543 | -293x | +|||
| 250 | +
- .names = .labels,+ count_fraction_fixed_dp = format_count_fraction_fixed_dp, |
|||
| 544 | -293x | +|||
| 251 | +
- .labels = .labels,+ n_blq = "xx.", |
|||
| 545 | -293x | +|||
| 252 | +
- .indent_mods = .indent_mods,+ sum = "xx.x", |
|||
| 546 | -293x | +|||
| 253 | +
- .format_na_strs = na_level+ mean = "xx.x", |
|||
| 547 | +254 |
- )+ sd = "xx.x", |
||
| 548 | +255 |
- }+ se = "xx.x", |
||
| 549 | +256 |
-
+ mean_sd = "xx.x (xx.x)", |
||
| 550 | +257 |
- #' Constructor Function for [analyze_vars()] and [summarize_colvars()]+ mean_se = "xx.x (xx.x)", |
||
| 551 | +258 |
- #'+ mean_ci = "(xx.xx, xx.xx)", |
||
| 552 | +259 |
- #' @description `r lifecycle::badge("deprecated")`
+ mean_sei = "(xx.xx, xx.xx)", |
||
| 553 | +260 |
- #'+ mean_sdi = "(xx.xx, xx.xx)", |
||
| 554 | +261 |
- #' Constructor function which creates a combined formatted analysis function.+ mean_pval = "xx.xx", |
||
| 555 | +262 |
- #'+ median = "xx.x", |
||
| 556 | +263 |
- #' @inheritParams argument_convention+ mad = "xx.x", |
||
| 557 | +264 |
- #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ median_ci = "(xx.xx, xx.xx)", |
||
| 558 | +265 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ quantiles = "xx.x - xx.x", |
||
| 559 | +266 |
- #' for that statistic's row label.+ iqr = "xx.x", |
||
| 560 | +267 |
- #'+ range = "xx.x - xx.x", |
||
| 561 | +268 |
- #' @return Combined formatted analysis function for use in [analyze_vars()].+ min = "xx.x", |
||
| 562 | +269 |
- #'+ max = "xx.x", |
||
| 563 | +270 |
- #' @note This function has been deprecated in favor of direct implementation of `a_summary()`.+ median_range = "xx.x (xx.x - xx.x)", |
||
| 564 | +271 |
- #'+ cv = "xx.x", |
||
| 565 | +272 |
- #' @seealso [analyze_vars()]+ geom_mean = "xx.x", |
||
| 566 | +273 |
- #'+ geom_mean_ci = "(xx.xx, xx.xx)", |
||
| 567 | +274 |
- #' @export+ geom_cv = "xx.x", |
||
| 568 | +275 |
- create_afun_summary <- function(.stats, .formats, .labels, .indent_mods) {
+ pval = "x.xxxx | (<0.0001)", |
||
| 569 | -1x | +|||
| 276 | +
- lifecycle::deprecate_warn(+ pval_counts = "x.xxxx | (<0.0001)" |
|||
| 570 | -1x | +|||
| 277 | +
- "0.8.5.9010",+ ) |
|||
| 571 | -1x | +|||
| 278 | +
- "create_afun_summary()",+ |
|||
| 572 | -1x | +|||
| 279 | +
- details = "Please use a_summary() directly instead."+ #' @describeIn default_stats_formats_labels `character` vector that contains default labels |
|||
| 573 | +280 |
- )+ #' for `tern`. |
||
| 574 | -1x | +|||
| 281 | +
- function(x,+ #' @format |
|||
| 575 | -1x | +|||
| 282 | +
- .ref_group,+ #' * `tern_default_labels` is a character vector of available labels, named after their relevant |
|||
| 576 | -1x | +|||
| 283 | +
- .in_ref_col,+ #' statistic. |
|||
| 577 | +284 |
- ...,+ #' @export |
||
| 578 | -1x | +|||
| 285 | +
- .var) {
+ tern_default_labels <- c( |
|||
| 579 | -18x | +|||
| 286 | +
- a_summary(x,+ # list of labels -> sorted? xxx it should be not relevant due to match |
|||
| 580 | -18x | +|||
| 287 | +
- .stats = .stats,+ unique = "Number of patients with at least one event", |
|||
| 581 | -18x | +|||
| 288 | +
- .formats = .formats,+ nonunique = "Number of events", |
|||
| 582 | -18x | +|||
| 289 | +
- .labels = .labels,+ n = "n", |
|||
| 583 | -18x | +|||
| 290 | +
- .indent_mods = .indent_mods,+ count = "count", |
|||
| 584 | -18x | +|||
| 291 | +
- .ref_group = .ref_group,+ count_fraction = "count_fraction", |
|||
| 585 | -18x | +|||
| 292 | +
- .in_ref_col = .in_ref_col,+ n_blq = "n_blq", |
|||
| 586 | -18x | +|||
| 293 | +
- .var = .var, ...+ sum = "Sum", |
|||
| 587 | +294 |
- )+ mean = "Mean", |
||
| 588 | +295 |
- }+ sd = "SD", |
||
| 589 | +296 |
- }+ se = "SE", |
||
| 590 | +297 |
-
+ mean_sd = "Mean (SD)", |
||
| 591 | +298 |
- #' @describeIn analyze_variables Layout-creating function which can take statistics function arguments+ mean_se = "Mean (SE)", |
||
| 592 | +299 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ mean_ci = "Mean 95% CI", |
||
| 593 | +300 |
- #'+ mean_sei = "Mean -/+ 1xSE", |
||
| 594 | +301 |
- #' @param ... arguments passed to `s_summary()`.+ mean_sdi = "Mean -/+ 1xSD", |
||
| 595 | +302 |
- #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ mean_pval = "Mean p-value (H0: mean = 0)", |
||
| 596 | +303 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ median = "Median", |
||
| 597 | +304 |
- #' for that statistic's row label.+ mad = "Median Absolute Deviation", |
||
| 598 | +305 |
- #'+ median_ci = "Median 95% CI", |
||
| 599 | +306 |
- #' @details+ quantiles = "25% and 75%-ile", |
||
| 600 | +307 |
- #' It is possible to use `"auto"` for `analyze_vars` on a subset of methods. This uses [format_auto()] to+ iqr = "IQR", |
||
| 601 | +308 |
- #' determine automatically the number of digits from the analyzed variable (`.vars`), but only for the+ range = "Min - Max", |
||
| 602 | +309 |
- #' current row data (`.df_row[[.var]]`, see `?rtables::additional_fun_params`), and not for the whole+ min = "Minimum", |
||
| 603 | +310 |
- #' data. Also no column split is considered.+ max = "Maximum", |
||
| 604 | +311 |
- #'+ median_range = "Median (Min - Max)", |
||
| 605 | +312 |
- #' @return+ cv = "CV (%)", |
||
| 606 | +313 |
- #' * `analyze_vars()` returns a layout object suitable for passing to further layouting functions,+ geom_mean = "Geometric Mean", |
||
| 607 | +314 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ geom_mean_ci = "Geometric Mean 95% CI", |
||
| 608 | +315 |
- #' the statistics from `s_summary()` to the table layout.+ geom_cv = "CV % Geometric Mean", |
||
| 609 | +316 |
- #'+ pval = "p-value (t-test)", # Default for numeric |
||
| 610 | +317 |
- #' @examples+ pval_counts = "p-value (chi-squared test)" # Default for counts |
||
| 611 | +318 |
- #' ## Fabricated dataset.+ ) |
||
| 612 | +319 |
- #' dta_test <- data.frame(+ |
||
| 613 | +320 |
- #' USUBJID = rep(1:6, each = 3),+ # To deprecate --------- |
||
| 614 | +321 |
- #' PARAMCD = rep("lab", 6 * 3),
+
|
||
| 615 | +322 |
- #' AVISIT = rep(paste0("V", 1:3), 6),
+ #' @describeIn default_stats_formats_labels Quick function to retrieve default formats for summary statistics: |
||
| 616 | +323 |
- #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ #' [analyze_vars()] and [analyze_vars_in_cols()] principally. |
||
| 617 | +324 |
- #' AVAL = c(9:1, rep(NA, 9))+ #' |
||
| 618 | +325 |
- #' )+ #' @param type (`flag`)\cr is it going to be `"numeric"` or `"counts"`? |
||
| 619 | +326 |
#' |
||
| 620 | +327 |
- #' # `analyze_vars()` in `rtables` pipelines+ #' @return |
||
| 621 | +328 |
- #' ## Default output within a `rtables` pipeline.+ #' * `summary_formats()` returns a named `vector` of default statistic formats for the given data type. |
||
| 622 | +329 |
- #' l <- basic_table() %>%+ #' |
||
| 623 | +330 |
- #' split_cols_by(var = "ARM") %>%+ #' @examples |
||
| 624 | +331 |
- #' split_rows_by(var = "AVISIT") %>%+ #' summary_formats() |
||
| 625 | +332 |
- #' analyze_vars(vars = "AVAL")+ #' summary_formats(type = "counts", include_pval = TRUE) |
||
| 626 | +333 |
#' |
||
| 627 | +334 |
- #' build_table(l, df = dta_test)+ #' @export |
||
| 628 | +335 |
- #'+ summary_formats <- function(type = "numeric", include_pval = FALSE) {
+ |
+ ||
| 336 | +2x | +
+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ |
+ ||
| 337 | +2x | +
+ get_formats_from_stats(get_stats(met_grp, add_pval = include_pval)) |
||
| 629 | +338 |
- #' ## Select and format statistics output.+ } |
||
| 630 | +339 |
- #' l <- basic_table() %>%+ |
||
| 631 | +340 |
- #' split_cols_by(var = "ARM") %>%+ #' @describeIn default_stats_formats_labels Quick function to retrieve default labels for summary statistics. |
||
| 632 | +341 |
- #' split_rows_by(var = "AVISIT") %>%+ #' Returns labels of descriptive statistics which are understood by `rtables`. Similar to `summary_formats` |
||
| 633 | +342 |
- #' analyze_vars(+ #' |
||
| 634 | +343 |
- #' vars = "AVAL",+ #' @param include_pval (`flag`)\cr deprecated parameter. Same as `add_pval`. |
||
| 635 | +344 |
- #' .stats = c("n", "mean_sd", "quantiles"),
+ #' @return |
||
| 636 | +345 |
- #' .formats = c("mean_sd" = "xx.x, xx.x"),
+ #' * `summary_labels` returns a named `vector` of default statistic labels for the given data type. |
||
| 637 | +346 |
- #' .labels = c(n = "n", mean_sd = "Mean, SD", quantiles = c("Q1 - Q3"))
+ #' |
||
| 638 | +347 |
- #' )+ #' @examples |
||
| 639 | +348 |
- #'+ #' summary_labels() |
||
| 640 | +349 |
- #' build_table(l, df = dta_test)+ #' summary_labels(type = "counts", include_pval = TRUE) |
||
| 641 | +350 |
#' |
||
| 642 | +351 |
- #' ## Use arguments interpreted by `s_summary`.+ #' @export |
||
| 643 | +352 |
- #' l <- basic_table() %>%+ summary_labels <- function(type = "numeric", include_pval = FALSE) {
+ |
+ ||
| 353 | +2x | +
+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ |
+ ||
| 354 | +2x | +
+ get_labels_from_stats(get_stats(met_grp, add_pval = include_pval)) |
||
| 644 | +355 |
- #' split_cols_by(var = "ARM") %>%+ } |
||
| 645 | +356 |
- #' split_rows_by(var = "AVISIT") %>%+ |
||
| 646 | +357 |
- #' analyze_vars(vars = "AVAL", na.rm = FALSE)+ #' @describeIn default_stats_formats_labels `r lifecycle::badge("deprecated")` Function to
|
||
| 647 | +358 |
- #'+ #' configure settings for default or custom summary statistics for a given data type. In |
||
| 648 | +359 |
- #' build_table(l, df = dta_test)+ #' addition to selecting a custom subset of statistics, the user can also set custom |
||
| 649 | +360 | ++ |
+ #' formats, labels, and indent modifiers for any of these statistics.+ |
+ |
| 361 |
#' |
|||
| 650 | +362 |
- #' ## Handle `NA` levels first when summarizing factors.+ #' @param stats_custom (`named vector` of `character`)\cr vector of statistics to include if |
||
| 651 | +363 |
- #' dta_test$AVISIT <- NA_character_+ #' not the defaults. This argument overrides `include_pval` and other custom value arguments |
||
| 652 | +364 |
- #' dta_test <- df_explicit_na(dta_test)+ #' such that only settings for these statistics will be returned. |
||
| 653 | +365 |
- #' l <- basic_table() %>%+ #' @param formats_custom (`named vector` of `character`)\cr vector of custom statistics formats |
||
| 654 | +366 |
- #' split_cols_by(var = "ARM") %>%+ #' to use in place of the defaults defined in [`summary_formats()`]. Names should be a subset |
||
| 655 | +367 |
- #' analyze_vars(vars = "AVISIT", na.rm = FALSE)+ #' of the statistics defined in `stats_custom` (or default statistics if this is `NULL`). |
||
| 656 | +368 |
- #'+ #' @param labels_custom (`named vector` of `character`)\cr vector of custom statistics labels |
||
| 657 | +369 |
- #' build_table(l, df = dta_test)+ #' to use in place of the defaults defined in [`summary_labels()`]. Names should be a subset |
||
| 658 | +370 |
- #'+ #' of the statistics defined in `stats_custom` (or default statistics if this is `NULL`). |
||
| 659 | +371 |
- #' # auto format+ #' @param indent_mods_custom (`integer` or `named vector` of `integer`)\cr vector of custom |
||
| 660 | +372 |
- #' dt <- data.frame("VAR" = c(0.001, 0.2, 0.0011000, 3, 4))
+ #' indentation modifiers for statistics to use instead of the default of `0L` for all statistics. |
||
| 661 | +373 |
- #' basic_table() %>%+ #' Names should be a subset of the statistics defined in `stats_custom` (or default statistics |
||
| 662 | +374 |
- #' analyze_vars(+ #' if this is `NULL`). Alternatively, the same indentation modifier can be applied to all |
||
| 663 | +375 |
- #' vars = "VAR",+ #' statistics by setting `indent_mods_custom` to a single integer value. |
||
| 664 | +376 |
- #' .stats = c("n", "mean", "mean_sd", "range"),
+ #' |
||
| 665 | +377 |
- #' .formats = c("mean_sd" = "auto", "range" = "auto")
+ #' @return |
||
| 666 | +378 |
- #' ) %>%+ #' * `summary_custom` returns a `list` of 4 named elements: `stats`, `formats`, `labels`, |
||
| 667 | +379 |
- #' build_table(dt)+ #' and `indent_mods`. |
||
| 668 | +380 |
#' |
||
| 669 | +381 |
- #' @export analyze_vars summarize_vars+ #' @examples |
||
| 670 | +382 |
- analyze_vars <- function(lyt,+ #' summary_custom() |
||
| 671 | +383 |
- vars,+ #' summary_custom(type = "counts", include_pval = TRUE) |
||
| 672 | +384 |
- var_labels = vars,+ #' summary_custom( |
||
| 673 | +385 |
- nested = TRUE,+ #' include_pval = TRUE, stats_custom = c("n", "mean", "sd", "pval"),
|
||
| 674 | +386 |
- ...,+ #' labels_custom = c(sd = "Std. Dev."), indent_mods_custom = 3L |
||
| 675 | +387 |
- na.rm = TRUE, # nolint+ #' ) |
||
| 676 | +388 |
- na_level = NA_character_,+ #' |
||
| 677 | +389 |
- show_labels = "default",+ #' @export |
||
| 678 | +390 |
- table_names = vars,+ summary_custom <- function(type = "numeric", |
||
| 679 | +391 |
- section_div = NA_character_,+ include_pval = FALSE, |
||
| 680 | +392 |
- .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
+ stats_custom = NULL, |
||
| 681 | +393 |
- .formats = NULL,+ formats_custom = NULL, |
||
| 682 | +394 |
- .labels = NULL,+ labels_custom = NULL, |
||
| 683 | +395 |
- .indent_mods = NULL) {
+ indent_mods_custom = NULL) {
|
||
| 684 | -20x | +396 | +1x |
- extra_args <- list(.stats = .stats, na.rm = na.rm, na_level = na_level, ...)+ lifecycle::deprecate_warn( |
| 685 | -2x | +397 | +1x |
- if (!is.null(.formats)) extra_args[[".formats"]] <- .formats+ "0.9.0.9001", |
| 686 | -! | +|||
| 398 | +1x |
- if (!is.null(.labels)) extra_args[[".labels"]] <- .labels+ "summary_custom()", |
||
| 687 | -! | +|||
| 399 | +1x |
- if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods+ details = "Please use `get_stats`, `get_formats_from_stats`, and `get_labels_from_stats` directly instead." |
||
| 688 | +400 |
-
+ ) |
||
| 689 | -20x | +401 | +1x |
- analyze(+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
|
| 690 | -20x | +402 | +1x |
- lyt = lyt,+ .stats <- get_stats(met_grp, stats_custom, add_pval = include_pval) |
| 691 | -20x | +403 | +1x |
- vars = vars,+ .formats <- get_formats_from_stats(.stats, formats_custom) |
| 692 | -20x | +404 | +1x |
- var_labels = var_labels,+ .labels <- get_labels_from_stats(.stats, labels_custom) |
| 693 | -20x | +405 | +1x |
- afun = a_summary,+ .indent_mods <- stats::setNames(rep(0L, length(.stats)), .stats) |
| 694 | -20x | +|||
| 406 | +
- nested = nested,+ |
|||
| 695 | -20x | +407 | +1x |
- extra_args = extra_args,+ if (!is.null(indent_mods_custom)) {
|
| 696 | -20x | +|||
| 408 | +! |
- inclNAs = TRUE,+ if (is.null(names(indent_mods_custom)) && length(indent_mods_custom) == 1) {
|
||
| 697 | -20x | +|||
| 409 | +! |
- show_labels = show_labels,+ .indent_mods[names(.indent_mods)] <- indent_mods_custom |
||
| 698 | -20x | +|||
| 410 | +
- table_names = table_names,+ } else {
|
|||
| 699 | -20x | +|||
| 411 | +! |
- section_div = section_div+ .indent_mods[names(indent_mods_custom)] <- indent_mods_custom |
||
| 700 | +412 |
- )+ } |
||
| 701 | +413 |
- }+ } |
||
| 702 | +414 |
- #' @describeIn analyze_variables `r lifecycle::badge("deprecated")` Use `analyze_vars` instead.
+
|
||
| 703 | -+ | |||
| 415 | +1x |
- summarize_vars <- function(...) {
+ list( |
||
| 704 | -! | +|||
| 416 | +1x |
- lifecycle::deprecate_warn(when = "0.8.5.9010", "summarize_vars()", "analyze_vars()")+ stats = .stats, |
||
| 705 | -! | +|||
| 417 | +1x |
- analyze_vars(...)+ formats = .formats,+ |
+ ||
| 418 | +1x | +
+ labels = .labels,+ |
+ ||
| 419 | +1x | +
+ indent_mods = .indent_mods[.stats] |
||
| 706 | +420 | ++ |
+ )+ |
+ |
| 421 |
}@@ -80444,14 +80766,14 @@ tern coverage - 94.83% |
| 1 |
- #' Survival Time Analysis+ #' Convert List of Groups to Data Frame |
||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' This converts a list of group levels into a data frame format which is expected by [rtables::add_combo_levels()]. |
||
| 5 |
- #' Summarize median survival time and CIs, percentiles of survival times, survival+ #' @param groups_list (named `list` of `character`)\cr specifies the new group levels via the names and the |
||
| 6 |
- #' time range of censored/event patients.+ #' levels that belong to it in the character vectors that are elements of the list. |
||
| 8 |
- #' @inheritParams argument_convention+ #' @return [tibble::tibble()] in the required format. |
||
| 9 |
- #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function+ #' |
||
| 10 |
- #' [control_surv_time()]. Some possible parameter options are:+ #' @examples |
||
| 11 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival time.+ #' grade_groups <- list( |
||
| 12 |
- #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", or "log-log",+ #' "Any Grade (%)" = c("1", "2", "3", "4", "5"),
|
||
| 13 |
- #' see more in [survival::survfit()]. Note option "none" is not supported.+ #' "Grade 3-4 (%)" = c("3", "4"),
|
||
| 14 |
- #' * `quantiles` (`numeric`)\cr vector of length two to specify the quantiles of survival time.+ #' "Grade 5 (%)" = "5" |
||
| 15 |
- #'+ #' ) |
||
| 16 |
- #' @name survival_time+ #' groups_list_to_df(grade_groups) |
||
| 17 |
- NULL+ #' |
||
| 18 |
-
+ #' @export |
||
| 19 |
- #' @describeIn survival_time Statistics function which analyzes survival times.+ groups_list_to_df <- function(groups_list) {
|
||
| 20 | -+ | 5x |
- #'+ checkmate::assert_list(groups_list, names = "named") |
| 21 | -+ | 5x |
- #' @return+ lapply(groups_list, checkmate::assert_character) |
| 22 | -+ | 5x |
- #' * `s_surv_time()` returns the statistics:+ tibble::tibble( |
| 23 | -+ | 5x |
- #' * `median`: Median survival time.+ valname = make_names(names(groups_list)), |
| 24 | -+ | 5x |
- #' * `median_ci`: Confidence interval for median time.+ label = names(groups_list), |
| 25 | -+ | 5x |
- #' * `quantiles`: Survival time for two specified quantiles.+ levelcombo = unname(groups_list), |
| 26 | -+ | 5x |
- #' * `range_censor`: Survival time range for censored observations.+ exargs = replicate(length(groups_list), list()) |
| 27 |
- #' * `range_event`: Survival time range for observations with events.+ ) |
||
| 28 |
- #' * `range`: Survival time range for all observations.+ } |
||
| 29 |
- #'+ |
||
| 30 |
- #' @examples+ #' Reference and Treatment Group Combination |
||
| 31 |
- #' library(dplyr)+ #' |
||
| 32 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 33 |
- #' adtte_f <- tern_ex_adtte %>%+ #' |
||
| 34 |
- #' filter(PARAMCD == "OS") %>%+ #' Facilitate the re-combination of groups divided as reference and treatment groups; it helps in arranging groups of |
||
| 35 |
- #' mutate(+ #' columns in the `rtables` framework and teal modules. |
||
| 36 |
- #' AVAL = day2month(AVAL),+ #' |
||
| 37 |
- #' is_event = CNSR == 0+ #' @param fct (`factor`)\cr the variable with levels which needs to be grouped. |
||
| 38 |
- #' )+ #' @param ref (`string`)\cr the reference level(s). |
||
| 39 |
- #' df <- adtte_f %>% filter(ARMCD == "ARM A")+ #' @param collapse (`string`)\cr a character string to separate `fct` and `ref`. |
||
| 41 |
- #' @keywords internal+ #' @return A `list` with first item `ref` (reference) and second item `trt` (treatment). |
||
| 42 |
- s_surv_time <- function(df,+ #' |
||
| 43 |
- .var,+ #' @examples |
||
| 44 |
- is_event,+ #' groups <- combine_groups( |
||
| 45 |
- control = control_surv_time()) {
+ #' fct = DM$ARM, |
||
| 46 | -146x | +
- checkmate::assert_string(.var)+ #' ref = c("B: Placebo")
|
|
| 47 | -146x | +
- assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ #' ) |
|
| 48 | -146x | +
- checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE)+ #' |
|
| 49 | -146x | +
- checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)+ #' basic_table() %>% |
|
| 50 |
-
+ #' split_cols_by_groups("ARM", groups) %>%
|
||
| 51 | -146x | +
- conf_type <- control$conf_type+ #' add_colcounts() %>% |
|
| 52 | -146x | +
- conf_level <- control$conf_level+ #' analyze_vars("AGE") %>%
|
|
| 53 | -146x | +
- quantiles <- control$quantiles+ #' build_table(DM) |
|
| 54 |
-
+ #' |
||
| 55 | -146x | +
- formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
+ #' @export |
|
| 56 | -146x | +
- srv_fit <- survival::survfit(+ combine_groups <- function(fct, |
|
| 57 | -146x | +
- formula = formula,+ ref = NULL, |
|
| 58 | -146x | +
- data = df,+ collapse = "/") {
|
|
| 59 | -146x | +10x |
- conf.int = conf_level,+ checkmate::assert_string(collapse) |
| 60 | -146x | +10x |
- conf.type = conf_type+ checkmate::assert_character(ref, min.chars = 1, any.missing = FALSE, null.ok = TRUE) |
| 61 | -+ | 10x |
- )+ checkmate::assert_multi_class(fct, classes = c("factor", "character"))
|
| 62 | -146x | +
- srv_tab <- summary(srv_fit, extend = TRUE)$table+ |
|
| 63 | -146x | +10x |
- srv_qt_tab <- stats::quantile(srv_fit, probs = quantiles)$quantile+ fct <- as_factor_keep_attributes(fct) |
| 64 | -146x | +
- range_censor <- range_noinf(df[[.var]][!df[[is_event]]], na.rm = TRUE)+ |
|
| 65 | -146x | +10x |
- range_event <- range_noinf(df[[.var]][df[[is_event]]], na.rm = TRUE)+ group_levels <- levels(fct) |
| 66 | -146x | +10x |
- range <- range_noinf(df[[.var]], na.rm = TRUE)+ if (is.null(ref)) {
|
| 67 | -146x | +6x |
- list(+ ref <- group_levels[1] |
| 68 | -146x | +
- median = formatters::with_label(unname(srv_tab["median"]), "Median"),+ } else {
|
|
| 69 | -146x | +4x |
- median_ci = formatters::with_label(+ checkmate::assert_subset(ref, group_levels) |
| 70 | -146x | +
- unname(srv_tab[paste0(srv_fit$conf.int, c("LCL", "UCL"))]), f_conf_level(conf_level)
+ } |
|
| 71 |
- ),+ |
||
| 72 | -146x | +10x |
- quantiles = formatters::with_label(+ groups <- list( |
| 73 | -146x | +10x |
- unname(srv_qt_tab), paste0(quantiles[1] * 100, "% and ", quantiles[2] * 100, "%-ile")+ ref = group_levels[group_levels %in% ref], |
| 74 | -+ | 10x |
- ),+ trt = group_levels[!group_levels %in% ref] |
| 75 | -146x | +
- range_censor = formatters::with_label(range_censor, "Range (censored)"),+ ) |
|
| 76 | -146x | +10x |
- range_event = formatters::with_label(range_event, "Range (event)"),+ stats::setNames(groups, nm = lapply(groups, paste, collapse = collapse)) |
| 77 | -146x | +
- range = formatters::with_label(range, "Range")+ } |
|
| 78 |
- )+ |
||
| 79 |
- }+ #' Split Columns by Groups of Levels |
||
| 80 |
-
+ #' |
||
| 81 |
- #' @describeIn survival_time Formatted analysis function which is used as `afun` in `surv_time()`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 83 |
- #' @return+ #' @inheritParams argument_convention |
||
| 84 |
- #' * `a_surv_time()` returns the corresponding list with formatted [rtables::CellValue()].+ #' @inheritParams groups_list_to_df |
||
| 85 |
- #'+ #' @param ... additional arguments to [rtables::split_cols_by()] in order. For instance, to |
||
| 86 |
- #' @keywords internal+ #' control formats (`format`), add a joint column for all groups (`incl_all`). |
||
| 87 |
- a_surv_time <- make_afun(+ #' |
||
| 88 |
- s_surv_time,+ #' @return A layout object suitable for passing to further layouting functions. Adding |
||
| 89 |
- .formats = c(+ #' this function to an `rtable` layout will add a column split including the given |
||
| 90 |
- "median" = "xx.x",+ #' groups to the table layout. |
||
| 91 |
- "median_ci" = "(xx.x, xx.x)",+ #' |
||
| 92 |
- "quantiles" = "xx.x, xx.x",+ #' @seealso [rtables::split_cols_by()] |
||
| 93 |
- "range_censor" = "xx.x to xx.x",+ #' |
||
| 94 |
- "range_event" = "xx.x to xx.x",+ #' @examples |
||
| 95 |
- "range" = "xx.x to xx.x"+ #' # 1 - Basic use |
||
| 96 |
- )+ #' |
||
| 97 |
- )+ #' # Without group combination `split_cols_by_groups` is |
||
| 98 |
-
+ #' # equivalent to [rtables::split_cols_by()]. |
||
| 99 |
- #' @describeIn survival_time Layout-creating function which can take statistics function arguments+ #' basic_table() %>% |
||
| 100 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' split_cols_by_groups("ARM") %>%
|
||
| 101 |
- #'+ #' add_colcounts() %>% |
||
| 102 |
- #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ #' analyze("AGE") %>%
|
||
| 103 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ #' build_table(DM) |
||
| 104 |
- #' for that statistic's row label.+ #' |
||
| 105 |
- #'+ #' # Add a reference column. |
||
| 106 |
- #' @return+ #' basic_table() %>% |
||
| 107 |
- #' * `surv_time()` returns a layout object suitable for passing to further layouting functions,+ #' split_cols_by_groups("ARM", ref_group = "B: Placebo") %>%
|
||
| 108 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' add_colcounts() %>% |
||
| 109 |
- #' the statistics from `s_surv_time()` to the table layout.+ #' analyze( |
||
| 110 |
- #'+ #' "AGE", |
||
| 111 |
- #' @examples+ #' afun = function(x, .ref_group, .in_ref_col) {
|
||
| 112 |
- #' basic_table() %>%+ #' if (.in_ref_col) {
|
||
| 113 |
- #' split_cols_by(var = "ARMCD") %>%+ #' in_rows("Diff Mean" = rcell(NULL))
|
||
| 114 |
- #' add_colcounts() %>%+ #' } else {
|
||
| 115 |
- #' surv_time(+ #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
|
||
| 116 |
- #' vars = "AVAL",+ #' } |
||
| 117 |
- #' var_labels = "Survival Time (Months)",+ #' } |
||
| 118 |
- #' is_event = "is_event",+ #' ) %>% |
||
| 119 |
- #' control = control_surv_time(conf_level = 0.9, conf_type = "log-log")+ #' build_table(DM) |
||
| 120 |
- #' ) %>%+ #' |
||
| 121 |
- #' build_table(df = adtte_f)+ #' # 2 - Adding group specification |
||
| 123 |
- #' @export+ #' # Manual preparation of the groups. |
||
| 124 |
- surv_time <- function(lyt,+ #' groups <- list( |
||
| 125 |
- vars,+ #' "Arms A+B" = c("A: Drug X", "B: Placebo"),
|
||
| 126 |
- nested = TRUE,+ #' "Arms A+C" = c("A: Drug X", "C: Combination")
|
||
| 127 |
- ...,+ #' ) |
||
| 128 |
- var_labels = "Time to Event",+ #' |
||
| 129 |
- table_names = vars,+ #' # Use of split_cols_by_groups without reference column. |
||
| 130 |
- .stats = c("median", "median_ci", "quantiles", "range_censor", "range_event"),
+ #' basic_table() %>% |
||
| 131 |
- .formats = NULL,+ #' split_cols_by_groups("ARM", groups) %>%
|
||
| 132 |
- .labels = NULL,+ #' add_colcounts() %>% |
||
| 133 |
- .indent_mods = c(+ #' analyze("AGE") %>%
|
||
| 134 |
- "median" = 0L, "median_ci" = 1L, "quantiles" = 0L,+ #' build_table(DM) |
||
| 135 |
- "range_censor" = 0L, "range_event" = 0L, "range" = 0L+ #' |
||
| 136 |
- )) {
+ #' # Including differentiated output in the reference column. |
||
| 137 | -2x | +
- afun <- make_afun(+ #' basic_table() %>% |
|
| 138 | -2x | +
- a_surv_time,+ #' split_cols_by_groups("ARM", groups_list = groups, ref_group = "Arms A+B") %>%
|
|
| 139 | -2x | +
- .stats = .stats,+ #' analyze( |
|
| 140 | -2x | +
- .formats = .formats,+ #' "AGE", |
|
| 141 | -2x | +
- .labels = .labels,+ #' afun = function(x, .ref_group, .in_ref_col) {
|
|
| 142 | -2x | +
- .indent_mods = extract_by_name(.indent_mods, .stats)+ #' if (.in_ref_col) {
|
|
| 143 |
- )+ #' in_rows("Diff. of Averages" = rcell(NULL))
|
||
| 144 | -2x | -
- analyze(- |
- |
| 145 | -2x | -
- lyt,- |
- |
| 146 | -2x | -
- vars,- |
- |
| 147 | -2x | -
- nested = nested,- |
- |
| 148 | -2x | -
- var_labels = var_labels,- |
- |
| 149 | -2x | -
- show_labels = "visible",- |
- |
| 150 | -2x | -
- table_names = table_names,- |
- |
| 151 | -2x | -
- afun = afun,- |
- |
| 152 | -2x | +
- extra_args = list(...)+ #' } else {
|
|
| 153 | +145 |
- )+ #' in_rows("Diff. of Averages" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
|
|
| 154 | +146 |
- }+ #' } |
| 1 | +147 |
- #' Number of Patients+ #' } |
||
| 2 | +148 |
- #'+ #' ) %>% |
||
| 3 | +149 |
- #' @description `r lifecycle::badge("stable")`
+ #' build_table(DM) |
||
| 4 | +150 |
#' |
||
| 5 | +151 |
- #' Count the number of unique and non-unique patients in a column (variable).+ #' # 3 - Binary list dividing factor levels into reference and treatment |
||
| 6 | +152 |
#' |
||
| 7 | +153 |
- #' @inheritParams argument_convention+ #' # `combine_groups` defines reference and treatment. |
||
| 8 | +154 |
- #' @param x (`character` or `factor`)\cr vector of patient IDs.+ #' groups <- combine_groups( |
||
| 9 | +155 |
- #' @param count_by (`character` or `factor`)\cr optional vector to be combined with `x` when counting+ #' fct = DM$ARM, |
||
| 10 | +156 |
- #' `nonunique` records.+ #' ref = c("A: Drug X", "B: Placebo")
|
||
| 11 | +157 |
- #' @param unique_count_suffix (`logical`)\cr should `"(n)"` suffix be added to `unique_count` labels.+ #' ) |
||
| 12 | +158 |
- #' Defaults to `TRUE`.+ #' groups |
||
| 13 | +159 |
#' |
||
| 14 | +160 |
- #' @name summarize_num_patients+ #' # Use group definition without reference column. |
||
| 15 | +161 |
- NULL+ #' basic_table() %>% |
||
| 16 | +162 |
-
+ #' split_cols_by_groups("ARM", groups_list = groups) %>%
|
||
| 17 | +163 |
- #' @describeIn summarize_num_patients Statistics function which counts the number of+ #' add_colcounts() %>% |
||
| 18 | +164 |
- #' unique patients, the corresponding percentage taken with respect to the+ #' analyze("AGE") %>%
|
||
| 19 | +165 |
- #' total number of patients, and the number of non-unique patients.+ #' build_table(DM) |
||
| 20 | +166 |
#' |
||
| 21 | +167 |
- #' @return+ #' # Use group definition with reference column (first item of groups). |
||
| 22 | +168 |
- #' * `s_num_patients()` returns a named `list` of 3 statistics:+ #' basic_table() %>% |
||
| 23 | +169 |
- #' * `unique`: Vector of counts and percentages.+ #' split_cols_by_groups("ARM", groups, ref_group = names(groups)[1]) %>%
|
||
| 24 | +170 |
- #' * `nonunique`: Vector of counts.+ #' add_colcounts() %>% |
||
| 25 | +171 |
- #' * `unique_count`: Counts.+ #' analyze( |
||
| 26 | +172 |
- #'+ #' "AGE", |
||
| 27 | +173 |
- #' @examples+ #' afun = function(x, .ref_group, .in_ref_col) {
|
||
| 28 | +174 |
- #' # Use the statistics function to count number of unique and nonunique patients.+ #' if (.in_ref_col) {
|
||
| 29 | +175 |
- #' s_num_patients(x = as.character(c(1, 1, 1, 2, 4, NA)), labelstr = "", .N_col = 6L)+ #' in_rows("Diff Mean" = rcell(NULL))
|
||
| 30 | +176 |
- #' s_num_patients(+ #' } else {
|
||
| 31 | +177 |
- #' x = as.character(c(1, 1, 1, 2, 4, NA)),+ #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
|
||
| 32 | +178 |
- #' labelstr = "",+ #' } |
||
| 33 | +179 |
- #' .N_col = 6L,+ #' } |
||
| 34 | +180 |
- #' count_by = as.character(c(1, 1, 2, 1, 1, 1))+ #' ) %>% |
||
| 35 | +181 |
- #' )+ #' build_table(DM) |
||
| 36 | +182 |
#' |
||
| 37 | +183 |
#' @export |
||
| 38 | -- |
- s_num_patients <- function(x, labelstr, .N_col, count_by = NULL, unique_count_suffix = TRUE) { # nolint
- |
- ||
| 39 | +184 | - - | -||
| 40 | -109x | -
- checkmate::assert_string(labelstr)- |
- ||
| 41 | -109x | -
- checkmate::assert_count(.N_col)- |
- ||
| 42 | -109x | -
- checkmate::assert_multi_class(x, classes = c("factor", "character"))
- |
- ||
| 43 | -109x | -
- checkmate::assert_flag(unique_count_suffix)+ split_cols_by_groups <- function(lyt, |
||
| 44 | +185 | - - | -||
| 45 | -109x | -
- count1 <- n_available(unique(x))- |
- ||
| 46 | -109x | -
- count2 <- n_available(x)+ var, |
||
| 47 | +186 | - - | -||
| 48 | -109x | -
- if (!is.null(count_by)) {
- |
- ||
| 49 | -10x | -
- checkmate::assert_vector(count_by, len = length(x))- |
- ||
| 50 | -10x | -
- checkmate::assert_multi_class(count_by, classes = c("factor", "character"))
- |
- ||
| 51 | -10x | -
- count2 <- n_available(unique(interaction(x, count_by)))+ groups_list = NULL, |
||
| 52 | +187 |
- }+ ref_group = NULL, |
||
| 53 | +188 |
-
+ ...) {
|
||
| 54 | -109x | +189 | +6x |
- out <- list(+ if (is.null(groups_list)) {
|
| 55 | -109x | +190 | +2x |
- unique = formatters::with_label(c(count1, ifelse(count1 == 0 && .N_col == 0, 0, count1 / .N_col)), labelstr),+ split_cols_by( |
| 56 | -109x | +191 | +2x |
- nonunique = formatters::with_label(count2, labelstr),+ lyt = lyt, |
| 57 | -109x | -
- unique_count = formatters::with_label(count1, ifelse(unique_count_suffix, paste(labelstr, "(n)"), labelstr))- |
- ||
| 58 | -- |
- )- |
- ||
| 59 | -+ | 192 | +2x |
-
+ var = var, |
| 60 | -109x | -
- out- |
- ||
| 61 | -- |
- }- |
- ||
| 62 | -- | - - | -||
| 63 | -- |
- #' @describeIn summarize_num_patients Statistics function which counts the number of unique patients- |
- ||
| 64 | -- |
- #' in a column (variable), the corresponding percentage taken with respect to the total number of- |
- ||
| 65 | -- |
- #' patients, and the number of non-unique patients in the column.- |
- ||
| 66 | -- |
- #'- |
- ||
| 67 | -- |
- #' @param required (`character` or `NULL`)\cr optional name of a variable that is required to be non-missing.- |
- ||
| 68 | -- |
- #'- |
- ||
| 69 | -- |
- #' @return- |
- ||
| 70 | -- |
- #' * `s_num_patients_content()` returns the same values as `s_num_patients()`.- |
- ||
| 71 | -- |
- #'- |
- ||
| 72 | -- |
- #' @examples- |
- ||
| 73 | -- |
- #' # Count number of unique and non-unique patients.- |
- ||
| 74 | -- |
- #' df <- data.frame(- |
- ||
| 75 | -- |
- #' USUBJID = as.character(c(1, 2, 1, 4, NA)),- |
- ||
| 76 | -- |
- #' EVENT = as.character(c(10, 15, 10, 17, 8))- |
- ||
| 77 | -- |
- #' )- |
- ||
| 78 | -- |
- #' s_num_patients_content(df, .N_col = 5, .var = "USUBJID")- |
- ||
| 79 | -- |
- #'- |
- ||
| 80 | -- |
- #' df_by_event <- data.frame(- |
- ||
| 81 | -- |
- #' USUBJID = as.character(c(1, 2, 1, 4, NA)),- |
- ||
| 82 | -- |
- #' EVENT = as.character(c(10, 15, 10, 17, 8))- |
- ||
| 83 | -- |
- #' )- |
- ||
| 84 | -- |
- #' s_num_patients_content(df_by_event, .N_col = 5, .var = "USUBJID")- |
- ||
| 85 | -- |
- #' s_num_patients_content(df_by_event, .N_col = 5, .var = "USUBJID", count_by = "EVENT")- |
- ||
| 86 | -+ | 193 | +2x |
- #'+ ref_group = ref_group, |
| 87 | +194 |
- #' @export+ ... |
||
| 88 | +195 |
- s_num_patients_content <- function(df,+ ) |
||
| 89 | +196 |
- labelstr = "",+ } else {
|
||
| 90 | -+ | |||
| 197 | +4x |
- .N_col, # nolint+ groups_df <- groups_list_to_df(groups_list) |
||
| 91 | -+ | |||
| 198 | +4x |
- .var,+ if (!is.null(ref_group)) {
|
||
| 92 | -+ | |||
| 199 | +3x |
- required = NULL,+ ref_group <- groups_df$valname[groups_df$label == ref_group] |
||
| 93 | +200 |
- count_by = NULL,+ } |
||
| 94 | -+ | |||
| 201 | +4x |
- unique_count_suffix = TRUE) {
+ split_cols_by( |
||
| 95 | -46x | +202 | +4x |
- checkmate::assert_string(.var)+ lyt = lyt, |
| 96 | -46x | +203 | +4x |
- checkmate::assert_data_frame(df)+ var = var, |
| 97 | -46x | +204 | +4x |
- if (is.null(count_by)) {
+ split_fun = add_combo_levels(groups_df, keep_levels = groups_df$valname), |
| 98 | -43x | +205 | +4x |
- assert_df_with_variables(df, list(id = .var))+ ref_group = ref_group, |
| 99 | +206 |
- } else {
+ ... |
||
| 100 | -3x | +|||
| 207 | +
- assert_df_with_variables(df, list(id = .var, count_by = count_by))+ ) |
|||
| 101 | +208 |
} |
||
| 102 | -46x | +|||
| 209 | +
- if (!is.null(required)) {
+ } |
|||
| 103 | -! | +|||
| 210 | +
- checkmate::assert_string(required)+ |
|||
| 104 | -! | +|||
| 211 | +
- assert_df_with_variables(df, list(required = required))+ #' Combine Counts |
|||
| 105 | -! | +|||
| 212 | +
- df <- df[!is.na(df[[required]]), , drop = FALSE]+ #' |
|||
| 106 | +213 |
- }+ #' Simplifies the estimation of column counts, especially when group combination is required. |
||
| 107 | +214 |
-
+ #' |
||
| 108 | -46x | +|||
| 215 | +
- x <- df[[.var]]+ #' @inheritParams combine_groups |
|||
| 109 | -46x | +|||
| 216 | +
- y <- switch(as.numeric(!is.null(count_by)) + 1,+ #' @inheritParams groups_list_to_df |
|||
| 110 | -46x | +|||
| 217 | +
- NULL,+ #' |
|||
| 111 | -46x | +|||
| 218 | +
- df[[count_by]]+ #' @return A `vector` of column counts. |
|||
| 112 | +219 |
- )+ #' |
||
| 113 | +220 |
-
+ #' @seealso [combine_groups()] |
||
| 114 | -46x | +|||
| 221 | +
- s_num_patients(+ #' |
|||
| 115 | -46x | +|||
| 222 | +
- x = x,+ #' @examples |
|||
| 116 | -46x | +|||
| 223 | +
- labelstr = labelstr,+ #' ref <- c("A: Drug X", "B: Placebo")
|
|||
| 117 | -46x | +|||
| 224 | +
- .N_col = .N_col,+ #' groups <- combine_groups(fct = DM$ARM, ref = ref) |
|||
| 118 | -46x | +|||
| 225 | +
- count_by = y,+ #' |
|||
| 119 | -46x | +|||
| 226 | +
- unique_count_suffix = unique_count_suffix+ #' col_counts <- combine_counts( |
|||
| 120 | +227 |
- )+ #' fct = DM$ARM, |
||
| 121 | +228 |
- }+ #' groups_list = groups |
||
| 122 | +229 |
-
+ #' ) |
||
| 123 | +230 |
- c_num_patients <- make_afun(+ #' |
||
| 124 | +231 |
- s_num_patients_content,+ #' basic_table() %>% |
||
| 125 | +232 |
- .stats = c("unique", "nonunique", "unique_count"),
+ #' split_cols_by_groups("ARM", groups) %>%
|
||
| 126 | +233 |
- .formats = c(unique = format_count_fraction_fixed_dp, nonunique = "xx", unique_count = "xx")+ #' add_colcounts() %>% |
||
| 127 | +234 |
- )+ #' analyze_vars("AGE") %>%
|
||
| 128 | +235 |
-
+ #' build_table(DM, col_counts = col_counts) |
||
| 129 | +236 |
- #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments+ #' |
||
| 130 | +237 |
- #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ #' ref <- "A: Drug X" |
||
| 131 | +238 |
- #'+ #' groups <- combine_groups(fct = DM$ARM, ref = ref) |
||
| 132 | +239 |
- #' @return+ #' col_counts <- combine_counts( |
||
| 133 | +240 |
- #' * `summarize_num_patients()` returns a layout object suitable for passing to further layouting functions,+ #' fct = DM$ARM, |
||
| 134 | +241 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' groups_list = groups |
||
| 135 | +242 |
- #' the statistics from `s_num_patients_content()` to the table layout.+ #' ) |
||
| 136 | +243 |
#' |
||
| 137 | +244 |
- #' @export+ #' basic_table() %>% |
||
| 138 | +245 |
- summarize_num_patients <- function(lyt,+ #' split_cols_by_groups("ARM", groups) %>%
|
||
| 139 | +246 |
- var,+ #' add_colcounts() %>% |
||
| 140 | +247 |
- .stats = NULL,+ #' analyze_vars("AGE") %>%
|
||
| 141 | +248 |
- .formats = NULL,+ #' build_table(DM, col_counts = col_counts) |
||
| 142 | +249 |
- .labels = c(+ #' |
||
| 143 | +250 |
- unique = "Number of patients with at least one event",+ #' @export |
||
| 144 | +251 |
- nonunique = "Number of events"+ combine_counts <- function(fct, groups_list = NULL) {
|
||
| 145 | -+ | |||
| 252 | +4x |
- ),+ checkmate::assert_multi_class(fct, classes = c("factor", "character"))
|
||
| 146 | +253 |
- indent_mod = lifecycle::deprecated(),+ |
||
| 147 | -+ | |||
| 254 | +4x |
- .indent_mods = 0L,+ fct <- as_factor_keep_attributes(fct) |
||
| 148 | +255 |
- riskdiff = FALSE,+ |
||
| 149 | -+ | |||
| 256 | +4x |
- ...) {
+ if (is.null(groups_list)) {
|
||
| 150 | -9x | +257 | +1x |
- checkmate::assert_flag(riskdiff)+ y <- table(fct)+ |
+
| 258 | +1x | +
+ y <- stats::setNames(as.numeric(y), nm = dimnames(y)[[1]]) |
||
| 151 | +259 |
-
+ } else {
|
||
| 152 | -9x | +260 | +3x |
- if (lifecycle::is_present(indent_mod)) {
+ y <- vapply( |
| 153 | -! | +|||
| 261 | +3x |
- lifecycle::deprecate_warn("0.8.2", "summarize_num_patients(indent_mod)", "summarize_num_patients(.indent_mods)")
+ X = groups_list, |
||
| 154 | -! | +|||
| 262 | +3x |
- .indent_mods <- indent_mod+ FUN = function(x) sum(table(fct)[x]),+ |
+ ||
| 263 | +3x | +
+ FUN.VALUE = 1 |
||
| 155 | +264 |
- }+ ) |
||
| 156 | +265 |
-
+ } |
||
| 157 | +266 | 4x |
- if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
+ y |
|
| 158 | -2x | +|||
| 267 | +
- if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats]+ } |
| 159 | +1 |
-
+ #' Subgroup Treatment Effect Pattern (STEP) Fit for Survival Outcome |
||
| 160 | -9x | +|||
| 2 | +
- cfun <- make_afun(+ #' |
|||
| 161 | -9x | +|||
| 3 | +
- c_num_patients,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 162 | -9x | +|||
| 4 | +
- .stats = .stats,+ #' |
|||
| 163 | -9x | +|||
| 5 | +
- .formats = .formats,+ #' This fits the Subgroup Treatment Effect Pattern models for a survival outcome. The treatment arm |
|||
| 164 | -9x | +|||
| 6 | +
- .labels = .labels+ #' variable must have exactly 2 levels, where the first one is taken as reference and the estimated |
|||
| 165 | +7 |
- )+ #' hazard ratios are for the comparison of the second level vs. the first one. |
||
| 166 | +8 |
-
+ #' |
||
| 167 | -9x | +|||
| 9 | +
- extra_args <- if (isFALSE(riskdiff)) {
+ #' The model which is fit is: |
|||
| 168 | -8x | +|||
| 10 | +
- list(...)+ #' |
|||
| 169 | +11 |
- } else {
+ #' `Surv(time, event) ~ arm * poly(biomarker, degree) + covariates + strata(strata)` |
||
| 170 | -1x | +|||
| 12 | +
- list(+ #' |
|||
| 171 | -1x | +|||
| 13 | +
- afun = list("s_num_patients_content" = cfun),
+ #' where `degree` is specified by `control_step()`. |
|||
| 172 | -1x | +|||
| 14 | +
- .stats = .stats,+ #' |
|||
| 173 | -1x | +|||
| 15 | +
- .indent_mods = .indent_mods,+ #' @inheritParams argument_convention |
|||
| 174 | -1x | +|||
| 16 | +
- s_args = list(...)+ #' @param variables (named `list` of `character`)\cr list of analysis variables: needs `time`, `event`, |
|||
| 175 | +17 |
- )+ #' `arm`, `biomarker`, and optional `covariates` and `strata`. |
||
| 176 | +18 |
- }+ #' @param control (named `list`)\cr combined control list from [control_step()] and [control_coxph()]. |
||
| 177 | +19 |
-
+ #' |
||
| 178 | -9x | +|||
| 20 | +
- summarize_row_groups(+ #' @return A matrix of class `step`. The first part of the columns describe the subgroup intervals used |
|||
| 179 | -9x | +|||
| 21 | +
- lyt = lyt,+ #' for the biomarker variable, including where the center of the intervals are and their bounds. The |
|||
| 180 | -9x | +|||
| 22 | +
- var = var,+ #' second part of the columns contain the estimates for the treatment arm comparison. |
|||
| 181 | -9x | +|||
| 23 | +
- cfun = ifelse(isFALSE(riskdiff), cfun, afun_riskdiff),+ #' |
|||
| 182 | -9x | +|||
| 24 | +
- extra_args = extra_args,+ #' @note For the default degree 0 the `biomarker` variable is not included in the model. |
|||
| 183 | -9x | +|||
| 25 | +
- indent_mod = .indent_mods+ #' |
|||
| 184 | +26 |
- )+ #' @seealso [control_step()] and [control_coxph()] for the available customization options. |
||
| 185 | +27 |
- }+ #' |
||
| 186 | +28 |
-
+ #' @examples |
||
| 187 | +29 |
- #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments+ #' # Testing dataset with just two treatment arms. |
||
| 188 | +30 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' library(dplyr) |
||
| 189 | +31 |
#' |
||
| 190 | +32 |
- #' @return+ #' adtte_f <- tern_ex_adtte %>% |
||
| 191 | +33 |
- #' * `analyze_num_patients()` returns a layout object suitable for passing to further layouting functions,+ #' filter( |
||
| 192 | +34 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' PARAMCD == "OS", |
||
| 193 | +35 |
- #' the statistics from `s_num_patients_content()` to the table layout.+ #' ARM %in% c("B: Placebo", "A: Drug X")
|
||
| 194 | +36 |
- #'+ #' ) %>% |
||
| 195 | +37 |
- #' @details In general, functions that starts with `analyze*` are expected to+ #' mutate( |
||
| 196 | +38 |
- #' work like [rtables::analyze()], while functions that starts with `summarize*`+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
||
| 197 | +39 |
- #' are based upon [rtables::summarize_row_groups()]. The latter provides a+ #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")), |
||
| 198 | +40 |
- #' value for each dividing split in the row and column space, but, being it+ #' is_event = CNSR == 0 |
||
| 199 | +41 |
- #' bound to the fundamental splits, it is repeated by design in every page+ #' ) |
||
| 200 | +42 |
- #' when pagination is involved.+ #' labels <- c("ARM" = "Treatment Arm", "is_event" = "Event Flag")
|
||
| 201 | +43 |
- #'+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
||
| 202 | +44 |
- #' @note As opposed to [summarize_num_patients()], this function does not repeat the produced rows.+ #' |
||
| 203 | +45 |
- #'+ #' variables <- list( |
||
| 204 | +46 |
- #' @examples+ #' arm = "ARM", |
||
| 205 | +47 |
- #' df_tmp <- data.frame(+ #' biomarker = "BMRKR1", |
||
| 206 | +48 |
- #' USUBJID = as.character(c(1, 2, 1, 4, NA, 6, 6, 8, 9)),+ #' covariates = c("AGE", "BMRKR2"),
|
||
| 207 | +49 |
- #' ARM = c("A", "A", "A", "A", "A", "B", "B", "B", "B"),
+ #' event = "is_event", |
||
| 208 | +50 |
- #' AGE = c(10, 15, 10, 17, 8, 11, 11, 19, 17)+ #' time = "AVAL" |
||
| 209 | +51 |
#' ) |
||
| 210 | +52 |
- #' tbl <- basic_table() %>%+ #' |
||
| 211 | +53 |
- #' split_cols_by("ARM") %>%
+ #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup. |
||
| 212 | +54 |
- #' add_colcounts() %>%+ #' step_matrix <- fit_survival_step( |
||
| 213 | +55 |
- #' analyze_num_patients("USUBJID", .stats = c("unique")) %>%
+ #' variables = variables, |
||
| 214 | +56 |
- #' build_table(df_tmp)+ #' data = adtte_f |
||
| 215 | +57 |
- #' tbl+ #' ) |
||
| 216 | +58 |
- #'+ #' dim(step_matrix) |
||
| 217 | +59 |
- #' @export+ #' head(step_matrix) |
||
| 218 | +60 |
- analyze_num_patients <- function(lyt,+ #' |
||
| 219 | +61 |
- vars,+ #' # Specify different polynomial degree for the biomarker interaction to use more flexible local |
||
| 220 | +62 |
- nested = TRUE,+ #' # models. Or specify different Cox regression options. |
||
| 221 | +63 |
- .stats = NULL,+ #' step_matrix2 <- fit_survival_step( |
||
| 222 | +64 |
- .formats = NULL,+ #' variables = variables, |
||
| 223 | +65 |
- .labels = c(+ #' data = adtte_f, |
||
| 224 | +66 |
- unique = "Number of patients with at least one event",+ #' control = c(control_coxph(conf_level = 0.9), control_step(degree = 2)) |
||
| 225 | +67 |
- nonunique = "Number of events"+ #' ) |
||
| 226 | +68 |
- ),+ #' |
||
| 227 | +69 |
- show_labels = c("default", "visible", "hidden"),
+ #' # Use a global model with cubic interaction and only 5 points. |
||
| 228 | +70 |
- indent_mod = lifecycle::deprecated(),+ #' step_matrix3 <- fit_survival_step( |
||
| 229 | +71 |
- .indent_mods = 0L,+ #' variables = variables, |
||
| 230 | +72 |
- riskdiff = FALSE,+ #' data = adtte_f, |
||
| 231 | +73 |
- ...) {
+ #' control = c(control_coxph(), control_step(bandwidth = NULL, degree = 3, num_points = 5L)) |
||
| 232 | -3x | +|||
| 74 | +
- checkmate::assert_flag(riskdiff)+ #' ) |
|||
| 233 | +75 |
-
+ #' |
||
| 234 | -3x | +|||
| 76 | +
- if (lifecycle::is_present(indent_mod)) {
+ #' @export |
|||
| 235 | -! | +|||
| 77 | +
- lifecycle::deprecate_warn("0.8.2", "analyze_num_patients(indent_mod)", "analyze_num_patients(.indent_mods)")
+ fit_survival_step <- function(variables, |
|||
| 236 | -! | +|||
| 78 | +
- .indent_mods <- indent_mod+ data, |
|||
| 237 | +79 |
- }+ control = c(control_step(), control_coxph())) {
|
||
| 238 | -+ | |||
| 80 | +4x |
-
+ checkmate::assert_list(control) |
||
| 239 | -! | +|||
| 81 | +4x |
- if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
+ assert_df_with_variables(data, variables) |
||
| 240 | -! | +|||
| 82 | +4x |
- if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats]+ data <- data[!is.na(data[[variables$biomarker]]), ] |
||
| 241 | -+ | |||
| 83 | +4x |
-
+ window_sel <- h_step_window(x = data[[variables$biomarker]], control = control) |
||
| 242 | -3x | +84 | +4x |
- afun <- make_afun(+ interval_center <- window_sel$interval[, "Interval Center"] |
| 243 | -3x | +85 | +4x |
- c_num_patients,+ form <- h_step_survival_formula(variables = variables, control = control) |
| 244 | -3x | +86 | +4x |
- .stats = .stats,+ estimates <- if (is.null(control$bandwidth)) {
|
| 245 | -3x | +87 | +1x |
- .formats = .formats,+ h_step_survival_est( |
| 246 | -3x | +88 | +1x |
- .labels = .labels+ formula = form,+ |
+
| 89 | +1x | +
+ data = data,+ |
+ ||
| 90 | +1x | +
+ variables = variables,+ |
+ ||
| 91 | +1x | +
+ x = interval_center,+ |
+ ||
| 92 | +1x | +
+ control = control |
||
| 247 | +93 |
- )+ ) |
||
| 248 | +94 |
-
+ } else {
|
||
| 249 | +95 | 3x |
- extra_args <- if (isFALSE(riskdiff)) {
+ tmp <- mapply( |
|
| 250 | -2x | +96 | +3x |
- list(...)+ FUN = h_step_survival_est, |
| 251 | -+ | |||
| 97 | +3x |
- } else {
+ x = interval_center, |
||
| 252 | -1x | +98 | +3x |
- list(+ subset = as.list(as.data.frame(window_sel$sel)), |
| 253 | -1x | +99 | +3x |
- afun = list("s_num_patients_content" = afun),
+ MoreArgs = list( |
| 254 | -1x | +100 | +3x |
- .stats = .stats,+ formula = form, |
| 255 | -1x | +101 | +3x |
- .indent_mods = .indent_mods,+ data = data, |
| 256 | -1x | +102 | +3x |
- s_args = list(...)+ variables = variables,+ |
+
| 103 | +3x | +
+ control = control |
||
| 257 | +104 |
- )+ ) |
||
| 258 | +105 |
- }+ ) |
||
| 259 | +106 |
-
+ # Maybe we find a more elegant solution than this. |
||
| 260 | +107 | 3x |
- analyze(+ rownames(tmp) <- c("n", "events", "loghr", "se", "ci_lower", "ci_upper")
|
|
| 261 | +108 | 3x |
- afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ t(tmp)+ |
+ |
| 109 | ++ |
+ } |
||
| 262 | -3x | +110 | +4x |
- lyt = lyt,+ result <- cbind(window_sel$interval, estimates) |
| 263 | -3x | +111 | +4x |
- vars = vars,+ structure( |
| 264 | -3x | +112 | +4x |
- nested = nested,+ result, |
| 265 | -3x | +113 | +4x |
- extra_args = extra_args,+ class = c("step", "matrix"),
|
| 266 | -3x | +114 | +4x |
- show_labels = show_labels,+ variables = variables, |
| 267 | -3x | +115 | +4x |
- indent_mod = .indent_mods+ control = control |
| 268 | +116 |
) |
||
| 269 | +117 |
}@@ -83417,14 +83466,14 @@ tern coverage - 94.83% |
| 1 |
- #' Survival Time Point Analysis+ #' Summary numeric variables in columns |
||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' @description `r lifecycle::badge("experimental")`
|
||
| 5 |
- #' Summarize patients' survival rate and difference of survival rates between groups at a time point.+ #' Layout-creating function which can be used for creating column-wise summary tables. |
||
| 6 |
- #'+ #' This function sets the analysis methods as column labels and is a wrapper for |
||
| 7 |
- #' @inheritParams argument_convention+ #' [rtables::analyze_colvars()]. It was designed principally for PK tables. |
||
| 8 |
- #' @inheritParams s_surv_time+ #' |
||
| 9 |
- #' @param time_point (`number`)\cr survival time point of interest.+ #' @inheritParams argument_convention |
||
| 10 |
- #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function+ #' @inheritParams rtables::analyze_colvars |
||
| 11 |
- #' [control_surv_timepoint()]. Some possible parameter options are:+ #' @param imp_rule (`character`)\cr imputation rule setting. Defaults to `NULL` for no imputation rule. Can |
||
| 12 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate.+ #' also be `"1/3"` to implement 1/3 imputation rule or `"1/2"` to implement 1/2 imputation rule. In order |
||
| 13 |
- #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log",+ #' to use an imputation rule, the `avalcat_var` argument must be specified. See [imputation_rule()] |
||
| 14 |
- #' see more in [survival::survfit()]. Note option "none" is no longer supported.+ #' for more details on imputation. |
||
| 15 |
- #' * `time_point` (`number`)\cr survival time point of interest.+ #' @param avalcat_var (`character`)\cr if `imp_rule` is not `NULL`, name of variable that indicates whether a |
||
| 16 |
- #'+ #' row in the data corresponds to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of |
||
| 17 |
- #' @name survival_timepoint+ #' the above (defaults to `"AVALCAT1"`). Variable must be present in the data and should match the variable |
||
| 18 |
- NULL+ #' used to calculate the `n_blq` statistic (if included in `.stats`). |
||
| 19 |
-
+ #' @param cache (`flag`)\cr whether to store computed values in a temporary caching environment. This will |
||
| 20 |
- #' @describeIn survival_timepoint Statistics function which analyzes survival rate.+ #' speed up calculations in large tables, but should be set to `FALSE` if the same `rtable` layout is |
||
| 21 |
- #'+ #' used for multiple tables with different data. Defaults to `FALSE`. |
||
| 22 |
- #' @return+ #' @param row_labels (`character`)\cr as this function works in columns space, usual `.labels` |
||
| 23 |
- #' * `s_surv_timepoint()` returns the statistics:+ #' character vector applies on the column space. You can change the row labels by defining this |
||
| 24 |
- #' * `pt_at_risk`: Patients remaining at risk.+ #' parameter to a named character vector with names corresponding to the split values. It defaults |
||
| 25 |
- #' * `event_free_rate`: Event-free rate (%).+ #' to `NULL` and if it contains only one `string`, it will duplicate that as a row label. |
||
| 26 |
- #' * `rate_se`: Standard error of event free rate.+ #' @param do_summarize_row_groups (`flag`)\cr defaults to `FALSE` and applies the analysis to the current |
||
| 27 |
- #' * `rate_ci`: Confidence interval for event free rate.+ #' label rows. This is a wrapper of [rtables::summarize_row_groups()] and it can accept `labelstr` |
||
| 28 |
- #'+ #' to define row labels. This behavior is not supported as we never need to overload row labels. |
||
| 29 |
- #' @examples+ #' @param split_col_vars (`flag`)\cr defaults to `TRUE` and puts the analysis results onto the columns. |
||
| 30 |
- #' library(dplyr)+ #' This option allows you to add multiple instances of this functions, also in a nested fashion, |
||
| 31 |
- #'+ #' without adding more splits. This split must happen only one time on a single layout. |
||
| 32 |
- #' adtte_f <- tern_ex_adtte %>%+ #' |
||
| 33 |
- #' filter(PARAMCD == "OS") %>%+ #' @return |
||
| 34 |
- #' mutate(+ #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()]. |
||
| 35 |
- #' AVAL = day2month(AVAL),+ #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output |
||
| 36 |
- #' is_event = CNSR == 0+ #' in columns, and add it to the table layout. |
||
| 37 |
- #' )+ #' |
||
| 38 |
- #' df <- adtte_f %>%+ #' @note This is an experimental implementation of [rtables::summarize_row_groups()] and |
||
| 39 |
- #' filter(ARMCD == "ARM A")+ #' [rtables::analyze_colvars()] that may be subjected to changes as `rtables` extends its |
||
| 40 |
- #'+ #' support to more complex analysis pipelines on the column space. For the same reasons, |
||
| 41 |
- #' @keywords internal+ #' we encourage to read the examples carefully and file issues for cases that differ from |
||
| 42 |
- s_surv_timepoint <- function(df,+ #' them. |
||
| 43 |
- .var,+ #' |
||
| 44 |
- time_point,+ #' Here `labelstr` behaves differently than usual. If it is not defined (default as `NULL`), |
||
| 45 |
- is_event,+ #' row labels are assigned automatically to the split values in case of `rtables::analyze_colvars` |
||
| 46 |
- control = control_surv_timepoint()) {
+ #' (`do_summarize_row_groups = FALSE`, the default), and to the group label for |
||
| 47 | -19x | +
- checkmate::assert_string(.var)+ #' `do_summarize_row_groups = TRUE`. |
|
| 48 | -19x | +
- assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ #' |
|
| 49 | -19x | +
- checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE)+ #' @seealso [analyze_vars()], [rtables::analyze_colvars()]. |
|
| 50 | -19x | +
- checkmate::assert_number(time_point)+ #' |
|
| 51 | -19x | +
- checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)+ #' @examples |
|
| 52 |
-
+ #' library(dplyr) |
||
| 53 | -19x | +
- conf_type <- control$conf_type+ #' |
|
| 54 | -19x | +
- conf_level <- control$conf_level+ #' # Data preparation |
|
| 55 |
-
+ #' adpp <- tern_ex_adpp %>% h_pkparam_sort() |
||
| 56 | -19x | +
- formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
+ #' |
|
| 57 | -19x | +
- srv_fit <- survival::survfit(+ #' lyt <- basic_table() %>% |
|
| 58 | -19x | +
- formula = formula,+ #' split_rows_by(var = "STRATA1", label_pos = "topleft") %>% |
|
| 59 | -19x | +
- data = df,+ #' split_rows_by( |
|
| 60 | -19x | +
- conf.int = conf_level,+ #' var = "SEX", |
|
| 61 | -19x | +
- conf.type = conf_type+ #' label_pos = "topleft", |
|
| 62 |
- )+ #' child_label = "hidden" |
||
| 63 | -19x | +
- s_srv_fit <- summary(srv_fit, times = time_point, extend = TRUE)+ #' ) %>% # Removes duplicated labels |
|
| 64 | -19x | +
- df_srv_fit <- as.data.frame(s_srv_fit[c("time", "n.risk", "surv", "lower", "upper", "std.err")])
+ #' analyze_vars_in_cols(vars = "AGE") |
|
| 65 | -19x | +
- if (df_srv_fit[["n.risk"]] == 0) {
+ #' result <- build_table(lyt = lyt, df = adpp) |
|
| 66 | -1x | +
- pt_at_risk <- event_free_rate <- rate_se <- NA_real_+ #' result |
|
| 67 | -1x | +
- rate_ci <- c(NA_real_, NA_real_)+ #' |
|
| 68 |
- } else {
+ #' # By selecting just some statistics and ad-hoc labels |
||
| 69 | -18x | +
- pt_at_risk <- df_srv_fit$n.risk+ #' lyt <- basic_table() %>% |
|
| 70 | -18x | +
- event_free_rate <- df_srv_fit$surv+ #' split_rows_by(var = "ARM", label_pos = "topleft") %>% |
|
| 71 | -18x | +
- rate_se <- df_srv_fit$std.err+ #' split_rows_by( |
|
| 72 | -18x | +
- rate_ci <- c(df_srv_fit$lower, df_srv_fit$upper)+ #' var = "SEX", |
|
| 73 |
- }+ #' label_pos = "topleft", |
||
| 74 | -19x | +
- list(+ #' child_labels = "hidden", |
|
| 75 | -19x | +
- pt_at_risk = formatters::with_label(pt_at_risk, "Patients remaining at risk"),+ #' split_fun = drop_split_levels |
|
| 76 | -19x | +
- event_free_rate = formatters::with_label(event_free_rate * 100, "Event Free Rate (%)"),+ #' ) %>% |
|
| 77 | -19x | +
- rate_se = formatters::with_label(rate_se * 100, "Standard Error of Event Free Rate"),+ #' analyze_vars_in_cols( |
|
| 78 | -19x | +
- rate_ci = formatters::with_label(rate_ci * 100, f_conf_level(conf_level))+ #' vars = "AGE", |
|
| 79 |
- )+ #' .stats = c("n", "cv", "geom_mean"),
|
||
| 80 |
- }+ #' .labels = c( |
||
| 81 |
-
+ #' n = "aN", |
||
| 82 |
- #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()`+ #' cv = "aCV", |
||
| 83 |
- #' when `method = "surv"`.+ #' geom_mean = "aGeomMean" |
||
| 84 |
- #'+ #' ) |
||
| 85 |
- #' @return+ #' ) |
||
| 86 |
- #' * `a_surv_timepoint()` returns the corresponding list with formatted [rtables::CellValue()].+ #' result <- build_table(lyt = lyt, df = adpp) |
||
| 87 |
- #'+ #' result |
||
| 88 |
- #' @keywords internal+ #' |
||
| 89 |
- a_surv_timepoint <- make_afun(+ #' # Changing row labels |
||
| 90 |
- s_surv_timepoint,+ #' lyt <- basic_table() %>% |
||
| 91 |
- .indent_mods = c(+ #' analyze_vars_in_cols( |
||
| 92 |
- pt_at_risk = 0L,+ #' vars = "AGE", |
||
| 93 |
- event_free_rate = 0L,+ #' row_labels = "some custom label" |
||
| 94 |
- rate_se = 1L,+ #' ) |
||
| 95 |
- rate_ci = 1L+ #' result <- build_table(lyt, df = adpp) |
||
| 96 |
- ),+ #' result |
||
| 97 |
- .formats = c(+ #' |
||
| 98 |
- pt_at_risk = "xx",+ #' # Pharmacokinetic parameters |
||
| 99 |
- event_free_rate = "xx.xx",+ #' lyt <- basic_table() %>% |
||
| 100 |
- rate_se = "xx.xx",+ #' split_rows_by( |
||
| 101 |
- rate_ci = "(xx.xx, xx.xx)"+ #' var = "TLG_DISPLAY", |
||
| 102 |
- )+ #' split_label = "PK Parameter", |
||
| 103 |
- )+ #' label_pos = "topleft", |
||
| 104 |
-
+ #' child_label = "hidden" |
||
| 105 |
- #' @describeIn survival_timepoint Statistics function which analyzes difference between two survival rates.+ #' ) %>% |
||
| 106 |
- #'+ #' analyze_vars_in_cols( |
||
| 107 |
- #' @return+ #' vars = "AVAL" |
||
| 108 |
- #' * `s_surv_timepoint_diff()` returns the statistics:+ #' ) |
||
| 109 |
- #' * `rate_diff`: Event-free rate difference between two groups.+ #' result <- build_table(lyt, df = adpp) |
||
| 110 |
- #' * `rate_diff_ci`: Confidence interval for the difference.+ #' result |
||
| 111 |
- #' * `ztest_pval`: p-value to test the difference is 0.+ #' |
||
| 112 |
- #'+ #' # Multiple calls (summarize label and analyze underneath) |
||
| 113 |
- #' @examples+ #' lyt <- basic_table() %>% |
||
| 114 |
- #' df_ref_group <- adtte_f %>%+ #' split_rows_by( |
||
| 115 |
- #' filter(ARMCD == "ARM B")+ #' var = "TLG_DISPLAY", |
||
| 116 |
- #'+ #' split_label = "PK Parameter", |
||
| 117 |
- #' @keywords internal+ #' label_pos = "topleft" |
||
| 118 |
- s_surv_timepoint_diff <- function(df,+ #' ) %>% |
||
| 119 |
- .var,+ #' analyze_vars_in_cols( |
||
| 120 |
- .ref_group,+ #' vars = "AVAL", |
||
| 121 |
- .in_ref_col,+ #' do_summarize_row_groups = TRUE # does a summarize level |
||
| 122 |
- time_point,+ #' ) %>% |
||
| 123 |
- control = control_surv_timepoint(),+ #' split_rows_by("SEX",
|
||
| 124 |
- ...) {
+ #' child_label = "hidden", |
||
| 125 | -2x | +
- if (.in_ref_col) {
+ #' label_pos = "topleft" |
|
| 126 | -! | +
- return(+ #' ) %>% |
|
| 127 | -! | +
- list(+ #' analyze_vars_in_cols( |
|
| 128 | -! | +
- rate_diff = formatters::with_label("", "Difference in Event Free Rate"),
+ #' vars = "AVAL", |
|
| 129 | -! | +
- rate_diff_ci = formatters::with_label("", f_conf_level(control$conf_level)),
+ #' split_col_vars = FALSE # avoids re-splitting the columns |
|
| 130 | -! | +
- ztest_pval = formatters::with_label("", "p-value (Z-test)")
+ #' ) |
|
| 131 |
- )+ #' result <- build_table(lyt, df = adpp) |
||
| 132 |
- )+ #' result |
||
| 133 |
- }+ #' |
||
| 134 | -2x | +
- data <- rbind(.ref_group, df)+ #' @export |
|
| 135 | -2x | +
- group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
+ analyze_vars_in_cols <- function(lyt, |
|
| 136 | -2x | +
- res_per_group <- lapply(split(data, group), function(x) {
+ vars, |
|
| 137 | -4x | +
- s_surv_timepoint(df = x, .var = .var, time_point = time_point, control = control, ...)+ ..., |
|
| 138 |
- })+ .stats = c( |
||
| 139 |
-
+ "n", |
||
| 140 | -2x | +
- res_x <- res_per_group[[2]]+ "mean", |
|
| 141 | -2x | +
- res_ref <- res_per_group[[1]]+ "sd", |
|
| 142 | -2x | +
- rate_diff <- res_x$event_free_rate - res_ref$event_free_rate+ "se", |
|
| 143 | -2x | +
- se_diff <- sqrt(res_x$rate_se^2 + res_ref$rate_se^2)+ "cv", |
|
| 144 |
-
+ "geom_cv" |
||
| 145 | -2x | +
- qs <- c(-1, 1) * stats::qnorm(1 - (1 - control$conf_level) / 2)+ ), |
|
| 146 | -2x | +
- rate_diff_ci <- rate_diff + qs * se_diff+ .labels = c( |
|
| 147 | -2x | +
- ztest_pval <- if (is.na(rate_diff)) {
+ n = "n", |
|
| 148 | -2x | +
- NA+ mean = "Mean", |
|
| 149 |
- } else {
+ sd = "SD", |
||
| 150 | -2x | +
- 2 * (1 - stats::pnorm(abs(rate_diff) / se_diff))+ se = "SE", |
|
| 151 |
- }+ cv = "CV (%)", |
||
| 152 | -2x | +
- list(+ geom_cv = "CV % Geometric Mean" |
|
| 153 | -2x | +
- rate_diff = formatters::with_label(rate_diff, "Difference in Event Free Rate"),+ ), |
|
| 154 | -2x | +
- rate_diff_ci = formatters::with_label(rate_diff_ci, f_conf_level(control$conf_level)),+ row_labels = NULL, |
|
| 155 | -2x | +
- ztest_pval = formatters::with_label(ztest_pval, "p-value (Z-test)")+ do_summarize_row_groups = FALSE, |
|
| 156 |
- )+ split_col_vars = TRUE, |
||
| 157 |
- }+ imp_rule = NULL, |
||
| 158 |
-
+ avalcat_var = "AVALCAT1", |
||
| 159 |
- #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()`+ cache = FALSE, |
||
| 160 |
- #' when `method = "surv_diff"`.+ .indent_mods = NULL, |
||
| 161 |
- #'+ na_level = lifecycle::deprecated(), |
||
| 162 |
- #' @return+ na_str = NA_character_, |
||
| 163 |
- #' * `a_surv_timepoint_diff()` returns the corresponding list with formatted [rtables::CellValue()].+ nested = TRUE, |
||
| 164 |
- #'+ .formats = NULL, |
||
| 165 |
- #' @keywords internal+ .aligns = NULL) {
|
||
| 166 | -+ | 10x |
- a_surv_timepoint_diff <- make_afun(+ if (lifecycle::is_present(na_level)) {
|
| 167 | -+ | ! |
- s_surv_timepoint_diff,+ lifecycle::deprecate_warn("0.9.1", "analyze_vars_in_cols(na_level)", "analyze_vars_in_cols(na_str)")
|
| 168 | -+ | ! |
- .formats = c(+ na_str <- na_level |
| 169 |
- rate_diff = "xx.xx",+ } |
||
| 170 |
- rate_diff_ci = "(xx.xx, xx.xx)",+ |
||
| 171 | -+ | 10x |
- ztest_pval = "x.xxxx | (<0.0001)"+ checkmate::assert_string(na_str, na.ok = TRUE, null.ok = TRUE) |
| 172 | -+ | 10x |
- )+ checkmate::assert_character(row_labels, null.ok = TRUE) |
| 173 | -+ | 10x |
- )+ checkmate::assert_int(.indent_mods, null.ok = TRUE) |
| 174 | -+ | 10x |
-
+ checkmate::assert_flag(nested) |
| 175 | -+ | 10x |
- #' @describeIn survival_timepoint Layout-creating function which can take statistics function arguments+ checkmate::assert_flag(split_col_vars) |
| 176 | -+ | 10x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ checkmate::assert_flag(do_summarize_row_groups) |
| 177 |
- #'+ |
||
| 178 |
- #' @param method (`string`)\cr either `surv` (survival estimations),+ # Filtering |
||
| 179 | -+ | 10x |
- #' `surv_diff` (difference in survival with the control) or `both`.+ met_grps <- paste0("analyze_vars", c("_numeric", "_counts"))
|
| 180 | -+ | 10x |
- #' @param table_names_suffix (`string`)\cr optional suffix for the `table_names` used for the `rtables` to+ .stats <- get_stats(met_grps, stats_in = .stats) |
| 181 | -+ | 10x |
- #' avoid warnings from duplicate table names.+ formats_v <- get_formats_from_stats(stats = .stats, formats_in = .formats) |
| 182 | -+ | 10x |
- #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ labels_v <- get_labels_from_stats(stats = .stats, labels_in = .labels) |
| 183 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ |
||
| 184 |
- #' for that statistic's row label.+ # Check for vars in the case that one or more are used |
||
| 185 | -+ | 10x |
- #'+ if (length(vars) == 1) {
|
| 186 | -+ | 7x |
- #' @return+ vars <- rep(vars, length(.stats)) |
| 187 | -+ | 3x |
- #' * `surv_timepoint()` returns a layout object suitable for passing to further layouting functions,+ } else if (length(vars) != length(.stats)) {
|
| 188 | -+ | 1x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ stop( |
| 189 | -+ | 1x |
- #' the statistics from `s_surv_timepoint()` and/or `s_surv_timepoint_diff()` to the table layout depending on+ "Analyzed variables (vars) does not have the same ", |
| 190 | -+ | 1x |
- #' the value of `method`.+ "number of elements of specified statistics (.stats)." |
| 191 |
- #'+ ) |
||
| 192 |
- #' @examples+ } |
||
| 193 |
- #' # Survival at given time points.+ |
||
| 194 | -+ | 9x |
- #' basic_table() %>%+ if (split_col_vars) {
|
| 195 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ # Checking there is not a previous identical column split |
||
| 196 | -+ | 8x |
- #' add_colcounts() %>%+ clyt <- tail(clayout(lyt), 1)[[1]] |
| 197 |
- #' surv_timepoint(+ |
||
| 198 | -+ | 8x |
- #' vars = "AVAL",+ dummy_lyt <- split_cols_by_multivar( |
| 199 | -+ | 8x |
- #' var_labels = "Months",+ lyt = basic_table(), |
| 200 | -+ | 8x |
- #' is_event = "is_event",+ vars = vars, |
| 201 | -+ | 8x |
- #' time_point = 7+ varlabels = labels_v |
| 202 |
- #' ) %>%+ ) |
||
| 203 |
- #' build_table(df = adtte_f)+ |
||
| 204 | -+ | 8x |
- #'+ if (any(sapply(clyt, identical, y = get_last_col_split(dummy_lyt)))) {
|
| 205 | -+ | ! |
- #' # Difference in survival at given time points.+ stop( |
| 206 | -+ | ! |
- #' basic_table() %>%+ "Column split called again with the same values. ", |
| 207 | -+ | ! |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ "This can create many unwanted columns. Please consider adding ", |
| 208 | -+ | ! |
- #' add_colcounts() %>%+ "split_col_vars = FALSE to the last call of ", |
| 209 | -+ | ! |
- #' surv_timepoint(+ deparse(sys.calls()[[sys.nframe() - 1]]), "." |
| 210 |
- #' vars = "AVAL",+ ) |
||
| 211 |
- #' var_labels = "Months",+ } |
||
| 212 |
- #' is_event = "is_event",+ |
||
| 213 |
- #' time_point = 9,+ # Main col split |
||
| 214 | -+ | 8x |
- #' method = "surv_diff",+ lyt <- split_cols_by_multivar( |
| 215 | -+ | 8x |
- #' .indent_mods = c("rate_diff" = 0L, "rate_diff_ci" = 2L, "ztest_pval" = 2L)
+ lyt = lyt, |
| 216 | -+ | 8x |
- #' ) %>%+ vars = vars, |
| 217 | -+ | 8x |
- #' build_table(df = adtte_f)+ varlabels = labels_v |
| 218 |
- #'+ ) |
||
| 219 |
- #' # Survival and difference in survival at given time points.+ } |
||
| 220 |
- #' basic_table() %>%+ |
||
| 221 | -+ | 9x |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ env <- new.env() # create caching environment |
| 222 |
- #' add_colcounts() %>%+ |
||
| 223 | -+ | 9x |
- #' surv_timepoint(+ if (do_summarize_row_groups) {
|
| 224 | -+ | 2x |
- #' vars = "AVAL",+ if (length(unique(vars)) > 1) {
|
| 225 | -+ | ! |
- #' var_labels = "Months",+ stop("When using do_summarize_row_groups only one label level var should be inserted.")
|
| 226 |
- #' is_event = "is_event",+ } |
||
| 227 |
- #' time_point = 9,+ |
||
| 228 |
- #' method = "both"+ # Function list for do_summarize_row_groups. Slightly different handling of labels |
||
| 229 | -+ | 2x |
- #' ) %>%+ cfun_list <- Map( |
| 230 | -+ | 2x |
- #' build_table(df = adtte_f)+ function(stat, use_cache, cache_env) {
|
| 231 | -+ | 12x |
- #'+ function(u, .spl_context, labelstr, .df_row, ...) {
|
| 232 |
- #' @export+ # Statistic |
||
| 233 | -+ | 24x |
- surv_timepoint <- function(lyt,+ var_row_val <- paste( |
| 234 | -+ | 24x |
- vars,+ gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
|
| 235 | -+ | 24x |
- nested = TRUE,+ paste(.spl_context$value, collapse = "_"), |
| 236 | -+ | 24x |
- ...,+ sep = "_" |
| 237 |
- table_names_suffix = "",+ ) |
||
| 238 | -+ | 24x |
- var_labels = "Time",+ if (use_cache) {
|
| 239 | -+ | ! |
- show_labels = "visible",+ if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...) |
| 240 | -+ | ! |
- method = c("surv", "surv_diff", "both"),
+ x_stats <- cache_env[[var_row_val]] |
| 241 |
- .stats = c(+ } else {
|
||
| 242 | -+ | 24x |
- "pt_at_risk", "event_free_rate", "rate_ci",+ x_stats <- s_summary(u, ...) |
| 243 |
- "rate_diff", "rate_diff_ci", "ztest_pval"+ } |
||
| 244 |
- ),+ |
||
| 245 | -+ | 24x |
- .formats = NULL,+ if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
|
| 246 | -+ | 24x |
- .labels = NULL,+ res <- x_stats[[stat]] |
| 247 |
- .indent_mods = if (method == "both") {
+ } else {
|
||
| 248 | -1x | +! |
- c(rate_diff = 1L, rate_diff_ci = 2L, ztest_pval = 2L)+ res_imp <- imputation_rule( |
| 249 | -+ | ! |
- } else {
+ .df_row, x_stats, stat, |
| 250 | -4x | +! |
- c(rate_diff_ci = 1L, ztest_pval = 1L)+ imp_rule = imp_rule, post = as.numeric(tail(.spl_context$value, 1)) > 0, avalcat_var = avalcat_var |
| 251 |
- }) {
+ ) |
||
| 252 | -5x | +! |
- method <- match.arg(method)+ res <- res_imp[["val"]] |
| 253 | -5x | +! |
- checkmate::assert_string(table_names_suffix)+ na_str <- res_imp[["na_str"]] |
| 254 |
-
+ } |
||
| 255 | -5x | +
- f <- list(+ |
|
| 256 | -5x | +
- surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
+ # Label check and replacement |
|
| 257 | -5x | +24x |
- surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
+ if (length(row_labels) > 1) {
|
| 258 | -+ | 12x |
- )+ if (!(labelstr %in% names(row_labels))) {
|
| 259 | -5x | +! |
- .stats <- h_split_param(.stats, .stats, f = f)+ stop( |
| 260 | -5x | +! |
- .formats <- h_split_param(.formats, names(.formats), f = f)+ "Replacing the labels in do_summarize_row_groups needs a named vector", |
| 261 | -5x | +! |
- .labels <- h_split_param(.labels, names(.labels), f = f)+ "that contains the split values. In the current split variable ", |
| 262 | -5x | +! |
- .indent_mods <- h_split_param(.indent_mods, names(.indent_mods), f = f)+ .spl_context$split[nrow(.spl_context)], |
| 263 | -+ | ! |
-
+ " the labelstr value (split value by default) ", labelstr, " is not in", |
| 264 | -5x | +! |
- afun_surv <- make_afun(+ " row_labels names: ", names(row_labels) |
| 265 | -5x | +
- a_surv_timepoint,+ ) |
|
| 266 | -5x | +
- .stats = .stats$surv,+ } |
|
| 267 | -5x | +12x |
- .formats = .formats$surv,+ lbl <- unlist(row_labels[labelstr]) |
| 268 | -5x | +
- .labels = .labels$surv,+ } else {
|
|
| 269 | -5x | +12x |
- .indent_mods = .indent_mods$surv+ lbl <- labelstr |
| 270 |
- )+ } |
||
| 272 | -5x | +
- afun_surv_diff <- make_afun(+ # Cell creation |
|
| 273 | -5x | +24x |
- a_surv_timepoint_diff,+ rcell(res, |
| 274 | -5x | +24x |
- .stats = .stats$surv_diff,+ label = lbl, |
| 275 | -5x | +24x |
- .formats = .formats$surv_diff,+ format = formats_v[names(formats_v) == stat][[1]], |
| 276 | -5x | +24x |
- .labels = .labels$surv_diff,+ format_na_str = na_str, |
| 277 | -5x | +24x |
- .indent_mods = .indent_mods$surv_diff+ indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods), |
| 278 | -+ | 24x |
- )+ align = .aligns |
| 279 |
-
+ ) |
||
| 280 | -5x | +
- time_point <- list(...)$time_point+ } |
|
| 281 |
-
+ }, |
||
| 282 | -5x | +2x |
- for (i in seq_along(time_point)) {
+ stat = .stats, |
| 283 | -5x | +2x |
- tpt <- time_point[i]+ use_cache = cache, |
| 284 | -+ | 2x |
-
+ cache_env = replicate(length(.stats), env) |
| 285 | -5x | +
- if (method %in% c("surv", "both")) {
+ ) |
|
| 286 | -3x | +
- lyt <- analyze(+ |
|
| 287 | -3x | +
- lyt,+ # Main call to rtables |
|
| 288 | -3x | +2x |
- vars,+ summarize_row_groups( |
| 289 | -3x | +2x |
- var_labels = paste(tpt, var_labels),+ lyt = lyt, |
| 290 | -3x | +2x |
- table_names = paste0("surv_", tpt, table_names_suffix),
+ var = unique(vars), |
| 291 | -3x | +2x |
- show_labels = show_labels,+ cfun = cfun_list, |
| 292 | -3x | +2x |
- afun = afun_surv,+ na_str = na_str, |
| 293 | -3x | +2x |
- nested = nested,+ extra_args = list(...) |
| 294 | -3x | +
- extra_args = list(+ ) |
|
| 295 | -3x | +
- is_event = list(...)$is_event,+ } else {
|
|
| 296 | -3x | +
- control = list(...)$control,+ # Function list for analyze_colvars |
|
| 297 | -3x | +7x |
- time_point = tpt+ afun_list <- Map( |
| 298 | -+ | 7x |
- )+ function(stat, use_cache, cache_env) {
|
| 299 | -+ | 32x |
- )+ function(u, .spl_context, .df_row, ...) {
|
| 300 |
- }+ # Main statistics |
||
| 301 | -+ | 210x |
-
+ var_row_val <- paste( |
| 302 | -5x | +210x |
- if (method %in% c("surv_diff", "both")) {
+ gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
|
| 303 | -3x | +210x |
- lyt <- analyze(+ paste(.spl_context$value, collapse = "_"), |
| 304 | -3x | +210x |
- lyt,+ sep = "_" |
| 305 | -3x | +
- vars,+ ) |
|
| 306 | -3x | +210x |
- var_labels = paste(tpt, var_labels),+ if (use_cache) {
|
| 307 | -3x | +16x |
- table_names = paste0("surv_diff_", tpt, table_names_suffix),
+ if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...) |
| 308 | -3x | +56x |
- show_labels = ifelse(method == "both", "hidden", show_labels),+ x_stats <- cache_env[[var_row_val]] |
| 309 | -3x | +
- afun = afun_surv_diff,+ } else {
|
|
| 310 | -3x | +154x |
- nested = nested,+ x_stats <- s_summary(u, ...) |
| 311 | -3x | +
- extra_args = list(+ } |
|
| 312 | -3x | +
- is_event = list(...)$is_event,+ |
|
| 313 | -3x | +210x |
- control = list(...)$control,+ if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
|
| 314 | -3x | +170x |
- time_point = tpt+ res <- x_stats[[stat]] |
| 315 |
- )+ } else {
|
||
| 316 | -+ | 40x |
- )+ res_imp <- imputation_rule( |
| 317 | -+ | 40x |
- }+ .df_row, x_stats, stat, |
| 318 | -+ | 40x |
- }+ imp_rule = imp_rule, post = as.numeric(tail(.spl_context$value, 1)) > 0, avalcat_var = avalcat_var |
| 319 | -5x | +
- lyt+ ) |
|
| 320 | -+ | 40x |
- }+ res <- res_imp[["val"]] |
| 1 | -+ | |||
| 321 | +40x |
- #' Convert Table into Matrix of Strings+ na_str <- res_imp[["na_str"]] |
||
| 2 | +322 |
- #'+ } |
||
| 3 | +323 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 4 | -+ | |||
| 324 | +210x |
- #'+ if (is.list(res)) {
|
||
| 5 | -+ | |||
| 325 | +19x |
- #' Helper function to use mostly within tests. `with_spaces`parameter allows+ if (length(res) > 1) {
|
||
| 6 | -+ | |||
| 326 | +1x |
- #' to test not only for content but also indentation and table structure.+ stop("The analyzed column produced more than one category of results.")
|
||
| 7 | +327 |
- #' `print_txt_to_copy` instead facilitate the testing development by returning a well+ } else {
|
||
| 8 | -+ | |||
| 328 | +18x |
- #' formatted text that needs only to be copied and pasted in the expected output.+ res <- unlist(res) |
||
| 9 | +329 |
- #'+ } |
||
| 10 | +330 |
- #' @param x `rtables` table.+ } |
||
| 11 | +331 |
- #' @param with_spaces Should the tested table keep the indentation and other relevant spaces?+ |
||
| 12 | +332 |
- #' @param print_txt_to_copy Utility to have a way to copy the input table directly+ # Label from context |
||
| 13 | -+ | |||
| 333 | +209x |
- #' into the expected variable instead of copying it too manually.+ label_from_context <- .spl_context$value[nrow(.spl_context)] |
||
| 14 | +334 |
- #'+ |
||
| 15 | +335 |
- #' @return A `matrix` of `string`s.+ # Label switcher |
||
| 16 | -+ | |||
| 336 | +209x |
- #'+ if (is.null(row_labels)) {
|
||
| 17 | -+ | |||
| 337 | +149x |
- #' @export+ lbl <- label_from_context |
||
| 18 | +338 |
- to_string_matrix <- function(x, with_spaces = FALSE, print_txt_to_copy = FALSE) {
+ } else {
|
||
| 19 | -5x | +339 | +60x |
- checkmate::assert_flag(with_spaces)+ if (length(row_labels) > 1) {
|
| 20 | -5x | +340 | +48x |
- checkmate::assert_flag(print_txt_to_copy)+ if (!(label_from_context %in% names(row_labels))) {
|
| 21 | -+ | |||
| 341 | +! |
-
+ stop( |
||
| 22 | -+ | |||
| 342 | +! |
- # Producing the matrix to test+ "Replacing the labels in do_summarize_row_groups needs a named vector", |
||
| 23 | -5x | +|||
| 343 | +! |
- if (with_spaces) {
+ "that contains the split values. In the current split variable ", |
||
| 24 | +344 | ! |
- out <- strsplit(toString(matrix_form(x, TRUE)), "\\n")[[1]]+ .spl_context$split[nrow(.spl_context)], |
|
| 25 | -+ | |||
| 345 | +! |
- } else {
+ " the split value ", label_from_context, " is not in", |
||
| 26 | -5x | +|||
| 346 | +! |
- out <- matrix_form(x)$string+ " row_labels names: ", names(row_labels) |
||
| 27 | +347 |
- }+ ) |
||
| 28 | +348 |
-
+ }+ |
+ ||
| 349 | +48x | +
+ lbl <- unlist(row_labels[label_from_context]) |
||
| 29 | +350 |
- # Printing to console formatted output that needs to be copied in "expected"+ } else {
|
||
| 30 | -5x | +351 | +12x |
- if (print_txt_to_copy) {
+ lbl <- row_labels |
| 31 | -! | +|||
| 352 | +
- out_tmp <- out+ } |
|||
| 32 | -! | +|||
| 353 | +
- if (!with_spaces) {
+ } |
|||
| 33 | -! | +|||
| 354 | +
- out_tmp <- apply(out, 1, paste0, collapse = '", "')+ |
|||
| 34 | +355 |
- }+ # Cell creation |
||
| 35 | -! | +|||
| 356 | +209x |
- cat(paste0('c(\n "', paste0(out_tmp, collapse = '",\n "'), '"\n)'))
+ rcell(res, |
||
| 36 | -+ | |||
| 357 | +209x |
- }+ label = lbl, |
||
| 37 | -+ | |||
| 358 | +209x |
-
+ format = formats_v[names(formats_v) == stat][[1]], |
||
| 38 | -+ | |||
| 359 | +209x |
- # Return values+ format_na_str = na_str, |
||
| 39 | -5x | +360 | +209x |
- return(out)+ indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods), |
| 40 | -+ | |||
| 361 | +209x |
- }+ align = .aligns |
||
| 41 | +362 |
-
+ ) |
||
| 42 | +363 |
- #' Blank for Missing Input+ } |
||
| 43 | +364 |
- #'+ }, |
||
| 44 | -+ | |||
| 365 | +7x |
- #' Helper function to use in tabulating model results.+ stat = .stats, |
||
| 45 | -+ | |||
| 366 | +7x |
- #'+ use_cache = cache, |
||
| 46 | -+ | |||
| 367 | +7x |
- #' @param x (`vector`)\cr input for a cell.+ cache_env = replicate(length(.stats), env) |
||
| 47 | +368 |
- #'+ ) |
||
| 48 | +369 |
- #' @return An empty `character` vector if all entries in `x` are missing (`NA`), otherwise+ |
||
| 49 | +370 |
- #' the unlisted version of `x`.+ # Main call to rtables |
||
| 50 | -+ | |||
| 371 | +7x |
- #'+ analyze_colvars(lyt,+ |
+ ||
| 372 | +7x | +
+ afun = afun_list,+ |
+ ||
| 373 | +7x | +
+ nested = nested,+ |
+ ||
| 374 | +7x | +
+ extra_args = list(...) |
||
| 51 | +375 |
- #' @keywords internal+ ) |
||
| 52 | +376 |
- unlist_and_blank_na <- function(x) {
+ } |
||
| 53 | -267x | +|||
| 377 | +
- unl <- unlist(x)+ } |
|||
| 54 | -267x | +|||
| 378 | +
- if (all(is.na(unl))) {
+
|
|||
| 55 | -161x | +|||
| 379 | +
- character()+ # Help function |
|||
| 56 | +380 |
- } else {
+ get_last_col_split <- function(lyt) {
|
||
| 57 | -106x | +381 | +1x |
- unl+ tail(tail(clayout(lyt), 1)[[1]], 1)[[1]] |
| 58 | +382 |
- }+ } |
| 59 | +1 |
- }+ #' Line plot with the optional table |
||
| 60 | +2 |
-
+ #' |
||
| 61 | +3 |
- #' Constructor for Content Functions given Data Frame with Flag Input+ #' @description `r lifecycle::badge("stable")`
|
||
| 62 | +4 |
#' |
||
| 63 | +5 |
- #' This can be useful for tabulating model results.+ #' Line plot with the optional table. |
||
| 64 | +6 |
#' |
||
| 65 | +7 |
- #' @param analysis_var (`string`)\cr variable name for the column containing values to be returned by the+ #' @param df (`data.frame`)\cr data set containing all analysis variables. |
||
| 66 | +8 |
- #' content function.+ #' @param alt_counts_df (`data.frame` or `NULL`)\cr data set that will be used (only) to counts objects in strata. |
||
| 67 | +9 |
- #' @param flag_var (`string`)\cr variable name for the logical column identifying which row should be returned.+ #' @param variables (named `character` vector) of variable names in `df` data set. Details are: |
||
| 68 | +10 |
- #' @param format (`string`)\cr `rtables` format to use.+ #' * `x` (`character`)\cr name of x-axis variable. |
||
| 69 | +11 |
- #'+ #' * `y` (`character`)\cr name of y-axis variable. |
||
| 70 | +12 |
- #' @return A content function which gives `df$analysis_var` at the row identified by+ #' * `strata` (`character`)\cr name of grouping variable, i.e. treatment arm. Can be `NA` to indicate lack of groups. |
||
| 71 | +13 |
- #' `.df_row$flag` in the given format.+ #' * `paramcd` (`character`)\cr name of the variable for parameter's code. Used for y-axis label and plot's subtitle. |
||
| 72 | +14 |
- #'+ #' Can be `NA` if `paramcd` is not to be added to the y-axis label or subtitle. |
||
| 73 | +15 |
- #' @keywords internal+ #' * `y_unit` (`character`)\cr name of variable with units of `y`. Used for y-axis label and plot's subtitle. |
||
| 74 | +16 |
- cfun_by_flag <- function(analysis_var,+ #' Can be `NA` if y unit is not to be added to the y-axis label or subtitle. |
||
| 75 | +17 |
- flag_var,+ #' @param mid (`character` or `NULL`)\cr names of the statistics that will be plotted as midpoints. |
||
| 76 | +18 |
- format = "xx",+ #' All the statistics indicated in `mid` variable must be present in the object returned by `sfun`, |
||
| 77 | +19 |
- .indent_mods = NULL) {
+ #' and be of a `double` or `numeric` type vector of length one. |
||
| 78 | -61x | +|||
| 20 | +
- checkmate::assert_string(analysis_var)+ #' @param interval (`character` or `NULL`)\cr names of the statistics that will be plotted as intervals. |
|||
| 79 | -61x | +|||
| 21 | +
- checkmate::assert_string(flag_var)+ #' All the statistics indicated in `interval` variable must be present in the object returned by `sfun`, |
|||
| 80 | -61x | +|||
| 22 | +
- function(df, labelstr) {
+ #' and be of a `double` or `numeric` type vector of length two. |
|||
| 81 | -265x | +|||
| 23 | +
- row_index <- which(df[[flag_var]])+ #' @param whiskers (`character`)\cr names of the interval whiskers that will be plotted. Must match the `names` |
|||
| 82 | -265x | +|||
| 24 | +
- x <- unlist_and_blank_na(df[[analysis_var]][row_index])+ #' attribute of the `interval` element in the list returned by `sfun`. It is possible to specify one whisker only, |
|||
| 83 | -265x | +|||
| 25 | +
- formatters::with_label(+ #' lower or upper. |
|||
| 84 | -265x | +|||
| 26 | +
- rcell(x, format = format, indent_mod = .indent_mods),+ #' @param table (`character` or `NULL`)\cr names of the statistics that will be displayed in the table below the plot. |
|||
| 85 | -265x | +|||
| 27 | +
- labelstr+ #' All the statistics indicated in `table` variable must be present in the object returned by `sfun`. |
|||
| 86 | +28 |
- )+ #' @param sfun (`closure`)\cr the function to compute the values of required statistics. It must return a named `list` |
||
| 87 | +29 |
- }+ #' with atomic vectors. The names of the `list` elements refer to the names of the statistics and are used by `mid`, |
||
| 88 | +30 |
- }+ #' `interval`, `table`. It must be able to accept as input a vector with data for which statistics are computed. |
||
| 89 | +31 |
-
+ #' @param ... optional arguments to `sfun`. |
||
| 90 | +32 |
- #' Content Row Function to Add Row Total to Labels+ #' @param mid_type (`character`)\cr controls the type of the `mid` plot, it can be point (`p`), line (`l`), |
||
| 91 | +33 |
- #'+ #' or point and line (`pl`). |
||
| 92 | +34 |
- #' This takes the label of the latest row split level and adds the row total from `df` in parentheses.+ #' @param mid_point_size (`integer` or `double`)\cr controls the font size of the point for `mid` plot. |
||
| 93 | +35 |
- #' This function differs from [c_label_n_alt()] by taking row counts from `df` rather than+ #' @param position (`character` or `call`)\cr geom element position adjustment, either as a string, or the result of |
||
| 94 | +36 |
- #' `alt_counts_df`, and is used by [add_rowcounts()] when `alt_counts` is set to `FALSE`.+ #' a call to a position adjustment function. |
||
| 95 | +37 |
- #'+ #' @param legend_title (`character` string)\cr legend title. |
||
| 96 | +38 |
- #' @inheritParams argument_convention+ #' @param legend_position (`character`)\cr the position of the plot legend (`none`, `left`, `right`, `bottom`, `top`, |
||
| 97 | +39 |
- #'+ #' or two-element numeric vector). |
||
| 98 | +40 |
- #' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label.+ #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot. |
||
| 99 | +41 |
- #'+ #' @param y_lab (`character`)\cr y-axis label. If equal to `NULL`, then no label will be added. |
||
| 100 | +42 |
- #' @note It is important here to not use `df` but rather `.N_row` in the implementation, because+ #' @param y_lab_add_paramcd (`logical`)\cr should `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` be added to the |
||
| 101 | +43 |
- #' the former is already split by columns and will refer to the first column of the data only.+ #' y-axis label `y_lab`? |
||
| 102 | +44 |
- #'+ #' @param y_lab_add_unit (`logical`)\cr should y unit, i.e. `unique(df[[variables["y_unit"]]])` be added to the y-axis |
||
| 103 | +45 |
- #' @seealso [c_label_n_alt()] which performs the same function but retrieves row counts from+ #' label `y_lab`? |
||
| 104 | +46 |
- #' `alt_counts_df` instead of `df`.+ #' @param title (`character`)\cr plot title. |
||
| 105 | +47 |
- #'+ #' @param subtitle (`character`)\cr plot subtitle. |
||
| 106 | +48 |
- #' @keywords internal+ #' @param subtitle_add_paramcd (`logical`)\cr should `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` be added to |
||
| 107 | +49 |
- c_label_n <- function(df,+ #' the plot's subtitle `subtitle`? |
||
| 108 | +50 |
- labelstr,+ #' @param subtitle_add_unit (`logical`)\cr should y unit, i.e. `unique(df[[variables["y_unit"]]])` be added to the |
||
| 109 | +51 |
- .N_row) { # nolint
+ #' plot's subtitle `subtitle`? |
||
| 110 | -270x | +|||
| 52 | +
- label <- paste0(labelstr, " (N=", .N_row, ")")+ #' @param caption (`character`)\cr optional caption below the plot. |
|||
| 111 | -270x | +|||
| 53 | +
- in_rows(+ #' @param table_format (named `character` or `NULL`)\cr format patterns for descriptive statistics used in the |
|||
| 112 | -270x | +|||
| 54 | +
- .list = list(row_count = formatters::with_label(c(.N_row, .N_row), label)),+ #' (optional) table appended to the plot. It is passed directly to the `h_format_row` function through the `format` |
|||
| 113 | -270x | +|||
| 55 | +
- .formats = c(row_count = function(x, ...) "")+ #' parameter. Names of `table_format` must match the names of statistics returned by `sfun` function. |
|||
| 114 | +56 |
- )+ #' @param table_labels (named `character` or `NULL`)\cr labels for descriptive statistics used in the (optional) table |
||
| 115 | +57 |
- }+ #' appended to the plot. Names of `table_labels` must match the names of statistics returned by `sfun` function. |
||
| 116 | +58 |
-
+ #' @param table_font_size (`integer` or `double`)\cr controls the font size of values in the table. |
||
| 117 | +59 |
- #' Content Row Function to Add `alt_counts_df` Row Total to Labels+ #' @param newpage (`logical`)\cr should plot be drawn on new page? |
||
| 118 | +60 |
- #'+ #' @param col (`character`)\cr colors. |
||
| 119 | +61 |
- #' This takes the label of the latest row split level and adds the row total from `alt_counts_df`+ #' |
||
| 120 | +62 |
- #' in parentheses. This function differs from [c_label_n()] by taking row counts from `alt_counts_df`+ #' @return A `ggplot` line plot (and statistics table if applicable). |
||
| 121 | +63 |
- #' rather than `df`, and is used by [add_rowcounts()] when `alt_counts` is set to `TRUE`.+ #' |
||
| 122 | +64 |
- #'+ #' @examples |
||
| 123 | +65 |
- #' @inheritParams argument_convention+ #' library(nestcolor) |
||
| 124 | +66 |
#' |
||
| 125 | +67 |
- #' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label.+ #' adsl <- tern_ex_adsl |
||
| 126 | +68 |
- #'+ #' adlb <- tern_ex_adlb %>% dplyr::filter(ANL01FL == "Y", PARAMCD == "ALT", AVISIT != "SCREENING") |
||
| 127 | +69 |
- #' @seealso [c_label_n()] which performs the same function but retrieves row counts from `df` instead+ #' adlb$AVISIT <- droplevels(adlb$AVISIT) |
||
| 128 | +70 |
- #' of `alt_counts_df`.+ #' adlb <- dplyr::mutate(adlb, AVISIT = forcats::fct_reorder(AVISIT, AVISITN, min)) |
||
| 129 | +71 |
#' |
||
| 130 | +72 |
- #' @keywords internal+ #' # Mean with CI |
||
| 131 | +73 |
- c_label_n_alt <- function(df,+ #' g_lineplot(adlb, adsl, subtitle = "Laboratory Test:") |
||
| 132 | +74 |
- labelstr,+ #' |
||
| 133 | +75 |
- .alt_df_row) {
- |
- ||
| 134 | -7x | -
- N_row_alt <- nrow(.alt_df_row) # nolint+ #' # Mean with CI, no stratification |
||
| 135 | -7x | +|||
| 76 | +
- label <- paste0(labelstr, " (N=", N_row_alt, ")")+ #' g_lineplot(adlb, variables = control_lineplot_vars(strata = NA)) |
|||
| 136 | -7x | +|||
| 77 | +
- in_rows(+ #' |
|||
| 137 | -7x | +|||
| 78 | +
- .list = list(row_count = formatters::with_label(c(N_row_alt, N_row_alt), label)),+ #' # Mean, upper whisker of CI, no strata counts N |
|||
| 138 | -7x | +|||
| 79 | +
- .formats = c(row_count = function(x, ...) "")+ #' g_lineplot( |
|||
| 139 | +80 |
- )+ #' adlb, |
||
| 140 | +81 |
- }+ #' whiskers = "mean_ci_upr", |
||
| 141 | +82 |
-
+ #' title = "Plot of Mean and Upper 95% Confidence Limit by Visit" |
||
| 142 | +83 |
- #' Layout Creating Function to Add Row Total Counts+ #' ) |
||
| 143 | +84 |
#' |
||
| 144 | +85 |
- #' @description `r lifecycle::badge("stable")`
+ #' # Median with CI |
||
| 145 | +86 |
- #'+ #' g_lineplot( |
||
| 146 | +87 |
- #' This works analogously to [rtables::add_colcounts()] but on the rows. This function+ #' adlb, |
||
| 147 | +88 |
- #' is a wrapper for [rtables::summarize_row_groups()].+ #' adsl, |
||
| 148 | +89 |
- #'+ #' mid = "median", |
||
| 149 | +90 |
- #' @inheritParams argument_convention+ #' interval = "median_ci", |
||
| 150 | +91 |
- #' @param alt_counts (`flag`)\cr whether row counts should be taken from `alt_counts_df` (`TRUE`)+ #' whiskers = c("median_ci_lwr", "median_ci_upr"),
|
||
| 151 | +92 |
- #' or from `df` (`FALSE`). Defaults to `FALSE`.+ #' title = "Plot of Median and 95% Confidence Limits by Visit" |
||
| 152 | +93 |
- #'+ #' ) |
||
| 153 | +94 |
- #' @return A modified layout where the latest row split labels now have the row-wise+ #' |
||
| 154 | +95 |
- #' total counts (i.e. without column-based subsetting) attached in parentheses.+ #' # Mean, +/- SD |
||
| 155 | +96 |
- #'+ #' g_lineplot(adlb, adsl, |
||
| 156 | +97 |
- #' @note Row count values are contained in these row count rows but are not displayed+ #' interval = "mean_sdi", |
||
| 157 | +98 |
- #' so that they are not considered zero rows by default when pruning.+ #' whiskers = c("mean_sdi_lwr", "mean_sdi_upr"),
|
||
| 158 | +99 |
- #'+ #' title = "Plot of Median +/- SD by Visit" |
||
| 159 | +100 |
- #' @examples+ #' ) |
||
| 160 | +101 |
- #' basic_table() %>%+ #' |
||
| 161 | +102 |
- #' split_cols_by("ARM") %>%
+ #' # Mean with CI plot with stats table |
||
| 162 | +103 |
- #' add_colcounts() %>%+ #' g_lineplot(adlb, adsl, table = c("n", "mean", "mean_ci"))
|
||
| 163 | +104 |
- #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
+ #' |
||
| 164 | +105 |
- #' add_rowcounts() %>%+ #' # Mean with CI, table and customized confidence level |
||
| 165 | +106 |
- #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>%
+ #' g_lineplot( |
||
| 166 | +107 |
- #' build_table(DM)+ #' adlb, |
||
| 167 | +108 |
- #'+ #' adsl, |
||
| 168 | +109 |
- #' @export+ #' table = c("n", "mean", "mean_ci"),
|
||
| 169 | +110 |
- add_rowcounts <- function(lyt, alt_counts = FALSE) {
+ #' control = control_analyze_vars(conf_level = 0.80), |
||
| 170 | -6x | +|||
| 111 | +
- summarize_row_groups(+ #' title = "Plot of Mean and 80% Confidence Limits by Visit" |
|||
| 171 | -6x | +|||
| 112 | +
- lyt,+ #' ) |
|||
| 172 | -6x | +|||
| 113 | +
- cfun = if (alt_counts) c_label_n_alt else c_label_n+ #' |
|||
| 173 | +114 |
- )+ #' # Mean with CI, table, filtered data |
||
| 174 | +115 |
- }+ #' adlb_f <- dplyr::filter(adlb, ARMCD != "ARM A" | AVISIT == "BASELINE") |
||
| 175 | +116 |
-
+ #' g_lineplot(adlb_f, table = c("n", "mean"))
|
||
| 176 | +117 |
- #' Obtain Column Indices+ #' |
||
| 177 | +118 |
- #'+ #' @export |
||
| 178 | +119 |
- #' @description `r lifecycle::badge("stable")`
+ g_lineplot <- function(df, |
||
| 179 | +120 |
- #'+ alt_counts_df = NULL, |
||
| 180 | +121 |
- #' Helper function to extract column indices from a `VTableTree` for a given+ variables = control_lineplot_vars(), |
||
| 181 | +122 |
- #' vector of column names.+ mid = "mean", |
||
| 182 | +123 |
- #'+ interval = "mean_ci", |
||
| 183 | +124 |
- #' @param table_tree (`VTableTree`)\cr table to extract the indices from.+ whiskers = c("mean_ci_lwr", "mean_ci_upr"),
|
||
| 184 | +125 |
- #' @param col_names (`character`)\cr vector of column names.+ table = NULL, |
||
| 185 | +126 |
- #'+ sfun = tern::s_summary, |
||
| 186 | +127 |
- #' @return A vector of column indices.+ ..., |
||
| 187 | +128 |
- #'+ mid_type = "pl", |
||
| 188 | +129 |
- #' @export+ mid_point_size = 2, |
||
| 189 | +130 |
- h_col_indices <- function(table_tree, col_names) {
+ position = ggplot2::position_dodge(width = 0.4), |
||
| 190 | -1232x | +|||
| 131 | +
- checkmate::assert_class(table_tree, "VTableNodeInfo")+ legend_title = NULL, |
|||
| 191 | -1232x | +|||
| 132 | +
- checkmate::assert_subset(col_names, names(attr(col_info(table_tree), "cextra_args")), empty.ok = FALSE)+ legend_position = "bottom", |
|||
| 192 | -1232x | +|||
| 133 | +
- match(col_names, names(attr(col_info(table_tree), "cextra_args")))+ ggtheme = nestcolor::theme_nest(), |
|||
| 193 | +134 |
- }+ y_lab = NULL, |
||
| 194 | +135 |
-
+ y_lab_add_paramcd = TRUE, |
||
| 195 | +136 |
- #' Labels or Names of List Elements+ y_lab_add_unit = TRUE, |
||
| 196 | +137 |
- #'+ title = "Plot of Mean and 95% Confidence Limits by Visit", |
||
| 197 | +138 |
- #' Internal helper function for working with nested statistic function results which typically+ subtitle = "", |
||
| 198 | +139 |
- #' don't have labels but names that we can use.+ subtitle_add_paramcd = TRUE, |
||
| 199 | +140 |
- #'+ subtitle_add_unit = TRUE, |
||
| 200 | +141 |
- #' @param x a list+ caption = NULL, |
||
| 201 | +142 |
- #'+ table_format = summary_formats(), |
||
| 202 | +143 |
- #' @return A `character` vector with the labels or names for the list elements.+ table_labels = summary_labels(), |
||
| 203 | +144 |
- #'+ table_font_size = 3, |
||
| 204 | +145 |
- #' @keywords internal+ newpage = TRUE, |
||
| 205 | +146 |
- labels_or_names <- function(x) {
+ col = NULL) {
|
||
| 206 | -119x | +147 | +2x |
- checkmate::assert_multi_class(x, c("data.frame", "list"))
+ checkmate::assert_character(variables, any.missing = TRUE) |
| 207 | -119x | +148 | +2x |
- labs <- sapply(x, obj_label)+ checkmate::assert_character(mid, null.ok = TRUE) |
| 208 | -119x | +149 | +2x |
- nams <- rlang::names2(x)+ checkmate::assert_character(interval, null.ok = TRUE) |
| 209 | -119x | +150 | +2x |
- label_is_null <- sapply(labs, is.null)+ checkmate::assert_character(col, null.ok = TRUE) |
| 210 | -119x | +|||
| 151 | +
- result <- unlist(ifelse(label_is_null, nams, labs))+ |
|||
| 211 | -119x | +152 | +2x |
- return(result)+ checkmate::assert_string(title, null.ok = TRUE) |
| 212 | -+ | |||
| 153 | +2x |
- }+ checkmate::assert_string(subtitle, null.ok = TRUE) |
||
| 213 | +154 | |||
| 214 | -+ | |||
| 155 | +2x |
- #' Convert to `rtable`+ if (is.character(interval)) {
|
||
| 215 | -+ | |||
| 156 | +2x |
- #'+ checkmate::assert_vector(whiskers, min.len = 0, max.len = 2) |
||
| 216 | +157 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 217 | +158 |
- #'+ |
||
| 218 | -+ | |||
| 159 | +2x |
- #' This is a new generic function to convert objects to `rtable` tables.+ if (length(whiskers) == 1) {
|
||
| 219 | -+ | |||
| 160 | +! |
- #'+ checkmate::assert_character(mid) |
||
| 220 | +161 |
- #' @param x the object which should be converted to an `rtable`.+ } |
||
| 221 | +162 |
- #' @param ... additional arguments for methods.+ |
||
| 222 | -+ | |||
| 163 | +2x |
- #'+ if (is.character(mid)) {
|
||
| 223 | -+ | |||
| 164 | +2x |
- #' @return An `rtables` table object. Note that the concrete class will depend on the method used.+ checkmate::assert_scalar(mid_type) |
||
| 224 | -+ | |||
| 165 | +2x |
- #'+ checkmate::assert_subset(mid_type, c("pl", "p", "l"))
|
||
| 225 | +166 |
- #' @export+ } |
||
| 226 | +167 |
- as.rtable <- function(x, ...) { # nolint
+
|
||
| 227 | -3x | +168 | +2x |
- UseMethod("as.rtable", x)
+ x <- variables[["x"]] |
| 228 | -+ | |||
| 169 | +2x |
- }+ y <- variables[["y"]] |
||
| 229 | -+ | |||
| 170 | +2x |
-
+ paramcd <- variables["paramcd"] # NA if paramcd == NA or it is not in variables |
||
| 230 | -+ | |||
| 171 | +2x |
- #' @describeIn as.rtable method for converting `data.frame` that contain numeric columns to `rtable`.+ y_unit <- variables["y_unit"] # NA if y_unit == NA or it is not in variables |
||
| 231 | -+ | |||
| 172 | +2x |
- #'+ if (is.na(variables["strata"])) {
|
||
| 232 | -+ | |||
| 173 | +! |
- #' @param format the format which should be used for the columns.+ strata <- NULL # NULL if strata == NA or it is not in variables |
||
| 233 | +174 |
- #'+ } else {
|
||
| 234 | -+ | |||
| 175 | +2x |
- #' @method as.rtable data.frame+ strata <- variables[["strata"]] |
||
| 235 | +176 |
- #'+ } |
||
| 236 | -+ | |||
| 177 | +2x |
- #' @examples+ checkmate::assert_flag(y_lab_add_paramcd, null.ok = TRUE) |
||
| 237 | -+ | |||
| 178 | +2x |
- #' x <- data.frame(+ checkmate::assert_flag(subtitle_add_paramcd, null.ok = TRUE) |
||
| 238 | -+ | |||
| 179 | +2x |
- #' a = 1:10,+ if ((!is.null(y_lab) && y_lab_add_paramcd) || (!is.null(subtitle) && subtitle_add_paramcd)) {
|
||
| 239 | -+ | |||
| 180 | +2x |
- #' b = rnorm(10)+ checkmate::assert_false(is.na(paramcd)) |
||
| 240 | -+ | |||
| 181 | +2x |
- #' )+ checkmate::assert_scalar(unique(df[[paramcd]])) |
||
| 241 | +182 |
- #' as.rtable(x)+ } |
||
| 242 | +183 |
- #'+ |
||
| 243 | -+ | |||
| 184 | +2x |
- #' @export+ checkmate::assert_flag(y_lab_add_unit, null.ok = TRUE) |
||
| 244 | -+ | |||
| 185 | +2x |
- as.rtable.data.frame <- function(x, format = "xx.xx", ...) {
+ checkmate::assert_flag(subtitle_add_unit, null.ok = TRUE) |
||
| 245 | -3x | +186 | +2x |
- checkmate::assert_numeric(unlist(x))+ if ((!is.null(y_lab) && y_lab_add_unit) || (!is.null(subtitle) && subtitle_add_unit)) {
|
| 246 | +187 | 2x |
- do.call(+ checkmate::assert_false(is.na(y_unit)) |
|
| 247 | +188 | 2x |
- rtable,+ checkmate::assert_scalar(unique(df[[y_unit]])) |
|
| 248 | -2x | +|||
| 189 | +
- c(+ } |
|||
| 249 | -2x | +|||
| 190 | +
- list(+ |
|||
| 250 | +191 | 2x |
- header = labels_or_names(x),+ if (!is.null(strata) && !is.null(alt_counts_df)) {
|
|
| 251 | +192 | 2x |
- format = format+ checkmate::assert_set_equal(unique(alt_counts_df[[strata]]), unique(df[[strata]])) |
|
| 252 | +193 |
- ),+ } |
||
| 253 | -2x | +|||
| 194 | +
- Map(+ |
|||
| 254 | -2x | +|||
| 195 | +
- function(row, row_name) {
+ ####################################### | |
|||
| 255 | -20x | +|||
| 196 | +
- do.call(+ # ---- Compute required statistics ---- |
|||
| 256 | -20x | +|||
| 197 | +
- rrow,+ ####################################### | |
|||
| 257 | -20x | +198 | +2x |
- c(as.list(unname(row)),+ if (!is.null(strata)) {
|
| 258 | -20x | +199 | +2x |
- row.name = row_name+ df_grp <- tidyr::expand(df, .data[[strata]], .data[[x]]) # expand based on levels of factors |
| 259 | +200 |
- )+ } else {
|
||
| 260 | -+ | |||
| 201 | +! |
- )+ df_grp <- tidyr::expand(df, NULL, .data[[x]]) |
||
| 261 | +202 |
- },+ } |
||
| 262 | +203 | 2x |
- row = as.data.frame(t(x)),+ df_grp <- df_grp %>% |
|
| 263 | +204 | 2x |
- row_name = rownames(x)+ dplyr::full_join(y = df[, c(strata, x, y)], by = c(strata, x), multiple = "all") %>% |
|
| 264 | -+ | |||
| 205 | +2x |
- )+ dplyr::group_by_at(c(strata, x)) |
||
| 265 | +206 |
- )+ |
||
| 266 | -+ | |||
| 207 | +2x |
- )+ df_stats <- df_grp %>% |
||
| 267 | -+ | |||
| 208 | +2x |
- }+ dplyr::summarise( |
||
| 268 | -+ | |||
| 209 | +2x |
-
+ data.frame(t(do.call(c, unname(sfun(.data[[y]], ...)[c(mid, interval)])))), |
||
| 269 | -+ | |||
| 210 | +2x |
- #' Split parameters+ .groups = "drop" |
||
| 270 | +211 |
- #'+ ) |
||
| 271 | +212 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 272 | -+ | |||
| 213 | +2x |
- #'+ df_stats <- df_stats[!is.na(df_stats[[mid]]), ] |
||
| 273 | +214 |
- #' It divides the data in the vector `param` into the groups defined by `f` based on specified `values`. It is relevant+ |
||
| 274 | +215 |
- #' in `rtables` layers so as to distribute parameters `.stats` or' `.formats` into lists with items corresponding to+ # add number of objects N in strata |
||
| 275 | -+ | |||
| 216 | +2x |
- #' specific analysis function.+ if (!is.null(strata) && !is.null(alt_counts_df)) {
|
||
| 276 | -+ | |||
| 217 | +2x |
- #'+ strata_N <- paste0(strata, "_N") # nolint |
||
| 277 | +218 |
- #' @param param (`vector`)\cr the parameter to be split.+ |
||
| 278 | -+ | |||
| 219 | +2x |
- #' @param value (`vector`)\cr the value used to split.+ df_N <- as.data.frame(table(alt_counts_df[[strata]], exclude = c(NA, NaN, Inf))) # nolint |
||
| 279 | -+ | |||
| 220 | +2x |
- #' @param f (`list` of `vectors`)\cr the reference to make the split+ colnames(df_N) <- c(strata, "N") # nolint |
||
| 280 | -+ | |||
| 221 | +2x |
- #'+ df_N[[strata_N]] <- paste0(df_N[[strata]], " (N = ", df_N$N, ")") # nolint |
||
| 281 | +222 |
- #' @return A named `list` with the same element names as `f`, each containing the elements specified in `.stats`.+ |
||
| 282 | +223 |
- #'+ # strata_N should not be in clonames(df_stats) |
||
| 283 | -+ | |||
| 224 | +2x |
- #' @examples+ checkmate::assert_disjunct(strata_N, colnames(df_stats)) |
||
| 284 | +225 |
- #' f <- list(+ |
||
| 285 | -+ | |||
| 226 | +2x |
- #' surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
+ df_stats <- merge(x = df_stats, y = df_N[, c(strata, strata_N)], by = strata) |
||
| 286 | -+ | |||
| 227 | +! |
- #' surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
+ } else if (!is.null(strata)) {
|
||
| 287 | -+ | |||
| 228 | +! |
- #' )+ strata_N <- strata # nolint |
||
| 288 | +229 |
- #'+ } else {
|
||
| 289 | -+ | |||
| 230 | +! |
- #' .stats <- c("pt_at_risk", "rate_diff")
+ strata_N <- NULL # nolint |
||
| 290 | +231 |
- #' h_split_param(.stats, .stats, f = f)+ } |
||
| 291 | +232 |
- #'+ |
||
| 292 | +233 |
- #' # $surv+ ############################################### | |
||
| 293 | +234 |
- #' # [1] "pt_at_risk"+ # ---- Prepare certain plot's properties. ---- |
||
| 294 | +235 |
- #' #+ ############################################### | |
||
| 295 | +236 |
- #' # $surv_diff+ # legend title |
||
| 296 | -+ | |||
| 237 | +2x |
- #' # [1] "rate_diff"+ if (is.null(legend_title) && !is.null(strata) && legend_position != "none") {
|
||
| 297 | -+ | |||
| 238 | +2x |
- #'+ legend_title <- attr(df[[strata]], "label") |
||
| 298 | +239 |
- #' .formats <- c("pt_at_risk" = "xx", "event_free_rate" = "xxx")
+ } |
||
| 299 | +240 |
- #' h_split_param(.formats, names(.formats), f = f)+ |
||
| 300 | +241 |
- #'+ # y label |
||
| 301 | -+ | |||
| 242 | +2x |
- #' # $surv+ if (!is.null(y_lab)) {
|
||
| 302 | -+ | |||
| 243 | +1x |
- #' # pt_at_risk event_free_rate+ if (y_lab_add_paramcd) {
|
||
| 303 | -+ | |||
| 244 | +1x |
- #' # "xx" "xxx"+ y_lab <- paste(y_lab, unique(df[[paramcd]])) |
||
| 304 | +245 |
- #' #+ } |
||
| 305 | +246 |
- #' # $surv_diff+ |
||
| 306 | -+ | |||
| 247 | +1x |
- #' # NULL+ if (y_lab_add_unit) {
+ |
+ ||
| 248 | +1x | +
+ y_lab <- paste0(y_lab, " (", unique(df[[y_unit]]), ")")
|
||
| 307 | +249 |
- #'+ } |
||
| 308 | +250 |
- #' @export+ + |
+ ||
| 251 | +1x | +
+ y_lab <- trimws(y_lab) |
||
| 309 | +252 |
- h_split_param <- function(param,+ } |
||
| 310 | +253 |
- value,+ |
||
| 311 | +254 |
- f) {
+ # subtitle |
||
| 312 | -21x | +255 | +2x |
- y <- lapply(f, function(x) param[value %in% x])+ if (!is.null(subtitle)) {
|
| 313 | -21x | +256 | +2x |
- lapply(y, function(x) if (length(x) == 0) NULL else x)+ if (subtitle_add_paramcd) {
|
| 314 | -+ | |||
| 257 | +2x |
- }+ subtitle <- paste(subtitle, unique(df[[paramcd]])) |
||
| 315 | +258 |
-
+ } |
||
| 316 | +259 |
- #' Get Selected Statistics Names+ |
||
| 317 | -+ | |||
| 260 | +2x |
- #'+ if (subtitle_add_unit) {
|
||
| 318 | -+ | |||
| 261 | +2x |
- #' Helper function to be used for creating `afun`.+ subtitle <- paste0(subtitle, " (", unique(df[[y_unit]]), ")")
|
||
| 319 | +262 |
- #'+ } |
||
| 320 | +263 |
- #' @param .stats (`vector` or `NULL`)\cr input to the layout creating function. Note that `NULL` means+ |
||
| 321 | -+ | |||
| 264 | +2x |
- #' in this context that all default statistics should be used.+ subtitle <- trimws(subtitle) |
||
| 322 | +265 |
- #' @param all_stats (`character`)\cr all statistics which can be selected here potentially.+ } |
||
| 323 | +266 |
- #'+ |
||
| 324 | +267 |
- #' @return A `character` vector with the selected statistics.+ ############################### | |
||
| 325 | +268 |
- #'+ # ---- Build plot object. ---- |
||
| 326 | +269 |
- #' @keywords internal+ ############################### | |
||
| 327 | -+ | |||
| 270 | +2x |
- afun_selected_stats <- function(.stats, all_stats) {
+ p <- ggplot2::ggplot( |
||
| 328 | +271 | 2x |
- checkmate::assert_character(.stats, null.ok = TRUE)+ data = df_stats, |
|
| 329 | +272 | 2x |
- checkmate::assert_character(all_stats)+ mapping = ggplot2::aes( |
|
| 330 | +273 | 2x |
- if (is.null(.stats)) {
+ x = .data[[x]], y = .data[[mid]], |
|
| 331 | -1x | +274 | +2x |
- all_stats+ color = if (is.null(strata_N)) NULL else .data[[strata_N]], |
| 332 | -+ | |||
| 275 | +2x |
- } else {
+ shape = if (is.null(strata_N)) NULL else .data[[strata_N]], |
||
| 333 | -1x | +276 | +2x |
- intersect(.stats, all_stats)+ lty = if (is.null(strata_N)) NULL else .data[[strata_N]], |
| 334 | -+ | |||
| 277 | +2x |
- }+ group = if (is.null(strata_N)) NULL else .data[[strata_N]] |
||
| 335 | +278 |
- }+ ) |
||
| 336 | +279 |
-
+ ) |
||
| 337 | +280 |
- #' Add Variable Labels to Top Left Corner in Table+ |
||
| 338 | -+ | |||
| 281 | +2x |
- #'+ if (!is.null(mid)) {
|
||
| 339 | +282 |
- #' @description `r lifecycle::badge("stable")`
+ # points |
||
| 340 | -+ | |||
| 283 | +2x |
- #'+ if (grepl("p", mid_type, fixed = TRUE)) {
|
||
| 341 | -+ | |||
| 284 | +2x |
- #' Helper layout creating function to just append the variable labels of a given variables vector+ p <- p + ggplot2::geom_point(position = position, size = mid_point_size, na.rm = TRUE) |
||
| 342 | +285 |
- #' from a given dataset in the top left corner. If a variable label is not found then the+ } |
||
| 343 | +286 |
- #' variable name itself is used instead. Multiple variable labels are concatenated with slashes.+ |
||
| 344 | +287 |
- #'+ # lines |
||
| 345 | +288 |
- #' @inheritParams argument_convention+ # further conditions in if are to ensure that not all of the groups consist of only one observation |
||
| 346 | -+ | |||
| 289 | +2x |
- #' @param vars (`character`)\cr variable names of which the labels are to be looked up in `df`.+ if (grepl("l", mid_type, fixed = TRUE) &&
|
||
| 347 | -+ | |||
| 290 | +2x |
- #' @param indent (`integer`)\cr non-negative number of nested indent space, default to 0L which means no indent.+ !is.null(strata) && |
||
| 348 | -+ | |||
| 291 | +2x |
- #' 1L means two spaces indent, 2L means four spaces indent and so on.+ !all(dplyr::summarise(df_grp, count_n = dplyr::n())[["count_n"]] == 1L)) {
|
||
| 349 | -+ | |||
| 292 | +2x |
- #'+ p <- p + ggplot2::geom_line(position = position, na.rm = TRUE) |
||
| 350 | +293 |
- #' @return A modified layout with the new variable label(s) added to the top-left material.+ } |
||
| 351 | +294 |
- #'+ } |
||
| 352 | +295 |
- #' @note This is not an optimal implementation of course, since we are using here the data set+ |
||
| 353 | +296 |
- #' itself during the layout creation. When we have a more mature `rtables` implementation then+ # interval |
||
| 354 | -+ | |||
| 297 | +2x |
- #' this will also be improved or not necessary anymore.+ if (!is.null(interval)) {
|
||
| 355 | -+ | |||
| 298 | +2x |
- #'+ p <- p + |
||
| 356 | -+ | |||
| 299 | +2x |
- #' @examples+ ggplot2::geom_errorbar( |
||
| 357 | -+ | |||
| 300 | +2x |
- #' lyt <- basic_table() %>%+ ggplot2::aes(ymin = .data[[whiskers[1]]], ymax = .data[[whiskers[max(1, length(whiskers))]]]), |
||
| 358 | -+ | |||
| 301 | +2x |
- #' split_cols_by("ARM") %>%
+ width = 0.45, |
||
| 359 | -+ | |||
| 302 | +2x |
- #' add_colcounts() %>%+ position = position |
||
| 360 | +303 |
- #' split_rows_by("SEX") %>%
+ ) |
||
| 361 | +304 |
- #' append_varlabels(DM, "SEX") %>%+ |
||
| 362 | -+ | |||
| 305 | +2x |
- #' analyze("AGE", afun = mean) %>%
+ if (length(whiskers) == 1) { # lwr or upr only; mid is then required
|
||
| 363 | +306 |
- #' append_varlabels(DM, "AGE", indent = 1)+ # workaround as geom_errorbar does not provide single-direction whiskers |
||
| 364 | -+ | |||
| 307 | +! |
- #' build_table(lyt, DM)+ p <- p + |
||
| 365 | -+ | |||
| 308 | +! |
- #'+ ggplot2::geom_linerange( |
||
| 366 | -+ | |||
| 309 | +! |
- #' lyt <- basic_table() %>%+ data = df_stats[!is.na(df_stats[[whiskers]]), ], # as na.rm =TRUE does not suppress warnings |
||
| 367 | -+ | |||
| 310 | +! |
- #' split_cols_by("ARM") %>%
+ ggplot2::aes(ymin = .data[[mid]], ymax = .data[[whiskers]]), |
||
| 368 | -+ | |||
| 311 | +! |
- #' split_rows_by("SEX") %>%
+ position = position, |
||
| 369 | -+ | |||
| 312 | +! |
- #' analyze("AGE", afun = mean) %>%
+ na.rm = TRUE, |
||
| 370 | -+ | |||
| 313 | +! |
- #' append_varlabels(DM, c("SEX", "AGE"))
+ show.legend = FALSE |
||
| 371 | +314 |
- #' build_table(lyt, DM)+ ) |
||
| 372 | +315 |
- #'+ } |
||
| 373 | +316 |
- #' @export+ } |
||
| 374 | +317 |
- append_varlabels <- function(lyt, df, vars, indent = 0L) {
+
|
||
| 375 | -3x | -
- if (checkmate::test_flag(indent)) {
- |
- ||
| 376 | -! | +318 | +2x |
- warning("indent argument is now accepting integers. Boolean indent will be converted to integers.")
+ p <- p + |
| 377 | -! | +|||
| 319 | +2x |
- indent <- as.integer(indent)+ ggplot2::scale_y_continuous(labels = scales::comma, expand = ggplot2::expansion(c(0.25, .25))) + |
||
| 378 | -+ | |||
| 320 | +2x |
- }+ ggplot2::labs( |
||
| 379 | -+ | |||
| 321 | +2x |
-
+ title = title, |
||
| 380 | -3x | +322 | +2x |
- checkmate::assert_data_frame(df)+ subtitle = subtitle, |
| 381 | -3x | +323 | +2x |
- checkmate::assert_character(vars)+ caption = caption, |
| 382 | -3x | +324 | +2x |
- checkmate::assert_count(indent)+ color = legend_title, |
| 383 | -+ | |||
| 325 | +2x |
-
+ lty = legend_title, |
||
| 384 | -3x | +326 | +2x |
- lab <- formatters::var_labels(df[vars], fill = TRUE)+ shape = legend_title, |
| 385 | -3x | +327 | +2x |
- lab <- paste(lab, collapse = " / ")+ x = attr(df[[x]], "label"), |
| 386 | -3x | +328 | +2x |
- space <- paste(rep(" ", indent * 2), collapse = "")
+ y = y_lab |
| 387 | -3x | +|||
| 329 | +
- lab <- paste0(space, lab)+ ) |
|||
| 388 | +330 | |||
| 389 | -3x | +331 | +2x |
- append_topleft(lyt, lab)+ if (!is.null(col)) {
|
| 390 | -+ | |||
| 332 | +! |
- }+ p <- p + |
| 1 | -+ | |||
| 333 | +! |
- #' Re-implemented [range()] Default S3 method for numerical objects+ ggplot2::scale_color_manual(values = col) |
||
| 2 | +334 |
- #'+ } |
||
| 3 | +335 |
- #' This function returns `c(NA, NA)` instead of `c(-Inf, Inf)` for zero-length data+ |
||
| 4 | -+ | |||
| 336 | +2x |
- #' without any warnings.+ if (!is.null(ggtheme)) {
|
||
| 5 | -+ | |||
| 337 | +2x |
- #'+ p <- p + ggtheme |
||
| 6 | +338 |
- #' @param x (`numeric`)\cr a sequence of numbers for which the range is computed.+ } else {
|
||
| 7 | -+ | |||
| 339 | +! |
- #' @param na.rm (`logical`)\cr indicating if `NA` should be omitted.+ p <- p + |
||
| 8 | -+ | |||
| 340 | +! |
- #' @param finite (`logical`)\cr indicating if non-finite elements should be removed.+ ggplot2::theme_bw() + |
||
| 9 | -+ | |||
| 341 | +! |
- #'+ ggplot2::theme( |
||
| 10 | -+ | |||
| 342 | +! |
- #' @return A 2-element vector of class `numeric`.+ legend.key.width = grid::unit(1, "cm"), |
||
| 11 | -+ | |||
| 343 | +! |
- #'+ legend.position = legend_position, |
||
| 12 | -+ | |||
| 344 | +! |
- #' @keywords internal+ legend.direction = ifelse( |
||
| 13 | -+ | |||
| 345 | +! |
- range_noinf <- function(x, na.rm = FALSE, finite = FALSE) { # nolint
+ legend_position %in% c("top", "bottom"),
|
||
| 14 | -+ | |||
| 346 | +! |
-
+ "horizontal", |
||
| 15 | -799x | +|||
| 347 | +! |
- checkmate::assert_numeric(x)+ "vertical" |
||
| 16 | +348 |
-
+ ) |
||
| 17 | -799x | +|||
| 349 | +
- if (finite) {
+ ) |
|||
| 18 | -24x | +|||
| 350 | +
- x <- x[is.finite(x)] # removes NAs too+ } |
|||
| 19 | -775x | +|||
| 351 | +
- } else if (na.rm) {
+
|
|||
| 20 | -468x | +|||
| 352 | +
- x <- x[!is.na(x)]+ ############################################################# | |
|||
| 21 | +353 |
- }+ # ---- Optionally, add table to the bottom of the plot. ---- |
||
| 22 | +354 |
-
+ ############################################################# | |
||
| 23 | -799x | +355 | +2x |
- if (length(x) == 0) {
+ if (!is.null(table)) {
|
| 24 | -47x | +356 | +1x |
- rval <- c(NA, NA)+ df_stats_table <- df_grp %>% |
| 25 | -47x | +357 | +1x |
- mode(rval) <- typeof(x)+ dplyr::summarise( |
| 26 | -+ | |||
| 358 | +1x |
- } else {
+ h_format_row( |
||
| 27 | -752x | +359 | +1x |
- rval <- c(min(x, na.rm = FALSE), max(x, na.rm = FALSE))+ x = sfun(.data[[y]], ...)[table], |
| 28 | -+ | |||
| 360 | +1x |
- }+ format = table_format,+ |
+ ||
| 361 | +1x | +
+ labels = table_labels |
||
| 29 | +362 |
-
+ ), |
||
| 30 | -799x | +363 | +1x |
- return(rval)+ .groups = "drop" |
| 31 | +364 |
- }+ ) |
||
| 32 | +365 | |||
| 33 | -+ | |||
| 366 | +1x |
- #' Utility function to create label for confidence interval+ stats_lev <- rev(setdiff(colnames(df_stats_table), c(strata, x))) |
||
| 34 | +367 |
- #'+ |
||
| 35 | -+ | |||
| 368 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ df_stats_table <- df_stats_table %>% |
||
| 36 | -+ | |||
| 369 | +1x |
- #'+ tidyr::pivot_longer( |
||
| 37 | -+ | |||
| 370 | +1x |
- #' @inheritParams argument_convention+ cols = -dplyr::all_of(c(strata, x)), |
||
| 38 | -+ | |||
| 371 | +1x |
- #'+ names_to = "stat", |
||
| 39 | -+ | |||
| 372 | +1x |
- #' @return A `string`.+ values_to = "value", |
||
| 40 | -+ | |||
| 373 | +1x |
- #'+ names_ptypes = list(stat = factor(levels = stats_lev)) |
||
| 41 | +374 |
- #' @export+ ) |
||
| 42 | +375 |
- f_conf_level <- function(conf_level) {
+
|
||
| 43 | -1197x | +376 | +1x |
- assert_proportion_value(conf_level)+ tbl <- ggplot2::ggplot( |
| 44 | -1195x | +377 | +1x |
- paste0(conf_level * 100, "% CI")+ df_stats_table, |
| 45 | -+ | |||
| 378 | +1x |
- }+ ggplot2::aes(x = .data[[x]], y = .data[["stat"]], label = .data[["value"]]) |
||
| 46 | +379 |
-
+ ) + |
||
| 47 | -+ | |||
| 380 | +1x |
- #' Utility function to create label for p-value+ ggplot2::geom_text(size = table_font_size) + |
||
| 48 | -+ | |||
| 381 | +1x |
- #'+ ggplot2::theme_bw() + |
||
| 49 | -+ | |||
| 382 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ ggplot2::theme( |
||
| 50 | -+ | |||
| 383 | +1x |
- #'+ panel.border = ggplot2::element_blank(), |
||
| 51 | -+ | |||
| 384 | +1x |
- #' @param test_mean (`number`)\cr mean value to test under the null hypothesis.+ panel.grid.major = ggplot2::element_blank(), |
||
| 52 | -+ | |||
| 385 | +1x |
- #'+ panel.grid.minor = ggplot2::element_blank(), |
||
| 53 | -+ | |||
| 386 | +1x |
- #' @return A `string`.+ axis.ticks = ggplot2::element_blank(), |
||
| 54 | -+ | |||
| 387 | +1x |
- #'+ axis.title = ggplot2::element_blank(), |
||
| 55 | -+ | |||
| 388 | +1x |
- #' @export+ axis.text.x = ggplot2::element_blank(), |
||
| 56 | -+ | |||
| 389 | +1x |
- f_pval <- function(test_mean) {
+ axis.text.y = ggplot2::element_text(margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 5)), |
||
| 57 | -298x | +390 | +1x |
- checkmate::assert_numeric(test_mean, len = 1)+ strip.text = ggplot2::element_text(hjust = 0), |
| 58 | -296x | +391 | +1x |
- paste0("p-value (H0: mean = ", test_mean, ")")
+ strip.text.x = ggplot2::element_text(margin = ggplot2::margin(1.5, 0, 1.5, 0, "pt")), |
| 59 | -+ | |||
| 392 | +1x |
- }+ strip.background = ggplot2::element_rect(fill = "grey95", color = NA), |
||
| 60 | -+ | |||
| 393 | +1x |
-
+ legend.position = "none" |
||
| 61 | +394 |
- #' Utility function to return a named list of covariate names.+ ) |
||
| 62 | +395 |
- #'+ |
||
| 63 | -+ | |||
| 396 | +1x |
- #' @param covariates (`character`)\cr a vector that can contain single variable names (such as+ if (!is.null(strata)) {
|
||
| 64 | -+ | |||
| 397 | +1x |
- #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`.+ tbl <- tbl + ggplot2::facet_wrap(facets = strata, ncol = 1) |
||
| 65 | +398 |
- #'+ } |
||
| 66 | +399 |
- #' @return A named `list` of `character` vector.+ |
||
| 67 | +400 |
- #'+ # align plot and table |
||
| 68 | -+ | |||
| 401 | +1x |
- #' @keywords internal+ cowplot::plot_grid(p, tbl, ncol = 1) |
||
| 69 | +402 |
- get_covariates <- function(covariates) {
- |
- ||
| 70 | -14x | -
- checkmate::assert_character(covariates)+ } else {
|
||
| 71 | -12x | +403 | +1x |
- cov_vars <- unique(trimws(unlist(strsplit(covariates, "\\*"))))+ p |
| 72 | -12x | +|||
| 404 | +
- stats::setNames(as.list(cov_vars), cov_vars)+ } |
|||
| 73 | +405 |
} |
||
| 74 | +406 | |||
| 75 | +407 |
- #' Replicate Entries of a Vector if Required+ #' Helper function to get the right formatting in the optional table in `g_lineplot`. |
||
| 76 | +408 |
#' |
||
| 77 | +409 |
#' @description `r lifecycle::badge("stable")`
|
||
| 78 | +410 |
#' |
||
| 79 | +411 |
- #' Replicate entries of a vector if required.+ #' @param x (named `list`)\cr list of numerical values to be formatted and optionally labeled. |
||
| 80 | +412 |
- #'+ #' Elements of `x` must be `numeric` vectors. |
||
| 81 | +413 |
- #' @inheritParams argument_convention+ #' @param format (named `character` or `NULL`)\cr format patterns for `x`. Names of the `format` must |
||
| 82 | +414 |
- #' @param n (`count`)\cr how many entries we need.+ #' match the names of `x`. This parameter is passed directly to the `rtables::format_rcell` |
||
| 83 | +415 |
- #'+ #' function through the `format` parameter. |
||
| 84 | +416 |
- #' @return `x` if it has the required length already or is `NULL`,+ #' @param labels (named `character` or `NULL`)\cr optional labels for `x`. Names of the `labels` must |
||
| 85 | +417 |
- #' otherwise if it is scalar the replicated version of it with `n` entries.+ #' match the names of `x`. When a label is not specified for an element of `x`, |
||
| 86 | +418 |
- #'+ #' then this function tries to use `label` or `names` (in this order) attribute of that element |
||
| 87 | +419 |
- #' @note This function will fail if `x` is not of length `n` and/or is not a scalar.+ #' (depending on which one exists and it is not `NULL` or `NA` or `NaN`). If none of these attributes |
||
| 88 | +420 |
- #'+ #' are attached to a given element of `x`, then the label is automatically generated. |
||
| 89 | +421 |
- #' @export+ #' |
||
| 90 | +422 |
- to_n <- function(x, n) {
- |
- ||
| 91 | -1x | -
- if (is.null(x)) {
- |
- ||
| 92 | -! | -
- NULL- |
- ||
| 93 | -1x | -
- } else if (length(x) == 1) {
- |
- ||
| 94 | -! | -
- rep(x, n)- |
- ||
| 95 | -1x | -
- } else if (length(x) == n) {
- |
- ||
| 96 | -1x | -
- x+ #' @return A single row `data.frame` object. |
||
| 97 | +423 |
- } else {
- |
- ||
| 98 | -! | -
- stop("dimension mismatch")
+ #' |
||
| 99 | +424 |
- }+ #' @examples |
||
| 100 | +425 |
- }+ #' mean_ci <- c(48, 51) |
||
| 101 | +426 |
-
+ #' x <- list(mean = 50, mean_ci = mean_ci) |
||
| 102 | +427 |
- #' Check Element Dimension+ #' format <- c(mean = "xx.x", mean_ci = "(xx.xx, xx.xx)") |
||
| 103 | +428 |
- #'+ #' labels <- c(mean = "My Mean") |
||
| 104 | +429 |
- #' Checks if the elements in `...` have the same dimension.+ #' h_format_row(x, format, labels) |
||
| 105 | +430 |
#' |
||
| 106 | -- |
- #' @param ... (`data.frame`s or `vector`s)\cr any data frames/vectors.- |
- ||
| 107 | +431 |
- #' @param omit_null (`logical`)\cr whether `NULL` elements in `...` should be omitted from the check.+ #' attr(mean_ci, "label") <- "Mean 95% CI" |
||
| 108 | +432 |
- #'+ #' x <- list(mean = 50, mean_ci = mean_ci) |
||
| 109 | +433 |
- #' @return A `logical` value.+ #' h_format_row(x, format, labels) |
||
| 110 | +434 |
#' |
||
| 111 | +435 |
- #' @keywords internal+ #' @export |
||
| 112 | +436 |
- check_same_n <- function(..., omit_null = TRUE) {
- |
- ||
| 113 | -2x | -
- dots <- list(...)+ h_format_row <- function(x, format, labels = NULL) {
|
||
| 114 | +437 | - - | -||
| 115 | -2x | -
- n_list <- Map(+ # cell: one row, one column data.frame |
||
| 116 | -2x | +438 | +19x |
- function(x, name) {
+ format_cell <- function(x, format, label = NULL) {
|
| 117 | -5x | -
- if (is.null(x)) {
- |
- ||
| 118 | -! | +439 | +56x |
- if (omit_null) {
+ fc <- format_rcell(x = x, format = unlist(format)) |
| 119 | -2x | -
- NA_integer_- |
- ||
| 120 | -+ | 440 | +56x |
- } else {
+ if (is.na(fc)) {
|
| 121 | +441 | ! |
- stop("arg", name, "is not supposed to be NULL")
+ fc <- "NA" |
|
| 122 | +442 |
- }+ } |
||
| 123 | -5x | +443 | +56x |
- } else if (is.data.frame(x)) {
+ x_label <- attr(x, "label") |
| 124 | -! | +|||
| 444 | +56x |
- nrow(x)+ if (!is.null(label) && !is.na(label)) {
|
||
| 125 | -5x | +445 | +55x |
- } else if (is.atomic(x)) {
+ names(fc) <- label |
| 126 | -5x | +446 | +1x |
- length(x)+ } else if (!is.null(x_label) && !is.na(x_label)) {
|
| 127 | -+ | |||
| 447 | +! |
- } else {
+ names(fc) <- x_label |
||
| 128 | -! | +|||
| 448 | +1x |
- stop("data structure for ", name, "is currently not supported")
+ } else if (length(x) == length(fc)) {
|
||
| 129 | -+ | |||
| 449 | +! |
- }+ names(fc) <- names(x) |
||
| 130 | +450 |
- },+ } |
||
| 131 | -2x | +451 | +56x |
- dots, names(dots)+ as.data.frame(t(fc)) |
| 132 | +452 |
- )+ } |
||
| 133 | +453 | |||
| 134 | -2x | +454 | +19x |
- n <- stats::na.omit(unlist(n_list))+ row <- do.call( |
| 135 | -+ | |||
| 455 | +19x |
-
+ cbind, |
||
| 136 | -2x | +456 | +19x |
- if (length(unique(n)) > 1) {
+ lapply( |
| 137 | -! | +|||
| 457 | +19x |
- sel <- which(n != n[1])+ names(x), function(xn) format_cell(x[[xn]], format = format[xn], label = labels[xn]) |
||
| 138 | -! | +|||
| 458 | +
- stop("dimension mismatch:", paste(names(n)[sel], collapse = ", "), " do not have N=", n[1])
+ ) |
|||
| 139 | +459 |
- }+ ) |
||
| 140 | +460 | |||
| 141 | -2x | +461 | +19x |
- TRUE+ row |
| 142 | +462 |
} |
||
| 143 | +463 | |||
| 144 | +464 |
- #' Make Names Without Dots+ #' Control Function for `g_lineplot` Function |
||
| 145 | +465 |
#' |
||
| 146 | +466 |
- #' @param nams (`character`)\cr vector of original names.+ #' @description `r lifecycle::badge("stable")`
|
||
| 147 | +467 |
#' |
||
| 148 | +468 |
- #' @return A `character` `vector` of proper names, which does not use dots in contrast to [make.names()].+ #' Default values for `variables` parameter in `g_lineplot` function. |
||
| 149 | +469 |
- #'+ #' A variable's default value can be overwritten for any variable. |
||
| 150 | +470 |
- #' @keywords internal+ #' |
||
| 151 | +471 |
- make_names <- function(nams) {
- |
- ||
| 152 | -6x | -
- orig <- make.names(nams)+ #' @param x (`character`)\cr x variable name. |
||
| 153 | -6x | +|||
| 472 | +
- gsub(".", "", x = orig, fixed = TRUE)
+ #' @param y (`character`)\cr y variable name. |
|||
| 154 | +473 |
- }+ #' @param strata (`character` or `NA`)\cr strata variable name. |
||
| 155 | +474 |
-
+ #' @param paramcd (`character` or `NA`)\cr `paramcd` variable name. |
||
| 156 | +475 |
- #' Conversion of Months to Days+ #' @param y_unit (`character` or `NA`)\cr `y_unit` variable name. |
||
| 157 | +476 |
#' |
||
| 158 | +477 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return A named character vector of variable names. |
||
| 159 | +478 |
#' |
||
| 160 | +479 |
- #' Conversion of Months to Days. This is an approximative calculation because it+ #' @examples |
||
| 161 | +480 |
- #' considers each month as having an average of 30.4375 days.+ #' control_lineplot_vars() |
||
| 162 | +481 |
- #'+ #' control_lineplot_vars(strata = NA) |
||
| 163 | +482 |
- #' @param x (`numeric`)\cr time in months.+ #' |
||
| 164 | +483 |
- #'+ #' @export |
||
| 165 | +484 |
- #' @return A `numeric` vector with the time in days.+ control_lineplot_vars <- function(x = "AVISIT", y = "AVAL", strata = "ARM", paramcd = "PARAMCD", y_unit = "AVALU") {
|
||
| 166 | -+ | |||
| 485 | +2x |
- #'+ checkmate::assert_string(x) |
||
| 167 | -+ | |||
| 486 | +2x |
- #' @examples+ checkmate::assert_string(y)+ |
+ ||
| 487 | +2x | +
+ checkmate::assert_string(strata, na.ok = TRUE)+ |
+ ||
| 488 | +2x | +
+ checkmate::assert_string(paramcd, na.ok = TRUE)+ |
+ ||
| 489 | +2x | +
+ checkmate::assert_string(y_unit, na.ok = TRUE) |
||
| 168 | +490 |
- #' x <- c(13.25, 8.15, 1, 2.834)+ + |
+ ||
| 491 | +2x | +
+ variables <- c(x = x, y = y, strata = strata, paramcd = paramcd, y_unit = y_unit)+ |
+ ||
| 492 | +2x | +
+ return(variables) |
||
| 169 | +493 |
- #' month2day(x)+ } |
| 170 | +1 |
- #'+ #' Helper Functions for Multivariate Logistic Regression |
||
| 171 | +2 |
- #' @export+ #' |
||
| 172 | +3 |
- month2day <- function(x) {
+ #' @description `r lifecycle::badge("stable")`
|
||
| 173 | -1x | +|||
| 4 | +
- checkmate::assert_numeric(x)+ #' |
|||
| 174 | -1x | +|||
| 5 | +
- x * 30.4375+ #' Helper functions used in calculations for logistic regression. |
|||
| 175 | +6 |
- }+ #' |
||
| 176 | +7 |
-
+ #' @inheritParams argument_convention |
||
| 177 | +8 |
- #' Conversion of Days to Months+ #' @param fit_glm (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family. |
||
| 178 | +9 |
- #'+ #' Limited functionality is also available for conditional logistic regression models fitted by |
||
| 179 | +10 |
- #' @param x (`numeric`)\cr time in days.+ #' [survival::clogit()], currently this is used only by [extract_rsp_biomarkers()]. |
||
| 180 | +11 |
- #'+ #' @param x (`string` or `character`)\cr a variable or interaction term in `fit_glm` (depending on the |
||
| 181 | +12 |
- #' @return A `numeric` vector with the time in months.+ #' helper function). |
||
| 182 | +13 |
#' |
||
| 183 | +14 |
#' @examples |
||
| 184 | +15 |
- #' x <- c(403, 248, 30, 86)+ #' library(dplyr) |
||
| 185 | +16 |
- #' day2month(x)+ #' library(broom) |
||
| 186 | +17 |
#' |
||
| 187 | +18 |
- #' @export+ #' adrs_f <- tern_ex_adrs %>% |
||
| 188 | +19 |
- day2month <- function(x) {
+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 189 | -15x | +|||
| 20 | +
- checkmate::assert_numeric(x)+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
|
|||
| 190 | -15x | +|||
| 21 | +
- x / 30.4375+ #' mutate( |
|||
| 191 | +22 |
- }+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
||
| 192 | +23 |
-
+ #' RACE = factor(RACE), |
||
| 193 | +24 |
- #' Return an empty numeric if all elements are `NA`.+ #' SEX = factor(SEX) |
||
| 194 | +25 |
- #'+ #' ) |
||
| 195 | +26 |
- #' @param x (`numeric`)\cr vector.+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
||
| 196 | +27 |
- #'+ #' mod1 <- fit_logistic( |
||
| 197 | +28 |
- #' @return An empty `numeric` if all elements of `x` are `NA`, otherwise `x`.+ #' data = adrs_f, |
||
| 198 | +29 |
- #'+ #' variables = list( |
||
| 199 | +30 |
- #' @examples+ #' response = "Response", |
||
| 200 | +31 |
- #' x <- c(NA, NA, NA)+ #' arm = "ARMCD", |
||
| 201 | +32 |
- #' # Internal function - empty_vector_if_na+ #' covariates = c("AGE", "RACE")
|
||
| 202 | +33 |
- #' @keywords internal+ #' ) |
||
| 203 | +34 |
- empty_vector_if_na <- function(x) {
+ #' ) |
||
| 204 | -683x | +|||
| 35 | +
- if (all(is.na(x))) {
+ #' mod2 <- fit_logistic( |
|||
| 205 | -220x | +|||
| 36 | +
- numeric()+ #' data = adrs_f, |
|||
| 206 | +37 |
- } else {
+ #' variables = list( |
||
| 207 | -463x | +|||
| 38 | +
- x+ #' response = "Response", |
|||
| 208 | +39 |
- }+ #' arm = "ARMCD", |
||
| 209 | +40 |
- }+ #' covariates = c("AGE", "RACE"),
|
||
| 210 | +41 |
-
+ #' interaction = "AGE" |
||
| 211 | +42 |
- #' Combine Two Vectors Element Wise+ #' ) |
||
| 212 | +43 | ++ |
+ #' )+ |
+ |
| 44 |
#' |
|||
| 213 | +45 |
- #' @param x (`vector`)\cr first vector to combine.+ #' @name h_logistic_regression |
||
| 214 | +46 |
- #' @param y (`vector`)\cr second vector to combine.+ NULL |
||
| 215 | +47 |
- #'+ |
||
| 216 | +48 |
- #' @return A `list` where each element combines corresponding elements of `x` and `y`.+ #' @describeIn h_logistic_regression Helper function to extract interaction variable names from a fitted |
||
| 217 | +49 |
- #'+ #' model assuming only one interaction term. |
||
| 218 | +50 |
- #' @examples+ #' |
||
| 219 | +51 |
- #' combine_vectors(1:3, 4:6)+ #' @return Vector of names of interaction variables. |
||
| 220 | +52 |
#' |
||
| 221 | +53 |
#' @export |
||
| 222 | +54 |
- combine_vectors <- function(x, y) {
+ h_get_interaction_vars <- function(fit_glm) {
|
||
| 223 | -49x | +55 | +27x |
- checkmate::assert_vector(x)+ checkmate::assert_class(fit_glm, "glm") |
| 224 | -49x | +56 | +27x |
- checkmate::assert_vector(y, len = length(x))+ terms_name <- attr(stats::terms(fit_glm), "term.labels") |
| 225 | -+ | |||
| 57 | +27x |
-
+ terms_order <- attr(stats::terms(fit_glm), "order") |
||
| 226 | -49x | +58 | +27x |
- result <- lapply(as.data.frame(rbind(x, y)), `c`)+ interaction_term <- terms_name[terms_order == 2] |
| 227 | -49x | +59 | +27x |
- names(result) <- NULL+ checkmate::assert_string(interaction_term) |
| 228 | -49x | +60 | +27x |
- result+ strsplit(interaction_term, split = ":")[[1]] |
| 229 | +61 |
} |
||
| 230 | +62 | |||
| 231 | +63 |
- #' Extract Elements by Name+ #' @describeIn h_logistic_regression Helper function to get the right coefficient name from the |
||
| 232 | +64 |
- #'+ #' interaction variable names and the given levels. The main value here is that the order |
||
| 233 | +65 |
- #' This utility function extracts elements from a vector `x` by `names`.+ #' of first and second variable is checked in the `interaction_vars` input. |
||
| 234 | +66 |
- #' Differences to the standard `[` function are:+ #' |
||
| 235 | +67 |
- #'+ #' @param interaction_vars (`character` of length 2)\cr interaction variable names. |
||
| 236 | +68 |
- #' - If `x` is `NULL`, then still always `NULL` is returned (same as in base function).+ #' @param first_var_with_level (`character` of length 2)\cr the first variable name with |
||
| 237 | +69 |
- #' - If `x` is not `NULL`, then the intersection of its names is made with `names` and those+ #' the interaction level. |
||
| 238 | +70 |
- #' elements are returned. That is, `names` which don't appear in `x` are not returned as `NA`s.+ #' @param second_var_with_level (`character` of length 2)\cr the second variable name with |
||
| 239 | +71 |
- #'+ #' the interaction level. |
||
| 240 | +72 |
- #' @param x (named `vector`)\cr where to extract named elements from.+ #' |
||
| 241 | +73 |
- #' @param names (`character`)\cr vector of names to extract.+ #' @return Name of coefficient. |
||
| 242 | +74 |
#' |
||
| 243 | +75 |
- #' @return `NULL` if `x` is `NULL`, otherwise the extracted elements from `x`.+ #' @export |
||
| 244 | +76 |
- #'+ h_interaction_coef_name <- function(interaction_vars, |
||
| 245 | +77 |
- #' @keywords internal+ first_var_with_level, |
||
| 246 | +78 |
- extract_by_name <- function(x, names) {
+ second_var_with_level) {
|
||
| 247 | -5x | +79 | +45x |
- if (is.null(x)) {
+ checkmate::assert_character(interaction_vars, len = 2, any.missing = FALSE) |
| 248 | -1x | +80 | +45x |
- return(NULL)+ checkmate::assert_character(first_var_with_level, len = 2, any.missing = FALSE) |
| 249 | -+ | |||
| 81 | +45x |
- }+ checkmate::assert_character(second_var_with_level, len = 2, any.missing = FALSE) |
||
| 250 | -4x | +82 | +45x |
- checkmate::assert_named(x)+ checkmate::assert_subset(c(first_var_with_level[1], second_var_with_level[1]), interaction_vars)+ |
+
| 83 | ++ | + | ||
| 251 | -4x | +84 | +45x |
- checkmate::assert_character(names)+ first_name <- paste(first_var_with_level, collapse = "") |
| 252 | -4x | +85 | +45x |
- which_extract <- intersect(names(x), names)+ second_name <- paste(second_var_with_level, collapse = "") |
| 253 | -4x | +86 | +45x |
- if (length(which_extract) > 0) {
+ if (first_var_with_level[1] == interaction_vars[1]) {
|
| 254 | -3x | +87 | +34x |
- x[which_extract]+ paste(first_name, second_name, sep = ":") |
| 255 | -+ | |||
| 88 | +11x |
- } else {
+ } else if (second_var_with_level[1] == interaction_vars[1]) {
|
||
| 256 | -1x | +89 | +11x |
- NULL+ paste(second_name, first_name, sep = ":") |
| 257 | +90 |
} |
||
| 258 | +91 |
} |
||
| 259 | +92 | |||
| 260 | +93 |
- #' Labels for Adverse Event Baskets+ #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates |
||
| 261 | +94 |
- #'+ #' for the case when both the odds ratio and the interaction variable are categorical. |
||
| 262 | +95 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 263 | +96 |
- #'+ #' @param odds_ratio_var (`string`)\cr the odds ratio variable. |
||
| 264 | +97 |
- #' @param aesi (`character`)\cr with standardized `MedDRA` query name (e.g. `SMQzzNAM`) or customized query+ #' @param interaction_var (`string`)\cr the interaction variable. |
||
| 265 | +98 |
- #' name (e.g. `CQzzNAM`).+ #' |
||
| 266 | +99 |
- #' @param scope (`character`)\cr with scope of query (e.g. `SMQzzSC`).+ #' @return Odds ratio. |
||
| 267 | +100 |
#' |
||
| 268 | +101 |
- #' @return A `string` with the standard label for the `AE` basket.+ #' @export |
||
| 269 | +102 |
- #'+ h_or_cat_interaction <- function(odds_ratio_var, |
||
| 270 | +103 |
- #' @examples+ interaction_var, |
||
| 271 | +104 |
- #' adae <- tern_ex_adae+ fit_glm, |
||
| 272 | +105 |
- #'+ conf_level = 0.95) {
|
||
| 273 | -+ | |||
| 106 | +7x |
- #' # Standardized query label includes scope.+ interaction_vars <- h_get_interaction_vars(fit_glm) |
||
| 274 | -+ | |||
| 107 | +7x |
- #' aesi_label(adae$SMQ01NAM, scope = adae$SMQ01SC)+ checkmate::assert_string(odds_ratio_var) |
||
| 275 | -+ | |||
| 108 | +7x |
- #'+ checkmate::assert_string(interaction_var) |
||
| 276 | -+ | |||
| 109 | +7x |
- #' # Customized query label.+ checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars) |
||
| 277 | -+ | |||
| 110 | +7x |
- #' aesi_label(adae$CQ01NAM)+ checkmate::assert_vector(interaction_vars, len = 2) |
||
| 278 | +111 |
- #'+ + |
+ ||
| 112 | +7x | +
+ xs_level <- fit_glm$xlevels+ |
+ ||
| 113 | +7x | +
+ xs_coef <- stats::coef(fit_glm)+ |
+ ||
| 114 | +7x | +
+ xs_vcov <- stats::vcov(fit_glm)+ |
+ ||
| 115 | +7x | +
+ y <- list()+ |
+ ||
| 116 | +7x | +
+ for (var_level in xs_level[[odds_ratio_var]][-1]) {
+ |
+ ||
| 117 | +12x | +
+ x <- list()+ |
+ ||
| 118 | +12x | +
+ for (ref_level in xs_level[[interaction_var]]) {
+ |
+ ||
| 119 | +32x | +
+ coef_names <- paste0(odds_ratio_var, var_level)+ |
+ ||
| 120 | +32x | +
+ if (ref_level != xs_level[[interaction_var]][1]) {
+ |
+ ||
| 121 | +20x | +
+ interaction_coef_name <- h_interaction_coef_name(+ |
+ ||
| 122 | +20x | +
+ interaction_vars,+ |
+ ||
| 123 | +20x | +
+ c(odds_ratio_var, var_level),+ |
+ ||
| 124 | +20x | +
+ c(interaction_var, ref_level) |
||
| 279 | +125 |
- #' @export+ )+ |
+ ||
| 126 | +20x | +
+ coef_names <- c(+ |
+ ||
| 127 | +20x | +
+ coef_names,+ |
+ ||
| 128 | +20x | +
+ interaction_coef_name |
||
| 280 | +129 |
- aesi_label <- function(aesi, scope = NULL) {
+ ) |
||
| 281 | -3x | +|||
| 130 | +
- checkmate::assert_character(aesi)+ } |
|||
| 282 | -3x | +131 | +32x |
- checkmate::assert_character(scope, null.ok = TRUE)+ if (length(coef_names) > 1) {
|
| 283 | -3x | +132 | +20x |
- aesi_label <- obj_label(aesi)+ ones <- t(c(1, 1)) |
| 284 | -3x | +133 | +20x |
- aesi <- sas_na(aesi)+ est <- as.numeric(ones %*% xs_coef[coef_names]) |
| 285 | -3x | +134 | +20x |
- aesi <- unique(aesi)[!is.na(unique(aesi))]+ se <- sqrt(as.numeric(ones %*% xs_vcov[coef_names, coef_names] %*% t(ones))) |
| 286 | +135 |
-
+ } else {
|
||
| 287 | -3x | +136 | +12x |
- lbl <- if (length(aesi) == 1 && !is.null(scope)) {
+ est <- xs_coef[coef_names] |
| 288 | -1x | +137 | +12x |
- scope <- sas_na(scope)+ se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names])) |
| 289 | -1x | +|||
| 138 | +
- scope <- unique(scope)[!is.na(unique(scope))]+ } |
|||
| 290 | -1x | +139 | +32x |
- checkmate::assert_string(scope)+ or <- exp(est) |
| 291 | -1x | +140 | +32x |
- paste0(aesi, " (", scope, ")")
+ ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se) |
| 292 | -3x | +141 | +32x |
- } else if (length(aesi) == 1 && is.null(scope)) {
+ x[[ref_level]] <- list(or = or, ci = ci)+ |
+
| 142 | ++ |
+ } |
||
| 293 | -1x | +143 | +12x |
- aesi+ y[[var_level]] <- x |
| 294 | +144 |
- } else {
+ } |
||
| 295 | -1x | +145 | +7x |
- aesi_label+ y |
| 296 | +146 |
- }+ } |
||
| 297 | +147 | |||
| 298 | -3x | +|||
| 148 | +
- lbl+ #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ |
+ |||
| 149 | ++ |
+ #' for the case when either the odds ratio or the interaction variable is continuous. |
||
| 299 | +150 |
- }+ #' |
||
| 300 | +151 |
-
+ #' @param at (`NULL` or `numeric`)\cr optional values for the interaction variable. Otherwise |
||
| 301 | +152 |
- #' Indicate Study Arm Variable in Formula+ #' the median is used. |
||
| 302 | +153 |
#' |
||
| 303 | +154 |
- #' We use `study_arm` to indicate the study arm variable in `tern` formulas.+ #' @return Odds ratio. |
||
| 304 | +155 |
#' |
||
| 305 | +156 |
- #' @param x arm information+ #' @note We don't provide a function for the case when both variables are continuous because |
||
| 306 | +157 |
- #'+ #' this does not arise in this table, as the treatment arm variable will always be involved |
||
| 307 | +158 |
- #' @return `x`+ #' and categorical. |
||
| 308 | +159 |
#' |
||
| 309 | +160 |
- #' @keywords internal+ #' @export |
||
| 310 | +161 |
- study_arm <- function(x) {
+ h_or_cont_interaction <- function(odds_ratio_var, |
||
| 311 | -! | +|||
| 162 | +
- structure(x, varname = deparse(substitute(x)))+ interaction_var, |
|||
| 312 | +163 |
- }+ fit_glm, |
||
| 313 | +164 |
-
+ at = NULL, |
||
| 314 | +165 |
- #' Smooth Function with Optional Grouping+ conf_level = 0.95) {
|
||
| 315 | -+ | |||
| 166 | +9x |
- #'+ interaction_vars <- h_get_interaction_vars(fit_glm) |
||
| 316 | -+ | |||
| 167 | +9x |
- #' @description `r lifecycle::badge("stable")`
+ checkmate::assert_string(odds_ratio_var) |
||
| 317 | -+ | |||
| 168 | +9x |
- #'+ checkmate::assert_string(interaction_var) |
||
| 318 | -+ | |||
| 169 | +9x |
- #' This produces `loess` smoothed estimates of `y` with Student confidence intervals.+ checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars) |
||
| 319 | -+ | |||
| 170 | +9x |
- #'+ checkmate::assert_vector(interaction_vars, len = 2) |
||
| 320 | -+ | |||
| 171 | +9x |
- #' @param df (`data.frame`)\cr data set containing all analysis variables.+ checkmate::assert_numeric(at, min.len = 1, null.ok = TRUE, any.missing = FALSE) |
||
| 321 | -+ | |||
| 172 | +9x |
- #' @param x (`character`)\cr value with x column name.+ xs_level <- fit_glm$xlevels |
||
| 322 | -+ | |||
| 173 | +9x |
- #' @param y (`character`)\cr value with y column name.+ xs_coef <- stats::coef(fit_glm) |
||
| 323 | -+ | |||
| 174 | +9x |
- #' @param groups (`character`)\cr vector with optional grouping variables names.+ xs_vcov <- stats::vcov(fit_glm) |
||
| 324 | -+ | |||
| 175 | +9x |
- #' @param level (`numeric`)\cr level of confidence interval to use (0.95 by default).+ xs_class <- attr(fit_glm$terms, "dataClasses") |
||
| 325 | -+ | |||
| 176 | +9x |
- #'+ model_data <- fit_glm$model |
||
| 326 | -+ | |||
| 177 | +9x |
- #' @return A `data.frame` with original `x`, smoothed `y`, `ylow`, and `yhigh`, and+ if (!is.null(at)) {
|
||
| 327 | -+ | |||
| 178 | +2x |
- #' optional `groups` variables formatted as `factor` type.+ checkmate::assert_set_equal(xs_class[interaction_var], "numeric") |
||
| 328 | +179 |
- #'+ }+ |
+ ||
| 180 | +9x | +
+ y <- list()+ |
+ ||
| 181 | +9x | +
+ if (xs_class[interaction_var] == "numeric") {
+ |
+ ||
| 182 | +6x | +
+ if (is.null(at)) {
+ |
+ ||
| 183 | +4x | +
+ at <- ceiling(stats::median(model_data[[interaction_var]])) |
||
| 329 | +184 |
- #' @export+ } |
||
| 330 | +185 |
- get_smooths <- function(df, x, y, groups = NULL, level = 0.95) {
+
|
||
| 331 | -5x | +186 | +6x |
- checkmate::assert_data_frame(df)+ for (var_level in xs_level[[odds_ratio_var]][-1]) {
|
| 332 | -5x | +187 | +12x |
- df_cols <- colnames(df)+ x <- list() |
| 333 | -5x | +188 | +12x |
- checkmate::assert_string(x)+ for (increment in at) {
|
| 334 | -5x | +189 | +18x |
- checkmate::assert_subset(x, df_cols)+ coef_names <- paste0(odds_ratio_var, var_level) |
| 335 | -5x | +190 | +18x |
- checkmate::assert_numeric(df[[x]])+ if (increment != 0) {
|
| 336 | -5x | +191 | +18x |
- checkmate::assert_string(y)+ interaction_coef_name <- h_interaction_coef_name( |
| 337 | -5x | +192 | +18x |
- checkmate::assert_subset(y, df_cols)+ interaction_vars, |
| 338 | -5x | +193 | +18x |
- checkmate::assert_numeric(df[[y]])+ c(odds_ratio_var, var_level),+ |
+
| 194 | +18x | +
+ c(interaction_var, "") |
||
| 339 | +195 |
-
+ ) |
||
| 340 | -5x | +196 | +18x |
- if (!is.null(groups)) {
+ coef_names <- c( |
| 341 | -4x | +197 | +18x |
- checkmate::assert_character(groups)+ coef_names, |
| 342 | -4x | +198 | +18x |
- checkmate::assert_subset(groups, df_cols)+ interaction_coef_name |
| 343 | +199 |
- }+ ) |
||
| 344 | +200 |
-
+ } |
||
| 345 | -5x | +201 | +18x |
- smooths <- function(x, y) {
+ if (length(coef_names) > 1) {
|
| 346 | +202 | 18x |
- stats::predict(stats::loess(y ~ x), se = TRUE)+ xvec <- t(c(1, increment))+ |
+ |
| 203 | +18x | +
+ est <- as.numeric(xvec %*% xs_coef[coef_names])+ |
+ ||
| 204 | +18x | +
+ se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec))) |
||
| 347 | +205 |
- }+ } else {
+ |
+ ||
| 206 | +! | +
+ est <- xs_coef[coef_names]+ |
+ ||
| 207 | +! | +
+ se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names])) |
||
| 348 | +208 |
-
+ } |
||
| 349 | -5x | +209 | +18x |
- if (!is.null(groups)) {
+ or <- exp(est) |
| 350 | -4x | +210 | +18x |
- cc <- stats::complete.cases(df[c(x, y, groups)])+ ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se) |
| 351 | -4x | +211 | +18x |
- df_c <- df[cc, c(x, y, groups)]+ x[[as.character(increment)]] <- list(or = or, ci = ci) |
| 352 | -4x | +|||
| 212 | +
- df_c_ordered <- df_c[do.call("order", as.list(df_c[, groups, drop = FALSE])), , drop = FALSE]
+ } |
|||
| 353 | -4x | +213 | +12x |
- df_c_g <- data.frame(Map(as.factor, df_c_ordered[groups]))+ y[[var_level]] <- x |
| 354 | +214 |
-
+ }+ |
+ ||
| 215 | ++ |
+ } else {
|
||
| 355 | -4x | +216 | +3x |
- df_smooth_raw <-+ checkmate::assert_set_equal(xs_class[odds_ratio_var], "numeric") |
| 356 | -4x | +217 | +3x |
- by(df_c_ordered, df_c_g, function(d) {
+ checkmate::assert_set_equal(xs_class[interaction_var], "factor") |
| 357 | -17x | +218 | +3x |
- plx <- smooths(d[[x]], d[[y]])+ for (var_level in xs_level[[interaction_var]]) {
|
| 358 | -17x | +219 | +9x |
- data.frame(+ coef_names <- odds_ratio_var |
| 359 | -17x | +220 | +9x |
- x = d[[x]],+ if (var_level != xs_level[[interaction_var]][1]) {
|
| 360 | -17x | +221 | +6x |
- y = plx$fit,+ interaction_coef_name <- h_interaction_coef_name( |
| 361 | -17x | +222 | +6x |
- ylow = plx$fit - stats::qt(level, plx$df) * plx$se,+ interaction_vars, |
| 362 | -17x | +223 | +6x |
- yhigh = plx$fit + stats::qt(level, plx$df) * plx$se+ c(odds_ratio_var, ""), |
| 363 | -+ | |||
| 224 | +6x |
- )+ c(interaction_var, var_level) |
||
| 364 | +225 |
- })+ ) |
||
| 365 | -+ | |||
| 226 | +6x |
-
+ coef_names <- c( |
||
| 366 | -4x | +227 | +6x |
- df_smooth <- do.call(rbind, df_smooth_raw)+ coef_names, |
| 367 | -4x | +228 | +6x |
- df_smooth[groups] <- df_c_g+ interaction_coef_name |
| 368 | +229 |
-
+ ) |
||
| 369 | -4x | +|||
| 230 | +
- df_smooth+ } |
|||
| 370 | -+ | |||
| 231 | +9x |
- } else {
+ if (length(coef_names) > 1) {
|
||
| 371 | -1x | +232 | +6x |
- cc <- stats::complete.cases(df[c(x, y)])+ xvec <- t(c(1, 1)) |
| 372 | -1x | +233 | +6x |
- df_c <- df[cc, ]+ est <- as.numeric(xvec %*% xs_coef[coef_names]) |
| 373 | -1x | +234 | +6x |
- plx <- smooths(df_c[[x]], df_c[[y]])+ se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec))) |
| 374 | +235 |
-
+ } else {
|
||
| 375 | -1x | +236 | +3x |
- df_smooth <- data.frame(+ est <- xs_coef[coef_names] |
| 376 | -1x | +237 | +3x |
- x = df_c[[x]],+ se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ |
+
| 238 | ++ |
+ } |
||
| 377 | -1x | +239 | +9x |
- y = plx$fit,+ or <- exp(est) |
| 378 | -1x | +240 | +9x |
- ylow = plx$fit - stats::qt(level, plx$df) * plx$se,+ ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se) |
| 379 | -1x | +241 | +9x |
- yhigh = plx$fit + stats::qt(level, plx$df) * plx$se+ y[[var_level]] <- list(or = or, ci = ci) |
| 380 | +242 |
- )+ } |
||
| 381 | +243 |
-
+ } |
||
| 382 | -1x | +244 | +9x |
- df_smooth+ y |
| 383 | +245 |
- }+ } |
||
| 384 | +246 |
- }+ |
||
| 385 | +247 |
-
+ #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates |
||
| 386 | +248 |
- #' Number of Available (Non-Missing Entries) in a Vector+ #' in case of an interaction. This is a wrapper for [h_or_cont_interaction()] and |
||
| 387 | +249 | ++ |
+ #' [h_or_cat_interaction()].+ |
+ |
| 250 |
#' |
|||
| 388 | +251 |
- #' Small utility function for better readability.+ #' @return Odds ratio. |
||
| 389 | +252 |
#' |
||
| 390 | +253 |
- #' @param x (`any`)\cr vector in which to count non-missing values.+ #' @export |
||
| 391 | +254 |
- #'+ h_or_interaction <- function(odds_ratio_var, |
||
| 392 | +255 |
- #' @return Number of non-missing values.+ interaction_var, |
||
| 393 | +256 |
- #'+ fit_glm, |
||
| 394 | +257 |
- #' @keywords internal+ at = NULL, |
||
| 395 | +258 |
- n_available <- function(x) {
+ conf_level = 0.95) {
|
||
| 396 | -254x | +259 | +13x |
- sum(!is.na(x))+ xs_class <- attr(fit_glm$terms, "dataClasses") |
| 397 | -+ | |||
| 260 | +13x |
- }+ if (any(xs_class[c(odds_ratio_var, interaction_var)] == "numeric")) {
|
||
| 398 | -+ | |||
| 261 | +7x |
-
+ h_or_cont_interaction( |
||
| 399 | -+ | |||
| 262 | +7x |
- #' Reapply Variable Labels+ odds_ratio_var,+ |
+ ||
| 263 | +7x | +
+ interaction_var,+ |
+ ||
| 264 | +7x | +
+ fit_glm,+ |
+ ||
| 265 | +7x | +
+ at = at,+ |
+ ||
| 266 | +7x | +
+ conf_level = conf_level |
||
| 400 | +267 |
- #'+ )+ |
+ ||
| 268 | +6x | +
+ } else if (all(xs_class[c(odds_ratio_var, interaction_var)] == "factor")) {
+ |
+ ||
| 269 | +6x | +
+ h_or_cat_interaction(+ |
+ ||
| 270 | +6x | +
+ odds_ratio_var,+ |
+ ||
| 271 | +6x | +
+ interaction_var,+ |
+ ||
| 272 | +6x | +
+ fit_glm,+ |
+ ||
| 273 | +6x | +
+ conf_level = conf_level |
||
| 401 | +274 |
- #' This is a helper function that is used in tests.+ ) |
||
| 402 | +275 |
- #'+ } else {
+ |
+ ||
| 276 | +! | +
+ stop("wrong interaction variable class, the interaction variable is not a numeric nor a factor")
|
||
| 403 | +277 |
- #' @param x (`vector`)\cr vector of elements that needs new labels.+ } |
||
| 404 | +278 |
- #' @param varlabels (`character`)\cr vector of labels for `x`.+ } |
||
| 405 | +279 |
- #' @param ... further parameters to be added to the list.+ |
||
| 406 | +280 |
- #'+ #' @describeIn h_logistic_regression Helper function to construct term labels from simple terms and the table |
||
| 407 | +281 |
- #' @return `x` with variable labels reapplied.+ #' of numbers of patients. |
||
| 408 | +282 |
#' |
||
| 409 | +283 |
- #' @export+ #' @param terms (`character`)\cr simple terms. |
||
| 410 | +284 |
- reapply_varlabels <- function(x, varlabels, ...) {
+ #' @param table (`table`)\cr table containing numbers for terms. |
||
| 411 | -10x | +|||
| 285 | +
- named_labels <- c(as.list(varlabels), list(...))+ #' |
|||
| 412 | -10x | +|||
| 286 | +
- formatters::var_labels(x)[names(named_labels)] <- as.character(named_labels)+ #' @return Term labels containing numbers of patients. |
|||
| 413 | -10x | +|||
| 287 | +
- x+ #' |
|||
| 414 | +288 |
- }+ #' @export |
||
| 415 | +289 |
-
+ h_simple_term_labels <- function(terms, |
||
| 416 | +290 |
- # Wrapper function of survival::clogit so that when model fitting failed, a more useful message would show+ table) {
|
||
| 417 | -+ | |||
| 291 | +45x |
- clogit_with_tryCatch <- function(formula, data, ...) { # nolint
+ checkmate::assert_true(is.table(table)) |
||
| 418 | -30x | +292 | +45x |
- tryCatch(+ checkmate::assert_multi_class(terms, classes = c("factor", "character"))
|
| 419 | -30x | +293 | +45x |
- survival::clogit(formula = formula, data = data, ...),+ terms <- as.character(terms) |
| 420 | -30x | +294 | +45x |
- error = function(e) stop("model not built successfully with survival::clogit")
+ term_n <- table[terms] |
| 421 | -+ | |||
| 295 | +45x |
- )+ paste0(terms, ", n = ", term_n) |
||
| 422 | +296 |
} |
| 1 | +297 |
- #' Multivariate Logistic Regression Table+ |
||
| 2 | +298 |
- #'+ #' @describeIn h_logistic_regression Helper function to construct term labels from interaction terms and the table |
||
| 3 | +299 |
- #' @description `r lifecycle::badge("stable")`
+ #' of numbers of patients. |
||
| 4 | +300 |
#' |
||
| 5 | +301 |
- #' Layout-creating function which summarizes a logistic variable regression for binary outcome with+ #' @param terms1 (`character`)\cr terms for first dimension (rows). |
||
| 6 | +302 |
- #' categorical/continuous covariates in model statement. For each covariate category (if categorical)+ #' @param terms2 (`character`)\cr terms for second dimension (rows). |
||
| 7 | +303 |
- #' or specified values (if continuous), present degrees of freedom, regression parameter estimate and+ #' @param any (`flag`)\cr whether any of `term1` and `term2` can be fulfilled to count the |
||
| 8 | +304 |
- #' standard error (SE) relative to reference group or category. Report odds ratios for each covariate+ #' number of patients. In that case they can only be scalar (strings). |
||
| 9 | +305 |
- #' category or specified values and corresponding Wald confidence intervals as default but allow user+ #' |
||
| 10 | +306 |
- #' to specify other confidence levels. Report p-value for Wald chi-square test of the null hypothesis+ #' @return Term labels containing numbers of patients. |
||
| 11 | +307 |
- #' that covariate has no effect on response in model containing all specified covariates.+ #' |
||
| 12 | +308 |
- #' Allow option to include one two-way interaction and present similar output for+ #' @export |
||
| 13 | +309 |
- #' each interaction degree of freedom.+ h_interaction_term_labels <- function(terms1, |
||
| 14 | +310 |
- #'+ terms2, |
||
| 15 | +311 |
- #' @inheritParams argument_convention+ table, |
||
| 16 | +312 |
- #' @param drop_and_remove_str (`character`)\cr string to be dropped and removed.+ any = FALSE) {
|
||
| 17 | -+ | |||
| 313 | +8x |
- #'+ checkmate::assert_true(is.table(table)) |
||
| 18 | -+ | |||
| 314 | +8x |
- #' @return A layout object suitable for passing to further layouting functions, or to [rtables::build_table()].+ checkmate::assert_flag(any)+ |
+ ||
| 315 | +8x | +
+ checkmate::assert_multi_class(terms1, classes = c("factor", "character"))
+ |
+ ||
| 316 | +8x | +
+ checkmate::assert_multi_class(terms2, classes = c("factor", "character"))
+ |
+ ||
| 317 | +8x | +
+ terms1 <- as.character(terms1)+ |
+ ||
| 318 | +8x | +
+ terms2 <- as.character(terms2)+ |
+ ||
| 319 | +8x | +
+ if (any) {
+ |
+ ||
| 320 | +4x | +
+ checkmate::assert_scalar(terms1)+ |
+ ||
| 321 | +4x | +
+ checkmate::assert_scalar(terms2)+ |
+ ||
| 322 | +4x | +
+ paste0(+ |
+ ||
| 323 | +4x | +
+ terms1, " or ", terms2, ", n = ", |
||
| 19 | +324 |
- #' Adding this function to an `rtable` layout will add a logistic regression variable summary to the table layout.+ # Note that we double count in the initial sum the cell [terms1, terms2], therefore subtract.+ |
+ ||
| 325 | +4x | +
+ sum(c(table[terms1, ], table[, terms2])) - table[terms1, terms2] |
||
| 20 | +326 |
- #'+ ) |
||
| 21 | +327 |
- #' @note For the formula, the variable names need to be standard `data.frame` column names without+ } else {
+ |
+ ||
| 328 | +4x | +
+ term_n <- table[cbind(terms1, terms2)]+ |
+ ||
| 329 | +4x | +
+ paste0(terms1, " * ", terms2, ", n = ", term_n) |
||
| 22 | +330 |
- #' special characters.+ } |
||
| 23 | +331 |
- #'+ } |
||
| 24 | +332 |
- #' @examples+ |
||
| 25 | +333 |
- #' library(dplyr)+ #' @describeIn h_logistic_regression Helper function to tabulate the main effect |
||
| 26 | +334 |
- #' library(broom)+ #' results of a (conditional) logistic regression model. |
||
| 27 | +335 |
#' |
||
| 28 | +336 |
- #' adrs_f <- tern_ex_adrs %>%+ #' @return Tabulated main effect results from a logistic regression model. |
||
| 29 | +337 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' |
||
| 30 | +338 |
- #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ #' @examples |
||
| 31 | +339 |
- #' mutate(+ #' h_glm_simple_term_extract("AGE", mod1)
|
||
| 32 | +340 |
- #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ #' h_glm_simple_term_extract("ARMCD", mod1)
|
||
| 33 | +341 |
- #' RACE = factor(RACE),+ #' |
||
| 34 | +342 |
- #' SEX = factor(SEX)+ #' @export |
||
| 35 | +343 |
- #' )+ h_glm_simple_term_extract <- function(x, fit_glm) {
|
||
| 36 | -+ | |||
| 344 | +61x |
- #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
|
||
| 37 | -+ | |||
| 345 | +61x |
- #' mod1 <- fit_logistic(+ checkmate::assert_string(x) |
||
| 38 | +346 |
- #' data = adrs_f,+ |
||
| 39 | -+ | |||
| 347 | +61x |
- #' variables = list(+ xs_class <- attr(fit_glm$terms, "dataClasses") |
||
| 40 | -+ | |||
| 348 | +61x |
- #' response = "Response",+ xs_level <- fit_glm$xlevels |
||
| 41 | -+ | |||
| 349 | +61x |
- #' arm = "ARMCD",+ xs_coef <- summary(fit_glm)$coefficients |
||
| 42 | -+ | |||
| 350 | +61x |
- #' covariates = c("AGE", "RACE")
+ stats <- if (inherits(fit_glm, "glm")) {
|
||
| 43 | -+ | |||
| 351 | +49x |
- #' )+ c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
|
||
| 44 | +352 |
- #' )+ } else {
|
||
| 45 | -+ | |||
| 353 | +12x |
- #' mod2 <- fit_logistic(+ c("estimate" = "coef", "std_error" = "se(coef)", "pvalue" = "Pr(>|z|)")
|
||
| 46 | +354 |
- #' data = adrs_f,+ } |
||
| 47 | +355 |
- #' variables = list(+ # Make sure x is not an interaction term. |
||
| 48 | -+ | |||
| 356 | +61x |
- #' response = "Response",+ checkmate::assert_subset(x, names(xs_class)) |
||
| 49 | -+ | |||
| 357 | +61x |
- #' arm = "ARMCD",+ x_sel <- if (xs_class[x] == "numeric") x else paste0(x, xs_level[[x]][-1]) |
||
| 50 | -+ | |||
| 358 | +61x |
- #' covariates = c("AGE", "RACE"),
+ x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE) |
||
| 51 | -+ | |||
| 359 | +61x |
- #' interaction = "AGE"+ colnames(x_stats) <- names(stats) |
||
| 52 | -+ | |||
| 360 | +61x |
- #' )+ x_stats$estimate <- as.list(x_stats$estimate) |
||
| 53 | -+ | |||
| 361 | +61x |
- #' )+ x_stats$std_error <- as.list(x_stats$std_error) |
||
| 54 | -+ | |||
| 362 | +61x |
- #'+ x_stats$pvalue <- as.list(x_stats$pvalue) |
||
| 55 | -+ | |||
| 363 | +61x |
- #' df <- tidy(mod1, conf_level = 0.99)+ x_stats$df <- as.list(1) |
||
| 56 | -+ | |||
| 364 | +61x |
- #' df2 <- tidy(mod2, conf_level = 0.99)+ if (xs_class[x] == "numeric") {
|
||
| 57 | -+ | |||
| 365 | +46x |
- #'+ x_stats$term <- x |
||
| 58 | -+ | |||
| 366 | +46x |
- #' # flagging empty strings with "_"+ x_stats$term_label <- if (inherits(fit_glm, "glm")) {
|
||
| 59 | -+ | |||
| 367 | +34x |
- #' df <- df_explicit_na(df, na_level = "_")+ formatters::var_labels(fit_glm$data[x], fill = TRUE) |
||
| 60 | +368 |
- #' df2 <- df_explicit_na(df2, na_level = "_")+ } else {
|
||
| 61 | +369 |
- #'+ # We just fill in here with the `term` itself as we don't have the data available. |
||
| 62 | -+ | |||
| 370 | +12x |
- #' result1 <- basic_table() %>%+ x |
||
| 63 | +371 |
- #' summarize_logistic(+ } |
||
| 64 | -+ | |||
| 372 | +46x |
- #' conf_level = 0.95,+ x_stats$is_variable_summary <- FALSE |
||
| 65 | -+ | |||
| 373 | +46x |
- #' drop_and_remove_str = "_"+ x_stats$is_term_summary <- TRUE |
||
| 66 | +374 |
- #' ) %>%+ } else {
|
||
| 67 | -+ | |||
| 375 | +15x |
- #' build_table(df = df)+ checkmate::assert_class(fit_glm, "glm") |
||
| 68 | +376 |
- #' result1+ # The reason is that we don't have the original data set in the `clogit` object |
||
| 69 | +377 |
- #'+ # and therefore cannot determine the `x_numbers` here. |
||
| 70 | -+ | |||
| 378 | +15x |
- #' result2 <- basic_table() %>%+ x_numbers <- table(fit_glm$data[[x]]) |
||
| 71 | -+ | |||
| 379 | +15x |
- #' summarize_logistic(+ x_stats$term <- xs_level[[x]][-1] |
||
| 72 | -+ | |||
| 380 | +15x |
- #' conf_level = 0.95,+ x_stats$term_label <- h_simple_term_labels(x_stats$term, x_numbers) |
||
| 73 | -+ | |||
| 381 | +15x |
- #' drop_and_remove_str = "_"+ x_stats$is_variable_summary <- FALSE |
||
| 74 | -+ | |||
| 382 | +15x |
- #' ) %>%+ x_stats$is_term_summary <- TRUE |
||
| 75 | -+ | |||
| 383 | +15x |
- #' build_table(df = df2)+ main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald") |
||
| 76 | -+ | |||
| 384 | +15x |
- #' result2+ x_main <- data.frame( |
||
| 77 | -+ | |||
| 385 | +15x |
- #'+ pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE], |
||
| 78 | -+ | |||
| 386 | +15x |
- #' @export+ term = xs_level[[x]][1], |
||
| 79 | -+ | |||
| 387 | +15x |
- summarize_logistic <- function(lyt,+ term_label = paste("Reference", h_simple_term_labels(xs_level[[x]][1], x_numbers)),
|
||
| 80 | -+ | |||
| 388 | +15x |
- conf_level,+ df = main_effects[x, "Df", drop = TRUE], |
||
| 81 | -+ | |||
| 389 | +15x |
- drop_and_remove_str = "",+ stringsAsFactors = FALSE |
||
| 82 | +390 |
- .indent_mods = NULL) {
+ ) |
||
| 83 | -+ | |||
| 391 | +15x |
- # checks+ x_main$pvalue <- as.list(x_main$pvalue) |
||
| 84 | -3x | +392 | +15x |
- checkmate::assert_string(drop_and_remove_str)+ x_main$df <- as.list(x_main$df) |
| 85 | -+ | |||
| 393 | +15x |
-
+ x_main$estimate <- list(numeric(0)) |
||
| 86 | -3x | +394 | +15x |
- sum_logistic_variable_test <- logistic_summary_by_flag("is_variable_summary")
+ x_main$std_error <- list(numeric(0)) |
| 87 | -3x | +395 | +15x |
- sum_logistic_term_estimates <- logistic_summary_by_flag("is_term_summary", .indent_mods = .indent_mods)
+ if (length(xs_level[[x]][-1]) == 1) {
|
| 88 | -3x | +396 | +6x |
- sum_logistic_odds_ratios <- logistic_summary_by_flag("is_reference_summary", .indent_mods = .indent_mods)
+ x_main$pvalue <- list(numeric(0)) |
| 89 | -3x | +397 | +6x |
- split_fun <- drop_and_remove_levels(drop_and_remove_str)+ x_main$df <- list(numeric(0)) |
| 90 | +398 |
-
+ } |
||
| 91 | -3x | +399 | +15x |
- lyt <- logistic_regression_cols(lyt, conf_level = conf_level)+ x_main$is_variable_summary <- TRUE |
| 92 | -3x | +400 | +15x |
- lyt <- split_rows_by(lyt, var = "variable", labels_var = "variable_label", split_fun = split_fun)+ x_main$is_term_summary <- FALSE |
| 93 | -3x | +401 | +15x |
- lyt <- sum_logistic_variable_test(lyt)+ x_stats <- rbind(x_main, x_stats) |
| 94 | -3x | +|||
| 402 | +
- lyt <- split_rows_by(lyt, var = "term", labels_var = "term_label", split_fun = split_fun)+ } |
|||
| 95 | -3x | +403 | +61x |
- lyt <- sum_logistic_term_estimates(lyt)+ x_stats$variable <- x |
| 96 | -3x | +404 | +61x |
- lyt <- split_rows_by(lyt, var = "interaction", labels_var = "interaction_label", split_fun = split_fun)+ x_stats$variable_label <- if (inherits(fit_glm, "glm")) {
|
| 97 | -3x | +405 | +49x |
- lyt <- split_rows_by(lyt, var = "reference", labels_var = "reference_label", split_fun = split_fun)+ formatters::var_labels(fit_glm$data[x], fill = TRUE) |
| 98 | -3x | +|||
| 406 | +
- lyt <- sum_logistic_odds_ratios(lyt)+ } else {
|
|||
| 99 | -3x | +407 | +12x |
- lyt+ x |
| 100 | +408 |
- }+ } |
||
| 101 | -+ | |||
| 409 | +61x |
-
+ x_stats$interaction <- "" |
||
| 102 | -+ | |||
| 410 | +61x |
- #' Fit for Logistic Regression+ x_stats$interaction_label <- "" |
||
| 103 | -+ | |||
| 411 | +61x |
- #'+ x_stats$reference <- "" |
||
| 104 | -+ | |||
| 412 | +61x |
- #' @description `r lifecycle::badge("stable")`
+ x_stats$reference_label <- "" |
||
| 105 | -+ | |||
| 413 | +61x |
- #'+ rownames(x_stats) <- NULL |
||
| 106 | -+ | |||
| 414 | +61x |
- #' Fit a (conditional) logistic regression model.+ x_stats[c( |
||
| 107 | -+ | |||
| 415 | +61x |
- #'+ "variable", |
||
| 108 | -+ | |||
| 416 | +61x |
- #' @inheritParams argument_convention+ "variable_label", |
||
| 109 | -+ | |||
| 417 | +61x |
- #' @param data (`data.frame`)\cr the data frame on which the model was fit.+ "term", |
||
| 110 | -+ | |||
| 418 | +61x |
- #' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`.+ "term_label", |
||
| 111 | -+ | |||
| 419 | +61x |
- #' This will be used when fitting the (conditional) logistic regression model on the left hand+ "interaction", |
||
| 112 | -+ | |||
| 420 | +61x |
- #' side of the formula.+ "interaction_label", |
||
| 113 | -+ | |||
| 421 | +61x |
- #'+ "reference", |
||
| 114 | -+ | |||
| 422 | +61x |
- #' @return A fitted logistic regression model.+ "reference_label", |
||
| 115 | -+ | |||
| 423 | +61x |
- #'+ "estimate", |
||
| 116 | -+ | |||
| 424 | +61x |
- #' @section Model Specification:+ "std_error",+ |
+ ||
| 425 | +61x | +
+ "df",+ |
+ ||
| 426 | +61x | +
+ "pvalue",+ |
+ ||
| 427 | +61x | +
+ "is_variable_summary",+ |
+ ||
| 428 | +61x | +
+ "is_term_summary" |
||
| 117 | +429 |
- #'+ )] |
||
| 118 | +430 |
- #' The `variables` list needs to include the following elements:+ } |
||
| 119 | +431 |
- #' * `arm`: Treatment arm variable name.+ |
||
| 120 | +432 |
- #' * `response`: The response arm variable name. Usually this is a 0/1 variable.+ #' @describeIn h_logistic_regression Helper function to tabulate the interaction term |
||
| 121 | +433 |
- #' * `covariates`: This is either `NULL` (no covariates) or a character vector of covariate variable names.+ #' results of a logistic regression model. |
||
| 122 | +434 |
- #' * `interaction`: This is either `NULL` (no interaction) or a string of a single covariate variable name already+ #' |
||
| 123 | +435 |
- #' included in `covariates`. Then the interaction with the treatment arm is included in the model.+ #' @return Tabulated interaction term results from a logistic regression model. |
||
| 124 | +436 |
#' |
||
| 125 | +437 |
#' @examples |
||
| 126 | +438 |
- #' library(dplyr)+ #' h_glm_interaction_extract("ARMCD:AGE", mod2)
|
||
| 127 | +439 |
#' |
||
| 128 | +440 |
- #' adrs_f <- tern_ex_adrs %>%+ #' @export |
||
| 129 | +441 |
- #' filter(PARAMCD == "BESRSPI") %>%+ h_glm_interaction_extract <- function(x, fit_glm) {
|
||
| 130 | -+ | |||
| 442 | +6x |
- #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ vars <- h_get_interaction_vars(fit_glm) |
||
| 131 | -+ | |||
| 443 | +6x |
- #' mutate(+ xs_class <- attr(fit_glm$terms, "dataClasses") |
||
| 132 | +444 |
- #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+
|
||
| 133 | -+ | |||
| 445 | +6x |
- #' RACE = factor(RACE),+ checkmate::assert_string(x) |
||
| 134 | +446 |
- #' SEX = factor(SEX)+ |
||
| 135 | +447 |
- #' )+ # Only take two-way interaction |
||
| 136 | -+ | |||
| 448 | +6x |
- #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ checkmate::assert_vector(vars, len = 2) |
||
| 137 | +449 |
- #' mod1 <- fit_logistic(+ |
||
| 138 | +450 |
- #' data = adrs_f,+ # Only consider simple case: first variable in interaction is arm, a categorical variable |
||
| 139 | -+ | |||
| 451 | +6x |
- #' variables = list(+ checkmate::assert_disjunct(xs_class[vars[1]], "numeric") |
||
| 140 | +452 |
- #' response = "Response",+ |
||
| 141 | -+ | |||
| 453 | +6x |
- #' arm = "ARMCD",+ xs_level <- fit_glm$xlevels |
||
| 142 | -+ | |||
| 454 | +6x |
- #' covariates = c("AGE", "RACE")
+ xs_coef <- summary(fit_glm)$coefficients |
||
| 143 | -+ | |||
| 455 | +6x |
- #' )+ main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald") |
||
| 144 | -+ | |||
| 456 | +6x |
- #' )+ stats <- c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
|
||
| 145 | -+ | |||
| 457 | +6x |
- #' mod2 <- fit_logistic(+ v1_comp <- xs_level[[vars[1]]][-1] |
||
| 146 | -+ | |||
| 458 | +6x |
- #' data = adrs_f,+ if (xs_class[vars[2]] == "numeric") {
|
||
| 147 | -+ | |||
| 459 | +3x |
- #' variables = list(+ x_stats <- as.data.frame( |
||
| 148 | -+ | |||
| 460 | +3x |
- #' response = "Response",+ xs_coef[paste0(vars[1], v1_comp, ":", vars[2]), stats, drop = FALSE], |
||
| 149 | -+ | |||
| 461 | +3x |
- #' arm = "ARMCD",+ stringsAsFactors = FALSE |
||
| 150 | +462 |
- #' covariates = c("AGE", "RACE"),
+ ) |
||
| 151 | -+ | |||
| 463 | +3x |
- #' interaction = "AGE"+ colnames(x_stats) <- names(stats) |
||
| 152 | -+ | |||
| 464 | +3x |
- #' )+ x_stats$term <- v1_comp |
||
| 153 | -+ | |||
| 465 | +3x |
- #' )+ x_numbers <- table(fit_glm$data[[vars[1]]]) |
||
| 154 | -+ | |||
| 466 | +3x |
- #'+ x_stats$term_label <- h_simple_term_labels(v1_comp, x_numbers) |
||
| 155 | -+ | |||
| 467 | +3x |
- #' @export+ v1_ref <- xs_level[[vars[1]]][1] |
||
| 156 | -+ | |||
| 468 | +3x |
- fit_logistic <- function(data,+ term_main <- v1_ref |
||
| 157 | -+ | |||
| 469 | +3x |
- variables = list(+ ref_label <- h_simple_term_labels(v1_ref, x_numbers) |
||
| 158 | -+ | |||
| 470 | +3x |
- response = "Response",+ } else if (xs_class[vars[2]] != "numeric") {
|
||
| 159 | -+ | |||
| 471 | +3x |
- arm = "ARMCD",+ v2_comp <- xs_level[[vars[2]]][-1] |
||
| 160 | -+ | |||
| 472 | +3x |
- covariates = NULL,+ v1_v2_grid <- expand.grid(v1 = v1_comp, v2 = v2_comp) |
||
| 161 | -+ | |||
| 473 | +3x |
- interaction = NULL,+ x_sel <- paste( |
||
| 162 | -+ | |||
| 474 | +3x |
- strata = NULL+ paste0(vars[1], v1_v2_grid$v1), |
||
| 163 | -+ | |||
| 475 | +3x |
- ),+ paste0(vars[2], v1_v2_grid$v2),+ |
+ ||
| 476 | +3x | +
+ sep = ":" |
||
| 164 | +477 |
- response_definition = "response") {
+ ) |
||
| 165 | -62x | +478 | +3x |
- assert_df_with_variables(data, variables)+ x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE) |
| 166 | -62x | +479 | +3x |
- checkmate::assert_subset(names(variables), c("response", "arm", "covariates", "interaction", "strata"))
+ colnames(x_stats) <- names(stats) |
| 167 | -62x | +480 | +3x |
- checkmate::assert_string(response_definition)+ x_stats$term <- paste(v1_v2_grid$v1, "*", v1_v2_grid$v2) |
| 168 | -62x | +481 | +3x |
- checkmate::assert_true(grepl("response", response_definition))
+ x_numbers <- table(fit_glm$data[[vars[1]]], fit_glm$data[[vars[2]]]) |
| 169 | -+ | |||
| 482 | +3x |
-
+ x_stats$term_label <- h_interaction_term_labels(v1_v2_grid$v1, v1_v2_grid$v2, x_numbers) |
||
| 170 | -62x | +483 | +3x |
- response_definition <- sub(+ v1_ref <- xs_level[[vars[1]]][1] |
| 171 | -62x | +484 | +3x |
- pattern = "response",+ v2_ref <- xs_level[[vars[2]]][1] |
| 172 | -62x | +485 | +3x |
- replacement = variables$response,+ term_main <- paste(vars[1], vars[2], sep = " * ") |
| 173 | -62x | +486 | +3x |
- x = response_definition,+ ref_label <- h_interaction_term_labels(v1_ref, v2_ref, x_numbers, any = TRUE)+ |
+
| 487 | ++ |
+ } |
||
| 174 | -62x | +488 | +6x |
- fixed = TRUE+ x_stats$df <- as.list(1) |
| 175 | -+ | |||
| 489 | +6x |
- )+ x_stats$pvalue <- as.list(x_stats$pvalue) |
||
| 176 | -62x | +490 | +6x |
- form <- paste0(response_definition, " ~ ", variables$arm)+ x_stats$is_variable_summary <- FALSE |
| 177 | -62x | +491 | +6x |
- if (!is.null(variables$covariates)) {
+ x_stats$is_term_summary <- TRUE |
| 178 | -28x | +492 | +6x |
- form <- paste0(form, " + ", paste(variables$covariates, collapse = " + "))+ x_main <- data.frame( |
| 179 | -+ | |||
| 493 | +6x |
- }+ pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE], |
||
| 180 | -62x | +494 | +6x |
- if (!is.null(variables$interaction)) {
+ term = term_main, |
| 181 | -17x | +495 | +6x |
- checkmate::assert_string(variables$interaction)+ term_label = paste("Reference", ref_label),
|
| 182 | -17x | +496 | +6x |
- checkmate::assert_subset(variables$interaction, variables$covariates)+ df = main_effects[x, "Df", drop = TRUE], |
| 183 | -17x | +497 | +6x |
- form <- paste0(form, " + ", variables$arm, ":", variables$interaction)+ stringsAsFactors = FALSE |
| 184 | +498 |
- }+ ) |
||
| 185 | -62x | +499 | +6x |
- if (!is.null(variables$strata)) {
+ x_main$pvalue <- as.list(x_main$pvalue) |
| 186 | -14x | +500 | +6x |
- strata_arg <- if (length(variables$strata) > 1) {
+ x_main$df <- as.list(x_main$df) |
| 187 | -7x | -
- paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
- |
- ||
| 188 | -+ | 501 | +6x |
- } else {
+ x_main$estimate <- list(numeric(0)) |
| 189 | -7x | +502 | +6x |
- variables$strata+ x_main$std_error <- list(numeric(0)) |
| 190 | -+ | |||
| 503 | +6x |
- }+ x_main$is_variable_summary <- TRUE |
||
| 191 | -14x | +504 | +6x |
- form <- paste0(form, "+ strata(", strata_arg, ")")
+ x_main$is_term_summary <- FALSE |
| 192 | +505 |
- }+ |
||
| 193 | -62x | +506 | +6x |
- formula <- stats::as.formula(form)+ x_stats <- rbind(x_main, x_stats) |
| 194 | -62x | +507 | +6x |
- if (is.null(variables$strata)) {
+ x_stats$variable <- x |
| 195 | -48x | +508 | +6x |
- stats::glm(+ x_stats$variable_label <- paste( |
| 196 | -48x | +509 | +6x |
- formula = formula,+ "Interaction of", |
| 197 | -48x | +510 | +6x |
- data = data,+ formatters::var_labels(fit_glm$data[vars[1]], fill = TRUE), |
| 198 | -48x | +|||
| 511 | +
- family = stats::binomial("logit")
+ "*", |
|||
| 199 | -+ | |||
| 512 | +6x |
- )+ formatters::var_labels(fit_glm$data[vars[2]], fill = TRUE) |
||
| 200 | +513 |
- } else {
+ ) |
||
| 201 | -14x | +514 | +6x |
- clogit_with_tryCatch(+ x_stats$interaction <- "" |
| 202 | -14x | +515 | +6x |
- formula = formula,+ x_stats$interaction_label <- "" |
| 203 | -14x | +516 | +6x |
- data = data,+ x_stats$reference <- "" |
| 204 | -14x | -
- x = TRUE- |
- ||
| 205 | -+ | 517 | +6x |
- )+ x_stats$reference_label <- "" |
| 206 | -+ | |||
| 518 | +6x |
- }+ rownames(x_stats) <- NULL |
||
| 207 | -+ | |||
| 519 | +6x |
- }+ x_stats[c( |
||
| 208 | -+ | |||
| 520 | +6x |
-
+ "variable", |
||
| 209 | -+ | |||
| 521 | +6x |
- #' Custom Tidy Method for Binomial GLM Results+ "variable_label", |
||
| 210 | -+ | |||
| 522 | +6x |
- #'+ "term", |
||
| 211 | -+ | |||
| 523 | +6x |
- #' @description `r lifecycle::badge("stable")`
+ "term_label", |
||
| 212 | -+ | |||
| 524 | +6x |
- #'+ "interaction", |
||
| 213 | -+ | |||
| 525 | +6x |
- #' Helper method (for [broom::tidy()]) to prepare a data frame from a `glm` object+ "interaction_label", |
||
| 214 | -+ | |||
| 526 | +6x |
- #' with `binomial` family.+ "reference", |
||
| 215 | -+ | |||
| 527 | +6x |
- #'+ "reference_label", |
||
| 216 | -+ | |||
| 528 | +6x |
- #' @inheritParams argument_convention+ "estimate", |
||
| 217 | -+ | |||
| 529 | +6x |
- #' @param at (`NULL` or `numeric`)\cr optional values for the interaction variable. Otherwise the median is used.+ "std_error", |
||
| 218 | -+ | |||
| 530 | +6x |
- #' @param x logistic regression model fitted by [stats::glm()] with "binomial" family.+ "df", |
||
| 219 | -+ | |||
| 531 | +6x |
- #'+ "pvalue", |
||
| 220 | -+ | |||
| 532 | +6x |
- #' @return A `data.frame` containing the tidied model.+ "is_variable_summary", |
||
| 221 | -+ | |||
| 533 | +6x |
- #'+ "is_term_summary" |
||
| 222 | +534 |
- #' @method tidy glm+ )] |
||
| 223 | +535 |
- #'+ } |
||
| 224 | +536 |
- #' @seealso [h_logistic_regression] for relevant helper functions.+ |
||
| 225 | +537 |
- #'+ #' @describeIn h_logistic_regression Helper function to tabulate the interaction |
||
| 226 | +538 |
- #' @examples+ #' results of a logistic regression model. This basically is a wrapper for |
||
| 227 | +539 |
- #' library(dplyr)+ #' [h_or_interaction()] and [h_glm_simple_term_extract()] which puts the results |
||
| 228 | +540 |
- #' library(broom)+ #' in the right data frame format. |
||
| 229 | +541 |
#' |
||
| 230 | -- |
- #' adrs_f <- tern_ex_adrs %>%- |
- ||
| 231 | +542 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' @return A `data.frame` of tabulated interaction term results from a logistic regression model. |
||
| 232 | +543 |
- #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ #' |
||
| 233 | +544 |
- #' mutate(+ #' @examples |
||
| 234 | +545 |
- #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ #' h_glm_inter_term_extract("AGE", "ARMCD", mod2)
|
||
| 235 | +546 |
- #' RACE = factor(RACE),+ #' |
||
| 236 | +547 |
- #' SEX = factor(SEX)+ #' @export |
||
| 237 | +548 |
- #' )+ h_glm_inter_term_extract <- function(odds_ratio_var, |
||
| 238 | +549 |
- #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ interaction_var, |
||
| 239 | +550 |
- #' mod1 <- fit_logistic(+ fit_glm, |
||
| 240 | +551 |
- #' data = adrs_f,+ ...) {
|
||
| 241 | +552 |
- #' variables = list(+ # First obtain the main effects. |
||
| 242 | -+ | |||
| 553 | +11x |
- #' response = "Response",+ main_stats <- h_glm_simple_term_extract(odds_ratio_var, fit_glm) |
||
| 243 | -+ | |||
| 554 | +11x |
- #' arm = "ARMCD",+ main_stats$is_reference_summary <- FALSE |
||
| 244 | -+ | |||
| 555 | +11x |
- #' covariates = c("AGE", "RACE")
+ main_stats$odds_ratio <- NA |
||
| 245 | -+ | |||
| 556 | +11x |
- #' )+ main_stats$lcl <- NA |
||
| 246 | -+ | |||
| 557 | +11x |
- #' )+ main_stats$ucl <- NA |
||
| 247 | +558 |
- #' mod2 <- fit_logistic(+ |
||
| 248 | +559 |
- #' data = adrs_f,+ # Then we get the odds ratio estimates and put into df form. |
||
| 249 | -+ | |||
| 560 | +11x |
- #' variables = list(+ or_numbers <- h_or_interaction(odds_ratio_var, interaction_var, fit_glm, ...) |
||
| 250 | -+ | |||
| 561 | +11x |
- #' response = "Response",+ is_num_or_var <- attr(fit_glm$terms, "dataClasses")[odds_ratio_var] == "numeric" |
||
| 251 | +562 |
- #' arm = "ARMCD",+ |
||
| 252 | -+ | |||
| 563 | +11x |
- #' covariates = c("AGE", "RACE"),
+ if (is_num_or_var) {
|
||
| 253 | +564 |
- #' interaction = "AGE"+ # Numeric OR variable case. |
||
| 254 | -+ | |||
| 565 | +3x |
- #' )+ references <- names(or_numbers) |
||
| 255 | -+ | |||
| 566 | +3x |
- #' )+ n_ref <- length(references) |
||
| 256 | +567 |
- #'+ |
||
| 257 | -+ | |||
| 568 | +3x |
- #' df <- tidy(mod1, conf_level = 0.99)+ extract_from_list <- function(l, name, pos = 1) {
|
||
| 258 | -+ | |||
| 569 | +9x |
- #' df2 <- tidy(mod2, conf_level = 0.99)+ unname(unlist( |
||
| 259 | -+ | |||
| 570 | +9x |
- #'+ lapply(or_numbers, function(x) {
|
||
| 260 | -+ | |||
| 571 | +27x |
- #' @export+ x[[name]][pos] |
||
| 261 | +572 |
- tidy.glm <- function(x, # nolint+ }) |
||
| 262 | +573 |
- conf_level = 0.95,+ )) |
||
| 263 | +574 |
- at = NULL,+ } |
||
| 264 | -+ | |||
| 575 | +3x |
- ...) {
+ or_stats <- data.frame( |
||
| 265 | -5x | +576 | +3x |
- checkmate::assert_class(x, "glm")+ variable = odds_ratio_var, |
| 266 | -5x | +577 | +3x |
- checkmate::assert_set_equal(x$family$family, "binomial")+ variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)), |
| 267 | -+ | |||
| 578 | +3x |
-
+ term = odds_ratio_var, |
||
| 268 | -5x | +579 | +3x |
- terms_name <- attr(stats::terms(x), "term.labels")+ term_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)), |
| 269 | -5x | +580 | +3x |
- xs_class <- attr(x$terms, "dataClasses")+ interaction = interaction_var, |
| 270 | -5x | +581 | +3x |
- interaction <- terms_name[which(!terms_name %in% names(xs_class))]+ interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)), |
| 271 | -5x | +582 | +3x |
- df <- if (length(interaction) == 0) {
+ reference = references, |
| 272 | -2x | +583 | +3x |
- h_logistic_simple_terms(+ reference_label = references, |
| 273 | -2x | +584 | +3x |
- x = terms_name,+ estimate = NA, |
| 274 | -2x | +585 | +3x |
- fit_glm = x,+ std_error = NA, |
| 275 | -2x | +586 | +3x |
- conf_level = conf_level+ odds_ratio = extract_from_list(or_numbers, "or"), |
| 276 | -+ | |||
| 587 | +3x |
- )+ lcl = extract_from_list(or_numbers, "ci", pos = "lcl"), |
||
| 277 | -+ | |||
| 588 | +3x |
- } else {
+ ucl = extract_from_list(or_numbers, "ci", pos = "ucl"), |
||
| 278 | +589 | 3x |
- h_logistic_inter_terms(+ df = NA, |
|
| 279 | +590 | 3x |
- x = terms_name,+ pvalue = NA, |
|
| 280 | +591 | 3x |
- fit_glm = x,+ is_variable_summary = FALSE, |
|
| 281 | +592 | 3x |
- conf_level = conf_level,+ is_term_summary = FALSE, |
|
| 282 | +593 | 3x |
- at = at+ is_reference_summary = TRUE |
|
| 283 | +594 |
) |
||
| 284 | +595 |
- }+ } else {
+ |
+ ||
| 596 | ++ |
+ # Categorical OR variable case. |
||
| 285 | -5x | +597 | +8x |
- for (var in c("variable", "term", "interaction", "reference")) {
+ references <- names(or_numbers[[1]]) |
| 286 | -20x | +598 | +8x |
- df[[var]] <- factor(df[[var]], levels = unique(df[[var]]))+ n_ref <- length(references) |
| 287 | +599 |
- }+ |
||
| 288 | -5x | +600 | +8x |
- df+ extract_from_list <- function(l, name, pos = 1) {
|
| 289 | -+ | |||
| 601 | +24x |
- }+ unname(unlist( |
||
| 290 | -+ | |||
| 602 | +24x |
-
+ lapply(or_numbers, function(x) {
|
||
| 291 | -+ | |||
| 603 | +42x |
- #' Logistic Regression Multivariate Column Layout Function+ lapply(x, function(y) y[[name]][pos]) |
||
| 292 | +604 |
- #'+ }) |
||
| 293 | +605 |
- #' @description `r lifecycle::badge("stable")`
+ )) |
||
| 294 | +606 |
- #'+ } |
||
| 295 | -+ | |||
| 607 | +8x |
- #' Layout-creating function which creates a multivariate column layout summarizing logistic+ or_stats <- data.frame( |
||
| 296 | -+ | |||
| 608 | +8x |
- #' regression results. This function is a wrapper for [rtables::split_cols_by_multivar()].+ variable = odds_ratio_var, |
||
| 297 | -+ | |||
| 609 | +8x |
- #'+ variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)), |
||
| 298 | -+ | |||
| 610 | +8x |
- #' @inheritParams argument_convention+ term = rep(names(or_numbers), each = n_ref), |
||
| 299 | -+ | |||
| 611 | +8x |
- #'+ term_label = h_simple_term_labels(rep(names(or_numbers), each = n_ref), table(fit_glm$data[[odds_ratio_var]])), |
||
| 300 | -+ | |||
| 612 | +8x |
- #' @return A layout object suitable for passing to further layouting functions. Adding this+ interaction = interaction_var, |
||
| 301 | -+ | |||
| 613 | +8x |
- #' function to an `rtable` layout will split the table into columns corresponding to+ interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)), |
||
| 302 | -+ | |||
| 614 | +8x |
- #' statistics `df`, `estimate`, `std_error`, `odds_ratio`, `ci`, and `pvalue`.+ reference = unlist(lapply(or_numbers, names)), |
||
| 303 | -+ | |||
| 615 | +8x |
- #'+ reference_label = unlist(lapply(or_numbers, names)), |
||
| 304 | -+ | |||
| 616 | +8x |
- #' @export+ estimate = NA, |
||
| 305 | -+ | |||
| 617 | +8x |
- logistic_regression_cols <- function(lyt,+ std_error = NA, |
||
| 306 | -+ | |||
| 618 | +8x |
- conf_level = 0.95) {
+ odds_ratio = extract_from_list(or_numbers, "or"), |
||
| 307 | -4x | +619 | +8x |
- vars <- c("df", "estimate", "std_error", "odds_ratio", "ci", "pvalue")
+ lcl = extract_from_list(or_numbers, "ci", pos = "lcl"), |
| 308 | -4x | +620 | +8x |
- var_labels <- c(+ ucl = extract_from_list(or_numbers, "ci", pos = "ucl"), |
| 309 | -4x | +621 | +8x |
- df = "Degrees of Freedom",+ df = NA, |
| 310 | -4x | +622 | +8x |
- estimate = "Parameter Estimate",+ pvalue = NA, |
| 311 | -4x | +623 | +8x |
- std_error = "Standard Error",+ is_variable_summary = FALSE, |
| 312 | -4x | +624 | +8x |
- odds_ratio = "Odds Ratio",+ is_term_summary = FALSE, |
| 313 | -4x | +625 | +8x |
- ci = paste("Wald", f_conf_level(conf_level)),
+ is_reference_summary = TRUE |
| 314 | -4x | +|||
| 626 | +
- pvalue = "p-value"+ ) |
|||
| 315 | +627 |
- )+ } |
||
| 316 | -4x | +|||
| 628 | +
- split_cols_by_multivar(+ |
|||
| 317 | -4x | +629 | +11x |
- lyt = lyt,+ df <- rbind( |
| 318 | -4x | +630 | +11x |
- vars = vars,+ main_stats[, names(or_stats)], |
| 319 | -4x | +631 | +11x |
- varlabels = var_labels+ or_stats |
| 320 | +632 |
) |
||
| 633 | +11x | +
+ df[order(-df$is_variable_summary, df$term, -df$is_term_summary, df$reference), ]+ |
+ ||
| 321 | +634 |
} |
||
| 322 | +635 | |||
| 323 | +636 |
- #' Logistic Regression Summary Table Constructor Function+ #' @describeIn h_logistic_regression Helper function to tabulate the results including |
||
| 324 | +637 |
- #'+ #' odds ratios and confidence intervals of simple terms. |
||
| 325 | +638 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 326 | +639 |
- #'+ #' @return Tabulated statistics for the given variable(s) from the logistic regression model. |
||
| 327 | +640 |
- #' Constructor for content functions to be used in [`summarize_logistic()`] to summarize+ #' |
||
| 328 | +641 |
- #' logistic regression results. This function is a wrapper for [rtables::summarize_row_groups()].+ #' @examples |
||
| 329 | +642 |
- #'+ #' h_logistic_simple_terms("AGE", mod1)
|
||
| 330 | +643 |
- #' @inheritParams argument_convention+ #' |
||
| 331 | +644 |
- #' @param flag_var (`string`)\cr variable name identifying which row should be used in this+ #' @export |
||
| 332 | +645 |
- #' content function.+ h_logistic_simple_terms <- function(x, fit_glm, conf_level = 0.95) {
|
||
| 333 | -+ | |||
| 646 | +40x |
- #'+ checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
|
||
| 334 | -+ | |||
| 647 | +40x |
- #' @return A content function.+ if (inherits(fit_glm, "glm")) {
|
||
| 335 | -+ | |||
| 648 | +29x |
- #'+ checkmate::assert_set_equal(fit_glm$family$family, "binomial") |
||
| 336 | +649 |
- #' @export+ } |
||
| 337 | -+ | |||
| 650 | +40x |
- logistic_summary_by_flag <- function(flag_var, .indent_mods = NULL) {
+ terms_name <- attr(stats::terms(fit_glm), "term.labels") |
||
| 338 | -10x | +651 | +40x |
- checkmate::assert_string(flag_var)+ xs_class <- attr(fit_glm$terms, "dataClasses") |
| 339 | -10x | +652 | +40x |
- function(lyt) {
+ interaction <- terms_name[which(!terms_name %in% names(xs_class))] |
| 340 | -10x | +653 | +40x |
- cfun_list <- list(+ checkmate::assert_subset(x, terms_name) |
| 341 | -10x | +654 | +40x |
- df = cfun_by_flag("df", flag_var, format = "xx.", .indent_mods = .indent_mods),
+ if (length(interaction) != 0) {
+ |
+
| 655 | ++ |
+ # Make sure any item in x is not part of interaction term |
||
| 342 | -10x | +656 | +1x |
- estimate = cfun_by_flag("estimate", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
+ checkmate::assert_disjunct(x, unlist(strsplit(interaction, ":")))+ |
+
| 657 | ++ |
+ } |
||
| 343 | -10x | +658 | +40x |
- std_error = cfun_by_flag("std_error", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
+ x_stats <- lapply(x, h_glm_simple_term_extract, fit_glm) |
| 344 | -10x | +659 | +40x |
- odds_ratio = cfun_by_flag("odds_ratio", flag_var, format = ">999.99", .indent_mods = .indent_mods),
+ x_stats <- do.call(rbind, x_stats) |
| 345 | -10x | +660 | +40x |
- ci = cfun_by_flag("ci", flag_var, format = format_extreme_values_ci(2L), .indent_mods = .indent_mods),
+ q_norm <- stats::qnorm((1 + conf_level) / 2) |
| 346 | -10x | +661 | +40x |
- pvalue = cfun_by_flag("pvalue", flag_var, format = "x.xxxx | (<0.0001)", .indent_mods = .indent_mods)
+ x_stats$odds_ratio <- lapply(x_stats$estimate, exp) |
| 347 | -+ | |||
| 662 | +40x |
- )+ x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
||
| 348 | -10x | +663 | +40x |
- summarize_row_groups(+ x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
| 349 | -10x | +664 | +40x |
- lyt = lyt,+ x_stats$ci <- Map(function(lcl, ucl) c(lcl, ucl), lcl = x_stats$lcl, ucl = x_stats$ucl) |
| 350 | -10x | +665 | +40x |
- cfun = cfun_list+ x_stats |
| 351 | +666 |
- )+ } |
||
| 352 | +667 |
- }+ |
||
| 353 | +668 |
- }+ #' @describeIn h_logistic_regression Helper function to tabulate the results including |
| 1 | +669 |
- #' Occurrence Counts+ #' odds ratios and confidence intervals of interaction terms. |
||
| 2 | +670 |
#' |
||
| 3 | +671 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return Tabulated statistics for the given variable(s) from the logistic regression model. |
||
| 4 | +672 |
#' |
||
| 5 | +673 |
- #' Functions for analyzing frequencies and fractions of occurrences for patients with occurrence+ #' @examples |
||
| 6 | +674 |
- #' data. Primary analysis variables are the dictionary terms. All occurrences are counted for total+ #' h_logistic_inter_terms(c("RACE", "AGE", "ARMCD", "AGE:ARMCD"), mod2)
|
||
| 7 | +675 |
- #' counts. Multiple occurrences within patient at the lowest term level displayed in the table are+ #' |
||
| 8 | +676 |
- #' counted only once.+ #' @export |
||
| 9 | +677 |
- #'+ h_logistic_inter_terms <- function(x, |
||
| 10 | +678 |
- #' @inheritParams argument_convention+ fit_glm, |
||
| 11 | +679 |
- #'+ conf_level = 0.95, |
||
| 12 | +680 |
- #' @note By default, occurrences which don't appear in a given row split are dropped from the table and+ at = NULL) {
|
||
| 13 | +681 |
- #' the occurrences in the table are sorted alphabetically per row split. Therefore, the corresponding layout+ # Find out the interaction variables and interaction term. |
||
| 14 | -+ | |||
| 682 | +4x |
- #' needs to use `split_fun = drop_split_levels` in the `split_rows_by` calls. Use `drop = FALSE` if you would+ inter_vars <- h_get_interaction_vars(fit_glm) |
||
| 15 | -+ | |||
| 683 | +4x |
- #' like to show all occurrences.+ checkmate::assert_vector(inter_vars, len = 2) |
||
| 16 | +684 |
- #'+ |
||
| 17 | +685 |
- #' @name count_occurrences+ |
||
| 18 | -+ | |||
| 686 | +4x |
- NULL+ inter_term_index <- intersect(grep(inter_vars[1], x), grep(inter_vars[2], x))+ |
+ ||
| 687 | +4x | +
+ inter_term <- x[inter_term_index] |
||
| 19 | +688 | |||
| 20 | +689 |
- #' @describeIn count_occurrences Statistics function which counts number of patients that report an+ # For the non-interaction vars we need the standard stuff. |
||
| 21 | -+ | |||
| 690 | +4x |
- #' occurrence.+ normal_terms <- setdiff(x, union(inter_vars, inter_term)) |
||
| 22 | +691 |
- #'+ |
||
| 23 | -+ | |||
| 692 | +4x |
- #' @param denom (`string`)\cr choice of denominator for patient proportions. Can be:+ x_stats <- lapply(normal_terms, h_glm_simple_term_extract, fit_glm) |
||
| 24 | -+ | |||
| 693 | +4x |
- #' - `N_col`: total number of patients in this column across rows+ x_stats <- do.call(rbind, x_stats) |
||
| 25 | -+ | |||
| 694 | +4x |
- #' - `n`: number of patients with any occurrences+ q_norm <- stats::qnorm((1 + conf_level) / 2) |
||
| 26 | -+ | |||
| 695 | +4x |
- #'+ x_stats$odds_ratio <- lapply(x_stats$estimate, exp) |
||
| 27 | -+ | |||
| 696 | +4x |
- #' @return+ x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
||
| 28 | -+ | |||
| 697 | +4x |
- #' * `s_count_occurrences()` returns a list with:+ x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error) |
||
| 29 | -+ | |||
| 698 | +4x |
- #' * `count`: list of counts with one element per occurrence.+ normal_stats <- x_stats |
||
| 30 | -+ | |||
| 699 | +4x |
- #' * `count_fraction`: list of counts and fractions with one element per occurrence.+ normal_stats$is_reference_summary <- FALSE |
||
| 31 | +700 |
- #' * `fraction`: list of numerators and denominators with one element per occurrence.+ |
||
| 32 | +701 |
- #'+ # Now the interaction term itself. |
||
| 33 | -+ | |||
| 702 | +4x |
- #' @examples+ inter_term_stats <- h_glm_interaction_extract(inter_term, fit_glm) |
||
| 34 | -+ | |||
| 703 | +4x |
- #' df <- data.frame(+ inter_term_stats$odds_ratio <- NA |
||
| 35 | -+ | |||
| 704 | +4x |
- #' USUBJID = as.character(c(1, 1, 2, 4, 4, 4)),+ inter_term_stats$lcl <- NA |
||
| 36 | -+ | |||
| 705 | +4x |
- #' MHDECOD = c("MH1", "MH2", "MH1", "MH1", "MH1", "MH3")
+ inter_term_stats$ucl <- NA |
||
| 37 | -+ | |||
| 706 | +4x |
- #' )+ inter_term_stats$is_reference_summary <- FALSE |
||
| 38 | +707 |
- #'+ |
||
| 39 | -+ | |||
| 708 | +4x |
- #' N_per_col <- 4L+ is_intervar1_numeric <- attr(fit_glm$terms, "dataClasses")[inter_vars[1]] == "numeric" |
||
| 40 | +709 |
- #'+ |
||
| 41 | +710 |
- #' # Count unique occurrences per subject.+ # Interaction stuff. |
||
| 42 | -+ | |||
| 711 | +4x |
- #' s_count_occurrences(+ inter_stats_one <- h_glm_inter_term_extract( |
||
| 43 | -+ | |||
| 712 | +4x |
- #' df,+ inter_vars[1], |
||
| 44 | -+ | |||
| 713 | +4x |
- #' .N_col = N_per_col,+ inter_vars[2], |
||
| 45 | -+ | |||
| 714 | +4x |
- #' .df_row = df,+ fit_glm, |
||
| 46 | -+ | |||
| 715 | +4x |
- #' .var = "MHDECOD",+ conf_level = conf_level, |
||
| 47 | -+ | |||
| 716 | +4x |
- #' id = "USUBJID"+ at = `if`(is_intervar1_numeric, NULL, at) |
||
| 48 | +717 |
- #' )+ ) |
||
| 49 | -+ | |||
| 718 | +4x |
- #'+ inter_stats_two <- h_glm_inter_term_extract( |
||
| 50 | -+ | |||
| 719 | +4x |
- #' @export+ inter_vars[2], |
||
| 51 | -+ | |||
| 720 | +4x |
- s_count_occurrences <- function(df,+ inter_vars[1], |
||
| 52 | -+ | |||
| 721 | +4x |
- denom = c("N_col", "n"),
+ fit_glm, |
||
| 53 | -+ | |||
| 722 | +4x |
- .N_col, # nolint+ conf_level = conf_level, |
||
| 54 | -+ | |||
| 723 | +4x |
- .df_row,+ at = `if`(is_intervar1_numeric, at, NULL) |
||
| 55 | +724 |
- drop = TRUE,+ ) |
||
| 56 | +725 |
- .var = "MHDECOD",+ |
||
| 57 | +726 |
- id = "USUBJID") {
+ # Now just combine everything in one data frame. |
||
| 58 | -7x | +727 | +4x |
- checkmate::assert_flag(drop)+ col_names <- c( |
| 59 | -7x | +728 | +4x |
- assert_df_with_variables(df, list(range = .var, id = id))+ "variable", |
| 60 | -7x | +729 | +4x |
- checkmate::assert_count(.N_col)+ "variable_label", |
| 61 | -7x | +730 | +4x |
- checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
+ "term", |
| 62 | -7x | +731 | +4x |
- checkmate::assert_multi_class(df[[id]], classes = c("factor", "character"))
+ "term_label", |
| 63 | -7x | -
- denom <- match.arg(denom)- |
- ||
| 64 | -+ | 732 | +4x |
-
+ "interaction", |
| 65 | -7x | +733 | +4x |
- occurrences <- if (drop) {
+ "interaction_label", |
| 66 | -+ | |||
| 734 | +4x |
- # Note that we don't try to preserve original level order here since a) that would required+ "reference", |
||
| 67 | -+ | |||
| 735 | +4x |
- # more time to look up in large original levels and b) that would fail for character input variable.+ "reference_label", |
||
| 68 | -6x | +736 | +4x |
- occurrence_levels <- sort(unique(.df_row[[.var]]))+ "estimate", |
| 69 | -6x | +737 | +4x |
- if (length(occurrence_levels) == 0) {
+ "std_error", |
| 70 | -1x | +738 | +4x |
- stop(+ "df", |
| 71 | -1x | +739 | +4x |
- "no empty `.df_row` input allowed when `drop = TRUE`,",+ "pvalue", |
| 72 | -1x | +740 | +4x |
- " please use `split_fun = drop_split_levels` in the `rtables` `split_rows_by` calls"+ "odds_ratio", |
| 73 | -+ | |||
| 741 | +4x |
- )+ "lcl", |
||
| 74 | -+ | |||
| 742 | +4x |
- }+ "ucl", |
||
| 75 | -5x | +743 | +4x |
- factor(df[[.var]], levels = occurrence_levels)+ "is_variable_summary", |
| 76 | -+ | |||
| 744 | +4x |
- } else {
+ "is_term_summary", |
||
| 77 | -1x | +745 | +4x |
- df[[.var]]+ "is_reference_summary" |
| 78 | +746 |
- }+ ) |
||
| 79 | -6x | +747 | +4x |
- ids <- factor(df[[id]])+ df <- rbind( |
| 80 | -6x | +748 | +4x |
- dn <- switch(denom,+ inter_stats_one[, col_names], |
| 81 | -6x | +749 | +4x |
- n = nlevels(ids),+ inter_stats_two[, col_names], |
| 82 | -6x | +750 | +4x |
- N_col = .N_col+ inter_term_stats[, col_names] |
| 83 | +751 |
) |
||
| 84 | -6x | +752 | +4x |
- has_occurrence_per_id <- table(occurrences, ids) > 0+ if (length(normal_terms) > 0) {
|
| 85 | -6x | +753 | +4x |
- n_ids_per_occurrence <- as.list(rowSums(has_occurrence_per_id))+ df <- rbind( |
| 86 | -6x | +754 | +4x |
- list(+ normal_stats[, col_names], |
| 87 | -6x | +755 | +4x |
- count = n_ids_per_occurrence,+ df |
| 88 | -6x | +|||
| 756 | +
- count_fraction = lapply(+ ) |
|||
| 89 | -6x | +|||
| 757 | +
- n_ids_per_occurrence,+ } |
|||
| 90 | -6x | +758 | +4x |
- function(i, denom) {
+ df$ci <- combine_vectors(df$lcl, df$ucl) |
| 91 | -33x | +759 | +4x |
- if (i == 0 && denom == 0) {
+ df |
| 92 | -! | +|||
| 760 | +
- c(0, 0)+ } |
| 93 | +1 |
- } else {
+ #' Univariate Formula Special Term |
||
| 94 | -33x | +|||
| 2 | +
- c(i, i / denom)+ #' |
|||
| 95 | +3 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 96 | +4 |
- },+ #' |
||
| 97 | -6x | +|||
| 5 | +
- denom = dn+ #' The special term `univariate` indicate that the model should be fitted individually for |
|||
| 98 | +6 |
- ),+ #' every variable included in univariate. |
||
| 99 | -6x | +|||
| 7 | +
- fraction = lapply(+ #' |
|||
| 100 | -6x | +|||
| 8 | +
- n_ids_per_occurrence,+ #' @param x A vector of variable name separated by commas. |
|||
| 101 | -6x | +|||
| 9 | +
- function(i, denom) c("num" = i, "denom" = denom),
+ #' |
|||
| 102 | -6x | +|||
| 10 | +
- denom = dn+ #' @return When used within a model formula, produces univariate models for each variable provided. |
|||
| 103 | +11 |
- )+ #' |
||
| 104 | +12 |
- )+ #' @details |
||
| 105 | +13 |
- }+ #' If provided alongside with pairwise specification, the model |
||
| 106 | +14 |
-
+ #' `y ~ ARM + univariate(SEX, AGE, RACE)` lead to the study and comparison of the models |
||
| 107 | +15 |
- #' @describeIn count_occurrences Formatted analysis function which is used as `afun`+ #' + `y ~ ARM` |
||
| 108 | +16 |
- #' in `count_occurrences()`.+ #' + `y ~ ARM + SEX` |
||
| 109 | +17 |
- #'+ #' + `y ~ ARM + AGE` |
||
| 110 | +18 |
- #' @return+ #' + `y ~ ARM + RACE` |
||
| 111 | +19 |
- #' * `a_count_occurrences()` returns the corresponding list with formatted [rtables::CellValue()].+ #' |
||
| 112 | +20 |
- #'+ #' @export |
||
| 113 | +21 |
- #' @examples+ univariate <- function(x) {
+ |
+ ||
| 22 | +1x | +
+ structure(x, varname = deparse(substitute(x))) |
||
| 114 | +23 |
- #' # We need to ungroup `count_fraction` first so that the `rtables` formatting+ } |
||
| 115 | +24 |
- #' # function `format_count_fraction()` can be applied correctly.+ |
||
| 116 | +25 |
- #' afun <- make_afun(a_count_occurrences, .ungroup_stats = c("count", "count_fraction", "fraction"))
+ # Get the right-hand-term of a formula |
||
| 117 | +26 |
- #' afun(+ rht <- function(x) {
+ |
+ ||
| 27 | +4x | +
+ checkmate::assert_formula(x)+ |
+ ||
| 28 | +4x | +
+ y <- as.character(rev(x)[[1]])+ |
+ ||
| 29 | +4x | +
+ return(y) |
||
| 118 | +30 |
- #' df,+ } |
||
| 119 | +31 |
- #' .N_col = N_per_col,+ |
||
| 120 | +32 |
- #' .df_row = df,+ #' Hazard Ratio Estimation in Interactions |
||
| 121 | +33 |
- #' .var = "MHDECOD",+ #' |
||
| 122 | +34 |
- #' id = "USUBJID"+ #' This function estimates the hazard ratios between arms when an interaction variable is given with |
||
| 123 | +35 |
- #' )+ #' specific values. |
||
| 124 | +36 |
#' |
||
| 125 | +37 |
- #' @export+ #' @param variable,given Names of two variable in interaction. We seek the estimation of the levels of `variable` |
||
| 126 | +38 |
- a_count_occurrences <- make_afun(+ #' given the levels of `given`. |
||
| 127 | +39 |
- s_count_occurrences,+ #' @param lvl_var,lvl_given corresponding levels has given by `levels`. |
||
| 128 | +40 |
- .formats = c(count = "xx", count_fraction = format_count_fraction_fixed_dp, fraction = format_fraction_fixed_dp)+ #' @param mmat A name numeric filled with 0 used as template to obtain the design matrix. |
||
| 129 | +41 |
- )+ #' @param coef Numeric of estimated coefficients. |
||
| 130 | +42 |
-
+ #' @param vcov Variance-covariance matrix of underlying model. |
||
| 131 | +43 |
- #' @describeIn count_occurrences Layout-creating function which can take statistics function arguments+ #' @param conf_level Single numeric for the confidence level of estimate intervals. |
||
| 132 | +44 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' |
||
| 133 | +45 |
- #'+ #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A) |
||
| 134 | +46 |
- #' @return+ #' and Sex (F, M; reference Female). The model is abbreviated: y ~ Arm + Sex + Arm x Sex. |
||
| 135 | +47 |
- #' * `count_occurrences()` returns a layout object suitable for passing to further layouting functions,+ #' The cox regression estimates the coefficients along with a variance-covariance matrix for: |
||
| 136 | +48 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 137 | +49 |
- #' the statistics from `s_count_occurrences()` to the table layout.+ #' - b1 (arm b), b2 (arm c) |
||
| 138 | +50 |
- #'+ #' - b3 (sex m) |
||
| 139 | +51 |
- #' @examples+ #' - b4 (arm b: sex m), b5 (arm c: sex m) |
||
| 140 | +52 |
- #' library(dplyr)+ #' |
||
| 141 | +53 |
- #' df <- data.frame(+ #' Given that I want an estimation of the Hazard Ratio for arm C/sex M, the estimation |
||
| 142 | +54 |
- #' USUBJID = as.character(c(+ #' will be given in reference to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5), |
||
| 143 | +55 |
- #' 1, 1, 2, 4, 4, 4,+ #' therefore the interaction coefficient is given by b2 + b5 while the standard error is obtained |
||
| 144 | +56 |
- #' 6, 6, 6, 7, 7, 8+ #' as $1.96 * sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$ for a confidence level of 0.95. |
||
| 145 | +57 |
- #' )),+ #' |
||
| 146 | +58 |
- #' MHDECOD = c(+ #' @return A list of matrix (one per level of variable) with rows corresponding to the combinations of |
||
| 147 | +59 |
- #' "MH1", "MH2", "MH1", "MH1", "MH1", "MH3",+ #' `variable` and `given`, with columns: |
||
| 148 | +60 |
- #' "MH2", "MH2", "MH3", "MH1", "MH2", "MH4"+ #' * `coef_hat`: Estimation of the coefficient. |
||
| 149 | +61 |
- #' ),+ #' * `coef_se`: Standard error of the estimation. |
||
| 150 | +62 |
- #' ARM = rep(c("A", "B"), each = 6)
+ #' * `hr`: Hazard ratio. |
||
| 151 | +63 |
- #' )+ #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio. |
||
| 152 | +64 |
- #' df_adsl <- df %>%+ #' |
||
| 153 | +65 |
- #' select(USUBJID, ARM) %>%+ #' @seealso [s_cox_multivariate()]. |
||
| 154 | +66 |
- #' unique()+ #' |
||
| 155 | +67 |
- #'+ #' @examples |
||
| 156 | +68 |
- #' # Create table layout+ #' library(dplyr) |
||
| 157 | +69 |
- #' lyt <- basic_table() %>%+ #' library(survival) |
||
| 158 | +70 |
- #' split_cols_by("ARM") %>%
+ #' |
||
| 159 | +71 |
- #' add_colcounts() %>%+ #' ADSL <- tern_ex_adsl %>% |
||
| 160 | +72 |
- #' count_occurrences(vars = "MHDECOD", .stats = c("count_fraction"))
+ #' filter(SEX %in% c("F", "M"))
|
||
| 161 | +73 |
#' |
||
| 162 | +74 |
- #' # Apply table layout to data and produce `rtable` object+ #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "PFS") |
||
| 163 | +75 |
- #' lyt %>%+ #' adtte$ARMCD <- droplevels(adtte$ARMCD) |
||
| 164 | +76 |
- #' build_table(df, alt_counts_df = df_adsl) %>%+ #' adtte$SEX <- droplevels(adtte$SEX) |
||
| 165 | +77 |
- #' prune_table()+ #' |
||
| 166 | +78 |
- #'+ #' mod <- coxph( |
||
| 167 | +79 |
- #' @export+ #' formula = Surv(time = AVAL, event = 1 - CNSR) ~ (SEX + ARMCD)^2, |
||
| 168 | +80 |
- count_occurrences <- function(lyt,+ #' data = adtte |
||
| 169 | +81 |
- vars,+ #' ) |
||
| 170 | +82 |
- var_labels = vars,+ #' |
||
| 171 | +83 |
- show_labels = "hidden",+ #' mmat <- stats::model.matrix(mod)[1, ] |
||
| 172 | +84 |
- riskdiff = FALSE,+ #' mmat[!mmat == 0] <- 0 |
||
| 173 | +85 |
- nested = TRUE,+ #' |
||
| 174 | +86 |
- ...,+ #' @keywords internal+ |
+ ||
| 87 | ++ |
+ estimate_coef <- function(variable, given, |
||
| 175 | +88 |
- table_names = vars,+ lvl_var, lvl_given, |
||
| 176 | +89 |
- .stats = "count_fraction",+ coef, |
||
| 177 | +90 |
- .formats = NULL,+ mmat, |
||
| 178 | +91 |
- .labels = NULL,+ vcov, |
||
| 179 | +92 |
- .indent_mods = NULL) {
+ conf_level = 0.95) {
|
||
| 180 | -7x | +93 | +8x |
- checkmate::assert_flag(riskdiff)+ var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level+ |
+
| 94 | +8x | +
+ giv_lvl <- paste0(given, lvl_given) |
||
| 181 | +95 | |||
| 182 | -7x | +96 | +8x |
- afun <- make_afun(+ design_mat <- expand.grid(variable = var_lvl, given = giv_lvl) |
| 183 | -7x | +97 | +8x |
- a_count_occurrences,+ design_mat <- design_mat[order(design_mat$variable, design_mat$given), ] |
| 184 | -7x | +98 | +8x |
- .stats = .stats,+ design_mat <- within( |
| 185 | -7x | +99 | +8x |
- .formats = .formats,+ data = design_mat, |
| 186 | -7x | +100 | +8x |
- .labels = .labels,+ expr = {
|
| 187 | -7x | +101 | +8x |
- .indent_mods = .indent_mods,+ inter <- paste0(variable, ":", given) |
| 188 | -7x | +102 | +8x |
- .ungroup_stats = .stats+ rev_inter <- paste0(given, ":", variable) |
| 189 | +103 | ++ |
+ }+ |
+ |
| 104 |
) |
|||
| 190 | +105 | |||
| 191 | -7x | +106 | +8x |
- extra_args <- if (isFALSE(riskdiff)) {
+ split_by_variable <- design_mat$variable |
| 192 | -6x | +107 | +8x |
- list(...)+ interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/") |
| 193 | +108 |
- } else {
+
|
||
| 194 | -1x | +109 | +8x |
- list(+ design_mat <- apply( |
| 195 | -1x | +110 | +8x |
- afun = list("s_count_occurrences" = afun),
+ X = design_mat, MARGIN = 1, FUN = function(x) {
|
| 196 | -1x | +111 | +27x |
- .stats = .stats,+ mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1 |
| 197 | -1x | +112 | +27x |
- .indent_mods = .indent_mods,+ return(mmat) |
| 198 | -1x | +|||
| 113 | +
- s_args = list(...)+ } |
|||
| 199 | +114 |
- )+ ) |
||
| 200 | -+ | |||
| 115 | +8x |
- }+ colnames(design_mat) <- interaction_names |
||
| 201 | +116 | |||
| 202 | -7x | +117 | +8x |
- analyze(+ betas <- as.matrix(coef) |
| 203 | -7x | +|||
| 118 | +
- lyt = lyt,+ |
|||
| 204 | -7x | +119 | +8x |
- vars = vars,+ coef_hat <- t(design_mat) %*% betas |
| 205 | -7x | +120 | +8x |
- afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ dimnames(coef_hat)[2] <- "coef" |
| 206 | -7x | +|||
| 121 | +
- var_labels = var_labels,+ |
|||
| 207 | -7x | +122 | +8x |
- show_labels = show_labels,+ coef_se <- apply(design_mat, 2, function(x) {
|
| 208 | -7x | +123 | +27x |
- table_names = table_names,+ vcov_el <- as.logical(x) |
| 209 | -7x | +124 | +27x |
- nested = nested,+ y <- vcov[vcov_el, vcov_el] |
| 210 | -7x | -
- extra_args = extra_args- |
- ||
| 211 | -- |
- )- |
- ||
| 212 | -+ | 125 | +27x |
- }+ y <- sum(y) |
| 1 | -+ | |||
| 126 | +27x |
- #' Convert List of Groups to Data Frame+ y <- sqrt(y) |
||
| 2 | -+ | |||
| 127 | +27x |
- #'+ return(y) |
||
| 3 | +128 |
- #' This converts a list of group levels into a data frame format which is expected by [rtables::add_combo_levels()].+ }) |
||
| 4 | +129 |
- #'+ |
||
| 5 | -+ | |||
| 130 | +8x |
- #' @param groups_list (named `list` of `character`)\cr specifies the new group levels via the names and the+ q_norm <- stats::qnorm((1 + conf_level) / 2) |
||
| 6 | -+ | |||
| 131 | +8x |
- #' levels that belong to it in the character vectors that are elements of the list.+ y <- cbind(coef_hat, `se(coef)` = coef_se) |
||
| 7 | +132 |
- #'+ |
||
| 8 | -+ | |||
| 133 | +8x |
- #' @return [tibble::tibble()] in the required format.+ y <- apply(y, 1, function(x) {
|
||
| 9 | -+ | |||
| 134 | +27x |
- #'+ x["hr"] <- exp(x["coef"]) |
||
| 10 | -+ | |||
| 135 | +27x |
- #' @examples+ x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"]) |
||
| 11 | -+ | |||
| 136 | +27x |
- #' grade_groups <- list(+ x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"]) |
||
| 12 | +137 |
- #' "Any Grade (%)" = c("1", "2", "3", "4", "5"),
+
|
||
| 13 | -+ | |||
| 138 | +27x |
- #' "Grade 3-4 (%)" = c("3", "4"),
+ return(x) |
||
| 14 | +139 |
- #' "Grade 5 (%)" = "5"+ }) |
||
| 15 | +140 |
- #' )+ |
||
| 16 | -+ | |||
| 141 | +8x |
- #' groups_list_to_df(grade_groups)+ y <- t(y) |
||
| 17 | -+ | |||
| 142 | +8x |
- #'+ y <- by(y, split_by_variable, identity) |
||
| 18 | -+ | |||
| 143 | +8x |
- #' @export+ y <- lapply(y, as.matrix) |
||
| 19 | +144 |
- groups_list_to_df <- function(groups_list) {
- |
- ||
| 20 | -5x | -
- checkmate::assert_list(groups_list, names = "named")+ |
||
| 21 | -5x | +145 | +8x |
- lapply(groups_list, checkmate::assert_character)+ attr(y, "details") <- paste0( |
| 22 | -5x | +146 | +8x |
- tibble::tibble(+ "Estimations of ", variable, |
| 23 | -5x | +147 | +8x |
- valname = make_names(names(groups_list)),+ " hazard ratio given the level of ", given, " compared to ", |
| 24 | -5x | +148 | +8x |
- label = names(groups_list),+ variable, " level ", lvl_var[1], "." |
| 25 | -5x | +|||
| 149 | +
- levelcombo = unname(groups_list),+ ) |
|||
| 26 | -5x | -
- exargs = replicate(length(groups_list), list())- |
- ||
| 27 | -+ | 150 | +8x |
- )+ return(y) |
| 28 | +151 |
} |
||
| 29 | +152 | |||
| 30 | +153 |
- #' Reference and Treatment Group Combination+ #' `tryCatch` around `car::Anova` |
||
| 31 | +154 |
#' |
||
| 32 | +155 |
- #' @description `r lifecycle::badge("stable")`
+ #' Captures warnings when executing [car::Anova]. |
||
| 33 | +156 |
#' |
||
| 34 | +157 |
- #' Facilitate the re-combination of groups divided as reference and treatment groups; it helps in arranging groups of+ #' @inheritParams car::Anova |
||
| 35 | +158 |
- #' columns in the `rtables` framework and teal modules.+ #' |
||
| 36 | +159 |
- #'+ #' @return A list with item `aov` for the result of the model and `error_text` for the captured warnings. |
||
| 37 | +160 |
- #' @param fct (`factor`)\cr the variable with levels which needs to be grouped.+ #' |
||
| 38 | +161 |
- #' @param ref (`string`)\cr the reference level(s).+ #' @examples |
||
| 39 | +162 |
- #' @param collapse (`string`)\cr a character string to separate `fct` and `ref`.+ #' # `car::Anova` on cox regression model including strata and expected |
||
| 40 | +163 |
- #'+ #' # a likelihood ratio test triggers a warning as only `Wald` method is |
||
| 41 | +164 |
- #' @return A `list` with first item `ref` (reference) and second item `trt` (treatment).+ #' # accepted. |
||
| 42 | +165 |
#' |
||
| 43 | +166 |
- #' @examples+ #' library(survival) |
||
| 44 | +167 |
- #' groups <- combine_groups(+ #' |
||
| 45 | +168 |
- #' fct = DM$ARM,+ #' mod <- coxph( |
||
| 46 | +169 |
- #' ref = c("B: Placebo")
+ #' formula = Surv(time = futime, event = fustat) ~ factor(rx) + strata(ecog.ps), |
||
| 47 | +170 |
- #' )+ #' data = ovarian |
||
| 48 | +171 |
- #'+ #' ) |
||
| 49 | +172 |
- #' basic_table() %>%+ #' |
||
| 50 | +173 |
- #' split_cols_by_groups("ARM", groups) %>%
+ #' @keywords internal |
||
| 51 | +174 |
- #' add_colcounts() %>%+ try_car_anova <- function(mod, |
||
| 52 | +175 |
- #' analyze_vars("AGE") %>%
+ test.statistic) { # nolint
|
||
| 53 | -+ | |||
| 176 | +2x |
- #' build_table(DM)+ y <- tryCatch( |
||
| 54 | -+ | |||
| 177 | +2x |
- #'+ withCallingHandlers( |
||
| 55 | -+ | |||
| 178 | +2x |
- #' @export+ expr = {
|
||
| 56 | -+ | |||
| 179 | +2x |
- combine_groups <- function(fct,+ warn_text <- c() |
||
| 57 | -+ | |||
| 180 | +2x |
- ref = NULL,+ list( |
||
| 58 | -+ | |||
| 181 | +2x |
- collapse = "/") {
+ aov = car::Anova( |
||
| 59 | -10x | +182 | +2x |
- checkmate::assert_string(collapse)+ mod, |
| 60 | -10x | +183 | +2x |
- checkmate::assert_character(ref, min.chars = 1, any.missing = FALSE, null.ok = TRUE)+ test.statistic = test.statistic, |
| 61 | -10x | +184 | +2x |
- checkmate::assert_multi_class(fct, classes = c("factor", "character"))
+ type = "III" |
| 62 | +185 |
-
+ ), |
||
| 63 | -10x | +186 | +2x |
- fct <- as_factor_keep_attributes(fct)+ warn_text = warn_text |
| 64 | +187 |
-
+ ) |
||
| 65 | -10x | +|||
| 188 | +
- group_levels <- levels(fct)+ }, |
|||
| 66 | -10x | +189 | +2x |
- if (is.null(ref)) {
+ warning = function(w) {
|
| 67 | -6x | +|||
| 190 | +
- ref <- group_levels[1]+ # If a warning is detected it is handled as "w".+ |
+ |||
| 191 | +! | +
+ warn_text <<- trimws(paste0("Warning in `try_car_anova`: ", w))
|
||
| 68 | +192 |
- } else {
+
|
||
| 69 | -4x | +|||
| 193 | +
- checkmate::assert_subset(ref, group_levels)+ # A warning is sometimes expected, then, we want to restart |
|||
| 70 | +194 |
- }+ # the execution while ignoring the warning.+ |
+ ||
| 195 | +! | +
+ invokeRestart("muffleWarning")
|
||
| 71 | +196 |
-
+ } |
||
| 72 | -10x | +|||
| 197 | +
- groups <- list(+ ), |
|||
| 73 | -10x | +198 | +2x |
- ref = group_levels[group_levels %in% ref],+ finally = {
|
| 74 | -10x | +|||
| 199 | +
- trt = group_levels[!group_levels %in% ref]+ } |
|||
| 75 | +200 |
) |
||
| 201 | ++ | + + | +||
| 76 | -10x | +202 | +2x |
- stats::setNames(groups, nm = lapply(groups, paste, collapse = collapse))+ return(y) |
| 77 | +203 |
} |
||
| 78 | +204 | |||
| 79 | +205 |
- #' Split Columns by Groups of Levels+ #' Fit the Cox Regression Model and `Anova` |
||
| 80 | +206 |
#' |
||
| 81 | +207 |
- #' @description `r lifecycle::badge("stable")`
+ #' The functions allows to derive from the [survival::coxph()] results the effect p.values using [car::Anova()]. |
||
| 82 | +208 |
- #'+ #' This last package introduces more flexibility to get the effect p.values. |
||
| 83 | +209 |
- #' @inheritParams argument_convention+ #' |
||
| 84 | +210 |
- #' @inheritParams groups_list_to_df+ #' @inheritParams t_coxreg |
||
| 85 | +211 |
- #' @param ... additional arguments to [rtables::split_cols_by()] in order. For instance, to+ #' |
||
| 86 | +212 |
- #' control formats (`format`), add a joint column for all groups (`incl_all`).+ #' @return A list with items `mod` (results of [survival::coxph()]), `msum` (result of `summary`) and |
||
| 87 | +213 |
- #'+ #' `aov` (result of [car::Anova()]). |
||
| 88 | +214 |
- #' @return A layout object suitable for passing to further layouting functions. Adding+ #' |
||
| 89 | +215 |
- #' this function to an `rtable` layout will add a column split including the given+ #' @noRd |
||
| 90 | +216 |
- #' groups to the table layout.+ fit_n_aov <- function(formula, |
||
| 91 | +217 |
- #'+ data = data, |
||
| 92 | +218 |
- #' @seealso [rtables::split_cols_by()]+ conf_level = conf_level, |
||
| 93 | +219 |
- #'+ pval_method = c("wald", "likelihood"),
|
||
| 94 | +220 |
- #' @examples+ ...) {
|
||
| 95 | -+ | |||
| 221 | +1x |
- #' # 1 - Basic use+ pval_method <- match.arg(pval_method) |
||
| 96 | +222 |
- #'+ |
||
| 97 | -+ | |||
| 223 | +1x |
- #' # Without group combination `split_cols_by_groups` is+ environment(formula) <- environment() |
||
| 98 | -+ | |||
| 224 | +1x |
- #' # equivalent to [rtables::split_cols_by()].+ suppressWarnings({
|
||
| 99 | +225 |
- #' basic_table() %>%+ # We expect some warnings due to coxph which fails strict programming. |
||
| 100 | -+ | |||
| 226 | +1x |
- #' split_cols_by_groups("ARM") %>%
+ mod <- survival::coxph(formula, data = data, ...) |
||
| 101 | -+ | |||
| 227 | +1x |
- #' add_colcounts() %>%+ msum <- summary(mod, conf.int = conf_level) |
||
| 102 | +228 |
- #' analyze("AGE") %>%
+ }) |
||
| 103 | +229 |
- #' build_table(DM)+ |
||
| 104 | -+ | |||
| 230 | +1x |
- #'+ aov <- try_car_anova( |
||
| 105 | -+ | |||
| 231 | +1x |
- #' # Add a reference column.+ mod, |
||
| 106 | -+ | |||
| 232 | +1x |
- #' basic_table() %>%+ test.statistic = switch(pval_method, |
||
| 107 | -+ | |||
| 233 | +1x |
- #' split_cols_by_groups("ARM", ref_group = "B: Placebo") %>%
+ "wald" = "Wald", |
||
| 108 | -+ | |||
| 234 | +1x |
- #' add_colcounts() %>%+ "likelihood" = "LR" |
||
| 109 | +235 |
- #' analyze(+ ) |
||
| 110 | +236 |
- #' "AGE",+ ) |
||
| 111 | +237 |
- #' afun = function(x, .ref_group, .in_ref_col) {
+
|
||
| 112 | -+ | |||
| 238 | +1x |
- #' if (.in_ref_col) {
+ warn_attr <- aov$warn_text |
||
| 113 | -+ | |||
| 239 | +! |
- #' in_rows("Diff Mean" = rcell(NULL))
+ if (!is.null(aov$warn_text)) message(warn_attr) |
||
| 114 | +240 |
- #' } else {
+
+ |
+ ||
| 241 | +1x | +
+ aov <- aov$aov+ |
+ ||
| 242 | +1x | +
+ y <- list(mod = mod, msum = msum, aov = aov)+ |
+ ||
| 243 | +1x | +
+ attr(y, "message") <- warn_attr |
||
| 115 | +244 |
- #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+
+ |
+ ||
| 245 | +1x | +
+ return(y) |
||
| 116 | +246 |
- #' }+ } |
||
| 117 | +247 |
- #' }+ |
||
| 118 | +248 |
- #' ) %>%+ # argument_checks |
||
| 119 | +249 |
- #' build_table(DM)+ check_formula <- function(formula) {
+ |
+ ||
| 250 | +1x | +
+ if (!(inherits(formula, "formula"))) {
+ |
+ ||
| 251 | +1x | +
+ stop("Check `formula`. A formula should resemble `Surv(time = AVAL, event = 1 - CNSR) ~ study_arm(ARMCD)`.")
|
||
| 120 | +252 |
- #'+ } |
||
| 121 | +253 |
- #' # 2 - Adding group specification+ + |
+ ||
| 254 | +! | +
+ invisible() |
||
| 122 | +255 |
- #'+ } |
||
| 123 | +256 |
- #' # Manual preparation of the groups.+ |
||
| 124 | +257 |
- #' groups <- list(+ check_covariate_formulas <- function(covariates) {
+ |
+ ||
| 258 | +1x | +
+ if (!all(vapply(X = covariates, FUN = inherits, what = "formula", FUN.VALUE = TRUE)) || is.null(covariates)) {
+ |
+ ||
| 259 | +1x | +
+ stop("Check `covariates`, it should be a list of right-hand-term formulas, e.g. list(Age = ~AGE).")
|
||
| 125 | +260 |
- #' "Arms A+B" = c("A: Drug X", "B: Placebo"),
+ } |
||
| 126 | +261 |
- #' "Arms A+C" = c("A: Drug X", "C: Combination")
+
+ |
+ ||
| 262 | +! | +
+ invisible() |
||
| 127 | +263 |
- #' )+ } |
||
| 128 | +264 |
- #'+ |
||
| 129 | +265 |
- #' # Use of split_cols_by_groups without reference column.+ name_covariate_names <- function(covariates) {
+ |
+ ||
| 266 | +1x | +
+ miss_names <- names(covariates) == ""+ |
+ ||
| 267 | +1x | +
+ no_names <- is.null(names(covariates))+ |
+ ||
| 268 | +! | +
+ if (any(miss_names)) names(covariates)[miss_names] <- vapply(covariates[miss_names], FUN = rht, FUN.VALUE = "name")+ |
+ ||
| 269 | +! | +
+ if (no_names) names(covariates) <- vapply(covariates, FUN = rht, FUN.VALUE = "name")+ |
+ ||
| 270 | +1x | +
+ return(covariates) |
||
| 130 | +271 |
- #' basic_table() %>%+ } |
||
| 131 | +272 |
- #' split_cols_by_groups("ARM", groups) %>%
+
|
||
| 132 | +273 |
- #' add_colcounts() %>%+ check_increments <- function(increments, covariates) {
|
||
| 133 | -+ | |||
| 274 | +1x |
- #' analyze("AGE") %>%
+ if (!is.null(increments)) {
|
||
| 134 | -+ | |||
| 275 | +1x |
- #' build_table(DM)+ covariates <- vapply(covariates, FUN = rht, FUN.VALUE = "name") |
||
| 135 | -+ | |||
| 276 | +1x |
- #'+ lapply( |
||
| 136 | -+ | |||
| 277 | +1x |
- #' # Including differentiated output in the reference column.+ X = names(increments), FUN = function(x) {
|
||
| 137 | -+ | |||
| 278 | +3x |
- #' basic_table() %>%+ if (!x %in% covariates) {
|
||
| 138 | -+ | |||
| 279 | +1x |
- #' split_cols_by_groups("ARM", groups_list = groups, ref_group = "Arms A+B") %>%
+ warning( |
||
| 139 | -+ | |||
| 280 | +1x |
- #' analyze(+ paste( |
||
| 140 | -+ | |||
| 281 | +1x |
- #' "AGE",+ "Check `increments`, the `increment` for ", x, |
||
| 141 | -+ | |||
| 282 | +1x |
- #' afun = function(x, .ref_group, .in_ref_col) {
+ "doesn't match any names in investigated covariate(s)." |
||
| 142 | +283 |
- #' if (.in_ref_col) {
+ ) |
||
| 143 | +284 |
- #' in_rows("Diff. of Averages" = rcell(NULL))
+ ) |
||
| 144 | +285 |
- #' } else {
+ } |
||
| 145 | +286 |
- #' in_rows("Diff. of Averages" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+ } |
||
| 146 | +287 |
- #' }+ ) |
||
| 147 | +288 |
- #' }+ } |
||
| 148 | +289 |
- #' ) %>%+ |
||
| 149 | -+ | |||
| 290 | +1x |
- #' build_table(DM)+ invisible() |
||
| 150 | +291 |
- #'+ } |
||
| 151 | +292 |
- #' # 3 - Binary list dividing factor levels into reference and treatment+ |
||
| 152 | +293 |
- #'+ #' Multivariate Cox Model - Summarized Results |
||
| 153 | +294 |
- #' # `combine_groups` defines reference and treatment.+ #' |
||
| 154 | +295 |
- #' groups <- combine_groups(+ #' Analyses based on multivariate Cox model are usually not performed for the Controlled Substance Reporting or |
||
| 155 | +296 |
- #' fct = DM$ARM,+ #' regulatory documents but serve exploratory purposes only (e.g., for publication). In practice, the model usually |
||
| 156 | +297 |
- #' ref = c("A: Drug X", "B: Placebo")
+ #' includes only the main effects (without interaction terms). It produces the hazard ratio estimates for each of the |
||
| 157 | +298 |
- #' )+ #' covariates included in the model. |
||
| 158 | +299 |
- #' groups+ #' The analysis follows the same principles (e.g., stratified vs. unstratified analysis and tie handling) as the |
||
| 159 | +300 |
- #'+ #' usual Cox model analysis. Since there is usually no pre-specified hypothesis testing for such analysis, |
||
| 160 | +301 |
- #' # Use group definition without reference column.+ #' the p.values need to be interpreted with caution. (**Statistical Analysis of Clinical Trials Data with R**, |
||
| 161 | +302 |
- #' basic_table() %>%+ #' `NEST's bookdown`) |
||
| 162 | +303 |
- #' split_cols_by_groups("ARM", groups_list = groups) %>%
+ #' |
||
| 163 | +304 |
- #' add_colcounts() %>%+ #' @param formula (`formula`)\cr A formula corresponding to the investigated [survival::Surv()] survival model |
||
| 164 | +305 |
- #' analyze("AGE") %>%
+ #' including covariates. |
||
| 165 | +306 |
- #' build_table(DM)+ #' @param data (`data.frame`)\cr A data frame which includes the variable in formula and covariates. |
||
| 166 | +307 |
- #'+ #' @param conf_level (`proportion`)\cr The confidence level for the hazard ratio interval estimations. Default is 0.95. |
||
| 167 | +308 |
- #' # Use group definition with reference column (first item of groups).+ #' @param pval_method (`character`)\cr The method used for the estimation of p-values, should be one of |
||
| 168 | +309 |
- #' basic_table() %>%+ #' `"wald"` (default) or `"likelihood"`. |
||
| 169 | +310 |
- #' split_cols_by_groups("ARM", groups, ref_group = names(groups)[1]) %>%
+ #' @param ... Optional parameters passed to [survival::coxph()]. Can include `ties`, a character string specifying the |
||
| 170 | +311 |
- #' add_colcounts() %>%+ #' method for tie handling, one of `exact` (default), `efron`, `breslow`. |
||
| 171 | +312 |
- #' analyze(+ #' |
||
| 172 | +313 |
- #' "AGE",+ #' @return A `list` with elements `mod`, `msum`, `aov`, and `coef_inter`. |
||
| 173 | +314 |
- #' afun = function(x, .ref_group, .in_ref_col) {
+ #' |
||
| 174 | +315 |
- #' if (.in_ref_col) {
+ #' @details The output is limited to single effect terms. Work in ongoing for estimation of interaction terms |
||
| 175 | +316 |
- #' in_rows("Diff Mean" = rcell(NULL))
+ #' but is out of scope as defined by the Global Data Standards Repository |
||
| 176 | +317 |
- #' } else {
+ #' (**`GDS_Standard_TLG_Specs_Tables_2.doc`**). |
||
| 177 | +318 |
- #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+ #' |
||
| 178 | +319 |
- #' }+ #' @seealso [estimate_coef()]. |
||
| 179 | +320 |
- #' }+ #' |
||
| 180 | +321 |
- #' ) %>%+ #' @examples |
||
| 181 | +322 |
- #' build_table(DM)+ #' library(dplyr) |
||
| 182 | +323 |
#' |
||
| 183 | +324 |
- #' @export+ #' adtte <- tern_ex_adtte |
||
| 184 | +325 |
- split_cols_by_groups <- function(lyt,+ #' adtte_f <- subset(adtte, PARAMCD == "OS") # _f: filtered |
||
| 185 | +326 |
- var,+ #' adtte_f <- filter( |
||
| 186 | +327 |
- groups_list = NULL,+ #' adtte_f, |
||
| 187 | +328 |
- ref_group = NULL,+ #' PARAMCD == "OS" & |
||
| 188 | +329 |
- ...) {
- |
- ||
| 189 | -6x | -
- if (is.null(groups_list)) {
- |
- ||
| 190 | -2x | -
- split_cols_by(- |
- ||
| 191 | -2x | -
- lyt = lyt,- |
- ||
| 192 | -2x | -
- var = var,- |
- ||
| 193 | -2x | -
- ref_group = ref_group,+ #' SEX %in% c("F", "M") &
|
||
| 194 | +330 |
- ...+ #' RACE %in% c("ASIAN", "BLACK OR AFRICAN AMERICAN", "WHITE")
|
||
| 195 | +331 |
- )+ #' ) |
||
| 196 | +332 |
- } 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]+ #' adtte_f$SEX <- droplevels(adtte_f$SEX) |
||
| 200 | +333 |
- }- |
- ||
| 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),+ #' adtte_f$RACE <- droplevels(adtte_f$RACE) |
||
| 205 | -4x | +|||
| 334 | +
- ref_group = ref_group,+ #' |
|||
| 206 | +335 |
- ...+ #' @keywords internal |
||
| 207 | +336 |
- )+ s_cox_multivariate <- function(formula, data, |
||
| 208 | +337 |
- }+ conf_level = 0.95, |
||
| 209 | +338 |
- }+ pval_method = c("wald", "likelihood"),
|
||
| 210 | +339 |
-
+ ...) {
|
||
| 211 | -+ | |||
| 340 | +1x |
- #' Combine Counts+ tf <- stats::terms(formula, specials = c("strata"))
|
||
| 212 | -+ | |||
| 341 | +1x |
- #'+ covariates <- rownames(attr(tf, "factors"))[-c(1, unlist(attr(tf, "specials")))] |
||
| 213 | -+ | |||
| 342 | +1x |
- #' Simplifies the estimation of column counts, especially when group combination is required.+ lapply( |
||
| 214 | -+ | |||
| 343 | +1x |
- #'+ X = covariates, |
||
| 215 | -+ | |||
| 344 | +1x |
- #' @inheritParams combine_groups+ FUN = function(x) {
|
||
| 216 | -+ | |||
| 345 | +3x |
- #' @inheritParams groups_list_to_df+ if (is.character(data[[x]])) {
|
||
| 217 | -+ | |||
| 346 | +1x |
- #'+ data[[x]] <<- as.factor(data[[x]]) |
||
| 218 | +347 |
- #' @return A `vector` of column counts.+ } |
||
| 219 | -+ | |||
| 348 | +3x |
- #'+ invisible() |
||
| 220 | +349 |
- #' @seealso [combine_groups()]+ } |
||
| 221 | +350 |
- #'+ ) |
||
| 222 | -+ | |||
| 351 | +1x |
- #' @examples+ pval_method <- match.arg(pval_method) |
||
| 223 | +352 |
- #' ref <- c("A: Drug X", "B: Placebo")
+
|
||
| 224 | +353 |
- #' groups <- combine_groups(fct = DM$ARM, ref = ref)+ # Results directly exported from environment(fit_n_aov) to environment(s_function_draft) |
||
| 225 | -+ | |||
| 354 | +1x |
- #'+ y <- fit_n_aov( |
||
| 226 | -+ | |||
| 355 | +1x |
- #' col_counts <- combine_counts(+ formula = formula, |
||
| 227 | -+ | |||
| 356 | +1x |
- #' fct = DM$ARM,+ data = data, |
||
| 228 | -+ | |||
| 357 | +1x |
- #' groups_list = groups+ conf_level = conf_level, |
||
| 229 | -+ | |||
| 358 | +1x |
- #' )+ pval_method = pval_method, |
||
| 230 | +359 |
- #'+ ... |
||
| 231 | +360 |
- #' basic_table() %>%+ ) |
||
| 232 | -+ | |||
| 361 | +1x |
- #' split_cols_by_groups("ARM", groups) %>%
+ mod <- y$mod |
||
| 233 | -+ | |||
| 362 | +1x |
- #' add_colcounts() %>%+ aov <- y$aov |
||
| 234 | -+ | |||
| 363 | +1x |
- #' analyze_vars("AGE") %>%
+ msum <- y$msum |
||
| 235 | -+ | |||
| 364 | +1x |
- #' build_table(DM, col_counts = col_counts)+ list2env(as.list(y), environment()) |
||
| 236 | +365 |
- #'+ |
||
| 237 | -+ | |||
| 366 | +1x |
- #' ref <- "A: Drug X"+ all_term_labs <- attr(mod$terms, "term.labels") |
||
| 238 | -+ | |||
| 367 | +1x |
- #' groups <- combine_groups(fct = DM$ARM, ref = ref)+ term_labs <- all_term_labs[which(attr(mod$terms, "order") == 1)] |
||
| 239 | -+ | |||
| 368 | +1x |
- #' col_counts <- combine_counts(+ names(term_labs) <- term_labs |
||
| 240 | +369 |
- #' fct = DM$ARM,+ |
||
| 241 | -+ | |||
| 370 | +1x |
- #' groups_list = groups+ coef_inter <- NULL |
||
| 242 | -+ | |||
| 371 | +1x |
- #' )+ if (any(attr(mod$terms, "order") > 1)) {
|
||
| 243 | -+ | |||
| 372 | +1x |
- #'+ for_inter <- all_term_labs[attr(mod$terms, "order") > 1] |
||
| 244 | -+ | |||
| 373 | +1x |
- #' basic_table() %>%+ names(for_inter) <- for_inter |
||
| 245 | -+ | |||
| 374 | +1x |
- #' split_cols_by_groups("ARM", groups) %>%
+ mmat <- stats::model.matrix(mod)[1, ] |
||
| 246 | -+ | |||
| 375 | +1x |
- #' add_colcounts() %>%+ mmat[!mmat == 0] <- 0 |
||
| 247 | -+ | |||
| 376 | +1x |
- #' analyze_vars("AGE") %>%
+ mcoef <- stats::coef(mod) |
||
| 248 | -+ | |||
| 377 | +1x |
- #' build_table(DM, col_counts = col_counts)+ mvcov <- stats::vcov(mod) |
||
| 249 | +378 |
- #'+ |
||
| 250 | -+ | |||
| 379 | +1x |
- #' @export+ estimate_coef_local <- function(variable, given) {
|
||
| 251 | -+ | |||
| 380 | +6x |
- combine_counts <- function(fct, groups_list = NULL) {
+ estimate_coef( |
||
| 252 | -4x | +381 | +6x |
- checkmate::assert_multi_class(fct, classes = c("factor", "character"))
+ variable, given, |
| 253 | -+ | |||
| 382 | +6x |
-
+ coef = mcoef, mmat = mmat, vcov = mvcov, conf_level = conf_level, |
||
| 254 | -4x | +383 | +6x |
- fct <- as_factor_keep_attributes(fct)+ lvl_var = levels(data[[variable]]), lvl_given = levels(data[[given]]) |
| 255 | +384 |
-
+ ) |
||
| 256 | -4x | +|||
| 385 | +
- if (is.null(groups_list)) {
+ } |
|||
| 257 | -1x | +|||
| 386 | +
- y <- table(fct)+ |
|||
| 258 | +387 | 1x |
- y <- stats::setNames(as.numeric(y), nm = dimnames(y)[[1]])+ coef_inter <- lapply( |
|
| 259 | -+ | |||
| 388 | +1x |
- } else {
+ for_inter, function(x) {
|
||
| 260 | +389 | 3x |
- y <- vapply(+ y <- attr(mod$terms, "factor")[, x] |
|
| 261 | +390 | 3x |
- X = groups_list,+ y <- names(y[y > 0]) |
|
| 262 | +391 | 3x |
- FUN = function(x) sum(table(fct)[x]),+ Map(estimate_coef_local, variable = y, given = rev(y)) |
|
| 263 | -3x | +|||
| 392 | +
- FUN.VALUE = 1+ } |
|||
| 264 | +393 |
) |
||
| 265 | +394 |
} |
||
| 395 | ++ | + + | +||
| 266 | -4x | +396 | +1x |
- y+ list(mod = mod, msum = msum, aov = aov, coef_inter = coef_inter) |
| 267 | +397 |
}@@ -97201,14 +97714,14 @@ tern coverage - 94.83% |
| 1 |
- #' Stack Multiple Grobs+ #' Helper Functions for Subgroup Treatment Effect Pattern (STEP) Calculations |
||
| 5 |
- #' Stack grobs as a new grob with 1 column and multiple rows layout.+ #' Helper functions that are used internally for the STEP calculations. |
||
| 7 |
- #' @param ... grobs.+ #' @inheritParams argument_convention |
||
| 8 |
- #' @param grobs list of grobs.+ #' |
||
| 9 |
- #' @param padding unit of length 1, space between each grob.+ #' @name h_step |
||
| 10 |
- #' @param vp a [viewport()] object (or `NULL`).+ #' @include control_step.R |
||
| 11 |
- #' @param name a character identifier for the grob.+ NULL |
||
| 12 |
- #' @param gp A [gpar()] object.+ |
||
| 13 |
- #'+ #' @describeIn h_step creates the windows for STEP, based on the control settings |
||
| 14 |
- #' @return A `grob`.+ #' provided. |
||
| 16 |
- #' @examples+ #' @param x (`numeric`)\cr biomarker value(s) to use (without `NA`). |
||
| 17 |
- #' library(grid)+ #' @param control (named `list`)\cr output from `control_step()`. |
||
| 19 |
- #' g1 <- circleGrob(gp = gpar(col = "blue"))+ #' @return |
||
| 20 |
- #' g2 <- circleGrob(gp = gpar(col = "red"))+ #' * `h_step_window()` returns a list containing the window-selection matrix `sel` |
||
| 21 |
- #' g3 <- textGrob("TEST TEXT")
+ #' and the interval information matrix `interval`. |
||
| 22 |
- #' grid.newpage()+ #' |
||
| 23 |
- #' grid.draw(stack_grobs(g1, g2, g3))+ #' @export |
||
| 24 |
- #'+ h_step_window <- function(x, |
||
| 25 |
- #' showViewport()+ control = control_step()) {
|
||
| 26 | -+ | 12x |
- #'+ checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) |
| 27 | -+ | 12x |
- #' grid.newpage()+ checkmate::assert_list(control, names = "named") |
| 28 |
- #' pushViewport(viewport(layout = grid.layout(1, 2)))+ |
||
| 29 | -+ | 12x |
- #' vp1 <- viewport(layout.pos.row = 1, layout.pos.col = 2)+ sel <- matrix(FALSE, length(x), control$num_points) |
| 30 | -+ | 12x |
- #' grid.draw(stack_grobs(g1, g2, g3, vp = vp1, name = "test"))+ out <- matrix(0, control$num_points, 3) |
| 31 | -+ | 12x |
- #'+ colnames(out) <- paste("Interval", c("Center", "Lower", "Upper"))
|
| 32 | -+ | 12x |
- #' showViewport()+ if (control$use_percentile) {
|
| 33 |
- #' grid.ls(grobs = TRUE, viewports = TRUE, print = FALSE)+ # Create windows according to percentile cutoffs. |
||
| 34 | -+ | 9x |
- #'+ out <- cbind(out, out) |
| 35 | -+ | 9x |
- #' @export+ colnames(out)[1:3] <- paste("Percentile", c("Center", "Lower", "Upper"))
|
| 36 | -+ | 9x |
- stack_grobs <- function(...,+ xs <- seq(0, 1, length = control$num_points + 2)[-1] |
| 37 | -+ | 9x |
- grobs = list(...),+ for (i in seq_len(control$num_points)) {
|
| 38 | -+ | 185x |
- padding = grid::unit(2, "line"),+ out[i, 2:3] <- c( |
| 39 | -+ | 185x |
- vp = NULL,+ max(xs[i] - control$bandwidth, 0), |
| 40 | -+ | 185x |
- gp = NULL,+ min(xs[i] + control$bandwidth, 1) |
| 41 |
- name = NULL) {
+ ) |
||
| 42 | -4x | +185x |
- checkmate::assert_true(+ out[i, 5:6] <- stats::quantile(x, out[i, 2:3]) |
| 43 | -4x | +185x |
- all(vapply(grobs, grid::is.grob, logical(1)))+ sel[, i] <- x >= out[i, 5] & x <= out[i, 6] |
| 44 |
- )+ } |
||
| 45 |
-
+ # Center is the middle point of the percentile window. |
||
| 46 | -4x | +9x |
- if (length(grobs) == 1) {
+ out[, 1] <- xs[-control$num_points - 1] |
| 47 | -1x | +9x |
- return(grobs[[1]])+ out[, 4] <- stats::quantile(x, out[, 1]) |
| 48 |
- }+ } else {
|
||
| 49 |
-
+ # Create windows according to cutoffs. |
||
| 50 | 3x |
- n_layout <- 2 * length(grobs) - 1+ m <- c(min(x), max(x)) |
|
| 51 | 3x |
- hts <- lapply(+ xs <- seq(m[1], m[2], length = control$num_points + 2)[-1] |
|
| 52 | 3x |
- seq(1, n_layout),+ for (i in seq_len(control$num_points)) {
|
|
| 53 | -3x | +11x |
- function(i) {
+ out[i, 2:3] <- c( |
| 54 | -39x | +11x |
- if (i %% 2 != 0) {
+ max(xs[i] - control$bandwidth, m[1]), |
| 55 | -21x | +11x |
- grid::unit(1, "null")+ min(xs[i] + control$bandwidth, m[2]) |
| 56 |
- } else {
+ ) |
||
| 57 | -18x | +11x |
- padding+ sel[, i] <- x >= out[i, 2] & x <= out[i, 3] |
| 58 |
- }+ } |
||
| 59 |
- }+ # Center is the same as the point for predicting. |
||
| 60 | -+ | 3x |
- )+ out[, 1] <- xs[-control$num_points - 1] |
| 61 | -3x | +
- hts <- do.call(grid::unit.c, hts)+ } |
|
| 62 | -+ | 12x |
-
+ list(sel = sel, interval = out) |
| 63 | -3x | +
- main_vp <- grid::viewport(+ } |
|
| 64 | -3x | +
- layout = grid::grid.layout(nrow = n_layout, ncol = 1, heights = hts)+ |
|
| 65 |
- )+ #' @describeIn h_step calculates the estimated treatment effect estimate |
||
| 66 |
-
+ #' on the linear predictor scale and corresponding standard error from a STEP `model` fitted |
||
| 67 | -3x | +
- nested_grobs <- Map(function(g, i) {
+ #' on `data` given `variables` specification, for a single biomarker value `x`. |
|
| 68 | -21x | +
- grid::gTree(+ #' This works for both `coxph` and `glm` models, i.e. for calculating log hazard ratio or log odds |
|
| 69 | -21x | +
- children = grid::gList(g),+ #' ratio estimates. |
|
| 70 | -21x | +
- vp = grid::viewport(layout.pos.row = i, layout.pos.col = 1)+ #' |
|
| 71 |
- )+ #' @param model the regression model object. |
||
| 72 | -3x | +
- }, grobs, seq_along(grobs) * 2 - 1)+ #' |
|
| 73 |
-
+ #' @return |
||
| 74 | -3x | +
- grobs_mainvp <- grid::gTree(+ #' * `h_step_trt_effect()` returns a vector with elements `est` and `se`. |
|
| 75 | -3x | +
- children = do.call(grid::gList, nested_grobs),+ #' |
|
| 76 | -3x | +
- vp = main_vp+ #' @export |
|
| 77 |
- )+ h_step_trt_effect <- function(data, |
||
| 78 |
-
+ model, |
||
| 79 | -3x | +
- grid::gTree(+ variables, |
|
| 80 | -3x | +
- children = grid::gList(grobs_mainvp),+ x) {
|
|
| 81 | -3x | +208x |
- vp = vp,+ checkmate::assert_multi_class(model, c("coxph", "glm"))
|
| 82 | -3x | +208x |
- gp = gp,+ checkmate::assert_number(x) |
| 83 | -3x | +208x |
- name = name+ assert_df_with_variables(data, variables) |
| 84 | -+ | 208x |
- )+ checkmate::assert_factor(data[[variables$arm]], n.levels = 2) |
| 85 |
- }+ |
||
| 86 | -+ | 208x |
-
+ newdata <- data[c(1, 1), ] |
| 87 | -+ | 208x |
- #' Arrange Multiple Grobs+ newdata[, variables$biomarker] <- x |
| 88 | -+ | 208x |
- #'+ newdata[, variables$arm] <- levels(data[[variables$arm]]) |
| 89 | -+ | 208x |
- #' Arrange grobs as a new grob with \verb{n*m (rows*cols)} layout.
+ model_terms <- stats::delete.response(stats::terms(model)) |
| 90 | -+ | 208x |
- #'+ model_frame <- stats::model.frame(model_terms, data = newdata, xlev = model$xlevels) |
| 91 | -+ | 208x |
- #' @inheritParams stack_grobs+ mat <- stats::model.matrix(model_terms, data = model_frame, contrasts.arg = model$contrasts) |
| 92 | -+ | 208x |
- #' @param ncol number of columns in layout.+ coefs <- stats::coef(model) |
| 93 |
- #' @param nrow number of rows in layout.+ # Note: It is important to use the coef subset from matrix, otherwise intercept and |
||
| 94 |
- #' @param padding_ht unit of length 1, vertical space between each grob.+ # strata are included for coxph() models. |
||
| 95 | -+ | 208x |
- #' @param padding_wt unit of length 1, horizontal space between each grob.+ mat <- mat[, names(coefs)] |
| 96 | -+ | 208x |
- #'+ mat_diff <- diff(mat) |
| 97 | -+ | 208x |
- #' @return A `grob`.+ est <- mat_diff %*% coefs |
| 98 | -+ | 208x |
- #' @examples+ var <- mat_diff %*% stats::vcov(model) %*% t(mat_diff) |
| 99 | -+ | 208x |
- #' library(grid)+ se <- sqrt(var) |
| 100 | -+ | 208x |
- #'+ c( |
| 101 | -+ | 208x |
- #' \donttest{
+ est = est, |
| 102 | -+ | 208x |
- #' num <- lapply(1:9, textGrob)+ se = se |
| 103 |
- #' grid::grid.newpage()+ ) |
||
| 104 |
- #' grid.draw(arrange_grobs(grobs = num, ncol = 2))+ } |
||
| 105 |
- #'+ |
||
| 106 |
- #' showViewport()+ #' @describeIn h_step builds the model formula used in survival STEP calculations. |
||
| 108 |
- #' g1 <- circleGrob(gp = gpar(col = "blue"))+ #' @return |
||
| 109 |
- #' g2 <- circleGrob(gp = gpar(col = "red"))+ #' * `h_step_survival_formula()` returns a model formula. |
||
| 110 |
- #' g3 <- textGrob("TEST TEXT")
+ #' |
||
| 111 |
- #' grid::grid.newpage()+ #' @export |
||
| 112 |
- #' grid.draw(arrange_grobs(g1, g2, g3, nrow = 2))+ h_step_survival_formula <- function(variables, |
||
| 113 |
- #'+ control = control_step()) {
|
||
| 114 | -+ | 10x |
- #' showViewport()+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
| 115 |
- #'+ |
||
| 116 | -+ | 10x |
- #' grid::grid.newpage()+ assert_list_of_variables(variables[c("arm", "biomarker", "event", "time")])
|
| 117 | -+ | 10x |
- #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 3))+ form <- paste0("Surv(", variables$time, ", ", variables$event, ") ~ ", variables$arm)
|
| 118 | -+ | 10x |
- #'+ if (control$degree > 0) {
|
| 119 | -+ | 5x |
- #' grid::grid.newpage()+ form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
|
| 120 |
- #' grid::pushViewport(grid::viewport(layout = grid::grid.layout(1, 2)))+ } |
||
| 121 | -+ | 10x |
- #' vp1 <- grid::viewport(layout.pos.row = 1, layout.pos.col = 2)+ if (!is.null(variables$covariates)) {
|
| 122 | -+ | 6x |
- #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 2, vp = vp1))+ form <- paste(form, "+", paste(variables$covariates, collapse = "+")) |
| 123 |
- #'+ } |
||
| 124 | -+ | 10x |
- #' showViewport()+ if (!is.null(variables$strata)) {
|
| 125 | -+ | 2x |
- #' }+ form <- paste0(form, " + strata(", paste0(variables$strata, collapse = ", "), ")")
|
| 126 |
- #' @export+ } |
||
| 127 | -+ | 10x |
- arrange_grobs <- function(...,+ stats::as.formula(form) |
| 128 |
- grobs = list(...),+ } |
||
| 129 |
- ncol = NULL, nrow = NULL,+ |
||
| 130 |
- padding_ht = grid::unit(2, "line"),+ #' @describeIn h_step estimates the model with `formula` built based on |
||
| 131 |
- padding_wt = grid::unit(2, "line"),+ #' `variables` in `data` for a given `subset` and `control` parameters for the |
||
| 132 |
- vp = NULL,+ #' Cox regression. |
||
| 133 |
- gp = NULL,+ #' |
||
| 134 |
- name = NULL) {
+ #' @param formula (`formula`)\cr the regression model formula. |
||
| 135 | -5x | +
- checkmate::assert_true(+ #' @param subset (`logical`)\cr subset vector. |
|
| 136 | -5x | +
- all(vapply(grobs, grid::is.grob, logical(1)))+ #' |
|
| 137 |
- )+ #' @return |
||
| 138 |
-
+ #' * `h_step_survival_est()` returns a matrix of number of observations `n`, |
||
| 139 | -5x | +
- if (length(grobs) == 1) {
+ #' `events`, log hazard ratio estimates `loghr`, standard error `se`, |
|
| 140 | -1x | +
- return(grobs[[1]])+ #' and Wald confidence interval bounds `ci_lower` and `ci_upper`. One row is |
|
| 141 |
- }+ #' included for each biomarker value in `x`. |
||
| 142 |
-
+ #' |
||
| 143 | -4x | +
- if (is.null(ncol) && is.null(nrow)) {
+ #' @export |
|
| 144 | -1x | +
- ncol <- 1+ h_step_survival_est <- function(formula, |
|
| 145 | -1x | +
- nrow <- ceiling(length(grobs) / ncol)+ data, |
|
| 146 | -3x | +
- } else if (!is.null(ncol) && is.null(nrow)) {
+ variables, |
|
| 147 | -1x | +
- nrow <- ceiling(length(grobs) / ncol)+ x, |
|
| 148 | -2x | +
- } else if (is.null(ncol) && !is.null(nrow)) {
+ subset = rep(TRUE, nrow(data)), |
|
| 149 | -! | +
- ncol <- ceiling(length(grobs) / nrow)+ control = control_coxph()) {
|
|
| 150 | -+ | 55x |
- }+ checkmate::assert_formula(formula) |
| 151 | -+ | 55x |
-
+ assert_df_with_variables(data, variables) |
| 152 | -4x | +55x |
- if (ncol * nrow < length(grobs)) {
+ checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE) |
| 153 | -1x | +55x |
- stop("specififed ncol and nrow are not enough for arranging the grobs ")
+ checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) |
| 154 | -+ | 55x |
- }+ checkmate::assert_list(control, names = "named") |
| 156 | -3x | +
- if (ncol == 1) {
+ # Note: `subset` in `coxph` needs to be an expression referring to `data` variables. |
|
| 157 | -2x | +55x |
- return(stack_grobs(grobs = grobs, padding = padding_ht, vp = vp, gp = gp, name = name))+ data$.subset <- subset |
| 158 | -+ | 55x |
- }+ coxph_warnings <- NULL |
| 159 | -+ | 55x |
-
+ tryCatch( |
| 160 | -1x | +55x |
- n_col <- 2 * ncol - 1+ withCallingHandlers( |
| 161 | -1x | +55x |
- n_row <- 2 * nrow - 1+ expr = {
|
| 162 | -1x | +55x |
- hts <- lapply(+ fit <- survival::coxph( |
| 163 | -1x | +55x |
- seq(1, n_row),+ formula = formula, |
| 164 | -1x | +55x |
- function(i) {
+ data = data, |
| 165 | -5x | +55x |
- if (i %% 2 != 0) {
+ subset = .subset, |
| 166 | -3x | +55x |
- grid::unit(1, "null")+ ties = control$ties |
| 167 |
- } else {
+ ) |
||
| 168 | -2x | +
- padding_ht+ }, |
|
| 169 | -+ | 55x |
- }+ warning = function(w) {
|
| 170 | -+ | 1x |
- }+ coxph_warnings <<- c(coxph_warnings, w) |
| 171 | -+ | 1x |
- )+ invokeRestart("muffleWarning")
|
| 172 | -1x | +
- hts <- do.call(grid::unit.c, hts)+ } |
|
| 173 |
-
+ ), |
||
| 174 | -1x | +55x |
- wts <- lapply(+ finally = {
|
| 175 | -1x | +
- seq(1, n_col),+ } |
|
| 176 | -1x | +
- function(i) {
+ ) |
|
| 177 | -5x | +55x |
- if (i %% 2 != 0) {
+ if (!is.null(coxph_warnings)) {
|
| 178 | -3x | +1x |
- grid::unit(1, "null")+ warning(paste( |
| 179 | -+ | 1x |
- } else {
+ "Fit warnings occurred, please consider using a simpler model, or", |
| 180 | -2x | +1x |
- padding_wt+ "larger `bandwidth`, less `num_points` in `control_step()` settings" |
| 181 |
- }+ )) |
||
| 182 |
- }+ } |
||
| 183 |
- )+ # Produce a matrix with one row per `x` and columns `est` and `se`. |
||
| 184 | -1x | +55x |
- wts <- do.call(grid::unit.c, wts)+ estimates <- t(vapply( |
| 185 | -+ | 55x |
-
+ X = x, |
| 186 | -1x | +55x |
- main_vp <- grid::viewport(+ FUN = h_step_trt_effect, |
| 187 | -1x | +55x |
- layout = grid::grid.layout(nrow = n_row, ncol = n_col, widths = wts, heights = hts)+ FUN.VALUE = c(1, 2), |
| 188 | -+ | 55x |
- )+ data = data, |
| 189 | -+ | 55x |
-
+ model = fit, |
| 190 | -1x | +55x |
- nested_grobs <- list()+ variables = variables |
| 191 | -1x | +
- k <- 0+ )) |
|
| 192 | -1x | +55x |
- for (i in seq(nrow) * 2 - 1) {
+ q_norm <- stats::qnorm((1 + control$conf_level) / 2) |
| 193 | -3x | +55x |
- for (j in seq(ncol) * 2 - 1) {
+ cbind( |
| 194 | -9x | +55x |
- k <- k + 1+ n = fit$n, |
| 195 | -9x | +55x |
- if (k <= length(grobs)) {
+ events = fit$nevent, |
| 196 | -9x | +55x |
- nested_grobs <- c(+ loghr = estimates[, "est"], |
| 197 | -9x | +55x |
- nested_grobs,+ se = estimates[, "se"], |
| 198 | -9x | +55x |
- list(grid::gTree(+ ci_lower = estimates[, "est"] - q_norm * estimates[, "se"], |
| 199 | -9x | -
- children = grid::gList(grobs[[k]]),- |
- |
| 200 | -9x | -
- vp = grid::viewport(layout.pos.row = i, layout.pos.col = j)- |
- |
| 201 | -- |
- ))- |
- |
| 202 | -- |
- )- |
- |
| 203 | -- |
- }- |
- |
| 204 | -- |
- }- |
- |
| 205 | -- |
- }- |
- |
| 206 | -1x | -
- grobs_mainvp <- grid::gTree(- |
- |
| 207 | -1x | -
- children = do.call(grid::gList, nested_grobs),- |
- |
| 208 | -1x | -
- vp = main_vp- |
- |
| 209 | -- |
- )- |
- |
| 210 | -- | - - | -|
| 211 | -1x | -
- grid::gTree(- |
- |
| 212 | -1x | -
- children = grid::gList(grobs_mainvp),- |
- |
| 213 | -1x | -
- vp = vp,- |
- |
| 214 | -1x | -
- gp = gp,- |
- |
| 215 | -1x | -
- name = name- |
- |
| 216 | -- |
- )- |
- |
| 217 | -- |
- }- |
- |
| 218 | -- | - - | -|
| 219 | -- |
- #' Draw `grob`- |
- |
| 220 | -- |
- #'- |
- |
| 221 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- |
| 222 | -- |
- #'- |
- |
| 223 | -- |
- #' Draw grob on device page.- |
- |
| 224 | -- |
- #'- |
- |
| 225 | -- |
- #' @param grob grid object- |
- |
| 226 | -- |
- #' @param newpage draw on a new page- |
- |
| 227 | -- |
- #' @param vp a [viewport()] object (or `NULL`).- |
- |
| 228 | -- |
- #'- |
- |
| 229 | -- |
- #' @return A `grob`.- |
- |
| 230 | -- |
- #'- |
- |
| 231 | -- |
- #' @examples- |
- |
| 232 | -- |
- #' library(dplyr)- |
- |
| 233 | -- |
- #' library(grid)- |
- |
| 234 | -- |
- #'- |
- |
| 235 | -- |
- #' \donttest{
- |
- |
| 236 | -- |
- #' rect <- rectGrob(width = grid::unit(0.5, "npc"), height = grid::unit(0.5, "npc"))- |
- |
| 237 | -- |
- #' rect %>% draw_grob(vp = grid::viewport(angle = 45))- |
- |
| 238 | -- |
- #'- |
- |
| 239 | -- |
- #' num <- lapply(1:10, textGrob)- |
- |
| 240 | -- |
- #' num %>%- |
- |
| 241 | -- |
- #' arrange_grobs(grobs = .) %>%- |
- |
| 242 | -- |
- #' draw_grob()- |
- |
| 243 | -- |
- #' showViewport()- |
- |
| 244 | -- |
- #' }- |
- |
| 245 | -- |
- #'- |
- |
| 246 | -- |
- #' @export- |
- |
| 247 | -- |
- draw_grob <- function(grob, newpage = TRUE, vp = NULL) {
- |
- |
| 248 | -3x | -
- if (newpage) {
- |
- |
| 249 | -3x | -
- grid::grid.newpage()- |
- |
| 250 | -- |
- }- |
- |
| 251 | -3x | -
- if (!is.null(vp)) {
- |
- |
| 252 | -1x | -
- grid::pushViewport(vp)- |
- |
| 253 | -- |
- }- |
- |
| 254 | -3x | -
- grid::grid.draw(grob)- |
- |
| 255 | -- |
- }- |
- |
| 256 | -- | - - | -|
| 257 | -- |
- tern_grob <- function(x) {
- |
- |
| 258 | -! | -
- class(x) <- unique(c("ternGrob", class(x)))
- |
- |
| 259 | -! | -
- x- |
- |
| 260 | -- |
- }- |
- |
| 261 | -- | - - | -|
| 262 | -- |
- print.ternGrob <- function(x, ...) {
- |
- |
| 263 | -! | -
- grid::grid.newpage()- |
- |
| 264 | -! | -
- grid::grid.draw(x)- |
- |
| 265 | -- |
- }- |
-
| 1 | -+ | 55x |
- #' Line plot with the optional table+ ci_upper = estimates[, "est"] + q_norm * estimates[, "se"] |
| 2 | +200 |
- #'+ ) |
|
| 3 | +201 |
- #' @description `r lifecycle::badge("stable")`
+ } |
|
| 4 | +202 |
- #'+ |
|
| 5 | +203 |
- #' Line plot with the optional table.+ #' @describeIn h_step builds the model formula used in response STEP calculations. |
|
| 6 | +204 |
#' |
|
| 7 | +205 |
- #' @param df (`data.frame`)\cr data set containing all analysis variables.+ #' @return |
|
| 8 | +206 |
- #' @param alt_counts_df (`data.frame` or `NULL`)\cr data set that will be used (only) to counts objects in strata.+ #' * `h_step_rsp_formula()` returns a model formula. |
|
| 9 | +207 |
- #' @param variables (named `character` vector) of variable names in `df` data set. Details are:+ #' |
|
| 10 | +208 |
- #' * `x` (`character`)\cr name of x-axis variable.+ #' @export |
|
| 11 | +209 |
- #' * `y` (`character`)\cr name of y-axis variable.+ h_step_rsp_formula <- function(variables, |
|
| 12 | +210 |
- #' * `strata` (`character`)\cr name of grouping variable, i.e. treatment arm. Can be `NA` to indicate lack of groups.+ control = c(control_step(), control_logistic())) {
|
|
| 13 | -+ | ||
| 211 | +14x |
- #' * `paramcd` (`character`)\cr name of the variable for parameter's code. Used for y-axis label and plot's subtitle.+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
|
| 14 | -+ | ||
| 212 | +14x |
- #' Can be `NA` if `paramcd` is not to be added to the y-axis label or subtitle.+ assert_list_of_variables(variables[c("arm", "biomarker", "response")])
|
|
| 15 | -+ | ||
| 213 | +14x |
- #' * `y_unit` (`character`)\cr name of variable with units of `y`. Used for y-axis label and plot's subtitle.+ response_definition <- sub( |
|
| 16 | -+ | ||
| 214 | +14x |
- #' Can be `NA` if y unit is not to be added to the y-axis label or subtitle.+ pattern = "response", |
|
| 17 | -+ | ||
| 215 | +14x |
- #' @param mid (`character` or `NULL`)\cr names of the statistics that will be plotted as midpoints.+ replacement = variables$response, |
|
| 18 | -+ | ||
| 216 | +14x |
- #' All the statistics indicated in `mid` variable must be present in the object returned by `sfun`,+ x = control$response_definition, |
|
| 19 | -+ | ||
| 217 | +14x |
- #' and be of a `double` or `numeric` type vector of length one.+ fixed = TRUE |
|
| 20 | +218 |
- #' @param interval (`character` or `NULL`)\cr names of the statistics that will be plotted as intervals.+ ) |
|
| 21 | -+ | ||
| 219 | +14x |
- #' All the statistics indicated in `interval` variable must be present in the object returned by `sfun`,+ form <- paste0(response_definition, " ~ ", variables$arm) |
|
| 22 | -+ | ||
| 220 | +14x |
- #' and be of a `double` or `numeric` type vector of length two.+ if (control$degree > 0) {
|
|
| 23 | -+ | ||
| 221 | +8x |
- #' @param whiskers (`character`)\cr names of the interval whiskers that will be plotted. Must match the `names`+ form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
|
|
| 24 | +222 |
- #' attribute of the `interval` element in the list returned by `sfun`. It is possible to specify one whisker only,+ } |
|
| 25 | -+ | ||
| 223 | +14x |
- #' lower or upper.+ if (!is.null(variables$covariates)) {
|
|
| 26 | -+ | ||
| 224 | +8x |
- #' @param table (`character` or `NULL`)\cr names of the statistics that will be displayed in the table below the plot.+ form <- paste(form, "+", paste(variables$covariates, collapse = "+")) |
|
| 27 | +225 |
- #' All the statistics indicated in `table` variable must be present in the object returned by `sfun`.+ } |
|
| 28 | -+ | ||
| 226 | +14x |
- #' @param sfun (`closure`)\cr the function to compute the values of required statistics. It must return a named `list`+ if (!is.null(variables$strata)) {
|
|
| 29 | -+ | ||
| 227 | +5x |
- #' with atomic vectors. The names of the `list` elements refer to the names of the statistics and are used by `mid`,+ strata_arg <- if (length(variables$strata) > 1) {
|
|
| 30 | -+ | ||
| 228 | +2x |
- #' `interval`, `table`. It must be able to accept as input a vector with data for which statistics are computed.+ paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
|
|
| 31 | +229 |
- #' @param ... optional arguments to `sfun`.+ } else {
|
|
| 32 | -+ | ||
| 230 | +3x |
- #' @param mid_type (`character`)\cr controls the type of the `mid` plot, it can be point (`p`), line (`l`),+ variables$strata |
|
| 33 | +231 |
- #' or point and line (`pl`).+ } |
|
| 34 | -+ | ||
| 232 | +5x |
- #' @param mid_point_size (`integer` or `double`)\cr controls the font size of the point for `mid` plot.+ form <- paste0(form, "+ strata(", strata_arg, ")")
|
|
| 35 | +233 |
- #' @param position (`character` or `call`)\cr geom element position adjustment, either as a string, or the result of+ } |
|
| 36 | -+ | ||
| 234 | +14x |
- #' a call to a position adjustment function.+ stats::as.formula(form) |
|
| 37 | +235 |
- #' @param legend_title (`character` string)\cr legend title.+ } |
|
| 38 | +236 |
- #' @param legend_position (`character`)\cr the position of the plot legend (`none`, `left`, `right`, `bottom`, `top`,+ |
|
| 39 | +237 |
- #' or two-element numeric vector).+ #' @describeIn h_step estimates the model with `formula` built based on |
|
| 40 | +238 |
- #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot.+ #' `variables` in `data` for a given `subset` and `control` parameters for the |
|
| 41 | +239 |
- #' @param y_lab (`character`)\cr y-axis label. If equal to `NULL`, then no label will be added.+ #' logistic regression. |
|
| 42 | +240 |
- #' @param y_lab_add_paramcd (`logical`)\cr should `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` be added to the+ #' |
|
| 43 | +241 |
- #' y-axis label `y_lab`?+ #' @param formula (`formula`)\cr the regression model formula. |
|
| 44 | +242 |
- #' @param y_lab_add_unit (`logical`)\cr should y unit, i.e. `unique(df[[variables["y_unit"]]])` be added to the y-axis+ #' @param subset (`logical`)\cr subset vector. |
|
| 45 | +243 |
- #' label `y_lab`?+ #' |
|
| 46 | +244 |
- #' @param title (`character`)\cr plot title.+ #' @return |
|
| 47 | +245 |
- #' @param subtitle (`character`)\cr plot subtitle.+ #' * `h_step_rsp_est()` returns a matrix of number of observations `n`, log odds |
|
| 48 | +246 |
- #' @param subtitle_add_paramcd (`logical`)\cr should `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` be added to+ #' ratio estimates `logor`, standard error `se`, and Wald confidence interval bounds |
|
| 49 | +247 |
- #' the plot's subtitle `subtitle`?+ #' `ci_lower` and `ci_upper`. One row is included for each biomarker value in `x`. |
|
| 50 | +248 |
- #' @param subtitle_add_unit (`logical`)\cr should y unit, i.e. `unique(df[[variables["y_unit"]]])` be added to the+ #' |
|
| 51 | +249 |
- #' plot's subtitle `subtitle`?+ #' @export |
|
| 52 | +250 |
- #' @param caption (`character`)\cr optional caption below the plot.+ h_step_rsp_est <- function(formula, |
|
| 53 | +251 |
- #' @param table_format (named `character` or `NULL`)\cr format patterns for descriptive statistics used in the+ data, |
|
| 54 | +252 |
- #' (optional) table appended to the plot. It is passed directly to the `h_format_row` function through the `format`+ variables, |
|
| 55 | +253 |
- #' parameter. Names of `table_format` must match the names of statistics returned by `sfun` function.+ x, |
|
| 56 | +254 |
- #' @param table_labels (named `character` or `NULL`)\cr labels for descriptive statistics used in the (optional) table+ subset = rep(TRUE, nrow(data)), |
|
| 57 | +255 |
- #' appended to the plot. Names of `table_labels` must match the names of statistics returned by `sfun` function.+ control = control_logistic()) {
|
|
| 58 | -+ | ||
| 256 | +58x |
- #' @param table_font_size (`integer` or `double`)\cr controls the font size of values in the table.+ checkmate::assert_formula(formula) |
|
| 59 | -+ | ||
| 257 | +58x |
- #' @param newpage (`logical`)\cr should plot be drawn on new page?+ assert_df_with_variables(data, variables) |
|
| 60 | -+ | ||
| 258 | +58x |
- #' @param col (`character`)\cr colors.+ checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE) |
|
| 61 | -+ | ||
| 259 | +58x |
- #'+ checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE) |
|
| 62 | -+ | ||
| 260 | +58x |
- #' @return A `ggplot` line plot (and statistics table if applicable).+ checkmate::assert_list(control, names = "named") |
|
| 63 | +261 |
- #'+ # Note: `subset` in `glm` needs to be an expression referring to `data` variables. |
|
| 64 | -+ | ||
| 262 | +58x |
- #' @examples+ data$.subset <- subset |
|
| 65 | -+ | ||
| 263 | +58x |
- #' library(nestcolor)+ fit_warnings <- NULL |
|
| 66 | -+ | ||
| 264 | +58x |
- #'+ tryCatch( |
|
| 67 | -+ | ||
| 265 | +58x |
- #' adsl <- tern_ex_adsl+ withCallingHandlers( |
|
| 68 | -+ | ||
| 266 | +58x |
- #' adlb <- tern_ex_adlb %>% dplyr::filter(ANL01FL == "Y", PARAMCD == "ALT", AVISIT != "SCREENING")+ expr = {
|
|
| 69 | -+ | ||
| 267 | +58x |
- #' adlb$AVISIT <- droplevels(adlb$AVISIT)+ fit <- if (is.null(variables$strata)) {
|
|
| 70 | -+ | ||
| 268 | +54x |
- #' adlb <- dplyr::mutate(adlb, AVISIT = forcats::fct_reorder(AVISIT, AVISITN, min))+ stats::glm( |
|
| 71 | -+ | ||
| 269 | +54x |
- #'+ formula = formula, |
|
| 72 | -+ | ||
| 270 | +54x |
- #' # Mean with CI+ data = data, |
|
| 73 | -+ | ||
| 271 | +54x |
- #' g_lineplot(adlb, adsl, subtitle = "Laboratory Test:")+ subset = .subset, |
|
| 74 | -+ | ||
| 272 | +54x |
- #'+ family = stats::binomial("logit")
|
|
| 75 | +273 |
- #' # Mean with CI, no stratification+ ) |
|
| 76 | +274 |
- #' g_lineplot(adlb, variables = control_lineplot_vars(strata = NA))+ } else {
|
|
| 77 | +275 |
- #'+ # clogit needs coxph and strata imported |
|
| 78 | -+ | ||
| 276 | +4x |
- #' # Mean, upper whisker of CI, no strata counts N+ survival::clogit( |
|
| 79 | -+ | ||
| 277 | +4x |
- #' g_lineplot(+ formula = formula, |
|
| 80 | -+ | ||
| 278 | +4x |
- #' adlb,+ data = data, |
|
| 81 | -+ | ||
| 279 | +4x |
- #' whiskers = "mean_ci_upr",+ subset = .subset |
|
| 82 | +280 |
- #' title = "Plot of Mean and Upper 95% Confidence Limit by Visit"+ ) |
|
| 83 | +281 |
- #' )+ } |
|
| 84 | +282 |
- #'+ }, |
|
| 85 | -+ | ||
| 283 | +58x |
- #' # Median with CI+ warning = function(w) {
|
|
| 86 | -+ | ||
| 284 | +19x |
- #' g_lineplot(+ fit_warnings <<- c(fit_warnings, w) |
|
| 87 | -+ | ||
| 285 | +19x |
- #' adlb,+ invokeRestart("muffleWarning")
|
|
| 88 | +286 |
- #' adsl,+ } |
|
| 89 | +287 |
- #' mid = "median",+ ), |
|
| 90 | -+ | ||
| 288 | +58x |
- #' interval = "median_ci",+ finally = {
|
|
| 91 | +289 |
- #' whiskers = c("median_ci_lwr", "median_ci_upr"),
+ } |
|
| 92 | +290 |
- #' title = "Plot of Median and 95% Confidence Limits by Visit"+ ) |
|
| 93 | -+ | ||
| 291 | +58x |
- #' )+ if (!is.null(fit_warnings)) {
|
|
| 94 | -+ | ||
| 292 | +13x |
- #'+ warning(paste( |
|
| 95 | -+ | ||
| 293 | +13x |
- #' # Mean, +/- SD+ "Fit warnings occurred, please consider using a simpler model, or", |
|
| 96 | -+ | ||
| 294 | +13x |
- #' g_lineplot(adlb, adsl,+ "larger `bandwidth`, less `num_points` in `control_step()` settings" |
|
| 97 | +295 |
- #' interval = "mean_sdi",+ )) |
|
| 98 | +296 |
- #' whiskers = c("mean_sdi_lwr", "mean_sdi_upr"),
+ } |
|
| 99 | +297 |
- #' title = "Plot of Median +/- SD by Visit"+ # Produce a matrix with one row per `x` and columns `est` and `se`. |
|
| 100 | -+ | ||
| 298 | +58x |
- #' )+ estimates <- t(vapply( |
|
| 101 | -+ | ||
| 299 | +58x |
- #'+ X = x, |
|
| 102 | -+ | ||
| 300 | +58x |
- #' # Mean with CI plot with stats table+ FUN = h_step_trt_effect, |
|
| 103 | -+ | ||
| 301 | +58x |
- #' g_lineplot(adlb, adsl, table = c("n", "mean", "mean_ci"))
+ FUN.VALUE = c(1, 2), |
|
| 104 | -+ | ||
| 302 | +58x |
- #'+ data = data, |
|
| 105 | -+ | ||
| 303 | +58x |
- #' # Mean with CI, table and customized confidence level+ model = fit, |
|
| 106 | -+ | ||
| 304 | +58x |
- #' g_lineplot(+ variables = variables |
|
| 107 | +305 |
- #' adlb,+ )) |
|
| 108 | -+ | ||
| 306 | +58x |
- #' adsl,+ q_norm <- stats::qnorm((1 + control$conf_level) / 2) |
|
| 109 | -+ | ||
| 307 | +58x |
- #' table = c("n", "mean", "mean_ci"),
+ cbind( |
|
| 110 | -+ | ||
| 308 | +58x |
- #' control = control_analyze_vars(conf_level = 0.80),+ n = length(fit$y), |
|
| 111 | -+ | ||
| 309 | +58x |
- #' title = "Plot of Mean and 80% Confidence Limits by Visit"+ logor = estimates[, "est"], |
|
| 112 | -+ | ||
| 310 | +58x |
- #' )+ se = estimates[, "se"], |
|
| 113 | -+ | ||
| 311 | +58x |
- #'+ ci_lower = estimates[, "est"] - q_norm * estimates[, "se"], |
|
| 114 | -+ | ||
| 312 | +58x |
- #' # Mean with CI, table, filtered data+ ci_upper = estimates[, "est"] + q_norm * estimates[, "se"] |
|
| 115 | +313 |
- #' adlb_f <- dplyr::filter(adlb, ARMCD != "ARM A" | AVISIT == "BASELINE")+ ) |
|
| 116 | +314 |
- #' g_lineplot(adlb_f, table = c("n", "mean"))
+ } |
| 117 | +1 |
- #'+ #' Horizontal Waterfall Plot |
||
| 118 | +2 |
- #' @export+ #' |
||
| 119 | +3 |
- g_lineplot <- function(df,+ #' This basic waterfall plot visualizes a quantity `height` ordered by value with some markup. |
||
| 120 | +4 |
- alt_counts_df = NULL,+ #' |
||
| 121 | +5 |
- variables = control_lineplot_vars(),+ #' @description `r lifecycle::badge("stable")`
|
||
| 122 | +6 |
- mid = "mean",+ #' |
||
| 123 | +7 |
- interval = "mean_ci",+ #' @param height (`numeric``)\cr vector containing values to be plotted as the waterfall bars. |
||
| 124 | +8 |
- whiskers = c("mean_ci_lwr", "mean_ci_upr"),
+ #' @param id (`character`)\cr vector containing IDs to use as the x-axis label for the waterfall bars. |
||
| 125 | +9 |
- table = NULL,+ #' @param col (`character`)\cr colors. |
||
| 126 | +10 |
- sfun = tern::s_summary,+ #' @param col_var (`factor`, `character` or `NULL`)\cr categorical variable for bar coloring. `NULL` by default. |
||
| 127 | +11 |
- ...,+ #' @param xlab (`character`)\cr x label. Default is `"ID"`. |
||
| 128 | +12 |
- mid_type = "pl",+ #' @param ylab (`character`)\cr y label. Default is `"Value"`. |
||
| 129 | +13 |
- mid_point_size = 2,+ #' @param title (`character`)\cr text to be displayed as plot title. |
||
| 130 | +14 |
- position = ggplot2::position_dodge(width = 0.4),+ #' @param col_legend_title (`character`)\cr text to be displayed as legend title. |
||
| 131 | +15 |
- legend_title = NULL,+ #' |
||
| 132 | +16 |
- legend_position = "bottom",+ #' @return A `ggplot` waterfall plot. |
||
| 133 | +17 |
- ggtheme = nestcolor::theme_nest(),+ #' |
||
| 134 | +18 |
- y_lab = NULL,+ #' @examples |
||
| 135 | +19 |
- y_lab_add_paramcd = TRUE,+ #' library(dplyr) |
||
| 136 | +20 |
- y_lab_add_unit = TRUE,+ #' library(nestcolor) |
||
| 137 | +21 |
- title = "Plot of Mean and 95% Confidence Limits by Visit",+ #' |
||
| 138 | +22 |
- subtitle = "",+ #' g_waterfall(height = c(3, 5, -1), id = letters[1:3]) |
||
| 139 | +23 |
- subtitle_add_paramcd = TRUE,+ #' |
||
| 140 | +24 |
- subtitle_add_unit = TRUE,+ #' g_waterfall( |
||
| 141 | +25 |
- caption = NULL,+ #' height = c(3, 5, -1), |
||
| 142 | +26 |
- table_format = summary_formats(),+ #' id = letters[1:3], |
||
| 143 | +27 |
- table_labels = summary_labels(),+ #' col_var = letters[1:3] |
||
| 144 | +28 |
- table_font_size = 3,+ #' ) |
||
| 145 | +29 |
- newpage = TRUE,+ #' |
||
| 146 | +30 |
- col = NULL) {
- |
- ||
| 147 | -2x | -
- checkmate::assert_character(variables, any.missing = TRUE)- |
- ||
| 148 | -2x | -
- checkmate::assert_character(mid, null.ok = TRUE)- |
- ||
| 149 | -2x | -
- checkmate::assert_character(interval, null.ok = TRUE)- |
- ||
| 150 | -2x | -
- checkmate::assert_character(col, null.ok = TRUE)+ #' adsl_f <- tern_ex_adsl %>% |
||
| 151 | +31 | - - | -||
| 152 | -2x | -
- checkmate::assert_string(title, null.ok = TRUE)- |
- ||
| 153 | -2x | -
- checkmate::assert_string(subtitle, null.ok = TRUE)+ #' select(USUBJID, STUDYID, ARM, ARMCD, SEX) |
||
| 154 | +32 | - - | -||
| 155 | -2x | -
- if (is.character(interval)) {
- |
- ||
| 156 | -2x | -
- checkmate::assert_vector(whiskers, min.len = 0, max.len = 2)+ #' |
||
| 157 | +33 |
- }+ #' adrs_f <- tern_ex_adrs %>% |
||
| 158 | +34 | - - | -||
| 159 | -2x | -
- if (length(whiskers) == 1) {
- |
- ||
| 160 | -! | -
- checkmate::assert_character(mid)+ #' filter(PARAMCD == "OVRINV") %>% |
||
| 161 | +35 |
- }+ #' mutate(pchg = rnorm(n(), 10, 50)) |
||
| 162 | +36 | - - | -||
| 163 | -2x | -
- if (is.character(mid)) {
- |
- ||
| 164 | -2x | -
- checkmate::assert_scalar(mid_type)+ #' |
||
| 165 | -2x | +|||
| 37 | +
- checkmate::assert_subset(mid_type, c("pl", "p", "l"))
+ #' adrs_f <- head(adrs_f, 30) |
|||
| 166 | +38 |
- }+ #' adrs_f <- adrs_f[!duplicated(adrs_f$USUBJID), ] |
||
| 167 | +39 |
-
+ #' head(adrs_f) |
||
| 168 | -2x | +|||
| 40 | +
- x <- variables[["x"]]+ #' |
|||
| 169 | -2x | +|||
| 41 | +
- y <- variables[["y"]]+ #' g_waterfall( |
|||
| 170 | -2x | +|||
| 42 | +
- paramcd <- variables["paramcd"] # NA if paramcd == NA or it is not in variables+ #' height = adrs_f$pchg, |
|||
| 171 | -2x | +|||
| 43 | +
- y_unit <- variables["y_unit"] # NA if y_unit == NA or it is not in variables+ #' id = adrs_f$USUBJID, |
|||
| 172 | -2x | +|||
| 44 | +
- if (is.na(variables["strata"])) {
+ #' col_var = adrs_f$AVALC |
|||
| 173 | -! | +|||
| 45 | +
- strata <- NULL # NULL if strata == NA or it is not in variables+ #' ) |
|||
| 174 | +46 |
- } else {
+ #' |
||
| 175 | -2x | +|||
| 47 | +
- strata <- variables[["strata"]]+ #' g_waterfall( |
|||
| 176 | +48 |
- }+ #' height = adrs_f$pchg, |
||
| 177 | -2x | +|||
| 49 | +
- checkmate::assert_flag(y_lab_add_paramcd, null.ok = TRUE)+ #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
|
|||
| 178 | -2x | +|||
| 50 | +
- checkmate::assert_flag(subtitle_add_paramcd, null.ok = TRUE)+ #' col_var = adrs_f$SEX |
|||
| 179 | -2x | +|||
| 51 | +
- if ((!is.null(y_lab) && y_lab_add_paramcd) || (!is.null(subtitle) && subtitle_add_paramcd)) {
+ #' ) |
|||
| 180 | -2x | +|||
| 52 | +
- checkmate::assert_false(is.na(paramcd))+ #' |
|||
| 181 | -2x | +|||
| 53 | +
- checkmate::assert_scalar(unique(df[[paramcd]]))+ #' g_waterfall( |
|||
| 182 | +54 |
- }+ #' height = adrs_f$pchg, |
||
| 183 | +55 |
-
+ #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
|
||
| 184 | -2x | +|||
| 56 | +
- checkmate::assert_flag(y_lab_add_unit, null.ok = TRUE)+ #' xlab = "ID", |
|||
| 185 | -2x | +|||
| 57 | +
- checkmate::assert_flag(subtitle_add_unit, null.ok = TRUE)+ #' ylab = "Percentage Change", |
|||
| 186 | -2x | +|||
| 58 | +
- if ((!is.null(y_lab) && y_lab_add_unit) || (!is.null(subtitle) && subtitle_add_unit)) {
+ #' title = "Waterfall plot" |
|||
| 187 | -2x | +|||
| 59 | +
- checkmate::assert_false(is.na(y_unit))+ #' ) |
|||
| 188 | -2x | +|||
| 60 | +
- checkmate::assert_scalar(unique(df[[y_unit]]))+ #' |
|||
| 189 | +61 |
- }+ #' @export |
||
| 190 | +62 |
-
+ g_waterfall <- function(height, |
||
| 191 | -2x | +|||
| 63 | +
- if (!is.null(strata) && !is.null(alt_counts_df)) {
+ id, |
|||
| 192 | -2x | +|||
| 64 | +
- checkmate::assert_set_equal(unique(alt_counts_df[[strata]]), unique(df[[strata]]))+ col_var = NULL, |
|||
| 193 | +65 |
- }+ col = getOption("ggplot2.discrete.colour"),
|
||
| 194 | +66 |
-
+ xlab = NULL, |
||
| 195 | +67 |
- ####################################### |+ ylab = NULL, |
||
| 196 | +68 |
- # ---- Compute required statistics ----+ col_legend_title = NULL, |
||
| 197 | +69 |
- ####################################### |+ title = NULL) {
|
||
| 198 | +70 | 2x |
- if (!is.null(strata)) {
+ if (!is.null(col_var)) {
|
|
| 199 | -2x | +71 | +1x |
- df_grp <- tidyr::expand(df, .data[[strata]], .data[[x]]) # expand based on levels of factors+ check_same_n(height = height, id = id, col_var = col_var) |
| 200 | +72 |
} else {
|
||
| 201 | -! | +|||
| 73 | +1x |
- df_grp <- tidyr::expand(df, NULL, .data[[x]])+ check_same_n(height = height, id = id) |
||
| 202 | +74 |
} |
||
| 203 | -2x | +|||
| 75 | +
- df_grp <- df_grp %>%+ |
|||
| 204 | +76 | 2x |
- dplyr::full_join(y = df[, c(strata, x, y)], by = c(strata, x), multiple = "all") %>%+ checkmate::assert_multi_class(col_var, c("character", "factor"), null.ok = TRUE)
|
|
| 205 | +77 | 2x |
- dplyr::group_by_at(c(strata, x))+ checkmate::assert_character(col, null.ok = TRUE) |
|
| 206 | +78 | |||
| 207 | +79 | 2x |
- df_stats <- df_grp %>%+ xlabel <- deparse(substitute(id)) |
|
| 208 | +80 | 2x |
- dplyr::summarise(+ ylabel <- deparse(substitute(height))+ |
+ |
| 81 | ++ | + | ||
| 209 | +82 | 2x |
- data.frame(t(do.call(c, unname(sfun(.data[[y]], ...)[c(mid, interval)])))),+ col_label <- if (!missing(col_var)) {
|
|
| 210 | -2x | +83 | +1x |
- .groups = "drop"+ deparse(substitute(col_var)) |
| 211 | +84 |
- )+ } |
||
| 212 | +85 | |||
| 213 | +86 | 2x |
- df_stats <- df_stats[!is.na(df_stats[[mid]]), ]+ xlab <- if (is.null(xlab)) xlabel else xlab |
|
| 214 | -+ | |||
| 87 | +2x |
-
+ ylab <- if (is.null(ylab)) ylabel else ylab+ |
+ ||
| 88 | +2x | +
+ col_legend_title <- if (is.null(col_legend_title)) col_label else col_legend_title |
||
| 215 | +89 |
- # add number of objects N in strata+ |
||
| 216 | +90 | 2x |
- if (!is.null(strata) && !is.null(alt_counts_df)) {
+ plot_data <- data.frame( |
|
| 217 | +91 | 2x |
- strata_N <- paste0(strata, "_N") # nolint- |
- |
| 218 | -- |
-
+ height = height, |
||
| 219 | +92 | 2x |
- df_N <- as.data.frame(table(alt_counts_df[[strata]], exclude = c(NA, NaN, Inf))) # nolint+ id = as.character(id), |
|
| 220 | +93 | 2x |
- colnames(df_N) <- c(strata, "N") # nolint+ col_var = if (is.null(col_var)) "x" else to_n(col_var, length(height)), |
|
| 221 | +94 | 2x |
- df_N[[strata_N]] <- paste0(df_N[[strata]], " (N = ", df_N$N, ")") # nolint+ stringsAsFactors = FALSE |
|
| 222 | +95 |
-
+ ) |
||
| 223 | +96 |
- # strata_N should not be in clonames(df_stats)+ |
||
| 224 | +97 | 2x |
- checkmate::assert_disjunct(strata_N, colnames(df_stats))+ plot_data_ord <- plot_data[order(plot_data$height, decreasing = TRUE), ] |
|
| 225 | +98 | |||
| 226 | +99 | 2x |
- df_stats <- merge(x = df_stats, y = df_N[, c(strata, strata_N)], by = strata)+ p <- ggplot2::ggplot(plot_data_ord, ggplot2::aes(x = factor(id, levels = id), y = height)) + |
|
| 227 | -! | +|||
| 100 | +2x |
- } else if (!is.null(strata)) {
+ ggplot2::geom_col() + |
||
| 228 | -! | +|||
| 101 | +2x |
- strata_N <- strata # nolint+ ggplot2::geom_text( |
||
| 229 | -+ | |||
| 102 | +2x |
- } else {
+ label = format(plot_data_ord$height, digits = 2), |
||
| 230 | -! | +|||
| 103 | +2x |
- strata_N <- NULL # nolint+ vjust = ifelse(plot_data_ord$height >= 0, -0.5, 1.5) |
||
| 231 | +104 |
- }+ ) + |
||
| 232 | -+ | |||
| 105 | +2x |
-
+ ggplot2::xlab(xlab) + |
||
| 233 | -+ | |||
| 106 | +2x |
- ############################################### |+ ggplot2::ylab(ylab) + |
||
| 234 | -+ | |||
| 107 | +2x |
- # ---- Prepare certain plot's properties. ----+ ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 0, vjust = .5)) |
||
| 235 | +108 |
- ############################################### |+ |
||
| 236 | -+ | |||
| 109 | +2x |
- # legend title+ if (!is.null(col_var)) {
|
||
| 237 | -2x | +110 | +1x |
- if (is.null(legend_title) && !is.null(strata) && legend_position != "none") {
+ p <- p + |
| 238 | -2x | +111 | +1x |
- legend_title <- attr(df[[strata]], "label")+ ggplot2::aes(fill = col_var) + |
| 239 | -+ | |||
| 112 | +1x |
- }+ ggplot2::labs(fill = col_legend_title) + |
||
| 240 | -+ | |||
| 113 | +1x |
-
+ ggplot2::theme( |
||
| 241 | -+ | |||
| 114 | +1x |
- # y label+ legend.position = "bottom", |
||
| 242 | -2x | +115 | +1x |
- if (!is.null(y_lab)) {
+ legend.background = ggplot2::element_blank(), |
| 243 | +116 | 1x |
- if (y_lab_add_paramcd) {
+ legend.title = ggplot2::element_text(face = "bold"), |
|
| 244 | +117 | 1x |
- y_lab <- paste(y_lab, unique(df[[paramcd]]))+ legend.box.background = ggplot2::element_rect(colour = "black") |
|
| 245 | +118 |
- }+ ) |
||
| 246 | +119 |
-
+ } |
||
| 247 | -1x | +|||
| 120 | +
- if (y_lab_add_unit) {
+
|
|||
| 248 | -1x | -
- y_lab <- paste0(y_lab, " (", unique(df[[y_unit]]), ")")
- |
- ||
| 249 | -+ | 121 | +2x |
- }+ if (!is.null(col)) {
|
| 250 | -+ | |||
| 122 | +1x |
-
+ p <- p + |
||
| 251 | +123 | 1x |
- y_lab <- trimws(y_lab)+ ggplot2::scale_fill_manual(values = col) |
|
| 252 | +124 |
} |
||
| 253 | +125 | |||
| 254 | -+ | |||
| 126 | +2x |
- # subtitle+ if (!is.null(title)) {
|
||
| 255 | -2x | +127 | +1x |
- if (!is.null(subtitle)) {
+ p <- p + |
| 256 | -2x | +128 | +1x |
- if (subtitle_add_paramcd) {
+ ggplot2::labs(title = title) + |
| 257 | -2x | +129 | +1x |
- subtitle <- paste(subtitle, unique(df[[paramcd]]))+ ggplot2::theme(plot.title = ggplot2::element_text(face = "bold")) |
| 258 | +130 |
- }+ } |
||
| 259 | +131 | |||
| 260 | +132 | 2x |
- if (subtitle_add_unit) {
+ p |
|
| 261 | -2x | +|||
| 133 | +
- subtitle <- paste0(subtitle, " (", unique(df[[y_unit]]), ")")
+ } |
| 262 | +1 |
- }+ #' Missing Data |
||
| 263 | +2 |
-
+ #' |
||
| 264 | -2x | +|||
| 3 | +
- subtitle <- trimws(subtitle)+ #' @description `r lifecycle::badge("stable")`
|
|||
| 265 | +4 |
- }+ #' |
||
| 266 | +5 |
-
+ #' Substitute missing data with a string or factor level. |
||
| 267 | +6 |
- ############################### |+ #' |
||
| 268 | +7 |
- # ---- Build plot object. ----+ #' @param x (`factor` or `character` vector)\cr values for which any missing values should be substituted. |
||
| 269 | +8 |
- ############################### |+ #' @param label (`character`)\cr string that missing data should be replaced with. |
||
| 270 | -2x | +|||
| 9 | +
- p <- ggplot2::ggplot(+ #' |
|||
| 271 | -2x | +|||
| 10 | +
- data = df_stats,+ #' @return `x` with any `NA` values substituted by `label`. |
|||
| 272 | -2x | +|||
| 11 | +
- mapping = ggplot2::aes(+ #' |
|||
| 273 | -2x | +|||
| 12 | +
- x = .data[[x]], y = .data[[mid]],+ #' @examples |
|||
| 274 | -2x | +|||
| 13 | +
- color = if (is.null(strata_N)) NULL else .data[[strata_N]],+ #' explicit_na(c(NA, "a", "b")) |
|||
| 275 | -2x | +|||
| 14 | +
- shape = if (is.null(strata_N)) NULL else .data[[strata_N]],+ #' is.na(explicit_na(c(NA, "a", "b"))) |
|||
| 276 | -2x | +|||
| 15 | +
- lty = if (is.null(strata_N)) NULL else .data[[strata_N]],+ #' |
|||
| 277 | -2x | +|||
| 16 | +
- group = if (is.null(strata_N)) NULL else .data[[strata_N]]+ #' explicit_na(factor(c(NA, "a", "b"))) |
|||
| 278 | +17 |
- )+ #' is.na(explicit_na(factor(c(NA, "a", "b")))) |
||
| 279 | +18 |
- )+ #' |
||
| 280 | +19 |
-
+ #' explicit_na(sas_na(c("a", "")))
|
||
| 281 | -2x | +|||
| 20 | +
- if (!is.null(mid)) {
+ #' |
|||
| 282 | +21 |
- # points+ #' @export |
||
| 283 | -2x | +|||
| 22 | +
- if (grepl("p", mid_type, fixed = TRUE)) {
+ explicit_na <- function(x, label = "<Missing>") {
|
|||
| 284 | -2x | -
- p <- p + ggplot2::geom_point(position = position, size = mid_point_size, na.rm = TRUE)- |
- ||
| 285 | -+ | 23 | +239x |
- }+ checkmate::assert_string(label) |
| 286 | +24 | |||
| 287 | -+ | |||
| 25 | +239x |
- # lines+ if (is.factor(x)) {
|
||
| 288 | -+ | |||
| 26 | +140x |
- # further conditions in if are to ensure that not all of the groups consist of only one observation+ x <- forcats::fct_na_value_to_level(x, label) |
||
| 289 | -2x | +27 | +140x |
- if (grepl("l", mid_type, fixed = TRUE) &&
+ forcats::fct_drop(x, only = label) |
| 290 | -2x | +28 | +99x |
- !is.null(strata) &&+ } else if (is.character(x)) {
|
| 291 | -2x | +29 | +99x |
- !all(dplyr::summarise(df_grp, count_n = dplyr::n())[["count_n"]] == 1L)) {
+ x[is.na(x)] <- label |
| 292 | -2x | +30 | +99x |
- p <- p + ggplot2::geom_line(position = position, na.rm = TRUE)+ x |
| 293 | +31 |
- }+ } else {
|
||
| 294 | -+ | |||
| 32 | +! |
- }+ stop("only factors and character vectors allowed")
|
||
| 295 | +33 |
-
+ } |
||
| 296 | +34 |
- # interval- |
- ||
| 297 | -2x | -
- if (!is.null(interval)) {
- |
- ||
| 298 | -2x | -
- p <- p +- |
- ||
| 299 | -2x | -
- ggplot2::geom_errorbar(+ } |
||
| 300 | -2x | +|||
| 35 | +
- ggplot2::aes(ymin = .data[[whiskers[1]]], ymax = .data[[whiskers[max(1, length(whiskers))]]]),+ |
|||
| 301 | -2x | +|||
| 36 | +
- width = 0.45,+ #' Convert Strings to `NA` |
|||
| 302 | -2x | +|||
| 37 | +
- position = position+ #' |
|||
| 303 | +38 |
- )+ #' @description `r lifecycle::badge("stable")`
|
||
| 304 | +39 |
-
+ #' |
||
| 305 | -2x | +|||
| 40 | +
- if (length(whiskers) == 1) { # lwr or upr only; mid is then required
+ #' SAS imports missing data as empty strings or strings with whitespaces only. This helper function can be used to |
|||
| 306 | +41 |
- # workaround as geom_errorbar does not provide single-direction whiskers+ #' convert these values to `NA`s. |
||
| 307 | -! | +|||
| 42 | +
- p <- p ++ #' |
|||
| 308 | -! | +|||
| 43 | +
- ggplot2::geom_linerange(+ #' @inheritParams explicit_na |
|||
| 309 | -! | +|||
| 44 | +
- data = df_stats[!is.na(df_stats[[whiskers]]), ], # as na.rm =TRUE does not suppress warnings+ #' @param empty (`logical`)\cr if `TRUE` empty strings get replaced by `NA`. |
|||
| 310 | -! | +|||
| 45 | +
- ggplot2::aes(ymin = .data[[mid]], ymax = .data[[whiskers]]),+ #' @param whitespaces (`logical`)\cr if `TRUE` then strings made from whitespaces only get replaced with `NA`. |
|||
| 311 | -! | +|||
| 46 | +
- position = position,+ #' |
|||
| 312 | -! | +|||
| 47 | +
- na.rm = TRUE,+ #' @return `x` with `""` and/or whitespace-only values substituted by `NA`, depending on the values of |
|||
| 313 | -! | +|||
| 48 | +
- show.legend = FALSE+ #' `empty` and `whitespaces`. |
|||
| 314 | +49 |
- )+ #' |
||
| 315 | +50 |
- }+ #' @examples |
||
| 316 | +51 |
- }+ #' sas_na(c("1", "", " ", " ", "b"))
|
||
| 317 | +52 |
-
+ #' sas_na(factor(c("", " ", "b")))
|
||
| 318 | -2x | +|||
| 53 | +
- p <- p ++ #' |
|||
| 319 | -2x | +|||
| 54 | +
- ggplot2::scale_y_continuous(labels = scales::comma, expand = ggplot2::expansion(c(0.25, .25))) ++ #' is.na(sas_na(c("1", "", " ", " ", "b")))
|
|||
| 320 | -2x | +|||
| 55 | +
- ggplot2::labs(+ #' |
|||
| 321 | -2x | +|||
| 56 | +
- title = title,+ #' @export |
|||
| 322 | -2x | +|||
| 57 | +
- subtitle = subtitle,+ sas_na <- function(x, empty = TRUE, whitespaces = TRUE) {
|
|||
| 323 | -2x | +58 | +236x |
- caption = caption,+ checkmate::assert_flag(empty) |
| 324 | -2x | +59 | +236x |
- color = legend_title,+ checkmate::assert_flag(whitespaces) |
| 325 | -2x | +|||
| 60 | +
- lty = legend_title,+ |
|||
| 326 | -2x | +61 | +236x |
- shape = legend_title,+ if (is.factor(x)) {
|
| 327 | -2x | +62 | +133x |
- x = attr(df[[x]], "label"),+ empty_levels <- levels(x) == "" |
| 328 | -2x | -
- y = y_lab- |
- ||
| 329 | -+ | 63 | +11x |
- )+ if (empty && any(empty_levels)) levels(x)[empty_levels] <- NA |
| 330 | +64 | |||
| 331 | -2x | -
- if (!is.null(col)) {
- |
- ||
| 332 | -! | +65 | +133x |
- p <- p ++ ws_levels <- grepl("^\\s+$", levels(x))
|
| 333 | +66 | ! |
- ggplot2::scale_color_manual(values = col)+ if (whitespaces && any(ws_levels)) levels(x)[ws_levels] <- NA |
|
| 334 | +67 |
- }+ |
||
| 335 | -+ | |||
| 68 | +133x |
-
+ x |
||
| 336 | -2x | +69 | +103x |
- if (!is.null(ggtheme)) {
+ } else if (is.character(x)) {
|
| 337 | -2x | +70 | +103x |
- p <- p + ggtheme+ if (empty) x[x == ""] <- NA_character_ |
| 338 | +71 |
- } else {
- |
- ||
| 339 | -! | -
- p <- p +- |
- ||
| 340 | -! | -
- ggplot2::theme_bw() ++ |
||
| 341 | -! | +|||
| 72 | +103x |
- ggplot2::theme(+ if (whitespaces) x[grepl("^\\s+$", x)] <- NA_character_
|
||
| 342 | -! | +|||
| 73 | +
- legend.key.width = grid::unit(1, "cm"),+ |
|||
| 343 | -! | +|||
| 74 | +103x |
- legend.position = legend_position,+ x |
||
| 344 | -! | +|||
| 75 | +
- legend.direction = ifelse(+ } else {
|
|||
| 345 | +76 | ! |
- legend_position %in% c("top", "bottom"),
+ stop("only factors and character vectors allowed")
|
|
| 346 | -! | +|||
| 77 | +
- "horizontal",+ } |
|||
| 347 | -! | +|||
| 78 | +
- "vertical"+ } |
| 348 | +1 |
- )+ #' Helper Function to create a map dataframe that can be used in `trim_levels_to_map` split function. |
||
| 349 | +2 |
- )+ #' |
||
| 350 | +3 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 351 | +4 |
-
+ #' |
||
| 352 | +5 |
- ############################################################# |+ #' Helper Function to create a map dataframe from the input dataset, which can be used as an argument in the |
||
| 353 | +6 |
- # ---- Optionally, add table to the bottom of the plot. ----+ #' `trim_levels_to_map` split function. Based on different method, the map is constructed differently. |
||
| 354 | +7 |
- ############################################################# |+ #' |
||
| 355 | -2x | +|||
| 8 | +
- if (!is.null(table)) {
+ #' @inheritParams argument_convention |
|||
| 356 | -1x | +|||
| 9 | +
- df_stats_table <- df_grp %>%+ #' @param abnormal (named `list`)\cr identifying the abnormal range level(s) in `df`. Based on the levels of |
|||
| 357 | -1x | +|||
| 10 | +
- dplyr::summarise(+ #' abnormality of the input dataset, it can be something like `list(Low = "LOW LOW", High = "HIGH HIGH")` or |
|||
| 358 | -1x | +|||
| 11 | +
- h_format_row(+ #' `abnormal = list(Low = "LOW", High = "HIGH"))` |
|||
| 359 | -1x | +|||
| 12 | +
- x = sfun(.data[[y]], ...)[table],+ #' @param method (`string`)\cr indicates how the returned map will be constructed. Can be `"default"` or `"range"`. |
|||
| 360 | -1x | +|||
| 13 | +
- format = table_format,+ #' |
|||
| 361 | -1x | +|||
| 14 | +
- labels = table_labels+ #' @return A map `data.frame`. |
|||
| 362 | +15 |
- ),+ #' |
||
| 363 | -1x | +|||
| 16 | +
- .groups = "drop"+ #' @note If method is `"default"`, the returned map will only have the abnormal directions that are observed in the |
|||
| 364 | +17 |
- )+ #' `df`, and records with all normal values will be excluded to avoid error in creating layout. If method is |
||
| 365 | +18 |
-
+ #' `"range"`, the returned map will be based on the rule that at least one observation with low range > 0 |
||
| 366 | -1x | +|||
| 19 | +
- stats_lev <- rev(setdiff(colnames(df_stats_table), c(strata, x)))+ #' for low direction and at least one observation with high range is not missing for high direction. |
|||
| 367 | +20 |
-
+ #' |
||
| 368 | -1x | +|||
| 21 | +
- df_stats_table <- df_stats_table %>%+ #' @examples |
|||
| 369 | -1x | +|||
| 22 | +
- tidyr::pivot_longer(+ #' adlb <- df_explicit_na(tern_ex_adlb) |
|||
| 370 | -1x | +|||
| 23 | +
- cols = -dplyr::all_of(c(strata, x)),+ #' |
|||
| 371 | -1x | +|||
| 24 | +
- names_to = "stat",+ #' h_map_for_count_abnormal( |
|||
| 372 | -1x | +|||
| 25 | +
- values_to = "value",+ #' df = adlb, |
|||
| 373 | -1x | +|||
| 26 | +
- names_ptypes = list(stat = factor(levels = stats_lev))+ #' variables = list(anl = "ANRIND", split_rows = c("LBCAT", "PARAM")),
|
|||
| 374 | +27 |
- )+ #' abnormal = list(low = c("LOW"), high = c("HIGH")),
|
||
| 375 | +28 |
-
+ #' method = "default", |
||
| 376 | -1x | +|||
| 29 | +
- tbl <- ggplot2::ggplot(+ #' na_str = "<Missing>" |
|||
| 377 | -1x | +|||
| 30 | +
- df_stats_table,+ #' ) |
|||
| 378 | -1x | +|||
| 31 | +
- ggplot2::aes(x = .data[[x]], y = .data[["stat"]], label = .data[["value"]])+ #' |
|||
| 379 | +32 |
- ) ++ #' df <- data.frame( |
||
| 380 | -1x | +|||
| 33 | +
- ggplot2::geom_text(size = table_font_size) ++ #' USUBJID = c(rep("1", 4), rep("2", 4), rep("3", 4)),
|
|||
| 381 | -1x | +|||
| 34 | +
- ggplot2::theme_bw() ++ #' AVISIT = c( |
|||
| 382 | -1x | +|||
| 35 | +
- ggplot2::theme(+ #' rep("WEEK 1", 2),
|
|||
| 383 | -1x | +|||
| 36 | +
- panel.border = ggplot2::element_blank(),+ #' rep("WEEK 2", 2),
|
|||
| 384 | -1x | +|||
| 37 | +
- panel.grid.major = ggplot2::element_blank(),+ #' rep("WEEK 1", 2),
|
|||
| 385 | -1x | +|||
| 38 | +
- panel.grid.minor = ggplot2::element_blank(),+ #' rep("WEEK 2", 2),
|
|||
| 386 | -1x | +|||
| 39 | +
- axis.ticks = ggplot2::element_blank(),+ #' rep("WEEK 1", 2),
|
|||
| 387 | -1x | +|||
| 40 | +
- axis.title = ggplot2::element_blank(),+ #' rep("WEEK 2", 2)
|
|||
| 388 | -1x | +|||
| 41 | +
- axis.text.x = ggplot2::element_blank(),+ #' ), |
|||
| 389 | -1x | +|||
| 42 | +
- axis.text.y = ggplot2::element_text(margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 5)),+ #' PARAM = rep(c("ALT", "CPR"), 6),
|
|||
| 390 | -1x | +|||
| 43 | +
- strip.text = ggplot2::element_text(hjust = 0),+ #' ANRIND = c( |
|||
| 391 | -1x | +|||
| 44 | +
- strip.text.x = ggplot2::element_text(margin = ggplot2::margin(1.5, 0, 1.5, 0, "pt")),+ #' "NORMAL", "NORMAL", "LOW", |
|||
| 392 | -1x | +|||
| 45 | +
- strip.background = ggplot2::element_rect(fill = "grey95", color = NA),+ #' "HIGH", "LOW", "LOW", "HIGH", "HIGH", rep("NORMAL", 4)
|
|||
| 393 | -1x | +|||
| 46 | +
- legend.position = "none"+ #' ), |
|||
| 394 | +47 |
- )+ #' ANRLO = rep(5, 12), |
||
| 395 | +48 |
-
+ #' ANRHI = rep(20, 12) |
||
| 396 | -1x | +|||
| 49 | +
- if (!is.null(strata)) {
+ #' ) |
|||
| 397 | -1x | +|||
| 50 | +
- tbl <- tbl + ggplot2::facet_wrap(facets = strata, ncol = 1)+ #' df$ANRIND <- factor(df$ANRIND, levels = c("LOW", "HIGH", "NORMAL"))
|
|||
| 398 | +51 |
- }+ #' h_map_for_count_abnormal( |
||
| 399 | +52 |
-
+ #' df = df, |
||
| 400 | +53 |
- # align plot and table+ #' variables = list( |
||
| 401 | -1x | +|||
| 54 | +
- cowplot::plot_grid(p, tbl, ncol = 1)+ #' anl = "ANRIND", |
|||
| 402 | +55 |
- } else {
+ #' split_rows = c("PARAM"),
|
||
| 403 | -1x | +|||
| 56 | +
- p+ #' range_low = "ANRLO", |
|||
| 404 | +57 |
- }+ #' range_high = "ANRHI" |
||
| 405 | +58 |
- }+ #' ), |
||
| 406 | +59 |
-
+ #' abnormal = list(low = c("LOW"), high = c("HIGH")),
|
||
| 407 | +60 |
- #' Helper function to get the right formatting in the optional table in `g_lineplot`.+ #' method = "range", |
||
| 408 | +61 |
- #'+ #' na_str = "<Missing>" |
||
| 409 | +62 |
- #' @description `r lifecycle::badge("stable")`
+ #' ) |
||
| 410 | +63 |
#' |
||
| 411 | +64 |
- #' @param x (named `list`)\cr list of numerical values to be formatted and optionally labeled.+ #' @export |
||
| 412 | +65 |
- #' Elements of `x` must be `numeric` vectors.+ h_map_for_count_abnormal <- function(df, |
||
| 413 | +66 |
- #' @param format (named `character` or `NULL`)\cr format patterns for `x`. Names of the `format` must+ variables = list( |
||
| 414 | +67 |
- #' match the names of `x`. This parameter is passed directly to the `rtables::format_rcell`+ anl = "ANRIND", |
||
| 415 | +68 |
- #' function through the `format` parameter.+ split_rows = c("PARAM"),
|
||
| 416 | +69 |
- #' @param labels (named `character` or `NULL`)\cr optional labels for `x`. Names of the `labels` must+ range_low = "ANRLO", |
||
| 417 | +70 |
- #' match the names of `x`. When a label is not specified for an element of `x`,+ range_high = "ANRHI" |
||
| 418 | +71 |
- #' then this function tries to use `label` or `names` (in this order) attribute of that element+ ), |
||
| 419 | +72 |
- #' (depending on which one exists and it is not `NULL` or `NA` or `NaN`). If none of these attributes+ abnormal = list(low = c("LOW", "LOW LOW"), high = c("HIGH", "HIGH HIGH")),
|
||
| 420 | +73 |
- #' are attached to a given element of `x`, then the label is automatically generated.+ method = c("default", "range"),
|
||
| 421 | +74 |
- #'+ na_level = lifecycle::deprecated(), |
||
| 422 | +75 |
- #' @return A single row `data.frame` object.+ na_str = "<Missing>") {
|
||
| 423 | -+ | |||
| 76 | +7x |
- #'+ if (lifecycle::is_present(na_level)) {
|
||
| 424 | -+ | |||
| 77 | +! |
- #' @examples+ lifecycle::deprecate_warn("0.9.1", "h_map_for_count_abnormal(na_level)", "h_map_for_count_abnormal(na_str)")
|
||
| 425 | -+ | |||
| 78 | +! |
- #' mean_ci <- c(48, 51)+ na_str <- na_level |
||
| 426 | +79 |
- #' x <- list(mean = 50, mean_ci = mean_ci)+ } |
||
| 427 | +80 |
- #' format <- c(mean = "xx.x", mean_ci = "(xx.xx, xx.xx)")+ |
||
| 428 | -+ | |||
| 81 | +7x |
- #' labels <- c(mean = "My Mean")+ method <- match.arg(method) |
||
| 429 | -+ | |||
| 82 | +7x |
- #' h_format_row(x, format, labels)+ checkmate::assert_subset(c("anl", "split_rows"), names(variables))
|
||
| 430 | -+ | |||
| 83 | +7x |
- #'+ checkmate::assert_false(anyNA(df[variables$split_rows])) |
||
| 431 | -+ | |||
| 84 | +7x |
- #' attr(mean_ci, "label") <- "Mean 95% CI"+ assert_df_with_variables(df, |
||
| 432 | -+ | |||
| 85 | +7x |
- #' x <- list(mean = 50, mean_ci = mean_ci)+ variables = list(anl = variables$anl, split_rows = variables$split_rows),+ |
+ ||
| 86 | +7x | +
+ na_level = na_str |
||
| 433 | +87 |
- #' h_format_row(x, format, labels)+ )+ |
+ ||
| 88 | +7x | +
+ assert_df_with_factors(df, list(val = variables$anl))+ |
+ ||
| 89 | +7x | +
+ assert_valid_factor(df[[variables$anl]], any.missing = FALSE)+ |
+ ||
| 90 | +7x | +
+ assert_list_of_variables(variables)+ |
+ ||
| 91 | +7x | +
+ checkmate::assert_list(abnormal, types = "character", len = 2) |
||
| 434 | +92 |
- #'+ |
||
| 435 | +93 |
- #' @export+ # Drop usued levels from df as they are not supposed to be in the final map+ |
+ ||
| 94 | +7x | +
+ df <- droplevels(df) |
||
| 436 | +95 |
- h_format_row <- function(x, format, labels = NULL) {
+
+ |
+ ||
| 96 | +7x | +
+ normal_value <- setdiff(levels(df[[variables$anl]]), unlist(abnormal)) |
||
| 437 | +97 |
- # cell: one row, one column data.frame+ |
||
| 438 | -19x | +|||
| 98 | +
- format_cell <- function(x, format, label = NULL) {
+ # Based on the understanding of clinical data, there should only be one level of normal which is "NORMAL" |
|||
| 439 | -56x | +99 | +7x |
- fc <- format_rcell(x = x, format = unlist(format))+ checkmate::assert_vector(normal_value, len = 1) |
| 440 | -56x | +|||
| 100 | +
- if (is.na(fc)) {
+
|
|||
| 441 | -! | +|||
| 101 | +
- fc <- "NA"+ # Default method will only have what is observed in the df, and records with all normal values will be excluded to |
|||
| 442 | +102 |
- }+ # avoid error in layout building. |
||
| 443 | -56x | +103 | +7x |
- x_label <- attr(x, "label")+ if (method == "default") {
|
| 444 | -56x | +104 | +3x |
- if (!is.null(label) && !is.na(label)) {
+ df_abnormal <- subset(df, df[[variables$anl]] %in% unlist(abnormal)) |
| 445 | -55x | +105 | +3x |
- names(fc) <- label+ map <- unique(df_abnormal[c(variables$split_rows, variables$anl)]) |
| 446 | -1x | +106 | +3x |
- } else if (!is.null(x_label) && !is.na(x_label)) {
+ map_normal <- unique(subset(map, select = variables$split_rows)) |
| 447 | -! | +|||
| 107 | +3x |
- names(fc) <- x_label+ map_normal[[variables$anl]] <- normal_value |
||
| 448 | -1x | +108 | +3x |
- } else if (length(x) == length(fc)) {
+ map <- rbind(map, map_normal) |
| 449 | -! | +|||
| 109 | +4x |
- names(fc) <- names(x)+ } else if (method == "range") {
|
||
| 450 | +110 |
- }+ # range method follows the rule that at least one observation with ANRLO > 0 for low+ |
+ ||
| 111 | ++ |
+ # direction and at least one observation with ANRHI is not missing for high direction. |
||
| 451 | -56x | +112 | +4x |
- as.data.frame(t(fc))+ checkmate::assert_subset(c("range_low", "range_high"), names(variables))
|
| 452 | -+ | |||
| 113 | +4x |
- }+ checkmate::assert_subset(c("LOW", "HIGH"), toupper(names(abnormal)))
|
||
| 453 | +114 | |||
| 454 | -19x | +115 | +4x |
- row <- do.call(+ assert_df_with_variables(df, |
| 455 | -19x | +116 | +4x |
- cbind,+ variables = list( |
| 456 | -19x | +117 | +4x |
- lapply(+ range_low = variables$range_low, |
| 457 | -19x | +118 | +4x |
- names(x), function(xn) format_cell(x[[xn]], format = format[xn], label = labels[xn])+ range_high = variables$range_high |
| 458 | +119 |
- )+ ) |
||
| 459 | +120 |
- )+ ) |
||
| 460 | +121 | |||
| 122 | ++ |
+ # Define low direction of map+ |
+ ||
| 461 | -19x | +123 | +4x |
- row+ df_low <- subset(df, df[[variables$range_low]] > 0) |
| 462 | -+ | |||
| 124 | +4x |
- }+ map_low <- unique(df_low[variables$split_rows]) |
||
| 463 | -+ | |||
| 125 | +4x |
-
+ low_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "LOW"])) |
||
| 464 | -+ | |||
| 126 | +4x |
- #' Control Function for `g_lineplot` Function+ low_levels_df <- as.data.frame(low_levels) |
||
| 465 | -+ | |||
| 127 | +4x |
- #'+ colnames(low_levels_df) <- variables$anl |
||
| 466 | -+ | |||
| 128 | +4x |
- #' @description `r lifecycle::badge("stable")`
+ low_levels_df <- do.call("rbind", replicate(nrow(map_low), low_levels_df, simplify = FALSE))
|
||
| 467 | -+ | |||
| 129 | +4x |
- #'+ rownames(map_low) <- NULL # Just to avoid strange row index in case upstream functions changed |
||
| 468 | -+ | |||
| 130 | +4x |
- #' Default values for `variables` parameter in `g_lineplot` function.+ map_low <- map_low[rep(seq_len(nrow(map_low)), each = length(low_levels)), , drop = FALSE] |
||
| 469 | -+ | |||
| 131 | +4x |
- #' A variable's default value can be overwritten for any variable.+ map_low <- cbind(map_low, low_levels_df) |
||
| 470 | +132 |
- #'+ |
||
| 471 | +133 |
- #' @param x (`character`)\cr x variable name.+ # Define high direction of map |
||
| 472 | -+ | |||
| 134 | +4x |
- #' @param y (`character`)\cr y variable name.+ df_high <- subset(df, df[[variables$range_high]] != na_str | !is.na(df[[variables$range_high]])) |
||
| 473 | -+ | |||
| 135 | +4x |
- #' @param strata (`character` or `NA`)\cr strata variable name.+ map_high <- unique(df_high[variables$split_rows]) |
||
| 474 | -+ | |||
| 136 | +4x |
- #' @param paramcd (`character` or `NA`)\cr `paramcd` variable name.+ high_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "HIGH"])) |
||
| 475 | -+ | |||
| 137 | +4x |
- #' @param y_unit (`character` or `NA`)\cr `y_unit` variable name.+ high_levels_df <- as.data.frame(high_levels) |
||
| 476 | -+ | |||
| 138 | +4x |
- #'+ colnames(high_levels_df) <- variables$anl |
||
| 477 | -+ | |||
| 139 | +4x |
- #' @return A named character vector of variable names.+ high_levels_df <- do.call("rbind", replicate(nrow(map_high), high_levels_df, simplify = FALSE))
|
||
| 478 | -+ | |||
| 140 | +4x |
- #'+ rownames(map_high) <- NULL+ |
+ ||
| 141 | +4x | +
+ map_high <- map_high[rep(seq_len(nrow(map_high)), each = length(high_levels)), , drop = FALSE]+ |
+ ||
| 142 | +4x | +
+ map_high <- cbind(map_high, high_levels_df) |
||
| 479 | +143 |
- #' @examples+ |
||
| 480 | +144 |
- #' control_lineplot_vars()+ # Define normal of map+ |
+ ||
| 145 | +4x | +
+ map_normal <- unique(rbind(map_low, map_high)[variables$split_rows])+ |
+ ||
| 146 | +4x | +
+ map_normal[variables$anl] <- normal_value |
||
| 481 | +147 |
- #' control_lineplot_vars(strata = NA)+ + |
+ ||
| 148 | +4x | +
+ map <- rbind(map_low, map_high, map_normal) |
||
| 482 | +149 |
- #'+ } |
||
| 483 | +150 |
- #' @export+ |
||
| 484 | +151 |
- control_lineplot_vars <- function(x = "AVISIT", y = "AVAL", strata = "ARM", paramcd = "PARAMCD", y_unit = "AVALU") {
+ # map should be all characters |
||
| 485 | -2x | +152 | +7x |
- checkmate::assert_string(x)+ map <- data.frame(lapply(map, as.character), stringsAsFactors = FALSE) |
| 486 | -2x | +|||
| 153 | +
- checkmate::assert_string(y)+ |
|||
| 487 | -2x | +|||
| 154 | +
- checkmate::assert_string(strata, na.ok = TRUE)+ # sort the map final output by split_rows variables |
|||
| 488 | -2x | +155 | +7x |
- checkmate::assert_string(paramcd, na.ok = TRUE)+ for (i in rev(seq_len(length(variables$split_rows)))) {
|
| 489 | -2x | +156 | +7x |
- checkmate::assert_string(y_unit, na.ok = TRUE)+ map <- map[order(map[[i]]), ] |
| 490 | +157 | - - | -||
| 491 | -2x | -
- variables <- c(x = x, y = y, strata = strata, paramcd = paramcd, y_unit = y_unit)+ } |
||
| 492 | -2x | +158 | +7x |
- return(variables)+ map |
| 493 | +159 |
}@@ -102519,14 +102526,14 @@ tern coverage - 94.83% |
| 1 |
- #' Missing Data+ #' Tabulate Biomarker Effects on Binary Response by Subgroup |
||
| 5 |
- #' Substitute missing data with a string or factor level.+ #' Tabulate the estimated effects of multiple continuous biomarker variables |
||
| 6 |
- #'+ #' on a binary response endpoint across population subgroups. |
||
| 7 |
- #' @param x (`factor` or `character` vector)\cr values for which any missing values should be substituted.+ #' |
||
| 8 |
- #' @param label (`character`)\cr string that missing data should be replaced with.+ #' @inheritParams argument_convention |
||
| 9 |
- #'+ #' @param df (`data.frame`)\cr containing all analysis variables, as returned by |
||
| 10 |
- #' @return `x` with any `NA` values substituted by `label`.+ #' [extract_rsp_biomarkers()]. |
||
| 11 |
- #'+ #' @param vars (`character`)\cr the names of statistics to be reported among: |
||
| 12 |
- #' @examples+ #' * `n_tot`: Total number of patients per group. |
||
| 13 |
- #' explicit_na(c(NA, "a", "b"))+ #' * `n_rsp`: Total number of responses per group. |
||
| 14 |
- #' is.na(explicit_na(c(NA, "a", "b")))+ #' * `prop`: Total response proportion per group. |
||
| 15 |
- #'+ #' * `or`: Odds ratio. |
||
| 16 |
- #' explicit_na(factor(c(NA, "a", "b")))+ #' * `ci`: Confidence interval of odds ratio. |
||
| 17 |
- #' is.na(explicit_na(factor(c(NA, "a", "b"))))+ #' * `pval`: p-value of the effect. |
||
| 18 |
- #'+ #' Note, the statistics `n_tot`, `or` and `ci` are required. |
||
| 19 |
- #' explicit_na(sas_na(c("a", "")))
+ #' |
||
| 20 |
- #'+ #' @return An `rtables` table summarizing biomarker effects on binary response by subgroup. |
||
| 21 |
- #' @export+ #' |
||
| 22 |
- explicit_na <- function(x, label = "<Missing>") {
+ #' @details These functions create a layout starting from a data frame which contains |
||
| 23 | -239x | +
- checkmate::assert_string(label)+ #' the required statistics. The tables are then typically used as input for forest plots. |
|
| 24 |
-
+ #' |
||
| 25 | -239x | +
- if (is.factor(x)) {
+ #' @note In contrast to [tabulate_rsp_subgroups()] this tabulation function does |
|
| 26 | -140x | +
- x <- forcats::fct_na_value_to_level(x, label)+ #' not start from an input layout `lyt`. This is because internally the table is |
|
| 27 | -140x | +
- forcats::fct_drop(x, only = label)+ #' created by combining multiple subtables. |
|
| 28 | -99x | +
- } else if (is.character(x)) {
+ #' |
|
| 29 | -99x | +
- x[is.na(x)] <- label+ #' @seealso [h_tab_rsp_one_biomarker()] which is used internally, [extract_rsp_biomarkers()]. |
|
| 30 | -99x | +
- x+ #' |
|
| 31 |
- } else {
+ #' @examples |
||
| 32 | -! | +
- stop("only factors and character vectors allowed")
+ #' library(dplyr) |
|
| 33 |
- }+ #' library(forcats) |
||
| 34 |
- }+ #' |
||
| 35 |
-
+ #' adrs <- tern_ex_adrs |
||
| 36 |
- #' Convert Strings to `NA`+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 38 |
- #' @description `r lifecycle::badge("stable")`
+ #' adrs_f <- adrs %>% |
||
| 39 |
- #'+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 40 |
- #' SAS imports missing data as empty strings or strings with whitespaces only. This helper function can be used to+ #' mutate(rsp = AVALC == "CR") |
||
| 41 |
- #' convert these values to `NA`s.+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
||
| 43 |
- #' @inheritParams explicit_na+ #' df <- extract_rsp_biomarkers( |
||
| 44 |
- #' @param empty (`logical`)\cr if `TRUE` empty strings get replaced by `NA`.+ #' variables = list( |
||
| 45 |
- #' @param whitespaces (`logical`)\cr if `TRUE` then strings made from whitespaces only get replaced with `NA`.+ #' rsp = "rsp", |
||
| 46 |
- #'+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 47 |
- #' @return `x` with `""` and/or whitespace-only values substituted by `NA`, depending on the values of+ #' covariates = "SEX", |
||
| 48 |
- #' `empty` and `whitespaces`.+ #' subgroups = "BMRKR2" |
||
| 49 |
- #'+ #' ), |
||
| 50 |
- #' @examples+ #' data = adrs_f |
||
| 51 |
- #' sas_na(c("1", "", " ", " ", "b"))
+ #' ) |
||
| 52 |
- #' sas_na(factor(c("", " ", "b")))
+ #' |
||
| 53 |
- #'+ #' \donttest{
|
||
| 54 |
- #' is.na(sas_na(c("1", "", " ", " ", "b")))
+ #' ## Table with default columns. |
||
| 55 |
- #'+ #' tabulate_rsp_biomarkers(df) |
||
| 56 |
- #' @export+ #' |
||
| 57 |
- sas_na <- function(x, empty = TRUE, whitespaces = TRUE) {
+ #' ## Table with a manually chosen set of columns: leave out "pval", reorder. |
||
| 58 | -236x | +
- checkmate::assert_flag(empty)+ #' tab <- tabulate_rsp_biomarkers( |
|
| 59 | -236x | +
- checkmate::assert_flag(whitespaces)+ #' df = df, |
|
| 60 |
-
+ #' vars = c("n_rsp", "ci", "n_tot", "prop", "or")
|
||
| 61 | -236x | +
- if (is.factor(x)) {
+ #' ) |
|
| 62 | -133x | +
- empty_levels <- levels(x) == ""+ #' |
|
| 63 | -11x | +
- if (empty && any(empty_levels)) levels(x)[empty_levels] <- NA+ #' ## Finally produce the forest plot. |
|
| 64 |
-
+ #' g_forest(tab, xlim = c(0.7, 1.4)) |
||
| 65 | -133x | +
- ws_levels <- grepl("^\\s+$", levels(x))
+ #' } |
|
| 66 | -! | +
- if (whitespaces && any(ws_levels)) levels(x)[ws_levels] <- NA+ #' |
|
| 67 |
-
+ #' @export |
||
| 68 | -133x | +
- x+ #' @name response_biomarkers_subgroups |
|
| 69 | -103x | +
- } else if (is.character(x)) {
+ tabulate_rsp_biomarkers <- function(df, |
|
| 70 | -103x | +
- if (empty) x[x == ""] <- NA_character_+ vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
|
|
| 71 |
-
+ .indent_mods = 0L) {
|
||
| 72 | -103x | +3x |
- if (whitespaces) x[grepl("^\\s+$", x)] <- NA_character_
+ checkmate::assert_data_frame(df) |
| 73 | -+ | 3x |
-
+ checkmate::assert_character(df$biomarker) |
| 74 | -103x | +3x |
- x+ checkmate::assert_character(df$biomarker_label) |
| 75 | -+ | 3x |
- } else {
+ checkmate::assert_subset(vars, c("n_tot", "n_rsp", "prop", "or", "ci", "pval"))
|
| 76 | -! | +
- stop("only factors and character vectors allowed")
+
|
|
| 77 | -+ | 3x |
- }+ df_subs <- split(df, f = df$biomarker) |
| 78 | -+ | 3x |
- }+ tabs <- lapply(df_subs, FUN = function(df_sub) {
+ |
+
| 79 | +5x | +
+ tab_sub <- h_tab_rsp_one_biomarker(+ |
+ |
| 80 | +5x | +
+ df = df_sub,+ |
+ |
| 81 | +5x | +
+ vars = vars,+ |
+ |
| 82 | +5x | +
+ .indent_mods = .indent_mods |
| 1 | +83 |
- #' Odds Ratio Estimation+ ) |
||
| 2 | +84 |
- #'+ # Insert label row as first row in table.+ |
+ ||
| 85 | +5x | +
+ label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1]+ |
+ ||
| 86 | +5x | +
+ tab_sub |
||
| 3 | +87 |
- #' @description `r lifecycle::badge("stable")`
+ })+ |
+ ||
| 88 | +3x | +
+ result <- do.call(rbind, tabs) |
||
| 4 | +89 |
- #'+ + |
+ ||
| 90 | +3x | +
+ n_id <- grep("n_tot", vars)
+ |
+ ||
| 91 | +3x | +
+ or_id <- match("or", vars)
+ |
+ ||
| 92 | +3x | +
+ ci_id <- match("ci", vars)
+ |
+ ||
| 93 | +3x | +
+ structure(+ |
+ ||
| 94 | +3x | +
+ result,+ |
+ ||
| 95 | +3x | +
+ forest_header = paste0(c("Lower", "Higher"), "\nBetter"),
+ |
+ ||
| 96 | +3x | +
+ col_x = or_id,+ |
+ ||
| 97 | +3x | +
+ col_ci = ci_id,+ |
+ ||
| 98 | +3x | +
+ col_symbol_size = n_id |
||
| 5 | +99 |
- #' Compares bivariate responses between two groups in terms of odds ratios+ ) |
||
| 6 | +100 |
- #' along with a confidence interval.+ } |
||
| 7 | +101 |
- #'+ |
||
| 8 | +102 |
- #' @inheritParams argument_convention+ #' Prepares Response Data Estimates for Multiple Biomarkers in a Single Data Frame |
||
| 9 | +103 |
#' |
||
| 10 | +104 |
- #' @details This function uses either logistic regression for unstratified+ #' @description `r lifecycle::badge("stable")`
|
||
| 11 | +105 |
- #' analyses, or conditional logistic regression for stratified analyses.+ #' |
||
| 12 | +106 |
- #' The Wald confidence interval with the specified confidence level is+ #' Prepares estimates for number of responses, patients and overall response rate, |
||
| 13 | +107 |
- #' calculated.+ #' as well as odds ratio estimates, confidence intervals and p-values, |
||
| 14 | +108 |
- #'+ #' for multiple biomarkers across population subgroups in a single data frame. |
||
| 15 | +109 |
- #' @note For stratified analyses, there is currently no implementation for conditional+ #' `variables` corresponds to the names of variables found in `data`, passed as a |
||
| 16 | +110 |
- #' likelihood confidence intervals, therefore the likelihood confidence interval is not+ #' named list and requires elements `rsp` and `biomarkers` (vector of continuous |
||
| 17 | +111 |
- #' yet available as an option. Besides, when `rsp` contains only responders or non-responders,+ #' biomarker variables) and optionally `covariates`, `subgroups` and `strat`. |
||
| 18 | +112 |
- #' then the result values will be `NA`, because no odds ratio estimation is possible.+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
||
| 19 | +113 |
#' |
||
| 20 | +114 |
- #' @seealso Relevant helper function [h_odds_ratio()].+ #' @inheritParams argument_convention |
||
| 21 | +115 |
- #'+ #' @inheritParams response_subgroups |
||
| 22 | +116 |
- #' @name odds_ratio+ #' @param control (named `list`)\cr controls for the response definition and the |
||
| 23 | +117 |
- NULL+ #' confidence level produced by [control_logistic()]. |
||
| 24 | +118 |
-
+ #' |
||
| 25 | +119 |
- #' @describeIn odds_ratio Statistics function which estimates the odds ratio+ #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_rsp`, |
||
| 26 | +120 |
- #' between a treatment and a control. A `variables` list with `arm` and `strata`+ #' `prop`, `or`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`, |
||
| 27 | +121 |
- #' variable names must be passed if a stratified analysis is required.+ #' `var_label`, and `row_type`. |
||
| 28 | +122 |
#' |
||
| 29 | +123 |
- #' @inheritParams split_cols_by_groups+ #' @note You can also specify a continuous variable in `rsp` and then use the |
||
| 30 | +124 |
- #'+ #' `response_definition` control to convert that internally to a logical |
||
| 31 | +125 |
- #' @return+ #' variable reflecting binary response. |
||
| 32 | +126 |
- #' * `s_odds_ratio()` returns a named list with the statistics `or_ci`+ #' |
||
| 33 | +127 |
- #' (containing `est`, `lcl`, and `ucl`) and `n_tot`.+ #' @seealso [h_logistic_mult_cont_df()] which is used internally. |
||
| 34 | +128 |
#' |
||
| 35 | +129 |
#' @examples |
||
| 36 | +130 |
- #' set.seed(12)+ #' library(dplyr) |
||
| 37 | +131 |
- #' dta <- data.frame(+ #' library(forcats) |
||
| 38 | +132 |
- #' rsp = sample(c(TRUE, FALSE), 100, TRUE),+ #' |
||
| 39 | +133 |
- #' grp = factor(rep(c("A", "B"), each = 50), levels = c("B", "A")),
+ #' adrs <- tern_ex_adrs |
||
| 40 | +134 |
- #' strata = factor(sample(c("C", "D"), 100, TRUE))
+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 41 | +135 |
- #' )+ #' |
||
| 42 | +136 |
- #'+ #' adrs_f <- adrs %>% |
||
| 43 | +137 |
- #' # Unstratified analysis.+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 44 | +138 |
- #' s_odds_ratio(+ #' mutate(rsp = AVALC == "CR") |
||
| 45 | +139 |
- #' df = subset(dta, grp == "A"),+ #' |
||
| 46 | +140 |
- #' .var = "rsp",+ #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`, |
||
| 47 | +141 |
- #' .ref_group = subset(dta, grp == "B"),+ #' # in logistic regression models with one covariate `RACE`. The subgroups |
||
| 48 | +142 |
- #' .in_ref_col = FALSE,+ #' # are defined by the levels of `BMRKR2`. |
||
| 49 | +143 |
- #' .df_row = dta+ #' df <- extract_rsp_biomarkers( |
||
| 50 | +144 |
- #' )+ #' variables = list( |
||
| 51 | +145 |
- #'+ #' rsp = "rsp", |
||
| 52 | +146 |
- #' # Stratified analysis.+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 53 | +147 |
- #' s_odds_ratio(+ #' covariates = "SEX", |
||
| 54 | +148 |
- #' df = subset(dta, grp == "A"),+ #' subgroups = "BMRKR2" |
||
| 55 | +149 |
- #' .var = "rsp",+ #' ), |
||
| 56 | +150 |
- #' .ref_group = subset(dta, grp == "B"),+ #' data = adrs_f |
||
| 57 | +151 |
- #' .in_ref_col = FALSE,+ #' ) |
||
| 58 | +152 |
- #' .df_row = dta,+ #' df |
||
| 59 | +153 |
- #' variables = list(arm = "grp", strata = "strata")+ #' |
||
| 60 | +154 |
- #' )+ #' # Here we group the levels of `BMRKR2` manually, and we add a stratification |
||
| 61 | +155 |
- #'+ #' # variable `STRATA1`. We also here use a continuous variable `EOSDY` |
||
| 62 | +156 |
- #' @export+ #' # which is then binarized internally (response is defined as this variable |
||
| 63 | +157 |
- s_odds_ratio <- function(df,+ #' # being larger than 500). |
||
| 64 | +158 |
- .var,+ #' df_grouped <- extract_rsp_biomarkers( |
||
| 65 | +159 |
- .ref_group,+ #' variables = list( |
||
| 66 | +160 |
- .in_ref_col,+ #' rsp = "EOSDY", |
||
| 67 | +161 |
- .df_row,+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 68 | +162 |
- variables = list(arm = NULL, strata = NULL),+ #' covariates = "SEX", |
||
| 69 | +163 |
- conf_level = 0.95,+ #' subgroups = "BMRKR2", |
||
| 70 | +164 |
- groups_list = NULL) {
+ #' strat = "STRATA1" |
||
| 71 | -65x | +|||
| 165 | +
- y <- list(or_ci = "", n_tot = "")+ #' ), |
|||
| 72 | +166 |
-
+ #' data = adrs_f, |
||
| 73 | -65x | +|||
| 167 | +
- if (!.in_ref_col) {
+ #' groups_lists = list( |
|||
| 74 | -65x | +|||
| 168 | +
- assert_proportion_value(conf_level)+ #' BMRKR2 = list( |
|||
| 75 | -65x | +|||
| 169 | +
- assert_df_with_variables(df, list(rsp = .var))+ #' "low" = "LOW", |
|||
| 76 | -65x | +|||
| 170 | +
- assert_df_with_variables(.ref_group, list(rsp = .var))+ #' "low/medium" = c("LOW", "MEDIUM"),
|
|||
| 77 | +171 |
-
+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 78 | -65x | +|||
| 172 | +
- if (is.null(variables$strata)) {
+ #' ) |
|||
| 79 | -52x | +|||
| 173 | +
- data <- data.frame(+ #' ), |
|||
| 80 | -52x | +|||
| 174 | +
- rsp = c(.ref_group[[.var]], df[[.var]]),+ #' control = control_logistic( |
|||
| 81 | -52x | +|||
| 175 | +
- grp = factor(+ #' response_definition = "I(response > 500)" |
|||
| 82 | -52x | +|||
| 176 | +
- rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
+ #' ) |
|||
| 83 | -52x | +|||
| 177 | +
- levels = c("ref", "Not-ref")
+ #' ) |
|||
| 84 | +178 |
- )+ #' df_grouped |
||
| 85 | +179 |
- )+ #' |
||
| 86 | -52x | +|||
| 180 | +
- y <- or_glm(data, conf_level = conf_level)+ #' @export |
|||
| 87 | +181 |
- } else {
+ extract_rsp_biomarkers <- function(variables, |
||
| 88 | -13x | +|||
| 182 | +
- assert_df_with_variables(.df_row, c(list(rsp = .var), variables))+ data, |
|||
| 89 | +183 |
-
+ groups_lists = list(), |
||
| 90 | +184 |
- # The group variable prepared for clogit must be synchronised with combination groups definition.+ control = control_logistic(), |
||
| 91 | -13x | +|||
| 185 | +
- if (is.null(groups_list)) {
+ label_all = "All Patients") {
|
|||
| 92 | -12x | +186 | +4x |
- ref_grp <- as.character(unique(.ref_group[[variables$arm]]))+ assert_list_of_variables(variables) |
| 93 | -12x | +187 | +4x |
- trt_grp <- as.character(unique(df[[variables$arm]]))+ checkmate::assert_string(variables$rsp) |
| 94 | -12x | +188 | +4x |
- grp <- stats::relevel(factor(.df_row[[variables$arm]]), ref = ref_grp)+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 95 | -+ | |||
| 189 | +4x |
- } else {
+ checkmate::assert_string(label_all) |
||
| 96 | +190 |
- # If more than one level in reference col.+ |
||
| 97 | -1x | +|||
| 191 | +
- reference <- as.character(unique(.ref_group[[variables$arm]]))+ # Start with all patients. |
|||
| 98 | -1x | +192 | +4x |
- grp_ref_flag <- vapply(+ result_all <- h_logistic_mult_cont_df( |
| 99 | -1x | +193 | +4x |
- X = groups_list,+ variables = variables, |
| 100 | -1x | +194 | +4x |
- FUN.VALUE = TRUE,+ data = data, |
| 101 | -1x | +195 | +4x |
- FUN = function(x) all(reference %in% x)+ control = control |
| 102 | +196 |
- )+ ) |
||
| 103 | -1x | +197 | +4x |
- ref_grp <- names(groups_list)[grp_ref_flag]+ result_all$subgroup <- label_all |
| 104 | -+ | |||
| 198 | +4x |
-
+ result_all$var <- "ALL" |
||
| 105 | -+ | |||
| 199 | +4x |
- # If more than one level in treatment col.+ result_all$var_label <- label_all |
||
| 106 | -1x | +200 | +4x |
- treatment <- as.character(unique(df[[variables$arm]]))+ result_all$row_type <- "content" |
| 107 | -1x | +201 | +4x |
- grp_trt_flag <- vapply(+ if (is.null(variables$subgroups)) {
|
| 108 | -1x | +|||
| 202 | +
- X = groups_list,+ # Only return result for all patients. |
|||
| 109 | +203 | 1x |
- FUN.VALUE = TRUE,+ result_all |
|
| 110 | -1x | +|||
| 204 | +
- FUN = function(x) all(treatment %in% x)+ } else {
|
|||
| 111 | +205 |
- )+ # Add subgroups results. |
||
| 112 | -1x | +206 | +3x |
- trt_grp <- names(groups_list)[grp_trt_flag]+ l_data <- h_split_by_subgroups( |
| 113 | -+ | |||
| 207 | +3x |
-
+ data, |
||
| 114 | -1x | +208 | +3x |
- grp <- combine_levels(.df_row[[variables$arm]], levels = reference, new_level = ref_grp)+ variables$subgroups, |
| 115 | -1x | +209 | +3x |
- grp <- combine_levels(grp, levels = treatment, new_level = trt_grp)+ groups_lists = groups_lists |
| 116 | +210 |
- }+ ) |
||
| 117 | -+ | |||
| 211 | +3x |
-
+ l_result <- lapply(l_data, function(grp) {
|
||
| 118 | -+ | |||
| 212 | +15x |
- # The reference level in `grp` must be the same as in the `rtables` column split.+ result <- h_logistic_mult_cont_df( |
||
| 119 | -13x | +213 | +15x |
- data <- data.frame(+ variables = variables, |
| 120 | -13x | +214 | +15x |
- rsp = .df_row[[.var]],+ data = grp$df, |
| 121 | -13x | +215 | +15x |
- grp = grp,+ control = control+ |
+
| 216 | ++ |
+ ) |
||
| 122 | -13x | +217 | +15x |
- strata = interaction(.df_row[variables$strata])+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ |
+
| 218 | +15x | +
+ cbind(result, result_labels) |
||
| 123 | +219 |
- )+ }) |
||
| 124 | -13x | +220 | +3x |
- y_all <- or_clogit(data, conf_level = conf_level)+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 125 | -13x | +221 | +3x |
- checkmate::assert_string(trt_grp)+ result_subgroups$row_type <- "analysis" |
| 126 | -13x | +222 | +3x |
- checkmate::assert_subset(trt_grp, names(y_all$or_ci))+ rbind( |
| 127 | -12x | +223 | +3x |
- y$or_ci <- y_all$or_ci[[trt_grp]]+ result_all, |
| 128 | -12x | +224 | +3x |
- y$n_tot <- y_all$n_tot+ result_subgroups |
| 129 | +225 |
- }+ ) |
||
| 130 | +226 |
} |
||
| 131 | +227 |
-
+ } |
||
| 132 | -64x | +
| 1 | +
- y$or_ci <- formatters::with_label(+ #' Count the Number of Patients with Particular Flags |
|||
| 133 | -64x | +|||
| 2 | +
- x = y$or_ci,+ #' |
|||
| 134 | -64x | +|||
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+ ||
| 4 | ++ |
+ #'+ |
+ ||
| 5 | ++ |
+ #' The primary analysis variable `.var` denotes the unique patient identifier.+ |
+ ||
| 6 | ++ |
+ #'+ |
+ ||
| 7 | +
- label = paste0("Odds Ratio (", 100 * conf_level, "% CI)")
+ #' @inheritParams argument_convention |
|||
| 135 | +8 |
- )+ #' |
||
| 136 | +9 |
-
+ #' @seealso [count_patients_with_event] |
||
| 137 | -64x | +|||
| 10 | +
- y$n_tot <- formatters::with_label(+ #' |
|||
| 138 | -64x | +|||
| 11 | +
- x = y$n_tot,+ #' @name count_patients_with_flags |
|||
| 139 | -64x | +|||
| 12 | +
- label = "Total n"+ NULL |
|||
| 140 | +13 |
- )+ |
||
| 141 | +14 |
-
+ #' @describeIn count_patients_with_flags Statistics function which counts the number of patients for which |
||
| 142 | -64x | +|||
| 15 | +
- y+ #' a particular flag variable is `TRUE`. |
|||
| 143 | +16 |
- }+ #' |
||
| 144 | +17 |
-
+ #' @inheritParams analyze_variables |
||
| 145 | +18 |
- #' @describeIn odds_ratio Formatted analysis function which is used as `afun` in `estimate_odds_ratio()`.+ #' @param .var (`character`)\cr name of the column that contains the unique identifier. |
||
| 146 | +19 |
- #'+ #' @param flag_variables (`character`)\cr a character vector specifying the names of `logical` |
||
| 147 | +20 |
- #' @return+ #' variables from analysis dataset used for counting the number of unique identifiers. |
||
| 148 | +21 |
- #' * `a_odds_ratio()` returns the corresponding list with formatted [rtables::CellValue()].+ #' @param flag_labels (`character`)\cr vector of labels to use for flag variables. |
||
| 149 | +22 |
#' |
||
| 150 | +23 |
- #' @examples+ #' @note If `flag_labels` is not specified, variables labels will be extracted from `df`. If variables are not |
||
| 151 | +24 |
- #' a_odds_ratio(+ #' labeled, variable names will be used instead. Alternatively, a named `vector` can be supplied to |
||
| 152 | +25 |
- #' df = subset(dta, grp == "A"),+ #' `flag_variables` such that within each name-value pair the name corresponds to the variable name and the value is |
||
| 153 | +26 |
- #' .var = "rsp",+ #' the label to use for this variable. |
||
| 154 | +27 |
- #' .ref_group = subset(dta, grp == "B"),+ #' |
||
| 155 | +28 |
- #' .in_ref_col = FALSE,+ #' @return |
||
| 156 | +29 |
- #' .df_row = dta+ #' * `s_count_patients_with_flags()` returns the count and the fraction of unique identifiers with each particular |
||
| 157 | +30 |
- #' )+ #' flag as a list of statistics `n`, `count`, `count_fraction`, and `n_blq`, with one element per flag. |
||
| 158 | +31 |
#' |
||
| 159 | +32 |
- #' @export+ #' @examples |
||
| 160 | +33 |
- a_odds_ratio <- make_afun(+ #' library(dplyr) |
||
| 161 | +34 |
- s_odds_ratio,+ #' |
||
| 162 | +35 |
- .formats = c(or_ci = "xx.xx (xx.xx - xx.xx)"),+ #' # `s_count_patients_with_flags()` |
||
| 163 | +36 |
- .indent_mods = c(or_ci = 1L)+ #' |
||
| 164 | +37 |
- )+ #' # Add labelled flag variables to analysis dataset. |
||
| 165 | +38 |
-
+ #' adae <- tern_ex_adae %>% |
||
| 166 | +39 |
- #' @describeIn odds_ratio Layout-creating function which can take statistics function arguments+ #' mutate( |
||
| 167 | +40 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' fl1 = TRUE, |
||
| 168 | +41 |
- #'+ #' fl2 = TRTEMFL == "Y", |
||
| 169 | +42 |
- #' @param ... arguments passed to `s_odds_ratio()`.+ #' fl3 = TRTEMFL == "Y" & AEOUT == "FATAL", |
||
| 170 | +43 |
- #'+ #' fl4 = TRTEMFL == "Y" & AEOUT == "FATAL" & AEREL == "Y" |
||
| 171 | +44 |
- #' @return+ #' ) |
||
| 172 | +45 |
- #' * `estimate_odds_ratio()` returns a layout object suitable for passing to further layouting functions,+ #' labels <- c( |
||
| 173 | +46 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' "fl1" = "Total AEs", |
||
| 174 | +47 |
- #' the statistics from `s_odds_ratio()` to the table layout.+ #' "fl2" = "Total number of patients with at least one adverse event", |
||
| 175 | +48 |
- #'+ #' "fl3" = "Total number of patients with fatal AEs", |
||
| 176 | +49 |
- #' @examples+ #' "fl4" = "Total number of patients with related fatal AEs" |
||
| 177 | +50 |
- #' dta <- data.frame(+ #' ) |
||
| 178 | +51 |
- #' rsp = sample(c(TRUE, FALSE), 100, TRUE),+ #' formatters::var_labels(adae)[names(labels)] <- labels |
||
| 179 | +52 |
- #' grp = factor(rep(c("A", "B"), each = 50))
+ #' |
||
| 180 | +53 |
- #' )+ #' s_count_patients_with_flags( |
||
| 181 | +54 |
- #'+ #' adae, |
||
| 182 | +55 |
- #' l <- basic_table() %>%+ #' "SUBJID", |
||
| 183 | +56 |
- #' split_cols_by(var = "grp", ref_group = "B") %>%+ #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
|
||
| 184 | +57 |
- #' estimate_odds_ratio(vars = "rsp")+ #' denom = "N_col", |
||
| 185 | +58 |
- #'+ #' .N_col = 1000 |
||
| 186 | +59 |
- #' build_table(l, df = dta)+ #' ) |
||
| 187 | +60 |
#' |
||
| 188 | +61 |
#' @export |
||
| 189 | +62 |
- estimate_odds_ratio <- function(lyt,+ s_count_patients_with_flags <- function(df, |
||
| 190 | +63 |
- vars,+ .var, |
||
| 191 | +64 |
- nested = TRUE,+ flag_variables, |
||
| 192 | +65 |
- ...,+ flag_labels = NULL, |
||
| 193 | +66 |
- show_labels = "hidden",+ .N_col, # nolint |
||
| 194 | +67 |
- table_names = vars,+ .N_row, # nolint |
||
| 195 | +68 |
- .stats = "or_ci",+ denom = c("n", "N_row", "N_col")) {
|
||
| 196 | -+ | |||
| 69 | +5x |
- .formats = NULL,+ checkmate::assert_character(flag_variables) |
||
| 197 | -+ | |||
| 70 | +5x |
- .labels = NULL,+ if (!is.null(flag_labels)) {
+ |
+ ||
| 71 | +! | +
+ checkmate::assert_character(flag_labels, len = length(flag_variables), any.missing = FALSE)+ |
+ ||
| 72 | +! | +
+ flag_names <- flag_labels |
||
| 198 | +73 |
- .indent_mods = NULL) {
+ } else {
|
||
| 199 | -3x | +74 | +5x |
- afun <- make_afun(+ if (is.null(names(flag_variables))) {
|
| 200 | -3x | +75 | +5x |
- a_odds_ratio,+ flag_names <- formatters::var_labels(df[flag_variables], fill = TRUE) |
| 201 | -3x | +|||
| 76 | +
- .stats = .stats,+ } else {
|
|||
| 202 | -3x | +|||
| 77 | +! |
- .formats = .formats,+ flag_names <- unname(flag_variables) |
||
| 203 | -3x | +|||
| 78 | +! |
- .labels = .labels,+ flag_variables <- names(flag_variables) |
||
| 204 | -3x | +|||
| 79 | +
- .indent_mods = .indent_mods+ } |
|||
| 205 | +80 |
- )+ } |
||
| 206 | +81 | |||
| 207 | -3x | +82 | +5x |
- analyze(+ checkmate::assert_subset(flag_variables, colnames(df)) |
| 208 | -3x | +83 | +5x |
- lyt,+ temp <- sapply(flag_variables, function(x) {
|
| 209 | -3x | +84 | +11x |
- vars,+ tmp <- Map(function(y) which(df[[y]]), x) |
| 210 | -3x | +85 | +11x |
- afun = afun,+ position_satisfy_flags <- Reduce(intersect, tmp) |
| 211 | -3x | +86 | +11x |
- nested = nested,+ id_satisfy_flags <- as.character(unique(df[position_satisfy_flags, ][[.var]])) |
| 212 | -3x | +87 | +11x |
- extra_args = list(...),+ s_count_values( |
| 213 | -3x | +88 | +11x |
- show_labels = show_labels,+ as.character(unique(df[[.var]])), |
| 214 | -3x | +89 | +11x |
- table_names = table_names+ id_satisfy_flags, |
| 215 | -+ | |||
| 90 | +11x |
- )+ denom = denom, |
||
| 216 | -+ | |||
| 91 | +11x |
- }+ .N_col = .N_col, |
||
| 217 | -+ | |||
| 92 | +11x |
-
+ .N_row = .N_row |
||
| 218 | +93 |
- #' Helper Functions for Odds Ratio Estimation+ ) |
||
| 219 | +94 |
- #'+ }) |
||
| 220 | -+ | |||
| 95 | +5x |
- #' @description `r lifecycle::badge("stable")`
+ colnames(temp) <- flag_names |
||
| 221 | -+ | |||
| 96 | +5x |
- #'+ temp <- data.frame(t(temp)) |
||
| 222 | -+ | |||
| 97 | +5x |
- #' Functions to calculate odds ratios in [estimate_odds_ratio()].+ result <- temp %>% as.list()+ |
+ ||
| 98 | +5x | +
+ if (length(flag_variables) == 1) {
+ |
+ ||
| 99 | +1x | +
+ for (i in 1:3) names(result[[i]]) <- flag_names[1] |
||
| 223 | +100 |
- #'+ }+ |
+ ||
| 101 | +5x | +
+ result |
||
| 224 | +102 |
- #' @inheritParams argument_convention+ } |
||
| 225 | +103 |
- #' @param data (`data.frame`)\cr data frame containing at least the variables `rsp` and `grp`, and optionally+ |
||
| 226 | +104 |
- #' `strata` for [or_clogit()].+ #' @describeIn count_patients_with_flags Formatted analysis function which is used as `afun` |
||
| 227 | +105 |
- #'+ #' in `count_patients_with_flags()`. |
||
| 228 | +106 |
- #' @return A named `list` of elements `or_ci` and `n_tot`.+ #' |
||
| 229 | +107 |
- #'+ #' @return |
||
| 230 | +108 |
- #' @seealso [odds_ratio]+ #' * `a_count_patients_with_flags()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 231 | +109 |
#' |
||
| 232 | +110 |
- #' @name h_odds_ratio+ #' @examples |
||
| 233 | +111 |
- NULL+ #' # We need to ungroup `count_fraction` first so that the `rtables` formatting |
||
| 234 | +112 |
-
+ #' # function `format_count_fraction()` can be applied correctly. |
||
| 235 | +113 |
- #' @describeIn h_odds_ratio Estimates the odds ratio based on [stats::glm()]. Note that there must be+ #' |
||
| 236 | +114 |
- #' exactly 2 groups in `data` as specified by the `grp` variable.+ #' # `a_count_patients_with_flags()` |
||
| 237 | +115 |
#' |
||
| 238 | +116 |
- #' @examples+ #' afun <- make_afun(a_count_patients_with_flags, |
||
| 239 | +117 |
- #' # Data with 2 groups.+ #' .stats = "count_fraction", |
||
| 240 | +118 |
- #' data <- data.frame(+ #' .ungroup_stats = "count_fraction" |
||
| 241 | +119 |
- #' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1)),+ #' ) |
||
| 242 | +120 |
- #' grp = letters[c(1, 1, 1, 2, 2, 2, 1, 2)],+ #' afun( |
||
| 243 | +121 |
- #' strata = letters[c(1, 2, 1, 2, 2, 2, 1, 2)],+ #' adae, |
||
| 244 | +122 |
- #' stringsAsFactors = TRUE+ #' .N_col = 10L, |
||
| 245 | +123 |
- #' )+ #' .N_row = 10L, |
||
| 246 | +124 |
- #'+ #' .var = "USUBJID", |
||
| 247 | +125 |
- #' # Odds ratio based on glm.+ #' flag_variables = c("fl1", "fl2", "fl3", "fl4")
|
||
| 248 | +126 |
- #' or_glm(data, conf_level = 0.95)+ #' ) |
||
| 249 | +127 |
#' |
||
| 250 | +128 |
#' @export |
||
| 251 | +129 |
- or_glm <- function(data, conf_level) {
- |
- ||
| 252 | -55x | -
- checkmate::assert_logical(data$rsp)+ a_count_patients_with_flags <- make_afun( |
||
| 253 | -55x | +|||
| 130 | +
- assert_proportion_value(conf_level)+ s_count_patients_with_flags, |
|||
| 254 | -55x | +|||
| 131 | +
- assert_df_with_variables(data, list(rsp = "rsp", grp = "grp"))+ .formats = c("count_fraction" = format_count_fraction_fixed_dp)
|
|||
| 255 | -55x | +|||
| 132 | +
- checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
+ ) |
|||
| 256 | +133 | |||
| 257 | -55x | -
- data$grp <- as_factor_keep_attributes(data$grp)- |
- ||
| 258 | -55x | +|||
| 134 | +
- assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2)+ #' @describeIn count_patients_with_flags Layout-creating function which can take statistics function |
|||
| 259 | -55x | +|||
| 135 | +
- formula <- stats::as.formula("rsp ~ grp")
+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 260 | -55x | +|||
| 136 | +
- model_fit <- stats::glm(+ #' |
|||
| 261 | -55x | +|||
| 137 | +
- formula = formula, data = data,+ #' @return |
|||
| 262 | -55x | +|||
| 138 | +
- family = stats::binomial(link = "logit")+ #' * `count_patients_with_flags()` returns a layout object suitable for passing to further layouting functions, |
|||
| 263 | +139 |
- )+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 264 | +140 |
-
+ #' the statistics from `s_count_patients_with_flags()` to the table layout. |
||
| 265 | +141 |
- # Note that here we need to discard the intercept.+ #' |
||
| 266 | -55x | +|||
| 142 | +
- or <- exp(stats::coef(model_fit)[-1])+ #' @examples |
|||
| 267 | -55x | +|||
| 143 | +
- or_ci <- exp(+ #' # `count_patients_with_flags()` |
|||
| 268 | -55x | +|||
| 144 | +
- stats::confint.default(model_fit, level = conf_level)[-1, , drop = FALSE]+ #' |
|||
| 269 | +145 |
- )+ #' lyt2 <- basic_table() %>% |
||
| 270 | +146 |
-
+ #' split_cols_by("ARM") %>%
|
||
| 271 | -55x | +|||
| 147 | +
- values <- stats::setNames(c(or, or_ci), c("est", "lcl", "ucl"))
+ #' add_colcounts() %>% |
|||
| 272 | -55x | +|||
| 148 | +
- n_tot <- stats::setNames(nrow(model_fit$model), "n_tot")+ #' count_patients_with_flags( |
|||
| 273 | +149 |
-
+ #' "SUBJID", |
||
| 274 | -55x | +|||
| 150 | +
- list(or_ci = values, n_tot = n_tot)+ #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
|
|||
| 275 | +151 |
- }+ #' denom = "N_col" |
||
| 276 | +152 |
-
+ #' ) |
||
| 277 | +153 |
- #' @describeIn h_odds_ratio estimates the odds ratio based on [survival::clogit()]. This is done for+ #' build_table(lyt2, adae, alt_counts_df = tern_ex_adsl) |
||
| 278 | +154 |
- #' the whole data set including all groups, since the results are not the same as when doing+ #' |
||
| 279 | +155 |
- #' pairwise comparisons between the groups.+ #' @export |
||
| 280 | +156 |
- #'+ count_patients_with_flags <- function(lyt, |
||
| 281 | +157 |
- #' @examples+ var, |
||
| 282 | +158 |
- #' # Data with 3 groups.+ var_labels = var, |
||
| 283 | +159 |
- #' data <- data.frame(+ show_labels = "hidden", |
||
| 284 | +160 |
- #' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0)),+ riskdiff = FALSE, |
||
| 285 | +161 |
- #' grp = letters[c(1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3)],+ na_str = NA_character_, |
||
| 286 | +162 |
- #' strata = LETTERS[c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)],+ nested = TRUE, |
||
| 287 | +163 |
- #' stringsAsFactors = TRUE+ ..., |
||
| 288 | +164 |
- #' )+ table_names = paste0("tbl_flags_", var),
|
||
| 289 | +165 |
- #'+ .stats = "count_fraction", |
||
| 290 | +166 |
- #' # Odds ratio based on stratified estimation by conditional logistic regression.+ .formats = NULL, |
||
| 291 | +167 |
- #' or_clogit(data, conf_level = 0.95)+ .indent_mods = NULL) {
|
||
| 292 | -+ | |||
| 168 | +6x |
- #'+ checkmate::assert_flag(riskdiff) |
||
| 293 | +169 |
- #' @export+ |
||
| 294 | -+ | |||
| 170 | +6x |
- or_clogit <- function(data, conf_level) {
+ afun <- make_afun( |
||
| 295 | -16x | +171 | +6x |
- checkmate::assert_logical(data$rsp)+ a_count_patients_with_flags, |
| 296 | -16x | +172 | +6x |
- assert_proportion_value(conf_level)+ .stats = .stats, |
| 297 | -16x | +173 | +6x |
- assert_df_with_variables(data, list(rsp = "rsp", grp = "grp", strata = "strata"))+ .formats = .formats, |
| 298 | -16x | +174 | +6x |
- checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
+ .indent_mods = .indent_mods, |
| 299 | -16x | +175 | +6x |
- checkmate::assert_multi_class(data$strata, classes = c("factor", "character"))
+ .ungroup_stats = .stats |
| 300 | +176 | ++ |
+ )+ |
+ |
| 177 | ||||
| 301 | -16x | +178 | +6x |
- data$grp <- as_factor_keep_attributes(data$grp)+ extra_args <- if (isFALSE(riskdiff)) {
|
| 302 | -16x | +179 | +5x |
- data$strata <- as_factor_keep_attributes(data$strata)+ list(...) |
| 303 | +180 |
-
+ } else {
|
||
| 304 | -+ | |||
| 181 | +1x |
- # Deviation from convention: `survival::strata` must be simply `strata`.+ list( |
||
| 305 | -16x | +182 | +1x |
- formula <- stats::as.formula("rsp ~ grp + strata(strata)")
+ afun = list("s_count_patients_with_flags" = afun),
|
| 306 | -16x | +183 | +1x |
- model_fit <- clogit_with_tryCatch(formula = formula, data = data)+ .stats = .stats,+ |
+
| 184 | +1x | +
+ .indent_mods = .indent_mods,+ |
+ ||
| 185 | +1x | +
+ s_args = list(...) |
||
| 307 | +186 |
-
+ ) |
||
| 308 | +187 |
- # Create a list with one set of OR estimates and CI per coefficient, i.e.+ } |
||
| 309 | +188 |
- # comparison of one group vs. the reference group.+ |
||
| 310 | -16x | +189 | +6x |
- coef_est <- stats::coef(model_fit)+ lyt <- analyze( |
| 311 | -16x | +190 | +6x |
- ci_est <- stats::confint(model_fit, level = conf_level)+ lyt = lyt, |
| 312 | -16x | +191 | +6x |
- or_ci <- list()+ vars = var, |
| 313 | -16x | +192 | +6x |
- for (coef_name in names(coef_est)) {
+ var_labels = var_labels, |
| 314 | -18x | +193 | +6x |
- grp_name <- gsub("^grp", "", x = coef_name)
+ show_labels = show_labels, |
| 315 | -18x | +194 | +6x |
- or_ci[[grp_name]] <- stats::setNames(+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff), |
| 316 | -18x | +195 | +6x |
- object = exp(c(coef_est[coef_name], ci_est[coef_name, , drop = TRUE])),+ table_names = table_names, |
| 317 | -18x | +196 | +6x |
- nm = c("est", "lcl", "ucl")
+ na_str = na_str,+ |
+
| 197 | +6x | +
+ nested = nested,+ |
+ ||
| 198 | +6x | +
+ extra_args = extra_args |
||
| 318 | +199 |
- )+ ) |
||
| 319 | +200 |
- }+ |
||
| 320 | -16x | +201 | +6x |
- list(or_ci = or_ci, n_tot = c(n_tot = model_fit$n))+ lyt |
| 321 | +202 |
}@@ -105324,14 +105541,14 @@ tern coverage - 94.83% |
| 1 |
- #' Tabulate Biomarker Effects on Binary Response by Subgroup+ #' Helper Function to create a new `SMQ` variable in `ADAE` by stacking `SMQ` and/or `CQ` records. |
|||
| 5 |
- #' Tabulate the estimated effects of multiple continuous biomarker variables+ #' Helper Function to create a new `SMQ` variable in `ADAE` that consists of all adverse events belonging to |
|||
| 6 |
- #' on a binary response endpoint across population subgroups.+ #' 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 |
- #' @inheritParams argument_convention+ #' done with [df_explicit_na()] to have the desired output. |
|||
| 9 |
- #' @param df (`data.frame`)\cr containing all analysis variables, as returned by+ #' |
|||
| 10 |
- #' [extract_rsp_biomarkers()].+ #' @inheritParams argument_convention |
|||
| 11 |
- #' @param vars (`character`)\cr the names of statistics to be reported among:+ #' @param baskets (`character`)\cr variable names of the selected Standardized/Customized queries. |
|||
| 12 |
- #' * `n_tot`: Total number of patients per group.+ #' @param smq_varlabel (`string`)\cr a label for the new variable created. |
|||
| 13 |
- #' * `n_rsp`: Total number of responses per group.+ #' @param keys (`character`)\cr names of the key variables to be returned along with the new variable created. |
|||
| 14 |
- #' * `prop`: Total response proportion per group.+ #' @param aag_summary (`data.frame`)\cr containing the `SMQ` baskets and the levels of interest for the final `SMQ` |
|||
| 15 |
- #' * `or`: Odds ratio.+ #' variable. This is useful when there are some levels of interest that are not observed in the `df` dataset. |
|||
| 16 |
- #' * `ci`: Confidence interval of odds ratio.+ #' The two columns of this dataset should be named `basket` and `basket_name`. |
|||
| 17 |
- #' * `pval`: p-value of the effect.+ #' |
|||
| 18 |
- #' Note, the statistics `n_tot`, `or` and `ci` are required.+ #' @return `data.frame` with variables in `keys` taken from `df` and new variable `SMQ` containing |
|||
| 19 |
- #'+ #' records belonging to the baskets selected via the `baskets` argument. |
|||
| 20 |
- #' @return An `rtables` table summarizing biomarker effects on binary response by subgroup.+ #' |
|||
| 21 |
- #'+ #' @examples |
|||
| 22 |
- #' @details These functions create a layout starting from a data frame which contains+ #' adae <- tern_ex_adae[1:20, ] %>% df_explicit_na() |
|||
| 23 |
- #' the required statistics. The tables are then typically used as input for forest plots.+ #' h_stack_by_baskets(df = adae) |
|||
| 25 |
- #' @note In contrast to [tabulate_rsp_subgroups()] this tabulation function does+ #' aag <- data.frame( |
|||
| 26 |
- #' not start from an input layout `lyt`. This is because internally the table is+ #' NAMVAR = c("CQ01NAM", "CQ02NAM", "SMQ01NAM", "SMQ02NAM"),
|
|||
| 27 |
- #' created by combining multiple subtables.+ #' 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 |
- #' @seealso [h_tab_rsp_one_biomarker()] which is used internally, [extract_rsp_biomarkers()].+ #' "C.1.1.1.3/B.2.2.3.1 AESI", "C.1.1.1.3/B.3.3.3.3 AESI" |
|||
| 30 |
- #'+ #' ), |
|||
| 31 |
- #' @examples+ #' SCOPE = c("", "", "BROAD", "BROAD"),
|
|||
| 32 |
- #' library(dplyr)+ #' stringsAsFactors = FALSE |
|||
| 33 |
- #' library(forcats)+ #' ) |
|||
| 35 |
- #' adrs <- tern_ex_adrs+ #' basket_name <- character(nrow(aag)) |
|||
| 36 |
- #' adrs_labels <- formatters::var_labels(adrs)+ #' cq_pos <- grep("^(CQ).+NAM$", aag$NAMVAR)
|
|||
| 37 |
- #'+ #' smq_pos <- grep("^(SMQ).+NAM$", aag$NAMVAR)
|
|||
| 38 |
- #' adrs_f <- adrs %>%+ #' basket_name[cq_pos] <- aag$REFNAME[cq_pos] |
|||
| 39 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' basket_name[smq_pos] <- paste0( |
|||
| 40 |
- #' mutate(rsp = AVALC == "CR")+ #' aag$REFNAME[smq_pos], "(", aag$SCOPE[smq_pos], ")"
|
|||
| 41 |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ #' ) |
|||
| 43 |
- #' df <- extract_rsp_biomarkers(+ #' aag_summary <- data.frame( |
|||
| 44 |
- #' variables = list(+ #' basket = aag$NAMVAR, |
|||
| 45 |
- #' rsp = "rsp",+ #' basket_name = basket_name, |
|||
| 46 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' stringsAsFactors = TRUE |
|||
| 47 |
- #' covariates = "SEX",+ #' ) |
|||
| 48 |
- #' subgroups = "BMRKR2"+ #' |
|||
| 49 |
- #' ),+ #' result <- h_stack_by_baskets(df = adae, aag_summary = aag_summary) |
|||
| 50 |
- #' data = adrs_f+ #' all(levels(aag_summary$basket_name) %in% levels(result$SMQ)) |
|||
| 51 |
- #' )+ #' |
|||
| 52 |
- #'+ #' h_stack_by_baskets( |
|||
| 53 |
- #' \donttest{
+ #' df = adae, |
|||
| 54 |
- #' ## Table with default columns.+ #' aag_summary = NULL, |
|||
| 55 |
- #' tabulate_rsp_biomarkers(df)+ #' keys = c("STUDYID", "USUBJID", "AEDECOD", "ARM"),
|
|||
| 56 |
- #'+ #' baskets = "SMQ01NAM" |
|||
| 57 |
- #' ## Table with a manually chosen set of columns: leave out "pval", reorder.+ #' ) |
|||
| 58 |
- #' tab <- tabulate_rsp_biomarkers(+ #' |
|||
| 59 |
- #' df = df,+ #' @export |
|||
| 60 |
- #' vars = c("n_rsp", "ci", "n_tot", "prop", "or")
+ h_stack_by_baskets <- function(df, |
|||
| 61 |
- #' )+ baskets = grep("^(SMQ|CQ).+NAM$", names(df), value = TRUE),
|
|||
| 62 |
- #'+ smq_varlabel = "Standardized MedDRA Query", |
|||
| 63 |
- #' ## Finally produce the forest plot.+ keys = c("STUDYID", "USUBJID", "ASTDTM", "AEDECOD", "AESEQ"),
|
|||
| 64 |
- #' g_forest(tab, xlim = c(0.7, 1.4))+ aag_summary = NULL, |
|||
| 65 |
- #' }+ na_level = lifecycle::deprecated(), |
|||
| 66 |
- #'+ na_str = "<Missing>") {
|
|||
| 67 | -+ | 5x |
- #' @export+ if (lifecycle::is_present(na_level)) {
|
|
| 68 | -+ | ! |
- #' @name response_biomarkers_subgroups+ lifecycle::deprecate_warn("0.9.1", "h_stack_by_baskets(na_level)", "h_stack_by_baskets(na_str)")
|
|
| 69 | -+ | ! |
- tabulate_rsp_biomarkers <- function(df,+ na_str <- na_level |
|
| 70 |
- vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
+ } |
|||
| 71 |
- .indent_mods = 0L) {
+
|
|||
| 72 | -3x | +5x |
- checkmate::assert_data_frame(df)+ smq_nam <- baskets[startsWith(baskets, "SMQ")] |
|
| 73 | -3x | +
- checkmate::assert_character(df$biomarker)+ # SC corresponding to NAM |
||
| 74 | -3x | +5x |
- checkmate::assert_character(df$biomarker_label)+ smq_sc <- gsub(pattern = "NAM", replacement = "SC", x = smq_nam, fixed = TRUE) |
|
| 75 | -3x | +5x |
- checkmate::assert_subset(vars, c("n_tot", "n_rsp", "prop", "or", "ci", "pval"))
+ smq <- stats::setNames(smq_sc, smq_nam) |
|
| 77 | -3x | +5x |
- df_subs <- split(df, f = df$biomarker)+ checkmate::assert_character(baskets) |
|
| 78 | -3x | +5x |
- tabs <- lapply(df_subs, FUN = function(df_sub) {
+ checkmate::assert_string(smq_varlabel) |
|
| 79 | 5x |
- tab_sub <- h_tab_rsp_one_biomarker(+ checkmate::assert_data_frame(df) |
||
| 80 | 5x |
- df = df_sub,+ checkmate::assert_true(all(startsWith(baskets, "SMQ") | startsWith(baskets, "CQ"))) |
||
| 81 | -5x | +4x |
- vars = vars,+ checkmate::assert_true(all(endsWith(baskets, "NAM"))) |
|
| 82 | -5x | +3x |
- .indent_mods = .indent_mods+ checkmate::assert_subset(baskets, names(df)) |
|
| 83 | -+ | 3x |
- )+ checkmate::assert_subset(keys, names(df)) |
|
| 84 | -+ | 3x |
- # Insert label row as first row in table.+ checkmate::assert_subset(smq_sc, names(df)) |
|
| 85 | -5x | +3x |
- label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1]+ checkmate::assert_string(na_str) |
|
| 86 | -5x | +
- tab_sub+ |
||
| 87 | -+ | 3x |
- })+ if (!is.null(aag_summary)) {
|
|
| 88 | -3x | +1x |
- result <- do.call(rbind, tabs)+ assert_df_with_variables( |
|
| 89 | -+ | 1x |
-
+ df = aag_summary, |
|
| 90 | -3x | +1x |
- n_id <- grep("n_tot", vars)
+ variables = list(val = c("basket", "basket_name"))
|
|
| 91 | -3x | +
- or_id <- match("or", vars)
+ ) |
||
| 92 | -3x | +
- ci_id <- match("ci", vars)
+ # Warning in case there is no match between `aag_summary$basket` and `baskets` argument. |
||
| 93 | -3x | +
- structure(+ # Honestly, I think those should completely match. Target baskets should be the same. |
||
| 94 | -3x | +1x |
- result,+ if (length(intersect(baskets, unique(aag_summary$basket))) == 0) {
|
|
| 95 | -3x | +! |
- forest_header = paste0(c("Lower", "Higher"), "\nBetter"),
+ warning("There are 0 baskets in common between aag_summary$basket and `baskets` argument.")
|
|
| 96 | -3x | +
- col_x = or_id,+ } |
||
| 97 | -3x | +
- col_ci = ci_id,+ } |
||
| 98 | -3x | +
- col_symbol_size = n_id+ |
||
| 99 | -+ | 3x |
- )+ var_labels <- c(formatters::var_labels(df[, keys]), "SMQ" = smq_varlabel) |
|
| 100 |
- }+ |
|||
| 101 |
-
+ # convert `na_str` records from baskets to NA for the later loop and from wide to long steps |
|||
| 102 | -+ | 3x |
- #' Prepares Response Data Estimates for Multiple Biomarkers in a Single Data Frame+ df[, c(baskets, smq_sc)][df[, c(baskets, smq_sc)] == na_str] <- NA |
|
| 103 |
- #'+ |
|||
| 104 | -+ | 3x |
- #' @description `r lifecycle::badge("stable")`
+ if (all(is.na(df[, baskets]))) { # in case there is no level for the target baskets
|
|
| 105 | -+ | 1x |
- #'+ df_long <- df[-seq_len(nrow(df)), keys] # we just need an empty dataframe keeping all factor levels |
|
| 106 |
- #' Prepares estimates for number of responses, patients and overall response rate,+ } else {
|
|||
| 107 |
- #' as well as odds ratio estimates, confidence intervals and p-values,+ # Concatenate SMQxxxNAM with corresponding SMQxxxSC |
|||
| 108 | -+ | 2x |
- #' for multiple biomarkers across population subgroups in a single data frame.+ df_cnct <- df[, c(keys, baskets[startsWith(baskets, "CQ")])] |
|
| 109 |
- #' `variables` corresponds to the names of variables found in `data`, passed as a+ |
|||
| 110 | -+ | 2x |
- #' named list and requires elements `rsp` and `biomarkers` (vector of continuous+ for (nam in names(smq)) {
|
|
| 111 | -+ | 4x |
- #' biomarker variables) and optionally `covariates`, `subgroups` and `strat`.+ sc <- smq[nam] # SMQxxxSC corresponding to SMQxxxNAM |
|
| 112 | -+ | 4x |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ nam_notna <- !is.na(df[[nam]]) |
|
| 113 | -+ | 4x |
- #'+ new_colname <- paste(nam, sc, sep = "_") |
|
| 114 | -+ | 4x |
- #' @inheritParams argument_convention+ df_cnct[nam_notna, new_colname] <- paste0(df[[nam]], "(", df[[sc]], ")")[nam_notna]
|
|
| 115 |
- #' @inheritParams response_subgroups+ } |
|||
| 116 |
- #' @param control (named `list`)\cr controls for the response definition and the+ |
|||
| 117 | -+ | 2x |
- #' confidence level produced by [control_logistic()].+ df_cnct$unique_id <- seq(1, nrow(df_cnct)) |
|
| 118 | -+ | 2x |
- #'+ var_cols <- names(df_cnct)[!(names(df_cnct) %in% c(keys, "unique_id"))] |
|
| 119 |
- #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_rsp`,+ # have to convert df_cnct from tibble to dataframe |
|||
| 120 |
- #' `prop`, `or`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`,+ # as it throws a warning otherwise about rownames. |
|||
| 121 |
- #' `var_label`, and `row_type`.+ # tibble do not support rownames and reshape creates rownames |
|||
| 122 |
- #'+ |
|||
| 123 | -+ | 2x |
- #' @note You can also specify a continuous variable in `rsp` and then use the+ df_long <- stats::reshape( |
|
| 124 | -+ | 2x |
- #' `response_definition` control to convert that internally to a logical+ data = as.data.frame(df_cnct), |
|
| 125 | -+ | 2x |
- #' variable reflecting binary response.+ varying = var_cols, |
|
| 126 | -+ | 2x |
- #'+ v.names = "SMQ", |
|
| 127 | -+ | 2x |
- #' @seealso [h_logistic_mult_cont_df()] which is used internally.+ idvar = names(df_cnct)[names(df_cnct) %in% c(keys, "unique_id")], |
|
| 128 | -+ | 2x |
- #'+ direction = "long", |
|
| 129 | -+ | 2x |
- #' @examples+ new.row.names = seq(prod(length(var_cols), nrow(df_cnct))) |
|
| 130 |
- #' library(dplyr)+ ) |
|||
| 131 |
- #' library(forcats)+ |
|||
| 132 | -+ | 2x |
- #'+ df_long <- df_long[!is.na(df_long[, "SMQ"]), !(names(df_long) %in% c("time", "unique_id"))]
|
|
| 133 | -+ | 2x |
- #' adrs <- tern_ex_adrs+ df_long$SMQ <- as.factor(df_long$SMQ) |
|
| 134 |
- #' adrs_labels <- formatters::var_labels(adrs)+ } |
|||
| 135 |
- #'+ |
|||
| 136 | -+ | 3x |
- #' adrs_f <- adrs %>%+ smq_levels <- setdiff(levels(df_long[["SMQ"]]), na_str) |
|
| 137 |
- #' filter(PARAMCD == "BESRSPI") %>%+ |
|||
| 138 | -+ | 3x |
- #' mutate(rsp = AVALC == "CR")+ if (!is.null(aag_summary)) {
|
|
| 139 |
- #'+ # A warning in case there is no match between df and aag_summary records |
|||
| 140 | -+ | 1x |
- #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`,+ if (length(intersect(smq_levels, unique(aag_summary$basket_name))) == 0) {
|
|
| 141 | -+ | 1x |
- #' # in logistic regression models with one covariate `RACE`. The subgroups+ warning("There are 0 basket levels in common between aag_summary$basket_name and df.")
|
|
| 142 |
- #' # are defined by the levels of `BMRKR2`.+ } |
|||
| 143 | -+ | 1x |
- #' df <- extract_rsp_biomarkers(+ df_long[["SMQ"]] <- factor( |
|
| 144 | -+ | 1x |
- #' variables = list(+ df_long[["SMQ"]], |
|
| 145 | -+ | 1x |
- #' rsp = "rsp",+ levels = sort( |
|
| 146 | -+ | 1x |
- #' biomarkers = c("BMRKR1", "AGE"),
+ c( |
|
| 147 | -+ | 1x |
- #' covariates = "SEX",+ smq_levels, |
|
| 148 | -+ | 1x |
- #' subgroups = "BMRKR2"+ setdiff(unique(aag_summary$basket_name), smq_levels) |
|
| 149 |
- #' ),+ ) |
|||
| 150 |
- #' data = adrs_f+ ) |
|||
| 151 |
- #' )+ ) |
|||
| 152 |
- #' df+ } else {
|
|||
| 153 | -+ | 2x |
- #'+ all_na_basket_flag <- vapply(df[, baskets], function(x) {
|
|
| 154 | -+ | 6x |
- #' # Here we group the levels of `BMRKR2` manually, and we add a stratification+ all(is.na(x)) |
|
| 155 | -+ | 2x |
- #' # variable `STRATA1`. We also here use a continuous variable `EOSDY`+ }, FUN.VALUE = logical(1)) |
|
| 156 | -+ | 2x |
- #' # which is then binarized internally (response is defined as this variable+ all_na_basket <- baskets[all_na_basket_flag] |
|
| 157 | - |
- #' # being larger than 500).- |
- ||
| 158 | -- |
- #' df_grouped <- extract_rsp_biomarkers(- |
- ||
| 159 | -- |
- #' variables = list(- |
- ||
| 160 | -- |
- #' rsp = "EOSDY",- |
- ||
| 161 | -- |
- #' biomarkers = c("BMRKR1", "AGE"),
- |
- ||
| 162 | -- |
- #' covariates = "SEX",- |
- ||
| 163 | -- |
- #' subgroups = "BMRKR2",- |
- ||
| 164 | -- |
- #' strat = "STRATA1"- |
- ||
| 165 | -- |
- #' ),- |
- ||
| 166 | -- |
- #' data = adrs_f,- |
- ||
| 167 | -- |
- #' groups_lists = list(- |
- ||
| 168 | -- |
- #' BMRKR2 = list(- |
- ||
| 169 | -- |
- #' "low" = "LOW",- |
- ||
| 170 | -- |
- #' "low/medium" = c("LOW", "MEDIUM"),
- |
- ||
| 171 | -- |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
- |
- ||
| 172 | -- |
- #' )- |
- ||
| 173 | -- |
- #' ),- |
- ||
| 174 | -- |
- #' control = control_logistic(- |
- ||
| 175 | -- |
- #' response_definition = "I(response > 500)"- |
- ||
| 176 | -- |
- #' )- |
- ||
| 177 | -- |
- #' )- |
- ||
| 178 | -- |
- #' df_grouped- |
- ||
| 179 | -- |
- #'- |
- ||
| 180 | -- |
- #' @export- |
- ||
| 181 | -- |
- extract_rsp_biomarkers <- function(variables,- |
- ||
| 182 | -- |
- data,- |
- ||
| 183 | -- |
- groups_lists = list(),- |
- ||
| 184 | -- |
- control = control_logistic(),- |
- ||
| 185 | -- |
- label_all = "All Patients") {
- |
- ||
| 186 | -4x | -
- assert_list_of_variables(variables)- |
- ||
| 187 | -4x | -
- checkmate::assert_string(variables$rsp)- |
- ||
| 188 | -4x | -
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)- |
- ||
| 189 | -4x | -
- checkmate::assert_string(label_all)- |
- ||
| 190 | -||||
| 191 | -- |
- # Start with all patients.- |
- ||
| 192 | -4x | -
- result_all <- h_logistic_mult_cont_df(- |
- ||
| 193 | -4x | -
- variables = variables,- |
- ||
| 194 | -4x | -
- data = data,- |
- ||
| 195 | -4x | -
- control = control- |
- ||
| 196 | -- |
- )- |
- ||
| 197 | -4x | -
- result_all$subgroup <- label_all- |
- ||
| 198 | -4x | -
- result_all$var <- "ALL"- |
- ||
| 199 | -4x | -
- result_all$var_label <- label_all- |
- ||
| 200 | -4x | -
- result_all$row_type <- "content"- |
- ||
| 201 | -4x | -
- if (is.null(variables$subgroups)) {
- |
- ||
| 202 | -- |
- # Only return result for all patients.- |
- ||
| 203 | -1x | -
- result_all- |
- ||
| 204 | -- |
- } else {
- |
- ||
| 205 | -- |
- # Add subgroups results.- |
- ||
| 206 | -3x | -
- l_data <- h_split_by_subgroups(- |
- ||
| 207 | -3x | +158 | +2x |
- data,+ df_long[["SMQ"]] <- factor( |
| 208 | -3x | +159 | +2x |
- variables$subgroups,+ df_long[["SMQ"]], |
| 209 | -3x | +160 | +2x |
- groups_lists = groups_lists+ levels = sort(c(smq_levels, all_na_basket)) |
| 210 | +161 |
) |
||
| 211 | -3x | -
- l_result <- lapply(l_data, function(grp) {
- |
- ||
| 212 | -15x | -
- result <- h_logistic_mult_cont_df(- |
- ||
| 213 | -15x | -
- variables = variables,- |
- ||
| 214 | -15x | -
- data = grp$df,- |
- ||
| 215 | -15x | -
- control = control- |
- ||
| 216 | -- |
- )- |
- ||
| 217 | -15x | -
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]- |
- ||
| 218 | -15x | -
- cbind(result, result_labels)- |
- ||
| 219 | +162 |
- })- |
- ||
| 220 | -3x | -
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))- |
- ||
| 221 | -3x | -
- result_subgroups$row_type <- "analysis"- |
- ||
| 222 | -3x | -
- rbind(+ } |
||
| 223 | +163 | 3x |
- result_all,+ formatters::var_labels(df_long) <- var_labels |
|
| 224 | +164 | 3x |
- result_subgroups- |
- |
| 225 | -- |
- )- |
- ||
| 226 | -- |
- }+ tibble::tibble(df_long) |
||
| 227 | +165 |
}@@ -106919,14 +106702,14 @@ tern coverage - 94.83% |
| 1 |
- #' Summary numeric variables in columns+ #' Proportion Difference |
||
| 3 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @description `r lifecycle::badge("stable")`
|
||
| 5 |
- #' Layout-creating function which can be used for creating column-wise summary tables.+ #' @inheritParams argument_convention |
||
| 6 |
- #' This function sets the analysis methods as column labels and is a wrapper for+ #' |
||
| 7 |
- #' [rtables::analyze_colvars()]. It was designed principally for PK tables.+ #' @seealso [d_proportion_diff()] |
||
| 9 |
- #' @inheritParams argument_convention+ #' @name prop_diff |
||
| 10 |
- #' @inheritParams rtables::analyze_colvars+ NULL |
||
| 11 |
- #' @param imp_rule (`character`)\cr imputation rule setting. Defaults to `NULL` for no imputation rule. Can+ |
||
| 12 |
- #' also be `"1/3"` to implement 1/3 imputation rule or `"1/2"` to implement 1/2 imputation rule. In order+ #' @describeIn prop_diff Statistics function estimating the difference |
||
| 13 |
- #' to use an imputation rule, the `avalcat_var` argument must be specified. See [imputation_rule()]+ #' in terms of responder proportion. |
||
| 14 |
- #' for more details on imputation.+ #' |
||
| 15 |
- #' @param avalcat_var (`character`)\cr if `imp_rule` is not `NULL`, name of variable that indicates whether a+ #' @inheritParams prop_diff_strat_nc |
||
| 16 |
- #' row in the data corresponds to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of+ #' @param method (`string`)\cr the method used for the confidence interval estimation. |
||
| 17 |
- #' the above (defaults to `"AVALCAT1"`). Variable must be present in the data and should match the variable+ #' |
||
| 18 |
- #' used to calculate the `n_blq` statistic (if included in `.stats`).+ #' @return |
||
| 19 |
- #' @param cache (`flag`)\cr whether to store computed values in a temporary caching environment. This will+ #' * `s_proportion_diff()` returns a named list of elements `diff` and `diff_ci`. |
||
| 20 |
- #' speed up calculations in large tables, but should be set to `FALSE` if the same `rtable` layout is+ #' |
||
| 21 |
- #' used for multiple tables with different data. Defaults to `FALSE`.+ #' @note When performing an unstratified analysis, methods `"cmh"`, `"strat_newcombe"`, and `"strat_newcombecc"` are |
||
| 22 |
- #' @param row_labels (`character`)\cr as this function works in columns space, usual `.labels`+ #' not permitted. |
||
| 23 |
- #' character vector applies on the column space. You can change the row labels by defining this+ #' |
||
| 24 |
- #' parameter to a named character vector with names corresponding to the split values. It defaults+ #' @examples |
||
| 25 |
- #' to `NULL` and if it contains only one `string`, it will duplicate that as a row label.+ #' # Summary |
||
| 26 |
- #' @param do_summarize_row_groups (`flag`)\cr defaults to `FALSE` and applies the analysis to the current+ #' |
||
| 27 |
- #' label rows. This is a wrapper of [rtables::summarize_row_groups()] and it can accept `labelstr`+ #' ## "Mid" case: 4/4 respond in group A, 1/2 respond in group B. |
||
| 28 |
- #' to define row labels. This behavior is not supported as we never need to overload row labels.+ #' nex <- 100 # Number of example rows |
||
| 29 |
- #' @param split_col_vars (`flag`)\cr defaults to `TRUE` and puts the analysis results onto the columns.+ #' dta <- data.frame( |
||
| 30 |
- #' This option allows you to add multiple instances of this functions, also in a nested fashion,+ #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE), |
||
| 31 |
- #' without adding more splits. This split must happen only one time on a single layout.+ #' "grp" = sample(c("A", "B"), nex, TRUE),
|
||
| 32 |
- #'+ #' "f1" = sample(c("a1", "a2"), nex, TRUE),
|
||
| 33 |
- #' @return+ #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
|
||
| 34 |
- #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()].+ #' stringsAsFactors = TRUE |
||
| 35 |
- #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output+ #' ) |
||
| 36 |
- #' in columns, and add it to the table layout.+ #' |
||
| 37 |
- #'+ #' s_proportion_diff( |
||
| 38 |
- #' @note This is an experimental implementation of [rtables::summarize_row_groups()] and+ #' df = subset(dta, grp == "A"), |
||
| 39 |
- #' [rtables::analyze_colvars()] that may be subjected to changes as `rtables` extends its+ #' .var = "rsp", |
||
| 40 |
- #' support to more complex analysis pipelines on the column space. For the same reasons,+ #' .ref_group = subset(dta, grp == "B"), |
||
| 41 |
- #' we encourage to read the examples carefully and file issues for cases that differ from+ #' .in_ref_col = FALSE, |
||
| 42 |
- #' them.+ #' conf_level = 0.90, |
||
| 43 |
- #'+ #' method = "ha" |
||
| 44 |
- #' Here `labelstr` behaves differently than usual. If it is not defined (default as `NULL`),+ #' ) |
||
| 45 |
- #' row labels are assigned automatically to the split values in case of `rtables::analyze_colvars`+ #' |
||
| 46 |
- #' (`do_summarize_row_groups = FALSE`, the default), and to the group label for+ #' # CMH example with strata |
||
| 47 |
- #' `do_summarize_row_groups = TRUE`.+ #' s_proportion_diff( |
||
| 48 |
- #'+ #' df = subset(dta, grp == "A"), |
||
| 49 |
- #' @seealso [analyze_vars()], [rtables::analyze_colvars()].+ #' .var = "rsp", |
||
| 50 |
- #'+ #' .ref_group = subset(dta, grp == "B"), |
||
| 51 |
- #' @examples+ #' .in_ref_col = FALSE, |
||
| 52 |
- #' library(dplyr)+ #' variables = list(strata = c("f1", "f2")),
|
||
| 53 |
- #'+ #' conf_level = 0.90, |
||
| 54 |
- #' # Data preparation+ #' method = "cmh" |
||
| 55 |
- #' adpp <- tern_ex_adpp %>% h_pkparam_sort()+ #' ) |
||
| 57 |
- #' lyt <- basic_table() %>%+ #' @export |
||
| 58 |
- #' split_rows_by(var = "STRATA1", label_pos = "topleft") %>%+ s_proportion_diff <- function(df, |
||
| 59 |
- #' split_rows_by(+ .var, |
||
| 60 |
- #' var = "SEX",+ .ref_group, |
||
| 61 |
- #' label_pos = "topleft",+ .in_ref_col, |
||
| 62 |
- #' child_label = "hidden"+ variables = list(strata = NULL), |
||
| 63 |
- #' ) %>% # Removes duplicated labels+ conf_level = 0.95, |
||
| 64 |
- #' analyze_vars_in_cols(vars = "AGE")+ method = c( |
||
| 65 |
- #' result <- build_table(lyt = lyt, df = adpp)+ "waldcc", "wald", "cmh", |
||
| 66 |
- #' result+ "ha", "newcombe", "newcombecc", |
||
| 67 |
- #'+ "strat_newcombe", "strat_newcombecc" |
||
| 68 |
- #' # By selecting just some statistics and ad-hoc labels+ ), |
||
| 69 |
- #' lyt <- basic_table() %>%+ weights_method = "cmh") {
|
||
| 70 | -+ | 2x |
- #' split_rows_by(var = "ARM", label_pos = "topleft") %>%+ method <- match.arg(method) |
| 71 | -+ | 2x |
- #' split_rows_by(+ if (is.null(variables$strata) && checkmate::test_subset(method, c("cmh", "strat_newcombe", "strat_newcombecc"))) {
|
| 72 | -+ | ! |
- #' var = "SEX",+ stop(paste( |
| 73 | -+ | ! |
- #' label_pos = "topleft",+ "When performing an unstratified analysis, methods 'cmh', 'strat_newcombe', and 'strat_newcombecc' are not", |
| 74 | -+ | ! |
- #' child_labels = "hidden",+ "permitted. Please choose a different method." |
| 75 |
- #' split_fun = drop_split_levels+ )) |
||
| 76 |
- #' ) %>%+ } |
||
| 77 | -+ | 2x |
- #' analyze_vars_in_cols(+ y <- list(diff = "", diff_ci = "") |
| 78 |
- #' vars = "AGE",+ |
||
| 79 | -+ | 2x |
- #' .stats = c("n", "cv", "geom_mean"),
+ if (!.in_ref_col) {
|
| 80 | -+ | 2x |
- #' .labels = c(+ rsp <- c(.ref_group[[.var]], df[[.var]]) |
| 81 | -+ | 2x |
- #' n = "aN",+ grp <- factor( |
| 82 | -+ | 2x |
- #' cv = "aCV",+ rep( |
| 83 | -+ | 2x |
- #' geom_mean = "aGeomMean"+ c("ref", "Not-ref"),
|
| 84 | -+ | 2x |
- #' )+ c(nrow(.ref_group), nrow(df)) |
| 85 |
- #' )+ ), |
||
| 86 | -+ | 2x |
- #' result <- build_table(lyt = lyt, df = adpp)+ levels = c("ref", "Not-ref")
|
| 87 |
- #' result+ ) |
||
| 88 |
- #'+ |
||
| 89 | -+ | 2x |
- #' # Changing row labels+ if (!is.null(variables$strata)) {
|
| 90 | -+ | 1x |
- #' lyt <- basic_table() %>%+ strata_colnames <- variables$strata |
| 91 | -+ | 1x |
- #' analyze_vars_in_cols(+ checkmate::assert_character(strata_colnames, null.ok = FALSE) |
| 92 | -+ | 1x |
- #' vars = "AGE",+ strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames) |
| 93 |
- #' row_labels = "some custom label"+ |
||
| 94 | -+ | 1x |
- #' )+ assert_df_with_variables(df, strata_vars) |
| 95 | -+ | 1x |
- #' result <- build_table(lyt, df = adpp)+ assert_df_with_variables(.ref_group, strata_vars) |
| 96 |
- #' result+ |
||
| 97 |
- #'+ # Merging interaction strata for reference group rows data and remaining |
||
| 98 | -+ | 1x |
- #' # Pharmacokinetic parameters+ strata <- c( |
| 99 | -+ | 1x |
- #' lyt <- basic_table() %>%+ interaction(.ref_group[strata_colnames]), |
| 100 | -+ | 1x |
- #' split_rows_by(+ interaction(df[strata_colnames]) |
| 101 |
- #' var = "TLG_DISPLAY",+ ) |
||
| 102 | -+ | 1x |
- #' split_label = "PK Parameter",+ strata <- as.factor(strata) |
| 103 |
- #' label_pos = "topleft",+ } |
||
| 104 |
- #' child_label = "hidden"+ |
||
| 105 |
- #' ) %>%+ # Defining the std way to calculate weights for strat_newcombe |
||
| 106 | -+ | 2x |
- #' analyze_vars_in_cols(+ if (!is.null(variables$weights_method)) {
|
| 107 | -+ | ! |
- #' vars = "AVAL"+ weights_method <- variables$weights_method |
| 108 |
- #' )+ } else {
|
||
| 109 | -+ | 2x |
- #' result <- build_table(lyt, df = adpp)+ weights_method <- "cmh" |
| 110 |
- #' result+ } |
||
| 111 |
- #'+ |
||
| 112 | -+ | 2x |
- #' # Multiple calls (summarize label and analyze underneath)+ y <- switch(method, |
| 113 | -+ | 2x |
- #' lyt <- basic_table() %>%+ "wald" = prop_diff_wald(rsp, grp, conf_level, correct = FALSE), |
| 114 | -+ | 2x |
- #' split_rows_by(+ "waldcc" = prop_diff_wald(rsp, grp, conf_level, correct = TRUE), |
| 115 | -+ | 2x |
- #' var = "TLG_DISPLAY",+ "ha" = prop_diff_ha(rsp, grp, conf_level), |
| 116 | -+ | 2x |
- #' split_label = "PK Parameter",+ "newcombe" = prop_diff_nc(rsp, grp, conf_level, correct = FALSE), |
| 117 | -+ | 2x |
- #' label_pos = "topleft"+ "newcombecc" = prop_diff_nc(rsp, grp, conf_level, correct = TRUE), |
| 118 | -+ | 2x |
- #' ) %>%+ "strat_newcombe" = prop_diff_strat_nc(rsp, |
| 119 | -+ | 2x |
- #' analyze_vars_in_cols(+ grp, |
| 120 | -+ | 2x |
- #' vars = "AVAL",+ strata, |
| 121 | -+ | 2x |
- #' do_summarize_row_groups = TRUE # does a summarize level+ weights_method, |
| 122 | -+ | 2x |
- #' ) %>%+ conf_level, |
| 123 | -+ | 2x |
- #' split_rows_by("SEX",
+ correct = FALSE |
| 124 |
- #' child_label = "hidden",+ ), |
||
| 125 | -+ | 2x |
- #' label_pos = "topleft"+ "strat_newcombecc" = prop_diff_strat_nc(rsp, |
| 126 | -+ | 2x |
- #' ) %>%+ grp, |
| 127 | -+ | 2x |
- #' analyze_vars_in_cols(+ strata, |
| 128 | -+ | 2x |
- #' vars = "AVAL",+ weights_method, |
| 129 | -+ | 2x |
- #' split_col_vars = FALSE # avoids re-splitting the columns+ conf_level, |
| 130 | -+ | 2x |
- #' )+ correct = TRUE |
| 131 |
- #' result <- build_table(lyt, df = adpp)+ ), |
||
| 132 | -+ | 2x |
- #' result+ "cmh" = prop_diff_cmh(rsp, grp, strata, conf_level)[c("diff", "diff_ci")]
|
| 133 |
- #'+ ) |
||
| 134 |
- #' @export+ |
||
| 135 | -+ | 2x |
- analyze_vars_in_cols <- function(lyt,+ y$diff <- y$diff * 100 |
| 136 | -+ | 2x |
- vars,+ y$diff_ci <- y$diff_ci * 100 |
| 137 |
- ...,+ } |
||
| 138 |
- .stats = c(+ |
||
| 139 | -+ | 2x |
- "n",+ attr(y$diff, "label") <- "Difference in Response rate (%)" |
| 140 | -+ | 2x |
- "mean",+ attr(y$diff_ci, "label") <- d_proportion_diff( |
| 141 | -+ | 2x |
- "sd",+ conf_level, method, |
| 142 | -+ | 2x |
- "se",+ long = FALSE |
| 143 |
- "cv",+ ) |
||
| 144 |
- "geom_cv"+ |
||
| 145 | -+ | 2x |
- ),+ y |
| 146 |
- .labels = c(+ } |
||
| 147 |
- n = "n",+ |
||
| 148 |
- mean = "Mean",+ #' @describeIn prop_diff Formatted analysis function which is used as `afun` in `estimate_proportion_diff()`. |
||
| 149 |
- sd = "SD",+ #' |
||
| 150 |
- se = "SE",+ #' @return |
||
| 151 |
- cv = "CV (%)",+ #' * `a_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 152 |
- geom_cv = "CV % Geometric Mean"+ #' |
||
| 153 |
- ),+ #' @examples |
||
| 154 |
- row_labels = NULL,+ #' a_proportion_diff( |
||
| 155 |
- do_summarize_row_groups = FALSE,+ #' df = subset(dta, grp == "A"), |
||
| 156 |
- split_col_vars = TRUE,+ #' .var = "rsp", |
||
| 157 |
- imp_rule = NULL,+ #' .ref_group = subset(dta, grp == "B"), |
||
| 158 |
- avalcat_var = "AVALCAT1",+ #' .in_ref_col = FALSE, |
||
| 159 |
- cache = FALSE,+ #' conf_level = 0.90, |
||
| 160 |
- .indent_mods = NULL,+ #' method = "ha" |
||
| 161 |
- nested = TRUE,+ #' ) |
||
| 162 |
- na_level = NULL,+ #' |
||
| 163 |
- .formats = NULL,+ #' @export |
||
| 164 |
- .aligns = NULL) {
+ a_proportion_diff <- make_afun( |
||
| 165 | -10x | +
- checkmate::assert_string(na_level, null.ok = TRUE)+ s_proportion_diff, |
|
| 166 | -10x | +
- checkmate::assert_character(row_labels, null.ok = TRUE)+ .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"), |
|
| 167 | -10x | +
- checkmate::assert_int(.indent_mods, null.ok = TRUE)+ .indent_mods = c(diff = 0L, diff_ci = 1L) |
|
| 168 | -10x | +
- checkmate::assert_flag(nested)+ ) |
|
| 169 | -10x | +
- checkmate::assert_flag(split_col_vars)+ |
|
| 170 | -10x | +
- checkmate::assert_flag(do_summarize_row_groups)+ #' @describeIn prop_diff Layout-creating function which can take statistics function arguments |
|
| 171 |
-
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 172 |
- # Filtering+ #' |
||
| 173 | -10x | +
- met_grps <- paste0("analyze_vars", c("_numeric", "_counts"))
+ #' @param ... arguments passed to `s_proportion_diff()`. |
|
| 174 | -10x | +
- .stats <- get_stats(met_grps, stats_in = .stats)+ #' |
|
| 175 | -10x | +
- formats_v <- get_formats_from_stats(stats = .stats, formats_in = .formats)+ #' @return |
|
| 176 | -10x | +
- labels_v <- get_labels_from_stats(stats = .stats, labels_in = .labels)+ #' * `estimate_proportion_diff()` returns a layout object suitable for passing to further layouting functions, |
|
| 177 |
-
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 178 |
- # Check for vars in the case that one or more are used+ #' the statistics from `s_proportion_diff()` to the table layout. |
||
| 179 | -10x | +
- if (length(vars) == 1) {
+ #' |
|
| 180 | -7x | +
- vars <- rep(vars, length(.stats))+ #' @examples |
|
| 181 | -3x | +
- } else if (length(vars) != length(.stats)) {
+ #' l <- basic_table() %>% |
|
| 182 | -1x | +
- stop(+ #' split_cols_by(var = "grp", ref_group = "B") %>% |
|
| 183 | -1x | +
- "Analyzed variables (vars) does not have the same ",+ #' estimate_proportion_diff( |
|
| 184 | -1x | +
- "number of elements of specified statistics (.stats)."+ #' vars = "rsp", |
|
| 185 |
- )+ #' conf_level = 0.90, |
||
| 186 |
- }+ #' method = "ha" |
||
| 187 |
-
+ #' ) |
||
| 188 | -9x | +
- if (split_col_vars) {
+ #' |
|
| 189 |
- # Checking there is not a previous identical column split+ #' build_table(l, df = dta) |
||
| 190 | -8x | +
- clyt <- tail(clayout(lyt), 1)[[1]]+ #' |
|
| 191 |
-
+ #' @export |
||
| 192 | -8x | +
- dummy_lyt <- split_cols_by_multivar(+ estimate_proportion_diff <- function(lyt, |
|
| 193 | -8x | +
- lyt = basic_table(),+ vars, |
|
| 194 | -8x | +
- vars = vars,+ na_str = NA_character_, |
|
| 195 | -8x | +
- varlabels = labels_v+ nested = TRUE, |
|
| 196 |
- )+ ..., |
||
| 197 |
-
+ var_labels = vars, |
||
| 198 | -8x | +
- if (any(sapply(clyt, identical, y = get_last_col_split(dummy_lyt)))) {
+ show_labels = "hidden", |
|
| 199 | -! | +
- stop(+ table_names = vars, |
|
| 200 | -! | +
- "Column split called again with the same values. ",+ .stats = NULL, |
|
| 201 | -! | +
- "This can create many unwanted columns. Please consider adding ",+ .formats = NULL, |
|
| 202 | -! | +
- "split_col_vars = FALSE to the last call of ",+ .labels = NULL, |
|
| 203 | -! | +
- deparse(sys.calls()[[sys.nframe() - 1]]), "."+ .indent_mods = NULL) {
|
|
| 204 | -+ | 3x |
- )+ afun <- make_afun( |
| 205 | -+ | 3x |
- }+ a_proportion_diff, |
| 206 | -+ | 3x |
-
+ .stats = .stats, |
| 207 | -+ | 3x |
- # Main col split+ .formats = .formats, |
| 208 | -8x | +3x |
- lyt <- split_cols_by_multivar(+ .labels = .labels, |
| 209 | -8x | +3x |
- lyt = lyt,+ .indent_mods = .indent_mods |
| 210 | -8x | +
- vars = vars,+ ) |
|
| 211 | -8x | +
- varlabels = labels_v+ |
|
| 212 | -+ | 3x |
- )+ analyze( |
| 213 | -+ | 3x |
- }+ lyt, |
| 214 | -+ | 3x |
-
+ vars, |
| 215 | -9x | +3x |
- env <- new.env() # create caching environment+ afun = afun, |
| 216 | -+ | 3x |
-
+ var_labels = var_labels, |
| 217 | -9x | +3x |
- if (do_summarize_row_groups) {
+ na_str = na_str, |
| 218 | -2x | +3x |
- if (length(unique(vars)) > 1) {
+ nested = nested, |
| 219 | -! | +3x |
- stop("When using do_summarize_row_groups only one label level var should be inserted.")
+ extra_args = list(...), |
| 220 | -+ | 3x |
- }+ show_labels = show_labels, |
| 221 | -+ | 3x |
-
+ table_names = table_names |
| 222 |
- # Function list for do_summarize_row_groups. Slightly different handling of labels+ ) |
||
| 223 | -2x | +
- cfun_list <- Map(+ } |
|
| 224 | -2x | +
- function(stat, use_cache, cache_env) {
+
|
|
| 225 | -12x | +
- function(u, .spl_context, labelstr, .df_row, ...) {
+ #' Check: Proportion Difference Arguments |
|
| 226 |
- # Statistic+ #' |
||
| 227 | -24x | +
- var_row_val <- paste(+ #' Verifies that and/or convert arguments into valid values to be used in the |
|
| 228 | -24x | +
- gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
+ #' estimation of difference in responder proportions. |
|
| 229 | -24x | +
- paste(.spl_context$value, collapse = "_"),+ #' |
|
| 230 | -24x | +
- sep = "_"+ #' @inheritParams prop_diff |
|
| 231 |
- )+ #' @inheritParams prop_diff_wald |
||
| 232 | -24x | +
- if (use_cache) {
+ #' |
|
| 233 | -! | +
- if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...)+ #' @keywords internal |
|
| 234 | -! | +
- x_stats <- cache_env[[var_row_val]]+ check_diff_prop_ci <- function(rsp, |
|
| 235 |
- } else {
+ grp, |
||
| 236 | -24x | +
- x_stats <- s_summary(u, ...)+ strata = NULL, |
|
| 237 |
- }+ conf_level, |
||
| 238 |
-
+ correct = NULL) {
|
||
| 239 | -24x | +17x |
- if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
+ checkmate::assert_logical(rsp, any.missing = FALSE) |
| 240 | -24x | +17x |
- res <- x_stats[[stat]]+ checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) |
| 241 | -+ | 17x |
- } else {
+ checkmate::assert_number(conf_level, lower = 0, upper = 1) |
| 242 | -! | +17x |
- res_imp <- imputation_rule(+ checkmate::assert_flag(correct, null.ok = TRUE) |
| 243 | -! | +
- .df_row, x_stats, stat,+ |
|
| 244 | -! | +17x |
- imp_rule = imp_rule, post = as.numeric(tail(.spl_context$value, 1)) > 0, avalcat_var = avalcat_var+ if (!is.null(strata)) {
|
| 245 | -+ | 11x |
- )+ checkmate::assert_factor(strata, len = length(rsp)) |
| 246 | -! | +
- res <- res_imp[["val"]]+ } |
|
| 247 | -! | +
- na_level <- res_imp[["na_level"]]+ |
|
| 248 | -+ | 17x |
- }+ invisible() |
| 249 |
-
+ } |
||
| 250 |
- # Label check and replacement+ |
||
| 251 | -24x | +
- if (length(row_labels) > 1) {
+ #' Description of Method Used for Proportion Comparison |
|
| 252 | -12x | +
- if (!(labelstr %in% names(row_labels))) {
+ #' |
|
| 253 | -! | +
- stop(+ #' @description `r lifecycle::badge("stable")`
|
|
| 254 | -! | +
- "Replacing the labels in do_summarize_row_groups needs a named vector",+ #' |
|
| 255 | -! | +
- "that contains the split values. In the current split variable ",+ #' This is an auxiliary function that describes the analysis in |
|
| 256 | -! | +
- .spl_context$split[nrow(.spl_context)],+ #' `s_proportion_diff`. |
|
| 257 | -! | +
- " the labelstr value (split value by default) ", labelstr, " is not in",+ #' |
|
| 258 | -! | +
- " row_labels names: ", names(row_labels)+ #' @inheritParams s_proportion_diff |
|
| 259 |
- )+ #' @param long (`logical`)\cr Whether a long or a short (default) description is required. |
||
| 260 |
- }+ #' |
||
| 261 | -12x | +
- lbl <- unlist(row_labels[labelstr])+ #' @return A `string` describing the analysis. |
|
| 262 |
- } else {
+ #' |
||
| 263 | -12x | +
- lbl <- labelstr+ #' @seealso [prop_diff] |
|
| 264 |
- }+ #' |
||
| 265 |
-
+ #' @export |
||
| 266 |
- # Cell creation+ d_proportion_diff <- function(conf_level, |
||
| 267 | -24x | +
- rcell(res,+ method, |
|
| 268 | -24x | +
- label = lbl,+ long = FALSE) {
|
|
| 269 | -24x | +8x |
- format = formats_v[names(formats_v) == stat][[1]],+ label <- paste0(conf_level * 100, "% CI") |
| 270 | -24x | +8x |
- format_na_str = na_level,+ if (long) {
|
| 271 | -24x | +! |
- indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods),+ label <- paste( |
| 272 | -24x | +! |
- align = .aligns+ label, |
| 273 | -+ | ! |
- )+ ifelse( |
| 274 | -+ | ! |
- }+ method == "cmh", |
| 275 | -+ | ! |
- },+ "for adjusted difference", |
| 276 | -2x | +! |
- stat = .stats,+ "for difference" |
| 277 | -2x | +
- use_cache = cache,+ ) |
|
| 278 | -2x | +
- cache_env = replicate(length(.stats), env)+ ) |
|
| 279 |
- )+ } |
||
| 281 | -+ | 8x |
- # Main call to rtables+ method_part <- switch(method, |
| 282 | -2x | +8x |
- summarize_row_groups(+ "cmh" = "CMH, without correction", |
| 283 | -2x | +8x |
- lyt = lyt,+ "waldcc" = "Wald, with correction", |
| 284 | -2x | +8x |
- var = unique(vars),+ "wald" = "Wald, without correction", |
| 285 | -2x | +8x |
- cfun = cfun_list,+ "ha" = "Anderson-Hauck", |
| 286 | -2x | +8x |
- extra_args = list(...)+ "newcombe" = "Newcombe, without correction", |
| 287 | -+ | 8x |
- )+ "newcombecc" = "Newcombe, with correction", |
| 288 | -+ | 8x |
- } else {
+ "strat_newcombe" = "Stratified Newcombe, without correction", |
| 289 | -+ | 8x |
- # Function list for analyze_colvars+ "strat_newcombecc" = "Stratified Newcombe, with correction", |
| 290 | -7x | +8x |
- afun_list <- Map(+ stop(paste(method, "does not have a description")) |
| 291 | -7x | +
- function(stat, use_cache, cache_env) {
+ ) |
|
| 292 | -32x | +8x |
- function(u, .spl_context, .df_row, ...) {
+ paste0(label, " (", method_part, ")")
|
| 293 |
- # Main statistics+ } |
||
| 294 | -210x | +
- var_row_val <- paste(+ |
|
| 295 | -210x | +
- gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
+ #' Helper Functions to Calculate Proportion Difference |
|
| 296 | -210x | +
- paste(.spl_context$value, collapse = "_"),+ #' |
|
| 297 | -210x | +
- sep = "_"+ #' @description `r lifecycle::badge("stable")`
|
|
| 298 |
- )+ #' |
||
| 299 | -210x | +
- if (use_cache) {
+ #' @inheritParams argument_convention |
|
| 300 | -16x | +
- if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...)+ #' @inheritParams prop_diff |
|
| 301 | -56x | +
- x_stats <- cache_env[[var_row_val]]+ #' @param grp (`factor`)\cr vector assigning observations to one out of two groups |
|
| 302 |
- } else {
+ #' (e.g. reference and treatment group). |
||
| 303 | -154x | +
- x_stats <- s_summary(u, ...)+ #' |
|
| 304 |
- }+ #' @return A named `list` of elements `diff` (proportion difference) and `diff_ci` |
||
| 305 |
-
+ #' (proportion difference confidence interval). |
||
| 306 | -210x | +
- if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
+ #' |
|
| 307 | -170x | +
- res <- x_stats[[stat]]+ #' @seealso [prop_diff()] for implementation of these helper functions. |
|
| 308 |
- } else {
+ #' |
||
| 309 | -40x | +
- res_imp <- imputation_rule(+ #' @name h_prop_diff |
|
| 310 | -40x | +
- .df_row, x_stats, stat,+ NULL |
|
| 311 | -40x | +
- imp_rule = imp_rule, post = as.numeric(tail(.spl_context$value, 1)) > 0, avalcat_var = avalcat_var+ |
|
| 312 |
- )+ #' @describeIn h_prop_diff The Wald interval follows the usual textbook |
||
| 313 | -40x | +
- res <- res_imp[["val"]]+ #' definition for a single proportion confidence interval using the normal |
|
| 314 | -40x | +
- na_level <- res_imp[["na_level"]]+ #' approximation. It is possible to include a continuity correction for Wald's |
|
| 315 |
- }+ #' interval. |
||
| 316 |
-
+ #' |
||
| 317 | -210x | +
- if (is.list(res)) {
+ #' @param correct (`logical`)\cr whether to include the continuity correction. For further |
|
| 318 | -19x | +
- if (length(res) > 1) {
+ #' information, see [stats::prop.test()]. |
|
| 319 | -1x | +
- stop("The analyzed column produced more than one category of results.")
+ #' |
|
| 320 |
- } else {
+ #' @examples |
||
| 321 | -18x | +
- res <- unlist(res)+ #' # Wald confidence interval |
|
| 322 |
- }+ #' set.seed(2) |
||
| 323 |
- }+ #' rsp <- sample(c(TRUE, FALSE), replace = TRUE, size = 20) |
||
| 324 |
-
+ #' grp <- factor(c(rep("A", 10), rep("B", 10)))
|
||
| 325 |
- # Label from context+ #' prop_diff_wald(rsp = rsp, grp = grp, conf_level = 0.95, correct = FALSE) |
||
| 326 | -209x | +
- label_from_context <- .spl_context$value[nrow(.spl_context)]+ #' |
|
| 327 |
-
+ #' @export |
||
| 328 |
- # Label switcher+ prop_diff_wald <- function(rsp, |
||
| 329 | -209x | +
- if (is.null(row_labels)) {
+ grp, |
|
| 330 | -149x | +
- lbl <- label_from_context+ conf_level = 0.95, |
|
| 331 |
- } else {
+ correct = FALSE) {
|
||
| 332 | -60x | +2x |
- if (length(row_labels) > 1) {
+ if (isTRUE(correct)) {
|
| 333 | -48x | +1x |
- if (!(label_from_context %in% names(row_labels))) {
+ mthd <- "waldcc" |
| 334 | -! | +
- stop(+ } else {
|
|
| 335 | -! | +1x |
- "Replacing the labels in do_summarize_row_groups needs a named vector",+ mthd <- "wald" |
| 336 | -! | +
- "that contains the split values. In the current split variable ",+ } |
|
| 337 | -! | +2x |
- .spl_context$split[nrow(.spl_context)],+ grp <- as_factor_keep_attributes(grp) |
| 338 | -! | +2x |
- " the split value ", label_from_context, " is not in",+ check_diff_prop_ci( |
| 339 | -! | +2x |
- " row_labels names: ", names(row_labels)+ rsp = rsp, grp = grp, conf_level = conf_level, correct = correct |
| 340 |
- )+ ) |
||
| 341 |
- }+ |
||
| 342 | -48x | +
- lbl <- unlist(row_labels[label_from_context])+ # check if binary response is coded as logical |
|
| 343 | -+ | 2x |
- } else {
+ checkmate::assert_logical(rsp, any.missing = FALSE) |
| 344 | -12x | +2x |
- lbl <- row_labels+ checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) |
| 345 |
- }+ |
||
| 346 | -+ | 2x |
- }+ tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE))) |
| 347 |
-
+ # x1 and n1 are non-reference groups. |
||
| 348 | -+ | 2x |
- # Cell creation+ diff_ci <- desctools_binom( |
| 349 | -209x | +2x |
- rcell(res,+ x1 = tbl[2], n1 = sum(tbl[2], tbl[4]), |
| 350 | -209x | +2x |
- label = lbl,+ x2 = tbl[1], n2 = sum(tbl[1], tbl[3]), |
| 351 | -209x | +2x |
- format = formats_v[names(formats_v) == stat][[1]],+ conf.level = conf_level, |
| 352 | -209x | +2x |
- format_na_str = na_level,+ method = mthd |
| 353 | -209x | +
- indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods),+ ) |
|
| 354 | -209x | +
- align = .aligns+ |
|
| 355 | -+ | 2x |
- )+ list( |
| 356 | -+ | 2x |
- }+ "diff" = unname(diff_ci[, "est"]), |
| 357 | -+ | 2x |
- },+ "diff_ci" = unname(diff_ci[, c("lwr.ci", "upr.ci")])
|
| 358 | -7x | +
- stat = .stats,+ ) |
|
| 359 | -7x | +
- use_cache = cache,+ } |
|
| 360 | -7x | +
- cache_env = replicate(length(.stats), env)+ |
|
| 361 |
- )+ #' @describeIn h_prop_diff Anderson-Hauck confidence interval. |
||
| 362 |
-
+ #' |
||
| 363 |
- # Main call to rtables+ #' @examples |
||
| 364 | -7x | +
- analyze_colvars(lyt,+ #' # Anderson-Hauck confidence interval |
|
| 365 | -7x | +
- afun = afun_list,+ #' ## "Mid" case: 3/4 respond in group A, 1/2 respond in group B. |
|
| 366 | -7x | +
- nested = nested,+ #' rsp <- c(TRUE, FALSE, FALSE, TRUE, TRUE, TRUE) |
|
| 367 | -7x | +
- extra_args = list(...)+ #' grp <- factor(c("A", "B", "A", "B", "A", "A"), levels = c("B", "A"))
|
|
| 368 |
- )+ #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.90) |
||
| 369 |
- }+ #' |
||
| 370 |
- }+ #' ## Edge case: Same proportion of response in A and B. |
||
| 371 |
-
+ #' rsp <- c(TRUE, FALSE, TRUE, FALSE) |
||
| 372 |
- # Help function+ #' grp <- factor(c("A", "A", "B", "B"), levels = c("A", "B"))
|
||
| 373 |
- get_last_col_split <- function(lyt) {
+ #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.6) |
||
| 374 | -1x | +
- tail(tail(clayout(lyt), 1)[[1]], 1)[[1]]+ #' |
|
| 375 |
- }+ #' @export |
| 1 | +376 |
- #' Control Function for Subgroup Treatment Effect Pattern (STEP) Calculations+ prop_diff_ha <- function(rsp, |
||
| 2 | +377 |
- #'+ grp, |
||
| 3 | +378 |
- #' @description `r lifecycle::badge("stable")`
+ conf_level) {
|
||
| 4 | -+ | |||
| 379 | +3x |
- #'+ grp <- as_factor_keep_attributes(grp) |
||
| 5 | -+ | |||
| 380 | +3x |
- #' This is an auxiliary function for controlling arguments for STEP calculations.+ check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level) |
||
| 6 | +381 |
- #'+ |
||
| 7 | -+ | |||
| 382 | +3x |
- #' @param biomarker (`numeric` or `NULL`)\cr optional provision of the numeric biomarker variable, which+ tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE))) |
||
| 8 | +383 |
- #' could be used to infer `bandwidth`, see below.+ # x1 and n1 are non-reference groups. |
||
| 9 | -+ | |||
| 384 | +3x |
- #' @param use_percentile (`flag`)\cr if `TRUE`, the running windows are created according to+ ci <- desctools_binom( |
||
| 10 | -+ | |||
| 385 | +3x |
- #' quantiles rather than actual values, i.e. the bandwidth refers to the percentage of data+ x1 = tbl[2], n1 = sum(tbl[2], tbl[4]), |
||
| 11 | -+ | |||
| 386 | +3x |
- #' covered in each window. Suggest `TRUE` if the biomarker variable is not uniformly+ x2 = tbl[1], n2 = sum(tbl[1], tbl[3]), |
||
| 12 | -+ | |||
| 387 | +3x |
- #' distributed.+ conf.level = conf_level, |
||
| 13 | -+ | |||
| 388 | +3x |
- #' @param bandwidth (`number` or `NULL`)\cr indicating the bandwidth of each window.+ method = "ha" |
||
| 14 | +389 |
- #' Depending on the argument `use_percentile`, it can be either the length of actual-value+ ) |
||
| 15 | -+ | |||
| 390 | +3x |
- #' windows on the real biomarker scale, or percentage windows.+ list( |
||
| 16 | -+ | |||
| 391 | +3x |
- #' If `use_percentile = TRUE`, it should be a number between 0 and 1.+ "diff" = unname(ci[, "est"]),+ |
+ ||
| 392 | +3x | +
+ "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
|
||
| 17 | +393 |
- #' If `NULL`, treat the bandwidth to be infinity, which means only one global model will be fitted.+ ) |
||
| 18 | +394 |
- #' By default, `0.25` is used for percentage windows and one quarter of the range of the `biomarker`+ } |
||
| 19 | +395 |
- #' variable for actual-value windows.+ |
||
| 20 | +396 |
- #' @param degree (`count`)\cr the degree of polynomial function of the biomarker as an interaction term+ #' @describeIn h_prop_diff `Newcombe` confidence interval. It is based on |
||
| 21 | +397 |
- #' with the treatment arm fitted at each window. If 0 (default), then the biomarker variable+ #' the Wilson score confidence interval for a single binomial proportion. |
||
| 22 | +398 |
- #' is not included in the model fitted in each biomarker window.+ #' |
||
| 23 | +399 |
- #' @param num_points (`count`)\cr the number of points at which the hazard ratios are estimated. The+ #' @examples |
||
| 24 | +400 |
- #' smallest number is 2.+ #' # `Newcombe` confidence interval |
||
| 25 | +401 |
#' |
||
| 26 | +402 |
- #' @return A list of components with the same names as the arguments, except `biomarker` which is+ #' set.seed(1) |
||
| 27 | +403 |
- #' just used to calculate the `bandwidth` in case that actual biomarker windows are requested.+ #' rsp <- c( |
||
| 28 | +404 |
- #'+ #' sample(c(TRUE, FALSE), size = 40, prob = c(3 / 4, 1 / 4), replace = TRUE), |
||
| 29 | +405 |
- #' @examples+ #' sample(c(TRUE, FALSE), size = 40, prob = c(1 / 2, 1 / 2), replace = TRUE) |
||
| 30 | +406 |
- #' # Provide biomarker values and request actual values to be used,+ #' ) |
||
| 31 | +407 |
- #' # so that bandwidth is chosen from range.+ #' grp <- factor(rep(c("A", "B"), each = 40), levels = c("B", "A"))
|
||
| 32 | +408 |
- #' control_step(biomarker = 1:10, use_percentile = FALSE)+ #' table(rsp, grp) |
||
| 33 | +409 |
- #'+ #' prop_diff_nc(rsp = rsp, grp = grp, conf_level = 0.9) |
||
| 34 | +410 |
- #' # Use a global model with quadratic biomarker interaction term.+ #' |
||
| 35 | +411 |
- #' control_step(bandwidth = NULL, degree = 2)+ #' @export |
||
| 36 | +412 |
- #'+ prop_diff_nc <- function(rsp, |
||
| 37 | +413 |
- #' # Reduce number of points to be used.+ grp, |
||
| 38 | +414 |
- #' control_step(num_points = 10)+ conf_level, |
||
| 39 | +415 |
- #'+ correct = FALSE) {
|
||
| 40 | -+ | |||
| 416 | +1x |
- #' @export+ if (isTRUE(correct)) {
|
||
| 41 | -+ | |||
| 417 | +! |
- control_step <- function(biomarker = NULL,+ mthd <- "scorecc" |
||
| 42 | +418 |
- use_percentile = TRUE,+ } else {
|
||
| 43 | -+ | |||
| 419 | +1x |
- bandwidth,+ mthd <- "score" |
||
| 44 | +420 |
- degree = 0L,+ }+ |
+ ||
| 421 | +1x | +
+ grp <- as_factor_keep_attributes(grp)+ |
+ ||
| 422 | +1x | +
+ check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level) |
||
| 45 | +423 |
- num_points = 39L) {
+
|
||
| 46 | -31x | +424 | +1x |
- checkmate::assert_numeric(biomarker, null.ok = TRUE)+ p_grp <- tapply(rsp, grp, mean) |
| 47 | -30x | +425 | +1x |
- checkmate::assert_flag(use_percentile)+ diff_p <- unname(diff(p_grp)) |
| 48 | -30x | +426 | +1x |
- checkmate::assert_int(num_points, lower = 2)+ tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE))) |
| 49 | -29x | +427 | +1x |
- checkmate::assert_count(degree)+ ci <- desctools_binom( |
| 50 | +428 |
-
+ # x1 and n1 are non-reference groups. |
||
| 51 | -29x | +429 | +1x |
- if (missing(bandwidth)) {
+ x1 = tbl[2], n1 = sum(tbl[2], tbl[4]), |
| 52 | -+ | |||
| 430 | +1x |
- # Infer bandwidth+ x2 = tbl[1], n2 = sum(tbl[1], tbl[3]), |
||
| 53 | -21x | +431 | +1x |
- bandwidth <- if (use_percentile) {
+ conf.level = conf_level, |
| 54 | -18x | +432 | +1x |
- 0.25+ method = mthd+ |
+
| 433 | ++ |
+ ) |
||
| 55 | -21x | +434 | +1x |
- } else if (!is.null(biomarker)) {
+ list( |
| 56 | -3x | +435 | +1x |
- diff(range(biomarker, na.rm = TRUE)) / 4+ "diff" = unname(ci[, "est"]),+ |
+
| 436 | +1x | +
+ "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
|
||
| 57 | +437 |
- } else {
+ ) |
||
| 58 | -! | +|||
| 438 | +
- NULL+ } |
|||
| 59 | +439 |
- }+ |
||
| 60 | +440 |
- } else {
+ #' @describeIn h_prop_diff Calculates the weighted difference. This is defined as the difference in |
||
| 61 | +441 |
- # Check bandwidth+ #' response rates between the experimental treatment group and the control treatment group, adjusted |
||
| 62 | -8x | +|||
| 442 | +
- if (!is.null(bandwidth)) {
+ #' for stratification factors by applying `Cochran-Mantel-Haenszel` (`CMH`) weights. For the `CMH` chi-squared |
|||
| 63 | -5x | +|||
| 443 | +
- if (use_percentile) {
+ #' test, use [stats::mantelhaen.test()]. |
|||
| 64 | -4x | +|||
| 444 | +
- assert_proportion_value(bandwidth)+ #' |
|||
| 65 | +445 |
- } else {
+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`. |
||
| 66 | -1x | +|||
| 446 | +
- checkmate::assert_scalar(bandwidth)+ #' |
|||
| 67 | -1x | +|||
| 447 | +
- checkmate::assert_true(bandwidth > 0)+ #' @examples |
|||
| 68 | +448 |
- }+ #' # Cochran-Mantel-Haenszel confidence interval |
||
| 69 | +449 |
- }+ #' |
||
| 70 | +450 |
- }+ #' set.seed(2) |
||
| 71 | -28x | +|||
| 451 | +
- list(+ #' rsp <- sample(c(TRUE, FALSE), 100, TRUE) |
|||
| 72 | -28x | +|||
| 452 | +
- use_percentile = use_percentile,+ #' grp <- sample(c("Placebo", "Treatment"), 100, TRUE)
|
|||
| 73 | -28x | +|||
| 453 | +
- bandwidth = bandwidth,+ #' grp <- factor(grp, levels = c("Placebo", "Treatment"))
|
|||
| 74 | -28x | +|||
| 454 | +
- degree = as.integer(degree),+ #' strata_data <- data.frame( |
|||
| 75 | -28x | +|||
| 455 | +
- num_points = as.integer(num_points)+ #' "f1" = sample(c("a", "b"), 100, TRUE),
|
|||
| 76 | +456 |
- )+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
||
| 77 | +457 |
- }+ #' stringsAsFactors = TRUE |
| 1 | +458 |
- #' Helper Functions for Tabulating Biomarker Effects on Binary Response by Subgroup+ #' ) |
||
| 2 | +459 |
#' |
||
| 3 | +460 |
- #' @description `r lifecycle::badge("stable")`
+ #' prop_diff_cmh( |
||
| 4 | +461 |
- #'+ #' rsp = rsp, grp = grp, strata = interaction(strata_data), |
||
| 5 | +462 |
- #' Helper functions which are documented here separately to not confuse the user+ #' conf_level = 0.90 |
||
| 6 | +463 |
- #' when reading about the user-facing functions.+ #' ) |
||
| 7 | +464 |
#' |
||
| 8 | +465 |
- #' @inheritParams response_biomarkers_subgroups+ #' @export |
||
| 9 | +466 |
- #' @inheritParams extract_rsp_biomarkers+ prop_diff_cmh <- function(rsp, |
||
| 10 | +467 |
- #' @inheritParams argument_convention+ grp, |
||
| 11 | +468 |
- #'+ strata, |
||
| 12 | +469 |
- #' @examples+ conf_level = 0.95) {
+ |
+ ||
| 470 | +7x | +
+ grp <- as_factor_keep_attributes(grp)+ |
+ ||
| 471 | +7x | +
+ strata <- as_factor_keep_attributes(strata)+ |
+ ||
| 472 | +7x | +
+ check_diff_prop_ci(+ |
+ ||
| 473 | +7x | +
+ rsp = rsp, grp = grp, conf_level = conf_level, strata = strata |
||
| 13 | +474 |
- #' library(dplyr)+ ) |
||
| 14 | +475 |
- #' library(forcats)+ + |
+ ||
| 476 | +7x | +
+ if (any(tapply(rsp, strata, length) < 5)) {
+ |
+ ||
| 477 | +! | +
+ warning("Less than 5 observations in some strata.")
|
||
| 15 | +478 |
- #'+ } |
||
| 16 | +479 |
- #' adrs <- tern_ex_adrs+ |
||
| 17 | +480 |
- #' adrs_labels <- formatters::var_labels(adrs)+ # first dimension: FALSE, TRUE |
||
| 18 | +481 | ++ |
+ # 2nd dimension: CONTROL, TX+ |
+ |
| 482 | ++ |
+ # 3rd dimension: levels of strat+ |
+ ||
| 483 |
- #'+ # rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records+ |
+ |||
| 484 | +7x | +
+ t_tbl <- table(+ |
+ ||
| 485 | +7x | +
+ factor(rsp, levels = c("FALSE", "TRUE")),
+ |
+ ||
| 486 | +7x | +
+ grp,+ |
+ ||
| 487 | +7x | +
+ strata |
||
| 19 | +488 |
- #' adrs_f <- adrs %>%+ ) |
||
| 20 | -+ | |||
| 489 | +7x |
- #' filter(PARAMCD == "BESRSPI") %>%+ n1 <- colSums(t_tbl[1:2, 1, ]) |
||
| 21 | -+ | |||
| 490 | +7x |
- #' mutate(rsp = AVALC == "CR")+ n2 <- colSums(t_tbl[1:2, 2, ]) |
||
| 22 | -+ | |||
| 491 | +7x |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ p1 <- t_tbl[2, 1, ] / n1 |
||
| 23 | -+ | |||
| 492 | +7x |
- #'+ p2 <- t_tbl[2, 2, ] / n2 |
||
| 24 | +493 |
- #' @name h_response_biomarkers_subgroups+ # CMH weights |
||
| 25 | -+ | |||
| 494 | +7x |
- NULL+ use_stratum <- (n1 > 0) & (n2 > 0) |
||
| 26 | -+ | |||
| 495 | +7x |
-
+ n1 <- n1[use_stratum] |
||
| 27 | -+ | |||
| 496 | +7x |
- #' @describeIn h_response_biomarkers_subgroups helps with converting the "response" function variable list+ n2 <- n2[use_stratum] |
||
| 28 | -+ | |||
| 497 | +7x |
- #' to the "logistic regression" variable list. The reason is that currently there is an+ p1 <- p1[use_stratum] |
||
| 29 | -+ | |||
| 498 | +7x |
- #' inconsistency between the variable names accepted by `extract_rsp_subgroups()` and `fit_logistic()`.+ p2 <- p2[use_stratum] |
||
| 30 | -+ | |||
| 499 | +7x |
- #'+ wt <- (n1 * n2 / (n1 + n2)) |
||
| 31 | -+ | |||
| 500 | +7x |
- #' @param biomarker (`string`)\cr the name of the biomarker variable.+ wt_normalized <- wt / sum(wt) |
||
| 32 | -+ | |||
| 501 | +7x |
- #'+ est1 <- sum(wt_normalized * p1) |
||
| 33 | -+ | |||
| 502 | +7x |
- #' @return+ est2 <- sum(wt_normalized * p2) |
||
| 34 | -+ | |||
| 503 | +7x |
- #' * `h_rsp_to_logistic_variables()` returns a named `list` of elements `response`, `arm`, `covariates`, and `strata`.+ estimate <- c(est1, est2) |
||
| 35 | -+ | |||
| 504 | +7x |
- #'+ names(estimate) <- levels(grp) |
||
| 36 | -+ | |||
| 505 | +7x |
- #' @examples+ se1 <- sqrt(sum(wt_normalized^2 * p1 * (1 - p1) / n1)) |
||
| 37 | -+ | |||
| 506 | +7x |
- #' # This is how the variable list is converted internally.+ se2 <- sqrt(sum(wt_normalized^2 * p2 * (1 - p2) / n2)) |
||
| 38 | -+ | |||
| 507 | +7x |
- #' h_rsp_to_logistic_variables(+ z <- stats::qnorm((1 + conf_level) / 2) |
||
| 39 | -+ | |||
| 508 | +7x |
- #' variables = list(+ err1 <- z * se1 |
||
| 40 | -+ | |||
| 509 | +7x |
- #' rsp = "RSP",+ err2 <- z * se2 |
||
| 41 | -+ | |||
| 510 | +7x |
- #' covariates = c("A", "B"),
+ ci1 <- c((est1 - err1), (est1 + err1)) |
||
| 42 | -+ | |||
| 511 | +7x |
- #' strat = "D"+ ci2 <- c((est2 - err2), (est2 + err2)) |
||
| 43 | -+ | |||
| 512 | +7x |
- #' ),+ estimate_ci <- list(ci1, ci2) |
||
| 44 | -+ | |||
| 513 | +7x |
- #' biomarker = "AGE"+ names(estimate_ci) <- levels(grp) |
||
| 45 | -+ | |||
| 514 | +7x |
- #' )+ diff_est <- est2 - est1 |
||
| 46 | -+ | |||
| 515 | +7x |
- #'+ se_diff <- sqrt(sum(((p1 * (1 - p1) / n1) + (p2 * (1 - p2) / n2)) * wt_normalized^2)) |
||
| 47 | -+ | |||
| 516 | +7x |
- #' @export+ diff_ci <- c(diff_est - z * se_diff, diff_est + z * se_diff) |
||
| 48 | +517 |
- h_rsp_to_logistic_variables <- function(variables, biomarker) {
+
|
||
| 49 | -37x | +518 | +7x |
- checkmate::assert_list(variables)+ list( |
| 50 | -37x | +519 | +7x |
- checkmate::assert_string(variables$rsp)+ prop = estimate, |
| 51 | -37x | +520 | +7x |
- checkmate::assert_string(biomarker)+ prop_ci = estimate_ci, |
| 52 | -37x | +521 | +7x |
- list(+ diff = diff_est, |
| 53 | -37x | +522 | +7x |
- response = variables$rsp,+ diff_ci = diff_ci, |
| 54 | -37x | +523 | +7x |
- arm = biomarker,+ weights = wt_normalized, |
| 55 | -37x | +524 | +7x |
- covariates = variables$covariates,+ n1 = n1, |
| 56 | -37x | +525 | +7x |
- strata = variables$strat+ n2 = n2 |
| 57 | +526 |
) |
||
| 58 | +527 |
} |
||
| 59 | +528 | |||
| 60 | +529 |
- #' @describeIn h_response_biomarkers_subgroups prepares estimates for number of responses, patients and+ #' @describeIn h_prop_diff Calculates the stratified `Newcombe` confidence interval and difference in response |
||
| 61 | +530 |
- #' overall response rate, as well as odds ratio estimates, confidence intervals and p-values, for multiple+ #' rates between the experimental treatment group and the control treatment group, adjusted for stratification |
||
| 62 | +531 |
- #' biomarkers in a given single data set.+ #' factors. This implementation follows closely the one proposed by \insertCite{Yan2010-jt;textual}{tern}.
|
||
| 63 | +532 |
- #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements+ #' Weights can be estimated from the heuristic proposed in [prop_strat_wilson()] or from `CMH`-derived weights |
||
| 64 | +533 |
- #' `rsp` and `biomarkers` (vector of continuous biomarker variables) and optionally `covariates`+ #' (see [prop_diff_cmh()]). |
||
| 65 | +534 |
- #' and `strat`.+ #' |
||
| 66 | +535 |
- #'+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`. |
||
| 67 | +536 |
- #' @return+ #' @param weights_method (`string`)\cr weights method. Can be either `"cmh"` or `"heuristic"` |
||
| 68 | +537 |
- #' * `h_logistic_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers.+ #' and directs the way weights are estimated. |
||
| 69 | +538 |
#' |
||
| 70 | +539 |
- #' @examples+ #' @references |
||
| 71 | +540 |
- #' # For a single population, estimate separately the effects+ #' \insertRef{Yan2010-jt}{tern}
|
||
| 72 | +541 |
- #' # of two biomarkers.+ #' |
||
| 73 | +542 |
- #' df <- h_logistic_mult_cont_df(+ #' @examples |
||
| 74 | +543 |
- #' variables = list(+ #' # Stratified `Newcombe` confidence interval |
||
| 75 | +544 |
- #' rsp = "rsp",+ #' |
||
| 76 | +545 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' set.seed(2) |
||
| 77 | +546 |
- #' covariates = "SEX"+ #' data_set <- data.frame( |
||
| 78 | +547 |
- #' ),+ #' "rsp" = sample(c(TRUE, FALSE), 100, TRUE), |
||
| 79 | +548 |
- #' data = adrs_f+ #' "f1" = sample(c("a", "b"), 100, TRUE),
|
||
| 80 | +549 |
- #' )+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
||
| 81 | +550 |
- #' df+ #' "grp" = sample(c("Placebo", "Treatment"), 100, TRUE),
|
||
| 82 | +551 |
- #'+ #' stringsAsFactors = TRUE |
||
| 83 | +552 |
- #' # If the data set is empty, still the corresponding rows with missings are returned.+ #' ) |
||
| 84 | +553 |
- #' h_coxreg_mult_cont_df(+ #' |
||
| 85 | +554 |
- #' variables = list(+ #' prop_diff_strat_nc( |
||
| 86 | +555 |
- #' rsp = "rsp",+ #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]), |
||
| 87 | +556 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' weights_method = "cmh", |
||
| 88 | +557 |
- #' covariates = "SEX",+ #' conf_level = 0.90 |
||
| 89 | +558 |
- #' strat = "STRATA1"+ #' ) |
||
| 90 | +559 |
- #' ),+ #' |
||
| 91 | +560 |
- #' data = adrs_f[NULL, ]+ #' prop_diff_strat_nc( |
||
| 92 | +561 |
- #' )+ #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]), |
||
| 93 | +562 |
- #'+ #' weights_method = "wilson_h", |
||
| 94 | +563 |
- #' @export+ #' conf_level = 0.90 |
||
| 95 | +564 |
- h_logistic_mult_cont_df <- function(variables,+ #' ) |
||
| 96 | +565 |
- data,+ #' |
||
| 97 | +566 |
- control = control_logistic()) {
- |
- ||
| 98 | -22x | -
- assert_df_with_variables(data, variables)+ #' @export |
||
| 99 | +567 | - - | -||
| 100 | -22x | -
- checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE)- |
- ||
| 101 | -22x | -
- checkmate::assert_list(control, names = "named")+ prop_diff_strat_nc <- function(rsp, |
||
| 102 | +568 | - - | -||
| 103 | -22x | -
- conf_level <- control[["conf_level"]]- |
- ||
| 104 | -22x | -
- pval_label <- "p-value (Wald)"+ grp, |
||
| 105 | +569 |
-
+ strata, |
||
| 106 | +570 |
- # If there is any data, run model, otherwise return empty results.+ weights_method = c("cmh", "wilson_h"),
|
||
| 107 | -22x | +|||
| 571 | +
- if (nrow(data) > 0) {
+ conf_level = 0.95, |
|||
| 108 | -21x | +|||
| 572 | +
- bm_cols <- match(variables$biomarkers, names(data))+ correct = FALSE) {
|
|||
| 109 | -21x | +573 | +4x |
- l_result <- lapply(variables$biomarkers, function(bm) {
+ weights_method <- match.arg(weights_method) |
| 110 | -36x | +574 | +4x |
- model_fit <- fit_logistic(+ grp <- as_factor_keep_attributes(grp) |
| 111 | -36x | +575 | +4x |
- variables = h_rsp_to_logistic_variables(variables, bm),+ strata <- as_factor_keep_attributes(strata) |
| 112 | -36x | +576 | +4x |
- data = data,+ check_diff_prop_ci( |
| 113 | -36x | +577 | +4x |
- response_definition = control$response_definition+ rsp = rsp, grp = grp, conf_level = conf_level, strata = strata |
| 114 | +578 |
- )+ ) |
||
| 115 | -36x | +579 | +4x |
- result <- h_logistic_simple_terms(+ checkmate::assert_number(conf_level, lower = 0, upper = 1) |
| 116 | -36x | +580 | +4x |
- x = bm,+ checkmate::assert_flag(correct) |
| 117 | -36x | +581 | +4x |
- fit_glm = model_fit,+ if (any(tapply(rsp, strata, length) < 5)) {
|
| 118 | -36x | +|||
| 582 | +! |
- conf_level = control$conf_level+ warning("Less than 5 observations in some strata.")
|
||
| 119 | +583 |
- )- |
- ||
| 120 | -36x | -
- resp_vector <- if (inherits(model_fit, "glm")) {
- |
- ||
| 121 | -26x | -
- model_fit$model[[variables$rsp]]+ } |
||
| 122 | +584 |
- } else {
+
|
||
| 123 | -10x | -
- as.logical(as.matrix(model_fit$y)[, "status"])- |
- ||
| 124 | -+ | 585 | +4x |
- }+ rsp_by_grp <- split(rsp, f = grp) |
| 125 | -36x | +586 | +4x |
- data.frame(+ strata_by_grp <- split(strata, f = grp) |
| 126 | +587 |
- # Dummy column needed downstream to create a nested header.- |
- ||
| 127 | -36x | -
- biomarker = bm,- |
- ||
| 128 | -36x | -
- biomarker_label = formatters::var_labels(data[bm], fill = TRUE),- |
- ||
| 129 | -36x | -
- n_tot = length(resp_vector),- |
- ||
| 130 | -36x | -
- n_rsp = sum(resp_vector),- |
- ||
| 131 | -36x | -
- prop = mean(resp_vector),+ |
||
| 132 | -36x | +|||
| 588 | +
- or = as.numeric(result[1L, "odds_ratio"]),+ # Finding the weights |
|||
| 133 | -36x | +589 | +4x |
- lcl = as.numeric(result[1L, "lcl"]),+ weights <- if (identical(weights_method, "cmh")) {
|
| 134 | -36x | +590 | +3x |
- ucl = as.numeric(result[1L, "ucl"]),+ prop_diff_cmh(rsp = rsp, grp = grp, strata = strata)$weights |
| 135 | -36x | +591 | +4x |
- conf_level = conf_level,+ } else if (identical(weights_method, "wilson_h")) {
|
| 136 | -36x | +592 | +1x |
- pval = as.numeric(result[1L, "pvalue"]),+ prop_strat_wilson(rsp, strata, conf_level = conf_level, correct = correct)$weights |
| 137 | -36x | +|||
| 593 | +
- pval_label = pval_label,+ } |
|||
| 138 | -36x | +594 | +4x |
- stringsAsFactors = FALSE+ weights[levels(strata)[!levels(strata) %in% names(weights)]] <- 0 |
| 139 | +595 |
- )+ |
||
| 140 | +596 |
- })+ # Calculating lower (`l`) and upper (`u`) confidence bounds per group. |
||
| 141 | -21x | -
- do.call(rbind, args = c(l_result, make.row.names = FALSE))- |
- ||
| 142 | -+ | 597 | +4x |
- } else {
+ strat_wilson_by_grp <- Map( |
| 143 | -1x | +598 | +4x |
- data.frame(+ prop_strat_wilson, |
| 144 | -1x | +599 | +4x |
- biomarker = variables$biomarkers,+ rsp = rsp_by_grp, |
| 145 | -1x | +600 | +4x |
- biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE),+ strata = strata_by_grp, |
| 146 | -1x | +601 | +4x |
- n_tot = 0L,+ weights = list(weights, weights), |
| 147 | -1x | +602 | +4x |
- n_rsp = 0L,+ conf_level = conf_level, |
| 148 | -1x | +603 | +4x |
- prop = NA,+ correct = correct |
| 149 | -1x | +|||
| 604 | +
- or = NA,+ ) |
|||
| 150 | -1x | +|||
| 605 | +
- lcl = NA,+ |
|||
| 151 | -1x | +606 | +4x |
- ucl = NA,+ ci_ref <- strat_wilson_by_grp[[1]] |
| 152 | -1x | +607 | +4x |
- conf_level = conf_level,+ ci_trt <- strat_wilson_by_grp[[2]] |
| 153 | -1x | +608 | +4x |
- pval = NA,+ l_ref <- as.numeric(ci_ref$conf_int[1]) |
| 154 | -1x | +609 | +4x |
- pval_label = pval_label,+ u_ref <- as.numeric(ci_ref$conf_int[2]) |
| 155 | -1x | +610 | +4x |
- row.names = seq_along(variables$biomarkers),+ l_trt <- as.numeric(ci_trt$conf_int[1]) |
| 156 | -1x | -
- stringsAsFactors = FALSE- |
- ||
| 157 | -- |
- )- |
- ||
| 158 | -- |
- }- |
- ||
| 159 | -+ | 611 | +4x |
- }+ u_trt <- as.numeric(ci_trt$conf_int[2]) |
| 160 | +612 | |||
| 161 | -- |
- #' @describeIn h_response_biomarkers_subgroups prepares a single sub-table given a `df_sub` containing- |
- ||
| 162 | -- |
- #' the results for a single biomarker.- |
- ||
| 163 | -- |
- #'- |
- ||
| 164 | -- |
- #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is- |
- ||
| 165 | -- |
- #' returned by [extract_rsp_biomarkers()] (it needs a couple of columns which are- |
- ||
| 166 | -- |
- #' added by that high-level function relative to what is returned by [h_logistic_mult_cont_df()],- |
- ||
| 167 | -- |
- #' see the example).- |
- ||
| 168 | -- |
- #'- |
- ||
| 169 | -- |
- #' @return- |
- ||
| 170 | -- |
- #' * `h_tab_rsp_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns.- |
- ||
| 171 | -- |
- #'- |
- ||
| 172 | -- |
- #' @examples- |
- ||
| 173 | -- |
- #' # Starting from above `df`, zoom in on one biomarker and add required columns.- |
- ||
| 174 | -- |
- #' df1 <- df[1, ]- |
- ||
| 175 | +613 |
- #' df1$subgroup <- "All patients"+ # Estimating the diff and n_ref, n_trt (it allows different weights to be used) |
||
| 176 | -+ | |||
| 614 | +4x |
- #' df1$row_type <- "content"+ t_tbl <- table( |
||
| 177 | -+ | |||
| 615 | +4x |
- #' df1$var <- "ALL"+ factor(rsp, levels = c("FALSE", "TRUE")),
|
||
| 178 | -+ | |||
| 616 | +4x |
- #' df1$var_label <- "All patients"+ grp, |
||
| 179 | -+ | |||
| 617 | +4x |
- #'+ strata |
||
| 180 | +618 |
- #' h_tab_rsp_one_biomarker(+ ) |
||
| 181 | -+ | |||
| 619 | +4x |
- #' df1,+ n_ref <- colSums(t_tbl[1:2, 1, ]) |
||
| 182 | -+ | |||
| 620 | +4x |
- #' vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval")
+ n_trt <- colSums(t_tbl[1:2, 2, ]) |
||
| 183 | -+ | |||
| 621 | +4x |
- #' )+ use_stratum <- (n_ref > 0) & (n_trt > 0) |
||
| 184 | -+ | |||
| 622 | +4x |
- #'+ n_ref <- n_ref[use_stratum] |
||
| 185 | -+ | |||
| 623 | +4x |
- #' @export+ n_trt <- n_trt[use_stratum] |
||
| 186 | -+ | |||
| 624 | +4x |
- h_tab_rsp_one_biomarker <- function(df,+ p_ref <- t_tbl[2, 1, use_stratum] / n_ref |
||
| 187 | -+ | |||
| 625 | +4x |
- vars,+ p_trt <- t_tbl[2, 2, use_stratum] / n_trt |
||
| 188 | -+ | |||
| 626 | +4x |
- .indent_mods = 0L) {
+ est1 <- sum(weights * p_ref) |
||
| 189 | -6x | +627 | +4x |
- afuns <- a_response_subgroups()[vars]+ est2 <- sum(weights * p_trt) |
| 190 | -6x | +628 | +4x |
- colvars <- d_rsp_subgroups_colvars(+ diff_est <- est2 - est1+ |
+
| 629 | ++ | + | ||
| 191 | -6x | +630 | +4x |
- vars,+ lambda1 <- sum(weights^2 / n_ref) |
| 192 | -6x | +631 | +4x |
- conf_level = df$conf_level[1],+ lambda2 <- sum(weights^2 / n_trt) |
| 193 | -6x | +632 | +4x |
- method = df$pval_label[1]+ z <- stats::qnorm((1 + conf_level) / 2) |
| 194 | +633 |
- )+ |
||
| 195 | -6x | +634 | +4x |
- h_tab_one_biomarker(+ lower <- diff_est - z * sqrt(lambda2 * l_trt * (1 - l_trt) + lambda1 * u_ref * (1 - u_ref)) |
| 196 | -6x | +635 | +4x |
- df = df,+ upper <- diff_est + z * sqrt(lambda1 * l_ref * (1 - l_ref) + lambda2 * u_trt * (1 - u_trt))+ |
+
| 636 | ++ | + | ||
| 197 | -6x | +637 | +4x |
- afuns = afuns,+ list( |
| 198 | -6x | +638 | +4x |
- colvars = colvars,+ "diff" = diff_est, |
| 199 | -6x | +639 | +4x |
- .indent_mods = .indent_mods+ "diff_ci" = c("lower" = lower, "upper" = upper)
|
| 200 | +640 |
) |
||
| 201 | +641 |
}@@ -111508,14 +111195,14 @@ tern coverage - 94.83% |
| 1 |
- #' Summarize Variables in Columns+ #' Multivariate Logistic Regression Table |
||
| 5 |
- #' This analyze function uses the S3 generic function [s_summary()] to summarize different variables+ #' Layout-creating function which summarizes a logistic variable regression for binary outcome with |
||
| 6 |
- #' that are arranged in columns. Additional standard formatting arguments are available. It is a+ #' categorical/continuous covariates in model statement. For each covariate category (if categorical) |
||
| 7 |
- #' minimal wrapper for [rtables::analyze_colvars()]. The latter function is meant to add different+ #' or specified values (if continuous), present degrees of freedom, regression parameter estimate and |
||
| 8 |
- #' analysis methods for each column variables as different rows. To have the analysis methods as+ #' standard error (SE) relative to reference group or category. Report odds ratios for each covariate |
||
| 9 |
- #' column labels, please refer to [analyze_vars_in_cols()].+ #' category or specified values and corresponding Wald confidence intervals as default but allow user |
||
| 10 |
- #'+ #' to specify other confidence levels. Report p-value for Wald chi-square test of the null hypothesis |
||
| 11 |
- #' @inheritParams argument_convention+ #' that covariate has no effect on response in model containing all specified covariates. |
||
| 12 |
- #' @param ... arguments passed to `s_summary()`.+ #' Allow option to include one two-way interaction and present similar output for |
||
| 13 |
- #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ #' each interaction degree of freedom. |
||
| 14 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ #' |
||
| 15 |
- #' for that statistic's row label.+ #' @inheritParams argument_convention |
||
| 16 |
- #'+ #' @param drop_and_remove_str (`character`)\cr string to be dropped and removed. |
||
| 17 |
- #' @return+ #' |
||
| 18 |
- #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()].+ #' @return A layout object suitable for passing to further layouting functions, or to [rtables::build_table()]. |
||
| 19 |
- #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output+ #' Adding this function to an `rtable` layout will add a logistic regression variable summary to the table layout. |
||
| 20 |
- #' in columns, and add it to the table layout.+ #' |
||
| 21 |
- #'+ #' @note For the formula, the variable names need to be standard `data.frame` column names without |
||
| 22 |
- #' @seealso [rtables::split_cols_by_multivar()] and [`analyze_colvars_functions`].+ #' special characters. |
||
| 25 |
- #' dta_test <- data.frame(+ #' library(dplyr) |
||
| 26 |
- #' USUBJID = rep(1:6, each = 3),+ #' library(broom) |
||
| 27 |
- #' PARAMCD = rep("lab", 6 * 3),
+ #' |
||
| 28 |
- #' AVISIT = rep(paste0("V", 1:3), 6),
+ #' adrs_f <- tern_ex_adrs %>% |
||
| 29 |
- #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 30 |
- #' AVAL = c(9:1, rep(NA, 9)),+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
|
||
| 31 |
- #' CHG = c(1:9, rep(NA, 9))+ #' mutate( |
||
| 32 |
- #' )+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
||
| 33 |
- #'+ #' RACE = factor(RACE), |
||
| 34 |
- #' ## Default output within a `rtables` pipeline.+ #' SEX = factor(SEX) |
||
| 35 |
- #' basic_table() %>%+ #' ) |
||
| 36 |
- #' split_cols_by("ARM") %>%
+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
||
| 37 |
- #' split_rows_by("AVISIT") %>%
+ #' mod1 <- fit_logistic( |
||
| 38 |
- #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
+ #' data = adrs_f, |
||
| 39 |
- #' summarize_colvars() %>%+ #' variables = list( |
||
| 40 |
- #' build_table(dta_test)+ #' response = "Response", |
||
| 41 |
- #'+ #' arm = "ARMCD", |
||
| 42 |
- #' ## Selection of statistics, formats and labels also work.+ #' covariates = c("AGE", "RACE")
|
||
| 43 |
- #' basic_table() %>%+ #' ) |
||
| 44 |
- #' split_cols_by("ARM") %>%
+ #' ) |
||
| 45 |
- #' split_rows_by("AVISIT") %>%
+ #' mod2 <- fit_logistic( |
||
| 46 |
- #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
+ #' data = adrs_f, |
||
| 47 |
- #' summarize_colvars(+ #' variables = list( |
||
| 48 |
- #' .stats = c("n", "mean_sd"),
+ #' response = "Response", |
||
| 49 |
- #' .formats = c("mean_sd" = "xx.x, xx.x"),
+ #' arm = "ARMCD", |
||
| 50 |
- #' .labels = c(n = "n", mean_sd = "Mean, SD")+ #' covariates = c("AGE", "RACE"),
|
||
| 51 |
- #' ) %>%+ #' interaction = "AGE" |
||
| 52 |
- #' build_table(dta_test)+ #' ) |
||
| 53 |
- #'+ #' ) |
||
| 54 |
- #' ## Use arguments interpreted by `s_summary`.+ #' |
||
| 55 |
- #' basic_table() %>%+ #' df <- tidy(mod1, conf_level = 0.99) |
||
| 56 |
- #' split_cols_by("ARM") %>%
+ #' df2 <- tidy(mod2, conf_level = 0.99) |
||
| 57 |
- #' split_rows_by("AVISIT") %>%
+ #' |
||
| 58 |
- #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
+ #' # flagging empty strings with "_" |
||
| 59 |
- #' summarize_colvars(na.rm = FALSE) %>%+ #' df <- df_explicit_na(df, na_level = "_") |
||
| 60 |
- #' build_table(dta_test)+ #' df2 <- df_explicit_na(df2, na_level = "_") |
||
| 62 |
- #' @export+ #' result1 <- basic_table() %>% |
||
| 63 |
- summarize_colvars <- function(lyt,+ #' summarize_logistic( |
||
| 64 |
- ...,+ #' conf_level = 0.95, |
||
| 65 |
- na_level = NA_character_,+ #' drop_and_remove_str = "_" |
||
| 66 |
- .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
+ #' ) %>% |
||
| 67 |
- .formats = NULL,+ #' build_table(df = df) |
||
| 68 |
- .labels = NULL,+ #' result1 |
||
| 69 |
- .indent_mods = NULL) {
- |
- ||
| 70 | -3x | -
- extra_args <- list(.stats = .stats, na_level = na_level, ...)- |
- |
| 71 | -1x | -
- if (!is.null(.formats)) extra_args[[".formats"]] <- .formats- |
- |
| 72 | -1x | -
- if (!is.null(.labels)) extra_args[[".labels"]] <- .labels- |
- |
| 73 | -1x | -
- if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods- |
- |
| 74 | -- | - - | -|
| 75 | -3x | -
- analyze_colvars(- |
- |
| 76 | -3x | -
- lyt,- |
- |
| 77 | -3x | -
- afun = a_summary,- |
- |
| 78 | -3x | -
- extra_args = extra_args+ #' |
|
| 79 | +70 |
- )+ #' result2 <- basic_table() %>% |
|
| 80 | +71 |
- }+ #' summarize_logistic( |
| 1 | +72 |
- #' Additional Assertions for `checkmate`+ #' conf_level = 0.95, |
||
| 2 | +73 |
- #'+ #' drop_and_remove_str = "_" |
||
| 3 | +74 |
- #' Additional assertion functions which can be used together with the `checkmate` package.+ #' ) %>% |
||
| 4 | +75 |
- #'+ #' build_table(df = df2) |
||
| 5 | +76 |
- #' @inheritParams checkmate::assert_factor+ #' result2 |
||
| 6 | +77 |
- #' @param x (`any`)\cr object to test.+ #' |
||
| 7 | +78 |
- #' @param df (`data.frame`)\cr data set to test.+ #' @export |
||
| 8 | +79 |
- #' @param variables (named `list` of `character`)\cr list of variables to test.+ summarize_logistic <- function(lyt, |
||
| 9 | +80 |
- #' @param include_boundaries (`logical`)\cr whether to include boundaries when testing+ conf_level, |
||
| 10 | +81 |
- #' for proportions.+ drop_and_remove_str = "", |
||
| 11 | +82 |
- #' @param na_level (`character`)\cr the string you have been using to represent NA or+ .indent_mods = NULL) {
|
||
| 12 | +83 |
- #' missing data. For `NA` values please consider using directly [is.na()] or+ # checks |
||
| 13 | -+ | |||
| 84 | +3x |
- #' similar approaches.+ checkmate::assert_string(drop_and_remove_str) |
||
| 14 | +85 |
- #'+ |
||
| 15 | -+ | |||
| 86 | +3x |
- #' @return Nothing if assertion passes, otherwise prints the error message.+ sum_logistic_variable_test <- logistic_summary_by_flag("is_variable_summary")
|
||
| 16 | -+ | |||
| 87 | +3x |
- #'+ sum_logistic_term_estimates <- logistic_summary_by_flag("is_term_summary", .indent_mods = .indent_mods)
|
||
| 17 | -+ | |||
| 88 | +3x |
- #' @name assertions+ sum_logistic_odds_ratios <- logistic_summary_by_flag("is_reference_summary", .indent_mods = .indent_mods)
|
||
| 18 | -+ | |||
| 89 | +3x |
- NULL+ split_fun <- drop_and_remove_levels(drop_and_remove_str) |
||
| 19 | +90 | |||
| 20 | -+ | |||
| 91 | +3x |
- check_list_of_variables <- function(x) {
+ lyt <- logistic_regression_cols(lyt, conf_level = conf_level) |
||
| 21 | -+ | |||
| 92 | +3x |
- # drop NULL elements in list+ lyt <- split_rows_by(lyt, var = "variable", labels_var = "variable_label", split_fun = split_fun) |
||
| 22 | -2190x | +93 | +3x |
- x <- Filter(Negate(is.null), x)+ lyt <- sum_logistic_variable_test(lyt) |
| 23 | -+ | |||
| 94 | +3x |
-
+ lyt <- split_rows_by(lyt, var = "term", labels_var = "term_label", split_fun = split_fun) |
||
| 24 | -2190x | +95 | +3x |
- res <- checkmate::check_list(x,+ lyt <- sum_logistic_term_estimates(lyt) |
| 25 | -2190x | +96 | +3x |
- names = "named",+ lyt <- split_rows_by(lyt, var = "interaction", labels_var = "interaction_label", split_fun = split_fun) |
| 26 | -2190x | +97 | +3x |
- min.len = 1,+ lyt <- split_rows_by(lyt, var = "reference", labels_var = "reference_label", split_fun = split_fun) |
| 27 | -2190x | +98 | +3x |
- any.missing = FALSE,+ lyt <- sum_logistic_odds_ratios(lyt) |
| 28 | -2190x | +99 | +3x |
- types = "character"+ lyt |
| 29 | +100 |
- )+ } |
||
| 30 | +101 |
- # no empty strings allowed- |
- ||
| 31 | -2190x | -
- if (isTRUE(res)) {
- |
- ||
| 32 | -2185x | -
- res <- checkmate::check_character(unlist(x), min.chars = 1)+ |
||
| 33 | +102 |
- }+ #' Fit for Logistic Regression |
||
| 34 | -2190x | +|||
| 103 | +
- return(res)+ #' |
|||
| 35 | +104 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 36 | +105 |
- #' @describeIn assertions Checks whether `x` is a valid list of variable names.+ #' |
||
| 37 | +106 |
- #' `NULL` elements of the list `x` are dropped with `Filter(Negate(is.null), x)`.+ #' Fit a (conditional) logistic regression model. |
||
| 38 | +107 |
#' |
||
| 39 | +108 |
- #' @keywords internal+ #' @inheritParams argument_convention |
||
| 40 | +109 |
- assert_list_of_variables <- checkmate::makeAssertionFunction(check_list_of_variables)+ #' @param data (`data.frame`)\cr the data frame on which the model was fit. |
||
| 41 | +110 |
-
+ #' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`. |
||
| 42 | +111 |
- check_df_with_variables <- function(df, variables, na_level = NULL) {
- |
- ||
| 43 | -1956x | -
- checkmate::assert_data_frame(df)- |
- ||
| 44 | -1954x | -
- assert_list_of_variables(variables)+ #' This will be used when fitting the (conditional) logistic regression model on the left hand |
||
| 45 | +112 |
-
+ #' side of the formula. |
||
| 46 | +113 |
- # flag for equal variables and column names- |
- ||
| 47 | -1952x | -
- err_flag <- all(unlist(variables) %in% colnames(df))- |
- ||
| 48 | -1952x | -
- checkmate::assert_flag(err_flag)+ #' |
||
| 49 | +114 | - - | -||
| 50 | -1952x | -
- if (isFALSE(err_flag)) {
- |
- ||
| 51 | -5x | -
- vars <- setdiff(unlist(variables), colnames(df))- |
- ||
| 52 | -5x | -
- return(paste(- |
- ||
| 53 | -5x | -
- deparse(substitute(df)),+ #' @return A fitted logistic regression model. |
||
| 54 | -5x | +|||
| 115 | +
- "does not contain all specified variables as column names. Missing from dataframe:",+ #' |
|||
| 55 | -5x | +|||
| 116 | +
- paste(vars, collapse = ", ")+ #' @section Model Specification: |
|||
| 56 | +117 |
- ))+ #' |
||
| 57 | +118 |
- }+ #' The `variables` list needs to include the following elements: |
||
| 58 | +119 |
- # checking if na_level is present and in which column+ #' * `arm`: Treatment arm variable name. |
||
| 59 | -1947x | +|||
| 120 | +
- if (!is.null(na_level)) {
+ #' * `response`: The response arm variable name. Usually this is a 0/1 variable. |
|||
| 60 | -9x | +|||
| 121 | +
- checkmate::assert_string(na_level)+ #' * `covariates`: This is either `NULL` (no covariates) or a character vector of covariate variable names. |
|||
| 61 | -9x | +|||
| 122 | +
- res <- unlist(lapply(as.list(df)[unlist(variables)], function(x) any(x == na_level)))+ #' * `interaction`: This is either `NULL` (no interaction) or a string of a single covariate variable name already |
|||
| 62 | -9x | +|||
| 123 | +
- if (any(res)) {
+ #' included in `covariates`. Then the interaction with the treatment arm is included in the model. |
|||
| 63 | -1x | +|||
| 124 | +
- return(paste0(+ #' |
|||
| 64 | -1x | +|||
| 125 | +
- deparse(substitute(df)), " contains explicit na_level (", na_level,
+ #' @examples |
|||
| 65 | -1x | +|||
| 126 | +
- ") in the following columns: ", paste0(unlist(variables)[res],+ #' library(dplyr) |
|||
| 66 | -1x | +|||
| 127 | +
- collapse = ", "+ #' |
|||
| 67 | +128 |
- )+ #' adrs_f <- tern_ex_adrs %>% |
||
| 68 | +129 |
- ))+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 69 | +130 |
- }+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
|
||
| 70 | +131 |
- }+ #' mutate( |
||
| 71 | -1946x | +|||
| 132 | +
- return(TRUE)+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
|||
| 72 | +133 |
- }+ #' RACE = factor(RACE), |
||
| 73 | +134 |
- #' @describeIn assertions Check whether `df` is a data frame with the analysis `variables`.+ #' SEX = factor(SEX) |
||
| 74 | +135 |
- #' Please notice how this produces an error when not all variables are present in the+ #' ) |
||
| 75 | +136 |
- #' data.frame while the opposite is not required.+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
||
| 76 | +137 |
- #'+ #' mod1 <- fit_logistic( |
||
| 77 | +138 |
- #' @keywords internal+ #' data = adrs_f, |
||
| 78 | +139 |
- assert_df_with_variables <- checkmate::makeAssertionFunction(check_df_with_variables)+ #' variables = list( |
||
| 79 | +140 |
-
+ #' response = "Response", |
||
| 80 | +141 |
- check_valid_factor <- function(x,+ #' arm = "ARMCD", |
||
| 81 | +142 |
- min.levels = 1, # nolint+ #' covariates = c("AGE", "RACE")
|
||
| 82 | +143 |
- max.levels = NULL, # nolint+ #' ) |
||
| 83 | +144 |
- null.ok = TRUE, # nolint+ #' ) |
||
| 84 | +145 |
- any.missing = TRUE, # nolint+ #' mod2 <- fit_logistic( |
||
| 85 | +146 |
- n.levels = NULL, # nolint+ #' data = adrs_f, |
||
| 86 | +147 |
- len = NULL) {
+ #' variables = list( |
||
| 87 | +148 |
- # checks on levels insertion+ #' response = "Response", |
||
| 88 | -846x | +|||
| 149 | +
- checkmate::assert_int(min.levels, lower = 1)+ #' arm = "ARMCD", |
|||
| 89 | +150 |
-
+ #' covariates = c("AGE", "RACE"),
|
||
| 90 | +151 |
- # main factor check+ #' interaction = "AGE" |
||
| 91 | -846x | +|||
| 152 | +
- res <- checkmate::check_factor(x,+ #' ) |
|||
| 92 | -846x | +|||
| 153 | +
- min.levels = min.levels,+ #' ) |
|||
| 93 | -846x | +|||
| 154 | +
- null.ok = null.ok,+ #' |
|||
| 94 | -846x | +|||
| 155 | +
- max.levels = max.levels,+ #' @export |
|||
| 95 | -846x | +|||
| 156 | +
- any.missing = any.missing,+ fit_logistic <- function(data, |
|||
| 96 | -846x | +|||
| 157 | +
- n.levels = n.levels+ variables = list( |
|||
| 97 | +158 |
- )+ response = "Response", |
||
| 98 | +159 |
-
+ arm = "ARMCD", |
||
| 99 | +160 |
- # no empty strings allowed+ covariates = NULL, |
||
| 100 | -846x | +|||
| 161 | +
- if (isTRUE(res)) {
+ interaction = NULL, |
|||
| 101 | -832x | +|||
| 162 | +
- res <- checkmate::check_character(levels(x), min.chars = 1)+ strata = NULL |
|||
| 102 | +163 |
- }+ ), |
||
| 103 | +164 |
-
+ response_definition = "response") {
|
||
| 104 | -846x | +165 | +62x |
- return(res)+ assert_df_with_variables(data, variables) |
| 105 | -+ | |||
| 166 | +62x |
- }+ checkmate::assert_subset(names(variables), c("response", "arm", "covariates", "interaction", "strata"))
|
||
| 106 | -+ | |||
| 167 | +62x |
- #' @describeIn assertions Check whether `x` is a valid factor (i.e. has levels and no empty+ checkmate::assert_string(response_definition) |
||
| 107 | -+ | |||
| 168 | +62x |
- #' string levels). Note that `NULL` and `NA` elements are allowed.+ checkmate::assert_true(grepl("response", response_definition))
|
||
| 108 | +169 |
- #'+ |
||
| 109 | -+ | |||
| 170 | +62x |
- #' @keywords internal+ response_definition <- sub( |
||
| 110 | -+ | |||
| 171 | +62x |
- assert_valid_factor <- checkmate::makeAssertionFunction(check_valid_factor)+ pattern = "response", |
||
| 111 | -+ | |||
| 172 | +62x |
-
+ replacement = variables$response, |
||
| 112 | -+ | |||
| 173 | +62x |
-
+ x = response_definition, |
||
| 113 | -+ | |||
| 174 | +62x |
- check_df_with_factors <- function(df,+ fixed = TRUE |
||
| 114 | +175 |
- variables,+ ) |
||
| 115 | -+ | |||
| 176 | +62x |
- min.levels = 1, # nolint+ form <- paste0(response_definition, " ~ ", variables$arm) |
||
| 116 | -+ | |||
| 177 | +62x |
- max.levels = NULL, # nolint+ if (!is.null(variables$covariates)) {
|
||
| 117 | -+ | |||
| 178 | +28x |
- any.missing = TRUE, # nolint+ form <- paste0(form, " + ", paste(variables$covariates, collapse = " + ")) |
||
| 118 | +179 |
- na_level = NULL) {
+ } |
||
| 119 | -190x | +180 | +62x |
- res <- check_df_with_variables(df, variables, na_level)+ if (!is.null(variables$interaction)) {
|
| 120 | -+ | |||
| 181 | +17x |
- # checking if all the columns specified by variables are valid factors+ checkmate::assert_string(variables$interaction) |
||
| 121 | -189x | +182 | +17x |
- if (isTRUE(res)) {
+ checkmate::assert_subset(variables$interaction, variables$covariates) |
| 122 | -+ | |||
| 183 | +17x |
- # searching the data.frame with selected columns (variables) as a list+ form <- paste0(form, " + ", variables$arm, ":", variables$interaction) |
||
| 123 | -187x | +|||
| 184 | +
- res <- lapply(+ } |
|||
| 124 | -187x | +185 | +62x |
- X = as.list(df)[unlist(variables)],+ if (!is.null(variables$strata)) {
|
| 125 | -187x | +186 | +14x |
- FUN = check_valid_factor,+ strata_arg <- if (length(variables$strata) > 1) {
|
| 126 | -187x | +187 | +7x |
- min.levels = min.levels,+ paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
|
| 127 | -187x | +|||
| 188 | +
- max.levels = max.levels,+ } else {
|
|||
| 128 | -187x | +|||
| 189 | +7x |
- any.missing = any.missing+ variables$strata |
||
| 129 | +190 |
- )+ } |
||
| 130 | -187x | +191 | +14x |
- res_lo <- unlist(vapply(res, Negate(isTRUE), logical(1)))+ form <- paste0(form, "+ strata(", strata_arg, ")")
|
| 131 | -187x | +|||
| 192 | +
- if (any(res_lo)) {
+ } |
|||
| 132 | -6x | +193 | +62x |
- return(paste0(+ formula <- stats::as.formula(form) |
| 133 | -6x | +194 | +62x |
- deparse(substitute(df)), " does not contain only factor variables among:",+ if (is.null(variables$strata)) {
|
| 134 | -6x | +195 | +48x |
- "\n* Column `", paste0(unlist(variables)[res_lo],+ stats::glm( |
| 135 | -6x | +196 | +48x |
- "` of the data.frame -> ", res[res_lo],+ formula = formula, |
| 136 | -6x | +197 | +48x |
- collapse = "\n* "+ data = data, |
| 137 | -+ | |||
| 198 | +48x |
- )+ family = stats::binomial("logit")
|
||
| 138 | +199 |
- ))+ ) |
||
| 139 | +200 |
- } else {
+ } else {
|
||
| 140 | -181x | +201 | +14x |
- res <- TRUE+ clogit_with_tryCatch( |
| 141 | -+ | |||
| 202 | +14x |
- }+ formula = formula, |
||
| 142 | -+ | |||
| 203 | +14x |
- }+ data = data, |
||
| 143 | -183x | +204 | +14x |
- return(res)+ x = TRUE |
| 144 | +205 |
- }+ ) |
||
| 145 | +206 |
- #' @describeIn assertions Check whether `df` is a data frame where the analysis `variables`+ } |
||
| 146 | +207 |
- #' are all factors. Note that the creation of `NA` by direct call of `factor()` will+ } |
||
| 147 | +208 |
- #' trim `NA` levels out of the vector list itself.+ |
||
| 148 | +209 |
- #'+ #' Custom Tidy Method for Binomial GLM Results |
||
| 149 | +210 |
- #' @keywords internal+ #' |
||
| 150 | +211 |
- assert_df_with_factors <- checkmate::makeAssertionFunction(check_df_with_factors)+ #' @description `r lifecycle::badge("stable")`
|
||
| 151 | +212 |
-
+ #' |
||
| 152 | +213 |
- #' @describeIn assertions Check whether `x` is a proportion: number between 0 and 1.+ #' Helper method (for [broom::tidy()]) to prepare a data frame from a `glm` object |
||
| 153 | +214 |
- #'+ #' with `binomial` family. |
||
| 154 | +215 |
- #' @keywords internal+ #' |
||
| 155 | +216 |
- assert_proportion_value <- function(x, include_boundaries = FALSE) {
- |
- ||
| 156 | -6861x | -
- checkmate::assert_number(x, lower = 0, upper = 1)- |
- ||
| 157 | -6849x | -
- checkmate::assert_flag(include_boundaries)+ #' @inheritParams argument_convention |
||
| 158 | -6849x | +|||
| 217 | +
- if (isFALSE(include_boundaries)) {
+ #' @param at (`NULL` or `numeric`)\cr optional values for the interaction variable. Otherwise the median is used. |
|||
| 159 | -2900x | +|||
| 218 | +
- checkmate::assert_true(x > 0)+ #' @param x logistic regression model fitted by [stats::glm()] with "binomial" family. |
|||
| 160 | -2898x | +|||
| 219 | +
- checkmate::assert_true(x < 1)+ #' |
|||
| 161 | +220 |
- }+ #' @return A `data.frame` containing the tidied model. |
||
| 162 | +221 |
- }+ #' |
| 1 | +222 |
- #' Summary for analysis of covariance (`ANCOVA`).+ #' @method tidy glm |
||
| 2 | +223 |
#' |
||
| 3 | +224 |
- #' @description `r lifecycle::badge("stable")`
+ #' @seealso [h_logistic_regression] for relevant helper functions. |
||
| 4 | +225 |
#' |
||
| 5 | +226 |
- #' Summarize results of `ANCOVA`. This can be used to analyze multiple endpoints and/or+ #' @examples |
||
| 6 | +227 |
- #' multiple timepoints within the same response variable `.var`.+ #' library(dplyr) |
||
| 7 | +228 |
- #'+ #' library(broom) |
||
| 8 | +229 |
- #' @inheritParams argument_convention+ #' |
||
| 9 | +230 |
- #'+ #' adrs_f <- tern_ex_adrs %>% |
||
| 10 | +231 |
- #' @name summarize_ancova+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 11 | +232 |
- NULL+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
|
||
| 12 | +233 |
-
+ #' mutate( |
||
| 13 | +234 |
- #' Helper Function to Return Results of a Linear Model+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
||
| 14 | +235 |
- #'+ #' RACE = factor(RACE), |
||
| 15 | +236 |
- #' @description `r lifecycle::badge("stable")`
+ #' SEX = factor(SEX) |
||
| 16 | +237 |
- #'+ #' ) |
||
| 17 | +238 |
- #' @inheritParams argument_convention+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
||
| 18 | +239 |
- #' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called in `.var` and `variables`.+ #' mod1 <- fit_logistic( |
||
| 19 | +240 |
- #' @param variables (named `list` of `strings`)\cr list of additional analysis variables, with expected elements:+ #' data = adrs_f, |
||
| 20 | +241 |
- #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be+ #' variables = list( |
||
| 21 | +242 |
- #' summarized. Specifically, the first level of `arm` variable is taken as the reference group.+ #' response = "Response", |
||
| 22 | +243 |
- #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as `"X1"`), and/or+ #' arm = "ARMCD", |
||
| 23 | +244 |
- #' interaction terms indicated by `"X1 * X2"`.+ #' covariates = c("AGE", "RACE")
|
||
| 24 | +245 |
- #' @param interaction_item (`character`)\cr name of the variable that should have interactions+ #' ) |
||
| 25 | +246 |
- #' with arm. if the interaction is not needed, the default option is `NULL`.+ #' ) |
||
| 26 | +247 |
- #'+ #' mod2 <- fit_logistic( |
||
| 27 | +248 |
- #' @return The summary of a linear model.+ #' data = adrs_f, |
||
| 28 | +249 |
- #'+ #' variables = list( |
||
| 29 | +250 |
- #' @examples+ #' response = "Response", |
||
| 30 | +251 |
- #' h_ancova(+ #' arm = "ARMCD", |
||
| 31 | +252 |
- #' .var = "Sepal.Length",+ #' covariates = c("AGE", "RACE"),
|
||
| 32 | +253 |
- #' .df_row = iris,+ #' interaction = "AGE" |
||
| 33 | +254 |
- #' variables = list(arm = "Species", covariates = c("Petal.Length * Petal.Width", "Sepal.Width"))
+ #' ) |
||
| 34 | +255 |
#' ) |
||
| 35 | +256 |
#' |
||
| 36 | +257 |
- #' @export+ #' df <- tidy(mod1, conf_level = 0.99) |
||
| 37 | +258 |
- h_ancova <- function(.var,+ #' df2 <- tidy(mod2, conf_level = 0.99) |
||
| 38 | +259 |
- .df_row,+ #' |
||
| 39 | +260 |
- variables,+ #' @export |
||
| 40 | +261 |
- interaction_item = NULL) {
- |
- ||
| 41 | -15x | -
- checkmate::assert_string(.var)- |
- ||
| 42 | -15x | -
- checkmate::assert_list(variables)- |
- ||
| 43 | -15x | -
- checkmate::assert_subset(names(variables), c("arm", "covariates"))
- |
- ||
| 44 | -15x | -
- assert_df_with_variables(.df_row, list(rsp = .var))+ tidy.glm <- function(x, # nolint |
||
| 45 | +262 | - - | -||
| 46 | -14x | -
- arm <- variables$arm- |
- ||
| 47 | -14x | -
- covariates <- variables$covariates+ conf_level = 0.95, |
||
| 48 | -14x | +|||
| 263 | +
- if (!is.null(covariates) && length(covariates) > 0) {
+ at = NULL, |
|||
| 49 | +264 |
- # Get all covariate variable names in the model.+ ...) {
|
||
| 50 | -11x | +265 | +5x |
- var_list <- get_covariates(covariates)+ checkmate::assert_class(x, "glm") |
| 51 | -11x | -
- assert_df_with_variables(.df_row, var_list)- |
- ||
| 52 | -+ | 266 | +5x |
- }+ checkmate::assert_set_equal(x$family$family, "binomial") |
| 53 | +267 | |||
| 54 | -13x | +268 | +5x |
- covariates_part <- paste(covariates, collapse = " + ")+ terms_name <- attr(stats::terms(x), "term.labels") |
| 55 | -13x | +269 | +5x |
- if (covariates_part != "") {
+ xs_class <- attr(x$terms, "dataClasses") |
| 56 | -10x | -
- formula <- stats::as.formula(paste0(.var, " ~ ", covariates_part, " + ", arm))- |
- ||
| 57 | -+ | 270 | +5x |
- } else {
+ interaction <- terms_name[which(!terms_name %in% names(xs_class))] |
| 58 | -3x | -
- formula <- stats::as.formula(paste0(.var, " ~ ", arm))- |
- ||
| 59 | -- |
- }- |
- ||
| 60 | -+ | 271 | +5x |
-
+ df <- if (length(interaction) == 0) {
|
| 61 | -13x | +272 | +2x |
- if (is.null(interaction_item)) {
+ h_logistic_simple_terms( |
| 62 | -9x | +273 | +2x |
- specs <- arm+ x = terms_name, |
| 63 | -+ | |||
| 274 | +2x |
- } else {
+ fit_glm = x, |
||
| 64 | -4x | +275 | +2x |
- specs <- c(arm, interaction_item)+ conf_level = conf_level |
| 65 | +276 |
- }+ ) |
||
| 66 | +277 |
-
+ } else {
|
||
| 67 | -13x | +278 | +3x |
- lm_fit <- stats::lm(+ h_logistic_inter_terms( |
| 68 | -13x | +279 | +3x |
- formula = formula,+ x = terms_name, |
| 69 | -13x | -
- data = .df_row- |
- ||
| 70 | -+ | 280 | +3x |
- )+ fit_glm = x, |
| 71 | -13x | +281 | +3x |
- emmeans_fit <- emmeans::emmeans(+ conf_level = conf_level, |
| 72 | -13x | +282 | +3x |
- lm_fit,+ at = at |
| 73 | +283 |
- # Specify here the group variable over which EMM are desired.- |
- ||
| 74 | -13x | -
- specs = specs,+ ) |
||
| 75 | +284 |
- # Pass the data again so that the factor levels of the arm variable can be inferred.+ } |
||
| 76 | -13x | +285 | +5x |
- data = .df_row+ for (var in c("variable", "term", "interaction", "reference")) {
|
| 77 | -+ | |||
| 286 | +20x |
- )+ df[[var]] <- factor(df[[var]], levels = unique(df[[var]])) |
||
| 78 | +287 |
-
+ } |
||
| 79 | -13x | +288 | +5x |
- emmeans_fit+ df |
| 80 | +289 |
} |
||
| 81 | +290 | |||
| 82 | +291 |
- #' @describeIn summarize_ancova Statistics function that produces a named list of results+ #' Logistic Regression Multivariate Column Layout Function |
||
| 83 | +292 |
- #' of the investigated linear model.+ #' |
||
| 84 | +293 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 85 | +294 |
- #' @inheritParams h_ancova+ #' |
||
| 86 | +295 |
- #' @param interaction_y (`character`)\cr a selected item inside of the interaction_item column which will be used+ #' Layout-creating function which creates a multivariate column layout summarizing logistic |
||
| 87 | +296 |
- #' to select the specific `ANCOVA` results. if the interaction is not needed, the default option is `FALSE`.+ #' regression results. This function is a wrapper for [rtables::split_cols_by_multivar()]. |
||
| 88 | +297 |
#' |
||
| 89 | +298 |
- #' @return+ #' @inheritParams argument_convention |
||
| 90 | +299 |
- #' * `s_ancova()` returns a named list of 5 statistics:+ #' |
||
| 91 | +300 |
- #' * `n`: Count of complete sample size for the group.+ #' @return A layout object suitable for passing to further layouting functions. Adding this |
||
| 92 | +301 |
- #' * `lsmean`: Estimated marginal means in the group.+ #' function to an `rtable` layout will split the table into columns corresponding to |
||
| 93 | +302 |
- #' * `lsmean_diff`: Difference in estimated marginal means in comparison to the reference group.+ #' statistics `df`, `estimate`, `std_error`, `odds_ratio`, `ci`, and `pvalue`. |
||
| 94 | +303 |
- #' If working with the reference group, this will be empty.+ #' |
||
| 95 | +304 |
- #' * `lsmean_diff_ci`: Confidence level for difference in estimated marginal means in comparison+ #' @export |
||
| 96 | +305 |
- #' to the reference group.+ logistic_regression_cols <- function(lyt, |
||
| 97 | +306 |
- #' * `pval`: p-value (not adjusted for multiple comparisons).+ conf_level = 0.95) {
|
||
| 98 | -+ | |||
| 307 | +4x |
- #'+ vars <- c("df", "estimate", "std_error", "odds_ratio", "ci", "pvalue")
|
||
| 99 | -+ | |||
| 308 | +4x |
- #' @examples+ var_labels <- c( |
||
| 100 | -+ | |||
| 309 | +4x |
- #' library(dplyr)+ df = "Degrees of Freedom", |
||
| 101 | -+ | |||
| 310 | +4x |
- #'+ estimate = "Parameter Estimate", |
||
| 102 | -+ | |||
| 311 | +4x |
- #' df <- iris %>% filter(Species == "virginica")+ std_error = "Standard Error", |
||
| 103 | -+ | |||
| 312 | +4x |
- #' .df_row <- iris+ odds_ratio = "Odds Ratio", |
||
| 104 | -+ | |||
| 313 | +4x |
- #' .var <- "Petal.Length"+ ci = paste("Wald", f_conf_level(conf_level)),
|
||
| 105 | -+ | |||
| 314 | +4x |
- #' variables <- list(arm = "Species", covariates = "Sepal.Length * Sepal.Width")+ pvalue = "p-value" |
||
| 106 | +315 |
- #' .ref_group <- iris %>% filter(Species == "setosa")+ ) |
||
| 107 | -+ | |||
| 316 | +4x |
- #' conf_level <- 0.95+ split_cols_by_multivar( |
||
| 108 | -+ | |||
| 317 | +4x |
- #'+ lyt = lyt, |
||
| 109 | -+ | |||
| 318 | +4x |
- #' @keywords internal+ vars = vars, |
||
| 110 | -+ | |||
| 319 | +4x |
- s_ancova <- function(df,+ varlabels = var_labels |
||
| 111 | +320 |
- .var,+ ) |
||
| 112 | +321 |
- .df_row,+ } |
||
| 113 | +322 |
- variables,+ |
||
| 114 | +323 |
- .ref_group,+ #' Logistic Regression Summary Table Constructor Function |
||
| 115 | +324 |
- .in_ref_col,+ #' |
||
| 116 | +325 |
- conf_level,+ #' @description `r lifecycle::badge("stable")`
|
||
| 117 | +326 |
- interaction_y = FALSE,+ #' |
||
| 118 | +327 |
- interaction_item = NULL) {
- |
- ||
| 119 | -3x | -
- emmeans_fit <- h_ancova(.var = .var, variables = variables, .df_row = .df_row, interaction_item = interaction_item)+ #' Constructor for content functions to be used in [`summarize_logistic()`] to summarize |
||
| 120 | +328 | - - | -||
| 121 | -3x | -
- sum_fit <- summary(+ #' logistic regression results. This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 122 | -3x | +|||
| 329 | +
- emmeans_fit,+ #' |
|||
| 123 | -3x | +|||
| 330 | +
- level = conf_level+ #' @inheritParams argument_convention |
|||
| 124 | +331 |
- )+ #' @param flag_var (`string`)\cr variable name identifying which row should be used in this |
||
| 125 | +332 |
-
+ #' content function. |
||
| 126 | -3x | +|||
| 333 | +
- arm <- variables$arm+ #' |
|||
| 127 | +334 |
-
+ #' @return A content function. |
||
| 128 | -3x | +|||
| 335 | +
- sum_level <- as.character(unique(df[[arm]]))+ #' |
|||
| 129 | +336 |
-
+ #' @export |
||
| 130 | +337 |
- # Ensure that there is only one element in sum_level.+ logistic_summary_by_flag <- function(flag_var, na_str = NA_character_, .indent_mods = NULL) {
|
||
| 131 | -3x | -
- checkmate::assert_scalar(sum_level)- |
- ||
| 132 | -+ | 338 | +10x |
-
+ checkmate::assert_string(flag_var) |
| 133 | -2x | +339 | +10x |
- sum_fit_level <- sum_fit[sum_fit[[arm]] == sum_level, ]+ function(lyt) {
|
| 134 | -+ | |||
| 340 | +10x |
-
+ cfun_list <- list( |
||
| 135 | -+ | |||
| 341 | +10x |
- # Get the index of the ref arm+ df = cfun_by_flag("df", flag_var, format = "xx.", .indent_mods = .indent_mods),
|
||
| 136 | -2x | +342 | +10x |
- if (interaction_y != FALSE) {
+ estimate = cfun_by_flag("estimate", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
|
| 137 | -1x | +343 | +10x |
- y <- unlist(df[(df[[interaction_item]] == interaction_y), .var])+ std_error = cfun_by_flag("std_error", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
|
| 138 | -+ | |||
| 344 | +10x |
- # convert characters selected in interaction_y into the numeric order+ odds_ratio = cfun_by_flag("odds_ratio", flag_var, format = ">999.99", .indent_mods = .indent_mods),
|
||
| 139 | -1x | +345 | +10x |
- interaction_y <- which(sum_fit_level[[interaction_item]] == interaction_y)+ ci = cfun_by_flag("ci", flag_var, format = format_extreme_values_ci(2L), .indent_mods = .indent_mods),
|
| 140 | -1x | +346 | +10x |
- sum_fit_level <- sum_fit_level[interaction_y, ]+ pvalue = cfun_by_flag("pvalue", flag_var, format = "x.xxxx | (<0.0001)", .indent_mods = .indent_mods)
|
| 141 | +347 |
- # if interaction is called, reset the index+ ) |
||
| 142 | -1x | +348 | +10x |
- ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])])+ summarize_row_groups( |
| 143 | -1x | +349 | +10x |
- ref_key <- tail(ref_key, n = 1)+ lyt = lyt, |
| 144 | -1x | +350 | +10x |
- ref_key <- (interaction_y - 1) * length(unique(.df_row[[arm]])) + ref_key+ cfun = cfun_list, |
| 145 | -+ | |||
| 351 | +10x |
- } else {
+ na_str = na_str |
||
| 146 | -1x | +|||
| 352 | +
- y <- df[[.var]]+ ) |
|||
| 147 | +353 |
- # Get the index of the ref arm when interaction is not called+ } |
||
| 148 | -1x | +|||
| 354 | +
- ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])])+ } |
|||
| 149 | -1x | +
| 1 | +
- ref_key <- tail(ref_key, n = 1)+ #' Re-implemented [range()] Default S3 method for numerical objects |
|||
| 150 | +2 |
- }+ #' |
||
| 151 | +3 |
-
+ #' This function returns `c(NA, NA)` instead of `c(-Inf, Inf)` for zero-length data |
||
| 152 | -2x | +|||
| 4 | +
- if (.in_ref_col) {
+ #' without any warnings. |
|||
| 153 | -1x | +|||
| 5 | +
- list(+ #' |
|||
| 154 | -1x | +|||
| 6 | +
- n = length(y[!is.na(y)]),+ #' @param x (`numeric`)\cr a sequence of numbers for which the range is computed. |
|||
| 155 | -1x | +|||
| 7 | +
- lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"),+ #' @param na.rm (`logical`)\cr indicating if `NA` should be omitted. |
|||
| 156 | -1x | +|||
| 8 | +
- lsmean_diff = formatters::with_label(character(), "Difference in Adjusted Means"),+ #' @param finite (`logical`)\cr indicating if non-finite elements should be removed. |
|||
| 157 | -1x | +|||
| 9 | +
- lsmean_diff_ci = formatters::with_label(character(), f_conf_level(conf_level)),+ #' |
|||
| 158 | -1x | +|||
| 10 | +
- pval = formatters::with_label(character(), "p-value")+ #' @return A 2-element vector of class `numeric`. |
|||
| 159 | +11 |
- )+ #' |
||
| 160 | +12 |
- } else {
+ #' @keywords internal |
||
| 161 | +13 |
- # Estimate the differences between the marginal means.+ range_noinf <- function(x, na.rm = FALSE, finite = FALSE) { # nolint
|
||
| 162 | -1x | +|||
| 14 | +
- emmeans_contrasts <- emmeans::contrast(+ |
|||
| 163 | -1x | +15 | +799x |
- emmeans_fit,+ checkmate::assert_numeric(x) |
| 164 | +16 |
- # Compare all arms versus the control arm.+ |
||
| 165 | -1x | +17 | +799x |
- method = "trt.vs.ctrl",+ if (finite) {
|
| 166 | -+ | |||
| 18 | +24x |
- # Take the arm factor from .ref_group as the control arm.+ x <- x[is.finite(x)] # removes NAs too |
||
| 167 | -1x | +19 | +775x |
- ref = ref_key,+ } else if (na.rm) {
|
| 168 | -1x | +20 | +468x |
- level = conf_level+ x <- x[!is.na(x)] |
| 169 | +21 |
- )+ } |
||
| 170 | -1x | +|||
| 22 | +
- sum_contrasts <- summary(+ |
|||
| 171 | -1x | +23 | +799x |
- emmeans_contrasts,+ if (length(x) == 0) {
|
| 172 | -+ | |||
| 24 | +47x |
- # Derive confidence intervals, t-tests and p-values.+ rval <- c(NA, NA) |
||
| 173 | -1x | +25 | +47x |
- infer = TRUE,+ mode(rval) <- typeof(x) |
| 174 | +26 |
- # Do not adjust the p-values for multiplicity.+ } else {
|
||
| 175 | -1x | +27 | +752x |
- adjust = "none"+ rval <- c(min(x, na.rm = FALSE), max(x, na.rm = FALSE)) |
| 176 | +28 |
- )+ } |
||
| 177 | +29 | |||
| 178 | -1x | +30 | +799x |
- sum_contrasts_level <- sum_contrasts[grepl(sum_level, sum_contrasts$contrast), ]+ return(rval) |
| 179 | -1x | +|||
| 31 | +
- if (interaction_y != FALSE) {
+ } |
|||
| 180 | -! | +|||
| 32 | +
- sum_contrasts_level <- sum_contrasts_level[interaction_y, ]+ |
|||
| 181 | +33 |
- }+ #' Utility function to create label for confidence interval |
||
| 182 | +34 |
-
+ #' |
||
| 183 | -1x | +|||
| 35 | +
- list(+ #' @description `r lifecycle::badge("stable")`
|
|||
| 184 | -1x | +|||
| 36 | +
- n = length(y[!is.na(y)]),+ #' |
|||
| 185 | -1x | +|||
| 37 | +
- lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"),+ #' @inheritParams argument_convention |
|||
| 186 | -1x | +|||
| 38 | +
- lsmean_diff = formatters::with_label(sum_contrasts_level$estimate, "Difference in Adjusted Means"),+ #' |
|||
| 187 | -1x | +|||
| 39 | +
- lsmean_diff_ci = formatters::with_label(+ #' @return A `string`. |
|||
| 188 | -1x | +|||
| 40 | +
- c(sum_contrasts_level$lower.CL, sum_contrasts_level$upper.CL),+ #' |
|||
| 189 | -1x | +|||
| 41 | +
- f_conf_level(conf_level)+ #' @export |
|||
| 190 | +42 |
- ),+ f_conf_level <- function(conf_level) {
|
||
| 191 | -1x | +43 | +1197x |
- pval = formatters::with_label(sum_contrasts_level$p.value, "p-value")+ assert_proportion_value(conf_level)+ |
+
| 44 | +1195x | +
+ paste0(conf_level * 100, "% CI") |
||
| 192 | +45 |
- )+ } |
||
| 193 | +46 |
- }+ |
||
| 194 | +47 |
- }+ #' Utility function to create label for p-value |
||
| 195 | +48 |
-
+ #' |
||
| 196 | +49 |
- #' @describeIn summarize_ancova Formatted analysis function which is used as `afun` in `summarize_ancova()`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 197 | +50 |
#' |
||
| 198 | +51 |
- #' @return+ #' @param test_mean (`number`)\cr mean value to test under the null hypothesis. |
||
| 199 | +52 |
- #' * `a_ancova()` returns the corresponding list with formatted [rtables::CellValue()].+ #' |
||
| 200 | +53 |
- #'+ #' @return A `string`. |
||
| 201 | +54 |
#' |
||
| 202 | +55 |
- #' @keywords internal+ #' @export |
||
| 203 | +56 |
- a_ancova <- make_afun(+ f_pval <- function(test_mean) {
|
||
| 204 | -+ | |||
| 57 | +298x |
- s_ancova,+ checkmate::assert_numeric(test_mean, len = 1) |
||
| 205 | -+ | |||
| 58 | +296x |
- .indent_mods = c("n" = 0L, "lsmean" = 0L, "lsmean_diff" = 0L, "lsmean_diff_ci" = 1L, "pval" = 1L),
+ paste0("p-value (H0: mean = ", test_mean, ")")
|
||
| 206 | +59 |
- .formats = c(+ } |
||
| 207 | +60 |
- "n" = "xx",+ |
||
| 208 | +61 |
- "lsmean" = "xx.xx",+ #' Utility function to return a named list of covariate names. |
||
| 209 | +62 |
- "lsmean_diff" = "xx.xx",+ #' |
||
| 210 | +63 |
- "lsmean_diff_ci" = "(xx.xx, xx.xx)",+ #' @param covariates (`character`)\cr a vector that can contain single variable names (such as |
||
| 211 | +64 |
- "pval" = "x.xxxx | (<0.0001)"+ #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`. |
||
| 212 | +65 |
- ),+ #' |
||
| 213 | +66 |
- .null_ref_cells = FALSE+ #' @return A named `list` of `character` vector. |
||
| 214 | +67 |
- )+ #' |
||
| 215 | +68 |
-
+ #' @keywords internal |
||
| 216 | +69 |
- #' @describeIn summarize_ancova Layout-creating function which can take statistics function arguments+ get_covariates <- function(covariates) {
|
||
| 217 | -+ | |||
| 70 | +14x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ checkmate::assert_character(covariates) |
||
| 218 | -+ | |||
| 71 | +12x |
- #'+ cov_vars <- unique(trimws(unlist(strsplit(covariates, "\\*")))) |
||
| 219 | -+ | |||
| 72 | +12x |
- #' @return+ stats::setNames(as.list(cov_vars), cov_vars) |
||
| 220 | +73 |
- #' * `summarize_ancova()` returns a layout object suitable for passing to further layouting functions,+ } |
||
| 221 | +74 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
||
| 222 | +75 |
- #' the statistics from `s_ancova()` to the table layout.+ #' Replicate Entries of a Vector if Required |
||
| 223 | +76 |
#' |
||
| 224 | +77 |
- #' @examples+ #' @description `r lifecycle::badge("stable")`
|
||
| 225 | +78 |
- #' basic_table() %>%+ #' |
||
| 226 | +79 |
- #' split_cols_by("Species", ref_group = "setosa") %>%
+ #' Replicate entries of a vector if required. |
||
| 227 | +80 |
- #' add_colcounts() %>%+ #' |
||
| 228 | +81 |
- #' summarize_ancova(+ #' @inheritParams argument_convention |
||
| 229 | +82 |
- #' vars = "Petal.Length",+ #' @param n (`count`)\cr how many entries we need. |
||
| 230 | +83 |
- #' variables = list(arm = "Species", covariates = NULL),+ #' |
||
| 231 | +84 |
- #' table_names = "unadj",+ #' @return `x` if it has the required length already or is `NULL`, |
||
| 232 | +85 |
- #' conf_level = 0.95, var_labels = "Unadjusted comparison",+ #' otherwise if it is scalar the replicated version of it with `n` entries. |
||
| 233 | +86 |
- #' .labels = c(lsmean = "Mean", lsmean_diff = "Difference in Means")+ #' |
||
| 234 | +87 |
- #' ) %>%+ #' @note This function will fail if `x` is not of length `n` and/or is not a scalar. |
||
| 235 | +88 |
- #' summarize_ancova(+ #' |
||
| 236 | +89 |
- #' vars = "Petal.Length",+ #' @export |
||
| 237 | +90 |
- #' variables = list(arm = "Species", covariates = c("Sepal.Length", "Sepal.Width")),
+ to_n <- function(x, n) {
|
||
| 238 | -+ | |||
| 91 | +1x |
- #' table_names = "adj",+ if (is.null(x)) {
|
||
| 239 | -+ | |||
| 92 | +! |
- #' conf_level = 0.95, var_labels = "Adjusted comparison (covariates: Sepal.Length and Sepal.Width)"+ NULL |
||
| 240 | -+ | |||
| 93 | +1x |
- #' ) %>%+ } else if (length(x) == 1) {
+ |
+ ||
| 94 | +! | +
+ rep(x, n)+ |
+ ||
| 95 | +1x | +
+ } else if (length(x) == n) {
+ |
+ ||
| 96 | +1x | +
+ x |
||
| 241 | +97 |
- #' build_table(iris)+ } else {
+ |
+ ||
| 98 | +! | +
+ stop("dimension mismatch")
|
||
| 242 | +99 |
- #'+ } |
||
| 243 | +100 |
- #' @export+ } |
||
| 244 | +101 |
- summarize_ancova <- function(lyt,+ |
||
| 245 | +102 |
- vars,+ #' Check Element Dimension |
||
| 246 | +103 |
- var_labels,+ #' |
||
| 247 | +104 |
- nested = TRUE,+ #' Checks if the elements in `...` have the same dimension. |
||
| 248 | +105 |
- ...,+ #' |
||
| 249 | +106 |
- show_labels = "visible",+ #' @param ... (`data.frame`s or `vector`s)\cr any data frames/vectors. |
||
| 250 | +107 |
- table_names = vars,+ #' @param omit_null (`logical`)\cr whether `NULL` elements in `...` should be omitted from the check. |
||
| 251 | +108 |
- .stats = NULL,+ #' |
||
| 252 | +109 |
- .formats = NULL,+ #' @return A `logical` value. |
||
| 253 | +110 |
- .labels = NULL,+ #' |
||
| 254 | +111 |
- .indent_mods = NULL,+ #' @keywords internal |
||
| 255 | +112 |
- interaction_y = FALSE,+ check_same_n <- function(..., omit_null = TRUE) {
+ |
+ ||
| 113 | +2x | +
+ dots <- list(...) |
||
| 256 | +114 |
- interaction_item = NULL) {
+
|
||
| 257 | -3x | +115 | +2x |
- afun <- make_afun(+ n_list <- Map( |
| 258 | -3x | +116 | +2x |
- a_ancova,+ function(x, name) {
|
| 259 | -3x | +117 | +5x |
- interaction_y = interaction_y,+ if (is.null(x)) {
|
| 260 | -3x | +|||
| 118 | +! |
- interaction_item = interaction_item,+ if (omit_null) {
|
||
| 261 | -3x | +119 | +2x |
- .stats = .stats,+ NA_integer_+ |
+
| 120 | ++ |
+ } else {
+ |
+ ||
| 121 | +! | +
+ stop("arg", name, "is not supposed to be NULL")
+ |
+ ||
| 122 | ++ |
+ } |
||
| 262 | -3x | +123 | +5x |
- .formats = .formats,+ } else if (is.data.frame(x)) {
+ |
+
| 124 | +! | +
+ nrow(x) |
||
| 263 | -3x | +125 | +5x |
- .labels = .labels,+ } else if (is.atomic(x)) {
|
| 264 | -3x | +126 | +5x |
- .indent_mods = .indent_mods+ length(x) |
| 265 | +127 |
- )+ } else {
+ |
+ ||
| 128 | +! | +
+ stop("data structure for ", name, "is currently not supported")
|
||
| 266 | +129 |
-
+ } |
||
| 267 | -3x | +|||
| 130 | +
- analyze(+ }, |
|||
| 268 | -3x | +131 | +2x |
- lyt,+ dots, names(dots) |
| 269 | -3x | +|||
| 132 | +
- vars,+ ) |
|||
| 270 | -3x | +|||
| 133 | +
- var_labels = var_labels,+ |
|||
| 271 | -3x | +134 | +2x |
- show_labels = show_labels,+ n <- stats::na.omit(unlist(n_list)) |
| 272 | -3x | +|||
| 135 | +
- table_names = table_names,+ |
|||
| 273 | -3x | +136 | +2x |
- afun = afun,+ if (length(unique(n)) > 1) {
|
| 274 | -3x | +|||
| 137 | +! |
- nested = nested,+ sel <- which(n != n[1]) |
||
| 275 | -3x | +|||
| 138 | +! |
- extra_args = list(...)+ stop("dimension mismatch:", paste(names(n)[sel], collapse = ", "), " do not have N=", n[1])
|
||
| 276 | +139 |
- )+ } |
||
| 277 | +140 |
- }+ + |
+ ||
| 141 | +2x | +
+ TRUE |
| 1 | +142 |
- #' Counting Patients Summing Exposure Across All Patients in Columns+ } |
||
| 2 | +143 |
- #'+ |
||
| 3 | +144 |
- #' @description `r lifecycle::badge("stable")`
+ #' Make Names Without Dots |
||
| 4 | +145 |
#' |
||
| 5 | +146 |
- #' Counting the number of patients and summing analysis value (i.e exposure values) across all patients+ #' @param nams (`character`)\cr vector of original names. |
||
| 6 | +147 |
- #' when a column table layout is required.+ #' |
||
| 7 | +148 |
- #'+ #' @return A `character` `vector` of proper names, which does not use dots in contrast to [make.names()]. |
||
| 8 | +149 |
- #' @inheritParams argument_convention+ #' |
||
| 9 | +150 |
- #'+ #' @keywords internal |
||
| 10 | +151 |
- #' @name summarize_patients_exposure_in_cols+ make_names <- function(nams) {
+ |
+ ||
| 152 | +6x | +
+ orig <- make.names(nams)+ |
+ ||
| 153 | +6x | +
+ gsub(".", "", x = orig, fixed = TRUE)
|
||
| 11 | +154 |
- NULL+ } |
||
| 12 | +155 | |||
| 13 | +156 |
- #' @describeIn summarize_patients_exposure_in_cols Statistics function which counts numbers+ #' Conversion of Months to Days |
||
| 14 | +157 |
- #' of patients and the sum of exposure across all patients.+ #' |
||
| 15 | +158 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 16 | +159 |
- #' @param ex_var (`character`)\cr name of the variable within `df` containing exposure values.+ #' |
||
| 17 | +160 |
- #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will be used as label.+ #' Conversion of Months to Days. This is an approximative calculation because it |
||
| 18 | +161 |
- #'+ #' considers each month as having an average of 30.4375 days. |
||
| 19 | +162 |
- #' @return+ #' |
||
| 20 | +163 |
- #' * `s_count_patients_sum_exposure()` returns a named `list` with the statistics:+ #' @param x (`numeric`)\cr time in months. |
||
| 21 | +164 |
- #' * `n_patients`: Number of unique patients in `df`.+ #' |
||
| 22 | +165 |
- #' * `sum_exposure`: Sum of `ex_var` across all patients in `df`.+ #' @return A `numeric` vector with the time in days. |
||
| 23 | +166 |
#' |
||
| 24 | +167 |
#' @examples |
||
| 25 | +168 |
- #' set.seed(1)+ #' x <- c(13.25, 8.15, 1, 2.834) |
||
| 26 | +169 |
- #' df <- data.frame(+ #' month2day(x) |
||
| 27 | +170 |
- #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
+ #' |
||
| 28 | +171 |
- #' ARMCD = c(rep("ARM A", 6), rep("ARM B", 6)),
+ #' @export |
||
| 29 | +172 |
- #' SEX = c(rep("Female", 6), rep("Male", 6)),
+ month2day <- function(x) {
+ |
+ ||
| 173 | +1x | +
+ checkmate::assert_numeric(x)+ |
+ ||
| 174 | +1x | +
+ x * 30.4375 |
||
| 30 | +175 |
- #' AVAL = as.numeric(sample(seq(1, 20), 12)),+ } |
||
| 31 | +176 |
- #' stringsAsFactors = TRUE+ |
||
| 32 | +177 |
- #' )+ #' Conversion of Days to Months |
||
| 33 | +178 |
- #' adsl <- data.frame(+ #' |
||
| 34 | +179 |
- #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
+ #' @param x (`numeric`)\cr time in days. |
||
| 35 | +180 |
- #' ARMCD = c(rep("ARM A", 2), rep("ARM B", 2)),
+ #' |
||
| 36 | +181 |
- #' SEX = c(rep("Female", 2), rep("Male", 2)),
+ #' @return A `numeric` vector with the time in months. |
||
| 37 | +182 |
- #' stringsAsFactors = TRUE+ #' |
||
| 38 | +183 |
- #' )+ #' @examples |
||
| 39 | +184 |
- #'+ #' x <- c(403, 248, 30, 86) |
||
| 40 | +185 |
- #' @keywords internal+ #' day2month(x) |
||
| 41 | +186 |
- s_count_patients_sum_exposure <- function(df,+ #' |
||
| 42 | +187 |
- ex_var = "AVAL",+ #' @export |
||
| 43 | +188 |
- id = "USUBJID",+ day2month <- function(x) {
+ |
+ ||
| 189 | +15x | +
+ checkmate::assert_numeric(x)+ |
+ ||
| 190 | +15x | +
+ x / 30.4375 |
||
| 44 | +191 |
- labelstr = "",+ } |
||
| 45 | +192 |
- .stats = c("n_patients", "sum_exposure"),
+
|
||
| 46 | +193 |
- .N_col, # nolint+ #' Return an empty numeric if all elements are `NA`. |
||
| 47 | +194 |
- custom_label = NULL) {
+ #' |
||
| 48 | -56x | +|||
| 195 | +
- assert_df_with_variables(df, list(ex_var = ex_var, id = id))+ #' @param x (`numeric`)\cr vector. |
|||
| 49 | -56x | +|||
| 196 | +
- checkmate::assert_string(id)+ #' |
|||
| 50 | -56x | +|||
| 197 | +
- checkmate::assert_string(labelstr)+ #' @return An empty `numeric` if all elements of `x` are `NA`, otherwise `x`. |
|||
| 51 | -56x | +|||
| 198 | +
- checkmate::assert_string(custom_label, null.ok = TRUE)+ #' |
|||
| 52 | -56x | +|||
| 199 | +
- checkmate::assert_numeric(df[[ex_var]])+ #' @examples |
|||
| 53 | -56x | +|||
| 200 | +
- checkmate::assert_true(all(.stats %in% c("n_patients", "sum_exposure")))
+ #' x <- c(NA, NA, NA) |
|||
| 54 | +201 |
-
+ #' # Internal function - empty_vector_if_na |
||
| 55 | -56x | +|||
| 202 | +
- row_label <- if (labelstr != "") {
+ #' @keywords internal |
|||
| 56 | -! | +|||
| 203 | +
- labelstr+ empty_vector_if_na <- function(x) {
|
|||
| 57 | -56x | +204 | +683x |
- } else if (!is.null(custom_label)) {
+ if (all(is.na(x))) {
|
| 58 | -48x | +205 | +220x |
- custom_label+ numeric() |
| 59 | +206 |
} else {
|
||
| 60 | -8x | +207 | +463x |
- "Total patients numbers/person time"+ x |
| 61 | +208 |
} |
||
| 62 | +209 | - - | -||
| 63 | -56x | -
- y <- list()+ } |
||
| 64 | +210 | |||
| 65 | -56x | +|||
| 211 | +
- if ("n_patients" %in% .stats) {
+ #' Combine Two Vectors Element Wise |
|||
| 66 | -23x | +|||
| 212 | +
- y$n_patients <-+ #' |
|||
| 67 | -23x | +|||
| 213 | +
- formatters::with_label(+ #' @param x (`vector`)\cr first vector to combine. |
|||
| 68 | -23x | +|||
| 214 | +
- s_num_patients_content(+ #' @param y (`vector`)\cr second vector to combine. |
|||
| 69 | -23x | +|||
| 215 | +
- df = df,+ #' |
|||
| 70 | -23x | +|||
| 216 | +
- .N_col = .N_col, # nolint+ #' @return A `list` where each element combines corresponding elements of `x` and `y`. |
|||
| 71 | -23x | +|||
| 217 | +
- .var = id,+ #' |
|||
| 72 | -23x | +|||
| 218 | +
- labelstr = ""+ #' @examples |
|||
| 73 | -23x | +|||
| 219 | +
- )$unique,+ #' combine_vectors(1:3, 4:6) |
|||
| 74 | -23x | +|||
| 220 | +
- row_label+ #' |
|||
| 75 | +221 |
- )+ #' @export |
||
| 76 | +222 |
- }+ combine_vectors <- function(x, y) {
|
||
| 77 | -56x | +223 | +49x |
- if ("sum_exposure" %in% .stats) {
+ checkmate::assert_vector(x) |
| 78 | -34x | +224 | +49x |
- y$sum_exposure <- formatters::with_label(sum(df[[ex_var]]), row_label)+ checkmate::assert_vector(y, len = length(x)) |
| 79 | +225 |
- }+ |
||
| 80 | -56x | +226 | +49x |
- y+ result <- lapply(as.data.frame(rbind(x, y)), `c`) |
| 81 | -+ | |||
| 227 | +49x |
- }+ names(result) <- NULL |
||
| 82 | -+ | |||
| 228 | +49x |
-
+ result |
||
| 83 | +229 |
- #' @describeIn summarize_patients_exposure_in_cols Analysis function which is used as `afun` in+ } |
||
| 84 | +230 |
- #' [rtables::analyze_colvars()] within `analyze_patients_exposure_in_cols()` and as `cfun` in+ |
||
| 85 | +231 |
- #' [rtables::summarize_row_groups()] within `summarize_patients_exposure_in_cols()`.+ #' Extract Elements by Name |
||
| 86 | +232 |
#' |
||
| 87 | +233 |
- #' @return+ #' This utility function extracts elements from a vector `x` by `names`. |
||
| 88 | +234 |
- #' * `a_count_patients_sum_exposure()` returns formatted [rtables::CellValue()].+ #' Differences to the standard `[` function are: |
||
| 89 | +235 |
#' |
||
| 90 | -- |
- #' @examples- |
- ||
| 91 | +236 |
- #' a_count_patients_sum_exposure(+ #' - If `x` is `NULL`, then still always `NULL` is returned (same as in base function). |
||
| 92 | +237 |
- #' df = df,+ #' - If `x` is not `NULL`, then the intersection of its names is made with `names` and those |
||
| 93 | +238 |
- #' var = "SEX",+ #' elements are returned. That is, `names` which don't appear in `x` are not returned as `NA`s. |
||
| 94 | +239 |
- #' .N_col = nrow(df),+ #' |
||
| 95 | +240 |
- #' .stats = "n_patients"+ #' @param x (named `vector`)\cr where to extract named elements from. |
||
| 96 | +241 |
- #' )+ #' @param names (`character`)\cr vector of names to extract. |
||
| 97 | +242 |
#' |
||
| 98 | +243 |
- #' @export+ #' @return `NULL` if `x` is `NULL`, otherwise the extracted elements from `x`. |
||
| 99 | +244 |
- a_count_patients_sum_exposure <- function(df,+ #' |
||
| 100 | +245 |
- var = NULL,+ #' @keywords internal |
||
| 101 | +246 |
- ex_var = "AVAL",+ extract_by_name <- function(x, names) {
|
||
| 102 | -+ | |||
| 247 | +5x |
- id = "USUBJID",+ if (is.null(x)) {
|
||
| 103 | -+ | |||
| 248 | +1x |
- labelstr = "",+ return(NULL) |
||
| 104 | +249 |
- add_total_level = FALSE,+ } |
||
| 105 | -+ | |||
| 250 | +4x |
- .N_col, # nolint+ checkmate::assert_named(x) |
||
| 106 | -+ | |||
| 251 | +4x |
- .stats,+ checkmate::assert_character(names) |
||
| 107 | -+ | |||
| 252 | +4x |
- .formats = list(n_patients = "xx (xx.x%)", sum_exposure = "xx"),+ which_extract <- intersect(names(x), names) |
||
| 108 | -+ | |||
| 253 | +4x |
- custom_label = NULL) {
+ if (length(which_extract) > 0) {
|
||
| 109 | -32x | +254 | +3x |
- checkmate::assert_flag(add_total_level)+ x[which_extract] |
| 110 | +255 |
-
+ } else {
|
||
| 111 | -32x | +256 | +1x |
- if (!is.null(var)) {
+ NULL |
| 112 | -21x | +|||
| 257 | +
- assert_df_with_variables(df, list(var = var))+ } |
|||
| 113 | -21x | +|||
| 258 | +
- df[[var]] <- as.factor(df[[var]])+ } |
|||
| 114 | +259 |
- }+ |
||
| 115 | +260 |
-
+ #' Labels for Adverse Event Baskets |
||
| 116 | -32x | +|||
| 261 | +
- y <- list()+ #' |
|||
| 117 | -32x | +|||
| 262 | +
- if (is.null(var)) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 118 | -11x | +|||
| 263 | +
- y[[.stats]] <- list(Total = s_count_patients_sum_exposure(+ #' |
|||
| 119 | -11x | +|||
| 264 | +
- df = df,+ #' @param aesi (`character`)\cr with standardized `MedDRA` query name (e.g. `SMQzzNAM`) or customized query |
|||
| 120 | -11x | +|||
| 265 | +
- ex_var = ex_var,+ #' name (e.g. `CQzzNAM`). |
|||
| 121 | -11x | +|||
| 266 | +
- id = id,+ #' @param scope (`character`)\cr with scope of query (e.g. `SMQzzSC`). |
|||
| 122 | -11x | +|||
| 267 | +
- labelstr = labelstr,+ #' |
|||
| 123 | -11x | +|||
| 268 | +
- .N_col = .N_col,+ #' @return A `string` with the standard label for the `AE` basket. |
|||
| 124 | -11x | +|||
| 269 | +
- .stats = .stats,+ #' |
|||
| 125 | -11x | +|||
| 270 | +
- custom_label = custom_label+ #' @examples |
|||
| 126 | -11x | +|||
| 271 | +
- )[[.stats]])+ #' adae <- tern_ex_adae |
|||
| 127 | +272 |
- } else {
+ #' |
||
| 128 | -21x | +|||
| 273 | +
- for (lvl in levels(df[[var]])) {
+ #' # Standardized query label includes scope. |
|||
| 129 | -42x | +|||
| 274 | +
- y[[.stats]][[lvl]] <- s_count_patients_sum_exposure(+ #' aesi_label(adae$SMQ01NAM, scope = adae$SMQ01SC) |
|||
| 130 | -42x | +|||
| 275 | +
- df = subset(df, get(var) == lvl),+ #' |
|||
| 131 | -42x | +|||
| 276 | +
- ex_var = ex_var,+ #' # Customized query label. |
|||
| 132 | -42x | +|||
| 277 | +
- id = id,+ #' aesi_label(adae$CQ01NAM) |
|||
| 133 | -42x | +|||
| 278 | +
- labelstr = labelstr,+ #' |
|||
| 134 | -42x | +|||
| 279 | +
- .N_col = .N_col,+ #' @export |
|||
| 135 | -42x | +|||
| 280 | +
- .stats = .stats,+ aesi_label <- function(aesi, scope = NULL) {
|
|||
| 136 | -42x | +281 | +3x |
- custom_label = lvl+ checkmate::assert_character(aesi) |
| 137 | -42x | +282 | +3x |
- )[[.stats]]+ checkmate::assert_character(scope, null.ok = TRUE) |
| 138 | -+ | |||
| 283 | +3x |
- }+ aesi_label <- obj_label(aesi) |
||
| 139 | -21x | +284 | +3x |
- if (add_total_level) {
+ aesi <- sas_na(aesi) |
| 140 | -2x | +285 | +3x |
- y[[.stats]][["Total"]] <- s_count_patients_sum_exposure(+ aesi <- unique(aesi)[!is.na(unique(aesi))] |
| 141 | -2x | +|||
| 286 | +
- df = df,+ |
|||
| 142 | -2x | +287 | +3x |
- ex_var = ex_var,+ lbl <- if (length(aesi) == 1 && !is.null(scope)) {
|
| 143 | -2x | +288 | +1x |
- id = id,+ scope <- sas_na(scope) |
| 144 | -2x | +289 | +1x |
- labelstr = labelstr,+ scope <- unique(scope)[!is.na(unique(scope))] |
| 145 | -2x | +290 | +1x |
- .N_col = .N_col,+ checkmate::assert_string(scope) |
| 146 | -2x | +291 | +1x |
- .stats = .stats,+ paste0(aesi, " (", scope, ")")
|
| 147 | -2x | +292 | +3x |
- custom_label = custom_label+ } else if (length(aesi) == 1 && is.null(scope)) {
|
| 148 | -2x | +293 | +1x |
- )[[.stats]]+ aesi |
| 149 | +294 |
- }+ } else {
+ |
+ ||
| 295 | +1x | +
+ aesi_label |
||
| 150 | +296 |
} |
||
| 151 | +297 | |||
| 152 | -32x | +298 | +3x |
- in_rows(.list = y[[.stats]], .formats = .formats[[.stats]])+ lbl |
| 153 | +299 |
} |
||
| 154 | +300 | |||
| 155 | +301 |
- #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics+ #' Indicate Study Arm Variable in Formula |
||
| 156 | +302 |
- #' function arguments and additional format arguments. This function is a wrapper for+ #' |
||
| 157 | +303 |
- #' [rtables::split_cols_by_multivar()] and [rtables::summarize_row_groups()].+ #' We use `study_arm` to indicate the study arm variable in `tern` formulas. |
||
| 158 | +304 |
#' |
||
| 159 | +305 |
- #' @return+ #' @param x arm information |
||
| 160 | +306 |
- #' * `summarize_patients_exposure_in_cols()` returns a layout object suitable for passing to further+ #' |
||
| 161 | +307 |
- #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will+ #' @return `x` |
||
| 162 | +308 |
- #' add formatted content rows, with the statistics from `s_count_patients_sum_exposure()` arranged in+ #' |
||
| 163 | +309 |
- #' columns, to the table layout.+ #' @keywords internal |
||
| 164 | +310 |
- #'+ study_arm <- function(x) {
+ |
+ ||
| 311 | +! | +
+ structure(x, varname = deparse(substitute(x))) |
||
| 165 | +312 |
- #' @examples+ } |
||
| 166 | +313 |
- #' lyt <- basic_table() %>%+ |
||
| 167 | +314 |
- #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE)+ #' Smooth Function with Optional Grouping |
||
| 168 | +315 |
- #' result <- build_table(lyt, df = df, alt_counts_df = adsl)+ #' |
||
| 169 | +316 |
- #' result+ #' @description `r lifecycle::badge("stable")`
|
||
| 170 | +317 |
#' |
||
| 171 | +318 |
- #' lyt2 <- basic_table() %>%+ #' This produces `loess` smoothed estimates of `y` with Student confidence intervals. |
||
| 172 | +319 |
- #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE, .stats = "sum_exposure")+ #' |
||
| 173 | +320 |
- #' result2 <- build_table(lyt2, df = df, alt_counts_df = adsl)+ #' @param df (`data.frame`)\cr data set containing all analysis variables. |
||
| 174 | +321 |
- #' result2+ #' @param x (`character`)\cr value with x column name. |
||
| 175 | +322 |
- #'+ #' @param y (`character`)\cr value with y column name. |
||
| 176 | +323 |
- #' @export+ #' @param groups (`character`)\cr vector with optional grouping variables names. |
||
| 177 | +324 |
- summarize_patients_exposure_in_cols <- function(lyt, # nolint+ #' @param level (`numeric`)\cr level of confidence interval to use (0.95 by default). |
||
| 178 | +325 |
- var,+ #' |
||
| 179 | +326 |
- ...,+ #' @return A `data.frame` with original `x`, smoothed `y`, `ylow`, and `yhigh`, and |
||
| 180 | +327 |
- .stats = c("n_patients", "sum_exposure"),
+ #' optional `groups` variables formatted as `factor` type. |
||
| 181 | +328 |
- .labels = c(n_patients = "Patients", sum_exposure = "Person time"),+ #' |
||
| 182 | +329 |
- .indent_mods = NULL,+ #' @export |
||
| 183 | +330 |
- col_split = TRUE) {
+ get_smooths <- function(df, x, y, groups = NULL, level = 0.95) {
|
||
| 184 | -3x | +331 | +5x |
- if (col_split) {
+ checkmate::assert_data_frame(df) |
| 185 | -3x | +332 | +5x |
- lyt <- split_cols_by_multivar(+ df_cols <- colnames(df) |
| 186 | -3x | +333 | +5x |
- lyt = lyt,+ checkmate::assert_string(x) |
| 187 | -3x | +334 | +5x |
- vars = rep(var, length(.stats)),+ checkmate::assert_subset(x, df_cols) |
| 188 | -3x | +335 | +5x |
- varlabels = .labels[.stats],+ checkmate::assert_numeric(df[[x]]) |
| 189 | -3x | -
- extra_args = list(.stats = .stats)- |
- ||
| 190 | -+ | 336 | +5x |
- )+ checkmate::assert_string(y) |
| 191 | -+ | |||
| 337 | +5x |
- }+ checkmate::assert_subset(y, df_cols) |
||
| 192 | -3x | +338 | +5x |
- summarize_row_groups(+ checkmate::assert_numeric(df[[y]]) |
| 193 | -3x | +|||
| 339 | +
- lyt = lyt,+ |
|||
| 194 | -3x | +340 | +5x |
- var = var,+ if (!is.null(groups)) {
|
| 195 | -3x | +341 | +4x |
- cfun = a_count_patients_sum_exposure,+ checkmate::assert_character(groups) |
| 196 | -3x | +342 | +4x |
- extra_args = list(...)+ checkmate::assert_subset(groups, df_cols) |
| 197 | +343 |
- )+ } |
||
| 198 | +344 |
- }+ |
||
| 199 | -+ | |||
| 345 | +5x |
-
+ smooths <- function(x, y) {
|
||
| 200 | -+ | |||
| 346 | +18x |
- #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics+ stats::predict(stats::loess(y ~ x), se = TRUE) |
||
| 201 | +347 |
- #' function arguments and additional format arguments. This function is a wrapper for+ } |
||
| 202 | +348 |
- #' [rtables::split_cols_by_multivar()] and [rtables::analyze_colvars()].+ |
||
| 203 | -+ | |||
| 349 | +5x |
- #'+ if (!is.null(groups)) {
|
||
| 204 | -+ | |||
| 350 | +4x |
- #' @param col_split (`flag`)\cr whether the columns should be split. Set to `FALSE` when the required+ cc <- stats::complete.cases(df[c(x, y, groups)]) |
||
| 205 | -+ | |||
| 351 | +4x |
- #' column split has been done already earlier in the layout pipe.+ df_c <- df[cc, c(x, y, groups)] |
||
| 206 | -+ | |||
| 352 | +4x |
- #'+ df_c_ordered <- df_c[do.call("order", as.list(df_c[, groups, drop = FALSE])), , drop = FALSE]
|
||
| 207 | -+ | |||
| 353 | +4x |
- #' @return+ df_c_g <- data.frame(Map(as.factor, df_c_ordered[groups])) |
||
| 208 | +354 |
- #' * `analyze_patients_exposure_in_cols()` returns a layout object suitable for passing to further+ |
||
| 209 | -+ | |||
| 355 | +4x |
- #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will+ df_smooth_raw <- |
||
| 210 | -+ | |||
| 356 | +4x |
- #' add formatted data rows, with the statistics from `s_count_patients_sum_exposure()` arranged in+ by(df_c_ordered, df_c_g, function(d) {
|
||
| 211 | -+ | |||
| 357 | +17x |
- #' columns, to the table layout.+ plx <- smooths(d[[x]], d[[y]]) |
||
| 212 | -+ | |||
| 358 | +17x |
- #'+ data.frame( |
||
| 213 | -+ | |||
| 359 | +17x |
- #' @note As opposed to [summarize_patients_exposure_in_cols()] which generates content rows,+ x = d[[x]], |
||
| 214 | -+ | |||
| 360 | +17x |
- #' `analyze_patients_exposure_in_cols()` generates data rows which will _not_ be repeated on multiple+ y = plx$fit, |
||
| 215 | -+ | |||
| 361 | +17x |
- #' pages when pagination is used.+ ylow = plx$fit - stats::qt(level, plx$df) * plx$se, |
||
| 216 | -+ | |||
| 362 | +17x |
- #'+ yhigh = plx$fit + stats::qt(level, plx$df) * plx$se |
||
| 217 | +363 |
- #' @examples+ ) |
||
| 218 | +364 |
- #' lyt3 <- basic_table() %>%+ }) |
||
| 219 | +365 |
- #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
+
|
||
| 220 | -+ | |||
| 366 | +4x |
- #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) %>%+ df_smooth <- do.call(rbind, df_smooth_raw) |
||
| 221 | -+ | |||
| 367 | +4x |
- #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE)+ df_smooth[groups] <- df_c_g |
||
| 222 | +368 |
- #' result3 <- build_table(lyt3, df = df, alt_counts_df = adsl)+ |
||
| 223 | -+ | |||
| 369 | +4x |
- #' result3+ df_smooth |
||
| 224 | +370 |
- #'+ } else {
|
||
| 225 | -+ | |||
| 371 | +1x |
- #' lyt4 <- basic_table() %>%+ cc <- stats::complete.cases(df[c(x, y)]) |
||
| 226 | -+ | |||
| 372 | +1x |
- #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
+ df_c <- df[cc, ] |
||
| 227 | -+ | |||
| 373 | +1x |
- #' summarize_patients_exposure_in_cols(+ plx <- smooths(df_c[[x]], df_c[[y]]) |
||
| 228 | +374 |
- #' var = "AVAL", col_split = TRUE,+ |
||
| 229 | -+ | |||
| 375 | +1x |
- #' .stats = "n_patients", custom_label = "some custom label"+ df_smooth <- data.frame( |
||
| 230 | -+ | |||
| 376 | +1x |
- #' ) %>%+ x = df_c[[x]], |
||
| 231 | -+ | |||
| 377 | +1x |
- #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE, ex_var = "AVAL")+ y = plx$fit, |
||
| 232 | -+ | |||
| 378 | +1x |
- #' result4 <- build_table(lyt4, df = df, alt_counts_df = adsl)+ ylow = plx$fit - stats::qt(level, plx$df) * plx$se, |
||
| 233 | -+ | |||
| 379 | +1x |
- #' result4+ yhigh = plx$fit + stats::qt(level, plx$df) * plx$se |
||
| 234 | +380 |
- #'+ ) |
||
| 235 | +381 |
- #' lyt5 <- basic_table() %>%+ |
||
| 236 | -+ | |||
| 382 | +1x |
- #' analyze_patients_exposure_in_cols(var = "SEX", col_split = TRUE, ex_var = "AVAL")+ df_smooth |
||
| 237 | +383 |
- #' result5 <- build_table(lyt5, df = df, alt_counts_df = adsl)+ } |
||
| 238 | +384 |
- #' result5+ } |
||
| 239 | +385 |
- #'+ |
||
| 240 | +386 |
- #' # Adding total levels and custom label+ #' Number of Available (Non-Missing Entries) in a Vector |
||
| 241 | +387 |
- #' lyt <- basic_table(+ #' |
||
| 242 | +388 |
- #' show_colcounts = TRUE+ #' Small utility function for better readability. |
||
| 243 | +389 |
- #' ) %>%+ #' |
||
| 244 | +390 |
- #' analyze_patients_exposure_in_cols(+ #' @param x (`any`)\cr vector in which to count non-missing values. |
||
| 245 | +391 |
- #' var = "ARMCD",+ #' |
||
| 246 | +392 |
- #' col_split = TRUE,+ #' @return Number of non-missing values. |
||
| 247 | +393 |
- #' add_total_level = TRUE,+ #' |
||
| 248 | +394 |
- #' custom_label = "TOTAL"+ #' @keywords internal |
||
| 249 | +395 |
- #' ) %>%+ n_available <- function(x) {
|
||
| 250 | -+ | |||
| 396 | +254x |
- #' append_topleft(c("", "Sex"))
+ sum(!is.na(x)) |
||
| 251 | +397 |
- #'+ } |
||
| 252 | +398 |
- #' tbl <- build_table(lyt, df = df, alt_counts_df = adsl)+ |
||
| 253 | +399 |
- #' tbl+ #' Reapply Variable Labels |
||
| 254 | +400 |
#' |
||
| 255 | +401 |
- #' @export+ #' This is a helper function that is used in tests. |
||
| 256 | +402 |
- analyze_patients_exposure_in_cols <- function(lyt, # nolint+ #' |
||
| 257 | +403 |
- var = NULL,+ #' @param x (`vector`)\cr vector of elements that needs new labels. |
||
| 258 | +404 |
- ex_var = "AVAL",+ #' @param varlabels (`character`)\cr vector of labels for `x`. |
||
| 259 | +405 |
- col_split = TRUE,+ #' @param ... further parameters to be added to the list. |
||
| 260 | +406 |
- add_total_level = FALSE,+ #' |
||
| 261 | +407 |
- .stats = c("n_patients", "sum_exposure"),
+ #' @return `x` with variable labels reapplied. |
||
| 262 | +408 |
- .labels = c(n_patients = "Patients", sum_exposure = "Person time"),+ #' |
||
| 263 | +409 |
- .indent_mods = 0L,+ #' @export |
||
| 264 | +410 |
- ...) {
- |
- ||
| 265 | -6x | -
- if (col_split) {
- |
- ||
| 266 | -4x | -
- lyt <- split_cols_by_multivar(- |
- ||
| 267 | -4x | -
- lyt = lyt,+ reapply_varlabels <- function(x, varlabels, ...) {
|
||
| 268 | -4x | +411 | +10x |
- vars = rep(ex_var, length(.stats)),+ named_labels <- c(as.list(varlabels), list(...)) |
| 269 | -4x | +412 | +10x |
- varlabels = .labels[.stats],+ formatters::var_labels(x)[names(named_labels)] <- as.character(named_labels) |
| 270 | -4x | +413 | +10x |
- extra_args = list(.stats = .stats)+ x |
| 271 | +414 |
- )+ } |
||
| 272 | +415 |
- }- |
- ||
| 273 | -6x | -
- lyt <- lyt %>% analyze_colvars(- |
- ||
| 274 | -6x | -
- afun = a_count_patients_sum_exposure,- |
- ||
| 275 | -6x | -
- indent_mod = .indent_mods,+ |
||
| 276 | -6x | +|||
| 416 | +
- extra_args = c(+ # Wrapper function of survival::clogit so that when model fitting failed, a more useful message would show |
|||
| 277 | -6x | +|||
| 417 | +
- list(+ clogit_with_tryCatch <- function(formula, data, ...) { # nolint
|
|||
| 278 | -6x | +418 | +30x |
- var = var,+ tryCatch( |
| 279 | -6x | +419 | +30x |
- ex_var = ex_var,+ survival::clogit(formula = formula, data = data, ...), |
| 280 | -6x | -
- add_total_level = add_total_level- |
- ||
| 281 | -- |
- ),- |
- ||
| 282 | -- |
- ...- |
- ||
| 283 | -+ | 420 | +30x |
- )+ error = function(e) stop("model not built successfully with survival::clogit")
|
| 284 | +421 |
) |
||
| 285 | -6x | -
- lyt- |
- ||
| 286 | +422 |
}@@ -117167,14 +116639,14 @@ tern coverage - 94.83% |
| 1 |
- #' Compare Variables Between Groups+ #' Summary for Poisson Negative Binomial. |
|||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' @description `r lifecycle::badge("experimental")`
|
|||
| 5 |
- #' Comparison with a reference group for different `x` objects.+ #' Summarize results of a Poisson Negative Binomial Regression. |
|||
| 6 |
- #'+ #' This can be used to analyze count and/or frequency data using a linear model. |
|||
| 7 |
- #' @inheritParams argument_convention+ #' |
|||
| 8 |
- #'+ #' @inheritParams argument_convention |
|||
| 9 |
- #' @note+ #' |
|||
| 10 |
- #' * For factor variables, `denom` for factor proportions can only be `n` since the purpose is to compare proportions+ #' @name summarize_glm_count |
|||
| 11 |
- #' between columns, therefore a row-based proportion would not make sense. Proportion based on `N_col` would+ NULL |
|||
| 12 |
- #' be difficult since we use counts for the chi-squared test statistic, therefore missing values should be accounted+ |
|||
| 13 |
- #' for as explicit factor levels.+ #' Helper Functions for Poisson Models. |
|||
| 14 |
- #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values+ #' |
|||
| 15 |
- #' set `na.rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit+ #' @description `r lifecycle::badge("experimental")`
|
|||
| 16 |
- #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the+ #' |
|||
| 17 |
- #' default `na_level` (`"<Missing>"`) will also be excluded when `na.rm` is set to `TRUE`.+ #' Helper functions that can be used to return the results of various Poisson models. |
|||
| 18 |
- #' * For character variables, automatic conversion to factor does not guarantee that the table+ #' |
|||
| 19 |
- #' will be generated correctly. In particular for sparse tables this very likely can fail.+ #' @inheritParams argument_convention |
|||
| 20 |
- #' Therefore it is always better to manually convert character variables to factors during pre-processing.+ #' |
|||
| 21 |
- #' * For `compare_vars()`, the column split must define a reference group via `ref_group` so that the comparison+ #' @seealso [summarize_glm_count] |
|||
| 22 |
- #' is well defined.+ #' |
|||
| 23 |
- #'+ #' @name h_glm_count |
|||
| 24 |
- #' @seealso Relevant constructor function [create_afun_compare()], [s_summary()] which is used internally+ NULL |
|||
| 25 |
- #' to compute a summary within `s_compare()`, and [a_compare()] which is used (with `compare = TRUE`) as the analysis+ |
|||
| 26 |
- #' function for `compare_vars()`.+ #' @describeIn h_glm_count Helper function to return results of a poisson model. |
|||
| 28 |
- #' @name compare_variables+ #' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called |
|||
| 29 |
- #' @include analyze_variables.R+ #' in `.var` and `variables`. |
|||
| 30 |
- NULL+ #' @param variables (named `list` of `strings`)\cr list of additional analysis variables, with |
|||
| 31 |
-
+ #' expected elements: |
|||
| 32 |
- #' @describeIn compare_variables S3 generic function to produce a comparison summary.+ #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple |
|||
| 33 |
- #'+ #' groups will be summarized. Specifically, the first level of `arm` variable is taken as the |
|||
| 34 |
- #' @return+ #' reference group. |
|||
| 35 |
- #' * `s_compare()` returns output of [s_summary()] and comparisons versus the reference group in the form of p-values.+ #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as |
|||
| 36 |
- #'+ #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`. |
|||
| 37 |
- #' @export+ #' * `offset` (`numeric`)\cr a numeric vector or scalar adding an offset. |
|||
| 38 |
- s_compare <- function(x,+ #' @param weights (`character`)\cr a character vector specifying weights used |
|||
| 39 |
- .ref_group,+ #' in averaging predictions. Number of weights must equal the number of levels included in the covariates. |
|||
| 40 |
- .in_ref_col,+ #' Weights option passed to [emmeans::emmeans()]. |
|||
| 41 |
- ...) {
+ #' |
|||
| 42 | -28x | +
- UseMethod("s_compare", x)
+ #' @return |
||
| 43 |
- }+ #' * `h_glm_poisson()` returns the results of a Poisson model. |
|||
| 44 |
-
+ #' |
|||
| 45 |
- #' @describeIn compare_variables Method for `numeric` class. This uses the standard t-test+ #' @keywords internal |
|||
| 46 |
- #' to calculate the p-value.+ h_glm_poisson <- function(.var, |
|||
| 47 |
- #'+ .df_row, |
|||
| 48 |
- #' @method s_compare numeric+ variables, |
|||
| 49 |
- #'+ weights) {
|
|||
| 50 | -+ | 12x |
- #' @examples+ arm <- variables$arm |
|
| 51 | -+ | 12x |
- #' # `s_compare.numeric`+ covariates <- variables$covariates |
|
| 52 | -+ | 12x |
- #'+ offset <- .df_row[[variables$offset]] |
|
| 53 |
- #' ## Usual case where both this and the reference group vector have more than 1 value.+ |
|||
| 54 | -+ | 10x |
- #' s_compare(rnorm(10, 5, 1), .ref_group = rnorm(5, -5, 1), .in_ref_col = FALSE)+ formula <- stats::as.formula(paste0( |
|
| 55 | -+ | 10x |
- #'+ .var, " ~ ", |
|
| 56 |
- #' ## If one group has not more than 1 value, then p-value is not calculated.+ " + ", |
|||
| 57 | -+ | 10x |
- #' s_compare(rnorm(10, 5, 1), .ref_group = 1, .in_ref_col = FALSE)+ paste(covariates, collapse = " + "), |
|
| 58 |
- #'+ " + ", |
|||
| 59 | -+ | 10x |
- #' ## Empty numeric does not fail, it returns NA-filled items and no p-value.+ arm |
|
| 60 |
- #' s_compare(numeric(), .ref_group = numeric(), .in_ref_col = FALSE)+ )) |
|||
| 61 |
- #'+ |
|||
| 62 | -+ | 10x |
- #' @export+ glm_fit <- stats::glm( |
|
| 63 | -+ | 10x |
- s_compare.numeric <- function(x,+ formula = formula, |
|
| 64 | -+ | 10x |
- .ref_group,+ offset = offset, |
|
| 65 | -+ | 10x |
- .in_ref_col,+ data = .df_row, |
|
| 66 | -+ | 10x |
- ...) {
+ family = stats::poisson(link = "log") |
|
| 67 | -12x | +
- checkmate::assert_numeric(x)+ ) |
||
| 68 | -12x | +
- checkmate::assert_numeric(.ref_group)+ |
||
| 69 | -12x | +10x |
- checkmate::assert_flag(.in_ref_col)+ emmeans_fit <- emmeans::emmeans( |
|
| 70 | -+ | 10x |
-
+ glm_fit, |
|
| 71 | -12x | +10x |
- y <- s_summary.numeric(x = x, ...)+ specs = arm, |
|
| 72 | -+ | 10x |
-
+ data = .df_row, |
|
| 73 | -12x | +10x |
- y$pval <- if (!.in_ref_col && n_available(x) > 1 && n_available(.ref_group) > 1) {
+ type = "response", |
|
| 74 | -9x | +10x |
- stats::t.test(x, .ref_group)$p.value+ offset = 0, |
|
| 75 | -+ | 10x |
- } else {
+ weights = weights |
|
| 76 | -3x | +
- character()+ ) |
||
| 77 |
- }+ |
|||
| 78 | -+ | 10x |
-
+ list( |
|
| 79 | -12x | +10x |
- y+ glm_fit = glm_fit, |
|
| 80 | -+ | 10x |
- }+ emmeans_fit = emmeans_fit |
|
| 81 |
-
+ ) |
|||
| 82 |
- #' @describeIn compare_variables Method for `factor` class. This uses the chi-squared test+ } |
|||
| 83 |
- #' to calculate the p-value.+ |
|||
| 84 |
- #'+ #' @describeIn h_glm_count Helper function to return results of a quasipoisson model. |
|||
| 85 |
- #' @param denom (`string`)\cr choice of denominator for factor proportions,+ #' |
|||
| 86 |
- #' can only be `n` (number of values in this row and column intersection).+ #' @inheritParams summarize_glm_count |
|||
| 88 |
- #' @method s_compare factor+ #' @return |
|||
| 89 |
- #'+ #' * `h_glm_quasipoisson()` returns the results of a Quasi-Poisson model. |
|||
| 90 |
- #' @examples+ #' |
|||
| 91 |
- #' # `s_compare.factor`+ #' |
|||
| 92 |
- #'+ #' @keywords internal |
|||
| 93 |
- #' ## Basic usage:+ h_glm_quasipoisson <- function(.var, |
|||
| 94 |
- #' x <- factor(c("a", "a", "b", "c", "a"))
+ .df_row, |
|||
| 95 |
- #' y <- factor(c("a", "b", "c"))
+ variables, |
|||
| 96 |
- #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE)+ weights) {
|
|||
| 97 | -+ | 4x |
- #'+ arm <- variables$arm |
|
| 98 | -+ | 4x |
- #' ## Management of NA values.+ covariates <- variables$covariates |
|
| 99 | -+ | 4x |
- #' x <- explicit_na(factor(c("a", "a", "b", "c", "a", NA, NA)))
+ offset <- .df_row[[variables$offset]] |
|
| 100 |
- #' y <- explicit_na(factor(c("a", "b", "c", NA)))
+
|
|||
| 101 | -+ | 2x |
- #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE)+ formula <- stats::as.formula(paste0( |
|
| 102 | -+ | 2x |
- #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE)+ .var, " ~ ", |
|
| 103 |
- #'+ " + ", |
|||
| 104 | -+ | 2x |
- #' @export+ paste(covariates, collapse = " + "), |
|
| 105 |
- s_compare.factor <- function(x,+ " + ", |
|||
| 106 | -+ | 2x |
- .ref_group,+ arm |
|
| 107 |
- .in_ref_col,+ )) |
|||
| 108 |
- denom = "n",+ |
|||
| 109 | -+ | 2x |
- na.rm = TRUE, # nolint+ glm_fit <- stats::glm( |
|
| 110 | -+ | 2x |
- ...) {
+ formula = formula, |
|
| 111 | -12x | +2x |
- checkmate::assert_flag(.in_ref_col)+ offset = offset, |
|
| 112 | -12x | +2x |
- assert_valid_factor(x)+ data = .df_row, |
|
| 113 | -12x | +2x |
- assert_valid_factor(.ref_group)+ family = stats::quasipoisson(link = "log") |
|
| 114 | -12x | +
- denom <- match.arg(denom)+ ) |
||
| 116 | -12x | +2x |
- y <- s_summary.factor(+ emmeans_fit <- emmeans::emmeans( |
|
| 117 | -12x | +2x |
- x = x,+ glm_fit, |
|
| 118 | -12x | +2x |
- denom = denom,+ specs = arm, |
|
| 119 | -12x | +2x |
- na.rm = na.rm,+ data = .df_row, |
|
| 120 | -+ | 2x |
- ...+ type = "response", |
|
| 121 | -+ | 2x |
- )+ offset = 0, |
|
| 122 | -+ | 2x |
-
+ weights = weights |
|
| 123 | -12x | +
- if (na.rm) {
+ ) |
||
| 124 | -12x | +
- x <- x[!is.na(x)] %>% fct_discard("<Missing>")
+
|
||
| 125 | -12x | +2x |
- .ref_group <- .ref_group[!is.na(.ref_group)] %>% fct_discard("<Missing>")
+ list( |
|
| 126 | -+ | 2x |
- } else {
+ glm_fit = glm_fit, |
|
| 127 | -! | +2x |
- x <- x %>% explicit_na(label = "NA")+ emmeans_fit = emmeans_fit |
|
| 128 | -! | +
- .ref_group <- .ref_group %>% explicit_na(label = "NA")+ ) |
||
| 129 |
- }+ } |
|||
| 131 | -! | +
- if ("NA" %in% levels(x)) levels(.ref_group) <- c(levels(.ref_group), "NA")
+ #' @describeIn h_glm_count Helper function to return the results of the |
||
| 132 | -12x | +
- checkmate::assert_factor(x, levels = levels(.ref_group), min.levels = 2)+ #' selected model (poisson, quasipoisson, negative binomial). |
||
| 133 |
-
+ #' |
|||
| 134 | -12x | +
- y$pval_counts <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
+ #' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called |
||
| 135 | -9x | +
- tab <- rbind(table(x), table(.ref_group))+ #' in `.var` and `variables`. |
||
| 136 | -9x | +
- res <- suppressWarnings(stats::chisq.test(tab))+ #' @param variables (named `list` of `strings`)\cr list of additional analysis variables, with |
||
| 137 | -9x | +
- res$p.value+ #' expected elements: |
||
| 138 |
- } else {
+ #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple |
|||
| 139 | -3x | +
- character()+ #' groups will be summarized. Specifically, the first level of `arm` variable is taken as the |
||
| 140 |
- }+ #' reference group. |
|||
| 141 |
-
+ #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as |
|||
| 142 | -12x | +
- y+ #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`. |
||
| 143 |
- }+ #' * `offset` (`numeric`)\cr a numeric vector or scalar adding an offset. |
|||
| 144 |
-
+ #' @param distribution (`character`)\cr a character value specifying the distribution |
|||
| 145 |
- #' @describeIn compare_variables Method for `character` class. This makes an automatic+ #' used in the regression (poisson, quasipoisson). |
|||
| 146 |
- #' conversion to `factor` (with a warning) and then forwards to the method for factors.+ #' |
|||
| 147 |
- #'+ #' @return |
|||
| 148 |
- #' @param verbose (`logical`)\cr Whether warnings and messages should be printed. Mainly used+ #' * `h_glm_count()` returns the results of the selected model. |
|||
| 149 |
- #' to print out information about factor casting. Defaults to `TRUE`.+ #' |
|||
| 151 |
- #' @method s_compare character+ #' @keywords internal |
|||
| 152 |
- #'+ h_glm_count <- function(.var, |
|||
| 153 |
- #' @examples+ .df_row, |
|||
| 154 |
- #' # `s_compare.character`+ variables, |
|||
| 155 |
- #'+ distribution, |
|||
| 156 |
- #' ## Basic usage:+ weights) {
|
|||
| 157 | -+ | 11x |
- #' x <- c("a", "a", "b", "c", "a")
+ if (distribution == "negbin") {
|
|
| 158 | -+ | ! |
- #' y <- c("a", "b", "c")
+ stop("negative binomial distribution is not currently available.")
|
|
| 159 |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, .var = "x", verbose = FALSE)+ } |
|||
| 160 | -+ | 9x |
- #'+ switch(distribution, |
|
| 161 | -+ | 9x |
- #' ## Note that missing values handling can make a large difference:+ poisson = h_glm_poisson(.var, .df_row, variables, weights), |
|
| 162 | -+ | ! |
- #' x <- c("a", "a", "b", "c", "a", NA)
+ quasipoisson = h_glm_quasipoisson(.var, .df_row, variables, weights), |
|
| 163 | -+ | ! |
- #' y <- c("a", "b", "c", rep(NA, 20))
+ negbin = list() # h_glm_negbin(.var, .df_row, variables, weights) # nolint |
|
| 164 |
- #' s_compare(x,+ ) |
|||
| 165 |
- #' .ref_group = y, .in_ref_col = FALSE,+ } |
|||
| 166 |
- #' .var = "x", verbose = FALSE+ |
|||
| 167 |
- #' )+ #' @describeIn h_glm_count Helper function to return the estimated means. |
|||
| 168 |
- #' s_compare(x,+ #' |
|||
| 169 |
- #' .ref_group = y, .in_ref_col = FALSE, .var = "x",+ #' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called in `.var` and `variables`. |
|||
| 170 |
- #' na.rm = FALSE, verbose = FALSE+ #' @param conf_level (`numeric`)\cr value used to derive the confidence interval for the rate. |
|||
| 171 |
- #' )+ #' @param obj (`glm.fit`)\cr fitted model object used to derive the mean rate estimates in each treatment arm. |
|||
| 172 |
- #'+ #' @param arm (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be |
|||
| 173 |
- #' @export+ #' summarized. Specifically, the first level of `arm` variable is taken as the reference group. |
|||
| 174 |
- s_compare.character <- function(x,+ #' |
|||
| 175 |
- .ref_group,+ #' @return |
|||
| 176 |
- .in_ref_col,+ #' * `h_ppmeans()` returns the estimated means. |
|||
| 177 |
- denom = "n",+ #' |
|||
| 178 |
- na.rm = TRUE, # nolint+ #' |
|||
| 179 |
- .var,+ #' @keywords internal |
|||
| 180 |
- verbose = TRUE,+ h_ppmeans <- function(obj, .df_row, arm, conf_level) {
|
|||
| 181 | -+ | ! |
- ...) {
+ alpha <- 1 - conf_level |
|
| 182 | -1x | +! |
- x <- as_factor_keep_attributes(x, verbose = verbose)+ p <- 1 - alpha / 2 |
|
| 183 | -1x | +
- .ref_group <- as_factor_keep_attributes(.ref_group, verbose = verbose)+ |
||
| 184 | -1x | +! |
- s_compare(+ arm_levels <- levels(.df_row[[arm]]) |
|
| 185 | -1x | +
- x = x,+ |
||
| 186 | -1x | +! |
- .ref_group = .ref_group,+ out <- lapply(arm_levels, function(lev) {
|
|
| 187 | -1x | +! |
- .in_ref_col = .in_ref_col,+ temp <- .df_row |
|
| 188 | -1x | +! |
- denom = denom,+ temp[[arm]] <- factor(lev, levels = arm_levels) |
|
| 189 | -1x | +
- na.rm = na.rm,+ |
||
| 190 | -+ | ! |
- ...+ mf <- stats::model.frame(obj$formula, data = temp) |
|
| 191 | -+ | ! |
- )+ X <- stats::model.matrix(obj$formula, data = mf) # nolint |
|
| 192 |
- }+ |
|||
| 193 | -+ | ! |
-
+ rate <- stats::predict(obj, newdata = mf, type = "response") |
|
| 194 | -+ | ! |
- #' @describeIn compare_variables Method for `logical` class. A chi-squared test+ rate_hat <- mean(rate) |
|
| 195 |
- #' is used. If missing values are not removed, then they are counted as `FALSE`.+ |
|||
| 196 | -+ | ! |
- #'+ zz <- colMeans(rate * X) |
|
| 197 | -+ | ! |
- #' @method s_compare logical+ se <- sqrt(as.numeric(t(zz) %*% stats::vcov(obj) %*% zz)) |
|
| 198 | -+ | ! |
- #'+ rate_lwr <- rate_hat * exp(-stats::qnorm(p) * se / rate_hat) |
|
| 199 | -+ | ! |
- #' @examples+ rate_upr <- rate_hat * exp(stats::qnorm(p) * se / rate_hat) |
|
| 200 |
- #' # `s_compare.logical`+ |
|||
| 201 | -+ | ! |
- #'+ c(rate_hat, rate_lwr, rate_upr) |
|
| 202 |
- #' ## Basic usage:+ }) |
|||
| 203 |
- #' x <- c(TRUE, FALSE, TRUE, TRUE)+ |
|||
| 204 | -+ | ! |
- #' y <- c(FALSE, FALSE, TRUE)+ names(out) <- arm_levels |
|
| 205 | -+ | ! |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE)+ out <- do.call(rbind, out) |
|
| 206 | -+ | ! |
- #'+ if ("negbin" %in% class(obj)) {
|
|
| 207 | -+ | ! |
- #' ## Management of NA values.+ colnames(out) <- c("response", "asymp.LCL", "asymp.UCL")
|
|
| 208 |
- #' x <- c(NA, TRUE, FALSE)+ } else {
|
|||
| 209 | -+ | ! |
- #' y <- c(NA, NA, NA, NA, FALSE)+ colnames(out) <- c("rate", "asymp.LCL", "asymp.UCL")
|
|
| 210 |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE)+ } |
|||
| 211 | -+ | ! |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE)+ out <- as.data.frame(out) |
|
| 212 | -+ | ! |
- #'+ out[[arm]] <- rownames(out) |
|
| 213 | -+ | ! |
- #' @export+ out |
|
| 214 |
- s_compare.logical <- function(x,+ } |
|||
| 215 |
- .ref_group,+ |
|||
| 216 |
- .in_ref_col,+ #' @describeIn summarize_glm_count Statistics function that produces a named list of results |
|||
| 217 |
- na.rm = TRUE, # nolint+ #' of the investigated Poisson model. |
|||
| 218 |
- denom = "n",+ #' |
|||
| 219 |
- ...) {
+ #' @inheritParams h_glm_count |
|||
| 220 | -3x | +
- denom <- match.arg(denom)+ #' |
||
| 221 |
-
+ #' @return |
|||
| 222 | -3x | +
- y <- s_summary.logical(+ #' * `s_glm_count()` returns a named `list` of 5 statistics: |
||
| 223 | -3x | +
- x = x,+ #' * `n`: Count of complete sample size for the group. |
||
| 224 | -3x | +
- na.rm = na.rm,+ #' * `rate`: Estimated event rate per follow-up time. |
||
| 225 | -3x | +
- denom = denom,+ #' * `rate_ci`: Confidence level for estimated rate per follow-up time. |
||
| 226 |
- ...+ #' * `rate_ratio`: Ratio of event rates in each treatment arm to the reference arm. |
|||
| 227 |
- )+ #' * `rate_ratio_ci`: Confidence level for the rate ratio. |
|||
| 228 |
-
+ #' * `pval`: p-value. |
|||
| 229 | -3x | +
- if (na.rm) {
+ #' |
||
| 230 | -2x | +
- x <- stats::na.omit(x)+ #' |
||
| 231 | -2x | +
- .ref_group <- stats::na.omit(.ref_group)+ #' @keywords internal |
||
| 232 |
- } else {
+ s_glm_count <- function(df, |
|||
| 233 | -1x | +
- x[is.na(x)] <- FALSE+ .var, |
||
| 234 | -1x | +
- .ref_group[is.na(.ref_group)] <- FALSE+ .df_row, |
||
| 235 |
- }+ variables, |
|||
| 236 |
-
+ .ref_group, |
|||
| 237 | -3x | +
- y$pval_counts <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
+ .in_ref_col, |
||
| 238 | -3x | +
- x <- factor(x, levels = c(TRUE, FALSE))+ distribution, |
||
| 239 | -3x | +
- .ref_group <- factor(.ref_group, levels = c(TRUE, FALSE))+ conf_level, |
||
| 240 | -3x | +
- tbl <- rbind(table(x), table(.ref_group))+ rate_mean_method, |
||
| 241 | -3x | +
- suppressWarnings(prop_chisq(tbl))+ weights, |
||
| 242 |
- } else {
+ scale = 1) {
|
|||
| 243 | -! | +3x |
- character()+ arm <- variables$arm |
|
| 244 |
- }+ |
|||
| 245 | -+ | 3x |
-
+ y <- df[[.var]] |
|
| 246 | -3x | +2x |
- y+ smry_level <- as.character(unique(df[[arm]])) |
|
| 247 |
- }+ |
|||
| 248 |
-
+ # ensure there is only 1 value |
|||
| 249 | -+ | 2x |
- #' @describeIn compare_variables Formatted analysis function which is used as `afun`+ checkmate::assert_scalar(smry_level) |
|
| 250 |
- #' in `compare_vars()`.+ |
|||
| 251 | -+ | 2x |
- #'+ results <- h_glm_count( |
|
| 252 | -+ | 2x |
- #' @return+ .var = .var, |
|
| 253 | -+ | 2x |
- #' * `a_compare()` returns the corresponding list with formatted [rtables::CellValue()].+ .df_row = .df_row, |
|
| 254 | -+ | 2x |
- #'+ variables = variables, |
|
| 255 | -+ | 2x |
- #' @note `a_compare()` has been deprecated in favor of `a_summary()` with argument `compare` set to `TRUE`.+ distribution = distribution, |
|
| 256 | -+ | 2x |
- #'+ weights |
|
| 257 |
- #' @examples+ ) |
|||
| 258 |
- #' # `a_compare` deprecated - use `a_summary()` instead+ |
|||
| 259 | -+ | 2x |
- #' a_compare(rnorm(10, 5, 1), .ref_group = rnorm(20, -5, 1), .stats = c("n", "pval"))
+ if (rate_mean_method == "emmeans") {
|
|
| 260 | -+ | 2x |
- #'+ emmeans_smry <- summary(results$emmeans_fit, level = conf_level) |
|
| 261 | -+ | ! |
- #' @export+ } else if (rate_mean_method == "ppmeans") {
|
|
| 262 | -+ | ! |
- a_compare <- function(x,+ emmeans_smry <- h_ppmeans(results$glm_fit, .df_row, arm, conf_level) |
|
| 263 |
- .N_col, # nolint+ } |
|||
| 264 |
- .N_row, # nolint+ |
|||
| 265 | -+ | 2x |
- .var = NULL,+ emmeans_smry_level <- emmeans_smry[emmeans_smry[[arm]] == smry_level, ] |
|
| 266 |
- .df_row = NULL,+ |
|||
| 267 | -+ | 2x |
- .ref_group = NULL,+ if (.in_ref_col) {
|
|
| 268 | -+ | 1x |
- .in_ref_col = FALSE,+ list( |
|
| 269 | -+ | 1x |
- ...) {
+ n = length(y[!is.na(y)]), |
|
| 270 | 1x |
- lifecycle::deprecate_warn(+ rate = formatters::with_label( |
||
| 271 | 1x |
- "0.8.3",+ ifelse(distribution == "negbin", emmeans_smry_level$response * scale, emmeans_smry_level$rate), |
||
| 272 | 1x |
- "a_compare()",+ "Adjusted Rate" |
||
| 273 | -1x | +
- details = "Please use a_summary() with argument `compare` set to TRUE instead."+ ), |
||
| 274 | -+ | 1x |
- )+ rate_ci = formatters::with_label( |
|
| 275 | 1x |
- a_summary(+ c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale), |
||
| 276 | 1x |
- x = x,+ f_conf_level(conf_level) |
||
| 277 | -1x | +
- .N_col = .N_col,+ ), |
||
| 278 | 1x |
- .N_row = .N_row,+ rate_ratio = formatters::with_label(character(), "Adjusted Rate Ratio"), |
||
| 279 | 1x |
- .var = .var,+ rate_ratio_ci = formatters::with_label(character(), f_conf_level(conf_level)), |
||
| 280 | 1x |
- .df_row = .df_row,+ pval = formatters::with_label(character(), "p-value") |
||
| 281 | -1x | +
- .ref_group = .ref_group,+ ) |
||
| 282 | -1x | +
- .in_ref_col = .in_ref_col,+ } else {
|
||
| 283 | 1x |
- compare = TRUE,+ emmeans_contrasts <- emmeans::contrast( |
||
| 284 | -+ | 1x |
- ...+ results$emmeans_fit, |
|
| 285 | -+ | 1x |
- )+ method = "trt.vs.ctrl", |
|
| 286 | -+ | 1x |
- }+ ref = grep( |
|
| 287 | -+ | 1x |
-
+ as.character(unique(.ref_group[[arm]])), |
|
| 288 | -+ | 1x |
- #' Constructor Function for [compare_vars()]+ as.data.frame(results$emmeans_fit)[[arm]] |
|
| 289 |
- #'+ ) |
|||
| 290 |
- #' @description `r lifecycle::badge("deprecated")`
+ ) |
|||
| 291 |
- #'+ |
|||
| 292 | -+ | 1x |
- #' Constructor function which creates a combined formatted analysis function.+ contrasts_smry <- summary( |
|
| 293 | -+ | 1x |
- #'+ emmeans_contrasts, |
|
| 294 | -+ | 1x |
- #' @inheritParams argument_convention+ infer = TRUE, |
|
| 295 | -+ | 1x |
- #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ adjust = "none" |
|
| 296 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ ) |
|||
| 297 |
- #' for that statistic's row label.+ |
|||
| 298 | -+ | 1x |
- #'+ smry_contrasts_level <- contrasts_smry[grepl(smry_level, contrasts_smry$contrast), ] |
|
| 299 |
- #' @return Combined formatted analysis function for use in [compare_vars()].+ |
|||
| 300 | -+ | 1x |
- #'+ list( |
|
| 301 | -+ | 1x |
- #' @note This function has been deprecated in favor of direct implementation of `a_summary()` with argument `compare`+ n = length(y[!is.na(y)]), |
|
| 302 | -+ | 1x |
- #' set to `TRUE`.+ rate = formatters::with_label( |
|
| 303 | -+ | 1x |
- #'+ ifelse(distribution == "negbin", emmeans_smry_level$response * scale, emmeans_smry_level$rate), |
|
| 304 | -+ | 1x |
- #' @seealso [compare_vars()]+ "Adjusted Rate" |
|
| 305 |
- #'+ ), |
|||
| 306 | -+ | 1x |
- #' @export+ rate_ci = formatters::with_label( |
|
| 307 | -+ | 1x |
- create_afun_compare <- function(.stats = NULL,+ c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale), |
|
| 308 | -+ | 1x |
- .formats = NULL,+ f_conf_level(conf_level) |
|
| 309 |
- .labels = NULL,+ ), |
|||
| 310 | -+ | 1x |
- .indent_mods = NULL) {
+ rate_ratio = formatters::with_label(smry_contrasts_level$ratio, "Adjusted Rate Ratio"), |
|
| 311 | 1x |
- lifecycle::deprecate_warn(+ rate_ratio_ci = formatters::with_label( |
||
| 312 | 1x |
- "0.8.5.9010",+ c(smry_contrasts_level$asymp.LCL, smry_contrasts_level$asymp.UCL), |
||
| 313 | 1x |
- "create_afun_compare()",+ f_conf_level(conf_level) |
||
| 314 | -1x | +
- details = "Please use a_summary(compare = TRUE) directly instead."+ ), |
||
| 315 | -+ | 1x |
- )+ pval = formatters::with_label(smry_contrasts_level$p.value, "p-value") |
|
| 316 | -1x | +
- function(x,+ ) |
||
| 317 | -1x | +
- .ref_group,+ } |
||
| 318 | -1x | +
- .in_ref_col,+ } |
||
| 319 |
- ...,+ |
|||
| 320 | -1x | +
- .var) {
+ #' @describeIn summarize_glm_count Formatted analysis function which is used as `afun` in `summarize_glm_count()`. |
||
| 321 | -! | +
- a_summary(x,+ #' |
||
| 322 | -! | +
- compare = TRUE,+ #' @return |
||
| 323 | -! | +
- .stats = .stats,+ #' * `a_glm_count()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 324 | -! | +
- .formats = .formats,+ #' |
||
| 325 | -! | +
- .labels = .labels,+ #' |
||
| 326 | -! | +
- .indent_mods = .indent_mods,+ #' @keywords internal |
||
| 327 | -! | +
- .ref_group = .ref_group,+ a_glm_count <- make_afun( |
||
| 328 | -! | +
- .in_ref_col = .in_ref_col,+ s_glm_count, |
||
| 329 | -! | +
- .var = .var, ...+ .indent_mods = c( |
||
| 330 |
- )+ "n" = 0L, |
|||
| 331 |
- }+ "rate" = 0L, |
|||
| 332 |
- }+ "rate_ci" = 1L, |
|||
| 333 |
-
+ "rate_ratio" = 0L, |
|||
| 334 |
- #' @describeIn compare_variables Layout-creating function which can take statistics function arguments+ "rate_ratio_ci" = 1L, |
|||
| 335 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ "pval" = 1L |
|||
| 336 |
- #'+ ), |
|||
| 337 |
- #' @param ... arguments passed to `s_compare()`.+ .formats = c( |
|||
| 338 |
- #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ "n" = "xx", |
|||
| 339 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ "rate" = "xx.xxxx", |
|||
| 340 |
- #' for that statistic's row label.+ "rate_ci" = "(xx.xxxx, xx.xxxx)", |
|||
| 341 |
- #'+ "rate_ratio" = "xx.xxxx", |
|||
| 342 |
- #' @return+ "rate_ratio_ci" = "(xx.xxxx, xx.xxxx)", |
|||
| 343 |
- #' * `compare_vars()` returns a layout object suitable for passing to further layouting functions,+ "pval" = "x.xxxx | (<0.0001)" |
|||
| 344 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ ), |
|||
| 345 |
- #' the statistics from `s_compare()` to the table layout.+ .null_ref_cells = FALSE |
|||
| 346 |
- #'+ ) |
|||
| 347 |
- #' @examples+ |
|||
| 348 |
- #' # `compare_vars()` in `rtables` pipelines+ #' @describeIn summarize_glm_count Layout-creating function which can take statistics function arguments |
|||
| 349 |
- #'+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 350 |
- #' ## Default output within a `rtables` pipeline.+ #' |
|||
| 351 |
- #' lyt <- basic_table() %>%+ #' @return |
|||
| 352 |
- #' split_cols_by("ARMCD", ref_group = "ARM B") %>%
+ #' * `summarize_glm_count()` returns a layout object suitable for passing to further layouting functions, |
|||
| 353 |
- #' compare_vars(c("AGE", "SEX"))
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 354 |
- #' build_table(lyt, tern_ex_adsl)+ #' the statistics from `s_glm_count()` to the table layout. |
|||
| 356 |
- #' ## Select and format statistics output.+ #' @examples |
|||
| 357 |
- #' lyt <- basic_table() %>%+ #' library(dplyr) |
|||
| 358 |
- #' split_cols_by("ARMCD", ref_group = "ARM C") %>%
+ #' anl <- tern_ex_adtte %>% filter(PARAMCD == "TNE") |
|||
| 359 |
- #' compare_vars(+ #' anl$AVAL_f <- as.factor(anl$AVAL) |
|||
| 360 |
- #' vars = "AGE",+ #' |
|||
| 361 |
- #' .stats = c("mean_sd", "pval"),
+ #' lyt <- basic_table() %>% |
|||
| 362 |
- #' .formats = c(mean_sd = "xx.x, xx.x"),+ #' split_cols_by("ARM", ref_group = "B: Placebo") %>%
|
|||
| 363 |
- #' .labels = c(mean_sd = "Mean, SD")+ #' add_colcounts() %>% |
|||
| 364 |
- #' )+ #' analyze_vars( |
|||
| 365 |
- #' build_table(lyt, df = tern_ex_adsl)+ #' "AVAL_f", |
|||
| 366 |
- #'+ #' var_labels = "Number of exacerbations per patient", |
|||
| 367 |
- #' @export+ #' .stats = c("count_fraction"),
|
|||
| 368 |
- compare_vars <- function(lyt,+ #' .formats = c("count_fraction" = "xx (xx.xx%)"),
|
|||
| 369 |
- vars,+ #' .label = c("Number of exacerbations per patient")
|
|||
| 370 |
- var_labels = vars,+ #' ) %>% |
|||
| 371 |
- nested = TRUE,+ #' summarize_glm_count( |
|||
| 372 |
- ...,+ #' vars = "AVAL", |
|||
| 373 |
- na.rm = TRUE, # nolint+ #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = NULL), |
|||
| 374 |
- na_level = NA_character_,+ #' conf_level = 0.95, |
|||
| 375 |
- show_labels = "default",+ #' distribution = "poisson", |
|||
| 376 |
- table_names = vars,+ #' rate_mean_method = "emmeans", |
|||
| 377 |
- section_div = NA_character_,+ #' var_labels = "Unadjusted exacerbation rate (per year)", |
|||
| 378 |
- .stats = c("n", "mean_sd", "count_fraction", "pval"),
+ #' table_names = "unadj", |
|||
| 379 |
- .formats = NULL,+ #' .stats = c("rate"),
|
|||
| 380 |
- .labels = NULL,+ #' .labels = c(rate = "Rate") |
|||
| 381 |
- .indent_mods = NULL) {
+ #' ) %>% |
|||
| 382 | -3x | +
- extra_args <- list(.stats = .stats, na.rm = na.rm, na_level = na_level, compare = TRUE, ...)+ #' summarize_glm_count( |
||
| 383 | -1x | +
- if (!is.null(.formats)) extra_args[[".formats"]] <- .formats+ #' vars = "AVAL", |
||
| 384 | -1x | +
- if (!is.null(.labels)) extra_args[[".labels"]] <- .labels+ #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = c("REGION1")),
|
||
| 385 | -! | +
- if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods+ #' conf_level = 0.95, |
||
| 386 |
-
+ #' distribution = "quasipoisson", |
|||
| 387 | -3x | +
- analyze(+ #' rate_mean_method = "ppmeans", |
||
| 388 | -3x | +
- lyt = lyt,+ #' var_labels = "Adjusted (QP) exacerbation rate (per year)", |
||
| 389 | -3x | +
- vars = vars,+ #' table_names = "adj", |
||
| 390 | -3x | +
- var_labels = var_labels,+ #' .stats = c("rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
|
||
| 391 | -3x | +
- afun = a_summary,+ #' .labels = c( |
||
| 392 | -3x | +
- nested = nested,+ #' rate = "Rate", rate_ci = "Rate CI", rate_ratio = "Rate Ratio", |
||
| 393 | -3x | +
- extra_args = extra_args,+ #' rate_ratio_ci = "Rate Ratio CI", pval = "p value" |
||
| 394 | -3x | +
- inclNAs = TRUE,+ #' ) |
||
| 395 | -3x | ++ |
+ #' )+ |
+ |
| 396 | ++ |
+ #' build_table(lyt = lyt, df = anl)+ |
+ ||
| 397 | ++ |
+ #'+ |
+ ||
| 398 | ++ |
+ #' @export+ |
+ ||
| 399 | ++ |
+ summarize_glm_count <- function(lyt,+ |
+ ||
| 400 | ++ |
+ vars,+ |
+ ||
| 401 | ++ |
+ var_labels,+ |
+ ||
| 402 | ++ |
+ na_str = NA_character_,+ |
+ ||
| 403 | ++ |
+ nested = TRUE,+ |
+ ||
| 404 | ++ |
+ ...,+ |
+ ||
| 405 | ++ |
+ show_labels = "visible",+ |
+ ||
| 406 | ++ |
+ table_names = vars,+ |
+ ||
| 407 | ++ |
+ .stats = NULL,+ |
+ ||
| 408 | ++ |
+ .formats = NULL,+ |
+ ||
| 409 | ++ |
+ .labels = NULL,+ |
+ ||
| 410 | ++ |
+ .indent_mods = NULL) {
+ |
+ ||
| 411 | +1x | +
+ afun <- make_afun(+ |
+ ||
| 412 | +1x | +
+ a_glm_count,+ |
+ ||
| 413 | +1x | +
+ .stats = .stats,+ |
+ ||
| 414 | +1x | +
+ .formats = .formats,+ |
+ ||
| 415 | +1x | +
+ .labels = .labels,+ |
+ ||
| 416 | +1x | +
+ .indent_mods = .indent_mods+ |
+ ||
| 417 | ++ |
+ )+ |
+ ||
| 418 | ++ | + + | +||
| 419 | +1x | +
+ analyze(+ |
+ ||
| 420 | +1x | +
+ lyt,+ |
+ ||
| 421 | +1x | +
+ vars,+ |
+ ||
| 422 | +1x | +
+ var_labels = var_labels,+ |
+ ||
| 423 | +1x |
show_labels = show_labels, |
||
| 396 | -3x | +424 | +1x |
table_names = table_names, |
| 397 | -3x | +425 | +1x |
- section_div = section_div+ afun = afun,+ |
+
| 426 | +1x | +
+ na_str = na_str,+ |
+ ||
| 427 | +1x | +
+ nested = nested,+ |
+ ||
| 428 | +1x | +
+ extra_args = list(...) |
||
| 398 | +429 |
) |
||
| 399 | +430 |
}@@ -119966,14 +119655,14 @@ tern coverage - 94.83% |
| 1 |
- #' Difference Test for Two Proportions+ #' Summary for analysis of covariance (`ANCOVA`). |
||
| 5 |
- #' Various tests were implemented to test the difference between two proportions.+ #' Summarize results of `ANCOVA`. This can be used to analyze multiple endpoints and/or |
||
| 6 |
- #'+ #' multiple timepoints within the same response variable `.var`. |
||
| 7 |
- #' @inheritParams argument_convention+ #' |
||
| 8 |
- #'+ #' @inheritParams argument_convention |
||
| 9 |
- #' @seealso [h_prop_diff_test]+ #' |
||
| 10 |
- #'+ #' @name summarize_ancova |
||
| 11 |
- #' @name prop_diff_test+ NULL |
||
| 12 |
- NULL+ |
||
| 13 |
-
+ #' Helper Function to Return Results of a Linear Model |
||
| 14 |
- #' @describeIn prop_diff_test Statistics function which tests the difference between two proportions.+ #' |
||
| 15 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 16 |
- #' @param method (`string`)\cr one of `chisq`, `cmh`, `fisher`, or `schouten`; specifies the test used+ #' |
||
| 17 |
- #' to calculate the p-value.+ #' @inheritParams argument_convention |
||
| 18 |
- #'+ #' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called in `.var` and `variables`. |
||
| 19 |
- #' @return+ #' @param variables (named `list` of `strings`)\cr list of additional analysis variables, with expected elements: |
||
| 20 |
- #' * `s_test_proportion_diff()` returns a named `list` with a single item `pval` with an attribute `label`+ #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be |
||
| 21 |
- #' describing the method used. The p-value tests the null hypothesis that proportions in two groups are the same.+ #' summarized. Specifically, the first level of `arm` variable is taken as the reference group. |
||
| 22 |
- #'+ #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as `"X1"`), and/or |
||
| 23 |
- #'+ #' interaction terms indicated by `"X1 * X2"`. |
||
| 24 |
- #' @keywords internal+ #' @param interaction_item (`character`)\cr name of the variable that should have interactions |
||
| 25 |
- s_test_proportion_diff <- function(df,+ #' with arm. if the interaction is not needed, the default option is `NULL`. |
||
| 26 |
- .var,+ #' |
||
| 27 |
- .ref_group,+ #' @return The summary of a linear model. |
||
| 28 |
- .in_ref_col,+ #' |
||
| 29 |
- variables = list(strata = NULL),+ #' @examples |
||
| 30 |
- method = c("chisq", "schouten", "fisher", "cmh")) {
+ #' h_ancova( |
||
| 31 | -30x | +
- method <- match.arg(method)+ #' .var = "Sepal.Length", |
|
| 32 | -30x | +
- y <- list(pval = "")+ #' .df_row = iris, |
|
| 33 |
-
+ #' variables = list(arm = "Species", covariates = c("Petal.Length * Petal.Width", "Sepal.Width"))
|
||
| 34 | -30x | +
- if (!.in_ref_col) {
+ #' ) |
|
| 35 | -30x | +
- assert_df_with_variables(df, list(rsp = .var))+ #' |
|
| 36 | -30x | +
- assert_df_with_variables(.ref_group, list(rsp = .var))+ #' @export |
|
| 37 | -30x | +
- rsp <- factor(+ h_ancova <- function(.var, |
|
| 38 | -30x | +
- c(.ref_group[[.var]], df[[.var]]),+ .df_row, |
|
| 39 | -30x | +
- levels = c("TRUE", "FALSE")
+ variables, |
|
| 40 |
- )+ interaction_item = NULL) {
|
||
| 41 | -30x | +15x |
- grp <- factor(+ checkmate::assert_string(.var) |
| 42 | -30x | +15x |
- rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
+ checkmate::assert_list(variables) |
| 43 | -30x | +15x |
- levels = c("ref", "Not-ref")
+ checkmate::assert_subset(names(variables), c("arm", "covariates"))
|
| 44 | -+ | 15x |
- )+ assert_df_with_variables(.df_row, list(rsp = .var)) |
| 46 | -30x | +14x |
- if (!is.null(variables$strata) || method == "cmh") {
+ arm <- variables$arm |
| 47 | -12x | +14x |
- strata <- variables$strata+ covariates <- variables$covariates |
| 48 | -12x | +14x |
- checkmate::assert_false(is.null(strata))+ if (!is.null(covariates) && length(covariates) > 0) {
|
| 49 | -12x | +
- strata_vars <- stats::setNames(as.list(strata), strata)+ # Get all covariate variable names in the model. |
|
| 50 | -12x | +11x |
- assert_df_with_variables(df, strata_vars)+ var_list <- get_covariates(covariates) |
| 51 | -12x | +11x |
- assert_df_with_variables(.ref_group, strata_vars)+ assert_df_with_variables(.df_row, var_list) |
| 52 | -12x | +
- strata <- c(interaction(.ref_group[strata]), interaction(df[strata]))+ } |
|
| 53 |
- }+ |
||
| 54 | -+ | 13x |
-
+ covariates_part <- paste(covariates, collapse = " + ") |
| 55 | -30x | +13x |
- tbl <- switch(method,+ if (covariates_part != "") {
|
| 56 | -30x | +10x |
- cmh = table(grp, rsp, strata),+ formula <- stats::as.formula(paste0(.var, " ~ ", covariates_part, " + ", arm)) |
| 57 | -30x | +
- table(grp, rsp)+ } else {
|
|
| 58 | -+ | 3x |
- )+ formula <- stats::as.formula(paste0(.var, " ~ ", arm)) |
| 59 |
-
+ } |
||
| 60 | -30x | +
- y$pval <- switch(method,+ |
|
| 61 | -30x | +13x |
- chisq = prop_chisq(tbl),+ if (is.null(interaction_item)) {
|
| 62 | -30x | +9x |
- cmh = prop_cmh(tbl),+ specs <- arm |
| 63 | -30x | +
- fisher = prop_fisher(tbl),+ } else {
|
|
| 64 | -30x | +4x |
- schouten = prop_schouten(tbl)+ specs <- c(arm, interaction_item) |
| 65 |
- )+ } |
||
| 66 |
- }+ |
||
| 67 | -+ | 13x |
-
+ lm_fit <- stats::lm( |
| 68 | -30x | +13x |
- y$pval <- formatters::with_label(y$pval, d_test_proportion_diff(method))+ formula = formula, |
| 69 | -30x | +13x |
- y+ data = .df_row |
| 70 |
- }+ ) |
||
| 71 | -+ | 13x |
-
+ emmeans_fit <- emmeans::emmeans( |
| 72 | -+ | 13x |
- #' Description of the Difference Test Between Two Proportions+ lm_fit, |
| 73 |
- #'+ # Specify here the group variable over which EMM are desired. |
||
| 74 | -+ | 13x |
- #' @description `r lifecycle::badge("stable")`
+ specs = specs, |
| 75 |
- #'+ # Pass the data again so that the factor levels of the arm variable can be inferred. |
||
| 76 | -+ | 13x |
- #' This is an auxiliary function that describes the analysis in `s_test_proportion_diff`.+ data = .df_row |
| 77 |
- #'+ ) |
||
| 78 |
- #' @inheritParams s_test_proportion_diff+ |
||
| 79 | -+ | 13x |
- #'+ emmeans_fit |
| 80 |
- #' @return `string` describing the test from which the p-value is derived.+ } |
||
| 81 |
- #'+ |
||
| 82 |
- #' @export+ #' @describeIn summarize_ancova Statistics function that produces a named list of results |
||
| 83 |
- d_test_proportion_diff <- function(method) {
+ #' of the investigated linear model. |
||
| 84 | -41x | +
- checkmate::assert_string(method)+ #' |
|
| 85 | -41x | +
- meth_part <- switch(method,+ #' @inheritParams h_ancova |
|
| 86 | -41x | +
- "schouten" = "Chi-Squared Test with Schouten Correction",+ #' @param interaction_y (`character`)\cr a selected item inside of the interaction_item column which will be used |
|
| 87 | -41x | +
- "chisq" = "Chi-Squared Test",+ #' to select the specific `ANCOVA` results. if the interaction is not needed, the default option is `FALSE`. |
|
| 88 | -41x | +
- "cmh" = "Cochran-Mantel-Haenszel Test",+ #' |
|
| 89 | -41x | +
- "fisher" = "Fisher's Exact Test",+ #' @return |
|
| 90 | -41x | +
- stop(paste(method, "does not have a description"))+ #' * `s_ancova()` returns a named list of 5 statistics: |
|
| 91 |
- )+ #' * `n`: Count of complete sample size for the group. |
||
| 92 | -41x | +
- paste0("p-value (", meth_part, ")")
+ #' * `lsmean`: Estimated marginal means in the group. |
|
| 93 |
- }+ #' * `lsmean_diff`: Difference in estimated marginal means in comparison to the reference group. |
||
| 94 |
-
+ #' If working with the reference group, this will be empty. |
||
| 95 |
- #' @describeIn prop_diff_test Formatted analysis function which is used as `afun` in `test_proportion_diff()`.+ #' * `lsmean_diff_ci`: Confidence level for difference in estimated marginal means in comparison |
||
| 96 |
- #'+ #' to the reference group. |
||
| 97 |
- #' @return+ #' * `pval`: p-value (not adjusted for multiple comparisons). |
||
| 98 |
- #' * `a_test_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()].+ #' |
||
| 99 |
- #'+ #' @examples |
||
| 100 |
- #'+ #' library(dplyr) |
||
| 101 |
- #' @keywords internal+ #' |
||
| 102 |
- a_test_proportion_diff <- make_afun(+ #' df <- iris %>% filter(Species == "virginica") |
||
| 103 |
- s_test_proportion_diff,+ #' .df_row <- iris |
||
| 104 |
- .formats = c(pval = "x.xxxx | (<0.0001)"),+ #' .var <- "Petal.Length" |
||
| 105 |
- .indent_mods = c(pval = 1L)+ #' variables <- list(arm = "Species", covariates = "Sepal.Length * Sepal.Width") |
||
| 106 |
- )+ #' .ref_group <- iris %>% filter(Species == "setosa") |
||
| 107 |
-
+ #' conf_level <- 0.95 |
||
| 108 |
- #' @describeIn prop_diff_test Layout-creating function which can take statistics function arguments+ #' |
||
| 109 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' @keywords internal |
||
| 110 |
- #'+ s_ancova <- function(df, |
||
| 111 |
- #' @param ... other arguments are passed to [s_test_proportion_diff()].+ .var, |
||
| 112 |
- #'+ .df_row, |
||
| 113 |
- #' @return+ variables, |
||
| 114 |
- #' * `test_proportion_diff()` returns a layout object suitable for passing to further layouting functions,+ .ref_group, |
||
| 115 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ .in_ref_col, |
||
| 116 |
- #' the statistics from `s_test_proportion_diff()` to the table layout.+ conf_level, |
||
| 117 |
- #'+ interaction_y = FALSE, |
||
| 118 |
- #' @examples+ interaction_item = NULL) {
|
||
| 119 | -+ | 3x |
- #' dta <- data.frame(+ emmeans_fit <- h_ancova(.var = .var, variables = variables, .df_row = .df_row, interaction_item = interaction_item) |
| 120 |
- #' rsp = sample(c(TRUE, FALSE), 100, TRUE),+ |
||
| 121 | -+ | 3x |
- #' grp = factor(rep(c("A", "B"), each = 50)),
+ sum_fit <- summary( |
| 122 | -+ | 3x |
- #' strat = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20))
+ emmeans_fit, |
| 123 | -+ | 3x |
- #' )+ level = conf_level |
| 124 |
- #'+ ) |
||
| 125 |
- #' # With `rtables` pipelines.+ |
||
| 126 | -+ | 3x |
- #' l <- basic_table() %>%+ arm <- variables$arm |
| 127 |
- #' split_cols_by(var = "grp", ref_group = "B") %>%+ |
||
| 128 | -+ | 3x |
- #' test_proportion_diff(+ sum_level <- as.character(unique(df[[arm]])) |
| 129 |
- #' vars = "rsp",+ |
||
| 130 |
- #' method = "cmh", variables = list(strata = "strat")+ # Ensure that there is only one element in sum_level. |
||
| 131 | -+ | 3x |
- #' )+ checkmate::assert_scalar(sum_level) |
| 132 |
- #'+ |
||
| 133 | -+ | 2x |
- #' build_table(l, df = dta)+ sum_fit_level <- sum_fit[sum_fit[[arm]] == sum_level, ] |
| 134 |
- #'+ |
||
| 135 |
- #' @export+ # Get the index of the ref arm |
||
| 136 | -+ | 2x |
- test_proportion_diff <- function(lyt,+ if (interaction_y != FALSE) {
|
| 137 | -+ | 1x |
- vars,+ y <- unlist(df[(df[[interaction_item]] == interaction_y), .var]) |
| 138 |
- nested = TRUE,+ # convert characters selected in interaction_y into the numeric order |
||
| 139 | -+ | 1x |
- ...,+ interaction_y <- which(sum_fit_level[[interaction_item]] == interaction_y) |
| 140 | -+ | 1x |
- var_labels = vars,+ sum_fit_level <- sum_fit_level[interaction_y, ] |
| 141 |
- show_labels = "hidden",+ # if interaction is called, reset the index |
||
| 142 | -+ | 1x |
- table_names = vars,+ ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])]) |
| 143 | -+ | 1x |
- .stats = NULL,+ ref_key <- tail(ref_key, n = 1) |
| 144 | -+ | 1x |
- .formats = NULL,+ ref_key <- (interaction_y - 1) * length(unique(.df_row[[arm]])) + ref_key |
| 145 |
- .labels = NULL,+ } else {
|
||
| 146 | -+ | 1x |
- .indent_mods = NULL) {
+ y <- df[[.var]] |
| 147 | -5x | +
- afun <- make_afun(+ # Get the index of the ref arm when interaction is not called |
|
| 148 | -5x | +1x |
- a_test_proportion_diff,+ ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])]) |
| 149 | -5x | +1x |
- .stats = .stats,+ ref_key <- tail(ref_key, n = 1) |
| 150 | -5x | +
- .formats = .formats,+ } |
|
| 151 | -5x | +
- .labels = .labels,+ |
|
| 152 | -5x | +2x |
- .indent_mods = .indent_mods+ if (.in_ref_col) {
|
| 153 | -+ | 1x |
- )+ list( |
| 154 | -5x | +1x |
- analyze(+ n = length(y[!is.na(y)]), |
| 155 | -5x | +1x |
- lyt,+ lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"), |
| 156 | -5x | +1x |
- vars,+ lsmean_diff = formatters::with_label(character(), "Difference in Adjusted Means"), |
| 157 | -5x | +1x |
- afun = afun,+ lsmean_diff_ci = formatters::with_label(character(), f_conf_level(conf_level)), |
| 158 | -5x | +1x |
- var_labels = var_labels,+ pval = formatters::with_label(character(), "p-value") |
| 159 | -5x | +
- nested = nested,+ ) |
|
| 160 | -5x | +
- extra_args = list(...),+ } else {
|
|
| 161 | -5x | +
- show_labels = show_labels,+ # Estimate the differences between the marginal means. |
|
| 162 | -5x | +1x |
- table_names = table_names+ emmeans_contrasts <- emmeans::contrast( |
| 163 | -+ | 1x |
- )+ emmeans_fit, |
| 164 |
- }+ # Compare all arms versus the control arm. |
||
| 165 | -+ | 1x |
-
+ method = "trt.vs.ctrl", |
| 166 |
- #' Helper Functions to Test Proportion Differences+ # Take the arm factor from .ref_group as the control arm. |
||
| 167 | -+ | 1x |
- #'+ ref = ref_key, |
| 168 | -+ | 1x |
- #' Helper functions to implement various tests on the difference between two proportions.+ level = conf_level |
| 169 |
- #'+ ) |
||
| 170 | -+ | 1x |
- #' @param tbl (`matrix`)\cr matrix with two groups in rows and the binary response (`TRUE`/`FALSE`) in columns.+ sum_contrasts <- summary( |
| 171 | -+ | 1x |
- #'+ emmeans_contrasts, |
| 172 |
- #' @return A p-value.+ # Derive confidence intervals, t-tests and p-values. |
||
| 173 | -+ | 1x |
- #'+ infer = TRUE, |
| 174 |
- #' @seealso [prop_diff_test()] for implementation of these helper functions.+ # Do not adjust the p-values for multiplicity. |
||
| 175 | -+ | 1x |
- #'+ adjust = "none" |
| 176 |
- #' @name h_prop_diff_test+ ) |
||
| 177 |
- NULL+ |
||
| 178 | -+ | 1x |
-
+ sum_contrasts_level <- sum_contrasts[grepl(sum_level, sum_contrasts$contrast), ] |
| 179 | -+ | 1x |
- #' @describeIn h_prop_diff_test performs Chi-Squared test. Internally calls [stats::prop.test()].+ if (interaction_y != FALSE) {
|
| 180 | -+ | ! |
- #'+ sum_contrasts_level <- sum_contrasts_level[interaction_y, ] |
| 181 |
- #'+ } |
||
| 182 |
- #' @keywords internal+ |
||
| 183 | -+ | 1x |
- prop_chisq <- function(tbl) {
+ list( |
| 184 | -23x | +1x |
- checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)+ n = length(y[!is.na(y)]), |
| 185 | -23x | +1x |
- tbl <- tbl[, c("TRUE", "FALSE")]
+ lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"), |
| 186 | -23x | +1x |
- if (any(colSums(tbl) == 0)) {
+ lsmean_diff = formatters::with_label(sum_contrasts_level$estimate, "Difference in Adjusted Means"), |
| 187 | -2x | +1x |
- return(1)+ lsmean_diff_ci = formatters::with_label( |
| 188 | -+ | 1x |
- }+ c(sum_contrasts_level$lower.CL, sum_contrasts_level$upper.CL), |
| 189 | -21x | +1x |
- stats::prop.test(tbl, correct = FALSE)$p.value+ f_conf_level(conf_level) |
| 190 |
- }+ ), |
||
| 191 | -+ | 1x |
-
+ pval = formatters::with_label(sum_contrasts_level$p.value, "p-value") |
| 192 |
- #' @describeIn h_prop_diff_test performs stratified Cochran-Mantel-Haenszel test. Internally calls+ ) |
||
| 193 |
- #' [stats::mantelhaen.test()]. Note that strata with less than two observations are automatically discarded.+ } |
||
| 194 |
- #'+ } |
||
| 195 |
- #' @param ary (`array`, 3 dimensions)\cr array with two groups in rows, the binary response+ |
||
| 196 |
- #' (`TRUE`/`FALSE`) in columns, and the strata in the third dimension.+ #' @describeIn summarize_ancova Formatted analysis function which is used as `afun` in `summarize_ancova()`. |
||
| 198 |
- #'+ #' @return |
||
| 199 |
- #' @keywords internal+ #' * `a_ancova()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 200 | - |
- prop_cmh <- function(ary) {
- |
- |
| 201 | -16x | -
- checkmate::assert_array(ary)- |
- |
| 202 | -16x | -
- checkmate::assert_integer(c(ncol(ary), nrow(ary)), lower = 2, upper = 2)- |
- |
| 203 | -16x | -
- checkmate::assert_integer(length(dim(ary)), lower = 3, upper = 3)- |
- |
| 204 | -16x | -
- strata_sizes <- apply(ary, MARGIN = 3, sum)- |
- |
| 205 | -16x | -
- if (any(strata_sizes < 5)) {
- |
- |
| 206 | -1x | -
- warning("<5 data points in some strata. CMH test may be incorrect.")
- |
- |
| 207 | -1x | -
- ary <- ary[, , strata_sizes > 1]- |
- |
| 208 | -- |
- }- |
- |
| 209 | -- | - - | -|
| 210 | -16x | -
- stats::mantelhaen.test(ary, correct = FALSE)$p.value- |
- |
| 211 | -- |
- }- |
- |
| 212 | -- | - - | -|
| 213 | -- |
- #' @describeIn h_prop_diff_test performs the Chi-Squared test with Schouten correction.- |
- |
| 214 | -- |
- #'- |
- |
| 215 | -- |
- #' @seealso Schouten correction is based upon \insertCite{Schouten1980-kd;textual}{tern}.
- |
- |
| 216 | -
#' |
||
| 217 | +201 |
#' |
|
| 218 | +202 |
#' @keywords internal |
|
| 219 | -- |
- prop_schouten <- function(tbl) {
- |
- |
| 220 | -100x | -
- checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)- |
- |
| 221 | -100x | -
- tbl <- tbl[, c("TRUE", "FALSE")]
- |
- |
| 222 | -100x | -
- if (any(colSums(tbl) == 0)) {
- |
- |
| 223 | -1x | -
- return(1)- |
- |
| 224 | -- |
- }- |
- |
| 225 | -- | - - | -|
| 226 | -99x | -
- n <- sum(tbl)- |
- |
| 227 | -99x | -
- n1 <- sum(tbl[1, ])- |
- |
| 228 | -99x | -
- n2 <- sum(tbl[2, ])- |
- |
| 229 | -- | - - | -|
| 230 | -99x | -
- ad <- diag(tbl)- |
- |
| 231 | -99x | -
- bc <- diag(apply(tbl, 2, rev))- |
- |
| 232 | -99x | -
- ac <- tbl[, 1]- |
- |
| 233 | -99x | -
- bd <- tbl[, 2]- |
- |
| 234 | -- | - - | -|
| 235 | -99x | -
- t_schouten <- (n - 1) *- |
- |
| 236 | -99x | -
- (abs(prod(ad) - prod(bc)) - 0.5 * min(n1, n2))^2 /- |
- |
| 237 | -99x | -
- (n1 * n2 * sum(ac) * sum(bd))- |
- |
| 238 | -- | - - | -|
| 239 | -99x | -
- 1 - stats::pchisq(t_schouten, df = 1)- |
- |
| 240 | -- |
- }- |
- |
| 241 | -- | - - | -|
| 242 | -- |
- #' @describeIn h_prop_diff_test performs the Fisher's exact test. Internally calls [stats::fisher.test()].- |
- |
| 243 | -- |
- #'- |
- |
| 244 | +203 |
- #'+ a_ancova <- make_afun( |
|
| 245 | +204 |
- #' @keywords internal+ s_ancova, |
|
| 246 | +205 |
- prop_fisher <- function(tbl) {
- |
- |
| 247 | -2x | -
- checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)- |
- |
| 248 | -2x | -
- tbl <- tbl[, c("TRUE", "FALSE")]
- |
- |
| 249 | -2x | -
- stats::fisher.test(tbl)$p.value+ .indent_mods = c("n" = 0L, "lsmean" = 0L, "lsmean_diff" = 0L, "lsmean_diff_ci" = 1L, "pval" = 1L),
|
|
| 250 | +206 |
- }+ .formats = c( |
| 1 | +207 |
- #' Combine Factor Levels+ "n" = "xx", |
||
| 2 | +208 |
- #'+ "lsmean" = "xx.xx", |
||
| 3 | +209 |
- #' @description `r lifecycle::badge("stable")`
+ "lsmean_diff" = "xx.xx", |
||
| 4 | +210 |
- #'+ "lsmean_diff_ci" = "(xx.xx, xx.xx)", |
||
| 5 | +211 |
- #' Combine specified old factor Levels in a single new level.+ "pval" = "x.xxxx | (<0.0001)" |
||
| 6 | +212 |
- #'+ ), |
||
| 7 | +213 |
- #' @param x factor+ .null_ref_cells = FALSE |
||
| 8 | +214 |
- #' @param levels level names to be combined+ ) |
||
| 9 | +215 |
- #' @param new_level name of new level+ |
||
| 10 | +216 |
- #'+ #' @describeIn summarize_ancova Layout-creating function which can take statistics function arguments |
||
| 11 | +217 |
- #' @return A `factor` with the new levels.+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 12 | +218 |
#' |
||
| 13 | -- |
- #' @examples- |
- ||
| 14 | -- |
- #' x <- factor(letters[1:5], levels = letters[5:1])- |
- ||
| 15 | +219 |
- #' combine_levels(x, levels = c("a", "b"))
+ #' @return |
||
| 16 | +220 |
- #'+ #' * `summarize_ancova()` returns a layout object suitable for passing to further layouting functions, |
||
| 17 | +221 |
- #' combine_levels(x, c("e", "b"))
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 18 | +222 |
- #'+ #' the statistics from `s_ancova()` to the table layout. |
||
| 19 | +223 |
- #' @export+ #' |
||
| 20 | +224 |
- combine_levels <- function(x, levels, new_level = paste(levels, collapse = "/")) {
+ #' @examples |
||
| 21 | -4x | +|||
| 225 | +
- checkmate::assert_factor(x)+ #' basic_table() %>% |
|||
| 22 | -4x | +|||
| 226 | +
- checkmate::assert_subset(levels, levels(x))+ #' split_cols_by("Species", ref_group = "setosa") %>%
|
|||
| 23 | +227 |
-
+ #' add_colcounts() %>% |
||
| 24 | -4x | +|||
| 228 | +
- lvls <- levels(x)+ #' summarize_ancova( |
|||
| 25 | +229 |
-
+ #' vars = "Petal.Length", |
||
| 26 | -4x | +|||
| 230 | +
- lvls[lvls %in% levels] <- new_level+ #' variables = list(arm = "Species", covariates = NULL), |
|||
| 27 | +231 |
-
+ #' table_names = "unadj", |
||
| 28 | -4x | +|||
| 232 | +
- levels(x) <- lvls+ #' conf_level = 0.95, var_labels = "Unadjusted comparison", |
|||
| 29 | +233 |
-
+ #' .labels = c(lsmean = "Mean", lsmean_diff = "Difference in Means") |
||
| 30 | -4x | +|||
| 234 | +
- x+ #' ) %>% |
|||
| 31 | +235 |
- }+ #' summarize_ancova( |
||
| 32 | +236 |
-
+ #' vars = "Petal.Length", |
||
| 33 | +237 |
- #' Conversion of a Vector to a Factor+ #' variables = list(arm = "Species", covariates = c("Sepal.Length", "Sepal.Width")),
|
||
| 34 | +238 |
- #'+ #' table_names = "adj", |
||
| 35 | +239 |
- #' Converts `x` to a factor and keeps its attributes. Warns appropriately such that the user+ #' conf_level = 0.95, var_labels = "Adjusted comparison (covariates: Sepal.Length and Sepal.Width)" |
||
| 36 | +240 |
- #' can decide whether they prefer converting to factor manually (e.g. for full control of+ #' ) %>% |
||
| 37 | +241 |
- #' factor levels).+ #' build_table(iris) |
||
| 38 | +242 |
#' |
||
| 39 | +243 |
- #' @param x (`atomic`)\cr object to convert.+ #' @export |
||
| 40 | +244 |
- #' @param x_name (`string`)\cr name of `x`.+ summarize_ancova <- function(lyt, |
||
| 41 | +245 |
- #' @param na_level (`string`)\cr the explicit missing level which should be used when converting a character vector.+ vars, |
||
| 42 | +246 |
- #' @param verbose defaults to `TRUE`. It prints out warnings and messages.+ var_labels, |
||
| 43 | +247 |
- #'+ na_str = NA_character_, |
||
| 44 | +248 |
- #' @return A `factor` with same attributes (except class) as `x`. Does not modify `x` if already a `factor`.+ nested = TRUE, |
||
| 45 | +249 |
- #'+ ..., |
||
| 46 | +250 |
- #' @keywords internal+ show_labels = "visible", |
||
| 47 | +251 |
- as_factor_keep_attributes <- function(x,+ table_names = vars, |
||
| 48 | +252 |
- x_name = deparse(substitute(x)),+ .stats = NULL, |
||
| 49 | +253 |
- na_level = "<Missing>",+ .formats = NULL, |
||
| 50 | +254 |
- verbose = TRUE) {
+ .labels = NULL, |
||
| 51 | -159x | +|||
| 255 | +
- checkmate::assert_atomic(x)+ .indent_mods = NULL, |
|||
| 52 | -159x | +|||
| 256 | +
- checkmate::assert_string(x_name)+ interaction_y = FALSE, |
|||
| 53 | -159x | +|||
| 257 | +
- checkmate::assert_string(na_level)+ interaction_item = NULL) {
|
|||
| 54 | -159x | +258 | +3x |
- checkmate::assert_flag(verbose)+ afun <- make_afun( |
| 55 | -159x | +259 | +3x |
- if (is.factor(x)) {
+ a_ancova, |
| 56 | -144x | -
- return(x)- |
- ||
| 57 | -+ | 260 | +3x |
- }+ interaction_y = interaction_y, |
| 58 | -15x | +261 | +3x |
- x_class <- class(x)[1]+ interaction_item = interaction_item, |
| 59 | -15x | +262 | +3x |
- if (verbose) {
+ .stats = .stats, |
| 60 | -15x | +263 | +3x |
- warning(paste(+ .formats = .formats, |
| 61 | -15x | +264 | +3x |
- "automatically converting", x_class, "variable", x_name,+ .labels = .labels, |
| 62 | -15x | +265 | +3x |
- "to factor, better manually convert to factor to avoid failures"+ .indent_mods = .indent_mods |
| 63 | +266 |
- ))+ ) |
||
| 64 | +267 |
- }- |
- ||
| 65 | -15x | -
- if (identical(length(x), 0L)) {
+
|
||
| 66 | -1x | +268 | +3x |
- warning(paste(+ analyze( |
| 67 | -1x | -
- x_name, "has length 0, this can lead to tabulation failures, better convert to factor"- |
- ||
| 68 | -- |
- ))- |
- ||
| 69 | -+ | 269 | +3x |
- }+ lyt, |
| 70 | -15x | +270 | +3x |
- if (is.character(x)) {
+ vars, |
| 71 | -15x | +271 | +3x |
- x_no_na <- explicit_na(sas_na(x), label = na_level)+ var_labels = var_labels, |
| 72 | -15x | +272 | +3x |
- if (any(na_level %in% x_no_na)) {
+ show_labels = show_labels, |
| 73 | +273 | 3x |
- do.call(+ table_names = table_names, |
|
| 74 | +274 | 3x |
- structure,+ afun = afun, |
|
| 75 | +275 | 3x |
- c(+ na_str = na_str, |
|
| 76 | +276 | 3x |
- list(.Data = forcats::fct_relevel(x_no_na, na_level, after = Inf)),+ nested = nested, |
|
| 77 | +277 | 3x |
- attributes(x)+ extra_args = list(...) |
|
| 78 | +278 |
- )+ ) |
||
| 79 | +279 |
- )+ } |
| 80 | +1 |
- } else {
- |
- ||
| 81 | -12x | -
- do.call(structure, c(list(.Data = as.factor(x)), attributes(x)))+ #' `rtables` Access Helper Functions |
||
| 82 | +2 |
- }+ #' |
||
| 83 | +3 |
- } else {
- |
- ||
| 84 | -! | -
- do.call(structure, c(list(.Data = as.factor(x)), attributes(x)))+ #' @description `r lifecycle::badge("stable")`
|
||
| 85 | +4 |
- }+ #' |
||
| 86 | +5 |
- }+ #' These are a couple of functions that help with accessing the data in `rtables` objects. |
||
| 87 | +6 |
-
+ #' Currently these work for occurrence tables, which are defined as having a count as the first |
||
| 88 | +7 |
- #' Labels for Bins in Percent+ #' element and a fraction as the second element in each cell. |
||
| 89 | +8 |
#' |
||
| 90 | +9 |
- #' This creates labels for quantile based bins in percent. This assumes the right-closed+ #' @seealso [prune_occurrences] for usage of these functions. |
||
| 91 | +10 |
- #' intervals as produced by [cut_quantile_bins()].+ #' |
||
| 92 | +11 |
- #'+ #' @name rtables_access |
||
| 93 | +12 |
- #' @param probs (`proportion` vector)\cr the probabilities identifying the quantiles.+ NULL |
||
| 94 | +13 |
- #' This is a sorted vector of unique `proportion` values, i.e. between 0 and 1, where+ |
||
| 95 | +14 |
- #' the boundaries 0 and 1 must not be included.+ #' @describeIn rtables_access Helper function to extract the first values from each content |
||
| 96 | +15 |
- #' @param digits (`integer`)\cr number of decimal places to round the percent numbers.+ #' cell and from specified columns in a `TableRow`. Defaults to all columns. |
||
| 97 | +16 |
#' |
||
| 98 | +17 |
- #' @return A `character` vector with labels in the format `[0%,20%]`, `(20%,50%]`, etc.+ #' @param table_row (`TableRow`)\cr an analysis row in a occurrence table. |
||
| 99 | +18 |
- #'+ #' @param col_names (`character`)\cr the names of the columns to extract from. |
||
| 100 | +19 |
- #' @keywords internal+ #' @param col_indices (`integer`)\cr the indices of the columns to extract from. If `col_names` are provided, |
||
| 101 | +20 |
- bins_percent_labels <- function(probs,+ #' then these are inferred from the names of `table_row`. Note that this currently only works well with a single |
||
| 102 | +21 |
- digits = 0) {
+ #' column split. |
||
| 103 | -1x | +|||
| 22 | +
- if (isFALSE(0 %in% probs)) probs <- c(0, probs)+ #' |
|||
| 104 | -1x | +|||
| 23 | +
- if (isFALSE(1 %in% probs)) probs <- c(probs, 1)+ #' @return |
|||
| 105 | -8x | +|||
| 24 | +
- checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE)+ #' * `h_row_first_values()` returns a `vector` of numeric values. |
|||
| 106 | -8x | +|||
| 25 | +
- percent <- round(probs * 100, digits = digits)+ #' |
|||
| 107 | -8x | +|||
| 26 | +
- left <- paste0(utils::head(percent, -1), "%")+ #' @examples |
|||
| 108 | -8x | +|||
| 27 | +
- right <- paste0(utils::tail(percent, -1), "%")+ #' tbl <- basic_table() %>% |
|||
| 109 | -8x | +|||
| 28 | +
- without_left_bracket <- paste0(left, ",", right, "]")+ #' split_cols_by("ARM") %>%
|
|||
| 110 | -8x | +|||
| 29 | +
- with_left_bracket <- paste0("[", utils::head(without_left_bracket, 1))
+ #' split_rows_by("RACE") %>%
|
|||
| 111 | -8x | +|||
| 30 | +
- if (length(without_left_bracket) > 1) {
+ #' analyze("AGE", function(x) {
|
|||
| 112 | -6x | +|||
| 31 | +
- with_left_bracket <- c(+ #' list( |
|||
| 113 | -6x | +|||
| 32 | +
- with_left_bracket,+ #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.x (xx.x)"), |
|||
| 114 | -6x | +|||
| 33 | +
- paste0("(", utils::tail(without_left_bracket, -1))
+ #' "n" = length(x), |
|||
| 115 | +34 |
- )+ #' "frac" = rcell(c(0.1, 0.1), format = "xx (xx)") |
||
| 116 | +35 |
- }+ #' ) |
||
| 117 | -8x | +|||
| 36 | +
- with_left_bracket+ #' }) %>% |
|||
| 118 | +37 |
- }+ #' build_table(tern_ex_adsl) %>% |
||
| 119 | +38 |
-
+ #' prune_table() |
||
| 120 | +39 |
- #' Cutting Numeric Vector into Empirical Quantile Bins+ #' tree_row_elem <- collect_leaves(tbl[2, ])[[1]] |
||
| 121 | +40 |
- #'+ #' result <- max(h_row_first_values(tree_row_elem)) |
||
| 122 | +41 |
- #' @description `r lifecycle::badge("stable")`
+ #' result |
||
| 123 | +42 |
#' |
||
| 124 | +43 |
- #' This cuts a numeric vector into sample quantile bins.+ #' @export |
||
| 125 | +44 |
- #'+ h_row_first_values <- function(table_row, |
||
| 126 | +45 |
- #' @inheritParams bins_percent_labels+ col_names = NULL, |
||
| 127 | +46 |
- #' @param x (`numeric`)\cr the continuous variable values which should be cut into+ col_indices = NULL) {
|
||
| 128 | -+ | |||
| 47 | +727x |
- #' quantile bins. This may contain `NA` values, which are then+ col_indices <- check_names_indices(table_row, col_names, col_indices) |
||
| 129 | -+ | |||
| 48 | +727x |
- #' not used for the quantile calculations, but included in the return vector.+ checkmate::assert_integerish(col_indices) |
||
| 130 | -+ | |||
| 49 | +727x |
- #' @param labels (`character`)\cr the unique labels for the quantile bins. When there are `n`+ checkmate::assert_subset(col_indices, seq_len(ncol(table_row))) |
||
| 131 | +50 |
- #' probabilities in `probs`, then this must be `n + 1` long.+ |
||
| 132 | +51 |
- #' @param type (`integer`)\cr type of quantiles to use, see [stats::quantile()] for details.+ # Main values are extracted |
||
| 133 | -+ | |||
| 52 | +727x |
- #' @param ordered (`flag`)\cr should the result be an ordered factor.+ row_vals <- row_values(table_row)[col_indices] |
||
| 134 | +53 |
- #'+ |
||
| 135 | +54 |
- #' @return A `factor` variable with appropriately-labeled bins as levels.+ # Main return |
||
| 136 | -+ | |||
| 55 | +727x |
- #'+ vapply(row_vals, function(rv) {
|
||
| 137 | -+ | |||
| 56 | +2066x |
- #' @note Intervals are closed on the right side. That is, the first bin is the interval+ if (is.null(rv)) {
|
||
| 138 | -+ | |||
| 57 | +727x |
- #' `[-Inf, q1]` where `q1` is the first quantile, the second bin is then `(q1, q2]`, etc.,+ NA_real_ |
||
| 139 | +58 |
- #' and the last bin is `(qn, +Inf]` where `qn` is the last quantile.+ } else {
|
||
| 140 | -+ | |||
| 59 | +2063x |
- #'+ rv[1L] |
||
| 141 | +60 |
- #' @examples+ } |
||
| 142 | -+ | |||
| 61 | +727x |
- #' # Default is to cut into quartile bins.+ }, FUN.VALUE = numeric(1)) |
||
| 143 | +62 |
- #' cut_quantile_bins(cars$speed)+ } |
||
| 144 | +63 |
- #'+ |
||
| 145 | +64 |
- #' # Use custom quantiles.+ #' @describeIn rtables_access Helper function that extracts row values and checks if they are |
||
| 146 | +65 |
- #' cut_quantile_bins(cars$speed, probs = c(0.1, 0.2, 0.6, 0.88))+ #' convertible to integers (`integerish` values). |
||
| 147 | +66 |
#' |
||
| 148 | +67 |
- #' # Use custom labels.+ #' @return |
||
| 149 | +68 |
- #' cut_quantile_bins(cars$speed, labels = paste0("Q", 1:4))
+ #' * `h_row_counts()` returns a `vector` of numeric values. |
||
| 150 | +69 |
#' |
||
| 151 | +70 |
- #' # NAs are preserved in result factor.+ #' @examples |
||
| 152 | +71 |
- #' ozone_binned <- cut_quantile_bins(airquality$Ozone)+ #' # Row counts (integer values) |
||
| 153 | +72 |
- #' which(is.na(ozone_binned))+ #' # h_row_counts(tree_row_elem) # Fails because there are no integers |
||
| 154 | +73 |
- #' # So you might want to make these explicit.+ #' # Using values with integers |
||
| 155 | +74 |
- #' explicit_na(ozone_binned)+ #' tree_row_elem <- collect_leaves(tbl[3, ])[[1]] |
||
| 156 | +75 |
- #'+ #' result <- h_row_counts(tree_row_elem) |
||
| 157 | +76 |
- #' @export+ #' # result |
||
| 158 | +77 |
- cut_quantile_bins <- function(x,+ #' |
||
| 159 | +78 |
- probs = c(0.25, 0.5, 0.75),+ #' @export |
||
| 160 | +79 |
- labels = NULL,+ h_row_counts <- function(table_row, |
||
| 161 | +80 |
- type = 7,+ col_names = NULL, |
||
| 162 | +81 |
- ordered = TRUE) {
- |
- ||
| 163 | -8x | -
- checkmate::assert_flag(ordered)- |
- ||
| 164 | -8x | -
- checkmate::assert_numeric(x)- |
- ||
| 165 | -7x | -
- if (isFALSE(0 %in% probs)) probs <- c(0, probs)+ col_indices = NULL) {
|
||
| 166 | -7x | +82 | +727x |
- if (isFALSE(1 %in% probs)) probs <- c(probs, 1)+ counts <- h_row_first_values(table_row, col_names, col_indices) |
| 167 | -8x | +83 | +727x |
- checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE)+ checkmate::assert_integerish(counts) |
| 168 | -7x | +84 | +727x |
- if (is.null(labels)) labels <- bins_percent_labels(probs)+ counts |
| 169 | -8x | +|||
| 85 | +
- checkmate::assert_character(labels, len = length(probs) - 1, any.missing = FALSE, unique = TRUE)+ } |
|||
| 170 | +86 | |||
| 171 | -8x | +|||
| 87 | +
- if (all(is.na(x))) {
+ #' @describeIn rtables_access helper function to extract fractions from specified columns in a `TableRow`. |
|||
| 172 | +88 |
- # Early return if there are only NAs in input.+ #' More specifically it extracts the second values from each content cell and checks it is a fraction. |
||
| 173 | -1x | +|||
| 89 | +
- return(factor(x, ordered = ordered, levels = labels))+ #' |
|||
| 174 | +90 |
- }+ #' @return |
||
| 175 | +91 |
-
+ #' * `h_row_fractions()` returns a `vector` of proportions. |
||
| 176 | -7x | +|||
| 92 | +
- quantiles <- stats::quantile(+ #' |
|||
| 177 | -7x | +|||
| 93 | +
- x,+ #' @examples |
|||
| 178 | -7x | +|||
| 94 | +
- probs = probs,+ #' # Row fractions |
|||
| 179 | -7x | +|||
| 95 | +
- type = type,+ #' tree_row_elem <- collect_leaves(tbl[4, ])[[1]] |
|||
| 180 | -7x | +|||
| 96 | +
- na.rm = TRUE+ #' h_row_fractions(tree_row_elem) |
|||
| 181 | +97 |
- )+ #' |
||
| 182 | +98 |
-
+ #' @export |
||
| 183 | -7x | +|||
| 99 | +
- checkmate::assert_numeric(quantiles, unique = TRUE)+ h_row_fractions <- function(table_row, |
|||
| 184 | +100 |
-
+ col_names = NULL, |
||
| 185 | -6x | +|||
| 101 | +
- cut(+ col_indices = NULL) {
|
|||
| 186 | -6x | +102 | +243x |
- x,+ col_indices <- check_names_indices(table_row, col_names, col_indices) |
| 187 | -6x | +103 | +243x |
- breaks = quantiles,+ row_vals <- row_values(table_row)[col_indices] |
| 188 | -6x | +104 | +243x |
- labels = labels,+ fractions <- sapply(row_vals, "[", 2L) |
| 189 | -6x | +105 | +243x |
- ordered_result = ordered,+ checkmate::assert_numeric(fractions, lower = 0, upper = 1) |
| 190 | -6x | +106 | +243x |
- include.lowest = TRUE,+ fractions |
| 191 | -6x | +|||
| 107 | +
- right = TRUE+ } |
|||
| 192 | +108 |
- )+ |
||
| 193 | +109 |
- }+ #' @describeIn rtables_access Helper function to extract column counts from specified columns in a table. |
||
| 194 | +110 |
-
+ #' |
||
| 195 | +111 |
- #' Discard Certain Levels from a Factor+ #' @param table (`VTableNodeInfo`)\cr an occurrence table or row. |
||
| 196 | +112 |
#' |
||
| 197 | +113 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return |
||
| 198 | +114 |
- #'+ #' * `h_col_counts()` returns a `vector` of column counts. |
||
| 199 | +115 |
- #' This discards the observations as well as the levels specified from a factor.+ #' |
||
| 200 | +116 |
- #'+ #' @export |
||
| 201 | +117 |
- #' @param x (`factor`)\cr the original factor.+ h_col_counts <- function(table, |
||
| 202 | +118 |
- #' @param discard (`character`)\cr which levels to discard.+ col_names = NULL, |
||
| 203 | +119 |
- #'+ col_indices = NULL) {
|
||
| 204 | -+ | |||
| 120 | +304x |
- #' @return A modified `factor` with observations as well as levels from `discard` dropped.+ col_indices <- check_names_indices(table, col_names, col_indices)+ |
+ ||
| 121 | +304x | +
+ counts <- col_counts(table)[col_indices]+ |
+ ||
| 122 | +304x | +
+ stats::setNames(counts, col_names) |
||
| 205 | +123 |
- #'+ } |
||
| 206 | +124 |
- #' @examples+ |
||
| 207 | +125 |
- #' fct_discard(factor(c("a", "b", "c")), "c")
+ #' @describeIn rtables_access Helper function to get first row of content table of current table. |
||
| 208 | +126 |
#' |
||
| 209 | +127 |
- #' @export+ #' @return |
||
| 210 | +128 |
- fct_discard <- function(x, discard) {
+ #' * `h_content_first_row()` returns a row from an `rtables` table. |
||
| 211 | -292x | +|||
| 129 | +
- checkmate::assert_factor(x)+ #' |
|||
| 212 | -292x | +|||
| 130 | +
- checkmate::assert_character(discard, any.missing = FALSE)+ #' @export |
|||
| 213 | -292x | +|||
| 131 | +
- new_obs <- x[!(x %in% discard)]+ h_content_first_row <- function(table) {
|
|||
| 214 | -292x | +132 | +27x |
- new_levels <- setdiff(levels(x), discard)+ ct <- content_table(table) |
| 215 | -292x | +133 | +27x |
- factor(new_obs, levels = new_levels)+ tree_children(ct)[[1]] |
| 216 | +134 |
} |
||
| 217 | +135 | |||
| 218 | +136 |
- #' Insertion of Explicit Missings in a Factor+ #' @describeIn rtables_access Helper function which says whether current table is a leaf in the tree. |
||
| 219 | +137 |
#' |
||
| 220 | +138 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return |
||
| 221 | +139 |
- #'+ #' * `is_leaf_table()` returns a `logical` value indicating whether current table is a leaf. |
||
| 222 | +140 |
- #' This inserts explicit missings in a factor based on a condition. Additionally,+ #' |
||
| 223 | +141 |
- #' existing `NA` values will be explicitly converted to given `na_level`.+ #' @keywords internal |
||
| 224 | +142 |
- #'+ is_leaf_table <- function(table) {
|
||
| 225 | -+ | |||
| 143 | +168x |
- #' @param x (`factor`)\cr the original factor.+ children <- tree_children(table) |
||
| 226 | -+ | |||
| 144 | +168x |
- #' @param condition (`logical`)\cr where to insert missings.+ child_classes <- unique(sapply(children, class))+ |
+ ||
| 145 | +168x | +
+ identical(child_classes, "ElementaryTable") |
||
| 227 | +146 |
- #' @param na_level (`string`)\cr which level to use for missings.+ } |
||
| 228 | +147 |
- #'+ |
||
| 229 | +148 |
- #' @return A modified `factor` with inserted and existing `NA` converted to `na_level`.+ #' @describeIn rtables_access Internal helper function that tests standard inputs for column indices. |
||
| 230 | +149 |
#' |
||
| 231 | +150 |
- #' @seealso [forcats::fct_na_value_to_level()] which is used internally.+ #' @return |
||
| 232 | +151 |
- #'+ #' * `check_names_indices` returns column indices. |
||
| 233 | +152 |
- #' @examples+ #' |
||
| 234 | +153 |
- #' fct_explicit_na_if(factor(c("a", "b", NA)), c(TRUE, FALSE, FALSE))
+ #' @keywords internal |
||
| 235 | +154 |
- #'+ check_names_indices <- function(table_row, |
||
| 236 | +155 |
- #' @export+ col_names = NULL, |
||
| 237 | +156 |
- fct_explicit_na_if <- function(x, condition, na_level = "<Missing>") {
+ col_indices = NULL) {
|
||
| 238 | -1x | +157 | +1274x |
- checkmate::assert_factor(x, len = length(condition))+ if (!is.null(col_names)) {
|
| 239 | -1x | +158 | +1231x |
- checkmate::assert_logical(condition)+ if (!is.null(col_indices)) {
|
| 240 | -1x | +|||
| 159 | +! |
- x[condition] <- NA+ stop( |
||
| 241 | -1x | +|||
| 160 | +! |
- x <- forcats::fct_na_value_to_level(x, level = na_level)+ "Inserted both col_names and col_indices when selecting row values. ", |
||
| 242 | -1x | +|||
| 161 | +! |
- forcats::fct_drop(x, only = na_level)+ "Please choose one." |
||
| 243 | +162 |
- }+ ) |
||
| 244 | +163 |
-
+ } |
||
| 245 | -+ | |||
| 164 | +1231x |
- #' Collapsing of Factor Levels and Keeping Only Those New Group Levels+ col_indices <- h_col_indices(table_row, col_names) |
||
| 246 | +165 |
- #'+ } |
||
| 247 | -+ | |||
| 166 | +1274x |
- #' @description `r lifecycle::badge("stable")`
+ if (is.null(col_indices)) {
|
||
| 248 | -+ | |||
| 167 | +37x |
- #'+ ll <- ifelse(is.null(ncol(table_row)), length(table_row), ncol(table_row)) |
||
| 249 | -+ | |||
| 168 | +37x |
- #' This collapses levels and only keeps those new group levels, in the order provided.+ col_indices <- seq_len(ll) |
||
| 250 | +169 |
- #' The returned factor has levels in the order given, with the possible missing level last (this will+ } |
||
| 251 | +170 |
- #' only be included if there are missing values).+ + |
+ ||
| 171 | +1274x | +
+ return(col_indices) |
||
| 252 | +172 |
- #'+ } |
| 253 | +1 |
- #' @param .f (`factor` or `character`)\cr original vector.+ #' Confidence Interval for Mean |
||
| 254 | +2 |
- #' @param ... (named `character` vectors)\cr levels in each vector provided will be collapsed into+ #' |
||
| 255 | +3 |
- #' the new level given by the respective name.+ #' @description `r lifecycle::badge("stable")`
|
||
| 256 | +4 |
- #' @param .na_level (`string`)\cr which level to use for other levels, which should be missing in the+ #' |
||
| 257 | +5 |
- #' new factor. Note that this level must not be contained in the new levels specified in `...`.+ #' Convenient function for calculating the mean confidence interval. It calculates the arithmetic as well as the |
||
| 258 | +6 |
- #'+ #' geometric mean. It can be used as a `ggplot` helper function for plotting. |
||
| 259 | +7 |
- #' @return A modified `factor` with collapsed levels. Values and levels which are not included+ #' |
||
| 260 | +8 |
- #' in the given `character` vector input will be set to the missing level `.na_level`.+ #' @inheritParams argument_convention |
||
| 261 | +9 |
- #'+ #' @param n_min (`number`)\cr a minimum number of non-missing `x` to estimate the confidence interval for mean. |
||
| 262 | +10 |
- #' @note Any existing `NA`s in the input vector will not be replaced by the missing level. If needed,+ #' @param gg_helper (`logical`)\cr `TRUE` when output should be aligned for the use with `ggplot`. |
||
| 263 | +11 |
- #' [explicit_na()] can be called separately on the result.+ #' @param geom_mean (`logical`)\cr `TRUE` when the geometric mean should be calculated. |
||
| 264 | +12 |
#' |
||
| 265 | +13 |
- #' @seealso [forcats::fct_collapse()], [forcats::fct_relevel()] which are used internally.+ #' @return A named `vector` of values `mean_ci_lwr` and `mean_ci_upr`. |
||
| 266 | +14 |
#' |
||
| 267 | +15 |
#' @examples |
||
| 268 | +16 |
- #' fct_collapse_only(factor(c("a", "b", "c", "d")), TRT = "b", CTRL = c("c", "d"))
+ #' stat_mean_ci(sample(10), gg_helper = FALSE) |
||
| 269 | +17 |
#' |
||
| 270 | +18 |
- #' @export+ #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) + |
||
| 271 | +19 |
- fct_collapse_only <- function(.f, ..., .na_level = "<Missing>") {
- |
- ||
| 272 | -4x | -
- new_lvls <- names(list(...))+ #' ggplot2::geom_point() |
||
| 273 | -4x | +|||
| 20 | +
- if (checkmate::test_subset(.na_level, new_lvls)) {
+ #' |
|||
| 274 | -1x | +|||
| 21 | +
- stop(paste0(".na_level currently set to '", .na_level, "' must not be contained in the new levels"))
+ #' p + ggplot2::stat_summary( |
|||
| 275 | +22 |
- }+ #' fun.data = stat_mean_ci, |
||
| 276 | -3x | +|||
| 23 | +
- x <- forcats::fct_collapse(.f, ..., other_level = .na_level)+ #' geom = "errorbar" |
|||
| 277 | -3x | +|||
| 24 | +
- do.call(forcats::fct_relevel, args = c(list(.f = x), as.list(new_lvls)))+ #' ) |
|||
| 278 | +25 |
- }+ #' |
||
| 279 | +26 |
-
+ #' p + ggplot2::stat_summary( |
||
| 280 | +27 |
- #' Ungroup Non-Numeric Statistics+ #' fun.data = stat_mean_ci, |
||
| 281 | +28 |
- #'+ #' fun.args = list(conf_level = 0.5), |
||
| 282 | +29 |
- #' Ungroups grouped non-numeric statistics within input vectors `.formats`, `.labels`, and `.indent_mods`.+ #' geom = "errorbar" |
||
| 283 | +30 |
- #'+ #' ) |
||
| 284 | +31 |
- #' @inheritParams argument_convention+ #' |
||
| 285 | +32 |
- #' @param x (`named list` of `numeric`)\cr list of numeric statistics containing the statistics to ungroup.+ #' p + ggplot2::stat_summary( |
||
| 286 | +33 |
- #'+ #' fun.data = stat_mean_ci, |
||
| 287 | +34 |
- #' @return A `list` with modified elements `x`, `.formats`, `.labels`, and `.indent_mods`.+ #' fun.args = list(conf_level = 0.5, geom_mean = TRUE), |
||
| 288 | +35 |
- #'+ #' geom = "errorbar" |
||
| 289 | +36 |
- #' @seealso [a_summary()] which uses this function internally.+ #' ) |
||
| 290 | +37 |
#' |
||
| 291 | +38 |
- #' @keywords internal+ #' @export |
||
| 292 | +39 |
- ungroup_stats <- function(x,+ stat_mean_ci <- function(x, |
||
| 293 | +40 |
- .formats,+ conf_level = 0.95, |
||
| 294 | +41 |
- .labels,+ na.rm = TRUE, # nolint |
||
| 295 | +42 |
- .indent_mods) {
+ n_min = 2, |
||
| 296 | -224x | +|||
| 43 | +
- checkmate::assert_list(x)+ gg_helper = TRUE, |
|||
| 297 | -224x | +|||
| 44 | +
- empty_pval <- "pval" %in% names(x) && length(x[["pval"]]) == 0+ geom_mean = FALSE) {
|
|||
| 298 | -224x | +45 | +592x |
- empty_pval_counts <- "pval_counts" %in% names(x) && length(x[["pval_counts"]]) == 0+ if (na.rm) {
|
| 299 | -224x | +46 | +2x |
- x <- unlist(x, recursive = FALSE)+ x <- stats::na.omit(x) |
| 300 | +47 |
-
+ } |
||
| 301 | -+ | |||
| 48 | +592x |
- # If p-value is empty it is removed by unlist and needs to be re-added+ n <- length(x) |
||
| 302 | -! | +|||
| 49 | +
- if (empty_pval) x[["pval"]] <- character()+ |
|||
| 303 | -3x | +50 | +592x |
- if (empty_pval_counts) x[["pval_counts"]] <- character()+ if (!geom_mean) {
|
| 304 | -224x | +51 | +297x |
- .stats <- names(x)+ m <- mean(x) |
| 305 | +52 |
-
+ } else {
|
||
| 306 | -+ | |||
| 53 | +295x |
- # Ungroup stats+ negative_values_exist <- any(is.na(x[!is.na(x)]) <- x[!is.na(x)] <= 0) |
||
| 307 | -224x | +54 | +295x |
- .formats <- lapply(.stats, function(x) {
+ if (negative_values_exist) {
|
| 308 | -2049x | +55 | +22x |
- .formats[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
+ m <- NA_real_ |
| 309 | +56 |
- })+ } else {
|
||
| 310 | -224x | +57 | +273x |
- .indent_mods <- sapply(.stats, function(x) {
+ x <- log(x) |
| 311 | -2049x | +58 | +273x |
- .indent_mods[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
+ m <- mean(x) |
| 312 | +59 |
- })+ } |
||
| 313 | -224x | +|||
| 60 | +
- .labels <- sapply(.stats, function(x) {
+ }+ |
+ |||
| 61 | ++ | + | ||
| 314 | -1998x | +62 | +592x |
- if (!grepl("\\.", x)) .labels[[x]] else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][2]
+ if (n < n_min || is.na(m)) {
|
| 315 | -+ | |||
| 63 | +100x |
- })+ ci <- c(mean_ci_lwr = NA_real_, mean_ci_upr = NA_real_) |
||
| 316 | +64 |
-
+ } else {
|
||
| 317 | -224x | +65 | +492x |
- list(+ hci <- stats::qt((1 + conf_level) / 2, df = n - 1) * stats::sd(x) / sqrt(n) |
| 318 | -224x | +66 | +492x |
- x = x,+ ci <- c(mean_ci_lwr = m - hci, mean_ci_upr = m + hci) |
| 319 | -224x | +67 | +492x |
- .formats = .formats,+ if (geom_mean) {
|
| 320 | -224x | +68 | +238x |
- .labels = .labels,+ ci <- exp(ci) |
| 321 | -224x | +|||
| 69 | +
- .indent_mods = .indent_mods+ } |
|||
| 322 | +70 |
- )+ } |
||
| 323 | +71 |
- }+ |
| 1 | -+ | |||
| 72 | +592x |
- #' Tabulate Survival Duration by Subgroup+ if (gg_helper) {
|
||
| 2 | -+ | |||
| 73 | +! |
- #'+ m <- ifelse(is.na(m), NA_real_, m) |
||
| 3 | -+ | |||
| 74 | +! |
- #' @description `r lifecycle::badge("stable")`
+ ci <- data.frame(y = ifelse(geom_mean, exp(m), m), ymin = ci[[1]], ymax = ci[[2]]) |
||
| 4 | +75 |
- #'+ } |
||
| 5 | +76 |
- #' Tabulate statistics such as median survival time and hazard ratio for population subgroups.+ |
||
| 6 | -+ | |||
| 77 | +592x |
- #'+ return(ci) |
||
| 7 | +78 |
- #' @inheritParams argument_convention+ } |
||
| 8 | +79 |
- #' @inheritParams survival_coxph_pairwise+ |
||
| 9 | +80 |
- #' @param time_unit (`string`)\cr label with unit of median survival time. Default `NULL` skips displaying unit.+ #' Confidence Interval for Median |
||
| 10 | +81 |
#' |
||
| 11 | +82 |
- #' @details These functions create a layout starting from a data frame which contains+ #' @description `r lifecycle::badge("stable")`
|
||
| 12 | +83 |
- #' the required statistics. Tables typically used as part of forest plot.+ #' |
||
| 13 | +84 |
- #'+ #' Convenient function for calculating the median confidence interval. It can be used as a `ggplot` helper |
||
| 14 | +85 |
- #' @seealso [extract_survival_subgroups()]+ #' function for plotting. |
||
| 15 | +86 |
#' |
||
| 16 | +87 |
- #' @examples+ #' @inheritParams argument_convention |
||
| 17 | +88 |
- #' library(dplyr)+ #' @param gg_helper (`logical`)\cr `TRUE` when output should be aligned for the use with `ggplot`. |
||
| 18 | +89 |
- #' library(forcats)+ #' |
||
| 19 | +90 | ++ |
+ #' @details The function was adapted from `DescTools/versions/0.99.35/source`+ |
+ |
| 91 |
#' |
|||
| 20 | +92 |
- #' adtte <- tern_ex_adtte+ #' @return A named `vector` of values `median_ci_lwr` and `median_ci_upr`. |
||
| 21 | +93 |
#' |
||
| 22 | +94 |
- #' # Save variable labels before data processing steps.+ #' @examples |
||
| 23 | +95 |
- #' adtte_labels <- formatters::var_labels(adtte)+ #' stat_median_ci(sample(10), gg_helper = FALSE) |
||
| 24 | +96 |
#' |
||
| 25 | +97 |
- #' adtte_f <- adtte %>%+ #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) + |
||
| 26 | +98 |
- #' filter(+ #' ggplot2::geom_point() |
||
| 27 | +99 |
- #' PARAMCD == "OS",+ #' p + ggplot2::stat_summary( |
||
| 28 | +100 |
- #' ARM %in% c("B: Placebo", "A: Drug X"),
+ #' fun.data = stat_median_ci, |
||
| 29 | +101 |
- #' SEX %in% c("M", "F")
+ #' geom = "errorbar" |
||
| 30 | +102 |
- #' ) %>%+ #' ) |
||
| 31 | +103 |
- #' mutate(+ #' |
||
| 32 | +104 |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ #' @export |
||
| 33 | +105 |
- #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),+ stat_median_ci <- function(x, |
||
| 34 | +106 |
- #' SEX = droplevels(SEX),+ conf_level = 0.95, |
||
| 35 | +107 |
- #' AVALU = as.character(AVALU),+ na.rm = TRUE, # nolint |
||
| 36 | +108 |
- #' is_event = CNSR == 0+ gg_helper = TRUE) {
|
||
| 37 | -+ | |||
| 109 | +298x |
- #' )+ x <- unname(x) |
||
| 38 | -+ | |||
| 110 | +298x |
- #' labels <- c(+ if (na.rm) {
|
||
| 39 | -+ | |||
| 111 | +3x |
- #' "ARM" = adtte_labels[["ARM"]],+ x <- x[!is.na(x)] |
||
| 40 | +112 |
- #' "SEX" = adtte_labels[["SEX"]],+ } |
||
| 41 | -+ | |||
| 113 | +298x |
- #' "AVALU" = adtte_labels[["AVALU"]],+ n <- length(x) |
||
| 42 | -+ | |||
| 114 | +298x |
- #' "is_event" = "Event Flag"+ med <- stats::median(x) |
||
| 43 | +115 |
- #' )+ |
||
| 44 | -+ | |||
| 116 | +298x |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ k <- stats::qbinom(p = (1 - conf_level) / 2, size = n, prob = 0.5, lower.tail = TRUE) |
||
| 45 | +117 |
- #'+ |
||
| 46 | +118 |
- #' df <- extract_survival_subgroups(+ # k == 0 - for small samples (e.g. n <= 5) ci can be outside the observed range |
||
| 47 | -+ | |||
| 119 | +298x |
- #' variables = list(+ if (k == 0 || is.na(med)) {
|
||
| 48 | -+ | |||
| 120 | +79x |
- #' tte = "AVAL",+ ci <- c(median_ci_lwr = NA_real_, median_ci_upr = NA_real_) |
||
| 49 | -+ | |||
| 121 | +79x |
- #' is_event = "is_event",+ empir_conf_level <- NA_real_ |
||
| 50 | +122 |
- #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ } else {
|
||
| 51 | -+ | |||
| 123 | +219x |
- #' ),+ x_sort <- sort(x) |
||
| 52 | -+ | |||
| 124 | +219x |
- #' data = adtte_f+ ci <- c(median_ci_lwr = x_sort[k], median_ci_upr = x_sort[n - k + 1]) |
||
| 53 | -+ | |||
| 125 | +219x |
- #' )+ empir_conf_level <- 1 - 2 * stats::pbinom(k - 1, size = n, prob = 0.5) |
||
| 54 | +126 |
- #' df+ } |
||
| 55 | +127 |
- #'+ |
||
| 56 | -+ | |||
| 128 | +298x |
- #' @name survival_duration_subgroups+ if (gg_helper) {
+ |
+ ||
| 129 | +! | +
+ ci <- data.frame(y = med, ymin = ci[[1]], ymax = ci[[2]]) |
||
| 57 | +130 |
- NULL+ } |
||
| 58 | +131 | |||
| 59 | -+ | |||
| 132 | +298x |
- #' Prepares Survival Data for Population Subgroups in Data Frames+ attr(ci, "conf_level") <- empir_conf_level |
||
| 60 | +133 |
- #'+ + |
+ ||
| 134 | +298x | +
+ return(ci) |
||
| 61 | +135 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 62 | +136 |
- #'+ |
||
| 63 | +137 |
- #' Prepares estimates of median survival times and treatment hazard ratios for population subgroups in+ #' p-Value of the Mean |
||
| 64 | +138 |
- #' data frames. Simple wrapper for [h_survtime_subgroups_df()] and [h_coxph_subgroups_df()]. Result is a `list`+ #' |
||
| 65 | +139 |
- #' of two `data.frame`s: `survtime` and `hr`. `variables` corresponds to the names of variables found in `data`,+ #' @description `r lifecycle::badge("stable")`
|
||
| 66 | +140 |
- #' passed as a named `list` and requires elements `tte`, `is_event`, `arm` and optionally `subgroups` and `strat`.+ #' |
||
| 67 | +141 |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ #' Convenient function for calculating the two-sided p-value of the mean. |
||
| 68 | +142 |
#' |
||
| 69 | +143 |
#' @inheritParams argument_convention |
||
| 70 | +144 |
- #' @inheritParams survival_duration_subgroups+ #' @param n_min (`numeric`)\cr a minimum number of non-missing `x` to estimate the p-value of the mean. |
||
| 71 | +145 |
- #' @inheritParams survival_coxph_pairwise+ #' @param test_mean (`numeric`)\cr mean value to test under the null hypothesis. |
||
| 72 | +146 |
#' |
||
| 73 | +147 |
- #' @return A named `list` of two elements:+ #' @return A p-value. |
||
| 74 | +148 |
- #' * `survtime`: A `data.frame` containing columns `arm`, `n`, `n_events`, `median`, `subgroup`, `var`,+ #' |
||
| 75 | +149 |
- #' `var_label`, and `row_type`.+ #' @examples |
||
| 76 | +150 |
- #' * `hr`: A `data.frame` containing columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`, `conf_level`,+ #' stat_mean_pval(sample(10)) |
||
| 77 | +151 |
- #' `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`.+ #' |
||
| 78 | +152 |
- #'+ #' stat_mean_pval(rnorm(10), test_mean = 0.5) |
||
| 79 | +153 |
- #' @seealso [survival_duration_subgroups]+ #' |
||
| 80 | +154 |
- #'+ #' @export |
||
| 81 | +155 |
- #' @examples+ stat_mean_pval <- function(x, |
||
| 82 | +156 |
- #' library(dplyr)+ na.rm = TRUE, # nolint |
||
| 83 | +157 |
- #' library(forcats)+ n_min = 2, |
||
| 84 | +158 |
- #'+ test_mean = 0) {
|
||
| 85 | -+ | |||
| 159 | +299x |
- #' adtte <- tern_ex_adtte+ if (na.rm) {
|
||
| 86 | -+ | |||
| 160 | +4x |
- #' adtte_labels <- formatters::var_labels(adtte)+ x <- stats::na.omit(x) |
||
| 87 | +161 |
- #'+ } |
||
| 88 | -+ | |||
| 162 | +299x |
- #' adtte_f <- adtte %>%+ n <- length(x) |
||
| 89 | +163 |
- #' filter(+ |
||
| 90 | -+ | |||
| 164 | +299x |
- #' PARAMCD == "OS",+ x_mean <- mean(x) |
||
| 91 | -+ | |||
| 165 | +299x |
- #' ARM %in% c("B: Placebo", "A: Drug X"),
+ x_sd <- stats::sd(x) |
||
| 92 | +166 |
- #' SEX %in% c("M", "F")
+
|
||
| 93 | -+ | |||
| 167 | +299x |
- #' ) %>%+ if (n < n_min) {
|
||
| 94 | -+ | |||
| 168 | +42x |
- #' mutate(+ pv <- c(p_value = NA_real_) |
||
| 95 | +169 |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ } else {
|
||
| 96 | -+ | |||
| 170 | +257x |
- #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),+ x_se <- stats::sd(x) / sqrt(n) |
||
| 97 | -+ | |||
| 171 | +257x |
- #' SEX = droplevels(SEX),+ ttest <- (x_mean - test_mean) / x_se |
||
| 98 | -+ | |||
| 172 | +257x |
- #' AVALU = as.character(AVALU),+ pv <- c(p_value = 2 * stats::pt(-abs(ttest), df = n - 1)) |
||
| 99 | +173 |
- #' is_event = CNSR == 0+ } |
||
| 100 | +174 |
- #' )+ + |
+ ||
| 175 | +299x | +
+ return(pv) |
||
| 101 | +176 |
- #' labels <- c(+ } |
||
| 102 | +177 |
- #' "ARM" = adtte_labels[["ARM"]],+ |
||
| 103 | +178 |
- #' "SEX" = adtte_labels[["SEX"]],+ #' Proportion Difference and Confidence Interval |
||
| 104 | +179 |
- #' "AVALU" = adtte_labels[["AVALU"]],+ #' |
||
| 105 | +180 |
- #' "is_event" = "Event Flag"+ #' @description `r lifecycle::badge("stable")`
|
||
| 106 | +181 |
- #' )+ #' |
||
| 107 | +182 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ #' Function for calculating the proportion (or risk) difference and confidence interval between arm |
||
| 108 | +183 |
- #'+ #' X (reference group) and arm Y. Risk difference is calculated by subtracting cumulative incidence |
||
| 109 | +184 |
- #' df <- extract_survival_subgroups(+ #' in arm Y from cumulative incidence in arm X. |
||
| 110 | +185 |
- #' variables = list(+ #' |
||
| 111 | +186 |
- #' tte = "AVAL",+ #' @inheritParams argument_convention |
||
| 112 | +187 |
- #' is_event = "is_event",+ #' @param x (`list` of `integer`)\cr list of number of occurrences in arm X (reference group). |
||
| 113 | +188 |
- #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ #' @param y (`list` of `integer`)\cr list of number of occurrences in arm Y. Must be of equal length to `x`. |
||
| 114 | +189 |
- #' ),+ #' @param N_x (`numeric`)\cr total number of records in arm X. |
||
| 115 | +190 |
- #' data = adtte_f+ #' @param N_y (`numeric`)\cr total number of records in arm Y. |
||
| 116 | +191 |
- #' )+ #' @param list_names (`character`)\cr names of each variable/level corresponding to pair of proportions in |
||
| 117 | +192 |
- #' df+ #' `x` and `y`. Must be of equal length to `x` and `y`. |
||
| 118 | +193 |
- #'+ #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`. |
||
| 119 | +194 |
- #' df_grouped <- extract_survival_subgroups(+ #' |
||
| 120 | +195 |
- #' variables = list(+ #' @return List of proportion differences and CIs corresponding to each pair of number of occurrences in `x` and |
||
| 121 | +196 |
- #' tte = "AVAL",+ #' `y`. Each list element consists of 3 statistics: proportion difference, CI lower bound, and CI upper bound. |
||
| 122 | +197 |
- #' is_event = "is_event",+ #' |
||
| 123 | +198 |
- #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ #' @seealso Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()] |
||
| 124 | +199 |
- #' ),+ #' with `riskdiff` argument is set to `TRUE` in subsequent analyze functions, adds a column containing |
||
| 125 | +200 |
- #' data = adtte_f,+ #' proportion (risk) difference to an `rtables` layout. |
||
| 126 | +201 |
- #' groups_lists = list(+ #' |
||
| 127 | +202 |
- #' BMRKR2 = list(+ #' @examples |
||
| 128 | +203 |
- #' "low" = "LOW",+ #' stat_propdiff_ci( |
||
| 129 | +204 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' x = list(0.375), y = list(0.01), N_x = 5, N_y = 5, list_names = "x", conf_level = 0.9 |
||
| 130 | +205 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ #' ) |
||
| 131 | +206 |
- #' )+ #' |
||
| 132 | +207 |
- #' )+ #' stat_propdiff_ci( |
||
| 133 | +208 |
- #' )+ #' x = list(0.5, 0.75, 1), y = list(0.25, 0.05, 0.5), N_x = 10, N_y = 20, pct = FALSE |
||
| 134 | +209 |
- #' df_grouped+ #' ) |
||
| 135 | +210 |
#' |
||
| 136 | +211 |
#' @export |
||
| 137 | +212 |
- extract_survival_subgroups <- function(variables,+ stat_propdiff_ci <- function(x, |
||
| 138 | +213 |
- data,+ y, |
||
| 139 | +214 |
- groups_lists = list(),+ N_x, # nolint |
||
| 140 | +215 |
- control = control_coxph(),+ N_y, # nolint |
||
| 141 | +216 |
- label_all = "All Patients") {
+ list_names = NULL, |
||
| 142 | -8x | +|||
| 217 | +
- df_survtime <- h_survtime_subgroups_df(+ conf_level = 0.95, |
|||
| 143 | -8x | +|||
| 218 | +
- variables,+ pct = TRUE) {
|
|||
| 144 | -8x | +219 | +11x |
- data,+ checkmate::assert_list(x, types = "numeric") |
| 145 | -8x | +220 | +11x |
- groups_lists = groups_lists,+ checkmate::assert_list(y, types = "numeric", len = length(x)) |
| 146 | -8x | -
- label_all = label_all- |
- ||
| 147 | -+ | 221 | +11x |
- )+ checkmate::assert_character(list_names, len = length(x), null.ok = TRUE) |
| 148 | -8x | +222 | +11x |
- df_hr <- h_coxph_subgroups_df(+ rd_list <- lapply(seq_along(x), function(i) {
|
| 149 | -8x | +223 | +25x |
- variables,+ p_x <- x[[i]] / N_x |
| 150 | -8x | +224 | +25x |
- data,+ p_y <- y[[i]] / N_y |
| 151 | -8x | +225 | +25x |
- groups_lists = groups_lists,+ rd_ci <- p_x - p_y + c(-1, 1) * stats::qnorm((1 + conf_level) / 2) * |
| 152 | -8x | +226 | +25x |
- control = control,+ sqrt(p_x * (1 - p_x) / N_x + p_y * (1 - p_y) / N_y) |
| 153 | -8x | +227 | +25x |
- label_all = label_all+ c(p_x - p_y, rd_ci) * ifelse(pct, 100, 1) |
| 154 | +228 |
- )+ }) |
||
| 155 | -+ | |||
| 229 | +11x |
-
+ names(rd_list) <- list_names |
||
| 156 | -8x | +230 | +11x |
- list(survtime = df_survtime, hr = df_hr)+ rd_list |
| 157 | +231 |
} |
| 158 | +1 |
-
+ #' Individual Patient Plots |
||
| 159 | +2 |
- #' @describeIn survival_duration_subgroups Formatted analysis function which is used as+ #' |
||
| 160 | +3 |
- #' `afun` in `tabulate_survival_subgroups()`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 161 | +4 |
#' |
||
| 162 | +5 |
- #' @return+ #' Line plot(s) displaying trend in patients' parameter values over time is rendered. |
||
| 163 | +6 |
- #' * `a_survival_subgroups()` returns the corresponding list with formatted [rtables::CellValue()].+ #' Patients' individual baseline values can be added to the plot(s) as reference. |
||
| 164 | +7 |
#' |
||
| 165 | +8 |
- #' @keywords internal+ #' @inheritParams argument_convention |
||
| 166 | +9 |
- a_survival_subgroups <- function(.formats = list(+ #' @param xvar (`string`)\cr time point variable to be plotted on x-axis. |
||
| 167 | +10 |
- n = "xx",+ #' @param yvar (`string`)\cr continuous analysis variable to be plotted on y-axis. |
||
| 168 | +11 |
- n_events = "xx",+ #' @param xlab (`string`)\cr plot label for x-axis. |
||
| 169 | +12 |
- n_tot_events = "xx",+ #' @param ylab (`string`)\cr plot label for y-axis. |
||
| 170 | +13 |
- median = "xx.x",+ #' @param id_var (`string`)\cr variable used as patient identifier. |
||
| 171 | +14 |
- n_tot = "xx",+ #' @param title (`string`)\cr title for plot. |
||
| 172 | +15 |
- hr = list(format_extreme_values(2L)),+ #' @param subtitle (`string`)\cr subtitle for plot. |
||
| 173 | +16 |
- ci = list(format_extreme_values_ci(2L)),+ #' @param add_baseline_hline (`flag`)\cr adds horizontal line at baseline y-value on |
||
| 174 | +17 |
- pval = "x.xxxx | (<0.0001)"+ #' plot when TRUE. |
||
| 175 | +18 |
- )) {
+ #' @param yvar_baseline (`string`)\cr variable with baseline values only. |
||
| 176 | -12x | +|||
| 19 | +
- checkmate::assert_list(.formats)+ #' Ignored when `add_baseline_hline` is FALSE. |
|||
| 177 | -12x | +|||
| 20 | +
- checkmate::assert_subset(+ #' @param ggtheme (`theme`)\cr optional graphical theme function as provided |
|||
| 178 | -12x | +|||
| 21 | +
- names(.formats),+ #' by `ggplot2` to control outlook of plot. Use `ggplot2::theme()` to tweak the display. |
|||
| 179 | -12x | +|||
| 22 | +
- c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
+ #' @param plotting_choices (`character`)\cr specifies options for displaying |
|||
| 180 | +23 |
- )+ #' plots. Must be one of "all_in_one", "split_by_max_obs", "separate_by_obs". |
||
| 181 | +24 |
-
+ #' @param max_obs_per_plot (`count`)\cr Number of observations to be plotted on one |
||
| 182 | -12x | +|||
| 25 | +
- afun_lst <- Map(+ #' plot. Ignored when `plotting_choices` is not "separate_by_obs". |
|||
| 183 | -12x | +|||
| 26 | +
- function(stat, fmt) {
+ #' @param caption (`character` scalar)\cr optional caption below the plot. |
|||
| 184 | -90x | +|||
| 27 | +
- if (stat == "ci") {
+ #' @param col (`character`)\cr lines colors. |
|||
| 185 | -11x | +|||
| 28 | +
- function(df, labelstr = "", ...) {
+ #' |
|||
| 186 | -20x | +|||
| 29 | +
- in_rows(+ #' @seealso Relevant helper function [h_g_ipp()]. |
|||
| 187 | -20x | +|||
| 30 | +
- .list = combine_vectors(df$lcl, df$ucl),+ #' |
|||
| 188 | -20x | +|||
| 31 | +
- .labels = as.character(df$subgroup),+ #' @name individual_patient_plot |
|||
| 189 | -20x | +|||
| 32 | +
- .formats = fmt+ NULL |
|||
| 190 | +33 |
- )+ |
||
| 191 | +34 |
- }+ #' Helper Function To Create Simple Line Plot over Time |
||
| 192 | +35 |
- } else {
+ #' |
||
| 193 | -79x | +|||
| 36 | +
- function(df, labelstr = "", ...) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 194 | -111x | +|||
| 37 | +
- in_rows(+ #' |
|||
| 195 | -111x | +|||
| 38 | +
- .list = as.list(df[[stat]]),+ #' Function that generates a simple line plot displaying parameter trends over time. |
|||
| 196 | -111x | +|||
| 39 | +
- .labels = as.character(df$subgroup),+ #' |
|||
| 197 | -111x | +|||
| 40 | +
- .formats = fmt+ #' @inheritParams argument_convention |
|||
| 198 | +41 |
- )+ #' @inheritParams g_ipp |
||
| 199 | +42 |
- }+ #' |
||
| 200 | +43 |
- }+ #' @return A `ggplot` line plot. |
||
| 201 | +44 |
- },+ #' |
||
| 202 | -12x | +|||
| 45 | +
- stat = names(.formats),+ #' @seealso [g_ipp()] which uses this function. |
|||
| 203 | -12x | +|||
| 46 | +
- fmt = .formats+ #' |
|||
| 204 | +47 |
- )+ #' @examples |
||
| 205 | +48 |
-
+ #' library(dplyr) |
||
| 206 | -12x | +|||
| 49 | +
- afun_lst+ #' library(nestcolor) |
|||
| 207 | +50 |
- }+ #' |
||
| 208 | +51 |
-
+ #' # Select a small sample of data to plot. |
||
| 209 | +52 |
- #' @describeIn survival_duration_subgroups Table-creating function which creates a table+ #' adlb <- tern_ex_adlb %>% |
||
| 210 | +53 |
- #' summarizing survival by subgroup. This function is a wrapper for [rtables::analyze_colvars()]+ #' filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
|
||
| 211 | +54 |
- #' and [rtables::summarize_row_groups()].+ #' slice(1:36) |
||
| 212 | +55 |
#' |
||
| 213 | +56 |
- #' @param df (`list`)\cr of data frames containing all analysis variables. List should be+ #' p <- h_g_ipp( |
||
| 214 | +57 |
- #' created using [extract_survival_subgroups()].+ #' df = adlb, |
||
| 215 | +58 |
- #' @param vars (`character`)\cr the name of statistics to be reported among:+ #' xvar = "AVISIT", |
||
| 216 | +59 |
- #' * `n_tot_events`: Total number of events per group.+ #' yvar = "AVAL", |
||
| 217 | +60 |
- #' * `n_events`: Number of events per group.+ #' xlab = "Visit", |
||
| 218 | +61 |
- #' * `n_tot`: Total number of observations per group.+ #' id_var = "USUBJID", |
||
| 219 | +62 |
- #' * `n`: Number of observations per group.+ #' ylab = "SGOT/ALT (U/L)", |
||
| 220 | +63 |
- #' * `median`: Median survival time.+ #' add_baseline_hline = TRUE |
||
| 221 | +64 |
- #' * `hr`: Hazard ratio.+ #' ) |
||
| 222 | +65 |
- #' * `ci`: Confidence interval of hazard ratio.+ #' p |
||
| 223 | +66 |
- #' * `pval`: p-value of the effect.+ #' |
||
| 224 | +67 |
- #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci`+ #' @export |
||
| 225 | +68 |
- #' are required.+ h_g_ipp <- function(df, |
||
| 226 | +69 |
- #'+ xvar, |
||
| 227 | +70 |
- #' @return An `rtables` table summarizing survival by subgroup.+ yvar, |
||
| 228 | +71 |
- #'+ xlab, |
||
| 229 | +72 |
- #' @examples+ ylab, |
||
| 230 | +73 |
- #' ## Table with default columns.+ id_var, |
||
| 231 | +74 |
- #' basic_table() %>%+ title = "Individual Patient Plots", |
||
| 232 | +75 |
- #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1])+ subtitle = "", |
||
| 233 | +76 |
- #'+ caption = NULL, |
||
| 234 | +77 |
- #' ## Table with a manually chosen set of columns: adding "pval".+ add_baseline_hline = FALSE, |
||
| 235 | +78 |
- #' basic_table() %>%+ yvar_baseline = "BASE", |
||
| 236 | +79 |
- #' tabulate_survival_subgroups(+ ggtheme = nestcolor::theme_nest(), |
||
| 237 | +80 |
- #' df = df,+ col = NULL) {
|
||
| 238 | -+ | |||
| 81 | +13x |
- #' vars = c("n_tot_events", "n_events", "median", "hr", "ci", "pval"),
+ checkmate::assert_string(xvar) |
||
| 239 | -+ | |||
| 82 | +13x |
- #' time_unit = adtte_f$AVALU[1]+ checkmate::assert_string(yvar) |
||
| 240 | -+ | |||
| 83 | +13x |
- #' )+ checkmate::assert_string(yvar_baseline) |
||
| 241 | -+ | |||
| 84 | +13x |
- #'+ checkmate::assert_string(id_var) |
||
| 242 | -+ | |||
| 85 | +13x |
- #' @export+ checkmate::assert_string(xlab) |
||
| 243 | -+ | |||
| 86 | +13x |
- tabulate_survival_subgroups <- function(lyt,+ checkmate::assert_string(ylab) |
||
| 244 | -+ | |||
| 87 | +13x |
- df,+ checkmate::assert_string(title) |
||
| 245 | -+ | |||
| 88 | +13x |
- vars = c("n_tot_events", "n_events", "median", "hr", "ci"),
+ checkmate::assert_string(subtitle) |
||
| 246 | -+ | |||
| 89 | +13x |
- time_unit = NULL) {
+ checkmate::assert_subset(c(xvar, yvar, yvar_baseline, id_var), colnames(df)) |
||
| 247 | -5x | +90 | +13x |
- conf_level <- df$hr$conf_level[1]+ checkmate::assert_data_frame(df) |
| 248 | -5x | +91 | +13x |
- method <- df$hr$pval_label[1]+ checkmate::assert_flag(add_baseline_hline)+ |
+
| 92 | +13x | +
+ checkmate::assert_character(col, null.ok = TRUE) |
||
| 249 | +93 | |||
| 250 | -5x | +94 | +13x |
- afun_lst <- a_survival_subgroups()+ p <- ggplot2::ggplot( |
| 251 | -5x | +95 | +13x |
- colvars <- d_survival_subgroups_colvars(+ data = df, |
| 252 | -5x | +96 | +13x |
- vars,+ mapping = ggplot2::aes( |
| 253 | -5x | +97 | +13x |
- conf_level = conf_level,+ x = .data[[xvar]], |
| 254 | -5x | +98 | +13x |
- method = method,+ y = .data[[yvar]], |
| 255 | -5x | +99 | +13x |
- time_unit = time_unit+ group = .data[[id_var]],+ |
+
| 100 | +13x | +
+ colour = .data[[id_var]] |
||
| 256 | +101 |
- )+ ) |
||
| 257 | +102 |
-
+ ) + |
||
| 258 | -5x | +103 | +13x |
- colvars_survtime <- list(+ ggplot2::geom_line(linewidth = 0.4) + |
| 259 | -5x | +104 | +13x |
- vars = colvars$vars[names(colvars$labels) %in% c("n", "n_events", "median")],
+ ggplot2::geom_point(size = 2) + |
| 260 | -5x | +105 | +13x |
- labels = colvars$labels[names(colvars$labels) %in% c("n", "n_events", "median")]
+ ggplot2::labs( |
| 261 | -+ | |||
| 106 | +13x |
- )+ x = xlab, |
||
| 262 | -5x | +107 | +13x |
- colvars_hr <- list(+ y = ylab, |
| 263 | -5x | +108 | +13x |
- vars = colvars$vars[names(colvars$labels) %in% c("n_tot", "n_tot_events", "hr", "ci", "pval")],
+ title = title, |
| 264 | -5x | +109 | +13x |
- labels = colvars$labels[names(colvars$labels) %in% c("n_tot", "n_tot_events", "hr", "ci", "pval")]
+ subtitle = subtitle,+ |
+
| 110 | +13x | +
+ caption = caption |
||
| 265 | +111 |
- )+ ) ++ |
+ ||
| 112 | +13x | +
+ ggtheme |
||
| 266 | +113 | |||
| 114 | +13x | +
+ if (add_baseline_hline) {
+ |
+ ||
| 115 | +12x | +
+ baseline_df <- df[, c(id_var, yvar_baseline)]+ |
+ ||
| 116 | +12x | +
+ baseline_df <- unique(baseline_df)+ |
+ ||
| 267 | +117 |
- # Columns from table_survtime are optional.+ |
||
| 268 | -5x | +118 | +12x |
- if (length(colvars_survtime$vars) > 0) {
+ p <- p ++ |
+
| 119 | +12x | +
+ ggplot2::geom_hline(+ |
+ ||
| 120 | +12x | +
+ data = baseline_df,+ |
+ ||
| 121 | +12x | +
+ mapping = ggplot2::aes(+ |
+ ||
| 122 | +12x | +
+ yintercept = .data[[yvar_baseline]],+ |
+ ||
| 123 | +12x | +
+ colour = .data[[id_var]] |
||
| 269 | -4x | +|||
| 124 | +
- lyt_survtime <- split_cols_by(lyt = lyt, var = "arm")+ ), |
|||
| 270 | -4x | +125 | +12x |
- lyt_survtime <- split_rows_by(+ linetype = "dotdash", |
| 271 | -4x | +126 | +12x |
- lyt = lyt_survtime,+ linewidth = 0.4 |
| 272 | -4x | +|||
| 127 | +
- var = "row_type",+ ) + |
|||
| 273 | -4x | +128 | +12x |
- split_fun = keep_split_levels("content"),
+ ggplot2::geom_text( |
| 274 | -4x | +129 | +12x |
- nested = FALSE+ data = baseline_df, |
| 275 | -+ | |||
| 130 | +12x |
- )+ mapping = ggplot2::aes( |
||
| 276 | -4x | +131 | +12x |
- lyt_survtime <- summarize_row_groups(+ x = 1, |
| 277 | -4x | +132 | +12x |
- lyt = lyt_survtime,+ y = .data[[yvar_baseline]], |
| 278 | -4x | +133 | +12x |
- var = "var_label",+ label = .data[[id_var]], |
| 279 | -4x | +134 | +12x |
- cfun = afun_lst[names(colvars_survtime$labels)]+ colour = .data[[id_var]] |
| 280 | +135 |
- )- |
- ||
| 281 | -4x | -
- lyt_survtime <- split_cols_by_multivar(+ ), |
||
| 282 | -4x | +136 | +12x |
- lyt = lyt_survtime,+ nudge_y = 0.025 * (max(df[, yvar], na.rm = TRUE) - min(df[, yvar], na.rm = TRUE)), |
| 283 | -4x | +137 | +12x |
- vars = colvars_survtime$vars,+ vjust = "right", |
| 284 | -4x | +138 | +12x |
- varlabels = colvars_survtime$labels+ size = 2 |
| 285 | +139 |
- )+ ) |
||
| 286 | +140 | |||
| 287 | -4x | +141 | +12x |
- if ("analysis" %in% df$survtime$row_type) {
+ if (!is.null(col)) {
|
| 288 | -3x | +142 | +1x |
- lyt_survtime <- split_rows_by(+ p <- p + |
| 289 | -3x | +143 | +1x |
- lyt = lyt_survtime,+ ggplot2::scale_color_manual(values = col) |
| 290 | -3x | +|||
| 144 | +
- var = "row_type",+ } |
|||
| 291 | -3x | +|||
| 145 | +
- split_fun = keep_split_levels("analysis"),
+ } |
|||
| 292 | -3x | +146 | +13x |
- nested = FALSE,+ p |
| 293 | -3x | +|||
| 147 | +
- child_labels = "hidden"+ } |
|||
| 294 | +148 |
- )+ |
||
| 295 | -3x | +|||
| 149 | +
- lyt_survtime <- split_rows_by(lyt = lyt_survtime, var = "var_label", nested = TRUE)+ #' @describeIn individual_patient_plot Plotting function for individual patient plots which, depending on user |
|||
| 296 | -3x | +|||
| 150 | +
- lyt_survtime <- analyze_colvars(+ #' preference, renders a single graphic or compiles a list of graphics that show trends in individual's parameter |
|||
| 297 | -3x | +|||
| 151 | +
- lyt = lyt_survtime,+ #' values over time. |
|||
| 298 | -3x | +|||
| 152 | +
- afun = afun_lst[names(colvars_survtime$labels)],+ #' |
|||
| 299 | -3x | +|||
| 153 | +
- inclNAs = TRUE+ #' @return A `ggplot` object or a list of `ggplot` objects. |
|||
| 300 | +154 |
- )+ #' |
||
| 301 | +155 |
- }+ #' @examples |
||
| 302 | +156 |
-
+ #' library(dplyr) |
||
| 303 | -4x | +|||
| 157 | +
- table_survtime <- build_table(lyt_survtime, df = df$survtime)+ #' library(nestcolor) |
|||
| 304 | +158 |
- } else {
+ #' |
||
| 305 | -1x | +|||
| 159 | +
- table_survtime <- NULL+ #' # Select a small sample of data to plot. |
|||
| 306 | +160 |
- }+ #' adlb <- tern_ex_adlb %>% |
||
| 307 | +161 |
-
+ #' filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
|
||
| 308 | +162 |
- # Columns "n_tot_events" or "n_tot", and "hr", "ci" in table_hr are required.+ #' slice(1:36) |
||
| 309 | -5x | +|||
| 163 | +
- lyt_hr <- split_cols_by(lyt = lyt, var = "arm")+ #' |
|||
| 310 | -5x | +|||
| 164 | +
- lyt_hr <- split_rows_by(+ #' plot_list <- g_ipp( |
|||
| 311 | -5x | +|||
| 165 | +
- lyt = lyt_hr,+ #' df = adlb, |
|||
| 312 | -5x | +|||
| 166 | +
- var = "row_type",+ #' xvar = "AVISIT", |
|||
| 313 | -5x | +|||
| 167 | +
- split_fun = keep_split_levels("content"),
+ #' yvar = "AVAL", |
|||
| 314 | -5x | +|||
| 168 | +
- nested = FALSE+ #' xlab = "Visit", |
|||
| 315 | +169 |
- )+ #' ylab = "SGOT/ALT (U/L)", |
||
| 316 | -5x | +|||
| 170 | +
- lyt_hr <- summarize_row_groups(+ #' title = "Individual Patient Plots", |
|||
| 317 | -5x | +|||
| 171 | +
- lyt = lyt_hr,+ #' add_baseline_hline = TRUE, |
|||
| 318 | -5x | +|||
| 172 | +
- var = "var_label",+ #' plotting_choices = "split_by_max_obs", |
|||
| 319 | -5x | +|||
| 173 | +
- cfun = afun_lst[names(colvars_hr$labels)]+ #' max_obs_per_plot = 5 |
|||
| 320 | +174 |
- )+ #' ) |
||
| 321 | -5x | +|||
| 175 | +
- lyt_hr <- split_cols_by_multivar(+ #' plot_list |
|||
| 322 | -5x | +|||
| 176 | +
- lyt = lyt_hr,+ #' |
|||
| 323 | -5x | +|||
| 177 | +
- vars = colvars_hr$vars,+ #' @export |
|||
| 324 | -5x | +|||
| 178 | +
- varlabels = colvars_hr$labels+ g_ipp <- function(df, |
|||
| 325 | +179 |
- ) %>%+ xvar, |
||
| 326 | -5x | +|||
| 180 | +
- append_topleft("Baseline Risk Factors")
+ yvar, |
|||
| 327 | +181 |
-
+ xlab, |
||
| 328 | -5x | +|||
| 182 | +
- if ("analysis" %in% df$survtime$row_type) {
+ ylab, |
|||
| 329 | -4x | +|||
| 183 | +
- lyt_hr <- split_rows_by(+ id_var = "USUBJID", |
|||
| 330 | -4x | +|||
| 184 | +
- lyt = lyt_hr,+ title = "Individual Patient Plots", |
|||
| 331 | -4x | +|||
| 185 | +
- var = "row_type",+ subtitle = "", |
|||
| 332 | -4x | +|||
| 186 | +
- split_fun = keep_split_levels("analysis"),
+ caption = NULL, |
|||
| 333 | -4x | +|||
| 187 | +
- nested = FALSE,+ add_baseline_hline = FALSE, |
|||
| 334 | -4x | +|||
| 188 | +
- child_labels = "hidden"+ yvar_baseline = "BASE", |
|||
| 335 | +189 |
- )+ ggtheme = nestcolor::theme_nest(), |
||
| 336 | -4x | +|||
| 190 | +
- lyt_hr <- split_rows_by(lyt = lyt_hr, var = "var_label", nested = TRUE)+ plotting_choices = c("all_in_one", "split_by_max_obs", "separate_by_obs"),
|
|||
| 337 | -4x | +|||
| 191 | +
- lyt_hr <- analyze_colvars(+ max_obs_per_plot = 4, |
|||
| 338 | -4x | +|||
| 192 | +
- lyt = lyt_hr,+ col = NULL) {
|
|||
| 339 | -4x | +193 | +3x |
- afun = afun_lst[names(colvars_hr$labels)],+ checkmate::assert_count(max_obs_per_plot) |
| 340 | -4x | +194 | +3x |
- inclNAs = TRUE+ checkmate::assert_subset(plotting_choices, c("all_in_one", "split_by_max_obs", "separate_by_obs"))
|
| 341 | -+ | |||
| 195 | +3x |
- )+ checkmate::assert_character(col, null.ok = TRUE) |
||
| 342 | +196 |
- }+ |
||
| 343 | -5x | +197 | +3x |
- table_hr <- build_table(lyt_hr, df = df$hr)+ plotting_choices <- match.arg(plotting_choices) |
| 344 | +198 | |||
| 345 | -+ | |||
| 199 | +3x |
- # There can be one or two vars starting with "n_tot".+ if (plotting_choices == "all_in_one") {
|
||
| 346 | -5x | +200 | +1x |
- n_tot_ids <- grep("^n_tot", colvars_hr$vars)
+ p <- h_g_ipp( |
| 347 | -5x | +201 | +1x |
- if (is.null(table_survtime)) {
+ df = df, |
| 348 | +202 | 1x |
- result <- table_hr+ xvar = xvar, |
|
| 349 | +203 | 1x |
- hr_id <- match("hr", colvars_hr$vars)
+ yvar = yvar, |
|
| 350 | +204 | 1x |
- ci_id <- match("lcl", colvars_hr$vars)
+ xlab = xlab, |
|
| 351 | -+ | |||
| 205 | +1x |
- } else {
+ ylab = ylab, |
||
| 352 | -+ | |||
| 206 | +1x |
- # Reorder the table.+ id_var = id_var, |
||
| 353 | -4x | +207 | +1x |
- result <- cbind_rtables(table_hr[, n_tot_ids], table_survtime, table_hr[, -n_tot_ids])+ title = title, |
| 354 | -+ | |||
| 208 | +1x |
- # And then calculate column indices accordingly.+ subtitle = subtitle, |
||
| 355 | -4x | +209 | +1x |
- hr_id <- length(n_tot_ids) + ncol(table_survtime) + match("hr", colvars_hr$vars[-n_tot_ids])
+ caption = caption, |
| 356 | -4x | +210 | +1x |
- ci_id <- length(n_tot_ids) + ncol(table_survtime) + match("lcl", colvars_hr$vars[-n_tot_ids])
+ add_baseline_hline = add_baseline_hline, |
| 357 | -4x | +211 | +1x |
- n_tot_ids <- seq_along(n_tot_ids)+ yvar_baseline = yvar_baseline,+ |
+
| 212 | +1x | +
+ ggtheme = ggtheme,+ |
+ ||
| 213 | +1x | +
+ col = col |
||
| 358 | +214 |
- }+ ) |
||
| 359 | +215 | |||
| 360 | -5x | +216 | +1x |
- structure(+ return(p) |
| 361 | -5x | +217 | +2x |
- result,+ } else if (plotting_choices == "split_by_max_obs") {
|
| 362 | -5x | +218 | +1x |
- forest_header = paste0(rev(levels(df$survtime$arm)), "\nBetter"),+ id_vec <- unique(df[[id_var]]) |
| 363 | -5x | +219 | +1x |
- col_x = hr_id,+ id_list <- split( |
| 364 | -5x | -
- col_ci = ci_id,- |
- ||
| 365 | -+ | 220 | +1x |
- # Take the first one for scaling the symbol sizes in graph.+ id_vec, |
| 366 | -5x | -
- col_symbol_size = n_tot_ids[1]- |
- ||
| 367 | -- |
- )- |
- ||
| 368 | -- |
- }- |
- ||
| 369 | -- | - - | -||
| 370 | -+ | 221 | +1x |
- #' Labels for Column Variables in Survival Duration by Subgroup Table+ rep(1:ceiling(length(id_vec) / max_obs_per_plot), |
| 371 | -+ | |||
| 222 | +1x |
- #'+ each = max_obs_per_plot, |
||
| 372 | -+ | |||
| 223 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ length.out = length(id_vec) |
||
| 373 | +224 |
- #'+ ) |
||
| 374 | +225 |
- #' Internal function to check variables included in [tabulate_survival_subgroups()] and create column labels.+ ) |
||
| 375 | +226 |
- #'+ |
||
| 376 | -+ | |||
| 227 | +1x |
- #' @inheritParams tabulate_survival_subgroups+ df_list <- list() |
||
| 377 | -+ | |||
| 228 | +1x |
- #' @inheritParams argument_convention+ plot_list <- list() |
||
| 378 | +229 |
- #' @param method (`character`)\cr p-value method for testing hazard ratio = 1.+ |
||
| 379 | -+ | |||
| 230 | +1x |
- #'+ for (i in seq_along(id_list)) {
|
||
| 380 | -+ | |||
| 231 | +2x |
- #' @return A `list` of variables and their labels to tabulate.+ df_list[[i]] <- df[df[[id_var]] %in% id_list[[i]], ] |
||
| 381 | +232 |
- #'+ |
||
| 382 | -+ | |||
| 233 | +2x |
- #' @note At least one of `n_tot` and `n_tot_events` must be provided in `vars`.+ plots <- h_g_ipp( |
||
| 383 | -+ | |||
| 234 | +2x |
- #'+ df = df_list[[i]], |
||
| 384 | -+ | |||
| 235 | +2x |
- #' @export+ xvar = xvar, |
||
| 385 | -+ | |||
| 236 | +2x |
- d_survival_subgroups_colvars <- function(vars,+ yvar = yvar, |
||
| 386 | -+ | |||
| 237 | +2x |
- conf_level,+ xlab = xlab, |
||
| 387 | -+ | |||
| 238 | +2x |
- method,+ ylab = ylab, |
||
| 388 | -+ | |||
| 239 | +2x |
- time_unit = NULL) {
+ id_var = id_var, |
||
| 389 | -12x | +240 | +2x |
- checkmate::assert_character(vars)+ title = title, |
| 390 | -12x | +241 | +2x |
- checkmate::assert_string(time_unit, null.ok = TRUE)+ subtitle = subtitle, |
| 391 | -12x | +242 | +2x |
- checkmate::assert_subset(c("hr", "ci"), vars)
+ caption = caption, |
| 392 | -12x | +243 | +2x |
- checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
+ add_baseline_hline = add_baseline_hline, |
| 393 | -12x | +244 | +2x |
- checkmate::assert_subset(+ yvar_baseline = yvar_baseline, |
| 394 | -12x | +245 | +2x |
- vars,+ ggtheme = ggtheme, |
| 395 | -12x | +246 | +2x |
- c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
+ col = col |
| 396 | +247 |
- )+ ) |
||
| 397 | +248 | |||
| 398 | -12x | +249 | +2x |
- propcase_time_label <- if (!is.null(time_unit)) {
+ plot_list[[i]] <- plots+ |
+
| 250 | ++ |
+ } |
||
| 399 | -11x | +251 | +1x |
- paste0("Median (", time_unit, ")")
+ return(plot_list) |
| 400 | +252 |
} else {
|
||
| 401 | +253 | 1x |
- "Median"+ ind_df <- split(df, df[[id_var]]) |
|
| 402 | -+ | |||
| 254 | +1x |
- }+ plot_list <- lapply( |
||
| 403 | -+ | |||
| 255 | +1x |
-
+ ind_df, |
||
| 404 | -12x | +256 | +1x |
- varlabels <- c(+ function(x) {
|
| 405 | -12x | +257 | +8x |
- n = "n",+ h_g_ipp( |
| 406 | -12x | +258 | +8x |
- n_events = "Events",+ df = x, |
| 407 | -12x | +259 | +8x |
- median = propcase_time_label,+ xvar = xvar, |
| 408 | -12x | +260 | +8x |
- n_tot = "Total n",+ yvar = yvar, |
| 409 | -12x | +261 | +8x |
- n_tot_events = "Total Events",+ xlab = xlab, |
| 410 | -12x | +262 | +8x |
- hr = "Hazard Ratio",+ ylab = ylab, |
| 411 | -12x | +263 | +8x |
- ci = paste0(100 * conf_level, "% Wald CI"),+ id_var = id_var, |
| 412 | -12x | +264 | +8x |
- pval = method+ title = title, |
| 413 | -+ | |||
| 265 | +8x |
- )+ subtitle = subtitle, |
||
| 414 | -+ | |||
| 266 | +8x |
-
+ caption = caption, |
||
| 415 | -12x | +267 | +8x |
- colvars <- vars+ add_baseline_hline = add_baseline_hline, |
| 416 | -+ | |||
| 268 | +8x |
-
+ yvar_baseline = yvar_baseline, |
||
| 417 | -+ | |||
| 269 | +8x |
- # The `lcl` variable is just a placeholder available in the analysis data,+ ggtheme = ggtheme, |
||
| 418 | -+ | |||
| 270 | +8x |
- # it is not acutally used in the tabulation.+ col = col |
||
| 419 | +271 |
- # Variables used in the tabulation are lcl and ucl, see `a_survival_subgroups` for details.- |
- ||
| 420 | -12x | -
- colvars[colvars == "ci"] <- "lcl"+ ) |
||
| 421 | +272 |
-
+ } |
||
| 422 | -12x | +|||
| 273 | +
- list(+ ) |
|||
| 423 | -12x | +|||
| 274 | +
- vars = colvars,+ |
|||
| 424 | -12x | +275 | +1x |
- labels = varlabels[vars]+ return(plot_list) |
| 425 | +276 |
- )+ } |
||
| 426 | +277 |
}@@ -126977,14 +126392,14 @@ tern coverage - 94.83% |
| 1 |
- #' `rtables` Access Helper Functions+ #' Compare Variables Between Groups |
||
| 5 |
- #' These are a couple of functions that help with accessing the data in `rtables` objects.+ #' Comparison with a reference group for different `x` objects. |
||
| 6 |
- #' Currently these work for occurrence tables, which are defined as having a count as the first+ #' |
||
| 7 |
- #' element and a fraction as the second element in each cell.+ #' @inheritParams argument_convention |
||
| 9 |
- #' @seealso [prune_occurrences] for usage of these functions.+ #' @note |
||
| 10 |
- #'+ #' * For factor variables, `denom` for factor proportions can only be `n` since the purpose is to compare proportions |
||
| 11 |
- #' @name rtables_access+ #' between columns, therefore a row-based proportion would not make sense. Proportion based on `N_col` would |
||
| 12 |
- NULL+ #' be difficult since we use counts for the chi-squared test statistic, therefore missing values should be accounted |
||
| 13 |
-
+ #' for as explicit factor levels. |
||
| 14 |
- #' @describeIn rtables_access Helper function to extract the first values from each content+ #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values |
||
| 15 |
- #' cell and from specified columns in a `TableRow`. Defaults to all columns.+ #' set `na.rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit |
||
| 16 |
- #'+ #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the |
||
| 17 |
- #' @param table_row (`TableRow`)\cr an analysis row in a occurrence table.+ #' default `na_level` (`"<Missing>"`) will also be excluded when `na.rm` is set to `TRUE`. |
||
| 18 |
- #' @param col_names (`character`)\cr the names of the columns to extract from.+ #' * For character variables, automatic conversion to factor does not guarantee that the table |
||
| 19 |
- #' @param col_indices (`integer`)\cr the indices of the columns to extract from. If `col_names` are provided,+ #' will be generated correctly. In particular for sparse tables this very likely can fail. |
||
| 20 |
- #' then these are inferred from the names of `table_row`. Note that this currently only works well with a single+ #' Therefore it is always better to manually convert character variables to factors during pre-processing. |
||
| 21 |
- #' column split.+ #' * For `compare_vars()`, the column split must define a reference group via `ref_group` so that the comparison |
||
| 22 |
- #'+ #' is well defined. |
||
| 23 |
- #' @return+ #' |
||
| 24 |
- #' * `h_row_first_values()` returns a `vector` of numeric values.+ #' @seealso Relevant constructor function [create_afun_compare()], [s_summary()] which is used internally |
||
| 25 |
- #'+ #' to compute a summary within `s_compare()`, and [a_compare()] which is used (with `compare = TRUE`) as the analysis |
||
| 26 |
- #' @examples+ #' function for `compare_vars()`. |
||
| 27 |
- #' tbl <- basic_table() %>%+ #' |
||
| 28 |
- #' split_cols_by("ARM") %>%
+ #' @name compare_variables |
||
| 29 |
- #' split_rows_by("RACE") %>%
+ #' @include analyze_variables.R |
||
| 30 |
- #' analyze("AGE", function(x) {
+ NULL |
||
| 31 |
- #' list(+ |
||
| 32 |
- #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.x (xx.x)"),+ #' @describeIn compare_variables S3 generic function to produce a comparison summary. |
||
| 33 |
- #' "n" = length(x),+ #' |
||
| 34 |
- #' "frac" = rcell(c(0.1, 0.1), format = "xx (xx)")+ #' @return |
||
| 35 |
- #' )+ #' * `s_compare()` returns output of [s_summary()] and comparisons versus the reference group in the form of p-values. |
||
| 36 |
- #' }) %>%+ #' |
||
| 37 |
- #' build_table(tern_ex_adsl) %>%+ #' @export |
||
| 38 |
- #' prune_table()+ s_compare <- function(x, |
||
| 39 |
- #' tree_row_elem <- collect_leaves(tbl[2, ])[[1]]+ .ref_group, |
||
| 40 |
- #' result <- max(h_row_first_values(tree_row_elem))+ .in_ref_col, |
||
| 41 |
- #' result+ ...) {
|
||
| 42 | -+ | 28x |
- #'+ UseMethod("s_compare", x)
|
| 43 |
- #' @export+ } |
||
| 44 |
- h_row_first_values <- function(table_row,+ |
||
| 45 |
- col_names = NULL,+ #' @describeIn compare_variables Method for `numeric` class. This uses the standard t-test |
||
| 46 |
- col_indices = NULL) {
+ #' to calculate the p-value. |
||
| 47 | -727x | +
- col_indices <- check_names_indices(table_row, col_names, col_indices)+ #' |
|
| 48 | -727x | +
- checkmate::assert_integerish(col_indices)+ #' @method s_compare numeric |
|
| 49 | -727x | +
- checkmate::assert_subset(col_indices, seq_len(ncol(table_row)))+ #' |
|
| 50 |
-
+ #' @examples |
||
| 51 |
- # Main values are extracted+ #' # `s_compare.numeric` |
||
| 52 | -727x | +
- row_vals <- row_values(table_row)[col_indices]+ #' |
|
| 53 |
-
+ #' ## Usual case where both this and the reference group vector have more than 1 value. |
||
| 54 |
- # Main return+ #' s_compare(rnorm(10, 5, 1), .ref_group = rnorm(5, -5, 1), .in_ref_col = FALSE) |
||
| 55 | -727x | +
- vapply(row_vals, function(rv) {
+ #' |
|
| 56 | -2066x | +
- if (is.null(rv)) {
+ #' ## If one group has not more than 1 value, then p-value is not calculated. |
|
| 57 | -727x | +
- NA_real_+ #' s_compare(rnorm(10, 5, 1), .ref_group = 1, .in_ref_col = FALSE) |
|
| 58 |
- } else {
+ #' |
||
| 59 | -2063x | +
- rv[1L]+ #' ## Empty numeric does not fail, it returns NA-filled items and no p-value. |
|
| 60 |
- }+ #' s_compare(numeric(), .ref_group = numeric(), .in_ref_col = FALSE) |
||
| 61 | -727x | +
- }, FUN.VALUE = numeric(1))+ #' |
|
| 62 |
- }+ #' @export |
||
| 63 |
-
+ s_compare.numeric <- function(x, |
||
| 64 |
- #' @describeIn rtables_access Helper function that extracts row values and checks if they are+ .ref_group, |
||
| 65 |
- #' convertible to integers (`integerish` values).+ .in_ref_col, |
||
| 66 |
- #'+ ...) {
|
||
| 67 | -+ | 12x |
- #' @return+ checkmate::assert_numeric(x) |
| 68 | -+ | 12x |
- #' * `h_row_counts()` returns a `vector` of numeric values.+ checkmate::assert_numeric(.ref_group) |
| 69 | -+ | 12x |
- #'+ checkmate::assert_flag(.in_ref_col) |
| 70 |
- #' @examples+ |
||
| 71 | -+ | 12x |
- #' # Row counts (integer values)+ y <- s_summary.numeric(x = x, ...) |
| 72 |
- #' # h_row_counts(tree_row_elem) # Fails because there are no integers+ |
||
| 73 | -+ | 12x |
- #' # Using values with integers+ y$pval <- if (!.in_ref_col && n_available(x) > 1 && n_available(.ref_group) > 1) {
|
| 74 | -+ | 9x |
- #' tree_row_elem <- collect_leaves(tbl[3, ])[[1]]+ stats::t.test(x, .ref_group)$p.value |
| 75 |
- #' result <- h_row_counts(tree_row_elem)+ } else {
|
||
| 76 | -+ | 3x |
- #' # result+ character() |
| 77 |
- #'+ } |
||
| 78 |
- #' @export+ |
||
| 79 | -+ | 12x |
- h_row_counts <- function(table_row,+ y |
| 80 |
- col_names = NULL,+ } |
||
| 81 |
- col_indices = NULL) {
+
|
||
| 82 | -727x | +
- counts <- h_row_first_values(table_row, col_names, col_indices)+ #' @describeIn compare_variables Method for `factor` class. This uses the chi-squared test |
|
| 83 | -727x | +
- checkmate::assert_integerish(counts)+ #' to calculate the p-value. |
|
| 84 | -727x | +
- counts+ #' |
|
| 85 |
- }+ #' @param denom (`string`)\cr choice of denominator for factor proportions, |
||
| 86 |
-
+ #' can only be `n` (number of values in this row and column intersection). |
||
| 87 |
- #' @describeIn rtables_access helper function to extract fractions from specified columns in a `TableRow`.+ #' |
||
| 88 |
- #' More specifically it extracts the second values from each content cell and checks it is a fraction.+ #' @method s_compare factor |
||
| 90 |
- #' @return+ #' @examples |
||
| 91 |
- #' * `h_row_fractions()` returns a `vector` of proportions.+ #' # `s_compare.factor` |
||
| 93 |
- #' @examples+ #' ## Basic usage: |
||
| 94 |
- #' # Row fractions+ #' x <- factor(c("a", "a", "b", "c", "a"))
|
||
| 95 |
- #' tree_row_elem <- collect_leaves(tbl[4, ])[[1]]+ #' y <- factor(c("a", "b", "c"))
|
||
| 96 |
- #' h_row_fractions(tree_row_elem)+ #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE) |
||
| 98 |
- #' @export+ #' ## Management of NA values. |
||
| 99 |
- h_row_fractions <- function(table_row,+ #' x <- explicit_na(factor(c("a", "a", "b", "c", "a", NA, NA)))
|
||
| 100 |
- col_names = NULL,+ #' y <- explicit_na(factor(c("a", "b", "c", NA)))
|
||
| 101 |
- col_indices = NULL) {
+ #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE) |
||
| 102 | -243x | +
- col_indices <- check_names_indices(table_row, col_names, col_indices)+ #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE) |
|
| 103 | -243x | +
- row_vals <- row_values(table_row)[col_indices]+ #' |
|
| 104 | -243x | +
- fractions <- sapply(row_vals, "[", 2L)+ #' @export |
|
| 105 | -243x | +
- checkmate::assert_numeric(fractions, lower = 0, upper = 1)+ s_compare.factor <- function(x, |
|
| 106 | -243x | +
- fractions+ .ref_group, |
|
| 107 |
- }+ .in_ref_col, |
||
| 108 |
-
+ denom = "n", |
||
| 109 |
- #' @describeIn rtables_access Helper function to extract column counts from specified columns in a table.+ na.rm = TRUE, # nolint |
||
| 110 |
- #'+ ...) {
|
||
| 111 | -+ | 12x |
- #' @param table (`VTableNodeInfo`)\cr an occurrence table or row.+ checkmate::assert_flag(.in_ref_col) |
| 112 | -+ | 12x |
- #'+ assert_valid_factor(x) |
| 113 | -+ | 12x |
- #' @return+ assert_valid_factor(.ref_group) |
| 114 | -+ | 12x |
- #' * `h_col_counts()` returns a `vector` of column counts.+ denom <- match.arg(denom) |
| 115 |
- #'+ |
||
| 116 | -+ | 12x |
- #' @export+ y <- s_summary.factor( |
| 117 | -+ | 12x |
- h_col_counts <- function(table,+ x = x, |
| 118 | -+ | 12x |
- col_names = NULL,+ denom = denom, |
| 119 | -+ | 12x |
- col_indices = NULL) {
+ na.rm = na.rm, |
| 120 | -304x | +
- col_indices <- check_names_indices(table, col_names, col_indices)+ ... |
|
| 121 | -304x | +
- counts <- col_counts(table)[col_indices]+ ) |
|
| 122 | -304x | +
- stats::setNames(counts, col_names)+ |
|
| 123 | -+ | 12x |
- }+ if (na.rm) {
|
| 124 | -+ | 12x |
-
+ x <- x[!is.na(x)] %>% fct_discard("<Missing>")
|
| 125 | -+ | 12x |
- #' @describeIn rtables_access Helper function to get first row of content table of current table.+ .ref_group <- .ref_group[!is.na(.ref_group)] %>% fct_discard("<Missing>")
|
| 126 |
- #'+ } else {
|
||
| 127 | -+ | ! |
- #' @return+ x <- x %>% explicit_na(label = "NA") |
| 128 | -+ | ! |
- #' * `h_content_first_row()` returns a row from an `rtables` table.+ .ref_group <- .ref_group %>% explicit_na(label = "NA") |
| 129 |
- #'+ } |
||
| 130 |
- #' @export+ |
||
| 131 | -+ | ! |
- h_content_first_row <- function(table) {
+ if ("NA" %in% levels(x)) levels(.ref_group) <- c(levels(.ref_group), "NA")
|
| 132 | -27x | +12x |
- ct <- content_table(table)+ checkmate::assert_factor(x, levels = levels(.ref_group), min.levels = 2) |
| 133 | -27x | +
- tree_children(ct)[[1]]+ |
|
| 134 | -+ | 12x |
- }+ y$pval_counts <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
|
| 135 | -+ | 9x |
-
+ tab <- rbind(table(x), table(.ref_group)) |
| 136 | -+ | 9x |
- #' @describeIn rtables_access Helper function which says whether current table is a leaf in the tree.+ res <- suppressWarnings(stats::chisq.test(tab)) |
| 137 | -+ | 9x |
- #'+ res$p.value |
| 138 |
- #' @return+ } else {
|
||
| 139 | -+ | 3x |
- #' * `is_leaf_table()` returns a `logical` value indicating whether current table is a leaf.+ character() |
| 140 |
- #'+ } |
||
| 141 |
- #' @keywords internal+ |
||
| 142 | -+ | 12x |
- is_leaf_table <- function(table) {
+ y |
| 143 | -168x | +
- children <- tree_children(table)+ } |
|
| 144 | -168x | +
- child_classes <- unique(sapply(children, class))+ |
|
| 145 | -168x | +
- identical(child_classes, "ElementaryTable")+ #' @describeIn compare_variables Method for `character` class. This makes an automatic |
|
| 146 |
- }+ #' conversion to `factor` (with a warning) and then forwards to the method for factors. |
||
| 147 |
-
+ #' |
||
| 148 |
- #' @describeIn rtables_access Internal helper function that tests standard inputs for column indices.+ #' @param verbose (`logical`)\cr Whether warnings and messages should be printed. Mainly used |
||
| 149 |
- #'+ #' to print out information about factor casting. Defaults to `TRUE`. |
||
| 150 |
- #' @return+ #' |
||
| 151 |
- #' * `check_names_indices` returns column indices.+ #' @method s_compare character |
||
| 153 |
- #' @keywords internal+ #' @examples |
||
| 154 |
- check_names_indices <- function(table_row,+ #' # `s_compare.character` |
||
| 155 |
- col_names = NULL,+ #' |
||
| 156 |
- col_indices = NULL) {
+ #' ## Basic usage: |
||
| 157 | -1274x | +
- if (!is.null(col_names)) {
+ #' x <- c("a", "a", "b", "c", "a")
|
|
| 158 | -1231x | +
- if (!is.null(col_indices)) {
+ #' y <- c("a", "b", "c")
|
|
| 159 | -! | +
- stop(+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, .var = "x", verbose = FALSE) |
|
| 160 | -! | +
- "Inserted both col_names and col_indices when selecting row values. ",+ #' |
|
| 161 | -! | +
- "Please choose one."+ #' ## Note that missing values handling can make a large difference: |
|
| 162 |
- )+ #' x <- c("a", "a", "b", "c", "a", NA)
|
||
| 163 |
- }+ #' y <- c("a", "b", "c", rep(NA, 20))
|
||
| 164 | -1231x | +
- col_indices <- h_col_indices(table_row, col_names)+ #' s_compare(x, |
|
| 165 |
- }+ #' .ref_group = y, .in_ref_col = FALSE, |
||
| 166 | -1274x | +
- if (is.null(col_indices)) {
+ #' .var = "x", verbose = FALSE |
|
| 167 | -37x | +
- ll <- ifelse(is.null(ncol(table_row)), length(table_row), ncol(table_row))+ #' ) |
|
| 168 | -37x | +
- col_indices <- seq_len(ll)+ #' s_compare(x, |
|
| 169 |
- }+ #' .ref_group = y, .in_ref_col = FALSE, .var = "x", |
||
| 170 |
-
+ #' na.rm = FALSE, verbose = FALSE |
||
| 171 | -1274x | +
- return(col_indices)+ #' ) |
|
| 172 |
- }+ #' |
| 1 | +173 |
- #' Confidence Interval for Mean+ #' @export |
||
| 2 | +174 |
- #'+ s_compare.character <- function(x, |
||
| 3 | +175 |
- #' @description `r lifecycle::badge("stable")`
+ .ref_group, |
||
| 4 | +176 |
- #'+ .in_ref_col, |
||
| 5 | +177 |
- #' Convenient function for calculating the mean confidence interval. It calculates the arithmetic as well as the+ denom = "n", |
||
| 6 | +178 |
- #' geometric mean. It can be used as a `ggplot` helper function for plotting.+ na.rm = TRUE, # nolint |
||
| 7 | +179 |
- #'+ .var, |
||
| 8 | +180 |
- #' @inheritParams argument_convention+ verbose = TRUE, |
||
| 9 | +181 |
- #' @param n_min (`number`)\cr a minimum number of non-missing `x` to estimate the confidence interval for mean.+ ...) {
|
||
| 10 | -+ | |||
| 182 | +1x |
- #' @param gg_helper (`logical`)\cr `TRUE` when output should be aligned for the use with `ggplot`.+ x <- as_factor_keep_attributes(x, verbose = verbose) |
||
| 11 | -+ | |||
| 183 | +1x |
- #' @param geom_mean (`logical`)\cr `TRUE` when the geometric mean should be calculated.+ .ref_group <- as_factor_keep_attributes(.ref_group, verbose = verbose) |
||
| 12 | -+ | |||
| 184 | +1x |
- #'+ s_compare( |
||
| 13 | -+ | |||
| 185 | +1x |
- #' @return A named `vector` of values `mean_ci_lwr` and `mean_ci_upr`.+ x = x, |
||
| 14 | -+ | |||
| 186 | +1x |
- #'+ .ref_group = .ref_group,+ |
+ ||
| 187 | +1x | +
+ .in_ref_col = .in_ref_col,+ |
+ ||
| 188 | +1x | +
+ denom = denom,+ |
+ ||
| 189 | +1x | +
+ na.rm = na.rm, |
||
| 15 | +190 |
- #' @examples+ ... |
||
| 16 | +191 |
- #' stat_mean_ci(sample(10), gg_helper = FALSE)+ ) |
||
| 17 | +192 |
- #'+ } |
||
| 18 | +193 |
- #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) ++ |
||
| 19 | +194 |
- #' ggplot2::geom_point()+ #' @describeIn compare_variables Method for `logical` class. A chi-squared test |
||
| 20 | +195 |
- #'+ #' is used. If missing values are not removed, then they are counted as `FALSE`. |
||
| 21 | +196 |
- #' p + ggplot2::stat_summary(+ #' |
||
| 22 | +197 |
- #' fun.data = stat_mean_ci,+ #' @method s_compare logical |
||
| 23 | +198 |
- #' geom = "errorbar"+ #' |
||
| 24 | +199 |
- #' )+ #' @examples |
||
| 25 | +200 |
- #'+ #' # `s_compare.logical` |
||
| 26 | +201 |
- #' p + ggplot2::stat_summary(+ #' |
||
| 27 | +202 |
- #' fun.data = stat_mean_ci,+ #' ## Basic usage: |
||
| 28 | +203 |
- #' fun.args = list(conf_level = 0.5),+ #' x <- c(TRUE, FALSE, TRUE, TRUE) |
||
| 29 | +204 |
- #' geom = "errorbar"+ #' y <- c(FALSE, FALSE, TRUE) |
||
| 30 | +205 |
- #' )+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE) |
||
| 31 | +206 |
#' |
||
| 32 | +207 |
- #' p + ggplot2::stat_summary(+ #' ## Management of NA values. |
||
| 33 | +208 |
- #' fun.data = stat_mean_ci,+ #' x <- c(NA, TRUE, FALSE) |
||
| 34 | +209 |
- #' fun.args = list(conf_level = 0.5, geom_mean = TRUE),+ #' y <- c(NA, NA, NA, NA, FALSE) |
||
| 35 | +210 |
- #' geom = "errorbar"+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE) |
||
| 36 | +211 |
- #' )+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE) |
||
| 37 | +212 |
#' |
||
| 38 | +213 |
#' @export |
||
| 39 | +214 |
- stat_mean_ci <- function(x,+ s_compare.logical <- function(x, |
||
| 40 | +215 |
- conf_level = 0.95,+ .ref_group, |
||
| 41 | +216 |
- na.rm = TRUE, # nolint+ .in_ref_col, |
||
| 42 | +217 |
- n_min = 2,+ na.rm = TRUE, # nolint |
||
| 43 | +218 |
- gg_helper = TRUE,+ denom = "n", |
||
| 44 | +219 |
- geom_mean = FALSE) {
- |
- ||
| 45 | -592x | -
- if (na.rm) {
+ ...) {
|
||
| 46 | -2x | +220 | +3x |
- x <- stats::na.omit(x)+ denom <- match.arg(denom) |
| 47 | +221 |
- }+ |
||
| 48 | -592x | +222 | +3x |
- n <- length(x)+ y <- s_summary.logical( |
| 49 | -+ | |||
| 223 | +3x |
-
+ x = x, |
||
| 50 | -592x | +224 | +3x |
- if (!geom_mean) {
+ na.rm = na.rm, |
| 51 | -297x | +225 | +3x |
- m <- mean(x)+ denom = denom, |
| 52 | +226 |
- } else {
+ ...+ |
+ ||
| 227 | ++ |
+ )+ |
+ ||
| 228 | ++ | + | ||
| 53 | -295x | +229 | +3x |
- negative_values_exist <- any(is.na(x[!is.na(x)]) <- x[!is.na(x)] <= 0)+ if (na.rm) {
|
| 54 | -295x | +230 | +2x |
- if (negative_values_exist) {
+ x <- stats::na.omit(x) |
| 55 | -22x | +231 | +2x |
- m <- NA_real_+ .ref_group <- stats::na.omit(.ref_group) |
| 56 | +232 |
- } else {
+ } else {
|
||
| 57 | -273x | +233 | +1x |
- x <- log(x)+ x[is.na(x)] <- FALSE |
| 58 | -273x | -
- m <- mean(x)- |
- ||
| 59 | -+ | 234 | +1x |
- }+ .ref_group[is.na(.ref_group)] <- FALSE |
| 60 | +235 |
} |
||
| 61 | +236 | |||
| 62 | -592x | +237 | +3x |
- if (n < n_min || is.na(m)) {
+ y$pval_counts <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
|
| 63 | -100x | -
- ci <- c(mean_ci_lwr = NA_real_, mean_ci_upr = NA_real_)- |
- ||
| 64 | -+ | 238 | +3x |
- } else {
+ x <- factor(x, levels = c(TRUE, FALSE)) |
| 65 | -492x | +239 | +3x |
- hci <- stats::qt((1 + conf_level) / 2, df = n - 1) * stats::sd(x) / sqrt(n)+ .ref_group <- factor(.ref_group, levels = c(TRUE, FALSE)) |
| 66 | -492x | +240 | +3x |
- ci <- c(mean_ci_lwr = m - hci, mean_ci_upr = m + hci)+ tbl <- rbind(table(x), table(.ref_group)) |
| 67 | -492x | +241 | +3x |
- if (geom_mean) {
+ suppressWarnings(prop_chisq(tbl)) |
| 68 | -238x | +|||
| 242 | +
- ci <- exp(ci)+ } else {
|
|||
| 69 | -+ | |||
| 243 | +! |
- }+ character() |
||
| 70 | +244 |
} |
||
| 71 | +245 | |||
| 72 | -592x | -
- if (gg_helper) {
- |
- ||
| 73 | -! | +246 | +3x |
- m <- ifelse(is.na(m), NA_real_, m)+ y |
| 74 | -! | +|||
| 247 | +
- ci <- data.frame(y = ifelse(geom_mean, exp(m), m), ymin = ci[[1]], ymax = ci[[2]])+ } |
|||
| 75 | +248 |
- }+ |
||
| 76 | +249 |
-
+ #' @describeIn compare_variables Formatted analysis function which is used as `afun` |
||
| 77 | -592x | +|||
| 250 | +
- return(ci)+ #' in `compare_vars()`. |
|||
| 78 | +251 |
- }+ #' |
||
| 79 | +252 |
-
+ #' @return |
||
| 80 | +253 |
- #' Confidence Interval for Median+ #' * `a_compare()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 81 | +254 |
#' |
||
| 82 | +255 |
- #' @description `r lifecycle::badge("stable")`
+ #' @note `a_compare()` has been deprecated in favor of `a_summary()` with argument `compare` set to `TRUE`. |
||
| 83 | +256 |
#' |
||
| 84 | +257 |
- #' Convenient function for calculating the median confidence interval. It can be used as a `ggplot` helper+ #' @examples |
||
| 85 | +258 |
- #' function for plotting.+ #' # `a_compare` deprecated - use `a_summary()` instead |
||
| 86 | +259 |
- #'+ #' a_compare(rnorm(10, 5, 1), .ref_group = rnorm(20, -5, 1), .stats = c("n", "pval"))
|
||
| 87 | +260 |
- #' @inheritParams argument_convention+ #' |
||
| 88 | +261 |
- #' @param gg_helper (`logical`)\cr `TRUE` when output should be aligned for the use with `ggplot`.+ #' @export |
||
| 89 | +262 |
- #'+ a_compare <- function(x, |
||
| 90 | +263 |
- #' @details The function was adapted from `DescTools/versions/0.99.35/source`+ .N_col, # nolint |
||
| 91 | +264 |
- #'+ .N_row, # nolint |
||
| 92 | +265 |
- #' @return A named `vector` of values `median_ci_lwr` and `median_ci_upr`.+ .var = NULL, |
||
| 93 | +266 |
- #'+ .df_row = NULL, |
||
| 94 | +267 |
- #' @examples+ .ref_group = NULL, |
||
| 95 | +268 |
- #' stat_median_ci(sample(10), gg_helper = FALSE)+ .in_ref_col = FALSE, |
||
| 96 | +269 |
- #'+ ...) {
|
||
| 97 | -+ | |||
| 270 | +1x |
- #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) ++ lifecycle::deprecate_warn( |
||
| 98 | -+ | |||
| 271 | +1x |
- #' ggplot2::geom_point()+ "0.8.3", |
||
| 99 | -+ | |||
| 272 | +1x |
- #' p + ggplot2::stat_summary(+ "a_compare()",+ |
+ ||
| 273 | +1x | +
+ details = "Please use a_summary() with argument `compare` set to TRUE instead." |
||
| 100 | +274 |
- #' fun.data = stat_median_ci,+ )+ |
+ ||
| 275 | +1x | +
+ a_summary(+ |
+ ||
| 276 | +1x | +
+ x = x,+ |
+ ||
| 277 | +1x | +
+ .N_col = .N_col,+ |
+ ||
| 278 | +1x | +
+ .N_row = .N_row,+ |
+ ||
| 279 | +1x | +
+ .var = .var,+ |
+ ||
| 280 | +1x | +
+ .df_row = .df_row,+ |
+ ||
| 281 | +1x | +
+ .ref_group = .ref_group,+ |
+ ||
| 282 | +1x | +
+ .in_ref_col = .in_ref_col,+ |
+ ||
| 283 | +1x | +
+ compare = TRUE, |
||
| 101 | +284 |
- #' geom = "errorbar"+ ... |
||
| 102 | +285 |
- #' )+ ) |
||
| 103 | +286 |
- #'+ } |
||
| 104 | +287 |
- #' @export+ |
||
| 105 | +288 |
- stat_median_ci <- function(x,+ #' Constructor Function for [compare_vars()] |
||
| 106 | +289 |
- conf_level = 0.95,+ #' |
||
| 107 | +290 |
- na.rm = TRUE, # nolint+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 108 | +291 |
- gg_helper = TRUE) {
+ #' |
||
| 109 | -298x | +|||
| 292 | +
- x <- unname(x)+ #' Constructor function which creates a combined formatted analysis function. |
|||
| 110 | -298x | +|||
| 293 | +
- if (na.rm) {
+ #' |
|||
| 111 | -3x | +|||
| 294 | +
- x <- x[!is.na(x)]+ #' @inheritParams argument_convention |
|||
| 112 | +295 |
- }+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 113 | -298x | +|||
| 296 | +
- n <- length(x)+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
|||
| 114 | -298x | +|||
| 297 | +
- med <- stats::median(x)+ #' for that statistic's row label. |
|||
| 115 | +298 |
-
+ #' |
||
| 116 | -298x | +|||
| 299 | +
- k <- stats::qbinom(p = (1 - conf_level) / 2, size = n, prob = 0.5, lower.tail = TRUE)+ #' @return Combined formatted analysis function for use in [compare_vars()]. |
|||
| 117 | +300 |
-
+ #' |
||
| 118 | +301 |
- # k == 0 - for small samples (e.g. n <= 5) ci can be outside the observed range+ #' @note This function has been deprecated in favor of direct implementation of `a_summary()` with argument `compare` |
||
| 119 | -298x | +|||
| 302 | +
- if (k == 0 || is.na(med)) {
+ #' set to `TRUE`. |
|||
| 120 | -79x | +|||
| 303 | +
- ci <- c(median_ci_lwr = NA_real_, median_ci_upr = NA_real_)+ #' |
|||
| 121 | -79x | +|||
| 304 | +
- empir_conf_level <- NA_real_+ #' @seealso [compare_vars()] |
|||
| 122 | +305 |
- } else {
+ #' |
||
| 123 | -219x | +|||
| 306 | +
- x_sort <- sort(x)+ #' @export |
|||
| 124 | -219x | +|||
| 307 | +
- ci <- c(median_ci_lwr = x_sort[k], median_ci_upr = x_sort[n - k + 1])+ create_afun_compare <- function(.stats = NULL, |
|||
| 125 | -219x | +|||
| 308 | +
- empir_conf_level <- 1 - 2 * stats::pbinom(k - 1, size = n, prob = 0.5)+ .formats = NULL, |
|||
| 126 | +309 |
- }+ .labels = NULL, |
||
| 127 | +310 |
-
+ .indent_mods = NULL) {
|
||
| 128 | -298x | +311 | +1x |
- if (gg_helper) {
+ lifecycle::deprecate_warn( |
| 129 | -! | +|||
| 312 | +1x |
- ci <- data.frame(y = med, ymin = ci[[1]], ymax = ci[[2]])+ "0.8.5.9010", |
||
| 130 | -+ | |||
| 313 | +1x |
- }+ "create_afun_compare()",+ |
+ ||
| 314 | +1x | +
+ details = "Please use a_summary(compare = TRUE) directly instead." |
||
| 131 | +315 |
-
+ ) |
||
| 132 | -298x | +316 | +1x |
- attr(ci, "conf_level") <- empir_conf_level+ function(x, |
| 133 | -+ | |||
| 317 | +1x |
-
+ .ref_group, |
||
| 134 | -298x | +318 | +1x |
- return(ci)+ .in_ref_col, |
| 135 | +319 |
- }+ ..., |
||
| 136 | -+ | |||
| 320 | +1x |
-
+ .var) {
|
||
| 137 | -+ | |||
| 321 | +! | +
+ a_summary(x,+ |
+ ||
| 322 | +! |
- #' p-Value of the Mean+ compare = TRUE, |
||
| 138 | -+ | |||
| 323 | +! |
- #'+ .stats = .stats, |
||
| 139 | -+ | |||
| 324 | +! |
- #' @description `r lifecycle::badge("stable")`
+ .formats = .formats, |
||
| 140 | -+ | |||
| 325 | +! |
- #'+ .labels = .labels, |
||
| 141 | -+ | |||
| 326 | +! |
- #' Convenient function for calculating the two-sided p-value of the mean.+ .indent_mods = .indent_mods, |
||
| 142 | -+ | |||
| 327 | +! |
- #'+ .ref_group = .ref_group, |
||
| 143 | -+ | |||
| 328 | +! |
- #' @inheritParams argument_convention+ .in_ref_col = .in_ref_col, |
||
| 144 | -+ | |||
| 329 | +! |
- #' @param n_min (`numeric`)\cr a minimum number of non-missing `x` to estimate the p-value of the mean.+ .var = .var, ... |
||
| 145 | +330 |
- #' @param test_mean (`numeric`)\cr mean value to test under the null hypothesis.+ ) |
||
| 146 | +331 |
- #'+ } |
||
| 147 | +332 |
- #' @return A p-value.+ } |
||
| 148 | +333 |
- #'+ |
||
| 149 | +334 |
- #' @examples+ #' @describeIn compare_variables Layout-creating function which can take statistics function arguments |
||
| 150 | +335 |
- #' stat_mean_pval(sample(10))+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 151 | +336 |
#' |
||
| 152 | +337 |
- #' stat_mean_pval(rnorm(10), test_mean = 0.5)+ #' @param ... arguments passed to `s_compare()`. |
||
| 153 | +338 |
- #'+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 154 | +339 |
- #' @export+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
||
| 155 | +340 |
- stat_mean_pval <- function(x,+ #' for that statistic's row label. |
||
| 156 | +341 |
- na.rm = TRUE, # nolint+ #' |
||
| 157 | +342 |
- n_min = 2,+ #' @return |
||
| 158 | +343 |
- test_mean = 0) {
- |
- ||
| 159 | -299x | -
- if (na.rm) {
- |
- ||
| 160 | -4x | -
- x <- stats::na.omit(x)+ #' * `compare_vars()` returns a layout object suitable for passing to further layouting functions, |
||
| 161 | +344 |
- }- |
- ||
| 162 | -299x | -
- n <- length(x)+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 163 | +345 | - - | -||
| 164 | -299x | -
- x_mean <- mean(x)- |
- ||
| 165 | -299x | -
- x_sd <- stats::sd(x)+ #' the statistics from `s_compare()` to the table layout. |
||
| 166 | +346 | - - | -||
| 167 | -299x | -
- if (n < n_min) {
- |
- ||
| 168 | -42x | -
- pv <- c(p_value = NA_real_)+ #' |
||
| 169 | +347 |
- } else {
- |
- ||
| 170 | -257x | -
- x_se <- stats::sd(x) / sqrt(n)- |
- ||
| 171 | -257x | -
- ttest <- (x_mean - test_mean) / x_se- |
- ||
| 172 | -257x | -
- pv <- c(p_value = 2 * stats::pt(-abs(ttest), df = n - 1))+ #' @examples |
||
| 173 | +348 |
- }+ #' # `compare_vars()` in `rtables` pipelines |
||
| 174 | +349 | - - | -||
| 175 | -299x | -
- return(pv)+ #' |
||
| 176 | +350 |
- }+ #' ## Default output within a `rtables` pipeline. |
||
| 177 | +351 |
-
+ #' lyt <- basic_table() %>% |
||
| 178 | +352 |
- #' Proportion Difference and Confidence Interval+ #' split_cols_by("ARMCD", ref_group = "ARM B") %>%
|
||
| 179 | +353 |
- #'+ #' compare_vars(c("AGE", "SEX"))
|
||
| 180 | +354 |
- #' @description `r lifecycle::badge("stable")`
+ #' build_table(lyt, tern_ex_adsl) |
||
| 181 | +355 |
#' |
||
| 182 | +356 |
- #' Function for calculating the proportion (or risk) difference and confidence interval between arm+ #' ## Select and format statistics output. |
||
| 183 | +357 |
- #' X (reference group) and arm Y. Risk difference is calculated by subtracting cumulative incidence+ #' lyt <- basic_table() %>% |
||
| 184 | +358 |
- #' in arm Y from cumulative incidence in arm X.+ #' split_cols_by("ARMCD", ref_group = "ARM C") %>%
|
||
| 185 | +359 |
- #'+ #' compare_vars( |
||
| 186 | +360 |
- #' @inheritParams argument_convention+ #' vars = "AGE", |
||
| 187 | +361 |
- #' @param x (`list` of `integer`)\cr list of number of occurrences in arm X (reference group).+ #' .stats = c("mean_sd", "pval"),
|
||
| 188 | +362 |
- #' @param y (`list` of `integer`)\cr list of number of occurrences in arm Y. Must be of equal length to `x`.+ #' .formats = c(mean_sd = "xx.x, xx.x"), |
||
| 189 | +363 |
- #' @param N_x (`numeric`)\cr total number of records in arm X.+ #' .labels = c(mean_sd = "Mean, SD") |
||
| 190 | +364 |
- #' @param N_y (`numeric`)\cr total number of records in arm Y.+ #' ) |
||
| 191 | +365 |
- #' @param list_names (`character`)\cr names of each variable/level corresponding to pair of proportions in+ #' build_table(lyt, df = tern_ex_adsl) |
||
| 192 | +366 |
- #' `x` and `y`. Must be of equal length to `x` and `y`.+ #' |
||
| 193 | +367 |
- #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`.+ #' @export |
||
| 194 | +368 |
- #'+ compare_vars <- function(lyt, |
||
| 195 | +369 |
- #' @return List of proportion differences and CIs corresponding to each pair of number of occurrences in `x` and+ vars, |
||
| 196 | +370 |
- #' `y`. Each list element consists of 3 statistics: proportion difference, CI lower bound, and CI upper bound.+ var_labels = vars, |
||
| 197 | +371 |
- #'+ na_level = lifecycle::deprecated(), |
||
| 198 | +372 |
- #' @seealso Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()]+ na_str = NA_character_, |
||
| 199 | +373 |
- #' with `riskdiff` argument is set to `TRUE` in subsequent analyze functions, adds a column containing+ nested = TRUE, |
||
| 200 | +374 |
- #' proportion (risk) difference to an `rtables` layout.+ ..., |
||
| 201 | +375 |
- #'+ na.rm = TRUE, # nolint |
||
| 202 | +376 |
- #' @examples+ show_labels = "default", |
||
| 203 | +377 |
- #' stat_propdiff_ci(+ table_names = vars, |
||
| 204 | +378 |
- #' x = list(0.375), y = list(0.01), N_x = 5, N_y = 5, list_names = "x", conf_level = 0.9+ section_div = NA_character_, |
||
| 205 | +379 |
- #' )+ .stats = c("n", "mean_sd", "count_fraction", "pval"),
|
||
| 206 | +380 |
- #'+ .formats = NULL, |
||
| 207 | +381 |
- #' stat_propdiff_ci(+ .labels = NULL, |
||
| 208 | +382 |
- #' x = list(0.5, 0.75, 1), y = list(0.25, 0.05, 0.5), N_x = 10, N_y = 20, pct = FALSE+ .indent_mods = NULL) {
|
||
| 209 | -+ | |||
| 383 | +3x |
- #' )+ if (lifecycle::is_present(na_level)) {
|
||
| 210 | -+ | |||
| 384 | +! |
- #'+ lifecycle::deprecate_warn("0.9.1", "compare_vars(na_level)", "compare_vars(na_str)")
|
||
| 211 | -+ | |||
| 385 | +! |
- #' @export+ na_str <- na_level |
||
| 212 | +386 |
- stat_propdiff_ci <- function(x,+ } |
||
| 213 | +387 |
- y,+ |
||
| 214 | -+ | |||
| 388 | +3x |
- N_x, # nolint+ extra_args <- list(.stats = .stats, na.rm = na.rm, na_str = na_str, compare = TRUE, ...) |
||
| 215 | -+ | |||
| 389 | +1x |
- N_y, # nolint+ if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
||
| 216 | -+ | |||
| 390 | +1x |
- list_names = NULL,+ if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
||
| 217 | -+ | |||
| 391 | +! |
- conf_level = 0.95,+ if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
||
| 218 | +392 |
- pct = TRUE) {
+
|
||
| 219 | -11x | +393 | +3x |
- checkmate::assert_list(x, types = "numeric")+ analyze( |
| 220 | -11x | +394 | +3x |
- checkmate::assert_list(y, types = "numeric", len = length(x))+ lyt = lyt, |
| 221 | -11x | +395 | +3x |
- checkmate::assert_character(list_names, len = length(x), null.ok = TRUE)+ vars = vars, |
| 222 | -11x | +396 | +3x |
- rd_list <- lapply(seq_along(x), function(i) {
+ var_labels = var_labels, |
| 223 | -25x | +397 | +3x |
- p_x <- x[[i]] / N_x+ afun = a_summary, |
| 224 | -25x | +398 | +3x |
- p_y <- y[[i]] / N_y+ na_str = na_str, |
| 225 | -25x | +399 | +3x |
- rd_ci <- p_x - p_y + c(-1, 1) * stats::qnorm((1 + conf_level) / 2) *+ nested = nested, |
| 226 | -25x | +400 | +3x |
- sqrt(p_x * (1 - p_x) / N_x + p_y * (1 - p_y) / N_y)+ extra_args = extra_args, |
| 227 | -25x | +401 | +3x |
- c(p_x - p_y, rd_ci) * ifelse(pct, 100, 1)+ inclNAs = TRUE, |
| 228 | -+ | |||
| 402 | +3x |
- })+ show_labels = show_labels, |
||
| 229 | -11x | +403 | +3x |
- names(rd_list) <- list_names+ table_names = table_names, |
| 230 | -11x | +404 | +3x |
- rd_list+ section_div = section_div |
| 231 | +405 | ++ |
+ )+ |
+ |
| 406 |
}@@ -129810,14 +129240,14 @@ tern coverage - 94.83% |
| 1 |
- #' Helper Functions for Tabulating Binary Response by Subgroup+ #' Count Patients with Marked Laboratory Abnormalities |
||
| 5 |
- #' Helper functions that tabulate in a data frame statistics such as response rate+ #' Primary analysis variable `.var` indicates whether single, replicated or last marked laboratory |
||
| 6 |
- #' and odds ratio for population subgroups.+ #' abnormality was observed (`factor`). Additional analysis variables are `id` (`character` or `factor`) |
||
| 7 |
- #'+ #' and `direction` (`factor`) indicating the direction of the abnormality. Denominator is number of |
||
| 8 |
- #' @inheritParams argument_convention+ #' patients with at least one valid measurement during the analysis. |
||
| 9 |
- #' @inheritParams response_subgroups+ #' * For `Single, not last` and `Last or replicated`: Numerator is number of patients |
||
| 10 |
- #' @param arm (`factor`)\cr the treatment group variable.+ #' with `Single, not last` and `Last or replicated` levels, respectively. |
||
| 11 |
- #'+ #' * For `Any`: Numerator is the number of patients with either single or |
||
| 12 |
- #' @details Main functionality is to prepare data for use in a layout-creating function.+ #' replicated marked abnormalities. |
||
| 14 |
- #' @examples+ #' @inheritParams argument_convention |
||
| 15 |
- #' library(dplyr)+ #' @param category (`list`)\cr with different marked category names for single |
||
| 16 |
- #' library(forcats)+ #' and last or replicated. |
||
| 18 |
- #' adrs <- tern_ex_adrs+ #' @note `Single, not last` and `Last or replicated` levels are mutually exclusive. If a patient has |
||
| 19 |
- #' adrs_labels <- formatters::var_labels(adrs)+ #' abnormalities that meet both the `Single, not last` and `Last or replicated` criteria, then the |
||
| 20 |
- #'+ #' patient will be counted only under the `Last or replicated` category. |
||
| 21 |
- #' adrs_f <- adrs %>%+ #' |
||
| 22 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' @name abnormal_by_marked |
||
| 23 |
- #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+ NULL |
||
| 24 |
- #' droplevels() %>%+ |
||
| 25 |
- #' mutate(+ #' @describeIn abnormal_by_marked Statistics function for patients with marked lab abnormalities. |
||
| 26 |
- #' # Reorder levels of factor to make the placebo group the reference arm.+ #' |
||
| 27 |
- #' ARM = fct_relevel(ARM, "B: Placebo"),+ #' @return |
||
| 28 |
- #' rsp = AVALC == "CR"+ #' * `s_count_abnormal_by_marked()` returns statistic `count_fraction` with `Single, not last`, |
||
| 29 |
- #' )+ #' `Last or replicated`, and `Any` results. |
||
| 30 |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ #' |
||
| 31 |
- #'+ #' @examples |
||
| 32 |
- #' @name h_response_subgroups+ #' library(dplyr) |
||
| 33 |
- NULL+ #' |
||
| 34 |
-
+ #' df <- data.frame( |
||
| 35 |
- #' @describeIn h_response_subgroups helper to prepare a data frame of binary responses by arm.+ #' USUBJID = as.character(c(rep(1, 5), rep(2, 5), rep(1, 5), rep(2, 5))), |
||
| 36 |
- #'+ #' ARMCD = factor(c(rep("ARM A", 5), rep("ARM B", 5), rep("ARM A", 5), rep("ARM B", 5))),
|
||
| 37 |
- #' @return+ #' ANRIND = factor(c( |
||
| 38 |
- #' * `h_proportion_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, and `prop`.+ #' "NORMAL", "HIGH", "HIGH", "HIGH HIGH", "HIGH", |
||
| 39 |
- #'+ #' "HIGH", "HIGH", "HIGH HIGH", "NORMAL", "HIGH HIGH", "NORMAL", "LOW", "LOW", "LOW LOW", "LOW", |
||
| 40 |
- #' @examples+ #' "LOW", "LOW", "LOW LOW", "NORMAL", "LOW LOW" |
||
| 41 |
- #' h_proportion_df(+ #' )), |
||
| 42 |
- #' c(TRUE, FALSE, FALSE),+ #' ONTRTFL = rep(c("", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y"), 2),
|
||
| 43 |
- #' arm = factor(c("A", "A", "B"), levels = c("A", "B"))
+ #' PARAMCD = factor(c(rep("CRP", 10), rep("ALT", 10))),
|
||
| 44 |
- #' )+ #' AVALCAT1 = factor(rep(c("", "", "", "SINGLE", "REPLICATED", "", "", "LAST", "", "SINGLE"), 2)),
|
||
| 45 |
- #'+ #' stringsAsFactors = FALSE |
||
| 46 |
- #' @export+ #' ) |
||
| 47 |
- h_proportion_df <- function(rsp, arm) {
+ #' |
||
| 48 | -59x | +
- checkmate::assert_logical(rsp)+ #' df <- df %>% |
|
| 49 | -58x | +
- assert_valid_factor(arm, len = length(rsp))+ #' mutate(abn_dir = factor( |
|
| 50 | -58x | +
- non_missing_rsp <- !is.na(rsp)+ #' case_when( |
|
| 51 | -58x | +
- rsp <- rsp[non_missing_rsp]+ #' ANRIND == "LOW LOW" ~ "Low", |
|
| 52 | -58x | +
- arm <- arm[non_missing_rsp]+ #' ANRIND == "HIGH HIGH" ~ "High", |
|
| 53 |
-
+ #' TRUE ~ "" |
||
| 54 | -58x | +
- lst_rsp <- split(rsp, arm)+ #' ), |
|
| 55 | -58x | +
- lst_results <- Map(function(x, arm) {
+ #' levels = c("Low", "High")
|
|
| 56 | -116x | +
- if (length(x) > 0) {
+ #' )) |
|
| 57 | -114x | +
- s_prop <- s_proportion(df = x)+ #' |
|
| 58 | -114x | +
- data.frame(+ #' # Select only post-baseline records. |
|
| 59 | -114x | +
- arm = arm,+ #' df <- df %>% filter(ONTRTFL == "Y") |
|
| 60 | -114x | +
- n = length(x),+ #' df_crp <- df %>% |
|
| 61 | -114x | +
- n_rsp = unname(s_prop$n_prop[1]),+ #' filter(PARAMCD == "CRP") %>% |
|
| 62 | -114x | +
- prop = unname(s_prop$n_prop[2]),+ #' droplevels() |
|
| 63 | -114x | +
- stringsAsFactors = FALSE+ #' full_parent_df <- list(df_crp, "not_needed") |
|
| 64 |
- )+ #' cur_col_subset <- list(rep(TRUE, nrow(df_crp)), "not_needed") |
||
| 65 |
- } else {
+ #' spl_context <- data.frame( |
||
| 66 | -2x | +
- data.frame(+ #' split = c("PARAMCD", "GRADE_DIR"),
|
|
| 67 | -2x | +
- arm = arm,+ #' full_parent_df = I(full_parent_df), |
|
| 68 | -2x | +
- n = 0L,+ #' cur_col_subset = I(cur_col_subset) |
|
| 69 | -2x | +
- n_rsp = NA,+ #' ) |
|
| 70 | -2x | +
- prop = NA,+ #' |
|
| 71 | -2x | +
- stringsAsFactors = FALSE+ #' @keywords internal |
|
| 72 |
- )+ s_count_abnormal_by_marked <- function(df, |
||
| 73 |
- }+ .var = "AVALCAT1", |
||
| 74 | -58x | +
- }, lst_rsp, names(lst_rsp))+ .spl_context, |
|
| 75 |
-
+ category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
|
||
| 76 | -58x | +
- df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE))+ variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir")) {
|
|
| 77 | -58x | +3x |
- df$arm <- factor(df$arm, levels = levels(arm))+ checkmate::assert_string(.var) |
| 78 | -58x | +3x |
- df+ checkmate::assert_list(variables) |
| 79 | -+ | 3x |
- }+ checkmate::assert_list(category) |
| 80 | -+ | 3x |
-
+ checkmate::assert_subset(names(category), c("single", "last_replicated"))
|
| 81 | -+ | 3x |
- #' @describeIn h_response_subgroups summarizes proportion of binary responses by arm and across subgroups+ checkmate::assert_subset(names(variables), c("id", "param", "direction"))
|
| 82 | -+ | 3x |
- #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and+ checkmate::assert_vector(unique(df[[variables$direction]]), max.len = 1) |
| 83 |
- #' requires elements `rsp`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies+ |
||
| 84 | -+ | 2x |
- #' groupings for `subgroups` variables.+ assert_df_with_variables(df, c(aval = .var, variables)) |
| 85 | -+ | 2x |
- #'+ checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
|
| 86 | -+ | 2x |
- #' @return+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
| 87 |
- #' * `h_proportion_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`,+ |
||
| 88 |
- #' `var`, `var_label`, and `row_type`.+ |
||
| 89 | -+ | 2x |
- #'+ first_row <- .spl_context[.spl_context$split == variables[["param"]], ] |
| 90 |
- #' @examples+ # Patients in the denominator have at least one post-baseline visit. |
||
| 91 | -+ | 2x |
- #' h_proportion_subgroups_df(+ subj <- first_row$full_parent_df[[1]][[variables[["id"]]]] |
| 92 | -+ | 2x |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ subj_cur_col <- subj[first_row$cur_col_subset[[1]]] |
| 93 |
- #' data = adrs_f+ # Some subjects may have a record for high and low directions but |
||
| 94 |
- #' )+ # should be counted only once. |
||
| 95 | -+ | 2x |
- #'+ denom <- length(unique(subj_cur_col)) |
| 96 |
- #' # Define groupings for BMRKR2 levels.+ |
||
| 97 | -+ | 2x |
- #' h_proportion_subgroups_df(+ if (denom != 0) {
|
| 98 | -+ | 2x |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ subjects_last_replicated <- unique( |
| 99 | -+ | 2x |
- #' data = adrs_f,+ df[df[[.var]] %in% category[["last_replicated"]], variables$id, drop = TRUE] |
| 100 |
- #' groups_lists = list(+ ) |
||
| 101 | -+ | 2x |
- #' BMRKR2 = list(+ subjects_single <- unique( |
| 102 | -+ | 2x |
- #' "low" = "LOW",+ df[df[[.var]] %in% category[["single"]], variables$id, drop = TRUE] |
| 103 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ ) |
||
| 104 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ # Subjects who have both single and last/replicated abnormalities are counted in only the last/replicated group. |
||
| 105 | -+ | 2x |
- #' )+ subjects_single <- setdiff(subjects_single, subjects_last_replicated) |
| 106 | -+ | 2x |
- #' )+ n_single <- length(subjects_single) |
| 107 | -+ | 2x |
- #' )+ n_last_replicated <- length(subjects_last_replicated) |
| 108 | -+ | 2x |
- #'+ n_any <- n_single + n_last_replicated |
| 109 | -+ | 2x |
- #' @export+ result <- list(count_fraction = list( |
| 110 | -+ | 2x |
- h_proportion_subgroups_df <- function(variables,+ "Single, not last" = c(n_single, n_single / denom), |
| 111 | -+ | 2x |
- data,+ "Last or replicated" = c(n_last_replicated, n_last_replicated / denom), |
| 112 | -+ | 2x |
- groups_lists = list(),+ "Any Abnormality" = c(n_any, n_any / denom) |
| 113 |
- label_all = "All Patients") {
+ )) |
||
| 114 | -13x | +
- checkmate::assert_character(variables$rsp)+ } else {
|
|
| 115 | -13x | +! |
- checkmate::assert_character(variables$arm)+ result <- list(count_fraction = list( |
| 116 | -13x | +! |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ "Single, not last" = c(0, 0), |
| 117 | -13x | +! |
- assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ "Last or replicated" = c(0, 0), |
| 118 | -13x | +! |
- assert_df_with_variables(data, variables)+ "Any Abnormality" = c(0, 0) |
| 119 | -13x | +
- checkmate::assert_string(label_all)+ )) |
|
| 120 |
-
+ } |
||
| 121 |
- # Add All Patients.+ |
||
| 122 | -13x | +2x |
- result_all <- h_proportion_df(data[[variables$rsp]], data[[variables$arm]])+ result |
| 123 | -13x | +
- result_all$subgroup <- label_all+ } |
|
| 124 | -13x | +
- result_all$var <- "ALL"+ |
|
| 125 | -13x | +
- result_all$var_label <- label_all+ #' @describeIn abnormal_by_marked Formatted analysis function which is used as `afun` |
|
| 126 | -13x | +
- result_all$row_type <- "content"+ #' in `count_abnormal_by_marked()`. |
|
| 127 |
-
+ #' |
||
| 128 |
- # Add Subgroups.+ #' @return |
||
| 129 | -13x | +
- if (is.null(variables$subgroups)) {
+ #' * `a_count_abnormal_by_marked()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 130 | -3x | +
- result_all+ #' |
|
| 131 |
- } else {
+ #' |
||
| 132 | -10x | +
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ #' @keywords internal |
|
| 133 |
-
+ a_count_abnormal_by_marked <- make_afun( |
||
| 134 | -10x | +
- l_result <- lapply(l_data, function(grp) {
+ s_count_abnormal_by_marked, |
|
| 135 | -42x | +
- result <- h_proportion_df(grp$df[[variables$rsp]], grp$df[[variables$arm]])+ .formats = c(count_fraction = format_count_fraction) |
|
| 136 | -42x | +
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ ) |
|
| 137 | -42x | +
- cbind(result, result_labels)+ |
|
| 138 |
- })+ #' @describeIn abnormal_by_marked Layout-creating function which can take statistics function arguments |
||
| 139 | -10x | +
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
| 140 | -10x | +
- result_subgroups$row_type <- "analysis"+ #' |
|
| 141 |
-
+ #' @return |
||
| 142 | -10x | +
- rbind(+ #' * `count_abnormal_by_marked()` returns a layout object suitable for passing to further layouting functions, |
|
| 143 | -10x | +
- result_all,+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
| 144 | -10x | +
- result_subgroups+ #' the statistics from `s_count_abnormal_by_marked()` to the table layout. |
|
| 145 |
- )+ #' |
||
| 146 |
- }+ #' @examples |
||
| 147 |
- }+ #' map <- unique( |
||
| 148 |
-
+ #' df[df$abn_dir %in% c("Low", "High") & df$AVALCAT1 != "", c("PARAMCD", "abn_dir")]
|
||
| 149 |
- #' @describeIn h_response_subgroups helper to prepare a data frame with estimates of+ #' ) %>% |
||
| 150 |
- #' the odds ratio between a treatment and a control arm.+ #' lapply(as.character) %>% |
||
| 151 |
- #'+ #' as.data.frame() %>% |
||
| 152 |
- #' @inheritParams response_subgroups+ #' arrange(PARAMCD, abn_dir) |
||
| 153 |
- #' @param strata_data (`factor`, `data.frame` or `NULL`)\cr required if stratified analysis is performed.+ #' |
||
| 154 |
- #'+ #' basic_table() %>% |
||
| 155 |
- #' @return+ #' split_cols_by("ARMCD") %>%
|
||
| 156 |
- #' * `h_odds_ratio_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`, and+ #' split_rows_by("PARAMCD") %>%
|
||
| 157 |
- #' optionally `pval` and `pval_label`.+ #' summarize_num_patients( |
||
| 158 |
- #'+ #' var = "USUBJID", |
||
| 159 |
- #' @examples+ #' .stats = "unique_count" |
||
| 160 |
- #' # Unstratatified analysis.+ #' ) %>% |
||
| 161 |
- #' h_odds_ratio_df(+ #' split_rows_by( |
||
| 162 |
- #' c(TRUE, FALSE, FALSE, TRUE),+ #' "abn_dir", |
||
| 163 |
- #' arm = factor(c("A", "A", "B", "B"), levels = c("A", "B"))
+ #' split_fun = trim_levels_to_map(map) |
||
| 164 |
- #' )+ #' ) %>% |
||
| 165 |
- #'+ #' count_abnormal_by_marked( |
||
| 166 |
- #' # Include p-value.+ #' var = "AVALCAT1", |
||
| 167 |
- #' h_odds_ratio_df(adrs_f$rsp, adrs_f$ARM, method = "chisq")+ #' variables = list( |
||
| 168 |
- #'+ #' id = "USUBJID", |
||
| 169 |
- #' # Stratatified analysis.+ #' param = "PARAMCD", |
||
| 170 |
- #' h_odds_ratio_df(+ #' direction = "abn_dir" |
||
| 171 |
- #' rsp = adrs_f$rsp,+ #' ) |
||
| 172 |
- #' arm = adrs_f$ARM,+ #' ) %>% |
||
| 173 |
- #' strata_data = adrs_f[, c("STRATA1", "STRATA2")],
+ #' build_table(df = df) |
||
| 174 |
- #' method = "cmh"+ #' |
||
| 175 |
- #' )+ #' basic_table() %>% |
||
| 176 |
- #'+ #' split_cols_by("ARMCD") %>%
|
||
| 177 |
- #' @export+ #' split_rows_by("PARAMCD") %>%
|
||
| 178 |
- h_odds_ratio_df <- function(rsp, arm, strata_data = NULL, conf_level = 0.95, method = NULL) {
+ #' summarize_num_patients( |
||
| 179 | -64x | +
- assert_valid_factor(arm, n.levels = 2, len = length(rsp))+ #' var = "USUBJID", |
|
| 180 |
-
+ #' .stats = "unique_count" |
||
| 181 | -64x | +
- df_rsp <- data.frame(+ #' ) %>% |
|
| 182 | -64x | +
- rsp = rsp,+ #' split_rows_by( |
|
| 183 | -64x | +
- arm = arm+ #' "abn_dir", |
|
| 184 |
- )+ #' split_fun = trim_levels_in_group("abn_dir")
|
||
| 185 |
-
+ #' ) %>% |
||
| 186 | -64x | +
- if (!is.null(strata_data)) {
+ #' count_abnormal_by_marked( |
|
| 187 | -11x | +
- strata_var <- interaction(strata_data, drop = TRUE)+ #' var = "AVALCAT1", |
|
| 188 | -11x | +
- strata_name <- "strata"+ #' variables = list( |
|
| 189 |
-
+ #' id = "USUBJID", |
||
| 190 | -11x | +
- assert_valid_factor(strata_var, len = nrow(df_rsp))+ #' param = "PARAMCD", |
|
| 191 |
-
+ #' direction = "abn_dir" |
||
| 192 | -11x | +
- df_rsp[[strata_name]] <- strata_var+ #' ) |
|
| 193 |
- } else {
+ #' ) %>% |
||
| 194 | -53x | +
- strata_name <- NULL+ #' build_table(df = df) |
|
| 195 |
- }+ #' |
||
| 196 |
-
+ #' @export |
||
| 197 | -64x | +
- l_df <- split(df_rsp, arm)+ count_abnormal_by_marked <- function(lyt, |
|
| 198 |
-
+ var, |
||
| 199 | -64x | +
- if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
+ na_str = NA_character_, |
|
| 200 |
- # Odds ratio and CI.+ nested = TRUE, |
||
| 201 | -62x | +
- result_odds_ratio <- s_odds_ratio(+ ..., |
|
| 202 | -62x | +
- df = l_df[[2]],+ .stats = NULL, |
|
| 203 | -62x | +
- .var = "rsp",+ .formats = NULL, |
|
| 204 | -62x | +
- .ref_group = l_df[[1]],+ .labels = NULL, |
|
| 205 | -62x | +
- .in_ref_col = FALSE,+ .indent_mods = NULL) {
|
|
| 206 | -62x | +1x |
- .df_row = df_rsp,+ checkmate::assert_string(var) |
| 207 | -62x | +
- variables = list(arm = "arm", strata = strata_name),+ |
|
| 208 | -62x | +1x |
- conf_level = conf_level+ afun <- make_afun( |
| 209 | -+ | 1x |
- )+ a_count_abnormal_by_marked, |
| 210 | -+ | 1x |
-
+ .stats = .stats, |
| 211 | -62x | +1x |
- df <- data.frame(+ .formats = .formats, |
| 212 | -+ | 1x |
- # Dummy column needed downstream to create a nested header.+ .labels = .labels, |
| 213 | -62x | +1x |
- arm = " ",+ .indent_mods = .indent_mods, |
| 214 | -62x | +1x |
- n_tot = unname(result_odds_ratio$n_tot["n_tot"]),+ .ungroup_stats = "count_fraction" |
| 215 | -62x | +
- or = unname(result_odds_ratio$or_ci["est"]),+ ) |
|
| 216 | -62x | +
- lcl = unname(result_odds_ratio$or_ci["lcl"]),+ |
|
| 217 | -62x | +1x |
- ucl = unname(result_odds_ratio$or_ci["ucl"]),+ lyt <- analyze( |
| 218 | -62x | +1x |
- conf_level = conf_level,+ lyt = lyt, |
| 219 | -62x | +1x |
- stringsAsFactors = FALSE+ vars = var, |
| 220 | -+ | 1x |
- )+ afun = afun, |
| 221 | -+ | 1x |
-
+ na_str = na_str, |
| 222 | -62x | +1x |
- if (!is.null(method)) {
+ nested = nested, |
| 223 | -+ | 1x |
- # Test for difference.+ show_labels = "hidden", |
| 224 | -29x | +1x |
- result_test <- s_test_proportion_diff(+ extra_args = c(list(...)) |
| 225 | -29x | +
- df = l_df[[2]],+ ) |
|
| 226 | -29x | +1x |
- .var = "rsp",+ lyt |
| 227 | -29x | +
- .ref_group = l_df[[1]],+ } |
|
| 228 | -29x | +
| 1 | +
- .in_ref_col = FALSE,+ #' Patient Counts with the Most Extreme Post-baseline Toxicity Grade per Direction of Abnormality |
|||
| 229 | -29x | +|||
| 2 | +
- variables = list(strata = strata_name),+ #' |
|||
| 230 | -29x | +|||
| 3 | +
- method = method+ #' @description `r lifecycle::badge("stable")`
|
|||
| 231 | +4 |
- )+ #' |
||
| 232 | +5 |
-
+ #' Primary analysis variable `.var` indicates the toxicity grade (`factor`), and additional |
||
| 233 | -29x | +|||
| 6 | +
- df$pval <- as.numeric(result_test$pval)+ #' analysis variables are `id` (`character` or `factor`), `param` (`factor`) and `grade_dir` (`factor`). |
|||
| 234 | -29x | +|||
| 7 | +
- df$pval_label <- obj_label(result_test$pval)+ #' The pre-processing steps are crucial when using this function. |
|||
| 235 | +8 |
- }+ #' For a certain direction (e.g. high or low) this function counts |
||
| 236 | +9 |
-
+ #' patients in the denominator as number of patients with at least one valid measurement during treatment, |
||
| 237 | +10 |
- # In those cases cannot go through the model so will obtain n_tot from data.+ #' and patients in the numerator as follows: |
||
| 238 | +11 |
- } else if (+ #' * `1` to `4`: Numerator is number of patients with worst grades 1-4 respectively; |
||
| 239 | -2x | +|||
| 12 | +
- (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) ||+ #' * `Any`: Numerator is number of patients with at least one abnormality, which means grade is different from 0. |
|||
| 240 | -2x | +|||
| 13 | +
- (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0)+ #' |
|||
| 241 | +14 |
- ) {
+ #' @inheritParams argument_convention |
||
| 242 | -2x | +|||
| 15 | +
- df <- data.frame(+ #' |
|||
| 243 | +16 |
- # Dummy column needed downstream to create a nested header.+ #' @details The pre-processing steps are crucial when using this function. From the standard lab grade variable |
||
| 244 | -2x | +|||
| 17 | +
- arm = " ",+ #' `ATOXGR`, derive the following two variables: |
|||
| 245 | -2x | +|||
| 18 | +
- n_tot = sum(stats::complete.cases(df_rsp)),+ #' * A grade direction variable (e.g. `GRADE_DIR`) is required in order to obtain |
|||
| 246 | -2x | +|||
| 19 | +
- or = NA,+ #' the correct denominators when building the layout as it is used to define row splitting. |
|||
| 247 | -2x | +|||
| 20 | +
- lcl = NA,+ #' * A toxicity grade variable (e.g. `GRADE_ANL`) where all negative values from |
|||
| 248 | -2x | +|||
| 21 | +
- ucl = NA,+ #' `ATOXGR` are replaced by their absolute values. |
|||
| 249 | -2x | +|||
| 22 | +
- conf_level = conf_level,+ #' |
|||
| 250 | -2x | +|||
| 23 | +
- stringsAsFactors = FALSE+ #' @note Prior to tabulation, `df` must be filtered to include only post-baseline records with worst grade flags. |
|||
| 251 | +24 |
- )+ #' |
||
| 252 | -2x | +|||
| 25 | +
- if (!is.null(method)) {
+ #' @name abnormal_by_worst_grade |
|||
| 253 | -2x | +|||
| 26 | +
- df$pval <- NA+ NULL |
|||
| 254 | -2x | +|||
| 27 | +
- df$pval_label <- NA+ |
|||
| 255 | +28 |
- }+ #' @describeIn abnormal_by_worst_grade Statistics function which counts patients by worst grade. |
||
| 256 | +29 |
- } else {
+ #' |
||
| 257 | -! | +|||
| 30 | +
- df <- data.frame(+ #' @return |
|||
| 258 | +31 |
- # Dummy column needed downstream to create a nested header.+ #' * `s_count_abnormal_by_worst_grade()` returns the single statistic `count_fraction` with grades 1 to 4 and |
||
| 259 | -! | +|||
| 32 | +
- arm = " ",+ #' "Any" results. |
|||
| 260 | -! | +|||
| 33 | +
- n_tot = 0L,+ #' |
|||
| 261 | -! | +|||
| 34 | +
- or = NA,+ #' @examples |
|||
| 262 | -! | +|||
| 35 | +
- lcl = NA,+ #' library(dplyr) |
|||
| 263 | -! | +|||
| 36 | +
- ucl = NA,+ #' library(forcats) |
|||
| 264 | -! | +|||
| 37 | +
- conf_level = conf_level,+ #' adlb <- tern_ex_adlb |
|||
| 265 | -! | +|||
| 38 | +
- stringsAsFactors = FALSE+ #' |
|||
| 266 | +39 |
- )+ #' # Data is modified in order to have some parameters with grades only in one direction |
||
| 267 | +40 |
-
+ #' # and simulate the real data. |
||
| 268 | -! | +|||
| 41 | +
- if (!is.null(method)) {
+ #' adlb$ATOXGR[adlb$PARAMCD == "ALT" & adlb$ATOXGR %in% c("1", "2", "3", "4")] <- "-1"
|
|||
| 269 | -! | +|||
| 42 | +
- df$pval <- NA+ #' adlb$ANRIND[adlb$PARAMCD == "ALT" & adlb$ANRIND == "HIGH"] <- "LOW" |
|||
| 270 | -! | +|||
| 43 | +
- df$pval_label <- NA+ #' adlb$WGRHIFL[adlb$PARAMCD == "ALT"] <- "" |
|||
| 271 | +44 |
- }+ #' |
||
| 272 | +45 |
- }+ #' adlb$ATOXGR[adlb$PARAMCD == "IGA" & adlb$ATOXGR %in% c("-1", "-2", "-3", "-4")] <- "1"
|
||
| 273 | +46 |
-
+ #' adlb$ANRIND[adlb$PARAMCD == "IGA" & adlb$ANRIND == "LOW"] <- "HIGH" |
||
| 274 | -64x | +|||
| 47 | +
- df+ #' adlb$WGRLOFL[adlb$PARAMCD == "IGA"] <- "" |
|||
| 275 | +48 |
- }+ #' |
||
| 276 | +49 |
-
+ #' # Here starts the real pre-processing. |
||
| 277 | +50 |
- #' @describeIn h_response_subgroups summarizes estimates of the odds ratio between a treatment and a control+ #' adlb_f <- adlb %>% |
||
| 278 | +51 |
- #' arm across subgroups in a data frame. `variables` corresponds to the names of variables found in+ #' filter(!AVISIT %in% c("SCREENING", "BASELINE")) %>%
|
||
| 279 | +52 |
- #' `data`, passed as a named list and requires elements `rsp`, `arm` and optionally `subgroups`+ #' mutate( |
||
| 280 | +53 |
- #' and `strat`. `groups_lists` optionally specifies groupings for `subgroups` variables.+ #' GRADE_DIR = factor( |
||
| 281 | +54 | ++ |
+ #' case_when(+ |
+ |
| 55 | ++ |
+ #' ATOXGR %in% c("-1", "-2", "-3", "-4") ~ "LOW",
+ |
+ ||
| 56 | ++ |
+ #' ATOXGR == "0" ~ "ZERO",+ |
+ ||
| 57 | ++ |
+ #' ATOXGR %in% c("1", "2", "3", "4") ~ "HIGH"
+ |
+ ||
| 58 | ++ |
+ #' ),+ |
+ ||
| 59 | ++ |
+ #' levels = c("LOW", "ZERO", "HIGH")
+ |
+ ||
| 60 | ++ |
+ #' ),+ |
+ ||
| 61 | ++ |
+ #' GRADE_ANL = fct_relevel(+ |
+ ||
| 62 | ++ |
+ #' fct_recode(ATOXGR, `1` = "-1", `2` = "-2", `3` = "-3", `4` = "-4"),+ |
+ ||
| 63 | ++ |
+ #' c("0", "1", "2", "3", "4")
+ |
+ ||
| 64 | ++ |
+ #' )+ |
+ ||
| 65 | ++ |
+ #' ) %>%+ |
+ ||
| 66 | ++ |
+ #' filter(WGRLOFL == "Y" | WGRHIFL == "Y") %>%+ |
+ ||
| 67 | ++ |
+ #' droplevels()+ |
+ ||
| 68 |
#' |
|||
| 282 | +69 |
- #' @return+ #' adlb_f_alt <- adlb_f %>% |
||
| 283 | +70 |
- #' * `h_odds_ratio_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`,+ #' filter(PARAMCD == "ALT") %>% |
||
| 284 | +71 |
- #' `conf_level`, `subgroup`, `var`, `var_label`, and `row_type`.+ #' droplevels() |
||
| 285 | +72 | ++ |
+ #' full_parent_df <- list(adlb_f_alt, "not_needed")+ |
+ |
| 73 | ++ |
+ #' cur_col_subset <- list(rep(TRUE, nrow(adlb_f_alt)), "not_needed")+ |
+ ||
| 74 |
#' |
|||
| 286 | +75 |
- #' @examples+ #' # This mimics a split structure on PARAM and GRADE_DIR for a total column |
||
| 287 | +76 |
- #' # Unstratified analysis.+ #' spl_context <- data.frame( |
||
| 288 | +77 |
- #' h_odds_ratio_subgroups_df(+ #' split = c("PARAM", "GRADE_DIR"),
|
||
| 289 | +78 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ #' full_parent_df = I(full_parent_df), |
||
| 290 | +79 |
- #' data = adrs_f+ #' cur_col_subset = I(cur_col_subset) |
||
| 291 | +80 |
#' ) |
||
| 292 | +81 |
#' |
||
| 293 | +82 |
- #' # Stratified analysis.+ #' @keywords internal |
||
| 294 | +83 |
- #' h_odds_ratio_subgroups_df(+ s_count_abnormal_by_worst_grade <- function(df, # nolint |
||
| 295 | +84 |
- #' variables = list(+ .var = "GRADE_ANL", |
||
| 296 | +85 |
- #' rsp = "rsp",+ .spl_context, |
||
| 297 | +86 |
- #' arm = "ARM",+ variables = list( |
||
| 298 | +87 |
- #' subgroups = c("SEX", "BMRKR2"),
+ id = "USUBJID", |
||
| 299 | +88 |
- #' strat = c("STRATA1", "STRATA2")
+ param = "PARAM", |
||
| 300 | +89 |
- #' ),+ grade_dir = "GRADE_DIR" |
||
| 301 | +90 |
- #' data = adrs_f+ )) {
+ |
+ ||
| 91 | +1x | +
+ checkmate::assert_string(.var)+ |
+ ||
| 92 | +1x | +
+ assert_valid_factor(df[[.var]])+ |
+ ||
| 93 | +1x | +
+ assert_valid_factor(df[[variables$param]])+ |
+ ||
| 94 | +1x | +
+ assert_valid_factor(df[[variables$grade_dir]])+ |
+ ||
| 95 | +1x | +
+ assert_df_with_variables(df, c(a = .var, variables))+ |
+ ||
| 96 | +1x | +
+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
||
| 302 | +97 |
- #' )+ |
||
| 303 | +98 |
- #'+ # To verify that the `split_rows_by` are performed with correct variables.+ |
+ ||
| 99 | +1x | +
+ checkmate::assert_subset(c(variables[["param"]], variables[["grade_dir"]]), .spl_context$split)+ |
+ ||
| 100 | +1x | +
+ first_row <- .spl_context[.spl_context$split == variables[["param"]], ]+ |
+ ||
| 101 | +1x | +
+ x_lvls <- c(setdiff(levels(df[[.var]]), "0"), "Any")+ |
+ ||
| 102 | +1x | +
+ result <- split(numeric(0), factor(x_lvls)) |
||
| 304 | +103 |
- #' # Define groupings of BMRKR2 levels.+ + |
+ ||
| 104 | +1x | +
+ subj <- first_row$full_parent_df[[1]][[variables[["id"]]]]+ |
+ ||
| 105 | +1x | +
+ subj_cur_col <- subj[first_row$cur_col_subset[[1]]] |
||
| 305 | +106 |
- #' h_odds_ratio_subgroups_df(+ # Some subjects may have a record for high and low directions but |
||
| 306 | +107 |
- #' variables = list(+ # should be counted only once.+ |
+ ||
| 108 | +1x | +
+ denom <- length(unique(subj_cur_col)) |
||
| 307 | +109 |
- #' rsp = "rsp",+ + |
+ ||
| 110 | +1x | +
+ for (lvl in x_lvls) {
+ |
+ ||
| 111 | +5x | +
+ if (lvl != "Any") {
+ |
+ ||
| 112 | +4x | +
+ df_lvl <- df[df[[.var]] == lvl, ] |
||
| 308 | +113 |
- #' arm = "ARM",+ } else {
+ |
+ ||
| 114 | +1x | +
+ df_lvl <- df[df[[.var]] != 0, ]+ |
+ ||
| 115 | ++ |
+ }+ |
+ ||
| 116 | +5x | +
+ num <- length(unique(df_lvl[["USUBJID"]]))+ |
+ ||
| 117 | +5x | +
+ fraction <- ifelse(denom == 0, 0, num / denom)+ |
+ ||
| 118 | +5x | +
+ result[[lvl]] <- formatters::with_label(c(count = num, fraction = fraction), lvl) |
||
| 309 | +119 |
- #' subgroups = c("SEX", "BMRKR2")
+ } |
||
| 310 | +120 |
- #' ),+ |
||
| 311 | -+ | |||
| 121 | +1x |
- #' data = adrs_f,+ result <- list(count_fraction = result) |
||
| 312 | -+ | |||
| 122 | +1x |
- #' groups_lists = list(+ result |
||
| 313 | +123 |
- #' BMRKR2 = list(+ } |
||
| 314 | +124 |
- #' "low" = "LOW",+ |
||
| 315 | +125 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' @describeIn abnormal_by_worst_grade Formatted analysis function which is used as `afun` |
||
| 316 | +126 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ #' in `count_abnormal_by_worst_grade()`. |
||
| 317 | +127 |
- #' )+ #' |
||
| 318 | +128 |
- #' )+ #' @return |
||
| 319 | +129 |
- #' )+ #' * `a_count_abnormal_by_worst_grade()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 320 | +130 |
#' |
||
| 321 | +131 |
- #' @export+ #' |
||
| 322 | +132 |
- h_odds_ratio_subgroups_df <- function(variables,+ #' @keywords internal |
||
| 323 | +133 |
- data,+ a_count_abnormal_by_worst_grade <- make_afun( # nolint |
||
| 324 | +134 |
- groups_lists = list(),+ s_count_abnormal_by_worst_grade, |
||
| 325 | +135 |
- conf_level = 0.95,+ .formats = c(count_fraction = format_count_fraction) |
||
| 326 | +136 |
- method = NULL,+ ) |
||
| 327 | +137 |
- label_all = "All Patients") {
- |
- ||
| 328 | -14x | -
- checkmate::assert_character(variables$rsp)- |
- ||
| 329 | -14x | -
- checkmate::assert_character(variables$arm)- |
- ||
| 330 | -14x | -
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)- |
- ||
| 331 | -14x | -
- checkmate::assert_character(variables$strat, null.ok = TRUE)+ |
||
| 332 | -14x | +|||
| 138 | +
- assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ #' @describeIn abnormal_by_worst_grade Layout-creating function which can take statistics function arguments |
|||
| 333 | -14x | +|||
| 139 | +
- assert_df_with_variables(data, variables)+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 334 | -14x | +|||
| 140 | +
- checkmate::assert_string(label_all)+ #' |
|||
| 335 | +141 |
-
+ #' @return |
||
| 336 | -14x | +|||
| 142 | +
- strata_data <- if (is.null(variables$strat)) {
+ #' * `count_abnormal_by_worst_grade()` returns a layout object suitable for passing to further layouting functions, |
|||
| 337 | -12x | +|||
| 143 | +
- NULL+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 338 | +144 |
- } else {
+ #' the statistics from `s_count_abnormal_by_worst_grade()` to the table layout. |
||
| 339 | -2x | +|||
| 145 | +
- data[, variables$strat, drop = FALSE]+ #' |
|||
| 340 | +146 |
- }+ #' @examples |
||
| 341 | +147 |
-
+ #' # Map excludes records without abnormal grade since they should not be displayed |
||
| 342 | +148 |
- # Add All Patients.+ #' # in the table. |
||
| 343 | -14x | +|||
| 149 | +
- result_all <- h_odds_ratio_df(+ #' map <- unique(adlb_f[adlb_f$GRADE_DIR != "ZERO", c("PARAM", "GRADE_DIR", "GRADE_ANL")]) %>%
|
|||
| 344 | -14x | +|||
| 150 | +
- rsp = data[[variables$rsp]],+ #' lapply(as.character) %>% |
|||
| 345 | -14x | +|||
| 151 | +
- arm = data[[variables$arm]],+ #' as.data.frame() %>% |
|||
| 346 | -14x | +|||
| 152 | +
- strata_data = strata_data,+ #' arrange(PARAM, desc(GRADE_DIR), GRADE_ANL) |
|||
| 347 | -14x | +|||
| 153 | +
- conf_level = conf_level,+ #' |
|||
| 348 | -14x | +|||
| 154 | +
- method = method+ #' basic_table() %>% |
|||
| 349 | +155 |
- )+ #' split_cols_by("ARMCD") %>%
|
||
| 350 | -14x | +|||
| 156 | +
- result_all$subgroup <- label_all+ #' split_rows_by("PARAM") %>%
|
|||
| 351 | -14x | +|||
| 157 | +
- result_all$var <- "ALL"+ #' split_rows_by("GRADE_DIR", split_fun = trim_levels_to_map(map)) %>%
|
|||
| 352 | -14x | +|||
| 158 | +
- result_all$var_label <- label_all+ #' count_abnormal_by_worst_grade( |
|||
| 353 | -14x | +|||
| 159 | +
- result_all$row_type <- "content"+ #' var = "GRADE_ANL", |
|||
| 354 | +160 |
-
+ #' variables = list(id = "USUBJID", param = "PARAM", grade_dir = "GRADE_DIR") |
||
| 355 | -14x | +|||
| 161 | +
- if (is.null(variables$subgroups)) {
+ #' ) %>% |
|||
| 356 | -3x | +|||
| 162 | +
- result_all+ #' build_table(df = adlb_f) |
|||
| 357 | +163 |
- } else {
+ #' |
||
| 358 | -11x | +|||
| 164 | +
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ #' @export |
|||
| 359 | +165 |
-
+ count_abnormal_by_worst_grade <- function(lyt, |
||
| 360 | -11x | +|||
| 166 | +
- l_result <- lapply(l_data, function(grp) {
+ var, |
|||
| 361 | -46x | +|||
| 167 | +
- grp_strata_data <- if (is.null(variables$strat)) {
+ na_str = NA_character_, |
|||
| 362 | -38x | +|||
| 168 | +
- NULL+ nested = TRUE, |
|||
| 363 | +169 |
- } else {
+ ..., |
||
| 364 | -8x | +|||
| 170 | +
- grp$df[, variables$strat, drop = FALSE]+ .stats = NULL, |
|||
| 365 | +171 |
- }+ .formats = NULL, |
||
| 366 | +172 |
-
+ .labels = NULL, |
||
| 367 | -46x | +|||
| 173 | +
- result <- h_odds_ratio_df(+ .indent_mods = NULL) {
|
|||
| 368 | -46x | +174 | +2x |
- rsp = grp$df[[variables$rsp]],+ afun <- make_afun( |
| 369 | -46x | +175 | +2x |
- arm = grp$df[[variables$arm]],+ a_count_abnormal_by_worst_grade, |
| 370 | -46x | +176 | +2x |
- strata_data = grp_strata_data,+ .stats = .stats, |
| 371 | -46x | +177 | +2x |
- conf_level = conf_level,+ .formats = .formats, |
| 372 | -46x | -
- method = method- |
- ||
| 373 | -+ | 178 | +2x |
- )+ .labels = .labels, |
| 374 | -46x | +179 | +2x |
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ .indent_mods = .indent_mods, |
| 375 | -46x | +180 | +2x |
- cbind(result, result_labels)+ .ungroup_stats = "count_fraction" |
| 376 | +181 |
- })+ ) |
||
| 377 | -+ | |||
| 182 | +2x |
-
+ analyze( |
||
| 378 | -11x | +183 | +2x |
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ lyt = lyt, |
| 379 | -11x | +184 | +2x |
- result_subgroups$row_type <- "analysis"+ vars = var, |
| 380 | -+ | |||
| 185 | +2x |
-
+ afun = afun, |
||
| 381 | -11x | +186 | +2x |
- rbind(+ na_str = na_str, |
| 382 | -11x | +187 | +2x |
- result_all,+ nested = nested, |
| 383 | -11x | +188 | +2x |
- result_subgroups+ extra_args = list(...), |
| 384 | -+ | |||
| 189 | +2x |
- )+ show_labels = "hidden" |
||
| 385 | +190 |
- }+ ) |
||
| 386 | +191 |
}@@ -132518,14 +132178,14 @@ tern coverage - 94.83% |
| 1 |
- #' Proportion Difference+ #' Difference Test for Two Proportions |
||
| 5 |
- #' @inheritParams argument_convention+ #' Various tests were implemented to test the difference between two proportions. |
||
| 7 |
- #' @seealso [d_proportion_diff()]+ #' @inheritParams argument_convention |
||
| 9 |
- #' @name prop_diff+ #' @seealso [h_prop_diff_test] |
||
| 10 |
- NULL+ #' |
||
| 11 |
-
+ #' @name prop_diff_test |
||
| 12 |
- #' @describeIn prop_diff Statistics function estimating the difference+ NULL |
||
| 13 |
- #' in terms of responder proportion.+ |
||
| 14 |
- #'+ #' @describeIn prop_diff_test Statistics function which tests the difference between two proportions. |
||
| 15 |
- #' @inheritParams prop_diff_strat_nc+ #' |
||
| 16 |
- #' @param method (`string`)\cr the method used for the confidence interval estimation.+ #' @param method (`string`)\cr one of `chisq`, `cmh`, `fisher`, or `schouten`; specifies the test used |
||
| 17 |
- #'+ #' to calculate the p-value. |
||
| 18 |
- #' @return+ #' |
||
| 19 |
- #' * `s_proportion_diff()` returns a named list of elements `diff` and `diff_ci`.+ #' @return |
||
| 20 |
- #'+ #' * `s_test_proportion_diff()` returns a named `list` with a single item `pval` with an attribute `label` |
||
| 21 |
- #' @note When performing an unstratified analysis, methods `"cmh"`, `"strat_newcombe"`, and `"strat_newcombecc"` are+ #' describing the method used. The p-value tests the null hypothesis that proportions in two groups are the same. |
||
| 22 |
- #' not permitted.+ #' |
||
| 24 |
- #' @examples+ #' @keywords internal |
||
| 25 |
- #' # Summary+ s_test_proportion_diff <- function(df, |
||
| 26 |
- #'+ .var, |
||
| 27 |
- #' ## "Mid" case: 4/4 respond in group A, 1/2 respond in group B.+ .ref_group, |
||
| 28 |
- #' nex <- 100 # Number of example rows+ .in_ref_col, |
||
| 29 |
- #' dta <- data.frame(+ variables = list(strata = NULL), |
||
| 30 |
- #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE),+ method = c("chisq", "schouten", "fisher", "cmh")) {
|
||
| 31 | -+ | 30x |
- #' "grp" = sample(c("A", "B"), nex, TRUE),
+ method <- match.arg(method) |
| 32 | -+ | 30x |
- #' "f1" = sample(c("a1", "a2"), nex, TRUE),
+ y <- list(pval = "") |
| 33 |
- #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
+
|
||
| 34 | -+ | 30x |
- #' stringsAsFactors = TRUE+ if (!.in_ref_col) {
|
| 35 | -+ | 30x |
- #' )+ assert_df_with_variables(df, list(rsp = .var)) |
| 36 | -+ | 30x |
- #'+ assert_df_with_variables(.ref_group, list(rsp = .var)) |
| 37 | -+ | 30x |
- #' s_proportion_diff(+ rsp <- factor( |
| 38 | -+ | 30x |
- #' df = subset(dta, grp == "A"),+ c(.ref_group[[.var]], df[[.var]]), |
| 39 | -+ | 30x |
- #' .var = "rsp",+ levels = c("TRUE", "FALSE")
|
| 40 |
- #' .ref_group = subset(dta, grp == "B"),+ ) |
||
| 41 | -+ | 30x |
- #' .in_ref_col = FALSE,+ grp <- factor( |
| 42 | -+ | 30x |
- #' conf_level = 0.90,+ rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
|
| 43 | -+ | 30x |
- #' method = "ha"+ levels = c("ref", "Not-ref")
|
| 44 |
- #' )+ ) |
||
| 45 |
- #'+ |
||
| 46 | -+ | 30x |
- #' # CMH example with strata+ if (!is.null(variables$strata) || method == "cmh") {
|
| 47 | -+ | 12x |
- #' s_proportion_diff(+ strata <- variables$strata |
| 48 | -+ | 12x |
- #' df = subset(dta, grp == "A"),+ checkmate::assert_false(is.null(strata)) |
| 49 | -+ | 12x |
- #' .var = "rsp",+ strata_vars <- stats::setNames(as.list(strata), strata) |
| 50 | -+ | 12x |
- #' .ref_group = subset(dta, grp == "B"),+ assert_df_with_variables(df, strata_vars) |
| 51 | -+ | 12x |
- #' .in_ref_col = FALSE,+ assert_df_with_variables(.ref_group, strata_vars) |
| 52 | -+ | 12x |
- #' variables = list(strata = c("f1", "f2")),
+ strata <- c(interaction(.ref_group[strata]), interaction(df[strata])) |
| 53 |
- #' conf_level = 0.90,+ } |
||
| 54 |
- #' method = "cmh"+ |
||
| 55 | -+ | 30x |
- #' )+ tbl <- switch(method, |
| 56 | -+ | 30x |
- #'+ cmh = table(grp, rsp, strata), |
| 57 | -+ | 30x |
- #' @export+ table(grp, rsp) |
| 58 |
- s_proportion_diff <- function(df,+ ) |
||
| 59 |
- .var,+ |
||
| 60 | -+ | 30x |
- .ref_group,+ y$pval <- switch(method, |
| 61 | -+ | 30x |
- .in_ref_col,+ chisq = prop_chisq(tbl), |
| 62 | -+ | 30x |
- variables = list(strata = NULL),+ cmh = prop_cmh(tbl), |
| 63 | -+ | 30x |
- conf_level = 0.95,+ fisher = prop_fisher(tbl), |
| 64 | -+ | 30x |
- method = c(+ schouten = prop_schouten(tbl) |
| 65 |
- "waldcc", "wald", "cmh",+ ) |
||
| 66 |
- "ha", "newcombe", "newcombecc",+ } |
||
| 67 |
- "strat_newcombe", "strat_newcombecc"+ |
||
| 68 | -+ | 30x |
- ),+ y$pval <- formatters::with_label(y$pval, d_test_proportion_diff(method)) |
| 69 | -+ | 30x |
- weights_method = "cmh") {
+ y |
| 70 | -2x | +
- method <- match.arg(method)+ } |
|
| 71 | -2x | +
- if (is.null(variables$strata) && checkmate::test_subset(method, c("cmh", "strat_newcombe", "strat_newcombecc"))) {
+
|
|
| 72 | -! | +
- stop(paste(+ #' Description of the Difference Test Between Two Proportions |
|
| 73 | -! | +
- "When performing an unstratified analysis, methods 'cmh', 'strat_newcombe', and 'strat_newcombecc' are not",+ #' |
|
| 74 | -! | +
- "permitted. Please choose a different method."+ #' @description `r lifecycle::badge("stable")`
|
|
| 75 |
- ))+ #' |
||
| 76 |
- }+ #' This is an auxiliary function that describes the analysis in `s_test_proportion_diff`. |
||
| 77 | -2x | +
- y <- list(diff = "", diff_ci = "")+ #' |
|
| 78 |
-
+ #' @inheritParams s_test_proportion_diff |
||
| 79 | -2x | +
- if (!.in_ref_col) {
+ #' |
|
| 80 | -2x | +
- rsp <- c(.ref_group[[.var]], df[[.var]])+ #' @return `string` describing the test from which the p-value is derived. |
|
| 81 | -2x | +
- grp <- factor(+ #' |
|
| 82 | -2x | +
- rep(+ #' @export |
|
| 83 | -2x | +
- c("ref", "Not-ref"),
+ d_test_proportion_diff <- function(method) {
|
|
| 84 | -2x | +41x |
- c(nrow(.ref_group), nrow(df))+ checkmate::assert_string(method) |
| 85 | -+ | 41x |
- ),+ meth_part <- switch(method, |
| 86 | -2x | +41x |
- levels = c("ref", "Not-ref")
+ "schouten" = "Chi-Squared Test with Schouten Correction", |
| 87 | -+ | 41x |
- )+ "chisq" = "Chi-Squared Test", |
| 88 | -+ | 41x |
-
+ "cmh" = "Cochran-Mantel-Haenszel Test", |
| 89 | -2x | +41x |
- if (!is.null(variables$strata)) {
+ "fisher" = "Fisher's Exact Test", |
| 90 | -1x | +41x |
- strata_colnames <- variables$strata+ stop(paste(method, "does not have a description")) |
| 91 | -1x | +
- checkmate::assert_character(strata_colnames, null.ok = FALSE)+ ) |
|
| 92 | -1x | +41x |
- strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)+ paste0("p-value (", meth_part, ")")
|
| 93 |
-
+ } |
||
| 94 | -1x | +
- assert_df_with_variables(df, strata_vars)+ |
|
| 95 | -1x | +
- assert_df_with_variables(.ref_group, strata_vars)+ #' @describeIn prop_diff_test Formatted analysis function which is used as `afun` in `test_proportion_diff()`. |
|
| 96 |
-
+ #' |
||
| 97 |
- # Merging interaction strata for reference group rows data and remaining+ #' @return |
||
| 98 | -1x | +
- strata <- c(+ #' * `a_test_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 99 | -1x | +
- interaction(.ref_group[strata_colnames]),+ #' |
|
| 100 | -1x | +
- interaction(df[strata_colnames])+ #' |
|
| 101 |
- )+ #' @keywords internal |
||
| 102 | -1x | +
- strata <- as.factor(strata)+ a_test_proportion_diff <- make_afun( |
|
| 103 |
- }+ s_test_proportion_diff, |
||
| 104 |
-
+ .formats = c(pval = "x.xxxx | (<0.0001)"), |
||
| 105 |
- # Defining the std way to calculate weights for strat_newcombe+ .indent_mods = c(pval = 1L) |
||
| 106 | -2x | +
- if (!is.null(variables$weights_method)) {
+ ) |
|
| 107 | -! | +
- weights_method <- variables$weights_method+ |
|
| 108 |
- } else {
+ #' @describeIn prop_diff_test Layout-creating function which can take statistics function arguments |
||
| 109 | -2x | +
- weights_method <- "cmh"+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
| 110 |
- }+ #' |
||
| 111 |
-
+ #' @param ... other arguments are passed to [s_test_proportion_diff()]. |
||
| 112 | -2x | +
- y <- switch(method,+ #' |
|
| 113 | -2x | +
- "wald" = prop_diff_wald(rsp, grp, conf_level, correct = FALSE),+ #' @return |
|
| 114 | -2x | +
- "waldcc" = prop_diff_wald(rsp, grp, conf_level, correct = TRUE),+ #' * `test_proportion_diff()` returns a layout object suitable for passing to further layouting functions, |
|
| 115 | -2x | +
- "ha" = prop_diff_ha(rsp, grp, conf_level),+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
| 116 | -2x | +
- "newcombe" = prop_diff_nc(rsp, grp, conf_level, correct = FALSE),+ #' the statistics from `s_test_proportion_diff()` to the table layout. |
|
| 117 | -2x | +
- "newcombecc" = prop_diff_nc(rsp, grp, conf_level, correct = TRUE),+ #' |
|
| 118 | -2x | +
- "strat_newcombe" = prop_diff_strat_nc(rsp,+ #' @examples |
|
| 119 | -2x | +
- grp,+ #' dta <- data.frame( |
|
| 120 | -2x | +
- strata,+ #' rsp = sample(c(TRUE, FALSE), 100, TRUE), |
|
| 121 | -2x | +
- weights_method,+ #' grp = factor(rep(c("A", "B"), each = 50)),
|
|
| 122 | -2x | +
- conf_level,+ #' strat = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20))
|
|
| 123 | -2x | +
- correct = FALSE+ #' ) |
|
| 124 |
- ),+ #' |
||
| 125 | -2x | +
- "strat_newcombecc" = prop_diff_strat_nc(rsp,+ #' # With `rtables` pipelines. |
|
| 126 | -2x | +
- grp,+ #' l <- basic_table() %>% |
|
| 127 | -2x | +
- strata,+ #' split_cols_by(var = "grp", ref_group = "B") %>% |
|
| 128 | -2x | +
- weights_method,+ #' test_proportion_diff( |
|
| 129 | -2x | +
- conf_level,+ #' vars = "rsp", |
|
| 130 | -2x | +
- correct = TRUE+ #' method = "cmh", variables = list(strata = "strat") |
|
| 131 |
- ),+ #' ) |
||
| 132 | -2x | +
- "cmh" = prop_diff_cmh(rsp, grp, strata, conf_level)[c("diff", "diff_ci")]
+ #' |
|
| 133 |
- )+ #' build_table(l, df = dta) |
||
| 134 |
-
+ #' |
||
| 135 | -2x | +
- y$diff <- y$diff * 100+ #' @export |
|
| 136 | -2x | +
- y$diff_ci <- y$diff_ci * 100+ test_proportion_diff <- function(lyt, |
|
| 137 |
- }+ vars, |
||
| 138 |
-
+ na_str = NA_character_, |
||
| 139 | -2x | +
- attr(y$diff, "label") <- "Difference in Response rate (%)"+ nested = TRUE, |
|
| 140 | -2x | +
- attr(y$diff_ci, "label") <- d_proportion_diff(+ ..., |
|
| 141 | -2x | +
- conf_level, method,+ var_labels = vars, |
|
| 142 | -2x | +
- long = FALSE+ show_labels = "hidden", |
|
| 143 |
- )+ table_names = vars, |
||
| 144 |
-
+ .stats = NULL, |
||
| 145 | -2x | +
- y+ .formats = NULL, |
|
| 146 |
- }+ .labels = NULL, |
||
| 147 |
-
+ .indent_mods = NULL) {
|
||
| 148 | -+ | 5x |
- #' @describeIn prop_diff Formatted analysis function which is used as `afun` in `estimate_proportion_diff()`.+ afun <- make_afun( |
| 149 | -+ | 5x |
- #'+ a_test_proportion_diff, |
| 150 | -+ | 5x |
- #' @return+ .stats = .stats, |
| 151 | -+ | 5x |
- #' * `a_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()].+ .formats = .formats, |
| 152 | -+ | 5x |
- #'+ .labels = .labels, |
| 153 | -+ | 5x |
- #' @examples+ .indent_mods = .indent_mods |
| 154 |
- #' a_proportion_diff(+ ) |
||
| 155 | -+ | 5x |
- #' df = subset(dta, grp == "A"),+ analyze( |
| 156 | -+ | 5x |
- #' .var = "rsp",+ lyt, |
| 157 | -+ | 5x |
- #' .ref_group = subset(dta, grp == "B"),+ vars, |
| 158 | -+ | 5x |
- #' .in_ref_col = FALSE,+ afun = afun, |
| 159 | -+ | 5x |
- #' conf_level = 0.90,+ var_labels = var_labels, |
| 160 | -+ | 5x |
- #' method = "ha"+ na_str = na_str, |
| 161 | -+ | 5x |
- #' )+ nested = nested, |
| 162 | -+ | 5x |
- #'+ extra_args = list(...), |
| 163 | -+ | 5x |
- #' @export+ show_labels = show_labels, |
| 164 | -+ | 5x |
- a_proportion_diff <- make_afun(+ table_names = table_names |
| 165 |
- s_proportion_diff,+ ) |
||
| 166 |
- .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"),+ } |
||
| 167 |
- .indent_mods = c(diff = 0L, diff_ci = 1L)+ |
||
| 168 |
- )+ #' Helper Functions to Test Proportion Differences |
||
| 169 |
-
+ #' |
||
| 170 |
- #' @describeIn prop_diff Layout-creating function which can take statistics function arguments+ #' Helper functions to implement various tests on the difference between two proportions. |
||
| 171 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' |
||
| 172 |
- #'+ #' @param tbl (`matrix`)\cr matrix with two groups in rows and the binary response (`TRUE`/`FALSE`) in columns. |
||
| 173 |
- #' @param ... arguments passed to `s_proportion_diff()`.+ #' |
||
| 174 |
- #'+ #' @return A p-value. |
||
| 175 |
- #' @return+ #' |
||
| 176 |
- #' * `estimate_proportion_diff()` returns a layout object suitable for passing to further layouting functions,+ #' @seealso [prop_diff_test()] for implementation of these helper functions. |
||
| 177 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 178 |
- #' the statistics from `s_proportion_diff()` to the table layout.+ #' @name h_prop_diff_test |
||
| 179 |
- #'+ NULL |
||
| 180 |
- #' @examples+ |
||
| 181 |
- #' l <- basic_table() %>%+ #' @describeIn h_prop_diff_test performs Chi-Squared test. Internally calls [stats::prop.test()]. |
||
| 182 |
- #' split_cols_by(var = "grp", ref_group = "B") %>%+ #' |
||
| 183 |
- #' estimate_proportion_diff(+ #' |
||
| 184 |
- #' vars = "rsp",+ #' @keywords internal |
||
| 185 |
- #' conf_level = 0.90,+ prop_chisq <- function(tbl) {
|
||
| 186 | -+ | 23x |
- #' method = "ha"+ checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2) |
| 187 | -+ | 23x |
- #' )+ tbl <- tbl[, c("TRUE", "FALSE")]
|
| 188 | -+ | 23x |
- #'+ if (any(colSums(tbl) == 0)) {
|
| 189 | -+ | 2x |
- #' build_table(l, df = dta)+ return(1) |
| 190 |
- #'+ } |
||
| 191 | -+ | 21x |
- #' @export+ stats::prop.test(tbl, correct = FALSE)$p.value |
| 192 |
- estimate_proportion_diff <- function(lyt,+ } |
||
| 193 |
- vars,+ |
||
| 194 |
- nested = TRUE,+ #' @describeIn h_prop_diff_test performs stratified Cochran-Mantel-Haenszel test. Internally calls |
||
| 195 |
- ...,+ #' [stats::mantelhaen.test()]. Note that strata with less than two observations are automatically discarded. |
||
| 196 |
- var_labels = vars,+ #' |
||
| 197 |
- show_labels = "hidden",+ #' @param ary (`array`, 3 dimensions)\cr array with two groups in rows, the binary response |
||
| 198 |
- table_names = vars,+ #' (`TRUE`/`FALSE`) in columns, and the strata in the third dimension. |
||
| 199 |
- .stats = NULL,+ #' |
||
| 200 |
- .formats = NULL,+ #' |
||
| 201 |
- .labels = NULL,+ #' @keywords internal |
||
| 202 |
- .indent_mods = NULL) {
+ prop_cmh <- function(ary) {
|
||
| 203 | -3x | +16x |
- afun <- make_afun(+ checkmate::assert_array(ary) |
| 204 | -3x | +16x |
- a_proportion_diff,+ checkmate::assert_integer(c(ncol(ary), nrow(ary)), lower = 2, upper = 2) |
| 205 | -3x | +16x |
- .stats = .stats,+ checkmate::assert_integer(length(dim(ary)), lower = 3, upper = 3) |
| 206 | -3x | +16x |
- .formats = .formats,+ strata_sizes <- apply(ary, MARGIN = 3, sum) |
| 207 | -3x | +16x |
- .labels = .labels,+ if (any(strata_sizes < 5)) {
|
| 208 | -3x | +1x |
- .indent_mods = .indent_mods+ warning("<5 data points in some strata. CMH test may be incorrect.")
|
| 209 | -+ | 1x |
- )+ ary <- ary[, , strata_sizes > 1] |
| 210 |
-
+ } |
||
| 211 | -3x | +
- analyze(+ |
|
| 212 | -3x | +16x |
- lyt,+ stats::mantelhaen.test(ary, correct = FALSE)$p.value |
| 213 | -3x | +
- vars,+ } |
|
| 214 | -3x | +
- afun = afun,+ |
|
| 215 | -3x | +
- var_labels = var_labels,+ #' @describeIn h_prop_diff_test performs the Chi-Squared test with Schouten correction. |
|
| 216 | -3x | +
- nested = nested,+ #' |
|
| 217 | -3x | +
- extra_args = list(...),+ #' @seealso Schouten correction is based upon \insertCite{Schouten1980-kd;textual}{tern}.
|
|
| 218 | -3x | +
- show_labels = show_labels,+ #' |
|
| 219 | -3x | +
- table_names = table_names+ #' |
|
| 220 |
- )+ #' @keywords internal |
||
| 221 |
- }+ prop_schouten <- function(tbl) {
|
||
| 222 | -+ | 100x |
-
+ checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2) |
| 223 | -+ | 100x |
- #' Check: Proportion Difference Arguments+ tbl <- tbl[, c("TRUE", "FALSE")]
|
| 224 | -+ | 100x |
- #'+ if (any(colSums(tbl) == 0)) {
|
| 225 | -+ | 1x |
- #' Verifies that and/or convert arguments into valid values to be used in the+ return(1) |
| 226 |
- #' estimation of difference in responder proportions.+ } |
||
| 227 |
- #'+ |
||
| 228 | -+ | 99x |
- #' @inheritParams prop_diff+ n <- sum(tbl) |
| 229 | -+ | 99x |
- #' @inheritParams prop_diff_wald+ n1 <- sum(tbl[1, ]) |
| 230 | -+ | 99x |
- #'+ n2 <- sum(tbl[2, ]) |
| 231 |
- #' @keywords internal+ |
||
| 232 | -+ | 99x |
- check_diff_prop_ci <- function(rsp,+ ad <- diag(tbl) |
| 233 | -+ | 99x |
- grp,+ bc <- diag(apply(tbl, 2, rev)) |
| 234 | -+ | 99x |
- strata = NULL,+ ac <- tbl[, 1] |
| 235 | -+ | 99x |
- conf_level,+ bd <- tbl[, 2] |
| 236 |
- correct = NULL) {
+
|
||
| 237 | -17x | +99x |
- checkmate::assert_logical(rsp, any.missing = FALSE)+ t_schouten <- (n - 1) * |
| 238 | -17x | +99x |
- checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2)+ (abs(prod(ad) - prod(bc)) - 0.5 * min(n1, n2))^2 / |
| 239 | -17x | +99x |
- checkmate::assert_number(conf_level, lower = 0, upper = 1)+ (n1 * n2 * sum(ac) * sum(bd)) |
| 240 | -17x | +
- checkmate::assert_flag(correct, null.ok = TRUE)+ |
|
| 241 | -+ | 99x |
-
+ 1 - stats::pchisq(t_schouten, df = 1) |
| 242 | -17x | +
- if (!is.null(strata)) {
+ } |
|
| 243 | -11x | +
- checkmate::assert_factor(strata, len = length(rsp))+ |
|
| 244 |
- }+ #' @describeIn h_prop_diff_test performs the Fisher's exact test. Internally calls [stats::fisher.test()]. |
||
| 245 |
-
+ #' |
||
| 246 | -17x | +
- invisible()+ #' |
|
| 247 |
- }+ #' @keywords internal |
||
| 248 |
-
+ prop_fisher <- function(tbl) {
|
||
| 249 | -+ | 2x |
- #' Description of Method Used for Proportion Comparison+ checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2) |
| 250 | -+ | 2x |
- #'+ tbl <- tbl[, c("TRUE", "FALSE")]
|
| 251 | -+ | 2x |
- #' @description `r lifecycle::badge("stable")`
+ stats::fisher.test(tbl)$p.value |
| 252 |
- #'+ } |
| 253 | +1 |
- #' This is an auxiliary function that describes the analysis in+ #' Encode Categorical Missing Values in a Data Frame |
||
| 254 | +2 |
- #' `s_proportion_diff`.+ #' |
||
| 255 | +3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+ |
| 4 |
#' |
|||
| 256 | +5 |
- #' @inheritParams s_proportion_diff+ #' This is a helper function to encode missing entries across groups of categorical |
||
| 257 | +6 |
- #' @param long (`logical`)\cr Whether a long or a short (default) description is required.+ #' variables in a data frame. |
||
| 258 | +7 |
#' |
||
| 259 | +8 |
- #' @return A `string` describing the analysis.+ #' @details Missing entries are those with `NA` or empty strings and will |
||
| 260 | +9 |
- #'+ #' be replaced with a specified value. If factor variables include missing |
||
| 261 | +10 |
- #' @seealso [prop_diff]+ #' values, the missing value will be inserted as the last level. |
||
| 262 | +11 |
- #'+ #' Similarly, in case character or logical variables should be converted to factors |
||
| 263 | +12 |
- #' @export+ #' with the `char_as_factor` or `logical_as_factor` options, the missing values will |
||
| 264 | +13 |
- d_proportion_diff <- function(conf_level,+ #' be set as the last level. |
||
| 265 | +14 |
- method,+ #' |
||
| 266 | +15 |
- long = FALSE) {
+ #' @param data (`data.frame`)\cr data set. |
||
| 267 | -8x | +|||
| 16 | +
- label <- paste0(conf_level * 100, "% CI")+ #' @param omit_columns (`character`)\cr names of variables from `data` that should |
|||
| 268 | -8x | +|||
| 17 | +
- if (long) {
+ #' not be modified by this function. |
|||
| 269 | -! | +|||
| 18 | +
- label <- paste(+ #' @param char_as_factor (`flag`)\cr whether to convert character variables |
|||
| 270 | -! | +|||
| 19 | +
- label,+ #' in `data` to factors. |
|||
| 271 | -! | +|||
| 20 | +
- ifelse(+ #' @param logical_as_factor (`flag`)\cr whether to convert logical variables |
|||
| 272 | -! | +|||
| 21 | +
- method == "cmh",+ #' in `data` to factors. |
|||
| 273 | -! | +|||
| 22 | +
- "for adjusted difference",+ #' @param na_level (`string`)\cr used to replace all `NA` or empty |
|||
| 274 | -! | +|||
| 23 | +
- "for difference"+ #' values inside non-`omit_columns` columns. |
|||
| 275 | +24 |
- )+ #' |
||
| 276 | +25 |
- )+ #' @return A `data.frame` with the chosen modifications applied. |
||
| 277 | +26 |
- }+ #' |
||
| 278 | +27 |
-
+ #' @seealso [sas_na()] and [explicit_na()] for other missing data helper functions. |
||
| 279 | -8x | +|||
| 28 | +
- method_part <- switch(method,+ #' |
|||
| 280 | -8x | +|||
| 29 | +
- "cmh" = "CMH, without correction",+ #' @examples |
|||
| 281 | -8x | +|||
| 30 | +
- "waldcc" = "Wald, with correction",+ #' my_data <- data.frame( |
|||
| 282 | -8x | +|||
| 31 | +
- "wald" = "Wald, without correction",+ #' u = c(TRUE, FALSE, NA, TRUE), |
|||
| 283 | -8x | +|||
| 32 | +
- "ha" = "Anderson-Hauck",+ #' v = factor(c("A", NA, NA, NA), levels = c("Z", "A")),
|
|||
| 284 | -8x | +|||
| 33 | +
- "newcombe" = "Newcombe, without correction",+ #' w = c("A", "B", NA, "C"),
|
|||
| 285 | -8x | +|||
| 34 | +
- "newcombecc" = "Newcombe, with correction",+ #' x = c("D", "E", "F", NA),
|
|||
| 286 | -8x | +|||
| 35 | +
- "strat_newcombe" = "Stratified Newcombe, without correction",+ #' y = c("G", "H", "I", ""),
|
|||
| 287 | -8x | +|||
| 36 | +
- "strat_newcombecc" = "Stratified Newcombe, with correction",+ #' z = c(1, 2, 3, 4), |
|||
| 288 | -8x | +|||
| 37 | +
- stop(paste(method, "does not have a description"))+ #' stringsAsFactors = FALSE |
|||
| 289 | +38 |
- )+ #' ) |
||
| 290 | -8x | +|||
| 39 | +
- paste0(label, " (", method_part, ")")
+ #' |
|||
| 291 | +40 |
- }+ #' # Example 1 |
||
| 292 | +41 |
-
+ #' # Encode missing values in all character or factor columns. |
||
| 293 | +42 |
- #' Helper Functions to Calculate Proportion Difference+ #' df_explicit_na(my_data) |
||
| 294 | +43 |
- #'+ #' # Also convert logical columns to factor columns. |
||
| 295 | +44 |
- #' @description `r lifecycle::badge("stable")`
+ #' df_explicit_na(my_data, logical_as_factor = TRUE) |
||
| 296 | +45 |
- #'+ #' # Encode missing values in a subset of columns. |
||
| 297 | +46 |
- #' @inheritParams argument_convention+ #' df_explicit_na(my_data, omit_columns = c("x", "y"))
|
||
| 298 | +47 |
- #' @inheritParams prop_diff+ #' |
||
| 299 | +48 |
- #' @param grp (`factor`)\cr vector assigning observations to one out of two groups+ #' # Example 2 |
||
| 300 | +49 |
- #' (e.g. reference and treatment group).+ #' # Here we purposefully convert all `M` values to `NA` in the `SEX` variable. |
||
| 301 | +50 |
- #'+ #' # After running `df_explicit_na` the `NA` values are encoded as `<Missing>` but they are not |
||
| 302 | +51 |
- #' @return A named `list` of elements `diff` (proportion difference) and `diff_ci`+ #' # included when generating `rtables`. |
||
| 303 | +52 |
- #' (proportion difference confidence interval).+ #' adsl <- tern_ex_adsl |
||
| 304 | +53 |
- #'+ #' adsl$SEX[adsl$SEX == "M"] <- NA |
||
| 305 | +54 |
- #' @seealso [prop_diff()] for implementation of these helper functions.+ #' adsl <- df_explicit_na(adsl) |
||
| 306 | +55 |
#' |
||
| 307 | +56 |
- #' @name h_prop_diff+ #' # If you want the `Na` values to be displayed in the table use the `na_level` argument. |
||
| 308 | +57 |
- NULL+ #' adsl <- tern_ex_adsl |
||
| 309 | +58 |
-
+ #' adsl$SEX[adsl$SEX == "M"] <- NA |
||
| 310 | +59 |
- #' @describeIn h_prop_diff The Wald interval follows the usual textbook+ #' adsl <- df_explicit_na(adsl, na_level = "Missing Values") |
||
| 311 | +60 |
- #' definition for a single proportion confidence interval using the normal+ #' |
||
| 312 | +61 |
- #' approximation. It is possible to include a continuity correction for Wald's+ #' # Example 3 |
||
| 313 | +62 |
- #' interval.+ #' # Numeric variables that have missing values are not altered. This means that any `NA` value in |
||
| 314 | +63 |
- #'+ #' # a numeric variable will not be included in the summary statistics, nor will they be included |
||
| 315 | +64 |
- #' @param correct (`logical`)\cr whether to include the continuity correction. For further+ #' # in the denominator value for calculating the percent values. |
||
| 316 | +65 |
- #' information, see [stats::prop.test()].+ #' adsl <- tern_ex_adsl |
||
| 317 | +66 |
- #'+ #' adsl$AGE[adsl$AGE < 30] <- NA |
||
| 318 | +67 |
- #' @examples+ #' adsl <- df_explicit_na(adsl) |
||
| 319 | +68 |
- #' # Wald confidence interval+ #' |
||
| 320 | +69 |
- #' set.seed(2)+ #' @export |
||
| 321 | +70 |
- #' rsp <- sample(c(TRUE, FALSE), replace = TRUE, size = 20)+ df_explicit_na <- function(data, |
||
| 322 | +71 |
- #' grp <- factor(c(rep("A", 10), rep("B", 10)))
+ omit_columns = NULL, |
||
| 323 | +72 |
- #' prop_diff_wald(rsp = rsp, grp = grp, conf_level = 0.95, correct = FALSE)+ char_as_factor = TRUE, |
||
| 324 | +73 |
- #'+ logical_as_factor = FALSE, |
||
| 325 | +74 |
- #' @export+ na_level = "<Missing>") {
|
||
| 326 | -+ | |||
| 75 | +22x |
- prop_diff_wald <- function(rsp,+ checkmate::assert_character(omit_columns, null.ok = TRUE, min.len = 1, any.missing = FALSE)+ |
+ ||
| 76 | +21x | +
+ checkmate::assert_data_frame(data)+ |
+ ||
| 77 | +20x | +
+ checkmate::assert_flag(char_as_factor)+ |
+ ||
| 78 | +19x | +
+ checkmate::assert_flag(logical_as_factor)+ |
+ ||
| 79 | +19x | +
+ checkmate::assert_string(na_level) |
||
| 327 | +80 |
- grp,+ + |
+ ||
| 81 | +17x | +
+ target_vars <- if (is.null(omit_columns)) {
+ |
+ ||
| 82 | +15x | +
+ names(data) |
||
| 328 | +83 |
- conf_level = 0.95,+ } else {
+ |
+ ||
| 84 | +2x | +
+ setdiff(names(data), omit_columns) # May have duplicates. |
||
| 329 | +85 |
- correct = FALSE) {
+ } |
||
| 330 | -2x | +86 | +17x |
- if (isTRUE(correct)) {
+ if (length(target_vars) == 0) {
|
| 331 | +87 | 1x |
- mthd <- "waldcc"+ return(data) |
|
| 332 | +88 |
- } else {
+ }+ |
+ ||
| 89 | ++ | + | ||
| 333 | -1x | +90 | +16x |
- mthd <- "wald"+ l_target_vars <- split(target_vars, target_vars) |
| 334 | +91 |
- }+ + |
+ ||
| 92 | ++ |
+ # Makes sure target_vars exist in data and names are not duplicated. |
||
| 335 | -2x | +93 | +16x |
- grp <- as_factor_keep_attributes(grp)+ assert_df_with_variables(data, l_target_vars)+ |
+
| 94 | ++ | + | ||
| 336 | -2x | +95 | +16x |
- check_diff_prop_ci(+ for (x in target_vars) {
|
| 337 | -2x | +96 | +304x |
- rsp = rsp, grp = grp, conf_level = conf_level, correct = correct+ xi <- data[[x]] |
| 338 | -+ | |||
| 97 | +304x |
- )+ xi_label <- obj_label(xi) |
||
| 339 | +98 | |||
| 340 | +99 |
- # check if binary response is coded as logical+ # Determine whether to convert character or logical input. |
||
| 341 | -2x | +100 | +304x |
- checkmate::assert_logical(rsp, any.missing = FALSE)+ do_char_conversion <- is.character(xi) && char_as_factor |
| 342 | -2x | +101 | +304x |
- checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2)+ do_logical_conversion <- is.logical(xi) && logical_as_factor |
| 343 | +102 | ++ | + + | +|
| 103 | ++ |
+ # Pre-convert logical to character to deal correctly with replacing NA+ |
+ ||
| 104 |
-
+ # values below.+ |
+ |||
| 105 | +304x | +
+ if (do_logical_conversion) {
|
||
| 344 | +106 | 2x |
- tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ xi <- as.character(xi) |
|
| 345 | +107 |
- # x1 and n1 are non-reference groups.+ } |
||
| 346 | -2x | +|||
| 108 | +
- diff_ci <- desctools_binom(+ |
|||
| 347 | -2x | +109 | +304x |
- x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ if (is.factor(xi) || is.character(xi)) {
|
| 348 | -2x | +|||
| 110 | +
- x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ # Handle empty strings and NA values. |
|||
| 349 | -2x | +111 | +217x |
- conf.level = conf_level,+ xi <- explicit_na(sas_na(xi), label = na_level) |
| 350 | -2x | +|||
| 112 | +
- method = mthd+ |
|||
| 351 | +113 |
- )+ # Convert to factors if requested for the original type, |
||
| 352 | +114 |
-
+ # set na_level as the last value. |
||
| 353 | -2x | +115 | +217x |
- list(+ if (do_char_conversion || do_logical_conversion) {
|
| 354 | -2x | +116 | +78x |
- "diff" = unname(diff_ci[, "est"]),+ levels_xi <- setdiff(sort(unique(xi)), na_level) |
| 355 | -2x | +117 | +78x |
- "diff_ci" = unname(diff_ci[, c("lwr.ci", "upr.ci")])
+ if (na_level %in% unique(xi)) {
|
| 356 | -+ | |||
| 118 | +18x |
- )+ levels_xi <- c(levels_xi, na_level) |
||
| 357 | +119 |
- }+ } |
||
| 358 | +120 | |||
| 359 | -+ | |||
| 121 | +78x |
- #' @describeIn h_prop_diff Anderson-Hauck confidence interval.+ xi <- factor(xi, levels = levels_xi) |
||
| 360 | +122 |
- #'+ } |
||
| 361 | +123 |
- #' @examples+ |
||
| 362 | -+ | |||
| 124 | +217x |
- #' # Anderson-Hauck confidence interval+ data[, x] <- formatters::with_label(xi, label = xi_label) |
||
| 363 | +125 |
- #' ## "Mid" case: 3/4 respond in group A, 1/2 respond in group B.+ } |
||
| 364 | +126 |
- #' rsp <- c(TRUE, FALSE, FALSE, TRUE, TRUE, TRUE)+ } |
||
| 365 | -+ | |||
| 127 | +16x |
- #' grp <- factor(c("A", "B", "A", "B", "A", "A"), levels = c("B", "A"))
+ return(data) |
||
| 366 | +128 |
- #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.90)+ } |
| 367 | +1 |
- #'+ #' Counting Specific Values |
||
| 368 | +2 |
- #' ## Edge case: Same proportion of response in A and B.+ #' |
||
| 369 | +3 |
- #' rsp <- c(TRUE, FALSE, TRUE, FALSE)+ #' @description `r lifecycle::badge("stable")`
|
||
| 370 | +4 |
- #' grp <- factor(c("A", "A", "B", "B"), levels = c("A", "B"))
+ #' |
||
| 371 | +5 |
- #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.6)+ #' We can count the occurrence of specific values in a variable of interest. |
||
| 372 | +6 |
#' |
||
| 373 | +7 |
- #' @export+ #' @inheritParams argument_convention |
||
| 374 | +8 |
- prop_diff_ha <- function(rsp,+ #' |
||
| 375 | +9 |
- grp,+ #' @note |
||
| 376 | +10 |
- conf_level) {
- |
- ||
| 377 | -3x | -
- grp <- as_factor_keep_attributes(grp)- |
- ||
| 378 | -3x | -
- check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level)+ #' * For `factor` variables, `s_count_values` checks whether `values` are all included in the levels of `x` |
||
| 379 | +11 | - - | -||
| 380 | -3x | -
- tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ #' and fails otherwise. |
||
| 381 | +12 |
- # x1 and n1 are non-reference groups.- |
- ||
| 382 | -3x | -
- ci <- desctools_binom(- |
- ||
| 383 | -3x | -
- x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ #' * For `count_values()`, variable labels are shown when there is more than one element in `vars`, |
||
| 384 | -3x | +|||
| 13 | +
- x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ #' otherwise they are hidden. |
|||
| 385 | -3x | +|||
| 14 | +
- conf.level = conf_level,+ #' |
|||
| 386 | -3x | +|||
| 15 | +
- method = "ha"+ #' @name count_values_funs |
|||
| 387 | +16 |
- )+ NULL |
||
| 388 | -3x | +|||
| 17 | +
- list(+ |
|||
| 389 | -3x | +|||
| 18 | +
- "diff" = unname(ci[, "est"]),+ #' @describeIn count_values_funs S3 generic function to count values. |
|||
| 390 | -3x | +|||
| 19 | +
- "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
+ #' |
|||
| 391 | +20 |
- )+ #' @inheritParams s_summary.logical |
||
| 392 | +21 |
- }+ #' @param values (`character`)\cr specific values that should be counted. |
||
| 393 | +22 |
-
+ #' |
||
| 394 | +23 |
- #' @describeIn h_prop_diff `Newcombe` confidence interval. It is based on+ #' @return |
||
| 395 | +24 |
- #' the Wilson score confidence interval for a single binomial proportion.+ #' * `s_count_values()` returns output of [s_summary()] for specified values of a non-numeric variable. |
||
| 396 | +25 |
#' |
||
| 397 | +26 |
- #' @examples+ #' @export |
||
| 398 | +27 |
- #' # `Newcombe` confidence interval+ s_count_values <- function(x, |
||
| 399 | +28 |
- #'+ values, |
||
| 400 | +29 |
- #' set.seed(1)+ na.rm = TRUE, # nolint |
||
| 401 | +30 |
- #' rsp <- c(+ .N_col, # nolint |
||
| 402 | +31 |
- #' sample(c(TRUE, FALSE), size = 40, prob = c(3 / 4, 1 / 4), replace = TRUE),+ .N_row, # nolint |
||
| 403 | +32 |
- #' sample(c(TRUE, FALSE), size = 40, prob = c(1 / 2, 1 / 2), replace = TRUE)+ denom = c("n", "N_row", "N_col")) {
|
||
| 404 | -+ | |||
| 33 | +110x |
- #' )+ UseMethod("s_count_values", x)
|
||
| 405 | +34 |
- #' grp <- factor(rep(c("A", "B"), each = 40), levels = c("B", "A"))
+ } |
||
| 406 | +35 |
- #' table(rsp, grp)+ |
||
| 407 | +36 |
- #' prop_diff_nc(rsp = rsp, grp = grp, conf_level = 0.9)+ #' @describeIn count_values_funs Method for `character` class. |
||
| 408 | +37 |
#' |
||
| 409 | +38 |
- #' @export+ #' @method s_count_values character |
||
| 410 | +39 |
- prop_diff_nc <- function(rsp,+ #' |
||
| 411 | +40 |
- grp,+ #' @examples |
||
| 412 | +41 |
- conf_level,+ #' # `s_count_values.character` |
||
| 413 | +42 |
- correct = FALSE) {
- |
- ||
| 414 | -1x | -
- if (isTRUE(correct)) {
+ #' s_count_values(x = c("a", "b", "a"), values = "a")
|
||
| 415 | -! | +|||
| 43 | +
- mthd <- "scorecc"+ #' s_count_values(x = c("a", "b", "a", NA, NA), values = "b", na.rm = FALSE)
|
|||
| 416 | +44 |
- } else {
+ #' |
||
| 417 | -1x | +|||
| 45 | +
- mthd <- "score"+ #' @export |
|||
| 418 | +46 |
- }+ s_count_values.character <- function(x, |
||
| 419 | -1x | +|||
| 47 | +
- grp <- as_factor_keep_attributes(grp)+ values = "Y", |
|||
| 420 | -1x | +|||
| 48 | +
- check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level)+ na.rm = TRUE, # nolint |
|||
| 421 | +49 |
-
+ ...) {
|
||
| 422 | -1x | +50 | +108x |
- p_grp <- tapply(rsp, grp, mean)+ checkmate::assert_character(values) |
| 423 | -1x | +|||
| 51 | +
- diff_p <- unname(diff(p_grp))+ |
|||
| 424 | -1x | +52 | +108x |
- tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ if (na.rm) {
|
| 425 | -1x | +53 | +108x |
- ci <- desctools_binom(+ x <- x[!is.na(x)] |
| 426 | +54 |
- # x1 and n1 are non-reference groups.+ } |
||
| 427 | -1x | +|||
| 55 | +
- x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ |
|||
| 428 | -1x | +56 | +108x |
- x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ is_in_values <- x %in% values |
| 429 | -1x | +|||
| 57 | +
- conf.level = conf_level,+ |
|||
| 430 | -1x | +58 | +108x |
- method = mthd+ s_summary(is_in_values, ...) |
| 431 | +59 |
- )- |
- ||
| 432 | -1x | -
- list(+ } |
||
| 433 | -1x | +|||
| 60 | +
- "diff" = unname(ci[, "est"]),+ |
|||
| 434 | -1x | +|||
| 61 | +
- "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
+ #' @describeIn count_values_funs Method for `factor` class. This makes an automatic |
|||
| 435 | +62 |
- )+ #' conversion to `character` and then forwards to the method for characters. |
||
| 436 | +63 |
- }+ #' |
||
| 437 | +64 |
-
+ #' @method s_count_values factor |
||
| 438 | +65 |
- #' @describeIn h_prop_diff Calculates the weighted difference. This is defined as the difference in+ #' |
||
| 439 | +66 |
- #' response rates between the experimental treatment group and the control treatment group, adjusted+ #' @examples |
||
| 440 | +67 |
- #' for stratification factors by applying `Cochran-Mantel-Haenszel` (`CMH`) weights. For the `CMH` chi-squared+ #' # `s_count_values.factor` |
||
| 441 | +68 |
- #' test, use [stats::mantelhaen.test()].+ #' s_count_values(x = factor(c("a", "b", "a")), values = "a")
|
||
| 442 | +69 |
#' |
||
| 443 | +70 |
- #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ #' @export |
||
| 444 | +71 |
- #'+ s_count_values.factor <- function(x, |
||
| 445 | +72 |
- #' @examples+ values = "Y", |
||
| 446 | +73 |
- #' # Cochran-Mantel-Haenszel confidence interval+ ...) {
|
||
| 447 | -+ | |||
| 74 | +3x |
- #'+ s_count_values(as.character(x), values = as.character(values), ...) |
||
| 448 | +75 |
- #' set.seed(2)+ } |
||
| 449 | +76 |
- #' rsp <- sample(c(TRUE, FALSE), 100, TRUE)+ |
||
| 450 | +77 |
- #' grp <- sample(c("Placebo", "Treatment"), 100, TRUE)
+ #' @describeIn count_values_funs Method for `logical` class. |
||
| 451 | +78 |
- #' grp <- factor(grp, levels = c("Placebo", "Treatment"))
+ #' |
||
| 452 | +79 |
- #' strata_data <- data.frame(+ #' @method s_count_values logical |
||
| 453 | +80 |
- #' "f1" = sample(c("a", "b"), 100, TRUE),
+ #' |
||
| 454 | +81 |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ #' @examples |
||
| 455 | +82 |
- #' stringsAsFactors = TRUE+ #' # `s_count_values.logical` |
||
| 456 | +83 |
- #' )+ #' s_count_values(x = c(TRUE, FALSE, TRUE)) |
||
| 457 | +84 |
#' |
||
| 458 | +85 |
- #' prop_diff_cmh(+ #' @export |
||
| 459 | +86 |
- #' rsp = rsp, grp = grp, strata = interaction(strata_data),+ s_count_values.logical <- function(x, values = TRUE, ...) {
|
||
| 460 | -+ | |||
| 87 | +3x |
- #' conf_level = 0.90+ checkmate::assert_logical(values) |
||
| 461 | -+ | |||
| 88 | +3x |
- #' )+ s_count_values(as.character(x), values = as.character(values), ...) |
||
| 462 | +89 |
- #'+ } |
||
| 463 | +90 |
- #' @export+ |
||
| 464 | +91 |
- prop_diff_cmh <- function(rsp,+ #' @describeIn count_values_funs Formatted analysis function which is used as `afun` |
||
| 465 | +92 |
- grp,+ #' in `count_values()`. |
||
| 466 | +93 |
- strata,+ #' |
||
| 467 | +94 |
- conf_level = 0.95) {
- |
- ||
| 468 | -7x | -
- grp <- as_factor_keep_attributes(grp)- |
- ||
| 469 | -7x | -
- strata <- as_factor_keep_attributes(strata)- |
- ||
| 470 | -7x | -
- check_diff_prop_ci(+ #' @return |
||
| 471 | -7x | +|||
| 95 | +
- rsp = rsp, grp = grp, conf_level = conf_level, strata = strata+ #' * `a_count_values()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 472 | +96 |
- )+ #' |
||
| 473 | +97 |
-
+ #' @examples |
||
| 474 | -7x | +|||
| 98 | +
- if (any(tapply(rsp, strata, length) < 5)) {
+ #' # `a_count_values` |
|||
| 475 | -! | +|||
| 99 | +
- warning("Less than 5 observations in some strata.")
+ #' a_count_values(x = factor(c("a", "b", "a")), values = "a", .N_col = 10, .N_row = 10)
|
|||
| 476 | +100 |
- }+ #' |
||
| 477 | +101 |
-
+ #' @export |
||
| 478 | +102 |
- # first dimension: FALSE, TRUE+ a_count_values <- make_afun( |
||
| 479 | +103 |
- # 2nd dimension: CONTROL, TX+ s_count_values, |
||
| 480 | +104 |
- # 3rd dimension: levels of strat+ .formats = c(count_fraction = "xx (xx.xx%)", count = "xx") |
||
| 481 | +105 |
- # rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records+ ) |
||
| 482 | -7x | +|||
| 106 | +
- t_tbl <- table(+ |
|||
| 483 | -7x | +|||
| 107 | +
- factor(rsp, levels = c("FALSE", "TRUE")),
+ #' @describeIn count_values_funs Layout-creating function which can take statistics function arguments |
|||
| 484 | -7x | +|||
| 108 | +
- grp,+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 485 | -7x | +|||
| 109 | +
- strata+ #' |
|||
| 486 | +110 |
- )+ #' @return |
||
| 487 | -7x | +|||
| 111 | +
- n1 <- colSums(t_tbl[1:2, 1, ])+ #' * `count_values()` returns a layout object suitable for passing to further layouting functions, |
|||
| 488 | -7x | +|||
| 112 | +
- n2 <- colSums(t_tbl[1:2, 2, ])+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 489 | -7x | +|||
| 113 | +
- p1 <- t_tbl[2, 1, ] / n1+ #' the statistics from `s_count_values()` to the table layout. |
|||
| 490 | -7x | +|||
| 114 | +
- p2 <- t_tbl[2, 2, ] / n2+ #' |
|||
| 491 | +115 |
- # CMH weights+ #' @examples |
||
| 492 | -7x | +|||
| 116 | +
- use_stratum <- (n1 > 0) & (n2 > 0)+ #' # `count_values` |
|||
| 493 | -7x | +|||
| 117 | +
- n1 <- n1[use_stratum]+ #' basic_table() %>% |
|||
| 494 | -7x | +|||
| 118 | +
- n2 <- n2[use_stratum]+ #' count_values("Species", values = "setosa") %>%
|
|||
| 495 | -7x | +|||
| 119 | +
- p1 <- p1[use_stratum]+ #' build_table(iris) |
|||
| 496 | -7x | +|||
| 120 | +
- p2 <- p2[use_stratum]+ #' |
|||
| 497 | -7x | +|||
| 121 | +
- wt <- (n1 * n2 / (n1 + n2))+ #' @export |
|||
| 498 | -7x | +|||
| 122 | +
- wt_normalized <- wt / sum(wt)+ count_values <- function(lyt, |
|||
| 499 | -7x | +|||
| 123 | +
- est1 <- sum(wt_normalized * p1)+ vars, |
|||
| 500 | -7x | +|||
| 124 | +
- est2 <- sum(wt_normalized * p2)+ values, |
|||
| 501 | -7x | +|||
| 125 | +
- estimate <- c(est1, est2)+ na_str = NA_character_, |
|||
| 502 | -7x | +|||
| 126 | +
- names(estimate) <- levels(grp)+ nested = TRUE, |
|||
| 503 | -7x | +|||
| 127 | +
- se1 <- sqrt(sum(wt_normalized^2 * p1 * (1 - p1) / n1))+ ..., |
|||
| 504 | -7x | +|||
| 128 | +
- se2 <- sqrt(sum(wt_normalized^2 * p2 * (1 - p2) / n2))+ table_names = vars, |
|||
| 505 | -7x | +|||
| 129 | +
- z <- stats::qnorm((1 + conf_level) / 2)+ .stats = "count_fraction", |
|||
| 506 | -7x | +|||
| 130 | +
- err1 <- z * se1+ .formats = NULL, |
|||
| 507 | -7x | +|||
| 131 | +
- err2 <- z * se2+ .labels = c(count_fraction = paste(values, collapse = ", ")), |
|||
| 508 | -7x | +|||
| 132 | +
- ci1 <- c((est1 - err1), (est1 + err1))+ .indent_mods = NULL) {
|
|||
| 509 | -7x | +133 | +3x |
- ci2 <- c((est2 - err2), (est2 + err2))+ afun <- make_afun( |
| 510 | -7x | +134 | +3x |
- estimate_ci <- list(ci1, ci2)+ a_count_values, |
| 511 | -7x | +135 | +3x |
- names(estimate_ci) <- levels(grp)+ .stats = .stats, |
| 512 | -7x | +136 | +3x |
- diff_est <- est2 - est1+ .formats = .formats, |
| 513 | -7x | +137 | +3x |
- se_diff <- sqrt(sum(((p1 * (1 - p1) / n1) + (p2 * (1 - p2) / n2)) * wt_normalized^2))+ .labels = .labels, |
| 514 | -7x | +138 | +3x |
- diff_ci <- c(diff_est - z * se_diff, diff_est + z * se_diff)+ .indent_mods = .indent_mods |
| 515 | +139 | - - | -||
| 516 | -7x | -
- list(- |
- ||
| 517 | -7x | -
- prop = estimate,+ ) |
||
| 518 | -7x | +140 | +3x |
- prop_ci = estimate_ci,+ analyze( |
| 519 | -7x | +141 | +3x |
- diff = diff_est,+ lyt, |
| 520 | -7x | +142 | +3x |
- diff_ci = diff_ci,+ vars, |
| 521 | -7x | +143 | +3x |
- weights = wt_normalized,+ afun = afun, |
| 522 | -7x | +144 | +3x |
- n1 = n1,+ na_str = na_str, |
| 523 | -7x | -
- n2 = n2- |
- ||
| 524 | -- |
- )- |
- ||
| 525 | -+ | 145 | +3x |
- }+ nested = nested, |
| 526 | -+ | |||
| 146 | +3x |
-
+ extra_args = c(list(values = values), list(...)), |
||
| 527 | -+ | |||
| 147 | +3x |
- #' @describeIn h_prop_diff Calculates the stratified `Newcombe` confidence interval and difference in response+ show_labels = ifelse(length(vars) > 1, "visible", "hidden"), |
||
| 528 | -+ | |||
| 148 | +3x |
- #' rates between the experimental treatment group and the control treatment group, adjusted for stratification+ table_names = table_names |
||
| 529 | +149 |
- #' factors. This implementation follows closely the one proposed by \insertCite{Yan2010-jt;textual}{tern}.
+ ) |
||
| 530 | +150 |
- #' Weights can be estimated from the heuristic proposed in [prop_strat_wilson()] or from `CMH`-derived weights+ } |
| 531 | +1 |
- #' (see [prop_diff_cmh()]).+ #' Number of Patients |
||
| 532 | +2 |
#' |
||
| 533 | +3 |
- #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 534 | +4 |
- #' @param weights_method (`string`)\cr weights method. Can be either `"cmh"` or `"heuristic"`+ #' |
||
| 535 | +5 |
- #' and directs the way weights are estimated.+ #' Count the number of unique and non-unique patients in a column (variable). |
||
| 536 | +6 |
#' |
||
| 537 | -- |
- #' @references- |
- ||
| 538 | +7 |
- #' \insertRef{Yan2010-jt}{tern}
+ #' @inheritParams argument_convention |
||
| 539 | +8 |
- #'+ #' @param x (`character` or `factor`)\cr vector of patient IDs. |
||
| 540 | +9 |
- #' @examples+ #' @param count_by (`character` or `factor`)\cr optional vector to be combined with `x` when counting |
||
| 541 | +10 |
- #' # Stratified `Newcombe` confidence interval+ #' `nonunique` records. |
||
| 542 | +11 |
- #'+ #' @param unique_count_suffix (`logical`)\cr should `"(n)"` suffix be added to `unique_count` labels. |
||
| 543 | +12 |
- #' set.seed(2)+ #' Defaults to `TRUE`. |
||
| 544 | +13 |
- #' data_set <- data.frame(+ #' |
||
| 545 | +14 |
- #' "rsp" = sample(c(TRUE, FALSE), 100, TRUE),+ #' @name summarize_num_patients |
||
| 546 | +15 |
- #' "f1" = sample(c("a", "b"), 100, TRUE),
+ NULL |
||
| 547 | +16 |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+
|
||
| 548 | +17 |
- #' "grp" = sample(c("Placebo", "Treatment"), 100, TRUE),
+ #' @describeIn summarize_num_patients Statistics function which counts the number of |
||
| 549 | +18 |
- #' stringsAsFactors = TRUE+ #' unique patients, the corresponding percentage taken with respect to the |
||
| 550 | +19 |
- #' )+ #' total number of patients, and the number of non-unique patients. |
||
| 551 | +20 |
#' |
||
| 552 | +21 |
- #' prop_diff_strat_nc(+ #' @return |
||
| 553 | +22 |
- #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]),+ #' * `s_num_patients()` returns a named `list` of 3 statistics: |
||
| 554 | +23 |
- #' weights_method = "cmh",+ #' * `unique`: Vector of counts and percentages. |
||
| 555 | +24 |
- #' conf_level = 0.90+ #' * `nonunique`: Vector of counts. |
||
| 556 | +25 |
- #' )+ #' * `unique_count`: Counts. |
||
| 557 | +26 |
#' |
||
| 558 | +27 |
- #' prop_diff_strat_nc(+ #' @examples |
||
| 559 | +28 |
- #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]),+ #' # Use the statistics function to count number of unique and nonunique patients. |
||
| 560 | +29 |
- #' weights_method = "wilson_h",+ #' s_num_patients(x = as.character(c(1, 1, 1, 2, 4, NA)), labelstr = "", .N_col = 6L) |
||
| 561 | +30 |
- #' conf_level = 0.90+ #' s_num_patients( |
||
| 562 | +31 |
- #' )+ #' x = as.character(c(1, 1, 1, 2, 4, NA)), |
||
| 563 | +32 |
- #'+ #' labelstr = "", |
||
| 564 | +33 |
- #' @export+ #' .N_col = 6L, |
||
| 565 | +34 |
- prop_diff_strat_nc <- function(rsp,+ #' count_by = as.character(c(1, 1, 2, 1, 1, 1)) |
||
| 566 | +35 |
- grp,+ #' ) |
||
| 567 | +36 |
- strata,+ #' |
||
| 568 | +37 |
- weights_method = c("cmh", "wilson_h"),
+ #' @export |
||
| 569 | +38 |
- conf_level = 0.95,+ s_num_patients <- function(x, labelstr, .N_col, count_by = NULL, unique_count_suffix = TRUE) { # nolint
|
||
| 570 | +39 |
- correct = FALSE) {
- |
- ||
| 571 | -4x | -
- weights_method <- match.arg(weights_method)- |
- ||
| 572 | -4x | -
- grp <- as_factor_keep_attributes(grp)- |
- ||
| 573 | -4x | -
- strata <- as_factor_keep_attributes(strata)- |
- ||
| 574 | -4x | -
- check_diff_prop_ci(+ |
||
| 575 | -4x | -
- rsp = rsp, grp = grp, conf_level = conf_level, strata = strata- |
- ||
| 576 | -+ | 40 | +109x |
- )+ checkmate::assert_string(labelstr) |
| 577 | -4x | +41 | +109x |
- checkmate::assert_number(conf_level, lower = 0, upper = 1)+ checkmate::assert_count(.N_col) |
| 578 | -4x | +42 | +109x |
- checkmate::assert_flag(correct)+ checkmate::assert_multi_class(x, classes = c("factor", "character"))
|
| 579 | -4x | -
- if (any(tapply(rsp, strata, length) < 5)) {
- |
- ||
| 580 | -! | -
- warning("Less than 5 observations in some strata.")
- |
- ||
| 581 | -+ | 43 | +109x |
- }+ checkmate::assert_flag(unique_count_suffix) |
| 582 | +44 | |||
| 583 | -4x | +45 | +109x |
- rsp_by_grp <- split(rsp, f = grp)+ count1 <- n_available(unique(x)) |
| 584 | -4x | +46 | +109x |
- strata_by_grp <- split(strata, f = grp)+ count2 <- n_available(x) |
| 585 | +47 | |||
| 586 | -- |
- # Finding the weights- |
- ||
| 587 | -4x | +48 | +109x |
- weights <- if (identical(weights_method, "cmh")) {
+ if (!is.null(count_by)) {
|
| 588 | -3x | +49 | +10x |
- prop_diff_cmh(rsp = rsp, grp = grp, strata = strata)$weights+ checkmate::assert_vector(count_by, len = length(x)) |
| 589 | -4x | +50 | +10x |
- } else if (identical(weights_method, "wilson_h")) {
+ checkmate::assert_multi_class(count_by, classes = c("factor", "character"))
|
| 590 | -1x | +51 | +10x |
- prop_strat_wilson(rsp, strata, conf_level = conf_level, correct = correct)$weights+ count2 <- n_available(unique(interaction(x, count_by))) |
| 591 | +52 |
} |
||
| 592 | -4x | -
- weights[levels(strata)[!levels(strata) %in% names(weights)]] <- 0- |
- ||
| 593 | +53 | |||
| 594 | -+ | |||
| 54 | +109x |
- # Calculating lower (`l`) and upper (`u`) confidence bounds per group.+ out <- list( |
||
| 595 | -4x | +55 | +109x |
- strat_wilson_by_grp <- Map(+ unique = formatters::with_label(c(count1, ifelse(count1 == 0 && .N_col == 0, 0, count1 / .N_col)), labelstr), |
| 596 | -4x | +56 | +109x |
- prop_strat_wilson,+ nonunique = formatters::with_label(count2, labelstr), |
| 597 | -4x | +57 | +109x |
- rsp = rsp_by_grp,+ unique_count = formatters::with_label(count1, ifelse(unique_count_suffix, paste(labelstr, "(n)"), labelstr)) |
| 598 | -4x | +|||
| 58 | +
- strata = strata_by_grp,+ ) |
|||
| 599 | -4x | +|||
| 59 | +
- weights = list(weights, weights),+ |
|||
| 600 | -4x | +60 | +109x |
- conf_level = conf_level,+ out |
| 601 | -4x | +|||
| 61 | +
- correct = correct+ } |
|||
| 602 | +62 |
- )+ |
||
| 603 | +63 |
-
+ #' @describeIn summarize_num_patients Statistics function which counts the number of unique patients |
||
| 604 | -4x | +|||
| 64 | +
- ci_ref <- strat_wilson_by_grp[[1]]+ #' in a column (variable), the corresponding percentage taken with respect to the total number of |
|||
| 605 | -4x | +|||
| 65 | +
- ci_trt <- strat_wilson_by_grp[[2]]+ #' patients, and the number of non-unique patients in the column. |
|||
| 606 | -4x | +|||
| 66 | +
- l_ref <- as.numeric(ci_ref$conf_int[1])+ #' |
|||
| 607 | -4x | +|||
| 67 | +
- u_ref <- as.numeric(ci_ref$conf_int[2])+ #' @param required (`character` or `NULL`)\cr optional name of a variable that is required to be non-missing. |
|||
| 608 | -4x | +|||
| 68 | +
- l_trt <- as.numeric(ci_trt$conf_int[1])+ #' |
|||
| 609 | -4x | +|||
| 69 | +
- u_trt <- as.numeric(ci_trt$conf_int[2])+ #' @return |
|||
| 610 | +70 |
-
+ #' * `s_num_patients_content()` returns the same values as `s_num_patients()`. |
||
| 611 | +71 |
- # Estimating the diff and n_ref, n_trt (it allows different weights to be used)+ #' |
||
| 612 | -4x | +|||
| 72 | +
- t_tbl <- table(+ #' @examples |
|||
| 613 | -4x | +|||
| 73 | +
- factor(rsp, levels = c("FALSE", "TRUE")),
+ #' # Count number of unique and non-unique patients. |
|||
| 614 | -4x | +|||
| 74 | +
- grp,+ #' df <- data.frame( |
|||
| 615 | -4x | +|||
| 75 | +
- strata+ #' USUBJID = as.character(c(1, 2, 1, 4, NA)), |
|||
| 616 | +76 |
- )+ #' EVENT = as.character(c(10, 15, 10, 17, 8)) |
||
| 617 | -4x | +|||
| 77 | +
- n_ref <- colSums(t_tbl[1:2, 1, ])+ #' ) |
|||
| 618 | -4x | +|||
| 78 | +
- n_trt <- colSums(t_tbl[1:2, 2, ])+ #' s_num_patients_content(df, .N_col = 5, .var = "USUBJID") |
|||
| 619 | -4x | +|||
| 79 | +
- use_stratum <- (n_ref > 0) & (n_trt > 0)+ #' |
|||
| 620 | -4x | +|||
| 80 | +
- n_ref <- n_ref[use_stratum]+ #' df_by_event <- data.frame( |
|||
| 621 | -4x | +|||
| 81 | +
- n_trt <- n_trt[use_stratum]+ #' USUBJID = as.character(c(1, 2, 1, 4, NA)), |
|||
| 622 | -4x | +|||
| 82 | +
- p_ref <- t_tbl[2, 1, use_stratum] / n_ref+ #' EVENT = as.character(c(10, 15, 10, 17, 8)) |
|||
| 623 | -4x | +|||
| 83 | +
- p_trt <- t_tbl[2, 2, use_stratum] / n_trt+ #' ) |
|||
| 624 | -4x | +|||
| 84 | +
- est1 <- sum(weights * p_ref)+ #' s_num_patients_content(df_by_event, .N_col = 5, .var = "USUBJID") |
|||
| 625 | -4x | +|||
| 85 | +
- est2 <- sum(weights * p_trt)+ #' s_num_patients_content(df_by_event, .N_col = 5, .var = "USUBJID", count_by = "EVENT") |
|||
| 626 | -4x | +|||
| 86 | +
- diff_est <- est2 - est1+ #' |
|||
| 627 | +87 |
-
+ #' @export |
||
| 628 | -4x | +|||
| 88 | +
- lambda1 <- sum(weights^2 / n_ref)+ s_num_patients_content <- function(df, |
|||
| 629 | -4x | +|||
| 89 | +
- lambda2 <- sum(weights^2 / n_trt)+ labelstr = "", |
|||
| 630 | -4x | +|||
| 90 | +
- z <- stats::qnorm((1 + conf_level) / 2)+ .N_col, # nolint |
|||
| 631 | +91 |
-
+ .var, |
||
| 632 | -4x | +|||
| 92 | +
- lower <- diff_est - z * sqrt(lambda2 * l_trt * (1 - l_trt) + lambda1 * u_ref * (1 - u_ref))+ required = NULL, |
|||
| 633 | -4x | +|||
| 93 | +
- upper <- diff_est + z * sqrt(lambda1 * l_ref * (1 - l_ref) + lambda2 * u_trt * (1 - u_trt))+ count_by = NULL, |
|||
| 634 | +94 |
-
+ unique_count_suffix = TRUE) {
|
||
| 635 | -4x | +95 | +46x |
- list(+ checkmate::assert_string(.var) |
| 636 | -4x | +96 | +46x |
- "diff" = diff_est,+ checkmate::assert_data_frame(df) |
| 637 | -4x | +97 | +46x |
- "diff_ci" = c("lower" = lower, "upper" = upper)
+ if (is.null(count_by)) {
|
| 638 | -+ | |||
| 98 | +43x |
- )+ assert_df_with_variables(df, list(id = .var)) |
||
| 639 | +99 |
- }+ } else {
|
| 1 | -+ | |||
| 100 | +3x |
- #' Incidence Rate+ assert_df_with_variables(df, list(id = .var, count_by = count_by)) |
||
| 2 | +101 |
- #'+ } |
||
| 3 | -+ | |||
| 102 | +46x |
- #' @description `r lifecycle::badge("stable")`
+ if (!is.null(required)) {
|
||
| 4 | -+ | |||
| 103 | +! |
- #'+ checkmate::assert_string(required) |
||
| 5 | -+ | |||
| 104 | +! |
- #' Estimate the event rate adjusted for person-years at risk, otherwise known+ assert_df_with_variables(df, list(required = required)) |
||
| 6 | -+ | |||
| 105 | +! |
- #' as incidence rate. Primary analysis variable is the person-years at risk.+ df <- df[!is.na(df[[required]]), , drop = FALSE] |
||
| 7 | +106 |
- #'+ } |
||
| 8 | +107 |
- #' @inheritParams argument_convention+ |
||
| 9 | -+ | |||
| 108 | +46x |
- #' @param control (`list`)\cr parameters for estimation details, specified by using+ x <- df[[.var]] |
||
| 10 | -+ | |||
| 109 | +46x |
- #' the helper function [control_incidence_rate()]. Possible parameter options are:+ y <- switch(as.numeric(!is.null(count_by)) + 1, |
||
| 11 | -+ | |||
| 110 | +46x |
- #' * `conf_level` (`proportion`)\cr confidence level for the estimated incidence rate.+ NULL, |
||
| 12 | -+ | |||
| 111 | +46x |
- #' * `conf_type` (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`+ df[[count_by]] |
||
| 13 | +112 |
- #' for confidence interval type.+ ) |
||
| 14 | +113 |
- #' * `input_time_unit` (`string`)\cr `day`, `week`, `month`, or `year` (default)+ |
||
| 15 | -+ | |||
| 114 | +46x |
- #' indicating time unit for data input.+ s_num_patients( |
||
| 16 | -+ | |||
| 115 | +46x |
- #' * `num_pt_year` (`numeric`)\cr time unit for desired output (in person-years).+ x = x, |
||
| 17 | -+ | |||
| 116 | +46x |
- #' @param n_events (`integer`)\cr number of events observed.+ labelstr = labelstr, |
||
| 18 | -+ | |||
| 117 | +46x |
- #'+ .N_col = .N_col, |
||
| 19 | -+ | |||
| 118 | +46x |
- #' @seealso [control_incidence_rate()] and helper functions [h_incidence_rate].+ count_by = y, |
||
| 20 | -+ | |||
| 119 | +46x |
- #'+ unique_count_suffix = unique_count_suffix |
||
| 21 | +120 |
- #' @name incidence_rate+ ) |
||
| 22 | +121 |
- NULL+ } |
||
| 23 | +122 | |||
| 24 | +123 |
- #' @describeIn incidence_rate Statistics function which estimates the incidence rate and the+ c_num_patients <- make_afun( |
||
| 25 | +124 |
- #' associated confidence interval.+ s_num_patients_content, |
||
| 26 | +125 |
- #'+ .stats = c("unique", "nonunique", "unique_count"),
|
||
| 27 | +126 |
- #' @return+ .formats = c(unique = format_count_fraction_fixed_dp, nonunique = "xx", unique_count = "xx") |
||
| 28 | +127 |
- #' * `s_incidence_rate()` returns the following statistics:+ ) |
||
| 29 | +128 |
- #' - `person_years`: Total person-years at risk.+ |
||
| 30 | +129 |
- #' - `n_events`: Total number of events observed.+ #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments |
||
| 31 | +130 |
- #' - `rate`: Estimated incidence rate.+ #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 32 | +131 |
- #' - `rate_ci`: Confidence interval for the incidence rate.+ #' |
||
| 33 | +132 |
- #'+ #' @return |
||
| 34 | +133 |
- #' @examples+ #' * `summarize_num_patients()` returns a layout object suitable for passing to further layouting functions, |
||
| 35 | +134 |
- #' library(dplyr)+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 36 | +135 |
- #'+ #' the statistics from `s_num_patients_content()` to the table layout. |
||
| 37 | +136 |
- #' df <- data.frame(+ #' |
||
| 38 | +137 |
- #' USUBJID = as.character(seq(6)),+ #' @export |
||
| 39 | +138 |
- #' CNSR = c(0, 1, 1, 0, 0, 0),+ summarize_num_patients <- function(lyt, |
||
| 40 | +139 |
- #' AVAL = c(10.1, 20.4, 15.3, 20.8, 18.7, 23.4),+ var, |
||
| 41 | +140 |
- #' ARM = factor(c("A", "A", "A", "B", "B", "B"))
+ na_str = NA_character_, |
||
| 42 | +141 |
- #' ) %>%+ .stats = NULL, |
||
| 43 | +142 |
- #' mutate(is_event = CNSR == 0) %>%+ .formats = NULL, |
||
| 44 | +143 |
- #' mutate(n_events = as.integer(is_event))+ .labels = c( |
||
| 45 | +144 |
- #'+ unique = "Number of patients with at least one event", |
||
| 46 | +145 |
- #' @keywords internal+ nonunique = "Number of events" |
||
| 47 | +146 |
- s_incidence_rate <- function(df,+ ), |
||
| 48 | +147 |
- .var,+ indent_mod = lifecycle::deprecated(), |
||
| 49 | +148 |
- n_events,+ .indent_mods = 0L, |
||
| 50 | +149 |
- is_event,+ riskdiff = FALSE, |
||
| 51 | +150 |
- control = control_incidence_rate()) {
+ ...) {
|
||
| 52 | -1x | -
- if (!missing(is_event)) {
- |
- ||
| 53 | -! | +151 | +9x |
- warning("argument is_event will be deprecated. Please use n_events.")
+ checkmate::assert_flag(riskdiff) |
| 54 | +152 | |||
| 55 | -! | +|||
| 153 | +9x |
- if (missing(n_events)) {
+ if (lifecycle::is_present(indent_mod)) {
|
||
| 56 | +154 | ! |
- assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ lifecycle::deprecate_warn("0.8.2", "summarize_num_patients(indent_mod)", "summarize_num_patients(.indent_mods)")
|
|
| 57 | +155 | ! |
- checkmate::assert_string(.var)+ .indent_mods <- indent_mod |
|
| 58 | -! | +|||
| 156 | +
- checkmate::assert_logical(df[[is_event]], any.missing = FALSE)+ } |
|||
| 59 | -! | +|||
| 157 | +
- checkmate::assert_numeric(df[[.var]], any.missing = FALSE)+ |
|||
| 60 | -! | +|||
| 158 | +4x |
- n_events <- is_event+ if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
|
||
| 61 | -+ | |||
| 159 | +2x |
- }+ if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats] |
||
| 62 | +160 |
- } else {
+
|
||
| 63 | -1x | +161 | +9x |
- assert_df_with_variables(df, list(tte = .var, n_events = n_events))+ cfun <- make_afun( |
| 64 | -1x | +162 | +9x |
- checkmate::assert_string(.var)+ c_num_patients, |
| 65 | -1x | +163 | +9x |
- checkmate::assert_numeric(df[[.var]], any.missing = FALSE)+ .stats = .stats, |
| 66 | -1x | +164 | +9x |
- checkmate::assert_integer(df[[n_events]], any.missing = FALSE)+ .formats = .formats,+ |
+
| 165 | +9x | +
+ .labels = .labels |
||
| 67 | +166 |
- }+ ) |
||
| 68 | +167 | |||
| 69 | -1x | +168 | +9x |
- input_time_unit <- control$input_time_unit+ extra_args <- if (isFALSE(riskdiff)) {
|
| 70 | -1x | +169 | +8x |
- num_pt_year <- control$num_pt_year+ list(...) |
| 71 | -1x | +|||
| 170 | +
- conf_level <- control$conf_level+ } else {
|
|||
| 72 | +171 | 1x |
- person_years <- sum(df[[.var]], na.rm = TRUE) * (+ list( |
|
| 73 | +172 | 1x |
- 1 * (input_time_unit == "year") ++ afun = list("s_num_patients_content" = cfun),
|
|
| 74 | +173 | 1x |
- 1 / 12 * (input_time_unit == "month") ++ .stats = .stats, |
|
| 75 | +174 | 1x |
- 1 / 52.14 * (input_time_unit == "week") ++ .indent_mods = .indent_mods, |
|
| 76 | +175 | 1x |
- 1 / 365.24 * (input_time_unit == "day")+ s_args = list(...) |
|
| 77 | +176 |
- )+ ) |
||
| 78 | -1x | +|||
| 177 | +
- n_events <- sum(df[[n_events]], na.rm = TRUE)+ } |
|||
| 79 | +178 | |||
| 80 | -1x | -
- result <- h_incidence_rate(- |
- ||
| 81 | -1x | -
- person_years,- |
- ||
| 82 | -1x | +179 | +9x |
- n_events,+ summarize_row_groups( |
| 83 | -1x | -
- control- |
- ||
| 84 | -+ | 180 | +9x |
- )+ lyt = lyt, |
| 85 | -1x | +181 | +9x |
- list(+ var = var, |
| 86 | -1x | +182 | +9x |
- person_years = formatters::with_label(person_years, "Total patient-years at risk"),+ cfun = ifelse(isFALSE(riskdiff), cfun, afun_riskdiff), |
| 87 | -1x | +183 | +9x |
- n_events = formatters::with_label(n_events, "Number of adverse events observed"),+ na_str = na_str, |
| 88 | -1x | +184 | +9x |
- rate = formatters::with_label(result$rate, paste("AE rate per", num_pt_year, "patient-years")),
+ extra_args = extra_args, |
| 89 | -1x | +185 | +9x |
- rate_ci = formatters::with_label(result$rate_ci, f_conf_level(conf_level))+ indent_mod = .indent_mods |
| 90 | +186 |
) |
||
| 91 | +187 |
} |
||
| 92 | +188 | |||
| 93 | +189 |
- #' @describeIn incidence_rate Formatted analysis function which is used as `afun`+ #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments |
||
| 94 | +190 |
- #' in `estimate_incidence_rate()`.+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 95 | +191 |
#' |
||
| 96 | +192 |
#' @return |
||
| 97 | +193 |
- #' * `a_incidence_rate()` returns the corresponding list with formatted [rtables::CellValue()].+ #' * `analyze_num_patients()` returns a layout object suitable for passing to further layouting functions, |
||
| 98 | +194 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 99 | +195 |
- #'+ #' the statistics from `s_num_patients_content()` to the table layout. |
||
| 100 | +196 |
- #' @keywords internal+ #' |
||
| 101 | +197 |
- a_incidence_rate <- make_afun(+ #' @details In general, functions that starts with `analyze*` are expected to |
||
| 102 | +198 |
- s_incidence_rate,+ #' work like [rtables::analyze()], while functions that starts with `summarize*` |
||
| 103 | +199 |
- .formats = c(+ #' are based upon [rtables::summarize_row_groups()]. The latter provides a |
||
| 104 | +200 |
- "person_years" = "xx.x",+ #' value for each dividing split in the row and column space, but, being it |
||
| 105 | +201 |
- "n_events" = "xx",+ #' bound to the fundamental splits, it is repeated by design in every page |
||
| 106 | +202 |
- "rate" = "xx.xx",+ #' when pagination is involved. |
||
| 107 | +203 |
- "rate_ci" = "(xx.xx, xx.xx)"+ #' |
||
| 108 | +204 |
- )+ #' @note As opposed to [summarize_num_patients()], this function does not repeat the produced rows. |
||
| 109 | +205 |
- )+ #' |
||
| 110 | +206 |
-
+ #' @examples |
||
| 111 | +207 |
- #' @describeIn incidence_rate Layout-creating function which can take statistics function arguments+ #' df_tmp <- data.frame( |
||
| 112 | +208 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' USUBJID = as.character(c(1, 2, 1, 4, NA, 6, 6, 8, 9)), |
||
| 113 | +209 |
- #'+ #' ARM = c("A", "A", "A", "A", "A", "B", "B", "B", "B"),
|
||
| 114 | +210 |
- #' @return+ #' AGE = c(10, 15, 10, 17, 8, 11, 11, 19, 17) |
||
| 115 | +211 |
- #' * `estimate_incidence_rate()` returns a layout object suitable for passing to further layouting functions,+ #' ) |
||
| 116 | +212 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' tbl <- basic_table() %>% |
||
| 117 | +213 |
- #' the statistics from `s_incidence_rate()` to the table layout.+ #' split_cols_by("ARM") %>%
|
||
| 118 | +214 |
- #'+ #' add_colcounts() %>% |
||
| 119 | +215 |
- #' @examples+ #' analyze_num_patients("USUBJID", .stats = c("unique")) %>%
|
||
| 120 | +216 |
- #' basic_table() %>%+ #' build_table(df_tmp) |
||
| 121 | +217 |
- #' split_cols_by("ARM") %>%
+ #' tbl |
||
| 122 | +218 |
- #' add_colcounts() %>%+ #' |
||
| 123 | +219 |
- #' estimate_incidence_rate(+ #' @export |
||
| 124 | +220 |
- #' vars = "AVAL",+ analyze_num_patients <- function(lyt, |
||
| 125 | +221 |
- #' n_events = "n_events",+ vars, |
||
| 126 | +222 |
- #' control = control_incidence_rate(+ na_str = NA_character_, |
||
| 127 | +223 |
- #' input_time_unit = "month",+ nested = TRUE, |
||
| 128 | +224 |
- #' num_pt_year = 100+ .stats = NULL, |
||
| 129 | +225 |
- #' )+ .formats = NULL, |
||
| 130 | +226 |
- #' ) %>%+ .labels = c( |
||
| 131 | +227 |
- #' build_table(df)+ unique = "Number of patients with at least one event", |
||
| 132 | +228 |
- #'+ nonunique = "Number of events" |
||
| 133 | +229 |
- #' @export+ ), |
||
| 134 | +230 |
- estimate_incidence_rate <- function(lyt,+ show_labels = c("default", "visible", "hidden"),
|
||
| 135 | +231 |
- vars,+ indent_mod = lifecycle::deprecated(), |
||
| 136 | +232 |
- nested = TRUE,+ .indent_mods = 0L, |
||
| 137 | +233 |
- ...,+ riskdiff = FALSE, |
||
| 138 | +234 |
- show_labels = "hidden",+ ...) {
|
||
| 139 | -+ | |||
| 235 | +3x |
- table_names = vars,+ checkmate::assert_flag(riskdiff) |
||
| 140 | +236 |
- .stats = NULL,+ + |
+ ||
| 237 | +3x | +
+ if (lifecycle::is_present(indent_mod)) {
+ |
+ ||
| 238 | +! | +
+ lifecycle::deprecate_warn("0.8.2", "analyze_num_patients(indent_mod)", "analyze_num_patients(.indent_mods)")
+ |
+ ||
| 239 | +! | +
+ .indent_mods <- indent_mod |
||
| 141 | +240 |
- .formats = NULL,+ } |
||
| 142 | +241 |
- .labels = NULL,+ + |
+ ||
| 242 | +! | +
+ if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
+ |
+ ||
| 243 | +! | +
+ if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats] |
||
| 143 | +244 |
- .indent_mods = NULL) {
+
|
||
| 144 | -1x | +245 | +3x |
afun <- make_afun( |
| 145 | -1x | +246 | +3x |
- a_incidence_rate,+ c_num_patients, |
| 146 | -1x | +247 | +3x |
.stats = .stats, |
| 147 | -1x | +248 | +3x |
.formats = .formats, |
| 148 | -1x | -
- .labels = .labels,- |
- ||
| 149 | -1x | +249 | +3x |
- .indent_mods = .indent_mods+ .labels = .labels |
| 150 | +250 |
) |
||
| 151 | +251 | |||
| 152 | -1x | +252 | +3x |
- analyze(+ extra_args <- if (isFALSE(riskdiff)) {
|
| 153 | -1x | +253 | +2x |
- lyt,+ list(...) |
| 154 | -1x | +|||
| 254 | +
- vars,+ } else {
|
|||
| 155 | +255 | 1x |
- show_labels = show_labels,+ list( |
|
| 156 | +256 | 1x |
- table_names = table_names,+ afun = list("s_num_patients_content" = afun),
|
|
| 157 | +257 | 1x |
- afun = afun,+ .stats = .stats, |
|
| 158 | +258 | 1x |
- nested = nested,+ .indent_mods = .indent_mods, |
|
| 159 | +259 | 1x |
- extra_args = list(...)+ s_args = list(...) |
|
| 160 | +260 |
- )+ ) |
||
| 161 | +261 |
- }+ } |
||
| 162 | +262 | |||
| 163 | -+ | |||
| 263 | +3x |
- #' Helper Functions for Incidence Rate+ analyze( |
||
| 164 | -+ | |||
| 264 | +3x |
- #'+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff), |
||
| 165 | -+ | |||
| 265 | +3x |
- #' @description `r lifecycle::badge("stable")`
+ lyt = lyt, |
||
| 166 | -+ | |||
| 266 | +3x |
- #'+ vars = vars, |
||
| 167 | -+ | |||
| 267 | +3x |
- #' @param control (`list`)\cr parameters for estimation details, specified by using+ na_str = na_str,+ |
+ ||
| 268 | +3x | +
+ nested = nested,+ |
+ ||
| 269 | +3x | +
+ extra_args = extra_args,+ |
+ ||
| 270 | +3x | +
+ show_labels = show_labels,+ |
+ ||
| 271 | +3x | +
+ indent_mod = .indent_mods |
||
| 168 | +272 |
- #' the helper function [control_incidence_rate()]. Possible parameter options are:+ ) |
||
| 169 | +273 |
- #' * `conf_level`: (`proportion`)\cr confidence level for the estimated incidence rate.+ } |
| 170 | +1 |
- #' * `conf_type`: (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`+ #' Odds Ratio Estimation |
||
| 171 | +2 |
- #' for confidence interval type.+ #' |
||
| 172 | +3 |
- #' * `input_time_unit`: (`string`)\cr `day`, `week`, `month`, or `year` (default)+ #' @description `r lifecycle::badge("stable")`
|
||
| 173 | +4 |
- #' indicating time unit for data input.+ #' |
||
| 174 | +5 |
- #' * `num_pt_year`: (`numeric`)\cr time unit for desired output (in person-years).+ #' Compares bivariate responses between two groups in terms of odds ratios |
||
| 175 | +6 |
- #' @param person_years (`numeric`)\cr total person-years at risk.+ #' along with a confidence interval. |
||
| 176 | +7 |
- #' @param alpha (`numeric`)\cr two-sided alpha-level for confidence interval.+ #' |
||
| 177 | +8 |
- #' @param n_events (`integer`)\cr number of events observed.+ #' @inheritParams argument_convention |
||
| 178 | +9 |
#' |
||
| 179 | +10 |
- #' @return Estimated incidence rate `rate` and associated confidence interval `rate_ci`.+ #' @details This function uses either logistic regression for unstratified |
||
| 180 | +11 |
- #'+ #' analyses, or conditional logistic regression for stratified analyses. |
||
| 181 | +12 |
- #' @seealso [incidence_rate]+ #' The Wald confidence interval with the specified confidence level is |
||
| 182 | +13 |
- #'+ #' calculated. |
||
| 183 | +14 |
- #' @name h_incidence_rate+ #' |
||
| 184 | +15 |
- NULL+ #' @note For stratified analyses, there is currently no implementation for conditional |
||
| 185 | +16 |
-
+ #' likelihood confidence intervals, therefore the likelihood confidence interval is not |
||
| 186 | +17 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ #' yet available as an option. Besides, when `rsp` contains only responders or non-responders, |
||
| 187 | +18 |
- #' associated confidence interval based on the normal approximation for the+ #' then the result values will be `NA`, because no odds ratio estimation is possible. |
||
| 188 | +19 |
- #' incidence rate. Unit is one person-year.+ #' |
||
| 189 | +20 |
- #'+ #' @seealso Relevant helper function [h_odds_ratio()]. |
||
| 190 | +21 |
- #' @examples+ #' |
||
| 191 | +22 |
- #' h_incidence_rate_normal(200, 2)+ #' @name odds_ratio |
||
| 192 | +23 |
- #'+ NULL |
||
| 193 | +24 |
- #' @export+ |
||
| 194 | +25 |
- h_incidence_rate_normal <- function(person_years,+ #' @describeIn odds_ratio Statistics function which estimates the odds ratio |
||
| 195 | +26 |
- n_events,+ #' between a treatment and a control. A `variables` list with `arm` and `strata` |
||
| 196 | +27 |
- alpha = 0.05) {
+ #' variable names must be passed if a stratified analysis is required. |
||
| 197 | -1x | +|||
| 28 | +
- checkmate::assert_number(person_years)+ #' |
|||
| 198 | -1x | +|||
| 29 | +
- checkmate::assert_number(n_events)+ #' @inheritParams split_cols_by_groups |
|||
| 199 | -1x | +|||
| 30 | +
- assert_proportion_value(alpha)+ #' |
|||
| 200 | +31 |
-
+ #' @return |
||
| 201 | -1x | +|||
| 32 | +
- est <- n_events / person_years+ #' * `s_odds_ratio()` returns a named list with the statistics `or_ci` |
|||
| 202 | -1x | +|||
| 33 | +
- se <- sqrt(est / person_years)+ #' (containing `est`, `lcl`, and `ucl`) and `n_tot`. |
|||
| 203 | -1x | +|||
| 34 | +
- ci <- est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * se+ #' |
|||
| 204 | +35 |
-
+ #' @examples |
||
| 205 | -1x | +|||
| 36 | +
- list(rate = est, rate_ci = ci)+ #' set.seed(12) |
|||
| 206 | +37 |
- }+ #' dta <- data.frame( |
||
| 207 | +38 |
-
+ #' rsp = sample(c(TRUE, FALSE), 100, TRUE), |
||
| 208 | +39 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ #' grp = factor(rep(c("A", "B"), each = 50), levels = c("B", "A")),
|
||
| 209 | +40 |
- #' associated confidence interval based on the normal approximation for the+ #' strata = factor(sample(c("C", "D"), 100, TRUE))
|
||
| 210 | +41 |
- #' logarithm of the incidence rate. Unit is one person-year.+ #' ) |
||
| 211 | +42 |
#' |
||
| 212 | +43 |
- #' @examples+ #' # Unstratified analysis. |
||
| 213 | +44 |
- #' h_incidence_rate_normal_log(200, 2)+ #' s_odds_ratio( |
||
| 214 | +45 |
- #'+ #' df = subset(dta, grp == "A"), |
||
| 215 | +46 |
- #' @export+ #' .var = "rsp", |
||
| 216 | +47 |
- h_incidence_rate_normal_log <- function(person_years,+ #' .ref_group = subset(dta, grp == "B"), |
||
| 217 | +48 |
- n_events,+ #' .in_ref_col = FALSE, |
||
| 218 | +49 |
- alpha = 0.05) {
+ #' .df_row = dta |
||
| 219 | -5x | +|||
| 50 | +
- checkmate::assert_number(person_years)+ #' ) |
|||
| 220 | -5x | +|||
| 51 | +
- checkmate::assert_number(n_events)+ #' |
|||
| 221 | -5x | +|||
| 52 | +
- assert_proportion_value(alpha)+ #' # Stratified analysis. |
|||
| 222 | +53 |
-
+ #' s_odds_ratio( |
||
| 223 | -5x | +|||
| 54 | +
- rate_est <- n_events / person_years+ #' df = subset(dta, grp == "A"), |
|||
| 224 | -5x | +|||
| 55 | +
- rate_se <- sqrt(rate_est / person_years)+ #' .var = "rsp", |
|||
| 225 | -5x | +|||
| 56 | +
- lrate_est <- log(rate_est)+ #' .ref_group = subset(dta, grp == "B"), |
|||
| 226 | -5x | +|||
| 57 | +
- lrate_se <- rate_se / rate_est+ #' .in_ref_col = FALSE, |
|||
| 227 | -5x | +|||
| 58 | +
- ci <- exp(lrate_est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * lrate_se)+ #' .df_row = dta, |
|||
| 228 | +59 |
-
+ #' variables = list(arm = "grp", strata = "strata") |
||
| 229 | -5x | +|||
| 60 | +
- list(rate = rate_est, rate_ci = ci)+ #' ) |
|||
| 230 | +61 |
- }+ #' |
||
| 231 | +62 |
-
+ #' @export |
||
| 232 | +63 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ s_odds_ratio <- function(df, |
||
| 233 | +64 |
- #' associated exact confidence interval. Unit is one person-year.+ .var, |
||
| 234 | +65 |
- #'+ .ref_group, |
||
| 235 | +66 |
- #' @examples+ .in_ref_col, |
||
| 236 | +67 |
- #' h_incidence_rate_exact(200, 2)+ .df_row, |
||
| 237 | +68 |
- #'+ variables = list(arm = NULL, strata = NULL), |
||
| 238 | +69 |
- #' @export+ conf_level = 0.95, |
||
| 239 | +70 |
- h_incidence_rate_exact <- function(person_years,+ groups_list = NULL) {
|
||
| 240 | -+ | |||
| 71 | +65x |
- n_events,+ y <- list(or_ci = "", n_tot = "") |
||
| 241 | +72 |
- alpha = 0.05) {
+
|
||
| 242 | -1x | +73 | +65x |
- checkmate::assert_number(person_years)+ if (!.in_ref_col) {
|
| 243 | -1x | +74 | +65x |
- checkmate::assert_number(n_events)+ assert_proportion_value(conf_level) |
| 244 | -1x | +75 | +65x |
- assert_proportion_value(alpha)+ assert_df_with_variables(df, list(rsp = .var))+ |
+
| 76 | +65x | +
+ assert_df_with_variables(.ref_group, list(rsp = .var)) |
||
| 245 | +77 | |||
| 246 | -1x | +78 | +65x |
- est <- n_events / person_years+ if (is.null(variables$strata)) {
|
| 247 | -1x | +79 | +52x |
- lcl <- stats::qchisq(p = (alpha) / 2, df = 2 * n_events) / (2 * person_years)+ data <- data.frame( |
| 248 | -1x | +80 | +52x |
- ucl <- stats::qchisq(p = 1 - (alpha) / 2, df = 2 * n_events + 2) / (2 * person_years)+ rsp = c(.ref_group[[.var]], df[[.var]]), |
| 249 | -+ | |||
| 81 | +52x |
-
+ grp = factor( |
||
| 250 | -1x | +82 | +52x |
- list(rate = est, rate_ci = c(lcl, ucl))+ rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
|
| 251 | -+ | |||
| 83 | +52x |
- }+ levels = c("ref", "Not-ref")
|
||
| 252 | +84 |
-
+ ) |
||
| 253 | +85 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ ) |
||
| 254 | -+ | |||
| 86 | +52x |
- #' associated `Byar`'s confidence interval. Unit is one person-year.+ y <- or_glm(data, conf_level = conf_level) |
||
| 255 | +87 |
- #'+ } else {
|
||
| 256 | -+ | |||
| 88 | +13x |
- #' @examples+ assert_df_with_variables(.df_row, c(list(rsp = .var), variables)) |
||
| 257 | +89 |
- #' h_incidence_rate_byar(200, 2)+ |
||
| 258 | +90 |
- #'+ # The group variable prepared for clogit must be synchronised with combination groups definition. |
||
| 259 | -+ | |||
| 91 | +13x |
- #' @export+ if (is.null(groups_list)) {
|
||
| 260 | -+ | |||
| 92 | +12x |
- h_incidence_rate_byar <- function(person_years,+ ref_grp <- as.character(unique(.ref_group[[variables$arm]]))+ |
+ ||
| 93 | +12x | +
+ trt_grp <- as.character(unique(df[[variables$arm]]))+ |
+ ||
| 94 | +12x | +
+ grp <- stats::relevel(factor(.df_row[[variables$arm]]), ref = ref_grp) |
||
| 261 | +95 |
- n_events,+ } else {
|
||
| 262 | +96 |
- alpha = 0.05) {
+ # If more than one level in reference col.+ |
+ ||
| 97 | +1x | +
+ reference <- as.character(unique(.ref_group[[variables$arm]]))+ |
+ ||
| 98 | +1x | +
+ grp_ref_flag <- vapply(+ |
+ ||
| 99 | +1x | +
+ X = groups_list, |
||
| 263 | +100 | 1x |
- checkmate::assert_number(person_years)+ FUN.VALUE = TRUE, |
|
| 264 | +101 | 1x |
- checkmate::assert_number(n_events)+ FUN = function(x) all(reference %in% x)+ |
+ |
| 102 | ++ |
+ ) |
||
| 265 | +103 | 1x |
- assert_proportion_value(alpha)+ ref_grp <- names(groups_list)[grp_ref_flag] |
|
| 266 | +104 | |||
| 105 | ++ |
+ # If more than one level in treatment col.+ |
+ ||
| 267 | +106 | 1x |
- est <- n_events / person_years+ treatment <- as.character(unique(df[[variables$arm]])) |
|
| 268 | +107 | 1x |
- seg_1 <- n_events + 0.5+ grp_trt_flag <- vapply( |
|
| 269 | +108 | 1x |
- seg_2 <- 1 - 1 / (9 * (n_events + 0.5))+ X = groups_list, |
|
| 270 | +109 | 1x |
- seg_3 <- stats::qnorm(1 - alpha / 2) * sqrt(1 / (n_events + 0.5)) / 3+ FUN.VALUE = TRUE, |
|
| 271 | +110 | 1x |
- lcl <- seg_1 * ((seg_2 - seg_3)^3) / person_years+ FUN = function(x) all(treatment %in% x)+ |
+ |
| 111 | ++ |
+ ) |
||
| 272 | +112 | 1x |
- ucl <- seg_1 * ((seg_2 + seg_3) ^ 3) / person_years # styler: off+ trt_grp <- names(groups_list)[grp_trt_flag] |
|
| 273 | +113 | |||
| 274 | +114 | 1x |
- list(rate = est, rate_ci = c(lcl, ucl))+ grp <- combine_levels(.df_row[[variables$arm]], levels = reference, new_level = ref_grp)+ |
+ |
| 115 | +1x | +
+ grp <- combine_levels(grp, levels = treatment, new_level = trt_grp) |
||
| 275 | +116 |
- }+ } |
||
| 276 | +117 | |||
| 277 | +118 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ # The reference level in `grp` must be the same as in the `rtables` column split. |
||
| 278 | -+ | |||
| 119 | +13x |
- #' associated confidence interval.+ data <- data.frame( |
||
| 279 | -+ | |||
| 120 | +13x |
- #'+ rsp = .df_row[[.var]], |
||
| 280 | -+ | |||
| 121 | +13x |
- #'+ grp = grp,+ |
+ ||
| 122 | +13x | +
+ strata = interaction(.df_row[variables$strata]) |
||
| 281 | +123 |
- #' @keywords internal+ )+ |
+ ||
| 124 | +13x | +
+ y_all <- or_clogit(data, conf_level = conf_level)+ |
+ ||
| 125 | +13x | +
+ checkmate::assert_string(trt_grp)+ |
+ ||
| 126 | +13x | +
+ checkmate::assert_subset(trt_grp, names(y_all$or_ci))+ |
+ ||
| 127 | +12x | +
+ y$or_ci <- y_all$or_ci[[trt_grp]]+ |
+ ||
| 128 | +12x | +
+ y$n_tot <- y_all$n_tot |
||
| 282 | +129 |
- h_incidence_rate <- function(person_years,+ } |
||
| 283 | +130 |
- n_events,+ } |
||
| 284 | +131 |
- control = control_incidence_rate()) {
+
|
||
| 285 | -4x | +132 | +64x |
- alpha <- 1 - control$conf_level+ y$or_ci <- formatters::with_label( |
| 286 | -4x | +133 | +64x |
- est <- switch(control$conf_type,+ x = y$or_ci, |
| 287 | -4x | +134 | +64x |
- normal = h_incidence_rate_normal(person_years, n_events, alpha),+ label = paste0("Odds Ratio (", 100 * conf_level, "% CI)")
+ |
+
| 135 | ++ |
+ )+ |
+ ||
| 136 | ++ | + | ||
| 288 | -4x | +137 | +64x |
- normal_log = h_incidence_rate_normal_log(person_years, n_events, alpha),+ y$n_tot <- formatters::with_label( |
| 289 | -4x | +138 | +64x |
- exact = h_incidence_rate_exact(person_years, n_events, alpha),+ x = y$n_tot, |
| 290 | -4x | +139 | +64x |
- byar = h_incidence_rate_byar(person_years, n_events, alpha)+ label = "Total n" |
| 291 | +140 |
) |
||
| 292 | +141 | |||
| 293 | -4x | +142 | +64x |
- num_pt_year <- control$num_pt_year+ y |
| 294 | -4x | +|||
| 143 | +
- list(+ } |
|||
| 295 | -4x | +|||
| 144 | +
- rate = est$rate * num_pt_year,+ |
|||
| 296 | -4x | +|||
| 145 | +
- rate_ci = est$rate_ci * num_pt_year+ #' @describeIn odds_ratio Formatted analysis function which is used as `afun` in `estimate_odds_ratio()`. |
|||
| 297 | +146 |
- )+ #' |
||
| 298 | +147 |
- }+ #' @return |
| 1 | +148 |
- #' Cumulative Counts with Thresholds+ #' * `a_odds_ratio()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 2 | +149 |
#' |
||
| 3 | +150 |
- #' @description `r lifecycle::badge("stable")`
+ #' @examples |
||
| 4 | +151 |
- #'+ #' a_odds_ratio( |
||
| 5 | +152 |
- #' Summarize cumulative counts of a (`numeric`) vector that is less than, less or equal to,+ #' df = subset(dta, grp == "A"), |
||
| 6 | +153 |
- #' greater than, or greater or equal to user-specific thresholds.+ #' .var = "rsp", |
||
| 7 | +154 |
- #'+ #' .ref_group = subset(dta, grp == "B"), |
||
| 8 | +155 |
- #' @inheritParams h_count_cumulative+ #' .in_ref_col = FALSE, |
||
| 9 | +156 |
- #' @inheritParams argument_convention+ #' .df_row = dta |
||
| 10 | +157 |
- #'+ #' ) |
||
| 11 | +158 |
- #' @seealso Relevant helper function [h_count_cumulative()], and descriptive function [d_count_cumulative()].+ #' |
||
| 12 | +159 |
- #'+ #' @export |
||
| 13 | +160 |
- #' @name count_cumulative+ a_odds_ratio <- make_afun( |
||
| 14 | +161 |
- NULL+ s_odds_ratio, |
||
| 15 | +162 |
-
+ .formats = c(or_ci = "xx.xx (xx.xx - xx.xx)"), |
||
| 16 | +163 |
- #' Helper Function for [s_count_cumulative()]+ .indent_mods = c(or_ci = 1L) |
||
| 17 | +164 |
- #'+ ) |
||
| 18 | +165 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 19 | +166 |
- #'+ #' @describeIn odds_ratio Layout-creating function which can take statistics function arguments |
||
| 20 | +167 |
- #' Helper function to calculate count and fraction of `x` values in the lower or upper tail given a threshold.+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 21 | +168 |
#' |
||
| 22 | +169 |
- #' @inheritParams argument_convention+ #' @param ... arguments passed to `s_odds_ratio()`. |
||
| 23 | +170 |
- #' @param threshold (`number`)\cr a cutoff value as threshold to count values of `x`.+ #' |
||
| 24 | +171 |
- #' @param lower_tail (`logical`)\cr whether to count lower tail, default is `TRUE`.+ #' @return |
||
| 25 | +172 |
- #' @param include_eq (`logical`)\cr whether to include value equal to the `threshold` in+ #' * `estimate_odds_ratio()` returns a layout object suitable for passing to further layouting functions, |
||
| 26 | +173 |
- #' count, default is `TRUE`.+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 27 | +174 |
- #' @param .N_col (`count`)\cr denominator for fraction calculation.+ #' the statistics from `s_odds_ratio()` to the table layout. |
||
| 28 | +175 |
#' |
||
| 29 | +176 |
- #' @return A named vector with items:+ #' @examples |
||
| 30 | +177 |
- #' * `count`: the count of values less than, less or equal to, greater than, or greater or equal to a threshold+ #' dta <- data.frame( |
||
| 31 | +178 |
- #' of user specification.+ #' rsp = sample(c(TRUE, FALSE), 100, TRUE), |
||
| 32 | +179 |
- #' * `fraction`: the fraction of the count.+ #' grp = factor(rep(c("A", "B"), each = 50))
|
||
| 33 | +180 | ++ |
+ #' )+ |
+ |
| 181 |
#' |
|||
| 34 | +182 |
- #' @seealso [count_cumulative]+ #' l <- basic_table() %>% |
||
| 35 | +183 |
- #'+ #' split_cols_by(var = "grp", ref_group = "B") %>% |
||
| 36 | +184 |
- #' @examples+ #' estimate_odds_ratio(vars = "rsp") |
||
| 37 | +185 |
- #' set.seed(1, kind = "Mersenne-Twister")+ #' |
||
| 38 | +186 |
- #' x <- c(sample(1:10, 10), NA)+ #' build_table(l, df = dta) |
||
| 39 | +187 |
- #' .N_col <- length(x)+ #' |
||
| 40 | +188 |
- #' h_count_cumulative(x, 5, .N_col = .N_col)+ #' @export |
||
| 41 | +189 |
- #' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na.rm = FALSE, .N_col = .N_col)+ estimate_odds_ratio <- function(lyt, |
||
| 42 | +190 |
- #' h_count_cumulative(x, 0, lower_tail = FALSE, .N_col = .N_col)+ vars, |
||
| 43 | +191 |
- #' h_count_cumulative(x, 100, lower_tail = FALSE, .N_col = .N_col)+ na_str = NA_character_, |
||
| 44 | +192 |
- #'+ nested = TRUE, |
||
| 45 | +193 |
- #' @export+ ..., |
||
| 46 | +194 |
- h_count_cumulative <- function(x,+ show_labels = "hidden", |
||
| 47 | +195 |
- threshold,+ table_names = vars, |
||
| 48 | +196 |
- lower_tail = TRUE,+ .stats = "or_ci", |
||
| 49 | +197 |
- include_eq = TRUE,+ .formats = NULL, |
||
| 50 | +198 |
- na.rm = TRUE, # nolint+ .labels = NULL, |
||
| 51 | +199 |
- .N_col) { # nolint
+ .indent_mods = NULL) {
|
||
| 52 | -20x | +200 | +3x |
- checkmate::assert_numeric(x)+ afun <- make_afun( |
| 53 | -20x | +201 | +3x |
- checkmate::assert_numeric(threshold)+ a_odds_ratio, |
| 54 | -20x | +202 | +3x |
- checkmate::assert_numeric(.N_col)+ .stats = .stats, |
| 55 | -20x | +203 | +3x |
- checkmate::assert_flag(lower_tail)+ .formats = .formats, |
| 56 | -20x | +204 | +3x |
- checkmate::assert_flag(include_eq)+ .labels = .labels, |
| 57 | -20x | +205 | +3x |
- checkmate::assert_flag(na.rm)+ .indent_mods = .indent_mods |
| 58 | +206 |
-
+ ) |
||
| 59 | -20x | +|||
| 207 | +
- is_keep <- if (na.rm) !is.na(x) else rep(TRUE, length(x))+ |
|||
| 60 | -20x | +208 | +3x |
- count <- if (lower_tail && include_eq) {
+ analyze( |
| 61 | -7x | +209 | +3x |
- length(x[is_keep & x <= threshold])+ lyt, |
| 62 | -20x | +210 | +3x |
- } else if (lower_tail && !include_eq) {
+ vars, |
| 63 | -! | +|||
| 211 | +3x |
- length(x[is_keep & x < threshold])+ afun = afun, |
||
| 64 | -20x | +212 | +3x |
- } else if (!lower_tail && include_eq) {
+ na_str = na_str, |
| 65 | -6x | +213 | +3x |
- length(x[is_keep & x >= threshold])+ nested = nested, |
| 66 | -20x | +214 | +3x |
- } else if (!lower_tail && !include_eq) {
+ extra_args = list(...), |
| 67 | -7x | +215 | +3x |
- length(x[is_keep & x > threshold])+ show_labels = show_labels, |
| 68 | -+ | |||
| 216 | +3x |
- }+ table_names = table_names |
||
| 69 | +217 | - - | -||
| 70 | -20x | -
- result <- c(count = count, fraction = count / .N_col)- |
- ||
| 71 | -20x | -
- result+ ) |
||
| 72 | +218 |
} |
||
| 73 | +219 | |||
| 74 | +220 |
- #' Description of Cumulative Count+ #' Helper Functions for Odds Ratio Estimation |
||
| 75 | +221 |
#' |
||
| 76 | +222 |
#' @description `r lifecycle::badge("stable")`
|
||
| 77 | +223 |
#' |
||
| 78 | +224 |
- #' This is a helper function that describes the analysis in [s_count_cumulative()].+ #' Functions to calculate odds ratios in [estimate_odds_ratio()]. |
||
| 79 | +225 |
#' |
||
| 80 | +226 |
- #' @inheritParams h_count_cumulative+ #' @inheritParams argument_convention |
||
| 81 | +227 |
- #'+ #' @param data (`data.frame`)\cr data frame containing at least the variables `rsp` and `grp`, and optionally |
||
| 82 | +228 |
- #' @return Labels for [s_count_cumulative()].+ #' `strata` for [or_clogit()]. |
||
| 83 | +229 |
#' |
||
| 84 | +230 |
- #' @export+ #' @return A named `list` of elements `or_ci` and `n_tot`. |
||
| 85 | +231 |
- d_count_cumulative <- function(threshold, lower_tail, include_eq) {
- |
- ||
| 86 | -18x | -
- checkmate::assert_numeric(threshold)- |
- ||
| 87 | -18x | -
- lg <- if (lower_tail) "<" else ">"+ #' |
||
| 88 | -18x | +|||
| 232 | +
- eq <- if (include_eq) "=" else ""+ #' @seealso [odds_ratio] |
|||
| 89 | -18x | +|||
| 233 | +
- paste0(lg, eq, " ", threshold)+ #' |
|||
| 90 | +234 |
- }+ #' @name h_odds_ratio |
||
| 91 | +235 |
-
+ NULL |
||
| 92 | +236 |
- #' @describeIn count_cumulative Statistics function that produces a named list given a numeric vector of thresholds.+ |
||
| 93 | +237 |
- #'+ #' @describeIn h_odds_ratio Estimates the odds ratio based on [stats::glm()]. Note that there must be |
||
| 94 | +238 |
- #' @param thresholds (`numeric`)\cr vector of cutoff value for the counts.+ #' exactly 2 groups in `data` as specified by the `grp` variable. |
||
| 95 | +239 |
#' |
||
| 96 | +240 |
- #' @return+ #' @examples |
||
| 97 | +241 |
- #' * `s_count_cumulative()` returns a named list of `count_fraction`s: a list with each `thresholds` value as a+ #' # Data with 2 groups. |
||
| 98 | +242 |
- #' component, each component containing a vector for the count and fraction.+ #' data <- data.frame( |
||
| 99 | +243 |
- #'+ #' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1)), |
||
| 100 | +244 |
- #' @keywords internal+ #' grp = letters[c(1, 1, 1, 2, 2, 2, 1, 2)], |
||
| 101 | +245 |
- s_count_cumulative <- function(x,+ #' strata = letters[c(1, 2, 1, 2, 2, 2, 1, 2)], |
||
| 102 | +246 |
- thresholds,+ #' stringsAsFactors = TRUE |
||
| 103 | +247 |
- lower_tail = TRUE,+ #' ) |
||
| 104 | +248 |
- include_eq = TRUE,+ #' |
||
| 105 | +249 |
- .N_col, # nolint+ #' # Odds ratio based on glm. |
||
| 106 | +250 |
- ...) {
+ #' or_glm(data, conf_level = 0.95) |
||
| 107 | -5x | +|||
| 251 | +
- checkmate::assert_numeric(thresholds, min.len = 1, any.missing = FALSE)+ #' |
|||
| 108 | +252 |
-
+ #' @export |
||
| 109 | -5x | +|||
| 253 | +
- count_fraction_list <- Map(function(thres) {
+ or_glm <- function(data, conf_level) {
|
|||
| 110 | -10x | +254 | +55x |
- result <- h_count_cumulative(x, thres, lower_tail, include_eq, .N_col = .N_col, ...)+ checkmate::assert_logical(data$rsp) |
| 111 | -10x | +255 | +55x |
- label <- d_count_cumulative(thres, lower_tail, include_eq)+ assert_proportion_value(conf_level) |
| 112 | -10x | +256 | +55x |
- formatters::with_label(result, label)+ assert_df_with_variables(data, list(rsp = "rsp", grp = "grp")) |
| 113 | -5x | +257 | +55x |
- }, thresholds)+ checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
|
| 114 | +258 | |||
| 115 | -5x | +259 | +55x |
- names(count_fraction_list) <- thresholds+ data$grp <- as_factor_keep_attributes(data$grp) |
| 116 | -5x | +260 | +55x |
- list(count_fraction = count_fraction_list)+ assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2) |
| 117 | -+ | |||
| 261 | +55x |
- }+ formula <- stats::as.formula("rsp ~ grp")
|
||
| 118 | -+ | |||
| 262 | +55x |
-
+ model_fit <- stats::glm( |
||
| 119 | -+ | |||
| 263 | +55x |
- #' @describeIn count_cumulative Formatted analysis function which is used as `afun`+ formula = formula, data = data, |
||
| 120 | -+ | |||
| 264 | +55x |
- #' in `count_cumulative()`.+ family = stats::binomial(link = "logit") |
||
| 121 | +265 |
- #'+ ) |
||
| 122 | +266 |
- #' @return+ |
||
| 123 | +267 |
- #' * `a_count_cumulative()` returns the corresponding list with formatted [rtables::CellValue()].+ # Note that here we need to discard the intercept. |
||
| 124 | -+ | |||
| 268 | +55x |
- #'+ or <- exp(stats::coef(model_fit)[-1]) |
||
| 125 | -+ | |||
| 269 | +55x |
- #' @keywords internal+ or_ci <- exp( |
||
| 126 | -+ | |||
| 270 | +55x |
- a_count_cumulative <- make_afun(+ stats::confint.default(model_fit, level = conf_level)[-1, , drop = FALSE] |
||
| 127 | +271 |
- s_count_cumulative,+ ) |
||
| 128 | +272 |
- .formats = c(count_fraction = format_count_fraction)+ |
||
| 129 | -+ | |||
| 273 | +55x |
- )+ values <- stats::setNames(c(or, or_ci), c("est", "lcl", "ucl"))
|
||
| 130 | -+ | |||
| 274 | +55x |
-
+ n_tot <- stats::setNames(nrow(model_fit$model), "n_tot") |
||
| 131 | +275 |
- #' @describeIn count_cumulative Layout-creating function which can take statistics function arguments+ |
||
| 132 | -+ | |||
| 276 | +55x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ list(or_ci = values, n_tot = n_tot) |
||
| 133 | +277 |
- #'+ } |
||
| 134 | +278 |
- #' @return+ |
||
| 135 | +279 |
- #' * `count_cumulative()` returns a layout object suitable for passing to further layouting functions,+ #' @describeIn h_odds_ratio estimates the odds ratio based on [survival::clogit()]. This is done for |
||
| 136 | +280 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' the whole data set including all groups, since the results are not the same as when doing |
||
| 137 | +281 |
- #' the statistics from `s_count_cumulative()` to the table layout.+ #' pairwise comparisons between the groups. |
||
| 138 | +282 |
#' |
||
| 139 | +283 |
#' @examples |
||
| 140 | -- |
- #' basic_table() %>%- |
- ||
| 141 | +284 |
- #' split_cols_by("ARM") %>%
+ #' # Data with 3 groups. |
||
| 142 | +285 |
- #' add_colcounts() %>%+ #' data <- data.frame( |
||
| 143 | +286 |
- #' count_cumulative(+ #' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0)), |
||
| 144 | +287 |
- #' vars = "AGE",+ #' grp = letters[c(1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3)], |
||
| 145 | +288 |
- #' thresholds = c(40, 60)+ #' strata = LETTERS[c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)], |
||
| 146 | +289 |
- #' ) %>%+ #' stringsAsFactors = TRUE |
||
| 147 | +290 |
- #' build_table(tern_ex_adsl)+ #' ) |
||
| 148 | +291 |
#' |
||
| 149 | +292 |
- #' @export+ #' # Odds ratio based on stratified estimation by conditional logistic regression. |
||
| 150 | +293 |
- count_cumulative <- function(lyt,+ #' or_clogit(data, conf_level = 0.95) |
||
| 151 | +294 |
- vars,+ #' |
||
| 152 | +295 |
- var_labels = vars,+ #' @export |
||
| 153 | +296 |
- show_labels = "visible",+ or_clogit <- function(data, conf_level) {
|
||
| 154 | -+ | |||
| 297 | +16x |
- nested = TRUE,+ checkmate::assert_logical(data$rsp) |
||
| 155 | -+ | |||
| 298 | +16x |
- ...,+ assert_proportion_value(conf_level) |
||
| 156 | -+ | |||
| 299 | +16x |
- table_names = vars,+ assert_df_with_variables(data, list(rsp = "rsp", grp = "grp", strata = "strata")) |
||
| 157 | -+ | |||
| 300 | +16x |
- .stats = NULL,+ checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
|
||
| 158 | -+ | |||
| 301 | +16x |
- .formats = NULL,+ checkmate::assert_multi_class(data$strata, classes = c("factor", "character"))
|
||
| 159 | +302 |
- .labels = NULL,+ |
||
| 160 | -+ | |||
| 303 | +16x |
- .indent_mods = NULL) {
+ data$grp <- as_factor_keep_attributes(data$grp) |
||
| 161 | -2x | +304 | +16x |
- afun <- make_afun(+ data$strata <- as_factor_keep_attributes(data$strata) |
| 162 | -2x | +|||
| 305 | +
- a_count_cumulative,+ |
|||
| 163 | -2x | +|||
| 306 | +
- .stats = .stats,+ # Deviation from convention: `survival::strata` must be simply `strata`. |
|||
| 164 | -2x | +307 | +16x |
- .formats = .formats,+ formula <- stats::as.formula("rsp ~ grp + strata(strata)")
|
| 165 | -2x | +308 | +16x |
- .labels = .labels,+ model_fit <- clogit_with_tryCatch(formula = formula, data = data) |
| 166 | -2x | +|||
| 309 | +
- .indent_mods = .indent_mods,+ |
|||
| 167 | -2x | +|||
| 310 | +
- .ungroup_stats = "count_fraction"+ # Create a list with one set of OR estimates and CI per coefficient, i.e. |
|||
| 168 | +311 |
- )+ # comparison of one group vs. the reference group. |
||
| 169 | -2x | +312 | +16x |
- analyze(+ coef_est <- stats::coef(model_fit) |
| 170 | -2x | +313 | +16x |
- lyt,+ ci_est <- stats::confint(model_fit, level = conf_level) |
| 171 | -2x | +314 | +16x |
- vars,+ or_ci <- list() |
| 172 | -2x | +315 | +16x |
- afun = afun,+ for (coef_name in names(coef_est)) {
|
| 173 | -2x | +316 | +18x |
- table_names = table_names,+ grp_name <- gsub("^grp", "", x = coef_name)
|
| 174 | -2x | +317 | +18x |
- var_labels = var_labels,+ or_ci[[grp_name]] <- stats::setNames( |
| 175 | -2x | +318 | +18x |
- show_labels = show_labels,+ object = exp(c(coef_est[coef_name], ci_est[coef_name, , drop = TRUE])), |
| 176 | -2x | +319 | +18x |
- nested = nested,+ nm = c("est", "lcl", "ucl")
|
| 177 | -2x | +|||
| 320 | +
- extra_args = list(...)+ ) |
|||
| 178 | +321 |
- )+ }+ |
+ ||
| 322 | +16x | +
+ list(or_ci = or_ci, n_tot = c(n_tot = model_fit$n)) |
||
| 179 | +323 |
}@@ -140348,14 +140090,14 @@ tern coverage - 94.83% |
| 1 |
- #' Subgroup Treatment Effect Pattern (STEP) Fit for Survival Outcome+ #' Control Function for Logistic Regression Model Fitting |
||
| 5 |
- #' This fits the Subgroup Treatment Effect Pattern models for a survival outcome. The treatment arm+ #' This is an auxiliary function for controlling arguments for logistic regression models. |
||
| 6 |
- #' variable must have exactly 2 levels, where the first one is taken as reference and the estimated+ #' `conf_level` refers to the confidence level used for the Odds Ratio CIs. |
||
| 7 |
- #' hazard ratios are for the comparison of the second level vs. the first one.+ #' |
||
| 8 |
- #'+ #' @inheritParams argument_convention |
||
| 9 |
- #' The model which is fit is:+ #' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`. |
||
| 10 |
- #'+ #' This will be used when fitting the logistic regression model on the left hand side of the formula. |
||
| 11 |
- #' `Surv(time, event) ~ arm * poly(biomarker, degree) + covariates + strata(strata)`+ #' Note that the evaluated expression should result in either a logical vector or a factor with 2 |
||
| 12 |
- #'+ #' levels. By default this is just `"response"` such that the original response variable is used |
||
| 13 |
- #' where `degree` is specified by `control_step()`.+ #' and not modified further. |
||
| 15 |
- #' @inheritParams argument_convention+ #' @return A list of components with the same names as the arguments. |
||
| 16 |
- #' @param variables (named `list` of `character`)\cr list of analysis variables: needs `time`, `event`,+ #' |
||
| 17 |
- #' `arm`, `biomarker`, and optional `covariates` and `strata`.+ #' @examples |
||
| 18 |
- #' @param control (named `list`)\cr combined control list from [control_step()] and [control_coxph()].+ #' # Standard options. |
||
| 19 |
- #'+ #' control_logistic() |
||
| 20 |
- #' @return A matrix of class `step`. The first part of the columns describe the subgroup intervals used+ #' |
||
| 21 |
- #' for the biomarker variable, including where the center of the intervals are and their bounds. The+ #' # Modify confidence level. |
||
| 22 |
- #' second part of the columns contain the estimates for the treatment arm comparison.+ #' control_logistic(conf_level = 0.9) |
||
| 24 |
- #' @note For the default degree 0 the `biomarker` variable is not included in the model.+ #' # Use a different response definition. |
||
| 25 |
- #'+ #' control_logistic(response_definition = "I(response %in% c('CR', 'PR'))")
|
||
| 26 |
- #' @seealso [control_step()] and [control_coxph()] for the available customization options.+ #' |
||
| 27 |
- #'+ #' @export |
||
| 28 |
- #' @examples+ control_logistic <- function(response_definition = "response", |
||
| 29 |
- #' # Testing dataset with just two treatment arms.+ conf_level = 0.95) {
|
||
| 30 | -+ | 28x |
- #' library(dplyr)+ checkmate::assert_true(grepl("response", response_definition))
|
| 31 | -+ | 27x |
- #'+ checkmate::assert_string(response_definition) |
| 32 | -+ | 27x |
- #' adtte_f <- tern_ex_adtte %>%+ assert_proportion_value(conf_level) |
| 33 | -+ | 26x |
- #' filter(+ list( |
| 34 | -+ | 26x |
- #' PARAMCD == "OS",+ response_definition = response_definition, |
| 35 | -+ | 26x |
- #' ARM %in% c("B: Placebo", "A: Drug X")
+ conf_level = conf_level |
| 36 |
- #' ) %>%+ ) |
||
| 37 |
- #' mutate(+ } |
| 38 | +1 |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ #' Cumulative Counts with Thresholds |
||
| 39 | +2 |
- #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")),+ #' |
||
| 40 | +3 |
- #' is_event = CNSR == 0+ #' @description `r lifecycle::badge("stable")`
|
||
| 41 | +4 |
- #' )+ #' |
||
| 42 | +5 |
- #' labels <- c("ARM" = "Treatment Arm", "is_event" = "Event Flag")
+ #' Summarize cumulative counts of a (`numeric`) vector that is less than, less or equal to, |
||
| 43 | +6 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ #' greater than, or greater or equal to user-specific thresholds. |
||
| 44 | +7 |
#' |
||
| 45 | +8 |
- #' variables <- list(+ #' @inheritParams h_count_cumulative |
||
| 46 | +9 |
- #' arm = "ARM",+ #' @inheritParams argument_convention |
||
| 47 | +10 |
- #' biomarker = "BMRKR1",+ #' |
||
| 48 | +11 |
- #' covariates = c("AGE", "BMRKR2"),
+ #' @seealso Relevant helper function [h_count_cumulative()], and descriptive function [d_count_cumulative()]. |
||
| 49 | +12 |
- #' event = "is_event",+ #' |
||
| 50 | +13 |
- #' time = "AVAL"+ #' @name count_cumulative |
||
| 51 | +14 |
- #' )+ NULL |
||
| 52 | +15 |
- #'+ |
||
| 53 | +16 |
- #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup.+ #' Helper Function for [s_count_cumulative()] |
||
| 54 | +17 |
- #' step_matrix <- fit_survival_step(+ #' |
||
| 55 | +18 |
- #' variables = variables,+ #' @description `r lifecycle::badge("stable")`
|
||
| 56 | +19 |
- #' data = adtte_f+ #' |
||
| 57 | +20 |
- #' )+ #' Helper function to calculate count and fraction of `x` values in the lower or upper tail given a threshold. |
||
| 58 | +21 |
- #' dim(step_matrix)+ #' |
||
| 59 | +22 |
- #' head(step_matrix)+ #' @inheritParams argument_convention |
||
| 60 | +23 |
- #'+ #' @param threshold (`number`)\cr a cutoff value as threshold to count values of `x`. |
||
| 61 | +24 |
- #' # Specify different polynomial degree for the biomarker interaction to use more flexible local+ #' @param lower_tail (`logical`)\cr whether to count lower tail, default is `TRUE`. |
||
| 62 | +25 |
- #' # models. Or specify different Cox regression options.+ #' @param include_eq (`logical`)\cr whether to include value equal to the `threshold` in |
||
| 63 | +26 |
- #' step_matrix2 <- fit_survival_step(+ #' count, default is `TRUE`. |
||
| 64 | +27 |
- #' variables = variables,+ #' @param .N_col (`count`)\cr denominator for fraction calculation. |
||
| 65 | +28 |
- #' data = adtte_f,+ #' |
||
| 66 | +29 |
- #' control = c(control_coxph(conf_level = 0.9), control_step(degree = 2))+ #' @return A named vector with items: |
||
| 67 | +30 |
- #' )+ #' * `count`: the count of values less than, less or equal to, greater than, or greater or equal to a threshold |
||
| 68 | +31 |
- #'+ #' of user specification. |
||
| 69 | +32 |
- #' # Use a global model with cubic interaction and only 5 points.+ #' * `fraction`: the fraction of the count. |
||
| 70 | +33 |
- #' step_matrix3 <- fit_survival_step(+ #' |
||
| 71 | +34 |
- #' variables = variables,+ #' @seealso [count_cumulative] |
||
| 72 | +35 |
- #' data = adtte_f,+ #' |
||
| 73 | +36 |
- #' control = c(control_coxph(), control_step(bandwidth = NULL, degree = 3, num_points = 5L))+ #' @examples |
||
| 74 | +37 |
- #' )+ #' set.seed(1, kind = "Mersenne-Twister") |
||
| 75 | +38 |
- #'+ #' x <- c(sample(1:10, 10), NA) |
||
| 76 | +39 |
- #' @export+ #' .N_col <- length(x) |
||
| 77 | +40 |
- fit_survival_step <- function(variables,+ #' h_count_cumulative(x, 5, .N_col = .N_col) |
||
| 78 | +41 |
- data,+ #' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na.rm = FALSE, .N_col = .N_col) |
||
| 79 | +42 |
- control = c(control_step(), control_coxph())) {
- |
- ||
| 80 | -4x | -
- checkmate::assert_list(control)- |
- ||
| 81 | -4x | -
- assert_df_with_variables(data, variables)- |
- ||
| 82 | -4x | -
- data <- data[!is.na(data[[variables$biomarker]]), ]- |
- ||
| 83 | -4x | -
- window_sel <- h_step_window(x = data[[variables$biomarker]], control = control)- |
- ||
| 84 | -4x | -
- interval_center <- window_sel$interval[, "Interval Center"]- |
- ||
| 85 | -4x | -
- form <- h_step_survival_formula(variables = variables, control = control)- |
- ||
| 86 | -4x | -
- estimates <- if (is.null(control$bandwidth)) {
- |
- ||
| 87 | -1x | -
- h_step_survival_est(- |
- ||
| 88 | -1x | -
- formula = form,+ #' h_count_cumulative(x, 0, lower_tail = FALSE, .N_col = .N_col) |
||
| 89 | -1x | +|||
| 43 | +
- data = data,+ #' h_count_cumulative(x, 100, lower_tail = FALSE, .N_col = .N_col) |
|||
| 90 | -1x | +|||
| 44 | +
- variables = variables,+ #' |
|||
| 91 | -1x | +|||
| 45 | +
- x = interval_center,+ #' @export |
|||
| 92 | -1x | +|||
| 46 | +
- control = control+ h_count_cumulative <- function(x, |
|||
| 93 | +47 |
- )+ threshold, |
||
| 94 | +48 |
- } else {
+ lower_tail = TRUE, |
||
| 95 | -3x | +|||
| 49 | +
- tmp <- mapply(+ include_eq = TRUE, |
|||
| 96 | -3x | +|||
| 50 | +
- FUN = h_step_survival_est,+ na.rm = TRUE, # nolint |
|||
| 97 | -3x | +|||
| 51 | +
- x = interval_center,+ .N_col) { # nolint
|
|||
| 98 | -3x | +52 | +20x |
- subset = as.list(as.data.frame(window_sel$sel)),+ checkmate::assert_numeric(x) |
| 99 | -3x | +53 | +20x |
- MoreArgs = list(+ checkmate::assert_numeric(threshold) |
| 100 | -3x | +54 | +20x |
- formula = form,+ checkmate::assert_numeric(.N_col) |
| 101 | -3x | +55 | +20x |
- data = data,+ checkmate::assert_flag(lower_tail) |
| 102 | -3x | +56 | +20x |
- variables = variables,+ checkmate::assert_flag(include_eq) |
| 103 | -3x | -
- control = control- |
- ||
| 104 | -- |
- )- |
- ||
| 105 | -+ | 57 | +20x |
- )+ checkmate::assert_flag(na.rm) |
| 106 | +58 |
- # Maybe we find a more elegant solution than this.+ |
||
| 107 | -3x | +59 | +20x |
- rownames(tmp) <- c("n", "events", "loghr", "se", "ci_lower", "ci_upper")
+ is_keep <- if (na.rm) !is.na(x) else rep(TRUE, length(x)) |
| 108 | -3x | +60 | +20x |
- t(tmp)+ count <- if (lower_tail && include_eq) {
|
| 109 | -+ | |||
| 61 | +7x |
- }+ length(x[is_keep & x <= threshold]) |
||
| 110 | -4x | +62 | +20x |
- result <- cbind(window_sel$interval, estimates)+ } else if (lower_tail && !include_eq) {
|
| 111 | -4x | +|||
| 63 | +! |
- structure(+ length(x[is_keep & x < threshold]) |
||
| 112 | -4x | +64 | +20x |
- result,+ } else if (!lower_tail && include_eq) {
|
| 113 | -4x | +65 | +6x |
- class = c("step", "matrix"),
+ length(x[is_keep & x >= threshold]) |
| 114 | -4x | +66 | +20x |
- variables = variables,+ } else if (!lower_tail && !include_eq) {
|
| 115 | -4x | +67 | +7x |
- control = control+ length(x[is_keep & x > threshold]) |
| 116 | +68 |
- )+ } |
||
| 117 | +69 |
- }+ |
| 1 | -+ | |||
| 70 | +20x |
- #' Horizontal Waterfall Plot+ result <- c(count = count, fraction = count / .N_col) |
||
| 2 | -+ | |||
| 71 | +20x |
- #'+ result |
||
| 3 | +72 |
- #' This basic waterfall plot visualizes a quantity `height` ordered by value with some markup.+ } |
||
| 4 | +73 |
- #'+ |
||
| 5 | +74 |
- #' @description `r lifecycle::badge("stable")`
+ #' Description of Cumulative Count |
||
| 6 | +75 |
#' |
||
| 7 | -- |
- #' @param height (`numeric``)\cr vector containing values to be plotted as the waterfall bars.- |
- ||
| 8 | -- |
- #' @param id (`character`)\cr vector containing IDs to use as the x-axis label for the waterfall bars.- |
- ||
| 9 | -- |
- #' @param col (`character`)\cr colors.- |
- ||
| 10 | -- |
- #' @param col_var (`factor`, `character` or `NULL`)\cr categorical variable for bar coloring. `NULL` by default.- |
- ||
| 11 | -- |
- #' @param xlab (`character`)\cr x label. Default is `"ID"`.- |
- ||
| 12 | -- |
- #' @param ylab (`character`)\cr y label. Default is `"Value"`.- |
- ||
| 13 | -- |
- #' @param title (`character`)\cr text to be displayed as plot title.- |
- ||
| 14 | +76 |
- #' @param col_legend_title (`character`)\cr text to be displayed as legend title.+ #' @description `r lifecycle::badge("stable")`
|
||
| 15 | +77 |
#' |
||
| 16 | +78 |
- #' @return A `ggplot` waterfall plot.+ #' This is a helper function that describes the analysis in [s_count_cumulative()]. |
||
| 17 | +79 |
#' |
||
| 18 | -- |
- #' @examples- |
- ||
| 19 | -- |
- #' library(dplyr)- |
- ||
| 20 | +80 |
- #' library(nestcolor)+ #' @inheritParams h_count_cumulative |
||
| 21 | +81 |
#' |
||
| 22 | +82 |
- #' g_waterfall(height = c(3, 5, -1), id = letters[1:3])+ #' @return Labels for [s_count_cumulative()]. |
||
| 23 | +83 |
#' |
||
| 24 | -- |
- #' g_waterfall(- |
- ||
| 25 | -- |
- #' height = c(3, 5, -1),- |
- ||
| 26 | -- |
- #' id = letters[1:3],- |
- ||
| 27 | +84 |
- #' col_var = letters[1:3]+ #' @export |
||
| 28 | +85 |
- #' )+ d_count_cumulative <- function(threshold, lower_tail, include_eq) {
|
||
| 29 | -+ | |||
| 86 | +18x |
- #'+ checkmate::assert_numeric(threshold) |
||
| 30 | -+ | |||
| 87 | +18x |
- #' adsl_f <- tern_ex_adsl %>%+ lg <- if (lower_tail) "<" else ">" |
||
| 31 | -+ | |||
| 88 | +18x |
- #' select(USUBJID, STUDYID, ARM, ARMCD, SEX)+ eq <- if (include_eq) "=" else "" |
||
| 32 | -+ | |||
| 89 | +18x |
- #'+ paste0(lg, eq, " ", threshold) |
||
| 33 | +90 |
- #' adrs_f <- tern_ex_adrs %>%+ } |
||
| 34 | +91 |
- #' filter(PARAMCD == "OVRINV") %>%+ |
||
| 35 | +92 |
- #' mutate(pchg = rnorm(n(), 10, 50))+ #' @describeIn count_cumulative Statistics function that produces a named list given a numeric vector of thresholds. |
||
| 36 | +93 |
#' |
||
| 37 | -- |
- #' adrs_f <- head(adrs_f, 30)- |
- ||
| 38 | -- |
- #' adrs_f <- adrs_f[!duplicated(adrs_f$USUBJID), ]- |
- ||
| 39 | +94 |
- #' head(adrs_f)+ #' @param thresholds (`numeric`)\cr vector of cutoff value for the counts. |
||
| 40 | +95 |
#' |
||
| 41 | +96 |
- #' g_waterfall(+ #' @return |
||
| 42 | +97 |
- #' height = adrs_f$pchg,+ #' * `s_count_cumulative()` returns a named list of `count_fraction`s: a list with each `thresholds` value as a |
||
| 43 | +98 |
- #' id = adrs_f$USUBJID,+ #' component, each component containing a vector for the count and fraction. |
||
| 44 | +99 |
- #' col_var = adrs_f$AVALC+ #' |
||
| 45 | +100 |
- #' )+ #' @keywords internal |
||
| 46 | +101 |
- #'+ s_count_cumulative <- function(x, |
||
| 47 | +102 |
- #' g_waterfall(+ thresholds, |
||
| 48 | +103 |
- #' height = adrs_f$pchg,+ lower_tail = TRUE, |
||
| 49 | +104 |
- #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
+ include_eq = TRUE, |
||
| 50 | +105 |
- #' col_var = adrs_f$SEX+ .N_col, # nolint |
||
| 51 | +106 |
- #' )+ ...) {
|
||
| 52 | -+ | |||
| 107 | +5x |
- #'+ checkmate::assert_numeric(thresholds, min.len = 1, any.missing = FALSE) |
||
| 53 | +108 |
- #' g_waterfall(+ |
||
| 54 | -+ | |||
| 109 | +5x |
- #' height = adrs_f$pchg,+ count_fraction_list <- Map(function(thres) {
|
||
| 55 | -+ | |||
| 110 | +10x |
- #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
+ result <- h_count_cumulative(x, thres, lower_tail, include_eq, .N_col = .N_col, ...) |
||
| 56 | -+ | |||
| 111 | +10x |
- #' xlab = "ID",+ label <- d_count_cumulative(thres, lower_tail, include_eq) |
||
| 57 | -+ | |||
| 112 | +10x |
- #' ylab = "Percentage Change",+ formatters::with_label(result, label) |
||
| 58 | -+ | |||
| 113 | +5x |
- #' title = "Waterfall plot"+ }, thresholds) |
||
| 59 | +114 |
- #' )+ |
||
| 60 | -+ | |||
| 115 | +5x |
- #'+ names(count_fraction_list) <- thresholds |
||
| 61 | -+ | |||
| 116 | +5x |
- #' @export+ list(count_fraction = count_fraction_list) |
||
| 62 | +117 |
- g_waterfall <- function(height,+ } |
||
| 63 | +118 |
- id,+ |
||
| 64 | +119 |
- col_var = NULL,+ #' @describeIn count_cumulative Formatted analysis function which is used as `afun` |
||
| 65 | +120 |
- col = getOption("ggplot2.discrete.colour"),
+ #' in `count_cumulative()`. |
||
| 66 | +121 |
- xlab = NULL,+ #' |
||
| 67 | +122 |
- ylab = NULL,+ #' @return |
||
| 68 | +123 |
- col_legend_title = NULL,+ #' * `a_count_cumulative()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 69 | +124 |
- title = NULL) {
- |
- ||
| 70 | -2x | -
- if (!is.null(col_var)) {
- |
- ||
| 71 | -1x | -
- check_same_n(height = height, id = id, col_var = col_var)+ #' |
||
| 72 | +125 |
- } else {
- |
- ||
| 73 | -1x | -
- check_same_n(height = height, id = id)+ #' @keywords internal |
||
| 74 | +126 |
- }+ a_count_cumulative <- make_afun( |
||
| 75 | +127 |
-
+ s_count_cumulative, |
||
| 76 | -2x | +|||
| 128 | +
- checkmate::assert_multi_class(col_var, c("character", "factor"), null.ok = TRUE)
+ .formats = c(count_fraction = format_count_fraction) |
|||
| 77 | -2x | +|||
| 129 | +
- checkmate::assert_character(col, null.ok = TRUE)+ ) |
|||
| 78 | +130 | |||
| 79 | -2x | -
- xlabel <- deparse(substitute(id))- |
- ||
| 80 | -2x | +|||
| 131 | +
- ylabel <- deparse(substitute(height))+ #' @describeIn count_cumulative Layout-creating function which can take statistics function arguments |
|||
| 81 | +132 |
-
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 82 | -2x | +|||
| 133 | +
- col_label <- if (!missing(col_var)) {
+ #' |
|||
| 83 | -1x | +|||
| 134 | +
- deparse(substitute(col_var))+ #' @return |
|||
| 84 | +135 |
- }+ #' * `count_cumulative()` returns a layout object suitable for passing to further layouting functions, |
||
| 85 | +136 |
-
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 86 | -2x | +|||
| 137 | +
- xlab <- if (is.null(xlab)) xlabel else xlab+ #' the statistics from `s_count_cumulative()` to the table layout. |
|||
| 87 | -2x | +|||
| 138 | +
- ylab <- if (is.null(ylab)) ylabel else ylab+ #' |
|||
| 88 | -2x | +|||
| 139 | +
- col_legend_title <- if (is.null(col_legend_title)) col_label else col_legend_title+ #' @examples |
|||
| 89 | +140 |
-
+ #' basic_table() %>% |
||
| 90 | -2x | +|||
| 141 | +
- plot_data <- data.frame(+ #' split_cols_by("ARM") %>%
|
|||
| 91 | -2x | +|||
| 142 | +
- height = height,+ #' add_colcounts() %>% |
|||
| 92 | -2x | +|||
| 143 | +
- id = as.character(id),+ #' count_cumulative( |
|||
| 93 | -2x | +|||
| 144 | +
- col_var = if (is.null(col_var)) "x" else to_n(col_var, length(height)),+ #' vars = "AGE", |
|||
| 94 | -2x | +|||
| 145 | +
- stringsAsFactors = FALSE+ #' thresholds = c(40, 60) |
|||
| 95 | +146 |
- )+ #' ) %>% |
||
| 96 | +147 |
-
+ #' build_table(tern_ex_adsl) |
||
| 97 | -2x | +|||
| 148 | +
- plot_data_ord <- plot_data[order(plot_data$height, decreasing = TRUE), ]+ #' |
|||
| 98 | +149 |
-
+ #' @export |
||
| 99 | -2x | +|||
| 150 | +
- p <- ggplot2::ggplot(plot_data_ord, ggplot2::aes(x = factor(id, levels = id), y = height)) ++ count_cumulative <- function(lyt, |
|||
| 100 | -2x | +|||
| 151 | +
- ggplot2::geom_col() ++ vars, |
|||
| 101 | -2x | +|||
| 152 | +
- ggplot2::geom_text(+ var_labels = vars, |
|||
| 102 | -2x | +|||
| 153 | +
- label = format(plot_data_ord$height, digits = 2),+ show_labels = "visible", |
|||
| 103 | -2x | +|||
| 154 | +
- vjust = ifelse(plot_data_ord$height >= 0, -0.5, 1.5)+ na_str = NA_character_, |
|||
| 104 | +155 |
- ) ++ nested = TRUE, |
||
| 105 | -2x | +|||
| 156 | +
- ggplot2::xlab(xlab) ++ ..., |
|||
| 106 | -2x | +|||
| 157 | +
- ggplot2::ylab(ylab) ++ table_names = vars, |
|||
| 107 | -2x | +|||
| 158 | +
- ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 0, vjust = .5))+ .stats = NULL, |
|||
| 108 | +159 |
-
+ .formats = NULL, |
||
| 109 | -2x | +|||
| 160 | +
- if (!is.null(col_var)) {
+ .labels = NULL, |
|||
| 110 | -1x | +|||
| 161 | +
- p <- p ++ .indent_mods = NULL) {
|
|||
| 111 | -1x | +162 | +2x |
- ggplot2::aes(fill = col_var) ++ afun <- make_afun( |
| 112 | -1x | +163 | +2x |
- ggplot2::labs(fill = col_legend_title) ++ a_count_cumulative, |
| 113 | -1x | +164 | +2x |
- ggplot2::theme(+ .stats = .stats, |
| 114 | -1x | +165 | +2x |
- legend.position = "bottom",+ .formats = .formats, |
| 115 | -1x | +166 | +2x |
- legend.background = ggplot2::element_blank(),+ .labels = .labels, |
| 116 | -1x | +167 | +2x |
- legend.title = ggplot2::element_text(face = "bold"),+ .indent_mods = .indent_mods, |
| 117 | -1x | -
- legend.box.background = ggplot2::element_rect(colour = "black")- |
- ||
| 118 | -- |
- )- |
- ||
| 119 | -+ | 168 | +2x |
- }+ .ungroup_stats = "count_fraction" |
| 120 | +169 |
-
+ ) |
||
| 121 | +170 | 2x |
- if (!is.null(col)) {
+ analyze( |
|
| 122 | -1x | +171 | +2x |
- p <- p ++ lyt, |
| 123 | -1x | +172 | +2x |
- ggplot2::scale_fill_manual(values = col)+ vars, |
| 124 | -+ | |||
| 173 | +2x |
- }+ afun = afun, |
||
| 125 | -+ | |||
| 174 | +2x |
-
+ na_str = na_str, |
||
| 126 | +175 | 2x |
- if (!is.null(title)) {
+ table_names = table_names, |
|
| 127 | -1x | +176 | +2x |
- p <- p ++ var_labels = var_labels, |
| 128 | -1x | +177 | +2x |
- ggplot2::labs(title = title) ++ show_labels = show_labels, |
| 129 | -1x | +178 | +2x |
- ggplot2::theme(plot.title = ggplot2::element_text(face = "bold"))+ nested = nested, |
| 130 | -+ | |||
| 179 | +2x |
- }+ extra_args = list(...) |
||
| 131 | +180 | - - | -||
| 132 | -2x | -
- p+ ) |
||
| 133 | +181 |
}@@ -142110,14 +141628,14 @@ tern coverage - 94.83% |
| 1 |
- #' Create a STEP Graph+ #' Additional Assertions for `checkmate` |
|||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' Additional assertion functions which can be used together with the `checkmate` package. |
|||
| 5 |
- #' Based on the STEP results, creates a `ggplot` graph showing the estimated HR or OR+ #' @inheritParams checkmate::assert_factor |
|||
| 6 |
- #' along the continuous biomarker value subgroups.+ #' @param x (`any`)\cr object to test. |
|||
| 7 |
- #'+ #' @param df (`data.frame`)\cr data set to test. |
|||
| 8 |
- #' @param df (`tibble`)\cr result of [tidy.step()].+ #' @param variables (named `list` of `character`)\cr list of variables to test. |
|||
| 9 |
- #' @param use_percentile (`flag`)\cr whether to use percentiles for the x axis or actual+ #' @param include_boundaries (`logical`)\cr whether to include boundaries when testing |
|||
| 10 |
- #' biomarker values.+ #' for proportions. |
|||
| 11 |
- #' @param est (named `list`)\cr `col` and `lty` settings for estimate line.+ #' @param na_level (`character`)\cr the string you have been using to represent NA or |
|||
| 12 |
- #' @param ci_ribbon (named `list` or `NULL`)\cr `fill` and `alpha` settings for the confidence interval+ #' missing data. For `NA` values please consider using directly [is.na()] or |
|||
| 13 |
- #' ribbon area, or `NULL` to not plot a CI ribbon.+ #' similar approaches. |
|||
| 14 |
- #' @param col (`character`)\cr colors.+ #' |
|||
| 15 |
- #'+ #' @return Nothing if assertion passes, otherwise prints the error message. |
|||
| 16 |
- #' @return A `ggplot` STEP graph.+ #' |
|||
| 17 |
- #'+ #' @name assertions |
|||
| 18 |
- #' @seealso Custom tidy method [tidy.step()].+ NULL |
|||
| 19 |
- #'+ |
|||
| 20 |
- #' @examples+ check_list_of_variables <- function(x) {
|
|||
| 21 |
- #' library(nestcolor)+ # drop NULL elements in list |
|||
| 22 | -+ | 2190x |
- #' library(survival)+ x <- Filter(Negate(is.null), x) |
|
| 23 |
- #' lung$sex <- factor(lung$sex)+ |
|||
| 24 | -+ | 2190x |
- #'+ res <- checkmate::check_list(x, |
|
| 25 | -+ | 2190x |
- #' # Survival example.+ names = "named", |
|
| 26 | -+ | 2190x |
- #' vars <- list(+ min.len = 1, |
|
| 27 | -+ | 2190x |
- #' time = "time",+ any.missing = FALSE, |
|
| 28 | -+ | 2190x |
- #' event = "status",+ types = "character" |
|
| 29 |
- #' arm = "sex",+ ) |
|||
| 30 |
- #' biomarker = "age"+ # no empty strings allowed |
|||
| 31 | -+ | 2190x |
- #' )+ if (isTRUE(res)) {
|
|
| 32 | -+ | 2185x |
- #'+ res <- checkmate::check_character(unlist(x), min.chars = 1) |
|
| 33 |
- #' step_matrix <- fit_survival_step(+ } |
|||
| 34 | -+ | 2190x |
- #' variables = vars,+ return(res) |
|
| 35 |
- #' data = lung,+ } |
|||
| 36 |
- #' control = c(control_coxph(), control_step(num_points = 10, degree = 2))+ #' @describeIn assertions Checks whether `x` is a valid list of variable names. |
|||
| 37 |
- #' )+ #' `NULL` elements of the list `x` are dropped with `Filter(Negate(is.null), x)`. |
|||
| 38 |
- #' step_data <- broom::tidy(step_matrix)+ #' |
|||
| 39 |
- #'+ #' @keywords internal |
|||
| 40 |
- #' # Default plot.+ assert_list_of_variables <- checkmate::makeAssertionFunction(check_list_of_variables) |
|||
| 41 |
- #' g_step(step_data)+ |
|||
| 42 |
- #'+ check_df_with_variables <- function(df, variables, na_level = NULL) {
|
|||
| 43 | -+ | 1956x |
- #' # Add the reference 1 horizontal line.+ checkmate::assert_data_frame(df) |
|
| 44 | -+ | 1954x |
- #' library(ggplot2)+ assert_list_of_variables(variables) |
|
| 45 |
- #' g_step(step_data) ++ |
|||
| 46 |
- #' ggplot2::geom_hline(ggplot2::aes(yintercept = 1), linetype = 2)+ # flag for equal variables and column names |
|||
| 47 | -+ | 1952x |
- #'+ err_flag <- all(unlist(variables) %in% colnames(df)) |
|
| 48 | -+ | 1952x |
- #' # Use actual values instead of percentiles, different color for estimate and no CI,+ checkmate::assert_flag(err_flag) |
|
| 49 |
- #' # use log scale for y axis.+ |
|||
| 50 | -+ | 1952x |
- #' g_step(+ if (isFALSE(err_flag)) {
|
|
| 51 | -+ | 5x |
- #' step_data,+ vars <- setdiff(unlist(variables), colnames(df)) |
|
| 52 | -+ | 5x |
- #' use_percentile = FALSE,+ return(paste( |
|
| 53 | -+ | 5x |
- #' est = list(col = "blue", lty = 1),+ deparse(substitute(df)), |
|
| 54 | -+ | 5x |
- #' ci_ribbon = NULL+ "does not contain all specified variables as column names. Missing from dataframe:", |
|
| 55 | -+ | 5x |
- #' ) + scale_y_log10()+ paste(vars, collapse = ", ") |
|
| 56 |
- #'+ )) |
|||
| 57 |
- #' # Adding another curve based on additional column.+ } |
|||
| 58 |
- #' step_data$extra <- exp(step_data$`Percentile Center`)+ # checking if na_level is present and in which column |
|||
| 59 | -+ | 1947x |
- #' g_step(step_data) ++ if (!is.null(na_level)) {
|
|
| 60 | -+ | 9x |
- #' ggplot2::geom_line(ggplot2::aes(y = extra), linetype = 2, color = "green")+ checkmate::assert_string(na_level) |
|
| 61 | -+ | 9x |
- #'+ res <- unlist(lapply(as.list(df)[unlist(variables)], function(x) any(x == na_level))) |
|
| 62 | -+ | 9x |
- #' # Response example.+ if (any(res)) {
|
|
| 63 | -+ | 1x |
- #' vars <- list(+ return(paste0( |
|
| 64 | -+ | 1x |
- #' response = "status",+ deparse(substitute(df)), " contains explicit na_level (", na_level,
|
|
| 65 | -+ | 1x |
- #' arm = "sex",+ ") in the following columns: ", paste0(unlist(variables)[res], |
|
| 66 | -+ | 1x |
- #' biomarker = "age"+ collapse = ", " |
|
| 67 |
- #' )+ ) |
|||
| 68 |
- #'+ )) |
|||
| 69 |
- #' step_matrix <- fit_rsp_step(+ } |
|||
| 70 |
- #' variables = vars,+ } |
|||
| 71 | -+ | 1946x |
- #' data = lung,+ return(TRUE) |
|
| 72 |
- #' control = c(+ } |
|||
| 73 |
- #' control_logistic(response_definition = "I(response == 2)"),+ #' @describeIn assertions Check whether `df` is a data frame with the analysis `variables`. |
|||
| 74 |
- #' control_step()+ #' Please notice how this produces an error when not all variables are present in the |
|||
| 75 |
- #' )+ #' data.frame while the opposite is not required. |
|||
| 76 |
- #' )+ #' |
|||
| 77 |
- #' step_data <- broom::tidy(step_matrix)+ #' @keywords internal |
|||
| 78 |
- #' g_step(step_data)+ assert_df_with_variables <- checkmate::makeAssertionFunction(check_df_with_variables) |
|||
| 79 |
- #'+ |
|||
| 80 |
- #' @export+ check_valid_factor <- function(x, |
|||
| 81 |
- g_step <- function(df,+ min.levels = 1, # nolint |
|||
| 82 |
- use_percentile = "Percentile Center" %in% names(df),+ max.levels = NULL, # nolint |
|||
| 83 |
- est = list(col = "blue", lty = 1),+ null.ok = TRUE, # nolint |
|||
| 84 |
- ci_ribbon = list(fill = getOption("ggplot2.discrete.colour")[1], alpha = 0.5),
+ any.missing = TRUE, # nolint |
|||
| 85 |
- col = getOption("ggplot2.discrete.colour")) {
+ n.levels = NULL, # nolint |
|||
| 86 | -2x | +
- checkmate::assert_tibble(df)+ len = NULL) {
|
||
| 87 | -2x | +
- checkmate::assert_flag(use_percentile)+ # checks on levels insertion |
||
| 88 | -2x | +846x |
- checkmate::assert_character(col, null.ok = TRUE)+ checkmate::assert_int(min.levels, lower = 1) |
|
| 89 | -2x | +
- checkmate::assert_list(est, names = "named")+ |
||
| 90 | -2x | +
- checkmate::assert_list(ci_ribbon, names = "named", null.ok = TRUE)+ # main factor check |
||
| 91 | -+ | 846x |
-
+ res <- checkmate::check_factor(x, |
|
| 92 | -2x | +846x |
- x_var <- ifelse(use_percentile, "Percentile Center", "Interval Center")+ min.levels = min.levels, |
|
| 93 | -2x | +846x |
- df$x <- df[[x_var]]+ null.ok = null.ok, |
|
| 94 | -2x | +846x |
- attrs <- attributes(df)+ max.levels = max.levels, |
|
| 95 | -2x | +846x |
- df$y <- df[[attrs$estimate]]+ any.missing = any.missing, |
|
| 96 | -+ | 846x |
-
+ n.levels = n.levels |
|
| 97 |
- # Set legend names. To be modified also at call level+ ) |
|||
| 98 | -2x | +
- legend_names <- c("Estimate", "CI 95%")
+
|
||
| 99 |
-
+ # no empty strings allowed |
|||
| 100 | -2x | +846x |
- p <- ggplot2::ggplot(df, ggplot2::aes(x = .data[["x"]], y = .data[["y"]]))+ if (isTRUE(res)) {
|
|
| 101 | -+ | 832x |
-
+ res <- checkmate::check_character(levels(x), min.chars = 1) |
|
| 102 | -2x | +
- if (!is.null(col)) {
+ } |
||
| 103 | -2x | +
- p <- p ++ |
||
| 104 | -2x | +846x |
- ggplot2::scale_color_manual(values = col)+ return(res) |
|
| 105 |
- }+ } |
|||
| 106 |
-
+ #' @describeIn assertions Check whether `x` is a valid factor (i.e. has levels and no empty |
|||
| 107 | -2x | +
- if (!is.null(ci_ribbon)) {
+ #' string levels). Note that `NULL` and `NA` elements are allowed. |
||
| 108 | -1x | +
- if (is.null(ci_ribbon$fill)) {
+ #' |
||
| 109 | -! | +
- ci_ribbon$fill <- "lightblue"+ #' @keywords internal |
||
| 110 |
- }+ assert_valid_factor <- checkmate::makeAssertionFunction(check_valid_factor) |
|||
| 111 | -1x | +
- p <- p + ggplot2::geom_ribbon(+ |
||
| 112 | -1x | +
- ggplot2::aes(+ |
||
| 113 | -1x | ++ |
+ check_df_with_factors <- function(df,+ |
+ |
| 114 | ++ |
+ variables,+ |
+ ||
| 115 | ++ |
+ min.levels = 1, # nolint+ |
+ ||
| 116 | ++ |
+ max.levels = NULL, # nolint+ |
+ ||
| 117 | ++ |
+ any.missing = TRUE, # nolint+ |
+ ||
| 118 | ++ |
+ na_level = NULL) {
+ |
+ ||
| 119 | +190x | +
+ res <- check_df_with_variables(df, variables, na_level)+ |
+ ||
| 120 | ++ |
+ # checking if all the columns specified by variables are valid factors+ |
+ ||
| 121 | +189x | +
+ if (isTRUE(res)) {
+ |
+ ||
| 122 | ++ |
+ # searching the data.frame with selected columns (variables) as a list+ |
+ ||
| 123 | +187x | +
+ res <- lapply(+ |
+ ||
| 124 | +187x | +
+ X = as.list(df)[unlist(variables)],+ |
+ ||
| 125 | +187x | +
+ FUN = check_valid_factor,+ |
+ ||
| 126 | +187x | +
+ min.levels = min.levels,+ |
+ ||
| 127 | +187x | +
+ max.levels = max.levels,+ |
+ ||
| 128 | +187x | +
+ any.missing = any.missing+ |
+ ||
| 129 | ++ |
+ )+ |
+ ||
| 130 | +187x | +
+ res_lo <- unlist(vapply(res, Negate(isTRUE), logical(1)))+ |
+ ||
| 131 | +187x | +
+ if (any(res_lo)) {
+ |
+ ||
| 132 | +6x | +
+ return(paste0(+ |
+ ||
| 133 | +6x | +
+ deparse(substitute(df)), " does not contain only factor variables among:",+ |
+ ||
| 134 | +6x | +
+ "\n* Column `", paste0(unlist(variables)[res_lo],+ |
+ ||
| 135 | +6x | +
+ "` of the data.frame -> ", res[res_lo],+ |
+ ||
| 136 | +6x | +
+ collapse = "\n* "+ |
+ ||
| 137 | ++ |
+ )+ |
+ ||
| 138 | ++ |
+ ))+ |
+ ||
| 139 | ++ |
+ } else {
+ |
+ ||
| 140 | +181x | +
+ res <- TRUE+ |
+ ||
| 141 | ++ |
+ }+ |
+ ||
| 142 | ++ |
+ }+ |
+ ||
| 143 | +183x | +
+ return(res)+ |
+ ||
| 144 | ++ |
+ }+ |
+ ||
| 145 | ++ |
+ #' @describeIn assertions Check whether `df` is a data frame where the analysis `variables`+ |
+ ||
| 146 | ++ |
+ #' are all factors. Note that the creation of `NA` by direct call of `factor()` will+ |
+ ||
| 147 | +
- ymin = .data[["ci_lower"]], ymax = .data[["ci_upper"]],+ #' trim `NA` levels out of the vector list itself. |
|||
| 114 | -1x | +|||
| 148 | +
- fill = legend_names[2]+ #' |
|||
| 115 | +149 |
- ),+ #' @keywords internal |
||
| 116 | -1x | +|||
| 150 | +
- alpha = ci_ribbon$alpha+ assert_df_with_factors <- checkmate::makeAssertionFunction(check_df_with_factors) |
|||
| 117 | +151 |
- ) ++ |
||
| 118 | -1x | +|||
| 152 | +
- scale_fill_manual(+ #' @describeIn assertions Check whether `x` is a proportion: number between 0 and 1. |
|||
| 119 | -1x | +|||
| 153 | +
- name = "", values = c("CI 95%" = ci_ribbon$fill)
+ #' |
|||
| 120 | +154 |
- )+ #' @keywords internal |
||
| 121 | +155 |
- }+ assert_proportion_value <- function(x, include_boundaries = FALSE) {
|
||
| 122 | -2x | +156 | +6861x |
- suppressMessages(p <- p ++ checkmate::assert_number(x, lower = 0, upper = 1) |
| 123 | -2x | +157 | +6849x |
- ggplot2::geom_line(+ checkmate::assert_flag(include_boundaries) |
| 124 | -2x | +158 | +6849x |
- ggplot2::aes(y = .data[["y"]], color = legend_names[1]),+ if (isFALSE(include_boundaries)) {
|
| 125 | -2x | +159 | +2900x |
- linetype = est$lty+ checkmate::assert_true(x > 0)+ |
+
| 160 | +2898x | +
+ checkmate::assert_true(x < 1) |
||
| 126 | +161 |
- ) ++ } |
||
| 127 | -2x | +|||
| 162 | +
- scale_colour_manual(+ } |
|||
| 128 | -2x | +
| 1 | +
- name = "", values = c("Estimate" = "blue")
+ #' Tabulate Biomarker Effects on Survival by Subgroup |
||
| 129 | +2 |
- ))+ #' |
|
| 130 | +3 |
-
+ #' @description `r lifecycle::badge("stable")`
|
|
| 131 | -2x | +||
| 4 | +
- p <- p + ggplot2::labs(x = attrs$biomarker, y = attrs$estimate)+ #' |
||
| 132 | -2x | +||
| 5 | +
- if (use_percentile) {
+ #' Tabulate the estimated effects of multiple continuous biomarker variables |
||
| 133 | -1x | +||
| 6 | +
- p <- p + ggplot2::scale_x_continuous(labels = scales::percent)+ #' across population subgroups. |
||
| 134 | +7 |
- }+ #' |
|
| 135 | -2x | +||
| 8 | +
- p+ #' @inheritParams argument_convention |
||
| 136 | +9 |
- }+ #' @inheritParams fit_coxreg_multivar |
|
| 137 | +10 |
-
+ #' @inheritParams survival_duration_subgroups |
|
| 138 | +11 |
- #' Custom Tidy Method for STEP Results+ #' |
|
| 139 | +12 |
- #'+ #' @details These functions create a layout starting from a data frame which contains |
|
| 140 | +13 |
- #' @description `r lifecycle::badge("stable")`
+ #' the required statistics. The tables are then typically used as input for forest plots. |
|
| 141 | +14 |
#' |
|
| 142 | +15 |
- #' Tidy the STEP results into a `tibble` format ready for plotting.+ #' @examples |
|
| 143 | +16 |
- #'+ #' library(dplyr) |
|
| 144 | +17 |
- #' @param x (`step` matrix)\cr results from [fit_survival_step()].+ #' |
|
| 145 | +18 |
- #' @param ... not used here.+ #' adtte <- tern_ex_adtte |
|
| 146 | +19 |
#' |
|
| 147 | +20 |
- #' @return A `tibble` with one row per STEP subgroup. The estimates and CIs are on the HR or OR scale,+ #' # Save variable labels before data processing steps. |
|
| 148 | +21 |
- #' respectively. Additional attributes carry metadata also used for plotting.+ #' adtte_labels <- formatters::var_labels(adtte) |
|
| 149 | +22 |
#' |
|
| 150 | +23 |
- #' @seealso [g_step()] which consumes the result from this function.+ #' adtte_f <- adtte %>% |
|
| 151 | +24 |
- #'+ #' filter(PARAMCD == "OS") %>% |
|
| 152 | +25 |
- #' @method tidy step+ #' mutate( |
|
| 153 | +26 |
- #'+ #' AVALU = as.character(AVALU), |
|
| 154 | +27 |
- #' @examples+ #' is_event = CNSR == 0 |
|
| 155 | +28 |
- #' library(survival)+ #' ) |
|
| 156 | +29 |
- #' lung$sex <- factor(lung$sex)+ #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
|
|
| 157 | +30 |
- #' vars <- list(+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
|
| 158 | +31 |
- #' time = "time",+ #' |
|
| 159 | +32 |
- #' event = "status",+ #' df <- extract_survival_biomarkers( |
|
| 160 | +33 |
- #' arm = "sex",+ #' variables = list( |
|
| 161 | +34 |
- #' biomarker = "age"+ #' tte = "AVAL", |
|
| 162 | +35 |
- #' )+ #' is_event = "is_event", |
|
| 163 | +36 |
- #' step_matrix <- fit_survival_step(+ #' biomarkers = c("BMRKR1", "AGE"),
|
|
| 164 | +37 |
- #' variables = vars,+ #' strata = "STRATA1", |
|
| 165 | +38 |
- #' data = lung,+ #' covariates = "SEX", |
|
| 166 | +39 |
- #' control = c(control_coxph(), control_step(num_points = 10, degree = 2))+ #' subgroups = "BMRKR2" |
|
| 167 | +40 |
- #' )+ #' ), |
|
| 168 | +41 |
- #' broom::tidy(step_matrix)+ #' data = adtte_f |
|
| 169 | +42 |
- #'+ #' ) |
|
| 170 | +43 |
- #' @export+ #' df |
|
| 171 | +44 |
- tidy.step <- function(x, ...) { # nolint
+ #' |
|
| 172 | -7x | +||
| 45 | +
- checkmate::assert_class(x, "step")+ #' @name survival_biomarkers_subgroups |
||
| 173 | -7x | +||
| 46 | +
- dat <- as.data.frame(x)+ NULL |
||
| 174 | -7x | +||
| 47 | +
- nams <- names(dat)+ |
||
| 175 | -7x | +||
| 48 | +
- is_surv <- "loghr" %in% names(dat)+ #' Prepares Survival Data Estimates for Multiple Biomarkers in a Single Data Frame |
||
| 176 | -7x | +||
| 49 | +
- est_var <- ifelse(is_surv, "loghr", "logor")+ #' |
||
| 177 | -7x | +||
| 50 | +
- new_est_var <- ifelse(is_surv, "Hazard Ratio", "Odds Ratio")+ #' @description `r lifecycle::badge("stable")`
|
||
| 178 | -7x | +||
| 51 | +
- new_y_vars <- c(new_est_var, c("ci_lower", "ci_upper"))
+ #' |
||
| 179 | -7x | +||
| 52 | +
- names(dat)[match(est_var, nams)] <- new_est_var+ #' Prepares estimates for number of events, patients and median survival times, as well as hazard ratio estimates, |
||
| 180 | -7x | +||
| 53 | +
- dat[, new_y_vars] <- exp(dat[, new_y_vars])+ #' confidence intervals and p-values, for multiple biomarkers across population subgroups in a single data frame. |
||
| 181 | -7x | +||
| 54 | +
- any_is_na <- any(is.na(dat[, new_y_vars]))+ #' `variables` corresponds to the names of variables found in `data`, passed as a named `list` and requires elements |
||
| 182 | -7x | +||
| 55 | +
- any_is_very_large <- any(abs(dat[, new_y_vars]) > 1e10, na.rm = TRUE)+ #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables), and optionally `subgroups` and `strat`. |
||
| 183 | -7x | +||
| 56 | +
- if (any_is_na) {
+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
||
| 184 | -2x | +||
| 57 | +
- warning(paste(+ #' |
||
| 185 | -2x | +||
| 58 | +
- "Missing values in the point estimate or CI columns,",+ #' @inheritParams argument_convention |
||
| 186 | -2x | +||
| 59 | +
- "this will lead to holes in the `g_step()` plot"+ #' @inheritParams fit_coxreg_multivar |
||
| 187 | +60 |
- ))+ #' @inheritParams survival_duration_subgroups |
|
| 188 | +61 |
- }+ #' |
|
| 189 | -7x | +||
| 62 | +
- if (any_is_very_large) {
+ #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_tot_events`, |
||
| 190 | -2x | +||
| 63 | +
- warning(paste(+ #' `median`, `hr`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`, |
||
| 191 | -2x | +||
| 64 | +
- "Very large absolute values in the point estimate or CI columns,",+ #' `var_label`, and `row_type`. |
||
| 192 | -2x | +||
| 65 | +
- "consider adding `scale_y_log10()` to the `g_step()` result for plotting"+ #' |
||
| 193 | +66 |
- ))+ #' @seealso [h_coxreg_mult_cont_df()] which is used internally, [tabulate_survival_biomarkers()]. |
|
| 194 | +67 |
- }+ #' |
|
| 195 | -7x | +||
| 68 | +
- if (any_is_na || any_is_very_large) {
+ #' @examples |
||
| 196 | -4x | +||
| 69 | +
- warning("Consider using larger `bandwidth`, less `num_points` in `control_step()` settings for fitting")
+ #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`, |
||
| 197 | +70 |
- }+ #' # in multiple regression models containing one covariate `RACE`, |
|
| 198 | -7x | +||
| 71 | +
- structure(+ #' # as well as one stratification variable `STRATA1`. The subgroups |
||
| 199 | -7x | +||
| 72 | +
- tibble::as_tibble(dat),+ #' # are defined by the levels of `BMRKR2`. |
||
| 200 | -7x | +||
| 73 | +
- estimate = new_est_var,+ #' |
||
| 201 | -7x | +||
| 74 | +
- biomarker = attr(x, "variables")$biomarker,+ #' library(dplyr) |
||
| 202 | -7x | +||
| 75 | +
- ci = f_conf_level(attr(x, "control")$conf_level)+ #' |
||
| 203 | +76 |
- )+ #' adtte <- tern_ex_adtte |
|
| 204 | +77 |
- }+ #' adtte_labels <- formatters::var_labels(adtte) |
| 1 | +78 |
- #' Summary for Poisson Negative Binomial.+ #' |
||
| 2 | +79 |
- #'+ #' adtte_f <- adtte %>% |
||
| 3 | +80 |
- #' @description `r lifecycle::badge("experimental")`
+ #' filter(PARAMCD == "OS") %>% |
||
| 4 | +81 |
- #'+ #' mutate( |
||
| 5 | +82 |
- #' Summarize results of a Poisson Negative Binomial Regression.+ #' AVALU = as.character(AVALU), |
||
| 6 | +83 |
- #' This can be used to analyze count and/or frequency data using a linear model.+ #' is_event = CNSR == 0 |
||
| 7 | +84 |
- #'+ #' ) |
||
| 8 | +85 |
- #' @inheritParams argument_convention+ #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
|
||
| 9 | +86 | ++ |
+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ |
+ |
| 87 |
#' |
|||
| 10 | +88 |
- #' @name summarize_glm_count+ #' df <- extract_survival_biomarkers( |
||
| 11 | +89 |
- NULL+ #' variables = list( |
||
| 12 | +90 |
-
+ #' tte = "AVAL", |
||
| 13 | +91 |
- #' Helper Functions for Poisson Models.+ #' is_event = "is_event", |
||
| 14 | +92 |
- #'+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 15 | +93 |
- #' @description `r lifecycle::badge("experimental")`
+ #' strata = "STRATA1", |
||
| 16 | +94 |
- #'+ #' covariates = "SEX", |
||
| 17 | +95 |
- #' Helper functions that can be used to return the results of various Poisson models.+ #' subgroups = "BMRKR2" |
||
| 18 | +96 |
- #'+ #' ), |
||
| 19 | +97 |
- #' @inheritParams argument_convention+ #' data = adtte_f |
||
| 20 | +98 |
- #'+ #' ) |
||
| 21 | +99 |
- #' @seealso [summarize_glm_count]+ #' df |
||
| 22 | +100 |
#' |
||
| 23 | +101 |
- #' @name h_glm_count+ #' # Here we group the levels of `BMRKR2` manually. |
||
| 24 | +102 |
- NULL+ #' df_grouped <- extract_survival_biomarkers( |
||
| 25 | +103 |
-
+ #' variables = list( |
||
| 26 | +104 |
- #' @describeIn h_glm_count Helper function to return results of a poisson model.+ #' tte = "AVAL", |
||
| 27 | +105 |
- #'+ #' is_event = "is_event", |
||
| 28 | +106 |
- #' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 29 | +107 |
- #' in `.var` and `variables`.+ #' strata = "STRATA1", |
||
| 30 | +108 |
- #' @param variables (named `list` of `strings`)\cr list of additional analysis variables, with+ #' covariates = "SEX", |
||
| 31 | +109 |
- #' expected elements:+ #' subgroups = "BMRKR2" |
||
| 32 | +110 |
- #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple+ #' ), |
||
| 33 | +111 |
- #' groups will be summarized. Specifically, the first level of `arm` variable is taken as the+ #' data = adtte_f, |
||
| 34 | +112 |
- #' reference group.+ #' groups_lists = list( |
||
| 35 | +113 |
- #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as+ #' BMRKR2 = list( |
||
| 36 | +114 |
- #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`.+ #' "low" = "LOW", |
||
| 37 | +115 |
- #' * `offset` (`numeric`)\cr a numeric vector or scalar adding an offset.+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 38 | +116 |
- #' @param weights (`character`)\cr a character vector specifying weights used+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 39 | +117 |
- #' in averaging predictions. Number of weights must equal the number of levels included in the covariates.+ #' ) |
||
| 40 | +118 |
- #' Weights option passed to [emmeans::emmeans()].+ #' ) |
||
| 41 | +119 |
- #'+ #' ) |
||
| 42 | +120 |
- #' @return+ #' df_grouped |
||
| 43 | +121 |
- #' * `h_glm_poisson()` returns the results of a Poisson model.+ #' |
||
| 44 | +122 |
- #'+ #' @export |
||
| 45 | +123 |
- #' @keywords internal+ extract_survival_biomarkers <- function(variables, |
||
| 46 | +124 |
- h_glm_poisson <- function(.var,+ data, |
||
| 47 | +125 |
- .df_row,+ groups_lists = list(), |
||
| 48 | +126 |
- variables,+ control = control_coxreg(), |
||
| 49 | +127 |
- weights) {
+ label_all = "All Patients") {
|
||
| 50 | -12x | +128 | +4x |
- arm <- variables$arm+ checkmate::assert_list(variables) |
| 51 | -12x | +129 | +4x |
- covariates <- variables$covariates+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 52 | -12x | +130 | +4x |
- offset <- .df_row[[variables$offset]]+ checkmate::assert_string(label_all) |
| 53 | +131 | |||
| 132 | ++ |
+ # Start with all patients.+ |
+ ||
| 54 | -10x | +133 | +4x |
- formula <- stats::as.formula(paste0(+ result_all <- h_coxreg_mult_cont_df( |
| 55 | -10x | +134 | +4x |
- .var, " ~ ",+ variables = variables,+ |
+
| 135 | +4x | +
+ data = data,+ |
+ ||
| 136 | +4x | +
+ control = control |
||
| 56 | +137 |
- " + ",+ ) |
||
| 57 | -10x | +138 | +4x |
- paste(covariates, collapse = " + "),+ result_all$subgroup <- label_all+ |
+
| 139 | +4x | +
+ result_all$var <- "ALL"+ |
+ ||
| 140 | +4x | +
+ result_all$var_label <- label_all+ |
+ ||
| 141 | +4x | +
+ result_all$row_type <- "content"+ |
+ ||
| 142 | +4x | +
+ if (is.null(variables$subgroups)) {
|
||
| 58 | +143 |
- " + ",+ # Only return result for all patients. |
||
| 59 | -10x | +144 | +1x |
- arm+ result_all |
| 60 | +145 |
- ))+ } else {
|
||
| 61 | +146 |
-
+ # Add subgroups results. |
||
| 62 | -10x | +147 | +3x |
- glm_fit <- stats::glm(+ l_data <- h_split_by_subgroups( |
| 63 | -10x | +148 | +3x |
- formula = formula,+ data, |
| 64 | -10x | +149 | +3x |
- offset = offset,+ variables$subgroups, |
| 65 | -10x | +150 | +3x |
- data = .df_row,+ groups_lists = groups_lists+ |
+
| 151 | ++ |
+ ) |
||
| 66 | -10x | +152 | +3x |
- family = stats::poisson(link = "log")+ l_result <- lapply(l_data, function(grp) {
+ |
+
| 153 | +15x | +
+ result <- h_coxreg_mult_cont_df(+ |
+ ||
| 154 | +15x | +
+ variables = variables,+ |
+ ||
| 155 | +15x | +
+ data = grp$df,+ |
+ ||
| 156 | +15x | +
+ control = control |
||
| 67 | +157 |
- )+ )+ |
+ ||
| 158 | +15x | +
+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ |
+ ||
| 159 | +15x | +
+ cbind(result, result_labels) |
||
| 68 | +160 |
-
+ }) |
||
| 69 | -10x | +161 | +3x |
- emmeans_fit <- emmeans::emmeans(+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 70 | -10x | +162 | +3x |
- glm_fit,+ result_subgroups$row_type <- "analysis" |
| 71 | -10x | +163 | +3x |
- specs = arm,+ rbind( |
| 72 | -10x | +164 | +3x |
- data = .df_row,+ result_all, |
| 73 | -10x | +165 | +3x | +
+ result_subgroups+ |
+
| 166 | ++ |
+ )+ |
+ ||
| 167 | ++ |
+ }+ |
+ ||
| 168 | ++ |
+ }+ |
+ ||
| 169 | ++ | + + | +||
| 170 | ++ |
+ #' @describeIn survival_biomarkers_subgroups Table-creating function which creates a table+ |
+ ||
| 171 | ++ |
+ #' summarizing biomarker effects on survival by subgroup.+ |
+ ||
| 172 | ++ |
+ #'+ |
+ ||
| 173 | ++ |
+ #' @param df (`data.frame`)\cr containing all analysis variables, as returned by+ |
+ ||
| 174 | ++ |
+ #' [extract_survival_biomarkers()].+ |
+ ||
| 175 | +
- type = "response",+ #' @param vars (`character`)\cr the names of statistics to be reported among: |
|||
| 74 | -10x | +|||
| 176 | +
- offset = 0,+ #' * `n_tot_events`: Total number of events per group. |
|||
| 75 | -10x | +|||
| 177 | +
- weights = weights+ #' * `n_tot`: Total number of observations per group. |
|||
| 76 | +178 |
- )+ #' * `median`: Median survival time. |
||
| 77 | +179 |
-
+ #' * `hr`: Hazard ratio. |
||
| 78 | -10x | +|||
| 180 | +
- list(+ #' * `ci`: Confidence interval of hazard ratio. |
|||
| 79 | -10x | +|||
| 181 | +
- glm_fit = glm_fit,+ #' * `pval`: p-value of the effect. |
|||
| 80 | -10x | +|||
| 182 | +
- emmeans_fit = emmeans_fit+ #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` are required. |
|||
| 81 | +183 |
- )+ #' |
||
| 82 | +184 |
- }+ #' @return An `rtables` table summarizing biomarker effects on survival by subgroup. |
||
| 83 | +185 |
-
+ #' |
||
| 84 | +186 |
- #' @describeIn h_glm_count Helper function to return results of a quasipoisson model.+ #' @note In contrast to [tabulate_survival_subgroups()] this tabulation function does |
||
| 85 | +187 |
- #'+ #' not start from an input layout `lyt`. This is because internally the table is |
||
| 86 | +188 |
- #' @inheritParams summarize_glm_count+ #' created by combining multiple subtables. |
||
| 87 | +189 |
#' |
||
| 88 | +190 |
- #' @return+ #' @seealso [h_tab_surv_one_biomarker()] which is used internally, [extract_survival_biomarkers()]. |
||
| 89 | +191 |
- #' * `h_glm_quasipoisson()` returns the results of a Quasi-Poisson model.+ #' |
||
| 90 | +192 |
- #'+ #' @examples |
||
| 91 | +193 |
- #'+ #' ## Table with default columns. |
||
| 92 | +194 |
- #' @keywords internal+ #' tabulate_survival_biomarkers(df) |
||
| 93 | +195 |
- h_glm_quasipoisson <- function(.var,+ #' |
||
| 94 | +196 |
- .df_row,+ #' ## Table with a manually chosen set of columns: leave out "pval", reorder. |
||
| 95 | +197 |
- variables,+ #' tab <- tabulate_survival_biomarkers( |
||
| 96 | +198 |
- weights) {
+ #' df = df, |
||
| 97 | -4x | +|||
| 199 | +
- arm <- variables$arm+ #' vars = c("n_tot_events", "ci", "n_tot", "median", "hr"),
|
|||
| 98 | -4x | +|||
| 200 | +
- covariates <- variables$covariates+ #' time_unit = as.character(adtte_f$AVALU[1]) |
|||
| 99 | -4x | +|||
| 201 | +
- offset <- .df_row[[variables$offset]]+ #' ) |
|||
| 100 | +202 |
-
+ #' |
||
| 101 | -2x | +|||
| 203 | +
- formula <- stats::as.formula(paste0(+ #' ## Finally produce the forest plot. |
|||
| 102 | -2x | +|||
| 204 | +
- .var, " ~ ",+ #' \donttest{
|
|||
| 103 | +205 |
- " + ",+ #' g_forest(tab, xlim = c(0.8, 1.2)) |
||
| 104 | -2x | +|||
| 206 | +
- paste(covariates, collapse = " + "),+ #' } |
|||
| 105 | +207 |
- " + ",+ #' |
||
| 106 | -2x | +|||
| 208 | +
- arm+ #' @export |
|||
| 107 | +209 |
- ))+ tabulate_survival_biomarkers <- function(df, |
||
| 108 | +210 |
-
+ vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
|
||
| 109 | -2x | +|||
| 211 | +
- glm_fit <- stats::glm(+ time_unit = NULL, |
|||
| 110 | -2x | +|||
| 212 | +
- formula = formula,+ .indent_mods = 0L) {
|
|||
| 111 | -2x | +213 | +3x |
- offset = offset,+ checkmate::assert_data_frame(df) |
| 112 | -2x | +214 | +3x |
- data = .df_row,+ checkmate::assert_character(df$biomarker) |
| 113 | -2x | +215 | +3x |
- family = stats::quasipoisson(link = "log")+ checkmate::assert_character(df$biomarker_label) |
| 114 | -+ | |||
| 216 | +3x |
- )+ checkmate::assert_subset(vars, c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"))
|
||
| 115 | +217 | |||
| 116 | -2x | +218 | +3x |
- emmeans_fit <- emmeans::emmeans(+ df_subs <- split(df, f = df$biomarker) |
| 117 | -2x | +219 | +3x |
- glm_fit,+ tabs <- lapply(df_subs, FUN = function(df_sub) {
|
| 118 | -2x | +220 | +5x |
- specs = arm,+ tab_sub <- h_tab_surv_one_biomarker( |
| 119 | -2x | +221 | +5x |
- data = .df_row,+ df = df_sub, |
| 120 | -2x | +222 | +5x |
- type = "response",+ vars = vars, |
| 121 | -2x | +223 | +5x |
- offset = 0,+ time_unit = time_unit, |
| 122 | -2x | +224 | +5x |
- weights = weights+ .indent_mods = .indent_mods |
| 123 | +225 |
- )+ ) |
||
| 124 | +226 | - - | -||
| 125 | -2x | -
- list(+ # Insert label row as first row in table. |
||
| 126 | -2x | +227 | +5x |
- glm_fit = glm_fit,+ label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1] |
| 127 | -2x | +228 | +5x |
- emmeans_fit = emmeans_fit+ tab_sub |
| 128 | +229 |
- )+ }) |
||
| 129 | -+ | |||
| 230 | +3x |
- }+ result <- do.call(rbind, tabs) |
||
| 130 | +231 | |||
| 131 | -+ | |||
| 232 | +3x |
- #' @describeIn h_glm_count Helper function to return the results of the+ n_tot_ids <- grep("^n_tot", vars)
|
||
| 132 | -+ | |||
| 233 | +3x |
- #' selected model (poisson, quasipoisson, negative binomial).+ hr_id <- match("hr", vars)
|
||
| 133 | -+ | |||
| 234 | +3x |
- #'+ ci_id <- match("ci", vars)
|
||
| 134 | -+ | |||
| 235 | +3x |
- #' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called+ structure( |
||
| 135 | -+ | |||
| 236 | +3x |
- #' in `.var` and `variables`.+ result, |
||
| 136 | -+ | |||
| 237 | +3x |
- #' @param variables (named `list` of `strings`)\cr list of additional analysis variables, with+ forest_header = paste0(c("Higher", "Lower"), "\nBetter"),
|
||
| 137 | -+ | |||
| 238 | +3x |
- #' expected elements:+ col_x = hr_id, |
||
| 138 | -+ | |||
| 239 | +3x |
- #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple+ col_ci = ci_id, |
||
| 139 | -+ | |||
| 240 | +3x |
- #' groups will be summarized. Specifically, the first level of `arm` variable is taken as the+ col_symbol_size = n_tot_ids[1] |
||
| 140 | +241 |
- #' reference group.+ ) |
||
| 141 | +242 |
- #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as+ } |
| 142 | +1 |
- #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`.+ #' Stack Multiple Grobs |
||
| 143 | +2 |
- #' * `offset` (`numeric`)\cr a numeric vector or scalar adding an offset.+ #' |
||
| 144 | +3 |
- #' @param distribution (`character`)\cr a character value specifying the distribution+ #' @description `r lifecycle::badge("stable")`
|
||
| 145 | +4 |
- #' used in the regression (poisson, quasipoisson).+ #' |
||
| 146 | +5 |
- #'+ #' Stack grobs as a new grob with 1 column and multiple rows layout. |
||
| 147 | +6 |
- #' @return+ #' |
||
| 148 | +7 |
- #' * `h_glm_count()` returns the results of the selected model.+ #' @param ... grobs. |
||
| 149 | +8 |
- #'+ #' @param grobs list of grobs. |
||
| 150 | +9 |
- #'+ #' @param padding unit of length 1, space between each grob. |
||
| 151 | +10 |
- #' @keywords internal+ #' @param vp a [viewport()] object (or `NULL`). |
||
| 152 | +11 |
- h_glm_count <- function(.var,+ #' @param name a character identifier for the grob. |
||
| 153 | +12 |
- .df_row,+ #' @param gp A [gpar()] object. |
||
| 154 | +13 |
- variables,+ #' |
||
| 155 | +14 |
- distribution,+ #' @return A `grob`. |
||
| 156 | +15 |
- weights) {
- |
- ||
| 157 | -11x | -
- if (distribution == "negbin") {
- |
- ||
| 158 | -! | -
- stop("negative binomial distribution is not currently available.")
+ #' |
||
| 159 | +16 |
- }- |
- ||
| 160 | -9x | -
- switch(distribution,+ #' @examples |
||
| 161 | -9x | +|||
| 17 | +
- poisson = h_glm_poisson(.var, .df_row, variables, weights),+ #' library(grid) |
|||
| 162 | -! | +|||
| 18 | +
- quasipoisson = h_glm_quasipoisson(.var, .df_row, variables, weights),+ #' |
|||
| 163 | -! | +|||
| 19 | +
- negbin = list() # h_glm_negbin(.var, .df_row, variables, weights) # nolint+ #' g1 <- circleGrob(gp = gpar(col = "blue")) |
|||
| 164 | +20 |
- )+ #' g2 <- circleGrob(gp = gpar(col = "red")) |
||
| 165 | +21 |
- }+ #' g3 <- textGrob("TEST TEXT")
|
||
| 166 | +22 |
-
+ #' grid.newpage() |
||
| 167 | +23 |
- #' @describeIn h_glm_count Helper function to return the estimated means.+ #' grid.draw(stack_grobs(g1, g2, g3)) |
||
| 168 | +24 |
#' |
||
| 169 | +25 |
- #' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called in `.var` and `variables`.+ #' showViewport() |
||
| 170 | +26 |
- #' @param conf_level (`numeric`)\cr value used to derive the confidence interval for the rate.+ #' |
||
| 171 | +27 |
- #' @param obj (`glm.fit`)\cr fitted model object used to derive the mean rate estimates in each treatment arm.+ #' grid.newpage() |
||
| 172 | +28 |
- #' @param arm (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be+ #' pushViewport(viewport(layout = grid.layout(1, 2))) |
||
| 173 | +29 |
- #' summarized. Specifically, the first level of `arm` variable is taken as the reference group.+ #' vp1 <- viewport(layout.pos.row = 1, layout.pos.col = 2) |
||
| 174 | +30 |
- #'+ #' grid.draw(stack_grobs(g1, g2, g3, vp = vp1, name = "test")) |
||
| 175 | +31 |
- #' @return+ #' |
||
| 176 | +32 |
- #' * `h_ppmeans()` returns the estimated means.+ #' showViewport() |
||
| 177 | +33 |
- #'+ #' grid.ls(grobs = TRUE, viewports = TRUE, print = FALSE) |
||
| 178 | +34 |
#' |
||
| 179 | +35 |
- #' @keywords internal+ #' @export |
||
| 180 | +36 |
- h_ppmeans <- function(obj, .df_row, arm, conf_level) {
- |
- ||
| 181 | -! | -
- alpha <- 1 - conf_level- |
- ||
| 182 | -! | -
- p <- 1 - alpha / 2+ stack_grobs <- function(..., |
||
| 183 | +37 | - - | -||
| 184 | -! | -
- arm_levels <- levels(.df_row[[arm]])+ grobs = list(...), |
||
| 185 | +38 | - - | -||
| 186 | -! | -
- out <- lapply(arm_levels, function(lev) {
- |
- ||
| 187 | -! | -
- temp <- .df_row- |
- ||
| 188 | -! | -
- temp[[arm]] <- factor(lev, levels = arm_levels)+ padding = grid::unit(2, "line"), |
||
| 189 | +39 | - - | -||
| 190 | -! | -
- mf <- stats::model.frame(obj$formula, data = temp)- |
- ||
| 191 | -! | -
- X <- stats::model.matrix(obj$formula, data = mf) # nolint+ vp = NULL, |
||
| 192 | +40 | - - | -||
| 193 | -! | -
- rate <- stats::predict(obj, newdata = mf, type = "response")- |
- ||
| 194 | -! | -
- rate_hat <- mean(rate)+ gp = NULL, |
||
| 195 | +41 | - - | -||
| 196 | -! | -
- zz <- colMeans(rate * X)- |
- ||
| 197 | -! | -
- se <- sqrt(as.numeric(t(zz) %*% stats::vcov(obj) %*% zz))- |
- ||
| 198 | -! | -
- rate_lwr <- rate_hat * exp(-stats::qnorm(p) * se / rate_hat)- |
- ||
| 199 | -! | -
- rate_upr <- rate_hat * exp(stats::qnorm(p) * se / rate_hat)+ name = NULL) {
|
||
| 200 | -+ | |||
| 42 | +4x |
-
+ checkmate::assert_true( |
||
| 201 | -! | +|||
| 43 | +4x |
- c(rate_hat, rate_lwr, rate_upr)+ all(vapply(grobs, grid::is.grob, logical(1))) |
||
| 202 | +44 |
- })+ ) |
||
| 203 | +45 | |||
| 204 | -! | -
- names(out) <- arm_levels- |
- ||
| 205 | -! | -
- out <- do.call(rbind, out)- |
- ||
| 206 | -! | +|||
| 46 | +4x |
- if ("negbin" %in% class(obj)) {
+ if (length(grobs) == 1) {
|
||
| 207 | -! | +|||
| 47 | +1x |
- colnames(out) <- c("response", "asymp.LCL", "asymp.UCL")
+ return(grobs[[1]]) |
||
| 208 | +48 |
- } else {
- |
- ||
| 209 | -! | -
- colnames(out) <- c("rate", "asymp.LCL", "asymp.UCL")
+ } |
||
| 210 | +49 |
- }- |
- ||
| 211 | -! | -
- out <- as.data.frame(out)- |
- ||
| 212 | -! | -
- out[[arm]] <- rownames(out)+ |
||
| 213 | -! | +|||
| 50 | +3x |
- out+ n_layout <- 2 * length(grobs) - 1 |
||
| 214 | -+ | |||
| 51 | +3x |
- }+ hts <- lapply( |
||
| 215 | -+ | |||
| 52 | +3x |
-
+ seq(1, n_layout), |
||
| 216 | -+ | |||
| 53 | +3x |
- #' @describeIn summarize_glm_count Statistics function that produces a named list of results+ function(i) {
|
||
| 217 | -+ | |||
| 54 | +39x |
- #' of the investigated Poisson model.+ if (i %% 2 != 0) {
|
||
| 218 | -+ | |||
| 55 | +21x |
- #'+ grid::unit(1, "null") |
||
| 219 | +56 |
- #' @inheritParams h_glm_count+ } else {
|
||
| 220 | -+ | |||
| 57 | +18x |
- #'+ padding |
||
| 221 | +58 |
- #' @return+ } |
||
| 222 | +59 |
- #' * `s_glm_count()` returns a named `list` of 5 statistics:+ } |
||
| 223 | +60 |
- #' * `n`: Count of complete sample size for the group.+ ) |
||
| 224 | -+ | |||
| 61 | +3x |
- #' * `rate`: Estimated event rate per follow-up time.+ hts <- do.call(grid::unit.c, hts) |
||
| 225 | +62 |
- #' * `rate_ci`: Confidence level for estimated rate per follow-up time.+ |
||
| 226 | -+ | |||
| 63 | +3x |
- #' * `rate_ratio`: Ratio of event rates in each treatment arm to the reference arm.+ main_vp <- grid::viewport( |
||
| 227 | -+ | |||
| 64 | +3x |
- #' * `rate_ratio_ci`: Confidence level for the rate ratio.+ layout = grid::grid.layout(nrow = n_layout, ncol = 1, heights = hts) |
||
| 228 | +65 |
- #' * `pval`: p-value.+ ) |
||
| 229 | +66 |
- #'+ |
||
| 230 | -+ | |||
| 67 | +3x |
- #'+ nested_grobs <- Map(function(g, i) {
|
||
| 231 | -+ | |||
| 68 | +21x |
- #' @keywords internal+ grid::gTree( |
||
| 232 | -+ | |||
| 69 | +21x |
- s_glm_count <- function(df,+ children = grid::gList(g), |
||
| 233 | -+ | |||
| 70 | +21x |
- .var,+ vp = grid::viewport(layout.pos.row = i, layout.pos.col = 1) |
||
| 234 | +71 |
- .df_row,+ ) |
||
| 235 | -+ | |||
| 72 | +3x |
- variables,+ }, grobs, seq_along(grobs) * 2 - 1) |
||
| 236 | +73 |
- .ref_group,+ |
||
| 237 | -+ | |||
| 74 | +3x |
- .in_ref_col,+ grobs_mainvp <- grid::gTree( |
||
| 238 | -+ | |||
| 75 | +3x |
- distribution,+ children = do.call(grid::gList, nested_grobs), |
||
| 239 | -+ | |||
| 76 | +3x |
- conf_level,+ vp = main_vp |
||
| 240 | +77 |
- rate_mean_method,+ ) |
||
| 241 | +78 |
- weights,+ |
||
| 242 | -+ | |||
| 79 | +3x |
- scale = 1) {
+ grid::gTree( |
||
| 243 | +80 | 3x |
- arm <- variables$arm+ children = grid::gList(grobs_mainvp), |
|
| 244 | -+ | |||
| 81 | +3x |
-
+ vp = vp, |
||
| 245 | +82 | 3x |
- y <- df[[.var]]+ gp = gp, |
|
| 246 | -2x | +83 | +3x |
- smry_level <- as.character(unique(df[[arm]]))+ name = name |
| 247 | +84 |
-
+ ) |
||
| 248 | +85 |
- # ensure there is only 1 value- |
- ||
| 249 | -2x | -
- checkmate::assert_scalar(smry_level)+ } |
||
| 250 | +86 | - | -||
| 251 | -2x | -
- results <- h_glm_count(- |
- ||
| 252 | -2x | + +|||
| 87 | +
- .var = .var,+ #' Arrange Multiple Grobs |
|||
| 253 | -2x | +|||
| 88 | +
- .df_row = .df_row,+ #' |
|||
| 254 | -2x | +|||
| 89 | +
- variables = variables,+ #' Arrange grobs as a new grob with \verb{n*m (rows*cols)} layout.
|
|||
| 255 | -2x | +|||
| 90 | +
- distribution = distribution,+ #' |
|||
| 256 | -2x | +|||
| 91 | +
- weights+ #' @inheritParams stack_grobs |
|||
| 257 | +92 |
- )+ #' @param ncol number of columns in layout. |
||
| 258 | +93 |
-
+ #' @param nrow number of rows in layout. |
||
| 259 | -2x | +|||
| 94 | +
- if (rate_mean_method == "emmeans") {
+ #' @param padding_ht unit of length 1, vertical space between each grob. |
|||
| 260 | -2x | +|||
| 95 | +
- emmeans_smry <- summary(results$emmeans_fit, level = conf_level)+ #' @param padding_wt unit of length 1, horizontal space between each grob. |
|||
| 261 | -! | +|||
| 96 | +
- } else if (rate_mean_method == "ppmeans") {
+ #' |
|||
| 262 | -! | +|||
| 97 | +
- emmeans_smry <- h_ppmeans(results$glm_fit, .df_row, arm, conf_level)+ #' @return A `grob`. |
|||
| 263 | +98 |
- }+ #' @examples |
||
| 264 | +99 |
-
+ #' library(grid) |
||
| 265 | -2x | +|||
| 100 | +
- emmeans_smry_level <- emmeans_smry[emmeans_smry[[arm]] == smry_level, ]+ #' |
|||
| 266 | +101 |
-
+ #' \donttest{
|
||
| 267 | -2x | +|||
| 102 | +
- if (.in_ref_col) {
+ #' num <- lapply(1:9, textGrob) |
|||
| 268 | -1x | +|||
| 103 | +
- list(+ #' grid::grid.newpage() |
|||
| 269 | -1x | +|||
| 104 | +
- n = length(y[!is.na(y)]),+ #' grid.draw(arrange_grobs(grobs = num, ncol = 2)) |
|||
| 270 | -1x | +|||
| 105 | +
- rate = formatters::with_label(+ #' |
|||
| 271 | -1x | +|||
| 106 | +
- ifelse(distribution == "negbin", emmeans_smry_level$response * scale, emmeans_smry_level$rate),+ #' showViewport() |
|||
| 272 | -1x | +|||
| 107 | +
- "Adjusted Rate"+ #' |
|||
| 273 | +108 |
- ),+ #' g1 <- circleGrob(gp = gpar(col = "blue")) |
||
| 274 | -1x | +|||
| 109 | +
- rate_ci = formatters::with_label(+ #' g2 <- circleGrob(gp = gpar(col = "red")) |
|||
| 275 | -1x | +|||
| 110 | +
- c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale),+ #' g3 <- textGrob("TEST TEXT")
|
|||
| 276 | -1x | +|||
| 111 | +
- f_conf_level(conf_level)+ #' grid::grid.newpage() |
|||
| 277 | +112 |
- ),+ #' grid.draw(arrange_grobs(g1, g2, g3, nrow = 2)) |
||
| 278 | -1x | +|||
| 113 | +
- rate_ratio = formatters::with_label(character(), "Adjusted Rate Ratio"),+ #' |
|||
| 279 | -1x | +|||
| 114 | +
- rate_ratio_ci = formatters::with_label(character(), f_conf_level(conf_level)),+ #' showViewport() |
|||
| 280 | -1x | +|||
| 115 | +
- pval = formatters::with_label(character(), "p-value")+ #' |
|||
| 281 | +116 |
- )+ #' grid::grid.newpage() |
||
| 282 | +117 |
- } else {
+ #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 3)) |
||
| 283 | -1x | +|||
| 118 | +
- emmeans_contrasts <- emmeans::contrast(+ #' |
|||
| 284 | -1x | +|||
| 119 | +
- results$emmeans_fit,+ #' grid::grid.newpage() |
|||
| 285 | -1x | +|||
| 120 | +
- method = "trt.vs.ctrl",+ #' grid::pushViewport(grid::viewport(layout = grid::grid.layout(1, 2))) |
|||
| 286 | -1x | +|||
| 121 | +
- ref = grep(+ #' vp1 <- grid::viewport(layout.pos.row = 1, layout.pos.col = 2) |
|||
| 287 | -1x | +|||
| 122 | +
- as.character(unique(.ref_group[[arm]])),+ #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 2, vp = vp1)) |
|||
| 288 | -1x | +|||
| 123 | +
- as.data.frame(results$emmeans_fit)[[arm]]+ #' |
|||
| 289 | +124 |
- )+ #' showViewport() |
||
| 290 | +125 |
- )+ #' } |
||
| 291 | +126 |
-
+ #' @export |
||
| 292 | -1x | +|||
| 127 | +
- contrasts_smry <- summary(+ arrange_grobs <- function(..., |
|||
| 293 | -1x | +|||
| 128 | +
- emmeans_contrasts,+ grobs = list(...), |
|||
| 294 | -1x | +|||
| 129 | +
- infer = TRUE,+ ncol = NULL, nrow = NULL, |
|||
| 295 | -1x | +|||
| 130 | +
- adjust = "none"+ padding_ht = grid::unit(2, "line"), |
|||
| 296 | +131 |
- )+ padding_wt = grid::unit(2, "line"), |
||
| 297 | +132 |
-
+ vp = NULL, |
||
| 298 | -1x | +|||
| 133 | +
- smry_contrasts_level <- contrasts_smry[grepl(smry_level, contrasts_smry$contrast), ]+ gp = NULL, |
|||
| 299 | +134 |
-
+ name = NULL) {
|
||
| 300 | -1x | +135 | +5x |
- list(+ checkmate::assert_true( |
| 301 | -1x | +136 | +5x |
- n = length(y[!is.na(y)]),+ all(vapply(grobs, grid::is.grob, logical(1))) |
| 302 | -1x | +|||
| 137 | +
- rate = formatters::with_label(+ )+ |
+ |||
| 138 | ++ | + | ||
| 303 | -1x | +139 | +5x |
- ifelse(distribution == "negbin", emmeans_smry_level$response * scale, emmeans_smry_level$rate),+ if (length(grobs) == 1) {
|
| 304 | +140 | 1x |
- "Adjusted Rate"+ return(grobs[[1]]) |
|
| 305 | +141 |
- ),+ }+ |
+ ||
| 142 | ++ | + | ||
| 306 | -1x | +143 | +4x |
- rate_ci = formatters::with_label(+ if (is.null(ncol) && is.null(nrow)) {
|
| 307 | +144 | 1x |
- c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale),+ ncol <- 1 |
|
| 308 | +145 | 1x |
- f_conf_level(conf_level)+ nrow <- ceiling(length(grobs) / ncol) |
|
| 309 | -+ | |||
| 146 | +3x |
- ),+ } else if (!is.null(ncol) && is.null(nrow)) {
|
||
| 310 | +147 | 1x |
- rate_ratio = formatters::with_label(smry_contrasts_level$ratio, "Adjusted Rate Ratio"),+ nrow <- ceiling(length(grobs) / ncol) |
|
| 311 | -1x | +148 | +2x |
- rate_ratio_ci = formatters::with_label(+ } else if (is.null(ncol) && !is.null(nrow)) {
|
| 312 | -1x | +|||
| 149 | +! |
- c(smry_contrasts_level$asymp.LCL, smry_contrasts_level$asymp.UCL),+ ncol <- ceiling(length(grobs) / nrow) |
||
| 313 | -1x | +|||
| 150 | +
- f_conf_level(conf_level)+ } |
|||
| 314 | +151 |
- ),+ |
||
| 315 | -1x | +152 | +4x |
- pval = formatters::with_label(smry_contrasts_level$p.value, "p-value")+ if (ncol * nrow < length(grobs)) {
|
| 316 | -+ | |||
| 153 | +1x |
- )+ stop("specififed ncol and nrow are not enough for arranging the grobs ")
|
||
| 317 | +154 |
} |
||
| 318 | +155 |
- }+ |
||
| 319 | -+ | |||
| 156 | +3x |
-
+ if (ncol == 1) {
|
||
| 320 | -+ | |||
| 157 | +2x |
- #' @describeIn summarize_glm_count Formatted analysis function which is used as `afun` in `summarize_glm_count()`.+ return(stack_grobs(grobs = grobs, padding = padding_ht, vp = vp, gp = gp, name = name)) |
||
| 321 | +158 |
- #'+ } |
||
| 322 | +159 |
- #' @return+ |
||
| 323 | -+ | |||
| 160 | +1x |
- #' * `a_glm_count()` returns the corresponding list with formatted [rtables::CellValue()].+ n_col <- 2 * ncol - 1 |
||
| 324 | -+ | |||
| 161 | +1x |
- #'+ n_row <- 2 * nrow - 1 |
||
| 325 | -+ | |||
| 162 | +1x |
- #'+ hts <- lapply( |
||
| 326 | -+ | |||
| 163 | +1x |
- #' @keywords internal+ seq(1, n_row), |
||
| 327 | -+ | |||
| 164 | +1x |
- a_glm_count <- make_afun(+ function(i) {
|
||
| 328 | -+ | |||
| 165 | +5x |
- s_glm_count,+ if (i %% 2 != 0) {
|
||
| 329 | -+ | |||
| 166 | +3x |
- .indent_mods = c(+ grid::unit(1, "null") |
||
| 330 | +167 |
- "n" = 0L,+ } else {
|
||
| 331 | -+ | |||
| 168 | +2x |
- "rate" = 0L,+ padding_ht |
||
| 332 | +169 |
- "rate_ci" = 1L,+ } |
||
| 333 | +170 |
- "rate_ratio" = 0L,+ } |
||
| 334 | +171 |
- "rate_ratio_ci" = 1L,+ ) |
||
| 335 | -+ | |||
| 172 | +1x |
- "pval" = 1L+ hts <- do.call(grid::unit.c, hts) |
||
| 336 | +173 |
- ),+ |
||
| 337 | -+ | |||
| 174 | +1x |
- .formats = c(+ wts <- lapply( |
||
| 338 | -+ | |||
| 175 | +1x |
- "n" = "xx",+ seq(1, n_col), |
||
| 339 | -+ | |||
| 176 | +1x |
- "rate" = "xx.xxxx",+ function(i) {
|
||
| 340 | -+ | |||
| 177 | +5x |
- "rate_ci" = "(xx.xxxx, xx.xxxx)",+ if (i %% 2 != 0) {
|
||
| 341 | -+ | |||
| 178 | +3x |
- "rate_ratio" = "xx.xxxx",+ grid::unit(1, "null") |
||
| 342 | +179 |
- "rate_ratio_ci" = "(xx.xxxx, xx.xxxx)",+ } else {
|
||
| 343 | -+ | |||
| 180 | +2x |
- "pval" = "x.xxxx | (<0.0001)"+ padding_wt |
||
| 344 | +181 |
- ),+ } |
||
| 345 | +182 |
- .null_ref_cells = FALSE+ } |
||
| 346 | +183 |
- )+ ) |
||
| 347 | -+ | |||
| 184 | +1x |
-
+ wts <- do.call(grid::unit.c, wts) |
||
| 348 | +185 |
- #' @describeIn summarize_glm_count Layout-creating function which can take statistics function arguments+ |
||
| 349 | -+ | |||
| 186 | +1x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ main_vp <- grid::viewport( |
||
| 350 | -+ | |||
| 187 | +1x |
- #'+ layout = grid::grid.layout(nrow = n_row, ncol = n_col, widths = wts, heights = hts) |
||
| 351 | +188 |
- #' @return+ ) |
||
| 352 | +189 |
- #' * `summarize_glm_count()` returns a layout object suitable for passing to further layouting functions,+ |
||
| 353 | -+ | |||
| 190 | +1x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ nested_grobs <- list() |
||
| 354 | -+ | |||
| 191 | +1x |
- #' the statistics from `s_glm_count()` to the table layout.+ k <- 0 |
||
| 355 | -+ | |||
| 192 | +1x |
- #'+ for (i in seq(nrow) * 2 - 1) {
|
||
| 356 | -+ | |||
| 193 | +3x |
- #' @examples+ for (j in seq(ncol) * 2 - 1) {
|
||
| 357 | -+ | |||
| 194 | +9x |
- #' library(dplyr)+ k <- k + 1 |
||
| 358 | -+ | |||
| 195 | +9x |
- #' anl <- tern_ex_adtte %>% filter(PARAMCD == "TNE")+ if (k <= length(grobs)) {
|
||
| 359 | -+ | |||
| 196 | +9x |
- #' anl$AVAL_f <- as.factor(anl$AVAL)+ nested_grobs <- c( |
||
| 360 | -+ | |||
| 197 | +9x |
- #'+ nested_grobs, |
||
| 361 | -+ | |||
| 198 | +9x |
- #' lyt <- basic_table() %>%+ list(grid::gTree( |
||
| 362 | -+ | |||
| 199 | +9x |
- #' split_cols_by("ARM", ref_group = "B: Placebo") %>%
+ children = grid::gList(grobs[[k]]), |
||
| 363 | -+ | |||
| 200 | +9x |
- #' add_colcounts() %>%+ vp = grid::viewport(layout.pos.row = i, layout.pos.col = j) |
||
| 364 | +201 |
- #' analyze_vars(+ )) |
||
| 365 | +202 |
- #' "AVAL_f",+ ) |
||
| 366 | +203 |
- #' var_labels = "Number of exacerbations per patient",+ } |
||
| 367 | +204 |
- #' .stats = c("count_fraction"),
+ } |
||
| 368 | +205 |
- #' .formats = c("count_fraction" = "xx (xx.xx%)"),
+ } |
||
| 369 | -+ | |||
| 206 | +1x |
- #' .label = c("Number of exacerbations per patient")
+ grobs_mainvp <- grid::gTree( |
||
| 370 | -+ | |||
| 207 | +1x |
- #' ) %>%+ children = do.call(grid::gList, nested_grobs), |
||
| 371 | -+ | |||
| 208 | +1x |
- #' summarize_glm_count(+ vp = main_vp |
||
| 372 | +209 |
- #' vars = "AVAL",+ ) |
||
| 373 | +210 |
- #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = NULL),+ |
||
| 374 | -+ | |||
| 211 | +1x |
- #' conf_level = 0.95,+ grid::gTree( |
||
| 375 | -+ | |||
| 212 | +1x |
- #' distribution = "poisson",+ children = grid::gList(grobs_mainvp), |
||
| 376 | -+ | |||
| 213 | +1x |
- #' rate_mean_method = "emmeans",+ vp = vp, |
||
| 377 | -+ | |||
| 214 | +1x |
- #' var_labels = "Unadjusted exacerbation rate (per year)",+ gp = gp, |
||
| 378 | -+ | |||
| 215 | +1x |
- #' table_names = "unadj",+ name = name |
||
| 379 | +216 |
- #' .stats = c("rate"),
+ ) |
||
| 380 | +217 |
- #' .labels = c(rate = "Rate")+ } |
||
| 381 | +218 |
- #' ) %>%+ |
||
| 382 | +219 |
- #' summarize_glm_count(+ #' Draw `grob` |
||
| 383 | +220 |
- #' vars = "AVAL",+ #' |
||
| 384 | +221 |
- #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = c("REGION1")),
+ #' @description `r lifecycle::badge("stable")`
|
||
| 385 | +222 |
- #' conf_level = 0.95,+ #' |
||
| 386 | +223 |
- #' distribution = "quasipoisson",+ #' Draw grob on device page. |
||
| 387 | +224 |
- #' rate_mean_method = "ppmeans",+ #' |
||
| 388 | +225 |
- #' var_labels = "Adjusted (QP) exacerbation rate (per year)",+ #' @param grob grid object |
||
| 389 | +226 |
- #' table_names = "adj",+ #' @param newpage draw on a new page |
||
| 390 | +227 |
- #' .stats = c("rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
+ #' @param vp a [viewport()] object (or `NULL`). |
||
| 391 | +228 |
- #' .labels = c(+ #' |
||
| 392 | +229 |
- #' rate = "Rate", rate_ci = "Rate CI", rate_ratio = "Rate Ratio",+ #' @return A `grob`. |
||
| 393 | +230 |
- #' rate_ratio_ci = "Rate Ratio CI", pval = "p value"+ #' |
||
| 394 | +231 |
- #' )+ #' @examples |
||
| 395 | +232 |
- #' )+ #' library(dplyr) |
||
| 396 | +233 |
- #' build_table(lyt = lyt, df = anl)+ #' library(grid) |
||
| 397 | +234 |
#' |
||
| 398 | +235 |
- #' @export+ #' \donttest{
|
||
| 399 | +236 |
- summarize_glm_count <- function(lyt,+ #' rect <- rectGrob(width = grid::unit(0.5, "npc"), height = grid::unit(0.5, "npc")) |
||
| 400 | +237 |
- vars,+ #' rect %>% draw_grob(vp = grid::viewport(angle = 45)) |
||
| 401 | +238 |
- var_labels,+ #' |
||
| 402 | +239 |
- nested = TRUE,+ #' num <- lapply(1:10, textGrob) |
||
| 403 | +240 |
- ...,+ #' num %>% |
||
| 404 | +241 |
- show_labels = "visible",+ #' arrange_grobs(grobs = .) %>% |
||
| 405 | +242 |
- table_names = vars,+ #' draw_grob() |
||
| 406 | +243 |
- .stats = NULL,+ #' showViewport() |
||
| 407 | +244 |
- .formats = NULL,+ #' } |
||
| 408 | +245 |
- .labels = NULL,+ #' |
||
| 409 | +246 |
- .indent_mods = NULL) {
+ #' @export |
||
| 410 | -1x | +|||
| 247 | +
- afun <- make_afun(+ draw_grob <- function(grob, newpage = TRUE, vp = NULL) {
|
|||
| 411 | -1x | +248 | +3x |
- a_glm_count,+ if (newpage) {
|
| 412 | -1x | +249 | +3x |
- .stats = .stats,+ grid::grid.newpage() |
| 413 | -1x | +|||
| 250 | +
- .formats = .formats,+ } |
|||
| 414 | -1x | +251 | +3x |
- .labels = .labels,+ if (!is.null(vp)) {
|
| 415 | +252 | 1x |
- .indent_mods = .indent_mods- |
- |
| 416 | -- |
- )+ grid::pushViewport(vp) |
||
| 417 | +253 |
-
+ } |
||
| 418 | -1x | +254 | +3x |
- analyze(+ grid::grid.draw(grob) |
| 419 | -1x | +|||
| 255 | ++ |
+ }+ |
+ ||
| 256 | +
- lyt,+ |
|||
| 420 | -1x | +|||
| 257 | +
- vars,+ tern_grob <- function(x) {
|
|||
| 421 | -1x | +|||
| 258 | +! |
- var_labels = var_labels,+ class(x) <- unique(c("ternGrob", class(x)))
|
||
| 422 | -1x | +|||
| 259 | +! |
- show_labels = show_labels,+ x |
||
| 423 | -1x | +|||
| 260 | +
- table_names = table_names,+ } |
|||
| 424 | -1x | +|||
| 261 | +
- afun = afun,+ |
|||
| 425 | -1x | +|||
| 262 | +
- nested = nested,+ print.ternGrob <- function(x, ...) {
|
|||
| 426 | -1x | +|||
| 263 | +! |
- extra_args = list(...)+ grid::grid.newpage() |
||
| 427 | -+ | |||
| 264 | +! |
- )+ grid::grid.draw(x) |
||
| 428 | +265 |
}@@ -146546,14 +146329,14 @@ tern coverage - 94.83% |
| 1 |
- #' Subgroup Treatment Effect Pattern (STEP) Fit for Binary (Response) Outcome+ #' Helper Functions for Tabulating Biomarker Effects on Survival by Subgroup |
||
| 5 |
- #' This fits the Subgroup Treatment Effect Pattern logistic regression models for a binary+ #' Helper functions which are documented here separately to not confuse the user |
||
| 6 |
- #' (response) outcome. The treatment arm variable must have exactly 2 levels,+ #' when reading about the user-facing functions. |
||
| 7 |
- #' where the first one is taken as reference and the estimated odds ratios are+ #' |
||
| 8 |
- #' for the comparison of the second level vs. the first one.+ #' @inheritParams survival_biomarkers_subgroups |
||
| 9 |
- #'+ #' @inheritParams argument_convention |
||
| 10 |
- #' The (conditional) logistic regression model which is fit is:+ #' @inheritParams fit_coxreg_multivar |
||
| 12 |
- #' `response ~ arm * poly(biomarker, degree) + covariates + strata(strata)`+ #' @examples |
||
| 13 |
- #'+ #' library(dplyr) |
||
| 14 |
- #' where `degree` is specified by `control_step()`.+ #' library(forcats) |
||
| 16 |
- #' @inheritParams argument_convention+ #' adtte <- tern_ex_adtte |
||
| 17 |
- #' @param variables (named `list` of `character`)\cr list of analysis variables:+ #' |
||
| 18 |
- #' needs `response`, `arm`, `biomarker`, and optional `covariates` and `strata`.+ #' # Save variable labels before data processing steps. |
||
| 19 |
- #' @param control (named `list`)\cr combined control list from [control_step()]+ #' adtte_labels <- formatters::var_labels(adtte, fill = FALSE) |
||
| 20 |
- #' and [control_logistic()].+ #' |
||
| 21 |
- #'+ #' adtte_f <- adtte %>% |
||
| 22 |
- #' @return A matrix of class `step`. The first part of the columns describe the+ #' filter(PARAMCD == "OS") %>% |
||
| 23 |
- #' subgroup intervals used for the biomarker variable, including where the+ #' mutate( |
||
| 24 |
- #' center of the intervals are and their bounds. The second part of the+ #' AVALU = as.character(AVALU), |
||
| 25 |
- #' columns contain the estimates for the treatment arm comparison.+ #' is_event = CNSR == 0 |
||
| 26 |
- #'+ #' ) |
||
| 27 |
- #' @note For the default degree 0 the `biomarker` variable is not included in the model.+ #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
|
||
| 28 |
- #'+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
||
| 29 |
- #' @seealso [control_step()] and [control_logistic()] for the available+ #' |
||
| 30 |
- #' customization options.+ #' @name h_survival_biomarkers_subgroups |
||
| 31 |
- #'+ NULL |
||
| 32 |
- #' @examples+ |
||
| 33 |
- #' # Testing dataset with just two treatment arms.+ #' @describeIn h_survival_biomarkers_subgroups helps with converting the "survival" function variable list |
||
| 34 |
- #' library(survival)+ #' to the "Cox regression" variable list. The reason is that currently there is an inconsistency between the variable |
||
| 35 |
- #' library(dplyr)+ #' names accepted by `extract_survival_subgroups()` and `fit_coxreg_multivar()`. |
||
| 37 |
- #' adrs_f <- tern_ex_adrs %>%+ #' @param biomarker (`string`)\cr the name of the biomarker variable. |
||
| 38 |
- #' filter(+ #' |
||
| 39 |
- #' PARAMCD == "BESRSPI",+ #' @return |
||
| 40 |
- #' ARM %in% c("B: Placebo", "A: Drug X")
+ #' * `h_surv_to_coxreg_variables()` returns a named `list` of elements `time`, `event`, `arm`, |
||
| 41 |
- #' ) %>%+ #' `covariates`, and `strata`. |
||
| 42 |
- #' mutate(+ #' |
||
| 43 |
- #' # Reorder levels of ARM to have Placebo as reference arm for Odds Ratio calculations.+ #' @examples |
||
| 44 |
- #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")),+ #' # This is how the variable list is converted internally. |
||
| 45 |
- #' RSP = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ #' h_surv_to_coxreg_variables( |
||
| 46 |
- #' SEX = factor(SEX)+ #' variables = list( |
||
| 47 |
- #' )+ #' tte = "AVAL", |
||
| 48 |
- #'+ #' is_event = "EVNT", |
||
| 49 |
- #' variables <- list(+ #' covariates = c("A", "B"),
|
||
| 50 |
- #' arm = "ARM",+ #' strata = "D" |
||
| 51 |
- #' biomarker = "BMRKR1",+ #' ), |
||
| 52 |
- #' covariates = "AGE",+ #' biomarker = "AGE" |
||
| 53 |
- #' response = "RSP"+ #' ) |
||
| 54 |
- #' )+ #' |
||
| 55 |
- #'+ #' @export |
||
| 56 |
- #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup.+ h_surv_to_coxreg_variables <- function(variables, biomarker) {
|
||
| 57 | -+ | 41x |
- #' # We use a large enough bandwidth to avoid too small subgroups and linear separation in those.+ checkmate::assert_list(variables) |
| 58 | -+ | 41x |
- #' step_matrix <- fit_rsp_step(+ checkmate::assert_string(variables$tte) |
| 59 | -+ | 41x |
- #' variables = variables,+ checkmate::assert_string(variables$is_event) |
| 60 | -+ | 41x |
- #' data = adrs_f,+ checkmate::assert_string(biomarker) |
| 61 | -+ | 41x |
- #' control = c(control_logistic(), control_step(bandwidth = 0.5))+ list( |
| 62 | -+ | 41x |
- #' )+ time = variables$tte, |
| 63 | -+ | 41x |
- #' dim(step_matrix)+ event = variables$is_event, |
| 64 | -+ | 41x |
- #' head(step_matrix)+ arm = biomarker, |
| 65 | -+ | 41x |
- #'+ covariates = variables$covariates, |
| 66 | -+ | 41x |
- #' # Specify different polynomial degree for the biomarker interaction to use more flexible local+ strata = variables$strata |
| 67 |
- #' # models. Or specify different logistic regression options, including confidence level.+ ) |
||
| 68 |
- #' step_matrix2 <- fit_rsp_step(+ } |
||
| 69 |
- #' variables = variables,+ |
||
| 70 |
- #' data = adrs_f,+ #' @describeIn h_survival_biomarkers_subgroups prepares estimates for number of events, patients and median survival |
||
| 71 |
- #' control = c(control_logistic(conf_level = 0.9), control_step(bandwidth = 0.6, degree = 1))+ #' times, as well as hazard ratio estimates, confidence intervals and p-values, for multiple biomarkers |
||
| 72 |
- #' )+ #' in a given single data set. |
||
| 73 |
- #'+ #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements |
||
| 74 |
- #' # Use a global constant model. This is helpful as a reference for the subgroup models.+ #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables) and optionally `subgroups` and `strat`. |
||
| 75 |
- #' step_matrix3 <- fit_rsp_step(+ #' |
||
| 76 |
- #' variables = variables,+ #' @return |
||
| 77 |
- #' data = adrs_f,+ #' * `h_coxreg_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers. |
||
| 78 |
- #' control = c(control_logistic(), control_step(bandwidth = NULL, num_points = 2L))+ #' |
||
| 79 |
- #' )+ #' @examples |
||
| 80 |
- #'+ #' # For a single population, estimate separately the effects |
||
| 81 |
- #' # It is also possible to use strata, i.e. use conditional logistic regression models.+ #' # of two biomarkers. |
||
| 82 |
- #' variables2 <- list(+ #' df <- h_coxreg_mult_cont_df( |
||
| 83 |
- #' arm = "ARM",+ #' variables = list( |
||
| 84 |
- #' biomarker = "BMRKR1",+ #' tte = "AVAL", |
||
| 85 |
- #' covariates = "AGE",+ #' is_event = "is_event", |
||
| 86 |
- #' response = "RSP",+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 87 |
- #' strata = c("STRATA1", "STRATA2")
+ #' covariates = "SEX", |
||
| 88 |
- #' )+ #' strata = c("STRATA1", "STRATA2")
|
||
| 89 |
- #'+ #' ), |
||
| 90 |
- #' step_matrix4 <- fit_rsp_step(+ #' data = adtte_f |
||
| 91 |
- #' variables = variables2,+ #' ) |
||
| 92 |
- #' data = adrs_f,+ #' df |
||
| 93 |
- #' control = c(control_logistic(), control_step(bandwidth = 0.6))+ #' |
||
| 94 |
- #' )+ #' # If the data set is empty, still the corresponding rows with missings are returned. |
||
| 95 |
- #'+ #' h_coxreg_mult_cont_df( |
||
| 96 |
- #' @export+ #' variables = list( |
||
| 97 |
- fit_rsp_step <- function(variables,+ #' tte = "AVAL", |
||
| 98 |
- data,+ #' is_event = "is_event", |
||
| 99 |
- control = c(control_step(), control_logistic())) {
+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 100 | -5x | +
- assert_df_with_variables(data, variables)+ #' covariates = "REGION1", |
|
| 101 | -5x | +
- checkmate::assert_list(control, names = "named")+ #' strata = c("STRATA1", "STRATA2")
|
|
| 102 | -5x | +
- data <- data[!is.na(data[[variables$biomarker]]), ]+ #' ), |
|
| 103 | -5x | +
- window_sel <- h_step_window(x = data[[variables$biomarker]], control = control)+ #' data = adtte_f[NULL, ] |
|
| 104 | -5x | +
- interval_center <- window_sel$interval[, "Interval Center"]+ #' ) |
|
| 105 | -5x | +
- form <- h_step_rsp_formula(variables = variables, control = control)+ #' |
|
| 106 | -5x | +
- estimates <- if (is.null(control$bandwidth)) {
+ #' @export |
|
| 107 | -1x | +
- h_step_rsp_est(+ h_coxreg_mult_cont_df <- function(variables, |
|
| 108 | -1x | +
- formula = form,+ data, |
|
| 109 | -1x | +
- data = data,+ control = control_coxreg()) {
|
|
| 110 | -1x | +21x |
- variables = variables,+ assert_df_with_variables(data, variables) |
| 111 | -1x | +21x |
- x = interval_center,+ checkmate::assert_list(control, names = "named") |
| 112 | -1x | +21x |
- control = control+ checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE) |
| 113 | -+ | 21x |
- )+ conf_level <- control[["conf_level"]] |
| 114 | -+ | 21x |
- } else {
+ pval_label <- paste0( |
| 115 | -4x | +
- tmp <- mapply(+ # the regex capitalizes the first letter of the string / senetence. |
|
| 116 | -4x | +21x |
- FUN = h_step_rsp_est,+ "p-value (", gsub("(^[a-z])", "\\U\\1", trimws(control[["pval_method"]]), perl = TRUE), ")"
|
| 117 | -4x | +
- x = interval_center,+ ) |
|
| 118 | -4x | +
- subset = as.list(as.data.frame(window_sel$sel)),+ # If there is any data, run model, otherwise return empty results. |
|
| 119 | -4x | +21x |
- MoreArgs = list(+ if (nrow(data) > 0) {
|
| 120 | -4x | +20x |
- formula = form,+ bm_cols <- match(variables$biomarkers, names(data)) |
| 121 | -4x | +20x |
- data = data,+ l_result <- lapply(variables$biomarkers, function(bm) {
|
| 122 | -4x | +40x |
- variables = variables,+ coxreg_list <- fit_coxreg_multivar( |
| 123 | -4x | +40x |
- control = control+ variables = h_surv_to_coxreg_variables(variables, bm), |
| 124 | -+ | 40x |
- )+ data = data, |
| 125 | -+ | 40x |
- )+ control = control |
| 126 |
- # Maybe we find a more elegant solution than this.+ ) |
||
| 127 | -4x | +40x |
- rownames(tmp) <- c("n", "logor", "se", "ci_lower", "ci_upper")
+ result <- do.call( |
| 128 | -4x | +40x |
- t(tmp)+ h_coxreg_multivar_extract, |
| 129 | -+ | 40x |
- }+ c(list(var = bm), coxreg_list[c("mod", "data", "control")])
|
| 130 | -5x | +
- result <- cbind(window_sel$interval, estimates)+ ) |
|
| 131 | -5x | +40x |
- structure(+ data_fit <- as.data.frame(as.matrix(coxreg_list$mod$y)) |
| 132 | -5x | +40x |
- result,+ data_fit$status <- as.logical(data_fit$status) |
| 133 | -5x | +40x |
- class = c("step", "matrix"),
+ median <- s_surv_time( |
| 134 | -5x | +40x |
- variables = variables,+ df = data_fit, |
| 135 | -5x | +40x |
- control = control+ .var = "time", |
| 136 | +40x | +
+ is_event = "status"+ |
+ |
| 137 | +40x | +
+ )$median+ |
+ |
| 138 | +40x | +
+ data.frame(+ |
+ |
| 139 | ++ |
+ # Dummy column needed downstream to create a nested header.+ |
+ |
| 140 | +40x | +
+ biomarker = bm,+ |
+ |
| 141 | +40x | +
+ biomarker_label = formatters::var_labels(data[bm], fill = TRUE),+ |
+ |
| 142 | +40x | +
+ n_tot = coxreg_list$mod$n,+ |
+ |
| 143 | +40x | +
+ n_tot_events = coxreg_list$mod$nevent,+ |
+ |
| 144 | +40x | +
+ median = as.numeric(median),+ |
+ |
| 145 | +40x | +
+ result[1L, c("hr", "lcl", "ucl")],
+ |
+ |
| 146 | +40x | +
+ conf_level = conf_level,+ |
+ |
| 147 | +40x | +
+ pval = result[1L, "pval"],+ |
+ |
| 148 | +40x | +
+ pval_label = pval_label,+ |
+ |
| 149 | +40x | +
+ stringsAsFactors = FALSE+ |
+ |
| 150 | ++ |
+ )+ |
+ |
| 151 | ++ |
+ })+ |
+ |
| 152 | +20x | +
+ do.call(rbind, args = c(l_result, make.row.names = FALSE))+ |
+ |
| 153 | ++ |
+ } else {
+ |
+ |
| 154 | +1x | +
+ data.frame(+ |
+ |
| 155 | +1x | +
+ biomarker = variables$biomarkers,+ |
+ |
| 156 | +1x | +
+ biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE),+ |
+ |
| 157 | +1x | +
+ n_tot = 0L,+ |
+ |
| 158 | +1x | +
+ n_tot_events = 0L,+ |
+ |
| 159 | +1x | +
+ median = NA,+ |
+ |
| 160 | +1x | +
+ hr = NA,+ |
+ |
| 161 | +1x | +
+ lcl = NA,+ |
+ |
| 162 | +1x | +
+ ucl = NA,+ |
+ |
| 163 | +1x | +
+ conf_level = conf_level,+ |
+ |
| 164 | +1x | +
+ pval = NA,+ |
+ |
| 165 | +1x | +
+ pval_label = pval_label,+ |
+ |
| 166 | +1x | +
+ row.names = seq_along(variables$biomarkers),+ |
+ |
| 167 | +1x | +
+ stringsAsFactors = FALSE+ |
+ |
| 168 | ++ |
+ )+ |
+ |
| 169 | ++ |
+ }+ |
+ |
| 170 | ++ |
+ }+ |
+ |
| 171 | ++ | + + | +|
| 172 | ++ |
+ #' @describeIn h_survival_biomarkers_subgroups prepares a single sub-table given a `df_sub` containing+ |
+ |
| 173 | ++ |
+ #' the results for a single biomarker.+ |
+ |
| 174 | ++ |
+ #'+ |
+ |
| 175 | ++ |
+ #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is+ |
+ |
| 176 | ++ |
+ #' returned by [extract_survival_biomarkers()] (it needs a couple of columns which are+ |
+ |
| 177 | ++ |
+ #' added by that high-level function relative to what is returned by [h_coxreg_mult_cont_df()],+ |
+ |
| 178 | ++ |
+ #' see the example).+ |
+ |
| 179 | ++ |
+ #'+ |
+ |
| 180 | ++ |
+ #' @return+ |
+ |
| 181 | ++ |
+ #' * `h_tab_surv_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns.+ |
+ |
| 182 | ++ |
+ #'+ |
+ |
| 183 | ++ |
+ #' @examples+ |
+ |
| 184 | ++ |
+ #' # Starting from above `df`, zoom in on one biomarker and add required columns.+ |
+ |
| 185 | ++ |
+ #' df1 <- df[1, ]+ |
+ |
| 186 | ++ |
+ #' df1$subgroup <- "All patients"+ |
+ |
| 187 | ++ |
+ #' df1$row_type <- "content"+ |
+ |
| 188 | ++ |
+ #' df1$var <- "ALL"+ |
+ |
| 189 | ++ |
+ #' df1$var_label <- "All patients"+ |
+ |
| 190 | ++ |
+ #' h_tab_surv_one_biomarker(+ |
+ |
| 191 | ++ |
+ #' df1,+ |
+ |
| 192 | ++ |
+ #' vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
+ |
+ |
| 193 | ++ |
+ #' time_unit = "days"+ |
+ |
| 194 | ++ |
+ #' )+ |
+ |
| 195 | ++ |
+ #'+ |
+ |
| 196 | ++ |
+ #' @export+ |
+ |
| 197 | ++ |
+ h_tab_surv_one_biomarker <- function(df,+ |
+ |
| 198 | ++ |
+ vars,+ |
+ |
| 199 | ++ |
+ time_unit,+ |
+ |
| 200 | ++ |
+ .indent_mods = 0L) {
+ |
+ |
| 201 | +6x | +
+ afuns <- a_survival_subgroups()[vars]+ |
+ |
| 202 | +6x | +
+ colvars <- d_survival_subgroups_colvars(+ |
+ |
| 203 | +6x | +
+ vars,+ |
+ |
| 204 | +6x | +
+ conf_level = df$conf_level[1],+ |
+ |
| 205 | +6x | +
+ method = df$pval_label[1],+ |
+ |
| 206 | +6x | +
+ time_unit = time_unit+ |
+ |
| 207 | ++ |
+ )+ |
+ |
| 208 | +6x | +
+ h_tab_one_biomarker(+ |
+ |
| 209 | +6x | +
+ df = df,+ |
+ |
| 210 | +6x | +
+ afuns = afuns,+ |
+ |
| 211 | +6x | +
+ colvars = colvars,+ |
+ |
| 212 | +6x | +
+ .indent_mods = .indent_mods+ |
+ |
| 213 |
) |
||
| 137 | +214 |
}@@ -150721,686 +151043,1595 @@ tern coverage - 94.83% |
|
| 459 | +459 | ++ | + + | +
| 460 | ++ |
+ #' Automatic formats from data significant digits+ |
+ |
| 461 | ++ |
+ #'+ |
+ |
| 462 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+ |
| 463 | ++ |
+ #'+ |
+ |
| 464 | ++ |
+ #' Formatting function for the majority of default methods used in [analyze_vars()].+ |
+ |
| 465 | ++ |
+ #' For non-derived values, the significant digits of data is used (e.g. range), while derived+ |
+ |
| 466 | ++ |
+ #' values have one more digits (measure of location and dispersion like mean, standard deviation).+ |
+ |
| 467 | ++ |
+ #' This function can be called internally with "auto" like, for example,+ |
+ |
| 468 | ++ |
+ #' `.formats = c("mean" = "auto")`. See details to see how this works with the inner function.
+ |
+ |
| 469 | ++ |
+ #'+ |
+ |
| 470 | ++ |
+ #' @param dt_var (`numeric`) \cr all the data the statistics was created upon. Used only to find+ |
+ |
| 471 | ++ |
+ #' significant digits. In [analyze_vars] this comes from `.df_row` (see+ |
+ |
| 472 | ++ |
+ #' [rtables::additional_fun_params]), and it is the row data after the above row splits. No+ |
+ |
| 473 | ++ |
+ #' column split is considered.+ |
+ |
| 474 | ++ |
+ #' @param x_stat (`string`) \cr string indicating the current statistical method used.+ |
+ |
| 475 | ++ |
+ #'+ |
+ |
| 476 | ++ |
+ #' @return A string that `rtables` prints in a table cell.+ |
+ |
| 477 | ++ |
+ #'+ |
+ |
| 478 | ++ |
+ #' @details+ |
+ |
| 479 | ++ |
+ #' The internal function is needed to work with `rtables` default structure for+ |
+ |
| 480 | ++ |
+ #' format functions, i.e. `function(x, ...)`, where is x are results from statistical evaluation.+ |
+ |
| 481 | ++ |
+ #' It can be more than one element (e.g. for `.stats = "mean_sd"`).+ |
+ |
| 482 | ++ |
+ #'+ |
+ |
| 483 | ++ |
+ #' @examples+ |
+ |
| 484 | ++ |
+ #' x_todo <- c(0.001, 0.2, 0.0011000, 3, 4)+ |
+ |
| 485 | ++ |
+ #' res <- c(mean(x_todo[1:3]), sd(x_todo[1:3]))+ |
+ |
| 486 | ++ |
+ #'+ |
+ |
| 487 | ++ |
+ #' # x is the result coming into the formatting function -> res!!+ |
+ |
| 488 | ++ |
+ #' format_auto(dt_var = x_todo, x_stat = "mean_sd")(x = res)+ |
+ |
| 489 | ++ |
+ #' format_auto(x_todo, "range")(x = range(x_todo))+ |
+ |
| 490 | ++ |
+ #' no_sc_x <- c(0.0000001, 1)+ |
+ |
| 491 | ++ |
+ #' format_auto(no_sc_x, "range")(x = no_sc_x)+ |
+ |
| 492 | ++ |
+ #'+ |
+ |
| 493 | ++ |
+ #' @family formatting functions+ |
+ |
| 494 | ++ |
+ #' @export+ |
+ |
| 495 | ++ |
+ format_auto <- function(dt_var, x_stat) {
+ |
+ |
| 496 | +7x | +
+ function(x = "", ...) {
+ |
+ |
| 497 | +11x | +
+ checkmate::assert_numeric(x, min.len = 1)+ |
+ |
| 498 | +11x | +
+ checkmate::assert_numeric(dt_var, min.len = 1)+ |
+ |
| 499 | ++ |
+ # Defaults - they may be a param in the future+ |
+ |
| 500 | +11x | +
+ der_stats <- c(+ |
+ |
| 501 | +11x | +
+ "mean", "sd", "se", "median", "geom_mean", "quantiles", "iqr",+ |
+ |
| 502 | +11x | +
+ "mean_sd", "mean_se", "mean_se", "mean_ci", "mean_sei", "mean_sdi"+ |
+ |
| 503 | ++ |
+ )+ |
+ |
| 504 | +11x | +
+ nonder_stats <- c("n", "range", "min", "max")
+ |
+ |
| 505 | ++ | + + | +|
| 506 | ++ |
+ # Safenet for miss-modifications+ |
+ |
| 507 | +11x | +
+ stopifnot(length(intersect(der_stats, nonder_stats)) == 0) # nolint+ |
+ |
| 508 | +11x | +
+ checkmate::assert_choice(x_stat, c(der_stats, nonder_stats))+ |
+ |
| 509 | ++ | + + | +|
| 510 | ++ |
+ # Finds the max number of digits in data+ |
+ |
| 511 | +11x | +
+ detect_dig <- vapply(dt_var, count_decimalplaces, FUN.VALUE = numeric(1)) %>%+ |
+ |
| 512 | +11x | +
+ max()+ |
+ |
| 513 | ++ | + + | +|
| 514 | +11x | +
+ if (x_stat %in% der_stats) {
+ |
+ |
| 515 | +4x | +
+ detect_dig <- detect_dig + 1+ |
+ |
| 516 | ++ |
+ }+ |
+ |
| 517 | ++ | + + | +|
| 518 | ++ |
+ # Render input+ |
+ |
| 519 | +11x | +
+ str_vals <- formatC(x, digits = detect_dig, format = "f")+ |
+ |
| 520 | +11x | +
+ def_fmt <- get_formats_from_stats(x_stat)[[x_stat]]+ |
+ |
| 521 | +11x | +
+ str_fmt <- str_extract(def_fmt, invert = FALSE)[[1]]+ |
+ |
| 522 | +11x | +
+ if (length(str_fmt) != length(str_vals)) {
+ |
+ |
| 523 | +2x | +
+ stop(+ |
+ |
| 524 | +2x | +
+ "Number of inserted values as result (", length(str_vals),
+ |
+ |
| 525 | +2x | +
+ ") is not the same as there should be in the default tern formats for ",+ |
+ |
| 526 | +2x | +
+ x_stat, " (-> ", def_fmt, " needs ", length(str_fmt), " values). ",+ |
+ |
| 527 | +2x | +
+ "See tern_default_formats to check all of them."+ |
+ |
| 528 | ++ |
+ )+ |
+ |
| 529 | ++ |
+ }+ |
+ |
| 530 | ++ | + + | +|
| 531 | ++ |
+ # Squashing them together+ |
+ |
| 532 | +9x | +
+ inv_str_fmt <- str_extract(def_fmt, invert = TRUE)[[1]]+ |
+ |
| 533 | +9x | +
+ stopifnot(length(inv_str_fmt) == length(str_vals) + 1) # nolint+ |
+ |
| 534 | ++ | + + | +|
| 535 | +9x | +
+ out <- vector("character", length = length(inv_str_fmt) + length(str_vals))
+ |
+ |
| 536 | +9x | +
+ is_even <- seq_along(out) %% 2 == 0+ |
+ |
| 537 | +9x | +
+ out[is_even] <- str_vals+ |
+ |
| 538 | +9x | +
+ out[!is_even] <- inv_str_fmt+ |
+ |
| 539 | ++ | + + | +|
| 540 | +9x | +
+ return(paste0(out, collapse = ""))+ |
+ |
| 541 | ++ |
+ }+ |
+ |
| 542 | ++ |
+ }+ |
+ |
| 543 | ++ | + + | +|
| 544 | ++ |
+ # Utility function that could be useful in general+ |
+ |
| 545 | ++ |
+ str_extract <- function(string, pattern = "xx|xx\\.|xx\\.x+", invert = FALSE) {
+ |
+ |
| 546 | +20x | +
+ regmatches(string, gregexpr(pattern, string), invert = invert)+ |
+ |
| 547 | ++ |
+ }+ |
+ |
| 548 | ++ | + + | +|
| 549 | ++ |
+ # Helper function+ |
+ |
| 550 | ++ |
+ count_decimalplaces <- function(dec) {
+ |
+ |
| 551 | +52x | +
+ if (abs(dec - round(dec)) > .Machine$double.eps^0.5) { # For precision
+ |
+ |
| 552 | +31x | +
+ nchar(strsplit(format(dec, scientific = FALSE, trim = FALSE), ".", fixed = TRUE)[[1]][[2]])+ |
+ |
| 553 | ++ |
+ } else {
+ |
+ |
| 554 | +21x | +
+ return(0)+ |
+ |
| 555 | ++ |
+ }+ |
+ |
| 556 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Occurrence Table Sorting+ |
+ ||
| 2 | ++ |
+ #'+ |
+ ||
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+ ||
| 4 | ++ |
+ #'+ |
+ ||
| 5 | ++ |
+ #' Functions to score occurrence table subtables and rows which can be used in the+ |
+ ||
| 6 | ++ |
+ #' sorting of occurrence tables.+ |
+ ||
| 7 | ++ |
+ #'+ |
+ ||
| 8 | ++ |
+ #' @name score_occurrences+ |
+ ||
| 9 | ++ |
+ NULL+ |
+ ||
| 10 | ++ | + + | +||
| 11 | ++ |
+ #' @describeIn score_occurrences Scoring function which sums the counts across all+ |
+ ||
| 12 | ++ |
+ #' columns. It will fail if anything else but counts are used.+ |
+ ||
| 13 | ++ |
+ #'+ |
+ ||
| 14 | ++ |
+ #' @inheritParams rtables_access+ |
+ ||
| 15 | ++ |
+ #'+ |
+ ||
| 16 | ++ |
+ #' @return+ |
+ ||
| 17 | ++ |
+ #' * `score_occurrences()` returns the sum of counts across all columns of a table row.+ |
+ ||
| 18 | ++ |
+ #'+ |
+ ||
| 19 | ++ |
+ #' @seealso [h_row_first_values()]+ |
+ ||
| 20 | ++ |
+ #'+ |
+ ||
| 21 | ++ |
+ #' @examples+ |
+ ||
| 22 | ++ |
+ #' lyt <- basic_table() %>%+ |
+ ||
| 23 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+ ||
| 24 | ++ |
+ #' add_colcounts() %>%+ |
+ ||
| 25 | ++ |
+ #' analyze_num_patients(+ |
+ ||
| 26 | ++ |
+ #' vars = "USUBJID",+ |
+ ||
| 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) %>%
|
|||
| 460 | +31 |
- #' Automatic formats from data significant digits+ #' summarize_num_patients( |
||
| 461 | +32 |
- #'+ #' var = "USUBJID", |
||
| 462 | +33 |
- #' @description `r lifecycle::badge("stable")`
+ #' .stats = c("unique", "nonunique"),
|
||
| 463 | +34 |
- #'+ #' .labels = c( |
||
| 464 | +35 |
- #' Formatting function for the majority of default methods used in [analyze_vars()].+ #' "Total number of patients with at least one event", |
||
| 465 | +36 |
- #' For non-derived values, the significant digits of data is used (e.g. range), while derived+ #' "Total number of events" |
||
| 466 | +37 |
- #' values have one more digits (measure of location and dispersion like mean, standard deviation).+ #' ) |
||
| 467 | +38 |
- #' This function can be called internally with "auto" like, for example,+ #' ) %>% |
||
| 468 | +39 |
- #' `.formats = c("mean" = "auto")`. See details to see how this works with the inner function.
+ #' count_occurrences(vars = "AEDECOD") |
||
| 469 | +40 |
#' |
||
| 470 | +41 |
- #' @param dt_var (`numeric`) \cr all the data the statistics was created upon. Used only to find+ #' tbl <- build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl) %>% |
||
| 471 | +42 |
- #' significant digits. In [analyze_vars] this comes from `.df_row` (see+ #' prune_table() |
||
| 472 | +43 |
- #' [rtables::additional_fun_params]), and it is the row data after the above row splits. No+ #' |
||
| 473 | +44 |
- #' column split is considered.+ #' tbl_sorted <- tbl %>% |
||
| 474 | +45 |
- #' @param x_stat (`string`) \cr string indicating the current statistical method used.+ #' sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_occurrences)
|
||
| 475 | +46 |
#' |
||
| 476 | +47 |
- #' @return A string that `rtables` prints in a table cell.+ #' tbl_sorted |
||
| 477 | +48 |
#' |
||
| 478 | +49 |
- #' @details+ #' @export |
||
| 479 | +50 |
- #' The internal function is needed to work with `rtables` default structure for+ score_occurrences <- function(table_row) {
|
||
| 480 | -+ | |||
| 51 | +37x |
- #' format functions, i.e. `function(x, ...)`, where is x are results from statistical evaluation.+ row_counts <- h_row_counts(table_row) |
||
| 481 | -+ | |||
| 52 | +37x |
- #' It can be more than one element (e.g. for `.stats = "mean_sd"`).+ sum(row_counts) |
||
| 482 | +53 |
- #'+ } |
||
| 483 | +54 |
- #' @examples+ |
||
| 484 | +55 |
- #' x_todo <- c(0.001, 0.2, 0.0011000, 3, 4)+ #' @describeIn score_occurrences Scoring functions can be produced by this constructor to only include |
||
| 485 | +56 |
- #' res <- c(mean(x_todo[1:3]), sd(x_todo[1:3]))+ #' specific columns in the scoring. See [h_row_counts()] for further information. |
||
| 486 | +57 |
#' |
||
| 487 | +58 |
- #' # x is the result coming into the formatting function -> res!!+ #' @inheritParams has_count_in_cols |
||
| 488 | +59 |
- #' format_auto(dt_var = x_todo, x_stat = "mean_sd")(x = res)+ #' |
||
| 489 | +60 |
- #' format_auto(x_todo, "range")(x = range(x_todo))+ #' @return |
||
| 490 | +61 |
- #' no_sc_x <- c(0.0000001, 1)+ #' * `score_occurrences_cols()` returns a function that sums counts across all specified columns |
||
| 491 | +62 |
- #' format_auto(no_sc_x, "range")(x = no_sc_x)+ #' of a table row. |
||
| 492 | +63 |
#' |
||
| 493 | +64 |
- #' @family formatting functions+ #' @seealso [h_row_counts()] |
||
| 494 | +65 |
- #' @export+ #' |
||
| 495 | +66 |
- format_auto <- function(dt_var, x_stat) {
+ #' @examples |
||
| 496 | -7x | +|||
| 67 | +
- function(x = "", ...) {
+ #' score_cols_a_and_b <- score_occurrences_cols(col_names = c("A: Drug X", "B: Placebo"))
|
|||
| 497 | -11x | +|||
| 68 | +
- checkmate::assert_numeric(x, min.len = 1)+ #' |
|||
| 498 | -11x | +|||
| 69 | +
- checkmate::assert_numeric(dt_var, min.len = 1)+ #' # Note that this here just sorts the AEDECOD inside the AEBODSYS. The AEBODSYS are not sorted. |
|||
| 499 | +70 |
- # Defaults - they may be a param in the future+ #' # That would require a second pass of `sort_at_path`. |
||
| 500 | -11x | +|||
| 71 | +
- der_stats <- c(+ #' tbl_sorted <- tbl %>% |
|||
| 501 | -11x | +|||
| 72 | +
- "mean", "sd", "se", "median", "geom_mean", "quantiles", "iqr",+ #' sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_cols_a_and_b)
|
|||
| 502 | -11x | +|||
| 73 | +
- "mean_sd", "mean_se", "mean_se", "mean_ci", "mean_sei", "mean_sdi"+ #' |
|||
| 503 | +74 |
- )+ #' tbl_sorted |
||
| 504 | -11x | +|||
| 75 | +
- nonder_stats <- c("n", "range", "min", "max")
+ #' |
|||
| 505 | +76 |
-
+ #' @export |
||
| 506 | +77 |
- # Safenet for miss-modifications+ score_occurrences_cols <- function(...) {
|
||
| 507 | -11x | +78 | +4x |
- stopifnot(length(intersect(der_stats, nonder_stats)) == 0) # nolint+ function(table_row) {
|
| 508 | -11x | +79 | +20x |
- checkmate::assert_choice(x_stat, c(der_stats, nonder_stats))+ row_counts <- h_row_counts(table_row, ...) |
| 509 | -+ | |||
| 80 | +20x |
-
+ sum(row_counts) |
||
| 510 | +81 |
- # Finds the max number of digits in data- |
- ||
| 511 | -11x | -
- detect_dig <- vapply(dt_var, count_decimalplaces, FUN.VALUE = numeric(1)) %>%+ } |
||
| 512 | -11x | +|||
| 82 | +
- max()+ } |
|||
| 513 | +83 | |||
| 514 | -11x | +|||
| 84 | +
- if (x_stat %in% der_stats) {
+ #' @describeIn score_occurrences Scoring functions produced by this constructor can be used on |
|||
| 515 | -4x | +|||
| 85 | +
- detect_dig <- detect_dig + 1+ #' subtables: They sum up all specified column counts in the subtable. This is useful when |
|||
| 516 | +86 |
- }+ #' there is no available content row summing up these counts. |
||
| 517 | +87 |
-
+ #' |
||
| 518 | +88 |
- # Render input+ #' @return |
||
| 519 | -11x | +|||
| 89 | +
- str_vals <- formatC(x, digits = detect_dig, format = "f")+ #' * `score_occurrences_subtable()` returns a function that sums counts in each subtable |
|||
| 520 | -11x | +|||
| 90 | +
- def_fmt <- get_formats_from_stats(x_stat)[[x_stat]]+ #' across all specified columns. |
|||
| 521 | -11x | +|||
| 91 | +
- str_fmt <- str_extract(def_fmt, invert = FALSE)[[1]]+ #' |
|||
| 522 | -11x | +|||
| 92 | +
- if (length(str_fmt) != length(str_vals)) {
+ #' @examples |
|||
| 523 | -2x | +|||
| 93 | +
- stop(+ #' score_subtable_all <- score_occurrences_subtable(col_names = names(tbl)) |
|||
| 524 | -2x | +|||
| 94 | +
- "Number of inserted values as result (", length(str_vals),
+ #' |
|||
| 525 | -2x | +|||
| 95 | +
- ") is not the same as there should be in the default tern formats for ",+ #' # Note that this code just sorts the AEBODSYS, not the AEDECOD within AEBODSYS. That |
|||
| 526 | -2x | +|||
| 96 | +
- x_stat, " (-> ", def_fmt, " needs ", length(str_fmt), " values). ",+ #' # would require a second pass of `sort_at_path`. |
|||
| 527 | -2x | +|||
| 97 | +
- "See tern_default_formats to check all of them."+ #' tbl_sorted <- tbl %>% |
|||
| 528 | +98 |
- )+ #' sort_at_path(path = c("AEBODSYS"), scorefun = score_subtable_all, decreasing = FALSE)
|
||
| 529 | +99 |
- }+ #' |
||
| 530 | +100 |
-
+ #' tbl_sorted |
||
| 531 | +101 |
- # Squashing them together+ #' |
||
| 532 | -9x | +|||
| 102 | +
- inv_str_fmt <- str_extract(def_fmt, invert = TRUE)[[1]]+ #' @export |
|||
| 533 | -9x | +|||
| 103 | +
- stopifnot(length(inv_str_fmt) == length(str_vals) + 1) # nolint+ score_occurrences_subtable <- function(...) {
|
|||
| 534 | -+ | |||
| 104 | +1x |
-
+ score_table_row <- score_occurrences_cols(...) |
||
| 535 | -9x | +105 | +1x |
- out <- vector("character", length = length(inv_str_fmt) + length(str_vals))
+ function(table_tree) {
|
| 536 | -9x | +106 | +2x |
- is_even <- seq_along(out) %% 2 == 0+ table_rows <- collect_leaves(table_tree) |
| 537 | -9x | +107 | +2x |
- out[is_even] <- str_vals+ counts <- vapply(table_rows, score_table_row, numeric(1)) |
| 538 | -9x | +108 | +2x |
- out[!is_even] <- inv_str_fmt+ sum(counts) |
| 539 | +109 |
-
+ } |
||
| 540 | -9x | +|||
| 110 | +
- return(paste0(out, collapse = ""))+ } |
|||
| 541 | +111 |
- }+ |
||
| 542 | +112 |
- }+ #' @describeIn score_occurrences Produce score function for sorting table by summing the first content row in |
||
| 543 | +113 |
-
+ #' specified columns. Note that this is extending [rtables::cont_n_onecol()] and [rtables::cont_n_allcols()]. |
||
| 544 | +114 |
- # Utility function that could be useful in general+ #' |
||
| 545 | +115 |
- str_extract <- function(string, pattern = "xx|xx\\.|xx\\.x+", invert = FALSE) {
+ #' @return |
||
| 546 | -20x | +|||
| 116 | +
- regmatches(string, gregexpr(pattern, string), invert = invert)+ #' * `score_occurrences_cont_cols()` returns a function that sums counts in the first content row in |
|||
| 547 | +117 |
- }+ #' specified columns. |
||
| 548 | +118 |
-
+ #' |
||
| 549 | +119 |
- # Helper function+ #' @export |
||
| 550 | +120 |
- count_decimalplaces <- function(dec) {
+ score_occurrences_cont_cols <- function(...) {
|
||
| 551 | -52x | +121 | +1x |
- if (abs(dec - round(dec)) > .Machine$double.eps^0.5) { # For precision
+ score_table_row <- score_occurrences_cols(...) |
| 552 | -31x | +122 | +1x |
- nchar(strsplit(format(dec, scientific = FALSE, trim = FALSE), ".", fixed = TRUE)[[1]][[2]])+ function(table_tree) {
+ |
+
| 123 | +2x | +
+ if (inherits(table_tree, "ContentRow")) {
+ |
+ ||
| 124 | +! | +
+ return(NA) |
||
| 553 | +125 |
- } else {
+ } |
||
| 554 | -21x | +126 | +2x |
- return(0)+ content_row <- h_content_first_row(table_tree)+ |
+
| 127 | +2x | +
+ score_table_row(content_row) |
||
| 555 | +128 |
} |
||
| 556 | +129 |
}@@ -151409,14 +152640,14 @@ tern coverage - 94.83% |
| 1 |
- #' Helper Function for Tabulation of a Single Biomarker Result+ #' Cox Regression Helper: Interactions |
|||
| 5 |
- #' Please see [h_tab_surv_one_biomarker()] and [h_tab_rsp_one_biomarker()], which use this function for examples.+ #' Test and estimate the effect of a treatment in interaction with a covariate. |
|||
| 6 |
- #' This function is a wrapper for [rtables::summarize_row_groups()].+ #' The effect is estimated as the HR of the tested treatment for a given level |
|||
| 7 |
- #'+ #' of the covariate, in comparison to the treatment control. |
|||
| 8 |
- #' @inheritParams argument_convention+ #' |
|||
| 9 |
- #' @param df (`data.frame`)\cr results for a single biomarker.+ #' @inheritParams argument_convention |
|||
| 10 |
- #' @param afuns (named `list` of `function`)\cr analysis functions.+ #' @param x (`numeric` or `factor`)\cr the values of the covariate to be tested. |
|||
| 11 |
- #' @param colvars (`list` with `vars` and `labels`)\cr variables to tabulate and their labels.+ #' @param effect (`string`)\cr the name of the effect to be tested and estimated. |
|||
| 12 |
- #'+ #' @param covar (`string`)\cr the name of the covariate in the model. |
|||
| 13 |
- #' @return An `rtables` table object with statistics in columns.+ #' @param mod (`coxph`)\cr the Cox regression model. |
|||
| 14 |
- #'+ #' @param label (`string`)\cr the label to be returned as `term_label`. |
|||
| 15 |
- #' @export+ #' @param control (`list`)\cr a list of controls as returned by [control_coxreg()]. |
|||
| 16 |
- h_tab_one_biomarker <- function(df,+ #' @param ... see methods. |
|||
| 17 |
- afuns,+ #' |
|||
| 18 |
- colvars,+ #' @examples |
|||
| 19 |
- .indent_mods = 0L) {
+ #' library(survival) |
|||
| 20 | -12x | +
- lyt <- basic_table()+ #' |
||
| 21 |
-
+ #' set.seed(1, kind = "Mersenne-Twister") |
|||
| 22 |
- # Row split by row type - only keep the content rows here.+ #' |
|||
| 23 | -12x | +
- lyt <- split_rows_by(+ #' # Testing dataset [survival::bladder]. |
||
| 24 | -12x | +
- lyt = lyt,+ #' dta_bladder <- with( |
||
| 25 | -12x | +
- var = "row_type",+ #' data = bladder[bladder$enum < 5, ], |
||
| 26 | -12x | +
- split_fun = keep_split_levels("content"),
+ #' data.frame( |
||
| 27 | -12x | +
- nested = FALSE+ #' time = stop, |
||
| 28 |
- )+ #' status = event, |
|||
| 29 |
-
+ #' armcd = as.factor(rx), |
|||
| 30 |
- # Summarize rows with all patients.+ #' covar1 = as.factor(enum), |
|||
| 31 | -12x | +
- lyt <- summarize_row_groups(+ #' covar2 = factor( |
||
| 32 | -12x | +
- lyt = lyt,+ #' sample(as.factor(enum)), |
||
| 33 | -12x | +
- var = "var_label",+ #' levels = 1:4, |
||
| 34 | -12x | +
- cfun = afuns,+ #' labels = c("F", "F", "M", "M")
|
||
| 35 | -12x | +
- indent_mod = .indent_mods+ #' ) |
||
| 36 |
- )+ #' ) |
|||
| 37 |
-
+ #' ) |
|||
| 38 |
- # Split cols by the multiple variables to populate into columns.+ #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
|
|||
| 39 | -12x | +
- lyt <- split_cols_by_multivar(+ #' formatters::var_labels(dta_bladder)[names(labels)] <- labels |
||
| 40 | -12x | +
- lyt = lyt,+ #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
||
| 41 | -12x | +
- vars = colvars$vars,+ #' |
||
| 42 | -12x | +
- varlabels = colvars$labels+ #' plot( |
||
| 43 |
- )+ #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder), |
|||
| 44 |
-
+ #' lty = 2:4, |
|||
| 45 |
- # If there is any subgroup variables, we extend the layout accordingly.+ #' xlab = "Months", |
|||
| 46 | -12x | +
- if ("analysis" %in% df$row_type) {
+ #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
|
||
| 47 |
- # Now only continue with the subgroup rows.+ #' ) |
|||
| 48 | -4x | +
- lyt <- split_rows_by(+ #' |
||
| 49 | -4x | +
- lyt = lyt,+ #' @name cox_regression_inter |
||
| 50 | -4x | +
- var = "row_type",+ NULL |
||
| 51 | -4x | +
- split_fun = keep_split_levels("analysis"),
+
|
||
| 52 | -4x | +
- nested = FALSE,+ #' @describeIn cox_regression_inter S3 generic helper function to determine interaction effect. |
||
| 53 | -4x | +
- child_labels = "hidden"+ #' |
||
| 54 |
- )+ #' @return |
|||
| 55 |
-
+ #' * `h_coxreg_inter_effect()` returns a `data.frame` of covariate interaction effects consisting of the following |
|||
| 56 |
- # Split by the subgroup variable.+ #' variables: `effect`, `term`, `term_label`, `level`, `n`, `hr`, `lcl`, `ucl`, `pval`, and `pval_inter`. |
|||
| 57 | -4x | +
- lyt <- split_rows_by(+ #' |
||
| 58 | -4x | +
- lyt = lyt,+ #' @export |
||
| 59 | -4x | +
- var = "var",+ h_coxreg_inter_effect <- function(x, |
||
| 60 | -4x | +
- labels_var = "var_label",+ effect, |
||
| 61 | -4x | +
- nested = TRUE,+ covar, |
||
| 62 | -4x | +
- child_labels = "visible",+ mod, |
||
| 63 | -4x | +
- indent_mod = .indent_mods * 2+ label, |
||
| 64 |
- )+ control, |
|||
| 65 |
-
+ ...) {
|
|||
| 66 | -+ | 26x |
- # Then analyze colvars for each subgroup.+ UseMethod("h_coxreg_inter_effect", x)
|
|
| 67 | -4x | +
- lyt <- summarize_row_groups(+ } |
||
| 68 | -4x | +
- lyt = lyt,+ |
||
| 69 | -4x | +
- cfun = afuns,+ #' @describeIn cox_regression_inter Method for `numeric` class. Estimates the interaction with a `numeric` covariate. |
||
| 70 | -4x | +
- var = "subgroup"+ #' |
||
| 71 |
- )+ #' @method h_coxreg_inter_effect numeric |
|||
| 72 | + |
+ #'+ |
+ ||
| 73 | ++ |
+ #' @param at (`list`)\cr a list with items named after the covariate, every+ |
+ ||
| 74 | ++ |
+ #' item is a vector of levels at which the interaction should be estimated.+ |
+ ||
| 75 | ++ |
+ #'+ |
+ ||
| 76 | ++ |
+ #' @export+ |
+ ||
| 77 | ++ |
+ h_coxreg_inter_effect.numeric <- function(x,+ |
+ ||
| 78 | ++ |
+ effect,+ |
+ ||
| 79 | ++ |
+ covar,+ |
+ ||
| 80 | ++ |
+ mod,+ |
+ ||
| 81 | ++ |
+ label,+ |
+ ||
| 82 | ++ |
+ control,+ |
+ ||
| 83 | ++ |
+ at,+ |
+ ||
| 84 | ++ |
+ ...) {
+ |
+ ||
| 85 | +7x | +
+ betas <- stats::coef(mod)+ |
+ ||
| 86 | +7x | +
+ attrs <- attr(stats::terms(mod), "term.labels")+ |
+ ||
| 87 | +7x | +
+ term_indices <- grep(+ |
+ ||
| 88 | +7x | +
+ pattern = effect,+ |
+ ||
| 89 | +7x | +
+ x = attrs[!grepl("strata\\(", attrs)]
+ |
+ ||
| 90 | ++ |
+ )+ |
+ ||
| 91 | +7x | +
+ checkmate::assert_vector(term_indices, len = 2)+ |
+ ||
| 92 | +7x | +
+ betas <- betas[term_indices]+ |
+ ||
| 93 | +7x | +
+ betas_var <- diag(stats::vcov(mod))[term_indices]+ |
+ ||
| 94 | +7x | +
+ betas_cov <- stats::vcov(mod)[term_indices[1], term_indices[2]]+ |
+ ||
| 95 | +7x | +
+ xval <- if (is.null(at[[covar]])) {
+ |
+ ||
| 96 | +6x | +
+ stats::median(x)+ |
+ ||
| 97 | ++ |
+ } else {
+ |
+ ||
| 98 | +1x | +
+ at[[covar]]+ |
+ ||
| 99 | +
} |
|||
| 73 | -12x | +100 | +7x | +
+ effect_index <- !grepl(covar, names(betas))+ |
+
| 101 | +7x | +
+ coef_hat <- betas[effect_index] + xval * betas[!effect_index]+ |
+ ||
| 102 | +7x | +
+ coef_se <- sqrt(+ |
+ ||
| 103 | +7x | +
+ betas_var[effect_index] ++ |
+ ||
| 104 | +7x | +
+ xval ^ 2 * betas_var[!effect_index] + # styler: off+ |
+ ||
| 105 | +7x |
- build_table(lyt, df = df)+ 2 * xval * betas_cov |
||
| 74 | +106 |
- }+ ) |
| 1 | -+ | |||
| 107 | +7x |
- #' Occurrence Table Sorting+ q_norm <- stats::qnorm((1 + control$conf_level) / 2) |
||
| 2 | -+ | |||
| 108 | +7x |
- #'+ data.frame( |
||
| 3 | -+ | |||
| 109 | +7x |
- #' @description `r lifecycle::badge("stable")`
+ effect = "Covariate:", |
||
| 4 | -+ | |||
| 110 | +7x |
- #'+ term = rep(covar, length(xval)), |
||
| 5 | -+ | |||
| 111 | +7x |
- #' Functions to score occurrence table subtables and rows which can be used in the+ term_label = paste0(" ", xval),
|
||
| 6 | -+ | |||
| 112 | +7x |
- #' sorting of occurrence tables.+ level = as.character(xval), |
||
| 7 | -+ | |||
| 113 | +7x |
- #'+ n = NA, |
||
| 8 | -+ | |||
| 114 | +7x |
- #' @name score_occurrences+ hr = exp(coef_hat), |
||
| 9 | -+ | |||
| 115 | +7x |
- NULL+ lcl = exp(coef_hat - q_norm * coef_se), |
||
| 10 | -+ | |||
| 116 | +7x |
-
+ ucl = exp(coef_hat + q_norm * coef_se), |
||
| 11 | -+ | |||
| 117 | +7x |
- #' @describeIn score_occurrences Scoring function which sums the counts across all+ pval = NA, |
||
| 12 | -+ | |||
| 118 | +7x |
- #' columns. It will fail if anything else but counts are used.+ pval_inter = NA, |
||
| 13 | -+ | |||
| 119 | +7x |
- #'+ stringsAsFactors = FALSE |
||
| 14 | +120 |
- #' @inheritParams rtables_access+ ) |
||
| 15 | +121 |
- #'+ } |
||
| 16 | +122 |
- #' @return+ |
||
| 17 | +123 |
- #' * `score_occurrences()` returns the sum of counts across all columns of a table row.+ #' @describeIn cox_regression_inter Method for `factor` class. Estimate the interaction with a `factor` covariate. |
||
| 18 | +124 |
#' |
||
| 19 | +125 |
- #' @seealso [h_row_first_values()]+ #' @method h_coxreg_inter_effect factor |
||
| 20 | +126 |
#' |
||
| 21 | -- |
- #' @examples- |
- ||
| 22 | +127 |
- #' lyt <- basic_table() %>%+ #' @param data (`data.frame`)\cr the data frame on which the model was fit. |
||
| 23 | +128 |
- #' split_cols_by("ARM") %>%
+ #' |
||
| 24 | +129 |
- #' add_colcounts() %>%+ #' @export |
||
| 25 | +130 |
- #' analyze_num_patients(+ h_coxreg_inter_effect.factor <- function(x, |
||
| 26 | +131 |
- #' vars = "USUBJID",+ effect, |
||
| 27 | +132 |
- #' .stats = c("unique"),
+ covar, |
||
| 28 | +133 |
- #' .labels = c("Total number of patients with at least one event")
+ mod, |
||
| 29 | +134 |
- #' ) %>%+ label, |
||
| 30 | +135 |
- #' split_rows_by("AEBODSYS", child_labels = "visible", nested = FALSE) %>%
+ control, |
||
| 31 | +136 |
- #' summarize_num_patients(+ data, |
||
| 32 | +137 |
- #' var = "USUBJID",+ ...) {
|
||
| 33 | -+ | |||
| 138 | +15x |
- #' .stats = c("unique", "nonunique"),
+ lvl_given <- levels(x) |
||
| 34 | -+ | |||
| 139 | +15x |
- #' .labels = c(+ y <- h_coxreg_inter_estimations( |
||
| 35 | -+ | |||
| 140 | +15x |
- #' "Total number of patients with at least one event",+ variable = effect, given = covar, |
||
| 36 | -+ | |||
| 141 | +15x |
- #' "Total number of events"+ lvl_var = levels(data[[effect]]), |
||
| 37 | -+ | |||
| 142 | +15x |
- #' )+ lvl_given = lvl_given, |
||
| 38 | -+ | |||
| 143 | +15x |
- #' ) %>%+ mod = mod, |
||
| 39 | -+ | |||
| 144 | +15x |
- #' count_occurrences(vars = "AEDECOD")+ conf_level = 0.95 |
||
| 40 | -+ | |||
| 145 | +15x |
- #'+ )[[1]] |
||
| 41 | +146 |
- #' tbl <- build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl) %>%+ |
||
| 42 | -+ | |||
| 147 | +15x |
- #' prune_table()+ data.frame( |
||
| 43 | -+ | |||
| 148 | +15x |
- #'+ effect = "Covariate:", |
||
| 44 | -+ | |||
| 149 | +15x |
- #' tbl_sorted <- tbl %>%+ term = rep(covar, nrow(y)), |
||
| 45 | -+ | |||
| 150 | +15x |
- #' sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_occurrences)
+ term_label = paste0(" ", lvl_given),
|
||
| 46 | -+ | |||
| 151 | +15x |
- #'+ level = lvl_given, |
||
| 47 | -+ | |||
| 152 | +15x |
- #' tbl_sorted+ n = NA, |
||
| 48 | -+ | |||
| 153 | +15x |
- #'+ hr = y[, "hr"], |
||
| 49 | -+ | |||
| 154 | +15x |
- #' @export+ lcl = y[, "lcl"], |
||
| 50 | -+ | |||
| 155 | +15x |
- score_occurrences <- function(table_row) {
+ ucl = y[, "ucl"], |
||
| 51 | -37x | +156 | +15x |
- row_counts <- h_row_counts(table_row)+ pval = NA, |
| 52 | -37x | +157 | +15x |
- sum(row_counts)+ pval_inter = NA, |
| 53 | -+ | |||
| 158 | +15x |
- }+ stringsAsFactors = FALSE |
||
| 54 | +159 |
-
+ ) |
||
| 55 | +160 |
- #' @describeIn score_occurrences Scoring functions can be produced by this constructor to only include+ } |
||
| 56 | +161 |
- #' specific columns in the scoring. See [h_row_counts()] for further information.+ |
||
| 57 | +162 |
- #'+ #' @describeIn cox_regression_inter Method for `character` class. Estimate the interaction with a `character` covariate. |
||
| 58 | +163 |
- #' @inheritParams has_count_in_cols+ #' This makes an automatic conversion to `factor` and then forwards to the method for factors. |
||
| 59 | +164 |
#' |
||
| 60 | +165 |
- #' @return+ #' @method h_coxreg_inter_effect character |
||
| 61 | +166 |
- #' * `score_occurrences_cols()` returns a function that sums counts across all specified columns+ #' |
||
| 62 | +167 |
- #' of a table row.+ #' @note |
||
| 63 | +168 |
- #'+ #' * Automatic conversion of character to factor does not guarantee results can be generated correctly. It is |
||
| 64 | +169 |
- #' @seealso [h_row_counts()]+ #' therefore better to always pre-process the dataset such that factors are manually created from character |
||
| 65 | +170 |
- #'+ #' variables before passing the dataset to [rtables::build_table()]. |
||
| 66 | +171 |
- #' @examples+ #' |
||
| 67 | +172 |
- #' score_cols_a_and_b <- score_occurrences_cols(col_names = c("A: Drug X", "B: Placebo"))
+ #' @export |
||
| 68 | +173 |
- #'+ h_coxreg_inter_effect.character <- function(x, |
||
| 69 | +174 |
- #' # Note that this here just sorts the AEDECOD inside the AEBODSYS. The AEBODSYS are not sorted.+ effect, |
||
| 70 | +175 |
- #' # That would require a second pass of `sort_at_path`.+ covar, |
||
| 71 | +176 |
- #' tbl_sorted <- tbl %>%+ mod, |
||
| 72 | +177 |
- #' sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_cols_a_and_b)
+ label, |
||
| 73 | +178 |
- #'+ control, |
||
| 74 | +179 |
- #' tbl_sorted+ data, |
||
| 75 | +180 |
- #'+ ...) {
|
||
| 76 | -+ | |||
| 181 | +4x |
- #' @export+ y <- as.factor(x) |
||
| 77 | +182 |
- score_occurrences_cols <- function(...) {
+
|
||
| 78 | +183 | 4x |
- function(table_row) {
+ h_coxreg_inter_effect( |
|
| 79 | -20x | +184 | +4x |
- row_counts <- h_row_counts(table_row, ...)+ x = y, |
| 80 | -20x | -
- sum(row_counts)- |
- ||
| 81 | -- |
- }- |
- ||
| 82 | -+ | 185 | +4x |
- }+ effect = effect, |
| 83 | -+ | |||
| 186 | +4x |
-
+ covar = covar, |
||
| 84 | -+ | |||
| 187 | +4x |
- #' @describeIn score_occurrences Scoring functions produced by this constructor can be used on+ mod = mod, |
||
| 85 | -+ | |||
| 188 | +4x |
- #' subtables: They sum up all specified column counts in the subtable. This is useful when+ label = label, |
||
| 86 | -+ | |||
| 189 | +4x |
- #' there is no available content row summing up these counts.+ control = control, |
||
| 87 | -+ | |||
| 190 | +4x |
- #'+ data = data, |
||
| 88 | +191 |
- #' @return+ ... |
||
| 89 | +192 |
- #' * `score_occurrences_subtable()` returns a function that sums counts in each subtable+ ) |
||
| 90 | +193 |
- #' across all specified columns.+ } |
||
| 91 | +194 |
- #'+ |
||
| 92 | +195 |
- #' @examples+ #' @describeIn cox_regression_inter A higher level function to get |
||
| 93 | +196 |
- #' score_subtable_all <- score_occurrences_subtable(col_names = names(tbl))+ #' the results of the interaction test and the estimated values. |
||
| 94 | +197 |
#' |
||
| 95 | -- |
- #' # Note that this code just sorts the AEBODSYS, not the AEDECOD within AEBODSYS. That- |
- ||
| 96 | -- |
- #' # would require a second pass of `sort_at_path`.- |
- ||
| 97 | -- |
- #' tbl_sorted <- tbl %>%- |
- ||
| 98 | +198 |
- #' sort_at_path(path = c("AEBODSYS"), scorefun = score_subtable_all, decreasing = FALSE)
+ #' @return |
||
| 99 | +199 |
- #'+ #' * `h_coxreg_extract_interaction()` returns the result of an interaction test and the estimated values. If |
||
| 100 | +200 |
- #' tbl_sorted+ #' no interaction, [h_coxreg_univar_extract()] is applied instead. |
||
| 101 | +201 |
#' |
||
| 102 | +202 |
- #' @export+ #' @examples |
||
| 103 | +203 |
- 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)+ #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder) |
||
| 109 | +204 |
- }+ #' h_coxreg_extract_interaction( |
||
| 110 | +205 |
- }+ #' mod = mod, effect = "armcd", covar = "covar1", data = dta_bladder, |
||
| 111 | +206 |
-
+ #' control = control_coxreg() |
||
| 112 | +207 |
- #' @describeIn score_occurrences Produce score function for sorting table by summing the first content row in+ #' ) |
||
| 113 | +208 |
- #' specified columns. Note that this is extending [rtables::cont_n_onecol()] and [rtables::cont_n_allcols()].+ #' |
||
| 114 | +209 |
- #'+ #' @export |
||
| 115 | +210 |
- #' @return+ h_coxreg_extract_interaction <- function(effect, |
||
| 116 | +211 |
- #' * `score_occurrences_cont_cols()` returns a function that sums counts in the first content row in+ covar, |
||
| 117 | +212 |
- #' specified columns.+ mod, |
||
| 118 | +213 |
- #'+ data, |
||
| 119 | +214 |
- #' @export+ at, |
||
| 120 | +215 |
- score_occurrences_cont_cols <- function(...) {
+ control) {
|
||
| 121 | -1x | +216 | +27x |
- score_table_row <- score_occurrences_cols(...)+ if (!any(attr(stats::terms(mod), "order") == 2)) {
|
| 122 | -1x | +217 | +10x |
- function(table_tree) {
+ y <- h_coxreg_univar_extract( |
| 123 | -2x | -
- if (inherits(table_tree, "ContentRow")) {
- |
- ||
| 124 | -! | +218 | +10x |
- return(NA)+ effect = effect, covar = covar, mod = mod, data = data, control = control |
| 125 | +219 |
- }+ ) |
||
| 126 | -2x | +220 | +10x |
- content_row <- h_content_first_row(table_tree)+ y$pval_inter <- NA |
| 127 | -2x | -
- score_table_row(content_row)- |
- ||
| 128 | -+ | 221 | +10x |
- }+ y |
| 129 | +222 |
- }+ } else {
|
| 1 | -+ | |||
| 223 | +17x |
- #' Individual Patient Plots+ test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method] |
||
| 2 | +224 |
- #'+ |
||
| 3 | +225 |
- #' @description `r lifecycle::badge("stable")`
+ # Test the main treatment effect. |
||
| 4 | -+ | |||
| 226 | +17x |
- #'+ mod_aov <- muffled_car_anova(mod, test_statistic) |
||
| 5 | -+ | |||
| 227 | +17x |
- #' Line plot(s) displaying trend in patients' parameter values over time is rendered.+ sum_anova <- broom::tidy(mod_aov) |
||
| 6 | -+ | |||
| 228 | +17x |
- #' Patients' individual baseline values can be added to the plot(s) as reference.+ pval <- sum_anova[sum_anova$term == effect, ][["p.value"]] |
||
| 7 | +229 |
- #'+ |
||
| 8 | +230 |
- #' @inheritParams argument_convention+ # Test the interaction effect. |
||
| 9 | -+ | |||
| 231 | +17x |
- #' @param xvar (`string`)\cr time point variable to be plotted on x-axis.+ pval_inter <- sum_anova[grep(":", sum_anova$term), ][["p.value"]]
|
||
| 10 | -+ | |||
| 232 | +17x |
- #' @param yvar (`string`)\cr continuous analysis variable to be plotted on y-axis.+ covar_test <- data.frame( |
||
| 11 | -+ | |||
| 233 | +17x |
- #' @param xlab (`string`)\cr plot label for x-axis.+ effect = "Covariate:", |
||
| 12 | -+ | |||
| 234 | +17x |
- #' @param ylab (`string`)\cr plot label for y-axis.+ term = covar, |
||
| 13 | -+ | |||
| 235 | +17x |
- #' @param id_var (`string`)\cr variable used as patient identifier.+ term_label = unname(labels_or_names(data[covar])), |
||
| 14 | -+ | |||
| 236 | +17x |
- #' @param title (`string`)\cr title for plot.+ level = "", |
||
| 15 | -+ | |||
| 237 | +17x |
- #' @param subtitle (`string`)\cr subtitle for plot.+ n = mod$n, hr = NA, lcl = NA, ucl = NA, pval = pval, |
||
| 16 | -+ | |||
| 238 | +17x |
- #' @param add_baseline_hline (`flag`)\cr adds horizontal line at baseline y-value on+ pval_inter = pval_inter, |
||
| 17 | -+ | |||
| 239 | +17x |
- #' plot when TRUE.+ stringsAsFactors = FALSE |
||
| 18 | +240 |
- #' @param yvar_baseline (`string`)\cr variable with baseline values only.+ ) |
||
| 19 | +241 |
- #' Ignored when `add_baseline_hline` is FALSE.+ # Estimate the interaction. |
||
| 20 | -+ | |||
| 242 | +17x |
- #' @param ggtheme (`theme`)\cr optional graphical theme function as provided+ y <- h_coxreg_inter_effect( |
||
| 21 | -+ | |||
| 243 | +17x |
- #' by `ggplot2` to control outlook of plot. Use `ggplot2::theme()` to tweak the display.+ data[[covar]], |
||
| 22 | -+ | |||
| 244 | +17x |
- #' @param plotting_choices (`character`)\cr specifies options for displaying+ covar = covar, |
||
| 23 | -+ | |||
| 245 | +17x |
- #' plots. Must be one of "all_in_one", "split_by_max_obs", "separate_by_obs".+ effect = effect, |
||
| 24 | -+ | |||
| 246 | +17x |
- #' @param max_obs_per_plot (`count`)\cr Number of observations to be plotted on one+ mod = mod, |
||
| 25 | -+ | |||
| 247 | +17x |
- #' plot. Ignored when `plotting_choices` is not "separate_by_obs".+ label = unname(labels_or_names(data[covar])), |
||
| 26 | -+ | |||
| 248 | +17x |
- #' @param caption (`character` scalar)\cr optional caption below the plot.+ at = at, |
||
| 27 | -+ | |||
| 249 | +17x |
- #' @param col (`character`)\cr lines colors.+ control = control, |
||
| 28 | -+ | |||
| 250 | +17x |
- #'+ data = data |
||
| 29 | +251 |
- #' @seealso Relevant helper function [h_g_ipp()].+ ) |
||
| 30 | -+ | |||
| 252 | +17x |
- #'+ rbind(covar_test, y) |
||
| 31 | +253 |
- #' @name individual_patient_plot+ } |
||
| 32 | +254 |
- NULL+ } |
||
| 33 | +255 | |||
| 34 | -- |
- #' Helper Function To Create Simple Line Plot over Time- |
- ||
| 35 | -- |
- #'- |
- ||
| 36 | +256 |
- #' @description `r lifecycle::badge("stable")`
+ #' @describeIn cox_regression_inter Hazard ratio estimation in interactions. |
||
| 37 | +257 |
#' |
||
| 38 | +258 |
- #' Function that generates a simple line plot displaying parameter trends over time.+ #' @param variable,given (`string`)\cr the name of variables in interaction. We seek the estimation |
||
| 39 | +259 |
- #'+ #' of the levels of `variable` given the levels of `given`. |
||
| 40 | +260 |
- #' @inheritParams argument_convention+ #' @param lvl_var,lvl_given (`character`)\cr corresponding levels has given by [levels()]. |
||
| 41 | +261 |
- #' @inheritParams g_ipp+ #' @param mod (`coxph`)\cr a fitted Cox regression model (see [survival::coxph()]). |
||
| 42 | +262 |
#' |
||
| 43 | +263 |
- #' @return A `ggplot` line plot.+ #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A) |
||
| 44 | +264 |
- #'+ #' and Sex (F, M; reference Female) and the model being abbreviated: y ~ Arm + Sex + Arm:Sex. |
||
| 45 | +265 |
- #' @seealso [g_ipp()] which uses this function.+ #' The cox regression estimates the coefficients along with a variance-covariance matrix for: |
||
| 46 | +266 |
#' |
||
| 47 | +267 |
- #' @examples+ #' - b1 (arm b), b2 (arm c) |
||
| 48 | +268 |
- #' library(dplyr)+ #' - b3 (sex m) |
||
| 49 | +269 |
- #' library(nestcolor)+ #' - b4 (arm b: sex m), b5 (arm c: sex m) |
||
| 50 | +270 |
#' |
||
| 51 | +271 |
- #' # Select a small sample of data to plot.+ #' The estimation of the Hazard Ratio for arm C/sex M is given in reference |
||
| 52 | +272 |
- #' adlb <- tern_ex_adlb %>%+ #' to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5). |
||
| 53 | +273 |
- #' filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
+ #' The interaction coefficient is deduced by b2 + b5 while the standard error |
||
| 54 | +274 |
- #' slice(1:36)+ #' is obtained as $sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$. |
||
| 55 | +275 |
#' |
||
| 56 | +276 |
- #' p <- h_g_ipp(+ #' @return |
||
| 57 | +277 |
- #' df = adlb,+ #' * `h_coxreg_inter_estimations()` returns a list of matrices (one per level of variable) with rows corresponding |
||
| 58 | +278 |
- #' xvar = "AVISIT",+ #' to the combinations of `variable` and `given`, with columns: |
||
| 59 | +279 |
- #' yvar = "AVAL",+ #' * `coef_hat`: Estimation of the coefficient. |
||
| 60 | +280 |
- #' xlab = "Visit",+ #' * `coef_se`: Standard error of the estimation. |
||
| 61 | +281 |
- #' id_var = "USUBJID",+ #' * `hr`: Hazard ratio. |
||
| 62 | +282 |
- #' ylab = "SGOT/ALT (U/L)",+ #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio. |
||
| 63 | +283 |
- #' add_baseline_hline = TRUE+ #' |
||
| 64 | +284 |
- #' )+ #' @examples |
||
| 65 | +285 |
- #' p+ #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder) |
||
| 66 | +286 |
- #'+ #' result <- h_coxreg_inter_estimations( |
||
| 67 | +287 |
- #' @export+ #' variable = "armcd", given = "covar1", |
||
| 68 | +288 |
- h_g_ipp <- function(df,+ #' lvl_var = levels(dta_bladder$armcd), |
||
| 69 | +289 |
- xvar,+ #' lvl_given = levels(dta_bladder$covar1), |
||
| 70 | +290 |
- yvar,+ #' mod = mod, conf_level = .95 |
||
| 71 | +291 |
- xlab,+ #' ) |
||
| 72 | +292 |
- ylab,+ #' result |
||
| 73 | +293 |
- id_var,+ #' |
||
| 74 | +294 |
- title = "Individual Patient Plots",+ #' @export |
||
| 75 | +295 |
- subtitle = "",+ h_coxreg_inter_estimations <- function(variable, |
||
| 76 | +296 |
- caption = NULL,+ given, |
||
| 77 | +297 |
- add_baseline_hline = FALSE,+ lvl_var, |
||
| 78 | +298 |
- yvar_baseline = "BASE",+ lvl_given, |
||
| 79 | +299 |
- ggtheme = nestcolor::theme_nest(),+ mod, |
||
| 80 | +300 |
- col = NULL) {
+ conf_level = 0.95) {
|
||
| 81 | -13x | +301 | +16x |
- checkmate::assert_string(xvar)+ var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level |
| 82 | -13x | +302 | +16x |
- checkmate::assert_string(yvar)+ giv_lvl <- paste0(given, lvl_given) |
| 83 | -13x | +303 | +16x |
- checkmate::assert_string(yvar_baseline)+ design_mat <- expand.grid(variable = var_lvl, given = giv_lvl) |
| 84 | -13x | +304 | +16x |
- checkmate::assert_string(id_var)+ design_mat <- design_mat[order(design_mat$variable, design_mat$given), ] |
| 85 | -13x | +305 | +16x |
- checkmate::assert_string(xlab)+ design_mat <- within( |
| 86 | -13x | +306 | +16x |
- checkmate::assert_string(ylab)+ data = design_mat, |
| 87 | -13x | +307 | +16x |
- checkmate::assert_string(title)+ expr = {
|
| 88 | -13x | +308 | +16x |
- checkmate::assert_string(subtitle)+ inter <- paste0(variable, ":", given) |
| 89 | -13x | +309 | +16x |
- checkmate::assert_subset(c(xvar, yvar, yvar_baseline, id_var), colnames(df))+ rev_inter <- paste0(given, ":", variable) |
| 90 | -13x | +|||
| 310 | +
- checkmate::assert_data_frame(df)+ }+ |
+ |||
| 311 | ++ |
+ ) |
||
| 91 | -13x | +312 | +16x |
- checkmate::assert_flag(add_baseline_hline)+ split_by_variable <- design_mat$variable |
| 92 | -13x | +313 | +16x |
- checkmate::assert_character(col, null.ok = TRUE)+ interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/") |
| 93 | +314 | |||
| 94 | -13x | +315 | +16x |
- p <- ggplot2::ggplot(+ mmat <- stats::model.matrix(mod)[1, ] |
| 95 | -13x | +316 | +16x |
- data = df,+ mmat[!mmat == 0] <- 0 |
| 96 | -13x | +|||
| 317 | +
- mapping = ggplot2::aes(+ |
|||
| 97 | -13x | +318 | +16x |
- x = .data[[xvar]],+ design_mat <- apply( |
| 98 | -13x | +319 | +16x |
- y = .data[[yvar]],+ X = design_mat, MARGIN = 1, FUN = function(x) {
|
| 99 | -13x | +320 | +46x |
- group = .data[[id_var]],+ mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1 |
| 100 | -13x | +321 | +46x |
- colour = .data[[id_var]]+ mmat |
| 101 | +322 |
- )+ } |
||
| 102 | +323 |
- ) +- |
- ||
| 103 | -13x | -
- ggplot2::geom_line(linewidth = 0.4) +- |
- ||
| 104 | -13x | -
- ggplot2::geom_point(size = 2) +- |
- ||
| 105 | -13x | -
- ggplot2::labs(+ ) |
||
| 106 | -13x | +324 | +16x |
- x = xlab,+ colnames(design_mat) <- interaction_names |
| 107 | -13x | +|||
| 325 | +
- y = ylab,+ |
|||
| 108 | -13x | +326 | +16x |
- title = title,+ coef <- stats::coef(mod) |
| 109 | -13x | +327 | +16x |
- subtitle = subtitle,+ vcov <- stats::vcov(mod) |
| 110 | -13x | -
- caption = caption- |
- ||
| 111 | -+ | 328 | +16x |
- ) ++ betas <- as.matrix(coef) |
| 112 | -13x | -
- ggtheme- |
- ||
| 113 | -+ | 329 | +16x |
-
+ coef_hat <- t(design_mat) %*% betas |
| 114 | -13x | +330 | +16x |
- if (add_baseline_hline) {
+ dimnames(coef_hat)[2] <- "coef" |
| 115 | -12x | +331 | +16x |
- baseline_df <- df[, c(id_var, yvar_baseline)]+ coef_se <- apply( |
| 116 | -12x | -
- baseline_df <- unique(baseline_df)- |
- ||
| 117 | -+ | 332 | +16x |
-
+ design_mat, 2, |
| 118 | -12x | +333 | +16x |
- p <- p ++ function(x) {
|
| 119 | -12x | +334 | +46x |
- ggplot2::geom_hline(+ vcov_el <- as.logical(x) |
| 120 | -12x | +335 | +46x |
- data = baseline_df,+ y <- vcov[vcov_el, vcov_el] |
| 121 | -12x | +336 | +46x |
- mapping = ggplot2::aes(+ y <- sum(y) |
| 122 | -12x | +337 | +46x |
- yintercept = .data[[yvar_baseline]],+ y <- sqrt(y) |
| 123 | -12x | +338 | +46x |
- colour = .data[[id_var]]+ return(y) |
| 124 | +339 |
- ),- |
- ||
| 125 | -12x | -
- linetype = "dotdash",- |
- ||
| 126 | -12x | -
- linewidth = 0.4+ } |
||
| 127 | +340 |
- ) ++ ) |
||
| 128 | -12x | +341 | +16x |
- ggplot2::geom_text(+ q_norm <- stats::qnorm((1 + conf_level) / 2) |
| 129 | -12x | +342 | +16x |
- data = baseline_df,+ y <- cbind(coef_hat, `se(coef)` = coef_se) |
| 130 | -12x | +343 | +16x |
- mapping = ggplot2::aes(+ y <- apply(y, 1, function(x) {
|
| 131 | -12x | +344 | +46x |
- x = 1,+ x["hr"] <- exp(x["coef"]) |
| 132 | -12x | +345 | +46x |
- y = .data[[yvar_baseline]],+ x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"]) |
| 133 | -12x | +346 | +46x |
- label = .data[[id_var]],+ x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"]) |
| 134 | -12x | +347 | +46x |
- colour = .data[[id_var]]+ x |
| 135 | +348 |
- ),+ }) |
||
| 136 | -12x | +349 | +16x |
- nudge_y = 0.025 * (max(df[, yvar], na.rm = TRUE) - min(df[, yvar], na.rm = TRUE)),+ y <- t(y) |
| 137 | -12x | +350 | +16x |
- vjust = "right",+ y <- by(y, split_by_variable, identity) |
| 138 | -12x | -
- size = 2- |
- ||
| 139 | -- |
- )- |
- ||
| 140 | -+ | 351 | +16x |
-
+ y <- lapply(y, as.matrix) |
| 141 | -12x | +352 | +16x |
- if (!is.null(col)) {
+ attr(y, "details") <- paste0( |
| 142 | -1x | +353 | +16x |
- p <- p ++ "Estimations of ", variable, |
| 143 | -1x | +354 | +16x |
- ggplot2::scale_color_manual(values = col)+ " hazard ratio given the level of ", given, " compared to ", |
| 144 | -+ | |||
| 355 | +16x |
- }+ variable, " level ", lvl_var[1], "." |
||
| 145 | +356 |
- }+ ) |
||
| 146 | -13x | +357 | +16x |
- p+ y |
| 147 | +358 |
} |
| 148 | -- | - - | -||
| 149 | -- |
- #' @describeIn individual_patient_plot Plotting function for individual patient plots which, depending on user- |
- ||
| 150 | -- |
- #' preference, renders a single graphic or compiles a list of graphics that show trends in individual's parameter- |
- ||
| 151 | +1 |
- #' values over time.+ #' Counting Patients Summing Exposure Across All Patients in Columns |
||
| 152 | +2 |
#' |
||
| 153 | +3 |
- #' @return A `ggplot` object or a list of `ggplot` objects.+ #' @description `r lifecycle::badge("stable")`
|
||
| 154 | +4 |
#' |
||
| 155 | -- |
- #' @examples- |
- ||
| 156 | +5 |
- #' library(dplyr)+ #' Counting the number of patients and summing analysis value (i.e exposure values) across all patients |
||
| 157 | +6 |
- #' library(nestcolor)+ #' when a column table layout is required. |
||
| 158 | +7 |
#' |
||
| 159 | -- |
- #' # Select a small sample of data to plot.- |
- ||
| 160 | -- |
- #' adlb <- tern_ex_adlb %>%- |
- ||
| 161 | -- |
- #' filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
- |
- ||
| 162 | +8 |
- #' slice(1:36)+ #' @inheritParams argument_convention |
||
| 163 | +9 |
#' |
||
| 164 | -- |
- #' plot_list <- g_ipp(- |
- ||
| 165 | -- |
- #' df = adlb,- |
- ||
| 166 | -- |
- #' xvar = "AVISIT",- |
- ||
| 167 | -- |
- #' yvar = "AVAL",- |
- ||
| 168 | +10 |
- #' xlab = "Visit",+ #' @name summarize_patients_exposure_in_cols |
||
| 169 | +11 |
- #' ylab = "SGOT/ALT (U/L)",+ NULL |
||
| 170 | +12 |
- #' title = "Individual Patient Plots",+ |
||
| 171 | +13 |
- #' add_baseline_hline = TRUE,+ #' @describeIn summarize_patients_exposure_in_cols Statistics function which counts numbers |
||
| 172 | +14 |
- #' plotting_choices = "split_by_max_obs",+ #' of patients and the sum of exposure across all patients. |
||
| 173 | +15 |
- #' max_obs_per_plot = 5+ #' |
||
| 174 | +16 |
- #' )+ #' @param ex_var (`character`)\cr name of the variable within `df` containing exposure values. |
||
| 175 | +17 |
- #' plot_list+ #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will be used as label. |
||
| 176 | +18 |
#' |
||
| 177 | -- |
- #' @export- |
- ||
| 178 | -- |
- g_ipp <- function(df,- |
- ||
| 179 | +19 |
- xvar,+ #' @return |
||
| 180 | +20 |
- yvar,+ #' * `s_count_patients_sum_exposure()` returns a named `list` with the statistics: |
||
| 181 | +21 |
- xlab,+ #' * `n_patients`: Number of unique patients in `df`. |
||
| 182 | +22 |
- ylab,+ #' * `sum_exposure`: Sum of `ex_var` across all patients in `df`. |
||
| 183 | +23 |
- id_var = "USUBJID",+ #' |
||
| 184 | +24 |
- title = "Individual Patient Plots",+ #' @examples |
||
| 185 | +25 |
- subtitle = "",+ #' set.seed(1) |
||
| 186 | +26 |
- caption = NULL,+ #' df <- data.frame( |
||
| 187 | +27 |
- add_baseline_hline = FALSE,+ #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
|
||
| 188 | +28 |
- yvar_baseline = "BASE",+ #' ARMCD = c(rep("ARM A", 6), rep("ARM B", 6)),
|
||
| 189 | +29 |
- ggtheme = nestcolor::theme_nest(),+ #' SEX = c(rep("Female", 6), rep("Male", 6)),
|
||
| 190 | +30 |
- plotting_choices = c("all_in_one", "split_by_max_obs", "separate_by_obs"),
+ #' AVAL = as.numeric(sample(seq(1, 20), 12)), |
||
| 191 | +31 |
- max_obs_per_plot = 4,+ #' stringsAsFactors = TRUE |
||
| 192 | +32 |
- col = NULL) {
- |
- ||
| 193 | -3x | -
- checkmate::assert_count(max_obs_per_plot)- |
- ||
| 194 | -3x | -
- checkmate::assert_subset(plotting_choices, c("all_in_one", "split_by_max_obs", "separate_by_obs"))
- |
- ||
| 195 | -3x | -
- checkmate::assert_character(col, null.ok = TRUE)+ #' ) |
||
| 196 | +33 | - - | -||
| 197 | -3x | -
- plotting_choices <- match.arg(plotting_choices)+ #' adsl <- data.frame( |
||
| 198 | +34 | - - | -||
| 199 | -3x | -
- if (plotting_choices == "all_in_one") {
- |
- ||
| 200 | -1x | -
- p <- h_g_ipp(- |
- ||
| 201 | -1x | -
- df = df,- |
- ||
| 202 | -1x | -
- xvar = xvar,- |
- ||
| 203 | -1x | -
- yvar = yvar,- |
- ||
| 204 | -1x | -
- xlab = xlab,- |
- ||
| 205 | -1x | -
- ylab = ylab,- |
- ||
| 206 | -1x | -
- id_var = id_var,- |
- ||
| 207 | -1x | -
- title = title,- |
- ||
| 208 | -1x | -
- subtitle = subtitle,- |
- ||
| 209 | -1x | -
- caption = caption,- |
- ||
| 210 | -1x | -
- add_baseline_hline = add_baseline_hline,- |
- ||
| 211 | -1x | -
- yvar_baseline = yvar_baseline,- |
- ||
| 212 | -1x | -
- ggtheme = ggtheme,- |
- ||
| 213 | -1x | -
- col = col+ #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
|
||
| 214 | +35 |
- )+ #' ARMCD = c(rep("ARM A", 2), rep("ARM B", 2)),
|
||
| 215 | +36 | - - | -||
| 216 | -1x | -
- return(p)- |
- ||
| 217 | -2x | -
- } else if (plotting_choices == "split_by_max_obs") {
- |
- ||
| 218 | -1x | -
- id_vec <- unique(df[[id_var]])- |
- ||
| 219 | -1x | -
- id_list <- split(- |
- ||
| 220 | -1x | -
- id_vec,- |
- ||
| 221 | -1x | -
- rep(1:ceiling(length(id_vec) / max_obs_per_plot),- |
- ||
| 222 | -1x | -
- each = max_obs_per_plot,- |
- ||
| 223 | -1x | -
- length.out = length(id_vec)+ #' SEX = c(rep("Female", 2), rep("Male", 2)),
|
||
| 224 | +37 |
- )+ #' stringsAsFactors = TRUE |
||
| 225 | +38 |
- )+ #' ) |
||
| 226 | +39 | - - | -||
| 227 | -1x | -
- df_list <- list()- |
- ||
| 228 | -1x | -
- plot_list <- list()+ #' |
||
| 229 | +40 | - - | -||
| 230 | -1x | -
- for (i in seq_along(id_list)) {
- |
- ||
| 231 | -2x | -
- df_list[[i]] <- df[df[[id_var]] %in% id_list[[i]], ]+ #' @keywords internal |
||
| 232 | -- | - - | -||
| 233 | -2x | -
- plots <- h_g_ipp(- |
- ||
| 234 | -2x | -
- df = df_list[[i]],- |
- ||
| 235 | -2x | -
- xvar = xvar,- |
- ||
| 236 | -2x | -
- yvar = yvar,- |
- ||
| 237 | -2x | +41 | +
- xlab = xlab,+ s_count_patients_sum_exposure <- function(df, |
|
| 238 | -2x | +|||
| 42 | +
- ylab = ylab,+ ex_var = "AVAL", |
|||
| 239 | -2x | +|||
| 43 | +
- id_var = id_var,+ id = "USUBJID", |
|||
| 240 | -2x | +|||
| 44 | +
- title = title,+ labelstr = "", |
|||
| 241 | -2x | +|||
| 45 | +
- subtitle = subtitle,+ .stats = c("n_patients", "sum_exposure"),
|
|||
| 242 | -2x | +|||
| 46 | +
- caption = caption,+ .N_col, # nolint |
|||
| 243 | -2x | +|||
| 47 | +
- add_baseline_hline = add_baseline_hline,+ custom_label = NULL) {
|
|||
| 244 | -2x | +48 | +56x |
- yvar_baseline = yvar_baseline,+ assert_df_with_variables(df, list(ex_var = ex_var, id = id)) |
| 245 | -2x | +49 | +56x |
- ggtheme = ggtheme,+ checkmate::assert_string(id) |
| 246 | -2x | +50 | +56x |
- col = col+ checkmate::assert_string(labelstr) |
| 247 | -+ | |||
| 51 | +56x |
- )+ checkmate::assert_string(custom_label, null.ok = TRUE) |
||
| 248 | -+ | |||
| 52 | +56x |
-
+ checkmate::assert_numeric(df[[ex_var]]) |
||
| 249 | -2x | +53 | +56x |
- plot_list[[i]] <- plots+ checkmate::assert_true(all(.stats %in% c("n_patients", "sum_exposure")))
|
| 250 | +54 |
- }+ |
||
| 251 | -1x | -
- return(plot_list)- |
- ||
| 252 | -+ | 55 | +56x |
- } else {
+ row_label <- if (labelstr != "") {
|
| 253 | -1x | +|||
| 56 | +! |
- ind_df <- split(df, df[[id_var]])+ labelstr |
||
| 254 | -1x | +57 | +56x |
- plot_list <- lapply(+ } else if (!is.null(custom_label)) {
|
| 255 | -1x | +58 | +48x |
- ind_df,+ custom_label |
| 256 | -1x | +|||
| 59 | +
- function(x) {
+ } else {
|
|||
| 257 | +60 | 8x |
- h_g_ipp(+ "Total patients numbers/person time" |
|
| 258 | -8x | +|||
| 61 | +
- df = x,+ } |
|||
| 259 | -8x | +|||
| 62 | +
- xvar = xvar,+ |
|||
| 260 | -8x | +63 | +56x |
- yvar = yvar,+ y <- list() |
| 261 | -8x | +|||
| 64 | +
- xlab = xlab,+ |
|||
| 262 | -8x | +65 | +56x |
- ylab = ylab,+ if ("n_patients" %in% .stats) {
|
| 263 | -8x | +66 | +23x |
- id_var = id_var,+ y$n_patients <- |
| 264 | -8x | +67 | +23x |
- title = title,+ formatters::with_label( |
| 265 | -8x | +68 | +23x |
- subtitle = subtitle,+ s_num_patients_content( |
| 266 | -8x | +69 | +23x |
- caption = caption,+ df = df, |
| 267 | -8x | +70 | +23x |
- add_baseline_hline = add_baseline_hline,+ .N_col = .N_col, # nolint |
| 268 | -8x | +71 | +23x |
- yvar_baseline = yvar_baseline,+ .var = id, |
| 269 | -8x | +72 | +23x |
- ggtheme = ggtheme,+ labelstr = "" |
| 270 | -8x | +73 | +23x |
- col = col+ )$unique, |
| 271 | -+ | |||
| 74 | +23x |
- )+ row_label |
||
| 272 | +75 |
- }+ ) |
||
| 273 | +76 |
- )+ } |
||
| 274 | -+ | |||
| 77 | +56x |
-
+ if ("sum_exposure" %in% .stats) {
|
||
| 275 | -1x | +78 | +34x |
- return(plot_list)+ y$sum_exposure <- formatters::with_label(sum(df[[ex_var]]), row_label) |
| 276 | +79 |
} |
||
| 277 | -+ | |||
| 80 | +56x |
- }+ y |
| 1 | +81 |
- #' Control function for incidence rate+ } |
||
| 2 | +82 |
- #'+ |
||
| 3 | +83 |
- #' @description `r lifecycle::badge("stable")`
+ #' @describeIn summarize_patients_exposure_in_cols Analysis function which is used as `afun` in |
||
| 4 | +84 |
- #'+ #' [rtables::analyze_colvars()] within `analyze_patients_exposure_in_cols()` and as `cfun` in |
||
| 5 | +85 |
- #' This is an auxiliary function for controlling arguments for the incidence rate, used+ #' [rtables::summarize_row_groups()] within `summarize_patients_exposure_in_cols()`. |
||
| 6 | +86 |
- #' internally to specify details in `s_incidence_rate()`.+ #' |
||
| 7 | +87 |
- #'+ #' @return |
||
| 8 | +88 |
- #' @inheritParams argument_convention+ #' * `a_count_patients_sum_exposure()` returns formatted [rtables::CellValue()]. |
||
| 9 | +89 |
- #' @param conf_type (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`+ #' |
||
| 10 | +90 |
- #' for confidence interval type.+ #' @examples |
||
| 11 | +91 |
- #' @param input_time_unit (`string`)\cr `day`, `week`, `month`, or `year` (default)+ #' a_count_patients_sum_exposure( |
||
| 12 | +92 |
- #' indicating time unit for data input.+ #' df = df, |
||
| 13 | +93 |
- #' @param num_pt_year (`numeric`)\cr number of patient-years to use when calculating adverse event rates.+ #' var = "SEX", |
||
| 14 | +94 |
- #' @param time_unit_input `r lifecycle::badge("deprecated")` Please use the `input_time_unit` argument instead.
+ #' .N_col = nrow(df), |
||
| 15 | +95 |
- #' @param time_unit_output `r lifecycle::badge("deprecated")` Please use the `num_pt_year` argument instead.
+ #' .stats = "n_patients" |
||
| 16 | +96 |
- #'+ #' ) |
||
| 17 | +97 |
- #' @return A list of components with the same names as the arguments.+ #' |
||
| 18 | +98 |
- #'+ #' @export |
||
| 19 | +99 |
- #' @seealso [incidence_rate]+ a_count_patients_sum_exposure <- function(df, |
||
| 20 | +100 |
- #'+ var = NULL, |
||
| 21 | +101 |
- #' @examples+ ex_var = "AVAL", |
||
| 22 | +102 |
- #' control_incidence_rate(0.9, "exact", "month", 100)+ id = "USUBJID", |
||
| 23 | +103 |
- #'+ labelstr = "", |
||
| 24 | +104 |
- #' @export+ add_total_level = FALSE, |
||
| 25 | +105 |
- control_incidence_rate <- function(conf_level = 0.95,+ .N_col, # nolint |
||
| 26 | +106 |
- conf_type = c("normal", "normal_log", "exact", "byar"),
+ .stats, |
||
| 27 | +107 |
- input_time_unit = c("year", "day", "week", "month"),
+ .formats = list(n_patients = "xx (xx.x%)", sum_exposure = "xx"), |
||
| 28 | +108 |
- num_pt_year = 100,+ custom_label = NULL) {
|
||
| 29 | -+ | |||
| 109 | +32x |
- time_unit_input = lifecycle::deprecated(),+ checkmate::assert_flag(add_total_level) |
||
| 30 | +110 |
- time_unit_output = lifecycle::deprecated()) {
+
|
||
| 31 | -8x | +111 | +32x |
- if (lifecycle::is_present(time_unit_input)) {
+ if (!is.null(var)) {
|
| 32 | -! | +|||
| 112 | +21x |
- lifecycle::deprecate_warn(+ assert_df_with_variables(df, list(var = var)) |
||
| 33 | -! | +|||
| 113 | +21x |
- "0.8.3", "control_incidence_rate(time_unit_input)", "control_incidence_rate(input_time_unit)"+ df[[var]] <- as.factor(df[[var]]) |
||
| 34 | +114 |
- )- |
- ||
| 35 | -! | -
- input_time_unit <- time_unit_input+ } |
||
| 36 | +115 |
- }+ |
||
| 37 | -8x | +116 | +32x |
- if (lifecycle::is_present(time_unit_output)) {
+ y <- list() |
| 38 | -! | +|||
| 117 | +32x |
- lifecycle::deprecate_warn(+ if (is.null(var)) {
|
||
| 39 | -! | +|||
| 118 | +11x |
- "0.8.3", "control_incidence_rate(time_unit_output)", "control_incidence_rate(num_pt_year)"+ y[[.stats]] <- list(Total = s_count_patients_sum_exposure( |
||
| 40 | -+ | |||
| 119 | +11x |
- )+ df = df, |
||
| 41 | -! | +|||
| 120 | +11x |
- num_pt_year <- time_unit_output+ ex_var = ex_var, |
||
| 42 | -+ | |||
| 121 | +11x |
- }+ id = id, |
||
| 43 | -+ | |||
| 122 | +11x |
-
+ labelstr = labelstr, |
||
| 44 | -8x | +123 | +11x |
- conf_type <- match.arg(conf_type)+ .N_col = .N_col, |
| 45 | -7x | +124 | +11x |
- input_time_unit <- match.arg(input_time_unit)+ .stats = .stats, |
| 46 | -6x | +125 | +11x |
- checkmate::assert_number(num_pt_year)+ custom_label = custom_label |
| 47 | -5x | +126 | +11x |
- assert_proportion_value(conf_level)+ )[[.stats]]) |
| 48 | +127 |
-
+ } else {
|
||
| 49 | -4x | +128 | +21x |
- list(+ for (lvl in levels(df[[var]])) {
|
| 50 | -4x | +129 | +42x |
- conf_level = conf_level,+ y[[.stats]][[lvl]] <- s_count_patients_sum_exposure( |
| 51 | -4x | +130 | +42x |
- conf_type = conf_type,+ df = subset(df, get(var) == lvl), |
| 52 | -4x | +131 | +42x |
- input_time_unit = input_time_unit,+ ex_var = ex_var, |
| 53 | -4x | +132 | +42x |
- num_pt_year = num_pt_year+ id = id, |
| 54 | -+ | |||
| 133 | +42x |
- )+ labelstr = labelstr, |
||
| 55 | -+ | |||
| 134 | +42x |
- }+ .N_col = .N_col, |
| 1 | -+ | |||
| 135 | +42x |
- #' Counting Patients and Events in Columns+ .stats = .stats, |
||
| 2 | -+ | |||
| 136 | +42x |
- #'+ custom_label = lvl |
||
| 3 | -+ | |||
| 137 | +42x |
- #' @description `r lifecycle::badge("stable")`
+ )[[.stats]] |
||
| 4 | +138 |
- #'+ } |
||
| 5 | -+ | |||
| 139 | +21x |
- #' Counting the number of unique patients and the total number of all and specific events+ if (add_total_level) {
|
||
| 6 | -+ | |||
| 140 | +2x |
- #' when a column table layout is required.+ y[[.stats]][["Total"]] <- s_count_patients_sum_exposure( |
||
| 7 | -+ | |||
| 141 | +2x |
- #'+ df = df, |
||
| 8 | -+ | |||
| 142 | +2x |
- #' @inheritParams argument_convention+ ex_var = ex_var, |
||
| 9 | -+ | |||
| 143 | +2x |
- #'+ id = id, |
||
| 10 | -+ | |||
| 144 | +2x |
- #' @name count_patients_events_in_cols+ labelstr = labelstr, |
||
| 11 | -+ | |||
| 145 | +2x |
- NULL+ .N_col = .N_col, |
||
| 12 | -+ | |||
| 146 | +2x |
-
+ .stats = .stats, |
||
| 13 | -+ | |||
| 147 | +2x |
- #' @describeIn count_patients_events_in_cols Statistics function which counts numbers of patients and multiple+ custom_label = custom_label |
||
| 14 | -+ | |||
| 148 | +2x |
- #' events defined by filters. Used as analysis function `afun` in `summarize_patients_events_in_cols()`.+ )[[.stats]] |
||
| 15 | +149 |
- #'+ } |
||
| 16 | +150 |
- #' @param filters_list (named `list` of `character`)\cr each element in this list describes one+ } |
||
| 17 | +151 |
- #' type of event describe by filters, in the same format as [s_count_patients_with_event()].+ |
||
| 18 | -+ | |||
| 152 | +32x |
- #' If it has a label, then this will be used for the column title.+ in_rows(.list = y[[.stats]], .formats = .formats[[.stats]]) |
||
| 19 | +153 |
- #' @param empty_stats (`character`)\cr optional names of the statistics that should be returned empty such+ } |
||
| 20 | +154 |
- #' that corresponding table cells will stay blank.+ |
||
| 21 | +155 |
- #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will+ #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics |
||
| 22 | +156 |
- #' be used as label.+ #' function arguments and additional format arguments. This function is a wrapper for |
||
| 23 | +157 |
- #'+ #' [rtables::split_cols_by_multivar()] and [rtables::summarize_row_groups()]. |
||
| 24 | +158 |
- #' @return+ #' |
||
| 25 | +159 |
- #' * `s_count_patients_and_multiple_events()` returns a list with the statistics:+ #' @return |
||
| 26 | +160 |
- #' - `unique`: number of unique patients in `df`.+ #' * `summarize_patients_exposure_in_cols()` returns a layout object suitable for passing to further |
||
| 27 | +161 |
- #' - `all`: number of rows in `df`.+ #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will |
||
| 28 | +162 |
- #' - one element with the same name as in `filters_list`: number of rows in `df`,+ #' add formatted content rows, with the statistics from `s_count_patients_sum_exposure()` arranged in |
||
| 29 | +163 |
- #' i.e. events, fulfilling the filter condition.+ #' columns, to the table layout. |
||
| 30 | +164 |
#' |
||
| 31 | +165 |
#' @examples |
||
| 32 | +166 |
- #' # `s_count_patients_and_multiple_events()`+ #' lyt <- basic_table() %>% |
||
| 33 | +167 |
- #' df <- data.frame(+ #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) |
||
| 34 | +168 |
- #' USUBJID = rep(c("id1", "id2", "id3", "id4"), c(2, 3, 1, 1)),
+ #' result <- build_table(lyt, df = df, alt_counts_df = adsl) |
||
| 35 | +169 |
- #' ARM = c("A", "A", "B", "B", "B", "B", "A"),
+ #' result |
||
| 36 | +170 |
- #' AESER = rep("Y", 7),
+ #' |
||
| 37 | +171 |
- #' AESDTH = c("Y", "Y", "N", "Y", "Y", "N", "N"),
+ #' lyt2 <- basic_table() %>% |
||
| 38 | +172 |
- #' AEREL = c("Y", "Y", "N", "Y", "Y", "N", "Y"),
+ #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE, .stats = "sum_exposure") |
||
| 39 | +173 |
- #' AEDECOD = c("A", "A", "A", "B", "B", "C", "D"),
+ #' result2 <- build_table(lyt2, df = df, alt_counts_df = adsl) |
||
| 40 | +174 |
- #' AEBODSYS = rep(c("SOC1", "SOC2", "SOC3"), c(3, 3, 1))
+ #' result2 |
||
| 41 | +175 |
- #' )+ #' |
||
| 42 | +176 |
- #'+ #' @export |
||
| 43 | +177 |
- #' @keywords internal+ summarize_patients_exposure_in_cols <- function(lyt, # nolint |
||
| 44 | +178 |
- s_count_patients_and_multiple_events <- function(df, # nolint+ var, |
||
| 45 | +179 |
- id,+ na_str = NA_character_, |
||
| 46 | +180 |
- filters_list,+ ..., |
||
| 47 | +181 |
- empty_stats = character(),+ .stats = c("n_patients", "sum_exposure"),
|
||
| 48 | +182 |
- labelstr = "",+ .labels = c(n_patients = "Patients", sum_exposure = "Person time"), |
||
| 49 | +183 |
- custom_label = NULL) {
+ .indent_mods = NULL, |
||
| 50 | -9x | +|||
| 184 | +
- checkmate::assert_list(filters_list, names = "named")+ col_split = TRUE) {
|
|||
| 51 | -9x | +185 | +3x |
- checkmate::assert_data_frame(df)+ if (col_split) {
|
| 52 | -9x | +186 | +3x |
- checkmate::assert_string(id)+ lyt <- split_cols_by_multivar( |
| 53 | -9x | +187 | +3x |
- checkmate::assert_disjunct(c("unique", "all"), names(filters_list))
+ lyt = lyt, |
| 54 | -9x | +188 | +3x |
- checkmate::assert_character(empty_stats)+ vars = rep(var, length(.stats)), |
| 55 | -9x | +189 | +3x |
- checkmate::assert_string(labelstr)+ varlabels = .labels[.stats], |
| 56 | -9x | +190 | +3x |
- checkmate::assert_string(custom_label, null.ok = TRUE)+ extra_args = list(.stats = .stats) |
| 57 | +191 |
-
+ ) |
||
| 58 | +192 |
- # Below we want to count each row in `df` once, therefore introducing this helper index column.+ } |
||
| 59 | -9x | +193 | +3x |
- df$.row_index <- as.character(seq_len(nrow(df)))+ summarize_row_groups( |
| 60 | -9x | +194 | +3x |
- y <- list()+ lyt = lyt, |
| 61 | -9x | +195 | +3x |
- row_label <- if (labelstr != "") {
+ var = var, |
| 62 | -! | +|||
| 196 | +3x |
- labelstr+ cfun = a_count_patients_sum_exposure, |
||
| 63 | -9x | +197 | +3x |
- } else if (!is.null(custom_label)) {
+ na_str = na_str, |
| 64 | -2x | +198 | +3x |
- custom_label+ extra_args = list(...) |
| 65 | +199 |
- } else {
- |
- ||
| 66 | -7x | -
- "counts"+ ) |
||
| 67 | +200 |
- }- |
- ||
| 68 | -9x | -
- y$unique <- formatters::with_label(- |
- ||
| 69 | -9x | -
- s_num_patients_content(df = df, .N_col = 1, .var = id, required = NULL)$unique[1L],- |
- ||
| 70 | -9x | -
- row_label+ } |
||
| 71 | +201 |
- )- |
- ||
| 72 | -9x | -
- y$all <- formatters::with_label(- |
- ||
| 73 | -9x | -
- nrow(df),+ |
||
| 74 | -9x | +|||
| 202 | +
- row_label+ #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics |
|||
| 75 | +203 |
- )+ #' function arguments and additional format arguments. This function is a wrapper for |
||
| 76 | -9x | +|||
| 204 | +
- events <- Map(+ #' [rtables::split_cols_by_multivar()] and [rtables::analyze_colvars()]. |
|||
| 77 | -9x | +|||
| 205 | +
- function(filters) {
+ #' |
|||
| 78 | -25x | +|||
| 206 | +
- formatters::with_label(+ #' @param col_split (`flag`)\cr whether the columns should be split. Set to `FALSE` when the required |
|||
| 79 | -25x | +|||
| 207 | +
- s_count_patients_with_event(df = df, .var = ".row_index", filters = filters, .N_col = 1, .N_row = 1)$count,+ #' column split has been done already earlier in the layout pipe. |
|||
| 80 | -25x | +|||
| 208 | +
- row_label+ #' |
|||
| 81 | +209 |
- )+ #' @return |
||
| 82 | +210 |
- },+ #' * `analyze_patients_exposure_in_cols()` returns a layout object suitable for passing to further |
||
| 83 | -9x | +|||
| 211 | +
- filters = filters_list+ #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will |
|||
| 84 | +212 |
- )+ #' add formatted data rows, with the statistics from `s_count_patients_sum_exposure()` arranged in |
||
| 85 | -9x | +|||
| 213 | +
- y_complete <- c(y, events)+ #' columns, to the table layout. |
|||
| 86 | -9x | +|||
| 214 | +
- y <- if (length(empty_stats) > 0) {
+ #' |
|||
| 87 | -3x | +|||
| 215 | +
- y_reduced <- y_complete+ #' @note As opposed to [summarize_patients_exposure_in_cols()] which generates content rows, |
|||
| 88 | -3x | +|||
| 216 | +
- for (stat in intersect(names(y_complete), empty_stats)) {
+ #' `analyze_patients_exposure_in_cols()` generates data rows which will _not_ be repeated on multiple |
|||
| 89 | -4x | +|||
| 217 | +
- y_reduced[[stat]] <- formatters::with_label(character(), obj_label(y_reduced[[stat]]))+ #' pages when pagination is used. |
|||
| 90 | +218 |
- }+ #' |
||
| 91 | -3x | +|||
| 219 | +
- y_reduced+ #' @examples |
|||
| 92 | +220 |
- } else {
+ #' lyt3 <- basic_table() %>% |
||
| 93 | -6x | +|||
| 221 | +
- y_complete+ #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
|
|||
| 94 | +222 |
- }+ #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) %>% |
||
| 95 | -9x | +|||
| 223 | +
- y+ #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE) |
|||
| 96 | +224 |
- }+ #' result3 <- build_table(lyt3, df = df, alt_counts_df = adsl) |
||
| 97 | +225 |
-
+ #' result3 |
||
| 98 | +226 |
- #' @describeIn count_patients_events_in_cols Layout-creating function which can take statistics function+ #' |
||
| 99 | +227 |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ #' lyt4 <- basic_table() %>% |
||
| 100 | +228 |
- #'+ #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
|
||
| 101 | +229 |
- #' @param col_split (`flag`)\cr whether the columns should be split.+ #' summarize_patients_exposure_in_cols( |
||
| 102 | +230 |
- #' Set to `FALSE` when the required column split has been done already earlier in the layout pipe.+ #' var = "AVAL", col_split = TRUE, |
||
| 103 | +231 |
- #'+ #' .stats = "n_patients", custom_label = "some custom label" |
||
| 104 | +232 |
- #' @return+ #' ) %>% |
||
| 105 | +233 |
- #' * `summarize_patients_events_in_cols()` returns a layout object suitable for passing to further layouting functions,+ #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE, ex_var = "AVAL") |
||
| 106 | +234 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows+ #' result4 <- build_table(lyt4, df = df, alt_counts_df = adsl) |
||
| 107 | +235 |
- #' containing the statistics from `s_count_patients_and_multiple_events()` to the table layout.+ #' result4 |
||
| 108 | +236 |
- #' @examples+ #' |
||
| 109 | +237 |
- #' # `summarize_patients_events_in_cols()`+ #' lyt5 <- basic_table() %>% |
||
| 110 | +238 |
- #' basic_table() %>%+ #' analyze_patients_exposure_in_cols(var = "SEX", col_split = TRUE, ex_var = "AVAL") |
||
| 111 | +239 |
- #' summarize_patients_events_in_cols(+ #' result5 <- build_table(lyt5, df = df, alt_counts_df = adsl) |
||
| 112 | +240 |
- #' filters_list = list(+ #' result5 |
||
| 113 | +241 |
- #' related = formatters::with_label(c(AEREL = "Y"), "Events (Related)"),+ #' |
||
| 114 | +242 |
- #' fatal = c(AESDTH = "Y"),+ #' # Adding total levels and custom label |
||
| 115 | +243 |
- #' fatal_related = c(AEREL = "Y", AESDTH = "Y")+ #' lyt <- basic_table( |
||
| 116 | +244 |
- #' ),+ #' show_colcounts = TRUE |
||
| 117 | +245 |
- #' custom_label = "%s Total number of patients and events"+ #' ) %>% |
||
| 118 | +246 |
- #' ) %>%+ #' analyze_patients_exposure_in_cols( |
||
| 119 | +247 |
- #' build_table(df)+ #' var = "ARMCD", |
||
| 120 | +248 |
- #'+ #' col_split = TRUE, |
||
| 121 | +249 |
- #' @export+ #' add_total_level = TRUE, |
||
| 122 | +250 |
- summarize_patients_events_in_cols <- function(lyt, # nolint+ #' custom_label = "TOTAL" |
||
| 123 | +251 |
- id = "USUBJID",+ #' ) %>% |
||
| 124 | +252 |
- filters_list = list(),+ #' append_topleft(c("", "Sex"))
|
||
| 125 | +253 |
- ...,+ #' |
||
| 126 | +254 |
- .stats = c(+ #' tbl <- build_table(lyt, df = df, alt_counts_df = adsl) |
||
| 127 | +255 |
- "unique",+ #' tbl |
||
| 128 | +256 |
- "all",+ #' |
||
| 129 | +257 |
- names(filters_list)+ #' @export |
||
| 130 | +258 |
- ),+ analyze_patients_exposure_in_cols <- function(lyt, # nolint |
||
| 131 | +259 |
- .labels = c(+ var = NULL, |
||
| 132 | +260 |
- unique = "Patients (All)",+ ex_var = "AVAL", |
||
| 133 | +261 |
- all = "Events (All)",+ col_split = TRUE, |
||
| 134 | +262 |
- labels_or_names(filters_list)+ add_total_level = FALSE, |
||
| 135 | +263 |
- ),+ .stats = c("n_patients", "sum_exposure"),
|
||
| 136 | +264 |
- col_split = TRUE) {
+ .labels = c(n_patients = "Patients", sum_exposure = "Person time"), |
||
| 137 | -2x | +|||
| 265 | +
- afun_list <- Map(+ .indent_mods = 0L, |
|||
| 138 | -2x | +|||
| 266 | +
- function(stat) {
+ ...) {
|
|||
| 139 | -7x | +267 | +6x |
- make_afun(+ if (col_split) {
|
| 140 | -7x | +268 | +4x |
- s_count_patients_and_multiple_events,+ lyt <- split_cols_by_multivar( |
| 141 | -7x | +269 | +4x |
- id = id,+ lyt = lyt, |
| 142 | -7x | +270 | +4x |
- filters_list = filters_list,+ vars = rep(ex_var, length(.stats)), |
| 143 | -7x | +271 | +4x |
- .stats = stat,+ varlabels = .labels[.stats], |
| 144 | -7x | +272 | +4x |
- .formats = "xx."+ extra_args = list(.stats = .stats) |
| 145 | +273 |
- )+ ) |
||
| 146 | +274 |
- },+ } |
||
| 147 | -2x | +275 | +6x |
- stat = .stats+ lyt <- lyt %>% analyze_colvars( |
| 148 | -+ | |||
| 276 | +6x |
- )+ afun = a_count_patients_sum_exposure, |
||
| 149 | -2x | +277 | +6x |
- if (col_split) {
+ indent_mod = .indent_mods, |
| 150 | -2x | +278 | +6x |
- lyt <- split_cols_by_multivar(+ extra_args = c( |
| 151 | -2x | +279 | +6x |
- lyt = lyt,+ list( |
| 152 | -2x | +280 | +6x |
- vars = rep(id, length(.stats)),+ var = var, |
| 153 | -2x | +281 | +6x |
- varlabels = .labels[.stats]+ ex_var = ex_var, |
| 154 | -+ | |||
| 282 | +6x |
- )+ add_total_level = add_total_level |
||
| 155 | +283 |
- }+ ), |
||
| 156 | -2x | +|||
| 284 | +
- summarize_row_groups(+ ... |
|||
| 157 | -2x | +|||
| 285 | +
- lyt = lyt,+ ) |
|||
| 158 | -2x | +|||
| 286 | +
- cfun = afun_list,+ ) |
|||
| 159 | -2x | -
- extra_args = list(...)- |
- ||
| 160 | -+ | 287 | +6x |
- )+ lyt |
| 161 | +288 |
}@@ -156311,14 +157174,14 @@ tern coverage - 94.83% |
| 1 |
- #' Count the Number of Patients with a Particular Event+ #' Apply 1/3 or 1/2 Imputation Rule to Data |
||
| 5 |
- #' The primary analysis variable `.var` denotes the unique patient identifier.+ #' @inheritParams argument_convention |
||
| 6 |
- #'+ #' @param x_stats (`named list`)\cr a named list of statistics, typically the results of [s_summary()]. |
||
| 7 |
- #' @inheritParams argument_convention+ #' @param stat (`character`)\cr statistic to return the value/NA level of according to the imputation |
||
| 8 |
- #'+ #' rule applied. |
||
| 9 |
- #' @seealso [count_patients_with_flags]+ #' @param imp_rule (`character`)\cr imputation rule setting. Set to `"1/3"` to implement 1/3 imputation |
||
| 10 |
- #'+ #' rule or `"1/2"` to implement 1/2 imputation rule. |
||
| 11 |
- #' @name count_patients_with_event+ #' @param post (`flag`)\cr whether the data corresponds to a post-dose time-point (defaults to `FALSE`). |
||
| 12 |
- NULL+ #' This parameter is only used when `imp_rule` is set to `"1/3"`. |
||
| 13 |
-
+ #' @param avalcat_var (`character`)\cr name of variable that indicates whether a row in `df` corresponds |
||
| 14 |
- #' @describeIn count_patients_with_event Statistics function which counts the number of patients for which+ #' to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of the above |
||
| 15 |
- #' the defined event has occurred.+ #' (defaults to `"AVALCAT1"`). Variable `avalcat_var` must be present in `df`. |
||
| 17 |
- #' @inheritParams analyze_variables+ #' @return A `list` containing statistic value (`val`) and NA level (`na_str`) that should be displayed |
||
| 18 |
- #' @param .var (`character`)\cr name of the column that contains the unique identifier.+ #' according to the specified imputation rule. |
||
| 19 |
- #' @param filters (`character`)\cr a character vector specifying the column names and flag variables+ #' |
||
| 20 |
- #' to be used for counting the number of unique identifiers satisfying such conditions.+ #' @seealso [analyze_vars_in_cols()] where this function can be implemented by setting the `imp_rule` |
||
| 21 |
- #' Multiple column names and flags are accepted in this format+ #' argument. |
||
| 22 |
- #' `c("column_name1" = "flag1", "column_name2" = "flag2")`.
+ #' |
||
| 23 |
- #' Note that only equality is being accepted as condition.+ #' @examples |
||
| 24 |
- #'+ #' set.seed(1) |
||
| 25 |
- #' @return+ #' df <- data.frame( |
||
| 26 |
- #' * `s_count_patients_with_event()` returns the count and fraction of unique identifiers with the defined event.+ #' AVAL = runif(50, 0, 1), |
||
| 27 |
- #'+ #' AVALCAT1 = sample(c(1, "BLQ"), 50, replace = TRUE) |
||
| 28 |
- #' @examples+ #' ) |
||
| 29 |
- #' library(dplyr)+ #' x_stats <- s_summary(df$AVAL) |
||
| 30 |
- #'+ #' imputation_rule(df, x_stats, "max", "1/3") |
||
| 31 |
- #' # `s_count_patients_with_event()`+ #' imputation_rule(df, x_stats, "geom_mean", "1/3") |
||
| 32 |
- #'+ #' imputation_rule(df, x_stats, "mean", "1/2") |
||
| 33 |
- #' s_count_patients_with_event(+ #' |
||
| 34 |
- #' tern_ex_adae,+ #' @export |
||
| 35 |
- #' .var = "SUBJID",+ imputation_rule <- function(df, x_stats, stat, imp_rule, post = FALSE, avalcat_var = "AVALCAT1") {
|
||
| 36 | -+ | 42x |
- #' filters = c("TRTEMFL" = "Y")
+ checkmate::assert_choice(avalcat_var, names(df)) |
| 37 | -+ | 42x |
- #' )+ checkmate::assert_choice(imp_rule, c("1/3", "1/2"))
|
| 38 | -+ | 42x |
- #' s_count_patients_with_event(+ n_blq <- sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", df[[avalcat_var]]))
|
| 39 | -+ | 42x |
- #' tern_ex_adae,+ ltr_blq_ratio <- n_blq / max(1, nrow(df)) |
| 40 |
- #' .var = "SUBJID",+ |
||
| 41 |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL")
+ # defaults |
||
| 42 | -+ | 42x |
- #' )+ val <- x_stats[[stat]] |
| 43 | -+ | 42x |
- #' s_count_patients_with_event(+ na_str <- "NE" |
| 44 |
- #' tern_ex_adae,+ |
||
| 45 | -+ | 42x |
- #' .var = "SUBJID",+ if (imp_rule == "1/3") {
|
| 46 | -+ | 1x |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
+ if (!post && stat == "geom_mean") val <- NA # 1/3_pre_LT, 1/3_pre_GT |
| 47 | -+ | 41x |
- #' denom = "N_col",+ if (ltr_blq_ratio > 1 / 3) {
|
| 48 | -+ | 29x |
- #' .N_col = 456+ if (stat != "geom_mean") na_str <- "ND" # 1/3_pre_GT, 1/3_post_GT |
| 49 | -+ | 4x |
- #' )+ if (!post && !stat %in% c("median", "max")) val <- NA # 1/3_pre_GT
|
| 50 | -+ | 18x |
- #'+ if (post && !stat %in% c("median", "max", "geom_mean")) val <- NA # 1/3_post_GT
|
| 51 |
- #' @export+ } |
||
| 52 | -+ | 1x |
- s_count_patients_with_event <- function(df,+ } else if (imp_rule == "1/2") {
|
| 53 | -+ | 1x |
- .var,+ if (ltr_blq_ratio > 1 / 2 && !stat == "max") {
|
| 54 | -+ | ! |
- filters,+ val <- NA # 1/2_GT |
| 55 | -+ | ! |
- .N_col, # nolint+ na_str <- "ND" # 1/2_GT |
| 56 |
- .N_row, # nolint+ } |
||
| 57 |
- denom = c("n", "N_row", "N_col")) {
+ } |
||
| 58 | -30x | +
- col_names <- names(filters)+ |
|
| 59 | -30x | +42x |
- filter_values <- filters+ list(val = val, na_str = na_str) |
| 60 | - - | -||
| 61 | -30x | -
- checkmate::assert_subset(col_names, colnames(df))+ } |
| 62 | +1 | - - | -||
| 63 | -30x | -
- temp <- Map(- |
- ||
| 64 | -30x | -
- function(x, y) which(df[[x]] == y),- |
- ||
| 65 | -30x | -
- col_names,- |
- ||
| 66 | -30x | -
- filter_values+ #' Pairwise `CoxPH` model |
||
| 67 | +2 |
- )- |
- ||
| 68 | -30x | -
- position_satisfy_filters <- Reduce(intersect, temp)- |
- ||
| 69 | -30x | -
- id_satisfy_filters <- as.character(unique(df[position_satisfy_filters, ][[.var]]))- |
- ||
| 70 | -30x | -
- result <- s_count_values(- |
- ||
| 71 | -30x | -
- as.character(unique(df[[.var]])),+ #' |
||
| 72 | -30x | +|||
| 3 | +
- id_satisfy_filters,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 73 | -30x | +|||
| 4 | +
- denom = denom,+ #' |
|||
| 74 | -30x | +|||
| 5 | +
- .N_col = .N_col,+ #' Summarize p-value, HR and CIs from stratified or unstratified `CoxPH` model. |
|||
| 75 | -30x | +|||
| 6 | +
- .N_row = .N_row+ #' |
|||
| 76 | +7 |
- )+ #' @inheritParams argument_convention |
||
| 77 | -30x | +|||
| 8 | +
- result+ #' @inheritParams s_surv_time |
|||
| 78 | +9 |
- }+ #' @param strat (`character` or `NULL`)\cr variable names indicating stratification factors. |
||
| 79 | +10 |
-
+ #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function |
||
| 80 | +11 |
- #' @describeIn count_patients_with_event Formatted analysis function which is used as `afun`+ #' [control_coxph()]. Some possible parameter options are: |
||
| 81 | +12 |
- #' in `count_patients_with_event()`.+ #' * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1. Default method is `"log-rank"` which |
||
| 82 | +13 |
- #'+ #' comes from [survival::survdiff()], can also be set to `"wald"` or `"likelihood"` (from [survival::coxph()]). |
||
| 83 | +14 |
- #' @return+ #' * `ties` (`string`)\cr specifying the method for tie handling. Default is `"efron"`, |
||
| 84 | +15 |
- #' * `a_count_patients_with_event()` returns the corresponding list with formatted [rtables::CellValue()].+ #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()] |
||
| 85 | +16 |
- #'+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR. |
||
| 86 | +17 |
- #' @examples+ #' |
||
| 87 | +18 |
- #' # `a_count_patients_with_event()`+ #' @name survival_coxph_pairwise |
||
| 88 | +19 |
- #'+ NULL |
||
| 89 | +20 |
- #' a_count_patients_with_event(+ |
||
| 90 | +21 |
- #' tern_ex_adae,+ #' @describeIn survival_coxph_pairwise Statistics function which analyzes HR, CIs of HR and p-value of a `coxph` model. |
||
| 91 | +22 |
- #' .var = "SUBJID",+ #' |
||
| 92 | +23 |
- #' filters = c("TRTEMFL" = "Y"),
+ #' @return |
||
| 93 | +24 |
- #' .N_col = 100,+ #' * `s_coxph_pairwise()` returns the statistics: |
||
| 94 | +25 |
- #' .N_row = 100+ #' * `pvalue`: p-value to test HR = 1. |
||
| 95 | +26 |
- #' )+ #' * `hr`: Hazard ratio. |
||
| 96 | +27 |
- #'+ #' * `hr_ci`: Confidence interval for hazard ratio. |
||
| 97 | +28 |
- #' @export+ #' * `n_tot`: Total number of observations. |
||
| 98 | +29 |
- a_count_patients_with_event <- make_afun(+ #' * `n_tot_events`: Total number of events. |
||
| 99 | +30 |
- s_count_patients_with_event,+ #' |
||
| 100 | +31 |
- .formats = c(count_fraction = format_count_fraction_fixed_dp)+ #' @examples |
||
| 101 | +32 |
- )+ #' library(dplyr) |
||
| 102 | +33 |
-
+ #' |
||
| 103 | +34 |
- #' @describeIn count_patients_with_event Layout-creating function which can take statistics function+ #' adtte_f <- tern_ex_adtte %>% |
||
| 104 | +35 |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' filter(PARAMCD == "OS") %>% |
||
| 105 | +36 |
- #'+ #' mutate(is_event = CNSR == 0) |
||
| 106 | +37 |
- #' @return+ #' df <- adtte_f %>% |
||
| 107 | +38 |
- #' * `count_patients_with_event()` returns a layout object suitable for passing to further layouting functions,+ #' filter(ARMCD == "ARM A") |
||
| 108 | +39 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' df_ref_group <- adtte_f %>% |
||
| 109 | +40 |
- #' the statistics from `s_count_patients_with_event()` to the table layout.+ #' filter(ARMCD == "ARM B") |
||
| 110 | +41 |
#' |
||
| 111 | +42 |
- #' @examples+ #' @keywords internal |
||
| 112 | +43 |
- #' # `count_patients_with_event()`+ s_coxph_pairwise <- function(df, |
||
| 113 | +44 |
- #'+ .ref_group, |
||
| 114 | +45 |
- #' lyt <- basic_table() %>%+ .in_ref_col, |
||
| 115 | +46 |
- #' split_cols_by("ARM") %>%
+ .var, |
||
| 116 | +47 |
- #' add_colcounts() %>%+ is_event, |
||
| 117 | +48 |
- #' count_values(+ strat = NULL, |
||
| 118 | +49 |
- #' "STUDYID",+ control = control_coxph()) {
|
||
| 119 | -+ | |||
| 50 | +65x |
- #' values = "AB12345",+ checkmate::assert_string(.var) |
||
| 120 | -+ | |||
| 51 | +65x |
- #' .stats = "count",+ checkmate::assert_numeric(df[[.var]]) |
||
| 121 | -+ | |||
| 52 | +65x |
- #' .labels = c(count = "Total AEs")+ checkmate::assert_logical(df[[is_event]]) |
||
| 122 | -+ | |||
| 53 | +65x |
- #' ) %>%+ assert_df_with_variables(df, list(tte = .var, is_event = is_event)) |
||
| 123 | -+ | |||
| 54 | +65x |
- #' count_patients_with_event(+ pval_method <- control$pval_method |
||
| 124 | -+ | |||
| 55 | +65x |
- #' "SUBJID",+ ties <- control$ties |
||
| 125 | -+ | |||
| 56 | +65x |
- #' filters = c("TRTEMFL" = "Y"),
+ conf_level <- control$conf_level |
||
| 126 | +57 |
- #' .labels = c(count_fraction = "Total number of patients with at least one adverse event"),+ |
||
| 127 | -+ | |||
| 58 | +65x |
- #' table_names = "tbl_all"+ if (.in_ref_col) {
|
||
| 128 | -+ | |||
| 59 | +! |
- #' ) %>%+ return( |
||
| 129 | -+ | |||
| 60 | +! |
- #' count_patients_with_event(+ list( |
||
| 130 | -+ | |||
| 61 | +! |
- #' "SUBJID",+ pvalue = formatters::with_label("", paste0("p-value (", pval_method, ")")),
|
||
| 131 | -+ | |||
| 62 | +! |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
+ hr = formatters::with_label("", "Hazard Ratio"),
|
||
| 132 | -+ | |||
| 63 | +! |
- #' .labels = c(count_fraction = "Total number of patients with fatal AEs"),+ hr_ci = formatters::with_label("", f_conf_level(conf_level)),
|
||
| 133 | -+ | |||
| 64 | +! |
- #' table_names = "tbl_fatal"+ n_tot = formatters::with_label("", "Total n"),
|
||
| 134 | -+ | |||
| 65 | +! |
- #' ) %>%+ n_tot_events = formatters::with_label("", "Total events")
|
||
| 135 | +66 |
- #' count_patients_with_event(+ ) |
||
| 136 | +67 |
- #' "SUBJID",+ ) |
||
| 137 | +68 |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL", "AEREL" = "Y"),
+ } |
||
| 138 | -+ | |||
| 69 | +65x |
- #' .labels = c(count_fraction = "Total number of patients with related fatal AEs"),+ data <- rbind(.ref_group, df) |
||
| 139 | -+ | |||
| 70 | +65x |
- #' .indent_mods = c(count_fraction = 2L),+ group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
|
||
| 140 | +71 |
- #' table_names = "tbl_rel_fatal"+ |
||
| 141 | -+ | |||
| 72 | +65x | +
+ df_cox <- data.frame(+ |
+ ||
| 73 | +65x |
- #' )+ tte = data[[.var]], |
||
| 142 | -+ | |||
| 74 | +65x |
- #' build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl)+ is_event = data[[is_event]], |
||
| 143 | -+ | |||
| 75 | +65x |
- #'+ arm = group |
||
| 144 | +76 |
- #' @export+ ) |
||
| 145 | -+ | |||
| 77 | +65x |
- count_patients_with_event <- function(lyt,+ if (is.null(strat)) {
|
||
| 146 | -+ | |||
| 78 | +58x |
- vars,+ formula_cox <- survival::Surv(tte, is_event) ~ arm |
||
| 147 | +79 |
- riskdiff = FALSE,+ } else {
|
||
| 148 | -+ | |||
| 80 | +7x |
- nested = TRUE,+ formula_cox <- stats::as.formula( |
||
| 149 | -+ | |||
| 81 | +7x |
- ...,+ paste0( |
||
| 150 | -+ | |||
| 82 | +7x |
- table_names = vars,+ "survival::Surv(tte, is_event) ~ arm + strata(",
|
||
| 151 | -+ | |||
| 83 | +7x |
- .stats = "count_fraction",+ paste(strat, collapse = ","), |
||
| 152 | +84 |
- .formats = NULL,+ ")" |
||
| 153 | +85 |
- .labels = NULL,+ ) |
||
| 154 | +86 |
- .indent_mods = NULL) {
+ ) |
||
| 155 | -6x | +87 | +7x |
- checkmate::assert_flag(riskdiff)+ df_cox <- cbind(df_cox, data[strat]) |
| 156 | +88 |
-
+ } |
||
| 157 | -6x | +89 | +65x |
- afun <- make_afun(+ cox_fit <- survival::coxph( |
| 158 | -6x | +90 | +65x |
- a_count_patients_with_event,+ formula = formula_cox, |
| 159 | -6x | +91 | +65x |
- .stats = .stats,+ data = df_cox, |
| 160 | -6x | +92 | +65x |
- .formats = .formats,+ ties = ties |
| 161 | -6x | +|||
| 93 | +
- .labels = .labels,+ ) |
|||
| 162 | -6x | -
- .indent_mods = .indent_mods- |
- ||
| 163 | -+ | 94 | +65x |
- )+ sum_cox <- summary(cox_fit, conf.int = conf_level, extend = TRUE) |
| 164 | -+ | |||
| 95 | +65x |
-
+ orginal_survdiff <- survival::survdiff( |
||
| 165 | -6x | +96 | +65x |
- extra_args <- if (isFALSE(riskdiff)) {
+ formula_cox, |
| 166 | -5x | +97 | +65x |
- list(...)+ data = df_cox |
| 167 | +98 |
- } else {
+ ) |
||
| 168 | -1x | +99 | +65x |
- list(+ log_rank_pvalue <- 1 - pchisq(orginal_survdiff$chisq, length(orginal_survdiff$n) - 1) |
| 169 | -1x | +|||
| 100 | +
- afun = list("s_count_patients_with_event" = afun),
+
|
|||
| 170 | -1x | +101 | +65x |
- .stats = .stats,+ pval <- switch(pval_method, |
| 171 | -1x | +102 | +65x |
- .indent_mods = .indent_mods,+ "wald" = sum_cox$waldtest["pvalue"], |
| 172 | -1x | -
- s_args = list(...)- |
- ||
| 173 | -+ | 103 | +65x |
- )+ "log-rank" = log_rank_pvalue, # pvalue from original log-rank test survival::survdiff() |
| 174 | -+ | |||
| 104 | +65x |
- }+ "likelihood" = sum_cox$logtest["pvalue"] |
||
| 175 | +105 | - - | -||
| 176 | -6x | -
- analyze(+ ) |
||
| 177 | -6x | +106 | +65x |
- lyt,+ list( |
| 178 | -6x | +107 | +65x |
- vars,+ pvalue = formatters::with_label(unname(pval), paste0("p-value (", pval_method, ")")),
|
| 179 | -6x | +108 | +65x |
- afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ hr = formatters::with_label(sum_cox$conf.int[1, 1], "Hazard Ratio"), |
| 180 | -6x | +109 | +65x |
- nested = nested,+ hr_ci = formatters::with_label(unname(sum_cox$conf.int[1, 3:4]), f_conf_level(conf_level)), |
| 181 | -6x | +110 | +65x |
- extra_args = extra_args,+ n_tot = formatters::with_label(sum_cox$n, "Total n"), |
| 182 | -6x | +111 | +65x |
- show_labels = ifelse(length(vars) > 1, "visible", "hidden"),+ n_tot_events = formatters::with_label(sum_cox$nevent, "Total events") |
| 183 | -6x | +|||
| 112 | +
- table_names = table_names+ ) |
|||
| 184 | +113 |
- )+ } |
||
| 185 | +114 |
- }+ |
| 1 | +115 |
- #' Summarize the Change from Baseline or Absolute Baseline Values+ #' @describeIn survival_coxph_pairwise Formatted analysis function which is used as `afun` in `coxph_pairwise()`. |
|
| 2 | +116 |
#' |
|
| 3 | +117 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return |
|
| 4 | +118 |
- #'+ #' * `a_coxph_pairwise()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 5 | +119 |
- #' The primary analysis variable `.var` indicates the numerical change from baseline results,+ #' |
|
| 6 | +120 |
- #' and additional required secondary analysis variables are `value` and `baseline_flag`.+ #' |
|
| 7 | +121 |
- #' Depending on the baseline flag, either the absolute baseline values (at baseline)+ #' @keywords internal |
|
| 8 | +122 |
- #' or the change from baseline values (post-baseline) are then summarized.+ a_coxph_pairwise <- make_afun( |
|
| 9 | +123 |
- #'+ s_coxph_pairwise, |
|
| 10 | +124 |
- #' @inheritParams argument_convention+ .indent_mods = c(pvalue = 0L, hr = 0L, hr_ci = 1L, n_tot = 0L, n_tot_events = 0L), |
|
| 11 | +125 |
- #'+ .formats = c( |
|
| 12 | +126 |
- #' @name summarize_change+ pvalue = "x.xxxx | (<0.0001)", |
|
| 13 | +127 |
- NULL+ hr = "xx.xx", |
|
| 14 | +128 |
-
+ hr_ci = "(xx.xx, xx.xx)", |
|
| 15 | +129 |
- #' @describeIn summarize_change Statistics function that summarizes baseline or post-baseline visits.+ n_tot = "xx.xx", |
|
| 16 | +130 |
- #'+ n_tot_events = "xx.xx" |
|
| 17 | +131 |
- #' @return+ ) |
|
| 18 | +132 |
- #' * `s_change_from_baseline()` returns the same values returned by [s_summary.numeric()].+ ) |
|
| 19 | +133 |
- #'+ |
|
| 20 | +134 |
- #' @note The data in `df` must be either all be from baseline or post-baseline visits. Otherwise+ #' @describeIn survival_coxph_pairwise Layout-creating function which can take statistics function arguments |
|
| 21 | +135 |
- #' an error will be thrown.+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
| 22 | +136 |
#' |
|
| 23 | +137 |
- #' @examples+ #' @return |
|
| 24 | +138 |
- #' df <- data.frame(+ #' * `coxph_pairwise()` returns a layout object suitable for passing to further layouting functions, |
|
| 25 | +139 |
- #' chg = c(1, 2, 3),+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
| 26 | +140 |
- #' is_bl = c(TRUE, TRUE, TRUE),+ #' the statistics from `s_coxph_pairwise()` to the table layout. |
|
| 27 | +141 |
- #' val = c(4, 5, 6)+ #' |
|
| 28 | +142 |
- #' )+ #' @examples |
|
| 29 | +143 |
- #'+ #' basic_table() %>% |
|
| 30 | +144 |
- #' @keywords internal+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
|
| 31 | +145 |
- s_change_from_baseline <- function(df,+ #' add_colcounts() %>% |
|
| 32 | +146 |
- .var,+ #' coxph_pairwise( |
|
| 33 | +147 |
- variables,+ #' vars = "AVAL", |
|
| 34 | +148 |
- na.rm = TRUE, # nolint+ #' is_event = "is_event", |
|
| 35 | +149 |
- ...) {
+ #' var_labels = "Unstratified Analysis" |
|
| 36 | -4x | +||
| 150 | +
- checkmate::assert_numeric(df[[variables$value]])+ #' ) %>% |
||
| 37 | -4x | +||
| 151 | +
- checkmate::assert_numeric(df[[.var]])+ #' build_table(df = adtte_f) |
||
| 38 | -4x | +||
| 152 | +
- checkmate::assert_logical(df[[variables$baseline_flag]])+ #' |
||
| 39 | -4x | +||
| 153 | +
- checkmate::assert_vector(unique(df[[variables$baseline_flag]]), max.len = 1)+ #' basic_table() %>% |
||
| 40 | -4x | +||
| 154 | +
- assert_df_with_variables(df, c(variables, list(chg = .var)))+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
||
| 41 | +155 |
-
+ #' add_colcounts() %>% |
|
| 42 | -4x | +||
| 156 | +
- combined <- ifelse(+ #' coxph_pairwise( |
||
| 43 | -4x | +||
| 157 | +
- df[[variables$baseline_flag]],+ #' vars = "AVAL", |
||
| 44 | -4x | +||
| 158 | +
- df[[variables$value]],+ #' is_event = "is_event", |
||
| 45 | -4x | +||
| 159 | +
- df[[.var]]+ #' var_labels = "Stratified Analysis", |
||
| 46 | +160 |
- )+ #' strat = "SEX", |
|
| 47 | -4x | +||
| 161 | +
- if (is.logical(combined) && identical(length(combined), 0L)) {
+ #' control = control_coxph(pval_method = "wald") |
||
| 48 | -1x | +||
| 162 | +
- combined <- numeric(0)+ #' ) %>% |
||
| 49 | +163 |
- }+ #' build_table(df = adtte_f) |
|
| 50 | -4x | +||
| 164 | +
- s_summary(combined, na.rm = na.rm, ...)+ #' |
||
| 51 | +165 |
- }+ #' @export |
|
| 52 | +166 |
-
+ coxph_pairwise <- function(lyt, |
|
| 53 | +167 |
- #' @describeIn summarize_change Formatted analysis function which is used as `afun` in `summarize_change()`.+ vars, |
|
| 54 | +168 |
- #'+ na_str = NA_character_, |
|
| 55 | +169 |
- #' @return+ nested = TRUE, |
|
| 56 | +170 |
- #' * `a_change_from_baseline()` returns the corresponding list with formatted [rtables::CellValue()].+ ..., |
|
| 57 | +171 |
- #'+ var_labels = "CoxPH", |
|
| 58 | +172 |
- #'+ show_labels = "visible", |
|
| 59 | +173 |
- #' @keywords internal+ table_names = vars, |
|
| 60 | +174 |
- a_change_from_baseline <- make_afun(+ .stats = c("pvalue", "hr", "hr_ci"),
|
|
| 61 | +175 |
- s_change_from_baseline,+ .formats = NULL, |
|
| 62 | +176 |
- .formats = c(+ .labels = NULL, |
|
| 63 | +177 |
- n = "xx",+ .indent_mods = NULL) {
|
|
| 64 | -+ | ||
| 178 | +4x |
- mean_sd = "xx.xx (xx.xx)",+ afun <- make_afun( |
|
| 65 | -+ | ||
| 179 | +4x |
- mean_se = "xx.xx (xx.xx)",+ a_coxph_pairwise, |
|
| 66 | -+ | ||
| 180 | +4x |
- median = "xx.xx",+ .stats = .stats, |
|
| 67 | -+ | ||
| 181 | +4x |
- range = "xx.xx - xx.xx",+ .formats = .formats, |
|
| 68 | -+ | ||
| 182 | +4x |
- mean_ci = "(xx.xx, xx.xx)",+ .labels = .labels, |
|
| 69 | -+ | ||
| 183 | +4x |
- median_ci = "(xx.xx, xx.xx)",+ .indent_mods = .indent_mods |
|
| 70 | +184 |
- mean_pval = "xx.xx"+ ) |
|
| 71 | -+ | ||
| 185 | +4x |
- ),+ analyze( |
|
| 72 | -+ | ||
| 186 | +4x |
- .labels = c(+ lyt, |
|
| 73 | -+ | ||
| 187 | +4x |
- mean_sd = "Mean (SD)",+ vars, |
|
| 74 | -+ | ||
| 188 | +4x |
- mean_se = "Mean (SE)",+ var_labels = var_labels, |
|
| 75 | -+ | ||
| 189 | +4x |
- median = "Median",+ show_labels = show_labels, |
|
| 76 | -+ | ||
| 190 | +4x |
- range = "Min - Max"+ table_names = table_names, |
|
| 77 | -+ | ||
| 191 | +4x |
- )+ afun = afun, |
|
| 78 | -+ | ||
| 192 | +4x |
- )+ na_str = na_str,+ |
+ |
| 193 | +4x | +
+ nested = nested,+ |
+ |
| 194 | +4x | +
+ extra_args = list(...) |
|
| 79 | +195 |
-
+ ) |
|
| 80 | +196 |
- #' @describeIn summarize_change Layout-creating function which can take statistics function arguments+ } |
| 81 | +1 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' Counting Patients and Events in Columns |
||
| 82 | +2 |
#' |
||
| 83 | +3 |
- #' @return+ #' @description `r lifecycle::badge("stable")`
|
||
| 84 | +4 |
- #' * `summarize_change()` returns a layout object suitable for passing to further layouting functions,+ #' |
||
| 85 | +5 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' Counting the number of unique patients and the total number of all and specific events |
||
| 86 | +6 |
- #' the statistics from `s_change_from_baseline()` to the table layout.+ #' when a column table layout is required. |
||
| 87 | +7 |
#' |
||
| 88 | +8 |
- #' @note To be used after a split on visits in the layout, such that each data subset only contains+ #' @inheritParams argument_convention |
||
| 89 | +9 |
- #' either baseline or post-baseline data.+ #' |
||
| 90 | +10 |
- #'+ #' @name count_patients_events_in_cols |
||
| 91 | +11 |
- #' @examples+ NULL |
||
| 92 | +12 |
- #' # `summarize_change()`+ |
||
| 93 | +13 |
- #'+ #' @describeIn count_patients_events_in_cols Statistics function which counts numbers of patients and multiple |
||
| 94 | +14 |
- #' ## Fabricated dataset.+ #' events defined by filters. Used as analysis function `afun` in `summarize_patients_events_in_cols()`. |
||
| 95 | +15 |
- #' library(dplyr)+ #' |
||
| 96 | +16 |
- #'+ #' @param filters_list (named `list` of `character`)\cr each element in this list describes one |
||
| 97 | +17 |
- #' dta_test <- data.frame(+ #' type of event describe by filters, in the same format as [s_count_patients_with_event()]. |
||
| 98 | +18 |
- #' USUBJID = rep(1:6, each = 3),+ #' If it has a label, then this will be used for the column title. |
||
| 99 | +19 |
- #' AVISIT = rep(paste0("V", 1:3), 6),
+ #' @param empty_stats (`character`)\cr optional names of the statistics that should be returned empty such |
||
| 100 | +20 |
- #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ #' that corresponding table cells will stay blank. |
||
| 101 | +21 |
- #' AVAL = c(9:1, rep(NA, 9))+ #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will |
||
| 102 | +22 |
- #' ) %>%+ #' be used as label. |
||
| 103 | +23 |
- #' mutate(ABLFLL = AVISIT == "V1") %>%+ #' |
||
| 104 | +24 |
- #' group_by(USUBJID) %>%+ #' @return |
||
| 105 | +25 |
- #' mutate(+ #' * `s_count_patients_and_multiple_events()` returns a list with the statistics: |
||
| 106 | +26 |
- #' BLVAL = AVAL[ABLFLL],+ #' - `unique`: number of unique patients in `df`. |
||
| 107 | +27 |
- #' CHG = AVAL - BLVAL+ #' - `all`: number of rows in `df`. |
||
| 108 | +28 |
- #' ) %>%+ #' - one element with the same name as in `filters_list`: number of rows in `df`, |
||
| 109 | +29 |
- #' ungroup()+ #' i.e. events, fulfilling the filter condition. |
||
| 110 | +30 |
#' |
||
| 111 | +31 |
- #' results <- basic_table() %>%+ #' @examples |
||
| 112 | +32 |
- #' split_cols_by("ARM") %>%
+ #' # `s_count_patients_and_multiple_events()` |
||
| 113 | +33 |
- #' split_rows_by("AVISIT") %>%
+ #' df <- data.frame( |
||
| 114 | +34 |
- #' summarize_change("CHG", variables = list(value = "AVAL", baseline_flag = "ABLFLL")) %>%
+ #' USUBJID = rep(c("id1", "id2", "id3", "id4"), c(2, 3, 1, 1)),
|
||
| 115 | +35 |
- #' build_table(dta_test)+ #' ARM = c("A", "A", "B", "B", "B", "B", "A"),
|
||
| 116 | +36 |
- #' \donttest{
+ #' AESER = rep("Y", 7),
|
||
| 117 | +37 |
- #' Viewer(results)+ #' AESDTH = c("Y", "Y", "N", "Y", "Y", "N", "N"),
|
||
| 118 | +38 |
- #' }+ #' AEREL = c("Y", "Y", "N", "Y", "Y", "N", "Y"),
|
||
| 119 | +39 |
- #'+ #' AEDECOD = c("A", "A", "A", "B", "B", "C", "D"),
|
||
| 120 | +40 |
- #' @export+ #' AEBODSYS = rep(c("SOC1", "SOC2", "SOC3"), c(3, 3, 1))
|
||
| 121 | +41 |
- summarize_change <- function(lyt,+ #' ) |
||
| 122 | +42 |
- vars,+ #' |
||
| 123 | +43 |
- nested = TRUE,+ #' @keywords internal |
||
| 124 | +44 |
- ...,+ s_count_patients_and_multiple_events <- function(df, # nolint |
||
| 125 | +45 |
- table_names = vars,+ id, |
||
| 126 | +46 |
- .stats = c("n", "mean_sd", "median", "range"),
+ filters_list, |
||
| 127 | +47 |
- .formats = NULL,+ empty_stats = character(), |
||
| 128 | +48 |
- .labels = NULL,+ labelstr = "", |
||
| 129 | +49 |
- .indent_mods = NULL) {
+ custom_label = NULL) {
|
||
| 130 | -1x | +50 | +9x |
- afun <- make_afun(+ checkmate::assert_list(filters_list, names = "named") |
| 131 | -1x | +51 | +9x |
- a_change_from_baseline,+ checkmate::assert_data_frame(df) |
| 132 | -1x | +52 | +9x |
- .stats = .stats,+ checkmate::assert_string(id) |
| 133 | -1x | +53 | +9x |
- .formats = .formats,+ checkmate::assert_disjunct(c("unique", "all"), names(filters_list))
|
| 134 | -1x | +54 | +9x |
- .labels = .labels,+ checkmate::assert_character(empty_stats) |
| 135 | -1x | +55 | +9x |
- .indent_mods = .indent_mods+ checkmate::assert_string(labelstr)+ |
+
| 56 | +9x | +
+ checkmate::assert_string(custom_label, null.ok = TRUE) |
||
| 136 | +57 |
- )+ |
||
| 137 | +58 |
-
+ # Below we want to count each row in `df` once, therefore introducing this helper index column. |
||
| 138 | -1x | +59 | +9x |
- analyze(+ df$.row_index <- as.character(seq_len(nrow(df))) |
| 139 | -1x | +60 | +9x |
- lyt,+ y <- list() |
| 140 | -1x | +61 | +9x |
- vars,+ row_label <- if (labelstr != "") {
+ |
+
| 62 | +! | +
+ labelstr |
||
| 141 | -1x | +63 | +9x |
- afun = afun,+ } else if (!is.null(custom_label)) {
+ |
+
| 64 | +2x | +
+ custom_label+ |
+ ||
| 65 | ++ |
+ } else {
+ |
+ ||
| 66 | +7x | +
+ "counts"+ |
+ ||
| 67 | ++ |
+ } |
||
| 142 | -1x | +68 | +9x |
- nested = nested,+ y$unique <- formatters::with_label( |
| 143 | -1x | +69 | +9x |
- extra_args = list(...),+ s_num_patients_content(df = df, .N_col = 1, .var = id, required = NULL)$unique[1L], |
| 144 | -1x | +70 | +9x |
- table_names = table_names+ row_label |
| 145 | +71 |
) |
||
| 146 | -+ | |||
| 72 | +9x |
- }+ y$all <- formatters::with_label( |
| 1 | -+ | ||
| 73 | +9x |
- #' Control Function for Logistic Regression Model Fitting+ nrow(df), |
|
| 2 | -+ | ||
| 74 | +9x |
- #'+ row_label |
|
| 3 | +75 |
- #' @description `r lifecycle::badge("stable")`
+ ) |
|
| 4 | -+ | ||
| 76 | +9x |
- #'+ events <- Map( |
|
| 5 | -+ | ||
| 77 | +9x |
- #' This is an auxiliary function for controlling arguments for logistic regression models.+ function(filters) {
|
|
| 6 | -+ | ||
| 78 | +25x |
- #' `conf_level` refers to the confidence level used for the Odds Ratio CIs.+ formatters::with_label( |
|
| 7 | -+ | ||
| 79 | +25x |
- #'+ s_count_patients_with_event(df = df, .var = ".row_index", filters = filters, .N_col = 1, .N_row = 1)$count, |
|
| 8 | -+ | ||
| 80 | +25x |
- #' @inheritParams argument_convention+ row_label |
|
| 9 | +81 |
- #' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`.+ ) |
|
| 10 | +82 |
- #' This will be used when fitting the logistic regression model on the left hand side of the formula.+ }, |
|
| 11 | -+ | ||
| 83 | +9x |
- #' Note that the evaluated expression should result in either a logical vector or a factor with 2+ filters = filters_list |
|
| 12 | +84 |
- #' levels. By default this is just `"response"` such that the original response variable is used+ ) |
|
| 13 | -+ | ||
| 85 | +9x |
- #' and not modified further.+ y_complete <- c(y, events) |
|
| 14 | -+ | ||
| 86 | +9x |
- #'+ y <- if (length(empty_stats) > 0) {
|
|
| 15 | -+ | ||
| 87 | +3x |
- #' @return A list of components with the same names as the arguments.+ y_reduced <- y_complete |
|
| 16 | -+ | ||
| 88 | +3x |
- #'+ for (stat in intersect(names(y_complete), empty_stats)) {
|
|
| 17 | -+ | ||
| 89 | +4x |
- #' @examples+ y_reduced[[stat]] <- formatters::with_label(character(), obj_label(y_reduced[[stat]])) |
|
| 18 | +90 |
- #' # Standard options.+ } |
|
| 19 | -+ | ||
| 91 | +3x |
- #' control_logistic()+ y_reduced |
|
| 20 | +92 |
- #'+ } else {
|
|
| 21 | -+ | ||
| 93 | +6x |
- #' # Modify confidence level.+ y_complete |
|
| 22 | +94 |
- #' control_logistic(conf_level = 0.9)+ } |
|
| 23 | -+ | ||
| 95 | +9x |
- #'+ y |
|
| 24 | +96 |
- #' # Use a different response definition.+ } |
|
| 25 | +97 |
- #' control_logistic(response_definition = "I(response %in% c('CR', 'PR'))")
+
|
|
| 26 | +98 |
- #'+ #' @describeIn count_patients_events_in_cols Layout-creating function which can take statistics function |
|
| 27 | +99 |
- #' @export+ #' arguments and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()]. |
|
| 28 | +100 |
- control_logistic <- function(response_definition = "response",+ #' |
|
| 29 | +101 |
- conf_level = 0.95) {
- |
- |
| 30 | -28x | -
- checkmate::assert_true(grepl("response", response_definition))
- |
- |
| 31 | -27x | -
- checkmate::assert_string(response_definition)- |
- |
| 32 | -27x | -
- assert_proportion_value(conf_level)- |
- |
| 33 | -26x | -
- list(- |
- |
| 34 | -26x | -
- response_definition = response_definition,+ #' @param col_split (`flag`)\cr whether the columns should be split. |
|
| 35 | -26x | +||
| 102 | +
- conf_level = conf_level+ #' Set to `FALSE` when the required column split has been done already earlier in the layout pipe. |
||
| 36 | +103 |
- )+ #' |
|
| 37 | +104 |
- }+ #' @return |
| 1 | +105 |
- #' Apply 1/3 or 1/2 Imputation Rule to Data+ #' * `summarize_patients_events_in_cols()` returns a layout object suitable for passing to further layouting functions, |
||
| 2 | +106 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows |
||
| 3 | +107 |
- #' @description `r lifecycle::badge("stable")`
+ #' containing the statistics from `s_count_patients_and_multiple_events()` to the table layout. |
||
| 4 | +108 |
- #'+ #' @examples |
||
| 5 | +109 |
- #' @inheritParams argument_convention+ #' # `summarize_patients_events_in_cols()` |
||
| 6 | +110 |
- #' @param x_stats (`named list`)\cr a named list of statistics, typically the results of [s_summary()].+ #' basic_table() %>% |
||
| 7 | +111 |
- #' @param stat (`character`)\cr statistic to return the value/NA level of according to the imputation+ #' summarize_patients_events_in_cols( |
||
| 8 | +112 |
- #' rule applied.+ #' filters_list = list( |
||
| 9 | +113 |
- #' @param imp_rule (`character`)\cr imputation rule setting. Set to `"1/3"` to implement 1/3 imputation+ #' related = formatters::with_label(c(AEREL = "Y"), "Events (Related)"), |
||
| 10 | +114 |
- #' rule or `"1/2"` to implement 1/2 imputation rule.+ #' fatal = c(AESDTH = "Y"), |
||
| 11 | +115 |
- #' @param post (`flag`)\cr whether the data corresponds to a post-dose time-point (defaults to `FALSE`).+ #' fatal_related = c(AEREL = "Y", AESDTH = "Y") |
||
| 12 | +116 |
- #' This parameter is only used when `imp_rule` is set to `"1/3"`.+ #' ), |
||
| 13 | +117 |
- #' @param avalcat_var (`character`)\cr name of variable that indicates whether a row in `df` corresponds+ #' custom_label = "%s Total number of patients and events" |
||
| 14 | +118 |
- #' to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of the above+ #' ) %>% |
||
| 15 | +119 |
- #' (defaults to `"AVALCAT1"`). Variable `avalcat_var` must be present in `df`.+ #' build_table(df) |
||
| 16 | +120 |
#' |
||
| 17 | +121 |
- #' @return A `list` containing statistic value (`val`) and NA level (`na_level`) that should be displayed+ #' @export |
||
| 18 | +122 |
- #' according to the specified imputation rule.+ summarize_patients_events_in_cols <- function(lyt, # nolint |
||
| 19 | +123 |
- #'+ id = "USUBJID", |
||
| 20 | +124 |
- #' @seealso [analyze_vars_in_cols()] where this function can be implemented by setting the `imp_rule`+ filters_list = list(), |
||
| 21 | +125 |
- #' argument.+ na_str = NA_character_, |
||
| 22 | +126 |
- #'+ ..., |
||
| 23 | +127 |
- #' @examples+ .stats = c( |
||
| 24 | +128 |
- #' set.seed(1)+ "unique", |
||
| 25 | +129 |
- #' df <- data.frame(+ "all", |
||
| 26 | +130 |
- #' AVAL = runif(50, 0, 1),+ names(filters_list) |
||
| 27 | +131 |
- #' AVALCAT1 = sample(c(1, "BLQ"), 50, replace = TRUE)+ ), |
||
| 28 | +132 |
- #' )+ .labels = c( |
||
| 29 | +133 |
- #' x_stats <- s_summary(df$AVAL)+ unique = "Patients (All)", |
||
| 30 | +134 |
- #' imputation_rule(df, x_stats, "max", "1/3")+ all = "Events (All)", |
||
| 31 | +135 |
- #' imputation_rule(df, x_stats, "geom_mean", "1/3")+ labels_or_names(filters_list) |
||
| 32 | +136 |
- #' imputation_rule(df, x_stats, "mean", "1/2")+ ), |
||
| 33 | +137 |
- #'+ col_split = TRUE) {
|
||
| 34 | -+ | |||
| 138 | +2x |
- #' @export+ afun_list <- Map( |
||
| 35 | -+ | |||
| 139 | +2x |
- imputation_rule <- function(df, x_stats, stat, imp_rule, post = FALSE, avalcat_var = "AVALCAT1") {
+ function(stat) {
|
||
| 36 | -42x | +140 | +7x |
- checkmate::assert_choice(avalcat_var, names(df))+ make_afun( |
| 37 | -42x | +141 | +7x |
- checkmate::assert_choice(imp_rule, c("1/3", "1/2"))
+ s_count_patients_and_multiple_events, |
| 38 | -42x | +142 | +7x |
- n_blq <- sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", df[[avalcat_var]]))
+ id = id, |
| 39 | -42x | +143 | +7x |
- ltr_blq_ratio <- n_blq / max(1, nrow(df))+ filters_list = filters_list, |
| 40 | -+ | |||
| 144 | +7x |
-
+ .stats = stat,+ |
+ ||
| 145 | +7x | +
+ .formats = "xx." |
||
| 41 | +146 |
- # defaults+ ) |
||
| 42 | -42x | +|||
| 147 | +
- val <- x_stats[[stat]]+ }, |
|||
| 43 | -42x | +148 | +2x |
- na_level <- "NE"+ stat = .stats |
| 44 | +149 |
-
+ ) |
||
| 45 | -42x | +150 | +2x |
- if (imp_rule == "1/3") {
+ if (col_split) {
|
| 46 | -1x | +151 | +2x |
- if (!post && stat == "geom_mean") val <- NA # 1/3_pre_LT, 1/3_pre_GT+ lyt <- split_cols_by_multivar( |
| 47 | -41x | +152 | +2x |
- if (ltr_blq_ratio > 1 / 3) {
+ lyt = lyt, |
| 48 | -29x | +153 | +2x |
- if (stat != "geom_mean") na_level <- "ND" # 1/3_pre_GT, 1/3_post_GT+ vars = rep(id, length(.stats)), |
| 49 | -4x | +154 | +2x |
- if (!post && !stat %in% c("median", "max")) val <- NA # 1/3_pre_GT
+ varlabels = .labels[.stats] |
| 50 | -18x | +|||
| 155 | +
- if (post && !stat %in% c("median", "max", "geom_mean")) val <- NA # 1/3_post_GT
+ ) |
|||
| 51 | +156 |
- }+ } |
||
| 52 | -1x | +157 | +2x |
- } else if (imp_rule == "1/2") {
+ summarize_row_groups( |
| 53 | -1x | -
- if (ltr_blq_ratio > 1 / 2 && !stat == "max") {
- |
- ||
| 54 | -! | +158 | +2x |
- val <- NA # 1/2_GT+ lyt = lyt, |
| 55 | -! | +|||
| 159 | +2x |
- na_level <- "ND" # 1/2_GT+ cfun = afun_list, |
||
| 56 | -+ | |||
| 160 | +2x |
- }+ na_str = na_str, |
||
| 57 | -+ | |||
| 161 | +2x |
- }+ extra_args = list(...) |
||
| 58 | +162 | - - | -||
| 59 | -42x | -
- list(val = val, na_level = na_level)+ ) |
||
| 60 | +163 |
}@@ -159331,14 +160125,14 @@ tern coverage - 94.83% |
| 1 |
- #' Count the Number of Patients with Particular Flags+ #' Control Function for Subgroup Treatment Effect Pattern (STEP) Calculations |
|||
| 5 |
- #' The primary analysis variable `.var` denotes the unique patient identifier.+ #' This is an auxiliary function for controlling arguments for STEP calculations. |
|||
| 7 |
- #' @inheritParams argument_convention+ #' @param biomarker (`numeric` or `NULL`)\cr optional provision of the numeric biomarker variable, which |
|||
| 8 |
- #'+ #' could be used to infer `bandwidth`, see below. |
|||
| 9 |
- #' @seealso [count_patients_with_event]+ #' @param use_percentile (`flag`)\cr if `TRUE`, the running windows are created according to |
|||
| 10 |
- #'+ #' quantiles rather than actual values, i.e. the bandwidth refers to the percentage of data |
|||
| 11 |
- #' @name count_patients_with_flags+ #' covered in each window. Suggest `TRUE` if the biomarker variable is not uniformly |
|||
| 12 |
- NULL+ #' distributed. |
|||
| 13 |
-
+ #' @param bandwidth (`number` or `NULL`)\cr indicating the bandwidth of each window. |
|||
| 14 |
- #' @describeIn count_patients_with_flags Statistics function which counts the number of patients for which+ #' Depending on the argument `use_percentile`, it can be either the length of actual-value |
|||
| 15 |
- #' a particular flag variable is `TRUE`.+ #' windows on the real biomarker scale, or percentage windows. |
|||
| 16 |
- #'+ #' If `use_percentile = TRUE`, it should be a number between 0 and 1. |
|||
| 17 |
- #' @inheritParams analyze_variables+ #' If `NULL`, treat the bandwidth to be infinity, which means only one global model will be fitted. |
|||
| 18 |
- #' @param .var (`character`)\cr name of the column that contains the unique identifier.+ #' By default, `0.25` is used for percentage windows and one quarter of the range of the `biomarker` |
|||
| 19 |
- #' @param flag_variables (`character`)\cr a character vector specifying the names of `logical`+ #' variable for actual-value windows. |
|||
| 20 |
- #' variables from analysis dataset used for counting the number of unique identifiers.+ #' @param degree (`count`)\cr the degree of polynomial function of the biomarker as an interaction term |
|||
| 21 |
- #' @param flag_labels (`character`)\cr vector of labels to use for flag variables.+ #' with the treatment arm fitted at each window. If 0 (default), then the biomarker variable |
|||
| 22 |
- #'+ #' is not included in the model fitted in each biomarker window. |
|||
| 23 |
- #' @note If `flag_labels` is not specified, variables labels will be extracted from `df`. If variables are not+ #' @param num_points (`count`)\cr the number of points at which the hazard ratios are estimated. The |
|||
| 24 |
- #' labeled, variable names will be used instead. Alternatively, a named `vector` can be supplied to+ #' smallest number is 2. |
|||
| 25 |
- #' `flag_variables` such that within each name-value pair the name corresponds to the variable name and the value is+ #' |
|||
| 26 |
- #' the label to use for this variable.+ #' @return A list of components with the same names as the arguments, except `biomarker` which is |
|||
| 27 |
- #'+ #' just used to calculate the `bandwidth` in case that actual biomarker windows are requested. |
|||
| 28 |
- #' @return+ #' |
|||
| 29 |
- #' * `s_count_patients_with_flags()` returns the count and the fraction of unique identifiers with each particular+ #' @examples |
|||
| 30 |
- #' flag as a list of statistics `n`, `count`, `count_fraction`, and `n_blq`, with one element per flag.+ #' # Provide biomarker values and request actual values to be used, |
|||
| 31 |
- #'+ #' # so that bandwidth is chosen from range. |
|||
| 32 |
- #' @examples+ #' control_step(biomarker = 1:10, use_percentile = FALSE) |
|||
| 33 |
- #' library(dplyr)+ #' |
|||
| 34 |
- #'+ #' # Use a global model with quadratic biomarker interaction term. |
|||
| 35 |
- #' # `s_count_patients_with_flags()`+ #' control_step(bandwidth = NULL, degree = 2) |
|||
| 37 |
- #' # Add labelled flag variables to analysis dataset.+ #' # Reduce number of points to be used. |
|||
| 38 |
- #' adae <- tern_ex_adae %>%+ #' control_step(num_points = 10) |
|||
| 39 |
- #' mutate(+ #' |
|||
| 40 |
- #' fl1 = TRUE,+ #' @export |
|||
| 41 |
- #' fl2 = TRTEMFL == "Y",+ control_step <- function(biomarker = NULL, |
|||
| 42 |
- #' fl3 = TRTEMFL == "Y" & AEOUT == "FATAL",+ use_percentile = TRUE, |
|||
| 43 |
- #' fl4 = TRTEMFL == "Y" & AEOUT == "FATAL" & AEREL == "Y"+ bandwidth, |
|||
| 44 |
- #' )+ degree = 0L, |
|||
| 45 |
- #' labels <- c(+ num_points = 39L) {
|
|||
| 46 | -+ | 31x |
- #' "fl1" = "Total AEs",+ checkmate::assert_numeric(biomarker, null.ok = TRUE) |
|
| 47 | -+ | 30x |
- #' "fl2" = "Total number of patients with at least one adverse event",+ checkmate::assert_flag(use_percentile) |
|
| 48 | -+ | 30x |
- #' "fl3" = "Total number of patients with fatal AEs",+ checkmate::assert_int(num_points, lower = 2) |
|
| 49 | -+ | 29x |
- #' "fl4" = "Total number of patients with related fatal AEs"+ checkmate::assert_count(degree) |
|
| 50 |
- #' )+ |
|||
| 51 | -+ | 29x |
- #' formatters::var_labels(adae)[names(labels)] <- labels+ if (missing(bandwidth)) {
|
|
| 52 |
- #'+ # Infer bandwidth |
|||
| 53 | -+ | 21x |
- #' s_count_patients_with_flags(+ bandwidth <- if (use_percentile) {
|
|
| 54 | -+ | 18x |
- #' adae,+ 0.25 |
|
| 55 | -+ | 21x |
- #' "SUBJID",+ } else if (!is.null(biomarker)) {
|
|
| 56 | -+ | 3x |
- #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
+ diff(range(biomarker, na.rm = TRUE)) / 4 |
|
| 57 |
- #' denom = "N_col",+ } else {
|
|||
| 58 | -+ | ! |
- #' .N_col = 1000+ NULL |
|
| 59 |
- #' )+ } |
|||
| 60 |
- #'+ } else {
|
|||
| 61 |
- #' @export+ # Check bandwidth |
|||
| 62 | -+ | 8x |
- s_count_patients_with_flags <- function(df,+ if (!is.null(bandwidth)) {
|
|
| 63 | -+ | 5x |
- .var,+ if (use_percentile) {
|
|
| 64 | -+ | 4x |
- flag_variables,+ assert_proportion_value(bandwidth) |
|
| 65 |
- flag_labels = NULL,+ } else {
|
|||
| 66 | -+ | 1x |
- .N_col, # nolint+ checkmate::assert_scalar(bandwidth) |
|
| 67 | -+ | 1x |
- .N_row, # nolint+ checkmate::assert_true(bandwidth > 0) |
|
| 68 |
- denom = c("n", "N_row", "N_col")) {
- |
- |||
| 69 | -5x | -
- checkmate::assert_character(flag_variables)- |
- ||
| 70 | -5x | -
- if (!is.null(flag_labels)) {
- |
- ||
| 71 | -! | -
- checkmate::assert_character(flag_labels, len = length(flag_variables), any.missing = FALSE)- |
- ||
| 72 | -! | -
- flag_names <- flag_labels- |
- ||
| 73 | -- |
- } else {
- |
- ||
| 74 | -5x | -
- if (is.null(names(flag_variables))) {
- |
- ||
| 75 | -5x | -
- flag_names <- formatters::var_labels(df[flag_variables], fill = TRUE)- |
- ||
| 76 | -- |
- } else {
- |
- ||
| 77 | -! | -
- flag_names <- unname(flag_variables)- |
- ||
| 78 | -! | -
- flag_variables <- names(flag_variables)+ } |
||
| 79 | +69 |
} |
||
| 80 | +70 |
} |
||
| 81 | -- | - - | -||
| 82 | -5x | -
- checkmate::assert_subset(flag_variables, colnames(df))- |
- ||
| 83 | -5x | -
- temp <- sapply(flag_variables, function(x) {
- |
- ||
| 84 | -11x | -
- tmp <- Map(function(y) which(df[[y]]), x)- |
- ||
| 85 | -11x | -
- position_satisfy_flags <- Reduce(intersect, tmp)- |
- ||
| 86 | -11x | -
- id_satisfy_flags <- as.character(unique(df[position_satisfy_flags, ][[.var]]))- |
- ||
| 87 | -11x | -
- s_count_values(- |
- ||
| 88 | -11x | +71 | +28x |
- as.character(unique(df[[.var]])),+ list( |
| 89 | -11x | +72 | +28x |
- id_satisfy_flags,+ use_percentile = use_percentile, |
| 90 | -11x | +73 | +28x |
- denom = denom,+ bandwidth = bandwidth, |
| 91 | -11x | +74 | +28x |
- .N_col = .N_col,+ degree = as.integer(degree), |
| 92 | -11x | +75 | +28x |
- .N_row = .N_row+ num_points = as.integer(num_points) |
| 93 | +76 |
- )+ ) |
||
| 94 | +77 |
- })- |
- ||
| 95 | -5x | -
- colnames(temp) <- flag_names- |
- ||
| 96 | -5x | -
- temp <- data.frame(t(temp))- |
- ||
| 97 | -5x | -
- result <- temp %>% as.list()- |
- ||
| 98 | -5x | -
- if (length(flag_variables) == 1) {
- |
- ||
| 99 | -1x | -
- for (i in 1:3) names(result[[i]]) <- flag_names[1]+ } |
| 100 | +1 |
- }- |
- ||
| 101 | -5x | -
- result+ #' Occurrence Table Pruning |
||
| 102 | +2 |
- }+ #' |
||
| 103 | +3 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 104 | +4 |
- #' @describeIn count_patients_with_flags Formatted analysis function which is used as `afun`+ #' |
||
| 105 | +5 |
- #' in `count_patients_with_flags()`.+ #' Family of constructor and condition functions to flexibly prune occurrence tables. |
||
| 106 | +6 |
- #'+ #' The condition functions always return whether the row result is higher than the threshold. |
||
| 107 | +7 |
- #' @return+ #' Since they are of class [CombinationFunction()] they can be logically combined with other condition |
||
| 108 | +8 |
- #' * `a_count_patients_with_flags()` returns the corresponding list with formatted [rtables::CellValue()].+ #' functions. |
||
| 109 | +9 |
#' |
||
| 110 | +10 |
- #' @examples+ #' @note Since most table specifications are worded positively, we name our constructor and condition |
||
| 111 | +11 |
- #' # We need to ungroup `count_fraction` first so that the `rtables` formatting+ #' functions positively, too. However, note that the result of [keep_rows()] says what |
||
| 112 | +12 |
- #' # function `format_count_fraction()` can be applied correctly.+ #' should be pruned, to conform with the [rtables::prune_table()] interface. |
||
| 113 | +13 |
#' |
||
| 114 | -- |
- #' # `a_count_patients_with_flags()`- |
- ||
| 115 | +14 |
- #'+ #' @examples |
||
| 116 | +15 |
- #' afun <- make_afun(a_count_patients_with_flags,+ #' \donttest{
|
||
| 117 | +16 |
- #' .stats = "count_fraction",+ #' tab <- basic_table() %>% |
||
| 118 | +17 |
- #' .ungroup_stats = "count_fraction"+ #' split_cols_by("ARM") %>%
|
||
| 119 | +18 |
- #' )+ #' split_rows_by("RACE") %>%
|
||
| 120 | +19 |
- #' afun(+ #' split_rows_by("STRATA1") %>%
|
||
| 121 | +20 |
- #' adae,+ #' summarize_row_groups() %>% |
||
| 122 | +21 |
- #' .N_col = 10L,+ #' analyze_vars("COUNTRY", .stats = "count_fraction") %>%
|
||
| 123 | +22 |
- #' .N_row = 10L,+ #' build_table(DM) |
||
| 124 | +23 |
- #' .var = "USUBJID",+ #' } |
||
| 125 | +24 |
- #' flag_variables = c("fl1", "fl2", "fl3", "fl4")
+ #' |
||
| 126 | +25 |
- #' )+ #' @name prune_occurrences |
||
| 127 | +26 |
- #'+ NULL |
||
| 128 | +27 |
- #' @export+ |
||
| 129 | +28 |
- a_count_patients_with_flags <- make_afun(+ #' @describeIn prune_occurrences Constructor for creating pruning functions based on |
||
| 130 | +29 |
- s_count_patients_with_flags,+ #' a row condition function. This removes all analysis rows (`TableRow`) that should be |
||
| 131 | +30 |
- .formats = c("count_fraction" = format_count_fraction_fixed_dp)
+ #' pruned, i.e., don't fulfill the row condition. It removes the sub-tree if there are no |
||
| 132 | +31 |
- )+ #' children left. |
||
| 133 | +32 |
-
+ #' |
||
| 134 | +33 |
- #' @describeIn count_patients_with_flags Layout-creating function which can take statistics function+ #' @param row_condition (`CombinationFunction`)\cr condition function which works on individual |
||
| 135 | +34 |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' analysis rows and flags whether these should be kept in the pruned table. |
||
| 136 | +35 |
#' |
||
| 137 | +36 |
#' @return |
||
| 138 | +37 |
- #' * `count_patients_with_flags()` returns a layout object suitable for passing to further layouting functions,+ #' * `keep_rows()` returns a pruning function that can be used with [rtables::prune_table()] |
||
| 139 | +38 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' to prune an `rtables` table. |
||
| 140 | +39 |
- #' the statistics from `s_count_patients_with_flags()` to the table layout.+ #' |
||
| 141 | +40 |
- #'+ #' @examples |
||
| 142 | +41 |
- #' @examples+ #' \donttest{
|
||
| 143 | +42 |
- #' # `count_patients_with_flags()`+ #' # `keep_rows` |
||
| 144 | +43 |
- #'+ #' is_non_empty <- !CombinationFunction(all_zero_or_na) |
||
| 145 | +44 |
- #' lyt2 <- basic_table() %>%+ #' prune_table(tab, keep_rows(is_non_empty)) |
||
| 146 | +45 |
- #' split_cols_by("ARM") %>%
+ #' } |
||
| 147 | +46 |
- #' add_colcounts() %>%+ #' |
||
| 148 | +47 |
- #' count_patients_with_flags(+ #' @export |
||
| 149 | +48 |
- #' "SUBJID",+ keep_rows <- function(row_condition) {
|
||
| 150 | -+ | |||
| 49 | +6x |
- #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
+ checkmate::assert_function(row_condition) |
||
| 151 | -+ | |||
| 50 | +6x |
- #' denom = "N_col"+ function(table_tree) {
|
||
| 152 | -+ | |||
| 51 | +2256x |
- #' )+ if (inherits(table_tree, "TableRow")) {
|
||
| 153 | -+ | |||
| 52 | +1872x |
- #' build_table(lyt2, adae, alt_counts_df = tern_ex_adsl)+ return(!row_condition(table_tree)) |
||
| 154 | +53 |
- #'+ } |
||
| 155 | -+ | |||
| 54 | +384x |
- #' @export+ children <- tree_children(table_tree) |
||
| 156 | -+ | |||
| 55 | +384x |
- count_patients_with_flags <- function(lyt,+ identical(length(children), 0L) |
||
| 157 | +56 |
- var,+ } |
||
| 158 | +57 |
- var_labels = var,+ } |
||
| 159 | +58 |
- show_labels = "hidden",+ |
||
| 160 | +59 |
- riskdiff = FALSE,+ #' @describeIn prune_occurrences Constructor for creating pruning functions based on |
||
| 161 | +60 |
- nested = TRUE,+ #' a condition for the (first) content row in leaf tables. This removes all leaf tables where |
||
| 162 | +61 |
- ...,+ #' the first content row does not fulfill the condition. It does not check individual rows. |
||
| 163 | +62 |
- table_names = paste0("tbl_flags_", var),
+ #' It then proceeds recursively by removing the sub tree if there are no children left. |
||
| 164 | +63 |
- .stats = "count_fraction",+ #' |
||
| 165 | +64 |
- .formats = NULL,+ #' @param content_row_condition (`CombinationFunction`)\cr condition function which works on individual |
||
| 166 | +65 |
- .indent_mods = NULL) {
+ #' first content rows of leaf tables and flags whether these leaf tables should be kept in the pruned table. |
||
| 167 | -6x | +|||
| 66 | +
- checkmate::assert_flag(riskdiff)+ #' |
|||
| 168 | +67 |
-
+ #' @return |
||
| 169 | -6x | +|||
| 68 | +
- afun <- make_afun(+ #' * `keep_content_rows()` returns a pruning function that checks the condition on the first content |
|||
| 170 | -6x | +|||
| 69 | +
- a_count_patients_with_flags,+ #' row of leaf tables in the table. |
|||
| 171 | -6x | +|||
| 70 | +
- .stats = .stats,+ #' |
|||
| 172 | -6x | +|||
| 71 | +
- .formats = .formats,+ #' @examples |
|||
| 173 | -6x | +|||
| 72 | +
- .indent_mods = .indent_mods,+ #' # `keep_content_rows` |
|||
| 174 | -6x | +|||
| 73 | +
- .ungroup_stats = .stats+ #' \donttest{
|
|||
| 175 | +74 |
- )+ #' more_than_twenty <- has_count_in_cols(atleast = 20L, col_names = names(tab)) |
||
| 176 | +75 |
-
+ #' prune_table(tab, keep_content_rows(more_than_twenty)) |
||
| 177 | -6x | +|||
| 76 | +
- extra_args <- if (isFALSE(riskdiff)) {
+ #' } |
|||
| 178 | -5x | +|||
| 77 | +
- list(...)+ #' |
|||
| 179 | +78 |
- } else {
+ #' @export |
||
| 180 | -1x | +|||
| 79 | +
- list(+ keep_content_rows <- function(content_row_condition) {
|
|||
| 181 | +80 | 1x |
- afun = list("s_count_patients_with_flags" = afun),
+ checkmate::assert_function(content_row_condition) |
|
| 182 | +81 | 1x |
- .stats = .stats,+ function(table_tree) {
|
|
| 183 | -1x | +82 | +166x |
- .indent_mods = .indent_mods,+ if (is_leaf_table(table_tree)) {
|
| 184 | -1x | -
- s_args = list(...)- |
- ||
| 185 | -+ | 83 | +24x |
- )+ content_row <- h_content_first_row(table_tree) |
| 186 | -+ | |||
| 84 | +24x |
- }+ return(!content_row_condition(content_row)) |
||
| 187 | +85 |
-
+ } |
||
| 188 | -6x | +86 | +142x |
- lyt <- analyze(+ if (inherits(table_tree, "DataRow")) {
|
| 189 | -6x | +87 | +120x |
- lyt = lyt,+ return(FALSE) |
| 190 | -6x | +|||
| 88 | +
- vars = var,+ } |
|||
| 191 | -6x | +89 | +22x |
- var_labels = var_labels,+ children <- tree_children(table_tree) |
| 192 | -6x | +90 | +22x |
- show_labels = show_labels,+ identical(length(children), 0L) |
| 193 | -6x | +|||
| 91 | +
- afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ } |
|||
| 194 | -6x | +|||
| 92 | +
- table_names = table_names,+ } |
|||
| 195 | -6x | +|||
| 93 | +
- nested = nested,+ |
|||
| 196 | -6x | +|||
| 94 | +
- extra_args = extra_args+ #' @describeIn prune_occurrences Constructor for creating condition functions on total counts in the specified columns. |
|||
| 197 | +95 |
- )+ #' |
||
| 198 | +96 |
-
+ #' @param atleast (`count` or `proportion`)\cr threshold which should be met in order to keep the row. |
||
| 199 | -6x | +|||
| 97 | +
- lyt+ #' @param ... arguments for row or column access, see [`rtables_access`]: either `col_names` (`character`) including |
|||
| 200 | +98 |
- }+ #' the names of the columns which should be used, or alternatively `col_indices` (`integer`) giving the indices |
| 1 | +99 |
- #' Counting Missed Doses+ #' directly instead. |
||
| 2 | +100 |
#' |
||
| 3 | +101 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return |
||
| 4 | +102 |
- #'+ #' * `has_count_in_cols()` returns a condition function that sums the counts in the specified column. |
||
| 5 | +103 |
- #' These are specific functions to count patients with missed doses. The difference to [count_cumulative()] is+ #' |
||
| 6 | +104 |
- #' mainly the special labels.+ #' @examples |
||
| 7 | +105 |
- #'+ #' \donttest{
|
||
| 8 | +106 |
- #' @inheritParams argument_convention+ #' more_than_one <- has_count_in_cols(atleast = 1L, col_names = names(tab)) |
||
| 9 | +107 |
- #'+ #' prune_table(tab, keep_rows(more_than_one)) |
||
| 10 | +108 |
- #' @seealso Relevant description function [d_count_missed_doses()].+ #' } |
||
| 11 | +109 |
#' |
||
| 12 | +110 |
- #' @name count_missed_doses+ #' @export |
||
| 13 | +111 |
- NULL+ has_count_in_cols <- function(atleast, ...) {
|
||
| 14 | -+ | |||
| 112 | +3x |
-
+ checkmate::assert_count(atleast) |
||
| 15 | -+ | |||
| 113 | +3x |
- #' @describeIn count_missed_doses Statistics function to count non-missing values.+ CombinationFunction(function(table_row) {
|
||
| 16 | -+ | |||
| 114 | +334x |
- #'+ row_counts <- h_row_counts(table_row, ...) |
||
| 17 | -+ | |||
| 115 | +334x |
- #' @return+ total_count <- sum(row_counts)+ |
+ ||
| 116 | +334x | +
+ total_count >= atleast |
||
| 18 | +117 |
- #' * `s_count_nonmissing()` returns the statistic `n` which is the count of non-missing values in `x`.+ }) |
||
| 19 | +118 |
- #'+ } |
||
| 20 | +119 |
- #' @examples+ |
||
| 21 | +120 |
- #' set.seed(1)+ #' @describeIn prune_occurrences Constructor for creating condition functions on any of the counts in |
||
| 22 | +121 |
- #' x <- c(sample(1:10, 10), NA)+ #' the specified columns satisfying a threshold. |
||
| 23 | +122 |
#' |
||
| 24 | +123 |
- #' @keywords internal+ #' @param atleast (`count` or `proportion`)\cr threshold which should be met in order to keep the row. |
||
| 25 | +124 |
- s_count_nonmissing <- function(x) {
+ #' |
||
| 26 | -5x | +|||
| 125 | +
- list(n = n_available(x))+ #' @return |
|||
| 27 | +126 |
- }+ #' * `has_count_in_any_col()` returns a condition function that compares the counts in the |
||
| 28 | +127 |
-
+ #' specified columns with the threshold. |
||
| 29 | +128 |
- #' Description Function that Calculates Labels for [s_count_missed_doses()].+ #' |
||
| 30 | +129 |
- #'+ #' @examples |
||
| 31 | +130 |
- #' @description `r lifecycle::badge("stable")`
+ #' \donttest{
|
||
| 32 | +131 |
- #'+ #' # `has_count_in_any_col` |
||
| 33 | +132 |
- #' @inheritParams s_count_missed_doses+ #' any_more_than_one <- has_count_in_any_col(atleast = 1L, col_names = names(tab)) |
||
| 34 | +133 |
- #'+ #' prune_table(tab, keep_rows(any_more_than_one)) |
||
| 35 | +134 |
- #' @return [d_count_missed_doses()] returns a named `character` vector with the labels.+ #' } |
||
| 36 | +135 |
#' |
||
| 37 | +136 |
- #' @seealso [s_count_missed_doses()]+ #' @export |
||
| 38 | +137 |
- #'+ has_count_in_any_col <- function(atleast, ...) {
|
||
| 39 | -+ | |||
| 138 | +! |
- #' @export+ checkmate::assert_count(atleast) |
||
| 40 | -+ | |||
| 139 | +! |
- d_count_missed_doses <- function(thresholds) {
+ CombinationFunction(function(table_row) {
|
||
| 41 | -4x | +|||
| 140 | +! |
- paste0("At least ", thresholds, " missed dose", ifelse(thresholds > 1, "s", ""))
+ row_counts <- h_row_counts(table_row, ...)+ |
+ ||
| 141 | +! | +
+ any(row_counts >= atleast) |
||
| 42 | +142 |
- }+ }) |
||
| 43 | +143 |
-
+ } |
||
| 44 | +144 |
- #' @describeIn count_missed_doses Statistics function to count patients with missed doses.+ |
||
| 45 | +145 |
- #'+ #' @describeIn prune_occurrences Constructor for creating condition functions on total fraction in |
||
| 46 | +146 |
- #' @param thresholds (vector of `count`)\cr number of missed doses the patients at least had.+ #' the specified columns. |
||
| 47 | +147 |
#' |
||
| 48 | +148 |
#' @return |
||
| 49 | +149 |
- #' * `s_count_missed_doses()` returns the statistics `n` and `count_fraction` with one element for each threshold.+ #' * `has_fraction_in_cols()` returns a condition function that sums the counts in the |
||
| 50 | +150 |
- #'+ #' specified column, and computes the fraction by dividing by the total column counts. |
||
| 51 | +151 |
- #' @keywords internal+ #' |
||
| 52 | +152 |
- s_count_missed_doses <- function(x,+ #' @examples |
||
| 53 | +153 |
- thresholds,+ #' \donttest{
|
||
| 54 | +154 |
- .N_col) { # nolint
- |
- ||
| 55 | -1x | -
- stat <- s_count_cumulative(+ #' # `has_fraction_in_cols` |
||
| 56 | -1x | +|||
| 155 | +
- x = x,+ #' more_than_five_percent <- has_fraction_in_cols(atleast = 0.05, col_names = names(tab)) |
|||
| 57 | -1x | +|||
| 156 | +
- thresholds = thresholds,+ #' prune_table(tab, keep_rows(more_than_five_percent)) |
|||
| 58 | -1x | +|||
| 157 | +
- lower_tail = FALSE,+ #' } |
|||
| 59 | -1x | +|||
| 158 | +
- include_eq = TRUE,+ #' |
|||
| 60 | -1x | +|||
| 159 | +
- .N_col = .N_col+ #' @export |
|||
| 61 | +160 |
- )+ has_fraction_in_cols <- function(atleast, ...) {
|
||
| 62 | +161 | 1x |
- labels <- d_count_missed_doses(thresholds)+ assert_proportion_value(atleast, include_boundaries = TRUE) |
|
| 63 | +162 | 1x |
- for (i in seq_along(stat$count_fraction)) {
+ CombinationFunction(function(table_row) {
|
|
| 64 | -2x | +163 | +303x |
- stat$count_fraction[[i]] <- formatters::with_label(stat$count_fraction[[i]], label = labels[i])+ row_counts <- h_row_counts(table_row, ...) |
| 65 | -+ | |||
| 164 | +303x |
- }+ total_count <- sum(row_counts) |
||
| 66 | -1x | +165 | +303x |
- n_stat <- s_count_nonmissing(x)+ col_counts <- h_col_counts(table_row, ...) |
| 67 | -1x | +166 | +303x |
- c(n_stat, stat)+ total_n <- sum(col_counts) |
| 68 | -+ | |||
| 167 | +303x |
- }+ total_percent <- total_count / total_n |
||
| 69 | -+ | |||
| 168 | +303x |
-
+ total_percent >= atleast |
||
| 70 | +169 |
- #' @describeIn count_missed_doses Formatted analysis function which is used as `afun`+ }) |
||
| 71 | +170 |
- #' in `count_missed_doses()`.+ } |
||
| 72 | +171 |
- #'+ |
||
| 73 | +172 |
- #' @return+ #' @describeIn prune_occurrences Constructor for creating condition functions on any fraction in |
||
| 74 | +173 |
- #' * `a_count_missed_doses()` returns the corresponding list with formatted [rtables::CellValue()].+ #' the specified columns. |
||
| 75 | +174 |
#' |
||
| 76 | +175 |
- #' @keywords internal+ #' @return |
||
| 77 | +176 |
- a_count_missed_doses <- make_afun(+ #' * `has_fraction_in_any_col()` returns a condition function that looks at the fractions |
||
| 78 | +177 |
- s_count_missed_doses,+ #' in the specified columns and checks whether any of them fulfill the threshold. |
||
| 79 | +178 |
- .formats = c(n = "xx", count_fraction = format_count_fraction)+ #' |
||
| 80 | +179 |
- )+ #' @examples |
||
| 81 | +180 |
-
+ #' \donttest{
|
||
| 82 | +181 |
- #' @describeIn count_missed_doses Layout-creating function which can take statistics function arguments+ #' # `has_fraction_in_any_col` |
||
| 83 | +182 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' any_atleast_five_percent <- has_fraction_in_any_col(atleast = 0.05, col_names = names(tab)) |
||
| 84 | +183 |
- #'+ #' prune_table(tab, keep_rows(more_than_five_percent)) |
||
| 85 | +184 |
- #' @inheritParams s_count_cumulative+ #' } |
||
| 86 | +185 |
#' |
||
| 87 | +186 |
- #' @return+ #' @export |
||
| 88 | +187 |
- #' * `count_missed_doses()` returns a layout object suitable for passing to further layouting functions,+ has_fraction_in_any_col <- function(atleast, ...) {
|
||
| 89 | -+ | |||
| 188 | +! |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ assert_proportion_value(atleast, include_boundaries = TRUE) |
||
| 90 | -+ | |||
| 189 | +! |
- #' the statistics from `s_count_missed_doses()` to the table layout.+ CombinationFunction(function(table_row) {
|
||
| 91 | -+ | |||
| 190 | +! |
- #'+ row_fractions <- h_row_fractions(table_row, ...) |
||
| 92 | -+ | |||
| 191 | +! |
- #' @examples+ any(row_fractions >= atleast) |
||
| 93 | +192 |
- #' library(dplyr)+ }) |
||
| 94 | +193 |
- #'+ } |
||
| 95 | +194 |
- #' anl <- tern_ex_adsl %>%+ |
||
| 96 | +195 |
- #' distinct(STUDYID, USUBJID, ARM) %>%+ #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference |
||
| 97 | +196 |
- #' mutate(+ #' between the fractions reported in each specified column. |
||
| 98 | +197 |
- #' PARAMCD = "TNDOSMIS",+ #' |
||
| 99 | +198 |
- #' PARAM = "Total number of missed doses during study",+ #' @return |
||
| 100 | +199 |
- #' AVAL = sample(0:20, size = nrow(tern_ex_adsl), replace = TRUE),+ #' * `has_fractions_difference()` returns a condition function that extracts the fractions of each |
||
| 101 | +200 |
- #' AVALC = ""+ #' specified column, and computes the difference of the minimum and maximum. |
||
| 102 | +201 |
- #' )+ #' |
||
| 103 | +202 |
- #'+ #' @examples |
||
| 104 | +203 |
- #' basic_table() %>%+ #' \donttest{
|
||
| 105 | +204 |
- #' split_cols_by("ARM") %>%
+ #' # `has_fractions_difference` |
||
| 106 | +205 |
- #' add_colcounts() %>%+ #' more_than_five_percent_diff <- has_fractions_difference(atleast = 0.05, col_names = names(tab)) |
||
| 107 | +206 |
- #' count_missed_doses("AVAL", thresholds = c(1, 5, 10, 15), var_labels = "Missed Doses") %>%
+ #' prune_table(tab, keep_rows(more_than_five_percent_diff)) |
||
| 108 | +207 |
- #' build_table(anl, alt_counts_df = tern_ex_adsl)+ #' } |
||
| 109 | +208 |
#' |
||
| 110 | +209 |
#' @export |
||
| 111 | +210 |
- count_missed_doses <- function(lyt,+ has_fractions_difference <- function(atleast, ...) {
|
||
| 112 | -+ | |||
| 211 | +1x |
- vars,+ assert_proportion_value(atleast, include_boundaries = TRUE) |
||
| 113 | -+ | |||
| 212 | +1x |
- var_labels = vars,+ CombinationFunction(function(table_row) {
|
||
| 114 | -+ | |||
| 213 | +243x |
- show_labels = "visible",+ fractions <- h_row_fractions(table_row, ...) |
||
| 115 | -+ | |||
| 214 | +243x |
- nested = TRUE,+ difference <- diff(range(fractions))+ |
+ ||
| 215 | +243x | +
+ difference >= atleast |
||
| 116 | +216 |
- ...,+ }) |
||
| 117 | +217 |
- table_names = vars,+ } |
||
| 118 | +218 |
- .stats = NULL,+ |
||
| 119 | +219 |
- .formats = NULL,+ #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference |
||
| 120 | +220 |
- .labels = NULL,+ #' between the counts reported in each specified column. |
||
| 121 | +221 |
- .indent_mods = NULL) {
+ #' |
||
| 122 | -1x | +|||
| 222 | +
- afun <- make_afun(+ #' @return |
|||
| 123 | -1x | +|||
| 223 | +
- a_count_missed_doses,+ #' * `has_counts_difference()` returns a condition function that extracts the counts of each |
|||
| 124 | -1x | +|||
| 224 | +
- .stats = .stats,+ #' specified column, and computes the difference of the minimum and maximum. |
|||
| 125 | -1x | +|||
| 225 | +
- .formats = .formats,+ #' |
|||
| 126 | -1x | +|||
| 226 | +
- .labels = .labels,+ #' @examples |
|||
| 127 | -1x | +|||
| 227 | +
- .indent_mods = .indent_mods,+ #' \donttest{
|
|||
| 128 | -1x | +|||
| 228 | +
- .ungroup_stats = "count_fraction"+ #' more_than_one_diff <- has_counts_difference(atleast = 1L, col_names = names(tab)) |
|||
| 129 | +229 |
- )+ #' prune_table(tab, keep_rows(more_than_one_diff)) |
||
| 130 | -1x | +|||
| 230 | +
- analyze(+ #' } |
|||
| 131 | -1x | +|||
| 231 | +
- lyt = lyt,+ #' |
|||
| 132 | -1x | +|||
| 232 | +
- vars = vars,+ #' @export |
|||
| 133 | -1x | +|||
| 233 | +
- afun = afun,+ has_counts_difference <- function(atleast, ...) {
|
|||
| 134 | +234 | 1x |
- var_labels = var_labels,+ checkmate::assert_count(atleast) |
|
| 135 | +235 | 1x |
- table_names = table_names,+ CombinationFunction(function(table_row) {
|
|
| 136 | -1x | +236 | +27x |
- show_labels = show_labels,+ counts <- h_row_counts(table_row, ...) |
| 137 | -1x | +237 | +27x |
- nested = nested,+ difference <- diff(range(counts)) |
| 138 | -1x | +238 | +27x |
- extra_args = list(...)+ difference >= atleast |
| 139 | +239 |
- )+ }) |
||
| 140 | +240 |
}@@ -161723,14 +162356,14 @@ tern coverage - 94.83% |
| 1 |
- #' Tabulate Biomarker Effects on Survival by Subgroup+ #' Helper Functions for Tabulating Biomarker Effects on Binary Response by Subgroup |
|||
| 5 |
- #' Tabulate the estimated effects of multiple continuous biomarker variables+ #' Helper functions which are documented here separately to not confuse the user |
|||
| 6 |
- #' across population subgroups.+ #' when reading about the user-facing functions. |
|||
| 8 |
- #' @inheritParams argument_convention+ #' @inheritParams response_biomarkers_subgroups |
|||
| 9 |
- #' @inheritParams fit_coxreg_multivar+ #' @inheritParams extract_rsp_biomarkers |
|||
| 10 |
- #' @inheritParams survival_duration_subgroups+ #' @inheritParams argument_convention |
|||
| 12 |
- #' @details These functions create a layout starting from a data frame which contains+ #' @examples |
|||
| 13 |
- #' the required statistics. The tables are then typically used as input for forest plots.+ #' library(dplyr) |
|||
| 14 |
- #'+ #' library(forcats) |
|||
| 15 |
- #' @examples+ #' |
|||
| 16 |
- #' library(dplyr)+ #' adrs <- tern_ex_adrs |
|||
| 17 |
- #'+ #' adrs_labels <- formatters::var_labels(adrs) |
|||
| 18 |
- #' adtte <- tern_ex_adtte+ #' |
|||
| 19 |
- #'+ #' adrs_f <- adrs %>% |
|||
| 20 |
- #' # Save variable labels before data processing steps.+ #' filter(PARAMCD == "BESRSPI") %>% |
|||
| 21 |
- #' adtte_labels <- formatters::var_labels(adtte)+ #' mutate(rsp = AVALC == "CR") |
|||
| 22 |
- #'+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
|||
| 23 |
- #' adtte_f <- adtte %>%+ #' |
|||
| 24 |
- #' filter(PARAMCD == "OS") %>%+ #' @name h_response_biomarkers_subgroups |
|||
| 25 |
- #' mutate(+ NULL |
|||
| 26 |
- #' AVALU = as.character(AVALU),+ |
|||
| 27 |
- #' is_event = CNSR == 0+ #' @describeIn h_response_biomarkers_subgroups helps with converting the "response" function variable list |
|||
| 28 |
- #' )+ #' to the "logistic regression" variable list. The reason is that currently there is an |
|||
| 29 |
- #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
+ #' inconsistency between the variable names accepted by `extract_rsp_subgroups()` and `fit_logistic()`. |
|||
| 30 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ #' |
|||
| 31 |
- #'+ #' @param biomarker (`string`)\cr the name of the biomarker variable. |
|||
| 32 |
- #' df <- extract_survival_biomarkers(+ #' |
|||
| 33 |
- #' variables = list(+ #' @return |
|||
| 34 |
- #' tte = "AVAL",+ #' * `h_rsp_to_logistic_variables()` returns a named `list` of elements `response`, `arm`, `covariates`, and `strata`. |
|||
| 35 |
- #' is_event = "is_event",+ #' |
|||
| 36 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' @examples |
|||
| 37 |
- #' strata = "STRATA1",+ #' # This is how the variable list is converted internally. |
|||
| 38 |
- #' covariates = "SEX",+ #' h_rsp_to_logistic_variables( |
|||
| 39 |
- #' subgroups = "BMRKR2"+ #' variables = list( |
|||
| 40 |
- #' ),+ #' rsp = "RSP", |
|||
| 41 |
- #' data = adtte_f+ #' covariates = c("A", "B"),
|
|||
| 42 |
- #' )+ #' strat = "D" |
|||
| 43 |
- #' df+ #' ), |
|||
| 44 |
- #'+ #' biomarker = "AGE" |
|||
| 45 |
- #' @name survival_biomarkers_subgroups+ #' ) |
|||
| 46 |
- NULL+ #' |
|||
| 47 |
-
+ #' @export |
|||
| 48 |
- #' Prepares Survival Data Estimates for Multiple Biomarkers in a Single Data Frame+ h_rsp_to_logistic_variables <- function(variables, biomarker) {
|
|||
| 49 | -+ | 37x |
- #'+ checkmate::assert_list(variables) |
|
| 50 | -+ | 37x |
- #' @description `r lifecycle::badge("stable")`
+ checkmate::assert_string(variables$rsp) |
|
| 51 | -+ | 37x |
- #'+ checkmate::assert_string(biomarker) |
|
| 52 | -+ | 37x |
- #' Prepares estimates for number of events, patients and median survival times, as well as hazard ratio estimates,+ list( |
|
| 53 | -+ | 37x |
- #' confidence intervals and p-values, for multiple biomarkers across population subgroups in a single data frame.+ response = variables$rsp, |
|
| 54 | -+ | 37x |
- #' `variables` corresponds to the names of variables found in `data`, passed as a named `list` and requires elements+ arm = biomarker, |
|
| 55 | -+ | 37x |
- #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables), and optionally `subgroups` and `strat`.+ covariates = variables$covariates, |
|
| 56 | -+ | 37x |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ strata = variables$strat |
|
| 57 |
- #'+ ) |
|||
| 58 |
- #' @inheritParams argument_convention+ } |
|||
| 59 |
- #' @inheritParams fit_coxreg_multivar+ |
|||
| 60 |
- #' @inheritParams survival_duration_subgroups+ #' @describeIn h_response_biomarkers_subgroups prepares estimates for number of responses, patients and |
|||
| 61 |
- #'+ #' overall response rate, as well as odds ratio estimates, confidence intervals and p-values, for multiple |
|||
| 62 |
- #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_tot_events`,+ #' biomarkers in a given single data set. |
|||
| 63 |
- #' `median`, `hr`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`,+ #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements |
|||
| 64 |
- #' `var_label`, and `row_type`.+ #' `rsp` and `biomarkers` (vector of continuous biomarker variables) and optionally `covariates` |
|||
| 65 |
- #'+ #' and `strat`. |
|||
| 66 |
- #' @seealso [h_coxreg_mult_cont_df()] which is used internally, [tabulate_survival_biomarkers()].+ #' |
|||
| 67 |
- #'+ #' @return |
|||
| 68 |
- #' @examples+ #' * `h_logistic_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers. |
|||
| 69 |
- #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`,+ #' |
|||
| 70 |
- #' # in multiple regression models containing one covariate `RACE`,+ #' @examples |
|||
| 71 |
- #' # as well as one stratification variable `STRATA1`. The subgroups+ #' # For a single population, estimate separately the effects |
|||
| 72 |
- #' # are defined by the levels of `BMRKR2`.+ #' # of two biomarkers. |
|||
| 73 |
- #'+ #' df <- h_logistic_mult_cont_df( |
|||
| 74 |
- #' library(dplyr)+ #' variables = list( |
|||
| 75 |
- #'+ #' rsp = "rsp", |
|||
| 76 |
- #' adtte <- tern_ex_adtte+ #' biomarkers = c("BMRKR1", "AGE"),
|
|||
| 77 |
- #' adtte_labels <- formatters::var_labels(adtte)+ #' covariates = "SEX" |
|||
| 78 |
- #'+ #' ), |
|||
| 79 |
- #' adtte_f <- adtte %>%+ #' data = adrs_f |
|||
| 80 |
- #' filter(PARAMCD == "OS") %>%+ #' ) |
|||
| 81 |
- #' mutate(+ #' df |
|||
| 82 |
- #' AVALU = as.character(AVALU),+ #' |
|||
| 83 |
- #' is_event = CNSR == 0+ #' # If the data set is empty, still the corresponding rows with missings are returned. |
|||
| 84 |
- #' )+ #' h_coxreg_mult_cont_df( |
|||
| 85 |
- #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
+ #' variables = list( |
|||
| 86 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ #' rsp = "rsp", |
|||
| 87 |
- #'+ #' biomarkers = c("BMRKR1", "AGE"),
|
|||
| 88 |
- #' df <- extract_survival_biomarkers(+ #' covariates = "SEX", |
|||
| 89 |
- #' variables = list(+ #' strat = "STRATA1" |
|||
| 90 |
- #' tte = "AVAL",+ #' ), |
|||
| 91 |
- #' is_event = "is_event",+ #' data = adrs_f[NULL, ] |
|||
| 92 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' ) |
|||
| 93 |
- #' strata = "STRATA1",+ #' |
|||
| 94 |
- #' covariates = "SEX",+ #' @export |
|||
| 95 |
- #' subgroups = "BMRKR2"+ h_logistic_mult_cont_df <- function(variables, |
|||
| 96 |
- #' ),+ data, |
|||
| 97 |
- #' data = adtte_f+ control = control_logistic()) {
|
|||
| 98 | -+ | 22x |
- #' )+ assert_df_with_variables(data, variables) |
|
| 99 |
- #' df+ |
|||
| 100 | -+ | 22x |
- #'+ checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE) |
|
| 101 | -+ | 22x |
- #' # Here we group the levels of `BMRKR2` manually.+ checkmate::assert_list(control, names = "named") |
|
| 102 |
- #' df_grouped <- extract_survival_biomarkers(+ |
|||
| 103 | -+ | 22x |
- #' variables = list(+ conf_level <- control[["conf_level"]] |
|
| 104 | -+ | 22x |
- #' tte = "AVAL",+ pval_label <- "p-value (Wald)" |
|
| 105 |
- #' is_event = "is_event",+ |
|||
| 106 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ # If there is any data, run model, otherwise return empty results. |
|||
| 107 | -+ | 22x |
- #' strata = "STRATA1",+ if (nrow(data) > 0) {
|
|
| 108 | -+ | 21x |
- #' covariates = "SEX",+ bm_cols <- match(variables$biomarkers, names(data)) |
|
| 109 | -+ | 21x |
- #' subgroups = "BMRKR2"+ l_result <- lapply(variables$biomarkers, function(bm) {
|
|
| 110 | -+ | 36x |
- #' ),+ model_fit <- fit_logistic( |
|
| 111 | -+ | 36x |
- #' data = adtte_f,+ variables = h_rsp_to_logistic_variables(variables, bm), |
|
| 112 | -+ | 36x |
- #' groups_lists = list(+ data = data, |
|
| 113 | -+ | 36x |
- #' BMRKR2 = list(+ response_definition = control$response_definition |
|
| 114 |
- #' "low" = "LOW",+ ) |
|||
| 115 | -+ | 36x |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ result <- h_logistic_simple_terms( |
|
| 116 | -+ | 36x |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ x = bm, |
|
| 117 | -+ | 36x |
- #' )+ fit_glm = model_fit, |
|
| 118 | -+ | 36x |
- #' )+ conf_level = control$conf_level |
|
| 119 |
- #' )+ ) |
|||
| 120 | -+ | 36x |
- #' df_grouped+ resp_vector <- if (inherits(model_fit, "glm")) {
|
|
| 121 | -+ | 26x |
- #'+ model_fit$model[[variables$rsp]] |
|
| 122 |
- #' @export+ } else {
|
|||
| 123 | -+ | 10x |
- extract_survival_biomarkers <- function(variables,+ as.logical(as.matrix(model_fit$y)[, "status"]) |
|
| 124 |
- data,+ } |
|||
| 125 | -+ | 36x |
- groups_lists = list(),+ data.frame( |
|
| 126 |
- control = control_coxreg(),+ # Dummy column needed downstream to create a nested header. |
|||
| 127 | -+ | 36x |
- label_all = "All Patients") {
+ biomarker = bm, |
|
| 128 | -4x | +36x |
- checkmate::assert_list(variables)+ biomarker_label = formatters::var_labels(data[bm], fill = TRUE), |
|
| 129 | -4x | +36x |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ n_tot = length(resp_vector), |
|
| 130 | -4x | +36x |
- checkmate::assert_string(label_all)+ n_rsp = sum(resp_vector), |
|
| 131 | -+ | 36x |
-
+ prop = mean(resp_vector), |
|
| 132 | -+ | 36x |
- # Start with all patients.+ or = as.numeric(result[1L, "odds_ratio"]), |
|
| 133 | -4x | +36x |
- result_all <- h_coxreg_mult_cont_df(+ lcl = as.numeric(result[1L, "lcl"]), |
|
| 134 | -4x | +36x |
- variables = variables,+ ucl = as.numeric(result[1L, "ucl"]), |
|
| 135 | -4x | +36x |
- data = data,+ conf_level = conf_level, |
|
| 136 | -4x | +36x |
- control = control+ pval = as.numeric(result[1L, "pvalue"]), |
|
| 137 | -+ | 36x |
- )+ pval_label = pval_label, |
|
| 138 | -4x | +36x |
- result_all$subgroup <- label_all+ stringsAsFactors = FALSE |
|
| 139 | -4x | +
- result_all$var <- "ALL"+ ) |
||
| 140 | -4x | +
- result_all$var_label <- label_all+ }) |
||
| 141 | -4x | +21x |
- result_all$row_type <- "content"+ do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
|
| 142 | -4x | +
- if (is.null(variables$subgroups)) {
+ } else {
|
||
| 143 | -+ | 1x |
- # Only return result for all patients.+ data.frame( |
|
| 144 | 1x |
- result_all+ biomarker = variables$biomarkers, |
||
| 145 | -+ | 1x |
- } else {
+ biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE), |
|
| 146 | -+ | 1x |
- # Add subgroups results.+ n_tot = 0L, |
|
| 147 | -3x | +1x |
- l_data <- h_split_by_subgroups(+ n_rsp = 0L, |
|
| 148 | -3x | +1x |
- data,+ prop = NA, |
|
| 149 | -3x | +1x |
- variables$subgroups,+ or = NA, |
|
| 150 | -3x | +1x |
- groups_lists = groups_lists+ lcl = NA, |
|
| 151 | -+ | 1x |
- )+ ucl = NA, |
|
| 152 | -3x | +1x |
- l_result <- lapply(l_data, function(grp) {
+ conf_level = conf_level, |
|
| 153 | -15x | +1x |
- result <- h_coxreg_mult_cont_df(+ pval = NA, |
|
| 154 | -15x | +1x |
- variables = variables,+ pval_label = pval_label, |
|
| 155 | -15x | +1x |
- data = grp$df,+ row.names = seq_along(variables$biomarkers), |
|
| 156 | -15x | +1x |
- control = control+ stringsAsFactors = FALSE |
|
| 157 |
- )+ ) |
|||
| 158 | -15x | +
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ } |
||
| 159 | -15x | +
- cbind(result, result_labels)+ } |
||
| 160 |
- })+ |
|||
| 161 | -3x | +
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ #' @describeIn h_response_biomarkers_subgroups prepares a single sub-table given a `df_sub` containing |
||
| 162 | -3x | +
- result_subgroups$row_type <- "analysis"+ #' the results for a single biomarker. |
||
| 163 | -3x | +
- rbind(+ #' |
||
| 164 | -3x | +
- result_all,+ #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is |
||
| 165 | -3x | +
- result_subgroups+ #' returned by [extract_rsp_biomarkers()] (it needs a couple of columns which are |
||
| 166 |
- )+ #' added by that high-level function relative to what is returned by [h_logistic_mult_cont_df()], |
|||
| 167 |
- }+ #' see the example). |
|||
| 168 |
- }+ #' |
|||
| 169 |
-
+ #' @return |
|||
| 170 |
- #' @describeIn survival_biomarkers_subgroups Table-creating function which creates a table+ #' * `h_tab_rsp_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns. |
|||
| 171 |
- #' summarizing biomarker effects on survival by subgroup.+ #' |
|||
| 172 |
- #'+ #' @examples |
|||
| 173 |
- #' @param df (`data.frame`)\cr containing all analysis variables, as returned by+ #' # Starting from above `df`, zoom in on one biomarker and add required columns. |
|||
| 174 |
- #' [extract_survival_biomarkers()].+ #' df1 <- df[1, ] |
|||
| 175 |
- #' @param vars (`character`)\cr the names of statistics to be reported among:+ #' df1$subgroup <- "All patients" |
|||
| 176 |
- #' * `n_tot_events`: Total number of events per group.+ #' df1$row_type <- "content" |
|||
| 177 |
- #' * `n_tot`: Total number of observations per group.+ #' df1$var <- "ALL" |
|||
| 178 |
- #' * `median`: Median survival time.+ #' df1$var_label <- "All patients" |
|||
| 179 |
- #' * `hr`: Hazard ratio.+ #' |
|||
| 180 |
- #' * `ci`: Confidence interval of hazard ratio.+ #' h_tab_rsp_one_biomarker( |
|||
| 181 |
- #' * `pval`: p-value of the effect.+ #' df1, |
|||
| 182 |
- #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` are required.+ #' vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval")
|
|||
| 183 |
- #'+ #' ) |
|||
| 184 |
- #' @return An `rtables` table summarizing biomarker effects on survival by subgroup.+ #' |
|||
| 185 |
- #'+ #' @export |
|||
| 186 |
- #' @note In contrast to [tabulate_survival_subgroups()] this tabulation function does+ h_tab_rsp_one_biomarker <- function(df, |
|||
| 187 |
- #' not start from an input layout `lyt`. This is because internally the table is+ vars, |
|||
| 188 |
- #' created by combining multiple subtables.- |
- |||
| 189 | -- |
- #'- |
- ||
| 190 | -- |
- #' @seealso [h_tab_surv_one_biomarker()] which is used internally, [extract_survival_biomarkers()].- |
- ||
| 191 | -- |
- #'- |
- ||
| 192 | -- |
- #' @examples- |
- ||
| 193 | -- |
- #' ## Table with default columns.- |
- ||
| 194 | -- |
- #' tabulate_survival_biomarkers(df)- |
- ||
| 195 | -- |
- #'- |
- ||
| 196 | -- |
- #' ## Table with a manually chosen set of columns: leave out "pval", reorder.- |
- ||
| 197 | -- |
- #' tab <- tabulate_survival_biomarkers(- |
- ||
| 198 | -- |
- #' df = df,- |
- ||
| 199 | -- |
- #' vars = c("n_tot_events", "ci", "n_tot", "median", "hr"),
- |
- ||
| 200 | -- |
- #' time_unit = as.character(adtte_f$AVALU[1])- |
- ||
| 201 | -- |
- #' )- |
- ||
| 202 | -- |
- #'- |
- ||
| 203 | -- |
- #' ## Finally produce the forest plot.- |
- ||
| 204 | -- |
- #' \donttest{
- |
- ||
| 205 | -- |
- #' g_forest(tab, xlim = c(0.8, 1.2))- |
- ||
| 206 | -- |
- #' }- |
- ||
| 207 | -- |
- #'- |
- ||
| 208 | -- |
- #' @export- |
- ||
| 209 | -- |
- tabulate_survival_biomarkers <- function(df,- |
- ||
| 210 | -- |
- vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
- |
- ||
| 211 | -- |
- time_unit = NULL,- |
- ||
| 212 | -- |
- .indent_mods = 0L) {
- |
- ||
| 213 | -3x | -
- checkmate::assert_data_frame(df)- |
- ||
| 214 | -3x | -
- checkmate::assert_character(df$biomarker)- |
- ||
| 215 | -3x | -
- checkmate::assert_character(df$biomarker_label)- |
- ||
| 216 | -3x | -
- checkmate::assert_subset(vars, c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"))
- |
- ||
| 217 | -- | - - | -||
| 218 | -3x | -
- df_subs <- split(df, f = df$biomarker)- |
- ||
| 219 | -3x | -
- tabs <- lapply(df_subs, FUN = function(df_sub) {
- |
- ||
| 220 | -5x | -
- tab_sub <- h_tab_surv_one_biomarker(- |
- ||
| 221 | -5x | -
- df = df_sub,- |
- ||
| 222 | -5x | -
- vars = vars,- |
- ||
| 223 | -5x | -
- time_unit = time_unit,- |
- ||
| 224 | -5x | -
- .indent_mods = .indent_mods- |
- ||
| 225 | -- |
- )- |
- ||
| 226 | -- |
- # Insert label row as first row in table.- |
- ||
| 227 | -5x | -
- label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1]+ .indent_mods = 0L) {
|
||
| 228 | -5x | -
- tab_sub- |
- ||
| 229 | -+ | 189 | +6x |
- })+ afuns <- a_response_subgroups()[vars] |
| 230 | -3x | -
- result <- do.call(rbind, tabs)- |
- ||
| 231 | -+ | 190 | +6x |
-
+ colvars <- d_rsp_subgroups_colvars( |
| 232 | -3x | +191 | +6x |
- n_tot_ids <- grep("^n_tot", vars)
+ vars, |
| 233 | -3x | +192 | +6x |
- hr_id <- match("hr", vars)
+ conf_level = df$conf_level[1], |
| 234 | -3x | +193 | +6x |
- ci_id <- match("ci", vars)
+ method = df$pval_label[1] |
| 235 | -3x | +|||
| 194 | +
- structure(+ ) |
|||
| 236 | -3x | +195 | +6x |
- result,+ h_tab_one_biomarker( |
| 237 | -3x | +196 | +6x |
- forest_header = paste0(c("Higher", "Lower"), "\nBetter"),
+ df = df, |
| 238 | -3x | +197 | +6x |
- col_x = hr_id,+ afuns = afuns, |
| 239 | -3x | +198 | +6x |
- col_ci = ci_id,+ colvars = colvars, |
| 240 | -3x | +199 | +6x |
- col_symbol_size = n_tot_ids[1]+ .indent_mods = .indent_mods |
| 241 | +200 |
) |
||
| 242 | +201 |
}@@ -163423,14 +163769,14 @@ tern coverage - 94.83% |
| 1 |
- #' Occurrence Table Pruning+ #' Helper Function for Deriving Analysis Datasets for `LBT13` and `LBT14` |
||
| 5 |
- #' Family of constructor and condition functions to flexibly prune occurrence tables.+ #' Helper function that merges `ADSL` and `ADLB` datasets so that missing lab test records are inserted in the |
||
| 6 |
- #' The condition functions always return whether the row result is higher than the threshold.+ #' output dataset. Remember that `na_level` must match the needed pre-processing |
||
| 7 |
- #' Since they are of class [CombinationFunction()] they can be logically combined with other condition+ #' done with [df_explicit_na()] to have the desired output. |
||
| 8 |
- #' functions.+ #' |
||
| 9 |
- #'+ #' @param adsl (`data.frame`)\cr `ADSL` dataframe. |
||
| 10 |
- #' @note Since most table specifications are worded positively, we name our constructor and condition+ #' @param adlb (`data.frame`)\cr `ADLB` dataframe. |
||
| 11 |
- #' functions positively, too. However, note that the result of [keep_rows()] says what+ #' @param worst_flag (named `vector`)\cr Worst post-baseline lab flag variable. |
||
| 12 |
- #' should be pruned, to conform with the [rtables::prune_table()] interface.+ #' @param by_visit (`logical`)\cr defaults to `FALSE` to generate worst grade per patient. |
||
| 13 |
- #'+ #' If worst grade per patient per visit is specified for `worst_flag`, then |
||
| 14 |
- #' @examples+ #' `by_visit` should be `TRUE` to generate worst grade patient per visit. |
||
| 15 |
- #' \donttest{
+ #' @param no_fillin_visits (named `character`)\cr Visits that are not considered for post-baseline worst toxicity |
||
| 16 |
- #' tab <- basic_table() %>%+ #' grade. Defaults to `c("SCREENING", "BASELINE")`.
|
||
| 17 |
- #' split_cols_by("ARM") %>%
+ #' |
||
| 18 |
- #' split_rows_by("RACE") %>%
+ #' @return `df` containing variables shared between `adlb` and `adsl` along with variables `PARAM`, `PARAMCD`, |
||
| 19 |
- #' split_rows_by("STRATA1") %>%
+ #' `ATOXGR`, and `BTOXGR` relevant for analysis. Optionally, `AVISIT` are `AVISITN` are included when |
||
| 20 |
- #' summarize_row_groups() %>%+ #' `by_visit = TRUE` and `no_fillin_visits = c("SCREENING", "BASELINE")`.
|
||
| 21 |
- #' analyze_vars("COUNTRY", .stats = "count_fraction") %>%
+ #' |
||
| 22 |
- #' build_table(DM)+ #' @details In the result data missing records will be created for the following situations: |
||
| 23 |
- #' }+ #' * Patients who are present in `adsl` but have no lab data in `adlb` (both baseline and post-baseline). |
||
| 24 |
- #'+ #' * Patients who do not have any post-baseline lab values. |
||
| 25 |
- #' @name prune_occurrences+ #' * Patients without any post-baseline values flagged as the worst. |
||
| 26 |
- NULL+ #' |
||
| 27 |
-
+ #' @examples |
||
| 28 |
- #' @describeIn prune_occurrences Constructor for creating pruning functions based on+ #' # `h_adsl_adlb_merge_using_worst_flag` |
||
| 29 |
- #' a row condition function. This removes all analysis rows (`TableRow`) that should be+ #' adlb_out <- h_adsl_adlb_merge_using_worst_flag( |
||
| 30 |
- #' pruned, i.e., don't fulfill the row condition. It removes the sub-tree if there are no+ #' tern_ex_adsl, |
||
| 31 |
- #' children left.+ #' tern_ex_adlb, |
||
| 32 |
- #'+ #' worst_flag = c("WGRHIFL" = "Y")
|
||
| 33 |
- #' @param row_condition (`CombinationFunction`)\cr condition function which works on individual+ #' ) |
||
| 34 |
- #' analysis rows and flags whether these should be kept in the pruned table.+ #' |
||
| 35 |
- #'+ #' # `h_adsl_adlb_merge_using_worst_flag` by visit example |
||
| 36 |
- #' @return+ #' adlb_out_by_visit <- h_adsl_adlb_merge_using_worst_flag( |
||
| 37 |
- #' * `keep_rows()` returns a pruning function that can be used with [rtables::prune_table()]+ #' tern_ex_adsl, |
||
| 38 |
- #' to prune an `rtables` table.+ #' tern_ex_adlb, |
||
| 39 |
- #'+ #' worst_flag = c("WGRLOVFL" = "Y"),
|
||
| 40 |
- #' @examples+ #' by_visit = TRUE |
||
| 41 |
- #' \donttest{
+ #' ) |
||
| 42 |
- #' # `keep_rows`+ #' |
||
| 43 |
- #' is_non_empty <- !CombinationFunction(all_zero_or_na)+ #' @export |
||
| 44 |
- #' prune_table(tab, keep_rows(is_non_empty))+ h_adsl_adlb_merge_using_worst_flag <- function(adsl, # nolint |
||
| 45 |
- #' }+ adlb, |
||
| 46 |
- #'+ worst_flag = c("WGRHIFL" = "Y"),
|
||
| 47 |
- #' @export+ by_visit = FALSE, |
||
| 48 |
- keep_rows <- function(row_condition) {
+ no_fillin_visits = c("SCREENING", "BASELINE")) {
|
||
| 49 | -6x | +5x |
- checkmate::assert_function(row_condition)+ col_names <- names(worst_flag) |
| 50 | -6x | +5x |
- function(table_tree) {
+ filter_values <- worst_flag |
| 51 | -2256x | +
- if (inherits(table_tree, "TableRow")) {
+
|
|
| 52 | -1872x | +5x |
- return(!row_condition(table_tree))+ temp <- Map( |
| 53 | -+ | 5x |
- }+ function(x, y) which(adlb[[x]] == y), |
| 54 | -384x | +5x |
- children <- tree_children(table_tree)+ col_names, |
| 55 | -384x | +5x |
- identical(length(children), 0L)+ filter_values |
| 56 |
- }+ ) |
||
| 57 |
- }+ |
||
| 58 | -+ | 5x |
-
+ position_satisfy_filters <- Reduce(intersect, temp) |
| 59 |
- #' @describeIn prune_occurrences Constructor for creating pruning functions based on+ |
||
| 60 | -+ | 5x |
- #' a condition for the (first) content row in leaf tables. This removes all leaf tables where+ adsl_adlb_common_columns <- intersect(colnames(adsl), colnames(adlb)) |
| 61 | -+ | 5x |
- #' the first content row does not fulfill the condition. It does not check individual rows.+ columns_from_adlb <- c("USUBJID", "PARAM", "PARAMCD", "AVISIT", "AVISITN", "ATOXGR", "BTOXGR")
|
| 62 |
- #' It then proceeds recursively by removing the sub tree if there are no children left.+ |
||
| 63 | -+ | 5x |
- #'+ adlb_f <- adlb[position_satisfy_filters, ] %>% |
| 64 | -+ | 5x |
- #' @param content_row_condition (`CombinationFunction`)\cr condition function which works on individual+ dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) |
| 65 | -+ | 5x |
- #' first content rows of leaf tables and flags whether these leaf tables should be kept in the pruned table.+ adlb_f <- adlb_f[, columns_from_adlb] |
| 66 |
- #'+ |
||
| 67 | -+ | 5x |
- #' @return+ avisits_grid <- adlb %>% |
| 68 | -+ | 5x |
- #' * `keep_content_rows()` returns a pruning function that checks the condition on the first content+ dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) %>% |
| 69 | -+ | 5x |
- #' row of leaf tables in the table.+ dplyr::pull(.data[["AVISIT"]]) %>% |
| 70 | -+ | 5x |
- #'+ unique() |
| 71 |
- #' @examples+ |
||
| 72 | -+ | 5x |
- #' # `keep_content_rows`+ if (by_visit) {
|
| 73 | -+ | 1x |
- #' \donttest{
+ adsl_lb <- expand.grid( |
| 74 | -+ | 1x |
- #' more_than_twenty <- has_count_in_cols(atleast = 20L, col_names = names(tab))+ USUBJID = unique(adsl$USUBJID), |
| 75 | -+ | 1x |
- #' prune_table(tab, keep_content_rows(more_than_twenty))+ AVISIT = avisits_grid, |
| 76 | -+ | 1x |
- #' }+ PARAMCD = unique(adlb$PARAMCD) |
| 77 |
- #'+ ) |
||
| 78 |
- #' @export+ |
||
| 79 | -+ | 1x |
- keep_content_rows <- function(content_row_condition) {
+ adsl_lb <- adsl_lb %>% |
| 80 | 1x |
- checkmate::assert_function(content_row_condition)+ dplyr::left_join(unique(adlb[c("AVISIT", "AVISITN")]), by = "AVISIT") %>%
|
|
| 81 | 1x |
- function(table_tree) {
+ dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
|
|
| 82 | -166x | +
- if (is_leaf_table(table_tree)) {
+
|
|
| 83 | -24x | +1x |
- content_row <- h_content_first_row(table_tree)+ adsl1 <- adsl[, adsl_adlb_common_columns] |
| 84 | -24x | +1x |
- return(!content_row_condition(content_row))+ adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID") |
| 85 |
- }+ |
||
| 86 | -142x | +1x |
- if (inherits(table_tree, "DataRow")) {
+ by_variables_from_adlb <- c("USUBJID", "AVISIT", "AVISITN", "PARAMCD", "PARAM")
|
| 87 | -120x | +
- return(FALSE)+ |
|
| 88 | -+ | 1x |
- }+ adlb_btoxgr <- adlb %>% |
| 89 | -22x | +1x |
- children <- tree_children(table_tree)+ dplyr::select(c("USUBJID", "PARAMCD", "BTOXGR")) %>%
|
| 90 | -22x | +1x |
- identical(length(children), 0L)+ unique() %>% |
| 91 | +1x | +
+ dplyr::rename("BTOXGR_MAP" = "BTOXGR")
+ |
+ |
| 92 | ++ | + + | +|
| 93 | +1x | +
+ adlb_out <- merge(+ |
+ |
| 94 | +1x | +
+ adlb_f,+ |
+ |
| 95 | +1x | +
+ adsl_lb,+ |
+ |
| 96 | +1x | +
+ by = by_variables_from_adlb,+ |
+ |
| 97 | +1x | +
+ all = TRUE,+ |
+ |
| 98 | +1x | +
+ sort = FALSE+ |
+ |
| 99 | ++ |
+ )+ |
+ |
| 100 | +1x | +
+ adlb_out <- adlb_out %>%+ |
+ |
| 101 | +1x | +
+ dplyr::left_join(adlb_btoxgr, by = c("USUBJID", "PARAMCD")) %>%
+ |
+ |
| 102 | +1x | +
+ dplyr::mutate(BTOXGR = .data$BTOXGR_MAP) %>%+ |
+ |
| 103 | +1x | +
+ dplyr::select(-"BTOXGR_MAP")+ |
+ |
| 104 | ++ | + + | +|
| 105 | +1x | +
+ adlb_var_labels <- c(+ |
+ |
| 106 | +1x | +
+ formatters::var_labels(adlb[by_variables_from_adlb]),+ |
+ |
| 107 | +1x | +
+ formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]),+ |
+ |
| 108 | +1x | +
+ formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]])+ |
+ |
| 109 | ++ |
+ )+ |
+ |
| 110 | ++ |
+ } else {
+ |
+ |
| 111 | +4x | +
+ adsl_lb <- expand.grid(+ |
+ |
| 112 | +4x | +
+ USUBJID = unique(adsl$USUBJID),+ |
+ |
| 113 | +4x | +
+ PARAMCD = unique(adlb$PARAMCD)+ |
+ |
| 114 | ++ |
+ )+ |
+ |
| 115 | ++ | + + | +|
| 116 | +4x | +
+ adsl_lb <- adsl_lb %>% dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
+ |
+ |
| 117 | ++ | + + | +|
| 118 | +4x | +
+ adsl1 <- adsl[, adsl_adlb_common_columns]+ |
+ |
| 119 | +4x | +
+ adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID")+ |
+ |
| 120 | ++ | + + | +|
| 121 | +4x | +
+ by_variables_from_adlb <- c("USUBJID", "PARAMCD", "PARAM")
+ |
+ |
| 122 | ++ | + + | +|
| 123 | +4x | +
+ adlb_out <- merge(+ |
+ |
| 124 | +4x | +
+ adlb_f,+ |
+ |
| 125 | +4x | +
+ adsl_lb,+ |
+ |
| 126 | +4x | +
+ by = by_variables_from_adlb,+ |
+ |
| 127 | +4x | +
+ all = TRUE,+ |
+ |
| 128 | +4x | +
+ sort = FALSE+ |
+ |
| 129 | ++ |
+ )+ |
+ |
| 130 | ++ | + + | +|
| 131 | +4x | +
+ adlb_var_labels <- c(+ |
+ |
| 132 | +4x | +
+ formatters::var_labels(adlb[by_variables_from_adlb]),+ |
+ |
| 133 | +4x | +
+ formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]),+ |
+ |
| 134 | +4x | +
+ formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]])+ |
+ |
| 135 | ++ |
+ )+ |
+ |
| 136 |
} |
||
| 92 | +137 |
- }+ + |
+ |
| 138 | +5x | +
+ adlb_out$ATOXGR <- as.factor(adlb_out$ATOXGR)+ |
+ |
| 139 | +5x | +
+ adlb_out$BTOXGR <- as.factor(adlb_out$BTOXGR) |
|
| 93 | +140 | ||
| 141 | +5x | +
+ formatters::var_labels(adlb_out) <- adlb_var_labels+ |
+ |
| 94 | +142 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on total counts in the specified columns.+ + |
+ |
| 143 | +5x | +
+ adlb_out |
|
| 95 | +144 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Patient Counts with Abnormal Range Values by Baseline Status+ |
+ ||
| 2 |
#' |
|||
| 96 | +3 |
- #' @param atleast (`count` or `proportion`)\cr threshold which should be met in order to keep the row.+ #' @description `r lifecycle::badge("stable")`
|
||
| 97 | +4 |
- #' @param ... arguments for row or column access, see [`rtables_access`]: either `col_names` (`character`) including+ #' |
||
| 98 | +5 |
- #' the names of the columns which should be used, or alternatively `col_indices` (`integer`) giving the indices+ #' Primary analysis variable `.var` indicates the abnormal range result (`character` or `factor`), and additional |
||
| 99 | +6 |
- #' directly instead.+ #' analysis variables are `id` (`character` or `factor`) and `baseline` (`character` or `factor`). For each |
||
| 100 | +7 |
- #'+ #' direction specified in `abnormal` (e.g. high or low) we condition on baseline range result and count |
||
| 101 | +8 |
- #' @return+ #' patients in the numerator and denominator as follows: |
||
| 102 | +9 |
- #' * `has_count_in_cols()` returns a condition function that sums the counts in the specified column.+ #' * `Not <Abnormal>` |
||
| 103 | +10 |
- #'+ #' * `denom`: the number of patients without abnormality at baseline (excluding those with missing baseline) |
||
| 104 | +11 |
- #' @examples+ #' * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline |
||
| 105 | +12 |
- #' \donttest{
+ #' * `<Abnormal>` |
||
| 106 | +13 |
- #' more_than_one <- has_count_in_cols(atleast = 1L, col_names = names(tab))+ #' * `denom`: the number of patients with abnormality at baseline |
||
| 107 | +14 |
- #' prune_table(tab, keep_rows(more_than_one))+ #' * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline |
||
| 108 | +15 |
- #' }+ #' * `Total` |
||
| 109 | +16 | ++ |
+ #' * `denom`: the number of patients with at least one valid measurement post-baseline+ |
+ |
| 17 | ++ |
+ #' * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline+ |
+ ||
| 18 |
#' |
|||
| 110 | +19 |
- #' @export+ #' @inheritParams argument_convention |
||
| 111 | +20 |
- has_count_in_cols <- function(atleast, ...) {
+ #' @param abnormal (`character`)\cr identifying the abnormal range level(s) in `.var`. |
||
| 112 | -3x | +|||
| 21 | +
- checkmate::assert_count(atleast)+ #' |
|||
| 113 | -3x | +|||
| 22 | +
- CombinationFunction(function(table_row) {
+ #' @note |
|||
| 114 | -334x | +|||
| 23 | +
- row_counts <- h_row_counts(table_row, ...)+ #' * `df` should be filtered to include only post-baseline records. |
|||
| 115 | -334x | +|||
| 24 | +
- total_count <- sum(row_counts)+ #' * If the baseline variable or analysis variable contains `NA`, it is expected that `NA` has been |
|||
| 116 | -334x | +|||
| 25 | +
- total_count >= atleast+ #' conveyed to `na_level` appropriately beforehand with [df_explicit_na()] or [explicit_na()]. |
|||
| 117 | +26 |
- })+ #' |
||
| 118 | +27 |
- }+ #' @seealso Relevant description function [d_count_abnormal_by_baseline()]. |
||
| 119 | +28 |
-
+ #' |
||
| 120 | +29 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on any of the counts in+ #' @name abnormal_by_baseline |
||
| 121 | +30 |
- #' the specified columns satisfying a threshold.+ NULL |
||
| 122 | +31 |
- #'+ |
||
| 123 | +32 |
- #' @param atleast (`count` or `proportion`)\cr threshold which should be met in order to keep the row.+ #' Description Function for [s_count_abnormal_by_baseline()] |
||
| 124 | +33 |
#' |
||
| 125 | +34 |
- #' @return+ #' @description `r lifecycle::badge("stable")`
|
||
| 126 | +35 |
- #' * `has_count_in_any_col()` returns a condition function that compares the counts in the+ #' |
||
| 127 | +36 |
- #' specified columns with the threshold.+ #' Description function that produces the labels for [s_count_abnormal_by_baseline()]. |
||
| 128 | +37 |
#' |
||
| 129 | +38 |
- #' @examples+ #' @inheritParams abnormal_by_baseline |
||
| 130 | +39 |
- #' \donttest{
+ #' |
||
| 131 | +40 |
- #' # `has_count_in_any_col`+ #' @return Abnormal category labels for [s_count_abnormal_by_baseline()]. |
||
| 132 | +41 |
- #' any_more_than_one <- has_count_in_any_col(atleast = 1L, col_names = names(tab))+ #' |
||
| 133 | +42 |
- #' prune_table(tab, keep_rows(any_more_than_one))+ #' @examples |
||
| 134 | +43 |
- #' }+ #' d_count_abnormal_by_baseline("LOW")
|
||
| 135 | +44 |
#' |
||
| 136 | +45 |
#' @export |
||
| 137 | +46 |
- has_count_in_any_col <- function(atleast, ...) {
+ d_count_abnormal_by_baseline <- function(abnormal) {
|
||
| 138 | -! | +|||
| 47 | +7x |
- checkmate::assert_count(atleast)+ not_abn_name <- paste("Not", tolower(abnormal))
|
||
| 139 | -! | +|||
| 48 | +7x |
- CombinationFunction(function(table_row) {
+ abn_name <- paste0(toupper(substr(abnormal, 1, 1)), tolower(substring(abnormal, 2))) |
||
| 140 | -! | +|||
| 49 | +7x |
- row_counts <- h_row_counts(table_row, ...)+ total_name <- "Total" |
||
| 141 | -! | +|||
| 50 | +
- any(row_counts >= atleast)+ + |
+ |||
| 51 | +7x | +
+ list(+ |
+ ||
| 52 | +7x | +
+ not_abnormal = not_abn_name,+ |
+ ||
| 53 | +7x | +
+ abnormal = abn_name,+ |
+ ||
| 54 | +7x | +
+ total = total_name |
||
| 142 | +55 |
- })+ ) |
||
| 143 | +56 |
} |
||
| 144 | +57 | |||
| 145 | +58 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on total fraction in+ #' @describeIn abnormal_by_baseline Statistics function for a single `abnormal` level.+ |
+ ||
| 59 | ++ |
+ #'+ |
+ ||
| 60 | ++ |
+ #' @param na_str (`string`)\cr the explicit `na_level` argument you used in the pre-processing steps (maybe with+ |
+ ||
| 61 | ++ |
+ #' [df_explicit_na()]). The default is `"<Missing>"`.+ |
+ ||
| 62 | ++ |
+ #'+ |
+ ||
| 63 | ++ |
+ #' @return+ |
+ ||
| 64 | ++ |
+ #' * `s_count_abnormal_by_baseline()` returns statistic `fraction` which is a named list with 3 labeled elements: |
||
| 146 | +65 |
- #' the specified columns.+ #' `not_abnormal`, `abnormal`, and `total`. Each element contains a vector with `num` and `denom` patient counts. |
||
| 147 | +66 |
#' |
||
| 148 | +67 |
- #' @return+ #' |
||
| 149 | +68 |
- #' * `has_fraction_in_cols()` returns a condition function that sums the counts in the+ #' @keywords internal |
||
| 150 | +69 |
- #' specified column, and computes the fraction by dividing by the total column counts.+ s_count_abnormal_by_baseline <- function(df, |
||
| 151 | +70 |
- #'+ .var, |
||
| 152 | +71 |
- #' @examples+ abnormal, |
||
| 153 | +72 |
- #' \donttest{
+ na_level = lifecycle::deprecated(), |
||
| 154 | +73 |
- #' # `has_fraction_in_cols`+ na_str = "<Missing>", |
||
| 155 | +74 |
- #' more_than_five_percent <- has_fraction_in_cols(atleast = 0.05, col_names = names(tab))+ variables = list(id = "USUBJID", baseline = "BNRIND")) {
|
||
| 156 | -+ | |||
| 75 | +5x |
- #' prune_table(tab, keep_rows(more_than_five_percent))+ if (lifecycle::is_present(na_level)) {
|
||
| 157 | -+ | |||
| 76 | +! |
- #' }+ lifecycle::deprecate_warn("0.9.1", "s_count_abnormal_by_baseline(na_level)", "s_count_abnormal_by_baseline(na_str)")
|
||
| 158 | -+ | |||
| 77 | +! |
- #'+ na_str <- na_level |
||
| 159 | +78 |
- #' @export+ } |
||
| 160 | +79 |
- has_fraction_in_cols <- function(atleast, ...) {
+
|
||
| 161 | -1x | +80 | +5x |
- assert_proportion_value(atleast, include_boundaries = TRUE)+ checkmate::assert_string(.var) |
| 162 | -1x | +81 | +5x |
- CombinationFunction(function(table_row) {
+ checkmate::assert_string(abnormal) |
| 163 | -303x | +82 | +5x |
- row_counts <- h_row_counts(table_row, ...)+ checkmate::assert_string(na_str) |
| 164 | -303x | +83 | +5x |
- total_count <- sum(row_counts)+ assert_df_with_variables(df, c(range = .var, variables)) |
| 165 | -303x | +84 | +5x |
- col_counts <- h_col_counts(table_row, ...)+ checkmate::assert_subset(names(variables), c("id", "baseline"))
|
| 166 | -303x | +85 | +5x |
- total_n <- sum(col_counts)+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
| 167 | -303x | +86 | +5x |
- total_percent <- total_count / total_n+ checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
|
| 168 | -303x | +87 | +5x |
- total_percent >= atleast+ checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
|
| 169 | +88 |
- })+ |
||
| 170 | +89 |
- }+ # If input is passed as character, changed to factor |
||
| 171 | -+ | |||
| 90 | +5x |
-
+ df[[.var]] <- as_factor_keep_attributes(df[[.var]], na_level = na_str) |
||
| 172 | -+ | |||
| 91 | +5x |
- #' @describeIn prune_occurrences Constructor for creating condition functions on any fraction in+ df[[variables$baseline]] <- as_factor_keep_attributes(df[[variables$baseline]], na_level = na_str) |
||
| 173 | +92 |
- #' the specified columns.+ |
||
| 174 | -+ | |||
| 93 | +5x |
- #'+ assert_valid_factor(df[[.var]], any.missing = FALSE) |
||
| 175 | -+ | |||
| 94 | +4x |
- #' @return+ assert_valid_factor(df[[variables$baseline]], any.missing = FALSE) |
||
| 176 | +95 |
- #' * `has_fraction_in_any_col()` returns a condition function that looks at the fractions+ |
||
| 177 | +96 |
- #' in the specified columns and checks whether any of them fulfill the threshold.+ # Keep only records with valid analysis value. |
||
| 178 | -+ | |||
| 97 | +3x |
- #'+ df <- df[df[[.var]] != na_str, ] |
||
| 179 | +98 |
- #' @examples+ |
||
| 180 | -+ | |||
| 99 | +3x |
- #' \donttest{
+ anl <- data.frame( |
||
| 181 | -+ | |||
| 100 | +3x |
- #' # `has_fraction_in_any_col`+ id = df[[variables$id]], |
||
| 182 | -+ | |||
| 101 | +3x |
- #' any_atleast_five_percent <- has_fraction_in_any_col(atleast = 0.05, col_names = names(tab))+ var = df[[.var]], |
||
| 183 | -+ | |||
| 102 | +3x |
- #' prune_table(tab, keep_rows(more_than_five_percent))+ baseline = df[[variables$baseline]], |
||
| 184 | -+ | |||
| 103 | +3x |
- #' }+ stringsAsFactors = FALSE |
||
| 185 | +104 |
- #'+ ) |
||
| 186 | +105 |
- #' @export+ |
||
| 187 | +106 |
- has_fraction_in_any_col <- function(atleast, ...) {
- |
- ||
| 188 | -! | -
- assert_proportion_value(atleast, include_boundaries = TRUE)+ # Total: |
||
| 189 | -! | +|||
| 107 | +
- CombinationFunction(function(table_row) {
+ # - Patients in denominator: have at least one valid measurement post-baseline. |
|||
| 190 | -! | +|||
| 108 | +
- row_fractions <- h_row_fractions(table_row, ...)+ # - Patients in numerator: have at least one abnormality. |
|||
| 191 | -! | +|||
| 109 | +3x |
- any(row_fractions >= atleast)+ total_denom <- length(unique(anl$id)) |
||
| 192 | -+ | |||
| 110 | +3x |
- })+ total_num <- length(unique(anl$id[anl$var == abnormal])) |
||
| 193 | +111 |
- }+ |
||
| 194 | +112 |
-
+ # Baseline NA records are counted only in total rows. |
||
| 195 | -+ | |||
| 113 | +3x |
- #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference+ anl <- anl[anl$baseline != na_str, ] |
||
| 196 | +114 |
- #' between the fractions reported in each specified column.+ |
||
| 197 | +115 |
- #'+ # Abnormal: |
||
| 198 | +116 |
- #' @return+ # - Patients in denominator: have abnormality at baseline. |
||
| 199 | +117 |
- #' * `has_fractions_difference()` returns a condition function that extracts the fractions of each+ # - Patients in numerator: have abnormality at baseline AND |
||
| 200 | +118 |
- #' specified column, and computes the difference of the minimum and maximum.+ # have at least one abnormality post-baseline. |
||
| 201 | -+ | |||
| 119 | +3x |
- #'+ abn_denom <- length(unique(anl$id[anl$baseline == abnormal])) |
||
| 202 | -+ | |||
| 120 | +3x |
- #' @examples+ abn_num <- length(unique(anl$id[anl$baseline == abnormal & anl$var == abnormal])) |
||
| 203 | +121 |
- #' \donttest{
+
|
||
| 204 | +122 |
- #' # `has_fractions_difference`+ # Not abnormal: |
||
| 205 | +123 |
- #' more_than_five_percent_diff <- has_fractions_difference(atleast = 0.05, col_names = names(tab))+ # - Patients in denominator: do not have abnormality at baseline. |
||
| 206 | +124 |
- #' prune_table(tab, keep_rows(more_than_five_percent_diff))+ # - Patients in numerator: do not have abnormality at baseline AND |
||
| 207 | +125 |
- #' }+ # have at least one abnormality post-baseline. |
||
| 208 | -+ | |||
| 126 | +3x |
- #'+ not_abn_denom <- length(unique(anl$id[anl$baseline != abnormal])) |
||
| 209 | -+ | |||
| 127 | +3x |
- #' @export+ not_abn_num <- length(unique(anl$id[anl$baseline != abnormal & anl$var == abnormal])) |
||
| 210 | +128 |
- has_fractions_difference <- function(atleast, ...) {
+
|
||
| 211 | -1x | +129 | +3x |
- assert_proportion_value(atleast, include_boundaries = TRUE)+ labels <- d_count_abnormal_by_baseline(abnormal) |
| 212 | -1x | +130 | +3x |
- CombinationFunction(function(table_row) {
+ list(fraction = list( |
| 213 | -243x | +131 | +3x |
- fractions <- h_row_fractions(table_row, ...)+ not_abnormal = formatters::with_label(c(num = not_abn_num, denom = not_abn_denom), labels$not_abnormal), |
| 214 | -243x | +132 | +3x |
- difference <- diff(range(fractions))+ abnormal = formatters::with_label(c(num = abn_num, denom = abn_denom), labels$abnormal), |
| 215 | -243x | +133 | +3x |
- difference >= atleast+ total = formatters::with_label(c(num = total_num, denom = total_denom), labels$total) |
| 216 | +134 |
- })+ )) |
||
| 217 | +135 |
} |
||
| 218 | +136 | |||
| 219 | +137 |
- #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference+ #' @describeIn abnormal_by_baseline Formatted analysis function which is used as `afun` |
||
| 220 | +138 |
- #' between the counts reported in each specified column.+ #' in `count_abnormal_by_baseline()`. |
||
| 221 | +139 |
#' |
||
| 222 | +140 |
#' @return |
||
| 223 | +141 |
- #' * `has_counts_difference()` returns a condition function that extracts the counts of each+ #' * `a_count_abnormal_by_baseline()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 224 | +142 |
- #' specified column, and computes the difference of the minimum and maximum.+ #' |
||
| 225 | +143 |
#' |
||
| 226 | +144 |
- #' @examples+ #' @keywords internal |
||
| 227 | +145 |
- #' \donttest{
+ a_count_abnormal_by_baseline <- make_afun( |
||
| 228 | +146 |
- #' more_than_one_diff <- has_counts_difference(atleast = 1L, col_names = names(tab))+ s_count_abnormal_by_baseline, |
||
| 229 | +147 |
- #' prune_table(tab, keep_rows(more_than_one_diff))+ .formats = c(fraction = format_fraction) |
||
| 230 | +148 |
- #' }+ ) |
||
| 231 | +149 |
- #'+ |
||
| 232 | +150 |
- #' @export+ #' @describeIn abnormal_by_baseline Layout-creating function which can take statistics function arguments |
||
| 233 | +151 |
- has_counts_difference <- function(atleast, ...) {
- |
- ||
| 234 | -1x | -
- checkmate::assert_count(atleast)- |
- ||
| 235 | -1x | -
- CombinationFunction(function(table_row) {
- |
- ||
| 236 | -27x | -
- counts <- h_row_counts(table_row, ...)- |
- ||
| 237 | -27x | -
- difference <- diff(range(counts))- |
- ||
| 238 | -27x | -
- difference >= atleast+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 239 | +152 |
- })+ #' |
||
| 240 | +153 |
- }+ #' @return |
| 1 | +154 |
- #' Helper Functions for Tabulating Biomarker Effects on Survival by Subgroup+ #' * `count_abnormal_by_baseline()` returns a layout object suitable for passing to further layouting functions, |
||
| 2 | +155 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 3 | +156 |
- #' @description `r lifecycle::badge("stable")`
+ #' the statistics from `s_count_abnormal_by_baseline()` to the table layout. |
||
| 4 | +157 |
#' |
||
| 5 | +158 |
- #' Helper functions which are documented here separately to not confuse the user+ #' @examples |
||
| 6 | +159 |
- #' when reading about the user-facing functions.+ #' df <- data.frame( |
||
| 7 | +160 |
- #'+ #' USUBJID = as.character(c(1:6)), |
||
| 8 | +161 |
- #' @inheritParams survival_biomarkers_subgroups+ #' ANRIND = factor(c(rep("LOW", 4), "NORMAL", "HIGH")),
|
||
| 9 | +162 |
- #' @inheritParams argument_convention+ #' BNRIND = factor(c("LOW", "NORMAL", "HIGH", NA, "LOW", "NORMAL"))
|
||
| 10 | +163 |
- #' @inheritParams fit_coxreg_multivar+ #' ) |
||
| 11 | +164 |
- #'+ #' df <- df_explicit_na(df) |
||
| 12 | +165 |
- #' @examples+ #' |
||
| 13 | +166 |
- #' library(dplyr)+ #' # Layout creating function. |
||
| 14 | +167 |
- #' library(forcats)+ #' basic_table() %>% |
||
| 15 | +168 |
- #'+ #' count_abnormal_by_baseline(var = "ANRIND", abnormal = c(High = "HIGH")) %>% |
||
| 16 | +169 |
- #' adtte <- tern_ex_adtte+ #' build_table(df) |
||
| 17 | +170 |
#' |
||
| 18 | +171 |
- #' # Save variable labels before data processing steps.+ #' # Passing of statistics function and formatting arguments. |
||
| 19 | +172 |
- #' adtte_labels <- formatters::var_labels(adtte, fill = FALSE)+ #' df2 <- data.frame( |
||
| 20 | +173 |
- #'+ #' ID = as.character(c(1, 2, 3, 4)), |
||
| 21 | +174 |
- #' adtte_f <- adtte %>%+ #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
|
||
| 22 | +175 |
- #' filter(PARAMCD == "OS") %>%+ #' BLRANGE = factor(c("LOW", "HIGH", "HIGH", "NORMAL"))
|
||
| 23 | +176 |
- #' mutate(+ #' ) |
||
| 24 | +177 |
- #' AVALU = as.character(AVALU),+ #' |
||
| 25 | +178 |
- #' is_event = CNSR == 0+ #' basic_table() %>% |
||
| 26 | +179 |
- #' )+ #' count_abnormal_by_baseline( |
||
| 27 | +180 |
- #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
+ #' var = "RANGE", |
||
| 28 | +181 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ #' abnormal = c(Low = "LOW"), |
||
| 29 | +182 |
- #'+ #' variables = list(id = "ID", baseline = "BLRANGE"), |
||
| 30 | +183 |
- #' @name h_survival_biomarkers_subgroups+ #' .formats = c(fraction = "xx / xx"), |
||
| 31 | +184 |
- NULL+ #' .indent_mods = c(fraction = 2L) |
||
| 32 | +185 |
-
+ #' ) %>% |
||
| 33 | +186 |
- #' @describeIn h_survival_biomarkers_subgroups helps with converting the "survival" function variable list+ #' build_table(df2) |
||
| 34 | +187 |
- #' to the "Cox regression" variable list. The reason is that currently there is an inconsistency between the variable+ #' |
||
| 35 | +188 |
- #' names accepted by `extract_survival_subgroups()` and `fit_coxreg_multivar()`.+ #' @export |
||
| 36 | +189 |
- #'+ count_abnormal_by_baseline <- function(lyt, |
||
| 37 | +190 |
- #' @param biomarker (`string`)\cr the name of the biomarker variable.+ var, |
||
| 38 | +191 |
- #'+ abnormal, |
||
| 39 | +192 |
- #' @return+ na_str = "<Missing>", |
||
| 40 | +193 |
- #' * `h_surv_to_coxreg_variables()` returns a named `list` of elements `time`, `event`, `arm`,+ nested = TRUE, |
||
| 41 | +194 |
- #' `covariates`, and `strata`.+ ..., |
||
| 42 | +195 |
- #'+ table_names = abnormal, |
||
| 43 | +196 |
- #' @examples+ .stats = NULL, |
||
| 44 | +197 |
- #' # This is how the variable list is converted internally.+ .formats = NULL, |
||
| 45 | +198 |
- #' h_surv_to_coxreg_variables(+ .labels = NULL, |
||
| 46 | +199 |
- #' variables = list(+ .indent_mods = NULL) {
|
||
| 47 | -+ | |||
| 200 | +2x |
- #' tte = "AVAL",+ checkmate::assert_character(abnormal, len = length(table_names), names = "named") |
||
| 48 | -+ | |||
| 201 | +2x |
- #' is_event = "EVNT",+ checkmate::assert_string(var) |
||
| 49 | -+ | |||
| 202 | +2x |
- #' covariates = c("A", "B"),
+ afun <- make_afun( |
||
| 50 | -+ | |||
| 203 | +2x |
- #' strata = "D"+ a_count_abnormal_by_baseline, |
||
| 51 | -+ | |||
| 204 | +2x |
- #' ),+ .stats = .stats, |
||
| 52 | -+ | |||
| 205 | +2x |
- #' biomarker = "AGE"+ .formats = .formats, |
||
| 53 | -+ | |||
| 206 | +2x |
- #' )+ .labels = .labels, |
||
| 54 | -+ | |||
| 207 | +2x |
- #'+ .indent_mods = .indent_mods, |
||
| 55 | -+ | |||
| 208 | +2x |
- #' @export+ .ungroup_stats = "fraction" |
||
| 56 | +209 |
- h_surv_to_coxreg_variables <- function(variables, biomarker) {
+ ) |
||
| 57 | -41x | +210 | +2x |
- checkmate::assert_list(variables)+ for (i in seq_along(abnormal)) {
|
| 58 | -41x | +211 | +4x |
- checkmate::assert_string(variables$tte)+ abn <- abnormal[i] |
| 59 | -41x | +212 | +4x |
- checkmate::assert_string(variables$is_event)+ lyt <- analyze( |
| 60 | -41x | +213 | +4x |
- checkmate::assert_string(biomarker)+ lyt = lyt, |
| 61 | -41x | +214 | +4x |
- list(+ vars = var, |
| 62 | -41x | +215 | +4x |
- time = variables$tte,+ var_labels = names(abn), |
| 63 | -41x | +216 | +4x |
- event = variables$is_event,+ afun = afun, |
| 64 | -41x | +217 | +4x |
- arm = biomarker,+ na_str = na_str, |
| 65 | -41x | +218 | +4x |
- covariates = variables$covariates,+ nested = nested, |
| 66 | -41x | -
- strata = variables$strata- |
- ||
| 67 | -+ | 219 | +4x |
- )+ table_names = table_names[i], |
| 68 | -+ | |||
| 220 | +4x |
- }+ extra_args = c(list(abnormal = abn, na_str = na_str), list(...)), |
||
| 69 | -+ | |||
| 221 | +4x |
-
+ show_labels = "visible" |
||
| 70 | +222 |
- #' @describeIn h_survival_biomarkers_subgroups prepares estimates for number of events, patients and median survival+ ) |
||
| 71 | +223 |
- #' times, as well as hazard ratio estimates, confidence intervals and p-values, for multiple biomarkers+ } |
||
| 72 | -+ | |||
| 224 | +2x |
- #' in a given single data set.+ lyt |
||
| 73 | +225 |
- #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements+ } |
| 74 | +1 |
- #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables) and optionally `subgroups` and `strat`.+ #' Control Function for `CoxPH` Model |
||
| 75 | +2 |
#' |
||
| 76 | -- |
- #' @return- |
- ||
| 77 | +3 |
- #' * `h_coxreg_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers.+ #' @description `r lifecycle::badge("stable")`
|
||
| 78 | +4 |
#' |
||
| 79 | +5 |
- #' @examples+ #' This is an auxiliary function for controlling arguments for `CoxPH` model, typically used internally to specify |
||
| 80 | +6 |
- #' # For a single population, estimate separately the effects+ #' details of `CoxPH` model for [s_coxph_pairwise()]. `conf_level` refers to Hazard Ratio estimation. |
||
| 81 | +7 |
- #' # of two biomarkers.+ #' |
||
| 82 | +8 |
- #' df <- h_coxreg_mult_cont_df(+ #' @inheritParams argument_convention |
||
| 83 | +9 |
- #' variables = list(+ #' @param pval_method (`string`)\cr p-value method for testing hazard ratio = 1. |
||
| 84 | +10 |
- #' tte = "AVAL",+ #' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`. |
||
| 85 | +11 |
- #' is_event = "is_event",+ #' @param ties (`string`)\cr specifying the method for tie handling. Default is `"efron"`, |
||
| 86 | +12 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()]. |
||
| 87 | +13 |
- #' covariates = "SEX",+ #' |
||
| 88 | +14 |
- #' strata = c("STRATA1", "STRATA2")
+ #' @return A list of components with the same names as the arguments |
||
| 89 | +15 |
- #' ),+ #' |
||
| 90 | +16 |
- #' data = adtte_f+ #' @export |
||
| 91 | +17 |
- #' )+ control_coxph <- function(pval_method = c("log-rank", "wald", "likelihood"),
|
||
| 92 | +18 |
- #' df+ ties = c("efron", "breslow", "exact"),
|
||
| 93 | +19 |
- #'+ conf_level = 0.95) {
|
||
| 94 | -+ | |||
| 20 | +40x |
- #' # If the data set is empty, still the corresponding rows with missings are returned.+ pval_method <- match.arg(pval_method) |
||
| 95 | -+ | |||
| 21 | +39x |
- #' h_coxreg_mult_cont_df(+ ties <- match.arg(ties) |
||
| 96 | -+ | |||
| 22 | +39x |
- #' variables = list(+ assert_proportion_value(conf_level) |
||
| 97 | +23 |
- #' tte = "AVAL",+ |
||
| 98 | -+ | |||
| 24 | +38x |
- #' is_event = "is_event",+ list(pval_method = pval_method, ties = ties, conf_level = conf_level) |
||
| 99 | +25 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ } |
||
| 100 | +26 |
- #' covariates = "REGION1",+ |
||
| 101 | +27 |
- #' strata = c("STRATA1", "STRATA2")
+ #' Control Function for `survfit` Model for Survival Time |
||
| 102 | +28 |
- #' ),+ #' |
||
| 103 | +29 |
- #' data = adtte_f[NULL, ]+ #' @description `r lifecycle::badge("stable")`
|
||
| 104 | +30 |
- #' )+ #' |
||
| 105 | +31 |
- #'+ #' This is an auxiliary function for controlling arguments for `survfit` model, typically used internally to specify |
||
| 106 | +32 |
- #' @export+ #' details of `survfit` model for [s_surv_time()]. `conf_level` refers to survival time estimation. |
||
| 107 | +33 |
- h_coxreg_mult_cont_df <- function(variables,+ #' |
||
| 108 | +34 |
- data,+ #' @inheritParams argument_convention |
||
| 109 | +35 |
- control = control_coxreg()) {
- |
- ||
| 110 | -21x | -
- assert_df_with_variables(data, variables)+ #' @param conf_type (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log", |
||
| 111 | -21x | +|||
| 36 | +
- checkmate::assert_list(control, names = "named")+ #' see more in [survival::survfit()]. Note option "none" is no longer supported. |
|||
| 112 | -21x | +|||
| 37 | +
- checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE)+ #' @param quantiles (`numeric`)\cr of length two to specify the quantiles of survival time. |
|||
| 113 | -21x | +|||
| 38 | +
- conf_level <- control[["conf_level"]]+ #' |
|||
| 114 | -21x | +|||
| 39 | +
- pval_label <- paste0(+ #' @return A list of components with the same names as the arguments |
|||
| 115 | +40 |
- # the regex capitalizes the first letter of the string / senetence.+ #' |
||
| 116 | -21x | +|||
| 41 | +
- "p-value (", gsub("(^[a-z])", "\\U\\1", trimws(control[["pval_method"]]), perl = TRUE), ")"
+ #' @export |
|||
| 117 | +42 |
- )+ control_surv_time <- function(conf_level = 0.95, |
||
| 118 | +43 |
- # If there is any data, run model, otherwise return empty results.+ conf_type = c("plain", "log", "log-log"),
|
||
| 119 | -21x | +|||
| 44 | +
- if (nrow(data) > 0) {
+ quantiles = c(0.25, 0.75)) {
|
|||
| 120 | -20x | +45 | +154x |
- bm_cols <- match(variables$biomarkers, names(data))+ conf_type <- match.arg(conf_type) |
| 121 | -20x | +46 | +153x |
- l_result <- lapply(variables$biomarkers, function(bm) {
+ checkmate::assert_numeric(quantiles, lower = 0, upper = 1, len = 2, unique = TRUE, sorted = TRUE) |
| 122 | -40x | +47 | +152x |
- coxreg_list <- fit_coxreg_multivar(+ nullo <- lapply(quantiles, assert_proportion_value) |
| 123 | -40x | +48 | +152x |
- variables = h_surv_to_coxreg_variables(variables, bm),+ assert_proportion_value(conf_level) |
| 124 | -40x | +49 | +151x |
- data = data,+ list(conf_level = conf_level, conf_type = conf_type, quantiles = quantiles) |
| 125 | -40x | +|||
| 50 | +
- control = control+ } |
|||
| 126 | +51 |
- )+ |
||
| 127 | -40x | +|||
| 52 | +
- result <- do.call(+ #' Control Function for `survfit` Model for Patient's Survival Rate at time point |
|||
| 128 | -40x | +|||
| 53 | +
- h_coxreg_multivar_extract,+ #' |
|||
| 129 | -40x | +|||
| 54 | +
- c(list(var = bm), coxreg_list[c("mod", "data", "control")])
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 130 | +55 |
- )+ #' |
||
| 131 | -40x | +|||
| 56 | +
- data_fit <- as.data.frame(as.matrix(coxreg_list$mod$y))+ #' This is an auxiliary function for controlling arguments for `survfit` model, typically used internally to specify |
|||
| 132 | -40x | +|||
| 57 | +
- data_fit$status <- as.logical(data_fit$status)+ #' details of `survfit` model for [s_surv_timepoint()]. `conf_level` refers to patient risk estimation at a time point. |
|||
| 133 | -40x | +|||
| 58 | +
- median <- s_surv_time(+ #' |
|||
| 134 | -40x | +|||
| 59 | +
- df = data_fit,+ #' @inheritParams argument_convention |
|||
| 135 | -40x | +|||
| 60 | +
- .var = "time",+ #' @inheritParams control_surv_time |
|||
| 136 | -40x | +|||
| 61 | +
- is_event = "status"+ #' |
|||
| 137 | -40x | +|||
| 62 | +
- )$median+ #' @return A list of components with the same names as the arguments |
|||
| 138 | -40x | +|||
| 63 | +
- data.frame(+ #' |
|||
| 139 | +64 |
- # Dummy column needed downstream to create a nested header.+ #' @export |
||
| 140 | -40x | +|||
| 65 | +
- biomarker = bm,+ control_surv_timepoint <- function(conf_level = 0.95, |
|||
| 141 | -40x | +|||
| 66 | +
- biomarker_label = formatters::var_labels(data[bm], fill = TRUE),+ conf_type = c("plain", "log", "log-log")) {
|
|||
| 142 | -40x | +67 | +30x |
- n_tot = coxreg_list$mod$n,+ conf_type <- match.arg(conf_type) |
| 143 | -40x | +68 | +29x |
- n_tot_events = coxreg_list$mod$nevent,+ assert_proportion_value(conf_level) |
| 144 | -40x | +69 | +28x |
- median = as.numeric(median),+ list( |
| 145 | -40x | +70 | +28x |
- result[1L, c("hr", "lcl", "ucl")],
+ conf_level = conf_level, |
| 146 | -40x | +71 | +28x |
- conf_level = conf_level,+ conf_type = conf_type |
| 147 | -40x | +|||
| 72 | +
- pval = result[1L, "pval"],+ ) |
|||
| 148 | -40x | +|||
| 73 | +
- pval_label = pval_label,+ } |
|||
| 149 | -40x | +
| 1 | +
- stringsAsFactors = FALSE+ #' Counting Missed Doses |
|||
| 150 | +2 |
- )+ #' |
||
| 151 | +3 |
- })+ #' @description `r lifecycle::badge("stable")`
|
||
| 152 | -20x | +|||
| 4 | +
- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ #' |
|||
| 153 | +5 |
- } else {
+ #' These are specific functions to count patients with missed doses. The difference to [count_cumulative()] is |
||
| 154 | -1x | +|||
| 6 | +
- data.frame(+ #' mainly the special labels. |
|||
| 155 | -1x | +|||
| 7 | +
- biomarker = variables$biomarkers,+ #' |
|||
| 156 | -1x | +|||
| 8 | +
- biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE),+ #' @inheritParams argument_convention |
|||
| 157 | -1x | +|||
| 9 | +
- n_tot = 0L,+ #' |
|||
| 158 | -1x | +|||
| 10 | +
- n_tot_events = 0L,+ #' @seealso Relevant description function [d_count_missed_doses()]. |
|||
| 159 | -1x | +|||
| 11 | +
- median = NA,+ #' |
|||
| 160 | -1x | +|||
| 12 | +
- hr = NA,+ #' @name count_missed_doses |
|||
| 161 | -1x | +|||
| 13 | +
- lcl = NA,+ NULL |
|||
| 162 | -1x | +|||
| 14 | +
- ucl = NA,+ |
|||
| 163 | -1x | +|||
| 15 | +
- conf_level = conf_level,+ #' @describeIn count_missed_doses Statistics function to count non-missing values. |
|||
| 164 | -1x | +|||
| 16 | +
- pval = NA,+ #' |
|||
| 165 | -1x | +|||
| 17 | +
- pval_label = pval_label,+ #' @return |
|||
| 166 | -1x | +|||
| 18 | +
- row.names = seq_along(variables$biomarkers),+ #' * `s_count_nonmissing()` returns the statistic `n` which is the count of non-missing values in `x`. |
|||
| 167 | -1x | +|||
| 19 | +
- stringsAsFactors = FALSE+ #' |
|||
| 168 | +20 |
- )+ #' @examples |
||
| 169 | +21 |
- }+ #' set.seed(1) |
||
| 170 | +22 |
- }+ #' x <- c(sample(1:10, 10), NA) |
||
| 171 | +23 |
-
+ #' |
||
| 172 | +24 |
- #' @describeIn h_survival_biomarkers_subgroups prepares a single sub-table given a `df_sub` containing+ #' @keywords internal |
||
| 173 | +25 |
- #' the results for a single biomarker.+ s_count_nonmissing <- function(x) {
+ |
+ ||
| 26 | +5x | +
+ list(n = n_available(x)) |
||
| 174 | +27 |
- #'+ } |
||
| 175 | +28 |
- #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is+ |
||
| 176 | +29 |
- #' returned by [extract_survival_biomarkers()] (it needs a couple of columns which are+ #' Description Function that Calculates Labels for [s_count_missed_doses()]. |
||
| 177 | +30 |
- #' added by that high-level function relative to what is returned by [h_coxreg_mult_cont_df()],+ #' |
||
| 178 | +31 |
- #' see the example).+ #' @description `r lifecycle::badge("stable")`
|
||
| 179 | +32 |
#' |
||
| 180 | +33 |
- #' @return+ #' @inheritParams s_count_missed_doses |
||
| 181 | +34 |
- #' * `h_tab_surv_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns.+ #' |
||
| 182 | +35 |
- #'+ #' @return [d_count_missed_doses()] returns a named `character` vector with the labels. |
||
| 183 | +36 |
- #' @examples+ #' |
||
| 184 | +37 |
- #' # Starting from above `df`, zoom in on one biomarker and add required columns.+ #' @seealso [s_count_missed_doses()] |
||
| 185 | +38 |
- #' df1 <- df[1, ]+ #' |
||
| 186 | +39 |
- #' df1$subgroup <- "All patients"+ #' @export |
||
| 187 | +40 |
- #' df1$row_type <- "content"+ d_count_missed_doses <- function(thresholds) {
+ |
+ ||
| 41 | +4x | +
+ paste0("At least ", thresholds, " missed dose", ifelse(thresholds > 1, "s", ""))
|
||
| 188 | +42 |
- #' df1$var <- "ALL"+ } |
||
| 189 | +43 |
- #' df1$var_label <- "All patients"+ |
||
| 190 | +44 |
- #' h_tab_surv_one_biomarker(+ #' @describeIn count_missed_doses Statistics function to count patients with missed doses. |
||
| 191 | +45 |
- #' df1,+ #' |
||
| 192 | +46 |
- #' vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
+ #' @param thresholds (vector of `count`)\cr number of missed doses the patients at least had. |
||
| 193 | +47 |
- #' time_unit = "days"+ #' |
||
| 194 | +48 |
- #' )+ #' @return |
||
| 195 | +49 |
- #'+ #' * `s_count_missed_doses()` returns the statistics `n` and `count_fraction` with one element for each threshold. |
||
| 196 | +50 |
- #' @export+ #' |
||
| 197 | +51 |
- h_tab_surv_one_biomarker <- function(df,+ #' @keywords internal |
||
| 198 | +52 |
- vars,+ s_count_missed_doses <- function(x, |
||
| 199 | +53 |
- time_unit,+ thresholds, |
||
| 200 | +54 |
- .indent_mods = 0L) {
+ .N_col) { # nolint
|
||
| 201 | -6x | +55 | +1x |
- afuns <- a_survival_subgroups()[vars]+ stat <- s_count_cumulative( |
| 202 | -6x | +56 | +1x |
- colvars <- d_survival_subgroups_colvars(+ x = x, |
| 203 | -6x | +57 | +1x |
- vars,+ thresholds = thresholds, |
| 204 | -6x | +58 | +1x |
- conf_level = df$conf_level[1],+ lower_tail = FALSE, |
| 205 | -6x | +59 | +1x |
- method = df$pval_label[1],+ include_eq = TRUE, |
| 206 | -6x | +60 | +1x |
- time_unit = time_unit+ .N_col = .N_col |
| 207 | +61 |
) |
||
| 208 | -6x | +62 | +1x |
- h_tab_one_biomarker(+ labels <- d_count_missed_doses(thresholds) |
| 209 | -6x | +63 | +1x |
- df = df,+ for (i in seq_along(stat$count_fraction)) {
|
| 210 | -6x | +64 | +2x |
- afuns = afuns,+ stat$count_fraction[[i]] <- formatters::with_label(stat$count_fraction[[i]], label = labels[i])+ |
+
| 65 | ++ |
+ } |
||
| 211 | -6x | +66 | +1x |
- colvars = colvars,+ n_stat <- s_count_nonmissing(x) |
| 212 | -6x | +67 | +1x |
- .indent_mods = .indent_mods+ c(n_stat, stat) |
| 213 | +68 |
- )+ } |
||
| 214 | +69 |
- }+ |
| 1 | +70 |
- #' Patient Counts with the Most Extreme Post-baseline Toxicity Grade per Direction of Abnormality+ #' @describeIn count_missed_doses Formatted analysis function which is used as `afun` |
|
| 2 | +71 |
- #'+ #' in `count_missed_doses()`. |
|
| 3 | +72 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
|
| 4 | +73 |
- #'+ #' @return |
|
| 5 | +74 |
- #' Primary analysis variable `.var` indicates the toxicity grade (`factor`), and additional+ #' * `a_count_missed_doses()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 6 | +75 |
- #' analysis variables are `id` (`character` or `factor`), `param` (`factor`) and `grade_dir` (`factor`).+ #' |
|
| 7 | +76 |
- #' The pre-processing steps are crucial when using this function.+ #' @keywords internal |
|
| 8 | +77 |
- #' For a certain direction (e.g. high or low) this function counts+ a_count_missed_doses <- make_afun( |
|
| 9 | +78 |
- #' patients in the denominator as number of patients with at least one valid measurement during treatment,+ s_count_missed_doses, |
|
| 10 | +79 |
- #' and patients in the numerator as follows:+ .formats = c(n = "xx", count_fraction = format_count_fraction) |
|
| 11 | +80 |
- #' * `1` to `4`: Numerator is number of patients with worst grades 1-4 respectively;+ ) |
|
| 12 | +81 |
- #' * `Any`: Numerator is number of patients with at least one abnormality, which means grade is different from 0.+ |
|
| 13 | +82 |
- #'+ #' @describeIn count_missed_doses Layout-creating function which can take statistics function arguments |
|
| 14 | +83 |
- #' @inheritParams argument_convention+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
| 15 | +84 |
#' |
|
| 16 | +85 |
- #' @details The pre-processing steps are crucial when using this function. From the standard lab grade variable+ #' @inheritParams s_count_cumulative |
|
| 17 | +86 |
- #' `ATOXGR`, derive the following two variables:+ #' |
|
| 18 | +87 |
- #' * A grade direction variable (e.g. `GRADE_DIR`) is required in order to obtain+ #' @return |
|
| 19 | +88 |
- #' the correct denominators when building the layout as it is used to define row splitting.+ #' * `count_missed_doses()` returns a layout object suitable for passing to further layouting functions, |
|
| 20 | +89 |
- #' * A toxicity grade variable (e.g. `GRADE_ANL`) where all negative values from+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
| 21 | +90 |
- #' `ATOXGR` are replaced by their absolute values.+ #' the statistics from `s_count_missed_doses()` to the table layout. |
|
| 22 | +91 |
#' |
|
| 23 | +92 |
- #' @note Prior to tabulation, `df` must be filtered to include only post-baseline records with worst grade flags.+ #' @examples |
|
| 24 | +93 |
- #'+ #' library(dplyr) |
|
| 25 | +94 |
- #' @name abnormal_by_worst_grade+ #' |
|
| 26 | +95 |
- NULL+ #' anl <- tern_ex_adsl %>% |
|
| 27 | +96 |
-
+ #' distinct(STUDYID, USUBJID, ARM) %>% |
|
| 28 | +97 |
- #' @describeIn abnormal_by_worst_grade Statistics function which counts patients by worst grade.+ #' mutate( |
|
| 29 | +98 |
- #'+ #' PARAMCD = "TNDOSMIS", |
|
| 30 | +99 |
- #' @return+ #' PARAM = "Total number of missed doses during study", |
|
| 31 | +100 |
- #' * `s_count_abnormal_by_worst_grade()` returns the single statistic `count_fraction` with grades 1 to 4 and+ #' AVAL = sample(0:20, size = nrow(tern_ex_adsl), replace = TRUE), |
|
| 32 | +101 |
- #' "Any" results.+ #' AVALC = "" |
|
| 33 | +102 |
- #'+ #' ) |
|
| 34 | +103 |
- #' @examples+ #' |
|
| 35 | +104 |
- #' library(dplyr)+ #' basic_table() %>% |
|
| 36 | +105 |
- #' library(forcats)+ #' split_cols_by("ARM") %>%
|
|
| 37 | +106 |
- #' adlb <- tern_ex_adlb+ #' add_colcounts() %>% |
|
| 38 | +107 |
- #'+ #' count_missed_doses("AVAL", thresholds = c(1, 5, 10, 15), var_labels = "Missed Doses") %>%
|
|
| 39 | +108 |
- #' # Data is modified in order to have some parameters with grades only in one direction+ #' build_table(anl, alt_counts_df = tern_ex_adsl) |
|
| 40 | +109 |
- #' # and simulate the real data.+ #' |
|
| 41 | +110 |
- #' adlb$ATOXGR[adlb$PARAMCD == "ALT" & adlb$ATOXGR %in% c("1", "2", "3", "4")] <- "-1"
+ #' @export |
|
| 42 | +111 |
- #' adlb$ANRIND[adlb$PARAMCD == "ALT" & adlb$ANRIND == "HIGH"] <- "LOW"+ count_missed_doses <- function(lyt, |
|
| 43 | +112 |
- #' adlb$WGRHIFL[adlb$PARAMCD == "ALT"] <- ""+ vars, |
|
| 44 | +113 |
- #'+ var_labels = vars, |
|
| 45 | +114 |
- #' adlb$ATOXGR[adlb$PARAMCD == "IGA" & adlb$ATOXGR %in% c("-1", "-2", "-3", "-4")] <- "1"
+ show_labels = "visible", |
|
| 46 | +115 |
- #' adlb$ANRIND[adlb$PARAMCD == "IGA" & adlb$ANRIND == "LOW"] <- "HIGH"+ na_str = NA_character_, |
|
| 47 | +116 |
- #' adlb$WGRLOFL[adlb$PARAMCD == "IGA"] <- ""+ nested = TRUE, |
|
| 48 | +117 |
- #'+ ..., |
|
| 49 | +118 |
- #' # Here starts the real pre-processing.+ table_names = vars, |
|
| 50 | +119 |
- #' adlb_f <- adlb %>%+ .stats = NULL, |
|
| 51 | +120 |
- #' filter(!AVISIT %in% c("SCREENING", "BASELINE")) %>%
+ .formats = NULL, |
|
| 52 | +121 |
- #' mutate(+ .labels = NULL, |
|
| 53 | +122 |
- #' GRADE_DIR = factor(+ .indent_mods = NULL) {
|
|
| 54 | -+ | ||
| 123 | +1x |
- #' case_when(+ afun <- make_afun( |
|
| 55 | -+ | ||
| 124 | +1x |
- #' ATOXGR %in% c("-1", "-2", "-3", "-4") ~ "LOW",
+ a_count_missed_doses, |
|
| 56 | -+ | ||
| 125 | +1x |
- #' ATOXGR == "0" ~ "ZERO",+ .stats = .stats, |
|
| 57 | -+ | ||
| 126 | +1x |
- #' ATOXGR %in% c("1", "2", "3", "4") ~ "HIGH"
+ .formats = .formats, |
|
| 58 | -+ | ||
| 127 | +1x |
- #' ),+ .labels = .labels, |
|
| 59 | -+ | ||
| 128 | +1x |
- #' levels = c("LOW", "ZERO", "HIGH")
+ .indent_mods = .indent_mods, |
|
| 60 | -+ | ||
| 129 | +1x |
- #' ),+ .ungroup_stats = "count_fraction" |
|
| 61 | +130 |
- #' GRADE_ANL = fct_relevel(+ ) |
|
| 62 | -+ | ||
| 131 | +1x |
- #' fct_recode(ATOXGR, `1` = "-1", `2` = "-2", `3` = "-3", `4` = "-4"),+ analyze(+ |
+ |
| 132 | +1x | +
+ lyt = lyt,+ |
+ |
| 133 | +1x | +
+ vars = vars,+ |
+ |
| 134 | +1x | +
+ afun = afun,+ |
+ |
| 135 | +1x | +
+ var_labels = var_labels,+ |
+ |
| 136 | +1x | +
+ table_names = table_names,+ |
+ |
| 137 | +1x | +
+ show_labels = show_labels,+ |
+ |
| 138 | +1x | +
+ na_str = na_str,+ |
+ |
| 139 | +1x | +
+ nested = nested,+ |
+ |
| 140 | +1x | +
+ extra_args = list(...) |
|
| 63 | +141 |
- #' c("0", "1", "2", "3", "4")
+ ) |
|
| 64 | +142 |
- #' )+ } |
| 65 | +1 |
- #' ) %>%+ #' Summarize Variables in Columns |
|
| 66 | +2 |
- #' filter(WGRLOFL == "Y" | WGRHIFL == "Y") %>%+ #' |
|
| 67 | +3 |
- #' droplevels()+ #' @description `r lifecycle::badge("stable")`
|
|
| 68 | +4 |
#' |
|
| 69 | +5 |
- #' adlb_f_alt <- adlb_f %>%+ #' This analyze function uses the S3 generic function [s_summary()] to summarize different variables |
|
| 70 | +6 |
- #' filter(PARAMCD == "ALT") %>%+ #' that are arranged in columns. Additional standard formatting arguments are available. It is a |
|
| 71 | +7 |
- #' droplevels()+ #' minimal wrapper for [rtables::analyze_colvars()]. The latter function is meant to add different |
|
| 72 | +8 |
- #' full_parent_df <- list(adlb_f_alt, "not_needed")+ #' analysis methods for each column variables as different rows. To have the analysis methods as |
|
| 73 | +9 |
- #' cur_col_subset <- list(rep(TRUE, nrow(adlb_f_alt)), "not_needed")+ #' column labels, please refer to [analyze_vars_in_cols()]. |
|
| 74 | +10 |
#' |
|
| 75 | +11 |
- #' # This mimics a split structure on PARAM and GRADE_DIR for a total column+ #' @inheritParams argument_convention |
|
| 76 | +12 |
- #' spl_context <- data.frame(+ #' @param ... arguments passed to `s_summary()`. |
|
| 77 | +13 |
- #' split = c("PARAM", "GRADE_DIR"),
+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector |
|
| 78 | +14 |
- #' full_parent_df = I(full_parent_df),+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
|
| 79 | +15 |
- #' cur_col_subset = I(cur_col_subset)+ #' for that statistic's row label. |
|
| 80 | +16 |
- #' )+ #' |
|
| 81 | +17 |
- #'+ #' @return |
|
| 82 | +18 |
- #' @keywords internal+ #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()]. |
|
| 83 | +19 |
- s_count_abnormal_by_worst_grade <- function(df, # nolint+ #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output |
|
| 84 | +20 |
- .var = "GRADE_ANL",+ #' in columns, and add it to the table layout. |
|
| 85 | +21 |
- .spl_context,+ #' |
|
| 86 | +22 |
- variables = list(+ #' @seealso [rtables::split_cols_by_multivar()] and [`analyze_colvars_functions`]. |
|
| 87 | +23 |
- id = "USUBJID",+ #' |
|
| 88 | +24 |
- param = "PARAM",+ #' @examples |
|
| 89 | +25 |
- grade_dir = "GRADE_DIR"+ #' dta_test <- data.frame( |
|
| 90 | +26 |
- )) {
+ #' USUBJID = rep(1:6, each = 3), |
|
| 91 | -1x | +||
| 27 | +
- checkmate::assert_string(.var)+ #' PARAMCD = rep("lab", 6 * 3),
|
||
| 92 | -1x | +||
| 28 | +
- assert_valid_factor(df[[.var]])+ #' AVISIT = rep(paste0("V", 1:3), 6),
|
||
| 93 | -1x | +||
| 29 | +
- assert_valid_factor(df[[variables$param]])+ #' ARM = rep(LETTERS[1:3], rep(6, 3)), |
||
| 94 | -1x | +||
| 30 | +
- assert_valid_factor(df[[variables$grade_dir]])+ #' AVAL = c(9:1, rep(NA, 9)), |
||
| 95 | -1x | +||
| 31 | +
- assert_df_with_variables(df, c(a = .var, variables))+ #' CHG = c(1:9, rep(NA, 9)) |
||
| 96 | -1x | +||
| 32 | +
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ #' ) |
||
| 97 | +33 |
-
+ #' |
|
| 98 | +34 |
- # To verify that the `split_rows_by` are performed with correct variables.+ #' ## Default output within a `rtables` pipeline. |
|
| 99 | -1x | +||
| 35 | +
- checkmate::assert_subset(c(variables[["param"]], variables[["grade_dir"]]), .spl_context$split)+ #' basic_table() %>% |
||
| 100 | -1x | +||
| 36 | +
- first_row <- .spl_context[.spl_context$split == variables[["param"]], ]+ #' split_cols_by("ARM") %>%
|
||
| 101 | -1x | +||
| 37 | +
- x_lvls <- c(setdiff(levels(df[[.var]]), "0"), "Any")+ #' split_rows_by("AVISIT") %>%
|
||
| 102 | -1x | +||
| 38 | +
- result <- split(numeric(0), factor(x_lvls))+ #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
|
||
| 103 | +39 |
-
+ #' summarize_colvars() %>% |
|
| 104 | -1x | +||
| 40 | +
- subj <- first_row$full_parent_df[[1]][[variables[["id"]]]]+ #' build_table(dta_test) |
||
| 105 | -1x | +||
| 41 | +
- subj_cur_col <- subj[first_row$cur_col_subset[[1]]]+ #' |
||
| 106 | +42 |
- # Some subjects may have a record for high and low directions but+ #' ## Selection of statistics, formats and labels also work. |
|
| 107 | +43 |
- # should be counted only once.+ #' basic_table() %>% |
|
| 108 | -1x | +||
| 44 | +
- denom <- length(unique(subj_cur_col))+ #' split_cols_by("ARM") %>%
|
||
| 109 | +45 |
-
+ #' split_rows_by("AVISIT") %>%
|
|
| 110 | -1x | +||
| 46 | +
- for (lvl in x_lvls) {
+ #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
|
||
| 111 | -5x | +||
| 47 | +
- if (lvl != "Any") {
+ #' summarize_colvars( |
||
| 112 | -4x | +||
| 48 | +
- df_lvl <- df[df[[.var]] == lvl, ]+ #' .stats = c("n", "mean_sd"),
|
||
| 113 | +49 |
- } else {
+ #' .formats = c("mean_sd" = "xx.x, xx.x"),
|
|
| 114 | -1x | +||
| 50 | +
- df_lvl <- df[df[[.var]] != 0, ]+ #' .labels = c(n = "n", mean_sd = "Mean, SD") |
||
| 115 | +51 |
- }+ #' ) %>% |
|
| 116 | -5x | +||
| 52 | +
- num <- length(unique(df_lvl[["USUBJID"]]))+ #' build_table(dta_test) |
||
| 117 | -5x | +||
| 53 | +
- fraction <- ifelse(denom == 0, 0, num / denom)+ #' |
||
| 118 | -5x | +||
| 54 | +
- result[[lvl]] <- formatters::with_label(c(count = num, fraction = fraction), lvl)+ #' ## Use arguments interpreted by `s_summary`. |
||
| 119 | +55 |
- }+ #' basic_table() %>% |
|
| 120 | +56 |
-
+ #' split_cols_by("ARM") %>%
|
|
| 121 | -1x | +||
| 57 | +
- result <- list(count_fraction = result)+ #' split_rows_by("AVISIT") %>%
|
||
| 122 | -1x | +||
| 58 | +
- result+ #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
|
||
| 123 | +59 |
- }+ #' summarize_colvars(na.rm = FALSE) %>% |
|
| 124 | +60 |
-
+ #' build_table(dta_test) |
|
| 125 | +61 |
- #' @describeIn abnormal_by_worst_grade Formatted analysis function which is used as `afun`+ #' |
|
| 126 | +62 |
- #' in `count_abnormal_by_worst_grade()`.+ #' @export |
|
| 127 | +63 |
- #'+ summarize_colvars <- function(lyt, |
|
| 128 | +64 |
- #' @return+ ..., |
|
| 129 | +65 |
- #' * `a_count_abnormal_by_worst_grade()` returns the corresponding list with formatted [rtables::CellValue()].+ na_level = lifecycle::deprecated(), |
|
| 130 | +66 |
- #'+ na_str = NA_character_, |
|
| 131 | +67 |
- #'+ .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
|
|
| 132 | +68 |
- #' @keywords internal+ .formats = NULL, |
|
| 133 | +69 |
- a_count_abnormal_by_worst_grade <- make_afun( # nolint+ .labels = NULL, |
|
| 134 | +70 |
- s_count_abnormal_by_worst_grade,+ .indent_mods = NULL) {
|
|
| 135 | -+ | ||
| 71 | +3x |
- .formats = c(count_fraction = format_count_fraction)+ if (lifecycle::is_present(na_level)) {
+ |
+ |
| 72 | +! | +
+ lifecycle::deprecate_warn("0.9.1", "summarize_colvars(na_level)", "summarize_colvars(na_str)")
+ |
+ |
| 73 | +! | +
+ na_str <- na_level |
|
| 136 | +74 |
- )+ } |
|
| 137 | +75 | ||
| 138 | -+ | ||
| 76 | +3x |
- #' @describeIn abnormal_by_worst_grade Layout-creating function which can take statistics function arguments+ extra_args <- list(.stats = .stats, na_str = na_str, ...) |
|
| 139 | -+ | ||
| 77 | +1x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
|
| 140 | -+ | ||
| 78 | +1x |
- #'+ if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
|
| 141 | -+ | ||
| 79 | +1x |
- #' @return+ if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
|
| 142 | +80 |
- #' * `count_abnormal_by_worst_grade()` returns a layout object suitable for passing to further layouting functions,+ |
|
| 143 | -+ | ||
| 81 | +3x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ analyze_colvars( |
|
| 144 | -+ | ||
| 82 | +3x |
- #' the statistics from `s_count_abnormal_by_worst_grade()` to the table layout.+ lyt, |
|
| 145 | -+ | ||
| 83 | +3x |
- #'+ afun = a_summary, |
|
| 146 | -+ | ||
| 84 | +3x |
- #' @examples+ extra_args = extra_args |
|
| 147 | +85 |
- #' # Map excludes records without abnormal grade since they should not be displayed+ ) |
|
| 148 | +86 |
- #' # in the table.+ } |
| 149 | +1 |
- #' map <- unique(adlb_f[adlb_f$GRADE_DIR != "ZERO", c("PARAM", "GRADE_DIR", "GRADE_ANL")]) %>%
+ #' Sort Data by `PK PARAM` Variable |
||
| 150 | +2 |
- #' lapply(as.character) %>%+ #' |
||
| 151 | +3 |
- #' as.data.frame() %>%+ #' @description `r lifecycle::badge("stable")`
|
||
| 152 | +4 |
- #' arrange(PARAM, desc(GRADE_DIR), GRADE_ANL)+ #' |
||
| 153 | +5 |
- #'+ #' @param pk_data (`data.frame`)\cr `Pharmacokinetics` dataframe |
||
| 154 | +6 |
- #' basic_table() %>%+ #' @param key_var (`character`)\cr key variable used to merge pk_data and metadata created by `d_pkparam()` |
||
| 155 | +7 |
- #' split_cols_by("ARMCD") %>%
+ #' |
||
| 156 | +8 |
- #' split_rows_by("PARAM") %>%
+ #' @return A PK `data.frame` sorted by a `PARAM` variable. |
||
| 157 | +9 |
- #' split_rows_by("GRADE_DIR", split_fun = trim_levels_to_map(map)) %>%
+ #' |
||
| 158 | +10 |
- #' count_abnormal_by_worst_grade(+ #' @examples |
||
| 159 | +11 |
- #' var = "GRADE_ANL",+ #' library(dplyr) |
||
| 160 | +12 |
- #' variables = list(id = "USUBJID", param = "PARAM", grade_dir = "GRADE_DIR")+ #' |
||
| 161 | +13 |
- #' ) %>%+ #' adpp <- tern_ex_adpp %>% mutate(PKPARAM = factor(paste0(PARAM, " (", AVALU, ")")))
|
||
| 162 | +14 |
- #' build_table(df = adlb_f)+ #' pk_ordered_data <- h_pkparam_sort(adpp) |
||
| 163 | +15 |
#' |
||
| 164 | +16 |
#' @export |
||
| 165 | +17 |
- count_abnormal_by_worst_grade <- function(lyt,+ h_pkparam_sort <- function(pk_data, key_var = "PARAMCD") {
|
||
| 166 | -+ | |||
| 18 | +4x |
- var,+ assert_df_with_variables(pk_data, list(key_var = key_var)) |
||
| 167 | -+ | |||
| 19 | +4x |
- nested = TRUE,+ pk_data$PARAMCD <- pk_data[[key_var]] |
||
| 168 | +20 |
- ...,+ |
||
| 169 | -+ | |||
| 21 | +4x |
- .stats = NULL,+ ordered_pk_data <- d_pkparam() |
||
| 170 | +22 |
- .formats = NULL,+ |
||
| 171 | +23 |
- .labels = NULL,+ # Add the numeric values from ordered_pk_data to pk_data+ |
+ ||
| 24 | +4x | +
+ joined_data <- merge(pk_data, ordered_pk_data, by = "PARAMCD", suffix = c("", ".y"))
|
||
| 172 | +25 |
- .indent_mods = NULL) {
+
|
||
| 173 | -2x | +26 | +4x |
- afun <- make_afun(+ joined_data <- joined_data[, -grep(".*.y$", colnames(joined_data))]
|
| 174 | -2x | +|||
| 27 | +
- a_count_abnormal_by_worst_grade,+ |
|||
| 175 | -2x | +28 | +4x |
- .stats = .stats,+ joined_data$TLG_ORDER <- as.numeric(joined_data$TLG_ORDER) |
| 176 | -2x | +|||
| 29 | +
- .formats = .formats,+ + |
+ |||
| 30 | ++ |
+ # Then order PARAM based on this column |
||
| 177 | -2x | +31 | +4x |
- .labels = .labels,+ joined_data$PARAM <- factor(joined_data$PARAM, |
| 178 | -2x | +32 | +4x |
- .indent_mods = .indent_mods,+ levels = unique(joined_data$PARAM[order(joined_data$TLG_ORDER)]), |
| 179 | -2x | +33 | +4x |
- .ungroup_stats = "count_fraction"+ ordered = TRUE |
| 180 | +34 |
) |
||
| 181 | -2x | +|||
| 35 | +
- analyze(+ |
|||
| 182 | -2x | +36 | +4x |
- lyt = lyt,+ joined_data$TLG_DISPLAY <- factor(joined_data$TLG_DISPLAY, |
| 183 | -2x | +37 | +4x |
- vars = var,+ levels = unique(joined_data$TLG_DISPLAY[order(joined_data$TLG_ORDER)]), |
| 184 | -2x | +38 | +4x |
- afun = afun,+ ordered = TRUE |
| 185 | -2x | +|||
| 39 | +
- nested = nested,+ ) |
|||
| 186 | -2x | +|||
| 40 | +
- extra_args = list(...),+ |
|||
| 187 | -2x | -
- show_labels = "hidden"- |
- ||
| 188 | -+ | 41 | +4x |
- )+ joined_data |
| 189 | +42 |
}@@ -167942,14 +168789,14 @@ tern coverage - 94.83% |
| 1 |
- #' Helper Function for Deriving Analysis Datasets for `LBT13` and `LBT14`+ #' Control function for incidence rate |
||
| 5 |
- #' Helper function that merges `ADSL` and `ADLB` datasets so that missing lab test records are inserted in the+ #' This is an auxiliary function for controlling arguments for the incidence rate, used |
||
| 6 |
- #' output dataset. Remember that `na_level` must match the needed pre-processing+ #' internally to specify details in `s_incidence_rate()`. |
||
| 7 |
- #' done with [df_explicit_na()] to have the desired output.+ #' |
||
| 8 |
- #'+ #' @inheritParams argument_convention |
||
| 9 |
- #' @param adsl (`data.frame`)\cr `ADSL` dataframe.+ #' @param conf_type (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar` |
||
| 10 |
- #' @param adlb (`data.frame`)\cr `ADLB` dataframe.+ #' for confidence interval type. |
||
| 11 |
- #' @param worst_flag (named `vector`)\cr Worst post-baseline lab flag variable.+ #' @param input_time_unit (`string`)\cr `day`, `week`, `month`, or `year` (default) |
||
| 12 |
- #' @param by_visit (`logical`)\cr defaults to `FALSE` to generate worst grade per patient.+ #' indicating time unit for data input. |
||
| 13 |
- #' If worst grade per patient per visit is specified for `worst_flag`, then+ #' @param num_pt_year (`numeric`)\cr number of patient-years to use when calculating adverse event rates. |
||
| 14 |
- #' `by_visit` should be `TRUE` to generate worst grade patient per visit.+ #' @param time_unit_input `r lifecycle::badge("deprecated")` Please use the `input_time_unit` argument instead.
|
||
| 15 |
- #' @param no_fillin_visits (named `character`)\cr Visits that are not considered for post-baseline worst toxicity+ #' @param time_unit_output `r lifecycle::badge("deprecated")` Please use the `num_pt_year` argument instead.
|
||
| 16 |
- #' grade. Defaults to `c("SCREENING", "BASELINE")`.
+ #' |
||
| 17 |
- #'+ #' @return A list of components with the same names as the arguments. |
||
| 18 |
- #' @return `df` containing variables shared between `adlb` and `adsl` along with variables `PARAM`, `PARAMCD`,+ #' |
||
| 19 |
- #' `ATOXGR`, and `BTOXGR` relevant for analysis. Optionally, `AVISIT` are `AVISITN` are included when+ #' @seealso [incidence_rate] |
||
| 20 |
- #' `by_visit = TRUE` and `no_fillin_visits = c("SCREENING", "BASELINE")`.
+ #' |
||
| 21 |
- #'+ #' @examples |
||
| 22 |
- #' @details In the result data missing records will be created for the following situations:+ #' control_incidence_rate(0.9, "exact", "month", 100) |
||
| 23 |
- #' * Patients who are present in `adsl` but have no lab data in `adlb` (both baseline and post-baseline).+ #' |
||
| 24 |
- #' * Patients who do not have any post-baseline lab values.+ #' @export |
||
| 25 |
- #' * Patients without any post-baseline values flagged as the worst.+ control_incidence_rate <- function(conf_level = 0.95, |
||
| 26 |
- #'+ conf_type = c("normal", "normal_log", "exact", "byar"),
|
||
| 27 |
- #' @examples+ input_time_unit = c("year", "day", "week", "month"),
|
||
| 28 |
- #' # `h_adsl_adlb_merge_using_worst_flag`+ num_pt_year = 100, |
||
| 29 |
- #' adlb_out <- h_adsl_adlb_merge_using_worst_flag(+ time_unit_input = lifecycle::deprecated(), |
||
| 30 |
- #' tern_ex_adsl,+ time_unit_output = lifecycle::deprecated()) {
|
||
| 31 | -+ | 8x |
- #' tern_ex_adlb,+ if (lifecycle::is_present(time_unit_input)) {
|
| 32 | -+ | ! |
- #' worst_flag = c("WGRHIFL" = "Y")
+ lifecycle::deprecate_warn( |
| 33 | -+ | ! |
- #' )+ "0.8.3", "control_incidence_rate(time_unit_input)", "control_incidence_rate(input_time_unit)" |
| 34 |
- #'+ ) |
||
| 35 | -+ | ! |
- #' # `h_adsl_adlb_merge_using_worst_flag` by visit example+ input_time_unit <- time_unit_input |
| 36 |
- #' adlb_out_by_visit <- h_adsl_adlb_merge_using_worst_flag(+ } |
||
| 37 | -+ | 8x |
- #' tern_ex_adsl,+ if (lifecycle::is_present(time_unit_output)) {
|
| 38 | -+ | ! |
- #' tern_ex_adlb,+ lifecycle::deprecate_warn( |
| 39 | -+ | ! |
- #' worst_flag = c("WGRLOVFL" = "Y"),
+ "0.8.3", "control_incidence_rate(time_unit_output)", "control_incidence_rate(num_pt_year)" |
| 40 |
- #' by_visit = TRUE+ ) |
||
| 41 | -+ | ! |
- #' )+ num_pt_year <- time_unit_output |
| 42 |
- #'+ } |
||
| 43 |
- #' @export+ |
||
| 44 | -+ | 8x |
- h_adsl_adlb_merge_using_worst_flag <- function(adsl, # nolint+ conf_type <- match.arg(conf_type) |
| 45 | -+ | 7x |
- adlb,+ input_time_unit <- match.arg(input_time_unit) |
| 46 | -+ | 6x |
- worst_flag = c("WGRHIFL" = "Y"),
+ checkmate::assert_number(num_pt_year) |
| 47 | -+ | 5x |
- by_visit = FALSE,+ assert_proportion_value(conf_level) |
| 48 |
- no_fillin_visits = c("SCREENING", "BASELINE")) {
+
|
||
| 49 | -5x | +4x |
- col_names <- names(worst_flag)+ list( |
| 50 | -5x | +4x |
- filter_values <- worst_flag+ conf_level = conf_level, |
| 51 | -+ | 4x |
-
+ conf_type = conf_type, |
| 52 | -5x | +4x |
- temp <- Map(+ input_time_unit = input_time_unit, |
| 53 | -5x | +4x |
- function(x, y) which(adlb[[x]] == y),+ num_pt_year = num_pt_year |
| 54 | -5x | +
- col_names,+ ) |
|
| 55 | -5x | +
- filter_values+ } |
| 56 | +1 |
- )+ #' Subgroup Treatment Effect Pattern (STEP) Fit for Binary (Response) Outcome |
|
| 57 | +2 | - - | -|
| 58 | -5x | -
- position_satisfy_filters <- Reduce(intersect, temp)+ #' |
|
| 59 | +3 | - - | -|
| 60 | -5x | -
- adsl_adlb_common_columns <- intersect(colnames(adsl), colnames(adlb))- |
- |
| 61 | -5x | -
- columns_from_adlb <- c("USUBJID", "PARAM", "PARAMCD", "AVISIT", "AVISITN", "ATOXGR", "BTOXGR")
+ #' @description `r lifecycle::badge("stable")`
|
|
| 62 | +4 | - - | -|
| 63 | -5x | -
- adlb_f <- adlb[position_satisfy_filters, ] %>%- |
- |
| 64 | -5x | -
- dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits)- |
- |
| 65 | -5x | -
- adlb_f <- adlb_f[, columns_from_adlb]+ #' |
|
| 66 | +5 | - - | -|
| 67 | -5x | -
- avisits_grid <- adlb %>%+ #' This fits the Subgroup Treatment Effect Pattern logistic regression models for a binary |
|
| 68 | -5x | +||
| 6 | +
- dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) %>%+ #' (response) outcome. The treatment arm variable must have exactly 2 levels, |
||
| 69 | -5x | +||
| 7 | +
- dplyr::pull(.data[["AVISIT"]]) %>%+ #' where the first one is taken as reference and the estimated odds ratios are |
||
| 70 | -5x | +||
| 8 | +
- unique()+ #' for the comparison of the second level vs. the first one. |
||
| 71 | +9 |
-
+ #' |
|
| 72 | -5x | +||
| 10 | +
- if (by_visit) {
+ #' The (conditional) logistic regression model which is fit is: |
||
| 73 | -1x | +||
| 11 | +
- adsl_lb <- expand.grid(+ #' |
||
| 74 | -1x | +||
| 12 | +
- USUBJID = unique(adsl$USUBJID),+ #' `response ~ arm * poly(biomarker, degree) + covariates + strata(strata)` |
||
| 75 | -1x | +||
| 13 | +
- AVISIT = avisits_grid,+ #' |
||
| 76 | -1x | +||
| 14 | +
- PARAMCD = unique(adlb$PARAMCD)+ #' where `degree` is specified by `control_step()`. |
||
| 77 | +15 |
- )+ #' |
|
| 78 | +16 |
-
+ #' @inheritParams argument_convention |
|
| 79 | -1x | +||
| 17 | +
- adsl_lb <- adsl_lb %>%+ #' @param variables (named `list` of `character`)\cr list of analysis variables: |
||
| 80 | -1x | +||
| 18 | +
- dplyr::left_join(unique(adlb[c("AVISIT", "AVISITN")]), by = "AVISIT") %>%
+ #' needs `response`, `arm`, `biomarker`, and optional `covariates` and `strata`. |
||
| 81 | -1x | +||
| 19 | +
- dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
+ #' @param control (named `list`)\cr combined control list from [control_step()] |
||
| 82 | +20 |
-
+ #' and [control_logistic()]. |
|
| 83 | -1x | +||
| 21 | +
- adsl1 <- adsl[, adsl_adlb_common_columns]+ #' |
||
| 84 | -1x | +||
| 22 | +
- adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID")+ #' @return A matrix of class `step`. The first part of the columns describe the |
||
| 85 | +23 |
-
+ #' subgroup intervals used for the biomarker variable, including where the |
|
| 86 | -1x | +||
| 24 | +
- by_variables_from_adlb <- c("USUBJID", "AVISIT", "AVISITN", "PARAMCD", "PARAM")
+ #' center of the intervals are and their bounds. The second part of the |
||
| 87 | +25 |
-
+ #' columns contain the estimates for the treatment arm comparison. |
|
| 88 | -1x | +||
| 26 | +
- adlb_btoxgr <- adlb %>%+ #' |
||
| 89 | -1x | +||
| 27 | +
- dplyr::select(c("USUBJID", "PARAMCD", "BTOXGR")) %>%
+ #' @note For the default degree 0 the `biomarker` variable is not included in the model. |
||
| 90 | -1x | +||
| 28 | +
- unique() %>%+ #' |
||
| 91 | -1x | +||
| 29 | +
- dplyr::rename("BTOXGR_MAP" = "BTOXGR")
+ #' @seealso [control_step()] and [control_logistic()] for the available |
||
| 92 | +30 |
-
+ #' customization options. |
|
| 93 | -1x | +||
| 31 | +
- adlb_out <- merge(+ #' |
||
| 94 | -1x | +||
| 32 | +
- adlb_f,+ #' @examples |
||
| 95 | -1x | +||
| 33 | +
- adsl_lb,+ #' # Testing dataset with just two treatment arms. |
||
| 96 | -1x | +||
| 34 | +
- by = by_variables_from_adlb,+ #' library(survival) |
||
| 97 | -1x | +||
| 35 | +
- all = TRUE,+ #' library(dplyr) |
||
| 98 | -1x | +||
| 36 | +
- sort = FALSE+ #' |
||
| 99 | +37 |
- )+ #' adrs_f <- tern_ex_adrs %>% |
|
| 100 | -1x | +||
| 38 | +
- adlb_out <- adlb_out %>%+ #' filter( |
||
| 101 | -1x | +||
| 39 | +
- dplyr::left_join(adlb_btoxgr, by = c("USUBJID", "PARAMCD")) %>%
+ #' PARAMCD == "BESRSPI", |
||
| 102 | -1x | +||
| 40 | +
- dplyr::mutate(BTOXGR = .data$BTOXGR_MAP) %>%+ #' ARM %in% c("B: Placebo", "A: Drug X")
|
||
| 103 | -1x | +||
| 41 | +
- dplyr::select(-"BTOXGR_MAP")+ #' ) %>% |
||
| 104 | +42 |
-
+ #' mutate( |
|
| 105 | -1x | +||
| 43 | +
- adlb_var_labels <- c(+ #' # Reorder levels of ARM to have Placebo as reference arm for Odds Ratio calculations. |
||
| 106 | -1x | +||
| 44 | +
- formatters::var_labels(adlb[by_variables_from_adlb]),+ #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")), |
||
| 107 | -1x | +||
| 45 | +
- formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]),+ #' RSP = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
||
| 108 | -1x | +||
| 46 | +
- formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]])+ #' SEX = factor(SEX) |
||
| 109 | +47 |
- )+ #' ) |
|
| 110 | +48 |
- } else {
+ #' |
|
| 111 | -4x | +||
| 49 | +
- adsl_lb <- expand.grid(+ #' variables <- list( |
||
| 112 | -4x | +||
| 50 | +
- USUBJID = unique(adsl$USUBJID),+ #' arm = "ARM", |
||
| 113 | -4x | +||
| 51 | +
- PARAMCD = unique(adlb$PARAMCD)+ #' biomarker = "BMRKR1", |
||
| 114 | +52 |
- )+ #' covariates = "AGE", |
|
| 115 | +53 |
-
+ #' response = "RSP" |
|
| 116 | -4x | +||
| 54 | +
- adsl_lb <- adsl_lb %>% dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
+ #' ) |
||
| 117 | +55 |
-
+ #' |
|
| 118 | -4x | +||
| 56 | +
- adsl1 <- adsl[, adsl_adlb_common_columns]+ #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup. |
||
| 119 | -4x | +||
| 57 | +
- adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID")+ #' # We use a large enough bandwidth to avoid too small subgroups and linear separation in those. |
||
| 120 | +58 |
-
+ #' step_matrix <- fit_rsp_step( |
|
| 121 | -4x | +||
| 59 | +
- by_variables_from_adlb <- c("USUBJID", "PARAMCD", "PARAM")
+ #' variables = variables, |
||
| 122 | +60 |
-
+ #' data = adrs_f, |
|
| 123 | -4x | +||
| 61 | +
- adlb_out <- merge(+ #' control = c(control_logistic(), control_step(bandwidth = 0.5)) |
||
| 124 | -4x | +||
| 62 | +
- adlb_f,+ #' ) |
||
| 125 | -4x | +||
| 63 | +
- adsl_lb,+ #' dim(step_matrix) |
||
| 126 | -4x | +||
| 64 | +
- by = by_variables_from_adlb,+ #' head(step_matrix) |
||
| 127 | -4x | +||
| 65 | +
- all = TRUE,+ #' |
||
| 128 | -4x | +||
| 66 | +
- sort = FALSE+ #' # Specify different polynomial degree for the biomarker interaction to use more flexible local |
||
| 129 | +67 |
- )+ #' # models. Or specify different logistic regression options, including confidence level. |
|
| 130 | +68 |
-
+ #' step_matrix2 <- fit_rsp_step( |
|
| 131 | -4x | +||
| 69 | +
- adlb_var_labels <- c(+ #' variables = variables, |
||
| 132 | -4x | +||
| 70 | +
- formatters::var_labels(adlb[by_variables_from_adlb]),+ #' data = adrs_f, |
||
| 133 | -4x | +||
| 71 | +
- formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]),+ #' control = c(control_logistic(conf_level = 0.9), control_step(bandwidth = 0.6, degree = 1)) |
||
| 134 | -4x | +||
| 72 | +
- formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]])+ #' ) |
||
| 135 | +73 |
- )+ #' |
|
| 136 | +74 |
- }+ #' # Use a global constant model. This is helpful as a reference for the subgroup models. |
|
| 137 | +75 |
-
+ #' step_matrix3 <- fit_rsp_step( |
|
| 138 | -5x | +||
| 76 | +
- adlb_out$ATOXGR <- as.factor(adlb_out$ATOXGR)+ #' variables = variables, |
||
| 139 | -5x | +||
| 77 | +
- adlb_out$BTOXGR <- as.factor(adlb_out$BTOXGR)+ #' data = adrs_f, |
||
| 140 | +78 |
-
+ #' control = c(control_logistic(), control_step(bandwidth = NULL, num_points = 2L)) |
|
| 141 | -5x | +||
| 79 | +
- formatters::var_labels(adlb_out) <- adlb_var_labels+ #' ) |
||
| 142 | +80 |
-
+ #' |
|
| 143 | -5x | +||
| 81 | +
- adlb_out+ #' # It is also possible to use strata, i.e. use conditional logistic regression models. |
||
| 144 | +82 |
- }+ #' variables2 <- list( |
| 1 | +83 |
- #' Sort Data by `PK PARAM` Variable+ #' arm = "ARM", |
||
| 2 | +84 |
- #'+ #' biomarker = "BMRKR1", |
||
| 3 | +85 |
- #' @description `r lifecycle::badge("stable")`
+ #' covariates = "AGE", |
||
| 4 | +86 |
- #'+ #' response = "RSP", |
||
| 5 | +87 |
- #' @param pk_data (`data.frame`)\cr `Pharmacokinetics` dataframe+ #' strata = c("STRATA1", "STRATA2")
|
||
| 6 | +88 |
- #' @param key_var (`character`)\cr key variable used to merge pk_data and metadata created by `d_pkparam()`+ #' ) |
||
| 7 | +89 |
#' |
||
| 8 | +90 |
- #' @return A PK `data.frame` sorted by a `PARAM` variable.+ #' step_matrix4 <- fit_rsp_step( |
||
| 9 | +91 |
- #'+ #' variables = variables2, |
||
| 10 | +92 |
- #' @examples+ #' data = adrs_f, |
||
| 11 | +93 |
- #' library(dplyr)+ #' control = c(control_logistic(), control_step(bandwidth = 0.6)) |
||
| 12 | +94 |
- #'+ #' ) |
||
| 13 | +95 |
- #' adpp <- tern_ex_adpp %>% mutate(PKPARAM = factor(paste0(PARAM, " (", AVALU, ")")))
+ #' |
||
| 14 | +96 |
- #' pk_ordered_data <- h_pkparam_sort(adpp)+ #' @export |
||
| 15 | +97 |
- #'+ fit_rsp_step <- function(variables, |
||
| 16 | +98 |
- #' @export+ data, |
||
| 17 | +99 |
- h_pkparam_sort <- function(pk_data, key_var = "PARAMCD") {
+ control = c(control_step(), control_logistic())) {
|
||
| 18 | -4x | +100 | +5x |
- assert_df_with_variables(pk_data, list(key_var = key_var))+ assert_df_with_variables(data, variables) |
| 19 | -4x | +101 | +5x |
- pk_data$PARAMCD <- pk_data[[key_var]]+ checkmate::assert_list(control, names = "named") |
| 20 | -+ | |||
| 102 | +5x |
-
+ data <- data[!is.na(data[[variables$biomarker]]), ] |
||
| 21 | -4x | +103 | +5x |
- ordered_pk_data <- d_pkparam()+ window_sel <- h_step_window(x = data[[variables$biomarker]], control = control) |
| 22 | -+ | |||
| 104 | +5x |
-
+ interval_center <- window_sel$interval[, "Interval Center"] |
||
| 23 | -+ | |||
| 105 | +5x |
- # Add the numeric values from ordered_pk_data to pk_data+ form <- h_step_rsp_formula(variables = variables, control = control) |
||
| 24 | -4x | +106 | +5x |
- joined_data <- merge(pk_data, ordered_pk_data, by = "PARAMCD", suffix = c("", ".y"))
+ estimates <- if (is.null(control$bandwidth)) {
|
| 25 | -+ | |||
| 107 | +1x |
-
+ h_step_rsp_est( |
||
| 26 | -4x | +108 | +1x |
- joined_data <- joined_data[, -grep(".*.y$", colnames(joined_data))]
+ formula = form, |
| 27 | -+ | |||
| 109 | +1x |
-
+ data = data, |
||
| 28 | -4x | +110 | +1x |
- joined_data$TLG_ORDER <- as.numeric(joined_data$TLG_ORDER)+ variables = variables,+ |
+
| 111 | +1x | +
+ x = interval_center,+ |
+ ||
| 112 | +1x | +
+ control = control |
||
| 29 | +113 |
-
+ ) |
||
| 30 | +114 |
- # Then order PARAM based on this column+ } else {
|
||
| 31 | +115 | 4x |
- joined_data$PARAM <- factor(joined_data$PARAM,+ tmp <- mapply( |
|
| 32 | +116 | 4x |
- levels = unique(joined_data$PARAM[order(joined_data$TLG_ORDER)]),+ FUN = h_step_rsp_est, |
|
| 33 | +117 | 4x |
- ordered = TRUE+ x = interval_center, |
|
| 34 | -+ | |||
| 118 | +4x |
- )+ subset = as.list(as.data.frame(window_sel$sel)), |
||
| 35 | -+ | |||
| 119 | +4x |
-
+ MoreArgs = list( |
||
| 36 | +120 | 4x |
- joined_data$TLG_DISPLAY <- factor(joined_data$TLG_DISPLAY,+ formula = form, |
|
| 37 | +121 | 4x |
- levels = unique(joined_data$TLG_DISPLAY[order(joined_data$TLG_ORDER)]),+ data = data, |
|
| 38 | +122 | 4x |
- ordered = TRUE+ variables = variables,+ |
+ |
| 123 | +4x | +
+ control = control |
||
| 39 | +124 |
- )+ ) |
||
| 40 | +125 |
-
+ )+ |
+ ||
| 126 | ++ |
+ # Maybe we find a more elegant solution than this. |
||
| 41 | +127 | 4x |
- joined_data+ rownames(tmp) <- c("n", "logor", "se", "ci_lower", "ci_upper")
+ |
+ |
| 128 | +4x | +
+ t(tmp) |
||
| 42 | +129 | ++ |
+ }+ |
+ |
| 130 | +5x | +
+ result <- cbind(window_sel$interval, estimates)+ |
+ ||
| 131 | +5x | +
+ structure(+ |
+ ||
| 132 | +5x | +
+ result,+ |
+ ||
| 133 | +5x | +
+ class = c("step", "matrix"),
+ |
+ ||
| 134 | +5x | +
+ variables = variables,+ |
+ ||
| 135 | +5x | +
+ control = control+ |
+ ||
| 136 | ++ |
+ )+ |
+ ||
| 137 |
}@@ -169256,14 +170145,14 @@ tern coverage - 94.83% |
| 1 |
- #' Control Function for `CoxPH` Model+ #' Helper Function for Tabulation of a Single Biomarker Result |
||
| 5 |
- #' This is an auxiliary function for controlling arguments for `CoxPH` model, typically used internally to specify+ #' Please see [h_tab_surv_one_biomarker()] and [h_tab_rsp_one_biomarker()], which use this function for examples. |
||
| 6 |
- #' details of `CoxPH` model for [s_coxph_pairwise()]. `conf_level` refers to Hazard Ratio estimation.+ #' This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 9 |
- #' @param pval_method (`string`)\cr p-value method for testing hazard ratio = 1.+ #' @param df (`data.frame`)\cr results for a single biomarker. |
||
| 10 |
- #' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`.+ #' @param afuns (named `list` of `function`)\cr analysis functions. |
||
| 11 |
- #' @param ties (`string`)\cr specifying the method for tie handling. Default is `"efron"`,+ #' @param colvars (`list` with `vars` and `labels`)\cr variables to tabulate and their labels. |
||
| 12 |
- #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()].+ #' |
||
| 13 |
- #'+ #' @return An `rtables` table object with statistics in columns. |
||
| 14 |
- #' @return A list of components with the same names as the arguments+ #' |
||
| 15 |
- #'+ #' @export |
||
| 16 |
- #' @export+ h_tab_one_biomarker <- function(df, |
||
| 17 |
- control_coxph <- function(pval_method = c("log-rank", "wald", "likelihood"),
+ afuns, |
||
| 18 |
- ties = c("efron", "breslow", "exact"),
+ colvars, |
||
| 19 |
- conf_level = 0.95) {
+ na_str = NA_character_, |
||
| 20 | -40x | +
- pval_method <- match.arg(pval_method)+ .indent_mods = 0L) {
|
|
| 21 | -39x | +12x |
- ties <- match.arg(ties)+ lyt <- basic_table() |
| 22 | -39x | +
- assert_proportion_value(conf_level)+ |
|
| 23 |
-
+ # Row split by row type - only keep the content rows here. |
||
| 24 | -38x | +12x |
- list(pval_method = pval_method, ties = ties, conf_level = conf_level)+ lyt <- split_rows_by( |
| 25 | -+ | 12x |
- }+ lyt = lyt, |
| 26 | -+ | 12x |
-
+ var = "row_type", |
| 27 | -+ | 12x |
- #' Control Function for `survfit` Model for Survival Time+ split_fun = keep_split_levels("content"),
|
| 28 | -+ | 12x |
- #'+ nested = FALSE |
| 29 |
- #' @description `r lifecycle::badge("stable")`
+ ) |
||
| 30 |
- #'+ |
||
| 31 |
- #' This is an auxiliary function for controlling arguments for `survfit` model, typically used internally to specify+ # Summarize rows with all patients. |
||
| 32 | -+ | 12x |
- #' details of `survfit` model for [s_surv_time()]. `conf_level` refers to survival time estimation.+ lyt <- summarize_row_groups( |
| 33 | -+ | 12x |
- #'+ lyt = lyt, |
| 34 | -+ | 12x |
- #' @inheritParams argument_convention+ var = "var_label", |
| 35 | -+ | 12x |
- #' @param conf_type (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log",+ cfun = afuns, |
| 36 | -+ | 12x |
- #' see more in [survival::survfit()]. Note option "none" is no longer supported.+ na_str = na_str, |
| 37 | -+ | 12x |
- #' @param quantiles (`numeric`)\cr of length two to specify the quantiles of survival time.+ indent_mod = .indent_mods |
| 38 |
- #'+ ) |
||
| 39 |
- #' @return A list of components with the same names as the arguments+ |
||
| 40 |
- #'+ # Split cols by the multiple variables to populate into columns. |
||
| 41 | -+ | 12x |
- #' @export+ lyt <- split_cols_by_multivar( |
| 42 | -+ | 12x |
- control_surv_time <- function(conf_level = 0.95,+ lyt = lyt, |
| 43 | -+ | 12x |
- conf_type = c("plain", "log", "log-log"),
+ vars = colvars$vars, |
| 44 | -+ | 12x |
- quantiles = c(0.25, 0.75)) {
+ varlabels = colvars$labels |
| 45 | -154x | +
- conf_type <- match.arg(conf_type)+ ) |
|
| 46 | -153x | +
- checkmate::assert_numeric(quantiles, lower = 0, upper = 1, len = 2, unique = TRUE, sorted = TRUE)+ |
|
| 47 | -152x | +
- nullo <- lapply(quantiles, assert_proportion_value)+ # If there is any subgroup variables, we extend the layout accordingly. |
|
| 48 | -152x | +12x |
- assert_proportion_value(conf_level)+ if ("analysis" %in% df$row_type) {
|
| 49 | -151x | +
- list(conf_level = conf_level, conf_type = conf_type, quantiles = quantiles)+ # Now only continue with the subgroup rows. |
|
| 50 | -+ | 4x |
- }+ lyt <- split_rows_by( |
| 51 | -+ | 4x |
-
+ lyt = lyt, |
| 52 | -+ | 4x |
- #' Control Function for `survfit` Model for Patient's Survival Rate at time point+ var = "row_type", |
| 53 | -+ | 4x |
- #'+ split_fun = keep_split_levels("analysis"),
|
| 54 | -+ | 4x |
- #' @description `r lifecycle::badge("stable")`
+ nested = FALSE, |
| 55 | -+ | 4x |
- #'+ child_labels = "hidden" |
| 56 |
- #' This is an auxiliary function for controlling arguments for `survfit` model, typically used internally to specify+ ) |
||
| 57 |
- #' details of `survfit` model for [s_surv_timepoint()]. `conf_level` refers to patient risk estimation at a time point.+ |
||
| 58 |
- #'+ # Split by the subgroup variable. |
||
| 59 | -+ | 4x |
- #' @inheritParams argument_convention+ lyt <- split_rows_by( |
| 60 | -+ | 4x |
- #' @inheritParams control_surv_time+ lyt = lyt, |
| 61 | -+ | 4x |
- #'+ var = "var", |
| 62 | -+ | 4x |
- #' @return A list of components with the same names as the arguments+ labels_var = "var_label", |
| 63 | -+ | 4x |
- #'+ nested = TRUE, |
| 64 | -+ | 4x |
- #' @export+ child_labels = "visible", |
| 65 | -+ | 4x |
- control_surv_timepoint <- function(conf_level = 0.95,+ indent_mod = .indent_mods * 2 |
| 66 |
- conf_type = c("plain", "log", "log-log")) {
+ ) |
||
| 67 | -30x | +
- conf_type <- match.arg(conf_type)+ |
|
| 68 | -29x | +
- assert_proportion_value(conf_level)+ # Then analyze colvars for each subgroup. |
|
| 69 | -28x | +4x |
- list(+ lyt <- summarize_row_groups( |
| 70 | -28x | +4x |
- conf_level = conf_level,+ lyt = lyt, |
| 71 | -28x | +4x |
- conf_type = conf_type+ cfun = afuns, |
| 72 | +4x | +
+ var = "subgroup",+ |
+ |
| 73 | +4x | +
+ na_str = na_str+ |
+ |
| 74 |
- )+ ) |
||
| 73 | +75 | ++ |
+ }+ |
+
| 76 | +12x | +
+ build_table(lyt, df = df)+ |
+ |
| 77 |
}@@ -169773,14 +170690,14 @@ tern coverage - 94.83% |
| 1 |
- #' Counting Specific Values+ #' Summarize the Change from Baseline or Absolute Baseline Values |
||
| 5 |
- #' We can count the occurrence of specific values in a variable of interest.+ #' The primary analysis variable `.var` indicates the numerical change from baseline results, |
||
| 6 |
- #'+ #' and additional required secondary analysis variables are `value` and `baseline_flag`. |
||
| 7 |
- #' @inheritParams argument_convention+ #' Depending on the baseline flag, either the absolute baseline values (at baseline) |
||
| 8 |
- #'+ #' or the change from baseline values (post-baseline) are then summarized. |
||
| 9 |
- #' @note+ #' |
||
| 10 |
- #' * For `factor` variables, `s_count_values` checks whether `values` are all included in the levels of `x`+ #' @inheritParams argument_convention |
||
| 11 |
- #' and fails otherwise.+ #' |
||
| 12 |
- #' * For `count_values()`, variable labels are shown when there is more than one element in `vars`,+ #' @name summarize_change |
||
| 13 |
- #' otherwise they are hidden.+ NULL |
||
| 14 |
- #'+ |
||
| 15 |
- #' @name count_values_funs+ #' @describeIn summarize_change Statistics function that summarizes baseline or post-baseline visits. |
||
| 16 |
- NULL+ #' |
||
| 17 |
-
+ #' @return |
||
| 18 |
- #' @describeIn count_values_funs S3 generic function to count values.+ #' * `s_change_from_baseline()` returns the same values returned by [s_summary.numeric()]. |
||
| 20 |
- #' @inheritParams s_summary.logical+ #' @note The data in `df` must be either all be from baseline or post-baseline visits. Otherwise |
||
| 21 |
- #' @param values (`character`)\cr specific values that should be counted.+ #' an error will be thrown. |
||
| 23 |
- #' @return+ #' @examples |
||
| 24 |
- #' * `s_count_values()` returns output of [s_summary()] for specified values of a non-numeric variable.+ #' df <- data.frame( |
||
| 25 |
- #'+ #' chg = c(1, 2, 3), |
||
| 26 |
- #' @export+ #' is_bl = c(TRUE, TRUE, TRUE), |
||
| 27 |
- s_count_values <- function(x,+ #' val = c(4, 5, 6) |
||
| 28 |
- values,+ #' ) |
||
| 29 |
- na.rm = TRUE, # nolint+ #' |
||
| 30 |
- .N_col, # nolint+ #' @keywords internal |
||
| 31 |
- .N_row, # nolint+ s_change_from_baseline <- function(df, |
||
| 32 |
- denom = c("n", "N_row", "N_col")) {
+ .var, |
||
| 33 | -110x | +
- UseMethod("s_count_values", x)
+ variables, |
|
| 34 |
- }+ na.rm = TRUE, # nolint |
||
| 35 |
-
+ ...) {
|
||
| 36 | -+ | 4x |
- #' @describeIn count_values_funs Method for `character` class.+ checkmate::assert_numeric(df[[variables$value]]) |
| 37 | -+ | 4x |
- #'+ checkmate::assert_numeric(df[[.var]]) |
| 38 | -+ | 4x |
- #' @method s_count_values character+ checkmate::assert_logical(df[[variables$baseline_flag]]) |
| 39 | -+ | 4x |
- #'+ checkmate::assert_vector(unique(df[[variables$baseline_flag]]), max.len = 1) |
| 40 | -+ | 4x |
- #' @examples+ assert_df_with_variables(df, c(variables, list(chg = .var))) |
| 41 |
- #' # `s_count_values.character`+ |
||
| 42 | -+ | 4x |
- #' s_count_values(x = c("a", "b", "a"), values = "a")
+ combined <- ifelse( |
| 43 | -+ | 4x |
- #' s_count_values(x = c("a", "b", "a", NA, NA), values = "b", na.rm = FALSE)
+ df[[variables$baseline_flag]], |
| 44 | -+ | 4x |
- #'+ df[[variables$value]], |
| 45 | -+ | 4x |
- #' @export+ df[[.var]] |
| 46 |
- s_count_values.character <- function(x,+ ) |
||
| 47 | -+ | 4x |
- values = "Y",+ if (is.logical(combined) && identical(length(combined), 0L)) {
|
| 48 | -+ | 1x |
- na.rm = TRUE, # nolint+ combined <- numeric(0) |
| 49 |
- ...) {
+ } |
||
| 50 | -108x | +4x |
- checkmate::assert_character(values)+ s_summary(combined, na.rm = na.rm, ...) |
| 51 |
-
+ } |
||
| 52 | -108x | +
- if (na.rm) {
+
|
|
| 53 | -108x | +
- x <- x[!is.na(x)]+ #' @describeIn summarize_change Formatted analysis function which is used as `afun` in `summarize_change()`. |
|
| 54 |
- }+ #' |
||
| 55 |
-
+ #' @return |
||
| 56 | -108x | +
- is_in_values <- x %in% values+ #' * `a_change_from_baseline()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 57 |
-
+ #' |
||
| 58 | -108x | +
- s_summary(is_in_values, ...)+ #' |
|
| 59 |
- }+ #' @keywords internal |
||
| 60 |
-
+ a_change_from_baseline <- make_afun( |
||
| 61 |
- #' @describeIn count_values_funs Method for `factor` class. This makes an automatic+ s_change_from_baseline, |
||
| 62 |
- #' conversion to `character` and then forwards to the method for characters.+ .formats = c( |
||
| 63 |
- #'+ n = "xx", |
||
| 64 |
- #' @method s_count_values factor+ mean_sd = "xx.xx (xx.xx)", |
||
| 65 |
- #'+ mean_se = "xx.xx (xx.xx)", |
||
| 66 |
- #' @examples+ median = "xx.xx", |
||
| 67 |
- #' # `s_count_values.factor`+ range = "xx.xx - xx.xx", |
||
| 68 |
- #' s_count_values(x = factor(c("a", "b", "a")), values = "a")
+ mean_ci = "(xx.xx, xx.xx)", |
||
| 69 |
- #'+ median_ci = "(xx.xx, xx.xx)", |
||
| 70 |
- #' @export+ mean_pval = "xx.xx" |
||
| 71 |
- s_count_values.factor <- function(x,+ ), |
||
| 72 |
- values = "Y",+ .labels = c( |
||
| 73 |
- ...) {
+ mean_sd = "Mean (SD)", |
||
| 74 | -3x | +
- s_count_values(as.character(x), values = as.character(values), ...)+ mean_se = "Mean (SE)", |
|
| 75 |
- }+ median = "Median", |
||
| 76 |
-
+ range = "Min - Max" |
||
| 77 |
- #' @describeIn count_values_funs Method for `logical` class.+ ) |
||
| 78 |
- #'+ ) |
||
| 79 |
- #' @method s_count_values logical+ |
||
| 80 |
- #'+ #' @describeIn summarize_change Layout-creating function which can take statistics function arguments |
||
| 81 |
- #' @examples+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 82 |
- #' # `s_count_values.logical`+ #' |
||
| 83 |
- #' s_count_values(x = c(TRUE, FALSE, TRUE))+ #' @return |
||
| 84 |
- #'+ #' * `summarize_change()` returns a layout object suitable for passing to further layouting functions, |
||
| 85 |
- #' @export+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 86 |
- s_count_values.logical <- function(x, values = TRUE, ...) {
+ #' the statistics from `s_change_from_baseline()` to the table layout. |
||
| 87 | -3x | +
- checkmate::assert_logical(values)+ #' |
|
| 88 | -3x | +
- s_count_values(as.character(x), values = as.character(values), ...)+ #' @note To be used after a split on visits in the layout, such that each data subset only contains |
|
| 89 |
- }+ #' either baseline or post-baseline data. |
||
| 90 |
-
+ #' |
||
| 91 |
- #' @describeIn count_values_funs Formatted analysis function which is used as `afun`+ #' @examples |
||
| 92 |
- #' in `count_values()`.+ #' # `summarize_change()` |
||
| 94 |
- #' @return+ #' ## Fabricated dataset. |
||
| 95 |
- #' * `a_count_values()` returns the corresponding list with formatted [rtables::CellValue()].+ #' library(dplyr) |
||
| 97 |
- #' @examples+ #' dta_test <- data.frame( |
||
| 98 |
- #' # `a_count_values`+ #' USUBJID = rep(1:6, each = 3), |
||
| 99 |
- #' a_count_values(x = factor(c("a", "b", "a")), values = "a", .N_col = 10, .N_row = 10)
+ #' AVISIT = rep(paste0("V", 1:3), 6),
|
||
| 100 |
- #'+ #' ARM = rep(LETTERS[1:3], rep(6, 3)), |
||
| 101 |
- #' @export+ #' AVAL = c(9:1, rep(NA, 9)) |
||
| 102 |
- a_count_values <- make_afun(+ #' ) %>% |
||
| 103 |
- s_count_values,+ #' mutate(ABLFLL = AVISIT == "V1") %>% |
||
| 104 |
- .formats = c(count_fraction = "xx (xx.xx%)", count = "xx")+ #' group_by(USUBJID) %>% |
||
| 105 |
- )+ #' mutate( |
||
| 106 |
-
+ #' BLVAL = AVAL[ABLFLL], |
||
| 107 |
- #' @describeIn count_values_funs Layout-creating function which can take statistics function arguments+ #' CHG = AVAL - BLVAL |
||
| 108 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' ) %>% |
||
| 109 |
- #'+ #' ungroup() |
||
| 110 |
- #' @return+ #' |
||
| 111 |
- #' * `count_values()` returns a layout object suitable for passing to further layouting functions,+ #' results <- basic_table() %>% |
||
| 112 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' split_cols_by("ARM") %>%
|
||
| 113 |
- #' the statistics from `s_count_values()` to the table layout.+ #' split_rows_by("AVISIT") %>%
|
||
| 114 |
- #'+ #' summarize_change("CHG", variables = list(value = "AVAL", baseline_flag = "ABLFLL")) %>%
|
||
| 115 |
- #' @examples+ #' build_table(dta_test) |
||
| 116 |
- #' # `count_values`+ #' \donttest{
|
||
| 117 |
- #' basic_table() %>%+ #' Viewer(results) |
||
| 118 |
- #' count_values("Species", values = "setosa") %>%
+ #' } |
||
| 119 |
- #' build_table(iris)+ #' |
||
| 120 |
- #'+ #' @export |
||
| 121 |
- #' @export+ summarize_change <- function(lyt, |
||
| 122 |
- count_values <- function(lyt,+ vars, |
||
| 123 |
- vars,+ na_str = NA_character_, |
||
| 124 |
- values,+ nested = TRUE, |
||
| 125 |
- nested = TRUE,+ ..., |
||
| 126 |
- ...,+ table_names = vars, |
||
| 127 |
- table_names = vars,+ .stats = c("n", "mean_sd", "median", "range"),
|
||
| 128 |
- .stats = "count_fraction",+ .formats = NULL, |
||
| 129 |
- .formats = NULL,+ .labels = NULL, |
||
| 130 |
- .labels = c(count_fraction = paste(values, collapse = ", ")),+ .indent_mods = NULL) {
|
||
| 131 | -+ | 1x |
- .indent_mods = NULL) {
+ afun <- make_afun( |
| 132 | -3x | +1x |
- afun <- make_afun(+ a_change_from_baseline, |
| 133 | -3x | +1x |
- a_count_values,+ .stats = .stats, |
| 134 | -3x | +1x |
- .stats = .stats,+ .formats = .formats, |
| 135 | -3x | +1x |
- .formats = .formats,+ .labels = .labels, |
| 136 | -3x | +1x |
- .labels = .labels,+ .indent_mods = .indent_mods |
| 137 | -3x | +
- .indent_mods = .indent_mods+ ) |
|
| 138 |
- )+ |
||
| 139 | -3x | +1x |
analyze( |
| 140 | -3x | +1x |
lyt, |
| 141 | -3x | +1x |
vars, |
| 142 | -3x | +1x |
afun = afun, |
| 143 | -3x | +1x |
- nested = nested,+ na_str = na_str, |
| 144 | -3x | +1x |
- extra_args = c(list(values = values), list(...)),+ nested = nested, |
| 145 | -3x | +1x |
- show_labels = ifelse(length(vars) > 1, "visible", "hidden"),+ extra_args = list(...), |
| 146 | -3x | +1x |
table_names = table_names |
diff --git a/main/coverage-report/lib/datatables-binding-0.29/datatables.js b/main/coverage-report/lib/datatables-binding-0.30/datatables.js
similarity index 99%
rename from main/coverage-report/lib/datatables-binding-0.29/datatables.js
rename to main/coverage-report/lib/datatables-binding-0.30/datatables.js
index b930851b0a..d968d8be0d 100644
--- a/main/coverage-report/lib/datatables-binding-0.29/datatables.js
+++ b/main/coverage-report/lib/datatables-binding-0.30/datatables.js
@@ -493,7 +493,9 @@ HTMLWidgets.widget({
$input.parent().hide(); $x.show().trigger('show'); filter[0].selectize.focus();
},
input: function() {
- if ($input.val() === '') filter[0].selectize.setValue([]);
+ var v1 = JSON.stringify(filter[0].selectize.getValue()), v2 = $input.val();
+ if (v1 === '[]') v1 = '';
+ if (v1 !== v2) filter[0].selectize.setValue(v2 === '' ? [] : JSON.parse(v2));
}
});
var $input2 = $x.children('select');
@@ -1398,7 +1400,7 @@ HTMLWidgets.widget({
console.log('The search keyword for column ' + i + ' is undefined')
return;
}
- $(td).find('input').first().val(v);
+ $(td).find('input').first().val(v).trigger('input');
searchColumn(i, v);
});
table.draw();