#' Options are: ``r shQuote(get_stats("analyze_vars_numeric"))``
+ #' Options are: ``r shQuote(get_stats("analyze_vars_numeric"), type = "sh")``
.labels = .labels,+
.labels = .labels %>% .unlist_keep_nulls(),
.indent_mods = .indent_mods+
.indent_mods = .indent_mods %>% .unlist_keep_nulls()
#' Options are: ``r shQuote(get_stats("estimate_odds_ratio"))``
+ #' Options are: ``r shQuote(get_stats("estimate_odds_ratio"), type = "sh")``
| 1 |
- #' Line plot with optional table+ #' Convert `rtable` objects to `ggplot` objects |
||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' @description `r lifecycle::badge("experimental")`
|
||
| 5 |
- #' Line plot with optional table.+ #' Given a [rtables::rtable()] object, performs basic conversion to a [ggplot2::ggplot()] object built using |
||
| 6 |
- #'+ #' functions from the `ggplot2` package. Any table titles and/or footnotes are ignored. |
||
| 7 |
- #' @inheritParams argument_convention+ #' |
||
| 8 |
- #' @param alt_counts_df (`data.frame` or `NULL`)\cr data set that will be used (only)+ #' @param tbl (`VTableTree`)\cr `rtables` table object. |
||
| 9 |
- #' to counts objects in groups for stratification.+ #' @param fontsize (`numeric(1)`)\cr font size. |
||
| 10 |
- #' @param variables (named `character`) vector of variable names in `df` which should include:+ #' @param colwidths (`numeric` or `NULL`)\cr a vector of column widths. Each element's position in |
||
| 11 |
- #' * `x` (`string`)\cr name of x-axis variable.+ #' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths |
||
| 12 |
- #' * `y` (`string`)\cr name of y-axis variable.+ #' are calculated according to maximum number of characters per column. |
||
| 13 |
- #' * `group_var` (`string` or `NULL`)\cr name of grouping variable (or strata), i.e. treatment arm.+ #' @param lbl_col_padding (`numeric`)\cr additional padding to use when calculating spacing between |
||
| 14 |
- #' Can be `NA` to indicate lack of groups.+ #' the first (label) column and the second column of `tbl`. If `colwidths` is specified, |
||
| 15 |
- #' * `subject_var` (`string` or `NULL`)\cr name of subject variable. Only applies if `group_var` is+ #' the width of the first column becomes `colwidths[1] + lbl_col_padding`. Defaults to 0. |
||
| 16 |
- #' not NULL.+ #' |
||
| 17 |
- #' * `paramcd` (`string` or `NA`)\cr name of the variable for parameter's code. Used for y-axis label and plot's+ #' @return A `ggplot` object. |
||
| 18 |
- #' subtitle. Can be `NA` if `paramcd` is not to be added to the y-axis label or subtitle.+ #' |
||
| 19 |
- #' * `y_unit` (`string` or `NA`)\cr name of variable with units of `y`. Used for y-axis label and plot's subtitle.+ #' @examples |
||
| 20 |
- #' Can be `NA` if y unit is not to be added to the y-axis label or subtitle.+ #' dta <- data.frame( |
||
| 21 |
- #' * `facet_var` (`string` or `NA`)\cr name of the secondary grouping variable used for plot faceting, i.e. treatment+ #' ARM = rep(LETTERS[1:3], rep(6, 3)), |
||
| 22 |
- #' arm. Can be `NA` to indicate lack of groups.+ #' AVISIT = rep(paste0("V", 1:3), 6),
|
||
| 23 |
- #' @param mid (`character` or `NULL`)\cr names of the statistics that will be plotted as midpoints.+ #' AVAL = c(9:1, rep(NA, 9)) |
||
| 24 |
- #' All the statistics indicated in `mid` variable must be present in the object returned by `sfun`,+ #' ) |
||
| 25 |
- #' and be of a `double` or `numeric` type vector of length one.+ #' |
||
| 26 |
- #' @param interval (`character` or `NULL`)\cr names of the statistics that will be plotted as intervals.+ #' lyt <- basic_table() %>% |
||
| 27 |
- #' All the statistics indicated in `interval` variable must be present in the object returned by `sfun`,+ #' split_cols_by(var = "ARM") %>% |
||
| 28 |
- #' and be of a `double` or `numeric` type vector of length two. Set `interval = NULL` if intervals should not be+ #' split_rows_by(var = "AVISIT") %>% |
||
| 29 |
- #' added to the plot.+ #' analyze_vars(vars = "AVAL") |
||
| 30 |
- #' @param whiskers (`character`)\cr names of the interval whiskers that will be plotted. Names must match names+ #' |
||
| 31 |
- #' of the list element `interval` that will be returned by `sfun` (e.g. `mean_ci_lwr` element of+ #' tbl <- build_table(lyt, df = dta) |
||
| 32 |
- #' `sfun(x)[["mean_ci"]]`). It is possible to specify one whisker only, or to suppress all whiskers by setting+ #' |
||
| 33 |
- #' `interval = NULL`.+ #' rtable2gg(tbl) |
||
| 34 |
- #' @param table (`character` or `NULL`)\cr names of the statistics that will be displayed in the table below the plot.+ #' |
||
| 35 |
- #' All the statistics indicated in `table` variable must be present in the object returned by `sfun`.+ #' rtable2gg(tbl, fontsize = 15, colwidths = c(2, 1, 1, 1)) |
||
| 36 |
- #' @param sfun (`function`)\cr the function to compute the values of required statistics. It must return a named `list`+ #' |
||
| 37 |
- #' with atomic vectors. The names of the `list` elements refer to the names of the statistics and are used by `mid`,+ #' @export |
||
| 38 |
- #' `interval`, `table`. It must be able to accept as input a vector with data for which statistics are computed.+ rtable2gg <- function(tbl, fontsize = 12, colwidths = NULL, lbl_col_padding = 0) {
|
||
| 39 | -+ | 6x |
- #' @param ... optional arguments to `sfun`.+ mat <- rtables::matrix_form(tbl, indent_rownames = TRUE) |
| 40 | -+ | 6x |
- #' @param mid_type (`string`)\cr controls the type of the `mid` plot, it can be point (`"p"`), line (`"l"`),+ mat_strings <- formatters::mf_strings(mat) |
| 41 | -+ | 6x |
- #' or point and line (`"pl"`).+ mat_aligns <- formatters::mf_aligns(mat) |
| 42 | -+ | 6x |
- #' @param mid_point_size (`numeric(1)`)\cr font size of the `mid` plot points.+ mat_indent <- formatters::mf_rinfo(mat)$indent |
| 43 | -+ | 6x |
- #' @param position (`character` or `call`)\cr geom element position adjustment, either as a string, or the result of+ mat_display <- formatters::mf_display(mat) |
| 44 | -+ | 6x |
- #' a call to a position adjustment function.+ nlines_hdr <- formatters::mf_nlheader(mat) |
| 45 | -+ | 6x |
- #' @param legend_title (`string`)\cr legend title.+ shared_hdr_rows <- which(apply(mat_display, 1, function(x) (any(!x)))) |
| 46 |
- #' @param legend_position (`string`)\cr the position of the plot legend (`"none"`, `"left"`, `"right"`, `"bottom"`,+ |
||
| 47 | -+ | 6x |
- #' `"top"`, or a two-element numeric vector).+ tbl_df <- data.frame(mat_strings) |
| 48 | -+ | 6x |
- #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot.+ body_rows <- seq(nlines_hdr + 1, nrow(tbl_df)) |
| 49 | -+ | 6x |
- #' @param xticks (`numeric` or `NULL`)\cr numeric vector of tick positions or a single number with spacing+ mat_aligns <- apply(mat_aligns, 1:2, function(x) if (x == "left") 0 else if (x == "right") 1 else 0.5) |
| 50 |
- #' between ticks on the x-axis, for use when `variables$x` is numeric. If `NULL` (default), [labeling::extended()] is+ |
||
| 51 |
- #' used to determine optimal tick positions on the x-axis. If `variables$x` is not numeric, this argument is ignored.+ # Apply indentation in first column |
||
| 52 | -+ | 6x |
- #' @param x_lab (`string` or `NULL`)\cr x-axis label. If `NULL` then no label will be added.+ tbl_df[body_rows, 1] <- sapply(body_rows, function(i) {
|
| 53 | -+ | 42x |
- #' @param y_lab (`string` or `NULL`)\cr y-axis label. If `NULL` then no label will be added.+ ind_i <- mat_indent[i - nlines_hdr] * 4 |
| 54 | -+ | 18x |
- #' @param y_lab_add_paramcd (`flag`)\cr whether `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` should be added+ if (ind_i > 0) paste0(paste(rep(" ", ind_i), collapse = ""), tbl_df[i, 1]) else tbl_df[i, 1]
|
| 55 |
- #' to the y-axis label (`y_lab`).+ }) |
||
| 56 |
- #' @param y_lab_add_unit (`flag`)\cr whether y-axis unit, i.e. `unique(df[[variables["y_unit"]]])` should be added+ |
||
| 57 |
- #' to the y-axis label (`y_lab`).+ # Get column widths |
||
| 58 | -+ | 6x |
- #' @param title (`string`)\cr plot title.+ if (is.null(colwidths)) {
|
| 59 | -+ | 6x |
- #' @param subtitle (`string`)\cr plot subtitle.+ colwidths <- apply(tbl_df, 2, function(x) max(nchar(x))) + 1 |
| 60 |
- #' @param subtitle_add_paramcd (`flag`)\cr whether `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` should be+ } |
||
| 61 | -+ | 6x |
- #' added to the plot's subtitle (`subtitle`).+ tot_width <- sum(colwidths) + lbl_col_padding |
| 62 |
- #' @param subtitle_add_unit (`flag`)\cr whether the y-axis unit, i.e. `unique(df[[variables["y_unit"]]])` should be+ |
||
| 63 | -+ | 6x |
- #' added to the plot's subtitle (`subtitle`).+ if (length(shared_hdr_rows) > 0) {
|
| 64 | -+ | 5x |
- #' @param caption (`string`)\cr optional caption below the plot.+ tbl_df <- tbl_df[-shared_hdr_rows, ] |
| 65 | -+ | 5x |
- #' @param table_format (named `character` or `NULL`)\cr format patterns for descriptive statistics used in the+ mat_aligns <- mat_aligns[-shared_hdr_rows, ] |
| 66 |
- #' (optional) table appended to the plot. It is passed directly to the `h_format_row` function through the `format`+ } |
||
| 67 |
- #' parameter. Names of `table_format` must match the names of statistics returned by `sfun` function.+ |
||
| 68 | -+ | 6x |
- #' @param table_labels (named `character` or `NULL`)\cr labels for descriptive statistics used in the (optional) table+ res <- ggplot(data = tbl_df) + |
| 69 | -+ | 6x |
- #' appended to the plot. Names of `table_labels` must match the names of statistics returned by `sfun` function.+ theme_void() + |
| 70 | -+ | 6x |
- #' @param table_font_size (`numeric(1)`)\cr font size of the text in the table.+ scale_x_continuous(limits = c(0, tot_width)) + |
| 71 | -+ | 6x |
- #' @param newpage `r lifecycle::badge("deprecated")` not used.
+ scale_y_continuous(limits = c(0, nrow(mat_strings))) + |
| 72 | -+ | 6x |
- #' @param col (`character`)\cr color(s). See `?ggplot2::aes_colour_fill_alpha` for example values.+ annotate( |
| 73 | -+ | 6x |
- #' @param linetype (`character`)\cr line type(s). See `?ggplot2::aes_linetype_size_shape` for example values.+ "segment", |
| 74 | -+ | 6x |
- #' @param errorbar_width (`numeric(1)`)\cr width of the error bars.+ x = 0, xend = tot_width, |
| 75 | -+ | 6x |
- #' @param rel_height_plot (`proportion`)\cr proportion of total figure height to allocate to the line plot.+ y = nrow(mat_strings) - nlines_hdr + 0.5, yend = nrow(mat_strings) - nlines_hdr + 0.5 |
| 76 |
- #' Relative height of annotation table is then `1 - rel_height_plot`. If `table = NULL`, this parameter is ignored.+ ) |
||
| 77 |
- #' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list when `table` is not `NULL`.+ |
||
| 78 |
- #' If `TRUE`, a named list with two elements, `plot` and `table`, will be returned. If `FALSE` (default) the+ # If header content spans multiple columns, center over these columns |
||
| 79 | -+ | 6x |
- #' annotation table is printed below the plot via [cowplot::plot_grid()].+ if (length(shared_hdr_rows) > 0) {
|
| 80 | -+ | 5x |
- #'+ mat_strings[shared_hdr_rows, ] <- trimws(mat_strings[shared_hdr_rows, ]) |
| 81 | -+ | 5x |
- #' @return A `ggplot` line plot (and statistics table if applicable).+ for (hr in shared_hdr_rows) {
|
| 82 | -+ | 6x |
- #'+ hdr_lbls <- mat_strings[1:hr, mat_display[hr, -1]] |
| 83 | -+ | 6x |
- #' @examples+ hdr_lbls <- matrix(hdr_lbls[nzchar(hdr_lbls)], nrow = hr) |
| 84 | -+ | 6x |
- #'+ for (idx_hl in seq_len(ncol(hdr_lbls))) {
|
| 85 | -+ | 13x |
- #' adsl <- tern_ex_adsl+ cur_lbl <- tail(hdr_lbls[, idx_hl], 1) |
| 86 | -+ | 13x |
- #' adlb <- tern_ex_adlb %>% dplyr::filter(ANL01FL == "Y", PARAMCD == "ALT", AVISIT != "SCREENING")+ which_cols <- if (hr == 1) {
|
| 87 | -+ | 9x |
- #' adlb$AVISIT <- droplevels(adlb$AVISIT)+ which(mat_strings[hr, ] == hdr_lbls[idx_hl]) |
| 88 | -+ | 13x |
- #' adlb <- dplyr::mutate(adlb, AVISIT = forcats::fct_reorder(AVISIT, AVISITN, min))+ } else { # for >2 col splits, only print labels for each unique combo of nested columns
|
| 89 | -+ | 4x |
- #'+ which( |
| 90 | -+ | 4x |
- #' # Mean with CI+ apply(mat_strings[1:hr, ], 2, function(x) all(x == hdr_lbls[1:hr, idx_hl])) |
| 91 |
- #' g_lineplot(adlb, adsl, subtitle = "Laboratory Test:")+ ) |
||
| 92 |
- #'+ } |
||
| 93 | -+ | 13x |
- #' # Mean with CI, no stratification with group_var+ line_pos <- c( |
| 94 | -+ | 13x |
- #' g_lineplot(adlb, variables = control_lineplot_vars(group_var = NA))+ sum(colwidths[1:(which_cols[1] - 1)]) + 1 + lbl_col_padding, |
| 95 | -+ | 13x |
- #'+ sum(colwidths[1:max(which_cols)]) - 1 + lbl_col_padding |
| 96 |
- #' # Mean, upper whisker of CI, no group_var(strata) counts N+ ) |
||
| 97 |
- #' g_lineplot(+ |
||
| 98 | -+ | 13x |
- #' adlb,+ res <- res + |
| 99 | -+ | 13x |
- #' whiskers = "mean_ci_upr",+ annotate( |
| 100 | -+ | 13x |
- #' title = "Plot of Mean and Upper 95% Confidence Limit by Visit"+ "text", |
| 101 | -+ | 13x |
- #' )+ x = mean(line_pos), |
| 102 | -+ | 13x |
- #'+ y = nrow(mat_strings) + 1 - hr, |
| 103 | -+ | 13x |
- #' # Median with CI+ label = cur_lbl, |
| 104 | -+ | 13x |
- #' g_lineplot(+ size = fontsize / .pt |
| 105 |
- #' adlb,+ ) + |
||
| 106 | -+ | 13x |
- #' adsl,+ annotate( |
| 107 | -+ | 13x |
- #' mid = "median",+ "segment", |
| 108 | -+ | 13x |
- #' interval = "median_ci",+ x = line_pos[1], |
| 109 | -+ | 13x |
- #' whiskers = c("median_ci_lwr", "median_ci_upr"),
+ xend = line_pos[2], |
| 110 | -+ | 13x |
- #' title = "Plot of Median and 95% Confidence Limits by Visit"+ y = nrow(mat_strings) - hr + 0.5, |
| 111 | -+ | 13x |
- #' )+ yend = nrow(mat_strings) - hr + 0.5 |
| 112 |
- #'+ ) |
||
| 113 |
- #' # Mean, +/- SD+ } |
||
| 114 |
- #' g_lineplot(adlb, adsl,+ } |
||
| 115 |
- #' interval = "mean_sdi",+ } |
||
| 116 |
- #' whiskers = c("mean_sdi_lwr", "mean_sdi_upr"),
+
|
||
| 117 |
- #' title = "Plot of Median +/- SD by Visit"+ # Add table columns |
||
| 118 | -+ | 6x |
- #' )+ for (i in seq_len(ncol(tbl_df))) {
|
| 119 | -+ | 40x |
- #'+ res <- res + annotate( |
| 120 | -+ | 40x |
- #' # Mean with CI plot with stats table+ "text", |
| 121 | -+ | 40x |
- #' g_lineplot(adlb, adsl, table = c("n", "mean", "mean_ci"))
+ x = if (i == 1) 0 else sum(colwidths[1:i]) - 0.5 * colwidths[i] + lbl_col_padding, |
| 122 | -+ | 40x |
- #'+ y = rev(seq_len(nrow(tbl_df))), |
| 123 | -+ | 40x |
- #' # Mean with CI, table and customized confidence level+ label = tbl_df[, i], |
| 124 | -+ | 40x |
- #' g_lineplot(+ hjust = mat_aligns[, i], |
| 125 | -+ | 40x |
- #' adlb,+ size = fontsize / .pt |
| 126 |
- #' adsl,+ ) |
||
| 127 |
- #' table = c("n", "mean", "mean_ci"),
+ } |
||
| 128 |
- #' control = control_analyze_vars(conf_level = 0.80),+ |
||
| 129 | -+ | 6x |
- #' title = "Plot of Mean and 80% Confidence Limits by Visit"+ res |
| 130 |
- #' )+ } |
||
| 131 |
- #'+ |
||
| 132 |
- #' # Mean with CI, table, filtered data+ #' Convert `data.frame` object to `ggplot` object |
||
| 133 |
- #' adlb_f <- dplyr::filter(adlb, ARMCD != "ARM A" | AVISIT == "BASELINE")+ #' |
||
| 134 |
- #' g_lineplot(adlb_f, table = c("n", "mean"))
+ #' @description `r lifecycle::badge("experimental")`
|
||
| 136 |
- #' @export+ #' Given a `data.frame` object, performs basic conversion to a [ggplot2::ggplot()] object built using |
||
| 137 |
- g_lineplot <- function(df,+ #' functions from the `ggplot2` package. |
||
| 138 |
- alt_counts_df = NULL,+ #' |
||
| 139 |
- variables = control_lineplot_vars(),+ #' @param df (`data.frame`)\cr a data frame. |
||
| 140 |
- mid = "mean",+ #' @param colwidths (`numeric` or `NULL`)\cr a vector of column widths. Each element's position in |
||
| 141 |
- interval = "mean_ci",+ #' `colwidths` corresponds to the column of `df` in the same position. If `NULL`, column widths |
||
| 142 |
- whiskers = c("mean_ci_lwr", "mean_ci_upr"),
+ #' are calculated according to maximum number of characters per column. |
||
| 143 |
- table = NULL,+ #' @param font_size (`numeric(1)`)\cr font size. |
||
| 144 |
- sfun = s_summary,+ #' @param col_labels (`flag`)\cr whether the column names (labels) of `df` should be used as the first row |
||
| 145 |
- ...,+ #' of the output table. |
||
| 146 |
- mid_type = "pl",+ #' @param col_lab_fontface (`string`)\cr font face to apply to the first row (of column labels |
||
| 147 |
- mid_point_size = 2,+ #' if `col_labels = TRUE`). Defaults to `"bold"`. |
||
| 148 |
- position = ggplot2::position_dodge(width = 0.4),+ #' @param hline (`flag`)\cr whether a horizontal line should be printed below the first row of the table. |
||
| 149 |
- legend_title = NULL,+ #' @param bg_fill (`string`)\cr table background fill color. |
||
| 150 |
- legend_position = "bottom",+ #' |
||
| 151 |
- ggtheme = nestcolor::theme_nest(),+ #' @return A `ggplot` object. |
||
| 152 |
- xticks = NULL,+ #' |
||
| 153 |
- xlim = NULL,+ #' @examples |
||
| 154 |
- ylim = NULL,+ #' \dontrun{
|
||
| 155 |
- x_lab = obj_label(df[[variables[["x"]]]]),+ #' df2gg(head(iris, 5)) |
||
| 156 |
- y_lab = NULL,+ #' |
||
| 157 |
- y_lab_add_paramcd = TRUE,+ #' df2gg(head(iris, 5), font_size = 15, colwidths = c(1, 1, 1, 1, 1)) |
||
| 158 |
- y_lab_add_unit = TRUE,+ #' } |
||
| 159 |
- title = "Plot of Mean and 95% Confidence Limits by Visit",+ #' @keywords internal |
||
| 160 |
- subtitle = "",+ df2gg <- function(df, |
||
| 161 |
- subtitle_add_paramcd = TRUE,+ colwidths = NULL, |
||
| 162 |
- subtitle_add_unit = TRUE,+ font_size = 10, |
||
| 163 |
- caption = NULL,+ col_labels = TRUE, |
||
| 164 |
- table_format = NULL,+ col_lab_fontface = "bold", |
||
| 165 |
- table_labels = NULL,+ hline = TRUE, |
||
| 166 |
- table_font_size = 3,+ bg_fill = NULL) {
|
||
| 167 |
- errorbar_width = 0.45,+ # convert to text |
||
| 168 | -+ | 19x |
- newpage = lifecycle::deprecated(),+ df <- as.data.frame(apply(df, 1:2, function(x) if (is.na(x)) "NA" else as.character(x))) |
| 169 |
- col = NULL,+ |
||
| 170 | -+ | 19x |
- linetype = NULL,+ if (col_labels) {
|
| 171 | -+ | 10x |
- rel_height_plot = 0.5,+ df <- as.matrix(df) |
| 172 | -+ | 10x |
- as_list = FALSE) {
+ df <- rbind(colnames(df), df) |
| 173 | -13x | +
- checkmate::assert_character(variables, any.missing = TRUE)+ } |
|
| 174 | -13x | +
- checkmate::assert_character(mid, null.ok = TRUE)+ |
|
| 175 | -13x | +
- checkmate::assert_character(interval, null.ok = TRUE)+ # Get column widths |
|
| 176 | -13x | +19x |
- checkmate::assert_character(col, null.ok = TRUE)+ if (is.null(colwidths)) {
|
| 177 | -13x | +1x |
- checkmate::assert_character(linetype, null.ok = TRUE)+ colwidths <- apply(df, 2, function(x) max(nchar(x), na.rm = TRUE)) |
| 178 | -13x | +
- checkmate::assert_numeric(xticks, null.ok = TRUE)+ } |
|
| 179 | -13x | +19x |
- checkmate::assert_numeric(xlim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE)+ tot_width <- sum(colwidths) |
| 180 | -13x | +
- checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE)+ |
|
| 181 | -13x | +19x |
- checkmate::assert_number(errorbar_width, lower = 0)+ res <- ggplot(data = df) + |
| 182 | -13x | +19x |
- checkmate::assert_string(title, null.ok = TRUE)+ theme_void() + |
| 183 | -13x | +19x |
- checkmate::assert_string(subtitle, null.ok = TRUE)+ scale_x_continuous(limits = c(0, tot_width)) + |
| 184 | -13x | +19x |
- assert_proportion_value(rel_height_plot)+ scale_y_continuous(limits = c(1, nrow(df))) |
| 185 | -13x | +
- checkmate::assert_logical(as_list)+ |
|
| 186 | -+ | 9x |
-
+ if (!is.null(bg_fill)) res <- res + theme(plot.background = element_rect(fill = bg_fill)) |
| 187 | -13x | +
- if (!is.null(table)) {
+
|
|
| 188 | -5x | +19x |
- table_format <- get_formats_from_stats(table)+ if (hline) {
|
| 189 | -5x | +10x |
- table_labels <- get_labels_from_stats(table)+ res <- res + |
| 190 | -+ | 10x |
- }+ annotate( |
| 191 | -+ | 10x |
-
+ "segment", |
| 192 | -13x | +10x |
- extra_args <- list(...)+ x = 0 + 0.2 * colwidths[2], xend = tot_width - 0.1 * tail(colwidths, 1), |
| 193 | -13x | +10x |
- if ("control" %in% names(extra_args)) {
+ y = nrow(df) - 0.5, yend = nrow(df) - 0.5 |
| 194 | -4x | +
- if (!is.null(table) && all(table_labels == get_labels_from_stats(table))) {
+ ) |
|
| 195 | -3x | +
- table_labels <- table_labels %>% labels_use_control(extra_args[["control"]])+ } |
|
| 196 |
- }+ |
||
| 197 | -+ | 19x |
- }+ for (i in seq_len(ncol(df))) {
|
| 198 | -+ | 86x |
-
+ line_pos <- c( |
| 199 | -13x | +86x |
- if (is.character(interval)) {
+ if (i == 1) 0 else sum(colwidths[1:(i - 1)]), |
| 200 | -13x | +86x |
- checkmate::assert_vector(whiskers, min.len = 0, max.len = 2)+ sum(colwidths[1:i]) |
| 201 |
- }+ ) |
||
| 202 | -+ | 86x |
-
+ res <- res + |
| 203 | -13x | +86x |
- if (length(whiskers) == 1) {
+ annotate( |
| 204 | -! | +86x |
- checkmate::assert_character(mid)+ "text", |
| 205 | -+ | 86x |
- }+ x = mean(line_pos), |
| 206 | -+ | 86x |
-
+ y = rev(seq_len(nrow(df))), |
| 207 | -13x | +86x |
- if (is.character(mid)) {
+ label = df[, i], |
| 208 | -13x | +86x |
- checkmate::assert_scalar(mid_type)+ size = font_size / .pt, |
| 209 | -13x | +86x |
- checkmate::assert_subset(mid_type, c("pl", "p", "l"))
+ fontface = if (col_labels) {
|
| 210 | -+ | 32x |
- }+ c(col_lab_fontface, rep("plain", nrow(df) - 1))
|
| 211 |
-
+ } else {
|
||
| 212 | -13x | +54x |
- x <- variables[["x"]]+ rep("plain", nrow(df))
|
| 213 | -13x | +
- y <- variables[["y"]]+ } |
|
| 214 | -13x | +
- paramcd <- variables["paramcd"] # NA if paramcd == NA or it is not in variables+ ) |
|
| 215 | -13x | +
- y_unit <- variables["y_unit"] # NA if y_unit == NA or it is not in variables+ } |
|
| 216 | -13x | +
- if (is.na(variables["group_var"])) {
+
|
|
| 217 | -1x | +19x |
- group_var <- NULL # NULL if group_var == NA or it is not in variables+ res |
| 218 |
- } else {
+ } |
||
| 219 | -12x | +
| 1 | +
- group_var <- variables[["group_var"]]+ #' Cumulative counts of numeric variable by thresholds |
|||
| 220 | -12x | +|||
| 2 | +
- subject_var <- variables[["subject_var"]]+ #' |
|||
| 221 | +3 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 222 | -13x | +|||
| 4 | +
- if (is.na(variables["facet_var"])) {
+ #' |
|||
| 223 | -12x | +|||
| 5 | +
- facet_var <- NULL # NULL if facet_var == NA or it is not in variables+ #' The analyze function [count_cumulative()] creates a layout element to calculate cumulative counts of values in a |
|||
| 224 | +6 |
- } else {
+ #' numeric variable that are less than, less or equal to, greater than, or greater or equal to user-specified |
||
| 225 | -1x | +|||
| 7 | +
- facet_var <- variables[["facet_var"]]+ #' threshold values. |
|||
| 226 | +8 |
- }+ #' |
||
| 227 | -13x | +|||
| 9 | +
- checkmate::assert_flag(y_lab_add_paramcd, null.ok = TRUE)+ #' This function analyzes numeric variable `vars` against the threshold values supplied to the `thresholds` |
|||
| 228 | -13x | +|||
| 10 | +
- checkmate::assert_flag(subtitle_add_paramcd, null.ok = TRUE)+ #' argument as a numeric vector. Whether counts should include the threshold values, and whether to count |
|||
| 229 | -13x | +|||
| 11 | +
- if ((!is.null(y_lab) && y_lab_add_paramcd) || (!is.null(subtitle) && subtitle_add_paramcd)) {
+ #' values lower or higher than the threshold values can be set via the `include_eq` and `lower_tail` |
|||
| 230 | -13x | +|||
| 12 | +
- checkmate::assert_false(is.na(paramcd))+ #' parameters, respectively. |
|||
| 231 | -13x | +|||
| 13 | +
- checkmate::assert_scalar(unique(df[[paramcd]]))+ #' |
|||
| 232 | +14 |
- }+ #' @inheritParams h_count_cumulative |
||
| 233 | +15 |
-
+ #' @inheritParams argument_convention |
||
| 234 | -13x | +|||
| 16 | +
- checkmate::assert_flag(y_lab_add_unit, null.ok = TRUE)+ #' @param thresholds (`numeric`)\cr vector of cutoff values for the counts. |
|||
| 235 | -13x | +|||
| 17 | +
- checkmate::assert_flag(subtitle_add_unit, null.ok = TRUE)+ #' @param .stats (`character`)\cr statistics to select for the table. |
|||
| 236 | -13x | +|||
| 18 | +
- if ((!is.null(y_lab) && y_lab_add_unit) || (!is.null(subtitle) && subtitle_add_unit)) {
+ #' |
|||
| 237 | -13x | +|||
| 19 | +
- checkmate::assert_false(is.na(y_unit))+ #' Options are: ``r shQuote(get_stats("count_cumulative"), type = "sh")``
|
|||
| 238 | -13x | +|||
| 20 | +
- checkmate::assert_scalar(unique(df[[y_unit]]))+ #' |
|||
| 239 | +21 |
- }+ #' @seealso Relevant helper function [h_count_cumulative()], and descriptive function [d_count_cumulative()]. |
||
| 240 | +22 |
-
+ #' |
||
| 241 | -13x | +|||
| 23 | +
- if (!is.null(group_var) && !is.null(alt_counts_df)) {
+ #' @name count_cumulative |
|||
| 242 | -8x | +|||
| 24 | +
- checkmate::assert_set_equal(unique(alt_counts_df[[group_var]]), unique(df[[group_var]]))+ #' @order 1 |
|||
| 243 | +25 |
- }+ NULL |
||
| 244 | +26 | |||
| 245 | +27 |
- ####################################### |+ #' Helper function for `s_count_cumulative()` |
||
| 246 | +28 |
- # ---- Compute required statistics ----+ #' |
||
| 247 | +29 |
- ####################################### |+ #' @description `r lifecycle::badge("stable")`
|
||
| 248 | +30 |
- # Remove unused levels for x-axis+ #' |
||
| 249 | -13x | +|||
| 31 | +
- if (is.factor(df[[x]])) {
+ #' Helper function to calculate count and fraction of `x` values in the lower or upper tail given a threshold. |
|||
| 250 | -12x | +|||
| 32 | +
- df[[x]] <- droplevels(df[[x]])+ #' |
|||
| 251 | +33 |
- }+ #' @inheritParams argument_convention |
||
| 252 | +34 |
-
+ #' @param threshold (`numeric(1)`)\cr a cutoff value as threshold to count values of `x`. |
||
| 253 | -13x | +|||
| 35 | +
- if (!is.null(facet_var) && !is.null(group_var)) {
+ #' @param lower_tail (`flag`)\cr whether to count lower tail, default is `TRUE`. |
|||
| 254 | -1x | +|||
| 36 | +
- df_grp <- tidyr::expand(df, .data[[facet_var]], .data[[group_var]], .data[[x]]) # expand based on levels of factors+ #' @param include_eq (`flag`)\cr whether to include value equal to the `threshold` in |
|||
| 255 | -12x | +|||
| 37 | +
- } else if (!is.null(group_var)) {
+ #' count, default is `TRUE`. |
|||
| 256 | -11x | +|||
| 38 | +
- df_grp <- tidyr::expand(df, .data[[group_var]], .data[[x]]) # expand based on levels of factors+ #' |
|||
| 257 | +39 |
- } else {
+ #' @return A named vector with items: |
||
| 258 | -1x | +|||
| 40 | +
- df_grp <- tidyr::expand(df, NULL, .data[[x]])+ #' * `count`: the count of values less than, less or equal to, greater than, or greater or equal to a threshold |
|||
| 259 | +41 |
- }+ #' of user specification. |
||
| 260 | +42 |
-
+ #' * `fraction`: the fraction of the count. |
||
| 261 | -13x | +|||
| 43 | +
- df_grp <- df_grp %>%+ #' |
|||
| 262 | -13x | +|||
| 44 | +
- dplyr::full_join(y = df[, c(facet_var, group_var, x, y)], by = c(facet_var, group_var, x), multiple = "all") %>%+ #' @seealso [count_cumulative] |
|||
| 263 | -13x | +|||
| 45 | +
- dplyr::group_by_at(c(facet_var, group_var, x))+ #' |
|||
| 264 | +46 |
-
+ #' @examples |
||
| 265 | -13x | +|||
| 47 | +
- df_stats <- df_grp %>%+ #' set.seed(1, kind = "Mersenne-Twister") |
|||
| 266 | -13x | +|||
| 48 | +
- dplyr::summarise(+ #' x <- c(sample(1:10, 10), NA) |
|||
| 267 | -13x | +|||
| 49 | +
- data.frame(t(do.call(c, unname(sfun(.data[[y]])[c(mid, interval)])))),+ #' .N_col <- length(x) |
|||
| 268 | -13x | +|||
| 50 | +
- .groups = "drop"+ #' |
|||
| 269 | +51 |
- )+ #' h_count_cumulative(x, 5, .N_col = .N_col) |
||
| 270 | +52 |
-
+ #' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na.rm = FALSE, .N_col = .N_col) |
||
| 271 | -13x | +|||
| 53 | +
- df_stats <- df_stats[!is.na(df_stats[[mid]]), ]+ #' h_count_cumulative(x, 0, lower_tail = FALSE, .N_col = .N_col) |
|||
| 272 | +54 |
-
+ #' h_count_cumulative(x, 100, lower_tail = FALSE, .N_col = .N_col) |
||
| 273 | +55 |
- # add number of objects N in group_var (strata)+ #' |
||
| 274 | -13x | +|||
| 56 | +
- if (!is.null(group_var) && !is.null(alt_counts_df)) {
+ #' @export |
|||
| 275 | -8x | +|||
| 57 | +
- strata_N <- paste0(group_var, "_N") # nolint+ h_count_cumulative <- function(x, |
|||
| 276 | +58 |
-
+ threshold, |
||
| 277 | -8x | +|||
| 59 | +
- df_N <- stats::aggregate(eval(parse(text = subject_var)) ~ eval(parse(text = group_var)), data = alt_counts_df, FUN = function(x) length(unique(x))) # nolint+ lower_tail = TRUE, |
|||
| 278 | -8x | +|||
| 60 | +
- colnames(df_N) <- c(group_var, "N") # nolint+ include_eq = TRUE, |
|||
| 279 | -8x | +|||
| 61 | +
- df_N[[strata_N]] <- paste0(df_N[[group_var]], " (N = ", df_N$N, ")") # nolint+ na.rm = TRUE, # nolint |
|||
| 280 | +62 |
-
+ .N_col) { # nolint
|
||
| 281 | -+ | |||
| 63 | +36x |
- # keep strata factor levels+ checkmate::assert_numeric(x) |
||
| 282 | -8x | +64 | +36x |
- matches <- sapply(unique(df_N[[group_var]]), function(x) {
+ checkmate::assert_numeric(threshold) |
| 283 | -22x | +65 | +36x |
- regex_pattern <- gsub("([][(){}^$.|*+?\\\\])", "\\\\\\1", x)
+ checkmate::assert_numeric(.N_col) |
| 284 | -22x | +66 | +36x |
- unique(df_N[[paste0(group_var, "_N")]])[grepl(+ checkmate::assert_flag(lower_tail) |
| 285 | -22x | +67 | +36x |
- paste0("^", regex_pattern),
+ checkmate::assert_flag(include_eq) |
| 286 | -22x | +68 | +36x |
- unique(df_N[[paste0(group_var, "_N")]])+ checkmate::assert_flag(na.rm) |
| 287 | +69 |
- )]+ |
||
| 288 | -+ | |||
| 70 | +36x |
- })+ is_keep <- if (na.rm) !is.na(x) else rep(TRUE, length(x)) |
||
| 289 | -8x | +71 | +36x |
- df_N[[paste0(group_var, "_N")]] <- factor(df_N[[group_var]]) # nolint+ count <- if (lower_tail && include_eq) {
|
| 290 | -8x | +72 | +7x |
- levels(df_N[[paste0(group_var, "_N")]]) <- unlist(matches) # nolint+ length(x[is_keep & x <= threshold]) |
| 291 | -+ | |||
| 73 | +36x |
-
+ } else if (lower_tail && !include_eq) {
|
||
| 292 | -+ | |||
| 74 | +! |
- # strata_N should not be in colnames(df_stats)+ length(x[is_keep & x < threshold]) |
||
| 293 | -8x | +75 | +36x |
- checkmate::assert_disjunct(strata_N, colnames(df_stats))+ } else if (!lower_tail && include_eq) {
+ |
+
| 76 | +14x | +
+ length(x[is_keep & x >= threshold])+ |
+ ||
| 77 | +36x | +
+ } else if (!lower_tail && !include_eq) {
+ |
+ ||
| 78 | +15x | +
+ length(x[is_keep & x > threshold]) |
||
| 294 | +79 | ++ |
+ }+ |
+ |
| 80 | ||||
| 295 | -8x | +81 | +36x |
- df_stats <- merge(x = df_stats, y = df_N[, c(group_var, strata_N)], by = group_var)+ result <- c( |
| 296 | -5x | +82 | +36x |
- } else if (!is.null(group_var)) {
+ count = count, |
| 297 | -4x | +83 | +36x |
- strata_N <- group_var # nolint+ fraction = if (count == 0 && .N_col == 0) 0 else count / .N_col |
| 298 | +84 |
- } else {
+ ) |
||
| 299 | -1x | +85 | +36x |
- strata_N <- NULL # nolint+ result |
| 300 | +86 |
- }+ } |
||
| 301 | +87 | |||
| 302 | +88 |
- ############################################### |+ #' Description of cumulative count |
||
| 303 | +89 |
- # ---- Prepare certain plot's properties. ----+ #' |
||
| 304 | +90 |
- ############################################### |+ #' @description `r lifecycle::badge("stable")`
|
||
| 305 | +91 |
- # legend title+ #' |
||
| 306 | -13x | +|||
| 92 | +
- if (is.null(legend_title) && !is.null(group_var) && legend_position != "none") {
+ #' This is a helper function that describes the analysis in [s_count_cumulative()]. |
|||
| 307 | -12x | +|||
| 93 | +
- legend_title <- attr(df[[group_var]], "label")+ #' |
|||
| 308 | +94 |
- }+ #' @inheritParams h_count_cumulative |
||
| 309 | +95 |
-
+ #' |
||
| 310 | +96 |
- # y label+ #' @return Labels for [s_count_cumulative()]. |
||
| 311 | -13x | +|||
| 97 | +
- if (!is.null(y_lab)) {
+ #' |
|||
| 312 | -4x | +|||
| 98 | +
- if (y_lab_add_paramcd) {
+ #' @export |
|||
| 313 | -4x | +|||
| 99 | +
- y_lab <- paste(y_lab, unique(df[[paramcd]]))+ d_count_cumulative <- function(threshold, lower_tail = TRUE, include_eq = TRUE) {
|
|||
| 314 | -+ | |||
| 100 | +34x |
- }+ checkmate::assert_numeric(threshold) |
||
| 315 | -+ | |||
| 101 | +34x |
-
+ lg <- if (lower_tail) "<" else ">" |
||
| 316 | -4x | +102 | +34x |
- if (y_lab_add_unit) {
+ eq <- if (include_eq) "=" else "" |
| 317 | -4x | +103 | +34x |
- y_lab <- paste0(y_lab, " (", unique(df[[y_unit]]), ")")
+ paste0(lg, eq, " ", threshold) |
| 318 | +104 |
- }+ } |
||
| 319 | +105 | |||
| 320 | -4x | +|||
| 106 | +
- y_lab <- trimws(y_lab)+ #' @describeIn count_cumulative Statistics function that produces a named list given a numeric vector of thresholds. |
|||
| 321 | +107 |
- }+ #' |
||
| 322 | +108 |
-
+ #' @return |
||
| 323 | +109 |
- # subtitle+ #' * `s_count_cumulative()` returns a named list of `count_fraction`s: a list with each `thresholds` value as a |
||
| 324 | -13x | +|||
| 110 | +
- if (!is.null(subtitle)) {
+ #' component, each component containing a vector for the count and fraction. |
|||
| 325 | -13x | +|||
| 111 | +
- if (subtitle_add_paramcd) {
+ #' |
|||
| 326 | -13x | +|||
| 112 | +
- subtitle <- paste(subtitle, unique(df[[paramcd]]))+ #' @keywords internal |
|||
| 327 | +113 |
- }+ s_count_cumulative <- function(x, |
||
| 328 | +114 |
-
+ thresholds, |
||
| 329 | -13x | +|||
| 115 | +
- if (subtitle_add_unit) {
+ lower_tail = TRUE, |
|||
| 330 | -13x | +|||
| 116 | +
- subtitle <- paste0(subtitle, " (", unique(df[[y_unit]]), ")")
+ include_eq = TRUE, |
|||
| 331 | +117 |
- }+ .N_col, # nolint |
||
| 332 | +118 |
-
+ .N_row, # nolint |
||
| 333 | -13x | +|||
| 119 | +
- subtitle <- trimws(subtitle)+ denom = c("N_col", "n", "N_row"),
|
|||
| 334 | +120 |
- }+ ...) {
+ |
+ ||
| 121 | +9x | +
+ checkmate::assert_numeric(thresholds, min.len = 1, any.missing = FALSE) |
||
| 335 | +122 | |||
| 336 | -+ | |||
| 123 | +9x |
- ############################### |+ denom <- match.arg(denom) %>%+ |
+ ||
| 124 | +9x | +
+ switch(+ |
+ ||
| 125 | +9x | +
+ n = length(x),+ |
+ ||
| 126 | +9x | +
+ N_row = .N_row,+ |
+ ||
| 127 | +9x | +
+ N_col = .N_col |
||
| 337 | +128 |
- # ---- Build plot object. ----+ ) |
||
| 338 | +129 |
- ############################### |+ |
||
| 339 | -13x | +130 | +9x |
- p <- ggplot2::ggplot(+ count_fraction_list <- Map(function(thres) {
|
| 340 | -13x | +131 | +18x |
- data = df_stats,+ result <- h_count_cumulative(x, thres, lower_tail, include_eq, .N_col = denom, ...) |
| 341 | -13x | +132 | +18x |
- mapping = ggplot2::aes(+ label <- d_count_cumulative(thres, lower_tail, include_eq) |
| 342 | -13x | +133 | +18x |
- x = .data[[x]], y = .data[[mid]],+ formatters::with_label(result, label) |
| 343 | -13x | +134 | +9x |
- color = if (is.null(strata_N)) NULL else .data[[strata_N]],+ }, thresholds) |
| 344 | -13x | +|||
| 135 | +
- shape = if (is.null(strata_N)) NULL else .data[[strata_N]],+ |
|||
| 345 | -13x | +136 | +9x |
- lty = if (is.null(strata_N)) NULL else .data[[strata_N]],+ names(count_fraction_list) <- thresholds |
| 346 | -13x | +137 | +9x |
- group = if (is.null(strata_N)) NULL else .data[[strata_N]]+ list(count_fraction = count_fraction_list) |
| 347 | +138 |
- )+ } |
||
| 348 | +139 |
- )+ |
||
| 349 | +140 |
-
+ #' @describeIn count_cumulative Formatted analysis function which is used as `afun` |
||
| 350 | -13x | +|||
| 141 | +
- if (!is.null(group_var) && nlevels(df_stats[[strata_N]]) > 6) {
+ #' in `count_cumulative()`. |
|||
| 351 | -1x | +|||
| 142 | +
- p <- p ++ #' |
|||
| 352 | -1x | +|||
| 143 | +
- scale_shape_manual(values = seq(15, 15 + nlevels(df_stats[[strata_N]])))+ #' @return |
|||
| 353 | +144 |
- }+ #' * `a_count_cumulative()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 354 | +145 |
-
+ #' |
||
| 355 | -13x | +|||
| 146 | +
- if (!is.null(mid)) {
+ #' @keywords internal |
|||
| 356 | +147 |
- # points+ a_count_cumulative <- make_afun( |
||
| 357 | -13x | +|||
| 148 | +
- if (grepl("p", mid_type, fixed = TRUE)) {
+ s_count_cumulative, |
|||
| 358 | -13x | +|||
| 149 | +
- p <- p + ggplot2::geom_point(position = position, size = mid_point_size, na.rm = TRUE)+ .formats = c(count_fraction = format_count_fraction) |
|||
| 359 | +150 |
- }+ ) |
||
| 360 | +151 | |||
| 361 | +152 |
- # lines - plotted only if there is a strata grouping (group_var)+ #' @describeIn count_cumulative Layout-creating function which can take statistics function arguments |
||
| 362 | -13x | +|||
| 153 | +
- if (grepl("l", mid_type, fixed = TRUE) && !is.null(strata_N)) { # nolint
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 363 | -12x | +|||
| 154 | +
- p <- p + ggplot2::geom_line(position = position, na.rm = TRUE)+ #' |
|||
| 364 | +155 |
- }+ #' @return |
||
| 365 | +156 |
- }+ #' * `count_cumulative()` returns a layout object suitable for passing to further layouting functions, |
||
| 366 | +157 |
-
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 367 | +158 |
- # interval+ #' the statistics from `s_count_cumulative()` to the table layout. |
||
| 368 | -13x | +|||
| 159 | +
- if (!is.null(interval)) {
+ #' |
|||
| 369 | -13x | +|||
| 160 | +
- p <- p ++ #' @examples |
|||
| 370 | -13x | +|||
| 161 | +
- ggplot2::geom_errorbar(+ #' basic_table() %>% |
|||
| 371 | -13x | +|||
| 162 | +
- ggplot2::aes(ymin = .data[[whiskers[1]]], ymax = .data[[whiskers[max(1, length(whiskers))]]]),+ #' split_cols_by("ARM") %>%
|
|||
| 372 | -13x | +|||
| 163 | +
- width = errorbar_width,+ #' add_colcounts() %>% |
|||
| 373 | -13x | +|||
| 164 | +
- position = position+ #' count_cumulative( |
|||
| 374 | +165 |
- )+ #' vars = "AGE", |
||
| 375 | +166 |
-
+ #' thresholds = c(40, 60) |
||
| 376 | -13x | +|||
| 167 | +
- if (length(whiskers) == 1) { # lwr or upr only; mid is then required
+ #' ) %>% |
|||
| 377 | +168 |
- # workaround as geom_errorbar does not provide single-direction whiskers+ #' build_table(tern_ex_adsl) |
||
| 378 | -! | +|||
| 169 | +
- p <- p ++ #' |
|||
| 379 | -! | +|||
| 170 | +
- ggplot2::geom_linerange(+ #' @export |
|||
| 380 | -! | +|||
| 171 | +
- data = df_stats[!is.na(df_stats[[whiskers]]), ], # as na.rm =TRUE does not suppress warnings+ #' @order 2 |
|||
| 381 | -! | +|||
| 172 | +
- ggplot2::aes(ymin = .data[[mid]], ymax = .data[[whiskers]]),+ count_cumulative <- function(lyt, |
|||
| 382 | -! | +|||
| 173 | +
- position = position,+ vars, |
|||
| 383 | -! | +|||
| 174 | +
- na.rm = TRUE,+ thresholds, |
|||
| 384 | -! | +|||
| 175 | +
- show.legend = FALSE+ lower_tail = TRUE, |
|||
| 385 | +176 |
- )+ include_eq = TRUE, |
||
| 386 | +177 |
- }+ var_labels = vars, |
||
| 387 | +178 |
- }+ show_labels = "visible", |
||
| 388 | +179 |
-
+ na_str = default_na_str(), |
||
| 389 | -13x | +|||
| 180 | +
- if (is.numeric(df_stats[[x]])) {
+ nested = TRUE, |
|||
| 390 | -1x | +|||
| 181 | +
- if (length(xticks) == 1) xticks <- seq(from = min(df_stats[[x]]), to = max(df_stats[[x]]), by = xticks)+ ..., |
|||
| 391 | -1x | +|||
| 182 | +
- p <- p + ggplot2::scale_x_continuous(breaks = if (!is.null(xticks)) xticks else waiver(), limits = xlim)+ table_names = vars, |
|||
| 392 | +183 |
- }+ .stats = NULL, |
||
| 393 | +184 |
-
+ .formats = NULL, |
||
| 394 | -13x | +|||
| 185 | +
- p <- p ++ .labels = NULL, |
|||
| 395 | -13x | +|||
| 186 | +
- ggplot2::scale_y_continuous(labels = scales::comma, limits = ylim) ++ .indent_mods = NULL) {
|
|||
| 396 | -13x | +187 | +3x |
- ggplot2::labs(+ extra_args <- list(thresholds = thresholds, lower_tail = lower_tail, include_eq = include_eq, ...) |
| 397 | -13x | +|||
| 188 | +
- title = title,+ |
|||
| 398 | -13x | +189 | +3x |
- subtitle = subtitle,+ afun <- make_afun( |
| 399 | -13x | +190 | +3x |
- caption = caption,+ a_count_cumulative, |
| 400 | -13x | +191 | +3x |
- color = legend_title,+ .stats = .stats, |
| 401 | -13x | +192 | +3x |
- lty = legend_title,+ .formats = .formats, |
| 402 | -13x | +193 | +3x |
- shape = legend_title,+ .labels = .labels, |
| 403 | -13x | +194 | +3x |
- x = x_lab,+ .indent_mods = .indent_mods, |
| 404 | -13x | +195 | +3x |
- y = y_lab+ .ungroup_stats = "count_fraction" |
| 405 | +196 |
- )+ ) |
||
| 406 | -+ | |||
| 197 | +3x |
-
+ analyze( |
||
| 407 | -13x | +198 | +3x |
- if (!is.null(col)) {
+ lyt, |
| 408 | -1x | +199 | +3x |
- p <- p ++ vars, |
| 409 | -1x | -
- ggplot2::scale_color_manual(values = col)- |
- ||
| 410 | -+ | 200 | +3x |
- }+ afun = afun, |
| 411 | -13x | +201 | +3x |
- if (!is.null(linetype)) {
+ na_str = na_str, |
| 412 | -1x | +202 | +3x |
- p <- p ++ table_names = table_names, |
| 413 | -1x | -
- ggplot2::scale_linetype_manual(values = linetype)- |
- ||
| 414 | -- |
- }- |
- ||
| 415 | -+ | 203 | +3x |
-
+ var_labels = var_labels, |
| 416 | -13x | +204 | +3x |
- if (!is.null(facet_var)) {
+ show_labels = show_labels, |
| 417 | -1x | +205 | +3x |
- p <- p ++ nested = nested, |
| 418 | -1x | +206 | +3x |
- facet_grid(cols = vars(df_stats[[facet_var]]))+ extra_args = extra_args |
| 419 | +207 |
- }+ ) |
||
| 420 | +208 | - - | -||
| 421 | -13x | -
- if (!is.null(ggtheme)) {
+ } |
||
| 422 | -13x | +
| 1 | +
- p <- p + ggtheme+ #' Line plot with optional table |
|||
| 423 | +2 |
- } else {
+ #' |
||
| 424 | -! | +|||
| 3 | +
- p <- p ++ #' @description `r lifecycle::badge("stable")`
|
|||
| 425 | -! | +|||
| 4 | +
- ggplot2::theme_bw() ++ #' |
|||
| 426 | -! | +|||
| 5 | +
- ggplot2::theme(+ #' Line plot with optional table. |
|||
| 427 | -! | +|||
| 6 | +
- legend.key.width = grid::unit(1, "cm"),+ #' |
|||
| 428 | -! | +|||
| 7 | +
- legend.position = legend_position,+ #' @inheritParams argument_convention |
|||
| 429 | -! | +|||
| 8 | +
- legend.direction = ifelse(+ #' @param alt_counts_df (`data.frame` or `NULL`)\cr data set that will be used (only) |
|||
| 430 | -! | +|||
| 9 | +
- legend_position %in% c("top", "bottom"),
+ #' to counts objects in groups for stratification. |
|||
| 431 | -! | +|||
| 10 | +
- "horizontal",+ #' @param variables (named `character`) vector of variable names in `df` which should include: |
|||
| 432 | -! | +|||
| 11 | +
- "vertical"+ #' * `x` (`string`)\cr name of x-axis variable. |
|||
| 433 | +12 |
- )+ #' * `y` (`string`)\cr name of y-axis variable. |
||
| 434 | +13 |
- )+ #' * `group_var` (`string` or `NULL`)\cr name of grouping variable (or strata), i.e. treatment arm. |
||
| 435 | +14 |
- }+ #' Can be `NA` to indicate lack of groups. |
||
| 436 | +15 |
-
+ #' * `subject_var` (`string` or `NULL`)\cr name of subject variable. Only applies if `group_var` is |
||
| 437 | +16 |
- ############################################################# |+ #' not NULL. |
||
| 438 | +17 |
- # ---- Optionally, add table to the bottom of the plot. ----+ #' * `paramcd` (`string` or `NA`)\cr name of the variable for parameter's code. Used for y-axis label and plot's |
||
| 439 | +18 |
- ############################################################# |+ #' subtitle. Can be `NA` if `paramcd` is not to be added to the y-axis label or subtitle. |
||
| 440 | -13x | +|||
| 19 | +
- if (!is.null(table)) {
+ #' * `y_unit` (`string` or `NA`)\cr name of variable with units of `y`. Used for y-axis label and plot's subtitle. |
|||
| 441 | -5x | +|||
| 20 | +
- df_stats_table <- df_grp %>%+ #' Can be `NA` if y unit is not to be added to the y-axis label or subtitle. |
|||
| 442 | -5x | +|||
| 21 | +
- dplyr::summarise(+ #' * `facet_var` (`string` or `NA`)\cr name of the secondary grouping variable used for plot faceting, i.e. treatment |
|||
| 443 | -5x | +|||
| 22 | +
- h_format_row(+ #' arm. Can be `NA` to indicate lack of groups. |
|||
| 444 | -5x | +|||
| 23 | +
- x = sfun(.data[[y]], ...)[table],+ #' @param mid (`character` or `NULL`)\cr names of the statistics that will be plotted as midpoints. |
|||
| 445 | -5x | +|||
| 24 | +
- format = table_format,+ #' All the statistics indicated in `mid` variable must be present in the object returned by `sfun`, |
|||
| 446 | -5x | +|||
| 25 | +
- labels = table_labels+ #' and be of a `double` or `numeric` type vector of length one. |
|||
| 447 | +26 |
- ),+ #' @param interval (`character` or `NULL`)\cr names of the statistics that will be plotted as intervals. |
||
| 448 | -5x | +|||
| 27 | +
- .groups = "drop"+ #' All the statistics indicated in `interval` variable must be present in the object returned by `sfun`, |
|||
| 449 | +28 |
- )+ #' and be of a `double` or `numeric` type vector of length two. Set `interval = NULL` if intervals should not be |
||
| 450 | +29 |
-
+ #' added to the plot. |
||
| 451 | -5x | +|||
| 30 | +
- stats_lev <- rev(setdiff(colnames(df_stats_table), c(group_var, x)))+ #' @param whiskers (`character`)\cr names of the interval whiskers that will be plotted. Names must match names |
|||
| 452 | +31 |
-
+ #' of the list element `interval` that will be returned by `sfun` (e.g. `mean_ci_lwr` element of |
||
| 453 | -5x | +|||
| 32 | +
- df_stats_table <- df_stats_table %>%+ #' `sfun(x)[["mean_ci"]]`). It is possible to specify one whisker only, or to suppress all whiskers by setting |
|||
| 454 | -5x | +|||
| 33 | +
- tidyr::pivot_longer(+ #' `interval = NULL`. |
|||
| 455 | -5x | +|||
| 34 | +
- cols = -dplyr::all_of(c(group_var, x)),+ #' @param table (`character` or `NULL`)\cr names of the statistics that will be displayed in the table below the plot. |
|||
| 456 | -5x | +|||
| 35 | +
- names_to = "stat",+ #' All the statistics indicated in `table` variable must be present in the object returned by `sfun`. |
|||
| 457 | -5x | +|||
| 36 | +
- values_to = "value",+ #' @param sfun (`function`)\cr the function to compute the values of required statistics. It must return a named `list` |
|||
| 458 | -5x | +|||
| 37 | +
- names_ptypes = list(stat = factor(levels = stats_lev))+ #' with atomic vectors. The names of the `list` elements refer to the names of the statistics and are used by `mid`, |
|||
| 459 | +38 |
- )+ #' `interval`, `table`. It must be able to accept as input a vector with data for which statistics are computed. |
||
| 460 | +39 |
-
+ #' @param ... optional arguments to `sfun`. |
||
| 461 | -5x | +|||
| 40 | +
- tbl <- ggplot2::ggplot(+ #' @param mid_type (`string`)\cr controls the type of the `mid` plot, it can be point (`"p"`), line (`"l"`), |
|||
| 462 | -5x | +|||
| 41 | +
- df_stats_table,+ #' or point and line (`"pl"`). |
|||
| 463 | -5x | +|||
| 42 | +
- ggplot2::aes(x = .data[[x]], y = .data[["stat"]], label = .data[["value"]])+ #' @param mid_point_size (`numeric(1)`)\cr font size of the `mid` plot points. |
|||
| 464 | +43 |
- ) ++ #' @param position (`character` or `call`)\cr geom element position adjustment, either as a string, or the result of |
||
| 465 | -5x | +|||
| 44 | +
- ggplot2::geom_text(size = table_font_size) ++ #' a call to a position adjustment function. |
|||
| 466 | -5x | +|||
| 45 | +
- ggplot2::theme_bw() ++ #' @param legend_title (`string`)\cr legend title. |
|||
| 467 | -5x | +|||
| 46 | +
- ggplot2::theme(+ #' @param legend_position (`string`)\cr the position of the plot legend (`"none"`, `"left"`, `"right"`, `"bottom"`, |
|||
| 468 | -5x | +|||
| 47 | +
- panel.border = ggplot2::element_blank(),+ #' `"top"`, or a two-element numeric vector). |
|||
| 469 | -5x | +|||
| 48 | +
- panel.grid.major = ggplot2::element_blank(),+ #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot. |
|||
| 470 | -5x | +|||
| 49 | +
- panel.grid.minor = ggplot2::element_blank(),+ #' @param xticks (`numeric` or `NULL`)\cr numeric vector of tick positions or a single number with spacing |
|||
| 471 | -5x | +|||
| 50 | +
- axis.ticks = ggplot2::element_blank(),+ #' between ticks on the x-axis, for use when `variables$x` is numeric. If `NULL` (default), [labeling::extended()] is |
|||
| 472 | -5x | +|||
| 51 | +
- axis.title = ggplot2::element_blank(),+ #' used to determine optimal tick positions on the x-axis. If `variables$x` is not numeric, this argument is ignored. |
|||
| 473 | -5x | +|||
| 52 | +
- axis.text.x = ggplot2::element_blank(),+ #' @param x_lab (`string` or `NULL`)\cr x-axis label. If `NULL` then no label will be added. |
|||
| 474 | -5x | +|||
| 53 | +
- axis.text.y = ggplot2::element_text(+ #' @param y_lab (`string` or `NULL`)\cr y-axis label. If `NULL` then no label will be added. |
|||
| 475 | -5x | +|||
| 54 | +
- size = table_font_size * ggplot2::.pt,+ #' @param y_lab_add_paramcd (`flag`)\cr whether `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` should be added |
|||
| 476 | -5x | +|||
| 55 | +
- margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 5)+ #' to the y-axis label (`y_lab`). |
|||
| 477 | +56 |
- ),+ #' @param y_lab_add_unit (`flag`)\cr whether y-axis unit, i.e. `unique(df[[variables["y_unit"]]])` should be added |
||
| 478 | -5x | +|||
| 57 | +
- strip.text = ggplot2::element_text(hjust = 0),+ #' to the y-axis label (`y_lab`). |
|||
| 479 | -5x | +|||
| 58 | +
- strip.text.x = ggplot2::element_text(+ #' @param title (`string`)\cr plot title. |
|||
| 480 | -5x | +|||
| 59 | +
- size = table_font_size * ggplot2::.pt,+ #' @param subtitle (`string`)\cr plot subtitle. |
|||
| 481 | -5x | +|||
| 60 | +
- margin = ggplot2::margin(1.5, 0, 1.5, 0, "pt")+ #' @param subtitle_add_paramcd (`flag`)\cr whether `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` should be |
|||
| 482 | +61 |
- ),+ #' added to the plot's subtitle (`subtitle`). |
||
| 483 | -5x | +|||
| 62 | +
- strip.background = ggplot2::element_rect(fill = "grey95", color = NA),+ #' @param subtitle_add_unit (`flag`)\cr whether the y-axis unit, i.e. `unique(df[[variables["y_unit"]]])` should be |
|||
| 484 | -5x | +|||
| 63 | +
- legend.position = "none"+ #' added to the plot's subtitle (`subtitle`). |
|||
| 485 | +64 |
- )+ #' @param caption (`string`)\cr optional caption below the plot. |
||
| 486 | +65 |
-
+ #' @param table_format (named `character` or `NULL`)\cr format patterns for descriptive statistics used in the |
||
| 487 | -5x | +|||
| 66 | +
- if (!is.null(group_var)) {
+ #' (optional) table appended to the plot. It is passed directly to the `h_format_row` function through the `format` |
|||
| 488 | -5x | +|||
| 67 | +
- tbl <- tbl + ggplot2::facet_wrap(facets = group_var, ncol = 1)+ #' parameter. Names of `table_format` must match the names of statistics returned by `sfun` function. |
|||
| 489 | +68 |
- }+ #' @param table_labels (named `character` or `NULL`)\cr labels for descriptive statistics used in the (optional) table |
||
| 490 | +69 |
-
+ #' appended to the plot. Names of `table_labels` must match the names of statistics returned by `sfun` function. |
||
| 491 | -5x | +|||
| 70 | +
- if (!as_list) {
+ #' @param table_font_size (`numeric(1)`)\cr font size of the text in the table. |
|||
| 492 | +71 |
- # align plot and table+ #' @param newpage `r lifecycle::badge("deprecated")` not used.
|
||
| 493 | -4x | +|||
| 72 | +
- cowplot::plot_grid(+ #' @param col (`character`)\cr color(s). See `?ggplot2::aes_colour_fill_alpha` for example values. |
|||
| 494 | -4x | +|||
| 73 | +
- p,+ #' @param linetype (`character`)\cr line type(s). See `?ggplot2::aes_linetype_size_shape` for example values. |
|||
| 495 | -4x | +|||
| 74 | +
- tbl,+ #' @param errorbar_width (`numeric(1)`)\cr width of the error bars. |
|||
| 496 | -4x | +|||
| 75 | +
- ncol = 1,+ #' @param rel_height_plot (`proportion`)\cr proportion of total figure height to allocate to the line plot. |
|||
| 497 | -4x | +|||
| 76 | +
- align = "v",+ #' Relative height of annotation table is then `1 - rel_height_plot`. If `table = NULL`, this parameter is ignored. |
|||
| 498 | -4x | +|||
| 77 | +
- axis = "tblr",+ #' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list when `table` is not `NULL`. |
|||
| 499 | -4x | +|||
| 78 | +
- rel_heights = c(rel_height_plot, 1 - rel_height_plot)+ #' If `TRUE`, a named list with two elements, `plot` and `table`, will be returned. If `FALSE` (default) the |
|||
| 500 | +79 |
- )+ #' annotation table is printed below the plot via [cowplot::plot_grid()]. |
||
| 501 | +80 |
- } else {
+ #' |
||
| 502 | -1x | +|||
| 81 | +
- list(plot = p, table = tbl)+ #' @return A `ggplot` line plot (and statistics table if applicable). |
|||
| 503 | +82 |
- }+ #' |
||
| 504 | +83 |
- } else {
+ #' @examples |
||
| 505 | -8x | +|||
| 84 | +
- p+ #' |
|||
| 506 | +85 |
- }+ #' adsl <- tern_ex_adsl |
||
| 507 | +86 |
- }+ #' adlb <- tern_ex_adlb %>% dplyr::filter(ANL01FL == "Y", PARAMCD == "ALT", AVISIT != "SCREENING") |
||
| 508 | +87 |
-
+ #' adlb$AVISIT <- droplevels(adlb$AVISIT) |
||
| 509 | +88 |
- #' Helper function to format the optional `g_lineplot` table+ #' adlb <- dplyr::mutate(adlb, AVISIT = forcats::fct_reorder(AVISIT, AVISITN, min)) |
||
| 510 | +89 |
#' |
||
| 511 | +90 |
- #' @description `r lifecycle::badge("stable")`
+ #' # Mean with CI |
||
| 512 | +91 |
- #'+ #' g_lineplot(adlb, adsl, subtitle = "Laboratory Test:") |
||
| 513 | +92 |
- #' @param x (named `list`)\cr list of numerical values to be formatted and optionally labeled.+ #' |
||
| 514 | +93 |
- #' Elements of `x` must be `numeric` vectors.+ #' # Mean with CI, no stratification with group_var |
||
| 515 | +94 |
- #' @param format (named `character` or `NULL`)\cr format patterns for `x`. Names of the `format` must+ #' g_lineplot(adlb, variables = control_lineplot_vars(group_var = NA)) |
||
| 516 | +95 |
- #' match the names of `x`. This parameter is passed directly to the `rtables::format_rcell`+ #' |
||
| 517 | +96 |
- #' function through the `format` parameter.+ #' # Mean, upper whisker of CI, no group_var(strata) counts N |
||
| 518 | +97 |
- #' @param labels (named `character` or `NULL`)\cr optional labels for `x`. Names of the `labels` must+ #' g_lineplot( |
||
| 519 | +98 |
- #' match the names of `x`. When a label is not specified for an element of `x`,+ #' adlb, |
||
| 520 | +99 |
- #' then this function tries to use `label` or `names` (in this order) attribute of that element+ #' whiskers = "mean_ci_upr", |
||
| 521 | +100 |
- #' (depending on which one exists and it is not `NULL` or `NA` or `NaN`). If none of these attributes+ #' title = "Plot of Mean and Upper 95% Confidence Limit by Visit" |
||
| 522 | +101 |
- #' are attached to a given element of `x`, then the label is automatically generated.+ #' ) |
||
| 523 | +102 |
#' |
||
| 524 | +103 |
- #' @return A single row `data.frame` object.+ #' # Median with CI |
||
| 525 | +104 |
- #'+ #' g_lineplot( |
||
| 526 | +105 |
- #' @examples+ #' adlb, |
||
| 527 | +106 |
- #' mean_ci <- c(48, 51)+ #' adsl, |
||
| 528 | +107 |
- #' x <- list(mean = 50, mean_ci = mean_ci)+ #' mid = "median", |
||
| 529 | +108 |
- #' format <- c(mean = "xx.x", mean_ci = "(xx.xx, xx.xx)")+ #' interval = "median_ci", |
||
| 530 | +109 |
- #' labels <- c(mean = "My Mean")+ #' whiskers = c("median_ci_lwr", "median_ci_upr"),
|
||
| 531 | +110 |
- #' h_format_row(x, format, labels)+ #' title = "Plot of Median and 95% Confidence Limits by Visit" |
||
| 532 | +111 |
- #'+ #' ) |
||
| 533 | +112 |
- #' attr(mean_ci, "label") <- "Mean 95% CI"+ #' |
||
| 534 | +113 |
- #' x <- list(mean = 50, mean_ci = mean_ci)+ #' # Mean, +/- SD |
||
| 535 | +114 |
- #' h_format_row(x, format, labels)+ #' g_lineplot(adlb, adsl, |
||
| 536 | +115 |
- #'+ #' interval = "mean_sdi", |
||
| 537 | +116 |
- #' @export+ #' whiskers = c("mean_sdi_lwr", "mean_sdi_upr"),
|
||
| 538 | +117 |
- h_format_row <- function(x, format, labels = NULL) {
+ #' title = "Plot of Median +/- SD by Visit" |
||
| 539 | +118 |
- # cell: one row, one column data.frame+ #' ) |
||
| 540 | -92x | +|||
| 119 | +
- format_cell <- function(x, format, label = NULL) {
+ #' |
|||
| 541 | -238x | +|||
| 120 | +
- fc <- format_rcell(x = x, format = unlist(format))+ #' # Mean with CI plot with stats table |
|||
| 542 | -238x | +|||
| 121 | +
- if (is.na(fc)) {
+ #' g_lineplot(adlb, adsl, table = c("n", "mean", "mean_ci"))
|
|||
| 543 | -! | +|||
| 122 | +
- fc <- "NA"+ #' |
|||
| 544 | +123 |
- }+ #' # Mean with CI, table and customized confidence level |
||
| 545 | -238x | +|||
| 124 | +
- x_label <- attr(x, "label")+ #' g_lineplot( |
|||
| 546 | -238x | +|||
| 125 | +
- if (!is.null(label) && !is.na(label)) {
+ #' adlb, |
|||
| 547 | -236x | +|||
| 126 | +
- names(fc) <- label+ #' adsl, |
|||
| 548 | -2x | +|||
| 127 | +
- } else if (!is.null(x_label) && !is.na(x_label)) {
+ #' table = c("n", "mean", "mean_ci"),
|
|||
| 549 | -1x | +|||
| 128 | +
- names(fc) <- x_label+ #' control = control_analyze_vars(conf_level = 0.80), |
|||
| 550 | -1x | +|||
| 129 | +
- } else if (length(x) == length(fc)) {
+ #' title = "Plot of Mean and 80% Confidence Limits by Visit" |
|||
| 551 | -! | +|||
| 130 | +
- names(fc) <- names(x)+ #' ) |
|||
| 552 | +131 |
- }+ #' |
||
| 553 | -238x | +|||
| 132 | +
- as.data.frame(t(fc))+ #' # Mean with CI, table, filtered data |
|||
| 554 | +133 |
- }+ #' adlb_f <- dplyr::filter(adlb, ARMCD != "ARM A" | AVISIT == "BASELINE") |
||
| 555 | +134 |
-
+ #' g_lineplot(adlb_f, table = c("n", "mean"))
|
||
| 556 | -92x | +|||
| 135 | +
- row <- do.call(+ #' |
|||
| 557 | -92x | +|||
| 136 | +
- cbind,+ #' @export |
|||
| 558 | -92x | +|||
| 137 | +
- lapply(+ g_lineplot <- function(df, |
|||
| 559 | -92x | +|||
| 138 | +
- names(x), function(xn) format_cell(x[[xn]], format = format[xn], label = labels[xn])+ alt_counts_df = NULL, |
|||
| 560 | +139 |
- )+ variables = control_lineplot_vars(), |
||
| 561 | +140 |
- )+ mid = "mean", |
||
| 562 | +141 |
-
+ interval = "mean_ci", |
||
| 563 | -92x | +|||
| 142 | +
- row+ whiskers = c("mean_ci_lwr", "mean_ci_upr"),
|
|||
| 564 | +143 |
- }+ table = NULL, |
||
| 565 | +144 |
-
+ sfun = s_summary, |
||
| 566 | +145 |
- #' Control function for `g_lineplot()`+ ..., |
||
| 567 | +146 |
- #'+ mid_type = "pl", |
||
| 568 | +147 |
- #' @description `r lifecycle::badge("stable")`
+ mid_point_size = 2, |
||
| 569 | +148 |
- #'+ position = ggplot2::position_dodge(width = 0.4), |
||
| 570 | +149 |
- #' Default values for `variables` parameter in `g_lineplot` function.+ legend_title = NULL, |
||
| 571 | +150 |
- #' A variable's default value can be overwritten for any variable.+ legend_position = "bottom", |
||
| 572 | +151 |
- #'+ ggtheme = nestcolor::theme_nest(), |
||
| 573 | +152 |
- #' @param x (`string`)\cr x-variable name.+ xticks = NULL, |
||
| 574 | +153 |
- #' @param y (`string`)\cr y-variable name.+ xlim = NULL, |
||
| 575 | +154 |
- #' @param group_var (`string` or `NA`)\cr group variable name.+ ylim = NULL, |
||
| 576 | +155 |
- #' @param subject_var (`string` or `NA`)\cr subject variable name.+ x_lab = obj_label(df[[variables[["x"]]]]), |
||
| 577 | +156 |
- #' @param facet_var (`string` or `NA`)\cr faceting variable name.+ y_lab = NULL, |
||
| 578 | +157 |
- #' @param paramcd (`string` or `NA`)\cr parameter code variable name.+ y_lab_add_paramcd = TRUE, |
||
| 579 | +158 |
- #' @param y_unit (`string` or `NA`)\cr y-axis unit variable name.+ y_lab_add_unit = TRUE, |
||
| 580 | +159 |
- #'+ title = "Plot of Mean and 95% Confidence Limits by Visit", |
||
| 581 | +160 |
- #' @return A named character vector of variable names.+ subtitle = "", |
||
| 582 | +161 |
- #'+ subtitle_add_paramcd = TRUE, |
||
| 583 | +162 |
- #' @examples+ subtitle_add_unit = TRUE, |
||
| 584 | +163 |
- #' control_lineplot_vars()+ caption = NULL, |
||
| 585 | +164 |
- #' control_lineplot_vars(group_var = NA)+ table_format = NULL, |
||
| 586 | +165 |
- #'+ table_labels = NULL, |
||
| 587 | +166 |
- #' @export+ table_font_size = 3, |
||
| 588 | +167 |
- control_lineplot_vars <- function(x = "AVISIT",+ errorbar_width = 0.45, |
||
| 589 | +168 |
- y = "AVAL",+ newpage = lifecycle::deprecated(), |
||
| 590 | +169 |
- group_var = "ARM",+ col = NULL, |
||
| 591 | +170 |
- facet_var = NA,+ linetype = NULL, |
||
| 592 | +171 |
- paramcd = "PARAMCD",+ rel_height_plot = 0.5, |
||
| 593 | +172 |
- y_unit = "AVALU",+ as_list = FALSE) {
|
||
| 594 | -+ | |||
| 173 | +13x |
- subject_var = "USUBJID") {
+ checkmate::assert_character(variables, any.missing = TRUE) |
||
| 595 | -16x | +174 | +13x |
- checkmate::assert_string(x)+ checkmate::assert_character(mid, null.ok = TRUE) |
| 596 | -16x | +175 | +13x |
- checkmate::assert_string(y)+ checkmate::assert_character(interval, null.ok = TRUE) |
| 597 | -16x | +176 | +13x |
- checkmate::assert_string(group_var, na.ok = TRUE, null.ok = TRUE)+ checkmate::assert_character(col, null.ok = TRUE) |
| 598 | -16x | +177 | +13x |
- checkmate::assert_string(facet_var, na.ok = TRUE, null.ok = TRUE)+ checkmate::assert_character(linetype, null.ok = TRUE) |
| 599 | -16x | +178 | +13x |
- checkmate::assert_string(subject_var, na.ok = TRUE, null.ok = TRUE)+ checkmate::assert_numeric(xticks, null.ok = TRUE) |
| 600 | -16x | +179 | +13x |
- checkmate::assert_string(paramcd, na.ok = TRUE, null.ok = TRUE)+ checkmate::assert_numeric(xlim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE) |
| 601 | -16x | +180 | +13x |
- checkmate::assert_string(y_unit, na.ok = TRUE, null.ok = TRUE)+ checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE) |
| 602 | -+ | |||
| 181 | +13x |
-
+ checkmate::assert_number(errorbar_width, lower = 0) |
||
| 603 | -16x | +182 | +13x |
- variables <- c(+ checkmate::assert_string(title, null.ok = TRUE) |
| 604 | -16x | +183 | +13x |
- x = x, y = y, group_var = group_var, paramcd = paramcd,+ checkmate::assert_string(subtitle, null.ok = TRUE) |
| 605 | -16x | +184 | +13x |
- y_unit = y_unit, subject_var = subject_var, facet_var = facet_var+ assert_proportion_value(rel_height_plot)+ |
+
| 185 | +13x | +
+ checkmate::assert_logical(as_list) |
||
| 606 | +186 |
- )+ |
||
| 607 | -16x | +187 | +13x |
- return(variables)+ if (!is.null(table)) {
|
| 608 | -+ | |||
| 188 | +5x |
- }+ table_format <- get_formats_from_stats(table) |
| 1 | -+ | |||
| 189 | +5x |
- #' Count number of patients and sum exposure across all patients in columns+ table_labels <- get_labels_from_stats(table) %>% .unlist_keep_nulls() |
||
| 2 | +190 |
- #'+ } |
||
| 3 | +191 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 4 | -+ | |||
| 192 | +13x |
- #'+ extra_args <- list(...) |
||
| 5 | -+ | |||
| 193 | +13x |
- #' The analyze function [analyze_patients_exposure_in_cols()] creates a layout element to count total numbers of+ if ("control" %in% names(extra_args)) {
|
||
| 6 | -+ | |||
| 194 | +4x |
- #' patients and sum an analysis value (i.e. exposure) across all patients in columns.+ if (!is.null(table) && all(table_labels == .unlist_keep_nulls(get_labels_from_stats(table)))) {
|
||
| 7 | -+ | |||
| 195 | +3x |
- #'+ table_labels <- table_labels %>% labels_use_control(extra_args[["control"]]) |
||
| 8 | +196 |
- #' The primary analysis variable `ex_var` is the exposure variable used to calculate the `sum_exposure` statistic. The+ } |
||
| 9 | +197 |
- #' `id` variable is used to uniquely identify patients in the data such that only unique patients are counted in the+ } |
||
| 10 | +198 |
- #' `n_patients` statistic, and the `var` variable is used to create a row split if needed. The percentage returned as+ |
||
| 11 | -+ | |||
| 199 | +13x |
- #' part of the `n_patients` statistic is the proportion of all records that correspond to a unique patient.+ if (is.character(interval)) {
|
||
| 12 | -+ | |||
| 200 | +13x |
- #'+ checkmate::assert_vector(whiskers, min.len = 0, max.len = 2) |
||
| 13 | +201 |
- #' The summarize function [summarize_patients_exposure_in_cols()] performs the same function as+ } |
||
| 14 | +202 |
- #' [analyze_patients_exposure_in_cols()] except it creates content rows, not data rows, to summarize the current table+ |
||
| 15 | -+ | |||
| 203 | +13x |
- #' row/column context and operates on the level of the latest row split or the root of the table if no row splits have+ if (length(whiskers) == 1) {
|
||
| 16 | -+ | |||
| 204 | +! |
- #' occurred.+ checkmate::assert_character(mid) |
||
| 17 | +205 |
- #'+ } |
||
| 18 | +206 |
- #' If a column split has not yet been performed in the table, `col_split` must be set to `TRUE` for the first call of+ |
||
| 19 | -+ | |||
| 207 | +13x |
- #' [analyze_patients_exposure_in_cols()] or [summarize_patients_exposure_in_cols()].+ if (is.character(mid)) {
|
||
| 20 | -+ | |||
| 208 | +13x |
- #'+ checkmate::assert_scalar(mid_type) |
||
| 21 | -+ | |||
| 209 | +13x |
- #' @inheritParams argument_convention+ checkmate::assert_subset(mid_type, c("pl", "p", "l"))
|
||
| 22 | +210 |
- #' @param ex_var (`string`)\cr name of the variable in `df` containing exposure values.+ } |
||
| 23 | +211 |
- #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty, this will be used as label.+ |
||
| 24 | -+ | |||
| 212 | +13x |
- #' @param .stats (`character`)\cr statistics to select for the table.+ x <- variables[["x"]] |
||
| 25 | -+ | |||
| 213 | +13x |
- #'+ y <- variables[["y"]] |
||
| 26 | -+ | |||
| 214 | +13x |
- #' Options are: ``r shQuote(get_stats("analyze_patients_exposure_in_cols"))``
+ paramcd <- variables["paramcd"] # NA if paramcd == NA or it is not in variables |
||
| 27 | -+ | |||
| 215 | +13x |
- #'+ y_unit <- variables["y_unit"] # NA if y_unit == NA or it is not in variables |
||
| 28 | -+ | |||
| 216 | +13x |
- #' @name summarize_patients_exposure_in_cols+ if (is.na(variables["group_var"])) {
|
||
| 29 | -+ | |||
| 217 | +1x |
- #' @order 1+ group_var <- NULL # NULL if group_var == NA or it is not in variables |
||
| 30 | +218 |
- NULL+ } else {
|
||
| 31 | -+ | |||
| 219 | +12x |
-
+ group_var <- variables[["group_var"]] |
||
| 32 | -+ | |||
| 220 | +12x |
- #' @describeIn summarize_patients_exposure_in_cols Statistics function which counts numbers+ subject_var <- variables[["subject_var"]] |
||
| 33 | +221 |
- #' of patients and the sum of exposure across all patients.+ } |
||
| 34 | -+ | |||
| 222 | +13x |
- #'+ if (is.na(variables["facet_var"])) {
|
||
| 35 | -+ | |||
| 223 | +12x |
- #' @return+ facet_var <- NULL # NULL if facet_var == NA or it is not in variables |
||
| 36 | +224 |
- #' * `s_count_patients_sum_exposure()` returns a named `list` with the statistics:+ } else {
|
||
| 37 | -+ | |||
| 225 | +1x |
- #' * `n_patients`: Number of unique patients in `df`.+ facet_var <- variables[["facet_var"]] |
||
| 38 | +226 |
- #' * `sum_exposure`: Sum of `ex_var` across all patients in `df`.+ } |
||
| 39 | -+ | |||
| 227 | +13x |
- #'+ checkmate::assert_flag(y_lab_add_paramcd, null.ok = TRUE) |
||
| 40 | -+ | |||
| 228 | +13x |
- #' @keywords internal+ checkmate::assert_flag(subtitle_add_paramcd, null.ok = TRUE)+ |
+ ||
| 229 | +13x | +
+ if ((!is.null(y_lab) && y_lab_add_paramcd) || (!is.null(subtitle) && subtitle_add_paramcd)) {
+ |
+ ||
| 230 | +13x | +
+ checkmate::assert_false(is.na(paramcd))+ |
+ ||
| 231 | +13x | +
+ checkmate::assert_scalar(unique(df[[paramcd]])) |
||
| 41 | +232 |
- s_count_patients_sum_exposure <- function(df,+ } |
||
| 42 | +233 |
- ex_var = "AVAL",+ + |
+ ||
| 234 | +13x | +
+ checkmate::assert_flag(y_lab_add_unit, null.ok = TRUE)+ |
+ ||
| 235 | +13x | +
+ checkmate::assert_flag(subtitle_add_unit, null.ok = TRUE)+ |
+ ||
| 236 | +13x | +
+ if ((!is.null(y_lab) && y_lab_add_unit) || (!is.null(subtitle) && subtitle_add_unit)) {
+ |
+ ||
| 237 | +13x | +
+ checkmate::assert_false(is.na(y_unit))+ |
+ ||
| 238 | +13x | +
+ checkmate::assert_scalar(unique(df[[y_unit]])) |
||
| 43 | +239 |
- id = "USUBJID",+ } |
||
| 44 | +240 |
- labelstr = "",+ + |
+ ||
| 241 | +13x | +
+ if (!is.null(group_var) && !is.null(alt_counts_df)) {
+ |
+ ||
| 242 | +8x | +
+ checkmate::assert_set_equal(unique(alt_counts_df[[group_var]]), unique(df[[group_var]])) |
||
| 45 | +243 |
- .stats = c("n_patients", "sum_exposure"),
+ } |
||
| 46 | +244 |
- .N_col, # nolint+ |
||
| 47 | +245 |
- custom_label = NULL) {
+ ####################################### | |
||
| 48 | -56x | +|||
| 246 | +
- assert_df_with_variables(df, list(ex_var = ex_var, id = id))+ # ---- Compute required statistics ---- |
|||
| 49 | -56x | +|||
| 247 | +
- checkmate::assert_string(id)+ ####################################### | |
|||
| 50 | -56x | +|||
| 248 | +
- checkmate::assert_string(labelstr)+ # Remove unused levels for x-axis |
|||
| 51 | -56x | +249 | +13x |
- checkmate::assert_string(custom_label, null.ok = TRUE)+ if (is.factor(df[[x]])) {
|
| 52 | -56x | +250 | +12x |
- checkmate::assert_numeric(df[[ex_var]])+ df[[x]] <- droplevels(df[[x]]) |
| 53 | -56x | +|||
| 251 | +
- checkmate::assert_true(all(.stats %in% c("n_patients", "sum_exposure")))
+ } |
|||
| 54 | +252 | |||
| 55 | -56x | +253 | +13x |
- row_label <- if (labelstr != "") {
+ if (!is.null(facet_var) && !is.null(group_var)) {
|
| 56 | -! | +|||
| 254 | +1x |
- labelstr+ df_grp <- tidyr::expand(df, .data[[facet_var]], .data[[group_var]], .data[[x]]) # expand based on levels of factors |
||
| 57 | -56x | +255 | +12x |
- } else if (!is.null(custom_label)) {
+ } else if (!is.null(group_var)) {
|
| 58 | -48x | +256 | +11x |
- custom_label+ df_grp <- tidyr::expand(df, .data[[group_var]], .data[[x]]) # expand based on levels of factors |
| 59 | +257 |
} else {
|
||
| 60 | -8x | +258 | +1x |
- "Total patients numbers/person time"+ df_grp <- tidyr::expand(df, NULL, .data[[x]]) |
| 61 | +259 |
} |
||
| 62 | +260 | |||
| 63 | -56x | -
- y <- list()- |
- ||
| 64 | -+ | 261 | +13x |
-
+ df_grp <- df_grp %>% |
| 65 | -56x | +262 | +13x |
- if ("n_patients" %in% .stats) {
+ dplyr::full_join(y = df[, c(facet_var, group_var, x, y)], by = c(facet_var, group_var, x), multiple = "all") %>% |
| 66 | -23x | +263 | +13x |
- y$n_patients <-+ dplyr::group_by_at(c(facet_var, group_var, x)) |
| 67 | -23x | +|||
| 264 | +
- formatters::with_label(+ |
|||
| 68 | -23x | +265 | +13x |
- s_num_patients_content(+ df_stats <- df_grp %>% |
| 69 | -23x | +266 | +13x |
- df = df,+ dplyr::summarise( |
| 70 | -23x | +267 | +13x |
- .N_col = .N_col, # nolint+ data.frame(t(do.call(c, unname(sfun(.data[[y]])[c(mid, interval)])))), |
| 71 | -23x | +268 | +13x |
- .var = id,+ .groups = "drop" |
| 72 | -23x | +|||
| 269 | +
- labelstr = ""+ ) |
|||
| 73 | -23x | +|||
| 270 | +
- )$unique,+ |
|||
| 74 | -23x | +271 | +13x |
- row_label+ df_stats <- df_stats[!is.na(df_stats[[mid]]), ] |
| 75 | +272 |
- )+ |
||
| 76 | +273 |
- }+ # add number of objects N in group_var (strata) |
||
| 77 | -56x | +274 | +13x |
- if ("sum_exposure" %in% .stats) {
+ if (!is.null(group_var) && !is.null(alt_counts_df)) {
|
| 78 | -34x | +275 | +8x |
- y$sum_exposure <- formatters::with_label(sum(df[[ex_var]]), row_label)+ strata_N <- paste0(group_var, "_N") # nolint |
| 79 | +276 |
- }+ |
||
| 80 | -56x | +277 | +8x |
- y+ df_N <- stats::aggregate(eval(parse(text = subject_var)) ~ eval(parse(text = group_var)), data = alt_counts_df, FUN = function(x) length(unique(x))) # nolint |
| 81 | -+ | |||
| 278 | +8x |
- }+ colnames(df_N) <- c(group_var, "N") # nolint+ |
+ ||
| 279 | +8x | +
+ df_N[[strata_N]] <- paste0(df_N[[group_var]], " (N = ", df_N$N, ")") # nolint |
||
| 82 | +280 | |||
| 83 | +281 |
- #' @describeIn summarize_patients_exposure_in_cols Analysis function which is used as `afun` in+ # keep strata factor levels |
||
| 84 | -+ | |||
| 282 | +8x |
- #' [rtables::analyze_colvars()] within `analyze_patients_exposure_in_cols()` and as `cfun` in+ matches <- sapply(unique(df_N[[group_var]]), function(x) {
|
||
| 85 | -+ | |||
| 283 | +22x |
- #' [rtables::summarize_row_groups()] within `summarize_patients_exposure_in_cols()`.+ regex_pattern <- gsub("([][(){}^$.|*+?\\\\])", "\\\\\\1", x)
|
||
| 86 | -+ | |||
| 284 | +22x |
- #'+ unique(df_N[[paste0(group_var, "_N")]])[grepl( |
||
| 87 | -+ | |||
| 285 | +22x |
- #' @return+ paste0("^", regex_pattern),
|
||
| 88 | -+ | |||
| 286 | +22x |
- #' * `a_count_patients_sum_exposure()` returns formatted [rtables::CellValue()].+ unique(df_N[[paste0(group_var, "_N")]]) |
||
| 89 | +287 |
- #'+ )] |
||
| 90 | +288 |
- #' @examples+ }) |
||
| 91 | -+ | |||
| 289 | +8x |
- #' a_count_patients_sum_exposure(+ df_N[[paste0(group_var, "_N")]] <- factor(df_N[[group_var]]) # nolint |
||
| 92 | -+ | |||
| 290 | +8x |
- #' df = df,+ levels(df_N[[paste0(group_var, "_N")]]) <- unlist(matches) # nolint |
||
| 93 | +291 |
- #' var = "SEX",+ |
||
| 94 | +292 |
- #' .N_col = nrow(df),+ # strata_N should not be in colnames(df_stats) |
||
| 95 | -+ | |||
| 293 | +8x |
- #' .stats = "n_patients"+ checkmate::assert_disjunct(strata_N, colnames(df_stats)) |
||
| 96 | +294 |
- #' )+ |
||
| 97 | -+ | |||
| 295 | +8x |
- #'+ df_stats <- merge(x = df_stats, y = df_N[, c(group_var, strata_N)], by = group_var) |
||
| 98 | -+ | |||
| 296 | +5x |
- #' @export+ } else if (!is.null(group_var)) {
|
||
| 99 | -+ | |||
| 297 | +4x |
- a_count_patients_sum_exposure <- function(df,+ strata_N <- group_var # nolint |
||
| 100 | +298 |
- var = NULL,+ } else {
|
||
| 101 | -+ | |||
| 299 | +1x |
- ex_var = "AVAL",+ strata_N <- NULL # nolint |
||
| 102 | +300 |
- id = "USUBJID",+ } |
||
| 103 | +301 |
- add_total_level = FALSE,+ |
||
| 104 | +302 |
- custom_label = NULL,+ ############################################### | |
||
| 105 | +303 |
- labelstr = "",+ # ---- Prepare certain plot's properties. ---- |
||
| 106 | +304 |
- .N_col, # nolint+ ############################################### | |
||
| 107 | +305 |
- .stats,+ # legend title |
||
| 108 | -+ | |||
| 306 | +13x |
- .formats = list(n_patients = "xx (xx.x%)", sum_exposure = "xx")) {
+ if (is.null(legend_title) && !is.null(group_var) && legend_position != "none") {
|
||
| 109 | -32x | +307 | +12x |
- checkmate::assert_flag(add_total_level)+ legend_title <- attr(df[[group_var]], "label") |
| 110 | +308 | ++ |
+ }+ |
+ |
| 309 | ||||
| 310 | ++ |
+ # y label+ |
+ ||
| 111 | -32x | +311 | +13x |
- if (!is.null(var)) {
+ if (!is.null(y_lab)) {
|
| 112 | -21x | +312 | +4x |
- assert_df_with_variables(df, list(var = var))+ if (y_lab_add_paramcd) {
|
| 113 | -21x | +313 | +4x |
- df[[var]] <- as.factor(df[[var]])+ y_lab <- paste(y_lab, unique(df[[paramcd]])) |
| 114 | +314 |
- }+ } |
||
| 115 | +315 | |||
| 116 | -32x | +316 | +4x |
- y <- list()+ if (y_lab_add_unit) {
|
| 117 | -32x | +317 | +4x |
- if (is.null(var)) {
+ y_lab <- paste0(y_lab, " (", unique(df[[y_unit]]), ")")
|
| 118 | -11x | +|||
| 318 | +
- y[[.stats]] <- list(Total = s_count_patients_sum_exposure(+ } |
|||
| 119 | -11x | +|||
| 319 | +
- df = df,+ |
|||
| 120 | -11x | +320 | +4x |
- ex_var = ex_var,+ y_lab <- trimws(y_lab) |
| 121 | -11x | +|||
| 321 | +
- id = id,+ } |
|||
| 122 | -11x | +|||
| 322 | +
- labelstr = labelstr,+ |
|||
| 123 | -11x | +|||
| 323 | +
- .N_col = .N_col,+ # subtitle |
|||
| 124 | -11x | +324 | +13x |
- .stats = .stats,+ if (!is.null(subtitle)) {
|
| 125 | -11x | +325 | +13x |
- custom_label = custom_label+ if (subtitle_add_paramcd) {
|
| 126 | -11x | +326 | +13x |
- )[[.stats]])+ subtitle <- paste(subtitle, unique(df[[paramcd]])) |
| 127 | +327 |
- } else {
+ } |
||
| 128 | -21x | +|||
| 328 | +
- for (lvl in levels(df[[var]])) {
+
|
|||
| 129 | -42x | +329 | +13x |
- y[[.stats]][[lvl]] <- s_count_patients_sum_exposure(+ if (subtitle_add_unit) {
|
| 130 | -42x | +330 | +13x |
- df = subset(df, get(var) == lvl),+ subtitle <- paste0(subtitle, " (", unique(df[[y_unit]]), ")")
|
| 131 | -42x | +|||
| 331 | +
- ex_var = ex_var,+ } |
|||
| 132 | -42x | +|||
| 332 | +
- id = id,+ |
|||
| 133 | -42x | +333 | +13x |
- labelstr = labelstr,+ subtitle <- trimws(subtitle) |
| 134 | -42x | +|||
| 334 | +
- .N_col = .N_col,+ } |
|||
| 135 | -42x | +|||
| 335 | +
- .stats = .stats,+ |
|||
| 136 | -42x | +|||
| 336 | +
- custom_label = lvl+ ############################### | |
|||
| 137 | -42x | +|||
| 337 | +
- )[[.stats]]+ # ---- Build plot object. ---- |
|||
| 138 | +338 |
- }+ ############################### | |
||
| 139 | -21x | +339 | +13x |
- if (add_total_level) {
+ p <- ggplot2::ggplot( |
| 140 | -2x | +340 | +13x |
- y[[.stats]][["Total"]] <- s_count_patients_sum_exposure(+ data = df_stats, |
| 141 | -2x | +341 | +13x |
- df = df,+ mapping = ggplot2::aes( |
| 142 | -2x | +342 | +13x |
- ex_var = ex_var,+ x = .data[[x]], y = .data[[mid]], |
| 143 | -2x | +343 | +13x |
- id = id,+ color = if (is.null(strata_N)) NULL else .data[[strata_N]], |
| 144 | -2x | +344 | +13x |
- labelstr = labelstr,+ shape = if (is.null(strata_N)) NULL else .data[[strata_N]], |
| 145 | -2x | +345 | +13x |
- .N_col = .N_col,+ lty = if (is.null(strata_N)) NULL else .data[[strata_N]], |
| 146 | -2x | +346 | +13x |
- .stats = .stats,+ group = if (is.null(strata_N)) NULL else .data[[strata_N]] |
| 147 | -2x | +|||
| 347 | +
- custom_label = custom_label+ ) |
|||
| 148 | -2x | +|||
| 348 | +
- )[[.stats]]+ ) |
|||
| 149 | +349 |
- }+ + |
+ ||
| 350 | +13x | +
+ if (!is.null(group_var) && nlevels(df_stats[[strata_N]]) > 6) {
+ |
+ ||
| 351 | +1x | +
+ p <- p ++ |
+ ||
| 352 | +1x | +
+ scale_shape_manual(values = seq(15, 15 + nlevels(df_stats[[strata_N]]))) |
||
| 150 | +353 |
} |
||
| 151 | +354 | |||
| 152 | -32x | +355 | +13x |
- in_rows(.list = y[[.stats]], .formats = .formats[[.stats]])+ if (!is.null(mid)) {
|
| 153 | +356 |
- }+ # points |
||
| 154 | -+ | |||
| 357 | +13x |
-
+ if (grepl("p", mid_type, fixed = TRUE)) {
|
||
| 155 | -+ | |||
| 358 | +13x |
- #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics+ p <- p + ggplot2::geom_point(position = position, size = mid_point_size, na.rm = TRUE) |
||
| 156 | +359 |
- #' function arguments and additional format arguments. This function is a wrapper for+ } |
||
| 157 | +360 |
- #' [rtables::split_cols_by_multivar()] and [rtables::summarize_row_groups()].+ |
||
| 158 | +361 |
- #'+ # lines - plotted only if there is a strata grouping (group_var) |
||
| 159 | -+ | |||
| 362 | +13x |
- #' @return+ if (grepl("l", mid_type, fixed = TRUE) && !is.null(strata_N)) { # nolint
|
||
| 160 | -+ | |||
| 363 | +12x |
- #' * `summarize_patients_exposure_in_cols()` returns a layout object suitable for passing to further+ p <- p + ggplot2::geom_line(position = position, na.rm = TRUE) |
||
| 161 | +364 |
- #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will+ } |
||
| 162 | +365 |
- #' add formatted content rows, with the statistics from `s_count_patients_sum_exposure()` arranged in+ } |
||
| 163 | +366 |
- #' columns, to the table layout.+ |
||
| 164 | +367 |
- #'+ # interval |
||
| 165 | -+ | |||
| 368 | +13x |
- #' @examples+ if (!is.null(interval)) {
|
||
| 166 | -+ | |||
| 369 | +13x |
- #' lyt5 <- basic_table() %>%+ p <- p + |
||
| 167 | -+ | |||
| 370 | +13x |
- #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE)+ ggplot2::geom_errorbar( |
||
| 168 | -+ | |||
| 371 | +13x |
- #'+ ggplot2::aes(ymin = .data[[whiskers[1]]], ymax = .data[[whiskers[max(1, length(whiskers))]]]), |
||
| 169 | -+ | |||
| 372 | +13x |
- #' result5 <- build_table(lyt5, df = df, alt_counts_df = adsl)+ width = errorbar_width, |
||
| 170 | -+ | |||
| 373 | +13x |
- #' result5+ position = position |
||
| 171 | +374 |
- #'+ ) |
||
| 172 | +375 |
- #' lyt6 <- basic_table() %>%+ |
||
| 173 | -+ | |||
| 376 | +13x |
- #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE, .stats = "sum_exposure")+ if (length(whiskers) == 1) { # lwr or upr only; mid is then required
|
||
| 174 | +377 |
- #'+ # workaround as geom_errorbar does not provide single-direction whiskers |
||
| 175 | -+ | |||
| 378 | +! |
- #' result6 <- build_table(lyt6, df = df, alt_counts_df = adsl)+ p <- p + |
||
| 176 | -+ | |||
| 379 | +! |
- #' result6+ ggplot2::geom_linerange( |
||
| 177 | -+ | |||
| 380 | +! |
- #'+ data = df_stats[!is.na(df_stats[[whiskers]]), ], # as na.rm =TRUE does not suppress warnings |
||
| 178 | -+ | |||
| 381 | +! |
- #' @export+ ggplot2::aes(ymin = .data[[mid]], ymax = .data[[whiskers]]), |
||
| 179 | -+ | |||
| 382 | +! |
- #' @order 3+ position = position, |
||
| 180 | -+ | |||
| 383 | +! |
- summarize_patients_exposure_in_cols <- function(lyt, # nolint+ na.rm = TRUE, |
||
| 181 | -+ | |||
| 384 | +! |
- var,+ show.legend = FALSE |
||
| 182 | +385 |
- ex_var = "AVAL",+ ) |
||
| 183 | +386 |
- id = "USUBJID",+ } |
||
| 184 | +387 |
- add_total_level = FALSE,+ } |
||
| 185 | +388 |
- custom_label = NULL,+ |
||
| 186 | -+ | |||
| 389 | +13x |
- col_split = TRUE,+ if (is.numeric(df_stats[[x]])) {
|
||
| 187 | -+ | |||
| 390 | +1x |
- na_str = default_na_str(),+ if (length(xticks) == 1) xticks <- seq(from = min(df_stats[[x]]), to = max(df_stats[[x]]), by = xticks) |
||
| 188 | -+ | |||
| 391 | +1x |
- ...,+ p <- p + ggplot2::scale_x_continuous(breaks = if (!is.null(xticks)) xticks else waiver(), limits = xlim) |
||
| 189 | +392 |
- .stats = c("n_patients", "sum_exposure"),
+ } |
||
| 190 | +393 |
- .labels = c(n_patients = "Patients", sum_exposure = "Person time"),+ |
||
| 191 | -+ | |||
| 394 | +13x |
- .indent_mods = NULL) {
+ p <- p + |
||
| 192 | -3x | +395 | +13x |
- extra_args <- list(ex_var = ex_var, id = id, add_total_level = add_total_level, custom_label = custom_label, ...)+ ggplot2::scale_y_continuous(labels = scales::comma, limits = ylim) + |
| 193 | -+ | |||
| 396 | +13x |
-
+ ggplot2::labs( |
||
| 194 | -3x | +397 | +13x |
- if (col_split) {
+ title = title, |
| 195 | -3x | +398 | +13x |
- lyt <- split_cols_by_multivar(+ subtitle = subtitle, |
| 196 | -3x | +399 | +13x |
- lyt = lyt,+ caption = caption, |
| 197 | -3x | +400 | +13x |
- vars = rep(var, length(.stats)),+ color = legend_title, |
| 198 | -3x | +401 | +13x |
- varlabels = .labels[.stats],+ lty = legend_title, |
| 199 | -3x | +402 | +13x |
- extra_args = list(.stats = .stats)+ shape = legend_title,+ |
+
| 403 | +13x | +
+ x = x_lab,+ |
+ ||
| 404 | +13x | +
+ y = y_lab |
||
| 200 | +405 |
) |
||
| 201 | +406 |
- }+ |
||
| 202 | -3x | +407 | +13x |
- summarize_row_groups(+ if (!is.null(col)) {
|
| 203 | -3x | +408 | +1x |
- lyt = lyt,+ p <- p + |
| 204 | -3x | +409 | +1x |
- var = var,+ ggplot2::scale_color_manual(values = col) |
| 205 | -3x | +|||
| 410 | +
- cfun = a_count_patients_sum_exposure,+ } |
|||
| 206 | -3x | +411 | +13x |
- na_str = na_str,+ if (!is.null(linetype)) {
|
| 207 | -3x | +412 | +1x |
- extra_args = extra_args+ p <- p + |
| 208 | -+ | |||
| 413 | +1x |
- )+ ggplot2::scale_linetype_manual(values = linetype) |
||
| 209 | +414 |
- }+ } |
||
| 210 | +415 | |||
| 211 | -+ | |||
| 416 | +13x |
- #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics+ if (!is.null(facet_var)) {
|
||
| 212 | -+ | |||
| 417 | +1x |
- #' function arguments and additional format arguments. This function is a wrapper for+ p <- p + |
||
| 213 | -+ | |||
| 418 | +1x |
- #' [rtables::split_cols_by_multivar()] and [rtables::analyze_colvars()].+ facet_grid(cols = vars(df_stats[[facet_var]])) |
||
| 214 | +419 |
- #'+ } |
||
| 215 | +420 |
- #' @param col_split (`flag`)\cr whether the columns should be split. Set to `FALSE` when the required+ |
||
| 216 | -+ | |||
| 421 | +13x |
- #' column split has been done already earlier in the layout pipe.+ if (!is.null(ggtheme)) {
|
||
| 217 | -+ | |||
| 422 | +13x |
- #'+ p <- p + ggtheme |
||
| 218 | +423 |
- #' @return+ } else {
|
||
| 219 | -+ | |||
| 424 | +! |
- #' * `analyze_patients_exposure_in_cols()` returns a layout object suitable for passing to further+ p <- p + |
||
| 220 | -+ | |||
| 425 | +! |
- #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will+ ggplot2::theme_bw() + |
||
| 221 | -+ | |||
| 426 | +! |
- #' add formatted data rows, with the statistics from `s_count_patients_sum_exposure()` arranged in+ ggplot2::theme( |
||
| 222 | -+ | |||
| 427 | +! |
- #' columns, to the table layout.+ legend.key.width = grid::unit(1, "cm"), |
||
| 223 | -+ | |||
| 428 | +! |
- #'+ legend.position = legend_position, |
||
| 224 | -+ | |||
| 429 | +! |
- #' @note As opposed to [summarize_patients_exposure_in_cols()] which generates content rows,+ legend.direction = ifelse( |
||
| 225 | -+ | |||
| 430 | +! |
- #' `analyze_patients_exposure_in_cols()` generates data rows which will _not_ be repeated on multiple+ legend_position %in% c("top", "bottom"),
|
||
| 226 | -+ | |||
| 431 | +! |
- #' pages when pagination is used.+ "horizontal", |
||
| 227 | -+ | |||
| 432 | +! |
- #'+ "vertical" |
||
| 228 | +433 |
- #' @examples+ ) |
||
| 229 | +434 |
- #' set.seed(1)+ ) |
||
| 230 | +435 |
- #' df <- data.frame(+ } |
||
| 231 | +436 |
- #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
+
|
||
| 232 | +437 |
- #' ARMCD = c(rep("ARM A", 6), rep("ARM B", 6)),
+ ############################################################# | |
||
| 233 | +438 |
- #' SEX = c(rep("Female", 6), rep("Male", 6)),
+ # ---- Optionally, add table to the bottom of the plot. ---- |
||
| 234 | +439 |
- #' AVAL = as.numeric(sample(seq(1, 20), 12)),+ ############################################################# | |
||
| 235 | -+ | |||
| 440 | +13x |
- #' stringsAsFactors = TRUE+ if (!is.null(table)) {
|
||
| 236 | -+ | |||
| 441 | +5x |
- #' )+ df_stats_table <- df_grp %>% |
||
| 237 | -+ | |||
| 442 | +5x |
- #' adsl <- data.frame(+ dplyr::summarise( |
||
| 238 | -+ | |||
| 443 | +5x |
- #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
+ h_format_row( |
||
| 239 | -+ | |||
| 444 | +5x |
- #' ARMCD = c(rep("ARM A", 2), rep("ARM B", 2)),
+ x = sfun(.data[[y]], ...)[table], |
||
| 240 | -+ | |||
| 445 | +5x |
- #' SEX = c(rep("Female", 2), rep("Male", 2)),
+ format = table_format, |
||
| 241 | -+ | |||
| 446 | +5x |
- #' stringsAsFactors = TRUE+ labels = table_labels |
||
| 242 | +447 |
- #' )+ ), |
||
| 243 | -+ | |||
| 448 | +5x |
- #'+ .groups = "drop" |
||
| 244 | +449 |
- #' lyt <- basic_table() %>%+ ) |
||
| 245 | +450 |
- #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
+
|
||
| 246 | -+ | |||
| 451 | +5x |
- #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) %>%+ stats_lev <- rev(setdiff(colnames(df_stats_table), c(group_var, x))) |
||
| 247 | +452 |
- #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE)+ |
||
| 248 | -+ | |||
| 453 | +5x |
- #' result <- build_table(lyt, df = df, alt_counts_df = adsl)+ df_stats_table <- df_stats_table %>% |
||
| 249 | -+ | |||
| 454 | +5x |
- #' result+ tidyr::pivot_longer( |
||
| 250 | -+ | |||
| 455 | +5x |
- #'+ cols = -dplyr::all_of(c(group_var, x)), |
||
| 251 | -+ | |||
| 456 | +5x |
- #' lyt2 <- basic_table() %>%+ names_to = "stat", |
||
| 252 | -+ | |||
| 457 | +5x |
- #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
+ values_to = "value", |
||
| 253 | -+ | |||
| 458 | +5x |
- #' summarize_patients_exposure_in_cols(+ names_ptypes = list(stat = factor(levels = stats_lev)) |
||
| 254 | +459 |
- #' var = "AVAL", col_split = TRUE,+ ) |
||
| 255 | +460 |
- #' .stats = "n_patients", custom_label = "some custom label"+ |
||
| 256 | -+ | |||
| 461 | +5x |
- #' ) %>%+ tbl <- ggplot2::ggplot( |
||
| 257 | -+ | |||
| 462 | +5x |
- #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE, ex_var = "AVAL")+ df_stats_table, |
||
| 258 | -+ | |||
| 463 | +5x |
- #' result2 <- build_table(lyt2, df = df, alt_counts_df = adsl)+ ggplot2::aes(x = .data[[x]], y = .data[["stat"]], label = .data[["value"]]) |
||
| 259 | +464 |
- #' result2+ ) + |
||
| 260 | -+ | |||
| 465 | +5x |
- #'+ ggplot2::geom_text(size = table_font_size) + |
||
| 261 | -+ | |||
| 466 | +5x |
- #' lyt3 <- basic_table() %>%+ ggplot2::theme_bw() + |
||
| 262 | -+ | |||
| 467 | +5x |
- #' analyze_patients_exposure_in_cols(var = "SEX", col_split = TRUE, ex_var = "AVAL")+ ggplot2::theme( |
||
| 263 | -+ | |||
| 468 | +5x |
- #' result3 <- build_table(lyt3, df = df, alt_counts_df = adsl)+ panel.border = ggplot2::element_blank(), |
||
| 264 | -+ | |||
| 469 | +5x |
- #' result3+ panel.grid.major = ggplot2::element_blank(), |
||
| 265 | -+ | |||
| 470 | +5x |
- #'+ panel.grid.minor = ggplot2::element_blank(), |
||
| 266 | -+ | |||
| 471 | +5x |
- #' # Adding total levels and custom label+ axis.ticks = ggplot2::element_blank(), |
||
| 267 | -+ | |||
| 472 | +5x |
- #' lyt4 <- basic_table(+ axis.title = ggplot2::element_blank(), |
||
| 268 | -+ | |||
| 473 | +5x |
- #' show_colcounts = TRUE+ axis.text.x = ggplot2::element_blank(), |
||
| 269 | -+ | |||
| 474 | +5x |
- #' ) %>%+ axis.text.y = ggplot2::element_text( |
||
| 270 | -+ | |||
| 475 | +5x |
- #' analyze_patients_exposure_in_cols(+ size = table_font_size * ggplot2::.pt, |
||
| 271 | -+ | |||
| 476 | +5x |
- #' var = "ARMCD",+ margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 5) |
||
| 272 | +477 |
- #' col_split = TRUE,+ ), |
||
| 273 | -+ | |||
| 478 | +5x |
- #' add_total_level = TRUE,+ strip.text = ggplot2::element_text(hjust = 0), |
||
| 274 | -+ | |||
| 479 | +5x |
- #' custom_label = "TOTAL"+ strip.text.x = ggplot2::element_text( |
||
| 275 | -+ | |||
| 480 | +5x |
- #' ) %>%+ size = table_font_size * ggplot2::.pt, |
||
| 276 | -+ | |||
| 481 | +5x |
- #' append_topleft(c("", "Sex"))
+ margin = ggplot2::margin(1.5, 0, 1.5, 0, "pt") |
||
| 277 | +482 |
- #'+ ), |
||
| 278 | -+ | |||
| 483 | +5x |
- #' result4 <- build_table(lyt4, df = df, alt_counts_df = adsl)+ strip.background = ggplot2::element_rect(fill = "grey95", color = NA), |
||
| 279 | -+ | |||
| 484 | +5x |
- #' result4+ legend.position = "none" |
||
| 280 | +485 |
- #'+ ) |
||
| 281 | +486 |
- #' @export+ |
||
| 282 | -+ | |||
| 487 | +5x |
- #' @order 2+ if (!is.null(group_var)) {
|
||
| 283 | -+ | |||
| 488 | +5x |
- analyze_patients_exposure_in_cols <- function(lyt, # nolint- |
- ||
| 284 | -- |
- var = NULL,- |
- ||
| 285 | -- |
- ex_var = "AVAL",- |
- ||
| 286 | -- |
- id = "USUBJID",- |
- ||
| 287 | -- |
- add_total_level = FALSE,- |
- ||
| 288 | -- |
- custom_label = NULL,- |
- ||
| 289 | -- |
- col_split = TRUE,- |
- ||
| 290 | -- |
- na_str = default_na_str(),- |
- ||
| 291 | -- |
- .stats = c("n_patients", "sum_exposure"),
- |
- ||
| 292 | -- |
- .labels = c(n_patients = "Patients", sum_exposure = "Person time"),+ tbl <- tbl + ggplot2::facet_wrap(facets = group_var, ncol = 1) |
||
| 293 | +489 |
- .indent_mods = 0L,+ } |
||
| 294 | +490 |
- ...) {
- |
- ||
| 295 | -6x | -
- extra_args <- list(+ |
||
| 296 | -6x | +491 | +5x |
- var = var, ex_var = ex_var, id = id, add_total_level = add_total_level, custom_label = custom_label, ...+ if (!as_list) {
|
| 297 | +492 |
- )+ # align plot and table |
||
| 298 | -+ | |||
| 493 | +4x |
-
+ cowplot::plot_grid( |
||
| 299 | -6x | +494 | +4x |
- if (col_split) {
+ p, |
| 300 | +495 | 4x |
- lyt <- split_cols_by_multivar(+ tbl, |
|
| 301 | +496 | 4x |
- lyt = lyt,+ ncol = 1, |
|
| 302 | +497 | 4x |
- vars = rep(ex_var, length(.stats)),+ align = "v", |
|
| 303 | +498 | 4x |
- varlabels = .labels[.stats],+ axis = "tblr", |
|
| 304 | +499 | 4x |
- extra_args = list(.stats = .stats)+ rel_heights = c(rel_height_plot, 1 - rel_height_plot) |
|
| 305 | +500 |
- )+ ) |
||
| 306 | +501 |
- }- |
- ||
| 307 | -6x | -
- lyt <- lyt %>% analyze_colvars(- |
- ||
| 308 | -6x | -
- afun = a_count_patients_sum_exposure,- |
- ||
| 309 | -6x | -
- indent_mod = .indent_mods,- |
- ||
| 310 | -6x | -
- na_str = na_str,+ } else {
|
||
| 311 | -6x | +502 | +1x |
- extra_args = extra_args+ list(plot = p, table = tbl) |
| 312 | +503 |
- )- |
- ||
| 313 | -6x | -
- lyt+ } |
||
| 314 | +504 |
- }+ } else {
|
| 1 | -+ | |||
| 505 | +8x |
- #' Helper functions for multivariate logistic regression+ p |
||
| 2 | +506 |
- #'+ } |
||
| 3 | +507 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 4 | +508 |
- #'+ |
||
| 5 | +509 |
- #' Helper functions used in calculations for logistic regression.+ #' Helper function to format the optional `g_lineplot` table |
||
| 6 | +510 |
#' |
||
| 7 | -- |
- #' @inheritParams argument_convention- |
- ||
| 8 | -- |
- #' @param fit_glm (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family.- |
- ||
| 9 | +511 |
- #' Limited functionality is also available for conditional logistic regression models fitted by+ #' @description `r lifecycle::badge("stable")`
|
||
| 10 | +512 |
- #' [survival::clogit()], currently this is used only by [extract_rsp_biomarkers()].+ #' |
||
| 11 | +513 |
- #' @param x (`character`)\cr a variable or interaction term in `fit_glm` (depending on the helper function used).+ #' @param x (named `list`)\cr list of numerical values to be formatted and optionally labeled. |
||
| 12 | +514 |
- #'+ #' Elements of `x` must be `numeric` vectors. |
||
| 13 | +515 |
- #' @examples+ #' @param format (named `character` or `NULL`)\cr format patterns for `x`. Names of the `format` must |
||
| 14 | +516 |
- #' library(dplyr)+ #' match the names of `x`. This parameter is passed directly to the `rtables::format_rcell` |
||
| 15 | +517 |
- #' library(broom)+ #' function through the `format` parameter. |
||
| 16 | +518 |
- #'+ #' @param labels (named `character` or `NULL`)\cr optional labels for `x`. Names of the `labels` must |
||
| 17 | +519 |
- #' adrs_f <- tern_ex_adrs %>%+ #' match the names of `x`. When a label is not specified for an element of `x`, |
||
| 18 | +520 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' then this function tries to use `label` or `names` (in this order) attribute of that element |
||
| 19 | +521 |
- #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ #' (depending on which one exists and it is not `NULL` or `NA` or `NaN`). If none of these attributes |
||
| 20 | +522 |
- #' mutate(+ #' are attached to a given element of `x`, then the label is automatically generated. |
||
| 21 | +523 |
- #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ #' |
||
| 22 | +524 |
- #' RACE = factor(RACE),+ #' @return A single row `data.frame` object. |
||
| 23 | +525 |
- #' SEX = factor(SEX)+ #' |
||
| 24 | +526 |
- #' )+ #' @examples |
||
| 25 | +527 |
- #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ #' mean_ci <- c(48, 51) |
||
| 26 | +528 |
- #' mod1 <- fit_logistic(+ #' x <- list(mean = 50, mean_ci = mean_ci) |
||
| 27 | +529 |
- #' data = adrs_f,+ #' format <- c(mean = "xx.x", mean_ci = "(xx.xx, xx.xx)") |
||
| 28 | +530 |
- #' variables = list(+ #' labels <- c(mean = "My Mean") |
||
| 29 | +531 |
- #' response = "Response",+ #' h_format_row(x, format, labels) |
||
| 30 | +532 |
- #' arm = "ARMCD",+ #' |
||
| 31 | +533 |
- #' covariates = c("AGE", "RACE")
+ #' attr(mean_ci, "label") <- "Mean 95% CI" |
||
| 32 | +534 |
- #' )+ #' x <- list(mean = 50, mean_ci = mean_ci) |
||
| 33 | +535 |
- #' )+ #' h_format_row(x, format, labels) |
||
| 34 | +536 |
- #' mod2 <- fit_logistic(+ #' |
||
| 35 | +537 |
- #' data = adrs_f,+ #' @export |
||
| 36 | +538 |
- #' variables = list(+ h_format_row <- function(x, format, labels = NULL) {
|
||
| 37 | +539 |
- #' response = "Response",+ # cell: one row, one column data.frame |
||
| 38 | -+ | |||
| 540 | +92x |
- #' arm = "ARMCD",+ format_cell <- function(x, format, label = NULL) {
|
||
| 39 | -+ | |||
| 541 | +238x |
- #' covariates = c("AGE", "RACE"),
+ fc <- format_rcell(x = x, format = unlist(format)) |
||
| 40 | -+ | |||
| 542 | +238x |
- #' interaction = "AGE"+ if (is.na(fc)) {
|
||
| 41 | -+ | |||
| 543 | +! |
- #' )+ fc <- "NA" |
||
| 42 | +544 |
- #' )+ } |
||
| 43 | -+ | |||
| 545 | +238x |
- #'+ x_label <- attr(x, "label") |
||
| 44 | -+ | |||
| 546 | +238x |
- #' @name h_logistic_regression+ if (!is.null(label) && !is.na(label)) {
|
||
| 45 | -+ | |||
| 547 | +236x |
- NULL+ names(fc) <- label |
||
| 46 | -+ | |||
| 548 | +2x |
-
+ } else if (!is.null(x_label) && !is.na(x_label)) {
|
||
| 47 | -+ | |||
| 549 | +1x |
- #' @describeIn h_logistic_regression Helper function to extract interaction variable names from a fitted+ names(fc) <- x_label |
||
| 48 | -+ | |||
| 550 | +1x |
- #' model assuming only one interaction term.+ } else if (length(x) == length(fc)) {
|
||
| 49 | -+ | |||
| 551 | +! |
- #'+ names(fc) <- names(x) |
||
| 50 | +552 |
- #' @return Vector of names of interaction variables.+ } |
||
| 51 | -+ | |||
| 553 | +238x |
- #'+ as.data.frame(t(fc)) |
||
| 52 | +554 |
- #' @export+ } |
||
| 53 | +555 |
- h_get_interaction_vars <- function(fit_glm) {
- |
- ||
| 54 | -34x | -
- checkmate::assert_class(fit_glm, "glm")+ |
||
| 55 | -34x | +556 | +92x |
- terms_name <- attr(stats::terms(fit_glm), "term.labels")+ row <- do.call( |
| 56 | -34x | +557 | +92x |
- terms_order <- attr(stats::terms(fit_glm), "order")+ cbind, |
| 57 | -34x | +558 | +92x |
- interaction_term <- terms_name[terms_order == 2]+ lapply( |
| 58 | -34x | +559 | +92x |
- checkmate::assert_string(interaction_term)+ names(x), function(xn) format_cell(x[[xn]], format = format[xn], label = labels[xn]) |
| 59 | -34x | +|||
| 560 | +
- strsplit(interaction_term, split = ":")[[1]]+ ) |
|||
| 60 | +561 |
- }+ ) |
||
| 61 | +562 | |||
| 62 | -+ | |||
| 563 | +92x |
- #' @describeIn h_logistic_regression Helper function to get the right coefficient name from the+ row |
||
| 63 | +564 |
- #' interaction variable names and the given levels. The main value here is that the order+ } |
||
| 64 | +565 |
- #' of first and second variable is checked in the `interaction_vars` input.+ |
||
| 65 | +566 |
- #'+ #' Control function for `g_lineplot()` |
||
| 66 | +567 |
- #' @param interaction_vars (`character(2)`)\cr interaction variable names.+ #' |
||
| 67 | +568 |
- #' @param first_var_with_level (`character(2)`)\cr the first variable name with the interaction level.+ #' @description `r lifecycle::badge("stable")`
|
||
| 68 | +569 |
- #' @param second_var_with_level (`character(2)`)\cr the second variable name with the interaction level.+ #' |
||
| 69 | +570 |
- #'+ #' Default values for `variables` parameter in `g_lineplot` function. |
||
| 70 | +571 |
- #' @return Name of coefficient.+ #' A variable's default value can be overwritten for any variable. |
||
| 71 | +572 |
#' |
||
| 72 | +573 |
- #' @export+ #' @param x (`string`)\cr x-variable name. |
||
| 73 | +574 |
- h_interaction_coef_name <- function(interaction_vars,+ #' @param y (`string`)\cr y-variable name. |
||
| 74 | +575 |
- first_var_with_level,+ #' @param group_var (`string` or `NA`)\cr group variable name. |
||
| 75 | +576 |
- second_var_with_level) {
- |
- ||
| 76 | -55x | -
- checkmate::assert_character(interaction_vars, len = 2, any.missing = FALSE)- |
- ||
| 77 | -55x | -
- checkmate::assert_character(first_var_with_level, len = 2, any.missing = FALSE)- |
- ||
| 78 | -55x | -
- checkmate::assert_character(second_var_with_level, len = 2, any.missing = FALSE)- |
- ||
| 79 | -55x | -
- checkmate::assert_subset(c(first_var_with_level[1], second_var_with_level[1]), interaction_vars)+ #' @param subject_var (`string` or `NA`)\cr subject variable name. |
||
| 80 | +577 | - - | -||
| 81 | -55x | -
- first_name <- paste(first_var_with_level, collapse = "")- |
- ||
| 82 | -55x | -
- second_name <- paste(second_var_with_level, collapse = "")- |
- ||
| 83 | -55x | -
- if (first_var_with_level[1] == interaction_vars[1]) {
- |
- ||
| 84 | -36x | -
- paste(first_name, second_name, sep = ":")- |
- ||
| 85 | -19x | -
- } else if (second_var_with_level[1] == interaction_vars[1]) {
- |
- ||
| 86 | -19x | -
- paste(second_name, first_name, sep = ":")+ #' @param facet_var (`string` or `NA`)\cr faceting variable name. |
||
| 87 | +578 |
- }+ #' @param paramcd (`string` or `NA`)\cr parameter code variable name. |
||
| 88 | +579 |
- }+ #' @param y_unit (`string` or `NA`)\cr y-axis unit variable name. |
||
| 89 | +580 |
-
+ #' |
||
| 90 | +581 |
- #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ #' @return A named character vector of variable names. |
||
| 91 | +582 |
- #' for the case when both the odds ratio and the interaction variable are categorical.+ #' |
||
| 92 | +583 |
- #'+ #' @examples |
||
| 93 | +584 |
- #' @param odds_ratio_var (`string`)\cr the odds ratio variable.+ #' control_lineplot_vars() |
||
| 94 | +585 |
- #' @param interaction_var (`string`)\cr the interaction variable.+ #' control_lineplot_vars(group_var = NA) |
||
| 95 | +586 |
#' |
||
| 96 | +587 |
- #' @return Odds ratio.+ #' @export |
||
| 97 | +588 |
- #'+ control_lineplot_vars <- function(x = "AVISIT", |
||
| 98 | +589 |
- #' @export+ y = "AVAL", |
||
| 99 | +590 |
- h_or_cat_interaction <- function(odds_ratio_var,+ group_var = "ARM", |
||
| 100 | +591 |
- interaction_var,+ facet_var = NA, |
||
| 101 | +592 |
- fit_glm,+ paramcd = "PARAMCD", |
||
| 102 | +593 |
- conf_level = 0.95) {
- |
- ||
| 103 | -8x | -
- interaction_vars <- h_get_interaction_vars(fit_glm)- |
- ||
| 104 | -8x | -
- checkmate::assert_string(odds_ratio_var)- |
- ||
| 105 | -8x | -
- checkmate::assert_string(interaction_var)- |
- ||
| 106 | -8x | -
- checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars)- |
- ||
| 107 | -8x | -
- checkmate::assert_vector(interaction_vars, len = 2)+ y_unit = "AVALU", |
||
| 108 | +594 |
-
+ subject_var = "USUBJID") {
|
||
| 109 | -8x | +595 | +16x |
- xs_level <- fit_glm$xlevels+ checkmate::assert_string(x) |
| 110 | -8x | +596 | +16x |
- xs_coef <- stats::coef(fit_glm)+ checkmate::assert_string(y) |
| 111 | -8x | +597 | +16x |
- xs_vcov <- stats::vcov(fit_glm)+ checkmate::assert_string(group_var, na.ok = TRUE, null.ok = TRUE) |
| 112 | -8x | +598 | +16x |
- y <- list()+ checkmate::assert_string(facet_var, na.ok = TRUE, null.ok = TRUE) |
| 113 | -8x | +599 | +16x |
- for (var_level in xs_level[[odds_ratio_var]][-1]) {
+ checkmate::assert_string(subject_var, na.ok = TRUE, null.ok = TRUE) |
| 114 | -14x | +600 | +16x |
- x <- list()+ checkmate::assert_string(paramcd, na.ok = TRUE, null.ok = TRUE) |
| 115 | -14x | +601 | +16x |
- for (ref_level in xs_level[[interaction_var]]) {
+ checkmate::assert_string(y_unit, na.ok = TRUE, null.ok = TRUE) |
| 116 | -38x | +|||
| 602 | +
- coef_names <- paste0(odds_ratio_var, var_level)+ |
|||
| 117 | -38x | +603 | +16x |
- if (ref_level != xs_level[[interaction_var]][1]) {
+ variables <- c( |
| 118 | -24x | +604 | +16x |
- interaction_coef_name <- h_interaction_coef_name(+ x = x, y = y, group_var = group_var, paramcd = paramcd, |
| 119 | -24x | +605 | +16x |
- interaction_vars,+ y_unit = y_unit, subject_var = subject_var, facet_var = facet_var |
| 120 | -24x | +|||
| 606 | +
- c(odds_ratio_var, var_level),+ ) |
|||
| 121 | -24x | +607 | +16x |
- c(interaction_var, ref_level)+ return(variables) |
| 122 | +608 |
- )+ } |
||
| 123 | -24x | +
| 1 | +
- coef_names <- c(+ #' Count number of patients and sum exposure across all patients in columns |
|||
| 124 | -24x | +|||
| 2 | +
- coef_names,+ #' |
|||
| 125 | -24x | +|||
| 3 | +
- interaction_coef_name+ #' @description `r lifecycle::badge("stable")`
|
|||
| 126 | +4 |
- )+ #' |
||
| 127 | +5 |
- }+ #' The analyze function [analyze_patients_exposure_in_cols()] creates a layout element to count total numbers of |
||
| 128 | -38x | +|||
| 6 | +
- if (length(coef_names) > 1) {
+ #' patients and sum an analysis value (i.e. exposure) across all patients in columns. |
|||
| 129 | -24x | +|||
| 7 | +
- ones <- t(c(1, 1))+ #' |
|||
| 130 | -24x | +|||
| 8 | +
- est <- as.numeric(ones %*% xs_coef[coef_names])+ #' The primary analysis variable `ex_var` is the exposure variable used to calculate the `sum_exposure` statistic. The |
|||
| 131 | -24x | +|||
| 9 | +
- se <- sqrt(as.numeric(ones %*% xs_vcov[coef_names, coef_names] %*% t(ones)))+ #' `id` variable is used to uniquely identify patients in the data such that only unique patients are counted in the |
|||
| 132 | +10 |
- } else {
+ #' `n_patients` statistic, and the `var` variable is used to create a row split if needed. The percentage returned as |
||
| 133 | -14x | +|||
| 11 | +
- est <- xs_coef[coef_names]+ #' part of the `n_patients` statistic is the proportion of all records that correspond to a unique patient. |
|||
| 134 | -14x | +|||
| 12 | +
- se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ #' |
|||
| 135 | +13 |
- }+ #' The summarize function [summarize_patients_exposure_in_cols()] performs the same function as |
||
| 136 | -38x | +|||
| 14 | +
- or <- exp(est)+ #' [analyze_patients_exposure_in_cols()] except it creates content rows, not data rows, to summarize the current table |
|||
| 137 | -38x | +|||
| 15 | +
- ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ #' row/column context and operates on the level of the latest row split or the root of the table if no row splits have |
|||
| 138 | -38x | +|||
| 16 | +
- x[[ref_level]] <- list(or = or, ci = ci)+ #' occurred. |
|||
| 139 | +17 |
- }+ #' |
||
| 140 | -14x | +|||
| 18 | +
- y[[var_level]] <- x+ #' If a column split has not yet been performed in the table, `col_split` must be set to `TRUE` for the first call of |
|||
| 141 | +19 |
- }+ #' [analyze_patients_exposure_in_cols()] or [summarize_patients_exposure_in_cols()]. |
||
| 142 | -8x | +|||
| 20 | +
- y+ #' |
|||
| 143 | +21 |
- }+ #' @inheritParams argument_convention |
||
| 144 | +22 |
-
+ #' @param ex_var (`string`)\cr name of the variable in `df` containing exposure values. |
||
| 145 | +23 |
- #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty, this will be used as label. |
||
| 146 | +24 |
- #' for the case when either the odds ratio or the interaction variable is continuous.+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 147 | +25 |
#' |
||
| 148 | +26 |
- #' @param at (`numeric` or `NULL`)\cr optional values for the interaction variable. Otherwise+ #' Options are: ``r shQuote(get_stats("analyze_patients_exposure_in_cols"), type = "sh")``
|
||
| 149 | +27 |
- #' the median is used.+ #' |
||
| 150 | +28 |
- #'+ #' @name summarize_patients_exposure_in_cols |
||
| 151 | +29 |
- #' @return Odds ratio.+ #' @order 1 |
||
| 152 | +30 |
- #'+ NULL |
||
| 153 | +31 |
- #' @note We don't provide a function for the case when both variables are continuous because+ |
||
| 154 | +32 |
- #' this does not arise in this table, as the treatment arm variable will always be involved+ #' @describeIn summarize_patients_exposure_in_cols Statistics function which counts numbers |
||
| 155 | +33 |
- #' and categorical.+ #' of patients and the sum of exposure across all patients. |
||
| 156 | +34 |
#' |
||
| 157 | +35 |
- #' @export+ #' @return |
||
| 158 | +36 |
- h_or_cont_interaction <- function(odds_ratio_var,+ #' * `s_count_patients_sum_exposure()` returns a named `list` with the statistics: |
||
| 159 | +37 |
- interaction_var,+ #' * `n_patients`: Number of unique patients in `df`. |
||
| 160 | +38 |
- fit_glm,+ #' * `sum_exposure`: Sum of `ex_var` across all patients in `df`. |
||
| 161 | +39 |
- at = NULL,+ #' |
||
| 162 | +40 |
- conf_level = 0.95) {
+ #' @keywords internal |
||
| 163 | -13x | +|||
| 41 | +
- interaction_vars <- h_get_interaction_vars(fit_glm)+ s_count_patients_sum_exposure <- function(df, |
|||
| 164 | -13x | +|||
| 42 | +
- checkmate::assert_string(odds_ratio_var)+ ex_var = "AVAL", |
|||
| 165 | -13x | +|||
| 43 | +
- checkmate::assert_string(interaction_var)+ id = "USUBJID", |
|||
| 166 | -13x | +|||
| 44 | +
- checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars)+ labelstr = "", |
|||
| 167 | -13x | +|||
| 45 | +
- checkmate::assert_vector(interaction_vars, len = 2)+ .stats = c("n_patients", "sum_exposure"),
|
|||
| 168 | -13x | +|||
| 46 | +
- checkmate::assert_numeric(at, min.len = 1, null.ok = TRUE, any.missing = FALSE)+ .N_col, # nolint |
|||
| 169 | -13x | +|||
| 47 | +
- xs_level <- fit_glm$xlevels+ custom_label = NULL) {
|
|||
| 170 | -13x | +48 | +56x |
- xs_coef <- stats::coef(fit_glm)+ assert_df_with_variables(df, list(ex_var = ex_var, id = id)) |
| 171 | -13x | +49 | +56x |
- xs_vcov <- stats::vcov(fit_glm)+ checkmate::assert_string(id) |
| 172 | -13x | +50 | +56x |
- xs_class <- attr(fit_glm$terms, "dataClasses")+ checkmate::assert_string(labelstr) |
| 173 | -13x | +51 | +56x |
- model_data <- fit_glm$model+ checkmate::assert_string(custom_label, null.ok = TRUE) |
| 174 | -13x | +52 | +56x |
- if (!is.null(at)) {
+ checkmate::assert_numeric(df[[ex_var]]) |
| 175 | -3x | +53 | +56x |
- checkmate::assert_set_equal(xs_class[interaction_var], "numeric")+ checkmate::assert_true(all(.stats %in% c("n_patients", "sum_exposure")))
|
| 176 | +54 |
- }+ |
||
| 177 | -12x | +55 | +56x |
- y <- list()+ row_label <- if (labelstr != "") {
|
| 178 | -12x | +|||
| 56 | +! |
- if (xs_class[interaction_var] == "numeric") {
+ labelstr |
||
| 179 | -7x | +57 | +56x |
- if (is.null(at)) {
+ } else if (!is.null(custom_label)) {
|
| 180 | -5x | +58 | +48x |
- at <- ceiling(stats::median(model_data[[interaction_var]]))+ custom_label |
| 181 | +59 |
- }+ } else {
+ |
+ ||
| 60 | +8x | +
+ "Total patients numbers/person time" |
||
| 182 | +61 |
-
+ } |
||
| 183 | -7x | +|||
| 62 | +
- for (var_level in xs_level[[odds_ratio_var]][-1]) {
+
|
|||
| 184 | -14x | +63 | +56x |
- x <- list()+ y <- list() |
| 185 | -14x | +|||
| 64 | +
- for (increment in at) {
+
|
|||
| 186 | -20x | +65 | +56x |
- coef_names <- paste0(odds_ratio_var, var_level)+ if ("n_patients" %in% .stats) {
|
| 187 | -20x | +66 | +23x |
- if (increment != 0) {
+ y$n_patients <- |
| 188 | -20x | +67 | +23x |
- interaction_coef_name <- h_interaction_coef_name(+ formatters::with_label( |
| 189 | -20x | +68 | +23x |
- interaction_vars,+ s_num_patients_content( |
| 190 | -20x | +69 | +23x |
- c(odds_ratio_var, var_level),+ df = df, |
| 191 | -20x | +70 | +23x |
- c(interaction_var, "")+ .N_col = .N_col, # nolint |
| 192 | -+ | |||
| 71 | +23x |
- )+ .var = id, |
||
| 193 | -20x | +72 | +23x |
- coef_names <- c(+ labelstr = "" |
| 194 | -20x | +73 | +23x |
- coef_names,+ )$unique, |
| 195 | -20x | +74 | +23x |
- interaction_coef_name+ row_label |
| 196 | +75 |
- )+ ) |
||
| 197 | +76 |
- }+ } |
||
| 198 | -20x | +77 | +56x |
- if (length(coef_names) > 1) {
+ if ("sum_exposure" %in% .stats) {
|
| 199 | -20x | +78 | +34x |
- xvec <- t(c(1, increment))+ y$sum_exposure <- formatters::with_label(sum(df[[ex_var]]), row_label) |
| 200 | -20x | +|||
| 79 | +
- est <- as.numeric(xvec %*% xs_coef[coef_names])+ } |
|||
| 201 | -20x | +80 | +56x |
- se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec)))+ y |
| 202 | +81 |
- } else {
+ } |
||
| 203 | -! | +|||
| 82 | +
- est <- xs_coef[coef_names]+ |
|||
| 204 | -! | +|||
| 83 | +
- se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ #' @describeIn summarize_patients_exposure_in_cols Analysis function which is used as `afun` in |
|||
| 205 | +84 |
- }+ #' [rtables::analyze_colvars()] within `analyze_patients_exposure_in_cols()` and as `cfun` in |
||
| 206 | -20x | +|||
| 85 | +
- or <- exp(est)+ #' [rtables::summarize_row_groups()] within `summarize_patients_exposure_in_cols()`. |
|||
| 207 | -20x | +|||
| 86 | +
- ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ #' |
|||
| 208 | -20x | +|||
| 87 | +
- x[[as.character(increment)]] <- list(or = or, ci = ci)+ #' @return |
|||
| 209 | +88 |
- }+ #' * `a_count_patients_sum_exposure()` returns formatted [rtables::CellValue()]. |
||
| 210 | -14x | +|||
| 89 | +
- y[[var_level]] <- x+ #' |
|||
| 211 | +90 |
- }+ #' @examples |
||
| 212 | +91 |
- } else {
+ #' a_count_patients_sum_exposure( |
||
| 213 | -5x | +|||
| 92 | +
- checkmate::assert_set_equal(xs_class[odds_ratio_var], "numeric")+ #' df = df, |
|||
| 214 | -5x | +|||
| 93 | +
- checkmate::assert_set_equal(xs_class[interaction_var], "factor")+ #' var = "SEX", |
|||
| 215 | -5x | +|||
| 94 | +
- for (var_level in xs_level[[interaction_var]]) {
+ #' .N_col = nrow(df), |
|||
| 216 | -15x | +|||
| 95 | +
- coef_names <- odds_ratio_var+ #' .stats = "n_patients" |
|||
| 217 | -15x | +|||
| 96 | +
- if (var_level != xs_level[[interaction_var]][1]) {
+ #' ) |
|||
| 218 | -10x | +|||
| 97 | +
- interaction_coef_name <- h_interaction_coef_name(+ #' |
|||
| 219 | -10x | +|||
| 98 | +
- interaction_vars,+ #' @export |
|||
| 220 | -10x | +|||
| 99 | +
- c(odds_ratio_var, ""),+ a_count_patients_sum_exposure <- function(df, |
|||
| 221 | -10x | +|||
| 100 | +
- c(interaction_var, var_level)+ var = NULL, |
|||
| 222 | +101 |
- )+ ex_var = "AVAL", |
||
| 223 | -10x | +|||
| 102 | +
- coef_names <- c(+ id = "USUBJID", |
|||
| 224 | -10x | +|||
| 103 | +
- coef_names,+ add_total_level = FALSE, |
|||
| 225 | -10x | +|||
| 104 | +
- interaction_coef_name+ custom_label = NULL, |
|||
| 226 | +105 |
- )+ labelstr = "", |
||
| 227 | +106 |
- }+ .N_col, # nolint |
||
| 228 | -15x | +|||
| 107 | +
- if (length(coef_names) > 1) {
+ .stats, |
|||
| 229 | -10x | +|||
| 108 | +
- xvec <- t(c(1, 1))+ .formats = list(n_patients = "xx (xx.x%)", sum_exposure = "xx")) {
|
|||
| 230 | -10x | +109 | +32x |
- est <- as.numeric(xvec %*% xs_coef[coef_names])+ checkmate::assert_flag(add_total_level) |
| 231 | -10x | +|||
| 110 | +
- se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec)))+ |
|||
| 232 | -+ | |||
| 111 | +32x |
- } else {
+ if (!is.null(var)) {
|
||
| 233 | -5x | +112 | +21x |
- est <- xs_coef[coef_names]+ assert_df_with_variables(df, list(var = var)) |
| 234 | -5x | +113 | +21x |
- se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ df[[var]] <- as.factor(df[[var]]) |
| 235 | +114 |
- }+ } |
||
| 236 | -15x | +|||
| 115 | +
- or <- exp(est)+ |
|||
| 237 | -15x | +116 | +32x |
- ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ y <- list() |
| 238 | -15x | +117 | +32x |
- y[[var_level]] <- list(or = or, ci = ci)+ if (is.null(var)) {
|
| 239 | -+ | |||
| 118 | +11x |
- }+ y[[.stats]] <- list(Total = s_count_patients_sum_exposure( |
||
| 240 | -+ | |||
| 119 | +11x |
- }+ df = df, |
||
| 241 | -12x | +120 | +11x |
- y+ ex_var = ex_var, |
| 242 | -+ | |||
| 121 | +11x |
- }+ id = id, |
||
| 243 | -+ | |||
| 122 | +11x |
-
+ labelstr = labelstr, |
||
| 244 | -+ | |||
| 123 | +11x |
- #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ .N_col = .N_col, |
||
| 245 | -+ | |||
| 124 | +11x |
- #' in case of an interaction. This is a wrapper for [h_or_cont_interaction()] and+ .stats = .stats, |
||
| 246 | -+ | |||
| 125 | +11x |
- #' [h_or_cat_interaction()].+ custom_label = custom_label |
||
| 247 | -+ | |||
| 126 | +11x |
- #'+ )[[.stats]]) |
||
| 248 | +127 |
- #' @return Odds ratio.+ } else {
|
||
| 249 | -+ | |||
| 128 | +21x |
- #'+ for (lvl in levels(df[[var]])) {
|
||
| 250 | -+ | |||
| 129 | +42x |
- #' @export+ y[[.stats]][[lvl]] <- s_count_patients_sum_exposure( |
||
| 251 | -+ | |||
| 130 | +42x |
- h_or_interaction <- function(odds_ratio_var,+ df = subset(df, get(var) == lvl), |
||
| 252 | -+ | |||
| 131 | +42x |
- interaction_var,+ ex_var = ex_var, |
||
| 253 | -+ | |||
| 132 | +42x |
- fit_glm,+ id = id, |
||
| 254 | -+ | |||
| 133 | +42x |
- at = NULL,+ labelstr = labelstr, |
||
| 255 | -+ | |||
| 134 | +42x |
- conf_level = 0.95) {
+ .N_col = .N_col, |
||
| 256 | -15x | +135 | +42x |
- xs_class <- attr(fit_glm$terms, "dataClasses")+ .stats = .stats, |
| 257 | -15x | +136 | +42x |
- if (any(xs_class[c(odds_ratio_var, interaction_var)] == "numeric")) {
+ custom_label = lvl |
| 258 | -9x | +137 | +42x |
- h_or_cont_interaction(+ )[[.stats]] |
| 259 | -9x | +|||
| 138 | +
- odds_ratio_var,+ } |
|||
| 260 | -9x | +139 | +21x |
- interaction_var,+ if (add_total_level) {
|
| 261 | -9x | +140 | +2x |
- fit_glm,+ y[[.stats]][["Total"]] <- s_count_patients_sum_exposure( |
| 262 | -9x | +141 | +2x |
- at = at,+ df = df, |
| 263 | -9x | +142 | +2x |
- conf_level = conf_level+ ex_var = ex_var, |
| 264 | -+ | |||
| 143 | +2x |
- )+ id = id, |
||
| 265 | -6x | +144 | +2x |
- } else if (all(xs_class[c(odds_ratio_var, interaction_var)] == "factor")) {
+ labelstr = labelstr, |
| 266 | -6x | +145 | +2x |
- h_or_cat_interaction(+ .N_col = .N_col, |
| 267 | -6x | +146 | +2x |
- odds_ratio_var,+ .stats = .stats, |
| 268 | -6x | +147 | +2x |
- interaction_var,+ custom_label = custom_label |
| 269 | -6x | +148 | +2x |
- fit_glm,+ )[[.stats]] |
| 270 | -6x | +|||
| 149 | +
- conf_level = conf_level+ } |
|||
| 271 | +150 |
- )+ } |
||
| 272 | +151 |
- } else {
+
|
||
| 273 | -! | +|||
| 152 | +32x |
- stop("wrong interaction variable class, the interaction variable is not a numeric nor a factor")
+ in_rows(.list = y[[.stats]], .formats = .formats[[.stats]]) |
||
| 274 | +153 |
- }+ } |
||
| 275 | +154 |
- }+ |
||
| 276 | +155 |
-
+ #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics |
||
| 277 | +156 |
- #' @describeIn h_logistic_regression Helper function to construct term labels from simple terms and the table+ #' function arguments and additional format arguments. This function is a wrapper for |
||
| 278 | +157 |
- #' of numbers of patients.+ #' [rtables::split_cols_by_multivar()] and [rtables::summarize_row_groups()]. |
||
| 279 | +158 |
#' |
||
| 280 | +159 |
- #' @param terms (`character`)\cr simple terms.+ #' @return |
||
| 281 | +160 |
- #' @param table (`table`)\cr table containing numbers for terms.+ #' * `summarize_patients_exposure_in_cols()` returns a layout object suitable for passing to further |
||
| 282 | +161 |
- #'+ #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will |
||
| 283 | +162 |
- #' @return Term labels containing numbers of patients.+ #' add formatted content rows, with the statistics from `s_count_patients_sum_exposure()` arranged in |
||
| 284 | +163 |
- #'+ #' columns, to the table layout. |
||
| 285 | +164 |
- #' @export+ #' |
||
| 286 | +165 |
- h_simple_term_labels <- function(terms,+ #' @examples |
||
| 287 | +166 |
- table) {
+ #' lyt5 <- basic_table() %>% |
||
| 288 | -54x | +|||
| 167 | +
- checkmate::assert_true(is.table(table))+ #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) |
|||
| 289 | -54x | +|||
| 168 | +
- checkmate::assert_multi_class(terms, classes = c("factor", "character"))
+ #' |
|||
| 290 | -54x | +|||
| 169 | +
- terms <- as.character(terms)+ #' result5 <- build_table(lyt5, df = df, alt_counts_df = adsl) |
|||
| 291 | -54x | +|||
| 170 | +
- term_n <- table[terms]+ #' result5 |
|||
| 292 | -54x | +|||
| 171 | +
- paste0(terms, ", n = ", term_n)+ #' |
|||
| 293 | +172 |
- }+ #' lyt6 <- basic_table() %>% |
||
| 294 | +173 |
-
+ #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE, .stats = "sum_exposure") |
||
| 295 | +174 |
- #' @describeIn h_logistic_regression Helper function to construct term labels from interaction terms and the table+ #' |
||
| 296 | +175 |
- #' of numbers of patients.+ #' result6 <- build_table(lyt6, df = df, alt_counts_df = adsl) |
||
| 297 | +176 |
- #'+ #' result6 |
||
| 298 | +177 |
- #' @param terms1 (`character`)\cr terms for first dimension (rows).+ #' |
||
| 299 | +178 |
- #' @param terms2 (`character`)\cr terms for second dimension (rows).+ #' @export |
||
| 300 | +179 |
- #' @param any (`flag`)\cr whether any of `term1` and `term2` can be fulfilled to count the+ #' @order 3 |
||
| 301 | +180 |
- #' number of patients. In that case they can only be scalar (strings).+ summarize_patients_exposure_in_cols <- function(lyt, # nolint |
||
| 302 | +181 |
- #'+ var, |
||
| 303 | +182 |
- #' @return Term labels containing numbers of patients.+ ex_var = "AVAL", |
||
| 304 | +183 |
- #'+ id = "USUBJID", |
||
| 305 | +184 |
- #' @export+ add_total_level = FALSE, |
||
| 306 | +185 |
- h_interaction_term_labels <- function(terms1,+ custom_label = NULL, |
||
| 307 | +186 |
- terms2,+ col_split = TRUE, |
||
| 308 | +187 |
- table,+ na_str = default_na_str(), |
||
| 309 | +188 |
- any = FALSE) {
+ ..., |
||
| 310 | -8x | +|||
| 189 | +
- checkmate::assert_true(is.table(table))+ .stats = c("n_patients", "sum_exposure"),
|
|||
| 311 | -8x | +|||
| 190 | +
- checkmate::assert_flag(any)+ .labels = c(n_patients = "Patients", sum_exposure = "Person time"), |
|||
| 312 | -8x | +|||
| 191 | +
- checkmate::assert_multi_class(terms1, classes = c("factor", "character"))
+ .indent_mods = NULL) {
|
|||
| 313 | -8x | +192 | +3x |
- checkmate::assert_multi_class(terms2, classes = c("factor", "character"))
+ extra_args <- list(ex_var = ex_var, id = id, add_total_level = add_total_level, custom_label = custom_label, ...) |
| 314 | -8x | +|||
| 193 | +
- terms1 <- as.character(terms1)+ |
|||
| 315 | -8x | +194 | +3x |
- terms2 <- as.character(terms2)+ if (col_split) {
|
| 316 | -8x | +195 | +3x |
- if (any) {
+ lyt <- split_cols_by_multivar( |
| 317 | -4x | +196 | +3x |
- checkmate::assert_scalar(terms1)+ lyt = lyt, |
| 318 | -4x | +197 | +3x |
- checkmate::assert_scalar(terms2)+ vars = rep(var, length(.stats)), |
| 319 | -4x | +198 | +3x |
- paste0(+ varlabels = .labels[.stats], |
| 320 | -4x | +199 | +3x |
- terms1, " or ", terms2, ", n = ",+ extra_args = list(.stats = .stats) |
| 321 | +200 |
- # Note that we double count in the initial sum the cell [terms1, terms2], therefore subtract.- |
- ||
| 322 | -4x | -
- sum(c(table[terms1, ], table[, terms2])) - table[terms1, terms2]+ ) |
||
| 323 | +201 |
- )+ } |
||
| 324 | -+ | |||
| 202 | +3x |
- } else {
+ summarize_row_groups( |
||
| 325 | -4x | +203 | +3x |
- term_n <- table[cbind(terms1, terms2)]+ lyt = lyt, |
| 326 | -4x | +204 | +3x |
- paste0(terms1, " * ", terms2, ", n = ", term_n)+ var = var,+ |
+
| 205 | +3x | +
+ cfun = a_count_patients_sum_exposure,+ |
+ ||
| 206 | +3x | +
+ na_str = na_str,+ |
+ ||
| 207 | +3x | +
+ extra_args = extra_args |
||
| 327 | +208 |
- }+ ) |
||
| 328 | +209 |
} |
||
| 329 | +210 | |||
| 330 | +211 |
- #' @describeIn h_logistic_regression Helper function to tabulate the main effect+ #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics |
||
| 331 | +212 |
- #' results of a (conditional) logistic regression model.+ #' function arguments and additional format arguments. This function is a wrapper for |
||
| 332 | +213 | ++ |
+ #' [rtables::split_cols_by_multivar()] and [rtables::analyze_colvars()].+ |
+ |
| 214 |
#' |
|||
| 333 | +215 |
- #' @return Tabulated main effect results from a logistic regression model.+ #' @param col_split (`flag`)\cr whether the columns should be split. Set to `FALSE` when the required |
||
| 334 | +216 | ++ |
+ #' column split has been done already earlier in the layout pipe.+ |
+ |
| 217 |
#' |
|||
| 335 | +218 |
- #' @examples+ #' @return |
||
| 336 | +219 |
- #' h_glm_simple_term_extract("AGE", mod1)
+ #' * `analyze_patients_exposure_in_cols()` returns a layout object suitable for passing to further |
||
| 337 | +220 |
- #' h_glm_simple_term_extract("ARMCD", mod1)
+ #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will |
||
| 338 | +221 | ++ |
+ #' add formatted data rows, with the statistics from `s_count_patients_sum_exposure()` arranged in+ |
+ |
| 222 | ++ |
+ #' columns, to the table layout.+ |
+ ||
| 223 |
#' |
|||
| 339 | +224 |
- #' @export+ #' @note As opposed to [summarize_patients_exposure_in_cols()] which generates content rows, |
||
| 340 | +225 |
- h_glm_simple_term_extract <- function(x, fit_glm) {
+ #' `analyze_patients_exposure_in_cols()` generates data rows which will _not_ be repeated on multiple |
||
| 341 | -78x | +|||
| 226 | +
- checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
+ #' pages when pagination is used. |
|||
| 342 | -78x | +|||
| 227 | +
- checkmate::assert_string(x)+ #' |
|||
| 343 | +228 |
-
+ #' @examples |
||
| 344 | -78x | +|||
| 229 | +
- xs_class <- attr(fit_glm$terms, "dataClasses")+ #' set.seed(1) |
|||
| 345 | -78x | +|||
| 230 | +
- xs_level <- fit_glm$xlevels+ #' df <- data.frame( |
|||
| 346 | -78x | +|||
| 231 | +
- xs_coef <- summary(fit_glm)$coefficients+ #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
|
|||
| 347 | -78x | +|||
| 232 | +
- stats <- if (inherits(fit_glm, "glm")) {
+ #' ARMCD = c(rep("ARM A", 6), rep("ARM B", 6)),
|
|||
| 348 | -66x | +|||
| 233 | +
- c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
+ #' SEX = c(rep("Female", 6), rep("Male", 6)),
|
|||
| 349 | +234 |
- } else {
+ #' AVAL = as.numeric(sample(seq(1, 20), 12)), |
||
| 350 | -12x | +|||
| 235 | +
- c("estimate" = "coef", "std_error" = "se(coef)", "pvalue" = "Pr(>|z|)")
+ #' stringsAsFactors = TRUE |
|||
| 351 | +236 |
- }+ #' ) |
||
| 352 | +237 |
- # Make sure x is not an interaction term.+ #' adsl <- data.frame( |
||
| 353 | -78x | +|||
| 238 | +
- checkmate::assert_subset(x, names(xs_class))+ #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
|
|||
| 354 | -78x | +|||
| 239 | +
- x_sel <- if (xs_class[x] == "numeric") x else paste0(x, xs_level[[x]][-1])+ #' ARMCD = c(rep("ARM A", 2), rep("ARM B", 2)),
|
|||
| 355 | -78x | +|||
| 240 | +
- x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE)+ #' SEX = c(rep("Female", 2), rep("Male", 2)),
|
|||
| 356 | -78x | +|||
| 241 | +
- colnames(x_stats) <- names(stats)+ #' stringsAsFactors = TRUE |
|||
| 357 | -78x | +|||
| 242 | +
- x_stats$estimate <- as.list(x_stats$estimate)+ #' ) |
|||
| 358 | -78x | +|||
| 243 | +
- x_stats$std_error <- as.list(x_stats$std_error)+ #' |
|||
| 359 | -78x | +|||
| 244 | +
- x_stats$pvalue <- as.list(x_stats$pvalue)+ #' lyt <- basic_table() %>% |
|||
| 360 | -78x | +|||
| 245 | +
- x_stats$df <- as.list(1)+ #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
|
|||
| 361 | -78x | +|||
| 246 | +
- if (xs_class[x] == "numeric") {
+ #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) %>% |
|||
| 362 | -60x | +|||
| 247 | +
- x_stats$term <- x+ #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE) |
|||
| 363 | -60x | +|||
| 248 | +
- x_stats$term_label <- if (inherits(fit_glm, "glm")) {
+ #' result <- build_table(lyt, df = df, alt_counts_df = adsl) |
|||
| 364 | -48x | +|||
| 249 | +
- formatters::var_labels(fit_glm$data[x], fill = TRUE)+ #' result |
|||
| 365 | +250 |
- } else {
+ #' |
||
| 366 | +251 |
- # We just fill in here with the `term` itself as we don't have the data available.+ #' lyt2 <- basic_table() %>% |
||
| 367 | -12x | +|||
| 252 | +
- x+ #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
|
|||
| 368 | +253 |
- }+ #' summarize_patients_exposure_in_cols( |
||
| 369 | -60x | +|||
| 254 | +
- x_stats$is_variable_summary <- FALSE+ #' var = "AVAL", col_split = TRUE, |
|||
| 370 | -60x | +|||
| 255 | +
- x_stats$is_term_summary <- TRUE+ #' .stats = "n_patients", custom_label = "some custom label" |
|||
| 371 | +256 |
- } else {
+ #' ) %>% |
||
| 372 | -18x | +|||
| 257 | +
- checkmate::assert_class(fit_glm, "glm")+ #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE, ex_var = "AVAL") |
|||
| 373 | +258 |
- # The reason is that we don't have the original data set in the `clogit` object+ #' result2 <- build_table(lyt2, df = df, alt_counts_df = adsl) |
||
| 374 | +259 |
- # and therefore cannot determine the `x_numbers` here.+ #' result2 |
||
| 375 | -18x | +|||
| 260 | +
- x_numbers <- table(fit_glm$data[[x]])+ #' |
|||
| 376 | -18x | +|||
| 261 | +
- x_stats$term <- xs_level[[x]][-1]+ #' lyt3 <- basic_table() %>% |
|||
| 377 | -18x | +|||
| 262 | +
- x_stats$term_label <- h_simple_term_labels(x_stats$term, x_numbers)+ #' analyze_patients_exposure_in_cols(var = "SEX", col_split = TRUE, ex_var = "AVAL") |
|||
| 378 | -18x | +|||
| 263 | +
- x_stats$is_variable_summary <- FALSE+ #' result3 <- build_table(lyt3, df = df, alt_counts_df = adsl) |
|||
| 379 | -18x | +|||
| 264 | +
- x_stats$is_term_summary <- TRUE+ #' result3 |
|||
| 380 | -18x | +|||
| 265 | +
- main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald")+ #' |
|||
| 381 | -18x | +|||
| 266 | +
- x_main <- data.frame(+ #' # Adding total levels and custom label |
|||
| 382 | -18x | +|||
| 267 | +
- pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE],+ #' lyt4 <- basic_table( |
|||
| 383 | -18x | +|||
| 268 | +
- term = xs_level[[x]][1],+ #' show_colcounts = TRUE |
|||
| 384 | -18x | +|||
| 269 | +
- term_label = paste("Reference", h_simple_term_labels(xs_level[[x]][1], x_numbers)),
+ #' ) %>% |
|||
| 385 | -18x | +|||
| 270 | +
- df = main_effects[x, "Df", drop = TRUE],+ #' analyze_patients_exposure_in_cols( |
|||
| 386 | -18x | +|||
| 271 | +
- stringsAsFactors = FALSE+ #' var = "ARMCD", |
|||
| 387 | +272 |
- )+ #' col_split = TRUE, |
||
| 388 | -18x | +|||
| 273 | +
- x_main$pvalue <- as.list(x_main$pvalue)+ #' add_total_level = TRUE, |
|||
| 389 | -18x | +|||
| 274 | +
- x_main$df <- as.list(x_main$df)+ #' custom_label = "TOTAL" |
|||
| 390 | -18x | +|||
| 275 | +
- x_main$estimate <- list(numeric(0))+ #' ) %>% |
|||
| 391 | -18x | +|||
| 276 | +
- x_main$std_error <- list(numeric(0))+ #' append_topleft(c("", "Sex"))
|
|||
| 392 | -18x | +|||
| 277 | +
- if (length(xs_level[[x]][-1]) == 1) {
+ #' |
|||
| 393 | -8x | +|||
| 278 | +
- x_main$pvalue <- list(numeric(0))+ #' result4 <- build_table(lyt4, df = df, alt_counts_df = adsl) |
|||
| 394 | -8x | +|||
| 279 | +
- x_main$df <- list(numeric(0))+ #' result4 |
|||
| 395 | +280 |
- }+ #' |
||
| 396 | -18x | +|||
| 281 | +
- x_main$is_variable_summary <- TRUE+ #' @export |
|||
| 397 | -18x | +|||
| 282 | +
- x_main$is_term_summary <- FALSE+ #' @order 2 |
|||
| 398 | -18x | +|||
| 283 | +
- x_stats <- rbind(x_main, x_stats)+ analyze_patients_exposure_in_cols <- function(lyt, # nolint |
|||
| 399 | +284 |
- }+ var = NULL, |
||
| 400 | -78x | +|||
| 285 | +
- x_stats$variable <- x+ ex_var = "AVAL", |
|||
| 401 | -78x | +|||
| 286 | +
- x_stats$variable_label <- if (inherits(fit_glm, "glm")) {
+ id = "USUBJID", |
|||
| 402 | -66x | +|||
| 287 | +
- formatters::var_labels(fit_glm$data[x], fill = TRUE)+ add_total_level = FALSE, |
|||
| 403 | +288 |
- } else {
+ custom_label = NULL, |
||
| 404 | -12x | +|||
| 289 | +
- x+ col_split = TRUE, |
|||
| 405 | +290 |
- }+ na_str = default_na_str(), |
||
| 406 | -78x | +|||
| 291 | +
- x_stats$interaction <- ""+ .stats = c("n_patients", "sum_exposure"),
|
|||
| 407 | -78x | +|||
| 292 | +
- x_stats$interaction_label <- ""+ .labels = c(n_patients = "Patients", sum_exposure = "Person time"), |
|||
| 408 | -78x | +|||
| 293 | +
- x_stats$reference <- ""+ .indent_mods = 0L, |
|||
| 409 | -78x | +|||
| 294 | +
- x_stats$reference_label <- ""+ ...) {
|
|||
| 410 | -78x | +295 | +6x |
- rownames(x_stats) <- NULL+ extra_args <- list( |
| 411 | -78x | +296 | +6x |
- x_stats[c(+ var = var, ex_var = ex_var, id = id, add_total_level = add_total_level, custom_label = custom_label, ... |
| 412 | -78x | +|||
| 297 | +
- "variable",+ ) |
|||
| 413 | -78x | +|||
| 298 | +
- "variable_label",+ |
|||
| 414 | -78x | +299 | +6x |
- "term",+ if (col_split) {
|
| 415 | -78x | +300 | +4x |
- "term_label",+ lyt <- split_cols_by_multivar( |
| 416 | -78x | +301 | +4x |
- "interaction",+ lyt = lyt, |
| 417 | -78x | +302 | +4x |
- "interaction_label",+ vars = rep(ex_var, length(.stats)), |
| 418 | -78x | +303 | +4x |
- "reference",+ varlabels = .labels[.stats], |
| 419 | -78x | +304 | +4x |
- "reference_label",+ extra_args = list(.stats = .stats) |
| 420 | -78x | +|||
| 305 | +
- "estimate",+ )+ |
+ |||
| 306 | ++ |
+ } |
||
| 421 | -78x | +307 | +6x |
- "std_error",+ lyt <- lyt %>% analyze_colvars( |
| 422 | -78x | +308 | +6x |
- "df",+ afun = a_count_patients_sum_exposure, |
| 423 | -78x | +309 | +6x |
- "pvalue",+ indent_mod = .indent_mods, |
| 424 | -78x | +310 | +6x |
- "is_variable_summary",+ na_str = na_str, |
| 425 | -78x | +311 | +6x |
- "is_term_summary"+ extra_args = extra_args |
| 426 | +312 |
- )]+ )+ |
+ ||
| 313 | +6x | +
+ lyt |
||
| 427 | +314 |
} |
| 428 | +1 |
-
+ #' Helper functions for multivariate logistic regression |
|
| 429 | +2 |
- #' @describeIn h_logistic_regression Helper function to tabulate the interaction term+ #' |
|
| 430 | +3 |
- #' results of a logistic regression model.+ #' @description `r lifecycle::badge("stable")`
|
|
| 431 | +4 |
#' |
|
| 432 | +5 |
- #' @return Tabulated interaction term results from a logistic regression model.+ #' Helper functions used in calculations for logistic regression. |
|
| 433 | +6 |
#' |
|
| 434 | +7 |
- #' @examples+ #' @inheritParams argument_convention |
|
| 435 | +8 |
- #' h_glm_interaction_extract("ARMCD:AGE", mod2)
+ #' @param fit_glm (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family. |
|
| 436 | +9 |
- #'+ #' Limited functionality is also available for conditional logistic regression models fitted by |
|
| 437 | +10 |
- #' @export+ #' [survival::clogit()], currently this is used only by [extract_rsp_biomarkers()]. |
|
| 438 | +11 |
- h_glm_interaction_extract <- function(x, fit_glm) {
+ #' @param x (`character`)\cr a variable or interaction term in `fit_glm` (depending on the helper function used). |
|
| 439 | -7x | +||
| 12 | +
- vars <- h_get_interaction_vars(fit_glm)+ #' |
||
| 440 | -7x | +||
| 13 | +
- xs_class <- attr(fit_glm$terms, "dataClasses")+ #' @examples |
||
| 441 | +14 |
-
+ #' library(dplyr) |
|
| 442 | -7x | +||
| 15 | +
- checkmate::assert_string(x)+ #' library(broom) |
||
| 443 | +16 |
-
+ #' |
|
| 444 | +17 |
- # Only take two-way interaction+ #' adrs_f <- tern_ex_adrs %>% |
|
| 445 | -7x | +||
| 18 | +
- checkmate::assert_vector(vars, len = 2)+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 446 | +19 |
-
+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
|
|
| 447 | +20 |
- # Only consider simple case: first variable in interaction is arm, a categorical variable+ #' mutate( |
|
| 448 | -7x | +||
| 21 | +
- checkmate::assert_disjunct(xs_class[vars[1]], "numeric")+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
||
| 449 | +22 |
-
+ #' RACE = factor(RACE), |
|
| 450 | -7x | +||
| 23 | +
- xs_level <- fit_glm$xlevels+ #' SEX = factor(SEX) |
||
| 451 | -7x | +||
| 24 | +
- xs_coef <- summary(fit_glm)$coefficients+ #' ) |
||
| 452 | -7x | +||
| 25 | +
- main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald")+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
||
| 453 | -7x | +||
| 26 | +
- stats <- c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
+ #' mod1 <- fit_logistic( |
||
| 454 | -7x | +||
| 27 | +
- v1_comp <- xs_level[[vars[1]]][-1]+ #' data = adrs_f, |
||
| 455 | -7x | +||
| 28 | +
- if (xs_class[vars[2]] == "numeric") {
+ #' variables = list( |
||
| 456 | -4x | +||
| 29 | +
- x_stats <- as.data.frame(+ #' response = "Response", |
||
| 457 | -4x | +||
| 30 | +
- xs_coef[paste0(vars[1], v1_comp, ":", vars[2]), stats, drop = FALSE],+ #' arm = "ARMCD", |
||
| 458 | -4x | +||
| 31 | +
- stringsAsFactors = FALSE+ #' covariates = c("AGE", "RACE")
|
||
| 459 | +32 |
- )+ #' ) |
|
| 460 | -4x | +||
| 33 | +
- colnames(x_stats) <- names(stats)+ #' ) |
||
| 461 | -4x | +||
| 34 | +
- x_stats$term <- v1_comp+ #' mod2 <- fit_logistic( |
||
| 462 | -4x | +||
| 35 | +
- x_numbers <- table(fit_glm$data[[vars[1]]])+ #' data = adrs_f, |
||
| 463 | -4x | +||
| 36 | +
- x_stats$term_label <- h_simple_term_labels(v1_comp, x_numbers)+ #' variables = list( |
||
| 464 | -4x | +||
| 37 | +
- v1_ref <- xs_level[[vars[1]]][1]+ #' response = "Response", |
||
| 465 | -4x | +||
| 38 | +
- term_main <- v1_ref+ #' arm = "ARMCD", |
||
| 466 | -4x | +||
| 39 | +
- ref_label <- h_simple_term_labels(v1_ref, x_numbers)+ #' covariates = c("AGE", "RACE"),
|
||
| 467 | -3x | +||
| 40 | +
- } else if (xs_class[vars[2]] != "numeric") {
+ #' interaction = "AGE" |
||
| 468 | -3x | +||
| 41 | +
- v2_comp <- xs_level[[vars[2]]][-1]+ #' ) |
||
| 469 | -3x | +||
| 42 | +
- v1_v2_grid <- expand.grid(v1 = v1_comp, v2 = v2_comp)+ #' ) |
||
| 470 | -3x | +||
| 43 | +
- x_sel <- paste(+ #' |
||
| 471 | -3x | +||
| 44 | +
- paste0(vars[1], v1_v2_grid$v1),+ #' @name h_logistic_regression |
||
| 472 | -3x | +||
| 45 | +
- paste0(vars[2], v1_v2_grid$v2),+ NULL |
||
| 473 | -3x | +||
| 46 | +
- sep = ":"+ |
||
| 474 | +47 |
- )+ #' @describeIn h_logistic_regression Helper function to extract interaction variable names from a fitted |
|
| 475 | -3x | +||
| 48 | +
- x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE)+ #' model assuming only one interaction term.+ |
+ ||
| 49 | ++ |
+ #'+ |
+ |
| 50 | ++ |
+ #' @return Vector of names of interaction variables.+ |
+ |
| 51 | ++ |
+ #'+ |
+ |
| 52 | ++ |
+ #' @export+ |
+ |
| 53 | ++ |
+ h_get_interaction_vars <- function(fit_glm) {
+ |
+ |
| 54 | +34x | +
+ checkmate::assert_class(fit_glm, "glm")+ |
+ |
| 55 | +34x | +
+ terms_name <- attr(stats::terms(fit_glm), "term.labels")+ |
+ |
| 56 | +34x | +
+ terms_order <- attr(stats::terms(fit_glm), "order")+ |
+ |
| 57 | +34x | +
+ interaction_term <- terms_name[terms_order == 2]+ |
+ |
| 58 | +34x | +
+ checkmate::assert_string(interaction_term)+ |
+ |
| 59 | +34x | +
+ strsplit(interaction_term, split = ":")[[1]]+ |
+ |
| 60 | ++ |
+ }+ |
+ |
| 61 | ++ | + + | +|
| 62 | ++ |
+ #' @describeIn h_logistic_regression Helper function to get the right coefficient name from the+ |
+ |
| 63 | ++ |
+ #' interaction variable names and the given levels. The main value here is that the order+ |
+ |
| 64 | ++ |
+ #' of first and second variable is checked in the `interaction_vars` input.+ |
+ |
| 65 | ++ |
+ #'+ |
+ |
| 66 | ++ |
+ #' @param interaction_vars (`character(2)`)\cr interaction variable names.+ |
+ |
| 67 | ++ |
+ #' @param first_var_with_level (`character(2)`)\cr the first variable name with the interaction level.+ |
+ |
| 68 | ++ |
+ #' @param second_var_with_level (`character(2)`)\cr the second variable name with the interaction level.+ |
+ |
| 69 | ++ |
+ #'+ |
+ |
| 70 | ++ |
+ #' @return Name of coefficient.+ |
+ |
| 71 | ++ |
+ #'+ |
+ |
| 72 | ++ |
+ #' @export+ |
+ |
| 73 | ++ |
+ h_interaction_coef_name <- function(interaction_vars,+ |
+ |
| 74 | ++ |
+ first_var_with_level,+ |
+ |
| 75 | ++ |
+ second_var_with_level) {
+ |
+ |
| 76 | +55x | +
+ checkmate::assert_character(interaction_vars, len = 2, any.missing = FALSE)+ |
+ |
| 77 | +55x | +
+ checkmate::assert_character(first_var_with_level, len = 2, any.missing = FALSE)+ |
+ |
| 78 | +55x | +
+ checkmate::assert_character(second_var_with_level, len = 2, any.missing = FALSE)+ |
+ |
| 79 | +55x | +
+ checkmate::assert_subset(c(first_var_with_level[1], second_var_with_level[1]), interaction_vars)+ |
+ |
| 80 | ++ | + + | +|
| 81 | +55x | +
+ first_name <- paste(first_var_with_level, collapse = "")+ |
+ |
| 82 | +55x | +
+ second_name <- paste(second_var_with_level, collapse = "")+ |
+ |
| 83 | +55x | +
+ if (first_var_with_level[1] == interaction_vars[1]) {
+ |
+ |
| 84 | +36x | +
+ paste(first_name, second_name, sep = ":")+ |
+ |
| 85 | +19x | +
+ } else if (second_var_with_level[1] == interaction_vars[1]) {
+ |
+ |
| 86 | +19x | +
+ paste(second_name, first_name, sep = ":")+ |
+ |
| 87 | ++ |
+ }+ |
+ |
| 88 | ++ |
+ }+ |
+ |
| 89 | ++ | + + | +|
| 90 | ++ |
+ #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ |
+ |
| 91 | ++ |
+ #' for the case when both the odds ratio and the interaction variable are categorical.+ |
+ |
| 92 | ++ |
+ #'+ |
+ |
| 93 | ++ |
+ #' @param odds_ratio_var (`string`)\cr the odds ratio variable.+ |
+ |
| 94 | ++ |
+ #' @param interaction_var (`string`)\cr the interaction variable.+ |
+ |
| 95 | ++ |
+ #'+ |
+ |
| 96 | ++ |
+ #' @return Odds ratio.+ |
+ |
| 97 | ++ |
+ #'+ |
+ |
| 98 | ++ |
+ #' @export+ |
+ |
| 99 | ++ |
+ h_or_cat_interaction <- function(odds_ratio_var,+ |
+ |
| 100 | ++ |
+ interaction_var,+ |
+ |
| 101 | ++ |
+ fit_glm,+ |
+ |
| 102 | ++ |
+ conf_level = 0.95) {
+ |
+ |
| 103 | +8x | +
+ interaction_vars <- h_get_interaction_vars(fit_glm)+ |
+ |
| 104 | +8x | +
+ checkmate::assert_string(odds_ratio_var)+ |
+ |
| 105 | +8x | +
+ checkmate::assert_string(interaction_var)+ |
+ |
| 106 | +8x | +
+ checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars)+ |
+ |
| 107 | +8x | +
+ checkmate::assert_vector(interaction_vars, len = 2)+ |
+ |
| 108 | ++ | + + | +|
| 109 | +8x | +
+ xs_level <- fit_glm$xlevels+ |
+ |
| 110 | +8x | +
+ xs_coef <- stats::coef(fit_glm)+ |
+ |
| 111 | +8x | +
+ xs_vcov <- stats::vcov(fit_glm)+ |
+ |
| 112 | +8x | +
+ y <- list()+ |
+ |
| 113 | +8x | +
+ for (var_level in xs_level[[odds_ratio_var]][-1]) {
+ |
+ |
| 114 | +14x | +
+ x <- list()+ |
+ |
| 115 | +14x | +
+ for (ref_level in xs_level[[interaction_var]]) {
+ |
+ |
| 116 | +38x | +
+ coef_names <- paste0(odds_ratio_var, var_level)+ |
+ |
| 117 | +38x | +
+ if (ref_level != xs_level[[interaction_var]][1]) {
+ |
+ |
| 118 | +24x | +
+ interaction_coef_name <- h_interaction_coef_name(+ |
+ |
| 119 | +24x | +
+ interaction_vars,+ |
+ |
| 120 | +24x | +
+ c(odds_ratio_var, var_level),+ |
+ |
| 121 | +24x | +
+ c(interaction_var, ref_level)+ |
+ |
| 122 | ++ |
+ )+ |
+ |
| 123 | +24x | +
+ coef_names <- c(+ |
+ |
| 124 | +24x | +
+ coef_names,+ |
+ |
| 125 | +24x | +
+ interaction_coef_name+ |
+ |
| 126 | ++ |
+ )+ |
+ |
| 127 | ++ |
+ }+ |
+ |
| 128 | +38x | +
+ if (length(coef_names) > 1) {
+ |
+ |
| 129 | +24x | +
+ ones <- t(c(1, 1))+ |
+ |
| 130 | +24x | +
+ est <- as.numeric(ones %*% xs_coef[coef_names])+ |
+ |
| 131 | +24x | +
+ se <- sqrt(as.numeric(ones %*% xs_vcov[coef_names, coef_names] %*% t(ones)))+ |
+ |
| 132 | ++ |
+ } else {
+ |
+ |
| 133 | +14x | +
+ est <- xs_coef[coef_names]+ |
+ |
| 134 | +14x | +
+ se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ |
+ |
| 135 | ++ |
+ }+ |
+ |
| 136 | +38x | +
+ or <- exp(est)+ |
+ |
| 137 | +38x | +
+ ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ |
+ |
| 138 | +38x | +
+ x[[ref_level]] <- list(or = or, ci = ci)+ |
+ |
| 139 | ++ |
+ }+ |
+ |
| 140 | +14x | +
+ y[[var_level]] <- x+ |
+ |
| 141 | ++ |
+ }+ |
+ |
| 142 | +8x | +
+ y+ |
+ |
| 143 | ++ |
+ }+ |
+ |
| 144 | ++ | + + | +|
| 145 | ++ |
+ #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ |
+ |
| 146 | ++ |
+ #' for the case when either the odds ratio or the interaction variable is continuous.+ |
+ |
| 147 | ++ |
+ #'+ |
+ |
| 148 | ++ |
+ #' @param at (`numeric` or `NULL`)\cr optional values for the interaction variable. Otherwise+ |
+ |
| 149 | ++ |
+ #' the median is used.+ |
+ |
| 150 | ++ |
+ #'+ |
+ |
| 151 | ++ |
+ #' @return Odds ratio.+ |
+ |
| 152 | ++ |
+ #'+ |
+ |
| 153 | ++ |
+ #' @note We don't provide a function for the case when both variables are continuous because+ |
+ |
| 154 | ++ |
+ #' this does not arise in this table, as the treatment arm variable will always be involved+ |
+ |
| 155 | ++ |
+ #' and categorical.+ |
+ |
| 156 | ++ |
+ #'+ |
+ |
| 157 | ++ |
+ #' @export+ |
+ |
| 158 | ++ |
+ h_or_cont_interaction <- function(odds_ratio_var,+ |
+ |
| 159 | ++ |
+ interaction_var,+ |
+ |
| 160 | ++ |
+ fit_glm,+ |
+ |
| 161 | ++ |
+ at = NULL,+ |
+ |
| 162 | ++ |
+ conf_level = 0.95) {
+ |
+ |
| 163 | +13x | +
+ interaction_vars <- h_get_interaction_vars(fit_glm)+ |
+ |
| 164 | +13x | +
+ checkmate::assert_string(odds_ratio_var)+ |
+ |
| 165 | +13x | +
+ checkmate::assert_string(interaction_var)+ |
+ |
| 166 | +13x | +
+ checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars)+ |
+ |
| 167 | +13x | +
+ checkmate::assert_vector(interaction_vars, len = 2)+ |
+ |
| 168 | +13x | +
+ checkmate::assert_numeric(at, min.len = 1, null.ok = TRUE, any.missing = FALSE)+ |
+ |
| 169 | +13x | +
+ xs_level <- fit_glm$xlevels+ |
+ |
| 170 | +13x | +
+ xs_coef <- stats::coef(fit_glm)+ |
+ |
| 171 | +13x | +
+ xs_vcov <- stats::vcov(fit_glm)+ |
+ |
| 172 | +13x | +
+ xs_class <- attr(fit_glm$terms, "dataClasses")+ |
+ |
| 173 | +13x | +
+ model_data <- fit_glm$model+ |
+ |
| 174 | +13x | +
+ if (!is.null(at)) {
+ |
+ |
| 175 | +3x | +
+ checkmate::assert_set_equal(xs_class[interaction_var], "numeric")+ |
+ |
| 176 | ++ |
+ }+ |
+ |
| 177 | +12x | +
+ y <- list()+ |
+ |
| 178 | +12x | +
+ if (xs_class[interaction_var] == "numeric") {
+ |
+ |
| 179 | +7x | +
+ if (is.null(at)) {
+ |
+ |
| 180 | +5x | +
+ at <- ceiling(stats::median(model_data[[interaction_var]]))+ |
+ |
| 181 | ++ |
+ }+ |
+ |
| 182 | ++ | + + | +|
| 183 | +7x | +
+ for (var_level in xs_level[[odds_ratio_var]][-1]) {
+ |
+ |
| 184 | +14x | +
+ x <- list()+ |
+ |
| 185 | +14x | +
+ for (increment in at) {
+ |
+ |
| 186 | +20x | +
+ coef_names <- paste0(odds_ratio_var, var_level)+ |
+ |
| 187 | +20x | +
+ if (increment != 0) {
+ |
+ |
| 188 | +20x | +
+ interaction_coef_name <- h_interaction_coef_name(+ |
+ |
| 189 | +20x | +
+ interaction_vars,+ |
+ |
| 190 | +20x | +
+ c(odds_ratio_var, var_level),+ |
+ |
| 191 | +20x | +
+ c(interaction_var, "")+ |
+ |
| 192 | ++ |
+ )+ |
+ |
| 193 | +20x | +
+ coef_names <- c(+ |
+ |
| 194 | +20x | +
+ coef_names,+ |
+ |
| 195 | +20x | +
+ interaction_coef_name+ |
+ |
| 196 | ++ |
+ )+ |
+ |
| 197 | ++ |
+ }+ |
+ |
| 198 | +20x | +
+ if (length(coef_names) > 1) {
+ |
+ |
| 199 | +20x | +
+ xvec <- t(c(1, increment))+ |
+ |
| 200 | +20x | +
+ est <- as.numeric(xvec %*% xs_coef[coef_names])+ |
+ |
| 201 | +20x | +
+ se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec)))+ |
+ |
| 202 | ++ |
+ } else {
+ |
+ |
| 203 | +! | +
+ est <- xs_coef[coef_names]+ |
+ |
| 204 | +! | +
+ se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ |
+ |
| 205 | ++ |
+ }+ |
+ |
| 206 | +20x | +
+ or <- exp(est)+ |
+ |
| 207 | +20x | +
+ ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ |
+ |
| 208 | +20x | +
+ x[[as.character(increment)]] <- list(or = or, ci = ci)+ |
+ |
| 209 | ++ |
+ }+ |
+ |
| 210 | +14x | +
+ y[[var_level]] <- x+ |
+ |
| 211 | ++ |
+ }+ |
+ |
| 212 | ++ |
+ } else {
+ |
+ |
| 213 | +5x | +
+ checkmate::assert_set_equal(xs_class[odds_ratio_var], "numeric")+ |
+ |
| 214 | +5x | +
+ checkmate::assert_set_equal(xs_class[interaction_var], "factor")+ |
+ |
| 215 | +5x | +
+ for (var_level in xs_level[[interaction_var]]) {
+ |
+ |
| 216 | +15x | +
+ coef_names <- odds_ratio_var+ |
+ |
| 217 | +15x | +
+ if (var_level != xs_level[[interaction_var]][1]) {
+ |
+ |
| 218 | +10x | +
+ interaction_coef_name <- h_interaction_coef_name(+ |
+ |
| 219 | +10x | +
+ interaction_vars,+ |
+ |
| 220 | +10x | +
+ c(odds_ratio_var, ""),+ |
+ |
| 221 | +10x | +
+ c(interaction_var, var_level)+ |
+ |
| 222 | ++ |
+ )+ |
+ |
| 223 | +10x | +
+ coef_names <- c(+ |
+ |
| 224 | +10x | +
+ coef_names,+ |
+ |
| 225 | +10x | +
+ interaction_coef_name+ |
+ |
| 226 | ++ |
+ )+ |
+ |
| 227 | ++ |
+ }+ |
+ |
| 228 | +15x | +
+ if (length(coef_names) > 1) {
+ |
+ |
| 229 | +10x | +
+ xvec <- t(c(1, 1))+ |
+ |
| 230 | +10x | +
+ est <- as.numeric(xvec %*% xs_coef[coef_names])+ |
+ |
| 231 | +10x | +
+ se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec)))+ |
+ |
| 232 | ++ |
+ } else {
+ |
+ |
| 233 | +5x | +
+ est <- xs_coef[coef_names]+ |
+ |
| 234 | +5x | +
+ se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ |
+ |
| 235 | ++ |
+ }+ |
+ |
| 236 | +15x | +
+ or <- exp(est)+ |
+ |
| 237 | +15x | +
+ ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ |
+ |
| 238 | +15x | +
+ y[[var_level]] <- list(or = or, ci = ci)+ |
+ |
| 239 | ++ |
+ }+ |
+ |
| 240 | ++ |
+ }+ |
+ |
| 241 | +12x | +
+ y+ |
+ |
| 242 | ++ |
+ }+ |
+ |
| 243 | ++ | + + | +|
| 244 | ++ |
+ #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ |
+ |
| 245 | ++ |
+ #' in case of an interaction. This is a wrapper for [h_or_cont_interaction()] and+ |
+ |
| 246 | ++ |
+ #' [h_or_cat_interaction()].+ |
+ |
| 247 | ++ |
+ #'+ |
+ |
| 248 | ++ |
+ #' @return Odds ratio.+ |
+ |
| 249 | ++ |
+ #'+ |
+ |
| 250 | ++ |
+ #' @export+ |
+ |
| 251 | ++ |
+ h_or_interaction <- function(odds_ratio_var,+ |
+ |
| 252 | ++ |
+ interaction_var,+ |
+ |
| 253 | ++ |
+ fit_glm,+ |
+ |
| 254 | ++ |
+ at = NULL,+ |
+ |
| 255 | ++ |
+ conf_level = 0.95) {
+ |
+ |
| 256 | +15x | +
+ xs_class <- attr(fit_glm$terms, "dataClasses")+ |
+ |
| 257 | +15x | +
+ if (any(xs_class[c(odds_ratio_var, interaction_var)] == "numeric")) {
+ |
+ |
| 258 | +9x | +
+ h_or_cont_interaction(+ |
+ |
| 259 | +9x | +
+ odds_ratio_var,+ |
+ |
| 260 | +9x | +
+ interaction_var,+ |
+ |
| 261 | +9x | +
+ fit_glm,+ |
+ |
| 262 | +9x | +
+ at = at,+ |
+ |
| 263 | +9x | +
+ conf_level = conf_level+ |
+ |
| 264 | ++ |
+ )+ |
+ |
| 265 | +6x | +
+ } else if (all(xs_class[c(odds_ratio_var, interaction_var)] == "factor")) {
+ |
+ |
| 266 | +6x | +
+ h_or_cat_interaction(+ |
+ |
| 267 | +6x | +
+ odds_ratio_var,+ |
+ |
| 268 | +6x | +
+ interaction_var,+ |
+ |
| 269 | +6x | +
+ fit_glm,+ |
+ |
| 270 | +6x | +
+ conf_level = conf_level+ |
+ |
| 271 | ++ |
+ )+ |
+ |
| 272 | ++ |
+ } else {
+ |
+ |
| 273 | +! | +
+ stop("wrong interaction variable class, the interaction variable is not a numeric nor a factor")
+ |
+ |
| 274 | ++ |
+ }+ |
+ |
| 275 | ++ |
+ }+ |
+ |
| 276 | ++ | + + | +|
| 277 | ++ |
+ #' @describeIn h_logistic_regression Helper function to construct term labels from simple terms and the table+ |
+ |
| 278 | ++ |
+ #' of numbers of patients.+ |
+ |
| 279 | ++ |
+ #'+ |
+ |
| 280 | ++ |
+ #' @param terms (`character`)\cr simple terms.+ |
+ |
| 281 | ++ |
+ #' @param table (`table`)\cr table containing numbers for terms.+ |
+ |
| 282 | ++ |
+ #'+ |
+ |
| 283 | ++ |
+ #' @return Term labels containing numbers of patients.+ |
+ |
| 284 | ++ |
+ #'+ |
+ |
| 285 | ++ |
+ #' @export+ |
+ |
| 286 | ++ |
+ h_simple_term_labels <- function(terms,+ |
+ |
| 287 | ++ |
+ table) {
+ |
+ |
| 288 | +54x | +
+ checkmate::assert_true(is.table(table))+ |
+ |
| 289 | +54x | +
+ checkmate::assert_multi_class(terms, classes = c("factor", "character"))
+ |
+ |
| 290 | +54x | +
+ terms <- as.character(terms)+ |
+ |
| 291 | +54x | +
+ term_n <- table[terms]+ |
+ |
| 292 | +54x | +
+ paste0(terms, ", n = ", term_n)+ |
+ |
| 293 | ++ |
+ }+ |
+ |
| 294 | ++ | + + | +|
| 295 | ++ |
+ #' @describeIn h_logistic_regression Helper function to construct term labels from interaction terms and the table+ |
+ |
| 296 | ++ |
+ #' of numbers of patients.+ |
+ |
| 297 | ++ |
+ #'+ |
+ |
| 298 | ++ |
+ #' @param terms1 (`character`)\cr terms for first dimension (rows).+ |
+ |
| 299 | ++ |
+ #' @param terms2 (`character`)\cr terms for second dimension (rows).+ |
+ |
| 300 | ++ |
+ #' @param any (`flag`)\cr whether any of `term1` and `term2` can be fulfilled to count the+ |
+ |
| 301 | ++ |
+ #' number of patients. In that case they can only be scalar (strings).+ |
+ |
| 302 | ++ |
+ #'+ |
+ |
| 303 | ++ |
+ #' @return Term labels containing numbers of patients.+ |
+ |
| 304 | ++ |
+ #'+ |
+ |
| 305 | ++ |
+ #' @export+ |
+ |
| 306 | ++ |
+ h_interaction_term_labels <- function(terms1,+ |
+ |
| 307 | ++ |
+ terms2,+ |
+ |
| 308 | ++ |
+ table,+ |
+ |
| 309 | ++ |
+ any = FALSE) {
+ |
+ |
| 310 | +8x | +
+ checkmate::assert_true(is.table(table))+ |
+ |
| 311 | +8x | +
+ checkmate::assert_flag(any)+ |
+ |
| 312 | +8x | +
+ checkmate::assert_multi_class(terms1, classes = c("factor", "character"))
+ |
+ |
| 313 | +8x | +
+ checkmate::assert_multi_class(terms2, classes = c("factor", "character"))
+ |
+ |
| 314 | +8x | +
+ terms1 <- as.character(terms1)+ |
+ |
| 315 | +8x | +
+ terms2 <- as.character(terms2)+ |
+ |
| 316 | +8x | +
+ if (any) {
+ |
+ |
| 317 | +4x | +
+ checkmate::assert_scalar(terms1)+ |
+ |
| 318 | +4x | +
+ checkmate::assert_scalar(terms2)+ |
+ |
| 319 | +4x | +
+ paste0(+ |
+ |
| 320 | +4x | +
+ terms1, " or ", terms2, ", n = ",+ |
+ |
| 321 | ++ |
+ # Note that we double count in the initial sum the cell [terms1, terms2], therefore subtract.+ |
+ |
| 322 | +4x | +
+ sum(c(table[terms1, ], table[, terms2])) - table[terms1, terms2]+ |
+ |
| 323 | ++ |
+ )+ |
+ |
| 324 | ++ |
+ } else {
+ |
+ |
| 325 | +4x | +
+ term_n <- table[cbind(terms1, terms2)]+ |
+ |
| 326 | +4x | +
+ paste0(terms1, " * ", terms2, ", n = ", term_n)+ |
+ |
| 327 | ++ |
+ }+ |
+ |
| 328 | ++ |
+ }+ |
+ |
| 329 | ++ | + + | +|
| 330 | ++ |
+ #' @describeIn h_logistic_regression Helper function to tabulate the main effect+ |
+ |
| 331 | ++ |
+ #' results of a (conditional) logistic regression model.+ |
+ |
| 332 | ++ |
+ #'+ |
+ |
| 333 | ++ |
+ #' @return Tabulated main effect results from a logistic regression model.+ |
+ |
| 334 | ++ |
+ #'+ |
+ |
| 335 | ++ |
+ #' @examples+ |
+ |
| 336 | ++ |
+ #' h_glm_simple_term_extract("AGE", mod1)
+ |
+ |
| 337 | ++ |
+ #' h_glm_simple_term_extract("ARMCD", mod1)
+ |
+ |
| 338 | ++ |
+ #'+ |
+ |
| 339 | ++ |
+ #' @export+ |
+ |
| 340 | ++ |
+ h_glm_simple_term_extract <- function(x, fit_glm) {
+ |
+ |
| 341 | +78x | +
+ checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
+ |
+ |
| 342 | +78x | +
+ checkmate::assert_string(x)+ |
+ |
| 343 | ++ | + + | +|
| 344 | +78x | +
+ xs_class <- attr(fit_glm$terms, "dataClasses")+ |
+ |
| 345 | +78x | +
+ xs_level <- fit_glm$xlevels+ |
+ |
| 346 | +78x | +
+ xs_coef <- summary(fit_glm)$coefficients+ |
+ |
| 347 | +78x | +
+ stats <- if (inherits(fit_glm, "glm")) {
+ |
+ |
| 348 | +66x | +
+ c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
+ |
+ |
| 349 | ++ |
+ } else {
+ |
+ |
| 350 | +12x | +
+ c("estimate" = "coef", "std_error" = "se(coef)", "pvalue" = "Pr(>|z|)")
+ |
+ |
| 351 | ++ |
+ }+ |
+ |
| 352 | ++ |
+ # Make sure x is not an interaction term.+ |
+ |
| 353 | +78x | +
+ checkmate::assert_subset(x, names(xs_class))+ |
+ |
| 354 | +78x | +
+ x_sel <- if (xs_class[x] == "numeric") x else paste0(x, xs_level[[x]][-1])+ |
+ |
| 355 | +78x | +
+ x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE)+ |
+ |
| 356 | +78x | +
+ colnames(x_stats) <- names(stats)+ |
+ |
| 357 | +78x | +
+ x_stats$estimate <- as.list(x_stats$estimate)+ |
+ |
| 358 | +78x | +
+ x_stats$std_error <- as.list(x_stats$std_error)+ |
+ |
| 359 | +78x | +
+ x_stats$pvalue <- as.list(x_stats$pvalue)+ |
+ |
| 360 | +78x | +
+ x_stats$df <- as.list(1)+ |
+ |
| 361 | +78x | +
+ if (xs_class[x] == "numeric") {
+ |
+ |
| 362 | +60x | +
+ x_stats$term <- x+ |
+ |
| 363 | +60x | +
+ x_stats$term_label <- if (inherits(fit_glm, "glm")) {
+ |
+ |
| 364 | +48x | +
+ formatters::var_labels(fit_glm$data[x], fill = TRUE)+ |
+ |
| 365 | ++ |
+ } else {
+ |
+ |
| 366 | ++ |
+ # We just fill in here with the `term` itself as we don't have the data available.+ |
+ |
| 367 | +12x | +
+ x+ |
+ |
| 368 | ++ |
+ }+ |
+ |
| 369 | +60x | +
+ x_stats$is_variable_summary <- FALSE+ |
+ |
| 370 | +60x | +
+ x_stats$is_term_summary <- TRUE+ |
+ |
| 371 | ++ |
+ } else {
+ |
+ |
| 372 | +18x | +
+ checkmate::assert_class(fit_glm, "glm")+ |
+ |
| 373 | ++ |
+ # The reason is that we don't have the original data set in the `clogit` object+ |
+ |
| 374 | ++ |
+ # and therefore cannot determine the `x_numbers` here.+ |
+ |
| 375 | +18x | +
+ x_numbers <- table(fit_glm$data[[x]])+ |
+ |
| 376 | +18x | +
+ x_stats$term <- xs_level[[x]][-1]+ |
+ |
| 377 | +18x | +
+ x_stats$term_label <- h_simple_term_labels(x_stats$term, x_numbers)+ |
+ |
| 378 | +18x | +
+ x_stats$is_variable_summary <- FALSE+ |
+ |
| 379 | +18x | +
+ x_stats$is_term_summary <- TRUE+ |
+ |
| 380 | +18x | +
+ main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald")+ |
+ |
| 381 | +18x | +
+ x_main <- data.frame(+ |
+ |
| 382 | +18x | +
+ pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE],+ |
+ |
| 383 | +18x | +
+ term = xs_level[[x]][1],+ |
+ |
| 384 | +18x | +
+ term_label = paste("Reference", h_simple_term_labels(xs_level[[x]][1], x_numbers)),
+ |
+ |
| 385 | +18x | +
+ df = main_effects[x, "Df", drop = TRUE],+ |
+ |
| 386 | +18x | +
+ stringsAsFactors = FALSE+ |
+ |
| 387 | ++ |
+ )+ |
+ |
| 388 | +18x | +
+ x_main$pvalue <- as.list(x_main$pvalue)+ |
+ |
| 389 | +18x | +
+ x_main$df <- as.list(x_main$df)+ |
+ |
| 390 | +18x | +
+ x_main$estimate <- list(numeric(0))+ |
+ |
| 391 | +18x | +
+ x_main$std_error <- list(numeric(0))+ |
+ |
| 392 | +18x | +
+ if (length(xs_level[[x]][-1]) == 1) {
+ |
+ |
| 393 | +8x | +
+ x_main$pvalue <- list(numeric(0))+ |
+ |
| 394 | +8x | +
+ x_main$df <- list(numeric(0))+ |
+ |
| 395 | ++ |
+ }+ |
+ |
| 396 | +18x | +
+ x_main$is_variable_summary <- TRUE+ |
+ |
| 397 | +18x | +
+ x_main$is_term_summary <- FALSE+ |
+ |
| 398 | +18x | +
+ x_stats <- rbind(x_main, x_stats)+ |
+ |
| 399 | ++ |
+ }+ |
+ |
| 400 | +78x | +
+ x_stats$variable <- x+ |
+ |
| 401 | +78x | +
+ x_stats$variable_label <- if (inherits(fit_glm, "glm")) {
+ |
+ |
| 402 | +66x | +
+ formatters::var_labels(fit_glm$data[x], fill = TRUE)+ |
+ |
| 403 | ++ |
+ } else {
+ |
+ |
| 404 | +12x | +
+ x+ |
+ |
| 405 | ++ |
+ }+ |
+ |
| 406 | +78x | +
+ x_stats$interaction <- ""+ |
+ |
| 407 | +78x | +
+ x_stats$interaction_label <- ""+ |
+ |
| 408 | +78x | +
+ x_stats$reference <- ""+ |
+ |
| 409 | +78x | +
+ x_stats$reference_label <- ""+ |
+ |
| 410 | +78x | +
+ rownames(x_stats) <- NULL+ |
+ |
| 411 | +78x | +
+ x_stats[c(+ |
+ |
| 412 | +78x | +
+ "variable",+ |
+ |
| 413 | +78x | +
+ "variable_label",+ |
+ |
| 414 | +78x | +
+ "term",+ |
+ |
| 415 | +78x | +
+ "term_label",+ |
+ |
| 416 | +78x | +
+ "interaction",+ |
+ |
| 417 | +78x | +
+ "interaction_label",+ |
+ |
| 418 | +78x | +
+ "reference",+ |
+ |
| 419 | +78x | +
+ "reference_label",+ |
+ |
| 420 | +78x | +
+ "estimate",+ |
+ |
| 421 | +78x | +
+ "std_error",+ |
+ |
| 422 | +78x | +
+ "df",+ |
+ |
| 423 | +78x | +
+ "pvalue",+ |
+ |
| 424 | +78x | +
+ "is_variable_summary",+ |
+ |
| 425 | +78x | +
+ "is_term_summary"+ |
+ |
| 426 | ++ |
+ )]+ |
+ |
| 427 | ++ |
+ }+ |
+ |
| 428 | ++ | + + | +|
| 429 | ++ |
+ #' @describeIn h_logistic_regression Helper function to tabulate the interaction term+ |
+ |
| 430 | ++ |
+ #' results of a logistic regression model.+ |
+ |
| 431 | ++ |
+ #'+ |
+ |
| 432 | ++ |
+ #' @return Tabulated interaction term results from a logistic regression model.+ |
+ |
| 433 | ++ |
+ #'+ |
+ |
| 434 | ++ |
+ #' @examples+ |
+ |
| 435 | ++ |
+ #' h_glm_interaction_extract("ARMCD:AGE", mod2)
+ |
+ |
| 436 | ++ |
+ #'+ |
+ |
| 437 | ++ |
+ #' @export+ |
+ |
| 438 | ++ |
+ h_glm_interaction_extract <- function(x, fit_glm) {
+ |
+ |
| 439 | +7x | +
+ vars <- h_get_interaction_vars(fit_glm)+ |
+ |
| 440 | +7x | +
+ xs_class <- attr(fit_glm$terms, "dataClasses")+ |
+ |
| 441 | ++ | + + | +|
| 442 | +7x | +
+ checkmate::assert_string(x)+ |
+ |
| 443 | ++ | + + | +|
| 444 | ++ |
+ # Only take two-way interaction+ |
+ |
| 445 | +7x | +
+ checkmate::assert_vector(vars, len = 2)+ |
+ |
| 446 | ++ | + + | +|
| 447 | ++ |
+ # Only consider simple case: first variable in interaction is arm, a categorical variable+ |
+ |
| 448 | +7x | +
+ checkmate::assert_disjunct(xs_class[vars[1]], "numeric")+ |
+ |
| 449 | ++ | + + | +|
| 450 | +7x | +
+ xs_level <- fit_glm$xlevels+ |
+ |
| 451 | +7x | +
+ xs_coef <- summary(fit_glm)$coefficients+ |
+ |
| 452 | +7x | +
+ main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald")+ |
+ |
| 453 | +7x | +
+ stats <- c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
+ |
+ |
| 454 | +7x | +
+ v1_comp <- xs_level[[vars[1]]][-1]+ |
+ |
| 455 | +7x | +
+ if (xs_class[vars[2]] == "numeric") {
+ |
+ |
| 456 | +4x | +
+ x_stats <- as.data.frame(+ |
+ |
| 457 | +4x | +
+ xs_coef[paste0(vars[1], v1_comp, ":", vars[2]), stats, drop = FALSE],+ |
+ |
| 458 | +4x | +
+ stringsAsFactors = FALSE+ |
+ |
| 459 | ++ |
+ )+ |
+ |
| 460 | +4x | +
+ colnames(x_stats) <- names(stats)+ |
+ |
| 461 | +4x | +
+ x_stats$term <- v1_comp+ |
+ |
| 462 | +4x | +
+ x_numbers <- table(fit_glm$data[[vars[1]]])+ |
+ |
| 463 | +4x | +
+ x_stats$term_label <- h_simple_term_labels(v1_comp, x_numbers)+ |
+ |
| 464 | +4x | +
+ v1_ref <- xs_level[[vars[1]]][1]+ |
+ |
| 465 | +4x | +
+ term_main <- v1_ref+ |
+ |
| 466 | +4x | +
+ ref_label <- h_simple_term_labels(v1_ref, x_numbers)+ |
+ |
| 467 | +3x | +
+ } else if (xs_class[vars[2]] != "numeric") {
+ |
+ |
| 468 | +3x | +
+ v2_comp <- xs_level[[vars[2]]][-1]+ |
+ |
| 469 | +3x | +
+ v1_v2_grid <- expand.grid(v1 = v1_comp, v2 = v2_comp)+ |
+ |
| 470 | +3x | +
+ x_sel <- paste(+ |
+ |
| 471 | +3x | +
+ paste0(vars[1], v1_v2_grid$v1),+ |
+ |
| 472 | +3x | +
+ paste0(vars[2], v1_v2_grid$v2),+ |
+ |
| 473 | +3x | +
+ sep = ":"+ |
+ |
| 474 | ++ |
+ )+ |
+ |
| 475 | +3x | +
+ x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE) |
|
| 1 |
- #' Get default statistical methods and their associated formats, labels, and indent modifiers+ #' Kaplan-Meier plot+ |
+ |||
| 2 | ++ |
+ #'+ |
+ ||
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+ ||
| 4 | ++ |
+ #'+ |
+ ||
| 5 | ++ |
+ #' From a survival model, a graphic is rendered along with tabulated annotation+ |
+ ||
| 6 | ++ |
+ #' including the number of patient at risk at given time and the median survival+ |
+ ||
| 7 | ++ |
+ #' per group.+ |
+ ||
| 8 | ++ |
+ #'+ |
+ ||
| 9 | ++ |
+ #' @inheritParams argument_convention+ |
+ ||
| 10 | ++ |
+ #' @param variables (named `list`)\cr variable names. Details are:+ |
+ ||
| 11 | ++ |
+ #' * `tte` (`numeric`)\cr variable indicating time-to-event duration values.+ |
+ ||
| 12 | ++ |
+ #' * `is_event` (`logical`)\cr event variable. `TRUE` if event, `FALSE` if time to event is censored.+ |
+ ||
| 13 | ++ |
+ #' * `arm` (`factor`)\cr the treatment group variable.+ |
+ ||
| 14 | ++ |
+ #' * `strata` (`character` or `NULL`)\cr variable names indicating stratification factors.+ |
+ ||
| 15 | ++ |
+ #' @param control_surv (`list`)\cr parameters for comparison details, specified by using+ |
+ ||
| 16 | ++ |
+ #' the helper function [control_surv_timepoint()]. Some possible parameter options are:+ |
+ ||
| 17 | ++ |
+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate.+ |
+ ||
| 18 | ++ |
+ #' * `conf_type` (`string`)\cr `"plain"` (default), `"log"`, `"log-log"` for confidence interval type,+ |
+ ||
| 19 | ++ |
+ #' see more in [survival::survfit()]. Note that the option "none" is no longer supported.+ |
+ ||
| 20 | ++ |
+ #' @param col (`character`)\cr lines colors. Length of a vector should be equal+ |
+ ||
| 21 | ++ |
+ #' to number of strata from [survival::survfit()].+ |
+ ||
| 22 | ++ |
+ #' @param lty (`numeric`)\cr line type. If a vector is given, its length should be equal to the number of strata from+ |
+ ||
| 23 | ++ |
+ #' [survival::survfit()].+ |
+ ||
| 24 | ++ |
+ #' @param lwd (`numeric`)\cr line width. If a vector is given, its length should be equal to the number of strata from+ |
+ ||
| 25 | ++ |
+ #' [survival::survfit()].+ |
+ ||
| 26 | ++ |
+ #' @param censor_show (`flag`)\cr whether to show censored observations.+ |
+ ||
| 27 | ++ |
+ #' @param pch (`string`)\cr name of symbol or character to use as point symbol to indicate censored cases.+ |
+ ||
| 28 | ++ |
+ #' @param size (`numeric(1)`)\cr size of censored point symbols.+ |
+ ||
| 29 | ++ |
+ #' @param max_time (`numeric(1)`)\cr maximum value to show on x-axis. Only data values less than or up to+ |
+ ||
| 30 | ++ |
+ #' this threshold value will be plotted (defaults to `NULL`).+ |
+ ||
| 31 | ++ |
+ #' @param xticks (`numeric` or `NULL`)\cr numeric vector of tick positions or a single number with spacing+ |
+ ||
| 32 | ++ |
+ #' between ticks on the x-axis. If `NULL` (default), [labeling::extended()] is used to determine+ |
+ ||
| 33 | ++ |
+ #' optimal tick positions on the x-axis.+ |
+ ||
| 34 | ++ |
+ #' @param xlab (`string`)\cr x-axis label.+ |
+ ||
| 35 | ++ |
+ #' @param yval (`string`)\cr type of plot, to be plotted on the y-axis. Options are `Survival` (default) and `Failure`+ |
+ ||
| 36 | ++ |
+ #' probability.+ |
+ ||
| 37 | ++ |
+ #' @param ylab (`string`)\cr y-axis label.+ |
+ ||
| 38 | ++ |
+ #' @param title (`string`)\cr plot title.+ |
+ ||
| 39 | ++ |
+ #' @param footnotes (`string`)\cr plot footnotes.+ |
+ ||
| 40 | ++ |
+ #' @param font_size (`numeric(1)`)\cr font size to use for all text.+ |
+ ||
| 41 | ++ |
+ #' @param ci_ribbon (`flag`)\cr whether the confidence interval should be drawn around the Kaplan-Meier curve.+ |
+ ||
| 42 | ++ |
+ #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of patient at risk+ |
+ ||
| 43 | ++ |
+ #' matching the main grid of the Kaplan-Meier curve.+ |
+ ||
| 44 | ++ |
+ #' @param annot_at_risk_title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk`+ |
+ ||
| 45 | ++ |
+ #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`.+ |
+ ||
| 46 | ++ |
+ #' @param annot_surv_med (`flag`)\cr compute and add the annotation table on the Kaplan-Meier curve estimating the+ |
+ ||
| 47 | ++ |
+ #' median survival time per group.+ |
+ ||
| 48 | ++ |
+ #' @param annot_coxph (`flag`)\cr whether to add the annotation table from a [survival::coxph()] model.+ |
+ ||
| 49 | ++ |
+ #' @param annot_stats (`string` or `NULL`)\cr statistics annotations to add to the plot. Options are+ |
+ ||
| 50 | ++ |
+ #' `median` (median survival follow-up time) and `min` (minimum survival follow-up time).+ |
+ ||
| 51 | ++ |
+ #' @param annot_stats_vlines (`flag`)\cr add vertical lines corresponding to each of the statistics+ |
+ ||
| 52 | ++ |
+ #' specified by `annot_stats`. If `annot_stats` is `NULL` no lines will be added.+ |
+ ||
| 53 | ++ |
+ #' @param control_coxph_pw (`list`)\cr parameters for comparison details, specified using the helper function+ |
+ ||
| 54 | ++ |
+ #' [control_coxph()]. Some possible parameter options are:+ |
+ ||
| 55 | ++ |
+ #' * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1.+ |
+ ||
| 56 | ++ |
+ #' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`.+ |
+ ||
| 57 | ++ |
+ #' * `ties` (`string`)\cr method for tie handling. Default is `"efron"`,+ |
+ ||
| 58 | ++ |
+ #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()]+ |
+ ||
| 59 | ++ |
+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR.+ |
+ ||
| 60 | ++ |
+ #' @param ref_group_coxph (`string` or `NULL`)\cr level of arm variable to use as reference group in calculations for+ |
+ ||
| 61 | ++ |
+ #' `annot_coxph` table. If `NULL` (default), uses the first level of the arm variable.+ |
+ ||
| 62 | ++ |
+ #' @param control_annot_surv_med (`list`)\cr parameters to control the position and size of the annotation table added+ |
+ ||
| 63 | ++ |
+ #' to the plot when `annot_surv_med = TRUE`, specified using the [control_surv_med_annot()] function. Parameter+ |
+ ||
| 64 | ++ |
+ #' options are: `x`, `y`, `w`, `h`, and `fill`. See [control_surv_med_annot()] for details.+ |
+ ||
| 65 | ++ |
+ #' @param control_annot_coxph (`list`)\cr parameters to control the position and size of the annotation table added+ |
+ ||
| 66 | ++ |
+ #' to the plot when `annot_coxph = TRUE`, specified using the [control_coxph_annot()] function. Parameter+ |
+ ||
| 67 | ++ |
+ #' options are: `x`, `y`, `w`, `h`, `fill`, and `ref_lbls`. See [control_coxph_annot()] for details.+ |
+ ||
| 68 | ++ |
+ #' @param legend_pos (`numeric(2)` or `NULL`)\cr vector containing x- and y-coordinates, respectively, for the legend+ |
+ ||
| 69 | ++ |
+ #' position relative to the KM plot area. If `NULL` (default), the legend is positioned in the bottom right corner of+ |
+ ||
| 70 | ++ |
+ #' the plot, or the middle right of the plot if needed to prevent overlapping.+ |
+ ||
| 71 | ++ |
+ #' @param rel_height_plot (`proportion`)\cr proportion of total figure height to allocate to the Kaplan-Meier plot.+ |
+ ||
| 72 | ++ |
+ #' Relative height of patients at risk table is then `1 - rel_height_plot`. If `annot_at_risk = FALSE` or+ |
+ ||
| 73 | ++ |
+ #' `as_list = TRUE`, this parameter is ignored.+ |
+ ||
| 74 | ++ |
+ #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to format the Kaplan-Meier plot.+ |
+ ||
| 75 | ++ |
+ #' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list when `annot_at_risk = TRUE`.+ |
+ ||
| 76 | ++ |
+ #' If `TRUE`, a named list with two elements, `plot` and `table`, will be returned. If `FALSE` (default) the patients+ |
+ ||
| 77 | ++ |
+ #' at risk table is printed below the plot via [cowplot::plot_grid()].+ |
+ ||
| 78 | ++ |
+ #' @param draw `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+ |
+ ||
| 79 | ++ |
+ #' @param newpage `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+ |
+ ||
| 80 | ++ |
+ #' @param gp `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+ |
+ ||
| 81 | ++ |
+ #' @param vp `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+ |
+ ||
| 82 | ++ |
+ #' @param name `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+ |
+ ||
| 83 | ++ |
+ #' @param annot_coxph_ref_lbls `r lifecycle::badge("deprecated")` Please use the `ref_lbls` element of
+ |
+ ||
| 84 | ++ |
+ #' `control_annot_coxph` instead.+ |
+ ||
| 85 | ++ |
+ #' @param position_coxph `r lifecycle::badge("deprecated")` Please use the `x` and `y` elements of
+ |
+ ||
| 86 | ++ |
+ #' `control_annot_coxph` instead.+ |
+ ||
| 87 | ++ |
+ #' @param position_surv_med `r lifecycle::badge("deprecated")` Please use the `x` and `y` elements of
+ |
+ ||
| 88 | ++ |
+ #' `control_annot_surv_med` instead.+ |
+ ||
| 89 | ++ |
+ #' @param width_annots `r lifecycle::badge("deprecated")` Please use the `w` element of `control_annot_surv_med`
+ |
+ ||
| 90 | ++ |
+ #' (for `surv_med`) and `control_annot_coxph` (for `coxph`)."+ |
+ ||
| 91 | ++ |
+ #'+ |
+ ||
| 92 | ++ |
+ #' @return A `ggplot` Kaplan-Meier plot and (optionally) summary table.+ |
+ ||
| 93 | ++ |
+ #'+ |
+ ||
| 94 | ++ |
+ #' @examples+ |
+ ||
| 95 | ++ |
+ #' library(dplyr)+ |
+ ||
| 96 | ++ |
+ #'+ |
+ ||
| 97 | ++ |
+ #' df <- tern_ex_adtte %>%+ |
+ ||
| 98 | ++ |
+ #' filter(PARAMCD == "OS") %>%+ |
+ ||
| 99 | ++ |
+ #' mutate(is_event = CNSR == 0)+ |
+ ||
| 100 | ++ |
+ #' variables <- list(tte = "AVAL", is_event = "is_event", arm = "ARMCD")+ |
+ ||
| 101 | ++ |
+ #' |
||
| 2 | +102 |
- #'+ #' # Basic examples |
||
| 3 | +103 |
- #' @description `r lifecycle::badge("stable")`
+ #' g_km(df = df, variables = variables) |
||
| 4 | +104 |
- #'+ #' g_km(df = df, variables = variables, yval = "Failure") |
||
| 5 | +105 |
- #' Utility functions to get valid statistic methods for different method groups+ #' |
||
| 6 | +106 |
- #' (`.stats`) and their associated formats (`.formats`), labels (`.labels`), and indent modifiers+ #' # Examples with customization parameters applied |
||
| 7 | +107 |
- #' (`.indent_mods`). This utility is used across `tern`, but some of its working principles can be+ #' g_km( |
||
| 8 | +108 |
- #' seen in [analyze_vars()]. See notes to understand why this is experimental.+ #' df = df, |
||
| 9 | +109 |
- #'+ #' variables = variables, |
||
| 10 | +110 |
- #' @param stats (`character`)\cr statistical methods to get defaults for.+ #' control_surv = control_surv_timepoint(conf_level = 0.9), |
||
| 11 | +111 |
- #'+ #' col = c("grey25", "grey50", "grey75"),
|
||
| 12 | +112 |
- #' @details+ #' annot_at_risk_title = FALSE, |
||
| 13 | +113 |
- #' Current choices for `type` are `counts` and `numeric` for [analyze_vars()] and affect `get_stats()`.+ #' lty = 1:3, |
||
| 14 | +114 |
- #'+ #' font_size = 8 |
||
| 15 | +115 |
- #' @note+ #' ) |
||
| 16 | +116 |
- #' These defaults are experimental because we use the names of functions to retrieve the default+ #' g_km( |
||
| 17 | +117 |
- #' statistics. This should be generalized in groups of methods according to more reasonable groupings.+ #' df = df, |
||
| 18 | +118 |
- #'+ #' variables = variables, |
||
| 19 | +119 |
- #' @name default_stats_formats_labels+ #' annot_stats = c("min", "median"),
|
||
| 20 | +120 |
- NULL+ #' annot_stats_vlines = TRUE, |
||
| 21 | +121 |
-
+ #' max_time = 3000, |
||
| 22 | +122 |
- #' @describeIn default_stats_formats_labels Get statistics available for a given method+ #' ggtheme = ggplot2::theme_minimal() |
||
| 23 | +123 |
- #' group (analyze function). To check available defaults see `tern::tern_default_stats` list.+ #' ) |
||
| 24 | +124 |
#' |
||
| 25 | +125 |
- #' @param method_groups (`character`)\cr indicates the statistical method group (`tern` analyze function)+ #' # Example with pairwise Cox-PH analysis annotation table, adjusted annotation tables |
||
| 26 | +126 |
- #' to retrieve default statistics for. A character vector can be used to specify more than one statistical+ #' g_km( |
||
| 27 | +127 |
- #' method group.+ #' df = df, variables = variables, |
||
| 28 | +128 |
- #' @param stats_in (`character`)\cr statistics to retrieve for the selected method group.+ #' annot_coxph = TRUE, |
||
| 29 | +129 |
- #' @param add_pval (`flag`)\cr should `"pval"` (or `"pval_counts"` if `method_groups` contains+ #' control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99), |
||
| 30 | +130 |
- #' `"analyze_vars_counts"`) be added to the statistical methods?+ #' control_annot_coxph = control_coxph_annot(x = 0.26, w = 0.35), |
||
| 31 | +131 |
- #'+ #' control_annot_surv_med = control_surv_med_annot(x = 0.8, y = 0.9, w = 0.35) |
||
| 32 | +132 |
- #' @return+ #' ) |
||
| 33 | +133 |
- #' * `get_stats()` returns a `character` vector of statistical methods.+ #' |
||
| 34 | +134 |
- #'+ #' @aliases kaplan_meier |
||
| 35 | +135 |
- #' @examples+ #' @export |
||
| 36 | +136 |
- #' # analyze_vars is numeric+ g_km <- function(df, |
||
| 37 | +137 |
- #' num_stats <- get_stats("analyze_vars_numeric") # also the default
+ variables, |
||
| 38 | +138 |
- #'+ control_surv = control_surv_timepoint(), |
||
| 39 | +139 |
- #' # Other type+ col = NULL, |
||
| 40 | +140 |
- #' cnt_stats <- get_stats("analyze_vars_counts")
+ lty = NULL, |
||
| 41 | +141 |
- #'+ lwd = 0.5, |
||
| 42 | +142 |
- #' # Weirdly taking the pval from count_occurrences+ censor_show = TRUE, |
||
| 43 | +143 |
- #' only_pval <- get_stats("count_occurrences", add_pval = TRUE, stats_in = "pval")
+ pch = 3, |
||
| 44 | +144 |
- #'+ size = 2, |
||
| 45 | +145 |
- #' # All count_occurrences+ max_time = NULL, |
||
| 46 | +146 |
- #' all_cnt_occ <- get_stats("count_occurrences")
+ xticks = NULL, |
||
| 47 | +147 |
- #'+ xlab = "Days", |
||
| 48 | +148 |
- #' # Multiple+ yval = c("Survival", "Failure"),
|
||
| 49 | +149 |
- #' get_stats(c("count_occurrences", "analyze_vars_counts"))
+ ylab = paste(yval, "Probability"), |
||
| 50 | +150 |
- #'+ ylim = NULL, |
||
| 51 | +151 |
- #' @export+ title = NULL, |
||
| 52 | +152 |
- get_stats <- function(method_groups = "analyze_vars_numeric", stats_in = NULL, add_pval = FALSE) {
+ footnotes = NULL, |
||
| 53 | -642x | +|||
| 153 | +
- checkmate::assert_character(method_groups)+ font_size = 10, |
|||
| 54 | -642x | +|||
| 154 | +
- checkmate::assert_character(stats_in, null.ok = TRUE)+ ci_ribbon = FALSE, |
|||
| 55 | -642x | +|||
| 155 | +
- checkmate::assert_flag(add_pval)+ annot_at_risk = TRUE, |
|||
| 56 | +156 |
-
+ annot_at_risk_title = TRUE, |
||
| 57 | +157 |
- # Default is still numeric+ annot_surv_med = TRUE, |
||
| 58 | -642x | +|||
| 158 | +
- if (any(method_groups == "analyze_vars")) {
+ annot_coxph = FALSE, |
|||
| 59 | -3x | +|||
| 159 | +
- method_groups[method_groups == "analyze_vars"] <- "analyze_vars_numeric"+ annot_stats = NULL, |
|||
| 60 | +160 |
- }+ annot_stats_vlines = FALSE, |
||
| 61 | +161 |
-
+ control_coxph_pw = control_coxph(), |
||
| 62 | -642x | +|||
| 162 | +
- type_tmp <- ifelse(any(grepl("counts$", method_groups)), "counts", "numeric") # for pval checks
+ ref_group_coxph = NULL, |
|||
| 63 | +163 |
-
+ control_annot_surv_med = control_surv_med_annot(), |
||
| 64 | +164 |
- # Defaults for loop+ control_annot_coxph = control_coxph_annot(), |
||
| 65 | -642x | +|||
| 165 | +
- out <- NULL+ legend_pos = NULL, |
|||
| 66 | +166 |
-
+ rel_height_plot = 0.75, |
||
| 67 | +167 |
- # Loop for multiple method groups+ ggtheme = NULL, |
||
| 68 | -642x | +|||
| 168 | +
- for (mgi in method_groups) {
+ as_list = FALSE, |
|||
| 69 | -669x | +|||
| 169 | +
- if (mgi %in% names(tern_default_stats)) {
+ draw = lifecycle::deprecated(), |
|||
| 70 | -668x | +|||
| 170 | +
- out_tmp <- tern_default_stats[[mgi]]+ newpage = lifecycle::deprecated(), |
|||
| 71 | +171 |
- } else {
+ gp = lifecycle::deprecated(), |
||
| 72 | -1x | +|||
| 172 | +
- stop("The selected method group (", mgi, ") has no default statistical method.")
+ vp = lifecycle::deprecated(), |
|||
| 73 | +173 |
- }+ name = lifecycle::deprecated(), |
||
| 74 | -668x | +|||
| 174 | +
- out <- unique(c(out, out_tmp))+ annot_coxph_ref_lbls = lifecycle::deprecated(), |
|||
| 75 | +175 |
- }+ position_coxph = lifecycle::deprecated(), |
||
| 76 | +176 |
-
+ position_surv_med = lifecycle::deprecated(), |
||
| 77 | +177 |
- # If you added pval to the stats_in you certainly want it+ width_annots = lifecycle::deprecated()) {
|
||
| 78 | -641x | +|||
| 178 | +
- if (!is.null(stats_in) && any(grepl("^pval", stats_in))) {
+ # Deprecated argument warnings |
|||
| 79 | -22x | +179 | +10x |
- stats_in_pval_value <- stats_in[grepl("^pval", stats_in)]
+ if (lifecycle::is_present(draw)) {
|
| 80 | -+ | |||
| 180 | +1x |
-
+ lifecycle::deprecate_warn( |
||
| 81 | -+ | |||
| 181 | +1x |
- # Must be only one value between choices+ "0.9.4", "g_km(draw)", |
||
| 82 | -22x | +182 | +1x |
- checkmate::assert_choice(stats_in_pval_value, c("pval", "pval_counts"))
+ details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
| 83 | +183 |
-
+ ) |
||
| 84 | +184 |
- # Mismatch with counts and numeric- |
- ||
| 85 | -21x | -
- if (any(grepl("counts", method_groups)) && stats_in_pval_value != "pval_counts" ||
- |
- ||
| 86 | -21x | -
- any(grepl("numeric", method_groups)) && stats_in_pval_value != "pval") { # nolint
+ } |
||
| 87 | -2x | +185 | +10x |
- stop(+ if (lifecycle::is_present(newpage)) {
|
| 88 | -2x | +186 | +1x |
- "Inserted p-value (", stats_in_pval_value, ") is not valid for type ",
+ lifecycle::deprecate_warn( |
| 89 | -2x | +187 | +1x |
- type_tmp, ". Use ", paste(ifelse(stats_in_pval_value == "pval", "pval_counts", "pval")),+ "0.9.4", "g_km(newpage)", |
| 90 | -2x | +188 | +1x |
- " instead."+ details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
| 91 | +189 |
- )+ ) |
||
| 92 | +190 |
- }+ } |
||
| 93 | -+ | |||
| 191 | +10x |
-
+ if (lifecycle::is_present(gp)) {
|
||
| 94 | -+ | |||
| 192 | +1x |
- # Lets add it even if present (thanks to unique)+ lifecycle::deprecate_warn( |
||
| 95 | -19x | +193 | +1x |
- add_pval <- TRUE+ "0.9.4", "g_km(gp)", |
| 96 | -+ | |||
| 194 | +1x |
- }+ details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
||
| 97 | +195 |
-
+ ) |
||
| 98 | +196 |
- # Mainly used in "analyze_vars" but it could be necessary elsewhere+ } |
||
| 99 | -638x | +197 | +10x |
- if (isTRUE(add_pval)) {
+ if (lifecycle::is_present(vp)) {
|
| 100 | -29x | +198 | +1x |
- if (any(grepl("counts", method_groups))) {
+ lifecycle::deprecate_warn( |
| 101 | -16x | -
- out <- unique(c(out, "pval_counts"))- |
- ||
| 102 | -+ | 199 | +1x |
- } else {
+ "0.9.4", "g_km(vp)", |
| 103 | -13x | +200 | +1x |
- out <- unique(c(out, "pval"))+ details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
| 104 | +201 |
- }+ ) |
||
| 105 | +202 |
} |
||
| 106 | -- | - - | -||
| 107 | -+ | |||
| 203 | +10x |
- # Filtering for stats_in (character vector)+ if (lifecycle::is_present(name)) {
|
||
| 108 | -638x | +204 | +1x |
- if (!is.null(stats_in)) {
+ lifecycle::deprecate_warn( |
| 109 | -586x | +205 | +1x |
- out <- intersect(stats_in, out) # It orders them too+ "0.9.4", "g_km(name)", |
| 110 | -+ | |||
| 206 | +1x |
- }+ details = "This argument is no longer used since the plot is now generated as a `ggplot2` object." |
||
| 111 | +207 |
-
+ ) |
||
| 112 | +208 |
- # If intersect did not find matches (and no pval?) -> error- |
- ||
| 113 | -638x | -
- if (length(out) == 0) {
+ } |
||
| 114 | -2x | +209 | +10x |
- stop(+ if (lifecycle::is_present(annot_coxph_ref_lbls)) {
|
| 115 | -2x | +210 | +1x |
- "The selected method group(s) (", paste0(method_groups, collapse = ", "), ")",
+ lifecycle::deprecate_warn( |
| 116 | -2x | +211 | +1x |
- " do not have the required default statistical methods:\n",+ "0.9.4", "g_km(annot_coxph_ref_lbls)", |
| 117 | -2x | +212 | +1x |
- paste0(stats_in, collapse = " ")+ details = "Please specify this setting using the 'ref_lbls' element of control_annot_coxph." |
| 118 | +213 |
) |
||
| 119 | -+ | |||
| 214 | +1x |
- }+ control_annot_coxph[["ref_lbls"]] <- annot_coxph_ref_lbls |
||
| 120 | +215 |
-
+ } |
||
| 121 | -636x | +216 | +10x |
- out+ if (lifecycle::is_present(position_coxph)) {
|
| 122 | -+ | |||
| 217 | +1x |
- }+ lifecycle::deprecate_warn( |
||
| 123 | -+ | |||
| 218 | +1x |
-
+ "0.9.4", "g_km(position_coxph)", |
||
| 124 | -+ | |||
| 219 | +1x |
-
+ details = "Please specify this setting using the 'x' and 'y' elements of control_annot_coxph." |
||
| 125 | +220 |
- #' @describeIn default_stats_formats_labels Get statistical NAMES available for a given method+ ) |
||
| 126 | -+ | |||
| 221 | +1x |
- #' group (analyze function). Please use the `s_*` functions to get the statistical names.+ control_annot_coxph[["x"]] <- position_coxph[1] |
||
| 127 | -+ | |||
| 222 | +1x |
- #' @param stat_results (`list`)\cr list of statistical results. It should be used close to the end of+ control_annot_coxph[["y"]] <- position_coxph[2] |
||
| 128 | +223 |
- #' a statistical function. See examples for a structure with two statistical results and two groups.+ } |
||
| 129 | -+ | |||
| 224 | +10x |
- #' @param stat_names_in (`character`)\cr custom modification of statistical values.+ if (lifecycle::is_present(position_surv_med)) {
|
||
| 130 | -+ | |||
| 225 | +1x |
- #'+ lifecycle::deprecate_warn( |
||
| 131 | -+ | |||
| 226 | +1x |
- #' @return+ "0.9.4", "g_km(position_surv_med)", |
||
| 132 | -+ | |||
| 227 | +1x |
- #' * `get_stat_names()` returns a named list of`character` vectors, indicating the names of+ details = "Please specify this setting using the 'x' and 'y' elements of control_annot_surv_med." |
||
| 133 | +228 |
- #' statistical outputs.+ ) |
||
| 134 | -+ | |||
| 229 | +1x |
- #'+ control_annot_surv_med[["x"]] <- position_surv_med[1] |
||
| 135 | -+ | |||
| 230 | +1x |
- #' @examples+ control_annot_surv_med[["y"]] <- position_surv_med[2] |
||
| 136 | +231 |
- #' stat_results <- list(+ } |
||
| 137 | -+ | |||
| 232 | +10x |
- #' "n" = list("M" = 1, "F" = 2),
+ if (lifecycle::is_present(width_annots)) {
|
||
| 138 | -+ | |||
| 233 | +1x |
- #' "count_fraction" = list("M" = c(1, 0.2), "F" = c(2, 0.1))
+ lifecycle::deprecate_warn( |
||
| 139 | -+ | |||
| 234 | +1x |
- #' )+ "0.9.4", "g_km(width_annots)", |
||
| 140 | -+ | |||
| 235 | +1x |
- #' get_stat_names(stat_results)+ details = paste( |
||
| 141 | -+ | |||
| 236 | +1x |
- #' get_stat_names(stat_results, list("n" = "argh"))
+ "Please specify widths of annotation tables relative to the plot area using the 'w' element of", |
||
| 142 | -+ | |||
| 237 | +1x |
- #'+ "control_annot_surv_med (for surv_med) and control_annot_coxph (for coxph)." |
||
| 143 | +238 |
- #' @export+ ) |
||
| 144 | +239 |
- get_stat_names <- function(stat_results, stat_names_in = NULL) {
+ ) |
||
| 145 | -331x | +240 | +1x |
- checkmate::assert_character(names(stat_results), min.len = 1)+ control_annot_surv_med[["w"]] <- as.numeric(width_annots[["surv_med"]]) |
| 146 | -331x | +241 | +1x |
- checkmate::assert_list(stat_names_in, null.ok = TRUE)+ control_annot_coxph[["w"]] <- as.numeric(width_annots[["coxph"]]) |
| 147 | +242 |
-
+ } |
||
| 148 | -331x | +|||
| 243 | +
- stat_nms_from_stats <- lapply(stat_results, function(si) {
+
|
|||
| 149 | -2608x | +244 | +10x |
- nm <- names(si)+ checkmate::assert_list(variables) |
| 150 | -2608x | +245 | +10x |
- if (is.null(nm)) {
+ checkmate::assert_subset(c("tte", "arm", "is_event"), names(variables))
|
| 151 | -30x | -
- nm <- rep(NA_character_, length(si)) # no statistical names- |
- ||
| 152 | -+ | 246 | +10x |
- }+ checkmate::assert_logical(censor_show, len = 1) |
| 153 | -2608x | +247 | +10x |
- return(nm)+ checkmate::assert_numeric(size, len = 1) |
| 154 | -+ | |||
| 248 | +10x |
- })+ checkmate::assert_numeric(max_time, len = 1, null.ok = TRUE) |
||
| 155 | -+ | |||
| 249 | +10x |
-
+ checkmate::assert_numeric(xticks, null.ok = TRUE) |
||
| 156 | -+ | |||
| 250 | +10x |
- # Modify some with custom stat names+ checkmate::assert_character(xlab, len = 1, null.ok = TRUE) |
||
| 157 | -331x | +251 | +10x |
- if (!is.null(stat_names_in)) {
+ checkmate::assert_character(yval) |
| 158 | -+ | |||
| 252 | +10x |
- # Stats is the main+ checkmate::assert_character(ylab, null.ok = TRUE) |
||
| 159 | -6x | +253 | +10x |
- common_names <- intersect(names(stat_nms_from_stats), names(stat_names_in))+ checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE) |
| 160 | -6x | +254 | +10x |
- stat_nms_from_stats[common_names] <- stat_names_in[common_names]+ checkmate::assert_character(title, len = 1, null.ok = TRUE) |
| 161 | -+ | |||
| 255 | +10x |
- }+ checkmate::assert_character(footnotes, len = 1, null.ok = TRUE) |
||
| 162 | -+ | |||
| 256 | +10x |
-
+ checkmate::assert_numeric(font_size, len = 1) |
||
| 163 | -331x | +257 | +10x |
- stat_nms_from_stats+ checkmate::assert_logical(ci_ribbon, len = 1) |
| 164 | -+ | |||
| 258 | +10x |
- }+ checkmate::assert_logical(annot_at_risk, len = 1) |
||
| 165 | -+ | |||
| 259 | +10x |
-
+ checkmate::assert_logical(annot_at_risk_title, len = 1) |
||
| 166 | -+ | |||
| 260 | +10x |
- # Utility function used to separate custom stats (user-defined functions) from defaults+ checkmate::assert_logical(annot_surv_med, len = 1) |
||
| 167 | -+ | |||
| 261 | +10x |
- .split_std_from_custom_stats <- function(stats_in) {
+ checkmate::assert_logical(annot_coxph, len = 1) |
||
| 168 | -354x | +262 | +10x |
- out <- list(default_stats = NULL, custom_stats = NULL)+ checkmate::assert_subset(annot_stats, c("median", "min"))
|
| 169 | -354x | +263 | +10x |
- if (is.list(stats_in)) {
+ checkmate::assert_logical(annot_stats_vlines) |
| 170 | -9x | +264 | +10x |
- is_custom_fnc <- sapply(stats_in, is.function)+ checkmate::assert_list(control_coxph_pw) |
| 171 | -9x | +265 | +10x |
- checkmate::assert_list(stats_in[is_custom_fnc], types = "function", names = "named")+ checkmate::assert_character(ref_group_coxph, len = 1, null.ok = TRUE) |
| 172 | -9x | +266 | +10x |
- out[["custom_stats"]] <- stats_in[is_custom_fnc]+ checkmate::assert_list(control_annot_surv_med) |
| 173 | -9x | +267 | +10x |
- out[["default_stats"]] <- unlist(stats_in[!is_custom_fnc])+ checkmate::assert_list(control_annot_coxph) |
| 174 | -+ | |||
| 268 | +10x |
- } else {
+ checkmate::assert_numeric(legend_pos, finite = TRUE, any.missing = FALSE, len = 2, null.ok = TRUE) |
||
| 175 | -345x | +269 | +10x |
- out[["default_stats"]] <- stats_in+ assert_proportion_value(rel_height_plot) |
| 176 | -+ | |||
| 270 | +10x |
- }+ checkmate::assert_logical(as_list) |
||
| 177 | +271 | |||
| 178 | -354x | -
- out- |
- ||
| 179 | -+ | 272 | +10x |
- }+ tte <- variables$tte |
| 180 | -+ | |||
| 273 | +10x |
-
+ is_event <- variables$is_event |
||
| 181 | -+ | |||
| 274 | +10x |
- # Utility function to apply statistical functions+ arm <- variables$arm |
||
| 182 | -+ | |||
| 275 | +10x |
- .apply_stat_functions <- function(default_stat_fnc, custom_stat_fnc_list, args_list) {
+ assert_valid_factor(df[[arm]]) |
||
| 183 | -+ | |||
| 276 | +10x |
- # Default checks+ armval <- as.character(unique(df[[arm]])) |
||
| 184 | -354x | +277 | +10x |
- checkmate::assert_function(default_stat_fnc)+ assert_df_with_variables(df, list(tte = tte, is_event = is_event, arm = arm)) |
| 185 | -354x | +278 | +10x |
- checkmate::assert_list(custom_stat_fnc_list, types = "function", null.ok = TRUE, names = "named")+ checkmate::assert_logical(df[[is_event]], min.len = 1) |
| 186 | -354x | +279 | +10x |
- checkmate::assert_list(args_list)+ checkmate::assert_numeric(df[[tte]], min.len = 1) |
| 187 | -+ | |||
| 280 | +10x |
-
+ checkmate::assert_vector(col, len = length(armval), null.ok = TRUE) |
||
| 188 | -+ | |||
| 281 | +10x |
- # Checking custom stats have same formals+ checkmate::assert_vector(lty, null.ok = TRUE) |
||
| 189 | -354x | +282 | +10x |
- if (!is.null(custom_stat_fnc_list)) {
+ checkmate::assert_numeric(lwd, len = 1, null.ok = TRUE) |
| 190 | -9x | +|||
| 283 | +
- fundamental_call_to_data <- names(formals(default_stat_fnc))[[1]]+ |
|||
| 191 | -9x | +284 | +10x |
- for (fnc in custom_stat_fnc_list) {
+ if (annot_coxph && length(armval) < 2) {
|
| 192 | -11x | +|||
| 285 | +! |
- if (!identical(names(formals(fnc))[[1]], fundamental_call_to_data)) {
+ stop(paste( |
||
| 193 | -1x | +|||
| 286 | +! |
- stop(+ "When `annot_coxph` = TRUE, `df` must contain at least 2 levels of `variables$arm`", |
||
| 194 | -1x | +|||
| 287 | +! |
- "The first parameter of a custom statistical function needs to be the same (it can be `df` or `x`) ",+ "in order to calculate the hazard ratio." |
||
| 195 | -1x | +|||
| 288 | +
- "as the default statistical function. In this case your custom function has ", names(formals(fnc))[[1]],+ )) |
|||
| 196 | -1x | +|||
| 289 | +
- " as first parameter, while the default function has ", fundamental_call_to_data, "."+ } |
|||
| 197 | +290 |
- )+ |
||
| 198 | +291 |
- }+ # process model |
||
| 199 | +292 | 10x |
- if (!any(names(formals(fnc)) == "...")) {
+ yval <- match.arg(yval) |
|
| 200 | -1x | +293 | +10x |
- stop(+ formula <- stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", arm))
|
| 201 | -1x | +294 | +10x |
- "The custom statistical function needs to have `...` as a parameter to accept additional arguments. ",+ fit_km <- survival::survfit( |
| 202 | -1x | +295 | +10x |
- "In this case your custom function does not have `...`."+ formula = formula, |
| 203 | -+ | |||
| 296 | +10x |
- )+ data = df, |
||
| 204 | -+ | |||
| 297 | +10x |
- }+ conf.int = control_surv$conf_level, |
||
| 205 | -+ | |||
| 298 | +10x |
- }+ conf.type = control_surv$conf_type |
||
| 206 | +299 |
- }+ )+ |
+ ||
| 300 | +10x | +
+ data <- h_data_plot(fit_km, armval = armval, max_time = max_time) |
||
| 207 | +301 | |||
| 208 | +302 |
- # Merging+ # calculate x-ticks |
||
| 209 | -352x | +303 | +10x |
- stat_fnc_list <- c(default_stat_fnc, custom_stat_fnc_list)+ xticks <- h_xticks(data = data, xticks = xticks, max_time = max_time) |
| 210 | +304 | |||
| 211 | +305 |
- # Applying+ # change estimates of survival to estimates of failure (1 - survival) |
||
| 212 | -352x | +306 | +10x |
- out <- unlist(lapply(stat_fnc_list, function(fnc) do.call(fnc, args = args_list)), recursive = FALSE)+ if (yval == "Failure") {
|
| 213 | -+ | |||
| 307 | +! |
-
+ data[c("estimate", "conf.low", "conf.high", "censor")] <- list(
|
||
| 214 | -352x | +|||
| 308 | +! |
- out+ 1 - data$estimate, 1 - data$conf.low, 1 - data$conf.high, 1 - data$censor |
||
| 215 | +309 |
- }+ ) |
||
| 216 | +310 |
-
+ } |
||
| 217 | +311 |
- #' @describeIn default_stats_formats_labels Get formats corresponding to a list of statistics.+ |
||
| 218 | +312 |
- #' To check available defaults see `tern::tern_default_formats` list.+ # derive y-axis limits |
||
| 219 | -+ | |||
| 313 | +10x |
- #'+ if (is.null(ylim)) {
|
||
| 220 | -+ | |||
| 314 | +10x |
- #' @param formats_in (named `vector`)\cr inserted formats to replace defaults. It can be a+ if (!is.null(max_time)) {
|
||
| 221 | -+ | |||
| 315 | +1x |
- #' character vector from [formatters::list_valid_format_labels()] or a custom format function.+ y_lwr <- min(data[data$time < max_time, ][["estimate"]]) |
||
| 222 | -+ | |||
| 316 | +1x |
- #'+ y_upr <- max(data[data$time < max_time, ][["estimate"]]) |
||
| 223 | +317 |
- #' @return+ } else {
|
||
| 224 | -+ | |||
| 318 | +9x |
- #' * `get_formats_from_stats()` returns a named vector of formats (if present in either+ y_lwr <- min(data[["estimate"]]) |
||
| 225 | -+ | |||
| 319 | +9x |
- #' `tern_default_formats` or `formats_in`, otherwise `NULL`). Values can be taken from+ y_upr <- max(data[["estimate"]]) |
||
| 226 | +320 |
- #' [formatters::list_valid_format_labels()] or a custom function (e.g. [formatting_functions]).+ } |
||
| 227 | -+ | |||
| 321 | +10x |
- #'+ ylim <- c(y_lwr, y_upr) |
||
| 228 | +322 |
- #' @note Formats in `tern` and `rtables` can be functions that take in the table cell value and+ } |
||
| 229 | +323 |
- #' return a string. This is well documented in `vignette("custom_appearance", package = "rtables")`.
+
|
||
| 230 | +324 |
- #'+ # initialize ggplot |
||
| 231 | -+ | |||
| 325 | +10x |
- #' @examples+ gg_plt <- ggplot( |
||
| 232 | -+ | |||
| 326 | +10x |
- #' # Defaults formats+ data = data, |
||
| 233 | -+ | |||
| 327 | +10x |
- #' get_formats_from_stats(num_stats)+ mapping = aes( |
||
| 234 | -+ | |||
| 328 | +10x |
- #' get_formats_from_stats(cnt_stats)+ x = .data[["time"]], |
||
| 235 | -+ | |||
| 329 | +10x |
- #' get_formats_from_stats(only_pval)+ y = .data[["estimate"]], |
||
| 236 | -+ | |||
| 330 | +10x |
- #' get_formats_from_stats(all_cnt_occ)+ ymin = .data[["conf.low"]], |
||
| 237 | -+ | |||
| 331 | +10x |
- #'+ ymax = .data[["conf.high"]], |
||
| 238 | -+ | |||
| 332 | +10x |
- #' # Addition of customs+ color = .data[["strata"]], |
||
| 239 | -+ | |||
| 333 | +10x |
- #' get_formats_from_stats(all_cnt_occ, formats_in = c("fraction" = c("xx")))
+ fill = .data[["strata"]] |
||
| 240 | +334 |
- #' get_formats_from_stats(all_cnt_occ, formats_in = list("fraction" = c("xx.xx", "xx")))
+ ) |
||
| 241 | +335 |
- #'+ ) + |
||
| 242 | -+ | |||
| 336 | +10x |
- #' @seealso [formatting_functions]+ theme_bw(base_size = font_size) + |
||
| 243 | -+ | |||
| 337 | +10x |
- #'+ scale_y_continuous(limits = ylim, expand = c(0.025, 0)) + |
||
| 244 | -+ | |||
| 338 | +10x |
- #' @export+ labs(title = title, x = xlab, y = ylab, caption = footnotes) + |
||
| 245 | -+ | |||
| 339 | +10x |
- get_formats_from_stats <- function(stats, formats_in = NULL) {
+ theme( |
||
| 246 | -642x | +340 | +10x |
- checkmate::assert_character(stats, min.len = 1)+ axis.text = element_text(size = font_size), |
| 247 | -+ | |||
| 341 | +10x |
- # It may be a list if there is a function in the formats+ axis.title = element_text(size = font_size), |
||
| 248 | -642x | +342 | +10x |
- if (checkmate::test_list(formats_in, null.ok = TRUE)) {
+ legend.title = element_blank(), |
| 249 | -540x | +343 | +10x |
- checkmate::assert_list(formats_in, null.ok = TRUE)+ legend.text = element_text(size = font_size), |
| 250 | -+ | |||
| 344 | +10x |
- # Or it may be a vector of characters+ legend.box.background = element_rect(fill = "white", linewidth = 0.5), |
||
| 251 | -+ | |||
| 345 | +10x |
- } else {
+ legend.background = element_blank(), |
||
| 252 | -102x | +346 | +10x |
- checkmate::assert_character(formats_in, null.ok = TRUE)+ legend.position = "inside", |
| 253 | -+ | |||
| 347 | +10x |
- }+ legend.spacing.y = unit(-0.02, "npc"), |
||
| 254 | -+ | |||
| 348 | +10x |
-
+ panel.grid.major = element_blank(), |
||
| 255 | -+ | |||
| 349 | +10x |
- # Extract global defaults+ panel.grid.minor = element_blank() |
||
| 256 | -642x | +|||
| 350 | +
- which_fmt <- match(stats, names(tern_default_formats))+ ) |
|||
| 257 | +351 | |||
| 258 | +352 |
- # Select only needed formats from stats+ # derive x-axis limits |
||
| 259 | -642x | +353 | +10x |
- ret <- vector("list", length = length(stats)) # Returning a list is simpler
+ if (!is.null(max_time) && !is.null(xticks)) {
|
| 260 | -642x | +354 | +1x | +
+ gg_plt <- gg_plt + scale_x_continuous(+ |
+
| 355 | +1x |
- ret[!is.na(which_fmt)] <- tern_default_formats[which_fmt[!is.na(which_fmt)]]+ breaks = xticks, limits = c(min(0, xticks), max(c(xticks, max_time))), expand = c(0.025, 0) |
||
| 261 | +356 |
-
+ ) |
||
| 262 | -642x | +357 | +9x |
- out <- setNames(ret, stats)+ } else if (!is.null(xticks)) {
|
| 263 | -+ | |||
| 358 | +9x |
-
+ if (max(data$time) <= max(xticks)) {
|
||
| 264 | -+ | |||
| 359 | +9x |
- # Modify some with custom formats+ gg_plt <- gg_plt + scale_x_continuous( |
||
| 265 | -642x | +360 | +9x |
- if (!is.null(formats_in)) {
+ breaks = xticks, limits = c(min(0, min(xticks)), max(xticks)), expand = c(0.025, 0) |
| 266 | +361 |
- # Stats is the main+ ) |
||
| 267 | -195x | +|||
| 362 | +
- common_names <- intersect(names(out), names(formats_in))+ } else {
|
|||
| 268 | -195x | +|||
| 363 | +! |
- out[common_names] <- formats_in[common_names]+ gg_plt <- gg_plt + scale_x_continuous(breaks = xticks, expand = c(0.025, 0)) |
||
| 269 | +364 |
- }+ } |
||
| 270 | -+ | |||
| 365 | +! |
-
+ } else if (!is.null(max_time)) {
|
||
| 271 | -642x | +|||
| 366 | +! |
- out+ gg_plt <- gg_plt + scale_x_continuous(limits = c(0, max_time), expand = c(0.025, 0)) |
||
| 272 | +367 |
- }+ } |
||
| 273 | +368 | |||
| 274 | +369 |
- #' @describeIn default_stats_formats_labels Get labels corresponding to a list of statistics.+ # set legend position |
||
| 275 | -+ | |||
| 370 | +10x |
- #' To check for available defaults see `tern::tern_default_labels` list. If not available there,+ if (!is.null(legend_pos)) {
|
||
| 276 | -+ | |||
| 371 | +2x |
- #' the statistics name will be used as label.+ gg_plt <- gg_plt + theme(legend.position.inside = legend_pos) |
||
| 277 | +372 |
- #'+ } else {
|
||
| 278 | -+ | |||
| 373 | +8x |
- #' @param labels_in (named `character`)\cr inserted labels to replace defaults.+ max_time2 <- sort( |
||
| 279 | -+ | |||
| 374 | +8x |
- #' @param levels_per_stats (named `list` of `character` or `NULL`)\cr Levels of a `factor` or `character` variable, each+ data$time, |
||
| 280 | -+ | |||
| 375 | +8x |
- #' of which the statistics in `.stats` will be calculated for. If this parameter is set, these+ partial = nrow(data) - length(armval) - 1 |
||
| 281 | -+ | |||
| 376 | +8x |
- #' variable levels will be used as the defaults, and the names of the given custom values should+ )[nrow(data) - length(armval) - 1] |
||
| 282 | +377 |
- #' correspond to levels (or have format `statistic.level`) instead of statistics. Can also be+ |
||
| 283 | -+ | |||
| 378 | +8x |
- #' variable names if rows correspond to different variables instead of levels. Defaults to `NULL`.+ y_rng <- ylim[2] - ylim[1] |
||
| 284 | +379 |
- #' @param row_nms (`character`)\cr See `levels_per_stats`. Deprecation cycle started.+ |
||
| 285 | -+ | |||
| 380 | +8x |
- #'+ if (yval == "Survival" && all(data$estimate[data$time == max_time2] > ylim[1] + 0.09 * y_rng) && |
||
| 286 | -+ | |||
| 381 | +8x |
- #' @return+ all(data$estimate[data$time == max_time2] < ylim[1] + 0.5 * y_rng)) { # nolint
|
||
| 287 | -+ | |||
| 382 | +1x |
- #' * `get_labels_from_stats()` returns a named `character` vector of labels (if present in either+ gg_plt <- gg_plt + |
||
| 288 | -+ | |||
| 383 | +1x |
- #' `tern_default_labels` or `labels_in`, otherwise `NULL`).+ theme( |
||
| 289 | -+ | |||
| 384 | +1x |
- #'+ legend.position.inside = c(1, 0.5), |
||
| 290 | -+ | |||
| 385 | +1x |
- #' @examples+ legend.justification = c(1.1, 0.6) |
||
| 291 | +386 |
- #' # Defaults labels+ ) |
||
| 292 | +387 |
- #' get_labels_from_stats(num_stats)+ } else {
|
||
| 293 | -+ | |||
| 388 | +7x |
- #' get_labels_from_stats(cnt_stats)+ gg_plt <- gg_plt + |
||
| 294 | -+ | |||
| 389 | +7x |
- #' get_labels_from_stats(only_pval)+ theme( |
||
| 295 | -+ | |||
| 390 | +7x |
- #' get_labels_from_stats(all_cnt_occ)+ legend.position.inside = c(1, 0), |
||
| 296 | -+ | |||
| 391 | +7x |
- #'+ legend.justification = c(1.1, -0.4) |
||
| 297 | +392 |
- #' # Addition of customs+ ) |
||
| 298 | +393 |
- #' get_labels_from_stats(all_cnt_occ, labels_in = c("fraction" = "Fraction"))
+ } |
||
| 299 | +394 |
- #' get_labels_from_stats(all_cnt_occ, labels_in = list("fraction" = c("Some more fractions")))
+ } |
||
| 300 | +395 |
- #'+ |
||
| 301 | +396 |
- #' @export+ # add lines |
||
| 302 | -+ | |||
| 397 | +10x |
- get_labels_from_stats <- function(stats, labels_in = NULL, levels_per_stats = NULL) {
+ gg_plt <- if (is.null(lty)) {
|
||
| 303 | -619x | +398 | +9x |
- checkmate::assert_character(stats, min.len = 1)+ gg_plt + geom_step(linewidth = lwd, na.rm = TRUE) |
| 304 | -619x | +399 | +10x |
- checkmate::assert_list(levels_per_stats, null.ok = TRUE)+ } else if (length(lty) == 1) {
|
| 305 | -+ | |||
| 400 | +! |
- # It may be a list+ gg_plt + geom_step(linewidth = lwd, lty = lty, na.rm = TRUE) |
||
| 306 | -619x | +|||
| 401 | +
- if (checkmate::test_list(labels_in, null.ok = TRUE)) {
+ } else {
|
|||
| 307 | -491x | -
- checkmate::assert_list(labels_in, null.ok = TRUE)- |
- ||
| 308 | -+ | 402 | +1x |
- # Or it may be a vector of characters+ gg_plt + |
| 309 | -+ | |||
| 403 | +1x |
- } else {
+ geom_step(aes(lty = .data[["strata"]]), linewidth = lwd, na.rm = TRUE) + |
||
| 310 | -128x | +404 | +1x |
- checkmate::assert_character(labels_in, null.ok = TRUE)+ scale_linetype_manual(values = lty) |
| 311 | +405 |
} |
||
| 312 | +406 | |||
| 313 | +407 |
- # Default for stats with sublevels (for factors or chrs) are the labels+ # add censor marks |
||
| 314 | -619x | +408 | +10x |
- if (!is.null(levels_per_stats)) {
+ if (censor_show) {
|
| 315 | -407x | +409 | +10x |
- out <- .adjust_stats_desc_by_in_def(levels_per_stats, labels_in, tern_default_labels)+ gg_plt <- gg_plt + geom_point( |
| 316 | -+ | |||
| 410 | +10x |
- # numeric case, where there are not other levels (list of stats)+ data = data[data$n.censor != 0, ], |
||
| 317 | -+ | |||
| 411 | +10x |
- } else {
+ aes(x = .data[["time"]], y = .data[["censor"]], shape = "Censored"), |
||
| 318 | -212x | +412 | +10x | +
+ size = size,+ |
+
| 413 | +10x |
- which_lbl <- match(stats, names(tern_default_labels))+ na.rm = TRUE |
||
| 319 | +414 |
-
+ ) + |
||
| 320 | -212x | +415 | +10x |
- ret <- stats # The default+ scale_shape_manual(name = NULL, values = pch) + |
| 321 | -212x | +416 | +10x |
- ret[!is.na(which_lbl)] <- tern_default_labels[which_lbl[!is.na(which_lbl)]]+ guides(fill = guide_legend(override.aes = list(shape = NA))) |
| 322 | +417 | - - | -||
| 323 | -212x | -
- out <- setNames(ret, stats)+ } |
||
| 324 | +418 | |||
| 325 | +419 |
- # Modify some with custom labels+ # add ci ribbon |
||
| 326 | -212x | +420 | +1x |
- if (!is.null(labels_in)) {
+ if (ci_ribbon) gg_plt <- gg_plt + geom_ribbon(alpha = 0.3, lty = 0, na.rm = TRUE) |
| 327 | +421 |
- # Stats is the main+ |
||
| 328 | -119x | +|||
| 422 | +
- common_names <- intersect(names(out), names(labels_in))+ # control aesthetics |
|||
| 329 | -119x | -
- out[common_names] <- unlist(labels_in[common_names], recursive = FALSE)- |
- ||
| 330 | -+ | 423 | +10x |
- }+ if (!is.null(col)) {
|
| 331 | -+ | |||
| 424 | +1x |
- }+ gg_plt <- gg_plt + |
||
| 332 | -+ | |||
| 425 | +1x |
-
+ scale_color_manual(values = col) + |
||
| 333 | -619x | +426 | +1x |
- out+ scale_fill_manual(values = col) |
| 334 | +427 |
- }+ } |
||
| 335 | -+ | |||
| 428 | +! |
-
+ if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme |
||
| 336 | +429 |
- #' @describeIn default_stats_formats_labels Format indent modifiers for a given vector/list of statistics.+ |
||
| 337 | +430 |
- #' It defaults to 0L for all values.+ # annotate with stats (text/vlines) |
||
| 338 | -+ | |||
| 431 | +10x |
- #'+ if (!is.null(annot_stats)) {
|
||
| 339 | -+ | |||
| 432 | +! |
- #' @param indents_in (named `vector`)\cr inserted indent modifiers to replace defaults (default is `0L`).+ if ("median" %in% annot_stats) {
|
||
| 340 | -+ | |||
| 433 | +! |
- #'+ fit_km_all <- survival::survfit( |
||
| 341 | -+ | |||
| 434 | +! |
- #' @return+ formula = stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", 1)),
|
||
| 342 | -+ | |||
| 435 | +! |
- #' * `get_indents_from_stats()` returns a single indent modifier value to apply to all rows+ data = df, |
||
| 343 | -+ | |||
| 436 | +! |
- #' or a named numeric vector of indent modifiers (if present, otherwise `NULL`).+ conf.int = control_surv$conf_level, |
||
| 344 | -+ | |||
| 437 | +! |
- #'+ conf.type = control_surv$conf_type |
||
| 345 | +438 |
- #' @examples+ ) |
||
| 346 | -+ | |||
| 439 | +! |
- #' get_indents_from_stats(all_cnt_occ, indents_in = 3L)+ gg_plt <- gg_plt + |
||
| 347 | -+ | |||
| 440 | +! |
- #' get_indents_from_stats(all_cnt_occ, indents_in = list(count = 2L, count_fraction = 5L))+ annotate( |
||
| 348 | -+ | |||
| 441 | +! |
- #' get_indents_from_stats(+ "text", |
||
| 349 | -+ | |||
| 442 | +! |
- #' all_cnt_occ,+ size = font_size / .pt, col = 1, lineheight = 0.95, |
||
| 350 | -+ | |||
| 443 | +! |
- #' indents_in = list(a = 2L, count.a = 1L, count.b = 5L), row_nms = c("a", "b")
+ x = stats::median(fit_km_all) + 0.07 * max(data$time), |
||
| 351 | -+ | |||
| 444 | +! |
- #' )+ y = ifelse(yval == "Survival", 0.65, 0.35), |
||
| 352 | -+ | |||
| 445 | +! |
- #'+ label = paste("Median F/U:\n", round(stats::median(fit_km_all), 1), tolower(df$AVALU[1]))
|
||
| 353 | +446 |
- #' @export+ ) |
||
| 354 | -+ | |||
| 447 | +! |
- get_indents_from_stats <- function(stats, indents_in = NULL, row_nms = NULL) {
+ if (annot_stats_vlines) {
|
||
| 355 | -577x | +|||
| 448 | +! |
- checkmate::assert_character(stats, min.len = 1)+ gg_plt <- gg_plt + |
||
| 356 | -577x | +|||
| 449 | +! |
- checkmate::assert_character(row_nms, null.ok = TRUE)+ annotate( |
||
| 357 | -+ | |||
| 450 | +! |
- # It may be a list+ "segment", |
||
| 358 | -577x | +|||
| 451 | +! |
- if (checkmate::test_list(indents_in, null.ok = TRUE)) {
+ x = stats::median(fit_km_all), xend = stats::median(fit_km_all), y = -Inf, yend = Inf, |
||
| 359 | -525x | +|||
| 452 | +! |
- checkmate::assert_list(indents_in, null.ok = TRUE)+ linetype = 2, col = "darkgray" |
||
| 360 | +453 |
- # Or it may be a vector of integers+ ) |
||
| 361 | +454 |
- } else {
- |
- ||
| 362 | -52x | -
- checkmate::assert_integerish(indents_in, null.ok = TRUE)+ } |
||
| 363 | +455 |
- }+ } |
||
| 364 | -+ | |||
| 456 | +! |
-
+ if ("min" %in% annot_stats) {
|
||
| 365 | -577x | +|||
| 457 | +! |
- if (is.null(names(indents_in)) && length(indents_in) == 1) {
+ min_fu <- min(df[[tte]]) |
||
| 366 | -20x | +|||
| 458 | +! |
- out <- rep(indents_in, length(stats) * if (!is.null(row_nms)) length(row_nms) else 1)+ gg_plt <- gg_plt + |
||
| 367 | -20x | +|||
| 459 | +! |
- return(out)+ annotate( |
||
| 368 | -+ | |||
| 460 | +! |
- }+ "text", |
||
| 369 | -+ | |||
| 461 | +! |
-
+ size = font_size / .pt, col = 1, lineheight = 0.95, |
||
| 370 | -557x | +|||
| 462 | +! |
- if (!is.null(row_nms)) {
+ x = min_fu + max(data$time) * 0.07, |
||
| 371 | -152x | +|||
| 463 | +! |
- ret <- rep(0L, length(stats) * length(row_nms))+ y = ifelse(yval == "Survival", 0.96, 0.05), |
||
| 372 | -152x | +|||
| 464 | +! |
- out <- setNames(ret, paste(rep(stats, each = length(row_nms)), rep(row_nms, length(stats)), sep = "."))+ label = paste("Min. F/U:\n", round(min_fu, 1), tolower(df$AVALU[1]))
|
||
| 373 | +465 |
-
+ ) |
||
| 374 | -152x | +|||
| 466 | +! |
- if (!is.null(indents_in)) {
+ if (annot_stats_vlines) {
|
||
| 375 | -3x | +|||
| 467 | +! |
- lvl_lbls <- intersect(names(indents_in), row_nms)+ gg_plt <- gg_plt + |
||
| 376 | -3x | +|||
| 468 | +! | +
+ annotate(+ |
+ ||
| 469 | +! | +
+ "segment",+ |
+ ||
| 470 | +! | +
+ linetype = 2, col = "darkgray",+ |
+ ||
| 471 | +! |
- for (i in lvl_lbls) out[paste(stats, i, sep = ".")] <- indents_in[[i]]+ x = min_fu, xend = min_fu, y = Inf, yend = -Inf |
||
| 377 | +472 |
- }+ ) |
||
| 378 | +473 |
- } else {
+ } |
||
| 379 | -405x | +|||
| 474 | +
- ret <- rep(0L, length(stats))+ } |
|||
| 380 | -405x | +|||
| 475 | +! |
- out <- setNames(ret, stats)+ gg_plt <- gg_plt + guides(fill = guide_legend(override.aes = list(shape = NA, label = ""))) |
||
| 381 | +476 |
} |
||
| 382 | +477 | |||
| 383 | +478 |
- # Modify some with custom labels+ # add at risk annotation table |
||
| 384 | -557x | +479 | +10x |
- if (!is.null(indents_in)) {
+ if (annot_at_risk) {
|
| 385 | -+ | |||
| 480 | +9x |
- # Stats is the main+ annot_tbl <- summary(fit_km, times = xticks, extend = TRUE) |
||
| 386 | -36x | +481 | +9x |
- common_names <- intersect(names(out), names(indents_in))+ annot_tbl <- if (is.null(fit_km$strata)) {
|
| 387 | -36x | +|||
| 482 | +! |
- out[common_names] <- indents_in[common_names]+ data.frame( |
||
| 388 | -+ | |||
| 483 | +! |
- }+ n.risk = annot_tbl$n.risk, |
||
| 389 | -+ | |||
| 484 | +! |
-
+ time = annot_tbl$time, |
||
| 390 | -557x | +|||
| 485 | +! |
- out+ strata = armval |
||
| 391 | +486 |
- }+ ) |
||
| 392 | +487 |
-
+ } else {
|
||
| 393 | -+ | |||
| 488 | +9x |
- # Function to loop over each stat and levels to set correct values+ strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
|
||
| 394 | -+ | |||
| 489 | +9x |
- .adjust_stats_desc_by_in_def <- function(levels_per_stats, user_in, tern_defaults) {
+ levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2] |
||
| 395 | -407x | +490 | +9x |
- out <- levels_per_stats+ data.frame( |
| 396 | -+ | |||
| 491 | +9x |
-
+ n.risk = annot_tbl$n.risk, |
||
| 397 | -+ | |||
| 492 | +9x |
- # Seq over the stats levels (can be also flat (stat$NULL))+ time = annot_tbl$time, |
||
| 398 | -407x | +493 | +9x |
- for (stat_i in seq_along(levels_per_stats)) {
+ strata = annot_tbl$strata |
| 399 | +494 |
- # If you want to change all factor levels at once by statistic+ ) |
||
| 400 | -817x | +|||
| 495 | +
- common_stat_names <- intersect(names(levels_per_stats), names(user_in))+ } |
|||
| 401 | +496 | |||
| 402 | -+ | |||
| 497 | +9x |
- # Levels for each statistic+ at_risk_tbl <- as.data.frame(tidyr::pivot_wider(annot_tbl, names_from = "time", values_from = "n.risk")[, -1]) |
||
| 403 | -817x | +498 | +9x | +
+ at_risk_tbl[is.na(at_risk_tbl)] <- 0+ |
+
| 499 | +9x |
- nm_of_levs <- levels_per_stats[[stat_i]]+ rownames(at_risk_tbl) <- levels(annot_tbl$strata) |
||
| 404 | +500 |
- # Special case in which only stat$NULL+ |
||
| 405 | -817x | +501 | +9x |
- if (is.null(nm_of_levs)) {
+ gg_at_risk <- df2gg( |
| 406 | -17x | +502 | +9x |
- nm_of_levs <- "a single NULL level"+ at_risk_tbl, |
| 407 | -+ | |||
| 503 | +9x |
- }+ font_size = font_size, col_labels = FALSE, hline = FALSE, |
||
| 408 | -+ | |||
| 504 | +9x |
-
+ colwidths = rep(1, ncol(at_risk_tbl)) |
||
| 409 | +505 |
- # Loop over levels for each statistic+ ) + |
||
| 410 | -817x | -
- for (lev_i in seq_along(nm_of_levs)) {
- |
- ||
| 411 | -+ | 506 | +9x |
- # If there are no further names (stat$NULL) push label (stat) down to lowest level+ labs(title = if (annot_at_risk_title) "Patients at Risk:" else NULL, x = xlab) + |
| 412 | -4115x | +507 | +9x |
- if (is.null(levels_per_stats[[stat_i]])) {
+ theme_bw(base_size = font_size) + |
| 413 | -17x | +508 | +9x |
- lev_val <- names(levels_per_stats[stat_i])+ theme( |
| 414 | -17x | +509 | +9x |
- out[[stat_i]] <- lev_val+ plot.title = element_text(size = font_size, vjust = 3, face = "bold"), |
| 415 | -+ | |||
| 510 | +9x |
- } else {
+ panel.border = element_blank(), |
||
| 416 | -4098x | +511 | +9x |
- lev_val <- levels_per_stats[[stat_i]][[lev_i]]+ panel.grid = element_blank(), |
| 417 | -+ | |||
| 512 | +9x |
- }+ axis.title.y = element_blank(), |
||
| 418 | -+ | |||
| 513 | +9x |
-
+ axis.ticks.y = element_blank(), |
||
| 419 | -+ | |||
| 514 | +9x |
- # Add default if it is a stat at last level+ axis.text.y = element_text(size = font_size, face = "italic", hjust = 1), |
||
| 420 | -4115x | +515 | +9x |
- if (lev_val %in% names(tern_defaults)) {
+ axis.text.x = element_text(size = font_size), |
| 421 | -72x | +516 | +9x |
- out[[stat_i]][[lev_i]] <- tern_defaults[[lev_val]]+ axis.line.x = element_line() |
| 422 | +517 |
- }+ ) + |
||
| 423 | -+ | |||
| 518 | +9x |
-
+ coord_cartesian(clip = "off", ylim = c(0.5, nrow(at_risk_tbl))) |
||
| 424 | -+ | |||
| 519 | +9x |
- # If a general stat was added to the custom labels+ gg_at_risk <- suppressMessages( |
||
| 425 | -4115x | +520 | +9x |
- if (names(levels_per_stats[stat_i]) %in% names(user_in)) {
+ gg_at_risk + |
| 426 | +521 | 9x |
- out[[stat_i]][[lev_i]] <- user_in[[names(levels_per_stats[stat_i])]]+ scale_x_continuous(expand = c(0.025, 0), breaks = seq_along(at_risk_tbl) - 0.5, labels = xticks) + |
|
| 427 | -+ | |||
| 522 | +9x |
- }+ scale_y_continuous(labels = rev(levels(annot_tbl$strata)), breaks = seq_len(nrow(at_risk_tbl))) |
||
| 428 | +523 |
-
+ ) |
||
| 429 | +524 |
- # If a stat level (e.g. if it is counts levels from table) was added to the custom labels+ |
||
| 430 | -4115x | +525 | +9x |
- if (lev_val %in% names(user_in)) {
+ if (!as_list) {
|
| 431 | -32x | -
- out[[stat_i]][[lev_i]] <- user_in[[lev_val]]- |
- ||
| 432 | -+ | 526 | +8x |
- }+ gg_plt <- cowplot::plot_grid( |
| 433 | -+ | |||
| 527 | +8x |
-
+ gg_plt, |
||
| 434 | -+ | |||
| 528 | +8x |
- # If stat_i.lev_val is added to labels_in+ gg_at_risk, |
||
| 435 | -4115x | +529 | +8x |
- composite_stat_lev_nm <- paste(+ align = "v", |
| 436 | -4115x | +530 | +8x |
- names(levels_per_stats[stat_i]),+ axis = "tblr", |
| 437 | -4115x | +531 | +8x |
- lev_val,+ ncol = 1, |
| 438 | -4115x | +532 | +8x |
- sep = "."+ rel_heights = c(rel_height_plot, 1 - rel_height_plot) |
| 439 | +533 |
) |
||
| 440 | -4115x | -
- if (composite_stat_lev_nm %in% names(user_in)) {
- |
- ||
| 441 | -2x | +|||
| 534 | +
- out[[stat_i]][[lev_i]] <- user_in[[composite_stat_lev_nm]]+ } |
|||
| 442 | +535 |
- }+ } |
||
| 443 | +536 | |||
| 444 | +537 |
- # Used by the unlist (to avoid count_fraction1, count_fraction2, etc.)+ # add median survival time annotation table |
||
| 445 | -4115x | +538 | +10x |
- names(out[[stat_i]])[lev_i] <- lev_val+ if (annot_surv_med) {
|
| 446 | -+ | |||
| 539 | +8x |
- }+ surv_med_tbl <- h_tbl_median_surv(fit_km = fit_km, armval = armval) |
||
| 447 | -+ | |||
| 540 | +8x |
- }+ bg_fill <- if (isTRUE(control_annot_surv_med[["fill"]])) "#00000020" else control_annot_surv_med[["fill"]] |
||
| 448 | +541 | |||
| 449 | -407x | +542 | +8x |
- out+ gg_surv_med <- df2gg(surv_med_tbl, font_size = font_size, colwidths = c(1, 1, 2), bg_fill = bg_fill) + |
| 450 | -+ | |||
| 543 | +8x |
- }+ theme( |
||
| 451 | -+ | |||
| 544 | +8x |
-
+ axis.text.y = element_text(size = font_size, face = "italic", hjust = 1), |
||
| 452 | -+ | |||
| 545 | +8x |
- # Custom unlist function to retain NULL as "NULL" or NA+ plot.margin = margin(0, 2, 0, 5) |
||
| 453 | +546 |
- .unlist_keep_nulls <- function(lst, null_placeholder = "NULL", recursive = FALSE) {
+ ) + |
||
| 454 | -407x | +547 | +8x |
- lapply(lst, function(x) if (is.null(x)) null_placeholder else x) %>%+ coord_cartesian(clip = "off", ylim = c(0.5, nrow(surv_med_tbl) + 1.5)) |
| 455 | -407x | +548 | +8x |
- unlist(recursive = recursive)+ gg_surv_med <- suppressMessages( |
| 456 | -+ | |||
| 549 | +8x |
- }+ gg_surv_med + |
||
| 457 | -+ | |||
| 550 | +8x |
-
+ scale_x_continuous(expand = c(0.025, 0)) + |
||
| 458 | -+ | |||
| 551 | +8x |
-
+ scale_y_continuous(labels = rev(rownames(surv_med_tbl)), breaks = seq_len(nrow(surv_med_tbl))) |
||
| 459 | +552 |
- #' Update labels according to control specifications+ ) |
||
| 460 | +553 |
- #'+ |
||
| 461 | -+ | |||
| 554 | +8x |
- #' @description `r lifecycle::badge("stable")`
+ gg_plt <- cowplot::ggdraw(gg_plt) + |
||
| 462 | -+ | |||
| 555 | +8x |
- #'+ cowplot::draw_plot( |
||
| 463 | -+ | |||
| 556 | +8x |
- #' Given a list of statistic labels and and a list of control parameters, updates labels with a relevant+ gg_surv_med, |
||
| 464 | -+ | |||
| 557 | +8x |
- #' control specification. For example, if control has element `conf_level` set to `0.9`, the default+ control_annot_surv_med[["x"]], |
||
| 465 | -+ | |||
| 558 | +8x |
- #' label for statistic `mean_ci` will be updated to `"Mean 90% CI"`. Any labels that are supplied+ control_annot_surv_med[["y"]], |
||
| 466 | -+ | |||
| 559 | +8x |
- #' via `labels_custom` will not be updated regardless of `control`.+ width = control_annot_surv_med[["w"]], |
||
| 467 | -+ | |||
| 560 | +8x |
- #'+ height = control_annot_surv_med[["h"]], |
||
| 468 | -+ | |||
| 561 | +8x |
- #' @param labels_default (named `character`)\cr a named vector of statistic labels to modify+ vjust = 0.5, |
||
| 469 | -+ | |||
| 562 | +8x |
- #' according to the control specifications. Labels that are explicitly defined in `labels_custom` will+ hjust = 0.5 |
||
| 470 | +563 |
- #' not be affected.+ ) |
||
| 471 | +564 |
- #' @param labels_custom (named `character`)\cr named vector of labels that are customized by+ } |
||
| 472 | +565 |
- #' the user and should not be affected by `control`.+ |
||
| 473 | +566 |
- #' @param control (named `list`)\cr list of control parameters to apply to adjust default labels.+ # add coxph annotation table |
||
| 474 | -+ | |||
| 567 | +10x |
- #'+ if (annot_coxph) {
|
||
| 475 | -+ | |||
| 568 | +1x |
- #' @return A named character vector of labels with control specifications applied to relevant labels.+ coxph_tbl <- h_tbl_coxph_pairwise( |
||
| 476 | -+ | |||
| 569 | +1x |
- #'+ df = df, |
||
| 477 | -+ | |||
| 570 | +1x |
- #' @examples+ variables = variables, |
||
| 478 | -+ | |||
| 571 | +1x |
- #' control <- list(conf_level = 0.80, quantiles = c(0.1, 0.83), test_mean = 0.57)+ ref_group_coxph = ref_group_coxph, |
||
| 479 | -+ | |||
| 572 | +1x |
- #' get_labels_from_stats(c("mean_ci", "quantiles", "mean_pval")) %>%
+ control_coxph_pw = control_coxph_pw, |
||
| 480 | -+ | |||
| 573 | +1x |
- #' labels_use_control(control = control)+ annot_coxph_ref_lbls = control_annot_coxph[["ref_lbls"]] |
||
| 481 | +574 |
- #'+ ) |
||
| 482 | -+ | |||
| 575 | +1x |
- #' @export+ bg_fill <- if (isTRUE(control_annot_coxph[["fill"]])) "#00000020" else control_annot_coxph[["fill"]] |
||
| 483 | +576 |
- labels_use_control <- function(labels_default, control, labels_custom = NULL) {
+
|
||
| 484 | -21x | +577 | +1x |
- if ("conf_level" %in% names(control)) {
+ gg_coxph <- df2gg(coxph_tbl, font_size = font_size, colwidths = c(1.1, 1, 3), bg_fill = bg_fill) + |
| 485 | -21x | +578 | +1x |
- labels_default <- sapply(+ theme( |
| 486 | -21x | +579 | +1x |
- names(labels_default),+ axis.text.y = element_text(size = font_size, face = "italic", hjust = 1), |
| 487 | -21x | +580 | +1x |
- function(x) {
+ plot.margin = margin(0, 2, 0, 5) |
| 488 | -111x | +|||
| 581 | +
- if (!x %in% names(labels_custom)) {
+ ) + |
|||
| 489 | -107x | +582 | +1x |
- gsub(labels_default[[x]], pattern = "[0-9]+% CI", replacement = f_conf_level(control[["conf_level"]]))+ coord_cartesian(clip = "off", ylim = c(0.5, nrow(coxph_tbl) + 1.5)) |
| 490 | -+ | |||
| 583 | +1x |
- } else {
+ gg_coxph <- suppressMessages( |
||
| 491 | -4x | +584 | +1x |
- labels_default[[x]]+ gg_coxph + |
| 492 | -+ | |||
| 585 | +1x |
- }+ scale_x_continuous(expand = c(0.025, 0)) + |
||
| 493 | -+ | |||
| 586 | +1x |
- }+ scale_y_continuous(labels = rev(rownames(coxph_tbl)), breaks = seq_len(nrow(coxph_tbl))) |
||
| 494 | +587 |
) |
||
| 495 | +588 |
- }+ |
||
| 496 | -21x | +589 | +1x |
- if ("quantiles" %in% names(control) && "quantiles" %in% names(labels_default) &&
+ gg_plt <- cowplot::ggdraw(gg_plt) + |
| 497 | -21x | +590 | +1x |
- !"quantiles" %in% names(labels_custom)) { # nolint
+ cowplot::draw_plot( |
| 498 | -16x | +591 | +1x |
- labels_default["quantiles"] <- gsub(+ gg_coxph, |
| 499 | -16x | +592 | +1x |
- "[0-9]+% and [0-9]+", paste0(control[["quantiles"]][1] * 100, "% and ", control[["quantiles"]][2] * 100, ""),+ control_annot_coxph[["x"]], |
| 500 | -16x | -
- labels_default["quantiles"]- |
- ||
| 501 | -- |
- )- |
- ||
| 502 | -+ | 593 | +1x |
- }+ control_annot_coxph[["y"]], |
| 503 | -21x | +594 | +1x |
- if ("quantiles" %in% names(control) && "quantiles_lower" %in% names(labels_default) &&
+ width = control_annot_coxph[["w"]], |
| 504 | -21x | +595 | +1x |
- !"quantiles_lower" %in% names(labels_custom)) { # nolint
+ height = control_annot_coxph[["h"]], |
| 505 | -6x | +596 | +1x |
- labels_default["quantiles_lower"] <- gsub(+ vjust = 0.5, |
| 506 | -6x | +597 | +1x |
- "[0-9]+%-ile", paste0(control[["quantiles"]][1] * 100, "%-ile", ""),+ hjust = 0.5 |
| 507 | -6x | +|||
| 598 | +
- labels_default["quantiles_lower"]+ ) |
|||
| 508 | +599 |
- )+ } |
||
| 509 | +600 |
- }+ |
||
| 510 | -21x | +601 | +10x |
- if ("quantiles" %in% names(control) && "quantiles_upper" %in% names(labels_default) &&
+ if (as_list) {
|
| 511 | -21x | +602 | +1x |
- !"quantiles_upper" %in% names(labels_custom)) { # nolint
+ list(plot = gg_plt, table = gg_at_risk) |
| 512 | -6x | +|||
| 603 | +
- labels_default["quantiles_upper"] <- gsub(+ } else {
|
|||
| 513 | -6x | +604 | +9x |
- "[0-9]+%-ile", paste0(control[["quantiles"]][2] * 100, "%-ile", ""),+ gg_plt |
| 514 | -6x | +|||
| 605 | ++ |
+ }+ |
+ ||
| 606 | ++ |
+ }+ |
+
| 1 | +
- labels_default["quantiles_upper"]+ #' Analyze numeric variables in columns |
|||
| 515 | +2 |
- )+ #' |
||
| 516 | +3 |
- }+ #' @description `r lifecycle::badge("experimental")`
|
||
| 517 | -21x | +|||
| 4 | +
- if ("test_mean" %in% names(control) && "mean_pval" %in% names(labels_default) &&
+ #' |
|||
| 518 | -21x | +|||
| 5 | +
- !"mean_pval" %in% names(labels_custom)) { # nolint
+ #' The layout-creating function [analyze_vars_in_cols()] creates a layout element to generate a column-wise |
|||
| 519 | -2x | +|||
| 6 | +
- labels_default["mean_pval"] <- gsub(+ #' analysis table. |
|||
| 520 | -2x | +|||
| 7 | +
- "p-value \\(H0: mean = [0-9\\.]+\\)", f_pval(control[["test_mean"]]), labels_default["mean_pval"]+ #' |
|||
| 521 | +8 |
- )+ #' This function sets the analysis methods as column labels and is a wrapper for [rtables::analyze_colvars()]. |
||
| 522 | +9 |
- }+ #' It was designed principally for PK tables. |
||
| 523 | +10 |
-
+ #' |
||
| 524 | -21x | +|||
| 11 | +
- labels_default+ #' @inheritParams argument_convention |
|||
| 525 | +12 |
- }+ #' @inheritParams rtables::analyze_colvars |
||
| 526 | +13 |
-
+ #' @param imp_rule (`string` or `NULL`)\cr imputation rule setting. Defaults to `NULL` for no imputation rule. Can |
||
| 527 | +14 |
- # tern_default_stats -----------------------------------------------------------+ #' also be `"1/3"` to implement 1/3 imputation rule or `"1/2"` to implement 1/2 imputation rule. In order |
||
| 528 | +15 |
- #' @describeIn default_stats_formats_labels Named list of available statistics by method group for `tern`.+ #' to use an imputation rule, the `avalcat_var` argument must be specified. See [imputation_rule()] |
||
| 529 | +16 |
- #'+ #' for more details on imputation. |
||
| 530 | +17 |
- #' @format+ #' @param avalcat_var (`string`)\cr if `imp_rule` is not `NULL`, name of variable that indicates whether a |
||
| 531 | +18 |
- #' * `tern_default_stats` is a named list of available statistics, with each element+ #' row in the data corresponds to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of |
||
| 532 | +19 |
- #' named for their corresponding statistical method group.+ #' the above (defaults to `"AVALCAT1"`). Variable must be present in the data and should match the variable |
||
| 533 | +20 |
- #'+ #' used to calculate the `n_blq` statistic (if included in `.stats`). |
||
| 534 | +21 |
- #' @export+ #' @param cache (`flag`)\cr whether to store computed values in a temporary caching environment. This will |
||
| 535 | +22 |
- tern_default_stats <- list(+ #' speed up calculations in large tables, but should be set to `FALSE` if the same `rtable` layout is |
||
| 536 | +23 |
- abnormal = c("fraction"),
+ #' used for multiple tables with different data. Defaults to `FALSE`. |
||
| 537 | +24 |
- abnormal_by_baseline = c("fraction"),
+ #' @param row_labels (`character`)\cr as this function works in columns space, usually `.labels` |
||
| 538 | +25 |
- abnormal_by_marked = c("count_fraction", "count_fraction_fixed_dp"),
+ #' character vector applies on the column space. You can change the row labels by defining this |
||
| 539 | +26 |
- abnormal_by_worst_grade = c("count_fraction", "count_fraction_fixed_dp"),
+ #' parameter to a named character vector with names corresponding to the split values. It defaults |
||
| 540 | +27 |
- abnormal_by_worst_grade_worsen = c("fraction"),
+ #' to `NULL` and if it contains only one `string`, it will duplicate that as a row label. |
||
| 541 | +28 |
- analyze_patients_exposure_in_cols = c("n_patients", "sum_exposure"),
+ #' @param do_summarize_row_groups (`flag`)\cr defaults to `FALSE` and applies the analysis to the current |
||
| 542 | +29 |
- analyze_vars_counts = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "fraction", "n_blq"),
+ #' label rows. This is a wrapper of [rtables::summarize_row_groups()] and it can accept `labelstr` |
||
| 543 | +30 |
- analyze_vars_numeric = c(+ #' to define row labels. This behavior is not supported as we never need to overload row labels. |
||
| 544 | +31 |
- "n", "sum", "mean", "sd", "se", "mean_sd", "mean_se", "mean_ci", "mean_sei", "mean_sdi", "mean_pval",+ #' @param split_col_vars (`flag`)\cr defaults to `TRUE` and puts the analysis results onto the columns. |
||
| 545 | +32 |
- "median", "mad", "median_ci", "quantiles", "iqr", "range", "min", "max", "median_range", "cv",+ #' This option allows you to add multiple instances of this functions, also in a nested fashion, |
||
| 546 | +33 |
- "geom_mean", "geom_mean_ci", "geom_cv",+ #' without adding more splits. This split must happen only one time on a single layout. |
||
| 547 | +34 |
- "median_ci_3d",+ #' |
||
| 548 | +35 |
- "mean_ci_3d", "geom_mean_ci_3d"+ #' @return |
||
| 549 | +36 |
- ),+ #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()]. |
||
| 550 | +37 |
- count_cumulative = c("count_fraction", "count_fraction_fixed_dp"),
+ #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output |
||
| 551 | +38 |
- count_missed_doses = c("n", "count_fraction", "count_fraction_fixed_dp"),
+ #' in columns, and add it to the table layout. |
||
| 552 | +39 |
- count_occurrences = c("count", "count_fraction", "count_fraction_fixed_dp", "fraction"),
+ #' |
||
| 553 | +40 |
- count_occurrences_by_grade = c("count_fraction", "count_fraction_fixed_dp"),
+ #' @note |
||
| 554 | +41 |
- count_patients_with_event = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
+ #' * This is an experimental implementation of [rtables::summarize_row_groups()] and [rtables::analyze_colvars()] |
||
| 555 | +42 |
- count_patients_with_flags = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
+ #' that may be subjected to changes as `rtables` extends its support to more complex analysis pipelines in the |
||
| 556 | +43 |
- count_values = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
+ #' column space. We encourage users to read the examples carefully and file issues for different use cases. |
||
| 557 | +44 |
- coxph_pairwise = c("pvalue", "hr", "hr_ci", "n_tot", "n_tot_events"),
+ #' * In this function, `labelstr` behaves atypically. If `labelstr = NULL` (the default), row labels are assigned |
||
| 558 | +45 |
- estimate_incidence_rate = c("person_years", "n_events", "rate", "rate_ci", "n_unique", "n_rate"),
+ #' automatically as the split values if `do_summarize_row_groups = FALSE` (the default), and as the group label |
||
| 559 | +46 |
- estimate_multinomial_response = c("n_prop", "prop_ci"),
+ #' if `do_summarize_row_groups = TRUE`. |
||
| 560 | +47 |
- estimate_odds_ratio = c("or_ci", "n_tot"),
+ #' |
||
| 561 | +48 |
- estimate_proportion = c("n_prop", "prop_ci"),
+ #' @seealso [analyze_vars()], [rtables::analyze_colvars()]. |
||
| 562 | +49 |
- estimate_proportion_diff = c("diff", "diff_ci"),
+ #' |
||
| 563 | +50 |
- summarize_ancova = c("n", "lsmean", "lsmean_diff", "lsmean_diff_ci", "pval"),
+ #' @examples |
||
| 564 | +51 |
- summarize_coxreg = c("n", "hr", "ci", "pval", "pval_inter"),
+ #' library(dplyr) |
||
| 565 | +52 |
- summarize_glm_count = c("n", "rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
+ #' |
||
| 566 | +53 |
- summarize_num_patients = c("unique", "nonunique", "unique_count"),
+ #' # Data preparation |
||
| 567 | +54 |
- summarize_patients_events_in_cols = c("unique", "all"),
+ #' adpp <- tern_ex_adpp %>% h_pkparam_sort() |
||
| 568 | +55 |
- surv_time = c(+ #' |
||
| 569 | +56 |
- "median", "median_ci", "median_ci_3d", "quantiles",+ #' lyt <- basic_table() %>% |
||
| 570 | +57 |
- "quantiles_lower", "quantiles_upper", "range_censor", "range_event", "range"+ #' split_rows_by(var = "STRATA1", label_pos = "topleft") %>% |
||
| 571 | +58 |
- ),+ #' split_rows_by( |
||
| 572 | +59 |
- surv_timepoint = c(+ #' var = "SEX", |
||
| 573 | +60 |
- "pt_at_risk", "event_free_rate", "rate_se", "rate_ci", "rate_diff", "rate_diff_ci", "ztest_pval",+ #' label_pos = "topleft", |
||
| 574 | +61 |
- "event_free_rate_3d"+ #' child_labels = "hidden" |
||
| 575 | +62 |
- ),+ #' ) %>% # Removes duplicated labels |
||
| 576 | +63 |
- tabulate_rsp_biomarkers = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
+ #' analyze_vars_in_cols(vars = "AGE") |
||
| 577 | +64 |
- tabulate_rsp_subgroups = c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval"),
+ #' result <- build_table(lyt = lyt, df = adpp) |
||
| 578 | +65 |
- tabulate_survival_biomarkers = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
+ #' result |
||
| 579 | +66 |
- tabulate_survival_subgroups = c("n_tot_events", "n_events", "n_tot", "n", "median", "hr", "ci", "pval"),
+ #' |
||
| 580 | +67 |
- test_proportion_diff = c("pval")
+ #' # By selecting just some statistics and ad-hoc labels |
||
| 581 | +68 |
- )+ #' lyt <- basic_table() %>% |
||
| 582 | +69 |
-
+ #' split_rows_by(var = "ARM", label_pos = "topleft") %>% |
||
| 583 | +70 |
- # tern_default_formats ---------------------------------------------------------+ #' split_rows_by( |
||
| 584 | +71 |
- #' @describeIn default_stats_formats_labels Named vector of default formats for `tern`.+ #' var = "SEX", |
||
| 585 | +72 |
- #'+ #' label_pos = "topleft", |
||
| 586 | +73 |
- #' @format+ #' child_labels = "hidden", |
||
| 587 | +74 |
- #' * `tern_default_formats` is a named vector of available default formats, with each element+ #' split_fun = drop_split_levels |
||
| 588 | +75 |
- #' named for their corresponding statistic.+ #' ) %>% |
||
| 589 | +76 |
- #'+ #' analyze_vars_in_cols( |
||
| 590 | +77 |
- #' @export+ #' vars = "AGE", |
||
| 591 | +78 |
- tern_default_formats <- c(+ #' .stats = c("n", "cv", "geom_mean"),
|
||
| 592 | +79 |
- fraction = format_fraction_fixed_dp,+ #' .labels = c( |
||
| 593 | +80 |
- unique = format_count_fraction_fixed_dp,+ #' n = "aN", |
||
| 594 | +81 |
- nonunique = "xx",+ #' cv = "aCV", |
||
| 595 | +82 |
- unique_count = "xx",+ #' geom_mean = "aGeomMean" |
||
| 596 | +83 |
- n = "xx.",+ #' ) |
||
| 597 | +84 |
- count = "xx.",+ #' ) |
||
| 598 | +85 |
- count_fraction = format_count_fraction,+ #' result <- build_table(lyt = lyt, df = adpp) |
||
| 599 | +86 |
- count_fraction_fixed_dp = format_count_fraction_fixed_dp,+ #' result |
||
| 600 | +87 |
- n_blq = "xx.",+ #' |
||
| 601 | +88 |
- sum = "xx.x",+ #' # Changing row labels |
||
| 602 | +89 |
- mean = "xx.x",+ #' lyt <- basic_table() %>% |
||
| 603 | +90 |
- sd = "xx.x",+ #' analyze_vars_in_cols( |
||
| 604 | +91 |
- se = "xx.x",+ #' vars = "AGE", |
||
| 605 | +92 |
- mean_sd = "xx.x (xx.x)",+ #' row_labels = "some custom label" |
||
| 606 | +93 |
- mean_se = "xx.x (xx.x)",+ #' ) |
||
| 607 | +94 |
- mean_ci = "(xx.xx, xx.xx)",+ #' result <- build_table(lyt, df = adpp) |
||
| 608 | +95 |
- mean_sei = "(xx.xx, xx.xx)",+ #' result |
||
| 609 | +96 |
- mean_sdi = "(xx.xx, xx.xx)",+ #' |
||
| 610 | +97 |
- mean_pval = "x.xxxx | (<0.0001)",+ #' # Pharmacokinetic parameters |
||
| 611 | +98 |
- mean_ci_3d = "xx.xx (xx.xx - xx.xx)",+ #' lyt <- basic_table() %>% |
||
| 612 | +99 |
- median = "xx.x",+ #' split_rows_by( |
||
| 613 | +100 |
- mad = "xx.x",+ #' var = "TLG_DISPLAY", |
||
| 614 | +101 |
- median_ci = "(xx.xx, xx.xx)",+ #' split_label = "PK Parameter", |
||
| 615 | +102 |
- median_ci_3d = "xx.xx (xx.xx - xx.xx)",+ #' label_pos = "topleft", |
||
| 616 | +103 |
- quantiles = "xx.x - xx.x",+ #' child_labels = "hidden" |
||
| 617 | +104 |
- quantiles_lower = "xx.xx (xx.xx - xx.xx)",+ #' ) %>% |
||
| 618 | +105 |
- quantiles_upper = "xx.xx (xx.xx - xx.xx)",+ #' analyze_vars_in_cols( |
||
| 619 | +106 |
- iqr = "xx.x",+ #' vars = "AVAL" |
||
| 620 | +107 |
- range = "xx.x - xx.x",+ #' ) |
||
| 621 | +108 |
- min = "xx.x",+ #' result <- build_table(lyt, df = adpp) |
||
| 622 | +109 |
- max = "xx.x",+ #' result |
||
| 623 | +110 |
- median_range = "xx.x (xx.x - xx.x)",+ #' |
||
| 624 | +111 |
- cv = "xx.x",+ #' # Multiple calls (summarize label and analyze underneath) |
||
| 625 | +112 |
- geom_mean = "xx.x",+ #' lyt <- basic_table() %>% |
||
| 626 | +113 |
- geom_mean_ci = "(xx.xx, xx.xx)",+ #' split_rows_by( |
||
| 627 | +114 |
- geom_mean_ci_3d = "xx.xx (xx.xx - xx.xx)",+ #' var = "TLG_DISPLAY", |
||
| 628 | +115 |
- geom_cv = "xx.x",+ #' split_label = "PK Parameter", |
||
| 629 | +116 |
- pval = "x.xxxx | (<0.0001)",+ #' label_pos = "topleft" |
||
| 630 | +117 |
- pval_counts = "x.xxxx | (<0.0001)",+ #' ) %>% |
||
| 631 | +118 |
- range_censor = "xx.x to xx.x",+ #' analyze_vars_in_cols( |
||
| 632 | +119 |
- range_event = "xx.x to xx.x",+ #' vars = "AVAL", |
||
| 633 | +120 |
- rate = "xx.xxxx",+ #' do_summarize_row_groups = TRUE # does a summarize level |
||
| 634 | +121 |
- rate_ci = "(xx.xxxx, xx.xxxx)",+ #' ) %>% |
||
| 635 | +122 |
- rate_ratio = "xx.xxxx",+ #' split_rows_by("SEX",
|
||
| 636 | +123 |
- rate_ratio_ci = "(xx.xxxx, xx.xxxx)"+ #' child_labels = "hidden", |
||
| 637 | +124 |
- )+ #' label_pos = "topleft" |
||
| 638 | +125 |
-
+ #' ) %>% |
||
| 639 | +126 |
- # tern_default_labels ----------------------------------------------------------+ #' analyze_vars_in_cols( |
||
| 640 | +127 |
- #' @describeIn default_stats_formats_labels Named `character` vector of default labels for `tern`.+ #' vars = "AVAL", |
||
| 641 | +128 |
- #'+ #' split_col_vars = FALSE # avoids re-splitting the columns |
||
| 642 | +129 |
- #' @format+ #' ) |
||
| 643 | +130 |
- #' * `tern_default_labels` is a named `character` vector of available default labels, with each element+ #' result <- build_table(lyt, df = adpp) |
||
| 644 | +131 |
- #' named for their corresponding statistic.+ #' result |
||
| 645 | +132 |
#' |
||
| 646 | +133 |
#' @export |
||
| 647 | +134 |
- tern_default_labels <- c(+ analyze_vars_in_cols <- function(lyt, |
||
| 648 | +135 |
- fraction = "fraction",+ vars, |
||
| 649 | +136 |
- unique = "Number of patients with at least one event",+ ..., |
||
| 650 | +137 |
- nonunique = "Number of events",+ .stats = c( |
||
| 651 | +138 |
- n = "n",+ "n", |
||
| 652 | +139 |
- count = "count",+ "mean", |
||
| 653 | +140 |
- count_fraction = "count_fraction",+ "sd", |
||
| 654 | +141 |
- count_fraction_fixed_dp = "count_fraction_fixed_dp",+ "se", |
||
| 655 | +142 |
- n_blq = "n_blq",+ "cv", |
||
| 656 | +143 |
- sum = "Sum",+ "geom_cv" |
||
| 657 | +144 |
- mean = "Mean",+ ), |
||
| 658 | +145 |
- sd = "SD",+ .labels = c( |
||
| 659 | +146 |
- se = "SE",+ n = "n", |
||
| 660 | +147 |
- mean_sd = "Mean (SD)",+ mean = "Mean", |
||
| 661 | +148 |
- mean_se = "Mean (SE)",+ sd = "SD", |
||
| 662 | +149 |
- mean_ci = "Mean 95% CI",+ se = "SE", |
||
| 663 | +150 |
- mean_sei = "Mean -/+ 1xSE",+ cv = "CV (%)", |
||
| 664 | +151 |
- mean_sdi = "Mean -/+ 1xSD",+ geom_cv = "CV % Geometric Mean" |
||
| 665 | +152 |
- mean_pval = "Mean p-value (H0: mean = 0)",+ ), |
||
| 666 | +153 |
- mean_ci_3d = "Mean (95% CI)",+ row_labels = NULL, |
||
| 667 | +154 |
- median = "Median",+ do_summarize_row_groups = FALSE, |
||
| 668 | +155 |
- mad = "Median Absolute Deviation",+ split_col_vars = TRUE, |
||
| 669 | +156 |
- median_ci = "Median 95% CI",+ imp_rule = NULL, |
||
| 670 | +157 |
- median_ci_3d = "Median (95% CI)",+ avalcat_var = "AVALCAT1", |
||
| 671 | +158 |
- quantiles = "25% and 75%-ile",+ cache = FALSE, |
||
| 672 | +159 |
- quantiles_lower = "25%-ile (95% CI)",+ .indent_mods = NULL, |
||
| 673 | +160 |
- quantiles_upper = "75%-ile (95% CI)",+ na_str = default_na_str(), |
||
| 674 | +161 |
- iqr = "IQR",+ nested = TRUE, |
||
| 675 | +162 |
- range = "Min - Max",+ .formats = NULL, |
||
| 676 | +163 |
- min = "Minimum",+ .aligns = NULL) {
|
||
| 677 | -+ | |||
| 164 | +26x |
- max = "Maximum",+ extra_args <- list(...) |
||
| 678 | +165 |
- median_range = "Median (Min - Max)",+ |
||
| 679 | -+ | |||
| 166 | +26x |
- cv = "CV (%)",+ checkmate::assert_string(na_str, na.ok = TRUE, null.ok = TRUE) |
||
| 680 | -+ | |||
| 167 | +26x |
- geom_mean = "Geometric Mean",+ checkmate::assert_character(row_labels, null.ok = TRUE) |
||
| 681 | -+ | |||
| 168 | +26x |
- geom_mean_ci = "Geometric Mean 95% CI",+ checkmate::assert_int(.indent_mods, null.ok = TRUE) |
||
| 682 | -+ | |||
| 169 | +26x |
- geom_mean_ci_3d = "Geometric Mean (95% CI)",+ checkmate::assert_flag(nested) |
||
| 683 | -+ | |||
| 170 | +26x |
- geom_cv = "CV % Geometric Mean",+ checkmate::assert_flag(split_col_vars) |
||
| 684 | -+ | |||
| 171 | +26x |
- pval = "p-value (t-test)", # Default for numeric+ checkmate::assert_flag(do_summarize_row_groups) |
||
| 685 | +172 |
- pval_counts = "p-value (chi-squared test)", # Default for counts+ |
||
| 686 | +173 |
- rate = "Adjusted Rate",+ # Filtering |
||
| 687 | -+ | |||
| 174 | +26x |
- rate_ratio = "Adjusted Rate Ratio"+ met_grps <- paste0("analyze_vars", c("_numeric", "_counts"))
|
||
| 688 | -+ | |||
| 175 | +26x |
- )+ .stats <- get_stats(met_grps, stats_in = .stats)+ |
+ ||
| 176 | +26x | +
+ formats_v <- get_formats_from_stats(stats = .stats, formats_in = .formats)+ |
+ ||
| 177 | +26x | +
+ labels_v <- get_labels_from_stats(stats = .stats, labels_in = .labels) %>% .unlist_keep_nulls()+ |
+ ||
| 178 | +! | +
+ if ("control" %in% names(extra_args)) labels_v <- labels_v %>% labels_use_control(extra_args[["control"]], .labels)
|
||
| 689 | +179 | |||
| 690 | +180 |
- #' @describeIn default_stats_formats_labels `r lifecycle::badge("stable")`
+ # Check for vars in the case that one or more are used |
||
| 691 | -+ | |||
| 181 | +26x |
- #' Quick function to retrieve default formats for summary statistics:+ if (length(vars) == 1) {
|
||
| 692 | -+ | |||
| 182 | +21x |
- #' [analyze_vars()] and [analyze_vars_in_cols()] principally.+ vars <- rep(vars, length(.stats)) |
||
| 693 | -+ | |||
| 183 | +5x |
- #'+ } else if (length(vars) != length(.stats)) {
|
||
| 694 | -+ | |||
| 184 | +1x |
- #' @param type (`string`)\cr `"numeric"` or `"counts"`.+ stop( |
||
| 695 | -+ | |||
| 185 | +1x |
- #'+ "Analyzed variables (vars) does not have the same ", |
||
| 696 | -+ | |||
| 186 | +1x |
- #' @return+ "number of elements of specified statistics (.stats)." |
||
| 697 | +187 |
- #' * `summary_formats()` returns a named `vector` of default statistic formats for the given data type.+ ) |
||
| 698 | +188 |
- #'+ } |
||
| 699 | +189 |
- #' @examples+ |
||
| 700 | -+ | |||
| 190 | +25x |
- #' summary_formats()+ if (split_col_vars) {
|
||
| 701 | +191 |
- #' summary_formats(type = "counts", include_pval = TRUE)+ # Checking there is not a previous identical column split+ |
+ ||
| 192 | +21x | +
+ clyt <- tail(clayout(lyt), 1)[[1]] |
||
| 702 | +193 |
- #'+ + |
+ ||
| 194 | +21x | +
+ dummy_lyt <- split_cols_by_multivar(+ |
+ ||
| 195 | +21x | +
+ lyt = basic_table(),+ |
+ ||
| 196 | +21x | +
+ vars = vars,+ |
+ ||
| 197 | +21x | +
+ varlabels = labels_v |
||
| 703 | +198 |
- #' @export+ ) |
||
| 704 | +199 |
- summary_formats <- function(type = "numeric", include_pval = FALSE) {
+
|
||
| 705 | +200 | +21x | +
+ if (any(sapply(clyt, identical, y = get_last_col_split(dummy_lyt)))) {
+ |
+ |
| 201 | 2x |
- met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ stop( |
||
| 706 | +202 | 2x |
- get_formats_from_stats(get_stats(met_grp, add_pval = include_pval))+ "Column split called again with the same values. ", |
|
| 707 | -+ | |||
| 203 | +2x |
- }+ "This can create many unwanted columns. Please consider adding ", |
||
| 708 | -+ | |||
| 204 | +2x |
-
+ "split_col_vars = FALSE to the last call of ", |
||
| 709 | -+ | |||
| 205 | +2x |
- #' @describeIn default_stats_formats_labels `r lifecycle::badge("stable")`
+ deparse(sys.calls()[[sys.nframe() - 1]]), "." |
||
| 710 | +206 |
- #' Quick function to retrieve default labels for summary statistics.+ ) |
||
| 711 | +207 |
- #' Returns labels of descriptive statistics which are understood by `rtables`. Similar to `summary_formats`.+ } |
||
| 712 | +208 |
- #'+ |
||
| 713 | +209 |
- #' @param include_pval (`flag`)\cr same as the `add_pval` argument in [get_stats()].+ # Main col split |
||
| 714 | -+ | |||
| 210 | +19x |
- #'+ lyt <- split_cols_by_multivar( |
||
| 715 | -+ | |||
| 211 | +19x |
- #' @details+ lyt = lyt, |
||
| 716 | -+ | |||
| 212 | +19x |
- #' `summary_*` quick get functions for labels or formats uses `get_stats` and `get_labels_from_stats` or+ vars = vars,+ |
+ ||
| 213 | +19x | +
+ varlabels = labels_v |
||
| 717 | +214 |
- #' `get_formats_from_stats` respectively to retrieve relevant information.+ ) |
||
| 718 | +215 |
- #'+ } |
||
| 719 | +216 |
- #' @return+ + |
+ ||
| 217 | +23x | +
+ env <- new.env() # create caching environment |
||
| 720 | +218 |
- #' * `summary_labels` returns a named `vector` of default statistic labels for the given data type.+ + |
+ ||
| 219 | +23x | +
+ if (do_summarize_row_groups) {
+ |
+ ||
| 220 | +8x | +
+ if (length(unique(vars)) > 1) {
+ |
+ ||
| 221 | +! | +
+ stop("When using do_summarize_row_groups only one label level var should be inserted.")
|
||
| 721 | +222 |
- #'+ } |
||
| 722 | +223 |
- #' @examples+ |
||
| 723 | +224 |
- #' summary_labels()+ # Function list for do_summarize_row_groups. Slightly different handling of labels |
||
| 724 | -+ | |||
| 225 | +8x |
- #' summary_labels(type = "counts", include_pval = TRUE)+ cfun_list <- Map( |
||
| 725 | -+ | |||
| 226 | +8x |
- #'+ function(stat, use_cache, cache_env) {
|
||
| 726 | -+ | |||
| 227 | +48x |
- #' @export+ function(u, .spl_context, labelstr, .df_row, ...) {
|
||
| 727 | +228 |
- summary_labels <- function(type = "numeric", include_pval = FALSE) {
+ # Statistic |
||
| 728 | -2x | +229 | +152x |
- met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ var_row_val <- paste( |
| 729 | -2x | +230 | +152x |
- get_labels_from_stats(get_stats(met_grp, add_pval = include_pval))+ gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
|
| 730 | -+ | |||
| 231 | +152x |
- }+ paste(.spl_context$value, collapse = "_"), |
| 1 | -+ | ||
| 232 | +152x |
- #' Kaplan-Meier plot+ sep = "_" |
|
| 2 | +233 |
- #'+ ) |
|
| 3 | -+ | ||
| 234 | +152x |
- #' @description `r lifecycle::badge("stable")`
+ if (use_cache) {
|
|
| 4 | -+ | ||
| 235 | +! |
- #'+ if (is.null(cache_env[[var_row_val]])) {
|
|
| 5 | -+ | ||
| 236 | +! |
- #' From a survival model, a graphic is rendered along with tabulated annotation+ cache_env[[var_row_val]] <- s_summary(u, ...) |
|
| 6 | +237 |
- #' including the number of patient at risk at given time and the median survival+ } |
|
| 7 | -+ | ||
| 238 | +! |
- #' per group.+ x_stats <- cache_env[[var_row_val]] |
|
| 8 | +239 |
- #'+ } else {
|
|
| 9 | -+ | ||
| 240 | +152x |
- #' @inheritParams argument_convention+ x_stats <- s_summary(u, ...) |
|
| 10 | +241 |
- #' @param variables (named `list`)\cr variable names. Details are:+ } |
|
| 11 | +242 |
- #' * `tte` (`numeric`)\cr variable indicating time-to-event duration values.+ |
|
| 12 | -+ | ||
| 243 | +152x |
- #' * `is_event` (`logical`)\cr event variable. `TRUE` if event, `FALSE` if time to event is censored.+ if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
|
|
| 13 | -+ | ||
| 244 | +152x |
- #' * `arm` (`factor`)\cr the treatment group variable.+ res <- x_stats[[stat]] |
|
| 14 | +245 |
- #' * `strata` (`character` or `NULL`)\cr variable names indicating stratification factors.+ } else {
|
|
| 15 | -+ | ||
| 246 | +! |
- #' @param control_surv (`list`)\cr parameters for comparison details, specified by using+ timept <- as.numeric(gsub(".*?([0-9\\.]+).*", "\\1", tail(.spl_context$value, 1)))
|
|
| 16 | -+ | ||
| 247 | +! |
- #' the helper function [control_surv_timepoint()]. Some possible parameter options are:+ res_imp <- imputation_rule( |
|
| 17 | -+ | ||
| 248 | +! |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate.+ .df_row, x_stats, stat, |
|
| 18 | -+ | ||
| 249 | +! |
- #' * `conf_type` (`string`)\cr `"plain"` (default), `"log"`, `"log-log"` for confidence interval type,+ imp_rule = imp_rule, |
|
| 19 | -+ | ||
| 250 | +! |
- #' see more in [survival::survfit()]. Note that the option "none" is no longer supported.+ post = grepl("Predose", tail(.spl_context$value, 1)) || timept > 0,
|
|
| 20 | -+ | ||
| 251 | +! |
- #' @param col (`character`)\cr lines colors. Length of a vector should be equal+ avalcat_var = avalcat_var |
|
| 21 | +252 |
- #' to number of strata from [survival::survfit()].+ ) |
|
| 22 | -+ | ||
| 253 | +! |
- #' @param lty (`numeric`)\cr line type. If a vector is given, its length should be equal to the number of strata from+ res <- res_imp[["val"]] |
|
| 23 | -+ | ||
| 254 | +! |
- #' [survival::survfit()].+ na_str <- res_imp[["na_str"]] |
|
| 24 | +255 |
- #' @param lwd (`numeric`)\cr line width. If a vector is given, its length should be equal to the number of strata from+ } |
|
| 25 | +256 |
- #' [survival::survfit()].+ |
|
| 26 | +257 |
- #' @param censor_show (`flag`)\cr whether to show censored observations.+ # Label check and replacement |
|
| 27 | -+ | ||
| 258 | +152x |
- #' @param pch (`string`)\cr name of symbol or character to use as point symbol to indicate censored cases.+ if (length(row_labels) > 1) {
|
|
| 28 | -+ | ||
| 259 | +32x |
- #' @param size (`numeric(1)`)\cr size of censored point symbols.+ if (!(labelstr %in% names(row_labels))) {
|
|
| 29 | -+ | ||
| 260 | +2x |
- #' @param max_time (`numeric(1)`)\cr maximum value to show on x-axis. Only data values less than or up to+ stop( |
|
| 30 | -+ | ||
| 261 | +2x |
- #' this threshold value will be plotted (defaults to `NULL`).+ "Replacing the labels in do_summarize_row_groups needs a named vector", |
|
| 31 | -+ | ||
| 262 | +2x |
- #' @param xticks (`numeric` or `NULL`)\cr numeric vector of tick positions or a single number with spacing+ "that contains the split values. In the current split variable ", |
|
| 32 | -+ | ||
| 263 | +2x |
- #' between ticks on the x-axis. If `NULL` (default), [labeling::extended()] is used to determine+ .spl_context$split[nrow(.spl_context)], |
|
| 33 | -+ | ||
| 264 | +2x |
- #' optimal tick positions on the x-axis.+ " the labelstr value (split value by default) ", labelstr, " is not in", |
|
| 34 | -+ | ||
| 265 | +2x |
- #' @param xlab (`string`)\cr x-axis label.+ " row_labels names: ", names(row_labels) |
|
| 35 | +266 |
- #' @param yval (`string`)\cr type of plot, to be plotted on the y-axis. Options are `Survival` (default) and `Failure`+ ) |
|
| 36 | +267 |
- #' probability.+ } |
|
| 37 | -+ | ||
| 268 | +30x |
- #' @param ylab (`string`)\cr y-axis label.+ lbl <- unlist(row_labels[labelstr]) |
|
| 38 | +269 |
- #' @param title (`string`)\cr plot title.+ } else {
|
|
| 39 | -+ | ||
| 270 | +120x |
- #' @param footnotes (`string`)\cr plot footnotes.+ lbl <- labelstr |
|
| 40 | +271 |
- #' @param font_size (`numeric(1)`)\cr font size to use for all text.+ } |
|
| 41 | +272 |
- #' @param ci_ribbon (`flag`)\cr whether the confidence interval should be drawn around the Kaplan-Meier curve.+ |
|
| 42 | +273 |
- #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of patient at risk+ # Cell creation |
|
| 43 | -+ | ||
| 274 | +150x |
- #' matching the main grid of the Kaplan-Meier curve.+ rcell(res, |
|
| 44 | -+ | ||
| 275 | +150x |
- #' @param annot_at_risk_title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk`+ label = lbl, |
|
| 45 | -+ | ||
| 276 | +150x |
- #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`.+ format = formats_v[names(formats_v) == stat][[1]], |
|
| 46 | -+ | ||
| 277 | +150x |
- #' @param annot_surv_med (`flag`)\cr compute and add the annotation table on the Kaplan-Meier curve estimating the+ format_na_str = na_str, |
|
| 47 | -+ | ||
| 278 | +150x |
- #' median survival time per group.+ indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods), |
|
| 48 | -+ | ||
| 279 | +150x |
- #' @param annot_coxph (`flag`)\cr whether to add the annotation table from a [survival::coxph()] model.+ align = .aligns |
|
| 49 | +280 |
- #' @param annot_stats (`string` or `NULL`)\cr statistics annotations to add to the plot. Options are+ ) |
|
| 50 | +281 |
- #' `median` (median survival follow-up time) and `min` (minimum survival follow-up time).+ } |
|
| 51 | +282 |
- #' @param annot_stats_vlines (`flag`)\cr add vertical lines corresponding to each of the statistics+ }, |
|
| 52 | -+ | ||
| 283 | +8x |
- #' specified by `annot_stats`. If `annot_stats` is `NULL` no lines will be added.+ stat = .stats, |
|
| 53 | -+ | ||
| 284 | +8x |
- #' @param control_coxph_pw (`list`)\cr parameters for comparison details, specified using the helper function+ use_cache = cache, |
|
| 54 | -+ | ||
| 285 | +8x |
- #' [control_coxph()]. Some possible parameter options are:+ cache_env = replicate(length(.stats), env) |
|
| 55 | +286 |
- #' * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1.+ ) |
|
| 56 | +287 |
- #' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`.+ |
|
| 57 | +288 |
- #' * `ties` (`string`)\cr method for tie handling. Default is `"efron"`,+ # Main call to rtables |
|
| 58 | -+ | ||
| 289 | +8x |
- #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()]+ summarize_row_groups( |
|
| 59 | -+ | ||
| 290 | +8x |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR.+ lyt = lyt, |
|
| 60 | -+ | ||
| 291 | +8x |
- #' @param ref_group_coxph (`string` or `NULL`)\cr level of arm variable to use as reference group in calculations for+ var = unique(vars), |
|
| 61 | -+ | ||
| 292 | +8x |
- #' `annot_coxph` table. If `NULL` (default), uses the first level of the arm variable.+ cfun = cfun_list, |
|
| 62 | -+ | ||
| 293 | +8x |
- #' @param control_annot_surv_med (`list`)\cr parameters to control the position and size of the annotation table added+ na_str = na_str, |
|
| 63 | -+ | ||
| 294 | +8x |
- #' to the plot when `annot_surv_med = TRUE`, specified using the [control_surv_med_annot()] function. Parameter+ extra_args = extra_args |
|
| 64 | +295 |
- #' options are: `x`, `y`, `w`, `h`, and `fill`. See [control_surv_med_annot()] for details.+ ) |
|
| 65 | +296 |
- #' @param control_annot_coxph (`list`)\cr parameters to control the position and size of the annotation table added+ } else {
|
|
| 66 | +297 |
- #' to the plot when `annot_coxph = TRUE`, specified using the [control_coxph_annot()] function. Parameter+ # Function list for analyze_colvars |
|
| 67 | -+ | ||
| 298 | +15x |
- #' options are: `x`, `y`, `w`, `h`, `fill`, and `ref_lbls`. See [control_coxph_annot()] for details.+ afun_list <- Map( |
|
| 68 | -+ | ||
| 299 | +15x |
- #' @param legend_pos (`numeric(2)` or `NULL`)\cr vector containing x- and y-coordinates, respectively, for the legend+ function(stat, use_cache, cache_env) {
|
|
| 69 | -+ | ||
| 300 | +76x |
- #' position relative to the KM plot area. If `NULL` (default), the legend is positioned in the bottom right corner of+ function(u, .spl_context, .df_row, ...) {
|
|
| 70 | +301 |
- #' the plot, or the middle right of the plot if needed to prevent overlapping.+ # Main statistics |
|
| 71 | -+ | ||
| 302 | +468x |
- #' @param rel_height_plot (`proportion`)\cr proportion of total figure height to allocate to the Kaplan-Meier plot.+ var_row_val <- paste( |
|
| 72 | -+ | ||
| 303 | +468x |
- #' Relative height of patients at risk table is then `1 - rel_height_plot`. If `annot_at_risk = FALSE` or+ gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
|
|
| 73 | -+ | ||
| 304 | +468x |
- #' `as_list = TRUE`, this parameter is ignored.+ paste(.spl_context$value, collapse = "_"), |
|
| 74 | -+ | ||
| 305 | +468x |
- #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to format the Kaplan-Meier plot.+ sep = "_" |
|
| 75 | +306 |
- #' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list when `annot_at_risk = TRUE`.+ ) |
|
| 76 | -+ | ||
| 307 | +468x |
- #' If `TRUE`, a named list with two elements, `plot` and `table`, will be returned. If `FALSE` (default) the patients+ if (use_cache) {
|
|
| 77 | -+ | ||
| 308 | +16x |
- #' at risk table is printed below the plot via [cowplot::plot_grid()].+ if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...) |
|
| 78 | -+ | ||
| 309 | +56x |
- #' @param draw `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+ x_stats <- cache_env[[var_row_val]] |
|
| 79 | +310 |
- #' @param newpage `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+ } else {
|
|
| 80 | -+ | ||
| 311 | +412x |
- #' @param gp `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+ x_stats <- s_summary(u, ...) |
|
| 81 | +312 |
- #' @param vp `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+ } |
|
| 82 | +313 |
- #' @param name `r lifecycle::badge("deprecated")` This function no longer generates `grob` objects.
+
|
|
| 83 | -+ | ||
| 314 | +468x |
- #' @param annot_coxph_ref_lbls `r lifecycle::badge("deprecated")` Please use the `ref_lbls` element of
+ if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
|
|
| 84 | -+ | ||
| 315 | +348x |
- #' `control_annot_coxph` instead.+ res <- x_stats[[stat]] |
|
| 85 | +316 |
- #' @param position_coxph `r lifecycle::badge("deprecated")` Please use the `x` and `y` elements of
+ } else {
|
|
| 86 | -+ | ||
| 317 | +120x |
- #' `control_annot_coxph` instead.+ timept <- as.numeric(gsub(".*?([0-9\\.]+).*", "\\1", tail(.spl_context$value, 1)))
|
|
| 87 | -+ | ||
| 318 | +120x |
- #' @param position_surv_med `r lifecycle::badge("deprecated")` Please use the `x` and `y` elements of
+ res_imp <- imputation_rule( |
|
| 88 | -+ | ||
| 319 | +120x |
- #' `control_annot_surv_med` instead.+ .df_row, x_stats, stat, |
|
| 89 | -+ | ||
| 320 | +120x |
- #' @param width_annots `r lifecycle::badge("deprecated")` Please use the `w` element of `control_annot_surv_med`
+ imp_rule = imp_rule, |
|
| 90 | -+ | ||
| 321 | +120x |
- #' (for `surv_med`) and `control_annot_coxph` (for `coxph`)."+ post = grepl("Predose", tail(.spl_context$value, 1)) || timept > 0,
|
|
| 91 | -+ | ||
| 322 | +120x |
- #'+ avalcat_var = avalcat_var |
|
| 92 | +323 |
- #' @return A `ggplot` Kaplan-Meier plot and (optionally) summary table.+ ) |
|
| 93 | -+ | ||
| 324 | +120x |
- #'+ res <- res_imp[["val"]] |
|
| 94 | -+ | ||
| 325 | +120x |
- #' @examples+ na_str <- res_imp[["na_str"]] |
|
| 95 | +326 |
- #' library(dplyr)+ } |
|
| 96 | +327 |
- #'+ |
|
| 97 | -+ | ||
| 328 | +468x |
- #' df <- tern_ex_adtte %>%+ if (is.list(res)) {
|
|
| 98 | -+ | ||
| 329 | +52x |
- #' filter(PARAMCD == "OS") %>%+ if (length(res) > 1) {
|
|
| 99 | -+ | ||
| 330 | +1x |
- #' mutate(is_event = CNSR == 0)+ stop("The analyzed column produced more than one category of results.")
|
|
| 100 | +331 |
- #' variables <- list(tte = "AVAL", is_event = "is_event", arm = "ARMCD")+ } else {
|
|
| 101 | -+ | ||
| 332 | +51x |
- #'+ res <- unlist(res) |
|
| 102 | +333 |
- #' # Basic examples+ } |
|
| 103 | +334 |
- #' g_km(df = df, variables = variables)+ } |
|
| 104 | +335 |
- #' g_km(df = df, variables = variables, yval = "Failure")+ |
|
| 105 | +336 |
- #'+ # Label from context |
|
| 106 | -+ | ||
| 337 | +467x |
- #' # Examples with customization parameters applied+ label_from_context <- .spl_context$value[nrow(.spl_context)] |
|
| 107 | +338 |
- #' g_km(+ |
|
| 108 | +339 |
- #' df = df,+ # Label switcher |
|
| 109 | -+ | ||
| 340 | +467x |
- #' variables = variables,+ if (is.null(row_labels)) {
|
|
| 110 | -+ | ||
| 341 | +387x |
- #' control_surv = control_surv_timepoint(conf_level = 0.9),+ lbl <- label_from_context |
|
| 111 | +342 |
- #' col = c("grey25", "grey50", "grey75"),
+ } else {
|
|
| 112 | -+ | ||
| 343 | +80x |
- #' annot_at_risk_title = FALSE,+ if (length(row_labels) > 1) {
|
|
| 113 | -+ | ||
| 344 | +68x |
- #' lty = 1:3,+ if (!(label_from_context %in% names(row_labels))) {
|
|
| 114 | -+ | ||
| 345 | +2x |
- #' font_size = 8+ stop( |
|
| 115 | -+ | ||
| 346 | +2x |
- #' )+ "Replacing the labels in do_summarize_row_groups needs a named vector", |
|
| 116 | -+ | ||
| 347 | +2x |
- #' g_km(+ "that contains the split values. In the current split variable ", |
|
| 117 | -+ | ||
| 348 | +2x |
- #' df = df,+ .spl_context$split[nrow(.spl_context)], |
|
| 118 | -+ | ||
| 349 | +2x |
- #' variables = variables,+ " the split value ", label_from_context, " is not in", |
|
| 119 | -+ | ||
| 350 | +2x |
- #' annot_stats = c("min", "median"),
+ " row_labels names: ", names(row_labels) |
|
| 120 | +351 |
- #' annot_stats_vlines = TRUE,+ ) |
|
| 121 | +352 |
- #' max_time = 3000,+ } |
|
| 122 | -+ | ||
| 353 | +66x |
- #' ggtheme = ggplot2::theme_minimal()+ lbl <- unlist(row_labels[label_from_context]) |
|
| 123 | +354 |
- #' )+ } else {
|
|
| 124 | -+ | ||
| 355 | +12x |
- #'+ lbl <- row_labels |
|
| 125 | +356 |
- #' # Example with pairwise Cox-PH analysis annotation table, adjusted annotation tables+ } |
|
| 126 | +357 |
- #' g_km(+ } |
|
| 127 | +358 |
- #' df = df, variables = variables,+ |
|
| 128 | +359 |
- #' annot_coxph = TRUE,+ # Cell creation |
|
| 129 | -+ | ||
| 360 | +465x |
- #' control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99),+ rcell(res, |
|
| 130 | -+ | ||
| 361 | +465x |
- #' control_annot_coxph = control_coxph_annot(x = 0.26, w = 0.35),+ label = lbl, |
|
| 131 | -+ | ||
| 362 | +465x |
- #' control_annot_surv_med = control_surv_med_annot(x = 0.8, y = 0.9, w = 0.35)+ format = formats_v[names(formats_v) == stat][[1]], |
|
| 132 | -+ | ||
| 363 | +465x |
- #' )+ format_na_str = na_str, |
|
| 133 | -+ | ||
| 364 | +465x |
- #'+ indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods), |
|
| 134 | -+ | ||
| 365 | +465x |
- #' @aliases kaplan_meier+ align = .aligns |
|
| 135 | +366 |
- #' @export+ ) |
|
| 136 | +367 |
- g_km <- function(df,+ } |
|
| 137 | +368 |
- variables,+ }, |
|
| 138 | -+ | ||
| 369 | +15x |
- control_surv = control_surv_timepoint(),+ stat = .stats, |
|
| 139 | -+ | ||
| 370 | +15x |
- col = NULL,+ use_cache = cache, |
|
| 140 | -+ | ||
| 371 | +15x |
- lty = NULL,+ cache_env = replicate(length(.stats), env) |
|
| 141 | +372 |
- lwd = 0.5,+ ) |
|
| 142 | +373 |
- censor_show = TRUE,+ |
|
| 143 | +374 |
- pch = 3,+ # Main call to rtables |
|
| 144 | -+ | ||
| 375 | +15x |
- size = 2,+ analyze_colvars(lyt, |
|
| 145 | -+ | ||
| 376 | +15x |
- max_time = NULL,+ afun = afun_list, |
|
| 146 | -+ | ||
| 377 | +15x |
- xticks = NULL,+ na_str = na_str, |
|
| 147 | -+ | ||
| 378 | +15x |
- xlab = "Days",+ nested = nested,+ |
+ |
| 379 | +15x | +
+ extra_args = extra_args |
|
| 148 | +380 |
- yval = c("Survival", "Failure"),
+ ) |
|
| 149 | +381 |
- ylab = paste(yval, "Probability"),+ } |
|
| 150 | +382 |
- ylim = NULL,+ } |
|
| 151 | +383 |
- title = NULL,+ |
|
| 152 | +384 |
- footnotes = NULL,+ # Helper function |
|
| 153 | +385 |
- font_size = 10,+ get_last_col_split <- function(lyt) {
|
|
| 154 | -+ | ||
| 386 | +3x |
- ci_ribbon = FALSE,+ tail(tail(clayout(lyt), 1)[[1]], 1)[[1]] |
|
| 155 | +387 |
- annot_at_risk = TRUE,+ } |
| 156 | +1 |
- annot_at_risk_title = TRUE,+ #' Difference test for two proportions |
||
| 157 | +2 |
- annot_surv_med = TRUE,+ #' |
||
| 158 | +3 |
- annot_coxph = FALSE,+ #' @description `r lifecycle::badge("stable")`
|
||
| 159 | +4 |
- annot_stats = NULL,+ #' |
||
| 160 | +5 |
- annot_stats_vlines = FALSE,+ #' The analyze function [test_proportion_diff()] creates a layout element to test the difference between two |
||
| 161 | +6 |
- control_coxph_pw = control_coxph(),+ #' proportions. The primary analysis variable, `vars`, indicates whether a response has occurred for each record. See |
||
| 162 | +7 |
- ref_group_coxph = NULL,+ #' the `method` parameter for options of methods to use to calculate the p-value. Additionally, a stratification |
||
| 163 | +8 |
- control_annot_surv_med = control_surv_med_annot(),+ #' variable can be supplied via the `strata` element of the `variables` argument. |
||
| 164 | +9 |
- control_annot_coxph = control_coxph_annot(),+ #' |
||
| 165 | +10 |
- legend_pos = NULL,+ #' @inheritParams argument_convention |
||
| 166 | +11 |
- rel_height_plot = 0.75,+ #' @param method (`string`)\cr one of `chisq`, `cmh`, `fisher`, or `schouten`; specifies the test used |
||
| 167 | +12 |
- ggtheme = NULL,+ #' to calculate the p-value. |
||
| 168 | +13 |
- as_list = FALSE,+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 169 | +14 |
- draw = lifecycle::deprecated(),+ #' |
||
| 170 | +15 |
- newpage = lifecycle::deprecated(),+ #' Options are: ``r shQuote(get_stats("test_proportion_diff"), type = "sh")``
|
||
| 171 | +16 |
- gp = lifecycle::deprecated(),+ #' |
||
| 172 | +17 |
- vp = lifecycle::deprecated(),+ #' @seealso [h_prop_diff_test] |
||
| 173 | +18 |
- name = lifecycle::deprecated(),+ #' |
||
| 174 | +19 |
- annot_coxph_ref_lbls = lifecycle::deprecated(),+ #' @name prop_diff_test |
||
| 175 | +20 |
- position_coxph = lifecycle::deprecated(),+ #' @order 1 |
||
| 176 | +21 |
- position_surv_med = lifecycle::deprecated(),+ NULL |
||
| 177 | +22 |
- width_annots = lifecycle::deprecated()) {
+
|
||
| 178 | +23 |
- # Deprecated argument warnings- |
- ||
| 179 | -10x | -
- if (lifecycle::is_present(draw)) {
- |
- ||
| 180 | -1x | -
- lifecycle::deprecate_warn(- |
- ||
| 181 | -1x | -
- "0.9.4", "g_km(draw)",- |
- ||
| 182 | -1x | -
- details = "This argument is no longer used since the plot is now generated as a `ggplot2` object."+ #' @describeIn prop_diff_test Statistics function which tests the difference between two proportions. |
||
| 183 | +24 |
- )+ #' |
||
| 184 | +25 |
- }- |
- ||
| 185 | -10x | -
- if (lifecycle::is_present(newpage)) {
- |
- ||
| 186 | -1x | -
- lifecycle::deprecate_warn(- |
- ||
| 187 | -1x | -
- "0.9.4", "g_km(newpage)",- |
- ||
| 188 | -1x | -
- details = "This argument is no longer used since the plot is now generated as a `ggplot2` object."+ #' @return |
||
| 189 | +26 |
- )+ #' * `s_test_proportion_diff()` returns a named `list` with a single item `pval` with an attribute `label` |
||
| 190 | +27 |
- }+ #' describing the method used. The p-value tests the null hypothesis that proportions in two groups are the same. |
||
| 191 | -10x | +|||
| 28 | +
- if (lifecycle::is_present(gp)) {
+ #' |
|||
| 192 | -1x | +|||
| 29 | +
- lifecycle::deprecate_warn(+ #' @keywords internal |
|||
| 193 | -1x | +|||
| 30 | +
- "0.9.4", "g_km(gp)",+ s_test_proportion_diff <- function(df, |
|||
| 194 | -1x | +|||
| 31 | +
- details = "This argument is no longer used since the plot is now generated as a `ggplot2` object."+ .var, |
|||
| 195 | +32 |
- )+ .ref_group, |
||
| 196 | +33 |
- }+ .in_ref_col, |
||
| 197 | -10x | +|||
| 34 | +
- if (lifecycle::is_present(vp)) {
+ variables = list(strata = NULL), |
|||
| 198 | -1x | +|||
| 35 | +
- lifecycle::deprecate_warn(+ method = c("chisq", "schouten", "fisher", "cmh")) {
|
|||
| 199 | -1x | +36 | +45x |
- "0.9.4", "g_km(vp)",+ method <- match.arg(method) |
| 200 | -1x | +37 | +45x |
- details = "This argument is no longer used since the plot is now generated as a `ggplot2` object."+ y <- list(pval = "") |
| 201 | +38 |
- )+ |
||
| 202 | -+ | |||
| 39 | +45x |
- }+ if (!.in_ref_col) {
|
||
| 203 | -10x | +40 | +45x |
- if (lifecycle::is_present(name)) {
+ assert_df_with_variables(df, list(rsp = .var)) |
| 204 | -1x | +41 | +45x |
- lifecycle::deprecate_warn(+ assert_df_with_variables(.ref_group, list(rsp = .var)) |
| 205 | -1x | +42 | +45x |
- "0.9.4", "g_km(name)",+ rsp <- factor( |
| 206 | -1x | +43 | +45x |
- details = "This argument is no longer used since the plot is now generated as a `ggplot2` object."+ c(.ref_group[[.var]], df[[.var]]), |
| 207 | -+ | |||
| 44 | +45x |
- )+ levels = c("TRUE", "FALSE")
|
||
| 208 | +45 |
- }- |
- ||
| 209 | -10x | -
- if (lifecycle::is_present(annot_coxph_ref_lbls)) {
+ ) |
||
| 210 | -1x | +46 | +45x |
- lifecycle::deprecate_warn(+ grp <- factor( |
| 211 | -1x | +47 | +45x |
- "0.9.4", "g_km(annot_coxph_ref_lbls)",+ rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
|
| 212 | -1x | +48 | +45x |
- details = "Please specify this setting using the 'ref_lbls' element of control_annot_coxph."+ levels = c("ref", "Not-ref")
|
| 213 | +49 |
) |
||
| 214 | -1x | -
- control_annot_coxph[["ref_lbls"]] <- annot_coxph_ref_lbls- |
- ||
| 215 | +50 |
- }+ |
||
| 216 | -10x | +51 | +45x |
- if (lifecycle::is_present(position_coxph)) {
+ if (!is.null(variables$strata) || method == "cmh") {
|
| 217 | -1x | +52 | +12x |
- lifecycle::deprecate_warn(+ strata <- variables$strata |
| 218 | -1x | +53 | +12x |
- "0.9.4", "g_km(position_coxph)",+ checkmate::assert_false(is.null(strata)) |
| 219 | -1x | +54 | +12x |
- details = "Please specify this setting using the 'x' and 'y' elements of control_annot_coxph."+ strata_vars <- stats::setNames(as.list(strata), strata) |
| 220 | -+ | |||
| 55 | +12x |
- )+ assert_df_with_variables(df, strata_vars) |
||
| 221 | -1x | +56 | +12x |
- control_annot_coxph[["x"]] <- position_coxph[1]+ assert_df_with_variables(.ref_group, strata_vars) |
| 222 | -1x | +57 | +12x |
- control_annot_coxph[["y"]] <- position_coxph[2]+ strata <- c(interaction(.ref_group[strata]), interaction(df[strata])) |
| 223 | +58 |
- }+ } |
||
| 224 | -10x | +|||
| 59 | +
- if (lifecycle::is_present(position_surv_med)) {
+
|
|||
| 225 | -1x | +60 | +45x |
- lifecycle::deprecate_warn(+ tbl <- switch(method, |
| 226 | -1x | +61 | +45x |
- "0.9.4", "g_km(position_surv_med)",+ cmh = table(grp, rsp, strata), |
| 227 | -1x | +62 | +45x |
- details = "Please specify this setting using the 'x' and 'y' elements of control_annot_surv_med."+ table(grp, rsp) |
| 228 | +63 |
) |
||
| 229 | -1x | -
- control_annot_surv_med[["x"]] <- position_surv_med[1]- |
- ||
| 230 | -1x | -
- control_annot_surv_med[["y"]] <- position_surv_med[2]- |
- ||
| 231 | +64 |
- }- |
- ||
| 232 | -10x | -
- if (lifecycle::is_present(width_annots)) {
+
|
||
| 233 | -1x | +65 | +45x |
- lifecycle::deprecate_warn(+ y$pval <- switch(method, |
| 234 | -1x | +66 | +45x |
- "0.9.4", "g_km(width_annots)",+ chisq = prop_chisq(tbl), |
| 235 | -1x | +67 | +45x |
- details = paste(+ cmh = prop_cmh(tbl), |
| 236 | -1x | +68 | +45x |
- "Please specify widths of annotation tables relative to the plot area using the 'w' element of",+ fisher = prop_fisher(tbl), |
| 237 | -1x | -
- "control_annot_surv_med (for surv_med) and control_annot_coxph (for coxph)."- |
- ||
| 238 | -+ | 69 | +45x |
- )+ schouten = prop_schouten(tbl) |
| 239 | +70 |
) |
||
| 240 | -1x | -
- control_annot_surv_med[["w"]] <- as.numeric(width_annots[["surv_med"]])- |
- ||
| 241 | -1x | -
- control_annot_coxph[["w"]] <- as.numeric(width_annots[["coxph"]])- |
- ||
| 242 | +71 |
} |
||
| 243 | +72 | |||
| 244 | -10x | -
- checkmate::assert_list(variables)- |
- ||
| 245 | -10x | +73 | +45x |
- checkmate::assert_subset(c("tte", "arm", "is_event"), names(variables))
+ y$pval <- formatters::with_label(y$pval, d_test_proportion_diff(method)) |
| 246 | -10x | +74 | +45x |
- checkmate::assert_logical(censor_show, len = 1)+ y |
| 247 | -10x | +|||
| 75 | +
- checkmate::assert_numeric(size, len = 1)+ } |
|||
| 248 | -10x | +|||
| 76 | +
- checkmate::assert_numeric(max_time, len = 1, null.ok = TRUE)+ |
|||
| 249 | -10x | +|||
| 77 | +
- checkmate::assert_numeric(xticks, null.ok = TRUE)+ #' Description of the difference test between two proportions |
|||
| 250 | -10x | +|||
| 78 | +
- checkmate::assert_character(xlab, len = 1, null.ok = TRUE)+ #' |
|||
| 251 | -10x | +|||
| 79 | +
- checkmate::assert_character(yval)+ #' @description `r lifecycle::badge("stable")`
|
|||
| 252 | -10x | +|||
| 80 | +
- checkmate::assert_character(ylab, null.ok = TRUE)+ #' |
|||
| 253 | -10x | +|||
| 81 | +
- checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE, null.ok = TRUE)+ #' This is an auxiliary function that describes the analysis in `s_test_proportion_diff`. |
|||
| 254 | -10x | +|||
| 82 | +
- checkmate::assert_character(title, len = 1, null.ok = TRUE)+ #' |
|||
| 255 | -10x | +|||
| 83 | +
- checkmate::assert_character(footnotes, len = 1, null.ok = TRUE)+ #' @inheritParams s_test_proportion_diff |
|||
| 256 | -10x | +|||
| 84 | +
- checkmate::assert_numeric(font_size, len = 1)+ #' |
|||
| 257 | -10x | +|||
| 85 | +
- checkmate::assert_logical(ci_ribbon, len = 1)+ #' @return A `string` describing the test from which the p-value is derived. |
|||
| 258 | -10x | +|||
| 86 | +
- checkmate::assert_logical(annot_at_risk, len = 1)+ #' |
|||
| 259 | -10x | +|||
| 87 | +
- checkmate::assert_logical(annot_at_risk_title, len = 1)+ #' @export |
|||
| 260 | -10x | +|||
| 88 | +
- checkmate::assert_logical(annot_surv_med, len = 1)+ d_test_proportion_diff <- function(method) {
|
|||
| 261 | -10x | +89 | +59x |
- checkmate::assert_logical(annot_coxph, len = 1)+ checkmate::assert_string(method) |
| 262 | -10x | +90 | +59x |
- checkmate::assert_subset(annot_stats, c("median", "min"))
+ meth_part <- switch(method, |
| 263 | -10x | +91 | +59x |
- checkmate::assert_logical(annot_stats_vlines)+ "schouten" = "Chi-Squared Test with Schouten Correction", |
| 264 | -10x | +92 | +59x |
- checkmate::assert_list(control_coxph_pw)+ "chisq" = "Chi-Squared Test", |
| 265 | -10x | +93 | +59x |
- checkmate::assert_character(ref_group_coxph, len = 1, null.ok = TRUE)+ "cmh" = "Cochran-Mantel-Haenszel Test", |
| 266 | -10x | +94 | +59x |
- checkmate::assert_list(control_annot_surv_med)+ "fisher" = "Fisher's Exact Test", |
| 267 | -10x | +95 | +59x |
- checkmate::assert_list(control_annot_coxph)+ stop(paste(method, "does not have a description")) |
| 268 | -10x | +|||
| 96 | +
- checkmate::assert_numeric(legend_pos, finite = TRUE, any.missing = FALSE, len = 2, null.ok = TRUE)+ ) |
|||
| 269 | -10x | +97 | +59x |
- assert_proportion_value(rel_height_plot)+ paste0("p-value (", meth_part, ")")
|
| 270 | -10x | +|||
| 98 | +
- checkmate::assert_logical(as_list)+ } |
|||
| 271 | +99 | |||
| 272 | -10x | +|||
| 100 | +
- tte <- variables$tte+ #' @describeIn prop_diff_test Formatted analysis function which is used as `afun` in `test_proportion_diff()`. |
|||
| 273 | -10x | +|||
| 101 | +
- is_event <- variables$is_event+ #' |
|||
| 274 | -10x | +|||
| 102 | +
- arm <- variables$arm+ #' @return |
|||
| 275 | -10x | +|||
| 103 | +
- assert_valid_factor(df[[arm]])+ #' * `a_test_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 276 | -10x | +|||
| 104 | +
- armval <- as.character(unique(df[[arm]]))+ #' |
|||
| 277 | -10x | +|||
| 105 | +
- assert_df_with_variables(df, list(tte = tte, is_event = is_event, arm = arm))+ #' @keywords internal |
|||
| 278 | -10x | +|||
| 106 | +
- checkmate::assert_logical(df[[is_event]], min.len = 1)+ a_test_proportion_diff <- make_afun( |
|||
| 279 | -10x | +|||
| 107 | +
- checkmate::assert_numeric(df[[tte]], min.len = 1)+ s_test_proportion_diff, |
|||
| 280 | -10x | +|||
| 108 | +
- checkmate::assert_vector(col, len = length(armval), null.ok = TRUE)+ .formats = c(pval = "x.xxxx | (<0.0001)"), |
|||
| 281 | -10x | +|||
| 109 | +
- checkmate::assert_vector(lty, null.ok = TRUE)+ .indent_mods = c(pval = 1L) |
|||
| 282 | -10x | +|||
| 110 | +
- checkmate::assert_numeric(lwd, len = 1, null.ok = TRUE)+ ) |
|||
| 283 | +111 | |||
| 284 | -10x | -
- if (annot_coxph && length(armval) < 2) {
- |
- ||
| 285 | -! | +|||
| 112 | +
- stop(paste(+ #' @describeIn prop_diff_test Layout-creating function which can take statistics function arguments |
|||
| 286 | -! | +|||
| 113 | +
- "When `annot_coxph` = TRUE, `df` must contain at least 2 levels of `variables$arm`",+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 287 | -! | +|||
| 114 | +
- "in order to calculate the hazard ratio."+ #' |
|||
| 288 | +115 |
- ))+ #' @return |
||
| 289 | +116 |
- }+ #' * `test_proportion_diff()` returns a layout object suitable for passing to further layouting functions, |
||
| 290 | +117 |
-
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 291 | +118 |
- # process model+ #' the statistics from `s_test_proportion_diff()` to the table layout. |
||
| 292 | -10x | +|||
| 119 | +
- yval <- match.arg(yval)+ #' |
|||
| 293 | -10x | +|||
| 120 | +
- formula <- stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", arm))
+ #' @examples |
|||
| 294 | -10x | +|||
| 121 | +
- fit_km <- survival::survfit(+ #' dta <- data.frame( |
|||
| 295 | -10x | +|||
| 122 | +
- formula = formula,+ #' rsp = sample(c(TRUE, FALSE), 100, TRUE), |
|||
| 296 | -10x | +|||
| 123 | +
- data = df,+ #' grp = factor(rep(c("A", "B"), each = 50)),
|
|||
| 297 | -10x | +|||
| 124 | +
- conf.int = control_surv$conf_level,+ #' strata = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20))
|
|||
| 298 | -10x | +|||
| 125 | +
- conf.type = control_surv$conf_type+ #' ) |
|||
| 299 | +126 |
- )+ #' |
||
| 300 | -10x | +|||
| 127 | +
- data <- h_data_plot(fit_km, armval = armval, max_time = max_time)+ #' # With `rtables` pipelines. |
|||
| 301 | +128 |
-
+ #' l <- basic_table() %>% |
||
| 302 | +129 |
- # calculate x-ticks+ #' split_cols_by(var = "grp", ref_group = "B") %>% |
||
| 303 | -10x | +|||
| 130 | +
- xticks <- h_xticks(data = data, xticks = xticks, max_time = max_time)+ #' test_proportion_diff( |
|||
| 304 | +131 |
-
+ #' vars = "rsp", |
||
| 305 | +132 |
- # change estimates of survival to estimates of failure (1 - survival)+ #' method = "cmh", variables = list(strata = "strata") |
||
| 306 | -10x | +|||
| 133 | +
- if (yval == "Failure") {
+ #' ) |
|||
| 307 | -! | +|||
| 134 | +
- data[c("estimate", "conf.low", "conf.high", "censor")] <- list(
+ #' |
|||
| 308 | -! | +|||
| 135 | +
- 1 - data$estimate, 1 - data$conf.low, 1 - data$conf.high, 1 - data$censor+ #' build_table(l, df = dta) |
|||
| 309 | +136 |
- )+ #' |
||
| 310 | +137 |
- }+ #' @export |
||
| 311 | +138 |
-
+ #' @order 2 |
||
| 312 | +139 |
- # derive y-axis limits+ test_proportion_diff <- function(lyt, |
||
| 313 | -10x | +|||
| 140 | +
- if (is.null(ylim)) {
+ vars, |
|||
| 314 | -10x | +|||
| 141 | +
- if (!is.null(max_time)) {
+ variables = list(strata = NULL), |
|||
| 315 | -1x | +|||
| 142 | +
- y_lwr <- min(data[data$time < max_time, ][["estimate"]])+ method = c("chisq", "schouten", "fisher", "cmh"),
|
|||
| 316 | -1x | +|||
| 143 | +
- y_upr <- max(data[data$time < max_time, ][["estimate"]])+ na_str = default_na_str(), |
|||
| 317 | +144 |
- } else {
+ nested = TRUE, |
||
| 318 | -9x | +|||
| 145 | +
- y_lwr <- min(data[["estimate"]])+ ..., |
|||
| 319 | -9x | +|||
| 146 | +
- y_upr <- max(data[["estimate"]])+ var_labels = vars, |
|||
| 320 | +147 |
- }+ show_labels = "hidden", |
||
| 321 | -10x | +|||
| 148 | +
- ylim <- c(y_lwr, y_upr)+ table_names = vars, |
|||
| 322 | +149 |
- }+ .stats = NULL, |
||
| 323 | +150 |
-
+ .formats = NULL, |
||
| 324 | +151 |
- # initialize ggplot+ .labels = NULL, |
||
| 325 | -10x | +|||
| 152 | +
- gg_plt <- ggplot(+ .indent_mods = NULL) {
|
|||
| 326 | -10x | +153 | +6x |
- data = data,+ extra_args <- list(variables = variables, method = method, ...) |
| 327 | -10x | +|||
| 154 | +
- mapping = aes(+ |
|||
| 328 | -10x | +155 | +6x |
- x = .data[["time"]],+ afun <- make_afun( |
| 329 | -10x | +156 | +6x |
- y = .data[["estimate"]],+ a_test_proportion_diff, |
| 330 | -10x | +157 | +6x |
- ymin = .data[["conf.low"]],+ .stats = .stats, |
| 331 | -10x | +158 | +6x |
- ymax = .data[["conf.high"]],+ .formats = .formats, |
| 332 | -10x | +159 | +6x |
- color = .data[["strata"]],+ .labels = .labels, |
| 333 | -10x | +160 | +6x |
- fill = .data[["strata"]]+ .indent_mods = .indent_mods |
| 334 | +161 |
- )+ ) |
||
| 335 | -+ | |||
| 162 | +6x |
- ) ++ analyze( |
||
| 336 | -10x | +163 | +6x |
- theme_bw(base_size = font_size) ++ lyt, |
| 337 | -10x | +164 | +6x |
- scale_y_continuous(limits = ylim, expand = c(0.025, 0)) ++ vars, |
| 338 | -10x | +165 | +6x |
- labs(title = title, x = xlab, y = ylab, caption = footnotes) ++ afun = afun, |
| 339 | -10x | +166 | +6x |
- theme(+ var_labels = var_labels, |
| 340 | -10x | +167 | +6x |
- axis.text = element_text(size = font_size),+ na_str = na_str, |
| 341 | -10x | +168 | +6x |
- axis.title = element_text(size = font_size),+ nested = nested, |
| 342 | -10x | +169 | +6x |
- legend.title = element_blank(),+ extra_args = extra_args, |
| 343 | -10x | +170 | +6x |
- legend.text = element_text(size = font_size),+ show_labels = show_labels, |
| 344 | -10x | +171 | +6x |
- legend.box.background = element_rect(fill = "white", linewidth = 0.5),+ table_names = table_names |
| 345 | -10x | +|||
| 172 | +
- legend.background = element_blank(),+ ) |
|||
| 346 | -10x | +|||
| 173 | +
- legend.position = "inside",+ } |
|||
| 347 | -10x | +|||
| 174 | +
- legend.spacing.y = unit(-0.02, "npc"),+ |
|||
| 348 | -10x | +|||
| 175 | +
- panel.grid.major = element_blank(),+ #' Helper functions to test proportion differences |
|||
| 349 | -10x | +|||
| 176 | +
- panel.grid.minor = element_blank()+ #' |
|||
| 350 | +177 |
- )+ #' Helper functions to implement various tests on the difference between two proportions. |
||
| 351 | +178 |
-
+ #' |
||
| 352 | +179 |
- # derive x-axis limits+ #' @param tbl (`matrix`)\cr matrix with two groups in rows and the binary response (`TRUE`/`FALSE`) in columns. |
||
| 353 | -10x | +|||
| 180 | +
- if (!is.null(max_time) && !is.null(xticks)) {
+ #' |
|||
| 354 | -1x | +|||
| 181 | +
- gg_plt <- gg_plt + scale_x_continuous(+ #' @return A p-value. |
|||
| 355 | -1x | +|||
| 182 | +
- breaks = xticks, limits = c(min(0, xticks), max(c(xticks, max_time))), expand = c(0.025, 0)+ #' |
|||
| 356 | +183 |
- )+ #' @seealso [prop_diff_test()] for implementation of these helper functions. |
||
| 357 | -9x | +|||
| 184 | +
- } else if (!is.null(xticks)) {
+ #' |
|||
| 358 | -9x | +|||
| 185 | +
- if (max(data$time) <= max(xticks)) {
+ #' @name h_prop_diff_test |
|||
| 359 | -9x | +|||
| 186 | +
- gg_plt <- gg_plt + scale_x_continuous(+ NULL |
|||
| 360 | -9x | +|||
| 187 | +
- breaks = xticks, limits = c(min(0, min(xticks)), max(xticks)), expand = c(0.025, 0)+ |
|||
| 361 | +188 |
- )+ #' @describeIn h_prop_diff_test Performs Chi-Squared test. Internally calls [stats::prop.test()]. |
||
| 362 | +189 |
- } else {
+ #' |
||
| 363 | -! | +|||
| 190 | +
- gg_plt <- gg_plt + scale_x_continuous(breaks = xticks, expand = c(0.025, 0))+ #' @keywords internal |
|||
| 364 | +191 |
- }+ prop_chisq <- function(tbl) {
|
||
| 365 | -! | +|||
| 192 | +41x |
- } else if (!is.null(max_time)) {
+ checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2) |
||
| 366 | -! | +|||
| 193 | +41x |
- gg_plt <- gg_plt + scale_x_continuous(limits = c(0, max_time), expand = c(0.025, 0))+ tbl <- tbl[, c("TRUE", "FALSE")]
|
||
| 367 | -+ | |||
| 194 | +41x |
- }+ if (any(colSums(tbl) == 0)) {
|
||
| 368 | -+ | |||
| 195 | +2x |
-
+ return(1) |
||
| 369 | +196 |
- # set legend position+ } |
||
| 370 | -10x | +197 | +39x |
- if (!is.null(legend_pos)) {
+ stats::prop.test(tbl, correct = FALSE)$p.value |
| 371 | -2x | +|||
| 198 | +
- gg_plt <- gg_plt + theme(legend.position.inside = legend_pos)+ } |
|||
| 372 | +199 |
- } else {
+
|
||
| 373 | -8x | +|||
| 200 | +
- max_time2 <- sort(+ #' @describeIn h_prop_diff_test Performs stratified Cochran-Mantel-Haenszel test. Internally calls |
|||
| 374 | -8x | +|||
| 201 | +
- data$time,+ #' [stats::mantelhaen.test()]. Note that strata with less than two observations are automatically discarded. |
|||
| 375 | -8x | +|||
| 202 | +
- partial = nrow(data) - length(armval) - 1+ #' |
|||
| 376 | -8x | +|||
| 203 | +
- )[nrow(data) - length(armval) - 1]+ #' @param ary (`array`, 3 dimensions)\cr array with two groups in rows, the binary response |
|||
| 377 | +204 |
-
+ #' (`TRUE`/`FALSE`) in columns, and the strata in the third dimension. |
||
| 378 | -8x | +|||
| 205 | +
- y_rng <- ylim[2] - ylim[1]+ #' |
|||
| 379 | +206 |
-
+ #' @keywords internal+ |
+ ||
| 207 | ++ |
+ prop_cmh <- function(ary) {
|
||
| 380 | -8x | +208 | +16x |
- if (yval == "Survival" && all(data$estimate[data$time == max_time2] > ylim[1] + 0.09 * y_rng) &&+ checkmate::assert_array(ary) |
| 381 | -8x | +209 | +16x |
- all(data$estimate[data$time == max_time2] < ylim[1] + 0.5 * y_rng)) { # nolint
+ checkmate::assert_integer(c(ncol(ary), nrow(ary)), lower = 2, upper = 2) |
| 382 | -1x | +210 | +16x |
- gg_plt <- gg_plt ++ checkmate::assert_integer(length(dim(ary)), lower = 3, upper = 3) |
| 383 | -1x | +211 | +16x |
- theme(+ strata_sizes <- apply(ary, MARGIN = 3, sum) |
| 384 | +212 | +16x | +
+ if (any(strata_sizes < 5)) {
+ |
+ |
| 213 | 1x |
- legend.position.inside = c(1, 0.5),+ warning("<5 data points in some strata. CMH test may be incorrect.")
|
||
| 385 | +214 | 1x |
- legend.justification = c(1.1, 0.6)+ ary <- ary[, , strata_sizes > 1] |
|
| 386 | +215 |
- )+ } |
||
| 387 | +216 |
- } else {
+
|
||
| 388 | -7x | +217 | +16x |
- gg_plt <- gg_plt ++ stats::mantelhaen.test(ary, correct = FALSE)$p.value |
| 389 | -7x | +|||
| 218 | +
- theme(+ } |
|||
| 390 | -7x | +|||
| 219 | +
- legend.position.inside = c(1, 0),+ |
|||
| 391 | -7x | +|||
| 220 | +
- legend.justification = c(1.1, -0.4)+ #' @describeIn h_prop_diff_test Performs the Chi-Squared test with Schouten correction. |
|||
| 392 | +221 |
- )+ #' |
||
| 393 | +222 |
- }+ #' @seealso Schouten correction is based upon \insertCite{Schouten1980-kd;textual}{tern}.
|
||
| 394 | +223 |
- }+ #' |
||
| 395 | +224 |
-
+ #' @keywords internal |
||
| 396 | +225 |
- # add lines+ prop_schouten <- function(tbl) {
|
||
| 397 | -10x | +226 | +100x |
- gg_plt <- if (is.null(lty)) {
+ checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2) |
| 398 | -9x | +227 | +100x |
- gg_plt + geom_step(linewidth = lwd, na.rm = TRUE)+ tbl <- tbl[, c("TRUE", "FALSE")]
|
| 399 | -10x | +228 | +100x |
- } else if (length(lty) == 1) {
+ if (any(colSums(tbl) == 0)) {
|
| 400 | -! | +|||
| 229 | +1x |
- gg_plt + geom_step(linewidth = lwd, lty = lty, na.rm = TRUE)+ return(1) |
||
| 401 | +230 |
- } else {
+ } |
||
| 402 | -1x | +|||
| 231 | +
- gg_plt ++ |
|||
| 403 | -1x | +232 | +99x |
- geom_step(aes(lty = .data[["strata"]]), linewidth = lwd, na.rm = TRUE) ++ n <- sum(tbl) |
| 404 | -1x | +233 | +99x |
- scale_linetype_manual(values = lty)+ n1 <- sum(tbl[1, ]) |
| 405 | -+ | |||
| 234 | +99x |
- }+ n2 <- sum(tbl[2, ]) |
||
| 406 | +235 | |||
| 407 | -+ | |||
| 236 | +99x |
- # add censor marks+ ad <- diag(tbl) |
||
| 408 | -10x | +237 | +99x |
- if (censor_show) {
+ bc <- diag(apply(tbl, 2, rev)) |
| 409 | -10x | +238 | +99x |
- gg_plt <- gg_plt + geom_point(+ ac <- tbl[, 1] |
| 410 | -10x | +239 | +99x |
- data = data[data$n.censor != 0, ],+ bd <- tbl[, 2] |
| 411 | -10x | +|||
| 240 | +
- aes(x = .data[["time"]], y = .data[["censor"]], shape = "Censored"),+ |
|||
| 412 | -10x | +241 | +99x |
- size = size,+ t_schouten <- (n - 1) * |
| 413 | -10x | +242 | +99x |
- na.rm = TRUE+ (abs(prod(ad) - prod(bc)) - 0.5 * min(n1, n2))^2 / |
| 414 | -+ | |||
| 243 | +99x |
- ) ++ (n1 * n2 * sum(ac) * sum(bd)) |
||
| 415 | -10x | +|||
| 244 | +
- scale_shape_manual(name = NULL, values = pch) ++ |
|||
| 416 | -10x | +245 | +99x |
- guides(fill = guide_legend(override.aes = list(shape = NA)))+ 1 - stats::pchisq(t_schouten, df = 1) |
| 417 | +246 |
- }+ } |
||
| 418 | +247 | |||
| 419 | +248 |
- # add ci ribbon- |
- ||
| 420 | -1x | -
- if (ci_ribbon) gg_plt <- gg_plt + geom_ribbon(alpha = 0.3, lty = 0, na.rm = TRUE)+ #' @describeIn h_prop_diff_test Performs the Fisher's exact test. Internally calls [stats::fisher.test()]. |
||
| 421 | +249 |
-
+ #' |
||
| 422 | +250 |
- # control aesthetics+ #' @keywords internal |
||
| 423 | -10x | +|||
| 251 | +
- if (!is.null(col)) {
+ prop_fisher <- function(tbl) {
|
|||
| 424 | -1x | +252 | +2x |
- gg_plt <- gg_plt ++ checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2) |
| 425 | -1x | +253 | +2x |
- scale_color_manual(values = col) ++ tbl <- tbl[, c("TRUE", "FALSE")]
|
| 426 | -1x | +254 | +2x |
- scale_fill_manual(values = col)+ stats::fisher.test(tbl)$p.value |
| 427 | +255 |
- }- |
- ||
| 428 | -! | -
- if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme+ } |
| 429 | +1 |
-
+ #' Stack multiple grobs |
||
| 430 | +2 |
- # annotate with stats (text/vlines)- |
- ||
| 431 | -10x | -
- if (!is.null(annot_stats)) {
- |
- ||
| 432 | -! | -
- if ("median" %in% annot_stats) {
- |
- ||
| 433 | -! | -
- fit_km_all <- survival::survfit(- |
- ||
| 434 | -! | -
- formula = stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", 1)),
- |
- ||
| 435 | -! | -
- data = df,- |
- ||
| 436 | -! | -
- conf.int = control_surv$conf_level,- |
- ||
| 437 | -! | -
- conf.type = control_surv$conf_type+ #' |
||
| 438 | +3 |
- )- |
- ||
| 439 | -! | -
- gg_plt <- gg_plt +- |
- ||
| 440 | -! | -
- annotate(+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 441 | -! | +|||
| 4 | +
- "text",+ #' |
|||
| 442 | -! | +|||
| 5 | +
- size = font_size / .pt, col = 1, lineheight = 0.95,+ #' Stack grobs as a new grob with 1 column and multiple rows layout. |
|||
| 443 | -! | +|||
| 6 | +
- x = stats::median(fit_km_all) + 0.07 * max(data$time),+ #' |
|||
| 444 | -! | +|||
| 7 | +
- y = ifelse(yval == "Survival", 0.65, 0.35),+ #' @param ... grobs. |
|||
| 445 | -! | +|||
| 8 | +
- label = paste("Median F/U:\n", round(stats::median(fit_km_all), 1), tolower(df$AVALU[1]))
+ #' @param grobs (`list` of `grob`)\cr a list of grobs. |
|||
| 446 | +9 |
- )+ #' @param padding (`grid::unit`)\cr unit of length 1, space between each grob. |
||
| 447 | -! | +|||
| 10 | +
- if (annot_stats_vlines) {
+ #' @param vp (`viewport` or `NULL`)\cr a [viewport()] object (or `NULL`). |
|||
| 448 | -! | +|||
| 11 | +
- gg_plt <- gg_plt ++ #' @param name (`string`)\cr a character identifier for the grob. |
|||
| 449 | -! | +|||
| 12 | +
- annotate(+ #' @param gp (`gpar`)\cr a [gpar()] object. |
|||
| 450 | -! | +|||
| 13 | +
- "segment",+ #' |
|||
| 451 | -! | +|||
| 14 | +
- x = stats::median(fit_km_all), xend = stats::median(fit_km_all), y = -Inf, yend = Inf,+ #' @return A `grob`. |
|||
| 452 | -! | +|||
| 15 | +
- linetype = 2, col = "darkgray"+ #' |
|||
| 453 | +16 |
- )+ #' @examples |
||
| 454 | +17 |
- }+ #' library(grid) |
||
| 455 | +18 |
- }+ #' |
||
| 456 | -! | +|||
| 19 | +
- if ("min" %in% annot_stats) {
+ #' g1 <- circleGrob(gp = gpar(col = "blue")) |
|||
| 457 | -! | +|||
| 20 | +
- min_fu <- min(df[[tte]])+ #' g2 <- circleGrob(gp = gpar(col = "red")) |
|||
| 458 | -! | +|||
| 21 | +
- gg_plt <- gg_plt ++ #' g3 <- textGrob("TEST TEXT")
|
|||
| 459 | -! | +|||
| 22 | +
- annotate(+ #' grid.newpage() |
|||
| 460 | -! | +|||
| 23 | +
- "text",+ #' grid.draw(stack_grobs(g1, g2, g3)) |
|||
| 461 | -! | +|||
| 24 | +
- size = font_size / .pt, col = 1, lineheight = 0.95,+ #' |
|||
| 462 | -! | +|||
| 25 | +
- x = min_fu + max(data$time) * 0.07,+ #' showViewport() |
|||
| 463 | -! | +|||
| 26 | +
- y = ifelse(yval == "Survival", 0.96, 0.05),+ #' |
|||
| 464 | -! | +|||
| 27 | +
- label = paste("Min. F/U:\n", round(min_fu, 1), tolower(df$AVALU[1]))
+ #' grid.newpage() |
|||
| 465 | +28 |
- )+ #' pushViewport(viewport(layout = grid.layout(1, 2))) |
||
| 466 | -! | +|||
| 29 | +
- if (annot_stats_vlines) {
+ #' vp1 <- viewport(layout.pos.row = 1, layout.pos.col = 2) |
|||
| 467 | -! | +|||
| 30 | +
- gg_plt <- gg_plt ++ #' grid.draw(stack_grobs(g1, g2, g3, vp = vp1, name = "test")) |
|||
| 468 | -! | +|||
| 31 | +
- annotate(+ #' |
|||
| 469 | -! | +|||
| 32 | +
- "segment",+ #' showViewport() |
|||
| 470 | -! | +|||
| 33 | +
- linetype = 2, col = "darkgray",+ #' grid.ls(grobs = TRUE, viewports = TRUE, print = FALSE) |
|||
| 471 | -! | +|||
| 34 | +
- x = min_fu, xend = min_fu, y = Inf, yend = -Inf+ #' |
|||
| 472 | +35 |
- )+ #' @export |
||
| 473 | +36 |
- }+ stack_grobs <- function(..., |
||
| 474 | +37 |
- }+ grobs = list(...), |
||
| 475 | -! | +|||
| 38 | +
- gg_plt <- gg_plt + guides(fill = guide_legend(override.aes = list(shape = NA, label = "")))+ padding = grid::unit(2, "line"), |
|||
| 476 | +39 |
- }+ vp = NULL, |
||
| 477 | +40 |
-
+ gp = NULL, |
||
| 478 | +41 |
- # add at risk annotation table+ name = NULL) {
|
||
| 479 | -10x | +42 | +4x |
- if (annot_at_risk) {
+ lifecycle::deprecate_warn( |
| 480 | -9x | +43 | +4x |
- annot_tbl <- summary(fit_km, times = xticks, extend = TRUE)+ "0.9.4", |
| 481 | -9x | -
- annot_tbl <- if (is.null(fit_km$strata)) {
- |
- ||
| 482 | -! | -
- data.frame(- |
- ||
| 483 | -! | -
- n.risk = annot_tbl$n.risk,- |
- ||
| 484 | -! | +44 | +4x |
- time = annot_tbl$time,+ "stack_grobs()", |
| 485 | -! | +|||
| 45 | +4x |
- strata = armval+ details = "`tern` plotting functions no longer generate `grob` objects." |
||
| 486 | +46 |
- )+ ) |
||
| 487 | +47 |
- } else {
+
|
||
| 488 | -9x | +48 | +4x |
- strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
+ checkmate::assert_true( |
| 489 | -9x | +49 | +4x |
- levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2]+ all(vapply(grobs, grid::is.grob, logical(1))) |
| 490 | -9x | +|||
| 50 | +
- data.frame(+ ) |
|||
| 491 | -9x | +|||
| 51 | +
- n.risk = annot_tbl$n.risk,+ |
|||
| 492 | -9x | +52 | +4x |
- time = annot_tbl$time,+ if (length(grobs) == 1) {
|
| 493 | -9x | +53 | +1x |
- strata = annot_tbl$strata+ return(grobs[[1]]) |
| 494 | +54 |
- )+ } |
||
| 495 | +55 |
- }+ |
||
| 496 | -+ | |||
| 56 | +3x |
-
+ n_layout <- 2 * length(grobs) - 1 |
||
| 497 | -9x | +57 | +3x |
- at_risk_tbl <- as.data.frame(tidyr::pivot_wider(annot_tbl, names_from = "time", values_from = "n.risk")[, -1])+ hts <- lapply( |
| 498 | -9x | +58 | +3x |
- at_risk_tbl[is.na(at_risk_tbl)] <- 0+ seq(1, n_layout), |
| 499 | -9x | +59 | +3x |
- rownames(at_risk_tbl) <- levels(annot_tbl$strata)+ function(i) {
|
| 500 | -+ | |||
| 60 | +39x |
-
+ if (i %% 2 != 0) {
|
||
| 501 | -9x | +61 | +21x |
- gg_at_risk <- df2gg(+ grid::unit(1, "null") |
| 502 | -9x | +|||
| 62 | +
- at_risk_tbl,+ } else {
|
|||
| 503 | -9x | +63 | +18x |
- font_size = font_size, col_labels = FALSE, hline = FALSE,+ padding |
| 504 | -9x | +|||
| 64 | +
- colwidths = rep(1, ncol(at_risk_tbl))+ } |
|||
| 505 | +65 |
- ) ++ } |
||
| 506 | -9x | +|||
| 66 | +
- labs(title = if (annot_at_risk_title) "Patients at Risk:" else NULL, x = xlab) ++ ) |
|||
| 507 | -9x | +67 | +3x |
- theme_bw(base_size = font_size) ++ hts <- do.call(grid::unit.c, hts) |
| 508 | -9x | +|||
| 68 | +
- theme(+ |
|||
| 509 | -9x | +69 | +3x |
- plot.title = element_text(size = font_size, vjust = 3, face = "bold"),+ main_vp <- grid::viewport( |
| 510 | -9x | +70 | +3x |
- panel.border = element_blank(),+ layout = grid::grid.layout(nrow = n_layout, ncol = 1, heights = hts) |
| 511 | -9x | +|||
| 71 | +
- panel.grid = element_blank(),+ ) |
|||
| 512 | -9x | +|||
| 72 | +
- axis.title.y = element_blank(),+ |
|||
| 513 | -9x | +73 | +3x |
- axis.ticks.y = element_blank(),+ nested_grobs <- Map(function(g, i) {
|
| 514 | -9x | +74 | +21x |
- axis.text.y = element_text(size = font_size, face = "italic", hjust = 1),+ grid::gTree( |
| 515 | -9x | +75 | +21x |
- axis.text.x = element_text(size = font_size),+ children = grid::gList(g), |
| 516 | -9x | +76 | +21x |
- axis.line.x = element_line()+ vp = grid::viewport(layout.pos.row = i, layout.pos.col = 1) |
| 517 | +77 |
- ) ++ ) |
||
| 518 | -9x | +78 | +3x |
- coord_cartesian(clip = "off", ylim = c(0.5, nrow(at_risk_tbl)))+ }, grobs, seq_along(grobs) * 2 - 1) |
| 519 | -9x | +|||
| 79 | +
- gg_at_risk <- suppressMessages(+ |
|||
| 520 | -9x | +80 | +3x |
- gg_at_risk ++ grobs_mainvp <- grid::gTree( |
| 521 | -9x | +81 | +3x |
- scale_x_continuous(expand = c(0.025, 0), breaks = seq_along(at_risk_tbl) - 0.5, labels = xticks) ++ children = do.call(grid::gList, nested_grobs), |
| 522 | -9x | +82 | +3x |
- scale_y_continuous(labels = rev(levels(annot_tbl$strata)), breaks = seq_len(nrow(at_risk_tbl)))+ vp = main_vp |
| 523 | +83 |
- )+ ) |
||
| 524 | +84 | |||
| 525 | -9x | +85 | +3x |
- if (!as_list) {
+ grid::gTree( |
| 526 | -8x | +86 | +3x |
- gg_plt <- cowplot::plot_grid(+ children = grid::gList(grobs_mainvp), |
| 527 | -8x | +87 | +3x |
- gg_plt,+ vp = vp, |
| 528 | -8x | +88 | +3x |
- gg_at_risk,+ gp = gp, |
| 529 | -8x | +89 | +3x |
- align = "v",+ name = name |
| 530 | -8x | +|||
| 90 | +
- axis = "tblr",+ ) |
|||
| 531 | -8x | +|||
| 91 | +
- ncol = 1,+ } |
|||
| 532 | -8x | +|||
| 92 | +
- rel_heights = c(rel_height_plot, 1 - rel_height_plot)+ |
|||
| 533 | +93 |
- )+ #' Arrange multiple grobs |
||
| 534 | +94 |
- }+ #' |
||
| 535 | +95 |
- }+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 536 | +96 |
-
+ #' |
||
| 537 | +97 |
- # add median survival time annotation table+ #' Arrange grobs as a new grob with `n * m (rows * cols)` layout. |
||
| 538 | -10x | +|||
| 98 | +
- if (annot_surv_med) {
+ #' |
|||
| 539 | -8x | +|||
| 99 | +
- surv_med_tbl <- h_tbl_median_surv(fit_km = fit_km, armval = armval)+ #' @inheritParams stack_grobs |
|||
| 540 | -8x | +|||
| 100 | +
- bg_fill <- if (isTRUE(control_annot_surv_med[["fill"]])) "#00000020" else control_annot_surv_med[["fill"]]+ #' @param ncol (`integer(1)`)\cr number of columns in layout. |
|||
| 541 | +101 |
-
+ #' @param nrow (`integer(1)`)\cr number of rows in layout. |
||
| 542 | -8x | +|||
| 102 | +
- gg_surv_med <- df2gg(surv_med_tbl, font_size = font_size, colwidths = c(1, 1, 2), bg_fill = bg_fill) ++ #' @param padding_ht (`grid::unit`)\cr unit of length 1, vertical space between each grob. |
|||
| 543 | -8x | +|||
| 103 | +
- theme(+ #' @param padding_wt (`grid::unit`)\cr unit of length 1, horizontal space between each grob. |
|||
| 544 | -8x | +|||
| 104 | +
- axis.text.y = element_text(size = font_size, face = "italic", hjust = 1),+ #' |
|||
| 545 | -8x | +|||
| 105 | +
- plot.margin = margin(0, 2, 0, 5)+ #' @return A `grob`. |
|||
| 546 | +106 |
- ) ++ #' |
||
| 547 | -8x | +|||
| 107 | +
- coord_cartesian(clip = "off", ylim = c(0.5, nrow(surv_med_tbl) + 1.5))+ #' @examples |
|||
| 548 | -8x | +|||
| 108 | +
- gg_surv_med <- suppressMessages(+ #' library(grid) |
|||
| 549 | -8x | +|||
| 109 | +
- gg_surv_med ++ #' |
|||
| 550 | -8x | +|||
| 110 | +
- scale_x_continuous(expand = c(0.025, 0)) ++ #' \donttest{
|
|||
| 551 | -8x | +|||
| 111 | +
- scale_y_continuous(labels = rev(rownames(surv_med_tbl)), breaks = seq_len(nrow(surv_med_tbl)))+ #' num <- lapply(1:9, textGrob) |
|||
| 552 | +112 |
- )+ #' grid::grid.newpage() |
||
| 553 | +113 |
-
+ #' grid.draw(arrange_grobs(grobs = num, ncol = 2)) |
||
| 554 | -8x | +|||
| 114 | +
- gg_plt <- cowplot::ggdraw(gg_plt) ++ #' |
|||
| 555 | -8x | +|||
| 115 | +
- cowplot::draw_plot(+ #' showViewport() |
|||
| 556 | -8x | +|||
| 116 | +
- gg_surv_med,+ #' |
|||
| 557 | -8x | +|||
| 117 | +
- control_annot_surv_med[["x"]],+ #' g1 <- circleGrob(gp = gpar(col = "blue")) |
|||
| 558 | -8x | +|||
| 118 | +
- control_annot_surv_med[["y"]],+ #' g2 <- circleGrob(gp = gpar(col = "red")) |
|||
| 559 | -8x | +|||
| 119 | +
- width = control_annot_surv_med[["w"]],+ #' g3 <- textGrob("TEST TEXT")
|
|||
| 560 | -8x | +|||
| 120 | +
- height = control_annot_surv_med[["h"]],+ #' grid::grid.newpage() |
|||
| 561 | -8x | +|||
| 121 | +
- vjust = 0.5,+ #' grid.draw(arrange_grobs(g1, g2, g3, nrow = 2)) |
|||
| 562 | -8x | +|||
| 122 | +
- hjust = 0.5+ #' |
|||
| 563 | +123 |
- )+ #' showViewport() |
||
| 564 | +124 |
- }+ #' |
||
| 565 | +125 |
-
+ #' grid::grid.newpage() |
||
| 566 | +126 |
- # add coxph annotation table+ #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 3)) |
||
| 567 | -10x | +|||
| 127 | +
- if (annot_coxph) {
+ #' |
|||
| 568 | -1x | +|||
| 128 | +
- coxph_tbl <- h_tbl_coxph_pairwise(+ #' grid::grid.newpage() |
|||
| 569 | -1x | +|||
| 129 | +
- df = df,+ #' grid::pushViewport(grid::viewport(layout = grid::grid.layout(1, 2))) |
|||
| 570 | -1x | +|||
| 130 | +
- variables = variables,+ #' vp1 <- grid::viewport(layout.pos.row = 1, layout.pos.col = 2) |
|||
| 571 | -1x | +|||
| 131 | +
- ref_group_coxph = ref_group_coxph,+ #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 2, vp = vp1)) |
|||
| 572 | -1x | +|||
| 132 | +
- control_coxph_pw = control_coxph_pw,+ #' |
|||
| 573 | -1x | +|||
| 133 | +
- annot_coxph_ref_lbls = control_annot_coxph[["ref_lbls"]]+ #' showViewport() |
|||
| 574 | +134 |
- )+ #' } |
||
| 575 | -1x | +|||
| 135 | +
- bg_fill <- if (isTRUE(control_annot_coxph[["fill"]])) "#00000020" else control_annot_coxph[["fill"]]+ #' @export |
|||
| 576 | +136 |
-
+ arrange_grobs <- function(..., |
||
| 577 | -1x | +|||
| 137 | +
- gg_coxph <- df2gg(coxph_tbl, font_size = font_size, colwidths = c(1.1, 1, 3), bg_fill = bg_fill) ++ grobs = list(...), |
|||
| 578 | -1x | +|||
| 138 | +
- theme(+ ncol = NULL, nrow = NULL, |
|||
| 579 | -1x | +|||
| 139 | +
- axis.text.y = element_text(size = font_size, face = "italic", hjust = 1),+ padding_ht = grid::unit(2, "line"), |
|||
| 580 | -1x | +|||
| 140 | +
- plot.margin = margin(0, 2, 0, 5)+ padding_wt = grid::unit(2, "line"), |
|||
| 581 | +141 |
- ) ++ vp = NULL, |
||
| 582 | -1x | +|||
| 142 | +
- coord_cartesian(clip = "off", ylim = c(0.5, nrow(coxph_tbl) + 1.5))+ gp = NULL,+ |
+ |||
| 143 | ++ |
+ name = NULL) {
|
||
| 583 | -1x | +144 | +5x |
- gg_coxph <- suppressMessages(+ lifecycle::deprecate_warn( |
| 584 | -1x | +145 | +5x |
- gg_coxph ++ "0.9.4", |
| 585 | -1x | +146 | +5x |
- scale_x_continuous(expand = c(0.025, 0)) ++ "arrange_grobs()", |
| 586 | -1x | +147 | +5x |
- scale_y_continuous(labels = rev(rownames(coxph_tbl)), breaks = seq_len(nrow(coxph_tbl)))+ details = "`tern` plotting functions no longer generate `grob` objects." |
| 587 | +148 |
- )+ ) |
||
| 588 | +149 | |||
| 589 | -1x | -
- gg_plt <- cowplot::ggdraw(gg_plt) +- |
- ||
| 590 | -1x | -
- cowplot::draw_plot(- |
- ||
| 591 | -1x | -
- gg_coxph,- |
- ||
| 592 | -1x | +150 | +5x |
- control_annot_coxph[["x"]],+ checkmate::assert_true( |
| 593 | -1x | +151 | +5x |
- control_annot_coxph[["y"]],+ all(vapply(grobs, grid::is.grob, logical(1))) |
| 594 | -1x | +|||
| 152 | +
- width = control_annot_coxph[["w"]],+ ) |
|||
| 595 | -1x | +|||
| 153 | +
- height = control_annot_coxph[["h"]],+ |
|||
| 596 | -1x | +154 | +5x |
- vjust = 0.5,+ if (length(grobs) == 1) {
|
| 597 | +155 | 1x |
- hjust = 0.5- |
- |
| 598 | -- |
- )+ return(grobs[[1]]) |
||
| 599 | +156 |
} |
||
| 600 | +157 | |||
| 601 | -10x | +158 | +4x |
- if (as_list) {
+ if (is.null(ncol) && is.null(nrow)) {
|
| 602 | +159 | 1x |
- list(plot = gg_plt, table = gg_at_risk)+ ncol <- 1 |
|
| 603 | -+ | |||
| 160 | +1x |
- } else {
+ nrow <- ceiling(length(grobs) / ncol) |
||
| 604 | -9x | +161 | +3x |
- gg_plt+ } else if (!is.null(ncol) && is.null(nrow)) {
|
| 605 | -+ | |||
| 162 | +1x |
- }+ nrow <- ceiling(length(grobs) / ncol) |
||
| 606 | -+ | |||
| 163 | +2x |
- }+ } else if (is.null(ncol) && !is.null(nrow)) {
|
| 1 | -+ | |||
| 164 | +! |
- #' Difference test for two proportions+ ncol <- ceiling(length(grobs) / nrow) |
||
| 2 | +165 |
- #'+ } |
||
| 3 | +166 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 4 | -+ | |||
| 167 | +4x |
- #'+ if (ncol * nrow < length(grobs)) {
|
||
| 5 | -+ | |||
| 168 | +1x |
- #' The analyze function [test_proportion_diff()] creates a layout element to test the difference between two+ stop("specififed ncol and nrow are not enough for arranging the grobs ")
|
||
| 6 | +169 |
- #' proportions. The primary analysis variable, `vars`, indicates whether a response has occurred for each record. See+ } |
||
| 7 | +170 |
- #' the `method` parameter for options of methods to use to calculate the p-value. Additionally, a stratification+ |
||
| 8 | -+ | |||
| 171 | +3x |
- #' variable can be supplied via the `strata` element of the `variables` argument.+ if (ncol == 1) {
|
||
| 9 | -+ | |||
| 172 | +2x |
- #'+ return(stack_grobs(grobs = grobs, padding = padding_ht, vp = vp, gp = gp, name = name)) |
||
| 10 | +173 |
- #' @inheritParams argument_convention+ } |
||
| 11 | +174 |
- #' @param method (`string`)\cr one of `chisq`, `cmh`, `fisher`, or `schouten`; specifies the test used+ |
||
| 12 | -+ | |||
| 175 | +1x |
- #' to calculate the p-value.+ n_col <- 2 * ncol - 1 |
||
| 13 | -+ | |||
| 176 | +1x |
- #' @param .stats (`character`)\cr statistics to select for the table.+ n_row <- 2 * nrow - 1 |
||
| 14 | -+ | |||
| 177 | +1x |
- #'+ hts <- lapply( |
||
| 15 | -+ | |||
| 178 | +1x |
- #' Options are: ``r shQuote(get_stats("test_proportion_diff"))``
+ seq(1, n_row), |
||
| 16 | -+ | |||
| 179 | +1x |
- #'+ function(i) {
|
||
| 17 | -+ | |||
| 180 | +5x |
- #' @seealso [h_prop_diff_test]+ if (i %% 2 != 0) {
|
||
| 18 | -+ | |||
| 181 | +3x |
- #'+ grid::unit(1, "null") |
||
| 19 | +182 |
- #' @name prop_diff_test+ } else {
|
||
| 20 | -+ | |||
| 183 | +2x |
- #' @order 1+ padding_ht |
||
| 21 | +184 |
- NULL+ } |
||
| 22 | +185 |
-
+ } |
||
| 23 | +186 |
- #' @describeIn prop_diff_test Statistics function which tests the difference between two proportions.+ ) |
||
| 24 | -+ | |||
| 187 | +1x |
- #'+ hts <- do.call(grid::unit.c, hts) |
||
| 25 | +188 |
- #' @return+ |
||
| 26 | -+ | |||
| 189 | +1x |
- #' * `s_test_proportion_diff()` returns a named `list` with a single item `pval` with an attribute `label`+ wts <- lapply( |
||
| 27 | -+ | |||
| 190 | +1x |
- #' describing the method used. The p-value tests the null hypothesis that proportions in two groups are the same.+ seq(1, n_col), |
||
| 28 | -+ | |||
| 191 | +1x |
- #'+ function(i) {
|
||
| 29 | -+ | |||
| 192 | +5x |
- #' @keywords internal+ if (i %% 2 != 0) {
|
||
| 30 | -+ | |||
| 193 | +3x |
- s_test_proportion_diff <- function(df,+ grid::unit(1, "null") |
||
| 31 | +194 |
- .var,+ } else {
|
||
| 32 | -+ | |||
| 195 | +2x |
- .ref_group,+ padding_wt |
||
| 33 | +196 |
- .in_ref_col,+ } |
||
| 34 | +197 |
- variables = list(strata = NULL),+ } |
||
| 35 | +198 |
- method = c("chisq", "schouten", "fisher", "cmh")) {
- |
- ||
| 36 | -45x | -
- method <- match.arg(method)+ ) |
||
| 37 | -45x | +199 | +1x |
- y <- list(pval = "")+ wts <- do.call(grid::unit.c, wts) |
| 38 | +200 | |||
| 39 | -45x | +201 | +1x |
- if (!.in_ref_col) {
+ main_vp <- grid::viewport( |
| 40 | -45x | +202 | +1x |
- assert_df_with_variables(df, list(rsp = .var))+ layout = grid::grid.layout(nrow = n_row, ncol = n_col, widths = wts, heights = hts) |
| 41 | -45x | +|||
| 203 | +
- assert_df_with_variables(.ref_group, list(rsp = .var))+ ) |
|||
| 42 | -45x | +|||
| 204 | +
- rsp <- factor(+ |
|||
| 43 | -45x | +205 | +1x |
- c(.ref_group[[.var]], df[[.var]]),+ nested_grobs <- list() |
| 44 | -45x | -
- levels = c("TRUE", "FALSE")
- |
- ||
| 45 | -+ | 206 | +1x |
- )+ k <- 0 |
| 46 | -45x | +207 | +1x |
- grp <- factor(+ for (i in seq(nrow) * 2 - 1) {
|
| 47 | -45x | +208 | +3x |
- rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
+ for (j in seq(ncol) * 2 - 1) {
|
| 48 | -45x | +209 | +9x |
- levels = c("ref", "Not-ref")
+ k <- k + 1 |
| 49 | -+ | |||
| 210 | +9x |
- )+ if (k <= length(grobs)) {
|
||
| 50 | -+ | |||
| 211 | +9x |
-
+ nested_grobs <- c( |
||
| 51 | -45x | +212 | +9x |
- if (!is.null(variables$strata) || method == "cmh") {
+ nested_grobs, |
| 52 | -12x | +213 | +9x |
- strata <- variables$strata+ list(grid::gTree( |
| 53 | -12x | +214 | +9x |
- checkmate::assert_false(is.null(strata))+ children = grid::gList(grobs[[k]]), |
| 54 | -12x | +215 | +9x |
- strata_vars <- stats::setNames(as.list(strata), strata)+ vp = grid::viewport(layout.pos.row = i, layout.pos.col = j) |
| 55 | -12x | +|||
| 216 | +
- assert_df_with_variables(df, strata_vars)+ )) |
|||
| 56 | -12x | +|||
| 217 | +
- assert_df_with_variables(.ref_group, strata_vars)+ ) |
|||
| 57 | -12x | +|||
| 218 | +
- strata <- c(interaction(.ref_group[strata]), interaction(df[strata]))+ } |
|||
| 58 | +219 |
} |
||
| 59 | +220 |
-
+ } |
||
| 60 | -45x | +221 | +1x |
- tbl <- switch(method,+ grobs_mainvp <- grid::gTree( |
| 61 | -45x | +222 | +1x |
- cmh = table(grp, rsp, strata),+ children = do.call(grid::gList, nested_grobs), |
| 62 | -45x | +223 | +1x |
- table(grp, rsp)+ vp = main_vp |
| 63 | +224 |
- )+ ) |
||
| 64 | +225 | |||
| 65 | -45x | +226 | +1x |
- y$pval <- switch(method,+ grid::gTree( |
| 66 | -45x | +227 | +1x |
- chisq = prop_chisq(tbl),+ children = grid::gList(grobs_mainvp), |
| 67 | -45x | +228 | +1x |
- cmh = prop_cmh(tbl),+ vp = vp, |
| 68 | -45x | +229 | +1x |
- fisher = prop_fisher(tbl),+ gp = gp, |
| 69 | -45x | +230 | +1x |
- schouten = prop_schouten(tbl)+ name = name |
| 70 | +231 |
- )+ ) |
||
| 71 | +232 |
- }+ } |
||
| 72 | +233 | |||
| 73 | -45x | -
- y$pval <- formatters::with_label(y$pval, d_test_proportion_diff(method))- |
- ||
| 74 | -45x | -
- y- |
- ||
| 75 | +234 |
- }+ #' Draw `grob` |
||
| 76 | +235 |
-
+ #' |
||
| 77 | +236 |
- #' Description of the difference test between two proportions+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 78 | +237 |
#' |
||
| 79 | +238 |
- #' @description `r lifecycle::badge("stable")`
+ #' Draw grob on device page. |
||
| 80 | +239 |
#' |
||
| 81 | +240 |
- #' This is an auxiliary function that describes the analysis in `s_test_proportion_diff`.+ #' @param grob (`grob`)\cr grid object. |
||
| 82 | +241 |
- #'+ #' @param newpage (`flag`)\cr draw on a new page. |
||
| 83 | +242 |
- #' @inheritParams s_test_proportion_diff+ #' @param vp (`viewport` or `NULL`)\cr a [viewport()] object (or `NULL`). |
||
| 84 | +243 |
#' |
||
| 85 | +244 |
- #' @return A `string` describing the test from which the p-value is derived.+ #' @return A `grob`. |
||
| 86 | +245 |
#' |
||
| 87 | +246 |
- #' @export+ #' @examples |
||
| 88 | +247 |
- d_test_proportion_diff <- function(method) {
+ #' library(dplyr) |
||
| 89 | -59x | +|||
| 248 | +
- checkmate::assert_string(method)+ #' library(grid) |
|||
| 90 | -59x | +|||
| 249 | +
- meth_part <- switch(method,+ #' |
|||
| 91 | -59x | +|||
| 250 | +
- "schouten" = "Chi-Squared Test with Schouten Correction",+ #' \donttest{
|
|||
| 92 | -59x | +|||
| 251 | +
- "chisq" = "Chi-Squared Test",+ #' rect <- rectGrob(width = grid::unit(0.5, "npc"), height = grid::unit(0.5, "npc")) |
|||
| 93 | -59x | +|||
| 252 | +
- "cmh" = "Cochran-Mantel-Haenszel Test",+ #' rect %>% draw_grob(vp = grid::viewport(angle = 45)) |
|||
| 94 | -59x | +|||
| 253 | +
- "fisher" = "Fisher's Exact Test",+ #' |
|||
| 95 | -59x | +|||
| 254 | +
- stop(paste(method, "does not have a description"))+ #' num <- lapply(1:10, textGrob) |
|||
| 96 | +255 |
- )+ #' num %>% |
||
| 97 | -59x | +|||
| 256 | +
- paste0("p-value (", meth_part, ")")
+ #' arrange_grobs(grobs = .) %>% |
|||
| 98 | +257 |
- }+ #' draw_grob() |
||
| 99 | +258 |
-
+ #' showViewport() |
||
| 100 | +259 |
- #' @describeIn prop_diff_test Formatted analysis function which is used as `afun` in `test_proportion_diff()`.+ #' } |
||
| 101 | +260 |
#' |
||
| 102 | +261 |
- #' @return+ #' @export |
||
| 103 | +262 |
- #' * `a_test_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()].+ draw_grob <- function(grob, newpage = TRUE, vp = NULL) {
|
||
| 104 | -+ | |||
| 263 | +3x |
- #'+ lifecycle::deprecate_warn( |
||
| 105 | -+ | |||
| 264 | +3x |
- #' @keywords internal+ "0.9.4", |
||
| 106 | -+ | |||
| 265 | +3x |
- a_test_proportion_diff <- make_afun(+ "draw_grob()", |
||
| 107 | -+ | |||
| 266 | +3x |
- s_test_proportion_diff,+ details = "`tern` plotting functions no longer generate `grob` objects." |
||
| 108 | +267 |
- .formats = c(pval = "x.xxxx | (<0.0001)"),+ ) |
||
| 109 | +268 |
- .indent_mods = c(pval = 1L)+ |
||
| 110 | -+ | |||
| 269 | +3x |
- )+ if (newpage) {
|
||
| 111 | -+ | |||
| 270 | +3x |
-
+ grid::grid.newpage() |
||
| 112 | +271 |
- #' @describeIn prop_diff_test Layout-creating function which can take statistics function arguments+ } |
||
| 113 | -+ | |||
| 272 | +3x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ if (!is.null(vp)) {
|
||
| 114 | -+ | |||
| 273 | +1x |
- #'+ grid::pushViewport(vp) |
||
| 115 | +274 |
- #' @return+ } |
||
| 116 | -+ | |||
| 275 | +3x |
- #' * `test_proportion_diff()` returns a layout object suitable for passing to further layouting functions,+ grid::grid.draw(grob) |
||
| 117 | +276 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ } |
||
| 118 | +277 |
- #' the statistics from `s_test_proportion_diff()` to the table layout.+ |
||
| 119 | +278 |
- #'+ tern_grob <- function(x) {
|
||
| 120 | -+ | |||
| 279 | +! |
- #' @examples+ class(x) <- unique(c("ternGrob", class(x)))
|
||
| 121 | -+ | |||
| 280 | +! |
- #' dta <- data.frame(+ x |
||
| 122 | +281 |
- #' rsp = sample(c(TRUE, FALSE), 100, TRUE),+ } |
||
| 123 | +282 |
- #' grp = factor(rep(c("A", "B"), each = 50)),
+
|
||
| 124 | +283 |
- #' strata = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20))
+ #' @keywords internal |
||
| 125 | +284 |
- #' )+ print.ternGrob <- function(x, ...) {
|
||
| 126 | -+ | |||
| 285 | +! |
- #'+ grid::grid.newpage()+ |
+ ||
| 286 | +! | +
+ grid::grid.draw(x) |
||
| 127 | +287 |
- #' # With `rtables` pipelines.+ } |
| 128 | +1 |
- #' l <- basic_table() %>%+ #' Tabulate binary response by subgroup |
||
| 129 | +2 |
- #' split_cols_by(var = "grp", ref_group = "B") %>%+ #' |
||
| 130 | +3 |
- #' test_proportion_diff(+ #' @description `r lifecycle::badge("stable")`
|
||
| 131 | +4 |
- #' vars = "rsp",+ #' |
||
| 132 | +5 |
- #' method = "cmh", variables = list(strata = "strata")+ #' The [tabulate_rsp_subgroups()] function creates a layout element to tabulate binary response by subgroup, returning |
||
| 133 | +6 |
- #' )+ #' statistics including response rate and odds ratio for each population subgroup. The table is created from `df`, a |
||
| 134 | +7 |
- #'+ #' list of data frames returned by [extract_rsp_subgroups()], with the statistics to include specified via the `vars` |
||
| 135 | +8 |
- #' build_table(l, df = dta)+ #' parameter. |
||
| 136 | +9 |
#' |
||
| 137 | +10 |
- #' @export+ #' A forest plot can be created from the resulting table using the [g_forest()] function. |
||
| 138 | +11 |
- #' @order 2+ #' |
||
| 139 | +12 |
- test_proportion_diff <- function(lyt,+ #' @inheritParams extract_rsp_subgroups |
||
| 140 | +13 |
- vars,+ #' @inheritParams argument_convention |
||
| 141 | +14 |
- variables = list(strata = NULL),+ #' |
||
| 142 | +15 |
- method = c("chisq", "schouten", "fisher", "cmh"),
+ #' @details These functions create a layout starting from a data frame which contains |
||
| 143 | +16 |
- na_str = default_na_str(),+ #' the required statistics. Tables typically used as part of forest plot. |
||
| 144 | +17 |
- nested = TRUE,+ #' |
||
| 145 | +18 |
- ...,+ #' @seealso [extract_rsp_subgroups()] |
||
| 146 | +19 |
- var_labels = vars,+ #' |
||
| 147 | +20 |
- show_labels = "hidden",+ #' @examples |
||
| 148 | +21 |
- table_names = vars,+ #' library(dplyr) |
||
| 149 | +22 |
- .stats = NULL,+ #' library(forcats) |
||
| 150 | +23 |
- .formats = NULL,+ #' |
||
| 151 | +24 |
- .labels = NULL,+ #' adrs <- tern_ex_adrs |
||
| 152 | +25 |
- .indent_mods = NULL) {
+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 153 | -6x | +|||
| 26 | +
- extra_args <- list(variables = variables, method = method, ...)+ #' |
|||
| 154 | +27 |
-
+ #' adrs_f <- adrs %>% |
||
| 155 | -6x | +|||
| 28 | +
- afun <- make_afun(+ #' filter(PARAMCD == "BESRSPI") %>% |
|||
| 156 | -6x | +|||
| 29 | +
- a_test_proportion_diff,+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
|
|||
| 157 | -6x | +|||
| 30 | +
- .stats = .stats,+ #' droplevels() %>% |
|||
| 158 | -6x | +|||
| 31 | +
- .formats = .formats,+ #' mutate( |
|||
| 159 | -6x | +|||
| 32 | +
- .labels = .labels,+ #' # Reorder levels of factor to make the placebo group the reference arm. |
|||
| 160 | -6x | +|||
| 33 | +
- .indent_mods = .indent_mods+ #' ARM = fct_relevel(ARM, "B: Placebo"), |
|||
| 161 | +34 |
- )+ #' rsp = AVALC == "CR" |
||
| 162 | -6x | +|||
| 35 | +
- analyze(+ #' ) |
|||
| 163 | -6x | +|||
| 36 | +
- lyt,+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
|||
| 164 | -6x | +|||
| 37 | +
- vars,+ #' |
|||
| 165 | -6x | +|||
| 38 | +
- afun = afun,+ #' # Unstratified analysis. |
|||
| 166 | -6x | +|||
| 39 | +
- var_labels = var_labels,+ #' df <- extract_rsp_subgroups( |
|||
| 167 | -6x | +|||
| 40 | +
- na_str = na_str,+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
|||
| 168 | -6x | +|||
| 41 | +
- nested = nested,+ #' data = adrs_f |
|||
| 169 | -6x | +|||
| 42 | +
- extra_args = extra_args,+ #' ) |
|||
| 170 | -6x | +|||
| 43 | +
- show_labels = show_labels,+ #' df |
|||
| 171 | -6x | +|||
| 44 | +
- table_names = table_names+ #' |
|||
| 172 | +45 |
- )+ #' # Stratified analysis. |
||
| 173 | +46 |
- }+ #' df_strat <- extract_rsp_subgroups( |
||
| 174 | +47 |
-
+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2"), strata = "STRATA1"),
|
||
| 175 | +48 |
- #' Helper functions to test proportion differences+ #' data = adrs_f |
||
| 176 | +49 |
- #'+ #' ) |
||
| 177 | +50 |
- #' Helper functions to implement various tests on the difference between two proportions.+ #' df_strat |
||
| 178 | +51 |
#' |
||
| 179 | +52 |
- #' @param tbl (`matrix`)\cr matrix with two groups in rows and the binary response (`TRUE`/`FALSE`) in columns.+ #' # Grouping of the BMRKR2 levels. |
||
| 180 | +53 |
- #'+ #' df_grouped <- extract_rsp_subgroups( |
||
| 181 | +54 |
- #' @return A p-value.+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
||
| 182 | +55 |
- #'+ #' data = adrs_f, |
||
| 183 | +56 |
- #' @seealso [prop_diff_test()] for implementation of these helper functions.+ #' groups_lists = list( |
||
| 184 | +57 |
- #'+ #' BMRKR2 = list( |
||
| 185 | +58 |
- #' @name h_prop_diff_test+ #' "low" = "LOW", |
||
| 186 | +59 |
- NULL+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 187 | +60 |
-
+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 188 | +61 |
- #' @describeIn h_prop_diff_test Performs Chi-Squared test. Internally calls [stats::prop.test()].+ #' ) |
||
| 189 | +62 |
- #'+ #' ) |
||
| 190 | +63 |
- #' @keywords internal+ #' ) |
||
| 191 | +64 |
- prop_chisq <- function(tbl) {
+ #' df_grouped |
||
| 192 | -41x | +|||
| 65 | +
- checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)+ #' |
|||
| 193 | -41x | +|||
| 66 | +
- tbl <- tbl[, c("TRUE", "FALSE")]
+ #' @name response_subgroups |
|||
| 194 | -41x | +|||
| 67 | +
- if (any(colSums(tbl) == 0)) {
+ #' @order 1 |
|||
| 195 | -2x | +|||
| 68 | +
- return(1)+ NULL |
|||
| 196 | +69 |
- }+ |
||
| 197 | -39x | +|||
| 70 | +
- stats::prop.test(tbl, correct = FALSE)$p.value+ #' Prepare response data for population subgroups in data frames |
|||
| 198 | +71 |
- }+ #' |
||
| 199 | +72 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 200 | +73 |
- #' @describeIn h_prop_diff_test Performs stratified Cochran-Mantel-Haenszel test. Internally calls+ #' |
||
| 201 | +74 |
- #' [stats::mantelhaen.test()]. Note that strata with less than two observations are automatically discarded.+ #' Prepares response rates and odds ratios for population subgroups in data frames. Simple wrapper |
||
| 202 | +75 |
- #'+ #' for [h_odds_ratio_subgroups_df()] and [h_proportion_subgroups_df()]. Result is a list of two |
||
| 203 | +76 |
- #' @param ary (`array`, 3 dimensions)\cr array with two groups in rows, the binary response+ #' `data.frames`: `prop` and `or`. `variables` corresponds to the names of variables found in `data`, |
||
| 204 | +77 |
- #' (`TRUE`/`FALSE`) in columns, and the strata in the third dimension.+ #' passed as a named `list` and requires elements `rsp`, `arm` and optionally `subgroups` and `strata`. |
||
| 205 | +78 |
- #'+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
||
| 206 | +79 |
- #' @keywords internal+ #' |
||
| 207 | +80 |
- prop_cmh <- function(ary) {
+ #' @inheritParams argument_convention |
||
| 208 | -16x | +|||
| 81 | +
- checkmate::assert_array(ary)+ #' @inheritParams response_subgroups |
|||
| 209 | -16x | +|||
| 82 | +
- checkmate::assert_integer(c(ncol(ary), nrow(ary)), lower = 2, upper = 2)+ #' @param label_all (`string`)\cr label for the total population analysis. |
|||
| 210 | -16x | +|||
| 83 | +
- checkmate::assert_integer(length(dim(ary)), lower = 3, upper = 3)+ #' |
|||
| 211 | -16x | +|||
| 84 | +
- strata_sizes <- apply(ary, MARGIN = 3, sum)+ #' @return A named list of two elements: |
|||
| 212 | -16x | +|||
| 85 | +
- if (any(strata_sizes < 5)) {
+ #' * `prop`: A `data.frame` containing columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`, `var`, |
|||
| 213 | -1x | +|||
| 86 | +
- warning("<5 data points in some strata. CMH test may be incorrect.")
+ #' `var_label`, and `row_type`. |
|||
| 214 | -1x | +|||
| 87 | +
- ary <- ary[, , strata_sizes > 1]+ #' * `or`: A `data.frame` containing columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`, |
|||
| 215 | +88 |
- }+ #' `subgroup`, `var`, `var_label`, and `row_type`. |
||
| 216 | +89 |
-
+ #' |
||
| 217 | -16x | +|||
| 90 | +
- stats::mantelhaen.test(ary, correct = FALSE)$p.value+ #' @seealso [response_subgroups] |
|||
| 218 | +91 |
- }+ #' |
||
| 219 | +92 |
-
+ #' @export |
||
| 220 | +93 |
- #' @describeIn h_prop_diff_test Performs the Chi-Squared test with Schouten correction.+ extract_rsp_subgroups <- function(variables, |
||
| 221 | +94 |
- #'+ data, |
||
| 222 | +95 |
- #' @seealso Schouten correction is based upon \insertCite{Schouten1980-kd;textual}{tern}.
+ groups_lists = list(), |
||
| 223 | +96 |
- #'+ conf_level = 0.95, |
||
| 224 | +97 |
- #' @keywords internal+ method = NULL, |
||
| 225 | +98 |
- prop_schouten <- function(tbl) {
+ label_all = "All Patients") {
|
||
| 226 | -100x | +99 | +14x |
- checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)+ if ("strat" %in% names(variables)) {
|
| 227 | -100x | +|||
| 100 | +! |
- tbl <- tbl[, c("TRUE", "FALSE")]
+ warning( |
||
| 228 | -100x | +|||
| 101 | +! |
- if (any(colSums(tbl) == 0)) {
+ "Warning: the `strat` element name of the `variables` list argument to `extract_rsp_subgroups() ", |
||
| 229 | -1x | +|||
| 102 | +! |
- return(1)+ "was deprecated in tern 0.9.4.\n ",+ |
+ ||
| 103 | +! | +
+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 230 | +104 | ++ |
+ )+ |
+ |
| 105 | +! | +
+ variables[["strata"]] <- variables[["strat"]]+ |
+ ||
| 106 |
} |
|||
| 231 | +107 | |||
| 232 | -99x | +108 | +14x |
- n <- sum(tbl)+ df_prop <- h_proportion_subgroups_df( |
| 233 | -99x | +109 | +14x |
- n1 <- sum(tbl[1, ])+ variables, |
| 234 | -99x | +110 | +14x |
- n2 <- sum(tbl[2, ])+ data,+ |
+
| 111 | +14x | +
+ groups_lists = groups_lists,+ |
+ ||
| 112 | +14x | +
+ label_all = label_all |
||
| 235 | +113 |
-
+ ) |
||
| 236 | -99x | +114 | +14x |
- ad <- diag(tbl)+ df_or <- h_odds_ratio_subgroups_df( |
| 237 | -99x | +115 | +14x |
- bc <- diag(apply(tbl, 2, rev))+ variables, |
| 238 | -99x | +116 | +14x |
- ac <- tbl[, 1]+ data, |
| 239 | -99x | +117 | +14x |
- bd <- tbl[, 2]+ groups_lists = groups_lists, |
| 240 | -+ | |||
| 118 | +14x |
-
+ conf_level = conf_level, |
||
| 241 | -99x | +119 | +14x |
- t_schouten <- (n - 1) *+ method = method, |
| 242 | -99x | +120 | +14x |
- (abs(prod(ad) - prod(bc)) - 0.5 * min(n1, n2))^2 /+ label_all = label_all |
| 243 | -99x | +|||
| 121 | +
- (n1 * n2 * sum(ac) * sum(bd))+ ) |
|||
| 244 | +122 | |||
| 245 | -99x | +123 | +14x |
- 1 - stats::pchisq(t_schouten, df = 1)+ list(prop = df_prop, or = df_or) |
| 246 | +124 |
} |
||
| 247 | +125 | |||
| 248 | +126 |
- #' @describeIn h_prop_diff_test Performs the Fisher's exact test. Internally calls [stats::fisher.test()].+ #' @describeIn response_subgroups Formatted analysis function which is used as `afun` in `tabulate_rsp_subgroups()`. |
||
| 249 | +127 |
#' |
||
| 250 | +128 |
- #' @keywords internal+ #' @return |
||
| 251 | +129 |
- prop_fisher <- function(tbl) {
- |
- ||
| 252 | -2x | -
- checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)+ #' * `a_response_subgroups()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 253 | -2x | +|||
| 130 | +
- tbl <- tbl[, c("TRUE", "FALSE")]
+ #' |
|||
| 254 | -2x | +|||
| 131 | +
- stats::fisher.test(tbl)$p.value+ #' @keywords internal |
|||
| 255 | +132 |
- }+ a_response_subgroups <- function(.formats = list( |
| 1 | +133 |
- #' Custom split functions+ n = "xx", # nolint start |
||
| 2 | +134 |
- #'+ n_rsp = "xx", |
||
| 3 | +135 |
- #' @description `r lifecycle::badge("stable")`
+ prop = "xx.x%", |
||
| 4 | +136 |
- #'+ n_tot = "xx", |
||
| 5 | +137 |
- #' Collection of useful functions that are expanding on the core list of functions+ or = list(format_extreme_values(2L)), |
||
| 6 | +138 |
- #' provided by `rtables`. See [rtables::custom_split_funs] and [rtables::make_split_fun()]+ ci = list(format_extreme_values_ci(2L)), |
||
| 7 | +139 |
- #' for more information on how to make a custom split function. All these functions+ pval = "x.xxxx | (<0.0001)", |
||
| 8 | +140 |
- #' work with [rtables::split_rows_by()] argument `split_fun` to modify the way the split+ riskdiff = "xx.x (xx.x - xx.x)" # nolint end |
||
| 9 | +141 |
- #' happens. For other split functions, consider consulting [`rtables::split_funcs`].+ ), |
||
| 10 | +142 |
- #'+ na_str = default_na_str()) {
|
||
| 11 | -+ | |||
| 143 | +22x |
- #' @seealso [rtables::make_split_fun()]+ checkmate::assert_list(.formats) |
||
| 12 | -+ | |||
| 144 | +22x |
- #'+ checkmate::assert_subset( |
||
| 13 | -+ | |||
| 145 | +22x |
- #' @name utils_split_funs+ names(.formats), |
||
| 14 | -+ | |||
| 146 | +22x |
- NULL+ c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval", "riskdiff")
|
||
| 15 | +147 |
-
+ ) |
||
| 16 | +148 |
- #' @describeIn utils_split_funs Split function to place reference group facet at a specific position+ |
||
| 17 | -+ | |||
| 149 | +22x |
- #' during post-processing stage.+ afun_lst <- Map( |
||
| 18 | -+ | |||
| 150 | +22x |
- #'+ function(stat, fmt, na_str) {
|
||
| 19 | -+ | |||
| 151 | +157x |
- #' @param position (`string` or `integer`)\cr position to use for the reference group facet. Can be `"first"`,+ function(df, labelstr = "", ...) {
|
||
| 20 | -+ | |||
| 152 | +349x |
- #' `"last"`, or a specific position.+ in_rows( |
||
| 21 | -+ | |||
| 153 | +349x |
- #'+ .list = as.list(df[[stat]]), |
||
| 22 | -+ | |||
| 154 | +349x |
- #' @return+ .labels = as.character(df$subgroup), |
||
| 23 | -+ | |||
| 155 | +349x |
- #' * `ref_group_position()` returns an utility function that puts the reference group+ .formats = fmt, |
||
| 24 | -+ | |||
| 156 | +349x |
- #' as first, last or at a certain position and needs to be assigned to `split_fun`.+ .format_na_strs = na_str |
||
| 25 | +157 |
- #'+ ) |
||
| 26 | +158 |
- #' @examples+ } |
||
| 27 | +159 |
- #' library(dplyr)+ }, |
||
| 28 | -+ | |||
| 160 | +22x |
- #'+ stat = names(.formats), |
||
| 29 | -+ | |||
| 161 | +22x |
- #' dat <- data.frame(+ fmt = .formats, |
||
| 30 | -+ | |||
| 162 | +22x |
- #' x = factor(letters[1:5], levels = letters[5:1]),+ na_str = na_str |
||
| 31 | +163 |
- #' y = 1:5+ ) |
||
| 32 | +164 |
- #' )+ |
||
| 33 | -+ | |||
| 165 | +22x |
- #'+ afun_lst |
||
| 34 | +166 |
- #' # With rtables layout functions+ } |
||
| 35 | +167 |
- #' basic_table() %>%+ |
||
| 36 | +168 |
- #' split_cols_by("x", ref_group = "c", split_fun = ref_group_position("last")) %>%
+ #' @describeIn response_subgroups Table-creating function which creates a table |
||
| 37 | +169 |
- #' analyze("y") %>%
+ #' summarizing binary response by subgroup. This function is a wrapper for [rtables::analyze_colvars()] |
||
| 38 | +170 |
- #' build_table(dat)+ #' and [rtables::summarize_row_groups()]. |
||
| 39 | +171 |
#' |
||
| 40 | +172 |
- #' # With tern layout funcitons+ #' @param df (`list`)\cr a list of data frames containing all analysis variables. List should be |
||
| 41 | +173 |
- #' adtte_f <- tern_ex_adtte %>%+ #' created using [extract_rsp_subgroups()]. |
||
| 42 | +174 |
- #' filter(PARAMCD == "OS") %>%+ #' @param vars (`character`)\cr the names of statistics to be reported among: |
||
| 43 | +175 |
- #' mutate(+ #' * `n`: Total number of observations per group. |
||
| 44 | +176 |
- #' AVAL = day2month(AVAL),+ #' * `n_rsp`: Number of responders per group. |
||
| 45 | +177 |
- #' is_event = CNSR == 0+ #' * `prop`: Proportion of responders. |
||
| 46 | +178 |
- #' )+ #' * `n_tot`: Total number of observations. |
||
| 47 | +179 |
- #'+ #' * `or`: Odds ratio. |
||
| 48 | +180 |
- #' basic_table() %>%+ #' * `ci` : Confidence interval of odds ratio. |
||
| 49 | +181 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM B", split_fun = ref_group_position("first")) %>%
+ #' * `pval`: p-value of the effect. |
||
| 50 | +182 |
- #' add_colcounts() %>%+ #' Note, the statistics `n_tot`, `or`, and `ci` are required. |
||
| 51 | +183 |
- #' surv_time(+ #' @param riskdiff (`list`)\cr if a risk (proportion) difference column should be added, a list of settings to apply |
||
| 52 | +184 |
- #' vars = "AVAL",+ #' within the column. See [control_riskdiff()] for details. If `NULL`, no risk difference column will be added. If |
||
| 53 | +185 |
- #' var_labels = "Survival Time (Months)",+ #' `riskdiff$arm_x` and `riskdiff$arm_y` are `NULL`, the first level of `df$prop$arm` will be used as `arm_x` and |
||
| 54 | +186 |
- #' is_event = "is_event",+ #' the second level as `arm_y`. |
||
| 55 | +187 |
- #' ) %>%+ #' |
||
| 56 | +188 |
- #' build_table(df = adtte_f)+ #' @return An `rtables` table summarizing binary response by subgroup. |
||
| 57 | +189 |
#' |
||
| 58 | +190 |
- #' basic_table() %>%+ #' @examples |
||
| 59 | +191 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM B", split_fun = ref_group_position(2)) %>%+ #' # Table with default columns |
||
| 60 | +192 |
- #' add_colcounts() %>%+ #' basic_table() %>% |
||
| 61 | +193 |
- #' surv_time(+ #' tabulate_rsp_subgroups(df) |
||
| 62 | +194 |
- #' vars = "AVAL",+ #' |
||
| 63 | +195 |
- #' var_labels = "Survival Time (Months)",+ #' # Table with selected columns |
||
| 64 | +196 |
- #' is_event = "is_event",+ #' basic_table() %>% |
||
| 65 | +197 |
- #' ) %>%+ #' tabulate_rsp_subgroups( |
||
| 66 | +198 |
- #' build_table(df = adtte_f)+ #' df = df, |
||
| 67 | +199 |
- #'+ #' vars = c("n_tot", "n", "n_rsp", "prop", "or", "ci")
|
||
| 68 | +200 |
- #' @export+ #' ) |
||
| 69 | +201 |
- ref_group_position <- function(position = "first") {
- |
- ||
| 70 | -20x | -
- make_split_fun(- |
- ||
| 71 | -20x | -
- post = list(+ #' |
||
| 72 | -20x | +|||
| 202 | +
- function(splret, spl, fulldf) {
+ #' # Table with risk difference column added |
|||
| 73 | -57x | +|||
| 203 | +
- if (!"ref_group_value" %in% methods::slotNames(spl)) {
+ #' basic_table() %>% |
|||
| 74 | -1x | +|||
| 204 | +
- stop("Reference group is undefined.")
+ #' tabulate_rsp_subgroups( |
|||
| 75 | +205 |
- }+ #' df, |
||
| 76 | +206 |
-
+ #' riskdiff = control_riskdiff( |
||
| 77 | -56x | +|||
| 207 | +
- spl_var <- rtables:::spl_payload(spl)+ #' arm_x = levels(df$prop$arm)[1], |
|||
| 78 | -56x | +|||
| 208 | +
- fulldf[[spl_var]] <- factor(fulldf[[spl_var]])+ #' arm_y = levels(df$prop$arm)[2] |
|||
| 79 | -56x | +|||
| 209 | +
- init_lvls <- levels(fulldf[[spl_var]])+ #' ) |
|||
| 80 | +210 |
-
+ #' ) |
||
| 81 | -56x | +|||
| 211 | +
- if (!all(names(splret$values) %in% init_lvls)) {
+ #' |
|||
| 82 | -! | +|||
| 212 | +
- stop("This split function does not work with combination facets.")
+ #' @export |
|||
| 83 | +213 |
- }+ #' @order 2 |
||
| 84 | +214 |
-
+ tabulate_rsp_subgroups <- function(lyt, |
||
| 85 | -56x | +|||
| 215 | +
- ref_group_pos <- which(init_lvls == rtables:::spl_ref_group(spl))+ df, |
|||
| 86 | -56x | +|||
| 216 | +
- pos_choices <- c("first", "last")
+ vars = c("n_tot", "n", "prop", "or", "ci"),
|
|||
| 87 | -56x | +|||
| 217 | +
- if (checkmate::test_choice(position, pos_choices) && position == "first") {
+ groups_lists = list(), |
|||
| 88 | -41x | +|||
| 218 | +
- pos <- 0+ label_all = "All Patients", |
|||
| 89 | -15x | +|||
| 219 | +
- } else if (checkmate::test_choice(position, pos_choices) && position == "last") {
+ riskdiff = NULL, |
|||
| 90 | -12x | +|||
| 220 | +
- pos <- length(init_lvls)+ na_str = default_na_str(), |
|||
| 91 | -3x | +|||
| 221 | +
- } else if (checkmate::test_int(position, lower = 1, upper = length(init_lvls))) {
+ .formats = c( |
|||
| 92 | -3x | +|||
| 222 | +
- pos <- position - 1+ n = "xx", n_rsp = "xx", prop = "xx.x%", n_tot = "xx", |
|||
| 93 | +223 |
- } else {
+ or = list(format_extreme_values(2L)), ci = list(format_extreme_values_ci(2L)), |
||
| 94 | -! | +|||
| 224 | +
- stop("Wrong input for ref group position. It must be 'first', 'last', or a integer.")
+ pval = "x.xxxx | (<0.0001)" |
|||
| 95 | +225 |
- }+ )) {
|
||
| 96 | -+ | |||
| 226 | +13x |
-
+ checkmate::assert_list(riskdiff, null.ok = TRUE) |
||
| 97 | -56x | +227 | +13x |
- reord_lvls <- append(init_lvls[-ref_group_pos], init_lvls[ref_group_pos], after = pos)+ checkmate::assert_true(all(c("n_tot", "or", "ci") %in% vars))
|
| 98 | -56x | +228 | +13x |
- ord <- match(reord_lvls, names(splret$values))+ if ("pval" %in% vars && !"pval" %in% names(df$or)) {
|
| 99 | -+ | |||
| 229 | +1x |
-
+ warning( |
||
| 100 | -56x | +230 | +1x |
- make_split_result(+ 'The "pval" statistic has been selected but is not present in "df" so it will not be included in the output ', |
| 101 | -56x | +231 | +1x |
- splret$values[ord],+ 'table. To include the "pval" statistic, please specify a p-value test when generating "df" via ', |
| 102 | -56x | +232 | +1x |
- splret$datasplit[ord],+ 'the "method" argument to `extract_rsp_subgroups()`. If method = "cmh", strata must also be specified via the ', |
| 103 | -56x | +233 | +1x |
- splret$labels[ord]+ '"variables" argument to `extract_rsp_subgroups()`.' |
| 104 | +234 |
- )+ ) |
||
| 105 | +235 |
- }+ } |
||
| 106 | +236 |
- )+ |
||
| 107 | +237 |
- )+ # Create "ci" column from "lcl" and "ucl" |
||
| 108 | -+ | |||
| 238 | +13x |
- }+ df$or$ci <- combine_vectors(df$or$lcl, df$or$ucl) |
||
| 109 | +239 | |||
| 110 | +240 |
- #' @describeIn utils_split_funs Split function to change level order based on an `integer`+ # Fill in missing formats with defaults |
||
| 111 | -+ | |||
| 241 | +13x |
- #' vector or a `character` vector that represent the split variable's factor levels.+ default_fmts <- eval(formals(tabulate_rsp_subgroups)$.formats) |
||
| 112 | -+ | |||
| 242 | +13x |
- #'+ .formats <- c(.formats, default_fmts[vars[!vars %in% names(.formats)]]) |
||
| 113 | +243 |
- #' @param order (`character` or `numeric`)\cr vector of ordering indices for the split facets.+ |
||
| 114 | +244 |
- #'+ # Extract additional parameters from df |
||
| 115 | -+ | |||
| 245 | +13x |
- #' @return+ conf_level <- df$or$conf_level[1] |
||
| 116 | -+ | |||
| 246 | +13x |
- #' * `level_order()` returns an utility function that changes the original levels' order,+ method <- if ("pval_label" %in% names(df$or)) df$or$pval_label[1] else NULL
|
||
| 117 | -+ | |||
| 247 | +13x |
- #' depending on input `order` and split levels.+ colvars <- d_rsp_subgroups_colvars(vars, conf_level = conf_level, method = method) |
||
| 118 | -+ | |||
| 248 | +13x |
- #'+ prop_vars <- intersect(colvars$vars, c("n", "prop", "n_rsp"))
|
||
| 119 | -+ | |||
| 249 | +13x |
- #' @examples+ or_vars <- intersect(names(colvars$labels), c("n_tot", "or", "ci", "pval"))
|
||
| 120 | -+ | |||
| 250 | +13x |
- #' # level_order --------+ colvars_prop <- list(vars = prop_vars, labels = colvars$labels[prop_vars]) |
||
| 121 | -+ | |||
| 251 | +13x |
- #' # Even if default would bring ref_group first, the original order puts it last+ colvars_or <- list(vars = or_vars, labels = colvars$labels[or_vars]) |
||
| 122 | +252 |
- #' basic_table() %>%+ |
||
| 123 | -+ | |||
| 253 | +13x |
- #' split_cols_by("Species", split_fun = level_order(c(1, 3, 2))) %>%
+ extra_args <- list(groups_lists = groups_lists, conf_level = conf_level, method = method, label_all = label_all) |
||
| 124 | +254 |
- #' analyze("Sepal.Length") %>%
+
|
||
| 125 | +255 |
- #' build_table(iris)+ # Get analysis function for each statistic |
||
| 126 | -+ | |||
| 256 | +13x |
- #'+ afun_lst <- a_response_subgroups(.formats = c(.formats, riskdiff = riskdiff$format), na_str = na_str) |
||
| 127 | +257 |
- #' # character vector+ |
||
| 128 | +258 |
- #' new_order <- level_order(levels(iris$Species)[c(1, 3, 2)])+ # Add risk difference column |
||
| 129 | -+ | |||
| 259 | +13x |
- #' basic_table() %>%+ if (!is.null(riskdiff)) {
|
||
| 130 | -+ | |||
| 260 | +! |
- #' split_cols_by("Species", ref_group = "virginica", split_fun = new_order) %>%
+ if (is.null(riskdiff$arm_x)) riskdiff$arm_x <- levels(df$prop$arm)[1] |
||
| 131 | -+ | |||
| 261 | +! |
- #' analyze("Sepal.Length") %>%
+ if (is.null(riskdiff$arm_y)) riskdiff$arm_y <- levels(df$prop$arm)[2] |
||
| 132 | -+ | |||
| 262 | +1x |
- #' build_table(iris)+ colvars_or$vars <- c(colvars_or$vars, "riskdiff") |
||
| 133 | -+ | |||
| 263 | +1x |
- #'+ colvars_or$labels <- c(colvars_or$labels, riskdiff = riskdiff$col_label) |
||
| 134 | -+ | |||
| 264 | +1x |
- #' @export+ arm_cols <- paste(rep(c("n_rsp", "n_rsp", "n", "n")), c(riskdiff$arm_x, riskdiff$arm_y), sep = "_")
|
||
| 135 | +265 |
- level_order <- function(order) {
+
|
||
| 136 | -2x | +266 | +1x |
- make_split_fun(+ df_prop_diff <- df$prop %>% |
| 137 | -2x | +267 | +1x |
- post = list(+ dplyr::select(-"prop") %>% |
| 138 | -2x | +268 | +1x |
- function(splret, spl, fulldf) {
+ tidyr::pivot_wider( |
| 139 | -4x | +269 | +1x |
- if (checkmate::test_integerish(order)) {
+ id_cols = c("subgroup", "var", "var_label", "row_type"),
|
| 140 | +270 | 1x |
- checkmate::assert_integerish(order, lower = 1, upper = length(splret$values))+ names_from = "arm", |
|
| 141 | +271 | 1x |
- ord <- order+ values_from = c("n", "n_rsp")
|
|
| 142 | +272 |
- } else {
+ ) %>% |
||
| 143 | -3x | +273 | +1x |
- checkmate::assert_character(order, len = length(splret$values))+ dplyr::rowwise() %>% |
| 144 | -3x | +274 | +1x |
- checkmate::assert_set_equal(order, names(splret$values), ordered = FALSE)+ dplyr::mutate( |
| 145 | -3x | -
- ord <- match(order, names(splret$values))- |
- ||
| 146 | -+ | 275 | +1x |
- }+ riskdiff = stat_propdiff_ci( |
| 147 | -4x | +276 | +1x |
- make_split_result(+ x = as.list(.data[[arm_cols[1]]]), |
| 148 | -4x | +277 | +1x |
- splret$values[ord],+ y = as.list(.data[[arm_cols[2]]]), |
| 149 | -4x | +278 | +1x |
- splret$datasplit[ord],+ N_x = .data[[arm_cols[3]]], |
| 150 | -4x | +279 | +1x |
- splret$labels[ord]+ N_y = .data[[arm_cols[4]]] |
| 151 | +280 |
) |
||
| 152 | -- |
- }- |
- ||
| 153 | +281 |
- )+ ) %>% |
||
| 154 | -+ | |||
| 282 | +1x |
- )+ dplyr::select(-dplyr::all_of(arm_cols)) |
||
| 155 | +283 |
- }+ |
| 1 | -+ | |||
| 284 | +1x |
- #' Tabulate binary response by subgroup+ df$or <- df$or %>% |
||
| 2 | -+ | |||
| 285 | +1x |
- #'+ dplyr::left_join( |
||
| 3 | -+ | |||
| 286 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ df_prop_diff, |
||
| 4 | -+ | |||
| 287 | +1x |
- #'+ by = c("subgroup", "var", "var_label", "row_type")
|
||
| 5 | +288 |
- #' The [tabulate_rsp_subgroups()] function creates a layout element to tabulate binary response by subgroup, returning+ ) |
||
| 6 | +289 |
- #' statistics including response rate and odds ratio for each population subgroup. The table is created from `df`, a+ } |
||
| 7 | +290 |
- #' list of data frames returned by [extract_rsp_subgroups()], with the statistics to include specified via the `vars`+ |
||
| 8 | +291 |
- #' parameter.+ # Add columns from table_prop (optional) |
||
| 9 | -+ | |||
| 292 | +13x |
- #'+ if (length(colvars_prop$vars) > 0) {
|
||
| 10 | -+ | |||
| 293 | +12x |
- #' A forest plot can be created from the resulting table using the [g_forest()] function.+ lyt_prop <- split_cols_by(lyt = lyt, var = "arm") |
||
| 11 | -+ | |||
| 294 | +12x |
- #'+ lyt_prop <- split_cols_by_multivar( |
||
| 12 | -+ | |||
| 295 | +12x |
- #' @inheritParams extract_rsp_subgroups+ lyt = lyt_prop, |
||
| 13 | -+ | |||
| 296 | +12x |
- #' @inheritParams argument_convention+ vars = colvars_prop$vars, |
||
| 14 | -+ | |||
| 297 | +12x |
- #'+ varlabels = colvars_prop$labels |
||
| 15 | +298 |
- #' @details These functions create a layout starting from a data frame which contains+ ) |
||
| 16 | +299 |
- #' the required statistics. Tables typically used as part of forest plot.+ |
||
| 17 | +300 |
- #'+ # Add "All Patients" row |
||
| 18 | -+ | |||
| 301 | +12x |
- #' @seealso [extract_rsp_subgroups()]+ lyt_prop <- split_rows_by( |
||
| 19 | -+ | |||
| 302 | +12x |
- #'+ lyt = lyt_prop, |
||
| 20 | -+ | |||
| 303 | +12x |
- #' @examples+ var = "row_type", |
||
| 21 | -+ | |||
| 304 | +12x |
- #' library(dplyr)+ split_fun = keep_split_levels("content"),
|
||
| 22 | -+ | |||
| 305 | +12x |
- #' library(forcats)+ nested = FALSE, |
||
| 23 | -+ | |||
| 306 | +12x |
- #'+ child_labels = "hidden" |
||
| 24 | +307 |
- #' adrs <- tern_ex_adrs+ ) |
||
| 25 | -+ | |||
| 308 | +12x |
- #' adrs_labels <- formatters::var_labels(adrs)+ lyt_prop <- analyze_colvars( |
||
| 26 | -+ | |||
| 309 | +12x |
- #'+ lyt = lyt_prop, |
||
| 27 | -+ | |||
| 310 | +12x |
- #' adrs_f <- adrs %>%+ afun = afun_lst[names(colvars_prop$labels)], |
||
| 28 | -+ | |||
| 311 | +12x |
- #' filter(PARAMCD == "BESRSPI") %>%+ na_str = na_str, |
||
| 29 | -+ | |||
| 312 | +12x |
- #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+ extra_args = extra_args |
||
| 30 | +313 |
- #' droplevels() %>%+ ) |
||
| 31 | +314 |
- #' mutate(+ |
||
| 32 | +315 |
- #' # Reorder levels of factor to make the placebo group the reference arm.+ # Add analysis rows |
||
| 33 | -+ | |||
| 316 | +12x |
- #' ARM = fct_relevel(ARM, "B: Placebo"),+ if ("analysis" %in% df$prop$row_type) {
|
||
| 34 | -+ | |||
| 317 | +11x |
- #' rsp = AVALC == "CR"+ lyt_prop <- split_rows_by( |
||
| 35 | -+ | |||
| 318 | +11x |
- #' )+ lyt = lyt_prop, |
||
| 36 | -+ | |||
| 319 | +11x |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ var = "row_type", |
||
| 37 | -+ | |||
| 320 | +11x |
- #'+ split_fun = keep_split_levels("analysis"),
|
||
| 38 | -+ | |||
| 321 | +11x |
- #' # Unstratified analysis.+ nested = FALSE, |
||
| 39 | -+ | |||
| 322 | +11x |
- #' df <- extract_rsp_subgroups(+ child_labels = "hidden" |
||
| 40 | +323 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ ) |
||
| 41 | -+ | |||
| 324 | +11x |
- #' data = adrs_f+ lyt_prop <- split_rows_by(lyt = lyt_prop, var = "var_label", nested = TRUE) |
||
| 42 | -+ | |||
| 325 | +11x |
- #' )+ lyt_prop <- analyze_colvars( |
||
| 43 | -+ | |||
| 326 | +11x |
- #' df+ lyt = lyt_prop, |
||
| 44 | -+ | |||
| 327 | +11x |
- #'+ afun = afun_lst[names(colvars_prop$labels)], |
||
| 45 | -+ | |||
| 328 | +11x |
- #' # Stratified analysis.+ na_str = na_str, |
||
| 46 | -+ | |||
| 329 | +11x |
- #' df_strat <- extract_rsp_subgroups(+ inclNAs = TRUE, |
||
| 47 | -+ | |||
| 330 | +11x |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2"), strata = "STRATA1"),
+ extra_args = extra_args |
||
| 48 | +331 |
- #' data = adrs_f+ ) |
||
| 49 | +332 |
- #' )+ } |
||
| 50 | +333 |
- #' df_strat+ |
||
| 51 | -+ | |||
| 334 | +12x |
- #'+ table_prop <- build_table(lyt_prop, df = df$prop) |
||
| 52 | +335 |
- #' # Grouping of the BMRKR2 levels.+ } else {
|
||
| 53 | -+ | |||
| 336 | +1x |
- #' df_grouped <- extract_rsp_subgroups(+ table_prop <- NULL |
||
| 54 | +337 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ } |
||
| 55 | +338 |
- #' data = adrs_f,+ |
||
| 56 | +339 |
- #' groups_lists = list(+ # Add columns from table_or ("n_tot", "or", and "ci" required)
|
||
| 57 | -+ | |||
| 340 | +13x |
- #' BMRKR2 = list(+ lyt_or <- split_cols_by(lyt = lyt, var = "arm") |
||
| 58 | -+ | |||
| 341 | +13x |
- #' "low" = "LOW",+ lyt_or <- split_cols_by_multivar( |
||
| 59 | -+ | |||
| 342 | +13x |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ lyt = lyt_or, |
||
| 60 | -+ | |||
| 343 | +13x |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ vars = colvars_or$vars, |
||
| 61 | -+ | |||
| 344 | +13x |
- #' )+ varlabels = colvars_or$labels |
||
| 62 | +345 |
- #' )+ ) |
||
| 63 | +346 |
- #' )+ |
||
| 64 | +347 |
- #' df_grouped+ # Add "All Patients" row |
||
| 65 | -+ | |||
| 348 | +13x |
- #'+ lyt_or <- split_rows_by( |
||
| 66 | -+ | |||
| 349 | +13x |
- #' @name response_subgroups+ lyt = lyt_or, |
||
| 67 | -+ | |||
| 350 | +13x |
- #' @order 1+ var = "row_type", |
||
| 68 | -+ | |||
| 351 | +13x |
- NULL+ split_fun = keep_split_levels("content"),
|
||
| 69 | -+ | |||
| 352 | +13x |
-
+ nested = FALSE, |
||
| 70 | -+ | |||
| 353 | +13x |
- #' Prepare response data for population subgroups in data frames+ child_labels = "hidden" |
||
| 71 | +354 |
- #'+ ) |
||
| 72 | -+ | |||
| 355 | +13x |
- #' @description `r lifecycle::badge("stable")`
+ lyt_or <- analyze_colvars( |
||
| 73 | -+ | |||
| 356 | +13x |
- #'+ lyt = lyt_or, |
||
| 74 | -+ | |||
| 357 | +13x |
- #' Prepares response rates and odds ratios for population subgroups in data frames. Simple wrapper+ afun = afun_lst[names(colvars_or$labels)], |
||
| 75 | -+ | |||
| 358 | +13x |
- #' for [h_odds_ratio_subgroups_df()] and [h_proportion_subgroups_df()]. Result is a list of two+ na_str = na_str, |
||
| 76 | -+ | |||
| 359 | +13x |
- #' `data.frames`: `prop` and `or`. `variables` corresponds to the names of variables found in `data`,+ extra_args = extra_args |
||
| 77 | +360 |
- #' passed as a named `list` and requires elements `rsp`, `arm` and optionally `subgroups` and `strata`.+ ) %>% |
||
| 78 | -+ | |||
| 361 | +13x |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ append_topleft("Baseline Risk Factors")
|
||
| 79 | +362 |
- #'+ |
||
| 80 | +363 |
- #' @inheritParams argument_convention+ # Add analysis rows |
||
| 81 | -+ | |||
| 364 | +13x |
- #' @inheritParams response_subgroups+ if ("analysis" %in% df$or$row_type) {
|
||
| 82 | -+ | |||
| 365 | +12x |
- #' @param label_all (`string`)\cr label for the total population analysis.+ lyt_or <- split_rows_by( |
||
| 83 | -+ | |||
| 366 | +12x |
- #'+ lyt = lyt_or, |
||
| 84 | -+ | |||
| 367 | +12x |
- #' @return A named list of two elements:+ var = "row_type", |
||
| 85 | -+ | |||
| 368 | +12x |
- #' * `prop`: A `data.frame` containing columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`, `var`,+ split_fun = keep_split_levels("analysis"),
|
||
| 86 | -+ | |||
| 369 | +12x |
- #' `var_label`, and `row_type`.+ nested = FALSE, |
||
| 87 | -+ | |||
| 370 | +12x |
- #' * `or`: A `data.frame` containing columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`,+ child_labels = "hidden" |
||
| 88 | +371 |
- #' `subgroup`, `var`, `var_label`, and `row_type`.+ ) |
||
| 89 | -+ | |||
| 372 | +12x |
- #'+ lyt_or <- split_rows_by(lyt = lyt_or, var = "var_label", nested = TRUE) |
||
| 90 | -+ | |||
| 373 | +12x |
- #' @seealso [response_subgroups]+ lyt_or <- analyze_colvars( |
||
| 91 | -+ | |||
| 374 | +12x |
- #'+ lyt = lyt_or, |
||
| 92 | -+ | |||
| 375 | +12x |
- #' @export+ afun = afun_lst[names(colvars_or$labels)], |
||
| 93 | -+ | |||
| 376 | +12x |
- extract_rsp_subgroups <- function(variables,+ na_str = na_str, |
||
| 94 | -+ | |||
| 377 | +12x |
- data,+ inclNAs = TRUE, |
||
| 95 | -+ | |||
| 378 | +12x |
- groups_lists = list(),+ extra_args = extra_args |
||
| 96 | +379 |
- conf_level = 0.95,+ ) |
||
| 97 | +380 |
- method = NULL,+ } |
||
| 98 | +381 |
- label_all = "All Patients") {
+
|
||
| 99 | -14x | +382 | +13x |
- if ("strat" %in% names(variables)) {
+ table_or <- build_table(lyt_or, df = df$or) |
| 100 | -! | +|||
| 383 | +
- warning(+ |
|||
| 101 | -! | +|||
| 384 | +
- "Warning: the `strat` element name of the `variables` list argument to `extract_rsp_subgroups() ",+ # Join tables, add forest plot attributes |
|||
| 102 | -! | +|||
| 385 | +13x |
- "was deprecated in tern 0.9.4.\n ",+ n_tot_id <- match("n_tot", colvars_or$vars)
|
||
| 103 | -! | +|||
| 386 | +13x |
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ if (is.null(table_prop)) {
|
||
| 104 | -+ | |||
| 387 | +1x |
- )+ result <- table_or |
||
| 105 | -! | +|||
| 388 | +1x |
- variables[["strata"]] <- variables[["strat"]]+ or_id <- match("or", colvars_or$vars)
|
||
| 106 | -+ | |||
| 389 | +1x |
- }+ ci_id <- match("ci", colvars_or$vars)
|
||
| 107 | +390 | - - | -||
| 108 | -14x | -
- df_prop <- h_proportion_subgroups_df(+ } else {
|
||
| 109 | -14x | +391 | +12x |
- variables,+ result <- cbind_rtables(table_or[, n_tot_id], table_prop, table_or[, -n_tot_id]) |
| 110 | -14x | +392 | +12x |
- data,+ or_id <- 1L + ncol(table_prop) + match("or", colvars_or$vars[-n_tot_id])
|
| 111 | -14x | +393 | +12x |
- groups_lists = groups_lists,+ ci_id <- 1L + ncol(table_prop) + match("ci", colvars_or$vars[-n_tot_id])
|
| 112 | -14x | +394 | +12x |
- label_all = label_all+ n_tot_id <- 1L |
| 113 | +395 |
- )- |
- ||
| 114 | -14x | -
- df_or <- h_odds_ratio_subgroups_df(+ } |
||
| 115 | -14x | +396 | +13x |
- variables,+ structure( |
| 116 | -14x | +397 | +13x |
- data,+ result, |
| 117 | -14x | +398 | +13x |
- groups_lists = groups_lists,+ forest_header = paste0(levels(df$prop$arm), "\nBetter"), |
| 118 | -14x | +399 | +13x |
- conf_level = conf_level,+ col_x = or_id, |
| 119 | -14x | +400 | +13x |
- method = method,+ col_ci = ci_id, |
| 120 | -14x | +401 | +13x |
- label_all = label_all+ col_symbol_size = n_tot_id |
| 121 | +402 |
) |
||
| 122 | -- | - - | -||
| 123 | -14x | -
- list(prop = df_prop, or = df_or)- |
- ||
| 124 | +403 |
} |
||
| 125 | +404 | |||
| 126 | +405 |
- #' @describeIn response_subgroups Formatted analysis function which is used as `afun` in `tabulate_rsp_subgroups()`.+ #' Labels for column variables in binary response by subgroup table |
||
| 127 | +406 |
#' |
||
| 128 | -- |
- #' @return- |
- ||
| 129 | +407 |
- #' * `a_response_subgroups()` returns the corresponding list with formatted [rtables::CellValue()].+ #' @description `r lifecycle::badge("stable")`
|
||
| 130 | +408 |
#' |
||
| 131 | +409 |
- #' @keywords internal+ #' Internal function to check variables included in [tabulate_rsp_subgroups()] and create column labels. |
||
| 132 | +410 |
- a_response_subgroups <- function(.formats = list(+ #' |
||
| 133 | +411 |
- n = "xx", # nolint start+ #' @inheritParams argument_convention |
||
| 134 | +412 |
- n_rsp = "xx",+ #' @inheritParams tabulate_rsp_subgroups |
||
| 135 | +413 |
- prop = "xx.x%",+ #' |
||
| 136 | +414 |
- n_tot = "xx",+ #' @return A `list` of variables to tabulate and their labels. |
||
| 137 | +415 |
- or = list(format_extreme_values(2L)),+ #' |
||
| 138 | +416 |
- ci = list(format_extreme_values_ci(2L)),+ #' @export |
||
| 139 | +417 |
- pval = "x.xxxx | (<0.0001)",+ d_rsp_subgroups_colvars <- function(vars, |
||
| 140 | +418 |
- riskdiff = "xx.x (xx.x - xx.x)" # nolint end+ conf_level = NULL, |
||
| 141 | +419 |
- ),+ method = NULL) {
|
||
| 142 | -+ | |||
| 420 | +22x |
- na_str = default_na_str()) {
+ checkmate::assert_character(vars) |
||
| 143 | +421 | 22x |
- checkmate::assert_list(.formats)+ checkmate::assert_subset(c("n_tot", "or", "ci"), vars)
|
|
| 144 | +422 | 22x |
checkmate::assert_subset( |
|
| 145 | +423 | 22x |
- names(.formats),+ vars, |
|
| 146 | +424 | 22x |
- c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval", "riskdiff")
+ c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
|
|
| 147 | +425 |
) |
||
| 148 | +426 | - - | -||
| 149 | -22x | -
- afun_lst <- Map(- |
- ||
| 150 | -22x | -
- function(stat, fmt, na_str) {
+
|
||
| 151 | -157x | +427 | +22x |
- function(df, labelstr = "", ...) {
+ varlabels <- c( |
| 152 | -349x | +428 | +22x |
- in_rows(+ n = "n", |
| 153 | -349x | +429 | +22x |
- .list = as.list(df[[stat]]),+ n_rsp = "Responders", |
| 154 | -349x | +430 | +22x |
- .labels = as.character(df$subgroup),+ prop = "Response (%)", |
| 155 | -349x | +431 | +22x |
- .formats = fmt,+ n_tot = "Total n", |
| 156 | -349x | +432 | +22x |
- .format_na_strs = na_str+ or = "Odds Ratio" |
| 157 | +433 |
- )+ ) |
||
| 158 | -+ | |||
| 434 | +22x |
- }+ colvars <- vars |
||
| 159 | +435 |
- },+ |
||
| 160 | +436 | 22x |
- stat = names(.formats),+ if ("ci" %in% colvars) {
|
|
| 161 | +437 | 22x |
- fmt = .formats,+ checkmate::assert_false(is.null(conf_level)) |
|
| 162 | -22x | +|||
| 438 | +
- na_str = na_str+ |
|||
| 163 | -+ | |||
| 439 | +22x |
- )+ varlabels <- c( |
||
| 164 | -+ | |||
| 440 | +22x |
-
+ varlabels, |
||
| 165 | +441 | 22x |
- afun_lst+ ci = paste0(100 * conf_level, "% CI") |
|
| 166 | +442 |
- }+ ) |
||
| 167 | +443 | |||
| 168 | +444 |
- #' @describeIn response_subgroups Table-creating function which creates a table+ # The `lcl`` variable is just a placeholder available in the analysis data, |
||
| 169 | +445 |
- #' summarizing binary response by subgroup. This function is a wrapper for [rtables::analyze_colvars()]+ # it is not acutally used in the tabulation. |
||
| 170 | +446 |
- #' and [rtables::summarize_row_groups()].+ # Variables used in the tabulation are lcl and ucl, see `a_response_subgroups` for details. |
||
| 171 | -+ | |||
| 447 | +22x |
- #'+ colvars[colvars == "ci"] <- "lcl" |
||
| 172 | +448 |
- #' @param df (`list`)\cr a list of data frames containing all analysis variables. List should be+ } |
||
| 173 | +449 |
- #' created using [extract_rsp_subgroups()].+ |
||
| 174 | -+ | |||
| 450 | +22x |
- #' @param vars (`character`)\cr the names of statistics to be reported among:+ if ("pval" %in% colvars) {
|
||
| 175 | -+ | |||
| 451 | +16x |
- #' * `n`: Total number of observations per group.+ varlabels <- c( |
||
| 176 | -+ | |||
| 452 | +16x |
- #' * `n_rsp`: Number of responders per group.+ varlabels, |
||
| 177 | -+ | |||
| 453 | +16x |
- #' * `prop`: Proportion of responders.+ pval = method |
||
| 178 | +454 |
- #' * `n_tot`: Total number of observations.+ ) |
||
| 179 | +455 |
- #' * `or`: Odds ratio.+ } |
||
| 180 | +456 |
- #' * `ci` : Confidence interval of odds ratio.+ |
||
| 181 | -+ | |||
| 457 | +22x |
- #' * `pval`: p-value of the effect.+ list( |
||
| 182 | -+ | |||
| 458 | +22x |
- #' Note, the statistics `n_tot`, `or`, and `ci` are required.+ vars = colvars, |
||
| 183 | -+ | |||
| 459 | +22x |
- #' @param riskdiff (`list`)\cr if a risk (proportion) difference column should be added, a list of settings to apply+ labels = varlabels[vars] |
||
| 184 | +460 |
- #' within the column. See [control_riskdiff()] for details. If `NULL`, no risk difference column will be added. If+ ) |
||
| 185 | +461 |
- #' `riskdiff$arm_x` and `riskdiff$arm_y` are `NULL`, the first level of `df$prop$arm` will be used as `arm_x` and+ } |
| 186 | +1 |
- #' the second level as `arm_y`.+ #' Helper functions for tabulating biomarker effects on survival by subgroup |
||
| 187 | +2 |
#' |
||
| 188 | +3 |
- #' @return An `rtables` table summarizing binary response by subgroup.+ #' @description `r lifecycle::badge("stable")`
|
||
| 189 | +4 |
#' |
||
| 190 | +5 |
- #' @examples+ #' Helper functions which are documented here separately to not confuse the user |
||
| 191 | +6 |
- #' # Table with default columns+ #' when reading about the user-facing functions. |
||
| 192 | +7 |
- #' basic_table() %>%+ #' |
||
| 193 | +8 |
- #' tabulate_rsp_subgroups(df)+ #' @inheritParams survival_biomarkers_subgroups |
||
| 194 | +9 |
- #'+ #' @inheritParams argument_convention |
||
| 195 | +10 |
- #' # Table with selected columns+ #' @inheritParams fit_coxreg_multivar |
||
| 196 | +11 |
- #' basic_table() %>%+ #' |
||
| 197 | +12 |
- #' tabulate_rsp_subgroups(+ #' @examples |
||
| 198 | +13 |
- #' df = df,+ #' library(dplyr) |
||
| 199 | +14 |
- #' vars = c("n_tot", "n", "n_rsp", "prop", "or", "ci")
+ #' library(forcats) |
||
| 200 | +15 |
- #' )+ #' |
||
| 201 | +16 |
- #'+ #' adtte <- tern_ex_adtte |
||
| 202 | +17 |
- #' # Table with risk difference column added+ #' |
||
| 203 | +18 |
- #' basic_table() %>%+ #' # Save variable labels before data processing steps. |
||
| 204 | +19 |
- #' tabulate_rsp_subgroups(+ #' adtte_labels <- formatters::var_labels(adtte, fill = FALSE) |
||
| 205 | +20 |
- #' df,+ #' |
||
| 206 | +21 |
- #' riskdiff = control_riskdiff(+ #' adtte_f <- adtte %>% |
||
| 207 | +22 |
- #' arm_x = levels(df$prop$arm)[1],+ #' filter(PARAMCD == "OS") %>% |
||
| 208 | +23 |
- #' arm_y = levels(df$prop$arm)[2]+ #' mutate( |
||
| 209 | +24 |
- #' )+ #' AVALU = as.character(AVALU), |
||
| 210 | +25 |
- #' )+ #' is_event = CNSR == 0 |
||
| 211 | +26 |
- #'+ #' ) |
||
| 212 | +27 |
- #' @export+ #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
|
||
| 213 | +28 |
- #' @order 2+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
||
| 214 | +29 |
- tabulate_rsp_subgroups <- function(lyt,+ #' |
||
| 215 | +30 |
- df,+ #' @name h_survival_biomarkers_subgroups |
||
| 216 | +31 |
- vars = c("n_tot", "n", "prop", "or", "ci"),
+ NULL |
||
| 217 | +32 |
- groups_lists = list(),+ |
||
| 218 | +33 |
- label_all = "All Patients",+ #' @describeIn h_survival_biomarkers_subgroups Helps with converting the "survival" function variable list |
||
| 219 | +34 |
- riskdiff = NULL,+ #' to the "Cox regression" variable list. The reason is that currently there is an inconsistency between the variable |
||
| 220 | +35 |
- na_str = default_na_str(),+ #' names accepted by `extract_survival_subgroups()` and `fit_coxreg_multivar()`. |
||
| 221 | +36 |
- .formats = c(+ #' |
||
| 222 | +37 |
- n = "xx", n_rsp = "xx", prop = "xx.x%", n_tot = "xx",+ #' @param biomarker (`string`)\cr the name of the biomarker variable. |
||
| 223 | +38 |
- or = list(format_extreme_values(2L)), ci = list(format_extreme_values_ci(2L)),+ #' |
||
| 224 | +39 |
- pval = "x.xxxx | (<0.0001)"+ #' @return |
||
| 225 | +40 |
- )) {
- |
- ||
| 226 | -13x | -
- checkmate::assert_list(riskdiff, null.ok = TRUE)- |
- ||
| 227 | -13x | -
- checkmate::assert_true(all(c("n_tot", "or", "ci") %in% vars))
- |
- ||
| 228 | -13x | -
- if ("pval" %in% vars && !"pval" %in% names(df$or)) {
- |
- ||
| 229 | -1x | -
- warning(- |
- ||
| 230 | -1x | -
- 'The "pval" statistic has been selected but is not present in "df" so it will not be included in the output ',- |
- ||
| 231 | -1x | -
- 'table. To include the "pval" statistic, please specify a p-value test when generating "df" via ',- |
- ||
| 232 | -1x | -
- 'the "method" argument to `extract_rsp_subgroups()`. If method = "cmh", strata must also be specified via the ',- |
- ||
| 233 | -1x | -
- '"variables" argument to `extract_rsp_subgroups()`.'+ #' * `h_surv_to_coxreg_variables()` returns a named `list` of elements `time`, `event`, `arm`, |
||
| 234 | +41 |
- )+ #' `covariates`, and `strata`. |
||
| 235 | +42 |
- }+ #' |
||
| 236 | +43 |
-
+ #' @examples |
||
| 237 | +44 |
- # Create "ci" column from "lcl" and "ucl"- |
- ||
| 238 | -13x | -
- df$or$ci <- combine_vectors(df$or$lcl, df$or$ucl)+ #' # This is how the variable list is converted internally. |
||
| 239 | +45 |
-
+ #' h_surv_to_coxreg_variables( |
||
| 240 | +46 |
- # Fill in missing formats with defaults- |
- ||
| 241 | -13x | -
- default_fmts <- eval(formals(tabulate_rsp_subgroups)$.formats)- |
- ||
| 242 | -13x | -
- .formats <- c(.formats, default_fmts[vars[!vars %in% names(.formats)]])+ #' variables = list( |
||
| 243 | +47 |
-
+ #' tte = "AVAL", |
||
| 244 | +48 |
- # Extract additional parameters from df- |
- ||
| 245 | -13x | -
- conf_level <- df$or$conf_level[1]- |
- ||
| 246 | -13x | -
- method <- if ("pval_label" %in% names(df$or)) df$or$pval_label[1] else NULL
- |
- ||
| 247 | -13x | -
- colvars <- d_rsp_subgroups_colvars(vars, conf_level = conf_level, method = method)- |
- ||
| 248 | -13x | -
- prop_vars <- intersect(colvars$vars, c("n", "prop", "n_rsp"))
- |
- ||
| 249 | -13x | -
- or_vars <- intersect(names(colvars$labels), c("n_tot", "or", "ci", "pval"))
- |
- ||
| 250 | -13x | -
- colvars_prop <- list(vars = prop_vars, labels = colvars$labels[prop_vars])- |
- ||
| 251 | -13x | -
- colvars_or <- list(vars = or_vars, labels = colvars$labels[or_vars])+ #' is_event = "EVNT", |
||
| 252 | +49 | - - | -||
| 253 | -13x | -
- extra_args <- list(groups_lists = groups_lists, conf_level = conf_level, method = method, label_all = label_all)+ #' covariates = c("A", "B"),
|
||
| 254 | +50 |
-
+ #' strata = "D" |
||
| 255 | +51 |
- # Get analysis function for each statistic- |
- ||
| 256 | -13x | -
- afun_lst <- a_response_subgroups(.formats = c(.formats, riskdiff = riskdiff$format), na_str = na_str)+ #' ), |
||
| 257 | +52 |
-
+ #' biomarker = "AGE" |
||
| 258 | +53 |
- # Add risk difference column- |
- ||
| 259 | -13x | -
- if (!is.null(riskdiff)) {
- |
- ||
| 260 | -! | -
- if (is.null(riskdiff$arm_x)) riskdiff$arm_x <- levels(df$prop$arm)[1]- |
- ||
| 261 | -! | -
- if (is.null(riskdiff$arm_y)) riskdiff$arm_y <- levels(df$prop$arm)[2]- |
- ||
| 262 | -1x | -
- colvars_or$vars <- c(colvars_or$vars, "riskdiff")- |
- ||
| 263 | -1x | -
- colvars_or$labels <- c(colvars_or$labels, riskdiff = riskdiff$col_label)- |
- ||
| 264 | -1x | -
- arm_cols <- paste(rep(c("n_rsp", "n_rsp", "n", "n")), c(riskdiff$arm_x, riskdiff$arm_y), sep = "_")
+ #' ) |
||
| 265 | +54 | - - | -||
| 266 | -1x | -
- df_prop_diff <- df$prop %>%+ #' |
||
| 267 | -1x | +|||
| 55 | +
- dplyr::select(-"prop") %>%+ #' @export |
|||
| 268 | -1x | +|||
| 56 | +
- tidyr::pivot_wider(+ h_surv_to_coxreg_variables <- function(variables, biomarker) {
|
|||
| 269 | -1x | +57 | +65x |
- id_cols = c("subgroup", "var", "var_label", "row_type"),
+ checkmate::assert_list(variables) |
| 270 | -1x | +58 | +65x |
- names_from = "arm",+ checkmate::assert_string(variables$tte) |
| 271 | -1x | -
- values_from = c("n", "n_rsp")
- |
- ||
| 272 | -+ | 59 | +65x |
- ) %>%+ checkmate::assert_string(variables$is_event) |
| 273 | -1x | +60 | +65x |
- dplyr::rowwise() %>%+ checkmate::assert_string(biomarker) |
| 274 | -1x | +61 | +65x |
- dplyr::mutate(+ list( |
| 275 | -1x | +62 | +65x |
- riskdiff = stat_propdiff_ci(+ time = variables$tte, |
| 276 | -1x | +63 | +65x |
- x = as.list(.data[[arm_cols[1]]]),+ event = variables$is_event, |
| 277 | -1x | +64 | +65x |
- y = as.list(.data[[arm_cols[2]]]),+ arm = biomarker, |
| 278 | -1x | +65 | +65x |
- N_x = .data[[arm_cols[3]]],+ covariates = variables$covariates, |
| 279 | -1x | +66 | +65x |
- N_y = .data[[arm_cols[4]]]+ strata = variables$strata |
| 280 | +67 |
- )+ ) |
||
| 281 | +68 |
- ) %>%- |
- ||
| 282 | -1x | -
- dplyr::select(-dplyr::all_of(arm_cols))+ } |
||
| 283 | +69 | |||
| 284 | -1x | -
- df$or <- df$or %>%- |
- ||
| 285 | -1x | -
- dplyr::left_join(- |
- ||
| 286 | -1x | -
- df_prop_diff,- |
- ||
| 287 | -1x | -
- by = c("subgroup", "var", "var_label", "row_type")
- |
- ||
| 288 | +70 |
- )+ #' @describeIn h_survival_biomarkers_subgroups Prepares estimates for number of events, patients and median survival |
||
| 289 | +71 |
- }+ #' times, as well as hazard ratio estimates, confidence intervals and p-values, for multiple biomarkers |
||
| 290 | +72 |
-
+ #' in a given single data set. |
||
| 291 | +73 |
- # Add columns from table_prop (optional)- |
- ||
| 292 | -13x | -
- if (length(colvars_prop$vars) > 0) {
- |
- ||
| 293 | -12x | -
- lyt_prop <- split_cols_by(lyt = lyt, var = "arm")+ #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements |
||
| 294 | -12x | +|||
| 74 | +
- lyt_prop <- split_cols_by_multivar(+ #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables) and optionally `subgroups` and `strata`. |
|||
| 295 | -12x | +|||
| 75 | +
- lyt = lyt_prop,+ #' |
|||
| 296 | -12x | +|||
| 76 | +
- vars = colvars_prop$vars,+ #' @return |
|||
| 297 | -12x | +|||
| 77 | +
- varlabels = colvars_prop$labels+ #' * `h_coxreg_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers. |
|||
| 298 | +78 |
- )+ #' |
||
| 299 | +79 |
-
+ #' @examples |
||
| 300 | +80 |
- # Add "All Patients" row+ #' # For a single population, estimate separately the effects |
||
| 301 | -12x | +|||
| 81 | +
- lyt_prop <- split_rows_by(+ #' # of two biomarkers. |
|||
| 302 | -12x | +|||
| 82 | +
- lyt = lyt_prop,+ #' df <- h_coxreg_mult_cont_df( |
|||
| 303 | -12x | +|||
| 83 | +
- var = "row_type",+ #' variables = list( |
|||
| 304 | -12x | +|||
| 84 | +
- split_fun = keep_split_levels("content"),
+ #' tte = "AVAL", |
|||
| 305 | -12x | +|||
| 85 | +
- nested = FALSE,+ #' is_event = "is_event", |
|||
| 306 | -12x | +|||
| 86 | +
- child_labels = "hidden"+ #' biomarkers = c("BMRKR1", "AGE"),
|
|||
| 307 | +87 |
- )+ #' covariates = "SEX", |
||
| 308 | -12x | +|||
| 88 | +
- lyt_prop <- analyze_colvars(+ #' strata = c("STRATA1", "STRATA2")
|
|||
| 309 | -12x | +|||
| 89 | +
- lyt = lyt_prop,+ #' ), |
|||
| 310 | -12x | +|||
| 90 | +
- afun = afun_lst[names(colvars_prop$labels)],+ #' data = adtte_f |
|||
| 311 | -12x | +|||
| 91 | +
- na_str = na_str,+ #' ) |
|||
| 312 | -12x | +|||
| 92 | +
- extra_args = extra_args+ #' df |
|||
| 313 | +93 |
- )+ #' |
||
| 314 | +94 |
-
+ #' # If the data set is empty, still the corresponding rows with missings are returned. |
||
| 315 | +95 |
- # Add analysis rows+ #' h_coxreg_mult_cont_df( |
||
| 316 | -12x | +|||
| 96 | +
- if ("analysis" %in% df$prop$row_type) {
+ #' variables = list( |
|||
| 317 | -11x | +|||
| 97 | +
- lyt_prop <- split_rows_by(+ #' tte = "AVAL", |
|||
| 318 | -11x | +|||
| 98 | +
- lyt = lyt_prop,+ #' is_event = "is_event", |
|||
| 319 | -11x | +|||
| 99 | +
- var = "row_type",+ #' biomarkers = c("BMRKR1", "AGE"),
|
|||
| 320 | -11x | +|||
| 100 | +
- split_fun = keep_split_levels("analysis"),
+ #' covariates = "REGION1", |
|||
| 321 | -11x | +|||
| 101 | +
- nested = FALSE,+ #' strata = c("STRATA1", "STRATA2")
|
|||
| 322 | -11x | +|||
| 102 | +
- child_labels = "hidden"+ #' ), |
|||
| 323 | +103 |
- )+ #' data = adtte_f[NULL, ] |
||
| 324 | -11x | +|||
| 104 | +
- lyt_prop <- split_rows_by(lyt = lyt_prop, var = "var_label", nested = TRUE)+ #' ) |
|||
| 325 | -11x | +|||
| 105 | +
- lyt_prop <- analyze_colvars(+ #' |
|||
| 326 | -11x | +|||
| 106 | +
- lyt = lyt_prop,+ #' @export |
|||
| 327 | -11x | +|||
| 107 | +
- afun = afun_lst[names(colvars_prop$labels)],+ h_coxreg_mult_cont_df <- function(variables, |
|||
| 328 | -11x | +|||
| 108 | +
- na_str = na_str,+ data, |
|||
| 329 | -11x | +|||
| 109 | +
- inclNAs = TRUE,+ control = control_coxreg()) {
|
|||
| 330 | -11x | +|||
| 110 | +33x |
- extra_args = extra_args+ if ("strat" %in% names(variables)) {
|
||
| 331 | -+ | |||
| 111 | +! |
- )+ warning( |
||
| 332 | -+ | |||
| 112 | +! |
- }+ "Warning: the `strat` element name of the `variables` list argument to `h_coxreg_mult_cont_df() ", |
||
| 333 | -+ | |||
| 113 | +! |
-
+ "was deprecated in tern 0.9.4.\n ", |
||
| 334 | -12x | +|||
| 114 | +! |
- table_prop <- build_table(lyt_prop, df = df$prop)+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 335 | +115 |
- } else {
+ ) |
||
| 336 | -1x | +|||
| 116 | +! |
- table_prop <- NULL+ variables[["strata"]] <- variables[["strat"]] |
||
| 337 | +117 |
} |
||
| 338 | +118 | |||
| 339 | -- |
- # Add columns from table_or ("n_tot", "or", and "ci" required)
- |
- ||
| 340 | -13x | +119 | +33x |
- lyt_or <- split_cols_by(lyt = lyt, var = "arm")+ assert_df_with_variables(data, variables) |
| 341 | -13x | +120 | +33x |
- lyt_or <- split_cols_by_multivar(+ checkmate::assert_list(control, names = "named") |
| 342 | -13x | +121 | +33x |
- lyt = lyt_or,+ checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE) |
| 343 | -13x | +122 | +33x |
- vars = colvars_or$vars,+ conf_level <- control[["conf_level"]] |
| 344 | -13x | +123 | +33x |
- varlabels = colvars_or$labels+ pval_label <- paste0( |
| 345 | +124 |
- )+ # the regex capitalizes the first letter of the string / senetence. |
||
| 346 | -+ | |||
| 125 | +33x |
-
+ "p-value (", gsub("(^[a-z])", "\\U\\1", trimws(control[["pval_method"]]), perl = TRUE), ")"
|
||
| 347 | +126 |
- # Add "All Patients" row+ ) |
||
| 348 | -13x | +|||
| 127 | +
- lyt_or <- split_rows_by(+ # If there is any data, run model, otherwise return empty results. |
|||
| 349 | -13x | +128 | +33x |
- lyt = lyt_or,+ if (nrow(data) > 0) {
|
| 350 | -13x | +129 | +32x |
- var = "row_type",+ bm_cols <- match(variables$biomarkers, names(data)) |
| 351 | -13x | +130 | +32x |
- split_fun = keep_split_levels("content"),
+ l_result <- lapply(variables$biomarkers, function(bm) {
|
| 352 | -13x | +131 | +64x |
- nested = FALSE,+ coxreg_list <- fit_coxreg_multivar( |
| 353 | -13x | -
- child_labels = "hidden"- |
- ||
| 354 | -+ | 132 | +64x |
- )+ variables = h_surv_to_coxreg_variables(variables, bm), |
| 355 | -13x | +133 | +64x |
- lyt_or <- analyze_colvars(+ data = data, |
| 356 | -13x | +134 | +64x |
- lyt = lyt_or,+ control = control |
| 357 | -13x | +|||
| 135 | +
- afun = afun_lst[names(colvars_or$labels)],+ ) |
|||
| 358 | -13x | +136 | +64x |
- na_str = na_str,+ result <- do.call( |
| 359 | -13x | -
- extra_args = extra_args- |
- ||
| 360 | -+ | 137 | +64x |
- ) %>%+ h_coxreg_multivar_extract, |
| 361 | -13x | +138 | +64x |
- append_topleft("Baseline Risk Factors")
+ c(list(var = bm), coxreg_list[c("mod", "data", "control")])
|
| 362 | +139 |
-
+ ) |
||
| 363 | -+ | |||
| 140 | +64x |
- # Add analysis rows+ data_fit <- as.data.frame(as.matrix(coxreg_list$mod$y)) |
||
| 364 | -13x | +141 | +64x |
- if ("analysis" %in% df$or$row_type) {
+ data_fit$status <- as.logical(data_fit$status) |
| 365 | -12x | +142 | +64x |
- lyt_or <- split_rows_by(+ median <- s_surv_time( |
| 366 | -12x | +143 | +64x |
- lyt = lyt_or,+ df = data_fit, |
| 367 | -12x | +144 | +64x |
- var = "row_type",+ .var = "time", |
| 368 | -12x | +145 | +64x |
- split_fun = keep_split_levels("analysis"),
+ is_event = "status" |
| 369 | -12x | +146 | +64x |
- nested = FALSE,+ )$median |
| 370 | -12x | +147 | +64x |
- child_labels = "hidden"+ data.frame( |
| 371 | +148 |
- )+ # Dummy column needed downstream to create a nested header. |
||
| 372 | -12x | +149 | +64x |
- lyt_or <- split_rows_by(lyt = lyt_or, var = "var_label", nested = TRUE)+ biomarker = bm, |
| 373 | -12x | +150 | +64x |
- lyt_or <- analyze_colvars(+ biomarker_label = formatters::var_labels(data[bm], fill = TRUE), |
| 374 | -12x | +151 | +64x |
- lyt = lyt_or,+ n_tot = coxreg_list$mod$n, |
| 375 | -12x | +152 | +64x |
- afun = afun_lst[names(colvars_or$labels)],+ n_tot_events = coxreg_list$mod$nevent, |
| 376 | -12x | +153 | +64x |
- na_str = na_str,+ median = as.numeric(median), |
| 377 | -12x | +154 | +64x |
- inclNAs = TRUE,+ result[1L, c("hr", "lcl", "ucl")],
|
| 378 | -12x | -
- extra_args = extra_args- |
- ||
| 379 | -+ | 155 | +64x |
- )+ conf_level = conf_level, |
| 380 | -+ | |||
| 156 | +64x |
- }+ pval = result[1L, "pval"], |
||
| 381 | -+ | |||
| 157 | +64x |
-
+ pval_label = pval_label, |
||
| 382 | -13x | +158 | +64x |
- table_or <- build_table(lyt_or, df = df$or)+ stringsAsFactors = FALSE |
| 383 | +159 |
-
+ ) |
||
| 384 | +160 |
- # Join tables, add forest plot attributes+ }) |
||
| 385 | -13x | +161 | +32x |
- n_tot_id <- match("n_tot", colvars_or$vars)
+ do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 386 | -13x | +|||
| 162 | +
- if (is.null(table_prop)) {
+ } else {
|
|||
| 387 | +163 | 1x |
- result <- table_or+ data.frame( |
|
| 388 | +164 | 1x |
- or_id <- match("or", colvars_or$vars)
+ biomarker = variables$biomarkers, |
|
| 389 | +165 | 1x |
- ci_id <- match("ci", colvars_or$vars)
- |
- |
| 390 | -- |
- } else {
+ biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE), |
||
| 391 | -12x | +166 | +1x |
- result <- cbind_rtables(table_or[, n_tot_id], table_prop, table_or[, -n_tot_id])+ n_tot = 0L, |
| 392 | -12x | +167 | +1x |
- or_id <- 1L + ncol(table_prop) + match("or", colvars_or$vars[-n_tot_id])
+ n_tot_events = 0L, |
| 393 | -12x | +168 | +1x |
- ci_id <- 1L + ncol(table_prop) + match("ci", colvars_or$vars[-n_tot_id])
+ median = NA, |
| 394 | -12x | +169 | +1x |
- n_tot_id <- 1L+ hr = NA, |
| 395 | -+ | |||
| 170 | +1x |
- }+ lcl = NA, |
||
| 396 | -13x | +171 | +1x |
- structure(+ ucl = NA, |
| 397 | -13x | +172 | +1x |
- result,+ conf_level = conf_level, |
| 398 | -13x | +173 | +1x |
- forest_header = paste0(levels(df$prop$arm), "\nBetter"),+ pval = NA, |
| 399 | -13x | +174 | +1x |
- col_x = or_id,+ pval_label = pval_label, |
| 400 | -13x | +175 | +1x |
- col_ci = ci_id,+ row.names = seq_along(variables$biomarkers), |
| 401 | -13x | +176 | +1x |
- col_symbol_size = n_tot_id+ stringsAsFactors = FALSE |
| 402 | +177 |
- )+ ) |
||
| 403 | +178 |
- }+ } |
||
| 404 | +179 |
-
+ } |
||
| 405 | +180 |
- #' Labels for column variables in binary response by subgroup table+ |
||
| 406 | +181 |
- #'+ #' @describeIn h_survival_biomarkers_subgroups Prepares a single sub-table given a `df_sub` containing |
||
| 407 | +182 |
- #' @description `r lifecycle::badge("stable")`
+ #' the results for a single biomarker. |
||
| 408 | +183 |
#' |
||
| 409 | +184 |
- #' Internal function to check variables included in [tabulate_rsp_subgroups()] and create column labels.+ #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is |
||
| 410 | +185 |
- #'+ #' returned by [extract_survival_biomarkers()] (it needs a couple of columns which are |
||
| 411 | +186 |
- #' @inheritParams argument_convention+ #' added by that high-level function relative to what is returned by [h_coxreg_mult_cont_df()], |
||
| 412 | +187 |
- #' @inheritParams tabulate_rsp_subgroups+ #' see the example). |
||
| 413 | +188 |
#' |
||
| 414 | +189 |
- #' @return A `list` of variables to tabulate and their labels.+ #' @return |
||
| 415 | +190 |
- #'+ #' * `h_tab_surv_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns. |
||
| 416 | +191 |
- #' @export+ #' |
||
| 417 | +192 |
- d_rsp_subgroups_colvars <- function(vars,+ #' @examples |
||
| 418 | +193 |
- conf_level = NULL,+ #' # Starting from above `df`, zoom in on one biomarker and add required columns. |
||
| 419 | +194 |
- method = NULL) {
- |
- ||
| 420 | -22x | -
- checkmate::assert_character(vars)- |
- ||
| 421 | -22x | -
- checkmate::assert_subset(c("n_tot", "or", "ci"), vars)
- |
- ||
| 422 | -22x | -
- checkmate::assert_subset(- |
- ||
| 423 | -22x | -
- vars,- |
- ||
| 424 | -22x | -
- c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
+ #' df1 <- df[1, ] |
||
| 425 | +195 |
- )+ #' df1$subgroup <- "All patients" |
||
| 426 | +196 | - - | -||
| 427 | -22x | -
- varlabels <- c(- |
- ||
| 428 | -22x | -
- n = "n",- |
- ||
| 429 | -22x | -
- n_rsp = "Responders",- |
- ||
| 430 | -22x | -
- prop = "Response (%)",- |
- ||
| 431 | -22x | -
- n_tot = "Total n",+ #' df1$row_type <- "content" |
||
| 432 | -22x | +|||
| 197 | +
- or = "Odds Ratio"+ #' df1$var <- "ALL" |
|||
| 433 | +198 |
- )+ #' df1$var_label <- "All patients" |
||
| 434 | -22x | +|||
| 199 | +
- colvars <- vars+ #' h_tab_surv_one_biomarker( |
|||
| 435 | +200 |
-
+ #' df1, |
||
| 436 | -22x | +|||
| 201 | +
- if ("ci" %in% colvars) {
+ #' vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
|
|||
| 437 | -22x | +|||
| 202 | +
- checkmate::assert_false(is.null(conf_level))+ #' time_unit = "days" |
|||
| 438 | +203 |
-
+ #' ) |
||
| 439 | -22x | +|||
| 204 | +
- varlabels <- c(+ #' |
|||
| 440 | -22x | +|||
| 205 | +
- varlabels,+ #' @export |
|||
| 441 | -22x | +|||
| 206 | +
- ci = paste0(100 * conf_level, "% CI")+ h_tab_surv_one_biomarker <- function(df, |
|||
| 442 | +207 |
- )+ vars, |
||
| 443 | +208 |
-
+ time_unit, |
||
| 444 | +209 |
- # The `lcl`` variable is just a placeholder available in the analysis data,+ na_str = default_na_str(), |
||
| 445 | +210 |
- # it is not acutally used in the tabulation.+ .indent_mods = 0L, |
||
| 446 | +211 |
- # Variables used in the tabulation are lcl and ucl, see `a_response_subgroups` for details.+ ...) {
|
||
| 447 | -22x | -
- colvars[colvars == "ci"] <- "lcl"- |
- ||
| 448 | -+ | 212 | +10x |
- }+ afuns <- a_survival_subgroups(na_str = na_str)[vars] |
| 449 | -+ | |||
| 213 | +10x |
-
+ colvars <- d_survival_subgroups_colvars( |
||
| 450 | -22x | +214 | +10x |
- if ("pval" %in% colvars) {
+ vars, |
| 451 | -16x | +215 | +10x |
- varlabels <- c(+ conf_level = df$conf_level[1], |
| 452 | -16x | +216 | +10x |
- varlabels,+ method = df$pval_label[1], |
| 453 | -16x | +217 | +10x |
- pval = method+ time_unit = time_unit |
| 454 | +218 |
- )+ ) |
||
| 455 | -+ | |||
| 219 | +10x |
- }+ h_tab_one_biomarker( |
||
| 456 | -+ | |||
| 220 | +10x |
-
+ df = df, |
||
| 457 | -22x | +221 | +10x |
- list(+ afuns = afuns, |
| 458 | -22x | +222 | +10x |
- vars = colvars,+ colvars = colvars, |
| 459 | -22x | +223 | +10x |
- labels = varlabels[vars]+ na_str = na_str,+ |
+
| 224 | +10x | +
+ .indent_mods = .indent_mods, |
||
| 460 | +225 | ++ |
+ ...+ |
+ |
| 226 |
) |
|||
| 461 | +227 |
}@@ -46208,14 +49320,14 @@ tern coverage - 95.59% |
| 1 |
- #' Helper functions for tabulating biomarker effects on survival by subgroup+ #' Formatting functions |
||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' See below for the list of formatting functions created in `tern` to work with `rtables`. |
||
| 5 |
- #' Helper functions which are documented here separately to not confuse the user+ #' Other available formats can be listed via [`formatters::list_valid_format_labels()`]. Additional |
||
| 6 |
- #' when reading about the user-facing functions.+ #' custom formats can be created via the [`formatters::sprintf_format()`] function. |
||
| 8 |
- #' @inheritParams survival_biomarkers_subgroups+ #' @family formatting functions |
||
| 9 |
- #' @inheritParams argument_convention+ #' @name formatting_functions |
||
| 10 |
- #' @inheritParams fit_coxreg_multivar+ NULL |
||
| 11 |
- #'+ |
||
| 12 |
- #' @examples+ #' Format fraction and percentage |
||
| 13 |
- #' library(dplyr)+ #' |
||
| 14 |
- #' library(forcats)+ #' @description `r lifecycle::badge("stable")`
|
||
| 16 |
- #' adtte <- tern_ex_adtte+ #' Formats a fraction together with ratio in percent. |
||
| 18 |
- #' # Save variable labels before data processing steps.+ #' @param x (named `integer`)\cr vector with elements `num` and `denom`. |
||
| 19 |
- #' adtte_labels <- formatters::var_labels(adtte, fill = FALSE)+ #' @param ... not used. Required for `rtables` interface. |
||
| 21 |
- #' adtte_f <- adtte %>%+ #' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`. |
||
| 22 |
- #' filter(PARAMCD == "OS") %>%+ #' |
||
| 23 |
- #' mutate(+ #' @examples |
||
| 24 |
- #' AVALU = as.character(AVALU),+ #' format_fraction(x = c(num = 2L, denom = 3L)) |
||
| 25 |
- #' is_event = CNSR == 0+ #' format_fraction(x = c(num = 0L, denom = 3L)) |
||
| 26 |
- #' )+ #' |
||
| 27 |
- #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
+ #' @family formatting functions |
||
| 28 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ #' @export |
||
| 29 |
- #'+ format_fraction <- function(x, ...) {
|
||
| 30 | -+ | 4x |
- #' @name h_survival_biomarkers_subgroups+ attr(x, "label") <- NULL |
| 31 |
- NULL+ |
||
| 32 | -+ | 4x |
-
+ checkmate::assert_vector(x) |
| 33 | -+ | 4x |
- #' @describeIn h_survival_biomarkers_subgroups Helps with converting the "survival" function variable list+ checkmate::assert_count(x["num"]) |
| 34 | -+ | 2x |
- #' to the "Cox regression" variable list. The reason is that currently there is an inconsistency between the variable+ checkmate::assert_count(x["denom"]) |
| 35 |
- #' names accepted by `extract_survival_subgroups()` and `fit_coxreg_multivar()`.+ |
||
| 36 | -+ | 2x |
- #'+ result <- if (x["num"] == 0) {
|
| 37 | -+ | 1x |
- #' @param biomarker (`string`)\cr the name of the biomarker variable.+ paste0(x["num"], "/", x["denom"]) |
| 38 |
- #'+ } else {
|
||
| 39 | -+ | 1x |
- #' @return+ paste0( |
| 40 | -+ | 1x |
- #' * `h_surv_to_coxreg_variables()` returns a named `list` of elements `time`, `event`, `arm`,+ x["num"], "/", x["denom"], |
| 41 | -+ | 1x |
- #' `covariates`, and `strata`.+ " (", round(x["num"] / x["denom"] * 100, 1), "%)"
|
| 42 |
- #'+ ) |
||
| 43 |
- #' @examples+ } |
||
| 44 |
- #' # This is how the variable list is converted internally.+ |
||
| 45 | -+ | 2x |
- #' h_surv_to_coxreg_variables(+ return(result) |
| 46 |
- #' variables = list(+ } |
||
| 47 |
- #' tte = "AVAL",+ |
||
| 48 |
- #' is_event = "EVNT",+ #' Format fraction and percentage with fixed single decimal place |
||
| 49 |
- #' covariates = c("A", "B"),
+ #' |
||
| 50 |
- #' strata = "D"+ #' @description `r lifecycle::badge("stable")`
|
||
| 51 |
- #' ),+ #' |
||
| 52 |
- #' biomarker = "AGE"+ #' Formats a fraction together with ratio in percent with fixed single decimal place. |
||
| 53 |
- #' )+ #' Includes trailing zero in case of whole number percentages to always keep one decimal place. |
||
| 55 |
- #' @export+ #' @inheritParams format_fraction |
||
| 56 |
- h_surv_to_coxreg_variables <- function(variables, biomarker) {
+ #' |
||
| 57 | -65x | +
- checkmate::assert_list(variables)+ #' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`. |
|
| 58 | -65x | +
- checkmate::assert_string(variables$tte)+ #' |
|
| 59 | -65x | +
- checkmate::assert_string(variables$is_event)+ #' @examples |
|
| 60 | -65x | +
- checkmate::assert_string(biomarker)+ #' format_fraction_fixed_dp(x = c(num = 1L, denom = 2L)) |
|
| 61 | -65x | +
- list(+ #' format_fraction_fixed_dp(x = c(num = 1L, denom = 4L)) |
|
| 62 | -65x | +
- time = variables$tte,+ #' format_fraction_fixed_dp(x = c(num = 0L, denom = 3L)) |
|
| 63 | -65x | +
- event = variables$is_event,+ #' |
|
| 64 | -65x | +
- arm = biomarker,+ #' @family formatting functions |
|
| 65 | -65x | +
- covariates = variables$covariates,+ #' @export |
|
| 66 | -65x | +
- strata = variables$strata+ format_fraction_fixed_dp <- function(x, ...) {
|
|
| 67 | -+ | 3x |
- )+ attr(x, "label") <- NULL |
| 68 | -+ | 3x |
- }+ checkmate::assert_vector(x) |
| 69 | -+ | 3x |
-
+ checkmate::assert_count(x["num"]) |
| 70 | -+ | 3x |
- #' @describeIn h_survival_biomarkers_subgroups Prepares estimates for number of events, patients and median survival+ checkmate::assert_count(x["denom"]) |
| 71 |
- #' times, as well as hazard ratio estimates, confidence intervals and p-values, for multiple biomarkers+ |
||
| 72 | -+ | 3x |
- #' in a given single data set.+ result <- if (x["num"] == 0) {
|
| 73 | -+ | 1x |
- #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements+ paste0(x["num"], "/", x["denom"]) |
| 74 |
- #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables) and optionally `subgroups` and `strata`.+ } else {
|
||
| 75 | -+ | 2x |
- #'+ paste0( |
| 76 | -+ | 2x |
- #' @return+ x["num"], "/", x["denom"], |
| 77 | -+ | 2x |
- #' * `h_coxreg_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers.+ " (", sprintf("%.1f", round(x["num"] / x["denom"] * 100, 1)), "%)"
|
| 78 |
- #'+ ) |
||
| 79 |
- #' @examples+ } |
||
| 80 | -+ | 3x |
- #' # For a single population, estimate separately the effects+ return(result) |
| 81 |
- #' # of two biomarkers.+ } |
||
| 82 |
- #' df <- h_coxreg_mult_cont_df(+ |
||
| 83 |
- #' variables = list(+ #' Format count and fraction |
||
| 84 |
- #' tte = "AVAL",+ #' |
||
| 85 |
- #' is_event = "is_event",+ #' @description `r lifecycle::badge("stable")`
|
||
| 86 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' |
||
| 87 |
- #' covariates = "SEX",+ #' Formats a count together with fraction with special consideration when count is `0`. |
||
| 88 |
- #' strata = c("STRATA1", "STRATA2")
+ #' |
||
| 89 |
- #' ),+ #' @param x (`numeric(2)`)\cr vector of length 2 with count and fraction, respectively. |
||
| 90 |
- #' data = adtte_f+ #' @param ... not used. Required for `rtables` interface. |
||
| 91 |
- #' )+ #' |
||
| 92 |
- #' df+ #' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`. |
||
| 94 |
- #' # If the data set is empty, still the corresponding rows with missings are returned.+ #' @examples |
||
| 95 |
- #' h_coxreg_mult_cont_df(+ #' format_count_fraction(x = c(2, 0.6667)) |
||
| 96 |
- #' variables = list(+ #' format_count_fraction(x = c(0, 0)) |
||
| 97 |
- #' tte = "AVAL",+ #' |
||
| 98 |
- #' is_event = "is_event",+ #' @family formatting functions |
||
| 99 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' @export |
||
| 100 |
- #' covariates = "REGION1",+ format_count_fraction <- function(x, ...) {
|
||
| 101 | -+ | 3x |
- #' strata = c("STRATA1", "STRATA2")
+ attr(x, "label") <- NULL |
| 102 |
- #' ),+ |
||
| 103 | -+ | 3x |
- #' data = adtte_f[NULL, ]+ if (any(is.na(x))) {
|
| 104 | -+ | 1x |
- #' )+ return("NA")
|
| 105 |
- #'+ } |
||
| 106 |
- #' @export+ |
||
| 107 | -+ | 2x |
- h_coxreg_mult_cont_df <- function(variables,+ checkmate::assert_vector(x) |
| 108 | -+ | 2x |
- data,+ checkmate::assert_integerish(x[1]) |
| 109 | -+ | 2x |
- control = control_coxreg()) {
+ assert_proportion_value(x[2], include_boundaries = TRUE) |
| 110 | -33x | +
- if ("strat" %in% names(variables)) {
+
|
|
| 111 | -! | +2x |
- warning(+ result <- if (x[1] == 0) {
|
| 112 | -! | +1x |
- "Warning: the `strat` element name of the `variables` list argument to `h_coxreg_mult_cont_df() ",+ "0" |
| 113 | -! | +
- "was deprecated in tern 0.9.4.\n ",+ } else {
|
|
| 114 | -! | +1x |
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ paste0(x[1], " (", round(x[2] * 100, 1), "%)")
|
| 115 |
- )+ } |
||
| 116 | -! | +
- variables[["strata"]] <- variables[["strat"]]+ |
|
| 117 | -+ | 2x |
- }+ return(result) |
| 118 |
-
+ } |
||
| 119 | -33x | +
- assert_df_with_variables(data, variables)+ |
|
| 120 | -33x | +
- checkmate::assert_list(control, names = "named")+ #' Format count and percentage with fixed single decimal place |
|
| 121 | -33x | +
- checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE)+ #' |
|
| 122 | -33x | +
- conf_level <- control[["conf_level"]]+ #' @description `r lifecycle::badge("experimental")`
|
|
| 123 | -33x | +
- pval_label <- paste0(+ #' |
|
| 124 |
- # the regex capitalizes the first letter of the string / senetence.+ #' Formats a count together with fraction with special consideration when count is `0`. |
||
| 125 | -33x | +
- "p-value (", gsub("(^[a-z])", "\\U\\1", trimws(control[["pval_method"]]), perl = TRUE), ")"
+ #' |
|
| 126 |
- )+ #' @inheritParams format_count_fraction |
||
| 127 |
- # If there is any data, run model, otherwise return empty results.+ #' |
||
| 128 | -33x | +
- if (nrow(data) > 0) {
+ #' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`. |
|
| 129 | -32x | +
- bm_cols <- match(variables$biomarkers, names(data))+ #' |
|
| 130 | -32x | +
- l_result <- lapply(variables$biomarkers, function(bm) {
+ #' @examples |
|
| 131 | -64x | +
- coxreg_list <- fit_coxreg_multivar(+ #' format_count_fraction_fixed_dp(x = c(2, 0.6667)) |
|
| 132 | -64x | +
- variables = h_surv_to_coxreg_variables(variables, bm),+ #' format_count_fraction_fixed_dp(x = c(2, 0.5)) |
|
| 133 | -64x | +
- data = data,+ #' format_count_fraction_fixed_dp(x = c(0, 0)) |
|
| 134 | -64x | +
- control = control+ #' |
|
| 135 |
- )+ #' @family formatting functions |
||
| 136 | -64x | +
- result <- do.call(+ #' @export |
|
| 137 | -64x | +
- h_coxreg_multivar_extract,+ format_count_fraction_fixed_dp <- function(x, ...) {
|
|
| 138 | -64x | +1408x |
- c(list(var = bm), coxreg_list[c("mod", "data", "control")])
+ attr(x, "label") <- NULL |
| 139 |
- )+ |
||
| 140 | -64x | +1408x |
- data_fit <- as.data.frame(as.matrix(coxreg_list$mod$y))+ if (any(is.na(x))) {
|
| 141 | -64x | +! |
- data_fit$status <- as.logical(data_fit$status)+ return("NA")
|
| 142 | -64x | +
- median <- s_surv_time(+ } |
|
| 143 | -64x | +
- df = data_fit,+ |
|
| 144 | -64x | +1408x |
- .var = "time",+ checkmate::assert_vector(x) |
| 145 | -64x | +1408x |
- is_event = "status"+ checkmate::assert_integerish(x[1]) |
| 146 | -64x | +1408x |
- )$median+ assert_proportion_value(x[2], include_boundaries = TRUE) |
| 147 | -64x | +
- data.frame(+ |
|
| 148 | -+ | 1408x |
- # Dummy column needed downstream to create a nested header.+ result <- if (x[1] == 0) {
|
| 149 | -64x | +195x |
- biomarker = bm,+ "0" |
| 150 | -64x | +1408x |
- biomarker_label = formatters::var_labels(data[bm], fill = TRUE),+ } else if (.is_equal_float(x[2], 1)) {
|
| 151 | -64x | +549x |
- n_tot = coxreg_list$mod$n,+ sprintf("%d (100%%)", x[1])
|
| 152 | -64x | +
- n_tot_events = coxreg_list$mod$nevent,+ } else {
|
|
| 153 | -64x | +664x |
- median = as.numeric(median),+ sprintf("%d (%.1f%%)", x[1], x[2] * 100)
|
| 154 | -64x | +
- result[1L, c("hr", "lcl", "ucl")],
+ } |
|
| 155 | -64x | +
- conf_level = conf_level,+ |
|
| 156 | -64x | +1408x |
- pval = result[1L, "pval"],+ return(result) |
| 157 | -64x | +
- pval_label = pval_label,+ } |
|
| 158 | -64x | +
- stringsAsFactors = FALSE+ |
|
| 159 |
- )+ #' Format count and fraction with special case for count < 10 |
||
| 160 |
- })+ #' |
||
| 161 | -32x | +
- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ #' @description `r lifecycle::badge("stable")`
|
|
| 162 |
- } else {
+ #' |
||
| 163 | -1x | +
- data.frame(+ #' Formats a count together with fraction with special consideration when count is less than 10. |
|
| 164 | -1x | +
- biomarker = variables$biomarkers,+ #' |
|
| 165 | -1x | +
- biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE),+ #' @inheritParams format_count_fraction |
|
| 166 | -1x | +
- n_tot = 0L,+ #' |
|
| 167 | -1x | +
- n_tot_events = 0L,+ #' @return A string in the format `count (fraction %)`. If `count` is less than 10, only `count` is printed. |
|
| 168 | -1x | +
- median = NA,+ #' |
|
| 169 | -1x | +
- hr = NA,+ #' @examples |
|
| 170 | -1x | +
- lcl = NA,+ #' format_count_fraction_lt10(x = c(275, 0.9673)) |
|
| 171 | -1x | +
- ucl = NA,+ #' format_count_fraction_lt10(x = c(2, 0.6667)) |
|
| 172 | -1x | +
- conf_level = conf_level,+ #' format_count_fraction_lt10(x = c(9, 1)) |
|
| 173 | -1x | +
- pval = NA,+ #' |
|
| 174 | -1x | +
- pval_label = pval_label,+ #' @family formatting functions |
|
| 175 | -1x | +
- row.names = seq_along(variables$biomarkers),+ #' @export |
|
| 176 | -1x | +
- stringsAsFactors = FALSE+ format_count_fraction_lt10 <- function(x, ...) {
|
|
| 177 | -+ | 7x |
- )+ attr(x, "label") <- NULL |
| 178 |
- }+ |
||
| 179 | -+ | 7x |
- }+ if (any(is.na(x))) {
|
| 180 | -+ | 1x |
-
+ return("NA")
|
| 181 |
- #' @describeIn h_survival_biomarkers_subgroups Prepares a single sub-table given a `df_sub` containing+ } |
||
| 182 |
- #' the results for a single biomarker.+ |
||
| 183 | -+ | 6x |
- #'+ checkmate::assert_vector(x) |
| 184 | -+ | 6x |
- #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is+ checkmate::assert_integerish(x[1]) |
| 185 | -+ | 6x |
- #' returned by [extract_survival_biomarkers()] (it needs a couple of columns which are+ assert_proportion_value(x[2], include_boundaries = TRUE) |
| 186 |
- #' added by that high-level function relative to what is returned by [h_coxreg_mult_cont_df()],+ |
||
| 187 | -+ | 6x |
- #' see the example).+ result <- if (x[1] < 10) {
|
| 188 | -+ | 3x |
- #'+ paste0(x[1]) |
| 189 |
- #' @return+ } else {
|
||
| 190 | -+ | 3x |
- #' * `h_tab_surv_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns.+ paste0(x[1], " (", round(x[2] * 100, 1), "%)")
|
| 191 |
- #'+ } |
||
| 192 |
- #' @examples+ |
||
| 193 | -+ | 6x |
- #' # Starting from above `df`, zoom in on one biomarker and add required columns.+ return(result) |
| 194 |
- #' df1 <- df[1, ]+ } |
||
| 195 |
- #' df1$subgroup <- "All patients"+ |
||
| 196 |
- #' df1$row_type <- "content"+ #' Format XX as a formatting function |
||
| 197 |
- #' df1$var <- "ALL"+ #' |
||
| 198 |
- #' df1$var_label <- "All patients"+ #' Translate a string where x and dots are interpreted as number place |
||
| 199 |
- #' h_tab_surv_one_biomarker(+ #' holders, and others as formatting elements. |
||
| 200 |
- #' df1,+ #' |
||
| 201 |
- #' vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
+ #' @param str (`string`)\cr template. |
||
| 202 |
- #' time_unit = "days"+ #' |
||
| 203 |
- #' )+ #' @return An `rtables` formatting function. |
||
| 205 |
- #' @export+ #' @examples |
||
| 206 |
- h_tab_surv_one_biomarker <- function(df,+ #' test <- list(c(1.658, 0.5761), c(1e1, 785.6)) |
||
| 207 |
- vars,+ #' |
||
| 208 |
- time_unit,+ #' z <- format_xx("xx (xx.x)")
|
||
| 209 |
- na_str = default_na_str(),+ #' sapply(test, z) |
||
| 210 | - |
- .indent_mods = 0L,- |
- |
| 211 | -- |
- ...) {
- |
- |
| 212 | -10x | -
- afuns <- a_survival_subgroups(na_str = na_str)[vars]- |
- |
| 213 | -10x | -
- colvars <- d_survival_subgroups_colvars(- |
- |
| 214 | -10x | -
- vars,- |
- |
| 215 | -10x | -
- conf_level = df$conf_level[1],- |
- |
| 216 | -10x | -
- method = df$pval_label[1],- |
- |
| 217 | -10x | -
- time_unit = time_unit- |
- |
| 218 | -- |
- )- |
- |
| 219 | -10x | -
- h_tab_one_biomarker(- |
- |
| 220 | -10x | -
- df = df,- |
- |
| 221 | -10x | -
- afuns = afuns,- |
- |
| 222 | -10x | -
- colvars = colvars,- |
- |
| 223 | -10x | -
- na_str = na_str,- |
- |
| 224 | -10x | -
- .indent_mods = .indent_mods,- |
- |
| 225 | -- |
- ...- |
- |
| 226 | -- |
- )- |
- |
| 227 | -- |
- }- |
-
| 1 | -- |
- #' Stack multiple grobs- |
- ||
| 2 | -- |
- #'- |
- ||
| 3 | -- |
- #' @description `r lifecycle::badge("deprecated")`
- |
- ||
| 4 | -- |
- #'- |
- ||
| 5 | -- |
- #' Stack grobs as a new grob with 1 column and multiple rows layout.- |
- ||
| 6 | -
#' |
|||
| 7 | -- |
- #' @param ... grobs.- |
- ||
| 8 | -- |
- #' @param grobs (`list` of `grob`)\cr a list of grobs.- |
- ||
| 9 | -- |
- #' @param padding (`grid::unit`)\cr unit of length 1, space between each grob.- |
- ||
| 10 | -- |
- #' @param vp (`viewport` or `NULL`)\cr a [viewport()] object (or `NULL`).- |
- ||
| 11 | -- |
- #' @param name (`string`)\cr a character identifier for the grob.- |
- ||
| 12 | -- |
- #' @param gp (`gpar`)\cr a [gpar()] object.- |
- ||
| 13 | +211 |
- #'+ #' z <- format_xx("xx.x - xx.x")
|
||
| 14 | +212 |
- #' @return A `grob`.+ #' sapply(test, z) |
||
| 15 | +213 |
#' |
||
| 16 | +214 |
- #' @examples+ #' z <- format_xx("xx.x, incl. xx.x% NE")
|
||
| 17 | +215 |
- #' library(grid)+ #' sapply(test, z) |
||
| 18 | +216 |
#' |
||
| 19 | -- |
- #' g1 <- circleGrob(gp = gpar(col = "blue"))- |
- ||
| 20 | -- |
- #' g2 <- circleGrob(gp = gpar(col = "red"))- |
- ||
| 21 | -- |
- #' g3 <- textGrob("TEST TEXT")
- |
- ||
| 22 | -- |
- #' grid.newpage()- |
- ||
| 23 | +217 |
- #' grid.draw(stack_grobs(g1, g2, g3))+ #' @family formatting functions |
||
| 24 | +218 |
- #'+ #' @export |
||
| 25 | +219 |
- #' showViewport()+ format_xx <- function(str) {
|
||
| 26 | +220 |
- #'+ # Find position in the string. |
||
| 27 | -+ | |||
| 221 | +1x |
- #' grid.newpage()+ positions <- gregexpr(pattern = "x+\\.x+|x+", text = str, perl = TRUE) |
||
| 28 | -+ | |||
| 222 | +1x |
- #' pushViewport(viewport(layout = grid.layout(1, 2)))+ x_positions <- regmatches(x = str, m = positions)[[1]] |
||
| 29 | +223 |
- #' vp1 <- viewport(layout.pos.row = 1, layout.pos.col = 2)+ |
||
| 30 | +224 |
- #' grid.draw(stack_grobs(g1, g2, g3, vp = vp1, name = "test"))+ # Roundings depends on the number of x behind [.]. |
||
| 31 | -+ | |||
| 225 | +1x |
- #'+ roundings <- lapply( |
||
| 32 | -+ | |||
| 226 | +1x |
- #' showViewport()+ X = x_positions, |
||
| 33 | -+ | |||
| 227 | +1x |
- #' grid.ls(grobs = TRUE, viewports = TRUE, print = FALSE)+ function(x) {
|
||
| 34 | -+ | |||
| 228 | +2x |
- #'+ y <- strsplit(split = "\\.", x = x)[[1]] |
||
| 35 | -+ | |||
| 229 | +2x |
- #' @export+ rounding <- function(x) {
|
||
| 36 | -+ | |||
| 230 | +4x |
- stack_grobs <- function(...,+ round(x, digits = ifelse(length(y) > 1, nchar(y[2]), 0)) |
||
| 37 | +231 |
- grobs = list(...),+ } |
||
| 38 | -+ | |||
| 232 | +2x |
- padding = grid::unit(2, "line"),+ return(rounding) |
||
| 39 | +233 |
- vp = NULL,+ } |
||
| 40 | +234 |
- gp = NULL,+ ) |
||
| 41 | +235 |
- name = NULL) {
+
|
||
| 42 | -4x | +236 | +1x |
- lifecycle::deprecate_warn(+ rtable_format <- function(x, output) {
|
| 43 | -4x | +237 | +2x |
- "0.9.4",+ values <- Map(y = x, fun = roundings, function(y, fun) fun(y)) |
| 44 | -4x | +238 | +2x |
- "stack_grobs()",+ regmatches(x = str, m = positions)[[1]] <- values |
| 45 | -4x | +239 | +2x |
- details = "`tern` plotting functions no longer generate `grob` objects."+ return(str) |
| 46 | +240 |
- )+ } |
||
| 47 | +241 | |||
| 48 | -4x | -
- checkmate::assert_true(- |
- ||
| 49 | -4x | +242 | +1x |
- all(vapply(grobs, grid::is.grob, logical(1)))+ return(rtable_format) |
| 50 | +243 |
- )+ } |
||
| 51 | +244 | |||
| 52 | -4x | -
- if (length(grobs) == 1) {
- |
- ||
| 53 | -1x | -
- return(grobs[[1]])- |
- ||
| 54 | +245 |
- }+ #' Format numeric values by significant figures |
||
| 55 | +246 | - - | -||
| 56 | -3x | -
- n_layout <- 2 * length(grobs) - 1- |
- ||
| 57 | -3x | -
- hts <- lapply(- |
- ||
| 58 | -3x | -
- seq(1, n_layout),- |
- ||
| 59 | -3x | -
- function(i) {
+ #' |
||
| 60 | -39x | +|||
| 247 | +
- if (i %% 2 != 0) {
+ #' Format numeric values to print with a specified number of significant figures. |
|||
| 61 | -21x | +|||
| 248 | +
- grid::unit(1, "null")+ #' |
|||
| 62 | +249 |
- } else {
+ #' @param sigfig (`integer(1)`)\cr number of significant figures to display. |
||
| 63 | -18x | +|||
| 250 | +
- padding+ #' @param format (`string`)\cr the format label (string) to apply when printing the value. Decimal |
|||
| 64 | +251 |
- }+ #' places in string are ignored in favor of formatting by significant figures. Formats options are: |
||
| 65 | +252 |
- }+ #' `"xx"`, `"xx / xx"`, `"(xx, xx)"`, `"xx - xx"`, and `"xx (xx)"`. |
||
| 66 | +253 |
- )+ #' @param num_fmt (`string`)\cr numeric format modifiers to apply to the value. Defaults to `"fg"` for |
||
| 67 | -3x | +|||
| 254 | +
- hts <- do.call(grid::unit.c, hts)+ #' standard significant figures formatting - fixed (non-scientific notation) format (`"f"`) |
|||
| 68 | +255 |
-
+ #' and `sigfig` equal to number of significant figures instead of decimal places (`"g"`). See the |
||
| 69 | -3x | +|||
| 256 | +
- main_vp <- grid::viewport(+ #' [formatC()] `format` argument for more options. |
|||
| 70 | -3x | +|||
| 257 | +
- layout = grid::grid.layout(nrow = n_layout, ncol = 1, heights = hts)+ #' |
|||
| 71 | +258 |
- )+ #' @return An `rtables` formatting function. |
||
| 72 | +259 |
-
+ #' |
||
| 73 | -3x | +|||
| 260 | +
- nested_grobs <- Map(function(g, i) {
+ #' @examples |
|||
| 74 | -21x | +|||
| 261 | +
- grid::gTree(+ #' fmt_3sf <- format_sigfig(3) |
|||
| 75 | -21x | +|||
| 262 | +
- children = grid::gList(g),+ #' fmt_3sf(1.658) |
|||
| 76 | -21x | +|||
| 263 | +
- vp = grid::viewport(layout.pos.row = i, layout.pos.col = 1)+ #' fmt_3sf(1e1) |
|||
| 77 | +264 |
- )+ #' |
||
| 78 | -3x | +|||
| 265 | +
- }, grobs, seq_along(grobs) * 2 - 1)+ #' fmt_5sf <- format_sigfig(5) |
|||
| 79 | +266 |
-
+ #' fmt_5sf(0.57) |
||
| 80 | -3x | +|||
| 267 | +
- grobs_mainvp <- grid::gTree(+ #' fmt_5sf(0.000025645) |
|||
| 81 | -3x | +|||
| 268 | +
- children = do.call(grid::gList, nested_grobs),+ #' |
|||
| 82 | -3x | +|||
| 269 | +
- vp = main_vp+ #' @family formatting functions |
|||
| 83 | +270 |
- )+ #' @export |
||
| 84 | +271 |
-
+ format_sigfig <- function(sigfig, format = "xx", num_fmt = "fg") {
|
||
| 85 | +272 | 3x |
- grid::gTree(+ checkmate::assert_integerish(sigfig) |
|
| 86 | +273 | 3x |
- children = grid::gList(grobs_mainvp),+ format <- gsub("xx\\.|xx\\.x+", "xx", format)
|
|
| 87 | +274 | 3x |
- vp = vp,+ checkmate::assert_choice(format, c("xx", "xx / xx", "(xx, xx)", "xx - xx", "xx (xx)"))
|
|
| 88 | +275 | 3x |
- gp = gp,+ function(x, ...) {
|
|
| 89 | -3x | +|||
| 276 | +! |
- name = name+ if (!is.numeric(x)) stop("`format_sigfig` cannot be used for non-numeric values. Please choose another format.")
|
||
| 90 | -+ | |||
| 277 | +12x |
- )+ num <- formatC(signif(x, digits = sigfig), digits = sigfig, format = num_fmt, flag = "#") |
||
| 91 | -+ | |||
| 278 | +12x |
- }+ num <- gsub("\\.$", "", num) # remove trailing "."
|
||
| 92 | +279 | |||
| 93 | -+ | |||
| 280 | +12x |
- #' Arrange multiple grobs+ format_value(num, format) |
||
| 94 | +281 |
- #'+ } |
||
| 95 | +282 |
- #' @description `r lifecycle::badge("deprecated")`
+ } |
||
| 96 | +283 |
- #'+ |
||
| 97 | +284 |
- #' Arrange grobs as a new grob with `n * m (rows * cols)` layout.+ #' Format fraction with lower threshold |
||
| 98 | +285 |
#' |
||
| 99 | +286 |
- #' @inheritParams stack_grobs+ #' @description `r lifecycle::badge("stable")`
|
||
| 100 | +287 |
- #' @param ncol (`integer(1)`)\cr number of columns in layout.+ #' |
||
| 101 | +288 |
- #' @param nrow (`integer(1)`)\cr number of rows in layout.+ #' Formats a fraction when the second element of the input `x` is the fraction. It applies |
||
| 102 | +289 |
- #' @param padding_ht (`grid::unit`)\cr unit of length 1, vertical space between each grob.+ #' a lower threshold, below which it is just stated that the fraction is smaller than that. |
||
| 103 | +290 |
- #' @param padding_wt (`grid::unit`)\cr unit of length 1, horizontal space between each grob.+ #' |
||
| 104 | +291 |
- #'+ #' @param threshold (`proportion`)\cr lower threshold. |
||
| 105 | +292 |
- #' @return A `grob`.+ #' |
||
| 106 | +293 |
- #'+ #' @return An `rtables` formatting function that takes numeric input `x` where the second |
||
| 107 | +294 |
- #' @examples+ #' element is the fraction that is formatted. If the fraction is above or equal to the threshold, |
||
| 108 | +295 |
- #' library(grid)+ #' then it is displayed in percentage. If it is positive but below the threshold, it returns, |
||
| 109 | +296 |
- #'+ #' e.g. "<1" if the threshold is `0.01`. If it is zero, then just "0" is returned. |
||
| 110 | +297 |
- #' \donttest{
+ #' |
||
| 111 | +298 |
- #' num <- lapply(1:9, textGrob)+ #' @examples |
||
| 112 | +299 |
- #' grid::grid.newpage()+ #' format_fun <- format_fraction_threshold(0.05) |
||
| 113 | +300 |
- #' grid.draw(arrange_grobs(grobs = num, ncol = 2))+ #' format_fun(x = c(20, 0.1)) |
||
| 114 | +301 |
- #'+ #' format_fun(x = c(2, 0.01)) |
||
| 115 | +302 |
- #' showViewport()+ #' format_fun(x = c(0, 0)) |
||
| 116 | +303 |
#' |
||
| 117 | +304 |
- #' g1 <- circleGrob(gp = gpar(col = "blue"))+ #' @family formatting functions |
||
| 118 | +305 |
- #' g2 <- circleGrob(gp = gpar(col = "red"))+ #' @export |
||
| 119 | +306 |
- #' g3 <- textGrob("TEST TEXT")
+ format_fraction_threshold <- function(threshold) {
|
||
| 120 | -+ | |||
| 307 | +1x |
- #' grid::grid.newpage()+ assert_proportion_value(threshold) |
||
| 121 | -+ | |||
| 308 | +1x |
- #' grid.draw(arrange_grobs(g1, g2, g3, nrow = 2))+ string_below_threshold <- paste0("<", round(threshold * 100))
|
||
| 122 | -+ | |||
| 309 | +1x |
- #'+ function(x, ...) {
|
||
| 123 | -+ | |||
| 310 | +3x |
- #' showViewport()+ assert_proportion_value(x[2], include_boundaries = TRUE) |
||
| 124 | -+ | |||
| 311 | +3x |
- #'+ ifelse( |
||
| 125 | -+ | |||
| 312 | +3x |
- #' grid::grid.newpage()+ x[2] > 0.01, |
||
| 126 | -+ | |||
| 313 | +3x |
- #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 3))+ round(x[2] * 100), |
||
| 127 | -+ | |||
| 314 | +3x |
- #'+ ifelse( |
||
| 128 | -+ | |||
| 315 | +3x |
- #' grid::grid.newpage()+ x[2] == 0, |
||
| 129 | -+ | |||
| 316 | +3x |
- #' grid::pushViewport(grid::viewport(layout = grid::grid.layout(1, 2)))+ "0", |
||
| 130 | -+ | |||
| 317 | +3x |
- #' vp1 <- grid::viewport(layout.pos.row = 1, layout.pos.col = 2)+ string_below_threshold |
||
| 131 | +318 |
- #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 2, vp = vp1))+ ) |
||
| 132 | +319 |
- #'+ ) |
||
| 133 | +320 |
- #' showViewport()+ } |
||
| 134 | +321 |
- #' }+ } |
||
| 135 | +322 |
- #' @export+ |
||
| 136 | +323 |
- arrange_grobs <- function(...,+ #' Format extreme values |
||
| 137 | +324 |
- grobs = list(...),+ #' |
||
| 138 | +325 |
- ncol = NULL, nrow = NULL,+ #' @description `r lifecycle::badge("stable")`
|
||
| 139 | +326 |
- padding_ht = grid::unit(2, "line"),+ #' |
||
| 140 | +327 |
- padding_wt = grid::unit(2, "line"),+ #' `rtables` formatting functions that handle extreme values. |
||
| 141 | +328 |
- vp = NULL,+ #' |
||
| 142 | +329 |
- gp = NULL,+ #' @param digits (`integer(1)`)\cr number of decimal places to display. |
||
| 143 | +330 |
- name = NULL) {
- |
- ||
| 144 | -5x | -
- lifecycle::deprecate_warn(+ #' |
||
| 145 | -5x | +|||
| 331 | +
- "0.9.4",+ #' @details For each input, apply a format to the specified number of `digits`. If the value is |
|||
| 146 | -5x | +|||
| 332 | +
- "arrange_grobs()",+ #' below a threshold, it returns "<0.01" e.g. if the number of `digits` is 2. If the value is |
|||
| 147 | -5x | +|||
| 333 | +
- details = "`tern` plotting functions no longer generate `grob` objects."+ #' above a threshold, it returns ">999.99" e.g. if the number of `digits` is 2. |
|||
| 148 | +334 |
- )+ #' If it is zero, then returns "0.00". |
||
| 149 | +335 |
-
+ #' |
||
| 150 | -5x | +|||
| 336 | +
- checkmate::assert_true(+ #' @family formatting functions |
|||
| 151 | -5x | +|||
| 337 | +
- all(vapply(grobs, grid::is.grob, logical(1)))+ #' @name extreme_format |
|||
| 152 | +338 |
- )+ NULL |
||
| 153 | +339 | |||
| 154 | -5x | -
- if (length(grobs) == 1) {
- |
- ||
| 155 | -1x | -
- return(grobs[[1]])- |
- ||
| 156 | +340 |
- }+ #' @describeIn extreme_format Internal helper function to calculate the threshold and create formatted strings |
||
| 157 | +341 |
-
+ #' used in Formatting Functions. Returns a list with elements `threshold` and `format_string`. |
||
| 158 | -4x | +|||
| 342 | +
- if (is.null(ncol) && is.null(nrow)) {
+ #' |
|||
| 159 | -1x | +|||
| 343 | +
- ncol <- 1+ #' @return |
|||
| 160 | -1x | +|||
| 344 | +
- nrow <- ceiling(length(grobs) / ncol)+ #' * `h_get_format_threshold()` returns a `list` of 2 elements: `threshold`, with `low` and `high` thresholds, |
|||
| 161 | -3x | +|||
| 345 | +
- } else if (!is.null(ncol) && is.null(nrow)) {
+ #' and `format_string`, with thresholds formatted as strings. |
|||
| 162 | -1x | +|||
| 346 | +
- nrow <- ceiling(length(grobs) / ncol)+ #' |
|||
| 163 | -2x | +|||
| 347 | +
- } else if (is.null(ncol) && !is.null(nrow)) {
+ #' @examples |
|||
| 164 | -! | +|||
| 348 | +
- ncol <- ceiling(length(grobs) / nrow)+ #' h_get_format_threshold(2L) |
|||
| 165 | +349 |
- }+ #' |
||
| 166 | +350 |
-
+ #' @export |
||
| 167 | -4x | +|||
| 351 | +
- if (ncol * nrow < length(grobs)) {
+ h_get_format_threshold <- function(digits = 2L) {
|
|||
| 168 | -1x | -
- stop("specififed ncol and nrow are not enough for arranging the grobs ")
- |
- ||
| 169 | -+ | 352 | +2113x |
- }+ checkmate::assert_integerish(digits) |
| 170 | +353 | |||
| 171 | -3x | +354 | +2113x |
- if (ncol == 1) {
+ low_threshold <- 1 / (10 ^ digits) # styler: off |
| 172 | -2x | -
- return(stack_grobs(grobs = grobs, padding = padding_ht, vp = vp, gp = gp, name = name))- |
- ||
| 173 | -+ | 355 | +2113x |
- }+ high_threshold <- 1000 - (1 / (10 ^ digits)) # styler: off |
| 174 | +356 | |||
| 175 | -1x | -
- n_col <- 2 * ncol - 1- |
- ||
| 176 | -1x | +357 | +2113x |
- n_row <- 2 * nrow - 1+ string_below_threshold <- paste0("<", low_threshold)
|
| 177 | -1x | +358 | +2113x |
- hts <- lapply(+ string_above_threshold <- paste0(">", high_threshold)
|
| 178 | -1x | +|||
| 359 | +
- seq(1, n_row),+ |
|||
| 179 | -1x | +360 | +2113x |
- function(i) {
+ list( |
| 180 | -5x | +361 | +2113x |
- if (i %% 2 != 0) {
+ "threshold" = c(low = low_threshold, high = high_threshold), |
| 181 | -3x | +362 | +2113x |
- grid::unit(1, "null")+ "format_string" = c(low = string_below_threshold, high = string_above_threshold) |
| 182 | +363 |
- } else {
- |
- ||
| 183 | -2x | -
- padding_ht+ ) |
||
| 184 | +364 |
- }+ } |
||
| 185 | +365 |
- }+ |
||
| 186 | +366 |
- )+ #' @describeIn extreme_format Internal helper function to apply a threshold format to a value. |
||
| 187 | -1x | +|||
| 367 | +
- hts <- do.call(grid::unit.c, hts)+ #' Creates a formatted string to be used in Formatting Functions. |
|||
| 188 | +368 |
-
+ #' |
||
| 189 | -1x | +|||
| 369 | +
- wts <- lapply(+ #' @param x (`numeric(1)`)\cr value to format. |
|||
| 190 | -1x | +|||
| 370 | +
- seq(1, n_col),+ #' |
|||
| 191 | -1x | +|||
| 371 | +
- function(i) {
+ #' @return |
|||
| 192 | -5x | +|||
| 372 | +
- if (i %% 2 != 0) {
+ #' * `h_format_threshold()` returns the given value, or if the value is not within the digit threshold the relation |
|||
| 193 | -3x | +|||
| 373 | +
- grid::unit(1, "null")+ #' of the given value to the digit threshold, as a formatted string. |
|||
| 194 | +374 |
- } else {
+ #' |
||
| 195 | -2x | +|||
| 375 | +
- padding_wt+ #' @examples |
|||
| 196 | +376 |
- }+ #' h_format_threshold(0.001) |
||
| 197 | +377 |
- }+ #' h_format_threshold(1000) |
||
| 198 | +378 |
- )+ #' |
||
| 199 | -1x | +|||
| 379 | +
- wts <- do.call(grid::unit.c, wts)+ #' @export |
|||
| 200 | +380 |
-
+ h_format_threshold <- function(x, digits = 2L) {
|
||
| 201 | -1x | +381 | +2115x |
- main_vp <- grid::viewport(+ if (is.na(x)) {
|
| 202 | -1x | +382 | +4x |
- layout = grid::grid.layout(nrow = n_row, ncol = n_col, widths = wts, heights = hts)+ return(x) |
| 203 | +383 |
- )+ } |
||
| 204 | +384 | |||
| 205 | -1x | +385 | +2111x |
- nested_grobs <- list()+ checkmate::assert_numeric(x, lower = 0) |
| 206 | -1x | +|||
| 386 | +
- k <- 0+ |
|||
| 207 | -1x | +387 | +2111x |
- for (i in seq(nrow) * 2 - 1) {
+ l_fmt <- h_get_format_threshold(digits) |
| 208 | -3x | +|||
| 388 | +
- for (j in seq(ncol) * 2 - 1) {
+
|
|||
| 209 | -9x | +389 | +2111x |
- k <- k + 1+ result <- if (x < l_fmt$threshold["low"] && 0 < x) {
|
| 210 | -9x | +390 | +44x |
- if (k <= length(grobs)) {
+ l_fmt$format_string["low"] |
| 211 | -9x | +391 | +2111x |
- nested_grobs <- c(+ } else if (x > l_fmt$threshold["high"]) {
|
| 212 | -9x | +392 | +99x |
- nested_grobs,+ l_fmt$format_string["high"] |
| 213 | -9x | +|||
| 393 | +
- list(grid::gTree(+ } else {
|
|||
| 214 | -9x | +394 | +1968x |
- children = grid::gList(grobs[[k]]),+ sprintf(fmt = paste0("%.", digits, "f"), x)
|
| 215 | -9x | +|||
| 395 | +
- vp = grid::viewport(layout.pos.row = i, layout.pos.col = j)+ } |
|||
| 216 | +396 |
- ))+ + |
+ ||
| 397 | +2111x | +
+ unname(result) |
||
| 217 | +398 |
- )+ } |
||
| 218 | +399 |
- }+ |
||
| 219 | +400 |
- }+ #' Format a single extreme value |
||
| 220 | +401 |
- }+ #' |
||
| 221 | -1x | +|||
| 402 | +
- grobs_mainvp <- grid::gTree(+ #' @description `r lifecycle::badge("stable")`
|
|||
| 222 | -1x | +|||
| 403 | +
- children = do.call(grid::gList, nested_grobs),+ #' |
|||
| 223 | -1x | +|||
| 404 | +
- vp = main_vp+ #' Create a formatting function for a single extreme value. |
|||
| 224 | +405 |
- )+ #' |
||
| 225 | +406 |
-
+ #' @inheritParams extreme_format |
||
| 226 | -1x | +|||
| 407 | +
- grid::gTree(+ #' |
|||
| 227 | -1x | +|||
| 408 | +
- children = grid::gList(grobs_mainvp),+ #' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme value. |
|||
| 228 | -1x | +|||
| 409 | +
- vp = vp,+ #' |
|||
| 229 | -1x | +|||
| 410 | +
- gp = gp,+ #' @examples |
|||
| 230 | -1x | +|||
| 411 | +
- name = name+ #' format_fun <- format_extreme_values(2L) |
|||
| 231 | +412 |
- )+ #' format_fun(x = 0.127) |
||
| 232 | +413 |
- }+ #' format_fun(x = Inf) |
||
| 233 | +414 |
-
+ #' format_fun(x = 0) |
||
| 234 | +415 |
- #' Draw `grob`+ #' format_fun(x = 0.009) |
||
| 235 | +416 |
#' |
||
| 236 | +417 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' @family formatting functions |
||
| 237 | +418 |
- #'+ #' @export |
||
| 238 | +419 |
- #' Draw grob on device page.+ format_extreme_values <- function(digits = 2L) {
+ |
+ ||
| 420 | +63x | +
+ function(x, ...) {
+ |
+ ||
| 421 | +657x | +
+ checkmate::assert_scalar(x, na.ok = TRUE) |
||
| 239 | +422 |
- #'+ + |
+ ||
| 423 | +657x | +
+ h_format_threshold(x = x, digits = digits) |
||
| 240 | +424 |
- #' @param grob (`grob`)\cr grid object.+ } |
||
| 241 | +425 |
- #' @param newpage (`flag`)\cr draw on a new page.+ } |
||
| 242 | +426 |
- #' @param vp (`viewport` or `NULL`)\cr a [viewport()] object (or `NULL`).+ |
||
| 243 | +427 |
- #'+ #' Format extreme values part of a confidence interval |
||
| 244 | +428 |
- #' @return A `grob`.+ #' |
||
| 245 | +429 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 246 | +430 |
- #' @examples+ #' |
||
| 247 | +431 |
- #' library(dplyr)+ #' Formatting Function for extreme values part of a confidence interval. Values |
||
| 248 | +432 |
- #' library(grid)+ #' are formatted as e.g. "(xx.xx, xx.xx)" if the number of `digits` is 2. |
||
| 249 | +433 |
#' |
||
| 250 | +434 |
- #' \donttest{
+ #' @inheritParams extreme_format |
||
| 251 | +435 |
- #' rect <- rectGrob(width = grid::unit(0.5, "npc"), height = grid::unit(0.5, "npc"))+ #' |
||
| 252 | +436 |
- #' rect %>% draw_grob(vp = grid::viewport(angle = 45))+ #' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme |
||
| 253 | +437 |
- #'+ #' values confidence interval. |
||
| 254 | +438 |
- #' num <- lapply(1:10, textGrob)+ #' |
||
| 255 | +439 |
- #' num %>%+ #' @examples |
||
| 256 | +440 |
- #' arrange_grobs(grobs = .) %>%+ #' format_fun <- format_extreme_values_ci(2L) |
||
| 257 | +441 |
- #' draw_grob()+ #' format_fun(x = c(0.127, Inf)) |
||
| 258 | +442 |
- #' showViewport()+ #' format_fun(x = c(0, 0.009)) |
||
| 259 | +443 |
- #' }+ #' |
||
| 260 | +444 |
- #'+ #' @family formatting functions |
||
| 261 | +445 |
#' @export |
||
| 262 | +446 |
- draw_grob <- function(grob, newpage = TRUE, vp = NULL) {
+ format_extreme_values_ci <- function(digits = 2L) {
|
||
| 263 | -3x | +447 | +71x |
- lifecycle::deprecate_warn(+ function(x, ...) {
|
| 264 | -3x | +448 | +726x |
- "0.9.4",+ checkmate::assert_vector(x, len = 2) |
| 265 | -3x | +449 | +726x |
- "draw_grob()",+ l_result <- h_format_threshold(x = x[1], digits = digits) |
| 266 | -3x | -
- details = "`tern` plotting functions no longer generate `grob` objects."- |
- ||
| 267 | -+ | 450 | +726x |
- )+ h_result <- h_format_threshold(x = x[2], digits = digits) |
| 268 | +451 | |||
| 269 | -3x | -
- if (newpage) {
- |
- ||
| 270 | -3x | +452 | +726x |
- grid::grid.newpage()+ paste0("(", l_result, ", ", h_result, ")")
|
| 271 | +453 |
} |
||
| 272 | -3x | -
- if (!is.null(vp)) {
- |
- ||
| 273 | -1x | -
- grid::pushViewport(vp)- |
- ||
| 274 | +454 |
- }+ } |
||
| 275 | -3x | +|||
| 455 | +
- grid::grid.draw(grob)+ |
|||
| 276 | +456 |
- }+ #' Format automatically using data significant digits |
||
| 277 | +457 |
-
+ #' |
||
| 278 | +458 |
- tern_grob <- function(x) {
+ #' @description `r lifecycle::badge("stable")`
|
||
| 279 | -! | +|||
| 459 | +
- class(x) <- unique(c("ternGrob", class(x)))
+ #' |
|||
| 280 | -! | +|||
| 460 | +
- x+ #' Formatting function for the majority of default methods used in [analyze_vars()]. |
|||
| 281 | +461 |
- }+ #' For non-derived values, the significant digits of data is used (e.g. range), while derived |
||
| 282 | +462 |
-
+ #' values have one more digits (measure of location and dispersion like mean, standard deviation). |
||
| 283 | +463 |
- #' @keywords internal+ #' This function can be called internally with "auto" like, for example, |
||
| 284 | +464 |
- print.ternGrob <- function(x, ...) {
+ #' `.formats = c("mean" = "auto")`. See details to see how this works with the inner function.
|
||
| 285 | -! | +|||
| 465 | +
- grid::grid.newpage()+ #' |
|||
| 286 | -! | +|||
| 466 | +
- grid::grid.draw(x)+ #' @param dt_var (`numeric`)\cr variable data the statistics were calculated from. Used only to |
|||
| 287 | +467 |
- }+ #' find significant digits. In [analyze_vars] this comes from `.df_row` (see |
| 1 | +468 |
- #' Count occurrences by grade+ #' [rtables::additional_fun_params]), and it is the row data after the above row splits. No |
||
| 2 | +469 |
- #'+ #' column split is considered. |
||
| 3 | +470 |
- #' @description `r lifecycle::badge("stable")`
+ #' @param x_stat (`string`)\cr string indicating the current statistical method used. |
||
| 4 | +471 |
#' |
||
| 5 | +472 |
- #' The analyze function [count_occurrences_by_grade()] creates a layout element to calculate occurrence counts by grade.+ #' @return A string that `rtables` prints in a table cell. |
||
| 6 | +473 |
#' |
||
| 7 | +474 |
- #' This function analyzes primary analysis variable `var` which indicates toxicity grades. The `id` variable+ #' @details |
||
| 8 | +475 |
- #' is used to indicate unique subject identifiers (defaults to `USUBJID`). The user can also supply a list of+ #' The internal function is needed to work with `rtables` default structure for |
||
| 9 | +476 |
- #' custom groups of grades to analyze via the `grade_groups` parameter. The `remove_single` argument will+ #' format functions, i.e. `function(x, ...)`, where is x are results from statistical evaluation. |
||
| 10 | +477 |
- #' remove single grades from the analysis so that *only* grade groups are analyzed.+ #' It can be more than one element (e.g. for `.stats = "mean_sd"`). |
||
| 11 | +478 |
#' |
||
| 12 | +479 |
- #' If there are multiple grades recorded for one patient only the highest grade level is counted.+ #' @examples |
||
| 13 | +480 |
- #'+ #' x_todo <- c(0.001, 0.2, 0.0011000, 3, 4) |
||
| 14 | +481 |
- #' The summarize function [summarize_occurrences_by_grade()] performs the same function as+ #' res <- c(mean(x_todo[1:3]), sd(x_todo[1:3])) |
||
| 15 | +482 |
- #' [count_occurrences_by_grade()] except it creates content rows, not data rows, to summarize the current table+ #' |
||
| 16 | +483 |
- #' row/column context and operates on the level of the latest row split or the root of the table if no row splits have+ #' # x is the result coming into the formatting function -> res!! |
||
| 17 | +484 |
- #' occurred.+ #' format_auto(dt_var = x_todo, x_stat = "mean_sd")(x = res) |
||
| 18 | +485 |
- #'+ #' format_auto(x_todo, "range")(x = range(x_todo)) |
||
| 19 | +486 |
- #' @inheritParams count_occurrences+ #' no_sc_x <- c(0.0000001, 1) |
||
| 20 | +487 |
- #' @inheritParams argument_convention+ #' format_auto(no_sc_x, "range")(x = no_sc_x) |
||
| 21 | +488 |
- #' @param grade_groups (named `list` of `character`)\cr list containing groupings of grades.+ #' |
||
| 22 | +489 |
- #' @param remove_single (`flag`)\cr `TRUE` to not include the elements of one-element grade groups+ #' @family formatting functions |
||
| 23 | +490 |
- #' in the the output list; in this case only the grade groups names will be included in the output. If+ #' @export |
||
| 24 | +491 |
- #' `only_grade_groups` is set to `TRUE` this argument is ignored.+ format_auto <- function(dt_var, x_stat) {
|
||
| 25 | -+ | |||
| 492 | +14x |
- #' @param only_grade_groups (`flag`)\cr whether only the specified grade groups should be+ function(x = "", ...) {
|
||
| 26 | -+ | |||
| 493 | +31x |
- #' included, with individual grade rows removed (`TRUE`), or all grades and grade groups+ checkmate::assert_numeric(x, min.len = 1) |
||
| 27 | -+ | |||
| 494 | +31x |
- #' should be displayed (`FALSE`).+ checkmate::assert_numeric(dt_var, min.len = 1) |
||
| 28 | +495 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ # Defaults - they may be a param in the future |
||
| 29 | -+ | |||
| 496 | +31x |
- #'+ der_stats <- c( |
||
| 30 | -+ | |||
| 497 | +31x |
- #' Options are: ``r shQuote(get_stats("count_occurrences_by_grade"))``
+ "mean", "sd", "se", "median", "geom_mean", "quantiles", "iqr", |
||
| 31 | -+ | |||
| 498 | +31x |
- #'+ "mean_sd", "mean_se", "mean_se", "mean_ci", "mean_sei", "mean_sdi", |
||
| 32 | -+ | |||
| 499 | +31x |
- #' @seealso Relevant helper function [h_append_grade_groups()].+ "median_ci" |
||
| 33 | +500 |
- #'+ ) |
||
| 34 | -+ | |||
| 501 | +31x |
- #' @name count_occurrences_by_grade+ nonder_stats <- c("n", "range", "min", "max")
|
||
| 35 | +502 |
- #' @order 1+ |
||
| 36 | +503 |
- NULL+ # Safenet for miss-modifications |
||
| 37 | -+ | |||
| 504 | +31x |
-
+ stopifnot(length(intersect(der_stats, nonder_stats)) == 0) # nolint |
||
| 38 | -+ | |||
| 505 | +31x |
- #' Helper function for `s_count_occurrences_by_grade()`+ checkmate::assert_choice(x_stat, c(der_stats, nonder_stats)) |
||
| 39 | +506 |
- #'+ |
||
| 40 | +507 |
- #' @description `r lifecycle::badge("stable")`
+ # Finds the max number of digits in data |
||
| 41 | -+ | |||
| 508 | +31x |
- #'+ detect_dig <- vapply(dt_var, count_decimalplaces, FUN.VALUE = numeric(1)) %>% |
||
| 42 | -+ | |||
| 509 | +31x |
- #' Helper function for [s_count_occurrences_by_grade()] to insert grade groupings into list with+ max() |
||
| 43 | +510 |
- #' individual grade frequencies. The order of the final result follows the order of `grade_groups`.+ |
||
| 44 | -+ | |||
| 511 | +31x |
- #' The elements under any-grade group (if any), i.e. the grade group equal to `refs` will be moved to+ if (x_stat %in% der_stats) {
|
||
| 45 | -+ | |||
| 512 | +19x |
- #' the end. Grade groups names must be unique.+ detect_dig <- detect_dig + 1 |
||
| 46 | +513 |
- #'+ } |
||
| 47 | +514 |
- #' @inheritParams count_occurrences_by_grade+ |
||
| 48 | +515 |
- #' @param refs (named `list` of `numeric`)\cr named list where each name corresponds to a reference grade level+ # Render input |
||
| 49 | -+ | |||
| 516 | +31x |
- #' and each entry represents a count.+ str_vals <- formatC(x, digits = detect_dig, format = "f") |
||
| 50 | -+ | |||
| 517 | +31x |
- #'+ def_fmt <- get_formats_from_stats(x_stat)[[x_stat]] |
||
| 51 | -+ | |||
| 518 | +31x |
- #' @return Formatted list of grade groupings.+ str_fmt <- str_extract(def_fmt, invert = FALSE)[[1]] |
||
| 52 | -+ | |||
| 519 | +31x |
- #'+ if (length(str_fmt) != length(str_vals)) {
|
||
| 53 | -+ | |||
| 520 | +2x |
- #' @examples+ stop( |
||
| 54 | -+ | |||
| 521 | +2x |
- #' h_append_grade_groups(+ "Number of inserted values as result (", length(str_vals),
|
||
| 55 | -+ | |||
| 522 | +2x |
- #' list(+ ") is not the same as there should be in the default tern formats for ", |
||
| 56 | -+ | |||
| 523 | +2x |
- #' "Any Grade" = as.character(1:5),+ x_stat, " (-> ", def_fmt, " needs ", length(str_fmt), " values). ", |
||
| 57 | -+ | |||
| 524 | +2x |
- #' "Grade 1-2" = c("1", "2"),
+ "See tern_default_formats to check all of them." |
||
| 58 | +525 |
- #' "Grade 3-4" = c("3", "4")
+ ) |
||
| 59 | +526 |
- #' ),+ } |
||
| 60 | +527 |
- #' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
+
|
||
| 61 | +528 |
- #' )+ # Squashing them together |
||
| 62 | -+ | |||
| 529 | +29x |
- #'+ inv_str_fmt <- str_extract(def_fmt, invert = TRUE)[[1]] |
||
| 63 | -+ | |||
| 530 | +29x |
- #' h_append_grade_groups(+ stopifnot(length(inv_str_fmt) == length(str_vals) + 1) # nolint |
||
| 64 | +531 |
- #' list(+ |
||
| 65 | -+ | |||
| 532 | +29x |
- #' "Any Grade" = as.character(5:1),+ out <- vector("character", length = length(inv_str_fmt) + length(str_vals))
|
||
| 66 | -+ | |||
| 533 | +29x |
- #' "Grade A" = "5",+ is_even <- seq_along(out) %% 2 == 0 |
||
| 67 | -+ | |||
| 534 | +29x |
- #' "Grade B" = c("4", "3")
+ out[is_even] <- str_vals |
||
| 68 | -+ | |||
| 535 | +29x |
- #' ),+ out[!is_even] <- inv_str_fmt |
||
| 69 | +536 |
- #' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
+
|
||
| 70 | -+ | |||
| 537 | +29x |
- #' )+ return(paste0(out, collapse = "")) |
||
| 71 | +538 |
- #'+ } |
||
| 72 | +539 |
- #' h_append_grade_groups(+ } |
||
| 73 | +540 |
- #' list(+ |
||
| 74 | +541 |
- #' "Any Grade" = as.character(1:5),+ # Utility function that could be useful in general |
||
| 75 | +542 |
- #' "Grade 1-2" = c("1", "2"),
+ str_extract <- function(string, pattern = "xx|xx\\.|xx\\.x+", invert = FALSE) {
|
||
| 76 | -+ | |||
| 543 | +60x |
- #' "Grade 3-4" = c("3", "4")
+ regmatches(string, gregexpr(pattern, string), invert = invert) |
||
| 77 | +544 |
- #' ),+ } |
||
| 78 | +545 |
- #' list("1" = 10, "2" = 5, "3" = 0)
+
|
||
| 79 | +546 |
- #' )+ # Helper function |
||
| 80 | +547 |
- #'+ count_decimalplaces <- function(dec) {
|
||
| 81 | -+ | |||
| 548 | +226x |
- #' @export+ if (is.na(dec)) {
|
||
| 82 | -+ | |||
| 549 | +6x |
- h_append_grade_groups <- function(grade_groups, refs, remove_single = TRUE, only_grade_groups = FALSE) {
+ return(0) |
||
| 83 | -32x | +550 | +220x |
- checkmate::assert_list(grade_groups)+ } else if (abs(dec - round(dec)) > .Machine$double.eps^0.5) { # For precision
|
| 84 | -32x | +551 | +161x |
- checkmate::assert_list(refs)+ nchar(strsplit(format(dec, scientific = FALSE, trim = FALSE), ".", fixed = TRUE)[[1]][[2]]) |
| 85 | -32x | +|||
| 552 | +
- refs_orig <- refs+ } else {
|
|||
| 86 | -32x | +553 | +59x |
- elements <- unique(unlist(grade_groups))+ return(0) |
| 87 | +554 |
-
+ } |
||
| 88 | +555 |
- ### compute sums in groups+ } |
||
| 89 | -32x | +|||
| 556 | +
- grp_sum <- lapply(grade_groups, function(i) do.call(sum, refs[i]))+ |
|||
| 90 | -32x | +|||
| 557 | +
- if (!checkmate::test_subset(elements, names(refs))) {
+ #' Apply automatic formatting |
|||
| 91 | -2x | +|||
| 558 | +
- padding_el <- setdiff(elements, names(refs))+ #' |
|||
| 92 | -2x | +|||
| 559 | +
- refs[padding_el] <- 0+ #' Checks if any of the listed formats in `.formats` are `"auto"`, and replaces `"auto"` with |
|||
| 93 | +560 |
- }+ #' the correct implementation of `format_auto` for the given statistics, data, and variable. |
||
| 94 | -32x | +|||
| 561 | +
- result <- c(grp_sum, refs)+ #' |
|||
| 95 | +562 |
-
+ #' @inheritParams argument_convention |
||
| 96 | +563 |
- ### order result while keeping grade_groups's ordering+ #' @param x_stats (named `list`)\cr a named list of statistics where each element corresponds |
||
| 97 | -32x | +|||
| 564 | +
- ordr <- grade_groups+ #' to an element in `.formats`, with matching names. |
|||
| 98 | +565 |
-
+ #' |
||
| 99 | +566 |
- # elements of any-grade group (if any) will be moved to the end+ #' @keywords internal+ |
+ ||
| 567 | ++ |
+ apply_auto_formatting <- function(.formats, x_stats, .df_row, .var) {
|
||
| 100 | -32x | +568 | +554x |
- is_any <- sapply(grade_groups, setequal, y = names(refs))+ is_auto_fmt <- vapply(.formats, function(ii) is.character(ii) && ii == "auto", logical(1)) |
| 101 | -32x | +569 | +554x |
- ordr[is_any] <- list(character(0)) # hide elements under any-grade group+ if (any(is_auto_fmt)) {
+ |
+
| 570 | +6x | +
+ auto_stats <- x_stats[is_auto_fmt]+ |
+ ||
| 571 | +6x | +
+ var_df <- .df_row[[.var]] # xxx this can be extended for the WHOLE data or single facets+ |
+ ||
| 572 | +6x | +
+ .formats[is_auto_fmt] <- lapply(names(auto_stats), format_auto, dt_var = var_df) |
||
| 102 | +573 |
-
+ }+ |
+ ||
| 574 | +554x | +
+ .formats |
||
| 103 | +575 |
- # groups-elements combined sequence+ } |
||
| 104 | -32x | +
| 1 | +
- ordr <- c(lapply(names(ordr), function(g) c(g, ordr[[g]])), recursive = TRUE, use.names = FALSE)+ #' Count occurrences |
|||
| 105 | -32x | +|||
| 2 | +
- ordr <- ordr[!duplicated(ordr)]+ #' |
|||
| 106 | +3 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 107 | +4 |
- # append remaining elements (if any)+ #' |
||
| 108 | -32x | +|||
| 5 | +
- ordr <- union(ordr, unlist(grade_groups[is_any])) # from any-grade group+ #' The analyze function [count_occurrences()] creates a layout element to calculate occurrence counts for patients. |
|||
| 109 | -32x | +|||
| 6 | +
- ordr <- union(ordr, names(refs)) # from refs+ #' |
|||
| 110 | +7 |
-
+ #' This function analyzes the variable(s) supplied to `vars` and returns a table of occurrence counts for |
||
| 111 | +8 |
- # remove elements of single-element groups, if any+ #' each unique value (or level) of the variable(s). This variable (or variables) must be |
||
| 112 | -32x | +|||
| 9 | +
- if (only_grade_groups) {
+ #' non-numeric. The `id` variable is used to indicate unique subject identifiers (defaults to `USUBJID`). |
|||
| 113 | -3x | +|||
| 10 | +
- ordr <- intersect(ordr, names(grade_groups))+ #' |
|||
| 114 | -29x | +|||
| 11 | +
- } else if (remove_single) {
+ #' If there are multiple occurrences of the same value recorded for a patient, the value is only counted once. |
|||
| 115 | -29x | +|||
| 12 | +
- is_single <- sapply(grade_groups, length) == 1L+ #' |
|||
| 116 | -29x | +|||
| 13 | +
- ordr <- setdiff(ordr, unlist(grade_groups[is_single]))+ #' The summarize function [summarize_occurrences()] performs the same function as [count_occurrences()] except it |
|||
| 117 | +14 |
- }+ #' creates content rows, not data rows, to summarize the current table row/column context and operates on the level of |
||
| 118 | +15 |
-
+ #' the latest row split or the root of the table if no row splits have occurred. |
||
| 119 | +16 |
- # apply the order+ #' |
||
| 120 | -32x | +|||
| 17 | +
- result <- result[ordr]+ #' @inheritParams argument_convention |
|||
| 121 | +18 |
-
+ #' @param drop (`flag`)\cr whether non-appearing occurrence levels should be dropped from the resulting table. |
||
| 122 | +19 |
- # remove groups without any elements in the original refs+ #' Note that in that case the remaining occurrence levels in the table are sorted alphabetically. |
||
| 123 | +20 |
- # note: it's OK if groups have 0 value+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 124 | -32x | +|||
| 21 | +
- keep_grp <- vapply(grade_groups, function(x, rf) {
+ #' |
|||
| 125 | -64x | +|||
| 22 | +
- any(x %in% rf)+ #' Options are: ``r shQuote(get_stats("count_occurrences"), type = "sh")``
|
|||
| 126 | -32x | +|||
| 23 | +
- }, rf = names(refs_orig), logical(1))+ #' |
|||
| 127 | +24 |
-
+ #' @note By default, occurrences which don't appear in a given row split are dropped from the table and |
||
| 128 | -32x | +|||
| 25 | +
- keep_el <- names(result) %in% names(refs_orig) | names(result) %in% names(keep_grp)[keep_grp]+ #' the occurrences in the table are sorted alphabetically per row split. Therefore, the corresponding layout |
|||
| 129 | -32x | +|||
| 26 | +
- result <- result[keep_el]+ #' needs to use `split_fun = drop_split_levels` in the `split_rows_by` calls. Use `drop = FALSE` if you would |
|||
| 130 | +27 |
-
+ #' like to show all occurrences. |
||
| 131 | -32x | +|||
| 28 | +
- result+ #' |
|||
| 132 | +29 |
- }+ #' @examples |
||
| 133 | +30 |
-
+ #' library(dplyr) |
||
| 134 | +31 |
- #' @describeIn count_occurrences_by_grade Statistics function which counts the+ #' df <- data.frame( |
||
| 135 | +32 |
- #' number of patients by highest grade.+ #' USUBJID = as.character(c( |
||
| 136 | +33 |
- #'+ #' 1, 1, 2, 4, 4, 4, |
||
| 137 | +34 |
- #' @return+ #' 6, 6, 6, 7, 7, 8 |
||
| 138 | +35 |
- #' * `s_count_occurrences_by_grade()` returns a list of counts and fractions with one element per grade level or+ #' )), |
||
| 139 | +36 |
- #' grade level grouping.+ #' MHDECOD = c( |
||
| 140 | +37 |
- #'+ #' "MH1", "MH2", "MH1", "MH1", "MH1", "MH3", |
||
| 141 | +38 |
- #' @examples+ #' "MH2", "MH2", "MH3", "MH1", "MH2", "MH4" |
||
| 142 | +39 |
- #' s_count_occurrences_by_grade(+ #' ), |
||
| 143 | +40 |
- #' df,+ #' ARM = rep(c("A", "B"), each = 6),
|
||
| 144 | +41 |
- #' .N_col = 10L,+ #' SEX = c("F", "F", "M", "M", "M", "M", "F", "F", "F", "M", "M", "F")
|
||
| 145 | +42 |
- #' .var = "AETOXGR",+ #' ) |
||
| 146 | +43 |
- #' id = "USUBJID",+ #' df_adsl <- df %>% |
||
| 147 | +44 |
- #' grade_groups = list("ANY" = levels(df$AETOXGR))
+ #' select(USUBJID, ARM) %>% |
||
| 148 | +45 |
- #' )+ #' unique() |
||
| 149 | +46 |
#' |
||
| 150 | +47 |
- #' @export+ #' @name count_occurrences |
||
| 151 | +48 |
- s_count_occurrences_by_grade <- function(df,+ #' @order 1 |
||
| 152 | +49 |
- .var,+ NULL |
||
| 153 | +50 |
- .N_row, # nolint+ |
||
| 154 | +51 |
- .N_col, # nolint+ #' @describeIn count_occurrences Statistics function which counts number of patients that report an |
||
| 155 | +52 |
- id = "USUBJID",+ #' occurrence. |
||
| 156 | +53 |
- grade_groups = list(),+ #' |
||
| 157 | +54 |
- remove_single = TRUE,+ #' @param denom (`string`)\cr choice of denominator for proportion. Options are: |
||
| 158 | +55 |
- only_grade_groups = FALSE,+ #' * `N_col`: total number of patients in this column across rows. |
||
| 159 | +56 |
- denom = c("N_col", "n", "N_row"),
+ #' * `n`: number of patients with any occurrences. |
||
| 160 | +57 |
- labelstr = "") {
+ #' * `N_row`: total number of patients in this row across columns. |
||
| 161 | -75x | +|||
| 58 | +
- assert_valid_factor(df[[.var]])+ #' |
|||
| 162 | -75x | +|||
| 59 | +
- assert_df_with_variables(df, list(grade = .var, id = id))+ #' @return |
|||
| 163 | +60 |
-
+ #' * `s_count_occurrences()` returns a list with: |
||
| 164 | -75x | +|||
| 61 | +
- denom <- match.arg(denom) %>%+ #' * `count`: list of counts with one element per occurrence. |
|||
| 165 | -75x | +|||
| 62 | +
- switch(+ #' * `count_fraction`: list of counts and fractions with one element per occurrence. |
|||
| 166 | -75x | +|||
| 63 | +
- n = nlevels(factor(df[[id]])),+ #' * `fraction`: list of numerators and denominators with one element per occurrence. |
|||
| 167 | -75x | +|||
| 64 | +
- N_row = .N_row,+ #' |
|||
| 168 | -75x | +|||
| 65 | +
- N_col = .N_col+ #' @examples |
|||
| 169 | +66 |
- )+ #' # Count unique occurrences per subject. |
||
| 170 | +67 |
-
+ #' s_count_occurrences( |
||
| 171 | -75x | +|||
| 68 | +
- if (nrow(df) < 1) {
+ #' df, |
|||
| 172 | -5x | +|||
| 69 | +
- grade_levels <- levels(df[[.var]])+ #' .N_col = 4L, |
|||
| 173 | -5x | +|||
| 70 | +
- l_count <- as.list(rep(0, length(grade_levels)))+ #' .N_row = 4L, |
|||
| 174 | -5x | +|||
| 71 | +
- names(l_count) <- grade_levels+ #' .df_row = df, |
|||
| 175 | +72 |
- } else {
+ #' .var = "MHDECOD", |
||
| 176 | -70x | +|||
| 73 | +
- if (isTRUE(is.factor(df[[id]]))) {
+ #' id = "USUBJID" |
|||
| 177 | -! | +|||
| 74 | +
- assert_valid_factor(df[[id]], any.missing = FALSE)+ #' ) |
|||
| 178 | +75 |
- } else {
+ #' |
||
| 179 | -70x | +|||
| 76 | +
- checkmate::assert_character(df[[id]], min.chars = 1, any.missing = FALSE)+ #' @export |
|||
| 180 | +77 |
- }+ s_count_occurrences <- function(df, |
||
| 181 | -70x | +|||
| 78 | +
- checkmate::assert_count(.N_col)+ denom = c("N_col", "n", "N_row"),
|
|||
| 182 | +79 |
-
+ .N_col, # nolint |
||
| 183 | -70x | +|||
| 80 | +
- id <- df[[id]]+ .N_row, # nolint |
|||
| 184 | -70x | +|||
| 81 | +
- grade <- df[[.var]]+ .df_row, |
|||
| 185 | +82 |
-
+ drop = TRUE, |
||
| 186 | -70x | +|||
| 83 | +
- if (!is.ordered(grade)) {
+ .var = "MHDECOD", |
|||
| 187 | -70x | +|||
| 84 | +
- grade_lbl <- obj_label(grade)+ id = "USUBJID") {
|
|||
| 188 | -70x | +85 | +126x |
- lvls <- levels(grade)+ checkmate::assert_flag(drop) |
| 189 | -70x | +86 | +126x |
- if (sum(grepl("^\\d+$", lvls)) %in% c(0, length(lvls))) {
+ assert_df_with_variables(df, list(range = .var, id = id)) |
| 190 | -69x | -
- lvl_ord <- lvls- |
- ||
| 191 | -+ | 87 | +126x |
- } else {
+ checkmate::assert_count(.N_col) |
| 192 | -1x | +88 | +126x |
- lvls[!grepl("^\\d+$", lvls)] <- min(as.numeric(lvls[grepl("^\\d+$", lvls)])) - 1
+ checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
|
| 193 | -1x | +89 | +126x |
- lvl_ord <- levels(grade)[order(as.numeric(lvls))]+ checkmate::assert_multi_class(df[[id]], classes = c("factor", "character"))
|
| 194 | +90 |
- }+ |
||
| 195 | -70x | +91 | +126x |
- grade <- formatters::with_label(factor(grade, levels = lvl_ord, ordered = TRUE), grade_lbl)+ occurrences <- if (drop) {
|
| 196 | +92 |
- }+ # Note that we don't try to preserve original level order here since a) that would required |
||
| 197 | +93 | - - | -||
| 198 | -70x | -
- missing_lvl <- grepl("missing", tolower(levels(grade)))
+ # more time to look up in large original levels and b) that would fail for character input variable. |
||
| 199 | -70x | +94 | +115x |
- if (any(missing_lvl)) {
+ occurrence_levels <- sort(unique(.df_row[[.var]])) |
| 200 | -1x | +95 | +115x |
- grade <- factor(+ if (length(occurrence_levels) == 0) {
|
| 201 | +96 | 1x |
- grade,+ stop( |
|
| 202 | +97 | 1x |
- levels = c(levels(grade)[!missing_lvl], levels(grade)[missing_lvl]),+ "no empty `.df_row` input allowed when `drop = TRUE`,", |
|
| 203 | +98 | 1x |
- ordered = is.ordered(grade)+ " please use `split_fun = drop_split_levels` in the `rtables` `split_rows_by` calls" |
|
| 204 | +99 |
) |
||
| 205 | +100 |
} |
||
| 206 | -70x | +101 | +114x |
- df_max <- stats::aggregate(grade ~ id, FUN = max, drop = FALSE)+ factor(df[[.var]], levels = occurrence_levels)+ |
+
| 102 | ++ |
+ } else {
|
||
| 207 | -70x | +103 | +11x |
- l_count <- as.list(table(df_max$grade))+ df[[.var]] |
| 208 | +104 |
} |
||
| 209 | -+ | |||
| 105 | +125x |
-
+ ids <- factor(df[[id]]) |
||
| 210 | -75x | +106 | +125x |
- if (length(grade_groups) > 0) {
+ denom <- match.arg(denom) %>% |
| 211 | -30x | +107 | +125x |
- l_count <- h_append_grade_groups(grade_groups, l_count, remove_single, only_grade_groups)+ switch( |
| 212 | -+ | |||
| 108 | +125x |
- }+ n = nlevels(ids),+ |
+ ||
| 109 | +125x | +
+ N_row = .N_row,+ |
+ ||
| 110 | +125x | +
+ N_col = .N_col |
||
| 213 | +111 |
-
+ ) |
||
| 214 | -75x | +112 | +125x |
- l_count_fraction <- lapply(+ has_occurrence_per_id <- table(occurrences, ids) > 0 |
| 215 | -75x | +113 | +125x |
- l_count,+ n_ids_per_occurrence <- as.list(rowSums(has_occurrence_per_id)) |
| 216 | -75x | +114 | +125x | +
+ cur_count_fraction <- lapply(+ |
+
| 115 | +125x | +
+ n_ids_per_occurrence,+ |
+ ||
| 116 | +125x |
function(i, denom) {
|
||
| 217 | -299x | +117 | +514x |
if (i == 0 && denom == 0) {
|
| 218 | -9x | +|||
| 118 | +! |
c(0, 0) |
||
| 219 | +119 |
} else {
|
||
| 220 | -290x | +120 | +514x |
c(i, i / denom) |
| 221 | +121 |
} |
||
| 222 | +122 |
}, |
||
| 223 | -75x | +123 | +125x |
denom = denom |
| 224 | +124 |
) |
||
| 225 | +125 | |||
| 226 | -75x | +126 | +125x |
list( |
| 227 | -75x | +127 | +125x |
- count_fraction = l_count_fraction,+ count = n_ids_per_occurrence, |
| 228 | -75x | -
- count_fraction_fixed_dp = l_count_fraction- |
- ||
| 229 | -- |
- )- |
- ||
| 230 | -+ | 128 | +125x |
- }+ count_fraction = cur_count_fraction, |
| 231 | -+ | |||
| 129 | +125x |
-
+ count_fraction_fixed_dp = cur_count_fraction, |
||
| 232 | -+ | |||
| 130 | +125x |
- #' @describeIn count_occurrences_by_grade Formatted analysis function which is used as `afun`+ fraction = lapply( |
||
| 233 | -+ | |||
| 131 | +125x |
- #' in `count_occurrences_by_grade()`.+ n_ids_per_occurrence, |
||
| 234 | -+ | |||
| 132 | +125x |
- #'+ function(i, denom) c("num" = i, "denom" = denom),
|
||
| 235 | -+ | |||
| 133 | +125x |
- #' @return+ denom = denom |
||
| 236 | +134 |
- #' * `a_count_occurrences_by_grade()` returns the corresponding list with formatted [rtables::CellValue()].+ ) |
||
| 237 | +135 |
- #'+ ) |
||
| 238 | +136 |
- #' @examples+ } |
||
| 239 | +137 |
- #' a_count_occurrences_by_grade(+ |
||
| 240 | +138 |
- #' df,+ #' @describeIn count_occurrences Formatted analysis function which is used as `afun` |
||
| 241 | +139 |
- #' .N_col = 10L,+ #' in `count_occurrences()`. |
||
| 242 | +140 |
- #' .N_row = 10L,+ #' |
||
| 243 | +141 |
- #' .var = "AETOXGR",+ #' @return |
||
| 244 | +142 |
- #' id = "USUBJID",+ #' * `a_count_occurrences()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 245 | +143 |
- #' grade_groups = list("ANY" = levels(df$AETOXGR))
+ #' |
||
| 246 | +144 |
- #' )+ #' @examples |
||
| 247 | +145 |
- #'+ #' a_count_occurrences( |
||
| 248 | +146 |
- #' @export+ #' df, |
||
| 249 | +147 |
- a_count_occurrences_by_grade <- function(df,+ #' .N_col = 4L, |
||
| 250 | +148 |
- labelstr = "",+ #' .df_row = df, |
||
| 251 | +149 |
- id = "USUBJID",+ #' .var = "MHDECOD", |
||
| 252 | +150 |
- grade_groups = list(),+ #' id = "USUBJID" |
||
| 253 | +151 |
- remove_single = TRUE,+ #' ) |
||
| 254 | +152 |
- only_grade_groups = FALSE,+ #' |
||
| 255 | +153 |
- denom = c("N_col", "n", "N_row"),
+ #' @export |
||
| 256 | +154 |
- .N_col, # nolint+ a_count_occurrences <- function(df, |
||
| 257 | +155 |
- .N_row, # nolint+ labelstr = "", |
||
| 258 | +156 |
- .df_row,+ id = "USUBJID", |
||
| 259 | +157 |
- .var = NULL,+ denom = c("N_col", "n", "N_row"),
|
||
| 260 | +158 |
- .stats = NULL,+ drop = TRUE, |
||
| 261 | +159 |
- .formats = NULL,+ .N_col, # nolint |
||
| 262 | +160 |
- .labels = NULL,+ .N_row, # nolint |
||
| 263 | +161 |
- .indent_mods = NULL,+ .var = NULL, |
||
| 264 | +162 |
- na_str = default_na_str()) {
- |
- ||
| 265 | -56x | -
- x_stats <- s_count_occurrences_by_grade(- |
- ||
| 266 | -56x | -
- df = df, .var = .var, .N_row = .N_row, .N_col = .N_col, id = id,- |
- ||
| 267 | -56x | -
- grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups,- |
- ||
| 268 | -56x | -
- denom = denom, labelstr = labelstr+ .df_row = NULL, |
||
| 269 | +163 |
- )+ .stats = NULL, |
||
| 270 | +164 | - - | -||
| 271 | -56x | -
- if (is.null(unlist(x_stats))) {
- |
- ||
| 272 | -! | -
- return(NULL)+ .formats = NULL, |
||
| 273 | +165 |
- }+ .labels = NULL, |
||
| 274 | +166 |
-
+ .indent_mods = NULL, |
||
| 275 | +167 |
- # Fill in with formatting defaults if needed+ na_str = default_na_str()) {
|
||
| 276 | -56x | +168 | +85x |
- .stats <- get_stats("count_occurrences_by_grade", stats_in = .stats)
+ denom <- match.arg(denom) |
| 277 | -56x | +169 | +85x |
- if (length(.formats) == 1 && is.null(names(.formats))) {
+ x_stats <- s_count_occurrences( |
| 278 | -4x | +170 | +85x |
- .formats <- rep(.formats, length(.stats)) %>% setNames(.stats)+ df = df, denom = denom, .N_col = .N_col, .N_row = .N_row, .df_row = .df_row, drop = drop, .var = .var, id = id |
| 279 | +171 |
- }- |
- ||
| 280 | -56x | -
- .formats <- get_formats_from_stats(.stats, .formats)- |
- ||
| 281 | -56x | -
- .labels <- .unlist_keep_nulls(get_labels_from_stats(.stats, .labels, lapply(x_stats, names)))+ ) |
||
| 282 | -56x | -
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods, row_nms = names(x_stats[[1]]))- |
- ||
| 283 | -+ | 172 | +85x |
-
+ if (is.null(unlist(x_stats))) {
|
| 284 | -56x | -
- x_stats <- x_stats[.stats]- |
- ||
| 285 | -+ | 173 | +3x |
-
+ return(NULL) |
| 286 | +174 |
- # Ungroup statistics with values for each level of x- |
- ||
| 287 | -56x | -
- x_ungrp <- ungroup_stats(x_stats, .formats, list())- |
- ||
| 288 | -56x | -
- x_stats <- x_ungrp[["x"]]- |
- ||
| 289 | -56x | -
- .formats <- x_ungrp[[".formats"]]+ } |
||
| 290 | +175 | |||
| 291 | -- |
- # Auto format handling- |
- ||
| 292 | -56x | -
- .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)- |
- ||
| 293 | +176 | - - | -||
| 294 | -56x | -
- in_rows(- |
- ||
| 295 | -56x | -
- .list = x_stats,+ # Fill in with formatting defaults if needed |
||
| 296 | -56x | +177 | +82x |
- .formats = .formats,+ .stats <- get_stats("count_occurrences", stats_in = .stats)
|
| 297 | -56x | +178 | +82x |
- .names = .labels,+ x_stats <- x_stats[.stats] |
| 298 | -56x | +179 | +82x |
- .labels = .labels,+ levels_per_stats <- lapply(x_stats, names) |
| 299 | -56x | +180 | +82x |
- .indent_mods = .indent_mods,+ .formats <- get_formats_from_stats(.stats, .formats, levels_per_stats) |
| 300 | -56x | -
- .format_na_strs = na_str- |
- ||
| 301 | -- |
- )- |
- ||
| 302 | -- |
- }- |
- ||
| 303 | -- | - - | -||
| 304 | -- |
- #' @describeIn count_occurrences_by_grade Layout-creating function which can take statistics function- |
- ||
| 305 | -- |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].- |
- ||
| 306 | -- |
- #'- |
- ||
| 307 | -- |
- #' @return- |
- ||
| 308 | -- |
- #' * `count_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions,- |
- ||
| 309 | -- |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing- |
- ||
| 310 | -- |
- #' the statistics from `s_count_occurrences_by_grade()` to the table layout.- |
- ||
| 311 | -- |
- #'- |
- ||
| 312 | -- |
- #' @examples- |
- ||
| 313 | -- |
- #' library(dplyr)- |
- ||
| 314 | -- |
- #'- |
- ||
| 315 | -- |
- #' df <- data.frame(- |
- ||
| 316 | -- |
- #' USUBJID = as.character(c(1:6, 1)),- |
- ||
| 317 | -- |
- #' ARM = factor(c("A", "A", "A", "B", "B", "B", "A"), levels = c("A", "B")),
- |
- ||
| 318 | -+ | 181 | +82x |
- #' AETOXGR = factor(c(1, 2, 3, 4, 1, 2, 3), levels = c(1:5)),+ .labels <- get_labels_from_stats(.stats, .labels, levels_per_stats) |
| 319 | -+ | |||
| 182 | +82x |
- #' AESEV = factor(+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods, levels_per_stats) |
||
| 320 | +183 |
- #' x = c("MILD", "MODERATE", "SEVERE", "MILD", "MILD", "MODERATE", "SEVERE"),
+
|
||
| 321 | +184 |
- #' levels = c("MILD", "MODERATE", "SEVERE")
+ # Unlist stats |
||
| 322 | -+ | |||
| 185 | +82x |
- #' ),+ x_stats <- x_stats %>% .unlist_keep_nulls() |
||
| 323 | +186 |
- #' stringsAsFactors = FALSE+ |
||
| 324 | +187 |
- #' )+ # Auto format handling |
||
| 325 | -+ | |||
| 188 | +82x |
- #'+ .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var) |
||
| 326 | +189 |
- #' df_adsl <- df %>%+ |
||
| 327 | -+ | |||
| 190 | +82x |
- #' select(USUBJID, ARM) %>%+ in_rows( |
||
| 328 | -+ | |||
| 191 | +82x |
- #' unique()+ .list = x_stats, |
||
| 329 | -+ | |||
| 192 | +82x |
- #'+ .formats = .formats, |
||
| 330 | -+ | |||
| 193 | +82x |
- #' # Layout creating function with custom format.+ .names = .labels %>% .unlist_keep_nulls(), |
||
| 331 | -+ | |||
| 194 | +82x |
- #' basic_table() %>%+ .labels = .labels %>% .unlist_keep_nulls(), |
||
| 332 | -+ | |||
| 195 | +82x |
- #' split_cols_by("ARM") %>%
+ .indent_mods = .indent_mods %>% .unlist_keep_nulls(), |
||
| 333 | -+ | |||
| 196 | +82x |
- #' add_colcounts() %>%+ .format_na_strs = na_str |
||
| 334 | +197 |
- #' count_occurrences_by_grade(+ ) |
||
| 335 | +198 |
- #' var = "AESEV",+ } |
||
| 336 | +199 |
- #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
+
|
||
| 337 | +200 |
- #' ) %>%+ #' @describeIn count_occurrences Layout-creating function which can take statistics function arguments |
||
| 338 | +201 |
- #' build_table(df, alt_counts_df = df_adsl)+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 339 | +202 |
#' |
||
| 340 | +203 |
- #' # Define additional grade groupings.+ #' @return |
||
| 341 | +204 |
- #' grade_groups <- list(+ #' * `count_occurrences()` returns a layout object suitable for passing to further layouting functions, |
||
| 342 | +205 |
- #' "-Any-" = c("1", "2", "3", "4", "5"),
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 343 | +206 |
- #' "Grade 1-2" = c("1", "2"),
+ #' the statistics from `s_count_occurrences()` to the table layout. |
||
| 344 | +207 |
- #' "Grade 3-5" = c("3", "4", "5")
+ #' |
||
| 345 | +208 |
- #' )+ #' @examples |
||
| 346 | +209 |
- #'+ #' # Create table layout |
||
| 347 | +210 |
- #' basic_table() %>%+ #' lyt <- basic_table() %>% |
||
| 348 | +211 |
#' split_cols_by("ARM") %>%
|
||
| 349 | +212 |
#' add_colcounts() %>% |
||
| 350 | +213 |
- #' count_occurrences_by_grade(+ #' count_occurrences(vars = "MHDECOD", .stats = c("count_fraction"))
|
||
| 351 | +214 |
- #' var = "AETOXGR",+ #' |
||
| 352 | +215 |
- #' grade_groups = grade_groups,+ #' # Apply table layout to data and produce `rtable` object |
||
| 353 | +216 |
- #' only_grade_groups = TRUE+ #' tbl <- lyt %>% |
||
| 354 | +217 |
- #' ) %>%+ #' build_table(df, alt_counts_df = df_adsl) %>% |
||
| 355 | +218 |
- #' build_table(df, alt_counts_df = df_adsl)+ #' prune_table() |
||
| 356 | +219 |
#' |
||
| 357 | +220 |
- #' @export+ #' tbl |
||
| 358 | +221 |
- #' @order 2+ #' |
||
| 359 | +222 |
- count_occurrences_by_grade <- function(lyt,+ #' @export |
||
| 360 | +223 |
- var,+ #' @order 2 |
||
| 361 | +224 |
- id = "USUBJID",+ count_occurrences <- function(lyt, |
||
| 362 | +225 |
- grade_groups = list(),+ vars, |
||
| 363 | +226 |
- remove_single = TRUE,+ id = "USUBJID", |
||
| 364 | +227 |
- only_grade_groups = FALSE,+ drop = TRUE, |
||
| 365 | +228 |
- var_labels = var,+ var_labels = vars, |
||
| 366 | +229 |
- show_labels = "default",+ show_labels = "hidden", |
||
| 367 | +230 |
- riskdiff = FALSE,+ riskdiff = FALSE, |
||
| 368 | +231 |
- na_str = default_na_str(),+ na_str = default_na_str(), |
||
| 369 | +232 |
- nested = TRUE,+ nested = TRUE, |
||
| 370 | +233 |
- ...,+ ..., |
||
| 371 | +234 |
- table_names = var,+ table_names = vars, |
||
| 372 | +235 |
- .stats = "count_fraction",+ .stats = "count_fraction_fixed_dp", |
||
| 373 | +236 |
- .formats = list(count_fraction = format_count_fraction_fixed_dp),+ .formats = NULL, |
||
| 374 | +237 |
- .indent_mods = NULL,+ .labels = NULL, |
||
| 375 | +238 |
- .labels = NULL) {
+ .indent_mods = NULL) {
|
||
| 376 | -12x | +239 | +9x |
checkmate::assert_flag(riskdiff) |
| 240 | ++ | + + | +||
| 377 | -12x | +241 | +9x |
extra_args <- list( |
| 378 | -12x | +242 | +9x |
.stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str |
| 379 | +243 |
) |
||
| 380 | -12x | -
- s_args <- list(- |
- ||
| 381 | -12x | -
- id = id, grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups, ...- |
- ||
| 382 | -+ | 244 | +9x |
- )+ s_args <- list(id = id, drop = drop, ...) |
| 383 | +245 | |||
| 384 | -12x | +246 | +9x |
if (isFALSE(riskdiff)) {
|
| 385 | -10x | +247 | +6x |
extra_args <- c(extra_args, s_args) |
| 386 | +248 |
} else {
|
||
| 387 | -2x | +249 | +3x |
extra_args <- c( |
| 388 | -2x | +250 | +3x |
extra_args, |
| 389 | -2x | +251 | +3x |
list( |
| 390 | -2x | +252 | +3x |
- afun = list("s_count_occurrences_by_grade" = a_count_occurrences_by_grade),
+ afun = list("s_count_occurrences" = a_count_occurrences),
|
| 391 | -2x | +253 | +3x |
s_args = s_args |
| 392 | +254 |
) |
||
| 393 | +255 |
) |
||
| 394 | +256 |
} |
||
| 395 | +257 | |||
| 396 | -12x | +258 | +9x |
analyze( |
| 397 | -12x | +259 | +9x |
lyt = lyt, |
| 398 | -12x | +260 | +9x |
- vars = var,+ vars = vars, |
| 399 | -12x | +261 | +9x |
- afun = ifelse(isFALSE(riskdiff), a_count_occurrences_by_grade, afun_riskdiff),+ afun = ifelse(isFALSE(riskdiff), a_count_occurrences, afun_riskdiff), |
| 400 | -12x | +262 | +9x |
var_labels = var_labels, |
| 401 | -12x | +263 | +9x |
show_labels = show_labels, |
| 402 | -12x | +264 | +9x |
table_names = table_names, |
| 403 | -12x | +265 | +9x |
na_str = na_str, |
| 404 | -12x | +266 | +9x |
nested = nested, |
| 405 | -12x | +267 | +9x |
extra_args = extra_args |
| 406 | +268 |
) |
||
| 407 | +269 |
} |
||
| 408 | +270 | |||
| 409 | +271 |
- #' @describeIn count_occurrences_by_grade Layout-creating function which can take content function arguments+ #' @describeIn count_occurrences Layout-creating function which can take content function arguments |
||
| 410 | +272 |
#' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 411 | +273 |
#' |
||
| 412 | +274 |
#' @return |
||
| 413 | +275 |
- #' * `summarize_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions,+ #' * `summarize_occurrences()` returns a layout object suitable for passing to further layouting functions, |
||
| 414 | +276 |
#' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows |
||
| 415 | +277 |
- #' containing the statistics from `s_count_occurrences_by_grade()` to the table layout.+ #' containing the statistics from `s_count_occurrences()` to the table layout. |
||
| 416 | +278 |
#' |
||
| 417 | +279 |
#' @examples |
||
| 418 | +280 |
#' # Layout creating function with custom format. |
||
| 419 | +281 |
#' basic_table() %>% |
||
| 420 | +282 |
#' add_colcounts() %>% |
||
| 421 | +283 |
- #' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
+ #' split_rows_by("SEX", child_labels = "visible") %>%
|
||
| 422 | +284 |
- #' summarize_occurrences_by_grade(+ #' summarize_occurrences( |
||
| 423 | +285 |
- #' var = "AESEV",+ #' var = "MHDECOD", |
||
| 424 | +286 |
#' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
|
||
| 425 | -- |
- #' ) %>%- |
- ||
| 426 | -- |
- #' build_table(df, alt_counts_df = df_adsl)- |
- ||
| 427 | -- |
- #'- |
- ||
| 428 | -- |
- #' basic_table() %>%- |
- ||
| 429 | -- |
- #' add_colcounts() %>%- |
- ||
| 430 | -- |
- #' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
- |
- ||
| 431 | -- |
- #' summarize_occurrences_by_grade(- |
- ||
| 432 | -- |
- #' var = "AETOXGR",- |
- ||
| 433 | -- |
- #' grade_groups = grade_groups- |
- ||
| 434 | +287 |
#' ) %>% |
||
| 435 | +288 |
#' build_table(df, alt_counts_df = df_adsl) |
||
| 436 | +289 |
#' |
||
| 437 | +290 |
#' @export |
||
| 438 | +291 |
#' @order 3 |
||
| 439 | +292 |
- summarize_occurrences_by_grade <- function(lyt,+ summarize_occurrences <- function(lyt, |
||
| 440 | +293 |
- var,+ var, |
||
| 441 | +294 |
- id = "USUBJID",+ id = "USUBJID", |
||
| 442 | +295 |
- grade_groups = list(),+ drop = TRUE, |
||
| 443 | +296 |
- remove_single = TRUE,+ riskdiff = FALSE, |
||
| 444 | +297 |
- only_grade_groups = FALSE,+ na_str = default_na_str(), |
||
| 445 | +298 |
- riskdiff = FALSE,+ ..., |
||
| 446 | +299 |
- na_str = default_na_str(),+ .stats = "count_fraction_fixed_dp", |
||
| 447 | +300 |
- ...,+ .formats = NULL, |
||
| 448 | +301 |
- .stats = "count_fraction",+ .indent_mods = NULL, |
||
| 449 | +302 |
- .formats = list(count_fraction = format_count_fraction_fixed_dp),+ .labels = NULL) {
|
||
| 450 | -+ | |||
| 303 | +5x |
- .indent_mods = NULL,+ checkmate::assert_flag(riskdiff) |
||
| 451 | +304 |
- .labels = NULL) {
- |
- ||
| 452 | -6x | -
- checkmate::assert_flag(riskdiff)+ |
||
| 453 | -6x | +305 | +5x |
extra_args <- list( |
| 454 | -6x | +306 | +5x |
.stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str |
| 455 | +307 |
) |
||
| 456 | -6x | -
- s_args <- list(- |
- ||
| 457 | -6x | -
- id = id, grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups, ...- |
- ||
| 458 | -+ | 308 | +5x |
- )+ s_args <- list(id = id, drop = drop, ...) |
| 459 | +309 | |||
| 460 | -6x | +310 | +5x |
if (isFALSE(riskdiff)) {
|
| 461 | -4x | +311 | +1x |
extra_args <- c(extra_args, s_args) |
| 462 | +312 |
} else {
|
||
| 463 | -2x | +313 | +4x |
extra_args <- c( |
| 464 | -2x | +314 | +4x |
extra_args, |
| 465 | -2x | +315 | +4x |
list( |
| 466 | -2x | +316 | +4x |
- afun = list("s_count_occurrences_by_grade" = a_count_occurrences_by_grade),
+ afun = list("s_count_occurrences" = a_count_occurrences),
|
| 467 | -2x | +317 | +4x |
s_args = s_args |
| 468 | +318 |
) |
||
| 469 | +319 |
) |
||
| 470 | +320 |
} |
||
| 471 | +321 | |||
| 472 | -6x | +322 | +5x |
summarize_row_groups( |
| 473 | -6x | +323 | +5x |
lyt = lyt, |
| 474 | -6x | +324 | +5x |
var = var, |
| 475 | -6x | +325 | +5x |
- cfun = ifelse(isFALSE(riskdiff), a_count_occurrences_by_grade, afun_riskdiff),+ cfun = ifelse(isFALSE(riskdiff), a_count_occurrences, afun_riskdiff), |
| 476 | -6x | +326 | +5x |
na_str = na_str, |
| 477 | -6x | +327 | +5x |
extra_args = extra_args |
| 478 | +328 |
) |
||
| 479 | +329 |
}@@ -53177,14 +55660,14 @@ tern coverage - 95.59% |
| 1 |
- #' Formatting functions+ #' Individual patient plots |
||
| 3 |
- #' See below for the list of formatting functions created in `tern` to work with `rtables`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 5 |
- #' Other available formats can be listed via [`formatters::list_valid_format_labels()`]. Additional+ #' Line plot(s) displaying trend in patients' parameter values over time is rendered. |
||
| 6 |
- #' custom formats can be created via the [`formatters::sprintf_format()`] function.+ #' Patients' individual baseline values can be added to the plot(s) as reference. |
||
| 8 |
- #' @family formatting functions+ #' @inheritParams argument_convention |
||
| 9 |
- #' @name formatting_functions+ #' @param xvar (`string`)\cr time point variable to be plotted on x-axis. |
||
| 10 |
- NULL+ #' @param yvar (`string`)\cr continuous analysis variable to be plotted on y-axis. |
||
| 11 |
-
+ #' @param xlab (`string`)\cr plot label for x-axis. |
||
| 12 |
- #' Format fraction and percentage+ #' @param ylab (`string`)\cr plot label for y-axis. |
||
| 13 |
- #'+ #' @param id_var (`string`)\cr variable used as patient identifier. |
||
| 14 |
- #' @description `r lifecycle::badge("stable")`
+ #' @param title (`string`)\cr title for plot. |
||
| 15 |
- #'+ #' @param subtitle (`string`)\cr subtitle for plot. |
||
| 16 |
- #' Formats a fraction together with ratio in percent.+ #' @param add_baseline_hline (`flag`)\cr adds horizontal line at baseline y-value on |
||
| 17 |
- #'+ #' plot when `TRUE`. |
||
| 18 |
- #' @param x (named `integer`)\cr vector with elements `num` and `denom`.+ #' @param yvar_baseline (`string`)\cr variable with baseline values only. |
||
| 19 |
- #' @param ... not used. Required for `rtables` interface.+ #' Ignored when `add_baseline_hline` is `FALSE`. |
||
| 20 |
- #'+ #' @param ggtheme (`theme`)\cr optional graphical theme function as provided |
||
| 21 |
- #' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`.+ #' by `ggplot2` to control outlook of plot. Use `ggplot2::theme()` to tweak the display. |
||
| 22 |
- #'+ #' @param plotting_choices (`string`)\cr specifies options for displaying |
||
| 23 |
- #' @examples+ #' plots. Must be one of `"all_in_one"`, `"split_by_max_obs"`, or `"separate_by_obs"`. |
||
| 24 |
- #' format_fraction(x = c(num = 2L, denom = 3L))+ #' @param max_obs_per_plot (`integer(1)`)\cr number of observations to be plotted on one |
||
| 25 |
- #' format_fraction(x = c(num = 0L, denom = 3L))+ #' plot. Ignored if `plotting_choices` is not `"separate_by_obs"`. |
||
| 26 |
- #'+ #' @param caption (`string`)\cr optional caption below the plot. |
||
| 27 |
- #' @family formatting functions+ #' @param col (`character`)\cr line colors. |
||
| 28 |
- #' @export+ #' |
||
| 29 |
- format_fraction <- function(x, ...) {
+ #' @seealso Relevant helper function [h_g_ipp()]. |
||
| 30 | -4x | +
- attr(x, "label") <- NULL+ #' |
|
| 31 |
-
+ #' @name g_ipp |
||
| 32 | -4x | +
- checkmate::assert_vector(x)+ #' @aliases individual_patient_plot |
|
| 33 | -4x | +
- checkmate::assert_count(x["num"])+ NULL |
|
| 34 | -2x | +
- checkmate::assert_count(x["denom"])+ |
|
| 35 |
-
+ #' Helper function to create simple line plot over time |
||
| 36 | -2x | +
- result <- if (x["num"] == 0) {
+ #' |
|
| 37 | -1x | +
- paste0(x["num"], "/", x["denom"])+ #' @description `r lifecycle::badge("stable")`
|
|
| 38 |
- } else {
+ #' |
||
| 39 | -1x | +
- paste0(+ #' Function that generates a simple line plot displaying parameter trends over time. |
|
| 40 | -1x | +
- x["num"], "/", x["denom"],+ #' |
|
| 41 | -1x | +
- " (", round(x["num"] / x["denom"] * 100, 1), "%)"
+ #' @inheritParams argument_convention |
|
| 42 |
- )+ #' @inheritParams g_ipp |
||
| 43 |
- }+ #' |
||
| 44 |
-
+ #' @return A `ggplot` line plot. |
||
| 45 | -2x | +
- return(result)+ #' |
|
| 46 |
- }+ #' @seealso [g_ipp()] which uses this function. |
||
| 47 |
-
+ #' |
||
| 48 |
- #' Format fraction and percentage with fixed single decimal place+ #' @examples |
||
| 49 |
- #'+ #' library(dplyr) |
||
| 50 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 51 |
- #'+ #' # Select a small sample of data to plot. |
||
| 52 |
- #' Formats a fraction together with ratio in percent with fixed single decimal place.+ #' adlb <- tern_ex_adlb %>% |
||
| 53 |
- #' Includes trailing zero in case of whole number percentages to always keep one decimal place.+ #' filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
|
||
| 54 |
- #'+ #' slice(1:36) |
||
| 55 |
- #' @inheritParams format_fraction+ #' |
||
| 56 |
- #'+ #' p <- h_g_ipp( |
||
| 57 |
- #' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`.+ #' df = adlb, |
||
| 58 |
- #'+ #' xvar = "AVISIT", |
||
| 59 |
- #' @examples+ #' yvar = "AVAL", |
||
| 60 |
- #' format_fraction_fixed_dp(x = c(num = 1L, denom = 2L))+ #' xlab = "Visit", |
||
| 61 |
- #' format_fraction_fixed_dp(x = c(num = 1L, denom = 4L))+ #' id_var = "USUBJID", |
||
| 62 |
- #' format_fraction_fixed_dp(x = c(num = 0L, denom = 3L))+ #' ylab = "SGOT/ALT (U/L)", |
||
| 63 |
- #'+ #' add_baseline_hline = TRUE |
||
| 64 |
- #' @family formatting functions+ #' ) |
||
| 65 |
- #' @export+ #' p |
||
| 66 |
- format_fraction_fixed_dp <- function(x, ...) {
+ #' |
||
| 67 | -3x | +
- attr(x, "label") <- NULL+ #' @export |
|
| 68 | -3x | +
- checkmate::assert_vector(x)+ h_g_ipp <- function(df, |
|
| 69 | -3x | +
- checkmate::assert_count(x["num"])+ xvar, |
|
| 70 | -3x | +
- checkmate::assert_count(x["denom"])+ yvar, |
|
| 71 |
-
+ xlab, |
||
| 72 | -3x | +
- result <- if (x["num"] == 0) {
+ ylab, |
|
| 73 | -1x | +
- paste0(x["num"], "/", x["denom"])+ id_var, |
|
| 74 |
- } else {
+ title = "Individual Patient Plots", |
||
| 75 | -2x | +
- paste0(+ subtitle = "", |
|
| 76 | -2x | +
- x["num"], "/", x["denom"],+ caption = NULL, |
|
| 77 | -2x | +
- " (", sprintf("%.1f", round(x["num"] / x["denom"] * 100, 1)), "%)"
+ add_baseline_hline = FALSE, |
|
| 78 |
- )+ yvar_baseline = "BASE", |
||
| 79 |
- }+ ggtheme = nestcolor::theme_nest(), |
||
| 80 | -3x | +
- return(result)+ col = NULL) {
|
|
| 81 | -+ | 13x |
- }+ checkmate::assert_string(xvar) |
| 82 | -+ | 13x |
-
+ checkmate::assert_string(yvar) |
| 83 | -+ | 13x |
- #' Format count and fraction+ checkmate::assert_string(yvar_baseline) |
| 84 | -+ | 13x |
- #'+ checkmate::assert_string(id_var) |
| 85 | -+ | 13x |
- #' @description `r lifecycle::badge("stable")`
+ checkmate::assert_string(xlab) |
| 86 | -+ | 13x |
- #'+ checkmate::assert_string(ylab) |
| 87 | -+ | 13x |
- #' Formats a count together with fraction with special consideration when count is `0`.+ checkmate::assert_string(title) |
| 88 | -+ | 13x |
- #'+ checkmate::assert_string(subtitle) |
| 89 | -+ | 13x |
- #' @param x (`numeric(2)`)\cr vector of length 2 with count and fraction, respectively.+ checkmate::assert_subset(c(xvar, yvar, yvar_baseline, id_var), colnames(df)) |
| 90 | -+ | 13x |
- #' @param ... not used. Required for `rtables` interface.+ checkmate::assert_data_frame(df) |
| 91 | -+ | 13x |
- #'+ checkmate::assert_flag(add_baseline_hline) |
| 92 | -+ | 13x |
- #' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`.+ checkmate::assert_character(col, null.ok = TRUE) |
| 93 |
- #'+ |
||
| 94 | -+ | 13x |
- #' @examples+ p <- ggplot2::ggplot( |
| 95 | -+ | 13x |
- #' format_count_fraction(x = c(2, 0.6667))+ data = df, |
| 96 | -+ | 13x |
- #' format_count_fraction(x = c(0, 0))+ mapping = ggplot2::aes( |
| 97 | -+ | 13x |
- #'+ x = .data[[xvar]], |
| 98 | -+ | 13x |
- #' @family formatting functions+ y = .data[[yvar]], |
| 99 | -+ | 13x |
- #' @export+ group = .data[[id_var]], |
| 100 | -+ | 13x |
- format_count_fraction <- function(x, ...) {
+ colour = .data[[id_var]] |
| 101 | -3x | +
- attr(x, "label") <- NULL+ ) |
|
| 102 |
-
+ ) + |
||
| 103 | -3x | +13x |
- if (any(is.na(x))) {
+ ggplot2::geom_line(linewidth = 0.4) + |
| 104 | -1x | +13x |
- return("NA")
+ ggplot2::geom_point(size = 2) + |
| 105 | -+ | 13x |
- }+ ggplot2::labs( |
| 106 | -+ | 13x |
-
+ x = xlab, |
| 107 | -2x | +13x |
- checkmate::assert_vector(x)+ y = ylab, |
| 108 | -2x | +13x |
- checkmate::assert_integerish(x[1])+ title = title, |
| 109 | -2x | +13x |
- assert_proportion_value(x[2], include_boundaries = TRUE)+ subtitle = subtitle, |
| 110 | -+ | 13x |
-
+ caption = caption |
| 111 | -2x | +
- result <- if (x[1] == 0) {
+ ) + |
|
| 112 | -1x | +13x |
- "0"+ ggtheme |
| 113 |
- } else {
+
|
||
| 114 | -1x | +13x |
- paste0(x[1], " (", round(x[2] * 100, 1), "%)")
+ if (add_baseline_hline) {
|
| 115 | -+ | 12x |
- }+ baseline_df <- df[, c(id_var, yvar_baseline)] |
| 116 | -+ | 12x |
-
+ baseline_df <- unique(baseline_df) |
| 117 | -2x | +
- return(result)+ |
|
| 118 | -+ | 12x |
- }+ p <- p + |
| 119 | -+ | 12x |
-
+ ggplot2::geom_hline( |
| 120 | -+ | 12x |
- #' Format count and percentage with fixed single decimal place+ data = baseline_df, |
| 121 | -+ | 12x |
- #'+ mapping = ggplot2::aes( |
| 122 | -+ | 12x |
- #' @description `r lifecycle::badge("experimental")`
+ yintercept = .data[[yvar_baseline]], |
| 123 | -+ | 12x |
- #'+ colour = .data[[id_var]] |
| 124 |
- #' Formats a count together with fraction with special consideration when count is `0`.+ ), |
||
| 125 | -+ | 12x |
- #'+ linetype = "dotdash", |
| 126 | -+ | 12x |
- #' @inheritParams format_count_fraction+ linewidth = 0.4 |
| 127 |
- #'+ ) + |
||
| 128 | -+ | 12x |
- #' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`.+ ggplot2::geom_text( |
| 129 | -+ | 12x |
- #'+ data = baseline_df, |
| 130 | -+ | 12x |
- #' @examples+ mapping = ggplot2::aes( |
| 131 | -+ | 12x |
- #' format_count_fraction_fixed_dp(x = c(2, 0.6667))+ x = 1, |
| 132 | -+ | 12x |
- #' format_count_fraction_fixed_dp(x = c(2, 0.5))+ y = .data[[yvar_baseline]], |
| 133 | -+ | 12x |
- #' format_count_fraction_fixed_dp(x = c(0, 0))+ label = .data[[id_var]], |
| 134 | -+ | 12x |
- #'+ colour = .data[[id_var]] |
| 135 |
- #' @family formatting functions+ ), |
||
| 136 | -+ | 12x |
- #' @export+ nudge_y = 0.025 * (max(df[, yvar], na.rm = TRUE) - min(df[, yvar], na.rm = TRUE)), |
| 137 | -+ | 12x |
- format_count_fraction_fixed_dp <- function(x, ...) {
+ vjust = "right", |
| 138 | -1408x | +12x |
- attr(x, "label") <- NULL+ size = 2 |
| 139 |
-
+ ) |
||
| 140 | -1408x | +
- if (any(is.na(x))) {
+
|
|
| 141 | -! | +12x |
- return("NA")
+ if (!is.null(col)) {
|
| 142 | -+ | 1x |
- }+ p <- p + |
| 143 | -+ | 1x |
-
+ ggplot2::scale_color_manual(values = col) |
| 144 | -1408x | +
- checkmate::assert_vector(x)+ } |
|
| 145 | -1408x | +
- checkmate::assert_integerish(x[1])+ } |
|
| 146 | -1408x | +13x |
- assert_proportion_value(x[2], include_boundaries = TRUE)+ p |
| 147 |
-
+ } |
||
| 148 | -1408x | +
- result <- if (x[1] == 0) {
+
|
|
| 149 | -195x | +
- "0"+ #' @describeIn g_ipp Plotting function for individual patient plots which, depending on user |
|
| 150 | -1408x | +
- } else if (.is_equal_float(x[2], 1)) {
+ #' preference, renders a single graphic or compiles a list of graphics that show trends in individual's parameter |
|
| 151 | -549x | +
- sprintf("%d (100%%)", x[1])
+ #' values over time. |
|
| 152 |
- } else {
+ #' |
||
| 153 | -664x | +
- sprintf("%d (%.1f%%)", x[1], x[2] * 100)
+ #' @return A `ggplot` object or a list of `ggplot` objects. |
|
| 154 |
- }+ #' |
||
| 155 |
-
+ #' @examples |
||
| 156 | -1408x | +
- return(result)+ #' library(dplyr) |
|
| 157 |
- }+ #' |
||
| 158 |
-
+ #' # Select a small sample of data to plot. |
||
| 159 |
- #' Format count and fraction with special case for count < 10+ #' adlb <- tern_ex_adlb %>% |
||
| 160 |
- #'+ #' filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
|
||
| 161 |
- #' @description `r lifecycle::badge("stable")`
+ #' slice(1:36) |
||
| 163 |
- #' Formats a count together with fraction with special consideration when count is less than 10.+ #' plot_list <- g_ipp( |
||
| 164 |
- #'+ #' df = adlb, |
||
| 165 |
- #' @inheritParams format_count_fraction+ #' xvar = "AVISIT", |
||
| 166 |
- #'+ #' yvar = "AVAL", |
||
| 167 |
- #' @return A string in the format `count (fraction %)`. If `count` is less than 10, only `count` is printed.+ #' xlab = "Visit", |
||
| 168 |
- #'+ #' ylab = "SGOT/ALT (U/L)", |
||
| 169 |
- #' @examples+ #' title = "Individual Patient Plots", |
||
| 170 |
- #' format_count_fraction_lt10(x = c(275, 0.9673))+ #' add_baseline_hline = TRUE, |
||
| 171 |
- #' format_count_fraction_lt10(x = c(2, 0.6667))+ #' plotting_choices = "split_by_max_obs", |
||
| 172 |
- #' format_count_fraction_lt10(x = c(9, 1))+ #' max_obs_per_plot = 5 |
||
| 173 |
- #'+ #' ) |
||
| 174 |
- #' @family formatting functions+ #' plot_list |
||
| 175 |
- #' @export+ #' |
||
| 176 |
- format_count_fraction_lt10 <- function(x, ...) {
+ #' @export |
||
| 177 | -7x | +
- attr(x, "label") <- NULL+ g_ipp <- function(df, |
|
| 178 |
-
+ xvar, |
||
| 179 | -7x | +
- if (any(is.na(x))) {
+ yvar, |
|
| 180 | -1x | +
- return("NA")
+ xlab, |
|
| 181 |
- }+ ylab, |
||
| 182 |
-
+ id_var = "USUBJID", |
||
| 183 | -6x | +
- checkmate::assert_vector(x)+ title = "Individual Patient Plots", |
|
| 184 | -6x | +
- checkmate::assert_integerish(x[1])+ subtitle = "", |
|
| 185 | -6x | +
- assert_proportion_value(x[2], include_boundaries = TRUE)+ caption = NULL, |
|
| 186 |
-
+ add_baseline_hline = FALSE, |
||
| 187 | -6x | +
- result <- if (x[1] < 10) {
+ yvar_baseline = "BASE", |
|
| 188 | -3x | +
- paste0(x[1])+ ggtheme = nestcolor::theme_nest(), |
|
| 189 |
- } else {
+ plotting_choices = c("all_in_one", "split_by_max_obs", "separate_by_obs"),
|
||
| 190 | -3x | +
- paste0(x[1], " (", round(x[2] * 100, 1), "%)")
+ max_obs_per_plot = 4, |
|
| 191 |
- }+ col = NULL) {
|
||
| 192 | -+ | 3x |
-
+ checkmate::assert_count(max_obs_per_plot) |
| 193 | -6x | +3x |
- return(result)+ checkmate::assert_subset(plotting_choices, c("all_in_one", "split_by_max_obs", "separate_by_obs"))
|
| 194 | -+ | 3x |
- }+ checkmate::assert_character(col, null.ok = TRUE) |
| 196 | -+ | 3x |
- #' Format XX as a formatting function+ plotting_choices <- match.arg(plotting_choices) |
| 197 |
- #'+ |
||
| 198 | -+ | 3x |
- #' Translate a string where x and dots are interpreted as number place+ if (plotting_choices == "all_in_one") {
|
| 199 | -+ | 1x |
- #' holders, and others as formatting elements.+ p <- h_g_ipp( |
| 200 | -+ | 1x |
- #'+ df = df, |
| 201 | -+ | 1x |
- #' @param str (`string`)\cr template.+ xvar = xvar, |
| 202 | -+ | 1x |
- #'+ yvar = yvar, |
| 203 | -+ | 1x |
- #' @return An `rtables` formatting function.+ xlab = xlab, |
| 204 | -+ | 1x |
- #'+ ylab = ylab, |
| 205 | -+ | 1x |
- #' @examples+ id_var = id_var, |
| 206 | -+ | 1x |
- #' test <- list(c(1.658, 0.5761), c(1e1, 785.6))+ title = title, |
| 207 | -+ | 1x |
- #'+ subtitle = subtitle, |
| 208 | -+ | 1x |
- #' z <- format_xx("xx (xx.x)")
+ caption = caption, |
| 209 | -+ | 1x |
- #' sapply(test, z)+ add_baseline_hline = add_baseline_hline, |
| 210 | -+ | 1x |
- #'+ yvar_baseline = yvar_baseline, |
| 211 | -+ | 1x |
- #' z <- format_xx("xx.x - xx.x")
+ ggtheme = ggtheme, |
| 212 | -+ | 1x |
- #' sapply(test, z)+ col = col |
| 213 |
- #'+ ) |
||
| 214 |
- #' z <- format_xx("xx.x, incl. xx.x% NE")
+
|
||
| 215 | -+ | 1x |
- #' sapply(test, z)+ return(p) |
| 216 | -+ | 2x |
- #'+ } else if (plotting_choices == "split_by_max_obs") {
|
| 217 | -+ | 1x |
- #' @family formatting functions+ id_vec <- unique(df[[id_var]]) |
| 218 | -+ | 1x |
- #' @export+ id_list <- split( |
| 219 | -+ | 1x |
- format_xx <- function(str) {
+ id_vec, |
| 220 | -+ | 1x |
- # Find position in the string.+ rep(1:ceiling(length(id_vec) / max_obs_per_plot), |
| 221 | 1x |
- positions <- gregexpr(pattern = "x+\\.x+|x+", text = str, perl = TRUE)+ each = max_obs_per_plot, |
|
| 222 | 1x |
- x_positions <- regmatches(x = str, m = positions)[[1]]+ length.out = length(id_vec) |
|
| 223 |
-
+ ) |
||
| 224 |
- # Roundings depends on the number of x behind [.].+ ) |
||
| 225 | -1x | +
- roundings <- lapply(+ |
|
| 226 | 1x |
- X = x_positions,+ df_list <- list() |
|
| 227 | 1x |
- function(x) {
+ plot_list <- list() |
|
| 228 | -2x | +
- y <- strsplit(split = "\\.", x = x)[[1]]+ |
|
| 229 | -2x | +1x |
- rounding <- function(x) {
+ for (i in seq_along(id_list)) {
|
| 230 | -4x | +2x |
- round(x, digits = ifelse(length(y) > 1, nchar(y[2]), 0))+ df_list[[i]] <- df[df[[id_var]] %in% id_list[[i]], ] |
| 231 |
- }+ |
||
| 232 | 2x |
- return(rounding)+ plots <- h_g_ipp( |
|
| 233 | -+ | 2x |
- }+ df = df_list[[i]], |
| 234 | -+ | 2x |
- )+ xvar = xvar, |
| 235 | -+ | 2x |
-
+ yvar = yvar, |
| 236 | -1x | +2x |
- rtable_format <- function(x, output) {
+ xlab = xlab, |
| 237 | 2x |
- values <- Map(y = x, fun = roundings, function(y, fun) fun(y))+ ylab = ylab, |
|
| 238 | 2x |
- regmatches(x = str, m = positions)[[1]] <- values+ id_var = id_var, |
|
| 239 | 2x |
- return(str)+ title = title, |
|
| 240 | -+ | 2x |
- }+ subtitle = subtitle, |
| 241 | -+ | 2x |
-
+ caption = caption, |
| 242 | -1x | +2x |
- return(rtable_format)+ add_baseline_hline = add_baseline_hline, |
| 243 | -+ | 2x |
- }+ yvar_baseline = yvar_baseline, |
| 244 | -+ | 2x |
-
+ ggtheme = ggtheme, |
| 245 | -+ | 2x |
- #' Format numeric values by significant figures+ col = col |
| 246 |
- #'+ ) |
||
| 247 |
- #' Format numeric values to print with a specified number of significant figures.+ |
||
| 248 | -+ | 2x |
- #'+ plot_list[[i]] <- plots |
| 249 |
- #' @param sigfig (`integer(1)`)\cr number of significant figures to display.+ } |
||
| 250 | -+ | 1x |
- #' @param format (`string`)\cr the format label (string) to apply when printing the value. Decimal+ return(plot_list) |
| 251 |
- #' places in string are ignored in favor of formatting by significant figures. Formats options are:+ } else {
|
||
| 252 | -+ | 1x |
- #' `"xx"`, `"xx / xx"`, `"(xx, xx)"`, `"xx - xx"`, and `"xx (xx)"`.+ ind_df <- split(df, df[[id_var]]) |
| 253 | -+ | 1x |
- #' @param num_fmt (`string`)\cr numeric format modifiers to apply to the value. Defaults to `"fg"` for+ plot_list <- lapply( |
| 254 | -+ | 1x |
- #' standard significant figures formatting - fixed (non-scientific notation) format (`"f"`)+ ind_df, |
| 255 | -+ | 1x |
- #' and `sigfig` equal to number of significant figures instead of decimal places (`"g"`). See the+ function(x) {
|
| 256 | -+ | 8x |
- #' [formatC()] `format` argument for more options.+ h_g_ipp( |
| 257 | -+ | 8x |
- #'+ df = x, |
| 258 | -+ | 8x |
- #' @return An `rtables` formatting function.+ xvar = xvar, |
| 259 | -+ | 8x |
- #'+ yvar = yvar, |
| 260 | -+ | 8x |
- #' @examples+ xlab = xlab, |
| 261 | -+ | 8x |
- #' fmt_3sf <- format_sigfig(3)+ ylab = ylab, |
| 262 | -+ | 8x |
- #' fmt_3sf(1.658)+ id_var = id_var, |
| 263 | -+ | 8x |
- #' fmt_3sf(1e1)+ title = title, |
| 264 | -+ | 8x |
- #'+ subtitle = subtitle, |
| 265 | -+ | 8x |
- #' fmt_5sf <- format_sigfig(5)+ caption = caption, |
| 266 | -+ | 8x |
- #' fmt_5sf(0.57)+ add_baseline_hline = add_baseline_hline, |
| 267 | -+ | 8x |
- #' fmt_5sf(0.000025645)+ yvar_baseline = yvar_baseline, |
| 268 | -+ | 8x |
- #'+ ggtheme = ggtheme, |
| 269 | -+ | 8x |
- #' @family formatting functions+ col = col |
| 270 |
- #' @export+ ) |
||
| 271 |
- format_sigfig <- function(sigfig, format = "xx", num_fmt = "fg") {
+ } |
||
| 272 | -3x | +
- checkmate::assert_integerish(sigfig)+ ) |
|
| 273 | -3x | +
- format <- gsub("xx\\.|xx\\.x+", "xx", format)
+
|
|
| 274 | -3x | +1x |
- checkmate::assert_choice(format, c("xx", "xx / xx", "(xx, xx)", "xx - xx", "xx (xx)"))
+ return(plot_list) |
| 275 | -3x | +
- function(x, ...) {
+ } |
|
| 276 | -! | +
- if (!is.numeric(x)) stop("`format_sigfig` cannot be used for non-numeric values. Please choose another format.")
+ } |
|
| 277 | -12x | +
| 1 | +
- num <- formatC(signif(x, digits = sigfig), digits = sigfig, format = num_fmt, flag = "#")+ #' Additional assertions to use with `checkmate` |
|||
| 278 | -12x | +|||
| 2 | +
- num <- gsub("\\.$", "", num) # remove trailing "."
+ #' |
|||
| 279 | +3 |
-
+ #' Additional assertion functions which can be used together with the `checkmate` package. |
||
| 280 | -12x | +|||
| 4 | +
- format_value(num, format)+ #' |
|||
| 281 | +5 |
- }+ #' @inheritParams checkmate::assert_factor |
||
| 282 | +6 |
- }+ #' @param x (`any`)\cr object to test. |
||
| 283 | +7 |
-
+ #' @param df (`data.frame`)\cr data set to test. |
||
| 284 | +8 |
- #' Format fraction with lower threshold+ #' @param variables (named `list` of `character`)\cr list of variables to test. |
||
| 285 | +9 |
- #'+ #' @param include_boundaries (`flag`)\cr whether to include boundaries when testing |
||
| 286 | +10 |
- #' @description `r lifecycle::badge("stable")`
+ #' for proportions. |
||
| 287 | +11 |
- #'+ #' @param na_level (`string`)\cr the string you have been using to represent NA or |
||
| 288 | +12 |
- #' Formats a fraction when the second element of the input `x` is the fraction. It applies+ #' missing data. For `NA` values please consider using directly [is.na()] or |
||
| 289 | +13 |
- #' a lower threshold, below which it is just stated that the fraction is smaller than that.+ #' similar approaches. |
||
| 290 | +14 |
#' |
||
| 291 | +15 |
- #' @param threshold (`proportion`)\cr lower threshold.+ #' @return Nothing if assertion passes, otherwise prints the error message. |
||
| 292 | +16 |
#' |
||
| 293 | +17 |
- #' @return An `rtables` formatting function that takes numeric input `x` where the second+ #' @name assertions |
||
| 294 | +18 |
- #' element is the fraction that is formatted. If the fraction is above or equal to the threshold,+ NULL |
||
| 295 | +19 |
- #' then it is displayed in percentage. If it is positive but below the threshold, it returns,+ |
||
| 296 | +20 |
- #' e.g. "<1" if the threshold is `0.01`. If it is zero, then just "0" is returned.+ check_list_of_variables <- function(x) {
|
||
| 297 | +21 |
- #'+ # drop NULL elements in list+ |
+ ||
| 22 | +2960x | +
+ x <- Filter(Negate(is.null), x) |
||
| 298 | +23 |
- #' @examples+ + |
+ ||
| 24 | +2960x | +
+ res <- checkmate::check_list(x,+ |
+ ||
| 25 | +2960x | +
+ names = "named",+ |
+ ||
| 26 | +2960x | +
+ min.len = 1,+ |
+ ||
| 27 | +2960x | +
+ any.missing = FALSE,+ |
+ ||
| 28 | +2960x | +
+ types = "character" |
||
| 299 | +29 |
- #' format_fun <- format_fraction_threshold(0.05)+ ) |
||
| 300 | +30 |
- #' format_fun(x = c(20, 0.1))+ # no empty strings allowed+ |
+ ||
| 31 | +2960x | +
+ if (isTRUE(res)) {
+ |
+ ||
| 32 | +2955x | +
+ res <- checkmate::check_character(unlist(x), min.chars = 1) |
||
| 301 | +33 |
- #' format_fun(x = c(2, 0.01))+ }+ |
+ ||
| 34 | +2960x | +
+ return(res) |
||
| 302 | +35 |
- #' format_fun(x = c(0, 0))+ } |
||
| 303 | +36 | ++ |
+ #' @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 |
#' |
|||
| 304 | +39 |
- #' @family formatting functions+ #' @keywords internal |
||
| 305 | +40 |
- #' @export+ assert_list_of_variables <- checkmate::makeAssertionFunction(check_list_of_variables)+ |
+ ||
| 41 | ++ | + + | +||
| 42 | ++ |
+ check_df_with_variables <- function(df, variables, na_level = NULL) {
+ |
+ ||
| 43 | +2643x | +
+ checkmate::assert_data_frame(df)+ |
+ ||
| 44 | +2641x | +
+ assert_list_of_variables(variables) |
||
| 306 | +45 |
- format_fraction_threshold <- function(threshold) {
+
|
||
| 307 | -1x | +|||
| 46 | +
- assert_proportion_value(threshold)+ # flag for equal variables and column names |
|||
| 308 | -1x | +47 | +2639x |
- string_below_threshold <- paste0("<", round(threshold * 100))
+ err_flag <- all(unlist(variables) %in% colnames(df)) |
| 309 | -1x | +48 | +2639x |
- function(x, ...) {
+ checkmate::assert_flag(err_flag) |
| 310 | -3x | +|||
| 49 | +
- assert_proportion_value(x[2], include_boundaries = TRUE)+ |
|||
| 311 | -3x | +50 | +2639x |
- ifelse(+ if (isFALSE(err_flag)) {
|
| 312 | -3x | +51 | +5x |
- x[2] > 0.01,+ vars <- setdiff(unlist(variables), colnames(df)) |
| 313 | -3x | +52 | +5x |
- round(x[2] * 100),+ return(paste( |
| 314 | -3x | +53 | +5x |
- ifelse(+ deparse(substitute(df)), |
| 315 | -3x | +54 | +5x |
- x[2] == 0,+ "does not contain all specified variables as column names. Missing from data frame:", |
| 316 | -3x | +55 | +5x |
- "0",+ paste(vars, collapse = ", ") |
| 317 | -3x | +|||
| 56 | +
- string_below_threshold+ )) |
|||
| 318 | +57 |
- )+ } |
||
| 319 | +58 |
- )+ # checking if na_level is present and in which column |
||
| 320 | -+ | |||
| 59 | +2634x |
- }+ if (!is.null(na_level)) {
|
||
| 321 | -+ | |||
| 60 | +9x |
- }+ checkmate::assert_string(na_level) |
||
| 322 | -+ | |||
| 61 | +9x |
-
+ res <- unlist(lapply(as.list(df)[unlist(variables)], function(x) any(x == na_level))) |
||
| 323 | -+ | |||
| 62 | +9x |
- #' Format extreme values+ if (any(res)) {
|
||
| 324 | -+ | |||
| 63 | +1x |
- #'+ return(paste0( |
||
| 325 | -+ | |||
| 64 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ deparse(substitute(df)), " contains explicit na_level (", na_level,
|
||
| 326 | -+ | |||
| 65 | +1x |
- #'+ ") in the following columns: ", paste0(unlist(variables)[res], |
||
| 327 | -+ | |||
| 66 | +1x |
- #' `rtables` formatting functions that handle extreme values.+ collapse = ", " |
||
| 328 | +67 |
- #'+ ) |
||
| 329 | +68 |
- #' @param digits (`integer(1)`)\cr number of decimal places to display.+ )) |
||
| 330 | +69 |
- #'+ } |
||
| 331 | +70 |
- #' @details For each input, apply a format to the specified number of `digits`. If the value is+ } |
||
| 332 | -+ | |||
| 71 | +2633x |
- #' below a threshold, it returns "<0.01" e.g. if the number of `digits` is 2. If the value is+ return(TRUE) |
||
| 333 | +72 |
- #' above a threshold, it returns ">999.99" e.g. if the number of `digits` is 2.+ } |
||
| 334 | +73 |
- #' If it is zero, then returns "0.00".+ #' @describeIn assertions Check whether `df` is a data frame with the analysis `variables`. |
||
| 335 | +74 |
- #'+ #' Please notice how this produces an error when not all variables are present in the |
||
| 336 | +75 |
- #' @family formatting functions+ #' data.frame while the opposite is not required. |
||
| 337 | +76 |
- #' @name extreme_format+ #' |
||
| 338 | +77 |
- NULL+ #' @keywords internal |
||
| 339 | +78 |
-
+ assert_df_with_variables <- checkmate::makeAssertionFunction(check_df_with_variables) |
||
| 340 | +79 |
- #' @describeIn extreme_format Internal helper function to calculate the threshold and create formatted strings+ |
||
| 341 | +80 |
- #' used in Formatting Functions. Returns a list with elements `threshold` and `format_string`.+ check_valid_factor <- function(x, |
||
| 342 | +81 |
- #'+ min.levels = 1, # nolint |
||
| 343 | +82 |
- #' @return+ max.levels = NULL, # nolint |
||
| 344 | +83 |
- #' * `h_get_format_threshold()` returns a `list` of 2 elements: `threshold`, with `low` and `high` thresholds,+ null.ok = TRUE, # nolint |
||
| 345 | +84 |
- #' and `format_string`, with thresholds formatted as strings.+ any.missing = TRUE, # nolint |
||
| 346 | +85 |
- #'+ n.levels = NULL, # nolint |
||
| 347 | +86 |
- #' @examples+ len = NULL) {
|
||
| 348 | +87 |
- #' h_get_format_threshold(2L)+ # checks on levels insertion |
||
| 349 | -+ | |||
| 88 | +1113x |
- #'+ checkmate::assert_int(min.levels, lower = 1) |
||
| 350 | +89 |
- #' @export+ |
||
| 351 | +90 |
- h_get_format_threshold <- function(digits = 2L) {
+ # main factor check |
||
| 352 | -2113x | +91 | +1113x |
- checkmate::assert_integerish(digits)+ res <- checkmate::check_factor(x, |
| 353 | -+ | |||
| 92 | +1113x |
-
+ min.levels = min.levels, |
||
| 354 | -2113x | +93 | +1113x |
- low_threshold <- 1 / (10 ^ digits) # styler: off+ null.ok = null.ok, |
| 355 | -2113x | +94 | +1113x |
- high_threshold <- 1000 - (1 / (10 ^ digits)) # styler: off+ max.levels = max.levels, |
| 356 | -+ | |||
| 95 | +1113x |
-
+ any.missing = any.missing, |
||
| 357 | -2113x | +96 | +1113x |
- string_below_threshold <- paste0("<", low_threshold)
+ n.levels = n.levels |
| 358 | -2113x | +|||
| 97 | +
- string_above_threshold <- paste0(">", high_threshold)
+ ) |
|||
| 359 | +98 | |||
| 360 | -2113x | +|||
| 99 | +
- list(+ # no empty strings allowed |
|||
| 361 | -2113x | +100 | +1113x |
- "threshold" = c(low = low_threshold, high = high_threshold),+ if (isTRUE(res)) {
|
| 362 | -2113x | -
- "format_string" = c(low = string_below_threshold, high = string_above_threshold)- |
- ||
| 363 | -+ | 101 | +1099x |
- )+ res <- checkmate::check_character(levels(x), min.chars = 1) |
| 364 | +102 |
- }+ } |
||
| 365 | +103 | |||
| 366 | -+ | |||
| 104 | +1113x |
- #' @describeIn extreme_format Internal helper function to apply a threshold format to a value.+ return(res) |
||
| 367 | +105 |
- #' Creates a formatted string to be used in Formatting Functions.+ } |
||
| 368 | +106 |
- #'+ #' @describeIn assertions Check whether `x` is a valid factor (i.e. has levels and no empty |
||
| 369 | +107 |
- #' @param x (`numeric(1)`)\cr value to format.+ #' string levels). Note that `NULL` and `NA` elements are allowed. |
||
| 370 | +108 |
#' |
||
| 371 | -- |
- #' @return- |
- ||
| 372 | +109 |
- #' * `h_format_threshold()` returns the given value, or if the value is not within the digit threshold the relation+ #' @keywords internal |
||
| 373 | +110 |
- #' of the given value to the digit threshold, as a formatted string.+ assert_valid_factor <- checkmate::makeAssertionFunction(check_valid_factor) |
||
| 374 | +111 |
- #'+ |
||
| 375 | +112 |
- #' @examples+ check_df_with_factors <- function(df, |
||
| 376 | +113 |
- #' h_format_threshold(0.001)+ variables, |
||
| 377 | +114 |
- #' h_format_threshold(1000)+ min.levels = 1, # nolint |
||
| 378 | +115 |
- #'+ max.levels = NULL, # nolint |
||
| 379 | +116 |
- #' @export+ any.missing = TRUE, # nolint |
||
| 380 | +117 |
- h_format_threshold <- function(x, digits = 2L) {
+ na_level = NULL) {
|
||
| 381 | -2115x | +118 | +254x |
- if (is.na(x)) {
+ res <- check_df_with_variables(df, variables, na_level) |
| 382 | -4x | +|||
| 119 | +
- return(x)+ # checking if all the columns specified by variables are valid factors |
|||
| 383 | -+ | |||
| 120 | +253x |
- }+ if (isTRUE(res)) {
|
||
| 384 | +121 |
-
+ # searching the data.frame with selected columns (variables) as a list |
||
| 385 | -2111x | +122 | +251x |
- checkmate::assert_numeric(x, lower = 0)+ res <- lapply( |
| 386 | -+ | |||
| 123 | +251x |
-
+ X = as.list(df)[unlist(variables)], |
||
| 387 | -2111x | +124 | +251x |
- l_fmt <- h_get_format_threshold(digits)+ FUN = check_valid_factor, |
| 388 | -+ | |||
| 125 | +251x |
-
+ min.levels = min.levels, |
||
| 389 | -2111x | +126 | +251x |
- result <- if (x < l_fmt$threshold["low"] && 0 < x) {
+ max.levels = max.levels, |
| 390 | -44x | +127 | +251x |
- l_fmt$format_string["low"]+ any.missing = any.missing |
| 391 | -2111x | +|||
| 128 | +
- } else if (x > l_fmt$threshold["high"]) {
+ ) |
|||
| 392 | -99x | +129 | +251x |
- l_fmt$format_string["high"]+ res_lo <- unlist(vapply(res, Negate(isTRUE), logical(1))) |
| 393 | -+ | |||
| 130 | +251x |
- } else {
+ if (any(res_lo)) {
|
||
| 394 | -1968x | +131 | +6x |
- sprintf(fmt = paste0("%.", digits, "f"), x)
+ return(paste0( |
| 395 | -+ | |||
| 132 | +6x |
- }+ deparse(substitute(df)), " does not contain only factor variables among:", |
||
| 396 | -+ | |||
| 133 | +6x |
-
+ "\n* Column `", paste0(unlist(variables)[res_lo], |
||
| 397 | -2111x | +134 | +6x |
- unname(result)+ "` of the data.frame -> ", res[res_lo], |
| 398 | -+ | |||
| 135 | +6x |
- }+ collapse = "\n* " |
||
| 399 | +136 |
-
+ ) |
||
| 400 | +137 |
- #' Format a single extreme value+ )) |
||
| 401 | +138 |
- #'+ } else {
|
||
| 402 | -+ | |||
| 139 | +245x |
- #' @description `r lifecycle::badge("stable")`
+ res <- TRUE |
||
| 403 | +140 |
- #'+ } |
||
| 404 | +141 |
- #' Create a formatting function for a single extreme value.+ } |
||
| 405 | -+ | |||
| 142 | +247x |
- #'+ return(res) |
||
| 406 | +143 |
- #' @inheritParams extreme_format+ } |
||
| 407 | +144 |
- #'+ |
||
| 408 | +145 |
- #' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme value.+ #' @describeIn assertions Check whether `df` is a data frame where the analysis `variables` |
||
| 409 | +146 |
- #'+ #' are all factors. Note that the creation of `NA` by direct call of `factor()` will |
||
| 410 | +147 |
- #' @examples+ #' trim `NA` levels out of the vector list itself. |
||
| 411 | +148 |
- #' format_fun <- format_extreme_values(2L)+ #' |
||
| 412 | +149 |
- #' format_fun(x = 0.127)+ #' @keywords internal |
||
| 413 | +150 |
- #' format_fun(x = Inf)+ assert_df_with_factors <- checkmate::makeAssertionFunction(check_df_with_factors) |
||
| 414 | +151 |
- #' format_fun(x = 0)+ |
||
| 415 | +152 |
- #' format_fun(x = 0.009)+ #' @describeIn assertions Check whether `x` is a proportion: number between 0 and 1. |
||
| 416 | +153 |
#' |
||
| 417 | +154 |
- #' @family formatting functions+ #' @keywords internal |
||
| 418 | +155 |
- #' @export+ assert_proportion_value <- function(x, include_boundaries = FALSE) {
|
||
| 419 | -+ | |||
| 156 | +18831x |
- format_extreme_values <- function(digits = 2L) {
+ checkmate::assert_number(x, lower = 0, upper = 1) |
||
| 420 | -63x | +157 | +18819x |
- function(x, ...) {
+ checkmate::assert_flag(include_boundaries) |
| 421 | -657x | +158 | +18819x |
- checkmate::assert_scalar(x, na.ok = TRUE)+ if (isFALSE(include_boundaries)) {
|
| 422 | -+ | |||
| 159 | +12931x |
-
+ checkmate::assert_true(x > 0) |
||
| 423 | -657x | +160 | +12929x |
- h_format_threshold(x = x, digits = digits)+ checkmate::assert_true(x < 1) |
| 424 | +161 |
} |
||
| 425 | +162 |
} |
| 426 | -- | - - | -||
| 427 | +1 |
- #' Format extreme values part of a confidence interval+ #' Univariate formula special term |
||
| 428 | +2 |
#' |
||
| 429 | +3 |
#' @description `r lifecycle::badge("stable")`
|
||
| 430 | +4 |
#' |
||
| 431 | +5 |
- #' Formatting Function for extreme values part of a confidence interval. Values+ #' The special term `univariate` indicate that the model should be fitted individually for |
||
| 432 | +6 |
- #' are formatted as e.g. "(xx.xx, xx.xx)" if the number of `digits` is 2.+ #' every variable included in univariate. |
||
| 433 | +7 |
#' |
||
| 434 | +8 |
- #' @inheritParams extreme_format+ #' @param x (`character`)\cr a vector of variable names separated by commas. |
||
| 435 | +9 |
#' |
||
| 436 | +10 |
- #' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme+ #' @return When used within a model formula, produces univariate models for each variable provided. |
||
| 437 | +11 |
- #' values confidence interval.+ #' |
||
| 438 | +12 |
- #'+ #' @details |
||
| 439 | +13 |
- #' @examples+ #' If provided alongside with pairwise specification, the model |
||
| 440 | +14 |
- #' format_fun <- format_extreme_values_ci(2L)+ #' `y ~ ARM + univariate(SEX, AGE, RACE)` lead to the study and comparison of the models |
||
| 441 | +15 |
- #' format_fun(x = c(0.127, Inf))+ #' + `y ~ ARM` |
||
| 442 | +16 |
- #' format_fun(x = c(0, 0.009))+ #' + `y ~ ARM + SEX` |
||
| 443 | +17 |
- #'+ #' + `y ~ ARM + AGE` |
||
| 444 | +18 |
- #' @family formatting functions+ #' + `y ~ ARM + RACE` |
||
| 445 | +19 |
- #' @export+ #' |
||
| 446 | +20 |
- format_extreme_values_ci <- function(digits = 2L) {
- |
- ||
| 447 | -71x | -
- function(x, ...) {
- |
- ||
| 448 | -726x | -
- checkmate::assert_vector(x, len = 2)- |
- ||
| 449 | -726x | -
- l_result <- h_format_threshold(x = x[1], digits = digits)- |
- ||
| 450 | -726x | -
- h_result <- h_format_threshold(x = x[2], digits = digits)+ #' @export |
||
| 451 | +21 |
-
+ univariate <- function(x) {
|
||
| 452 | -726x | +22 | +2x |
- paste0("(", l_result, ", ", h_result, ")")
+ structure(x, varname = deparse(substitute(x))) |
| 453 | +23 |
- }+ } |
||
| 454 | +24 |
- }+ |
||
| 455 | +25 |
-
+ # Get the right-hand-term of a formula |
||
| 456 | +26 |
- #' Format automatically using data significant digits+ rht <- function(x) {
|
||
| 457 | -+ | |||
| 27 | +4x |
- #'+ checkmate::assert_formula(x) |
||
| 458 | -+ | |||
| 28 | +4x |
- #' @description `r lifecycle::badge("stable")`
+ y <- as.character(rev(x)[[1]]) |
||
| 459 | -+ | |||
| 29 | +4x |
- #'+ return(y) |
||
| 460 | +30 |
- #' Formatting function for the majority of default methods used in [analyze_vars()].+ } |
||
| 461 | +31 |
- #' For non-derived values, the significant digits of data is used (e.g. range), while derived+ |
||
| 462 | +32 |
- #' values have one more digits (measure of location and dispersion like mean, standard deviation).+ #' Hazard ratio estimation in interactions |
||
| 463 | +33 |
- #' This function can be called internally with "auto" like, for example,+ #' |
||
| 464 | +34 |
- #' `.formats = c("mean" = "auto")`. See details to see how this works with the inner function.
+ #' This function estimates the hazard ratios between arms when an interaction variable is given with |
||
| 465 | +35 |
- #'+ #' specific values. |
||
| 466 | +36 |
- #' @param dt_var (`numeric`)\cr variable data the statistics were calculated from. Used only to+ #' |
||
| 467 | +37 |
- #' find significant digits. In [analyze_vars] this comes from `.df_row` (see+ #' @param variable,given (`character(2)`)\cr names of the two variables in the interaction. We seek the estimation of |
||
| 468 | +38 |
- #' [rtables::additional_fun_params]), and it is the row data after the above row splits. No+ #' the levels of `variable` given the levels of `given`. |
||
| 469 | +39 |
- #' column split is considered.+ #' @param lvl_var,lvl_given (`character`)\cr corresponding levels given by [levels()]. |
||
| 470 | +40 |
- #' @param x_stat (`string`)\cr string indicating the current statistical method used.+ #' @param mmat (named `numeric`) a vector filled with `0`s used as a template to obtain the design matrix. |
||
| 471 | +41 |
- #'+ #' @param coef (`numeric`)\cr vector of estimated coefficients. |
||
| 472 | +42 |
- #' @return A string that `rtables` prints in a table cell.+ #' @param vcov (`matrix`)\cr variance-covariance matrix of underlying model. |
||
| 473 | +43 |
- #'+ #' @param conf_level (`proportion`)\cr confidence level of estimate intervals. |
||
| 474 | +44 |
- #' @details+ #' |
||
| 475 | +45 |
- #' The internal function is needed to work with `rtables` default structure for+ #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A) |
||
| 476 | +46 |
- #' format functions, i.e. `function(x, ...)`, where is x are results from statistical evaluation.+ #' and Sex (F, M; reference Female). The model is abbreviated: y ~ Arm + Sex + Arm x Sex. |
||
| 477 | +47 |
- #' It can be more than one element (e.g. for `.stats = "mean_sd"`).+ #' The cox regression estimates the coefficients along with a variance-covariance matrix for: |
||
| 478 | +48 |
#' |
||
| 479 | +49 |
- #' @examples+ #' - b1 (arm b), b2 (arm c) |
||
| 480 | +50 |
- #' x_todo <- c(0.001, 0.2, 0.0011000, 3, 4)+ #' - b3 (sex m) |
||
| 481 | +51 |
- #' res <- c(mean(x_todo[1:3]), sd(x_todo[1:3]))+ #' - b4 (arm b: sex m), b5 (arm c: sex m) |
||
| 482 | +52 |
#' |
||
| 483 | +53 |
- #' # x is the result coming into the formatting function -> res!!+ #' Given that I want an estimation of the Hazard Ratio for arm C/sex M, the estimation |
||
| 484 | +54 |
- #' format_auto(dt_var = x_todo, x_stat = "mean_sd")(x = res)+ #' will be given in reference to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5), |
||
| 485 | +55 |
- #' format_auto(x_todo, "range")(x = range(x_todo))+ #' therefore the interaction coefficient is given by b2 + b5 while the standard error is obtained |
||
| 486 | +56 |
- #' no_sc_x <- c(0.0000001, 1)+ #' as $1.96 * sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$ for a confidence level of 0.95. |
||
| 487 | +57 |
- #' format_auto(no_sc_x, "range")(x = no_sc_x)+ #' |
||
| 488 | +58 |
- #'+ #' @return A list of matrices (one per level of variable) with rows corresponding to the combinations of |
||
| 489 | +59 |
- #' @family formatting functions+ #' `variable` and `given`, with columns: |
||
| 490 | +60 |
- #' @export+ #' * `coef_hat`: Estimation of the coefficient. |
||
| 491 | +61 |
- format_auto <- function(dt_var, x_stat) {
- |
- ||
| 492 | -14x | -
- function(x = "", ...) {
- |
- ||
| 493 | -31x | -
- checkmate::assert_numeric(x, min.len = 1)- |
- ||
| 494 | -31x | -
- checkmate::assert_numeric(dt_var, min.len = 1)+ #' * `coef_se`: Standard error of the estimation. |
||
| 495 | +62 |
- # Defaults - they may be a param in the future- |
- ||
| 496 | -31x | -
- der_stats <- c(- |
- ||
| 497 | -31x | -
- "mean", "sd", "se", "median", "geom_mean", "quantiles", "iqr",- |
- ||
| 498 | -31x | -
- "mean_sd", "mean_se", "mean_se", "mean_ci", "mean_sei", "mean_sdi",+ #' * `hr`: Hazard ratio. |
||
| 499 | -31x | +|||
| 63 | +
- "median_ci"+ #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio. |
|||
| 500 | +64 |
- )+ #' |
||
| 501 | -31x | +|||
| 65 | +
- nonder_stats <- c("n", "range", "min", "max")
+ #' @seealso [s_cox_multivariate()]. |
|||
| 502 | +66 |
-
+ #' |
||
| 503 | +67 |
- # Safenet for miss-modifications+ #' @examples |
||
| 504 | -31x | +|||
| 68 | +
- stopifnot(length(intersect(der_stats, nonder_stats)) == 0) # nolint+ #' library(dplyr) |
|||
| 505 | -31x | +|||
| 69 | +
- checkmate::assert_choice(x_stat, c(der_stats, nonder_stats))+ #' library(survival) |
|||
| 506 | +70 |
-
+ #' |
||
| 507 | +71 |
- # Finds the max number of digits in data+ #' ADSL <- tern_ex_adsl %>% |
||
| 508 | -31x | +|||
| 72 | +
- detect_dig <- vapply(dt_var, count_decimalplaces, FUN.VALUE = numeric(1)) %>%+ #' filter(SEX %in% c("F", "M"))
|
|||
| 509 | -31x | +|||
| 73 | +
- max()+ #' |
|||
| 510 | +74 |
-
+ #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "PFS") |
||
| 511 | -31x | +|||
| 75 | +
- if (x_stat %in% der_stats) {
+ #' adtte$ARMCD <- droplevels(adtte$ARMCD) |
|||
| 512 | -19x | +|||
| 76 | +
- detect_dig <- detect_dig + 1+ #' adtte$SEX <- droplevels(adtte$SEX) |
|||
| 513 | +77 |
- }+ #' |
||
| 514 | +78 |
-
+ #' mod <- coxph( |
||
| 515 | +79 |
- # Render input+ #' formula = Surv(time = AVAL, event = 1 - CNSR) ~ (SEX + ARMCD)^2, |
||
| 516 | -31x | +|||
| 80 | +
- str_vals <- formatC(x, digits = detect_dig, format = "f")+ #' data = adtte |
|||
| 517 | -31x | +|||
| 81 | +
- def_fmt <- get_formats_from_stats(x_stat)[[x_stat]]+ #' ) |
|||
| 518 | -31x | +|||
| 82 | +
- str_fmt <- str_extract(def_fmt, invert = FALSE)[[1]]+ #' |
|||
| 519 | -31x | +|||
| 83 | +
- if (length(str_fmt) != length(str_vals)) {
+ #' mmat <- stats::model.matrix(mod)[1, ] |
|||
| 520 | -2x | +|||
| 84 | +
- stop(+ #' mmat[!mmat == 0] <- 0 |
|||
| 521 | -2x | +|||
| 85 | +
- "Number of inserted values as result (", length(str_vals),
+ #' |
|||
| 522 | -2x | +|||
| 86 | +
- ") is not the same as there should be in the default tern formats for ",+ #' @keywords internal |
|||
| 523 | -2x | +|||
| 87 | +
- x_stat, " (-> ", def_fmt, " needs ", length(str_fmt), " values). ",+ estimate_coef <- function(variable, given, |
|||
| 524 | -2x | +|||
| 88 | +
- "See tern_default_formats to check all of them."+ lvl_var, lvl_given, |
|||
| 525 | +89 |
- )+ coef, |
||
| 526 | +90 |
- }+ mmat, |
||
| 527 | +91 |
-
+ vcov, |
||
| 528 | +92 |
- # Squashing them together+ conf_level = 0.95) {
|
||
| 529 | -29x | +93 | +8x |
- inv_str_fmt <- str_extract(def_fmt, invert = TRUE)[[1]]+ var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level |
| 530 | -29x | +94 | +8x |
- stopifnot(length(inv_str_fmt) == length(str_vals) + 1) # nolint+ giv_lvl <- paste0(given, lvl_given) |
| 531 | +95 | |||
| 532 | -29x | +96 | +8x |
- out <- vector("character", length = length(inv_str_fmt) + length(str_vals))
+ design_mat <- expand.grid(variable = var_lvl, given = giv_lvl) |
| 533 | -29x | +97 | +8x |
- is_even <- seq_along(out) %% 2 == 0+ design_mat <- design_mat[order(design_mat$variable, design_mat$given), ] |
| 534 | -29x | +98 | +8x |
- out[is_even] <- str_vals+ design_mat <- within( |
| 535 | -29x | -
- out[!is_even] <- inv_str_fmt- |
- ||
| 536 | -+ | 99 | +8x |
-
+ data = design_mat, |
| 537 | -29x | +100 | +8x |
- return(paste0(out, collapse = ""))+ expr = {
|
| 538 | -+ | |||
| 101 | +8x |
- }+ inter <- paste0(variable, ":", given) |
||
| 539 | -+ | |||
| 102 | +8x |
- }+ rev_inter <- paste0(given, ":", variable) |
||
| 540 | +103 |
-
+ } |
||
| 541 | +104 |
- # Utility function that could be useful in general+ ) |
||
| 542 | +105 |
- str_extract <- function(string, pattern = "xx|xx\\.|xx\\.x+", invert = FALSE) {
+
|
||
| 543 | -60x | +106 | +8x |
- regmatches(string, gregexpr(pattern, string), invert = invert)+ split_by_variable <- design_mat$variable |
| 544 | -+ | |||
| 107 | +8x |
- }+ interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/") |
||
| 545 | +108 | |||
| 546 | -- |
- # Helper function- |
- ||
| 547 | -+ | |||
| 109 | +8x |
- count_decimalplaces <- function(dec) {
+ design_mat <- apply( |
||
| 548 | -226x | +110 | +8x |
- if (is.na(dec)) {
+ X = design_mat, MARGIN = 1, FUN = function(x) {
|
| 549 | -6x | +111 | +27x |
- return(0)+ mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1 |
| 550 | -220x | +112 | +27x |
- } else if (abs(dec - round(dec)) > .Machine$double.eps^0.5) { # For precision
+ return(mmat) |
| 551 | -161x | +|||
| 113 | +
- nchar(strsplit(format(dec, scientific = FALSE, trim = FALSE), ".", fixed = TRUE)[[1]][[2]])+ } |
|||
| 552 | +114 |
- } else {
+ ) |
||
| 553 | -59x | +115 | +8x |
- return(0)+ colnames(design_mat) <- interaction_names |
| 554 | +116 |
- }+ |
||
| 555 | -+ | |||
| 117 | +8x |
- }+ betas <- as.matrix(coef) |
||
| 556 | +118 | |||
| 557 | -+ | |||
| 119 | +8x |
- #' Apply automatic formatting+ coef_hat <- t(design_mat) %*% betas |
||
| 558 | -+ | |||
| 120 | +8x |
- #'+ dimnames(coef_hat)[2] <- "coef" |
||
| 559 | +121 |
- #' Checks if any of the listed formats in `.formats` are `"auto"`, and replaces `"auto"` with+ |
||
| 560 | -+ | |||
| 122 | +8x |
- #' the correct implementation of `format_auto` for the given statistics, data, and variable.+ coef_se <- apply(design_mat, 2, function(x) {
|
||
| 561 | -+ | |||
| 123 | +27x |
- #'+ vcov_el <- as.logical(x) |
||
| 562 | -+ | |||
| 124 | +27x |
- #' @inheritParams argument_convention+ y <- vcov[vcov_el, vcov_el] |
||
| 563 | -+ | |||
| 125 | +27x |
- #' @param x_stats (named `list`)\cr a named list of statistics where each element corresponds+ y <- sum(y) |
||
| 564 | -+ | |||
| 126 | +27x |
- #' to an element in `.formats`, with matching names.+ y <- sqrt(y) |
||
| 565 | -+ | |||
| 127 | +27x |
- #'+ return(y) |
||
| 566 | +128 |
- #' @keywords internal+ }) |
||
| 567 | +129 |
- apply_auto_formatting <- function(.formats, x_stats, .df_row, .var) {
+
|
||
| 568 | -554x | +130 | +8x |
- is_auto_fmt <- vapply(.formats, function(ii) is.character(ii) && ii == "auto", logical(1))+ q_norm <- stats::qnorm((1 + conf_level) / 2) |
| 569 | -554x | +131 | +8x |
- if (any(is_auto_fmt)) {
+ y <- cbind(coef_hat, `se(coef)` = coef_se) |
| 570 | -6x | +|||
| 132 | +
- auto_stats <- x_stats[is_auto_fmt]+ |
|||
| 571 | -6x | +133 | +8x |
- var_df <- .df_row[[.var]] # xxx this can be extended for the WHOLE data or single facets+ y <- apply(y, 1, function(x) {
|
| 572 | -6x | +134 | +27x |
- .formats[is_auto_fmt] <- lapply(names(auto_stats), format_auto, dt_var = var_df)+ x["hr"] <- exp(x["coef"]) |
| 573 | -+ | |||
| 135 | +27x |
- }+ x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"]) |
||
| 574 | -554x | +136 | +27x |
- .formats+ x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"]) |
| 575 | +137 |
- }+ |
| 1 | -+ | |||
| 138 | +27x |
- #' Individual patient plots+ return(x) |
||
| 2 | +139 |
- #'+ }) |
||
| 3 | +140 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 4 | -+ | |||
| 141 | +8x |
- #'+ y <- t(y) |
||
| 5 | -+ | |||
| 142 | +8x |
- #' Line plot(s) displaying trend in patients' parameter values over time is rendered.+ y <- by(y, split_by_variable, identity) |
||
| 6 | -+ | |||
| 143 | +8x |
- #' Patients' individual baseline values can be added to the plot(s) as reference.+ y <- lapply(y, as.matrix) |
||
| 7 | +144 |
- #'+ |
||
| 8 | -+ | |||
| 145 | +8x |
- #' @inheritParams argument_convention+ attr(y, "details") <- paste0( |
||
| 9 | -+ | |||
| 146 | +8x |
- #' @param xvar (`string`)\cr time point variable to be plotted on x-axis.+ "Estimations of ", variable, |
||
| 10 | -+ | |||
| 147 | +8x |
- #' @param yvar (`string`)\cr continuous analysis variable to be plotted on y-axis.+ " hazard ratio given the level of ", given, " compared to ", |
||
| 11 | -+ | |||
| 148 | +8x |
- #' @param xlab (`string`)\cr plot label for x-axis.+ variable, " level ", lvl_var[1], "." |
||
| 12 | +149 |
- #' @param ylab (`string`)\cr plot label for y-axis.+ ) |
||
| 13 | -+ | |||
| 150 | +8x |
- #' @param id_var (`string`)\cr variable used as patient identifier.+ return(y) |
||
| 14 | +151 |
- #' @param title (`string`)\cr title for plot.+ } |
||
| 15 | +152 |
- #' @param subtitle (`string`)\cr subtitle for plot.+ |
||
| 16 | +153 |
- #' @param add_baseline_hline (`flag`)\cr adds horizontal line at baseline y-value on+ #' `tryCatch` around `car::Anova` |
||
| 17 | +154 |
- #' plot when `TRUE`.+ #' |
||
| 18 | +155 |
- #' @param yvar_baseline (`string`)\cr variable with baseline values only.+ #' Captures warnings when executing [car::Anova]. |
||
| 19 | +156 |
- #' Ignored when `add_baseline_hline` is `FALSE`.+ #' |
||
| 20 | +157 |
- #' @param ggtheme (`theme`)\cr optional graphical theme function as provided+ #' @inheritParams car::Anova |
||
| 21 | +158 |
- #' by `ggplot2` to control outlook of plot. Use `ggplot2::theme()` to tweak the display.+ #' |
||
| 22 | +159 |
- #' @param plotting_choices (`string`)\cr specifies options for displaying+ #' @return A list with item `aov` for the result of the model and `error_text` for the captured warnings. |
||
| 23 | +160 |
- #' plots. Must be one of `"all_in_one"`, `"split_by_max_obs"`, or `"separate_by_obs"`.+ #' |
||
| 24 | +161 |
- #' @param max_obs_per_plot (`integer(1)`)\cr number of observations to be plotted on one+ #' @examples |
||
| 25 | +162 |
- #' plot. Ignored if `plotting_choices` is not `"separate_by_obs"`.+ #' # `car::Anova` on cox regression model including strata and expected |
||
| 26 | +163 |
- #' @param caption (`string`)\cr optional caption below the plot.+ #' # a likelihood ratio test triggers a warning as only Wald method is |
||
| 27 | +164 |
- #' @param col (`character`)\cr line colors.+ #' # accepted. |
||
| 28 | +165 |
#' |
||
| 29 | +166 |
- #' @seealso Relevant helper function [h_g_ipp()].+ #' library(survival) |
||
| 30 | +167 |
#' |
||
| 31 | +168 |
- #' @name g_ipp+ #' mod <- coxph( |
||
| 32 | +169 |
- #' @aliases individual_patient_plot+ #' formula = Surv(time = futime, event = fustat) ~ factor(rx) + strata(ecog.ps), |
||
| 33 | +170 |
- NULL+ #' data = ovarian |
||
| 34 | +171 |
-
+ #' ) |
||
| 35 | +172 |
- #' Helper function to create simple line plot over time+ #' |
||
| 36 | +173 |
- #'+ #' @keywords internal |
||
| 37 | +174 |
- #' @description `r lifecycle::badge("stable")`
+ try_car_anova <- function(mod, |
||
| 38 | +175 |
- #'+ test.statistic) { # nolint
|
||
| 39 | -+ | |||
| 176 | +1x |
- #' Function that generates a simple line plot displaying parameter trends over time.+ y <- tryCatch( |
||
| 40 | -+ | |||
| 177 | +1x |
- #'+ withCallingHandlers( |
||
| 41 | -+ | |||
| 178 | +1x |
- #' @inheritParams argument_convention+ expr = {
|
||
| 42 | -+ | |||
| 179 | +1x |
- #' @inheritParams g_ipp+ warn_text <- c() |
||
| 43 | -+ | |||
| 180 | +1x |
- #'+ list( |
||
| 44 | -+ | |||
| 181 | +1x |
- #' @return A `ggplot` line plot.+ aov = car::Anova( |
||
| 45 | -+ | |||
| 182 | +1x |
- #'+ mod, |
||
| 46 | -+ | |||
| 183 | +1x |
- #' @seealso [g_ipp()] which uses this function.+ test.statistic = test.statistic, |
||
| 47 | -+ | |||
| 184 | +1x |
- #'+ type = "III" |
||
| 48 | +185 |
- #' @examples+ ), |
||
| 49 | -+ | |||
| 186 | +1x |
- #' library(dplyr)+ warn_text = warn_text |
||
| 50 | +187 |
- #'+ ) |
||
| 51 | +188 |
- #' # Select a small sample of data to plot.+ }, |
||
| 52 | -+ | |||
| 189 | +1x |
- #' adlb <- tern_ex_adlb %>%+ warning = function(w) {
|
||
| 53 | +190 |
- #' filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
+ # If a warning is detected it is handled as "w". |
||
| 54 | -+ | |||
| 191 | +! |
- #' slice(1:36)+ warn_text <<- trimws(paste0("Warning in `try_car_anova`: ", w))
|
||
| 55 | +192 |
- #'+ |
||
| 56 | +193 |
- #' p <- h_g_ipp(+ # A warning is sometimes expected, then, we want to restart |
||
| 57 | +194 |
- #' df = adlb,+ # the execution while ignoring the warning. |
||
| 58 | -+ | |||
| 195 | +! |
- #' xvar = "AVISIT",+ invokeRestart("muffleWarning")
|
||
| 59 | +196 |
- #' yvar = "AVAL",+ } |
||
| 60 | +197 |
- #' xlab = "Visit",+ ), |
||
| 61 | -+ | |||
| 198 | +1x |
- #' id_var = "USUBJID",+ finally = {
|
||
| 62 | +199 |
- #' ylab = "SGOT/ALT (U/L)",+ } |
||
| 63 | +200 |
- #' add_baseline_hline = TRUE+ ) |
||
| 64 | +201 |
- #' )+ |
||
| 65 | -+ | |||
| 202 | +1x |
- #' p+ return(y) |
||
| 66 | +203 |
- #'+ } |
||
| 67 | +204 |
- #' @export+ |
||
| 68 | +205 |
- h_g_ipp <- function(df,+ #' Fit a Cox regression model and ANOVA |
||
| 69 | +206 |
- xvar,+ #' |
||
| 70 | +207 |
- yvar,+ #' The functions derives the effect p-values using [car::Anova()] from [survival::coxph()] results. |
||
| 71 | +208 |
- xlab,+ #' |
||
| 72 | +209 |
- ylab,+ #' @inheritParams t_coxreg |
||
| 73 | +210 |
- id_var,+ #' |
||
| 74 | +211 |
- title = "Individual Patient Plots",+ #' @return A list with items `mod` (results of [survival::coxph()]), `msum` (result of `summary`) and |
||
| 75 | +212 |
- subtitle = "",+ #' `aov` (result of [car::Anova()]). |
||
| 76 | +213 |
- caption = NULL,+ #' |
||
| 77 | +214 |
- add_baseline_hline = FALSE,+ #' @noRd |
||
| 78 | +215 |
- yvar_baseline = "BASE",+ fit_n_aov <- function(formula, |
||
| 79 | +216 |
- ggtheme = nestcolor::theme_nest(),+ data = data, |
||
| 80 | +217 |
- col = NULL) {
- |
- ||
| 81 | -13x | -
- checkmate::assert_string(xvar)- |
- ||
| 82 | -13x | -
- checkmate::assert_string(yvar)+ conf_level = conf_level, |
||
| 83 | -13x | +|||
| 218 | +
- checkmate::assert_string(yvar_baseline)+ pval_method = c("wald", "likelihood"),
|
|||
| 84 | -13x | +|||
| 219 | +
- checkmate::assert_string(id_var)+ ...) {
|
|||
| 85 | -13x | +220 | +1x |
- checkmate::assert_string(xlab)+ pval_method <- match.arg(pval_method) |
| 86 | -13x | +|||
| 221 | +
- checkmate::assert_string(ylab)+ |
|||
| 87 | -13x | +222 | +1x |
- checkmate::assert_string(title)+ environment(formula) <- environment() |
| 88 | -13x | +223 | +1x |
- checkmate::assert_string(subtitle)+ suppressWarnings({
|
| 89 | -13x | +|||
| 224 | +
- checkmate::assert_subset(c(xvar, yvar, yvar_baseline, id_var), colnames(df))+ # We expect some warnings due to coxph which fails strict programming. |
|||
| 90 | -13x | +225 | +1x |
- checkmate::assert_data_frame(df)+ mod <- survival::coxph(formula, data = data, ...) |
| 91 | -13x | +226 | +1x |
- checkmate::assert_flag(add_baseline_hline)+ msum <- summary(mod, conf.int = conf_level) |
| 92 | -13x | +|||
| 227 | +
- checkmate::assert_character(col, null.ok = TRUE)+ }) |
|||
| 93 | +228 | |||
| 94 | -13x | -
- p <- ggplot2::ggplot(- |
- ||
| 95 | -13x | +229 | +1x |
- data = df,+ aov <- try_car_anova( |
| 96 | -13x | +230 | +1x |
- mapping = ggplot2::aes(+ mod, |
| 97 | -13x | +231 | +1x |
- x = .data[[xvar]],+ test.statistic = switch(pval_method, |
| 98 | -13x | +232 | +1x |
- y = .data[[yvar]],+ "wald" = "Wald", |
| 99 | -13x | +233 | +1x |
- group = .data[[id_var]],+ "likelihood" = "LR" |
| 100 | -13x | +|||
| 234 | +
- colour = .data[[id_var]]+ ) |
|||
| 101 | +235 |
- )+ ) |
||
| 102 | +236 |
- ) ++ |
||
| 103 | -13x | +237 | +1x |
- ggplot2::geom_line(linewidth = 0.4) ++ warn_attr <- aov$warn_text |
| 104 | -13x | +|||
| 238 | +! |
- ggplot2::geom_point(size = 2) ++ if (!is.null(aov$warn_text)) message(warn_attr) |
||
| 105 | -13x | +|||
| 239 | +
- ggplot2::labs(+ |
|||
| 106 | -13x | +240 | +1x |
- x = xlab,+ aov <- aov$aov |
| 107 | -13x | +241 | +1x |
- y = ylab,+ y <- list(mod = mod, msum = msum, aov = aov) |
| 108 | -13x | +242 | +1x | +
+ attr(y, "message") <- warn_attr+ |
+
| 243 | +
- title = title,+ |
|||
| 109 | -13x | +244 | +1x |
- subtitle = subtitle,+ return(y) |
| 110 | -13x | +|||
| 245 | +
- caption = caption+ } |
|||
| 111 | +246 |
- ) ++ |
||
| 112 | -13x | +|||
| 247 | +
- ggtheme+ # argument_checks |
|||
| 113 | +248 |
-
+ check_formula <- function(formula) {
|
||
| 114 | -13x | +249 | +1x |
- if (add_baseline_hline) {
+ if (!(inherits(formula, "formula"))) {
|
| 115 | -12x | +250 | +1x |
- baseline_df <- df[, c(id_var, yvar_baseline)]+ stop("Check `formula`. A formula should resemble `Surv(time = AVAL, event = 1 - CNSR) ~ study_arm(ARMCD)`.")
|
| 116 | -12x | +|||
| 251 | +
- baseline_df <- unique(baseline_df)+ } |
|||
| 117 | +252 | |||
| 118 | -12x | +|||
| 253 | +! |
- p <- p ++ invisible() |
||
| 119 | -12x | +|||
| 254 | +
- ggplot2::geom_hline(+ } |
|||
| 120 | -12x | +|||
| 255 | +
- data = baseline_df,+ |
|||
| 121 | -12x | +|||
| 256 | +
- mapping = ggplot2::aes(+ check_covariate_formulas <- function(covariates) {
|
|||
| 122 | -12x | +257 | +1x |
- yintercept = .data[[yvar_baseline]],+ if (!all(vapply(X = covariates, FUN = inherits, what = "formula", FUN.VALUE = TRUE)) || is.null(covariates)) {
|
| 123 | -12x | +258 | +1x |
- colour = .data[[id_var]]+ stop("Check `covariates`, it should be a list of right-hand-term formulas, e.g. list(Age = ~AGE).")
|
| 124 | +259 |
- ),+ } |
||
| 125 | -12x | +|||
| 260 | +
- linetype = "dotdash",+ |
|||
| 126 | -12x | +|||
| 261 | +! |
- linewidth = 0.4+ invisible() |
||
| 127 | +262 |
- ) ++ } |
||
| 128 | -12x | +|||
| 263 | +
- ggplot2::geom_text(+ |
|||
| 129 | -12x | +|||
| 264 | +
- data = baseline_df,+ name_covariate_names <- function(covariates) {
|
|||
| 130 | -12x | +265 | +1x |
- mapping = ggplot2::aes(+ miss_names <- names(covariates) == "" |
| 131 | -12x | +266 | +1x |
- x = 1,+ no_names <- is.null(names(covariates)) |
| 132 | -12x | +|||
| 267 | +! |
- y = .data[[yvar_baseline]],+ if (any(miss_names)) names(covariates)[miss_names] <- vapply(covariates[miss_names], FUN = rht, FUN.VALUE = "name") |
||
| 133 | -12x | +|||
| 268 | +! |
- label = .data[[id_var]],+ if (no_names) names(covariates) <- vapply(covariates, FUN = rht, FUN.VALUE = "name") |
||
| 134 | -12x | +269 | +1x |
- colour = .data[[id_var]]+ return(covariates) |
| 135 | +270 |
- ),+ } |
||
| 136 | -12x | +|||
| 271 | +
- nudge_y = 0.025 * (max(df[, yvar], na.rm = TRUE) - min(df[, yvar], na.rm = TRUE)),+ |
|||
| 137 | -12x | +|||
| 272 | +
- vjust = "right",+ check_increments <- function(increments, covariates) {
|
|||
| 138 | -12x | +273 | +1x |
- size = 2+ if (!is.null(increments)) {
|
| 139 | -+ | |||
| 274 | +1x |
- )+ covariates <- vapply(covariates, FUN = rht, FUN.VALUE = "name") |
||
| 140 | -+ | |||
| 275 | +1x |
-
+ lapply( |
||
| 141 | -12x | +276 | +1x |
- if (!is.null(col)) {
+ X = names(increments), FUN = function(x) {
|
| 142 | -1x | +277 | +3x |
- p <- p ++ if (!x %in% covariates) {
|
| 143 | +278 | 1x |
- ggplot2::scale_color_manual(values = col)+ warning( |
|
| 144 | -+ | |||
| 279 | +1x |
- }+ paste( |
||
| 145 | -+ | |||
| 280 | +1x |
- }+ "Check `increments`, the `increment` for ", x, |
||
| 146 | -13x | +281 | +1x |
- p+ "doesn't match any names in investigated covariate(s)." |
| 147 | +282 |
- }+ ) |
||
| 148 | +283 |
-
+ ) |
||
| 149 | +284 |
- #' @describeIn g_ipp Plotting function for individual patient plots which, depending on user+ } |
||
| 150 | +285 |
- #' preference, renders a single graphic or compiles a list of graphics that show trends in individual's parameter+ } |
||
| 151 | +286 |
- #' values over time.+ ) |
||
| 152 | +287 |
- #'+ } |
||
| 153 | +288 |
- #' @return A `ggplot` object or a list of `ggplot` objects.+ + |
+ ||
| 289 | +1x | +
+ invisible() |
||
| 154 | +290 |
- #'+ } |
||
| 155 | +291 |
- #' @examples+ |
||
| 156 | +292 |
- #' library(dplyr)+ #' Multivariate Cox model - summarized results |
||
| 157 | +293 |
#' |
||
| 158 | +294 |
- #' # Select a small sample of data to plot.+ #' Analyses based on multivariate Cox model are usually not performed for the Controlled Substance Reporting or |
||
| 159 | +295 |
- #' adlb <- tern_ex_adlb %>%+ #' regulatory documents but serve exploratory purposes only (e.g., for publication). In practice, the model usually |
||
| 160 | +296 |
- #' filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
+ #' includes only the main effects (without interaction terms). It produces the hazard ratio estimates for each of the |
||
| 161 | +297 |
- #' slice(1:36)+ #' covariates included in the model. |
||
| 162 | +298 |
- #'+ #' The analysis follows the same principles (e.g., stratified vs. unstratified analysis and tie handling) as the |
||
| 163 | +299 |
- #' plot_list <- g_ipp(+ #' usual Cox model analysis. Since there is usually no pre-specified hypothesis testing for such analysis, |
||
| 164 | +300 |
- #' df = adlb,+ #' the p.values need to be interpreted with caution. (**Statistical Analysis of Clinical Trials Data with R**, |
||
| 165 | +301 |
- #' xvar = "AVISIT",+ #' `NEST's bookdown`) |
||
| 166 | +302 |
- #' yvar = "AVAL",+ #' |
||
| 167 | +303 |
- #' xlab = "Visit",+ #' @param formula (`formula`)\cr a formula corresponding to the investigated [survival::Surv()] survival model |
||
| 168 | +304 |
- #' ylab = "SGOT/ALT (U/L)",+ #' including covariates. |
||
| 169 | +305 |
- #' title = "Individual Patient Plots",+ #' @param data (`data.frame`)\cr a data frame which includes the variable in formula and covariates. |
||
| 170 | +306 |
- #' add_baseline_hline = TRUE,+ #' @param conf_level (`proportion`)\cr the confidence level for the hazard ratio interval estimations. Default is 0.95. |
||
| 171 | +307 |
- #' plotting_choices = "split_by_max_obs",+ #' @param pval_method (`string`)\cr the method used for the estimation of p-values, should be one of |
||
| 172 | +308 |
- #' max_obs_per_plot = 5+ #' `"wald"` (default) or `"likelihood"`. |
||
| 173 | +309 |
- #' )+ #' @param ... optional parameters passed to [survival::coxph()]. Can include `ties`, a character string specifying the |
||
| 174 | +310 |
- #' plot_list+ #' method for tie handling, one of `exact` (default), `efron`, `breslow`. |
||
| 175 | +311 |
#' |
||
| 176 | +312 |
- #' @export+ #' @return A `list` with elements `mod`, `msum`, `aov`, and `coef_inter`. |
||
| 177 | +313 |
- g_ipp <- function(df,+ #' |
||
| 178 | +314 |
- xvar,+ #' @details The output is limited to single effect terms. Work in ongoing for estimation of interaction terms |
||
| 179 | +315 |
- yvar,+ #' but is out of scope as defined by the Global Data Standards Repository |
||
| 180 | +316 |
- xlab,+ #' (**`GDS_Standard_TLG_Specs_Tables_2.doc`**). |
||
| 181 | +317 |
- ylab,+ #' |
||
| 182 | +318 |
- id_var = "USUBJID",+ #' @seealso [estimate_coef()]. |
||
| 183 | +319 |
- title = "Individual Patient Plots",+ #' |
||
| 184 | +320 |
- subtitle = "",+ #' @examples |
||
| 185 | +321 |
- caption = NULL,+ #' library(dplyr) |
||
| 186 | +322 |
- add_baseline_hline = FALSE,+ #' |
||
| 187 | +323 |
- yvar_baseline = "BASE",+ #' adtte <- tern_ex_adtte |
||
| 188 | +324 |
- ggtheme = nestcolor::theme_nest(),+ #' adtte_f <- subset(adtte, PARAMCD == "OS") # _f: filtered |
||
| 189 | +325 |
- plotting_choices = c("all_in_one", "split_by_max_obs", "separate_by_obs"),
+ #' adtte_f <- filter( |
||
| 190 | +326 |
- max_obs_per_plot = 4,+ #' adtte_f, |
||
| 191 | +327 |
- col = NULL) {
- |
- ||
| 192 | -3x | -
- checkmate::assert_count(max_obs_per_plot)+ #' PARAMCD == "OS" & |
||
| 193 | -3x | +|||
| 328 | +
- checkmate::assert_subset(plotting_choices, c("all_in_one", "split_by_max_obs", "separate_by_obs"))
+ #' SEX %in% c("F", "M") &
|
|||
| 194 | -3x | +|||
| 329 | +
- checkmate::assert_character(col, null.ok = TRUE)+ #' RACE %in% c("ASIAN", "BLACK OR AFRICAN AMERICAN", "WHITE")
|
|||
| 195 | +330 |
-
+ #' ) |
||
| 196 | -3x | +|||
| 331 | +
- plotting_choices <- match.arg(plotting_choices)+ #' adtte_f$SEX <- droplevels(adtte_f$SEX) |
|||
| 197 | +332 |
-
+ #' adtte_f$RACE <- droplevels(adtte_f$RACE) |
||
| 198 | -3x | +|||
| 333 | +
- if (plotting_choices == "all_in_one") {
+ #' |
|||
| 199 | -1x | +|||
| 334 | +
- p <- h_g_ipp(+ #' @keywords internal |
|||
| 200 | -1x | +|||
| 335 | +
- df = df,+ s_cox_multivariate <- function(formula, data, |
|||
| 201 | -1x | +|||
| 336 | +
- xvar = xvar,+ conf_level = 0.95, |
|||
| 202 | -1x | +|||
| 337 | +
- yvar = yvar,+ pval_method = c("wald", "likelihood"),
|
|||
| 203 | -1x | +|||
| 338 | +
- xlab = xlab,+ ...) {
|
|||
| 204 | +339 | 1x |
- ylab = ylab,+ tf <- stats::terms(formula, specials = c("strata"))
|
|
| 205 | +340 | 1x |
- id_var = id_var,+ covariates <- rownames(attr(tf, "factors"))[-c(1, unlist(attr(tf, "specials")))] |
|
| 206 | +341 | 1x |
- title = title,+ lapply( |
|
| 207 | +342 | 1x |
- subtitle = subtitle,+ X = covariates, |
|
| 208 | +343 | 1x |
- caption = caption,+ FUN = function(x) {
|
|
| 209 | -1x | +344 | +3x |
- add_baseline_hline = add_baseline_hline,+ if (is.character(data[[x]])) {
|
| 210 | +345 | 1x |
- yvar_baseline = yvar_baseline,+ data[[x]] <<- as.factor(data[[x]]) |
|
| 211 | -1x | +|||
| 346 | +
- ggtheme = ggtheme,+ } |
|||
| 212 | -1x | +347 | +3x |
- col = col+ invisible() |
| 213 | +348 |
- )+ } |
||
| 214 | +349 |
-
+ ) |
||
| 215 | +350 | 1x |
- return(p)+ pval_method <- match.arg(pval_method) |
|
| 216 | -2x | +|||
| 351 | +
- } else if (plotting_choices == "split_by_max_obs") {
+
|
|||
| 217 | -1x | +|||
| 352 | +
- id_vec <- unique(df[[id_var]])+ # Results directly exported from environment(fit_n_aov) to environment(s_function_draft) |
|||
| 218 | +353 | 1x |
- id_list <- split(+ y <- fit_n_aov( |
|
| 219 | +354 | 1x |
- id_vec,+ formula = formula, |
|
| 220 | +355 | 1x |
- rep(1:ceiling(length(id_vec) / max_obs_per_plot),+ data = data, |
|
| 221 | +356 | 1x |
- each = max_obs_per_plot,+ conf_level = conf_level, |
|
| 222 | +357 | 1x |
- length.out = length(id_vec)- |
- |
| 223 | -- |
- )+ pval_method = pval_method, |
||
| 224 | +358 |
- )+ ... |
||
| 225 | +359 |
-
+ ) |
||
| 226 | +360 | 1x |
- df_list <- list()+ mod <- y$mod |
|
| 227 | +361 | 1x |
- plot_list <- list()- |
- |
| 228 | -- |
-
+ aov <- y$aov |
||
| 229 | +362 | 1x |
- for (i in seq_along(id_list)) {
+ msum <- y$msum |
|
| 230 | -2x | +363 | +1x |
- df_list[[i]] <- df[df[[id_var]] %in% id_list[[i]], ]+ list2env(as.list(y), environment()) |
| 231 | +364 | |||
| 232 | -2x | -
- plots <- h_g_ipp(- |
- ||
| 233 | -2x | -
- df = df_list[[i]],- |
- ||
| 234 | -2x | -
- xvar = xvar,- |
- ||
| 235 | -2x | -
- yvar = yvar,- |
- ||
| 236 | -2x | -
- xlab = xlab,- |
- ||
| 237 | -2x | -
- ylab = ylab,- |
- ||
| 238 | -2x | -
- id_var = id_var,- |
- ||
| 239 | -2x | -
- title = title,- |
- ||
| 240 | -2x | -
- subtitle = subtitle,- |
- ||
| 241 | -2x | -
- caption = caption,- |
- ||
| 242 | -2x | -
- add_baseline_hline = add_baseline_hline,- |
- ||
| 243 | -2x | +365 | +1x |
- yvar_baseline = yvar_baseline,+ all_term_labs <- attr(mod$terms, "term.labels") |
| 244 | -2x | +366 | +1x |
- ggtheme = ggtheme,+ term_labs <- all_term_labs[which(attr(mod$terms, "order") == 1)] |
| 245 | -2x | -
- col = col- |
- ||
| 246 | -+ | 367 | +1x |
- )+ names(term_labs) <- term_labs |
| 247 | +368 | |||
| 248 | -2x | +369 | +1x |
- plot_list[[i]] <- plots+ coef_inter <- NULL |
| 249 | -+ | |||
| 370 | +1x |
- }+ if (any(attr(mod$terms, "order") > 1)) {
|
||
| 250 | +371 | 1x |
- return(plot_list)+ for_inter <- all_term_labs[attr(mod$terms, "order") > 1] |
|
| 251 | -+ | |||
| 372 | +1x |
- } else {
+ names(for_inter) <- for_inter |
||
| 252 | +373 | 1x |
- ind_df <- split(df, df[[id_var]])+ mmat <- stats::model.matrix(mod)[1, ] |
|
| 253 | +374 | 1x |
- plot_list <- lapply(+ mmat[!mmat == 0] <- 0 |
|
| 254 | +375 | 1x |
- ind_df,+ mcoef <- stats::coef(mod) |
|
| 255 | +376 | 1x |
- function(x) {
+ mvcov <- stats::vcov(mod) |
|
| 256 | -8x | +|||
| 377 | +
- h_g_ipp(+ |
|||
| 257 | -8x | +378 | +1x |
- df = x,+ estimate_coef_local <- function(variable, given) {
|
| 258 | -8x | +379 | +6x |
- xvar = xvar,+ estimate_coef( |
| 259 | -8x | +380 | +6x |
- yvar = yvar,+ variable, given, |
| 260 | -8x | +381 | +6x |
- xlab = xlab,+ coef = mcoef, mmat = mmat, vcov = mvcov, conf_level = conf_level, |
| 261 | -8x | +382 | +6x |
- ylab = ylab,+ lvl_var = levels(data[[variable]]), lvl_given = levels(data[[given]]) |
| 262 | -8x | +|||
| 383 | +
- id_var = id_var,+ ) |
|||
| 263 | -8x | +|||
| 384 | +
- title = title,+ } |
|||
| 264 | -8x | +|||
| 385 | +
- subtitle = subtitle,+ |
|||
| 265 | -8x | +386 | +1x |
- caption = caption,+ coef_inter <- lapply( |
| 266 | -8x | +387 | +1x |
- add_baseline_hline = add_baseline_hline,+ for_inter, function(x) {
|
| 267 | -8x | +388 | +3x |
- yvar_baseline = yvar_baseline,+ y <- attr(mod$terms, "factors")[, x] |
| 268 | -8x | +389 | +3x |
- ggtheme = ggtheme,+ y <- names(y[y > 0]) |
| 269 | -8x | +390 | +3x |
- col = col+ Map(estimate_coef_local, variable = y, given = rev(y)) |
| 270 | +391 |
- )+ } |
||
| 271 | +392 |
- }+ ) |
||
| 272 | +393 |
- )+ } |
||
| 273 | +394 | |||
| 274 | +395 | 1x |
- return(plot_list)- |
- |
| 275 | -- |
- }+ list(mod = mod, msum = msum, aov = aov, coef_inter = coef_inter) |
||
| 276 | +396 |
}@@ -59146,14 +61516,14 @@ tern coverage - 95.59% |
| 1 |
- #' Additional assertions to use with `checkmate`+ #' Count number of patients |
||
| 3 |
- #' Additional assertion functions which can be used together with the `checkmate` package.+ #' @description `r lifecycle::badge("stable")`
|
||
| 5 |
- #' @inheritParams checkmate::assert_factor+ #' The analyze function [analyze_num_patients()] creates a layout element to count total numbers of unique or |
||
| 6 |
- #' @param x (`any`)\cr object to test.+ #' non-unique patients. The primary analysis variable `vars` is used to uniquely identify patients. |
||
| 7 |
- #' @param df (`data.frame`)\cr data set to test.+ #' |
||
| 8 |
- #' @param variables (named `list` of `character`)\cr list of variables to test.+ #' The `count_by` variable can be used to identify non-unique patients such that the number of patients with a unique |
||
| 9 |
- #' @param include_boundaries (`flag`)\cr whether to include boundaries when testing+ #' combination of values in `vars` and `count_by` will be returned instead as the `nonunique` statistic. The `required` |
||
| 10 |
- #' for proportions.+ #' variable can be used to specify a variable required to be non-missing for the record to be included in the counts. |
||
| 11 |
- #' @param na_level (`string`)\cr the string you have been using to represent NA or+ #' |
||
| 12 |
- #' missing data. For `NA` values please consider using directly [is.na()] or+ #' The summarize function [summarize_num_patients()] performs the same function as [analyze_num_patients()] except it |
||
| 13 |
- #' similar approaches.+ #' creates content rows, not data rows, to summarize the current table row/column context and operates on the level of |
||
| 14 |
- #'+ #' the latest row split or the root of the table if no row splits have occurred. |
||
| 15 |
- #' @return Nothing if assertion passes, otherwise prints the error message.+ #' |
||
| 16 |
- #'+ #' @inheritParams argument_convention |
||
| 17 |
- #' @name assertions+ #' @param required (`character` or `NULL`)\cr name of a variable that is required to be non-missing. |
||
| 18 |
- NULL+ #' @param count_by (`character` or `NULL`)\cr name of a variable to be combined with `vars` when counting |
||
| 19 |
-
+ #' `nonunique` records. |
||
| 20 |
- check_list_of_variables <- function(x) {
+ #' @param unique_count_suffix (`flag`)\cr whether the `"(n)"` suffix should be added to `unique_count` labels. |
||
| 21 |
- # drop NULL elements in list+ #' Defaults to `TRUE`. |
||
| 22 | -2960x | +
- x <- Filter(Negate(is.null), x)+ #' @param .stats (`character`)\cr statistics to select for the table. |
|
| 23 |
-
+ #' |
||
| 24 | -2960x | +
- res <- checkmate::check_list(x,+ #' Options are: ``r shQuote(get_stats("summarize_num_patients"), type = "sh")``
|
|
| 25 | -2960x | +
- names = "named",+ #' |
|
| 26 | -2960x | +
- min.len = 1,+ #' @name summarize_num_patients |
|
| 27 | -2960x | +
- any.missing = FALSE,+ #' @order 1 |
|
| 28 | -2960x | +
- types = "character"+ NULL |
|
| 29 |
- )+ |
||
| 30 |
- # no empty strings allowed+ #' @describeIn summarize_num_patients Statistics function which counts the number of |
||
| 31 | -2960x | +
- if (isTRUE(res)) {
+ #' unique patients, the corresponding percentage taken with respect to the |
|
| 32 | -2955x | +
- res <- checkmate::check_character(unlist(x), min.chars = 1)+ #' total number of patients, and the number of non-unique patients. |
|
| 33 |
- }+ #' |
||
| 34 | -2960x | +
- return(res)+ #' @param x (`character` or `factor`)\cr vector of patient IDs. |
|
| 35 |
- }+ #' |
||
| 36 |
- #' @describeIn assertions Checks whether `x` is a valid list of variable names.+ #' @return |
||
| 37 |
- #' `NULL` elements of the list `x` are dropped with `Filter(Negate(is.null), x)`.+ #' * `s_num_patients()` returns a named `list` of 3 statistics: |
||
| 38 |
- #'+ #' * `unique`: Vector of counts and percentages. |
||
| 39 |
- #' @keywords internal+ #' * `nonunique`: Vector of counts. |
||
| 40 |
- assert_list_of_variables <- checkmate::makeAssertionFunction(check_list_of_variables)+ #' * `unique_count`: Counts. |
||
| 41 |
-
+ #' |
||
| 42 |
- check_df_with_variables <- function(df, variables, na_level = NULL) {
+ #' @examples |
||
| 43 | -2643x | +
- checkmate::assert_data_frame(df)+ #' # Use the statistics function to count number of unique and nonunique patients. |
|
| 44 | -2641x | +
- assert_list_of_variables(variables)+ #' s_num_patients(x = as.character(c(1, 1, 1, 2, 4, NA)), labelstr = "", .N_col = 6L) |
|
| 45 |
-
+ #' s_num_patients( |
||
| 46 |
- # flag for equal variables and column names+ #' x = as.character(c(1, 1, 1, 2, 4, NA)), |
||
| 47 | -2639x | +
- err_flag <- all(unlist(variables) %in% colnames(df))+ #' labelstr = "", |
|
| 48 | -2639x | +
- checkmate::assert_flag(err_flag)+ #' .N_col = 6L, |
|
| 49 |
-
+ #' count_by = c(1, 1, 2, 1, 1, 1) |
||
| 50 | -2639x | +
- if (isFALSE(err_flag)) {
+ #' ) |
|
| 51 | -5x | +
- vars <- setdiff(unlist(variables), colnames(df))+ #' |
|
| 52 | -5x | +
- return(paste(+ #' @export |
|
| 53 | -5x | +
- deparse(substitute(df)),+ s_num_patients <- function(x, labelstr, .N_col, count_by = NULL, unique_count_suffix = TRUE) { # nolint
|
|
| 54 | -5x | +
- "does not contain all specified variables as column names. Missing from data frame:",+ |
|
| 55 | -5x | +146x |
- paste(vars, collapse = ", ")+ checkmate::assert_string(labelstr) |
| 56 | -+ | 146x |
- ))+ checkmate::assert_count(.N_col) |
| 57 | -+ | 146x |
- }+ checkmate::assert_multi_class(x, classes = c("factor", "character"))
|
| 58 | -+ | 146x |
- # checking if na_level is present and in which column+ checkmate::assert_flag(unique_count_suffix) |
| 59 | -2634x | +
- if (!is.null(na_level)) {
+
|
|
| 60 | -9x | +146x |
- checkmate::assert_string(na_level)+ count1 <- n_available(unique(x)) |
| 61 | -9x | +146x |
- res <- unlist(lapply(as.list(df)[unlist(variables)], function(x) any(x == na_level)))+ count2 <- n_available(x) |
| 62 | -9x | +
- if (any(res)) {
+
|
|
| 63 | -1x | +146x |
- return(paste0(+ if (!is.null(count_by)) {
|
| 64 | -1x | +16x |
- deparse(substitute(df)), " contains explicit na_level (", na_level,
+ checkmate::assert_vector(count_by, len = length(x)) |
| 65 | -1x | +16x |
- ") in the following columns: ", paste0(unlist(variables)[res],+ count2 <- n_available(unique(interaction(x, count_by))) |
| 66 | -1x | +
- collapse = ", "+ } |
|
| 67 |
- )+ |
||
| 68 | -+ | 146x |
- ))+ out <- list( |
| 69 | -+ | 146x |
- }+ unique = formatters::with_label(c(count1, ifelse(count1 == 0 && .N_col == 0, 0, count1 / .N_col)), labelstr), |
| 70 | -+ | 146x |
- }+ nonunique = formatters::with_label(count2, labelstr), |
| 71 | -2633x | +146x |
- return(TRUE)+ unique_count = formatters::with_label( |
| 72 | -+ | 146x |
- }+ count1, ifelse(unique_count_suffix, paste0(labelstr, if (nzchar(labelstr)) " ", "(n)"), labelstr) |
| 73 |
- #' @describeIn assertions Check whether `df` is a data frame with the analysis `variables`.+ ) |
||
| 74 |
- #' 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 | -+ | 146x |
- #'+ out |
| 77 |
- #' @keywords internal+ } |
||
| 78 |
- assert_df_with_variables <- checkmate::makeAssertionFunction(check_df_with_variables)+ |
||
| 79 |
-
+ #' @describeIn summarize_num_patients Statistics function which counts the number of unique patients |
||
| 80 |
- check_valid_factor <- function(x,+ #' in a column (variable), the corresponding percentage taken with respect to the total number of |
||
| 81 |
- min.levels = 1, # nolint+ #' patients, and the number of non-unique patients in the column. |
||
| 82 |
- max.levels = NULL, # nolint+ #' |
||
| 83 |
- null.ok = TRUE, # nolint+ #' @return |
||
| 84 |
- any.missing = TRUE, # nolint+ #' * `s_num_patients_content()` returns the same values as `s_num_patients()`. |
||
| 85 |
- n.levels = NULL, # nolint+ #' |
||
| 86 |
- len = NULL) {
+ #' @examples |
||
| 87 |
- # checks on levels insertion+ #' # Count number of unique and non-unique patients. |
||
| 88 | -1113x | +
- checkmate::assert_int(min.levels, lower = 1)+ #' |
|
| 89 |
-
+ #' df <- data.frame( |
||
| 90 |
- # main factor check+ #' USUBJID = as.character(c(1, 2, 1, 4, NA)), |
||
| 91 | -1113x | +
- res <- checkmate::check_factor(x,+ #' EVENT = as.character(c(10, 15, 10, 17, 8)) |
|
| 92 | -1113x | +
- min.levels = min.levels,+ #' ) |
|
| 93 | -1113x | +
- null.ok = null.ok,+ #' s_num_patients_content(df, .N_col = 5, .var = "USUBJID") |
|
| 94 | -1113x | +
- max.levels = max.levels,+ #' |
|
| 95 | -1113x | +
- any.missing = any.missing,+ #' df_by_event <- data.frame( |
|
| 96 | -1113x | +
- n.levels = n.levels+ #' USUBJID = as.character(c(1, 2, 1, 4, NA)), |
|
| 97 |
- )+ #' EVENT = c(10, 15, 10, 17, 8) |
||
| 98 |
-
+ #' ) |
||
| 99 |
- # no empty strings allowed+ #' s_num_patients_content(df_by_event, .N_col = 5, .var = "USUBJID", count_by = "EVENT") |
||
| 100 | -1113x | +
- if (isTRUE(res)) {
+ #' |
|
| 101 | -1099x | +
- res <- checkmate::check_character(levels(x), min.chars = 1)+ #' @export |
|
| 102 |
- }+ s_num_patients_content <- function(df, |
||
| 103 |
-
+ labelstr = "", |
||
| 104 | -1113x | +
- return(res)+ .N_col, # nolint |
|
| 105 |
- }+ .var, |
||
| 106 |
- #' @describeIn assertions Check whether `x` is a valid factor (i.e. has levels and no empty+ required = NULL, |
||
| 107 |
- #' string levels). Note that `NULL` and `NA` elements are allowed.+ count_by = NULL, |
||
| 108 |
- #'+ unique_count_suffix = TRUE) {
|
||
| 109 | -+ | 56x |
- #' @keywords internal+ checkmate::assert_string(.var) |
| 110 | -+ | 56x |
- assert_valid_factor <- checkmate::makeAssertionFunction(check_valid_factor)+ checkmate::assert_data_frame(df) |
| 111 | -+ | 56x |
-
+ if (is.null(count_by)) {
|
| 112 | -+ | 53x |
- check_df_with_factors <- function(df,+ assert_df_with_variables(df, list(id = .var)) |
| 113 |
- variables,+ } else {
|
||
| 114 | -+ | 3x |
- min.levels = 1, # nolint+ assert_df_with_variables(df, list(id = .var, count_by = count_by)) |
| 115 |
- max.levels = NULL, # nolint+ } |
||
| 116 | -+ | 56x |
- any.missing = TRUE, # nolint+ if (!is.null(required)) {
|
| 117 | -+ | ! |
- na_level = NULL) {
+ checkmate::assert_string(required) |
| 118 | -254x | +! |
- res <- check_df_with_variables(df, variables, na_level)+ assert_df_with_variables(df, list(required = required)) |
| 119 | -+ | ! |
- # checking if all the columns specified by variables are valid factors+ df <- df[!is.na(df[[required]]), , drop = FALSE] |
| 120 | -253x | +
- if (isTRUE(res)) {
+ } |
|
| 121 |
- # searching the data.frame with selected columns (variables) as a list+ |
||
| 122 | -251x | +56x |
- res <- lapply(+ x <- df[[.var]] |
| 123 | -251x | +56x |
- X = as.list(df)[unlist(variables)],+ y <- if (is.null(count_by)) NULL else df[[count_by]] |
| 124 | -251x | +
- FUN = check_valid_factor,+ |
|
| 125 | -251x | +56x |
- min.levels = min.levels,+ s_num_patients( |
| 126 | -251x | +56x |
- max.levels = max.levels,+ x = x, |
| 127 | -251x | +56x |
- any.missing = any.missing+ labelstr = labelstr, |
| 128 | -+ | 56x |
- )+ .N_col = .N_col, |
| 129 | -251x | +56x |
- res_lo <- unlist(vapply(res, Negate(isTRUE), logical(1)))+ count_by = y, |
| 130 | -251x | +56x |
- if (any(res_lo)) {
+ unique_count_suffix = unique_count_suffix |
| 131 | -6x | +
- return(paste0(+ ) |
|
| 132 | -6x | +
- deparse(substitute(df)), " does not contain only factor variables among:",+ } |
|
| 133 | -6x | +
- "\n* Column `", paste0(unlist(variables)[res_lo],+ |
|
| 134 | -6x | +
- "` of the data.frame -> ", res[res_lo],+ c_num_patients <- make_afun( |
|
| 135 | -6x | +
- collapse = "\n* "+ s_num_patients_content, |
|
| 136 |
- )+ .stats = c("unique", "nonunique", "unique_count"),
|
||
| 137 |
- ))+ .formats = c(unique = format_count_fraction_fixed_dp, nonunique = "xx", unique_count = "xx") |
||
| 138 |
- } else {
+ ) |
||
| 139 | -245x | +
- res <- TRUE+ |
|
| 140 |
- }+ #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments |
||
| 141 |
- }+ #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 142 | -247x | +
- return(res)+ #' |
|
| 143 |
- }+ #' @return |
||
| 144 |
-
+ #' * `summarize_num_patients()` returns a layout object suitable for passing to further layouting functions, |
||
| 145 |
- #' @describeIn assertions Check whether `df` is a data frame where the analysis `variables`+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 146 |
- #' are all factors. Note that the creation of `NA` by direct call of `factor()` will+ #' the statistics from `s_num_patients_content()` to the table layout. |
||
| 147 |
- #' trim `NA` levels out of the vector list itself.+ #' |
||
| 148 |
- #'+ #' @examples |
||
| 149 |
- #' @keywords internal+ #' # summarize_num_patients |
||
| 150 |
- assert_df_with_factors <- checkmate::makeAssertionFunction(check_df_with_factors)+ #' tbl <- basic_table() %>% |
||
| 151 |
-
+ #' split_cols_by("ARM") %>%
|
||
| 152 |
- #' @describeIn assertions Check whether `x` is a proportion: number between 0 and 1.+ #' split_rows_by("SEX") %>%
|
||
| 153 |
- #'+ #' summarize_num_patients("USUBJID", .stats = "unique_count") %>%
|
||
| 154 |
- #' @keywords internal+ #' build_table(df) |
||
| 155 | - |
- assert_proportion_value <- function(x, include_boundaries = FALSE) {
- |
- |
| 156 | -18765x | -
- checkmate::assert_number(x, lower = 0, upper = 1)- |
- |
| 157 | -18753x | -
- checkmate::assert_flag(include_boundaries)- |
- |
| 158 | -18753x | -
- if (isFALSE(include_boundaries)) {
- |
- |
| 159 | -12931x | -
- checkmate::assert_true(x > 0)- |
- |
| 160 | -12929x | -
- checkmate::assert_true(x < 1)- |
- |
| 161 | -- |
- }- |
- |
| 162 | -- |
- }- |
-
| 1 | -- |
- #' Control function for incidence rate- |
- ||
| 2 | -- |
- #'- |
- ||
| 3 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- ||
| 4 | -
#' |
|||
| 5 | -- |
- #' This is an auxiliary function for controlling arguments for the incidence rate, used- |
- ||
| 6 | +156 |
- #' internally to specify details in `s_incidence_rate()`.+ #' tbl |
||
| 7 | +157 |
#' |
||
| 8 | +158 |
- #' @inheritParams argument_convention+ #' @export |
||
| 9 | +159 |
- #' @param conf_type (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`+ #' @order 3 |
||
| 10 | +160 |
- #' for confidence interval type.+ summarize_num_patients <- function(lyt, |
||
| 11 | +161 |
- #' @param input_time_unit (`string`)\cr `day`, `week`, `month`, or `year` (default)+ var, |
||
| 12 | +162 |
- #' indicating time unit for data input.+ required = NULL, |
||
| 13 | +163 |
- #' @param num_pt_year (`numeric(1)`)\cr number of patient-years to use when calculating adverse event rates.+ count_by = NULL, |
||
| 14 | +164 |
- #'+ unique_count_suffix = TRUE, |
||
| 15 | +165 |
- #' @return A list of components with the same names as the arguments.+ na_str = default_na_str(), |
||
| 16 | +166 |
- #'+ .stats = NULL, |
||
| 17 | +167 |
- #' @seealso [incidence_rate]+ .formats = NULL, |
||
| 18 | +168 |
- #'+ .labels = c( |
||
| 19 | +169 |
- #' @examples+ unique = "Number of patients with at least one event", |
||
| 20 | +170 |
- #' control_incidence_rate(0.9, "exact", "month", 100)+ nonunique = "Number of events" |
||
| 21 | +171 |
- #'+ ), |
||
| 22 | +172 |
- #' @export+ .indent_mods = 0L, |
||
| 23 | +173 |
- control_incidence_rate <- function(conf_level = 0.95,+ riskdiff = FALSE, |
||
| 24 | +174 |
- conf_type = c("normal", "normal_log", "exact", "byar"),
+ ...) {
|
||
| 25 | -+ | |||
| 175 | +16x |
- input_time_unit = c("year", "day", "week", "month"),
+ checkmate::assert_flag(riskdiff) |
||
| 26 | +176 |
- num_pt_year = 100) {
+
|
||
| 27 | -14x | +177 | +5x |
- conf_type <- match.arg(conf_type)+ if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
|
| 28 | -13x | +178 | +8x |
- input_time_unit <- match.arg(input_time_unit)+ if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats] |
| 29 | -12x | +|||
| 179 | +
- checkmate::assert_number(num_pt_year)+ |
|||
| 30 | -11x | +180 | +16x |
- assert_proportion_value(conf_level)+ s_args <- list(required = required, count_by = count_by, unique_count_suffix = unique_count_suffix, ...) |
| 31 | +181 | |||
| 32 | -10x | +182 | +16x |
- list(+ cfun <- make_afun( |
| 33 | -10x | +183 | +16x |
- conf_level = conf_level,+ c_num_patients, |
| 34 | -10x | +184 | +16x |
- conf_type = conf_type,+ .stats = .stats, |
| 35 | -10x | +185 | +16x |
- input_time_unit = input_time_unit,+ .formats = .formats, |
| 36 | -10x | +186 | +16x |
- num_pt_year = num_pt_year+ .labels = .labels |
| 37 | +187 |
) |
||
| 38 | -- |
- }- |
-
| 1 | -- |
- #' Univariate formula special term- |
- ||
| 2 | -- |
- #'- |
- ||
| 3 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- ||
| 4 | -- |
- #'- |
- ||
| 5 | -- |
- #' The special term `univariate` indicate that the model should be fitted individually for- |
- ||
| 6 | -- |
- #' every variable included in univariate.- |
- ||
| 7 | -- |
- #'- |
- ||
| 8 | -- |
- #' @param x (`character`)\cr a vector of variable names separated by commas.- |
- ||
| 9 | -- |
- #'- |
- ||
| 10 | -- |
- #' @return When used within a model formula, produces univariate models for each variable provided.- |
- ||
| 11 | -- |
- #'- |
- ||
| 12 | -- |
- #' @details- |
- ||
| 13 | -- |
- #' If provided alongside with pairwise specification, the model- |
- ||
| 14 | -- |
- #' `y ~ ARM + univariate(SEX, AGE, RACE)` lead to the study and comparison of the models- |
- ||
| 15 | +188 |
- #' + `y ~ ARM`+ |
||
| 16 | -+ | |||
| 189 | +16x |
- #' + `y ~ ARM + SEX`+ extra_args <- if (isFALSE(riskdiff)) {
|
||
| 17 | -+ | |||
| 190 | +14x |
- #' + `y ~ ARM + AGE`+ s_args |
||
| 18 | +191 |
- #' + `y ~ ARM + RACE`+ } else {
|
||
| 19 | -+ | |||
| 192 | +2x |
- #'+ list( |
||
| 20 | -+ | |||
| 193 | +2x |
- #' @export+ afun = list("s_num_patients_content" = cfun),
|
||
| 21 | -+ | |||
| 194 | +2x |
- univariate <- function(x) {
+ .stats = .stats, |
||
| 22 | +195 | 2x |
- structure(x, varname = deparse(substitute(x)))+ .indent_mods = .indent_mods, |
|
| 23 | -+ | |||
| 196 | +2x |
- }+ s_args = s_args |
||
| 24 | +197 |
-
+ ) |
||
| 25 | +198 |
- # Get the right-hand-term of a formula+ } |
||
| 26 | +199 |
- rht <- function(x) {
+
|
||
| 27 | -4x | +200 | +16x |
- checkmate::assert_formula(x)+ summarize_row_groups( |
| 28 | -4x | +201 | +16x |
- y <- as.character(rev(x)[[1]])+ lyt = lyt, |
| 29 | -4x | +202 | +16x |
- return(y)+ var = var, |
| 30 | -+ | |||
| 203 | +16x |
- }+ cfun = ifelse(isFALSE(riskdiff), cfun, afun_riskdiff), |
||
| 31 | -+ | |||
| 204 | +16x |
-
+ na_str = na_str, |
||
| 32 | -+ | |||
| 205 | +16x |
- #' Hazard ratio estimation in interactions+ extra_args = extra_args, |
||
| 33 | -+ | |||
| 206 | +16x |
- #'+ indent_mod = .indent_mods |
||
| 34 | +207 |
- #' This function estimates the hazard ratios between arms when an interaction variable is given with+ ) |
||
| 35 | +208 |
- #' specific values.+ } |
||
| 36 | +209 |
- #'+ |
||
| 37 | +210 |
- #' @param variable,given (`character(2)`)\cr names of the two variables in the interaction. We seek the estimation of+ #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments |
||
| 38 | +211 |
- #' the levels of `variable` given the levels of `given`.+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 39 | +212 |
- #' @param lvl_var,lvl_given (`character`)\cr corresponding levels given by [levels()].+ #' |
||
| 40 | +213 |
- #' @param mmat (named `numeric`) a vector filled with `0`s used as a template to obtain the design matrix.+ #' @return |
||
| 41 | +214 |
- #' @param coef (`numeric`)\cr vector of estimated coefficients.+ #' * `analyze_num_patients()` returns a layout object suitable for passing to further layouting functions, |
||
| 42 | +215 |
- #' @param vcov (`matrix`)\cr variance-covariance matrix of underlying model.+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 43 | +216 |
- #' @param conf_level (`proportion`)\cr confidence level of estimate intervals.+ #' the statistics from `s_num_patients_content()` to the table layout. |
||
| 44 | +217 |
#' |
||
| 45 | -- |
- #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A)- |
- ||
| 46 | +218 |
- #' and Sex (F, M; reference Female). The model is abbreviated: y ~ Arm + Sex + Arm x Sex.+ #' @details In general, functions that starts with `analyze*` are expected to |
||
| 47 | +219 |
- #' The cox regression estimates the coefficients along with a variance-covariance matrix for:+ #' work like [rtables::analyze()], while functions that starts with `summarize*` |
||
| 48 | +220 |
- #'+ #' are based upon [rtables::summarize_row_groups()]. The latter provides a |
||
| 49 | +221 |
- #' - b1 (arm b), b2 (arm c)+ #' value for each dividing split in the row and column space, but, being it |
||
| 50 | +222 |
- #' - b3 (sex m)+ #' bound to the fundamental splits, it is repeated by design in every page |
||
| 51 | +223 |
- #' - b4 (arm b: sex m), b5 (arm c: sex m)+ #' when pagination is involved. |
||
| 52 | +224 |
#' |
||
| 53 | -- |
- #' Given that I want an estimation of the Hazard Ratio for arm C/sex M, the estimation- |
- ||
| 54 | +225 |
- #' will be given in reference to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5),+ #' @note As opposed to [summarize_num_patients()], this function does not repeat the produced rows. |
||
| 55 | +226 |
- #' therefore the interaction coefficient is given by b2 + b5 while the standard error is obtained+ #' |
||
| 56 | +227 |
- #' as $1.96 * sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$ for a confidence level of 0.95.+ #' @examples |
||
| 57 | +228 |
- #'+ #' df <- data.frame( |
||
| 58 | +229 |
- #' @return A list of matrices (one per level of variable) with rows corresponding to the combinations of+ #' USUBJID = as.character(c(1, 2, 1, 4, NA, 6, 6, 8, 9)), |
||
| 59 | +230 |
- #' `variable` and `given`, with columns:+ #' ARM = c("A", "A", "A", "A", "A", "B", "B", "B", "B"),
|
||
| 60 | +231 |
- #' * `coef_hat`: Estimation of the coefficient.+ #' AGE = c(10, 15, 10, 17, 8, 11, 11, 19, 17), |
||
| 61 | +232 |
- #' * `coef_se`: Standard error of the estimation.+ #' SEX = c("M", "M", "M", "F", "F", "F", "M", "F", "M")
|
||
| 62 | +233 |
- #' * `hr`: Hazard ratio.+ #' ) |
||
| 63 | +234 |
- #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio.+ #' |
||
| 64 | +235 |
- #'+ #' # analyze_num_patients |
||
| 65 | +236 |
- #' @seealso [s_cox_multivariate()].+ #' tbl <- basic_table() %>% |
||
| 66 | +237 |
- #'+ #' split_cols_by("ARM") %>%
|
||
| 67 | +238 |
- #' @examples+ #' add_colcounts() %>% |
||
| 68 | +239 |
- #' library(dplyr)+ #' analyze_num_patients("USUBJID", .stats = c("unique")) %>%
|
||
| 69 | +240 |
- #' library(survival)+ #' build_table(df) |
||
| 70 | +241 |
#' |
||
| 71 | +242 |
- #' ADSL <- tern_ex_adsl %>%+ #' tbl |
||
| 72 | +243 |
- #' filter(SEX %in% c("F", "M"))
+ #' |
||
| 73 | +244 |
- #'+ #' @export |
||
| 74 | +245 |
- #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "PFS")+ #' @order 2 |
||
| 75 | +246 |
- #' adtte$ARMCD <- droplevels(adtte$ARMCD)+ analyze_num_patients <- function(lyt, |
||
| 76 | +247 |
- #' adtte$SEX <- droplevels(adtte$SEX)+ vars, |
||
| 77 | +248 |
- #'+ required = NULL, |
||
| 78 | +249 |
- #' mod <- coxph(+ count_by = NULL, |
||
| 79 | +250 |
- #' formula = Surv(time = AVAL, event = 1 - CNSR) ~ (SEX + ARMCD)^2,+ unique_count_suffix = TRUE, |
||
| 80 | +251 |
- #' data = adtte+ na_str = default_na_str(), |
||
| 81 | +252 |
- #' )+ nested = TRUE, |
||
| 82 | +253 |
- #'+ .stats = NULL, |
||
| 83 | +254 |
- #' mmat <- stats::model.matrix(mod)[1, ]+ .formats = NULL, |
||
| 84 | +255 |
- #' mmat[!mmat == 0] <- 0+ .labels = c( |
||
| 85 | +256 |
- #'+ unique = "Number of patients with at least one event", |
||
| 86 | +257 |
- #' @keywords internal+ nonunique = "Number of events" |
||
| 87 | +258 |
- estimate_coef <- function(variable, given,+ ), |
||
| 88 | +259 |
- lvl_var, lvl_given,+ show_labels = c("default", "visible", "hidden"),
|
||
| 89 | +260 |
- coef,+ .indent_mods = 0L, |
||
| 90 | +261 |
- mmat,+ riskdiff = FALSE, |
||
| 91 | +262 |
- vcov,+ ...) {
+ |
+ ||
| 263 | +4x | +
+ checkmate::assert_flag(riskdiff) |
||
| 92 | +264 |
- conf_level = 0.95) {
+
|
||
| 93 | -8x | +265 | +1x |
- var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level+ if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
|
| 94 | -8x | +|||
| 266 | +! |
- giv_lvl <- paste0(given, lvl_given)+ if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats] |
||
| 95 | +267 | |||
| 96 | -8x | +268 | +4x |
- design_mat <- expand.grid(variable = var_lvl, given = giv_lvl)+ s_args <- list(required = required, count_by = count_by, unique_count_suffix = unique_count_suffix, ...) |
| 97 | -8x | +|||
| 269 | +
- design_mat <- design_mat[order(design_mat$variable, design_mat$given), ]+ |
|||
| 98 | -8x | +270 | +4x |
- design_mat <- within(+ afun <- make_afun( |
| 99 | -8x | +271 | +4x |
- data = design_mat,+ c_num_patients, |
| 100 | -8x | +272 | +4x |
- expr = {
+ .stats = .stats, |
| 101 | -8x | +273 | +4x |
- inter <- paste0(variable, ":", given)+ .formats = .formats, |
| 102 | -8x | -
- rev_inter <- paste0(given, ":", variable)- |
- ||
| 103 | -+ | 274 | +4x |
- }+ .labels = .labels |
| 104 | +275 |
) |
||
| 105 | +276 | |||
| 106 | -8x | +277 | +4x |
- split_by_variable <- design_mat$variable+ extra_args <- if (isFALSE(riskdiff)) {
|
| 107 | -8x | +278 | +2x |
- interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/")+ s_args |
| 108 | +279 |
-
+ } else {
|
||
| 109 | -8x | +280 | +2x |
- design_mat <- apply(+ list( |
| 110 | -8x | +281 | +2x |
- X = design_mat, MARGIN = 1, FUN = function(x) {
+ afun = list("s_num_patients_content" = afun),
|
| 111 | -27x | +282 | +2x |
- mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1+ .stats = .stats, |
| 112 | -27x | +283 | +2x |
- return(mmat)+ .indent_mods = .indent_mods, |
| 113 | -+ | |||
| 284 | +2x |
- }+ s_args = s_args |
||
| 114 | +285 |
- )- |
- ||
| 115 | -8x | -
- colnames(design_mat) <- interaction_names+ ) |
||
| 116 | +286 | - - | -||
| 117 | -8x | -
- betas <- as.matrix(coef)+ } |
||
| 118 | +287 | |||
| 119 | -8x | +288 | +4x |
- coef_hat <- t(design_mat) %*% betas+ analyze( |
| 120 | -8x | +289 | +4x |
- dimnames(coef_hat)[2] <- "coef"+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff), |
| 121 | -+ | |||
| 290 | +4x |
-
+ lyt = lyt, |
||
| 122 | -8x | +291 | +4x |
- coef_se <- apply(design_mat, 2, function(x) {
+ vars = vars, |
| 123 | -27x | +292 | +4x |
- vcov_el <- as.logical(x)+ na_str = na_str, |
| 124 | -27x | +293 | +4x |
- y <- vcov[vcov_el, vcov_el]+ nested = nested, |
| 125 | -27x | +294 | +4x |
- y <- sum(y)+ extra_args = extra_args, |
| 126 | -27x | +295 | +4x |
- y <- sqrt(y)+ show_labels = show_labels, |
| 127 | -27x | +296 | +4x |
- return(y)+ indent_mod = .indent_mods |
| 128 | +297 |
- })+ ) |
||
| 129 | +298 |
-
+ } |
||
| 130 | -8x | +
| 1 | +
- q_norm <- stats::qnorm((1 + conf_level) / 2)+ #' Proportion difference estimation |
|||
| 131 | -8x | +|||
| 2 | +
- y <- cbind(coef_hat, `se(coef)` = coef_se)+ #' |
|||
| 132 | +3 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 133 | -8x | +|||
| 4 | +
- y <- apply(y, 1, function(x) {
+ #' |
|||
| 134 | -27x | +|||
| 5 | +
- x["hr"] <- exp(x["coef"])+ #' The analysis function [estimate_proportion_diff()] creates a layout element to estimate the difference in proportion |
|||
| 135 | -27x | +|||
| 6 | +
- x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"])+ #' of responders within a studied population. The primary analysis variable, `vars`, is a logical variable indicating |
|||
| 136 | -27x | +|||
| 7 | +
- x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"])+ #' whether a response has occurred for each record. See the `method` parameter for options of methods to use when |
|||
| 137 | +8 |
-
+ #' constructing the confidence interval of the proportion difference. A stratification variable can be supplied via the |
||
| 138 | -27x | +|||
| 9 | +
- return(x)+ #' `strata` element of the `variables` argument. |
|||
| 139 | +10 |
- })+ #' |
||
| 140 | +11 |
-
+ #' |
||
| 141 | -8x | +|||
| 12 | +
- y <- t(y)+ #' @inheritParams prop_diff_strat_nc |
|||
| 142 | -8x | +|||
| 13 | +
- y <- by(y, split_by_variable, identity)+ #' @inheritParams argument_convention |
|||
| 143 | -8x | +|||
| 14 | +
- y <- lapply(y, as.matrix)+ #' @param method (`string`)\cr the method used for the confidence interval estimation. |
|||
| 144 | +15 |
-
+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 145 | -8x | +|||
| 16 | +
- attr(y, "details") <- paste0(+ #' |
|||
| 146 | -8x | +|||
| 17 | +
- "Estimations of ", variable,+ #' Options are: ``r shQuote(get_stats("estimate_proportion_diff"), type = "sh")``
|
|||
| 147 | -8x | +|||
| 18 | +
- " hazard ratio given the level of ", given, " compared to ",+ #' |
|||
| 148 | -8x | +|||
| 19 | +
- variable, " level ", lvl_var[1], "."+ #' @seealso [d_proportion_diff()] |
|||
| 149 | +20 |
- )+ #' |
||
| 150 | -8x | +|||
| 21 | +
- return(y)+ #' @name prop_diff |
|||
| 151 | +22 |
- }+ #' @order 1 |
||
| 152 | +23 |
-
+ NULL |
||
| 153 | +24 |
- #' `tryCatch` around `car::Anova`+ |
||
| 154 | +25 |
- #'+ #' @describeIn prop_diff Statistics function estimating the difference |
||
| 155 | +26 |
- #' Captures warnings when executing [car::Anova].+ #' in terms of responder proportion. |
||
| 156 | +27 |
#' |
||
| 157 | +28 |
- #' @inheritParams car::Anova+ #' @return |
||
| 158 | +29 |
- #'+ #' * `s_proportion_diff()` returns a named list of elements `diff` and `diff_ci`. |
||
| 159 | +30 |
- #' @return A list with item `aov` for the result of the model and `error_text` for the captured warnings.+ #' |
||
| 160 | +31 |
- #'+ #' @note When performing an unstratified analysis, methods `"cmh"`, `"strat_newcombe"`, and `"strat_newcombecc"` are |
||
| 161 | +32 |
- #' @examples+ #' not permitted. |
||
| 162 | +33 |
- #' # `car::Anova` on cox regression model including strata and expected+ #' |
||
| 163 | +34 |
- #' # a likelihood ratio test triggers a warning as only Wald method is+ #' @examples |
||
| 164 | +35 |
- #' # accepted.+ #' s_proportion_diff( |
||
| 165 | +36 |
- #'+ #' df = subset(dta, grp == "A"), |
||
| 166 | +37 |
- #' library(survival)+ #' .var = "rsp", |
||
| 167 | +38 |
- #'+ #' .ref_group = subset(dta, grp == "B"), |
||
| 168 | +39 |
- #' mod <- coxph(+ #' .in_ref_col = FALSE, |
||
| 169 | +40 |
- #' formula = Surv(time = futime, event = fustat) ~ factor(rx) + strata(ecog.ps),+ #' conf_level = 0.90, |
||
| 170 | +41 |
- #' data = ovarian+ #' method = "ha" |
||
| 171 | +42 |
#' ) |
||
| 172 | +43 |
#' |
||
| 173 | +44 |
- #' @keywords internal+ #' # CMH example with strata |
||
| 174 | +45 |
- try_car_anova <- function(mod,+ #' s_proportion_diff( |
||
| 175 | +46 |
- test.statistic) { # nolint
- |
- ||
| 176 | -1x | -
- y <- tryCatch(+ #' df = subset(dta, grp == "A"), |
||
| 177 | -1x | +|||
| 47 | +
- withCallingHandlers(+ #' .var = "rsp", |
|||
| 178 | -1x | +|||
| 48 | +
- expr = {
+ #' .ref_group = subset(dta, grp == "B"), |
|||
| 179 | -1x | +|||
| 49 | +
- warn_text <- c()+ #' .in_ref_col = FALSE, |
|||
| 180 | -1x | +|||
| 50 | +
- list(+ #' variables = list(strata = c("f1", "f2")),
|
|||
| 181 | -1x | +|||
| 51 | +
- aov = car::Anova(+ #' conf_level = 0.90, |
|||
| 182 | -1x | +|||
| 52 | +
- mod,+ #' method = "cmh" |
|||
| 183 | -1x | +|||
| 53 | +
- test.statistic = test.statistic,+ #' ) |
|||
| 184 | -1x | +|||
| 54 | +
- type = "III"+ #' |
|||
| 185 | +55 |
- ),+ #' @export |
||
| 186 | -1x | +|||
| 56 | +
- warn_text = warn_text+ s_proportion_diff <- function(df, |
|||
| 187 | +57 |
- )+ .var, |
||
| 188 | +58 |
- },+ .ref_group, |
||
| 189 | -1x | +|||
| 59 | +
- warning = function(w) {
+ .in_ref_col, |
|||
| 190 | +60 |
- # If a warning is detected it is handled as "w".+ variables = list(strata = NULL), |
||
| 191 | -! | +|||
| 61 | +
- warn_text <<- trimws(paste0("Warning in `try_car_anova`: ", w))
+ conf_level = 0.95, |
|||
| 192 | +62 |
-
+ method = c( |
||
| 193 | +63 |
- # A warning is sometimes expected, then, we want to restart+ "waldcc", "wald", "cmh", |
||
| 194 | +64 |
- # the execution while ignoring the warning.+ "ha", "newcombe", "newcombecc", |
||
| 195 | -! | +|||
| 65 | +
- invokeRestart("muffleWarning")
+ "strat_newcombe", "strat_newcombecc" |
|||
| 196 | +66 |
- }+ ), |
||
| 197 | +67 |
- ),+ weights_method = "cmh") {
|
||
| 198 | -1x | +68 | +2x |
- finally = {
+ method <- match.arg(method) |
| 199 | -+ | |||
| 69 | +2x |
- }+ if (is.null(variables$strata) && checkmate::test_subset(method, c("cmh", "strat_newcombe", "strat_newcombecc"))) {
|
||
| 200 | -+ | |||
| 70 | +! |
- )+ stop(paste( |
||
| 201 | -+ | |||
| 71 | +! |
-
+ "When performing an unstratified analysis, methods 'cmh', 'strat_newcombe', and 'strat_newcombecc' are not", |
||
| 202 | -1x | +|||
| 72 | +! |
- return(y)+ "permitted. Please choose a different method." |
||
| 203 | +73 |
- }+ )) |
||
| 204 | +74 |
-
+ } |
||
| 205 | -+ | |||
| 75 | +2x |
- #' Fit a Cox regression model and ANOVA+ y <- list(diff = "", diff_ci = "") |
||
| 206 | +76 |
- #'+ |
||
| 207 | -+ | |||
| 77 | +2x |
- #' The functions derives the effect p-values using [car::Anova()] from [survival::coxph()] results.+ if (!.in_ref_col) {
|
||
| 208 | -+ | |||
| 78 | +2x |
- #'+ rsp <- c(.ref_group[[.var]], df[[.var]]) |
||
| 209 | -+ | |||
| 79 | +2x |
- #' @inheritParams t_coxreg+ grp <- factor( |
||
| 210 | -+ | |||
| 80 | +2x |
- #'+ rep( |
||
| 211 | -+ | |||
| 81 | +2x |
- #' @return A list with items `mod` (results of [survival::coxph()]), `msum` (result of `summary`) and+ c("ref", "Not-ref"),
|
||
| 212 | -+ | |||
| 82 | +2x |
- #' `aov` (result of [car::Anova()]).+ c(nrow(.ref_group), nrow(df)) |
||
| 213 | +83 |
- #'+ ), |
||
| 214 | -+ | |||
| 84 | +2x |
- #' @noRd+ levels = c("ref", "Not-ref")
|
||
| 215 | +85 |
- fit_n_aov <- function(formula,+ ) |
||
| 216 | +86 |
- data = data,+ |
||
| 217 | -+ | |||
| 87 | +2x |
- conf_level = conf_level,+ if (!is.null(variables$strata)) {
|
||
| 218 | -+ | |||
| 88 | +1x |
- pval_method = c("wald", "likelihood"),
+ strata_colnames <- variables$strata |
||
| 219 | -+ | |||
| 89 | +1x |
- ...) {
+ checkmate::assert_character(strata_colnames, null.ok = FALSE) |
||
| 220 | +90 | 1x |
- pval_method <- match.arg(pval_method)+ strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames) |
|
| 221 | +91 | |||
| 222 | +92 | 1x |
- environment(formula) <- environment()+ assert_df_with_variables(df, strata_vars) |
|
| 223 | +93 | 1x |
- suppressWarnings({
+ assert_df_with_variables(.ref_group, strata_vars) |
|
| 224 | +94 |
- # We expect some warnings due to coxph which fails strict programming.+ + |
+ ||
| 95 | ++ |
+ # Merging interaction strata for reference group rows data and remaining |
||
| 225 | +96 | 1x |
- mod <- survival::coxph(formula, data = data, ...)+ strata <- c( |
|
| 226 | +97 | 1x |
- msum <- summary(mod, conf.int = conf_level)+ interaction(.ref_group[strata_colnames]), |
|
| 227 | -+ | |||
| 98 | +1x |
- })+ interaction(df[strata_colnames]) |
||
| 228 | +99 |
-
+ ) |
||
| 229 | +100 | 1x |
- aov <- try_car_anova(+ strata <- as.factor(strata) |
|
| 230 | -1x | +|||
| 101 | +
- mod,+ } |
|||
| 231 | -1x | +|||
| 102 | +
- test.statistic = switch(pval_method,+ |
|||
| 232 | -1x | +|||
| 103 | +
- "wald" = "Wald",+ # Defining the std way to calculate weights for strat_newcombe |
|||
| 233 | -1x | +104 | +2x |
- "likelihood" = "LR"+ if (!is.null(variables$weights_method)) {
+ |
+
| 105 | +! | +
+ weights_method <- variables$weights_method |
||
| 234 | +106 |
- )+ } else {
+ |
+ ||
| 107 | +2x | +
+ weights_method <- "cmh" |
||
| 235 | +108 |
- )+ } |
||
| 236 | +109 | |||
| 237 | -1x | +110 | +2x | +
+ y <- switch(method,+ |
+
| 111 | +2x | +
+ "wald" = prop_diff_wald(rsp, grp, conf_level, correct = FALSE),+ |
+ ||
| 112 | +2x | +
+ "waldcc" = prop_diff_wald(rsp, grp, conf_level, correct = TRUE),+ |
+ ||
| 113 | +2x | +
+ "ha" = prop_diff_ha(rsp, grp, conf_level),+ |
+ ||
| 114 | +2x |
- warn_attr <- aov$warn_text+ "newcombe" = prop_diff_nc(rsp, grp, conf_level, correct = FALSE), |
||
| 238 | -! | +|||
| 115 | +2x |
- if (!is.null(aov$warn_text)) message(warn_attr)+ "newcombecc" = prop_diff_nc(rsp, grp, conf_level, correct = TRUE), |
||
| 239 | -+ | |||
| 116 | +2x |
-
+ "strat_newcombe" = prop_diff_strat_nc(rsp, |
||
| 240 | -1x | +117 | +2x |
- aov <- aov$aov+ grp, |
| 241 | -1x | +118 | +2x |
- y <- list(mod = mod, msum = msum, aov = aov)+ strata, |
| 242 | -1x | +119 | +2x |
- attr(y, "message") <- warn_attr+ weights_method, |
| 243 | -+ | |||
| 120 | +2x |
-
+ conf_level, |
||
| 244 | -1x | +121 | +2x |
- return(y)+ correct = FALSE |
| 245 | +122 |
- }+ ), |
||
| 246 | -+ | |||
| 123 | +2x |
-
+ "strat_newcombecc" = prop_diff_strat_nc(rsp, |
||
| 247 | -+ | |||
| 124 | +2x |
- # argument_checks+ grp, |
||
| 248 | -+ | |||
| 125 | +2x |
- check_formula <- function(formula) {
+ strata, |
||
| 249 | -1x | +126 | +2x |
- if (!(inherits(formula, "formula"))) {
+ weights_method, |
| 250 | -1x | +127 | +2x |
- stop("Check `formula`. A formula should resemble `Surv(time = AVAL, event = 1 - CNSR) ~ study_arm(ARMCD)`.")
+ conf_level, |
| 251 | -+ | |||
| 128 | +2x |
- }+ correct = TRUE |
||
| 252 | +129 |
-
+ ), |
||
| 253 | -! | +|||
| 130 | +2x |
- invisible()+ "cmh" = prop_diff_cmh(rsp, grp, strata, conf_level)[c("diff", "diff_ci")]
|
||
| 254 | +131 |
- }+ ) |
||
| 255 | +132 | |||
| 256 | -- |
- check_covariate_formulas <- function(covariates) {
- |
- ||
| 257 | -1x | +133 | +2x |
- if (!all(vapply(X = covariates, FUN = inherits, what = "formula", FUN.VALUE = TRUE)) || is.null(covariates)) {
+ y$diff <- y$diff * 100 |
| 258 | -1x | +134 | +2x |
- stop("Check `covariates`, it should be a list of right-hand-term formulas, e.g. list(Age = ~AGE).")
+ y$diff_ci <- y$diff_ci * 100 |
| 259 | +135 |
} |
||
| 260 | +136 | |||
| 261 | -! | -
- invisible()- |
- ||
| 262 | -- |
- }- |
- ||
| 263 | -+ | |||
| 137 | +2x |
-
+ attr(y$diff, "label") <- "Difference in Response rate (%)" |
||
| 264 | -+ | |||
| 138 | +2x |
- name_covariate_names <- function(covariates) {
+ attr(y$diff_ci, "label") <- d_proportion_diff( |
||
| 265 | -1x | +139 | +2x |
- miss_names <- names(covariates) == ""+ conf_level, method, |
| 266 | -1x | +140 | +2x |
- no_names <- is.null(names(covariates))+ long = FALSE |
| 267 | -! | +|||
| 141 | +
- if (any(miss_names)) names(covariates)[miss_names] <- vapply(covariates[miss_names], FUN = rht, FUN.VALUE = "name")+ ) |
|||
| 268 | -! | +|||
| 142 | +
- if (no_names) names(covariates) <- vapply(covariates, FUN = rht, FUN.VALUE = "name")+ |
|||
| 269 | -1x | +143 | +2x |
- return(covariates)+ y |
| 270 | +144 |
} |
||
| 271 | +145 | |||
| 272 | +146 |
- check_increments <- function(increments, covariates) {
- |
- ||
| 273 | -1x | -
- if (!is.null(increments)) {
+ #' @describeIn prop_diff Formatted analysis function which is used as `afun` in `estimate_proportion_diff()`. |
||
| 274 | -1x | +|||
| 147 | +
- covariates <- vapply(covariates, FUN = rht, FUN.VALUE = "name")+ #' |
|||
| 275 | -1x | +|||
| 148 | +
- lapply(+ #' @return |
|||
| 276 | -1x | +|||
| 149 | +
- X = names(increments), FUN = function(x) {
+ #' * `a_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()]. |
|||
| 277 | -3x | +|||
| 150 | +
- if (!x %in% covariates) {
+ #' |
|||
| 278 | -1x | +|||
| 151 | +
- warning(+ #' @examples |
|||
| 279 | -1x | +|||
| 152 | +
- paste(+ #' a_proportion_diff( |
|||
| 280 | -1x | +|||
| 153 | +
- "Check `increments`, the `increment` for ", x,+ #' df = subset(dta, grp == "A"), |
|||
| 281 | -1x | +|||
| 154 | +
- "doesn't match any names in investigated covariate(s)."+ #' .var = "rsp", |
|||
| 282 | +155 |
- )+ #' .ref_group = subset(dta, grp == "B"), |
||
| 283 | +156 |
- )+ #' .in_ref_col = FALSE, |
||
| 284 | +157 |
- }+ #' conf_level = 0.90, |
||
| 285 | +158 |
- }+ #' method = "ha" |
||
| 286 | +159 |
- )+ #' ) |
||
| 287 | +160 |
- }+ #' |
||
| 288 | +161 |
-
+ #' @export |
||
| 289 | -1x | +|||
| 162 | +
- invisible()+ a_proportion_diff <- make_afun( |
|||
| 290 | +163 |
- }+ s_proportion_diff, |
||
| 291 | +164 |
-
+ .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"), |
||
| 292 | +165 |
- #' Multivariate Cox model - summarized results+ .indent_mods = c(diff = 0L, diff_ci = 1L) |
||
| 293 | +166 |
- #'+ ) |
||
| 294 | +167 |
- #' Analyses based on multivariate Cox model are usually not performed for the Controlled Substance Reporting or+ |
||
| 295 | +168 |
- #' regulatory documents but serve exploratory purposes only (e.g., for publication). In practice, the model usually+ #' @describeIn prop_diff Layout-creating function which can take statistics function arguments |
||
| 296 | +169 |
- #' includes only the main effects (without interaction terms). It produces the hazard ratio estimates for each of the+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 297 | +170 |
- #' covariates included in the model.+ #' |
||
| 298 | +171 |
- #' The analysis follows the same principles (e.g., stratified vs. unstratified analysis and tie handling) as the+ #' @return |
||
| 299 | +172 |
- #' usual Cox model analysis. Since there is usually no pre-specified hypothesis testing for such analysis,+ #' * `estimate_proportion_diff()` returns a layout object suitable for passing to further layouting functions, |
||
| 300 | +173 |
- #' the p.values need to be interpreted with caution. (**Statistical Analysis of Clinical Trials Data with R**,+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 301 | +174 |
- #' `NEST's bookdown`)+ #' the statistics from `s_proportion_diff()` to the table layout. |
||
| 302 | +175 |
#' |
||
| 303 | +176 |
- #' @param formula (`formula`)\cr a formula corresponding to the investigated [survival::Surv()] survival model+ #' @examples |
||
| 304 | +177 |
- #' including covariates.+ #' ## "Mid" case: 4/4 respond in group A, 1/2 respond in group B. |
||
| 305 | +178 |
- #' @param data (`data.frame`)\cr a data frame which includes the variable in formula and covariates.+ #' nex <- 100 # Number of example rows |
||
| 306 | +179 |
- #' @param conf_level (`proportion`)\cr the confidence level for the hazard ratio interval estimations. Default is 0.95.+ #' dta <- data.frame( |
||
| 307 | +180 |
- #' @param pval_method (`string`)\cr the method used for the estimation of p-values, should be one of+ #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE), |
||
| 308 | +181 |
- #' `"wald"` (default) or `"likelihood"`.+ #' "grp" = sample(c("A", "B"), nex, TRUE),
|
||
| 309 | +182 |
- #' @param ... optional parameters passed to [survival::coxph()]. Can include `ties`, a character string specifying the+ #' "f1" = sample(c("a1", "a2"), nex, TRUE),
|
||
| 310 | +183 |
- #' method for tie handling, one of `exact` (default), `efron`, `breslow`.+ #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
|
||
| 311 | +184 |
- #'+ #' stringsAsFactors = TRUE |
||
| 312 | +185 |
- #' @return A `list` with elements `mod`, `msum`, `aov`, and `coef_inter`.+ #' ) |
||
| 313 | +186 |
#' |
||
| 314 | +187 |
- #' @details The output is limited to single effect terms. Work in ongoing for estimation of interaction terms+ #' l <- basic_table() %>% |
||
| 315 | +188 |
- #' but is out of scope as defined by the Global Data Standards Repository+ #' split_cols_by(var = "grp", ref_group = "B") %>% |
||
| 316 | +189 |
- #' (**`GDS_Standard_TLG_Specs_Tables_2.doc`**).+ #' estimate_proportion_diff( |
||
| 317 | +190 |
- #'+ #' vars = "rsp", |
||
| 318 | +191 |
- #' @seealso [estimate_coef()].+ #' conf_level = 0.90, |
||
| 319 | +192 |
- #'+ #' method = "ha" |
||
| 320 | +193 |
- #' @examples+ #' ) |
||
| 321 | +194 |
- #' library(dplyr)+ #' |
||
| 322 | +195 |
- #'+ #' build_table(l, df = dta) |
||
| 323 | +196 |
- #' adtte <- tern_ex_adtte+ #' |
||
| 324 | +197 |
- #' adtte_f <- subset(adtte, PARAMCD == "OS") # _f: filtered+ #' @export |
||
| 325 | +198 |
- #' adtte_f <- filter(+ #' @order 2 |
||
| 326 | +199 |
- #' adtte_f,+ estimate_proportion_diff <- function(lyt, |
||
| 327 | +200 |
- #' PARAMCD == "OS" &+ vars, |
||
| 328 | +201 |
- #' SEX %in% c("F", "M") &
+ variables = list(strata = NULL), |
||
| 329 | +202 |
- #' RACE %in% c("ASIAN", "BLACK OR AFRICAN AMERICAN", "WHITE")
+ conf_level = 0.95, |
||
| 330 | +203 |
- #' )+ method = c( |
||
| 331 | +204 |
- #' adtte_f$SEX <- droplevels(adtte_f$SEX)+ "waldcc", "wald", "cmh", |
||
| 332 | +205 |
- #' adtte_f$RACE <- droplevels(adtte_f$RACE)+ "ha", "newcombe", "newcombecc", |
||
| 333 | +206 |
- #'+ "strat_newcombe", "strat_newcombecc" |
||
| 334 | +207 |
- #' @keywords internal+ ), |
||
| 335 | +208 |
- s_cox_multivariate <- function(formula, data,+ weights_method = "cmh", |
||
| 336 | +209 |
- conf_level = 0.95,+ na_str = default_na_str(), |
||
| 337 | +210 |
- pval_method = c("wald", "likelihood"),
+ nested = TRUE, |
||
| 338 | +211 |
- ...) {
- |
- ||
| 339 | -1x | -
- tf <- stats::terms(formula, specials = c("strata"))
+ ..., |
||
| 340 | -1x | +|||
| 212 | +
- covariates <- rownames(attr(tf, "factors"))[-c(1, unlist(attr(tf, "specials")))]+ var_labels = vars, |
|||
| 341 | -1x | +|||
| 213 | +
- lapply(+ show_labels = "hidden", |
|||
| 342 | -1x | +|||
| 214 | +
- X = covariates,+ table_names = vars, |
|||
| 343 | -1x | +|||
| 215 | +
- FUN = function(x) {
+ .stats = NULL, |
|||
| 344 | -3x | +|||
| 216 | +
- if (is.character(data[[x]])) {
+ .formats = NULL, |
|||
| 345 | -1x | +|||
| 217 | +
- data[[x]] <<- as.factor(data[[x]])+ .labels = NULL, |
|||
| 346 | +218 |
- }+ .indent_mods = NULL) {
|
||
| 347 | -3x | +219 | +4x |
- invisible()+ extra_args <- list( |
| 348 | -+ | |||
| 220 | +4x |
- }+ variables = variables, conf_level = conf_level, method = method, weights_method = weights_method, ... |
||
| 349 | +221 |
) |
||
| 350 | -1x | -
- pval_method <- match.arg(pval_method)- |
- ||
| 351 | +222 | |||
| 352 | -+ | |||
| 223 | +4x |
- # Results directly exported from environment(fit_n_aov) to environment(s_function_draft)+ afun <- make_afun( |
||
| 353 | -1x | +224 | +4x |
- y <- fit_n_aov(+ a_proportion_diff, |
| 354 | -1x | +225 | +4x |
- formula = formula,+ .stats = .stats, |
| 355 | -1x | +226 | +4x |
- data = data,+ .formats = .formats, |
| 356 | -1x | +227 | +4x |
- conf_level = conf_level,+ .labels = .labels, |
| 357 | -1x | +228 | +4x |
- pval_method = pval_method,+ .indent_mods = .indent_mods |
| 358 | +229 |
- ...+ ) |
||
| 359 | +230 |
- )+ |
||
| 360 | -1x | +231 | +4x |
- mod <- y$mod+ analyze( |
| 361 | -1x | +232 | +4x |
- aov <- y$aov+ lyt, |
| 362 | -1x | +233 | +4x |
- msum <- y$msum+ vars, |
| 363 | -1x | +234 | +4x |
- list2env(as.list(y), environment())+ afun = afun, |
| 364 | -+ | |||
| 235 | +4x |
-
+ var_labels = var_labels, |
||
| 365 | -1x | +236 | +4x |
- all_term_labs <- attr(mod$terms, "term.labels")+ na_str = na_str, |
| 366 | -1x | +237 | +4x |
- term_labs <- all_term_labs[which(attr(mod$terms, "order") == 1)]+ nested = nested, |
| 367 | -1x | +238 | +4x |
- names(term_labs) <- term_labs+ extra_args = extra_args, |
| 368 | -+ | |||
| 239 | +4x |
-
+ show_labels = show_labels, |
||
| 369 | -1x | +240 | +4x |
- coef_inter <- NULL+ table_names = table_names |
| 370 | -1x | +|||
| 241 | +
- if (any(attr(mod$terms, "order") > 1)) {
+ ) |
|||
| 371 | -1x | +|||
| 242 | +
- for_inter <- all_term_labs[attr(mod$terms, "order") > 1]+ } |
|||
| 372 | -1x | +|||
| 243 | +
- names(for_inter) <- for_inter+ |
|||
| 373 | -1x | +|||
| 244 | +
- mmat <- stats::model.matrix(mod)[1, ]+ #' Check proportion difference arguments |
|||
| 374 | -1x | +|||
| 245 | +
- mmat[!mmat == 0] <- 0+ #' |
|||
| 375 | -1x | +|||
| 246 | +
- mcoef <- stats::coef(mod)+ #' Verifies that and/or convert arguments into valid values to be used in the |
|||
| 376 | -1x | +|||
| 247 | +
- mvcov <- stats::vcov(mod)+ #' estimation of difference in responder proportions. |
|||
| 377 | +248 |
-
+ #' |
||
| 378 | -1x | +|||
| 249 | +
- estimate_coef_local <- function(variable, given) {
+ #' @inheritParams prop_diff |
|||
| 379 | -6x | +|||
| 250 | +
- estimate_coef(+ #' @inheritParams prop_diff_wald |
|||
| 380 | -6x | +|||
| 251 | +
- variable, given,+ #' |
|||
| 381 | -6x | +|||
| 252 | +
- coef = mcoef, mmat = mmat, vcov = mvcov, conf_level = conf_level,+ #' @keywords internal |
|||
| 382 | -6x | +|||
| 253 | +
- lvl_var = levels(data[[variable]]), lvl_given = levels(data[[given]])+ check_diff_prop_ci <- function(rsp, |
|||
| 383 | +254 |
- )+ grp, |
||
| 384 | +255 |
- }+ strata = NULL, |
||
| 385 | +256 |
-
+ conf_level, |
||
| 386 | -1x | +|||
| 257 | +
- coef_inter <- lapply(+ correct = NULL) {
|
|||
| 387 | -1x | +258 | +26x |
- for_inter, function(x) {
+ checkmate::assert_logical(rsp, any.missing = FALSE) |
| 388 | -3x | +259 | +26x |
- y <- attr(mod$terms, "factors")[, x]+ checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) |
| 389 | -3x | +260 | +26x |
- y <- names(y[y > 0])+ checkmate::assert_number(conf_level, lower = 0, upper = 1) |
| 390 | -3x | +261 | +26x |
- Map(estimate_coef_local, variable = y, given = rev(y))+ checkmate::assert_flag(correct, null.ok = TRUE) |
| 391 | +262 |
- }+ |
||
| 392 | -+ | |||
| 263 | +26x |
- )+ if (!is.null(strata)) {
+ |
+ ||
| 264 | +12x | +
+ checkmate::assert_factor(strata, len = length(rsp)) |
||
| 393 | +265 |
} |
||
| 394 | +266 | |||
| 395 | -1x | +267 | +26x |
- list(mod = mod, msum = msum, aov = aov, coef_inter = coef_inter)+ invisible() |
| 396 | +268 |
} |
| 1 | -- |
- #' Control function for descriptive statistics- |
- ||
| 2 | +269 |
- #'+ |
||
| 3 | +270 |
- #' @description `r lifecycle::badge("stable")`
+ #' Description of method used for proportion comparison |
||
| 4 | +271 |
#' |
||
| 5 | -- |
- #' Sets a list of parameters for summaries of descriptive statistics. Typically used internally to specify- |
- ||
| 6 | +272 |
- #' details for [s_summary()]. This function family is mainly used by [analyze_vars()].+ #' @description `r lifecycle::badge("stable")`
|
||
| 7 | +273 |
#' |
||
| 8 | +274 |
- #' @inheritParams argument_convention+ #' This is an auxiliary function that describes the analysis in |
||
| 9 | +275 |
- #' @param quantiles (`numeric(2)`)\cr vector of length two to specify the quantiles to calculate.+ #' [s_proportion_diff()]. |
||
| 10 | +276 |
- #' @param quantile_type (`numeric(1)`)\cr number between 1 and 9 selecting quantile algorithms to be used.+ #' |
||
| 11 | +277 |
- #' Default is set to 2 as this matches the default quantile algorithm in SAS `proc univariate` set by `QNTLDEF=5`.+ #' @inheritParams s_proportion_diff |
||
| 12 | +278 |
- #' This differs from R's default. See more about `type` in [stats::quantile()].+ #' @param long (`flag`)\cr whether a long (`TRUE`) or a short (`FALSE`, default) description is required. |
||
| 13 | +279 |
- #' @param test_mean (`numeric(1)`)\cr number to test against the mean under the null hypothesis when calculating+ #' |
||
| 14 | +280 |
- #' p-value.+ #' @return A `string` describing the analysis. |
||
| 15 | +281 |
#' |
||
| 16 | +282 |
- #' @return A list of components with the same names as the arguments.+ #' @seealso [prop_diff] |
||
| 17 | +283 |
#' |
||
| 18 | +284 |
#' @export |
||
| 19 | +285 |
- control_analyze_vars <- function(conf_level = 0.95,+ d_proportion_diff <- function(conf_level, |
||
| 20 | +286 |
- quantiles = c(0.25, 0.75),+ method, |
||
| 21 | +287 |
- quantile_type = 2,+ long = FALSE) {
|
||
| 22 | -+ | |||
| 288 | +11x |
- test_mean = 0) {
+ label <- paste0(conf_level * 100, "% CI") |
||
| 23 | -1095x | +289 | +11x |
- checkmate::assert_vector(quantiles, len = 2)+ if (long) {
|
| 24 | -1095x | +|||
| 290 | +! |
- checkmate::assert_int(quantile_type, lower = 1, upper = 9)+ label <- paste( |
||
| 25 | -1095x | +|||
| 291 | +! |
- checkmate::assert_numeric(test_mean)+ label, |
||
| 26 | -1095x | +|||
| 292 | +! |
- lapply(quantiles, assert_proportion_value)+ ifelse( |
||
| 27 | -1094x | +|||
| 293 | +! |
- assert_proportion_value(conf_level)+ method == "cmh", |
||
| 28 | -1093x | +|||
| 294 | +! | +
+ "for adjusted difference",+ |
+ ||
| 295 | +! |
- list(conf_level = conf_level, quantiles = quantiles, quantile_type = quantile_type, test_mean = test_mean)+ "for difference" |
||
| 29 | +296 |
- }+ ) |
||
| 30 | +297 |
-
+ ) |
||
| 31 | +298 |
- # Helper function to fix numeric or counts pval if necessary+ } |
||
| 32 | +299 |
- .correct_num_or_counts_pval <- function(type, .stats) {
+
|
||
| 33 | -329x | +300 | +11x |
- if (type == "numeric") {
+ method_part <- switch(method, |
| 34 | -89x | +301 | +11x |
- if (!is.null(.stats) && any(grepl("^pval", .stats))) {
+ "cmh" = "CMH, without correction", |
| 35 | -10x | +302 | +11x |
- .stats[grepl("^pval", .stats)] <- "pval" # tmp fix xxx
+ "waldcc" = "Wald, with correction", |
| 36 | -+ | |||
| 303 | +11x |
- }+ "wald" = "Wald, without correction", |
||
| 37 | -+ | |||
| 304 | +11x |
- } else {
+ "ha" = "Anderson-Hauck", |
||
| 38 | -240x | +305 | +11x |
- if (!is.null(.stats) && any(grepl("^pval", .stats))) {
+ "newcombe" = "Newcombe, without correction", |
| 39 | -9x | +306 | +11x |
- .stats[grepl("^pval", .stats)] <- "pval_counts" # tmp fix xxx
+ "newcombecc" = "Newcombe, with correction", |
| 40 | -+ | |||
| 307 | +11x |
- }+ "strat_newcombe" = "Stratified Newcombe, without correction",+ |
+ ||
| 308 | +11x | +
+ "strat_newcombecc" = "Stratified Newcombe, with correction",+ |
+ ||
| 309 | +11x | +
+ stop(paste(method, "does not have a description")) |
||
| 41 | +310 |
- }+ ) |
||
| 42 | -329x | +311 | +11x |
- .stats+ paste0(label, " (", method_part, ")")
|
| 43 | +312 |
} |
||
| 44 | +313 | |||
| 45 | +314 |
- #' Analyze variables+ #' Helper functions to calculate proportion difference |
||
| 46 | +315 |
#' |
||
| 47 | +316 |
#' @description `r lifecycle::badge("stable")`
|
||
| 48 | +317 |
#' |
||
| 49 | +318 |
- #' The analyze function [analyze_vars()] creates a layout element to summarize one or more variables, using the S3+ #' @inheritParams argument_convention |
||
| 50 | +319 |
- #' generic function [s_summary()] to calculate a list of summary statistics. A list of all available statistics for+ #' @inheritParams prop_diff |
||
| 51 | +320 |
- #' numeric variables can be viewed by running `get_stats("analyze_vars_numeric")` and for non-numeric variables by
+ #' @param grp (`factor`)\cr vector assigning observations to one out of two groups |
||
| 52 | +321 |
- #' running `get_stats("analyze_vars_counts")`. Use the `.stats` parameter to specify the statistics to include in your
+ #' (e.g. reference and treatment group). |
||
| 53 | +322 |
- #' output summary table. Use `compare_with_ref_group = TRUE` to compare the variable with reference groups.+ #' |
||
| 54 | +323 |
- #'+ #' @return A named `list` of elements `diff` (proportion difference) and `diff_ci` |
||
| 55 | +324 |
- #' @details+ #' (proportion difference confidence interval). |
||
| 56 | +325 |
- #' **Automatic digit formatting:** The number of digits to display can be automatically determined from the analyzed+ #' |
||
| 57 | +326 |
- #' variable(s) (`vars`) for certain statistics by setting the statistic format to `"auto"` in `.formats`.+ #' @seealso [prop_diff()] for implementation of these helper functions. |
||
| 58 | +327 |
- #' This utilizes the [format_auto()] formatting function. Note that only data for the current row & variable (for all+ #' |
||
| 59 | +328 |
- #' columns) will be considered (`.df_row[[.var]]`, see [`rtables::additional_fun_params`]) and not the whole dataset.+ #' @name h_prop_diff |
||
| 60 | +329 |
- #'+ NULL |
||
| 61 | +330 |
- #' @inheritParams argument_convention+ |
||
| 62 | +331 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' @describeIn h_prop_diff The Wald interval follows the usual textbook |
||
| 63 | +332 |
- #'+ #' definition for a single proportion confidence interval using the normal |
||
| 64 | +333 |
- #' Options for numeric variables are: ``r shQuote(get_stats("analyze_vars_numeric"))``
+ #' approximation. It is possible to include a continuity correction for Wald's |
||
| 65 | +334 | ++ |
+ #' interval.+ |
+ |
| 335 |
#' |
|||
| 66 | +336 |
- #' Options for non-numeric variables are: ``r shQuote(get_stats("analyze_vars_counts"))``
+ #' @param correct (`flag`)\cr whether to include the continuity correction. For further |
||
| 67 | +337 |
- #'+ #' information, see [stats::prop.test()]. |
||
| 68 | +338 |
- #' @name analyze_variables+ #' |
||
| 69 | +339 |
- #' @order 1+ #' @examples |
||
| 70 | +340 |
- NULL+ #' # Wald confidence interval |
||
| 71 | +341 |
-
+ #' set.seed(2) |
||
| 72 | +342 |
- #' @describeIn analyze_variables S3 generic function to produces a variable summary.+ #' rsp <- sample(c(TRUE, FALSE), replace = TRUE, size = 20) |
||
| 73 | +343 |
- #'+ #' grp <- factor(c(rep("A", 10), rep("B", 10)))
|
||
| 74 | +344 |
- #' @return+ #' |
||
| 75 | +345 |
- #' * `s_summary()` returns different statistics depending on the class of `x`.+ #' prop_diff_wald(rsp = rsp, grp = grp, conf_level = 0.95, correct = FALSE) |
||
| 76 | +346 |
#' |
||
| 77 | +347 |
#' @export |
||
| 78 | +348 |
- s_summary <- function(x, ...) {
+ prop_diff_wald <- function(rsp, |
||
| 79 | -1658x | +|||
| 349 | +
- UseMethod("s_summary", x)
+ grp, |
|||
| 80 | +350 |
- }+ conf_level = 0.95, |
||
| 81 | +351 |
-
+ correct = FALSE) {
|
||
| 82 | -+ | |||
| 352 | +8x |
- #' @describeIn analyze_variables Method for `numeric` class.+ if (isTRUE(correct)) {
|
||
| 83 | -+ | |||
| 353 | +5x |
- #'+ mthd <- "waldcc" |
||
| 84 | +354 |
- #' @param control (`list`)\cr parameters for descriptive statistics details, specified by using+ } else {
|
||
| 85 | -+ | |||
| 355 | +3x |
- #' the helper function [control_analyze_vars()]. Some possible parameter options are:+ mthd <- "wald" |
||
| 86 | +356 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for mean and median.+ } |
||
| 87 | -+ | |||
| 357 | +8x |
- #' * `quantiles` (`numeric(2)`)\cr vector of length two to specify the quantiles.+ grp <- as_factor_keep_attributes(grp) |
||
| 88 | -+ | |||
| 358 | +8x |
- #' * `quantile_type` (`numeric(1)`)\cr between 1 and 9 selecting quantile algorithms to be used.+ check_diff_prop_ci( |
||
| 89 | -+ | |||
| 359 | +8x |
- #' See more about `type` in [stats::quantile()].+ rsp = rsp, grp = grp, conf_level = conf_level, correct = correct |
||
| 90 | +360 |
- #' * `test_mean` (`numeric(1)`)\cr value to test against the mean under the null hypothesis when calculating p-value.+ ) |
||
| 91 | +361 |
- #'+ |
||
| 92 | +362 |
- #' @return+ # check if binary response is coded as logical |
||
| 93 | -+ | |||
| 363 | +8x |
- #' * If `x` is of class `numeric`, returns a `list` with the following named `numeric` items:+ checkmate::assert_logical(rsp, any.missing = FALSE) |
||
| 94 | -+ | |||
| 364 | +8x |
- #' * `n`: The [length()] of `x`.+ checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2) |
||
| 95 | +365 |
- #' * `sum`: The [sum()] of `x`.+ |
||
| 96 | -+ | |||
| 366 | +8x |
- #' * `mean`: The [mean()] of `x`.+ tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE))) |
||
| 97 | +367 |
- #' * `sd`: The [stats::sd()] of `x`.+ # x1 and n1 are non-reference groups. |
||
| 98 | -+ | |||
| 368 | +8x |
- #' * `se`: The standard error of `x` mean, i.e.: (`sd(x) / sqrt(length(x))`).+ diff_ci <- desctools_binom( |
||
| 99 | -+ | |||
| 369 | +8x |
- #' * `mean_sd`: The [mean()] and [stats::sd()] of `x`.+ x1 = tbl[2], n1 = sum(tbl[2], tbl[4]), |
||
| 100 | -+ | |||
| 370 | +8x |
- #' * `mean_se`: The [mean()] of `x` and its standard error (see above).+ x2 = tbl[1], n2 = sum(tbl[1], tbl[3]), |
||
| 101 | -+ | |||
| 371 | +8x |
- #' * `mean_ci`: The CI for the mean of `x` (from [stat_mean_ci()]).+ conf.level = conf_level, |
||
| 102 | -+ | |||
| 372 | +8x |
- #' * `mean_sei`: The SE interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()] / [sqrt()]).+ method = mthd |
||
| 103 | +373 |
- #' * `mean_sdi`: The SD interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()]).+ ) |
||
| 104 | +374 |
- #' * `mean_pval`: The two-sided p-value of the mean of `x` (from [stat_mean_pval()]).+ |
||
| 105 | -+ | |||
| 375 | +8x |
- #' * `median`: The [stats::median()] of `x`.+ list( |
||
| 106 | -+ | |||
| 376 | +8x |
- #' * `mad`: The median absolute deviation of `x`, i.e.: ([stats::median()] of `xc`,+ "diff" = unname(diff_ci[, "est"]), |
||
| 107 | -+ | |||
| 377 | +8x |
- #' where `xc` = `x` - [stats::median()]).+ "diff_ci" = unname(diff_ci[, c("lwr.ci", "upr.ci")])
|
||
| 108 | +378 |
- #' * `median_ci`: The CI for the median of `x` (from [stat_median_ci()]).+ ) |
||
| 109 | +379 |
- #' * `quantiles`: Two sample quantiles of `x` (from [stats::quantile()]).+ } |
||
| 110 | +380 |
- #' * `iqr`: The [stats::IQR()] of `x`.+ |
||
| 111 | +381 |
- #' * `range`: The [range_noinf()] of `x`.+ #' @describeIn h_prop_diff Anderson-Hauck confidence interval. |
||
| 112 | +382 |
- #' * `min`: The [max()] of `x`.+ #' |
||
| 113 | +383 |
- #' * `max`: The [min()] of `x`.+ #' @examples |
||
| 114 | +384 |
- #' * `median_range`: The [median()] and [range_noinf()] of `x`.+ #' # Anderson-Hauck confidence interval |
||
| 115 | +385 |
- #' * `cv`: The coefficient of variation of `x`, i.e.: ([stats::sd()] / [mean()] * 100).+ #' ## "Mid" case: 3/4 respond in group A, 1/2 respond in group B. |
||
| 116 | +386 |
- #' * `geom_mean`: The geometric mean of `x`, i.e.: (`exp(mean(log(x)))`).+ #' rsp <- c(TRUE, FALSE, FALSE, TRUE, TRUE, TRUE) |
||
| 117 | +387 |
- #' * `geom_cv`: The geometric coefficient of variation of `x`, i.e.: (`sqrt(exp(sd(log(x)) ^ 2) - 1) * 100`).+ #' grp <- factor(c("A", "B", "A", "B", "A", "A"), levels = c("B", "A"))
|
||
| 118 | +388 |
#' |
||
| 119 | +389 |
- #' @note+ #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.90) |
||
| 120 | +390 |
- #' * If `x` is an empty vector, `NA` is returned. This is the expected feature so as to return `rcell` content in+ #' |
||
| 121 | +391 |
- #' `rtables` when the intersection of a column and a row delimits an empty data selection.+ #' ## Edge case: Same proportion of response in A and B. |
||
| 122 | +392 |
- #' * When the `mean` function is applied to an empty vector, `NA` will be returned instead of `NaN`, the latter+ #' rsp <- c(TRUE, FALSE, TRUE, FALSE) |
||
| 123 | +393 |
- #' being standard behavior in R.+ #' grp <- factor(c("A", "A", "B", "B"), levels = c("A", "B"))
|
||
| 124 | +394 |
#' |
||
| 125 | +395 |
- #' @method s_summary numeric+ #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.6) |
||
| 126 | +396 |
#' |
||
| 127 | +397 |
- #' @examples+ #' @export |
||
| 128 | +398 |
- #' # `s_summary.numeric`+ prop_diff_ha <- function(rsp, |
||
| 129 | +399 |
- #'+ grp, |
||
| 130 | +400 |
- #' ## Basic usage: empty numeric returns NA-filled items.+ conf_level) {
|
||
| 131 | -+ | |||
| 401 | +4x |
- #' s_summary(numeric())+ grp <- as_factor_keep_attributes(grp)+ |
+ ||
| 402 | +4x | +
+ check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level) |
||
| 132 | +403 |
- #'+ + |
+ ||
| 404 | +4x | +
+ tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE))) |
||
| 133 | +405 |
- #' ## Management of NA values.+ # x1 and n1 are non-reference groups.+ |
+ ||
| 406 | +4x | +
+ ci <- desctools_binom(+ |
+ ||
| 407 | +4x | +
+ x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ |
+ ||
| 408 | +4x | +
+ x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ |
+ ||
| 409 | +4x | +
+ conf.level = conf_level,+ |
+ ||
| 410 | +4x | +
+ method = "ha" |
||
| 134 | +411 |
- #' x <- c(NA_real_, 1)+ )+ |
+ ||
| 412 | +4x | +
+ list(+ |
+ ||
| 413 | +4x | +
+ "diff" = unname(ci[, "est"]),+ |
+ ||
| 414 | +4x | +
+ "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
|
||
| 135 | +415 |
- #' s_summary(x, na_rm = TRUE)+ ) |
||
| 136 | +416 |
- #' s_summary(x, na_rm = FALSE)+ } |
||
| 137 | +417 |
- #'+ |
||
| 138 | +418 |
- #' x <- c(NA_real_, 1, 2)+ #' @describeIn h_prop_diff Newcombe confidence interval. It is based on |
||
| 139 | +419 |
- #' s_summary(x)+ #' the Wilson score confidence interval for a single binomial proportion. |
||
| 140 | +420 |
#' |
||
| 141 | +421 |
- #' ## Benefits in `rtables` contructions:+ #' @examples |
||
| 142 | +422 |
- #' dta_test <- data.frame(+ #' # Newcombe confidence interval |
||
| 143 | +423 |
- #' Group = rep(LETTERS[seq(3)], each = 2),+ #' |
||
| 144 | +424 |
- #' sub_group = rep(letters[seq(2)], each = 3),+ #' set.seed(1) |
||
| 145 | +425 |
- #' x = seq(6)+ #' rsp <- c( |
||
| 146 | +426 |
- #' )+ #' sample(c(TRUE, FALSE), size = 40, prob = c(3 / 4, 1 / 4), replace = TRUE), |
||
| 147 | +427 |
- #'+ #' sample(c(TRUE, FALSE), size = 40, prob = c(1 / 2, 1 / 2), replace = TRUE) |
||
| 148 | +428 |
- #' ## The summary obtained in with `rtables`:+ #' ) |
||
| 149 | +429 |
- #' basic_table() %>%+ #' grp <- factor(rep(c("A", "B"), each = 40), levels = c("B", "A"))
|
||
| 150 | +430 |
- #' split_cols_by(var = "Group") %>%+ #' table(rsp, grp) |
||
| 151 | +431 |
- #' split_rows_by(var = "sub_group") %>%+ #' |
||
| 152 | +432 |
- #' analyze(vars = "x", afun = s_summary) %>%+ #' prop_diff_nc(rsp = rsp, grp = grp, conf_level = 0.9) |
||
| 153 | +433 |
- #' build_table(df = dta_test)+ #' |
||
| 154 | +434 |
- #'+ #' @export |
||
| 155 | +435 |
- #' ## By comparison with `lapply`:+ prop_diff_nc <- function(rsp, |
||
| 156 | +436 |
- #' X <- split(dta_test, f = with(dta_test, interaction(Group, sub_group)))+ grp, |
||
| 157 | +437 |
- #' lapply(X, function(x) s_summary(x$x))+ conf_level, |
||
| 158 | +438 |
- #'+ correct = FALSE) {
+ |
+ ||
| 439 | +2x | +
+ if (isTRUE(correct)) {
+ |
+ ||
| 440 | +! | +
+ mthd <- "scorecc" |
||
| 159 | +441 |
- #' @export+ } else {
+ |
+ ||
| 442 | +2x | +
+ mthd <- "score" |
||
| 160 | +443 |
- s_summary.numeric <- function(x, control = control_analyze_vars(), ...) {
+ } |
||
| 161 | -1140x | +444 | +2x |
- checkmate::assert_numeric(x)+ grp <- as_factor_keep_attributes(grp) |
| 162 | -1140x | +445 | +2x |
- args_list <- list(...)+ check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level)+ |
+
| 446 | ++ | + | ||
| 163 | -1140x | +447 | +2x |
- .N_row <- args_list[[".N_row"]] # nolint+ p_grp <- tapply(rsp, grp, mean) |
| 164 | -1140x | +448 | +2x |
- .N_col <- args_list[[".N_col"]] # nolint+ diff_p <- unname(diff(p_grp)) |
| 165 | -1140x | +449 | +2x |
- na_rm <- args_list[["na_rm"]] %||% TRUE+ tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE))) |
| 166 | -1140x | +450 | +2x |
- compare_with_ref_group <- args_list[["compare_with_ref_group"]]+ ci <- desctools_binom( |
| 167 | +451 |
-
+ # x1 and n1 are non-reference groups. |
||
| 168 | -1140x | +452 | +2x |
- if (na_rm) {
+ x1 = tbl[2], n1 = sum(tbl[2], tbl[4]), |
| 169 | -1138x | +453 | +2x |
- x <- x[!is.na(x)]+ x2 = tbl[1], n2 = sum(tbl[1], tbl[3]), |
| 170 | -+ | |||
| 454 | +2x |
- }+ conf.level = conf_level,+ |
+ ||
| 455 | +2x | +
+ method = mthd |
||
| 171 | +456 |
-
+ ) |
||
| 172 | -1140x | +457 | +2x |
- y <- list()+ list(+ |
+
| 458 | +2x | +
+ "diff" = unname(ci[, "est"]),+ |
+ ||
| 459 | +2x | +
+ "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
|
||
| 173 | +460 |
-
+ ) |
||
| 174 | -1140x | +|||
| 461 | +
- y$n <- c("n" = length(x))
+ } |
|||
| 175 | +462 | |||
| 176 | -1140x | +|||
| 463 | +
- y$sum <- c("sum" = ifelse(length(x) == 0, NA_real_, sum(x, na.rm = FALSE)))
+ #' @describeIn h_prop_diff Calculates the weighted difference. This is defined as the difference in |
|||
| 177 | +464 |
-
+ #' response rates between the experimental treatment group and the control treatment group, adjusted |
||
| 178 | -1140x | +|||
| 465 | +
- y$mean <- c("mean" = ifelse(length(x) == 0, NA_real_, mean(x, na.rm = FALSE)))
+ #' for stratification factors by applying Cochran-Mantel-Haenszel (CMH) weights. For the CMH chi-squared |
|||
| 179 | +466 |
-
+ #' test, use [stats::mantelhaen.test()]. |
||
| 180 | -1140x | +|||
| 467 | +
- y$sd <- c("sd" = stats::sd(x, na.rm = FALSE))
+ #' |
|||
| 181 | +468 |
-
+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`. |
||
| 182 | -1140x | +|||
| 469 | +
- y$se <- c("se" = stats::sd(x, na.rm = FALSE) / sqrt(length(stats::na.omit(x))))
+ #' |
|||
| 183 | +470 |
-
+ #' @examples |
||
| 184 | -1140x | +|||
| 471 | +
- y$mean_sd <- c(y$mean, "sd" = stats::sd(x, na.rm = FALSE))+ #' # Cochran-Mantel-Haenszel confidence interval |
|||
| 185 | +472 |
-
+ #' |
||
| 186 | -1140x | +|||
| 473 | +
- y$mean_se <- c(y$mean, y$se)+ #' set.seed(2) |
|||
| 187 | +474 |
-
+ #' rsp <- sample(c(TRUE, FALSE), 100, TRUE) |
||
| 188 | -1140x | +|||
| 475 | +
- mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE)+ #' grp <- sample(c("Placebo", "Treatment"), 100, TRUE)
|
|||
| 189 | -1140x | +|||
| 476 | +
- y$mean_ci <- formatters::with_label(mean_ci, paste("Mean", f_conf_level(control$conf_level)))
+ #' grp <- factor(grp, levels = c("Placebo", "Treatment"))
|
|||
| 190 | +477 |
-
+ #' strata_data <- data.frame( |
||
| 191 | -1140x | +|||
| 478 | +
- mean_sei <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE) / sqrt(y$n)+ #' "f1" = sample(c("a", "b"), 100, TRUE),
|
|||
| 192 | -1140x | +|||
| 479 | +
- names(mean_sei) <- c("mean_sei_lwr", "mean_sei_upr")
+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
|||
| 193 | -1140x | +|||
| 480 | +
- y$mean_sei <- formatters::with_label(mean_sei, "Mean -/+ 1xSE")+ #' stringsAsFactors = TRUE |
|||
| 194 | +481 |
-
+ #' ) |
||
| 195 | -1140x | +|||
| 482 | +
- mean_sdi <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE)+ #' |
|||
| 196 | -1140x | +|||
| 483 | +
- names(mean_sdi) <- c("mean_sdi_lwr", "mean_sdi_upr")
+ #' prop_diff_cmh( |
|||
| 197 | -1140x | +|||
| 484 | +
- y$mean_sdi <- formatters::with_label(mean_sdi, "Mean -/+ 1xSD")+ #' rsp = rsp, grp = grp, strata = interaction(strata_data), |
|||
| 198 | -1140x | +|||
| 485 | +
- mean_ci_3d <- c(y$mean, y$mean_ci)+ #' conf_level = 0.90 |
|||
| 199 | -1140x | +|||
| 486 | +
- y$mean_ci_3d <- formatters::with_label(mean_ci_3d, paste0("Mean (", f_conf_level(control$conf_level), ")"))
+ #' ) |
|||
| 200 | +487 |
-
+ #' |
||
| 201 | -1140x | +|||
| 488 | +
- mean_pval <- stat_mean_pval(x, test_mean = control$test_mean, na.rm = FALSE, n_min = 2)+ #' @export |
|||
| 202 | -1140x | +|||
| 489 | +
- y$mean_pval <- formatters::with_label(mean_pval, paste("Mean", f_pval(control$test_mean)))
+ prop_diff_cmh <- function(rsp, |
|||
| 203 | +490 |
-
+ grp, |
||
| 204 | -1140x | +|||
| 491 | +
- y$median <- c("median" = stats::median(x, na.rm = FALSE))
+ strata, |
|||
| 205 | +492 |
-
+ conf_level = 0.95) {
|
||
| 206 | -1140x | +493 | +8x |
- y$mad <- c("mad" = stats::median(x - y$median, na.rm = FALSE))
+ grp <- as_factor_keep_attributes(grp) |
| 207 | -+ | |||
| 494 | +8x |
-
+ strata <- as_factor_keep_attributes(strata) |
||
| 208 | -1140x | +495 | +8x |
- median_ci <- stat_median_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE)+ check_diff_prop_ci( |
| 209 | -1140x | +496 | +8x |
- y$median_ci <- formatters::with_label(median_ci, paste("Median", f_conf_level(control$conf_level)))
+ rsp = rsp, grp = grp, conf_level = conf_level, strata = strata |
| 210 | +497 | ++ |
+ )+ |
+ |
| 498 | ||||
| 211 | -1140x | +499 | +8x |
- median_ci_3d <- c(y$median, median_ci)+ if (any(tapply(rsp, strata, length) < 5)) {
|
| 212 | -1140x | +500 | +1x |
- y$median_ci_3d <- formatters::with_label(median_ci_3d, paste0("Median (", f_conf_level(control$conf_level), ")"))
+ warning("Less than 5 observations in some strata.")
|
| 213 | +501 | ++ |
+ }+ |
+ |
| 502 | ||||
| 214 | -1140x | +|||
| 503 | +
- q <- control$quantiles+ # first dimension: FALSE, TRUE |
|||
| 215 | -1140x | +|||
| 504 | +
- if (any(is.na(x))) {
+ # 2nd dimension: CONTROL, TX |
|||
| 216 | -2x | +|||
| 505 | +
- qnts <- rep(NA_real_, length(q))+ # 3rd dimension: levels of strata |
|||
| 217 | +506 |
- } else {
+ # rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records |
||
| 218 | -1138x | +507 | +8x |
- qnts <- stats::quantile(x, probs = q, type = control$quantile_type, na.rm = FALSE)+ t_tbl <- table( |
| 219 | -+ | |||
| 508 | +8x |
- }+ factor(rsp, levels = c("FALSE", "TRUE")),
|
||
| 220 | -1140x | +509 | +8x |
- names(qnts) <- paste("quantile", q, sep = "_")
+ grp, |
| 221 | -1140x | +510 | +8x |
- y$quantiles <- formatters::with_label(qnts, paste0(paste(paste0(q * 100, "%"), collapse = " and "), "-ile"))+ strata |
| 222 | +511 |
-
+ ) |
||
| 223 | -1140x | +512 | +8x |
- y$iqr <- c("iqr" = ifelse(
+ n1 <- colSums(t_tbl[1:2, 1, ]) |
| 224 | -1140x | +513 | +8x |
- any(is.na(x)),+ n2 <- colSums(t_tbl[1:2, 2, ]) |
| 225 | -1140x | +514 | +8x |
- NA_real_,+ p1 <- t_tbl[2, 1, ] / n1 |
| 226 | -1140x | +515 | +8x |
- stats::IQR(x, na.rm = FALSE, type = control$quantile_type)+ p2 <- t_tbl[2, 2, ] / n2 |
| 227 | +516 |
- ))+ # CMH weights |
||
| 228 | -+ | |||
| 517 | +8x |
-
+ use_stratum <- (n1 > 0) & (n2 > 0) |
||
| 229 | -1140x | +518 | +8x |
- y$range <- stats::setNames(range_noinf(x, na.rm = FALSE), c("min", "max"))
+ n1 <- n1[use_stratum] |
| 230 | -1140x | +519 | +8x |
- y$min <- y$range[1]+ n2 <- n2[use_stratum] |
| 231 | -1140x | +520 | +8x |
- y$max <- y$range[2]+ p1 <- p1[use_stratum] |
| 232 | -+ | |||
| 521 | +8x |
-
+ p2 <- p2[use_stratum] |
||
| 233 | -1140x | +522 | +8x |
- y$median_range <- formatters::with_label(c(y$median, y$range), "Median (Min - Max)")+ wt <- (n1 * n2 / (n1 + n2)) |
| 234 | -+ | |||
| 523 | +8x |
-
+ wt_normalized <- wt / sum(wt) |
||
| 235 | -1140x | +524 | +8x |
- y$cv <- c("cv" = unname(y$sd) / unname(y$mean) * 100)
+ est1 <- sum(wt_normalized * p1) |
| 236 | -+ | |||
| 525 | +8x |
-
+ est2 <- sum(wt_normalized * p2) |
||
| 237 | -+ | |||
| 526 | +8x |
- # Convert negative values to NA for log calculation.+ estimate <- c(est1, est2) |
||
| 238 | -1140x | +527 | +8x |
- x_no_negative_vals <- x+ names(estimate) <- levels(grp) |
| 239 | -1140x | +528 | +8x |
- x_no_negative_vals[x_no_negative_vals <= 0] <- NA+ se1 <- sqrt(sum(wt_normalized^2 * p1 * (1 - p1) / n1)) |
| 240 | -1140x | +529 | +8x |
- y$geom_mean <- c("geom_mean" = exp(mean(log(x_no_negative_vals), na.rm = FALSE)))
+ se2 <- sqrt(sum(wt_normalized^2 * p2 * (1 - p2) / n2)) |
| 241 | -1140x | +530 | +8x |
- geom_mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE, geom_mean = TRUE)+ z <- stats::qnorm((1 + conf_level) / 2) |
| 242 | -1140x | +531 | +8x |
- y$geom_mean_ci <- formatters::with_label(geom_mean_ci, paste("Geometric Mean", f_conf_level(control$conf_level)))
+ err1 <- z * se1 |
| 243 | -+ | |||
| 532 | +8x |
-
+ err2 <- z * se2 |
||
| 244 | -1140x | +533 | +8x |
- y$geom_cv <- c("geom_cv" = sqrt(exp(stats::sd(log(x_no_negative_vals), na.rm = FALSE) ^ 2) - 1) * 100) # styler: off
+ ci1 <- c((est1 - err1), (est1 + err1)) |
| 245 | -+ | |||
| 534 | +8x |
-
+ ci2 <- c((est2 - err2), (est2 + err2)) |
||
| 246 | -1140x | +535 | +8x |
- geom_mean_ci_3d <- c(y$geom_mean, y$geom_mean_ci)+ estimate_ci <- list(ci1, ci2) |
| 247 | -1140x | +536 | +8x |
- y$geom_mean_ci_3d <- formatters::with_label(+ names(estimate_ci) <- levels(grp) |
| 248 | -1140x | +537 | +8x |
- geom_mean_ci_3d,+ diff_est <- est2 - est1 |
| 249 | -1140x | +538 | +8x |
- paste0("Geometric Mean (", f_conf_level(control$conf_level), ")")
+ se_diff <- sqrt(sum(((p1 * (1 - p1) / n1) + (p2 * (1 - p2) / n2)) * wt_normalized^2)) |
| 250 | -+ | |||
| 539 | +8x |
- )+ diff_ci <- c(diff_est - z * se_diff, diff_est + z * se_diff) |
||
| 251 | +540 | |||
| 252 | -- |
- # Compare with reference group- |
- ||
| 253 | -1140x | +541 | +8x |
- if (isTRUE(compare_with_ref_group)) {
+ list( |
| 254 | -13x | +542 | +8x |
- .ref_group <- args_list[[".ref_group"]]+ prop = estimate, |
| 255 | -13x | +543 | +8x |
- .in_ref_col <- args_list[[".in_ref_col"]]+ prop_ci = estimate_ci, |
| 256 | -13x | +544 | +8x |
- checkmate::assert_numeric(.ref_group)+ diff = diff_est, |
| 257 | -13x | -
- checkmate::assert_flag(.in_ref_col)- |
- ||
| 258 | -+ | 545 | +8x |
-
+ diff_ci = diff_ci, |
| 259 | -13x | +546 | +8x |
- y$pval <- character()+ weights = wt_normalized, |
| 260 | -13x | +547 | +8x |
- if (!.in_ref_col && n_available(x) > 1 && n_available(.ref_group) > 1) {
+ n1 = n1, |
| 261 | -9x | +548 | +8x |
- y$pval <- stats::t.test(x, .ref_group)$p.value+ n2 = n2 |
| 262 | +549 |
- }+ ) |
||
| 263 | +550 |
- }+ } |
||
| 264 | +551 | |||
| 265 | -1140x | +|||
| 552 | +
- y+ #' @describeIn h_prop_diff Calculates the stratified Newcombe confidence interval and difference in response |
|||
| 266 | +553 |
- }+ #' rates between the experimental treatment group and the control treatment group, adjusted for stratification |
||
| 267 | +554 |
-
+ #' factors. This implementation follows closely the one proposed by \insertCite{Yan2010-jt;textual}{tern}.
|
||
| 268 | +555 |
- #' @describeIn analyze_variables Method for `factor` class.+ #' Weights can be estimated from the heuristic proposed in [prop_strat_wilson()] or from CMH-derived weights |
||
| 269 | +556 |
- #'+ #' (see [prop_diff_cmh()]). |
||
| 270 | +557 |
- #' @return+ #' |
||
| 271 | +558 |
- #' * If `x` is of class `factor` or converted from `character`, returns a `list` with named `numeric` items:+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`. |
||
| 272 | +559 |
- #' * `n`: The [length()] of `x`.+ #' @param weights_method (`string`)\cr weights method. Can be either `"cmh"` or `"heuristic"` |
||
| 273 | +560 |
- #' * `count`: A list with the number of cases for each level of the factor `x`.+ #' and directs the way weights are estimated. |
||
| 274 | +561 |
- #' * `count_fraction`: Similar to `count` but also includes the proportion of cases for each level of the+ #' |
||
| 275 | +562 |
- #' factor `x` relative to the denominator, or `NA` if the denominator is zero.+ #' @references |
||
| 276 | +563 |
- #'+ #' \insertRef{Yan2010-jt}{tern}
|
||
| 277 | +564 |
- #' @note+ #' |
||
| 278 | +565 |
- #' * If `x` is an empty `factor`, a list is still returned for `counts` with one element+ #' @examples |
||
| 279 | +566 |
- #' per factor level. If there are no levels in `x`, the function fails.+ #' # Stratified Newcombe confidence interval |
||
| 280 | +567 |
- #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values+ #' |
||
| 281 | +568 |
- #' set `na_rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit+ #' set.seed(2) |
||
| 282 | +569 |
- #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the+ #' data_set <- data.frame( |
||
| 283 | +570 |
- #' default `na_level` (`"<Missing>"`) will also be excluded when `na_rm` is set to `TRUE`.+ #' "rsp" = sample(c(TRUE, FALSE), 100, TRUE), |
||
| 284 | +571 |
- #'+ #' "f1" = sample(c("a", "b"), 100, TRUE),
|
||
| 285 | +572 |
- #' @method s_summary factor+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
||
| 286 | +573 |
- #'+ #' "grp" = sample(c("Placebo", "Treatment"), 100, TRUE),
|
||
| 287 | +574 |
- #' @examples+ #' stringsAsFactors = TRUE |
||
| 288 | +575 |
- #' # `s_summary.factor`+ #' ) |
||
| 289 | +576 |
#' |
||
| 290 | +577 |
- #' ## Basic usage:+ #' prop_diff_strat_nc( |
||
| 291 | +578 |
- #' s_summary(factor(c("a", "a", "b", "c", "a")))
+ #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]), |
||
| 292 | +579 |
- #'+ #' weights_method = "cmh", |
||
| 293 | +580 |
- #' # Empty factor returns zero-filled items.+ #' conf_level = 0.90 |
||
| 294 | +581 |
- #' s_summary(factor(levels = c("a", "b", "c")))
+ #' ) |
||
| 295 | +582 |
#' |
||
| 296 | +583 |
- #' ## Management of NA values.+ #' prop_diff_strat_nc( |
||
| 297 | +584 |
- #' x <- factor(c(NA, "Female"))+ #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]), |
||
| 298 | +585 |
- #' x <- explicit_na(x)+ #' weights_method = "wilson_h", |
||
| 299 | +586 |
- #' s_summary(x, na_rm = TRUE)+ #' conf_level = 0.90 |
||
| 300 | +587 |
- #' s_summary(x, na_rm = FALSE)+ #' ) |
||
| 301 | +588 |
#' |
||
| 302 | +589 |
- #' ## Different denominators.+ #' @export |
||
| 303 | +590 |
- #' x <- factor(c("a", "a", "b", "c", "a"))
+ prop_diff_strat_nc <- function(rsp, |
||
| 304 | +591 |
- #' s_summary(x, denom = "N_row", .N_row = 10L)+ grp, |
||
| 305 | +592 |
- #' s_summary(x, denom = "N_col", .N_col = 20L)+ strata, |
||
| 306 | +593 |
- #'+ weights_method = c("cmh", "wilson_h"),
|
||
| 307 | +594 |
- #' @export+ conf_level = 0.95, |
||
| 308 | +595 |
- s_summary.factor <- function(x, denom = c("n", "N_col", "N_row"), ...) {
- |
- ||
| 309 | -304x | -
- assert_valid_factor(x)- |
- ||
| 310 | -301x | -
- args_list <- list(...)+ correct = FALSE) {
|
||
| 311 | -301x | +596 | +4x |
- .N_row <- args_list[[".N_row"]] # nolint+ weights_method <- match.arg(weights_method) |
| 312 | -301x | +597 | +4x |
- .N_col <- args_list[[".N_col"]] # nolint+ grp <- as_factor_keep_attributes(grp) |
| 313 | -301x | +598 | +4x |
- na_rm <- args_list[["na_rm"]] %||% TRUE+ strata <- as_factor_keep_attributes(strata) |
| 314 | -301x | +599 | +4x |
- verbose <- args_list[["verbose"]] %||% TRUE+ check_diff_prop_ci( |
| 315 | -301x | +600 | +4x |
- compare_with_ref_group <- args_list[["compare_with_ref_group"]]+ rsp = rsp, grp = grp, conf_level = conf_level, strata = strata |
| 316 | +601 |
-
+ ) |
||
| 317 | -301x | +602 | +4x |
- if (na_rm) {
+ checkmate::assert_number(conf_level, lower = 0, upper = 1) |
| 318 | -292x | +603 | +4x |
- x <- x[!is.na(x)] %>% fct_discard("<Missing>")
+ checkmate::assert_flag(correct) |
| 319 | -+ | |||
| 604 | +4x |
- } else {
+ if (any(tapply(rsp, strata, length) < 5)) {
|
||
| 320 | -9x | +|||
| 605 | +! |
- x <- x %>% explicit_na(label = "NA")+ warning("Less than 5 observations in some strata.")
|
||
| 321 | +606 |
} |
||
| 322 | +607 | |||
| 323 | -301x | -
- y <- list()- |
- ||
| 324 | -+ | 608 | +4x |
-
+ rsp_by_grp <- split(rsp, f = grp) |
| 325 | -301x | +609 | +4x |
- y$n <- list("n" = c("n" = length(x))) # all list of a list
+ strata_by_grp <- split(strata, f = grp) |
| 326 | +610 | |||
| 327 | -301x | -
- y$count <- lapply(as.list(table(x, useNA = "ifany")), setNames, nm = "count")- |
- ||
| 328 | +611 | - - | -||
| 329 | -301x | -
- denom <- match.arg(denom) %>%+ # Finding the weights |
||
| 330 | -301x | +612 | +4x |
- switch(+ weights <- if (identical(weights_method, "cmh")) {
|
| 331 | -301x | +613 | +3x |
- n = length(x),+ prop_diff_cmh(rsp = rsp, grp = grp, strata = strata)$weights |
| 332 | -301x | +614 | +4x |
- N_row = .N_row,+ } else if (identical(weights_method, "wilson_h")) {
|
| 333 | -301x | -
- N_col = .N_col- |
- ||
| 334 | -+ | 615 | +1x |
- )+ prop_strat_wilson(rsp, strata, conf_level = conf_level, correct = correct)$weights |
| 335 | +616 | - - | -||
| 336 | -301x | -
- y$count_fraction <- lapply(- |
- ||
| 337 | -301x | -
- y$count,- |
- ||
| 338 | -301x | -
- function(x) {
+ } |
||
| 339 | -2182x | -
- c(x, "p" = ifelse(denom > 0, x / denom, 0))- |
- ||
| 340 | -+ | 617 | +4x |
- }+ weights[levels(strata)[!levels(strata) %in% names(weights)]] <- 0 |
| 341 | +618 |
- )+ |
||
| 342 | +619 |
-
+ # Calculating lower (`l`) and upper (`u`) confidence bounds per group. |
||
| 343 | -301x | -
- y$count_fraction_fixed_dp <- y$count_fraction- |
- ||
| 344 | -+ | 620 | +4x |
-
+ strat_wilson_by_grp <- Map( |
| 345 | -301x | +621 | +4x |
- y$fraction <- lapply(+ prop_strat_wilson, |
| 346 | -301x | +622 | +4x |
- y$count,+ rsp = rsp_by_grp, |
| 347 | -301x | +623 | +4x |
- function(count) c("num" = unname(count), "denom" = denom)
+ strata = strata_by_grp, |
| 348 | -+ | |||
| 624 | +4x |
- )+ weights = list(weights, weights), |
||
| 349 | -+ | |||
| 625 | +4x |
-
+ conf_level = conf_level, |
||
| 350 | -301x | +626 | +4x |
- y$n_blq <- list("n_blq" = c("n_blq" = sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", x))))
+ correct = correct |
| 351 | +627 |
-
+ ) |
||
| 352 | +628 | |||
| 353 | -301x | +629 | +4x |
- if (isTRUE(compare_with_ref_group)) {
+ ci_ref <- strat_wilson_by_grp[[1]] |
| 354 | -16x | +630 | +4x |
- .ref_group <- as_factor_keep_attributes(args_list[[".ref_group"]], verbose = verbose)+ ci_trt <- strat_wilson_by_grp[[2]] |
| 355 | -16x | +631 | +4x |
- .in_ref_col <- args_list[[".in_ref_col"]]+ l_ref <- as.numeric(ci_ref$conf_int[1]) |
| 356 | -16x | +632 | +4x |
- checkmate::assert_flag(.in_ref_col)+ u_ref <- as.numeric(ci_ref$conf_int[2]) |
| 357 | -16x | +633 | +4x |
- assert_valid_factor(x)+ l_trt <- as.numeric(ci_trt$conf_int[1]) |
| 358 | -16x | +634 | +4x |
- assert_valid_factor(.ref_group)+ u_trt <- as.numeric(ci_trt$conf_int[2]) |
| 359 | +635 | |||
| 360 | -16x | +|||
| 636 | +
- if (na_rm) {
+ # Estimating the diff and n_ref, n_trt (it allows different weights to be used) |
|||
| 361 | -14x | +637 | +4x |
- x <- x[!is.na(x)] %>% fct_discard("<Missing>")
+ t_tbl <- table( |
| 362 | -14x | -
- .ref_group <- .ref_group[!is.na(.ref_group)] %>% fct_discard("<Missing>")
- |
- ||
| 363 | -+ | 638 | +4x |
- } else {
+ factor(rsp, levels = c("FALSE", "TRUE")),
|
| 364 | -2x | +639 | +4x |
- x <- x %>% explicit_na(label = "NA")+ grp, |
| 365 | -2x | +640 | +4x |
- .ref_group <- .ref_group %>% explicit_na(label = "NA")+ strata |
| 366 | +641 |
- }+ ) |
||
| 367 | -+ | |||
| 642 | +4x |
-
+ n_ref <- colSums(t_tbl[1:2, 1, ]) |
||
| 368 | -1x | +643 | +4x |
- if ("NA" %in% levels(x)) levels(.ref_group) <- c(levels(.ref_group), "NA")
+ n_trt <- colSums(t_tbl[1:2, 2, ]) |
| 369 | -16x | +644 | +4x |
- checkmate::assert_factor(x, levels = levels(.ref_group), min.levels = 2)+ use_stratum <- (n_ref > 0) & (n_trt > 0) |
| 370 | -+ | |||
| 645 | +4x |
-
+ n_ref <- n_ref[use_stratum] |
||
| 371 | -16x | +646 | +4x |
- y$pval_counts <- character()+ n_trt <- n_trt[use_stratum] |
| 372 | -16x | +647 | +4x |
- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
+ p_ref <- t_tbl[2, 1, use_stratum] / n_ref |
| 373 | -13x | +648 | +4x |
- tab <- rbind(table(x), table(.ref_group))+ p_trt <- t_tbl[2, 2, use_stratum] / n_trt |
| 374 | -13x | +649 | +4x |
- res <- suppressWarnings(stats::chisq.test(tab))+ est1 <- sum(weights * p_ref) |
| 375 | -13x | +650 | +4x |
- y$pval_counts <- res$p.value+ est2 <- sum(weights * p_trt) |
| 376 | -+ | |||
| 651 | +4x |
- }+ diff_est <- est2 - est1 |
||
| 377 | +652 |
- }+ |
||
| 378 | -+ | |||
| 653 | +4x |
-
+ lambda1 <- sum(weights^2 / n_ref) |
||
| 379 | -301x | +654 | +4x |
- y+ lambda2 <- sum(weights^2 / n_trt) |
| 380 | -+ | |||
| 655 | +4x |
- }+ z <- stats::qnorm((1 + conf_level) / 2) |
||
| 381 | +656 | |||
| 382 | -+ | |||
| 657 | +4x |
- #' @describeIn analyze_variables Method for `character` class. This makes an automatic+ lower <- diff_est - z * sqrt(lambda2 * l_trt * (1 - l_trt) + lambda1 * u_ref * (1 - u_ref)) |
||
| 383 | -+ | |||
| 658 | +4x |
- #' conversion to factor (with a warning) and then forwards to the method for factors.+ upper <- diff_est + z * sqrt(lambda1 * l_ref * (1 - l_ref) + lambda2 * u_trt * (1 - u_trt)) |
||
| 384 | +659 |
- #'+ |
||
| 385 | -+ | |||
| 660 | +4x |
- #' @note+ list( |
||
| 386 | -+ | |||
| 661 | +4x |
- #' * Automatic conversion of character to factor does not guarantee that the table+ "diff" = diff_est,+ |
+ ||
| 662 | +4x | +
+ "diff_ci" = c("lower" = lower, "upper" = upper)
|
||
| 387 | +663 |
- #' can be generated correctly. In particular for sparse tables this very likely can fail.+ ) |
||
| 388 | +664 |
- #' It is therefore better to always pre-process the dataset such that factors are manually+ } |
| 389 | +1 |
- #' created from character variables before passing the dataset to [rtables::build_table()].+ #' Count specific values |
||
| 390 | +2 |
#' |
||
| 391 | +3 |
- #' @method s_summary character+ #' @description `r lifecycle::badge("stable")`
|
||
| 392 | +4 |
#' |
||
| 393 | +5 |
- #' @examples+ #' The analyze function [count_values()] creates a layout element to calculate counts of specific values within a |
||
| 394 | +6 |
- #' # `s_summary.character`+ #' variable of interest. |
||
| 395 | +7 |
#' |
||
| 396 | +8 |
- #' ## Basic usage:+ #' This function analyzes one or more variables of interest supplied as a vector to `vars`. Values to |
||
| 397 | +9 |
- #' s_summary(c("a", "a", "b", "c", "a"), verbose = FALSE)
+ #' count for variable(s) in `vars` can be given as a vector via the `values` argument. One row of |
||
| 398 | +10 |
- #' s_summary(c("a", "a", "b", "c", "a", ""), .var = "x", na_rm = FALSE, verbose = FALSE)
+ #' counts will be generated for each variable. |
||
| 399 | +11 |
#' |
||
| 400 | +12 |
- #' @export+ #' @inheritParams argument_convention |
||
| 401 | +13 |
- s_summary.character <- function(x, denom = c("n", "N_col", "N_row"), ...) {
- |
- ||
| 402 | -12x | -
- args_list <- list(...)- |
- ||
| 403 | -12x | -
- na_rm <- args_list[["na_rm"]] %||% TRUE- |
- ||
| 404 | -12x | -
- verbose <- args_list[["verbose"]] %||% TRUE+ #' @param values (`character`)\cr specific values that should be counted. |
||
| 405 | +14 | - - | -||
| 406 | -12x | -
- if (na_rm) {
- |
- ||
| 407 | -11x | -
- y <- as_factor_keep_attributes(x, verbose = verbose)+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 408 | +15 |
- } else {
- |
- ||
| 409 | -1x | -
- y <- as_factor_keep_attributes(x, verbose = verbose, na_level = "NA")+ #' |
||
| 410 | +16 |
- }+ #' Options are: ``r shQuote(get_stats("count_values"), type = "sh")``
|
||
| 411 | +17 |
-
+ #' |
||
| 412 | -12x | +|||
| 18 | +
- s_summary(x = y, denom = denom, ...)+ #' @note |
|||
| 413 | +19 |
- }+ #' * For `factor` variables, `s_count_values` checks whether `values` are all included in the levels of `x` |
||
| 414 | +20 |
-
+ #' and fails otherwise. |
||
| 415 | +21 |
- #' @describeIn analyze_variables Method for `logical` class.+ #' * For `count_values()`, variable labels are shown when there is more than one element in `vars`, |
||
| 416 | +22 |
- #'+ #' otherwise they are hidden. |
||
| 417 | +23 |
- #' @return+ #' |
||
| 418 | +24 |
- #' * If `x` is of class `logical`, returns a `list` with named `numeric` items:+ #' @name count_values |
||
| 419 | +25 |
- #' * `n`: The [length()] of `x` (possibly after removing `NA`s).+ #' @order 1 |
||
| 420 | +26 |
- #' * `count`: Count of `TRUE` in `x`.+ NULL |
||
| 421 | +27 |
- #' * `count_fraction`: Count and proportion of `TRUE` in `x` relative to the denominator, or `NA` if the+ |
||
| 422 | +28 |
- #' denominator is zero. Note that `NA`s in `x` are never counted or leading to `NA` here.+ #' @describeIn count_values S3 generic function to count values. |
||
| 423 | +29 |
#' |
||
| 424 | +30 |
- #' @method s_summary logical+ #' @inheritParams s_summary.logical |
||
| 425 | +31 |
#' |
||
| 426 | +32 |
- #' @examples+ #' @return |
||
| 427 | +33 |
- #' # `s_summary.logical`+ #' * `s_count_values()` returns output of [s_summary()] for specified values of a non-numeric variable. |
||
| 428 | +34 |
#' |
||
| 429 | +35 |
- #' ## Basic usage:+ #' @export |
||
| 430 | +36 |
- #' s_summary(c(TRUE, FALSE, TRUE, TRUE))+ s_count_values <- function(x, |
||
| 431 | +37 |
- #'+ values, |
||
| 432 | +38 |
- #' # Empty factor returns zero-filled items.+ na.rm = TRUE, # nolint |
||
| 433 | +39 |
- #' s_summary(as.logical(c()))+ denom = c("n", "N_col", "N_row"),
|
||
| 434 | +40 |
- #'+ ...) {
|
||
| 435 | -+ | |||
| 41 | +207x |
- #' ## Management of NA values.+ UseMethod("s_count_values", x)
|
||
| 436 | +42 |
- #' x <- c(NA, TRUE, FALSE)+ } |
||
| 437 | +43 |
- #' s_summary(x, na_rm = TRUE)+ |
||
| 438 | +44 |
- #' s_summary(x, na_rm = FALSE)+ #' @describeIn count_values Method for `character` class. |
||
| 439 | +45 |
#' |
||
| 440 | +46 |
- #' ## Different denominators.+ #' @method s_count_values character |
||
| 441 | +47 |
- #' x <- c(TRUE, FALSE, TRUE, TRUE)+ #' |
||
| 442 | +48 |
- #' s_summary(x, denom = "N_row", .N_row = 10L)+ #' @examples |
||
| 443 | +49 |
- #' s_summary(x, denom = "N_col", .N_col = 20L)+ #' # `s_count_values.character` |
||
| 444 | +50 |
- #'+ #' s_count_values(x = c("a", "b", "a"), values = "a")
|
||
| 445 | +51 |
- #' @export+ #' s_count_values(x = c("a", "b", "a", NA, NA), values = "b", na.rm = FALSE)
|
||
| 446 | +52 |
- s_summary.logical <- function(x, denom = c("n", "N_col", "N_row"), ...) {
+ #' |
||
| 447 | -211x | +|||
| 53 | +
- checkmate::assert_logical(x)+ #' @export |
|||
| 448 | -211x | +|||
| 54 | +
- args_list <- list(...)+ s_count_values.character <- function(x, |
|||
| 449 | -211x | +|||
| 55 | +
- .N_row <- args_list[[".N_row"]] # nolint+ values = "Y", |
|||
| 450 | -211x | +|||
| 56 | +
- .N_col <- args_list[[".N_col"]] # nolint+ na.rm = TRUE, # nolint |
|||
| 451 | -211x | +|||
| 57 | +
- na_rm <- args_list[["na_rm"]] %||% TRUE+ ...) {
|
|||
| 452 | -211x | +58 | +200x |
- compare_with_ref_group <- args_list[["compare_with_ref_group"]]+ checkmate::assert_character(values) |
| 453 | +59 | |||
| 454 | -211x | +60 | +200x |
- if (na_rm) {
+ if (na.rm) {
|
| 455 | -208x | +61 | +199x |
x <- x[!is.na(x)] |
| 456 | +62 |
} |
||
| 457 | +63 | |||
| 458 | -211x | +64 | +200x |
- y <- list()+ is_in_values <- x %in% values |
| 459 | -211x | +|||
| 65 | +
- y$n <- c("n" = length(x))
+
|
|||
| 460 | -211x | +66 | +200x |
- denom <- match.arg(denom) %>%+ s_summary(is_in_values, na_rm = na.rm, ...) |
| 461 | -211x | +|||
| 67 | +
- switch(+ } |
|||
| 462 | -211x | +|||
| 68 | +
- n = length(x),+ |
|||
| 463 | -211x | +|||
| 69 | +
- N_row = .N_row,+ #' @describeIn count_values Method for `factor` class. This makes an automatic |
|||
| 464 | -211x | +|||
| 70 | +
- N_col = .N_col+ #' conversion to `character` and then forwards to the method for characters. |
|||
| 465 | +71 |
- )+ #' |
||
| 466 | -211x | +|||
| 72 | +
- y$count <- c("count" = sum(x, na.rm = TRUE))
+ #' @method s_count_values factor |
|||
| 467 | -211x | +|||
| 73 | +
- y$count_fraction <- c(y$count, "fraction" = ifelse(denom > 0, y$count / denom, 0))+ #' |
|||
| 468 | -211x | +|||
| 74 | +
- y$count_fraction_fixed_dp <- y$count_fraction+ #' @examples |
|||
| 469 | -211x | +|||
| 75 | +
- y$fraction <- c("num" = unname(y$count), "denom" = denom)
+ #' # `s_count_values.factor` |
|||
| 470 | -211x | +|||
| 76 | +
- y$n_blq <- c("n_blq" = 0L)
+ #' s_count_values(x = factor(c("a", "b", "a")), values = "a")
|
|||
| 471 | +77 |
-
+ #' |
||
| 472 | +78 |
-
+ #' @export |
||
| 473 | -211x | +|||
| 79 | +
- if (isTRUE(compare_with_ref_group)) {
+ s_count_values.factor <- function(x, |
|||
| 474 | -4x | +|||
| 80 | +
- .ref_group <- args_list[[".ref_group"]]+ values = "Y", |
|||
| 475 | -4x | +|||
| 81 | +
- .in_ref_col <- args_list[[".in_ref_col"]]+ ...) {
|
|||
| 476 | +82 | 4x |
- checkmate::assert_flag(.in_ref_col)+ s_count_values(as.character(x), values = as.character(values), ...) |
|
| 477 | +83 | - - | -||
| 478 | -4x | -
- if (na_rm) {
+ } |
||
| 479 | -3x | +|||
| 84 | +
- x <- stats::na.omit(x)+ |
|||
| 480 | -3x | +|||
| 85 | +
- .ref_group <- stats::na.omit(.ref_group)+ #' @describeIn count_values Method for `logical` class. |
|||
| 481 | +86 |
- } else {
+ #' |
||
| 482 | -1x | +|||
| 87 | +
- x[is.na(x)] <- FALSE+ #' @method s_count_values logical |
|||
| 483 | -1x | +|||
| 88 | +
- .ref_group[is.na(.ref_group)] <- FALSE+ #' |
|||
| 484 | +89 |
- }+ #' @examples |
||
| 485 | +90 |
-
+ #' # `s_count_values.logical` |
||
| 486 | -4x | +|||
| 91 | +
- y$pval_counts <- character()+ #' s_count_values(x = c(TRUE, FALSE, TRUE)) |
|||
| 487 | -4x | +|||
| 92 | +
- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
+ #' |
|||
| 488 | -4x | +|||
| 93 | +
- x <- factor(x, levels = c(TRUE, FALSE))+ #' @export |
|||
| 489 | -4x | +|||
| 94 | +
- .ref_group <- factor(.ref_group, levels = c(TRUE, FALSE))+ s_count_values.logical <- function(x, values = TRUE, ...) {
|
|||
| 490 | -4x | +95 | +3x |
- tbl <- rbind(table(x), table(.ref_group))+ checkmate::assert_logical(values) |
| 491 | -4x | +96 | +3x |
- y$pval_counts <- suppressWarnings(prop_chisq(tbl))+ s_count_values(as.character(x), values = as.character(values), ...) |
| 492 | +97 |
- }+ } |
||
| 493 | +98 |
- }+ |
||
| 494 | +99 | - - | -||
| 495 | -211x | -
- y+ #' @describeIn count_values Formatted analysis function which is used as `afun` |
||
| 496 | +100 |
- }+ #' in `count_values()`. |
||
| 497 | +101 |
-
+ #' |
||
| 498 | +102 |
- #' @describeIn analyze_variables Formatted analysis function which is used as `afun` in `analyze_vars()` and+ #' @return |
||
| 499 | +103 |
- #' `compare_vars()` and as `cfun` in `summarize_colvars()`.+ #' * `a_count_values()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 500 | +104 |
#' |
||
| 501 | +105 |
- #' @param compare_with_ref_group (`flag`)\cr whether comparison statistics should be analyzed instead of summary+ #' @examples |
||
| 502 | +106 |
- #' statistics (`compare_with_ref_group = TRUE` adds `pval` statistic comparing+ #' # `a_count_values` |
||
| 503 | +107 |
- #' against reference group).+ #' a_count_values(x = factor(c("a", "b", "a")), values = "a", .N_col = 10, .N_row = 10)
|
||
| 504 | +108 |
#' |
||
| 505 | +109 |
- #' @return+ #' @export |
||
| 506 | +110 |
- #' * `a_summary()` returns the corresponding list with formatted [rtables::CellValue()].+ a_count_values <- function(x, |
||
| 507 | +111 |
- #'+ ..., |
||
| 508 | +112 |
- #' @note+ .stats = NULL, |
||
| 509 | +113 |
- #' * To use for comparison (with additional p-value statistic), parameter+ .stat_names = NULL, |
||
| 510 | +114 |
- #' `compare_with_ref_group` must be set to `TRUE`.+ .formats = NULL, |
||
| 511 | +115 |
- #' * Ensure that either all `NA` values are converted to an explicit `NA` level or all `NA` values are left as is.+ .labels = NULL, |
||
| 512 | +116 |
- #'+ .indent_mods = NULL) {
|
||
| 513 | -+ | |||
| 117 | +17x |
- #' @examples+ dots_extra_args <- list(...) |
||
| 514 | +118 |
- #' a_summary(factor(c("a", "a", "b", "c", "a")), .N_row = 10, .N_col = 10)
+
|
||
| 515 | +119 |
- #' a_summary(+ # Check for user-defined functions |
||
| 516 | -+ | |||
| 120 | +17x |
- #' factor(c("a", "a", "b", "c", "a")),
+ default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) |
||
| 517 | -+ | |||
| 121 | +17x |
- #' .ref_group = factor(c("a", "a", "b", "c")), compare_with_ref_group = TRUE, .in_ref_col = TRUE
+ .stats <- default_and_custom_stats_list$default_stats |
||
| 518 | -+ | |||
| 122 | +17x |
- #' )+ custom_stat_functions <- default_and_custom_stats_list$custom_stats |
||
| 519 | +123 |
- #'+ |
||
| 520 | +124 |
- #' a_summary(c("A", "B", "A", "C"), .var = "x", .N_col = 10, .N_row = 10, verbose = FALSE)
+ # Add extra parameters to the s_* function |
||
| 521 | -+ | |||
| 125 | +17x |
- #' a_summary(+ extra_afun_params <- retrieve_extra_afun_params( |
||
| 522 | -+ | |||
| 126 | +17x |
- #' c("A", "B", "A", "C"),
+ names(dots_extra_args$.additional_fun_parameters) |
||
| 523 | +127 |
- #' .ref_group = c("B", "A", "C"), .var = "x", compare_with_ref_group = TRUE, verbose = FALSE,
+ ) |
||
| 524 | -+ | |||
| 128 | +17x |
- #' .in_ref_col = FALSE+ dots_extra_args$.additional_fun_parameters <- NULL |
||
| 525 | +129 |
- #' )+ |
||
| 526 | +130 |
- #'+ # Main statistic calculations |
||
| 527 | -+ | |||
| 131 | +17x |
- #' a_summary(c(TRUE, FALSE, FALSE, TRUE, TRUE), .N_row = 10, .N_col = 10)+ x_stats <- .apply_stat_functions( |
||
| 528 | -+ | |||
| 132 | +17x |
- #' a_summary(+ default_stat_fnc = s_count_values, |
||
| 529 | -+ | |||
| 133 | +17x |
- #' c(TRUE, FALSE, FALSE, TRUE, TRUE),+ custom_stat_fnc_list = custom_stat_functions, |
||
| 530 | -+ | |||
| 134 | +17x |
- #' .ref_group = c(TRUE, FALSE), .in_ref_col = TRUE, compare_with_ref_group = TRUE,+ args_list = c( |
||
| 531 | -+ | |||
| 135 | +17x |
- #' .in_ref_col = FALSE+ x = list(x), |
||
| 532 | -+ | |||
| 136 | +17x |
- #' )+ extra_afun_params, |
||
| 533 | -+ | |||
| 137 | +17x |
- #'+ dots_extra_args |
||
| 534 | +138 |
- #' a_summary(rnorm(10), .N_col = 10, .N_row = 20, .var = "bla")+ ) |
||
| 535 | +139 |
- #' a_summary(rnorm(10, 5, 1),+ ) |
||
| 536 | +140 |
- #' .ref_group = rnorm(20, -5, 1), .var = "bla", compare_with_ref_group = TRUE,+ |
||
| 537 | +141 |
- #' .in_ref_col = FALSE+ # Fill in formatting defaults |
||
| 538 | -+ | |||
| 142 | +17x |
- #' )+ .stats <- c( |
||
| 539 | -+ | |||
| 143 | +17x |
- #'+ get_stats("analyze_vars_counts", stats_in = .stats),
|
||
| 540 | -+ | |||
| 144 | +17x |
- #' @export+ names(custom_stat_functions) # Additional stats from custom functions |
||
| 541 | +145 |
- a_summary <- function(x,+ )+ |
+ ||
| 146 | +17x | +
+ .formats <- get_formats_from_stats(.stats, .formats)+ |
+ ||
| 147 | +17x | +
+ .labels <- get_labels_from_stats(.stats, .labels)+ |
+ ||
| 148 | +17x | +
+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods) |
||
| 542 | +149 |
- ...,+ + |
+ ||
| 150 | +17x | +
+ x_stats <- x_stats[.stats] |
||
| 543 | +151 |
- .stats = NULL,+ |
||
| 544 | +152 |
- .stat_names_in = NULL,+ # Auto format handling+ |
+ ||
| 153 | +17x | +
+ .formats <- apply_auto_formatting(+ |
+ ||
| 154 | +17x | +
+ .formats,+ |
+ ||
| 155 | +17x | +
+ x_stats,+ |
+ ||
| 156 | +17x | +
+ extra_afun_params$.df_row,+ |
+ ||
| 157 | +17x | +
+ extra_afun_params$.var |
||
| 545 | +158 |
- .formats = NULL,+ ) |
||
| 546 | +159 |
- .labels = NULL,+ |
||
| 547 | +160 |
- .indent_mods = NULL) {
+ # Get and check statistic names from defaults |
||
| 548 | -329x | +161 | +17x |
- dots_extra_args <- list(...)+ .stat_names <- get_stat_names(x_stats, .stat_names) |
| 549 | +162 | |||
| 550 | -+ | |||
| 163 | +17x |
- # Check if there are user-defined functions+ in_rows( |
||
| 551 | -329x | +164 | +17x |
- default_and_custom_stats_list <- .split_std_from_custom_stats(.stats)+ .list = x_stats, |
| 552 | -329x | +165 | +17x |
- .stats <- default_and_custom_stats_list$default_stats+ .formats = .formats, |
| 553 | -329x | +166 | +17x |
- custom_stat_functions <- default_and_custom_stats_list$custom_stats+ .names = names(.labels),+ |
+
| 167 | +17x | +
+ .stat_names = .stat_names,+ |
+ ||
| 168 | +17x | +
+ .labels = .labels %>% .unlist_keep_nulls(),+ |
+ ||
| 169 | +17x | +
+ .indent_mods = .indent_mods %>% .unlist_keep_nulls() |
||
| 554 | +170 |
-
+ ) |
||
| 555 | +171 |
- # Correction of the pval indication if it is numeric or counts+ } |
||
| 556 | -329x | +|||
| 172 | +
- type <- ifelse(is.numeric(x), "numeric", "counts") # counts is "categorical"+ |
|||
| 557 | -329x | +|||
| 173 | +
- .stats <- .correct_num_or_counts_pval(type, .stats)+ #' @describeIn count_values Layout-creating function which can take statistics function arguments |
|||
| 558 | +174 |
-
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 559 | +175 |
- # Adding automatically extra parameters to the statistic function (see ?rtables::additional_fun_params)+ #' |
||
| 560 | -329x | +|||
| 176 | +
- extra_afun_params <- retrieve_extra_afun_params(+ #' @return |
|||
| 561 | -329x | +|||
| 177 | +
- names(dots_extra_args$.additional_fun_parameters)+ #' * `count_values()` returns a layout object suitable for passing to further layouting functions, |
|||
| 562 | +178 |
- )+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 563 | -329x | +|||
| 179 | +
- dots_extra_args$.additional_fun_parameters <- NULL # After extraction we do not need them anymore+ #' the statistics from `s_count_values()` to the table layout. |
|||
| 564 | +180 |
-
+ #' |
||
| 565 | +181 |
- # If one col has NA vals, must add NA row to other cols (using placeholder lvl `fill-na-level`)+ #' @examples |
||
| 566 | -329x | +|||
| 182 | ++ |
+ #' # `count_values`+ |
+ ||
| 183 | +
- if (any(is.na(dots_extra_args$.df_row[[dots_extra_args$.var]])) && !any(is.na(x)) && !dots_extra_args$na_rm) {
+ #' basic_table() %>% |
|||
| 567 | -! | +|||
| 184 | +
- levels(x) <- c(levels(x), "fill-na-level")+ #' count_values("Species", values = "setosa") %>%
|
|||
| 568 | +185 |
- }+ #' build_table(iris) |
||
| 569 | +186 |
-
+ #' |
||
| 570 | +187 |
- # Check if compare_with_ref_group is TRUE but no ref col is set+ #' @export |
||
| 571 | -329x | +|||
| 188 | +
- if (isTRUE(dots_extra_args$compare_with_ref_group) &&+ #' @order 2 |
|||
| 572 | -329x | +|||
| 189 | +
- all(+ count_values <- function(lyt, |
|||
| 573 | -329x | +|||
| 190 | +
- length(dots_extra_args[[".ref_group"]]) == 0, # only used for testing+ vars, |
|||
| 574 | -329x | +|||
| 191 | +
- length(extra_afun_params[[".ref_group"]]) == 0+ values, |
|||
| 575 | +192 |
- )+ na_str = default_na_str(), |
||
| 576 | +193 |
- ) {
+ na_rm = TRUE, |
||
| 577 | -! | +|||
| 194 | +
- stop(+ nested = TRUE, |
|||
| 578 | -! | +|||
| 195 | +
- "For comparison (compare_with_ref_group = TRUE), the reference group must be specified.",+ ..., |
|||
| 579 | -! | +|||
| 196 | +
- "\nSee split_fun in spit_cols_by()."+ table_names = vars, |
|||
| 580 | +197 |
- )+ .stats = "count_fraction", |
||
| 581 | +198 |
- }+ .stat_names = NULL, |
||
| 582 | +199 |
-
+ .formats = c(count_fraction = "xx (xx.xx%)", count = "xx"), |
||
| 583 | +200 |
- # Main statistical functions application+ .labels = c(count_fraction = paste(values, collapse = ", ")), |
||
| 584 | -329x | +|||
| 201 | +
- x_stats <- .apply_stat_functions(+ .indent_mods = NULL) {
|
|||
| 585 | -329x | +|||
| 202 | +
- default_stat_fnc = s_summary,+ # Process extra args |
|||
| 586 | -329x | +203 | +8x |
- custom_stat_fnc_list = custom_stat_functions,+ extra_args <- list("na_rm" = na_rm, "values" = values, ...)
|
| 587 | -329x | +204 | +8x |
- args_list = c(+ if (!is.null(.stats)) extra_args[[".stats"]] <- .stats |
| 588 | -329x | +|||
| 205 | +! |
- x = list(x),+ if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names |
||
| 589 | -329x | +206 | +8x |
- extra_afun_params,+ if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
| 590 | -329x | -
- dots_extra_args- |
- ||
| 591 | -+ | 207 | +8x |
- )+ if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
| 592 | -+ | |||
| 208 | +! |
- )+ if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
||
| 593 | +209 | |||
| 594 | +210 |
- # Fill in with stats defaults if needed+ # Adding additional info from layout to analysis function |
||
| 595 | -329x | +211 | +8x |
- met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) |
| 596 | -329x | +212 | +8x |
- .stats <- c(+ formals(a_count_values) <- c(formals(a_count_values), extra_args[[".additional_fun_parameters"]]) |
| 597 | -329x | +|||
| 213 | +
- get_stats(met_grp,+ |
|||
| 598 | -329x | +214 | +8x |
- stats_in = .stats,+ analyze( |
| 599 | -329x | +215 | +8x |
- add_pval = dots_extra_args$compare_with_ref_group %||% FALSE+ lyt, |
| 600 | -+ | |||
| 216 | +8x |
- ),+ vars, |
||
| 601 | -329x | +217 | +8x |
- names(custom_stat_functions) # Additional stats from custom functions+ afun = a_count_values, |
| 602 | -+ | |||
| 218 | +8x |
- )+ na_str = na_str, |
||
| 603 | -+ | |||
| 219 | +8x |
-
+ nested = nested, |
||
| 604 | -329x | +220 | +8x |
- x_stats <- x_stats[.stats]+ extra_args = extra_args, |
| 605 | -329x | +221 | +8x |
- if (is.character(x) || is.factor(x)) {
+ show_labels = ifelse(length(vars) > 1, "visible", "hidden"), |
| 606 | -236x | +222 | +8x |
- levels_per_stats <- lapply(x_stats, names) # if there is a count is table() with levels+ table_names = table_names |
| 607 | +223 |
- } else {
- |
- ||
| 608 | -93x | -
- levels_per_stats <- NULL+ ) |
||
| 609 | +224 |
- }+ } |
| 610 | +1 |
-
+ #' Count occurrences by grade |
||
| 611 | +2 |
- # Formats checks+ #' |
||
| 612 | -329x | +|||
| 3 | +
- .formats <- get_formats_from_stats(.stats, .formats)+ #' @description `r lifecycle::badge("stable")`
|
|||
| 613 | +4 |
-
+ #' |
||
| 614 | +5 |
- # Auto format handling+ #' The analyze function [count_occurrences_by_grade()] creates a layout element to calculate occurrence counts by grade. |
||
| 615 | -329x | +|||
| 6 | +
- .formats <- apply_auto_formatting(+ #' |
|||
| 616 | -329x | +|||
| 7 | +
- .formats,+ #' This function analyzes primary analysis variable `var` which indicates toxicity grades. The `id` variable |
|||
| 617 | -329x | +|||
| 8 | +
- x_stats,+ #' is used to indicate unique subject identifiers (defaults to `USUBJID`). The user can also supply a list of |
|||
| 618 | -329x | +|||
| 9 | +
- extra_afun_params$.df_row,+ #' custom groups of grades to analyze via the `grade_groups` parameter. The `remove_single` argument will |
|||
| 619 | -329x | +|||
| 10 | +
- extra_afun_params$.var+ #' remove single grades from the analysis so that *only* grade groups are analyzed. |
|||
| 620 | +11 |
- )+ #' |
||
| 621 | +12 |
-
+ #' If there are multiple grades recorded for one patient only the highest grade level is counted. |
||
| 622 | +13 |
- # Indentation checks+ #' |
||
| 623 | -329x | +|||
| 14 | +
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods)+ #' The summarize function [summarize_occurrences_by_grade()] performs the same function as |
|||
| 624 | +15 |
-
+ #' [count_occurrences_by_grade()] except it creates content rows, not data rows, to summarize the current table |
||
| 625 | +16 |
- # Labels assignments+ #' row/column context and operates on the level of the latest row split or the root of the table if no row splits have |
||
| 626 | -329x | +|||
| 17 | +
- lbls <- get_labels_from_stats(.stats, .labels, levels_per_stats)+ #' occurred. |
|||
| 627 | +18 |
- # Check for custom labels from control_analyze_vars+ #' |
||
| 628 | -329x | +|||
| 19 | +
- .labels <- if ("control" %in% names(dots_extra_args)) {
+ #' @inheritParams count_occurrences |
|||
| 629 | -2x | +|||
| 20 | +
- labels_use_control(lbls, dots_extra_args[["control"]], .labels)+ #' @inheritParams argument_convention |
|||
| 630 | +21 |
- } else {
+ #' @param grade_groups (named `list` of `character`)\cr list containing groupings of grades. |
||
| 631 | -327x | +|||
| 22 | +
- lbls+ #' @param remove_single (`flag`)\cr `TRUE` to not include the elements of one-element grade groups |
|||
| 632 | +23 |
- }+ #' in the the output list; in this case only the grade groups names will be included in the output. If |
||
| 633 | +24 |
-
+ #' `only_grade_groups` is set to `TRUE` this argument is ignored. |
||
| 634 | -329x | +|||
| 25 | +
- if (is.character(x) || is.factor(x)) {
+ #' @param only_grade_groups (`flag`)\cr whether only the specified grade groups should be |
|||
| 635 | +26 |
- # Ungroup statistics with values for each level of x+ #' included, with individual grade rows removed (`TRUE`), or all grades and grade groups |
||
| 636 | -236x | +|||
| 27 | +
- x_ungrp <- ungroup_stats(x_stats, .formats, .indent_mods)+ #' should be displayed (`FALSE`). |
|||
| 637 | -236x | +|||
| 28 | +
- x_stats <- x_ungrp[["x"]]+ #' @param .stats (`character`)\cr statistics to select for the table. |
|||
| 638 | -236x | +|||
| 29 | +
- .formats <- x_ungrp[[".formats"]]+ #' |
|||
| 639 | -236x | +|||
| 30 | +
- .indent_mods <- x_ungrp[[".indent_mods"]]+ #' Options are: ``r shQuote(get_stats("count_occurrences_by_grade"), type = "sh")``
|
|||
| 640 | -236x | +|||
| 31 | +
- .labels <- .unlist_keep_nulls(.labels)+ #' |
|||
| 641 | -236x | +|||
| 32 | +
- .labels <- gsub("fill-na-level", "NA", .labels)
+ #' @seealso Relevant helper function [h_append_grade_groups()]. |
|||
| 642 | +33 |
- }+ #' |
||
| 643 | +34 |
-
+ #' @name count_occurrences_by_grade |
||
| 644 | +35 |
- # Get and check statistical names from defaults+ #' @order 1 |
||
| 645 | -329x | +|||
| 36 | +
- .stat_names <- get_stat_names(x_stats, .stat_names_in) # note is x_stats+ NULL |
|||
| 646 | +37 | |||
| 647 | -329x | +|||
| 38 | +
- in_rows(+ #' Helper function for `s_count_occurrences_by_grade()` |
|||
| 648 | -329x | +|||
| 39 | +
- .list = x_stats,+ #' |
|||
| 649 | -329x | +|||
| 40 | +
- .formats = .formats,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 650 | -329x | +|||
| 41 | +
- .names = names(.labels),+ #' |
|||
| 651 | -329x | +|||
| 42 | +
- .stat_names = .stat_names,+ #' Helper function for [s_count_occurrences_by_grade()] to insert grade groupings into list with |
|||
| 652 | -329x | +|||
| 43 | +
- .labels = .labels,+ #' individual grade frequencies. The order of the final result follows the order of `grade_groups`. |
|||
| 653 | -329x | +|||
| 44 | +
- .indent_mods = .indent_mods+ #' The elements under any-grade group (if any), i.e. the grade group equal to `refs` will be moved to |
|||
| 654 | +45 |
- )+ #' the end. Grade groups names must be unique. |
||
| 655 | +46 |
- }+ #' |
||
| 656 | +47 |
-
+ #' @inheritParams count_occurrences_by_grade |
||
| 657 | +48 |
- #' @describeIn analyze_variables Layout-creating function which can take statistics function arguments+ #' @param refs (named `list` of `numeric`)\cr named list where each name corresponds to a reference grade level |
||
| 658 | +49 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' and each entry represents a count. |
||
| 659 | +50 |
#' |
||
| 660 | +51 |
- #' @param ... additional arguments passed to `s_summary()`, including:+ #' @return Formatted list of grade groupings. |
||
| 661 | +52 |
- #' * `denom`: (`string`) See parameter description below.+ #' |
||
| 662 | +53 |
- #' * `.N_row`: (`numeric(1)`) Row-wise N (row group count) for the group of observations being analyzed (i.e. with no+ #' @examples |
||
| 663 | +54 |
- #' column-based subsetting).+ #' h_append_grade_groups( |
||
| 664 | +55 |
- #' * `.N_col`: (`numeric(1)`) Column-wise N (column count) for the full column being tabulated within.+ #' list( |
||
| 665 | +56 |
- #' * `verbose`: (`flag`) Whether additional warnings and messages should be printed. Mainly used to print out+ #' "Any Grade" = as.character(1:5), |
||
| 666 | +57 |
- #' information about factor casting. Defaults to `TRUE`. Used for `character`/`factor` variables only.+ #' "Grade 1-2" = c("1", "2"),
|
||
| 667 | +58 |
- #' @param compare_with_ref_group (logical)\cr whether to compare the variable with a reference group.+ #' "Grade 3-4" = c("3", "4")
|
||
| 668 | +59 |
- #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector+ #' ), |
||
| 669 | +60 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ #' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
|
||
| 670 | +61 |
- #' for that statistic's row label.+ #' ) |
||
| 671 | +62 |
#' |
||
| 672 | +63 |
- #' @return+ #' h_append_grade_groups( |
||
| 673 | +64 |
- #' * `analyze_vars()` returns a layout object suitable for passing to further layouting functions,+ #' list( |
||
| 674 | +65 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' "Any Grade" = as.character(5:1), |
||
| 675 | +66 |
- #' the statistics from `s_summary()` to the table layout.+ #' "Grade A" = "5", |
||
| 676 | +67 |
- #'+ #' "Grade B" = c("4", "3")
|
||
| 677 | +68 |
- #' @examples+ #' ), |
||
| 678 | +69 |
- #' ## Fabricated dataset.+ #' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
|
||
| 679 | +70 |
- #' dta_test <- data.frame(+ #' ) |
||
| 680 | +71 |
- #' USUBJID = rep(1:6, each = 3),+ #' |
||
| 681 | +72 |
- #' PARAMCD = rep("lab", 6 * 3),
+ #' h_append_grade_groups( |
||
| 682 | +73 |
- #' AVISIT = rep(paste0("V", 1:3), 6),
+ #' list( |
||
| 683 | +74 |
- #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ #' "Any Grade" = as.character(1:5), |
||
| 684 | +75 |
- #' AVAL = c(9:1, rep(NA, 9))+ #' "Grade 1-2" = c("1", "2"),
|
||
| 685 | +76 |
- #' )+ #' "Grade 3-4" = c("3", "4")
|
||
| 686 | +77 |
- #'+ #' ), |
||
| 687 | +78 |
- #' # `analyze_vars()` in `rtables` pipelines+ #' list("1" = 10, "2" = 5, "3" = 0)
|
||
| 688 | +79 |
- #' ## Default output within a `rtables` pipeline.+ #' ) |
||
| 689 | +80 |
- #' l <- basic_table() %>%+ #' |
||
| 690 | +81 |
- #' split_cols_by(var = "ARM") %>%+ #' @export |
||
| 691 | +82 |
- #' split_rows_by(var = "AVISIT") %>%+ h_append_grade_groups <- function(grade_groups, refs, remove_single = TRUE, only_grade_groups = FALSE) {
|
||
| 692 | -+ | |||
| 83 | +32x |
- #' analyze_vars(vars = "AVAL")+ checkmate::assert_list(grade_groups) |
||
| 693 | -+ | |||
| 84 | +32x |
- #'+ checkmate::assert_list(refs) |
||
| 694 | -+ | |||
| 85 | +32x |
- #' build_table(l, df = dta_test)+ refs_orig <- refs |
||
| 695 | -+ | |||
| 86 | +32x |
- #'+ elements <- unique(unlist(grade_groups)) |
||
| 696 | +87 |
- #' ## Select and format statistics output.+ |
||
| 697 | +88 |
- #' l <- basic_table() %>%+ ### compute sums in groups |
||
| 698 | -+ | |||
| 89 | +32x |
- #' split_cols_by(var = "ARM") %>%+ grp_sum <- lapply(grade_groups, function(i) do.call(sum, refs[i])) |
||
| 699 | -+ | |||
| 90 | +32x |
- #' split_rows_by(var = "AVISIT") %>%+ if (!checkmate::test_subset(elements, names(refs))) {
|
||
| 700 | -+ | |||
| 91 | +2x |
- #' analyze_vars(+ padding_el <- setdiff(elements, names(refs)) |
||
| 701 | -+ | |||
| 92 | +2x |
- #' vars = "AVAL",+ refs[padding_el] <- 0 |
||
| 702 | +93 |
- #' .stats = c("n", "mean_sd", "quantiles"),
+ } |
||
| 703 | -+ | |||
| 94 | +32x |
- #' .formats = c("mean_sd" = "xx.x, xx.x"),
+ result <- c(grp_sum, refs) |
||
| 704 | +95 |
- #' .labels = c(n = "n", mean_sd = "Mean, SD", quantiles = c("Q1 - Q3"))
+
|
||
| 705 | +96 |
- #' )+ ### order result while keeping grade_groups's ordering+ |
+ ||
| 97 | +32x | +
+ ordr <- grade_groups |
||
| 706 | +98 |
- #'+ |
||
| 707 | +99 |
- #' build_table(l, df = dta_test)+ # elements of any-grade group (if any) will be moved to the end+ |
+ ||
| 100 | +32x | +
+ is_any <- sapply(grade_groups, setequal, y = names(refs))+ |
+ ||
| 101 | +32x | +
+ ordr[is_any] <- list(character(0)) # hide elements under any-grade group |
||
| 708 | +102 |
- #'+ |
||
| 709 | +103 |
- #' ## Use arguments interpreted by `s_summary`.+ # groups-elements combined sequence+ |
+ ||
| 104 | +32x | +
+ ordr <- c(lapply(names(ordr), function(g) c(g, ordr[[g]])), recursive = TRUE, use.names = FALSE)+ |
+ ||
| 105 | +32x | +
+ ordr <- ordr[!duplicated(ordr)] |
||
| 710 | +106 |
- #' l <- basic_table() %>%+ |
||
| 711 | +107 |
- #' split_cols_by(var = "ARM") %>%+ # append remaining elements (if any)+ |
+ ||
| 108 | +32x | +
+ ordr <- union(ordr, unlist(grade_groups[is_any])) # from any-grade group+ |
+ ||
| 109 | +32x | +
+ ordr <- union(ordr, names(refs)) # from refs |
||
| 712 | +110 |
- #' split_rows_by(var = "AVISIT") %>%+ |
||
| 713 | +111 |
- #' analyze_vars(vars = "AVAL", na_rm = FALSE)+ # remove elements of single-element groups, if any+ |
+ ||
| 112 | +32x | +
+ if (only_grade_groups) {
+ |
+ ||
| 113 | +3x | +
+ ordr <- intersect(ordr, names(grade_groups))+ |
+ ||
| 114 | +29x | +
+ } else if (remove_single) {
+ |
+ ||
| 115 | +29x | +
+ is_single <- sapply(grade_groups, length) == 1L+ |
+ ||
| 116 | +29x | +
+ ordr <- setdiff(ordr, unlist(grade_groups[is_single])) |
||
| 714 | +117 |
- #'+ } |
||
| 715 | +118 |
- #' build_table(l, df = dta_test)+ |
||
| 716 | +119 |
- #'+ # apply the order+ |
+ ||
| 120 | +32x | +
+ result <- result[ordr] |
||
| 717 | +121 |
- #' ## Handle `NA` levels first when summarizing factors.+ |
||
| 718 | +122 |
- #' dta_test$AVISIT <- NA_character_+ # remove groups without any elements in the original refs |
||
| 719 | +123 |
- #' dta_test <- df_explicit_na(dta_test)+ # note: it's OK if groups have 0 value+ |
+ ||
| 124 | +32x | +
+ keep_grp <- vapply(grade_groups, function(x, rf) {
+ |
+ ||
| 125 | +64x | +
+ any(x %in% rf)+ |
+ ||
| 126 | +32x | +
+ }, rf = names(refs_orig), logical(1)) |
||
| 720 | +127 |
- #' l <- basic_table() %>%+ + |
+ ||
| 128 | +32x | +
+ keep_el <- names(result) %in% names(refs_orig) | names(result) %in% names(keep_grp)[keep_grp]+ |
+ ||
| 129 | +32x | +
+ result <- result[keep_el] |
||
| 721 | +130 |
- #' split_cols_by(var = "ARM") %>%+ + |
+ ||
| 131 | +32x | +
+ result |
||
| 722 | +132 |
- #' analyze_vars(vars = "AVISIT", na_rm = FALSE)+ } |
||
| 723 | +133 |
- #'+ |
||
| 724 | +134 |
- #' build_table(l, df = dta_test)+ #' @describeIn count_occurrences_by_grade Statistics function which counts the |
||
| 725 | +135 |
- #'+ #' number of patients by highest grade. |
||
| 726 | +136 |
- #' # auto format+ #' |
||
| 727 | +137 |
- #' dt <- data.frame("VAR" = c(0.001, 0.2, 0.0011000, 3, 4))
+ #' @return |
||
| 728 | +138 |
- #' basic_table() %>%+ #' * `s_count_occurrences_by_grade()` returns a list of counts and fractions with one element per grade level or |
||
| 729 | +139 |
- #' analyze_vars(+ #' grade level grouping. |
||
| 730 | +140 |
- #' vars = "VAR",+ #' |
||
| 731 | +141 |
- #' .stats = c("n", "mean", "mean_sd", "range"),
+ #' @examples |
||
| 732 | +142 |
- #' .formats = c("mean_sd" = "auto", "range" = "auto")
+ #' s_count_occurrences_by_grade( |
||
| 733 | +143 |
- #' ) %>%+ #' df, |
||
| 734 | +144 |
- #' build_table(dt)+ #' .N_col = 10L, |
||
| 735 | +145 |
- #'+ #' .var = "AETOXGR", |
||
| 736 | +146 |
- #' @export+ #' id = "USUBJID", |
||
| 737 | +147 |
- #' @order 2+ #' grade_groups = list("ANY" = levels(df$AETOXGR))
|
||
| 738 | +148 |
- analyze_vars <- function(lyt,+ #' ) |
||
| 739 | +149 |
- vars,+ #' |
||
| 740 | +150 |
- var_labels = vars,+ #' @export |
||
| 741 | +151 |
- na_str = default_na_str(),+ s_count_occurrences_by_grade <- function(df, |
||
| 742 | +152 |
- nested = TRUE,+ .var, |
||
| 743 | +153 |
- show_labels = "default",+ .N_row, # nolint |
||
| 744 | +154 |
- table_names = vars,+ .N_col, # nolint |
||
| 745 | +155 |
- section_div = NA_character_,+ id = "USUBJID", |
||
| 746 | +156 |
- ...,+ grade_groups = list(), |
||
| 747 | +157 |
- na_rm = TRUE,+ remove_single = TRUE, |
||
| 748 | +158 |
- compare_with_ref_group = FALSE,+ only_grade_groups = FALSE, |
||
| 749 | +159 |
- .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
+ denom = c("N_col", "n", "N_row"),
|
||
| 750 | +160 |
- .stat_names_in = NULL,+ labelstr = "") {
|
||
| 751 | -+ | |||
| 161 | +75x |
- .formats = NULL,+ assert_valid_factor(df[[.var]]) |
||
| 752 | -+ | |||
| 162 | +75x |
- .labels = NULL,+ assert_df_with_variables(df, list(grade = .var, id = id)) |
||
| 753 | +163 |
- .indent_mods = NULL) {
+
|
||
| 754 | -+ | |||
| 164 | +75x |
- # Depending on main functions+ denom <- match.arg(denom) %>% |
||
| 755 | -37x | +165 | +75x |
- extra_args <- list(+ switch( |
| 756 | -37x | +166 | +75x |
- "na_rm" = na_rm,+ n = nlevels(factor(df[[id]])), |
| 757 | -37x | +167 | +75x |
- "compare_with_ref_group" = compare_with_ref_group,+ N_row = .N_row, |
| 758 | -+ | |||
| 168 | +75x |
- ...+ N_col = .N_col |
||
| 759 | +169 |
- )+ ) |
||
| 760 | +170 | |||
| 761 | -+ | |||
| 171 | +75x |
- # Needed defaults+ if (nrow(df) < 1) {
|
||
| 762 | -37x | +172 | +5x |
- if (!is.null(.stats)) extra_args[[".stats"]] <- .stats+ grade_levels <- levels(df[[.var]]) |
| 763 | -3x | +173 | +5x |
- if (!is.null(.stat_names_in)) extra_args[[".stat_names_in"]] <- .stat_names_in+ l_count <- as.list(rep(0, length(grade_levels))) |
| 764 | -8x | +174 | +5x |
- if (!is.null(.formats)) extra_args[[".formats"]] <- .formats+ names(l_count) <- grade_levels+ |
+
| 175 | ++ |
+ } else {
|
||
| 765 | -4x | +176 | +70x |
- if (!is.null(.labels)) extra_args[[".labels"]] <- .labels+ if (isTRUE(is.factor(df[[id]]))) {
|
| 766 | +177 | ! |
- if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods+ assert_valid_factor(df[[id]], any.missing = FALSE) |
|
| 767 | +178 |
-
+ } else {
|
||
| 768 | -+ | |||
| 179 | +70x |
-
+ checkmate::assert_character(df[[id]], min.chars = 1, any.missing = FALSE) |
||
| 769 | +180 |
- # Adding all additional information from layout to analysis functions (see ?rtables::additional_fun_params)+ } |
||
| 770 | -37x | +181 | +70x |
- extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE)+ checkmate::assert_count(.N_col) |
| 771 | -37x | +|||
| 182 | +
- formals(a_summary) <- c(+ |
|||
| 772 | -37x | +183 | +70x |
- formals(a_summary),+ id <- df[[id]] |
| 773 | -37x | +184 | +70x |
- extra_args[[".additional_fun_parameters"]]+ grade <- df[[.var]] |
| 774 | +185 |
- )+ |
||
| 775 | -+ | |||
| 186 | +70x |
-
+ if (!is.ordered(grade)) {
|
||
| 776 | -+ | |||
| 187 | +70x |
- # Main {rtables} structural call
+ grade_lbl <- obj_label(grade) |
||
| 777 | -37x | +188 | +70x |
- analyze(+ lvls <- levels(grade) |
| 778 | -37x | +189 | +70x |
- lyt = lyt,+ if (sum(grepl("^\\d+$", lvls)) %in% c(0, length(lvls))) {
|
| 779 | -37x | +190 | +69x |
- vars = vars,+ lvl_ord <- lvls+ |
+
| 191 | ++ |
+ } else {
|
||
| 780 | -37x | +192 | +1x |
- var_labels = var_labels,+ lvls[!grepl("^\\d+$", lvls)] <- min(as.numeric(lvls[grepl("^\\d+$", lvls)])) - 1
|
| 781 | -37x | +193 | +1x |
- afun = a_summary,+ lvl_ord <- levels(grade)[order(as.numeric(lvls))]+ |
+
| 194 | ++ |
+ } |
||
| 782 | -37x | +195 | +70x |
- na_str = na_str,+ grade <- formatters::with_label(factor(grade, levels = lvl_ord, ordered = TRUE), grade_lbl)+ |
+
| 196 | ++ |
+ }+ |
+ ||
| 197 | ++ | + | ||
| 783 | -37x | +198 | +70x |
- inclNAs = !na_rm,+ missing_lvl <- grepl("missing", tolower(levels(grade)))
|
| 784 | -37x | +199 | +70x |
- nested = nested,+ if (any(missing_lvl)) {
|
| 785 | -37x | +200 | +1x |
- extra_args = extra_args,+ grade <- factor( |
| 786 | -37x | +201 | +1x |
- show_labels = show_labels,+ grade, |
| 787 | -37x | +202 | +1x |
- table_names = table_names,+ levels = c(levels(grade)[!missing_lvl], levels(grade)[missing_lvl]), |
| 788 | -37x | +203 | +1x |
- section_div = section_div+ ordered = is.ordered(grade) |
| 789 | +204 |
- )+ ) |
||
| 790 | +205 |
- }+ } |
| 1 | -+ | |||
| 206 | +70x |
- #' Count number of patients+ df_max <- stats::aggregate(grade ~ id, FUN = max, drop = FALSE) |
||
| 2 | -+ | |||
| 207 | +70x |
- #'+ l_count <- as.list(table(df_max$grade)) |
||
| 3 | +208 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 4 | +209 |
- #'+ |
||
| 5 | -+ | |||
| 210 | +75x |
- #' The analyze function [analyze_num_patients()] creates a layout element to count total numbers of unique or+ if (length(grade_groups) > 0) {
|
||
| 6 | -+ | |||
| 211 | +30x |
- #' non-unique patients. The primary analysis variable `vars` is used to uniquely identify patients.+ l_count <- h_append_grade_groups(grade_groups, l_count, remove_single, only_grade_groups) |
||
| 7 | +212 |
- #'+ } |
||
| 8 | +213 |
- #' The `count_by` variable can be used to identify non-unique patients such that the number of patients with a unique+ |
||
| 9 | -+ | |||
| 214 | +75x |
- #' combination of values in `vars` and `count_by` will be returned instead as the `nonunique` statistic. The `required`+ l_count_fraction <- lapply( |
||
| 10 | -+ | |||
| 215 | +75x |
- #' variable can be used to specify a variable required to be non-missing for the record to be included in the counts.+ l_count, |
||
| 11 | -+ | |||
| 216 | +75x |
- #'+ function(i, denom) {
|
||
| 12 | -+ | |||
| 217 | +299x |
- #' The summarize function [summarize_num_patients()] performs the same function as [analyze_num_patients()] except it+ if (i == 0 && denom == 0) {
|
||
| 13 | -+ | |||
| 218 | +9x |
- #' creates content rows, not data rows, to summarize the current table row/column context and operates on the level of+ c(0, 0) |
||
| 14 | +219 |
- #' the latest row split or the root of the table if no row splits have occurred.+ } else {
|
||
| 15 | -+ | |||
| 220 | +290x |
- #'+ c(i, i / denom) |
||
| 16 | +221 |
- #' @inheritParams argument_convention+ } |
||
| 17 | +222 |
- #' @param required (`character` or `NULL`)\cr name of a variable that is required to be non-missing.+ },+ |
+ ||
| 223 | +75x | +
+ denom = denom |
||
| 18 | +224 |
- #' @param count_by (`character` or `NULL`)\cr name of a variable to be combined with `vars` when counting+ ) |
||
| 19 | +225 |
- #' `nonunique` records.+ + |
+ ||
| 226 | +75x | +
+ list(+ |
+ ||
| 227 | +75x | +
+ count_fraction = l_count_fraction,+ |
+ ||
| 228 | +75x | +
+ count_fraction_fixed_dp = l_count_fraction |
||
| 20 | +229 |
- #' @param unique_count_suffix (`flag`)\cr whether the `"(n)"` suffix should be added to `unique_count` labels.+ ) |
||
| 21 | +230 |
- #' Defaults to `TRUE`.+ } |
||
| 22 | +231 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ |
||
| 23 | +232 |
- #'+ #' @describeIn count_occurrences_by_grade Formatted analysis function which is used as `afun` |
||
| 24 | +233 |
- #' Options are: ``r shQuote(get_stats("summarize_num_patients"))``
+ #' in `count_occurrences_by_grade()`. |
||
| 25 | +234 |
#' |
||
| 26 | +235 |
- #' @name summarize_num_patients+ #' @return |
||
| 27 | +236 |
- #' @order 1+ #' * `a_count_occurrences_by_grade()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 28 | +237 |
- NULL+ #' |
||
| 29 | +238 |
-
+ #' @examples |
||
| 30 | +239 |
- #' @describeIn summarize_num_patients Statistics function which counts the number of+ #' a_count_occurrences_by_grade( |
||
| 31 | +240 |
- #' unique patients, the corresponding percentage taken with respect to the+ #' df, |
||
| 32 | +241 |
- #' total number of patients, and the number of non-unique patients.+ #' .N_col = 10L, |
||
| 33 | +242 |
- #'+ #' .N_row = 10L, |
||
| 34 | +243 |
- #' @param x (`character` or `factor`)\cr vector of patient IDs.+ #' .var = "AETOXGR", |
||
| 35 | +244 |
- #'+ #' id = "USUBJID", |
||
| 36 | +245 |
- #' @return+ #' grade_groups = list("ANY" = levels(df$AETOXGR))
|
||
| 37 | +246 |
- #' * `s_num_patients()` returns a named `list` of 3 statistics:+ #' ) |
||
| 38 | +247 |
- #' * `unique`: Vector of counts and percentages.+ #' |
||
| 39 | +248 |
- #' * `nonunique`: Vector of counts.+ #' @export |
||
| 40 | +249 |
- #' * `unique_count`: Counts.+ a_count_occurrences_by_grade <- function(df, |
||
| 41 | +250 |
- #'+ labelstr = "", |
||
| 42 | +251 |
- #' @examples+ id = "USUBJID", |
||
| 43 | +252 |
- #' # Use the statistics function to count number of unique and nonunique patients.+ grade_groups = list(), |
||
| 44 | +253 |
- #' s_num_patients(x = as.character(c(1, 1, 1, 2, 4, NA)), labelstr = "", .N_col = 6L)+ remove_single = TRUE, |
||
| 45 | +254 |
- #' s_num_patients(+ only_grade_groups = FALSE, |
||
| 46 | +255 |
- #' x = as.character(c(1, 1, 1, 2, 4, NA)),+ denom = c("N_col", "n", "N_row"),
|
||
| 47 | +256 |
- #' labelstr = "",+ .N_col, # nolint |
||
| 48 | +257 |
- #' .N_col = 6L,+ .N_row, # nolint |
||
| 49 | +258 |
- #' count_by = c(1, 1, 2, 1, 1, 1)+ .df_row, |
||
| 50 | +259 |
- #' )+ .var = NULL, |
||
| 51 | +260 |
- #'+ .stats = NULL, |
||
| 52 | +261 |
- #' @export+ .formats = NULL, |
||
| 53 | +262 |
- s_num_patients <- function(x, labelstr, .N_col, count_by = NULL, unique_count_suffix = TRUE) { # nolint
+ .labels = NULL, |
||
| 54 | +263 |
-
+ .indent_mods = NULL, |
||
| 55 | -146x | +|||
| 264 | +
- checkmate::assert_string(labelstr)+ na_str = default_na_str()) {
|
|||
| 56 | -146x | +265 | +56x |
- checkmate::assert_count(.N_col)+ x_stats <- s_count_occurrences_by_grade( |
| 57 | -146x | +266 | +56x |
- checkmate::assert_multi_class(x, classes = c("factor", "character"))
+ df = df, .var = .var, .N_row = .N_row, .N_col = .N_col, id = id, |
| 58 | -146x | -
- checkmate::assert_flag(unique_count_suffix)- |
- ||
| 59 | -+ | 267 | +56x |
-
+ grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups, |
| 60 | -146x | +268 | +56x |
- count1 <- n_available(unique(x))+ denom = denom, labelstr = labelstr |
| 61 | -146x | +|||
| 269 | +
- count2 <- n_available(x)+ ) |
|||
| 62 | +270 | |||
| 63 | -146x | +271 | +56x |
- if (!is.null(count_by)) {
+ if (is.null(unlist(x_stats))) {
|
| 64 | -16x | +|||
| 272 | +! |
- checkmate::assert_vector(count_by, len = length(x))+ return(NULL) |
||
| 65 | -16x | +|||
| 273 | +
- count2 <- n_available(unique(interaction(x, count_by)))+ } |
|||
| 66 | +274 |
- }+ |
||
| 67 | +275 |
-
+ # Fill in with formatting defaults if needed |
||
| 68 | -146x | +276 | +56x |
- out <- list(+ .stats <- get_stats("count_occurrences_by_grade", stats_in = .stats)
|
| 69 | -146x | +277 | +56x |
- unique = formatters::with_label(c(count1, ifelse(count1 == 0 && .N_col == 0, 0, count1 / .N_col)), labelstr),+ x_stats <- x_stats[.stats] |
| 70 | -146x | +278 | +56x |
- nonunique = formatters::with_label(count2, labelstr),+ levels_per_stats <- lapply(x_stats, names) |
| 71 | -146x | +279 | +56x |
- unique_count = formatters::with_label(+ .formats <- get_formats_from_stats(.stats, .formats, levels_per_stats) |
| 72 | -146x | +280 | +56x |
- count1, ifelse(unique_count_suffix, paste0(labelstr, if (nzchar(labelstr)) " ", "(n)"), labelstr)+ .labels <- get_labels_from_stats(.stats, .labels, levels_per_stats) |
| 73 | -+ | |||
| 281 | +56x |
- )+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods, levels_per_stats) |
||
| 74 | +282 |
- )+ |
||
| 75 | +283 |
-
+ # Unlist stats |
||
| 76 | -146x | -
- out- |
- ||
| 77 | -+ | 284 | +56x |
- }+ x_stats <- x_stats %>% .unlist_keep_nulls() |
| 78 | +285 | |||
| 79 | +286 |
- #' @describeIn summarize_num_patients Statistics function which counts the number of unique patients+ # Auto format handling |
||
| 80 | -+ | |||
| 287 | +56x |
- #' in a column (variable), the corresponding percentage taken with respect to the total number of+ .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var) |
||
| 81 | +288 |
- #' patients, and the number of non-unique patients in the column.+ |
||
| 82 | -+ | |||
| 289 | +56x |
- #'+ in_rows( |
||
| 83 | -+ | |||
| 290 | +56x |
- #' @return+ .list = x_stats, |
||
| 84 | -+ | |||
| 291 | +56x |
- #' * `s_num_patients_content()` returns the same values as `s_num_patients()`.+ .formats = .formats, |
||
| 85 | -+ | |||
| 292 | +56x |
- #'+ .names = .labels %>% .unlist_keep_nulls(), |
||
| 86 | -+ | |||
| 293 | +56x |
- #' @examples+ .labels = .labels %>% .unlist_keep_nulls(), |
||
| 87 | -+ | |||
| 294 | +56x |
- #' # Count number of unique and non-unique patients.+ .indent_mods = .indent_mods %>% .unlist_keep_nulls(), |
||
| 88 | -+ | |||
| 295 | +56x |
- #'+ .format_na_strs = na_str |
||
| 89 | +296 |
- #' df <- data.frame(+ ) |
||
| 90 | +297 |
- #' USUBJID = as.character(c(1, 2, 1, 4, NA)),+ } |
||
| 91 | +298 |
- #' EVENT = as.character(c(10, 15, 10, 17, 8))+ |
||
| 92 | +299 |
- #' )+ #' @describeIn count_occurrences_by_grade Layout-creating function which can take statistics function |
||
| 93 | +300 |
- #' s_num_patients_content(df, .N_col = 5, .var = "USUBJID")+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 94 | +301 |
#' |
||
| 95 | -- |
- #' df_by_event <- data.frame(- |
- ||
| 96 | +302 |
- #' USUBJID = as.character(c(1, 2, 1, 4, NA)),+ #' @return |
||
| 97 | +303 |
- #' EVENT = c(10, 15, 10, 17, 8)+ #' * `count_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions, |
||
| 98 | +304 |
- #' )+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 99 | +305 |
- #' s_num_patients_content(df_by_event, .N_col = 5, .var = "USUBJID", count_by = "EVENT")+ #' the statistics from `s_count_occurrences_by_grade()` to the table layout. |
||
| 100 | +306 |
#' |
||
| 101 | -- |
- #' @export- |
- ||
| 102 | -- |
- s_num_patients_content <- function(df,- |
- ||
| 103 | -- |
- labelstr = "",- |
- ||
| 104 | +307 |
- .N_col, # nolint+ #' @examples |
||
| 105 | +308 |
- .var,+ #' library(dplyr) |
||
| 106 | +309 |
- required = NULL,+ #' |
||
| 107 | +310 |
- count_by = NULL,+ #' df <- data.frame( |
||
| 108 | +311 |
- unique_count_suffix = TRUE) {
- |
- ||
| 109 | -56x | -
- checkmate::assert_string(.var)- |
- ||
| 110 | -56x | -
- checkmate::assert_data_frame(df)- |
- ||
| 111 | -56x | -
- if (is.null(count_by)) {
- |
- ||
| 112 | -53x | -
- assert_df_with_variables(df, list(id = .var))+ #' USUBJID = as.character(c(1:6, 1)), |
||
| 113 | +312 |
- } else {
- |
- ||
| 114 | -3x | -
- assert_df_with_variables(df, list(id = .var, count_by = count_by))+ #' ARM = factor(c("A", "A", "A", "B", "B", "B", "A"), levels = c("A", "B")),
|
||
| 115 | +313 |
- }- |
- ||
| 116 | -56x | -
- if (!is.null(required)) {
- |
- ||
| 117 | -! | -
- checkmate::assert_string(required)- |
- ||
| 118 | -! | -
- assert_df_with_variables(df, list(required = required))- |
- ||
| 119 | -! | -
- df <- df[!is.na(df[[required]]), , drop = FALSE]+ #' AETOXGR = factor(c(1, 2, 3, 4, 1, 2, 3), levels = c(1:5)), |
||
| 120 | +314 |
- }+ #' AESEV = factor( |
||
| 121 | +315 | - - | -||
| 122 | -56x | -
- x <- df[[.var]]- |
- ||
| 123 | -56x | -
- y <- if (is.null(count_by)) NULL else df[[count_by]]+ #' x = c("MILD", "MODERATE", "SEVERE", "MILD", "MILD", "MODERATE", "SEVERE"),
|
||
| 124 | +316 | - - | -||
| 125 | -56x | -
- s_num_patients(- |
- ||
| 126 | -56x | -
- x = x,- |
- ||
| 127 | -56x | -
- labelstr = labelstr,+ #' levels = c("MILD", "MODERATE", "SEVERE")
|
||
| 128 | -56x | +|||
| 317 | +
- .N_col = .N_col,+ #' ), |
|||
| 129 | -56x | +|||
| 318 | +
- count_by = y,+ #' stringsAsFactors = FALSE |
|||
| 130 | -56x | +|||
| 319 | +
- unique_count_suffix = unique_count_suffix+ #' ) |
|||
| 131 | +320 |
- )+ #' |
||
| 132 | +321 |
- }+ #' df_adsl <- df %>% |
||
| 133 | +322 |
-
+ #' select(USUBJID, ARM) %>% |
||
| 134 | +323 |
- c_num_patients <- make_afun(+ #' unique() |
||
| 135 | +324 |
- s_num_patients_content,+ #' |
||
| 136 | +325 |
- .stats = c("unique", "nonunique", "unique_count"),
+ #' # Layout creating function with custom format. |
||
| 137 | +326 |
- .formats = c(unique = format_count_fraction_fixed_dp, nonunique = "xx", unique_count = "xx")+ #' basic_table() %>% |
||
| 138 | +327 |
- )+ #' split_cols_by("ARM") %>%
|
||
| 139 | +328 |
-
+ #' add_colcounts() %>% |
||
| 140 | +329 |
- #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments+ #' count_occurrences_by_grade( |
||
| 141 | +330 |
- #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ #' var = "AESEV", |
||
| 142 | +331 |
- #'+ #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
|
||
| 143 | +332 |
- #' @return+ #' ) %>% |
||
| 144 | +333 |
- #' * `summarize_num_patients()` returns a layout object suitable for passing to further layouting functions,+ #' build_table(df, alt_counts_df = df_adsl) |
||
| 145 | +334 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 146 | +335 |
- #' the statistics from `s_num_patients_content()` to the table layout.+ #' # Define additional grade groupings. |
||
| 147 | +336 |
- #'+ #' grade_groups <- list( |
||
| 148 | +337 |
- #' @examples+ #' "-Any-" = c("1", "2", "3", "4", "5"),
|
||
| 149 | +338 |
- #' # summarize_num_patients+ #' "Grade 1-2" = c("1", "2"),
|
||
| 150 | +339 |
- #' tbl <- basic_table() %>%+ #' "Grade 3-5" = c("3", "4", "5")
|
||
| 151 | +340 |
- #' split_cols_by("ARM") %>%
+ #' ) |
||
| 152 | +341 |
- #' split_rows_by("SEX") %>%
+ #' |
||
| 153 | +342 |
- #' summarize_num_patients("USUBJID", .stats = "unique_count") %>%
+ #' basic_table() %>% |
||
| 154 | +343 |
- #' build_table(df)+ #' split_cols_by("ARM") %>%
|
||
| 155 | +344 |
- #'+ #' add_colcounts() %>% |
||
| 156 | +345 |
- #' tbl+ #' count_occurrences_by_grade( |
||
| 157 | +346 |
- #'+ #' var = "AETOXGR", |
||
| 158 | +347 |
- #' @export+ #' grade_groups = grade_groups, |
||
| 159 | +348 |
- #' @order 3+ #' only_grade_groups = TRUE |
||
| 160 | +349 |
- summarize_num_patients <- function(lyt,+ #' ) %>% |
||
| 161 | +350 |
- var,+ #' build_table(df, alt_counts_df = df_adsl) |
||
| 162 | +351 |
- required = NULL,+ #' |
||
| 163 | +352 |
- count_by = NULL,+ #' @export |
||
| 164 | +353 |
- unique_count_suffix = TRUE,+ #' @order 2 |
||
| 165 | +354 |
- na_str = default_na_str(),+ count_occurrences_by_grade <- function(lyt, |
||
| 166 | +355 |
- .stats = NULL,+ var, |
||
| 167 | +356 |
- .formats = NULL,+ id = "USUBJID", |
||
| 168 | +357 |
- .labels = c(+ grade_groups = list(), |
||
| 169 | +358 |
- unique = "Number of patients with at least one event",+ remove_single = TRUE, |
||
| 170 | +359 |
- nonunique = "Number of events"+ only_grade_groups = FALSE, |
||
| 171 | +360 |
- ),+ var_labels = var, |
||
| 172 | +361 |
- .indent_mods = 0L,+ show_labels = "default", |
||
| 173 | +362 |
- riskdiff = FALSE,+ riskdiff = FALSE, |
||
| 174 | +363 |
- ...) {
+ na_str = default_na_str(), |
||
| 175 | -16x | +|||
| 364 | +
- checkmate::assert_flag(riskdiff)+ nested = TRUE, |
|||
| 176 | +365 |
-
+ ..., |
||
| 177 | -5x | +|||
| 366 | +
- if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
+ table_names = var, |
|||
| 178 | -8x | +|||
| 367 | +
- if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats]+ .stats = "count_fraction", |
|||
| 179 | +368 |
-
+ .formats = list(count_fraction = format_count_fraction_fixed_dp), |
||
| 180 | -16x | +|||
| 369 | +
- s_args <- list(required = required, count_by = count_by, unique_count_suffix = unique_count_suffix, ...)+ .indent_mods = NULL, |
|||
| 181 | +370 |
-
+ .labels = NULL) {
|
||
| 182 | -16x | +371 | +12x |
- cfun <- make_afun(+ checkmate::assert_flag(riskdiff) |
| 183 | -16x | +372 | +12x |
- c_num_patients,+ extra_args <- list( |
| 184 | -16x | +373 | +12x |
- .stats = .stats,+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str+ |
+
| 374 | ++ |
+ ) |
||
| 185 | -16x | +375 | +12x |
- .formats = .formats,+ s_args <- list( |
| 186 | -16x | +376 | +12x |
- .labels = .labels+ id = id, grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups, ... |
| 187 | +377 |
) |
||
| 188 | +378 | |||
| 189 | -16x | +379 | +12x |
- extra_args <- if (isFALSE(riskdiff)) {
+ if (isFALSE(riskdiff)) {
|
| 190 | -14x | +380 | +10x |
- s_args+ extra_args <- c(extra_args, s_args) |
| 191 | +381 |
} else {
|
||
| 192 | +382 | 2x |
- list(+ extra_args <- c( |
|
| 193 | +383 | 2x |
- afun = list("s_num_patients_content" = cfun),
+ extra_args, |
|
| 194 | +384 | 2x |
- .stats = .stats,+ list( |
|
| 195 | +385 | 2x |
- .indent_mods = .indent_mods,+ afun = list("s_count_occurrences_by_grade" = a_count_occurrences_by_grade),
|
|
| 196 | +386 | 2x |
- s_args = s_args+ s_args = s_args |
|
| 197 | +387 | ++ |
+ )+ |
+ |
| 388 |
) |
|||
| 198 | +389 |
} |
||
| 199 | +390 | |||
| 200 | -16x | +391 | +12x |
- summarize_row_groups(+ analyze( |
| 201 | -16x | +392 | +12x |
lyt = lyt, |
| 202 | -16x | +393 | +12x |
- var = var,+ vars = var, |
| 203 | -16x | +394 | +12x |
- cfun = ifelse(isFALSE(riskdiff), cfun, afun_riskdiff),+ afun = ifelse(isFALSE(riskdiff), a_count_occurrences_by_grade, afun_riskdiff), |
| 204 | -16x | +395 | +12x |
- na_str = na_str,+ var_labels = var_labels, |
| 205 | -16x | +396 | +12x |
- extra_args = extra_args,+ show_labels = show_labels, |
| 206 | -16x | -
- indent_mod = .indent_mods- |
- ||
| 207 | -- |
- )- |
- ||
| 208 | -+ | 397 | +12x |
- }+ table_names = table_names, |
| 209 | -+ | |||
| 398 | +12x |
-
+ na_str = na_str, |
||
| 210 | -+ | |||
| 399 | +12x |
- #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments+ nested = nested, |
||
| 211 | -+ | |||
| 400 | +12x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ extra_args = extra_args |
||
| 212 | +401 |
- #'+ ) |
||
| 213 | +402 |
- #' @return+ } |
||
| 214 | +403 |
- #' * `analyze_num_patients()` returns a layout object suitable for passing to further layouting functions,+ |
||
| 215 | +404 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' @describeIn count_occurrences_by_grade Layout-creating function which can take content function arguments |
||
| 216 | +405 |
- #' the statistics from `s_num_patients_content()` to the table layout.+ #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 217 | +406 |
#' |
||
| 218 | -- |
- #' @details In general, functions that starts with `analyze*` are expected to- |
- ||
| 219 | +407 |
- #' work like [rtables::analyze()], while functions that starts with `summarize*`+ #' @return |
||
| 220 | +408 |
- #' are based upon [rtables::summarize_row_groups()]. The latter provides a+ #' * `summarize_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions, |
||
| 221 | +409 |
- #' value for each dividing split in the row and column space, but, being it+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows |
||
| 222 | +410 |
- #' bound to the fundamental splits, it is repeated by design in every page+ #' containing the statistics from `s_count_occurrences_by_grade()` to the table layout. |
||
| 223 | +411 |
- #' when pagination is involved.+ #' |
||
| 224 | +412 |
- #'+ #' @examples |
||
| 225 | +413 |
- #' @note As opposed to [summarize_num_patients()], this function does not repeat the produced rows.+ #' # Layout creating function with custom format. |
||
| 226 | +414 |
- #'+ #' basic_table() %>% |
||
| 227 | +415 |
- #' @examples+ #' add_colcounts() %>% |
||
| 228 | +416 |
- #' df <- data.frame(+ #' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
|
||
| 229 | +417 |
- #' USUBJID = as.character(c(1, 2, 1, 4, NA, 6, 6, 8, 9)),+ #' summarize_occurrences_by_grade( |
||
| 230 | +418 |
- #' ARM = c("A", "A", "A", "A", "A", "B", "B", "B", "B"),
+ #' var = "AESEV", |
||
| 231 | +419 |
- #' AGE = c(10, 15, 10, 17, 8, 11, 11, 19, 17),+ #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
|
||
| 232 | +420 |
- #' SEX = c("M", "M", "M", "F", "F", "F", "M", "F", "M")
+ #' ) %>% |
||
| 233 | +421 |
- #' )+ #' build_table(df, alt_counts_df = df_adsl) |
||
| 234 | +422 |
#' |
||
| 235 | +423 |
- #' # analyze_num_patients+ #' basic_table() %>% |
||
| 236 | +424 |
- #' tbl <- basic_table() %>%+ #' add_colcounts() %>% |
||
| 237 | +425 |
- #' split_cols_by("ARM") %>%
+ #' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
|
||
| 238 | +426 |
- #' add_colcounts() %>%+ #' summarize_occurrences_by_grade( |
||
| 239 | +427 |
- #' analyze_num_patients("USUBJID", .stats = c("unique")) %>%
+ #' var = "AETOXGR", |
||
| 240 | +428 |
- #' build_table(df)+ #' grade_groups = grade_groups |
||
| 241 | +429 |
- #'+ #' ) %>% |
||
| 242 | +430 |
- #' tbl+ #' build_table(df, alt_counts_df = df_adsl) |
||
| 243 | +431 |
#' |
||
| 244 | +432 |
#' @export |
||
| 245 | -- |
- #' @order 2- |
- ||
| 246 | -- |
- analyze_num_patients <- function(lyt,- |
- ||
| 247 | -- |
- vars,- |
- ||
| 248 | -- |
- required = NULL,- |
- ||
| 249 | +433 |
- count_by = NULL,+ #' @order 3 |
||
| 250 | +434 |
- unique_count_suffix = TRUE,+ summarize_occurrences_by_grade <- function(lyt, |
||
| 251 | +435 |
- na_str = default_na_str(),+ var, |
||
| 252 | +436 |
- nested = TRUE,+ id = "USUBJID", |
||
| 253 | +437 |
- .stats = NULL,+ grade_groups = list(), |
||
| 254 | +438 |
- .formats = NULL,+ remove_single = TRUE, |
||
| 255 | +439 |
- .labels = c(+ only_grade_groups = FALSE, |
||
| 256 | +440 |
- unique = "Number of patients with at least one event",+ riskdiff = FALSE, |
||
| 257 | +441 |
- nonunique = "Number of events"+ na_str = default_na_str(), |
||
| 258 | +442 |
- ),+ ..., |
||
| 259 | +443 |
- show_labels = c("default", "visible", "hidden"),
+ .stats = "count_fraction", |
||
| 260 | +444 |
- .indent_mods = 0L,+ .formats = list(count_fraction = format_count_fraction_fixed_dp), |
||
| 261 | +445 |
- riskdiff = FALSE,+ .indent_mods = NULL, |
||
| 262 | +446 |
- ...) {
+ .labels = NULL) {
|
||
| 263 | -4x | +447 | +6x |
checkmate::assert_flag(riskdiff) |
| 264 | -- | - - | -||
| 265 | -1x | -
- if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
- |
- ||
| 266 | -! | -
- if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats]- |
- ||
| 267 | -+ | 448 | +6x |
-
+ extra_args <- list( |
| 268 | -4x | +449 | +6x |
- s_args <- list(required = required, count_by = count_by, unique_count_suffix = unique_count_suffix, ...)+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str |
| 269 | +450 | - - | -||
| 270 | -4x | -
- afun <- make_afun(- |
- ||
| 271 | -4x | -
- c_num_patients,- |
- ||
| 272 | -4x | -
- .stats = .stats,+ ) |
||
| 273 | -4x | +451 | +6x |
- .formats = .formats,+ s_args <- list( |
| 274 | -4x | +452 | +6x |
- .labels = .labels+ id = id, grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups, ... |
| 275 | +453 |
) |
||
| 276 | +454 | |||
| 277 | -4x | +455 | +6x |
- extra_args <- if (isFALSE(riskdiff)) {
+ if (isFALSE(riskdiff)) {
|
| 278 | -2x | +456 | +4x |
- s_args+ extra_args <- c(extra_args, s_args) |
| 279 | +457 |
} else {
|
||
| 280 | +458 | 2x |
- list(+ extra_args <- c( |
|
| 281 | +459 | 2x |
- afun = list("s_num_patients_content" = afun),
+ extra_args, |
|
| 282 | +460 | 2x |
- .stats = .stats,+ list( |
|
| 283 | +461 | 2x |
- .indent_mods = .indent_mods,+ afun = list("s_count_occurrences_by_grade" = a_count_occurrences_by_grade),
|
|
| 284 | +462 | 2x |
- s_args = s_args+ s_args = s_args |
|
| 285 | +463 |
- )+ ) |
||
| 286 | +464 |
- }+ ) |
||
| 287 | +465 |
-
+ } |
||
| 288 | -4x | +|||
| 466 | +
- analyze(+ |
|||
| 289 | -4x | +467 | +6x |
- afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ summarize_row_groups( |
| 290 | -4x | +468 | +6x |
lyt = lyt, |
| 291 | -4x | -
- vars = vars,- |
- ||
| 292 | -4x | -
- na_str = na_str,- |
- ||
| 293 | -4x | +469 | +6x |
- nested = nested,+ var = var, |
| 294 | -4x | +470 | +6x |
- extra_args = extra_args,+ cfun = ifelse(isFALSE(riskdiff), a_count_occurrences_by_grade, afun_riskdiff), |
| 295 | -4x | +471 | +6x |
- show_labels = show_labels,+ na_str = na_str, |
| 296 | -4x | +472 | +6x |
- indent_mod = .indent_mods+ extra_args = extra_args |
| 297 | +473 |
) |
||
| 298 | +474 |
}@@ -70964,14 +73160,14 @@ tern coverage - 95.59% |
| 1 |
- #' Proportion difference estimation+ #' Encode categorical missing values in a data frame |
||
| 5 |
- #' The analysis function [estimate_proportion_diff()] creates a layout element to estimate the difference in proportion+ #' This is a helper function to encode missing entries across groups of categorical |
||
| 6 |
- #' of responders within a studied population. The primary analysis variable, `vars`, is a logical variable indicating+ #' variables in a data frame. |
||
| 7 |
- #' whether a response has occurred for each record. See the `method` parameter for options of methods to use when+ #' |
||
| 8 |
- #' constructing the confidence interval of the proportion difference. A stratification variable can be supplied via the+ #' @details Missing entries are those with `NA` or empty strings and will |
||
| 9 |
- #' `strata` element of the `variables` argument.+ #' be replaced with a specified value. If factor variables include missing |
||
| 10 |
- #'+ #' values, the missing value will be inserted as the last level. |
||
| 11 |
- #'+ #' Similarly, in case character or logical variables should be converted to factors |
||
| 12 |
- #' @inheritParams prop_diff_strat_nc+ #' with the `char_as_factor` or `logical_as_factor` options, the missing values will |
||
| 13 |
- #' @inheritParams argument_convention+ #' be set as the last level. |
||
| 14 |
- #' @param method (`string`)\cr the method used for the confidence interval estimation.+ #' |
||
| 15 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' @param data (`data.frame`)\cr data set. |
||
| 16 |
- #'+ #' @param omit_columns (`character`)\cr names of variables from `data` that should |
||
| 17 |
- #' Options are: ``r shQuote(get_stats("estimate_proportion_diff"))``
+ #' not be modified by this function. |
||
| 18 |
- #'+ #' @param char_as_factor (`flag`)\cr whether to convert character variables |
||
| 19 |
- #' @seealso [d_proportion_diff()]+ #' in `data` to factors. |
||
| 20 |
- #'+ #' @param logical_as_factor (`flag`)\cr whether to convert logical variables |
||
| 21 |
- #' @name prop_diff+ #' in `data` to factors. |
||
| 22 |
- #' @order 1+ #' @param na_level (`string`)\cr string used to replace all `NA` or empty |
||
| 23 |
- NULL+ #' values inside non-`omit_columns` columns. |
||
| 24 |
-
+ #' |
||
| 25 |
- #' @describeIn prop_diff Statistics function estimating the difference+ #' @return A `data.frame` with the chosen modifications applied. |
||
| 26 |
- #' in terms of responder proportion.+ #' |
||
| 27 |
- #'+ #' @seealso [sas_na()] and [explicit_na()] for other missing data helper functions. |
||
| 28 |
- #' @return+ #' |
||
| 29 |
- #' * `s_proportion_diff()` returns a named list of elements `diff` and `diff_ci`.+ #' @examples |
||
| 30 |
- #'+ #' my_data <- data.frame( |
||
| 31 |
- #' @note When performing an unstratified analysis, methods `"cmh"`, `"strat_newcombe"`, and `"strat_newcombecc"` are+ #' u = c(TRUE, FALSE, NA, TRUE), |
||
| 32 |
- #' not permitted.+ #' v = factor(c("A", NA, NA, NA), levels = c("Z", "A")),
|
||
| 33 |
- #'+ #' w = c("A", "B", NA, "C"),
|
||
| 34 |
- #' @examples+ #' x = c("D", "E", "F", NA),
|
||
| 35 |
- #' s_proportion_diff(+ #' y = c("G", "H", "I", ""),
|
||
| 36 |
- #' df = subset(dta, grp == "A"),+ #' z = c(1, 2, 3, 4), |
||
| 37 |
- #' .var = "rsp",+ #' stringsAsFactors = FALSE |
||
| 38 |
- #' .ref_group = subset(dta, grp == "B"),+ #' ) |
||
| 39 |
- #' .in_ref_col = FALSE,+ #' |
||
| 40 |
- #' conf_level = 0.90,+ #' # Example 1 |
||
| 41 |
- #' method = "ha"+ #' # Encode missing values in all character or factor columns. |
||
| 42 |
- #' )+ #' df_explicit_na(my_data) |
||
| 43 |
- #'+ #' # Also convert logical columns to factor columns. |
||
| 44 |
- #' # CMH example with strata+ #' df_explicit_na(my_data, logical_as_factor = TRUE) |
||
| 45 |
- #' s_proportion_diff(+ #' # Encode missing values in a subset of columns. |
||
| 46 |
- #' df = subset(dta, grp == "A"),+ #' df_explicit_na(my_data, omit_columns = c("x", "y"))
|
||
| 47 |
- #' .var = "rsp",+ #' |
||
| 48 |
- #' .ref_group = subset(dta, grp == "B"),+ #' # Example 2 |
||
| 49 |
- #' .in_ref_col = FALSE,+ #' # Here we purposefully convert all `M` values to `NA` in the `SEX` variable. |
||
| 50 |
- #' variables = list(strata = c("f1", "f2")),
+ #' # After running `df_explicit_na` the `NA` values are encoded as `<Missing>` but they are not |
||
| 51 |
- #' conf_level = 0.90,+ #' # included when generating `rtables`. |
||
| 52 |
- #' method = "cmh"+ #' adsl <- tern_ex_adsl |
||
| 53 |
- #' )+ #' adsl$SEX[adsl$SEX == "M"] <- NA |
||
| 54 |
- #'+ #' adsl <- df_explicit_na(adsl) |
||
| 55 |
- #' @export+ #' |
||
| 56 |
- s_proportion_diff <- function(df,+ #' # If you want the `Na` values to be displayed in the table use the `na_level` argument. |
||
| 57 |
- .var,+ #' adsl <- tern_ex_adsl |
||
| 58 |
- .ref_group,+ #' adsl$SEX[adsl$SEX == "M"] <- NA |
||
| 59 |
- .in_ref_col,+ #' adsl <- df_explicit_na(adsl, na_level = "Missing Values") |
||
| 60 |
- variables = list(strata = NULL),+ #' |
||
| 61 |
- conf_level = 0.95,+ #' # Example 3 |
||
| 62 |
- method = c(+ #' # Numeric variables that have missing values are not altered. This means that any `NA` value in |
||
| 63 |
- "waldcc", "wald", "cmh",+ #' # a numeric variable will not be included in the summary statistics, nor will they be included |
||
| 64 |
- "ha", "newcombe", "newcombecc",+ #' # in the denominator value for calculating the percent values. |
||
| 65 |
- "strat_newcombe", "strat_newcombecc"+ #' adsl <- tern_ex_adsl |
||
| 66 |
- ),+ #' adsl$AGE[adsl$AGE < 30] <- NA |
||
| 67 |
- weights_method = "cmh") {
+ #' adsl <- df_explicit_na(adsl) |
||
| 68 | -2x | +
- method <- match.arg(method)+ #' |
|
| 69 | -2x | +
- if (is.null(variables$strata) && checkmate::test_subset(method, c("cmh", "strat_newcombe", "strat_newcombecc"))) {
+ #' @export |
|
| 70 | -! | +
- stop(paste(+ df_explicit_na <- function(data, |
|
| 71 | -! | +
- "When performing an unstratified analysis, methods 'cmh', 'strat_newcombe', and 'strat_newcombecc' are not",+ omit_columns = NULL, |
|
| 72 | -! | +
- "permitted. Please choose a different method."+ char_as_factor = TRUE, |
|
| 73 |
- ))+ logical_as_factor = FALSE, |
||
| 74 |
- }+ na_level = "<Missing>") {
|
||
| 75 | -2x | +24x |
- y <- list(diff = "", diff_ci = "")+ checkmate::assert_character(omit_columns, null.ok = TRUE, min.len = 1, any.missing = FALSE) |
| 76 | -+ | 23x |
-
+ checkmate::assert_data_frame(data) |
| 77 | -2x | +22x |
- if (!.in_ref_col) {
+ checkmate::assert_flag(char_as_factor) |
| 78 | -2x | +21x |
- rsp <- c(.ref_group[[.var]], df[[.var]])+ checkmate::assert_flag(logical_as_factor) |
| 79 | -2x | +21x |
- grp <- factor(+ checkmate::assert_string(na_level) |
| 80 | -2x | +
- rep(+ |
|
| 81 | -2x | +19x |
- c("ref", "Not-ref"),
+ target_vars <- if (is.null(omit_columns)) {
|
| 82 | -2x | +17x |
- c(nrow(.ref_group), nrow(df))+ names(data) |
| 83 |
- ),+ } else {
|
||
| 84 | 2x |
- levels = c("ref", "Not-ref")
+ setdiff(names(data), omit_columns) # May have duplicates. |
|
| 85 |
- )+ } |
||
| 86 | -+ | 19x |
-
+ if (length(target_vars) == 0) {
|
| 87 | -2x | +1x |
- if (!is.null(variables$strata)) {
+ return(data) |
| 88 | -1x | +
- strata_colnames <- variables$strata+ } |
|
| 89 | -1x | +
- checkmate::assert_character(strata_colnames, null.ok = FALSE)+ |
|
| 90 | -1x | +18x |
- strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)+ l_target_vars <- split(target_vars, target_vars) |
| 92 | -1x | +
- assert_df_with_variables(df, strata_vars)+ # Makes sure target_vars exist in data and names are not duplicated. |
|
| 93 | -1x | +18x |
- assert_df_with_variables(.ref_group, strata_vars)+ assert_df_with_variables(data, l_target_vars) |
| 95 | -+ | 18x |
- # Merging interaction strata for reference group rows data and remaining+ for (x in target_vars) {
|
| 96 | -1x | +306x |
- strata <- c(+ xi <- data[[x]] |
| 97 | -1x | +306x |
- interaction(.ref_group[strata_colnames]),+ xi_label <- obj_label(xi) |
| 98 | -1x | +
- interaction(df[strata_colnames])+ |
|
| 99 |
- )+ # Determine whether to convert character or logical input. |
||
| 100 | -1x | +306x |
- strata <- as.factor(strata)+ do_char_conversion <- is.character(xi) && char_as_factor |
| 101 | -+ | 306x |
- }+ do_logical_conversion <- is.logical(xi) && logical_as_factor |
| 103 |
- # Defining the std way to calculate weights for strat_newcombe+ # Pre-convert logical to character to deal correctly with replacing NA |
||
| 104 | -2x | +
- if (!is.null(variables$weights_method)) {
+ # values below. |
|
| 105 | -! | -
- weights_method <- variables$weights_method- |
- |
| 106 | -+ | 306x |
- } else {
+ if (do_logical_conversion) {
|
| 107 | +106 | 2x |
- weights_method <- "cmh"+ xi <- as.character(xi) |
| 108 | +107 |
} |
|
| 109 | +108 | ||
| 109 | +306x | +
+ if (is.factor(xi) || is.character(xi)) {
+ |
+ |
| 110 | -2x | +
- y <- switch(method,+ # Handle empty strings and NA values. |
|
| 111 | -2x | +219x |
- "wald" = prop_diff_wald(rsp, grp, conf_level, correct = FALSE),+ xi <- explicit_na(sas_na(xi), label = na_level) |
| 112 | -2x | +
- "waldcc" = prop_diff_wald(rsp, grp, conf_level, correct = TRUE),+ |
|
| 113 | -2x | +
- "ha" = prop_diff_ha(rsp, grp, conf_level),+ # Convert to factors if requested for the original type, |
|
| 114 | -2x | +
- "newcombe" = prop_diff_nc(rsp, grp, conf_level, correct = FALSE),+ # set na_level as the last value. |
|
| 115 | -2x | +219x |
- "newcombecc" = prop_diff_nc(rsp, grp, conf_level, correct = TRUE),+ if (do_char_conversion || do_logical_conversion) {
|
| 116 | -2x | +78x |
- "strat_newcombe" = prop_diff_strat_nc(rsp,+ levels_xi <- setdiff(sort(unique(xi)), na_level) |
| 117 | -2x | +78x |
- grp,+ if (na_level %in% unique(xi)) {
|
| 118 | -2x | +18x |
- strata,+ levels_xi <- c(levels_xi, na_level) |
| 119 | -2x | +
- weights_method,+ } |
|
| 120 | -2x | +
- conf_level,+ |
|
| 121 | -2x | +78x |
- correct = FALSE+ xi <- factor(xi, levels = levels_xi) |
| 122 |
- ),+ } |
||
| 123 | -2x | +
- "strat_newcombecc" = prop_diff_strat_nc(rsp,+ |
|
| 124 | -2x | +219x |
- grp,+ data[, x] <- formatters::with_label(xi, label = xi_label) |
| 125 | -2x | +
- strata,+ } |
|
| 126 | -2x | +
- weights_method,+ } |
|
| 127 | -2x | +18x |
- conf_level,+ return(data) |
| 128 | -2x | +
- correct = TRUE+ } |
| 129 | +1 |
- ),+ #' Helper function for deriving analysis datasets for select laboratory tables |
||
| 130 | -2x | +|||
| 2 | +
- "cmh" = prop_diff_cmh(rsp, grp, strata, conf_level)[c("diff", "diff_ci")]
+ #' |
|||
| 131 | +3 |
- )+ #' @description `r lifecycle::badge("stable")`
|
||
| 132 | +4 |
-
+ #' |
||
| 133 | -2x | +|||
| 5 | +
- y$diff <- y$diff * 100+ #' Helper function that merges ADSL and ADLB datasets so that missing lab test records are inserted in the |
|||
| 134 | -2x | +|||
| 6 | +
- y$diff_ci <- y$diff_ci * 100+ #' output dataset. Remember that `na_level` must match the needed pre-processing |
|||
| 135 | +7 |
- }+ #' done with [df_explicit_na()] to have the desired output. |
||
| 136 | +8 |
-
+ #' |
||
| 137 | -2x | +|||
| 9 | +
- attr(y$diff, "label") <- "Difference in Response rate (%)"+ #' @param adsl (`data.frame`)\cr ADSL data frame. |
|||
| 138 | -2x | +|||
| 10 | +
- attr(y$diff_ci, "label") <- d_proportion_diff(+ #' @param adlb (`data.frame`)\cr ADLB data frame. |
|||
| 139 | -2x | +|||
| 11 | +
- conf_level, method,+ #' @param worst_flag (named `character`)\cr worst post-baseline lab flag variable. See how this is implemented in the |
|||
| 140 | -2x | +|||
| 12 | +
- long = FALSE+ #' following examples. |
|||
| 141 | +13 |
- )+ #' @param by_visit (`flag`)\cr defaults to `FALSE` to generate worst grade per patient. |
||
| 142 | +14 |
-
+ #' If worst grade per patient per visit is specified for `worst_flag`, then |
||
| 143 | -2x | +|||
| 15 | +
- y+ #' `by_visit` should be `TRUE` to generate worst grade patient per visit. |
|||
| 144 | +16 |
- }+ #' @param no_fillin_visits (named `character`)\cr visits that are not considered for post-baseline worst toxicity |
||
| 145 | +17 |
-
+ #' grade. Defaults to `c("SCREENING", "BASELINE")`.
|
||
| 146 | +18 |
- #' @describeIn prop_diff Formatted analysis function which is used as `afun` in `estimate_proportion_diff()`.+ #' |
||
| 147 | +19 |
- #'+ #' @return `df` containing variables shared between `adlb` and `adsl` along with variables `PARAM`, `PARAMCD`, |
||
| 148 | +20 |
- #' @return+ #' `ATOXGR`, and `BTOXGR` relevant for analysis. Optionally, `AVISIT` are `AVISITN` are included when |
||
| 149 | +21 |
- #' * `a_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()].+ #' `by_visit = TRUE` and `no_fillin_visits = c("SCREENING", "BASELINE")`.
|
||
| 150 | +22 |
#' |
||
| 151 | +23 |
- #' @examples+ #' @details In the result data missing records will be created for the following situations: |
||
| 152 | +24 |
- #' a_proportion_diff(+ #' * Patients who are present in `adsl` but have no lab data in `adlb` (both baseline and post-baseline). |
||
| 153 | +25 |
- #' df = subset(dta, grp == "A"),+ #' * Patients who do not have any post-baseline lab values. |
||
| 154 | +26 |
- #' .var = "rsp",+ #' * Patients without any post-baseline values flagged as the worst. |
||
| 155 | +27 |
- #' .ref_group = subset(dta, grp == "B"),+ #' |
||
| 156 | +28 |
- #' .in_ref_col = FALSE,+ #' @examples |
||
| 157 | +29 |
- #' conf_level = 0.90,+ #' # `h_adsl_adlb_merge_using_worst_flag` |
||
| 158 | +30 |
- #' method = "ha"+ #' adlb_out <- h_adsl_adlb_merge_using_worst_flag( |
||
| 159 | +31 |
- #' )+ #' tern_ex_adsl, |
||
| 160 | +32 |
- #'+ #' tern_ex_adlb, |
||
| 161 | +33 |
- #' @export+ #' worst_flag = c("WGRHIFL" = "Y")
|
||
| 162 | +34 |
- a_proportion_diff <- make_afun(+ #' ) |
||
| 163 | +35 |
- s_proportion_diff,+ #' |
||
| 164 | +36 |
- .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"),+ #' # `h_adsl_adlb_merge_using_worst_flag` by visit example |
||
| 165 | +37 |
- .indent_mods = c(diff = 0L, diff_ci = 1L)+ #' adlb_out_by_visit <- h_adsl_adlb_merge_using_worst_flag( |
||
| 166 | +38 |
- )+ #' tern_ex_adsl, |
||
| 167 | +39 |
-
+ #' tern_ex_adlb, |
||
| 168 | +40 |
- #' @describeIn prop_diff Layout-creating function which can take statistics function arguments+ #' worst_flag = c("WGRLOVFL" = "Y"),
|
||
| 169 | +41 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' by_visit = TRUE |
||
| 170 | +42 |
- #'+ #' ) |
||
| 171 | +43 |
- #' @return+ #' |
||
| 172 | +44 |
- #' * `estimate_proportion_diff()` returns a layout object suitable for passing to further layouting functions,+ #' @export |
||
| 173 | +45 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ h_adsl_adlb_merge_using_worst_flag <- function(adsl, # nolint |
||
| 174 | +46 |
- #' the statistics from `s_proportion_diff()` to the table layout.+ adlb, |
||
| 175 | +47 |
- #'+ worst_flag = c("WGRHIFL" = "Y"),
|
||
| 176 | +48 |
- #' @examples+ by_visit = FALSE, |
||
| 177 | +49 |
- #' ## "Mid" case: 4/4 respond in group A, 1/2 respond in group B.+ no_fillin_visits = c("SCREENING", "BASELINE")) {
|
||
| 178 | -+ | |||
| 50 | +5x |
- #' nex <- 100 # Number of example rows+ col_names <- names(worst_flag) |
||
| 179 | -+ | |||
| 51 | +5x |
- #' dta <- data.frame(+ filter_values <- worst_flag |
||
| 180 | +52 |
- #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE),+ |
||
| 181 | -+ | |||
| 53 | +5x |
- #' "grp" = sample(c("A", "B"), nex, TRUE),
+ temp <- Map( |
||
| 182 | -+ | |||
| 54 | +5x |
- #' "f1" = sample(c("a1", "a2"), nex, TRUE),
+ function(x, y) which(adlb[[x]] == y), |
||
| 183 | -+ | |||
| 55 | +5x |
- #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
+ col_names, |
||
| 184 | -+ | |||
| 56 | +5x |
- #' stringsAsFactors = TRUE+ filter_values |
||
| 185 | +57 |
- #' )+ ) |
||
| 186 | +58 |
- #'+ |
||
| 187 | -+ | |||
| 59 | +5x |
- #' l <- basic_table() %>%+ position_satisfy_filters <- Reduce(intersect, temp) |
||
| 188 | +60 |
- #' split_cols_by(var = "grp", ref_group = "B") %>%+ |
||
| 189 | -+ | |||
| 61 | +5x |
- #' estimate_proportion_diff(+ adsl_adlb_common_columns <- intersect(colnames(adsl), colnames(adlb)) |
||
| 190 | -+ | |||
| 62 | +5x |
- #' vars = "rsp",+ columns_from_adlb <- c("USUBJID", "PARAM", "PARAMCD", "AVISIT", "AVISITN", "ATOXGR", "BTOXGR")
|
||
| 191 | +63 |
- #' conf_level = 0.90,+ |
||
| 192 | -+ | |||
| 64 | +5x |
- #' method = "ha"+ adlb_f <- adlb[position_satisfy_filters, ] %>% |
||
| 193 | -+ | |||
| 65 | +5x |
- #' )+ dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) |
||
| 194 | -+ | |||
| 66 | +5x |
- #'+ adlb_f <- adlb_f[, columns_from_adlb] |
||
| 195 | +67 |
- #' build_table(l, df = dta)+ |
||
| 196 | -+ | |||
| 68 | +5x |
- #'+ avisits_grid <- adlb %>% |
||
| 197 | -+ | |||
| 69 | +5x |
- #' @export+ dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) %>% |
||
| 198 | -+ | |||
| 70 | +5x |
- #' @order 2+ dplyr::pull(.data[["AVISIT"]]) %>% |
||
| 199 | -+ | |||
| 71 | +5x |
- estimate_proportion_diff <- function(lyt,+ unique() |
||
| 200 | +72 |
- vars,+ |
||
| 201 | -+ | |||
| 73 | +5x |
- variables = list(strata = NULL),+ if (by_visit) {
|
||
| 202 | -+ | |||
| 74 | +1x |
- conf_level = 0.95,+ adsl_lb <- expand.grid( |
||
| 203 | -+ | |||
| 75 | +1x |
- method = c(+ USUBJID = unique(adsl$USUBJID), |
||
| 204 | -+ | |||
| 76 | +1x |
- "waldcc", "wald", "cmh",+ AVISIT = avisits_grid, |
||
| 205 | -+ | |||
| 77 | +1x |
- "ha", "newcombe", "newcombecc",+ PARAMCD = unique(adlb$PARAMCD) |
||
| 206 | +78 |
- "strat_newcombe", "strat_newcombecc"+ ) |
||
| 207 | +79 |
- ),+ + |
+ ||
| 80 | +1x | +
+ adsl_lb <- adsl_lb %>%+ |
+ ||
| 81 | +1x | +
+ dplyr::left_join(unique(adlb[c("AVISIT", "AVISITN")]), by = "AVISIT") %>%
+ |
+ ||
| 82 | +1x | +
+ dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
|
||
| 208 | +83 |
- weights_method = "cmh",+ + |
+ ||
| 84 | +1x | +
+ adsl1 <- adsl[, adsl_adlb_common_columns]+ |
+ ||
| 85 | +1x | +
+ adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID") |
||
| 209 | +86 |
- na_str = default_na_str(),+ + |
+ ||
| 87 | +1x | +
+ by_variables_from_adlb <- c("USUBJID", "AVISIT", "AVISITN", "PARAMCD", "PARAM")
|
||
| 210 | +88 |
- nested = TRUE,+ + |
+ ||
| 89 | +1x | +
+ adlb_btoxgr <- adlb %>%+ |
+ ||
| 90 | +1x | +
+ dplyr::select(c("USUBJID", "PARAMCD", "BTOXGR")) %>%
+ |
+ ||
| 91 | +1x | +
+ unique() %>%+ |
+ ||
| 92 | +1x | +
+ dplyr::rename("BTOXGR_MAP" = "BTOXGR")
|
||
| 211 | +93 |
- ...,+ + |
+ ||
| 94 | +1x | +
+ adlb_out <- merge(+ |
+ ||
| 95 | +1x | +
+ adlb_f,+ |
+ ||
| 96 | +1x | +
+ adsl_lb,+ |
+ ||
| 97 | +1x | +
+ by = by_variables_from_adlb,+ |
+ ||
| 98 | +1x | +
+ all = TRUE,+ |
+ ||
| 99 | +1x | +
+ sort = FALSE |
||
| 212 | +100 |
- var_labels = vars,+ )+ |
+ ||
| 101 | +1x | +
+ adlb_out <- adlb_out %>%+ |
+ ||
| 102 | +1x | +
+ dplyr::left_join(adlb_btoxgr, by = c("USUBJID", "PARAMCD")) %>%
+ |
+ ||
| 103 | +1x | +
+ dplyr::mutate(BTOXGR = .data$BTOXGR_MAP) %>%+ |
+ ||
| 104 | +1x | +
+ dplyr::select(-"BTOXGR_MAP") |
||
| 213 | +105 |
- show_labels = "hidden",+ + |
+ ||
| 106 | +1x | +
+ adlb_var_labels <- c(+ |
+ ||
| 107 | +1x | +
+ formatters::var_labels(adlb[by_variables_from_adlb]),+ |
+ ||
| 108 | +1x | +
+ formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]),+ |
+ ||
| 109 | +1x | +
+ formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]]) |
||
| 214 | +110 |
- table_names = vars,+ ) |
||
| 215 | +111 |
- .stats = NULL,+ } else {
+ |
+ ||
| 112 | +4x | +
+ adsl_lb <- expand.grid(+ |
+ ||
| 113 | +4x | +
+ USUBJID = unique(adsl$USUBJID),+ |
+ ||
| 114 | +4x | +
+ PARAMCD = unique(adlb$PARAMCD) |
||
| 216 | +115 |
- .formats = NULL,+ ) |
||
| 217 | +116 |
- .labels = NULL,+ + |
+ ||
| 117 | +4x | +
+ adsl_lb <- adsl_lb %>% dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
|
||
| 218 | +118 |
- .indent_mods = NULL) {
+
|
||
| 219 | +119 | 4x |
- extra_args <- list(+ adsl1 <- adsl[, adsl_adlb_common_columns] |
|
| 220 | +120 | 4x |
- variables = variables, conf_level = conf_level, method = method, weights_method = weights_method, ...+ adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID") |
|
| 221 | +121 |
- )+ + |
+ ||
| 122 | +4x | +
+ by_variables_from_adlb <- c("USUBJID", "PARAMCD", "PARAM")
|
||
| 222 | +123 | |||
| 223 | +124 | 4x |
- afun <- make_afun(+ adlb_out <- merge( |
|
| 224 | +125 | 4x |
- a_proportion_diff,+ adlb_f, |
|
| 225 | +126 | 4x |
- .stats = .stats,+ adsl_lb, |
|
| 226 | +127 | 4x |
- .formats = .formats,+ by = by_variables_from_adlb, |
|
| 227 | +128 | 4x |
- .labels = .labels,+ all = TRUE, |
|
| 228 | +129 | 4x |
- .indent_mods = .indent_mods+ sort = FALSE |
|
| 229 | +130 |
- )+ ) |
||
| 230 | +131 | |||
| 231 | +132 | 4x |
- analyze(+ adlb_var_labels <- c( |
|
| 232 | +133 | 4x |
- lyt,+ formatters::var_labels(adlb[by_variables_from_adlb]), |
|
| 233 | +134 | 4x |
- vars,+ formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]), |
|
| 234 | +135 | 4x |
- afun = afun,+ formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]])+ |
+ |
| 136 | ++ |
+ )+ |
+ ||
| 137 | ++ |
+ }+ |
+ ||
| 138 | ++ | + | ||
| 235 | -4x | +139 | +5x |
- var_labels = var_labels,+ adlb_out$ATOXGR <- as.factor(adlb_out$ATOXGR) |
| 236 | -4x | +140 | +5x | +
+ adlb_out$BTOXGR <- as.factor(adlb_out$BTOXGR)+ |
+
| 141 | ++ | + + | +||
| 142 | +5x | +
+ formatters::var_labels(adlb_out) <- adlb_var_labels+ |
+ ||
| 143 | ++ | + + | +||
| 144 | +5x | +
+ adlb_out+ |
+ ||
| 145 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Tabulate survival duration by subgroup+ |
+ ||
| 2 | ++ |
+ #'+ |
+ ||
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+ ||
| 4 | +
- na_str = na_str,+ #' |
|||
| 237 | -4x | +|||
| 5 | +
- nested = nested,+ #' The [tabulate_survival_subgroups()] function creates a layout element to tabulate survival duration by subgroup, |
|||
| 238 | -4x | +|||
| 6 | +
- extra_args = extra_args,+ #' returning statistics including median survival time and hazard ratio for each population subgroup. The table is |
|||
| 239 | -4x | +|||
| 7 | +
- show_labels = show_labels,+ #' created from `df`, a list of data frames returned by [extract_survival_subgroups()], with the statistics to include |
|||
| 240 | -4x | +|||
| 8 | +
- table_names = table_names+ #' specified via the `vars` parameter. |
|||
| 241 | +9 |
- )+ #' |
||
| 242 | +10 |
- }+ #' A forest plot can be created from the resulting table using the [g_forest()] function. |
||
| 243 | +11 |
-
+ #' |
||
| 244 | +12 |
- #' Check proportion difference arguments+ #' @inheritParams argument_convention |
||
| 245 | +13 |
- #'+ #' @inheritParams survival_coxph_pairwise |
||
| 246 | +14 |
- #' Verifies that and/or convert arguments into valid values to be used in the+ #' @param df (`list`)\cr list of data frames containing all analysis variables. List should be |
||
| 247 | +15 |
- #' estimation of difference in responder proportions.+ #' created using [extract_survival_subgroups()]. |
||
| 248 | +16 |
- #'+ #' @param vars (`character`)\cr the names of statistics to be reported among: |
||
| 249 | +17 |
- #' @inheritParams prop_diff+ #' * `n_tot_events`: Total number of events per group. |
||
| 250 | +18 |
- #' @inheritParams prop_diff_wald+ #' * `n_events`: Number of events per group. |
||
| 251 | +19 |
- #'+ #' * `n_tot`: Total number of observations per group. |
||
| 252 | +20 |
- #' @keywords internal+ #' * `n`: Number of observations per group. |
||
| 253 | +21 |
- check_diff_prop_ci <- function(rsp,+ #' * `median`: Median survival time. |
||
| 254 | +22 |
- grp,+ #' * `hr`: Hazard ratio. |
||
| 255 | +23 |
- strata = NULL,+ #' * `ci`: Confidence interval of hazard ratio. |
||
| 256 | +24 |
- conf_level,+ #' * `pval`: p-value of the effect. |
||
| 257 | +25 |
- correct = NULL) {
+ #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` |
||
| 258 | -26x | +|||
| 26 | +
- checkmate::assert_logical(rsp, any.missing = FALSE)+ #' are required. |
|||
| 259 | -26x | +|||
| 27 | +
- checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2)+ #' @param time_unit (`string`)\cr label with unit of median survival time. Default `NULL` skips displaying unit. |
|||
| 260 | -26x | +|||
| 28 | +
- checkmate::assert_number(conf_level, lower = 0, upper = 1)+ #' |
|||
| 261 | -26x | +|||
| 29 | +
- checkmate::assert_flag(correct, null.ok = TRUE)+ #' @details These functions create a layout starting from a data frame which contains |
|||
| 262 | +30 |
-
+ #' the required statistics. Tables typically used as part of forest plot. |
||
| 263 | -26x | +|||
| 31 | +
- if (!is.null(strata)) {
+ #' |
|||
| 264 | -12x | +|||
| 32 | +
- checkmate::assert_factor(strata, len = length(rsp))+ #' @seealso [extract_survival_subgroups()] |
|||
| 265 | +33 |
- }+ #' |
||
| 266 | +34 |
-
+ #' @examples |
||
| 267 | -26x | +|||
| 35 | +
- invisible()+ #' library(dplyr) |
|||
| 268 | +36 |
- }+ #' |
||
| 269 | +37 |
-
+ #' adtte <- tern_ex_adtte |
||
| 270 | +38 |
- #' Description of method used for proportion comparison+ #' |
||
| 271 | +39 |
- #'+ #' # Save variable labels before data processing steps. |
||
| 272 | +40 |
- #' @description `r lifecycle::badge("stable")`
+ #' adtte_labels <- formatters::var_labels(adtte) |
||
| 273 | +41 |
#' |
||
| 274 | +42 |
- #' This is an auxiliary function that describes the analysis in+ #' adtte_f <- adtte %>% |
||
| 275 | +43 |
- #' [s_proportion_diff()].+ #' filter( |
||
| 276 | +44 |
- #'+ #' PARAMCD == "OS", |
||
| 277 | +45 |
- #' @inheritParams s_proportion_diff+ #' ARM %in% c("B: Placebo", "A: Drug X"),
|
||
| 278 | +46 |
- #' @param long (`flag`)\cr whether a long (`TRUE`) or a short (`FALSE`, default) description is required.+ #' SEX %in% c("M", "F")
|
||
| 279 | +47 |
- #'+ #' ) %>% |
||
| 280 | +48 |
- #' @return A `string` describing the analysis.+ #' mutate( |
||
| 281 | +49 |
- #'+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
||
| 282 | +50 |
- #' @seealso [prop_diff]+ #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")), |
||
| 283 | +51 |
- #'+ #' SEX = droplevels(SEX), |
||
| 284 | +52 |
- #' @export+ #' AVALU = as.character(AVALU), |
||
| 285 | +53 |
- d_proportion_diff <- function(conf_level,+ #' is_event = CNSR == 0 |
||
| 286 | +54 |
- method,+ #' ) |
||
| 287 | +55 |
- long = FALSE) {
+ #' labels <- c( |
||
| 288 | -11x | +|||
| 56 | +
- label <- paste0(conf_level * 100, "% CI")+ #' "ARM" = adtte_labels[["ARM"]], |
|||
| 289 | -11x | +|||
| 57 | +
- if (long) {
+ #' "SEX" = adtte_labels[["SEX"]], |
|||
| 290 | -! | +|||
| 58 | +
- label <- paste(+ #' "AVALU" = adtte_labels[["AVALU"]], |
|||
| 291 | -! | +|||
| 59 | +
- label,+ #' "is_event" = "Event Flag" |
|||
| 292 | -! | +|||
| 60 | +
- ifelse(+ #' ) |
|||
| 293 | -! | +|||
| 61 | +
- method == "cmh",+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
|||
| 294 | -! | +|||
| 62 | +
- "for adjusted difference",+ #' |
|||
| 295 | -! | +|||
| 63 | +
- "for difference"+ #' df <- extract_survival_subgroups( |
|||
| 296 | +64 |
- )+ #' variables = list( |
||
| 297 | +65 |
- )+ #' tte = "AVAL", |
||
| 298 | +66 |
- }+ #' is_event = "is_event", |
||
| 299 | +67 |
-
+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
|
||
| 300 | -11x | +|||
| 68 | +
- method_part <- switch(method,+ #' ), |
|||
| 301 | -11x | +|||
| 69 | +
- "cmh" = "CMH, without correction",+ #' label_all = "Total Patients", |
|||
| 302 | -11x | +|||
| 70 | +
- "waldcc" = "Wald, with correction",+ #' data = adtte_f |
|||
| 303 | -11x | +|||
| 71 | +
- "wald" = "Wald, without correction",+ #' ) |
|||
| 304 | -11x | +|||
| 72 | +
- "ha" = "Anderson-Hauck",+ #' df |
|||
| 305 | -11x | +|||
| 73 | +
- "newcombe" = "Newcombe, without correction",+ #' |
|||
| 306 | -11x | +|||
| 74 | +
- "newcombecc" = "Newcombe, with correction",+ #' df_grouped <- extract_survival_subgroups( |
|||
| 307 | -11x | +|||
| 75 | +
- "strat_newcombe" = "Stratified Newcombe, without correction",+ #' variables = list( |
|||
| 308 | -11x | +|||
| 76 | +
- "strat_newcombecc" = "Stratified Newcombe, with correction",+ #' tte = "AVAL", |
|||
| 309 | -11x | +|||
| 77 | +
- stop(paste(method, "does not have a description"))+ #' is_event = "is_event", |
|||
| 310 | +78 |
- )+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
|
||
| 311 | -11x | +|||
| 79 | +
- paste0(label, " (", method_part, ")")
+ #' ), |
|||
| 312 | +80 |
- }+ #' data = adtte_f, |
||
| 313 | +81 |
-
+ #' groups_lists = list( |
||
| 314 | +82 |
- #' Helper functions to calculate proportion difference+ #' BMRKR2 = list( |
||
| 315 | +83 |
- #'+ #' "low" = "LOW", |
||
| 316 | +84 |
- #' @description `r lifecycle::badge("stable")`
+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 317 | +85 |
- #'+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 318 | +86 |
- #' @inheritParams argument_convention+ #' ) |
||
| 319 | +87 |
- #' @inheritParams prop_diff+ #' ) |
||
| 320 | +88 |
- #' @param grp (`factor`)\cr vector assigning observations to one out of two groups+ #' ) |
||
| 321 | +89 |
- #' (e.g. reference and treatment group).+ #' df_grouped |
||
| 322 | +90 |
#' |
||
| 323 | +91 |
- #' @return A named `list` of elements `diff` (proportion difference) and `diff_ci`+ #' @name survival_duration_subgroups |
||
| 324 | +92 |
- #' (proportion difference confidence interval).+ #' @order 1 |
||
| 325 | +93 |
- #'+ NULL |
||
| 326 | +94 |
- #' @seealso [prop_diff()] for implementation of these helper functions.+ |
||
| 327 | +95 | ++ |
+ #' Prepare survival data for population subgroups in data frames+ |
+ |
| 96 |
#' |
|||
| 328 | +97 |
- #' @name h_prop_diff+ #' @description `r lifecycle::badge("stable")`
|
||
| 329 | +98 |
- NULL+ #' |
||
| 330 | +99 |
-
+ #' Prepares estimates of median survival times and treatment hazard ratios for population subgroups in |
||
| 331 | +100 |
- #' @describeIn h_prop_diff The Wald interval follows the usual textbook+ #' data frames. Simple wrapper for [h_survtime_subgroups_df()] and [h_coxph_subgroups_df()]. Result is a `list` |
||
| 332 | +101 |
- #' definition for a single proportion confidence interval using the normal+ #' of two `data.frame`s: `survtime` and `hr`. `variables` corresponds to the names of variables found in `data`, |
||
| 333 | +102 |
- #' approximation. It is possible to include a continuity correction for Wald's+ #' passed as a named `list` and requires elements `tte`, `is_event`, `arm` and optionally `subgroups` and `strata`. |
||
| 334 | +103 |
- #' interval.+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
||
| 335 | +104 |
#' |
||
| 336 | +105 |
- #' @param correct (`flag`)\cr whether to include the continuity correction. For further+ #' @inheritParams argument_convention |
||
| 337 | +106 |
- #' information, see [stats::prop.test()].+ #' @inheritParams survival_duration_subgroups |
||
| 338 | +107 | ++ |
+ #' @inheritParams survival_coxph_pairwise+ |
+ |
| 108 |
#' |
|||
| 339 | +109 |
- #' @examples+ #' @return A named `list` of two elements: |
||
| 340 | +110 |
- #' # Wald confidence interval+ #' * `survtime`: A `data.frame` containing columns `arm`, `n`, `n_events`, `median`, `subgroup`, `var`, |
||
| 341 | +111 |
- #' set.seed(2)+ #' `var_label`, and `row_type`. |
||
| 342 | +112 |
- #' rsp <- sample(c(TRUE, FALSE), replace = TRUE, size = 20)+ #' * `hr`: A `data.frame` containing columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`, `conf_level`, |
||
| 343 | +113 |
- #' grp <- factor(c(rep("A", 10), rep("B", 10)))
+ #' `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`. |
||
| 344 | +114 |
#' |
||
| 345 | +115 |
- #' prop_diff_wald(rsp = rsp, grp = grp, conf_level = 0.95, correct = FALSE)+ #' @seealso [survival_duration_subgroups] |
||
| 346 | +116 |
#' |
||
| 347 | +117 |
#' @export |
||
| 348 | +118 |
- prop_diff_wald <- function(rsp,+ extract_survival_subgroups <- function(variables, |
||
| 349 | +119 |
- grp,+ data, |
||
| 350 | +120 |
- conf_level = 0.95,+ groups_lists = list(), |
||
| 351 | +121 |
- correct = FALSE) {
+ control = control_coxph(), |
||
| 352 | -8x | +|||
| 122 | +
- if (isTRUE(correct)) {
+ label_all = "All Patients") {
|
|||
| 353 | -5x | +123 | +12x |
- mthd <- "waldcc"+ if ("strat" %in% names(variables)) {
|
| 354 | -+ | |||
| 124 | +! |
- } else {
+ warning( |
||
| 355 | -3x | +|||
| 125 | +! |
- mthd <- "wald"+ "Warning: the `strat` element name of the `variables` list argument to `extract_survival_subgroups() ", |
||
| 356 | -+ | |||
| 126 | +! |
- }+ "was deprecated in tern 0.9.4.\n ", |
||
| 357 | -8x | +|||
| 127 | +! |
- grp <- as_factor_keep_attributes(grp)+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 358 | -8x | +|||
| 128 | +
- check_diff_prop_ci(+ ) |
|||
| 359 | -8x | +|||
| 129 | +! |
- rsp = rsp, grp = grp, conf_level = conf_level, correct = correct+ variables[["strata"]] <- variables[["strat"]] |
||
| 360 | +130 |
- )+ } |
||
| 361 | +131 | |||
| 362 | -+ | |||
| 132 | +12x |
- # check if binary response is coded as logical+ df_survtime <- h_survtime_subgroups_df( |
||
| 363 | -8x | +133 | +12x |
- checkmate::assert_logical(rsp, any.missing = FALSE)+ variables, |
| 364 | -8x | +134 | +12x |
- checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2)+ data, |
| 365 | -+ | |||
| 135 | +12x |
-
+ groups_lists = groups_lists, |
||
| 366 | -8x | +136 | +12x |
- tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ label_all = label_all |
| 367 | +137 |
- # x1 and n1 are non-reference groups.+ ) |
||
| 368 | -8x | +138 | +12x |
- diff_ci <- desctools_binom(+ df_hr <- h_coxph_subgroups_df( |
| 369 | -8x | +139 | +12x |
- x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ variables, |
| 370 | -8x | +140 | +12x |
- x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ data, |
| 371 | -8x | +141 | +12x |
- conf.level = conf_level,+ groups_lists = groups_lists, |
| 372 | -8x | +142 | +12x |
- method = mthd+ control = control,+ |
+
| 143 | +12x | +
+ label_all = label_all |
||
| 373 | +144 |
) |
||
| 374 | +145 | |||
| 375 | -8x | +146 | +12x |
- list(+ list(survtime = df_survtime, hr = df_hr) |
| 376 | -8x | +|||
| 147 | +
- "diff" = unname(diff_ci[, "est"]),+ } |
|||
| 377 | -8x | +|||
| 148 | +
- "diff_ci" = unname(diff_ci[, c("lwr.ci", "upr.ci")])
+
|
|||
| 378 | +149 |
- )+ #' @describeIn survival_duration_subgroups Formatted analysis function which is used as |
||
| 379 | +150 |
- }+ #' `afun` in `tabulate_survival_subgroups()`. |
||
| 380 | +151 |
-
+ #' |
||
| 381 | +152 |
- #' @describeIn h_prop_diff Anderson-Hauck confidence interval.+ #' @return |
||
| 382 | +153 |
- #'+ #' * `a_survival_subgroups()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 383 | +154 |
- #' @examples+ #' |
||
| 384 | +155 |
- #' # Anderson-Hauck confidence interval+ #' @keywords internal |
||
| 385 | +156 |
- #' ## "Mid" case: 3/4 respond in group A, 1/2 respond in group B.+ a_survival_subgroups <- function(.formats = list( # nolint start |
||
| 386 | +157 |
- #' rsp <- c(TRUE, FALSE, FALSE, TRUE, TRUE, TRUE)+ n = "xx", |
||
| 387 | +158 |
- #' grp <- factor(c("A", "B", "A", "B", "A", "A"), levels = c("B", "A"))
+ n_events = "xx", |
||
| 388 | +159 |
- #'+ n_tot_events = "xx", |
||
| 389 | +160 |
- #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.90)+ median = "xx.x", |
||
| 390 | +161 |
- #'+ n_tot = "xx", |
||
| 391 | +162 |
- #' ## Edge case: Same proportion of response in A and B.+ hr = list(format_extreme_values(2L)), |
||
| 392 | +163 |
- #' rsp <- c(TRUE, FALSE, TRUE, FALSE)+ ci = list(format_extreme_values_ci(2L)), |
||
| 393 | +164 |
- #' grp <- factor(c("A", "A", "B", "B"), levels = c("A", "B"))
+ pval = "x.xxxx | (<0.0001)" |
||
| 394 | +165 |
- #'+ ), |
||
| 395 | +166 |
- #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.6)+ na_str = default_na_str()) { # nolint end
+ |
+ ||
| 167 | +21x | +
+ checkmate::assert_list(.formats)+ |
+ ||
| 168 | +21x | +
+ checkmate::assert_subset(+ |
+ ||
| 169 | +21x | +
+ names(.formats),+ |
+ ||
| 170 | +21x | +
+ c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval", "riskdiff")
|
||
| 396 | +171 |
- #'+ ) |
||
| 397 | +172 |
- #' @export+ + |
+ ||
| 173 | +21x | +
+ afun_lst <- Map(+ |
+ ||
| 174 | +21x | +
+ function(stat, fmt, na_str) {
+ |
+ ||
| 175 | +160x | +
+ function(df, labelstr = "", ...) {
+ |
+ ||
| 176 | +312x | +
+ in_rows(+ |
+ ||
| 177 | +312x | +
+ .list = as.list(df[[stat]]),+ |
+ ||
| 178 | +312x | +
+ .labels = as.character(df$subgroup),+ |
+ ||
| 179 | +312x | +
+ .formats = fmt,+ |
+ ||
| 180 | +312x | +
+ .format_na_strs = na_str |
||
| 398 | +181 |
- prop_diff_ha <- function(rsp,+ ) |
||
| 399 | +182 |
- grp,+ } |
||
| 400 | +183 |
- conf_level) {
+ }, |
||
| 401 | -4x | +184 | +21x |
- grp <- as_factor_keep_attributes(grp)+ stat = names(.formats), |
| 402 | -4x | +185 | +21x |
- check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level)+ fmt = .formats,+ |
+
| 186 | +21x | +
+ na_str = na_str |
||
| 403 | +187 | ++ |
+ )+ |
+ |
| 188 | ||||
| 404 | -4x | +189 | +21x |
- tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ afun_lst |
| 405 | +190 |
- # x1 and n1 are non-reference groups.+ } |
||
| 406 | -4x | +|||
| 191 | +
- ci <- desctools_binom(+ |
|||
| 407 | -4x | +|||
| 192 | +
- x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ #' @describeIn survival_duration_subgroups Table-creating function which creates a table |
|||
| 408 | -4x | +|||
| 193 | +
- x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ #' summarizing survival by subgroup. This function is a wrapper for [rtables::analyze_colvars()] |
|||
| 409 | -4x | +|||
| 194 | +
- conf.level = conf_level,+ #' and [rtables::summarize_row_groups()].+ |
+ |||
| 195 | ++ |
+ #'+ |
+ ||
| 196 | ++ |
+ #' @param label_all `r lifecycle::badge("deprecated")`\cr please assign the `label_all` parameter within the
+ |
+ ||
| 197 | ++ |
+ #' [extract_survival_subgroups()] function when creating `df`.+ |
+ ||
| 198 | ++ |
+ #' @param riskdiff (`list`)\cr if a risk (proportion) difference column should be added, a list of settings to apply |
||
| 410 | -4x | +|||
| 199 | +
- method = "ha"+ #' within the column. See [control_riskdiff()] for details. If `NULL`, no risk difference column will be added. If |
|||
| 411 | +200 |
- )+ #' `riskdiff$arm_x` and `riskdiff$arm_y` are `NULL`, the first level of `df$survtime$arm` will be used as `arm_x` |
||
| 412 | -4x | +|||
| 201 | +
- list(+ #' and the second level as `arm_y`. |
|||
| 413 | -4x | +|||
| 202 | +
- "diff" = unname(ci[, "est"]),+ #' |
|||
| 414 | -4x | +|||
| 203 | +
- "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
+ #' @return An `rtables` table summarizing survival by subgroup. |
|||
| 415 | +204 |
- )+ #' |
||
| 416 | +205 |
- }+ #' @examples |
||
| 417 | +206 |
-
+ #' ## Table with default columns. |
||
| 418 | +207 |
- #' @describeIn h_prop_diff Newcombe confidence interval. It is based on+ #' basic_table() %>% |
||
| 419 | +208 |
- #' the Wilson score confidence interval for a single binomial proportion.+ #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) |
||
| 420 | +209 |
#' |
||
| 421 | +210 |
- #' @examples+ #' ## Table with a manually chosen set of columns: adding "pval". |
||
| 422 | +211 |
- #' # Newcombe confidence interval+ #' basic_table() %>% |
||
| 423 | +212 |
- #'+ #' tabulate_survival_subgroups( |
||
| 424 | +213 |
- #' set.seed(1)+ #' df = df, |
||
| 425 | +214 |
- #' rsp <- c(+ #' vars = c("n_tot_events", "n_events", "median", "hr", "ci", "pval"),
|
||
| 426 | +215 |
- #' sample(c(TRUE, FALSE), size = 40, prob = c(3 / 4, 1 / 4), replace = TRUE),+ #' time_unit = adtte_f$AVALU[1] |
||
| 427 | +216 |
- #' sample(c(TRUE, FALSE), size = 40, prob = c(1 / 2, 1 / 2), replace = TRUE)+ #' ) |
||
| 428 | +217 |
- #' )+ #' |
||
| 429 | +218 |
- #' grp <- factor(rep(c("A", "B"), each = 40), levels = c("B", "A"))
+ #' @export |
||
| 430 | +219 |
- #' table(rsp, grp)+ #' @order 2 |
||
| 431 | +220 |
- #'+ tabulate_survival_subgroups <- function(lyt, |
||
| 432 | +221 |
- #' prop_diff_nc(rsp = rsp, grp = grp, conf_level = 0.9)+ df, |
||
| 433 | +222 |
- #'+ vars = c("n_tot_events", "n_events", "median", "hr", "ci"),
|
||
| 434 | +223 |
- #' @export+ groups_lists = list(), |
||
| 435 | +224 |
- prop_diff_nc <- function(rsp,+ label_all = lifecycle::deprecated(), |
||
| 436 | +225 |
- grp,+ time_unit = NULL, |
||
| 437 | +226 |
- conf_level,+ riskdiff = NULL, |
||
| 438 | +227 |
- correct = FALSE) {
+ na_str = default_na_str(), |
||
| 439 | -2x | +|||
| 228 | +
- if (isTRUE(correct)) {
+ .formats = c( |
|||
| 440 | -! | +|||
| 229 | +
- mthd <- "scorecc"+ n = "xx", n_events = "xx", n_tot_events = "xx", median = "xx.x", n_tot = "xx", |
|||
| 441 | +230 |
- } else {
+ hr = list(format_extreme_values(2L)), ci = list(format_extreme_values_ci(2L)), |
||
| 442 | -2x | +|||
| 231 | +
- mthd <- "score"+ pval = "x.xxxx | (<0.0001)" |
|||
| 443 | +232 |
- }+ )) {
|
||
| 444 | -2x | +233 | +10x |
- grp <- as_factor_keep_attributes(grp)+ checkmate::assert_list(riskdiff, null.ok = TRUE) |
| 445 | -2x | +234 | +10x |
- check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level)+ checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
+ |
+
| 235 | +10x | +
+ checkmate::assert_true(all(c("hr", "ci") %in% vars))
|
||
| 446 | +236 | |||
| 447 | -2x | +237 | +10x |
- p_grp <- tapply(rsp, grp, mean)+ if (lifecycle::is_present(label_all)) {
|
| 448 | -2x | +238 | +1x |
- diff_p <- unname(diff(p_grp))+ lifecycle::deprecate_warn( |
| 449 | -2x | +239 | +1x |
- tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ "0.9.5", "tabulate_survival_subgroups(label_all)", |
| 450 | -2x | +240 | +1x |
- ci <- desctools_binom(+ details =+ |
+
| 241 | +1x | +
+ "Please assign the `label_all` parameter within the `extract_survival_subgroups()` function when creating `df`." |
||
| 451 | +242 |
- # x1 and n1 are non-reference groups.+ ) |
||
| 452 | -2x | +|||
| 243 | +
- x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ } |
|||
| 453 | -2x | +|||
| 244 | +
- x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ |
|||
| 454 | -2x | +|||
| 245 | +
- conf.level = conf_level,+ # Create "ci" column from "lcl" and "ucl" |
|||
| 455 | -2x | +246 | +10x |
- method = mthd+ df$hr$ci <- combine_vectors(df$hr$lcl, df$hr$ucl) |
| 456 | +247 |
- )+ |
||
| 457 | -2x | +|||
| 248 | +
- list(+ # Fill in missing formats with defaults |
|||
| 458 | -2x | +249 | +10x |
- "diff" = unname(ci[, "est"]),+ default_fmts <- eval(formals(tabulate_survival_subgroups)$.formats) |
| 459 | -2x | +250 | +10x |
- "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
+ .formats <- c(.formats, default_fmts[vars[!vars %in% names(.formats)]]) |
| 460 | +251 |
- )+ |
||
| 461 | +252 |
- }+ # Extract additional parameters from df |
||
| 462 | -+ | |||
| 253 | +10x |
-
+ conf_level <- df$hr$conf_level[1] |
||
| 463 | -+ | |||
| 254 | +10x |
- #' @describeIn h_prop_diff Calculates the weighted difference. This is defined as the difference in+ method <- df$hr$pval_label[1] |
||
| 464 | -+ | |||
| 255 | +10x |
- #' response rates between the experimental treatment group and the control treatment group, adjusted+ colvars <- d_survival_subgroups_colvars(vars, conf_level = conf_level, method = method, time_unit = time_unit) |
||
| 465 | -+ | |||
| 256 | +10x |
- #' for stratification factors by applying Cochran-Mantel-Haenszel (CMH) weights. For the CMH chi-squared+ survtime_vars <- intersect(colvars$vars, c("n", "n_events", "median"))
|
||
| 466 | -+ | |||
| 257 | +10x |
- #' test, use [stats::mantelhaen.test()].+ hr_vars <- intersect(names(colvars$labels), c("n_tot", "n_tot_events", "hr", "ci", "pval"))
|
||
| 467 | -+ | |||
| 258 | +10x |
- #'+ colvars_survtime <- list(vars = survtime_vars, labels = colvars$labels[survtime_vars]) |
||
| 468 | -+ | |||
| 259 | +10x |
- #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ colvars_hr <- list(vars = hr_vars, labels = colvars$labels[hr_vars]) |
||
| 469 | +260 |
- #'+ |
||
| 470 | -+ | |||
| 261 | +10x |
- #' @examples+ extra_args <- list(groups_lists = groups_lists, conf_level = conf_level, method = method) |
||
| 471 | +262 |
- #' # Cochran-Mantel-Haenszel confidence interval+ |
||
| 472 | +263 |
- #'+ # Get analysis function for each statistic |
||
| 473 | -+ | |||
| 264 | +10x |
- #' set.seed(2)+ afun_lst <- a_survival_subgroups(.formats = c(.formats, riskdiff = riskdiff$format), na_str = na_str) |
||
| 474 | +265 |
- #' rsp <- sample(c(TRUE, FALSE), 100, TRUE)+ |
||
| 475 | +266 |
- #' grp <- sample(c("Placebo", "Treatment"), 100, TRUE)
+ # Add risk difference column |
||
| 476 | -+ | |||
| 267 | +10x |
- #' grp <- factor(grp, levels = c("Placebo", "Treatment"))
+ if (!is.null(riskdiff)) {
|
||
| 477 | -+ | |||
| 268 | +1x |
- #' strata_data <- data.frame(+ if (is.null(riskdiff$arm_x)) riskdiff$arm_x <- levels(df$survtime$arm)[1] |
||
| 478 | -+ | |||
| 269 | +1x |
- #' "f1" = sample(c("a", "b"), 100, TRUE),
+ if (is.null(riskdiff$arm_y)) riskdiff$arm_y <- levels(df$survtime$arm)[2] |
||
| 479 | -+ | |||
| 270 | +1x |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ colvars_hr$vars <- c(colvars_hr$vars, "riskdiff") |
||
| 480 | -+ | |||
| 271 | +1x |
- #' stringsAsFactors = TRUE+ colvars_hr$labels <- c(colvars_hr$labels, riskdiff = riskdiff$col_label) |
||
| 481 | -+ | |||
| 272 | +1x |
- #' )+ arm_cols <- paste(rep(c("n_events", "n_events", "n", "n")), c(riskdiff$arm_x, riskdiff$arm_y), sep = "_")
|
||
| 482 | +273 |
- #'+ |
||
| 483 | -+ | |||
| 274 | +1x |
- #' prop_diff_cmh(+ df_prop_diff <- df$survtime %>% |
||
| 484 | -+ | |||
| 275 | +1x |
- #' rsp = rsp, grp = grp, strata = interaction(strata_data),+ dplyr::select(-"median") %>% |
||
| 485 | -+ | |||
| 276 | +1x |
- #' conf_level = 0.90+ tidyr::pivot_wider( |
||
| 486 | -+ | |||
| 277 | +1x |
- #' )+ id_cols = c("subgroup", "var", "var_label", "row_type"),
|
||
| 487 | -+ | |||
| 278 | +1x |
- #'+ names_from = "arm", |
||
| 488 | -+ | |||
| 279 | +1x |
- #' @export+ values_from = c("n", "n_events")
|
||
| 489 | +280 |
- prop_diff_cmh <- function(rsp,+ ) %>% |
||
| 490 | -+ | |||
| 281 | +1x |
- grp,+ dplyr::rowwise() %>% |
||
| 491 | -+ | |||
| 282 | +1x |
- strata,+ dplyr::mutate( |
||
| 492 | -+ | |||
| 283 | +1x |
- conf_level = 0.95) {
+ riskdiff = stat_propdiff_ci( |
||
| 493 | -8x | +284 | +1x |
- grp <- as_factor_keep_attributes(grp)+ x = as.list(.data[[arm_cols[1]]]), |
| 494 | -8x | +285 | +1x |
- strata <- as_factor_keep_attributes(strata)+ y = as.list(.data[[arm_cols[2]]]), |
| 495 | -8x | +286 | +1x |
- check_diff_prop_ci(+ N_x = .data[[arm_cols[3]]], |
| 496 | -8x | +287 | +1x |
- rsp = rsp, grp = grp, conf_level = conf_level, strata = strata+ N_y = .data[[arm_cols[4]]] |
| 497 | +288 |
- )+ ) |
||
| 498 | +289 |
-
+ ) %>% |
||
| 499 | -8x | +290 | +1x |
- if (any(tapply(rsp, strata, length) < 5)) {
+ dplyr::select(-dplyr::all_of(arm_cols))+ |
+
| 291 | ++ | + | ||
| 500 | +292 | 1x |
- warning("Less than 5 observations in some strata.")
+ df$hr <- df$hr %>% |
|
| 501 | -+ | |||
| 293 | +1x |
- }+ dplyr::left_join( |
||
| 502 | -+ | |||
| 294 | +1x |
-
+ df_prop_diff, |
||
| 503 | -+ | |||
| 295 | +1x |
- # first dimension: FALSE, TRUE+ by = c("subgroup", "var", "var_label", "row_type")
|
||
| 504 | +296 |
- # 2nd dimension: CONTROL, TX+ ) |
||
| 505 | +297 |
- # 3rd dimension: levels of strata+ } |
||
| 506 | +298 |
- # rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records+ |
||
| 507 | -8x | +|||
| 299 | +
- t_tbl <- table(+ # Add columns from table_survtime (optional) |
|||
| 508 | -8x | +300 | +10x |
- factor(rsp, levels = c("FALSE", "TRUE")),
+ if (length(colvars_survtime$vars) > 0) {
|
| 509 | -8x | +301 | +9x |
- grp,+ lyt_survtime <- split_cols_by(lyt = lyt, var = "arm") |
| 510 | -8x | -
- strata- |
- ||
| 511 | -+ | 302 | +9x |
- )+ lyt_survtime <- split_rows_by( |
| 512 | -8x | +303 | +9x |
- n1 <- colSums(t_tbl[1:2, 1, ])+ lyt = lyt_survtime, |
| 513 | -8x | +304 | +9x |
- n2 <- colSums(t_tbl[1:2, 2, ])+ var = "row_type", |
| 514 | -8x | +305 | +9x |
- p1 <- t_tbl[2, 1, ] / n1+ split_fun = keep_split_levels("content"),
|
| 515 | -8x | +306 | +9x |
- p2 <- t_tbl[2, 2, ] / n2+ nested = FALSE |
| 516 | +307 |
- # CMH weights+ ) |
||
| 517 | -8x | +|||
| 308 | +
- use_stratum <- (n1 > 0) & (n2 > 0)+ |
|||
| 518 | -8x | +|||
| 309 | +
- n1 <- n1[use_stratum]+ # Add "All Patients" row |
|||
| 519 | -8x | +310 | +9x |
- n2 <- n2[use_stratum]+ lyt_survtime <- summarize_row_groups( |
| 520 | -8x | +311 | +9x |
- p1 <- p1[use_stratum]+ lyt = lyt_survtime, |
| 521 | -8x | +312 | +9x |
- p2 <- p2[use_stratum]+ var = "var_label", |
| 522 | -8x | +313 | +9x |
- wt <- (n1 * n2 / (n1 + n2))+ cfun = afun_lst[names(colvars_survtime$labels)], |
| 523 | -8x | +314 | +9x |
- wt_normalized <- wt / sum(wt)+ na_str = na_str, |
| 524 | -8x | +315 | +9x |
- est1 <- sum(wt_normalized * p1)+ extra_args = extra_args |
| 525 | -8x | +|||
| 316 | +
- est2 <- sum(wt_normalized * p2)+ ) |
|||
| 526 | -8x | +317 | +9x |
- estimate <- c(est1, est2)+ lyt_survtime <- split_cols_by_multivar( |
| 527 | -8x | +318 | +9x |
- names(estimate) <- levels(grp)+ lyt = lyt_survtime, |
| 528 | -8x | +319 | +9x |
- se1 <- sqrt(sum(wt_normalized^2 * p1 * (1 - p1) / n1))+ vars = colvars_survtime$vars, |
| 529 | -8x | +320 | +9x |
- se2 <- sqrt(sum(wt_normalized^2 * p2 * (1 - p2) / n2))+ varlabels = colvars_survtime$labels |
| 530 | -8x | +|||
| 321 | +
- z <- stats::qnorm((1 + conf_level) / 2)+ ) |
|||
| 531 | -8x | +|||
| 322 | +
- err1 <- z * se1+ |
|||
| 532 | -8x | +|||
| 323 | +
- err2 <- z * se2+ # Add analysis rows |
|||
| 533 | -8x | +324 | +9x |
- ci1 <- c((est1 - err1), (est1 + err1))+ if ("analysis" %in% df$survtime$row_type) {
|
| 534 | +325 | 8x |
- ci2 <- c((est2 - err2), (est2 + err2))+ lyt_survtime <- split_rows_by( |
|
| 535 | +326 | 8x |
- estimate_ci <- list(ci1, ci2)+ lyt = lyt_survtime, |
|
| 536 | +327 | 8x |
- names(estimate_ci) <- levels(grp)+ var = "row_type", |
|
| 537 | +328 | 8x |
- diff_est <- est2 - est1+ split_fun = keep_split_levels("analysis"),
|
|
| 538 | +329 | 8x |
- se_diff <- sqrt(sum(((p1 * (1 - p1) / n1) + (p2 * (1 - p2) / n2)) * wt_normalized^2))+ nested = FALSE, |
|
| 539 | +330 | 8x |
- diff_ci <- c(diff_est - z * se_diff, diff_est + z * se_diff)+ child_labels = "hidden" |
|
| 540 | +331 | - - | -||
| 541 | -8x | -
- list(+ ) |
||
| 542 | +332 | 8x |
- prop = estimate,+ lyt_survtime <- split_rows_by(lyt = lyt_survtime, var = "var_label", nested = TRUE) |
|
| 543 | +333 | 8x |
- prop_ci = estimate_ci,+ lyt_survtime <- analyze_colvars( |
|
| 544 | +334 | 8x |
- diff = diff_est,+ lyt = lyt_survtime, |
|
| 545 | +335 | 8x |
- diff_ci = diff_ci,+ afun = afun_lst[names(colvars_survtime$labels)], |
|
| 546 | +336 | 8x |
- weights = wt_normalized,+ na_str = na_str, |
|
| 547 | +337 | 8x |
- n1 = n1,+ inclNAs = TRUE, |
|
| 548 | +338 | 8x |
- n2 = n2+ extra_args = extra_args |
|
| 549 | +339 |
- )+ ) |
||
| 550 | +340 |
- }+ } |
||
| 551 | +341 | |||
| 552 | -+ | |||
| 342 | +9x |
- #' @describeIn h_prop_diff Calculates the stratified Newcombe confidence interval and difference in response+ table_survtime <- build_table(lyt_survtime, df = df$survtime) |
||
| 553 | +343 |
- #' rates between the experimental treatment group and the control treatment group, adjusted for stratification+ } else {
|
||
| 554 | -+ | |||
| 344 | +1x |
- #' factors. This implementation follows closely the one proposed by \insertCite{Yan2010-jt;textual}{tern}.
+ table_survtime <- NULL |
||
| 555 | +345 |
- #' Weights can be estimated from the heuristic proposed in [prop_strat_wilson()] or from CMH-derived weights+ } |
||
| 556 | +346 |
- #' (see [prop_diff_cmh()]).+ |
||
| 557 | +347 |
- #'+ # Add columns from table_hr ("n_tot_events" or "n_tot", "or" and "ci" required)
|
||
| 558 | -+ | |||
| 348 | +10x |
- #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ lyt_hr <- split_cols_by(lyt = lyt, var = "arm") |
||
| 559 | -+ | |||
| 349 | +10x |
- #' @param weights_method (`string`)\cr weights method. Can be either `"cmh"` or `"heuristic"`+ lyt_hr <- split_rows_by( |
||
| 560 | -+ | |||
| 350 | +10x |
- #' and directs the way weights are estimated.+ lyt = lyt_hr, |
||
| 561 | -+ | |||
| 351 | +10x |
- #'+ var = "row_type", |
||
| 562 | -+ | |||
| 352 | +10x |
- #' @references+ split_fun = keep_split_levels("content"),
|
||
| 563 | -+ | |||
| 353 | +10x |
- #' \insertRef{Yan2010-jt}{tern}
+ nested = FALSE |
||
| 564 | +354 |
- #'+ ) |
||
| 565 | -+ | |||
| 355 | +10x |
- #' @examples+ lyt_hr <- summarize_row_groups(+ |
+ ||
| 356 | +10x | +
+ lyt = lyt_hr,+ |
+ ||
| 357 | +10x | +
+ var = "var_label",+ |
+ ||
| 358 | +10x | +
+ cfun = afun_lst[names(colvars_hr$labels)],+ |
+ ||
| 359 | +10x | +
+ na_str = na_str,+ |
+ ||
| 360 | +10x | +
+ extra_args = extra_args |
||
| 566 | +361 |
- #' # Stratified Newcombe confidence interval+ )+ |
+ ||
| 362 | +10x | +
+ lyt_hr <- split_cols_by_multivar(+ |
+ ||
| 363 | +10x | +
+ lyt = lyt_hr,+ |
+ ||
| 364 | +10x | +
+ vars = colvars_hr$vars,+ |
+ ||
| 365 | +10x | +
+ varlabels = colvars_hr$labels |
||
| 567 | +366 |
- #'+ ) %>%+ |
+ ||
| 367 | +10x | +
+ append_topleft("Baseline Risk Factors")
|
||
| 568 | +368 |
- #' set.seed(2)+ |
||
| 569 | +369 |
- #' data_set <- data.frame(+ # Add analysis rows+ |
+ ||
| 370 | +10x | +
+ if ("analysis" %in% df$survtime$row_type) {
+ |
+ ||
| 371 | +9x | +
+ lyt_hr <- split_rows_by( |
||
| 570 | -+ | |||
| 372 | +9x |
- #' "rsp" = sample(c(TRUE, FALSE), 100, TRUE),+ lyt = lyt_hr, |
||
| 571 | -+ | |||
| 373 | +9x |
- #' "f1" = sample(c("a", "b"), 100, TRUE),
+ var = "row_type", |
||
| 572 | -+ | |||
| 374 | +9x |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ split_fun = keep_split_levels("analysis"),
|
||
| 573 | -+ | |||
| 375 | +9x |
- #' "grp" = sample(c("Placebo", "Treatment"), 100, TRUE),
+ nested = FALSE, |
||
| 574 | -+ | |||
| 376 | +9x |
- #' stringsAsFactors = TRUE+ child_labels = "hidden" |
||
| 575 | +377 |
- #' )+ ) |
||
| 576 | -+ | |||
| 378 | +9x |
- #'+ lyt_hr <- split_rows_by(lyt = lyt_hr, var = "var_label", nested = TRUE) |
||
| 577 | -+ | |||
| 379 | +9x |
- #' prop_diff_strat_nc(+ lyt_hr <- analyze_colvars( |
||
| 578 | -+ | |||
| 380 | +9x |
- #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]),+ lyt = lyt_hr, |
||
| 579 | -+ | |||
| 381 | +9x |
- #' weights_method = "cmh",+ afun = afun_lst[names(colvars_hr$labels)], |
||
| 580 | -+ | |||
| 382 | +9x |
- #' conf_level = 0.90+ na_str = na_str, |
||
| 581 | -+ | |||
| 383 | +9x |
- #' )+ inclNAs = TRUE, |
||
| 582 | -+ | |||
| 384 | +9x |
- #'+ extra_args = extra_args |
||
| 583 | +385 |
- #' prop_diff_strat_nc(+ ) |
||
| 584 | +386 |
- #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]),+ } |
||
| 585 | +387 |
- #' weights_method = "wilson_h",+ |
||
| 586 | -+ | |||
| 388 | +10x |
- #' conf_level = 0.90+ table_hr <- build_table(lyt_hr, df = df$hr) |
||
| 587 | +389 |
- #' )+ |
||
| 588 | +390 |
- #'+ # Join tables, add forest plot attributes |
||
| 589 | -+ | |||
| 391 | +10x |
- #' @export+ n_tot_ids <- grep("^n_tot", colvars_hr$vars)
|
||
| 590 | -+ | |||
| 392 | +10x |
- prop_diff_strat_nc <- function(rsp,+ if (is.null(table_survtime)) {
|
||
| 591 | -+ | |||
| 393 | +1x |
- grp,+ result <- table_hr |
||
| 592 | -+ | |||
| 394 | +1x |
- strata,+ hr_id <- match("hr", colvars_hr$vars)
|
||
| 593 | -+ | |||
| 395 | +1x |
- weights_method = c("cmh", "wilson_h"),
+ ci_id <- match("ci", colvars_hr$vars)
|
||
| 594 | +396 |
- conf_level = 0.95,+ } else {
|
||
| 595 | -+ | |||
| 397 | +9x |
- correct = FALSE) {
+ result <- cbind_rtables(table_hr[, n_tot_ids], table_survtime, table_hr[, -n_tot_ids]) |
||
| 596 | -4x | +398 | +9x |
- weights_method <- match.arg(weights_method)+ hr_id <- length(n_tot_ids) + ncol(table_survtime) + match("hr", colvars_hr$vars[-n_tot_ids])
|
| 597 | -4x | +399 | +9x |
- grp <- as_factor_keep_attributes(grp)+ ci_id <- length(n_tot_ids) + ncol(table_survtime) + match("ci", colvars_hr$vars[-n_tot_ids])
|
| 598 | -4x | +400 | +9x |
- strata <- as_factor_keep_attributes(strata)+ n_tot_ids <- seq_along(n_tot_ids) |
| 599 | -4x | +|||
| 401 | +
- check_diff_prop_ci(+ } |
|||
| 600 | -4x | +402 | +10x |
- rsp = rsp, grp = grp, conf_level = conf_level, strata = strata+ structure( |
| 601 | -+ | |||
| 403 | +10x |
- )+ result, |
||
| 602 | -4x | +404 | +10x |
- checkmate::assert_number(conf_level, lower = 0, upper = 1)+ forest_header = paste0(rev(levels(df$survtime$arm)), "\nBetter"), |
| 603 | -4x | +405 | +10x |
- checkmate::assert_flag(correct)+ col_x = hr_id, |
| 604 | -4x | +406 | +10x |
- if (any(tapply(rsp, strata, length) < 5)) {
+ col_ci = ci_id, |
| 605 | -! | +|||
| 407 | +10x |
- warning("Less than 5 observations in some strata.")
+ col_symbol_size = n_tot_ids[1] # for scaling the symbol sizes in forest plots |
||
| 606 | +408 |
- }+ ) |
||
| 607 | +409 |
-
+ } |
||
| 608 | -4x | +|||
| 410 | +
- rsp_by_grp <- split(rsp, f = grp)+ |
|||
| 609 | -4x | +|||
| 411 | +
- strata_by_grp <- split(strata, f = grp)+ #' Labels for column variables in survival duration by subgroup table |
|||
| 610 | +412 |
-
+ #' |
||
| 611 | +413 |
- # Finding the weights+ #' @description `r lifecycle::badge("stable")`
|
||
| 612 | -4x | +|||
| 414 | +
- weights <- if (identical(weights_method, "cmh")) {
+ #' |
|||
| 613 | -3x | +|||
| 415 | +
- prop_diff_cmh(rsp = rsp, grp = grp, strata = strata)$weights+ #' Internal function to check variables included in [tabulate_survival_subgroups()] and create column labels. |
|||
| 614 | -4x | +|||
| 416 | +
- } else if (identical(weights_method, "wilson_h")) {
+ #' |
|||
| 615 | -1x | +|||
| 417 | +
- prop_strat_wilson(rsp, strata, conf_level = conf_level, correct = correct)$weights+ #' @inheritParams tabulate_survival_subgroups |
|||
| 616 | +418 |
- }+ #' @inheritParams argument_convention |
||
| 617 | -4x | +|||
| 419 | +
- weights[levels(strata)[!levels(strata) %in% names(weights)]] <- 0+ #' @param method (`string`)\cr p-value method for testing hazard ratio = 1. |
|||
| 618 | +420 |
-
+ #' |
||
| 619 | +421 |
- # Calculating lower (`l`) and upper (`u`) confidence bounds per group.+ #' @return A `list` of variables and their labels to tabulate. |
||
| 620 | -4x | +|||
| 422 | +
- strat_wilson_by_grp <- Map(+ #' |
|||
| 621 | -4x | +|||
| 423 | +
- prop_strat_wilson,+ #' @note At least one of `n_tot` and `n_tot_events` must be provided in `vars`. |
|||
| 622 | -4x | +|||
| 424 | +
- rsp = rsp_by_grp,+ #' |
|||
| 623 | -4x | +|||
| 425 | +
- strata = strata_by_grp,+ #' @export |
|||
| 624 | -4x | +|||
| 426 | +
- weights = list(weights, weights),+ d_survival_subgroups_colvars <- function(vars, |
|||
| 625 | -4x | +|||
| 427 | +
- conf_level = conf_level,+ conf_level, |
|||
| 626 | -4x | +|||
| 428 | +
- correct = correct+ method, |
|||
| 627 | +429 |
- )+ time_unit = NULL) {
|
||
| 628 | -+ | |||
| 430 | +21x |
-
+ checkmate::assert_character(vars) |
||
| 629 | -4x | +431 | +21x |
- ci_ref <- strat_wilson_by_grp[[1]]+ checkmate::assert_string(time_unit, null.ok = TRUE) |
| 630 | -4x | +432 | +21x |
- ci_trt <- strat_wilson_by_grp[[2]]+ checkmate::assert_subset(c("hr", "ci"), vars)
|
| 631 | -4x | +433 | +21x |
- l_ref <- as.numeric(ci_ref$conf_int[1])+ checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
|
| 632 | -4x | +434 | +21x |
- u_ref <- as.numeric(ci_ref$conf_int[2])+ checkmate::assert_subset( |
| 633 | -4x | +435 | +21x |
- l_trt <- as.numeric(ci_trt$conf_int[1])+ vars, |
| 634 | -4x | +436 | +21x |
- u_trt <- as.numeric(ci_trt$conf_int[2])+ c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
|
| 635 | +437 |
-
+ ) |
||
| 636 | +438 |
- # Estimating the diff and n_ref, n_trt (it allows different weights to be used)+ |
||
| 637 | -4x | +439 | +21x |
- t_tbl <- table(+ propcase_time_label <- if (!is.null(time_unit)) {
|
| 638 | -4x | +440 | +20x |
- factor(rsp, levels = c("FALSE", "TRUE")),
+ paste0("Median (", time_unit, ")")
|
| 639 | -4x | +|||
| 441 | +
- grp,+ } else {
|
|||
| 640 | -4x | +442 | +1x |
- strata+ "Median" |
| 641 | +443 |
- )+ } |
||
| 642 | -4x | +|||
| 444 | +
- n_ref <- colSums(t_tbl[1:2, 1, ])+ |
|||
| 643 | -4x | +445 | +21x |
- n_trt <- colSums(t_tbl[1:2, 2, ])+ varlabels <- c( |
| 644 | -4x | +446 | +21x |
- use_stratum <- (n_ref > 0) & (n_trt > 0)+ n = "n", |
| 645 | -4x | +447 | +21x |
- n_ref <- n_ref[use_stratum]+ n_events = "Events", |
| 646 | -4x | +448 | +21x |
- n_trt <- n_trt[use_stratum]+ median = propcase_time_label, |
| 647 | -4x | +449 | +21x |
- p_ref <- t_tbl[2, 1, use_stratum] / n_ref+ n_tot = "Total n", |
| 648 | -4x | +450 | +21x |
- p_trt <- t_tbl[2, 2, use_stratum] / n_trt+ n_tot_events = "Total Events", |
| 649 | -4x | +451 | +21x |
- est1 <- sum(weights * p_ref)+ hr = "Hazard Ratio", |
| 650 | -4x | +452 | +21x |
- est2 <- sum(weights * p_trt)+ ci = paste0(100 * conf_level, "% Wald CI"), |
| 651 | -4x | +453 | +21x |
- diff_est <- est2 - est1+ pval = method |
| 652 | +454 | ++ |
+ )+ |
+ |
| 455 | ||||
| 653 | -4x | +456 | +21x |
- lambda1 <- sum(weights^2 / n_ref)+ colvars <- vars |
| 654 | -4x | +|||
| 457 | +
- lambda2 <- sum(weights^2 / n_trt)+ |
|||
| 655 | -4x | +|||
| 458 | +
- z <- stats::qnorm((1 + conf_level) / 2)+ # The `lcl` variable is just a placeholder available in the analysis data, |
|||
| 656 | +459 |
-
+ # it is not acutally used in the tabulation. |
||
| 657 | -4x | +|||
| 460 | +
- lower <- diff_est - z * sqrt(lambda2 * l_trt * (1 - l_trt) + lambda1 * u_ref * (1 - u_ref))+ # Variables used in the tabulation are lcl and ucl, see `a_survival_subgroups` for details. |
|||
| 658 | -4x | +461 | +21x |
- upper <- diff_est + z * sqrt(lambda1 * l_ref * (1 - l_ref) + lambda2 * u_trt * (1 - u_trt))+ colvars[colvars == "ci"] <- "lcl" |
| 659 | +462 | |||
| 660 | -4x | +463 | +21x |
list( |
| 661 | -4x | +464 | +21x |
- "diff" = diff_est,+ vars = colvars, |
| 662 | -4x | +465 | +21x |
- "diff_ci" = c("lower" = lower, "upper" = upper)
+ labels = varlabels[vars] |
| 663 | +466 |
) |
||
| 664 | +467 |
}@@ -75618,14 +78358,14 @@ tern coverage - 95.59% |
| 1 |
- #' Encode categorical missing values in a data frame+ #' Create a forest plot from an `rtable` |
||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' Given a [rtables::rtable()] object with at least one column with a single value and one column with 2 |
||
| 4 |
- #'+ #' values, converts table to a [ggplot2::ggplot()] object and generates an accompanying forest plot. The |
||
| 5 |
- #' This is a helper function to encode missing entries across groups of categorical+ #' table and forest plot are printed side-by-side. |
||
| 6 |
- #' variables in a data frame.+ #' |
||
| 7 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 8 |
- #' @details Missing entries are those with `NA` or empty strings and will+ #' |
||
| 9 |
- #' be replaced with a specified value. If factor variables include missing+ #' @inheritParams rtable2gg |
||
| 10 |
- #' values, the missing value will be inserted as the last level.+ #' @inheritParams argument_convention |
||
| 11 |
- #' Similarly, in case character or logical variables should be converted to factors+ #' @param tbl (`VTableTree`)\cr `rtables` table with at least one column with a single value and one column with 2 |
||
| 12 |
- #' with the `char_as_factor` or `logical_as_factor` options, the missing values will+ #' values. |
||
| 13 |
- #' be set as the last level.+ #' @param col_x (`integer(1)` or `NULL`)\cr column index with estimator. By default tries to get this from |
||
| 14 |
- #'+ #' `tbl` attribute `col_x`, otherwise needs to be manually specified. If `NULL`, points will be excluded |
||
| 15 |
- #' @param data (`data.frame`)\cr data set.+ #' from forest plot. |
||
| 16 |
- #' @param omit_columns (`character`)\cr names of variables from `data` that should+ #' @param col_ci (`integer(1)` or `NULL`)\cr column index with confidence intervals. By default tries to get this from |
||
| 17 |
- #' not be modified by this function.+ #' `tbl` attribute `col_ci`, otherwise needs to be manually specified. If `NULL`, lines will be excluded |
||
| 18 |
- #' @param char_as_factor (`flag`)\cr whether to convert character variables+ #' from forest plot. |
||
| 19 |
- #' in `data` to factors.+ #' @param vline (`numeric(1)` or `NULL`)\cr x coordinate for vertical line, if `NULL` then the line is omitted. |
||
| 20 |
- #' @param logical_as_factor (`flag`)\cr whether to convert logical variables+ #' @param forest_header (`character(2)`)\cr text displayed to the left and right of `vline`, respectively. |
||
| 21 |
- #' in `data` to factors.+ #' If `vline = NULL` then `forest_header` is not printed. By default tries to get this from `tbl` attribute |
||
| 22 |
- #' @param na_level (`string`)\cr string used to replace all `NA` or empty+ #' `forest_header`. If `NULL`, defaults will be extracted from the table if possible, and set to |
||
| 23 |
- #' values inside non-`omit_columns` columns.+ #' `"Comparison\nBetter"` and `"Treatment\nBetter"` if not. |
||
| 24 |
- #'+ #' @param xlim (`numeric(2)`)\cr limits for x axis. |
||
| 25 |
- #' @return A `data.frame` with the chosen modifications applied.+ #' @param logx (`flag`)\cr show the x-values on logarithm scale. |
||
| 26 |
- #'+ #' @param x_at (`numeric`)\cr x-tick locations, if `NULL`, `x_at` is set to `vline` and both `xlim` values. |
||
| 27 |
- #' @seealso [sas_na()] and [explicit_na()] for other missing data helper functions.+ #' @param width_row_names `r lifecycle::badge("deprecated")` Please use the `lbl_col_padding` argument instead.
|
||
| 28 |
- #'+ #' @param width_columns (`numeric`)\cr a vector of column widths. Each element's position in |
||
| 29 |
- #' @examples+ #' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths are calculated |
||
| 30 |
- #' my_data <- data.frame(+ #' according to maximum number of characters per column. |
||
| 31 |
- #' u = c(TRUE, FALSE, NA, TRUE),+ #' @param width_forest `r lifecycle::badge("deprecated")` Please use the `rel_width_forest` argument instead.
|
||
| 32 |
- #' v = factor(c("A", NA, NA, NA), levels = c("Z", "A")),
+ #' @param rel_width_forest (`proportion`)\cr proportion of total width to allocate to the forest plot. Relative |
||
| 33 |
- #' w = c("A", "B", NA, "C"),
+ #' width of table is then `1 - rel_width_forest`. If `as_list = TRUE`, this parameter is ignored. |
||
| 34 |
- #' x = c("D", "E", "F", NA),
+ #' @param font_size (`numeric(1)`)\cr font size. |
||
| 35 |
- #' y = c("G", "H", "I", ""),
+ #' @param col_symbol_size (`numeric` or `NULL`)\cr column index from `tbl` containing data to be used |
||
| 36 |
- #' z = c(1, 2, 3, 4),+ #' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional |
||
| 37 |
- #' stringsAsFactors = FALSE+ #' to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups. |
||
| 38 |
- #' )+ #' By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified. |
||
| 39 |
- #'+ #' @param col (`character`)\cr color(s). |
||
| 40 |
- #' # Example 1+ #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot. |
||
| 41 |
- #' # Encode missing values in all character or factor columns.+ #' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list. If `TRUE`, a named list |
||
| 42 |
- #' df_explicit_na(my_data)+ #' with two elements, `table` and `plot`, will be returned. If `FALSE` (default) the table and forest plot are |
||
| 43 |
- #' # Also convert logical columns to factor columns.+ #' printed side-by-side via [cowplot::plot_grid()]. |
||
| 44 |
- #' df_explicit_na(my_data, logical_as_factor = TRUE)+ #' @param gp `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
|
||
| 45 |
- #' # Encode missing values in a subset of columns.+ #' is no longer used. |
||
| 46 |
- #' df_explicit_na(my_data, omit_columns = c("x", "y"))
+ #' @param draw `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
|
||
| 47 |
- #'+ #' is no longer used. |
||
| 48 |
- #' # Example 2+ #' @param newpage `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
|
||
| 49 |
- #' # Here we purposefully convert all `M` values to `NA` in the `SEX` variable.+ #' is no longer used. |
||
| 50 |
- #' # After running `df_explicit_na` the `NA` values are encoded as `<Missing>` but they are not+ #' |
||
| 51 |
- #' # included when generating `rtables`.+ #' @return `ggplot` forest plot and table. |
||
| 52 |
- #' adsl <- tern_ex_adsl+ #' |
||
| 53 |
- #' adsl$SEX[adsl$SEX == "M"] <- NA+ #' @examples |
||
| 54 |
- #' adsl <- df_explicit_na(adsl)+ #' library(dplyr) |
||
| 55 |
- #'+ #' library(forcats) |
||
| 56 |
- #' # If you want the `Na` values to be displayed in the table use the `na_level` argument.+ #' |
||
| 57 |
- #' adsl <- tern_ex_adsl+ #' adrs <- tern_ex_adrs |
||
| 58 |
- #' adsl$SEX[adsl$SEX == "M"] <- NA+ #' n_records <- 20 |
||
| 59 |
- #' adsl <- df_explicit_na(adsl, na_level = "Missing Values")+ #' adrs_labels <- formatters::var_labels(adrs, fill = TRUE) |
||
| 60 |
- #'+ #' adrs <- adrs %>% |
||
| 61 |
- #' # Example 3+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 62 |
- #' # Numeric variables that have missing values are not altered. This means that any `NA` value in+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
|
||
| 63 |
- #' # a numeric variable will not be included in the summary statistics, nor will they be included+ #' slice(seq_len(n_records)) %>% |
||
| 64 |
- #' # in the denominator value for calculating the percent values.+ #' droplevels() %>% |
||
| 65 |
- #' adsl <- tern_ex_adsl+ #' mutate( |
||
| 66 |
- #' adsl$AGE[adsl$AGE < 30] <- NA+ #' # Reorder levels of factor to make the placebo group the reference arm. |
||
| 67 |
- #' adsl <- df_explicit_na(adsl)+ #' ARM = fct_relevel(ARM, "B: Placebo"), |
||
| 68 |
- #'+ #' rsp = AVALC == "CR" |
||
| 69 |
- #' @export+ #' ) |
||
| 70 |
- df_explicit_na <- function(data,+ #' formatters::var_labels(adrs) <- c(adrs_labels, "Response") |
||
| 71 |
- omit_columns = NULL,+ #' df <- extract_rsp_subgroups( |
||
| 72 |
- char_as_factor = TRUE,+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")),
|
||
| 73 |
- logical_as_factor = FALSE,+ #' data = adrs |
||
| 74 |
- na_level = "<Missing>") {
+ #' ) |
||
| 75 | -24x | +
- checkmate::assert_character(omit_columns, null.ok = TRUE, min.len = 1, any.missing = FALSE)+ #' # Full commonly used response table. |
|
| 76 | -23x | +
- checkmate::assert_data_frame(data)+ #' |
|
| 77 | -22x | +
- checkmate::assert_flag(char_as_factor)+ #' tbl <- basic_table() %>% |
|
| 78 | -21x | +
- checkmate::assert_flag(logical_as_factor)+ #' tabulate_rsp_subgroups(df) |
|
| 79 | -21x | +
- checkmate::assert_string(na_level)+ #' g_forest(tbl) |
|
| 80 |
-
+ #' |
||
| 81 | -19x | +
- target_vars <- if (is.null(omit_columns)) {
+ #' # Odds ratio only table. |
|
| 82 | -17x | +
- names(data)+ #' |
|
| 83 |
- } else {
+ #' tbl_or <- basic_table() %>% |
||
| 84 | -2x | +
- setdiff(names(data), omit_columns) # May have duplicates.+ #' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci"))
|
|
| 85 |
- }+ #' g_forest( |
||
| 86 | -19x | +
- if (length(target_vars) == 0) {
+ #' tbl_or, |
|
| 87 | -1x | +
- return(data)+ #' forest_header = c("Comparison\nBetter", "Treatment\nBetter")
|
|
| 88 |
- }+ #' ) |
||
| 89 |
-
+ #' |
||
| 90 | -18x | +
- l_target_vars <- split(target_vars, target_vars)+ #' # Survival forest plot example. |
|
| 91 |
-
+ #' adtte <- tern_ex_adtte |
||
| 92 |
- # Makes sure target_vars exist in data and names are not duplicated.+ #' # Save variable labels before data processing steps. |
||
| 93 | -18x | +
- assert_df_with_variables(data, l_target_vars)+ #' adtte_labels <- formatters::var_labels(adtte, fill = TRUE) |
|
| 94 |
-
+ #' adtte_f <- adtte %>% |
||
| 95 | -18x | +
- for (x in target_vars) {
+ #' filter( |
|
| 96 | -306x | +
- xi <- data[[x]]+ #' PARAMCD == "OS", |
|
| 97 | -306x | +
- xi_label <- obj_label(xi)+ #' ARM %in% c("B: Placebo", "A: Drug X"),
|
|
| 98 |
-
+ #' SEX %in% c("M", "F")
|
||
| 99 |
- # Determine whether to convert character or logical input.+ #' ) %>% |
||
| 100 | -306x | +
- do_char_conversion <- is.character(xi) && char_as_factor+ #' mutate( |
|
| 101 | -306x | +
- do_logical_conversion <- is.logical(xi) && logical_as_factor+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
|
| 102 |
-
+ #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")), |
||
| 103 |
- # Pre-convert logical to character to deal correctly with replacing NA+ #' SEX = droplevels(SEX), |
||
| 104 |
- # values below.+ #' AVALU = as.character(AVALU), |
||
| 105 | -306x | +
- if (do_logical_conversion) {
+ #' is_event = CNSR == 0 |
|
| 106 | -2x | +
- xi <- as.character(xi)+ #' ) |
|
| 107 |
- }+ #' labels <- list( |
||
| 108 |
-
+ #' "ARM" = adtte_labels["ARM"], |
||
| 109 | -306x | +
- if (is.factor(xi) || is.character(xi)) {
+ #' "SEX" = adtte_labels["SEX"], |
|
| 110 |
- # Handle empty strings and NA values.+ #' "AVALU" = adtte_labels["AVALU"], |
||
| 111 | -219x | +
- xi <- explicit_na(sas_na(xi), label = na_level)+ #' "is_event" = "Event Flag" |
|
| 112 |
-
+ #' ) |
||
| 113 |
- # Convert to factors if requested for the original type,+ #' formatters::var_labels(adtte_f)[names(labels)] <- as.character(labels) |
||
| 114 |
- # set na_level as the last value.- |
- ||
| 115 | -219x | -
- if (do_char_conversion || do_logical_conversion) {
- |
- |
| 116 | -78x | -
- levels_xi <- setdiff(sort(unique(xi)), na_level)- |
- |
| 117 | -78x | -
- if (na_level %in% unique(xi)) {
- |
- |
| 118 | -18x | -
- levels_xi <- c(levels_xi, na_level)- |
- |
| 119 | -- |
- }- |
- |
| 120 | -- | - - | -|
| 121 | -78x | -
- xi <- factor(xi, levels = levels_xi)- |
- |
| 122 | -- |
- }- |
- |
| 123 | -- | - - | -|
| 124 | -219x | -
- data[, x] <- formatters::with_label(xi, label = xi_label)- |
- |
| 125 | -- |
- }- |
- |
| 126 | -- |
- }- |
- |
| 127 | -18x | -
- return(data)+ #' df <- extract_survival_subgroups( |
|
| 128 | +115 |
- }+ #' variables = list( |
| 1 | +116 |
- #' Helper function for deriving analysis datasets for select laboratory tables+ #' tte = "AVAL", |
||
| 2 | +117 |
- #'+ #' is_event = "is_event", |
||
| 3 | +118 |
- #' @description `r lifecycle::badge("stable")`
+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
|
||
| 4 | +119 |
- #'+ #' ), |
||
| 5 | +120 |
- #' Helper function that merges ADSL and ADLB datasets so that missing lab test records are inserted in the+ #' data = adtte_f |
||
| 6 | +121 |
- #' output dataset. Remember that `na_level` must match the needed pre-processing+ #' ) |
||
| 7 | +122 |
- #' done with [df_explicit_na()] to have the desired output.+ #' table_hr <- basic_table() %>% |
||
| 8 | +123 |
- #'+ #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) |
||
| 9 | +124 |
- #' @param adsl (`data.frame`)\cr ADSL data frame.+ #' g_forest(table_hr) |
||
| 10 | +125 |
- #' @param adlb (`data.frame`)\cr ADLB data frame.+ #' |
||
| 11 | +126 |
- #' @param worst_flag (named `character`)\cr worst post-baseline lab flag variable. See how this is implemented in the+ #' # Works with any `rtable`. |
||
| 12 | +127 |
- #' following examples.+ #' tbl <- rtable( |
||
| 13 | +128 |
- #' @param by_visit (`flag`)\cr defaults to `FALSE` to generate worst grade per patient.+ #' header = c("E", "CI", "N"),
|
||
| 14 | +129 |
- #' If worst grade per patient per visit is specified for `worst_flag`, then+ #' rrow("", 1, c(.8, 1.2), 200),
|
||
| 15 | +130 |
- #' `by_visit` should be `TRUE` to generate worst grade patient per visit.+ #' rrow("", 1.2, c(1.1, 1.4), 50)
|
||
| 16 | +131 |
- #' @param no_fillin_visits (named `character`)\cr visits that are not considered for post-baseline worst toxicity+ #' ) |
||
| 17 | +132 |
- #' grade. Defaults to `c("SCREENING", "BASELINE")`.
+ #' g_forest( |
||
| 18 | +133 |
- #'+ #' tbl = tbl, |
||
| 19 | +134 |
- #' @return `df` containing variables shared between `adlb` and `adsl` along with variables `PARAM`, `PARAMCD`,+ #' col_x = 1, |
||
| 20 | +135 |
- #' `ATOXGR`, and `BTOXGR` relevant for analysis. Optionally, `AVISIT` are `AVISITN` are included when+ #' col_ci = 2, |
||
| 21 | +136 |
- #' `by_visit = TRUE` and `no_fillin_visits = c("SCREENING", "BASELINE")`.
+ #' xlim = c(0.5, 2), |
||
| 22 | +137 |
- #'+ #' x_at = c(0.5, 1, 2), |
||
| 23 | +138 |
- #' @details In the result data missing records will be created for the following situations:+ #' col_symbol_size = 3 |
||
| 24 | +139 |
- #' * Patients who are present in `adsl` but have no lab data in `adlb` (both baseline and post-baseline).+ #' ) |
||
| 25 | +140 |
- #' * Patients who do not have any post-baseline lab values.+ #' |
||
| 26 | +141 |
- #' * Patients without any post-baseline values flagged as the worst.+ #' tbl <- rtable( |
||
| 27 | +142 |
- #'+ #' header = rheader( |
||
| 28 | +143 |
- #' @examples+ #' rrow("", rcell("A", colspan = 2)),
|
||
| 29 | +144 |
- #' # `h_adsl_adlb_merge_using_worst_flag`+ #' rrow("", "c1", "c2")
|
||
| 30 | +145 |
- #' adlb_out <- h_adsl_adlb_merge_using_worst_flag(+ #' ), |
||
| 31 | +146 |
- #' tern_ex_adsl,+ #' rrow("row 1", 1, c(.8, 1.2)),
|
||
| 32 | +147 |
- #' tern_ex_adlb,+ #' rrow("row 2", 1.2, c(1.1, 1.4))
|
||
| 33 | +148 |
- #' worst_flag = c("WGRHIFL" = "Y")
+ #' ) |
||
| 34 | +149 |
- #' )+ #' g_forest( |
||
| 35 | +150 |
- #'+ #' tbl = tbl, |
||
| 36 | +151 |
- #' # `h_adsl_adlb_merge_using_worst_flag` by visit example+ #' col_x = 1, |
||
| 37 | +152 |
- #' adlb_out_by_visit <- h_adsl_adlb_merge_using_worst_flag(+ #' col_ci = 2, |
||
| 38 | +153 |
- #' tern_ex_adsl,+ #' xlim = c(0.5, 2), |
||
| 39 | +154 |
- #' tern_ex_adlb,+ #' x_at = c(0.5, 1, 2), |
||
| 40 | +155 |
- #' worst_flag = c("WGRLOVFL" = "Y"),
+ #' vline = 1, |
||
| 41 | +156 |
- #' by_visit = TRUE+ #' forest_header = c("Hello", "World")
|
||
| 42 | +157 |
#' ) |
||
| 43 | +158 |
#' |
||
| 44 | +159 |
#' @export |
||
| 45 | +160 |
- h_adsl_adlb_merge_using_worst_flag <- function(adsl, # nolint+ g_forest <- function(tbl, |
||
| 46 | +161 |
- adlb,+ col_x = attr(tbl, "col_x"), |
||
| 47 | +162 |
- worst_flag = c("WGRHIFL" = "Y"),
+ col_ci = attr(tbl, "col_ci"), |
||
| 48 | +163 |
- by_visit = FALSE,+ vline = 1, |
||
| 49 | +164 |
- no_fillin_visits = c("SCREENING", "BASELINE")) {
- |
- ||
| 50 | -5x | -
- col_names <- names(worst_flag)+ forest_header = attr(tbl, "forest_header"), |
||
| 51 | -5x | +|||
| 165 | +
- filter_values <- worst_flag+ xlim = c(0.1, 10), |
|||
| 52 | +166 |
-
+ logx = TRUE, |
||
| 53 | -5x | +|||
| 167 | +
- temp <- Map(+ x_at = c(0.1, 1, 10), |
|||
| 54 | -5x | +|||
| 168 | +
- function(x, y) which(adlb[[x]] == y),+ width_row_names = lifecycle::deprecated(), |
|||
| 55 | -5x | +|||
| 169 | +
- col_names,+ width_columns = NULL, |
|||
| 56 | -5x | +|||
| 170 | +
- filter_values+ width_forest = lifecycle::deprecated(), |
|||
| 57 | +171 |
- )+ lbl_col_padding = 0, |
||
| 58 | +172 |
-
+ rel_width_forest = 0.25, |
||
| 59 | -5x | +|||
| 173 | +
- position_satisfy_filters <- Reduce(intersect, temp)+ font_size = 12, |
|||
| 60 | +174 |
-
+ col_symbol_size = attr(tbl, "col_symbol_size"), |
||
| 61 | -5x | +|||
| 175 | +
- adsl_adlb_common_columns <- intersect(colnames(adsl), colnames(adlb))+ col = getOption("ggplot2.discrete.colour")[1],
|
|||
| 62 | -5x | +|||
| 176 | +
- columns_from_adlb <- c("USUBJID", "PARAM", "PARAMCD", "AVISIT", "AVISITN", "ATOXGR", "BTOXGR")
+ ggtheme = NULL, |
|||
| 63 | +177 |
-
+ as_list = FALSE, |
||
| 64 | -5x | +|||
| 178 | +
- adlb_f <- adlb[position_satisfy_filters, ] %>%+ gp = lifecycle::deprecated(), |
|||
| 65 | -5x | +|||
| 179 | +
- dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits)+ draw = lifecycle::deprecated(), |
|||
| 66 | -5x | +|||
| 180 | +
- adlb_f <- adlb_f[, columns_from_adlb]+ newpage = lifecycle::deprecated()) {
|
|||
| 67 | +181 |
-
+ # Deprecated argument warnings |
||
| 68 | -5x | +182 | +4x |
- avisits_grid <- adlb %>%+ if (lifecycle::is_present(width_row_names)) {
|
| 69 | -5x | +183 | +1x |
- dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) %>%+ lifecycle::deprecate_warn( |
| 70 | -5x | +184 | +1x |
- dplyr::pull(.data[["AVISIT"]]) %>%+ "0.9.4", "g_forest(width_row_names)", "g_forest(lbl_col_padding)", |
| 71 | -5x | +185 | +1x |
- unique()+ details = "The width of the row label column can be adjusted via the `lbl_col_padding` parameter." |
| 72 | +186 |
-
+ ) |
||
| 73 | -5x | +|||
| 187 | +
- if (by_visit) {
+ } |
|||
| 74 | -1x | +188 | +4x |
- adsl_lb <- expand.grid(+ if (lifecycle::is_present(width_forest)) {
|
| 75 | +189 | 1x |
- USUBJID = unique(adsl$USUBJID),+ lifecycle::deprecate_warn( |
|
| 76 | +190 | 1x |
- AVISIT = avisits_grid,+ "0.9.4", "g_forest(width_forest)", "g_forest(rel_width_forest)", |
|
| 77 | +191 | 1x |
- PARAMCD = unique(adlb$PARAMCD)+ details = "Relative width of the forest plot (as a proportion) can be set via the `rel_width_forest` parameter." |
|
| 78 | +192 |
) |
||
| 79 | +193 |
-
+ } |
||
| 80 | -1x | +194 | +4x |
- adsl_lb <- adsl_lb %>%+ if (lifecycle::is_present(gp)) {
|
| 81 | +195 | 1x |
- dplyr::left_join(unique(adlb[c("AVISIT", "AVISITN")]), by = "AVISIT") %>%
+ lifecycle::deprecate_warn( |
|
| 82 | +196 | 1x |
- dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
+ "0.9.4", "g_forest(gp)", "g_forest(ggtheme)", |
|
| 83 | -+ | |||
| 197 | +1x |
-
+ details = paste( |
||
| 84 | +198 | 1x |
- adsl1 <- adsl[, adsl_adlb_common_columns]+ "`g_forest` is now generated as a `ggplot` object.", |
|
| 85 | +199 | 1x |
- adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID")+ "Additional display settings should be supplied via the `ggtheme` parameter." |
|
| 86 | +200 |
-
+ ) |
||
| 87 | -1x | +|||
| 201 | +
- by_variables_from_adlb <- c("USUBJID", "AVISIT", "AVISITN", "PARAMCD", "PARAM")
+ ) |
|||
| 88 | +202 |
-
+ } |
||
| 89 | -1x | +203 | +4x |
- adlb_btoxgr <- adlb %>%+ if (lifecycle::is_present(draw)) {
|
| 90 | +204 | 1x |
- dplyr::select(c("USUBJID", "PARAMCD", "BTOXGR")) %>%
+ lifecycle::deprecate_warn( |
|
| 91 | +205 | 1x |
- unique() %>%+ "0.9.4", "g_forest(draw)", |
|
| 92 | +206 | 1x |
- dplyr::rename("BTOXGR_MAP" = "BTOXGR")
+ details = "`g_forest` now generates `ggplot` objects. This parameter has no effect." |
|
| 93 | +207 | - - | -||
| 94 | -1x | -
- adlb_out <- merge(+ ) |
||
| 95 | -1x | +|||
| 208 | +
- adlb_f,+ } |
|||
| 96 | -1x | +209 | +4x |
- adsl_lb,+ if (lifecycle::is_present(newpage)) {
|
| 97 | +210 | 1x |
- by = by_variables_from_adlb,+ lifecycle::deprecate_warn( |
|
| 98 | +211 | 1x |
- all = TRUE,+ "0.9.4", "g_forest(newpage)", |
|
| 99 | +212 | 1x |
- sort = FALSE+ details = "`g_forest` now generates `ggplot` objects. This parameter has no effect." |
|
| 100 | +213 |
) |
||
| 101 | -1x | +|||
| 214 | +
- adlb_out <- adlb_out %>%+ } |
|||
| 102 | -1x | +|||
| 215 | +
- dplyr::left_join(adlb_btoxgr, by = c("USUBJID", "PARAMCD")) %>%
+
|
|||
| 103 | -1x | +216 | +4x |
- dplyr::mutate(BTOXGR = .data$BTOXGR_MAP) %>%+ checkmate::assert_class(tbl, "VTableTree") |
| 104 | -1x | +217 | +4x |
- dplyr::select(-"BTOXGR_MAP")+ checkmate::assert_number(col_x, lower = 0, upper = ncol(tbl), null.ok = TRUE) |
| 105 | -+ | |||
| 218 | +4x |
-
+ checkmate::assert_number(col_ci, lower = 0, upper = ncol(tbl), null.ok = TRUE) |
||
| 106 | -1x | +219 | +4x |
- adlb_var_labels <- c(+ checkmate::assert_number(col_symbol_size, lower = 0, upper = ncol(tbl), null.ok = TRUE) |
| 107 | -1x | +220 | +4x |
- formatters::var_labels(adlb[by_variables_from_adlb]),+ checkmate::assert_number(font_size, lower = 0) |
| 108 | -1x | +221 | +4x |
- formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]),+ checkmate::assert_character(col, null.ok = TRUE) |
| 109 | -1x | +222 | +4x |
- formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]])+ checkmate::assert_true(is.null(col) | length(col) == 1 | length(col) == nrow(tbl)) |
| 110 | +223 |
- )+ |
||
| 111 | +224 |
- } else {
+ # Extract info from table |
||
| 112 | +225 | 4x |
- adsl_lb <- expand.grid(+ mat <- matrix_form(tbl, indent_rownames = TRUE) |
|
| 113 | +226 | 4x |
- USUBJID = unique(adsl$USUBJID),+ mat_strings <- formatters::mf_strings(mat) |
|
| 114 | +227 | 4x |
- PARAMCD = unique(adlb$PARAMCD)- |
- |
| 115 | -- |
- )+ nlines_hdr <- formatters::mf_nlheader(mat) |
||
| 116 | -+ | |||
| 228 | +4x |
-
+ nrows_body <- nrow(mat_strings) - nlines_hdr |
||
| 117 | +229 | 4x |
- adsl_lb <- adsl_lb %>% dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
+ tbl_stats <- mat_strings[nlines_hdr, -1] |
|
| 118 | +230 | |||
| 119 | -4x | +|||
| 231 | +
- adsl1 <- adsl[, adsl_adlb_common_columns]+ # Generate and modify table as ggplot object |
|||
| 120 | +232 | 4x |
- adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID")- |
- |
| 121 | -- |
-
+ gg_table <- rtable2gg(tbl, fontsize = font_size, colwidths = width_columns, lbl_col_padding = lbl_col_padding) + |
||
| 122 | +233 | 4x |
- by_variables_from_adlb <- c("USUBJID", "PARAMCD", "PARAM")
+ theme(plot.margin = margin(0, 0, 0, 0.025, "npc")) |
|
| 123 | -+ | |||
| 234 | +4x |
-
+ gg_table$scales$scales[[1]]$expand <- c(0.01, 0.01) |
||
| 124 | +235 | 4x |
- adlb_out <- merge(+ gg_table$scales$scales[[2]]$limits[2] <- nrow(mat_strings) + 1 |
|
| 125 | +236 | 4x |
- adlb_f,+ if (nlines_hdr == 2) {
|
|
| 126 | +237 | 4x |
- adsl_lb,+ gg_table$scales$scales[[2]]$expand <- c(0, 0) |
|
| 127 | +238 | 4x |
- by = by_variables_from_adlb,+ arms <- unique(mat_strings[1, ][nzchar(trimws(mat_strings[1, ]))]) |
|
| 128 | -4x | +|||
| 239 | +
- all = TRUE,+ } else {
|
|||
| 129 | -4x | +|||
| 240 | +! |
- sort = FALSE+ arms <- NULL |
||
| 130 | +241 |
- )+ } |
||
| 131 | +242 | |||
| 132 | +243 | 4x |
- adlb_var_labels <- c(+ tbl_df <- as_result_df(tbl) |
|
| 133 | +244 | 4x |
- formatters::var_labels(adlb[by_variables_from_adlb]),+ dat_cols <- seq(which(names(tbl_df) == "node_class") + 1, ncol(tbl_df)) |
|
| 134 | +245 | 4x |
- formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]),+ tbl_df <- tbl_df[, c(which(names(tbl_df) == "row_num"), dat_cols)] |
|
| 135 | +246 | 4x |
- formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]])+ names(tbl_df) <- c("row_num", tbl_stats)
|
|
| 136 | +247 |
- )+ |
||
| 137 | +248 |
- }+ # Check table data columns+ |
+ ||
| 249 | +4x | +
+ if (!is.null(col_ci)) {
+ |
+ ||
| 250 | +4x | +
+ ci_col <- col_ci + 1 |
||
| 138 | +251 |
-
+ } else {
|
||
| 139 | -5x | +|||
| 252 | +! |
- adlb_out$ATOXGR <- as.factor(adlb_out$ATOXGR)+ tbl_df[["empty_ci"]] <- rep(list(c(NA_real_, NA_real_)), nrow(tbl_df)) |
||
| 140 | -5x | +|||
| 253 | +! |
- adlb_out$BTOXGR <- as.factor(adlb_out$BTOXGR)+ ci_col <- which(names(tbl_df) == "empty_ci") |
||
| 141 | +254 |
-
+ } |
||
| 142 | -5x | +|||
| 255 | +! |
- formatters::var_labels(adlb_out) <- adlb_var_labels+ if (length(tbl_df[, ci_col][[1]]) != 2) stop("CI column must have two elements (lower and upper limits).")
|
||
| 143 | +256 | |||
| 144 | -5x | +257 | +4x |
- adlb_out+ if (!is.null(col_x)) {
|
| 145 | -+ | |||
| 258 | +4x |
- }+ x_col <- col_x + 1 |
| 1 | +259 |
- #' Tabulate survival duration by subgroup+ } else {
|
||
| 2 | -+ | |||
| 260 | +! |
- #'+ tbl_df[["empty_x"]] <- NA_real_ |
||
| 3 | -+ | |||
| 261 | +! |
- #' @description `r lifecycle::badge("stable")`
+ x_col <- which(names(tbl_df) == "empty_x") |
||
| 4 | +262 |
- #'+ } |
||
| 5 | -+ | |||
| 263 | +4x |
- #' The [tabulate_survival_subgroups()] function creates a layout element to tabulate survival duration by subgroup,+ if (!is.null(col_symbol_size)) {
|
||
| 6 | -+ | |||
| 264 | +3x |
- #' returning statistics including median survival time and hazard ratio for each population subgroup. The table is+ sym_size <- unlist(tbl_df[, col_symbol_size + 1]) |
||
| 7 | +265 |
- #' created from `df`, a list of data frames returned by [extract_survival_subgroups()], with the statistics to include+ } else {
|
||
| 8 | -+ | |||
| 266 | +1x |
- #' specified via the `vars` parameter.+ sym_size <- rep(1, nrow(tbl_df)) |
||
| 9 | +267 |
- #'+ } |
||
| 10 | +268 |
- #' A forest plot can be created from the resulting table using the [g_forest()] function.+ |
||
| 11 | -+ | |||
| 269 | +4x |
- #'+ tbl_df[, c("ci_lwr", "ci_upr")] <- t(sapply(tbl_df[, ci_col], unlist))
|
||
| 12 | -+ | |||
| 270 | +4x |
- #' @inheritParams argument_convention+ x <- unlist(tbl_df[, x_col]) |
||
| 13 | -+ | |||
| 271 | +4x |
- #' @inheritParams survival_coxph_pairwise+ lwr <- unlist(tbl_df[["ci_lwr"]]) |
||
| 14 | -+ | |||
| 272 | +4x |
- #' @param df (`list`)\cr list of data frames containing all analysis variables. List should be+ upr <- unlist(tbl_df[["ci_upr"]]) |
||
| 15 | -+ | |||
| 273 | +4x |
- #' created using [extract_survival_subgroups()].+ row_num <- nrow(mat_strings) - tbl_df[["row_num"]] - as.numeric(nlines_hdr == 2) |
||
| 16 | +274 |
- #' @param vars (`character`)\cr the names of statistics to be reported among:+ |
||
| 17 | -+ | |||
| 275 | +! |
- #' * `n_tot_events`: Total number of events per group.+ if (is.null(col)) col <- "#343cff" |
||
| 18 | -+ | |||
| 276 | +4x |
- #' * `n_events`: Number of events per group.+ if (length(col) == 1) col <- rep(col, nrow(tbl_df)) |
||
| 19 | -+ | |||
| 277 | +! |
- #' * `n_tot`: Total number of observations per group.+ if (is.null(x_at)) x_at <- union(xlim, vline) |
||
| 20 | -+ | |||
| 278 | +4x |
- #' * `n`: Number of observations per group.+ x_labels <- x_at |
||
| 21 | +279 |
- #' * `median`: Median survival time.+ |
||
| 22 | +280 |
- #' * `hr`: Hazard ratio.+ # Apply log transformation |
||
| 23 | -+ | |||
| 281 | +4x |
- #' * `ci`: Confidence interval of hazard ratio.+ if (logx) {
|
||
| 24 | -+ | |||
| 282 | +4x |
- #' * `pval`: p-value of the effect.+ x_t <- log(x) |
||
| 25 | -+ | |||
| 283 | +4x |
- #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci`+ lwr_t <- log(lwr) |
||
| 26 | -+ | |||
| 284 | +4x |
- #' are required.+ upr_t <- log(upr) |
||
| 27 | -+ | |||
| 285 | +4x |
- #' @param time_unit (`string`)\cr label with unit of median survival time. Default `NULL` skips displaying unit.+ xlim_t <- log(xlim) |
||
| 28 | +286 |
- #'+ } else {
|
||
| 29 | -+ | |||
| 287 | +! |
- #' @details These functions create a layout starting from a data frame which contains+ x_t <- x |
||
| 30 | -+ | |||
| 288 | +! |
- #' the required statistics. Tables typically used as part of forest plot.+ lwr_t <- lwr |
||
| 31 | -+ | |||
| 289 | +! |
- #'+ upr_t <- upr |
||
| 32 | -+ | |||
| 290 | +! |
- #' @seealso [extract_survival_subgroups()]+ xlim_t <- xlim |
||
| 33 | +291 |
- #'+ } |
||
| 34 | +292 |
- #' @examples+ |
||
| 35 | +293 |
- #' library(dplyr)+ # Set up plot area |
||
| 36 | -+ | |||
| 294 | +4x |
- #'+ gg_plt <- ggplot(data = tbl_df) + |
||
| 37 | -+ | |||
| 295 | +4x |
- #' adtte <- tern_ex_adtte+ theme( |
||
| 38 | -+ | |||
| 296 | +4x |
- #'+ panel.background = element_rect(fill = "transparent", color = NA_character_), |
||
| 39 | -+ | |||
| 297 | +4x |
- #' # Save variable labels before data processing steps.+ plot.background = element_rect(fill = "transparent", color = NA_character_), |
||
| 40 | -+ | |||
| 298 | +4x |
- #' adtte_labels <- formatters::var_labels(adtte)+ panel.grid.major = element_blank(), |
||
| 41 | -+ | |||
| 299 | +4x |
- #'+ panel.grid.minor = element_blank(), |
||
| 42 | -+ | |||
| 300 | +4x |
- #' adtte_f <- adtte %>%+ axis.title.x = element_blank(),+ |
+ ||
| 301 | +4x | +
+ axis.title.y = element_blank(), |
||
| 43 | -+ | |||
| 302 | +4x |
- #' filter(+ axis.line.x = element_line(), |
||
| 44 | -+ | |||
| 303 | +4x |
- #' PARAMCD == "OS",+ axis.text = element_text(size = font_size), |
||
| 45 | -+ | |||
| 304 | +4x |
- #' ARM %in% c("B: Placebo", "A: Drug X"),
+ legend.position = "none", |
||
| 46 | -+ | |||
| 305 | +4x |
- #' SEX %in% c("M", "F")
+ plot.margin = margin(0, 0.1, 0.05, 0, "npc") |
||
| 47 | +306 |
- #' ) %>%+ ) + |
||
| 48 | -+ | |||
| 307 | +4x |
- #' mutate(+ scale_x_continuous( |
||
| 49 | -+ | |||
| 308 | +4x |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ transform = ifelse(logx, "log", "identity"), |
||
| 50 | -+ | |||
| 309 | +4x |
- #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")),+ limits = xlim, |
||
| 51 | -+ | |||
| 310 | +4x |
- #' SEX = droplevels(SEX),+ breaks = x_at, |
||
| 52 | -+ | |||
| 311 | +4x |
- #' AVALU = as.character(AVALU),+ labels = x_labels, |
||
| 53 | -+ | |||
| 312 | +4x |
- #' is_event = CNSR == 0+ expand = c(0.01, 0) |
||
| 54 | +313 |
- #' )+ ) + |
||
| 55 | -+ | |||
| 314 | +4x |
- #' labels <- c(+ scale_y_continuous( |
||
| 56 | -+ | |||
| 315 | +4x |
- #' "ARM" = adtte_labels[["ARM"]],+ limits = c(0, nrow(mat_strings) + 1), |
||
| 57 | -+ | |||
| 316 | +4x |
- #' "SEX" = adtte_labels[["SEX"]],+ breaks = NULL, |
||
| 58 | -+ | |||
| 317 | +4x |
- #' "AVALU" = adtte_labels[["AVALU"]],+ expand = c(0, 0) |
||
| 59 | +318 |
- #' "is_event" = "Event Flag"+ ) + |
||
| 60 | -+ | |||
| 319 | +4x |
- #' )+ coord_cartesian(clip = "off") |
||
| 61 | +320 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ |
||
| 62 | -+ | |||
| 321 | +4x |
- #'+ if (is.null(ggtheme)) {
|
||
| 63 | -+ | |||
| 322 | +4x |
- #' df <- extract_survival_subgroups(+ gg_plt <- gg_plt + annotate( |
||
| 64 | -+ | |||
| 323 | +4x |
- #' variables = list(+ "rect", |
||
| 65 | -+ | |||
| 324 | +4x |
- #' tte = "AVAL",+ xmin = xlim[1], |
||
| 66 | -+ | |||
| 325 | +4x |
- #' is_event = "is_event",+ xmax = xlim[2], |
||
| 67 | -+ | |||
| 326 | +4x |
- #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ ymin = 0, |
||
| 68 | -+ | |||
| 327 | +4x |
- #' ),+ ymax = nrows_body + 0.5, |
||
| 69 | -+ | |||
| 328 | +4x |
- #' label_all = "Total Patients",+ fill = "grey92" |
||
| 70 | +329 |
- #' data = adtte_f+ ) |
||
| 71 | +330 |
- #' )+ } |
||
| 72 | +331 |
- #' df+ |
||
| 73 | -+ | |||
| 332 | +4x |
- #'+ if (!is.null(vline)) {
|
||
| 74 | +333 |
- #' df_grouped <- extract_survival_subgroups(+ # Set default forest header |
||
| 75 | -+ | |||
| 334 | +4x |
- #' variables = list(+ if (is.null(forest_header)) {
|
||
| 76 | -+ | |||
| 335 | +! |
- #' tte = "AVAL",+ forest_header <- c( |
||
| 77 | -+ | |||
| 336 | +! |
- #' is_event = "is_event",+ paste(if (length(arms) == 2) arms[1] else "Comparison", "Better", sep = "\n"), |
||
| 78 | -+ | |||
| 337 | +! |
- #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ paste(if (length(arms) == 2) arms[2] else "Treatment", "Better", sep = "\n") |
||
| 79 | +338 |
- #' ),+ ) |
||
| 80 | +339 |
- #' data = adtte_f,+ } |
||
| 81 | +340 |
- #' groups_lists = list(+ |
||
| 82 | +341 |
- #' BMRKR2 = list(+ # Add vline and forest header labels |
||
| 83 | -+ | |||
| 342 | +4x |
- #' "low" = "LOW",+ mid_pts <- if (logx) {
|
||
| 84 | -+ | |||
| 343 | +4x |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ c(exp(mean(log(c(xlim[1], vline)))), exp(mean(log(c(vline, xlim[2]))))) |
||
| 85 | +344 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ } else {
|
||
| 86 | -+ | |||
| 345 | +! |
- #' )+ c(mean(c(xlim[1], vline)), mean(c(vline, xlim[2]))) |
||
| 87 | +346 |
- #' )+ } |
||
| 88 | -+ | |||
| 347 | +4x |
- #' )+ gg_plt <- gg_plt + |
||
| 89 | -+ | |||
| 348 | +4x |
- #' df_grouped+ annotate( |
||
| 90 | -+ | |||
| 349 | +4x |
- #'+ "segment", |
||
| 91 | -+ | |||
| 350 | +4x |
- #' @name survival_duration_subgroups+ x = vline, xend = vline, y = 0, yend = nrows_body + 0.5 |
||
| 92 | +351 |
- #' @order 1+ ) + |
||
| 93 | -+ | |||
| 352 | +4x |
- NULL+ annotate( |
||
| 94 | -+ | |||
| 353 | +4x |
-
+ "text", |
||
| 95 | -+ | |||
| 354 | +4x |
- #' Prepare survival data for population subgroups in data frames+ x = mid_pts[1], y = nrows_body + 1.25, |
||
| 96 | -+ | |||
| 355 | +4x |
- #'+ label = forest_header[1], |
||
| 97 | -+ | |||
| 356 | +4x |
- #' @description `r lifecycle::badge("stable")`
+ size = font_size / .pt, |
||
| 98 | -+ | |||
| 357 | +4x |
- #'+ lineheight = 0.9 |
||
| 99 | +358 |
- #' Prepares estimates of median survival times and treatment hazard ratios for population subgroups in+ ) + |
||
| 100 | -+ | |||
| 359 | +4x |
- #' data frames. Simple wrapper for [h_survtime_subgroups_df()] and [h_coxph_subgroups_df()]. Result is a `list`+ annotate( |
||
| 101 | -+ | |||
| 360 | +4x |
- #' of two `data.frame`s: `survtime` and `hr`. `variables` corresponds to the names of variables found in `data`,+ "text", |
||
| 102 | -+ | |||
| 361 | +4x |
- #' passed as a named `list` and requires elements `tte`, `is_event`, `arm` and optionally `subgroups` and `strata`.+ x = mid_pts[2], y = nrows_body + 1.25, |
||
| 103 | -+ | |||
| 362 | +4x |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ label = forest_header[2], |
||
| 104 | -+ | |||
| 363 | +4x |
- #'+ size = font_size / .pt, |
||
| 105 | -+ | |||
| 364 | +4x |
- #' @inheritParams argument_convention+ lineheight = 0.9 |
||
| 106 | +365 |
- #' @inheritParams survival_duration_subgroups+ ) |
||
| 107 | +366 |
- #' @inheritParams survival_coxph_pairwise+ } |
||
| 108 | +367 |
- #'+ |
||
| 109 | +368 |
- #' @return A named `list` of two elements:+ # Add points to plot |
||
| 110 | -+ | |||
| 369 | +4x |
- #' * `survtime`: A `data.frame` containing columns `arm`, `n`, `n_events`, `median`, `subgroup`, `var`,+ if (any(!is.na(x_t))) {
|
||
| 111 | -+ | |||
| 370 | +4x |
- #' `var_label`, and `row_type`.+ x_t[x < xlim[1] | x > xlim[2]] <- NA |
||
| 112 | -+ | |||
| 371 | +4x |
- #' * `hr`: A `data.frame` containing columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`, `conf_level`,+ gg_plt <- gg_plt + geom_point( |
||
| 113 | -+ | |||
| 372 | +4x |
- #' `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`.+ x = x_t, |
||
| 114 | -+ | |||
| 373 | +4x |
- #'+ y = row_num, |
||
| 115 | -+ | |||
| 374 | +4x |
- #' @seealso [survival_duration_subgroups]+ color = col, |
||
| 116 | -+ | |||
| 375 | +4x |
- #'+ aes(size = sym_size), |
||
| 117 | -+ | |||
| 376 | +4x |
- #' @export+ na.rm = TRUE |
||
| 118 | +377 |
- extract_survival_subgroups <- function(variables,+ ) |
||
| 119 | +378 |
- data,+ } |
||
| 120 | +379 |
- groups_lists = list(),+ |
||
| 121 | -+ | |||
| 380 | +4x |
- control = control_coxph(),+ for (i in seq_len(nrow(tbl_df))) {
|
||
| 122 | +381 |
- label_all = "All Patients") {
+ # Determine which arrow(s) to add to CI lines |
||
| 123 | -12x | -
- if ("strat" %in% names(variables)) {
- |
- ||
| 124 | -! | +382 | +17x |
- warning(+ which_arrow <- c(lwr_t[i] < xlim_t[1], upr_t[i] > xlim_t[2]) |
| 125 | -! | +|||
| 383 | +17x |
- "Warning: the `strat` element name of the `variables` list argument to `extract_survival_subgroups() ",+ which_arrow <- dplyr::case_when( |
||
| 126 | -! | +|||
| 384 | +17x |
- "was deprecated in tern 0.9.4.\n ",+ all(which_arrow) ~ "both", |
||
| 127 | -! | +|||
| 385 | +17x |
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ which_arrow[1] ~ "first", |
||
| 128 | -+ | |||
| 386 | +17x |
- )+ which_arrow[2] ~ "last", |
||
| 129 | -! | +|||
| 387 | +17x |
- variables[["strata"]] <- variables[["strat"]]+ TRUE ~ NA_character_ |
||
| 130 | +388 |
- }+ ) |
||
| 131 | +389 | |||
| 132 | -12x | +|||
| 390 | +
- df_survtime <- h_survtime_subgroups_df(+ # Add CI lines |
|||
| 133 | -12x | +391 | +17x |
- variables,+ gg_plt <- gg_plt + |
| 134 | -12x | +392 | +17x |
- data,+ if (!is.na(which_arrow)) {
|
| 135 | -12x | +393 | +15x |
- groups_lists = groups_lists,+ annotate( |
| 136 | -12x | -
- label_all = label_all- |
- ||
| 137 | -+ | 394 | +15x |
- )+ "segment", |
| 138 | -12x | +395 | +15x |
- df_hr <- h_coxph_subgroups_df(+ x = if (!which_arrow %in% c("first", "both")) lwr[i] else xlim[1],
|
| 139 | -12x | +396 | +15x |
- variables,+ xend = if (!which_arrow %in% c("last", "both")) upr[i] else xlim[2],
|
| 140 | -12x | +397 | +15x |
- data,+ y = row_num[i], yend = row_num[i], |
| 141 | -12x | +398 | +15x |
- groups_lists = groups_lists,+ color = if (length(col) == 1) col else col[i], |
| 142 | -12x | +399 | +15x |
- control = control,+ arrow = arrow(length = unit(0.05, "npc"), ends = which_arrow), |
| 143 | -12x | +400 | +15x |
- label_all = label_all+ na.rm = TRUE |
| 144 | +401 |
- )+ ) |
||
| 145 | +402 |
-
+ } else {
|
||
| 146 | -12x | +403 | +2x |
- list(survtime = df_survtime, hr = df_hr)+ annotate( |
| 147 | -+ | |||
| 404 | +2x |
- }+ "segment", |
||
| 148 | -+ | |||
| 405 | +2x |
-
+ x = lwr[i], xend = upr[i], |
||
| 149 | -+ | |||
| 406 | +2x |
- #' @describeIn survival_duration_subgroups Formatted analysis function which is used as+ y = row_num[i], yend = row_num[i], |
||
| 150 | -+ | |||
| 407 | +2x |
- #' `afun` in `tabulate_survival_subgroups()`.+ color = if (length(col) == 1) col else col[i], |
||
| 151 | -+ | |||
| 408 | +2x |
- #'+ na.rm = TRUE |
||
| 152 | +409 |
- #' @return+ ) |
||
| 153 | +410 |
- #' * `a_survival_subgroups()` returns the corresponding list with formatted [rtables::CellValue()].+ } |
||
| 154 | +411 |
- #'+ } |
||
| 155 | +412 |
- #' @keywords internal+ |
||
| 156 | +413 |
- a_survival_subgroups <- function(.formats = list( # nolint start+ # Apply custom ggtheme to plot |
||
| 157 | -+ | |||
| 414 | +! |
- n = "xx",+ if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme |
||
| 158 | +415 |
- n_events = "xx",+ |
||
| 159 | -+ | |||
| 416 | +4x |
- n_tot_events = "xx",+ if (as_list) {
|
||
| 160 | -+ | |||
| 417 | +1x |
- median = "xx.x",+ list( |
||
| 161 | -+ | |||
| 418 | +1x |
- n_tot = "xx",+ table = gg_table, |
||
| 162 | -+ | |||
| 419 | +1x |
- hr = list(format_extreme_values(2L)),+ plot = gg_plt |
||
| 163 | +420 |
- ci = list(format_extreme_values_ci(2L)),+ ) |
||
| 164 | +421 |
- pval = "x.xxxx | (<0.0001)"+ } else {
|
||
| 165 | -+ | |||
| 422 | +3x |
- ),+ cowplot::plot_grid( |
||
| 166 | -+ | |||
| 423 | +3x |
- na_str = default_na_str()) { # nolint end
+ gg_table, |
||
| 167 | -21x | +424 | +3x |
- checkmate::assert_list(.formats)+ gg_plt, |
| 168 | -21x | +425 | +3x |
- checkmate::assert_subset(+ align = "h", |
| 169 | -21x | +426 | +3x |
- names(.formats),+ axis = "tblr", |
| 170 | -21x | +427 | +3x |
- c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval", "riskdiff")
+ rel_widths = c(1 - rel_width_forest, rel_width_forest) |
| 171 | +428 |
- )+ ) |
||
| 172 | +429 | - - | -||
| 173 | -21x | -
- afun_lst <- Map(- |
- ||
| 174 | -21x | -
- function(stat, fmt, na_str) {
- |
- ||
| 175 | -160x | -
- function(df, labelstr = "", ...) {
+ } |
||
| 176 | -312x | +|||
| 430 | +
- in_rows(+ } |
|||
| 177 | -312x | +|||
| 431 | +
- .list = as.list(df[[stat]]),+ |
|||
| 178 | -312x | +|||
| 432 | +
- .labels = as.character(df$subgroup),+ #' Forest plot grob |
|||
| 179 | -312x | +|||
| 433 | +
- .formats = fmt,+ #' |
|||
| 180 | -312x | +|||
| 434 | +
- .format_na_strs = na_str+ #' @description `r lifecycle::badge("deprecated")`
|
|||
| 181 | +435 |
- )+ #' |
||
| 182 | +436 |
- }+ #' @inheritParams g_forest |
||
| 183 | +437 |
- },+ #' @param tbl (`VTableTree`)\cr `rtables` table object. |
||
| 184 | -21x | +|||
| 438 | +
- stat = names(.formats),+ #' @param x (`numeric`)\cr coordinate of point. |
|||
| 185 | -21x | +|||
| 439 | +
- fmt = .formats,+ #' @param lower,upper (`numeric`)\cr lower/upper bound of the confidence interval. |
|||
| 186 | -21x | +|||
| 440 | +
- na_str = na_str+ #' @param symbol_size (`numeric`)\cr vector with relative size for plot symbol. |
|||
| 187 | +441 |
- )+ #' If `NULL`, the same symbol size is used. |
||
| 188 | +442 |
-
+ #' |
||
| 189 | -21x | +|||
| 443 | +
- afun_lst+ #' @details |
|||
| 190 | +444 |
- }+ #' The heights get automatically determined. |
||
| 191 | +445 |
-
+ #' |
||
| 192 | +446 |
- #' @describeIn survival_duration_subgroups Table-creating function which creates a table+ #' @examples |
||
| 193 | +447 |
- #' summarizing survival by subgroup. This function is a wrapper for [rtables::analyze_colvars()]+ #' tbl <- rtable( |
||
| 194 | +448 |
- #' and [rtables::summarize_row_groups()].+ #' header = rheader( |
||
| 195 | +449 |
- #'+ #' rrow("", "E", rcell("CI", colspan = 2), "N"),
|
||
| 196 | +450 |
- #' @param label_all `r lifecycle::badge("deprecated")`\cr please assign the `label_all` parameter within the
+ #' rrow("", "A", "B", "C", "D")
|
||
| 197 | +451 |
- #' [extract_survival_subgroups()] function when creating `df`.+ #' ), |
||
| 198 | +452 |
- #' @param riskdiff (`list`)\cr if a risk (proportion) difference column should be added, a list of settings to apply+ #' rrow("row 1", 1, 0.8, 1.1, 16),
|
||
| 199 | +453 |
- #' within the column. See [control_riskdiff()] for details. If `NULL`, no risk difference column will be added. If+ #' rrow("row 2", 1.4, 0.8, 1.6, 25),
|
||
| 200 | +454 |
- #' `riskdiff$arm_x` and `riskdiff$arm_y` are `NULL`, the first level of `df$survtime$arm` will be used as `arm_x`+ #' rrow("row 3", 1.2, 0.8, 1.6, 36)
|
||
| 201 | +455 |
- #' and the second level as `arm_y`.+ #' ) |
||
| 202 | +456 |
#' |
||
| 203 | +457 |
- #' @return An `rtables` table summarizing survival by subgroup.+ #' x <- c(1, 1.4, 1.2) |
||
| 204 | +458 |
- #'+ #' lower <- c(0.8, 0.8, 0.8) |
||
| 205 | +459 |
- #' @examples+ #' upper <- c(1.1, 1.6, 1.6) |
||
| 206 | +460 |
- #' ## Table with default columns.+ #' # numeric vector with multiplication factor to scale each circle radius |
||
| 207 | +461 |
- #' basic_table() %>%+ #' # default radius is 1/3.5 lines |
||
| 208 | +462 |
- #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1])+ #' symbol_scale <- c(1, 1.25, 1.5) |
||
| 209 | +463 |
#' |
||
| 210 | +464 |
- #' ## Table with a manually chosen set of columns: adding "pval".+ #' # Internal function - forest_grob |
||
| 211 | +465 |
- #' basic_table() %>%+ #' \donttest{
|
||
| 212 | +466 |
- #' tabulate_survival_subgroups(+ #' p <- forest_grob(tbl, x, lower, upper, |
||
| 213 | +467 |
- #' df = df,+ #' vline = 1, forest_header = c("A", "B"),
|
||
| 214 | +468 |
- #' vars = c("n_tot_events", "n_events", "median", "hr", "ci", "pval"),
+ #' x_at = c(.1, 1, 10), xlim = c(0.1, 10), logx = TRUE, symbol_size = symbol_scale, |
||
| 215 | +469 |
- #' time_unit = adtte_f$AVALU[1]+ #' vp = grid::plotViewport(margins = c(1, 1, 1, 1)) |
||
| 216 | +470 |
- #' )+ #' ) |
||
| 217 | +471 |
#' |
||
| 218 | +472 |
- #' @export+ #' draw_grob(p) |
||
| 219 | +473 |
- #' @order 2+ #' } |
||
| 220 | +474 |
- tabulate_survival_subgroups <- function(lyt,+ #' |
||
| 221 | +475 |
- df,+ #' @noRd |
||
| 222 | +476 |
- vars = c("n_tot_events", "n_events", "median", "hr", "ci"),
+ #' @keywords internal |
||
| 223 | +477 |
- groups_lists = list(),+ forest_grob <- function(tbl, |
||
| 224 | +478 |
- label_all = lifecycle::deprecated(),+ x, |
||
| 225 | +479 |
- time_unit = NULL,+ lower, |
||
| 226 | +480 |
- riskdiff = NULL,+ upper, |
||
| 227 | +481 |
- na_str = default_na_str(),+ vline, |
||
| 228 | +482 |
- .formats = c(+ forest_header, |
||
| 229 | +483 |
- n = "xx", n_events = "xx", n_tot_events = "xx", median = "xx.x", n_tot = "xx",+ xlim = NULL, |
||
| 230 | +484 |
- hr = list(format_extreme_values(2L)), ci = list(format_extreme_values_ci(2L)),+ logx = FALSE, |
||
| 231 | +485 |
- pval = "x.xxxx | (<0.0001)"+ x_at = NULL, |
||
| 232 | +486 |
- )) {
+ width_row_names = NULL, |
||
| 233 | -10x | +|||
| 487 | +
- checkmate::assert_list(riskdiff, null.ok = TRUE)+ width_columns = NULL, |
|||
| 234 | -10x | +|||
| 488 | +
- checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
+ width_forest = grid::unit(1, "null"), |
|||
| 235 | -10x | +|||
| 489 | +
- checkmate::assert_true(all(c("hr", "ci") %in% vars))
+ symbol_size = NULL, |
|||
| 236 | +490 |
-
+ col = "blue", |
||
| 237 | -10x | +|||
| 491 | +
- if (lifecycle::is_present(label_all)) {
+ name = NULL, |
|||
| 238 | -1x | +|||
| 492 | +
- lifecycle::deprecate_warn(+ gp = NULL, |
|||
| 239 | -1x | +|||
| 493 | +
- "0.9.5", "tabulate_survival_subgroups(label_all)",+ vp = NULL) {
|
|||
| 240 | +494 | 1x |
- details =+ lifecycle::deprecate_warn( |
|
| 241 | +495 | 1x |
- "Please assign the `label_all` parameter within the `extract_survival_subgroups()` function when creating `df`."+ "0.9.4", "forest_grob()", |
|
| 242 | -+ | |||
| 496 | +1x |
- )+ details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
||
| 243 | +497 |
- }+ ) |
||
| 244 | +498 | |||
| 245 | -+ | |||
| 499 | +1x |
- # Create "ci" column from "lcl" and "ucl"+ nr <- nrow(tbl) |
||
| 246 | -10x | +500 | +1x |
- df$hr$ci <- combine_vectors(df$hr$lcl, df$hr$ucl)+ if (is.null(vline)) {
|
| 247 | -+ | |||
| 501 | +! |
-
+ checkmate::assert_true(is.null(forest_header)) |
||
| 248 | +502 |
- # Fill in missing formats with defaults+ } else {
|
||
| 249 | -10x | +503 | +1x |
- default_fmts <- eval(formals(tabulate_survival_subgroups)$.formats)+ checkmate::assert_number(vline) |
| 250 | -10x | +504 | +1x |
- .formats <- c(.formats, default_fmts[vars[!vars %in% names(.formats)]])+ checkmate::assert_character(forest_header, len = 2, null.ok = TRUE) |
| 251 | +505 |
-
+ } |
||
| 252 | +506 |
- # Extract additional parameters from df+ |
||
| 253 | -10x | +507 | +1x |
- conf_level <- df$hr$conf_level[1]+ checkmate::assert_numeric(x, len = nr) |
| 254 | -10x | +508 | +1x |
- method <- df$hr$pval_label[1]+ checkmate::assert_numeric(lower, len = nr) |
| 255 | -10x | +509 | +1x |
- colvars <- d_survival_subgroups_colvars(vars, conf_level = conf_level, method = method, time_unit = time_unit)+ checkmate::assert_numeric(upper, len = nr) |
| 256 | -10x | +510 | +1x |
- survtime_vars <- intersect(colvars$vars, c("n", "n_events", "median"))
+ checkmate::assert_numeric(symbol_size, len = nr, null.ok = TRUE) |
| 257 | -10x | +511 | +1x |
- hr_vars <- intersect(names(colvars$labels), c("n_tot", "n_tot_events", "hr", "ci", "pval"))
+ checkmate::assert_character(col) |
| 258 | -10x | +|||
| 512 | +
- colvars_survtime <- list(vars = survtime_vars, labels = colvars$labels[survtime_vars])+ |
|||
| 259 | -10x | +513 | +1x |
- colvars_hr <- list(vars = hr_vars, labels = colvars$labels[hr_vars])+ if (is.null(symbol_size)) {
|
| 260 | -+ | |||
| 514 | +! |
-
+ symbol_size <- rep(1, nr) |
||
| 261 | -10x | +|||
| 515 | +
- extra_args <- list(groups_lists = groups_lists, conf_level = conf_level, method = method)+ } |
|||
| 262 | +516 | |||
| 263 | -+ | |||
| 517 | +1x |
- # Get analysis function for each statistic+ if (is.null(xlim)) {
|
||
| 264 | -10x | +|||
| 518 | +! |
- afun_lst <- a_survival_subgroups(.formats = c(.formats, riskdiff = riskdiff$format), na_str = na_str)+ r <- range(c(x, lower, upper), na.rm = TRUE)+ |
+ ||
| 519 | +! | +
+ xlim <- r + c(-0.05, 0.05) * diff(r) |
||
| 265 | +520 |
-
+ } |
||
| 266 | +521 |
- # Add risk difference column+ |
||
| 267 | -10x | +522 | +1x |
- if (!is.null(riskdiff)) {
+ if (logx) {
|
| 268 | +523 | 1x |
- if (is.null(riskdiff$arm_x)) riskdiff$arm_x <- levels(df$survtime$arm)[1]+ if (is.null(x_at)) {
|
|
| 269 | -1x | +|||
| 524 | +! |
- if (is.null(riskdiff$arm_y)) riskdiff$arm_y <- levels(df$survtime$arm)[2]+ x_at <- pretty(log(stats::na.omit(c(x, lower, upper)))) |
||
| 270 | -1x | +|||
| 525 | +! |
- colvars_hr$vars <- c(colvars_hr$vars, "riskdiff")+ x_labels <- exp(x_at)+ |
+ ||
| 526 | ++ |
+ } else {
|
||
| 271 | +527 | 1x |
- colvars_hr$labels <- c(colvars_hr$labels, riskdiff = riskdiff$col_label)+ x_labels <- x_at |
|
| 272 | +528 | 1x |
- arm_cols <- paste(rep(c("n_events", "n_events", "n", "n")), c(riskdiff$arm_x, riskdiff$arm_y), sep = "_")
+ x_at <- log(x_at) |
|
| 273 | +529 |
-
+ } |
||
| 274 | +530 | 1x |
- df_prop_diff <- df$survtime %>%+ xlim <- log(xlim) |
|
| 275 | +531 | 1x |
- dplyr::select(-"median") %>%+ x <- log(x) |
|
| 276 | +532 | 1x |
- tidyr::pivot_wider(+ lower <- log(lower) |
|
| 277 | +533 | 1x |
- id_cols = c("subgroup", "var", "var_label", "row_type"),
+ upper <- log(upper) |
|
| 278 | +534 | 1x |
- names_from = "arm",+ if (!is.null(vline)) {
|
|
| 279 | +535 | 1x |
- values_from = c("n", "n_events")
+ vline <- log(vline) |
|
| 280 | +536 |
- ) %>%- |
- ||
| 281 | -1x | -
- dplyr::rowwise() %>%- |
- ||
| 282 | -1x | -
- dplyr::mutate(+ } |
||
| 283 | -1x | +|||
| 537 | +
- riskdiff = stat_propdiff_ci(+ } else {
|
|||
| 284 | -1x | +|||
| 538 | +! |
- x = as.list(.data[[arm_cols[1]]]),+ x_labels <- TRUE |
||
| 285 | -1x | +|||
| 539 | +
- y = as.list(.data[[arm_cols[2]]]),+ } |
|||
| 286 | -1x | +|||
| 540 | +
- N_x = .data[[arm_cols[3]]],+ |
|||
| 287 | +541 | 1x |
- N_y = .data[[arm_cols[4]]]+ data_forest_vp <- grid::dataViewport(xlim, c(0, 1)) |
|
| 288 | +542 |
- )+ |
||
| 289 | +543 |
- ) %>%+ # Get table content as matrix form. |
||
| 290 | +544 | 1x |
- dplyr::select(-dplyr::all_of(arm_cols))+ mf <- matrix_form(tbl) |
|
| 291 | +545 | |||
| 292 | -1x | +|||
| 546 | +
- df$hr <- df$hr %>%+ # Use `rtables` indent_string eventually. |
|||
| 293 | +547 | 1x |
- dplyr::left_join(+ mf$strings[, 1] <- paste0( |
|
| 294 | +548 | 1x |
- df_prop_diff,+ strrep(" ", c(rep(0, attr(mf, "nrow_header")), mf$row_info$indent)),
|
|
| 295 | +549 | 1x |
- by = c("subgroup", "var", "var_label", "row_type")
+ mf$strings[, 1] |
|
| 296 | +550 |
- )+ ) |
||
| 297 | +551 |
- }+ + |
+ ||
| 552 | +1x | +
+ n_header <- attr(mf, "nrow_header") |
||
| 298 | +553 | |||
| 299 | -+ | |||
| 554 | +! |
- # Add columns from table_survtime (optional)+ if (any(mf$display[, 1] == FALSE)) stop("row names need to be always displayed")
|
||
| 300 | -10x | +|||
| 555 | +
- if (length(colvars_survtime$vars) > 0) {
+
|
|||
| 301 | -9x | +|||
| 556 | +
- lyt_survtime <- split_cols_by(lyt = lyt, var = "arm")+ # Pre-process the data to be used in lapply and cell_in_rows. |
|||
| 302 | -9x | +557 | +1x |
- lyt_survtime <- split_rows_by(+ to_args_for_cell_in_rows_fun <- function(part = c("body", "header"),
|
| 303 | -9x | +558 | +1x |
- lyt = lyt_survtime,+ underline_colspan = FALSE) {
|
| 304 | -9x | +559 | +2x |
- var = "row_type",+ part <- match.arg(part) |
| 305 | -9x | +560 | +2x |
- split_fun = keep_split_levels("content"),
+ if (part == "body") {
|
| 306 | -9x | +561 | +1x |
- nested = FALSE+ mat_row_indices <- seq_len(nrow(tbl)) + n_header |
| 307 | -+ | |||
| 562 | +1x |
- )+ row_ind_offset <- -n_header |
||
| 308 | +563 |
-
+ } else {
|
||
| 309 | -+ | |||
| 564 | +1x |
- # Add "All Patients" row+ mat_row_indices <- seq_len(n_header) |
||
| 310 | -9x | +565 | +1x |
- lyt_survtime <- summarize_row_groups(+ row_ind_offset <- 0 |
| 311 | -9x | +|||
| 566 | +
- lyt = lyt_survtime,+ } |
|||
| 312 | -9x | +|||
| 567 | +
- var = "var_label",+ |
|||
| 313 | -9x | +568 | +2x |
- cfun = afun_lst[names(colvars_survtime$labels)],+ lapply(mat_row_indices, function(i) {
|
| 314 | -9x | +569 | +5x |
- na_str = na_str,+ disp <- mf$display[i, -1] |
| 315 | -9x | +570 | +5x |
- extra_args = extra_args+ list( |
| 316 | -+ | |||
| 571 | +5x |
- )+ row_name = mf$strings[i, 1], |
||
| 317 | -9x | +572 | +5x |
- lyt_survtime <- split_cols_by_multivar(+ cells = mf$strings[i, -1][disp], |
| 318 | -9x | +573 | +5x |
- lyt = lyt_survtime,+ cell_spans = mf$spans[i, -1][disp], |
| 319 | -9x | +574 | +5x |
- vars = colvars_survtime$vars,+ row_index = i + row_ind_offset, |
| 320 | -9x | +575 | +5x |
- varlabels = colvars_survtime$labels+ underline_colspan = underline_colspan |
| 321 | +576 |
- )+ ) |
||
| 322 | +577 |
-
+ }) |
||
| 323 | +578 |
- # Add analysis rows+ } |
||
| 324 | -9x | +|||
| 579 | +
- if ("analysis" %in% df$survtime$row_type) {
+
|
|||
| 325 | -8x | +580 | +1x |
- lyt_survtime <- split_rows_by(+ args_header <- to_args_for_cell_in_rows_fun("header", underline_colspan = TRUE)
|
| 326 | -8x | +581 | +1x |
- lyt = lyt_survtime,+ args_body <- to_args_for_cell_in_rows_fun("body", underline_colspan = FALSE)
|
| 327 | -8x | +|||
| 582 | +
- var = "row_type",+ |
|||
| 328 | -8x | +583 | +1x |
- split_fun = keep_split_levels("analysis"),
+ grid::gTree( |
| 329 | -8x | +584 | +1x |
- nested = FALSE,+ name = name, |
| 330 | -8x | -
- child_labels = "hidden"- |
- ||
| 331 | -+ | 585 | +1x |
- )+ children = grid::gList( |
| 332 | -8x | +586 | +1x |
- lyt_survtime <- split_rows_by(lyt = lyt_survtime, var = "var_label", nested = TRUE)+ grid::gTree( |
| 333 | -8x | +587 | +1x |
- lyt_survtime <- analyze_colvars(+ children = do.call(grid::gList, lapply(args_header, do.call, what = cell_in_rows)), |
| 334 | -8x | +588 | +1x |
- lyt = lyt_survtime,+ vp = grid::vpPath("vp_table_layout", "vp_header")
|
| 335 | -8x | +|||
| 589 | +
- afun = afun_lst[names(colvars_survtime$labels)],+ ), |
|||
| 336 | -8x | +590 | +1x |
- na_str = na_str,+ grid::gTree( |
| 337 | -8x | +591 | +1x |
- inclNAs = TRUE,+ children = do.call(grid::gList, lapply(args_body, do.call, what = cell_in_rows)), |
| 338 | -8x | -
- extra_args = extra_args- |
- ||
| 339 | -+ | 592 | +1x |
- )+ vp = grid::vpPath("vp_table_layout", "vp_body")
|
| 340 | +593 |
- }+ ), |
||
| 341 | -+ | |||
| 594 | +1x |
-
+ grid::linesGrob( |
||
| 342 | -9x | +595 | +1x |
- table_survtime <- build_table(lyt_survtime, df = df$survtime)+ grid::unit(c(0, 1), "npc"), |
| 343 | -+ | |||
| 596 | +1x |
- } else {
+ y = grid::unit(c(.5, .5), "npc"), |
||
| 344 | +597 | 1x |
- table_survtime <- NULL+ vp = grid::vpPath("vp_table_layout", "vp_spacer")
|
|
| 345 | +598 |
- }+ ), |
||
| 346 | +599 |
-
+ # forest part |
||
| 347 | -+ | |||
| 600 | +1x |
- # Add columns from table_hr ("n_tot_events" or "n_tot", "or" and "ci" required)
+ if (is.null(vline)) {
|
||
| 348 | -10x | +|||
| 601 | +! |
- lyt_hr <- split_cols_by(lyt = lyt, var = "arm")+ NULL |
||
| 349 | -10x | +|||
| 602 | +
- lyt_hr <- split_rows_by(+ } else {
|
|||
| 350 | -10x | +603 | +1x |
- lyt = lyt_hr,+ grid::gTree( |
| 351 | -10x | +604 | +1x |
- var = "row_type",+ children = grid::gList( |
| 352 | -10x | +605 | +1x |
- split_fun = keep_split_levels("content"),
+ grid::gTree( |
| 353 | -10x | +606 | +1x |
- nested = FALSE+ children = grid::gList( |
| 354 | +607 |
- )- |
- ||
| 355 | -10x | -
- lyt_hr <- summarize_row_groups(+ # this may overflow, to fix, look here |
||
| 356 | -10x | +|||
| 608 | +
- lyt = lyt_hr,+ # https://stackoverflow.com/questions/33623169/add-multi-line-footnote-to-tablegrob-while-using-gridextra-in-r # nolint |
|||
| 357 | -10x | +609 | +1x |
- var = "var_label",+ grid::textGrob( |
| 358 | -10x | +610 | +1x |
- cfun = afun_lst[names(colvars_hr$labels)],+ forest_header[1], |
| 359 | -10x | +611 | +1x |
- na_str = na_str,+ x = grid::unit(vline, "native") - grid::unit(1, "lines"), |
| 360 | -10x | +612 | +1x |
- extra_args = extra_args+ just = c("right", "center")
|
| 361 | +613 |
- )+ ), |
||
| 362 | -10x | +614 | +1x |
- lyt_hr <- split_cols_by_multivar(+ grid::textGrob( |
| 363 | -10x | +615 | +1x |
- lyt = lyt_hr,+ forest_header[2], |
| 364 | -10x | +616 | +1x |
- vars = colvars_hr$vars,+ x = grid::unit(vline, "native") + grid::unit(1, "lines"), |
| 365 | -10x | +617 | +1x |
- varlabels = colvars_hr$labels+ just = c("left", "center")
|
| 366 | +618 |
- ) %>%+ )+ |
+ ||
| 619 | ++ |
+ ), |
||
| 367 | -10x | +620 | +1x |
- append_topleft("Baseline Risk Factors")
+ vp = grid::vpStack(grid::viewport(layout.pos.col = ncol(tbl) + 2), data_forest_vp) |
| 368 | +621 |
-
+ ) |
||
| 369 | +622 |
- # Add analysis rows+ ), |
||
| 370 | -10x | +623 | +1x |
- if ("analysis" %in% df$survtime$row_type) {
+ vp = grid::vpPath("vp_table_layout", "vp_header")
|
| 371 | -9x | +|||
| 624 | +
- lyt_hr <- split_rows_by(+ ) |
|||
| 372 | -9x | +|||
| 625 | +
- lyt = lyt_hr,+ }, |
|||
| 373 | -9x | +626 | +1x |
- var = "row_type",+ grid::gTree( |
| 374 | -9x | +627 | +1x |
- split_fun = keep_split_levels("analysis"),
+ children = grid::gList( |
| 375 | -9x | +628 | +1x |
- nested = FALSE,+ grid::gTree( |
| 376 | -9x | +629 | +1x |
- child_labels = "hidden"+ children = grid::gList( |
| 377 | -+ | |||
| 630 | +1x |
- )+ grid::rectGrob(gp = grid::gpar(col = "gray90", fill = "gray90")), |
||
| 378 | -9x | +631 | +1x |
- lyt_hr <- split_rows_by(lyt = lyt_hr, var = "var_label", nested = TRUE)+ if (is.null(vline)) {
|
| 379 | -9x | +|||
| 632 | +! |
- lyt_hr <- analyze_colvars(+ NULL+ |
+ ||
| 633 | ++ |
+ } else {
|
||
| 380 | -9x | +634 | +1x |
- lyt = lyt_hr,+ grid::linesGrob( |
| 381 | -9x | +635 | +1x |
- afun = afun_lst[names(colvars_hr$labels)],+ x = grid::unit(rep(vline, 2), "native"), |
| 382 | -9x | +636 | +1x |
- na_str = na_str,+ y = grid::unit(c(0, 1), "npc"), |
| 383 | -9x | +637 | +1x |
- inclNAs = TRUE,+ gp = grid::gpar(lwd = 2), |
| 384 | -9x | +638 | +1x |
- extra_args = extra_args+ vp = data_forest_vp |
| 385 | +639 |
- )+ ) |
||
| 386 | +640 |
- }+ },+ |
+ ||
| 641 | +1x | +
+ grid::xaxisGrob(at = x_at, label = x_labels, vp = data_forest_vp) |
||
| 387 | +642 |
-
+ ), |
||
| 388 | -10x | +643 | +1x |
- table_hr <- build_table(lyt_hr, df = df$hr)+ vp = grid::viewport(layout.pos.col = ncol(tbl) + 2) |
| 389 | +644 |
-
+ ) |
||
| 390 | +645 |
- # Join tables, add forest plot attributes+ ), |
||
| 391 | -10x | +646 | +1x |
- n_tot_ids <- grep("^n_tot", colvars_hr$vars)
+ vp = grid::vpPath("vp_table_layout", "vp_body")
|
| 392 | -10x | +|||
| 647 | +
- if (is.null(table_survtime)) {
+ ), |
|||
| 393 | +648 | 1x |
- result <- table_hr+ grid::gTree( |
|
| 394 | +649 | 1x |
- hr_id <- match("hr", colvars_hr$vars)
+ children = do.call( |
|
| 395 | +650 | 1x |
- ci_id <- match("ci", colvars_hr$vars)
- |
- |
| 396 | -- |
- } else {
+ grid::gList, |
||
| 397 | -9x | +651 | +1x |
- result <- cbind_rtables(table_hr[, n_tot_ids], table_survtime, table_hr[, -n_tot_ids])+ Map( |
| 398 | -9x | +652 | +1x |
- hr_id <- length(n_tot_ids) + ncol(table_survtime) + match("hr", colvars_hr$vars[-n_tot_ids])
+ function(xi, li, ui, row_index, size_i, col) {
|
| 399 | -9x | +653 | +3x |
- ci_id <- length(n_tot_ids) + ncol(table_survtime) + match("ci", colvars_hr$vars[-n_tot_ids])
+ forest_dot_line( |
| 400 | -9x | +654 | +3x |
- n_tot_ids <- seq_along(n_tot_ids)+ xi, |
| 401 | -+ | |||
| 655 | +3x |
- }+ li, |
||
| 402 | -10x | +656 | +3x |
- structure(+ ui, |
| 403 | -10x | +657 | +3x |
- result,+ row_index, |
| 404 | -10x | +658 | +3x |
- forest_header = paste0(rev(levels(df$survtime$arm)), "\nBetter"),+ xlim, |
| 405 | -10x | +659 | +3x |
- col_x = hr_id,+ symbol_size = size_i, |
| 406 | -10x | +660 | +3x |
- col_ci = ci_id,+ col = col, |
| 407 | -10x | +661 | +3x |
- col_symbol_size = n_tot_ids[1] # for scaling the symbol sizes in forest plots+ datavp = data_forest_vp |
| 408 | +662 |
- )+ ) |
||
| 409 | +663 |
- }+ }, |
||
| 410 | -+ | |||
| 664 | +1x |
-
+ x, |
||
| 411 | -+ | |||
| 665 | +1x |
- #' Labels for column variables in survival duration by subgroup table+ lower, |
||
| 412 | -+ | |||
| 666 | +1x |
- #'+ upper, |
||
| 413 | -+ | |||
| 667 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ seq_along(x), |
||
| 414 | -+ | |||
| 668 | +1x |
- #'+ symbol_size, |
||
| 415 | -+ | |||
| 669 | +1x |
- #' Internal function to check variables included in [tabulate_survival_subgroups()] and create column labels.+ col, |
||
| 416 | -+ | |||
| 670 | +1x |
- #'+ USE.NAMES = FALSE |
||
| 417 | +671 |
- #' @inheritParams tabulate_survival_subgroups+ ) |
||
| 418 | +672 |
- #' @inheritParams argument_convention+ ), |
||
| 419 | -+ | |||
| 673 | +1x |
- #' @param method (`string`)\cr p-value method for testing hazard ratio = 1.+ vp = grid::vpPath("vp_table_layout", "vp_body")
|
||
| 420 | +674 |
- #'+ ) |
||
| 421 | +675 |
- #' @return A `list` of variables and their labels to tabulate.+ ),+ |
+ ||
| 676 | +1x | +
+ childrenvp = forest_viewport(tbl, width_row_names, width_columns, width_forest),+ |
+ ||
| 677 | +1x | +
+ vp = vp,+ |
+ ||
| 678 | +1x | +
+ gp = gp |
||
| 422 | +679 |
- #'+ ) |
||
| 423 | +680 |
- #' @note At least one of `n_tot` and `n_tot_events` must be provided in `vars`.+ } |
||
| 424 | +681 |
- #'+ |
||
| 425 | +682 |
- #' @export+ cell_in_rows <- function(row_name, |
||
| 426 | +683 |
- d_survival_subgroups_colvars <- function(vars,+ cells, |
||
| 427 | +684 |
- conf_level,+ cell_spans, |
||
| 428 | +685 |
- method,+ row_index, |
||
| 429 | +686 |
- time_unit = NULL) {
+ underline_colspan = FALSE) {
|
||
| 430 | -21x | +687 | +5x |
- checkmate::assert_character(vars)+ checkmate::assert_string(row_name) |
| 431 | -21x | +688 | +5x |
- checkmate::assert_string(time_unit, null.ok = TRUE)+ checkmate::assert_character(cells, min.len = 1, any.missing = FALSE) |
| 432 | -21x | +689 | +5x |
- checkmate::assert_subset(c("hr", "ci"), vars)
+ checkmate::assert_numeric(cell_spans, len = length(cells), any.missing = FALSE) |
| 433 | -21x | +690 | +5x |
- checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
+ checkmate::assert_number(row_index) |
| 434 | -21x | +691 | +5x |
- checkmate::assert_subset(+ checkmate::assert_flag(underline_colspan)+ |
+
| 692 | ++ | + | ||
| 435 | -21x | +693 | +5x |
- vars,+ vp_name_rn <- paste0("rowname-", row_index)
|
| 436 | -21x | +694 | +5x |
- c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
+ g_rowname <- if (!is.null(row_name) && row_name != "") {
|
| 437 | -+ | |||
| 695 | +3x |
- )+ grid::textGrob( |
||
| 438 | -+ | |||
| 696 | +3x |
-
+ name = vp_name_rn, |
||
| 439 | -21x | +697 | +3x |
- propcase_time_label <- if (!is.null(time_unit)) {
+ label = row_name, |
| 440 | -20x | +698 | +3x |
- paste0("Median (", time_unit, ")")
+ x = grid::unit(0, "npc"),+ |
+
| 699 | +3x | +
+ just = c("left", "center"),
+ |
+ ||
| 700 | +3x | +
+ vp = grid::vpPath(paste0("rowname-", row_index))
|
||
| 441 | +701 | ++ |
+ )+ |
+ |
| 702 |
} else {
|
|||
| 442 | -1x | +703 | +2x |
- "Median"+ NULL |
| 443 | +704 |
} |
||
| 444 | +705 | |||
| 445 | -21x | +706 | +5x |
- varlabels <- c(+ gl_cols <- if (!(length(cells) > 0)) {
|
| 446 | -21x | +|||
| 707 | +! |
- n = "n",+ list(NULL) |
||
| 447 | -21x | +|||
| 708 | +
- n_events = "Events",+ } else {
|
|||
| 448 | -21x | +709 | +5x |
- median = propcase_time_label,+ j <- 1 # column index of cell |
| 449 | -21x | +|||
| 710 | +
- n_tot = "Total n",+ |
|||
| 450 | -21x | +711 | +5x |
- n_tot_events = "Total Events",+ lapply(seq_along(cells), function(k) {
|
| 451 | -21x | +712 | +19x |
- hr = "Hazard Ratio",+ cell_ascii <- cells[[k]] |
| 452 | -21x | +713 | +19x |
- ci = paste0(100 * conf_level, "% Wald CI"),+ cs <- cell_spans[[k]]+ |
+
| 714 | ++ | + | ||
| 453 | -21x | +715 | +19x |
- pval = method+ if (is.na(cell_ascii) || is.null(cell_ascii)) {
+ |
+
| 716 | +! | +
+ cell_ascii <- "NA" |
||
| 454 | +717 |
- )+ } |
||
| 455 | +718 | |||
| 456 | -21x | +719 | +19x |
- colvars <- vars+ cell_name <- paste0("g-cell-", row_index, "-", j)
|
| 457 | +720 | |||
| 458 | -+ | |||
| 721 | +19x |
- # The `lcl` variable is just a placeholder available in the analysis data,+ cell_grobs <- if (identical(cell_ascii, "")) {
|
||
| 459 | -+ | |||
| 722 | +! |
- # it is not acutally used in the tabulation.+ NULL |
||
| 460 | +723 |
- # Variables used in the tabulation are lcl and ucl, see `a_survival_subgroups` for details.+ } else {
|
||
| 461 | -21x | -
- colvars[colvars == "ci"] <- "lcl"- |
- ||
| 462 | -+ | 724 | +19x |
-
+ if (cs == 1) {
|
| 463 | -21x | +725 | +18x |
- list(+ grid::textGrob( |
| 464 | -21x | +726 | +18x |
- vars = colvars,+ label = cell_ascii, |
| 465 | -21x | +727 | +18x |
- labels = varlabels[vars]+ name = cell_name, |
| 466 | -+ | |||
| 728 | +18x |
- )+ vp = grid::vpPath(paste0("cell-", row_index, "-", j))
|
||
| 467 | +729 |
- }+ ) |
| 1 | +730 |
- #' Create a forest plot from an `rtable`+ } else {
|
||
| 2 | +731 |
- #'+ # +1 because of rowname |
||
| 3 | -+ | |||
| 732 | +1x |
- #' Given a [rtables::rtable()] object with at least one column with a single value and one column with 2+ vp_joined_cols <- grid::viewport(layout.pos.row = row_index, layout.pos.col = seq(j + 1, j + cs)) |
||
| 4 | +733 |
- #' values, converts table to a [ggplot2::ggplot()] object and generates an accompanying forest plot. The+ |
||
| 5 | -+ | |||
| 734 | +1x |
- #' table and forest plot are printed side-by-side.+ lab <- grid::textGrob( |
||
| 6 | -+ | |||
| 735 | +1x |
- #'+ label = cell_ascii, |
||
| 7 | -+ | |||
| 736 | +1x |
- #' @description `r lifecycle::badge("stable")`
+ name = cell_name, |
||
| 8 | -+ | |||
| 737 | +1x |
- #'+ vp = vp_joined_cols |
||
| 9 | +738 |
- #' @inheritParams rtable2gg+ ) |
||
| 10 | +739 |
- #' @inheritParams argument_convention+ |
||
| 11 | -+ | |||
| 740 | +1x |
- #' @param tbl (`VTableTree`)\cr `rtables` table with at least one column with a single value and one column with 2+ if (!underline_colspan || grepl("^[[:space:]]*$", cell_ascii)) {
|
||
| 12 | -+ | |||
| 741 | +! |
- #' values.+ lab |
||
| 13 | +742 |
- #' @param col_x (`integer(1)` or `NULL`)\cr column index with estimator. By default tries to get this from+ } else {
|
||
| 14 | -+ | |||
| 743 | +1x |
- #' `tbl` attribute `col_x`, otherwise needs to be manually specified. If `NULL`, points will be excluded+ grid::gList( |
||
| 15 | -+ | |||
| 744 | +1x |
- #' from forest plot.+ lab, |
||
| 16 | -+ | |||
| 745 | +1x |
- #' @param col_ci (`integer(1)` or `NULL`)\cr column index with confidence intervals. By default tries to get this from+ grid::linesGrob( |
||
| 17 | -+ | |||
| 746 | +1x |
- #' `tbl` attribute `col_ci`, otherwise needs to be manually specified. If `NULL`, lines will be excluded+ x = grid::unit.c(grid::unit(.2, "lines"), grid::unit(1, "npc") - grid::unit(.2, "lines")), |
||
| 18 | -+ | |||
| 747 | +1x |
- #' from forest plot.+ y = grid::unit(c(0, 0), "npc"), |
||
| 19 | -+ | |||
| 748 | +1x |
- #' @param vline (`numeric(1)` or `NULL`)\cr x coordinate for vertical line, if `NULL` then the line is omitted.+ vp = vp_joined_cols |
||
| 20 | +749 |
- #' @param forest_header (`character(2)`)\cr text displayed to the left and right of `vline`, respectively.+ ) |
||
| 21 | +750 |
- #' If `vline = NULL` then `forest_header` is not printed. By default tries to get this from `tbl` attribute+ ) |
||
| 22 | +751 |
- #' `forest_header`. If `NULL`, defaults will be extracted from the table if possible, and set to+ } |
||
| 23 | +752 |
- #' `"Comparison\nBetter"` and `"Treatment\nBetter"` if not.+ } |
||
| 24 | +753 |
- #' @param xlim (`numeric(2)`)\cr limits for x axis.+ } |
||
| 25 | -+ | |||
| 754 | +19x |
- #' @param logx (`flag`)\cr show the x-values on logarithm scale.+ j <<- j + cs |
||
| 26 | +755 |
- #' @param x_at (`numeric`)\cr x-tick locations, if `NULL`, `x_at` is set to `vline` and both `xlim` values.+ |
||
| 27 | -+ | |||
| 756 | +19x |
- #' @param width_row_names `r lifecycle::badge("deprecated")` Please use the `lbl_col_padding` argument instead.
+ cell_grobs |
||
| 28 | +757 |
- #' @param width_columns (`numeric`)\cr a vector of column widths. Each element's position in+ }) |
||
| 29 | +758 |
- #' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths are calculated+ } |
||
| 30 | +759 |
- #' according to maximum number of characters per column.+ |
||
| 31 | -+ | |||
| 760 | +5x |
- #' @param width_forest `r lifecycle::badge("deprecated")` Please use the `rel_width_forest` argument instead.
+ grid::gList( |
||
| 32 | -+ | |||
| 761 | +5x |
- #' @param rel_width_forest (`proportion`)\cr proportion of total width to allocate to the forest plot. Relative+ g_rowname, |
||
| 33 | -+ | |||
| 762 | +5x |
- #' width of table is then `1 - rel_width_forest`. If `as_list = TRUE`, this parameter is ignored.+ do.call(grid::gList, gl_cols) |
||
| 34 | +763 |
- #' @param font_size (`numeric(1)`)\cr font size.+ ) |
||
| 35 | +764 |
- #' @param col_symbol_size (`numeric` or `NULL`)\cr column index from `tbl` containing data to be used+ } |
||
| 36 | +765 |
- #' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional+ |
||
| 37 | +766 |
- #' to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups.+ #' Graphic object: forest dot line |
||
| 38 | +767 |
- #' By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified.+ #' |
||
| 39 | +768 |
- #' @param col (`character`)\cr color(s).+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 40 | +769 |
- #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot.+ #' |
||
| 41 | +770 |
- #' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list. If `TRUE`, a named list+ #' Calculate the `grob` corresponding to the dot line within the forest plot. |
||
| 42 | +771 |
- #' with two elements, `table` and `plot`, will be returned. If `FALSE` (default) the table and forest plot are+ #' |
||
| 43 | +772 |
- #' printed side-by-side via [cowplot::plot_grid()].+ #' @noRd |
||
| 44 | +773 |
- #' @param gp `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
+ #' @keywords internal |
||
| 45 | +774 |
- #' is no longer used.+ forest_dot_line <- function(x, |
||
| 46 | +775 |
- #' @param draw `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
+ lower, |
||
| 47 | +776 |
- #' is no longer used.+ upper, |
||
| 48 | +777 |
- #' @param newpage `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument
+ row_index, |
||
| 49 | +778 |
- #' is no longer used.+ xlim, |
||
| 50 | +779 |
- #'+ symbol_size = 1, |
||
| 51 | +780 |
- #' @return `ggplot` forest plot and table.+ col = "blue", |
||
| 52 | +781 |
- #'+ datavp) {
|
||
| 53 | -+ | |||
| 782 | +3x |
- #' @examples+ lifecycle::deprecate_warn( |
||
| 54 | -+ | |||
| 783 | +3x |
- #' library(dplyr)+ "0.9.4", "forest_dot_line()", |
||
| 55 | -+ | |||
| 784 | +3x |
- #' library(forcats)+ details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
||
| 56 | +785 |
- #'+ ) |
||
| 57 | +786 |
- #' adrs <- tern_ex_adrs+ |
||
| 58 | -+ | |||
| 787 | +3x |
- #' n_records <- 20+ ci <- c(lower, upper) |
||
| 59 | -+ | |||
| 788 | +3x |
- #' adrs_labels <- formatters::var_labels(adrs, fill = TRUE)+ if (any(!is.na(c(x, ci)))) {
|
||
| 60 | +789 |
- #' adrs <- adrs %>%+ # line |
||
| 61 | -+ | |||
| 790 | +3x |
- #' filter(PARAMCD == "BESRSPI") %>%+ y <- grid::unit(c(0.5, 0.5), "npc") |
||
| 62 | +791 |
- #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+
|
||
| 63 | -+ | |||
| 792 | +3x |
- #' slice(seq_len(n_records)) %>%+ g_line <- if (all(!is.na(ci)) && ci[2] > xlim[1] && ci[1] < xlim[2]) {
|
||
| 64 | +793 |
- #' droplevels() %>%+ # - |
||
| 65 | -+ | |||
| 794 | +3x |
- #' mutate(+ if (ci[1] >= xlim[1] && ci[2] <= xlim[2]) {
|
||
| 66 | -+ | |||
| 795 | +3x |
- #' # Reorder levels of factor to make the placebo group the reference arm.+ grid::linesGrob(x = grid::unit(c(ci[1], ci[2]), "native"), y = y) |
||
| 67 | -+ | |||
| 796 | +! |
- #' ARM = fct_relevel(ARM, "B: Placebo"),+ } else if (ci[1] < xlim[1] && ci[2] > xlim[2]) {
|
||
| 68 | +797 |
- #' rsp = AVALC == "CR"+ # <-> |
||
| 69 | -+ | |||
| 798 | +! |
- #' )+ grid::linesGrob( |
||
| 70 | -+ | |||
| 799 | +! |
- #' formatters::var_labels(adrs) <- c(adrs_labels, "Response")+ x = grid::unit(xlim, "native"), |
||
| 71 | -+ | |||
| 800 | +! |
- #' df <- extract_rsp_subgroups(+ y = y, |
||
| 72 | -+ | |||
| 801 | +! |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")),
+ arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "both") |
||
| 73 | +802 |
- #' data = adrs+ ) |
||
| 74 | -+ | |||
| 803 | +! |
- #' )+ } else if (ci[1] < xlim[1] && ci[2] <= xlim[2]) {
|
||
| 75 | +804 |
- #' # Full commonly used response table.+ # <- |
||
| 76 | -+ | |||
| 805 | +! |
- #'+ grid::linesGrob( |
||
| 77 | -+ | |||
| 806 | +! |
- #' tbl <- basic_table() %>%+ x = grid::unit(c(xlim[1], ci[2]), "native"), |
||
| 78 | -+ | |||
| 807 | +! |
- #' tabulate_rsp_subgroups(df)+ y = y, |
||
| 79 | -+ | |||
| 808 | +! |
- #' g_forest(tbl)+ arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "first") |
||
| 80 | +809 |
- #'+ ) |
||
| 81 | -+ | |||
| 810 | +! |
- #' # Odds ratio only table.+ } else if (ci[1] >= xlim[1] && ci[2] > xlim[2]) {
|
||
| 82 | +811 |
- #'+ # -> |
||
| 83 | -+ | |||
| 812 | +! |
- #' tbl_or <- basic_table() %>%+ grid::linesGrob( |
||
| 84 | -+ | |||
| 813 | +! |
- #' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci"))
+ x = grid::unit(c(ci[1], xlim[2]), "native"), |
||
| 85 | -+ | |||
| 814 | +! |
- #' g_forest(+ y = y, |
||
| 86 | -+ | |||
| 815 | +! |
- #' tbl_or,+ arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "last") |
||
| 87 | +816 |
- #' forest_header = c("Comparison\nBetter", "Treatment\nBetter")
+ ) |
||
| 88 | +817 |
- #' )+ } |
||
| 89 | +818 |
- #'+ } else {
|
||
| 90 | -+ | |||
| 819 | +! |
- #' # Survival forest plot example.+ NULL |
||
| 91 | +820 |
- #' adtte <- tern_ex_adtte+ } |
||
| 92 | +821 |
- #' # Save variable labels before data processing steps.+ |
||
| 93 | -+ | |||
| 822 | +3x |
- #' adtte_labels <- formatters::var_labels(adtte, fill = TRUE)+ g_circle <- if (!is.na(x) && x >= xlim[1] && x <= xlim[2]) {
|
||
| 94 | -+ | |||
| 823 | +3x |
- #' adtte_f <- adtte %>%+ grid::circleGrob( |
||
| 95 | -+ | |||
| 824 | +3x |
- #' filter(+ x = grid::unit(x, "native"), |
||
| 96 | -+ | |||
| 825 | +3x |
- #' PARAMCD == "OS",+ y = y, |
||
| 97 | -+ | |||
| 826 | +3x |
- #' ARM %in% c("B: Placebo", "A: Drug X"),
+ r = grid::unit(1 / 3.5 * symbol_size, "lines"), |
||
| 98 | -+ | |||
| 827 | +3x |
- #' SEX %in% c("M", "F")
+ name = "point" |
||
| 99 | +828 |
- #' ) %>%+ ) |
||
| 100 | +829 |
- #' mutate(+ } else {
|
||
| 101 | -+ | |||
| 830 | +! |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ NULL |
||
| 102 | +831 |
- #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),+ } |
||
| 103 | +832 |
- #' SEX = droplevels(SEX),+ |
||
| 104 | -+ | |||
| 833 | +3x |
- #' AVALU = as.character(AVALU),+ grid::gTree( |
||
| 105 | -+ | |||
| 834 | +3x |
- #' is_event = CNSR == 0+ children = grid::gList( |
||
| 106 | -+ | |||
| 835 | +3x |
- #' )+ grid::gTree( |
||
| 107 | -+ | |||
| 836 | +3x |
- #' labels <- list(+ children = grid::gList( |
||
| 108 | -+ | |||
| 837 | +3x |
- #' "ARM" = adtte_labels["ARM"],+ grid::gList( |
||
| 109 | -+ | |||
| 838 | +3x |
- #' "SEX" = adtte_labels["SEX"],+ g_line, |
||
| 110 | -+ | |||
| 839 | +3x |
- #' "AVALU" = adtte_labels["AVALU"],+ g_circle |
||
| 111 | +840 |
- #' "is_event" = "Event Flag"+ ) |
||
| 112 | +841 |
- #' )+ ), |
||
| 113 | -+ | |||
| 842 | +3x |
- #' formatters::var_labels(adtte_f)[names(labels)] <- as.character(labels)+ vp = datavp, |
||
| 114 | -+ | |||
| 843 | +3x |
- #' df <- extract_survival_subgroups(+ gp = grid::gpar(col = col, fill = col) |
||
| 115 | +844 |
- #' variables = list(+ ) |
||
| 116 | +845 |
- #' tte = "AVAL",+ ), |
||
| 117 | -+ | |||
| 846 | +3x |
- #' is_event = "is_event",+ vp = grid::vpPath(paste0("forest-", row_index))
|
||
| 118 | +847 |
- #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ ) |
||
| 119 | +848 |
- #' ),+ } else {
|
||
| 120 | -+ | |||
| 849 | +! |
- #' data = adtte_f+ NULL |
||
| 121 | +850 |
- #' )+ } |
||
| 122 | +851 |
- #' table_hr <- basic_table() %>%+ } |
||
| 123 | +852 |
- #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1])+ |
||
| 124 | +853 |
- #' g_forest(table_hr)+ #' Create a viewport tree for the forest plot |
||
| 125 | +854 |
#' |
||
| 126 | +855 |
- #' # Works with any `rtable`.+ #' @description `r lifecycle::badge("deprecated")`
|
||
| 127 | +856 |
- #' tbl <- rtable(+ #' |
||
| 128 | +857 |
- #' header = c("E", "CI", "N"),
+ #' @param tbl (`VTableTree`)\cr `rtables` table object. |
||
| 129 | +858 |
- #' rrow("", 1, c(.8, 1.2), 200),
+ #' @param width_row_names (`grid::unit`)\cr width of row names. |
||
| 130 | +859 |
- #' rrow("", 1.2, c(1.1, 1.4), 50)
+ #' @param width_columns (`grid::unit`)\cr width of column spans. |
||
| 131 | +860 |
- #' )+ #' @param width_forest (`grid::unit`)\cr width of the forest plot. |
||
| 132 | +861 |
- #' g_forest(+ #' @param gap_column (`grid::unit`)\cr gap width between the columns. |
||
| 133 | +862 |
- #' tbl = tbl,+ #' @param gap_header (`grid::unit`)\cr gap width between the header. |
||
| 134 | +863 |
- #' col_x = 1,+ #' @param mat_form (`MatrixPrintForm`)\cr matrix print form of the table. |
||
| 135 | +864 |
- #' col_ci = 2,+ #' |
||
| 136 | +865 |
- #' xlim = c(0.5, 2),+ #' @return A viewport tree. |
||
| 137 | +866 |
- #' x_at = c(0.5, 1, 2),+ #' |
||
| 138 | +867 |
- #' col_symbol_size = 3+ #' @examples |
||
| 139 | +868 |
- #' )+ #' library(grid) |
||
| 140 | +869 |
#' |
||
| 141 | +870 |
#' tbl <- rtable( |
||
| 142 | +871 |
#' header = rheader( |
||
| 143 | +872 |
- #' rrow("", rcell("A", colspan = 2)),
+ #' rrow("", "E", rcell("CI", colspan = 2)),
|
||
| 144 | +873 |
- #' rrow("", "c1", "c2")
+ #' rrow("", "A", "B", "C")
|
||
| 145 | +874 |
#' ), |
||
| 146 | +875 |
- #' rrow("row 1", 1, c(.8, 1.2)),
+ #' rrow("row 1", 1, 0.8, 1.1),
|
||
| 147 | +876 |
- #' rrow("row 2", 1.2, c(1.1, 1.4))
+ #' rrow("row 2", 1.4, 0.8, 1.6),
|
||
| 148 | +877 |
- #' )+ #' rrow("row 3", 1.2, 0.8, 1.2)
|
||
| 149 | +878 |
- #' g_forest(+ #' ) |
||
| 150 | +879 |
- #' tbl = tbl,+ #' |
||
| 151 | +880 |
- #' col_x = 1,+ #' \donttest{
|
||
| 152 | +881 |
- #' col_ci = 2,+ #' v <- forest_viewport(tbl) |
||
| 153 | +882 |
- #' xlim = c(0.5, 2),+ #' |
||
| 154 | +883 |
- #' x_at = c(0.5, 1, 2),+ #' grid::grid.newpage() |
||
| 155 | +884 |
- #' vline = 1,+ #' showViewport(v) |
||
| 156 | +885 |
- #' forest_header = c("Hello", "World")
+ #' } |
||
| 157 | +886 |
- #' )+ #' |
||
| 158 | +887 |
- #'+ #' @export |
||
| 159 | +888 |
- #' @export+ forest_viewport <- function(tbl, |
||
| 160 | +889 |
- g_forest <- function(tbl,+ width_row_names = NULL, |
||
| 161 | +890 |
- col_x = attr(tbl, "col_x"),+ width_columns = NULL, |
||
| 162 | +891 |
- col_ci = attr(tbl, "col_ci"),+ width_forest = grid::unit(1, "null"), |
||
| 163 | +892 |
- vline = 1,+ gap_column = grid::unit(1, "lines"), |
||
| 164 | +893 |
- forest_header = attr(tbl, "forest_header"),+ gap_header = grid::unit(1, "lines"), |
||
| 165 | +894 |
- xlim = c(0.1, 10),+ mat_form = NULL) {
|
||
| 166 | -+ | |||
| 895 | +2x |
- logx = TRUE,+ lifecycle::deprecate_warn( |
||
| 167 | -+ | |||
| 896 | +2x |
- x_at = c(0.1, 1, 10),+ "0.9.4", |
||
| 168 | -+ | |||
| 897 | +2x |
- width_row_names = lifecycle::deprecated(),+ "forest_viewport()", |
||
| 169 | -+ | |||
| 898 | +2x |
- width_columns = NULL,+ details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
||
| 170 | +899 |
- width_forest = lifecycle::deprecated(),+ ) |
||
| 171 | +900 |
- lbl_col_padding = 0,+ |
||
| 172 | -+ | |||
| 901 | +2x |
- rel_width_forest = 0.25,+ checkmate::assert_class(tbl, "VTableTree") |
||
| 173 | -+ | |||
| 902 | +2x |
- font_size = 12,+ checkmate::assert_true(grid::is.unit(width_forest)) |
||
| 174 | -+ | |||
| 903 | +2x |
- col_symbol_size = attr(tbl, "col_symbol_size"),+ if (!is.null(width_row_names)) {
|
||
| 175 | -+ | |||
| 904 | +! |
- col = getOption("ggplot2.discrete.colour")[1],
+ checkmate::assert_true(grid::is.unit(width_row_names)) |
||
| 176 | +905 |
- ggtheme = NULL,+ } |
||
| 177 | -+ | |||
| 906 | +2x |
- as_list = FALSE,+ if (!is.null(width_columns)) {
|
||
| 178 | -+ | |||
| 907 | +! |
- gp = lifecycle::deprecated(),+ checkmate::assert_true(grid::is.unit(width_columns)) |
||
| 179 | +908 |
- draw = lifecycle::deprecated(),+ } |
||
| 180 | +909 |
- newpage = lifecycle::deprecated()) {
+
+ |
+ ||
| 910 | +2x | +
+ if (is.null(mat_form)) mat_form <- matrix_form(tbl) |
||
| 181 | +911 |
- # Deprecated argument warnings+ |
||
| 182 | -4x | +912 | +2x |
- if (lifecycle::is_present(width_row_names)) {
+ mat_form$strings[!mat_form$display] <- "" |
| 183 | -1x | +|||
| 913 | +
- lifecycle::deprecate_warn(+ |
|||
| 184 | -1x | +914 | +2x |
- "0.9.4", "g_forest(width_row_names)", "g_forest(lbl_col_padding)",+ nr <- nrow(tbl) |
| 185 | -1x | +915 | +2x |
- details = "The width of the row label column can be adjusted via the `lbl_col_padding` parameter."+ nc <- ncol(tbl) |
| 186 | -+ | |||
| 916 | +2x |
- )+ nr_h <- attr(mat_form, "nrow_header") |
||
| 187 | +917 |
- }+ |
||
| 188 | -4x | +918 | +2x |
- if (lifecycle::is_present(width_forest)) {
+ if (is.null(width_row_names) || is.null(width_columns)) {
|
| 189 | -1x | +919 | +2x |
- lifecycle::deprecate_warn(+ tbl_widths <- formatters::propose_column_widths(mat_form) |
| 190 | -1x | +920 | +2x |
- "0.9.4", "g_forest(width_forest)", "g_forest(rel_width_forest)",+ strs_with_width <- strrep("x", tbl_widths) # that works for mono spaced fonts
|
| 191 | -1x | +921 | +2x |
- details = "Relative width of the forest plot (as a proportion) can be set via the `rel_width_forest` parameter."+ if (is.null(width_row_names)) width_row_names <- grid::stringWidth(strs_with_width[1]) |
| 192 | -+ | |||
| 922 | +2x |
- )+ if (is.null(width_columns)) width_columns <- grid::stringWidth(strs_with_width[-1]) |
||
| 193 | +923 |
} |
||
| 194 | -4x | +|||
| 924 | +
- if (lifecycle::is_present(gp)) {
+
|
|||
| 195 | -1x | +|||
| 925 | +
- lifecycle::deprecate_warn(+ # Widths for row name, cols, forest. |
|||
| 196 | -1x | +926 | +2x |
- "0.9.4", "g_forest(gp)", "g_forest(ggtheme)",+ widths <- grid::unit.c( |
| 197 | -1x | +927 | +2x |
- details = paste(+ width_row_names + gap_column, |
| 198 | -1x | +928 | +2x |
- "`g_forest` is now generated as a `ggplot` object.",+ width_columns + gap_column, |
| 199 | -1x | -
- "Additional display settings should be supplied via the `ggtheme` parameter."- |
- ||
| 200 | -+ | 929 | +2x |
- )+ width_forest |
| 201 | +930 |
- )+ ) |
||
| 202 | +931 |
- }+ |
||
| 203 | -4x | +932 | +2x |
- if (lifecycle::is_present(draw)) {
+ n_lines_per_row <- apply( |
| 204 | -1x | +933 | +2x |
- lifecycle::deprecate_warn(+ X = mat_form$strings, |
| 205 | -1x | +934 | +2x |
- "0.9.4", "g_forest(draw)",+ MARGIN = 1, |
| 206 | -1x | +935 | +2x |
- details = "`g_forest` now generates `ggplot` objects. This parameter has no effect."+ FUN = function(row) {
|
| 207 | -+ | |||
| 936 | +10x |
- )+ tmp <- vapply( |
||
| 208 | -+ | |||
| 937 | +10x |
- }+ gregexpr("\n", row, fixed = TRUE),
|
||
| 209 | -4x | +938 | +10x |
- if (lifecycle::is_present(newpage)) {
+ attr, numeric(1), |
| 210 | -1x | +939 | +10x |
- lifecycle::deprecate_warn(+ "match.length" |
| 211 | -1x | +940 | +10x |
- "0.9.4", "g_forest(newpage)",+ ) + 1 |
| 212 | -1x | +941 | +10x |
- details = "`g_forest` now generates `ggplot` objects. This parameter has no effect."+ max(c(tmp, 1)) |
| 213 | +942 |
- )+ } |
||
| 214 | +943 |
- }+ ) |
||
| 215 | +944 | |||
| 216 | -4x | +945 | +2x |
- checkmate::assert_class(tbl, "VTableTree")+ i_header <- seq_len(nr_h) |
| 217 | -4x | +|||
| 946 | +
- checkmate::assert_number(col_x, lower = 0, upper = ncol(tbl), null.ok = TRUE)+ |
|||
| 218 | -4x | +947 | +2x |
- checkmate::assert_number(col_ci, lower = 0, upper = ncol(tbl), null.ok = TRUE)+ height_body_rows <- grid::unit(n_lines_per_row[-i_header] * 1.2, "lines") |
| 219 | -4x | +948 | +2x |
- checkmate::assert_number(col_symbol_size, lower = 0, upper = ncol(tbl), null.ok = TRUE)+ height_header_rows <- grid::unit(n_lines_per_row[i_header] * 1.2, "lines") |
| 220 | -4x | +|||
| 949 | +
- checkmate::assert_number(font_size, lower = 0)+ |
|||
| 221 | -4x | +950 | +2x |
- checkmate::assert_character(col, null.ok = TRUE)+ height_body <- grid::unit(sum(n_lines_per_row[-i_header]) * 1.2, "lines") |
| 222 | -4x | +951 | +2x |
- checkmate::assert_true(is.null(col) | length(col) == 1 | length(col) == nrow(tbl))+ height_header <- grid::unit(sum(n_lines_per_row[i_header]) * 1.2, "lines") |
| 223 | +952 | |||
| 953 | +2x | +
+ nc_g <- nc + 2 # number of columns incl. row names and forest+ |
+ ||
| 224 | +954 |
- # Extract info from table+ |
||
| 225 | -4x | +955 | +2x |
- mat <- matrix_form(tbl, indent_rownames = TRUE)+ vp_tbl <- grid::vpTree( |
| 226 | -4x | +956 | +2x |
- mat_strings <- formatters::mf_strings(mat)+ parent = grid::viewport( |
| 227 | -4x | +957 | +2x |
- nlines_hdr <- formatters::mf_nlheader(mat)+ name = "vp_table_layout", |
| 228 | -4x | +958 | +2x |
- nrows_body <- nrow(mat_strings) - nlines_hdr+ layout = grid::grid.layout( |
| 229 | -4x | +959 | +2x |
- tbl_stats <- mat_strings[nlines_hdr, -1]+ nrow = 3, ncol = 1, |
| 230 | -+ | |||
| 960 | +2x |
-
+ heights = grid::unit.c(height_header, gap_header, height_body) |
||
| 231 | +961 |
- # Generate and modify table as ggplot object- |
- ||
| 232 | -4x | -
- gg_table <- rtable2gg(tbl, fontsize = font_size, colwidths = width_columns, lbl_col_padding = lbl_col_padding) ++ ) |
||
| 233 | -4x | +|||
| 962 | +
- theme(plot.margin = margin(0, 0, 0, 0.025, "npc"))+ ), |
|||
| 234 | -4x | +963 | +2x |
- gg_table$scales$scales[[1]]$expand <- c(0.01, 0.01)+ children = grid::vpList( |
| 235 | -4x | +964 | +2x |
- gg_table$scales$scales[[2]]$limits[2] <- nrow(mat_strings) + 1+ vp_forest_table_part(nr_h, nc_g, 1, 1, widths, height_header_rows, "vp_header"), |
| 236 | -4x | +965 | +2x |
- if (nlines_hdr == 2) {
+ vp_forest_table_part(nr, nc_g, 3, 1, widths, height_body_rows, "vp_body"), |
| 237 | -4x | +966 | +2x |
- gg_table$scales$scales[[2]]$expand <- c(0, 0)+ grid::viewport(name = "vp_spacer", layout.pos.row = 2, layout.pos.col = 1) |
| 238 | -4x | +|||
| 967 | +
- arms <- unique(mat_strings[1, ][nzchar(trimws(mat_strings[1, ]))])+ ) |
|||
| 239 | +968 |
- } else {
+ ) |
||
| 240 | -! | +|||
| 969 | +2x |
- arms <- NULL+ vp_tbl |
||
| 241 | +970 |
- }+ } |
||
| 242 | +971 | |||
| 243 | -4x | -
- tbl_df <- as_result_df(tbl)- |
- ||
| 244 | -4x | -
- dat_cols <- seq(which(names(tbl_df) == "node_class") + 1, ncol(tbl_df))- |
- ||
| 245 | -4x | -
- tbl_df <- tbl_df[, c(which(names(tbl_df) == "row_num"), dat_cols)]- |
- ||
| 246 | -4x | -
- names(tbl_df) <- c("row_num", tbl_stats)
- |
- ||
| 247 | +972 |
-
+ #' Viewport forest plot: table part |
||
| 248 | +973 |
- # Check table data columns- |
- ||
| 249 | -4x | -
- if (!is.null(col_ci)) {
+ #' |
||
| 250 | -4x | +|||
| 974 | +
- ci_col <- col_ci + 1+ #' @description `r lifecycle::badge("deprecated")`
|
|||
| 251 | +975 |
- } else {
+ #' |
||
| 252 | -! | +|||
| 976 | +
- tbl_df[["empty_ci"]] <- rep(list(c(NA_real_, NA_real_)), nrow(tbl_df))+ #' Prepares a viewport for the table included in the forest plot. |
|||
| 253 | -! | +|||
| 977 | +
- ci_col <- which(names(tbl_df) == "empty_ci")+ #' |
|||
| 254 | +978 |
- }+ #' @noRd |
||
| 255 | -! | +|||
| 979 | +
- if (length(tbl_df[, ci_col][[1]]) != 2) stop("CI column must have two elements (lower and upper limits).")
+ #' @keywords internal |
|||
| 256 | +980 |
-
+ vp_forest_table_part <- function(nrow, |
||
| 257 | -4x | +|||
| 981 | +
- if (!is.null(col_x)) {
+ ncol, |
|||
| 258 | -4x | +|||
| 982 | +
- x_col <- col_x + 1+ l_row, |
|||
| 259 | +983 |
- } else {
+ l_col, |
||
| 260 | -! | +|||
| 984 | +
- tbl_df[["empty_x"]] <- NA_real_+ widths, |
|||
| 261 | -! | +|||
| 985 | +
- x_col <- which(names(tbl_df) == "empty_x")+ heights, |
|||
| 262 | +986 |
- }+ name) {
|
||
| 263 | +987 | 4x |
- if (!is.null(col_symbol_size)) {
+ lifecycle::deprecate_warn( |
|
| 264 | -3x | -
- sym_size <- unlist(tbl_df[, col_symbol_size + 1])- |
- ||
| 265 | -+ | 988 | +4x |
- } else {
+ "0.9.4", "vp_forest_table_part()", |
| 266 | -1x | +989 | +4x |
- sym_size <- rep(1, nrow(tbl_df))+ details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
| 267 | +990 |
- }+ ) |
||
| 268 | +991 | |||
| 269 | +992 | 4x |
- tbl_df[, c("ci_lwr", "ci_upr")] <- t(sapply(tbl_df[, ci_col], unlist))
+ grid::vpTree( |
|
| 270 | +993 | 4x |
- x <- unlist(tbl_df[, x_col])+ grid::viewport( |
|
| 271 | +994 | 4x |
- lwr <- unlist(tbl_df[["ci_lwr"]])+ name = name, |
|
| 272 | +995 | 4x |
- upr <- unlist(tbl_df[["ci_upr"]])+ layout.pos.row = l_row, |
|
| 273 | +996 | 4x |
- row_num <- nrow(mat_strings) - tbl_df[["row_num"]] - as.numeric(nlines_hdr == 2)+ layout.pos.col = l_col,+ |
+ |
| 997 | +4x | +
+ layout = grid::grid.layout(nrow = nrow, ncol = ncol, widths = widths, heights = heights) |
||
| 274 | +998 |
-
+ ), |
||
| 275 | -! | +|||
| 999 | +4x |
- if (is.null(col)) col <- "#343cff"+ children = grid::vpList( |
||
| 276 | +1000 | 4x |
- if (length(col) == 1) col <- rep(col, nrow(tbl_df))+ do.call( |
|
| 277 | -! | +|||
| 1001 | +4x |
- if (is.null(x_at)) x_at <- union(xlim, vline)+ grid::vpList, |
||
| 278 | +1002 | 4x |
- x_labels <- x_at+ lapply(+ |
+ |
| 1003 | +4x | +
+ seq_len(nrow), function(i) {
+ |
+ ||
| 1004 | +10x | +
+ grid::viewport(layout.pos.row = i, layout.pos.col = 1, name = paste0("rowname-", i))
|
||
| 279 | +1005 |
-
+ } |
||
| 280 | +1006 |
- # Apply log transformation+ ) |
||
| 281 | -4x | +|||
| 1007 | +
- if (logx) {
+ ), |
|||
| 282 | +1008 | 4x |
- x_t <- log(x)+ do.call( |
|
| 283 | +1009 | 4x |
- lwr_t <- log(lwr)+ grid::vpList, |
|
| 284 | +1010 | 4x |
- upr_t <- log(upr)+ apply( |
|
| 285 | +1011 | 4x |
- xlim_t <- log(xlim)+ expand.grid(seq_len(nrow), seq_len(ncol - 2)), |
|
| 286 | -+ | |||
| 1012 | +4x |
- } else {
+ 1, |
||
| 287 | -! | +|||
| 1013 | +4x |
- x_t <- x+ function(x) {
|
||
| 288 | -! | +|||
| 1014 | +35x |
- lwr_t <- lwr+ i <- x[1] |
||
| 289 | -! | +|||
| 1015 | +35x |
- upr_t <- upr+ j <- x[2] |
||
| 290 | -! | +|||
| 1016 | +35x |
- xlim_t <- xlim+ grid::viewport(layout.pos.row = i, layout.pos.col = j + 1, name = paste0("cell-", i, "-", j))
|
||
| 291 | +1017 |
- }+ } |
||
| 292 | +1018 |
-
+ ) |
||
| 293 | +1019 |
- # Set up plot area+ ), |
||
| 294 | +1020 | 4x |
- gg_plt <- ggplot(data = tbl_df) ++ do.call( |
|
| 295 | +1021 | 4x |
- theme(+ grid::vpList, |
|
| 296 | +1022 | 4x |
- panel.background = element_rect(fill = "transparent", color = NA_character_),+ lapply( |
|
| 297 | +1023 | 4x |
- plot.background = element_rect(fill = "transparent", color = NA_character_),+ seq_len(nrow), |
|
| 298 | +1024 | 4x |
- panel.grid.major = element_blank(),+ function(i) {
|
|
| 299 | -4x | +1025 | +10x |
- panel.grid.minor = element_blank(),+ grid::viewport(layout.pos.row = i, layout.pos.col = ncol, name = paste0("forest-", i))
|
| 300 | -4x | +|||
| 1026 | +
- axis.title.x = element_blank(),+ } |
|||
| 301 | -4x | +|||
| 1027 | +
- axis.title.y = element_blank(),+ ) |
|||
| 302 | -4x | +|||
| 1028 | +
- axis.line.x = element_line(),+ ) |
|||
| 303 | -4x | +|||
| 1029 | +
- axis.text = element_text(size = font_size),+ ) |
|||
| 304 | -4x | +|||
| 1030 | +
- legend.position = "none",+ ) |
|||
| 305 | -4x | +|||
| 1031 | +
- plot.margin = margin(0, 0.1, 0.05, 0, "npc")+ } |
|||
| 306 | +1032 |
- ) ++ |
||
| 307 | -4x | +|||
| 1033 | +
- scale_x_continuous(+ #' Forest rendering |
|||
| 308 | -4x | +|||
| 1034 | +
- transform = ifelse(logx, "log", "identity"),+ #' |
|||
| 309 | -4x | +|||
| 1035 | +
- limits = xlim,+ #' @description `r lifecycle::badge("deprecated")`
|
|||
| 310 | -4x | +|||
| 1036 | +
- breaks = x_at,+ #' |
|||
| 311 | -4x | +|||
| 1037 | +
- labels = x_labels,+ #' Renders the forest grob. |
|||
| 312 | -4x | +|||
| 1038 | +
- expand = c(0.01, 0)+ #' |
|||
| 313 | +1039 |
- ) ++ #' @noRd |
||
| 314 | -4x | +|||
| 1040 | +
- scale_y_continuous(+ #' @keywords internal |
|||
| 315 | -4x | +|||
| 1041 | +
- limits = c(0, nrow(mat_strings) + 1),+ grid.forest <- function(...) { # nolint
|
|||
| 316 | -4x | +|||
| 1042 | +! |
- breaks = NULL,+ lifecycle::deprecate_warn( |
||
| 317 | -4x | +|||
| 1043 | +! |
- expand = c(0, 0)+ "0.9.4", "grid.forest()", |
||
| 318 | -+ | |||
| 1044 | +! |
- ) ++ details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." |
||
| 319 | -4x | +|||
| 1045 | +
- coord_cartesian(clip = "off")+ ) |
|||
| 320 | +1046 | |||
| 321 | -4x | +|||
| 1047 | +! |
- if (is.null(ggtheme)) {
+ grid::grid.draw(forest_grob(...)) |
||
| 322 | -4x | +|||
| 1048 | +
- gg_plt <- gg_plt + annotate(+ } |
|||
| 323 | -4x | +
| 1 | +
- "rect",+ #' Split function to configure risk difference column |
|||
| 324 | -4x | +|||
| 2 | +
- xmin = xlim[1],+ #' |
|||
| 325 | -4x | +|||
| 3 | +
- xmax = xlim[2],+ #' @description `r lifecycle::badge("stable")`
|
|||
| 326 | -4x | +|||
| 4 | +
- ymin = 0,+ #' |
|||
| 327 | -4x | +|||
| 5 | +
- ymax = nrows_body + 0.5,+ #' Wrapper function for [rtables::add_combo_levels()] which configures settings for the risk difference |
|||
| 328 | -4x | +|||
| 6 | +
- fill = "grey92"+ #' column to be added to an `rtables` object. To add a risk difference column to a table, this function |
|||
| 329 | +7 |
- )+ #' should be used as `split_fun` in calls to [rtables::split_cols_by()], followed by setting argument |
||
| 330 | +8 |
- }+ #' `riskdiff` to `TRUE` in all following analyze function calls. |
||
| 331 | +9 |
-
+ #' |
||
| 332 | -4x | +|||
| 10 | +
- if (!is.null(vline)) {
+ #' @param arm_x (`string`)\cr name of reference arm to use in risk difference calculations. |
|||
| 333 | +11 |
- # Set default forest header+ #' @param arm_y (`character`)\cr names of one or more arms to compare to reference arm in risk difference |
||
| 334 | -4x | +|||
| 12 | +
- if (is.null(forest_header)) {
+ #' calculations. A new column will be added for each value of `arm_y`. |
|||
| 335 | -! | +|||
| 13 | +
- forest_header <- c(+ #' @param col_label (`character`)\cr labels to use when rendering the risk difference column within the table. |
|||
| 336 | -! | +|||
| 14 | +
- paste(if (length(arms) == 2) arms[1] else "Comparison", "Better", sep = "\n"),+ #' If more than one comparison arm is specified in `arm_y`, default labels will specify which two arms are |
|||
| 337 | -! | +|||
| 15 | +
- paste(if (length(arms) == 2) arms[2] else "Treatment", "Better", sep = "\n")+ #' being compared (reference arm vs. comparison arm). |
|||
| 338 | +16 |
- )+ #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`. |
||
| 339 | +17 |
- }+ #' |
||
| 340 | +18 |
-
+ #' @return A closure suitable for use as a split function (`split_fun`) within [rtables::split_cols_by()] |
||
| 341 | +19 |
- # Add vline and forest header labels+ #' when creating a table layout. |
||
| 342 | -4x | +|||
| 20 | +
- mid_pts <- if (logx) {
+ #' |
|||
| 343 | -4x | +|||
| 21 | +
- c(exp(mean(log(c(xlim[1], vline)))), exp(mean(log(c(vline, xlim[2])))))+ #' @seealso [stat_propdiff_ci()] for details on risk difference calculation. |
|||
| 344 | +22 |
- } else {
+ #' |
||
| 345 | -! | +|||
| 23 | +
- c(mean(c(xlim[1], vline)), mean(c(vline, xlim[2])))+ #' @examples |
|||
| 346 | +24 |
- }+ #' adae <- tern_ex_adae |
||
| 347 | -4x | +|||
| 25 | +
- gg_plt <- gg_plt ++ #' adae$AESEV <- factor(adae$AESEV) |
|||
| 348 | -4x | +|||
| 26 | +
- annotate(+ #' |
|||
| 349 | -4x | +|||
| 27 | +
- "segment",+ #' lyt <- basic_table() %>% |
|||
| 350 | -4x | +|||
| 28 | +
- x = vline, xend = vline, y = 0, yend = nrows_body + 0.5+ #' split_cols_by("ARMCD", split_fun = add_riskdiff(arm_x = "ARM A", arm_y = c("ARM B", "ARM C"))) %>%
|
|||
| 351 | +29 |
- ) ++ #' count_occurrences_by_grade( |
||
| 352 | -4x | +|||
| 30 | +
- annotate(+ #' var = "AESEV", |
|||
| 353 | -4x | +|||
| 31 | +
- "text",+ #' riskdiff = TRUE |
|||
| 354 | -4x | +|||
| 32 | +
- x = mid_pts[1], y = nrows_body + 1.25,+ #' ) |
|||
| 355 | -4x | +|||
| 33 | +
- label = forest_header[1],+ #' |
|||
| 356 | -4x | +|||
| 34 | +
- size = font_size / .pt,+ #' tbl <- build_table(lyt, df = adae) |
|||
| 357 | -4x | +|||
| 35 | +
- lineheight = 0.9+ #' tbl |
|||
| 358 | +36 |
- ) ++ #' |
||
| 359 | -4x | +|||
| 37 | +
- annotate(+ #' @export |
|||
| 360 | -4x | +|||
| 38 | +
- "text",+ add_riskdiff <- function(arm_x, |
|||
| 361 | -4x | +|||
| 39 | +
- x = mid_pts[2], y = nrows_body + 1.25,+ arm_y, |
|||
| 362 | -4x | +|||
| 40 | +
- label = forest_header[2],+ col_label = paste0( |
|||
| 363 | -4x | +|||
| 41 | +
- size = font_size / .pt,+ "Risk Difference (%) (95% CI)", if (length(arm_y) > 1) paste0("\n", arm_x, " vs. ", arm_y)
|
|||
| 364 | -4x | +|||
| 42 | +
- lineheight = 0.9+ ), |
|||
| 365 | +43 |
- )+ pct = TRUE) {
|
||
| 366 | -+ | |||
| 44 | +19x |
- }+ checkmate::assert_character(arm_x, len = 1) |
||
| 367 | -+ | |||
| 45 | +19x |
-
+ checkmate::assert_character(arm_y, min.len = 1)+ |
+ ||
| 46 | +19x | +
+ checkmate::assert_character(col_label, len = length(arm_y)) |
||
| 368 | +47 |
- # Add points to plot+ |
||
| 369 | -4x | +48 | +19x |
- if (any(!is.na(x_t))) {
+ combodf <- tibble::tribble(~valname, ~label, ~levelcombo, ~exargs) |
| 370 | -4x | +49 | +19x |
- x_t[x < xlim[1] | x > xlim[2]] <- NA+ for (i in seq_len(length(arm_y))) {
|
| 371 | -4x | +50 | +20x |
- gg_plt <- gg_plt + geom_point(+ combodf <- rbind( |
| 372 | -4x | +51 | +20x |
- x = x_t,+ combodf, |
| 373 | -4x | +52 | +20x |
- y = row_num,+ tibble::tribble( |
| 374 | -4x | +53 | +20x |
- color = col,+ ~valname, ~label, ~levelcombo, ~exargs, |
| 375 | -4x | +54 | +20x |
- aes(size = sym_size),+ paste("riskdiff", arm_x, arm_y[i], sep = "_"), col_label[i], c(arm_x, arm_y[i]), list()
|
| 376 | -4x | +|||
| 55 | +
- na.rm = TRUE+ ) |
|||
| 377 | +56 |
) |
||
| 378 | +57 |
} |
||
| 58 | +19x | +
+ if (pct) combodf$valname <- paste0(combodf$valname, "_pct")+ |
+ ||
| 59 | +19x | +
+ add_combo_levels(combodf)+ |
+ ||
| 379 | +60 | ++ |
+ }+ |
+ |
| 61 | ||||
| 380 | -4x | +|||
| 62 | +
- for (i in seq_len(nrow(tbl_df))) {
+ #' Analysis function to calculate risk difference column values |
|||
| 381 | +63 |
- # Determine which arrow(s) to add to CI lines+ #' |
||
| 382 | -17x | +|||
| 64 | +
- which_arrow <- c(lwr_t[i] < xlim_t[1], upr_t[i] > xlim_t[2])+ #' In the risk difference column, this function uses the statistics function associated with `afun` to |
|||
| 383 | -17x | +|||
| 65 | +
- which_arrow <- dplyr::case_when(+ #' calculates risk difference values from arm X (reference group) and arm Y. These arms are specified |
|||
| 384 | -17x | +|||
| 66 | +
- all(which_arrow) ~ "both",+ #' when configuring the risk difference column which is done using the [add_riskdiff()] split function in |
|||
| 385 | -17x | +|||
| 67 | +
- which_arrow[1] ~ "first",+ #' the previous call to [rtables::split_cols_by()]. For all other columns, applies `afun` as usual. This |
|||
| 386 | -17x | +|||
| 68 | +
- which_arrow[2] ~ "last",+ #' function utilizes the [stat_propdiff_ci()] function to perform risk difference calculations. |
|||
| 387 | -17x | +|||
| 69 | +
- TRUE ~ NA_character_+ #' |
|||
| 388 | +70 |
- )+ #' @inheritParams argument_convention |
||
| 389 | +71 |
-
+ #' @param afun (named `list`)\cr a named list containing one name-value pair where the name corresponds to |
||
| 390 | +72 |
- # Add CI lines+ #' the name of the statistics function that should be used in calculations and the value is the corresponding |
||
| 391 | -17x | +|||
| 73 | +
- gg_plt <- gg_plt ++ #' analysis function. |
|||
| 392 | -17x | +|||
| 74 | +
- if (!is.na(which_arrow)) {
+ #' @param s_args (named `list`)\cr additional arguments to be passed to the statistics function and analysis |
|||
| 393 | -15x | +|||
| 75 | +
- annotate(+ #' function supplied in `afun`. |
|||
| 394 | -15x | +|||
| 76 | +
- "segment",+ #' |
|||
| 395 | -15x | +|||
| 77 | +
- x = if (!which_arrow %in% c("first", "both")) lwr[i] else xlim[1],
+ #' @return A list of formatted [rtables::CellValue()]. |
|||
| 396 | -15x | +|||
| 78 | +
- xend = if (!which_arrow %in% c("last", "both")) upr[i] else xlim[2],
+ #' |
|||
| 397 | -15x | +|||
| 79 | +
- y = row_num[i], yend = row_num[i],+ #' @seealso |
|||
| 398 | -15x | +|||
| 80 | +
- color = if (length(col) == 1) col else col[i],+ #' * [stat_propdiff_ci()] for details on risk difference calculation. |
|||
| 399 | -15x | +|||
| 81 | +
- arrow = arrow(length = unit(0.05, "npc"), ends = which_arrow),+ #' * Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()] with |
|||
| 400 | -15x | +|||
| 82 | +
- na.rm = TRUE+ #' `riskdiff` argument set to `TRUE` in subsequent analyze functions calls, adds a risk difference column |
|||
| 401 | +83 |
- )+ #' to a table layout. |
||
| 402 | +84 |
- } else {
+ #' |
||
| 403 | -2x | +|||
| 85 | +
- annotate(+ #' @keywords internal |
|||
| 404 | -2x | +|||
| 86 | +
- "segment",+ afun_riskdiff <- function(df, |
|||
| 405 | -2x | +|||
| 87 | +
- x = lwr[i], xend = upr[i],+ labelstr = "", |
|||
| 406 | -2x | +|||
| 88 | +
- y = row_num[i], yend = row_num[i],+ .var, |
|||
| 407 | -2x | +|||
| 89 | +
- color = if (length(col) == 1) col else col[i],+ .N_col, # nolint |
|||
| 408 | -2x | +|||
| 90 | +
- na.rm = TRUE+ .N_row, # nolint |
|||
| 409 | +91 | ++ |
+ .df_row,+ |
+ |
| 92 | ++ |
+ .spl_context,+ |
+ ||
| 93 | ++ |
+ .all_col_counts,+ |
+ ||
| 94 |
- )+ .stats, |
|||
| 410 | +95 |
- }+ .formats = NULL, |
||
| 411 | +96 |
- }+ .labels = NULL, |
||
| 412 | +97 |
-
+ .indent_mods = NULL, |
||
| 413 | +98 |
- # Apply custom ggtheme to plot+ na_str = default_na_str(), |
||
| 414 | -! | +|||
| 99 | +
- if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme+ afun, |
|||
| 415 | +100 |
-
+ s_args = list()) {
|
||
| 416 | -4x | +101 | +146x |
- if (as_list) {
+ if (!any(grepl("riskdiff", names(.spl_context)))) {
|
| 417 | -1x | +|||
| 102 | +! |
- list(+ stop( |
||
| 418 | -1x | +|||
| 103 | +! |
- table = gg_table,+ "Please set up levels to use in risk difference calculations using the `add_riskdiff` ", |
||
| 419 | -1x | +|||
| 104 | +! |
- plot = gg_plt+ "split function within `split_cols_by`. See ?add_riskdiff for details." |
||
| 420 | +105 |
) |
||
| 421 | +106 |
- } else {
- |
- ||
| 422 | -3x | -
- cowplot::plot_grid(+ } |
||
| 423 | -3x | +107 | +146x |
- gg_table,+ checkmate::assert_list(afun, len = 1, types = "function") |
| 424 | -3x | +108 | +146x |
- gg_plt,+ checkmate::assert_named(afun) |
| 425 | -3x | +109 | +146x |
- align = "h",+ afun_args <- list( |
| 426 | -3x | +110 | +146x |
- axis = "tblr",+ .var = .var, .df_row = .df_row, .N_row = .N_row, denom = "N_col", labelstr = labelstr, |
| 427 | -3x | +111 | +146x |
- rel_widths = c(1 - rel_width_forest, rel_width_forest)+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str |
| 428 | +112 |
- )+ ) |
||
| 429 | -+ | |||
| 113 | +146x |
- }+ afun_args <- afun_args[intersect(names(afun_args), names(as.list(args(afun[[1]]))))] |
||
| 430 | -+ | |||
| 114 | +! |
- }+ if ("denom" %in% names(s_args)) afun_args[["denom"]] <- NULL
|
||
| 431 | +115 | |||
| 432 | -+ | |||
| 116 | +146x |
- #' Forest plot grob+ cur_split <- tail(.spl_context$cur_col_split_val[[1]], 1) |
||
| 433 | -+ | |||
| 117 | +146x |
- #'+ if (!grepl("^riskdiff", cur_split)) {
|
||
| 434 | +118 |
- #' @description `r lifecycle::badge("deprecated")`
+ # Apply basic afun (no risk difference) in all other columns |
||
| 435 | -+ | |||
| 119 | +108x |
- #'+ do.call(afun[[1]], args = c(list(df = df, .N_col = .N_col), afun_args, s_args)) |
||
| 436 | +120 |
- #' @inheritParams g_forest+ } else {
|
||
| 437 | -+ | |||
| 121 | +38x |
- #' @param tbl (`VTableTree`)\cr `rtables` table object.+ arm_x <- strsplit(cur_split, "_")[[1]][2] |
||
| 438 | -+ | |||
| 122 | +38x |
- #' @param x (`numeric`)\cr coordinate of point.+ arm_y <- strsplit(cur_split, "_")[[1]][3] |
||
| 439 | -+ | |||
| 123 | +38x |
- #' @param lower,upper (`numeric`)\cr lower/upper bound of the confidence interval.+ if (length(.spl_context$cur_col_split[[1]]) > 1) { # Different split name for nested column splits
|
||
| 440 | -+ | |||
| 124 | +8x |
- #' @param symbol_size (`numeric`)\cr vector with relative size for plot symbol.+ arm_spl_x <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 2)], collapse = ""))
|
||
| 441 | -+ | |||
| 125 | +8x |
- #' If `NULL`, the same symbol size is used.+ arm_spl_y <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 3)], collapse = ""))
|
||
| 442 | +126 |
- #'+ } else {
|
||
| 443 | -+ | |||
| 127 | +30x |
- #' @details+ arm_spl_x <- arm_x |
||
| 444 | -+ | |||
| 128 | +30x |
- #' The heights get automatically determined.+ arm_spl_y <- arm_y |
||
| 445 | +129 |
- #'+ } |
||
| 446 | +130 |
- #' @examples+ |
||
| 447 | -+ | |||
| 131 | +38x |
- #' tbl <- rtable(+ N_col_x <- .all_col_counts[[arm_spl_x]] # nolint |
||
| 448 | -+ | |||
| 132 | +38x |
- #' header = rheader(+ N_col_y <- .all_col_counts[[arm_spl_y]] # nolint |
||
| 449 | -+ | |||
| 133 | +38x |
- #' rrow("", "E", rcell("CI", colspan = 2), "N"),
+ cur_var <- tail(.spl_context$cur_col_split[[1]], 1) |
||
| 450 | +134 |
- #' rrow("", "A", "B", "C", "D")
+
|
||
| 451 | +135 |
- #' ),+ # Apply statistics function to arm X and arm Y data |
||
| 452 | -+ | |||
| 136 | +38x |
- #' rrow("row 1", 1, 0.8, 1.1, 16),
+ s_args <- c(s_args, afun_args[intersect(names(afun_args), names(as.list(args(names(afun)))))]) |
||
| 453 | -+ | |||
| 137 | +38x |
- #' rrow("row 2", 1.4, 0.8, 1.6, 25),
+ s_x <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_x, ], .N_col = N_col_x), s_args)) |
||
| 454 | -+ | |||
| 138 | +38x |
- #' rrow("row 3", 1.2, 0.8, 1.6, 36)
+ s_y <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_y, ], .N_col = N_col_y), s_args)) |
||
| 455 | +139 |
- #' )+ |
||
| 456 | +140 |
- #'+ # Get statistic name and row names |
||
| 457 | -+ | |||
| 141 | +38x |
- #' x <- c(1, 1.4, 1.2)+ stat <- ifelse("count_fraction" %in% names(s_x), "count_fraction", "unique")
|
||
| 458 | -+ | |||
| 142 | +38x |
- #' lower <- c(0.8, 0.8, 0.8)+ if ("flag_variables" %in% names(s_args)) {
|
||
| 459 | -+ | |||
| 143 | +2x |
- #' upper <- c(1.1, 1.6, 1.6)+ var_nms <- s_args$flag_variables |
||
| 460 | -+ | |||
| 144 | +36x |
- #' # numeric vector with multiplication factor to scale each circle radius+ } else if (is.list(s_x[[stat]]) && !is.null(names(s_x[[stat]]))) {
|
||
| 461 | -+ | |||
| 145 | +24x |
- #' # default radius is 1/3.5 lines+ var_nms <- names(s_x[[stat]]) |
||
| 462 | +146 |
- #' symbol_scale <- c(1, 1.25, 1.5)+ } else {
|
||
| 463 | -+ | |||
| 147 | +12x |
- #'+ var_nms <- "" |
||
| 464 | -+ | |||
| 148 | +12x |
- #' # Internal function - forest_grob+ s_x[[stat]] <- list(s_x[[stat]]) |
||
| 465 | -+ | |||
| 149 | +12x |
- #' \donttest{
+ s_y[[stat]] <- list(s_y[[stat]]) |
||
| 466 | +150 |
- #' p <- forest_grob(tbl, x, lower, upper,+ } |
||
| 467 | +151 |
- #' vline = 1, forest_header = c("A", "B"),
+
|
||
| 468 | +152 |
- #' x_at = c(.1, 1, 10), xlim = c(0.1, 10), logx = TRUE, symbol_size = symbol_scale,+ # Calculate risk difference for each row, repeated if multiple statistics in table |
||
| 469 | -+ | |||
| 153 | +38x |
- #' vp = grid::plotViewport(margins = c(1, 1, 1, 1))+ pct <- tail(strsplit(cur_split, "_")[[1]], 1) == "pct" |
||
| 470 | -+ | |||
| 154 | +38x |
- #' )+ rd_ci <- rep(stat_propdiff_ci( |
||
| 471 | -+ | |||
| 155 | +38x |
- #'+ lapply(s_x[[stat]], `[`, 1), lapply(s_y[[stat]], `[`, 1), |
||
| 472 | -+ | |||
| 156 | +38x |
- #' draw_grob(p)+ N_col_x, N_col_y, |
||
| 473 | -+ | |||
| 157 | +38x |
- #' }+ list_names = var_nms, |
||
| 474 | -+ | |||
| 158 | +38x |
- #'+ pct = pct |
||
| 475 | -+ | |||
| 159 | +38x |
- #' @noRd+ ), max(1, length(.stats))) |
||
| 476 | +160 |
- #' @keywords internal+ |
||
| 477 | -+ | |||
| 161 | +38x |
- forest_grob <- function(tbl,+ in_rows(.list = rd_ci, .formats = "xx.x (xx.x - xx.x)", .indent_mods = .indent_mods) |
||
| 478 | +162 |
- x,+ } |
||
| 479 | +163 |
- lower,+ } |
||
| 480 | +164 |
- upper,+ |
||
| 481 | +165 |
- vline,+ #' Control function for risk difference column |
||
| 482 | +166 |
- forest_header,+ #' |
||
| 483 | +167 |
- xlim = NULL,+ #' @description `r lifecycle::badge("stable")`
|
||
| 484 | +168 |
- logx = FALSE,+ #' |
||
| 485 | +169 |
- x_at = NULL,+ #' Sets a list of parameters to use when generating a risk (proportion) difference column. Used as input to the |
||
| 486 | +170 |
- width_row_names = NULL,+ #' `riskdiff` parameter of [tabulate_rsp_subgroups()] and [tabulate_survival_subgroups()]. |
||
| 487 | +171 |
- width_columns = NULL,+ #' |
||
| 488 | +172 |
- width_forest = grid::unit(1, "null"),+ #' @inheritParams add_riskdiff |
||
| 489 | +173 |
- symbol_size = NULL,+ #' @param format (`string` or `function`)\cr the format label (string) or formatting function to apply to the risk |
||
| 490 | +174 |
- col = "blue",+ #' difference statistic. See the `3d` string options in [formatters::list_valid_format_labels()] for possible format |
||
| 491 | +175 |
- name = NULL,+ #' strings. Defaults to `"xx.x (xx.x - xx.x)"`. |
||
| 492 | +176 |
- gp = NULL,+ #' |
||
| 493 | +177 |
- vp = NULL) {
+ #' @return A `list` of items with names corresponding to the arguments. |
||
| 494 | -1x | +|||
| 178 | +
- lifecycle::deprecate_warn(+ #' |
|||
| 495 | -1x | +|||
| 179 | +
- "0.9.4", "forest_grob()",+ #' @seealso [add_riskdiff()], [tabulate_rsp_subgroups()], and [tabulate_survival_subgroups()]. |
|||
| 496 | -1x | +|||
| 180 | +
- details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`."+ #' |
|||
| 497 | +181 |
- )+ #' @examples |
||
| 498 | +182 |
-
+ #' control_riskdiff() |
||
| 499 | -1x | +|||
| 183 | +
- nr <- nrow(tbl)+ #' control_riskdiff(arm_x = "ARM A", arm_y = "ARM B") |
|||
| 500 | -1x | +|||
| 184 | +
- if (is.null(vline)) {
+ #' |
|||
| 501 | -! | +|||
| 185 | +
- checkmate::assert_true(is.null(forest_header))+ #' @export |
|||
| 502 | +186 |
- } else {
+ control_riskdiff <- function(arm_x = NULL, |
||
| 503 | -1x | +|||
| 187 | +
- checkmate::assert_number(vline)+ arm_y = NULL, |
|||
| 504 | -1x | +|||
| 188 | +
- checkmate::assert_character(forest_header, len = 2, null.ok = TRUE)+ format = "xx.x (xx.x - xx.x)", |
|||
| 505 | +189 |
- }+ col_label = "Risk Difference (%) (95% CI)", |
||
| 506 | +190 |
-
+ pct = TRUE) {
|
||
| 507 | -1x | +191 | +2x |
- checkmate::assert_numeric(x, len = nr)+ checkmate::assert_character(arm_x, len = 1, null.ok = TRUE) |
| 508 | -1x | +192 | +2x |
- checkmate::assert_numeric(lower, len = nr)+ checkmate::assert_character(arm_y, min.len = 1, null.ok = TRUE) |
| 509 | -1x | +193 | +2x |
- checkmate::assert_numeric(upper, len = nr)+ checkmate::assert_character(format, len = 1) |
| 510 | -1x | +194 | +2x |
- checkmate::assert_numeric(symbol_size, len = nr, null.ok = TRUE)+ checkmate::assert_character(col_label) |
| 511 | -1x | +195 | +2x |
- checkmate::assert_character(col)+ checkmate::assert_flag(pct) |
| 512 | +196 | |||
| 513 | -1x | -
- if (is.null(symbol_size)) {
- |
- ||
| 514 | -! | +197 | +2x |
- symbol_size <- rep(1, nr)+ list(arm_x = arm_x, arm_y = arm_y, format = format, col_label = col_label, pct = pct) |
| 515 | +198 |
- }+ } |
| 516 | +1 | - - | -||
| 517 | -1x | -
- if (is.null(xlim)) {
- |
- ||
| 518 | -! | -
- r <- range(c(x, lower, upper), na.rm = TRUE)+ #' Tabulate biomarker effects on binary response by subgroup |
||
| 519 | -! | +|||
| 2 | +
- xlim <- r + c(-0.05, 0.05) * diff(r)+ #' |
|||
| 520 | +3 |
- }+ #' @description `r lifecycle::badge("stable")`
|
||
| 521 | +4 |
-
+ #' |
||
| 522 | -1x | +|||
| 5 | +
- if (logx) {
+ #' The [tabulate_rsp_biomarkers()] function creates a layout element to tabulate the estimated biomarker effects on a |
|||
| 523 | -1x | +|||
| 6 | +
- if (is.null(x_at)) {
+ #' binary response endpoint across subgroups, returning statistics including response rate and odds ratio for each |
|||
| 524 | -! | +|||
| 7 | +
- x_at <- pretty(log(stats::na.omit(c(x, lower, upper))))+ #' population subgroup. The table is created from `df`, a list of data frames returned by [extract_rsp_biomarkers()], |
|||
| 525 | -! | +|||
| 8 | +
- x_labels <- exp(x_at)+ #' with the statistics to include specified via the `vars` parameter. |
|||
| 526 | +9 |
- } else {
+ #' |
||
| 527 | -1x | +|||
| 10 | +
- x_labels <- x_at+ #' A forest plot can be created from the resulting table using the [g_forest()] function. |
|||
| 528 | -1x | +|||
| 11 | +
- x_at <- log(x_at)+ #' |
|||
| 529 | +12 |
- }+ #' @inheritParams argument_convention |
||
| 530 | -1x | +|||
| 13 | +
- xlim <- log(xlim)+ #' @param df (`data.frame`)\cr containing all analysis variables, as returned by |
|||
| 531 | -1x | +|||
| 14 | +
- x <- log(x)+ #' [extract_rsp_biomarkers()]. |
|||
| 532 | -1x | +|||
| 15 | +
- lower <- log(lower)+ #' @param vars (`character`)\cr the names of statistics to be reported among: |
|||
| 533 | -1x | +|||
| 16 | +
- upper <- log(upper)+ #' * `n_tot`: Total number of patients per group. |
|||
| 534 | -1x | +|||
| 17 | +
- if (!is.null(vline)) {
+ #' * `n_rsp`: Total number of responses per group. |
|||
| 535 | -1x | +|||
| 18 | +
- vline <- log(vline)+ #' * `prop`: Total response proportion per group. |
|||
| 536 | +19 |
- }+ #' * `or`: Odds ratio. |
||
| 537 | +20 |
- } else {
+ #' * `ci`: Confidence interval of odds ratio. |
||
| 538 | -! | +|||
| 21 | +
- x_labels <- TRUE+ #' * `pval`: p-value of the effect. |
|||
| 539 | +22 |
- }+ #' Note, the statistics `n_tot`, `or` and `ci` are required. |
||
| 540 | +23 |
-
+ #' |
||
| 541 | -1x | +|||
| 24 | +
- data_forest_vp <- grid::dataViewport(xlim, c(0, 1))+ #' @return An `rtables` table summarizing biomarker effects on binary response by subgroup. |
|||
| 542 | +25 |
-
+ #' |
||
| 543 | +26 |
- # Get table content as matrix form.+ #' @details These functions create a layout starting from a data frame which contains |
||
| 544 | -1x | +|||
| 27 | +
- mf <- matrix_form(tbl)+ #' the required statistics. The tables are then typically used as input for forest plots. |
|||
| 545 | +28 |
-
+ #' |
||
| 546 | +29 |
- # Use `rtables` indent_string eventually.+ #' @note In contrast to [tabulate_rsp_subgroups()] this tabulation function does |
||
| 547 | -1x | +|||
| 30 | +
- mf$strings[, 1] <- paste0(+ #' not start from an input layout `lyt`. This is because internally the table is |
|||
| 548 | -1x | +|||
| 31 | +
- strrep(" ", c(rep(0, attr(mf, "nrow_header")), mf$row_info$indent)),
+ #' created by combining multiple subtables. |
|||
| 549 | -1x | +|||
| 32 | +
- mf$strings[, 1]+ #' |
|||
| 550 | +33 |
- )+ #' @seealso [h_tab_rsp_one_biomarker()] which is used internally, [extract_rsp_biomarkers()]. |
||
| 551 | +34 |
-
+ #' |
||
| 552 | -1x | +|||
| 35 | +
- n_header <- attr(mf, "nrow_header")+ #' @examples |
|||
| 553 | +36 |
-
+ #' library(dplyr) |
||
| 554 | -! | +|||
| 37 | +
- if (any(mf$display[, 1] == FALSE)) stop("row names need to be always displayed")
+ #' library(forcats) |
|||
| 555 | +38 |
-
+ #' |
||
| 556 | +39 |
- # Pre-process the data to be used in lapply and cell_in_rows.+ #' adrs <- tern_ex_adrs |
||
| 557 | -1x | +|||
| 40 | +
- to_args_for_cell_in_rows_fun <- function(part = c("body", "header"),
+ #' adrs_labels <- formatters::var_labels(adrs) |
|||
| 558 | -1x | +|||
| 41 | +
- underline_colspan = FALSE) {
+ #' |
|||
| 559 | -2x | +|||
| 42 | +
- part <- match.arg(part)+ #' adrs_f <- adrs %>% |
|||
| 560 | -2x | +|||
| 43 | +
- if (part == "body") {
+ #' filter(PARAMCD == "BESRSPI") %>% |
|||
| 561 | -1x | +|||
| 44 | +
- mat_row_indices <- seq_len(nrow(tbl)) + n_header+ #' mutate(rsp = AVALC == "CR") |
|||
| 562 | -1x | +|||
| 45 | +
- row_ind_offset <- -n_header+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
|||
| 563 | +46 |
- } else {
+ #' |
||
| 564 | -1x | +|||
| 47 | +
- mat_row_indices <- seq_len(n_header)+ #' df <- extract_rsp_biomarkers( |
|||
| 565 | -1x | +|||
| 48 | +
- row_ind_offset <- 0+ #' variables = list( |
|||
| 566 | +49 |
- }+ #' rsp = "rsp", |
||
| 567 | +50 |
-
+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 568 | -2x | +|||
| 51 | +
- lapply(mat_row_indices, function(i) {
+ #' covariates = "SEX", |
|||
| 569 | -5x | +|||
| 52 | +
- disp <- mf$display[i, -1]+ #' subgroups = "BMRKR2" |
|||
| 570 | -5x | +|||
| 53 | +
- list(+ #' ), |
|||
| 571 | -5x | +|||
| 54 | +
- row_name = mf$strings[i, 1],+ #' data = adrs_f |
|||
| 572 | -5x | +|||
| 55 | +
- cells = mf$strings[i, -1][disp],+ #' ) |
|||
| 573 | -5x | +|||
| 56 | +
- cell_spans = mf$spans[i, -1][disp],+ #' |
|||
| 574 | -5x | +|||
| 57 | +
- row_index = i + row_ind_offset,+ #' \donttest{
|
|||
| 575 | -5x | +|||
| 58 | +
- underline_colspan = underline_colspan+ #' ## Table with default columns. |
|||
| 576 | +59 |
- )+ #' tabulate_rsp_biomarkers(df) |
||
| 577 | +60 |
- })+ #' |
||
| 578 | +61 |
- }+ #' ## Table with a manually chosen set of columns: leave out "pval", reorder. |
||
| 579 | +62 |
-
+ #' tab <- tabulate_rsp_biomarkers( |
||
| 580 | -1x | +|||
| 63 | +
- args_header <- to_args_for_cell_in_rows_fun("header", underline_colspan = TRUE)
+ #' df = df, |
|||
| 581 | -1x | +|||
| 64 | +
- args_body <- to_args_for_cell_in_rows_fun("body", underline_colspan = FALSE)
+ #' vars = c("n_rsp", "ci", "n_tot", "prop", "or")
|
|||
| 582 | +65 |
-
+ #' ) |
||
| 583 | -1x | +|||
| 66 | +
- grid::gTree(+ #' |
|||
| 584 | -1x | +|||
| 67 | +
- name = name,+ #' ## Finally produce the forest plot. |
|||
| 585 | -1x | +|||
| 68 | +
- children = grid::gList(+ #' g_forest(tab, xlim = c(0.7, 1.4)) |
|||
| 586 | -1x | +|||
| 69 | +
- grid::gTree(+ #' } |
|||
| 587 | -1x | +|||
| 70 | +
- children = do.call(grid::gList, lapply(args_header, do.call, what = cell_in_rows)),+ #' |
|||
| 588 | -1x | +|||
| 71 | +
- vp = grid::vpPath("vp_table_layout", "vp_header")
+ #' @export |
|||
| 589 | +72 |
- ),+ #' @name response_biomarkers_subgroups |
||
| 590 | -1x | +|||
| 73 | +
- grid::gTree(+ tabulate_rsp_biomarkers <- function(df, |
|||
| 591 | -1x | +|||
| 74 | +
- children = do.call(grid::gList, lapply(args_body, do.call, what = cell_in_rows)),+ vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
|
|||
| 592 | -1x | +|||
| 75 | +
- vp = grid::vpPath("vp_table_layout", "vp_body")
+ na_str = default_na_str(), |
|||
| 593 | +76 |
- ),+ .indent_mods = 0L) {
|
||
| 594 | -1x | +77 | +4x |
- grid::linesGrob(+ checkmate::assert_data_frame(df) |
| 595 | -1x | +78 | +4x |
- grid::unit(c(0, 1), "npc"),+ checkmate::assert_character(df$biomarker) |
| 596 | -1x | +79 | +4x |
- y = grid::unit(c(.5, .5), "npc"),+ checkmate::assert_character(df$biomarker_label) |
| 597 | -1x | +80 | +4x |
- vp = grid::vpPath("vp_table_layout", "vp_spacer")
+ checkmate::assert_subset(vars, get_stats("tabulate_rsp_biomarkers"))
|
| 598 | +81 |
- ),+ |
||
| 599 | +82 |
- # forest part+ # Create "ci" column from "lcl" and "ucl" |
||
| 600 | -1x | -
- if (is.null(vline)) {
- |
- ||
| 601 | -! | +83 | +4x |
- NULL+ df$ci <- combine_vectors(df$lcl, df$ucl) |
| 602 | +84 |
- } else {
+
|
||
| 603 | -1x | +85 | +4x |
- grid::gTree(+ df_subs <- split(df, f = df$biomarker) |
| 604 | -1x | +86 | +4x |
- children = grid::gList(+ tabs <- lapply(df_subs, FUN = function(df_sub) {
|
| 605 | -1x | +87 | +7x |
- grid::gTree(+ tab_sub <- h_tab_rsp_one_biomarker( |
| 606 | -1x | -
- children = grid::gList(- |
- ||
| 607 | -- |
- # this may overflow, to fix, look here- |
- ||
| 608 | -+ | 88 | +7x |
- # https://stackoverflow.com/questions/33623169/add-multi-line-footnote-to-tablegrob-while-using-gridextra-in-r # nolint+ df = df_sub, |
| 609 | -1x | +89 | +7x |
- grid::textGrob(+ vars = vars, |
| 610 | -1x | +90 | +7x |
- forest_header[1],+ na_str = na_str, |
| 611 | -1x | +91 | +7x |
- x = grid::unit(vline, "native") - grid::unit(1, "lines"),+ .indent_mods = .indent_mods |
| 612 | -1x | +|||
| 92 | +
- just = c("right", "center")
+ ) |
|||
| 613 | +93 |
- ),+ # Insert label row as first row in table. |
||
| 614 | -1x | +94 | +7x |
- grid::textGrob(+ label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1] |
| 615 | -1x | +95 | +7x |
- forest_header[2],+ tab_sub |
| 616 | -1x | +|||
| 96 | +
- x = grid::unit(vline, "native") + grid::unit(1, "lines"),+ }) |
|||
| 617 | -1x | +97 | +4x |
- just = c("left", "center")
+ result <- do.call(rbind, tabs) |
| 618 | +98 |
- )+ |
||
| 619 | -+ | |||
| 99 | +4x |
- ),+ n_id <- grep("n_tot", vars)
|
||
| 620 | -1x | +100 | +4x |
- vp = grid::vpStack(grid::viewport(layout.pos.col = ncol(tbl) + 2), data_forest_vp)+ or_id <- match("or", vars)
|
| 621 | -+ | |||
| 101 | +4x |
- )+ ci_id <- match("ci", vars)
|
||
| 622 | -+ | |||
| 102 | +4x |
- ),+ structure( |
||
| 623 | -1x | +103 | +4x |
- vp = grid::vpPath("vp_table_layout", "vp_header")
+ result, |
| 624 | -+ | |||
| 104 | +4x |
- )+ forest_header = paste0(c("Lower", "Higher"), "\nBetter"),
|
||
| 625 | -+ | |||
| 105 | +4x |
- },+ col_x = or_id, |
||
| 626 | -1x | +106 | +4x |
- grid::gTree(+ col_ci = ci_id, |
| 627 | -1x | +107 | +4x |
- children = grid::gList(+ col_symbol_size = n_id |
| 628 | -1x | +|||
| 108 | +
- grid::gTree(+ ) |
|||
| 629 | -1x | +|||
| 109 | +
- children = grid::gList(+ } |
|||
| 630 | -1x | +|||
| 110 | +
- grid::rectGrob(gp = grid::gpar(col = "gray90", fill = "gray90")),+ |
|||
| 631 | -1x | +|||
| 111 | +
- if (is.null(vline)) {
+ #' Prepare response data estimates for multiple biomarkers in a single data frame |
|||
| 632 | -! | +|||
| 112 | +
- NULL+ #' |
|||
| 633 | +113 |
- } else {
+ #' @description `r lifecycle::badge("stable")`
|
||
| 634 | -1x | +|||
| 114 | +
- grid::linesGrob(+ #' |
|||
| 635 | -1x | +|||
| 115 | +
- x = grid::unit(rep(vline, 2), "native"),+ #' Prepares estimates for number of responses, patients and overall response rate, |
|||
| 636 | -1x | +|||
| 116 | +
- y = grid::unit(c(0, 1), "npc"),+ #' as well as odds ratio estimates, confidence intervals and p-values, |
|||
| 637 | -1x | +|||
| 117 | +
- gp = grid::gpar(lwd = 2),+ #' for multiple biomarkers across population subgroups in a single data frame. |
|||
| 638 | -1x | +|||
| 118 | +
- vp = data_forest_vp+ #' `variables` corresponds to the names of variables found in `data`, passed as a |
|||
| 639 | +119 |
- )+ #' named list and requires elements `rsp` and `biomarkers` (vector of continuous |
||
| 640 | +120 |
- },+ #' biomarker variables) and optionally `covariates`, `subgroups` and `strata`. |
||
| 641 | -1x | +|||
| 121 | +
- grid::xaxisGrob(at = x_at, label = x_labels, vp = data_forest_vp)+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
|||
| 642 | +122 |
- ),+ #' |
||
| 643 | -1x | +|||
| 123 | +
- vp = grid::viewport(layout.pos.col = ncol(tbl) + 2)+ #' @inheritParams argument_convention |
|||
| 644 | +124 |
- )+ #' @inheritParams response_subgroups |
||
| 645 | +125 |
- ),+ #' @param control (named `list`)\cr controls for the response definition and the |
||
| 646 | -1x | +|||
| 126 | +
- vp = grid::vpPath("vp_table_layout", "vp_body")
+ #' confidence level produced by [control_logistic()]. |
|||
| 647 | +127 |
- ),+ #' |
||
| 648 | -1x | +|||
| 128 | +
- grid::gTree(+ #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_rsp`, |
|||
| 649 | -1x | +|||
| 129 | +
- children = do.call(+ #' `prop`, `or`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`, |
|||
| 650 | -1x | +|||
| 130 | +
- grid::gList,+ #' `var_label`, and `row_type`. |
|||
| 651 | -1x | +|||
| 131 | +
- Map(+ #' |
|||
| 652 | -1x | +|||
| 132 | +
- function(xi, li, ui, row_index, size_i, col) {
+ #' @note You can also specify a continuous variable in `rsp` and then use the |
|||
| 653 | -3x | +|||
| 133 | +
- forest_dot_line(+ #' `response_definition` control to convert that internally to a logical |
|||
| 654 | -3x | +|||
| 134 | +
- xi,+ #' variable reflecting binary response. |
|||
| 655 | -3x | +|||
| 135 | +
- li,+ #' |
|||
| 656 | -3x | +|||
| 136 | +
- ui,+ #' @seealso [h_logistic_mult_cont_df()] which is used internally. |
|||
| 657 | -3x | +|||
| 137 | +
- row_index,+ #' |
|||
| 658 | -3x | +|||
| 138 | +
- xlim,+ #' @examples |
|||
| 659 | -3x | +|||
| 139 | +
- symbol_size = size_i,+ #' library(dplyr) |
|||
| 660 | -3x | +|||
| 140 | +
- col = col,+ #' library(forcats) |
|||
| 661 | -3x | +|||
| 141 | +
- datavp = data_forest_vp+ #' |
|||
| 662 | +142 |
- )+ #' adrs <- tern_ex_adrs |
||
| 663 | +143 |
- },+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 664 | -1x | +|||
| 144 | +
- x,+ #' |
|||
| 665 | -1x | +|||
| 145 | +
- lower,+ #' adrs_f <- adrs %>% |
|||
| 666 | -1x | +|||
| 146 | +
- upper,+ #' filter(PARAMCD == "BESRSPI") %>% |
|||
| 667 | -1x | +|||
| 147 | +
- seq_along(x),+ #' mutate(rsp = AVALC == "CR") |
|||
| 668 | -1x | +|||
| 148 | +
- symbol_size,+ #' |
|||
| 669 | -1x | +|||
| 149 | +
- col,+ #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`, |
|||
| 670 | -1x | +|||
| 150 | +
- USE.NAMES = FALSE+ #' # in logistic regression models with one covariate `RACE`. The subgroups |
|||
| 671 | +151 |
- )+ #' # are defined by the levels of `BMRKR2`. |
||
| 672 | +152 |
- ),+ #' df <- extract_rsp_biomarkers( |
||
| 673 | -1x | +|||
| 153 | +
- vp = grid::vpPath("vp_table_layout", "vp_body")
+ #' variables = list( |
|||
| 674 | +154 |
- )+ #' rsp = "rsp", |
||
| 675 | +155 |
- ),+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 676 | -1x | +|||
| 156 | +
- childrenvp = forest_viewport(tbl, width_row_names, width_columns, width_forest),+ #' covariates = "SEX", |
|||
| 677 | -1x | +|||
| 157 | +
- vp = vp,+ #' subgroups = "BMRKR2" |
|||
| 678 | -1x | +|||
| 158 | +
- gp = gp+ #' ), |
|||
| 679 | +159 |
- )+ #' data = adrs_f |
||
| 680 | +160 |
- }+ #' ) |
||
| 681 | +161 |
-
+ #' df |
||
| 682 | +162 |
- cell_in_rows <- function(row_name,+ #' |
||
| 683 | +163 |
- cells,+ #' # Here we group the levels of `BMRKR2` manually, and we add a stratification |
||
| 684 | +164 |
- cell_spans,+ #' # variable `STRATA1`. We also here use a continuous variable `EOSDY` |
||
| 685 | +165 |
- row_index,+ #' # which is then binarized internally (response is defined as this variable |
||
| 686 | +166 |
- underline_colspan = FALSE) {
+ #' # being larger than 750). |
||
| 687 | -5x | +|||
| 167 | +
- checkmate::assert_string(row_name)+ #' df_grouped <- extract_rsp_biomarkers( |
|||
| 688 | -5x | +|||
| 168 | +
- checkmate::assert_character(cells, min.len = 1, any.missing = FALSE)+ #' variables = list( |
|||
| 689 | -5x | +|||
| 169 | +
- checkmate::assert_numeric(cell_spans, len = length(cells), any.missing = FALSE)+ #' rsp = "EOSDY", |
|||
| 690 | -5x | +|||
| 170 | +
- checkmate::assert_number(row_index)+ #' biomarkers = c("BMRKR1", "AGE"),
|
|||
| 691 | -5x | +|||
| 171 | +
- checkmate::assert_flag(underline_colspan)+ #' covariates = "SEX", |
|||
| 692 | +172 |
-
+ #' subgroups = "BMRKR2", |
||
| 693 | -5x | +|||
| 173 | +
- vp_name_rn <- paste0("rowname-", row_index)
+ #' strata = "STRATA1" |
|||
| 694 | -5x | +|||
| 174 | +
- g_rowname <- if (!is.null(row_name) && row_name != "") {
+ #' ), |
|||
| 695 | -3x | +|||
| 175 | +
- grid::textGrob(+ #' data = adrs_f, |
|||
| 696 | -3x | +|||
| 176 | +
- name = vp_name_rn,+ #' groups_lists = list( |
|||
| 697 | -3x | +|||
| 177 | +
- label = row_name,+ #' BMRKR2 = list( |
|||
| 698 | -3x | +|||
| 178 | +
- x = grid::unit(0, "npc"),+ #' "low" = "LOW", |
|||
| 699 | -3x | +|||
| 179 | +
- just = c("left", "center"),
+ #' "low/medium" = c("LOW", "MEDIUM"),
|
|||
| 700 | -3x | +|||
| 180 | +
- vp = grid::vpPath(paste0("rowname-", row_index))
+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
|||
| 701 | +181 |
- )+ #' ) |
||
| 702 | +182 |
- } else {
+ #' ), |
||
| 703 | -2x | +|||
| 183 | +
- NULL+ #' control = control_logistic( |
|||
| 704 | +184 |
- }+ #' response_definition = "I(response > 750)" |
||
| 705 | +185 |
-
+ #' ) |
||
| 706 | -5x | +|||
| 186 | +
- gl_cols <- if (!(length(cells) > 0)) {
+ #' ) |
|||
| 707 | -! | +|||
| 187 | +
- list(NULL)+ #' df_grouped |
|||
| 708 | +188 |
- } else {
+ #' |
||
| 709 | -5x | +|||
| 189 | +
- j <- 1 # column index of cell+ #' @export |
|||
| 710 | +190 |
-
+ extract_rsp_biomarkers <- function(variables, |
||
| 711 | -5x | +|||
| 191 | +
- lapply(seq_along(cells), function(k) {
+ data, |
|||
| 712 | -19x | +|||
| 192 | +
- cell_ascii <- cells[[k]]+ groups_lists = list(), |
|||
| 713 | -19x | +|||
| 193 | +
- cs <- cell_spans[[k]]+ control = control_logistic(), |
|||
| 714 | +194 |
-
+ label_all = "All Patients") {
|
||
| 715 | -19x | +195 | +5x |
- if (is.na(cell_ascii) || is.null(cell_ascii)) {
+ if ("strat" %in% names(variables)) {
|
| 716 | +196 | ! |
- cell_ascii <- "NA"+ warning( |
|
| 717 | -+ | |||
| 197 | +! |
- }+ "Warning: the `strat` element name of the `variables` list argument to `extract_rsp_biomarkers() ", |
||
| 718 | -+ | |||
| 198 | +! |
-
+ "was deprecated in tern 0.9.4.\n ", |
||
| 719 | -19x | +|||
| 199 | +! |
- cell_name <- paste0("g-cell-", row_index, "-", j)
+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 720 | +200 | - - | -||
| 721 | -19x | -
- cell_grobs <- if (identical(cell_ascii, "")) {
+ ) |
||
| 722 | +201 | ! |
- NULL+ variables[["strata"]] <- variables[["strat"]] |
|
| 723 | +202 |
- } else {
+ } |
||
| 724 | -19x | +|||
| 203 | +
- if (cs == 1) {
+
|
|||
| 725 | -18x | +204 | +5x |
- grid::textGrob(+ assert_list_of_variables(variables) |
| 726 | -18x | +205 | +5x |
- label = cell_ascii,+ checkmate::assert_string(variables$rsp) |
| 727 | -18x | +206 | +5x |
- name = cell_name,+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 728 | -18x | +207 | +5x |
- vp = grid::vpPath(paste0("cell-", row_index, "-", j))
+ checkmate::assert_string(label_all) |
| 729 | +208 |
- )+ |
||
| 730 | +209 |
- } else {
+ # Start with all patients.+ |
+ ||
| 210 | +5x | +
+ result_all <- h_logistic_mult_cont_df(+ |
+ ||
| 211 | +5x | +
+ variables = variables, |
||
| 731 | -+ | |||
| 212 | +5x |
- # +1 because of rowname+ data = data, |
||
| 732 | -1x | +213 | +5x |
- vp_joined_cols <- grid::viewport(layout.pos.row = row_index, layout.pos.col = seq(j + 1, j + cs))+ control = control |
| 733 | +214 |
-
+ ) |
||
| 734 | -1x | +215 | +5x |
- lab <- grid::textGrob(+ result_all$subgroup <- label_all |
| 735 | -1x | +216 | +5x |
- label = cell_ascii,+ result_all$var <- "ALL" |
| 736 | -1x | +217 | +5x |
- name = cell_name,+ result_all$var_label <- label_all |
| 737 | -1x | +218 | +5x |
- vp = vp_joined_cols+ result_all$row_type <- "content" |
| 738 | -+ | |||
| 219 | +5x |
- )+ if (is.null(variables$subgroups)) {
|
||
| 739 | +220 |
-
+ # Only return result for all patients. |
||
| 740 | +221 | 1x |
- if (!underline_colspan || grepl("^[[:space:]]*$", cell_ascii)) {
+ result_all |
|
| 741 | -! | +|||
| 222 | +
- lab+ } else {
|
|||
| 742 | +223 |
- } else {
+ # Add subgroups results. |
||
| 743 | -1x | +224 | +4x |
- grid::gList(+ l_data <- h_split_by_subgroups( |
| 744 | -1x | +225 | +4x |
- lab,+ data, |
| 745 | -1x | +226 | +4x |
- grid::linesGrob(+ variables$subgroups, |
| 746 | -1x | +227 | +4x |
- x = grid::unit.c(grid::unit(.2, "lines"), grid::unit(1, "npc") - grid::unit(.2, "lines")),+ groups_lists = groups_lists |
| 747 | -1x | +|||
| 228 | +
- y = grid::unit(c(0, 0), "npc"),+ ) |
|||
| 748 | -1x | +229 | +4x |
- vp = vp_joined_cols+ l_result <- lapply(l_data, function(grp) {
|
| 749 | -+ | |||
| 230 | +20x |
- )+ result <- h_logistic_mult_cont_df( |
||
| 750 | -+ | |||
| 231 | +20x |
- )+ variables = variables, |
||
| 751 | -+ | |||
| 232 | +20x |
- }+ data = grp$df, |
||
| 752 | -+ | |||
| 233 | +20x |
- }+ control = control |
||
| 753 | +234 |
- }+ ) |
||
| 754 | -19x | -
- j <<- j + cs- |
- ||
| 755 | -+ | 235 | +20x |
-
+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
| 756 | -19x | +236 | +20x |
- cell_grobs+ cbind(result, result_labels) |
| 757 | +237 |
}) |
||
| 758 | -+ | |||
| 238 | +4x |
- }+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
||
| 759 | -+ | |||
| 239 | +4x |
-
+ result_subgroups$row_type <- "analysis" |
||
| 760 | -5x | +240 | +4x |
- grid::gList(+ rbind( |
| 761 | -5x | +241 | +4x |
- g_rowname,+ result_all, |
| 762 | -5x | +242 | +4x |
- do.call(grid::gList, gl_cols)+ result_subgroups |
| 763 | +243 |
- )+ ) |
||
| 764 | +244 |
- }+ } |
||
| 765 | +245 |
-
+ } |
| 766 | +1 |
- #' Graphic object: forest dot line+ #' Control function for Cox regression |
||
| 767 | +2 |
#' |
||
| 768 | +3 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' @description `r lifecycle::badge("stable")`
|
||
| 769 | +4 |
#' |
||
| 770 | +5 |
- #' Calculate the `grob` corresponding to the dot line within the forest plot.+ #' Sets a list of parameters for Cox regression fit. Used internally. |
||
| 771 | +6 |
#' |
||
| 772 | +7 |
- #' @noRd+ #' @inheritParams argument_convention |
||
| 773 | +8 |
- #' @keywords internal+ #' @param pval_method (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`. |
||
| 774 | +9 |
- forest_dot_line <- function(x,+ #' @param interaction (`flag`)\cr if `TRUE`, the model includes the interaction between the studied |
||
| 775 | +10 |
- lower,+ #' treatment and candidate covariate. Note that for univariate models without treatment arm, and |
||
| 776 | +11 |
- upper,+ #' multivariate models, no interaction can be used so that this needs to be `FALSE`. |
||
| 777 | +12 |
- row_index,+ #' @param ties (`string`)\cr among `exact` (equivalent to `DISCRETE` in SAS), `efron` and `breslow`, |
||
| 778 | +13 |
- xlim,+ #' see [survival::coxph()]. Note: there is no equivalent of SAS `EXACT` method in R. |
||
| 779 | +14 |
- symbol_size = 1,+ #' |
||
| 780 | +15 |
- col = "blue",+ #' @return A `list` of items with names corresponding to the arguments. |
||
| 781 | +16 |
- datavp) {
+ #' |
||
| 782 | -3x | +|||
| 17 | +
- lifecycle::deprecate_warn(+ #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()]. |
|||
| 783 | -3x | +|||
| 18 | +
- "0.9.4", "forest_dot_line()",+ #' |
|||
| 784 | -3x | +|||
| 19 | +
- details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`."+ #' @examples |
|||
| 785 | +20 |
- )+ #' control_coxreg() |
||
| 786 | +21 |
-
+ #' |
||
| 787 | -3x | +|||
| 22 | +
- ci <- c(lower, upper)+ #' @export |
|||
| 788 | -3x | +|||
| 23 | +
- if (any(!is.na(c(x, ci)))) {
+ control_coxreg <- function(pval_method = c("wald", "likelihood"),
|
|||
| 789 | +24 |
- # line+ ties = c("exact", "efron", "breslow"),
|
||
| 790 | -3x | +|||
| 25 | +
- y <- grid::unit(c(0.5, 0.5), "npc")+ conf_level = 0.95, |
|||
| 791 | +26 |
-
+ interaction = FALSE) {
|
||
| 792 | -3x | -
- g_line <- if (all(!is.na(ci)) && ci[2] > xlim[1] && ci[1] < xlim[2]) {
- |
- ||
| 793 | -+ | 27 | +55x |
- # -+ pval_method <- match.arg(pval_method) |
| 794 | -3x | +28 | +55x |
- if (ci[1] >= xlim[1] && ci[2] <= xlim[2]) {
+ ties <- match.arg(ties) |
| 795 | -3x | +29 | +55x |
- grid::linesGrob(x = grid::unit(c(ci[1], ci[2]), "native"), y = y)+ checkmate::assert_flag(interaction) |
| 796 | -! | +|||
| 30 | +55x |
- } else if (ci[1] < xlim[1] && ci[2] > xlim[2]) {
+ assert_proportion_value(conf_level) |
||
| 797 | -+ | |||
| 31 | +55x |
- # <->+ list( |
||
| 798 | -! | +|||
| 32 | +55x |
- grid::linesGrob(+ pval_method = pval_method, |
||
| 799 | -! | +|||
| 33 | +55x |
- x = grid::unit(xlim, "native"),+ ties = ties, |
||
| 800 | -! | +|||
| 34 | +55x |
- y = y,+ conf_level = conf_level, |
||
| 801 | -! | +|||
| 35 | +55x |
- arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "both")+ interaction = interaction |
||
| 802 | +36 |
- )- |
- ||
| 803 | -! | -
- } else if (ci[1] < xlim[1] && ci[2] <= xlim[2]) {
+ ) |
||
| 804 | +37 |
- # <-- |
- ||
| 805 | -! | -
- grid::linesGrob(+ } |
||
| 806 | -! | +|||
| 38 | +
- x = grid::unit(c(xlim[1], ci[2]), "native"),+ |
|||
| 807 | -! | +|||
| 39 | +
- y = y,+ #' Custom tidy methods for Cox regression |
|||
| 808 | -! | +|||
| 40 | +
- arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "first")+ #' |
|||
| 809 | +41 |
- )+ #' @description `r lifecycle::badge("stable")`
|
||
| 810 | -! | +|||
| 42 | +
- } else if (ci[1] >= xlim[1] && ci[2] > xlim[2]) {
+ #' |
|||
| 811 | +43 |
- # ->+ #' @inheritParams argument_convention |
||
| 812 | -! | +|||
| 44 | +
- grid::linesGrob(+ #' @param x (`list`)\cr result of the Cox regression model fitted by [fit_coxreg_univar()] (for univariate models) |
|||
| 813 | -! | +|||
| 45 | +
- x = grid::unit(c(ci[1], xlim[2]), "native"),+ #' or [fit_coxreg_multivar()] (for multivariate models). |
|||
| 814 | -! | +|||
| 46 | +
- y = y,+ #' |
|||
| 815 | -! | +|||
| 47 | +
- arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "last")+ #' @return [broom::tidy()] returns: |
|||
| 816 | +48 |
- )+ #' * For `summary.coxph` objects, a `data.frame` with columns: `Pr(>|z|)`, `exp(coef)`, `exp(-coef)`, `lower .95`, |
||
| 817 | +49 |
- }+ #' `upper .95`, `level`, and `n`. |
||
| 818 | +50 |
- } else {
+ #' * For `coxreg.univar` objects, a `data.frame` with columns: `effect`, `term`, `term_label`, `level`, `n`, `hr`, |
||
| 819 | -! | +|||
| 51 | +
- NULL+ #' `lcl`, `ucl`, `pval`, and `ci`. |
|||
| 820 | +52 |
- }+ #' * For `coxreg.multivar` objects, a `data.frame` with columns: `term`, `pval`, `term_label`, `hr`, `lcl`, `ucl`, |
||
| 821 | +53 |
-
+ #' `level`, and `ci`. |
||
| 822 | -3x | +|||
| 54 | +
- g_circle <- if (!is.na(x) && x >= xlim[1] && x <= xlim[2]) {
+ #' |
|||
| 823 | -3x | +|||
| 55 | +
- grid::circleGrob(+ #' @seealso [cox_regression] |
|||
| 824 | -3x | +|||
| 56 | +
- x = grid::unit(x, "native"),+ #' |
|||
| 825 | -3x | +|||
| 57 | +
- y = y,+ #' @name tidy_coxreg |
|||
| 826 | -3x | +|||
| 58 | +
- r = grid::unit(1 / 3.5 * symbol_size, "lines"),+ NULL |
|||
| 827 | -3x | +|||
| 59 | +
- name = "point"+ |
|||
| 828 | +60 |
- )+ #' @describeIn tidy_coxreg Custom tidy method for [survival::coxph()] summary results. |
||
| 829 | +61 |
- } else {
+ #' |
||
| 830 | -! | +|||
| 62 | +
- NULL+ #' Tidy the [survival::coxph()] results into a `data.frame` to extract model results. |
|||
| 831 | +63 |
- }+ #' |
||
| 832 | +64 |
-
+ #' @method tidy summary.coxph |
||
| 833 | -3x | +|||
| 65 | +
- grid::gTree(+ #' |
|||
| 834 | -3x | +|||
| 66 | +
- children = grid::gList(+ #' @examples |
|||
| 835 | -3x | +|||
| 67 | +
- grid::gTree(+ #' library(survival) |
|||
| 836 | -3x | +|||
| 68 | +
- children = grid::gList(+ #' library(broom) |
|||
| 837 | -3x | +|||
| 69 | +
- grid::gList(+ #' |
|||
| 838 | -3x | +|||
| 70 | +
- g_line,+ #' set.seed(1, kind = "Mersenne-Twister") |
|||
| 839 | -3x | +|||
| 71 | +
- g_circle+ #' |
|||
| 840 | +72 |
- )+ #' dta_bladder <- with( |
||
| 841 | +73 |
- ),+ #' data = bladder[bladder$enum < 5, ], |
||
| 842 | -3x | +|||
| 74 | +
- vp = datavp,+ #' data.frame( |
|||
| 843 | -3x | +|||
| 75 | +
- gp = grid::gpar(col = col, fill = col)+ #' time = stop, |
|||
| 844 | +76 |
- )+ #' status = event, |
||
| 845 | +77 |
- ),+ #' armcd = as.factor(rx), |
||
| 846 | -3x | +|||
| 78 | +
- vp = grid::vpPath(paste0("forest-", row_index))
+ #' covar1 = as.factor(enum), |
|||
| 847 | +79 |
- )+ #' covar2 = factor( |
||
| 848 | +80 |
- } else {
+ #' sample(as.factor(enum)), |
||
| 849 | -! | +|||
| 81 | +
- NULL+ #' levels = 1:4, labels = c("F", "F", "M", "M")
|
|||
| 850 | +82 |
- }+ #' ) |
||
| 851 | +83 |
- }+ #' ) |
||
| 852 | +84 |
-
+ #' ) |
||
| 853 | +85 |
- #' Create a viewport tree for the forest plot+ #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
|
||
| 854 | +86 |
- #'+ #' formatters::var_labels(dta_bladder)[names(labels)] <- labels |
||
| 855 | +87 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
||
| 856 | +88 |
#' |
||
| 857 | +89 |
- #' @param tbl (`VTableTree`)\cr `rtables` table object.+ #' formula <- "survival::Surv(time, status) ~ armcd + covar1" |
||
| 858 | +90 |
- #' @param width_row_names (`grid::unit`)\cr width of row names.+ #' msum <- summary(coxph(stats::as.formula(formula), data = dta_bladder)) |
||
| 859 | +91 |
- #' @param width_columns (`grid::unit`)\cr width of column spans.+ #' tidy(msum) |
||
| 860 | +92 |
- #' @param width_forest (`grid::unit`)\cr width of the forest plot.+ #' |
||
| 861 | +93 |
- #' @param gap_column (`grid::unit`)\cr gap width between the columns.+ #' @export |
||
| 862 | +94 |
- #' @param gap_header (`grid::unit`)\cr gap width between the header.+ tidy.summary.coxph <- function(x, # nolint |
||
| 863 | +95 |
- #' @param mat_form (`MatrixPrintForm`)\cr matrix print form of the table.+ ...) {
|
||
| 864 | -+ | |||
| 96 | +199x |
- #'+ checkmate::assert_class(x, "summary.coxph") |
||
| 865 | -+ | |||
| 97 | +199x |
- #' @return A viewport tree.+ pval <- x$coefficients |
||
| 866 | -+ | |||
| 98 | +199x |
- #'+ confint <- x$conf.int |
||
| 867 | -+ | |||
| 99 | +199x |
- #' @examples+ levels <- rownames(pval) |
||
| 868 | +100 |
- #' library(grid)+ |
||
| 869 | -+ | |||
| 101 | +199x |
- #'+ pval <- tibble::as_tibble(pval) |
||
| 870 | -+ | |||
| 102 | +199x |
- #' tbl <- rtable(+ confint <- tibble::as_tibble(confint) |
||
| 871 | +103 |
- #' header = rheader(+ |
||
| 872 | -+ | |||
| 104 | +199x |
- #' rrow("", "E", rcell("CI", colspan = 2)),
+ ret <- cbind(pval[, grepl("Pr", names(pval))], confint)
|
||
| 873 | -+ | |||
| 105 | +199x |
- #' rrow("", "A", "B", "C")
+ ret$level <- levels |
||
| 874 | -+ | |||
| 106 | +199x |
- #' ),+ ret$n <- x[["n"]] |
||
| 875 | -+ | |||
| 107 | +199x |
- #' rrow("row 1", 1, 0.8, 1.1),
+ ret |
||
| 876 | +108 |
- #' rrow("row 2", 1.4, 0.8, 1.6),
+ } |
||
| 877 | +109 |
- #' rrow("row 3", 1.2, 0.8, 1.2)
+
|
||
| 878 | +110 |
- #' )+ #' @describeIn tidy_coxreg Custom tidy method for a univariate Cox regression. |
||
| 879 | +111 |
#' |
||
| 880 | +112 |
- #' \donttest{
+ #' Tidy up the result of a Cox regression model fitted by [fit_coxreg_univar()]. |
||
| 881 | +113 |
- #' v <- forest_viewport(tbl)+ #' |
||
| 882 | +114 |
- #'+ #' @method tidy coxreg.univar |
||
| 883 | +115 |
- #' grid::grid.newpage()+ #' |
||
| 884 | +116 |
- #' showViewport(v)+ #' @examples |
||
| 885 | +117 |
- #' }+ #' ## Cox regression: arm + 1 covariate. |
||
| 886 | +118 |
- #'+ #' mod1 <- fit_coxreg_univar( |
||
| 887 | +119 |
- #' @export+ #' variables = list( |
||
| 888 | +120 |
- forest_viewport <- function(tbl,+ #' time = "time", event = "status", arm = "armcd", |
||
| 889 | +121 |
- width_row_names = NULL,+ #' covariates = "covar1" |
||
| 890 | +122 |
- width_columns = NULL,+ #' ), |
||
| 891 | +123 |
- width_forest = grid::unit(1, "null"),+ #' data = dta_bladder, |
||
| 892 | +124 |
- gap_column = grid::unit(1, "lines"),+ #' control = control_coxreg(conf_level = 0.91) |
||
| 893 | +125 |
- gap_header = grid::unit(1, "lines"),+ #' ) |
||
| 894 | +126 |
- mat_form = NULL) {
- |
- ||
| 895 | -2x | -
- lifecycle::deprecate_warn(- |
- ||
| 896 | -2x | -
- "0.9.4",+ #' |
||
| 897 | -2x | +|||
| 127 | +
- "forest_viewport()",+ #' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates. |
|||
| 898 | -2x | +|||
| 128 | +
- details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`."+ #' mod2 <- fit_coxreg_univar( |
|||
| 899 | +129 |
- )+ #' variables = list( |
||
| 900 | +130 |
-
+ #' time = "time", event = "status", arm = "armcd", |
||
| 901 | -2x | +|||
| 131 | +
- checkmate::assert_class(tbl, "VTableTree")+ #' covariates = c("covar1", "covar2")
|
|||
| 902 | -2x | +|||
| 132 | +
- checkmate::assert_true(grid::is.unit(width_forest))+ #' ), |
|||
| 903 | -2x | +|||
| 133 | +
- if (!is.null(width_row_names)) {
+ #' data = dta_bladder, |
|||
| 904 | -! | +|||
| 134 | +
- checkmate::assert_true(grid::is.unit(width_row_names))+ #' control = control_coxreg(conf_level = 0.91, interaction = TRUE) |
|||
| 905 | +135 |
- }+ #' ) |
||
| 906 | -2x | +|||
| 136 | +
- if (!is.null(width_columns)) {
+ #' |
|||
| 907 | -! | +|||
| 137 | +
- checkmate::assert_true(grid::is.unit(width_columns))+ #' tidy(mod1) |
|||
| 908 | +138 |
- }+ #' tidy(mod2) |
||
| 909 | +139 |
-
+ #' |
||
| 910 | -2x | +|||
| 140 | +
- if (is.null(mat_form)) mat_form <- matrix_form(tbl)+ #' @export |
|||
| 911 | +141 |
-
+ tidy.coxreg.univar <- function(x, # nolint |
||
| 912 | -2x | +|||
| 142 | +
- mat_form$strings[!mat_form$display] <- ""+ ...) {
|
|||
| 913 | -+ | |||
| 143 | +38x |
-
+ checkmate::assert_class(x, "coxreg.univar") |
||
| 914 | -2x | +144 | +38x |
- nr <- nrow(tbl)+ mod <- x$mod |
| 915 | -2x | +145 | +38x |
- nc <- ncol(tbl)+ vars <- c(x$vars$arm, x$vars$covariates) |
| 916 | -2x | +146 | +38x |
- nr_h <- attr(mat_form, "nrow_header")+ has_arm <- "arm" %in% names(x$vars) |
| 917 | +147 | |||
| 918 | -2x | +148 | +38x |
- if (is.null(width_row_names) || is.null(width_columns)) {
+ result <- if (!has_arm) {
|
| 919 | -2x | +149 | +5x |
- tbl_widths <- formatters::propose_column_widths(mat_form)+ Map( |
| 920 | -2x | +150 | +5x |
- strs_with_width <- strrep("x", tbl_widths) # that works for mono spaced fonts
+ mod = mod, vars = vars, |
| 921 | -2x | +151 | +5x |
- if (is.null(width_row_names)) width_row_names <- grid::stringWidth(strs_with_width[1])+ f = function(mod, vars) {
|
| 922 | -2x | -
- if (is.null(width_columns)) width_columns <- grid::stringWidth(strs_with_width[-1])- |
- ||
| 923 | -- |
- }- |
- ||
| 924 | -- | - - | -||
| 925 | -+ | 152 | +6x |
- # Widths for row name, cols, forest.+ h_coxreg_multivar_extract( |
| 926 | -2x | +153 | +6x |
- widths <- grid::unit.c(+ var = vars, |
| 927 | -2x | +154 | +6x |
- width_row_names + gap_column,+ data = x$data, |
| 928 | -2x | +155 | +6x |
- width_columns + gap_column,+ mod = mod, |
| 929 | -2x | +156 | +6x |
- width_forest+ control = x$control |
| 930 | +157 |
- )+ ) |
||
| 931 | +158 |
-
+ } |
||
| 932 | -2x | +|||
| 159 | +
- n_lines_per_row <- apply(+ ) |
|||
| 933 | -2x | +160 | +38x |
- X = mat_form$strings,+ } else if (x$control$interaction) {
|
| 934 | -2x | +161 | +12x |
- MARGIN = 1,+ Map( |
| 935 | -2x | +162 | +12x |
- FUN = function(row) {
+ mod = mod, covar = vars, |
| 936 | -10x | +163 | +12x |
- tmp <- vapply(+ f = function(mod, covar) {
|
| 937 | -10x | +164 | +26x |
- gregexpr("\n", row, fixed = TRUE),
+ h_coxreg_extract_interaction( |
| 938 | -10x | +165 | +26x |
- attr, numeric(1),+ effect = x$vars$arm, covar = covar, mod = mod, data = x$data, |
| 939 | -10x | +166 | +26x |
- "match.length"+ at = x$at, control = x$control |
| 940 | -10x | +|||
| 167 | +
- ) + 1+ ) |
|||
| 941 | -10x | +|||
| 168 | +
- max(c(tmp, 1))+ } |
|||
| 942 | +169 |
- }+ ) |
||
| 943 | +170 |
- )+ } else {
|
||
| 944 | -+ | |||
| 171 | +21x |
-
+ Map( |
||
| 945 | -2x | +172 | +21x |
- i_header <- seq_len(nr_h)+ mod = mod, vars = vars, |
| 946 | -+ | |||
| 173 | +21x |
-
+ f = function(mod, vars) {
|
||
| 947 | -2x | +174 | +53x |
- height_body_rows <- grid::unit(n_lines_per_row[-i_header] * 1.2, "lines")+ h_coxreg_univar_extract( |
| 948 | -2x | +175 | +53x |
- height_header_rows <- grid::unit(n_lines_per_row[i_header] * 1.2, "lines")+ effect = x$vars$arm, covar = vars, data = x$data, mod = mod,+ |
+
| 176 | +53x | +
+ control = x$control |
||
| 949 | +177 |
-
+ ) |
||
| 950 | -2x | +|||
| 178 | +
- height_body <- grid::unit(sum(n_lines_per_row[-i_header]) * 1.2, "lines")+ } |
|||
| 951 | -2x | +|||
| 179 | +
- height_header <- grid::unit(sum(n_lines_per_row[i_header]) * 1.2, "lines")+ ) |
|||
| 952 | +180 |
-
+ } |
||
| 953 | -2x | +181 | +38x |
- nc_g <- nc + 2 # number of columns incl. row names and forest+ result <- do.call(rbind, result) |
| 954 | +182 | |||
| 955 | -2x | +183 | +38x |
- vp_tbl <- grid::vpTree(+ result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl)) |
| 956 | -2x | +184 | +38x |
- parent = grid::viewport(+ result$n <- lapply(result$n, empty_vector_if_na) |
| 957 | -2x | +185 | +38x |
- name = "vp_table_layout",+ result$ci <- lapply(result$ci, empty_vector_if_na) |
| 958 | -2x | +186 | +38x |
- layout = grid::grid.layout(+ result$hr <- lapply(result$hr, empty_vector_if_na) |
| 959 | -2x | +187 | +38x |
- nrow = 3, ncol = 1,+ if (x$control$interaction) {
|
| 960 | -2x | +188 | +12x |
- heights = grid::unit.c(height_header, gap_header, height_body)+ result$pval_inter <- lapply(result$pval_inter, empty_vector_if_na) |
| 961 | +189 |
- )+ # Remove interaction p-values due to change in specifications.+ |
+ ||
| 190 | +12x | +
+ result$pval[result$effect != "Treatment:"] <- NA |
||
| 962 | +191 |
- ),+ } |
||
| 963 | -2x | +192 | +38x |
- children = grid::vpList(+ result$pval <- lapply(result$pval, empty_vector_if_na) |
| 964 | -2x | +193 | +38x |
- vp_forest_table_part(nr_h, nc_g, 1, 1, widths, height_header_rows, "vp_header"),+ attr(result, "conf_level") <- x$control$conf_level |
| 965 | -2x | +194 | +38x |
- vp_forest_table_part(nr, nc_g, 3, 1, widths, height_body_rows, "vp_body"),+ result |
| 966 | -2x | +|||
| 195 | +
- grid::viewport(name = "vp_spacer", layout.pos.row = 2, layout.pos.col = 1)+ } |
|||
| 967 | +196 |
- )+ |
||
| 968 | +197 |
- )+ #' @describeIn tidy_coxreg Custom tidy method for a multivariate Cox regression. |
||
| 969 | -2x | +|||
| 198 | +
- vp_tbl+ #' |
|||
| 970 | +199 |
- }+ #' Tidy up the result of a Cox regression model fitted by [fit_coxreg_multivar()]. |
||
| 971 | +200 |
-
+ #' |
||
| 972 | +201 |
- #' Viewport forest plot: table part+ #' @method tidy coxreg.multivar |
||
| 973 | +202 |
#' |
||
| 974 | +203 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' @examples |
||
| 975 | +204 |
- #'+ #' multivar_model <- fit_coxreg_multivar( |
||
| 976 | +205 |
- #' Prepares a viewport for the table included in the forest plot.+ #' variables = list( |
||
| 977 | +206 |
- #'+ #' time = "time", event = "status", arm = "armcd", |
||
| 978 | +207 |
- #' @noRd+ #' covariates = c("covar1", "covar2")
|
||
| 979 | +208 |
- #' @keywords internal+ #' ), |
||
| 980 | +209 |
- vp_forest_table_part <- function(nrow,+ #' data = dta_bladder |
||
| 981 | +210 |
- ncol,+ #' ) |
||
| 982 | +211 |
- l_row,+ #' broom::tidy(multivar_model) |
||
| 983 | +212 |
- l_col,+ #' |
||
| 984 | +213 |
- widths,+ #' @export |
||
| 985 | +214 |
- heights,+ tidy.coxreg.multivar <- function(x, # nolint |
||
| 986 | +215 |
- name) {
+ ...) {
|
||
| 987 | -4x | +216 | +16x |
- lifecycle::deprecate_warn(+ checkmate::assert_class(x, "coxreg.multivar") |
| 988 | -4x | +217 | +16x |
- "0.9.4", "vp_forest_table_part()",+ vars <- c(x$vars$arm, x$vars$covariates) |
| 989 | -4x | +|||
| 218 | +
- details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`."+ |
|||
| 990 | +219 |
- )+ # Convert the model summaries to data. |
||
| 991 | -+ | |||
| 220 | +16x |
-
+ result <- Map( |
||
| 992 | -4x | +221 | +16x |
- grid::vpTree(+ vars = vars, |
| 993 | -4x | +222 | +16x |
- grid::viewport(+ f = function(vars) {
|
| 994 | -4x | +223 | +60x |
- name = name,+ h_coxreg_multivar_extract( |
| 995 | -4x | +224 | +60x |
- layout.pos.row = l_row,+ var = vars, data = x$data, |
| 996 | -4x | +225 | +60x |
- layout.pos.col = l_col,+ mod = x$mod, control = x$control+ |
+
| 226 | ++ |
+ )+ |
+ ||
| 227 | ++ |
+ }+ |
+ ||
| 228 | ++ |
+ ) |
||
| 997 | -4x | +229 | +16x |
- layout = grid::grid.layout(nrow = nrow, ncol = ncol, widths = widths, heights = heights)+ result <- do.call(rbind, result) |
| 998 | +230 |
- ),+ |
||
| 999 | -4x | +231 | +16x |
- children = grid::vpList(+ result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl)) |
| 1000 | -4x | +232 | +16x |
- do.call(+ result$ci <- lapply(result$ci, empty_vector_if_na) |
| 1001 | -4x | +233 | +16x |
- grid::vpList,+ result$hr <- lapply(result$hr, empty_vector_if_na) |
| 1002 | -4x | +234 | +16x |
- lapply(+ result$pval <- lapply(result$pval, empty_vector_if_na) |
| 1003 | -4x | +235 | +16x |
- seq_len(nrow), function(i) {
+ result <- result[, names(result) != "n"] |
| 1004 | -10x | +236 | +16x |
- grid::viewport(layout.pos.row = i, layout.pos.col = 1, name = paste0("rowname-", i))
+ attr(result, "conf_level") <- x$control$conf_level |
| 1005 | +237 |
- }+ + |
+ ||
| 238 | +16x | +
+ result |
||
| 1006 | +239 |
- )+ } |
||
| 1007 | +240 |
- ),+ |
||
| 1008 | -4x | +|||
| 241 | +
- do.call(+ #' Fitting functions for Cox proportional hazards regression |
|||
| 1009 | -4x | +|||
| 242 | +
- grid::vpList,+ #' |
|||
| 1010 | -4x | +|||
| 243 | +
- apply(+ #' @description `r lifecycle::badge("stable")`
|
|||
| 1011 | -4x | +|||
| 244 | +
- expand.grid(seq_len(nrow), seq_len(ncol - 2)),+ #' |
|||
| 1012 | -4x | +|||
| 245 | +
- 1,+ #' Fitting functions for univariate and multivariate Cox regression models. |
|||
| 1013 | -4x | +|||
| 246 | +
- function(x) {
+ #' |
|||
| 1014 | -35x | +|||
| 247 | +
- i <- x[1]+ #' @param variables (named `list`)\cr the names of the variables found in `data`, passed as a named list and |
|||
| 1015 | -35x | +|||
| 248 | +
- j <- x[2]+ #' corresponding to the `time`, `event`, `arm`, `strata`, and `covariates` terms. If `arm` is missing from |
|||
| 1016 | -35x | +|||
| 249 | +
- grid::viewport(layout.pos.row = i, layout.pos.col = j + 1, name = paste0("cell-", i, "-", j))
+ #' `variables`, then only Cox model(s) including the `covariates` will be fitted and the corresponding effect |
|||
| 1017 | +250 |
- }+ #' estimates will be tabulated later. |
||
| 1018 | +251 |
- )+ #' @param data (`data.frame`)\cr the dataset containing the variables to fit the models. |
||
| 1019 | +252 |
- ),+ #' @param at (`list` of `numeric`)\cr when the candidate covariate is a `numeric`, use `at` to specify |
||
| 1020 | -4x | +|||
| 253 | +
- do.call(+ #' the value of the covariate at which the effect should be estimated. |
|||
| 1021 | -4x | +|||
| 254 | +
- grid::vpList,+ #' @param control (`list`)\cr a list of parameters as returned by the helper function [control_coxreg()]. |
|||
| 1022 | -4x | +|||
| 255 | +
- lapply(+ #' |
|||
| 1023 | -4x | +|||
| 256 | +
- seq_len(nrow),+ #' @seealso [h_cox_regression] for relevant helper functions, [cox_regression]. |
|||
| 1024 | -4x | +|||
| 257 | +
- function(i) {
+ #' |
|||
| 1025 | -10x | +|||
| 258 | +
- grid::viewport(layout.pos.row = i, layout.pos.col = ncol, name = paste0("forest-", i))
+ #' @examples |
|||
| 1026 | +259 |
- }+ #' library(survival) |
||
| 1027 | +260 |
- )+ #' |
||
| 1028 | +261 |
- )+ #' set.seed(1, kind = "Mersenne-Twister") |
||
| 1029 | +262 |
- )+ #' |
||
| 1030 | +263 |
- )+ #' # Testing dataset [survival::bladder]. |
||
| 1031 | +264 |
- }+ #' dta_bladder <- with( |
||
| 1032 | +265 |
-
+ #' data = bladder[bladder$enum < 5, ], |
||
| 1033 | +266 |
- #' Forest rendering+ #' data.frame( |
||
| 1034 | +267 |
- #'+ #' time = stop, |
||
| 1035 | +268 |
- #' @description `r lifecycle::badge("deprecated")`
+ #' status = event, |
||
| 1036 | +269 |
- #'+ #' armcd = as.factor(rx), |
||
| 1037 | +270 |
- #' Renders the forest grob.+ #' covar1 = as.factor(enum), |
||
| 1038 | +271 |
- #'+ #' covar2 = factor( |
||
| 1039 | +272 |
- #' @noRd+ #' sample(as.factor(enum)), |
||
| 1040 | +273 |
- #' @keywords internal+ #' levels = 1:4, labels = c("F", "F", "M", "M")
|
||
| 1041 | +274 |
- grid.forest <- function(...) { # nolint
+ #' ) |
||
| 1042 | -! | +|||
| 275 | +
- lifecycle::deprecate_warn(+ #' ) |
|||
| 1043 | -! | +|||
| 276 | +
- "0.9.4", "grid.forest()",+ #' ) |
|||
| 1044 | -! | +|||
| 277 | +
- details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`."+ #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
|
|||
| 1045 | +278 |
- )+ #' formatters::var_labels(dta_bladder)[names(labels)] <- labels |
||
| 1046 | +279 |
-
+ #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
||
| 1047 | -! | +|||
| 280 | +
- grid::grid.draw(forest_grob(...))+ #' |
|||
| 1048 | +281 |
- }+ #' plot( |
| 1 | +282 |
- #' Cumulative counts of numeric variable by thresholds+ #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder), |
||
| 2 | +283 |
- #'+ #' lty = 2:4, |
||
| 3 | +284 |
- #' @description `r lifecycle::badge("stable")`
+ #' xlab = "Months", |
||
| 4 | +285 | ++ |
+ #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
+ |
+ |
| 286 | ++ |
+ #' )+ |
+ ||
| 287 |
#' |
|||
| 5 | +288 |
- #' The analyze function [count_cumulative()] creates a layout element to calculate cumulative counts of values in a+ #' @name fit_coxreg |
||
| 6 | +289 |
- #' numeric variable that are less than, less or equal to, greater than, or greater or equal to user-specified+ NULL |
||
| 7 | +290 |
- #' threshold values.+ |
||
| 8 | +291 |
- #'+ #' @describeIn fit_coxreg Fit a series of univariate Cox regression models given the inputs. |
||
| 9 | +292 |
- #' This function analyzes numeric variable `vars` against the threshold values supplied to the `thresholds`+ #' |
||
| 10 | +293 |
- #' argument as a numeric vector. Whether counts should include the threshold values, and whether to count+ #' @return |
||
| 11 | +294 |
- #' values lower or higher than the threshold values can be set via the `include_eq` and `lower_tail`+ #' * `fit_coxreg_univar()` returns a `coxreg.univar` class object which is a named `list` |
||
| 12 | +295 |
- #' parameters, respectively.+ #' with 5 elements: |
||
| 13 | +296 |
- #'+ #' * `mod`: Cox regression models fitted by [survival::coxph()]. |
||
| 14 | +297 |
- #' @inheritParams h_count_cumulative+ #' * `data`: The original data frame input. |
||
| 15 | +298 |
- #' @inheritParams argument_convention+ #' * `control`: The original control input. |
||
| 16 | +299 |
- #' @param thresholds (`numeric`)\cr vector of cutoff values for the counts.+ #' * `vars`: The variables used in the model. |
||
| 17 | +300 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' * `at`: Value of the covariate at which the effect should be estimated. |
||
| 18 | +301 |
#' |
||
| 19 | +302 |
- #' Options are: ``r shQuote(get_stats("count_cumulative"))``
+ #' @note When using `fit_coxreg_univar` there should be two study arms. |
||
| 20 | +303 |
#' |
||
| 21 | +304 |
- #' @seealso Relevant helper function [h_count_cumulative()], and descriptive function [d_count_cumulative()].+ #' @examples |
||
| 22 | +305 | ++ |
+ #' # fit_coxreg_univar+ |
+ |
| 306 |
#' |
|||
| 23 | +307 |
- #' @name count_cumulative+ #' ## Cox regression: arm + 1 covariate. |
||
| 24 | +308 |
- #' @order 1+ #' mod1 <- fit_coxreg_univar( |
||
| 25 | +309 |
- NULL+ #' variables = list( |
||
| 26 | +310 |
-
+ #' time = "time", event = "status", arm = "armcd", |
||
| 27 | +311 |
- #' Helper function for `s_count_cumulative()`+ #' covariates = "covar1" |
||
| 28 | +312 |
- #'+ #' ), |
||
| 29 | +313 |
- #' @description `r lifecycle::badge("stable")`
+ #' data = dta_bladder, |
||
| 30 | +314 |
- #'+ #' control = control_coxreg(conf_level = 0.91) |
||
| 31 | +315 |
- #' Helper function to calculate count and fraction of `x` values in the lower or upper tail given a threshold.+ #' ) |
||
| 32 | +316 |
#' |
||
| 33 | +317 |
- #' @inheritParams argument_convention+ #' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates. |
||
| 34 | +318 |
- #' @param threshold (`numeric(1)`)\cr a cutoff value as threshold to count values of `x`.+ #' mod2 <- fit_coxreg_univar( |
||
| 35 | +319 |
- #' @param lower_tail (`flag`)\cr whether to count lower tail, default is `TRUE`.+ #' variables = list( |
||
| 36 | +320 |
- #' @param include_eq (`flag`)\cr whether to include value equal to the `threshold` in+ #' time = "time", event = "status", arm = "armcd", |
||
| 37 | +321 |
- #' count, default is `TRUE`.+ #' covariates = c("covar1", "covar2")
|
||
| 38 | +322 |
- #'+ #' ), |
||
| 39 | +323 | ++ |
+ #' data = dta_bladder,+ |
+ |
| 324 | ++ |
+ #' control = control_coxreg(conf_level = 0.91, interaction = TRUE)+ |
+ ||
| 325 | ++ |
+ #' )+ |
+ ||
| 326 |
- #' @return A named vector with items:+ #' |
|||
| 40 | +327 |
- #' * `count`: the count of values less than, less or equal to, greater than, or greater or equal to a threshold+ #' ## Cox regression: arm + 1 covariate, stratified analysis. |
||
| 41 | +328 |
- #' of user specification.+ #' mod3 <- fit_coxreg_univar( |
||
| 42 | +329 |
- #' * `fraction`: the fraction of the count.+ #' variables = list( |
||
| 43 | +330 |
- #'+ #' time = "time", event = "status", arm = "armcd", strata = "covar2", |
||
| 44 | +331 |
- #' @seealso [count_cumulative]+ #' covariates = c("covar1")
|
||
| 45 | +332 |
- #'+ #' ), |
||
| 46 | +333 |
- #' @examples+ #' data = dta_bladder, |
||
| 47 | +334 |
- #' set.seed(1, kind = "Mersenne-Twister")+ #' control = control_coxreg(conf_level = 0.91) |
||
| 48 | +335 |
- #' x <- c(sample(1:10, 10), NA)+ #' ) |
||
| 49 | +336 |
- #' .N_col <- length(x)+ #' |
||
| 50 | +337 |
- #'+ #' ## Cox regression: no arm, only covariates. |
||
| 51 | +338 |
- #' h_count_cumulative(x, 5, .N_col = .N_col)+ #' mod4 <- fit_coxreg_univar( |
||
| 52 | +339 |
- #' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na.rm = FALSE, .N_col = .N_col)+ #' variables = list( |
||
| 53 | +340 |
- #' h_count_cumulative(x, 0, lower_tail = FALSE, .N_col = .N_col)+ #' time = "time", event = "status", |
||
| 54 | +341 |
- #' h_count_cumulative(x, 100, lower_tail = FALSE, .N_col = .N_col)+ #' covariates = c("covar1", "covar2")
|
||
| 55 | +342 |
- #'+ #' ), |
||
| 56 | +343 |
- #' @export+ #' data = dta_bladder |
||
| 57 | +344 |
- h_count_cumulative <- function(x,+ #' ) |
||
| 58 | +345 |
- threshold,+ #' |
||
| 59 | +346 |
- lower_tail = TRUE,+ #' @export |
||
| 60 | +347 |
- include_eq = TRUE,+ fit_coxreg_univar <- function(variables, |
||
| 61 | +348 |
- na.rm = TRUE, # nolint+ data, |
||
| 62 | +349 |
- .N_col) { # nolint
+ at = list(), |
||
| 63 | -36x | +|||
| 350 | +
- checkmate::assert_numeric(x)+ control = control_coxreg()) {
|
|||
| 64 | -36x | +351 | +43x |
- checkmate::assert_numeric(threshold)+ checkmate::assert_list(variables, names = "named") |
| 65 | -36x | +352 | +43x |
- checkmate::assert_numeric(.N_col)+ has_arm <- "arm" %in% names(variables) |
| 66 | -36x | +353 | +43x |
- checkmate::assert_flag(lower_tail)+ arm_name <- if (has_arm) "arm" else NULL |
| 67 | -36x | +|||
| 354 | +
- checkmate::assert_flag(include_eq)+ |
|||
| 68 | -36x | +355 | +43x |
- checkmate::assert_flag(na.rm)+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
| 69 | +356 | |||
| 70 | -36x | +357 | +43x |
- is_keep <- if (na.rm) !is.na(x) else rep(TRUE, length(x))+ assert_df_with_variables(data, variables) |
| 71 | -36x | +358 | +43x |
- count <- if (lower_tail && include_eq) {
+ assert_list_of_variables(variables[c(arm_name, "event", "time")]) |
| 72 | -7x | +|||
| 359 | +
- length(x[is_keep & x <= threshold])+ |
|||
| 73 | -36x | -
- } else if (lower_tail && !include_eq) {
- |
- ||
| 74 | -! | +360 | +43x |
- length(x[is_keep & x < threshold])+ if (!is.null(variables$strata)) {
|
| 75 | -36x | +361 | +4x |
- } else if (!lower_tail && include_eq) {
+ checkmate::assert_disjunct(control$pval_method, "likelihood") |
| 76 | -14x | +|||
| 362 | +
- length(x[is_keep & x >= threshold])+ } |
|||
| 77 | -36x | +363 | +42x |
- } else if (!lower_tail && !include_eq) {
+ if (has_arm) {
|
| 78 | -15x | +364 | +36x |
- length(x[is_keep & x > threshold])+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2) |
| 79 | +365 |
} |
||
| 80 | -- | - - | -||
| 81 | -36x | +366 | +41x |
- result <- c(+ vars <- unlist(variables[c(arm_name, "covariates", "strata")], use.names = FALSE) |
| 82 | -36x | +367 | +41x |
- count = count,+ for (i in vars) {
|
| 83 | -36x | -
- fraction = if (count == 0 && .N_col == 0) 0 else count / .N_col- |
- ||
| 84 | -+ | 368 | +94x |
- )+ if (is.factor(data[[i]])) {
|
| 85 | -36x | +369 | +82x |
- result+ attr(data[[i]], "levels") <- levels(droplevels(data[[i]])) |
| 86 | +370 |
- }+ } |
||
| 87 | +371 |
-
+ } |
||
| 88 | -+ | |||
| 372 | +41x |
- #' Description of cumulative count+ forms <- h_coxreg_univar_formulas(variables, interaction = control$interaction) |
||
| 89 | -+ | |||
| 373 | +41x |
- #'+ mod <- lapply( |
||
| 90 | -+ | |||
| 374 | +41x |
- #' @description `r lifecycle::badge("stable")`
+ forms, function(x) {
|
||
| 91 | -+ | |||
| 375 | +90x |
- #'+ survival::coxph(formula = stats::as.formula(x), data = data, ties = control$ties) |
||
| 92 | +376 |
- #' This is a helper function that describes the analysis in [s_count_cumulative()].+ } |
||
| 93 | +377 |
- #'+ ) |
||
| 94 | -+ | |||
| 378 | +41x |
- #' @inheritParams h_count_cumulative+ structure( |
||
| 95 | -+ | |||
| 379 | +41x |
- #'+ list( |
||
| 96 | -+ | |||
| 380 | +41x |
- #' @return Labels for [s_count_cumulative()].+ mod = mod, |
||
| 97 | -+ | |||
| 381 | +41x |
- #'+ data = data, |
||
| 98 | -+ | |||
| 382 | +41x |
- #' @export+ control = control, |
||
| 99 | -+ | |||
| 383 | +41x |
- d_count_cumulative <- function(threshold, lower_tail = TRUE, include_eq = TRUE) {
+ vars = variables, |
||
| 100 | -34x | +384 | +41x |
- checkmate::assert_numeric(threshold)+ at = at |
| 101 | -34x | +|||
| 385 | +
- lg <- if (lower_tail) "<" else ">"+ ), |
|||
| 102 | -34x | +386 | +41x |
- eq <- if (include_eq) "=" else ""+ class = "coxreg.univar" |
| 103 | -34x | +|||
| 387 | +
- paste0(lg, eq, " ", threshold)+ ) |
|||
| 104 | +388 |
} |
||
| 105 | +389 | |||
| 106 | +390 |
- #' @describeIn count_cumulative Statistics function that produces a named list given a numeric vector of thresholds.+ #' @describeIn fit_coxreg Fit a multivariate Cox regression model. |
||
| 107 | +391 |
#' |
||
| 108 | +392 |
#' @return |
||
| 109 | +393 |
- #' * `s_count_cumulative()` returns a named list of `count_fraction`s: a list with each `thresholds` value as a+ #' * `fit_coxreg_multivar()` returns a `coxreg.multivar` class object which is a named list |
||
| 110 | +394 |
- #' component, each component containing a vector for the count and fraction.+ #' with 4 elements: |
||
| 111 | +395 |
- #'+ #' * `mod`: Cox regression model fitted by [survival::coxph()]. |
||
| 112 | +396 |
- #' @keywords internal+ #' * `data`: The original data frame input. |
||
| 113 | +397 |
- s_count_cumulative <- function(x,+ #' * `control`: The original control input. |
||
| 114 | +398 |
- thresholds,+ #' * `vars`: The variables used in the model. |
||
| 115 | +399 |
- lower_tail = TRUE,+ #' |
||
| 116 | +400 |
- include_eq = TRUE,+ #' @examples |
||
| 117 | +401 |
- .N_col, # nolint+ #' # fit_coxreg_multivar |
||
| 118 | +402 |
- .N_row, # nolint+ #' |
||
| 119 | +403 |
- denom = c("N_col", "n", "N_row"),
+ #' ## Cox regression: multivariate Cox regression. |
||
| 120 | +404 |
- ...) {
- |
- ||
| 121 | -9x | -
- checkmate::assert_numeric(thresholds, min.len = 1, any.missing = FALSE)+ #' multivar_model <- fit_coxreg_multivar( |
||
| 122 | +405 | - - | -||
| 123 | -9x | -
- denom <- match.arg(denom) %>%- |
- ||
| 124 | -9x | -
- switch(+ #' variables = list( |
||
| 125 | -9x | +|||
| 406 | +
- n = length(x),+ #' time = "time", event = "status", arm = "armcd", |
|||
| 126 | -9x | +|||
| 407 | +
- N_row = .N_row,+ #' covariates = c("covar1", "covar2")
|
|||
| 127 | -9x | +|||
| 408 | +
- N_col = .N_col+ #' ), |
|||
| 128 | +409 |
- )+ #' data = dta_bladder |
||
| 129 | +410 |
-
+ #' ) |
||
| 130 | -9x | +|||
| 411 | +
- count_fraction_list <- Map(function(thres) {
+ #' |
|||
| 131 | -18x | +|||
| 412 | +
- result <- h_count_cumulative(x, thres, lower_tail, include_eq, .N_col = denom, ...)+ #' # Example without treatment arm. |
|||
| 132 | -18x | +|||
| 413 | +
- label <- d_count_cumulative(thres, lower_tail, include_eq)+ #' multivar_covs_model <- fit_coxreg_multivar( |
|||
| 133 | -18x | +|||
| 414 | +
- formatters::with_label(result, label)+ #' variables = list( |
|||
| 134 | -9x | +|||
| 415 | +
- }, thresholds)+ #' time = "time", event = "status", |
|||
| 135 | +416 |
-
+ #' covariates = c("covar1", "covar2")
|
||
| 136 | -9x | +|||
| 417 | +
- names(count_fraction_list) <- thresholds+ #' ), |
|||
| 137 | -9x | +|||
| 418 | +
- list(count_fraction = count_fraction_list)+ #' data = dta_bladder |
|||
| 138 | +419 |
- }+ #' ) |
||
| 139 | +420 |
-
+ #' |
||
| 140 | +421 |
- #' @describeIn count_cumulative Formatted analysis function which is used as `afun`+ #' @export |
||
| 141 | +422 |
- #' in `count_cumulative()`.+ fit_coxreg_multivar <- function(variables, |
||
| 142 | +423 |
- #'+ data, |
||
| 143 | +424 |
- #' @return+ control = control_coxreg()) {
|
||
| 144 | -+ | |||
| 425 | +83x |
- #' * `a_count_cumulative()` returns the corresponding list with formatted [rtables::CellValue()].+ checkmate::assert_list(variables, names = "named") |
||
| 145 | -+ | |||
| 426 | +83x |
- #'+ has_arm <- "arm" %in% names(variables) |
||
| 146 | -+ | |||
| 427 | +83x |
- #' @keywords internal+ arm_name <- if (has_arm) "arm" else NULL |
||
| 147 | +428 |
- a_count_cumulative <- make_afun(+ |
||
| 148 | -+ | |||
| 429 | +83x |
- s_count_cumulative,+ if (!is.null(variables$covariates)) {
|
||
| 149 | -+ | |||
| 430 | +21x |
- .formats = c(count_fraction = format_count_fraction)+ checkmate::assert_character(variables$covariates) |
||
| 150 | +431 |
- )+ } |
||
| 151 | +432 | |||
| 152 | -+ | |||
| 433 | +83x |
- #' @describeIn count_cumulative Layout-creating function which can take statistics function arguments+ checkmate::assert_false(control$interaction) |
||
| 153 | -+ | |||
| 434 | +83x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ assert_df_with_variables(data, variables) |
||
| 154 | -+ | |||
| 435 | +83x |
- #'+ assert_list_of_variables(variables[c(arm_name, "event", "time")]) |
||
| 155 | +436 |
- #' @return+ |
||
| 156 | -+ | |||
| 437 | +83x |
- #' * `count_cumulative()` returns a layout object suitable for passing to further layouting functions,+ if (!is.null(variables$strata)) {
|
||
| 157 | -+ | |||
| 438 | +3x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ checkmate::assert_disjunct(control$pval_method, "likelihood") |
||
| 158 | +439 |
- #' the statistics from `s_count_cumulative()` to the table layout.+ } |
||
| 159 | +440 |
- #'+ |
||
| 160 | -+ | |||
| 441 | +82x |
- #' @examples+ form <- h_coxreg_multivar_formula(variables) |
||
| 161 | -+ | |||
| 442 | +82x |
- #' basic_table() %>%+ mod <- survival::coxph( |
||
| 162 | -+ | |||
| 443 | +82x |
- #' split_cols_by("ARM") %>%
+ formula = stats::as.formula(form), |
||
| 163 | -+ | |||
| 444 | +82x |
- #' add_colcounts() %>%+ data = data, |
||
| 164 | -+ | |||
| 445 | +82x |
- #' count_cumulative(+ ties = control$ties |
||
| 165 | +446 |
- #' vars = "AGE",+ ) |
||
| 166 | -+ | |||
| 447 | +82x |
- #' thresholds = c(40, 60)+ structure( |
||
| 167 | -+ | |||
| 448 | +82x |
- #' ) %>%+ list( |
||
| 168 | -+ | |||
| 449 | +82x |
- #' build_table(tern_ex_adsl)+ mod = mod, |
||
| 169 | -+ | |||
| 450 | +82x |
- #'+ data = data, |
||
| 170 | -+ | |||
| 451 | +82x |
- #' @export+ control = control, |
||
| 171 | -+ | |||
| 452 | +82x |
- #' @order 2+ vars = variables |
||
| 172 | +453 |
- count_cumulative <- function(lyt,+ ), |
||
| 173 | -+ | |||
| 454 | +82x |
- vars,+ class = "coxreg.multivar" |
||
| 174 | +455 |
- thresholds,+ ) |
||
| 175 | +456 |
- lower_tail = TRUE,+ } |
||
| 176 | +457 |
- include_eq = TRUE,+ |
||
| 177 | +458 |
- var_labels = vars,+ #' Muffled `car::Anova` |
||
| 178 | +459 |
- show_labels = "visible",+ #' |
||
| 179 | +460 |
- na_str = default_na_str(),+ #' Applied on survival models, [car::Anova()] signal that the `strata` terms is dropped from the model formula when |
||
| 180 | +461 |
- nested = TRUE,+ #' present, this function deliberately muffles this message. |
||
| 181 | +462 |
- ...,+ #' |
||
| 182 | +463 |
- table_names = vars,+ #' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()]. |
||
| 183 | +464 |
- .stats = NULL,+ #' @param test_statistic (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`. |
||
| 184 | +465 |
- .formats = NULL,+ #' |
||
| 185 | +466 |
- .labels = NULL,+ #' @return The output of [car::Anova()], with convergence message muffled. |
||
| 186 | +467 |
- .indent_mods = NULL) {
+ #' |
||
| 187 | -3x | +|||
| 468 | +
- extra_args <- list(thresholds = thresholds, lower_tail = lower_tail, include_eq = include_eq, ...)+ #' @keywords internal |
|||
| 188 | +469 |
-
+ muffled_car_anova <- function(mod, test_statistic) {
|
||
| 189 | -3x | +470 | +219x |
- afun <- make_afun(+ tryCatch( |
| 190 | -3x | +471 | +219x |
- a_count_cumulative,+ withCallingHandlers( |
| 191 | -3x | +472 | +219x |
- .stats = .stats,+ expr = {
|
| 192 | -3x | +473 | +219x |
- .formats = .formats,+ car::Anova( |
| 193 | -3x | +474 | +219x |
- .labels = .labels,+ mod, |
| 194 | -3x | +475 | +219x |
- .indent_mods = .indent_mods,+ test.statistic = test_statistic, |
| 195 | -3x | +476 | +219x |
- .ungroup_stats = "count_fraction"+ type = "III" |
| 196 | +477 |
- )+ ) |
||
| 197 | -3x | +|||
| 478 | +
- analyze(+ }, |
|||
| 198 | -3x | +479 | +219x |
- lyt,+ message = function(m) invokeRestart("muffleMessage"),
|
| 199 | -3x | +480 | +219x |
- vars,+ error = function(e) {
|
| 200 | -3x | +481 | +1x |
- afun = afun,+ stop(paste( |
| 201 | -3x | +482 | +1x |
- na_str = na_str,+ "the model seems to have convergence problems, please try to change", |
| 202 | -3x | +483 | +1x |
- table_names = table_names,+ "the configuration of covariates or strata variables, e.g.", |
| 203 | -3x | +484 | +1x |
- var_labels = var_labels,+ "- original error:", e |
| 204 | -3x | +|||
| 485 | +
- show_labels = show_labels,+ )) |
|||
| 205 | -3x | +|||
| 486 | +
- nested = nested,+ } |
|||
| 206 | -3x | +|||
| 487 | +
- extra_args = extra_args+ ) |
|||
| 207 | +488 |
) |
||
| 208 | +489 |
}@@ -89620,14 +92242,14 @@ tern coverage - 95.59% |
| 1 |
- #' Split function to configure risk difference column+ #' Confidence interval for mean |
|||
| 5 |
- #' Wrapper function for [rtables::add_combo_levels()] which configures settings for the risk difference+ #' Convenient function for calculating the mean confidence interval. It calculates the arithmetic as well as the |
|||
| 6 |
- #' column to be added to an `rtables` object. To add a risk difference column to a table, this function+ #' geometric mean. It can be used as a `ggplot` helper function for plotting. |
|||
| 7 |
- #' should be used as `split_fun` in calls to [rtables::split_cols_by()], followed by setting argument+ #' |
|||
| 8 |
- #' `riskdiff` to `TRUE` in all following analyze function calls.+ #' @inheritParams argument_convention |
|||
| 9 |
- #'+ #' @param n_min (`numeric(1)`)\cr a minimum number of non-missing `x` to estimate the confidence interval for mean. |
|||
| 10 |
- #' @param arm_x (`string`)\cr name of reference arm to use in risk difference calculations.+ #' @param gg_helper (`flag`)\cr whether output should be aligned for use with `ggplot`s. |
|||
| 11 |
- #' @param arm_y (`character`)\cr names of one or more arms to compare to reference arm in risk difference+ #' @param geom_mean (`flag`)\cr whether the geometric mean should be calculated. |
|||
| 12 |
- #' calculations. A new column will be added for each value of `arm_y`.+ #' |
|||
| 13 |
- #' @param col_label (`character`)\cr labels to use when rendering the risk difference column within the table.+ #' @return A named `vector` of values `mean_ci_lwr` and `mean_ci_upr`. |
|||
| 14 |
- #' If more than one comparison arm is specified in `arm_y`, default labels will specify which two arms are+ #' |
|||
| 15 |
- #' being compared (reference arm vs. comparison arm).+ #' @examples |
|||
| 16 |
- #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`.+ #' stat_mean_ci(sample(10), gg_helper = FALSE) |
|||
| 18 |
- #' @return A closure suitable for use as a split function (`split_fun`) within [rtables::split_cols_by()]+ #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) + |
|||
| 19 |
- #' when creating a table layout.+ #' ggplot2::geom_point() |
|||
| 21 |
- #' @seealso [stat_propdiff_ci()] for details on risk difference calculation.+ #' p + ggplot2::stat_summary( |
|||
| 22 |
- #'+ #' fun.data = stat_mean_ci, |
|||
| 23 |
- #' @examples+ #' geom = "errorbar" |
|||
| 24 |
- #' adae <- tern_ex_adae+ #' ) |
|||
| 25 |
- #' adae$AESEV <- factor(adae$AESEV)+ #' |
|||
| 26 |
- #'+ #' p + ggplot2::stat_summary( |
|||
| 27 |
- #' lyt <- basic_table() %>%+ #' fun.data = stat_mean_ci, |
|||
| 28 |
- #' split_cols_by("ARMCD", split_fun = add_riskdiff(arm_x = "ARM A", arm_y = c("ARM B", "ARM C"))) %>%
+ #' fun.args = list(conf_level = 0.5), |
|||
| 29 |
- #' count_occurrences_by_grade(+ #' geom = "errorbar" |
|||
| 30 |
- #' var = "AESEV",+ #' ) |
|||
| 31 |
- #' riskdiff = TRUE+ #' |
|||
| 32 |
- #' )+ #' p + ggplot2::stat_summary( |
|||
| 33 |
- #'+ #' fun.data = stat_mean_ci, |
|||
| 34 |
- #' tbl <- build_table(lyt, df = adae)+ #' fun.args = list(conf_level = 0.5, geom_mean = TRUE), |
|||
| 35 |
- #' tbl+ #' geom = "errorbar" |
|||
| 36 |
- #'+ #' ) |
|||
| 37 |
- #' @export+ #' |
|||
| 38 |
- add_riskdiff <- function(arm_x,+ #' @export |
|||
| 39 |
- arm_y,+ stat_mean_ci <- function(x, |
|||
| 40 |
- col_label = paste0(+ conf_level = 0.95, |
|||
| 41 |
- "Risk Difference (%) (95% CI)", if (length(arm_y) > 1) paste0("\n", arm_x, " vs. ", arm_y)
+ na.rm = TRUE, # nolint |
|||
| 42 |
- ),+ n_min = 2, |
|||
| 43 |
- pct = TRUE) {
+ gg_helper = TRUE, |
|||
| 44 | -19x | +
- checkmate::assert_character(arm_x, len = 1)+ geom_mean = FALSE) {
|
||
| 45 | -19x | +2295x |
- checkmate::assert_character(arm_y, min.len = 1)+ if (na.rm) {
|
|
| 46 | -19x | +10x |
- checkmate::assert_character(col_label, len = length(arm_y))+ x <- stats::na.omit(x) |
|
| 47 |
-
+ } |
|||
| 48 | -19x | +2295x |
- combodf <- tibble::tribble(~valname, ~label, ~levelcombo, ~exargs)+ n <- length(x) |
|
| 49 | -19x | +
- for (i in seq_len(length(arm_y))) {
+
|
||
| 50 | -20x | +2295x |
- combodf <- rbind(+ if (!geom_mean) {
|
|
| 51 | -20x | +1155x |
- combodf,+ m <- mean(x) |
|
| 52 | -20x | +
- tibble::tribble(+ } else {
|
||
| 53 | -20x | +1140x |
- ~valname, ~label, ~levelcombo, ~exargs,+ negative_values_exist <- any(is.na(x[!is.na(x)]) <- x[!is.na(x)] <= 0) |
|
| 54 | -20x | +1140x |
- paste("riskdiff", arm_x, arm_y[i], sep = "_"), col_label[i], c(arm_x, arm_y[i]), list()
+ if (negative_values_exist) {
|
|
| 55 | -+ | 24x |
- )+ m <- NA_real_ |
|
| 56 |
- )+ } else {
|
|||
| 57 | -+ | 1116x |
- }+ x <- log(x) |
|
| 58 | -19x | +1116x |
- if (pct) combodf$valname <- paste0(combodf$valname, "_pct")+ m <- mean(x) |
|
| 59 | -19x | +
- add_combo_levels(combodf)+ } |
||
| 60 |
- }+ } |
|||
| 62 | -+ | 2295x |
- #' Analysis function to calculate risk difference column values+ if (n < n_min || is.na(m)) {
|
|
| 63 | -+ | 304x |
- #'+ ci <- c(mean_ci_lwr = NA_real_, mean_ci_upr = NA_real_) |
|
| 64 |
- #' In the risk difference column, this function uses the statistics function associated with `afun` to+ } else {
|
|||
| 65 | -+ | 1991x |
- #' calculates risk difference values from arm X (reference group) and arm Y. These arms are specified+ hci <- stats::qt((1 + conf_level) / 2, df = n - 1) * stats::sd(x) / sqrt(n) |
|
| 66 | -+ | 1991x |
- #' when configuring the risk difference column which is done using the [add_riskdiff()] split function in+ ci <- c(mean_ci_lwr = m - hci, mean_ci_upr = m + hci) |
|
| 67 | -+ | 1991x |
- #' the previous call to [rtables::split_cols_by()]. For all other columns, applies `afun` as usual. This+ if (geom_mean) {
|
|
| 68 | -+ | 985x |
- #' function utilizes the [stat_propdiff_ci()] function to perform risk difference calculations.+ ci <- exp(ci) |
|
| 69 |
- #'+ } |
|||
| 70 |
- #' @inheritParams argument_convention+ } |
|||
| 71 |
- #' @param afun (named `list`)\cr a named list containing one name-value pair where the name corresponds to+ |
|||
| 72 | -+ | 2295x |
- #' the name of the statistics function that should be used in calculations and the value is the corresponding+ if (gg_helper) {
|
|
| 73 | -+ | 4x |
- #' analysis function.+ m <- ifelse(is.na(m), NA_real_, m) |
|
| 74 | -+ | 4x |
- #' @param s_args (named `list`)\cr additional arguments to be passed to the statistics function and analysis+ ci <- data.frame(y = ifelse(geom_mean, exp(m), m), ymin = ci[[1]], ymax = ci[[2]]) |
|
| 75 |
- #' function supplied in `afun`.+ } |
|||
| 76 |
- #'+ |
|||
| 77 | -+ | 2295x |
- #' @return A list of formatted [rtables::CellValue()].+ return(ci) |
|
| 78 |
- #'+ } |
|||
| 79 |
- #' @seealso+ |
|||
| 80 |
- #' * [stat_propdiff_ci()] for details on risk difference calculation.+ #' Confidence interval for median |
|||
| 81 |
- #' * Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()] with+ #' |
|||
| 82 |
- #' `riskdiff` argument set to `TRUE` in subsequent analyze functions calls, adds a risk difference column+ #' @description `r lifecycle::badge("stable")`
|
|||
| 83 |
- #' to a table layout.+ #' |
|||
| 84 |
- #'+ #' Convenient function for calculating the median confidence interval. It can be used as a `ggplot` helper |
|||
| 85 |
- #' @keywords internal+ #' function for plotting. |
|||
| 86 |
- afun_riskdiff <- function(df,+ #' |
|||
| 87 |
- labelstr = "",+ #' @inheritParams argument_convention |
|||
| 88 |
- .var,+ #' @param gg_helper (`flag`)\cr whether output should be aligned for use with `ggplot`s. |
|||
| 89 |
- .N_col, # nolint+ #' |
|||
| 90 |
- .N_row, # nolint+ #' @details This function was adapted from `DescTools/versions/0.99.35/source` |
|||
| 91 |
- .df_row,+ #' |
|||
| 92 |
- .spl_context,+ #' @return A named `vector` of values `median_ci_lwr` and `median_ci_upr`. |
|||
| 93 |
- .all_col_counts,+ #' |
|||
| 94 |
- .stats,+ #' @examples |
|||
| 95 |
- .formats = NULL,+ #' stat_median_ci(sample(10), gg_helper = FALSE) |
|||
| 96 |
- .labels = NULL,+ #' |
|||
| 97 |
- .indent_mods = NULL,+ #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) + |
|||
| 98 |
- na_str = default_na_str(),+ #' ggplot2::geom_point() |
|||
| 99 |
- afun,+ #' p + ggplot2::stat_summary( |
|||
| 100 |
- s_args = list()) {
+ #' fun.data = stat_median_ci, |
|||
| 101 | -146x | +
- if (!any(grepl("riskdiff", names(.spl_context)))) {
+ #' geom = "errorbar" |
||
| 102 | -! | +
- stop(+ #' ) |
||
| 103 | -! | +
- "Please set up levels to use in risk difference calculations using the `add_riskdiff` ",+ #' |
||
| 104 | -! | +
- "split function within `split_cols_by`. See ?add_riskdiff for details."+ #' @export |
||
| 105 |
- )+ stat_median_ci <- function(x, |
|||
| 106 |
- }+ conf_level = 0.95, |
|||
| 107 | -146x | +
- checkmate::assert_list(afun, len = 1, types = "function")+ na.rm = TRUE, # nolint |
||
| 108 | -146x | +
- checkmate::assert_named(afun)+ gg_helper = TRUE) {
|
||
| 109 | -146x | +1153x |
- afun_args <- list(+ x <- unname(x) |
|
| 110 | -146x | +1153x |
- .var = .var, .df_row = .df_row, .N_row = .N_row, denom = "N_col", labelstr = labelstr,+ if (na.rm) {
|
|
| 111 | -146x | +9x |
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str+ x <- x[!is.na(x)] |
|
| 112 |
- )+ } |
|||
| 113 | -146x | +1153x |
- afun_args <- afun_args[intersect(names(afun_args), names(as.list(args(afun[[1]]))))]+ n <- length(x) |
|
| 114 | -! | +1153x |
- if ("denom" %in% names(s_args)) afun_args[["denom"]] <- NULL
+ med <- stats::median(x) |
|
| 116 | -146x | +1153x |
- cur_split <- tail(.spl_context$cur_col_split_val[[1]], 1)+ k <- stats::qbinom(p = (1 - conf_level) / 2, size = n, prob = 0.5, lower.tail = TRUE) |
|
| 117 | -146x | +
- if (!grepl("^riskdiff", cur_split)) {
+
|
||
| 118 |
- # Apply basic afun (no risk difference) in all other columns+ # k == 0 - for small samples (e.g. n <= 5) ci can be outside the observed range |
|||
| 119 | -108x | +1153x |
- do.call(afun[[1]], args = c(list(df = df, .N_col = .N_col), afun_args, s_args))+ if (k == 0 || is.na(med)) {
|
|
| 120 | -+ | 248x |
- } else {
+ ci <- c(median_ci_lwr = NA_real_, median_ci_upr = NA_real_) |
|
| 121 | -38x | +248x |
- arm_x <- strsplit(cur_split, "_")[[1]][2]+ empir_conf_level <- NA_real_ |
|
| 122 | -38x | +
- arm_y <- strsplit(cur_split, "_")[[1]][3]+ } else {
|
||
| 123 | -38x | +905x |
- if (length(.spl_context$cur_col_split[[1]]) > 1) { # Different split name for nested column splits
+ x_sort <- sort(x) |
|
| 124 | -8x | +905x |
- arm_spl_x <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 2)], collapse = ""))
+ ci <- c(median_ci_lwr = x_sort[k], median_ci_upr = x_sort[n - k + 1]) |
|
| 125 | -8x | +905x |
- arm_spl_y <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 3)], collapse = ""))
+ empir_conf_level <- 1 - 2 * stats::pbinom(k - 1, size = n, prob = 0.5) |
|
| 126 |
- } else {
+ } |
|||
| 127 | -30x | +
- arm_spl_x <- arm_x+ |
||
| 128 | -30x | +1153x |
- arm_spl_y <- arm_y+ if (gg_helper) {
|
|
| 129 | -+ | 4x |
- }+ ci <- data.frame(y = med, ymin = ci[[1]], ymax = ci[[2]]) |
|
| 130 |
-
+ } |
|||
| 131 | -38x | +
- N_col_x <- .all_col_counts[[arm_spl_x]] # nolint+ |
||
| 132 | -38x | +1153x |
- N_col_y <- .all_col_counts[[arm_spl_y]] # nolint+ attr(ci, "conf_level") <- empir_conf_level |
|
| 133 | -38x | +
- cur_var <- tail(.spl_context$cur_col_split[[1]], 1)+ |
||
| 134 | -+ | 1153x |
-
+ return(ci) |
|
| 135 |
- # Apply statistics function to arm X and arm Y data+ } |
|||
| 136 | -38x | +
- s_args <- c(s_args, afun_args[intersect(names(afun_args), names(as.list(args(names(afun)))))])+ |
||
| 137 | -38x | +
- s_x <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_x, ], .N_col = N_col_x), s_args))+ #' p-Value of the mean |
||
| 138 | -38x | +
- s_y <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_y, ], .N_col = N_col_y), s_args))+ #' |
||
| 139 |
-
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 140 |
- # Get statistic name and row names+ #' |
|||
| 141 | -38x | +
- stat <- ifelse("count_fraction" %in% names(s_x), "count_fraction", "unique")
+ #' Convenient function for calculating the two-sided p-value of the mean. |
||
| 142 | -38x | +
- if ("flag_variables" %in% names(s_args)) {
+ #' |
||
| 143 | -2x | +
- var_nms <- s_args$flag_variables+ #' @inheritParams argument_convention |
||
| 144 | -36x | +
- } else if (is.list(s_x[[stat]]) && !is.null(names(s_x[[stat]]))) {
+ #' @param n_min (`numeric(1)`)\cr a minimum number of non-missing `x` to estimate the p-value of the mean. |
||
| 145 | -24x | +
- var_nms <- names(s_x[[stat]])+ #' @param test_mean (`numeric(1)`)\cr mean value to test under the null hypothesis. |
||
| 146 |
- } else {
+ #' |
|||
| 147 | -12x | +
- var_nms <- ""+ #' @return A p-value. |
||
| 148 | -12x | +
- s_x[[stat]] <- list(s_x[[stat]])+ #' |
||
| 149 | -12x | +
- s_y[[stat]] <- list(s_y[[stat]])+ #' @examples |
||
| 150 |
- }+ #' stat_mean_pval(sample(10)) |
|||
| 151 |
-
+ #' |
|||
| 152 |
- # Calculate risk difference for each row, repeated if multiple statistics in table+ #' stat_mean_pval(rnorm(10), test_mean = 0.5) |
|||
| 153 | -38x | +
- pct <- tail(strsplit(cur_split, "_")[[1]], 1) == "pct"+ #' |
||
| 154 | -38x | +
- rd_ci <- rep(stat_propdiff_ci(+ #' @export |
||
| 155 | -38x | +
- lapply(s_x[[stat]], `[`, 1), lapply(s_y[[stat]], `[`, 1),+ stat_mean_pval <- function(x, |
||
| 156 | -38x | +
- N_col_x, N_col_y,+ na.rm = TRUE, # nolint |
||
| 157 | -38x | +
- list_names = var_nms,+ n_min = 2, |
||
| 158 | -38x | +
- pct = pct+ test_mean = 0) {
|
||
| 159 | -38x | +1153x |
- ), max(1, length(.stats)))+ if (na.rm) {
|
|
| 160 | +9x | +
+ x <- stats::na.omit(x)+ |
+ ||
| 161 | ++ |
+ }+ |
+ ||
| 162 | +1153x | +
+ n <- length(x)+ |
+ ||
| 163 | ||||
| 161 | -38x | +164 | +1153x |
- in_rows(.list = rd_ci, .formats = "xx.x (xx.x - xx.x)", .indent_mods = .indent_mods)+ x_mean <- mean(x)+ |
+
| 165 | +1153x | +
+ x_sd <- stats::sd(x) |
||
| 162 | +166 | ++ | + + | +|
| 167 | +1153x | +
+ if (n < n_min) {
+ |
+ ||
| 168 | +140x | +
+ pv <- c(p_value = NA_real_)+ |
+ ||
| 169 | ++ |
+ } else {
+ |
+ ||
| 170 | +1013x | +
+ x_se <- stats::sd(x) / sqrt(n)+ |
+ ||
| 171 | +1013x | +
+ ttest <- (x_mean - test_mean) / x_se+ |
+ ||
| 172 | +1013x | +
+ pv <- c(p_value = 2 * stats::pt(-abs(ttest), df = n - 1))+ |
+ ||
| 173 |
} |
|||
| 163 | +174 | ++ | + + | +|
| 175 | +1153x | +
+ return(pv)+ |
+ ||
| 176 |
} |
|||
| 164 | +177 | |||
| 165 | +178 |
- #' Control function for risk difference column+ #' Proportion difference and confidence interval |
||
| 166 | +179 |
#' |
||
| 167 | +180 |
#' @description `r lifecycle::badge("stable")`
|
||
| 168 | +181 |
#' |
||
| 169 | +182 |
- #' Sets a list of parameters to use when generating a risk (proportion) difference column. Used as input to the+ #' Function for calculating the proportion (or risk) difference and confidence interval between arm |
||
| 170 | +183 |
- #' `riskdiff` parameter of [tabulate_rsp_subgroups()] and [tabulate_survival_subgroups()].+ #' X (reference group) and arm Y. Risk difference is calculated by subtracting cumulative incidence |
||
| 171 | +184 | ++ |
+ #' in arm Y from cumulative incidence in arm X.+ |
+ |
| 185 |
#' |
|||
| 172 | +186 |
- #' @inheritParams add_riskdiff+ #' @inheritParams argument_convention |
||
| 173 | +187 |
- #' @param format (`string` or `function`)\cr the format label (string) or formatting function to apply to the risk+ #' @param x (`list` of `integer`)\cr list of number of occurrences in arm X (reference group). |
||
| 174 | +188 |
- #' difference statistic. See the `3d` string options in [formatters::list_valid_format_labels()] for possible format+ #' @param y (`list` of `integer`)\cr list of number of occurrences in arm Y. Must be of equal length to `x`. |
||
| 175 | +189 |
- #' strings. Defaults to `"xx.x (xx.x - xx.x)"`.+ #' @param N_x (`numeric(1)`)\cr total number of records in arm X. |
||
| 176 | +190 | ++ |
+ #' @param N_y (`numeric(1)`)\cr total number of records in arm Y.+ |
+ |
| 191 | ++ |
+ #' @param list_names (`character`)\cr names of each variable/level corresponding to pair of proportions in+ |
+ ||
| 192 | ++ |
+ #' `x` and `y`. Must be of equal length to `x` and `y`.+ |
+ ||
| 193 | ++ |
+ #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`.+ |
+ ||
| 194 |
#' |
|||
| 177 | +195 |
- #' @return A `list` of items with names corresponding to the arguments.+ #' @return List of proportion differences and CIs corresponding to each pair of number of occurrences in `x` and |
||
| 178 | +196 | ++ |
+ #' `y`. Each list element consists of 3 statistics: proportion difference, CI lower bound, and CI upper bound.+ |
+ |
| 197 |
#' |
|||
| 179 | +198 |
- #' @seealso [add_riskdiff()], [tabulate_rsp_subgroups()], and [tabulate_survival_subgroups()].+ #' @seealso Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()] |
||
| 180 | +199 | ++ |
+ #' with `riskdiff` argument is set to `TRUE` in subsequent analyze functions, adds a column containing+ |
+ |
| 200 | ++ |
+ #' proportion (risk) difference to an `rtables` layout.+ |
+ ||
| 201 |
#' |
|||
| 181 | +202 |
#' @examples |
||
| 182 | +203 |
- #' control_riskdiff()+ #' stat_propdiff_ci( |
||
| 183 | +204 |
- #' control_riskdiff(arm_x = "ARM A", arm_y = "ARM B")+ #' x = list(0.375), y = list(0.01), N_x = 5, N_y = 5, list_names = "x", conf_level = 0.9 |
||
| 184 | +205 | ++ |
+ #' )+ |
+ |
| 206 |
#' |
|||
| 185 | +207 | ++ |
+ #' stat_propdiff_ci(+ |
+ |
| 208 | ++ |
+ #' x = list(0.5, 0.75, 1), y = list(0.25, 0.05, 0.5), N_x = 10, N_y = 20, pct = FALSE+ |
+ ||
| 209 | ++ |
+ #' )+ |
+ ||
| 210 | ++ |
+ #'+ |
+ ||
| 211 |
#' @export |
|||
| 186 | +212 |
- control_riskdiff <- function(arm_x = NULL,+ stat_propdiff_ci <- function(x, |
||
| 187 | +213 |
- arm_y = NULL,+ y, |
||
| 188 | +214 |
- format = "xx.x (xx.x - xx.x)",+ N_x, # nolint |
||
| 189 | +215 |
- col_label = "Risk Difference (%) (95% CI)",+ N_y, # nolint |
||
| 190 | +216 | ++ |
+ list_names = NULL,+ |
+ |
| 217 | ++ |
+ conf_level = 0.95,+ |
+ ||
| 218 |
pct = TRUE) {
|
|||
| 191 | -2x | +219 | +51x |
- checkmate::assert_character(arm_x, len = 1, null.ok = TRUE)+ checkmate::assert_list(x, types = "numeric") |
| 192 | -2x | +220 | +51x |
- checkmate::assert_character(arm_y, min.len = 1, null.ok = TRUE)+ checkmate::assert_list(y, types = "numeric", len = length(x)) |
| 193 | -2x | +221 | +51x |
- checkmate::assert_character(format, len = 1)+ checkmate::assert_character(list_names, len = length(x), null.ok = TRUE) |
| 194 | -2x | +222 | +51x |
- checkmate::assert_character(col_label)+ rd_list <- lapply(seq_along(x), function(i) {
|
| 195 | -2x | +223 | +134x |
- checkmate::assert_flag(pct)+ p_x <- x[[i]] / N_x+ |
+
| 224 | +134x | +
+ p_y <- y[[i]] / N_y+ |
+ ||
| 225 | +134x | +
+ rd_ci <- p_x - p_y + c(-1, 1) * stats::qnorm((1 + conf_level) / 2) *+ |
+ ||
| 226 | +134x | +
+ sqrt(p_x * (1 - p_x) / N_x + p_y * (1 - p_y) / N_y)+ |
+ ||
| 227 | +134x | +
+ c(p_x - p_y, rd_ci) * ifelse(pct, 100, 1) |
||
| 196 | +228 |
-
+ }) |
||
| 197 | -2x | +229 | +51x |
- list(arm_x = arm_x, arm_y = arm_y, format = format, col_label = col_label, pct = pct)+ names(rd_list) <- list_names+ |
+
| 230 | +51x | +
+ rd_list |
||
| 198 | +231 |
}@@ -91012,14 +93865,14 @@ tern coverage - 95.59% |
| 1 |
- #' Compare variables between groups+ #' Helper functions for Cox proportional hazards regression |
|||
| 5 |
- #' The analyze function [compare_vars()] creates a layout element to summarize and compare one or more variables, using+ #' Helper functions used in [fit_coxreg_univar()] and [fit_coxreg_multivar()]. |
|||
| 6 |
- #' the S3 generic function [s_summary()] to calculate a list of summary statistics. A list of all available statistics+ #' |
|||
| 7 |
- #' for numeric variables can be viewed by running `get_stats("analyze_vars_numeric", add_pval = TRUE)` and for
+ #' @inheritParams argument_convention |
|||
| 8 |
- #' non-numeric variables by running `get_stats("analyze_vars_counts", add_pval = TRUE)`. Use the `.stats` parameter to
+ #' @inheritParams h_coxreg_univar_extract |
|||
| 9 |
- #' specify the statistics to include in your output summary table.+ #' @inheritParams cox_regression_inter |
|||
| 10 |
- #'+ #' @inheritParams control_coxreg |
|||
| 11 |
- #' Prior to using this function in your table layout you must use [rtables::split_cols_by()] to create a column+ #' |
|||
| 12 |
- #' split on the variable to be used in comparisons, and specify a reference group via the `ref_group` parameter.+ #' @seealso [cox_regression] |
|||
| 13 |
- #' Comparisons can be performed for each group (column) against the specified reference group by including the p-value+ #' |
|||
| 14 |
- #' statistic.+ #' @name h_cox_regression |
|||
| 15 |
- #'+ NULL |
|||
| 16 |
- #' @inheritParams argument_convention+ |
|||
| 17 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' @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 |
- #' Options for numeric variables are: ``r shQuote(get_stats("analyze_vars_numeric", add_pval = TRUE))``
+ #' |
|||
| 20 |
- #'+ #' @return |
|||
| 21 |
- #' Options for non-numeric variables are: ``r shQuote(get_stats("analyze_vars_counts", add_pval = TRUE))``
+ #' * `h_coxreg_univar_formulas()` returns a `character` vector coercible into formulas (e.g [stats::as.formula()]). |
|||
| 23 |
- #' @note+ #' @examples |
|||
| 24 |
- #' * For factor variables, `denom` for factor proportions can only be `n` since the purpose is to compare proportions+ #' # `h_coxreg_univar_formulas` |
|||
| 25 |
- #' between columns, therefore a row-based proportion would not make sense. Proportion based on `N_col` would+ #' |
|||
| 26 |
- #' be difficult since we use counts for the chi-squared test statistic, therefore missing values should be accounted+ #' ## Simple formulas. |
|||
| 27 |
- #' for as explicit factor levels.+ #' h_coxreg_univar_formulas( |
|||
| 28 |
- #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values+ #' variables = list( |
|||
| 29 |
- #' set `na.rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit+ #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y")
|
|||
| 30 |
- #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the+ #' ) |
|||
| 31 |
- #' default `na_level` (`"<Missing>"`) will also be excluded when `na.rm` is set to `TRUE`.+ #' ) |
|||
| 32 |
- #' * For character variables, automatic conversion to factor does not guarantee that the table+ #' |
|||
| 33 |
- #' will be generated correctly. In particular for sparse tables this very likely can fail.+ #' ## Addition of an optional strata. |
|||
| 34 |
- #' Therefore it is always better to manually convert character variables to factors during pre-processing.+ #' h_coxreg_univar_formulas( |
|||
| 35 |
- #' * For `compare_vars()`, the column split must define a reference group via `ref_group` so that the comparison+ #' variables = list( |
|||
| 36 |
- #' is well defined.+ #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
|
|||
| 37 |
- #'+ #' strata = "SITE" |
|||
| 38 |
- #' @seealso [s_summary()] which is used internally to compute a summary within `s_compare()`, and [a_summary()]+ #' ) |
|||
| 39 |
- #' which is used (with `compare = TRUE`) as the analysis function for `compare_vars()`.+ #' ) |
|||
| 41 |
- #' @name compare_variables+ #' ## Inclusion of the interaction term. |
|||
| 42 |
- #' @include analyze_variables.R+ #' h_coxreg_univar_formulas( |
|||
| 43 |
- #' @order 1+ #' variables = list( |
|||
| 44 |
- NULL+ #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
|
|||
| 45 |
-
+ #' strata = "SITE" |
|||
| 46 |
- #' @describeIn compare_variables S3 generic function to produce a comparison summary.+ #' ), |
|||
| 47 |
- #'+ #' interaction = TRUE |
|||
| 48 |
- #' @return+ #' ) |
|||
| 49 |
- #' * `s_compare()` returns output of [s_summary()] and comparisons versus the reference group in the form of p-values.+ #' |
|||
| 50 |
- #'+ #' ## Only covariates fitted in separate models. |
|||
| 51 |
- #' @export+ #' h_coxreg_univar_formulas( |
|||
| 52 |
- s_compare <- function(x,+ #' variables = list( |
|||
| 53 |
- ...) {
+ #' time = "time", event = "status", covariates = c("X", "y")
|
|||
| 54 | -9x | +
- UseMethod("s_compare", x)
+ #' ) |
||
| 55 |
- }+ #' ) |
|||
| 56 |
-
+ #' |
|||
| 57 |
- #' @describeIn compare_variables Method for `numeric` class. This uses the standard t-test+ #' @export |
|||
| 58 |
- #' to calculate the p-value.+ h_coxreg_univar_formulas <- function(variables, |
|||
| 59 |
- #'+ interaction = FALSE) {
|
|||
| 60 | -+ | 50x |
- #' @method s_compare numeric+ checkmate::assert_list(variables, names = "named") |
|
| 61 | -+ | 50x |
- #'+ has_arm <- "arm" %in% names(variables) |
|
| 62 | -+ | 50x |
- #' @examples+ arm_name <- if (has_arm) "arm" else NULL |
|
| 63 |
- #' # `s_compare.numeric`+ |
|||
| 64 | -+ | 50x |
- #'+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
|
| 65 |
- #' ## Usual case where both this and the reference group vector have more than 1 value.+ |
|||
| 66 | -+ | 50x |
- #' s_compare(rnorm(10, 5, 1), .ref_group = rnorm(5, -5, 1), .in_ref_col = FALSE)+ checkmate::assert_flag(interaction) |
|
| 67 |
- #'+ |
|||
| 68 | -+ | 50x |
- #' ## If one group has not more than 1 value, then p-value is not calculated.+ if (!has_arm || is.null(variables$covariates)) {
|
|
| 69 | -+ | 10x |
- #' s_compare(rnorm(10, 5, 1), .ref_group = 1, .in_ref_col = FALSE)+ checkmate::assert_false(interaction) |
|
| 70 |
- #'+ } |
|||
| 71 |
- #' ## Empty numeric does not fail, it returns NA-filled items and no p-value.+ |
|||
| 72 | -+ | 48x |
- #' s_compare(numeric(), .ref_group = numeric(), .in_ref_col = FALSE)+ assert_list_of_variables(variables[c(arm_name, "event", "time")]) |
|
| 73 |
- #'+ |
|||
| 74 | -+ | 48x |
- #' @export+ if (!is.null(variables$covariates)) {
|
|
| 75 | -+ | 47x |
- s_compare.numeric <- function(x, ...) {
+ forms <- paste0( |
|
| 76 | -2x | +47x |
- s_summary.numeric(x = x, compare_with_ref_group = TRUE, ...)+ "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
|
|
| 77 | -+ | 47x |
- }+ ifelse(has_arm, variables$arm, "1"), |
|
| 78 | -+ | 47x |
-
+ ifelse(interaction, " * ", " + "), |
|
| 79 | -+ | 47x |
- #' @describeIn compare_variables Method for `factor` class. This uses the chi-squared test+ variables$covariates, |
|
| 80 | -+ | 47x |
- #' to calculate the p-value.+ ifelse( |
|
| 81 | -+ | 47x |
- #'+ !is.null(variables$strata), |
|
| 82 | -+ | 47x |
- #' @method s_compare factor+ paste0(" + strata(", paste0(variables$strata, collapse = ", "), ")"),
|
|
| 83 |
- #'+ "" |
|||
| 84 |
- #' @examples+ ) |
|||
| 85 |
- #' # `s_compare.factor`+ ) |
|||
| 86 |
- #'+ } else {
|
|||
| 87 | -+ | 1x |
- #' ## Basic usage:+ forms <- NULL |
|
| 88 |
- #' x <- factor(c("a", "a", "b", "c", "a"))
+ } |
|||
| 89 | -+ | 48x |
- #' y <- factor(c("a", "b", "c"))
+ nams <- variables$covariates |
|
| 90 | -+ | 48x |
- #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE)+ if (has_arm) {
|
|
| 91 | -+ | 41x |
- #'+ ref <- paste0( |
|
| 92 | -+ | 41x |
- #' ## Management of NA values.+ "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
|
|
| 93 | -+ | 41x |
- #' x <- explicit_na(factor(c("a", "a", "b", "c", "a", NA, NA)))
+ variables$arm, |
|
| 94 | -+ | 41x |
- #' y <- explicit_na(factor(c("a", "b", "c", NA)))
+ ifelse( |
|
| 95 | -+ | 41x |
- #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na_rm = TRUE)+ !is.null(variables$strata), |
|
| 96 | -+ | 41x |
- #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na_rm = FALSE)+ paste0( |
|
| 97 | -+ | 41x |
- #'+ " + strata(", paste0(variables$strata, collapse = ", "), ")"
|
|
| 98 |
- #' @export+ ), |
|||
| 99 |
- s_compare.factor <- function(x, ...) {
+ "" |
|||
| 100 | -3x | +
- s_summary.factor(+ ) |
||
| 101 | -3x | +
- x = x,+ ) |
||
| 102 | -3x | +41x |
- compare_with_ref_group = TRUE,+ forms <- c(ref, forms) |
|
| 103 | -+ | 41x |
- ...+ nams <- c("ref", nams)
|
|
| 104 |
- )+ } |
|||
| 105 | -+ | 48x |
- }+ stats::setNames(forms, nams) |
|
| 106 |
-
+ } |
|||
| 107 |
- #' @describeIn compare_variables Method for `character` class. This makes an automatic+ |
|||
| 108 |
- #' conversion to `factor` (with a warning) and then forwards to the method for factors.+ #' @describeIn h_cox_regression Helper for multivariate Cox regression formula. Creates a formulas |
|||
| 109 |
- #'+ #' string. It is used internally by [fit_coxreg_multivar()] for the comparison of multivariate Cox |
|||
| 110 |
- #' @method s_compare character+ #' regression models. Interactions will not be included in multivariate Cox regression model. |
|||
| 112 |
- #' @examples+ #' @return |
|||
| 113 |
- #' # `s_compare.character`+ #' * `h_coxreg_multivar_formula()` returns a `string` coercible into a formula (e.g [stats::as.formula()]). |
|||
| 115 |
- #' ## Basic usage:+ #' @examples |
|||
| 116 |
- #' x <- c("a", "a", "b", "c", "a")
+ #' # `h_coxreg_multivar_formula` |
|||
| 117 |
- #' y <- c("a", "b", "c")
+ #' |
|||
| 118 |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, .var = "x", verbose = FALSE)+ #' h_coxreg_multivar_formula( |
|||
| 119 |
- #'+ #' variables = list( |
|||
| 120 |
- #' ## Note that missing values handling can make a large difference:+ #' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE")
|
|||
| 121 |
- #' x <- c("a", "a", "b", "c", "a", NA)
+ #' ) |
|||
| 122 |
- #' y <- c("a", "b", "c", rep(NA, 20))
+ #' ) |
|||
| 123 |
- #' s_compare(x,+ #' |
|||
| 124 |
- #' .ref_group = y, .in_ref_col = FALSE,+ #' # Addition of an optional strata. |
|||
| 125 |
- #' .var = "x", verbose = FALSE+ #' h_coxreg_multivar_formula( |
|||
| 126 |
- #' )+ #' variables = list( |
|||
| 127 |
- #' s_compare(x,+ #' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE"),
|
|||
| 128 |
- #' .ref_group = y, .in_ref_col = FALSE, .var = "x",+ #' strata = "SITE" |
|||
| 129 |
- #' na.rm = FALSE, verbose = FALSE+ #' ) |
|||
| 132 |
- #' @export+ #' # Example without treatment arm. |
|||
| 133 |
- s_compare.character <- function(x, ...) {
+ #' h_coxreg_multivar_formula( |
|||
| 134 | -1x | +
- s_summary.character(+ #' variables = list( |
||
| 135 | -1x | +
- x,+ #' time = "AVAL", event = "event", covariates = c("RACE", "AGE"),
|
||
| 136 | -1x | +
- compare_with_ref_group = TRUE,+ #' strata = "SITE" |
||
| 137 |
- ...+ #' ) |
|||
| 138 |
- )+ #' ) |
|||
| 139 |
- }+ #' |
|||
| 140 |
-
+ #' @export |
|||
| 141 |
- #' @describeIn compare_variables Method for `logical` class. A chi-squared test+ h_coxreg_multivar_formula <- function(variables) {
|
|||
| 142 | -+ | 89x |
- #' is used. If missing values are not removed, then they are counted as `FALSE`.+ checkmate::assert_list(variables, names = "named") |
|
| 143 | -+ | 89x |
- #'+ has_arm <- "arm" %in% names(variables) |
|
| 144 | -+ | 89x |
- #' @method s_compare logical+ arm_name <- if (has_arm) "arm" else NULL |
|
| 145 |
- #'+ |
|||
| 146 | -+ | 89x |
- #' @examples+ checkmate::assert_character(variables$covariates, null.ok = TRUE) |
|
| 147 |
- #' # `s_compare.logical`+ |
|||
| 148 | -+ | 89x |
- #'+ assert_list_of_variables(variables[c(arm_name, "event", "time")]) |
|
| 149 |
- #' ## Basic usage:+ |
|||
| 150 | -+ | 89x |
- #' x <- c(TRUE, FALSE, TRUE, TRUE)+ y <- paste0( |
|
| 151 | -+ | 89x |
- #' y <- c(FALSE, FALSE, TRUE)+ "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
|
|
| 152 | -+ | 89x |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE)+ ifelse(has_arm, variables$arm, "1") |
|
| 153 |
- #'+ ) |
|||
| 154 | -+ | 89x |
- #' ## Management of NA values.+ if (length(variables$covariates) > 0) {
|
|
| 155 | -+ | 26x |
- #' x <- c(NA, TRUE, FALSE)+ y <- paste(y, paste(variables$covariates, collapse = " + "), sep = " + ") |
|
| 156 |
- #' y <- c(NA, NA, NA, NA, FALSE)+ } |
|||
| 157 | -+ | 89x |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na_rm = TRUE)+ if (!is.null(variables$strata)) {
|
|
| 158 | -+ | 5x |
- #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na_rm = FALSE)+ y <- paste0(y, " + strata(", paste0(variables$strata, collapse = ", "), ")")
|
|
| 159 |
- #'+ } |
|||
| 160 | -+ | 89x |
- #' @export+ y |
|
| 161 |
- s_compare.logical <- function(x, ...) {
+ } |
|||
| 162 | -3x | +
- s_summary.logical(+ |
||
| 163 | -3x | +
- x = x,+ #' @describeIn h_cox_regression Utility function to help tabulate the result of |
||
| 164 | -3x | +
- compare_with_ref_group = TRUE,+ #' a univariate Cox regression model. |
||
| 165 |
- ...+ #' |
|||
| 166 |
- )+ #' @param effect (`string`)\cr the treatment variable. |
|||
| 167 |
- }+ #' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()]. |
|||
| 168 |
-
+ #' |
|||
| 169 |
- #' @describeIn compare_variables Layout-creating function which can take statistics function arguments+ #' @return |
|||
| 170 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' * `h_coxreg_univar_extract()` returns a `data.frame` with variables `effect`, `term`, `term_label`, `level`, |
|||
| 171 |
- #'+ #' `n`, `hr`, `lcl`, `ucl`, and `pval`. |
|||
| 172 |
- #' @param ... additional arguments passed to `s_compare()`, including:+ #' |
|||
| 173 |
- #' * `denom`: (`string`) choice of denominator. Options are `c("n", "N_col", "N_row")`. For factor variables, can
+ #' @examples |
|||
| 174 |
- #' only be `"n"` (number of values in this row and column intersection).+ #' library(survival) |
|||
| 175 |
- #' * `.N_row`: (`numeric(1)`) Row-wise N (row group count) for the group of observations being analyzed (i.e. with no+ #' |
|||
| 176 |
- #' column-based subsetting).+ #' dta_simple <- data.frame( |
|||
| 177 |
- #' * `.N_col`: (`numeric(1)`) Column-wise N (column count) for the full column being tabulated within.+ #' time = c(5, 5, 10, 10, 5, 5, 10, 10), |
|||
| 178 |
- #' * `verbose`: (`flag`) Whether additional warnings and messages should be printed. Mainly used to print out+ #' status = c(0, 0, 1, 0, 0, 1, 1, 1), |
|||
| 179 |
- #' information about factor casting. Defaults to `TRUE`. Used for `character`/`factor` variables only.+ #' armcd = factor(LETTERS[c(1, 1, 1, 1, 2, 2, 2, 2)], levels = c("A", "B")),
|
|||
| 180 |
- #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector+ #' var1 = c(45, 55, 65, 75, 55, 65, 85, 75), |
|||
| 181 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ #' var2 = c("F", "M", "F", "M", "F", "M", "F", "U")
|
|||
| 182 |
- #' for that statistic's row label.+ #' ) |
|||
| 183 |
- #'+ #' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple) |
|||
| 184 |
- #' @return+ #' result <- h_coxreg_univar_extract( |
|||
| 185 |
- #' * `compare_vars()` returns a layout object suitable for passing to further layouting functions,+ #' effect = "armcd", covar = "armcd", mod = mod, data = dta_simple |
|||
| 186 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' ) |
|||
| 187 |
- #' the statistics from `s_compare()` to the table layout.+ #' result |
|||
| 189 |
- #' @examples+ #' @export |
|||
| 190 |
- #' # `compare_vars()` in `rtables` pipelines+ h_coxreg_univar_extract <- function(effect, |
|||
| 191 |
- #'+ covar, |
|||
| 192 |
- #' ## Default output within a `rtables` pipeline.+ data, |
|||
| 193 |
- #' lyt <- basic_table() %>%+ mod, |
|||
| 194 |
- #' split_cols_by("ARMCD", ref_group = "ARM B") %>%
+ control = control_coxreg()) {
|
|||
| 195 | +66x | +
+ checkmate::assert_string(covar)+ |
+ ||
| 196 | +66x | +
+ checkmate::assert_string(effect)+ |
+ ||
| 197 | +66x | +
+ checkmate::assert_class(mod, "coxph")+ |
+ ||
| 198 | +66x | +
+ test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]+ |
+ ||
| 199 |
- #' compare_vars(c("AGE", "SEX"))
+
+ |
+ |||
| 200 | +66x | +
+ mod_aov <- muffled_car_anova(mod, test_statistic)+ |
+ ||
| 201 | +66x | +
+ msum <- summary(mod, conf.int = control$conf_level)+ |
+ ||
| 202 | +66x | +
+ sum_cox <- broom::tidy(msum) |
||
| 196 | +203 |
- #' build_table(lyt, tern_ex_adsl)+ |
||
| 197 | +204 |
- #'+ # Combine results together.+ |
+ ||
| 205 | +66x | +
+ effect_aov <- mod_aov[effect, , drop = TRUE]+ |
+ ||
| 206 | +66x | +
+ pval <- effect_aov[[grep(pattern = "Pr", x = names(effect_aov)), drop = TRUE]]+ |
+ ||
| 207 | +66x | +
+ sum_main <- sum_cox[grepl(effect, sum_cox$level), ] |
||
| 198 | +208 |
- #' ## Select and format statistics output.+ + |
+ ||
| 209 | +66x | +
+ term_label <- if (effect == covar) {
+ |
+ ||
| 210 | +34x | +
+ paste0(+ |
+ ||
| 211 | +34x | +
+ levels(data[[covar]])[2],+ |
+ ||
| 212 | +34x | +
+ " vs control (",
+ |
+ ||
| 213 | +34x | +
+ levels(data[[covar]])[1], |
||
| 199 | +214 |
- #' lyt <- basic_table() %>%+ ")" |
||
| 200 | +215 |
- #' split_cols_by("ARMCD", ref_group = "ARM C") %>%
+ ) |
||
| 201 | +216 |
- #' compare_vars(+ } else {
+ |
+ ||
| 217 | +32x | +
+ unname(labels_or_names(data[covar])) |
||
| 202 | +218 |
- #' vars = "AGE",+ }+ |
+ ||
| 219 | +66x | +
+ data.frame(+ |
+ ||
| 220 | +66x | +
+ effect = ifelse(covar == effect, "Treatment:", "Covariate:"),+ |
+ ||
| 221 | +66x | +
+ term = covar,+ |
+ ||
| 222 | +66x | +
+ term_label = term_label,+ |
+ ||
| 223 | +66x | +
+ level = levels(data[[effect]])[2],+ |
+ ||
| 224 | +66x | +
+ n = mod[["n"]],+ |
+ ||
| 225 | +66x | +
+ hr = unname(sum_main["exp(coef)"]),+ |
+ ||
| 226 | +66x | +
+ lcl = unname(sum_main[grep("lower", names(sum_main))]),
+ |
+ ||
| 227 | +66x | +
+ ucl = unname(sum_main[grep("upper", names(sum_main))]),
+ |
+ ||
| 228 | +66x | +
+ pval = pval,+ |
+ ||
| 229 | +66x | +
+ stringsAsFactors = FALSE |
||
| 203 | +230 |
- #' .stats = c("mean_sd", "pval"),
+ ) |
||
| 204 | +231 |
- #' .formats = c(mean_sd = "xx.x, xx.x"),+ } |
||
| 205 | +232 |
- #' .labels = c(mean_sd = "Mean, SD")+ |
||
| 206 | +233 |
- #' )+ #' @describeIn h_cox_regression Tabulation of multivariate Cox regressions. Utility function to help |
||
| 207 | +234 |
- #' build_table(lyt, df = tern_ex_adsl)+ #' tabulate the result of a multivariate Cox regression model for a treatment/covariate variable. |
||
| 208 | +235 |
#' |
||
| 209 | +236 |
- #' @export+ #' @return |
||
| 210 | +237 |
- #' @order 2+ #' * `h_coxreg_multivar_extract()` returns a `data.frame` with variables `pval`, `hr`, `lcl`, `ucl`, `level`, |
||
| 211 | +238 |
- compare_vars <- function(lyt,+ #' `n`, `term`, and `term_label`. |
||
| 212 | +239 |
- vars,+ #' |
||
| 213 | +240 |
- var_labels = vars,+ #' @examples |
||
| 214 | +241 |
- na_str = default_na_str(),+ #' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple) |
||
| 215 | +242 |
- nested = TRUE,+ #' result <- h_coxreg_multivar_extract( |
||
| 216 | +243 |
- ...,+ #' var = "var1", mod = mod, data = dta_simple |
||
| 217 | +244 |
- na_rm = TRUE,+ #' ) |
||
| 218 | +245 |
- show_labels = "default",+ #' result |
||
| 219 | +246 |
- table_names = vars,+ #' |
||
| 220 | +247 |
- section_div = NA_character_,+ #' @export |
||
| 221 | +248 |
- .stats = c("n", "mean_sd", "count_fraction", "pval"),
+ h_coxreg_multivar_extract <- function(var, |
||
| 222 | +249 |
- .stat_names_in = NULL,+ data, |
||
| 223 | +250 |
- .formats = NULL,+ mod, |
||
| 224 | +251 |
- .labels = NULL,+ control = control_coxreg()) {
+ |
+ ||
| 252 | +132x | +
+ test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]+ |
+ ||
| 253 | +132x | +
+ mod_aov <- muffled_car_anova(mod, test_statistic) |
||
| 225 | +254 |
- .indent_mods = NULL) {
+
|
||
| 226 | -4x | +255 | +132x |
- analyze_vars(+ msum <- summary(mod, conf.int = control$conf_level) |
| 227 | -4x | +256 | +132x |
- lyt = lyt,+ sum_anova <- broom::tidy(mod_aov) |
| 228 | -4x | +257 | +132x |
- compare_with_ref_group = TRUE,+ sum_cox <- broom::tidy(msum)+ |
+
| 258 | ++ | + | ||
| 229 | -4x | +259 | +132x |
- vars = vars,+ ret_anova <- sum_anova[sum_anova$term == var, c("term", "p.value")]
|
| 230 | -4x | +260 | +132x |
- var_labels = var_labels,+ names(ret_anova)[2] <- "pval" |
| 231 | -4x | +261 | +132x |
- na_str = na_str,+ if (is.factor(data[[var]])) {
|
| 232 | -4x | +262 | +53x |
- nested = nested,+ ret_cox <- sum_cox[startsWith(prefix = var, x = sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")]+ |
+
| 263 | ++ |
+ } else {
|
||
| 233 | -4x | +264 | +79x |
- na_rm = na_rm,+ ret_cox <- sum_cox[(var == sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")]+ |
+
| 265 | ++ |
+ } |
||
| 234 | -4x | +266 | +132x |
- show_labels = show_labels,+ names(ret_cox)[1:4] <- c("pval", "hr", "lcl", "ucl")
|
| 235 | -4x | +267 | +132x |
- table_names = table_names,+ varlab <- unname(labels_or_names(data[var])) |
| 236 | -4x | +268 | +132x |
- section_div = section_div,+ ret_cox$term <- varlab+ |
+
| 269 | ++ | + | ||
| 237 | -4x | +270 | +132x |
- .stats = .stats,+ if (is.numeric(data[[var]])) {
|
| 238 | -4x | +271 | +79x |
- .stat_names_in = .stat_names_in,+ ret <- ret_cox |
| 239 | -4x | +272 | +79x |
- .formats = .formats,+ ret$term_label <- ret$term |
| 240 | -4x | +273 | +53x |
- .labels = .labels,+ } else if (length(levels(data[[var]])) <= 2) {
|
| 241 | -4x | +274 | +34x |
- .indent_mods = .indent_mods,+ ret_anova$pval <- NA+ |
+
| 275 | +34x | +
+ ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")")+ |
+ ||
| 276 | +34x | +
+ ret_cox$level <- gsub(var, "", ret_cox$level)+ |
+ ||
| 277 | +34x | +
+ ret_cox$term_label <- ret_cox$level+ |
+ ||
| 278 | +34x | +
+ ret <- dplyr::bind_rows(ret_anova, ret_cox) |
||
| 242 | +279 |
- ...+ } else {
+ |
+ ||
| 280 | +19x | +
+ ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")")+ |
+ ||
| 281 | +19x | +
+ ret_cox$level <- gsub(var, "", ret_cox$level)+ |
+ ||
| 282 | +19x | +
+ ret_cox$term_label <- ret_cox$level+ |
+ ||
| 283 | +19x | +
+ ret <- dplyr::bind_rows(ret_anova, ret_cox) |
||
| 243 | +284 |
- )+ } |
||
| 244 | +285 | ++ | + + | +|
| 286 | +132x | +
+ as.data.frame(ret)+ |
+ ||
| 287 |
}@@ -92726,14 +95880,14 @@ tern coverage - 95.59% |
| 1 |
- #' Tabulate biomarker effects on binary response by subgroup+ #' Helper functions for tabulating binary response by subgroup |
||
| 5 |
- #' The [tabulate_rsp_biomarkers()] function creates a layout element to tabulate the estimated biomarker effects on a+ #' Helper functions that tabulate in a data frame statistics such as response rate |
||
| 6 |
- #' binary response endpoint across subgroups, returning statistics including response rate and odds ratio for each+ #' and odds ratio for population subgroups. |
||
| 7 |
- #' population subgroup. The table is created from `df`, a list of data frames returned by [extract_rsp_biomarkers()],+ #' |
||
| 8 |
- #' with the statistics to include specified via the `vars` parameter.+ #' @inheritParams argument_convention |
||
| 9 |
- #'+ #' @inheritParams response_subgroups |
||
| 10 |
- #' A forest plot can be created from the resulting table using the [g_forest()] function.+ #' @param arm (`factor`)\cr the treatment group variable. |
||
| 12 |
- #' @inheritParams argument_convention+ #' @details Main functionality is to prepare data for use in a layout-creating function. |
||
| 13 |
- #' @param df (`data.frame`)\cr containing all analysis variables, as returned by+ #' |
||
| 14 |
- #' [extract_rsp_biomarkers()].+ #' @examples |
||
| 15 |
- #' @param vars (`character`)\cr the names of statistics to be reported among:+ #' library(dplyr) |
||
| 16 |
- #' * `n_tot`: Total number of patients per group.+ #' library(forcats) |
||
| 17 |
- #' * `n_rsp`: Total number of responses per group.+ #' |
||
| 18 |
- #' * `prop`: Total response proportion per group.+ #' adrs <- tern_ex_adrs |
||
| 19 |
- #' * `or`: Odds ratio.+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 20 |
- #' * `ci`: Confidence interval of odds ratio.+ #' |
||
| 21 |
- #' * `pval`: p-value of the effect.+ #' adrs_f <- adrs %>% |
||
| 22 |
- #' Note, the statistics `n_tot`, `or` and `ci` are required.+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 23 |
- #'+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
|
||
| 24 |
- #' @return An `rtables` table summarizing biomarker effects on binary response by subgroup.+ #' droplevels() %>% |
||
| 25 |
- #'+ #' mutate( |
||
| 26 |
- #' @details These functions create a layout starting from a data frame which contains+ #' # Reorder levels of factor to make the placebo group the reference arm. |
||
| 27 |
- #' the required statistics. The tables are then typically used as input for forest plots.+ #' ARM = fct_relevel(ARM, "B: Placebo"), |
||
| 28 |
- #'+ #' rsp = AVALC == "CR" |
||
| 29 |
- #' @note In contrast to [tabulate_rsp_subgroups()] this tabulation function does+ #' ) |
||
| 30 |
- #' not start from an input layout `lyt`. This is because internally the table is+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
||
| 31 |
- #' created by combining multiple subtables.+ #' |
||
| 32 |
- #'+ #' @name h_response_subgroups |
||
| 33 |
- #' @seealso [h_tab_rsp_one_biomarker()] which is used internally, [extract_rsp_biomarkers()].+ NULL |
||
| 34 |
- #'+ |
||
| 35 |
- #' @examples+ #' @describeIn h_response_subgroups Helper to prepare a data frame of binary responses by arm. |
||
| 36 |
- #' library(dplyr)+ #' |
||
| 37 |
- #' library(forcats)+ #' @return |
||
| 38 |
- #'+ #' * `h_proportion_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, and `prop`. |
||
| 39 |
- #' adrs <- tern_ex_adrs+ #' |
||
| 40 |
- #' adrs_labels <- formatters::var_labels(adrs)+ #' @examples |
||
| 41 |
- #'+ #' h_proportion_df( |
||
| 42 |
- #' adrs_f <- adrs %>%+ #' c(TRUE, FALSE, FALSE), |
||
| 43 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' arm = factor(c("A", "A", "B"), levels = c("A", "B"))
|
||
| 44 |
- #' mutate(rsp = AVALC == "CR")+ #' ) |
||
| 45 |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ #' |
||
| 46 |
- #'+ #' @export |
||
| 47 |
- #' df <- extract_rsp_biomarkers(+ h_proportion_df <- function(rsp, arm) {
|
||
| 48 | -+ | 79x |
- #' variables = list(+ checkmate::assert_logical(rsp) |
| 49 | -+ | 78x |
- #' rsp = "rsp",+ assert_valid_factor(arm, len = length(rsp)) |
| 50 | -+ | 78x |
- #' biomarkers = c("BMRKR1", "AGE"),
+ non_missing_rsp <- !is.na(rsp) |
| 51 | -+ | 78x |
- #' covariates = "SEX",+ rsp <- rsp[non_missing_rsp] |
| 52 | -+ | 78x |
- #' subgroups = "BMRKR2"+ arm <- arm[non_missing_rsp] |
| 53 |
- #' ),+ |
||
| 54 | -+ | 78x |
- #' data = adrs_f+ lst_rsp <- split(rsp, arm) |
| 55 | -+ | 78x |
- #' )+ lst_results <- Map(function(x, arm) {
|
| 56 | -+ | 156x |
- #'+ if (length(x) > 0) {
|
| 57 | -+ | 154x |
- #' \donttest{
+ s_prop <- s_proportion(df = x) |
| 58 | -+ | 154x |
- #' ## Table with default columns.+ data.frame( |
| 59 | -+ | 154x |
- #' tabulate_rsp_biomarkers(df)+ arm = arm, |
| 60 | -+ | 154x |
- #'+ n = length(x), |
| 61 | -+ | 154x |
- #' ## Table with a manually chosen set of columns: leave out "pval", reorder.+ n_rsp = unname(s_prop$n_prop[1]), |
| 62 | -+ | 154x |
- #' tab <- tabulate_rsp_biomarkers(+ prop = unname(s_prop$n_prop[2]), |
| 63 | -+ | 154x |
- #' df = df,+ stringsAsFactors = FALSE |
| 64 |
- #' vars = c("n_rsp", "ci", "n_tot", "prop", "or")
+ ) |
||
| 65 |
- #' )+ } else {
|
||
| 66 | -+ | 2x |
- #'+ data.frame( |
| 67 | -+ | 2x |
- #' ## Finally produce the forest plot.+ arm = arm, |
| 68 | -+ | 2x |
- #' g_forest(tab, xlim = c(0.7, 1.4))+ n = 0L, |
| 69 | -+ | 2x |
- #' }+ n_rsp = NA, |
| 70 | -+ | 2x |
- #'+ prop = NA, |
| 71 | -+ | 2x |
- #' @export+ stringsAsFactors = FALSE |
| 72 |
- #' @name response_biomarkers_subgroups+ ) |
||
| 73 |
- tabulate_rsp_biomarkers <- function(df,+ } |
||
| 74 | -+ | 78x |
- vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
+ }, lst_rsp, names(lst_rsp)) |
| 75 |
- na_str = default_na_str(),+ |
||
| 76 | -+ | 78x |
- .indent_mods = 0L) {
+ df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE)) |
| 77 | -4x | +78x |
- checkmate::assert_data_frame(df)+ df$arm <- factor(df$arm, levels = levels(arm)) |
| 78 | -4x | +78x |
- checkmate::assert_character(df$biomarker)+ df |
| 79 | -4x | +
- checkmate::assert_character(df$biomarker_label)+ } |
|
| 80 | -4x | +
- checkmate::assert_subset(vars, get_stats("tabulate_rsp_biomarkers"))
+
|
|
| 81 |
-
+ #' @describeIn h_response_subgroups Summarizes proportion of binary responses by arm and across subgroups |
||
| 82 |
- # Create "ci" column from "lcl" and "ucl"+ #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and |
||
| 83 | -4x | +
- df$ci <- combine_vectors(df$lcl, df$ucl)+ #' requires elements `rsp`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies |
|
| 84 |
-
+ #' groupings for `subgroups` variables. |
||
| 85 | -4x | +
- df_subs <- split(df, f = df$biomarker)+ #' |
|
| 86 | -4x | +
- tabs <- lapply(df_subs, FUN = function(df_sub) {
+ #' @return |
|
| 87 | -7x | +
- tab_sub <- h_tab_rsp_one_biomarker(+ #' * `h_proportion_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`, |
|
| 88 | -7x | +
- df = df_sub,+ #' `var`, `var_label`, and `row_type`. |
|
| 89 | -7x | +
- vars = vars,+ #' |
|
| 90 | -7x | +
- na_str = na_str,+ #' @examples |
|
| 91 | -7x | +
- .indent_mods = .indent_mods+ #' h_proportion_subgroups_df( |
|
| 92 |
- )+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
||
| 93 |
- # Insert label row as first row in table.+ #' data = adrs_f |
||
| 94 | -7x | +
- label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1]+ #' ) |
|
| 95 | -7x | +
- tab_sub+ #' |
|
| 96 |
- })+ #' # Define groupings for BMRKR2 levels. |
||
| 97 | -4x | +
- result <- do.call(rbind, tabs)+ #' h_proportion_subgroups_df( |
|
| 98 |
-
+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
||
| 99 | -4x | +
- n_id <- grep("n_tot", vars)
+ #' data = adrs_f, |
|
| 100 | -4x | +
- or_id <- match("or", vars)
+ #' groups_lists = list( |
|
| 101 | -4x | +
- ci_id <- match("ci", vars)
+ #' BMRKR2 = list( |
|
| 102 | -4x | +
- structure(+ #' "low" = "LOW", |
|
| 103 | -4x | +
- result,+ #' "low/medium" = c("LOW", "MEDIUM"),
|
|
| 104 | -4x | +
- forest_header = paste0(c("Lower", "Higher"), "\nBetter"),
+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
|
| 105 | -4x | +
- col_x = or_id,+ #' ) |
|
| 106 | -4x | +
- col_ci = ci_id,+ #' ) |
|
| 107 | -4x | +
- col_symbol_size = n_id+ #' ) |
|
| 108 |
- )+ #' |
||
| 109 |
- }+ #' @export |
||
| 110 |
-
+ h_proportion_subgroups_df <- function(variables, |
||
| 111 |
- #' Prepare response data estimates for multiple biomarkers in a single data frame+ data, |
||
| 112 |
- #'+ groups_lists = list(), |
||
| 113 |
- #' @description `r lifecycle::badge("stable")`
+ label_all = "All Patients") {
|
||
| 114 | -+ | 17x |
- #'+ checkmate::assert_character(variables$rsp) |
| 115 | -+ | 17x |
- #' Prepares estimates for number of responses, patients and overall response rate,+ checkmate::assert_character(variables$arm) |
| 116 | -+ | 17x |
- #' as well as odds ratio estimates, confidence intervals and p-values,+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 117 | -+ | 17x |
- #' for multiple biomarkers across population subgroups in a single data frame.+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2) |
| 118 | -+ | 17x |
- #' `variables` corresponds to the names of variables found in `data`, passed as a+ assert_df_with_variables(data, variables) |
| 119 | -+ | 17x |
- #' named list and requires elements `rsp` and `biomarkers` (vector of continuous+ checkmate::assert_string(label_all) |
| 120 |
- #' biomarker variables) and optionally `covariates`, `subgroups` and `strata`.+ |
||
| 121 |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ # Add All Patients. |
||
| 122 | -+ | 17x |
- #'+ result_all <- h_proportion_df(data[[variables$rsp]], data[[variables$arm]]) |
| 123 | -+ | 17x |
- #' @inheritParams argument_convention+ result_all$subgroup <- label_all |
| 124 | -+ | 17x |
- #' @inheritParams response_subgroups+ result_all$var <- "ALL" |
| 125 | -+ | 17x |
- #' @param control (named `list`)\cr controls for the response definition and the+ result_all$var_label <- label_all |
| 126 | -+ | 17x |
- #' confidence level produced by [control_logistic()].+ result_all$row_type <- "content" |
| 127 |
- #'+ |
||
| 128 |
- #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_rsp`,+ # Add Subgroups. |
||
| 129 | -+ | 17x |
- #' `prop`, `or`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`,+ if (is.null(variables$subgroups)) {
|
| 130 | -+ | 3x |
- #' `var_label`, and `row_type`.+ result_all |
| 131 |
- #'+ } else {
|
||
| 132 | -+ | 14x |
- #' @note You can also specify a continuous variable in `rsp` and then use the+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
| 133 |
- #' `response_definition` control to convert that internally to a logical+ |
||
| 134 | -+ | 14x |
- #' variable reflecting binary response.+ l_result <- lapply(l_data, function(grp) {
|
| 135 | -+ | 58x |
- #'+ result <- h_proportion_df(grp$df[[variables$rsp]], grp$df[[variables$arm]]) |
| 136 | -+ | 58x |
- #' @seealso [h_logistic_mult_cont_df()] which is used internally.+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
| 137 | -+ | 58x |
- #'+ cbind(result, result_labels) |
| 138 |
- #' @examples+ }) |
||
| 139 | -+ | 14x |
- #' library(dplyr)+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 140 | -+ | 14x |
- #' library(forcats)+ result_subgroups$row_type <- "analysis" |
| 141 |
- #'+ |
||
| 142 | -+ | 14x |
- #' adrs <- tern_ex_adrs+ rbind( |
| 143 | -+ | 14x |
- #' adrs_labels <- formatters::var_labels(adrs)+ result_all, |
| 144 | -+ | 14x |
- #'+ result_subgroups |
| 145 |
- #' adrs_f <- adrs %>%+ ) |
||
| 146 |
- #' filter(PARAMCD == "BESRSPI") %>%+ } |
||
| 147 |
- #' mutate(rsp = AVALC == "CR")+ } |
||
| 148 |
- #'+ |
||
| 149 |
- #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`,+ #' @describeIn h_response_subgroups Helper to prepare a data frame with estimates of |
||
| 150 |
- #' # in logistic regression models with one covariate `RACE`. The subgroups+ #' the odds ratio between a treatment and a control arm. |
||
| 151 |
- #' # are defined by the levels of `BMRKR2`.+ #' |
||
| 152 |
- #' df <- extract_rsp_biomarkers(+ #' @inheritParams response_subgroups |
||
| 153 |
- #' variables = list(+ #' @param strata_data (`factor`, `data.frame`, or `NULL`)\cr required if stratified analysis is performed. |
||
| 154 |
- #' rsp = "rsp",+ #' |
||
| 155 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' @return |
||
| 156 |
- #' covariates = "SEX",+ #' * `h_odds_ratio_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`, and |
||
| 157 |
- #' subgroups = "BMRKR2"+ #' optionally `pval` and `pval_label`. |
||
| 158 |
- #' ),+ #' |
||
| 159 |
- #' data = adrs_f+ #' @examples |
||
| 160 |
- #' )+ #' # Unstratatified analysis. |
||
| 161 |
- #' df+ #' h_odds_ratio_df( |
||
| 162 |
- #'+ #' c(TRUE, FALSE, FALSE, TRUE), |
||
| 163 |
- #' # Here we group the levels of `BMRKR2` manually, and we add a stratification+ #' arm = factor(c("A", "A", "B", "B"), levels = c("A", "B"))
|
||
| 164 |
- #' # variable `STRATA1`. We also here use a continuous variable `EOSDY`+ #' ) |
||
| 165 |
- #' # which is then binarized internally (response is defined as this variable+ #' |
||
| 166 |
- #' # being larger than 750).+ #' # Include p-value. |
||
| 167 |
- #' df_grouped <- extract_rsp_biomarkers(+ #' h_odds_ratio_df(adrs_f$rsp, adrs_f$ARM, method = "chisq") |
||
| 168 |
- #' variables = list(+ #' |
||
| 169 |
- #' rsp = "EOSDY",+ #' # Stratatified analysis. |
||
| 170 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' h_odds_ratio_df( |
||
| 171 |
- #' covariates = "SEX",+ #' rsp = adrs_f$rsp, |
||
| 172 |
- #' subgroups = "BMRKR2",+ #' arm = adrs_f$ARM, |
||
| 173 |
- #' strata = "STRATA1"+ #' strata_data = adrs_f[, c("STRATA1", "STRATA2")],
|
||
| 174 |
- #' ),+ #' method = "cmh" |
||
| 175 |
- #' data = adrs_f,+ #' ) |
||
| 176 |
- #' groups_lists = list(+ #' |
||
| 177 |
- #' BMRKR2 = list(+ #' @export |
||
| 178 |
- #' "low" = "LOW",+ h_odds_ratio_df <- function(rsp, arm, strata_data = NULL, conf_level = 0.95, method = NULL) {
|
||
| 179 | -+ | 84x |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ assert_valid_factor(arm, n.levels = 2, len = length(rsp)) |
| 180 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+
|
||
| 181 | -+ | 84x |
- #' )+ df_rsp <- data.frame( |
| 182 | -+ | 84x |
- #' ),+ rsp = rsp, |
| 183 | -+ | 84x |
- #' control = control_logistic(+ arm = arm |
| 184 |
- #' response_definition = "I(response > 750)"+ ) |
||
| 185 |
- #' )+ |
||
| 186 | -+ | 84x |
- #' )+ if (!is.null(strata_data)) {
|
| 187 | -+ | 11x |
- #' df_grouped+ strata_var <- interaction(strata_data, drop = TRUE) |
| 188 | -+ | 11x |
- #'+ strata_name <- "strata" |
| 189 |
- #' @export+ |
||
| 190 | -+ | 11x |
- extract_rsp_biomarkers <- function(variables,+ assert_valid_factor(strata_var, len = nrow(df_rsp)) |
| 191 |
- data,+ |
||
| 192 | -+ | 11x |
- groups_lists = list(),+ df_rsp[[strata_name]] <- strata_var |
| 193 |
- control = control_logistic(),+ } else {
|
||
| 194 | -+ | 73x |
- label_all = "All Patients") {
+ strata_name <- NULL |
| 195 | -5x | +
- if ("strat" %in% names(variables)) {
+ } |
|
| 196 | -! | +
- warning(+ |
|
| 197 | -! | +84x |
- "Warning: the `strat` element name of the `variables` list argument to `extract_rsp_biomarkers() ",+ l_df <- split(df_rsp, arm) |
| 198 | -! | +
- "was deprecated in tern 0.9.4.\n ",+ |
|
| 199 | -! | +84x |
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
|
| 200 |
- )+ # Odds ratio and CI. |
||
| 201 | -! | +82x |
- variables[["strata"]] <- variables[["strat"]]+ result_odds_ratio <- s_odds_ratio( |
| 202 | -+ | 82x |
- }+ df = l_df[[2]], |
| 203 | -+ | 82x |
-
+ .var = "rsp", |
| 204 | -5x | +82x |
- assert_list_of_variables(variables)+ .ref_group = l_df[[1]], |
| 205 | -5x | +82x |
- checkmate::assert_string(variables$rsp)+ .in_ref_col = FALSE, |
| 206 | -5x | +82x |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ .df_row = df_rsp, |
| 207 | -5x | +82x |
- checkmate::assert_string(label_all)+ variables = list(arm = "arm", strata = strata_name), |
| 208 | -+ | 82x |
-
+ conf_level = conf_level |
| 209 |
- # Start with all patients.+ ) |
||
| 210 | -5x | +
- result_all <- h_logistic_mult_cont_df(+ |
|
| 211 | -5x | +82x |
- variables = variables,+ df <- data.frame( |
| 212 | -5x | +
- data = data,+ # Dummy column needed downstream to create a nested header. |
|
| 213 | -5x | +82x |
- control = control+ arm = " ", |
| 214 | -+ | 82x |
- )+ n_tot = unname(result_odds_ratio$n_tot["n_tot"]), |
| 215 | -5x | +82x |
- result_all$subgroup <- label_all+ or = unname(result_odds_ratio$or_ci["est"]), |
| 216 | -5x | +82x |
- result_all$var <- "ALL"+ lcl = unname(result_odds_ratio$or_ci["lcl"]), |
| 217 | -5x | +82x |
- result_all$var_label <- label_all+ ucl = unname(result_odds_ratio$or_ci["ucl"]), |
| 218 | -5x | +82x |
- result_all$row_type <- "content"+ conf_level = conf_level, |
| 219 | -5x | +82x |
- if (is.null(variables$subgroups)) {
+ stringsAsFactors = FALSE |
| 220 |
- # Only return result for all patients.+ ) |
||
| 221 | -1x | +
- result_all+ |
|
| 222 | -+ | 82x |
- } else {
+ if (!is.null(method)) {
|
| 223 |
- # Add subgroups results.+ # Test for difference. |
||
| 224 | -4x | +44x |
- l_data <- h_split_by_subgroups(+ result_test <- s_test_proportion_diff( |
| 225 | -4x | +44x |
- data,+ df = l_df[[2]], |
| 226 | -4x | +44x |
- variables$subgroups,+ .var = "rsp", |
| 227 | -4x | +44x |
- groups_lists = groups_lists+ .ref_group = l_df[[1]], |
| 228 | -+ | 44x |
- )+ .in_ref_col = FALSE, |
| 229 | -4x | +44x |
- l_result <- lapply(l_data, function(grp) {
+ variables = list(strata = strata_name), |
| 230 | -20x | +44x |
- result <- h_logistic_mult_cont_df(+ method = method |
| 231 | -20x | +
- variables = variables,+ ) |
|
| 232 | -20x | +
- data = grp$df,+ |
|
| 233 | -20x | +44x |
- control = control+ df$pval <- as.numeric(result_test$pval) |
| 234 | -+ | 44x |
- )+ df$pval_label <- obj_label(result_test$pval) |
| 235 | -20x | +
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ } |
|
| 236 | -20x | +
- cbind(result, result_labels)+ |
|
| 237 |
- })+ # In those cases cannot go through the model so will obtain n_tot from data. |
||
| 238 | -4x | +
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ } else if ( |
|
| 239 | -4x | +2x |
- result_subgroups$row_type <- "analysis"+ (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) || |
| 240 | -4x | +2x |
- rbind(+ (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0) |
| 241 | -4x | +
- result_all,+ ) {
|
|
| 242 | -4x | +2x |
- result_subgroups+ df <- data.frame( |
| 243 |
- )+ # Dummy column needed downstream to create a nested header. |
||
| 244 | -+ | 2x |
- }+ arm = " ", |
| 245 | -+ | 2x |
- }+ n_tot = sum(stats::complete.cases(df_rsp)), |
| 1 | -+ | ||
| 246 | +2x |
- #' Analyze numeric variables in columns+ or = NA, |
|
| 2 | -+ | ||
| 247 | +2x |
- #'+ lcl = NA, |
|
| 3 | -+ | ||
| 248 | +2x |
- #' @description `r lifecycle::badge("experimental")`
+ ucl = NA, |
|
| 4 | -+ | ||
| 249 | +2x |
- #'+ conf_level = conf_level, |
|
| 5 | -+ | ||
| 250 | +2x |
- #' The layout-creating function [analyze_vars_in_cols()] creates a layout element to generate a column-wise+ stringsAsFactors = FALSE |
|
| 6 | +251 |
- #' analysis table.+ ) |
|
| 7 | -+ | ||
| 252 | +2x |
- #'+ if (!is.null(method)) {
|
|
| 8 | -+ | ||
| 253 | +2x |
- #' This function sets the analysis methods as column labels and is a wrapper for [rtables::analyze_colvars()].+ df$pval <- NA |
|
| 9 | -+ | ||
| 254 | +2x |
- #' It was designed principally for PK tables.+ df$pval_label <- NA |
|
| 10 | +255 |
- #'+ } |
|
| 11 | +256 |
- #' @inheritParams argument_convention+ } else {
|
|
| 12 | -+ | ||
| 257 | +! |
- #' @inheritParams rtables::analyze_colvars+ df <- data.frame( |
|
| 13 | +258 |
- #' @param imp_rule (`string` or `NULL`)\cr imputation rule setting. Defaults to `NULL` for no imputation rule. Can+ # Dummy column needed downstream to create a nested header. |
|
| 14 | -+ | ||
| 259 | +! |
- #' also be `"1/3"` to implement 1/3 imputation rule or `"1/2"` to implement 1/2 imputation rule. In order+ arm = " ", |
|
| 15 | -+ | ||
| 260 | +! |
- #' to use an imputation rule, the `avalcat_var` argument must be specified. See [imputation_rule()]+ n_tot = 0L, |
|
| 16 | -+ | ||
| 261 | +! |
- #' for more details on imputation.+ or = NA, |
|
| 17 | -+ | ||
| 262 | +! |
- #' @param avalcat_var (`string`)\cr if `imp_rule` is not `NULL`, name of variable that indicates whether a+ lcl = NA, |
|
| 18 | -+ | ||
| 263 | +! |
- #' row in the data corresponds to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of+ ucl = NA,+ |
+ |
| 264 | +! | +
+ conf_level = conf_level,+ |
+ |
| 265 | +! | +
+ stringsAsFactors = FALSE |
|
| 19 | +266 |
- #' the above (defaults to `"AVALCAT1"`). Variable must be present in the data and should match the variable+ ) |
|
| 20 | +267 |
- #' used to calculate the `n_blq` statistic (if included in `.stats`).+ + |
+ |
| 268 | +! | +
+ if (!is.null(method)) {
+ |
+ |
| 269 | +! | +
+ df$pval <- NA+ |
+ |
| 270 | +! | +
+ df$pval_label <- NA |
|
| 21 | +271 |
- #' @param cache (`flag`)\cr whether to store computed values in a temporary caching environment. This will+ } |
|
| 22 | +272 |
- #' speed up calculations in large tables, but should be set to `FALSE` if the same `rtable` layout is+ } |
|
| 23 | +273 |
- #' used for multiple tables with different data. Defaults to `FALSE`.+ + |
+ |
| 274 | +84x | +
+ df |
|
| 24 | +275 |
- #' @param row_labels (`character`)\cr as this function works in columns space, usually `.labels`+ } |
|
| 25 | +276 |
- #' character vector applies on the column space. You can change the row labels by defining this+ |
|
| 26 | +277 |
- #' parameter to a named character vector with names corresponding to the split values. It defaults+ #' @describeIn h_response_subgroups Summarizes estimates of the odds ratio between a treatment and a control |
|
| 27 | +278 |
- #' to `NULL` and if it contains only one `string`, it will duplicate that as a row label.+ #' arm across subgroups in a data frame. `variables` corresponds to the names of variables found in |
|
| 28 | +279 |
- #' @param do_summarize_row_groups (`flag`)\cr defaults to `FALSE` and applies the analysis to the current+ #' `data`, passed as a named list and requires elements `rsp`, `arm` and optionally `subgroups` |
|
| 29 | +280 |
- #' label rows. This is a wrapper of [rtables::summarize_row_groups()] and it can accept `labelstr`+ #' and `strata`. `groups_lists` optionally specifies groupings for `subgroups` variables. |
|
| 30 | +281 |
- #' to define row labels. This behavior is not supported as we never need to overload row labels.+ #' |
|
| 31 | +282 |
- #' @param split_col_vars (`flag`)\cr defaults to `TRUE` and puts the analysis results onto the columns.+ #' @return |
|
| 32 | +283 |
- #' This option allows you to add multiple instances of this functions, also in a nested fashion,+ #' * `h_odds_ratio_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, |
|
| 33 | +284 |
- #' without adding more splits. This split must happen only one time on a single layout.+ #' `conf_level`, `subgroup`, `var`, `var_label`, and `row_type`. |
|
| 34 | +285 |
#' |
|
| 35 | +286 |
- #' @return+ #' @examples |
|
| 36 | +287 |
- #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()].+ #' # Unstratified analysis. |
|
| 37 | +288 |
- #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output+ #' h_odds_ratio_subgroups_df( |
|
| 38 | +289 |
- #' in columns, and add it to the table layout.+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
|
|
| 39 | +290 |
- #'+ #' data = adrs_f |
|
| 40 | +291 |
- #' @note+ #' ) |
|
| 41 | +292 |
- #' * This is an experimental implementation of [rtables::summarize_row_groups()] and [rtables::analyze_colvars()]+ #' |
|
| 42 | +293 |
- #' that may be subjected to changes as `rtables` extends its support to more complex analysis pipelines in the+ #' # Stratified analysis. |
|
| 43 | +294 |
- #' column space. We encourage users to read the examples carefully and file issues for different use cases.+ #' h_odds_ratio_subgroups_df( |
|
| 44 | +295 |
- #' * In this function, `labelstr` behaves atypically. If `labelstr = NULL` (the default), row labels are assigned+ #' variables = list( |
|
| 45 | +296 |
- #' automatically as the split values if `do_summarize_row_groups = FALSE` (the default), and as the group label+ #' rsp = "rsp", |
|
| 46 | +297 |
- #' if `do_summarize_row_groups = TRUE`.+ #' arm = "ARM", |
|
| 47 | +298 |
- #'+ #' subgroups = c("SEX", "BMRKR2"),
|
|
| 48 | +299 |
- #' @seealso [analyze_vars()], [rtables::analyze_colvars()].+ #' strata = c("STRATA1", "STRATA2")
|
|
| 49 | +300 |
- #'+ #' ), |
|
| 50 | +301 |
- #' @examples+ #' data = adrs_f |
|
| 51 | +302 |
- #' library(dplyr)+ #' ) |
|
| 52 | +303 |
#' |
|
| 53 | +304 |
- #' # Data preparation+ #' # Define groupings of BMRKR2 levels. |
|
| 54 | +305 |
- #' adpp <- tern_ex_adpp %>% h_pkparam_sort()+ #' h_odds_ratio_subgroups_df( |
|
| 55 | +306 |
- #'+ #' variables = list( |
|
| 56 | +307 |
- #' lyt <- basic_table() %>%+ #' rsp = "rsp", |
|
| 57 | +308 |
- #' split_rows_by(var = "STRATA1", label_pos = "topleft") %>%+ #' arm = "ARM", |
|
| 58 | +309 |
- #' split_rows_by(+ #' subgroups = c("SEX", "BMRKR2")
|
|
| 59 | +310 |
- #' var = "SEX",+ #' ), |
|
| 60 | +311 |
- #' label_pos = "topleft",+ #' data = adrs_f, |
|
| 61 | +312 |
- #' child_labels = "hidden"+ #' groups_lists = list( |
|
| 62 | +313 |
- #' ) %>% # Removes duplicated labels+ #' BMRKR2 = list( |
|
| 63 | +314 |
- #' analyze_vars_in_cols(vars = "AGE")+ #' "low" = "LOW", |
|
| 64 | +315 |
- #' result <- build_table(lyt = lyt, df = adpp)+ #' "low/medium" = c("LOW", "MEDIUM"),
|
|
| 65 | +316 |
- #' result+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
|
| 66 | +317 |
- #'+ #' ) |
|
| 67 | +318 |
- #' # By selecting just some statistics and ad-hoc labels+ #' ) |
|
| 68 | +319 |
- #' lyt <- basic_table() %>%+ #' ) |
|
| 69 | +320 |
- #' split_rows_by(var = "ARM", label_pos = "topleft") %>%+ #' |
|
| 70 | +321 |
- #' split_rows_by(+ #' @export |
|
| 71 | +322 |
- #' var = "SEX",+ h_odds_ratio_subgroups_df <- function(variables, |
|
| 72 | +323 |
- #' label_pos = "topleft",+ data, |
|
| 73 | +324 |
- #' child_labels = "hidden",+ groups_lists = list(), |
|
| 74 | +325 |
- #' split_fun = drop_split_levels+ conf_level = 0.95, |
|
| 75 | +326 |
- #' ) %>%+ method = NULL, |
|
| 76 | +327 |
- #' analyze_vars_in_cols(+ label_all = "All Patients") {
|
|
| 77 | -+ | ||
| 328 | +18x |
- #' vars = "AGE",+ if ("strat" %in% names(variables)) {
|
|
| 78 | -+ | ||
| 329 | +! |
- #' .stats = c("n", "cv", "geom_mean"),
+ warning( |
|
| 79 | -+ | ||
| 330 | +! |
- #' .labels = c(+ "Warning: the `strat` element name of the `variables` list argument to `h_odds_ratio_subgroups_df() ", |
|
| 80 | -+ | ||
| 331 | +! |
- #' n = "aN",+ "was deprecated in tern 0.9.4.\n ", |
|
| 81 | -+ | ||
| 332 | +! |
- #' cv = "aCV",+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
|
| 82 | +333 |
- #' geom_mean = "aGeomMean"+ ) |
|
| 83 | -+ | ||
| 334 | +! |
- #' )+ variables[["strata"]] <- variables[["strat"]] |
|
| 84 | +335 |
- #' )+ } |
|
| 85 | +336 |
- #' result <- build_table(lyt = lyt, df = adpp)+ |
|
| 86 | -+ | ||
| 337 | +18x |
- #' result+ checkmate::assert_character(variables$rsp) |
|
| 87 | -+ | ||
| 338 | +18x |
- #'+ checkmate::assert_character(variables$arm) |
|
| 88 | -+ | ||
| 339 | +18x |
- #' # Changing row labels+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
|
| 89 | -+ | ||
| 340 | +18x |
- #' lyt <- basic_table() %>%+ checkmate::assert_character(variables$strata, null.ok = TRUE) |
|
| 90 | -+ | ||
| 341 | +18x |
- #' analyze_vars_in_cols(+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2) |
|
| 91 | -+ | ||
| 342 | +18x |
- #' vars = "AGE",+ assert_df_with_variables(data, variables) |
|
| 92 | -+ | ||
| 343 | +18x |
- #' row_labels = "some custom label"+ checkmate::assert_string(label_all) |
|
| 93 | +344 |
- #' )+ |
|
| 94 | -+ | ||
| 345 | +18x |
- #' result <- build_table(lyt, df = adpp)+ strata_data <- if (is.null(variables$strata)) {
|
|
| 95 | -+ | ||
| 346 | +16x |
- #' result+ NULL |
|
| 96 | +347 |
- #'+ } else {
|
|
| 97 | -+ | ||
| 348 | +2x |
- #' # Pharmacokinetic parameters+ data[, variables$strata, drop = FALSE] |
|
| 98 | +349 |
- #' lyt <- basic_table() %>%+ } |
|
| 99 | +350 |
- #' split_rows_by(+ |
|
| 100 | +351 |
- #' var = "TLG_DISPLAY",+ # Add All Patients. |
|
| 101 | -+ | ||
| 352 | +18x |
- #' split_label = "PK Parameter",+ result_all <- h_odds_ratio_df( |
|
| 102 | -+ | ||
| 353 | +18x |
- #' label_pos = "topleft",+ rsp = data[[variables$rsp]], |
|
| 103 | -+ | ||
| 354 | +18x |
- #' child_labels = "hidden"+ arm = data[[variables$arm]], |
|
| 104 | -+ | ||
| 355 | +18x |
- #' ) %>%+ strata_data = strata_data, |
|
| 105 | -+ | ||
| 356 | +18x |
- #' analyze_vars_in_cols(+ conf_level = conf_level, |
|
| 106 | -+ | ||
| 357 | +18x |
- #' vars = "AVAL"+ method = method |
|
| 107 | +358 |
- #' )+ ) |
|
| 108 | -+ | ||
| 359 | +18x |
- #' result <- build_table(lyt, df = adpp)+ result_all$subgroup <- label_all |
|
| 109 | -+ | ||
| 360 | +18x |
- #' result+ result_all$var <- "ALL" |
|
| 110 | -+ | ||
| 361 | +18x |
- #'+ result_all$var_label <- label_all |
|
| 111 | -+ | ||
| 362 | +18x |
- #' # Multiple calls (summarize label and analyze underneath)+ result_all$row_type <- "content" |
|
| 112 | +363 |
- #' lyt <- basic_table() %>%+ |
|
| 113 | -+ | ||
| 364 | +18x |
- #' split_rows_by(+ if (is.null(variables$subgroups)) {
|
|
| 114 | -+ | ||
| 365 | +3x |
- #' var = "TLG_DISPLAY",+ result_all |
|
| 115 | +366 |
- #' split_label = "PK Parameter",+ } else {
|
|
| 116 | -+ | ||
| 367 | +15x |
- #' label_pos = "topleft"+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
|
| 117 | +368 |
- #' ) %>%+ |
|
| 118 | -+ | ||
| 369 | +15x |
- #' analyze_vars_in_cols(+ l_result <- lapply(l_data, function(grp) {
|
|
| 119 | -+ | ||
| 370 | +62x |
- #' vars = "AVAL",+ grp_strata_data <- if (is.null(variables$strata)) {
|
|
| 120 | -+ | ||
| 371 | +54x |
- #' do_summarize_row_groups = TRUE # does a summarize level+ NULL |
|
| 121 | +372 |
- #' ) %>%+ } else {
|
|
| 122 | -+ | ||
| 373 | +8x |
- #' split_rows_by("SEX",
+ grp$df[, variables$strata, drop = FALSE] |
|
| 123 | +374 |
- #' child_labels = "hidden",+ } |
|
| 124 | +375 |
- #' label_pos = "topleft"+ |
|
| 125 | -+ | ||
| 376 | +62x |
- #' ) %>%+ result <- h_odds_ratio_df( |
|
| 126 | -+ | ||
| 377 | +62x |
- #' analyze_vars_in_cols(+ rsp = grp$df[[variables$rsp]], |
|
| 127 | -+ | ||
| 378 | +62x |
- #' vars = "AVAL",+ arm = grp$df[[variables$arm]], |
|
| 128 | -+ | ||
| 379 | +62x |
- #' split_col_vars = FALSE # avoids re-splitting the columns+ strata_data = grp_strata_data, |
|
| 129 | -+ | ||
| 380 | +62x |
- #' )+ conf_level = conf_level, |
|
| 130 | -+ | ||
| 381 | +62x |
- #' result <- build_table(lyt, df = adpp)+ method = method |
|
| 131 | +382 |
- #' result+ ) |
|
| 132 | -+ | ||
| 383 | +62x |
- #'+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
|
| 133 | -+ | ||
| 384 | +62x |
- #' @export+ cbind(result, result_labels) |
|
| 134 | +385 |
- analyze_vars_in_cols <- function(lyt,+ }) |
|
| 135 | +386 |
- vars,+ |
|
| 136 | -+ | ||
| 387 | +15x |
- ...,+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
|
| 137 | -+ | ||
| 388 | +15x |
- .stats = c(+ result_subgroups$row_type <- "analysis" |
|
| 138 | +389 |
- "n",+ |
|
| 139 | -+ | ||
| 390 | +15x |
- "mean",+ rbind( |
|
| 140 | -+ | ||
| 391 | +15x |
- "sd",+ result_all, |
|
| 141 | -+ | ||
| 392 | +15x |
- "se",+ result_subgroups |
|
| 142 | +393 |
- "cv",+ ) |
|
| 143 | +394 |
- "geom_cv"+ } |
|
| 144 | +395 |
- ),+ } |
| 145 | +1 |
- .labels = c(+ #' Occurrence table pruning |
||
| 146 | +2 |
- n = "n",+ #' |
||
| 147 | +3 |
- mean = "Mean",+ #' @description `r lifecycle::badge("stable")`
|
||
| 148 | +4 |
- sd = "SD",+ #' |
||
| 149 | +5 |
- se = "SE",+ #' Family of constructor and condition functions to flexibly prune occurrence tables. |
||
| 150 | +6 |
- cv = "CV (%)",+ #' The condition functions always return whether the row result is higher than the threshold. |
||
| 151 | +7 |
- geom_cv = "CV % Geometric Mean"+ #' Since they are of class [CombinationFunction()] they can be logically combined with other condition |
||
| 152 | +8 |
- ),+ #' functions. |
||
| 153 | +9 |
- row_labels = NULL,+ #' |
||
| 154 | +10 |
- do_summarize_row_groups = FALSE,+ #' @note Since most table specifications are worded positively, we name our constructor and condition |
||
| 155 | +11 |
- split_col_vars = TRUE,+ #' functions positively, too. However, note that the result of [keep_rows()] says what |
||
| 156 | +12 |
- imp_rule = NULL,+ #' should be pruned, to conform with the [rtables::prune_table()] interface. |
||
| 157 | +13 |
- avalcat_var = "AVALCAT1",+ #' |
||
| 158 | +14 |
- cache = FALSE,+ #' @examples |
||
| 159 | +15 |
- .indent_mods = NULL,+ #' \donttest{
|
||
| 160 | +16 |
- na_str = default_na_str(),+ #' tab <- basic_table() %>% |
||
| 161 | +17 |
- nested = TRUE,+ #' split_cols_by("ARM") %>%
|
||
| 162 | +18 |
- .formats = NULL,+ #' split_rows_by("RACE") %>%
|
||
| 163 | +19 |
- .aligns = NULL) {
- |
- ||
| 164 | -26x | -
- extra_args <- list(...)+ #' split_rows_by("STRATA1") %>%
|
||
| 165 | +20 |
-
+ #' summarize_row_groups() %>% |
||
| 166 | -26x | +|||
| 21 | +
- checkmate::assert_string(na_str, na.ok = TRUE, null.ok = TRUE)+ #' analyze_vars("COUNTRY", .stats = "count_fraction") %>%
|
|||
| 167 | -26x | +|||
| 22 | +
- checkmate::assert_character(row_labels, null.ok = TRUE)+ #' build_table(DM) |
|||
| 168 | -26x | +|||
| 23 | +
- checkmate::assert_int(.indent_mods, null.ok = TRUE)+ #' } |
|||
| 169 | -26x | +|||
| 24 | +
- checkmate::assert_flag(nested)+ #' |
|||
| 170 | -26x | +|||
| 25 | +
- checkmate::assert_flag(split_col_vars)+ #' @name prune_occurrences |
|||
| 171 | -26x | +|||
| 26 | +
- checkmate::assert_flag(do_summarize_row_groups)+ NULL |
|||
| 172 | +27 | |||
| 173 | +28 |
- # Filtering+ #' @describeIn prune_occurrences Constructor for creating pruning functions based on |
||
| 174 | -26x | +|||
| 29 | +
- met_grps <- paste0("analyze_vars", c("_numeric", "_counts"))
+ #' a row condition function. This removes all analysis rows (`TableRow`) that should be |
|||
| 175 | -26x | +|||
| 30 | +
- .stats <- get_stats(met_grps, stats_in = .stats)+ #' pruned, i.e., don't fulfill the row condition. It removes the sub-tree if there are no |
|||
| 176 | -26x | +|||
| 31 | +
- formats_v <- get_formats_from_stats(stats = .stats, formats_in = .formats)+ #' children left. |
|||
| 177 | -26x | +|||
| 32 | +
- labels_v <- get_labels_from_stats(stats = .stats, labels_in = .labels)+ #' |
|||
| 178 | -! | +|||
| 33 | +
- if ("control" %in% names(extra_args)) labels_v <- labels_v %>% labels_use_control(extra_args[["control"]], .labels)
+ #' @param row_condition (`CombinationFunction`)\cr condition function which works on individual |
|||
| 179 | +34 |
-
+ #' analysis rows and flags whether these should be kept in the pruned table. |
||
| 180 | +35 |
- # Check for vars in the case that one or more are used+ #' |
||
| 181 | -26x | +|||
| 36 | +
- if (length(vars) == 1) {
+ #' @return |
|||
| 182 | -21x | +|||
| 37 | +
- vars <- rep(vars, length(.stats))+ #' * `keep_rows()` returns a pruning function that can be used with [rtables::prune_table()] |
|||
| 183 | -5x | +|||
| 38 | +
- } else if (length(vars) != length(.stats)) {
+ #' to prune an `rtables` table. |
|||
| 184 | -1x | +|||
| 39 | +
- stop(+ #' |
|||
| 185 | -1x | +|||
| 40 | +
- "Analyzed variables (vars) does not have the same ",+ #' @examples |
|||
| 186 | -1x | +|||
| 41 | +
- "number of elements of specified statistics (.stats)."+ #' \donttest{
|
|||
| 187 | +42 |
- )+ #' # `keep_rows` |
||
| 188 | +43 |
- }+ #' is_non_empty <- !CombinationFunction(all_zero_or_na) |
||
| 189 | +44 |
-
+ #' prune_table(tab, keep_rows(is_non_empty)) |
||
| 190 | -25x | +|||
| 45 | +
- if (split_col_vars) {
+ #' } |
|||
| 191 | +46 |
- # Checking there is not a previous identical column split+ #' |
||
| 192 | -21x | +|||
| 47 | +
- clyt <- tail(clayout(lyt), 1)[[1]]+ #' @export |
|||
| 193 | +48 |
-
+ keep_rows <- function(row_condition) {
|
||
| 194 | -21x | +49 | +6x |
- dummy_lyt <- split_cols_by_multivar(+ checkmate::assert_function(row_condition) |
| 195 | -21x | +50 | +6x |
- lyt = basic_table(),+ function(table_tree) {
|
| 196 | -21x | +51 | +2256x |
- vars = vars,+ if (inherits(table_tree, "TableRow")) {
|
| 197 | -21x | +52 | +1872x |
- varlabels = labels_v+ return(!row_condition(table_tree)) |
| 198 | +53 |
- )+ } |
||
| 199 | -+ | |||
| 54 | +384x |
-
+ children <- tree_children(table_tree) |
||
| 200 | -21x | +55 | +384x |
- if (any(sapply(clyt, identical, y = get_last_col_split(dummy_lyt)))) {
+ identical(length(children), 0L) |
| 201 | -2x | +|||
| 56 | +
- stop(+ } |
|||
| 202 | -2x | +|||
| 57 | +
- "Column split called again with the same values. ",+ } |
|||
| 203 | -2x | +|||
| 58 | +
- "This can create many unwanted columns. Please consider adding ",+ |
|||
| 204 | -2x | +|||
| 59 | +
- "split_col_vars = FALSE to the last call of ",+ #' @describeIn prune_occurrences Constructor for creating pruning functions based on |
|||
| 205 | -2x | +|||
| 60 | +
- deparse(sys.calls()[[sys.nframe() - 1]]), "."+ #' a condition for the (first) content row in leaf tables. This removes all leaf tables where |
|||
| 206 | +61 |
- )+ #' the first content row does not fulfill the condition. It does not check individual rows. |
||
| 207 | +62 |
- }+ #' It then proceeds recursively by removing the sub tree if there are no children left. |
||
| 208 | +63 |
-
+ #' |
||
| 209 | +64 |
- # Main col split+ #' @param content_row_condition (`CombinationFunction`)\cr condition function which works on individual |
||
| 210 | -19x | +|||
| 65 | +
- lyt <- split_cols_by_multivar(+ #' first content rows of leaf tables and flags whether these leaf tables should be kept in the pruned table. |
|||
| 211 | -19x | +|||
| 66 | +
- lyt = lyt,+ #' |
|||
| 212 | -19x | +|||
| 67 | +
- vars = vars,+ #' @return |
|||
| 213 | -19x | +|||
| 68 | +
- varlabels = labels_v+ #' * `keep_content_rows()` returns a pruning function that checks the condition on the first content |
|||
| 214 | +69 |
- )+ #' row of leaf tables in the table. |
||
| 215 | +70 |
- }+ #' |
||
| 216 | +71 |
-
+ #' @examples |
||
| 217 | -23x | +|||
| 72 | +
- env <- new.env() # create caching environment+ #' # `keep_content_rows` |
|||
| 218 | +73 |
-
+ #' \donttest{
|
||
| 219 | -23x | +|||
| 74 | +
- if (do_summarize_row_groups) {
+ #' more_than_twenty <- has_count_in_cols(atleast = 20L, col_names = names(tab)) |
|||
| 220 | -8x | +|||
| 75 | +
- if (length(unique(vars)) > 1) {
+ #' prune_table(tab, keep_content_rows(more_than_twenty)) |
|||
| 221 | -! | +|||
| 76 | +
- stop("When using do_summarize_row_groups only one label level var should be inserted.")
+ #' } |
|||
| 222 | +77 |
- }+ #' |
||
| 223 | +78 |
-
+ #' @export |
||
| 224 | +79 |
- # Function list for do_summarize_row_groups. Slightly different handling of labels+ keep_content_rows <- function(content_row_condition) {
|
||
| 225 | -8x | +80 | +1x |
- cfun_list <- Map(+ checkmate::assert_function(content_row_condition) |
| 226 | -8x | +81 | +1x |
- function(stat, use_cache, cache_env) {
+ function(table_tree) {
|
| 227 | -48x | +82 | +166x |
- function(u, .spl_context, labelstr, .df_row, ...) {
+ if (is_leaf_table(table_tree)) {
|
| 228 | -+ | |||
| 83 | +24x |
- # Statistic+ content_row <- h_content_first_row(table_tree) |
||
| 229 | -152x | +84 | +24x |
- var_row_val <- paste(+ return(!content_row_condition(content_row)) |
| 230 | -152x | +|||
| 85 | +
- gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
+ } |
|||
| 231 | -152x | +86 | +142x |
- paste(.spl_context$value, collapse = "_"),+ if (inherits(table_tree, "DataRow")) {
|
| 232 | -152x | +87 | +120x |
- sep = "_"+ return(FALSE) |
| 233 | +88 |
- )+ } |
||
| 234 | -152x | -
- if (use_cache) {
- |
- ||
| 235 | -! | +89 | +22x |
- if (is.null(cache_env[[var_row_val]])) {
+ children <- tree_children(table_tree) |
| 236 | -! | +|||
| 90 | +22x |
- cache_env[[var_row_val]] <- s_summary(u, ...)+ identical(length(children), 0L) |
||
| 237 | +91 |
- }- |
- ||
| 238 | -! | -
- x_stats <- cache_env[[var_row_val]]+ } |
||
| 239 | +92 |
- } else {
- |
- ||
| 240 | -152x | -
- x_stats <- s_summary(u, ...)+ } |
||
| 241 | +93 |
- }+ |
||
| 242 | +94 | - - | -||
| 243 | -152x | -
- if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
+ #' @describeIn prune_occurrences Constructor for creating condition functions on total counts in the specified columns. |
||
| 244 | -152x | +|||
| 95 | +
- res <- x_stats[[stat]]+ #' |
|||
| 245 | +96 |
- } else {
+ #' @param atleast (`numeric(1)`)\cr threshold which should be met in order to keep the row. |
||
| 246 | -! | +|||
| 97 | +
- timept <- as.numeric(gsub(".*?([0-9\\.]+).*", "\\1", tail(.spl_context$value, 1)))
+ #' @param ... arguments for row or column access, see [`rtables_access`]: either `col_names` (`character`) including |
|||
| 247 | -! | +|||
| 98 | +
- res_imp <- imputation_rule(+ #' the names of the columns which should be used, or alternatively `col_indices` (`integer`) giving the indices |
|||
| 248 | -! | +|||
| 99 | +
- .df_row, x_stats, stat,+ #' directly instead. |
|||
| 249 | -! | +|||
| 100 | +
- imp_rule = imp_rule,+ #' |
|||
| 250 | -! | +|||
| 101 | +
- post = grepl("Predose", tail(.spl_context$value, 1)) || timept > 0,
+ #' @return |
|||
| 251 | -! | +|||
| 102 | +
- avalcat_var = avalcat_var+ #' * `has_count_in_cols()` returns a condition function that sums the counts in the specified column. |
|||
| 252 | +103 |
- )+ #' |
||
| 253 | -! | +|||
| 104 | +
- res <- res_imp[["val"]]+ #' @examples |
|||
| 254 | -! | +|||
| 105 | +
- na_str <- res_imp[["na_str"]]+ #' \donttest{
|
|||
| 255 | +106 |
- }+ #' more_than_one <- has_count_in_cols(atleast = 1L, col_names = names(tab)) |
||
| 256 | +107 |
-
+ #' prune_table(tab, keep_rows(more_than_one)) |
||
| 257 | +108 |
- # Label check and replacement+ #' } |
||
| 258 | -152x | +|||
| 109 | +
- if (length(row_labels) > 1) {
+ #' |
|||
| 259 | -32x | +|||
| 110 | +
- if (!(labelstr %in% names(row_labels))) {
+ #' @export |
|||
| 260 | -2x | +|||
| 111 | +
- stop(+ has_count_in_cols <- function(atleast, ...) {
|
|||
| 261 | -2x | +112 | +6x |
- "Replacing the labels in do_summarize_row_groups needs a named vector",+ checkmate::assert_count(atleast) |
| 262 | -2x | +113 | +6x |
- "that contains the split values. In the current split variable ",+ CombinationFunction(function(table_row) {
|
| 263 | -2x | +114 | +337x |
- .spl_context$split[nrow(.spl_context)],+ row_counts <- h_row_counts(table_row, ...) |
| 264 | -2x | +115 | +337x |
- " the labelstr value (split value by default) ", labelstr, " is not in",+ total_count <- sum(row_counts) |
| 265 | -2x | +116 | +337x |
- " row_labels names: ", names(row_labels)+ total_count >= atleast |
| 266 | +117 |
- )+ }) |
||
| 267 | +118 |
- }- |
- ||
| 268 | -30x | -
- lbl <- unlist(row_labels[labelstr])+ } |
||
| 269 | +119 |
- } else {
- |
- ||
| 270 | -120x | -
- lbl <- labelstr+ |
||
| 271 | +120 |
- }+ #' @describeIn prune_occurrences Constructor for creating condition functions on any of the counts in |
||
| 272 | +121 |
-
+ #' the specified columns satisfying a threshold. |
||
| 273 | +122 |
- # Cell creation- |
- ||
| 274 | -150x | -
- rcell(res,- |
- ||
| 275 | -150x | -
- label = lbl,+ #' |
||
| 276 | -150x | +|||
| 123 | +
- format = formats_v[names(formats_v) == stat][[1]],+ #' @param atleast (`numeric(1)`)\cr threshold which should be met in order to keep the row. |
|||
| 277 | -150x | +|||
| 124 | +
- format_na_str = na_str,+ #' |
|||
| 278 | -150x | +|||
| 125 | +
- indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods),+ #' @return |
|||
| 279 | -150x | +|||
| 126 | +
- align = .aligns+ #' * `has_count_in_any_col()` returns a condition function that compares the counts in the |
|||
| 280 | +127 |
- )+ #' specified columns with the threshold. |
||
| 281 | +128 |
- }+ #' |
||
| 282 | +129 |
- },+ #' @examples |
||
| 283 | -8x | +|||
| 130 | +
- stat = .stats,+ #' \donttest{
|
|||
| 284 | -8x | +|||
| 131 | +
- use_cache = cache,+ #' # `has_count_in_any_col` |
|||
| 285 | -8x | +|||
| 132 | +
- cache_env = replicate(length(.stats), env)+ #' any_more_than_one <- has_count_in_any_col(atleast = 1L, col_names = names(tab)) |
|||
| 286 | +133 |
- )+ #' prune_table(tab, keep_rows(any_more_than_one)) |
||
| 287 | +134 |
-
+ #' } |
||
| 288 | +135 |
- # Main call to rtables+ #' |
||
| 289 | -8x | +|||
| 136 | +
- summarize_row_groups(+ #' @export |
|||
| 290 | -8x | +|||
| 137 | +
- lyt = lyt,+ has_count_in_any_col <- function(atleast, ...) {
|
|||
| 291 | -8x | +138 | +3x |
- var = unique(vars),+ checkmate::assert_count(atleast) |
| 292 | -8x | +139 | +3x |
- cfun = cfun_list,+ CombinationFunction(function(table_row) {
|
| 293 | -8x | +140 | +3x |
- na_str = na_str,+ row_counts <- h_row_counts(table_row, ...) |
| 294 | -8x | +141 | +3x |
- extra_args = extra_args+ any(row_counts >= atleast) |
| 295 | +142 |
- )+ }) |
||
| 296 | +143 |
- } else {
+ } |
||
| 297 | +144 |
- # Function list for analyze_colvars+ |
||
| 298 | -15x | +|||
| 145 | +
- afun_list <- Map(+ #' @describeIn prune_occurrences Constructor for creating condition functions on total fraction in |
|||
| 299 | -15x | +|||
| 146 | +
- function(stat, use_cache, cache_env) {
+ #' the specified columns. |
|||
| 300 | -76x | +|||
| 147 | +
- function(u, .spl_context, .df_row, ...) {
+ #' |
|||
| 301 | +148 |
- # Main statistics+ #' @return |
||
| 302 | -468x | +|||
| 149 | +
- var_row_val <- paste(+ #' * `has_fraction_in_cols()` returns a condition function that sums the counts in the |
|||
| 303 | -468x | +|||
| 150 | +
- gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
+ #' specified column, and computes the fraction by dividing by the total column counts. |
|||
| 304 | -468x | +|||
| 151 | +
- paste(.spl_context$value, collapse = "_"),+ #' |
|||
| 305 | -468x | +|||
| 152 | +
- sep = "_"+ #' @examples |
|||
| 306 | +153 |
- )+ #' \donttest{
|
||
| 307 | -468x | +|||
| 154 | +
- if (use_cache) {
+ #' # `has_fraction_in_cols` |
|||
| 308 | -16x | +|||
| 155 | +
- if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...)+ #' more_than_five_percent <- has_fraction_in_cols(atleast = 0.05, col_names = names(tab)) |
|||
| 309 | -56x | +|||
| 156 | +
- x_stats <- cache_env[[var_row_val]]+ #' prune_table(tab, keep_rows(more_than_five_percent)) |
|||
| 310 | +157 |
- } else {
+ #' } |
||
| 311 | -412x | +|||
| 158 | +
- x_stats <- s_summary(u, ...)+ #' |
|||
| 312 | +159 |
- }+ #' @export |
||
| 313 | +160 |
-
+ has_fraction_in_cols <- function(atleast, ...) {
|
||
| 314 | -468x | +161 | +4x |
- if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
+ assert_proportion_value(atleast, include_boundaries = TRUE) |
| 315 | -348x | +162 | +4x |
- res <- x_stats[[stat]]+ CombinationFunction(function(table_row) {
|
| 316 | -+ | |||
| 163 | +306x |
- } else {
+ row_counts <- h_row_counts(table_row, ...) |
||
| 317 | -120x | +164 | +306x |
- timept <- as.numeric(gsub(".*?([0-9\\.]+).*", "\\1", tail(.spl_context$value, 1)))
+ total_count <- sum(row_counts) |
| 318 | -120x | +165 | +306x |
- res_imp <- imputation_rule(+ col_counts <- h_col_counts(table_row, ...) |
| 319 | -120x | +166 | +306x |
- .df_row, x_stats, stat,+ total_n <- sum(col_counts) |
| 320 | -120x | +167 | +306x |
- imp_rule = imp_rule,+ total_percent <- total_count / total_n |
| 321 | -120x | +168 | +306x |
- post = grepl("Predose", tail(.spl_context$value, 1)) || timept > 0,
+ total_percent >= atleast |
| 322 | -120x | +|||
| 169 | +
- avalcat_var = avalcat_var+ }) |
|||
| 323 | +170 |
- )+ } |
||
| 324 | -120x | +|||
| 171 | +
- res <- res_imp[["val"]]+ |
|||
| 325 | -120x | +|||
| 172 | +
- na_str <- res_imp[["na_str"]]+ #' @describeIn prune_occurrences Constructor for creating condition functions on any fraction in |
|||
| 326 | +173 |
- }+ #' the specified columns. |
||
| 327 | +174 |
-
+ #' |
||
| 328 | -468x | +|||
| 175 | +
- if (is.list(res)) {
+ #' @return |
|||
| 329 | -52x | +|||
| 176 | +
- if (length(res) > 1) {
+ #' * `has_fraction_in_any_col()` returns a condition function that looks at the fractions |
|||
| 330 | -1x | +|||
| 177 | +
- stop("The analyzed column produced more than one category of results.")
+ #' in the specified columns and checks whether any of them fulfill the threshold. |
|||
| 331 | +178 |
- } else {
+ #' |
||
| 332 | -51x | +|||
| 179 | +
- res <- unlist(res)+ #' @examples |
|||
| 333 | +180 |
- }+ #' \donttest{
|
||
| 334 | +181 |
- }+ #' # `has_fraction_in_any_col` |
||
| 335 | +182 |
-
+ #' any_atleast_five_percent <- has_fraction_in_any_col(atleast = 0.05, col_names = names(tab)) |
||
| 336 | +183 |
- # Label from context+ #' prune_table(tab, keep_rows(any_atleast_five_percent)) |
||
| 337 | -467x | +|||
| 184 | +
- label_from_context <- .spl_context$value[nrow(.spl_context)]+ #' } |
|||
| 338 | +185 |
-
+ #' |
||
| 339 | +186 |
- # Label switcher+ #' @export+ |
+ ||
| 187 | ++ |
+ has_fraction_in_any_col <- function(atleast, ...) {
|
||
| 340 | -467x | +188 | +3x |
- if (is.null(row_labels)) {
+ assert_proportion_value(atleast, include_boundaries = TRUE) |
| 341 | -387x | +189 | +3x |
- lbl <- label_from_context+ CombinationFunction(function(table_row) {
+ |
+
| 190 | +3x | +
+ row_fractions <- h_row_fractions(table_row, ...)+ |
+ ||
| 191 | +3x | +
+ any(row_fractions >= atleast) |
||
| 342 | +192 |
- } else {
+ }) |
||
| 343 | -80x | +|||
| 193 | +
- if (length(row_labels) > 1) {
+ } |
|||
| 344 | -68x | +|||
| 194 | +
- if (!(label_from_context %in% names(row_labels))) {
+
|
|||
| 345 | -2x | +|||
| 195 | +
- stop(+ #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference |
|||
| 346 | -2x | +|||
| 196 | +
- "Replacing the labels in do_summarize_row_groups needs a named vector",+ #' between the fractions reported in each specified column. |
|||
| 347 | -2x | +|||
| 197 | +
- "that contains the split values. In the current split variable ",+ #' |
|||
| 348 | -2x | +|||
| 198 | +
- .spl_context$split[nrow(.spl_context)],+ #' @return |
|||
| 349 | -2x | +|||
| 199 | +
- " the split value ", label_from_context, " is not in",+ #' * `has_fractions_difference()` returns a condition function that extracts the fractions of each |
|||
| 350 | -2x | +|||
| 200 | +
- " row_labels names: ", names(row_labels)+ #' specified column, and computes the difference of the minimum and maximum. |
|||
| 351 | +201 |
- )+ #' |
||
| 352 | +202 |
- }+ #' @examples |
||
| 353 | -66x | +|||
| 203 | +
- lbl <- unlist(row_labels[label_from_context])+ #' \donttest{
|
|||
| 354 | +204 |
- } else {
+ #' # `has_fractions_difference` |
||
| 355 | -12x | +|||
| 205 | +
- lbl <- row_labels+ #' more_than_five_percent_diff <- has_fractions_difference(atleast = 0.05, col_names = names(tab)) |
|||
| 356 | +206 |
- }+ #' prune_table(tab, keep_rows(more_than_five_percent_diff)) |
||
| 357 | +207 |
- }+ #' } |
||
| 358 | +208 |
-
+ #' |
||
| 359 | +209 |
- # Cell creation+ #' @export |
||
| 360 | -465x | +|||
| 210 | +
- rcell(res,+ has_fractions_difference <- function(atleast, ...) {
|
|||
| 361 | -465x | +211 | +4x |
- label = lbl,+ assert_proportion_value(atleast, include_boundaries = TRUE) |
| 362 | -465x | +212 | +4x |
- format = formats_v[names(formats_v) == stat][[1]],+ CombinationFunction(function(table_row) {
|
| 363 | -465x | +213 | +246x |
- format_na_str = na_str,+ fractions <- h_row_fractions(table_row, ...) |
| 364 | -465x | +214 | +246x |
- indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods),+ difference <- diff(range(fractions)) |
| 365 | -465x | +215 | +246x |
- align = .aligns+ difference >= atleast |
| 366 | +216 |
- )+ }) |
||
| 367 | +217 |
- }+ } |
||
| 368 | +218 |
- },- |
- ||
| 369 | -15x | -
- stat = .stats,+ |
||
| 370 | -15x | +|||
| 219 | +
- use_cache = cache,+ #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference |
|||
| 371 | -15x | +|||
| 220 | +
- cache_env = replicate(length(.stats), env)+ #' between the counts reported in each specified column. |
|||
| 372 | +221 |
- )+ #' |
||
| 373 | +222 |
-
+ #' @return |
||
| 374 | +223 |
- # Main call to rtables+ #' * `has_counts_difference()` returns a condition function that extracts the counts of each |
||
| 375 | -15x | +|||
| 224 | +
- analyze_colvars(lyt,+ #' specified column, and computes the difference of the minimum and maximum. |
|||
| 376 | -15x | +|||
| 225 | +
- afun = afun_list,+ #' |
|||
| 377 | -15x | +|||
| 226 | +
- na_str = na_str,+ #' @examples |
|||
| 378 | -15x | +|||
| 227 | +
- nested = nested,+ #' \donttest{
|
|||
| 379 | -15x | +|||
| 228 | +
- extra_args = extra_args+ #' more_than_one_diff <- has_counts_difference(atleast = 1L, col_names = names(tab)) |
|||
| 380 | +229 |
- )+ #' prune_table(tab, keep_rows(more_than_one_diff)) |
||
| 381 | +230 |
- }+ #' } |
||
| 382 | +231 |
- }+ #' |
||
| 383 | +232 |
-
+ #' @export |
||
| 384 | +233 |
- # Helper function+ has_counts_difference <- function(atleast, ...) {
|
||
| 385 | -+ | |||
| 234 | +4x |
- get_last_col_split <- function(lyt) {
+ checkmate::assert_count(atleast) |
||
| 386 | -3x | +235 | +4x |
- tail(tail(clayout(lyt), 1)[[1]], 1)[[1]]+ CombinationFunction(function(table_row) {
+ |
+
| 236 | +30x | +
+ counts <- h_row_counts(table_row, ...)+ |
+ ||
| 237 | +30x | +
+ difference <- diff(range(counts))+ |
+ ||
| 238 | +30x | +
+ difference >= atleast |
||
| 387 | +239 | ++ |
+ })+ |
+ |
| 240 |
}@@ -97162,14 +100337,14 @@ tern coverage - 95.59% |
| 1 |
- #' Control function for Cox regression+ #' Re-implemented `range()` default S3 method for numerical objects |
|||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' This function returns `c(NA, NA)` instead of `c(-Inf, Inf)` for zero-length data |
|||
| 4 |
- #'+ #' without any warnings. |
|||
| 5 |
- #' Sets a list of parameters for Cox regression fit. Used internally.+ #' |
|||
| 6 |
- #'+ #' @param x (`numeric`)\cr a sequence of numbers for which the range is computed. |
|||
| 7 |
- #' @inheritParams argument_convention+ #' @param na.rm (`flag`)\cr flag indicating if `NA` should be omitted. |
|||
| 8 |
- #' @param pval_method (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`.+ #' @param finite (`flag`)\cr flag indicating if non-finite elements should be removed. |
|||
| 9 |
- #' @param interaction (`flag`)\cr if `TRUE`, the model includes the interaction between the studied+ #' |
|||
| 10 |
- #' treatment and candidate covariate. Note that for univariate models without treatment arm, and+ #' @return A 2-element vector of class `numeric`. |
|||
| 11 |
- #' multivariate models, no interaction can be used so that this needs to be `FALSE`.+ #' |
|||
| 12 |
- #' @param ties (`string`)\cr among `exact` (equivalent to `DISCRETE` in SAS), `efron` and `breslow`,+ #' @keywords internal |
|||
| 13 |
- #' see [survival::coxph()]. Note: there is no equivalent of SAS `EXACT` method in R.+ range_noinf <- function(x, na.rm = FALSE, finite = FALSE) { # nolint
|
|||
| 14 |
- #'+ |
|||
| 15 | -+ | 1884x |
- #' @return A `list` of items with names corresponding to the arguments.+ checkmate::assert_numeric(x) |
|
| 16 |
- #'+ |
|||
| 17 | -+ | 1884x |
- #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()].+ if (finite) {
|
|
| 18 | -+ | 24x |
- #'+ x <- x[is.finite(x)] # removes NAs too |
|
| 19 | -+ | 1860x |
- #' @examples+ } else if (na.rm) {
|
|
| 20 | -+ | 708x |
- #' control_coxreg()+ x <- x[!is.na(x)] |
|
| 21 |
- #'+ } |
|||
| 22 |
- #' @export+ |
|||
| 23 | -+ | 1884x |
- control_coxreg <- function(pval_method = c("wald", "likelihood"),
+ if (length(x) == 0) {
|
|
| 24 | -+ | 111x |
- ties = c("exact", "efron", "breslow"),
+ rval <- c(NA, NA) |
|
| 25 | -+ | 111x |
- conf_level = 0.95,+ mode(rval) <- typeof(x) |
|
| 26 |
- interaction = FALSE) {
+ } else {
|
|||
| 27 | -55x | +1773x |
- pval_method <- match.arg(pval_method)+ rval <- c(min(x, na.rm = FALSE), max(x, na.rm = FALSE)) |
|
| 28 | -55x | +
- ties <- match.arg(ties)+ } |
||
| 29 | -55x | +
- checkmate::assert_flag(interaction)+ |
||
| 30 | -55x | +1884x |
- assert_proportion_value(conf_level)+ return(rval) |
|
| 31 | -55x | +
- list(+ } |
||
| 32 | -55x | +
- pval_method = pval_method,+ |
||
| 33 | -55x | +
- ties = ties,+ #' Utility function to create label for confidence interval |
||
| 34 | -55x | +
- conf_level = conf_level,+ #' |
||
| 35 | -55x | +
- interaction = interaction+ #' @description `r lifecycle::badge("stable")`
|
||
| 36 |
- )+ #' |
|||
| 37 |
- }+ #' @inheritParams argument_convention |
|||
| 38 |
-
+ #' |
|||
| 39 |
- #' Custom tidy methods for Cox regression+ #' @return A `string`. |
|||
| 41 |
- #' @description `r lifecycle::badge("stable")`
+ #' @export |
|||
| 42 |
- #'+ f_conf_level <- function(conf_level) {
|
|||
| 43 | -+ | 8277x |
- #' @inheritParams argument_convention+ assert_proportion_value(conf_level) |
|
| 44 | -+ | 8275x |
- #' @param x (`list`)\cr result of the Cox regression model fitted by [fit_coxreg_univar()] (for univariate models)+ paste0(conf_level * 100, "% CI") |
|
| 45 |
- #' or [fit_coxreg_multivar()] (for multivariate models).+ } |
|||
| 46 |
- #'+ |
|||
| 47 |
- #' @return [broom::tidy()] returns:+ #' Utility function to create label for p-value |
|||
| 48 |
- #' * For `summary.coxph` objects, a `data.frame` with columns: `Pr(>|z|)`, `exp(coef)`, `exp(-coef)`, `lower .95`,+ #' |
|||
| 49 |
- #' `upper .95`, `level`, and `n`.+ #' @description `r lifecycle::badge("stable")`
|
|||
| 50 |
- #' * For `coxreg.univar` objects, a `data.frame` with columns: `effect`, `term`, `term_label`, `level`, `n`, `hr`,+ #' |
|||
| 51 |
- #' `lcl`, `ucl`, `pval`, and `ci`.+ #' @param test_mean (`numeric(1)`)\cr mean value to test under the null hypothesis. |
|||
| 52 |
- #' * For `coxreg.multivar` objects, a `data.frame` with columns: `term`, `pval`, `term_label`, `hr`, `lcl`, `ucl`,+ #' |
|||
| 53 |
- #' `level`, and `ci`.+ #' @return A `string`. |
|||
| 55 |
- #' @seealso [cox_regression]+ #' @export |
|||
| 56 |
- #'+ f_pval <- function(test_mean) {
|
|||
| 57 | -+ | 1145x |
- #' @name tidy_coxreg+ checkmate::assert_numeric(test_mean, len = 1) |
|
| 58 | -+ | 1143x |
- NULL+ paste0("p-value (H0: mean = ", test_mean, ")")
|
|
| 59 |
-
+ } |
|||
| 60 |
- #' @describeIn tidy_coxreg Custom tidy method for [survival::coxph()] summary results.+ |
|||
| 61 |
- #'+ #' Utility function to return a named list of covariate names |
|||
| 62 |
- #' Tidy the [survival::coxph()] results into a `data.frame` to extract model results.+ #' |
|||
| 63 |
- #'+ #' @param covariates (`character`)\cr a vector that can contain single variable names (such as |
|||
| 64 |
- #' @method tidy summary.coxph+ #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`. |
|||
| 66 |
- #' @examples+ #' @return A named `list` of `character` vector. |
|||
| 67 |
- #' library(survival)+ #' |
|||
| 68 |
- #' library(broom)+ #' @keywords internal |
|||
| 69 |
- #'+ get_covariates <- function(covariates) {
|
|||
| 70 | -+ | 14x |
- #' set.seed(1, kind = "Mersenne-Twister")+ checkmate::assert_character(covariates) |
|
| 71 | -+ | 12x |
- #'+ cov_vars <- unique(trimws(unlist(strsplit(covariates, "\\*")))) |
|
| 72 | -+ | 12x |
- #' dta_bladder <- with(+ stats::setNames(as.list(cov_vars), cov_vars) |
|
| 73 |
- #' data = bladder[bladder$enum < 5, ],+ } |
|||
| 74 |
- #' data.frame(+ |
|||
| 75 |
- #' time = stop,+ #' Replicate entries of a vector if required |
|||
| 76 |
- #' status = event,+ #' |
|||
| 77 |
- #' armcd = as.factor(rx),+ #' @description `r lifecycle::badge("stable")`
|
|||
| 78 |
- #' covar1 = as.factor(enum),+ #' |
|||
| 79 |
- #' covar2 = factor(+ #' Replicate entries of a vector if required. |
|||
| 80 |
- #' sample(as.factor(enum)),+ #' |
|||
| 81 |
- #' levels = 1:4, labels = c("F", "F", "M", "M")
+ #' @inheritParams argument_convention |
|||
| 82 |
- #' )+ #' @param n (`integer(1)`)\cr number of entries that are needed. |
|||
| 83 |
- #' )+ #' |
|||
| 84 |
- #' )+ #' @return `x` if it has the required length already or is `NULL`, |
|||
| 85 |
- #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
+ #' otherwise if it is scalar the replicated version of it with `n` entries. |
|||
| 86 |
- #' formatters::var_labels(dta_bladder)[names(labels)] <- labels+ #' |
|||
| 87 |
- #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ #' @note This function will fail if `x` is not of length `n` and/or is not a scalar. |
|||
| 89 |
- #' formula <- "survival::Surv(time, status) ~ armcd + covar1"+ #' @export |
|||
| 90 |
- #' msum <- summary(coxph(stats::as.formula(formula), data = dta_bladder))+ to_n <- function(x, n) {
|
|||
| 91 | -+ | 5x |
- #' tidy(msum)+ if (is.null(x)) {
|
|
| 92 | -+ | 1x |
- #'+ NULL |
|
| 93 | -+ | 4x |
- #' @export+ } else if (length(x) == 1) {
|
|
| 94 | -+ | 1x |
- tidy.summary.coxph <- function(x, # nolint+ rep(x, n) |
|
| 95 | -+ | 3x |
- ...) {
+ } else if (length(x) == n) {
|
|
| 96 | -199x | +2x |
- checkmate::assert_class(x, "summary.coxph")+ x |
|
| 97 | -199x | +
- pval <- x$coefficients+ } else {
|
||
| 98 | -199x | +1x |
- confint <- x$conf.int+ stop("dimension mismatch")
|
|
| 99 | -199x | +
- levels <- rownames(pval)+ } |
||
| 100 |
-
+ } |
|||
| 101 | -199x | +
- pval <- tibble::as_tibble(pval)+ |
||
| 102 | -199x | +
- confint <- tibble::as_tibble(confint)+ #' Check element dimension |
||
| 103 |
-
+ #' |
|||
| 104 | -199x | +
- ret <- cbind(pval[, grepl("Pr", names(pval))], confint)
+ #' Checks if the elements in `...` have the same dimension. |
||
| 105 | -199x | +
- ret$level <- levels+ #' |
||
| 106 | -199x | +
- ret$n <- x[["n"]]+ #' @param ... (`data.frame` or `vector`)\cr any data frames or vectors. |
||
| 107 | -199x | +
- ret+ #' @param omit_null (`flag`)\cr whether `NULL` elements in `...` should be omitted from the check. |
||
| 108 |
- }+ #' |
|||
| 109 |
-
+ #' @return A `logical` value. |
|||
| 110 |
- #' @describeIn tidy_coxreg Custom tidy method for a univariate Cox regression.+ #' |
|||
| 111 |
- #'+ #' @keywords internal |
|||
| 112 |
- #' Tidy up the result of a Cox regression model fitted by [fit_coxreg_univar()].+ check_same_n <- function(..., omit_null = TRUE) {
|
|||
| 113 | -+ | 2x |
- #'+ dots <- list(...) |
|
| 114 |
- #' @method tidy coxreg.univar+ |
|||
| 115 | -+ | 2x |
- #'+ n_list <- Map( |
|
| 116 | -+ | 2x |
- #' @examples+ function(x, name) {
|
|
| 117 | -+ | 5x |
- #' ## Cox regression: arm + 1 covariate.+ if (is.null(x)) {
|
|
| 118 | -+ | ! |
- #' mod1 <- fit_coxreg_univar(+ if (omit_null) {
|
|
| 119 | -+ | 2x |
- #' variables = list(+ NA_integer_ |
|
| 120 |
- #' time = "time", event = "status", arm = "armcd",+ } else {
|
|||
| 121 | -+ | ! |
- #' covariates = "covar1"+ stop("arg", name, "is not supposed to be NULL")
|
|
| 122 |
- #' ),+ } |
|||
| 123 | -+ | 5x |
- #' data = dta_bladder,+ } else if (is.data.frame(x)) {
|
|
| 124 | -+ | ! |
- #' control = control_coxreg(conf_level = 0.91)+ nrow(x) |
|
| 125 | -+ | 5x |
- #' )+ } else if (is.atomic(x)) {
|
|
| 126 | -+ | 5x |
- #'+ length(x) |
|
| 127 |
- #' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates.+ } else {
|
|||
| 128 | -+ | ! |
- #' mod2 <- fit_coxreg_univar(+ stop("data structure for ", name, "is currently not supported")
|
|
| 129 |
- #' variables = list(+ } |
|||
| 130 |
- #' time = "time", event = "status", arm = "armcd",+ }, |
|||
| 131 | -+ | 2x |
- #' covariates = c("covar1", "covar2")
+ dots, names(dots) |
|
| 132 |
- #' ),+ ) |
|||
| 133 |
- #' data = dta_bladder,+ |
|||
| 134 | -+ | 2x |
- #' control = control_coxreg(conf_level = 0.91, interaction = TRUE)+ n <- stats::na.omit(unlist(n_list)) |
|
| 135 |
- #' )+ |
|||
| 136 | -+ | 2x |
- #'+ if (length(unique(n)) > 1) {
|
|
| 137 | -+ | ! |
- #' tidy(mod1)+ sel <- which(n != n[1]) |
|
| 138 | -+ | ! |
- #' tidy(mod2)+ stop("Dimension mismatch:", paste(names(n)[sel], collapse = ", "), " do not have N=", n[1])
|
|
| 139 |
- #'+ } |
|||
| 140 |
- #' @export+ |
|||
| 141 | -+ | 2x |
- tidy.coxreg.univar <- function(x, # nolint+ TRUE |
|
| 142 |
- ...) {
+ } |
|||
| 143 | -38x | +
- checkmate::assert_class(x, "coxreg.univar")+ |
||
| 144 | -38x | +
- mod <- x$mod+ #' Utility function to check if a float value is equal to another float value |
||
| 145 | -38x | +
- vars <- c(x$vars$arm, x$vars$covariates)+ #' |
||
| 146 | -38x | +
- has_arm <- "arm" %in% names(x$vars)+ #' Uses `.Machine$double.eps` as the tolerance for the comparison. |
||
| 147 |
-
+ #' |
|||
| 148 | -38x | +
- result <- if (!has_arm) {
+ #' @param x (`numeric(1)`)\cr a float number. |
||
| 149 | -5x | +
- Map(+ #' @param y (`numeric(1)`)\cr a float number. |
||
| 150 | -5x | +
- mod = mod, vars = vars,+ #' |
||
| 151 | -5x | +
- f = function(mod, vars) {
+ #' @return `TRUE` if identical, otherwise `FALSE`. |
||
| 152 | -6x | +
- h_coxreg_multivar_extract(+ #' |
||
| 153 | -6x | +
- var = vars,+ #' @keywords internal |
||
| 154 | -6x | +
- data = x$data,+ .is_equal_float <- function(x, y) {
|
||
| 155 | -6x | +2990x |
- mod = mod,+ checkmate::assert_number(x) |
|
| 156 | -6x | +2990x |
- control = x$control+ checkmate::assert_number(y) |
|
| 157 |
- )+ |
|||
| 158 |
- }+ # Define a tolerance |
|||
| 159 | -+ | 2990x |
- )+ tolerance <- .Machine$double.eps |
|
| 160 | -38x | +
- } else if (x$control$interaction) {
+
|
||
| 161 | -12x | +
- Map(+ # Check if x is close enough to y |
||
| 162 | -12x | +2990x |
- mod = mod, covar = vars,+ abs(x - y) < tolerance |
|
| 163 | -12x | +
- f = function(mod, covar) {
+ } |
||
| 164 | -26x | +
- h_coxreg_extract_interaction(+ |
||
| 165 | -26x | +
- effect = x$vars$arm, covar = covar, mod = mod, data = x$data,+ #' Make names without dots |
||
| 166 | -26x | +
- at = x$at, control = x$control+ #' |
||
| 167 |
- )+ #' @param nams (`character`)\cr vector of original names. |
|||
| 168 |
- }+ #' |
|||
| 169 |
- )+ #' @return A `character` `vector` of proper names, which does not use dots in contrast to [make.names()]. |
|||
| 170 |
- } else {
+ #' |
|||
| 171 | -21x | +
- Map(+ #' @keywords internal |
||
| 172 | -21x | +
- mod = mod, vars = vars,+ make_names <- function(nams) {
|
||
| 173 | -21x | +6x |
- f = function(mod, vars) {
+ orig <- make.names(nams) |
|
| 174 | -53x | +6x |
- h_coxreg_univar_extract(+ gsub(".", "", x = orig, fixed = TRUE)
|
|
| 175 | -53x | +
- effect = x$vars$arm, covar = vars, data = x$data, mod = mod,+ } |
||
| 176 | -53x | +
- control = x$control+ |
||
| 177 |
- )+ #' Conversion of months to days |
|||
| 178 |
- }+ #' |
|||
| 179 |
- )+ #' @description `r lifecycle::badge("stable")`
|
|||
| 180 |
- }+ #' |
|||
| 181 | -38x | +
- result <- do.call(rbind, result)+ #' Conversion of months to days. This is an approximative calculation because it |
||
| 182 |
-
+ #' considers each month as having an average of 30.4375 days. |
|||
| 183 | -38x | +
- result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl))+ #' |
||
| 184 | -38x | +
- result$n <- lapply(result$n, empty_vector_if_na)+ #' @param x (`numeric(1)`)\cr time in months. |
||
| 185 | -38x | +
- result$ci <- lapply(result$ci, empty_vector_if_na)+ #' |
||
| 186 | -38x | +
- result$hr <- lapply(result$hr, empty_vector_if_na)+ #' @return A `numeric` vector with the time in days. |
||
| 187 | -38x | +
- if (x$control$interaction) {
+ #' |
||
| 188 | -12x | +
- result$pval_inter <- lapply(result$pval_inter, empty_vector_if_na)+ #' @examples |
||
| 189 |
- # Remove interaction p-values due to change in specifications.+ #' x <- c(13.25, 8.15, 1, 2.834) |
|||
| 190 | -12x | +
- result$pval[result$effect != "Treatment:"] <- NA+ #' month2day(x) |
||
| 191 |
- }+ #' |
|||
| 192 | -38x | +
- result$pval <- lapply(result$pval, empty_vector_if_na)+ #' @export |
||
| 193 | -38x | +
- attr(result, "conf_level") <- x$control$conf_level+ month2day <- function(x) {
|
||
| 194 | -38x | +1x |
- result+ checkmate::assert_numeric(x) |
|
| 195 | -+ | 1x |
- }+ x * 30.4375 |
|
| 196 |
-
+ } |
|||
| 197 |
- #' @describeIn tidy_coxreg Custom tidy method for a multivariate Cox regression.+ |
|||
| 198 |
- #'+ #' Conversion of days to months |
|||
| 199 |
- #' Tidy up the result of a Cox regression model fitted by [fit_coxreg_multivar()].+ #' |
|||
| 200 |
- #'+ #' @param x (`numeric(1)`)\cr time in days. |
|||
| 201 |
- #' @method tidy coxreg.multivar+ #' |
|||
| 202 |
- #'+ #' @return A `numeric` vector with the time in months. |
|||
| 203 |
- #' @examples+ #' |
|||
| 204 |
- #' multivar_model <- fit_coxreg_multivar(+ #' @examples |
|||
| 205 |
- #' variables = list(+ #' x <- c(403, 248, 30, 86) |
|||
| 206 |
- #' time = "time", event = "status", arm = "armcd",+ #' day2month(x) |
|||
| 207 |
- #' covariates = c("covar1", "covar2")
+ #' |
|||
| 208 |
- #' ),+ #' @export |
|||
| 209 |
- #' data = dta_bladder+ day2month <- function(x) {
|
|||
| 210 | -+ | 19x |
- #' )+ checkmate::assert_numeric(x) |
|
| 211 | -+ | 19x |
- #' broom::tidy(multivar_model)+ x / 30.4375 |
|
| 212 |
- #'+ } |
|||
| 213 |
- #' @export+ |
|||
| 214 |
- tidy.coxreg.multivar <- function(x, # nolint+ #' Return an empty numeric if all elements are `NA`. |
|||
| 215 |
- ...) {
+ #' |
|||
| 216 | -16x | +
- checkmate::assert_class(x, "coxreg.multivar")+ #' @param x (`numeric`)\cr vector. |
||
| 217 | -16x | +
- vars <- c(x$vars$arm, x$vars$covariates)+ #' |
||
| 218 |
-
+ #' @return An empty `numeric` if all elements of `x` are `NA`, otherwise `x`. |
|||
| 219 |
- # Convert the model summaries to data.+ #' |
|||
| 220 | -16x | +
- result <- Map(+ #' @examples |
||
| 221 | -16x | +
- vars = vars,+ #' x <- c(NA, NA, NA) |
||
| 222 | -16x | +
- f = function(vars) {
+ #' # Internal function - empty_vector_if_na |
||
| 223 | -60x | +
- h_coxreg_multivar_extract(+ #' @keywords internal |
||
| 224 | -60x | +
- var = vars, data = x$data,+ empty_vector_if_na <- function(x) {
|
||
| 225 | -60x | +1017x |
- mod = x$mod, control = x$control+ if (all(is.na(x))) {
|
|
| 226 | -+ | 310x |
- )+ numeric() |
|
| 227 |
- }+ } else {
|
|||
| 228 | -+ | 707x |
- )+ x |
|
| 229 | -16x | +
- result <- do.call(rbind, result)+ } |
||
| 230 |
-
+ } |
|||
| 231 | -16x | +
- result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl))+ |
||
| 232 | -16x | +
- result$ci <- lapply(result$ci, empty_vector_if_na)+ #' Element-wise combination of two vectors |
||
| 233 | -16x | +
- result$hr <- lapply(result$hr, empty_vector_if_na)+ #' |
||
| 234 | -16x | +
- result$pval <- lapply(result$pval, empty_vector_if_na)+ #' @param x (`vector`)\cr first vector to combine. |
||
| 235 | -16x | +
- result <- result[, names(result) != "n"]+ #' @param y (`vector`)\cr second vector to combine. |
||
| 236 | -16x | +
- attr(result, "conf_level") <- x$control$conf_level+ #' |
||
| 237 |
-
+ #' @return A `list` where each element combines corresponding elements of `x` and `y`. |
|||
| 238 | -16x | +
- result+ #' |
||
| 239 |
- }+ #' @examples |
|||
| 240 |
-
+ #' combine_vectors(1:3, 4:6) |
|||
| 241 |
- #' Fitting functions for Cox proportional hazards regression+ #' |
|||
| 242 |
- #'+ #' @export |
|||
| 243 |
- #' @description `r lifecycle::badge("stable")`
+ combine_vectors <- function(x, y) {
|
|||
| 244 | -+ | 51x |
- #'+ checkmate::assert_vector(x) |
|
| 245 | -+ | 51x |
- #' Fitting functions for univariate and multivariate Cox regression models.+ checkmate::assert_vector(y, len = length(x)) |
|
| 246 |
- #'+ |
|||
| 247 | -+ | 51x |
- #' @param variables (named `list`)\cr the names of the variables found in `data`, passed as a named list and+ result <- lapply(as.data.frame(rbind(x, y)), `c`) |
|
| 248 | -+ | 51x |
- #' corresponding to the `time`, `event`, `arm`, `strata`, and `covariates` terms. If `arm` is missing from+ names(result) <- NULL |
|
| 249 | -+ | 51x |
- #' `variables`, then only Cox model(s) including the `covariates` will be fitted and the corresponding effect+ result |
|
| 250 |
- #' estimates will be tabulated later.+ } |
|||
| 251 |
- #' @param data (`data.frame`)\cr the dataset containing the variables to fit the models.+ |
|||
| 252 |
- #' @param at (`list` of `numeric`)\cr when the candidate covariate is a `numeric`, use `at` to specify+ #' Extract elements by name |
|||
| 253 |
- #' the value of the covariate at which the effect should be estimated.+ #' |
|||
| 254 |
- #' @param control (`list`)\cr a list of parameters as returned by the helper function [control_coxreg()].+ #' This utility function extracts elements from a vector `x` by `names`. |
|||
| 255 |
- #'+ #' Differences to the standard `[` function are: |
|||
| 256 |
- #' @seealso [h_cox_regression] for relevant helper functions, [cox_regression].+ #' |
|||
| 257 |
- #'+ #' - If `x` is `NULL`, then still always `NULL` is returned (same as in base function). |
|||
| 258 |
- #' @examples+ #' - If `x` is not `NULL`, then the intersection of its names is made with `names` and those |
|||
| 259 |
- #' library(survival)+ #' elements are returned. That is, `names` which don't appear in `x` are not returned as `NA`s. |
|||
| 261 |
- #' set.seed(1, kind = "Mersenne-Twister")+ #' @param x (named `vector`)\cr where to extract named elements from. |
|||
| 262 |
- #'+ #' @param names (`character`)\cr vector of names to extract. |
|||
| 263 |
- #' # Testing dataset [survival::bladder].+ #' |
|||
| 264 |
- #' dta_bladder <- with(+ #' @return `NULL` if `x` is `NULL`, otherwise the extracted elements from `x`. |
|||
| 265 |
- #' data = bladder[bladder$enum < 5, ],+ #' |
|||
| 266 |
- #' data.frame(+ #' @keywords internal |
|||
| 267 |
- #' time = stop,+ extract_by_name <- function(x, names) {
|
|||
| 268 | -+ | 3x |
- #' status = event,+ if (is.null(x)) {
|
|
| 269 | -+ | 1x |
- #' armcd = as.factor(rx),+ return(NULL) |
|
| 270 |
- #' covar1 = as.factor(enum),+ } |
|||
| 271 | -+ | 2x |
- #' covar2 = factor(+ checkmate::assert_named(x) |
|
| 272 | -+ | 2x |
- #' sample(as.factor(enum)),+ checkmate::assert_character(names) |
|
| 273 | -+ | 2x |
- #' levels = 1:4, labels = c("F", "F", "M", "M")
+ which_extract <- intersect(names(x), names) |
|
| 274 | -+ | 2x |
- #' )+ if (length(which_extract) > 0) {
|
|
| 275 | -+ | 1x |
- #' )+ x[which_extract] |
|
| 276 |
- #' )+ } else {
|
|||
| 277 | -+ | 1x |
- #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
+ NULL |
|
| 278 |
- #' formatters::var_labels(dta_bladder)[names(labels)] <- labels+ } |
|||
| 279 |
- #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ } |
|||
| 280 |
- #'+ |
|||
| 281 |
- #' plot(+ #' Labels for adverse event baskets |
|||
| 282 |
- #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder),+ #' |
|||
| 283 |
- #' lty = 2:4,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 284 |
- #' xlab = "Months",+ #' |
|||
| 285 |
- #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
+ #' @param aesi (`character`)\cr vector with standardized MedDRA query name (e.g. `SMQxxNAM`) or customized query |
|||
| 286 |
- #' )+ #' name (e.g. `CQxxNAM`). |
|||
| 287 |
- #'+ #' @param scope (`character`)\cr vector with scope of query (e.g. `SMQxxSC`). |
|||
| 288 |
- #' @name fit_coxreg+ #' |
|||
| 289 |
- NULL+ #' @return A `string` with the standard label for the AE basket. |
|||
| 290 |
-
+ #' |
|||
| 291 |
- #' @describeIn fit_coxreg Fit a series of univariate Cox regression models given the inputs.+ #' @examples |
|||
| 292 |
- #'+ #' adae <- tern_ex_adae |
|||
| 293 |
- #' @return+ #' |
|||
| 294 |
- #' * `fit_coxreg_univar()` returns a `coxreg.univar` class object which is a named `list`+ #' # Standardized query label includes scope. |
|||
| 295 |
- #' with 5 elements:+ #' aesi_label(adae$SMQ01NAM, scope = adae$SMQ01SC) |
|||
| 296 |
- #' * `mod`: Cox regression models fitted by [survival::coxph()].+ #' |
|||
| 297 |
- #' * `data`: The original data frame input.+ #' # Customized query label. |
|||
| 298 |
- #' * `control`: The original control input.+ #' aesi_label(adae$CQ01NAM) |
|||
| 299 |
- #' * `vars`: The variables used in the model.+ #' |
|||
| 300 |
- #' * `at`: Value of the covariate at which the effect should be estimated.+ #' @export |
|||
| 301 |
- #'+ aesi_label <- function(aesi, scope = NULL) {
|
|||
| 302 | -+ | 4x |
- #' @note When using `fit_coxreg_univar` there should be two study arms.+ checkmate::assert_character(aesi) |
|
| 303 | -+ | 4x |
- #'+ checkmate::assert_character(scope, null.ok = TRUE) |
|
| 304 | -+ | 4x |
- #' @examples+ aesi_label <- obj_label(aesi) |
|
| 305 | -+ | 4x |
- #' # fit_coxreg_univar+ aesi <- sas_na(aesi) |
|
| 306 | -+ | 4x |
- #'+ aesi <- unique(aesi)[!is.na(unique(aesi))] |
|
| 307 |
- #' ## Cox regression: arm + 1 covariate.+ |
|||
| 308 | -+ | 4x |
- #' mod1 <- fit_coxreg_univar(+ lbl <- if (length(aesi) == 1 && !is.null(scope)) {
|
|
| 309 | -+ | 1x |
- #' variables = list(+ scope <- sas_na(scope) |
|
| 310 | -+ | 1x |
- #' time = "time", event = "status", arm = "armcd",+ scope <- unique(scope)[!is.na(unique(scope))] |
|
| 311 | -+ | 1x |
- #' covariates = "covar1"+ checkmate::assert_string(scope) |
|
| 312 | -+ | 1x |
- #' ),+ paste0(aesi, " (", scope, ")")
|
|
| 313 | -+ | 4x |
- #' data = dta_bladder,+ } else if (length(aesi) == 1 && is.null(scope)) {
|
|
| 314 | -+ | 1x |
- #' control = control_coxreg(conf_level = 0.91)+ aesi |
|
| 315 |
- #' )+ } else {
|
|||
| 316 | -+ | 2x |
- #'+ aesi_label |
|
| 317 |
- #' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates.+ } |
|||
| 318 |
- #' mod2 <- fit_coxreg_univar(+ |
|||
| 319 | -+ | 4x |
- #' variables = list(+ lbl |
|
| 320 |
- #' time = "time", event = "status", arm = "armcd",+ } |
|||
| 321 |
- #' covariates = c("covar1", "covar2")
+
|
|||
| 322 |
- #' ),+ #' Indicate study arm variable in formula |
|||
| 323 |
- #' data = dta_bladder,+ #' |
|||
| 324 |
- #' control = control_coxreg(conf_level = 0.91, interaction = TRUE)+ #' We use `study_arm` to indicate the study arm variable in `tern` formulas. |
|||
| 325 |
- #' )+ #' |
|||
| 326 |
- #'+ #' @param x arm information |
|||
| 327 |
- #' ## Cox regression: arm + 1 covariate, stratified analysis.+ #' |
|||
| 328 |
- #' mod3 <- fit_coxreg_univar(+ #' @return `x` |
|||
| 329 |
- #' variables = list(+ #' |
|||
| 330 |
- #' time = "time", event = "status", arm = "armcd", strata = "covar2",+ #' @keywords internal |
|||
| 331 |
- #' covariates = c("covar1")
+ study_arm <- function(x) {
|
|||
| 332 | -+ | ! |
- #' ),+ structure(x, varname = deparse(substitute(x))) |
|
| 333 |
- #' data = dta_bladder,+ } |
|||
| 334 |
- #' control = control_coxreg(conf_level = 0.91)+ |
|||
| 335 |
- #' )+ #' Smooth function with optional grouping |
|||
| 337 |
- #' ## Cox regression: no arm, only covariates.+ #' @description `r lifecycle::badge("stable")`
|
|||
| 338 |
- #' mod4 <- fit_coxreg_univar(+ #' |
|||
| 339 |
- #' variables = list(+ #' This produces `loess` smoothed estimates of `y` with Student confidence intervals. |
|||
| 340 |
- #' time = "time", event = "status",+ #' |
|||
| 341 |
- #' covariates = c("covar1", "covar2")
+ #' @param df (`data.frame`)\cr data set containing all analysis variables. |
|||
| 342 |
- #' ),+ #' @param x (`string`)\cr x column name. |
|||
| 343 |
- #' data = dta_bladder+ #' @param y (`string`)\cr y column name. |
|||
| 344 |
- #' )+ #' @param groups (`character` or `NULL`)\cr vector with optional grouping variables names. |
|||
| 345 |
- #'+ #' @param level (`proportion`)\cr level of confidence interval to use (0.95 by default). |
|||
| 346 |
- #' @export+ #' |
|||
| 347 |
- fit_coxreg_univar <- function(variables,+ #' @return A `data.frame` with original `x`, smoothed `y`, `ylow`, and `yhigh`, and |
|||
| 348 |
- data,+ #' optional `groups` variables formatted as `factor` type. |
|||
| 349 |
- at = list(),+ #' |
|||
| 350 |
- control = control_coxreg()) {
+ #' @export |
|||
| 351 | -43x | +
- checkmate::assert_list(variables, names = "named")+ get_smooths <- function(df, x, y, groups = NULL, level = 0.95) {
|
||
| 352 | -43x | +5x |
- has_arm <- "arm" %in% names(variables)+ checkmate::assert_data_frame(df) |
|
| 353 | -43x | +5x |
- arm_name <- if (has_arm) "arm" else NULL+ df_cols <- colnames(df) |
|
| 354 | -+ | 5x |
-
+ checkmate::assert_string(x) |
|
| 355 | -43x | +5x |
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ checkmate::assert_subset(x, df_cols) |
|
| 356 | -+ | 5x |
-
+ checkmate::assert_numeric(df[[x]]) |
|
| 357 | -43x | +5x |
- assert_df_with_variables(data, variables)+ checkmate::assert_string(y) |
|
| 358 | -43x | +5x |
- assert_list_of_variables(variables[c(arm_name, "event", "time")])+ checkmate::assert_subset(y, df_cols) |
|
| 359 | -+ | 5x |
-
+ checkmate::assert_numeric(df[[y]]) |
|
| 360 | -43x | +
- if (!is.null(variables$strata)) {
+
|
||
| 361 | -4x | +5x |
- checkmate::assert_disjunct(control$pval_method, "likelihood")+ if (!is.null(groups)) {
|
|
| 362 | -+ | 4x |
- }+ checkmate::assert_character(groups) |
|
| 363 | -42x | +4x |
- if (has_arm) {
+ checkmate::assert_subset(groups, df_cols) |
|
| 364 | -36x | +
- assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ } |
||
| 365 |
- }+ |
|||
| 366 | -41x | +5x |
- vars <- unlist(variables[c(arm_name, "covariates", "strata")], use.names = FALSE)+ smooths <- function(x, y) {
|
|
| 367 | -41x | +18x |
- for (i in vars) {
+ stats::predict(stats::loess(y ~ x), se = TRUE) |
|
| 368 | -94x | +
- if (is.factor(data[[i]])) {
+ } |
||
| 369 | -82x | +
- attr(data[[i]], "levels") <- levels(droplevels(data[[i]]))+ |
||
| 370 | -+ | 5x |
- }+ if (!is.null(groups)) {
|
|
| 371 | -+ | 4x |
- }+ cc <- stats::complete.cases(df[c(x, y, groups)]) |
|
| 372 | -41x | +4x |
- forms <- h_coxreg_univar_formulas(variables, interaction = control$interaction)+ df_c <- df[cc, c(x, y, groups)] |
|
| 373 | -41x | +4x |
- mod <- lapply(+ df_c_ordered <- df_c[do.call("order", as.list(df_c[, groups, drop = FALSE])), , drop = FALSE]
|
|
| 374 | -41x | +4x |
- forms, function(x) {
+ df_c_g <- data.frame(Map(as.factor, df_c_ordered[groups])) |
|
| 375 | -90x | +
- survival::coxph(formula = stats::as.formula(x), data = data, ties = control$ties)+ |
||
| 376 | -+ | 4x |
- }+ df_smooth_raw <- |
|
| 377 | -+ | 4x |
- )+ by(df_c_ordered, df_c_g, function(d) {
|
|
| 378 | -41x | +17x |
- structure(+ plx <- smooths(d[[x]], d[[y]]) |
|
| 379 | -41x | +17x |
- list(+ data.frame( |
|
| 380 | -41x | +17x |
- mod = mod,+ x = d[[x]], |
|
| 381 | -41x | +17x |
- data = data,+ y = plx$fit, |
|
| 382 | -41x | +17x |
- control = control,+ ylow = plx$fit - stats::qt(level, plx$df) * plx$se.fit, |
|
| 383 | -41x | +17x |
- vars = variables,+ yhigh = plx$fit + stats::qt(level, plx$df) * plx$se.fit |
|
| 384 | -41x | +
- at = at+ ) |
||
| 385 |
- ),+ }) |
|||
| 386 | -41x | +
- class = "coxreg.univar"+ |
||
| 387 | -+ | 4x |
- )+ df_smooth <- do.call(rbind, df_smooth_raw) |
|
| 388 | -+ | 4x |
- }+ df_smooth[groups] <- df_c_g |
|
| 390 | -+ | 4x |
- #' @describeIn fit_coxreg Fit a multivariate Cox regression model.+ df_smooth |
|
| 391 |
- #'+ } else {
|
|||
| 392 | -+ | 1x |
- #' @return+ cc <- stats::complete.cases(df[c(x, y)]) |
|
| 393 | -+ | 1x |
- #' * `fit_coxreg_multivar()` returns a `coxreg.multivar` class object which is a named list+ df_c <- df[cc, ] |
|
| 394 | -+ | 1x |
- #' with 4 elements:+ plx <- smooths(df_c[[x]], df_c[[y]]) |
|
| 395 |
- #' * `mod`: Cox regression model fitted by [survival::coxph()].+ |
|||
| 396 | -+ | 1x |
- #' * `data`: The original data frame input.+ df_smooth <- data.frame( |
|
| 397 | -+ | 1x |
- #' * `control`: The original control input.+ x = df_c[[x]], |
|
| 398 | -+ | 1x |
- #' * `vars`: The variables used in the model.+ y = plx$fit, |
|
| 399 | -+ | 1x |
- #'+ ylow = plx$fit - stats::qt(level, plx$df) * plx$se.fit, |
|
| 400 | -+ | 1x |
- #' @examples+ yhigh = plx$fit + stats::qt(level, plx$df) * plx$se.fit |
|
| 401 |
- #' # fit_coxreg_multivar+ ) |
|||
| 402 |
- #'+ |
|||
| 403 | -+ | 1x |
- #' ## Cox regression: multivariate Cox regression.+ df_smooth |
|
| 404 |
- #' multivar_model <- fit_coxreg_multivar(+ } |
|||
| 405 |
- #' variables = list(+ } |
|||
| 406 |
- #' time = "time", event = "status", arm = "armcd",+ |
|||
| 407 |
- #' covariates = c("covar1", "covar2")
+ #' Number of available (non-missing entries) in a vector |
|||
| 408 |
- #' ),+ #' |
|||
| 409 |
- #' data = dta_bladder+ #' Small utility function for better readability. |
|||
| 410 |
- #' )+ #' |
|||
| 411 |
- #'+ #' @param x (`vector`)\cr vector in which to count non-missing values. |
|||
| 412 |
- #' # Example without treatment arm.+ #' |
|||
| 413 |
- #' multivar_covs_model <- fit_coxreg_multivar(+ #' @return Number of non-missing values. |
|||
| 414 |
- #' variables = list(+ #' |
|||
| 415 |
- #' time = "time", event = "status",+ #' @keywords internal |
|||
| 416 |
- #' covariates = c("covar1", "covar2")
+ n_available <- function(x) {
|
|||
| 417 | -+ | 355x |
- #' ),+ sum(!is.na(x)) |
|
| 418 |
- #' data = dta_bladder+ } |
|||
| 419 |
- #' )+ |
|||
| 420 |
- #'+ #' Reapply variable labels |
|||
| 421 |
- #' @export+ #' |
|||
| 422 |
- fit_coxreg_multivar <- function(variables,+ #' This is a helper function that is used in tests. |
|||
| 423 |
- data,+ #' |
|||
| 424 |
- control = control_coxreg()) {
- |
- |||
| 425 | -83x | -
- checkmate::assert_list(variables, names = "named")- |
- ||
| 426 | -83x | -
- has_arm <- "arm" %in% names(variables)- |
- ||
| 427 | -83x | -
- arm_name <- if (has_arm) "arm" else NULL+ #' @param x (`vector`)\cr vector of elements that needs new labels. |
||
| 428 | +425 | - - | -||
| 429 | -83x | -
- if (!is.null(variables$covariates)) {
- |
- ||
| 430 | -21x | -
- checkmate::assert_character(variables$covariates)+ #' @param varlabels (`character`)\cr vector of labels for `x`. |
||
| 431 | +426 |
- }+ #' @param ... further parameters to be added to the list. |
||
| 432 | +427 | - - | -||
| 433 | -83x | -
- checkmate::assert_false(control$interaction)- |
- ||
| 434 | -83x | -
- assert_df_with_variables(data, variables)- |
- ||
| 435 | -83x | -
- assert_list_of_variables(variables[c(arm_name, "event", "time")])+ #' |
||
| 436 | +428 | - - | -||
| 437 | -83x | -
- if (!is.null(variables$strata)) {
- |
- ||
| 438 | -3x | -
- checkmate::assert_disjunct(control$pval_method, "likelihood")+ #' @return `x` with variable labels reapplied. |
||
| 439 | +429 |
- }+ #' |
||
| 440 | +430 | - - | -||
| 441 | -82x | -
- form <- h_coxreg_multivar_formula(variables)- |
- ||
| 442 | -82x | -
- mod <- survival::coxph(- |
- ||
| 443 | -82x | -
- formula = stats::as.formula(form),- |
- ||
| 444 | -82x | -
- data = data,- |
- ||
| 445 | -82x | -
- ties = control$ties+ #' @export |
||
| 446 | +431 |
- )- |
- ||
| 447 | -82x | -
- structure(- |
- ||
| 448 | -82x | -
- list(- |
- ||
| 449 | -82x | -
- mod = mod,- |
- ||
| 450 | -82x | -
- data = data,+ reapply_varlabels <- function(x, varlabels, ...) {
|
||
| 451 | -82x | +432 | +11x |
- control = control,+ named_labels <- c(as.list(varlabels), list(...)) |
| 452 | -82x | -
- vars = variables- |
- ||
| 453 | -+ | 433 | +11x |
- ),+ formatters::var_labels(x)[names(named_labels)] <- as.character(named_labels) |
| 454 | -82x | -
- class = "coxreg.multivar"- |
- ||
| 455 | -+ | 434 | +11x |
- )+ x |
| 456 | +435 |
} |
||
| 457 | +436 | |||
| 458 | -- |
- #' Muffled `car::Anova`- |
- ||
| 459 | -- |
- #'- |
- ||
| 460 | -- |
- #' Applied on survival models, [car::Anova()] signal that the `strata` terms is dropped from the model formula when- |
- ||
| 461 | -- |
- #' present, this function deliberately muffles this message.- |
- ||
| 462 | -- |
- #'- |
- ||
| 463 | -- |
- #' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()].- |
- ||
| 464 | -- |
- #' @param test_statistic (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`.- |
- ||
| 465 | -- |
- #'- |
- ||
| 466 | -- |
- #' @return The output of [car::Anova()], with convergence message muffled.- |
- ||
| 467 | -- |
- #'- |
- ||
| 468 | +437 |
- #' @keywords internal+ # Wrapper function of survival::clogit so that when model fitting failed, a more useful message would show |
||
| 469 | +438 |
- muffled_car_anova <- function(mod, test_statistic) {
+ clogit_with_tryCatch <- function(formula, data, ...) { # nolint
|
||
| 470 | -219x | +439 | +33x |
tryCatch( |
| 471 | -219x | -
- withCallingHandlers(- |
- ||
| 472 | -219x | -
- expr = {
- |
- ||
| 473 | -219x | -
- car::Anova(- |
- ||
| 474 | -219x | -
- mod,- |
- ||
| 475 | -219x | -
- test.statistic = test_statistic,- |
- ||
| 476 | -219x | -
- type = "III"- |
- ||
| 477 | -- |
- )- |
- ||
| 478 | -- |
- },- |
- ||
| 479 | -219x | -
- message = function(m) invokeRestart("muffleMessage"),
- |
- ||
| 480 | -219x | -
- error = function(e) {
- |
- ||
| 481 | -1x | -
- stop(paste(- |
- ||
| 482 | -1x | -
- "the model seems to have convergence problems, please try to change",- |
- ||
| 483 | -1x | -
- "the configuration of covariates or strata variables, e.g.",- |
- ||
| 484 | -1x | -
- "- original error:", e- |
- ||
| 485 | -- |
- ))- |
- ||
| 486 | -+ | 440 | +33x |
- }+ survival::clogit(formula = formula, data = data, ...), |
| 487 | -+ | |||
| 441 | +33x |
- )+ error = function(e) stop("model not built successfully with survival::clogit")
|
||
| 488 | +442 |
) |
||
| 489 | +443 |
}@@ -100591,14 +103444,14 @@ tern coverage - 95.59% |
| 1 |
- #' Confidence interval for mean+ #' Convert list of groups to a data frame |
|||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' This converts a list of group levels into a data frame format which is expected by [rtables::add_combo_levels()]. |
|||
| 5 |
- #' Convenient function for calculating the mean confidence interval. It calculates the arithmetic as well as the+ #' @param groups_list (named `list` of `character`)\cr specifies the new group levels via the names and the |
|||
| 6 |
- #' geometric mean. It can be used as a `ggplot` helper function for plotting.+ #' levels that belong to it in the character vectors that are elements of the list. |
|||
| 8 |
- #' @inheritParams argument_convention+ #' @return A `tibble` in the required format. |
|||
| 9 |
- #' @param n_min (`numeric(1)`)\cr a minimum number of non-missing `x` to estimate the confidence interval for mean.+ #' |
|||
| 10 |
- #' @param gg_helper (`flag`)\cr whether output should be aligned for use with `ggplot`s.+ #' @examples |
|||
| 11 |
- #' @param geom_mean (`flag`)\cr whether the geometric mean should be calculated.+ #' grade_groups <- list( |
|||
| 12 |
- #'+ #' "Any Grade (%)" = c("1", "2", "3", "4", "5"),
|
|||
| 13 |
- #' @return A named `vector` of values `mean_ci_lwr` and `mean_ci_upr`.+ #' "Grade 3-4 (%)" = c("3", "4"),
|
|||
| 14 |
- #'+ #' "Grade 5 (%)" = "5" |
|||
| 15 |
- #' @examples+ #' ) |
|||
| 16 |
- #' stat_mean_ci(sample(10), gg_helper = FALSE)+ #' groups_list_to_df(grade_groups) |
|||
| 18 |
- #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) ++ #' @export |
|||
| 19 |
- #' ggplot2::geom_point()+ groups_list_to_df <- function(groups_list) {
|
|||
| 20 | -+ | 5x |
- #'+ checkmate::assert_list(groups_list, names = "named") |
|
| 21 | -+ | 5x |
- #' p + ggplot2::stat_summary(+ lapply(groups_list, checkmate::assert_character) |
|
| 22 | -+ | 5x |
- #' fun.data = stat_mean_ci,+ tibble::tibble( |
|
| 23 | -+ | 5x |
- #' geom = "errorbar"+ valname = make_names(names(groups_list)), |
|
| 24 | -+ | 5x |
- #' )+ label = names(groups_list), |
|
| 25 | -+ | 5x |
- #'+ levelcombo = unname(groups_list), |
|
| 26 | -+ | 5x |
- #' p + ggplot2::stat_summary(+ exargs = replicate(length(groups_list), list()) |
|
| 27 |
- #' fun.data = stat_mean_ci,+ ) |
|||
| 28 |
- #' fun.args = list(conf_level = 0.5),+ } |
|||
| 29 |
- #' geom = "errorbar"+ |
|||
| 30 |
- #' )+ #' Reference and treatment group combination |
|||
| 32 |
- #' p + ggplot2::stat_summary(+ #' @description `r lifecycle::badge("stable")`
|
|||
| 33 |
- #' fun.data = stat_mean_ci,+ #' |
|||
| 34 |
- #' fun.args = list(conf_level = 0.5, geom_mean = TRUE),+ #' Facilitate the re-combination of groups divided as reference and treatment groups; it helps in arranging groups of |
|||
| 35 |
- #' geom = "errorbar"+ #' columns in the `rtables` framework and teal modules. |
|||
| 36 |
- #' )+ #' |
|||
| 37 |
- #'+ #' @param fct (`factor`)\cr the variable with levels which needs to be grouped. |
|||
| 38 |
- #' @export+ #' @param ref (`character`)\cr the reference level(s). |
|||
| 39 |
- stat_mean_ci <- function(x,+ #' @param collapse (`string`)\cr a character string to separate `fct` and `ref`. |
|||
| 40 |
- conf_level = 0.95,+ #' |
|||
| 41 |
- na.rm = TRUE, # nolint+ #' @return A `list` with first item `ref` (reference) and second item `trt` (treatment). |
|||
| 42 |
- n_min = 2,+ #' |
|||
| 43 |
- gg_helper = TRUE,+ #' @examples |
|||
| 44 |
- geom_mean = FALSE) {
+ #' groups <- combine_groups( |
|||
| 45 | -2295x | +
- if (na.rm) {
+ #' fct = DM$ARM, |
||
| 46 | -10x | +
- x <- stats::na.omit(x)+ #' ref = c("B: Placebo")
|
||
| 47 |
- }+ #' ) |
|||
| 48 | -2295x | +
- n <- length(x)+ #' |
||
| 49 |
-
+ #' basic_table() %>% |
|||
| 50 | -2295x | +
- if (!geom_mean) {
+ #' split_cols_by_groups("ARM", groups) %>%
|
||
| 51 | -1155x | +
- m <- mean(x)+ #' add_colcounts() %>% |
||
| 52 |
- } else {
+ #' analyze_vars("AGE") %>%
|
|||
| 53 | -1140x | +
- negative_values_exist <- any(is.na(x[!is.na(x)]) <- x[!is.na(x)] <= 0)+ #' build_table(DM) |
||
| 54 | -1140x | +
- if (negative_values_exist) {
+ #' |
||
| 55 | -24x | +
- m <- NA_real_+ #' @export |
||
| 56 |
- } else {
+ combine_groups <- function(fct, |
|||
| 57 | -1116x | +
- x <- log(x)+ ref = NULL, |
||
| 58 | -1116x | +
- m <- mean(x)+ collapse = "/") {
|
||
| 59 | -+ | 10x |
- }+ checkmate::assert_string(collapse) |
|
| 60 | -+ | 10x |
- }+ 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 | -2295x | +
- if (n < n_min || is.na(m)) {
+
|
||
| 63 | -304x | +10x |
- ci <- c(mean_ci_lwr = NA_real_, mean_ci_upr = NA_real_)+ fct <- as_factor_keep_attributes(fct) |
|
| 64 |
- } else {
+
|
|||
| 65 | -1991x | +10x |
- hci <- stats::qt((1 + conf_level) / 2, df = n - 1) * stats::sd(x) / sqrt(n)+ group_levels <- levels(fct) |
|
| 66 | -1991x | +10x |
- ci <- c(mean_ci_lwr = m - hci, mean_ci_upr = m + hci)+ if (is.null(ref)) {
|
|
| 67 | -1991x | +6x |
- if (geom_mean) {
+ ref <- group_levels[1] |
|
| 68 | -985x | +
- ci <- exp(ci)+ } else {
|
||
| 69 | -+ | 4x |
- }+ checkmate::assert_subset(ref, group_levels) |
|
| 72 | -2295x | +10x |
- if (gg_helper) {
+ groups <- list( |
|
| 73 | -4x | +10x |
- m <- ifelse(is.na(m), NA_real_, m)+ ref = group_levels[group_levels %in% ref], |
|
| 74 | -4x | +10x |
- ci <- data.frame(y = ifelse(geom_mean, exp(m), m), ymin = ci[[1]], ymax = ci[[2]])+ trt = group_levels[!group_levels %in% ref] |
|
| 75 |
- }+ ) |
|||
| 76 | -+ | 10x |
-
+ stats::setNames(groups, nm = lapply(groups, paste, collapse = collapse)) |
|
| 77 | -2295x | +
- return(ci)+ } |
||
| 78 |
- }+ |
|||
| 79 |
-
+ #' Split columns by groups of levels |
|||
| 80 |
- #' Confidence interval for median+ #' |
|||
| 81 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
|||
| 82 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
|||
| 83 |
- #'+ #' @inheritParams argument_convention |
|||
| 84 |
- #' Convenient function for calculating the median confidence interval. It can be used as a `ggplot` helper+ #' @inheritParams groups_list_to_df |
|||
| 85 |
- #' function for plotting.+ #' @param ... additional arguments to [rtables::split_cols_by()] in order. For instance, to |
|||
| 86 |
- #'+ #' control formats (`format`), add a joint column for all groups (`incl_all`). |
|||
| 87 |
- #' @inheritParams argument_convention+ #' |
|||
| 88 |
- #' @param gg_helper (`flag`)\cr whether output should be aligned for use with `ggplot`s.+ #' @return A layout object suitable for passing to further layouting functions. Adding |
|||
| 89 |
- #'+ #' this function to an `rtable` layout will add a column split including the given |
|||
| 90 |
- #' @details This function was adapted from `DescTools/versions/0.99.35/source`+ #' groups to the table layout. |
|||
| 92 |
- #' @return A named `vector` of values `median_ci_lwr` and `median_ci_upr`.+ #' @seealso [rtables::split_cols_by()] |
|||
| 95 |
- #' stat_median_ci(sample(10), gg_helper = FALSE)+ #' # 1 - Basic use |
|||
| 97 |
- #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) ++ #' # Without group combination `split_cols_by_groups` is |
|||
| 98 |
- #' ggplot2::geom_point()+ #' # equivalent to [rtables::split_cols_by()]. |
|||
| 99 |
- #' p + ggplot2::stat_summary(+ #' basic_table() %>% |
|||
| 100 |
- #' fun.data = stat_median_ci,+ #' split_cols_by_groups("ARM") %>%
|
|||
| 101 |
- #' geom = "errorbar"+ #' add_colcounts() %>% |
|||
| 102 |
- #' )+ #' analyze("AGE") %>%
|
|||
| 103 |
- #'+ #' build_table(DM) |
|||
| 104 |
- #' @export+ #' |
|||
| 105 |
- stat_median_ci <- function(x,+ #' # Add a reference column. |
|||
| 106 |
- conf_level = 0.95,+ #' basic_table() %>% |
|||
| 107 |
- na.rm = TRUE, # nolint+ #' split_cols_by_groups("ARM", ref_group = "B: Placebo") %>%
|
|||
| 108 |
- gg_helper = TRUE) {
+ #' add_colcounts() %>% |
|||
| 109 | -1153x | +
- x <- unname(x)+ #' analyze( |
||
| 110 | -1153x | +
- if (na.rm) {
+ #' "AGE", |
||
| 111 | -9x | +
- x <- x[!is.na(x)]+ #' afun = function(x, .ref_group, .in_ref_col) {
|
||
| 112 |
- }+ #' if (.in_ref_col) {
|
|||
| 113 | -1153x | +
- n <- length(x)+ #' in_rows("Diff Mean" = rcell(NULL))
|
||
| 114 | -1153x | +
- med <- stats::median(x)+ #' } else {
|
||
| 115 |
-
+ #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
|
|||
| 116 | -1153x | +
- k <- stats::qbinom(p = (1 - conf_level) / 2, size = n, prob = 0.5, lower.tail = TRUE)+ #' } |
||
| 117 |
-
+ #' } |
|||
| 118 |
- # k == 0 - for small samples (e.g. n <= 5) ci can be outside the observed range+ #' ) %>% |
|||
| 119 | -1153x | +
- if (k == 0 || is.na(med)) {
+ #' build_table(DM) |
||
| 120 | -248x | +
- ci <- c(median_ci_lwr = NA_real_, median_ci_upr = NA_real_)+ #' |
||
| 121 | -248x | +
- empir_conf_level <- NA_real_+ #' # 2 - Adding group specification |
||
| 122 |
- } else {
+ #' |
|||
| 123 | -905x | +
- x_sort <- sort(x)+ #' # Manual preparation of the groups. |
||
| 124 | -905x | +
- ci <- c(median_ci_lwr = x_sort[k], median_ci_upr = x_sort[n - k + 1])+ #' groups <- list( |
||
| 125 | -905x | +
- empir_conf_level <- 1 - 2 * stats::pbinom(k - 1, size = n, prob = 0.5)+ #' "Arms A+B" = c("A: Drug X", "B: Placebo"),
|
||
| 126 |
- }+ #' "Arms A+C" = c("A: Drug X", "C: Combination")
|
|||
| 127 |
-
+ #' ) |
|||
| 128 | -1153x | +
- if (gg_helper) {
+ #' |
||
| 129 | -4x | +
- ci <- data.frame(y = med, ymin = ci[[1]], ymax = ci[[2]])+ #' # Use of split_cols_by_groups without reference column. |
||
| 130 |
- }+ #' basic_table() %>% |
|||
| 131 |
-
+ #' split_cols_by_groups("ARM", groups) %>%
|
|||
| 132 | -1153x | +
- attr(ci, "conf_level") <- empir_conf_level+ #' add_colcounts() %>% |
||
| 133 |
-
+ #' analyze("AGE") %>%
|
|||
| 134 | -1153x | +
- return(ci)+ #' build_table(DM) |
||
| 135 |
- }+ #' |
|||
| 136 |
-
+ #' # Including differentiated output in the reference column. |
|||
| 137 |
- #' p-Value of the mean+ #' basic_table() %>% |
|||
| 138 |
- #'+ #' split_cols_by_groups("ARM", groups_list = groups, ref_group = "Arms A+B") %>%
|
|||
| 139 |
- #' @description `r lifecycle::badge("stable")`
+ #' analyze( |
|||
| 140 |
- #'+ #' "AGE", |
|||
| 141 |
- #' Convenient function for calculating the two-sided p-value of the mean.+ #' afun = function(x, .ref_group, .in_ref_col) {
|
|||
| 142 |
- #'+ #' if (.in_ref_col) {
|
|||
| 143 |
- #' @inheritParams argument_convention+ #' in_rows("Diff. of Averages" = rcell(NULL))
|
|||
| 144 |
- #' @param n_min (`numeric(1)`)\cr a minimum number of non-missing `x` to estimate the p-value of the mean.+ #' } else {
|
|||
| 145 |
- #' @param test_mean (`numeric(1)`)\cr mean value to test under the null hypothesis.+ #' in_rows("Diff. of Averages" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
|
|||
| 146 |
- #'+ #' } |
|||
| 147 |
- #' @return A p-value.+ #' } |
|||
| 148 |
- #'+ #' ) %>% |
|||
| 149 |
- #' @examples+ #' build_table(DM) |
|||
| 150 |
- #' stat_mean_pval(sample(10))+ #' |
|||
| 151 |
- #'+ #' # 3 - Binary list dividing factor levels into reference and treatment |
|||
| 152 |
- #' stat_mean_pval(rnorm(10), test_mean = 0.5)+ #' |
|||
| 153 |
- #'+ #' # `combine_groups` defines reference and treatment. |
|||
| 154 |
- #' @export+ #' groups <- combine_groups( |
|||
| 155 |
- stat_mean_pval <- function(x,+ #' fct = DM$ARM, |
|||
| 156 |
- na.rm = TRUE, # nolint+ #' ref = c("A: Drug X", "B: Placebo")
|
|||
| 157 |
- n_min = 2,+ #' ) |
|||
| 158 |
- test_mean = 0) {
+ #' groups |
|||
| 159 | -1153x | +
- if (na.rm) {
+ #' |
||
| 160 | -9x | +
- x <- stats::na.omit(x)+ #' # Use group definition without reference column. |
||
| 161 |
- }+ #' basic_table() %>% |
|||
| 162 | -1153x | +
- n <- length(x)+ #' split_cols_by_groups("ARM", groups_list = groups) %>%
|
||
| 163 |
-
+ #' add_colcounts() %>% |
|||
| 164 | -1153x | +
- x_mean <- mean(x)+ #' analyze("AGE") %>%
|
||
| 165 | -1153x | +
- x_sd <- stats::sd(x)+ #' build_table(DM) |
||
| 166 |
-
+ #' |
|||
| 167 | -1153x | +
- if (n < n_min) {
+ #' # Use group definition with reference column (first item of groups). |
||
| 168 | -140x | +
- pv <- c(p_value = NA_real_)+ #' basic_table() %>% |
||
| 169 |
- } else {
+ #' split_cols_by_groups("ARM", groups, ref_group = names(groups)[1]) %>%
|
|||
| 170 | -1013x | +
- x_se <- stats::sd(x) / sqrt(n)+ #' add_colcounts() %>% |
||
| 171 | -1013x | +
- ttest <- (x_mean - test_mean) / x_se+ #' analyze( |
||
| 172 | -1013x | +
- pv <- c(p_value = 2 * stats::pt(-abs(ttest), df = n - 1))+ #' "AGE", |
||
| 173 |
- }+ #' afun = function(x, .ref_group, .in_ref_col) {
|
|||
| 174 |
-
+ #' if (.in_ref_col) {
|
|||
| 175 | -1153x | +
- return(pv)+ #' in_rows("Diff Mean" = rcell(NULL))
|
||
| 176 |
- }+ #' } else {
|
|||
| 177 |
-
+ #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
|
|||
| 178 |
- #' Proportion difference and confidence interval+ #' } |
|||
| 179 |
- #'+ #' } |
|||
| 180 |
- #' @description `r lifecycle::badge("stable")`
+ #' ) %>% |
|||
| 181 |
- #'+ #' build_table(DM) |
|||
| 182 |
- #' Function for calculating the proportion (or risk) difference and confidence interval between arm+ #' |
|||
| 183 |
- #' X (reference group) and arm Y. Risk difference is calculated by subtracting cumulative incidence+ #' @export |
|||
| 184 |
- #' in arm Y from cumulative incidence in arm X.+ split_cols_by_groups <- function(lyt, |
|||
| 185 |
- #'+ var, |
|||
| 186 |
- #' @inheritParams argument_convention+ groups_list = NULL, |
|||
| 187 |
- #' @param x (`list` of `integer`)\cr list of number of occurrences in arm X (reference group).+ ref_group = NULL, |
|||
| 188 |
- #' @param y (`list` of `integer`)\cr list of number of occurrences in arm Y. Must be of equal length to `x`.+ ...) {
|
|||
| 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,+ |
+ ||
| 194 |
- #' @param N_x (`numeric(1)`)\cr total number of records in arm X.+ ... |
|||
| 190 | +195 |
- #' @param N_y (`numeric(1)`)\cr total number of records in arm Y.+ ) |
||
| 191 | +196 |
- #' @param list_names (`character`)\cr names of each variable/level corresponding to pair of proportions in+ } 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] |
||
| 192 | +200 |
- #' `x` and `y`. Must be of equal length to `x` and `y`.+ }+ |
+ ||
| 201 | +4x | +
+ split_cols_by(+ |
+ ||
| 202 | +4x | +
+ lyt = lyt,+ |
+ ||
| 203 | +4x | +
+ var = var,+ |
+ ||
| 204 | +4x | +
+ split_fun = add_combo_levels(groups_df, keep_levels = groups_df$valname),+ |
+ ||
| 205 | +4x | +
+ ref_group = ref_group, |
||
| 193 | +206 |
- #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`.+ ... |
||
| 194 | +207 | ++ |
+ )+ |
+ |
| 208 | ++ |
+ }+ |
+ ||
| 209 | ++ |
+ }+ |
+ ||
| 210 | ++ | + + | +||
| 211 | ++ |
+ #' Combine counts+ |
+ ||
| 212 |
#' |
|||
| 195 | +213 |
- #' @return List of proportion differences and CIs corresponding to each pair of number of occurrences in `x` and+ #' Simplifies the estimation of column counts, especially when group combination is required. |
||
| 196 | +214 |
- #' `y`. Each list element consists of 3 statistics: proportion difference, CI lower bound, and CI upper bound.+ #' |
||
| 197 | +215 | ++ |
+ #' @inheritParams combine_groups+ |
+ |
| 216 | ++ |
+ #' @inheritParams groups_list_to_df+ |
+ ||
| 217 |
#' |
|||
| 198 | +218 |
- #' @seealso Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()]+ #' @return A `vector` of column counts. |
||
| 199 | +219 |
- #' with `riskdiff` argument is set to `TRUE` in subsequent analyze functions, adds a column containing+ #' |
||
| 200 | +220 |
- #' proportion (risk) difference to an `rtables` layout.+ #' @seealso [combine_groups()] |
||
| 201 | +221 |
#' |
||
| 202 | +222 |
#' @examples |
||
| 203 | +223 |
- #' stat_propdiff_ci(+ #' ref <- c("A: Drug X", "B: Placebo")
|
||
| 204 | +224 |
- #' x = list(0.375), y = list(0.01), N_x = 5, N_y = 5, list_names = "x", conf_level = 0.9+ #' groups <- combine_groups(fct = DM$ARM, ref = ref) |
||
| 205 | +225 | ++ |
+ #'+ |
+ |
| 226 | ++ |
+ #' col_counts <- combine_counts(+ |
+ ||
| 227 | ++ |
+ #' fct = DM$ARM,+ |
+ ||
| 228 | ++ |
+ #' groups_list = groups+ |
+ ||
| 229 |
#' ) |
|||
| 206 | +230 |
#' |
||
| 207 | +231 |
- #' stat_propdiff_ci(+ #' basic_table() %>% |
||
| 208 | +232 |
- #' x = list(0.5, 0.75, 1), y = list(0.25, 0.05, 0.5), N_x = 10, N_y = 20, pct = FALSE+ #' split_cols_by_groups("ARM", groups) %>%
|
||
| 209 | +233 | ++ |
+ #' add_colcounts() %>%+ |
+ |
| 234 | ++ |
+ #' analyze_vars("AGE") %>%
+ |
+ ||
| 235 | ++ |
+ #' build_table(DM, col_counts = col_counts)+ |
+ ||
| 236 | ++ |
+ #'+ |
+ ||
| 237 | ++ |
+ #' ref <- "A: Drug X"+ |
+ ||
| 238 | ++ |
+ #' groups <- combine_groups(fct = DM$ARM, ref = ref)+ |
+ ||
| 239 | ++ |
+ #' col_counts <- combine_counts(+ |
+ ||
| 240 | ++ |
+ #' fct = DM$ARM,+ |
+ ||
| 241 | ++ |
+ #' groups_list = groups+ |
+ ||
| 242 |
#' ) |
|||
| 210 | +243 |
#' |
||
| 211 | +244 |
- #' @export+ #' basic_table() %>% |
||
| 212 | +245 |
- stat_propdiff_ci <- function(x,+ #' split_cols_by_groups("ARM", groups) %>%
|
||
| 213 | +246 |
- y,+ #' add_colcounts() %>% |
||
| 214 | +247 |
- N_x, # nolint+ #' analyze_vars("AGE") %>%
|
||
| 215 | +248 |
- N_y, # nolint+ #' build_table(DM, col_counts = col_counts) |
||
| 216 | +249 |
- list_names = NULL,+ #' |
||
| 217 | +250 |
- conf_level = 0.95,+ #' @export |
||
| 218 | +251 |
- pct = TRUE) {
+ combine_counts <- function(fct, groups_list = NULL) {
|
||
| 219 | -51x | +252 | +4x |
- checkmate::assert_list(x, types = "numeric")+ checkmate::assert_multi_class(fct, classes = c("factor", "character"))
+ |
+
| 253 | ++ | + | ||
| 220 | -51x | +254 | +4x |
- checkmate::assert_list(y, types = "numeric", len = length(x))+ fct <- as_factor_keep_attributes(fct)+ |
+
| 255 | ++ | + | ||
| 221 | -51x | +256 | +4x |
- checkmate::assert_character(list_names, len = length(x), null.ok = TRUE)+ if (is.null(groups_list)) {
|
| 222 | -51x | +257 | +1x |
- rd_list <- lapply(seq_along(x), function(i) {
+ y <- table(fct) |
| 223 | -134x | +258 | +1x |
- p_x <- x[[i]] / N_x+ y <- stats::setNames(as.numeric(y), nm = dimnames(y)[[1]])+ |
+
| 259 | ++ |
+ } else {
|
||
| 224 | -134x | +260 | +3x |
- p_y <- y[[i]] / N_y+ y <- vapply( |
| 225 | -134x | +261 | +3x |
- rd_ci <- p_x - p_y + c(-1, 1) * stats::qnorm((1 + conf_level) / 2) *+ X = groups_list, |
| 226 | -134x | +262 | +3x |
- sqrt(p_x * (1 - p_x) / N_x + p_y * (1 - p_y) / N_y)+ FUN = function(x) sum(table(fct)[x]), |
| 227 | -134x | +263 | +3x |
- c(p_x - p_y, rd_ci) * ifelse(pct, 100, 1)+ FUN.VALUE = 1 |
| 228 | +264 |
- })+ ) |
||
| 229 | -51x | +|||
| 265 | +
- names(rd_list) <- list_names+ } |
|||
| 230 | -51x | +266 | +4x |
- rd_list+ y |
| 231 | +267 |
}@@ -102214,14 +105319,14 @@ tern coverage - 95.59% |
| 1 |
- #' Helper functions for Cox proportional hazards regression+ #' Helper functions for tabulating survival duration by subgroup |
||
| 5 |
- #' Helper functions used in [fit_coxreg_univar()] and [fit_coxreg_multivar()].+ #' Helper functions that tabulate in a data frame statistics such as median survival |
||
| 6 |
- #'+ #' time and hazard ratio for population subgroups. |
||
| 7 |
- #' @inheritParams argument_convention+ #' |
||
| 8 |
- #' @inheritParams h_coxreg_univar_extract+ #' @inheritParams argument_convention |
||
| 9 |
- #' @inheritParams cox_regression_inter+ #' @inheritParams survival_coxph_pairwise |
||
| 10 |
- #' @inheritParams control_coxreg+ #' @inheritParams survival_duration_subgroups |
||
| 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 |
- NULL+ #' @examples |
||
| 16 |
-
+ #' library(dplyr) |
||
| 17 |
- #' @describeIn h_cox_regression Helper for Cox regression formula. Creates a list of formulas. It is used+ #' library(forcats) |
||
| 18 |
- #' internally by [fit_coxreg_univar()] for the comparison of univariate Cox regression models.+ #' |
||
| 19 |
- #'+ #' adtte <- tern_ex_adtte |
||
| 20 |
- #' @return+ #' |
||
| 21 |
- #' * `h_coxreg_univar_formulas()` returns a `character` vector coercible into formulas (e.g [stats::as.formula()]).+ #' # Save variable labels before data processing steps. |
||
| 22 |
- #'+ #' adtte_labels <- formatters::var_labels(adtte) |
||
| 23 |
- #' @examples+ #' |
||
| 24 |
- #' # `h_coxreg_univar_formulas`+ #' adtte_f <- adtte %>% |
||
| 25 |
- #'+ #' filter( |
||
| 26 |
- #' ## Simple formulas.+ #' PARAMCD == "OS", |
||
| 27 |
- #' h_coxreg_univar_formulas(+ #' ARM %in% c("B: Placebo", "A: Drug X"),
|
||
| 28 |
- #' variables = list(+ #' SEX %in% c("M", "F")
|
||
| 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 |
- #' ## Addition of an optional strata.+ #' SEX = droplevels(SEX), |
||
| 34 |
- #' h_coxreg_univar_formulas(+ #' is_event = CNSR == 0 |
||
| 35 |
- #' variables = list(+ #' ) |
||
| 36 |
- #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
+ #' labels <- c("ARM" = adtte_labels[["ARM"]], "SEX" = adtte_labels[["SEX"]], "is_event" = "Event Flag")
|
||
| 37 |
- #' strata = "SITE"+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
||
| 38 |
- #' )+ #' |
||
| 39 |
- #' )+ #' @name h_survival_duration_subgroups |
||
| 40 |
- #'+ NULL |
||
| 41 |
- #' ## Inclusion of the interaction term.+ |
||
| 42 |
- #' h_coxreg_univar_formulas(+ #' @describeIn h_survival_duration_subgroups Helper to prepare a data frame of median survival times by arm. |
||
| 43 |
- #' variables = list(+ #' |
||
| 44 |
- #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
+ #' @return |
||
| 45 |
- #' strata = "SITE"+ #' * `h_survtime_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, and `median`. |
||
| 46 |
- #' ),+ #' |
||
| 47 |
- #' interaction = TRUE+ #' @examples |
||
| 48 |
- #' )+ #' # Extract median survival time for one group. |
||
| 49 |
- #'+ #' h_survtime_df( |
||
| 50 |
- #' ## Only covariates fitted in separate models.+ #' tte = adtte_f$AVAL, |
||
| 51 |
- #' h_coxreg_univar_formulas(+ #' is_event = adtte_f$is_event, |
||
| 52 |
- #' variables = list(+ #' arm = adtte_f$ARM |
||
| 53 |
- #' time = "time", event = "status", covariates = c("X", "y")
+ #' ) |
||
| 54 |
- #' )+ #' |
||
| 55 |
- #' )+ #' @export |
||
| 56 |
- #'+ h_survtime_df <- function(tte, is_event, arm) {
|
||
| 57 | -+ | 79x |
- #' @export+ checkmate::assert_numeric(tte) |
| 58 | -+ | 78x |
- h_coxreg_univar_formulas <- function(variables,+ checkmate::assert_logical(is_event, len = length(tte)) |
| 59 | -+ | 78x |
- interaction = FALSE) {
+ assert_valid_factor(arm, len = length(tte)) |
| 60 | -50x | +
- checkmate::assert_list(variables, names = "named")+ |
|
| 61 | -50x | +78x |
- has_arm <- "arm" %in% names(variables)+ df_tte <- data.frame( |
| 62 | -50x | +78x |
- arm_name <- if (has_arm) "arm" else NULL+ tte = tte, |
| 63 | -+ | 78x |
-
+ is_event = is_event, |
| 64 | -50x | +78x |
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ stringsAsFactors = FALSE |
| 65 |
-
+ ) |
||
| 66 | -50x | +
- checkmate::assert_flag(interaction)+ |
|
| 67 |
-
+ # Delete NAs |
||
| 68 | -50x | +78x |
- if (!has_arm || is.null(variables$covariates)) {
+ non_missing_rows <- stats::complete.cases(df_tte) |
| 69 | -10x | +78x |
- checkmate::assert_false(interaction)+ df_tte <- df_tte[non_missing_rows, ] |
| 70 | -+ | 78x |
- }+ arm <- arm[non_missing_rows] |
| 72 | -48x | +78x |
- assert_list_of_variables(variables[c(arm_name, "event", "time")])+ lst_tte <- split(df_tte, arm) |
| 73 | -+ | 78x |
-
+ lst_results <- Map(function(x, arm) {
|
| 74 | -48x | +156x |
- if (!is.null(variables$covariates)) {
+ if (nrow(x) > 0) {
|
| 75 | -47x | +152x |
- forms <- paste0(+ s_surv <- s_surv_time(x, .var = "tte", is_event = "is_event") |
| 76 | -47x | +152x |
- "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
+ median_est <- unname(as.numeric(s_surv$median)) |
| 77 | -47x | +152x |
- ifelse(has_arm, variables$arm, "1"),+ n_events <- sum(x$is_event) |
| 78 | -47x | +
- ifelse(interaction, " * ", " + "),+ } else {
|
|
| 79 | -47x | +4x |
- variables$covariates,+ median_est <- NA |
| 80 | -47x | +4x |
- ifelse(+ n_events <- NA |
| 81 | -47x | +
- !is.null(variables$strata),+ } |
|
| 82 | -47x | +
- paste0(" + strata(", paste0(variables$strata, collapse = ", "), ")"),
+
|
|
| 83 | -+ | 156x |
- ""+ data.frame( |
| 84 | -+ | 156x |
- )+ arm = arm, |
| 85 | -+ | 156x |
- )+ n = nrow(x), |
| 86 | -+ | 156x |
- } else {
+ n_events = n_events, |
| 87 | -1x | +156x |
- forms <- NULL+ median = median_est, |
| 88 | -+ | 156x |
- }+ stringsAsFactors = FALSE |
| 89 | -48x | +
- nams <- variables$covariates+ ) |
|
| 90 | -48x | +78x |
- if (has_arm) {
+ }, lst_tte, names(lst_tte)) |
| 91 | -41x | +
- ref <- paste0(+ |
|
| 92 | -41x | +78x |
- "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
+ df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE)) |
| 93 | -41x | +78x |
- variables$arm,+ df$arm <- factor(df$arm, levels = levels(arm)) |
| 94 | -41x | +78x |
- ifelse(+ df |
| 95 | -41x | +
- !is.null(variables$strata),+ } |
|
| 96 | -41x | +
- paste0(+ |
|
| 97 | -41x | +
- " + strata(", paste0(variables$strata, collapse = ", "), ")"
+ #' @describeIn h_survival_duration_subgroups Summarizes median survival times by arm and across subgroups |
|
| 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 | -41x | +
- forms <- c(ref, forms)+ #' @return |
|
| 103 | -41x | +
- nams <- c("ref", nams)
+ #' * `h_survtime_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, `median`, `subgroup`, |
|
| 104 |
- }+ #' `var`, `var_label`, and `row_type`. |
||
| 105 | -48x | +
- stats::setNames(forms, nams)+ #' |
|
| 106 |
- }+ #' @examples |
||
| 107 |
-
+ #' # Extract median survival time for multiple groups. |
||
| 108 |
- #' @describeIn h_cox_regression Helper for multivariate Cox regression formula. Creates a formulas+ #' h_survtime_subgroups_df( |
||
| 109 |
- #' string. It is used internally by [fit_coxreg_multivar()] for the comparison of multivariate Cox+ #' variables = list( |
||
| 110 |
- #' regression models. Interactions will not be included in multivariate Cox regression model.+ #' tte = "AVAL", |
||
| 111 |
- #'+ #' is_event = "is_event", |
||
| 112 |
- #' @return+ #' arm = "ARM", |
||
| 113 |
- #' * `h_coxreg_multivar_formula()` returns a `string` coercible into a formula (e.g [stats::as.formula()]).+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 114 |
- #'+ #' ), |
||
| 115 |
- #' @examples+ #' data = adtte_f |
||
| 116 |
- #' # `h_coxreg_multivar_formula`+ #' ) |
||
| 118 |
- #' h_coxreg_multivar_formula(+ #' # Define groupings for BMRKR2 levels. |
||
| 119 |
- #' variables = list(+ #' h_survtime_subgroups_df( |
||
| 120 |
- #' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE")
+ #' variables = list( |
||
| 121 |
- #' )+ #' tte = "AVAL", |
||
| 122 |
- #' )+ #' is_event = "is_event", |
||
| 123 |
- #'+ #' arm = "ARM", |
||
| 124 |
- #' # Addition of an optional strata.+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 125 |
- #' h_coxreg_multivar_formula(+ #' ), |
||
| 126 |
- #' variables = list(+ #' data = adtte_f, |
||
| 127 |
- #' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE"),
+ #' groups_lists = list( |
||
| 128 |
- #' strata = "SITE"+ #' BMRKR2 = list( |
||
| 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 |
- #' strata = "SITE"+ #' @export |
||
| 137 |
- #' )+ h_survtime_subgroups_df <- function(variables, |
||
| 138 |
- #' )+ data, |
||
| 139 |
- #'+ groups_lists = list(), |
||
| 140 |
- #' @export+ label_all = "All Patients") {
|
||
| 141 | -+ | 15x |
- h_coxreg_multivar_formula <- function(variables) {
+ checkmate::assert_character(variables$tte) |
| 142 | -89x | +15x |
- checkmate::assert_list(variables, names = "named")+ checkmate::assert_character(variables$is_event) |
| 143 | -89x | +15x |
- has_arm <- "arm" %in% names(variables)+ checkmate::assert_character(variables$arm) |
| 144 | -89x | +15x |
- arm_name <- if (has_arm) "arm" else NULL+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 146 | -89x | +15x |
- checkmate::assert_character(variables$covariates, null.ok = TRUE)+ assert_df_with_variables(data, variables) |
| 148 | -89x | +15x |
- assert_list_of_variables(variables[c(arm_name, "event", "time")])+ checkmate::assert_string(label_all) |
| 150 | -89x | +
- y <- paste0(+ # Add All Patients. |
|
| 151 | -89x | +15x |
- "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
+ result_all <- h_survtime_df(data[[variables$tte]], data[[variables$is_event]], data[[variables$arm]]) |
| 152 | -89x | +15x |
- ifelse(has_arm, variables$arm, "1")+ result_all$subgroup <- label_all |
| 153 | -+ | 15x |
- )+ result_all$var <- "ALL" |
| 154 | -89x | +15x |
- if (length(variables$covariates) > 0) {
+ result_all$var_label <- label_all |
| 155 | -26x | +15x |
- y <- paste(y, paste(variables$covariates, collapse = " + "), sep = " + ")+ result_all$row_type <- "content" |
| 156 |
- }+ |
||
| 157 | -89x | +
- if (!is.null(variables$strata)) {
+ # Add Subgroups. |
|
| 158 | -5x | +15x |
- y <- paste0(y, " + strata(", paste0(variables$strata, collapse = ", "), ")")
+ if (is.null(variables$subgroups)) {
|
| 159 | -+ | 3x |
- }+ result_all |
| 160 | -89x | +
- y+ } else {
|
|
| 161 | -+ | 12x |
- }+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists) |
| 162 | -+ | 12x |
-
+ l_result <- lapply(l_data, function(grp) {
|
| 163 | -+ | 60x |
- #' @describeIn h_cox_regression Utility function to help tabulate the result of+ result <- h_survtime_df(grp$df[[variables$tte]], grp$df[[variables$is_event]], grp$df[[variables$arm]]) |
| 164 | -+ | 60x |
- #' a univariate Cox regression model.+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
| 165 | -+ | 60x |
- #'+ cbind(result, result_labels) |
| 166 |
- #' @param effect (`string`)\cr the treatment variable.+ }) |
||
| 167 | -+ | 12x |
- #' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()].+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 168 | -+ | 12x |
- #'+ result_subgroups$row_type <- "analysis" |
| 169 | -+ | 12x |
- #' @return+ rbind( |
| 170 | -+ | 12x |
- #' * `h_coxreg_univar_extract()` returns a `data.frame` with variables `effect`, `term`, `term_label`, `level`,+ result_all, |
| 171 | -+ | 12x |
- #' `n`, `hr`, `lcl`, `ucl`, and `pval`.+ result_subgroups |
| 172 |
- #'+ ) |
||
| 173 |
- #' @examples+ } |
||
| 174 |
- #' library(survival)+ } |
||
| 175 |
- #'+ |
||
| 176 |
- #' dta_simple <- data.frame(+ #' @describeIn h_survival_duration_subgroups Helper to prepare a data frame with estimates of |
||
| 177 |
- #' time = c(5, 5, 10, 10, 5, 5, 10, 10),+ #' treatment hazard ratio. |
||
| 178 |
- #' status = c(0, 0, 1, 0, 0, 1, 1, 1),+ #' |
||
| 179 |
- #' armcd = factor(LETTERS[c(1, 1, 1, 1, 2, 2, 2, 2)], levels = c("A", "B")),
+ #' @param strata_data (`factor`, `data.frame`, or `NULL`)\cr required if stratified analysis is performed. |
||
| 180 |
- #' var1 = c(45, 55, 65, 75, 55, 65, 85, 75),+ #' |
||
| 181 |
- #' var2 = c("F", "M", "F", "M", "F", "M", "F", "U")
+ #' @return |
||
| 182 |
- #' )+ #' * `h_coxph_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`, |
||
| 183 |
- #' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple)+ #' `conf_level`, `pval` and `pval_label`. |
||
| 184 |
- #' result <- h_coxreg_univar_extract(+ #' |
||
| 185 |
- #' effect = "armcd", covar = "armcd", mod = mod, data = dta_simple+ #' @examples |
||
| 186 |
- #' )+ #' # Extract hazard ratio for one group. |
||
| 187 |
- #' result+ #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM) |
||
| 189 |
- #' @export+ #' # Extract hazard ratio for one group with stratification factor. |
||
| 190 |
- h_coxreg_univar_extract <- function(effect,+ #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM, strata_data = adtte_f$STRATA1) |
||
| 191 |
- covar,+ #' |
||
| 192 |
- data,+ #' @export |
||
| 193 |
- mod,+ h_coxph_df <- function(tte, is_event, arm, strata_data = NULL, control = control_coxph()) {
|
||
| 194 | -+ | 85x |
- control = control_coxreg()) {
+ checkmate::assert_numeric(tte) |
| 195 | -66x | +85x |
- checkmate::assert_string(covar)+ checkmate::assert_logical(is_event, len = length(tte)) |
| 196 | -66x | +85x |
- checkmate::assert_string(effect)+ assert_valid_factor(arm, n.levels = 2, len = length(tte)) |
| 197 | -66x | +
- checkmate::assert_class(mod, "coxph")+ |
|
| 198 | -66x | +85x |
- test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]+ df_tte <- data.frame(tte = tte, is_event = is_event) |
| 199 | -+ | 85x |
-
+ strata_vars <- NULL |
| 200 | -66x | +
- mod_aov <- muffled_car_anova(mod, test_statistic)+ |
|
| 201 | -66x | +85x |
- msum <- summary(mod, conf.int = control$conf_level)+ if (!is.null(strata_data)) {
|
| 202 | -66x | +5x |
- sum_cox <- broom::tidy(msum)+ if (is.data.frame(strata_data)) {
|
| 203 | -+ | 4x |
-
+ strata_vars <- names(strata_data) |
| 204 | -+ | 4x |
- # Combine results together.+ checkmate::assert_data_frame(strata_data, nrows = nrow(df_tte)) |
| 205 | -66x | +4x |
- effect_aov <- mod_aov[effect, , drop = TRUE]+ assert_df_with_factors(strata_data, as.list(stats::setNames(strata_vars, strata_vars))) |
| 206 | -66x | +
- pval <- effect_aov[[grep(pattern = "Pr", x = names(effect_aov)), drop = TRUE]]+ } else {
|
|
| 207 | -66x | +1x |
- sum_main <- sum_cox[grepl(effect, sum_cox$level), ]+ assert_valid_factor(strata_data, len = nrow(df_tte)) |
| 208 | -+ | 1x |
-
+ strata_vars <- "strata_data" |
| 209 | -66x | +
- term_label <- if (effect == covar) {
+ } |
|
| 210 | -34x | +5x |
- paste0(+ df_tte[strata_vars] <- strata_data |
| 211 | -34x | +
- levels(data[[covar]])[2],+ } |
|
| 212 | -34x | +
- " vs control (",
+
|
|
| 213 | -34x | +85x |
- levels(data[[covar]])[1],+ l_df <- split(df_tte, arm) |
| 214 |
- ")"+ |
||
| 215 | -+ | 85x |
- )+ if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
|
| 216 |
- } else {
+ # Hazard ratio and CI. |
||
| 217 | -32x | +79x |
- unname(labels_or_names(data[covar]))+ result <- s_coxph_pairwise( |
| 218 | -+ | 79x |
- }+ df = l_df[[2]], |
| 219 | -66x | +79x |
- data.frame(+ .ref_group = l_df[[1]], |
| 220 | -66x | +79x |
- effect = ifelse(covar == effect, "Treatment:", "Covariate:"),+ .in_ref_col = FALSE, |
| 221 | -66x | +79x |
- term = covar,+ .var = "tte", |
| 222 | -66x | +79x |
- term_label = term_label,+ is_event = "is_event", |
| 223 | -66x | +79x |
- level = levels(data[[effect]])[2],+ strata = strata_vars, |
| 224 | -66x | +79x |
- n = mod[["n"]],+ control = control |
| 225 | -66x | +
- hr = unname(sum_main["exp(coef)"]),+ ) |
|
| 226 | -66x | +
- lcl = unname(sum_main[grep("lower", names(sum_main))]),
+
|
|
| 227 | -66x | +79x |
- ucl = unname(sum_main[grep("upper", names(sum_main))]),
+ df <- data.frame( |
| 228 | -66x | +
- pval = pval,+ # Dummy column needed downstream to create a nested header. |
|
| 229 | -66x | +79x |
- stringsAsFactors = FALSE+ arm = " ", |
| 230 | -+ | 79x |
- )+ n_tot = unname(as.numeric(result$n_tot)), |
| 231 | -+ | 79x |
- }+ n_tot_events = unname(as.numeric(result$n_tot_events)), |
| 232 | -+ | 79x |
-
+ hr = unname(as.numeric(result$hr)), |
| 233 | -+ | 79x |
- #' @describeIn h_cox_regression Tabulation of multivariate Cox regressions. Utility function to help+ lcl = unname(result$hr_ci[1]), |
| 234 | -+ | 79x |
- #' tabulate the result of a multivariate Cox regression model for a treatment/covariate variable.+ ucl = unname(result$hr_ci[2]), |
| 235 | -+ | 79x |
- #'+ conf_level = control[["conf_level"]], |
| 236 | -+ | 79x |
- #' @return+ pval = as.numeric(result$pvalue), |
| 237 | -+ | 79x |
- #' * `h_coxreg_multivar_extract()` returns a `data.frame` with variables `pval`, `hr`, `lcl`, `ucl`, `level`,+ pval_label = obj_label(result$pvalue), |
| 238 | -+ | 79x |
- #' `n`, `term`, and `term_label`.+ stringsAsFactors = FALSE |
| 239 |
- #'+ ) |
||
| 240 |
- #' @examples+ } else if ( |
||
| 241 | -+ | 6x |
- #' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple)+ (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) || |
| 242 | -+ | 6x |
- #' result <- h_coxreg_multivar_extract(+ (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0) |
| 243 |
- #' var = "var1", mod = mod, data = dta_simple+ ) {
|
||
| 244 | -+ | 6x |
- #' )+ df_tte_complete <- df_tte[stats::complete.cases(df_tte), ] |
| 245 | -+ | 6x |
- #' result+ df <- data.frame( |
| 246 |
- #'+ # Dummy column needed downstream to create a nested header. |
||
| 247 | -+ | 6x |
- #' @export+ arm = " ", |
| 248 | -+ | 6x |
- h_coxreg_multivar_extract <- function(var,+ n_tot = nrow(df_tte_complete), |
| 249 | -+ | 6x |
- data,+ n_tot_events = sum(df_tte_complete$is_event), |
| 250 | -+ | 6x |
- mod,+ hr = NA, |
| 251 | -+ | 6x |
- control = control_coxreg()) {
+ lcl = NA, |
| 252 | -132x | +6x |
- test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]+ ucl = NA, |
| 253 | -132x | +6x |
- mod_aov <- muffled_car_anova(mod, test_statistic)+ conf_level = control[["conf_level"]], |
| 254 | -+ | 6x |
-
+ pval = NA, |
| 255 | -132x | +6x |
- msum <- summary(mod, conf.int = control$conf_level)+ pval_label = NA, |
| 256 | -132x | +6x |
- sum_anova <- broom::tidy(mod_aov)+ stringsAsFactors = FALSE |
| 257 | -132x | +
- sum_cox <- broom::tidy(msum)+ ) |
|
| 258 |
-
+ } else {
|
||
| 259 | -132x | +! |
- ret_anova <- sum_anova[sum_anova$term == var, c("term", "p.value")]
+ df <- data.frame( |
| 260 | -132x | +
- names(ret_anova)[2] <- "pval"+ # Dummy column needed downstream to create a nested header. |
|
| 261 | -132x | +! |
- if (is.factor(data[[var]])) {
+ arm = " ", |
| 262 | -53x | +! |
- ret_cox <- sum_cox[startsWith(prefix = var, x = sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")]+ n_tot = 0L, |
| 263 | -+ | ! |
- } else {
+ n_tot_events = 0L, |
| 264 | -79x | +! |
- ret_cox <- sum_cox[(var == sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")]+ hr = NA, |
| 265 | -+ | ! |
- }+ lcl = NA, |
| 266 | -132x | +! |
- names(ret_cox)[1:4] <- c("pval", "hr", "lcl", "ucl")
+ ucl = NA, |
| 267 | -132x | +! |
- varlab <- unname(labels_or_names(data[var]))+ conf_level = control[["conf_level"]], |
| 268 | -132x | +! |
- ret_cox$term <- varlab+ pval = NA, |
| 269 | -+ | ! |
-
+ pval_label = NA, |
| 270 | -132x | +! |
- if (is.numeric(data[[var]])) {
+ stringsAsFactors = FALSE |
| 271 | -79x | +
- ret <- ret_cox+ ) |
|
| 272 | -79x | +
- ret$term_label <- ret$term+ } |
|
| 273 | -53x | +
- } else if (length(levels(data[[var]])) <= 2) {
+
|
|
| 274 | -34x | +85x |
- ret_anova$pval <- NA+ df |
| 275 | -34x | +
- ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")")+ } |
|
| 276 | -34x | +
- ret_cox$level <- gsub(var, "", ret_cox$level)+ |
|
| 277 | -34x | +
- ret_cox$term_label <- ret_cox$level+ #' @describeIn h_survival_duration_subgroups Summarizes estimates of the treatment hazard ratio |
|
| 278 | -34x | +
- ret <- dplyr::bind_rows(ret_anova, ret_cox)+ #' across subgroups in a data frame. `variables` corresponds to the names of variables found in |
|
| 279 |
- } else {
+ #' `data`, passed as a named list and requires elements `tte`, `is_event`, `arm` and |
||
| 280 | -19x | +
- ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")")+ #' optionally `subgroups` and `strata`. `groups_lists` optionally specifies |
|
| 281 | -19x | +
- ret_cox$level <- gsub(var, "", ret_cox$level)+ #' groupings for `subgroups` variables. |
|
| 282 | -19x | +
- ret_cox$term_label <- ret_cox$level+ #' |
|
| 283 | -19x | +
- ret <- dplyr::bind_rows(ret_anova, ret_cox)+ #' @return |
|
| 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 | -132x | +
- as.data.frame(ret)+ #' |
|
| 287 |
- }+ #' @examples |
| 1 | +288 |
- #' Helper functions for tabulating binary response by subgroup+ #' # Extract hazard ratio for multiple groups. |
||
| 2 | +289 |
- #'+ #' h_coxph_subgroups_df( |
||
| 3 | +290 |
- #' @description `r lifecycle::badge("stable")`
+ #' variables = list( |
||
| 4 | +291 |
- #'+ #' tte = "AVAL", |
||
| 5 | +292 |
- #' Helper functions that tabulate in a data frame statistics such as response rate+ #' is_event = "is_event", |
||
| 6 | +293 |
- #' and odds ratio for population subgroups.+ #' arm = "ARM", |
||
| 7 | +294 |
- #'+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 8 | +295 |
- #' @inheritParams argument_convention+ #' ), |
||
| 9 | +296 |
- #' @inheritParams response_subgroups+ #' data = adtte_f |
||
| 10 | +297 |
- #' @param arm (`factor`)\cr the treatment group variable.+ #' ) |
||
| 11 | +298 |
#' |
||
| 12 | +299 |
- #' @details Main functionality is to prepare data for use in a layout-creating function.+ #' # Define groupings of BMRKR2 levels. |
||
| 13 | +300 |
- #'+ #' h_coxph_subgroups_df( |
||
| 14 | +301 |
- #' @examples+ #' variables = list( |
||
| 15 | +302 |
- #' library(dplyr)+ #' tte = "AVAL", |
||
| 16 | +303 |
- #' library(forcats)+ #' is_event = "is_event", |
||
| 17 | +304 |
- #'+ #' arm = "ARM", |
||
| 18 | +305 |
- #' adrs <- tern_ex_adrs+ #' subgroups = c("SEX", "BMRKR2")
|
||
| 19 | +306 |
- #' adrs_labels <- formatters::var_labels(adrs)+ #' ), |
||
| 20 | +307 |
- #'+ #' data = adtte_f, |
||
| 21 | +308 |
- #' adrs_f <- adrs %>%+ #' groups_lists = list( |
||
| 22 | +309 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' BMRKR2 = list( |
||
| 23 | +310 |
- #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+ #' "low" = "LOW", |
||
| 24 | +311 |
- #' droplevels() %>%+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 25 | +312 |
- #' mutate(+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 26 | +313 |
- #' # Reorder levels of factor to make the placebo group the reference arm.+ #' ) |
||
| 27 | +314 |
- #' ARM = fct_relevel(ARM, "B: Placebo"),+ #' ) |
||
| 28 | +315 |
- #' rsp = AVALC == "CR"+ #' ) |
||
| 29 | +316 |
- #' )+ #' |
||
| 30 | +317 |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ #' # Extract hazard ratio for multiple groups with stratification factors. |
||
| 31 | +318 |
- #'+ #' h_coxph_subgroups_df( |
||
| 32 | +319 |
- #' @name h_response_subgroups+ #' variables = list( |
||
| 33 | +320 |
- NULL+ #' tte = "AVAL", |
||
| 34 | +321 |
-
+ #' is_event = "is_event", |
||
| 35 | +322 |
- #' @describeIn h_response_subgroups Helper to prepare a data frame of binary responses by arm.+ #' arm = "ARM", |
||
| 36 | +323 |
- #'+ #' subgroups = c("SEX", "BMRKR2"),
|
||
| 37 | +324 |
- #' @return+ #' strata = c("STRATA1", "STRATA2")
|
||
| 38 | +325 |
- #' * `h_proportion_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, and `prop`.+ #' ), |
||
| 39 | +326 | ++ |
+ #' data = adtte_f+ |
+ |
| 327 | ++ |
+ #' )+ |
+ ||
| 328 |
#' |
|||
| 40 | +329 |
- #' @examples+ #' @export |
||
| 41 | +330 |
- #' h_proportion_df(+ h_coxph_subgroups_df <- function(variables, |
||
| 42 | +331 |
- #' c(TRUE, FALSE, FALSE),+ data, |
||
| 43 | +332 |
- #' arm = factor(c("A", "A", "B"), levels = c("A", "B"))
+ groups_lists = list(), |
||
| 44 | +333 |
- #' )+ control = control_coxph(), |
||
| 45 | +334 |
- #'+ label_all = "All Patients") {
+ |
+ ||
| 335 | +17x | +
+ if ("strat" %in% names(variables)) {
+ |
+ ||
| 336 | +! | +
+ warning(+ |
+ ||
| 337 | +! | +
+ "Warning: the `strat` element name of the `variables` list argument to `h_coxph_subgroups_df() ",+ |
+ ||
| 338 | +! | +
+ "was deprecated in tern 0.9.4.\n ",+ |
+ ||
| 339 | +! | +
+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 46 | +340 |
- #' @export+ )+ |
+ ||
| 341 | +! | +
+ variables[["strata"]] <- variables[["strat"]] |
||
| 47 | +342 |
- h_proportion_df <- function(rsp, arm) {
+ }+ |
+ ||
| 343 | ++ | + | ||
| 48 | -79x | +344 | +17x |
- checkmate::assert_logical(rsp)+ checkmate::assert_character(variables$tte) |
| 49 | -78x | +345 | +17x |
- assert_valid_factor(arm, len = length(rsp))+ checkmate::assert_character(variables$is_event) |
| 50 | -78x | +346 | +17x |
- non_missing_rsp <- !is.na(rsp)+ checkmate::assert_character(variables$arm) |
| 51 | -78x | +347 | +17x |
- rsp <- rsp[non_missing_rsp]+ checkmate::assert_character(variables$subgroups, null.ok = TRUE) |
| 52 | -78x | +348 | +17x |
- arm <- arm[non_missing_rsp]+ checkmate::assert_character(variables$strata, null.ok = TRUE)+ |
+
| 349 | +17x | +
+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ |
+ ||
| 350 | +17x | +
+ assert_df_with_variables(data, variables)+ |
+ ||
| 351 | +17x | +
+ checkmate::assert_string(label_all) |
||
| 53 | +352 | |||
| 353 | ++ |
+ # Add All Patients.+ |
+ ||
| 54 | -78x | +354 | +17x |
- lst_rsp <- split(rsp, arm)+ result_all <- h_coxph_df( |
| 55 | -78x | +355 | +17x |
- lst_results <- Map(function(x, arm) {
+ tte = data[[variables$tte]], |
| 56 | -156x | +356 | +17x |
- if (length(x) > 0) {
+ is_event = data[[variables$is_event]], |
| 57 | -154x | +357 | +17x |
- s_prop <- s_proportion(df = x)+ arm = data[[variables$arm]], |
| 58 | -154x | +358 | +17x |
- data.frame(+ strata_data = if (is.null(variables$strata)) NULL else data[variables$strata], |
| 59 | -154x | +359 | +17x |
- arm = arm,+ control = control+ |
+
| 360 | ++ |
+ ) |
||
| 60 | -154x | +361 | +17x |
- n = length(x),+ result_all$subgroup <- label_all |
| 61 | -154x | +362 | +17x |
- n_rsp = unname(s_prop$n_prop[1]),+ result_all$var <- "ALL" |
| 62 | -154x | +363 | +17x |
- prop = unname(s_prop$n_prop[2]),+ result_all$var_label <- label_all |
| 63 | -154x | +364 | +17x |
- stringsAsFactors = FALSE+ result_all$row_type <- "content" |
| 64 | +365 | ++ | + + | +|
| 366 | ++ |
+ # Add Subgroups.+ |
+ ||
| 367 | +17x | +
+ if (is.null(variables$subgroups)) {
+ |
+ ||
| 368 | +3x | +
+ result_all+ |
+ ||
| 369 | ++ |
+ } else {
+ |
+ ||
| 370 | +14x | +
+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ |
+ ||
| 371 | ++ | + + | +||
| 372 | +14x | +
+ l_result <- lapply(l_data, function(grp) {
+ |
+ ||
| 373 | +64x | +
+ result <- h_coxph_df(+ |
+ ||
| 374 | +64x | +
+ tte = grp$df[[variables$tte]],+ |
+ ||
| 375 | +64x | +
+ is_event = grp$df[[variables$is_event]],+ |
+ ||
| 376 | +64x | +
+ arm = grp$df[[variables$arm]],+ |
+ ||
| 377 | +64x | +
+ strata_data = if (is.null(variables$strata)) NULL else grp$df[variables$strata],+ |
+ ||
| 378 | +64x | +
+ control = control+ |
+ ||
| 379 |
) |
|||
| 380 | +64x | +
+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ |
+ ||
| 381 | +64x | +
+ cbind(result, result_labels)+ |
+ ||
| 65 | +382 | ++ |
+ })+ |
+ |
| 383 | ++ | + + | +||
| 384 | +14x | +
+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ |
+ ||
| 385 | +14x | +
+ result_subgroups$row_type <- "analysis"+ |
+ ||
| 386 |
- } else {
+
|
|||
| 66 | -2x | +387 | +14x |
- data.frame(+ rbind( |
| 67 | -2x | +388 | +14x |
- arm = arm,+ result_all, |
| 68 | -2x | +389 | +14x |
- n = 0L,+ result_subgroups |
| 69 | -2x | +|||
| 390 | +
- n_rsp = NA,+ ) |
|||
| 70 | -2x | +|||
| 391 | +
- prop = NA,+ } |
|||
| 71 | -2x | +|||
| 392 | +
- stringsAsFactors = FALSE+ } |
|||
| 72 | +393 |
- )+ |
||
| 73 | +394 |
- }+ #' Split data frame by subgroups |
||
| 74 | -78x | +|||
| 395 | +
- }, lst_rsp, names(lst_rsp))+ #' |
|||
| 75 | +396 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 76 | -78x | +|||
| 397 | +
- df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE))+ #' |
|||
| 77 | -78x | +|||
| 398 | +
- df$arm <- factor(df$arm, levels = levels(arm))+ #' Split a data frame into a non-nested list of subsets. |
|||
| 78 | -78x | +|||
| 399 | +
- df+ #' |
|||
| 79 | +400 |
- }+ #' @inheritParams argument_convention |
||
| 80 | +401 |
-
+ #' @inheritParams survival_duration_subgroups |
||
| 81 | +402 |
- #' @describeIn h_response_subgroups Summarizes proportion of binary responses by arm and across subgroups+ #' @param data (`data.frame`)\cr dataset to split. |
||
| 82 | +403 |
- #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and+ #' @param subgroups (`character`)\cr names of factor variables from `data` used to create subsets. |
||
| 83 | +404 |
- #' requires elements `rsp`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies+ #' Unused levels not present in `data` are dropped. Note that the order in this vector |
||
| 84 | +405 |
- #' groupings for `subgroups` variables.+ #' determines the order in the downstream table. |
||
| 85 | +406 |
#' |
||
| 86 | +407 |
- #' @return+ #' @return A list with subset data (`df`) and metadata about the subset (`df_labels`). |
||
| 87 | +408 |
- #' * `h_proportion_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`,+ #' |
||
| 88 | +409 |
- #' `var`, `var_label`, and `row_type`.+ #' @details Main functionality is to prepare data for use in forest plot layouts. |
||
| 89 | +410 |
#' |
||
| 90 | +411 |
#' @examples |
||
| 91 | +412 |
- #' h_proportion_subgroups_df(+ #' df <- data.frame( |
||
| 92 | +413 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ #' x = c(1:5), |
||
| 93 | +414 |
- #' data = adrs_f+ #' y = factor(c("A", "B", "A", "B", "A"), levels = c("A", "B", "C")),
|
||
| 94 | +415 |
- #' )+ #' z = factor(c("C", "C", "D", "D", "D"), levels = c("D", "C"))
|
||
| 95 | +416 |
- #'+ #' ) |
||
| 96 | +417 |
- #' # Define groupings for BMRKR2 levels.+ #' formatters::var_labels(df) <- paste("label for", names(df))
|
||
| 97 | +418 |
- #' h_proportion_subgroups_df(+ #' |
||
| 98 | +419 |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ #' h_split_by_subgroups( |
||
| 99 | +420 |
- #' data = adrs_f,+ #' data = df, |
||
| 100 | +421 |
- #' groups_lists = list(+ #' subgroups = c("y", "z")
|
||
| 101 | +422 |
- #' BMRKR2 = list(+ #' ) |
||
| 102 | +423 |
- #' "low" = "LOW",+ #' |
||
| 103 | +424 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' h_split_by_subgroups( |
||
| 104 | +425 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ #' data = df, |
||
| 105 | +426 |
- #' )+ #' subgroups = c("y", "z"),
|
||
| 106 | +427 |
- #' )+ #' groups_lists = list( |
||
| 107 | +428 |
- #' )+ #' y = list("AB" = c("A", "B"), "C" = "C")
|
||
| 108 | +429 |
- #'+ #' ) |
||
| 109 | +430 |
- #' @export+ #' ) |
||
| 110 | +431 |
- h_proportion_subgroups_df <- function(variables,+ #' |
||
| 111 | +432 |
- data,+ #' @export |
||
| 112 | +433 |
- groups_lists = list(),+ h_split_by_subgroups <- function(data, |
||
| 113 | +434 |
- label_all = "All Patients") {
- |
- ||
| 114 | -17x | -
- checkmate::assert_character(variables$rsp)+ subgroups, |
||
| 115 | -17x | +|||
| 435 | +
- checkmate::assert_character(variables$arm)+ groups_lists = list()) {
|
|||
| 116 | -17x | +436 | +66x |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ checkmate::assert_character(subgroups, min.len = 1, any.missing = FALSE) |
| 117 | -17x | +437 | +66x |
- assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ checkmate::assert_list(groups_lists, names = "named") |
| 118 | -17x | +438 | +66x |
- assert_df_with_variables(data, variables)+ checkmate::assert_subset(names(groups_lists), subgroups) |
| 119 | -17x | +439 | +66x |
- checkmate::assert_string(label_all)+ assert_df_with_factors(data, as.list(stats::setNames(subgroups, subgroups))) |
| 120 | +440 | |||
| 121 | -+ | |||
| 441 | +66x |
- # Add All Patients.+ data_labels <- unname(formatters::var_labels(data)) |
||
| 122 | -17x | +442 | +66x |
- result_all <- h_proportion_df(data[[variables$rsp]], data[[variables$arm]])+ df_subgroups <- data[, subgroups, drop = FALSE] |
| 123 | -17x | +443 | +66x |
- result_all$subgroup <- label_all+ subgroup_labels <- formatters::var_labels(df_subgroups, fill = TRUE)+ |
+
| 444 | ++ | + | ||
| 124 | -17x | +445 | +66x |
- result_all$var <- "ALL"+ l_labels <- Map(function(grp_i, name_i) {
|
| 125 | -17x | +446 | +120x |
- result_all$var_label <- label_all+ existing_levels <- levels(droplevels(grp_i)) |
| 126 | -17x | +447 | +120x |
- result_all$row_type <- "content"+ grp_levels <- if (name_i %in% names(groups_lists)) {
|
| 127 | +448 |
-
+ # For this variable groupings are defined. We check which groups are contained in the data. |
||
| 128 | -+ | |||
| 449 | +11x |
- # Add Subgroups.+ group_list_i <- groups_lists[[name_i]] |
||
| 129 | -17x | +450 | +11x |
- if (is.null(variables$subgroups)) {
+ group_has_levels <- vapply(group_list_i, function(lvls) any(lvls %in% existing_levels), TRUE) |
| 130 | -3x | +451 | +11x |
- result_all+ names(which(group_has_levels)) |
| 131 | +452 |
- } else {
+ } else {
|
||
| 132 | -14x | +453 | +109x |
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ existing_levels |
| 133 | +454 |
-
+ } |
||
| 134 | -14x | +455 | +120x |
- l_result <- lapply(l_data, function(grp) {
+ df_labels <- data.frame( |
| 135 | -58x | +456 | +120x |
- result <- h_proportion_df(grp$df[[variables$rsp]], grp$df[[variables$arm]])+ subgroup = grp_levels, |
| 136 | -58x | +457 | +120x |
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ var = name_i, |
| 137 | -58x | +458 | +120x |
- cbind(result, result_labels)+ var_label = unname(subgroup_labels[name_i]),+ |
+
| 459 | +120x | +
+ stringsAsFactors = FALSE # Rationale is that subgroups may not be unique. |
||
| 138 | +460 |
- })+ ) |
||
| 139 | -14x | +461 | +66x |
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ }, df_subgroups, names(df_subgroups)) |
| 140 | -14x | +|||
| 462 | +
- result_subgroups$row_type <- "analysis"+ |
|||
| 141 | +463 |
-
+ # Create a data frame with one row per subgroup. |
||
| 142 | -14x | +464 | +66x |
- rbind(+ df_labels <- do.call(rbind, args = c(l_labels, make.row.names = FALSE)) |
| 143 | -14x | +465 | +66x |
- result_all,+ row_label <- paste0(df_labels$var, ".", df_labels$subgroup) |
| 144 | -14x | +466 | +66x |
- result_subgroups+ row_split_var <- factor(row_label, levels = row_label) |
| 145 | +467 |
- )+ |
||
| 146 | +468 |
- }+ # Create a list of data subsets. |
||
| 147 | -+ | |||
| 469 | +66x |
- }+ lapply(split(df_labels, row_split_var), function(row_i) {
|
||
| 148 | -+ | |||
| 470 | +294x |
-
+ which_row <- if (row_i$var %in% names(groups_lists)) {
|
||
| 149 | -+ | |||
| 471 | +31x |
- #' @describeIn h_response_subgroups Helper to prepare a data frame with estimates of+ data[[row_i$var]] %in% groups_lists[[row_i$var]][[row_i$subgroup]] |
||
| 150 | +472 |
- #' the odds ratio between a treatment and a control arm.+ } else {
|
||
| 151 | -+ | |||
| 473 | +263x |
- #'+ data[[row_i$var]] == row_i$subgroup |
||
| 152 | +474 |
- #' @inheritParams response_subgroups+ } |
||
| 153 | -+ | |||
| 475 | +294x |
- #' @param strata_data (`factor`, `data.frame`, or `NULL`)\cr required if stratified analysis is performed.+ df <- data[which_row, ] |
||
| 154 | -+ | |||
| 476 | +294x |
- #'+ rownames(df) <- NULL |
||
| 155 | -+ | |||
| 477 | +294x |
- #' @return+ formatters::var_labels(df) <- data_labels |
||
| 156 | +478 |
- #' * `h_odds_ratio_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`, and+ + |
+ ||
| 479 | +294x | +
+ list(+ |
+ ||
| 480 | +294x | +
+ df = df,+ |
+ ||
| 481 | +294x | +
+ df_labels = data.frame(row_i, row.names = NULL) |
||
| 157 | +482 |
- #' optionally `pval` and `pval_label`.+ ) |
||
| 158 | +483 |
- #'+ }) |
||
| 159 | +484 |
- #' @examples+ } |
| 160 | +1 |
- #' # Unstratatified analysis.+ #' Create a STEP graph |
||
| 161 | +2 |
- #' h_odds_ratio_df(+ #' |
||
| 162 | +3 |
- #' c(TRUE, FALSE, FALSE, TRUE),+ #' @description `r lifecycle::badge("stable")`
|
||
| 163 | +4 |
- #' arm = factor(c("A", "A", "B", "B"), levels = c("A", "B"))
+ #' |
||
| 164 | +5 |
- #' )+ #' Based on the STEP results, creates a `ggplot` graph showing the estimated HR or OR |
||
| 165 | +6 |
- #'+ #' along the continuous biomarker value subgroups. |
||
| 166 | +7 |
- #' # Include p-value.+ #' |
||
| 167 | +8 |
- #' h_odds_ratio_df(adrs_f$rsp, adrs_f$ARM, method = "chisq")+ #' @param df (`tibble`)\cr result of [tidy.step()]. |
||
| 168 | +9 |
- #'+ #' @param use_percentile (`flag`)\cr whether to use percentiles for the x axis or actual |
||
| 169 | +10 |
- #' # Stratatified analysis.+ #' biomarker values. |
||
| 170 | +11 |
- #' h_odds_ratio_df(+ #' @param est (named `list`)\cr `col` and `lty` settings for estimate line. |
||
| 171 | +12 |
- #' rsp = adrs_f$rsp,+ #' @param ci_ribbon (named `list` or `NULL`)\cr `fill` and `alpha` settings for the confidence interval |
||
| 172 | +13 |
- #' arm = adrs_f$ARM,+ #' ribbon area, or `NULL` to not plot a CI ribbon. |
||
| 173 | +14 |
- #' strata_data = adrs_f[, c("STRATA1", "STRATA2")],
+ #' @param col (`character`)\cr color(s). |
||
| 174 | +15 |
- #' method = "cmh"+ #' |
||
| 175 | +16 |
- #' )+ #' @return A `ggplot` STEP graph. |
||
| 176 | +17 |
#' |
||
| 177 | +18 |
- #' @export+ #' @seealso Custom tidy method [tidy.step()]. |
||
| 178 | +19 |
- h_odds_ratio_df <- function(rsp, arm, strata_data = NULL, conf_level = 0.95, method = NULL) {
+ #' |
||
| 179 | -84x | +|||
| 20 | +
- assert_valid_factor(arm, n.levels = 2, len = length(rsp))+ #' @examples |
|||
| 180 | +21 |
-
+ #' library(survival) |
||
| 181 | -84x | +|||
| 22 | +
- df_rsp <- data.frame(+ #' lung$sex <- factor(lung$sex) |
|||
| 182 | -84x | +|||
| 23 | +
- rsp = rsp,+ #' |
|||
| 183 | -84x | +|||
| 24 | +
- arm = arm+ #' # Survival example. |
|||
| 184 | +25 |
- )+ #' vars <- list( |
||
| 185 | +26 |
-
+ #' time = "time", |
||
| 186 | -84x | +|||
| 27 | +
- if (!is.null(strata_data)) {
+ #' event = "status", |
|||
| 187 | -11x | +|||
| 28 | +
- strata_var <- interaction(strata_data, drop = TRUE)+ #' arm = "sex", |
|||
| 188 | -11x | +|||
| 29 | +
- strata_name <- "strata"+ #' biomarker = "age" |
|||
| 189 | +30 |
-
+ #' ) |
||
| 190 | -11x | +|||
| 31 | +
- assert_valid_factor(strata_var, len = nrow(df_rsp))+ #' |
|||
| 191 | +32 |
-
+ #' step_matrix <- fit_survival_step( |
||
| 192 | -11x | +|||
| 33 | +
- df_rsp[[strata_name]] <- strata_var+ #' variables = vars, |
|||
| 193 | +34 |
- } else {
+ #' data = lung, |
||
| 194 | -73x | +|||
| 35 | +
- strata_name <- NULL+ #' control = c(control_coxph(), control_step(num_points = 10, degree = 2)) |
|||
| 195 | +36 |
- }+ #' ) |
||
| 196 | +37 |
-
+ #' step_data <- broom::tidy(step_matrix) |
||
| 197 | -84x | +|||
| 38 | +
- l_df <- split(df_rsp, arm)+ #' |
|||
| 198 | +39 |
-
+ #' # Default plot. |
||
| 199 | -84x | +|||
| 40 | +
- if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
+ #' g_step(step_data) |
|||
| 200 | +41 |
- # Odds ratio and CI.+ #' |
||
| 201 | -82x | +|||
| 42 | +
- result_odds_ratio <- s_odds_ratio(+ #' # Add the reference 1 horizontal line. |
|||
| 202 | -82x | +|||
| 43 | +
- df = l_df[[2]],+ #' library(ggplot2) |
|||
| 203 | -82x | +|||
| 44 | +
- .var = "rsp",+ #' g_step(step_data) + |
|||
| 204 | -82x | +|||
| 45 | +
- .ref_group = l_df[[1]],+ #' ggplot2::geom_hline(ggplot2::aes(yintercept = 1), linetype = 2) |
|||
| 205 | -82x | +|||
| 46 | +
- .in_ref_col = FALSE,+ #' |
|||
| 206 | -82x | +|||
| 47 | +
- .df_row = df_rsp,+ #' # Use actual values instead of percentiles, different color for estimate and no CI, |
|||
| 207 | -82x | +|||
| 48 | +
- variables = list(arm = "arm", strata = strata_name),+ #' # use log scale for y axis. |
|||
| 208 | -82x | +|||
| 49 | +
- conf_level = conf_level+ #' g_step( |
|||
| 209 | +50 |
- )+ #' step_data, |
||
| 210 | +51 |
-
+ #' use_percentile = FALSE, |
||
| 211 | -82x | +|||
| 52 | +
- df <- data.frame(+ #' est = list(col = "blue", lty = 1), |
|||
| 212 | +53 |
- # Dummy column needed downstream to create a nested header.+ #' ci_ribbon = NULL |
||
| 213 | -82x | +|||
| 54 | +
- arm = " ",+ #' ) + scale_y_log10() |
|||
| 214 | -82x | +|||
| 55 | +
- n_tot = unname(result_odds_ratio$n_tot["n_tot"]),+ #' |
|||
| 215 | -82x | +|||
| 56 | +
- or = unname(result_odds_ratio$or_ci["est"]),+ #' # Adding another curve based on additional column. |
|||
| 216 | -82x | +|||
| 57 | +
- lcl = unname(result_odds_ratio$or_ci["lcl"]),+ #' step_data$extra <- exp(step_data$`Percentile Center`) |
|||
| 217 | -82x | +|||
| 58 | +
- ucl = unname(result_odds_ratio$or_ci["ucl"]),+ #' g_step(step_data) + |
|||
| 218 | -82x | +|||
| 59 | +
- conf_level = conf_level,+ #' ggplot2::geom_line(ggplot2::aes(y = extra), linetype = 2, color = "green") |
|||
| 219 | -82x | +|||
| 60 | +
- stringsAsFactors = FALSE+ #' |
|||
| 220 | +61 |
- )+ #' # Response example. |
||
| 221 | +62 |
-
+ #' vars <- list( |
||
| 222 | -82x | +|||
| 63 | +
- if (!is.null(method)) {
+ #' response = "status", |
|||
| 223 | +64 |
- # Test for difference.+ #' arm = "sex", |
||
| 224 | -44x | +|||
| 65 | +
- result_test <- s_test_proportion_diff(+ #' biomarker = "age" |
|||
| 225 | -44x | +|||
| 66 | +
- df = l_df[[2]],+ #' ) |
|||
| 226 | -44x | +|||
| 67 | +
- .var = "rsp",+ #' |
|||
| 227 | -44x | +|||
| 68 | +
- .ref_group = l_df[[1]],+ #' step_matrix <- fit_rsp_step( |
|||
| 228 | -44x | +|||
| 69 | +
- .in_ref_col = FALSE,+ #' variables = vars, |
|||
| 229 | -44x | +|||
| 70 | +
- variables = list(strata = strata_name),+ #' data = lung, |
|||
| 230 | -44x | +|||
| 71 | +
- method = method+ #' control = c( |
|||
| 231 | +72 |
- )+ #' control_logistic(response_definition = "I(response == 2)"), |
||
| 232 | +73 |
-
+ #' control_step() |
||
| 233 | -44x | +|||
| 74 | +
- df$pval <- as.numeric(result_test$pval)+ #' ) |
|||
| 234 | -44x | +|||
| 75 | +
- df$pval_label <- obj_label(result_test$pval)+ #' ) |
|||
| 235 | +76 |
- }+ #' step_data <- broom::tidy(step_matrix) |
||
| 236 | +77 |
-
+ #' g_step(step_data) |
||
| 237 | +78 |
- # In those cases cannot go through the model so will obtain n_tot from data.+ #' |
||
| 238 | +79 |
- } else if (+ #' @export |
||
| 239 | -2x | +|||
| 80 | +
- (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) ||+ g_step <- function(df, |
|||
| 240 | -2x | +|||
| 81 | +
- (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0)+ use_percentile = "Percentile Center" %in% names(df), |
|||
| 241 | +82 |
- ) {
+ est = list(col = "blue", lty = 1), |
||
| 242 | -2x | +|||
| 83 | +
- df <- data.frame(+ ci_ribbon = list(fill = getOption("ggplot2.discrete.colour")[1], alpha = 0.5),
|
|||
| 243 | +84 |
- # Dummy column needed downstream to create a nested header.+ col = getOption("ggplot2.discrete.colour")) {
|
||
| 244 | +85 | 2x |
- arm = " ",+ checkmate::assert_tibble(df) |
|
| 245 | +86 | 2x |
- n_tot = sum(stats::complete.cases(df_rsp)),+ checkmate::assert_flag(use_percentile) |
|
| 246 | +87 | 2x |
- or = NA,+ checkmate::assert_character(col, null.ok = TRUE) |
|
| 247 | +88 | 2x |
- lcl = NA,+ checkmate::assert_list(est, names = "named") |
|
| 248 | +89 | 2x |
- ucl = NA,+ checkmate::assert_list(ci_ribbon, names = "named", null.ok = TRUE) |
|
| 249 | -2x | +|||
| 90 | +
- conf_level = conf_level,+ |
|||
| 250 | +91 | 2x |
- stringsAsFactors = FALSE- |
- |
| 251 | -- |
- )+ x_var <- ifelse(use_percentile, "Percentile Center", "Interval Center") |
||
| 252 | +92 | 2x |
- if (!is.null(method)) {
+ df$x <- df[[x_var]] |
|
| 253 | +93 | 2x |
- df$pval <- NA+ attrs <- attributes(df) |
|
| 254 | +94 | 2x |
- df$pval_label <- NA+ df$y <- df[[attrs$estimate]] |
|
| 255 | +95 |
- }+ |
||
| 256 | +96 |
- } else {
+ # Set legend names. To be modified also at call level |
||
| 257 | -! | +|||
| 97 | +2x |
- df <- data.frame(+ legend_names <- c("Estimate", "CI 95%")
|
||
| 258 | +98 |
- # Dummy column needed downstream to create a nested header.- |
- ||
| 259 | -! | -
- arm = " ",- |
- ||
| 260 | -! | -
- n_tot = 0L,+ |
||
| 261 | -! | +|||
| 99 | +2x |
- or = NA,+ p <- ggplot2::ggplot(df, ggplot2::aes(x = .data[["x"]], y = .data[["y"]])) |
||
| 262 | -! | +|||
| 100 | +
- lcl = NA,+ |
|||
| 263 | -! | +|||
| 101 | +2x |
- ucl = NA,+ if (!is.null(col)) {
|
||
| 264 | -! | +|||
| 102 | +2x |
- conf_level = conf_level,+ p <- p + |
||
| 265 | -! | +|||
| 103 | +2x |
- stringsAsFactors = FALSE+ ggplot2::scale_color_manual(values = col) |
||
| 266 | +104 |
- )+ } |
||
| 267 | +105 | |||
| 268 | -! | +|||
| 106 | +2x |
- if (!is.null(method)) {
+ if (!is.null(ci_ribbon)) {
|
||
| 269 | -! | +|||
| 107 | +1x |
- df$pval <- NA+ if (is.null(ci_ribbon$fill)) {
|
||
| 270 | +108 | ! |
- df$pval_label <- NA+ ci_ribbon$fill <- "lightblue" |
|
| 271 | +109 |
} |
||
| 272 | -- |
- }- |
- ||
| 273 | -- | - - | -||
| 274 | -84x | -
- df- |
- ||
| 275 | -+ | 110 | +1x |
- }+ p <- p + ggplot2::geom_ribbon( |
| 276 | -+ | |||
| 111 | +1x |
-
+ ggplot2::aes( |
||
| 277 | -+ | |||
| 112 | +1x |
- #' @describeIn h_response_subgroups Summarizes estimates of the odds ratio between a treatment and a control+ ymin = .data[["ci_lower"]], ymax = .data[["ci_upper"]], |
||
| 278 | -+ | |||
| 113 | +1x |
- #' arm across subgroups in a data frame. `variables` corresponds to the names of variables found in+ fill = legend_names[2] |
||
| 279 | +114 |
- #' `data`, passed as a named list and requires elements `rsp`, `arm` and optionally `subgroups`+ ), |
||
| 280 | -+ | |||
| 115 | +1x |
- #' and `strata`. `groups_lists` optionally specifies groupings for `subgroups` variables.+ alpha = ci_ribbon$alpha |
||
| 281 | +116 |
- #'+ ) + |
||
| 282 | -+ | |||
| 117 | +1x |
- #' @return+ scale_fill_manual( |
||
| 283 | -+ | |||
| 118 | +1x |
- #' * `h_odds_ratio_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`,+ name = "", values = c("CI 95%" = ci_ribbon$fill)
|
||
| 284 | +119 |
- #' `conf_level`, `subgroup`, `var`, `var_label`, and `row_type`.+ ) |
||
| 285 | +120 |
- #'+ } |
||
| 286 | -+ | |||
| 121 | +2x |
- #' @examples+ suppressMessages(p <- p + |
||
| 287 | -+ | |||
| 122 | +2x |
- #' # Unstratified analysis.+ ggplot2::geom_line( |
||
| 288 | -+ | |||
| 123 | +2x |
- #' h_odds_ratio_subgroups_df(+ ggplot2::aes(y = .data[["y"]], color = legend_names[1]), |
||
| 289 | -+ | |||
| 124 | +2x |
- #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ linetype = est$lty |
||
| 290 | +125 |
- #' data = adrs_f+ ) + |
||
| 291 | -+ | |||
| 126 | +2x |
- #' )+ scale_colour_manual( |
||
| 292 | -+ | |||
| 127 | +2x |
- #'+ name = "", values = c("Estimate" = "blue")
|
||
| 293 | +128 |
- #' # Stratified analysis.+ )) |
||
| 294 | +129 |
- #' h_odds_ratio_subgroups_df(+ |
||
| 295 | -+ | |||
| 130 | +2x |
- #' variables = list(+ p <- p + ggplot2::labs(x = attrs$biomarker, y = attrs$estimate) |
||
| 296 | -+ | |||
| 131 | +2x |
- #' rsp = "rsp",+ if (use_percentile) {
|
||
| 297 | -+ | |||
| 132 | +1x |
- #' arm = "ARM",+ p <- p + ggplot2::scale_x_continuous(labels = scales::percent) |
||
| 298 | +133 |
- #' subgroups = c("SEX", "BMRKR2"),
+ } |
||
| 299 | -+ | |||
| 134 | +2x |
- #' strata = c("STRATA1", "STRATA2")
+ p |
||
| 300 | +135 |
- #' ),+ } |
||
| 301 | +136 |
- #' data = adrs_f+ |
||
| 302 | +137 |
- #' )+ #' Custom tidy method for STEP results |
||
| 303 | +138 |
#' |
||
| 304 | +139 |
- #' # Define groupings of BMRKR2 levels.+ #' @description `r lifecycle::badge("stable")`
|
||
| 305 | +140 |
- #' h_odds_ratio_subgroups_df(+ #' |
||
| 306 | +141 |
- #' variables = list(+ #' Tidy the STEP results into a `tibble` format ready for plotting. |
||
| 307 | +142 |
- #' rsp = "rsp",+ #' |
||
| 308 | +143 |
- #' arm = "ARM",+ #' @param x (`matrix`)\cr results from [fit_survival_step()]. |
||
| 309 | +144 |
- #' subgroups = c("SEX", "BMRKR2")
+ #' @param ... not used. |
||
| 310 | +145 |
- #' ),+ #' |
||
| 311 | +146 |
- #' data = adrs_f,+ #' @return A `tibble` with one row per STEP subgroup. The estimates and CIs are on the HR or OR scale, |
||
| 312 | +147 |
- #' groups_lists = list(+ #' respectively. Additional attributes carry metadata also used for plotting. |
||
| 313 | +148 |
- #' BMRKR2 = list(+ #' |
||
| 314 | +149 |
- #' "low" = "LOW",+ #' @seealso [g_step()] which consumes the result from this function. |
||
| 315 | +150 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' |
||
| 316 | +151 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ #' @method tidy step |
||
| 317 | +152 |
- #' )+ #' |
||
| 318 | +153 |
- #' )+ #' @examples |
||
| 319 | +154 |
- #' )+ #' library(survival) |
||
| 320 | +155 |
- #'+ #' lung$sex <- factor(lung$sex) |
||
| 321 | +156 |
- #' @export+ #' vars <- list( |
||
| 322 | +157 |
- h_odds_ratio_subgroups_df <- function(variables,+ #' time = "time", |
||
| 323 | +158 |
- data,+ #' event = "status", |
||
| 324 | +159 |
- groups_lists = list(),+ #' arm = "sex", |
||
| 325 | +160 |
- conf_level = 0.95,+ #' biomarker = "age" |
||
| 326 | +161 |
- method = NULL,+ #' ) |
||
| 327 | +162 |
- label_all = "All Patients") {
- |
- ||
| 328 | -18x | -
- if ("strat" %in% names(variables)) {
- |
- ||
| 329 | -! | -
- warning(- |
- ||
| 330 | -! | -
- "Warning: the `strat` element name of the `variables` list argument to `h_odds_ratio_subgroups_df() ",- |
- ||
| 331 | -! | -
- "was deprecated in tern 0.9.4.\n ",- |
- ||
| 332 | -! | -
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ #' step_matrix <- fit_survival_step( |
||
| 333 | +163 |
- )- |
- ||
| 334 | -! | -
- variables[["strata"]] <- variables[["strat"]]+ #' variables = vars, |
||
| 335 | +164 |
- }+ #' data = lung, |
||
| 336 | +165 | - - | -||
| 337 | -18x | -
- checkmate::assert_character(variables$rsp)- |
- ||
| 338 | -18x | -
- checkmate::assert_character(variables$arm)- |
- ||
| 339 | -18x | -
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)- |
- ||
| 340 | -18x | -
- checkmate::assert_character(variables$strata, null.ok = TRUE)- |
- ||
| 341 | -18x | -
- assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)- |
- ||
| 342 | -18x | -
- assert_df_with_variables(data, variables)- |
- ||
| 343 | -18x | -
- checkmate::assert_string(label_all)+ #' control = c(control_coxph(), control_step(num_points = 10, degree = 2)) |
||
| 344 | +166 | - - | -||
| 345 | -18x | -
- strata_data <- if (is.null(variables$strata)) {
- |
- ||
| 346 | -16x | -
- NULL+ #' ) |
||
| 347 | +167 |
- } else {
- |
- ||
| 348 | -2x | -
- data[, variables$strata, drop = FALSE]+ #' broom::tidy(step_matrix) |
||
| 349 | +168 |
- }+ #' |
||
| 350 | +169 |
-
+ #' @export |
||
| 351 | +170 |
- # Add All Patients.- |
- ||
| 352 | -18x | -
- result_all <- h_odds_ratio_df(- |
- ||
| 353 | -18x | -
- rsp = data[[variables$rsp]],+ tidy.step <- function(x, ...) { # nolint
|
||
| 354 | -18x | +171 | +7x |
- arm = data[[variables$arm]],+ checkmate::assert_class(x, "step") |
| 355 | -18x | +172 | +7x |
- strata_data = strata_data,+ dat <- as.data.frame(x) |
| 356 | -18x | +173 | +7x |
- conf_level = conf_level,+ nams <- names(dat) |
| 357 | -18x | -
- method = method- |
- ||
| 358 | -+ | 174 | +7x |
- )+ is_surv <- "loghr" %in% names(dat) |
| 359 | -18x | +175 | +7x |
- result_all$subgroup <- label_all+ est_var <- ifelse(is_surv, "loghr", "logor") |
| 360 | -18x | +176 | +7x |
- result_all$var <- "ALL"+ new_est_var <- ifelse(is_surv, "Hazard Ratio", "Odds Ratio") |
| 361 | -18x | +177 | +7x |
- result_all$var_label <- label_all+ new_y_vars <- c(new_est_var, c("ci_lower", "ci_upper"))
|
| 362 | -18x | -
- result_all$row_type <- "content"- |
- ||
| 363 | -+ | 178 | +7x |
-
+ names(dat)[match(est_var, nams)] <- new_est_var |
| 364 | -18x | +179 | +7x |
- if (is.null(variables$subgroups)) {
+ dat[, new_y_vars] <- exp(dat[, new_y_vars]) |
| 365 | -3x | -
- result_all- |
- ||
| 366 | -+ | 180 | +7x |
- } else {
+ any_is_na <- any(is.na(dat[, new_y_vars])) |
| 367 | -15x | -
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)- |
- ||
| 368 | -+ | 181 | +7x |
-
+ any_is_very_large <- any(abs(dat[, new_y_vars]) > 1e10, na.rm = TRUE) |
| 369 | -15x | +182 | +7x |
- l_result <- lapply(l_data, function(grp) {
+ if (any_is_na) {
|
| 370 | -62x | +183 | +2x |
- grp_strata_data <- if (is.null(variables$strata)) {
+ warning(paste( |
| 371 | -54x | -
- NULL- |
- ||
| 372 | -+ | 184 | +2x |
- } else {
+ "Missing values in the point estimate or CI columns,", |
| 373 | -8x | +185 | +2x |
- grp$df[, variables$strata, drop = FALSE]+ "this will lead to holes in the `g_step()` plot" |
| 374 | +186 |
- }+ )) |
||
| 375 | +187 | - - | -||
| 376 | -62x | -
- result <- h_odds_ratio_df(+ } |
||
| 377 | -62x | +188 | +7x |
- rsp = grp$df[[variables$rsp]],+ if (any_is_very_large) {
|
| 378 | -62x | +189 | +2x |
- arm = grp$df[[variables$arm]],+ warning(paste( |
| 379 | -62x | +190 | +2x |
- strata_data = grp_strata_data,+ "Very large absolute values in the point estimate or CI columns,", |
| 380 | -62x | +191 | +2x |
- conf_level = conf_level,+ "consider adding `scale_y_log10()` to the `g_step()` result for plotting" |
| 381 | -62x | +|||
| 192 | +
- method = method+ )) |
|||
| 382 | +193 |
- )+ } |
||
| 383 | -62x | +194 | +7x |
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ if (any_is_na || any_is_very_large) {
|
| 384 | -62x | -
- cbind(result, result_labels)- |
- ||
| 385 | -+ | 195 | +4x |
- })+ warning("Consider using larger `bandwidth`, less `num_points` in `control_step()` settings for fitting")
|
| 386 | +196 |
-
+ } |
||
| 387 | -15x | +197 | +7x |
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ structure( |
| 388 | -15x | -
- result_subgroups$row_type <- "analysis"- |
- ||
| 389 | -+ | 198 | +7x |
-
+ tibble::as_tibble(dat), |
| 390 | -15x | +199 | +7x |
- rbind(+ estimate = new_est_var, |
| 391 | -15x | +200 | +7x |
- result_all,+ biomarker = attr(x, "variables")$biomarker, |
| 392 | -15x | -
- result_subgroups- |
- ||
| 393 | -+ | 201 | +7x |
- )+ ci = f_conf_level(attr(x, "control")$conf_level) |
| 394 | +202 |
- }+ ) |
||
| 395 | +203 |
}@@ -107000,14 +110140,14 @@ tern coverage - 95.59% |
| 1 |
- #' Occurrence table pruning+ #' Combine factor levels |
||
| 5 |
- #' Family of constructor and condition functions to flexibly prune occurrence tables.+ #' Combine specified old factor Levels in a single new level. |
||
| 6 |
- #' The condition functions always return whether the row result is higher than the threshold.+ #' |
||
| 7 |
- #' Since they are of class [CombinationFunction()] they can be logically combined with other condition+ #' @param x (`factor`)\cr factor variable. |
||
| 8 |
- #' functions.+ #' @param levels (`character`)\cr level names to be combined. |
||
| 9 |
- #'+ #' @param new_level (`string`)\cr name of new level. |
||
| 10 |
- #' @note Since most table specifications are worded positively, we name our constructor and condition+ #' |
||
| 11 |
- #' functions positively, too. However, note that the result of [keep_rows()] says what+ #' @return A `factor` with the new levels. |
||
| 12 |
- #' should be pruned, to conform with the [rtables::prune_table()] interface.+ #' |
||
| 13 |
- #'+ #' @examples |
||
| 14 |
- #' @examples+ #' x <- factor(letters[1:5], levels = letters[5:1]) |
||
| 15 |
- #' \donttest{
+ #' combine_levels(x, levels = c("a", "b"))
|
||
| 16 |
- #' tab <- basic_table() %>%+ #' |
||
| 17 |
- #' split_cols_by("ARM") %>%
+ #' combine_levels(x, c("e", "b"))
|
||
| 18 |
- #' split_rows_by("RACE") %>%
+ #' |
||
| 19 |
- #' split_rows_by("STRATA1") %>%
+ #' @export |
||
| 20 |
- #' summarize_row_groups() %>%+ combine_levels <- function(x, levels, new_level = paste(levels, collapse = "/")) {
|
||
| 21 | -+ | 4x |
- #' analyze_vars("COUNTRY", .stats = "count_fraction") %>%
+ checkmate::assert_factor(x) |
| 22 | -+ | 4x |
- #' build_table(DM)+ checkmate::assert_subset(levels, levels(x)) |
| 23 |
- #' }+ |
||
| 24 | -+ | 4x |
- #'+ lvls <- levels(x) |
| 25 |
- #' @name prune_occurrences+ |
||
| 26 | -+ | 4x |
- NULL+ lvls[lvls %in% levels] <- new_level |
| 28 | -+ | 4x |
- #' @describeIn prune_occurrences Constructor for creating pruning functions based on+ levels(x) <- lvls |
| 29 |
- #' a row condition function. This removes all analysis rows (`TableRow`) that should be+ |
||
| 30 | -+ | 4x |
- #' pruned, i.e., don't fulfill the row condition. It removes the sub-tree if there are no+ x |
| 31 |
- #' children left.+ } |
||
| 32 |
- #'+ |
||
| 33 |
- #' @param row_condition (`CombinationFunction`)\cr condition function which works on individual+ #' Conversion of a vector to a factor |
||
| 34 |
- #' analysis rows and flags whether these should be kept in the pruned table.+ #' |
||
| 35 |
- #'+ #' Converts `x` to a factor and keeps its attributes. Warns appropriately such that the user |
||
| 36 |
- #' @return+ #' can decide whether they prefer converting to factor manually (e.g. for full control of |
||
| 37 |
- #' * `keep_rows()` returns a pruning function that can be used with [rtables::prune_table()]+ #' factor levels). |
||
| 38 |
- #' to prune an `rtables` table.+ #' |
||
| 39 |
- #'+ #' @param x (`vector`)\cr object to convert. |
||
| 40 |
- #' @examples+ #' @param x_name (`string`)\cr name of `x`. |
||
| 41 |
- #' \donttest{
+ #' @param na_level (`string`)\cr the explicit missing level which should be used when converting a character vector. |
||
| 42 |
- #' # `keep_rows`+ #' @param verbose (`flag`)\cr defaults to `TRUE`. It prints out warnings and messages. |
||
| 43 |
- #' is_non_empty <- !CombinationFunction(all_zero_or_na)+ #' |
||
| 44 |
- #' prune_table(tab, keep_rows(is_non_empty))+ #' @return A `factor` with same attributes (except class) as `x`. Does not modify `x` if already a `factor`. |
||
| 45 |
- #' }+ #' |
||
| 46 |
- #'+ #' @keywords internal |
||
| 47 |
- #' @export+ as_factor_keep_attributes <- function(x, |
||
| 48 |
- keep_rows <- function(row_condition) {
+ x_name = deparse(substitute(x)), |
||
| 49 | -6x | +
- checkmate::assert_function(row_condition)+ na_level = "<Missing>", |
|
| 50 | -6x | +
- function(table_tree) {
+ verbose = TRUE) {
|
|
| 51 | -2256x | +221x |
- if (inherits(table_tree, "TableRow")) {
+ checkmate::assert_atomic(x) |
| 52 | -1872x | +221x |
- return(!row_condition(table_tree))+ checkmate::assert_string(x_name) |
| 53 | -+ | 221x |
- }+ checkmate::assert_string(na_level) |
| 54 | -384x | +221x |
- children <- tree_children(table_tree)+ checkmate::assert_flag(verbose) |
| 55 | -384x | +221x |
- identical(length(children), 0L)+ if (is.factor(x)) {
|
| 56 | -+ | 200x |
- }+ return(x) |
| 57 |
- }+ } |
||
| 58 | -+ | 21x |
-
+ x_class <- class(x)[1] |
| 59 | -+ | 21x |
- #' @describeIn prune_occurrences Constructor for creating pruning functions based on+ if (verbose) {
|
| 60 | -+ | 15x |
- #' a condition for the (first) content row in leaf tables. This removes all leaf tables where+ warning(paste( |
| 61 | -+ | 15x |
- #' the first content row does not fulfill the condition. It does not check individual rows.+ "automatically converting", x_class, "variable", x_name, |
| 62 | -+ | 15x |
- #' It then proceeds recursively by removing the sub tree if there are no children left.+ "to factor, better manually convert to factor to avoid failures" |
| 63 |
- #'+ )) |
||
| 64 |
- #' @param content_row_condition (`CombinationFunction`)\cr condition function which works on individual+ } |
||
| 65 | -+ | 21x |
- #' first content rows of leaf tables and flags whether these leaf tables should be kept in the pruned table.+ if (identical(length(x), 0L)) {
|
| 66 | -+ | 1x |
- #'+ warning(paste( |
| 67 | -+ | 1x |
- #' @return+ x_name, "has length 0, this can lead to tabulation failures, better convert to factor" |
| 68 |
- #' * `keep_content_rows()` returns a pruning function that checks the condition on the first content+ )) |
||
| 69 |
- #' row of leaf tables in the table.+ } |
||
| 70 | -+ | 21x |
- #'+ if (is.character(x)) {
|
| 71 | -+ | 21x |
- #' @examples+ x_no_na <- explicit_na(sas_na(x), label = na_level) |
| 72 | -+ | 21x |
- #' # `keep_content_rows`+ if (any(na_level %in% x_no_na)) {
|
| 73 | -+ | 3x |
- #' \donttest{
+ do.call( |
| 74 | -+ | 3x |
- #' more_than_twenty <- has_count_in_cols(atleast = 20L, col_names = names(tab))+ structure, |
| 75 | -+ | 3x |
- #' prune_table(tab, keep_content_rows(more_than_twenty))+ c( |
| 76 | -+ | 3x |
- #' }+ list(.Data = forcats::fct_relevel(x_no_na, na_level, after = Inf)), |
| 77 | -+ | 3x |
- #'+ attributes(x) |
| 78 |
- #' @export+ ) |
||
| 79 |
- keep_content_rows <- function(content_row_condition) {
+ ) |
||
| 80 | -1x | +
- checkmate::assert_function(content_row_condition)+ } else {
|
|
| 81 | -1x | +18x |
- function(table_tree) {
+ do.call(structure, c(list(.Data = as.factor(x)), attributes(x))) |
| 82 | -166x | +
- if (is_leaf_table(table_tree)) {
+ } |
|
| 83 | -24x | +
- content_row <- h_content_first_row(table_tree)+ } else {
|
|
| 84 | -24x | +! |
- return(!content_row_condition(content_row))+ do.call(structure, c(list(.Data = as.factor(x)), attributes(x))) |
| 85 |
- }+ } |
||
| 86 | -142x | +
- if (inherits(table_tree, "DataRow")) {
+ } |
|
| 87 | -120x | +
- return(FALSE)+ |
|
| 88 |
- }+ #' Labels for bins in percent |
||
| 89 | -22x | +
- children <- tree_children(table_tree)+ #' |
|
| 90 | -22x | +
- identical(length(children), 0L)+ #' This creates labels for quantile based bins in percent. This assumes the right-closed |
|
| 91 |
- }+ #' intervals as produced by [cut_quantile_bins()]. |
||
| 92 |
- }+ #' |
||
| 93 |
-
+ #' @param probs (`numeric`)\cr the probabilities identifying the quantiles. |
||
| 94 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on total counts in the specified columns.+ #' This is a sorted vector of unique `proportion` values, i.e. between 0 and 1, where |
||
| 95 |
- #'+ #' the boundaries 0 and 1 must not be included. |
||
| 96 |
- #' @param atleast (`numeric(1)`)\cr threshold which should be met in order to keep the row.+ #' @param digits (`integer(1)`)\cr number of decimal places to round the percent numbers. |
||
| 97 |
- #' @param ... arguments for row or column access, see [`rtables_access`]: either `col_names` (`character`) including+ #' |
||
| 98 |
- #' the names of the columns which should be used, or alternatively `col_indices` (`integer`) giving the indices+ #' @return A `character` vector with labels in the format `[0%,20%]`, `(20%,50%]`, etc. |
||
| 99 |
- #' directly instead.+ #' |
||
| 100 |
- #'+ #' @keywords internal |
||
| 101 |
- #' @return+ bins_percent_labels <- function(probs, |
||
| 102 |
- #' * `has_count_in_cols()` returns a condition function that sums the counts in the specified column.+ digits = 0) {
|
||
| 103 | -+ | 3x |
- #'+ if (isFALSE(0 %in% probs)) probs <- c(0, probs) |
| 104 | -+ | 3x |
- #' @examples+ if (isFALSE(1 %in% probs)) probs <- c(probs, 1) |
| 105 | -+ | 10x |
- #' \donttest{
+ checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE) |
| 106 | -+ | 10x |
- #' more_than_one <- has_count_in_cols(atleast = 1L, col_names = names(tab))+ percent <- round(probs * 100, digits = digits) |
| 107 | -+ | 10x |
- #' prune_table(tab, keep_rows(more_than_one))+ left <- paste0(utils::head(percent, -1), "%") |
| 108 | -+ | 10x |
- #' }+ right <- paste0(utils::tail(percent, -1), "%") |
| 109 | -+ | 10x |
- #'+ without_left_bracket <- paste0(left, ",", right, "]") |
| 110 | -+ | 10x |
- #' @export+ with_left_bracket <- paste0("[", utils::head(without_left_bracket, 1))
|
| 111 | -+ | 10x |
- has_count_in_cols <- function(atleast, ...) {
+ if (length(without_left_bracket) > 1) {
|
| 112 | -6x | +7x |
- checkmate::assert_count(atleast)+ with_left_bracket <- c( |
| 113 | -6x | +7x |
- CombinationFunction(function(table_row) {
+ with_left_bracket, |
| 114 | -337x | +7x |
- row_counts <- h_row_counts(table_row, ...)+ paste0("(", utils::tail(without_left_bracket, -1))
|
| 115 | -337x | +
- total_count <- sum(row_counts)+ ) |
|
| 116 | -337x | +
- total_count >= atleast+ } |
|
| 117 | -+ | 10x |
- })+ with_left_bracket |
| 120 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on any of the counts in+ #' Cut numeric vector into empirical quantile bins |
||
| 121 |
- #' the specified columns satisfying a threshold.+ #' |
||
| 122 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 123 |
- #' @param atleast (`numeric(1)`)\cr threshold which should be met in order to keep the row.+ #' |
||
| 124 |
- #'+ #' This cuts a numeric vector into sample quantile bins. |
||
| 125 |
- #' @return+ #' |
||
| 126 |
- #' * `has_count_in_any_col()` returns a condition function that compares the counts in the+ #' @inheritParams bins_percent_labels |
||
| 127 |
- #' specified columns with the threshold.+ #' @param x (`numeric`)\cr the continuous variable values which should be cut into |
||
| 128 |
- #'+ #' quantile bins. This may contain `NA` values, which are then |
||
| 129 |
- #' @examples+ #' not used for the quantile calculations, but included in the return vector. |
||
| 130 |
- #' \donttest{
+ #' @param labels (`character`)\cr the unique labels for the quantile bins. When there are `n` |
||
| 131 |
- #' # `has_count_in_any_col`+ #' probabilities in `probs`, then this must be `n + 1` long. |
||
| 132 |
- #' any_more_than_one <- has_count_in_any_col(atleast = 1L, col_names = names(tab))+ #' @param type (`integer(1)`)\cr type of quantiles to use, see [stats::quantile()] for details. |
||
| 133 |
- #' prune_table(tab, keep_rows(any_more_than_one))+ #' @param ordered (`flag`)\cr should the result be an ordered factor. |
||
| 134 |
- #' }+ #' |
||
| 135 |
- #'+ #' @return A `factor` variable with appropriately-labeled bins as levels. |
||
| 136 |
- #' @export+ #' |
||
| 137 |
- has_count_in_any_col <- function(atleast, ...) {
+ #' @note Intervals are closed on the right side. That is, the first bin is the interval |
||
| 138 | -3x | +
- checkmate::assert_count(atleast)+ #' `[-Inf, q1]` where `q1` is the first quantile, the second bin is then `(q1, q2]`, etc., |
|
| 139 | -3x | +
- CombinationFunction(function(table_row) {
+ #' and the last bin is `(qn, +Inf]` where `qn` is the last quantile. |
|
| 140 | -3x | +
- row_counts <- h_row_counts(table_row, ...)+ #' |
|
| 141 | -3x | +
- any(row_counts >= atleast)+ #' @examples |
|
| 142 |
- })+ #' # Default is to cut into quartile bins. |
||
| 143 |
- }+ #' cut_quantile_bins(cars$speed) |
||
| 144 |
-
+ #' |
||
| 145 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on total fraction in+ #' # Use custom quantiles. |
||
| 146 |
- #' the specified columns.+ #' cut_quantile_bins(cars$speed, probs = c(0.1, 0.2, 0.6, 0.88)) |
||
| 148 |
- #' @return+ #' # Use custom labels. |
||
| 149 |
- #' * `has_fraction_in_cols()` returns a condition function that sums the counts in the+ #' cut_quantile_bins(cars$speed, labels = paste0("Q", 1:4))
|
||
| 150 |
- #' specified column, and computes the fraction by dividing by the total column counts.+ #' |
||
| 151 |
- #'+ #' # NAs are preserved in result factor. |
||
| 152 |
- #' @examples+ #' ozone_binned <- cut_quantile_bins(airquality$Ozone) |
||
| 153 |
- #' \donttest{
+ #' which(is.na(ozone_binned)) |
||
| 154 |
- #' # `has_fraction_in_cols`+ #' # So you might want to make these explicit. |
||
| 155 |
- #' more_than_five_percent <- has_fraction_in_cols(atleast = 0.05, col_names = names(tab))+ #' explicit_na(ozone_binned) |
||
| 156 |
- #' prune_table(tab, keep_rows(more_than_five_percent))+ #' |
||
| 157 |
- #' }+ #' @export |
||
| 158 |
- #'+ cut_quantile_bins <- function(x, |
||
| 159 |
- #' @export+ probs = c(0.25, 0.5, 0.75), |
||
| 160 |
- has_fraction_in_cols <- function(atleast, ...) {
+ labels = NULL, |
||
| 161 | -4x | +
- assert_proportion_value(atleast, include_boundaries = TRUE)+ type = 7, |
|
| 162 | -4x | +
- CombinationFunction(function(table_row) {
+ ordered = TRUE) {
|
|
| 163 | -306x | +8x |
- row_counts <- h_row_counts(table_row, ...)+ checkmate::assert_flag(ordered) |
| 164 | -306x | +8x |
- total_count <- sum(row_counts)+ checkmate::assert_numeric(x) |
| 165 | -306x | +7x |
- col_counts <- h_col_counts(table_row, ...)+ if (isFALSE(0 %in% probs)) probs <- c(0, probs) |
| 166 | -306x | +7x |
- total_n <- sum(col_counts)+ if (isFALSE(1 %in% probs)) probs <- c(probs, 1) |
| 167 | -306x | +8x |
- total_percent <- total_count / total_n+ checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE) |
| 168 | -306x | +7x |
- total_percent >= atleast+ if (is.null(labels)) labels <- bins_percent_labels(probs) |
| 169 | -+ | 8x |
- })+ checkmate::assert_character(labels, len = length(probs) - 1, any.missing = FALSE, unique = TRUE) |
| 170 |
- }+ |
||
| 171 | -+ | 8x |
-
+ if (all(is.na(x))) {
|
| 172 |
- #' @describeIn prune_occurrences Constructor for creating condition functions on any fraction in+ # Early return if there are only NAs in input. |
||
| 173 | -+ | 1x |
- #' the specified columns.+ return(factor(x, ordered = ordered, levels = labels)) |
| 174 |
- #'+ } |
||
| 175 |
- #' @return+ |
||
| 176 | -+ | 7x |
- #' * `has_fraction_in_any_col()` returns a condition function that looks at the fractions+ quantiles <- stats::quantile( |
| 177 | -+ | 7x |
- #' in the specified columns and checks whether any of them fulfill the threshold.+ x, |
| 178 | -+ | 7x |
- #'+ probs = probs, |
| 179 | -+ | 7x |
- #' @examples+ type = type, |
| 180 | -+ | 7x |
- #' \donttest{
+ na.rm = TRUE |
| 181 |
- #' # `has_fraction_in_any_col`+ ) |
||
| 182 |
- #' any_atleast_five_percent <- has_fraction_in_any_col(atleast = 0.05, col_names = names(tab))+ |
||
| 183 | -+ | 7x |
- #' prune_table(tab, keep_rows(any_atleast_five_percent))+ checkmate::assert_numeric(quantiles, unique = TRUE) |
| 184 |
- #' }+ |
||
| 185 | -+ | 6x |
- #'+ cut( |
| 186 | -+ | 6x |
- #' @export+ x, |
| 187 | -+ | 6x |
- has_fraction_in_any_col <- function(atleast, ...) {
+ breaks = quantiles, |
| 188 | -3x | +6x |
- assert_proportion_value(atleast, include_boundaries = TRUE)+ labels = labels, |
| 189 | -3x | +6x |
- CombinationFunction(function(table_row) {
+ ordered_result = ordered, |
| 190 | -3x | +6x |
- row_fractions <- h_row_fractions(table_row, ...)+ include.lowest = TRUE, |
| 191 | -3x | +6x |
- any(row_fractions >= atleast)+ right = TRUE |
| 192 |
- })+ ) |
||
| 195 |
- #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference+ #' Discard specified levels of a factor |
||
| 196 |
- #' between the fractions reported in each specified column.+ #' |
||
| 197 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 198 |
- #' @return+ #' |
||
| 199 |
- #' * `has_fractions_difference()` returns a condition function that extracts the fractions of each+ #' This discards the observations as well as the levels specified from a factor. |
||
| 200 |
- #' specified column, and computes the difference of the minimum and maximum.+ #' |
||
| 201 |
- #'+ #' @param x (`factor`)\cr the original factor. |
||
| 202 |
- #' @examples+ #' @param discard (`character`)\cr levels to discard. |
||
| 203 |
- #' \donttest{
+ #' |
||
| 204 |
- #' # `has_fractions_difference`+ #' @return A modified `factor` with observations as well as levels from `discard` dropped. |
||
| 205 |
- #' more_than_five_percent_diff <- has_fractions_difference(atleast = 0.05, col_names = names(tab))+ #' |
||
| 206 |
- #' prune_table(tab, keep_rows(more_than_five_percent_diff))+ #' @examples |
||
| 207 |
- #' }+ #' fct_discard(factor(c("a", "b", "c")), "c")
|
||
| 210 |
- has_fractions_difference <- function(atleast, ...) {
+ fct_discard <- function(x, discard) {
|
||
| 211 | -4x | +321x |
- assert_proportion_value(atleast, include_boundaries = TRUE)+ checkmate::assert_factor(x) |
| 212 | -4x | +321x |
- CombinationFunction(function(table_row) {
+ checkmate::assert_character(discard, any.missing = FALSE) |
| 213 | -246x | +321x |
- fractions <- h_row_fractions(table_row, ...)+ new_obs <- x[!(x %in% discard)] |
| 214 | -246x | +321x |
- difference <- diff(range(fractions))+ new_levels <- setdiff(levels(x), discard) |
| 215 | -246x | +321x |
- difference >= atleast+ factor(new_obs, levels = new_levels) |
| 216 |
- })+ } |
||
| 217 |
- }+ |
||
| 218 |
-
+ #' Insertion of explicit missing values in a factor |
||
| 219 |
- #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference+ #' |
||
| 220 |
- #' between the counts reported in each specified column.+ #' @description `r lifecycle::badge("stable")`
|
||
| 222 |
- #' @return+ #' This inserts explicit missing values in a factor based on a condition. Additionally, |
||
| 223 |
- #' * `has_counts_difference()` returns a condition function that extracts the counts of each+ #' existing `NA` values will be explicitly converted to given `na_level`. |
||
| 224 |
- #' specified column, and computes the difference of the minimum and maximum.+ #' |
||
| 225 |
- #'+ #' @param x (`factor`)\cr the original factor. |
||
| 226 |
- #' @examples+ #' @param condition (`logical`)\cr positions at which to insert missing values. |
||
| 227 |
- #' \donttest{
+ #' @param na_level (`string`)\cr which level to use for missing values. |
||
| 228 |
- #' more_than_one_diff <- has_counts_difference(atleast = 1L, col_names = names(tab))+ #' |
||
| 229 |
- #' prune_table(tab, keep_rows(more_than_one_diff))+ #' @return A modified `factor` with inserted and existing `NA` converted to `na_level`. |
||
| 230 |
- #' }+ #' |
||
| 231 |
- #'+ #' @seealso [forcats::fct_na_value_to_level()] which is used internally. |
||
| 232 | - |
- #' @export- |
- |
| 233 | -- |
- has_counts_difference <- function(atleast, ...) {
- |
- |
| 234 | -4x | -
- checkmate::assert_count(atleast)- |
- |
| 235 | -4x | -
- CombinationFunction(function(table_row) {
- |
- |
| 236 | -30x | -
- counts <- h_row_counts(table_row, ...)- |
- |
| 237 | -30x | -
- difference <- diff(range(counts))- |
- |
| 238 | -30x | -
- difference >= atleast- |
- |
| 239 | -- |
- })- |
- |
| 240 | -- |
- }- |
-
| 1 | -- |
- #' Re-implemented `range()` default S3 method for numerical objects- |
- ||
| 2 | -- |
- #'- |
- ||
| 3 | -- |
- #' This function returns `c(NA, NA)` instead of `c(-Inf, Inf)` for zero-length data- |
- ||
| 4 | -- |
- #' without any warnings.- |
- ||
| 5 | -- |
- #'- |
- ||
| 6 | -- |
- #' @param x (`numeric`)\cr a sequence of numbers for which the range is computed.- |
- ||
| 7 | -- |
- #' @param na.rm (`flag`)\cr flag indicating if `NA` should be omitted.- |
- ||
| 8 | -- |
- #' @param finite (`flag`)\cr flag indicating if non-finite elements should be removed.- |
- ||
| 9 | -- |
- #'- |
- ||
| 10 | -- |
- #' @return A 2-element vector of class `numeric`.- |
- ||
| 11 | -- |
- #'- |
- ||
| 12 | -- |
- #' @keywords internal- |
- ||
| 13 | -- |
- range_noinf <- function(x, na.rm = FALSE, finite = FALSE) { # nolint
- |
- ||
| 14 | -- | - - | -||
| 15 | -1884x | -
- checkmate::assert_numeric(x)- |
- ||
| 16 | -- | - - | -||
| 17 | -1884x | -
- if (finite) {
- |
- ||
| 18 | -24x | -
- x <- x[is.finite(x)] # removes NAs too- |
- ||
| 19 | -1860x | -
- } else if (na.rm) {
- |
- ||
| 20 | -708x | -
- x <- x[!is.na(x)]- |
- ||
| 21 | -- |
- }- |
- ||
| 22 | -- | - - | -||
| 23 | -1884x | -
- if (length(x) == 0) {
- |
- ||
| 24 | -111x | -
- rval <- c(NA, NA)- |
- ||
| 25 | -111x | -
- mode(rval) <- typeof(x)- |
- ||
| 26 | -- |
- } else {
- |
- ||
| 27 | -1773x | -
- rval <- c(min(x, na.rm = FALSE), max(x, na.rm = FALSE))- |
- ||
| 28 | -- |
- }- |
- ||
| 29 | -- | - - | -||
| 30 | -1884x | -
- return(rval)- |
- ||
| 31 | -- |
- }- |
- ||
| 32 | -- | - - | -||
| 33 | -- |
- #' Utility function to create label for confidence interval- |
- ||
| 34 | -- |
- #'- |
- ||
| 35 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- ||
| 36 | -
#' |
|||
| 37 | -- |
- #' @inheritParams argument_convention- |
- ||
| 38 | +233 |
- #'+ #' @examples |
||
| 39 | +234 |
- #' @return A `string`.+ #' fct_explicit_na_if(factor(c("a", "b", NA)), c(TRUE, FALSE, FALSE))
|
||
| 40 | +235 |
#' |
||
| 41 | +236 |
#' @export |
||
| 42 | +237 |
- f_conf_level <- function(conf_level) {
+ fct_explicit_na_if <- function(x, condition, na_level = "<Missing>") {
|
||
| 43 | -8277x | +238 | +1x |
- assert_proportion_value(conf_level)+ checkmate::assert_factor(x, len = length(condition)) |
| 44 | -8275x | -
- paste0(conf_level * 100, "% CI")- |
- ||
| 45 | -- |
- }- |
- ||
| 46 | -- | - - | -||
| 47 | -- |
- #' Utility function to create label for p-value- |
- ||
| 48 | -- |
- #'- |
- ||
| 49 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- ||
| 50 | -- |
- #'- |
- ||
| 51 | -- |
- #' @param test_mean (`numeric(1)`)\cr mean value to test under the null hypothesis.- |
- ||
| 52 | -- |
- #'- |
- ||
| 53 | -- |
- #' @return A `string`.- |
- ||
| 54 | -- |
- #'- |
- ||
| 55 | -+ | 239 | +1x |
- #' @export+ checkmate::assert_logical(condition) |
| 56 | -+ | |||
| 240 | +1x |
- f_pval <- function(test_mean) {
+ x[condition] <- NA |
||
| 57 | -1145x | +241 | +1x |
- checkmate::assert_numeric(test_mean, len = 1)+ x <- forcats::fct_na_value_to_level(x, level = na_level) |
| 58 | -1143x | +242 | +1x |
- paste0("p-value (H0: mean = ", test_mean, ")")
+ forcats::fct_drop(x, only = na_level) |
| 59 | +243 |
} |
||
| 60 | +244 | |||
| 61 | +245 |
- #' Utility function to return a named list of covariate names+ #' Collapse factor levels and keep only those new group levels |
||
| 62 | +246 |
#' |
||
| 63 | +247 |
- #' @param covariates (`character`)\cr a vector that can contain single variable names (such as+ #' @description `r lifecycle::badge("stable")`
|
||
| 64 | +248 |
- #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`.+ #' |
||
| 65 | +249 |
- #'+ #' This collapses levels and only keeps those new group levels, in the order provided. |
||
| 66 | +250 |
- #' @return A named `list` of `character` vector.+ #' The returned factor has levels in the order given, with the possible missing level last (this will |
||
| 67 | +251 |
- #'+ #' only be included if there are missing values). |
||
| 68 | +252 |
- #' @keywords internal+ #' |
||
| 69 | +253 |
- get_covariates <- function(covariates) {
- |
- ||
| 70 | -14x | -
- checkmate::assert_character(covariates)- |
- ||
| 71 | -12x | -
- cov_vars <- unique(trimws(unlist(strsplit(covariates, "\\*"))))- |
- ||
| 72 | -12x | -
- stats::setNames(as.list(cov_vars), cov_vars)+ #' @param .f (`factor` or `character`)\cr original vector. |
||
| 73 | +254 |
- }+ #' @param ... (named `character`)\cr levels in each vector provided will be collapsed into |
||
| 74 | +255 |
-
+ #' the new level given by the respective name. |
||
| 75 | +256 |
- #' Replicate entries of a vector if required+ #' @param .na_level (`string`)\cr which level to use for other levels, which should be missing in the |
||
| 76 | +257 |
- #'+ #' new factor. Note that this level must not be contained in the new levels specified in `...`. |
||
| 77 | +258 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 78 | +259 |
- #'+ #' @return A modified `factor` with collapsed levels. Values and levels which are not included |
||
| 79 | +260 |
- #' Replicate entries of a vector if required.+ #' in the given `character` vector input will be set to the missing level `.na_level`. |
||
| 80 | +261 |
#' |
||
| 81 | +262 |
- #' @inheritParams argument_convention+ #' @note Any existing `NA`s in the input vector will not be replaced by the missing level. If needed, |
||
| 82 | +263 |
- #' @param n (`integer(1)`)\cr number of entries that are needed.+ #' [explicit_na()] can be called separately on the result. |
||
| 83 | +264 |
#' |
||
| 84 | +265 |
- #' @return `x` if it has the required length already or is `NULL`,+ #' @seealso [forcats::fct_collapse()], [forcats::fct_relevel()] which are used internally. |
||
| 85 | +266 |
- #' otherwise if it is scalar the replicated version of it with `n` entries.+ #' |
||
| 86 | +267 |
- #'+ #' @examples |
||
| 87 | +268 |
- #' @note This function will fail if `x` is not of length `n` and/or is not a scalar.+ #' fct_collapse_only(factor(c("a", "b", "c", "d")), TRT = "b", CTRL = c("c", "d"))
|
||
| 88 | +269 |
#' |
||
| 89 | +270 |
#' @export |
||
| 90 | +271 |
- to_n <- function(x, n) {
+ fct_collapse_only <- function(.f, ..., .na_level = "<Missing>") {
|
||
| 91 | -5x | +272 | +4x |
- if (is.null(x)) {
+ new_lvls <- names(list(...)) |
| 92 | -1x | +273 | +4x |
- NULL+ if (checkmate::test_subset(.na_level, new_lvls)) {
|
| 93 | -4x | +274 | +1x |
- } else if (length(x) == 1) {
+ stop(paste0(".na_level currently set to '", .na_level, "' must not be contained in the new levels"))
|
| 94 | -1x | +|||
| 275 | +
- rep(x, n)+ } |
|||
| 95 | +276 | 3x |
- } else if (length(x) == n) {
+ x <- forcats::fct_collapse(.f, ..., other_level = .na_level) |
|
| 96 | -2x | +277 | +3x |
- x+ do.call(forcats::fct_relevel, args = c(list(.f = x), as.list(new_lvls))) |
| 97 | +278 |
- } else {
- |
- ||
| 98 | -1x | -
- stop("dimension mismatch")
+ } |
||
| 99 | +279 |
- }+ |
||
| 100 | +280 |
- }+ #' Ungroup non-numeric statistics |
||
| 101 | +281 |
-
+ #' |
||
| 102 | +282 |
- #' Check element dimension+ #' Ungroups grouped non-numeric statistics within input vectors `.formats`, `.labels`, and `.indent_mods`. |
||
| 103 | +283 |
#' |
||
| 104 | +284 |
- #' Checks if the elements in `...` have the same dimension.+ #' @inheritParams argument_convention |
||
| 105 | +285 |
- #'+ #' @param stat_out (named `list` of `numeric`)\cr list of numeric statistics containing the statistics to ungroup. |
||
| 106 | +286 |
- #' @param ... (`data.frame` or `vector`)\cr any data frames or vectors.+ #' |
||
| 107 | +287 |
- #' @param omit_null (`flag`)\cr whether `NULL` elements in `...` should be omitted from the check.+ #' @return A `list` with modified elements `stat_out`, `.formats`, `.labels`, `.levels`, and `.indent_mods`. |
||
| 108 | +288 |
#' |
||
| 109 | +289 |
- #' @return A `logical` value.+ #' @seealso [a_summary()] which uses this function internally. |
||
| 110 | +290 |
#' |
||
| 111 | +291 |
#' @keywords internal |
||
| 112 | +292 |
- check_same_n <- function(..., omit_null = TRUE) {
+ ungroup_stats <- function(stat_out, |
||
| 113 | -2x | +|||
| 293 | +
- dots <- list(...)+ .formats, |
|||
| 114 | +294 |
-
+ .indent_mods) {
|
||
| 115 | -2x | +|||
| 295 | +! |
- n_list <- Map(+ checkmate::assert_list(stat_out) |
||
| 116 | -2x | +|||
| 296 | +! |
- function(x, name) {
+ empty_pval <- "pval" %in% names(stat_out) && length(stat_out[["pval"]]) == 0 |
||
| 117 | -5x | +|||
| 297 | +! |
- if (is.null(x)) {
+ empty_pval_counts <- "pval_counts" %in% names(stat_out) && length(stat_out[["pval_counts"]]) == 0 |
||
| 118 | +298 | ! |
- if (omit_null) {
+ stat_out <- unlist(stat_out, recursive = FALSE) |
|
| 119 | -2x | +|||
| 299 | +
- NA_integer_+ |
|||
| 120 | +300 |
- } else {
+ # If p-value is empty it is removed by unlist and needs to be re-added |
||
| 121 | +301 | ! |
- stop("arg", name, "is not supposed to be NULL")
- |
- |
| 122 | -- |
- }+ if (empty_pval) stat_out[["pval"]] <- character() |
||
| 123 | -5x | +|||
| 302 | +! |
- } else if (is.data.frame(x)) {
+ if (empty_pval_counts) stat_out[["pval_counts"]] <- character() |
||
| 124 | +303 | ! |
- nrow(x)+ .stats <- sapply(regmatches(names(stat_out), regexpr("\\.", names(stat_out)), invert = TRUE), function(xi) xi[[1]])
|
|
| 125 | -5x | +|||
| 304 | +
- } else if (is.atomic(x)) {
+
|
|||
| 126 | -5x | +|||
| 305 | +
- length(x)+ # Ungroup stats |
|||
| 127 | -+ | |||
| 306 | +! |
- } else {
+ .formats <- lapply(.stats, function(x) {
|
||
| 128 | +307 | ! |
- stop("data structure for ", name, "is currently not supported")
+ .formats[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
|
|
| 129 | +308 |
- }+ }) |
||
| 130 | +309 |
- },+ |
||
| 131 | -2x | +|||
| 310 | +! |
- dots, names(dots)+ .indent_mods <- sapply(.stats, function(x) {
|
||
| 132 | -+ | |||
| 311 | +! |
- )+ .indent_mods[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
|
||
| 133 | +312 | - - | -||
| 134 | -2x | -
- n <- stats::na.omit(unlist(n_list))+ }) |
||
| 135 | +313 | |||
| 136 | -2x | +|||
| 314 | +! |
- if (length(unique(n)) > 1) {
+ list( |
||
| 137 | +315 | ! |
- sel <- which(n != n[1])+ x = stat_out, |
|
| 138 | +316 | ! |
- stop("Dimension mismatch:", paste(names(n)[sel], collapse = ", "), " do not have N=", n[1])
+ .formats = .formats, |
|
| 139 | -+ | |||
| 317 | +! |
- }+ .indent_mods = .indent_mods |
||
| 140 | +318 | - - | -||
| 141 | -2x | -
- TRUE+ ) |
||
| 142 | +319 |
} |
| 143 | -- | - - | -||
| 144 | +1 |
- #' Utility function to check if a float value is equal to another float value+ #' Helper function to create a new SMQ variable in ADAE by stacking SMQ and/or CQ records. |
||
| 145 | +2 |
#' |
||
| 146 | +3 |
- #' Uses `.Machine$double.eps` as the tolerance for the comparison.+ #' @description `r lifecycle::badge("stable")`
|
||
| 147 | +4 |
#' |
||
| 148 | +5 |
- #' @param x (`numeric(1)`)\cr a float number.+ #' Helper function to create a new SMQ variable in ADAE that consists of all adverse events belonging to |
||
| 149 | +6 |
- #' @param y (`numeric(1)`)\cr a float number.+ #' selected Standardized/Customized queries. The new dataset will only contain records of the adverse events |
||
| 150 | +7 |
- #'+ #' belonging to any of the selected baskets. Remember that `na_str` must match the needed pre-processing |
||
| 151 | +8 |
- #' @return `TRUE` if identical, otherwise `FALSE`.+ #' done with [df_explicit_na()] to have the desired output. |
||
| 152 | +9 |
#' |
||
| 153 | +10 |
- #' @keywords internal+ #' @inheritParams argument_convention |
||
| 154 | +11 |
- .is_equal_float <- function(x, y) {
- |
- ||
| 155 | -2990x | -
- checkmate::assert_number(x)- |
- ||
| 156 | -2990x | -
- checkmate::assert_number(y)+ #' @param baskets (`character`)\cr variable names of the selected Standardized/Customized queries. |
||
| 157 | +12 |
-
+ #' @param smq_varlabel (`string`)\cr a label for the new variable created. |
||
| 158 | +13 |
- # Define a tolerance- |
- ||
| 159 | -2990x | -
- tolerance <- .Machine$double.eps+ #' @param keys (`character`)\cr names of the key variables to be returned along with the new variable created. |
||
| 160 | +14 |
-
+ #' @param aag_summary (`data.frame`)\cr containing the SMQ baskets and the levels of interest for the final SMQ |
||
| 161 | +15 |
- # Check if x is close enough to y- |
- ||
| 162 | -2990x | -
- abs(x - y) < tolerance+ #' variable. This is useful when there are some levels of interest that are not observed in the `df` dataset. |
||
| 163 | +16 |
- }+ #' The two columns of this dataset should be named `basket` and `basket_name`. |
||
| 164 | +17 |
-
+ #' |
||
| 165 | +18 |
- #' Make names without dots+ #' @return A `data.frame` with variables in `keys` taken from `df` and new variable SMQ containing |
||
| 166 | +19 |
- #'+ #' records belonging to the baskets selected via the `baskets` argument. |
||
| 167 | +20 |
- #' @param nams (`character`)\cr vector of original names.+ #' |
||
| 168 | +21 |
- #'+ #' @examples |
||
| 169 | +22 |
- #' @return A `character` `vector` of proper names, which does not use dots in contrast to [make.names()].+ #' adae <- tern_ex_adae[1:20, ] %>% df_explicit_na() |
||
| 170 | +23 |
- #'+ #' h_stack_by_baskets(df = adae) |
||
| 171 | +24 |
- #' @keywords internal+ #' |
||
| 172 | +25 |
- make_names <- function(nams) {
- |
- ||
| 173 | -6x | -
- orig <- make.names(nams)- |
- ||
| 174 | -6x | -
- gsub(".", "", x = orig, fixed = TRUE)
+ #' aag <- data.frame( |
||
| 175 | +26 |
- }+ #' NAMVAR = c("CQ01NAM", "CQ02NAM", "SMQ01NAM", "SMQ02NAM"),
|
||
| 176 | +27 |
-
+ #' REFNAME = c( |
||
| 177 | +28 |
- #' Conversion of months to days+ #' "D.2.1.5.3/A.1.1.1.1 aesi", "X.9.9.9.9/Y.8.8.8.8 aesi", |
||
| 178 | +29 |
- #'+ #' "C.1.1.1.3/B.2.2.3.1 aesi", "C.1.1.1.3/B.3.3.3.3 aesi" |
||
| 179 | +30 |
- #' @description `r lifecycle::badge("stable")`
+ #' ), |
||
| 180 | +31 |
- #'+ #' SCOPE = c("", "", "BROAD", "BROAD"),
|
||
| 181 | +32 |
- #' Conversion of months to days. This is an approximative calculation because it+ #' stringsAsFactors = FALSE |
||
| 182 | +33 |
- #' considers each month as having an average of 30.4375 days.+ #' ) |
||
| 183 | +34 |
#' |
||
| 184 | +35 |
- #' @param x (`numeric(1)`)\cr time in months.+ #' basket_name <- character(nrow(aag)) |
||
| 185 | +36 |
- #'+ #' cq_pos <- grep("^(CQ).+NAM$", aag$NAMVAR)
|
||
| 186 | +37 |
- #' @return A `numeric` vector with the time in days.+ #' smq_pos <- grep("^(SMQ).+NAM$", aag$NAMVAR)
|
||
| 187 | +38 |
- #'+ #' basket_name[cq_pos] <- aag$REFNAME[cq_pos] |
||
| 188 | +39 |
- #' @examples+ #' basket_name[smq_pos] <- paste0( |
||
| 189 | +40 |
- #' x <- c(13.25, 8.15, 1, 2.834)+ #' aag$REFNAME[smq_pos], "(", aag$SCOPE[smq_pos], ")"
|
||
| 190 | +41 |
- #' month2day(x)+ #' ) |
||
| 191 | +42 |
#' |
||
| 192 | +43 |
- #' @export+ #' aag_summary <- data.frame( |
||
| 193 | +44 |
- month2day <- function(x) {
+ #' basket = aag$NAMVAR, |
||
| 194 | -1x | +|||
| 45 | +
- checkmate::assert_numeric(x)+ #' basket_name = basket_name, |
|||
| 195 | -1x | +|||
| 46 | +
- x * 30.4375+ #' stringsAsFactors = TRUE |
|||
| 196 | +47 |
- }+ #' ) |
||
| 197 | +48 |
-
+ #' |
||
| 198 | +49 |
- #' Conversion of days to months+ #' result <- h_stack_by_baskets(df = adae, aag_summary = aag_summary) |
||
| 199 | +50 |
- #'+ #' all(levels(aag_summary$basket_name) %in% levels(result$SMQ)) |
||
| 200 | +51 |
- #' @param x (`numeric(1)`)\cr time in days.+ #' |
||
| 201 | +52 |
- #'+ #' h_stack_by_baskets( |
||
| 202 | +53 |
- #' @return A `numeric` vector with the time in months.+ #' df = adae, |
||
| 203 | +54 |
- #'+ #' aag_summary = NULL, |
||
| 204 | +55 |
- #' @examples+ #' keys = c("STUDYID", "USUBJID", "AEDECOD", "ARM"),
|
||
| 205 | +56 |
- #' x <- c(403, 248, 30, 86)+ #' baskets = "SMQ01NAM" |
||
| 206 | +57 |
- #' day2month(x)+ #' ) |
||
| 207 | +58 |
#' |
||
| 208 | +59 |
#' @export |
||
| 209 | +60 |
- day2month <- function(x) {
- |
- ||
| 210 | -19x | -
- checkmate::assert_numeric(x)- |
- ||
| 211 | -19x | -
- x / 30.4375+ h_stack_by_baskets <- function(df, |
||
| 212 | +61 |
- }+ baskets = grep("^(SMQ|CQ).+NAM$", names(df), value = TRUE),
|
||
| 213 | +62 |
-
+ smq_varlabel = "Standardized MedDRA Query", |
||
| 214 | +63 |
- #' Return an empty numeric if all elements are `NA`.+ keys = c("STUDYID", "USUBJID", "ASTDTM", "AEDECOD", "AESEQ"),
|
||
| 215 | +64 |
- #'+ aag_summary = NULL, |
||
| 216 | +65 |
- #' @param x (`numeric`)\cr vector.+ na_str = "<Missing>") {
|
||
| 217 | -+ | |||
| 66 | +5x |
- #'+ smq_nam <- baskets[startsWith(baskets, "SMQ")] |
||
| 218 | +67 |
- #' @return An empty `numeric` if all elements of `x` are `NA`, otherwise `x`.+ # SC corresponding to NAM |
||
| 219 | -+ | |||
| 68 | +5x |
- #'+ smq_sc <- gsub(pattern = "NAM", replacement = "SC", x = smq_nam, fixed = TRUE) |
||
| 220 | -+ | |||
| 69 | +5x |
- #' @examples+ smq <- stats::setNames(smq_sc, smq_nam) |
||
| 221 | +70 |
- #' x <- c(NA, NA, NA)+ |
||
| 222 | -+ | |||
| 71 | +5x |
- #' # Internal function - empty_vector_if_na+ checkmate::assert_character(baskets) |
||
| 223 | -+ | |||
| 72 | +5x |
- #' @keywords internal+ checkmate::assert_string(smq_varlabel) |
||
| 224 | -+ | |||
| 73 | +5x |
- empty_vector_if_na <- function(x) {
+ checkmate::assert_data_frame(df) |
||
| 225 | -1017x | +74 | +5x |
- if (all(is.na(x))) {
+ checkmate::assert_true(all(startsWith(baskets, "SMQ") | startsWith(baskets, "CQ"))) |
| 226 | -310x | +75 | +4x |
- numeric()+ checkmate::assert_true(all(endsWith(baskets, "NAM"))) |
| 227 | -+ | |||
| 76 | +3x |
- } else {
+ checkmate::assert_subset(baskets, names(df)) |
||
| 228 | -707x | +77 | +3x |
- x+ checkmate::assert_subset(keys, names(df)) |
| 229 | -+ | |||
| 78 | +3x |
- }+ checkmate::assert_subset(smq_sc, names(df)) |
||
| 230 | -+ | |||
| 79 | +3x |
- }+ checkmate::assert_string(na_str) |
||
| 231 | +80 | |||
| 232 | -+ | |||
| 81 | +3x |
- #' Element-wise combination of two vectors+ if (!is.null(aag_summary)) {
|
||
| 233 | -+ | |||
| 82 | +1x |
- #'+ assert_df_with_variables( |
||
| 234 | -+ | |||
| 83 | +1x |
- #' @param x (`vector`)\cr first vector to combine.+ df = aag_summary, |
||
| 235 | -+ | |||
| 84 | +1x |
- #' @param y (`vector`)\cr second vector to combine.+ variables = list(val = c("basket", "basket_name"))
|
||
| 236 | +85 |
- #'+ ) |
||
| 237 | +86 |
- #' @return A `list` where each element combines corresponding elements of `x` and `y`.+ # Warning in case there is no match between `aag_summary$basket` and `baskets` argument. |
||
| 238 | +87 |
- #'+ # Honestly, I think those should completely match. Target baskets should be the same. |
||
| 239 | -+ | |||
| 88 | +1x |
- #' @examples+ if (length(intersect(baskets, unique(aag_summary$basket))) == 0) {
|
||
| 240 | -+ | |||
| 89 | +! |
- #' combine_vectors(1:3, 4:6)+ warning("There are 0 baskets in common between aag_summary$basket and `baskets` argument.")
|
||
| 241 | +90 |
- #'+ } |
||
| 242 | +91 |
- #' @export+ } |
||
| 243 | +92 |
- combine_vectors <- function(x, y) {
+
|
||
| 244 | -51x | +93 | +3x |
- checkmate::assert_vector(x)+ var_labels <- c(formatters::var_labels(df[, keys]), "SMQ" = smq_varlabel) |
| 245 | -51x | +|||
| 94 | +
- checkmate::assert_vector(y, len = length(x))+ |
|||
| 246 | +95 |
-
+ # convert `na_str` records from baskets to NA for the later loop and from wide to long steps |
||
| 247 | -51x | +96 | +3x |
- result <- lapply(as.data.frame(rbind(x, y)), `c`)+ df[, c(baskets, smq_sc)][df[, c(baskets, smq_sc)] == na_str] <- NA |
| 248 | -51x | +|||
| 97 | +
- names(result) <- NULL+ |
|||
| 249 | -51x | +98 | +3x |
- result+ if (all(is.na(df[, baskets]))) { # in case there is no level for the target baskets
|
| 250 | -+ | |||
| 99 | +1x |
- }+ df_long <- df[-seq_len(nrow(df)), keys] # we just need an empty data frame keeping all factor levels |
||
| 251 | +100 |
-
+ } else {
|
||
| 252 | +101 |
- #' Extract elements by name+ # Concatenate SMQxxxNAM with corresponding SMQxxxSC |
||
| 253 | -+ | |||
| 102 | +2x |
- #'+ df_cnct <- df[, c(keys, baskets[startsWith(baskets, "CQ")])] |
||
| 254 | +103 |
- #' This utility function extracts elements from a vector `x` by `names`.+ |
||
| 255 | -+ | |||
| 104 | +2x |
- #' Differences to the standard `[` function are:+ for (nam in names(smq)) {
|
||
| 256 | -+ | |||
| 105 | +4x |
- #'+ sc <- smq[nam] # SMQxxxSC corresponding to SMQxxxNAM |
||
| 257 | -+ | |||
| 106 | +4x |
- #' - If `x` is `NULL`, then still always `NULL` is returned (same as in base function).+ nam_notna <- !is.na(df[[nam]]) |
||
| 258 | -+ | |||
| 107 | +4x |
- #' - If `x` is not `NULL`, then the intersection of its names is made with `names` and those+ new_colname <- paste(nam, sc, sep = "_") |
||
| 259 | -+ | |||
| 108 | +4x |
- #' elements are returned. That is, `names` which don't appear in `x` are not returned as `NA`s.+ df_cnct[nam_notna, new_colname] <- paste0(df[[nam]], "(", df[[sc]], ")")[nam_notna]
|
||
| 260 | +109 |
- #'+ } |
||
| 261 | +110 |
- #' @param x (named `vector`)\cr where to extract named elements from.+ |
||
| 262 | -+ | |||
| 111 | +2x |
- #' @param names (`character`)\cr vector of names to extract.+ df_cnct$unique_id <- seq(1, nrow(df_cnct)) |
||
| 263 | -+ | |||
| 112 | +2x |
- #'+ var_cols <- names(df_cnct)[!(names(df_cnct) %in% c(keys, "unique_id"))] |
||
| 264 | +113 |
- #' @return `NULL` if `x` is `NULL`, otherwise the extracted elements from `x`.+ # have to convert df_cnct from tibble to data frame |
||
| 265 | +114 |
- #'+ # as it throws a warning otherwise about rownames. |
||
| 266 | +115 |
- #' @keywords internal+ # tibble do not support rownames and reshape creates rownames |
||
| 267 | +116 |
- extract_by_name <- function(x, names) {
+
|
||
| 268 | -3x | +117 | +2x |
- if (is.null(x)) {
+ df_long <- stats::reshape( |
| 269 | -1x | +118 | +2x |
- return(NULL)+ data = as.data.frame(df_cnct), |
| 270 | -+ | |||
| 119 | +2x |
- }+ varying = var_cols, |
||
| 271 | +120 | 2x |
- checkmate::assert_named(x)+ v.names = "SMQ", |
|
| 272 | +121 | 2x |
- checkmate::assert_character(names)+ idvar = names(df_cnct)[names(df_cnct) %in% c(keys, "unique_id")], |
|
| 273 | +122 | 2x |
- which_extract <- intersect(names(x), names)+ direction = "long", |
|
| 274 | +123 | 2x |
- if (length(which_extract) > 0) {
+ new.row.names = seq(prod(length(var_cols), nrow(df_cnct))) |
|
| 275 | -1x | +|||
| 124 | +
- x[which_extract]+ ) |
|||
| 276 | +125 |
- } else {
+
|
||
| 277 | -1x | +126 | +2x |
- NULL+ df_long <- df_long[!is.na(df_long[, "SMQ"]), !(names(df_long) %in% c("time", "unique_id"))]
|
| 278 | -+ | |||
| 127 | +2x |
- }+ df_long$SMQ <- as.factor(df_long$SMQ) |
||
| 279 | +128 |
- }+ } |
||
| 280 | +129 | |||
| 281 | -+ | |||
| 130 | +3x |
- #' Labels for adverse event baskets+ smq_levels <- setdiff(levels(df_long[["SMQ"]]), na_str) |
||
| 282 | +131 |
- #'+ |
||
| 283 | -+ | |||
| 132 | +3x |
- #' @description `r lifecycle::badge("stable")`
+ if (!is.null(aag_summary)) {
|
||
| 284 | +133 |
- #'+ # A warning in case there is no match between df and aag_summary records |
||
| 285 | -+ | |||
| 134 | +1x |
- #' @param aesi (`character`)\cr vector with standardized MedDRA query name (e.g. `SMQxxNAM`) or customized query+ if (length(intersect(smq_levels, unique(aag_summary$basket_name))) == 0) {
|
||
| 286 | -+ | |||
| 135 | +1x |
- #' name (e.g. `CQxxNAM`).+ warning("There are 0 basket levels in common between aag_summary$basket_name and df.")
|
||
| 287 | +136 |
- #' @param scope (`character`)\cr vector with scope of query (e.g. `SMQxxSC`).+ } |
||
| 288 | -+ | |||
| 137 | +1x |
- #'+ df_long[["SMQ"]] <- factor( |
||
| 289 | -+ | |||
| 138 | +1x |
- #' @return A `string` with the standard label for the AE basket.+ df_long[["SMQ"]], |
||
| 290 | -+ | |||
| 139 | +1x |
- #'+ levels = sort( |
||
| 291 | -+ | |||
| 140 | +1x |
- #' @examples+ c( |
||
| 292 | -+ | |||
| 141 | +1x |
- #' adae <- tern_ex_adae+ smq_levels, |
||
| 293 | -+ | |||
| 142 | +1x |
- #'+ setdiff(unique(aag_summary$basket_name), smq_levels) |
||
| 294 | +143 |
- #' # Standardized query label includes scope.+ ) |
||
| 295 | +144 |
- #' aesi_label(adae$SMQ01NAM, scope = adae$SMQ01SC)+ ) |
||
| 296 | +145 |
- #'+ ) |
||
| 297 | +146 |
- #' # Customized query label.+ } else {
|
||
| 298 | -+ | |||
| 147 | +2x |
- #' aesi_label(adae$CQ01NAM)+ all_na_basket_flag <- vapply(df[, baskets], function(x) {
|
||
| 299 | -+ | |||
| 148 | +6x |
- #'+ all(is.na(x)) |
||
| 300 | -+ | |||
| 149 | +2x |
- #' @export+ }, FUN.VALUE = logical(1)) |
||
| 301 | -+ | |||
| 150 | +2x |
- aesi_label <- function(aesi, scope = NULL) {
+ all_na_basket <- baskets[all_na_basket_flag] |
||
| 302 | -4x | +|||
| 151 | +
- checkmate::assert_character(aesi)+ |
|||
| 303 | -4x | +152 | +2x |
- checkmate::assert_character(scope, null.ok = TRUE)+ df_long[["SMQ"]] <- factor( |
| 304 | -4x | +153 | +2x |
- aesi_label <- obj_label(aesi)+ df_long[["SMQ"]], |
| 305 | -4x | +154 | +2x |
- aesi <- sas_na(aesi)+ levels = sort(c(smq_levels, all_na_basket)) |
| 306 | -4x | +|||
| 155 | +
- aesi <- unique(aesi)[!is.na(unique(aesi))]+ ) |
|||
| 307 | +156 |
-
+ } |
||
| 308 | -4x | +157 | +3x |
- lbl <- if (length(aesi) == 1 && !is.null(scope)) {
+ formatters::var_labels(df_long) <- var_labels |
| 309 | -1x | +158 | +3x |
- scope <- sas_na(scope)+ tibble::tibble(df_long) |
| 310 | -1x | +|||
| 159 | +
- scope <- unique(scope)[!is.na(unique(scope))]+ } |
|||
| 311 | -1x | +
| 1 | +
- checkmate::assert_string(scope)+ #' Get default statistical methods and their associated formats, labels, and indent modifiers |
|||
| 312 | -1x | +|||
| 2 | +
- paste0(aesi, " (", scope, ")")
+ #' |
|||
| 313 | -4x | +|||
| 3 | +
- } else if (length(aesi) == 1 && is.null(scope)) {
+ #' @description `r lifecycle::badge("experimental")`
|
|||
| 314 | -1x | +|||
| 4 | +
- aesi+ #' |
|||
| 315 | +5 |
- } else {
+ #' Utility functions to get valid statistic methods for different method groups |
||
| 316 | -2x | +|||
| 6 | +
- aesi_label+ #' (`.stats`) and their associated formats (`.formats`), labels (`.labels`), and indent modifiers |
|||
| 317 | +7 |
- }+ #' (`.indent_mods`). This utility is used across `tern`, but some of its working principles can be |
||
| 318 | +8 |
-
+ #' seen in [analyze_vars()]. See notes to understand why this is experimental. |
||
| 319 | -4x | +|||
| 9 | +
- lbl+ #' |
|||
| 320 | +10 |
- }+ #' @param stats (`character`)\cr statistical methods to return defaults for. |
||
| 321 | +11 |
-
+ #' @param levels_per_stats (named `list` of `character` or `NULL`)\cr named list where the name of each element is a |
||
| 322 | +12 |
- #' Indicate study arm variable in formula+ #' statistic from `stats` and each element is the levels of a `factor` or `character` variable (or variable name), |
||
| 323 | +13 |
- #'+ #' each corresponding to a single row, for which the named statistic should be calculated for. If a statistic is only |
||
| 324 | +14 |
- #' We use `study_arm` to indicate the study arm variable in `tern` formulas.+ #' calculated once (one row), the element can be either `NULL` or the name of the statistic. Each list element will be |
||
| 325 | +15 |
- #'+ #' flattened such that the names of the list elements returned by the function have the format `statistic.level` (or |
||
| 326 | +16 |
- #' @param x arm information+ #' just `statistic` for statistics calculated for a single row). Defaults to `NULL`. |
||
| 327 | +17 |
- #'+ #' @param tern_defaults (`list` or `vector`)\cr defaults to use to fill in missing values if no user input is given. |
||
| 328 | +18 |
- #' @return `x`+ #' Must be of the same type as the values that are being filled in (e.g. indentation must be integers). |
||
| 329 | +19 |
#' |
||
| 330 | +20 |
- #' @keywords internal+ #' @details |
||
| 331 | +21 |
- study_arm <- function(x) {
+ #' Current choices for `type` are `counts` and `numeric` for [analyze_vars()] and affect `get_stats()`. |
||
| 332 | -! | +|||
| 22 | +
- structure(x, varname = deparse(substitute(x)))+ #' |
|||
| 333 | +23 |
- }+ #' @note |
||
| 334 | +24 |
-
+ #' These defaults are experimental because we use the names of functions to retrieve the default |
||
| 335 | +25 |
- #' Smooth function with optional grouping+ #' statistics. This should be generalized in groups of methods according to more reasonable groupings. |
||
| 336 | +26 |
#' |
||
| 337 | +27 |
- #' @description `r lifecycle::badge("stable")`
+ #' @name default_stats_formats_labels |
||
| 338 | +28 |
- #'+ NULL |
||
| 339 | +29 |
- #' This produces `loess` smoothed estimates of `y` with Student confidence intervals.+ |
||
| 340 | +30 |
- #'+ #' @describeIn default_stats_formats_labels Get statistics available for a given method |
||
| 341 | +31 |
- #' @param df (`data.frame`)\cr data set containing all analysis variables.+ #' group (analyze function). To check available defaults see `tern::tern_default_stats` list. |
||
| 342 | +32 |
- #' @param x (`string`)\cr x column name.+ #' |
||
| 343 | +33 |
- #' @param y (`string`)\cr y column name.+ #' @param method_groups (`character`)\cr indicates the statistical method group (`tern` analyze function) |
||
| 344 | +34 |
- #' @param groups (`character` or `NULL`)\cr vector with optional grouping variables names.+ #' to retrieve default statistics for. A character vector can be used to specify more than one statistical |
||
| 345 | +35 |
- #' @param level (`proportion`)\cr level of confidence interval to use (0.95 by default).+ #' method group. |
||
| 346 | +36 |
- #'+ #' @param stats_in (`character`)\cr statistics to retrieve for the selected method group. |
||
| 347 | +37 |
- #' @return A `data.frame` with original `x`, smoothed `y`, `ylow`, and `yhigh`, and+ #' @param add_pval (`flag`)\cr should `"pval"` (or `"pval_counts"` if `method_groups` contains |
||
| 348 | +38 |
- #' optional `groups` variables formatted as `factor` type.+ #' `"analyze_vars_counts"`) be added to the statistical methods? |
||
| 349 | +39 |
#' |
||
| 350 | +40 |
- #' @export+ #' @return |
||
| 351 | +41 |
- get_smooths <- function(df, x, y, groups = NULL, level = 0.95) {
+ #' * `get_stats()` returns a `character` vector of statistical methods. |
||
| 352 | -5x | +|||
| 42 | +
- checkmate::assert_data_frame(df)+ #' |
|||
| 353 | -5x | +|||
| 43 | +
- df_cols <- colnames(df)+ #' @examples |
|||
| 354 | -5x | +|||
| 44 | +
- checkmate::assert_string(x)+ #' # analyze_vars is numeric |
|||
| 355 | -5x | +|||
| 45 | +
- checkmate::assert_subset(x, df_cols)+ #' num_stats <- get_stats("analyze_vars_numeric") # also the default
|
|||
| 356 | -5x | +|||
| 46 | +
- checkmate::assert_numeric(df[[x]])+ #' |
|||
| 357 | -5x | +|||
| 47 | +
- checkmate::assert_string(y)+ #' # Other type |
|||
| 358 | -5x | +|||
| 48 | +
- checkmate::assert_subset(y, df_cols)+ #' cnt_stats <- get_stats("analyze_vars_counts")
|
|||
| 359 | -5x | +|||
| 49 | +
- checkmate::assert_numeric(df[[y]])+ #' |
|||
| 360 | +50 |
-
+ #' # Weirdly taking the pval from count_occurrences |
||
| 361 | -5x | +|||
| 51 | +
- if (!is.null(groups)) {
+ #' only_pval <- get_stats("count_occurrences", add_pval = TRUE, stats_in = "pval")
|
|||
| 362 | -4x | +|||
| 52 | +
- checkmate::assert_character(groups)+ #' |
|||
| 363 | -4x | +|||
| 53 | +
- checkmate::assert_subset(groups, df_cols)+ #' # All count_occurrences |
|||
| 364 | +54 |
- }+ #' all_cnt_occ <- get_stats("count_occurrences")
|
||
| 365 | +55 |
-
+ #' |
||
| 366 | -5x | +|||
| 56 | +
- smooths <- function(x, y) {
+ #' # Multiple |
|||
| 367 | -18x | +|||
| 57 | +
- stats::predict(stats::loess(y ~ x), se = TRUE)+ #' get_stats(c("count_occurrences", "analyze_vars_counts"))
|
|||
| 368 | +58 |
- }+ #' |
||
| 369 | +59 |
-
+ #' @export |
||
| 370 | -5x | +|||
| 60 | +
- if (!is.null(groups)) {
+ get_stats <- function(method_groups = "analyze_vars_numeric", stats_in = NULL, add_pval = FALSE) {
|
|||
| 371 | -4x | +61 | +642x |
- cc <- stats::complete.cases(df[c(x, y, groups)])+ checkmate::assert_character(method_groups) |
| 372 | -4x | +62 | +642x |
- df_c <- df[cc, c(x, y, groups)]+ checkmate::assert_character(stats_in, null.ok = TRUE) |
| 373 | -4x | +63 | +642x |
- df_c_ordered <- df_c[do.call("order", as.list(df_c[, groups, drop = FALSE])), , drop = FALSE]
+ checkmate::assert_flag(add_pval) |
| 374 | -4x | +|||
| 64 | +
- df_c_g <- data.frame(Map(as.factor, df_c_ordered[groups]))+ |
|||
| 375 | +65 |
-
+ # Default is still numeric |
||
| 376 | -4x | +66 | +642x |
- df_smooth_raw <-+ if (any(method_groups == "analyze_vars")) {
|
| 377 | -4x | +67 | +3x |
- by(df_c_ordered, df_c_g, function(d) {
+ method_groups[method_groups == "analyze_vars"] <- "analyze_vars_numeric" |
| 378 | -17x | +|||
| 68 | +
- plx <- smooths(d[[x]], d[[y]])+ } |
|||
| 379 | -17x | +|||
| 69 | +
- data.frame(+ |
|||
| 380 | -17x | +70 | +642x |
- x = d[[x]],+ type_tmp <- ifelse(any(grepl("counts$", method_groups)), "counts", "numeric") # for pval checks
|
| 381 | -17x | +|||
| 71 | +
- y = plx$fit,+ |
|||
| 382 | -17x | +|||
| 72 | +
- ylow = plx$fit - stats::qt(level, plx$df) * plx$se.fit,+ # Defaults for loop |
|||
| 383 | -17x | +73 | +642x |
- yhigh = plx$fit + stats::qt(level, plx$df) * plx$se.fit+ out <- NULL |
| 384 | +74 |
- )+ |
||
| 385 | +75 |
- })+ # Loop for multiple method groups |
||
| 386 | -+ | |||
| 76 | +642x |
-
+ for (mgi in method_groups) {
|
||
| 387 | -4x | +77 | +669x |
- df_smooth <- do.call(rbind, df_smooth_raw)+ if (mgi %in% names(tern_default_stats)) {
|
| 388 | -4x | +78 | +668x |
- df_smooth[groups] <- df_c_g+ out_tmp <- tern_default_stats[[mgi]] |
| 389 | +79 |
-
+ } else {
|
||
| 390 | -4x | +80 | +1x |
- df_smooth+ stop("The selected method group (", mgi, ") has no default statistical method.")
|
| 391 | +81 |
- } else {
+ } |
||
| 392 | -1x | +82 | +668x |
- cc <- stats::complete.cases(df[c(x, y)])+ out <- unique(c(out, out_tmp)) |
| 393 | -1x | +|||
| 83 | +
- df_c <- df[cc, ]+ } |
|||
| 394 | -1x | +|||
| 84 | +
- plx <- smooths(df_c[[x]], df_c[[y]])+ |
|||
| 395 | +85 |
-
+ # If you added pval to the stats_in you certainly want it |
||
| 396 | -1x | +86 | +641x |
- df_smooth <- data.frame(+ if (!is.null(stats_in) && any(grepl("^pval", stats_in))) {
|
| 397 | -1x | +87 | +22x |
- x = df_c[[x]],+ stats_in_pval_value <- stats_in[grepl("^pval", stats_in)]
|
| 398 | -1x | +|||
| 88 | +
- y = plx$fit,+ |
|||
| 399 | -1x | +|||
| 89 | +
- ylow = plx$fit - stats::qt(level, plx$df) * plx$se.fit,+ # Must be only one value between choices |
|||
| 400 | -1x | +90 | +22x |
- yhigh = plx$fit + stats::qt(level, plx$df) * plx$se.fit+ checkmate::assert_choice(stats_in_pval_value, c("pval", "pval_counts"))
|
| 401 | +91 |
- )+ |
||
| 402 | +92 |
-
+ # Mismatch with counts and numeric |
||
| 403 | -1x | +93 | +21x |
- df_smooth+ if (any(grepl("counts", method_groups)) && stats_in_pval_value != "pval_counts" ||
|
| 404 | -+ | |||
| 94 | +21x |
- }+ any(grepl("numeric", method_groups)) && stats_in_pval_value != "pval") { # nolint
|
||
| 405 | -+ | |||
| 95 | +2x |
- }+ stop( |
||
| 406 | -+ | |||
| 96 | +2x |
-
+ "Inserted p-value (", stats_in_pval_value, ") is not valid for type ",
|
||
| 407 | -+ | |||
| 97 | +2x |
- #' Number of available (non-missing entries) in a vector+ type_tmp, ". Use ", paste(ifelse(stats_in_pval_value == "pval", "pval_counts", "pval")), |
||
| 408 | -+ | |||
| 98 | +2x |
- #'+ " instead." |
||
| 409 | +99 |
- #' Small utility function for better readability.+ ) |
||
| 410 | +100 |
- #'+ } |
||
| 411 | +101 |
- #' @param x (`vector`)\cr vector in which to count non-missing values.+ |
||
| 412 | +102 |
- #'+ # Lets add it even if present (thanks to unique) |
||
| 413 | -+ | |||
| 103 | +19x |
- #' @return Number of non-missing values.+ add_pval <- TRUE |
||
| 414 | +104 |
- #'+ } |
||
| 415 | +105 |
- #' @keywords internal+ |
||
| 416 | +106 |
- n_available <- function(x) {
+ # Mainly used in "analyze_vars" but it could be necessary elsewhere |
||
| 417 | -355x | +107 | +638x |
- sum(!is.na(x))+ if (isTRUE(add_pval)) {
|
| 418 | -+ | |||
| 108 | +29x |
- }+ if (any(grepl("counts", method_groups))) {
|
||
| 419 | -+ | |||
| 109 | +16x |
-
+ out <- unique(c(out, "pval_counts")) |
||
| 420 | +110 |
- #' Reapply variable labels+ } else {
|
||
| 421 | -+ | |||
| 111 | +13x |
- #'+ out <- unique(c(out, "pval")) |
||
| 422 | +112 |
- #' This is a helper function that is used in tests.+ } |
||
| 423 | +113 |
- #'+ } |
||
| 424 | +114 |
- #' @param x (`vector`)\cr vector of elements that needs new labels.+ |
||
| 425 | +115 |
- #' @param varlabels (`character`)\cr vector of labels for `x`.+ # Filtering for stats_in (character vector) |
||
| 426 | -+ | |||
| 116 | +638x |
- #' @param ... further parameters to be added to the list.+ if (!is.null(stats_in)) {
|
||
| 427 | -+ | |||
| 117 | +586x |
- #'+ out <- intersect(stats_in, out) # It orders them too |
||
| 428 | +118 |
- #' @return `x` with variable labels reapplied.+ } |
||
| 429 | +119 |
- #'+ |
||
| 430 | +120 |
- #' @export+ # If intersect did not find matches (and no pval?) -> error |
||
| 431 | -+ | |||
| 121 | +638x |
- reapply_varlabels <- function(x, varlabels, ...) {
+ if (length(out) == 0) {
|
||
| 432 | -11x | +122 | +2x |
- named_labels <- c(as.list(varlabels), list(...))+ stop( |
| 433 | -11x | +123 | +2x |
- formatters::var_labels(x)[names(named_labels)] <- as.character(named_labels)+ "The selected method group(s) (", paste0(method_groups, collapse = ", "), ")",
|
| 434 | -11x | +124 | +2x |
- x+ " do not have the required default statistical methods:\n", |
| 435 | -+ | |||
| 125 | +2x |
- }+ paste0(stats_in, collapse = " ") |
||
| 436 | +126 |
-
+ ) |
||
| 437 | +127 |
- # Wrapper function of survival::clogit so that when model fitting failed, a more useful message would show+ } |
||
| 438 | +128 |
- clogit_with_tryCatch <- function(formula, data, ...) { # nolint
- |
- ||
| 439 | -33x | -
- tryCatch(- |
- ||
| 440 | -33x | -
- survival::clogit(formula = formula, data = data, ...),+ |
||
| 441 | -33x | +129 | +636x |
- error = function(e) stop("model not built successfully with survival::clogit")
+ out |
| 442 | +130 |
- )+ } |
||
| 443 | +131 |
- }+ |
| 1 | +132 |
- #' Combine factor levels+ #' @describeIn default_stats_formats_labels Get statistical *names* available for a given method |
||
| 2 | +133 |
- #'+ #' group (analyze function). Please use the `s_*` functions to get the statistical names. |
||
| 3 | +134 |
- #' @description `r lifecycle::badge("stable")`
+ #' @param stat_results (`list`)\cr list of statistical results. It should be used close to the end of |
||
| 4 | +135 |
- #'+ #' a statistical function. See examples for a structure with two statistical results and two groups. |
||
| 5 | +136 |
- #' Combine specified old factor Levels in a single new level.+ #' @param stat_names_in (`character`)\cr custom modification of statistical values. |
||
| 6 | +137 |
#' |
||
| 7 | +138 |
- #' @param x (`factor`)\cr factor variable.+ #' @return |
||
| 8 | +139 |
- #' @param levels (`character`)\cr level names to be combined.+ #' * `get_stat_names()` returns a named list of`character` vectors, indicating the names of |
||
| 9 | +140 |
- #' @param new_level (`string`)\cr name of new level.+ #' statistical outputs. |
||
| 10 | +141 |
#' |
||
| 11 | +142 |
- #' @return A `factor` with the new levels.+ #' @examples |
||
| 12 | +143 |
- #'+ #' stat_results <- list( |
||
| 13 | +144 |
- #' @examples+ #' "n" = list("M" = 1, "F" = 2),
|
||
| 14 | +145 |
- #' x <- factor(letters[1:5], levels = letters[5:1])+ #' "count_fraction" = list("M" = c(1, 0.2), "F" = c(2, 0.1))
|
||
| 15 | +146 |
- #' combine_levels(x, levels = c("a", "b"))
+ #' ) |
||
| 16 | +147 |
- #'+ #' get_stat_names(stat_results) |
||
| 17 | +148 |
- #' combine_levels(x, c("e", "b"))
+ #' get_stat_names(stat_results, list("n" = "argh"))
|
||
| 18 | +149 |
#' |
||
| 19 | +150 |
#' @export |
||
| 20 | +151 |
- combine_levels <- function(x, levels, new_level = paste(levels, collapse = "/")) {
+ get_stat_names <- function(stat_results, stat_names_in = NULL) {
|
||
| 21 | -4x | +152 | +379x |
- checkmate::assert_factor(x)+ checkmate::assert_character(names(stat_results), min.len = 1) |
| 22 | -4x | +153 | +379x |
- checkmate::assert_subset(levels, levels(x))+ checkmate::assert_list(stat_names_in, null.ok = TRUE) |
| 23 | +154 | |||
| 24 | -4x | -
- lvls <- levels(x)- |
- ||
| 25 | -+ | 155 | +379x |
-
+ stat_nms_from_stats <- lapply(stat_results, function(si) {
|
| 26 | -4x | +156 | +2743x |
- lvls[lvls %in% levels] <- new_level+ nm <- names(si) |
| 27 | -+ | |||
| 157 | +2743x |
-
+ if (is.null(nm)) {
|
||
| 28 | -4x | +158 | +30x |
- levels(x) <- lvls+ nm <- rep(NA_character_, length(si)) # no statistical names |
| 29 | +159 |
-
+ } |
||
| 30 | -4x | +160 | +2743x |
- x+ return(nm) |
| 31 | +161 |
- }+ }) |
||
| 32 | +162 | |||
| 33 | +163 |
- #' Conversion of a vector to a factor+ # Modify some with custom stat names |
||
| 34 | -+ | |||
| 164 | +379x |
- #'+ if (!is.null(stat_names_in)) {
|
||
| 35 | +165 |
- #' Converts `x` to a factor and keeps its attributes. Warns appropriately such that the user+ # Stats is the main |
||
| 36 | -+ | |||
| 166 | +6x |
- #' can decide whether they prefer converting to factor manually (e.g. for full control of+ common_names <- intersect(names(stat_nms_from_stats), names(stat_names_in))+ |
+ ||
| 167 | +6x | +
+ stat_nms_from_stats[common_names] <- stat_names_in[common_names] |
||
| 37 | +168 |
- #' factor levels).+ } |
||
| 38 | +169 |
- #'+ + |
+ ||
| 170 | +379x | +
+ stat_nms_from_stats |
||
| 39 | +171 |
- #' @param x (`vector`)\cr object to convert.+ } |
||
| 40 | +172 |
- #' @param x_name (`string`)\cr name of `x`.+ |
||
| 41 | +173 |
- #' @param na_level (`string`)\cr the explicit missing level which should be used when converting a character vector.+ # Utility function used to separate custom stats (user-defined functions) from defaults |
||
| 42 | +174 |
- #' @param verbose (`flag`)\cr defaults to `TRUE`. It prints out warnings and messages.+ .split_std_from_custom_stats <- function(stats_in) {
+ |
+ ||
| 175 | +354x | +
+ out <- list(default_stats = NULL, custom_stats = NULL)+ |
+ ||
| 176 | +354x | +
+ if (is.list(stats_in)) {
+ |
+ ||
| 177 | +9x | +
+ is_custom_fnc <- sapply(stats_in, is.function)+ |
+ ||
| 178 | +9x | +
+ checkmate::assert_list(stats_in[is_custom_fnc], types = "function", names = "named")+ |
+ ||
| 179 | +9x | +
+ out[["custom_stats"]] <- stats_in[is_custom_fnc]+ |
+ ||
| 180 | +9x | +
+ out[["default_stats"]] <- unlist(stats_in[!is_custom_fnc]) |
||
| 43 | +181 |
- #'+ } else {
+ |
+ ||
| 182 | +345x | +
+ out[["default_stats"]] <- stats_in |
||
| 44 | +183 |
- #' @return A `factor` with same attributes (except class) as `x`. Does not modify `x` if already a `factor`.+ } |
||
| 45 | +184 |
- #'+ + |
+ ||
| 185 | +354x | +
+ out |
||
| 46 | +186 |
- #' @keywords internal+ } |
||
| 47 | +187 |
- as_factor_keep_attributes <- function(x,+ |
||
| 48 | +188 |
- x_name = deparse(substitute(x)),+ # Utility function to apply statistical functions |
||
| 49 | +189 |
- na_level = "<Missing>",+ .apply_stat_functions <- function(default_stat_fnc, custom_stat_fnc_list, args_list) {
|
||
| 50 | +190 |
- verbose = TRUE) {
+ # Default checks |
||
| 51 | -221x | +191 | +354x |
- checkmate::assert_atomic(x)+ checkmate::assert_function(default_stat_fnc) |
| 52 | -221x | +192 | +354x |
- checkmate::assert_string(x_name)+ checkmate::assert_list(custom_stat_fnc_list, types = "function", null.ok = TRUE, names = "named") |
| 53 | -221x | +193 | +354x |
- checkmate::assert_string(na_level)+ checkmate::assert_list(args_list) |
| 54 | -221x | +|||
| 194 | +
- checkmate::assert_flag(verbose)+ + |
+ |||
| 195 | ++ |
+ # Checking custom stats have same formals |
||
| 55 | -221x | +196 | +354x |
- if (is.factor(x)) {
+ if (!is.null(custom_stat_fnc_list)) {
|
| 56 | -200x | +197 | +9x |
- return(x)+ fundamental_call_to_data <- names(formals(default_stat_fnc))[[1]] |
| 57 | -+ | |||
| 198 | +9x |
- }+ for (fnc in custom_stat_fnc_list) {
|
||
| 58 | -21x | +199 | +11x |
- x_class <- class(x)[1]+ if (!identical(names(formals(fnc))[[1]], fundamental_call_to_data)) {
|
| 59 | -21x | +200 | +1x |
- if (verbose) {
+ stop( |
| 60 | -15x | +201 | +1x |
- warning(paste(+ "The first parameter of a custom statistical function needs to be the same (it can be `df` or `x`) ", |
| 61 | -15x | +202 | +1x |
- "automatically converting", x_class, "variable", x_name,+ "as the default statistical function. In this case your custom function has ", names(formals(fnc))[[1]], |
| 62 | -15x | +203 | +1x |
- "to factor, better manually convert to factor to avoid failures"+ " as first parameter, while the default function has ", fundamental_call_to_data, "." |
| 63 | +204 |
- ))+ ) |
||
| 64 | +205 |
- }+ } |
||
| 65 | -21x | +206 | +10x |
- if (identical(length(x), 0L)) {
+ if (!any(names(formals(fnc)) == "...")) {
|
| 66 | +207 | 1x |
- warning(paste(+ stop( |
|
| 67 | +208 | 1x |
- x_name, "has length 0, this can lead to tabulation failures, better convert to factor"+ "The custom statistical function needs to have `...` as a parameter to accept additional arguments. ",+ |
+ |
| 209 | +1x | +
+ "In this case your custom function does not have `...`." |
||
| 68 | +210 |
- ))+ ) |
||
| 69 | +211 | ++ |
+ }+ |
+ |
| 212 | ++ |
+ }+ |
+ ||
| 213 |
} |
|||
| 70 | -21x | +|||
| 214 | +
- if (is.character(x)) {
+
|
|||
| 71 | -21x | +|||
| 215 | +
- x_no_na <- explicit_na(sas_na(x), label = na_level)+ # Merging |
|||
| 72 | -21x | +216 | +352x |
- if (any(na_level %in% x_no_na)) {
+ stat_fnc_list <- c(default_stat_fnc, custom_stat_fnc_list) |
| 73 | -3x | +|||
| 217 | +
- do.call(+ |
|||
| 74 | -3x | +|||
| 218 | +
- structure,+ # Applying |
|||
| 75 | -3x | +219 | +352x |
- c(+ out <- unlist(lapply(stat_fnc_list, function(fnc) do.call(fnc, args = args_list)), recursive = FALSE) |
| 76 | -3x | +|||
| 220 | +
- list(.Data = forcats::fct_relevel(x_no_na, na_level, after = Inf)),+ |
|||
| 77 | -3x | +221 | +352x |
- attributes(x)+ out |
| 78 | +222 |
- )+ } |
||
| 79 | +223 |
- )+ |
||
| 80 | +224 |
- } else {
+ #' @describeIn default_stats_formats_labels Get formats corresponding to a list of statistics. |
||
| 81 | -18x | +|||
| 225 | +
- do.call(structure, c(list(.Data = as.factor(x)), attributes(x)))+ #' To check available defaults see list `tern::tern_default_formats`. |
|||
| 82 | +226 |
- }+ #' |
||
| 83 | +227 |
- } else {
+ #' @param formats_in (named `vector`)\cr custom formats to use instead of defaults. Can be a character vector with |
||
| 84 | -! | +|||
| 228 | +
- do.call(structure, c(list(.Data = as.factor(x)), attributes(x)))+ #' values from [formatters::list_valid_format_labels()] or custom format functions. Defaults to `NULL` for any rows |
|||
| 85 | +229 |
- }+ #' with no value is provided. |
||
| 86 | +230 |
- }+ #' |
||
| 87 | +231 |
-
+ #' @return |
||
| 88 | +232 |
- #' Labels for bins in percent+ #' * `get_formats_from_stats()` returns a named list of formats as strings or functions. |
||
| 89 | +233 |
#' |
||
| 90 | +234 |
- #' This creates labels for quantile based bins in percent. This assumes the right-closed+ #' @note Formats in `tern` and `rtables` can be functions that take in the table cell value and |
||
| 91 | +235 |
- #' intervals as produced by [cut_quantile_bins()].+ #' return a string. This is well documented in `vignette("custom_appearance", package = "rtables")`.
|
||
| 92 | +236 |
#' |
||
| 93 | +237 |
- #' @param probs (`numeric`)\cr the probabilities identifying the quantiles.+ #' @examples |
||
| 94 | +238 |
- #' This is a sorted vector of unique `proportion` values, i.e. between 0 and 1, where+ #' # Defaults formats |
||
| 95 | +239 |
- #' the boundaries 0 and 1 must not be included.+ #' get_formats_from_stats(num_stats) |
||
| 96 | +240 |
- #' @param digits (`integer(1)`)\cr number of decimal places to round the percent numbers.+ #' get_formats_from_stats(cnt_stats) |
||
| 97 | +241 | ++ |
+ #' get_formats_from_stats(only_pval)+ |
+ |
| 242 | ++ |
+ #' get_formats_from_stats(all_cnt_occ)+ |
+ ||
| 243 |
#' |
|||
| 98 | +244 |
- #' @return A `character` vector with labels in the format `[0%,20%]`, `(20%,50%]`, etc.+ #' # Addition of customs |
||
| 99 | +245 | ++ |
+ #' get_formats_from_stats(all_cnt_occ, formats_in = c("fraction" = c("xx")))
+ |
+ |
| 246 | ++ |
+ #' get_formats_from_stats(all_cnt_occ, formats_in = list("fraction" = c("xx.xx", "xx")))
+ |
+ ||
| 247 |
#' |
|||
| 100 | +248 |
- #' @keywords internal+ #' @seealso [formatting_functions] |
||
| 101 | +249 |
- bins_percent_labels <- function(probs,+ #' |
||
| 102 | +250 |
- digits = 0) {
+ #' @export |
||
| 103 | -3x | +|||
| 251 | +
- if (isFALSE(0 %in% probs)) probs <- c(0, probs)+ get_formats_from_stats <- function(stats, |
|||
| 104 | -3x | +|||
| 252 | +
- if (isFALSE(1 %in% probs)) probs <- c(probs, 1)+ formats_in = NULL, |
|||
| 105 | -10x | +|||
| 253 | +
- checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE)+ levels_per_stats = NULL, |
|||
| 106 | -10x | +|||
| 254 | +
- percent <- round(probs * 100, digits = digits)+ tern_defaults = tern_default_formats) {
|
|||
| 107 | -10x | +255 | +642x |
- left <- paste0(utils::head(percent, -1), "%")+ checkmate::assert_character(stats, min.len = 1) |
| 108 | -10x | +|||
| 256 | +
- right <- paste0(utils::tail(percent, -1), "%")+ # It may be a list if there is a function in the formats |
|||
| 109 | -10x | +257 | +642x |
- without_left_bracket <- paste0(left, ",", right, "]")+ if (checkmate::test_list(formats_in, null.ok = TRUE)) {
|
| 110 | -10x | +258 | +540x |
- with_left_bracket <- paste0("[", utils::head(without_left_bracket, 1))
+ checkmate::assert_list(formats_in, null.ok = TRUE) |
| 111 | -10x | +|||
| 259 | +
- if (length(without_left_bracket) > 1) {
+ # Or it may be a vector of characters+ |
+ |||
| 260 | ++ |
+ } else {
|
||
| 112 | -7x | +261 | +102x |
- with_left_bracket <- c(+ checkmate::assert_character(formats_in, null.ok = TRUE)+ |
+
| 262 | ++ |
+ } |
||
| 113 | -7x | +263 | +642x |
- with_left_bracket,+ checkmate::assert_list(levels_per_stats, null.ok = TRUE)+ |
+
| 264 | ++ | + + | +||
| 265 | ++ |
+ # If levels_per_stats not given, assume one row per statistic |
||
| 114 | -7x | +266 | +144x |
- paste0("(", utils::tail(without_left_bracket, -1))
+ if (is.null(levels_per_stats)) levels_per_stats <- as.list(stats) %>% setNames(stats) |
| 115 | +267 |
- )+ |
||
| 116 | +268 |
- }+ # Apply custom formats |
||
| 117 | -10x | +269 | +642x |
- with_left_bracket+ out <- .fill_in_vals_by_stats(levels_per_stats, formats_in, tern_defaults) |
| 118 | +270 |
- }+ |
||
| 119 | +271 | ++ |
+ # Default to NULL if no format+ |
+ |
| 272 | +642x | +
+ out[names(out) == out] <- list(NULL)+ |
+ ||
| 273 | ||||
| 274 | +642x | +
+ out+ |
+ ||
| 120 | +275 |
- #' Cut numeric vector into empirical quantile bins+ } |
||
| 121 | +276 |
- #'+ |
||
| 122 | +277 |
- #' @description `r lifecycle::badge("stable")`
+ #' @describeIn default_stats_formats_labels Get labels corresponding to a list of statistics. |
||
| 123 | +278 | ++ |
+ #' To check for available defaults see list `tern::tern_default_labels`.+ |
+ |
| 279 |
#' |
|||
| 124 | +280 |
- #' This cuts a numeric vector into sample quantile bins.+ #' @param labels_in (named `character`)\cr custom labels to use instead of defaults. If no value is provided, the |
||
| 125 | +281 |
- #'+ #' variable level (if rows correspond to levels of a variable) or statistic name will be used as label. |
||
| 126 | +282 |
- #' @inheritParams bins_percent_labels+ #' |
||
| 127 | +283 |
- #' @param x (`numeric`)\cr the continuous variable values which should be cut into+ #' @return |
||
| 128 | +284 |
- #' quantile bins. This may contain `NA` values, which are then+ #' * `get_labels_from_stats()` returns a named list of labels as strings. |
||
| 129 | +285 |
- #' not used for the quantile calculations, but included in the return vector.+ #' |
||
| 130 | +286 |
- #' @param labels (`character`)\cr the unique labels for the quantile bins. When there are `n`+ #' @examples |
||
| 131 | +287 |
- #' probabilities in `probs`, then this must be `n + 1` long.+ #' # Defaults labels |
||
| 132 | +288 |
- #' @param type (`integer(1)`)\cr type of quantiles to use, see [stats::quantile()] for details.+ #' get_labels_from_stats(num_stats) |
||
| 133 | +289 |
- #' @param ordered (`flag`)\cr should the result be an ordered factor.+ #' get_labels_from_stats(cnt_stats) |
||
| 134 | +290 |
- #'+ #' get_labels_from_stats(only_pval) |
||
| 135 | +291 |
- #' @return A `factor` variable with appropriately-labeled bins as levels.+ #' get_labels_from_stats(all_cnt_occ) |
||
| 136 | +292 |
#' |
||
| 137 | +293 |
- #' @note Intervals are closed on the right side. That is, the first bin is the interval+ #' # Addition of customs |
||
| 138 | +294 |
- #' `[-Inf, q1]` where `q1` is the first quantile, the second bin is then `(q1, q2]`, etc.,+ #' get_labels_from_stats(all_cnt_occ, labels_in = c("fraction" = "Fraction"))
|
||
| 139 | +295 |
- #' and the last bin is `(qn, +Inf]` where `qn` is the last quantile.+ #' get_labels_from_stats(all_cnt_occ, labels_in = list("fraction" = c("Some more fractions")))
|
||
| 140 | +296 |
#' |
||
| 141 | +297 |
- #' @examples+ #' @export |
||
| 142 | +298 |
- #' # Default is to cut into quartile bins.+ get_labels_from_stats <- function(stats, |
||
| 143 | +299 |
- #' cut_quantile_bins(cars$speed)+ labels_in = NULL, |
||
| 144 | +300 |
- #'+ levels_per_stats = NULL, |
||
| 145 | +301 |
- #' # Use custom quantiles.+ tern_defaults = tern_default_labels) {
+ |
+ ||
| 302 | +620x | +
+ checkmate::assert_character(stats, min.len = 1) |
||
| 146 | +303 |
- #' cut_quantile_bins(cars$speed, probs = c(0.1, 0.2, 0.6, 0.88))+ # It may be a list+ |
+ ||
| 304 | +620x | +
+ if (checkmate::test_list(labels_in, null.ok = TRUE)) {
+ |
+ ||
| 305 | +492x | +
+ checkmate::assert_list(labels_in, null.ok = TRUE) |
||
| 147 | +306 |
- #'+ # Or it may be a vector of characters |
||
| 148 | +307 |
- #' # Use custom labels.+ } else {
+ |
+ ||
| 308 | +128x | +
+ checkmate::assert_character(labels_in, null.ok = TRUE) |
||
| 149 | +309 |
- #' cut_quantile_bins(cars$speed, labels = paste0("Q", 1:4))
+ }+ |
+ ||
| 310 | +620x | +
+ checkmate::assert_list(levels_per_stats, null.ok = TRUE) |
||
| 150 | +311 |
- #'+ |
||
| 151 | +312 |
- #' # NAs are preserved in result factor.+ # If levels_per_stats not given, assume one row per statistic+ |
+ ||
| 313 | +120x | +
+ if (is.null(levels_per_stats)) levels_per_stats <- as.list(stats) %>% setNames(stats) |
||
| 152 | +314 |
- #' ozone_binned <- cut_quantile_bins(airquality$Ozone)+ |
||
| 153 | +315 |
- #' which(is.na(ozone_binned))+ # Apply custom labels+ |
+ ||
| 316 | +620x | +
+ out <- .fill_in_vals_by_stats(levels_per_stats, labels_in, tern_defaults)+ |
+ ||
| 317 | +620x | +
+ out |
||
| 154 | +318 |
- #' # So you might want to make these explicit.+ } |
||
| 155 | +319 |
- #' explicit_na(ozone_binned)+ |
||
| 156 | +320 | ++ |
+ #' @describeIn default_stats_formats_labels Get row indent modifiers corresponding to a list of statistics/rows.+ |
+ |
| 321 |
#' |
|||
| 157 | +322 |
- #' @export+ #' @param indents_in (named `integer`)\cr custom row indent modifiers to use instead of defaults. Defaults to `0L` for |
||
| 158 | +323 |
- cut_quantile_bins <- function(x,+ #' all values. |
||
| 159 | +324 |
- probs = c(0.25, 0.5, 0.75),+ #' @param row_nms `r lifecycle::badge("deprecated")` Deprecation cycle started. See the `levels_per_stats` parameter
|
||
| 160 | +325 |
- labels = NULL,+ #' for details. |
||
| 161 | +326 |
- type = 7,+ #' |
||
| 162 | +327 |
- ordered = TRUE) {
+ #' @return |
||
| 163 | -8x | +|||
| 328 | +
- checkmate::assert_flag(ordered)+ #' * `get_indents_from_stats()` returns a named list of indentation modifiers as integers. |
|||
| 164 | -8x | +|||
| 329 | +
- checkmate::assert_numeric(x)+ #' |
|||
| 165 | -7x | +|||
| 330 | +
- if (isFALSE(0 %in% probs)) probs <- c(0, probs)+ #' @examples |
|||
| 166 | -7x | +|||
| 331 | +
- if (isFALSE(1 %in% probs)) probs <- c(probs, 1)+ #' get_indents_from_stats(all_cnt_occ, indents_in = 3L) |
|||
| 167 | -8x | +|||
| 332 | +
- checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE)+ #' get_indents_from_stats(all_cnt_occ, indents_in = list(count = 2L, count_fraction = 5L)) |
|||
| 168 | -7x | +|||
| 333 | +
- if (is.null(labels)) labels <- bins_percent_labels(probs)+ #' get_indents_from_stats( |
|||
| 169 | -8x | +|||
| 334 | +
- checkmate::assert_character(labels, len = length(probs) - 1, any.missing = FALSE, unique = TRUE)+ #' all_cnt_occ, |
|||
| 170 | +335 |
-
+ #' indents_in = list(a = 2L, count.a = 1L, count.b = 5L) |
||
| 171 | -8x | +|||
| 336 | ++ |
+ #' )+ |
+ ||
| 337 | ++ |
+ #'+ |
+ ||
| 338 | +
- if (all(is.na(x))) {
+ #' @export |
|||
| 172 | +339 |
- # Early return if there are only NAs in input.+ get_indents_from_stats <- function(stats, |
||
| 173 | -1x | +|||
| 340 | +
- return(factor(x, ordered = ordered, levels = labels))+ indents_in = NULL, |
|||
| 174 | +341 |
- }+ levels_per_stats = NULL, |
||
| 175 | +342 |
-
+ tern_defaults = as.list(rep(0L, length(stats))) %>% setNames(stats), |
||
| 176 | -7x | +|||
| 343 | +
- quantiles <- stats::quantile(+ row_nms = lifecycle::deprecated()) {
|
|||
| 177 | -7x | +344 | +577x |
- x,+ checkmate::assert_character(stats, min.len = 1) |
| 178 | -7x | +|||
| 345 | +
- probs = probs,+ # It may be a list |
|||
| 179 | -7x | +346 | +577x |
- type = type,+ if (checkmate::test_list(indents_in, null.ok = TRUE)) {
|
| 180 | -7x | +347 | +525x |
- na.rm = TRUE+ checkmate::assert_list(indents_in, null.ok = TRUE) |
| 181 | +348 |
- )+ # Or it may be a vector of integers |
||
| 182 | +349 |
-
+ } else {
|
||
| 183 | -7x | +350 | +52x |
- checkmate::assert_numeric(quantiles, unique = TRUE)+ checkmate::assert_integerish(indents_in, null.ok = TRUE) |
| 184 | +351 |
-
+ } |
||
| 185 | -6x | +352 | +577x |
- cut(+ checkmate::assert_list(levels_per_stats, null.ok = TRUE) |
| 186 | -6x | +|||
| 353 | +
- x,+ |
|||
| 187 | -6x | +|||
| 354 | +
- breaks = quantiles,+ # If levels_per_stats not given, assume one row per statistic |
|||
| 188 | -6x | +355 | +79x |
- labels = labels,+ if (is.null(levels_per_stats)) levels_per_stats <- as.list(stats) %>% setNames(stats) |
| 189 | -6x | +|||
| 356 | +
- ordered_result = ordered,+ |
|||
| 190 | -6x | +|||
| 357 | +
- include.lowest = TRUE,+ # Single indentation level for all rows |
|||
| 191 | -6x | +358 | +577x |
- right = TRUE+ if (is.null(names(indents_in)) && length(indents_in) == 1) {
|
| 192 | -+ | |||
| 359 | +20x |
- )+ out <- rep(indents_in, length(levels_per_stats %>% unlist())) |
||
| 193 | -+ | |||
| 360 | +20x |
- }+ return(out) |
||
| 194 | +361 |
-
+ } |
||
| 195 | +362 |
- #' Discard specified levels of a factor+ |
||
| 196 | +363 |
- #'+ # Apply custom indentation |
||
| 197 | -+ | |||
| 364 | +557x |
- #' @description `r lifecycle::badge("stable")`
+ out <- .fill_in_vals_by_stats(levels_per_stats, indents_in, tern_defaults) |
||
| 198 | -+ | |||
| 365 | +557x |
- #'+ out |
||
| 199 | +366 |
- #' This discards the observations as well as the levels specified from a factor.+ } |
||
| 200 | +367 |
- #'+ |
||
| 201 | +368 |
- #' @param x (`factor`)\cr the original factor.+ # Function to loop over each stat and levels to set correct values |
||
| 202 | +369 |
- #' @param discard (`character`)\cr levels to discard.+ .fill_in_vals_by_stats <- function(levels_per_stats, user_in, tern_defaults) {
|
||
| 203 | -+ | |||
| 370 | +1819x |
- #'+ out <- list() |
||
| 204 | +371 |
- #' @return A modified `factor` with observations as well as levels from `discard` dropped.+ |
||
| 205 | -+ | |||
| 372 | +1819x |
- #'+ for (stat_i in names(levels_per_stats)) {
|
||
| 206 | +373 |
- #' @examples+ # Get all levels of the statistic |
||
| 207 | -+ | |||
| 374 | +3845x |
- #' fct_discard(factor(c("a", "b", "c")), "c")
+ all_lvls <- levels_per_stats[[stat_i]] |
||
| 208 | +375 |
- #'+ |
||
| 209 | -+ | |||
| 376 | +3845x |
- #' @export+ if ((length(all_lvls) == 1 && all_lvls == stat_i) || is.null(all_lvls)) { # One row per statistic
|
||
| 210 | -+ | |||
| 377 | +2476x |
- fct_discard <- function(x, discard) {
+ out[[stat_i]] <- if (stat_i %in% names(user_in)) { # 1. Check for stat_i in user input
|
||
| 211 | -321x | +378 | +572x |
- checkmate::assert_factor(x)+ user_in[[stat_i]] |
| 212 | -321x | +379 | +2476x |
- checkmate::assert_character(discard, any.missing = FALSE)+ } else if (stat_i %in% names(tern_defaults)) { # 2. Check for stat_i in tern defaults
|
| 213 | -321x | +380 | +1858x |
- new_obs <- x[!(x %in% discard)]+ tern_defaults[[stat_i]] |
| 214 | -321x | +381 | +2476x |
- new_levels <- setdiff(levels(x), discard)+ } else { # 3. Otherwise stat_i
|
| 215 | -321x | +382 | +46x |
- factor(new_obs, levels = new_levels)+ stat_i |
| 216 | +383 |
- }+ } |
||
| 217 | +384 |
-
+ } else { # One row per combination of variable level and statistic
|
||
| 218 | +385 |
- #' Insertion of explicit missing values in a factor+ # Loop over levels for each statistic |
||
| 219 | -+ | |||
| 386 | +1369x |
- #'+ for (lev_i in all_lvls) {
|
||
| 220 | +387 |
- #' @description `r lifecycle::badge("stable")`
+ # Construct row name (stat_i.lev_i) |
||
| 221 | -+ | |||
| 388 | +8713x |
- #'+ row_nm <- paste(stat_i, lev_i, sep = ".") |
||
| 222 | +389 |
- #' This inserts explicit missing values in a factor based on a condition. Additionally,+ |
||
| 223 | -+ | |||
| 390 | +8713x |
- #' existing `NA` values will be explicitly converted to given `na_level`.+ out[[row_nm]] <- if (row_nm %in% names(user_in)) { # 1. Check for stat_i.lev_i in user input
|
||
| 224 | -+ | |||
| 391 | +5x |
- #'+ user_in[[row_nm]] |
||
| 225 | -+ | |||
| 392 | +8713x |
- #' @param x (`factor`)\cr the original factor.+ } else if (lev_i %in% names(user_in)) { # 2. Check for lev_i in user input
|
||
| 226 | -+ | |||
| 393 | +24x |
- #' @param condition (`logical`)\cr positions at which to insert missing values.+ user_in[[lev_i]] |
||
| 227 | -+ | |||
| 394 | +8713x |
- #' @param na_level (`string`)\cr which level to use for missing values.+ } else if (stat_i %in% names(user_in)) { # 3. Check for stat_i in user input
|
||
| 228 | -+ | |||
| 395 | +358x |
- #'+ user_in[[stat_i]] |
||
| 229 | -+ | |||
| 396 | +8713x |
- #' @return A modified `factor` with inserted and existing `NA` converted to `na_level`.+ } else if (lev_i %in% names(tern_defaults)) { # 4. Check for lev_i in tern defaults (only used for labels)
|
||
| 230 | -+ | |||
| 397 | +117x |
- #'+ tern_defaults[[lev_i]] |
||
| 231 | -+ | |||
| 398 | +8713x |
- #' @seealso [forcats::fct_na_value_to_level()] which is used internally.+ } else if (stat_i %in% names(tern_defaults)) { # 5. Check for stat_i in tern defaults
+ |
+ ||
| 399 | +5414x | +
+ tern_defaults[[stat_i]]+ |
+ ||
| 400 | +8713x | +
+ } else { # 6. Otherwise lev_i
+ |
+ ||
| 401 | +2795x | +
+ lev_i |
||
| 232 | +402 |
- #'+ } |
||
| 233 | +403 |
- #' @examples+ } |
||
| 234 | +404 |
- #' fct_explicit_na_if(factor(c("a", "b", NA)), c(TRUE, FALSE, FALSE))
+ } |
||
| 235 | +405 |
- #'+ } |
||
| 236 | +406 |
- #' @export+ + |
+ ||
| 407 | +1819x | +
+ out |
||
| 237 | +408 |
- fct_explicit_na_if <- function(x, condition, na_level = "<Missing>") {
+ } |
||
| 238 | -1x | +|||
| 409 | +
- checkmate::assert_factor(x, len = length(condition))+ |
|||
| 239 | -1x | +|||
| 410 | +
- checkmate::assert_logical(condition)+ # Custom unlist function to retain NULL as "NULL" or NA |
|||
| 240 | -1x | +|||
| 411 | +
- x[condition] <- NA+ .unlist_keep_nulls <- function(lst, null_placeholder = "NULL", recursive = FALSE) {
|
|||
| 241 | -1x | +412 | +1691x |
- x <- forcats::fct_na_value_to_level(x, level = na_level)+ lapply(lst, function(x) if (is.null(x)) null_placeholder else x) %>% |
| 242 | -1x | +413 | +1691x |
- forcats::fct_drop(x, only = na_level)+ unlist(recursive = recursive) |
| 243 | +414 |
} |
||
| 244 | +415 | |||
| 245 | +416 |
- #' Collapse factor levels and keep only those new group levels+ #' Update labels according to control specifications |
||
| 246 | +417 |
#' |
||
| 247 | +418 |
#' @description `r lifecycle::badge("stable")`
|
||
| 248 | +419 |
#' |
||
| 249 | -- |
- #' This collapses levels and only keeps those new group levels, in the order provided.- |
- ||
| 250 | +420 |
- #' The returned factor has levels in the order given, with the possible missing level last (this will+ #' Given a list of statistic labels and and a list of control parameters, updates labels with a relevant |
||
| 251 | +421 |
- #' only be included if there are missing values).+ #' control specification. For example, if control has element `conf_level` set to `0.9`, the default |
||
| 252 | +422 |
- #'+ #' label for statistic `mean_ci` will be updated to `"Mean 90% CI"`. Any labels that are supplied |
||
| 253 | +423 |
- #' @param .f (`factor` or `character`)\cr original vector.+ #' via `labels_custom` will not be updated regardless of `control`. |
||
| 254 | +424 |
- #' @param ... (named `character`)\cr levels in each vector provided will be collapsed into+ #' |
||
| 255 | +425 |
- #' the new level given by the respective name.+ #' @param labels_default (named `character`)\cr a named vector of statistic labels to modify |
||
| 256 | +426 |
- #' @param .na_level (`string`)\cr which level to use for other levels, which should be missing in the+ #' according to the control specifications. Labels that are explicitly defined in `labels_custom` will |
||
| 257 | +427 |
- #' new factor. Note that this level must not be contained in the new levels specified in `...`.+ #' not be affected. |
||
| 258 | +428 |
- #'+ #' @param labels_custom (named `character`)\cr named vector of labels that are customized by |
||
| 259 | +429 |
- #' @return A modified `factor` with collapsed levels. Values and levels which are not included+ #' the user and should not be affected by `control`. |
||
| 260 | +430 |
- #' in the given `character` vector input will be set to the missing level `.na_level`.+ #' @param control (named `list`)\cr list of control parameters to apply to adjust default labels. |
||
| 261 | +431 |
#' |
||
| 262 | -- |
- #' @note Any existing `NA`s in the input vector will not be replaced by the missing level. If needed,- |
- ||
| 263 | +432 |
- #' [explicit_na()] can be called separately on the result.+ #' @return A named character vector of labels with control specifications applied to relevant labels. |
||
| 264 | +433 |
#' |
||
| 265 | +434 |
- #' @seealso [forcats::fct_collapse()], [forcats::fct_relevel()] which are used internally.+ #' @examples |
||
| 266 | +435 |
- #'+ #' control <- list(conf_level = 0.80, quantiles = c(0.1, 0.83), test_mean = 0.57) |
||
| 267 | +436 |
- #' @examples+ #' get_labels_from_stats(c("mean_ci", "quantiles", "mean_pval")) %>%
|
||
| 268 | +437 |
- #' fct_collapse_only(factor(c("a", "b", "c", "d")), TRT = "b", CTRL = c("c", "d"))
+ #' labels_use_control(control = control) |
||
| 269 | +438 |
#' |
||
| 270 | +439 |
#' @export |
||
| 271 | +440 |
- fct_collapse_only <- function(.f, ..., .na_level = "<Missing>") {
+ labels_use_control <- function(labels_default, control, labels_custom = NULL) {
|
||
| 272 | -4x | +441 | +21x |
- new_lvls <- names(list(...))+ if ("conf_level" %in% names(control)) {
|
| 273 | -4x | +442 | +21x |
- if (checkmate::test_subset(.na_level, new_lvls)) {
+ labels_default <- sapply( |
| 274 | -1x | +443 | +21x |
- stop(paste0(".na_level currently set to '", .na_level, "' must not be contained in the new levels"))
+ names(labels_default), |
| 275 | -+ | |||
| 444 | +21x |
- }+ function(x) {
|
||
| 276 | -3x | +445 | +111x |
- x <- forcats::fct_collapse(.f, ..., other_level = .na_level)+ if (!x %in% names(labels_custom)) {
|
| 277 | -3x | +446 | +107x |
- do.call(forcats::fct_relevel, args = c(list(.f = x), as.list(new_lvls)))+ gsub(labels_default[[x]], pattern = "[0-9]+% CI", replacement = f_conf_level(control[["conf_level"]])) |
| 278 | +447 |
- }+ } else {
|
||
| 279 | -+ | |||
| 448 | +4x |
-
+ labels_default[[x]] |
||
| 280 | +449 |
- #' Ungroup non-numeric statistics+ } |
||
| 281 | +450 |
- #'+ } |
||
| 282 | +451 |
- #' Ungroups grouped non-numeric statistics within input vectors `.formats`, `.labels`, and `.indent_mods`.+ ) |
||
| 283 | +452 |
- #'+ } |
||
| 284 | -+ | |||
| 453 | +21x |
- #' @inheritParams argument_convention+ if ("quantiles" %in% names(control) && "quantiles" %in% names(labels_default) &&
|
||
| 285 | -+ | |||
| 454 | +21x |
- #' @param stat_out (named `list` of `numeric`)\cr list of numeric statistics containing the statistics to ungroup.+ !"quantiles" %in% names(labels_custom)) { # nolint
|
||
| 286 | -+ | |||
| 455 | +16x |
- #'+ labels_default["quantiles"] <- gsub( |
||
| 287 | -+ | |||
| 456 | +16x |
- #' @return A `list` with modified elements `stat_out`, `.formats`, `.labels`, `.levels`, and `.indent_mods`.+ "[0-9]+% and [0-9]+", paste0(control[["quantiles"]][1] * 100, "% and ", control[["quantiles"]][2] * 100, ""), |
||
| 288 | -+ | |||
| 457 | +16x |
- #'+ labels_default["quantiles"] |
||
| 289 | +458 |
- #' @seealso [a_summary()] which uses this function internally.+ ) |
||
| 290 | +459 |
- #'+ } |
||
| 291 | -+ | |||
| 460 | +21x |
- #' @keywords internal+ if ("quantiles" %in% names(control) && "quantiles_lower" %in% names(labels_default) &&
|
||
| 292 | -+ | |||
| 461 | +21x |
- ungroup_stats <- function(stat_out,+ !"quantiles_lower" %in% names(labels_custom)) { # nolint
+ |
+ ||
| 462 | +6x | +
+ labels_default["quantiles_lower"] <- gsub(+ |
+ ||
| 463 | +6x | +
+ "[0-9]+%-ile", paste0(control[["quantiles"]][1] * 100, "%-ile", ""),+ |
+ ||
| 464 | +6x | +
+ labels_default["quantiles_lower"] |
||
| 293 | +465 |
- .formats,+ ) |
||
| 294 | +466 |
- .indent_mods) {
+ } |
||
| 295 | -405x | +467 | +21x |
- checkmate::assert_list(stat_out)+ if ("quantiles" %in% names(control) && "quantiles_upper" %in% names(labels_default) &&
|
| 296 | -405x | +468 | +21x |
- empty_pval <- "pval" %in% names(stat_out) && length(stat_out[["pval"]]) == 0+ !"quantiles_upper" %in% names(labels_custom)) { # nolint
|
| 297 | -405x | +469 | +6x |
- empty_pval_counts <- "pval_counts" %in% names(stat_out) && length(stat_out[["pval_counts"]]) == 0+ labels_default["quantiles_upper"] <- gsub( |
| 298 | -405x | +470 | +6x |
- stat_out <- unlist(stat_out, recursive = FALSE)+ "[0-9]+%-ile", paste0(control[["quantiles"]][2] * 100, "%-ile", ""), |
| 299 | -+ | |||
| 471 | +6x |
-
+ labels_default["quantiles_upper"] |
||
| 300 | +472 |
- # If p-value is empty it is removed by unlist and needs to be re-added+ ) |
||
| 301 | -! | +|||
| 473 | +
- if (empty_pval) stat_out[["pval"]] <- character()+ } |
|||
| 302 | -3x | +474 | +21x |
- if (empty_pval_counts) stat_out[["pval_counts"]] <- character()+ if ("test_mean" %in% names(control) && "mean_pval" %in% names(labels_default) &&
|
| 303 | -405x | -
- .stats <- sapply(regmatches(names(stat_out), regexpr("\\.", names(stat_out)), invert = TRUE), function(xi) xi[[1]])
- |
- ||
| 304 | -- | - - | -||
| 305 | -+ | 475 | +21x |
- # Ungroup stats+ !"mean_pval" %in% names(labels_custom)) { # nolint
|
| 306 | -405x | +476 | +2x |
- .formats <- lapply(.stats, function(x) {
+ labels_default["mean_pval"] <- gsub( |
| 307 | -2995x | +477 | +2x |
- .formats[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
+ "p-value \\(H0: mean = [0-9\\.]+\\)", f_pval(control[["test_mean"]]), labels_default["mean_pval"] |
| 308 | +478 |
- })+ ) |
||
| 309 | +479 |
-
+ } |
||
| 310 | -405x | +|||
| 480 | +
- .indent_mods <- sapply(.stats, function(x) {
+
|
|||
| 311 | -2995x | +481 | +21x |
- .indent_mods[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
+ labels_default |
| 312 | +482 |
- })+ } |
||
| 313 | +483 | |||
| 314 | -405x | -
- list(- |
- ||
| 315 | -405x | +|||
| 484 | +
- x = stat_out,+ # tern_default_stats ----------------------------------------------------------- |
|||
| 316 | -405x | +|||
| 485 | +
- .formats = .formats,+ #' @describeIn default_stats_formats_labels Named list of available statistics by method group for `tern`. |
|||
| 317 | -405x | +|||
| 486 | +
- .indent_mods = .indent_mods+ #' |
|||
| 318 | +487 |
- )+ #' @format |
||
| 319 | +488 |
- }+ #' * `tern_default_stats` is a named list of available statistics, with each element |
| 1 | +489 |
- #' Convert list of groups to a data frame+ #' named for their corresponding statistical method group. |
|
| 2 | +490 |
#' |
|
| 3 | +491 |
- #' This converts a list of group levels into a data frame format which is expected by [rtables::add_combo_levels()].+ #' @export |
|
| 4 | +492 |
- #'+ tern_default_stats <- list( |
|
| 5 | +493 |
- #' @param groups_list (named `list` of `character`)\cr specifies the new group levels via the names and the+ abnormal = c("fraction"),
|
|
| 6 | +494 |
- #' levels that belong to it in the character vectors that are elements of the list.+ abnormal_by_baseline = c("fraction"),
|
|
| 7 | +495 |
- #'+ abnormal_by_marked = c("count_fraction", "count_fraction_fixed_dp"),
|
|
| 8 | +496 |
- #' @return A `tibble` in the required format.+ abnormal_by_worst_grade = c("count_fraction", "count_fraction_fixed_dp"),
|
|
| 9 | +497 |
- #'+ abnormal_by_worst_grade_worsen = c("fraction"),
|
|
| 10 | +498 |
- #' @examples+ analyze_patients_exposure_in_cols = c("n_patients", "sum_exposure"),
|
|
| 11 | +499 |
- #' grade_groups <- list(+ analyze_vars_counts = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "fraction", "n_blq"),
|
|
| 12 | +500 |
- #' "Any Grade (%)" = c("1", "2", "3", "4", "5"),
+ analyze_vars_numeric = c( |
|
| 13 | +501 |
- #' "Grade 3-4 (%)" = c("3", "4"),
+ "n", "sum", "mean", "sd", "se", "mean_sd", "mean_se", "mean_ci", "mean_sei", "mean_sdi", "mean_pval", |
|
| 14 | +502 |
- #' "Grade 5 (%)" = "5"+ "median", "mad", "median_ci", "quantiles", "iqr", "range", "min", "max", "median_range", "cv", |
|
| 15 | +503 |
- #' )+ "geom_mean", "geom_mean_ci", "geom_cv", |
|
| 16 | +504 |
- #' groups_list_to_df(grade_groups)+ "median_ci_3d", |
|
| 17 | +505 |
- #'+ "mean_ci_3d", "geom_mean_ci_3d" |
|
| 18 | +506 |
- #' @export+ ), |
|
| 19 | +507 |
- groups_list_to_df <- function(groups_list) {
+ count_cumulative = c("count_fraction", "count_fraction_fixed_dp"),
|
|
| 20 | -5x | +||
| 508 | +
- checkmate::assert_list(groups_list, names = "named")+ count_missed_doses = c("n", "count_fraction", "count_fraction_fixed_dp"),
|
||
| 21 | -5x | +||
| 509 | +
- lapply(groups_list, checkmate::assert_character)+ count_occurrences = c("count", "count_fraction", "count_fraction_fixed_dp", "fraction"),
|
||
| 22 | -5x | +||
| 510 | +
- tibble::tibble(+ count_occurrences_by_grade = c("count_fraction", "count_fraction_fixed_dp"),
|
||
| 23 | -5x | +||
| 511 | +
- valname = make_names(names(groups_list)),+ count_patients_with_event = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
|
||
| 24 | -5x | +||
| 512 | +
- label = names(groups_list),+ count_patients_with_flags = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
|
||
| 25 | -5x | +||
| 513 | +
- levelcombo = unname(groups_list),+ count_values = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"),
|
||
| 26 | -5x | +||
| 514 | +
- exargs = replicate(length(groups_list), list())+ coxph_pairwise = c("pvalue", "hr", "hr_ci", "n_tot", "n_tot_events"),
|
||
| 27 | +515 |
- )+ estimate_incidence_rate = c("person_years", "n_events", "rate", "rate_ci", "n_unique", "n_rate"),
|
|
| 28 | +516 |
- }+ estimate_multinomial_response = c("n_prop", "prop_ci"),
|
|
| 29 | +517 |
-
+ estimate_odds_ratio = c("or_ci", "n_tot"),
|
|
| 30 | +518 |
- #' Reference and treatment group combination+ estimate_proportion = c("n_prop", "prop_ci"),
|
|
| 31 | +519 |
- #'+ estimate_proportion_diff = c("diff", "diff_ci"),
|
|
| 32 | +520 |
- #' @description `r lifecycle::badge("stable")`
+ summarize_ancova = c("n", "lsmean", "lsmean_diff", "lsmean_diff_ci", "pval"),
|
|
| 33 | +521 |
- #'+ summarize_coxreg = c("n", "hr", "ci", "pval", "pval_inter"),
|
|
| 34 | +522 |
- #' Facilitate the re-combination of groups divided as reference and treatment groups; it helps in arranging groups of+ summarize_glm_count = c("n", "rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
|
|
| 35 | +523 |
- #' columns in the `rtables` framework and teal modules.+ summarize_num_patients = c("unique", "nonunique", "unique_count"),
|
|
| 36 | +524 |
- #'+ summarize_patients_events_in_cols = c("unique", "all"),
|
|
| 37 | +525 |
- #' @param fct (`factor`)\cr the variable with levels which needs to be grouped.+ surv_time = c( |
|
| 38 | +526 |
- #' @param ref (`character`)\cr the reference level(s).+ "median", "median_ci", "median_ci_3d", "quantiles", |
|
| 39 | +527 |
- #' @param collapse (`string`)\cr a character string to separate `fct` and `ref`.+ "quantiles_lower", "quantiles_upper", "range_censor", "range_event", "range" |
|
| 40 | +528 |
- #'+ ), |
|
| 41 | +529 |
- #' @return A `list` with first item `ref` (reference) and second item `trt` (treatment).+ surv_timepoint = c( |
|
| 42 | +530 |
- #'+ "pt_at_risk", "event_free_rate", "rate_se", "rate_ci", "rate_diff", "rate_diff_ci", "ztest_pval", |
|
| 43 | +531 |
- #' @examples+ "event_free_rate_3d" |
|
| 44 | +532 |
- #' groups <- combine_groups(+ ), |
|
| 45 | +533 |
- #' fct = DM$ARM,+ tabulate_rsp_biomarkers = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
|
|
| 46 | +534 |
- #' ref = c("B: Placebo")
+ tabulate_rsp_subgroups = c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval"),
|
|
| 47 | +535 |
- #' )+ tabulate_survival_biomarkers = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
|
|
| 48 | +536 |
- #'+ tabulate_survival_subgroups = c("n_tot_events", "n_events", "n_tot", "n", "median", "hr", "ci", "pval"),
|
|
| 49 | +537 |
- #' basic_table() %>%+ test_proportion_diff = c("pval")
|
|
| 50 | +538 |
- #' split_cols_by_groups("ARM", groups) %>%
+ ) |
|
| 51 | +539 |
- #' add_colcounts() %>%+ |
|
| 52 | +540 |
- #' analyze_vars("AGE") %>%
+ # tern_default_formats --------------------------------------------------------- |
|
| 53 | +541 |
- #' build_table(DM)+ #' @describeIn default_stats_formats_labels Named vector of default formats for `tern`. |
|
| 54 | +542 |
#' |
|
| 55 | +543 |
- #' @export+ #' @format |
|
| 56 | +544 |
- combine_groups <- function(fct,+ #' * `tern_default_formats` is a named vector of available default formats, with each element |
|
| 57 | +545 |
- ref = NULL,+ #' named for their corresponding statistic. |
|
| 58 | +546 |
- collapse = "/") {
+ #' |
|
| 59 | -10x | +||
| 547 | +
- checkmate::assert_string(collapse)+ #' @export |
||
| 60 | -10x | +||
| 548 | +
- checkmate::assert_character(ref, min.chars = 1, any.missing = FALSE, null.ok = TRUE)+ tern_default_formats <- c( |
||
| 61 | -10x | +||
| 549 | +
- checkmate::assert_multi_class(fct, classes = c("factor", "character"))
+ fraction = format_fraction_fixed_dp, |
||
| 62 | +550 |
-
+ unique = format_count_fraction_fixed_dp, |
|
| 63 | -10x | +||
| 551 | +
- fct <- as_factor_keep_attributes(fct)+ nonunique = "xx", |
||
| 64 | +552 |
-
+ unique_count = "xx", |
|
| 65 | -10x | +||
| 553 | +
- group_levels <- levels(fct)+ n = "xx.", |
||
| 66 | -10x | +||
| 554 | +
- if (is.null(ref)) {
+ count = "xx.", |
||
| 67 | -6x | +||
| 555 | +
- ref <- group_levels[1]+ count_fraction = format_count_fraction, |
||
| 68 | +556 |
- } else {
+ count_fraction_fixed_dp = format_count_fraction_fixed_dp, |
|
| 69 | -4x | +||
| 557 | +
- checkmate::assert_subset(ref, group_levels)+ n_blq = "xx.", |
||
| 70 | +558 |
- }+ sum = "xx.x", |
|
| 71 | +559 |
-
+ mean = "xx.x", |
|
| 72 | -10x | +||
| 560 | +
- groups <- list(+ sd = "xx.x", |
||
| 73 | -10x | +||
| 561 | +
- ref = group_levels[group_levels %in% ref],+ se = "xx.x", |
||
| 74 | -10x | +||
| 562 | +
- trt = group_levels[!group_levels %in% ref]+ mean_sd = "xx.x (xx.x)", |
||
| 75 | +563 |
- )+ mean_se = "xx.x (xx.x)", |
|
| 76 | -10x | +||
| 564 | +
- stats::setNames(groups, nm = lapply(groups, paste, collapse = collapse))+ mean_ci = "(xx.xx, xx.xx)", |
||
| 77 | +565 |
- }+ mean_sei = "(xx.xx, xx.xx)", |
|
| 78 | +566 |
-
+ mean_sdi = "(xx.xx, xx.xx)", |
|
| 79 | +567 |
- #' Split columns by groups of levels+ mean_pval = "x.xxxx | (<0.0001)", |
|
| 80 | +568 |
- #'+ mean_ci_3d = "xx.xx (xx.xx - xx.xx)", |
|
| 81 | +569 |
- #' @description `r lifecycle::badge("stable")`
+ median = "xx.x", |
|
| 82 | +570 |
- #'+ mad = "xx.x", |
|
| 83 | +571 |
- #' @inheritParams argument_convention+ median_ci = "(xx.xx, xx.xx)", |
|
| 84 | +572 |
- #' @inheritParams groups_list_to_df+ median_ci_3d = "xx.xx (xx.xx - xx.xx)", |
|
| 85 | +573 |
- #' @param ... additional arguments to [rtables::split_cols_by()] in order. For instance, to+ quantiles = "xx.x - xx.x", |
|
| 86 | +574 |
- #' control formats (`format`), add a joint column for all groups (`incl_all`).+ quantiles_lower = "xx.xx (xx.xx - xx.xx)", |
|
| 87 | +575 |
- #'+ quantiles_upper = "xx.xx (xx.xx - xx.xx)", |
|
| 88 | +576 |
- #' @return A layout object suitable for passing to further layouting functions. Adding+ iqr = "xx.x", |
|
| 89 | +577 |
- #' this function to an `rtable` layout will add a column split including the given+ range = "xx.x - xx.x", |
|
| 90 | +578 |
- #' groups to the table layout.+ min = "xx.x", |
|
| 91 | +579 |
- #'+ max = "xx.x", |
|
| 92 | +580 |
- #' @seealso [rtables::split_cols_by()]+ median_range = "xx.x (xx.x - xx.x)", |
|
| 93 | +581 |
- #'+ cv = "xx.x", |
|
| 94 | +582 |
- #' @examples+ geom_mean = "xx.x", |
|
| 95 | +583 |
- #' # 1 - Basic use+ geom_mean_ci = "(xx.xx, xx.xx)", |
|
| 96 | +584 |
- #'+ geom_mean_ci_3d = "xx.xx (xx.xx - xx.xx)", |
|
| 97 | +585 |
- #' # Without group combination `split_cols_by_groups` is+ geom_cv = "xx.x", |
|
| 98 | +586 |
- #' # equivalent to [rtables::split_cols_by()].+ pval = "x.xxxx | (<0.0001)", |
|
| 99 | +587 |
- #' basic_table() %>%+ pval_counts = "x.xxxx | (<0.0001)", |
|
| 100 | +588 |
- #' split_cols_by_groups("ARM") %>%
+ range_censor = "xx.x to xx.x", |
|
| 101 | +589 |
- #' add_colcounts() %>%+ range_event = "xx.x to xx.x", |
|
| 102 | +590 |
- #' analyze("AGE") %>%
+ rate = "xx.xxxx", |
|
| 103 | +591 |
- #' build_table(DM)+ rate_ci = "(xx.xxxx, xx.xxxx)", |
|
| 104 | +592 |
- #'+ rate_ratio = "xx.xxxx", |
|
| 105 | +593 |
- #' # Add a reference column.+ rate_ratio_ci = "(xx.xxxx, xx.xxxx)" |
|
| 106 | +594 |
- #' basic_table() %>%+ ) |
|
| 107 | +595 |
- #' split_cols_by_groups("ARM", ref_group = "B: Placebo") %>%
+
|
|
| 108 | +596 |
- #' add_colcounts() %>%+ # tern_default_labels ---------------------------------------------------------- |
|
| 109 | +597 |
- #' analyze(+ #' @describeIn default_stats_formats_labels Named `character` vector of default labels for `tern`. |
|
| 110 | +598 |
- #' "AGE",+ #' |
|
| 111 | +599 |
- #' afun = function(x, .ref_group, .in_ref_col) {
+ #' @format |
|
| 112 | +600 |
- #' if (.in_ref_col) {
+ #' * `tern_default_labels` is a named `character` vector of available default labels, with each element |
|
| 113 | +601 |
- #' in_rows("Diff Mean" = rcell(NULL))
+ #' named for their corresponding statistic. |
|
| 114 | +602 |
- #' } else {
+ #' |
|
| 115 | +603 |
- #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+ #' @export |
|
| 116 | +604 |
- #' }+ tern_default_labels <- c( |
|
| 117 | +605 |
- #' }+ unique = "Number of patients with at least one event", |
|
| 118 | +606 |
- #' ) %>%+ nonunique = "Number of events", |
|
| 119 | +607 |
- #' build_table(DM)+ n = "n", |
|
| 120 | +608 |
- #'+ n_blq = "n_blq", |
|
| 121 | +609 |
- #' # 2 - Adding group specification+ sum = "Sum", |
|
| 122 | +610 |
- #'+ mean = "Mean", |
|
| 123 | +611 |
- #' # Manual preparation of the groups.+ sd = "SD", |
|
| 124 | +612 |
- #' groups <- list(+ se = "SE", |
|
| 125 | +613 |
- #' "Arms A+B" = c("A: Drug X", "B: Placebo"),
+ mean_sd = "Mean (SD)", |
|
| 126 | +614 |
- #' "Arms A+C" = c("A: Drug X", "C: Combination")
+ mean_se = "Mean (SE)", |
|
| 127 | +615 |
- #' )+ mean_ci = "Mean 95% CI", |
|
| 128 | +616 |
- #'+ mean_sei = "Mean -/+ 1xSE", |
|
| 129 | +617 |
- #' # Use of split_cols_by_groups without reference column.+ mean_sdi = "Mean -/+ 1xSD", |
|
| 130 | +618 |
- #' basic_table() %>%+ mean_pval = "Mean p-value (H0: mean = 0)", |
|
| 131 | +619 |
- #' split_cols_by_groups("ARM", groups) %>%
+ mean_ci_3d = "Mean (95% CI)", |
|
| 132 | +620 |
- #' add_colcounts() %>%+ median = "Median", |
|
| 133 | +621 |
- #' analyze("AGE") %>%
+ mad = "Median Absolute Deviation", |
|
| 134 | +622 |
- #' build_table(DM)+ median_ci = "Median 95% CI", |
|
| 135 | +623 |
- #'+ median_ci_3d = "Median (95% CI)", |
|
| 136 | +624 |
- #' # Including differentiated output in the reference column.+ quantiles = "25% and 75%-ile", |
|
| 137 | +625 |
- #' basic_table() %>%+ quantiles_lower = "25%-ile (95% CI)", |
|
| 138 | +626 |
- #' split_cols_by_groups("ARM", groups_list = groups, ref_group = "Arms A+B") %>%
+ quantiles_upper = "75%-ile (95% CI)", |
|
| 139 | +627 |
- #' analyze(+ iqr = "IQR", |
|
| 140 | +628 |
- #' "AGE",+ range = "Min - Max", |
|
| 141 | +629 |
- #' afun = function(x, .ref_group, .in_ref_col) {
+ min = "Minimum", |
|
| 142 | +630 |
- #' if (.in_ref_col) {
+ max = "Maximum", |
|
| 143 | +631 |
- #' in_rows("Diff. of Averages" = rcell(NULL))
+ median_range = "Median (Min - Max)", |
|
| 144 | +632 |
- #' } else {
+ cv = "CV (%)", |
|
| 145 | +633 |
- #' in_rows("Diff. of Averages" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+ geom_mean = "Geometric Mean", |
|
| 146 | +634 |
- #' }+ geom_mean_ci = "Geometric Mean 95% CI", |
|
| 147 | +635 |
- #' }+ geom_mean_ci_3d = "Geometric Mean (95% CI)", |
|
| 148 | +636 |
- #' ) %>%+ geom_cv = "CV % Geometric Mean", |
|
| 149 | +637 |
- #' build_table(DM)+ pval = "p-value (t-test)", # Default for numeric |
|
| 150 | +638 |
- #'+ pval_counts = "p-value (chi-squared test)", # Default for counts |
|
| 151 | +639 |
- #' # 3 - Binary list dividing factor levels into reference and treatment+ rate = "Adjusted Rate", |
|
| 152 | +640 |
- #'+ rate_ratio = "Adjusted Rate Ratio" |
|
| 153 | +641 |
- #' # `combine_groups` defines reference and treatment.+ ) |
|
| 154 | +642 |
- #' groups <- combine_groups(+ |
|
| 155 | +643 |
- #' fct = DM$ARM,+ #' @describeIn default_stats_formats_labels Quick function to retrieve default formats for summary statistics: |
|
| 156 | +644 |
- #' ref = c("A: Drug X", "B: Placebo")
+ #' [analyze_vars()] and [analyze_vars_in_cols()] principally. |
|
| 157 | +645 |
- #' )+ #' |
|
| 158 | +646 |
- #' groups+ #' @param type (`string`)\cr `"numeric"` or `"counts"`. |
|
| 159 | +647 |
#' |
|
| 160 | +648 |
- #' # Use group definition without reference column.+ #' @return |
|
| 161 | +649 |
- #' basic_table() %>%+ #' * `summary_formats()` returns a named `vector` of default statistic formats for the given data type. |
|
| 162 | +650 |
- #' split_cols_by_groups("ARM", groups_list = groups) %>%
+ #' |
|
| 163 | +651 |
- #' add_colcounts() %>%+ #' @examples |
|
| 164 | +652 |
- #' analyze("AGE") %>%
+ #' summary_formats() |
|
| 165 | +653 |
- #' build_table(DM)+ #' summary_formats(type = "counts", include_pval = TRUE) |
|
| 166 | +654 |
#' |
|
| 167 | +655 |
- #' # Use group definition with reference column (first item of groups).+ #' @export |
|
| 168 | +656 |
- #' basic_table() %>%+ summary_formats <- function(type = "numeric", include_pval = FALSE) {
|
|
| 169 | -+ | ||
| 657 | +2x |
- #' split_cols_by_groups("ARM", groups, ref_group = names(groups)[1]) %>%
+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
|
|
| 170 | -+ | ||
| 658 | +2x |
- #' add_colcounts() %>%+ get_formats_from_stats(get_stats(met_grp, add_pval = include_pval)) |
|
| 171 | +659 |
- #' analyze(+ } |
|
| 172 | +660 |
- #' "AGE",+ |
|
| 173 | +661 |
- #' afun = function(x, .ref_group, .in_ref_col) {
+ #' @describeIn default_stats_formats_labels Quick function to retrieve default labels for summary statistics. |
|
| 174 | +662 |
- #' if (.in_ref_col) {
+ #' Returns labels of descriptive statistics which are understood by `rtables`. Similar to `summary_formats`. |
|
| 175 | +663 |
- #' in_rows("Diff Mean" = rcell(NULL))
+ #' |
|
| 176 | +664 |
- #' } else {
+ #' @param include_pval (`flag`)\cr same as the `add_pval` argument in [get_stats()]. |
|
| 177 | +665 |
- #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+ #' |
|
| 178 | +666 |
- #' }+ #' @details |
|
| 179 | +667 |
- #' }+ #' `summary_*` quick get functions for labels or formats uses `get_stats` and `get_labels_from_stats` or |
|
| 180 | +668 |
- #' ) %>%+ #' `get_formats_from_stats` respectively to retrieve relevant information. |
|
| 181 | +669 |
- #' build_table(DM)+ #' |
|
| 182 | +670 |
- #'+ #' @return |
|
| 183 | +671 |
- #' @export+ #' * `summary_labels` returns a named `vector` of default statistic labels for the given data type. |
|
| 184 | +672 |
- split_cols_by_groups <- function(lyt,+ #' |
|
| 185 | +673 |
- var,+ #' @examples |
|
| 186 | +674 |
- groups_list = NULL,+ #' summary_labels() |
|
| 187 | +675 |
- ref_group = NULL,+ #' summary_labels(type = "counts", include_pval = TRUE) |
|
| 188 | +676 |
- ...) {
+ #' |
|
| 189 | -6x | +||
| 677 | +
- if (is.null(groups_list)) {
+ #' @export |
||
| 190 | -2x | +||
| 678 | +
- split_cols_by(+ summary_labels <- function(type = "numeric", include_pval = FALSE) {
|
||
| 191 | +679 | 2x |
- lyt = lyt,+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
|
| 192 | +680 | 2x |
- var = var,+ get_labels_from_stats(get_stats(met_grp, add_pval = include_pval)) |
| 193 | -2x | +||
| 681 | +
- ref_group = ref_group,+ } |
| 194 | +1 |
- ...+ #' Control function for subgroup treatment effect pattern (STEP) calculations |
||
| 195 | +2 |
- )+ #' |
||
| 196 | +3 |
- } else {
+ #' @description `r lifecycle::badge("stable")`
|
||
| 197 | -4x | +|||
| 4 | +
- groups_df <- groups_list_to_df(groups_list)+ #' |
|||
| 198 | -4x | +|||
| 5 | +
- if (!is.null(ref_group)) {
+ #' This is an auxiliary function for controlling arguments for STEP calculations. |
|||
| 199 | -3x | +|||
| 6 | +
- ref_group <- groups_df$valname[groups_df$label == ref_group]+ #' |
|||
| 200 | +7 |
- }+ #' @param biomarker (`numeric` or `NULL`)\cr optional provision of the numeric biomarker variable, which |
||
| 201 | -4x | +|||
| 8 | +
- split_cols_by(+ #' could be used to infer `bandwidth`, see below. |
|||
| 202 | -4x | +|||
| 9 | +
- lyt = lyt,+ #' @param use_percentile (`flag`)\cr if `TRUE`, the running windows are created according to |
|||
| 203 | -4x | +|||
| 10 | +
- var = var,+ #' quantiles rather than actual values, i.e. the bandwidth refers to the percentage of data |
|||
| 204 | -4x | +|||
| 11 | +
- split_fun = add_combo_levels(groups_df, keep_levels = groups_df$valname),+ #' covered in each window. Suggest `TRUE` if the biomarker variable is not uniformly |
|||
| 205 | -4x | +|||
| 12 | +
- ref_group = ref_group,+ #' distributed. |
|||
| 206 | +13 |
- ...+ #' @param bandwidth (`numeric(1)` or `NULL`)\cr indicating the bandwidth of each window. |
||
| 207 | +14 |
- )+ #' Depending on the argument `use_percentile`, it can be either the length of actual-value |
||
| 208 | +15 |
- }+ #' windows on the real biomarker scale, or percentage windows. |
||
| 209 | +16 |
- }+ #' If `use_percentile = TRUE`, it should be a number between 0 and 1. |
||
| 210 | +17 |
-
+ #' If `NULL`, treat the bandwidth to be infinity, which means only one global model will be fitted. |
||
| 211 | +18 |
- #' Combine counts+ #' By default, `0.25` is used for percentage windows and one quarter of the range of the `biomarker` |
||
| 212 | +19 |
- #'+ #' variable for actual-value windows. |
||
| 213 | +20 |
- #' Simplifies the estimation of column counts, especially when group combination is required.+ #' @param degree (`integer(1)`)\cr the degree of polynomial function of the biomarker as an interaction term |
||
| 214 | +21 |
- #'+ #' with the treatment arm fitted at each window. If 0 (default), then the biomarker variable |
||
| 215 | +22 |
- #' @inheritParams combine_groups+ #' is not included in the model fitted in each biomarker window. |
||
| 216 | +23 |
- #' @inheritParams groups_list_to_df+ #' @param num_points (`integer(1)`)\cr the number of points at which the hazard ratios are estimated. The |
||
| 217 | +24 |
- #'+ #' smallest number is 2. |
||
| 218 | +25 |
- #' @return A `vector` of column counts.+ #' |
||
| 219 | +26 |
- #'+ #' @return A list of components with the same names as the arguments, except `biomarker` which is |
||
| 220 | +27 |
- #' @seealso [combine_groups()]+ #' just used to calculate the `bandwidth` in case that actual biomarker windows are requested. |
||
| 221 | +28 |
#' |
||
| 222 | +29 |
#' @examples |
||
| 223 | +30 |
- #' ref <- c("A: Drug X", "B: Placebo")
+ #' # Provide biomarker values and request actual values to be used, |
||
| 224 | +31 |
- #' groups <- combine_groups(fct = DM$ARM, ref = ref)+ #' # so that bandwidth is chosen from range. |
||
| 225 | +32 |
- #'+ #' control_step(biomarker = 1:10, use_percentile = FALSE) |
||
| 226 | +33 |
- #' col_counts <- combine_counts(+ #' |
||
| 227 | +34 |
- #' fct = DM$ARM,+ #' # Use a global model with quadratic biomarker interaction term. |
||
| 228 | +35 |
- #' groups_list = groups+ #' control_step(bandwidth = NULL, degree = 2) |
||
| 229 | +36 |
- #' )+ #' |
||
| 230 | +37 |
- #'+ #' # Reduce number of points to be used. |
||
| 231 | +38 |
- #' basic_table() %>%+ #' control_step(num_points = 10) |
||
| 232 | +39 |
- #' split_cols_by_groups("ARM", groups) %>%
+ #' |
||
| 233 | +40 |
- #' add_colcounts() %>%+ #' @export |
||
| 234 | +41 |
- #' analyze_vars("AGE") %>%
+ control_step <- function(biomarker = NULL, |
||
| 235 | +42 |
- #' build_table(DM, col_counts = col_counts)+ use_percentile = TRUE, |
||
| 236 | +43 |
- #'+ bandwidth, |
||
| 237 | +44 |
- #' ref <- "A: Drug X"+ degree = 0L, |
||
| 238 | +45 |
- #' groups <- combine_groups(fct = DM$ARM, ref = ref)+ num_points = 39L) {
|
||
| 239 | -+ | |||
| 46 | +31x |
- #' col_counts <- combine_counts(+ checkmate::assert_numeric(biomarker, null.ok = TRUE) |
||
| 240 | -+ | |||
| 47 | +30x |
- #' fct = DM$ARM,+ checkmate::assert_flag(use_percentile) |
||
| 241 | -+ | |||
| 48 | +30x |
- #' groups_list = groups+ checkmate::assert_int(num_points, lower = 2) |
||
| 242 | -+ | |||
| 49 | +29x |
- #' )+ checkmate::assert_count(degree) |
||
| 243 | +50 |
- #'+ |
||
| 244 | -+ | |||
| 51 | +29x |
- #' basic_table() %>%+ if (missing(bandwidth)) {
|
||
| 245 | +52 |
- #' split_cols_by_groups("ARM", groups) %>%
+ # Infer bandwidth |
||
| 246 | -+ | |||
| 53 | +21x |
- #' add_colcounts() %>%+ bandwidth <- if (use_percentile) {
|
||
| 247 | -+ | |||
| 54 | +18x |
- #' analyze_vars("AGE") %>%
+ 0.25+ |
+ ||
| 55 | +21x | +
+ } else if (!is.null(biomarker)) {
+ |
+ ||
| 56 | +3x | +
+ diff(range(biomarker, na.rm = TRUE)) / 4 |
||
| 248 | +57 |
- #' build_table(DM, col_counts = col_counts)+ } else {
+ |
+ ||
| 58 | +! | +
+ NULL |
||
| 249 | +59 |
- #'+ } |
||
| 250 | +60 |
- #' @export+ } else {
|
||
| 251 | +61 |
- combine_counts <- function(fct, groups_list = NULL) {
+ # Check bandwidth |
||
| 252 | -4x | +62 | +8x |
- checkmate::assert_multi_class(fct, classes = c("factor", "character"))
+ if (!is.null(bandwidth)) {
|
| 253 | -+ | |||
| 63 | +5x |
-
+ if (use_percentile) {
|
||
| 254 | +64 | 4x |
- fct <- as_factor_keep_attributes(fct)+ assert_proportion_value(bandwidth) |
|
| 255 | +65 |
-
+ } else {
|
||
| 256 | -4x | +66 | +1x |
- if (is.null(groups_list)) {
+ checkmate::assert_scalar(bandwidth) |
| 257 | +67 | 1x |
- y <- table(fct)+ checkmate::assert_true(bandwidth > 0) |
|
| 258 | -1x | +|||
| 68 | +
- y <- stats::setNames(as.numeric(y), nm = dimnames(y)[[1]])+ } |
|||
| 259 | +69 |
- } else {
+ }+ |
+ ||
| 70 | ++ |
+ } |
||
| 260 | -3x | +71 | +28x |
- y <- vapply(+ list( |
| 261 | -3x | +72 | +28x |
- X = groups_list,+ use_percentile = use_percentile, |
| 262 | -3x | +73 | +28x |
- FUN = function(x) sum(table(fct)[x]),+ bandwidth = bandwidth, |
| 263 | -3x | +74 | +28x |
- FUN.VALUE = 1+ degree = as.integer(degree), |
| 264 | -+ | |||
| 75 | +28x |
- )+ num_points = as.integer(num_points) |
||
| 265 | +76 |
- }- |
- ||
| 266 | -4x | -
- y+ ) |
||
| 267 | +77 |
}@@ -115907,14 +118816,14 @@ tern coverage - 95.59% |
| 1 |
- #' Helper functions for tabulating survival duration by subgroup+ #' Control function for descriptive statistics |
||
| 5 |
- #' Helper functions that tabulate in a data frame statistics such as median survival+ #' Sets a list of parameters for summaries of descriptive statistics. Typically used internally to specify |
||
| 6 |
- #' time and hazard ratio for population subgroups.+ #' details for [s_summary()]. This function family is mainly used by [analyze_vars()]. |
||
| 9 |
- #' @inheritParams survival_coxph_pairwise+ #' @param quantiles (`numeric(2)`)\cr vector of length two to specify the quantiles to calculate. |
||
| 10 |
- #' @inheritParams survival_duration_subgroups+ #' @param quantile_type (`numeric(1)`)\cr number between 1 and 9 selecting quantile algorithms to be used. |
||
| 11 |
- #' @param arm (`factor`)\cr the treatment group variable.+ #' Default is set to 2 as this matches the default quantile algorithm in SAS `proc univariate` set by `QNTLDEF=5`. |
||
| 12 |
- #'+ #' This differs from R's default. See more about `type` in [stats::quantile()]. |
||
| 13 |
- #' @details Main functionality is to prepare data for use in a layout-creating function.+ #' @param test_mean (`numeric(1)`)\cr number to test against the mean under the null hypothesis when calculating |
||
| 14 |
- #'+ #' p-value. |
||
| 15 |
- #' @examples+ #' |
||
| 16 |
- #' library(dplyr)+ #' @return A list of components with the same names as the arguments. |
||
| 17 |
- #' library(forcats)+ #' |
||
| 18 |
- #'+ #' @export |
||
| 19 |
- #' adtte <- tern_ex_adtte+ control_analyze_vars <- function(conf_level = 0.95, |
||
| 20 |
- #'+ quantiles = c(0.25, 0.75), |
||
| 21 |
- #' # Save variable labels before data processing steps.+ quantile_type = 2, |
||
| 22 |
- #' adtte_labels <- formatters::var_labels(adtte)+ test_mean = 0) {
|
||
| 23 | -+ | 1095x |
- #'+ checkmate::assert_vector(quantiles, len = 2) |
| 24 | -+ | 1095x |
- #' adtte_f <- adtte %>%+ checkmate::assert_int(quantile_type, lower = 1, upper = 9) |
| 25 | -+ | 1095x |
- #' filter(+ checkmate::assert_numeric(test_mean) |
| 26 | -+ | 1095x |
- #' PARAMCD == "OS",+ lapply(quantiles, assert_proportion_value) |
| 27 | -+ | 1094x |
- #' ARM %in% c("B: Placebo", "A: Drug X"),
+ assert_proportion_value(conf_level) |
| 28 | -+ | 1093x |
- #' SEX %in% c("M", "F")
+ list(conf_level = conf_level, quantiles = quantiles, quantile_type = quantile_type, test_mean = test_mean) |
| 29 |
- #' ) %>%+ } |
||
| 30 |
- #' mutate(+ |
||
| 31 |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ # Helper function to fix numeric or counts pval if necessary |
||
| 32 |
- #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),+ .correct_num_or_counts_pval <- function(type, .stats) {
|
||
| 33 | -+ | 329x |
- #' SEX = droplevels(SEX),+ if (type == "numeric") {
|
| 34 | -+ | 89x |
- #' is_event = CNSR == 0+ if (!is.null(.stats) && any(grepl("^pval", .stats))) {
|
| 35 | -+ | 10x |
- #' )+ .stats[grepl("^pval", .stats)] <- "pval" # tmp fix xxx
|
| 36 |
- #' labels <- c("ARM" = adtte_labels[["ARM"]], "SEX" = adtte_labels[["SEX"]], "is_event" = "Event Flag")
+ } |
||
| 37 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ } else {
|
||
| 38 | -+ | 240x |
- #'+ if (!is.null(.stats) && any(grepl("^pval", .stats))) {
|
| 39 | -+ | 9x |
- #' @name h_survival_duration_subgroups+ .stats[grepl("^pval", .stats)] <- "pval_counts" # tmp fix xxx
|
| 40 |
- NULL+ } |
||
| 41 |
-
+ } |
||
| 42 | -+ | 329x |
- #' @describeIn h_survival_duration_subgroups Helper to prepare a data frame of median survival times by arm.+ .stats |
| 43 |
- #'+ } |
||
| 44 |
- #' @return+ |
||
| 45 |
- #' * `h_survtime_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, and `median`.+ #' Analyze variables |
||
| 47 |
- #' @examples+ #' @description `r lifecycle::badge("stable")`
|
||
| 48 |
- #' # Extract median survival time for one group.+ #' |
||
| 49 |
- #' h_survtime_df(+ #' The analyze function [analyze_vars()] creates a layout element to summarize one or more variables, using the S3 |
||
| 50 |
- #' tte = adtte_f$AVAL,+ #' generic function [s_summary()] to calculate a list of summary statistics. A list of all available statistics for |
||
| 51 |
- #' is_event = adtte_f$is_event,+ #' numeric variables can be viewed by running `get_stats("analyze_vars_numeric")` and for non-numeric variables by
|
||
| 52 |
- #' arm = adtte_f$ARM+ #' running `get_stats("analyze_vars_counts")`. Use the `.stats` parameter to specify the statistics to include in your
|
||
| 53 |
- #' )+ #' output summary table. Use `compare_with_ref_group = TRUE` to compare the variable with reference groups. |
||
| 55 |
- #' @export+ #' @details |
||
| 56 |
- h_survtime_df <- function(tte, is_event, arm) {
+ #' **Automatic digit formatting:** The number of digits to display can be automatically determined from the analyzed |
||
| 57 | -79x | +
- checkmate::assert_numeric(tte)+ #' variable(s) (`vars`) for certain statistics by setting the statistic format to `"auto"` in `.formats`. |
|
| 58 | -78x | +
- checkmate::assert_logical(is_event, len = length(tte))+ #' This utilizes the [format_auto()] formatting function. Note that only data for the current row & variable (for all |
|
| 59 | -78x | +
- assert_valid_factor(arm, len = length(tte))+ #' columns) will be considered (`.df_row[[.var]]`, see [`rtables::additional_fun_params`]) and not the whole dataset. |
|
| 60 |
-
+ #' |
||
| 61 | -78x | +
- df_tte <- data.frame(+ #' @inheritParams argument_convention |
|
| 62 | -78x | +
- tte = tte,+ #' @param .stats (`character`)\cr statistics to select for the table. |
|
| 63 | -78x | +
- is_event = is_event,+ #' |
|
| 64 | -78x | +
- stringsAsFactors = FALSE+ #' Options for numeric variables are: ``r shQuote(get_stats("analyze_vars_numeric"), type = "sh")``
|
|
| 65 |
- )+ #' |
||
| 66 |
-
+ #' Options for non-numeric variables are: ``r shQuote(get_stats("analyze_vars_counts"), type = "sh")``
|
||
| 67 |
- # Delete NAs+ #' |
||
| 68 | -78x | +
- non_missing_rows <- stats::complete.cases(df_tte)+ #' @name analyze_variables |
|
| 69 | -78x | +
- df_tte <- df_tte[non_missing_rows, ]+ #' @order 1 |
|
| 70 | -78x | +
- arm <- arm[non_missing_rows]+ NULL |
|
| 72 | -78x | +
- lst_tte <- split(df_tte, arm)+ #' @describeIn analyze_variables S3 generic function to produces a variable summary. |
|
| 73 | -78x | +
- lst_results <- Map(function(x, arm) {
+ #' |
|
| 74 | -156x | +
- if (nrow(x) > 0) {
+ #' @return |
|
| 75 | -152x | +
- s_surv <- s_surv_time(x, .var = "tte", is_event = "is_event")+ #' * `s_summary()` returns different statistics depending on the class of `x`. |
|
| 76 | -152x | +
- median_est <- unname(as.numeric(s_surv$median))+ #' |
|
| 77 | -152x | +
- n_events <- sum(x$is_event)+ #' @export |
|
| 78 |
- } else {
+ s_summary <- function(x, ...) {
|
||
| 79 | -4x | +1658x |
- median_est <- NA+ UseMethod("s_summary", x)
|
| 80 | -4x | +
- n_events <- NA+ } |
|
| 81 |
- }+ |
||
| 82 |
-
+ #' @describeIn analyze_variables Method for `numeric` class. |
||
| 83 | -156x | +
- data.frame(+ #' |
|
| 84 | -156x | +
- arm = arm,+ #' @param control (`list`)\cr parameters for descriptive statistics details, specified by using |
|
| 85 | -156x | +
- n = nrow(x),+ #' the helper function [control_analyze_vars()]. Some possible parameter options are: |
|
| 86 | -156x | +
- n_events = n_events,+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for mean and median. |
|
| 87 | -156x | +
- median = median_est,+ #' * `quantiles` (`numeric(2)`)\cr vector of length two to specify the quantiles. |
|
| 88 | -156x | +
- stringsAsFactors = FALSE+ #' * `quantile_type` (`numeric(1)`)\cr between 1 and 9 selecting quantile algorithms to be used. |
|
| 89 |
- )+ #' See more about `type` in [stats::quantile()]. |
||
| 90 | -78x | +
- }, lst_tte, names(lst_tte))+ #' * `test_mean` (`numeric(1)`)\cr value to test against the mean under the null hypothesis when calculating p-value. |
|
| 91 |
-
+ #' |
||
| 92 | -78x | +
- df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE))+ #' @return |
|
| 93 | -78x | +
- df$arm <- factor(df$arm, levels = levels(arm))+ #' * If `x` is of class `numeric`, returns a `list` with the following named `numeric` items: |
|
| 94 | -78x | +
- df+ #' * `n`: The [length()] of `x`. |
|
| 95 |
- }+ #' * `sum`: The [sum()] of `x`. |
||
| 96 |
-
+ #' * `mean`: The [mean()] of `x`. |
||
| 97 |
- #' @describeIn h_survival_duration_subgroups Summarizes median survival times by arm and across subgroups+ #' * `sd`: The [stats::sd()] of `x`. |
||
| 98 |
- #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and+ #' * `se`: The standard error of `x` mean, i.e.: (`sd(x) / sqrt(length(x))`). |
||
| 99 |
- #' requires elements `tte`, `is_event`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies+ #' * `mean_sd`: The [mean()] and [stats::sd()] of `x`. |
||
| 100 |
- #' groupings for `subgroups` variables.+ #' * `mean_se`: The [mean()] of `x` and its standard error (see above). |
||
| 101 |
- #'+ #' * `mean_ci`: The CI for the mean of `x` (from [stat_mean_ci()]). |
||
| 102 |
- #' @return+ #' * `mean_sei`: The SE interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()] / [sqrt()]). |
||
| 103 |
- #' * `h_survtime_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, `median`, `subgroup`,+ #' * `mean_sdi`: The SD interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()]). |
||
| 104 |
- #' `var`, `var_label`, and `row_type`.+ #' * `mean_pval`: The two-sided p-value of the mean of `x` (from [stat_mean_pval()]). |
||
| 105 |
- #'+ #' * `median`: The [stats::median()] of `x`. |
||
| 106 |
- #' @examples+ #' * `mad`: The median absolute deviation of `x`, i.e.: ([stats::median()] of `xc`, |
||
| 107 |
- #' # Extract median survival time for multiple groups.+ #' where `xc` = `x` - [stats::median()]). |
||
| 108 |
- #' h_survtime_subgroups_df(+ #' * `median_ci`: The CI for the median of `x` (from [stat_median_ci()]). |
||
| 109 |
- #' variables = list(+ #' * `quantiles`: Two sample quantiles of `x` (from [stats::quantile()]). |
||
| 110 |
- #' tte = "AVAL",+ #' * `iqr`: The [stats::IQR()] of `x`. |
||
| 111 |
- #' is_event = "is_event",+ #' * `range`: The [range_noinf()] of `x`. |
||
| 112 |
- #' arm = "ARM",+ #' * `min`: The [max()] of `x`. |
||
| 113 |
- #' subgroups = c("SEX", "BMRKR2")
+ #' * `max`: The [min()] of `x`. |
||
| 114 |
- #' ),+ #' * `median_range`: The [median()] and [range_noinf()] of `x`. |
||
| 115 |
- #' data = adtte_f+ #' * `cv`: The coefficient of variation of `x`, i.e.: ([stats::sd()] / [mean()] * 100). |
||
| 116 |
- #' )+ #' * `geom_mean`: The geometric mean of `x`, i.e.: (`exp(mean(log(x)))`). |
||
| 117 |
- #'+ #' * `geom_cv`: The geometric coefficient of variation of `x`, i.e.: (`sqrt(exp(sd(log(x)) ^ 2) - 1) * 100`). |
||
| 118 |
- #' # Define groupings for BMRKR2 levels.+ #' |
||
| 119 |
- #' h_survtime_subgroups_df(+ #' @note |
||
| 120 |
- #' variables = list(+ #' * If `x` is an empty vector, `NA` is returned. This is the expected feature so as to return `rcell` content in |
||
| 121 |
- #' tte = "AVAL",+ #' `rtables` when the intersection of a column and a row delimits an empty data selection. |
||
| 122 |
- #' is_event = "is_event",+ #' * When the `mean` function is applied to an empty vector, `NA` will be returned instead of `NaN`, the latter |
||
| 123 |
- #' arm = "ARM",+ #' being standard behavior in R. |
||
| 124 |
- #' subgroups = c("SEX", "BMRKR2")
+ #' |
||
| 125 |
- #' ),+ #' @method s_summary numeric |
||
| 126 |
- #' data = adtte_f,+ #' |
||
| 127 |
- #' groups_lists = list(+ #' @examples |
||
| 128 |
- #' BMRKR2 = list(+ #' # `s_summary.numeric` |
||
| 129 |
- #' "low" = "LOW",+ #' |
||
| 130 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' ## Basic usage: empty numeric returns NA-filled items. |
||
| 131 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ #' s_summary(numeric()) |
||
| 132 |
- #' )+ #' |
||
| 133 |
- #' )+ #' ## Management of NA values. |
||
| 134 |
- #' )+ #' x <- c(NA_real_, 1) |
||
| 135 |
- #'+ #' s_summary(x, na_rm = TRUE) |
||
| 136 |
- #' @export+ #' s_summary(x, na_rm = FALSE) |
||
| 137 |
- h_survtime_subgroups_df <- function(variables,+ #' |
||
| 138 |
- data,+ #' x <- c(NA_real_, 1, 2) |
||
| 139 |
- groups_lists = list(),+ #' s_summary(x) |
||
| 140 |
- label_all = "All Patients") {
+ #' |
||
| 141 | -15x | +
- checkmate::assert_character(variables$tte)+ #' ## Benefits in `rtables` contructions: |
|
| 142 | -15x | +
- checkmate::assert_character(variables$is_event)+ #' dta_test <- data.frame( |
|
| 143 | -15x | +
- checkmate::assert_character(variables$arm)+ #' Group = rep(LETTERS[seq(3)], each = 2), |
|
| 144 | -15x | +
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ #' sub_group = rep(letters[seq(2)], each = 3), |
|
| 145 |
-
+ #' x = seq(6) |
||
| 146 | -15x | +
- assert_df_with_variables(data, variables)+ #' ) |
|
| 147 |
-
+ #' |
||
| 148 | -15x | +
- checkmate::assert_string(label_all)+ #' ## The summary obtained in with `rtables`: |
|
| 149 |
-
+ #' basic_table() %>% |
||
| 150 |
- # Add All Patients.+ #' split_cols_by(var = "Group") %>% |
||
| 151 | -15x | +
- result_all <- h_survtime_df(data[[variables$tte]], data[[variables$is_event]], data[[variables$arm]])+ #' split_rows_by(var = "sub_group") %>% |
|
| 152 | -15x | +
- result_all$subgroup <- label_all+ #' analyze(vars = "x", afun = s_summary) %>% |
|
| 153 | -15x | +
- result_all$var <- "ALL"+ #' build_table(df = dta_test) |
|
| 154 | -15x | +
- result_all$var_label <- label_all+ #' |
|
| 155 | -15x | +
- result_all$row_type <- "content"+ #' ## By comparison with `lapply`: |
|
| 156 |
-
+ #' X <- split(dta_test, f = with(dta_test, interaction(Group, sub_group))) |
||
| 157 |
- # Add Subgroups.+ #' lapply(X, function(x) s_summary(x$x)) |
||
| 158 | -15x | +
- if (is.null(variables$subgroups)) {
+ #' |
|
| 159 | -3x | +
- result_all+ #' @export |
|
| 160 |
- } else {
+ s_summary.numeric <- function(x, control = control_analyze_vars(), ...) {
|
||
| 161 | -12x | +1140x |
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ checkmate::assert_numeric(x) |
| 162 | -12x | +1140x |
- l_result <- lapply(l_data, function(grp) {
+ args_list <- list(...) |
| 163 | -60x | +1140x |
- result <- h_survtime_df(grp$df[[variables$tte]], grp$df[[variables$is_event]], grp$df[[variables$arm]])+ .N_row <- args_list[[".N_row"]] # nolint |
| 164 | -60x | +1140x |
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ .N_col <- args_list[[".N_col"]] # nolint |
| 165 | -60x | +1140x |
- cbind(result, result_labels)+ na_rm <- args_list[["na_rm"]] %||% TRUE |
| 166 | -+ | 1140x |
- })+ compare_with_ref_group <- args_list[["compare_with_ref_group"]] |
| 167 | -12x | +
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ |
|
| 168 | -12x | +1140x |
- result_subgroups$row_type <- "analysis"+ if (na_rm) {
|
| 169 | -12x | +1138x |
- rbind(+ x <- x[!is.na(x)] |
| 170 | -12x | +
- result_all,+ } |
|
| 171 | -12x | +
- result_subgroups+ |
|
| 172 | -+ | 1140x |
- )+ y <- list() |
| 173 |
- }+ |
||
| 174 | -+ | 1140x |
- }+ y$n <- c("n" = length(x))
|
| 176 | -+ | 1140x |
- #' @describeIn h_survival_duration_subgroups Helper to prepare a data frame with estimates of+ y$sum <- c("sum" = ifelse(length(x) == 0, NA_real_, sum(x, na.rm = FALSE)))
|
| 177 |
- #' treatment hazard ratio.+ |
||
| 178 | -+ | 1140x |
- #'+ y$mean <- c("mean" = ifelse(length(x) == 0, NA_real_, mean(x, na.rm = FALSE)))
|
| 179 |
- #' @param strata_data (`factor`, `data.frame`, or `NULL`)\cr required if stratified analysis is performed.+ |
||
| 180 | -+ | 1140x |
- #'+ y$sd <- c("sd" = stats::sd(x, na.rm = FALSE))
|
| 181 |
- #' @return+ |
||
| 182 | -+ | 1140x |
- #' * `h_coxph_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`,+ y$se <- c("se" = stats::sd(x, na.rm = FALSE) / sqrt(length(stats::na.omit(x))))
|
| 183 |
- #' `conf_level`, `pval` and `pval_label`.+ |
||
| 184 | -+ | 1140x |
- #'+ y$mean_sd <- c(y$mean, "sd" = stats::sd(x, na.rm = FALSE)) |
| 185 |
- #' @examples+ |
||
| 186 | -+ | 1140x |
- #' # Extract hazard ratio for one group.+ y$mean_se <- c(y$mean, y$se) |
| 187 |
- #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM)+ |
||
| 188 | -+ | 1140x |
- #'+ mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE) |
| 189 | -+ | 1140x |
- #' # Extract hazard ratio for one group with stratification factor.+ y$mean_ci <- formatters::with_label(mean_ci, paste("Mean", f_conf_level(control$conf_level)))
|
| 190 |
- #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM, strata_data = adtte_f$STRATA1)+ |
||
| 191 | -+ | 1140x |
- #'+ mean_sei <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE) / sqrt(y$n) |
| 192 | -+ | 1140x |
- #' @export+ names(mean_sei) <- c("mean_sei_lwr", "mean_sei_upr")
|
| 193 | -+ | 1140x |
- h_coxph_df <- function(tte, is_event, arm, strata_data = NULL, control = control_coxph()) {
+ y$mean_sei <- formatters::with_label(mean_sei, "Mean -/+ 1xSE") |
| 194 | -85x | +
- checkmate::assert_numeric(tte)+ |
|
| 195 | -85x | +1140x |
- checkmate::assert_logical(is_event, len = length(tte))+ mean_sdi <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE) |
| 196 | -85x | +1140x |
- assert_valid_factor(arm, n.levels = 2, len = length(tte))+ names(mean_sdi) <- c("mean_sdi_lwr", "mean_sdi_upr")
|
| 197 | -+ | 1140x |
-
+ y$mean_sdi <- formatters::with_label(mean_sdi, "Mean -/+ 1xSD") |
| 198 | -85x | +1140x |
- df_tte <- data.frame(tte = tte, is_event = is_event)+ mean_ci_3d <- c(y$mean, y$mean_ci) |
| 199 | -85x | +1140x |
- strata_vars <- NULL+ y$mean_ci_3d <- formatters::with_label(mean_ci_3d, paste0("Mean (", f_conf_level(control$conf_level), ")"))
|
| 201 | -85x | +1140x |
- if (!is.null(strata_data)) {
+ mean_pval <- stat_mean_pval(x, test_mean = control$test_mean, na.rm = FALSE, n_min = 2) |
| 202 | -5x | +1140x |
- if (is.data.frame(strata_data)) {
+ y$mean_pval <- formatters::with_label(mean_pval, paste("Mean", f_pval(control$test_mean)))
|
| 203 | -4x | +
- strata_vars <- names(strata_data)+ |
|
| 204 | -4x | +1140x |
- checkmate::assert_data_frame(strata_data, nrows = nrow(df_tte))+ y$median <- c("median" = stats::median(x, na.rm = FALSE))
|
| 205 | -4x | +
- assert_df_with_factors(strata_data, as.list(stats::setNames(strata_vars, strata_vars)))+ |
|
| 206 | -+ | 1140x |
- } else {
+ y$mad <- c("mad" = stats::median(x - y$median, na.rm = FALSE))
|
| 207 | -1x | +
- assert_valid_factor(strata_data, len = nrow(df_tte))+ |
|
| 208 | -1x | +1140x |
- strata_vars <- "strata_data"+ median_ci <- stat_median_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE) |
| 209 | -+ | 1140x |
- }+ y$median_ci <- formatters::with_label(median_ci, paste("Median", f_conf_level(control$conf_level)))
|
| 210 | -5x | +
- df_tte[strata_vars] <- strata_data+ |
|
| 211 | -+ | 1140x |
- }+ median_ci_3d <- c(y$median, median_ci) |
| 212 | -+ | 1140x |
-
+ y$median_ci_3d <- formatters::with_label(median_ci_3d, paste0("Median (", f_conf_level(control$conf_level), ")"))
|
| 213 | -85x | +
- l_df <- split(df_tte, arm)+ |
|
| 214 | -+ | 1140x |
-
+ q <- control$quantiles |
| 215 | -85x | +1140x |
- if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
+ if (any(is.na(x))) {
|
| 216 | -+ | 2x |
- # Hazard ratio and CI.+ qnts <- rep(NA_real_, length(q)) |
| 217 | -79x | +
- result <- s_coxph_pairwise(+ } else {
|
|
| 218 | -79x | +1138x |
- df = l_df[[2]],+ qnts <- stats::quantile(x, probs = q, type = control$quantile_type, na.rm = FALSE) |
| 219 | -79x | +
- .ref_group = l_df[[1]],+ } |
|
| 220 | -79x | +1140x |
- .in_ref_col = FALSE,+ names(qnts) <- paste("quantile", q, sep = "_")
|
| 221 | -79x | +1140x |
- .var = "tte",+ y$quantiles <- formatters::with_label(qnts, paste0(paste(paste0(q * 100, "%"), collapse = " and "), "-ile")) |
| 222 | -79x | +
- is_event = "is_event",+ |
|
| 223 | -79x | +1140x |
- strata = strata_vars,+ y$iqr <- c("iqr" = ifelse(
|
| 224 | -79x | +1140x |
- control = control+ any(is.na(x)), |
| 225 | -+ | 1140x |
- )+ NA_real_, |
| 226 | -+ | 1140x |
-
+ stats::IQR(x, na.rm = FALSE, type = control$quantile_type) |
| 227 | -79x | +
- df <- data.frame(+ )) |
|
| 228 |
- # Dummy column needed downstream to create a nested header.+ |
||
| 229 | -79x | +1140x |
- arm = " ",+ y$range <- stats::setNames(range_noinf(x, na.rm = FALSE), c("min", "max"))
|
| 230 | -79x | +1140x |
- n_tot = unname(as.numeric(result$n_tot)),+ y$min <- y$range[1] |
| 231 | -79x | +1140x |
- n_tot_events = unname(as.numeric(result$n_tot_events)),+ y$max <- y$range[2] |
| 232 | -79x | +
- hr = unname(as.numeric(result$hr)),+ |
|
| 233 | -79x | +1140x |
- lcl = unname(result$hr_ci[1]),+ y$median_range <- formatters::with_label(c(y$median, y$range), "Median (Min - Max)") |
| 234 | -79x | +
- ucl = unname(result$hr_ci[2]),+ |
|
| 235 | -79x | +1140x |
- conf_level = control[["conf_level"]],+ y$cv <- c("cv" = unname(y$sd) / unname(y$mean) * 100)
|
| 236 | -79x | +
- pval = as.numeric(result$pvalue),+ |
|
| 237 | -79x | +
- pval_label = obj_label(result$pvalue),+ # Convert negative values to NA for log calculation. |
|
| 238 | -79x | +1140x |
- stringsAsFactors = FALSE+ x_no_negative_vals <- x |
| 239 | -+ | 1140x |
- )+ x_no_negative_vals[x_no_negative_vals <= 0] <- NA |
| 240 | -+ | 1140x |
- } else if (+ y$geom_mean <- c("geom_mean" = exp(mean(log(x_no_negative_vals), na.rm = FALSE)))
|
| 241 | -6x | +1140x |
- (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) ||+ geom_mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE, geom_mean = TRUE) |
| 242 | -6x | +1140x |
- (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0)+ y$geom_mean_ci <- formatters::with_label(geom_mean_ci, paste("Geometric Mean", f_conf_level(control$conf_level)))
|
| 243 |
- ) {
+
|
||
| 244 | -6x | +1140x |
- df_tte_complete <- df_tte[stats::complete.cases(df_tte), ]+ y$geom_cv <- c("geom_cv" = sqrt(exp(stats::sd(log(x_no_negative_vals), na.rm = FALSE) ^ 2) - 1) * 100) # styler: off
|
| 245 | -6x | +
- df <- data.frame(+ |
|
| 246 | -+ | 1140x |
- # Dummy column needed downstream to create a nested header.+ geom_mean_ci_3d <- c(y$geom_mean, y$geom_mean_ci) |
| 247 | -6x | +1140x |
- arm = " ",+ y$geom_mean_ci_3d <- formatters::with_label( |
| 248 | -6x | +1140x |
- n_tot = nrow(df_tte_complete),+ geom_mean_ci_3d, |
| 249 | -6x | +1140x |
- n_tot_events = sum(df_tte_complete$is_event),+ paste0("Geometric Mean (", f_conf_level(control$conf_level), ")")
|
| 250 | -6x | +
- hr = NA,+ ) |
|
| 251 | -6x | +
- lcl = NA,+ |
|
| 252 | -6x | +
- ucl = NA,+ # Compare with reference group |
|
| 253 | -6x | +1140x |
- conf_level = control[["conf_level"]],+ if (isTRUE(compare_with_ref_group)) {
|
| 254 | -6x | +13x |
- pval = NA,+ .ref_group <- args_list[[".ref_group"]] |
| 255 | -6x | +13x |
- pval_label = NA,+ .in_ref_col <- args_list[[".in_ref_col"]] |
| 256 | -6x | +13x |
- stringsAsFactors = FALSE+ checkmate::assert_numeric(.ref_group) |
| 257 | -+ | 13x |
- )+ checkmate::assert_flag(.in_ref_col) |
| 258 |
- } else {
+
|
||
| 259 | -! | +13x |
- df <- data.frame(+ y$pval <- character() |
| 260 | -+ | 13x |
- # Dummy column needed downstream to create a nested header.+ if (!.in_ref_col && n_available(x) > 1 && n_available(.ref_group) > 1) {
|
| 261 | -! | +9x |
- arm = " ",+ y$pval <- stats::t.test(x, .ref_group)$p.value |
| 262 | -! | +
- n_tot = 0L,+ } |
|
| 263 | -! | +
- n_tot_events = 0L,+ } |
|
| 264 | -! | +
- hr = NA,+ |
|
| 265 | -! | +1140x |
- lcl = NA,+ y |
| 266 | -! | +
- ucl = NA,+ } |
|
| 267 | -! | +
- conf_level = control[["conf_level"]],+ |
|
| 268 | -! | +
- pval = NA,+ #' @describeIn analyze_variables Method for `factor` class. |
|
| 269 | -! | +
- pval_label = NA,+ #' |
|
| 270 | -! | +
- stringsAsFactors = FALSE+ #' @return |
|
| 271 |
- )+ #' * If `x` is of class `factor` or converted from `character`, returns a `list` with named `numeric` items: |
||
| 272 |
- }+ #' * `n`: The [length()] of `x`. |
||
| 273 |
-
+ #' * `count`: A list with the number of cases for each level of the factor `x`. |
||
| 274 | -85x | +
- df+ #' * `count_fraction`: Similar to `count` but also includes the proportion of cases for each level of the |
|
| 275 |
- }+ #' factor `x` relative to the denominator, or `NA` if the denominator is zero. |
||
| 276 |
-
+ #' |
||
| 277 |
- #' @describeIn h_survival_duration_subgroups Summarizes estimates of the treatment hazard ratio+ #' @note |
||
| 278 |
- #' across subgroups in a data frame. `variables` corresponds to the names of variables found in+ #' * If `x` is an empty `factor`, a list is still returned for `counts` with one element |
||
| 279 |
- #' `data`, passed as a named list and requires elements `tte`, `is_event`, `arm` and+ #' per factor level. If there are no levels in `x`, the function fails. |
||
| 280 |
- #' optionally `subgroups` and `strata`. `groups_lists` optionally specifies+ #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values |
||
| 281 |
- #' groupings for `subgroups` variables.+ #' set `na_rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit |
||
| 282 |
- #'+ #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the |
||
| 283 |
- #' @return+ #' default `na_level` (`"<Missing>"`) will also be excluded when `na_rm` is set to `TRUE`. |
||
| 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`.+ #' @method s_summary factor |
||
| 288 |
- #' # Extract hazard ratio for multiple groups.+ #' # `s_summary.factor` |
||
| 289 |
- #' h_coxph_subgroups_df(+ #' |
||
| 290 |
- #' variables = list(+ #' ## Basic usage: |
||
| 291 |
- #' tte = "AVAL",+ #' s_summary(factor(c("a", "a", "b", "c", "a")))
|
||
| 292 |
- #' is_event = "is_event",+ #' |
||
| 293 |
- #' arm = "ARM",+ #' # Empty factor returns zero-filled items. |
||
| 294 |
- #' subgroups = c("SEX", "BMRKR2")
+ #' s_summary(factor(levels = c("a", "b", "c")))
|
||
| 295 |
- #' ),+ #' |
||
| 296 |
- #' data = adtte_f+ #' ## Management of NA values. |
||
| 297 |
- #' )+ #' x <- factor(c(NA, "Female")) |
||
| 298 |
- #'+ #' x <- explicit_na(x) |
||
| 299 |
- #' # Define groupings of BMRKR2 levels.+ #' s_summary(x, na_rm = TRUE) |
||
| 300 |
- #' h_coxph_subgroups_df(+ #' s_summary(x, na_rm = FALSE) |
||
| 301 |
- #' variables = list(+ #' |
||
| 302 |
- #' tte = "AVAL",+ #' ## Different denominators. |
||
| 303 |
- #' is_event = "is_event",+ #' x <- factor(c("a", "a", "b", "c", "a"))
|
||
| 304 |
- #' arm = "ARM",+ #' s_summary(x, denom = "N_row", .N_row = 10L) |
||
| 305 |
- #' subgroups = c("SEX", "BMRKR2")
+ #' s_summary(x, denom = "N_col", .N_col = 20L) |
||
| 306 |
- #' ),+ #' |
||
| 307 |
- #' data = adtte_f,+ #' @export |
||
| 308 |
- #' groups_lists = list(+ s_summary.factor <- function(x, denom = c("n", "N_col", "N_row"), ...) {
|
||
| 309 | -+ | 304x |
- #' BMRKR2 = list(+ assert_valid_factor(x) |
| 310 | -+ | 301x |
- #' "low" = "LOW",+ args_list <- list(...) |
| 311 | -+ | 301x |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ .N_row <- args_list[[".N_row"]] # nolint |
| 312 | -+ | 301x |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ .N_col <- args_list[[".N_col"]] # nolint |
| 313 | -+ | 301x |
- #' )+ na_rm <- args_list[["na_rm"]] %||% TRUE |
| 314 | -+ | 301x |
- #' )+ verbose <- args_list[["verbose"]] %||% TRUE |
| 315 | -+ | 301x |
- #' )+ compare_with_ref_group <- args_list[["compare_with_ref_group"]] |
| 316 |
- #'+ |
||
| 317 | -+ | 301x |
- #' # Extract hazard ratio for multiple groups with stratification factors.+ if (na_rm) {
|
| 318 | -+ | 292x |
- #' h_coxph_subgroups_df(+ x <- x[!is.na(x)] %>% fct_discard("<Missing>")
|
| 319 |
- #' variables = list(+ } else {
|
||
| 320 | -+ | 9x |
- #' tte = "AVAL",+ x <- x %>% explicit_na(label = "NA") |
| 321 |
- #' is_event = "is_event",+ } |
||
| 322 |
- #' arm = "ARM",+ |
||
| 323 | -+ | 301x |
- #' subgroups = c("SEX", "BMRKR2"),
+ y <- list() |
| 324 |
- #' strata = c("STRATA1", "STRATA2")
+
|
||
| 325 | -+ | 301x |
- #' ),+ y$n <- list("n" = c("n" = length(x))) # all list of a list
|
| 326 |
- #' data = adtte_f+ |
||
| 327 | -+ | 301x |
- #' )+ y$count <- lapply(as.list(table(x, useNA = "ifany")), setNames, nm = "count") |
| 328 |
- #'+ |
||
| 329 | -+ | 301x |
- #' @export+ denom <- match.arg(denom) %>% |
| 330 | -+ | 301x |
- h_coxph_subgroups_df <- function(variables,+ switch( |
| 331 | -+ | 301x |
- data,+ n = length(x), |
| 332 | -+ | 301x |
- groups_lists = list(),+ N_row = .N_row, |
| 333 | -+ | 301x |
- control = control_coxph(),+ N_col = .N_col |
| 334 |
- label_all = "All Patients") {
+ ) |
||
| 335 | -17x | +
- if ("strat" %in% names(variables)) {
+
|
|
| 336 | -! | +301x |
- warning(+ y$count_fraction <- lapply( |
| 337 | -! | +301x |
- "Warning: the `strat` element name of the `variables` list argument to `h_coxph_subgroups_df() ",+ y$count, |
| 338 | -! | +301x |
- "was deprecated in tern 0.9.4.\n ",+ function(x) {
|
| 339 | -! | +2182x |
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ c(x, "p" = ifelse(denom > 0, x / denom, 0)) |
| 340 |
- )+ } |
||
| 341 | -! | +
- variables[["strata"]] <- variables[["strat"]]+ ) |
|
| 342 |
- }+ |
||
| 343 | -+ | 301x |
-
+ y$count_fraction_fixed_dp <- y$count_fraction |
| 344 | -17x | +
- checkmate::assert_character(variables$tte)+ |
|
| 345 | -17x | +301x |
- checkmate::assert_character(variables$is_event)+ y$fraction <- lapply( |
| 346 | -17x | +301x |
- checkmate::assert_character(variables$arm)+ y$count, |
| 347 | -17x | +301x |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ function(count) c("num" = unname(count), "denom" = denom)
|
| 348 | -17x | +
- checkmate::assert_character(variables$strata, null.ok = TRUE)+ ) |
|
| 349 | -17x | +
- assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ |
|
| 350 | -17x | +301x |
- assert_df_with_variables(data, variables)+ y$n_blq <- list("n_blq" = c("n_blq" = sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", x))))
|
| 351 | -17x | +
- checkmate::assert_string(label_all)+ |
|
| 353 | -+ | 301x |
- # Add All Patients.+ if (isTRUE(compare_with_ref_group)) {
|
| 354 | -17x | +16x |
- result_all <- h_coxph_df(+ .ref_group <- as_factor_keep_attributes(args_list[[".ref_group"]], verbose = verbose) |
| 355 | -17x | +16x |
- tte = data[[variables$tte]],+ .in_ref_col <- args_list[[".in_ref_col"]] |
| 356 | -17x | +16x |
- is_event = data[[variables$is_event]],+ checkmate::assert_flag(.in_ref_col) |
| 357 | -17x | +16x |
- arm = data[[variables$arm]],+ assert_valid_factor(x) |
| 358 | -17x | +16x |
- strata_data = if (is.null(variables$strata)) NULL else data[variables$strata],+ assert_valid_factor(.ref_group) |
| 359 | -17x | +
- control = control+ |
|
| 360 | -+ | 16x |
- )+ if (na_rm) {
|
| 361 | -17x | +14x |
- result_all$subgroup <- label_all+ x <- x[!is.na(x)] %>% fct_discard("<Missing>")
|
| 362 | -17x | +14x |
- result_all$var <- "ALL"+ .ref_group <- .ref_group[!is.na(.ref_group)] %>% fct_discard("<Missing>")
|
| 363 | -17x | +
- result_all$var_label <- label_all+ } else {
|
|
| 364 | -17x | +2x |
- result_all$row_type <- "content"+ x <- x %>% explicit_na(label = "NA") |
| 365 | -+ | 2x |
-
+ .ref_group <- .ref_group %>% explicit_na(label = "NA") |
| 366 |
- # Add Subgroups.+ } |
||
| 367 | -17x | +
- if (is.null(variables$subgroups)) {
+
|
|
| 368 | -3x | +1x |
- result_all+ if ("NA" %in% levels(x)) levels(.ref_group) <- c(levels(.ref_group), "NA")
|
| 369 | -+ | 16x |
- } else {
+ checkmate::assert_factor(x, levels = levels(.ref_group), min.levels = 2) |
| 370 | -14x | +
- l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ |
|
| 371 | -+ | 16x |
-
+ y$pval_counts <- character() |
| 372 | -14x | +16x |
- l_result <- lapply(l_data, function(grp) {
+ if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
|
| 373 | -64x | +13x |
- result <- h_coxph_df(+ tab <- rbind(table(x), table(.ref_group)) |
| 374 | -64x | +13x |
- tte = grp$df[[variables$tte]],+ res <- suppressWarnings(stats::chisq.test(tab)) |
| 375 | -64x | +13x |
- is_event = grp$df[[variables$is_event]],+ y$pval_counts <- res$p.value |
| 376 | -64x | +
- arm = grp$df[[variables$arm]],+ } |
|
| 377 | -64x | +
- strata_data = if (is.null(variables$strata)) NULL else grp$df[variables$strata],+ } |
|
| 378 | -64x | +
- control = control+ |
|
| 379 | -+ | 301x |
- )+ y |
| 380 | -64x | +
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ } |
|
| 381 | -64x | +
- cbind(result, result_labels)+ |
|
| 382 |
- })+ #' @describeIn analyze_variables Method for `character` class. This makes an automatic |
||
| 383 |
-
+ #' conversion to factor (with a warning) and then forwards to the method for factors. |
||
| 384 | -14x | +
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ #' |
|
| 385 | -14x | +
- result_subgroups$row_type <- "analysis"+ #' @note |
|
| 386 |
-
+ #' * Automatic conversion of character to factor does not guarantee that the table |
||
| 387 | -14x | +
- rbind(+ #' can be generated correctly. In particular for sparse tables this very likely can fail. |
|
| 388 | -14x | +
- result_all,+ #' It is therefore better to always pre-process the dataset such that factors are manually |
|
| 389 | -14x | +
- result_subgroups+ #' created from character variables before passing the dataset to [rtables::build_table()]. |
|
| 390 |
- )+ #' |
||
| 391 |
- }+ #' @method s_summary character |
||
| 392 |
- }+ #' |
||
| 393 |
-
+ #' @examples |
||
| 394 |
- #' Split data frame by subgroups+ #' # `s_summary.character` |
||
| 396 |
- #' @description `r lifecycle::badge("stable")`
+ #' ## Basic usage: |
||
| 397 |
- #'+ #' s_summary(c("a", "a", "b", "c", "a"), verbose = FALSE)
|
||
| 398 |
- #' Split a data frame into a non-nested list of subsets.+ #' s_summary(c("a", "a", "b", "c", "a", ""), .var = "x", na_rm = FALSE, verbose = FALSE)
|
||
| 400 |
- #' @inheritParams argument_convention+ #' @export |
||
| 401 |
- #' @inheritParams survival_duration_subgroups+ s_summary.character <- function(x, denom = c("n", "N_col", "N_row"), ...) {
|
||
| 402 | -+ | 12x |
- #' @param data (`data.frame`)\cr dataset to split.+ args_list <- list(...) |
| 403 | -+ | 12x |
- #' @param subgroups (`character`)\cr names of factor variables from `data` used to create subsets.+ na_rm <- args_list[["na_rm"]] %||% TRUE |
| 404 | -+ | 12x |
- #' Unused levels not present in `data` are dropped. Note that the order in this vector+ verbose <- args_list[["verbose"]] %||% TRUE |
| 405 |
- #' determines the order in the downstream table.+ |
||
| 406 | -+ | 12x |
- #'+ if (na_rm) {
|
| 407 | -+ | 11x |
- #' @return A list with subset data (`df`) and metadata about the subset (`df_labels`).+ y <- as_factor_keep_attributes(x, verbose = verbose) |
| 408 |
- #'+ } else {
|
||
| 409 | -+ | 1x |
- #' @details Main functionality is to prepare data for use in forest plot layouts.+ y <- as_factor_keep_attributes(x, verbose = verbose, na_level = "NA") |
| 410 |
- #'+ } |
||
| 411 |
- #' @examples+ |
||
| 412 | -+ | 12x |
- #' df <- data.frame(+ s_summary(x = y, denom = denom, ...) |
| 413 |
- #' x = c(1:5),+ } |
||
| 414 |
- #' y = factor(c("A", "B", "A", "B", "A"), levels = c("A", "B", "C")),
+
|
||
| 415 |
- #' z = factor(c("C", "C", "D", "D", "D"), levels = c("D", "C"))
+ #' @describeIn analyze_variables Method for `logical` class. |
||
| 416 |
- #' )+ #' |
||
| 417 |
- #' formatters::var_labels(df) <- paste("label for", names(df))
+ #' @return |
||
| 418 |
- #'+ #' * If `x` is of class `logical`, returns a `list` with named `numeric` items: |
||
| 419 |
- #' h_split_by_subgroups(+ #' * `n`: The [length()] of `x` (possibly after removing `NA`s). |
||
| 420 |
- #' data = df,+ #' * `count`: Count of `TRUE` in `x`. |
||
| 421 |
- #' subgroups = c("y", "z")
+ #' * `count_fraction`: Count and proportion of `TRUE` in `x` relative to the denominator, or `NA` if the |
||
| 422 |
- #' )+ #' denominator is zero. Note that `NA`s in `x` are never counted or leading to `NA` here. |
||
| 424 |
- #' h_split_by_subgroups(+ #' @method s_summary logical |
||
| 425 |
- #' data = df,+ #' |
||
| 426 |
- #' subgroups = c("y", "z"),
+ #' @examples |
||
| 427 |
- #' groups_lists = list(+ #' # `s_summary.logical` |
||
| 428 |
- #' y = list("AB" = c("A", "B"), "C" = "C")
+ #' |
||
| 429 |
- #' )+ #' ## Basic usage: |
||
| 430 |
- #' )+ #' s_summary(c(TRUE, FALSE, TRUE, TRUE)) |
||
| 432 |
- #' @export+ #' # Empty factor returns zero-filled items. |
||
| 433 |
- h_split_by_subgroups <- function(data,+ #' s_summary(as.logical(c())) |
||
| 434 |
- subgroups,+ #' |
||
| 435 |
- groups_lists = list()) {
+ #' ## Management of NA values. |
||
| 436 | -66x | +
- checkmate::assert_character(subgroups, min.len = 1, any.missing = FALSE)+ #' x <- c(NA, TRUE, FALSE) |
|
| 437 | -66x | +
- checkmate::assert_list(groups_lists, names = "named")+ #' s_summary(x, na_rm = TRUE) |
|
| 438 | -66x | +
- checkmate::assert_subset(names(groups_lists), subgroups)+ #' s_summary(x, na_rm = FALSE) |
|
| 439 | -66x | +
- assert_df_with_factors(data, as.list(stats::setNames(subgroups, subgroups)))+ #' |
|
| 440 |
-
+ #' ## Different denominators. |
||
| 441 | -66x | +
- data_labels <- unname(formatters::var_labels(data))+ #' x <- c(TRUE, FALSE, TRUE, TRUE) |
|
| 442 | -66x | +
- df_subgroups <- data[, subgroups, drop = FALSE]+ #' s_summary(x, denom = "N_row", .N_row = 10L) |
|
| 443 | -66x | +
- subgroup_labels <- formatters::var_labels(df_subgroups, fill = TRUE)+ #' s_summary(x, denom = "N_col", .N_col = 20L) |
|
| 444 |
-
+ #' |
||
| 445 | -66x | +
- l_labels <- Map(function(grp_i, name_i) {
+ #' @export |
|
| 446 | -120x | +
- existing_levels <- levels(droplevels(grp_i))+ s_summary.logical <- function(x, denom = c("n", "N_col", "N_row"), ...) {
|
|
| 447 | -120x | +211x |
- grp_levels <- if (name_i %in% names(groups_lists)) {
+ checkmate::assert_logical(x) |
| 448 | -+ | 211x |
- # For this variable groupings are defined. We check which groups are contained in the data.+ args_list <- list(...) |
| 449 | -11x | +211x |
- group_list_i <- groups_lists[[name_i]]+ .N_row <- args_list[[".N_row"]] # nolint |
| 450 | -11x | +211x |
- group_has_levels <- vapply(group_list_i, function(lvls) any(lvls %in% existing_levels), TRUE)+ .N_col <- args_list[[".N_col"]] # nolint |
| 451 | -11x | +211x |
- names(which(group_has_levels))+ na_rm <- args_list[["na_rm"]] %||% TRUE |
| 452 | -+ | 211x |
- } else {
+ compare_with_ref_group <- args_list[["compare_with_ref_group"]] |
| 453 | -109x | +
- existing_levels+ |
|
| 454 | -+ | 211x |
- }+ if (na_rm) {
|
| 455 | -120x | +208x |
- df_labels <- data.frame(+ x <- x[!is.na(x)] |
| 456 | -120x | +
- subgroup = grp_levels,+ } |
|
| 457 | -120x | +
- var = name_i,+ |
|
| 458 | -120x | +211x |
- var_label = unname(subgroup_labels[name_i]),+ y <- list() |
| 459 | -120x | +211x |
- stringsAsFactors = FALSE # Rationale is that subgroups may not be unique.+ y$n <- c("n" = length(x))
|
| 460 | -+ | 211x |
- )+ denom <- match.arg(denom) %>% |
| 461 | -66x | +211x |
- }, df_subgroups, names(df_subgroups))+ switch( |
| 462 | -+ | 211x |
-
+ n = length(x), |
| 463 | -+ | 211x |
- # Create a data frame with one row per subgroup.+ N_row = .N_row, |
| 464 | -66x | +211x |
- df_labels <- do.call(rbind, args = c(l_labels, make.row.names = FALSE))+ N_col = .N_col |
| 465 | -66x | +
- row_label <- paste0(df_labels$var, ".", df_labels$subgroup)+ ) |
|
| 466 | -66x | +211x |
- row_split_var <- factor(row_label, levels = row_label)+ y$count <- c("count" = sum(x, na.rm = TRUE))
|
| 467 | -+ | 211x |
-
+ y$count_fraction <- c(y$count, "fraction" = ifelse(denom > 0, y$count / denom, 0)) |
| 468 | -+ | 211x |
- # Create a list of data subsets.+ y$count_fraction_fixed_dp <- y$count_fraction |
| 469 | -66x | +211x |
- lapply(split(df_labels, row_split_var), function(row_i) {
+ y$fraction <- c("num" = unname(y$count), "denom" = denom)
|
| 470 | -294x | +211x |
- which_row <- if (row_i$var %in% names(groups_lists)) {
+ y$n_blq <- c("n_blq" = 0L)
|
| 471 | -31x | +
- data[[row_i$var]] %in% groups_lists[[row_i$var]][[row_i$subgroup]]+ |
|
| 472 |
- } else {
+
|
||
| 473 | -263x | +211x |
- data[[row_i$var]] == row_i$subgroup+ if (isTRUE(compare_with_ref_group)) {
|
| 474 | -+ | 4x |
- }+ .ref_group <- args_list[[".ref_group"]] |
| 475 | -294x | +4x |
- df <- data[which_row, ]+ .in_ref_col <- args_list[[".in_ref_col"]] |
| 476 | -294x | +4x |
- rownames(df) <- NULL+ checkmate::assert_flag(.in_ref_col) |
| 477 | -294x | +
- formatters::var_labels(df) <- data_labels+ |
|
| 478 | -+ | 4x |
-
+ if (na_rm) {
|
| 479 | -294x | +3x |
- list(+ x <- stats::na.omit(x) |
| 480 | -294x | +3x |
- df = df,+ .ref_group <- stats::na.omit(.ref_group) |
| 481 | -294x | +
- df_labels = data.frame(row_i, row.names = NULL)+ } else {
|
|
| 482 | +1x | +
+ x[is.na(x)] <- FALSE+ |
+ |
| 483 | +1x | +
+ .ref_group[is.na(.ref_group)] <- FALSE+ |
+ |
| 484 |
- )+ } |
||
| 483 | +485 |
- })+ + |
+ |
| 486 | +4x | +
+ y$pval_counts <- character()+ |
+ |
| 487 | +4x | +
+ if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
+ |
+ |
| 488 | +4x | +
+ x <- factor(x, levels = c(TRUE, FALSE))+ |
+ |
| 489 | +4x | +
+ .ref_group <- factor(.ref_group, levels = c(TRUE, FALSE))+ |
+ |
| 490 | +4x | +
+ tbl <- rbind(table(x), table(.ref_group))+ |
+ |
| 491 | +4x | +
+ y$pval_counts <- suppressWarnings(prop_chisq(tbl)) |
|
| 484 | +492 |
- }+ } |
| 1 | +493 |
- #' Create a STEP graph+ } |
||
| 2 | +494 |
- #'+ + |
+ ||
| 495 | +211x | +
+ y |
||
| 3 | +496 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 4 | +497 |
- #'+ |
||
| 5 | +498 |
- #' Based on the STEP results, creates a `ggplot` graph showing the estimated HR or OR+ #' @describeIn analyze_variables Formatted analysis function which is used as `afun` in `analyze_vars()` and |
||
| 6 | +499 |
- #' along the continuous biomarker value subgroups.+ #' `compare_vars()` and as `cfun` in `summarize_colvars()`. |
||
| 7 | +500 |
#' |
||
| 8 | +501 |
- #' @param df (`tibble`)\cr result of [tidy.step()].+ #' @param compare_with_ref_group (`flag`)\cr whether comparison statistics should be analyzed instead of summary |
||
| 9 | +502 |
- #' @param use_percentile (`flag`)\cr whether to use percentiles for the x axis or actual+ #' statistics (`compare_with_ref_group = TRUE` adds `pval` statistic comparing |
||
| 10 | +503 |
- #' biomarker values.+ #' against reference group). |
||
| 11 | +504 |
- #' @param est (named `list`)\cr `col` and `lty` settings for estimate line.+ #' |
||
| 12 | +505 |
- #' @param ci_ribbon (named `list` or `NULL`)\cr `fill` and `alpha` settings for the confidence interval+ #' @return |
||
| 13 | +506 |
- #' ribbon area, or `NULL` to not plot a CI ribbon.+ #' * `a_summary()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 14 | +507 |
- #' @param col (`character`)\cr color(s).+ #' |
||
| 15 | +508 |
- #'+ #' @note |
||
| 16 | +509 |
- #' @return A `ggplot` STEP graph.+ #' * To use for comparison (with additional p-value statistic), parameter |
||
| 17 | +510 |
- #'+ #' `compare_with_ref_group` must be set to `TRUE`. |
||
| 18 | +511 |
- #' @seealso Custom tidy method [tidy.step()].+ #' * Ensure that either all `NA` values are converted to an explicit `NA` level or all `NA` values are left as is. |
||
| 19 | +512 |
#' |
||
| 20 | +513 | ++ |
+ #' @examples+ |
+ |
| 514 | ++ |
+ #' a_summary(factor(c("a", "a", "b", "c", "a")), .N_row = 10, .N_col = 10)
+ |
+ ||
| 515 |
- #' @examples+ #' a_summary( |
|||
| 21 | +516 |
- #' library(survival)+ #' factor(c("a", "a", "b", "c", "a")),
|
||
| 22 | +517 |
- #' lung$sex <- factor(lung$sex)+ #' .ref_group = factor(c("a", "a", "b", "c")), compare_with_ref_group = TRUE, .in_ref_col = TRUE
|
||
| 23 | +518 |
- #'+ #' ) |
||
| 24 | +519 |
- #' # Survival example.+ #' |
||
| 25 | +520 |
- #' vars <- list(+ #' a_summary(c("A", "B", "A", "C"), .var = "x", .N_col = 10, .N_row = 10, verbose = FALSE)
|
||
| 26 | +521 |
- #' time = "time",+ #' a_summary( |
||
| 27 | +522 |
- #' event = "status",+ #' c("A", "B", "A", "C"),
|
||
| 28 | +523 |
- #' arm = "sex",+ #' .ref_group = c("B", "A", "C"), .var = "x", compare_with_ref_group = TRUE, verbose = FALSE,
|
||
| 29 | +524 |
- #' biomarker = "age"+ #' .in_ref_col = FALSE |
||
| 30 | +525 |
#' ) |
||
| 31 | +526 |
#' |
||
| 32 | +527 |
- #' step_matrix <- fit_survival_step(+ #' a_summary(c(TRUE, FALSE, FALSE, TRUE, TRUE), .N_row = 10, .N_col = 10) |
||
| 33 | +528 |
- #' variables = vars,+ #' a_summary( |
||
| 34 | +529 |
- #' data = lung,+ #' c(TRUE, FALSE, FALSE, TRUE, TRUE), |
||
| 35 | +530 |
- #' control = c(control_coxph(), control_step(num_points = 10, degree = 2))+ #' .ref_group = c(TRUE, FALSE), .in_ref_col = TRUE, compare_with_ref_group = TRUE, |
||
| 36 | +531 |
- #' )+ #' .in_ref_col = FALSE |
||
| 37 | +532 |
- #' step_data <- broom::tidy(step_matrix)+ #' ) |
||
| 38 | +533 |
#' |
||
| 39 | +534 |
- #' # Default plot.+ #' a_summary(rnorm(10), .N_col = 10, .N_row = 20, .var = "bla") |
||
| 40 | +535 |
- #' g_step(step_data)+ #' a_summary(rnorm(10, 5, 1), |
||
| 41 | +536 |
- #'+ #' .ref_group = rnorm(20, -5, 1), .var = "bla", compare_with_ref_group = TRUE, |
||
| 42 | +537 |
- #' # Add the reference 1 horizontal line.+ #' .in_ref_col = FALSE |
||
| 43 | +538 |
- #' library(ggplot2)+ #' ) |
||
| 44 | +539 |
- #' g_step(step_data) ++ #' |
||
| 45 | +540 |
- #' ggplot2::geom_hline(ggplot2::aes(yintercept = 1), linetype = 2)+ #' @export |
||
| 46 | +541 |
- #'+ a_summary <- function(x, |
||
| 47 | +542 |
- #' # Use actual values instead of percentiles, different color for estimate and no CI,+ ..., |
||
| 48 | +543 |
- #' # use log scale for y axis.+ .stats = NULL, |
||
| 49 | +544 |
- #' g_step(+ .stat_names = NULL, |
||
| 50 | +545 |
- #' step_data,+ .formats = NULL, |
||
| 51 | +546 |
- #' use_percentile = FALSE,+ .labels = NULL, |
||
| 52 | +547 |
- #' est = list(col = "blue", lty = 1),+ .indent_mods = NULL) {
|
||
| 53 | -+ | |||
| 548 | +329x |
- #' ci_ribbon = NULL+ dots_extra_args <- list(...) |
||
| 54 | +549 |
- #' ) + scale_y_log10()+ |
||
| 55 | +550 |
- #'+ # Check if there are user-defined functions |
||
| 56 | -+ | |||
| 551 | +329x |
- #' # Adding another curve based on additional column.+ default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) |
||
| 57 | -+ | |||
| 552 | +329x |
- #' step_data$extra <- exp(step_data$`Percentile Center`)+ .stats <- default_and_custom_stats_list$default_stats |
||
| 58 | -+ | |||
| 553 | +329x |
- #' g_step(step_data) ++ custom_stat_functions <- default_and_custom_stats_list$custom_stats |
||
| 59 | +554 |
- #' ggplot2::geom_line(ggplot2::aes(y = extra), linetype = 2, color = "green")+ |
||
| 60 | +555 |
- #'+ # Correction of the pval indication if it is numeric or counts |
||
| 61 | -+ | |||
| 556 | +329x |
- #' # Response example.+ type <- ifelse(is.numeric(x), "numeric", "counts") # counts is "categorical" |
||
| 62 | -+ | |||
| 557 | +329x |
- #' vars <- list(+ .stats <- .correct_num_or_counts_pval(type, .stats) |
||
| 63 | +558 |
- #' response = "status",+ |
||
| 64 | +559 |
- #' arm = "sex",+ # Adding automatically extra parameters to the statistic function (see ?rtables::additional_fun_params) |
||
| 65 | -+ | |||
| 560 | +329x |
- #' biomarker = "age"+ extra_afun_params <- retrieve_extra_afun_params( |
||
| 66 | -+ | |||
| 561 | +329x |
- #' )+ names(dots_extra_args$.additional_fun_parameters) |
||
| 67 | +562 |
- #'+ ) |
||
| 68 | -+ | |||
| 563 | +329x |
- #' step_matrix <- fit_rsp_step(+ dots_extra_args$.additional_fun_parameters <- NULL # After extraction we do not need them anymore |
||
| 69 | +564 |
- #' variables = vars,+ |
||
| 70 | +565 |
- #' data = lung,+ # Check if compare_with_ref_group is TRUE but no ref col is set |
||
| 71 | -+ | |||
| 566 | +329x |
- #' control = c(+ if (isTRUE(dots_extra_args$compare_with_ref_group) && |
||
| 72 | -+ | |||
| 567 | +329x |
- #' control_logistic(response_definition = "I(response == 2)"),+ all( |
||
| 73 | -+ | |||
| 568 | +329x |
- #' control_step()+ length(dots_extra_args[[".ref_group"]]) == 0, # only used for testing |
||
| 74 | -+ | |||
| 569 | +329x |
- #' )+ length(extra_afun_params[[".ref_group"]]) == 0 |
||
| 75 | +570 |
- #' )+ ) |
||
| 76 | +571 |
- #' step_data <- broom::tidy(step_matrix)+ ) {
|
||
| 77 | -+ | |||
| 572 | +! |
- #' g_step(step_data)+ stop( |
||
| 78 | -+ | |||
| 573 | +! |
- #'+ "For comparison (compare_with_ref_group = TRUE), the reference group must be specified.", |
||
| 79 | -+ | |||
| 574 | +! |
- #' @export+ "\nSee ref_group in split_cols_by()." |
||
| 80 | +575 |
- g_step <- function(df,+ ) |
||
| 81 | +576 |
- use_percentile = "Percentile Center" %in% names(df),+ } |
||
| 82 | +577 |
- est = list(col = "blue", lty = 1),+ |
||
| 83 | +578 |
- ci_ribbon = list(fill = getOption("ggplot2.discrete.colour")[1], alpha = 0.5),
+ # Main statistical functions application |
||
| 84 | -+ | |||
| 579 | +329x |
- col = getOption("ggplot2.discrete.colour")) {
+ x_stats <- .apply_stat_functions( |
||
| 85 | -2x | +580 | +329x |
- checkmate::assert_tibble(df)+ default_stat_fnc = s_summary, |
| 86 | -2x | +581 | +329x |
- checkmate::assert_flag(use_percentile)+ custom_stat_fnc_list = custom_stat_functions, |
| 87 | -2x | +582 | +329x |
- checkmate::assert_character(col, null.ok = TRUE)+ args_list = c( |
| 88 | -2x | +583 | +329x |
- checkmate::assert_list(est, names = "named")+ x = list(x), |
| 89 | -2x | +584 | +329x |
- checkmate::assert_list(ci_ribbon, names = "named", null.ok = TRUE)+ extra_afun_params,+ |
+
| 585 | +329x | +
+ dots_extra_args |
||
| 90 | +586 | ++ |
+ )+ |
+ |
| 587 | ++ |
+ )+ |
+ ||
| 588 | ||||
| 589 | ++ |
+ # Fill in with stats defaults if needed+ |
+ ||
| 91 | -2x | +590 | +329x |
- x_var <- ifelse(use_percentile, "Percentile Center", "Interval Center")+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
|
| 92 | -2x | +591 | +329x |
- df$x <- df[[x_var]]+ .stats <- c( |
| 93 | -2x | +592 | +329x |
- attrs <- attributes(df)+ get_stats(met_grp, |
| 94 | -2x | +593 | +329x |
- df$y <- df[[attrs$estimate]]+ stats_in = .stats, |
| 95 | -+ | |||
| 594 | +329x |
-
+ add_pval = dots_extra_args$compare_with_ref_group %||% FALSE |
||
| 96 | +595 |
- # Set legend names. To be modified also at call level+ ), |
||
| 97 | -2x | +596 | +329x |
- legend_names <- c("Estimate", "CI 95%")
+ names(custom_stat_functions) # Additional stats from custom functions |
| 98 | +597 | ++ |
+ )+ |
+ |
| 598 | ||||
| 99 | -2x | +599 | +329x |
- p <- ggplot2::ggplot(df, ggplot2::aes(x = .data[["x"]], y = .data[["y"]]))+ x_stats <- x_stats[.stats] |
| 100 | +600 | |||
| 101 | -2x | +601 | +329x |
- if (!is.null(col)) {
+ is_char <- is.character(x) || is.factor(x) |
| 102 | -2x | +602 | +329x |
- p <- p ++ if (is_char) {
|
| 103 | -2x | +603 | +236x |
- ggplot2::scale_color_manual(values = col)+ levels_per_stats <- lapply(x_stats, names) |
| 104 | +604 |
- }+ } else {
|
||
| 105 | -+ | |||
| 605 | +93x |
-
+ levels_per_stats <- names(x_stats) %>% |
||
| 106 | -2x | +606 | +93x |
- if (!is.null(ci_ribbon)) {
+ as.list() %>% |
| 107 | -1x | +607 | +93x |
- if (is.null(ci_ribbon$fill)) {
+ setNames(names(x_stats)) |
| 108 | -! | +|||
| 608 | +
- ci_ribbon$fill <- "lightblue"+ } |
|||
| 109 | +609 |
- }+ |
||
| 110 | -1x | +|||
| 610 | +
- p <- p + ggplot2::geom_ribbon(+ # Fill in formats/indents/labels with custom input and defaults |
|||
| 111 | -1x | +611 | +329x |
- ggplot2::aes(+ .formats <- get_formats_from_stats(.stats, .formats, levels_per_stats) |
| 112 | -1x | +612 | +329x |
- ymin = .data[["ci_lower"]], ymax = .data[["ci_upper"]],+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods, levels_per_stats) |
| 113 | -1x | +613 | +329x |
- fill = legend_names[2]+ lbls <- get_labels_from_stats(.stats, .labels, levels_per_stats) |
| 114 | +614 |
- ),+ |
||
| 115 | -1x | +615 | +329x |
- alpha = ci_ribbon$alpha+ if (is_char) {
|
| 116 | +616 |
- ) ++ # Keep pval_counts stat if present from comparisons and empty |
||
| 117 | -1x | +617 | +236x |
- scale_fill_manual(+ if ("pval_counts" %in% names(x_stats) && length(x_stats[["pval_counts"]]) == 0) {
|
| 118 | -1x | +618 | +3x |
- name = "", values = c("CI 95%" = ci_ribbon$fill)
+ x_stats[["pval_counts"]] <- list(NULL) %>% setNames("pval_counts")
|
| 119 | +619 |
- )+ } |
||
| 120 | +620 |
- }+ |
||
| 121 | -2x | +|||
| 621 | +
- suppressMessages(p <- p ++ # Unlist stats |
|||
| 122 | -2x | +622 | +236x |
- ggplot2::geom_line(+ x_stats <- x_stats %>% |
| 123 | -2x | +623 | +236x |
- ggplot2::aes(y = .data[["y"]], color = legend_names[1]),+ .unlist_keep_nulls() %>% |
| 124 | -2x | +624 | +236x |
- linetype = est$lty+ setNames(names(.formats)) |
| 125 | +625 |
- ) +- |
- ||
| 126 | -2x | -
- scale_colour_manual(- |
- ||
| 127 | -2x | -
- name = "", values = c("Estimate" = "blue")
+ } |
||
| 128 | +626 |
- ))+ |
||
| 129 | +627 |
-
+ # Check for custom labels from control_analyze_vars |
||
| 130 | -2x | +628 | +329x |
- p <- p + ggplot2::labs(x = attrs$biomarker, y = attrs$estimate)+ .labels <- if ("control" %in% names(dots_extra_args)) {
|
| 131 | +629 | 2x |
- if (use_percentile) {
- |
- |
| 132 | -1x | -
- p <- p + ggplot2::scale_x_continuous(labels = scales::percent)+ labels_use_control(lbls, dots_extra_args[["control"]], .labels) |
||
| 133 | +630 |
- }+ } else {
|
||
| 134 | -2x | +631 | +327x |
- p+ lbls |
| 135 | +632 |
- }+ } |
||
| 136 | +633 | |||
| 137 | +634 |
- #' Custom tidy method for STEP results+ # Auto format handling |
||
| 138 | -+ | |||
| 635 | +329x |
- #'+ .formats <- apply_auto_formatting( |
||
| 139 | -+ | |||
| 636 | +329x |
- #' @description `r lifecycle::badge("stable")`
+ .formats, |
||
| 140 | -+ | |||
| 637 | +329x |
- #'+ x_stats, |
||
| 141 | -+ | |||
| 638 | +329x |
- #' Tidy the STEP results into a `tibble` format ready for plotting.+ extra_afun_params$.df_row, |
||
| 142 | -+ | |||
| 639 | +329x |
- #'+ extra_afun_params$.var |
||
| 143 | +640 |
- #' @param x (`matrix`)\cr results from [fit_survival_step()].+ ) |
||
| 144 | +641 |
- #' @param ... not used.+ |
||
| 145 | +642 |
- #'+ # Get and check statistical names from defaults |
||
| 146 | -+ | |||
| 643 | +329x |
- #' @return A `tibble` with one row per STEP subgroup. The estimates and CIs are on the HR or OR scale,+ .stat_names <- get_stat_names(x_stats, .stat_names) # note is x_stats |
||
| 147 | +644 |
- #' respectively. Additional attributes carry metadata also used for plotting.+ |
||
| 148 | -+ | |||
| 645 | +329x |
- #'+ in_rows( |
||
| 149 | -+ | |||
| 646 | +329x |
- #' @seealso [g_step()] which consumes the result from this function.+ .list = x_stats, |
||
| 150 | -+ | |||
| 647 | +329x |
- #'+ .formats = .formats, |
||
| 151 | -+ | |||
| 648 | +329x |
- #' @method tidy step+ .names = names(.labels), |
||
| 152 | -+ | |||
| 649 | +329x |
- #'+ .stat_names = .stat_names, |
||
| 153 | -+ | |||
| 650 | +329x |
- #' @examples+ .labels = .labels %>% .unlist_keep_nulls(), |
||
| 154 | -+ | |||
| 651 | +329x |
- #' library(survival)+ .indent_mods = .indent_mods %>% .unlist_keep_nulls() |
||
| 155 | +652 |
- #' lung$sex <- factor(lung$sex)+ ) |
||
| 156 | +653 |
- #' vars <- list(+ } |
||
| 157 | +654 |
- #' time = "time",+ |
||
| 158 | +655 |
- #' event = "status",+ #' @describeIn analyze_variables Layout-creating function which can take statistics function arguments |
||
| 159 | +656 |
- #' arm = "sex",+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 160 | +657 |
- #' biomarker = "age"+ #' |
||
| 161 | +658 |
- #' )+ #' @param ... additional arguments passed to `s_summary()`, including: |
||
| 162 | +659 |
- #' step_matrix <- fit_survival_step(+ #' * `denom`: (`string`) See parameter description below. |
||
| 163 | +660 |
- #' variables = vars,+ #' * `.N_row`: (`numeric(1)`) Row-wise N (row group count) for the group of observations being analyzed (i.e. with no |
||
| 164 | +661 |
- #' data = lung,+ #' column-based subsetting). |
||
| 165 | +662 |
- #' control = c(control_coxph(), control_step(num_points = 10, degree = 2))+ #' * `.N_col`: (`numeric(1)`) Column-wise N (column count) for the full column being tabulated within. |
||
| 166 | +663 |
- #' )+ #' * `verbose`: (`flag`) Whether additional warnings and messages should be printed. Mainly used to print out |
||
| 167 | +664 |
- #' broom::tidy(step_matrix)+ #' information about factor casting. Defaults to `TRUE`. Used for `character`/`factor` variables only. |
||
| 168 | +665 |
- #'+ #' @param compare_with_ref_group (logical)\cr whether to compare the variable with a reference group. |
||
| 169 | +666 |
- #' @export+ #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 170 | +667 |
- tidy.step <- function(x, ...) { # nolint
+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
||
| 171 | -7x | +|||
| 668 | +
- checkmate::assert_class(x, "step")+ #' for that statistic's row label. |
|||
| 172 | -7x | +|||
| 669 | +
- dat <- as.data.frame(x)+ #' |
|||
| 173 | -7x | +|||
| 670 | +
- nams <- names(dat)+ #' @return |
|||
| 174 | -7x | +|||
| 671 | +
- is_surv <- "loghr" %in% names(dat)+ #' * `analyze_vars()` returns a layout object suitable for passing to further layouting functions, |
|||
| 175 | -7x | +|||
| 672 | +
- est_var <- ifelse(is_surv, "loghr", "logor")+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 176 | -7x | +|||
| 673 | +
- new_est_var <- ifelse(is_surv, "Hazard Ratio", "Odds Ratio")+ #' the statistics from `s_summary()` to the table layout. |
|||
| 177 | -7x | +|||
| 674 | +
- new_y_vars <- c(new_est_var, c("ci_lower", "ci_upper"))
+ #' |
|||
| 178 | -7x | +|||
| 675 | +
- names(dat)[match(est_var, nams)] <- new_est_var+ #' @examples |
|||
| 179 | -7x | +|||
| 676 | +
- dat[, new_y_vars] <- exp(dat[, new_y_vars])+ #' ## Fabricated dataset. |
|||
| 180 | -7x | +|||
| 677 | +
- any_is_na <- any(is.na(dat[, new_y_vars]))+ #' dta_test <- data.frame( |
|||
| 181 | -7x | +|||
| 678 | +
- any_is_very_large <- any(abs(dat[, new_y_vars]) > 1e10, na.rm = TRUE)+ #' USUBJID = rep(1:6, each = 3), |
|||
| 182 | -7x | +|||
| 679 | +
- if (any_is_na) {
+ #' PARAMCD = rep("lab", 6 * 3),
|
|||
| 183 | -2x | +|||
| 680 | +
- warning(paste(+ #' AVISIT = rep(paste0("V", 1:3), 6),
|
|||
| 184 | -2x | +|||
| 681 | +
- "Missing values in the point estimate or CI columns,",+ #' ARM = rep(LETTERS[1:3], rep(6, 3)), |
|||
| 185 | -2x | +|||
| 682 | +
- "this will lead to holes in the `g_step()` plot"+ #' AVAL = c(9:1, rep(NA, 9)) |
|||
| 186 | +683 |
- ))+ #' ) |
||
| 187 | +684 |
- }+ #' |
||
| 188 | -7x | +|||
| 685 | +
- if (any_is_very_large) {
+ #' # `analyze_vars()` in `rtables` pipelines |
|||
| 189 | -2x | +|||
| 686 | +
- warning(paste(+ #' ## Default output within a `rtables` pipeline. |
|||
| 190 | -2x | +|||
| 687 | +
- "Very large absolute values in the point estimate or CI columns,",+ #' l <- basic_table() %>% |
|||
| 191 | -2x | +|||
| 688 | +
- "consider adding `scale_y_log10()` to the `g_step()` result for plotting"+ #' split_cols_by(var = "ARM") %>% |
|||
| 192 | +689 |
- ))+ #' split_rows_by(var = "AVISIT") %>% |
||
| 193 | +690 |
- }+ #' analyze_vars(vars = "AVAL") |
||
| 194 | -7x | +|||
| 691 | +
- if (any_is_na || any_is_very_large) {
+ #' |
|||
| 195 | -4x | +|||
| 692 | +
- warning("Consider using larger `bandwidth`, less `num_points` in `control_step()` settings for fitting")
+ #' build_table(l, df = dta_test) |
|||
| 196 | +693 |
- }+ #' |
||
| 197 | -7x | +|||
| 694 | +
- structure(+ #' ## Select and format statistics output. |
|||
| 198 | -7x | +|||
| 695 | +
- tibble::as_tibble(dat),+ #' l <- basic_table() %>% |
|||
| 199 | -7x | +|||
| 696 | +
- estimate = new_est_var,+ #' split_cols_by(var = "ARM") %>% |
|||
| 200 | -7x | +|||
| 697 | +
- biomarker = attr(x, "variables")$biomarker,+ #' split_rows_by(var = "AVISIT") %>% |
|||
| 201 | -7x | +|||
| 698 | +
- ci = f_conf_level(attr(x, "control")$conf_level)+ #' analyze_vars( |
|||
| 202 | +699 |
- )+ #' vars = "AVAL", |
||
| 203 | +700 |
- }+ #' .stats = c("n", "mean_sd", "quantiles"),
|
| 1 | +701 |
- #' Count occurrences+ #' .formats = c("mean_sd" = "xx.x, xx.x"),
|
|
| 2 | +702 |
- #'+ #' .labels = c(n = "n", mean_sd = "Mean, SD", quantiles = c("Q1 - Q3"))
|
|
| 3 | +703 |
- #' @description `r lifecycle::badge("stable")`
+ #' ) |
|
| 4 | +704 |
#' |
|
| 5 | +705 |
- #' The analyze function [count_occurrences()] creates a layout element to calculate occurrence counts for patients.+ #' build_table(l, df = dta_test) |
|
| 6 | +706 |
#' |
|
| 7 | +707 |
- #' This function analyzes the variable(s) supplied to `vars` and returns a table of occurrence counts for+ #' ## Use arguments interpreted by `s_summary`. |
|
| 8 | +708 |
- #' each unique value (or level) of the variable(s). This variable (or variables) must be+ #' l <- basic_table() %>% |
|
| 9 | +709 |
- #' non-numeric. The `id` variable is used to indicate unique subject identifiers (defaults to `USUBJID`).+ #' split_cols_by(var = "ARM") %>% |
|
| 10 | +710 |
- #'+ #' split_rows_by(var = "AVISIT") %>% |
|
| 11 | +711 |
- #' If there are multiple occurrences of the same value recorded for a patient, the value is only counted once.+ #' analyze_vars(vars = "AVAL", na_rm = FALSE) |
|
| 12 | +712 |
#' |
|
| 13 | +713 |
- #' The summarize function [summarize_occurrences()] performs the same function as [count_occurrences()] except it+ #' build_table(l, df = dta_test) |
|
| 14 | +714 |
- #' creates content rows, not data rows, to summarize the current table row/column context and operates on the level of+ #' |
|
| 15 | +715 |
- #' the latest row split or the root of the table if no row splits have occurred.+ #' ## Handle `NA` levels first when summarizing factors. |
|
| 16 | +716 |
- #'+ #' dta_test$AVISIT <- NA_character_ |
|
| 17 | +717 |
- #' @inheritParams argument_convention+ #' dta_test <- df_explicit_na(dta_test) |
|
| 18 | +718 |
- #' @param drop (`flag`)\cr whether non-appearing occurrence levels should be dropped from the resulting table.+ #' l <- basic_table() %>% |
|
| 19 | +719 |
- #' Note that in that case the remaining occurrence levels in the table are sorted alphabetically.+ #' split_cols_by(var = "ARM") %>% |
|
| 20 | +720 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' analyze_vars(vars = "AVISIT", na_rm = FALSE) |
|
| 21 | +721 |
#' |
|
| 22 | +722 |
- #' Options are: ``r shQuote(get_stats("count_occurrences"))``
+ #' build_table(l, df = dta_test) |
|
| 23 | +723 |
#' |
|
| 24 | +724 |
- #' @note By default, occurrences which don't appear in a given row split are dropped from the table and+ #' # auto format |
|
| 25 | +725 |
- #' the occurrences in the table are sorted alphabetically per row split. Therefore, the corresponding layout+ #' dt <- data.frame("VAR" = c(0.001, 0.2, 0.0011000, 3, 4))
|
|
| 26 | +726 |
- #' needs to use `split_fun = drop_split_levels` in the `split_rows_by` calls. Use `drop = FALSE` if you would+ #' basic_table() %>% |
|
| 27 | +727 |
- #' like to show all occurrences.+ #' analyze_vars( |
|
| 28 | +728 |
- #'+ #' vars = "VAR", |
|
| 29 | +729 |
- #' @examples+ #' .stats = c("n", "mean", "mean_sd", "range"),
|
|
| 30 | +730 |
- #' library(dplyr)+ #' .formats = c("mean_sd" = "auto", "range" = "auto")
|
|
| 31 | +731 |
- #' df <- data.frame(+ #' ) %>% |
|
| 32 | +732 |
- #' USUBJID = as.character(c(+ #' build_table(dt) |
|
| 33 | +733 |
- #' 1, 1, 2, 4, 4, 4,+ #' |
|
| 34 | +734 |
- #' 6, 6, 6, 7, 7, 8+ #' @export |
|
| 35 | +735 |
- #' )),+ #' @order 2 |
|
| 36 | +736 |
- #' MHDECOD = c(+ analyze_vars <- function(lyt, |
|
| 37 | +737 |
- #' "MH1", "MH2", "MH1", "MH1", "MH1", "MH3",+ vars, |
|
| 38 | +738 |
- #' "MH2", "MH2", "MH3", "MH1", "MH2", "MH4"+ var_labels = vars, |
|
| 39 | +739 |
- #' ),+ na_str = default_na_str(), |
|
| 40 | +740 |
- #' ARM = rep(c("A", "B"), each = 6),
+ nested = TRUE, |
|
| 41 | +741 |
- #' SEX = c("F", "F", "M", "M", "M", "M", "F", "F", "F", "M", "M", "F")
+ show_labels = "default", |
|
| 42 | +742 |
- #' )+ table_names = vars, |
|
| 43 | +743 |
- #' df_adsl <- df %>%+ section_div = NA_character_, |
|
| 44 | +744 |
- #' select(USUBJID, ARM) %>%+ ..., |
|
| 45 | +745 |
- #' unique()+ na_rm = TRUE, |
|
| 46 | +746 |
- #'+ compare_with_ref_group = FALSE, |
|
| 47 | +747 |
- #' @name count_occurrences+ .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
|
|
| 48 | +748 |
- #' @order 1+ .stat_names = NULL, |
|
| 49 | +749 |
- NULL+ .formats = NULL, |
|
| 50 | +750 |
-
+ .labels = NULL, |
|
| 51 | +751 |
- #' @describeIn count_occurrences Statistics function which counts number of patients that report an+ .indent_mods = NULL) {
|
|
| 52 | +752 |
- #' occurrence.+ # Depending on main functions |
|
| 53 | -+ | ||
| 753 | +37x |
- #'+ extra_args <- list( |
|
| 54 | -+ | ||
| 754 | +37x |
- #' @param denom (`string`)\cr choice of denominator for proportion. Options are:+ "na_rm" = na_rm, |
|
| 55 | -+ | ||
| 755 | +37x |
- #' * `N_col`: total number of patients in this column across rows.+ "compare_with_ref_group" = compare_with_ref_group, |
|
| 56 | +756 |
- #' * `n`: number of patients with any occurrences.+ ... |
|
| 57 | +757 |
- #' * `N_row`: total number of patients in this row across columns.+ ) |
|
| 58 | +758 |
- #'+ |
|
| 59 | +759 |
- #' @return+ # Needed defaults |
|
| 60 | -+ | ||
| 760 | +37x |
- #' * `s_count_occurrences()` returns a list with:+ if (!is.null(.stats)) extra_args[[".stats"]] <- .stats |
|
| 61 | -+ | ||
| 761 | +3x |
- #' * `count`: list of counts with one element per occurrence.+ if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names |
|
| 62 | -+ | ||
| 762 | +8x |
- #' * `count_fraction`: list of counts and fractions with one element per occurrence.+ if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
|
| 63 | -+ | ||
| 763 | +4x |
- #' * `fraction`: list of numerators and denominators with one element per occurrence.+ if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
|
| 64 | -+ | ||
| 764 | +! |
- #'+ if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
|
| 65 | +765 |
- #' @examples+ |
|
| 66 | +766 |
- #' # Count unique occurrences per subject.+ # Adding all additional information from layout to analysis functions (see ?rtables::additional_fun_params) |
|
| 67 | -+ | ||
| 767 | +37x |
- #' s_count_occurrences(+ extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) |
|
| 68 | -+ | ||
| 768 | +37x |
- #' df,+ formals(a_summary) <- c(+ |
+ |
| 769 | +37x | +
+ formals(a_summary),+ |
+ |
| 770 | +37x | +
+ extra_args[[".additional_fun_parameters"]] |
|
| 69 | +771 |
- #' .N_col = 4L,+ ) |
|
| 70 | +772 |
- #' .N_row = 4L,+ |
|
| 71 | +773 |
- #' .df_row = df,+ # Main {rtables} structural call
+ |
+ |
| 774 | +37x | +
+ analyze(+ |
+ |
| 775 | +37x | +
+ lyt = lyt,+ |
+ |
| 776 | +37x | +
+ vars = vars,+ |
+ |
| 777 | +37x | +
+ var_labels = var_labels,+ |
+ |
| 778 | +37x | +
+ afun = a_summary,+ |
+ |
| 779 | +37x | +
+ na_str = na_str,+ |
+ |
| 780 | +37x | +
+ inclNAs = !na_rm,+ |
+ |
| 781 | +37x | +
+ nested = nested,+ |
+ |
| 782 | +37x | +
+ extra_args = extra_args,+ |
+ |
| 783 | +37x | +
+ show_labels = show_labels,+ |
+ |
| 784 | +37x | +
+ table_names = table_names,+ |
+ |
| 785 | +37x | +
+ section_div = section_div |
|
| 72 | +786 |
- #' .var = "MHDECOD",+ ) |
|
| 73 | +787 |
- #' id = "USUBJID"+ } |
| 74 | +1 |
- #' )+ #' Count patients with toxicity grades that have worsened from baseline by highest grade post-baseline |
||
| 75 | +2 |
#' |
||
| 76 | +3 |
- #' @export+ #' @description `r lifecycle::badge("stable")`
|
||
| 77 | +4 |
- s_count_occurrences <- function(df,+ #' |
||
| 78 | +5 |
- denom = c("N_col", "n", "N_row"),
+ #' The analyze function [count_abnormal_lab_worsen_by_baseline()] creates a layout element to count patients with |
||
| 79 | +6 |
- .N_col, # nolint+ #' analysis toxicity grades which have worsened from baseline, categorized by highest (worst) grade post-baseline. |
||
| 80 | +7 |
- .N_row, # nolint+ #' |
||
| 81 | +8 |
- .df_row,+ #' This function analyzes primary analysis variable `var` which indicates analysis toxicity grades. Additional |
||
| 82 | +9 |
- drop = TRUE,+ #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to `USUBJID`), |
||
| 83 | +10 |
- .var = "MHDECOD",+ #' a variable to indicate unique subject identifiers, `baseline_var` (defaults to `BTOXGR`), a variable to indicate |
||
| 84 | +11 |
- id = "USUBJID") {
+ #' baseline toxicity grades, and `direction_var` (defaults to `GRADDIR`), a variable to indicate toxicity grade |
||
| 85 | -126x | +|||
| 12 | +
- checkmate::assert_flag(drop)+ #' directions of interest to include (e.g. `"H"` (high), `"L"` (low), or `"B"` (both)). |
|||
| 86 | -126x | +|||
| 13 | +
- assert_df_with_variables(df, list(range = .var, id = id))+ #' |
|||
| 87 | -126x | +|||
| 14 | +
- checkmate::assert_count(.N_col)+ #' For the direction(s) specified in `direction_var`, patient counts by worst grade for patients who have |
|||
| 88 | -126x | +|||
| 15 | +
- checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
+ #' worsened from baseline are calculated as follows: |
|||
| 89 | -126x | +|||
| 16 | +
- checkmate::assert_multi_class(df[[id]], classes = c("factor", "character"))
+ #' * `1` to `4`: The number of patients who have worsened from their baseline grades with worst |
|||
| 90 | +17 |
-
+ #' grades 1-4, respectively. |
||
| 91 | -126x | +|||
| 18 | +
- occurrences <- if (drop) {
+ #' * `Any`: The total number of patients who have worsened from their baseline grades. |
|||
| 92 | +19 |
- # Note that we don't try to preserve original level order here since a) that would required+ #' |
||
| 93 | +20 |
- # more time to look up in large original levels and b) that would fail for character input variable.+ #' Fractions are calculated by dividing the above counts by the number of patients who's analysis toxicity grades |
||
| 94 | -115x | +|||
| 21 | +
- occurrence_levels <- sort(unique(.df_row[[.var]]))+ #' have worsened from baseline toxicity grades during treatment. |
|||
| 95 | -115x | +|||
| 22 | +
- if (length(occurrence_levels) == 0) {
+ #' |
|||
| 96 | -1x | +|||
| 23 | +
- stop(+ #' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create a row |
|||
| 97 | -1x | +|||
| 24 | +
- "no empty `.df_row` input allowed when `drop = TRUE`,",+ #' split on variable `direction_var`. |
|||
| 98 | -1x | +|||
| 25 | +
- " please use `split_fun = drop_split_levels` in the `rtables` `split_rows_by` calls"+ #' |
|||
| 99 | +26 |
- )+ #' @inheritParams argument_convention |
||
| 100 | +27 |
- }+ #' @param variables (named `list` of `string`)\cr list of additional analysis variables including: |
||
| 101 | -114x | +|||
| 28 | +
- factor(df[[.var]], levels = occurrence_levels)+ #' * `id` (`string`)\cr subject variable name. |
|||
| 102 | +29 |
- } else {
+ #' * `baseline_var` (`string`)\cr name of the data column containing baseline toxicity variable. |
||
| 103 | -11x | +|||
| 30 | +
- df[[.var]]+ #' * `direction_var` (`string`)\cr see `direction_var` for more details. |
|||
| 104 | +31 |
- }+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 105 | -125x | +|||
| 32 | +
- ids <- factor(df[[id]])+ #' |
|||
| 106 | -125x | +|||
| 33 | +
- denom <- match.arg(denom) %>%+ #' Options are: ``r shQuote(get_stats("abnormal_by_worst_grade_worsen"), type = "sh")``
|
|||
| 107 | -125x | +|||
| 34 | +
- switch(+ #' |
|||
| 108 | -125x | +|||
| 35 | +
- n = nlevels(ids),+ #' @seealso Relevant helper functions [h_adlb_worsen()] and [h_worsen_counter()] which are used within |
|||
| 109 | -125x | +|||
| 36 | +
- N_row = .N_row,+ #' [s_count_abnormal_lab_worsen_by_baseline()] to process input data. |
|||
| 110 | -125x | +|||
| 37 | +
- N_col = .N_col+ #' |
|||
| 111 | +38 |
- )+ #' @name abnormal_by_worst_grade_worsen |
||
| 112 | -125x | +|||
| 39 | +
- has_occurrence_per_id <- table(occurrences, ids) > 0+ #' @order 1 |
|||
| 113 | -125x | +|||
| 40 | +
- n_ids_per_occurrence <- as.list(rowSums(has_occurrence_per_id))+ NULL |
|||
| 114 | -125x | +|||
| 41 | +
- cur_count_fraction <- lapply(+ |
|||
| 115 | -125x | +|||
| 42 | +
- n_ids_per_occurrence,+ #' Helper function to prepare ADLB with worst labs |
|||
| 116 | -125x | +|||
| 43 | +
- function(i, denom) {
+ #' |
|||
| 117 | -514x | +|||
| 44 | +
- if (i == 0 && denom == 0) {
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 118 | -! | +|||
| 45 | +
- c(0, 0)+ #' |
|||
| 119 | +46 |
- } else {
+ #' Helper function to prepare a `df` for generate the patient count shift table. |
||
| 120 | -514x | +|||
| 47 | +
- c(i, i / denom)+ #' |
|||
| 121 | +48 |
- }+ #' @param adlb (`data.frame`)\cr ADLB data frame. |
||
| 122 | +49 |
- },+ #' @param worst_flag_low (named `vector`)\cr worst low post-baseline lab grade flag variable. See how this is |
||
| 123 | -125x | +|||
| 50 | +
- denom = denom+ #' implemented in the following examples. |
|||
| 124 | +51 |
- )+ #' @param worst_flag_high (named `vector`)\cr worst high post-baseline lab grade flag variable. See how this is |
||
| 125 | +52 |
-
+ #' implemented in the following examples. |
||
| 126 | -125x | +|||
| 53 | +
- list(+ #' @param direction_var (`string`)\cr name of the direction variable specifying the direction of the shift table of |
|||
| 127 | -125x | +|||
| 54 | +
- count = n_ids_per_occurrence,+ #' interest. Only lab records flagged by `L`, `H` or `B` are included in the shift table. |
|||
| 128 | -125x | +|||
| 55 | +
- count_fraction = cur_count_fraction,+ #' * `L`: low direction only |
|||
| 129 | -125x | +|||
| 56 | +
- count_fraction_fixed_dp = cur_count_fraction,+ #' * `H`: high direction only |
|||
| 130 | -125x | +|||
| 57 | +
- fraction = lapply(+ #' * `B`: both low and high directions |
|||
| 131 | -125x | +|||
| 58 | +
- n_ids_per_occurrence,+ #' |
|||
| 132 | -125x | +|||
| 59 | +
- function(i, denom) c("num" = i, "denom" = denom),
+ #' @return `h_adlb_worsen()` returns the `adlb` `data.frame` containing only the |
|||
| 133 | -125x | +|||
| 60 | +
- denom = denom+ #' worst labs specified according to `worst_flag_low` or `worst_flag_high` for the |
|||
| 134 | +61 |
- )+ #' direction specified according to `direction_var`. For instance, for a lab that is |
||
| 135 | +62 |
- )+ #' needed for the low direction only, only records flagged by `worst_flag_low` are |
||
| 136 | +63 |
- }+ #' selected. For a lab that is needed for both low and high directions, the worst |
||
| 137 | +64 |
-
+ #' low records are selected for the low direction, and the worst high record are selected |
||
| 138 | +65 |
- #' @describeIn count_occurrences Formatted analysis function which is used as `afun`+ #' for the high direction. |
||
| 139 | +66 |
- #' in `count_occurrences()`.+ #' |
||
| 140 | +67 |
- #'+ #' @seealso [abnormal_by_worst_grade_worsen] |
||
| 141 | +68 |
- #' @return+ #' |
||
| 142 | +69 |
- #' * `a_count_occurrences()` returns the corresponding list with formatted [rtables::CellValue()].+ #' @examples |
||
| 143 | +70 |
- #'+ #' library(dplyr) |
||
| 144 | +71 |
- #' @examples+ #' |
||
| 145 | +72 |
- #' a_count_occurrences(+ #' # The direction variable, GRADDR, is based on metadata |
||
| 146 | +73 |
- #' df,+ #' adlb <- tern_ex_adlb %>% |
||
| 147 | +74 |
- #' .N_col = 4L,+ #' mutate( |
||
| 148 | +75 |
- #' .df_row = df,+ #' GRADDR = case_when( |
||
| 149 | +76 |
- #' .var = "MHDECOD",+ #' PARAMCD == "ALT" ~ "B", |
||
| 150 | +77 |
- #' id = "USUBJID"+ #' PARAMCD == "CRP" ~ "L", |
||
| 151 | +78 |
- #' )+ #' PARAMCD == "IGA" ~ "H" |
||
| 152 | +79 |
- #'+ #' ) |
||
| 153 | +80 |
- #' @export+ #' ) %>% |
||
| 154 | +81 |
- a_count_occurrences <- function(df,+ #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "") |
||
| 155 | +82 |
- labelstr = "",+ #' |
||
| 156 | +83 |
- id = "USUBJID",+ #' df <- h_adlb_worsen( |
||
| 157 | +84 |
- denom = c("N_col", "n", "N_row"),
+ #' adlb, |
||
| 158 | +85 |
- drop = TRUE,+ #' worst_flag_low = c("WGRLOFL" = "Y"),
|
||
| 159 | +86 |
- .N_col, # nolint+ #' worst_flag_high = c("WGRHIFL" = "Y"),
|
||
| 160 | +87 |
- .N_row, # nolint+ #' direction_var = "GRADDR" |
||
| 161 | +88 |
- .var = NULL,+ #' ) |
||
| 162 | +89 |
- .df_row = NULL,+ #' |
||
| 163 | +90 |
- .stats = NULL,+ #' @export |
||
| 164 | +91 |
- .formats = NULL,+ h_adlb_worsen <- function(adlb, |
||
| 165 | +92 |
- .labels = NULL,+ worst_flag_low = NULL, |
||
| 166 | +93 |
- .indent_mods = NULL,+ worst_flag_high = NULL, |
||
| 167 | +94 |
- na_str = default_na_str()) {
+ direction_var) {
|
||
| 168 | -85x | +95 | +5x |
- denom <- match.arg(denom)+ checkmate::assert_string(direction_var) |
| 169 | -85x | +96 | +5x |
- x_stats <- s_count_occurrences(+ checkmate::assert_subset(as.character(unique(adlb[[direction_var]])), c("B", "L", "H"))
|
| 170 | -85x | +97 | +5x |
- df = df, denom = denom, .N_col = .N_col, .N_row = .N_row, .df_row = .df_row, drop = drop, .var = .var, id = id+ assert_df_with_variables(adlb, list("Col" = direction_var))
|
| 171 | +98 |
- )+ |
||
| 172 | -85x | +99 | +5x |
- if (is.null(unlist(x_stats))) {
+ if (any(unique(adlb[[direction_var]]) == "H")) {
|
| 173 | -3x | +100 | +4x |
- return(NULL)+ assert_df_with_variables(adlb, list("High" = names(worst_flag_high)))
|
| 174 | +101 |
} |
||
| 175 | +102 | |||
| 176 | -- |
- # Fill in with formatting defaults if needed- |
- ||
| 177 | -82x | -
- .stats <- get_stats("count_occurrences", stats_in = .stats)
- |
- ||
| 178 | -82x | +103 | +5x |
- .formats <- get_formats_from_stats(.stats, .formats)+ if (any(unique(adlb[[direction_var]]) == "L")) {
|
| 179 | -82x | +104 | +4x |
- .labels <- .unlist_keep_nulls(get_labels_from_stats(.stats, .labels, levels_per_stats = lapply(x_stats, names)))+ assert_df_with_variables(adlb, list("Low" = names(worst_flag_low)))
|
| 180 | -82x | +|||
| 105 | +
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods, row_nms = names(x_stats[[1]]))+ } |
|||
| 181 | +106 | |||
| 182 | -82x | +107 | +5x |
- x_stats <- x_stats[.stats]+ if (any(unique(adlb[[direction_var]]) == "B")) {
|
| 183 | -+ | |||
| 108 | +3x |
-
+ assert_df_with_variables( |
||
| 184 | -+ | |||
| 109 | +3x |
- # Ungroup statistics with values for each level of x+ adlb, |
||
| 185 | -82x | +110 | +3x |
- x_ungrp <- ungroup_stats(x_stats, .formats, list())+ list( |
| 186 | -82x | +111 | +3x |
- x_stats <- x_ungrp[["x"]]+ "Low" = names(worst_flag_low), |
| 187 | -82x | +112 | +3x |
- .formats <- x_ungrp[[".formats"]]+ "High" = names(worst_flag_high) |
| 188 | +113 |
-
+ ) |
||
| 189 | +114 |
- # Auto format handling+ ) |
||
| 190 | -82x | +|||
| 115 | +
- .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)+ } |
|||
| 191 | +116 | |||
| 192 | -82x | +|||
| 117 | +
- in_rows(+ # extract patients with worst post-baseline lab, either low or high or both |
|||
| 193 | -82x | +118 | +5x |
- .list = x_stats,+ worst_flag <- c(worst_flag_low, worst_flag_high) |
| 194 | -82x | +119 | +5x |
- .formats = .formats,+ col_names <- names(worst_flag) |
| 195 | -82x | +120 | +5x |
- .names = .labels,+ filter_values <- worst_flag |
| 196 | -82x | +121 | +5x |
- .labels = .labels,+ temp <- Map( |
| 197 | -82x | +122 | +5x |
- .indent_mods = .indent_mods,+ function(x, y) which(adlb[[x]] == y), |
| 198 | -82x | +123 | +5x |
- .format_na_strs = na_str+ col_names, |
| 199 | -+ | |||
| 124 | +5x |
- )+ filter_values |
||
| 200 | +125 |
- }+ ) |
||
| 201 | -+ | |||
| 126 | +5x |
-
+ position_satisfy_filters <- Reduce(union, temp) |
||
| 202 | +127 |
- #' @describeIn count_occurrences Layout-creating function which can take statistics function arguments+ |
||
| 203 | +128 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ # select variables of interest |
||
| 204 | -+ | |||
| 129 | +5x |
- #'+ adlb_f <- adlb[position_satisfy_filters, ] |
||
| 205 | +130 |
- #' @return+ |
||
| 206 | +131 |
- #' * `count_occurrences()` returns a layout object suitable for passing to further layouting functions,+ # generate subsets for different directionality |
||
| 207 | -+ | |||
| 132 | +5x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ adlb_f_h <- adlb_f[which(adlb_f[[direction_var]] == "H"), ] |
||
| 208 | -+ | |||
| 133 | +5x |
- #' the statistics from `s_count_occurrences()` to the table layout.+ adlb_f_l <- adlb_f[which(adlb_f[[direction_var]] == "L"), ] |
||
| 209 | -+ | |||
| 134 | +5x |
- #'+ adlb_f_b <- adlb_f[which(adlb_f[[direction_var]] == "B"), ] |
||
| 210 | +135 |
- #' @examples+ |
||
| 211 | +136 |
- #' # Create table layout+ # for labs requiring both high and low, data is duplicated and will be stacked on top of each other |
||
| 212 | -+ | |||
| 137 | +5x |
- #' lyt <- basic_table() %>%+ adlb_f_b_h <- adlb_f_b |
||
| 213 | -+ | |||
| 138 | +5x |
- #' split_cols_by("ARM") %>%
+ adlb_f_b_l <- adlb_f_b |
||
| 214 | +139 |
- #' add_colcounts() %>%+ |
||
| 215 | +140 |
- #' count_occurrences(vars = "MHDECOD", .stats = c("count_fraction"))
+ # extract data with worst lab |
||
| 216 | -+ | |||
| 141 | +5x |
- #'+ if (!is.null(worst_flag_high) && !is.null(worst_flag_low)) {
|
||
| 217 | +142 |
- #' # Apply table layout to data and produce `rtable` object+ # change H to High, L to Low |
||
| 218 | -+ | |||
| 143 | +3x |
- #' tbl <- lyt %>%+ adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
|
||
| 219 | -+ | |||
| 144 | +3x |
- #' build_table(df, alt_counts_df = df_adsl) %>%+ adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
|
||
| 220 | +145 |
- #' prune_table()+ |
||
| 221 | +146 |
- #'+ # change, B to High and Low |
||
| 222 | -+ | |||
| 147 | +3x |
- #' tbl+ adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
|
||
| 223 | -+ | |||
| 148 | +3x |
- #'+ adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
|
||
| 224 | +149 |
- #' @export+ |
||
| 225 | -+ | |||
| 150 | +3x |
- #' @order 2+ adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ] |
||
| 226 | -+ | |||
| 151 | +3x |
- count_occurrences <- function(lyt,+ adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ] |
||
| 227 | -+ | |||
| 152 | +3x |
- vars,+ adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ] |
||
| 228 | -+ | |||
| 153 | +3x |
- id = "USUBJID",+ adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ] |
||
| 229 | +154 |
- drop = TRUE,+ |
||
| 230 | -+ | |||
| 155 | +3x |
- var_labels = vars,+ out <- rbind(adlb_out_h, adlb_out_b_h, adlb_out_l, adlb_out_b_l) |
||
| 231 | -+ | |||
| 156 | +2x |
- show_labels = "hidden",+ } else if (!is.null(worst_flag_high)) {
|
||
| 232 | -+ | |||
| 157 | +1x |
- riskdiff = FALSE,+ adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
|
||
| 233 | -+ | |||
| 158 | +1x |
- na_str = default_na_str(),+ adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
|
||
| 234 | +159 |
- nested = TRUE,+ |
||
| 235 | -+ | |||
| 160 | +1x |
- ...,+ adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ] |
||
| 236 | -+ | |||
| 161 | +1x |
- table_names = vars,+ adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ] |
||
| 237 | +162 |
- .stats = "count_fraction_fixed_dp",+ |
||
| 238 | -+ | |||
| 163 | +1x |
- .formats = NULL,+ out <- rbind(adlb_out_h, adlb_out_b_h) |
||
| 239 | -+ | |||
| 164 | +1x |
- .labels = NULL,+ } else if (!is.null(worst_flag_low)) {
|
||
| 240 | -+ | |||
| 165 | +1x |
- .indent_mods = NULL) {
+ adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
|
||
| 241 | -9x | +166 | +1x |
- checkmate::assert_flag(riskdiff)+ adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
|
| 242 | +167 | |||
| 243 | -9x | +168 | +1x |
- extra_args <- list(+ adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ] |
| 244 | -9x | +169 | +1x |
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str+ adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ] |
| 245 | +170 |
- )+ |
||
| 246 | -9x | +171 | +1x |
- s_args <- list(id = id, drop = drop, ...)+ out <- rbind(adlb_out_l, adlb_out_b_l) |
| 247 | +172 | ++ |
+ }+ |
+ |
| 173 | ||||
| 248 | -9x | +|||
| 174 | +
- if (isFALSE(riskdiff)) {
+ # label |
|||
| 249 | -6x | +175 | +5x |
- extra_args <- c(extra_args, s_args)+ formatters::var_labels(out) <- formatters::var_labels(adlb_f, fill = FALSE) |
| 250 | +176 |
- } else {
- |
- ||
| 251 | -3x | -
- extra_args <- c(+ # NA |
||
| 252 | -3x | +177 | +5x |
- extra_args,+ out |
| 253 | -3x | +|||
| 178 | +
- list(+ } |
|||
| 254 | -3x | +|||
| 179 | +
- afun = list("s_count_occurrences" = a_count_occurrences),
+
|
|||
| 255 | -3x | +|||
| 180 | +
- s_args = s_args+ #' Helper function to analyze patients for `s_count_abnormal_lab_worsen_by_baseline()` |
|||
| 256 | +181 |
- )+ #' |
||
| 257 | +182 |
- )+ #' @description `r lifecycle::badge("stable")`
|
||
| 258 | +183 |
- }+ #' |
||
| 259 | +184 |
-
+ #' Helper function to count the number of patients and the fraction of patients according to |
||
| 260 | -9x | +|||
| 185 | +
- analyze(+ #' highest post-baseline lab grade variable `.var`, baseline lab grade variable `baseline_var`, |
|||
| 261 | -9x | +|||
| 186 | +
- lyt = lyt,+ #' and the direction of interest specified in `direction_var`. |
|||
| 262 | -9x | +|||
| 187 | +
- vars = vars,+ #' |
|||
| 263 | -9x | +|||
| 188 | +
- afun = ifelse(isFALSE(riskdiff), a_count_occurrences, afun_riskdiff),+ #' @inheritParams argument_convention |
|||
| 264 | -9x | +|||
| 189 | +
- var_labels = var_labels,+ #' @inheritParams h_adlb_worsen |
|||
| 265 | -9x | +|||
| 190 | +
- show_labels = show_labels,+ #' @param baseline_var (`string`)\cr name of the baseline lab grade variable. |
|||
| 266 | -9x | +|||
| 191 | +
- table_names = table_names,+ #' |
|||
| 267 | -9x | +|||
| 192 | +
- na_str = na_str,+ #' @return The counts and fraction of patients |
|||
| 268 | -9x | +|||
| 193 | +
- nested = nested,+ #' whose worst post-baseline lab grades are worse than their baseline grades, for |
|||
| 269 | -9x | +|||
| 194 | +
- extra_args = extra_args+ #' post-baseline worst grades "1", "2", "3", "4" and "Any". |
|||
| 270 | +195 |
- )+ #' |
||
| 271 | +196 |
- }+ #' @seealso [abnormal_by_worst_grade_worsen] |
||
| 272 | +197 |
-
+ #' |
||
| 273 | +198 |
- #' @describeIn count_occurrences Layout-creating function which can take content function arguments+ #' @examples |
||
| 274 | +199 |
- #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ #' library(dplyr) |
||
| 275 | +200 |
#' |
||
| 276 | +201 |
- #' @return+ #' # The direction variable, GRADDR, is based on metadata |
||
| 277 | +202 |
- #' * `summarize_occurrences()` returns a layout object suitable for passing to further layouting functions,+ #' adlb <- tern_ex_adlb %>% |
||
| 278 | +203 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows+ #' mutate( |
||
| 279 | +204 |
- #' containing the statistics from `s_count_occurrences()` to the table layout.+ #' GRADDR = case_when( |
||
| 280 | +205 |
- #'+ #' PARAMCD == "ALT" ~ "B", |
||
| 281 | +206 |
- #' @examples+ #' PARAMCD == "CRP" ~ "L", |
||
| 282 | +207 |
- #' # Layout creating function with custom format.+ #' PARAMCD == "IGA" ~ "H" |
||
| 283 | +208 |
- #' basic_table() %>%+ #' ) |
||
| 284 | +209 |
- #' add_colcounts() %>%+ #' ) %>% |
||
| 285 | +210 |
- #' split_rows_by("SEX", child_labels = "visible") %>%
+ #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "") |
||
| 286 | +211 |
- #' summarize_occurrences(+ #' |
||
| 287 | +212 |
- #' var = "MHDECOD",+ #' df <- h_adlb_worsen( |
||
| 288 | +213 |
- #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
+ #' adlb, |
||
| 289 | +214 |
- #' ) %>%+ #' worst_flag_low = c("WGRLOFL" = "Y"),
|
||
| 290 | +215 |
- #' build_table(df, alt_counts_df = df_adsl)+ #' worst_flag_high = c("WGRHIFL" = "Y"),
|
||
| 291 | +216 |
- #'+ #' direction_var = "GRADDR" |
||
| 292 | +217 |
- #' @export+ #' ) |
||
| 293 | +218 |
- #' @order 3+ #' |
||
| 294 | +219 |
- summarize_occurrences <- function(lyt,+ #' # `h_worsen_counter` |
||
| 295 | +220 |
- var,+ #' h_worsen_counter( |
||
| 296 | +221 |
- id = "USUBJID",+ #' df %>% filter(PARAMCD == "CRP" & GRADDR == "Low"), |
||
| 297 | +222 |
- drop = TRUE,+ #' id = "USUBJID", |
||
| 298 | +223 |
- riskdiff = FALSE,+ #' .var = "ATOXGR", |
||
| 299 | +224 |
- na_str = default_na_str(),+ #' baseline_var = "BTOXGR", |
||
| 300 | +225 |
- ...,+ #' direction_var = "GRADDR" |
||
| 301 | +226 |
- .stats = "count_fraction_fixed_dp",+ #' ) |
||
| 302 | +227 |
- .formats = NULL,+ #' |
||
| 303 | +228 |
- .indent_mods = NULL,+ #' @export |
||
| 304 | +229 |
- .labels = NULL) {
+ h_worsen_counter <- function(df, id, .var, baseline_var, direction_var) {
|
||
| 305 | -5x | +230 | +17x |
- checkmate::assert_flag(riskdiff)+ checkmate::assert_string(id) |
| 306 | -+ | |||
| 231 | +17x |
-
+ checkmate::assert_string(.var) |
||
| 307 | -5x | +232 | +17x |
- extra_args <- list(+ checkmate::assert_string(baseline_var) |
| 308 | -5x | +233 | +17x |
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str+ checkmate::assert_scalar(unique(df[[direction_var]]))+ |
+
| 234 | +17x | +
+ checkmate::assert_subset(unique(df[[direction_var]]), c("High", "Low"))
+ |
+ ||
| 235 | +17x | +
+ assert_df_with_variables(df, list(val = c(id, .var, baseline_var, direction_var))) |
||
| 309 | +236 |
- )+ + |
+ ||
| 237 | ++ |
+ # remove post-baseline missing |
||
| 310 | -5x | +238 | +17x |
- s_args <- list(id = id, drop = drop, ...)+ df <- df[df[[.var]] != "<Missing>", ] |
| 311 | +239 | |||
| 312 | -5x | +|||
| 240 | +
- if (isFALSE(riskdiff)) {
+ # obtain directionality |
|||
| 313 | -1x | +241 | +17x |
- extra_args <- c(extra_args, s_args)+ direction <- unique(df[[direction_var]]) |
| 314 | +242 |
- } else {
+
|
||
| 315 | -4x | +243 | +17x |
- extra_args <- c(+ if (direction == "Low") {
|
| 316 | -4x | +244 | +10x |
- extra_args,+ grade <- -1:-4 |
| 317 | -4x | +245 | +10x |
- list(+ worst_grade <- -4 |
| 318 | -4x | +246 | +7x |
- afun = list("s_count_occurrences" = a_count_occurrences),
+ } else if (direction == "High") {
|
| 319 | -4x | +247 | +7x |
- s_args = s_args+ grade <- 1:4 |
| 320 | -+ | |||
| 248 | +7x |
- )+ worst_grade <- 4 |
||
| 321 | +249 |
- )+ } |
||
| 322 | +250 |
- }+ + |
+ ||
| 251 | +17x | +
+ if (nrow(df) > 0) {
+ |
+ ||
| 252 | +17x | +
+ by_grade <- lapply(grade, function(i) {
|
||
| 323 | +253 |
-
+ # filter baseline values that is less than i or <Missing> |
||
| 324 | -5x | +254 | +68x |
- summarize_row_groups(+ df_temp <- df[df[[baseline_var]] %in% c((i + sign(i) * -1):(-1 * worst_grade), "<Missing>"), ] |
| 325 | -5x | +|||
| 255 | +
- lyt = lyt,+ # num: number of patients with post-baseline worst lab equal to i |
|||
| 326 | -5x | +256 | +68x |
- var = var,+ num <- length(unique(df_temp[df_temp[[.var]] %in% i, id, drop = TRUE]))+ |
+
| 257 | ++ |
+ # denom: number of patients with baseline values less than i or <missing> and post-baseline in the same direction |
||
| 327 | -5x | +258 | +68x |
- cfun = ifelse(isFALSE(riskdiff), a_count_occurrences, afun_riskdiff),+ denom <- length(unique(df_temp[[id]])) |
| 328 | -5x | +259 | +68x |
- na_str = na_str,+ rm(df_temp) |
| 329 | -5x | +260 | +68x |
- extra_args = extra_args+ c(num = num, denom = denom) |
| 330 | +261 |
- )+ }) |
||
| 331 | +262 |
- }+ } else {
|
| 1 | -+ | |||
| 263 | +! |
- #' Helper function to create a new SMQ variable in ADAE by stacking SMQ and/or CQ records.+ by_grade <- lapply(1, function(i) {
|
||
| 2 | -+ | |||
| 264 | +! |
- #'+ c(num = 0, denom = 0) |
||
| 3 | +265 |
- #' @description `r lifecycle::badge("stable")`
+ }) |
||
| 4 | +266 |
- #'+ } |
||
| 5 | +267 |
- #' Helper function to create a new SMQ variable in ADAE that consists of all adverse events belonging to+ |
||
| 6 | -+ | |||
| 268 | +17x |
- #' selected Standardized/Customized queries. The new dataset will only contain records of the adverse events+ names(by_grade) <- as.character(seq_along(by_grade)) |
||
| 7 | +269 |
- #' belonging to any of the selected baskets. Remember that `na_str` must match the needed pre-processing+ |
||
| 8 | +270 |
- #' done with [df_explicit_na()] to have the desired output.+ # baseline grade less 4 or missing |
||
| 9 | -+ | |||
| 271 | +17x |
- #'+ df_temp <- df[!df[[baseline_var]] %in% worst_grade, ] |
||
| 10 | +272 |
- #' @inheritParams argument_convention+ |
||
| 11 | +273 |
- #' @param baskets (`character`)\cr variable names of the selected Standardized/Customized queries.+ # denom: number of patients with baseline values less than 4 or <missing> and post-baseline in the same direction |
||
| 12 | -+ | |||
| 274 | +17x |
- #' @param smq_varlabel (`string`)\cr a label for the new variable created.+ denom <- length(unique(df_temp[, id, drop = TRUE])) |
||
| 13 | +275 |
- #' @param keys (`character`)\cr names of the key variables to be returned along with the new variable created.+ |
||
| 14 | +276 |
- #' @param aag_summary (`data.frame`)\cr containing the SMQ baskets and the levels of interest for the final SMQ+ # condition 1: missing baseline and in the direction of abnormality |
||
| 15 | -+ | |||
| 277 | +17x |
- #' variable. This is useful when there are some levels of interest that are not observed in the `df` dataset.+ con1 <- which(df_temp[[baseline_var]] == "<Missing>" & df_temp[[.var]] %in% grade) |
||
| 16 | -+ | |||
| 278 | +17x |
- #' The two columns of this dataset should be named `basket` and `basket_name`.+ df_temp_nm <- df_temp[which(df_temp[[baseline_var]] != "<Missing>" & df_temp[[.var]] %in% grade), ] |
||
| 17 | +279 |
- #'+ |
||
| 18 | +280 |
- #' @return A `data.frame` with variables in `keys` taken from `df` and new variable SMQ containing+ # condition 2: if post-baseline values are present then post-baseline values must be worse than baseline+ |
+ ||
| 281 | +17x | +
+ if (direction == "Low") {
+ |
+ ||
| 282 | +10x | +
+ con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) < as.numeric(as.character(df_temp_nm[[baseline_var]]))) |
||
| 19 | +283 |
- #' records belonging to the baskets selected via the `baskets` argument.+ } else {
|
||
| 20 | -+ | |||
| 284 | +7x |
- #'+ con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) > as.numeric(as.character(df_temp_nm[[baseline_var]]))) |
||
| 21 | +285 |
- #' @examples+ } |
||
| 22 | +286 |
- #' adae <- tern_ex_adae[1:20, ] %>% df_explicit_na()+ |
||
| 23 | +287 |
- #' h_stack_by_baskets(df = adae)+ # number of patients satisfy either conditions 1 or 2 |
||
| 24 | -+ | |||
| 288 | +17x |
- #'+ num <- length(unique(df_temp[union(con1, con2), id, drop = TRUE])) |
||
| 25 | +289 |
- #' aag <- data.frame(+ |
||
| 26 | -+ | |||
| 290 | +17x |
- #' NAMVAR = c("CQ01NAM", "CQ02NAM", "SMQ01NAM", "SMQ02NAM"),
+ list(fraction = c(by_grade, list("Any" = c(num = num, denom = denom))))
|
||
| 27 | +291 |
- #' REFNAME = c(+ } |
||
| 28 | +292 |
- #' "D.2.1.5.3/A.1.1.1.1 aesi", "X.9.9.9.9/Y.8.8.8.8 aesi",+ |
||
| 29 | +293 |
- #' "C.1.1.1.3/B.2.2.3.1 aesi", "C.1.1.1.3/B.3.3.3.3 aesi"+ #' @describeIn abnormal_by_worst_grade_worsen Statistics function for patients whose worst post-baseline |
||
| 30 | +294 |
- #' ),+ #' lab grades are worse than their baseline grades. |
||
| 31 | +295 |
- #' SCOPE = c("", "", "BROAD", "BROAD"),
+ #' |
||
| 32 | +296 |
- #' stringsAsFactors = FALSE+ #' @return |
||
| 33 | +297 |
- #' )+ #' * `s_count_abnormal_lab_worsen_by_baseline()` returns the counts and fraction of patients whose worst |
||
| 34 | +298 |
- #'+ #' post-baseline lab grades are worse than their baseline grades, for post-baseline worst grades |
||
| 35 | +299 |
- #' basket_name <- character(nrow(aag))+ #' "1", "2", "3", "4" and "Any". |
||
| 36 | +300 |
- #' cq_pos <- grep("^(CQ).+NAM$", aag$NAMVAR)
+ #' |
||
| 37 | +301 |
- #' smq_pos <- grep("^(SMQ).+NAM$", aag$NAMVAR)
+ #' @keywords internal |
||
| 38 | +302 |
- #' basket_name[cq_pos] <- aag$REFNAME[cq_pos]+ s_count_abnormal_lab_worsen_by_baseline <- function(df, # nolint |
||
| 39 | +303 |
- #' basket_name[smq_pos] <- paste0(+ .var = "ATOXGR", |
||
| 40 | +304 |
- #' aag$REFNAME[smq_pos], "(", aag$SCOPE[smq_pos], ")"
+ variables = list( |
||
| 41 | +305 |
- #' )+ id = "USUBJID", |
||
| 42 | +306 |
- #'+ baseline_var = "BTOXGR", |
||
| 43 | +307 |
- #' aag_summary <- data.frame(+ direction_var = "GRADDR" |
||
| 44 | +308 |
- #' basket = aag$NAMVAR,+ )) {
|
||
| 45 | -+ | |||
| 309 | +1x |
- #' basket_name = basket_name,+ checkmate::assert_string(.var) |
||
| 46 | -+ | |||
| 310 | +1x |
- #' stringsAsFactors = TRUE+ checkmate::assert_set_equal(names(variables), c("id", "baseline_var", "direction_var"))
|
||
| 47 | -+ | |||
| 311 | +1x |
- #' )+ checkmate::assert_string(variables$id) |
||
| 48 | -+ | |||
| 312 | +1x |
- #'+ checkmate::assert_string(variables$baseline_var) |
||
| 49 | -+ | |||
| 313 | +1x |
- #' result <- h_stack_by_baskets(df = adae, aag_summary = aag_summary)+ checkmate::assert_string(variables$direction_var) |
||
| 50 | -+ | |||
| 314 | +1x |
- #' all(levels(aag_summary$basket_name) %in% levels(result$SMQ))+ assert_df_with_variables(df, c(aval = .var, variables[1:3])) |
||
| 51 | -+ | |||
| 315 | +1x |
- #'+ assert_list_of_variables(variables) |
||
| 52 | +316 |
- #' h_stack_by_baskets(+ |
||
| 53 | -+ | |||
| 317 | +1x |
- #' df = adae,+ h_worsen_counter(df, variables$id, .var, variables$baseline_var, variables$direction_var) |
||
| 54 | +318 |
- #' aag_summary = NULL,+ } |
||
| 55 | +319 |
- #' keys = c("STUDYID", "USUBJID", "AEDECOD", "ARM"),
+
|
||
| 56 | +320 |
- #' baskets = "SMQ01NAM"+ #' @describeIn abnormal_by_worst_grade_worsen Formatted analysis function which is used as `afun` |
||
| 57 | +321 |
- #' )+ #' in `count_abnormal_lab_worsen_by_baseline()`. |
||
| 58 | +322 |
#' |
||
| 59 | +323 |
- #' @export+ #' @return |
||
| 60 | +324 |
- h_stack_by_baskets <- function(df,+ #' * `a_count_abnormal_lab_worsen_by_baseline()` returns the corresponding list with |
||
| 61 | +325 |
- baskets = grep("^(SMQ|CQ).+NAM$", names(df), value = TRUE),
+ #' formatted [rtables::CellValue()]. |
||
| 62 | +326 |
- smq_varlabel = "Standardized MedDRA Query",+ #' |
||
| 63 | +327 |
- keys = c("STUDYID", "USUBJID", "ASTDTM", "AEDECOD", "AESEQ"),
+ #' @keywords internal |
||
| 64 | +328 |
- aag_summary = NULL,+ a_count_abnormal_lab_worsen_by_baseline <- make_afun( # nolint |
||
| 65 | +329 |
- na_str = "<Missing>") {
+ s_count_abnormal_lab_worsen_by_baseline, |
||
| 66 | -5x | +|||
| 330 | +
- smq_nam <- baskets[startsWith(baskets, "SMQ")]+ .formats = c(fraction = format_fraction), |
|||
| 67 | +331 |
- # SC corresponding to NAM+ .ungroup_stats = "fraction" |
||
| 68 | -5x | +|||
| 332 | +
- smq_sc <- gsub(pattern = "NAM", replacement = "SC", x = smq_nam, fixed = TRUE)+ ) |
|||
| 69 | -5x | +|||
| 333 | +
- smq <- stats::setNames(smq_sc, smq_nam)+ |
|||
| 70 | +334 |
-
+ #' @describeIn abnormal_by_worst_grade_worsen Layout-creating function which can take statistics function |
||
| 71 | -5x | +|||
| 335 | +
- checkmate::assert_character(baskets)+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 72 | -5x | +|||
| 336 | +
- checkmate::assert_string(smq_varlabel)+ #' |
|||
| 73 | -5x | +|||
| 337 | +
- checkmate::assert_data_frame(df)+ #' @return |
|||
| 74 | -5x | +|||
| 338 | +
- checkmate::assert_true(all(startsWith(baskets, "SMQ") | startsWith(baskets, "CQ")))+ #' * `count_abnormal_lab_worsen_by_baseline()` returns a layout object suitable for passing to further layouting |
|||
| 75 | -4x | +|||
| 339 | +
- checkmate::assert_true(all(endsWith(baskets, "NAM")))+ #' functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted |
|||
| 76 | -3x | +|||
| 340 | +
- checkmate::assert_subset(baskets, names(df))+ #' rows containing the statistics from `s_count_abnormal_lab_worsen_by_baseline()` to the table layout. |
|||
| 77 | -3x | +|||
| 341 | +
- checkmate::assert_subset(keys, names(df))+ #' |
|||
| 78 | -3x | +|||
| 342 | +
- checkmate::assert_subset(smq_sc, names(df))+ #' @examples |
|||
| 79 | -3x | +|||
| 343 | +
- checkmate::assert_string(na_str)+ #' library(dplyr) |
|||
| 80 | +344 |
-
+ #' |
||
| 81 | -3x | +|||
| 345 | +
- if (!is.null(aag_summary)) {
+ #' # The direction variable, GRADDR, is based on metadata |
|||
| 82 | -1x | +|||
| 346 | +
- assert_df_with_variables(+ #' adlb <- tern_ex_adlb %>% |
|||
| 83 | -1x | +|||
| 347 | +
- df = aag_summary,+ #' mutate( |
|||
| 84 | -1x | +|||
| 348 | +
- variables = list(val = c("basket", "basket_name"))
+ #' GRADDR = case_when( |
|||
| 85 | +349 |
- )+ #' PARAMCD == "ALT" ~ "B", |
||
| 86 | +350 |
- # Warning in case there is no match between `aag_summary$basket` and `baskets` argument.+ #' PARAMCD == "CRP" ~ "L", |
||
| 87 | +351 |
- # Honestly, I think those should completely match. Target baskets should be the same.+ #' PARAMCD == "IGA" ~ "H" |
||
| 88 | -1x | +|||
| 352 | +
- if (length(intersect(baskets, unique(aag_summary$basket))) == 0) {
+ #' ) |
|||
| 89 | -! | +|||
| 353 | +
- warning("There are 0 baskets in common between aag_summary$basket and `baskets` argument.")
+ #' ) %>% |
|||
| 90 | +354 |
- }+ #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "") |
||
| 91 | +355 |
- }+ #' |
||
| 92 | +356 |
-
+ #' df <- h_adlb_worsen( |
||
| 93 | -3x | +|||
| 357 | +
- var_labels <- c(formatters::var_labels(df[, keys]), "SMQ" = smq_varlabel)+ #' adlb, |
|||
| 94 | +358 |
-
+ #' worst_flag_low = c("WGRLOFL" = "Y"),
|
||
| 95 | +359 |
- # convert `na_str` records from baskets to NA for the later loop and from wide to long steps+ #' worst_flag_high = c("WGRHIFL" = "Y"),
|
||
| 96 | -3x | +|||
| 360 | +
- df[, c(baskets, smq_sc)][df[, c(baskets, smq_sc)] == na_str] <- NA+ #' direction_var = "GRADDR" |
|||
| 97 | +361 |
-
+ #' ) |
||
| 98 | -3x | +|||
| 362 | +
- if (all(is.na(df[, baskets]))) { # in case there is no level for the target baskets
+ #' |
|||
| 99 | -1x | +|||
| 363 | +
- df_long <- df[-seq_len(nrow(df)), keys] # we just need an empty data frame keeping all factor levels+ #' basic_table() %>% |
|||
| 100 | +364 |
- } else {
+ #' split_cols_by("ARMCD") %>%
|
||
| 101 | +365 |
- # Concatenate SMQxxxNAM with corresponding SMQxxxSC+ #' add_colcounts() %>% |
||
| 102 | -2x | +|||
| 366 | +
- df_cnct <- df[, c(keys, baskets[startsWith(baskets, "CQ")])]+ #' split_rows_by("PARAMCD") %>%
|
|||
| 103 | +367 |
-
+ #' split_rows_by("GRADDR") %>%
|
||
| 104 | -2x | +|||
| 368 | +
- for (nam in names(smq)) {
+ #' count_abnormal_lab_worsen_by_baseline( |
|||
| 105 | -4x | +|||
| 369 | +
- sc <- smq[nam] # SMQxxxSC corresponding to SMQxxxNAM+ #' var = "ATOXGR", |
|||
| 106 | -4x | +|||
| 370 | +
- nam_notna <- !is.na(df[[nam]])+ #' variables = list( |
|||
| 107 | -4x | +|||
| 371 | +
- new_colname <- paste(nam, sc, sep = "_")+ #' id = "USUBJID", |
|||
| 108 | -4x | +|||
| 372 | +
- df_cnct[nam_notna, new_colname] <- paste0(df[[nam]], "(", df[[sc]], ")")[nam_notna]
+ #' baseline_var = "BTOXGR", |
|||
| 109 | +373 |
- }+ #' direction_var = "GRADDR" |
||
| 110 | +374 |
-
+ #' ) |
||
| 111 | -2x | +|||
| 375 | +
- df_cnct$unique_id <- seq(1, nrow(df_cnct))+ #' ) %>% |
|||
| 112 | -2x | +|||
| 376 | +
- var_cols <- names(df_cnct)[!(names(df_cnct) %in% c(keys, "unique_id"))]+ #' append_topleft("Direction of Abnormality") %>%
|
|||
| 113 | +377 |
- # have to convert df_cnct from tibble to data frame+ #' build_table(df = df, alt_counts_df = tern_ex_adsl) |
||
| 114 | +378 |
- # as it throws a warning otherwise about rownames.+ #' |
||
| 115 | +379 |
- # tibble do not support rownames and reshape creates rownames+ #' @export |
||
| 116 | +380 |
-
+ #' @order 2 |
||
| 117 | -2x | +|||
| 381 | +
- df_long <- stats::reshape(+ count_abnormal_lab_worsen_by_baseline <- function(lyt, # nolint |
|||
| 118 | -2x | +|||
| 382 | +
- data = as.data.frame(df_cnct),+ var, |
|||
| 119 | -2x | +|||
| 383 | +
- varying = var_cols,+ variables = list( |
|||
| 120 | -2x | +|||
| 384 | +
- v.names = "SMQ",+ id = "USUBJID", |
|||
| 121 | -2x | +|||
| 385 | +
- idvar = names(df_cnct)[names(df_cnct) %in% c(keys, "unique_id")],+ baseline_var = "BTOXGR", |
|||
| 122 | -2x | +|||
| 386 | +
- direction = "long",+ direction_var = "GRADDR" |
|||
| 123 | -2x | +|||
| 387 | +
- new.row.names = seq(prod(length(var_cols), nrow(df_cnct)))+ ), |
|||
| 124 | +388 |
- )+ na_str = default_na_str(), |
||
| 125 | +389 |
-
+ nested = TRUE, |
||
| 126 | -2x | +|||
| 390 | +
- df_long <- df_long[!is.na(df_long[, "SMQ"]), !(names(df_long) %in% c("time", "unique_id"))]
+ ..., |
|||
| 127 | -2x | +|||
| 391 | +
- df_long$SMQ <- as.factor(df_long$SMQ)+ table_names = NULL, |
|||
| 128 | +392 |
- }+ .stats = NULL, |
||
| 129 | +393 |
-
+ .formats = NULL, |
||
| 130 | -3x | +|||
| 394 | +
- smq_levels <- setdiff(levels(df_long[["SMQ"]]), na_str)+ .labels = NULL, |
|||
| 131 | +395 |
-
+ .indent_mods = NULL) {
|
||
| 132 | -3x | +396 | +1x |
- if (!is.null(aag_summary)) {
+ checkmate::assert_string(var) |
| 133 | +397 |
- # A warning in case there is no match between df and aag_summary records- |
- ||
| 134 | -1x | -
- if (length(intersect(smq_levels, unique(aag_summary$basket_name))) == 0) {
+
|
||
| 135 | +398 | 1x |
- warning("There are 0 basket levels in common between aag_summary$basket_name and df.")
+ extra_args <- list(variables = variables, ...) |
|
| 136 | +399 |
- }+ |
||
| 137 | +400 | 1x |
- df_long[["SMQ"]] <- factor(+ afun <- make_afun( |
|
| 138 | +401 | 1x |
- df_long[["SMQ"]],+ a_count_abnormal_lab_worsen_by_baseline, |
|
| 139 | +402 | 1x |
- levels = sort(+ .stats = .stats, |
|
| 140 | +403 | 1x |
- c(+ .formats = .formats, |
|
| 141 | +404 | 1x |
- smq_levels,+ .labels = .labels, |
|
| 142 | +405 | 1x |
- setdiff(unique(aag_summary$basket_name), smq_levels)- |
- |
| 143 | -- |
- )- |
- ||
| 144 | -- |
- )+ .indent_mods = .indent_mods |
||
| 145 | +406 |
- )+ ) |
||
| 146 | +407 |
- } else {
+
|
||
| 147 | -2x | +408 | +1x |
- all_na_basket_flag <- vapply(df[, baskets], function(x) {
+ lyt <- analyze( |
| 148 | -6x | +409 | +1x |
- all(is.na(x))+ lyt = lyt, |
| 149 | -2x | +410 | +1x |
- }, FUN.VALUE = logical(1))+ vars = var, |
| 150 | -2x | +411 | +1x |
- all_na_basket <- baskets[all_na_basket_flag]+ afun = afun, |
| 151 | -+ | |||
| 412 | +1x |
-
+ na_str = na_str, |
||
| 152 | -2x | +413 | +1x |
- df_long[["SMQ"]] <- factor(+ nested = nested, |
| 153 | -2x | +414 | +1x |
- df_long[["SMQ"]],+ extra_args = extra_args, |
| 154 | -2x | +415 | +1x |
- levels = sort(c(smq_levels, all_na_basket))+ show_labels = "hidden" |
| 155 | +416 |
- )+ ) |
||
| 156 | +417 |
- }- |
- ||
| 157 | -3x | -
- formatters::var_labels(df_long) <- var_labels+ |
||
| 158 | -3x | +418 | +1x |
- tibble::tibble(df_long)+ lyt |
| 159 | +419 |
}@@ -124170,14 +127270,14 @@ tern coverage - 95.59% |
| 1 |
- #' Count the number of patients with a particular event+ #' Multivariate logistic regression table |
||
| 5 |
- #' The analyze function [count_patients_with_event()] creates a layout element to calculate patient counts for a+ #' Layout-creating function which summarizes a logistic variable regression for binary outcome with |
||
| 6 |
- #' user-specified set of events.+ #' categorical/continuous covariates in model statement. For each covariate category (if categorical) |
||
| 7 |
- #'+ #' or specified values (if continuous), present degrees of freedom, regression parameter estimate and |
||
| 8 |
- #' This function analyzes primary analysis variable `vars` which indicates unique subject identifiers. Events+ #' standard error (SE) relative to reference group or category. Report odds ratios for each covariate |
||
| 9 |
- #' are defined by the user as a named vector via the `filters` argument, where each name corresponds to a+ #' category or specified values and corresponding Wald confidence intervals as default but allow user |
||
| 10 |
- #' variable and each value is the value(s) that that variable takes for the event.+ #' to specify other confidence levels. Report p-value for Wald chi-square test of the null hypothesis |
||
| 11 |
- #'+ #' that covariate has no effect on response in model containing all specified covariates. |
||
| 12 |
- #' If there are multiple records with the same event recorded for a patient, only one occurrence is counted.+ #' Allow option to include one two-way interaction and present similar output for |
||
| 13 |
- #'+ #' each interaction degree of freedom. |
||
| 14 |
- #' @inheritParams argument_convention+ #' |
||
| 15 |
- #' @param filters (`character`)\cr a character vector specifying the column names and flag variables+ #' @inheritParams argument_convention |
||
| 16 |
- #' to be used for counting the number of unique identifiers satisfying such conditions.+ #' @param drop_and_remove_str (`string`)\cr string to be dropped and removed. |
||
| 17 |
- #' Multiple column names and flags are accepted in this format+ #' |
||
| 18 |
- #' `c("column_name1" = "flag1", "column_name2" = "flag2")`.
+ #' @return A layout object suitable for passing to further layouting functions, or to [rtables::build_table()]. |
||
| 19 |
- #' Note that only equality is being accepted as condition.+ #' Adding this function to an `rtable` layout will add a logistic regression variable summary to the table layout. |
||
| 20 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' |
||
| 21 |
- #'+ #' @note For the formula, the variable names need to be standard `data.frame` column names without |
||
| 22 |
- #' Options are: ``r shQuote(get_stats("count_patients_with_event"))``
+ #' special characters. |
||
| 24 |
- #' @seealso [count_patients_with_flags()]+ #' @examples |
||
| 25 |
- #'+ #' library(dplyr) |
||
| 26 |
- #' @name count_patients_with_event+ #' library(broom) |
||
| 27 |
- #' @order 1+ #' |
||
| 28 |
- NULL+ #' adrs_f <- tern_ex_adrs %>% |
||
| 29 |
-
+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 30 |
- #' @describeIn count_patients_with_event Statistics function which counts the number of patients for which+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
|
||
| 31 |
- #' the defined event has occurred.+ #' mutate( |
||
| 32 |
- #'+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
||
| 33 |
- #' @inheritParams analyze_variables+ #' RACE = factor(RACE), |
||
| 34 |
- #' @param .var (`string`)\cr name of the column that contains the unique identifier.+ #' SEX = factor(SEX) |
||
| 35 |
- #'+ #' ) |
||
| 36 |
- #' @return+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
||
| 37 |
- #' * `s_count_patients_with_event()` returns the count and fraction of unique identifiers with the defined event.+ #' mod1 <- fit_logistic( |
||
| 38 |
- #'+ #' data = adrs_f, |
||
| 39 |
- #' @examples+ #' variables = list( |
||
| 40 |
- #' s_count_patients_with_event(+ #' response = "Response", |
||
| 41 |
- #' tern_ex_adae,+ #' arm = "ARMCD", |
||
| 42 |
- #' .var = "SUBJID",+ #' covariates = c("AGE", "RACE")
|
||
| 43 |
- #' filters = c("TRTEMFL" = "Y"),
+ #' ) |
||
| 45 |
- #'+ #' mod2 <- fit_logistic( |
||
| 46 |
- #' s_count_patients_with_event(+ #' data = adrs_f, |
||
| 47 |
- #' tern_ex_adae,+ #' variables = list( |
||
| 48 |
- #' .var = "SUBJID",+ #' response = "Response", |
||
| 49 |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL")
+ #' arm = "ARMCD", |
||
| 50 |
- #' )+ #' covariates = c("AGE", "RACE"),
|
||
| 51 |
- #'+ #' interaction = "AGE" |
||
| 52 |
- #' s_count_patients_with_event(+ #' ) |
||
| 53 |
- #' tern_ex_adae,+ #' ) |
||
| 54 |
- #' .var = "SUBJID",+ #' |
||
| 55 |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
+ #' df <- tidy(mod1, conf_level = 0.99) |
||
| 56 |
- #' denom = "N_col",+ #' df2 <- tidy(mod2, conf_level = 0.99) |
||
| 57 |
- #' .N_col = 456+ #' |
||
| 58 |
- #' )+ #' # flagging empty strings with "_" |
||
| 59 |
- #'+ #' df <- df_explicit_na(df, na_level = "_") |
||
| 60 |
- #' @export+ #' df2 <- df_explicit_na(df2, na_level = "_") |
||
| 61 |
- s_count_patients_with_event <- function(df,+ #' |
||
| 62 |
- .var,+ #' result1 <- basic_table() %>% |
||
| 63 |
- filters,+ #' summarize_logistic( |
||
| 64 |
- .N_col = ncol(df), # nolint+ #' conf_level = 0.95, |
||
| 65 |
- .N_row = nrow(df), # nolint+ #' drop_and_remove_str = "_" |
||
| 66 |
- denom = c("n", "N_col", "N_row")) {
+ #' ) %>% |
||
| 67 | -51x | +
- col_names <- names(filters)+ #' build_table(df = df) |
|
| 68 | -51x | +
- filter_values <- filters+ #' result1 |
|
| 69 |
-
+ #' |
||
| 70 | -51x | +
- checkmate::assert_subset(col_names, colnames(df))+ #' result2 <- basic_table() %>% |
|
| 71 |
-
+ #' summarize_logistic( |
||
| 72 | -51x | +
- temp <- Map(+ #' conf_level = 0.95, |
|
| 73 | -51x | +
- function(x, y) which(df[[x]] == y),+ #' drop_and_remove_str = "_" |
|
| 74 | -51x | +
- col_names,+ #' ) %>% |
|
| 75 | -51x | +
- filter_values+ #' build_table(df = df2) |
|
| 76 |
- )+ #' result2 |
||
| 77 | -51x | +
- position_satisfy_filters <- Reduce(intersect, temp)+ #' |
|
| 78 | -51x | +
- id_satisfy_filters <- as.character(unique(df[position_satisfy_filters, ][[.var]]))+ #' @export |
|
| 79 | -51x | +
- result <- s_count_values(+ #' @order 1 |
|
| 80 | -51x | +
- as.character(unique(df[[.var]])),+ summarize_logistic <- function(lyt, |
|
| 81 | -51x | +
- id_satisfy_filters,+ conf_level, |
|
| 82 | -51x | +
- denom = denom,+ drop_and_remove_str = "", |
|
| 83 | -51x | +
- .N_col = .N_col,+ .indent_mods = NULL) {
|
|
| 84 | -51x | +
- .N_row = .N_row+ # checks+ |
+ |
| 85 | +3x | +
+ checkmate::assert_string(drop_and_remove_str) |
|
| 85 | +86 |
- )+ |
|
| 86 | -51x | -
- result- |
- |
| 87 | -+ | 3x |
- }+ sum_logistic_variable_test <- logistic_summary_by_flag("is_variable_summary")
|
| 88 | -+ | 3x |
-
+ sum_logistic_term_estimates <- logistic_summary_by_flag("is_term_summary", .indent_mods = .indent_mods)
|
| 89 | -+ | 3x |
- #' @describeIn count_patients_with_event Formatted analysis function which is used as `afun`+ sum_logistic_odds_ratios <- logistic_summary_by_flag("is_reference_summary", .indent_mods = .indent_mods)
|
| 90 | -+ | 3x |
- #' in `count_patients_with_event()`.+ split_fun <- drop_and_remove_levels(drop_and_remove_str) |
| 91 |
- #'+ |
||
| 92 | -+ | 3x |
- #' @return+ lyt <- logistic_regression_cols(lyt, conf_level = conf_level) |
| 93 | -+ | 3x |
- #' * `a_count_patients_with_event()` returns the corresponding list with formatted [rtables::CellValue()].+ lyt <- split_rows_by(lyt, var = "variable", labels_var = "variable_label", split_fun = split_fun) |
| 94 | -+ | 3x |
- #'+ lyt <- sum_logistic_variable_test(lyt) |
| 95 | -+ | 3x |
- #' @examples+ lyt <- split_rows_by(lyt, var = "term", labels_var = "term_label", split_fun = split_fun) |
| 96 | -+ | 3x |
- #' a_count_patients_with_event(+ lyt <- sum_logistic_term_estimates(lyt) |
| 97 | -+ | 3x |
- #' tern_ex_adae,+ lyt <- split_rows_by(lyt, var = "interaction", labels_var = "interaction_label", split_fun = split_fun) |
| 98 | -+ | 3x |
- #' .var = "SUBJID",+ lyt <- split_rows_by(lyt, var = "reference", labels_var = "reference_label", split_fun = split_fun) |
| 99 | -+ | 3x |
- #' filters = c("TRTEMFL" = "Y"),
+ lyt <- sum_logistic_odds_ratios(lyt) |
| 100 | -+ | 3x |
- #' .N_col = 100,+ lyt |
| 101 |
- #' .N_row = 100+ } |
||
| 102 |
- #' )+ |
||
| 103 |
- #'+ #' Fit for logistic regression |
||
| 104 |
- #' @export+ #' |
||
| 105 |
- a_count_patients_with_event <- function(df,+ #' @description `r lifecycle::badge("stable")`
|
||
| 106 |
- labelstr = "",+ #' |
||
| 107 |
- filters,+ #' Fit a (conditional) logistic regression model. |
||
| 108 |
- .N_col, # nolint+ #' |
||
| 109 |
- .N_row, # nolint+ #' @inheritParams argument_convention |
||
| 110 |
- denom = c("n", "N_col", "N_row"),
+ #' @param data (`data.frame`)\cr the data frame on which the model was fit. |
||
| 111 |
- .df_row,+ #' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`. |
||
| 112 |
- .var = NULL,+ #' This will be used when fitting the (conditional) logistic regression model on the left hand |
||
| 113 |
- .stats = NULL,+ #' side of the formula. |
||
| 114 |
- .formats = NULL,+ #' |
||
| 115 |
- .labels = NULL,+ #' @return A fitted logistic regression model. |
||
| 116 |
- .indent_mods = NULL,+ #' |
||
| 117 |
- na_str = default_na_str()) {
+ #' @section Model Specification: |
||
| 118 | -19x | +
- x_stats <- s_count_patients_with_event(+ #' |
|
| 119 | -19x | +
- df = df, .var = .var, filters = filters, .N_col, .N_row, denom = denom+ #' The `variables` list needs to include the following elements: |
|
| 120 |
- )+ #' * `arm`: Treatment arm variable name. |
||
| 121 |
-
+ #' * `response`: The response arm variable name. Usually this is a 0/1 variable. |
||
| 122 | -19x | +
- if (is.null(unlist(x_stats))) {
+ #' * `covariates`: This is either `NULL` (no covariates) or a character vector of covariate variable names. |
|
| 123 | -! | +
- return(NULL)+ #' * `interaction`: This is either `NULL` (no interaction) or a string of a single covariate variable name already |
|
| 124 |
- }+ #' included in `covariates`. Then the interaction with the treatment arm is included in the model. |
||
| 125 |
-
+ #' |
||
| 126 |
- # Fill in with formatting defaults if needed+ #' @examples |
||
| 127 | -19x | +
- .stats <- get_stats("count_patients_with_event", stats_in = .stats)
+ #' library(dplyr) |
|
| 128 | -19x | +
- .formats <- get_formats_from_stats(.stats, .formats)+ #' |
|
| 129 | -19x | +
- .labels <- get_labels_from_stats(.stats, .labels)+ #' adrs_f <- tern_ex_adrs %>% |
|
| 130 | -19x | +
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods)+ #' filter(PARAMCD == "BESRSPI") %>% |
|
| 131 |
-
+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
|
||
| 132 | -19x | +
- x_stats <- x_stats[.stats]+ #' mutate( |
|
| 133 |
-
+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
||
| 134 |
- # Auto format handling+ #' RACE = factor(RACE), |
||
| 135 | -19x | +
- .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)+ #' SEX = factor(SEX) |
|
| 136 |
-
+ #' ) |
||
| 137 | -19x | +
- in_rows(+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
|
| 138 | -19x | +
- .list = x_stats,+ #' mod1 <- fit_logistic( |
|
| 139 | -19x | +
- .formats = .formats,+ #' data = adrs_f, |
|
| 140 | -19x | +
- .names = names(.labels),+ #' variables = list( |
|
| 141 | -19x | +
- .labels = .labels,+ #' response = "Response", |
|
| 142 | -19x | +
- .indent_mods = .indent_mods,+ #' arm = "ARMCD", |
|
| 143 | -19x | +
- .format_na_strs = na_str+ #' covariates = c("AGE", "RACE")
|
|
| 144 |
- )+ #' ) |
||
| 145 |
- }+ #' ) |
||
| 146 |
-
+ #' mod2 <- fit_logistic( |
||
| 147 |
- #' @describeIn count_patients_with_event Layout-creating function which can take statistics function+ #' data = adrs_f, |
||
| 148 |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' variables = list( |
||
| 149 |
- #'+ #' response = "Response", |
||
| 150 |
- #' @return+ #' arm = "ARMCD", |
||
| 151 |
- #' * `count_patients_with_event()` returns a layout object suitable for passing to further layouting functions,+ #' covariates = c("AGE", "RACE"),
|
||
| 152 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' interaction = "AGE" |
||
| 153 |
- #' the statistics from `s_count_patients_with_event()` to the table layout.+ #' ) |
||
| 154 |
- #'+ #' ) |
||
| 155 |
- #' @examples+ #' |
||
| 156 |
- #' lyt <- basic_table() %>%+ #' @export |
||
| 157 |
- #' split_cols_by("ARM") %>%
+ fit_logistic <- function(data, |
||
| 158 |
- #' add_colcounts() %>%+ variables = list( |
||
| 159 |
- #' count_values(+ response = "Response", |
||
| 160 |
- #' "STUDYID",+ arm = "ARMCD", |
||
| 161 |
- #' values = "AB12345",+ covariates = NULL, |
||
| 162 |
- #' .stats = "count",+ interaction = NULL, |
||
| 163 |
- #' .labels = c(count = "Total AEs")+ strata = NULL |
||
| 164 |
- #' ) %>%+ ), |
||
| 165 |
- #' count_patients_with_event(+ response_definition = "response") {
|
||
| 166 | -+ | 75x |
- #' "SUBJID",+ assert_df_with_variables(data, variables) |
| 167 | -+ | 75x |
- #' filters = c("TRTEMFL" = "Y"),
+ checkmate::assert_subset(names(variables), c("response", "arm", "covariates", "interaction", "strata"))
|
| 168 | -+ | 75x |
- #' .labels = c(count_fraction = "Total number of patients with at least one adverse event"),+ checkmate::assert_string(response_definition) |
| 169 | -+ | 75x |
- #' table_names = "tbl_all"+ checkmate::assert_true(grepl("response", response_definition))
|
| 170 |
- #' ) %>%+ |
||
| 171 | -+ | 75x |
- #' count_patients_with_event(+ response_definition <- sub( |
| 172 | -+ | 75x |
- #' "SUBJID",+ pattern = "response", |
| 173 | -+ | 75x |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
+ replacement = variables$response, |
| 174 | -+ | 75x |
- #' .labels = c(count_fraction = "Total number of patients with fatal AEs"),+ x = response_definition, |
| 175 | -+ | 75x |
- #' table_names = "tbl_fatal"+ fixed = TRUE |
| 176 |
- #' ) %>%+ ) |
||
| 177 | -+ | 75x |
- #' count_patients_with_event(+ form <- paste0(response_definition, " ~ ", variables$arm) |
| 178 | -+ | 75x |
- #' "SUBJID",+ if (!is.null(variables$covariates)) {
|
| 179 | -+ | 29x |
- #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL", "AEREL" = "Y"),
+ form <- paste0(form, " + ", paste(variables$covariates, collapse = " + ")) |
| 180 |
- #' .labels = c(count_fraction = "Total number of patients with related fatal AEs"),+ } |
||
| 181 | -+ | 75x |
- #' .indent_mods = c(count_fraction = 2L),+ if (!is.null(variables$interaction)) {
|
| 182 | -+ | 18x |
- #' table_names = "tbl_rel_fatal"+ checkmate::assert_string(variables$interaction) |
| 183 | -+ | 18x |
- #' )+ checkmate::assert_subset(variables$interaction, variables$covariates) |
| 184 | -+ | 18x |
- #'+ form <- paste0(form, " + ", variables$arm, ":", variables$interaction) |
| 185 |
- #' build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl)+ } |
||
| 186 | -+ | 75x |
- #'+ if (!is.null(variables$strata)) {
|
| 187 | -+ | 14x |
- #' @export+ strata_arg <- if (length(variables$strata) > 1) {
|
| 188 | -+ | 7x |
- #' @order 2+ paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
|
| 189 |
- count_patients_with_event <- function(lyt,+ } else {
|
||
| 190 | -+ | 7x |
- vars,+ variables$strata |
| 191 |
- filters,+ } |
||
| 192 | -+ | 14x |
- riskdiff = FALSE,+ form <- paste0(form, "+ strata(", strata_arg, ")")
|
| 193 |
- na_str = default_na_str(),+ } |
||
| 194 | -+ | 75x |
- nested = TRUE,+ formula <- stats::as.formula(form) |
| 195 | -+ | 75x |
- ...,+ if (is.null(variables$strata)) {
|
| 196 | -+ | 61x |
- table_names = vars,+ stats::glm( |
| 197 | -+ | 61x |
- .stats = "count_fraction",+ formula = formula, |
| 198 | -+ | 61x |
- .formats = list(count_fraction = format_count_fraction_fixed_dp),+ data = data, |
| 199 | -+ | 61x |
- .labels = NULL,+ family = stats::binomial("logit")
|
| 200 |
- .indent_mods = NULL) {
+ ) |
||
| 201 | -7x | +
- checkmate::assert_flag(riskdiff)+ } else {
|
|
| 202 | -7x | +14x |
- extra_args <- list(+ clogit_with_tryCatch( |
| 203 | -7x | +14x |
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str+ formula = formula, |
| 204 | -+ | 14x |
- )+ data = data, |
| 205 | -7x | +14x |
- s_args <- list(filters = filters, ...)+ x = TRUE |
| 206 |
-
+ ) |
||
| 207 | -7x | +
- if (isFALSE(riskdiff)) {
+ } |
|
| 208 | -5x | +
- extra_args <- c(extra_args, s_args)+ } |
|
| 209 |
- } else {
+
|
||
| 210 | -2x | +
- extra_args <- c(+ #' Custom tidy method for binomial GLM results |
|
| 211 | -2x | +
- extra_args,+ #' |
|
| 212 | -2x | +
- list(+ #' @description `r lifecycle::badge("stable")`
|
|
| 213 | -2x | +
- afun = list("s_count_patients_with_event" = a_count_patients_with_event),
+ #' |
|
| 214 | -2x | +
- s_args = s_args+ #' Helper method (for [broom::tidy()]) to prepare a data frame from a `glm` object |
|
| 215 |
- )+ #' with `binomial` family. |
||
| 216 |
- )+ #' |
||
| 217 |
- }+ #' @inheritParams argument_convention |
||
| 218 |
-
+ #' @param at (`numeric` or `NULL`)\cr optional values for the interaction variable. Otherwise the median is used. |
||
| 219 | -7x | +
- analyze(+ #' @param x (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family. |
|
| 220 | -7x | +
- lyt = lyt,+ #' |
|
| 221 | -7x | +
- vars = vars,+ #' @return A `data.frame` containing the tidied model. |
|
| 222 | -7x | +
- afun = ifelse(isFALSE(riskdiff), a_count_patients_with_event, afun_riskdiff),+ #' |
|
| 223 | -7x | +
- show_labels = ifelse(length(vars) > 1, "visible", "hidden"),+ #' @method tidy glm |
|
| 224 | -7x | +
- table_names = table_names,+ #' |
|
| 225 | -7x | +
- na_str = na_str,+ #' @seealso [h_logistic_regression] for relevant helper functions. |
|
| 226 | -7x | +
- nested = nested,+ #' |
|
| 227 | -7x | +
- extra_args = extra_args+ #' @examples |
|
| 228 |
- )+ #' library(dplyr) |
||
| 229 |
- }+ #' library(broom) |
| 1 | +230 |
- #' Count patients with toxicity grades that have worsened from baseline by highest grade post-baseline+ #' |
||
| 2 | +231 |
- #'+ #' adrs_f <- tern_ex_adrs %>% |
||
| 3 | +232 |
- #' @description `r lifecycle::badge("stable")`
+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 4 | +233 |
- #'+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
|
||
| 5 | +234 |
- #' The analyze function [count_abnormal_lab_worsen_by_baseline()] creates a layout element to count patients with+ #' mutate( |
||
| 6 | +235 |
- #' analysis toxicity grades which have worsened from baseline, categorized by highest (worst) grade post-baseline.+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
|
||
| 7 | +236 |
- #'+ #' RACE = factor(RACE), |
||
| 8 | +237 |
- #' This function analyzes primary analysis variable `var` which indicates analysis toxicity grades. Additional+ #' SEX = factor(SEX) |
||
| 9 | +238 |
- #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to `USUBJID`),+ #' ) |
||
| 10 | +239 |
- #' a variable to indicate unique subject identifiers, `baseline_var` (defaults to `BTOXGR`), a variable to indicate+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response") |
||
| 11 | +240 |
- #' baseline toxicity grades, and `direction_var` (defaults to `GRADDIR`), a variable to indicate toxicity grade+ #' mod1 <- fit_logistic( |
||
| 12 | +241 |
- #' directions of interest to include (e.g. `"H"` (high), `"L"` (low), or `"B"` (both)).+ #' data = adrs_f, |
||
| 13 | +242 |
- #'+ #' variables = list( |
||
| 14 | +243 |
- #' For the direction(s) specified in `direction_var`, patient counts by worst grade for patients who have+ #' response = "Response", |
||
| 15 | +244 |
- #' worsened from baseline are calculated as follows:+ #' arm = "ARMCD", |
||
| 16 | +245 |
- #' * `1` to `4`: The number of patients who have worsened from their baseline grades with worst+ #' covariates = c("AGE", "RACE")
|
||
| 17 | +246 |
- #' grades 1-4, respectively.+ #' ) |
||
| 18 | +247 |
- #' * `Any`: The total number of patients who have worsened from their baseline grades.+ #' ) |
||
| 19 | +248 |
- #'+ #' mod2 <- fit_logistic( |
||
| 20 | +249 |
- #' Fractions are calculated by dividing the above counts by the number of patients who's analysis toxicity grades+ #' data = adrs_f, |
||
| 21 | +250 |
- #' have worsened from baseline toxicity grades during treatment.+ #' variables = list( |
||
| 22 | +251 |
- #'+ #' response = "Response", |
||
| 23 | +252 |
- #' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create a row+ #' arm = "ARMCD", |
||
| 24 | +253 |
- #' split on variable `direction_var`.+ #' covariates = c("AGE", "RACE"),
|
||
| 25 | +254 |
- #'+ #' interaction = "AGE" |
||
| 26 | +255 |
- #' @inheritParams argument_convention+ #' ) |
||
| 27 | +256 |
- #' @param variables (named `list` of `string`)\cr list of additional analysis variables including:+ #' ) |
||
| 28 | +257 |
- #' * `id` (`string`)\cr subject variable name.+ #' |
||
| 29 | +258 |
- #' * `baseline_var` (`string`)\cr name of the data column containing baseline toxicity variable.+ #' df <- tidy(mod1, conf_level = 0.99) |
||
| 30 | +259 |
- #' * `direction_var` (`string`)\cr see `direction_var` for more details.+ #' df2 <- tidy(mod2, conf_level = 0.99) |
||
| 31 | +260 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' |
||
| 32 | +261 |
- #'+ #' @export |
||
| 33 | +262 |
- #' Options are: ``r shQuote(get_stats("abnormal_by_worst_grade_worsen"))``
+ tidy.glm <- function(x, # nolint |
||
| 34 | +263 |
- #'+ conf_level = 0.95, |
||
| 35 | +264 |
- #' @seealso Relevant helper functions [h_adlb_worsen()] and [h_worsen_counter()] which are used within+ at = NULL, |
||
| 36 | +265 |
- #' [s_count_abnormal_lab_worsen_by_baseline()] to process input data.+ ...) {
|
||
| 37 | -+ | |||
| 266 | +5x |
- #'+ checkmate::assert_class(x, "glm")+ |
+ ||
| 267 | +5x | +
+ checkmate::assert_set_equal(x$family$family, "binomial") |
||
| 38 | +268 |
- #' @name abnormal_by_worst_grade_worsen+ + |
+ ||
| 269 | +5x | +
+ terms_name <- attr(stats::terms(x), "term.labels")+ |
+ ||
| 270 | +5x | +
+ xs_class <- attr(x$terms, "dataClasses")+ |
+ ||
| 271 | +5x | +
+ interaction <- terms_name[which(!terms_name %in% names(xs_class))]+ |
+ ||
| 272 | +5x | +
+ df <- if (length(interaction) == 0) {
+ |
+ ||
| 273 | +2x | +
+ h_logistic_simple_terms(+ |
+ ||
| 274 | +2x | +
+ x = terms_name,+ |
+ ||
| 275 | +2x | +
+ fit_glm = x,+ |
+ ||
| 276 | +2x | +
+ conf_level = conf_level |
||
| 39 | +277 |
- #' @order 1+ ) |
||
| 40 | +278 |
- NULL+ } else {
+ |
+ ||
| 279 | +3x | +
+ h_logistic_inter_terms(+ |
+ ||
| 280 | +3x | +
+ x = terms_name,+ |
+ ||
| 281 | +3x | +
+ fit_glm = x,+ |
+ ||
| 282 | +3x | +
+ conf_level = conf_level,+ |
+ ||
| 283 | +3x | +
+ at = at |
||
| 41 | +284 |
-
+ ) |
||
| 42 | +285 |
- #' Helper function to prepare ADLB with worst labs+ }+ |
+ ||
| 286 | +5x | +
+ for (var in c("variable", "term", "interaction", "reference")) {
+ |
+ ||
| 287 | +20x | +
+ df[[var]] <- factor(df[[var]], levels = unique(df[[var]])) |
||
| 43 | +288 |
- #'+ }+ |
+ ||
| 289 | +5x | +
+ df |
||
| 44 | +290 |
- #' @description `r lifecycle::badge("stable")`
+ } |
||
| 45 | +291 |
- #'+ |
||
| 46 | +292 |
- #' Helper function to prepare a `df` for generate the patient count shift table.+ #' Logistic regression multivariate column layout function |
||
| 47 | +293 |
#' |
||
| 48 | +294 |
- #' @param adlb (`data.frame`)\cr ADLB data frame.+ #' @description `r lifecycle::badge("stable")`
|
||
| 49 | +295 |
- #' @param worst_flag_low (named `vector`)\cr worst low post-baseline lab grade flag variable. See how this is+ #' |
||
| 50 | +296 |
- #' implemented in the following examples.+ #' Layout-creating function which creates a multivariate column layout summarizing logistic |
||
| 51 | +297 |
- #' @param worst_flag_high (named `vector`)\cr worst high post-baseline lab grade flag variable. See how this is+ #' regression results. This function is a wrapper for [rtables::split_cols_by_multivar()]. |
||
| 52 | +298 |
- #' implemented in the following examples.+ #' |
||
| 53 | +299 |
- #' @param direction_var (`string`)\cr name of the direction variable specifying the direction of the shift table of+ #' @inheritParams argument_convention |
||
| 54 | +300 |
- #' interest. Only lab records flagged by `L`, `H` or `B` are included in the shift table.+ #' |
||
| 55 | +301 |
- #' * `L`: low direction only+ #' @return A layout object suitable for passing to further layouting functions. Adding this |
||
| 56 | +302 |
- #' * `H`: high direction only+ #' function to an `rtable` layout will split the table into columns corresponding to |
||
| 57 | +303 |
- #' * `B`: both low and high directions+ #' statistics `df`, `estimate`, `std_error`, `odds_ratio`, `ci`, and `pvalue`. |
||
| 58 | +304 |
#' |
||
| 59 | +305 |
- #' @return `h_adlb_worsen()` returns the `adlb` `data.frame` containing only the+ #' @export |
||
| 60 | +306 |
- #' worst labs specified according to `worst_flag_low` or `worst_flag_high` for the+ logistic_regression_cols <- function(lyt, |
||
| 61 | +307 |
- #' direction specified according to `direction_var`. For instance, for a lab that is+ conf_level = 0.95) {
|
||
| 62 | -+ | |||
| 308 | +4x |
- #' needed for the low direction only, only records flagged by `worst_flag_low` are+ vars <- c("df", "estimate", "std_error", "odds_ratio", "ci", "pvalue")
|
||
| 63 | -+ | |||
| 309 | +4x |
- #' selected. For a lab that is needed for both low and high directions, the worst+ var_labels <- c( |
||
| 64 | -+ | |||
| 310 | +4x |
- #' low records are selected for the low direction, and the worst high record are selected+ df = "Degrees of Freedom", |
||
| 65 | -+ | |||
| 311 | +4x |
- #' for the high direction.+ estimate = "Parameter Estimate", |
||
| 66 | -+ | |||
| 312 | +4x |
- #'+ std_error = "Standard Error", |
||
| 67 | -+ | |||
| 313 | +4x |
- #' @seealso [abnormal_by_worst_grade_worsen]+ odds_ratio = "Odds Ratio",+ |
+ ||
| 314 | +4x | +
+ ci = paste("Wald", f_conf_level(conf_level)),
|
||
| 68 | -+ | |||
| 315 | +4x |
- #'+ pvalue = "p-value" |
||
| 69 | +316 |
- #' @examples+ ) |
||
| 70 | -+ | |||
| 317 | +4x |
- #' library(dplyr)+ split_cols_by_multivar( |
||
| 71 | -+ | |||
| 318 | +4x |
- #'+ lyt = lyt, |
||
| 72 | -+ | |||
| 319 | +4x |
- #' # The direction variable, GRADDR, is based on metadata+ vars = vars, |
||
| 73 | -+ | |||
| 320 | +4x |
- #' adlb <- tern_ex_adlb %>%+ varlabels = var_labels |
||
| 74 | +321 |
- #' mutate(+ ) |
||
| 75 | +322 |
- #' GRADDR = case_when(+ } |
||
| 76 | +323 |
- #' PARAMCD == "ALT" ~ "B",+ |
||
| 77 | +324 |
- #' PARAMCD == "CRP" ~ "L",+ #' Logistic regression summary table |
||
| 78 | +325 |
- #' PARAMCD == "IGA" ~ "H"+ #' |
||
| 79 | +326 |
- #' )+ #' @description `r lifecycle::badge("stable")`
|
||
| 80 | +327 |
- #' ) %>%+ #' |
||
| 81 | +328 |
- #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")+ #' Constructor for content functions to be used in [`summarize_logistic()`] to summarize |
||
| 82 | +329 |
- #'+ #' logistic regression results. This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 83 | +330 |
- #' df <- h_adlb_worsen(+ #' |
||
| 84 | +331 |
- #' adlb,+ #' @inheritParams argument_convention |
||
| 85 | +332 |
- #' worst_flag_low = c("WGRLOFL" = "Y"),
+ #' @param flag_var (`string`)\cr variable name identifying which row should be used in this |
||
| 86 | +333 |
- #' worst_flag_high = c("WGRHIFL" = "Y"),
+ #' content function. |
||
| 87 | +334 |
- #' direction_var = "GRADDR"+ #' |
||
| 88 | +335 |
- #' )+ #' @return A content function. |
||
| 89 | +336 |
#' |
||
| 90 | +337 |
#' @export |
||
| 91 | +338 |
- h_adlb_worsen <- function(adlb,+ logistic_summary_by_flag <- function(flag_var, na_str = default_na_str(), .indent_mods = NULL) {
|
||
| 92 | -+ | |||
| 339 | +10x |
- worst_flag_low = NULL,+ checkmate::assert_string(flag_var) |
||
| 93 | -+ | |||
| 340 | +10x |
- worst_flag_high = NULL,+ function(lyt) {
|
||
| 94 | -+ | |||
| 341 | +10x |
- direction_var) {
+ cfun_list <- list( |
||
| 95 | -5x | +342 | +10x |
- checkmate::assert_string(direction_var)+ df = cfun_by_flag("df", flag_var, format = "xx.", .indent_mods = .indent_mods),
|
| 96 | -5x | +343 | +10x |
- checkmate::assert_subset(as.character(unique(adlb[[direction_var]])), c("B", "L", "H"))
+ estimate = cfun_by_flag("estimate", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
|
| 97 | -5x | +344 | +10x |
- assert_df_with_variables(adlb, list("Col" = direction_var))
+ std_error = cfun_by_flag("std_error", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
|
| 98 | -+ | |||
| 345 | +10x |
-
+ odds_ratio = cfun_by_flag("odds_ratio", flag_var, format = ">999.99", .indent_mods = .indent_mods),
|
||
| 99 | -5x | +346 | +10x |
- if (any(unique(adlb[[direction_var]]) == "H")) {
+ ci = cfun_by_flag("ci", flag_var, format = format_extreme_values_ci(2L), .indent_mods = .indent_mods),
|
| 100 | -4x | +347 | +10x |
- assert_df_with_variables(adlb, list("High" = names(worst_flag_high)))
+ pvalue = cfun_by_flag("pvalue", flag_var, format = "x.xxxx | (<0.0001)", .indent_mods = .indent_mods)
|
| 101 | +348 |
- }+ ) |
||
| 102 | -+ | |||
| 349 | +10x |
-
+ summarize_row_groups( |
||
| 103 | -5x | +350 | +10x |
- if (any(unique(adlb[[direction_var]]) == "L")) {
+ lyt = lyt, |
| 104 | -4x | +351 | +10x |
- assert_df_with_variables(adlb, list("Low" = names(worst_flag_low)))
+ cfun = cfun_list, |
| 105 | -+ | |||
| 352 | +10x |
- }+ na_str = na_str |
||
| 106 | +353 | - - | -||
| 107 | -5x | -
- if (any(unique(adlb[[direction_var]]) == "B")) {
+ ) |
||
| 108 | -3x | +|||
| 354 | +
- assert_df_with_variables(+ } |
|||
| 109 | -3x | +|||
| 355 | +
- adlb,+ } |
|||
| 110 | -3x | +
| 1 | +
- list(+ #' Tabulate biomarker effects on survival by subgroup |
|||
| 111 | -3x | +|||
| 2 | +
- "Low" = names(worst_flag_low),+ #' |
|||
| 112 | -3x | +|||
| 3 | +
- "High" = names(worst_flag_high)+ #' @description `r lifecycle::badge("stable")`
|
|||
| 113 | +4 |
- )+ #' |
||
| 114 | +5 |
- )+ #' The [tabulate_survival_biomarkers()] function creates a layout element to tabulate the estimated effects of multiple |
||
| 115 | +6 |
- }+ #' continuous biomarker variables on survival across subgroups, returning statistics including median survival time and |
||
| 116 | +7 |
-
+ #' hazard ratio for each population subgroup. The table is created from `df`, a list of data frames returned by |
||
| 117 | +8 |
- # extract patients with worst post-baseline lab, either low or high or both+ #' [extract_survival_biomarkers()], with the statistics to include specified via the `vars` parameter. |
||
| 118 | -5x | +|||
| 9 | +
- worst_flag <- c(worst_flag_low, worst_flag_high)+ #' |
|||
| 119 | -5x | +|||
| 10 | +
- col_names <- names(worst_flag)+ #' A forest plot can be created from the resulting table using the [g_forest()] function. |
|||
| 120 | -5x | +|||
| 11 | +
- filter_values <- worst_flag+ #' |
|||
| 121 | -5x | +|||
| 12 | +
- temp <- Map(+ #' @inheritParams fit_coxreg_multivar |
|||
| 122 | -5x | +|||
| 13 | +
- function(x, y) which(adlb[[x]] == y),+ #' @inheritParams survival_duration_subgroups |
|||
| 123 | -5x | +|||
| 14 | +
- col_names,+ #' @inheritParams argument_convention |
|||
| 124 | -5x | +|||
| 15 | +
- filter_values+ #' @param df (`data.frame`)\cr containing all analysis variables, as returned by |
|||
| 125 | +16 |
- )+ #' [extract_survival_biomarkers()]. |
||
| 126 | -5x | +|||
| 17 | +
- position_satisfy_filters <- Reduce(union, temp)+ #' @param vars (`character`)\cr the names of statistics to be reported among: |
|||
| 127 | +18 |
-
+ #' * `n_tot_events`: Total number of events per group. |
||
| 128 | +19 |
- # select variables of interest+ #' * `n_tot`: Total number of observations per group. |
||
| 129 | -5x | +|||
| 20 | +
- adlb_f <- adlb[position_satisfy_filters, ]+ #' * `median`: Median survival time. |
|||
| 130 | +21 |
-
+ #' * `hr`: Hazard ratio. |
||
| 131 | +22 |
- # generate subsets for different directionality+ #' * `ci`: Confidence interval of hazard ratio. |
||
| 132 | -5x | +|||
| 23 | +
- adlb_f_h <- adlb_f[which(adlb_f[[direction_var]] == "H"), ]+ #' * `pval`: p-value of the effect. |
|||
| 133 | -5x | +|||
| 24 | +
- adlb_f_l <- adlb_f[which(adlb_f[[direction_var]] == "L"), ]+ #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` are required. |
|||
| 134 | -5x | +|||
| 25 | +
- adlb_f_b <- adlb_f[which(adlb_f[[direction_var]] == "B"), ]+ #' |
|||
| 135 | +26 |
-
+ #' @details These functions create a layout starting from a data frame which contains |
||
| 136 | +27 |
- # for labs requiring both high and low, data is duplicated and will be stacked on top of each other+ #' the required statistics. The tables are then typically used as input for forest plots. |
||
| 137 | -5x | +|||
| 28 | +
- adlb_f_b_h <- adlb_f_b+ #' |
|||
| 138 | -5x | +|||
| 29 | +
- adlb_f_b_l <- adlb_f_b+ #' @examples |
|||
| 139 | +30 |
-
+ #' library(dplyr) |
||
| 140 | +31 |
- # extract data with worst lab+ #' |
||
| 141 | -5x | +|||
| 32 | +
- if (!is.null(worst_flag_high) && !is.null(worst_flag_low)) {
+ #' adtte <- tern_ex_adtte |
|||
| 142 | +33 |
- # change H to High, L to Low+ #' |
||
| 143 | -3x | +|||
| 34 | +
- adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
+ #' # Save variable labels before data processing steps. |
|||
| 144 | -3x | +|||
| 35 | +
- adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
+ #' adtte_labels <- formatters::var_labels(adtte) |
|||
| 145 | +36 |
-
+ #' |
||
| 146 | +37 |
- # change, B to High and Low+ #' adtte_f <- adtte %>% |
||
| 147 | -3x | +|||
| 38 | +
- adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
+ #' filter(PARAMCD == "OS") %>% |
|||
| 148 | -3x | +|||
| 39 | +
- adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
+ #' mutate( |
|||
| 149 | +40 |
-
+ #' AVALU = as.character(AVALU), |
||
| 150 | -3x | +|||
| 41 | +
- adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ]+ #' is_event = CNSR == 0 |
|||
| 151 | -3x | +|||
| 42 | +
- adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ]+ #' ) |
|||
| 152 | -3x | +|||
| 43 | +
- adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ]+ #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
|
|||
| 153 | -3x | +|||
| 44 | +
- adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ]+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
|||
| 154 | +45 |
-
+ #' |
||
| 155 | -3x | +|||
| 46 | +
- out <- rbind(adlb_out_h, adlb_out_b_h, adlb_out_l, adlb_out_b_l)+ #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`, |
|||
| 156 | -2x | +|||
| 47 | +
- } else if (!is.null(worst_flag_high)) {
+ #' # in multiple regression models containing one covariate `RACE`, |
|||
| 157 | -1x | +|||
| 48 | +
- adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
+ #' # as well as one stratification variable `STRATA1`. The subgroups |
|||
| 158 | -1x | +|||
| 49 | +
- adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
+ #' # are defined by the levels of `BMRKR2`. |
|||
| 159 | +50 |
-
+ #' |
||
| 160 | -1x | +|||
| 51 | +
- adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ]+ #' df <- extract_survival_biomarkers( |
|||
| 161 | -1x | +|||
| 52 | +
- adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ]+ #' variables = list( |
|||
| 162 | +53 |
-
+ #' tte = "AVAL", |
||
| 163 | -1x | +|||
| 54 | +
- out <- rbind(adlb_out_h, adlb_out_b_h)+ #' is_event = "is_event", |
|||
| 164 | -1x | +|||
| 55 | +
- } else if (!is.null(worst_flag_low)) {
+ #' biomarkers = c("BMRKR1", "AGE"),
|
|||
| 165 | -1x | +|||
| 56 | +
- adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
+ #' strata = "STRATA1", |
|||
| 166 | -1x | +|||
| 57 | +
- adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
+ #' covariates = "SEX", |
|||
| 167 | +58 |
-
+ #' subgroups = "BMRKR2" |
||
| 168 | -1x | +|||
| 59 | +
- adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ]+ #' ), |
|||
| 169 | -1x | +|||
| 60 | +
- adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ]+ #' label_all = "Total Patients", |
|||
| 170 | +61 |
-
+ #' data = adtte_f |
||
| 171 | -1x | +|||
| 62 | +
- out <- rbind(adlb_out_l, adlb_out_b_l)+ #' ) |
|||
| 172 | +63 |
- }+ #' df |
||
| 173 | +64 |
-
+ #' |
||
| 174 | +65 |
- # label+ #' # Here we group the levels of `BMRKR2` manually. |
||
| 175 | -5x | +|||
| 66 | +
- formatters::var_labels(out) <- formatters::var_labels(adlb_f, fill = FALSE)+ #' df_grouped <- extract_survival_biomarkers( |
|||
| 176 | +67 |
- # NA+ #' variables = list( |
||
| 177 | -5x | +|||
| 68 | +
- out+ #' tte = "AVAL", |
|||
| 178 | +69 |
- }+ #' is_event = "is_event", |
||
| 179 | +70 |
-
+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 180 | +71 |
- #' Helper function to analyze patients for `s_count_abnormal_lab_worsen_by_baseline()`+ #' strata = "STRATA1", |
||
| 181 | +72 |
- #'+ #' covariates = "SEX", |
||
| 182 | +73 |
- #' @description `r lifecycle::badge("stable")`
+ #' subgroups = "BMRKR2" |
||
| 183 | +74 |
- #'+ #' ), |
||
| 184 | +75 |
- #' Helper function to count the number of patients and the fraction of patients according to+ #' data = adtte_f, |
||
| 185 | +76 |
- #' highest post-baseline lab grade variable `.var`, baseline lab grade variable `baseline_var`,+ #' groups_lists = list( |
||
| 186 | +77 |
- #' and the direction of interest specified in `direction_var`.+ #' BMRKR2 = list( |
||
| 187 | +78 |
- #'+ #' "low" = "LOW", |
||
| 188 | +79 |
- #' @inheritParams argument_convention+ #' "low/medium" = c("LOW", "MEDIUM"),
|
||
| 189 | +80 |
- #' @inheritParams h_adlb_worsen+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
|
||
| 190 | +81 |
- #' @param baseline_var (`string`)\cr name of the baseline lab grade variable.+ #' ) |
||
| 191 | +82 |
- #'+ #' ) |
||
| 192 | +83 |
- #' @return The counts and fraction of patients+ #' ) |
||
| 193 | +84 |
- #' whose worst post-baseline lab grades are worse than their baseline grades, for+ #' df_grouped |
||
| 194 | +85 |
- #' post-baseline worst grades "1", "2", "3", "4" and "Any".+ #' |
||
| 195 | +86 |
- #'+ #' @name survival_biomarkers_subgroups |
||
| 196 | +87 |
- #' @seealso [abnormal_by_worst_grade_worsen]+ #' @order 1 |
||
| 197 | +88 |
- #'+ NULL |
||
| 198 | +89 |
- #' @examples+ |
||
| 199 | +90 |
- #' library(dplyr)+ #' Prepare survival data estimates for multiple biomarkers in a single data frame |
||
| 200 | +91 |
#' |
||
| 201 | +92 |
- #' # The direction variable, GRADDR, is based on metadata+ #' @description `r lifecycle::badge("stable")`
|
||
| 202 | +93 |
- #' adlb <- tern_ex_adlb %>%+ #' |
||
| 203 | +94 |
- #' mutate(+ #' Prepares estimates for number of events, patients and median survival times, as well as hazard ratio estimates, |
||
| 204 | +95 |
- #' GRADDR = case_when(+ #' confidence intervals and p-values, for multiple biomarkers across population subgroups in a single data frame. |
||
| 205 | +96 |
- #' PARAMCD == "ALT" ~ "B",+ #' `variables` corresponds to the names of variables found in `data`, passed as a named `list` and requires elements |
||
| 206 | +97 |
- #' PARAMCD == "CRP" ~ "L",+ #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables), and optionally `subgroups` and `strata`. |
||
| 207 | +98 |
- #' PARAMCD == "IGA" ~ "H"+ #' `groups_lists` optionally specifies groupings for `subgroups` variables. |
||
| 208 | +99 |
- #' )+ #' |
||
| 209 | +100 |
- #' ) %>%+ #' @inheritParams argument_convention |
||
| 210 | +101 |
- #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")+ #' @inheritParams fit_coxreg_multivar |
||
| 211 | +102 |
- #'+ #' @inheritParams survival_duration_subgroups |
||
| 212 | +103 |
- #' df <- h_adlb_worsen(+ #' |
||
| 213 | +104 |
- #' adlb,+ #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_tot_events`, |
||
| 214 | +105 |
- #' worst_flag_low = c("WGRLOFL" = "Y"),
+ #' `median`, `hr`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`, |
||
| 215 | +106 |
- #' worst_flag_high = c("WGRHIFL" = "Y"),
+ #' `var_label`, and `row_type`. |
||
| 216 | +107 |
- #' direction_var = "GRADDR"+ #' |
||
| 217 | +108 |
- #' )+ #' @seealso [h_coxreg_mult_cont_df()] which is used internally, [tabulate_survival_biomarkers()]. |
||
| 218 | +109 |
#' |
||
| 219 | +110 |
- #' # `h_worsen_counter`+ #' @export |
||
| 220 | +111 |
- #' h_worsen_counter(+ extract_survival_biomarkers <- function(variables, |
||
| 221 | +112 |
- #' df %>% filter(PARAMCD == "CRP" & GRADDR == "Low"),+ data, |
||
| 222 | +113 |
- #' id = "USUBJID",+ groups_lists = list(), |
||
| 223 | +114 |
- #' .var = "ATOXGR",+ control = control_coxreg(), |
||
| 224 | +115 |
- #' baseline_var = "BTOXGR",+ label_all = "All Patients") {
+ |
+ ||
| 116 | +6x | +
+ if ("strat" %in% names(variables)) {
+ |
+ ||
| 117 | +! | +
+ warning(+ |
+ ||
| 118 | +! | +
+ "Warning: the `strat` element name of the `variables` list argument to `extract_survival_biomarkers() ",+ |
+ ||
| 119 | +! | +
+ "was deprecated in tern 0.9.4.\n ",+ |
+ ||
| 120 | +! | +
+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 225 | +121 |
- #' direction_var = "GRADDR"+ )+ |
+ ||
| 122 | +! | +
+ variables[["strata"]] <- variables[["strat"]] |
||
| 226 | +123 |
- #' )+ } |
||
| 227 | +124 |
- #'+ + |
+ ||
| 125 | +6x | +
+ checkmate::assert_list(variables)+ |
+ ||
| 126 | +6x | +
+ checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ |
+ ||
| 127 | +6x | +
+ checkmate::assert_string(label_all) |
||
| 228 | +128 |
- #' @export+ |
||
| 229 | +129 |
- h_worsen_counter <- function(df, id, .var, baseline_var, direction_var) {
+ # Start with all patients. |
||
| 230 | -17x | +130 | +6x |
- checkmate::assert_string(id)+ result_all <- h_coxreg_mult_cont_df( |
| 231 | -17x | +131 | +6x |
- checkmate::assert_string(.var)+ variables = variables, |
| 232 | -17x | +132 | +6x |
- checkmate::assert_string(baseline_var)+ data = data, |
| 233 | -17x | +133 | +6x |
- checkmate::assert_scalar(unique(df[[direction_var]]))+ control = control |
| 234 | -17x | +|||
| 134 | +
- checkmate::assert_subset(unique(df[[direction_var]]), c("High", "Low"))
+ ) |
|||
| 235 | -17x | +135 | +6x |
- assert_df_with_variables(df, list(val = c(id, .var, baseline_var, direction_var)))+ result_all$subgroup <- label_all |
| 236 | -+ | |||
| 136 | +6x |
-
+ result_all$var <- "ALL" |
||
| 237 | -+ | |||
| 137 | +6x |
- # remove post-baseline missing+ result_all$var_label <- label_all |
||
| 238 | -17x | +138 | +6x |
- df <- df[df[[.var]] != "<Missing>", ]+ result_all$row_type <- "content" |
| 239 | -+ | |||
| 139 | +6x |
-
+ if (is.null(variables$subgroups)) {
|
||
| 240 | +140 |
- # obtain directionality+ # Only return result for all patients. |
||
| 241 | -17x | +141 | +1x | +
+ result_all+ |
+
| 142 | +
- direction <- unique(df[[direction_var]])+ } else {
|
|||
| 242 | +143 |
-
+ # Add subgroups results. |
||
| 243 | -17x | +144 | +5x |
- if (direction == "Low") {
+ l_data <- h_split_by_subgroups( |
| 244 | -10x | +145 | +5x |
- grade <- -1:-4+ data, |
| 245 | -10x | +146 | +5x |
- worst_grade <- -4+ variables$subgroups, |
| 246 | -7x | +147 | +5x |
- } else if (direction == "High") {
+ groups_lists = groups_lists |
| 247 | -7x | +|||
| 148 | +
- grade <- 1:4+ ) |
|||
| 248 | -7x | +149 | +5x |
- worst_grade <- 4+ l_result <- lapply(l_data, function(grp) {
|
| 249 | -+ | |||
| 150 | +25x |
- }+ result <- h_coxreg_mult_cont_df( |
||
| 250 | -+ | |||
| 151 | +25x |
-
+ variables = variables, |
||
| 251 | -17x | +152 | +25x |
- if (nrow(df) > 0) {
+ data = grp$df, |
| 252 | -17x | +153 | +25x |
- by_grade <- lapply(grade, function(i) {
+ control = control |
| 253 | +154 |
- # filter baseline values that is less than i or <Missing>+ ) |
||
| 254 | -68x | -
- df_temp <- df[df[[baseline_var]] %in% c((i + sign(i) * -1):(-1 * worst_grade), "<Missing>"), ]- |
- ||
| 255 | -+ | 155 | +25x |
- # num: number of patients with post-baseline worst lab equal to i+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ] |
| 256 | -68x | +156 | +25x |
- num <- length(unique(df_temp[df_temp[[.var]] %in% i, id, drop = TRUE]))+ cbind(result, result_labels) |
| 257 | +157 |
- # denom: number of patients with baseline values less than i or <missing> and post-baseline in the same direction+ }) |
||
| 258 | -68x | +158 | +5x |
- denom <- length(unique(df_temp[[id]]))+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
| 259 | -68x | +159 | +5x |
- rm(df_temp)+ result_subgroups$row_type <- "analysis" |
| 260 | -68x | -
- c(num = num, denom = denom)- |
- ||
| 261 | -- |
- })- |
- ||
| 262 | -+ | 160 | +5x |
- } else {
+ rbind( |
| 263 | -! | +|||
| 161 | +5x |
- by_grade <- lapply(1, function(i) {
+ result_all, |
||
| 264 | -! | +|||
| 162 | +5x |
- c(num = 0, denom = 0)+ result_subgroups |
||
| 265 | +163 |
- })+ ) |
||
| 266 | +164 |
} |
||
| 267 | +165 | - - | -||
| 268 | -17x | -
- names(by_grade) <- as.character(seq_along(by_grade))+ } |
||
| 269 | +166 | |||
| 270 | +167 |
- # baseline grade less 4 or missing+ #' @describeIn survival_biomarkers_subgroups Table-creating function which creates a table |
||
| 271 | -17x | +|||
| 168 | +
- df_temp <- df[!df[[baseline_var]] %in% worst_grade, ]+ #' summarizing biomarker effects on survival by subgroup. |
|||
| 272 | +169 |
-
+ #' |
||
| 273 | +170 |
- # denom: number of patients with baseline values less than 4 or <missing> and post-baseline in the same direction+ #' @param label_all `r lifecycle::badge("deprecated")`\cr please assign the `label_all` parameter within the
|
||
| 274 | -17x | +|||
| 171 | +
- denom <- length(unique(df_temp[, id, drop = TRUE]))+ #' [extract_survival_biomarkers()] function when creating `df`. |
|||
| 275 | +172 |
-
+ #' |
||
| 276 | +173 |
- # condition 1: missing baseline and in the direction of abnormality+ #' @return An `rtables` table summarizing biomarker effects on survival by subgroup. |
||
| 277 | -17x | +|||
| 174 | +
- con1 <- which(df_temp[[baseline_var]] == "<Missing>" & df_temp[[.var]] %in% grade)+ #' |
|||
| 278 | -17x | +|||
| 175 | +
- df_temp_nm <- df_temp[which(df_temp[[baseline_var]] != "<Missing>" & df_temp[[.var]] %in% grade), ]+ #' @note In contrast to [tabulate_survival_subgroups()] this tabulation function does |
|||
| 279 | +176 |
-
+ #' not start from an input layout `lyt`. This is because internally the table is |
||
| 280 | +177 |
- # condition 2: if post-baseline values are present then post-baseline values must be worse than baseline+ #' created by combining multiple subtables. |
||
| 281 | -17x | +|||
| 178 | +
- if (direction == "Low") {
+ #' |
|||
| 282 | -10x | +|||
| 179 | +
- con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) < as.numeric(as.character(df_temp_nm[[baseline_var]])))+ #' @seealso [h_tab_surv_one_biomarker()] which is used internally, [extract_survival_biomarkers()]. |
|||
| 283 | +180 |
- } else {
+ #' |
||
| 284 | -7x | +|||
| 181 | +
- con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) > as.numeric(as.character(df_temp_nm[[baseline_var]])))+ #' @examples |
|||
| 285 | +182 |
- }+ #' ## Table with default columns. |
||
| 286 | +183 |
-
+ #' tabulate_survival_biomarkers(df) |
||
| 287 | +184 |
- # number of patients satisfy either conditions 1 or 2+ #' |
||
| 288 | -17x | +|||
| 185 | +
- num <- length(unique(df_temp[union(con1, con2), id, drop = TRUE]))+ #' ## Table with a manually chosen set of columns: leave out "pval", reorder. |
|||
| 289 | +186 |
-
+ #' tab <- tabulate_survival_biomarkers( |
||
| 290 | -17x | +|||
| 187 | +
- list(fraction = c(by_grade, list("Any" = c(num = num, denom = denom))))
+ #' df = df, |
|||
| 291 | +188 |
- }+ #' vars = c("n_tot_events", "ci", "n_tot", "median", "hr"),
|
||
| 292 | +189 |
-
+ #' time_unit = as.character(adtte_f$AVALU[1]) |
||
| 293 | +190 |
- #' @describeIn abnormal_by_worst_grade_worsen Statistics function for patients whose worst post-baseline+ #' ) |
||
| 294 | +191 |
- #' lab grades are worse than their baseline grades.+ #' |
||
| 295 | +192 |
- #'+ #' ## Finally produce the forest plot. |
||
| 296 | +193 |
- #' @return+ #' \donttest{
|
||
| 297 | +194 |
- #' * `s_count_abnormal_lab_worsen_by_baseline()` returns the counts and fraction of patients whose worst+ #' g_forest(tab, xlim = c(0.8, 1.2)) |
||
| 298 | +195 |
- #' post-baseline lab grades are worse than their baseline grades, for post-baseline worst grades+ #' } |
||
| 299 | +196 |
- #' "1", "2", "3", "4" and "Any".+ #' |
||
| 300 | +197 |
- #'+ #' @export |
||
| 301 | +198 |
- #' @keywords internal+ #' @order 2 |
||
| 302 | +199 |
- s_count_abnormal_lab_worsen_by_baseline <- function(df, # nolint+ tabulate_survival_biomarkers <- function(df, |
||
| 303 | +200 |
- .var = "ATOXGR",+ vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
|
||
| 304 | +201 |
- variables = list(+ groups_lists = list(), |
||
| 305 | +202 |
- id = "USUBJID",+ control = control_coxreg(), |
||
| 306 | +203 |
- baseline_var = "BTOXGR",+ label_all = lifecycle::deprecated(), |
||
| 307 | +204 |
- direction_var = "GRADDR"+ time_unit = NULL, |
||
| 308 | +205 |
- )) {
+ na_str = default_na_str(), |
||
| 309 | -1x | +|||
| 206 | +
- checkmate::assert_string(.var)+ .indent_mods = 0L) {
|
|||
| 310 | -1x | +207 | +5x |
- checkmate::assert_set_equal(names(variables), c("id", "baseline_var", "direction_var"))
+ if (lifecycle::is_present(label_all)) {
|
| 311 | +208 | 1x |
- checkmate::assert_string(variables$id)+ lifecycle::deprecate_warn( |
|
| 312 | +209 | 1x |
- checkmate::assert_string(variables$baseline_var)+ "0.9.5", "tabulate_survival_biomarkers(label_all)", |
|
| 313 | +210 | 1x |
- checkmate::assert_string(variables$direction_var)+ details = paste( |
|
| 314 | +211 | 1x |
- assert_df_with_variables(df, c(aval = .var, variables[1:3]))+ "Please assign the `label_all` parameter within the", |
|
| 315 | +212 | 1x |
- assert_list_of_variables(variables)+ "`extract_survival_biomarkers()` function when creating `df`." |
|
| 316 | +213 |
-
+ ) |
||
| 317 | -1x | +|||
| 214 | +
- h_worsen_counter(df, variables$id, .var, variables$baseline_var, variables$direction_var)+ ) |
|||
| 318 | +215 |
- }+ } |
||
| 319 | +216 | |||
| 320 | -+ | |||
| 217 | +5x |
- #' @describeIn abnormal_by_worst_grade_worsen Formatted analysis function which is used as `afun`+ checkmate::assert_data_frame(df) |
||
| 321 | -+ | |||
| 218 | +5x |
- #' in `count_abnormal_lab_worsen_by_baseline()`.+ checkmate::assert_character(df$biomarker) |
||
| 322 | -+ | |||
| 219 | +5x |
- #'+ checkmate::assert_character(df$biomarker_label) |
||
| 323 | -+ | |||
| 220 | +5x |
- #' @return+ checkmate::assert_subset(vars, get_stats("tabulate_survival_biomarkers"))
|
||
| 324 | +221 |
- #' * `a_count_abnormal_lab_worsen_by_baseline()` returns the corresponding list with+ |
||
| 325 | -+ | |||
| 222 | +5x |
- #' formatted [rtables::CellValue()].+ extra_args <- list(groups_lists = groups_lists, control = control) |
||
| 326 | +223 |
- #'+ |
||
| 327 | -+ | |||
| 224 | +5x |
- #' @keywords internal+ df_subs <- split(df, f = df$biomarker) |
||
| 328 | -+ | |||
| 225 | +5x |
- a_count_abnormal_lab_worsen_by_baseline <- make_afun( # nolint+ tabs <- lapply(df_subs, FUN = function(df_sub) {
|
||
| 329 | -+ | |||
| 226 | +9x |
- s_count_abnormal_lab_worsen_by_baseline,+ tab_sub <- h_tab_surv_one_biomarker( |
||
| 330 | -+ | |||
| 227 | +9x |
- .formats = c(fraction = format_fraction),+ df = df_sub, |
||
| 331 | -+ | |||
| 228 | +9x |
- .ungroup_stats = "fraction"+ vars = vars, |
||
| 332 | -+ | |||
| 229 | +9x |
- )+ time_unit = time_unit, |
||
| 333 | -+ | |||
| 230 | +9x |
-
+ na_str = na_str, |
||
| 334 | -+ | |||
| 231 | +9x |
- #' @describeIn abnormal_by_worst_grade_worsen Layout-creating function which can take statistics function+ .indent_mods = .indent_mods, |
||
| 335 | -+ | |||
| 232 | +9x |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ extra_args = extra_args |
||
| 336 | +233 |
- #'+ ) |
||
| 337 | +234 |
- #' @return+ # Insert label row as first row in table. |
||
| 338 | -+ | |||
| 235 | +9x |
- #' * `count_abnormal_lab_worsen_by_baseline()` returns a layout object suitable for passing to further layouting+ label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1] |
||
| 339 | -+ | |||
| 236 | +9x |
- #' functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted+ tab_sub |
||
| 340 | +237 |
- #' rows containing the statistics from `s_count_abnormal_lab_worsen_by_baseline()` to the table layout.+ }) |
||
| 341 | -+ | |||
| 238 | +5x |
- #'+ result <- do.call(rbind, tabs) |
||
| 342 | +239 |
- #' @examples+ |
||
| 343 | -+ | |||
| 240 | +5x |
- #' library(dplyr)+ n_tot_ids <- grep("^n_tot", vars)
|
||
| 344 | -+ | |||
| 241 | +5x |
- #'+ hr_id <- match("hr", vars)
|
||
| 345 | -+ | |||
| 242 | +5x |
- #' # The direction variable, GRADDR, is based on metadata+ ci_id <- match("ci", vars)
|
||
| 346 | -+ | |||
| 243 | +5x |
- #' adlb <- tern_ex_adlb %>%+ structure( |
||
| 347 | -+ | |||
| 244 | +5x |
- #' mutate(+ result, |
||
| 348 | -+ | |||
| 245 | +5x |
- #' GRADDR = case_when(+ forest_header = paste0(c("Higher", "Lower"), "\nBetter"),
|
||
| 349 | -+ | |||
| 246 | +5x |
- #' PARAMCD == "ALT" ~ "B",+ col_x = hr_id,+ |
+ ||
| 247 | +5x | +
+ col_ci = ci_id,+ |
+ ||
| 248 | +5x | +
+ col_symbol_size = n_tot_ids[1] |
||
| 350 | +249 |
- #' PARAMCD == "CRP" ~ "L",+ ) |
||
| 351 | +250 |
- #' PARAMCD == "IGA" ~ "H"+ } |
| 352 | +1 |
- #' )+ #' Helper functions for tabulating biomarker effects on binary response by subgroup |
||
| 353 | +2 |
- #' ) %>%+ #' |
||
| 354 | +3 |
- #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")+ #' @description `r lifecycle::badge("stable")`
|
||
| 355 | +4 |
#' |
||
| 356 | +5 |
- #' df <- h_adlb_worsen(+ #' Helper functions which are documented here separately to not confuse the user |
||
| 357 | +6 |
- #' adlb,+ #' when reading about the user-facing functions. |
||
| 358 | +7 |
- #' worst_flag_low = c("WGRLOFL" = "Y"),
+ #' |
||
| 359 | +8 |
- #' worst_flag_high = c("WGRHIFL" = "Y"),
+ #' @inheritParams response_biomarkers_subgroups |
||
| 360 | +9 |
- #' direction_var = "GRADDR"+ #' @inheritParams extract_rsp_biomarkers |
||
| 361 | +10 |
- #' )+ #' @inheritParams argument_convention |
||
| 362 | +11 |
#' |
||
| 363 | +12 |
- #' basic_table() %>%+ #' @examples |
||
| 364 | +13 |
- #' split_cols_by("ARMCD") %>%
+ #' library(dplyr) |
||
| 365 | +14 |
- #' add_colcounts() %>%+ #' library(forcats) |
||
| 366 | +15 |
- #' split_rows_by("PARAMCD") %>%
+ #' |
||
| 367 | +16 |
- #' split_rows_by("GRADDR") %>%
+ #' adrs <- tern_ex_adrs |
||
| 368 | +17 |
- #' count_abnormal_lab_worsen_by_baseline(+ #' adrs_labels <- formatters::var_labels(adrs) |
||
| 369 | +18 |
- #' var = "ATOXGR",+ #' |
||
| 370 | +19 |
- #' variables = list(+ #' adrs_f <- adrs %>% |
||
| 371 | +20 |
- #' id = "USUBJID",+ #' filter(PARAMCD == "BESRSPI") %>% |
||
| 372 | +21 |
- #' baseline_var = "BTOXGR",+ #' mutate(rsp = AVALC == "CR") |
||
| 373 | +22 |
- #' direction_var = "GRADDR"+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response") |
||
| 374 | +23 |
- #' )+ #' |
||
| 375 | +24 |
- #' ) %>%+ #' @name h_response_biomarkers_subgroups |
||
| 376 | +25 |
- #' append_topleft("Direction of Abnormality") %>%
+ NULL |
||
| 377 | +26 |
- #' build_table(df = df, alt_counts_df = tern_ex_adsl)+ |
||
| 378 | +27 |
- #'+ #' @describeIn h_response_biomarkers_subgroups helps with converting the "response" function variable list |
||
| 379 | +28 |
- #' @export+ #' to the "logistic regression" variable list. The reason is that currently there is an |
||
| 380 | +29 |
- #' @order 2+ #' inconsistency between the variable names accepted by `extract_rsp_subgroups()` and `fit_logistic()`. |
||
| 381 | +30 |
- count_abnormal_lab_worsen_by_baseline <- function(lyt, # nolint+ #' |
||
| 382 | +31 |
- var,+ #' @param biomarker (`string`)\cr the name of the biomarker variable. |
||
| 383 | +32 |
- variables = list(+ #' |
||
| 384 | +33 |
- id = "USUBJID",+ #' @return |
||
| 385 | +34 |
- baseline_var = "BTOXGR",+ #' * `h_rsp_to_logistic_variables()` returns a named `list` of elements `response`, `arm`, `covariates`, and `strata`. |
||
| 386 | +35 |
- direction_var = "GRADDR"+ #' |
||
| 387 | +36 |
- ),+ #' @examples |
||
| 388 | +37 |
- na_str = default_na_str(),+ #' # This is how the variable list is converted internally. |
||
| 389 | +38 |
- nested = TRUE,+ #' h_rsp_to_logistic_variables( |
||
| 390 | +39 |
- ...,+ #' variables = list( |
||
| 391 | +40 |
- table_names = NULL,+ #' rsp = "RSP", |
||
| 392 | +41 |
- .stats = NULL,+ #' covariates = c("A", "B"),
|
||
| 393 | +42 |
- .formats = NULL,+ #' strata = "D" |
||
| 394 | +43 |
- .labels = NULL,+ #' ), |
||
| 395 | +44 |
- .indent_mods = NULL) {
+ #' biomarker = "AGE" |
||
| 396 | -1x | +|||
| 45 | +
- checkmate::assert_string(var)+ #' ) |
|||
| 397 | +46 |
-
+ #' |
||
| 398 | -1x | +|||
| 47 | +
- extra_args <- list(variables = variables, ...)+ #' @export |
|||
| 399 | +48 |
-
+ h_rsp_to_logistic_variables <- function(variables, biomarker) {
|
||
| 400 | -1x | +49 | +49x |
- afun <- make_afun(+ if ("strat" %in% names(variables)) {
|
| 401 | -1x | +|||
| 50 | +! |
- a_count_abnormal_lab_worsen_by_baseline,+ warning( |
||
| 402 | -1x | +|||
| 51 | +! |
- .stats = .stats,+ "Warning: the `strat` element name of the `variables` list argument to `h_rsp_to_logistic_variables() ", |
||
| 403 | -1x | +|||
| 52 | +! |
- .formats = .formats,+ "was deprecated in tern 0.9.4.\n ", |
||
| 404 | -1x | +|||
| 53 | +! |
- .labels = .labels,+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 405 | -1x | +|||
| 54 | +
- .indent_mods = .indent_mods+ ) |
|||
| 406 | -+ | |||
| 55 | +! |
- )+ variables[["strata"]] <- variables[["strat"]] |
||
| 407 | +56 |
-
+ } |
||
| 408 | -1x | +57 | +49x |
- lyt <- analyze(+ checkmate::assert_list(variables) |
| 409 | -1x | +58 | +49x |
- lyt = lyt,+ checkmate::assert_string(variables$rsp) |
| 410 | -1x | +59 | +49x |
- vars = var,+ checkmate::assert_string(biomarker) |
| 411 | -1x | +60 | +49x |
- afun = afun,+ list( |
| 412 | -1x | +61 | +49x |
- na_str = na_str,+ response = variables$rsp, |
| 413 | -1x | +62 | +49x |
- nested = nested,+ arm = biomarker, |
| 414 | -1x | +63 | +49x |
- extra_args = extra_args,+ covariates = variables$covariates, |
| 415 | -1x | +64 | +49x |
- show_labels = "hidden"+ strata = variables$strata |
| 416 | +65 |
) |
||
| 417 | +66 | ++ |
+ }+ |
+ |
| 67 | ||||
| 418 | -1x | +|||
| 68 | +
- lyt+ #' @describeIn h_response_biomarkers_subgroups prepares estimates for number of responses, patients and |
|||
| 419 | +69 |
- }+ #' overall response rate, as well as odds ratio estimates, confidence intervals and p-values, for multiple |
| 1 | +70 |
- #' Multivariate logistic regression table+ #' biomarkers in a given single data set. |
||
| 2 | +71 | ++ |
+ #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements+ |
+ |
| 72 | ++ |
+ #' `rsp` and `biomarkers` (vector of continuous biomarker variables) and optionally `covariates`+ |
+ ||
| 73 | ++ |
+ #' and `strata`.+ |
+ ||
| 74 |
#' |
|||
| 3 | +75 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return+ |
+ ||
| 76 | ++ |
+ #' * `h_logistic_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers. |
||
| 4 | +77 |
#' |
||
| 5 | +78 |
- #' Layout-creating function which summarizes a logistic variable regression for binary outcome with+ #' @examples |
||
| 6 | +79 |
- #' categorical/continuous covariates in model statement. For each covariate category (if categorical)+ #' # For a single population, estimate separately the effects |
||
| 7 | +80 |
- #' or specified values (if continuous), present degrees of freedom, regression parameter estimate and+ #' # of two biomarkers. |
||
| 8 | +81 |
- #' standard error (SE) relative to reference group or category. Report odds ratios for each covariate+ #' df <- h_logistic_mult_cont_df( |
||
| 9 | +82 |
- #' category or specified values and corresponding Wald confidence intervals as default but allow user+ #' variables = list( |
||
| 10 | +83 |
- #' to specify other confidence levels. Report p-value for Wald chi-square test of the null hypothesis+ #' rsp = "rsp", |
||
| 11 | +84 |
- #' that covariate has no effect on response in model containing all specified covariates.+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 12 | +85 |
- #' Allow option to include one two-way interaction and present similar output for+ #' covariates = "SEX" |
||
| 13 | +86 |
- #' each interaction degree of freedom.+ #' ), |
||
| 14 | +87 |
- #'+ #' data = adrs_f |
||
| 15 | +88 |
- #' @inheritParams argument_convention+ #' ) |
||
| 16 | +89 |
- #' @param drop_and_remove_str (`string`)\cr string to be dropped and removed.+ #' df |
||
| 17 | +90 |
#' |
||
| 18 | +91 |
- #' @return A layout object suitable for passing to further layouting functions, or to [rtables::build_table()].+ #' # If the data set is empty, still the corresponding rows with missings are returned. |
||
| 19 | +92 |
- #' Adding this function to an `rtable` layout will add a logistic regression variable summary to the table layout.+ #' h_coxreg_mult_cont_df( |
||
| 20 | +93 |
- #'+ #' variables = list( |
||
| 21 | +94 |
- #' @note For the formula, the variable names need to be standard `data.frame` column names without+ #' rsp = "rsp", |
||
| 22 | +95 |
- #' special characters.+ #' biomarkers = c("BMRKR1", "AGE"),
|
||
| 23 | +96 |
- #'+ #' covariates = "SEX", |
||
| 24 | +97 |
- #' @examples+ #' strata = "STRATA1" |
||
| 25 | +98 |
- #' library(dplyr)+ #' ), |
||
| 26 | +99 |
- #' library(broom)+ #' data = adrs_f[NULL, ] |
||
| 27 | +100 |
- #'+ #' ) |
||
| 28 | +101 |
- #' adrs_f <- tern_ex_adrs %>%+ #' |
||
| 29 | +102 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' @export |
||
| 30 | +103 |
- #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ h_logistic_mult_cont_df <- function(variables, |
||
| 31 | +104 |
- #' mutate(+ data, |
||
| 32 | +105 |
- #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ control = control_logistic()) {
|
||
| 33 | -+ | |||
| 106 | +28x |
- #' RACE = factor(RACE),+ if ("strat" %in% names(variables)) {
|
||
| 34 | -+ | |||
| 107 | +! |
- #' SEX = factor(SEX)+ warning( |
||
| 35 | -+ | |||
| 108 | +! |
- #' )+ "Warning: the `strat` element name of the `variables` list argument to `h_logistic_mult_cont_df() ", |
||
| 36 | -+ | |||
| 109 | +! |
- #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ "was deprecated in tern 0.9.4.\n ", |
||
| 37 | -+ | |||
| 110 | +! |
- #' mod1 <- fit_logistic(+ "Please use the name `strata` instead of `strat` in the `variables` argument." |
||
| 38 | +111 |
- #' data = adrs_f,+ ) |
||
| 39 | -+ | |||
| 112 | +! |
- #' variables = list(+ variables[["strata"]] <- variables[["strat"]] |
||
| 40 | +113 |
- #' response = "Response",+ } |
||
| 41 | -+ | |||
| 114 | +28x |
- #' arm = "ARMCD",+ assert_df_with_variables(data, variables) |
||
| 42 | +115 |
- #' covariates = c("AGE", "RACE")
+
|
||
| 43 | -+ | |||
| 116 | +28x |
- #' )+ checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE) |
||
| 44 | -+ | |||
| 117 | +28x |
- #' )+ checkmate::assert_list(control, names = "named") |
||
| 45 | +118 |
- #' mod2 <- fit_logistic(+ |
||
| 46 | -+ | |||
| 119 | +28x |
- #' data = adrs_f,+ conf_level <- control[["conf_level"]] |
||
| 47 | -+ | |||
| 120 | +28x |
- #' variables = list(+ pval_label <- "p-value (Wald)" |
||
| 48 | +121 |
- #' response = "Response",+ |
||
| 49 | +122 |
- #' arm = "ARMCD",+ # If there is any data, run model, otherwise return empty results. |
||
| 50 | -+ | |||
| 123 | +28x |
- #' covariates = c("AGE", "RACE"),
+ if (nrow(data) > 0) {
|
||
| 51 | -+ | |||
| 124 | +27x |
- #' interaction = "AGE"+ bm_cols <- match(variables$biomarkers, names(data)) |
||
| 52 | -+ | |||
| 125 | +27x |
- #' )+ l_result <- lapply(variables$biomarkers, function(bm) {
|
||
| 53 | -+ | |||
| 126 | +48x |
- #' )+ model_fit <- fit_logistic( |
||
| 54 | -+ | |||
| 127 | +48x |
- #'+ variables = h_rsp_to_logistic_variables(variables, bm), |
||
| 55 | -+ | |||
| 128 | +48x |
- #' df <- tidy(mod1, conf_level = 0.99)+ data = data, |
||
| 56 | -+ | |||
| 129 | +48x |
- #' df2 <- tidy(mod2, conf_level = 0.99)+ response_definition = control$response_definition |
||
| 57 | +130 |
- #'+ ) |
||
| 58 | -+ | |||
| 131 | +48x |
- #' # flagging empty strings with "_"+ result <- h_logistic_simple_terms( |
||
| 59 | -+ | |||
| 132 | +48x |
- #' df <- df_explicit_na(df, na_level = "_")+ x = bm, |
||
| 60 | -+ | |||
| 133 | +48x |
- #' df2 <- df_explicit_na(df2, na_level = "_")+ fit_glm = model_fit, |
||
| 61 | -+ | |||
| 134 | +48x |
- #'+ conf_level = control$conf_level |
||
| 62 | +135 |
- #' result1 <- basic_table() %>%+ ) |
||
| 63 | -+ | |||
| 136 | +48x |
- #' summarize_logistic(+ resp_vector <- if (inherits(model_fit, "glm")) {
|
||
| 64 | -+ | |||
| 137 | +38x |
- #' conf_level = 0.95,+ model_fit$model[[variables$rsp]] |
||
| 65 | +138 |
- #' drop_and_remove_str = "_"+ } else {
|
||
| 66 | -+ | |||
| 139 | +10x |
- #' ) %>%+ as.logical(as.matrix(model_fit$y)[, "status"]) |
||
| 67 | +140 |
- #' build_table(df = df)+ } |
||
| 68 | -+ | |||
| 141 | +48x |
- #' result1+ data.frame( |
||
| 69 | +142 |
- #'+ # Dummy column needed downstream to create a nested header. |
||
| 70 | -+ | |||
| 143 | +48x |
- #' result2 <- basic_table() %>%+ biomarker = bm, |
||
| 71 | -+ | |||
| 144 | +48x |
- #' summarize_logistic(+ biomarker_label = formatters::var_labels(data[bm], fill = TRUE), |
||
| 72 | -+ | |||
| 145 | +48x |
- #' conf_level = 0.95,+ n_tot = length(resp_vector), |
||
| 73 | -+ | |||
| 146 | +48x |
- #' drop_and_remove_str = "_"+ n_rsp = sum(resp_vector), |
||
| 74 | -+ | |||
| 147 | +48x |
- #' ) %>%+ prop = mean(resp_vector), |
||
| 75 | -+ | |||
| 148 | +48x |
- #' build_table(df = df2)+ or = as.numeric(result[1L, "odds_ratio"]), |
||
| 76 | -+ | |||
| 149 | +48x |
- #' result2+ lcl = as.numeric(result[1L, "lcl"]), |
||
| 77 | -+ | |||
| 150 | +48x |
- #'+ ucl = as.numeric(result[1L, "ucl"]), |
||
| 78 | -+ | |||
| 151 | +48x |
- #' @export+ conf_level = conf_level, |
||
| 79 | -+ | |||
| 152 | +48x |
- #' @order 1+ pval = as.numeric(result[1L, "pvalue"]), |
||
| 80 | -+ | |||
| 153 | +48x |
- summarize_logistic <- function(lyt,+ pval_label = pval_label, |
||
| 81 | -+ | |||
| 154 | +48x |
- conf_level,+ stringsAsFactors = FALSE |
||
| 82 | +155 |
- drop_and_remove_str = "",+ ) |
||
| 83 | +156 |
- .indent_mods = NULL) {
+ })+ |
+ ||
| 157 | +27x | +
+ do.call(rbind, args = c(l_result, make.row.names = FALSE)) |
||
| 84 | +158 |
- # checks+ } else {
|
||
| 85 | -3x | +159 | +1x |
- checkmate::assert_string(drop_and_remove_str)+ data.frame( |
| 86 | -+ | |||
| 160 | +1x |
-
+ biomarker = variables$biomarkers, |
||
| 87 | -3x | +161 | +1x |
- sum_logistic_variable_test <- logistic_summary_by_flag("is_variable_summary")
+ biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE), |
| 88 | -3x | +162 | +1x |
- sum_logistic_term_estimates <- logistic_summary_by_flag("is_term_summary", .indent_mods = .indent_mods)
+ n_tot = 0L, |
| 89 | -3x | +163 | +1x |
- sum_logistic_odds_ratios <- logistic_summary_by_flag("is_reference_summary", .indent_mods = .indent_mods)
+ n_rsp = 0L, |
| 90 | -3x | +164 | +1x |
- split_fun <- drop_and_remove_levels(drop_and_remove_str)+ prop = NA, |
| 91 | -+ | |||
| 165 | +1x |
-
+ or = NA, |
||
| 92 | -3x | +166 | +1x |
- lyt <- logistic_regression_cols(lyt, conf_level = conf_level)+ lcl = NA, |
| 93 | -3x | +167 | +1x |
- lyt <- split_rows_by(lyt, var = "variable", labels_var = "variable_label", split_fun = split_fun)+ ucl = NA, |
| 94 | -3x | +168 | +1x |
- lyt <- sum_logistic_variable_test(lyt)+ conf_level = conf_level, |
| 95 | -3x | +169 | +1x |
- lyt <- split_rows_by(lyt, var = "term", labels_var = "term_label", split_fun = split_fun)+ pval = NA, |
| 96 | -3x | +170 | +1x |
- lyt <- sum_logistic_term_estimates(lyt)+ pval_label = pval_label, |
| 97 | -3x | +171 | +1x |
- lyt <- split_rows_by(lyt, var = "interaction", labels_var = "interaction_label", split_fun = split_fun)+ row.names = seq_along(variables$biomarkers), |
| 98 | -3x | +172 | +1x |
- lyt <- split_rows_by(lyt, var = "reference", labels_var = "reference_label", split_fun = split_fun)+ stringsAsFactors = FALSE |
| 99 | -3x | +|||
| 173 | +
- lyt <- sum_logistic_odds_ratios(lyt)+ ) |
|||
| 100 | -3x | +|||
| 174 | +
- lyt+ } |
|||
| 101 | +175 |
} |
||
| 102 | +176 | |||
| 103 | +177 |
- #' Fit for logistic regression+ #' @describeIn h_response_biomarkers_subgroups Prepares a single sub-table given a `df_sub` containing |
||
| 104 | +178 | ++ |
+ #' the results for a single biomarker.+ |
+ |
| 179 |
#' |
|||
| 105 | +180 |
- #' @description `r lifecycle::badge("stable")`
+ #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is |
||
| 106 | +181 |
- #'+ #' returned by [extract_rsp_biomarkers()] (it needs a couple of columns which are |
||
| 107 | +182 |
- #' Fit a (conditional) logistic regression model.+ #' added by that high-level function relative to what is returned by [h_logistic_mult_cont_df()], |
||
| 108 | +183 |
- #'+ #' see the example). |
||
| 109 | +184 |
- #' @inheritParams argument_convention+ #' |
||
| 110 | +185 |
- #' @param data (`data.frame`)\cr the data frame on which the model was fit.+ #' @return |
||
| 111 | +186 |
- #' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`.+ #' * `h_tab_rsp_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns. |
||
| 112 | +187 |
- #' This will be used when fitting the (conditional) logistic regression model on the left hand+ #' |
||
| 113 | +188 |
- #' side of the formula.+ #' @examples |
||
| 114 | +189 |
- #'+ #' # Starting from above `df`, zoom in on one biomarker and add required columns. |
||
| 115 | +190 |
- #' @return A fitted logistic regression model.+ #' df1 <- df[1, ] |
||
| 116 | +191 |
- #'+ #' df1$subgroup <- "All patients" |
||
| 117 | +192 |
- #' @section Model Specification:+ #' df1$row_type <- "content" |
||
| 118 | +193 |
- #'+ #' df1$var <- "ALL" |
||
| 119 | +194 |
- #' The `variables` list needs to include the following elements:+ #' df1$var_label <- "All patients" |
||
| 120 | +195 |
- #' * `arm`: Treatment arm variable name.+ #' |
||
| 121 | +196 |
- #' * `response`: The response arm variable name. Usually this is a 0/1 variable.+ #' h_tab_rsp_one_biomarker( |
||
| 122 | +197 |
- #' * `covariates`: This is either `NULL` (no covariates) or a character vector of covariate variable names.+ #' df1, |
||
| 123 | +198 |
- #' * `interaction`: This is either `NULL` (no interaction) or a string of a single covariate variable name already+ #' vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval")
|
||
| 124 | +199 |
- #' included in `covariates`. Then the interaction with the treatment arm is included in the model.+ #' ) |
||
| 125 | +200 |
#' |
||
| 126 | +201 |
- #' @examples+ #' @export |
||
| 127 | +202 |
- #' library(dplyr)+ h_tab_rsp_one_biomarker <- function(df, |
||
| 128 | +203 |
- #'+ vars, |
||
| 129 | +204 |
- #' adrs_f <- tern_ex_adrs %>%+ na_str = default_na_str(), |
||
| 130 | +205 |
- #' filter(PARAMCD == "BESRSPI") %>%+ .indent_mods = 0L) {
+ |
+ ||
| 206 | +8x | +
+ afuns <- a_response_subgroups(na_str = na_str)[vars]+ |
+ ||
| 207 | +8x | +
+ colvars <- d_rsp_subgroups_colvars(+ |
+ ||
| 208 | +8x | +
+ vars,+ |
+ ||
| 209 | +8x | +
+ conf_level = df$conf_level[1],+ |
+ ||
| 210 | +8x | +
+ method = df$pval_label[1] |
||
| 131 | +211 |
- #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ )+ |
+ ||
| 212 | +8x | +
+ h_tab_one_biomarker(+ |
+ ||
| 213 | +8x | +
+ df = df,+ |
+ ||
| 214 | +8x | +
+ afuns = afuns,+ |
+ ||
| 215 | +8x | +
+ colvars = colvars,+ |
+ ||
| 216 | +8x | +
+ na_str = na_str,+ |
+ ||
| 217 | +8x | +
+ .indent_mods = .indent_mods |
||
| 132 | +218 |
- #' mutate(+ ) |
||
| 133 | +219 |
- #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ } |
| 134 | +1 |
- #' RACE = factor(RACE),+ #' Missing data |
||
| 135 | +2 |
- #' SEX = factor(SEX)+ #' |
||
| 136 | +3 |
- #' )+ #' @description `r lifecycle::badge("stable")`
|
||
| 137 | +4 |
- #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ #' |
||
| 138 | +5 |
- #' mod1 <- fit_logistic(+ #' Substitute missing data with a string or factor level. |
||
| 139 | +6 |
- #' data = adrs_f,+ #' |
||
| 140 | +7 |
- #' variables = list(+ #' @param x (`factor` or `character`)\cr values for which any missing values should be substituted. |
||
| 141 | +8 |
- #' response = "Response",+ #' @param label (`string`)\cr string that missing data should be replaced with. |
||
| 142 | +9 |
- #' arm = "ARMCD",+ #' |
||
| 143 | +10 |
- #' covariates = c("AGE", "RACE")
+ #' @return `x` with any `NA` values substituted by `label`. |
||
| 144 | +11 |
- #' )+ #' |
||
| 145 | +12 |
- #' )+ #' @examples |
||
| 146 | +13 |
- #' mod2 <- fit_logistic(+ #' explicit_na(c(NA, "a", "b")) |
||
| 147 | +14 |
- #' data = adrs_f,+ #' is.na(explicit_na(c(NA, "a", "b"))) |
||
| 148 | +15 |
- #' variables = list(+ #' |
||
| 149 | +16 |
- #' response = "Response",+ #' explicit_na(factor(c(NA, "a", "b"))) |
||
| 150 | +17 |
- #' arm = "ARMCD",+ #' is.na(explicit_na(factor(c(NA, "a", "b")))) |
||
| 151 | +18 |
- #' covariates = c("AGE", "RACE"),
+ #' |
||
| 152 | +19 |
- #' interaction = "AGE"+ #' explicit_na(sas_na(c("a", "")))
|
||
| 153 | +20 |
- #' )+ #' |
||
| 154 | +21 |
- #' )+ #' @export |
||
| 155 | +22 |
- #'+ explicit_na <- function(x, label = "<Missing>") {
+ |
+ ||
| 23 | +256x | +
+ checkmate::assert_string(label) |
||
| 156 | +24 |
- #' @export+ + |
+ ||
| 25 | +256x | +
+ if (is.factor(x)) {
+ |
+ ||
| 26 | +151x | +
+ x <- forcats::fct_na_value_to_level(x, label)+ |
+ ||
| 27 | +151x | +
+ forcats::fct_drop(x, only = label)+ |
+ ||
| 28 | +105x | +
+ } else if (is.character(x)) {
+ |
+ ||
| 29 | +105x | +
+ x[is.na(x)] <- label+ |
+ ||
| 30 | +105x | +
+ x |
||
| 157 | +31 |
- fit_logistic <- function(data,+ } else {
+ |
+ ||
| 32 | +! | +
+ stop("only factors and character vectors allowed")
|
||
| 158 | +33 |
- variables = list(+ } |
||
| 159 | +34 |
- response = "Response",+ } |
||
| 160 | +35 |
- arm = "ARMCD",+ |
||
| 161 | +36 |
- covariates = NULL,+ #' Convert strings to `NA` |
||
| 162 | +37 |
- interaction = NULL,+ #' |
||
| 163 | +38 |
- strata = NULL+ #' @description `r lifecycle::badge("stable")`
|
||
| 164 | +39 |
- ),+ #' |
||
| 165 | +40 |
- response_definition = "response") {
+ #' SAS imports missing data as empty strings or strings with whitespaces only. This helper function can be used to |
||
| 166 | -75x | +|||
| 41 | +
- assert_df_with_variables(data, variables)+ #' convert these values to `NA`s. |
|||
| 167 | -75x | +|||
| 42 | +
- checkmate::assert_subset(names(variables), c("response", "arm", "covariates", "interaction", "strata"))
+ #' |
|||
| 168 | -75x | +|||
| 43 | +
- checkmate::assert_string(response_definition)+ #' @inheritParams explicit_na |
|||
| 169 | -75x | +|||
| 44 | +
- checkmate::assert_true(grepl("response", response_definition))
+ #' @param empty (`flag`)\cr if `TRUE`, empty strings get replaced by `NA`. |
|||
| 170 | +45 |
-
+ #' @param whitespaces (`flag`)\cr if `TRUE`, strings made from only whitespaces get replaced with `NA`. |
||
| 171 | -75x | +|||
| 46 | +
- response_definition <- sub(+ #' |
|||
| 172 | -75x | +|||
| 47 | +
- pattern = "response",+ #' @return `x` with `""` and/or whitespace-only values substituted by `NA`, depending on the values of |
|||
| 173 | -75x | +|||
| 48 | +
- replacement = variables$response,+ #' `empty` and `whitespaces`. |
|||
| 174 | -75x | +|||
| 49 | +
- x = response_definition,+ #' |
|||
| 175 | -75x | +|||
| 50 | +
- fixed = TRUE+ #' @examples |
|||
| 176 | +51 |
- )+ #' sas_na(c("1", "", " ", " ", "b"))
|
||
| 177 | -75x | +|||
| 52 | +
- form <- paste0(response_definition, " ~ ", variables$arm)+ #' sas_na(factor(c("", " ", "b")))
|
|||
| 178 | -75x | +|||
| 53 | +
- if (!is.null(variables$covariates)) {
+ #' |
|||
| 179 | -29x | +|||
| 54 | +
- form <- paste0(form, " + ", paste(variables$covariates, collapse = " + "))+ #' is.na(sas_na(c("1", "", " ", " ", "b")))
|
|||
| 180 | +55 |
- }+ #' |
||
| 181 | -75x | +|||
| 56 | +
- if (!is.null(variables$interaction)) {
+ #' @export |
|||
| 182 | -18x | +|||
| 57 | +
- checkmate::assert_string(variables$interaction)+ sas_na <- function(x, empty = TRUE, whitespaces = TRUE) {
|
|||
| 183 | -18x | +58 | +245x |
- checkmate::assert_subset(variables$interaction, variables$covariates)+ checkmate::assert_flag(empty) |
| 184 | -18x | +59 | +245x |
- form <- paste0(form, " + ", variables$arm, ":", variables$interaction)+ checkmate::assert_flag(whitespaces) |
| 185 | +60 |
- }+ |
||
| 186 | -75x | +61 | +245x |
- if (!is.null(variables$strata)) {
+ if (is.factor(x)) {
|
| 187 | -14x | +62 | +135x |
- strata_arg <- if (length(variables$strata) > 1) {
+ empty_levels <- levels(x) == "" |
| 188 | -7x | +63 | +11x |
- paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
+ if (empty && any(empty_levels)) levels(x)[empty_levels] <- NA |
| 189 | +64 |
- } else {
+
|
||
| 190 | -7x | +65 | +135x |
- variables$strata+ ws_levels <- grepl("^\\s+$", levels(x))
+ |
+
| 66 | +! | +
+ if (whitespaces && any(ws_levels)) levels(x)[ws_levels] <- NA |
||
| 191 | +67 |
- }+ |
||
| 192 | -14x | +68 | +135x |
- form <- paste0(form, "+ strata(", strata_arg, ")")
+ x |
| 193 | -+ | |||
| 69 | +110x |
- }+ } else if (is.character(x)) {
|
||
| 194 | -75x | +70 | +110x |
- formula <- stats::as.formula(form)+ if (empty) x[x == ""] <- NA_character_ |
| 195 | -75x | +|||
| 71 | +
- if (is.null(variables$strata)) {
+
|
|||
| 196 | -61x | +72 | +110x |
- stats::glm(+ if (whitespaces) x[grepl("^\\s+$", x)] <- NA_character_
|
| 197 | -61x | +|||
| 73 | +
- formula = formula,+ |
|||
| 198 | -61x | +74 | +110x |
- data = data,+ x |
| 199 | -61x | +|||
| 75 | +
- family = stats::binomial("logit")
+ } else {
+ |
+ |||
| 76 | +! | +
+ stop("only factors and character vectors allowed")
|
||
| 200 | +77 |
- )+ } |
||
| 201 | +78 |
- } else {
+ } |
||
| 202 | -14x | +
| 1 | +
- clogit_with_tryCatch(+ #' Custom split functions |
|||
| 203 | -14x | +|||
| 2 | +
- formula = formula,+ #' |
|||
| 204 | -14x | +|||
| 3 | +
- data = data,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 205 | -14x | +|||
| 4 | +
- x = TRUE+ #' |
|||
| 206 | +5 |
- )+ #' Collection of useful functions that are expanding on the core list of functions |
||
| 207 | +6 |
- }+ #' provided by `rtables`. See [rtables::custom_split_funs] and [rtables::make_split_fun()] |
||
| 208 | +7 |
- }+ #' for more information on how to make a custom split function. All these functions |
||
| 209 | +8 |
-
+ #' work with [rtables::split_rows_by()] argument `split_fun` to modify the way the split |
||
| 210 | +9 |
- #' Custom tidy method for binomial GLM results+ #' happens. For other split functions, consider consulting [`rtables::split_funcs`]. |
||
| 211 | +10 |
#' |
||
| 212 | +11 |
- #' @description `r lifecycle::badge("stable")`
+ #' @seealso [rtables::make_split_fun()] |
||
| 213 | +12 |
#' |
||
| 214 | +13 |
- #' Helper method (for [broom::tidy()]) to prepare a data frame from a `glm` object+ #' @name utils_split_funs |
||
| 215 | +14 |
- #' with `binomial` family.+ NULL |
||
| 216 | +15 |
- #'+ |
||
| 217 | +16 |
- #' @inheritParams argument_convention+ #' @describeIn utils_split_funs Split function to place reference group facet at a specific position |
||
| 218 | +17 |
- #' @param at (`numeric` or `NULL`)\cr optional values for the interaction variable. Otherwise the median is used.+ #' during post-processing stage. |
||
| 219 | +18 |
- #' @param x (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family.+ #' |
||
| 220 | +19 |
- #'+ #' @param position (`string` or `integer`)\cr position to use for the reference group facet. Can be `"first"`, |
||
| 221 | +20 |
- #' @return A `data.frame` containing the tidied model.+ #' `"last"`, or a specific position. |
||
| 222 | +21 |
#' |
||
| 223 | +22 |
- #' @method tidy glm+ #' @return |
||
| 224 | +23 |
- #'+ #' * `ref_group_position()` returns an utility function that puts the reference group |
||
| 225 | +24 |
- #' @seealso [h_logistic_regression] for relevant helper functions.+ #' as first, last or at a certain position and needs to be assigned to `split_fun`. |
||
| 226 | +25 |
#' |
||
| 227 | +26 |
#' @examples |
||
| 228 | +27 |
#' library(dplyr) |
||
| 229 | +28 |
- #' library(broom)+ #' |
||
| 230 | +29 |
- #'+ #' dat <- data.frame( |
||
| 231 | +30 |
- #' adrs_f <- tern_ex_adrs %>%+ #' x = factor(letters[1:5], levels = letters[5:1]), |
||
| 232 | +31 |
- #' filter(PARAMCD == "BESRSPI") %>%+ #' y = 1:5 |
||
| 233 | +32 |
- #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ #' ) |
||
| 234 | +33 |
- #' mutate(+ #' |
||
| 235 | +34 |
- #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ #' # With rtables layout functions |
||
| 236 | +35 |
- #' RACE = factor(RACE),+ #' basic_table() %>% |
||
| 237 | +36 |
- #' SEX = factor(SEX)+ #' split_cols_by("x", ref_group = "c", split_fun = ref_group_position("last")) %>%
|
||
| 238 | +37 |
- #' )+ #' analyze("y") %>%
|
||
| 239 | +38 |
- #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ #' build_table(dat) |
||
| 240 | +39 |
- #' mod1 <- fit_logistic(+ #' |
||
| 241 | +40 |
- #' data = adrs_f,+ #' # With tern layout funcitons |
||
| 242 | +41 |
- #' variables = list(+ #' adtte_f <- tern_ex_adtte %>% |
||
| 243 | +42 |
- #' response = "Response",+ #' filter(PARAMCD == "OS") %>% |
||
| 244 | +43 |
- #' arm = "ARMCD",+ #' mutate( |
||
| 245 | +44 |
- #' covariates = c("AGE", "RACE")
+ #' AVAL = day2month(AVAL), |
||
| 246 | +45 |
- #' )+ #' is_event = CNSR == 0 |
||
| 247 | +46 |
- #' )+ #' ) |
||
| 248 | +47 |
- #' mod2 <- fit_logistic(+ #' |
||
| 249 | +48 |
- #' data = adrs_f,+ #' basic_table() %>% |
||
| 250 | +49 |
- #' variables = list(+ #' split_cols_by(var = "ARMCD", ref_group = "ARM B", split_fun = ref_group_position("first")) %>%
|
||
| 251 | +50 |
- #' response = "Response",+ #' add_colcounts() %>% |
||
| 252 | +51 |
- #' arm = "ARMCD",+ #' surv_time( |
||
| 253 | +52 |
- #' covariates = c("AGE", "RACE"),
+ #' vars = "AVAL", |
||
| 254 | +53 |
- #' interaction = "AGE"+ #' var_labels = "Survival Time (Months)", |
||
| 255 | +54 |
- #' )+ #' is_event = "is_event", |
||
| 256 | +55 |
- #' )+ #' ) %>% |
||
| 257 | +56 |
- #'+ #' build_table(df = adtte_f) |
||
| 258 | +57 |
- #' df <- tidy(mod1, conf_level = 0.99)+ #' |
||
| 259 | +58 |
- #' df2 <- tidy(mod2, conf_level = 0.99)+ #' basic_table() %>% |
||
| 260 | +59 |
- #'+ #' split_cols_by(var = "ARMCD", ref_group = "ARM B", split_fun = ref_group_position(2)) %>% |
||
| 261 | +60 |
- #' @export+ #' add_colcounts() %>% |
||
| 262 | +61 |
- tidy.glm <- function(x, # nolint+ #' surv_time( |
||
| 263 | +62 |
- conf_level = 0.95,+ #' vars = "AVAL", |
||
| 264 | +63 |
- at = NULL,+ #' var_labels = "Survival Time (Months)", |
||
| 265 | +64 |
- ...) {
- |
- ||
| 266 | -5x | -
- checkmate::assert_class(x, "glm")+ #' is_event = "is_event", |
||
| 267 | -5x | +|||
| 65 | +
- checkmate::assert_set_equal(x$family$family, "binomial")+ #' ) %>% |
|||
| 268 | +66 |
-
+ #' build_table(df = adtte_f) |
||
| 269 | -5x | +|||
| 67 | +
- terms_name <- attr(stats::terms(x), "term.labels")+ #' |
|||
| 270 | -5x | +|||
| 68 | +
- xs_class <- attr(x$terms, "dataClasses")+ #' @export |
|||
| 271 | -5x | +|||
| 69 | +
- interaction <- terms_name[which(!terms_name %in% names(xs_class))]+ ref_group_position <- function(position = "first") {
|
|||
| 272 | -5x | +70 | +20x |
- df <- if (length(interaction) == 0) {
+ make_split_fun( |
| 273 | -2x | +71 | +20x |
- h_logistic_simple_terms(+ post = list( |
| 274 | -2x | +72 | +20x |
- x = terms_name,+ function(splret, spl, fulldf) {
|
| 275 | -2x | +73 | +57x |
- fit_glm = x,+ if (!"ref_group_value" %in% methods::slotNames(spl)) {
|
| 276 | -2x | +74 | +1x |
- conf_level = conf_level+ stop("Reference group is undefined.")
|
| 277 | +75 |
- )+ } |
||
| 278 | +76 |
- } else {
+
|
||
| 279 | -3x | +77 | +56x |
- h_logistic_inter_terms(+ spl_var <- rtables:::spl_payload(spl) |
| 280 | -3x | +78 | +56x |
- x = terms_name,+ fulldf[[spl_var]] <- factor(fulldf[[spl_var]]) |
| 281 | -3x | +79 | +56x |
- fit_glm = x,+ init_lvls <- levels(fulldf[[spl_var]]) |
| 282 | -3x | +|||
| 80 | +
- conf_level = conf_level,+ |
|||
| 283 | -3x | +81 | +56x |
- at = at+ if (!all(names(splret$values) %in% init_lvls)) {
+ |
+
| 82 | +! | +
+ stop("This split function does not work with combination facets.")
|
||
| 284 | +83 |
- )+ } |
||
| 285 | +84 |
- }+ |
||
| 286 | -5x | +85 | +56x |
- for (var in c("variable", "term", "interaction", "reference")) {
+ ref_group_pos <- which(init_lvls == rtables:::spl_ref_group(spl)) |
| 287 | -20x | +86 | +56x |
- df[[var]] <- factor(df[[var]], levels = unique(df[[var]]))+ pos_choices <- c("first", "last")
|
| 288 | -+ | |||
| 87 | +56x |
- }+ if (checkmate::test_choice(position, pos_choices) && position == "first") {
|
||
| 289 | -5x | +88 | +41x |
- df+ pos <- 0 |
| 290 | -+ | |||
| 89 | +15x |
- }+ } else if (checkmate::test_choice(position, pos_choices) && position == "last") {
|
||
| 291 | -+ | |||
| 90 | +12x |
-
+ pos <- length(init_lvls) |
||
| 292 | -+ | |||
| 91 | +3x |
- #' Logistic regression multivariate column layout function+ } else if (checkmate::test_int(position, lower = 1, upper = length(init_lvls))) {
|
||
| 293 | -+ | |||
| 92 | +3x |
- #'+ pos <- position - 1 |
||
| 294 | +93 |
- #' @description `r lifecycle::badge("stable")`
+ } else {
|
||
| 295 | -+ | |||
| 94 | +! |
- #'+ stop("Wrong input for ref group position. It must be 'first', 'last', or a integer.")
|
||
| 296 | +95 |
- #' Layout-creating function which creates a multivariate column layout summarizing logistic+ } |
||
| 297 | +96 |
- #' regression results. This function is a wrapper for [rtables::split_cols_by_multivar()].+ |
||
| 298 | -+ | |||
| 97 | +56x |
- #'+ reord_lvls <- append(init_lvls[-ref_group_pos], init_lvls[ref_group_pos], after = pos) |
||
| 299 | -+ | |||
| 98 | +56x |
- #' @inheritParams argument_convention+ ord <- match(reord_lvls, names(splret$values)) |
||
| 300 | +99 |
- #'+ |
||
| 301 | -+ | |||
| 100 | +56x |
- #' @return A layout object suitable for passing to further layouting functions. Adding this+ make_split_result( |
||
| 302 | -+ | |||
| 101 | +56x |
- #' function to an `rtable` layout will split the table into columns corresponding to+ splret$values[ord], |
||
| 303 | -+ | |||
| 102 | +56x |
- #' statistics `df`, `estimate`, `std_error`, `odds_ratio`, `ci`, and `pvalue`.+ splret$datasplit[ord], |
||
| 304 | -+ | |||
| 103 | +56x |
- #'+ splret$labels[ord] |
||
| 305 | +104 |
- #' @export+ ) |
||
| 306 | +105 |
- logistic_regression_cols <- function(lyt,+ } |
||
| 307 | +106 |
- conf_level = 0.95) {
- |
- ||
| 308 | -4x | -
- vars <- c("df", "estimate", "std_error", "odds_ratio", "ci", "pvalue")
- |
- ||
| 309 | -4x | -
- var_labels <- c(+ ) |
||
| 310 | -4x | +|||
| 107 | +
- df = "Degrees of Freedom",+ ) |
|||
| 311 | -4x | +|||
| 108 | +
- estimate = "Parameter Estimate",+ } |
|||
| 312 | -4x | +|||
| 109 | +
- std_error = "Standard Error",+ |
|||
| 313 | -4x | +|||
| 110 | +
- odds_ratio = "Odds Ratio",+ #' @describeIn utils_split_funs Split function to change level order based on an `integer` |
|||
| 314 | -4x | +|||
| 111 | +
- ci = paste("Wald", f_conf_level(conf_level)),
+ #' vector or a `character` vector that represent the split variable's factor levels. |
|||
| 315 | -4x | +|||
| 112 | +
- pvalue = "p-value"+ #' |
|||
| 316 | +113 |
- )+ #' @param order (`character` or `numeric`)\cr vector of ordering indices for the split facets. |
||
| 317 | -4x | +|||
| 114 | +
- split_cols_by_multivar(+ #' |
|||
| 318 | -4x | +|||
| 115 | +
- lyt = lyt,+ #' @return |
|||
| 319 | -4x | +|||
| 116 | +
- vars = vars,+ #' * `level_order()` returns an utility function that changes the original levels' order, |
|||
| 320 | -4x | +|||
| 117 | +
- varlabels = var_labels+ #' depending on input `order` and split levels. |
|||
| 321 | +118 |
- )+ #' |
||
| 322 | +119 |
- }+ #' @examples |
||
| 323 | +120 |
-
+ #' # level_order -------- |
||
| 324 | +121 |
- #' Logistic regression summary table+ #' # Even if default would bring ref_group first, the original order puts it last |
||
| 325 | +122 |
- #'+ #' basic_table() %>% |
||
| 326 | +123 |
- #' @description `r lifecycle::badge("stable")`
+ #' split_cols_by("Species", split_fun = level_order(c(1, 3, 2))) %>%
|
||
| 327 | +124 |
- #'+ #' analyze("Sepal.Length") %>%
|
||
| 328 | +125 |
- #' Constructor for content functions to be used in [`summarize_logistic()`] to summarize+ #' build_table(iris) |
||
| 329 | +126 |
- #' logistic regression results. This function is a wrapper for [rtables::summarize_row_groups()].+ #' |
||
| 330 | +127 |
- #'+ #' # character vector |
||
| 331 | +128 |
- #' @inheritParams argument_convention+ #' new_order <- level_order(levels(iris$Species)[c(1, 3, 2)]) |
||
| 332 | +129 |
- #' @param flag_var (`string`)\cr variable name identifying which row should be used in this+ #' basic_table() %>% |
||
| 333 | +130 |
- #' content function.+ #' split_cols_by("Species", ref_group = "virginica", split_fun = new_order) %>%
|
||
| 334 | +131 |
- #'+ #' analyze("Sepal.Length") %>%
|
||
| 335 | +132 |
- #' @return A content function.+ #' build_table(iris) |
||
| 336 | +133 |
#' |
||
| 337 | +134 |
#' @export |
||
| 338 | +135 |
- logistic_summary_by_flag <- function(flag_var, na_str = default_na_str(), .indent_mods = NULL) {
+ level_order <- function(order) {
|
||
| 339 | -10x | +136 | +2x |
- checkmate::assert_string(flag_var)+ make_split_fun( |
| 340 | -10x | +137 | +2x |
- function(lyt) {
+ post = list( |
| 341 | -10x | +138 | +2x |
- cfun_list <- list(+ function(splret, spl, fulldf) {
|
| 342 | -10x | +139 | +4x |
- df = cfun_by_flag("df", flag_var, format = "xx.", .indent_mods = .indent_mods),
+ if (checkmate::test_integerish(order)) {
|
| 343 | -10x | +140 | +1x |
- estimate = cfun_by_flag("estimate", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
+ checkmate::assert_integerish(order, lower = 1, upper = length(splret$values)) |
| 344 | -10x | +141 | +1x |
- std_error = cfun_by_flag("std_error", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
+ ord <- order+ |
+
| 142 | ++ |
+ } else {
|
||
| 345 | -10x | +143 | +3x |
- odds_ratio = cfun_by_flag("odds_ratio", flag_var, format = ">999.99", .indent_mods = .indent_mods),
+ checkmate::assert_character(order, len = length(splret$values)) |
| 346 | -10x | +144 | +3x |
- ci = cfun_by_flag("ci", flag_var, format = format_extreme_values_ci(2L), .indent_mods = .indent_mods),
+ checkmate::assert_set_equal(order, names(splret$values), ordered = FALSE) |
| 347 | -10x | +145 | +3x |
- pvalue = cfun_by_flag("pvalue", flag_var, format = "x.xxxx | (<0.0001)", .indent_mods = .indent_mods)
+ ord <- match(order, names(splret$values)) |
| 348 | +146 |
- )+ } |
||
| 349 | -10x | +147 | +4x |
- summarize_row_groups(+ make_split_result( |
| 350 | -10x | +148 | +4x |
- lyt = lyt,+ splret$values[ord], |
| 351 | -10x | +149 | +4x |
- cfun = cfun_list,+ splret$datasplit[ord], |
| 352 | -10x | +150 | +4x |
- na_str = na_str+ splret$labels[ord] |
| 353 | +151 | ++ |
+ )+ |
+ |
| 152 | ++ |
+ }+ |
+ ||
| 153 |
) |
|||
| 354 | +154 |
- }+ ) |
||
| 355 | +155 |
}@@ -131209,14 +134699,14 @@ tern coverage - 95.59% |
| 1 |
- #' Count the number of patients with particular flags+ #' Incidence rate estimation |
||
| 5 |
- #' The analyze function [count_patients_with_flags()] creates a layout element to calculate counts of patients for+ #' The analyze function [estimate_incidence_rate()] creates a layout element to estimate an event rate adjusted for |
||
| 6 |
- #' which user-specified flags are present.+ #' person-years at risk, otherwise known as incidence rate. The primary analysis variable specified via `vars` is |
||
| 7 |
- #'+ #' the person-years at risk. In addition to this variable, the `n_events` variable for number of events observed (where |
||
| 8 |
- #' This function analyzes primary analysis variable `var` which indicates unique subject identifiers. Flags+ #' a value of 1 means an event was observed and 0 means that no event was observed) must also be specified. |
||
| 9 |
- #' variables to analyze are specified by the user via the `flag_variables` argument, and must either take value+ #' |
||
| 10 |
- #' `TRUE` (flag present) or `FALSE` (flag absent) for each record.+ #' @inheritParams argument_convention |
||
| 11 |
- #'+ #' @param control (`list`)\cr parameters for estimation details, specified by using |
||
| 12 |
- #' If there are multiple records with the same flag present for a patient, only one occurrence is counted.+ #' the helper function [control_incidence_rate()]. Possible parameter options are: |
||
| 13 |
- #'+ #' * `conf_level` (`proportion`)\cr confidence level for the estimated incidence rate. |
||
| 14 |
- #' @inheritParams argument_convention+ #' * `conf_type` (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar` |
||
| 15 |
- #' @param flag_variables (`character`)\cr a vector specifying the names of `logical` variables from analysis dataset+ #' for confidence interval type. |
||
| 16 |
- #' used for counting the number of unique identifiers.+ #' * `input_time_unit` (`string`)\cr `day`, `week`, `month`, or `year` (default) |
||
| 17 |
- #' @param flag_labels (`character`)\cr vector of labels to use for flag variables. If any labels are also specified via+ #' indicating time unit for data input. |
||
| 18 |
- #' the `.labels` parameter, the `.labels` values will take precedence and replace these labels.+ #' * `num_pt_year` (`numeric`)\cr time unit for desired output (in person-years). |
||
| 19 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' @param n_events (`string`)\cr name of integer variable indicating whether an event has been observed (1) or not (0). |
||
| 20 |
- #'+ #' @param id_var (`string`)\cr name of variable used as patient identifier if `"n_unique"` is included in `.stats`. |
||
| 21 |
- #' Options are: ``r shQuote(get_stats("count_patients_with_flags"))``
+ #' Defaults to `"USUBJID"`. |
||
| 22 |
- #'+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 23 |
- #' @seealso [count_patients_with_event]+ #' |
||
| 24 |
- #'+ #' Options are: ``r shQuote(get_stats("estimate_incidence_rate"), type = "sh")``
|
||
| 25 |
- #' @name count_patients_with_flags+ #' @param summarize (`flag`)\cr whether the function should act as an analyze function (`summarize = FALSE`), or a |
||
| 26 |
- #' @order 1+ #' summarize function (`summarize = TRUE`). Defaults to `FALSE`. |
||
| 27 |
- NULL+ #' @param label_fmt (`string`)\cr how labels should be formatted after a row split occurs if `summarize = TRUE`. The |
||
| 28 |
-
+ #' string should use `"%s"` to represent row split levels, and `"%.labels"` to represent labels supplied to the |
||
| 29 |
- #' @describeIn count_patients_with_flags Statistics function which counts the number of patients for which+ #' `.labels` argument. Defaults to `"%s - %.labels"`. |
||
| 30 |
- #' a particular flag variable is `TRUE`.+ #' |
||
| 31 |
- #'+ #' @seealso [control_incidence_rate()] and helper functions [h_incidence_rate]. |
||
| 32 |
- #' @inheritParams analyze_variables+ #' |
||
| 33 |
- #' @param .var (`string`)\cr name of the column that contains the unique identifier.+ #' @examples |
||
| 34 |
- #'+ #' df <- data.frame( |
||
| 35 |
- #' @note If `flag_labels` is not specified, variables labels will be extracted from `df`. If variables are not+ #' USUBJID = as.character(seq(6)), |
||
| 36 |
- #' labeled, variable names will be used instead. Alternatively, a named `vector` can be supplied to+ #' CNSR = c(0, 1, 1, 0, 0, 0), |
||
| 37 |
- #' `flag_variables` such that within each name-value pair the name corresponds to the variable name and the value is+ #' AVAL = c(10.1, 20.4, 15.3, 20.8, 18.7, 23.4), |
||
| 38 |
- #' the label to use for this variable.+ #' ARM = factor(c("A", "A", "A", "B", "B", "B")),
|
||
| 39 |
- #'+ #' STRATA1 = factor(c("X", "Y", "Y", "X", "X", "Y"))
|
||
| 40 |
- #' @return+ #' ) |
||
| 41 |
- #' * `s_count_patients_with_flags()` returns the count and the fraction of unique identifiers with each particular+ #' df$n_events <- 1 - df$CNSR |
||
| 42 |
- #' flag as a list of statistics `n`, `count`, `count_fraction`, and `n_blq`, with one element per flag.+ #' |
||
| 43 |
- #'+ #' @name incidence_rate |
||
| 44 |
- #' @examples+ #' @order 1 |
||
| 45 |
- #' # `s_count_patients_with_flags()`+ NULL |
||
| 46 |
- #'+ |
||
| 47 |
- #' s_count_patients_with_flags(+ #' @describeIn incidence_rate Statistics function which estimates the incidence rate and the |
||
| 48 |
- #' adae,+ #' associated confidence interval. |
||
| 49 |
- #' "SUBJID",+ #' |
||
| 50 |
- #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
+ #' @return |
||
| 51 |
- #' denom = "N_col",+ #' * `s_incidence_rate()` returns the following statistics: |
||
| 52 |
- #' .N_col = 1000+ #' - `person_years`: Total person-years at risk. |
||
| 53 |
- #' )+ #' - `n_events`: Total number of events observed. |
||
| 54 |
- #'+ #' - `rate`: Estimated incidence rate. |
||
| 55 |
- #' @export+ #' - `rate_ci`: Confidence interval for the incidence rate. |
||
| 56 |
- s_count_patients_with_flags <- function(df,+ #' - `n_unique`: Total number of patients with at least one event observed. |
||
| 57 |
- .var,+ #' - `n_rate`: Total number of events observed & estimated incidence rate. |
||
| 58 |
- flag_variables,+ #' |
||
| 59 |
- flag_labels = NULL,+ #' @keywords internal |
||
| 60 |
- .N_col = ncol(df), # nolint+ s_incidence_rate <- function(df, |
||
| 61 |
- .N_row = nrow(df), # nolint+ .var, |
||
| 62 |
- denom = c("n", "N_col", "N_row")) {
+ n_events, |
||
| 63 | -41x | +
- checkmate::assert_character(flag_variables)+ is_event = lifecycle::deprecated(), |
|
| 64 | -41x | +
- if (!is.null(flag_labels)) {
+ id_var = "USUBJID", |
|
| 65 | -6x | +
- checkmate::assert_character(flag_labels, len = length(flag_variables), any.missing = FALSE)+ control = control_incidence_rate()) {
|
|
| 66 | -6x | +17x |
- flag_names <- flag_labels+ if (lifecycle::is_present(is_event)) {
|
| 67 | -+ | ! |
- } else {
+ checkmate::assert_string(is_event) |
| 68 | -35x | +! |
- if (is.null(names(flag_variables))) {
+ lifecycle::deprecate_warn( |
| 69 | -20x | +! |
- flag_names <- formatters::var_labels(df[flag_variables], fill = TRUE)+ "0.9.6", "s_incidence_rate(is_event)", "s_incidence_rate(n_events)" |
| 70 |
- } else {
+ ) |
||
| 71 | -15x | +! |
- flag_names <- unname(flag_variables)+ n_events <- is_event |
| 72 | -15x | +! |
- flag_variables <- names(flag_variables)+ df[[n_events]] <- as.numeric(df[[is_event]]) |
| 73 |
- }+ } |
||
| 74 |
- }+ |
||
| 75 | -+ | 17x |
-
+ assert_df_with_variables(df, list(tte = .var, n_events = n_events)) |
| 76 | -41x | +17x |
- checkmate::assert_subset(flag_variables, colnames(df))+ checkmate::assert_string(.var) |
| 77 | -41x | +17x |
- temp <- sapply(flag_variables, function(x) {
+ checkmate::assert_string(n_events) |
| 78 | -123x | +17x |
- tmp <- Map(function(y) which(df[[y]]), x)+ checkmate::assert_string(id_var) |
| 79 | -123x | +17x |
- position_satisfy_flags <- Reduce(intersect, tmp)+ checkmate::assert_numeric(df[[.var]], any.missing = FALSE) |
| 80 | -123x | +17x |
- id_satisfy_flags <- as.character(unique(df[position_satisfy_flags, ][[.var]]))+ checkmate::assert_integerish(df[[n_events]], any.missing = FALSE) |
| 81 | -123x | +
- s_count_values(+ |
|
| 82 | -123x | +17x |
- x = as.character(unique(df[[.var]])),+ n_unique <- n_available(unique(df[[id_var]][df[[n_events]] == 1])) |
| 83 | -123x | +17x |
- values = id_satisfy_flags,+ input_time_unit <- control$input_time_unit |
| 84 | -123x | +17x |
- denom = denom,+ num_pt_year <- control$num_pt_year |
| 85 | -123x | +17x |
- .N_col = .N_col,+ conf_level <- control$conf_level |
| 86 | -123x | +17x |
- .N_row = .N_row+ person_years <- sum(df[[.var]], na.rm = TRUE) * ( |
| 87 | -+ | 17x |
- )+ 1 * (input_time_unit == "year") + |
| 88 | -+ | 17x |
- })+ 1 / 12 * (input_time_unit == "month") + |
| 89 | -41x | +17x |
- colnames(temp) <- flag_names+ 1 / 52.14 * (input_time_unit == "week") + |
| 90 | -41x | +17x |
- temp <- data.frame(t(temp))+ 1 / 365.24 * (input_time_unit == "day") |
| 91 | -41x | +
- result <- as.list(temp)+ ) |
|
| 92 | -41x | +17x |
- if (length(flag_variables) == 1) {
+ n_events <- sum(df[[n_events]], na.rm = TRUE) |
| 93 | -1x | +
- for (i in seq(3)) names(result[[i]]) <- flag_names[1]+ |
|
| 94 | -+ | 17x |
- }+ result <- h_incidence_rate( |
| 95 | -41x | +17x |
- result+ person_years, |
| 96 | -+ | 17x |
- }+ n_events, |
| 97 | -+ | 17x |
-
+ control |
| 98 |
- #' @describeIn count_patients_with_flags Formatted analysis function which is used as `afun`+ ) |
||
| 99 | -+ | 17x |
- #' in `count_patients_with_flags()`.+ list( |
| 100 | -+ | 17x |
- #'+ person_years = formatters::with_label(person_years, "Total patient-years at risk"), |
| 101 | -+ | 17x |
- #' @return+ n_events = formatters::with_label(n_events, "Number of adverse events observed"), |
| 102 | -+ | 17x |
- #' * `a_count_patients_with_flags()` returns the corresponding list with formatted [rtables::CellValue()].+ rate = formatters::with_label(result$rate, paste("AE rate per", num_pt_year, "patient-years")),
|
| 103 | -+ | 17x |
- #'+ rate_ci = formatters::with_label(result$rate_ci, f_conf_level(conf_level)), |
| 104 | -+ | 17x |
- #' @examples+ n_unique = formatters::with_label(n_unique, "Total number of patients with at least one adverse event"), |
| 105 | -+ | 17x |
- #' a_count_patients_with_flags(+ n_rate = formatters::with_label( |
| 106 | -+ | 17x |
- #' adae,+ c(n_events, result$rate), |
| 107 | -+ | 17x |
- #' .N_col = 10L,+ paste("Number of adverse events observed (AE rate per", num_pt_year, "patient-years)")
|
| 108 |
- #' .N_row = 10L,+ ) |
||
| 109 |
- #' .var = "USUBJID",+ ) |
||
| 110 |
- #' flag_variables = c("fl1", "fl2", "fl3", "fl4")
+ } |
||
| 111 |
- #' )+ |
||
| 112 |
- #'+ #' @describeIn incidence_rate Formatted analysis function which is used as `afun` in `estimate_incidence_rate()`. |
||
| 113 |
- #' @export+ #' |
||
| 114 |
- a_count_patients_with_flags <- function(df,+ #' @return |
||
| 115 |
- labelstr = "",+ #' * `a_incidence_rate()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 116 |
- flag_variables,+ #' |
||
| 117 |
- flag_labels = NULL,+ #' @examples |
||
| 118 |
- denom = c("n", "N_col", "N_row"),
+ #' a_incidence_rate( |
||
| 119 |
- .N_col = ncol(df), # nolint+ #' df, |
||
| 120 |
- .N_row = nrow(df), # nolint+ #' .var = "AVAL", |
||
| 121 |
- .df_row,+ #' .df_row = df, |
||
| 122 |
- .var = NULL,+ #' n_events = "n_events" |
||
| 123 |
- .stats = NULL,+ #' ) |
||
| 124 |
- .formats = NULL,+ #' |
||
| 125 |
- .labels = NULL,+ #' @export |
||
| 126 |
- .indent_mods = NULL,+ a_incidence_rate <- function(df, |
||
| 127 |
- na_str = default_na_str()) {
+ labelstr = "", |
||
| 128 | -31x | +
- x_stats <- s_count_patients_with_flags(+ .var, |
|
| 129 | -31x | +
- df = df, .var = .var, flag_variables = flag_variables, flag_labels = flag_labels,+ .df_row, |
|
| 130 | -31x | +
- .N_col = .N_col, .N_row = .N_row, denom = denom+ n_events, |
|
| 131 |
- )+ id_var = "USUBJID", |
||
| 132 |
-
+ control = control_incidence_rate(), |
||
| 133 | -31x | +
- if (is.null(unlist(x_stats))) {
+ .stats = NULL, |
|
| 134 | -! | +
- return(NULL)+ .formats = c( |
|
| 135 |
- }+ "person_years" = "xx.x", |
||
| 136 |
-
+ "n_events" = "xx", |
||
| 137 |
- # Fill in with formatting defaults if needed+ "rate" = "xx.xx", |
||
| 138 | -31x | +
- .stats <- get_stats("count_patients_with_flags", stats_in = .stats)
+ "rate_ci" = "(xx.xx, xx.xx)", |
|
| 139 | -31x | +
- x_stats <- x_stats[.stats]+ "n_unique" = "xx", |
|
| 140 |
-
+ "n_rate" = "xx (xx.x)" |
||
| 141 | -31x | +
- .formats <- get_formats_from_stats(.stats, .formats)+ ), |
|
| 142 |
-
+ .labels = NULL, |
||
| 143 |
- # label formatting+ .indent_mods = NULL, |
||
| 144 | -31x | +
- x_nms <- paste(rep(.stats, each = length(flag_variables)), flag_variables, sep = ".")+ na_str = default_na_str(), |
|
| 145 | -31x | +
- new_lbls <- if (!is.null(.labels)) .labels[names(.labels) %in% x_nms] else NULL+ label_fmt = "%s - %.labels") {
|
|
| 146 | -31x | +16x |
- .labels <- .unlist_keep_nulls(get_labels_from_stats(.stats, .labels,+ checkmate::assert_string(label_fmt) |
| 147 | -31x | +
- levels_per_stats = lapply(x_stats, names)+ |
|
| 148 | -+ | 16x |
- )) %>%+ x_stats <- s_incidence_rate( |
| 149 | -31x | +16x |
- setNames(x_nms)+ df = df, .var = .var, n_events = n_events, id_var = id_var, control = control |
| 150 |
-
+ ) |
||
| 151 | -+ | 16x |
- # indent mod formatting+ if (is.null(unlist(x_stats))) {
|
| 152 | -31x | +! |
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods, row_nms = flag_variables)+ return(NULL) |
| 153 |
-
+ } |
||
| 155 |
- # Ungroup statistics with values for each level of x+ # Fill in with defaults |
||
| 156 | -31x | +16x |
- x_ungrp <- ungroup_stats(x_stats, .formats, list())+ formats_def <- formals()$.formats %>% eval() |
| 157 | -31x | +16x |
- x_stats <- x_ungrp[["x"]] %>% setNames(x_nms)+ .formats <- c(.formats, formats_def)[!duplicated(names(c(.formats, formats_def)))] |
| 158 | -31x | +16x |
- .formats <- x_ungrp[[".formats"]] %>% setNames(x_nms)+ labels_def <- sapply(x_stats, \(x) attributes(x)$label) |
| 159 | -+ | 16x |
-
+ .labels <- c(.labels, labels_def)[!duplicated(names(c(.labels, labels_def)))] |
| 160 | -+ | 16x |
- # Auto format handling+ if (nzchar(labelstr) > 0) {
|
| 161 | -31x | +8x |
- .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)+ .labels <- sapply(.labels, \(x) gsub("%.labels", x, gsub("%s", labelstr, label_fmt)))
|
| 162 |
-
+ } |
||
| 163 | -31x | +
- in_rows(+ |
|
| 164 | -31x | +
- .list = x_stats,+ # Fill in with formatting defaults if needed |
|
| 165 | -31x | +16x |
- .formats = .formats,+ .stats <- get_stats("estimate_incidence_rate", stats_in = .stats)
|
| 166 | -31x | +16x |
- .names = names(.labels),+ .formats <- get_formats_from_stats(.stats, .formats) |
| 167 | -31x | +16x |
- .labels = .labels,+ .labels <- get_labels_from_stats(.stats, .labels) |
| 168 | -31x | +16x |
- .indent_mods = .indent_mods,+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods) |
| 169 | -31x | +
- .format_na_strs = na_str+ |
|
| 170 | -+ | 16x |
- )+ x_stats <- x_stats[.stats] |
| 171 |
- }+ |
||
| 172 | -+ | 16x |
-
+ in_rows( |
| 173 | -+ | 16x |
- #' @describeIn count_patients_with_flags Layout-creating function which can take statistics function+ .list = x_stats, |
| 174 | -+ | 16x |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ .formats = .formats, |
| 175 | -+ | 16x |
- #'+ .labels = .labels %>% .unlist_keep_nulls(), |
| 176 | -+ | 16x |
- #' @return+ .indent_mods = .indent_mods %>% .unlist_keep_nulls(), |
| 177 | -+ | 16x |
- #' * `count_patients_with_flags()` returns a layout object suitable for passing to further layouting functions,+ .format_na_strs = na_str |
| 178 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ ) |
||
| 179 |
- #' the statistics from `s_count_patients_with_flags()` to the table layout.+ } |
||
| 180 |
- #'+ |
||
| 181 |
- #' @examples+ #' @describeIn incidence_rate Layout-creating function which can take statistics function arguments |
||
| 182 |
- #' # Add labelled flag variables to analysis dataset.+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 183 |
- #' adae <- tern_ex_adae %>%+ #' |
||
| 184 |
- #' dplyr::mutate(+ #' @return |
||
| 185 |
- #' fl1 = TRUE %>% with_label("Total AEs"),
+ #' * `estimate_incidence_rate()` returns a layout object suitable for passing to further layouting functions, |
||
| 186 |
- #' fl2 = (TRTEMFL == "Y") %>%+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 187 |
- #' with_label("Total number of patients with at least one adverse event"),
+ #' the statistics from `s_incidence_rate()` to the table layout. |
||
| 188 |
- #' fl3 = (TRTEMFL == "Y" & AEOUT == "FATAL") %>%+ #' |
||
| 189 |
- #' with_label("Total number of patients with fatal AEs"),
+ #' @examples |
||
| 190 |
- #' fl4 = (TRTEMFL == "Y" & AEOUT == "FATAL" & AEREL == "Y") %>%+ #' basic_table(show_colcounts = TRUE) %>% |
||
| 191 |
- #' with_label("Total number of patients with related fatal AEs")
+ #' split_cols_by("ARM") %>%
|
||
| 192 |
- #' )+ #' estimate_incidence_rate( |
||
| 193 |
- #'+ #' vars = "AVAL", |
||
| 194 |
- #' lyt <- basic_table() %>%+ #' n_events = "n_events", |
||
| 195 |
- #' split_cols_by("ARM") %>%
+ #' control = control_incidence_rate( |
||
| 196 |
- #' add_colcounts() %>%+ #' input_time_unit = "month", |
||
| 197 |
- #' count_patients_with_flags(+ #' num_pt_year = 100 |
||
| 198 |
- #' "SUBJID",+ #' ) |
||
| 199 |
- #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
+ #' ) %>% |
||
| 200 |
- #' denom = "N_col"+ #' build_table(df) |
||
| 201 |
- #' )+ #' |
||
| 202 |
- #'+ #' # summarize = TRUE |
||
| 203 |
- #' build_table(lyt, adae, alt_counts_df = tern_ex_adsl)+ #' basic_table(show_colcounts = TRUE) %>% |
||
| 204 |
- #'+ #' split_cols_by("ARM") %>%
|
||
| 205 |
- #' @export+ #' split_rows_by("STRATA1", child_labels = "visible") %>%
|
||
| 206 |
- #' @order 2+ #' estimate_incidence_rate( |
||
| 207 |
- count_patients_with_flags <- function(lyt,+ #' vars = "AVAL", |
||
| 208 |
- var,+ #' n_events = "n_events", |
||
| 209 |
- flag_variables,+ #' .stats = c("n_unique", "n_rate"),
|
||
| 210 |
- flag_labels = NULL,+ #' summarize = TRUE, |
||
| 211 |
- var_labels = var,+ #' label_fmt = "%.labels" |
||
| 212 |
- show_labels = "hidden",+ #' ) %>% |
||
| 213 |
- riskdiff = FALSE,+ #' build_table(df) |
||
| 214 |
- na_str = default_na_str(),+ #' |
||
| 215 |
- nested = TRUE,+ #' @export |
||
| 216 |
- ...,+ #' @order 2 |
||
| 217 |
- table_names = paste0("tbl_flags_", var),
+ estimate_incidence_rate <- function(lyt, |
||
| 218 |
- .stats = "count_fraction",+ vars, |
||
| 219 |
- .formats = list(count_fraction = format_count_fraction_fixed_dp),+ n_events, |
||
| 220 |
- .indent_mods = NULL,+ id_var = "USUBJID", |
||
| 221 |
- .labels = NULL) {
+ control = control_incidence_rate(), |
||
| 222 | -11x | +
- checkmate::assert_flag(riskdiff)+ na_str = default_na_str(), |
|
| 223 | -11x | +
- extra_args <- list(+ nested = TRUE, |
|
| 224 | -11x | +
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str+ summarize = FALSE, |
|
| 225 |
- )+ label_fmt = "%s - %.labels", |
||
| 226 | -11x | +
- s_args <- list(flag_variables = flag_variables, flag_labels = flag_labels, ...)+ ..., |
|
| 227 |
-
+ show_labels = "hidden", |
||
| 228 | -11x | +
- if (isFALSE(riskdiff)) {
+ table_names = vars, |
|
| 229 | -9x | +
- extra_args <- c(extra_args, s_args)+ .stats = c("person_years", "n_events", "rate", "rate_ci"),
|
|
| 230 |
- } else {
+ .formats = NULL, |
||
| 231 | -2x | +
- extra_args <- c(+ .labels = NULL, |
|
| 232 | -2x | +
- extra_args,+ .indent_mods = NULL) {
|
|
| 233 | -2x | +5x |
- list(+ extra_args <- c( |
| 234 | -2x | +5x |
- afun = list("s_count_patients_with_flags" = a_count_patients_with_flags),
+ list(.stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str), |
| 235 | -2x | +5x |
- s_args = s_args+ list(n_events = n_events, id_var = id_var, control = control, label_fmt = label_fmt, ...) |
| 236 |
- )+ ) |
||
| 237 |
- )+ |
||
| 238 | -+ | 5x |
- }+ if (!summarize) {
|
| 239 | -+ | 3x |
-
+ analyze( |
| 240 | -11x | +3x |
- analyze(+ lyt, |
| 241 | -11x | +3x |
- lyt = lyt,+ vars, |
| 242 | -11x | +3x |
- vars = var,+ show_labels = show_labels, |
| 243 | -11x | +3x |
- afun = ifelse(isFALSE(riskdiff), a_count_patients_with_flags, afun_riskdiff),+ table_names = table_names, |
| 244 | -11x | +3x |
- var_labels = var_labels,+ afun = a_incidence_rate, |
| 245 | -11x | +3x |
- show_labels = show_labels,+ na_str = na_str, |
| 246 | -11x | +3x |
- table_names = table_names,+ nested = nested, |
| 247 | -11x | +3x |
- na_str = na_str,+ extra_args = extra_args |
| 248 | -11x | ++ |
+ )+ |
+
| 249 | ++ |
+ } else {
+ |
+ |
| 250 | +2x | +
+ summarize_row_groups(+ |
+ |
| 251 | +2x | +
+ lyt,+ |
+ |
| 252 | +2x | +
+ vars,+ |
+ |
| 253 | +2x | +
+ cfun = a_incidence_rate,+ |
+ |
| 254 | +2x | +
+ na_str = na_str,+ |
+ |
| 255 | +2x |
- nested = nested,+ extra_args = extra_args |
|
| 249 | -11x | +||
| 256 | +
- extra_args = extra_args+ ) |
||
| 250 | +257 |
- )+ } |
|
| 251 | +258 |
}@@ -132972,14 +136511,14 @@ tern coverage - 95.59% |
| 1 |
- #' Tabulate biomarker effects on survival by subgroup+ #' Cox proportional hazards regression |
||
| 5 |
- #' The [tabulate_survival_biomarkers()] function creates a layout element to tabulate the estimated effects of multiple+ #' Fits a Cox regression model and estimates hazard ratio to describe the effect size in a survival analysis. |
||
| 6 |
- #' continuous biomarker variables on survival across subgroups, returning statistics including median survival time and+ #' |
||
| 7 |
- #' hazard ratio for each population subgroup. The table is created from `df`, a list of data frames returned by+ #' @inheritParams argument_convention |
||
| 8 |
- #' [extract_survival_biomarkers()], with the statistics to include specified via the `vars` parameter.+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 10 |
- #' A forest plot can be created from the resulting table using the [g_forest()] function.+ #' Options are: ``r shQuote(get_stats("summarize_coxreg"), type = "sh")``
|
||
| 12 |
- #' @inheritParams fit_coxreg_multivar+ #' @details Cox models are the most commonly used methods to estimate the magnitude of |
||
| 13 |
- #' @inheritParams survival_duration_subgroups+ #' the effect in survival analysis. It assumes proportional hazards: the ratio |
||
| 14 |
- #' @inheritParams argument_convention+ #' of the hazards between groups (e.g., two arms) is constant over time. |
||
| 15 |
- #' @param df (`data.frame`)\cr containing all analysis variables, as returned by+ #' This ratio is referred to as the "hazard ratio" (HR) and is one of the |
||
| 16 |
- #' [extract_survival_biomarkers()].+ #' most commonly reported metrics to describe the effect size in survival |
||
| 17 |
- #' @param vars (`character`)\cr the names of statistics to be reported among:+ #' analysis (NEST Team, 2020). |
||
| 18 |
- #' * `n_tot_events`: Total number of events per group.+ #' |
||
| 19 |
- #' * `n_tot`: Total number of observations per group.+ #' @seealso [fit_coxreg] for relevant fitting functions, [h_cox_regression] for relevant |
||
| 20 |
- #' * `median`: Median survival time.+ #' helper functions, and [tidy_coxreg] for custom tidy methods. |
||
| 21 |
- #' * `hr`: Hazard ratio.+ #' |
||
| 22 |
- #' * `ci`: Confidence interval of hazard ratio.+ #' @examples |
||
| 23 |
- #' * `pval`: p-value of the effect.+ #' library(survival) |
||
| 24 |
- #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` are required.+ #' |
||
| 25 |
- #'+ #' # Testing dataset [survival::bladder]. |
||
| 26 |
- #' @details These functions create a layout starting from a data frame which contains+ #' set.seed(1, kind = "Mersenne-Twister") |
||
| 27 |
- #' the required statistics. The tables are then typically used as input for forest plots.+ #' dta_bladder <- with( |
||
| 28 |
- #'+ #' data = bladder[bladder$enum < 5, ], |
||
| 29 |
- #' @examples+ #' tibble::tibble( |
||
| 30 |
- #' library(dplyr)+ #' TIME = stop, |
||
| 31 |
- #'+ #' STATUS = event, |
||
| 32 |
- #' adtte <- tern_ex_adtte+ #' ARM = as.factor(rx), |
||
| 33 |
- #'+ #' COVAR1 = as.factor(enum) %>% formatters::with_label("A Covariate Label"),
|
||
| 34 |
- #' # Save variable labels before data processing steps.+ #' COVAR2 = factor( |
||
| 35 |
- #' adtte_labels <- formatters::var_labels(adtte)+ #' sample(as.factor(enum)), |
||
| 36 |
- #'+ #' levels = 1:4, labels = c("F", "F", "M", "M")
|
||
| 37 |
- #' adtte_f <- adtte %>%+ #' ) %>% formatters::with_label("Sex (F/M)")
|
||
| 38 |
- #' filter(PARAMCD == "OS") %>%+ #' ) |
||
| 39 |
- #' mutate(+ #' ) |
||
| 40 |
- #' AVALU = as.character(AVALU),+ #' dta_bladder$AGE <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
||
| 41 |
- #' is_event = CNSR == 0+ #' dta_bladder$STUDYID <- factor("X")
|
||
| 42 |
- #' )+ #' |
||
| 43 |
- #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
+ #' u1_variables <- list( |
||
| 44 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
|
||
| 45 |
- #'+ #' ) |
||
| 46 |
- #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`,+ #' |
||
| 47 |
- #' # in multiple regression models containing one covariate `RACE`,+ #' u2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
|
||
| 48 |
- #' # as well as one stratification variable `STRATA1`. The subgroups+ #' |
||
| 49 |
- #' # are defined by the levels of `BMRKR2`.+ #' m1_variables <- list( |
||
| 50 |
- #'+ #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
|
||
| 51 |
- #' df <- extract_survival_biomarkers(+ #' ) |
||
| 52 |
- #' variables = list(+ #' |
||
| 53 |
- #' tte = "AVAL",+ #' m2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
|
||
| 54 |
- #' is_event = "is_event",+ #' |
||
| 55 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' @name cox_regression |
||
| 56 |
- #' strata = "STRATA1",+ #' @order 1 |
||
| 57 |
- #' covariates = "SEX",+ NULL |
||
| 58 |
- #' subgroups = "BMRKR2"+ |
||
| 59 |
- #' ),+ #' @describeIn cox_regression Statistics function that transforms results tabulated |
||
| 60 |
- #' label_all = "Total Patients",+ #' from [fit_coxreg_univar()] or [fit_coxreg_multivar()] into a list. |
||
| 61 |
- #' data = adtte_f+ #' |
||
| 62 |
- #' )+ #' @param model_df (`data.frame`)\cr contains the resulting model fit from a [fit_coxreg] |
||
| 63 |
- #' df+ #' function with tidying applied via [broom::tidy()]. |
||
| 64 |
- #'+ #' @param .stats (`character`)\cr the names of statistics to be reported among: |
||
| 65 |
- #' # Here we group the levels of `BMRKR2` manually.+ #' * `n`: number of observations (univariate only) |
||
| 66 |
- #' df_grouped <- extract_survival_biomarkers(+ #' * `hr`: hazard ratio |
||
| 67 |
- #' variables = list(+ #' * `ci`: confidence interval |
||
| 68 |
- #' tte = "AVAL",+ #' * `pval`: p-value of the treatment effect |
||
| 69 |
- #' is_event = "is_event",+ #' * `pval_inter`: p-value of the interaction effect between the treatment and the covariate (univariate only) |
||
| 70 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' @param .which_vars (`character`)\cr which rows should statistics be returned for from the given model. |
||
| 71 |
- #' strata = "STRATA1",+ #' Defaults to `"all"`. Other options include `"var_main"` for main effects, `"inter"` for interaction effects, |
||
| 72 |
- #' covariates = "SEX",+ #' and `"multi_lvl"` for multivariate model covariate level rows. When `.which_vars` is `"all"`, specific |
||
| 73 |
- #' subgroups = "BMRKR2"+ #' variables can be selected by specifying `.var_nms`. |
||
| 74 |
- #' ),+ #' @param .var_nms (`character`)\cr the `term` value of rows in `df` for which `.stats` should be returned. Typically |
||
| 75 |
- #' data = adtte_f,+ #' this is the name of a variable. If using variable labels, `var` should be a vector of both the desired |
||
| 76 |
- #' groups_lists = list(+ #' variable name and the variable label in that order to see all `.stats` related to that variable. When `.which_vars` |
||
| 77 |
- #' BMRKR2 = list(+ #' is `"var_main"`, `.var_nms` should be only the variable name. |
||
| 78 |
- #' "low" = "LOW",+ #' |
||
| 79 |
- #' "low/medium" = c("LOW", "MEDIUM"),
+ #' @return |
||
| 80 |
- #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ #' * `s_coxreg()` returns the selected statistic for from the Cox regression model for the selected variable(s). |
||
| 81 |
- #' )+ #' |
||
| 82 |
- #' )+ #' @examples |
||
| 83 |
- #' )+ #' # s_coxreg |
||
| 84 |
- #' df_grouped+ #' |
||
| 85 |
- #'+ #' # Univariate |
||
| 86 |
- #' @name survival_biomarkers_subgroups+ #' univar_model <- fit_coxreg_univar(variables = u1_variables, data = dta_bladder) |
||
| 87 |
- #' @order 1+ #' df1 <- broom::tidy(univar_model) |
||
| 88 |
- NULL+ #' |
||
| 89 |
-
+ #' s_coxreg(model_df = df1, .stats = "hr") |
||
| 90 |
- #' Prepare survival data estimates for multiple biomarkers in a single data frame+ #' |
||
| 91 |
- #'+ #' # Univariate with interactions |
||
| 92 |
- #' @description `r lifecycle::badge("stable")`
+ #' univar_model_inter <- fit_coxreg_univar( |
||
| 93 |
- #'+ #' variables = u1_variables, control = control_coxreg(interaction = TRUE), data = dta_bladder |
||
| 94 |
- #' Prepares estimates for number of events, patients and median survival times, as well as hazard ratio estimates,+ #' ) |
||
| 95 |
- #' confidence intervals and p-values, for multiple biomarkers across population subgroups in a single data frame.+ #' df1_inter <- broom::tidy(univar_model_inter) |
||
| 96 |
- #' `variables` corresponds to the names of variables found in `data`, passed as a named `list` and requires elements+ #' |
||
| 97 |
- #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables), and optionally `subgroups` and `strata`.+ #' s_coxreg(model_df = df1_inter, .stats = "hr", .which_vars = "inter", .var_nms = "COVAR1") |
||
| 98 |
- #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ #' |
||
| 99 |
- #'+ #' # Univariate without treatment arm - only "COVAR2" covariate effects |
||
| 100 |
- #' @inheritParams argument_convention+ #' univar_covs_model <- fit_coxreg_univar(variables = u2_variables, data = dta_bladder) |
||
| 101 |
- #' @inheritParams fit_coxreg_multivar+ #' df1_covs <- broom::tidy(univar_covs_model) |
||
| 102 |
- #' @inheritParams survival_duration_subgroups+ #' |
||
| 103 |
- #'+ #' s_coxreg(model_df = df1_covs, .stats = "hr", .var_nms = c("COVAR2", "Sex (F/M)"))
|
||
| 104 |
- #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_tot_events`,+ #' |
||
| 105 |
- #' `median`, `hr`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`,+ #' # Multivariate. |
||
| 106 |
- #' `var_label`, and `row_type`.+ #' multivar_model <- fit_coxreg_multivar(variables = m1_variables, data = dta_bladder) |
||
| 107 |
- #'+ #' df2 <- broom::tidy(multivar_model) |
||
| 108 |
- #' @seealso [h_coxreg_mult_cont_df()] which is used internally, [tabulate_survival_biomarkers()].+ #' |
||
| 109 |
- #'+ #' s_coxreg(model_df = df2, .stats = "pval", .which_vars = "var_main", .var_nms = "COVAR1") |
||
| 110 |
- #' @export+ #' s_coxreg( |
||
| 111 |
- extract_survival_biomarkers <- function(variables,+ #' model_df = df2, .stats = "pval", .which_vars = "multi_lvl", |
||
| 112 |
- data,+ #' .var_nms = c("COVAR1", "A Covariate Label")
|
||
| 113 |
- groups_lists = list(),+ #' ) |
||
| 114 |
- control = control_coxreg(),+ #' |
||
| 115 |
- label_all = "All Patients") {
+ #' # Multivariate without treatment arm - only "COVAR1" main effect |
||
| 116 | -6x | +
- if ("strat" %in% names(variables)) {
+ #' multivar_covs_model <- fit_coxreg_multivar(variables = m2_variables, data = dta_bladder) |
|
| 117 | -! | +
- warning(+ #' df2_covs <- broom::tidy(multivar_covs_model) |
|
| 118 | -! | +
- "Warning: the `strat` element name of the `variables` list argument to `extract_survival_biomarkers() ",+ #' |
|
| 119 | -! | +
- "was deprecated in tern 0.9.4.\n ",+ #' s_coxreg(model_df = df2_covs, .stats = "hr") |
|
| 120 | -! | +
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ #' |
|
| 121 |
- )+ #' @export |
||
| 122 | -! | +
- variables[["strata"]] <- variables[["strat"]]+ s_coxreg <- function(model_df, .stats, .which_vars = "all", .var_nms = NULL) {
|
|
| 123 | -+ | 291x |
- }+ assert_df_with_variables(model_df, list(term = "term", stat = .stats)) |
| 124 | -+ | 291x |
-
+ checkmate::assert_multi_class(model_df$term, classes = c("factor", "character"))
|
| 125 | -6x | +291x |
- checkmate::assert_list(variables)+ model_df$term <- as.character(model_df$term) |
| 126 | -6x | +291x |
- checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ .var_nms <- .var_nms[!is.na(.var_nms)] |
| 127 | -6x | +
- checkmate::assert_string(label_all)+ |
|
| 128 | -+ | 289x |
-
+ if (length(.var_nms) > 0) model_df <- model_df[model_df$term %in% .var_nms, ] |
| 129 | -+ | 69x |
- # Start with all patients.+ if (.which_vars == "multi_lvl") model_df$term <- tail(.var_nms, 1) |
| 130 | -6x | +
- result_all <- h_coxreg_mult_cont_df(+ |
|
| 131 | -6x | +
- variables = variables,+ # We need a list with names corresponding to the stats to display of equal length to the list of stats. |
|
| 132 | -6x | +291x |
- data = data,+ y <- split(model_df, f = model_df$term, drop = FALSE) |
| 133 | -6x | +291x |
- control = control+ y <- stats::setNames(y, nm = rep(.stats, length(y))) |
| 134 |
- )+ |
||
| 135 | -6x | +291x |
- result_all$subgroup <- label_all+ if (.which_vars == "var_main") {
|
| 136 | -6x | +128x |
- result_all$var <- "ALL"+ y <- lapply(y, function(x) x[1, ]) # only main effect |
| 137 | -6x | +163x |
- result_all$var_label <- label_all+ } else if (.which_vars %in% c("inter", "multi_lvl")) {
|
| 138 | -6x | +120x |
- result_all$row_type <- "content"+ y <- lapply(y, function(x) if (nrow(y[[1]]) > 1) x[-1, ] else x) # exclude main effect |
| 139 | -6x | +
- if (is.null(variables$subgroups)) {
+ } |
|
| 140 |
- # Only return result for all patients.+ |
||
| 141 | -1x | +291x |
- result_all+ lapply( |
| 142 | -+ | 291x |
- } else {
+ X = y, |
| 143 | -+ | 291x |
- # Add subgroups results.+ FUN = function(x) {
|
| 144 | -5x | +295x |
- l_data <- h_split_by_subgroups(+ z <- as.list(x[[.stats]]) |
| 145 | -5x | +295x |
- data,+ stats::setNames(z, nm = x$term_label) |
| 146 | -5x | +
- variables$subgroups,+ } |
|
| 147 | -5x | +
- groups_lists = groups_lists+ ) |
|
| 148 |
- )+ } |
||
| 149 | -5x | +
- l_result <- lapply(l_data, function(grp) {
+
|
|
| 150 | -25x | +
- result <- h_coxreg_mult_cont_df(+ #' @describeIn cox_regression Analysis function which is used as `afun` in [rtables::analyze()] |
|
| 151 | -25x | +
- variables = variables,+ #' and `cfun` in [rtables::summarize_row_groups()] within `summarize_coxreg()`. |
|
| 152 | -25x | +
- data = grp$df,+ #' |
|
| 153 | -25x | +
- control = control+ #' @param eff (`flag`)\cr whether treatment effect should be calculated. Defaults to `FALSE`. |
|
| 154 |
- )+ #' @param var_main (`flag`)\cr whether main effects should be calculated. Defaults to `FALSE`. |
||
| 155 | -25x | +
- result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ #' @param na_str (`string`)\cr custom string to replace all `NA` values with. Defaults to `""`. |
|
| 156 | -25x | +
- cbind(result, result_labels)+ #' @param cache_env (`environment`)\cr an environment object used to cache the regression model in order to |
|
| 157 |
- })+ #' avoid repeatedly fitting the same model for every row in the table. Defaults to `NULL` (no caching). |
||
| 158 | -5x | +
- result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ #' @param varlabels (`list`)\cr a named list corresponds to the names of variables found in data, passed |
|
| 159 | -5x | +
- result_subgroups$row_type <- "analysis"+ #' as a named list and corresponding to time, event, arm, strata, and covariates terms. If arm is missing |
|
| 160 | -5x | +
- rbind(+ #' from variables, then only Cox model(s) including the covariates will be fitted and the corresponding |
|
| 161 | -5x | +
- result_all,+ #' effect estimates will be tabulated later. |
|
| 162 | -5x | +
- result_subgroups+ #' |
|
| 163 |
- )+ #' @return |
||
| 164 |
- }+ #' * `a_coxreg()` returns formatted [rtables::CellValue()]. |
||
| 165 |
- }+ #' |
||
| 166 |
-
+ #' @examples |
||
| 167 |
- #' @describeIn survival_biomarkers_subgroups Table-creating function which creates a table+ #' a_coxreg( |
||
| 168 |
- #' summarizing biomarker effects on survival by subgroup.+ #' df = dta_bladder, |
||
| 169 |
- #'+ #' labelstr = "Label 1", |
||
| 170 |
- #' @param label_all `r lifecycle::badge("deprecated")`\cr please assign the `label_all` parameter within the
+ #' variables = u1_variables, |
||
| 171 |
- #' [extract_survival_biomarkers()] function when creating `df`.+ #' .spl_context = list(value = "COVAR1"), |
||
| 172 |
- #'+ #' .stats = "n", |
||
| 173 |
- #' @return An `rtables` table summarizing biomarker effects on survival by subgroup.+ #' .formats = "xx" |
||
| 174 |
- #'+ #' ) |
||
| 175 |
- #' @note In contrast to [tabulate_survival_subgroups()] this tabulation function does+ #' |
||
| 176 |
- #' not start from an input layout `lyt`. This is because internally the table is+ #' a_coxreg( |
||
| 177 |
- #' created by combining multiple subtables.+ #' df = dta_bladder, |
||
| 178 |
- #'+ #' labelstr = "", |
||
| 179 |
- #' @seealso [h_tab_surv_one_biomarker()] which is used internally, [extract_survival_biomarkers()].+ #' variables = u1_variables, |
||
| 180 |
- #'+ #' .spl_context = list(value = "COVAR2"), |
||
| 181 |
- #' @examples+ #' .stats = "pval", |
||
| 182 |
- #' ## Table with default columns.+ #' .formats = "xx.xxxx" |
||
| 183 |
- #' tabulate_survival_biomarkers(df)+ #' ) |
||
| 185 |
- #' ## Table with a manually chosen set of columns: leave out "pval", reorder.+ #' @export |
||
| 186 |
- #' tab <- tabulate_survival_biomarkers(+ a_coxreg <- function(df, |
||
| 187 |
- #' df = df,+ labelstr, |
||
| 188 |
- #' vars = c("n_tot_events", "ci", "n_tot", "median", "hr"),
+ eff = FALSE, |
||
| 189 |
- #' time_unit = as.character(adtte_f$AVALU[1])+ var_main = FALSE, |
||
| 190 |
- #' )+ multivar = FALSE, |
||
| 191 |
- #'+ variables, |
||
| 192 |
- #' ## Finally produce the forest plot.+ at = list(), |
||
| 193 |
- #' \donttest{
+ control = control_coxreg(), |
||
| 194 |
- #' g_forest(tab, xlim = c(0.8, 1.2))+ .spl_context, |
||
| 195 |
- #' }+ .stats, |
||
| 196 |
- #'+ .formats, |
||
| 197 |
- #' @export+ .indent_mods = NULL, |
||
| 198 |
- #' @order 2+ na_str = "", |
||
| 199 |
- tabulate_survival_biomarkers <- function(df,+ cache_env = NULL) {
|
||
| 200 | -+ | 288x |
- vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
+ cov_no_arm <- !multivar && !"arm" %in% names(variables) && control$interaction # special case: univar no arm |
| 201 | -+ | 288x |
- groups_lists = list(),+ cov <- tail(.spl_context$value, 1) # current variable/covariate |
| 202 | -+ | 288x |
- control = control_coxreg(),+ var_lbl <- formatters::var_labels(df)[cov] # check for df labels |
| 203 | -+ | 288x |
- label_all = lifecycle::deprecated(),+ if (length(labelstr) > 1) {
|
| 204 | -+ | 8x |
- time_unit = NULL,+ labelstr <- if (cov %in% names(labelstr)) labelstr[[cov]] else var_lbl # use df labels if none |
| 205 | -+ | 280x |
- na_str = default_na_str(),+ } else if (!is.na(var_lbl) && labelstr == cov && cov %in% variables$covariates) {
|
| 206 | -+ | 67x |
- .indent_mods = 0L) {
+ labelstr <- var_lbl |
| 207 | -5x | +
- if (lifecycle::is_present(label_all)) {
+ } |
|
| 208 | -1x | +288x |
- lifecycle::deprecate_warn(+ if (eff || multivar || cov_no_arm) {
|
| 209 | -1x | +143x |
- "0.9.5", "tabulate_survival_biomarkers(label_all)",+ control$interaction <- FALSE |
| 210 | -1x | +
- details = paste(+ } else {
|
|
| 211 | -1x | +145x |
- "Please assign the `label_all` parameter within the",+ variables$covariates <- cov |
| 212 | -1x | +50x |
- "`extract_survival_biomarkers()` function when creating `df`."+ if (var_main) control$interaction <- TRUE |
| 213 | - |
- )- |
- |
| 214 | -- |
- )- |
- |
| 215 | -
} |
||
| 216 | -- | - - | -|
| 217 | -5x | -
- checkmate::assert_data_frame(df)- |
- |
| 218 | -5x | -
- checkmate::assert_character(df$biomarker)- |
- |
| 219 | -5x | -
- checkmate::assert_character(df$biomarker_label)- |
- |
| 220 | -5x | -
- checkmate::assert_subset(vars, get_stats("tabulate_survival_biomarkers"))
- |
- |
| 221 | -- | - - | -|
| 222 | -5x | -
- extra_args <- list(groups_lists = groups_lists, control = control)- |
- |
| 223 | -- | - - | -|
| 224 | -5x | -
- df_subs <- split(df, f = df$biomarker)- |
- |
| 225 | -5x | -
- tabs <- lapply(df_subs, FUN = function(df_sub) {
- |
- |
| 226 | -9x | -
- tab_sub <- h_tab_surv_one_biomarker(- |
- |
| 227 | -9x | -
- df = df_sub,- |
- |
| 228 | -9x | -
- vars = vars,- |
- |
| 229 | -9x | -
- time_unit = time_unit,- |
- |
| 230 | -9x | -
- na_str = na_str,- |
- |
| 231 | -9x | -
- .indent_mods = .indent_mods,- |
- |
| 232 | -9x | -
- extra_args = extra_args- |
- |
| 233 | -- |
- )- |
- |
| 234 | -- |
- # Insert label row as first row in table.- |
- |
| 235 | -9x | -
- label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1]- |
- |
| 236 | -9x | -
- tab_sub- |
- |
| 237 | -- |
- })- |
- |
| 238 | -5x | -
- result <- do.call(rbind, tabs)- |
- |
| 239 | -- | - - | -|
| 240 | -5x | -
- n_tot_ids <- grep("^n_tot", vars)
- |
- |
| 241 | -5x | -
- hr_id <- match("hr", vars)
- |
- |
| 242 | -5x | -
- ci_id <- match("ci", vars)
- |
- |
| 243 | -5x | -
- structure(- |
- |
| 244 | -5x | -
- result,- |
- |
| 245 | -5x | -
- forest_header = paste0(c("Higher", "Lower"), "\nBetter"),
- |
- |
| 246 | -5x | -
- col_x = hr_id,- |
- |
| 247 | -5x | -
- col_ci = ci_id,- |
- |
| 248 | -5x | -
- col_symbol_size = n_tot_ids[1]- |
- |
| 249 | -- |
- )- |
- |
| 250 | -- |
- }- |
-
| 1 | -- |
- #' Helper functions for tabulating biomarker effects on binary response by subgroup- |
- ||
| 2 | -- |
- #'- |
- ||
| 3 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- ||
| 4 | -- |
- #'- |
- ||
| 5 | -- |
- #' Helper functions which are documented here separately to not confuse the user- |
- ||
| 6 | -- |
- #' when reading about the user-facing functions.- |
- ||
| 7 | -- |
- #'- |
- ||
| 8 | -- |
- #' @inheritParams response_biomarkers_subgroups- |
- ||
| 9 | -- |
- #' @inheritParams extract_rsp_biomarkers- |
- ||
| 10 | -- |
- #' @inheritParams argument_convention- |
- ||
| 11 | -- |
- #'- |
- ||
| 12 | -- |
- #' @examples- |
- ||
| 13 | -- |
- #' library(dplyr)- |
- ||
| 14 | -- |
- #' library(forcats)- |
- ||
| 15 | -- |
- #'- |
- ||
| 16 | -- |
- #' adrs <- tern_ex_adrs- |
- ||
| 17 | -- |
- #' adrs_labels <- formatters::var_labels(adrs)- |
- ||
| 18 | -- |
- #'- |
- ||
| 19 | -- |
- #' adrs_f <- adrs %>%- |
- ||
| 20 | -- |
- #' filter(PARAMCD == "BESRSPI") %>%- |
- ||
| 21 | +214 |
- #' mutate(rsp = AVALC == "CR")+ |
||
| 22 | -+ | |||
| 215 | +288x |
- #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ if (is.null(cache_env[[cov]])) {
|
||
| 23 | -+ | |||
| 216 | +47x |
- #'+ if (!multivar) {
|
||
| 24 | -+ | |||
| 217 | +32x |
- #' @name h_response_biomarkers_subgroups+ model <- fit_coxreg_univar(variables = variables, data = df, at = at, control = control) %>% broom::tidy() |
||
| 25 | +218 |
- NULL+ } else {
|
||
| 26 | -+ | |||
| 219 | +15x |
-
+ model <- fit_coxreg_multivar(variables = variables, data = df, control = control) %>% broom::tidy() |
||
| 27 | +220 |
- #' @describeIn h_response_biomarkers_subgroups helps with converting the "response" function variable list+ } |
||
| 28 | -+ | |||
| 221 | +47x |
- #' to the "logistic regression" variable list. The reason is that currently there is an+ cache_env[[cov]] <- model |
||
| 29 | +222 |
- #' inconsistency between the variable names accepted by `extract_rsp_subgroups()` and `fit_logistic()`.+ } else {
|
||
| 30 | -+ | |||
| 223 | +241x |
- #'+ model <- cache_env[[cov]] |
||
| 31 | +224 |
- #' @param biomarker (`string`)\cr the name of the biomarker variable.+ } |
||
| 32 | -+ | |||
| 225 | +148x |
- #'+ if (!multivar && !var_main) model[, "pval_inter"] <- NA_real_ |
||
| 33 | +226 |
- #' @return+ |
||
| 34 | -+ | |||
| 227 | +288x |
- #' * `h_rsp_to_logistic_variables()` returns a named `list` of elements `response`, `arm`, `covariates`, and `strata`.+ if (cov_no_arm || (!cov_no_arm && !"arm" %in% names(variables) && is.numeric(df[[cov]]))) {
|
||
| 35 | -+ | |||
| 228 | +15x |
- #'+ multivar <- TRUE |
||
| 36 | -+ | |||
| 229 | +3x |
- #' @examples+ if (!cov_no_arm) var_main <- TRUE |
||
| 37 | +230 |
- #' # This is how the variable list is converted internally.+ } |
||
| 38 | +231 |
- #' h_rsp_to_logistic_variables(+ |
||
| 39 | -+ | |||
| 232 | +288x |
- #' variables = list(+ vars_coxreg <- list(which_vars = "all", var_nms = NULL) |
||
| 40 | -+ | |||
| 233 | +288x |
- #' rsp = "RSP",+ if (eff) {
|
||
| 41 | -+ | |||
| 234 | +65x |
- #' covariates = c("A", "B"),
+ if (multivar && !var_main) { # multivar treatment level
|
||
| 42 | -+ | |||
| 235 | +12x |
- #' strata = "D"+ var_lbl_arm <- formatters::var_labels(df)[[variables$arm]] |
||
| 43 | -+ | |||
| 236 | +12x |
- #' ),+ vars_coxreg[c("var_nms", "which_vars")] <- list(c(variables$arm, var_lbl_arm), "multi_lvl")
|
||
| 44 | +237 |
- #' biomarker = "AGE"+ } else { # treatment effect
|
||
| 45 | -+ | |||
| 238 | +53x |
- #' )+ vars_coxreg["var_nms"] <- variables$arm |
||
| 46 | -+ | |||
| 239 | +12x |
- #'+ if (var_main) vars_coxreg["which_vars"] <- "var_main" |
||
| 47 | +240 |
- #' @export+ } |
||
| 48 | +241 |
- h_rsp_to_logistic_variables <- function(variables, biomarker) {
+ } else {
|
||
| 49 | -49x | +242 | +223x |
- if ("strat" %in% names(variables)) {
+ if (!multivar || (multivar && var_main && !is.numeric(df[[cov]]))) { # covariate effect/level
|
| 50 | -! | +|||
| 243 | +166x |
- warning(+ vars_coxreg[c("var_nms", "which_vars")] <- list(cov, "var_main")
|
||
| 51 | -! | +|||
| 244 | +57x |
- "Warning: the `strat` element name of the `variables` list argument to `h_rsp_to_logistic_variables() ",+ } else if (multivar) { # multivar covariate level
|
||
| 52 | -! | +|||
| 245 | +57x |
- "was deprecated in tern 0.9.4.\n ",+ vars_coxreg[c("var_nms", "which_vars")] <- list(c(cov, var_lbl), "multi_lvl")
|
||
| 53 | -! | +|||
| 246 | +12x |
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ if (var_main) model[cov, .stats] <- NA_real_ |
||
| 54 | +247 |
- )+ } |
||
| 55 | -! | +|||
| 248 | +50x |
- variables[["strata"]] <- variables[["strat"]]+ if (!multivar && !var_main && control$interaction) vars_coxreg["which_vars"] <- "inter" # interaction effect |
||
| 56 | +249 |
} |
||
| 57 | -49x | +250 | +288x |
- checkmate::assert_list(variables)+ var_vals <- s_coxreg(model, .stats, .which_vars = vars_coxreg$which_vars, .var_nms = vars_coxreg$var_nms)[[1]] |
| 58 | -49x | +251 | +288x |
- checkmate::assert_string(variables$rsp)+ var_names <- if (all(grepl("\\(reference = ", names(var_vals))) && labelstr != tail(.spl_context$value, 1)) {
|
| 59 | -49x | +252 | +27x |
- checkmate::assert_string(biomarker)+ paste(c(labelstr, tail(strsplit(names(var_vals), " ")[[1]], 3)), collapse = " ") # "reference" main effect labels |
| 60 | -49x | +253 | +288x |
- list(+ } else if ((!multivar && !eff && !(!var_main && control$interaction) && nchar(labelstr) > 0) || |
| 61 | -49x | +254 | +288x |
- response = variables$rsp,+ (multivar && var_main && is.numeric(df[[cov]]))) { # nolint
|
| 62 | -49x | +255 | +71x |
- arm = biomarker,+ labelstr # other main effect labels |
| 63 | -49x | +256 | +288x |
- covariates = variables$covariates,+ } else if (multivar && !eff && !var_main && is.numeric(df[[cov]])) {
|
| 64 | -49x | +257 | +12x |
- strata = variables$strata+ "All" # multivar numeric covariate |
| 65 | +258 |
- )+ } else {
|
||
| 66 | -+ | |||
| 259 | +178x |
- }+ names(var_vals) |
||
| 67 | +260 |
-
+ } |
||
| 68 | -+ | |||
| 261 | +288x |
- #' @describeIn h_response_biomarkers_subgroups prepares estimates for number of responses, patients and+ in_rows( |
||
| 69 | -+ | |||
| 262 | +288x |
- #' overall response rate, as well as odds ratio estimates, confidence intervals and p-values, for multiple+ .list = var_vals, .names = var_names, .labels = var_names, .indent_mods = .indent_mods, |
||
| 70 | -+ | |||
| 263 | +288x |
- #' biomarkers in a given single data set.+ .formats = stats::setNames(rep(.formats, length(var_names)), var_names), |
||
| 71 | -+ | |||
| 264 | +288x |
- #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements+ .format_na_strs = stats::setNames(rep(na_str, length(var_names)), var_names) |
||
| 72 | +265 |
- #' `rsp` and `biomarkers` (vector of continuous biomarker variables) and optionally `covariates`+ ) |
||
| 73 | +266 |
- #' and `strata`.+ } |
||
| 74 | +267 |
- #'+ |
||
| 75 | +268 |
- #' @return+ #' @describeIn cox_regression Layout-creating function which creates a Cox regression summary table |
||
| 76 | +269 |
- #' * `h_logistic_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers.+ #' layout. This function is a wrapper for several `rtables` layouting functions. This function |
||
| 77 | +270 |
- #'+ #' is a wrapper for [rtables::analyze_colvars()] and [rtables::summarize_row_groups()]. |
||
| 78 | +271 |
- #' @examples+ #' |
||
| 79 | +272 |
- #' # For a single population, estimate separately the effects+ #' @inheritParams fit_coxreg_univar |
||
| 80 | +273 |
- #' # of two biomarkers.+ #' @param multivar (`flag`)\cr whether multivariate Cox regression should run (defaults to `FALSE`), otherwise |
||
| 81 | +274 |
- #' df <- h_logistic_mult_cont_df(+ #' univariate Cox regression will run. |
||
| 82 | +275 |
- #' variables = list(+ #' @param common_var (`string`)\cr the name of a factor variable in the dataset which takes the same value |
||
| 83 | +276 |
- #' rsp = "rsp",+ #' for all rows. This should be created during pre-processing if no such variable currently exists. |
||
| 84 | +277 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' @param .section_div (`string` or `NA`)\cr string which should be repeated as a section divider between sections. |
||
| 85 | +278 |
- #' covariates = "SEX"+ #' Defaults to `NA` for no section divider. If a vector of two strings are given, the first will be used between |
||
| 86 | +279 |
- #' ),+ #' treatment and covariate sections and the second between different covariates. |
||
| 87 | +280 |
- #' data = adrs_f+ #' |
||
| 88 | +281 |
- #' )+ #' @return |
||
| 89 | +282 |
- #' df+ #' * `summarize_coxreg()` returns a layout object suitable for passing to further layouting functions, |
||
| 90 | +283 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add a Cox regression table |
||
| 91 | +284 |
- #' # If the data set is empty, still the corresponding rows with missings are returned.+ #' containing the chosen statistics to the table layout. |
||
| 92 | +285 |
- #' h_coxreg_mult_cont_df(+ #' |
||
| 93 | +286 |
- #' variables = list(+ #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()] which also take the `variables`, `data`, |
||
| 94 | +287 |
- #' rsp = "rsp",+ #' `at` (univariate only), and `control` arguments but return unformatted univariate and multivariate |
||
| 95 | +288 |
- #' biomarkers = c("BMRKR1", "AGE"),
+ #' Cox regression models, respectively. |
||
| 96 | +289 |
- #' covariates = "SEX",+ #' |
||
| 97 | +290 |
- #' strata = "STRATA1"+ #' @examples |
||
| 98 | +291 |
- #' ),+ #' # summarize_coxreg |
||
| 99 | +292 |
- #' data = adrs_f[NULL, ]+ #' |
||
| 100 | +293 |
- #' )+ #' result_univar <- basic_table() %>% |
||
| 101 | +294 |
- #'+ #' summarize_coxreg(variables = u1_variables) %>% |
||
| 102 | +295 |
- #' @export+ #' build_table(dta_bladder) |
||
| 103 | +296 |
- h_logistic_mult_cont_df <- function(variables,+ #' result_univar |
||
| 104 | +297 |
- data,+ #' |
||
| 105 | +298 |
- control = control_logistic()) {
- |
- ||
| 106 | -28x | -
- if ("strat" %in% names(variables)) {
- |
- ||
| 107 | -! | -
- warning(- |
- ||
| 108 | -! | -
- "Warning: the `strat` element name of the `variables` list argument to `h_logistic_mult_cont_df() ",- |
- ||
| 109 | -! | -
- "was deprecated in tern 0.9.4.\n ",- |
- ||
| 110 | -! | -
- "Please use the name `strata` instead of `strat` in the `variables` argument."+ #' result_univar_covs <- basic_table() %>% |
||
| 111 | +299 |
- )- |
- ||
| 112 | -! | -
- variables[["strata"]] <- variables[["strat"]]+ #' summarize_coxreg( |
||
| 113 | +300 |
- }- |
- ||
| 114 | -28x | -
- assert_df_with_variables(data, variables)+ #' variables = u2_variables, |
||
| 115 | +301 | - - | -||
| 116 | -28x | -
- checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE)- |
- ||
| 117 | -28x | -
- checkmate::assert_list(control, names = "named")+ #' ) %>% |
||
| 118 | +302 | - - | -||
| 119 | -28x | -
- conf_level <- control[["conf_level"]]- |
- ||
| 120 | -28x | -
- pval_label <- "p-value (Wald)"+ #' build_table(dta_bladder) |
||
| 121 | +303 |
-
+ #' result_univar_covs |
||
| 122 | +304 |
- # If there is any data, run model, otherwise return empty results.- |
- ||
| 123 | -28x | -
- if (nrow(data) > 0) {
- |
- ||
| 124 | -27x | -
- bm_cols <- match(variables$biomarkers, names(data))- |
- ||
| 125 | -27x | -
- l_result <- lapply(variables$biomarkers, function(bm) {
- |
- ||
| 126 | -48x | -
- model_fit <- fit_logistic(- |
- ||
| 127 | -48x | -
- variables = h_rsp_to_logistic_variables(variables, bm),- |
- ||
| 128 | -48x | -
- data = data,- |
- ||
| 129 | -48x | -
- response_definition = control$response_definition+ #' |
||
| 130 | +305 |
- )- |
- ||
| 131 | -48x | -
- result <- h_logistic_simple_terms(- |
- ||
| 132 | -48x | -
- x = bm,- |
- ||
| 133 | -48x | -
- fit_glm = model_fit,- |
- ||
| 134 | -48x | -
- conf_level = control$conf_level+ #' result_multivar <- basic_table() %>% |
||
| 135 | +306 |
- )- |
- ||
| 136 | -48x | -
- resp_vector <- if (inherits(model_fit, "glm")) {
+ #' summarize_coxreg( |
||
| 137 | -38x | +|||
| 307 | +
- model_fit$model[[variables$rsp]]+ #' variables = m1_variables, |
|||
| 138 | +308 |
- } else {
+ #' multivar = TRUE, |
||
| 139 | -10x | +|||
| 309 | +
- as.logical(as.matrix(model_fit$y)[, "status"])+ #' ) %>% |
|||
| 140 | +310 |
- }+ #' build_table(dta_bladder) |
||
| 141 | -48x | +|||
| 311 | +
- data.frame(+ #' result_multivar |
|||
| 142 | +312 |
- # Dummy column needed downstream to create a nested header.+ #' |
||
| 143 | -48x | +|||
| 313 | +
- biomarker = bm,+ #' result_multivar_covs <- basic_table() %>% |
|||
| 144 | -48x | +|||
| 314 | +
- biomarker_label = formatters::var_labels(data[bm], fill = TRUE),+ #' summarize_coxreg( |
|||
| 145 | -48x | +|||
| 315 | +
- n_tot = length(resp_vector),+ #' variables = m2_variables, |
|||
| 146 | -48x | +|||
| 316 | +
- n_rsp = sum(resp_vector),+ #' multivar = TRUE, |
|||
| 147 | -48x | +|||
| 317 | +
- prop = mean(resp_vector),+ #' varlabels = c("Covariate 1", "Covariate 2") # custom labels
|
|||
| 148 | -48x | +|||
| 318 | +
- or = as.numeric(result[1L, "odds_ratio"]),+ #' ) %>% |
|||
| 149 | -48x | +|||
| 319 | +
- lcl = as.numeric(result[1L, "lcl"]),+ #' build_table(dta_bladder) |
|||
| 150 | -48x | +|||
| 320 | +
- ucl = as.numeric(result[1L, "ucl"]),+ #' result_multivar_covs |
|||
| 151 | -48x | +|||
| 321 | +
- conf_level = conf_level,+ #' |
|||
| 152 | -48x | +|||
| 322 | +
- pval = as.numeric(result[1L, "pvalue"]),+ #' @export |
|||
| 153 | -48x | +|||
| 323 | +
- pval_label = pval_label,+ #' @order 2 |
|||
| 154 | -48x | +|||
| 324 | +
- stringsAsFactors = FALSE+ summarize_coxreg <- function(lyt, |
|||
| 155 | +325 |
- )+ variables, |
||
| 156 | +326 |
- })+ control = control_coxreg(), |
||
| 157 | -27x | +|||
| 327 | +
- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ at = list(), |
|||
| 158 | +328 |
- } else {
+ multivar = FALSE, |
||
| 159 | -1x | +|||
| 329 | +
- data.frame(+ common_var = "STUDYID", |
|||
| 160 | -1x | +|||
| 330 | +
- biomarker = variables$biomarkers,+ .stats = c("n", "hr", "ci", "pval", "pval_inter"),
|
|||
| 161 | -1x | +|||
| 331 | +
- biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE),+ .formats = c( |
|||
| 162 | -1x | +|||
| 332 | +
- n_tot = 0L,+ n = "xx", hr = "xx.xx", ci = "(xx.xx, xx.xx)", |
|||
| 163 | -1x | +|||
| 333 | +
- n_rsp = 0L,+ pval = "x.xxxx | (<0.0001)", pval_inter = "x.xxxx | (<0.0001)" |
|||
| 164 | -1x | +|||
| 334 | +
- prop = NA,+ ), |
|||
| 165 | -1x | +|||
| 335 | +
- or = NA,+ varlabels = NULL, |
|||
| 166 | -1x | +|||
| 336 | +
- lcl = NA,+ .indent_mods = NULL, |
|||
| 167 | -1x | +|||
| 337 | +
- ucl = NA,+ na_str = "", |
|||
| 168 | -1x | +|||
| 338 | +
- conf_level = conf_level,+ .section_div = NA_character_) {
|
|||
| 169 | -1x | +339 | +16x |
- pval = NA,+ if (multivar && control$interaction) {
|
| 170 | +340 | 1x |
- pval_label = pval_label,+ warning(paste( |
|
| 171 | +341 | 1x |
- row.names = seq_along(variables$biomarkers),+ "Interactions are not available for multivariate cox regression using summarize_coxreg.", |
|
| 172 | +342 | 1x |
- stringsAsFactors = FALSE+ "The model will be calculated without interaction effects." |
|
| 173 | +343 |
- )+ )) |
||
| 174 | +344 |
} |
||
| 175 | -- |
- }- |
- ||
| 176 | -- | - - | -||
| 177 | -+ | |||
| 345 | +16x |
- #' @describeIn h_response_biomarkers_subgroups Prepares a single sub-table given a `df_sub` containing+ if (control$interaction && !"arm" %in% names(variables)) {
|
||
| 178 | -+ | |||
| 346 | +1x |
- #' the results for a single biomarker.+ stop("To include interactions please specify 'arm' in variables.")
|
||
| 179 | +347 |
- #'+ } |
||
| 180 | +348 |
- #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is+ |
||
| 181 | -+ | |||
| 349 | +15x |
- #' returned by [extract_rsp_biomarkers()] (it needs a couple of columns which are+ .stats <- if (!"arm" %in% names(variables) || multivar) { # only valid statistics
|
||
| 182 | -+ | |||
| 350 | +6x |
- #' added by that high-level function relative to what is returned by [h_logistic_mult_cont_df()],+ intersect(c("hr", "ci", "pval"), .stats)
|
||
| 183 | -+ | |||
| 351 | +15x |
- #' see the example).+ } else if (control$interaction) {
|
||
| 184 | -+ | |||
| 352 | +5x |
- #'+ intersect(c("n", "hr", "ci", "pval", "pval_inter"), .stats)
|
||
| 185 | +353 |
- #' @return+ } else {
|
||
| 186 | -+ | |||
| 354 | +4x |
- #' * `h_tab_rsp_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns.+ intersect(c("n", "hr", "ci", "pval"), .stats)
|
||
| 187 | +355 |
- #'+ } |
||
| 188 | -+ | |||
| 356 | +15x |
- #' @examples+ stat_labels <- c( |
||
| 189 | -+ | |||
| 357 | +15x |
- #' # Starting from above `df`, zoom in on one biomarker and add required columns.+ n = "n", hr = "Hazard Ratio", ci = paste0(control$conf_level * 100, "% CI"), |
||
| 190 | -+ | |||
| 358 | +15x |
- #' df1 <- df[1, ]+ pval = "p-value", pval_inter = "Interaction p-value" |
||
| 191 | +359 |
- #' df1$subgroup <- "All patients"+ ) |
||
| 192 | -+ | |||
| 360 | +15x |
- #' df1$row_type <- "content"+ stat_labels <- stat_labels[names(stat_labels) %in% .stats] |
||
| 193 | -+ | |||
| 361 | +15x |
- #' df1$var <- "ALL"+ .formats <- .formats[names(.formats) %in% .stats] |
||
| 194 | -+ | |||
| 362 | +15x |
- #' df1$var_label <- "All patients"+ env <- new.env() # create caching environment |
||
| 195 | +363 |
- #'+ |
||
| 196 | -+ | |||
| 364 | +15x |
- #' h_tab_rsp_one_biomarker(+ lyt <- lyt %>% |
||
| 197 | -+ | |||
| 365 | +15x |
- #' df1,+ split_cols_by_multivar( |
||
| 198 | -+ | |||
| 366 | +15x |
- #' vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval")
+ vars = rep(common_var, length(.stats)), |
||
| 199 | -+ | |||
| 367 | +15x |
- #' )+ varlabels = stat_labels, |
||
| 200 | -+ | |||
| 368 | +15x |
- #'+ extra_args = list( |
||
| 201 | -+ | |||
| 369 | +15x |
- #' @export+ .stats = .stats, .formats = .formats, .indent_mods = .indent_mods, na_str = rep(na_str, length(.stats)), |
||
| 202 | -+ | |||
| 370 | +15x |
- h_tab_rsp_one_biomarker <- function(df,+ cache_env = replicate(length(.stats), list(env)) |
||
| 203 | +371 |
- vars,+ ) |
||
| 204 | +372 |
- na_str = default_na_str(),+ ) |
||
| 205 | +373 |
- .indent_mods = 0L) {
+
|
||
| 206 | -8x | +374 | +15x |
- afuns <- a_response_subgroups(na_str = na_str)[vars]+ if ("arm" %in% names(variables)) { # treatment effect
|
| 207 | -8x | +375 | +13x |
- colvars <- d_rsp_subgroups_colvars(+ lyt <- lyt %>% |
| 208 | -8x | +376 | +13x |
- vars,+ split_rows_by( |
| 209 | -8x | +377 | +13x |
- conf_level = df$conf_level[1],+ common_var, |
| 210 | -8x | -
- method = df$pval_label[1]- |
- ||
| 211 | -+ | 378 | +13x |
- )+ split_label = "Treatment:", |
| 212 | -8x | +379 | +13x |
- h_tab_one_biomarker(+ label_pos = "visible", |
| 213 | -8x | +380 | +13x |
- df = df,+ child_labels = "hidden", |
| 214 | -8x | +381 | +13x |
- afuns = afuns,+ section_div = head(.section_div, 1) |
| 215 | -8x | +|||
| 382 | +
- colvars = colvars,+ ) |
|||
| 216 | -8x | +383 | +13x |
- na_str = na_str,+ if (!multivar) {
|
| 217 | -8x | +384 | +9x |
- .indent_mods = .indent_mods+ lyt <- lyt %>% |
| 218 | -+ | |||
| 385 | +9x |
- )+ analyze_colvars( |
||
| 219 | -+ | |||
| 386 | +9x |
- }+ afun = a_coxreg, |
| 1 | -+ | |||
| 387 | +9x |
- #' Missing data+ na_str = na_str, |
||
| 2 | -+ | |||
| 388 | +9x |
- #'+ extra_args = list( |
||
| 3 | -+ | |||
| 389 | +9x |
- #' @description `r lifecycle::badge("stable")`
+ variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar, |
||
| 4 | -+ | |||
| 390 | +9x |
- #'+ labelstr = "" |
||
| 5 | +391 |
- #' Substitute missing data with a string or factor level.+ ) |
||
| 6 | +392 |
- #'+ ) |
||
| 7 | +393 |
- #' @param x (`factor` or `character`)\cr values for which any missing values should be substituted.+ } else { # treatment level effects
|
||
| 8 | -+ | |||
| 394 | +4x |
- #' @param label (`string`)\cr string that missing data should be replaced with.+ lyt <- lyt %>% |
||
| 9 | -+ | |||
| 395 | +4x |
- #'+ summarize_row_groups( |
||
| 10 | -+ | |||
| 396 | +4x |
- #' @return `x` with any `NA` values substituted by `label`.+ cfun = a_coxreg, |
||
| 11 | -+ | |||
| 397 | +4x |
- #'+ na_str = na_str, |
||
| 12 | -+ | |||
| 398 | +4x |
- #' @examples+ extra_args = list( |
||
| 13 | -+ | |||
| 399 | +4x |
- #' explicit_na(c(NA, "a", "b"))+ variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar |
||
| 14 | +400 |
- #' is.na(explicit_na(c(NA, "a", "b")))+ ) |
||
| 15 | +401 |
- #'+ ) %>% |
||
| 16 | -+ | |||
| 402 | +4x |
- #' explicit_na(factor(c(NA, "a", "b")))+ analyze_colvars( |
||
| 17 | -+ | |||
| 403 | +4x |
- #' is.na(explicit_na(factor(c(NA, "a", "b"))))+ afun = a_coxreg, |
||
| 18 | -+ | |||
| 404 | +4x |
- #'+ na_str = na_str, |
||
| 19 | -+ | |||
| 405 | +4x |
- #' explicit_na(sas_na(c("a", "")))
+ extra_args = list(eff = TRUE, control = control, variables = variables, multivar = multivar, labelstr = "") |
||
| 20 | +406 |
- #'+ ) |
||
| 21 | +407 |
- #' @export+ } |
||
| 22 | +408 |
- explicit_na <- function(x, label = "<Missing>") {
- |
- ||
| 23 | -256x | -
- checkmate::assert_string(label)+ } |
||
| 24 | +409 | |||
| 25 | -256x | +410 | +15x |
- if (is.factor(x)) {
+ if ("covariates" %in% names(variables)) { # covariate main effects
|
| 26 | -151x | +411 | +15x |
- x <- forcats::fct_na_value_to_level(x, label)+ lyt <- lyt %>% |
| 27 | -151x | +412 | +15x |
- forcats::fct_drop(x, only = label)+ split_rows_by_multivar( |
| 28 | -105x | +413 | +15x |
- } else if (is.character(x)) {
+ vars = variables$covariates, |
| 29 | -105x | +414 | +15x |
- x[is.na(x)] <- label+ varlabels = varlabels, |
| 30 | -105x | +415 | +15x |
- x+ split_label = "Covariate:", |
| 31 | -+ | |||
| 416 | +15x |
- } else {
+ nested = FALSE, |
||
| 32 | -! | +|||
| 417 | +15x |
- stop("only factors and character vectors allowed")
+ child_labels = if (multivar || control$interaction || !"arm" %in% names(variables)) "default" else "hidden", |
||
| 33 | -+ | |||
| 418 | +15x |
- }+ section_div = tail(.section_div, 1) |
||
| 34 | +419 |
- }+ ) |
||
| 35 | -+ | |||
| 420 | +15x |
-
+ if (multivar || control$interaction || !"arm" %in% names(variables)) {
|
||
| 36 | -+ | |||
| 421 | +11x |
- #' Convert strings to `NA`+ lyt <- lyt %>% |
||
| 37 | -+ | |||
| 422 | +11x |
- #'+ summarize_row_groups( |
||
| 38 | -+ | |||
| 423 | +11x |
- #' @description `r lifecycle::badge("stable")`
+ cfun = a_coxreg, |
||
| 39 | -+ | |||
| 424 | +11x |
- #'+ na_str = na_str, |
||
| 40 | -+ | |||
| 425 | +11x |
- #' SAS imports missing data as empty strings or strings with whitespaces only. This helper function can be used to+ extra_args = list( |
||
| 41 | -+ | |||
| 426 | +11x |
- #' convert these values to `NA`s.+ variables = variables, at = at, control = control, multivar = multivar, |
||
| 42 | -+ | |||
| 427 | +11x |
- #'+ var_main = if (multivar) multivar else control$interaction |
||
| 43 | +428 |
- #' @inheritParams explicit_na+ ) |
||
| 44 | +429 |
- #' @param empty (`flag`)\cr if `TRUE`, empty strings get replaced by `NA`.+ ) |
||
| 45 | +430 |
- #' @param whitespaces (`flag`)\cr if `TRUE`, strings made from only whitespaces get replaced with `NA`.+ } else {
|
||
| 46 | -+ | |||
| 431 | +1x |
- #'+ if (!is.null(varlabels)) names(varlabels) <- variables$covariates |
||
| 47 | -+ | |||
| 432 | +4x |
- #' @return `x` with `""` and/or whitespace-only values substituted by `NA`, depending on the values of+ lyt <- lyt %>% |
||
| 48 | -+ | |||
| 433 | +4x |
- #' `empty` and `whitespaces`.+ analyze_colvars( |
||
| 49 | -+ | |||
| 434 | +4x |
- #'+ afun = a_coxreg, |
||
| 50 | -+ | |||
| 435 | +4x |
- #' @examples+ na_str = na_str, |
||
| 51 | -+ | |||
| 436 | +4x |
- #' sas_na(c("1", "", " ", " ", "b"))
+ extra_args = list( |
||
| 52 | -+ | |||
| 437 | +4x |
- #' sas_na(factor(c("", " ", "b")))
+ variables = variables, at = at, control = control, multivar = multivar, |
||
| 53 | -+ | |||
| 438 | +4x |
- #'+ var_main = if (multivar) multivar else control$interaction, |
||
| 54 | -+ | |||
| 439 | +4x |
- #' is.na(sas_na(c("1", "", " ", " ", "b")))
+ labelstr = if (is.null(varlabels)) "" else varlabels |
||
| 55 | +440 |
- #'+ ) |
||
| 56 | +441 |
- #' @export+ ) |
||
| 57 | +442 |
- sas_na <- function(x, empty = TRUE, whitespaces = TRUE) {
- |
- ||
| 58 | -245x | -
- checkmate::assert_flag(empty)- |
- ||
| 59 | -245x | -
- checkmate::assert_flag(whitespaces)+ } |
||
| 60 | +443 | |||
| 61 | -245x | +444 | +2x |
- if (is.factor(x)) {
+ if (!"arm" %in% names(variables)) control$interaction <- TRUE # special case: univar no arm |
| 62 | -135x | +445 | +15x |
- empty_levels <- levels(x) == ""+ if (multivar || control$interaction) { # covariate level effects
|
| 63 | +446 | 11x |
- if (empty && any(empty_levels)) levels(x)[empty_levels] <- NA- |
- |
| 64 | -- |
-
+ lyt <- lyt %>% |
||
| 65 | -135x | -
- ws_levels <- grepl("^\\s+$", levels(x))
- |
- ||
| 66 | -! | +447 | +11x |
- if (whitespaces && any(ws_levels)) levels(x)[ws_levels] <- NA+ analyze_colvars( |
| 67 | -+ | |||
| 448 | +11x |
-
+ afun = a_coxreg, |
||
| 68 | -135x | +449 | +11x |
- x+ na_str = na_str, |
| 69 | -110x | +450 | +11x |
- } else if (is.character(x)) {
+ extra_args = list(variables = variables, at = at, control = control, multivar = multivar, labelstr = ""), |
| 70 | -110x | +451 | +11x |
- if (empty) x[x == ""] <- NA_character_+ indent_mod = if (!"arm" %in% names(variables) || multivar) 0L else -1L |
| 71 | +452 | - - | -||
| 72 | -110x | -
- if (whitespaces) x[grepl("^\\s+$", x)] <- NA_character_
+ ) |
||
| 73 | +453 | - - | -||
| 74 | -110x | -
- x+ } |
||
| 75 | +454 |
- } else {
+ } |
||
| 76 | -! | +|||
| 455 | +
- stop("only factors and character vectors allowed")
+
|
|||
| 77 | -+ | |||
| 456 | +15x |
- }+ lyt |
||
| 78 | +457 |
}@@ -136819,14 +139716,14 @@ tern coverage - 95.59% |
| 1 |
- #' Incidence rate estimation+ #' Helper functions for incidence rate |
||
| 5 |
- #' The analyze function [estimate_incidence_rate()] creates a layout element to estimate an event rate adjusted for+ #' @param control (`list`)\cr parameters for estimation details, specified by using |
||
| 6 |
- #' person-years at risk, otherwise known as incidence rate. The primary analysis variable specified via `vars` is+ #' the helper function [control_incidence_rate()]. Possible parameter options are: |
||
| 7 |
- #' the person-years at risk. In addition to this variable, the `n_events` variable for number of events observed (where+ #' * `conf_level`: (`proportion`)\cr confidence level for the estimated incidence rate. |
||
| 8 |
- #' a value of 1 means an event was observed and 0 means that no event was observed) must also be specified.+ #' * `conf_type`: (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar` |
||
| 9 |
- #'+ #' for confidence interval type. |
||
| 10 |
- #' @inheritParams argument_convention+ #' * `input_time_unit`: (`string`)\cr `day`, `week`, `month`, or `year` (default) |
||
| 11 |
- #' @param control (`list`)\cr parameters for estimation details, specified by using+ #' indicating time unit for data input. |
||
| 12 |
- #' the helper function [control_incidence_rate()]. Possible parameter options are:+ #' * `num_pt_year`: (`numeric`)\cr time unit for desired output (in person-years). |
||
| 13 |
- #' * `conf_level` (`proportion`)\cr confidence level for the estimated incidence rate.+ #' @param person_years (`numeric(1)`)\cr total person-years at risk. |
||
| 14 |
- #' * `conf_type` (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`+ #' @param alpha (`numeric(1)`)\cr two-sided alpha-level for confidence interval. |
||
| 15 |
- #' for confidence interval type.+ #' @param n_events (`integer(1)`)\cr number of events observed. |
||
| 16 |
- #' * `input_time_unit` (`string`)\cr `day`, `week`, `month`, or `year` (default)+ #' |
||
| 17 |
- #' indicating time unit for data input.+ #' @return Estimated incidence rate, `rate`, and associated confidence interval, `rate_ci`. |
||
| 18 |
- #' * `num_pt_year` (`numeric`)\cr time unit for desired output (in person-years).+ #' |
||
| 19 |
- #' @param n_events (`string`)\cr name of integer variable indicating whether an event has been observed (1) or not (0).+ #' @seealso [incidence_rate] |
||
| 20 |
- #' @param id_var (`string`)\cr name of variable used as patient identifier if `"n_unique"` is included in `.stats`.+ #' |
||
| 21 |
- #' Defaults to `"USUBJID"`.+ #' @name h_incidence_rate |
||
| 22 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ NULL |
||
| 23 |
- #'+ |
||
| 24 |
- #' Options are: ``r shQuote(get_stats("estimate_incidence_rate"))``
+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
||
| 25 |
- #' @param summarize (`flag`)\cr whether the function should act as an analyze function (`summarize = FALSE`), or a+ #' associated confidence interval. |
||
| 26 |
- #' summarize function (`summarize = TRUE`). Defaults to `FALSE`.+ #' |
||
| 27 |
- #' @param label_fmt (`string`)\cr how labels should be formatted after a row split occurs if `summarize = TRUE`. The+ #' @keywords internal |
||
| 28 |
- #' string should use `"%s"` to represent row split levels, and `"%.labels"` to represent labels supplied to the+ h_incidence_rate <- function(person_years, |
||
| 29 |
- #' `.labels` argument. Defaults to `"%s - %.labels"`.+ n_events, |
||
| 30 |
- #'+ control = control_incidence_rate()) {
|
||
| 31 | -+ | 18x |
- #' @seealso [control_incidence_rate()] and helper functions [h_incidence_rate].+ alpha <- 1 - control$conf_level |
| 32 | -+ | 18x |
- #'+ est <- switch(control$conf_type, |
| 33 | -+ | 18x |
- #' @examples+ normal = h_incidence_rate_normal(person_years, n_events, alpha), |
| 34 | -+ | 18x |
- #' df <- data.frame(+ normal_log = h_incidence_rate_normal_log(person_years, n_events, alpha), |
| 35 | -+ | 18x |
- #' USUBJID = as.character(seq(6)),+ exact = h_incidence_rate_exact(person_years, n_events, alpha), |
| 36 | -+ | 18x |
- #' CNSR = c(0, 1, 1, 0, 0, 0),+ byar = h_incidence_rate_byar(person_years, n_events, alpha) |
| 37 |
- #' AVAL = c(10.1, 20.4, 15.3, 20.8, 18.7, 23.4),+ ) |
||
| 38 |
- #' ARM = factor(c("A", "A", "A", "B", "B", "B")),
+
|
||
| 39 | -+ | 18x |
- #' STRATA1 = factor(c("X", "Y", "Y", "X", "X", "Y"))
+ num_pt_year <- control$num_pt_year |
| 40 | -+ | 18x |
- #' )+ list( |
| 41 | -+ | 18x |
- #' df$n_events <- 1 - df$CNSR+ rate = est$rate * num_pt_year, |
| 42 | -+ | 18x |
- #'+ rate_ci = est$rate_ci * num_pt_year |
| 43 |
- #' @name incidence_rate+ ) |
||
| 44 |
- #' @order 1+ } |
||
| 45 |
- NULL+ |
||
| 46 |
-
+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
||
| 47 |
- #' @describeIn incidence_rate Statistics function which estimates the incidence rate and the+ #' associated confidence interval based on the normal approximation for the |
||
| 48 |
- #' associated confidence interval.+ #' incidence rate. Unit is one person-year. |
||
| 50 |
- #' @return+ #' @examples |
||
| 51 |
- #' * `s_incidence_rate()` returns the following statistics:+ #' h_incidence_rate_normal(200, 2) |
||
| 52 |
- #' - `person_years`: Total person-years at risk.+ #' |
||
| 53 |
- #' - `n_events`: Total number of events observed.+ #' @export |
||
| 54 |
- #' - `rate`: Estimated incidence rate.+ h_incidence_rate_normal <- function(person_years, |
||
| 55 |
- #' - `rate_ci`: Confidence interval for the incidence rate.+ n_events, |
||
| 56 |
- #' - `n_unique`: Total number of patients with at least one event observed.+ alpha = 0.05) {
|
||
| 57 | -+ | 14x |
- #' - `n_rate`: Total number of events observed & estimated incidence rate.+ checkmate::assert_number(person_years) |
| 58 | -+ | 14x |
- #'+ checkmate::assert_number(n_events) |
| 59 | -+ | 14x |
- #' @keywords internal+ assert_proportion_value(alpha) |
| 60 |
- s_incidence_rate <- function(df,+ |
||
| 61 | -+ | 14x |
- .var,+ est <- n_events / person_years |
| 62 | -+ | 14x |
- n_events,+ se <- sqrt(est / person_years) |
| 63 | -+ | 14x |
- is_event = lifecycle::deprecated(),+ ci <- est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * se |
| 64 |
- id_var = "USUBJID",+ |
||
| 65 | -+ | 14x |
- control = control_incidence_rate()) {
+ list(rate = est, rate_ci = ci) |
| 66 | -17x | +
- if (lifecycle::is_present(is_event)) {
+ } |
|
| 67 | -! | +
- checkmate::assert_string(is_event)+ |
|
| 68 | -! | +
- lifecycle::deprecate_warn(+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
|
| 69 | -! | +
- "0.9.6", "s_incidence_rate(is_event)", "s_incidence_rate(n_events)"+ #' associated confidence interval based on the normal approximation for the |
|
| 70 |
- )+ #' logarithm of the incidence rate. Unit is one person-year. |
||
| 71 | -! | +
- n_events <- is_event+ #' |
|
| 72 | -! | +
- df[[n_events]] <- as.numeric(df[[is_event]])+ #' @examples |
|
| 73 |
- }+ #' h_incidence_rate_normal_log(200, 2) |
||
| 74 |
-
+ #' |
||
| 75 | -17x | +
- assert_df_with_variables(df, list(tte = .var, n_events = n_events))+ #' @export |
|
| 76 | -17x | +
- checkmate::assert_string(.var)+ h_incidence_rate_normal_log <- function(person_years, |
|
| 77 | -17x | +
- checkmate::assert_string(n_events)+ n_events, |
|
| 78 | -17x | +
- checkmate::assert_string(id_var)+ alpha = 0.05) {
|
|
| 79 | -17x | +6x |
- checkmate::assert_numeric(df[[.var]], any.missing = FALSE)+ checkmate::assert_number(person_years) |
| 80 | -17x | +6x |
- checkmate::assert_integerish(df[[n_events]], any.missing = FALSE)+ checkmate::assert_number(n_events) |
| 81 | -+ | 6x |
-
+ assert_proportion_value(alpha) |
| 82 | -17x | +
- n_unique <- n_available(unique(df[[id_var]][df[[n_events]] == 1]))+ |
|
| 83 | -17x | +6x |
- input_time_unit <- control$input_time_unit+ rate_est <- n_events / person_years |
| 84 | -17x | +6x |
- num_pt_year <- control$num_pt_year+ rate_se <- sqrt(rate_est / person_years) |
| 85 | -17x | +6x |
- conf_level <- control$conf_level+ lrate_est <- log(rate_est) |
| 86 | -17x | +6x |
- person_years <- sum(df[[.var]], na.rm = TRUE) * (+ lrate_se <- rate_se / rate_est |
| 87 | -17x | +6x |
- 1 * (input_time_unit == "year") ++ ci <- exp(lrate_est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * lrate_se) |
| 88 | -17x | +
- 1 / 12 * (input_time_unit == "month") ++ |
|
| 89 | -17x | +6x |
- 1 / 52.14 * (input_time_unit == "week") ++ list(rate = rate_est, rate_ci = ci) |
| 90 | -17x | +
- 1 / 365.24 * (input_time_unit == "day")+ } |
|
| 91 |
- )+ |
||
| 92 | -17x | +
- n_events <- sum(df[[n_events]], na.rm = TRUE)+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
|
| 93 |
-
+ #' associated exact confidence interval. Unit is one person-year. |
||
| 94 | -17x | +
- result <- h_incidence_rate(+ #' |
|
| 95 | -17x | +
- person_years,+ #' @examples |
|
| 96 | -17x | +
- n_events,+ #' h_incidence_rate_exact(200, 2) |
|
| 97 | -17x | +
- control+ #' |
|
| 98 |
- )+ #' @export |
||
| 99 | -17x | +
- list(+ h_incidence_rate_exact <- function(person_years, |
|
| 100 | -17x | +
- person_years = formatters::with_label(person_years, "Total patient-years at risk"),+ n_events, |
|
| 101 | -17x | +
- n_events = formatters::with_label(n_events, "Number of adverse events observed"),+ alpha = 0.05) {
|
|
| 102 | -17x | +1x |
- rate = formatters::with_label(result$rate, paste("AE rate per", num_pt_year, "patient-years")),
+ checkmate::assert_number(person_years) |
| 103 | -17x | +1x |
- rate_ci = formatters::with_label(result$rate_ci, f_conf_level(conf_level)),+ checkmate::assert_number(n_events) |
| 104 | -17x | +1x |
- n_unique = formatters::with_label(n_unique, "Total number of patients with at least one adverse event"),+ assert_proportion_value(alpha) |
| 105 | -17x | +
- n_rate = formatters::with_label(+ |
|
| 106 | -17x | +1x |
- c(n_events, result$rate),+ est <- n_events / person_years |
| 107 | -17x | +1x |
- paste("Number of adverse events observed (AE rate per", num_pt_year, "patient-years)")
+ lcl <- stats::qchisq(p = (alpha) / 2, df = 2 * n_events) / (2 * person_years) |
| 108 | -+ | 1x |
- )+ ucl <- stats::qchisq(p = 1 - (alpha) / 2, df = 2 * n_events + 2) / (2 * person_years) |
| 109 |
- )+ |
||
| 110 | -+ | 1x |
- }+ list(rate = est, rate_ci = c(lcl, ucl)) |
| 111 |
-
+ } |
||
| 112 |
- #' @describeIn incidence_rate Formatted analysis function which is used as `afun` in `estimate_incidence_rate()`.+ |
||
| 113 |
- #'+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and |
||
| 114 |
- #' @return+ #' associated Byar's confidence interval. Unit is one person-year. |
||
| 115 |
- #' * `a_incidence_rate()` returns the corresponding list with formatted [rtables::CellValue()].+ #' |
||
| 116 |
- #'+ #' @examples |
||
| 117 |
- #' @examples+ #' h_incidence_rate_byar(200, 2) |
||
| 118 |
- #' a_incidence_rate(+ #' |
||
| 119 |
- #' df,+ #' @export |
||
| 120 |
- #' .var = "AVAL",+ h_incidence_rate_byar <- function(person_years, |
||
| 121 |
- #' .df_row = df,+ n_events, |
||
| 122 |
- #' n_events = "n_events"+ alpha = 0.05) {
|
||
| 123 | -+ | 1x |
- #' )+ checkmate::assert_number(person_years) |
| 124 | -+ | 1x |
- #'+ checkmate::assert_number(n_events) |
| 125 | -+ | 1x |
- #' @export+ assert_proportion_value(alpha) |
| 126 |
- a_incidence_rate <- function(df,+ |
||
| 127 | -+ | 1x |
- labelstr = "",+ est <- n_events / person_years |
| 128 | -+ | 1x |
- .var,+ seg_1 <- n_events + 0.5 |
| 129 | -+ | 1x |
- .df_row,+ seg_2 <- 1 - 1 / (9 * (n_events + 0.5)) |
| 130 | -+ | 1x |
- n_events,+ seg_3 <- stats::qnorm(1 - alpha / 2) * sqrt(1 / (n_events + 0.5)) / 3 |
| 131 | -+ | 1x |
- id_var = "USUBJID",+ lcl <- seg_1 * ((seg_2 - seg_3)^3) / person_years |
| 132 | -+ | 1x |
- control = control_incidence_rate(),+ ucl <- seg_1 * ((seg_2 + seg_3)^3) / person_years |
| 133 |
- .stats = NULL,+ |
||
| 134 | -+ | 1x |
- .formats = c(+ list(rate = est, rate_ci = c(lcl, ucl)) |
| 135 |
- "person_years" = "xx.x",+ } |
| 136 | +1 |
- "n_events" = "xx",+ #' Survival time analysis |
||
| 137 | +2 |
- "rate" = "xx.xx",+ #' |
||
| 138 | +3 |
- "rate_ci" = "(xx.xx, xx.xx)",+ #' @description `r lifecycle::badge("stable")`
|
||
| 139 | +4 |
- "n_unique" = "xx",+ #' |
||
| 140 | +5 |
- "n_rate" = "xx (xx.x)"+ #' The analyze function [surv_time()] creates a layout element to analyze survival time by calculating survival time |
||
| 141 | +6 |
- ),+ #' median, median confidence interval, quantiles, and range (for all, censored, or event patients). The primary |
||
| 142 | +7 |
- .labels = NULL,+ #' analysis variable `vars` is the time variable and the secondary analysis variable `is_event` indicates whether or |
||
| 143 | +8 |
- .indent_mods = NULL,+ #' not an event has occurred. |
||
| 144 | +9 |
- na_str = default_na_str(),+ #' |
||
| 145 | +10 |
- label_fmt = "%s - %.labels") {
- |
- ||
| 146 | -16x | -
- checkmate::assert_string(label_fmt)+ #' @inheritParams argument_convention |
||
| 147 | +11 | - - | -||
| 148 | -16x | -
- x_stats <- s_incidence_rate(- |
- ||
| 149 | -16x | -
- df = df, .var = .var, n_events = n_events, id_var = id_var, control = control+ #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function |
||
| 150 | +12 |
- )- |
- ||
| 151 | -16x | -
- if (is.null(unlist(x_stats))) {
- |
- ||
| 152 | -! | -
- return(NULL)+ #' [control_surv_time()]. Some possible parameter options are: |
||
| 153 | +13 |
- }+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival time. |
||
| 154 | +14 |
-
+ #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", or "log-log", |
||
| 155 | +15 |
- # Fill in with defaults- |
- ||
| 156 | -16x | -
- formats_def <- formals()$.formats %>% eval()- |
- ||
| 157 | -16x | -
- .formats <- c(.formats, formats_def)[!duplicated(names(c(.formats, formats_def)))]- |
- ||
| 158 | -16x | -
- labels_def <- sapply(x_stats, \(x) attributes(x)$label)- |
- ||
| 159 | -16x | -
- .labels <- c(.labels, labels_def)[!duplicated(names(c(.labels, labels_def)))]- |
- ||
| 160 | -16x | -
- if (nzchar(labelstr) > 0) {
- |
- ||
| 161 | -8x | -
- .labels <- sapply(.labels, \(x) gsub("%.labels", x, gsub("%s", labelstr, label_fmt)))
+ #' see more in [survival::survfit()]. Note option "none" is not supported. |
||
| 162 | +16 |
- }+ #' * `quantiles` (`numeric`)\cr vector of length two to specify the quantiles of survival time. |
||
| 163 | +17 |
-
+ #' @param ref_fn_censor (`flag`)\cr whether referential footnotes indicating censored observations should be printed |
||
| 164 | +18 |
- # Fill in with formatting defaults if needed- |
- ||
| 165 | -16x | -
- .stats <- get_stats("estimate_incidence_rate", stats_in = .stats)
- |
- ||
| 166 | -16x | -
- .formats <- get_formats_from_stats(.stats, .formats)- |
- ||
| 167 | -16x | -
- .labels <- get_labels_from_stats(.stats, .labels)- |
- ||
| 168 | -16x | -
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods)+ #' when the `range` statistic is included. |
||
| 169 | +19 |
-
+ #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 170 | -16x | +|||
| 20 | +
- x_stats <- x_stats[.stats]+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
|||
| 171 | +21 |
-
+ #' for that statistic's row label. |
||
| 172 | -16x | +|||
| 22 | +
- in_rows(+ #' @param .stats (`character`)\cr statistics to select for the table. |
|||
| 173 | -16x | +|||
| 23 | +
- .list = x_stats,+ #' |
|||
| 174 | -16x | +|||
| 24 | +
- .formats = .formats,+ #' Options are: ``r shQuote(get_stats("surv_time"), type = "sh")``
|
|||
| 175 | -16x | +|||
| 25 | +
- .labels = .labels,+ #' |
|||
| 176 | -16x | +|||
| 26 | +
- .indent_mods = .indent_mods,+ #' @examples |
|||
| 177 | -16x | +|||
| 27 | +
- .format_na_strs = na_str+ #' library(dplyr) |
|||
| 178 | +28 |
- )+ #' |
||
| 179 | +29 |
- }+ #' adtte_f <- tern_ex_adtte %>% |
||
| 180 | +30 |
-
+ #' filter(PARAMCD == "OS") %>% |
||
| 181 | +31 |
- #' @describeIn incidence_rate Layout-creating function which can take statistics function arguments+ #' mutate( |
||
| 182 | +32 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' AVAL = day2month(AVAL), |
||
| 183 | +33 |
- #'+ #' is_event = CNSR == 0 |
||
| 184 | +34 |
- #' @return+ #' ) |
||
| 185 | +35 |
- #' * `estimate_incidence_rate()` returns a layout object suitable for passing to further layouting functions,+ #' df <- adtte_f %>% filter(ARMCD == "ARM A") |
||
| 186 | +36 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' |
||
| 187 | +37 |
- #' the statistics from `s_incidence_rate()` to the table layout.+ #' @name survival_time |
||
| 188 | +38 |
- #'+ #' @order 1 |
||
| 189 | +39 |
- #' @examples+ NULL |
||
| 190 | +40 |
- #' basic_table(show_colcounts = TRUE) %>%+ |
||
| 191 | +41 |
- #' split_cols_by("ARM") %>%
+ #' @describeIn survival_time Statistics function which analyzes survival times. |
||
| 192 | +42 |
- #' estimate_incidence_rate(+ #' |
||
| 193 | +43 |
- #' vars = "AVAL",+ #' @return |
||
| 194 | +44 |
- #' n_events = "n_events",+ #' * `s_surv_time()` returns the statistics: |
||
| 195 | +45 |
- #' control = control_incidence_rate(+ #' * `median`: Median survival time. |
||
| 196 | +46 |
- #' input_time_unit = "month",+ #' * `median_ci`: Confidence interval for median time. |
||
| 197 | +47 |
- #' num_pt_year = 100+ #' * `median_ci_3d`: Median with confidence interval for median time. |
||
| 198 | +48 |
- #' )+ #' * `quantiles`: Survival time for two specified quantiles. |
||
| 199 | +49 |
- #' ) %>%+ #' * `quantiles_lower`: quantile with confidence interval for the first specified quantile. |
||
| 200 | +50 |
- #' build_table(df)+ #' * `quantiles_upper`: quantile with confidence interval for the second specified quantile. |
||
| 201 | +51 |
- #'+ #' * `range_censor`: Survival time range for censored observations. |
||
| 202 | +52 |
- #' # summarize = TRUE+ #' * `range_event`: Survival time range for observations with events. |
||
| 203 | +53 |
- #' basic_table(show_colcounts = TRUE) %>%+ #' * `range`: Survival time range for all observations. |
||
| 204 | +54 |
- #' split_cols_by("ARM") %>%
+ #' |
||
| 205 | +55 |
- #' split_rows_by("STRATA1", child_labels = "visible") %>%
+ #' @keywords internal |
||
| 206 | +56 |
- #' estimate_incidence_rate(+ s_surv_time <- function(df, |
||
| 207 | +57 |
- #' vars = "AVAL",+ .var, |
||
| 208 | +58 |
- #' n_events = "n_events",+ is_event, |
||
| 209 | +59 |
- #' .stats = c("n_unique", "n_rate"),
+ control = control_surv_time()) {
|
||
| 210 | -+ | |||
| 60 | +232x |
- #' summarize = TRUE,+ checkmate::assert_string(.var) |
||
| 211 | -+ | |||
| 61 | +232x |
- #' label_fmt = "%.labels"+ assert_df_with_variables(df, list(tte = .var, is_event = is_event)) |
||
| 212 | -+ | |||
| 62 | +232x |
- #' ) %>%+ checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE) |
||
| 213 | -+ | |||
| 63 | +232x |
- #' build_table(df)+ checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE) |
||
| 214 | +64 |
- #'+ |
||
| 215 | -+ | |||
| 65 | +232x |
- #' @export+ conf_type <- control$conf_type |
||
| 216 | -+ | |||
| 66 | +232x |
- #' @order 2+ conf_level <- control$conf_level |
||
| 217 | -+ | |||
| 67 | +232x |
- estimate_incidence_rate <- function(lyt,+ quantiles <- control$quantiles |
||
| 218 | +68 |
- vars,+ |
||
| 219 | -+ | |||
| 69 | +232x |
- n_events,+ formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
|
||
| 220 | -+ | |||
| 70 | +232x |
- id_var = "USUBJID",+ srv_fit <- survival::survfit( |
||
| 221 | -+ | |||
| 71 | +232x |
- control = control_incidence_rate(),+ formula = formula, |
||
| 222 | -+ | |||
| 72 | +232x |
- na_str = default_na_str(),+ data = df, |
||
| 223 | -+ | |||
| 73 | +232x |
- nested = TRUE,+ conf.int = conf_level, |
||
| 224 | -+ | |||
| 74 | +232x |
- summarize = FALSE,+ conf.type = conf_type |
||
| 225 | +75 |
- label_fmt = "%s - %.labels",+ ) |
||
| 226 | -+ | |||
| 76 | +232x |
- ...,+ srv_tab <- summary(srv_fit, extend = TRUE)$table |
||
| 227 | -+ | |||
| 77 | +232x |
- show_labels = "hidden",+ srv_qt_tab_pre <- stats::quantile(srv_fit, probs = quantiles) |
||
| 228 | -+ | |||
| 78 | +232x |
- table_names = vars,+ srv_qt_tab <- srv_qt_tab_pre$quantile |
||
| 229 | -+ | |||
| 79 | +232x |
- .stats = c("person_years", "n_events", "rate", "rate_ci"),
+ range_censor <- range_noinf(df[[.var]][!df[[is_event]]], na.rm = TRUE) |
||
| 230 | -+ | |||
| 80 | +232x |
- .formats = NULL,+ range_event <- range_noinf(df[[.var]][df[[is_event]]], na.rm = TRUE) |
||
| 231 | -+ | |||
| 81 | +232x |
- .labels = NULL,+ range <- range_noinf(df[[.var]], na.rm = TRUE) |
||
| 232 | +82 |
- .indent_mods = NULL) {
+
|
||
| 233 | -5x | +83 | +232x |
- extra_args <- c(+ names(quantiles) <- as.character(100 * quantiles) |
| 234 | -5x | +84 | +232x |
- list(.stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str),+ srv_qt_tab_pre <- unlist(srv_qt_tab_pre) |
| 235 | -5x | +85 | +232x |
- list(n_events = n_events, id_var = id_var, control = control, label_fmt = label_fmt, ...)+ srv_qt_ci <- lapply(quantiles, function(x) {
|
| 236 | -+ | |||
| 86 | +464x |
- )+ name <- as.character(100 * x) |
||
| 237 | +87 | |||
| 238 | -5x | +88 | +464x |
- if (!summarize) {
+ c( |
| 239 | -3x | +89 | +464x |
- analyze(+ srv_qt_tab_pre[[paste0("quantile.", name)]],
|
| 240 | -3x | +90 | +464x |
- lyt,+ srv_qt_tab_pre[[paste0("lower.", name)]],
|
| 241 | -3x | +91 | +464x |
- vars,+ srv_qt_tab_pre[[paste0("upper.", name)]]
|
| 242 | -3x | +|||
| 92 | +
- show_labels = show_labels,+ ) |
|||
| 243 | -3x | +|||
| 93 | +
- table_names = table_names,+ })+ |
+ |||
| 94 | ++ | + | ||
| 244 | -3x | +95 | +232x |
- afun = a_incidence_rate,+ list( |
| 245 | -3x | +96 | +232x |
- na_str = na_str,+ median = formatters::with_label(unname(srv_tab["median"]), "Median"), |
| 246 | -3x | +97 | +232x |
- nested = nested,+ median_ci = formatters::with_label( |
| 247 | -3x | +98 | +232x |
- extra_args = extra_args+ unname(srv_tab[paste0(srv_fit$conf.int, c("LCL", "UCL"))]), f_conf_level(conf_level)
|
| 248 | +99 |
- )+ ), |
||
| 249 | -+ | |||
| 100 | +232x |
- } else {
+ quantiles = formatters::with_label( |
||
| 250 | -2x | +101 | +232x |
- summarize_row_groups(+ unname(srv_qt_tab), paste0(quantiles[1] * 100, "% and ", quantiles[2] * 100, "%-ile")+ |
+
| 102 | ++ |
+ ), |
||
| 251 | -2x | +103 | +232x |
- lyt,+ range_censor = formatters::with_label(range_censor, "Range (censored)"), |
| 252 | -2x | +104 | +232x |
- vars,+ range_event = formatters::with_label(range_event, "Range (event)"), |
| 253 | -2x | +105 | +232x |
- cfun = a_incidence_rate,+ range = formatters::with_label(range, "Range"), |
| 254 | -2x | +106 | +232x |
- na_str = na_str,+ median_ci_3d = formatters::with_label( |
| 255 | -2x | +107 | +232x |
- extra_args = extra_args+ c( |
| 256 | -+ | |||
| 108 | +232x |
- )+ unname(srv_tab["median"]), |
||
| 257 | -+ | |||
| 109 | +232x |
- }+ unname(srv_tab[paste0(srv_fit$conf.int, c("LCL", "UCL"))])
|
||
| 258 | +110 |
- }+ ), |
| 1 | -+ | |||
| 111 | +232x |
- #' Cox proportional hazards regression+ paste0("Median (", f_conf_level(conf_level), ")")
|
||
| 2 | +112 |
- #'+ ), |
||
| 3 | -+ | |||
| 113 | +232x |
- #' @description `r lifecycle::badge("stable")`
+ quantiles_lower = formatters::with_label( |
||
| 4 | -+ | |||
| 114 | +232x |
- #'+ unname(srv_qt_ci[[1]]), paste0(quantiles[1] * 100, "%-ile (", f_conf_level(conf_level), ")")
|
||
| 5 | +115 |
- #' Fits a Cox regression model and estimates hazard ratio to describe the effect size in a survival analysis.+ ), |
||
| 6 | -+ | |||
| 116 | +232x |
- #'+ quantiles_upper = formatters::with_label( |
||
| 7 | -+ | |||
| 117 | +232x |
- #' @inheritParams argument_convention+ unname(srv_qt_ci[[2]]), paste0(quantiles[2] * 100, "%-ile (", f_conf_level(conf_level), ")")
|
||
| 8 | +118 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ ) |
||
| 9 | +119 |
- #'+ ) |
||
| 10 | +120 |
- #' Options are: ``r shQuote(get_stats("summarize_coxreg"))``
+ } |
||
| 11 | +121 |
- #'+ |
||
| 12 | +122 |
- #' @details Cox models are the most commonly used methods to estimate the magnitude of+ #' @describeIn survival_time Formatted analysis function which is used as `afun` in `surv_time()`. |
||
| 13 | +123 |
- #' the effect in survival analysis. It assumes proportional hazards: the ratio+ #' |
||
| 14 | +124 |
- #' of the hazards between groups (e.g., two arms) is constant over time.+ #' @return |
||
| 15 | +125 |
- #' This ratio is referred to as the "hazard ratio" (HR) and is one of the+ #' * `a_surv_time()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 16 | +126 |
- #' most commonly reported metrics to describe the effect size in survival+ #' |
||
| 17 | +127 |
- #' analysis (NEST Team, 2020).+ #' @examples |
||
| 18 | +128 |
- #'+ #' a_surv_time( |
||
| 19 | +129 |
- #' @seealso [fit_coxreg] for relevant fitting functions, [h_cox_regression] for relevant+ #' df, |
||
| 20 | +130 |
- #' helper functions, and [tidy_coxreg] for custom tidy methods.+ #' .df_row = df, |
||
| 21 | +131 |
- #'+ #' .var = "AVAL", |
||
| 22 | +132 |
- #' @examples+ #' is_event = "is_event" |
||
| 23 | +133 |
- #' library(survival)+ #' ) |
||
| 24 | +134 |
#' |
||
| 25 | +135 |
- #' # Testing dataset [survival::bladder].+ #' @export |
||
| 26 | +136 |
- #' set.seed(1, kind = "Mersenne-Twister")+ a_surv_time <- function(df, |
||
| 27 | +137 |
- #' dta_bladder <- with(+ labelstr = "", |
||
| 28 | +138 |
- #' data = bladder[bladder$enum < 5, ],+ .var = NULL, |
||
| 29 | +139 |
- #' tibble::tibble(+ .df_row = NULL, |
||
| 30 | +140 |
- #' TIME = stop,+ is_event, |
||
| 31 | +141 |
- #' STATUS = event,+ control = control_surv_time(), |
||
| 32 | +142 |
- #' ARM = as.factor(rx),+ ref_fn_censor = TRUE, |
||
| 33 | +143 |
- #' COVAR1 = as.factor(enum) %>% formatters::with_label("A Covariate Label"),
+ .stats = NULL, |
||
| 34 | +144 |
- #' COVAR2 = factor(+ .formats = NULL, |
||
| 35 | +145 |
- #' sample(as.factor(enum)),+ .labels = NULL, |
||
| 36 | +146 |
- #' levels = 1:4, labels = c("F", "F", "M", "M")
+ .indent_mods = NULL, |
||
| 37 | +147 |
- #' ) %>% formatters::with_label("Sex (F/M)")
+ na_str = default_na_str()) {
|
||
| 38 | -+ | |||
| 148 | +14x |
- #' )+ x_stats <- s_surv_time( |
||
| 39 | -+ | |||
| 149 | +14x |
- #' )+ df = df, .var = .var, is_event = is_event, control = control |
||
| 40 | +150 |
- #' dta_bladder$AGE <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ ) |
||
| 41 | -+ | |||
| 151 | +14x |
- #' dta_bladder$STUDYID <- factor("X")
+ rng_censor_lwr <- x_stats[["range_censor"]][1] |
||
| 42 | -+ | |||
| 152 | +14x |
- #'+ rng_censor_upr <- x_stats[["range_censor"]][2] |
||
| 43 | +153 |
- #' u1_variables <- list(+ |
||
| 44 | +154 |
- #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
+ # Use method-specific defaults |
||
| 45 | -+ | |||
| 155 | +14x |
- #' )+ fmts <- c( |
||
| 46 | -+ | |||
| 156 | +14x |
- #'+ median_ci = "(xx.x, xx.x)", quantiles = "xx.x, xx.x", range = "xx.x to xx.x", |
||
| 47 | -+ | |||
| 157 | +14x |
- #' u2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
+ median_ci_3d = "xx.x (xx.x - xx.x)", |
||
| 48 | -+ | |||
| 158 | +14x |
- #'+ quantiles_lower = "xx.x (xx.x - xx.x)", quantiles_upper = "xx.x (xx.x - xx.x)" |
||
| 49 | +159 |
- #' m1_variables <- list(+ ) |
||
| 50 | -+ | |||
| 160 | +14x |
- #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
+ lbls <- c( |
||
| 51 | -+ | |||
| 161 | +14x |
- #' )+ median_ci = "95% CI", range = "Range", range_censor = "Range (censored)", range_event = "Range (event)", |
||
| 52 | -+ | |||
| 162 | +14x |
- #'+ median_ci_3d = "Median (95% CI)", |
||
| 53 | -+ | |||
| 163 | +14x |
- #' m2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
+ quantiles_lower = "25%-ile (95% CI)", |
||
| 54 | -+ | |||
| 164 | +14x |
- #'+ quantiles_upper = "75%-ile (95% CI)" |
||
| 55 | +165 |
- #' @name cox_regression+ ) |
||
| 56 | -+ | |||
| 166 | +14x |
- #' @order 1+ lbls_custom <- .labels |
||
| 57 | -+ | |||
| 167 | +14x |
- NULL+ .formats <- c(.formats, fmts[setdiff(names(fmts), names(.formats))])+ |
+ ||
| 168 | +14x | +
+ .labels <- c(.labels, lbls[setdiff(names(lbls), names(lbls_custom))]) |
||
| 58 | +169 | |||
| 59 | +170 |
- #' @describeIn cox_regression Statistics function that transforms results tabulated+ # Fill in with formatting defaults if needed |
||
| 60 | -+ | |||
| 171 | +14x |
- #' from [fit_coxreg_univar()] or [fit_coxreg_multivar()] into a list.+ .stats <- get_stats("surv_time", stats_in = .stats)
|
||
| 61 | -+ | |||
| 172 | +14x |
- #'+ .formats <- get_formats_from_stats(.stats, .formats) |
||
| 62 | -+ | |||
| 173 | +14x |
- #' @param model_df (`data.frame`)\cr contains the resulting model fit from a [fit_coxreg]+ .labels <- get_labels_from_stats(.stats, .labels) %>% labels_use_control(control, lbls_custom) |
||
| 63 | -+ | |||
| 174 | +14x |
- #' function with tidying applied via [broom::tidy()].+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods) |
||
| 64 | +175 |
- #' @param .stats (`character`)\cr the names of statistics to be reported among:+ |
||
| 65 | -+ | |||
| 176 | +14x |
- #' * `n`: number of observations (univariate only)+ x_stats <- x_stats[.stats] |
||
| 66 | +177 |
- #' * `hr`: hazard ratio+ |
||
| 67 | +178 |
- #' * `ci`: confidence interval+ # Auto format handling |
||
| 68 | -+ | |||
| 179 | +14x |
- #' * `pval`: p-value of the treatment effect+ .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var) |
||
| 69 | +180 |
- #' * `pval_inter`: p-value of the interaction effect between the treatment and the covariate (univariate only)+ |
||
| 70 | -+ | |||
| 181 | +14x |
- #' @param .which_vars (`character`)\cr which rows should statistics be returned for from the given model.+ cell_fns <- setNames(vector("list", length = length(x_stats)), .labels)
|
||
| 71 | -+ | |||
| 182 | +14x |
- #' Defaults to `"all"`. Other options include `"var_main"` for main effects, `"inter"` for interaction effects,+ if ("range" %in% names(x_stats) && ref_fn_censor) {
|
||
| 72 | -+ | |||
| 183 | +14x |
- #' and `"multi_lvl"` for multivariate model covariate level rows. When `.which_vars` is `"all"`, specific+ if (identical(x_stats[["range"]][1], rng_censor_lwr) && identical(x_stats[["range"]][2], rng_censor_upr)) {
|
||
| 73 | -+ | |||
| 184 | +2x |
- #' variables can be selected by specifying `.var_nms`.+ cell_fns[[.labels[["range"]]]] <- "Censored observations: range minimum & maximum" |
||
| 74 | -+ | |||
| 185 | +12x |
- #' @param .var_nms (`character`)\cr the `term` value of rows in `df` for which `.stats` should be returned. Typically+ } else if (identical(x_stats[["range"]][1], rng_censor_lwr)) {
|
||
| 75 | -+ | |||
| 186 | +2x |
- #' this is the name of a variable. If using variable labels, `var` should be a vector of both the desired+ cell_fns[[.labels[["range"]]]] <- "Censored observation: range minimum" |
||
| 76 | -+ | |||
| 187 | +10x |
- #' variable name and the variable label in that order to see all `.stats` related to that variable. When `.which_vars`+ } else if (identical(x_stats[["range"]][2], rng_censor_upr)) {
|
||
| 77 | -+ | |||
| 188 | +1x |
- #' is `"var_main"`, `.var_nms` should be only the variable name.+ cell_fns[[.labels[["range"]]]] <- "Censored observation: range maximum" |
||
| 78 | +189 |
- #'+ } |
||
| 79 | +190 |
- #' @return+ } |
||
| 80 | +191 |
- #' * `s_coxreg()` returns the selected statistic for from the Cox regression model for the selected variable(s).+ |
||
| 81 | -+ | |||
| 192 | +14x |
- #'+ in_rows( |
||
| 82 | -+ | |||
| 193 | +14x |
- #' @examples+ .list = x_stats, |
||
| 83 | -+ | |||
| 194 | +14x |
- #' # s_coxreg+ .formats = .formats, |
||
| 84 | -+ | |||
| 195 | +14x |
- #'+ .names = .labels, |
||
| 85 | -+ | |||
| 196 | +14x |
- #' # Univariate+ .labels = .labels, |
||
| 86 | -+ | |||
| 197 | +14x |
- #' univar_model <- fit_coxreg_univar(variables = u1_variables, data = dta_bladder)+ .indent_mods = .indent_mods, |
||
| 87 | -+ | |||
| 198 | +14x |
- #' df1 <- broom::tidy(univar_model)+ .cell_footnotes = cell_fns |
||
| 88 | +199 |
- #'+ ) |
||
| 89 | +200 |
- #' s_coxreg(model_df = df1, .stats = "hr")+ } |
||
| 90 | +201 |
- #'+ |
||
| 91 | +202 |
- #' # Univariate with interactions+ #' @describeIn survival_time Layout-creating function which can take statistics function arguments |
||
| 92 | +203 |
- #' univar_model_inter <- fit_coxreg_univar(+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 93 | +204 |
- #' variables = u1_variables, control = control_coxreg(interaction = TRUE), data = dta_bladder+ #' |
||
| 94 | +205 |
- #' )+ #' @return |
||
| 95 | +206 |
- #' df1_inter <- broom::tidy(univar_model_inter)+ #' * `surv_time()` returns a layout object suitable for passing to further layouting functions, |
||
| 96 | +207 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 97 | +208 |
- #' s_coxreg(model_df = df1_inter, .stats = "hr", .which_vars = "inter", .var_nms = "COVAR1")+ #' the statistics from `s_surv_time()` to the table layout. |
||
| 98 | +209 |
#' |
||
| 99 | +210 |
- #' # Univariate without treatment arm - only "COVAR2" covariate effects+ #' @examples |
||
| 100 | +211 |
- #' univar_covs_model <- fit_coxreg_univar(variables = u2_variables, data = dta_bladder)+ #' basic_table() %>% |
||
| 101 | +212 |
- #' df1_covs <- broom::tidy(univar_covs_model)+ #' split_cols_by(var = "ARMCD") %>% |
||
| 102 | +213 |
- #'+ #' add_colcounts() %>% |
||
| 103 | +214 |
- #' s_coxreg(model_df = df1_covs, .stats = "hr", .var_nms = c("COVAR2", "Sex (F/M)"))
+ #' surv_time( |
||
| 104 | +215 |
- #'+ #' vars = "AVAL", |
||
| 105 | +216 |
- #' # Multivariate.+ #' var_labels = "Survival Time (Months)", |
||
| 106 | +217 |
- #' multivar_model <- fit_coxreg_multivar(variables = m1_variables, data = dta_bladder)+ #' is_event = "is_event", |
||
| 107 | +218 |
- #' df2 <- broom::tidy(multivar_model)+ #' control = control_surv_time(conf_level = 0.9, conf_type = "log-log") |
||
| 108 | +219 |
- #'+ #' ) %>% |
||
| 109 | +220 |
- #' s_coxreg(model_df = df2, .stats = "pval", .which_vars = "var_main", .var_nms = "COVAR1")+ #' build_table(df = adtte_f) |
||
| 110 | +221 |
- #' s_coxreg(+ #' |
||
| 111 | +222 |
- #' model_df = df2, .stats = "pval", .which_vars = "multi_lvl",+ #' @export |
||
| 112 | +223 |
- #' .var_nms = c("COVAR1", "A Covariate Label")
+ #' @order 2 |
||
| 113 | +224 |
- #' )+ surv_time <- function(lyt, |
||
| 114 | +225 |
- #'+ vars, |
||
| 115 | +226 |
- #' # Multivariate without treatment arm - only "COVAR1" main effect+ is_event, |
||
| 116 | +227 |
- #' multivar_covs_model <- fit_coxreg_multivar(variables = m2_variables, data = dta_bladder)+ control = control_surv_time(), |
||
| 117 | +228 |
- #' df2_covs <- broom::tidy(multivar_covs_model)+ ref_fn_censor = TRUE, |
||
| 118 | +229 |
- #'+ na_str = default_na_str(), |
||
| 119 | +230 |
- #' s_coxreg(model_df = df2_covs, .stats = "hr")+ nested = TRUE, |
||
| 120 | +231 |
- #'+ ..., |
||
| 121 | +232 |
- #' @export+ var_labels = "Time to Event", |
||
| 122 | +233 |
- s_coxreg <- function(model_df, .stats, .which_vars = "all", .var_nms = NULL) {
+ show_labels = "visible", |
||
| 123 | -291x | +|||
| 234 | +
- assert_df_with_variables(model_df, list(term = "term", stat = .stats))+ table_names = vars, |
|||
| 124 | -291x | +|||
| 235 | +
- checkmate::assert_multi_class(model_df$term, classes = c("factor", "character"))
+ .stats = c("median", "median_ci", "quantiles", "range"),
|
|||
| 125 | -291x | +|||
| 236 | +
- model_df$term <- as.character(model_df$term)+ .formats = NULL, |
|||
| 126 | -291x | +|||
| 237 | +
- .var_nms <- .var_nms[!is.na(.var_nms)]+ .labels = NULL, |
|||
| 127 | +238 |
-
+ .indent_mods = c(median_ci = 1L)) {
|
||
| 128 | -289x | +239 | +3x |
- if (length(.var_nms) > 0) model_df <- model_df[model_df$term %in% .var_nms, ]+ extra_args <- list( |
| 129 | -69x | +240 | +3x |
- if (.which_vars == "multi_lvl") model_df$term <- tail(.var_nms, 1)+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, |
| 130 | -+ | |||
| 241 | +3x |
-
+ is_event = is_event, control = control, ref_fn_censor = ref_fn_censor, ... |
||
| 131 | +242 |
- # We need a list with names corresponding to the stats to display of equal length to the list of stats.- |
- ||
| 132 | -291x | -
- y <- split(model_df, f = model_df$term, drop = FALSE)- |
- ||
| 133 | -291x | -
- y <- stats::setNames(y, nm = rep(.stats, length(y)))+ ) |
||
| 134 | +243 | |||
| 135 | -291x | +244 | +3x |
- if (.which_vars == "var_main") {
+ analyze( |
| 136 | -128x | +245 | +3x |
- y <- lapply(y, function(x) x[1, ]) # only main effect+ lyt = lyt, |
| 137 | -163x | +246 | +3x |
- } else if (.which_vars %in% c("inter", "multi_lvl")) {
+ vars = vars, |
| 138 | -120x | -
- y <- lapply(y, function(x) if (nrow(y[[1]]) > 1) x[-1, ] else x) # exclude main effect- |
- ||
| 139 | -- |
- }- |
- ||
| 140 | -+ | 247 | +3x |
-
+ afun = a_surv_time, |
| 141 | -291x | +248 | +3x |
- lapply(+ var_labels = var_labels, |
| 142 | -291x | +249 | +3x |
- X = y,+ show_labels = show_labels, |
| 143 | -291x | +250 | +3x |
- FUN = function(x) {
+ table_names = table_names, |
| 144 | -295x | +251 | +3x |
- z <- as.list(x[[.stats]])+ na_str = na_str, |
| 145 | -295x | +252 | +3x |
- stats::setNames(z, nm = x$term_label)+ nested = nested, |
| 146 | -+ | |||
| 253 | +3x |
- }+ extra_args = extra_args |
||
| 147 | +254 |
) |
||
| 148 | +255 |
} |
| 149 | -- | - - | -||
| 150 | -- |
- #' @describeIn cox_regression Analysis function which is used as `afun` in [rtables::analyze()]- |
- ||
| 151 | +1 |
- #' and `cfun` in [rtables::summarize_row_groups()] within `summarize_coxreg()`.+ #' Count patients with marked laboratory abnormalities |
||
| 152 | +2 |
#' |
||
| 153 | +3 |
- #' @param eff (`flag`)\cr whether treatment effect should be calculated. Defaults to `FALSE`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 154 | +4 |
- #' @param var_main (`flag`)\cr whether main effects should be calculated. Defaults to `FALSE`.+ #' |
||
| 155 | +5 |
- #' @param na_str (`string`)\cr custom string to replace all `NA` values with. Defaults to `""`.+ #' The analyze function [count_abnormal_by_marked()] creates a layout element to count patients with marked laboratory |
||
| 156 | +6 |
- #' @param cache_env (`environment`)\cr an environment object used to cache the regression model in order to+ #' abnormalities for each direction of abnormality, categorized by parameter value. |
||
| 157 | +7 |
- #' avoid repeatedly fitting the same model for every row in the table. Defaults to `NULL` (no caching).+ #' |
||
| 158 | +8 |
- #' @param varlabels (`list`)\cr a named list corresponds to the names of variables found in data, passed+ #' This function analyzes primary analysis variable `var` which indicates whether a single, replicated, |
||
| 159 | +9 |
- #' as a named list and corresponding to time, event, arm, strata, and covariates terms. If arm is missing+ #' or last marked laboratory abnormality was observed. Levels of `var` to include for each marked lab |
||
| 160 | +10 |
- #' from variables, then only Cox model(s) including the covariates will be fitted and the corresponding+ #' abnormality (`single` and `last_replicated`) can be supplied via the `category` parameter. Additional |
||
| 161 | +11 |
- #' effect estimates will be tabulated later.+ #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults |
||
| 162 | +12 |
- #'+ #' to `USUBJID`), a variable to indicate unique subject identifiers, `param` (defaults to `PARAM`), a |
||
| 163 | +13 |
- #' @return+ #' variable to indicate parameter values, and `direction` (defaults to `abn_dir`), a variable to indicate |
||
| 164 | +14 |
- #' * `a_coxreg()` returns formatted [rtables::CellValue()].+ #' abnormality directions. |
||
| 165 | +15 |
#' |
||
| 166 | +16 |
- #' @examples+ #' For each combination of `param` and `direction` levels, marked lab abnormality counts are calculated |
||
| 167 | +17 |
- #' a_coxreg(+ #' as follows: |
||
| 168 | +18 |
- #' df = dta_bladder,+ #' * `Single, not last` & `Last or replicated`: The number of patients with `Single, not last` |
||
| 169 | +19 |
- #' labelstr = "Label 1",+ #' and `Last or replicated` values, respectively. |
||
| 170 | +20 |
- #' variables = u1_variables,+ #' * `Any`: The number of patients with either single or replicated marked abnormalities. |
||
| 171 | +21 |
- #' .spl_context = list(value = "COVAR1"),+ #' |
||
| 172 | +22 |
- #' .stats = "n",+ #' Fractions are calculated by dividing the above counts by the number of patients with at least one |
||
| 173 | +23 |
- #' .formats = "xx"+ #' valid measurement recorded during the analysis. |
||
| 174 | +24 |
- #' )+ #' |
||
| 175 | +25 |
- #'+ #' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create two |
||
| 176 | +26 |
- #' a_coxreg(+ #' row splits, one on variable `param` and one on variable `direction`. |
||
| 177 | +27 |
- #' df = dta_bladder,+ #' |
||
| 178 | +28 |
- #' labelstr = "",+ #' @inheritParams argument_convention |
||
| 179 | +29 |
- #' variables = u1_variables,+ #' @param category (`list`)\cr a list with different marked category names for single |
||
| 180 | +30 |
- #' .spl_context = list(value = "COVAR2"),+ #' and last or replicated. |
||
| 181 | +31 |
- #' .stats = "pval",+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 182 | +32 |
- #' .formats = "xx.xxxx"+ #' |
||
| 183 | +33 |
- #' )+ #' Options are: ``r shQuote(get_stats("abnormal_by_marked"), type = "sh")``
|
||
| 184 | +34 |
#' |
||
| 185 | +35 |
- #' @export+ #' @note `Single, not last` and `Last or replicated` levels are mutually exclusive. If a patient has |
||
| 186 | +36 |
- a_coxreg <- function(df,+ #' abnormalities that meet both the `Single, not last` and `Last or replicated` criteria, then the |
||
| 187 | +37 |
- labelstr,+ #' patient will be counted only under the `Last or replicated` category. |
||
| 188 | +38 |
- eff = FALSE,+ #' |
||
| 189 | +39 |
- var_main = FALSE,+ #' @name abnormal_by_marked |
||
| 190 | +40 |
- multivar = FALSE,+ #' @order 1 |
||
| 191 | +41 |
- variables,+ NULL |
||
| 192 | +42 |
- at = list(),+ |
||
| 193 | +43 |
- control = control_coxreg(),+ #' @describeIn abnormal_by_marked Statistics function for patients with marked lab abnormalities. |
||
| 194 | +44 |
- .spl_context,+ #' |
||
| 195 | +45 |
- .stats,+ #' @return |
||
| 196 | +46 |
- .formats,+ #' * `s_count_abnormal_by_marked()` returns statistic `count_fraction` with `Single, not last`, |
||
| 197 | +47 |
- .indent_mods = NULL,+ #' `Last or replicated`, and `Any` results. |
||
| 198 | +48 |
- na_str = "",+ #' |
||
| 199 | +49 |
- cache_env = NULL) {
- |
- ||
| 200 | -288x | -
- cov_no_arm <- !multivar && !"arm" %in% names(variables) && control$interaction # special case: univar no arm- |
- ||
| 201 | -288x | -
- cov <- tail(.spl_context$value, 1) # current variable/covariate- |
- ||
| 202 | -288x | -
- var_lbl <- formatters::var_labels(df)[cov] # check for df labels- |
- ||
| 203 | -288x | -
- if (length(labelstr) > 1) {
- |
- ||
| 204 | -8x | -
- labelstr <- if (cov %in% names(labelstr)) labelstr[[cov]] else var_lbl # use df labels if none- |
- ||
| 205 | -280x | -
- } else if (!is.na(var_lbl) && labelstr == cov && cov %in% variables$covariates) {
- |
- ||
| 206 | -67x | -
- labelstr <- var_lbl+ #' @keywords internal |
||
| 207 | +50 |
- }- |
- ||
| 208 | -288x | -
- if (eff || multivar || cov_no_arm) {
- |
- ||
| 209 | -143x | -
- control$interaction <- FALSE+ s_count_abnormal_by_marked <- function(df, |
||
| 210 | +51 |
- } else {
- |
- ||
| 211 | -145x | -
- variables$covariates <- cov- |
- ||
| 212 | -50x | -
- if (var_main) control$interaction <- TRUE+ .var = "AVALCAT1", |
||
| 213 | +52 |
- }+ .spl_context, |
||
| 214 | +53 | - - | -||
| 215 | -288x | -
- if (is.null(cache_env[[cov]])) {
- |
- ||
| 216 | -47x | -
- if (!multivar) {
- |
- ||
| 217 | -32x | -
- model <- fit_coxreg_univar(variables = variables, data = df, at = at, control = control) %>% broom::tidy()+ category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
|
||
| 218 | +54 |
- } else {
+ variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir")) {
|
||
| 219 | -15x | -
- model <- fit_coxreg_multivar(variables = variables, data = df, control = control) %>% broom::tidy()- |
- ||
| 220 | -+ | 55 | +3x |
- }+ checkmate::assert_string(.var) |
| 221 | -47x | +56 | +3x |
- cache_env[[cov]] <- model+ checkmate::assert_list(variables) |
| 222 | -+ | |||
| 57 | +3x |
- } else {
+ checkmate::assert_list(category) |
||
| 223 | -241x | +58 | +3x |
- model <- cache_env[[cov]]+ checkmate::assert_subset(names(category), c("single", "last_replicated"))
|
| 224 | -+ | |||
| 59 | +3x |
- }+ checkmate::assert_subset(names(variables), c("id", "param", "direction"))
|
||
| 225 | -148x | +60 | +3x |
- if (!multivar && !var_main) model[, "pval_inter"] <- NA_real_+ checkmate::assert_vector(unique(df[[variables$direction]]), max.len = 1) |
| 226 | +61 | |||
| 227 | -288x | +62 | +2x |
- if (cov_no_arm || (!cov_no_arm && !"arm" %in% names(variables) && is.numeric(df[[cov]]))) {
+ assert_df_with_variables(df, c(aval = .var, variables)) |
| 228 | -15x | +63 | +2x |
- multivar <- TRUE+ checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
|
| 229 | -3x | +64 | +2x |
- if (!cov_no_arm) var_main <- TRUE+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
| 230 | +65 |
- }+ |
||
| 231 | +66 | |||
| 232 | -288x | -
- vars_coxreg <- list(which_vars = "all", var_nms = NULL)- |
- ||
| 233 | -288x | +67 | +2x |
- if (eff) {
+ first_row <- .spl_context[.spl_context$split == variables[["param"]], ] |
| 234 | -65x | +|||
| 68 | +
- if (multivar && !var_main) { # multivar treatment level
+ # Patients in the denominator have at least one post-baseline visit. |
|||
| 235 | -12x | +69 | +2x |
- var_lbl_arm <- formatters::var_labels(df)[[variables$arm]]+ subj <- first_row$full_parent_df[[1]][[variables[["id"]]]] |
| 236 | -12x | +70 | +2x |
- vars_coxreg[c("var_nms", "which_vars")] <- list(c(variables$arm, var_lbl_arm), "multi_lvl")
+ subj_cur_col <- subj[first_row$cur_col_subset[[1]]] |
| 237 | +71 |
- } else { # treatment effect
+ # Some subjects may have a record for high and low directions but |
||
| 238 | -53x | +|||
| 72 | +
- vars_coxreg["var_nms"] <- variables$arm+ # should be counted only once. |
|||
| 239 | -12x | +73 | +2x |
- if (var_main) vars_coxreg["which_vars"] <- "var_main"+ denom <- length(unique(subj_cur_col)) |
| 240 | +74 |
- }+ |
||
| 241 | -+ | |||
| 75 | +2x |
- } else {
+ if (denom != 0) {
|
||
| 242 | -223x | +76 | +2x |
- if (!multivar || (multivar && var_main && !is.numeric(df[[cov]]))) { # covariate effect/level
+ subjects_last_replicated <- unique( |
| 243 | -166x | +77 | +2x |
- vars_coxreg[c("var_nms", "which_vars")] <- list(cov, "var_main")
+ df[df[[.var]] %in% category[["last_replicated"]], variables$id, drop = TRUE] |
| 244 | -57x | +|||
| 78 | +
- } else if (multivar) { # multivar covariate level
+ ) |
|||
| 245 | -57x | +79 | +2x |
- vars_coxreg[c("var_nms", "which_vars")] <- list(c(cov, var_lbl), "multi_lvl")
+ subjects_single <- unique( |
| 246 | -12x | +80 | +2x |
- if (var_main) model[cov, .stats] <- NA_real_+ df[df[[.var]] %in% category[["single"]], variables$id, drop = TRUE] |
| 247 | +81 |
- }- |
- ||
| 248 | -50x | -
- if (!multivar && !var_main && control$interaction) vars_coxreg["which_vars"] <- "inter" # interaction effect+ ) |
||
| 249 | +82 |
- }+ # Subjects who have both single and last/replicated abnormalities are counted in only the last/replicated group. |
||
| 250 | -288x | +83 | +2x |
- var_vals <- s_coxreg(model, .stats, .which_vars = vars_coxreg$which_vars, .var_nms = vars_coxreg$var_nms)[[1]]+ subjects_single <- setdiff(subjects_single, subjects_last_replicated) |
| 251 | -288x | +84 | +2x |
- var_names <- if (all(grepl("\\(reference = ", names(var_vals))) && labelstr != tail(.spl_context$value, 1)) {
+ n_single <- length(subjects_single) |
| 252 | -27x | +85 | +2x |
- paste(c(labelstr, tail(strsplit(names(var_vals), " ")[[1]], 3)), collapse = " ") # "reference" main effect labels+ n_last_replicated <- length(subjects_last_replicated) |
| 253 | -288x | +86 | +2x |
- } else if ((!multivar && !eff && !(!var_main && control$interaction) && nchar(labelstr) > 0) ||+ n_any <- n_single + n_last_replicated |
| 254 | -288x | +87 | +2x |
- (multivar && var_main && is.numeric(df[[cov]]))) { # nolint
+ result <- list(count_fraction = list( |
| 255 | -71x | +88 | +2x |
- labelstr # other main effect labels+ "Single, not last" = c(n_single, n_single / denom), |
| 256 | -288x | +89 | +2x |
- } else if (multivar && !eff && !var_main && is.numeric(df[[cov]])) {
+ "Last or replicated" = c(n_last_replicated, n_last_replicated / denom), |
| 257 | -12x | +90 | +2x |
- "All" # multivar numeric covariate+ "Any Abnormality" = c(n_any, n_any / denom) |
| 258 | +91 |
- } else {
- |
- ||
| 259 | -178x | -
- names(var_vals)+ )) |
||
| 260 | +92 |
- }+ } else {
|
||
| 261 | -288x | +|||
| 93 | +! |
- in_rows(+ result <- list(count_fraction = list( |
||
| 262 | -288x | +|||
| 94 | +! |
- .list = var_vals, .names = var_names, .labels = var_names, .indent_mods = .indent_mods,+ "Single, not last" = c(0, 0), |
||
| 263 | -288x | +|||
| 95 | +! |
- .formats = stats::setNames(rep(.formats, length(var_names)), var_names),+ "Last or replicated" = c(0, 0), |
||
| 264 | -288x | +|||
| 96 | +! |
- .format_na_strs = stats::setNames(rep(na_str, length(var_names)), var_names)+ "Any Abnormality" = c(0, 0) |
||
| 265 | +97 |
- )+ )) |
||
| 266 | +98 |
- }+ } |
||
| 267 | +99 | |||
| 100 | +2x | +
+ result+ |
+ ||
| 268 | +101 |
- #' @describeIn cox_regression Layout-creating function which creates a Cox regression summary table+ } |
||
| 269 | +102 |
- #' layout. This function is a wrapper for several `rtables` layouting functions. This function+ |
||
| 270 | +103 |
- #' is a wrapper for [rtables::analyze_colvars()] and [rtables::summarize_row_groups()].+ #' @describeIn abnormal_by_marked Formatted analysis function which is used as `afun` |
||
| 271 | +104 |
- #'+ #' in `count_abnormal_by_marked()`. |
||
| 272 | +105 |
- #' @inheritParams fit_coxreg_univar+ #' |
||
| 273 | +106 |
- #' @param multivar (`flag`)\cr whether multivariate Cox regression should run (defaults to `FALSE`), otherwise+ #' @return |
||
| 274 | +107 |
- #' univariate Cox regression will run.+ #' * `a_count_abnormal_by_marked()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 275 | +108 |
- #' @param common_var (`string`)\cr the name of a factor variable in the dataset which takes the same value+ #' |
||
| 276 | +109 |
- #' for all rows. This should be created during pre-processing if no such variable currently exists.+ #' @keywords internal |
||
| 277 | +110 |
- #' @param .section_div (`string` or `NA`)\cr string which should be repeated as a section divider between sections.+ a_count_abnormal_by_marked <- make_afun( |
||
| 278 | +111 |
- #' Defaults to `NA` for no section divider. If a vector of two strings are given, the first will be used between+ s_count_abnormal_by_marked, |
||
| 279 | +112 |
- #' treatment and covariate sections and the second between different covariates.+ .formats = c(count_fraction = format_count_fraction) |
||
| 280 | +113 |
- #'+ ) |
||
| 281 | +114 |
- #' @return+ |
||
| 282 | +115 |
- #' * `summarize_coxreg()` returns a layout object suitable for passing to further layouting functions,+ #' @describeIn abnormal_by_marked Layout-creating function which can take statistics function arguments |
||
| 283 | +116 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add a Cox regression table+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 284 | +117 |
- #' containing the chosen statistics to the table layout.+ #' |
||
| 285 | +118 |
- #'+ #' @return |
||
| 286 | +119 |
- #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()] which also take the `variables`, `data`,+ #' * `count_abnormal_by_marked()` returns a layout object suitable for passing to further layouting functions, |
||
| 287 | +120 |
- #' `at` (univariate only), and `control` arguments but return unformatted univariate and multivariate+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 288 | +121 |
- #' Cox regression models, respectively.+ #' the statistics from `s_count_abnormal_by_marked()` to the table layout. |
||
| 289 | +122 |
#' |
||
| 290 | +123 |
#' @examples |
||
| 291 | +124 |
- #' # summarize_coxreg+ #' library(dplyr) |
||
| 292 | +125 |
#' |
||
| 293 | +126 |
- #' result_univar <- basic_table() %>%+ #' df <- data.frame( |
||
| 294 | +127 |
- #' summarize_coxreg(variables = u1_variables) %>%+ #' USUBJID = as.character(c(rep(1, 5), rep(2, 5), rep(1, 5), rep(2, 5))), |
||
| 295 | +128 |
- #' build_table(dta_bladder)+ #' ARMCD = factor(c(rep("ARM A", 5), rep("ARM B", 5), rep("ARM A", 5), rep("ARM B", 5))),
|
||
| 296 | +129 |
- #' result_univar+ #' ANRIND = factor(c( |
||
| 297 | +130 |
- #'+ #' "NORMAL", "HIGH", "HIGH", "HIGH HIGH", "HIGH", |
||
| 298 | +131 |
- #' result_univar_covs <- basic_table() %>%+ #' "HIGH", "HIGH", "HIGH HIGH", "NORMAL", "HIGH HIGH", "NORMAL", "LOW", "LOW", "LOW LOW", "LOW", |
||
| 299 | +132 |
- #' summarize_coxreg(+ #' "LOW", "LOW", "LOW LOW", "NORMAL", "LOW LOW" |
||
| 300 | +133 |
- #' variables = u2_variables,+ #' )), |
||
| 301 | +134 |
- #' ) %>%+ #' ONTRTFL = rep(c("", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y"), 2),
|
||
| 302 | +135 |
- #' build_table(dta_bladder)+ #' PARAMCD = factor(c(rep("CRP", 10), rep("ALT", 10))),
|
||
| 303 | +136 |
- #' result_univar_covs+ #' AVALCAT1 = factor(rep(c("", "", "", "SINGLE", "REPLICATED", "", "", "LAST", "", "SINGLE"), 2)),
|
||
| 304 | +137 |
- #'+ #' stringsAsFactors = FALSE |
||
| 305 | +138 |
- #' result_multivar <- basic_table() %>%+ #' ) |
||
| 306 | +139 |
- #' summarize_coxreg(+ #' |
||
| 307 | +140 |
- #' variables = m1_variables,+ #' df <- df %>% |
||
| 308 | +141 |
- #' multivar = TRUE,+ #' mutate(abn_dir = factor( |
||
| 309 | +142 |
- #' ) %>%+ #' case_when( |
||
| 310 | +143 |
- #' build_table(dta_bladder)+ #' ANRIND == "LOW LOW" ~ "Low", |
||
| 311 | +144 |
- #' result_multivar+ #' ANRIND == "HIGH HIGH" ~ "High", |
||
| 312 | +145 |
- #'+ #' TRUE ~ "" |
||
| 313 | +146 |
- #' result_multivar_covs <- basic_table() %>%+ #' ), |
||
| 314 | +147 |
- #' summarize_coxreg(+ #' levels = c("Low", "High")
|
||
| 315 | +148 |
- #' variables = m2_variables,+ #' )) |
||
| 316 | +149 |
- #' multivar = TRUE,+ #' |
||
| 317 | +150 |
- #' varlabels = c("Covariate 1", "Covariate 2") # custom labels
+ #' # Select only post-baseline records. |
||
| 318 | +151 |
- #' ) %>%+ #' df <- df %>% filter(ONTRTFL == "Y") |
||
| 319 | +152 |
- #' build_table(dta_bladder)+ #' df_crp <- df %>% |
||
| 320 | +153 |
- #' result_multivar_covs+ #' filter(PARAMCD == "CRP") %>% |
||
| 321 | +154 |
- #'+ #' droplevels() |
||
| 322 | +155 |
- #' @export+ #' full_parent_df <- list(df_crp, "not_needed") |
||
| 323 | +156 |
- #' @order 2+ #' cur_col_subset <- list(rep(TRUE, nrow(df_crp)), "not_needed") |
||
| 324 | +157 |
- summarize_coxreg <- function(lyt,+ #' spl_context <- data.frame( |
||
| 325 | +158 |
- variables,+ #' split = c("PARAMCD", "GRADE_DIR"),
|
||
| 326 | +159 |
- control = control_coxreg(),+ #' full_parent_df = I(full_parent_df), |
||
| 327 | +160 |
- at = list(),+ #' cur_col_subset = I(cur_col_subset) |
||
| 328 | +161 |
- multivar = FALSE,+ #' ) |
||
| 329 | +162 |
- common_var = "STUDYID",+ #' |
||
| 330 | +163 |
- .stats = c("n", "hr", "ci", "pval", "pval_inter"),
+ #' map <- unique( |
||
| 331 | +164 |
- .formats = c(+ #' df[df$abn_dir %in% c("Low", "High") & df$AVALCAT1 != "", c("PARAMCD", "abn_dir")]
|
||
| 332 | +165 |
- n = "xx", hr = "xx.xx", ci = "(xx.xx, xx.xx)",+ #' ) %>% |
||
| 333 | +166 |
- pval = "x.xxxx | (<0.0001)", pval_inter = "x.xxxx | (<0.0001)"+ #' lapply(as.character) %>% |
||
| 334 | +167 |
- ),+ #' as.data.frame() %>% |
||
| 335 | +168 |
- varlabels = NULL,+ #' arrange(PARAMCD, abn_dir) |
||
| 336 | +169 |
- .indent_mods = NULL,+ #' |
||
| 337 | +170 |
- na_str = "",+ #' basic_table() %>% |
||
| 338 | +171 |
- .section_div = NA_character_) {
- |
- ||
| 339 | -16x | -
- if (multivar && control$interaction) {
- |
- ||
| 340 | -1x | -
- warning(paste(- |
- ||
| 341 | -1x | -
- "Interactions are not available for multivariate cox regression using summarize_coxreg.",- |
- ||
| 342 | -1x | -
- "The model will be calculated without interaction effects."+ #' split_cols_by("ARMCD") %>%
|
||
| 343 | +172 |
- ))+ #' split_rows_by("PARAMCD") %>%
|
||
| 344 | +173 |
- }- |
- ||
| 345 | -16x | -
- if (control$interaction && !"arm" %in% names(variables)) {
- |
- ||
| 346 | -1x | -
- stop("To include interactions please specify 'arm' in variables.")
+ #' summarize_num_patients( |
||
| 347 | +174 |
- }+ #' var = "USUBJID", |
||
| 348 | +175 | - - | -||
| 349 | -15x | -
- .stats <- if (!"arm" %in% names(variables) || multivar) { # only valid statistics
- |
- ||
| 350 | -6x | -
- intersect(c("hr", "ci", "pval"), .stats)
- |
- ||
| 351 | -15x | -
- } else if (control$interaction) {
- |
- ||
| 352 | -5x | -
- intersect(c("n", "hr", "ci", "pval", "pval_inter"), .stats)
+ #' .stats = "unique_count" |
||
| 353 | +176 |
- } else {
- |
- ||
| 354 | -4x | -
- intersect(c("n", "hr", "ci", "pval"), .stats)
+ #' ) %>% |
||
| 355 | +177 |
- }- |
- ||
| 356 | -15x | -
- stat_labels <- c(- |
- ||
| 357 | -15x | -
- n = "n", hr = "Hazard Ratio", ci = paste0(control$conf_level * 100, "% CI"),- |
- ||
| 358 | -15x | -
- pval = "p-value", pval_inter = "Interaction p-value"+ #' split_rows_by( |
||
| 359 | +178 |
- )- |
- ||
| 360 | -15x | -
- stat_labels <- stat_labels[names(stat_labels) %in% .stats]- |
- ||
| 361 | -15x | -
- .formats <- .formats[names(.formats) %in% .stats]- |
- ||
| 362 | -15x | -
- env <- new.env() # create caching environment+ #' "abn_dir", |
||
| 363 | +179 | - - | -||
| 364 | -15x | -
- lyt <- lyt %>%- |
- ||
| 365 | -15x | -
- split_cols_by_multivar(- |
- ||
| 366 | -15x | -
- vars = rep(common_var, length(.stats)),- |
- ||
| 367 | -15x | -
- varlabels = stat_labels,- |
- ||
| 368 | -15x | -
- extra_args = list(- |
- ||
| 369 | -15x | -
- .stats = .stats, .formats = .formats, .indent_mods = .indent_mods, na_str = rep(na_str, length(.stats)),- |
- ||
| 370 | -15x | -
- cache_env = replicate(length(.stats), list(env))+ #' split_fun = trim_levels_to_map(map) |
||
| 371 | +180 |
- )+ #' ) %>% |
||
| 372 | +181 |
- )+ #' count_abnormal_by_marked( |
||
| 373 | +182 | - - | -||
| 374 | -15x | -
- if ("arm" %in% names(variables)) { # treatment effect
- |
- ||
| 375 | -13x | -
- lyt <- lyt %>%- |
- ||
| 376 | -13x | -
- split_rows_by(- |
- ||
| 377 | -13x | -
- common_var,- |
- ||
| 378 | -13x | -
- split_label = "Treatment:",- |
- ||
| 379 | -13x | -
- label_pos = "visible",- |
- ||
| 380 | -13x | -
- child_labels = "hidden",- |
- ||
| 381 | -13x | -
- section_div = head(.section_div, 1)+ #' var = "AVALCAT1", |
||
| 382 | +183 |
- )- |
- ||
| 383 | -13x | -
- if (!multivar) {
- |
- ||
| 384 | -9x | -
- lyt <- lyt %>%- |
- ||
| 385 | -9x | -
- analyze_colvars(- |
- ||
| 386 | -9x | -
- afun = a_coxreg,- |
- ||
| 387 | -9x | -
- na_str = na_str,- |
- ||
| 388 | -9x | -
- extra_args = list(- |
- ||
| 389 | -9x | -
- variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar,+ #' variables = list( |
||
| 390 | -9x | +|||
| 184 | +
- labelstr = ""+ #' id = "USUBJID", |
|||
| 391 | +185 |
- )+ #' param = "PARAMCD", |
||
| 392 | +186 |
- )+ #' direction = "abn_dir" |
||
| 393 | +187 |
- } else { # treatment level effects
+ #' ) |
||
| 394 | -4x | +|||
| 188 | +
- lyt <- lyt %>%+ #' ) %>% |
|||
| 395 | -4x | +|||
| 189 | +
- summarize_row_groups(+ #' build_table(df = df) |
|||
| 396 | -4x | +|||
| 190 | +
- cfun = a_coxreg,+ #' |
|||
| 397 | -4x | +|||
| 191 | +
- na_str = na_str,+ #' basic_table() %>% |
|||
| 398 | -4x | +|||
| 192 | +
- extra_args = list(+ #' split_cols_by("ARMCD") %>%
|
|||
| 399 | -4x | +|||
| 193 | +
- variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar+ #' split_rows_by("PARAMCD") %>%
|
|||
| 400 | +194 |
- )+ #' summarize_num_patients( |
||
| 401 | +195 |
- ) %>%+ #' var = "USUBJID", |
||
| 402 | -4x | +|||
| 196 | +
- analyze_colvars(+ #' .stats = "unique_count" |
|||
| 403 | -4x | +|||
| 197 | +
- afun = a_coxreg,+ #' ) %>% |
|||
| 404 | -4x | +|||
| 198 | +
- na_str = na_str,+ #' split_rows_by( |
|||
| 405 | -4x | +|||
| 199 | +
- extra_args = list(eff = TRUE, control = control, variables = variables, multivar = multivar, labelstr = "")+ #' "abn_dir", |
|||
| 406 | +200 |
- )+ #' split_fun = trim_levels_in_group("abn_dir")
|
||
| 407 | +201 |
- }+ #' ) %>% |
||
| 408 | +202 |
- }+ #' count_abnormal_by_marked( |
||
| 409 | +203 |
-
+ #' var = "AVALCAT1", |
||
| 410 | -15x | +|||
| 204 | +
- if ("covariates" %in% names(variables)) { # covariate main effects
+ #' variables = list( |
|||
| 411 | -15x | +|||
| 205 | +
- lyt <- lyt %>%+ #' id = "USUBJID", |
|||
| 412 | -15x | +|||
| 206 | +
- split_rows_by_multivar(+ #' param = "PARAMCD", |
|||
| 413 | -15x | +|||
| 207 | +
- vars = variables$covariates,+ #' direction = "abn_dir" |
|||
| 414 | -15x | +|||
| 208 | +
- varlabels = varlabels,+ #' ) |
|||
| 415 | -15x | +|||
| 209 | +
- split_label = "Covariate:",+ #' ) %>% |
|||
| 416 | -15x | +|||
| 210 | +
- nested = FALSE,+ #' build_table(df = df) |
|||
| 417 | -15x | +|||
| 211 | +
- child_labels = if (multivar || control$interaction || !"arm" %in% names(variables)) "default" else "hidden",+ #' |
|||
| 418 | -15x | +|||
| 212 | +
- section_div = tail(.section_div, 1)+ #' @export |
|||
| 419 | +213 |
- )+ #' @order 2 |
||
| 420 | -15x | +|||
| 214 | +
- if (multivar || control$interaction || !"arm" %in% names(variables)) {
+ count_abnormal_by_marked <- function(lyt, |
|||
| 421 | -11x | +|||
| 215 | +
- lyt <- lyt %>%+ var, |
|||
| 422 | -11x | +|||
| 216 | +
- summarize_row_groups(+ category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
|
|||
| 423 | -11x | +|||
| 217 | +
- cfun = a_coxreg,+ variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir"), |
|||
| 424 | -11x | +|||
| 218 | +
- na_str = na_str,+ na_str = default_na_str(), |
|||
| 425 | -11x | +|||
| 219 | +
- extra_args = list(+ nested = TRUE, |
|||
| 426 | -11x | +|||
| 220 | +
- variables = variables, at = at, control = control, multivar = multivar,+ ..., |
|||
| 427 | -11x | +|||
| 221 | +
- var_main = if (multivar) multivar else control$interaction+ .stats = NULL, |
|||
| 428 | +222 |
- )+ .formats = NULL, |
||
| 429 | +223 |
- )+ .labels = NULL, |
||
| 430 | +224 |
- } else {
+ .indent_mods = NULL) {
|
||
| 431 | +225 | 1x |
- if (!is.null(varlabels)) names(varlabels) <- variables$covariates+ checkmate::assert_string(var) |
|
| 432 | -4x | +|||
| 226 | +
- lyt <- lyt %>%+ |
|||
| 433 | -4x | +227 | +1x |
- analyze_colvars(+ extra_args <- list(category = category, variables = variables, ...) |
| 434 | -4x | +|||
| 228 | +
- afun = a_coxreg,+ |
|||
| 435 | -4x | +229 | +1x |
- na_str = na_str,+ afun <- make_afun( |
| 436 | -4x | +230 | +1x |
- extra_args = list(+ a_count_abnormal_by_marked, |
| 437 | -4x | +231 | +1x |
- variables = variables, at = at, control = control, multivar = multivar,+ .stats = .stats, |
| 438 | -4x | +232 | +1x |
- var_main = if (multivar) multivar else control$interaction,+ .formats = .formats, |
| 439 | -4x | +233 | +1x |
- labelstr = if (is.null(varlabels)) "" else varlabels+ .labels = .labels, |
| 440 | -+ | |||
| 234 | +1x |
- )+ .indent_mods = .indent_mods, |
||
| 441 | -+ | |||
| 235 | +1x |
- )+ .ungroup_stats = "count_fraction" |
||
| 442 | +236 |
- }+ ) |
||
| 443 | +237 | |||
| 444 | -2x | +238 | +1x |
- if (!"arm" %in% names(variables)) control$interaction <- TRUE # special case: univar no arm+ lyt <- analyze( |
| 445 | -15x | +239 | +1x |
- if (multivar || control$interaction) { # covariate level effects
+ lyt = lyt, |
| 446 | -11x | +240 | +1x |
- lyt <- lyt %>%+ vars = var, |
| 447 | -11x | +241 | +1x |
- analyze_colvars(+ afun = afun, |
| 448 | -11x | +242 | +1x |
- afun = a_coxreg,+ na_str = na_str, |
| 449 | -11x | +243 | +1x |
- na_str = na_str,+ nested = nested, |
| 450 | -11x | +244 | +1x |
- extra_args = list(variables = variables, at = at, control = control, multivar = multivar, labelstr = ""),+ show_labels = "hidden", |
| 451 | -11x | -
- indent_mod = if (!"arm" %in% names(variables) || multivar) 0L else -1L- |
- ||
| 452 | -- |
- )- |
- ||
| 453 | -- |
- }- |
- ||
| 454 | -+ | 245 | +1x |
- }+ extra_args = extra_args |
| 455 | +246 |
-
+ ) |
||
| 456 | -15x | +247 | +1x |
lyt |
| 457 | +248 |
}@@ -141836,126 +144200,126 @@ tern coverage - 95.59% |
| 1 |
- #' Helper functions for incidence rate+ # summarize_glm_count ---------------------------------------------------------- |
||
| 2 |
- #'+ #' Summarize Poisson negative binomial regression |
||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 4 |
- #'+ #' @description `r lifecycle::badge("experimental")`
|
||
| 5 |
- #' @param control (`list`)\cr parameters for estimation details, specified by using+ #' |
||
| 6 |
- #' the helper function [control_incidence_rate()]. Possible parameter options are:+ #' Summarize results of a Poisson negative binomial regression. |
||
| 7 |
- #' * `conf_level`: (`proportion`)\cr confidence level for the estimated incidence rate.+ #' This can be used to analyze count and/or frequency data using a linear model. |
||
| 8 |
- #' * `conf_type`: (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`+ #' It is specifically useful for analyzing count data (using the Poisson or Negative |
||
| 9 |
- #' for confidence interval type.+ #' Binomial distribution) that is result of a generalized linear model of one (e.g. arm) or more |
||
| 10 |
- #' * `input_time_unit`: (`string`)\cr `day`, `week`, `month`, or `year` (default)+ #' covariates. |
||
| 11 |
- #' indicating time unit for data input.+ #' |
||
| 12 |
- #' * `num_pt_year`: (`numeric`)\cr time unit for desired output (in person-years).+ #' @inheritParams h_glm_count |
||
| 13 |
- #' @param person_years (`numeric(1)`)\cr total person-years at risk.+ #' @inheritParams argument_convention |
||
| 14 |
- #' @param alpha (`numeric(1)`)\cr two-sided alpha-level for confidence interval.+ #' @param rate_mean_method (`character(1)`)\cr method used to estimate the mean odds ratio. Defaults to `emmeans`. |
||
| 15 |
- #' @param n_events (`integer(1)`)\cr number of events observed.+ #' see details for more information. |
||
| 16 |
- #'+ #' @param scale (`numeric(1)`)\cr linear scaling factor for rate and confidence intervals. Defaults to `1`. |
||
| 17 |
- #' @return Estimated incidence rate, `rate`, and associated confidence interval, `rate_ci`.+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 19 |
- #' @seealso [incidence_rate]+ #' Options are: ``r shQuote(get_stats("summarize_glm_count"), type = "sh")``
|
||
| 21 |
- #' @name h_incidence_rate+ #' @details |
||
| 22 |
- NULL+ #' `summarize_glm_count()` uses `s_glm_count()` to calculate the statistics for the table. This |
||
| 23 |
-
+ #' analysis function uses [h_glm_count()] to estimate the GLM with [stats::glm()] for Poisson and Quasi-Poisson |
||
| 24 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ #' distributions or [MASS::glm.nb()] for Negative Binomial distribution. All methods assume a |
||
| 25 |
- #' associated confidence interval.+ #' logarithmic link function. |
||
| 27 |
- #' @keywords internal+ #' At this point, rates and confidence intervals are estimated from the model using |
||
| 28 |
- h_incidence_rate <- function(person_years,+ #' either [emmeans::emmeans()] when `rate_mean_method = "emmeans"` or [h_ppmeans()] |
||
| 29 |
- n_events,+ #' when `rate_mean_method = "ppmeans"`. |
||
| 30 |
- control = control_incidence_rate()) {
+ #' |
||
| 31 | -18x | +
- alpha <- 1 - control$conf_level+ #' If a reference group is specified while building the table with `split_cols_by(ref_group)`, |
|
| 32 | -18x | +
- est <- switch(control$conf_type,+ #' no rate ratio or `p-value` are calculated. Otherwise, we use [emmeans::contrast()] to |
|
| 33 | -18x | +
- normal = h_incidence_rate_normal(person_years, n_events, alpha),+ #' calculate the rate ratio and `p-value` for the reference group. Values are always estimated |
|
| 34 | -18x | +
- normal_log = h_incidence_rate_normal_log(person_years, n_events, alpha),+ #' with `method = "trt.vs.ctrl"` and `ref` equal to the first `arm` value. |
|
| 35 | -18x | +
- exact = h_incidence_rate_exact(person_years, n_events, alpha),+ #' |
|
| 36 | -18x | +
- byar = h_incidence_rate_byar(person_years, n_events, alpha)+ #' @name summarize_glm_count |
|
| 37 |
- )+ NULL |
||
| 39 | -18x | +
- num_pt_year <- control$num_pt_year+ #' @describeIn summarize_glm_count Layout-creating function which can take statistics function arguments |
|
| 40 | -18x | +
- list(+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|
| 41 | -18x | +
- rate = est$rate * num_pt_year,+ #' |
|
| 42 | -18x | +
- rate_ci = est$rate_ci * num_pt_year+ #' @return |
|
| 43 |
- )+ #' * `summarize_glm_count()` returns a layout object suitable for passing to further layouting functions, |
||
| 44 |
- }+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 45 |
-
+ #' the statistics from `s_glm_count()` to the table layout. |
||
| 46 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ #' |
||
| 47 |
- #' associated confidence interval based on the normal approximation for the+ #' @examples |
||
| 48 |
- #' incidence rate. Unit is one person-year.+ #' library(dplyr) |
||
| 50 |
- #' @examples+ #' anl <- tern_ex_adtte %>% filter(PARAMCD == "TNE") |
||
| 51 |
- #' h_incidence_rate_normal(200, 2)+ #' anl$AVAL_f <- as.factor(anl$AVAL) |
||
| 53 |
- #' @export+ #' lyt <- basic_table() %>% |
||
| 54 |
- h_incidence_rate_normal <- function(person_years,+ #' split_cols_by("ARM", ref_group = "B: Placebo") %>%
|
||
| 55 |
- n_events,+ #' add_colcounts() %>% |
||
| 56 |
- alpha = 0.05) {
+ #' analyze_vars( |
||
| 57 | -14x | +
- checkmate::assert_number(person_years)+ #' "AVAL_f", |
|
| 58 | -14x | +
- checkmate::assert_number(n_events)+ #' var_labels = "Number of exacerbations per patient", |
|
| 59 | -14x | +
- assert_proportion_value(alpha)+ #' .stats = c("count_fraction"),
|
|
| 60 |
-
+ #' .formats = c("count_fraction" = "xx (xx.xx%)"),
|
||
| 61 | -14x | +
- est <- n_events / person_years+ #' .labels = c("Number of exacerbations per patient")
|
|
| 62 | -14x | +
- se <- sqrt(est / person_years)+ #' ) %>% |
|
| 63 | -14x | +
- ci <- est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * se+ #' summarize_glm_count( |
|
| 64 |
-
+ #' vars = "AVAL", |
||
| 65 | -14x | +
- list(rate = est, rate_ci = ci)+ #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = NULL), |
|
| 66 |
- }+ #' conf_level = 0.95, |
||
| 67 |
-
+ #' distribution = "poisson", |
||
| 68 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ #' rate_mean_method = "emmeans", |
||
| 69 |
- #' associated confidence interval based on the normal approximation for the+ #' var_labels = "Adjusted (P) exacerbation rate (per year)", |
||
| 70 |
- #' logarithm of the incidence rate. Unit is one person-year.+ #' table_names = "adjP", |
||
| 71 |
- #'+ #' .stats = c("rate"),
|
||
| 72 |
- #' @examples+ #' .labels = c(rate = "Rate") |
||
| 73 |
- #' h_incidence_rate_normal_log(200, 2)+ #' ) %>% |
||
| 74 |
- #'+ #' summarize_glm_count( |
||
| 75 |
- #' @export+ #' vars = "AVAL", |
||
| 76 |
- h_incidence_rate_normal_log <- function(person_years,+ #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = c("REGION1")),
|
||
| 77 |
- n_events,+ #' conf_level = 0.95, |
||
| 78 |
- alpha = 0.05) {
+ #' distribution = "quasipoisson", |
||
| 79 | -6x | +
- checkmate::assert_number(person_years)+ #' rate_mean_method = "ppmeans", |
|
| 80 | -6x | +
- checkmate::assert_number(n_events)+ #' var_labels = "Adjusted (QP) exacerbation rate (per year)", |
|
| 81 | -6x | +
- assert_proportion_value(alpha)+ #' table_names = "adjQP", |
|
| 82 |
-
+ #' .stats = c("rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
|
||
| 83 | -6x | +
- rate_est <- n_events / person_years+ #' .labels = c( |
|
| 84 | -6x | +
- rate_se <- sqrt(rate_est / person_years)+ #' rate = "Rate", rate_ci = "Rate CI", rate_ratio = "Rate Ratio", |
|
| 85 | -6x | +
- lrate_est <- log(rate_est)+ #' rate_ratio_ci = "Rate Ratio CI", pval = "p value" |
|
| 86 | -6x | +
- lrate_se <- rate_se / rate_est+ #' ) |
|
| 87 | -6x | +
- ci <- exp(lrate_est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * lrate_se)+ #' ) %>% |
|
| 88 |
-
+ #' summarize_glm_count( |
||
| 89 | -6x | +
- list(rate = rate_est, rate_ci = ci)+ #' vars = "AVAL", |
|
| 90 |
- }+ #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = c("REGION1")),
|
||
| 91 |
-
+ #' conf_level = 0.95, |
||
| 92 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ #' distribution = "negbin", |
||
| 93 |
- #' associated exact confidence interval. Unit is one person-year.+ #' rate_mean_method = "emmeans", |
||
| 94 |
- #'+ #' var_labels = "Adjusted (NB) exacerbation rate (per year)", |
||
| 95 |
- #' @examples+ #' table_names = "adjNB", |
||
| 96 |
- #' h_incidence_rate_exact(200, 2)+ #' .stats = c("rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
|
||
| 97 |
- #'+ #' .labels = c( |
||
| 98 |
- #' @export+ #' rate = "Rate", rate_ci = "Rate CI", rate_ratio = "Rate Ratio", |
||
| 99 |
- h_incidence_rate_exact <- function(person_years,+ #' rate_ratio_ci = "Rate Ratio CI", pval = "p value" |
||
| 100 |
- n_events,+ #' ) |
||
| 101 |
- alpha = 0.05) {
+ #' ) |
||
| 102 | -1x | +
- checkmate::assert_number(person_years)+ #' |
|
| 103 | -1x | +
- checkmate::assert_number(n_events)+ #' build_table(lyt = lyt, df = anl) |
|
| 104 | -1x | +
- assert_proportion_value(alpha)+ #' |
|
| 105 |
-
+ #' @export |
||
| 106 | -1x | +
- est <- n_events / person_years+ summarize_glm_count <- function(lyt, |
|
| 107 | -1x | +
- lcl <- stats::qchisq(p = (alpha) / 2, df = 2 * n_events) / (2 * person_years)+ vars, |
|
| 108 | -1x | +
- ucl <- stats::qchisq(p = 1 - (alpha) / 2, df = 2 * n_events + 2) / (2 * person_years)+ variables, |
|
| 109 |
-
+ distribution, |
||
| 110 | -1x | +
- list(rate = est, rate_ci = c(lcl, ucl))+ conf_level, |
|
| 111 |
- }+ rate_mean_method = c("emmeans", "ppmeans")[1],
|
||
| 112 |
-
+ weights = stats::weights, |
||
| 113 |
- #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ scale = 1, |
||
| 114 |
- #' associated Byar's confidence interval. Unit is one person-year.+ var_labels, |
||
| 115 |
- #'+ na_str = default_na_str(), |
||
| 116 |
- #' @examples+ nested = TRUE, |
||
| 117 |
- #' h_incidence_rate_byar(200, 2)+ ..., |
||
| 118 |
- #'+ show_labels = "visible", |
||
| 119 |
- #' @export+ table_names = vars, |
||
| 120 |
- h_incidence_rate_byar <- function(person_years,+ .stats = get_stats("summarize_glm_count"),
|
||
| 121 |
- n_events,+ .formats = NULL, |
||
| 122 |
- alpha = 0.05) {
+ .labels = NULL, |
||
| 123 | -1x | +
- checkmate::assert_number(person_years)+ .indent_mods = c( |
|
| 124 | -1x | +
- checkmate::assert_number(n_events)+ "n" = 0L, |
|
| 125 | -1x | +
- assert_proportion_value(alpha)+ "rate" = 0L, |
|
| 126 |
-
+ "rate_ci" = 1L, |
||
| 127 | -1x | +
- est <- n_events / person_years+ "rate_ratio" = 0L, |
|
| 128 | -1x | +
- seg_1 <- n_events + 0.5+ "rate_ratio_ci" = 1L, |
|
| 129 | -1x | +
- seg_2 <- 1 - 1 / (9 * (n_events + 0.5))+ "pval" = 1L |
|
| 130 | -1x | +
- seg_3 <- stats::qnorm(1 - alpha / 2) * sqrt(1 / (n_events + 0.5)) / 3+ )) {
|
|
| 131 | -1x | +3x |
- lcl <- seg_1 * ((seg_2 - seg_3)^3) / person_years+ checkmate::assert_choice(rate_mean_method, c("emmeans", "ppmeans"))
|
| 132 | -1x | +
- ucl <- seg_1 * ((seg_2 + seg_3)^3) / person_years+ |
|
| 133 | -+ | 3x |
-
+ extra_args <- list( |
| 134 | -1x | +3x |
- list(rate = est, rate_ci = c(lcl, ucl))+ variables = variables, distribution = distribution, conf_level = conf_level, |
| 135 | -+ | 3x |
- }+ rate_mean_method = rate_mean_method, weights = weights, scale = scale, ... |
| 1 | +136 |
- #' Survival time analysis+ ) |
||
| 2 | +137 |
- #'+ |
||
| 3 | +138 |
- #' @description `r lifecycle::badge("stable")`
+ # Selecting parameters following the statistics |
||
| 4 | -+ | |||
| 139 | +3x |
- #'+ .formats <- get_formats_from_stats(.stats, formats_in = .formats) |
||
| 5 | -+ | |||
| 140 | +3x |
- #' The analyze function [surv_time()] creates a layout element to analyze survival time by calculating survival time+ .labels <- get_labels_from_stats(.stats, labels_in = .labels) |
||
| 6 | -+ | |||
| 141 | +3x |
- #' median, median confidence interval, quantiles, and range (for all, censored, or event patients). The primary+ .indent_mods <- get_indents_from_stats(.stats, indents_in = .indent_mods) |
||
| 7 | +142 |
- #' analysis variable `vars` is the time variable and the secondary analysis variable `is_event` indicates whether or+ |
||
| 8 | -+ | |||
| 143 | +3x |
- #' not an event has occurred.+ afun <- make_afun( |
||
| 9 | -+ | |||
| 144 | +3x |
- #'+ s_glm_count, |
||
| 10 | -+ | |||
| 145 | +3x |
- #' @inheritParams argument_convention+ .stats = .stats, |
||
| 11 | -+ | |||
| 146 | +3x |
- #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function+ .formats = .formats, |
||
| 12 | -+ | |||
| 147 | +3x |
- #' [control_surv_time()]. Some possible parameter options are:+ .labels = .labels, |
||
| 13 | -+ | |||
| 148 | +3x |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival time.+ .indent_mods = .indent_mods, |
||
| 14 | -+ | |||
| 149 | +3x |
- #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", or "log-log",+ .null_ref_cells = FALSE |
||
| 15 | +150 |
- #' see more in [survival::survfit()]. Note option "none" is not supported.+ ) |
||
| 16 | +151 |
- #' * `quantiles` (`numeric`)\cr vector of length two to specify the quantiles of survival time.+ |
||
| 17 | -+ | |||
| 152 | +3x |
- #' @param ref_fn_censor (`flag`)\cr whether referential footnotes indicating censored observations should be printed+ analyze( |
||
| 18 | -+ | |||
| 153 | +3x |
- #' when the `range` statistic is included.+ lyt, |
||
| 19 | -+ | |||
| 154 | +3x |
- #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector+ vars,+ |
+ ||
| 155 | +3x | +
+ var_labels = var_labels,+ |
+ ||
| 156 | +3x | +
+ show_labels = show_labels,+ |
+ ||
| 157 | +3x | +
+ table_names = table_names,+ |
+ ||
| 158 | +3x | +
+ afun = afun,+ |
+ ||
| 159 | +3x | +
+ na_str = na_str,+ |
+ ||
| 160 | +3x | +
+ nested = nested,+ |
+ ||
| 161 | +3x | +
+ extra_args = extra_args |
||
| 20 | +162 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ ) |
||
| 21 | +163 |
- #' for that statistic's row label.+ } |
||
| 22 | +164 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ |
||
| 23 | +165 |
- #'+ #' @describeIn summarize_glm_count Statistics function that produces a named list of results |
||
| 24 | +166 |
- #' Options are: ``r shQuote(get_stats("surv_time"))``
+ #' of the investigated Poisson model. |
||
| 25 | +167 |
#' |
||
| 26 | +168 |
- #' @examples+ #' @return |
||
| 27 | +169 |
- #' library(dplyr)+ #' * `s_glm_count()` returns a named `list` of 5 statistics: |
||
| 28 | +170 |
- #'+ #' * `n`: Count of complete sample size for the group. |
||
| 29 | +171 |
- #' adtte_f <- tern_ex_adtte %>%+ #' * `rate`: Estimated event rate per follow-up time. |
||
| 30 | +172 |
- #' filter(PARAMCD == "OS") %>%+ #' * `rate_ci`: Confidence level for estimated rate per follow-up time. |
||
| 31 | +173 |
- #' mutate(+ #' * `rate_ratio`: Ratio of event rates in each treatment arm to the reference arm. |
||
| 32 | +174 |
- #' AVAL = day2month(AVAL),+ #' * `rate_ratio_ci`: Confidence level for the rate ratio. |
||
| 33 | +175 |
- #' is_event = CNSR == 0+ #' * `pval`: p-value. |
||
| 34 | +176 |
- #' )+ #' |
||
| 35 | +177 |
- #' df <- adtte_f %>% filter(ARMCD == "ARM A")+ #' @keywords internal |
||
| 36 | +178 |
- #'+ s_glm_count <- function(df, |
||
| 37 | +179 |
- #' @name survival_time+ .var, |
||
| 38 | +180 |
- #' @order 1+ .df_row, |
||
| 39 | +181 |
- NULL+ variables, |
||
| 40 | +182 |
-
+ .ref_group, |
||
| 41 | +183 |
- #' @describeIn survival_time Statistics function which analyzes survival times.+ .in_ref_col, |
||
| 42 | +184 |
- #'+ distribution, |
||
| 43 | +185 |
- #' @return+ conf_level, |
||
| 44 | +186 |
- #' * `s_surv_time()` returns the statistics:+ rate_mean_method, |
||
| 45 | +187 |
- #' * `median`: Median survival time.+ weights, |
||
| 46 | +188 |
- #' * `median_ci`: Confidence interval for median time.+ scale = 1) {
+ |
+ ||
| 189 | +14x | +
+ arm <- variables$arm |
||
| 47 | +190 |
- #' * `median_ci_3d`: Median with confidence interval for median time.+ + |
+ ||
| 191 | +14x | +
+ y <- df[[.var]]+ |
+ ||
| 192 | +13x | +
+ smry_level <- as.character(unique(df[[arm]])) |
||
| 48 | +193 |
- #' * `quantiles`: Survival time for two specified quantiles.+ |
||
| 49 | +194 |
- #' * `quantiles_lower`: quantile with confidence interval for the first specified quantile.+ # ensure there is only 1 value |
||
| 50 | -+ | |||
| 195 | +13x |
- #' * `quantiles_upper`: quantile with confidence interval for the second specified quantile.+ checkmate::assert_scalar(smry_level) |
||
| 51 | +196 |
- #' * `range_censor`: Survival time range for censored observations.+ |
||
| 52 | -+ | |||
| 197 | +13x |
- #' * `range_event`: Survival time range for observations with events.+ results <- h_glm_count( |
||
| 53 | -+ | |||
| 198 | +13x |
- #' * `range`: Survival time range for all observations.+ .var = .var, |
||
| 54 | -+ | |||
| 199 | +13x |
- #'+ .df_row = .df_row, |
||
| 55 | -+ | |||
| 200 | +13x |
- #' @keywords internal+ variables = variables, |
||
| 56 | -+ | |||
| 201 | +13x |
- s_surv_time <- function(df,+ distribution = distribution, |
||
| 57 | -+ | |||
| 202 | +13x |
- .var,+ weights |
||
| 58 | +203 |
- is_event,+ ) |
||
| 59 | +204 |
- control = control_surv_time()) {
+
|
||
| 60 | -232x | +205 | +13x |
- checkmate::assert_string(.var)+ if (rate_mean_method == "emmeans") {
|
| 61 | -232x | +206 | +13x |
- assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ emmeans_smry <- summary(results$emmeans_fit, level = conf_level) |
| 62 | -232x | +|||
| 207 | +! |
- checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE)+ } else if (rate_mean_method == "ppmeans") {
|
||
| 63 | -232x | +|||
| 208 | +! |
- checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)+ emmeans_smry <- h_ppmeans(results$glm_fit, .df_row, arm, conf_level) |
||
| 64 | +209 |
-
+ } |
||
| 65 | -232x | +|||
| 210 | +
- conf_type <- control$conf_type+ |
|||
| 66 | -232x | +211 | +13x |
- conf_level <- control$conf_level+ emmeans_smry_level <- emmeans_smry[emmeans_smry[[arm]] == smry_level, ] |
| 67 | -232x | +|||
| 212 | +
- quantiles <- control$quantiles+ |
|||
| 68 | +213 |
-
+ # This happens if there is a reference col. No Ratio is calculated? |
||
| 69 | -232x | +214 | +13x |
- formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
+ if (.in_ref_col) {
|
| 70 | -232x | +215 | +5x |
- srv_fit <- survival::survfit(+ list( |
| 71 | -232x | +216 | +5x |
- formula = formula,+ n = length(y[!is.na(y)]), |
| 72 | -232x | +217 | +5x |
- data = df,+ rate = formatters::with_label( |
| 73 | -232x | +218 | +5x |
- conf.int = conf_level,+ ifelse(distribution == "negbin", emmeans_smry_level$response * scale, emmeans_smry_level$rate * scale), |
| 74 | -232x | +219 | +5x |
- conf.type = conf_type+ "Adjusted Rate" |
| 75 | +220 |
- )+ ), |
||
| 76 | -232x | +221 | +5x |
- srv_tab <- summary(srv_fit, extend = TRUE)$table+ rate_ci = formatters::with_label( |
| 77 | -232x | +222 | +5x |
- srv_qt_tab_pre <- stats::quantile(srv_fit, probs = quantiles)+ c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale), |
| 78 | -232x | +223 | +5x |
- srv_qt_tab <- srv_qt_tab_pre$quantile+ f_conf_level(conf_level) |
| 79 | -232x | +|||
| 224 | +
- range_censor <- range_noinf(df[[.var]][!df[[is_event]]], na.rm = TRUE)+ ), |
|||
| 80 | -232x | +225 | +5x |
- range_event <- range_noinf(df[[.var]][df[[is_event]]], na.rm = TRUE)+ rate_ratio = formatters::with_label(character(), "Adjusted Rate Ratio"), |
| 81 | -232x | -
- range <- range_noinf(df[[.var]], na.rm = TRUE)- |
- ||
| 82 | -+ | 226 | +5x |
-
+ rate_ratio_ci = formatters::with_label(character(), f_conf_level(conf_level)), |
| 83 | -232x | +227 | +5x |
- names(quantiles) <- as.character(100 * quantiles)+ pval = formatters::with_label(character(), "p-value") |
| 84 | -232x | +|||
| 228 | +
- srv_qt_tab_pre <- unlist(srv_qt_tab_pre)+ ) |
|||
| 85 | -232x | +|||
| 229 | +
- srv_qt_ci <- lapply(quantiles, function(x) {
+ } else {
|
|||
| 86 | -464x | +230 | +8x |
- name <- as.character(100 * x)+ emmeans_contrasts <- emmeans::contrast( |
| 87 | -+ | |||
| 231 | +8x |
-
+ results$emmeans_fit, |
||
| 88 | -464x | +232 | +8x |
- c(+ method = "trt.vs.ctrl", |
| 89 | -464x | +233 | +8x |
- srv_qt_tab_pre[[paste0("quantile.", name)]],
+ ref = grep( |
| 90 | -464x | +234 | +8x |
- srv_qt_tab_pre[[paste0("lower.", name)]],
+ as.character(unique(.ref_group[[arm]])), |
| 91 | -464x | +235 | +8x |
- srv_qt_tab_pre[[paste0("upper.", name)]]
+ as.data.frame(results$emmeans_fit)[[arm]] |
| 92 | +236 |
- )+ ) |
||
| 93 | +237 |
- })+ ) |
||
| 94 | +238 | |||
| 95 | -232x | +239 | +8x |
- list(+ contrasts_smry <- summary( |
| 96 | -232x | +240 | +8x |
- median = formatters::with_label(unname(srv_tab["median"]), "Median"),+ emmeans_contrasts, |
| 97 | -232x | +241 | +8x |
- median_ci = formatters::with_label(+ infer = TRUE, |
| 98 | -232x | +242 | +8x |
- unname(srv_tab[paste0(srv_fit$conf.int, c("LCL", "UCL"))]), f_conf_level(conf_level)
+ adjust = "none" |
| 99 | +243 |
- ),+ ) |
||
| 100 | -232x | +|||
| 244 | +
- quantiles = formatters::with_label(+ |
|||
| 101 | -232x | +245 | +8x |
- unname(srv_qt_tab), paste0(quantiles[1] * 100, "% and ", quantiles[2] * 100, "%-ile")+ smry_contrasts_level <- contrasts_smry[grepl(smry_level, contrasts_smry$contrast), ] |
| 102 | +246 |
- ),- |
- ||
| 103 | -232x | -
- range_censor = formatters::with_label(range_censor, "Range (censored)"),+ |
||
| 104 | -232x | +247 | +8x |
- range_event = formatters::with_label(range_event, "Range (event)"),+ list( |
| 105 | -232x | +248 | +8x |
- range = formatters::with_label(range, "Range"),+ n = length(y[!is.na(y)]), |
| 106 | -232x | +249 | +8x |
- median_ci_3d = formatters::with_label(+ rate = formatters::with_label( |
| 107 | -232x | +250 | +8x |
- c(+ ifelse(distribution == "negbin", |
| 108 | -232x | +251 | +8x |
- unname(srv_tab["median"]),+ emmeans_smry_level$response * scale, |
| 109 | -232x | +252 | +8x |
- unname(srv_tab[paste0(srv_fit$conf.int, c("LCL", "UCL"))])
+ emmeans_smry_level$rate * scale |
| 110 | +253 |
- ),+ ), |
||
| 111 | -232x | +254 | +8x |
- paste0("Median (", f_conf_level(conf_level), ")")
+ "Adjusted Rate" |
| 112 | +255 |
- ),+ ), |
||
| 113 | -232x | +256 | +8x |
- quantiles_lower = formatters::with_label(+ rate_ci = formatters::with_label( |
| 114 | -232x | +257 | +8x |
- unname(srv_qt_ci[[1]]), paste0(quantiles[1] * 100, "%-ile (", f_conf_level(conf_level), ")")
+ c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale),+ |
+
| 258 | +8x | +
+ f_conf_level(conf_level) |
||
| 115 | +259 |
- ),+ ), |
||
| 116 | -232x | +260 | +8x |
- quantiles_upper = formatters::with_label(+ rate_ratio = formatters::with_label( |
| 117 | -232x | +261 | +8x |
- unname(srv_qt_ci[[2]]), paste0(quantiles[2] * 100, "%-ile (", f_conf_level(conf_level), ")")
+ smry_contrasts_level$ratio, |
| 118 | -+ | |||
| 262 | +8x |
- )+ "Adjusted Rate Ratio" |
||
| 119 | +263 |
- )+ ), |
||
| 120 | -+ | |||
| 264 | +8x |
- }+ rate_ratio_ci = formatters::with_label( |
||
| 121 | -+ | |||
| 265 | +8x |
-
+ c(smry_contrasts_level$asymp.LCL, smry_contrasts_level$asymp.UCL), |
||
| 122 | -+ | |||
| 266 | +8x |
- #' @describeIn survival_time Formatted analysis function which is used as `afun` in `surv_time()`.+ f_conf_level(conf_level) |
||
| 123 | +267 |
- #'+ ), |
||
| 124 | -+ | |||
| 268 | +8x |
- #' @return+ pval = formatters::with_label( |
||
| 125 | -+ | |||
| 269 | +8x |
- #' * `a_surv_time()` returns the corresponding list with formatted [rtables::CellValue()].+ smry_contrasts_level$p.value, |
||
| 126 | -+ | |||
| 270 | +8x |
- #'+ "p-value" |
||
| 127 | +271 |
- #' @examples+ ) |
||
| 128 | +272 |
- #' a_surv_time(+ ) |
||
| 129 | +273 |
- #' df,+ } |
||
| 130 | +274 |
- #' .df_row = df,+ } |
||
| 131 | +275 |
- #' .var = "AVAL",+ # h_glm_count ------------------------------------------------------------------ |
||
| 132 | +276 |
- #' is_event = "is_event"+ #' Helper functions for Poisson models |
||
| 133 | +277 |
- #' )+ #' |
||
| 134 | +278 |
- #'+ #' @description `r lifecycle::badge("experimental")`
|
||
| 135 | +279 |
- #' @export+ #' |
||
| 136 | +280 |
- a_surv_time <- function(df,+ #' Helper functions that returns the results of [stats::glm()] when Poisson or Quasi-Poisson |
||
| 137 | +281 |
- labelstr = "",+ #' distributions are needed (see `family` parameter), or [MASS::glm.nb()] for Negative Binomial |
||
| 138 | +282 |
- .var = NULL,+ #' distributions. Link function for the GLM is `log`. |
||
| 139 | +283 |
- .df_row = NULL,+ #' |
||
| 140 | +284 |
- is_event,+ #' @inheritParams argument_convention |
||
| 141 | +285 |
- control = control_surv_time(),+ #' |
||
| 142 | +286 |
- ref_fn_censor = TRUE,+ #' @seealso [summarize_glm_count] |
||
| 143 | +287 |
- .stats = NULL,+ #' |
||
| 144 | +288 |
- .formats = NULL,+ #' @name h_glm_count |
||
| 145 | +289 |
- .labels = NULL,+ NULL |
||
| 146 | +290 |
- .indent_mods = NULL,+ |
||
| 147 | +291 |
- na_str = default_na_str()) {
- |
- ||
| 148 | -14x | -
- x_stats <- s_surv_time(- |
- ||
| 149 | -14x | -
- df = df, .var = .var, is_event = is_event, control = control+ #' @describeIn h_glm_count Helper function to return the results of the |
||
| 150 | +292 |
- )- |
- ||
| 151 | -14x | -
- rng_censor_lwr <- x_stats[["range_censor"]][1]- |
- ||
| 152 | -14x | -
- rng_censor_upr <- x_stats[["range_censor"]][2]+ #' selected model (Poisson, Quasi-Poisson, negative binomial). |
||
| 153 | +293 |
-
+ #' |
||
| 154 | +294 |
- # Use method-specific defaults- |
- ||
| 155 | -14x | -
- fmts <- c(- |
- ||
| 156 | -14x | -
- median_ci = "(xx.x, xx.x)", quantiles = "xx.x, xx.x", range = "xx.x to xx.x",- |
- ||
| 157 | -14x | -
- median_ci_3d = "xx.x (xx.x - xx.x)",- |
- ||
| 158 | -14x | -
- quantiles_lower = "xx.x (xx.x - xx.x)", quantiles_upper = "xx.x (xx.x - xx.x)"+ #' @param .df_row (`data.frame`)\cr dataset that includes all the variables that are called |
||
| 159 | +295 |
- )- |
- ||
| 160 | -14x | -
- lbls <- c(- |
- ||
| 161 | -14x | -
- median_ci = "95% CI", range = "Range", range_censor = "Range (censored)", range_event = "Range (event)",- |
- ||
| 162 | -14x | -
- median_ci_3d = "Median (95% CI)",- |
- ||
| 163 | -14x | -
- quantiles_lower = "25%-ile (95% CI)",- |
- ||
| 164 | -14x | -
- quantiles_upper = "75%-ile (95% CI)"+ #' in `.var` and `variables`. |
||
| 165 | +296 |
- )- |
- ||
| 166 | -14x | -
- lbls_custom <- .labels- |
- ||
| 167 | -14x | -
- .formats <- c(.formats, fmts[setdiff(names(fmts), names(.formats))])- |
- ||
| 168 | -14x | -
- .labels <- c(.labels, lbls[setdiff(names(lbls), names(lbls_custom))])+ #' @param variables (named `list` of `string`)\cr list of additional analysis variables, with |
||
| 169 | +297 |
-
+ #' expected elements: |
||
| 170 | +298 |
- # Fill in with formatting defaults if needed- |
- ||
| 171 | -14x | -
- .stats <- get_stats("surv_time", stats_in = .stats)
- |
- ||
| 172 | -14x | -
- .formats <- get_formats_from_stats(.stats, .formats)- |
- ||
| 173 | -14x | -
- .labels <- get_labels_from_stats(.stats, .labels) %>% labels_use_control(control, lbls_custom)+ #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple |
||
| 174 | -14x | +|||
| 299 | +
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods)+ #' groups will be summarized. Specifically, the first level of `arm` variable is taken as the |
|||
| 175 | +300 |
-
+ #' reference group. |
||
| 176 | -14x | +|||
| 301 | +
- x_stats <- x_stats[.stats]+ #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as |
|||
| 177 | +302 |
-
+ #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`. |
||
| 178 | +303 |
- # Auto format handling+ #' * `offset` (`numeric`)\cr a numeric vector or scalar adding an offset. |
||
| 179 | -14x | +|||
| 304 | +
- .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)+ #' @param distribution (`character`)\cr a character value specifying the distribution |
|||
| 180 | +305 |
-
+ #' used in the regression (Poisson, Quasi-Poisson, negative binomial). |
||
| 181 | -14x | +|||
| 306 | +
- cell_fns <- setNames(vector("list", length = length(x_stats)), .labels)
+ #' @param weights (`character`)\cr a character vector specifying weights used |
|||
| 182 | -14x | +|||
| 307 | +
- if ("range" %in% names(x_stats) && ref_fn_censor) {
+ #' in averaging predictions. Number of weights must equal the number of levels included in the covariates. |
|||
| 183 | -14x | +|||
| 308 | +
- if (identical(x_stats[["range"]][1], rng_censor_lwr) && identical(x_stats[["range"]][2], rng_censor_upr)) {
+ #' Weights option passed to [emmeans::emmeans()]. |
|||
| 184 | -2x | +|||
| 309 | +
- cell_fns[[.labels[["range"]]]] <- "Censored observations: range minimum & maximum"+ #' |
|||
| 185 | -12x | +|||
| 310 | +
- } else if (identical(x_stats[["range"]][1], rng_censor_lwr)) {
+ #' @return |
|||
| 186 | -2x | +|||
| 311 | +
- cell_fns[[.labels[["range"]]]] <- "Censored observation: range minimum"+ #' * `h_glm_count()` returns the results of the selected model. |
|||
| 187 | -10x | +|||
| 312 | +
- } else if (identical(x_stats[["range"]][2], rng_censor_upr)) {
+ #' |
|||
| 188 | -1x | +|||
| 313 | +
- cell_fns[[.labels[["range"]]]] <- "Censored observation: range maximum"+ #' @keywords internal |
|||
| 189 | +314 |
- }+ h_glm_count <- function(.var, |
||
| 190 | +315 |
- }+ .df_row, |
||
| 191 | +316 |
-
+ variables, |
||
| 192 | -14x | +|||
| 317 | +
- in_rows(+ distribution, |
|||
| 193 | -14x | +|||
| 318 | +
- .list = x_stats,+ weights) {
|
|||
| 194 | -14x | +319 | +21x |
- .formats = .formats,+ checkmate::assert_subset(distribution, c("poisson", "quasipoisson", "negbin"), empty.ok = FALSE)
|
| 195 | -14x | +320 | +19x |
- .names = .labels,+ switch(distribution, |
| 196 | -14x | +321 | +13x |
- .labels = .labels,+ poisson = h_glm_poisson(.var, .df_row, variables, weights), |
| 197 | -14x | +322 | +1x |
- .indent_mods = .indent_mods,+ quasipoisson = h_glm_quasipoisson(.var, .df_row, variables, weights), |
| 198 | -14x | +323 | +5x |
- .cell_footnotes = cell_fns+ negbin = h_glm_negbin(.var, .df_row, variables, weights) |
| 199 | +324 |
) |
||
| 200 | +325 |
} |
||
| 201 | +326 | |||
| 202 | -- |
- #' @describeIn survival_time Layout-creating function which can take statistics function arguments- |
- ||
| 203 | +327 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' @describeIn h_glm_count Helper function to return results of a Poisson model. |
||
| 204 | +328 |
#' |
||
| 205 | +329 |
#' @return |
||
| 206 | -- |
- #' * `surv_time()` returns a layout object suitable for passing to further layouting functions,- |
- ||
| 207 | -- |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing- |
- ||
| 208 | +330 |
- #' the statistics from `s_surv_time()` to the table layout.+ #' * `h_glm_poisson()` returns the results of a Poisson model. |
||
| 209 | +331 |
#' |
||
| 210 | -- |
- #' @examples- |
- ||
| 211 | -- |
- #' basic_table() %>%- |
- ||
| 212 | -- |
- #' split_cols_by(var = "ARMCD") %>%- |
- ||
| 213 | -- |
- #' add_colcounts() %>%- |
- ||
| 214 | +332 |
- #' surv_time(+ #' @keywords internal |
||
| 215 | +333 |
- #' vars = "AVAL",+ h_glm_poisson <- function(.var, |
||
| 216 | +334 |
- #' var_labels = "Survival Time (Months)",+ .df_row, |
||
| 217 | +335 |
- #' is_event = "is_event",+ variables, |
||
| 218 | +336 |
- #' control = control_surv_time(conf_level = 0.9, conf_type = "log-log")+ weights) {
|
||
| 219 | -+ | |||
| 337 | +17x |
- #' ) %>%+ arm <- variables$arm |
||
| 220 | -+ | |||
| 338 | +17x |
- #' build_table(df = adtte_f)+ covariates <- variables$covariates |
||
| 221 | +339 |
- #'+ |
||
| 222 | -+ | |||
| 340 | +17x |
- #' @export+ formula <- stats::as.formula(paste0( |
||
| 223 | -+ | |||
| 341 | +17x |
- #' @order 2+ .var, " ~ ", |
||
| 224 | +342 |
- surv_time <- function(lyt,+ " + ", |
||
| 225 | -+ | |||
| 343 | +17x |
- vars,+ paste(covariates, collapse = " + "), |
||
| 226 | +344 |
- is_event,+ " + ", |
||
| 227 | -+ | |||
| 345 | +17x |
- control = control_surv_time(),+ arm |
||
| 228 | +346 |
- ref_fn_censor = TRUE,+ )) |
||
| 229 | +347 |
- na_str = default_na_str(),+ |
||
| 230 | -+ | |||
| 348 | +17x |
- nested = TRUE,+ if (is.null(variables$offset)) {
|
||
| 231 | -+ | |||
| 349 | +1x |
- ...,+ glm_fit <- stats::glm( |
||
| 232 | -+ | |||
| 350 | +1x |
- var_labels = "Time to Event",+ formula = formula, |
||
| 233 | -+ | |||
| 351 | +1x |
- show_labels = "visible",+ data = .df_row, |
||
| 234 | -+ | |||
| 352 | +1x |
- table_names = vars,+ family = stats::poisson(link = "log") |
||
| 235 | +353 |
- .stats = c("median", "median_ci", "quantiles", "range"),
+ ) |
||
| 236 | +354 |
- .formats = NULL,+ } else {
|
||
| 237 | -+ | |||
| 355 | +16x |
- .labels = NULL,+ offset <- .df_row[[variables$offset]] |
||
| 238 | -+ | |||
| 356 | +14x |
- .indent_mods = c(median_ci = 1L)) {
+ glm_fit <- stats::glm( |
||
| 239 | -3x | +357 | +14x |
- extra_args <- list(+ formula = formula, |
| 240 | -3x | +358 | +14x |
- .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods,+ offset = offset, |
| 241 | -3x | +359 | +14x |
- is_event = is_event, control = control, ref_fn_censor = ref_fn_censor, ...+ data = .df_row,+ |
+
| 360 | +14x | +
+ family = stats::poisson(link = "log") |
||
| 242 | +361 |
- )+ ) |
||
| 243 | +362 | ++ |
+ }+ |
+ |
| 363 | ||||
| 244 | -3x | +364 | +15x |
- analyze(+ emmeans_fit <- emmeans::emmeans( |
| 245 | -3x | +365 | +15x |
- lyt = lyt,+ glm_fit, |
| 246 | -3x | +366 | +15x |
- vars = vars,+ specs = arm, |
| 247 | -3x | +367 | +15x |
- afun = a_surv_time,+ data = .df_row, |
| 248 | -3x | +368 | +15x |
- var_labels = var_labels,+ type = "response", |
| 249 | -3x | +369 | +15x |
- show_labels = show_labels,+ offset = 0, |
| 250 | -3x | +370 | +15x |
- table_names = table_names,+ weights = weights+ |
+
| 371 | ++ |
+ )+ |
+ ||
| 372 | ++ | + | ||
| 251 | -3x | +373 | +15x |
- na_str = na_str,+ list( |
| 252 | -3x | +374 | +15x |
- nested = nested,+ glm_fit = glm_fit, |
| 253 | -3x | +375 | +15x |
- extra_args = extra_args+ emmeans_fit = emmeans_fit |
| 254 | +376 |
) |
||
| 255 | +377 |
} |
| 1 | +378 |
- #' Count patients with marked laboratory abnormalities+ |
||
| 2 | +379 |
- #'+ #' @describeIn h_glm_count Helper function to return results of a Quasi-Poisson model. |
||
| 3 | +380 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 4 | +381 |
- #'+ #' @return |
||
| 5 | +382 |
- #' The analyze function [count_abnormal_by_marked()] creates a layout element to count patients with marked laboratory+ #' * `h_glm_quasipoisson()` returns the results of a Quasi-Poisson model. |
||
| 6 | +383 |
- #' abnormalities for each direction of abnormality, categorized by parameter value.+ #' |
||
| 7 | +384 |
- #'+ #' @keywords internal |
||
| 8 | +385 |
- #' This function analyzes primary analysis variable `var` which indicates whether a single, replicated,+ h_glm_quasipoisson <- function(.var, |
||
| 9 | +386 |
- #' or last marked laboratory abnormality was observed. Levels of `var` to include for each marked lab+ .df_row, |
||
| 10 | +387 |
- #' abnormality (`single` and `last_replicated`) can be supplied via the `category` parameter. Additional+ variables, |
||
| 11 | +388 |
- #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults+ weights) {
|
||
| 12 | -+ | |||
| 389 | +5x |
- #' to `USUBJID`), a variable to indicate unique subject identifiers, `param` (defaults to `PARAM`), a+ arm <- variables$arm |
||
| 13 | -+ | |||
| 390 | +5x |
- #' variable to indicate parameter values, and `direction` (defaults to `abn_dir`), a variable to indicate+ covariates <- variables$covariates |
||
| 14 | +391 |
- #' abnormality directions.+ |
||
| 15 | -+ | |||
| 392 | +5x |
- #'+ formula <- stats::as.formula(paste0( |
||
| 16 | -+ | |||
| 393 | +5x |
- #' For each combination of `param` and `direction` levels, marked lab abnormality counts are calculated+ .var, " ~ ", |
||
| 17 | +394 |
- #' as follows:+ " + ", |
||
| 18 | -+ | |||
| 395 | +5x |
- #' * `Single, not last` & `Last or replicated`: The number of patients with `Single, not last`+ paste(covariates, collapse = " + "), |
||
| 19 | +396 |
- #' and `Last or replicated` values, respectively.+ " + ", |
||
| 20 | -+ | |||
| 397 | +5x |
- #' * `Any`: The number of patients with either single or replicated marked abnormalities.+ arm |
||
| 21 | +398 |
- #'+ )) |
||
| 22 | +399 |
- #' Fractions are calculated by dividing the above counts by the number of patients with at least one+ |
||
| 23 | -+ | |||
| 400 | +5x |
- #' valid measurement recorded during the analysis.+ if (is.null(variables$offset)) {
|
||
| 24 | -+ | |||
| 401 | +! |
- #'+ glm_fit <- stats::glm( |
||
| 25 | -+ | |||
| 402 | +! |
- #' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create two+ formula = formula, |
||
| 26 | -+ | |||
| 403 | +! |
- #' row splits, one on variable `param` and one on variable `direction`.+ data = .df_row, |
||
| 27 | -+ | |||
| 404 | +! |
- #'+ family = stats::quasipoisson(link = "log") |
||
| 28 | +405 |
- #' @inheritParams argument_convention+ ) |
||
| 29 | +406 |
- #' @param category (`list`)\cr a list with different marked category names for single+ } else {
|
||
| 30 | -+ | |||
| 407 | +5x |
- #' and last or replicated.+ offset <- .df_row[[variables$offset]] |
||
| 31 | -+ | |||
| 408 | +3x |
- #' @param .stats (`character`)\cr statistics to select for the table.+ glm_fit <- stats::glm( |
||
| 32 | -+ | |||
| 409 | +3x |
- #'+ formula = formula, |
||
| 33 | -+ | |||
| 410 | +3x |
- #' Options are: ``r shQuote(get_stats("abnormal_by_marked"))``
+ offset = offset, |
||
| 34 | -+ | |||
| 411 | +3x |
- #'+ data = .df_row, |
||
| 35 | -+ | |||
| 412 | +3x |
- #' @note `Single, not last` and `Last or replicated` levels are mutually exclusive. If a patient has+ family = stats::quasipoisson(link = "log") |
||
| 36 | +413 |
- #' abnormalities that meet both the `Single, not last` and `Last or replicated` criteria, then the+ ) |
||
| 37 | +414 |
- #' patient will be counted only under the `Last or replicated` category.+ } |
||
| 38 | -+ | |||
| 415 | +3x |
- #'+ emmeans_fit <- emmeans::emmeans( |
||
| 39 | -+ | |||
| 416 | +3x |
- #' @name abnormal_by_marked+ glm_fit, |
||
| 40 | -+ | |||
| 417 | +3x |
- #' @order 1+ specs = arm,+ |
+ ||
| 418 | +3x | +
+ data = .df_row,+ |
+ ||
| 419 | +3x | +
+ type = "response",+ |
+ ||
| 420 | +3x | +
+ offset = 0,+ |
+ ||
| 421 | +3x | +
+ weights = weights |
||
| 41 | +422 |
- NULL+ ) |
||
| 42 | +423 | |||
| 43 | -+ | |||
| 424 | +3x |
- #' @describeIn abnormal_by_marked Statistics function for patients with marked lab abnormalities.+ list(+ |
+ ||
| 425 | +3x | +
+ glm_fit = glm_fit,+ |
+ ||
| 426 | +3x | +
+ emmeans_fit = emmeans_fit |
||
| 44 | +427 |
- #'+ ) |
||
| 45 | +428 |
- #' @return+ } |
||
| 46 | +429 |
- #' * `s_count_abnormal_by_marked()` returns statistic `count_fraction` with `Single, not last`,+ |
||
| 47 | +430 |
- #' `Last or replicated`, and `Any` results.+ #' @describeIn h_glm_count Helper function to return results of a negative binomial model. |
||
| 48 | +431 |
#' |
||
| 49 | +432 |
- #' @keywords internal+ #' @return |
||
| 50 | +433 |
- s_count_abnormal_by_marked <- function(df,+ #' * `h_glm_negbin()` returns the results of a negative binomial model. |
||
| 51 | +434 |
- .var = "AVALCAT1",+ #' |
||
| 52 | +435 |
- .spl_context,+ #' @keywords internal |
||
| 53 | +436 |
- category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
+ h_glm_negbin <- function(.var, |
||
| 54 | +437 |
- variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir")) {
+ .df_row, |
||
| 55 | -3x | +|||
| 438 | +
- checkmate::assert_string(.var)+ variables, |
|||
| 56 | -3x | +|||
| 439 | +
- checkmate::assert_list(variables)+ weights) {
|
|||
| 57 | -3x | +440 | +9x |
- checkmate::assert_list(category)+ arm <- variables$arm |
| 58 | -3x | +441 | +9x |
- checkmate::assert_subset(names(category), c("single", "last_replicated"))
+ covariates <- variables$covariates |
| 59 | -3x | +442 | +9x |
- checkmate::assert_subset(names(variables), c("id", "param", "direction"))
+ formula <- stats::as.formula(paste0( |
| 60 | -3x | +443 | +9x |
- checkmate::assert_vector(unique(df[[variables$direction]]), max.len = 1)+ .var, " ~ ", |
| 61 | +444 |
-
+ " + ", |
||
| 62 | -2x | +445 | +9x |
- assert_df_with_variables(df, c(aval = .var, variables))+ paste(covariates, collapse = " + "), |
| 63 | -2x | +|||
| 446 | +
- checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
+ " + ", |
|||
| 64 | -2x | +447 | +9x |
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ arm |
| 65 | +448 |
-
+ )) |
||
| 66 | +449 | |||
| 67 | -2x | -
- first_row <- .spl_context[.spl_context$split == variables[["param"]], ]- |
- ||
| 68 | -+ | 450 | +9x |
- # Patients in the denominator have at least one post-baseline visit.+ if (is.null(variables$offset)) {
|
| 69 | -2x | +451 | +1x |
- subj <- first_row$full_parent_df[[1]][[variables[["id"]]]]+ formula <- stats::as.formula(paste0( |
| 70 | -2x | +452 | +1x |
- subj_cur_col <- subj[first_row$cur_col_subset[[1]]]+ .var, " ~ ", |
| 71 | +453 |
- # Some subjects may have a record for high and low directions but+ " + ",+ |
+ ||
| 454 | +1x | +
+ paste(covariates, collapse = " + "), |
||
| 72 | +455 |
- # should be counted only once.+ " + ", |
||
| 73 | -2x | +456 | +1x |
- denom <- length(unique(subj_cur_col))+ arm |
| 74 | +457 |
-
+ )) |
||
| 75 | -2x | +|||
| 458 | +
- if (denom != 0) {
+ } else {
|
|||
| 76 | -2x | +459 | +8x |
- subjects_last_replicated <- unique(+ offset <- variables$offset |
| 77 | -2x | +460 | +8x |
- df[df[[.var]] %in% category[["last_replicated"]], variables$id, drop = TRUE]+ formula_txt <- sprintf( |
| 78 | -+ | |||
| 461 | +8x |
- )+ "%s ~ %s + %s + offset(%s)", |
||
| 79 | -2x | +462 | +8x |
- subjects_single <- unique(+ .var, |
| 80 | -2x | +463 | +8x |
- df[df[[.var]] %in% category[["single"]], variables$id, drop = TRUE]+ arm, paste0(covariates, collapse = " + "), offset |
| 81 | +464 |
) |
||
| 82 | -+ | |||
| 465 | +8x |
- # Subjects who have both single and last/replicated abnormalities are counted in only the last/replicated group.+ formula <- stats::as.formula( |
||
| 83 | -2x | +466 | +8x |
- subjects_single <- setdiff(subjects_single, subjects_last_replicated)+ formula_txt |
| 84 | -2x | +|||
| 467 | +
- n_single <- length(subjects_single)+ ) |
|||
| 85 | -2x | +|||
| 468 | +
- n_last_replicated <- length(subjects_last_replicated)+ } |
|||
| 86 | -2x | +|||
| 469 | +
- n_any <- n_single + n_last_replicated+ |
|||
| 87 | -2x | +470 | +9x |
- result <- list(count_fraction = list(+ glm_fit <- MASS::glm.nb( |
| 88 | -2x | +471 | +9x |
- "Single, not last" = c(n_single, n_single / denom),+ formula = formula, |
| 89 | -2x | +472 | +9x |
- "Last or replicated" = c(n_last_replicated, n_last_replicated / denom),+ data = .df_row, |
| 90 | -2x | +473 | +9x |
- "Any Abnormality" = c(n_any, n_any / denom)+ link = "log" |
| 91 | +474 |
- ))+ ) |
||
| 92 | +475 |
- } else {
- |
- ||
| 93 | -! | -
- result <- list(count_fraction = list(+ |
||
| 94 | -! | +|||
| 476 | +7x |
- "Single, not last" = c(0, 0),+ emmeans_fit <- emmeans::emmeans( |
||
| 95 | -! | +|||
| 477 | +7x |
- "Last or replicated" = c(0, 0),+ glm_fit, |
||
| 96 | -! | +|||
| 478 | +7x |
- "Any Abnormality" = c(0, 0)+ specs = arm, |
||
| 97 | -+ | |||
| 479 | +7x |
- ))+ data = .df_row, |
||
| 98 | -+ | |||
| 480 | +7x |
- }+ type = "response", |
||
| 99 | -+ | |||
| 481 | +7x |
-
+ offset = 0, |
||
| 100 | -2x | +482 | +7x |
- result+ weights = weights |
| 101 | +483 |
- }+ ) |
||
| 102 | +484 | |||
| 103 | -+ | |||
| 485 | +7x |
- #' @describeIn abnormal_by_marked Formatted analysis function which is used as `afun`+ list( |
||
| 104 | -+ | |||
| 486 | +7x |
- #' in `count_abnormal_by_marked()`.+ glm_fit = glm_fit, |
||
| 105 | -+ | |||
| 487 | +7x |
- #'+ emmeans_fit = emmeans_fit |
||
| 106 | +488 |
- #' @return+ ) |
||
| 107 | +489 |
- #' * `a_count_abnormal_by_marked()` returns the corresponding list with formatted [rtables::CellValue()].+ } |
||
| 108 | +490 |
- #'+ |
||
| 109 | +491 |
- #' @keywords internal+ # h_ppmeans -------------------------------------------------------------------- |
||
| 110 | +492 |
- a_count_abnormal_by_marked <- make_afun(+ #' Function to return the estimated means using predicted probabilities |
||
| 111 | +493 |
- s_count_abnormal_by_marked,+ #' |
||
| 112 | +494 |
- .formats = c(count_fraction = format_count_fraction)+ #' @description |
||
| 113 | +495 |
- )+ #' For each arm level, the predicted mean rate is calculated using the fitted model object, with `newdata` |
||
| 114 | +496 |
-
+ #' set to the result of `stats::model.frame`, a reconstructed data or the original data, depending on the |
||
| 115 | +497 |
- #' @describeIn abnormal_by_marked Layout-creating function which can take statistics function arguments+ #' object formula (coming from the fit). The confidence interval is derived using the `conf_level` parameter. |
||
| 116 | +498 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' |
||
| 117 | +499 |
- #'+ #' @param obj (`glm.fit`)\cr fitted model object used to derive the mean rate estimates in each treatment arm. |
||
| 118 | +500 |
- #' @return+ #' @param .df_row (`data.frame`)\cr dataset that includes all the variables that are called in `.var` and `variables`. |
||
| 119 | +501 |
- #' * `count_abnormal_by_marked()` returns a layout object suitable for passing to further layouting functions,+ #' @param arm (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be |
||
| 120 | +502 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' summarized. Specifically, the first level of `arm` variable is taken as the reference group. |
||
| 121 | +503 |
- #' the statistics from `s_count_abnormal_by_marked()` to the table layout.+ #' @param conf_level (`proportion`)\cr value used to derive the confidence interval for the rate. |
||
| 122 | +504 |
#' |
||
| 123 | +505 |
- #' @examples+ #' @return |
||
| 124 | +506 |
- #' library(dplyr)+ #' * `h_ppmeans()` returns the estimated means. |
||
| 125 | +507 |
#' |
||
| 126 | -- |
- #' df <- data.frame(- |
- ||
| 127 | -- |
- #' USUBJID = as.character(c(rep(1, 5), rep(2, 5), rep(1, 5), rep(2, 5))),- |
- ||
| 128 | +508 |
- #' ARMCD = factor(c(rep("ARM A", 5), rep("ARM B", 5), rep("ARM A", 5), rep("ARM B", 5))),
+ #' @seealso [summarize_glm_count()]. |
||
| 129 | +509 |
- #' ANRIND = factor(c(+ #' |
||
| 130 | +510 |
- #' "NORMAL", "HIGH", "HIGH", "HIGH HIGH", "HIGH",+ #' @export |
||
| 131 | +511 |
- #' "HIGH", "HIGH", "HIGH HIGH", "NORMAL", "HIGH HIGH", "NORMAL", "LOW", "LOW", "LOW LOW", "LOW",+ h_ppmeans <- function(obj, .df_row, arm, conf_level) {
|
||
| 132 | -+ | |||
| 512 | +1x |
- #' "LOW", "LOW", "LOW LOW", "NORMAL", "LOW LOW"+ alpha <- 1 - conf_level |
||
| 133 | -+ | |||
| 513 | +1x |
- #' )),+ p <- 1 - alpha / 2 |
||
| 134 | +514 |
- #' ONTRTFL = rep(c("", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y"), 2),
+
|
||
| 135 | -+ | |||
| 515 | +1x |
- #' PARAMCD = factor(c(rep("CRP", 10), rep("ALT", 10))),
+ arm_levels <- levels(.df_row[[arm]]) |
||
| 136 | +516 |
- #' AVALCAT1 = factor(rep(c("", "", "", "SINGLE", "REPLICATED", "", "", "LAST", "", "SINGLE"), 2)),
+
|
||
| 137 | -+ | |||
| 517 | +1x |
- #' stringsAsFactors = FALSE+ out <- lapply(arm_levels, function(lev) {
|
||
| 138 | -+ | |||
| 518 | +3x |
- #' )+ temp <- .df_row |
||
| 139 | -+ | |||
| 519 | +3x |
- #'+ temp[[arm]] <- factor(lev, levels = arm_levels) |
||
| 140 | +520 |
- #' df <- df %>%+ |
||
| 141 | -+ | |||
| 521 | +3x |
- #' mutate(abn_dir = factor(+ mf <- stats::model.frame(obj$formula, data = temp) |
||
| 142 | -+ | |||
| 522 | +3x |
- #' case_when(+ X <- stats::model.matrix(obj$formula, data = mf) # nolint |
||
| 143 | +523 |
- #' ANRIND == "LOW LOW" ~ "Low",+ |
||
| 144 | -+ | |||
| 524 | +3x |
- #' ANRIND == "HIGH HIGH" ~ "High",+ rate <- stats::predict(obj, newdata = mf, type = "response") |
||
| 145 | -+ | |||
| 525 | +3x |
- #' TRUE ~ ""+ rate_hat <- mean(rate) |
||
| 146 | +526 |
- #' ),+ |
||
| 147 | -+ | |||
| 527 | +3x |
- #' levels = c("Low", "High")
+ zz <- colMeans(rate * X) |
||
| 148 | -+ | |||
| 528 | +3x |
- #' ))+ se <- sqrt(as.numeric(t(zz) %*% stats::vcov(obj) %*% zz)) |
||
| 149 | -+ | |||
| 529 | +3x |
- #'+ rate_lwr <- rate_hat * exp(-stats::qnorm(p) * se / rate_hat) |
||
| 150 | -+ | |||
| 530 | +3x |
- #' # Select only post-baseline records.+ rate_upr <- rate_hat * exp(stats::qnorm(p) * se / rate_hat) |
||
| 151 | +531 |
- #' df <- df %>% filter(ONTRTFL == "Y")+ |
||
| 152 | -+ | |||
| 532 | +3x |
- #' df_crp <- df %>%+ c(rate_hat, rate_lwr, rate_upr) |
||
| 153 | +533 |
- #' filter(PARAMCD == "CRP") %>%+ }) |
||
| 154 | +534 |
- #' droplevels()+ |
||
| 155 | -+ | |||
| 535 | +1x |
- #' full_parent_df <- list(df_crp, "not_needed")+ names(out) <- arm_levels |
||
| 156 | -+ | |||
| 536 | +1x |
- #' cur_col_subset <- list(rep(TRUE, nrow(df_crp)), "not_needed")+ out <- do.call(rbind, out) |
||
| 157 | -+ | |||
| 537 | +1x |
- #' spl_context <- data.frame(+ if ("negbin" %in% class(obj)) {
|
||
| 158 | -+ | |||
| 538 | +! |
- #' split = c("PARAMCD", "GRADE_DIR"),
+ colnames(out) <- c("response", "asymp.LCL", "asymp.UCL")
|
||
| 159 | +539 |
- #' full_parent_df = I(full_parent_df),+ } else {
|
||
| 160 | -+ | |||
| 540 | +1x |
- #' cur_col_subset = I(cur_col_subset)+ colnames(out) <- c("rate", "asymp.LCL", "asymp.UCL")
|
||
| 161 | +541 |
- #' )+ } |
||
| 162 | -+ | |||
| 542 | +1x |
- #'+ out <- as.data.frame(out) |
||
| 163 | -+ | |||
| 543 | +1x |
- #' map <- unique(+ out[[arm]] <- rownames(out) |
||
| 164 | -+ | |||
| 544 | +1x |
- #' df[df$abn_dir %in% c("Low", "High") & df$AVALCAT1 != "", c("PARAMCD", "abn_dir")]
+ out |
||
| 165 | +545 |
- #' ) %>%+ } |
| 166 | +1 |
- #' lapply(as.character) %>%+ #' Count patients by most extreme post-baseline toxicity grade per direction of abnormality |
||
| 167 | +2 |
- #' as.data.frame() %>%+ #' |
||
| 168 | +3 |
- #' arrange(PARAMCD, abn_dir)+ #' @description `r lifecycle::badge("stable")`
|
||
| 169 | +4 |
#' |
||
| 170 | +5 |
- #' basic_table() %>%+ #' The analyze function [count_abnormal_by_worst_grade()] creates a layout element to count patients by highest (worst) |
||
| 171 | +6 |
- #' split_cols_by("ARMCD") %>%
+ #' analysis toxicity grade post-baseline for each direction, categorized by parameter value. |
||
| 172 | +7 |
- #' split_rows_by("PARAMCD") %>%
+ #' |
||
| 173 | +8 |
- #' summarize_num_patients(+ #' This function analyzes primary analysis variable `var` which indicates toxicity grades. Additional |
||
| 174 | +9 |
- #' var = "USUBJID",+ #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to |
||
| 175 | +10 |
- #' .stats = "unique_count"+ #' `USUBJID`), a variable to indicate unique subject identifiers, `param` (defaults to `PARAM`), a variable |
||
| 176 | +11 |
- #' ) %>%+ #' to indicate parameter values, and `grade_dir` (defaults to `GRADE_DIR`), a variable to indicate directions |
||
| 177 | +12 |
- #' split_rows_by(+ #' (e.g. High or Low) for each toxicity grade supplied in `var`. |
||
| 178 | +13 |
- #' "abn_dir",+ #' |
||
| 179 | +14 |
- #' split_fun = trim_levels_to_map(map)+ #' For each combination of `param` and `grade_dir` levels, patient counts by worst |
||
| 180 | +15 |
- #' ) %>%+ #' grade are calculated as follows: |
||
| 181 | +16 |
- #' count_abnormal_by_marked(+ #' * `1` to `4`: The number of patients with worst grades 1-4, respectively. |
||
| 182 | +17 |
- #' var = "AVALCAT1",+ #' * `Any`: The number of patients with at least one abnormality (i.e. grade is not 0). |
||
| 183 | +18 |
- #' variables = list(+ #' |
||
| 184 | +19 |
- #' id = "USUBJID",+ #' Fractions are calculated by dividing the above counts by the number of patients with at least one |
||
| 185 | +20 |
- #' param = "PARAMCD",+ #' valid measurement recorded during treatment. |
||
| 186 | +21 |
- #' direction = "abn_dir"+ #' |
||
| 187 | +22 |
- #' )+ #' Pre-processing is crucial when using this function and can be done automatically using the |
||
| 188 | +23 |
- #' ) %>%+ #' [h_adlb_abnormal_by_worst_grade()] helper function. See the description of this function for details on the |
||
| 189 | +24 |
- #' build_table(df = df)+ #' necessary pre-processing steps. |
||
| 190 | +25 |
#' |
||
| 191 | +26 |
- #' basic_table() %>%+ #' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create two row |
||
| 192 | +27 |
- #' split_cols_by("ARMCD") %>%
+ #' splits, one on variable `param` and one on variable `grade_dir`. |
||
| 193 | +28 |
- #' split_rows_by("PARAMCD") %>%
+ #' |
||
| 194 | +29 |
- #' summarize_num_patients(+ #' @inheritParams argument_convention |
||
| 195 | +30 |
- #' var = "USUBJID",+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 196 | +31 |
- #' .stats = "unique_count"+ #' |
||
| 197 | +32 |
- #' ) %>%+ #' Options are: ``r shQuote(get_stats("abnormal_by_worst_grade"), type = "sh")``
|
||
| 198 | +33 |
- #' split_rows_by(+ #' |
||
| 199 | +34 |
- #' "abn_dir",+ #' @seealso [h_adlb_abnormal_by_worst_grade()] which pre-processes ADLB data frames to be used in |
||
| 200 | +35 |
- #' split_fun = trim_levels_in_group("abn_dir")
+ #' [count_abnormal_by_worst_grade()]. |
||
| 201 | +36 |
- #' ) %>%+ #' |
||
| 202 | +37 |
- #' count_abnormal_by_marked(+ #' @name abnormal_by_worst_grade |
||
| 203 | +38 |
- #' var = "AVALCAT1",+ #' @order 1 |
||
| 204 | +39 |
- #' variables = list(+ NULL |
||
| 205 | +40 |
- #' id = "USUBJID",+ |
||
| 206 | +41 |
- #' param = "PARAMCD",+ #' @describeIn abnormal_by_worst_grade Statistics function which counts patients by worst grade. |
||
| 207 | +42 |
- #' direction = "abn_dir"+ #' |
||
| 208 | +43 |
- #' )+ #' @return |
||
| 209 | +44 |
- #' ) %>%+ #' * `s_count_abnormal_by_worst_grade()` returns the single statistic `count_fraction` with grades 1 to 4 and |
||
| 210 | +45 |
- #' build_table(df = df)+ #' "Any" results. |
||
| 211 | +46 |
#' |
||
| 212 | -- |
- #' @export- |
- ||
| 213 | +47 |
- #' @order 2+ #' @keywords internal |
||
| 214 | +48 |
- count_abnormal_by_marked <- function(lyt,+ s_count_abnormal_by_worst_grade <- function(df, # nolint |
||
| 215 | +49 |
- var,+ .var = "GRADE_ANL", |
||
| 216 | +50 |
- category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
+ .spl_context, |
||
| 217 | +51 |
- variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir"),+ variables = list( |
||
| 218 | +52 |
- na_str = default_na_str(),+ id = "USUBJID", |
||
| 219 | +53 |
- nested = TRUE,+ param = "PARAM", |
||
| 220 | +54 |
- ...,+ grade_dir = "GRADE_DIR" |
||
| 221 | +55 |
- .stats = NULL,+ )) {
|
||
| 222 | -+ | |||
| 56 | +1x |
- .formats = NULL,+ checkmate::assert_string(.var) |
||
| 223 | -+ | |||
| 57 | +1x |
- .labels = NULL,+ assert_valid_factor(df[[.var]]) |
||
| 224 | -+ | |||
| 58 | +1x |
- .indent_mods = NULL) {
+ assert_valid_factor(df[[variables$param]]) |
||
| 225 | +59 | 1x |
- checkmate::assert_string(var)+ assert_valid_factor(df[[variables$grade_dir]]) |
|
| 226 | -+ | |||
| 60 | +1x |
-
+ assert_df_with_variables(df, c(a = .var, variables)) |
||
| 227 | +61 | 1x |
- extra_args <- list(category = category, variables = variables, ...)+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
|
| 228 | +62 | |||
| 229 | -1x | +|||
| 63 | +
- afun <- make_afun(+ # To verify that the `split_rows_by` are performed with correct variables. |
|||
| 230 | +64 | 1x |
- a_count_abnormal_by_marked,+ checkmate::assert_subset(c(variables[["param"]], variables[["grade_dir"]]), .spl_context$split) |
|
| 231 | +65 | 1x |
- .stats = .stats,+ first_row <- .spl_context[.spl_context$split == variables[["param"]], ] |
|
| 232 | +66 | 1x |
- .formats = .formats,+ x_lvls <- c(setdiff(levels(df[[.var]]), "0"), "Any") |
|
| 233 | +67 | 1x |
- .labels = .labels,+ result <- split(numeric(0), factor(x_lvls))+ |
+ |
| 68 | ++ | + | ||
| 234 | +69 | 1x |
- .indent_mods = .indent_mods,+ subj <- first_row$full_parent_df[[1]][[variables[["id"]]]] |
|
| 235 | +70 | 1x |
- .ungroup_stats = "count_fraction"+ subj_cur_col <- subj[first_row$cur_col_subset[[1]]] |
|
| 236 | +71 |
- )+ # Some subjects may have a record for high and low directions but |
||
| 237 | +72 |
-
+ # should be counted only once. |
||
| 238 | +73 | 1x |
- lyt <- analyze(+ denom <- length(unique(subj_cur_col))+ |
+ |
| 74 | ++ | + | ||
| 239 | +75 | 1x |
- lyt = lyt,+ for (lvl in x_lvls) {
|
|
| 240 | -1x | +76 | +5x |
- vars = var,+ if (lvl != "Any") {
|
| 241 | -1x | +77 | +4x |
- afun = afun,+ df_lvl <- df[df[[.var]] == lvl, ]+ |
+
| 78 | ++ |
+ } else {
|
||
| 242 | +79 | 1x |
- na_str = na_str,+ df_lvl <- df[df[[.var]] != 0, ]+ |
+ |
| 80 | ++ |
+ } |
||
| 243 | -1x | +81 | +5x |
- nested = nested,+ num <- length(unique(df_lvl[[variables[["id"]]]])) |
| 244 | -1x | +82 | +5x |
- show_labels = "hidden",+ fraction <- ifelse(denom == 0, 0, num / denom) |
| 245 | -1x | +83 | +5x |
- extra_args = extra_args+ result[[lvl]] <- formatters::with_label(c(count = num, fraction = fraction), lvl) |
| 246 | +84 |
- )+ }+ |
+ ||
| 85 | ++ | + | ||
| 247 | +86 | 1x |
- lyt+ result <- list(count_fraction = result)+ |
+ |
| 87 | +1x | +
+ result |
||
| 248 | +88 |
} |
| 1 | +89 |
- # summarize_glm_count ----------------------------------------------------------+ |
||
| 2 | +90 |
- #' Summarize Poisson negative binomial regression+ #' @describeIn abnormal_by_worst_grade Formatted analysis function which is used as `afun` |
||
| 3 | +91 |
- #'+ #' in `count_abnormal_by_worst_grade()`. |
||
| 4 | +92 |
- #' @description `r lifecycle::badge("experimental")`
+ #' |
||
| 5 | +93 |
- #'+ #' @return |
||
| 6 | +94 |
- #' Summarize results of a Poisson negative binomial regression.+ #' * `a_count_abnormal_by_worst_grade()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 7 | +95 |
- #' This can be used to analyze count and/or frequency data using a linear model.+ #' |
||
| 8 | +96 |
- #' It is specifically useful for analyzing count data (using the Poisson or Negative+ #' @keywords internal |
||
| 9 | +97 |
- #' Binomial distribution) that is result of a generalized linear model of one (e.g. arm) or more+ a_count_abnormal_by_worst_grade <- make_afun( # nolint |
||
| 10 | +98 |
- #' covariates.+ s_count_abnormal_by_worst_grade, |
||
| 11 | +99 |
- #'+ .formats = c(count_fraction = format_count_fraction) |
||
| 12 | +100 |
- #' @inheritParams h_glm_count+ ) |
||
| 13 | +101 |
- #' @inheritParams argument_convention+ |
||
| 14 | +102 |
- #' @param rate_mean_method (`character(1)`)\cr method used to estimate the mean odds ratio. Defaults to `emmeans`.+ #' @describeIn abnormal_by_worst_grade Layout-creating function which can take statistics function arguments |
||
| 15 | +103 |
- #' see details for more information.+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 16 | +104 |
- #' @param scale (`numeric(1)`)\cr linear scaling factor for rate and confidence intervals. Defaults to `1`.+ #' |
||
| 17 | +105 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' @return |
||
| 18 | +106 |
- #'+ #' * `count_abnormal_by_worst_grade()` returns a layout object suitable for passing to further layouting functions, |
||
| 19 | +107 |
- #' Options are: ``r shQuote(get_stats("summarize_glm_count"))``
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 20 | +108 |
- #'+ #' the statistics from `s_count_abnormal_by_worst_grade()` to the table layout. |
||
| 21 | +109 |
- #' @details+ #' |
||
| 22 | +110 |
- #' `summarize_glm_count()` uses `s_glm_count()` to calculate the statistics for the table. This+ #' @examples |
||
| 23 | +111 |
- #' analysis function uses [h_glm_count()] to estimate the GLM with [stats::glm()] for Poisson and Quasi-Poisson+ #' library(dplyr) |
||
| 24 | +112 |
- #' distributions or [MASS::glm.nb()] for Negative Binomial distribution. All methods assume a+ #' library(forcats) |
||
| 25 | +113 |
- #' logarithmic link function.+ #' adlb <- tern_ex_adlb |
||
| 26 | +114 |
#' |
||
| 27 | +115 |
- #' At this point, rates and confidence intervals are estimated from the model using+ #' # Data is modified in order to have some parameters with grades only in one direction |
||
| 28 | +116 |
- #' either [emmeans::emmeans()] when `rate_mean_method = "emmeans"` or [h_ppmeans()]+ #' # and simulate the real data. |
||
| 29 | +117 |
- #' when `rate_mean_method = "ppmeans"`.+ #' adlb$ATOXGR[adlb$PARAMCD == "ALT" & adlb$ATOXGR %in% c("1", "2", "3", "4")] <- "-1"
|
||
| 30 | +118 |
- #'+ #' adlb$ANRIND[adlb$PARAMCD == "ALT" & adlb$ANRIND == "HIGH"] <- "LOW" |
||
| 31 | +119 |
- #' If a reference group is specified while building the table with `split_cols_by(ref_group)`,+ #' adlb$WGRHIFL[adlb$PARAMCD == "ALT"] <- "" |
||
| 32 | +120 |
- #' no rate ratio or `p-value` are calculated. Otherwise, we use [emmeans::contrast()] to+ #' |
||
| 33 | +121 |
- #' calculate the rate ratio and `p-value` for the reference group. Values are always estimated+ #' adlb$ATOXGR[adlb$PARAMCD == "IGA" & adlb$ATOXGR %in% c("-1", "-2", "-3", "-4")] <- "1"
|
||
| 34 | +122 |
- #' with `method = "trt.vs.ctrl"` and `ref` equal to the first `arm` value.+ #' adlb$ANRIND[adlb$PARAMCD == "IGA" & adlb$ANRIND == "LOW"] <- "HIGH" |
||
| 35 | +123 |
- #'+ #' adlb$WGRLOFL[adlb$PARAMCD == "IGA"] <- "" |
||
| 36 | +124 |
- #' @name summarize_glm_count+ #' |
||
| 37 | +125 |
- NULL+ #' # Pre-processing |
||
| 38 | +126 |
-
+ #' adlb_f <- adlb %>% h_adlb_abnormal_by_worst_grade() |
||
| 39 | +127 |
- #' @describeIn summarize_glm_count Layout-creating function which can take statistics function arguments+ #' |
||
| 40 | +128 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' # Map excludes records without abnormal grade since they should not be displayed |
||
| 41 | +129 |
- #'+ #' # in the table. |
||
| 42 | +130 |
- #' @return+ #' map <- unique(adlb_f[adlb_f$GRADE_DIR != "ZERO", c("PARAM", "GRADE_DIR", "GRADE_ANL")]) %>%
|
||
| 43 | +131 |
- #' * `summarize_glm_count()` returns a layout object suitable for passing to further layouting functions,+ #' lapply(as.character) %>% |
||
| 44 | +132 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' as.data.frame() %>% |
||
| 45 | +133 |
- #' the statistics from `s_glm_count()` to the table layout.+ #' arrange(PARAM, desc(GRADE_DIR), GRADE_ANL) |
||
| 46 | +134 |
#' |
||
| 47 | +135 |
- #' @examples+ #' basic_table() %>% |
||
| 48 | +136 |
- #' library(dplyr)+ #' split_cols_by("ARMCD") %>%
|
||
| 49 | +137 |
- #'+ #' split_rows_by("PARAM") %>%
|
||
| 50 | +138 |
- #' anl <- tern_ex_adtte %>% filter(PARAMCD == "TNE")+ #' split_rows_by("GRADE_DIR", split_fun = trim_levels_to_map(map)) %>%
|
||
| 51 | +139 |
- #' anl$AVAL_f <- as.factor(anl$AVAL)+ #' count_abnormal_by_worst_grade( |
||
| 52 | +140 |
- #'+ #' var = "GRADE_ANL", |
||
| 53 | +141 |
- #' lyt <- basic_table() %>%+ #' variables = list(id = "USUBJID", param = "PARAM", grade_dir = "GRADE_DIR") |
||
| 54 | +142 |
- #' split_cols_by("ARM", ref_group = "B: Placebo") %>%
+ #' ) %>% |
||
| 55 | +143 |
- #' add_colcounts() %>%+ #' build_table(df = adlb_f) |
||
| 56 | +144 |
- #' analyze_vars(+ #' |
||
| 57 | +145 |
- #' "AVAL_f",+ #' @export |
||
| 58 | +146 |
- #' var_labels = "Number of exacerbations per patient",+ #' @order 2 |
||
| 59 | +147 |
- #' .stats = c("count_fraction"),
+ count_abnormal_by_worst_grade <- function(lyt, |
||
| 60 | +148 |
- #' .formats = c("count_fraction" = "xx (xx.xx%)"),
+ var, |
||
| 61 | +149 |
- #' .labels = c("Number of exacerbations per patient")
+ variables = list( |
||
| 62 | +150 |
- #' ) %>%+ id = "USUBJID", |
||
| 63 | +151 |
- #' summarize_glm_count(+ param = "PARAM", |
||
| 64 | +152 |
- #' vars = "AVAL",+ grade_dir = "GRADE_DIR" |
||
| 65 | +153 |
- #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = NULL),+ ), |
||
| 66 | +154 |
- #' conf_level = 0.95,+ na_str = default_na_str(), |
||
| 67 | +155 |
- #' distribution = "poisson",+ nested = TRUE, |
||
| 68 | +156 |
- #' rate_mean_method = "emmeans",+ ..., |
||
| 69 | +157 |
- #' var_labels = "Adjusted (P) exacerbation rate (per year)",+ .stats = NULL, |
||
| 70 | +158 |
- #' table_names = "adjP",+ .formats = NULL, |
||
| 71 | +159 |
- #' .stats = c("rate"),
+ .labels = NULL, |
||
| 72 | +160 |
- #' .labels = c(rate = "Rate")+ .indent_mods = NULL) {
|
||
| 73 | -+ | |||
| 161 | +2x |
- #' ) %>%+ extra_args <- list(variables = variables, ...) |
||
| 74 | +162 |
- #' summarize_glm_count(+ |
||
| 75 | -+ | |||
| 163 | +2x |
- #' vars = "AVAL",+ afun <- make_afun( |
||
| 76 | -+ | |||
| 164 | +2x |
- #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = c("REGION1")),
+ a_count_abnormal_by_worst_grade, |
||
| 77 | -+ | |||
| 165 | +2x |
- #' conf_level = 0.95,+ .stats = .stats, |
||
| 78 | -+ | |||
| 166 | +2x |
- #' distribution = "quasipoisson",+ .formats = .formats, |
||
| 79 | -+ | |||
| 167 | +2x |
- #' rate_mean_method = "ppmeans",+ .labels = .labels, |
||
| 80 | -+ | |||
| 168 | +2x |
- #' var_labels = "Adjusted (QP) exacerbation rate (per year)",+ .indent_mods = .indent_mods, |
||
| 81 | -+ | |||
| 169 | +2x |
- #' table_names = "adjQP",+ .ungroup_stats = "count_fraction" |
||
| 82 | +170 |
- #' .stats = c("rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
+ ) |
||
| 83 | -+ | |||
| 171 | +2x |
- #' .labels = c(+ analyze(+ |
+ ||
| 172 | +2x | +
+ lyt = lyt,+ |
+ ||
| 173 | +2x | +
+ vars = var,+ |
+ ||
| 174 | +2x | +
+ afun = afun,+ |
+ ||
| 175 | +2x | +
+ na_str = na_str,+ |
+ ||
| 176 | +2x | +
+ nested = nested,+ |
+ ||
| 177 | +2x | +
+ extra_args = extra_args,+ |
+ ||
| 178 | +2x | +
+ show_labels = "hidden" |
||
| 84 | +179 |
- #' rate = "Rate", rate_ci = "Rate CI", rate_ratio = "Rate Ratio",+ ) |
||
| 85 | +180 |
- #' rate_ratio_ci = "Rate Ratio CI", pval = "p value"+ } |
||
| 86 | +181 |
- #' )+ |
||
| 87 | +182 |
- #' ) %>%+ #' Helper function to prepare ADLB for `count_abnormal_by_worst_grade()` |
||
| 88 | +183 |
- #' summarize_glm_count(+ #' |
||
| 89 | +184 |
- #' vars = "AVAL",+ #' @description `r lifecycle::badge("stable")`
|
||
| 90 | +185 |
- #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = c("REGION1")),
+ #' |
||
| 91 | +186 |
- #' conf_level = 0.95,+ #' Helper function to prepare an ADLB data frame to be used as input in |
||
| 92 | +187 |
- #' distribution = "negbin",+ #' [count_abnormal_by_worst_grade()]. The following pre-processing steps are applied: |
||
| 93 | +188 |
- #' rate_mean_method = "emmeans",+ #' |
||
| 94 | +189 |
- #' var_labels = "Adjusted (NB) exacerbation rate (per year)",+ #' 1. `adlb` is filtered on variable `avisit` to only include post-baseline visits. |
||
| 95 | +190 |
- #' table_names = "adjNB",+ #' 2. `adlb` is filtered on variables `worst_flag_low` and `worst_flag_high` so that only |
||
| 96 | +191 |
- #' .stats = c("rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
+ #' worst grades (in either direction) are included. |
||
| 97 | +192 |
- #' .labels = c(+ #' 3. From the standard lab grade variable `atoxgr`, the following two variables are derived |
||
| 98 | +193 |
- #' rate = "Rate", rate_ci = "Rate CI", rate_ratio = "Rate Ratio",+ #' and added to `adlb`: |
||
| 99 | +194 |
- #' rate_ratio_ci = "Rate Ratio CI", pval = "p value"+ #' * A grade direction variable (e.g. `GRADE_DIR`). The variable takes value `"HIGH"` when |
||
| 100 | +195 |
- #' )+ #' `atoxgr > 0`, `"LOW"` when `atoxgr < 0`, and `"ZERO"` otherwise. |
||
| 101 | +196 |
- #' )+ #' * A toxicity grade variable (e.g. `GRADE_ANL`) where all negative values from `atoxgr` are |
||
| 102 | +197 |
- #'+ #' replaced by their absolute values. |
||
| 103 | +198 |
- #' build_table(lyt = lyt, df = anl)+ #' 4. Unused factor levels are dropped from `adlb` via [droplevels()]. |
||
| 104 | +199 |
#' |
||
| 105 | +200 |
- #' @export+ #' @param adlb (`data.frame`)\cr ADLB data frame. |
||
| 106 | +201 |
- summarize_glm_count <- function(lyt,+ #' @param atoxgr (`string`)\cr name of the analysis toxicity grade variable. This must be a `factor` |
||
| 107 | +202 |
- vars,+ #' variable. |
||
| 108 | +203 |
- variables,+ #' @param avisit (`string`)\cr name of the analysis visit variable. |
||
| 109 | +204 |
- distribution,+ #' @param worst_flag_low (`string`)\cr name of the worst low lab grade flag variable. This variable is |
||
| 110 | +205 |
- conf_level,+ #' set to `"Y"` when indicating records of worst low lab grades. |
||
| 111 | +206 |
- rate_mean_method = c("emmeans", "ppmeans")[1],
+ #' @param worst_flag_high (`string`)\cr name of the worst high lab grade flag variable. This variable is |
||
| 112 | +207 |
- weights = stats::weights,+ #' set to `"Y"` when indicating records of worst high lab grades. |
||
| 113 | +208 |
- scale = 1,+ #' |
||
| 114 | +209 |
- var_labels,+ #' @return `h_adlb_abnormal_by_worst_grade()` returns the `adlb` data frame with two new |
||
| 115 | +210 |
- na_str = default_na_str(),+ #' variables: `GRADE_DIR` and `GRADE_ANL`. |
||
| 116 | +211 |
- nested = TRUE,+ #' |
||
| 117 | +212 |
- ...,+ #' @seealso [abnormal_by_worst_grade] |
||
| 118 | +213 |
- show_labels = "visible",+ #' |
||
| 119 | +214 |
- table_names = vars,+ #' @examples |
||
| 120 | +215 |
- .stats = get_stats("summarize_glm_count"),
+ #' h_adlb_abnormal_by_worst_grade(tern_ex_adlb) %>% |
||
| 121 | +216 |
- .formats = NULL,+ #' dplyr::select(ATOXGR, GRADE_DIR, GRADE_ANL) %>% |
||
| 122 | +217 |
- .labels = NULL,+ #' head(10) |
||
| 123 | +218 |
- .indent_mods = c(+ #' |
||
| 124 | +219 |
- "n" = 0L,+ #' @export |
||
| 125 | +220 |
- "rate" = 0L,+ h_adlb_abnormal_by_worst_grade <- function(adlb, |
||
| 126 | +221 |
- "rate_ci" = 1L,+ atoxgr = "ATOXGR", |
||
| 127 | +222 |
- "rate_ratio" = 0L,+ avisit = "AVISIT", |
||
| 128 | +223 |
- "rate_ratio_ci" = 1L,+ worst_flag_low = "WGRLOFL", |
||
| 129 | +224 |
- "pval" = 1L+ worst_flag_high = "WGRHIFL") {
|
||
| 130 | -+ | |||
| 225 | +1x |
- )) {
+ adlb %>% |
||
| 131 | -3x | +226 | +1x |
- checkmate::assert_choice(rate_mean_method, c("emmeans", "ppmeans"))
+ dplyr::filter( |
| 132 | -+ | |||
| 227 | +1x |
-
+ !.data[[avisit]] %in% c("SCREENING", "BASELINE"),
|
||
| 133 | -3x | +228 | +1x |
- extra_args <- list(+ .data[[worst_flag_low]] == "Y" | .data[[worst_flag_high]] == "Y" |
| 134 | -3x | +|||
| 229 | +
- variables = variables, distribution = distribution, conf_level = conf_level,+ ) %>% |
|||
| 135 | -3x | +230 | +1x |
- rate_mean_method = rate_mean_method, weights = weights, scale = scale, ...+ dplyr::mutate( |
| 136 | -+ | |||
| 231 | +1x |
- )+ GRADE_DIR = factor( |
||
| 137 | -+ | |||
| 232 | +1x |
-
+ dplyr::case_when( |
||
| 138 | -+ | |||
| 233 | +1x |
- # Selecting parameters following the statistics+ .data[[atoxgr]] %in% c("-1", "-2", "-3", "-4") ~ "LOW",
|
||
| 139 | -3x | +234 | +1x |
- .formats <- get_formats_from_stats(.stats, formats_in = .formats)+ .data[[atoxgr]] == "0" ~ "ZERO", |
| 140 | -3x | +235 | +1x |
- .labels <- get_labels_from_stats(.stats, labels_in = .labels)+ .data[[atoxgr]] %in% c("1", "2", "3", "4") ~ "HIGH"
+ |
+
| 236 | ++ |
+ ), |
||
| 141 | -3x | +237 | +1x |
- .indent_mods <- get_indents_from_stats(.stats, indents_in = .indent_mods)+ levels = c("LOW", "ZERO", "HIGH")
|
| 142 | +238 |
-
+ ), |
||
| 143 | -3x | +239 | +1x |
- afun <- make_afun(+ GRADE_ANL = forcats::fct_relevel( |
| 144 | -3x | +240 | +1x |
- s_glm_count,+ forcats::fct_recode(.data[[atoxgr]], `1` = "-1", `2` = "-2", `3` = "-3", `4` = "-4"), |
| 145 | -3x | +241 | +1x |
- .stats = .stats,+ c("0", "1", "2", "3", "4")
|
| 146 | -3x | +|||
| 242 | +
- .formats = .formats,+ ) |
|||
| 147 | -3x | +|||
| 243 | +
- .labels = .labels,+ ) %>% |
|||
| 148 | -3x | +244 | +1x |
- .indent_mods = .indent_mods,+ droplevels() |
| 149 | -3x | +|||
| 245 | +
- .null_ref_cells = FALSE+ } |
| 150 | +1 |
- )+ #' Proportion estimation |
||
| 151 | +2 |
-
+ #' |
||
| 152 | -3x | +|||
| 3 | +
- analyze(+ #' @description `r lifecycle::badge("stable")`
|
|||
| 153 | -3x | +|||
| 4 | +
- lyt,+ #' |
|||
| 154 | -3x | +|||
| 5 | +
- vars,+ #' The analyze function [estimate_proportion()] creates a layout element to estimate the proportion of responders |
|||
| 155 | -3x | +|||
| 6 | +
- var_labels = var_labels,+ #' within a studied population. The primary analysis variable, `vars`, indicates whether a response has occurred for |
|||
| 156 | -3x | +|||
| 7 | +
- show_labels = show_labels,+ #' each record. See the `method` parameter for options of methods to use when constructing the confidence interval of |
|||
| 157 | -3x | +|||
| 8 | +
- table_names = table_names,+ #' the proportion. Additionally, a stratification variable can be supplied via the `strata` element of the `variables` |
|||
| 158 | -3x | +|||
| 9 | +
- afun = afun,+ #' argument. |
|||
| 159 | -3x | +|||
| 10 | +
- na_str = na_str,+ #' |
|||
| 160 | -3x | +|||
| 11 | +
- nested = nested,+ #' @inheritParams prop_strat_wilson |
|||
| 161 | -3x | +|||
| 12 | +
- extra_args = extra_args+ #' @inheritParams argument_convention |
|||
| 162 | +13 |
- )+ #' @param method (`string`)\cr the method used to construct the confidence interval |
||
| 163 | +14 |
- }+ #' for proportion of successful outcomes; one of `waldcc`, `wald`, `clopper-pearson`, |
||
| 164 | +15 |
-
+ #' `wilson`, `wilsonc`, `strat_wilson`, `strat_wilsonc`, `agresti-coull` or `jeffreys`. |
||
| 165 | +16 |
- #' @describeIn summarize_glm_count Statistics function that produces a named list of results+ #' @param long (`flag`)\cr whether a long description is required. |
||
| 166 | +17 |
- #' of the investigated Poisson model.+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 167 | +18 |
#' |
||
| 168 | +19 |
- #' @return+ #' Options are: ``r shQuote(get_stats("estimate_proportion"), type = "sh")``
|
||
| 169 | +20 |
- #' * `s_glm_count()` returns a named `list` of 5 statistics:+ #' |
||
| 170 | +21 |
- #' * `n`: Count of complete sample size for the group.+ #' @seealso [h_proportions] |
||
| 171 | +22 |
- #' * `rate`: Estimated event rate per follow-up time.+ #' |
||
| 172 | +23 |
- #' * `rate_ci`: Confidence level for estimated rate per follow-up time.+ #' @name estimate_proportion |
||
| 173 | +24 |
- #' * `rate_ratio`: Ratio of event rates in each treatment arm to the reference arm.+ #' @order 1 |
||
| 174 | +25 |
- #' * `rate_ratio_ci`: Confidence level for the rate ratio.+ NULL |
||
| 175 | +26 |
- #' * `pval`: p-value.+ |
||
| 176 | +27 |
- #'+ #' @describeIn estimate_proportion Statistics function estimating a |
||
| 177 | +28 |
- #' @keywords internal+ #' proportion along with its confidence interval. |
||
| 178 | +29 |
- s_glm_count <- function(df,+ #' |
||
| 179 | +30 |
- .var,+ #' @param df (`logical` or `data.frame`)\cr if only a logical vector is used, |
||
| 180 | +31 |
- .df_row,+ #' it indicates whether each subject is a responder or not. `TRUE` represents |
||
| 181 | +32 |
- variables,+ #' a successful outcome. If a `data.frame` is provided, also the `strata` variable |
||
| 182 | +33 |
- .ref_group,+ #' names must be provided in `variables` as a list element with the strata strings. |
||
| 183 | +34 |
- .in_ref_col,+ #' In the case of `data.frame`, the logical vector of responses must be indicated as a |
||
| 184 | +35 |
- distribution,+ #' variable name in `.var`. |
||
| 185 | +36 |
- conf_level,+ #' |
||
| 186 | +37 |
- rate_mean_method,+ #' @return |
||
| 187 | +38 |
- weights,+ #' * `s_proportion()` returns statistics `n_prop` (`n` and proportion) and `prop_ci` (proportion CI) for a |
||
| 188 | +39 |
- scale = 1) {
+ #' given variable. |
||
| 189 | -14x | +|||
| 40 | +
- arm <- variables$arm+ #' |
|||
| 190 | +41 |
-
+ #' @examples |
||
| 191 | -14x | +|||
| 42 | +
- y <- df[[.var]]+ #' # Case with only logical vector. |
|||
| 192 | -13x | +|||
| 43 | +
- smry_level <- as.character(unique(df[[arm]]))+ #' rsp_v <- c(1, 0, 1, 0, 1, 1, 0, 0) |
|||
| 193 | +44 |
-
+ #' s_proportion(rsp_v) |
||
| 194 | +45 |
- # ensure there is only 1 value+ #' |
||
| 195 | -13x | +|||
| 46 | +
- checkmate::assert_scalar(smry_level)+ #' # Example for Stratified Wilson CI |
|||
| 196 | +47 |
-
+ #' nex <- 100 # Number of example rows |
||
| 197 | -13x | +|||
| 48 | +
- results <- h_glm_count(+ #' dta <- data.frame( |
|||
| 198 | -13x | +|||
| 49 | +
- .var = .var,+ #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE), |
|||
| 199 | -13x | +|||
| 50 | +
- .df_row = .df_row,+ #' "grp" = sample(c("A", "B"), nex, TRUE),
|
|||
| 200 | -13x | +|||
| 51 | +
- variables = variables,+ #' "f1" = sample(c("a1", "a2"), nex, TRUE),
|
|||
| 201 | -13x | +|||
| 52 | +
- distribution = distribution,+ #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
|
|||
| 202 | -13x | +|||
| 53 | +
- weights+ #' stringsAsFactors = TRUE |
|||
| 203 | +54 |
- )+ #' ) |
||
| 204 | +55 |
-
+ #' |
||
| 205 | -13x | +|||
| 56 | +
- if (rate_mean_method == "emmeans") {
+ #' s_proportion( |
|||
| 206 | -13x | +|||
| 57 | +
- emmeans_smry <- summary(results$emmeans_fit, level = conf_level)+ #' df = dta, |
|||
| 207 | -! | +|||
| 58 | +
- } else if (rate_mean_method == "ppmeans") {
+ #' .var = "rsp", |
|||
| 208 | -! | +|||
| 59 | +
- emmeans_smry <- h_ppmeans(results$glm_fit, .df_row, arm, conf_level)+ #' variables = list(strata = c("f1", "f2")),
|
|||
| 209 | +60 |
- }+ #' conf_level = 0.90, |
||
| 210 | +61 |
-
+ #' method = "strat_wilson" |
||
| 211 | -13x | +|||
| 62 | +
- emmeans_smry_level <- emmeans_smry[emmeans_smry[[arm]] == smry_level, ]+ #' ) |
|||
| 212 | +63 |
-
+ #' |
||
| 213 | +64 |
- # This happens if there is a reference col. No Ratio is calculated?+ #' @export |
||
| 214 | -13x | +|||
| 65 | +
- if (.in_ref_col) {
+ s_proportion <- function(df, |
|||
| 215 | -5x | +|||
| 66 | +
- list(+ .var, |
|||
| 216 | -5x | +|||
| 67 | +
- n = length(y[!is.na(y)]),+ conf_level = 0.95, |
|||
| 217 | -5x | +|||
| 68 | +
- rate = formatters::with_label(+ method = c( |
|||
| 218 | -5x | +|||
| 69 | +
- ifelse(distribution == "negbin", emmeans_smry_level$response * scale, emmeans_smry_level$rate * scale),+ "waldcc", "wald", "clopper-pearson", |
|||
| 219 | -5x | +|||
| 70 | +
- "Adjusted Rate"+ "wilson", "wilsonc", "strat_wilson", "strat_wilsonc", |
|||
| 220 | +71 |
- ),+ "agresti-coull", "jeffreys" |
||
| 221 | -5x | +|||
| 72 | +
- rate_ci = formatters::with_label(+ ), |
|||
| 222 | -5x | +|||
| 73 | +
- c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale),+ weights = NULL, |
|||
| 223 | -5x | +|||
| 74 | +
- f_conf_level(conf_level)+ max_iterations = 50, |
|||
| 224 | +75 |
- ),+ variables = list(strata = NULL), |
||
| 225 | -5x | +|||
| 76 | +
- rate_ratio = formatters::with_label(character(), "Adjusted Rate Ratio"),+ long = FALSE) {
|
|||
| 226 | -5x | +77 | +167x |
- rate_ratio_ci = formatters::with_label(character(), f_conf_level(conf_level)),+ method <- match.arg(method) |
| 227 | -5x | +78 | +167x |
- pval = formatters::with_label(character(), "p-value")+ checkmate::assert_flag(long) |
| 228 | -+ | |||
| 79 | +167x |
- )+ assert_proportion_value(conf_level) |
||
| 229 | +80 |
- } else {
+
|
||
| 230 | -8x | +81 | +167x |
- emmeans_contrasts <- emmeans::contrast(+ if (!is.null(variables$strata)) {
|
| 231 | -8x | +|||
| 82 | +
- results$emmeans_fit,+ # Checks for strata |
|||
| 232 | -8x | +|||
| 83 | +! |
- method = "trt.vs.ctrl",+ if (missing(df)) stop("When doing stratified analysis a data.frame with specific columns is needed.")
|
||
| 233 | -8x | +|||
| 84 | +! |
- ref = grep(+ strata_colnames <- variables$strata |
||
| 234 | -8x | +|||
| 85 | +! |
- as.character(unique(.ref_group[[arm]])),+ checkmate::assert_character(strata_colnames, null.ok = FALSE) |
||
| 235 | -8x | +|||
| 86 | +! |
- as.data.frame(results$emmeans_fit)[[arm]]+ strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)+ |
+ ||
| 87 | +! | +
+ assert_df_with_variables(df, strata_vars) |
||
| 236 | +88 |
- )+ + |
+ ||
| 89 | +! | +
+ strata <- interaction(df[strata_colnames])+ |
+ ||
| 90 | +! | +
+ strata <- as.factor(strata) |
||
| 237 | +91 |
- )+ |
||
| 238 | +92 |
-
+ # Pushing down checks to prop_strat_wilson |
||
| 239 | -8x | +93 | +167x |
- contrasts_smry <- summary(+ } else if (checkmate::test_subset(method, c("strat_wilson", "strat_wilsonc"))) {
|
| 240 | -8x | +|||
| 94 | +! |
- emmeans_contrasts,+ stop("To use stratified methods you need to specify the strata variables.")
+ |
+ ||
| 95 | ++ |
+ } |
||
| 241 | -8x | +96 | +167x |
- infer = TRUE,+ if (checkmate::test_atomic_vector(df)) {
|
| 242 | -8x | +97 | +167x |
- adjust = "none"+ rsp <- as.logical(df) |
| 243 | +98 |
- )+ } else {
+ |
+ ||
| 99 | +! | +
+ rsp <- as.logical(df[[.var]]) |
||
| 244 | +100 |
-
+ } |
||
| 245 | -8x | +101 | +167x |
- smry_contrasts_level <- contrasts_smry[grepl(smry_level, contrasts_smry$contrast), ]+ n <- sum(rsp)+ |
+
| 102 | +167x | +
+ p_hat <- mean(rsp) |
||
| 246 | +103 | |||
| 247 | -8x | +104 | +167x |
- list(+ prop_ci <- switch(method, |
| 248 | -8x | +105 | +167x |
- n = length(y[!is.na(y)]),+ "clopper-pearson" = prop_clopper_pearson(rsp, conf_level), |
| 249 | -8x | +106 | +167x |
- rate = formatters::with_label(+ "wilson" = prop_wilson(rsp, conf_level), |
| 250 | -8x | +107 | +167x |
- ifelse(distribution == "negbin",+ "wilsonc" = prop_wilson(rsp, conf_level, correct = TRUE), |
| 251 | -8x | +108 | +167x |
- emmeans_smry_level$response * scale,+ "strat_wilson" = prop_strat_wilson(rsp, |
| 252 | -8x | +109 | +167x |
- emmeans_smry_level$rate * scale+ strata, |
| 253 | -+ | |||
| 110 | +167x |
- ),+ weights, |
||
| 254 | -8x | +111 | +167x |
- "Adjusted Rate"+ conf_level, |
| 255 | -+ | |||
| 112 | +167x |
- ),+ max_iterations, |
||
| 256 | -8x | +113 | +167x |
- rate_ci = formatters::with_label(+ correct = FALSE |
| 257 | -8x | +114 | +167x |
- c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale),+ )$conf_int, |
| 258 | -8x | +115 | +167x |
- f_conf_level(conf_level)+ "strat_wilsonc" = prop_strat_wilson(rsp, |
| 259 | -+ | |||
| 116 | +167x | +
+ strata,+ |
+ ||
| 117 | +167x | +
+ weights,+ |
+ ||
| 118 | +167x | +
+ conf_level,+ |
+ ||
| 119 | +167x |
- ),+ max_iterations, |
||
| 260 | -8x | +120 | +167x |
- rate_ratio = formatters::with_label(+ correct = TRUE |
| 261 | -8x | +121 | +167x |
- smry_contrasts_level$ratio,+ )$conf_int, |
| 262 | -8x | +122 | +167x |
- "Adjusted Rate Ratio"+ "wald" = prop_wald(rsp, conf_level), |
| 263 | -+ | |||
| 123 | +167x |
- ),+ "waldcc" = prop_wald(rsp, conf_level, correct = TRUE), |
||
| 264 | -8x | +124 | +167x |
- rate_ratio_ci = formatters::with_label(+ "agresti-coull" = prop_agresti_coull(rsp, conf_level), |
| 265 | -8x | +125 | +167x |
- c(smry_contrasts_level$asymp.LCL, smry_contrasts_level$asymp.UCL),+ "jeffreys" = prop_jeffreys(rsp, conf_level) |
| 266 | -8x | +|||
| 126 | +
- f_conf_level(conf_level)+ ) |
|||
| 267 | +127 |
- ),+ |
||
| 268 | -8x | +128 | +167x |
- pval = formatters::with_label(+ list( |
| 269 | -8x | +129 | +167x |
- smry_contrasts_level$p.value,+ "n_prop" = formatters::with_label(c(n, p_hat), "Responders"), |
| 270 | -8x | +130 | +167x |
- "p-value"+ "prop_ci" = formatters::with_label( |
| 271 | -+ | |||
| 131 | +167x |
- )+ x = 100 * prop_ci, label = d_proportion(conf_level, method, long = long) |
||
| 272 | +132 |
) |
||
| 273 | +133 |
- }+ ) |
||
| 274 | +134 |
} |
||
| 275 | +135 |
- # h_glm_count ------------------------------------------------------------------+ |
||
| 276 | +136 |
- #' Helper functions for Poisson models+ #' @describeIn estimate_proportion Formatted analysis function which is used as `afun` |
||
| 277 | +137 |
- #'+ #' in `estimate_proportion()`. |
||
| 278 | +138 |
- #' @description `r lifecycle::badge("experimental")`
+ #' |
||
| 279 | +139 |
- #'+ #' @return |
||
| 280 | +140 |
- #' Helper functions that returns the results of [stats::glm()] when Poisson or Quasi-Poisson+ #' * `a_proportion()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 281 | +141 |
- #' distributions are needed (see `family` parameter), or [MASS::glm.nb()] for Negative Binomial+ #' |
||
| 282 | +142 |
- #' distributions. Link function for the GLM is `log`.+ #' @export |
||
| 283 | +143 |
- #'+ a_proportion <- make_afun( |
||
| 284 | +144 |
- #' @inheritParams argument_convention+ s_proportion, |
||
| 285 | +145 |
- #'+ .formats = c(n_prop = "xx (xx.x%)", prop_ci = "(xx.x, xx.x)") |
||
| 286 | +146 |
- #' @seealso [summarize_glm_count]+ ) |
||
| 287 | +147 |
- #'+ |
||
| 288 | +148 |
- #' @name h_glm_count+ #' @describeIn estimate_proportion Layout-creating function which can take statistics function arguments |
||
| 289 | +149 |
- NULL+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 290 | +150 |
-
+ #' |
||
| 291 | +151 |
- #' @describeIn h_glm_count Helper function to return the results of the+ #' @return |
||
| 292 | +152 |
- #' selected model (Poisson, Quasi-Poisson, negative binomial).+ #' * `estimate_proportion()` returns a layout object suitable for passing to further layouting functions, |
||
| 293 | +153 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 294 | +154 |
- #' @param .df_row (`data.frame`)\cr dataset that includes all the variables that are called+ #' the statistics from `s_proportion()` to the table layout. |
||
| 295 | +155 |
- #' in `.var` and `variables`.+ #' |
||
| 296 | +156 |
- #' @param variables (named `list` of `string`)\cr list of additional analysis variables, with+ #' @examples |
||
| 297 | +157 |
- #' expected elements:+ #' dta_test <- data.frame( |
||
| 298 | +158 |
- #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple+ #' USUBJID = paste0("S", 1:12),
|
||
| 299 | +159 |
- #' groups will be summarized. Specifically, the first level of `arm` variable is taken as the+ #' ARM = rep(LETTERS[1:3], each = 4), |
||
| 300 | +160 |
- #' reference group.+ #' AVAL = rep(LETTERS[1:3], each = 4) |
||
| 301 | +161 |
- #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as+ #' ) |
||
| 302 | +162 |
- #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`.+ #' |
||
| 303 | +163 |
- #' * `offset` (`numeric`)\cr a numeric vector or scalar adding an offset.+ #' basic_table() %>% |
||
| 304 | +164 |
- #' @param distribution (`character`)\cr a character value specifying the distribution+ #' split_cols_by("ARM") %>%
|
||
| 305 | +165 |
- #' used in the regression (Poisson, Quasi-Poisson, negative binomial).+ #' estimate_proportion(vars = "AVAL") %>% |
||
| 306 | +166 |
- #' @param weights (`character`)\cr a character vector specifying weights used+ #' build_table(df = dta_test) |
||
| 307 | +167 |
- #' in averaging predictions. Number of weights must equal the number of levels included in the covariates.+ #' |
||
| 308 | +168 |
- #' Weights option passed to [emmeans::emmeans()].+ #' @export |
||
| 309 | +169 |
- #'+ #' @order 2 |
||
| 310 | +170 |
- #' @return+ estimate_proportion <- function(lyt, |
||
| 311 | +171 |
- #' * `h_glm_count()` returns the results of the selected model.+ vars, |
||
| 312 | +172 |
- #'+ conf_level = 0.95, |
||
| 313 | +173 |
- #' @keywords internal+ method = c( |
||
| 314 | +174 |
- h_glm_count <- function(.var,+ "waldcc", "wald", "clopper-pearson", |
||
| 315 | +175 |
- .df_row,+ "wilson", "wilsonc", "strat_wilson", "strat_wilsonc", |
||
| 316 | +176 |
- variables,+ "agresti-coull", "jeffreys" |
||
| 317 | +177 |
- distribution,+ ), |
||
| 318 | +178 |
- weights) {
+ weights = NULL, |
||
| 319 | -21x | +|||
| 179 | +
- checkmate::assert_subset(distribution, c("poisson", "quasipoisson", "negbin"), empty.ok = FALSE)
+ max_iterations = 50, |
|||
| 320 | -19x | +|||
| 180 | +
- switch(distribution,+ variables = list(strata = NULL), |
|||
| 321 | -13x | +|||
| 181 | +
- poisson = h_glm_poisson(.var, .df_row, variables, weights),+ long = FALSE, |
|||
| 322 | -1x | +|||
| 182 | +
- quasipoisson = h_glm_quasipoisson(.var, .df_row, variables, weights),+ na_str = default_na_str(), |
|||
| 323 | -5x | +|||
| 183 | +
- negbin = h_glm_negbin(.var, .df_row, variables, weights)+ nested = TRUE, |
|||
| 324 | +184 |
- )+ ..., |
||
| 325 | +185 |
- }+ show_labels = "hidden", |
||
| 326 | +186 |
-
+ table_names = vars, |
||
| 327 | +187 |
- #' @describeIn h_glm_count Helper function to return results of a Poisson model.+ .stats = NULL, |
||
| 328 | +188 |
- #'+ .formats = NULL, |
||
| 329 | +189 |
- #' @return+ .labels = NULL, |
||
| 330 | +190 |
- #' * `h_glm_poisson()` returns the results of a Poisson model.+ .indent_mods = NULL) {
|
||
| 331 | -+ | |||
| 191 | +3x |
- #'+ extra_args <- list( |
||
| 332 | -+ | |||
| 192 | +3x |
- #' @keywords internal+ conf_level = conf_level, method = method, weights = weights, max_iterations = max_iterations, |
||
| 333 | -+ | |||
| 193 | +3x |
- h_glm_poisson <- function(.var,+ variables = variables, long = long, ... |
||
| 334 | +194 |
- .df_row,+ ) |
||
| 335 | +195 |
- variables,+ |
||
| 336 | -+ | |||
| 196 | +3x |
- weights) {
+ afun <- make_afun( |
||
| 337 | -17x | +197 | +3x |
- arm <- variables$arm+ a_proportion, |
| 338 | -17x | +198 | +3x |
- covariates <- variables$covariates+ .stats = .stats, |
| 339 | -+ | |||
| 199 | +3x |
-
+ .formats = .formats, |
||
| 340 | -17x | +200 | +3x |
- formula <- stats::as.formula(paste0(+ .labels = .labels, |
| 341 | -17x | +201 | +3x |
- .var, " ~ ",+ .indent_mods = .indent_mods |
| 342 | +202 |
- " + ",+ ) |
||
| 343 | -17x | +203 | +3x |
- paste(covariates, collapse = " + "),+ analyze( |
| 344 | -+ | |||
| 204 | +3x |
- " + ",+ lyt, |
||
| 345 | -17x | +205 | +3x |
- arm+ vars, |
| 346 | -+ | |||
| 206 | +3x |
- ))+ afun = afun, |
||
| 347 | -+ | |||
| 207 | +3x |
-
+ na_str = na_str, |
||
| 348 | -17x | +208 | +3x |
- if (is.null(variables$offset)) {
+ nested = nested, |
| 349 | -1x | +209 | +3x |
- glm_fit <- stats::glm(+ extra_args = extra_args, |
| 350 | -1x | +210 | +3x |
- formula = formula,+ show_labels = show_labels, |
| 351 | -1x | +211 | +3x |
- data = .df_row,+ table_names = table_names |
| 352 | -1x | +|||
| 212 | +
- family = stats::poisson(link = "log")+ ) |
|||
| 353 | +213 |
- )+ } |
||
| 354 | +214 |
- } else {
+
|
||
| 355 | -16x | +|||
| 215 | +
- offset <- .df_row[[variables$offset]]+ #' Helper functions for calculating proportion confidence intervals |
|||
| 356 | -14x | +|||
| 216 | +
- glm_fit <- stats::glm(+ #' |
|||
| 357 | -14x | +|||
| 217 | +
- formula = formula,+ #' @description `r lifecycle::badge("stable")`
|
|||
| 358 | -14x | +|||
| 218 | +
- offset = offset,+ #' |
|||
| 359 | -14x | +|||
| 219 | +
- data = .df_row,+ #' Functions to calculate different proportion confidence intervals for use in [estimate_proportion()]. |
|||
| 360 | -14x | +|||
| 220 | +
- family = stats::poisson(link = "log")+ #' |
|||
| 361 | +221 |
- )+ #' @inheritParams argument_convention |
||
| 362 | +222 |
- }+ #' @inheritParams estimate_proportion |
||
| 363 | +223 |
-
+ #' |
||
| 364 | -15x | +|||
| 224 | +
- emmeans_fit <- emmeans::emmeans(+ #' @return Confidence interval of a proportion. |
|||
| 365 | -15x | +|||
| 225 | +
- glm_fit,+ #' |
|||
| 366 | -15x | +|||
| 226 | +
- specs = arm,+ #' @seealso [estimate_proportion], descriptive function [d_proportion()], |
|||
| 367 | -15x | +|||
| 227 | +
- data = .df_row,+ #' and helper functions [strata_normal_quantile()] and [update_weights_strat_wilson()]. |
|||
| 368 | -15x | +|||
| 228 | +
- type = "response",+ #' |
|||
| 369 | -15x | +|||
| 229 | +
- offset = 0,+ #' @name h_proportions |
|||
| 370 | -15x | +|||
| 230 | +
- weights = weights+ NULL |
|||
| 371 | +231 |
- )+ |
||
| 372 | +232 |
-
+ #' @describeIn h_proportions Calculates the Wilson interval by calling [stats::prop.test()]. |
||
| 373 | -15x | +|||
| 233 | +
- list(+ #' Also referred to as Wilson score interval. |
|||
| 374 | -15x | +|||
| 234 | +
- glm_fit = glm_fit,+ #' |
|||
| 375 | -15x | +|||
| 235 | +
- emmeans_fit = emmeans_fit+ #' @examples |
|||
| 376 | +236 |
- )+ #' rsp <- c( |
||
| 377 | +237 |
- }+ #' TRUE, TRUE, TRUE, TRUE, TRUE, |
||
| 378 | +238 |
-
+ #' FALSE, FALSE, FALSE, FALSE, FALSE |
||
| 379 | +239 |
- #' @describeIn h_glm_count Helper function to return results of a Quasi-Poisson model.+ #' ) |
||
| 380 | +240 | ++ |
+ #' prop_wilson(rsp, conf_level = 0.9)+ |
+ |
| 241 |
#' |
|||
| 381 | +242 |
- #' @return+ #' @export |
||
| 382 | +243 |
- #' * `h_glm_quasipoisson()` returns the results of a Quasi-Poisson model.+ prop_wilson <- function(rsp, conf_level, correct = FALSE) {
+ |
+ ||
| 244 | +5x | +
+ y <- stats::prop.test(+ |
+ ||
| 245 | +5x | +
+ sum(rsp),+ |
+ ||
| 246 | +5x | +
+ length(rsp),+ |
+ ||
| 247 | +5x | +
+ correct = correct,+ |
+ ||
| 248 | +5x | +
+ conf.level = conf_level |
||
| 383 | +249 |
- #'+ ) |
||
| 384 | +250 |
- #' @keywords internal+ + |
+ ||
| 251 | +5x | +
+ as.numeric(y$conf.int) |
||
| 385 | +252 |
- h_glm_quasipoisson <- function(.var,+ } |
||
| 386 | +253 |
- .df_row,+ |
||
| 387 | +254 |
- variables,+ #' @describeIn h_proportions Calculates the stratified Wilson confidence |
||
| 388 | +255 |
- weights) {
+ #' interval for unequal proportions as described in \insertCite{Yan2010-jt;textual}{tern}
|
||
| 389 | -5x | +|||
| 256 | +
- arm <- variables$arm+ #' |
|||
| 390 | -5x | +|||
| 257 | +
- covariates <- variables$covariates+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`. |
|||
| 391 | +258 |
-
+ #' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are |
||
| 392 | -5x | +|||
| 259 | +
- formula <- stats::as.formula(paste0(+ #' estimated using the iterative algorithm proposed in \insertCite{Yan2010-jt;textual}{tern} that
|
|||
| 393 | -5x | +|||
| 260 | +
- .var, " ~ ",+ #' minimizes the weighted squared length of the confidence interval. |
|||
| 394 | +261 |
- " + ",+ #' @param max_iterations (`count`)\cr maximum number of iterations for the iterative procedure used |
||
| 395 | -5x | +|||
| 262 | +
- paste(covariates, collapse = " + "),+ #' to find estimates of optimal weights. |
|||
| 396 | +263 |
- " + ",+ #' @param correct (`flag`)\cr whether to include the continuity correction. For further information, see for example |
||
| 397 | -5x | +|||
| 264 | +
- arm+ #' for [stats::prop.test()]. |
|||
| 398 | +265 |
- ))+ #' |
||
| 399 | +266 |
-
+ #' @references |
||
| 400 | -5x | +|||
| 267 | +
- if (is.null(variables$offset)) {
+ #' \insertRef{Yan2010-jt}{tern}
|
|||
| 401 | -! | +|||
| 268 | +
- glm_fit <- stats::glm(+ #' |
|||
| 402 | -! | +|||
| 269 | +
- formula = formula,+ #' @examples |
|||
| 403 | -! | +|||
| 270 | +
- data = .df_row,+ #' # Stratified Wilson confidence interval with unequal probabilities |
|||
| 404 | -! | +|||
| 271 | +
- family = stats::quasipoisson(link = "log")+ #' |
|||
| 405 | +272 |
- )+ #' set.seed(1) |
||
| 406 | +273 |
- } else {
+ #' rsp <- sample(c(TRUE, FALSE), 100, TRUE) |
||
| 407 | -5x | +|||
| 274 | +
- offset <- .df_row[[variables$offset]]+ #' strata_data <- data.frame( |
|||
| 408 | -3x | +|||
| 275 | +
- glm_fit <- stats::glm(+ #' "f1" = sample(c("a", "b"), 100, TRUE),
|
|||
| 409 | -3x | +|||
| 276 | +
- formula = formula,+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
|||
| 410 | -3x | +|||
| 277 | +
- offset = offset,+ #' stringsAsFactors = TRUE |
|||
| 411 | -3x | +|||
| 278 | +
- data = .df_row,+ #' ) |
|||
| 412 | -3x | +|||
| 279 | +
- family = stats::quasipoisson(link = "log")+ #' strata <- interaction(strata_data) |
|||
| 413 | +280 |
- )+ #' n_strata <- ncol(table(rsp, strata)) # Number of strata |
||
| 414 | +281 |
- }+ #' |
||
| 415 | -3x | +|||
| 282 | +
- emmeans_fit <- emmeans::emmeans(+ #' prop_strat_wilson( |
|||
| 416 | -3x | +|||
| 283 | +
- glm_fit,+ #' rsp = rsp, strata = strata, |
|||
| 417 | -3x | +|||
| 284 | +
- specs = arm,+ #' conf_level = 0.90 |
|||
| 418 | -3x | +|||
| 285 | +
- data = .df_row,+ #' ) |
|||
| 419 | -3x | +|||
| 286 | +
- type = "response",+ #' |
|||
| 420 | -3x | +|||
| 287 | +
- offset = 0,+ #' # Not automatic setting of weights |
|||
| 421 | -3x | +|||
| 288 | +
- weights = weights+ #' prop_strat_wilson( |
|||
| 422 | +289 |
- )+ #' rsp = rsp, strata = strata, |
||
| 423 | +290 |
-
+ #' weights = rep(1 / n_strata, n_strata), |
||
| 424 | -3x | +|||
| 291 | +
- list(+ #' conf_level = 0.90 |
|||
| 425 | -3x | +|||
| 292 | +
- glm_fit = glm_fit,+ #' ) |
|||
| 426 | -3x | +|||
| 293 | +
- emmeans_fit = emmeans_fit+ #' |
|||
| 427 | +294 |
- )+ #' @export |
||
| 428 | +295 |
- }+ prop_strat_wilson <- function(rsp, |
||
| 429 | +296 |
-
+ strata, |
||
| 430 | +297 |
- #' @describeIn h_glm_count Helper function to return results of a negative binomial model.+ weights = NULL, |
||
| 431 | +298 |
- #'+ conf_level = 0.95,+ |
+ ||
| 299 | ++ |
+ max_iterations = NULL,+ |
+ ||
| 300 | ++ |
+ correct = FALSE) {
|
||
| 432 | -+ | |||
| 301 | +20x |
- #' @return+ checkmate::assert_logical(rsp, any.missing = FALSE) |
||
| 433 | -+ | |||
| 302 | +20x |
- #' * `h_glm_negbin()` returns the results of a negative binomial model.+ checkmate::assert_factor(strata, len = length(rsp)) |
||
| 434 | -+ | |||
| 303 | +20x |
- #'+ assert_proportion_value(conf_level) |
||
| 435 | +304 |
- #' @keywords internal+ |
||
| 436 | -+ | |||
| 305 | +20x |
- h_glm_negbin <- function(.var,+ tbl <- table(rsp, strata) |
||
| 437 | -+ | |||
| 306 | +20x |
- .df_row,+ n_strata <- length(unique(strata)) |
||
| 438 | +307 |
- variables,+ |
||
| 439 | +308 |
- weights) {
+ # Checking the weights and maximum number of iterations. |
||
| 440 | -9x | +309 | +20x |
- arm <- variables$arm+ do_iter <- FALSE |
| 441 | -9x | +310 | +20x |
- covariates <- variables$covariates+ if (is.null(weights)) {
|
| 442 | -9x | +311 | +6x |
- formula <- stats::as.formula(paste0(+ weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure |
| 443 | -9x | +312 | +6x |
- .var, " ~ ",+ do_iter <- TRUE |
| 444 | +313 |
- " + ",- |
- ||
| 445 | -9x | -
- paste(covariates, collapse = " + "),+ |
||
| 446 | +314 |
- " + ",+ # Iteration parameters |
||
| 447 | -9x | +315 | +2x |
- arm+ if (is.null(max_iterations)) max_iterations <- 10 |
| 448 | -+ | |||
| 316 | +6x |
- ))+ checkmate::assert_int(max_iterations, na.ok = FALSE, null.ok = FALSE, lower = 1) |
||
| 449 | +317 |
-
+ } |
||
| 450 | -9x | +318 | +20x |
- if (is.null(variables$offset)) {
+ checkmate::assert_numeric(weights, lower = 0, upper = 1, any.missing = FALSE, len = n_strata) |
| 451 | -1x | +319 | +20x |
- formula <- stats::as.formula(paste0(+ sum_weights <- checkmate::assert_int(sum(weights)) |
| 452 | -1x | +|||
| 320 | +! |
- .var, " ~ ",+ if (as.integer(sum_weights + 0.5) != 1L) stop("Sum of weights must be 1L.")
|
||
| 453 | +321 |
- " + ",+ |
||
| 454 | -1x | +322 | +20x |
- paste(covariates, collapse = " + "),+ xs <- tbl["TRUE", ] |
| 455 | -+ | |||
| 323 | +20x |
- " + ",+ ns <- colSums(tbl) |
||
| 456 | -1x | +324 | +20x |
- arm+ use_stratum <- (ns > 0) |
| 457 | -+ | |||
| 325 | +20x |
- ))+ ns <- ns[use_stratum] |
||
| 458 | -+ | |||
| 326 | +20x |
- } else {
+ xs <- xs[use_stratum] |
||
| 459 | -8x | +327 | +20x |
- offset <- variables$offset+ ests <- xs / ns |
| 460 | -8x | +328 | +20x |
- formula_txt <- sprintf(+ vars <- ests * (1 - ests) / ns |
| 461 | -8x | +|||
| 329 | +
- "%s ~ %s + %s + offset(%s)",+ |
|||
| 462 | -8x | +330 | +20x |
- .var,+ strata_qnorm <- strata_normal_quantile(vars, weights, conf_level) |
| 463 | -8x | +|||
| 331 | +
- arm, paste0(covariates, collapse = " + "), offset+ |
|||
| 464 | +332 |
- )+ # Iterative setting of weights if they were not set externally |
||
| 465 | -8x | +333 | +20x |
- formula <- stats::as.formula(+ weights_new <- if (do_iter) {
|
| 466 | -8x | +334 | +6x |
- formula_txt+ update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max_iterations, conf_level)$weights |
| 467 | +335 |
- )+ } else {
+ |
+ ||
| 336 | +14x | +
+ weights |
||
| 468 | +337 |
} |
||
| 469 | +338 | |||
| 470 | -9x | +339 | +20x |
- glm_fit <- MASS::glm.nb(+ strata_conf_level <- 2 * stats::pnorm(strata_qnorm) - 1 |
| 471 | -9x | +|||
| 340 | +
- formula = formula,+ |
|||
| 472 | -9x | +341 | +20x |
- data = .df_row,+ ci_by_strata <- Map( |
| 473 | -9x | +342 | +20x |
- link = "log"+ function(x, n) {
|
| 474 | +343 |
- )+ # Classic Wilson's confidence interval+ |
+ ||
| 344 | +139x | +
+ suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf_level)$conf.int) |
||
| 475 | +345 |
-
+ }, |
||
| 476 | -7x | +346 | +20x |
- emmeans_fit <- emmeans::emmeans(+ x = xs, |
| 477 | -7x | +347 | +20x |
- glm_fit,+ n = ns |
| 478 | -7x | +|||
| 348 | +
- specs = arm,+ ) |
|||
| 479 | -7x | +349 | +20x |
- data = .df_row,+ lower_by_strata <- sapply(ci_by_strata, "[", 1L) |
| 480 | -7x | +350 | +20x |
- type = "response",+ upper_by_strata <- sapply(ci_by_strata, "[", 2L)+ |
+
| 351 | ++ | + | ||
| 481 | -7x | +352 | +20x |
- offset = 0,+ lower <- sum(weights_new * lower_by_strata) |
| 482 | -7x | +353 | +20x |
- weights = weights+ upper <- sum(weights_new * upper_by_strata) |
| 483 | +354 |
- )+ |
||
| 484 | +355 |
-
+ # Return values |
||
| 485 | -7x | +356 | +20x |
- list(+ if (do_iter) {
|
| 486 | -7x | +357 | +6x |
- glm_fit = glm_fit,+ list( |
| 487 | -7x | +358 | +6x |
- emmeans_fit = emmeans_fit+ conf_int = c( |
| 488 | -+ | |||
| 359 | +6x |
- )+ lower = lower, |
||
| 489 | -+ | |||
| 360 | +6x |
- }+ upper = upper |
||
| 490 | +361 |
-
+ ), |
||
| 491 | -+ | |||
| 362 | +6x |
- # h_ppmeans --------------------------------------------------------------------+ weights = weights_new |
||
| 492 | +363 |
- #' Function to return the estimated means using predicted probabilities+ ) |
||
| 493 | +364 |
- #'+ } else {
|
||
| 494 | -+ | |||
| 365 | +14x |
- #' @description+ list( |
||
| 495 | -+ | |||
| 366 | +14x |
- #' For each arm level, the predicted mean rate is calculated using the fitted model object, with `newdata`+ conf_int = c( |
||
| 496 | -+ | |||
| 367 | +14x |
- #' set to the result of `stats::model.frame`, a reconstructed data or the original data, depending on the+ lower = lower, |
||
| 497 | -+ | |||
| 368 | +14x |
- #' object formula (coming from the fit). The confidence interval is derived using the `conf_level` parameter.+ upper = upper |
||
| 498 | +369 |
- #'+ ) |
||
| 499 | +370 |
- #' @param obj (`glm.fit`)\cr fitted model object used to derive the mean rate estimates in each treatment arm.+ ) |
||
| 500 | +371 |
- #' @param .df_row (`data.frame`)\cr dataset that includes all the variables that are called in `.var` and `variables`.+ } |
||
| 501 | +372 |
- #' @param arm (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be+ } |
||
| 502 | +373 |
- #' summarized. Specifically, the first level of `arm` variable is taken as the reference group.+ |
||
| 503 | +374 |
- #' @param conf_level (`proportion`)\cr value used to derive the confidence interval for the rate.+ #' @describeIn h_proportions Calculates the Clopper-Pearson interval by calling [stats::binom.test()]. |
||
| 504 | +375 |
- #'+ #' Also referred to as the `exact` method. |
||
| 505 | +376 |
- #' @return+ #' |
||
| 506 | +377 |
- #' * `h_ppmeans()` returns the estimated means.+ #' @examples |
||
| 507 | +378 |
- #'+ #' prop_clopper_pearson(rsp, conf_level = .95) |
||
| 508 | +379 |
- #' @seealso [summarize_glm_count()].+ #' |
||
| 509 | +380 |
- #'+ #' @export |
||
| 510 | +381 |
- #' @export+ prop_clopper_pearson <- function(rsp, |
||
| 511 | +382 |
- h_ppmeans <- function(obj, .df_row, arm, conf_level) {
+ conf_level) {
|
||
| 512 | +383 | 1x |
- alpha <- 1 - conf_level+ y <- stats::binom.test( |
|
| 513 | +384 | 1x |
- p <- 1 - alpha / 2+ x = sum(rsp), |
|
| 514 | -+ | |||
| 385 | +1x |
-
+ n = length(rsp), |
||
| 515 | +386 | 1x |
- arm_levels <- levels(.df_row[[arm]])+ conf.level = conf_level |
|
| 516 | +387 |
-
+ ) |
||
| 517 | +388 | 1x |
- out <- lapply(arm_levels, function(lev) {
- |
- |
| 518 | -3x | -
- temp <- .df_row+ as.numeric(y$conf.int) |
||
| 519 | -3x | +|||
| 389 | +
- temp[[arm]] <- factor(lev, levels = arm_levels)+ } |
|||
| 520 | +390 | |||
| 521 | -3x | -
- mf <- stats::model.frame(obj$formula, data = temp)- |
- ||
| 522 | -3x | -
- X <- stats::model.matrix(obj$formula, data = mf) # nolint- |
- ||
| 523 | +391 |
-
+ #' @describeIn h_proportions Calculates the Wald interval by following the usual textbook definition |
||
| 524 | -3x | +|||
| 392 | +
- rate <- stats::predict(obj, newdata = mf, type = "response")+ #' for a single proportion confidence interval using the normal approximation. |
|||
| 525 | -3x | +|||
| 393 | +
- rate_hat <- mean(rate)+ #' |
|||
| 526 | +394 |
-
+ #' @param correct (`flag`)\cr whether to apply continuity correction. |
||
| 527 | -3x | +|||
| 395 | +
- zz <- colMeans(rate * X)+ #' |
|||
| 528 | -3x | +|||
| 396 | +
- se <- sqrt(as.numeric(t(zz) %*% stats::vcov(obj) %*% zz))+ #' @examples |
|||
| 529 | -3x | +|||
| 397 | +
- rate_lwr <- rate_hat * exp(-stats::qnorm(p) * se / rate_hat)+ #' prop_wald(rsp, conf_level = 0.95) |
|||
| 530 | -3x | +|||
| 398 | +
- rate_upr <- rate_hat * exp(stats::qnorm(p) * se / rate_hat)+ #' prop_wald(rsp, conf_level = 0.95, correct = TRUE) |
|||
| 531 | +399 |
-
+ #' |
||
| 532 | -3x | +|||
| 400 | +
- c(rate_hat, rate_lwr, rate_upr)+ #' @export |
|||
| 533 | +401 |
- })+ prop_wald <- function(rsp, conf_level, correct = FALSE) {
|
||
| 534 | -+ | |||
| 402 | +163x |
-
+ n <- length(rsp) |
||
| 535 | -1x | +403 | +163x |
- names(out) <- arm_levels+ p_hat <- mean(rsp) |
| 536 | -1x | +404 | +163x |
- out <- do.call(rbind, out)+ z <- stats::qnorm((1 + conf_level) / 2) |
| 537 | -1x | +405 | +163x |
- if ("negbin" %in% class(obj)) {
+ q_hat <- 1 - p_hat |
| 538 | -! | +|||
| 406 | +163x |
- colnames(out) <- c("response", "asymp.LCL", "asymp.UCL")
+ correct <- if (correct) 1 / (2 * n) else 0 |
||
| 539 | +407 |
- } else {
+
|
||
| 540 | -1x | +408 | +163x |
- colnames(out) <- c("rate", "asymp.LCL", "asymp.UCL")
+ err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correct |
| 541 | -+ | |||
| 409 | +163x |
- }+ l_ci <- max(0, p_hat - err) |
||
| 542 | -1x | +410 | +163x |
- out <- as.data.frame(out)+ u_ci <- min(1, p_hat + err) |
| 543 | -1x | +|||
| 411 | +
- out[[arm]] <- rownames(out)+ |
|||
| 544 | -1x | +412 | +163x |
- out+ c(l_ci, u_ci) |
| 545 | +413 |
} |
| 1 | +414 |
- #' Count patients by most extreme post-baseline toxicity grade per direction of abnormality+ |
||
| 2 | +415 |
- #'+ #' @describeIn h_proportions Calculates the Agresti-Coull interval. Constructed (for 95% CI) by adding two successes |
||
| 3 | +416 |
- #' @description `r lifecycle::badge("stable")`
+ #' and two failures to the data and then using the Wald formula to construct a CI. |
||
| 4 | +417 |
#' |
||
| 5 | +418 |
- #' The analyze function [count_abnormal_by_worst_grade()] creates a layout element to count patients by highest (worst)+ #' @examples |
||
| 6 | +419 |
- #' analysis toxicity grade post-baseline for each direction, categorized by parameter value.+ #' prop_agresti_coull(rsp, conf_level = 0.95) |
||
| 7 | +420 |
#' |
||
| 8 | +421 |
- #' This function analyzes primary analysis variable `var` which indicates toxicity grades. Additional+ #' @export |
||
| 9 | +422 |
- #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to+ prop_agresti_coull <- function(rsp, conf_level) {
|
||
| 10 | -+ | |||
| 423 | +3x |
- #' `USUBJID`), a variable to indicate unique subject identifiers, `param` (defaults to `PARAM`), a variable+ n <- length(rsp) |
||
| 11 | -+ | |||
| 424 | +3x |
- #' to indicate parameter values, and `grade_dir` (defaults to `GRADE_DIR`), a variable to indicate directions+ x_sum <- sum(rsp) |
||
| 12 | -+ | |||
| 425 | +3x |
- #' (e.g. High or Low) for each toxicity grade supplied in `var`.+ z <- stats::qnorm((1 + conf_level) / 2) |
||
| 13 | +426 |
- #'+ |
||
| 14 | +427 |
- #' For each combination of `param` and `grade_dir` levels, patient counts by worst+ # Add here both z^2 / 2 successes and failures. |
||
| 15 | -+ | |||
| 428 | +3x |
- #' grade are calculated as follows:+ x_sum_tilde <- x_sum + z^2 / 2 |
||
| 16 | -+ | |||
| 429 | +3x |
- #' * `1` to `4`: The number of patients with worst grades 1-4, respectively.+ n_tilde <- n + z^2 |
||
| 17 | +430 |
- #' * `Any`: The number of patients with at least one abnormality (i.e. grade is not 0).+ |
||
| 18 | +431 |
- #'+ # Then proceed as with the Wald interval. |
||
| 19 | -+ | |||
| 432 | +3x |
- #' Fractions are calculated by dividing the above counts by the number of patients with at least one+ p_tilde <- x_sum_tilde / n_tilde |
||
| 20 | -+ | |||
| 433 | +3x |
- #' valid measurement recorded during treatment.+ q_tilde <- 1 - p_tilde |
||
| 21 | -+ | |||
| 434 | +3x |
- #'+ err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde) |
||
| 22 | -+ | |||
| 435 | +3x |
- #' Pre-processing is crucial when using this function and can be done automatically using the+ l_ci <- max(0, p_tilde - err) |
||
| 23 | -+ | |||
| 436 | +3x |
- #' [h_adlb_abnormal_by_worst_grade()] helper function. See the description of this function for details on the+ u_ci <- min(1, p_tilde + err) |
||
| 24 | +437 |
- #' necessary pre-processing steps.+ |
||
| 25 | -+ | |||
| 438 | +3x |
- #'+ c(l_ci, u_ci) |
||
| 26 | +439 |
- #' Prior to using this function in your table layout you must use [rtables::split_rows_by()] to create two row+ } |
||
| 27 | +440 |
- #' splits, one on variable `param` and one on variable `grade_dir`.+ |
||
| 28 | +441 |
- #'+ #' @describeIn h_proportions Calculates the Jeffreys interval, an equal-tailed interval based on the |
||
| 29 | +442 |
- #' @inheritParams argument_convention+ #' non-informative Jeffreys prior for a binomial proportion. |
||
| 30 | +443 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' |
||
| 31 | +444 |
- #'+ #' @examples |
||
| 32 | +445 |
- #' Options are: ``r shQuote(get_stats("abnormal_by_worst_grade"))``
+ #' prop_jeffreys(rsp, conf_level = 0.95) |
||
| 33 | +446 |
#' |
||
| 34 | +447 |
- #' @seealso [h_adlb_abnormal_by_worst_grade()] which pre-processes ADLB data frames to be used in+ #' @export |
||
| 35 | +448 |
- #' [count_abnormal_by_worst_grade()].+ prop_jeffreys <- function(rsp, |
||
| 36 | +449 |
- #'+ conf_level) {
|
||
| 37 | -+ | |||
| 450 | +5x |
- #' @name abnormal_by_worst_grade+ n <- length(rsp) |
||
| 38 | -+ | |||
| 451 | +5x |
- #' @order 1+ x_sum <- sum(rsp) |
||
| 39 | +452 |
- NULL+ |
||
| 40 | -+ | |||
| 453 | +5x |
-
+ alpha <- 1 - conf_level |
||
| 41 | -+ | |||
| 454 | +5x |
- #' @describeIn abnormal_by_worst_grade Statistics function which counts patients by worst grade.+ l_ci <- ifelse( |
||
| 42 | -+ | |||
| 455 | +5x |
- #'+ x_sum == 0, |
||
| 43 | -+ | |||
| 456 | +5x |
- #' @return+ 0, |
||
| 44 | -+ | |||
| 457 | +5x |
- #' * `s_count_abnormal_by_worst_grade()` returns the single statistic `count_fraction` with grades 1 to 4 and+ stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5) |
||
| 45 | +458 |
- #' "Any" results.+ ) |
||
| 46 | +459 |
- #'+ |
||
| 47 | -+ | |||
| 460 | +5x |
- #' @keywords internal+ u_ci <- ifelse( |
||
| 48 | -+ | |||
| 461 | +5x |
- s_count_abnormal_by_worst_grade <- function(df, # nolint+ x_sum == n, |
||
| 49 | -+ | |||
| 462 | +5x |
- .var = "GRADE_ANL",+ 1, |
||
| 50 | -+ | |||
| 463 | +5x |
- .spl_context,+ stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5) |
||
| 51 | +464 |
- variables = list(+ ) |
||
| 52 | +465 |
- id = "USUBJID",+ + |
+ ||
| 466 | +5x | +
+ c(l_ci, u_ci) |
||
| 53 | +467 |
- param = "PARAM",+ } |
||
| 54 | +468 |
- grade_dir = "GRADE_DIR"+ |
||
| 55 | +469 |
- )) {
+ #' Description of the proportion summary |
||
| 56 | -1x | +|||
| 470 | +
- checkmate::assert_string(.var)+ #' |
|||
| 57 | -1x | +|||
| 471 | +
- assert_valid_factor(df[[.var]])+ #' @description `r lifecycle::badge("stable")`
|
|||
| 58 | -1x | +|||
| 472 | +
- assert_valid_factor(df[[variables$param]])+ #' |
|||
| 59 | -1x | +|||
| 473 | +
- assert_valid_factor(df[[variables$grade_dir]])+ #' This is a helper function that describes the analysis in [s_proportion()]. |
|||
| 60 | -1x | +|||
| 474 | +
- assert_df_with_variables(df, c(a = .var, variables))+ #' |
|||
| 61 | -1x | +|||
| 475 | +
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ #' @inheritParams s_proportion |
|||
| 62 | +476 |
-
+ #' @param long (`flag`)\cr whether a long or a short (default) description is required. |
||
| 63 | +477 |
- # To verify that the `split_rows_by` are performed with correct variables.+ #' |
||
| 64 | -1x | +|||
| 478 | +
- checkmate::assert_subset(c(variables[["param"]], variables[["grade_dir"]]), .spl_context$split)+ #' @return String describing the analysis. |
|||
| 65 | -1x | +|||
| 479 | +
- first_row <- .spl_context[.spl_context$split == variables[["param"]], ]+ #' |
|||
| 66 | -1x | +|||
| 480 | +
- x_lvls <- c(setdiff(levels(df[[.var]]), "0"), "Any")+ #' @export |
|||
| 67 | -1x | +|||
| 481 | +
- result <- split(numeric(0), factor(x_lvls))+ d_proportion <- function(conf_level, |
|||
| 68 | +482 |
-
+ method, |
||
| 69 | -1x | +|||
| 483 | +
- subj <- first_row$full_parent_df[[1]][[variables[["id"]]]]+ long = FALSE) {
|
|||
| 70 | -1x | +484 | +179x |
- subj_cur_col <- subj[first_row$cur_col_subset[[1]]]+ label <- paste0(conf_level * 100, "% CI") |
| 71 | +485 |
- # Some subjects may have a record for high and low directions but+ + |
+ ||
| 486 | +! | +
+ if (long) label <- paste(label, "for Response Rates") |
||
| 72 | +487 |
- # should be counted only once.+ |
||
| 73 | -1x | +488 | +179x |
- denom <- length(unique(subj_cur_col))+ method_part <- switch(method, |
| 74 | -+ | |||
| 489 | +179x |
-
+ "clopper-pearson" = "Clopper-Pearson", |
||
| 75 | -1x | +490 | +179x |
- for (lvl in x_lvls) {
+ "waldcc" = "Wald, with correction", |
| 76 | -5x | +491 | +179x |
- if (lvl != "Any") {
+ "wald" = "Wald, without correction", |
| 77 | -4x | +492 | +179x |
- df_lvl <- df[df[[.var]] == lvl, ]+ "wilson" = "Wilson, without correction", |
| 78 | -+ | |||
| 493 | +179x |
- } else {
+ "strat_wilson" = "Stratified Wilson, without correction", |
||
| 79 | -1x | +494 | +179x |
- df_lvl <- df[df[[.var]] != 0, ]+ "wilsonc" = "Wilson, with correction", |
| 80 | -+ | |||
| 495 | +179x |
- }+ "strat_wilsonc" = "Stratified Wilson, with correction", |
||
| 81 | -5x | +496 | +179x |
- num <- length(unique(df_lvl[[variables[["id"]]]]))+ "agresti-coull" = "Agresti-Coull", |
| 82 | -5x | +497 | +179x |
- fraction <- ifelse(denom == 0, 0, num / denom)+ "jeffreys" = "Jeffreys", |
| 83 | -5x | +498 | +179x |
- result[[lvl]] <- formatters::with_label(c(count = num, fraction = fraction), lvl)+ stop(paste(method, "does not have a description")) |
| 84 | +499 |
- }+ ) |
||
| 85 | +500 | |||
| 86 | -1x | -
- result <- list(count_fraction = result)- |
- ||
| 87 | -1x | +501 | +179x |
- result+ paste0(label, " (", method_part, ")")
|
| 88 | +502 |
} |
||
| 89 | +503 | |||
| 90 | +504 |
- #' @describeIn abnormal_by_worst_grade Formatted analysis function which is used as `afun`+ #' Helper function for the estimation of stratified quantiles |
||
| 91 | +505 |
- #' in `count_abnormal_by_worst_grade()`.+ #' |
||
| 92 | +506 |
- #'+ #' @description `r lifecycle::badge("stable")`
|
||
| 93 | +507 |
- #' @return+ #' |
||
| 94 | +508 |
- #' * `a_count_abnormal_by_worst_grade()` returns the corresponding list with formatted [rtables::CellValue()].+ #' This function wraps the estimation of stratified percentiles when we assume |
||
| 95 | +509 |
- #'+ #' the approximation for large numbers. This is necessary only in the case |
||
| 96 | +510 |
- #' @keywords internal+ #' proportions for each strata are unequal. |
||
| 97 | +511 |
- a_count_abnormal_by_worst_grade <- make_afun( # nolint+ #' |
||
| 98 | +512 |
- s_count_abnormal_by_worst_grade,+ #' @inheritParams argument_convention |
||
| 99 | +513 |
- .formats = c(count_fraction = format_count_fraction)+ #' @inheritParams prop_strat_wilson |
||
| 100 | +514 |
- )+ #' |
||
| 101 | +515 |
-
+ #' @return Stratified quantile. |
||
| 102 | +516 |
- #' @describeIn abnormal_by_worst_grade Layout-creating function which can take statistics function arguments+ #' |
||
| 103 | +517 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' @seealso [prop_strat_wilson()] |
||
| 104 | +518 |
#' |
||
| 105 | +519 |
- #' @return+ #' @examples |
||
| 106 | +520 |
- #' * `count_abnormal_by_worst_grade()` returns a layout object suitable for passing to further layouting functions,+ #' strata_data <- table(data.frame( |
||
| 107 | +521 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' "f1" = sample(c(TRUE, FALSE), 100, TRUE), |
||
| 108 | +522 |
- #' the statistics from `s_count_abnormal_by_worst_grade()` to the table layout.+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
||
| 109 | +523 |
- #'+ #' stringsAsFactors = TRUE |
||
| 110 | +524 |
- #' @examples+ #' )) |
||
| 111 | +525 |
- #' library(dplyr)+ #' ns <- colSums(strata_data) |
||
| 112 | +526 |
- #' library(forcats)+ #' ests <- strata_data["TRUE", ] / ns |
||
| 113 | +527 |
- #' adlb <- tern_ex_adlb+ #' vars <- ests * (1 - ests) / ns |
||
| 114 | +528 |
- #'+ #' weights <- rep(1 / length(ns), length(ns)) |
||
| 115 | +529 |
- #' # Data is modified in order to have some parameters with grades only in one direction+ #' |
||
| 116 | +530 |
- #' # and simulate the real data.+ #' strata_normal_quantile(vars, weights, 0.95) |
||
| 117 | +531 |
- #' adlb$ATOXGR[adlb$PARAMCD == "ALT" & adlb$ATOXGR %in% c("1", "2", "3", "4")] <- "-1"
+ #' |
||
| 118 | +532 |
- #' adlb$ANRIND[adlb$PARAMCD == "ALT" & adlb$ANRIND == "HIGH"] <- "LOW"+ #' @export |
||
| 119 | +533 |
- #' adlb$WGRHIFL[adlb$PARAMCD == "ALT"] <- ""+ strata_normal_quantile <- function(vars, weights, conf_level) {
|
||
| 120 | -+ | |||
| 534 | +43x |
- #'+ summands <- weights^2 * vars |
||
| 121 | +535 |
- #' adlb$ATOXGR[adlb$PARAMCD == "IGA" & adlb$ATOXGR %in% c("-1", "-2", "-3", "-4")] <- "1"
+ # Stratified quantile+ |
+ ||
| 536 | +43x | +
+ sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf_level) / 2) |
||
| 122 | +537 |
- #' adlb$ANRIND[adlb$PARAMCD == "IGA" & adlb$ANRIND == "LOW"] <- "HIGH"+ } |
||
| 123 | +538 |
- #' adlb$WGRLOFL[adlb$PARAMCD == "IGA"] <- ""+ |
||
| 124 | +539 |
- #'+ #' Helper function for the estimation of weights for `prop_strat_wilson()` |
||
| 125 | +540 |
- #' # Pre-processing+ #' |
||
| 126 | +541 |
- #' adlb_f <- adlb %>% h_adlb_abnormal_by_worst_grade()+ #' @description `r lifecycle::badge("stable")`
|
||
| 127 | +542 |
#' |
||
| 128 | +543 |
- #' # Map excludes records without abnormal grade since they should not be displayed+ #' This function wraps the iteration procedure that allows you to estimate |
||
| 129 | +544 |
- #' # in the table.+ #' the weights for each proportional strata. This assumes to minimize the |
||
| 130 | +545 |
- #' map <- unique(adlb_f[adlb_f$GRADE_DIR != "ZERO", c("PARAM", "GRADE_DIR", "GRADE_ANL")]) %>%
+ #' weighted squared length of the confidence interval. |
||
| 131 | +546 |
- #' lapply(as.character) %>%+ #' |
||
| 132 | +547 |
- #' as.data.frame() %>%+ #' @inheritParams prop_strat_wilson |
||
| 133 | +548 |
- #' arrange(PARAM, desc(GRADE_DIR), GRADE_ANL)+ #' @param vars (`numeric`)\cr normalized proportions for each strata. |
||
| 134 | +549 |
- #'+ #' @param strata_qnorm (`numeric(1)`)\cr initial estimation with identical weights of the quantiles. |
||
| 135 | +550 |
- #' basic_table() %>%+ #' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can |
||
| 136 | +551 |
- #' split_cols_by("ARMCD") %>%
+ #' be optimized in the future if we need to estimate better initial weights. |
||
| 137 | +552 |
- #' split_rows_by("PARAM") %>%
+ #' @param n_per_strata (`numeric`)\cr number of elements in each strata. |
||
| 138 | +553 |
- #' split_rows_by("GRADE_DIR", split_fun = trim_levels_to_map(map)) %>%
+ #' @param max_iterations (`integer(1)`)\cr maximum number of iterations to be tried. Convergence is always checked. |
||
| 139 | +554 |
- #' count_abnormal_by_worst_grade(+ #' @param tol (`numeric(1)`)\cr tolerance threshold for convergence. |
||
| 140 | +555 |
- #' var = "GRADE_ANL",+ #' |
||
| 141 | +556 |
- #' variables = list(id = "USUBJID", param = "PARAM", grade_dir = "GRADE_DIR")+ #' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`. |
||
| 142 | +557 |
- #' ) %>%+ #' |
||
| 143 | +558 |
- #' build_table(df = adlb_f)+ #' @seealso For references and details see [prop_strat_wilson()]. |
||
| 144 | +559 |
#' |
||
| 145 | +560 |
- #' @export+ #' @examples |
||
| 146 | +561 |
- #' @order 2+ #' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018) |
||
| 147 | +562 |
- count_abnormal_by_worst_grade <- function(lyt,+ #' sq <- 0.674 |
||
| 148 | +563 |
- var,+ #' ws <- rep(1 / length(vs), length(vs)) |
||
| 149 | +564 |
- variables = list(+ #' ns <- c(22, 18, 17, 17, 14, 12) |
||
| 150 | +565 |
- id = "USUBJID",+ #' |
||
| 151 | +566 |
- param = "PARAM",+ #' update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001) |
||
| 152 | +567 |
- grade_dir = "GRADE_DIR"+ #' |
||
| 153 | +568 |
- ),+ #' @export |
||
| 154 | +569 |
- na_str = default_na_str(),+ update_weights_strat_wilson <- function(vars, |
||
| 155 | +570 |
- nested = TRUE,+ strata_qnorm, |
||
| 156 | +571 |
- ...,+ initial_weights, |
||
| 157 | +572 |
- .stats = NULL,+ n_per_strata, |
||
| 158 | +573 |
- .formats = NULL,+ max_iterations = 50, |
||
| 159 | +574 |
- .labels = NULL,+ conf_level = 0.95, |
||
| 160 | +575 |
- .indent_mods = NULL) {
+ tol = 0.001) {
|
||
| 161 | -2x | +576 | +9x |
- extra_args <- list(variables = variables, ...)+ it <- 0+ |
+
| 577 | +9x | +
+ diff_v <- NULL |
||
| 162 | +578 | |||
| 163 | -2x | +579 | +9x |
- afun <- make_afun(+ while (it < max_iterations) {
|
| 164 | -2x | +580 | +21x |
- a_count_abnormal_by_worst_grade,+ it <- it + 1 |
| 165 | -2x | +581 | +21x |
- .stats = .stats,+ weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2 |
| 166 | -2x | +582 | +21x |
- .formats = .formats,+ weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2)) |
| 167 | -2x | +583 | +21x |
- .labels = .labels,+ weights_new <- weights_new_t / weights_new_b |
| 168 | -2x | +584 | +21x |
- .indent_mods = .indent_mods,+ weights_new <- weights_new / sum(weights_new) |
| 169 | -2x | +585 | +21x |
- .ungroup_stats = "count_fraction"+ strata_qnorm <- strata_normal_quantile(vars, weights_new, conf_level) |
| 170 | -+ | |||
| 586 | +21x |
- )+ diff_v <- c(diff_v, sum(abs(weights_new - initial_weights))) |
||
| 171 | -2x | +587 | +8x |
- analyze(+ if (diff_v[length(diff_v)] < tol) break |
| 172 | -2x | +588 | +13x |
- lyt = lyt,+ initial_weights <- weights_new |
| 173 | -2x | +|||
| 589 | +
- vars = var,+ }+ |
+ |||
| 590 | ++ | + | ||
| 174 | -2x | +591 | +9x |
- afun = afun,+ if (it == max_iterations) {
|
| 175 | -2x | +592 | +1x |
- na_str = na_str,+ warning("The heuristic to find weights did not converge with max_iterations = ", max_iterations)
+ |
+
| 593 | ++ |
+ }+ |
+ ||
| 594 | ++ | + | ||
| 176 | -2x | +595 | +9x |
- nested = nested,+ list( |
| 177 | -2x | +596 | +9x |
- extra_args = extra_args,+ "n_it" = it, |
| 178 | -2x | +597 | +9x |
- show_labels = "hidden"+ "weights" = weights_new, |
| 179 | -+ | |||
| 598 | +9x |
- )+ "diff_v" = diff_v |
||
| 180 | +599 |
- }+ ) |
||
| 181 | +600 |
-
+ } |
| 182 | +1 |
- #' Helper function to prepare ADLB for `count_abnormal_by_worst_grade()`+ #' Count patients with abnormal range values |
||
| 183 | +2 |
#' |
||
| 184 | +3 |
#' @description `r lifecycle::badge("stable")`
|
||
| 185 | +4 |
#' |
||
| 186 | +5 |
- #' Helper function to prepare an ADLB data frame to be used as input in+ #' The analyze function [count_abnormal()] creates a layout element to count patients with abnormal analysis range |
||
| 187 | +6 |
- #' [count_abnormal_by_worst_grade()]. The following pre-processing steps are applied:+ #' values in each direction. |
||
| 188 | +7 |
#' |
||
| 189 | +8 |
- #' 1. `adlb` is filtered on variable `avisit` to only include post-baseline visits.+ #' This function analyzes primary analysis variable `var` which indicates abnormal range results. |
||
| 190 | +9 |
- #' 2. `adlb` is filtered on variables `worst_flag_low` and `worst_flag_high` so that only+ #' Additional analysis variables that can be supplied as a list via the `variables` parameter are |
||
| 191 | +10 |
- #' worst grades (in either direction) are included.+ #' `id` (defaults to `USUBJID`), a variable to indicate unique subject identifiers, and `baseline` |
||
| 192 | +11 |
- #' 3. From the standard lab grade variable `atoxgr`, the following two variables are derived+ #' (defaults to `BNRIND`), a variable to indicate baseline reference ranges. |
||
| 193 | +12 |
- #' and added to `adlb`:+ #' |
||
| 194 | +13 |
- #' * A grade direction variable (e.g. `GRADE_DIR`). The variable takes value `"HIGH"` when+ #' For each direction specified via the `abnormal` parameter (e.g. High or Low), a fraction of |
||
| 195 | +14 |
- #' `atoxgr > 0`, `"LOW"` when `atoxgr < 0`, and `"ZERO"` otherwise.+ #' patient counts is returned, with numerator and denominator calculated as follows: |
||
| 196 | +15 |
- #' * A toxicity grade variable (e.g. `GRADE_ANL`) where all negative values from `atoxgr` are+ #' * `num`: The number of patients with this abnormality recorded while on treatment. |
||
| 197 | +16 |
- #' replaced by their absolute values.+ #' * `denom`: The total number of patients with at least one post-baseline assessment. |
||
| 198 | +17 |
- #' 4. Unused factor levels are dropped from `adlb` via [droplevels()].+ #' |
||
| 199 | +18 |
- #'+ #' This function assumes that `df` has been filtered to only include post-baseline records. |
||
| 200 | +19 |
- #' @param adlb (`data.frame`)\cr ADLB data frame.+ #' |
||
| 201 | +20 |
- #' @param atoxgr (`string`)\cr name of the analysis toxicity grade variable. This must be a `factor`+ #' @inheritParams argument_convention |
||
| 202 | +21 |
- #' variable.+ #' @param abnormal (named `list`)\cr list identifying the abnormal range level(s) in `var`. Defaults to |
||
| 203 | +22 |
- #' @param avisit (`string`)\cr name of the analysis visit variable.+ #' `list(Low = "LOW", High = "HIGH")` but you can also group different levels into the named list, |
||
| 204 | +23 |
- #' @param worst_flag_low (`string`)\cr name of the worst low lab grade flag variable. This variable is+ #' for example, `abnormal = list(Low = c("LOW", "LOW LOW"), High = c("HIGH", "HIGH HIGH"))`.
|
||
| 205 | +24 |
- #' set to `"Y"` when indicating records of worst low lab grades.+ #' @param exclude_base_abn (`flag`)\cr whether to exclude subjects with baseline abnormality |
||
| 206 | +25 |
- #' @param worst_flag_high (`string`)\cr name of the worst high lab grade flag variable. This variable is+ #' from numerator and denominator. |
||
| 207 | +26 |
- #' set to `"Y"` when indicating records of worst high lab grades.+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 208 | +27 |
#' |
||
| 209 | +28 |
- #' @return `h_adlb_abnormal_by_worst_grade()` returns the `adlb` data frame with two new+ #' Options are: ``r shQuote(get_stats("abnormal"), type = "sh")``
|
||
| 210 | +29 |
- #' variables: `GRADE_DIR` and `GRADE_ANL`.+ #' |
||
| 211 | +30 |
- #'+ #' @note |
||
| 212 | +31 |
- #' @seealso [abnormal_by_worst_grade]+ #' * `count_abnormal()` only considers a single variable that contains multiple abnormal levels. |
||
| 213 | +32 |
- #'+ #' * `df` should be filtered to only include post-baseline records. |
||
| 214 | +33 |
- #' @examples+ #' * The denominator includes patients that may have other abnormal levels at baseline, |
||
| 215 | +34 |
- #' h_adlb_abnormal_by_worst_grade(tern_ex_adlb) %>%+ #' and patients missing baseline records. Patients with these abnormalities at |
||
| 216 | +35 |
- #' dplyr::select(ATOXGR, GRADE_DIR, GRADE_ANL) %>%+ #' baseline can be optionally excluded from numerator and denominator via the |
||
| 217 | +36 |
- #' head(10)+ #' `exclude_base_abn` parameter. |
||
| 218 | +37 |
#' |
||
| 219 | +38 |
- #' @export+ #' @name abnormal |
||
| 220 | +39 |
- h_adlb_abnormal_by_worst_grade <- function(adlb,+ #' @include formatting_functions.R |
||
| 221 | +40 |
- atoxgr = "ATOXGR",+ #' @order 1 |
||
| 222 | +41 |
- avisit = "AVISIT",+ NULL |
||
| 223 | +42 |
- worst_flag_low = "WGRLOFL",+ |
||
| 224 | +43 |
- worst_flag_high = "WGRHIFL") {
+ #' @describeIn abnormal Statistics function which counts patients with abnormal range values |
||
| 225 | -1x | +|||
| 44 | +
- adlb %>%+ #' for a single `abnormal` level. |
|||
| 226 | -1x | +|||
| 45 | +
- dplyr::filter(+ #' |
|||
| 227 | -1x | +|||
| 46 | +
- !.data[[avisit]] %in% c("SCREENING", "BASELINE"),
+ #' @return |
|||
| 228 | -1x | +|||
| 47 | +
- .data[[worst_flag_low]] == "Y" | .data[[worst_flag_high]] == "Y"+ #' * `s_count_abnormal()` returns the statistic `fraction` which is a vector with `num` and `denom` counts of patients. |
|||
| 229 | +48 |
- ) %>%+ #' |
||
| 230 | -1x | +|||
| 49 | +
- dplyr::mutate(+ #' @keywords internal |
|||
| 231 | -1x | +|||
| 50 | +
- GRADE_DIR = factor(+ s_count_abnormal <- function(df, |
|||
| 232 | -1x | +|||
| 51 | +
- dplyr::case_when(+ .var, |
|||
| 233 | -1x | +|||
| 52 | +
- .data[[atoxgr]] %in% c("-1", "-2", "-3", "-4") ~ "LOW",
+ abnormal = list(Low = "LOW", High = "HIGH"), |
|||
| 234 | -1x | +|||
| 53 | +
- .data[[atoxgr]] == "0" ~ "ZERO",+ variables = list(id = "USUBJID", baseline = "BNRIND"), |
|||
| 235 | -1x | +|||
| 54 | +
- .data[[atoxgr]] %in% c("1", "2", "3", "4") ~ "HIGH"
+ exclude_base_abn = FALSE) {
|
|||
| 236 | -+ | |||
| 55 | +4x |
- ),+ checkmate::assert_list(abnormal, types = "character", names = "named", len = 2, any.missing = FALSE) |
||
| 237 | -1x | +56 | +4x |
- levels = c("LOW", "ZERO", "HIGH")
+ checkmate::assert_true(any(unlist(abnormal) %in% levels(df[[.var]]))) |
| 238 | -+ | |||
| 57 | +4x |
- ),+ checkmate::assert_factor(df[[.var]]) |
||
| 239 | -1x | +58 | +4x |
- GRADE_ANL = forcats::fct_relevel(+ checkmate::assert_flag(exclude_base_abn) |
| 240 | -1x | +59 | +4x |
- forcats::fct_recode(.data[[atoxgr]], `1` = "-1", `2` = "-2", `3` = "-3", `4` = "-4"),+ assert_df_with_variables(df, c(range = .var, variables)) |
| 241 | -1x | +60 | +4x |
- c("0", "1", "2", "3", "4")
+ checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
|
| 242 | -+ | |||
| 61 | +4x |
- )+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
||
| 243 | +62 |
- ) %>%+ |
||
| 244 | -1x | +63 | +4x |
- droplevels()+ count_abnormal_single <- function(abn_name, abn) {
|
| 245 | +64 |
- }+ # Patients in the denominator fulfill: |
| 1 | +65 |
- #' Proportion estimation+ # - have at least one post-baseline visit |
||
| 2 | +66 |
- #'+ # - their baseline must not be abnormal if `exclude_base_abn`. |
||
| 3 | -+ | |||
| 67 | +8x |
- #' @description `r lifecycle::badge("stable")`
+ if (exclude_base_abn) {
|
||
| 4 | -+ | |||
| 68 | +4x |
- #'+ denom_select <- !(df[[variables$baseline]] %in% abn) |
||
| 5 | +69 |
- #' The analyze function [estimate_proportion()] creates a layout element to estimate the proportion of responders+ } else {
|
||
| 6 | -+ | |||
| 70 | +4x |
- #' within a studied population. The primary analysis variable, `vars`, indicates whether a response has occurred for+ denom_select <- TRUE |
||
| 7 | +71 |
- #' each record. See the `method` parameter for options of methods to use when constructing the confidence interval of+ } |
||
| 8 | -+ | |||
| 72 | +8x |
- #' the proportion. Additionally, a stratification variable can be supplied via the `strata` element of the `variables`+ denom <- length(unique(df[denom_select, variables$id, drop = TRUE])) |
||
| 9 | +73 |
- #' argument.+ |
||
| 10 | +74 |
- #'+ # Patients in the numerator fulfill: |
||
| 11 | +75 |
- #' @inheritParams prop_strat_wilson+ # - have at least one post-baseline visit with the required abnormality level |
||
| 12 | +76 |
- #' @inheritParams argument_convention+ # - are part of the denominator patients. |
||
| 13 | -+ | |||
| 77 | +8x |
- #' @param method (`string`)\cr the method used to construct the confidence interval+ num_select <- (df[[.var]] %in% abn) & denom_select+ |
+ ||
| 78 | +8x | +
+ num <- length(unique(df[num_select, variables$id, drop = TRUE])) |
||
| 14 | +79 |
- #' for proportion of successful outcomes; one of `waldcc`, `wald`, `clopper-pearson`,+ |
||
| 15 | -+ | |||
| 80 | +8x |
- #' `wilson`, `wilsonc`, `strat_wilson`, `strat_wilsonc`, `agresti-coull` or `jeffreys`.+ formatters::with_label(c(num = num, denom = denom), abn_name) |
||
| 16 | +81 |
- #' @param long (`flag`)\cr whether a long description is required.+ } |
||
| 17 | +82 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ |
||
| 18 | +83 |
- #'+ # This will define the abnormal levels theoretically possible for a specific lab parameter |
||
| 19 | +84 |
- #' Options are: ``r shQuote(get_stats("estimate_proportion"))``
+ # within a split level of a layout. |
||
| 20 | -+ | |||
| 85 | +4x |
- #'+ abnormal_lev <- lapply(abnormal, intersect, levels(df[[.var]])) |
||
| 21 | -+ | |||
| 86 | +4x |
- #' @seealso [h_proportions]+ abnormal_lev <- abnormal_lev[vapply(abnormal_lev, function(x) length(x) > 0, logical(1))] |
||
| 22 | +87 |
- #'+ |
||
| 23 | -+ | |||
| 88 | +4x |
- #' @name estimate_proportion+ result <- sapply(names(abnormal_lev), function(i) count_abnormal_single(i, abnormal_lev[[i]]), simplify = FALSE) |
||
| 24 | -+ | |||
| 89 | +4x |
- #' @order 1+ result <- list(fraction = result)+ |
+ ||
| 90 | +4x | +
+ result |
||
| 25 | +91 |
- NULL+ } |
||
| 26 | +92 | |||
| 27 | +93 |
- #' @describeIn estimate_proportion Statistics function estimating a+ #' @describeIn abnormal Formatted analysis function which is used as `afun` in `count_abnormal()`. |
||
| 28 | +94 |
- #' proportion along with its confidence interval.+ #' |
||
| 29 | +95 |
- #'+ #' @return |
||
| 30 | +96 |
- #' @param df (`logical` or `data.frame`)\cr if only a logical vector is used,+ #' * `a_count_abnormal()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 31 | +97 |
- #' it indicates whether each subject is a responder or not. `TRUE` represents+ #' |
||
| 32 | +98 |
- #' a successful outcome. If a `data.frame` is provided, also the `strata` variable+ #' @keywords internal |
||
| 33 | +99 |
- #' names must be provided in `variables` as a list element with the strata strings.+ a_count_abnormal <- make_afun( |
||
| 34 | +100 |
- #' In the case of `data.frame`, the logical vector of responses must be indicated as a+ s_count_abnormal, |
||
| 35 | +101 |
- #' variable name in `.var`.+ .formats = c(fraction = format_fraction) |
||
| 36 | +102 |
- #'+ ) |
||
| 37 | +103 |
- #' @return+ |
||
| 38 | +104 |
- #' * `s_proportion()` returns statistics `n_prop` (`n` and proportion) and `prop_ci` (proportion CI) for a+ #' @describeIn abnormal Layout-creating function which can take statistics function arguments |
||
| 39 | +105 |
- #' given variable.+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 40 | +106 |
#' |
||
| 41 | +107 |
- #' @examples+ #' @return |
||
| 42 | +108 |
- #' # Case with only logical vector.+ #' * `count_abnormal()` returns a layout object suitable for passing to further layouting functions, |
||
| 43 | +109 |
- #' rsp_v <- c(1, 0, 1, 0, 1, 1, 0, 0)+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 44 | +110 |
- #' s_proportion(rsp_v)+ #' the statistics from `s_count_abnormal()` to the table layout. |
||
| 45 | +111 |
#' |
||
| 46 | +112 |
- #' # Example for Stratified Wilson CI+ #' @examples |
||
| 47 | +113 |
- #' nex <- 100 # Number of example rows+ #' library(dplyr) |
||
| 48 | +114 |
- #' dta <- data.frame(+ #' |
||
| 49 | +115 |
- #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE),+ #' df <- data.frame( |
||
| 50 | +116 |
- #' "grp" = sample(c("A", "B"), nex, TRUE),
+ #' USUBJID = as.character(c(1, 1, 2, 2)), |
||
| 51 | +117 |
- #' "f1" = sample(c("a1", "a2"), nex, TRUE),
+ #' ANRIND = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
|
||
| 52 | +118 |
- #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
+ #' BNRIND = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
|
||
| 53 | +119 |
- #' stringsAsFactors = TRUE+ #' ONTRTFL = c("", "Y", "", "Y"),
|
||
| 54 | +120 |
- #' )+ #' stringsAsFactors = FALSE |
||
| 55 | +121 |
- #'+ #' ) |
||
| 56 | +122 |
- #' s_proportion(+ #' |
||
| 57 | +123 |
- #' df = dta,+ #' # Select only post-baseline records. |
||
| 58 | +124 |
- #' .var = "rsp",+ #' df <- df %>% |
||
| 59 | +125 |
- #' variables = list(strata = c("f1", "f2")),
+ #' filter(ONTRTFL == "Y") |
||
| 60 | +126 |
- #' conf_level = 0.90,+ #' |
||
| 61 | +127 |
- #' method = "strat_wilson"+ #' # Layout creating function. |
||
| 62 | +128 |
- #' )+ #' basic_table() %>% |
||
| 63 | +129 |
- #'+ #' count_abnormal(var = "ANRIND", abnormal = list(high = "HIGH", low = "LOW")) %>% |
||
| 64 | +130 |
- #' @export+ #' build_table(df) |
||
| 65 | +131 |
- s_proportion <- function(df,+ #' |
||
| 66 | +132 |
- .var,+ #' # Passing of statistics function and formatting arguments. |
||
| 67 | +133 |
- conf_level = 0.95,+ #' df2 <- data.frame( |
||
| 68 | +134 |
- method = c(+ #' ID = as.character(c(1, 1, 2, 2)), |
||
| 69 | +135 |
- "waldcc", "wald", "clopper-pearson",+ #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
|
||
| 70 | +136 |
- "wilson", "wilsonc", "strat_wilson", "strat_wilsonc",+ #' BL_RANGE = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
|
||
| 71 | +137 |
- "agresti-coull", "jeffreys"+ #' ONTRTFL = c("", "Y", "", "Y"),
|
||
| 72 | +138 |
- ),+ #' stringsAsFactors = FALSE |
||
| 73 | +139 |
- weights = NULL,+ #' ) |
||
| 74 | +140 |
- max_iterations = 50,+ #' |
||
| 75 | +141 |
- variables = list(strata = NULL),+ #' # Select only post-baseline records. |
||
| 76 | +142 |
- long = FALSE) {
+ #' df2 <- df2 %>% |
||
| 77 | -167x | +|||
| 143 | +
- method <- match.arg(method)+ #' filter(ONTRTFL == "Y") |
|||
| 78 | -167x | +|||
| 144 | +
- checkmate::assert_flag(long)+ #' |
|||
| 79 | -167x | +|||
| 145 | +
- assert_proportion_value(conf_level)+ #' basic_table() %>% |
|||
| 80 | +146 |
-
+ #' count_abnormal( |
||
| 81 | -167x | +|||
| 147 | +
- if (!is.null(variables$strata)) {
+ #' var = "RANGE", |
|||
| 82 | +148 |
- # Checks for strata+ #' abnormal = list(low = "LOW", high = "HIGH"), |
||
| 83 | -! | +|||
| 149 | +
- if (missing(df)) stop("When doing stratified analysis a data.frame with specific columns is needed.")
+ #' variables = list(id = "ID", baseline = "BL_RANGE") |
|||
| 84 | -! | +|||
| 150 | +
- strata_colnames <- variables$strata+ #' ) %>% |
|||
| 85 | -! | +|||
| 151 | +
- checkmate::assert_character(strata_colnames, null.ok = FALSE)+ #' build_table(df2) |
|||
| 86 | -! | +|||
| 152 | +
- strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)+ #' |
|||
| 87 | -! | +|||
| 153 | +
- assert_df_with_variables(df, strata_vars)+ #' @export |
|||
| 88 | +154 |
-
+ #' @order 2 |
||
| 89 | -! | +|||
| 155 | +
- strata <- interaction(df[strata_colnames])+ count_abnormal <- function(lyt, |
|||
| 90 | -! | +|||
| 156 | +
- strata <- as.factor(strata)+ var, |
|||
| 91 | +157 |
-
+ abnormal = list(Low = "LOW", High = "HIGH"), |
||
| 92 | +158 |
- # Pushing down checks to prop_strat_wilson+ variables = list(id = "USUBJID", baseline = "BNRIND"), |
||
| 93 | -167x | +|||
| 159 | +
- } else if (checkmate::test_subset(method, c("strat_wilson", "strat_wilsonc"))) {
+ exclude_base_abn = FALSE, |
|||
| 94 | -! | +|||
| 160 | +
- stop("To use stratified methods you need to specify the strata variables.")
+ na_str = default_na_str(), |
|||
| 95 | +161 |
- }+ nested = TRUE, |
||
| 96 | -167x | +|||
| 162 | +
- if (checkmate::test_atomic_vector(df)) {
+ ..., |
|||
| 97 | -167x | +|||
| 163 | +
- rsp <- as.logical(df)+ table_names = var, |
|||
| 98 | +164 |
- } else {
+ .stats = NULL, |
||
| 99 | -! | +|||
| 165 | +
- rsp <- as.logical(df[[.var]])+ .formats = NULL, |
|||
| 100 | +166 |
- }+ .labels = NULL, |
||
| 101 | -167x | +|||
| 167 | +
- n <- sum(rsp)+ .indent_mods = NULL) {
|
|||
| 102 | -167x | +168 | +3x |
- p_hat <- mean(rsp)+ extra_args <- list(abnormal = abnormal, variables = variables, exclude_base_abn = exclude_base_abn, ...) |
| 103 | +169 | |||
| 104 | -167x | +170 | +3x |
- prop_ci <- switch(method,+ afun <- make_afun( |
| 105 | -167x | +171 | +3x |
- "clopper-pearson" = prop_clopper_pearson(rsp, conf_level),+ a_count_abnormal, |
| 106 | -167x | +172 | +3x |
- "wilson" = prop_wilson(rsp, conf_level),+ .stats = .stats, |
| 107 | -167x | +173 | +3x |
- "wilsonc" = prop_wilson(rsp, conf_level, correct = TRUE),+ .formats = .formats, |
| 108 | -167x | +174 | +3x |
- "strat_wilson" = prop_strat_wilson(rsp,+ .labels = .labels, |
| 109 | -167x | +175 | +3x |
- strata,+ .indent_mods = .indent_mods, |
| 110 | -167x | +176 | +3x |
- weights,+ .ungroup_stats = "fraction" |
| 111 | -167x | +|||
| 177 | +
- conf_level,+ ) |
|||
| 112 | -167x | +|||
| 178 | +
- max_iterations,+ |
|||
| 113 | -167x | +179 | +3x |
- correct = FALSE+ checkmate::assert_string(var) |
| 114 | -167x | +|||
| 180 | +
- )$conf_int,+ |
|||
| 115 | -167x | +181 | +3x |
- "strat_wilsonc" = prop_strat_wilson(rsp,+ analyze( |
| 116 | -167x | +182 | +3x |
- strata,+ lyt = lyt, |
| 117 | -167x | +183 | +3x |
- weights,+ vars = var, |
| 118 | -167x | +184 | +3x |
- conf_level,+ afun = afun, |
| 119 | -167x | +185 | +3x |
- max_iterations,+ na_str = na_str, |
| 120 | -167x | +186 | +3x |
- correct = TRUE+ nested = nested, |
| 121 | -167x | +187 | +3x |
- )$conf_int,+ table_names = table_names, |
| 122 | -167x | +188 | +3x |
- "wald" = prop_wald(rsp, conf_level),+ extra_args = extra_args, |
| 123 | -167x | +189 | +3x |
- "waldcc" = prop_wald(rsp, conf_level, correct = TRUE),+ show_labels = "hidden" |
| 124 | -167x | +|||
| 190 | +
- "agresti-coull" = prop_agresti_coull(rsp, conf_level),+ ) |
|||
| 125 | -167x | +|||
| 191 | +
- "jeffreys" = prop_jeffreys(rsp, conf_level)+ } |
| 126 | +1 |
- )+ #' Estimate proportions of each level of a variable |
||
| 127 | +2 |
-
+ #' |
||
| 128 | -167x | +|||
| 3 | +
- list(+ #' @description `r lifecycle::badge("stable")`
|
|||
| 129 | -167x | +|||
| 4 | +
- "n_prop" = formatters::with_label(c(n, p_hat), "Responders"),+ #' |
|||
| 130 | -167x | +|||
| 5 | +
- "prop_ci" = formatters::with_label(+ #' The analyze & summarize function [estimate_multinomial_response()] creates a layout element to estimate the |
|||
| 131 | -167x | +|||
| 6 | +
- x = 100 * prop_ci, label = d_proportion(conf_level, method, long = long)+ #' proportion and proportion confidence interval for each level of a factor variable. The primary analysis variable, |
|||
| 132 | +7 |
- )+ #' `var`, should be a factor variable, the values of which will be used as labels within the output table. |
||
| 133 | +8 |
- )+ #' |
||
| 134 | +9 |
- }+ #' @inheritParams argument_convention |
||
| 135 | +10 |
-
+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 136 | +11 |
- #' @describeIn estimate_proportion Formatted analysis function which is used as `afun`+ #' |
||
| 137 | +12 |
- #' in `estimate_proportion()`.+ #' Options are: ``r shQuote(get_stats("estimate_multinomial_response"), type = "sh")``
|
||
| 138 | +13 |
#' |
||
| 139 | +14 |
- #' @return+ #' @seealso Relevant description function [d_onco_rsp_label()]. |
||
| 140 | +15 |
- #' * `a_proportion()` returns the corresponding list with formatted [rtables::CellValue()].+ #' |
||
| 141 | +16 |
- #'+ #' @name estimate_multinomial_rsp |
||
| 142 | +17 |
- #' @export+ #' @order 1 |
||
| 143 | +18 |
- a_proportion <- make_afun(+ NULL |
||
| 144 | +19 |
- s_proportion,+ |
||
| 145 | +20 |
- .formats = c(n_prop = "xx (xx.x%)", prop_ci = "(xx.x, xx.x)")+ #' Description of standard oncology response |
||
| 146 | +21 |
- )+ #' |
||
| 147 | +22 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 148 | +23 |
- #' @describeIn estimate_proportion Layout-creating function which can take statistics function arguments+ #' |
||
| 149 | +24 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' Describe the oncology response in a standard way. |
||
| 150 | +25 |
#' |
||
| 151 | +26 |
- #' @return+ #' @param x (`character`)\cr the standard oncology codes to be described. |
||
| 152 | +27 |
- #' * `estimate_proportion()` returns a layout object suitable for passing to further layouting functions,+ #' |
||
| 153 | +28 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' @return Response labels. |
||
| 154 | +29 |
- #' the statistics from `s_proportion()` to the table layout.+ #' |
||
| 155 | +30 |
- #'+ #' @seealso [estimate_multinomial_rsp()] |
||
| 156 | +31 |
- #' @examples+ #' |
||
| 157 | +32 |
- #' dta_test <- data.frame(+ #' @examples |
||
| 158 | +33 |
- #' USUBJID = paste0("S", 1:12),
+ #' d_onco_rsp_label( |
||
| 159 | +34 |
- #' ARM = rep(LETTERS[1:3], each = 4),+ #' c("CR", "PR", "SD", "NON CR/PD", "PD", "NE", "Missing", "<Missing>", "NE/Missing")
|
||
| 160 | +35 |
- #' AVAL = rep(LETTERS[1:3], each = 4)+ #' ) |
||
| 161 | +36 |
- #' )+ #' |
||
| 162 | +37 |
- #'+ #' # Adding some values not considered in d_onco_rsp_label |
||
| 163 | +38 |
- #' basic_table() %>%+ #' |
||
| 164 | +39 |
- #' split_cols_by("ARM") %>%
+ #' d_onco_rsp_label( |
||
| 165 | +40 |
- #' estimate_proportion(vars = "AVAL") %>%+ #' c("CR", "PR", "hello", "hi")
|
||
| 166 | +41 |
- #' build_table(df = dta_test)+ #' ) |
||
| 167 | +42 |
#' |
||
| 168 | +43 |
#' @export |
||
| 169 | +44 |
- #' @order 2+ d_onco_rsp_label <- function(x) {
|
||
| 170 | -+ | |||
| 45 | +2x |
- estimate_proportion <- function(lyt,+ x <- as.character(x) |
||
| 171 | -+ | |||
| 46 | +2x |
- vars,+ desc <- c( |
||
| 172 | -+ | |||
| 47 | +2x |
- conf_level = 0.95,+ CR = "Complete Response (CR)", |
||
| 173 | -+ | |||
| 48 | +2x |
- method = c(+ PR = "Partial Response (PR)", |
||
| 174 | -+ | |||
| 49 | +2x |
- "waldcc", "wald", "clopper-pearson",+ MR = "Minimal/Minor Response (MR)", |
||
| 175 | -+ | |||
| 50 | +2x |
- "wilson", "wilsonc", "strat_wilson", "strat_wilsonc",+ MRD = "Minimal Residual Disease (MRD)", |
||
| 176 | -+ | |||
| 51 | +2x |
- "agresti-coull", "jeffreys"+ SD = "Stable Disease (SD)", |
||
| 177 | -+ | |||
| 52 | +2x |
- ),+ PD = "Progressive Disease (PD)", |
||
| 178 | -+ | |||
| 53 | +2x |
- weights = NULL,+ `NON CR/PD` = "Non-CR or Non-PD (NON CR/PD)", |
||
| 179 | -+ | |||
| 54 | +2x |
- max_iterations = 50,+ NE = "Not Evaluable (NE)", |
||
| 180 | -+ | |||
| 55 | +2x |
- variables = list(strata = NULL),+ `NE/Missing` = "Missing or unevaluable", |
||
| 181 | -+ | |||
| 56 | +2x |
- long = FALSE,+ Missing = "Missing", |
||
| 182 | -+ | |||
| 57 | +2x |
- na_str = default_na_str(),+ `NA` = "Not Applicable (NA)",+ |
+ ||
| 58 | +2x | +
+ ND = "Not Done (ND)" |
||
| 183 | +59 |
- nested = TRUE,+ ) |
||
| 184 | +60 |
- ...,+ + |
+ ||
| 61 | +2x | +
+ values_label <- vapply(+ |
+ ||
| 62 | +2x | +
+ X = x,+ |
+ ||
| 63 | +2x | +
+ FUN.VALUE = character(1),+ |
+ ||
| 64 | +2x | +
+ function(val) {
+ |
+ ||
| 65 | +! | +
+ if (val %in% names(desc)) desc[val] else val |
||
| 185 | +66 |
- show_labels = "hidden",+ } |
||
| 186 | +67 |
- table_names = vars,+ ) |
||
| 187 | +68 |
- .stats = NULL,+ + |
+ ||
| 69 | +2x | +
+ return(factor(values_label, levels = c(intersect(desc, values_label), setdiff(values_label, desc)))) |
||
| 188 | +70 |
- .formats = NULL,+ } |
||
| 189 | +71 |
- .labels = NULL,+ |
||
| 190 | +72 |
- .indent_mods = NULL) {
+ #' @describeIn estimate_multinomial_rsp Statistics function which feeds the length of `x` as number |
||
| 191 | -3x | +|||
| 73 | +
- extra_args <- list(+ #' of successes, and `.N_col` as total number of successes and failures into [s_proportion()]. |
|||
| 192 | -3x | +|||
| 74 | +
- conf_level = conf_level, method = method, weights = weights, max_iterations = max_iterations,+ #' |
|||
| 193 | -3x | +|||
| 75 | +
- variables = variables, long = long, ...+ #' @return |
|||
| 194 | +76 |
- )+ #' * `s_length_proportion()` returns statistics from [s_proportion()]. |
||
| 195 | +77 |
-
+ #' |
||
| 196 | -3x | +|||
| 78 | +
- afun <- make_afun(+ #' @examples |
|||
| 197 | -3x | +|||
| 79 | +
- a_proportion,+ #' s_length_proportion(rep("CR", 10), .N_col = 100)
|
|||
| 198 | -3x | +|||
| 80 | +
- .stats = .stats,+ #' s_length_proportion(factor(character(0)), .N_col = 100) |
|||
| 199 | -3x | +|||
| 81 | +
- .formats = .formats,+ #' |
|||
| 200 | -3x | +|||
| 82 | +
- .labels = .labels,+ #' @export |
|||
| 201 | -3x | +|||
| 83 | +
- .indent_mods = .indent_mods+ s_length_proportion <- function(x, |
|||
| 202 | +84 |
- )+ .N_col, # nolint |
||
| 203 | -3x | +|||
| 85 | +
- analyze(+ ...) {
|
|||
| 204 | -3x | +86 | +4x |
- lyt,+ checkmate::assert_multi_class(x, classes = c("factor", "character"))
|
| 205 | +87 | 3x |
- vars,+ checkmate::assert_vector(x, min.len = 0, max.len = .N_col) |
|
| 206 | -3x | +88 | +2x |
- afun = afun,+ checkmate::assert_vector(unique(x), min.len = 0, max.len = 1) |
| 207 | -3x | +|||
| 89 | +
- na_str = na_str,+ |
|||
| 208 | -3x | +90 | +1x |
- nested = nested,+ n_true <- length(x) |
| 209 | -3x | +91 | +1x |
- extra_args = extra_args,+ n_false <- .N_col - n_true |
| 210 | -3x | +92 | +1x |
- show_labels = show_labels,+ x_logical <- rep(c(TRUE, FALSE), c(n_true, n_false)) |
| 211 | -3x | +93 | +1x |
- table_names = table_names+ s_proportion(df = x_logical, ...) |
| 212 | +94 |
- )+ } |
||
| 213 | +95 |
- }+ |
||
| 214 | +96 |
-
+ #' @describeIn estimate_multinomial_rsp Formatted analysis function which is used as `afun` |
||
| 215 | +97 |
- #' Helper functions for calculating proportion confidence intervals+ #' in `estimate_multinomial_response()`. |
||
| 216 | +98 |
#' |
||
| 217 | +99 |
- #' @description `r lifecycle::badge("stable")`
+ #' @return |
||
| 218 | +100 |
- #'+ #' * `a_length_proportion()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 219 | +101 |
- #' Functions to calculate different proportion confidence intervals for use in [estimate_proportion()].+ #' |
||
| 220 | +102 |
- #'+ #' @examples |
||
| 221 | +103 |
- #' @inheritParams argument_convention+ #' a_length_proportion(rep("CR", 10), .N_col = 100)
|
||
| 222 | +104 |
- #' @inheritParams estimate_proportion+ #' a_length_proportion(factor(character(0)), .N_col = 100) |
||
| 223 | +105 |
#' |
||
| 224 | +106 |
- #' @return Confidence interval of a proportion.+ #' @export |
||
| 225 | +107 |
- #'+ a_length_proportion <- make_afun( |
||
| 226 | +108 |
- #' @seealso [estimate_proportion], descriptive function [d_proportion()],+ s_length_proportion, |
||
| 227 | +109 |
- #' and helper functions [strata_normal_quantile()] and [update_weights_strat_wilson()].+ .formats = c( |
||
| 228 | +110 |
- #'+ n_prop = "xx (xx.x%)", |
||
| 229 | +111 |
- #' @name h_proportions+ prop_ci = "(xx.xx, xx.xx)" |
||
| 230 | +112 |
- NULL+ ) |
||
| 231 | +113 |
-
+ ) |
||
| 232 | +114 |
- #' @describeIn h_proportions Calculates the Wilson interval by calling [stats::prop.test()].+ |
||
| 233 | +115 |
- #' Also referred to as Wilson score interval.+ #' @describeIn estimate_multinomial_rsp Layout-creating function which can take statistics function arguments |
||
| 234 | +116 |
- #'+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()] and |
||
| 235 | +117 |
- #' @examples+ #' [rtables::summarize_row_groups()]. |
||
| 236 | +118 |
- #' rsp <- c(+ #' |
||
| 237 | +119 |
- #' TRUE, TRUE, TRUE, TRUE, TRUE,+ #' @return |
||
| 238 | +120 |
- #' FALSE, FALSE, FALSE, FALSE, FALSE+ #' * `estimate_multinomial_response()` returns a layout object suitable for passing to further layouting functions, |
||
| 239 | +121 |
- #' )+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 240 | +122 |
- #' prop_wilson(rsp, conf_level = 0.9)+ #' the statistics from `s_length_proportion()` to the table layout. |
||
| 241 | +123 |
#' |
||
| 242 | +124 |
- #' @export+ #' @examples |
||
| 243 | +125 |
- prop_wilson <- function(rsp, conf_level, correct = FALSE) {
+ #' library(dplyr) |
||
| 244 | -5x | +|||
| 126 | +
- y <- stats::prop.test(+ #' |
|||
| 245 | -5x | +|||
| 127 | +
- sum(rsp),+ #' # Use of the layout creating function. |
|||
| 246 | -5x | +|||
| 128 | +
- length(rsp),+ #' dta_test <- data.frame( |
|||
| 247 | -5x | +|||
| 129 | +
- correct = correct,+ #' USUBJID = paste0("S", 1:12),
|
|||
| 248 | -5x | +|||
| 130 | +
- conf.level = conf_level+ #' ARM = factor(rep(LETTERS[1:3], each = 4)), |
|||
| 249 | +131 |
- )+ #' AVAL = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0)) |
||
| 250 | +132 |
-
+ #' ) %>% mutate( |
||
| 251 | -5x | +|||
| 133 | +
- as.numeric(y$conf.int)+ #' AVALC = factor(AVAL, |
|||
| 252 | +134 |
- }+ #' levels = c(0, 1), |
||
| 253 | +135 |
-
+ #' labels = c("Complete Response (CR)", "Partial Response (PR)")
|
||
| 254 | +136 |
- #' @describeIn h_proportions Calculates the stratified Wilson confidence+ #' ) |
||
| 255 | +137 |
- #' interval for unequal proportions as described in \insertCite{Yan2010-jt;textual}{tern}
+ #' ) |
||
| 256 | +138 |
#' |
||
| 257 | +139 |
- #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ #' lyt <- basic_table() %>% |
||
| 258 | +140 |
- #' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are+ #' split_cols_by("ARM") %>%
|
||
| 259 | +141 |
- #' estimated using the iterative algorithm proposed in \insertCite{Yan2010-jt;textual}{tern} that
+ #' estimate_multinomial_response(var = "AVALC") |
||
| 260 | +142 |
- #' minimizes the weighted squared length of the confidence interval.+ #' |
||
| 261 | +143 |
- #' @param max_iterations (`count`)\cr maximum number of iterations for the iterative procedure used+ #' tbl <- build_table(lyt, dta_test) |
||
| 262 | +144 |
- #' to find estimates of optimal weights.+ #' |
||
| 263 | +145 |
- #' @param correct (`flag`)\cr whether to include the continuity correction. For further information, see for example+ #' tbl |
||
| 264 | +146 |
- #' for [stats::prop.test()].+ #' |
||
| 265 | +147 |
- #'+ #' @export |
||
| 266 | +148 |
- #' @references+ #' @order 2 |
||
| 267 | +149 |
- #' \insertRef{Yan2010-jt}{tern}
+ estimate_multinomial_response <- function(lyt, |
||
| 268 | +150 |
- #'+ var, |
||
| 269 | +151 |
- #' @examples+ na_str = default_na_str(), |
||
| 270 | +152 |
- #' # Stratified Wilson confidence interval with unequal probabilities+ nested = TRUE, |
||
| 271 | +153 |
- #'+ ..., |
||
| 272 | +154 |
- #' set.seed(1)+ show_labels = "hidden", |
||
| 273 | +155 |
- #' rsp <- sample(c(TRUE, FALSE), 100, TRUE)+ table_names = var, |
||
| 274 | +156 |
- #' strata_data <- data.frame(+ .stats = "prop_ci", |
||
| 275 | +157 |
- #' "f1" = sample(c("a", "b"), 100, TRUE),
+ .formats = NULL, |
||
| 276 | +158 |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ .labels = NULL, |
||
| 277 | +159 |
- #' stringsAsFactors = TRUE+ .indent_mods = NULL) {
|
||
| 278 | -+ | |||
| 160 | +1x |
- #' )+ extra_args <- list(...) |
||
| 279 | +161 |
- #' strata <- interaction(strata_data)+ |
||
| 280 | -+ | |||
| 162 | +1x |
- #' n_strata <- ncol(table(rsp, strata)) # Number of strata+ afun <- make_afun( |
||
| 281 | -+ | |||
| 163 | +1x |
- #'+ a_length_proportion,+ |
+ ||
| 164 | +1x | +
+ .stats = .stats,+ |
+ ||
| 165 | +1x | +
+ .formats = .formats,+ |
+ ||
| 166 | +1x | +
+ .labels = .labels,+ |
+ ||
| 167 | +1x | +
+ .indent_mods = .indent_mods |
||
| 282 | +168 |
- #' prop_strat_wilson(+ )+ |
+ ||
| 169 | +1x | +
+ lyt <- split_rows_by(lyt, var = var)+ |
+ ||
| 170 | +1x | +
+ lyt <- summarize_row_groups(lyt, na_str = na_str) |
||
| 283 | +171 |
- #' rsp = rsp, strata = strata,+ + |
+ ||
| 172 | +1x | +
+ analyze(+ |
+ ||
| 173 | +1x | +
+ lyt,+ |
+ ||
| 174 | +1x | +
+ vars = var,+ |
+ ||
| 175 | +1x | +
+ afun = afun,+ |
+ ||
| 176 | +1x | +
+ show_labels = show_labels,+ |
+ ||
| 177 | +1x | +
+ table_names = table_names,+ |
+ ||
| 178 | +1x | +
+ na_str = na_str,+ |
+ ||
| 179 | +1x | +
+ nested = nested,+ |
+ ||
| 180 | +1x | +
+ extra_args = extra_args |
||
| 284 | +181 |
- #' conf_level = 0.90+ ) |
||
| 285 | +182 |
- #' )+ } |
| 286 | +1 |
- #'+ #' Summarize variables in columns |
||
| 287 | +2 |
- #' # Not automatic setting of weights+ #' |
||
| 288 | +3 |
- #' prop_strat_wilson(+ #' @description `r lifecycle::badge("stable")`
|
||
| 289 | +4 |
- #' rsp = rsp, strata = strata,+ #' |
||
| 290 | +5 |
- #' weights = rep(1 / n_strata, n_strata),+ #' The analyze function [summarize_colvars()] uses the statistics function [s_summary()] to analyze variables that are |
||
| 291 | +6 |
- #' conf_level = 0.90+ #' arranged in columns. The variables to analyze should be specified in the table layout via column splits (see |
||
| 292 | +7 |
- #' )+ #' [rtables::split_cols_by()] and [rtables::split_cols_by_multivar()]) prior to using [summarize_colvars()]. |
||
| 293 | +8 |
#' |
||
| 294 | +9 |
- #' @export+ #' The function is a minimal wrapper for [rtables::analyze_colvars()], a function typically used to apply different |
||
| 295 | +10 |
- prop_strat_wilson <- function(rsp,+ #' analysis methods in rows for each column variable. To use the analysis methods as column labels, please refer to |
||
| 296 | +11 |
- strata,+ #' the [analyze_vars_in_cols()] function. |
||
| 297 | +12 |
- weights = NULL,+ #' |
||
| 298 | +13 |
- conf_level = 0.95,+ #' @inheritParams argument_convention |
||
| 299 | +14 |
- max_iterations = NULL,+ #' @param ... arguments passed to [s_summary()]. |
||
| 300 | +15 |
- correct = FALSE) {
+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector |
||
| 301 | -20x | +|||
| 16 | +
- checkmate::assert_logical(rsp, any.missing = FALSE)+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
|||
| 302 | -20x | +|||
| 17 | +
- checkmate::assert_factor(strata, len = length(rsp))+ #' for that statistic's row label. |
|||
| 303 | -20x | +|||
| 18 | +
- assert_proportion_value(conf_level)+ #' |
|||
| 304 | +19 |
-
+ #' @return |
||
| 305 | -20x | +|||
| 20 | +
- tbl <- table(rsp, strata)+ #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()]. |
|||
| 306 | -20x | +|||
| 21 | +
- n_strata <- length(unique(strata))+ #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output |
|||
| 307 | +22 |
-
+ #' in columns, and add it to the table layout. |
||
| 308 | +23 |
- # Checking the weights and maximum number of iterations.+ #' |
||
| 309 | -20x | +|||
| 24 | +
- do_iter <- FALSE+ #' @seealso [rtables::split_cols_by_multivar()] and [`analyze_colvars_functions`]. |
|||
| 310 | -20x | +|||
| 25 | +
- if (is.null(weights)) {
+ #' |
|||
| 311 | -6x | +|||
| 26 | +
- weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure+ #' @examples |
|||
| 312 | -6x | +|||
| 27 | +
- do_iter <- TRUE+ #' dta_test <- data.frame( |
|||
| 313 | +28 |
-
+ #' USUBJID = rep(1:6, each = 3), |
||
| 314 | +29 |
- # Iteration parameters+ #' PARAMCD = rep("lab", 6 * 3),
|
||
| 315 | -2x | +|||
| 30 | +
- if (is.null(max_iterations)) max_iterations <- 10+ #' AVISIT = rep(paste0("V", 1:3), 6),
|
|||
| 316 | -6x | +|||
| 31 | +
- checkmate::assert_int(max_iterations, na.ok = FALSE, null.ok = FALSE, lower = 1)+ #' ARM = rep(LETTERS[1:3], rep(6, 3)), |
|||
| 317 | +32 |
- }+ #' AVAL = c(9:1, rep(NA, 9)), |
||
| 318 | -20x | +|||
| 33 | +
- checkmate::assert_numeric(weights, lower = 0, upper = 1, any.missing = FALSE, len = n_strata)+ #' CHG = c(1:9, rep(NA, 9)) |
|||
| 319 | -20x | +|||
| 34 | +
- sum_weights <- checkmate::assert_int(sum(weights))+ #' ) |
|||
| 320 | -! | +|||
| 35 | +
- if (as.integer(sum_weights + 0.5) != 1L) stop("Sum of weights must be 1L.")
+ #' |
|||
| 321 | +36 |
-
+ #' ## Default output within a `rtables` pipeline. |
||
| 322 | -20x | +|||
| 37 | +
- xs <- tbl["TRUE", ]+ #' basic_table() %>% |
|||
| 323 | -20x | +|||
| 38 | +
- ns <- colSums(tbl)+ #' split_cols_by("ARM") %>%
|
|||
| 324 | -20x | +|||
| 39 | +
- use_stratum <- (ns > 0)+ #' split_rows_by("AVISIT") %>%
|
|||
| 325 | -20x | +|||
| 40 | +
- ns <- ns[use_stratum]+ #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
|
|||
| 326 | -20x | +|||
| 41 | +
- xs <- xs[use_stratum]+ #' summarize_colvars() %>% |
|||
| 327 | -20x | +|||
| 42 | +
- ests <- xs / ns+ #' build_table(dta_test) |
|||
| 328 | -20x | +|||
| 43 | +
- vars <- ests * (1 - ests) / ns+ #' |
|||
| 329 | +44 |
-
+ #' ## Selection of statistics, formats and labels also work. |
||
| 330 | -20x | +|||
| 45 | +
- strata_qnorm <- strata_normal_quantile(vars, weights, conf_level)+ #' basic_table() %>% |
|||
| 331 | +46 |
-
+ #' split_cols_by("ARM") %>%
|
||
| 332 | +47 |
- # Iterative setting of weights if they were not set externally+ #' split_rows_by("AVISIT") %>%
|
||
| 333 | -20x | +|||
| 48 | +
- weights_new <- if (do_iter) {
+ #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
|
|||
| 334 | -6x | +|||
| 49 | +
- update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max_iterations, conf_level)$weights+ #' summarize_colvars( |
|||
| 335 | +50 |
- } else {
+ #' .stats = c("n", "mean_sd"),
|
||
| 336 | -14x | +|||
| 51 | +
- weights+ #' .formats = c("mean_sd" = "xx.x, xx.x"),
|
|||
| 337 | +52 |
- }+ #' .labels = c(n = "n", mean_sd = "Mean, SD") |
||
| 338 | +53 |
-
+ #' ) %>% |
||
| 339 | -20x | +|||
| 54 | +
- strata_conf_level <- 2 * stats::pnorm(strata_qnorm) - 1+ #' build_table(dta_test) |
|||
| 340 | +55 |
-
+ #' |
||
| 341 | -20x | +|||
| 56 | +
- ci_by_strata <- Map(+ #' ## Use arguments interpreted by `s_summary`. |
|||
| 342 | -20x | +|||
| 57 | +
- function(x, n) {
+ #' basic_table() %>% |
|||
| 343 | +58 |
- # Classic Wilson's confidence interval+ #' split_cols_by("ARM") %>%
|
||
| 344 | -139x | +|||
| 59 | +
- suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf_level)$conf.int)+ #' split_rows_by("AVISIT") %>%
|
|||
| 345 | +60 |
- },+ #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
|
||
| 346 | -20x | +|||
| 61 | +
- x = xs,+ #' summarize_colvars(na.rm = FALSE) %>% |
|||
| 347 | -20x | +|||
| 62 | +
- n = ns+ #' build_table(dta_test) |
|||
| 348 | +63 |
- )+ #' |
||
| 349 | -20x | +|||
| 64 | +
- lower_by_strata <- sapply(ci_by_strata, "[", 1L)+ #' @export |
|||
| 350 | -20x | +|||
| 65 | +
- upper_by_strata <- sapply(ci_by_strata, "[", 2L)+ summarize_colvars <- function(lyt, |
|||
| 351 | +66 |
-
+ ..., |
||
| 352 | -20x | +|||
| 67 | +
- lower <- sum(weights_new * lower_by_strata)+ na_str = default_na_str(), |
|||
| 353 | -20x | +|||
| 68 | +
- upper <- sum(weights_new * upper_by_strata)+ .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
|
|||
| 354 | +69 |
-
+ .formats = NULL, |
||
| 355 | +70 |
- # Return values+ .labels = NULL, |
||
| 356 | -20x | +|||
| 71 | +
- if (do_iter) {
+ .indent_mods = NULL) {
|
|||
| 357 | -6x | +72 | +3x |
- list(+ extra_args <- list(.stats = .stats, na_str = na_str, ...) |
| 358 | -6x | +73 | +1x |
- conf_int = c(+ if (!is.null(.formats)) extra_args[[".formats"]] <- .formats |
| 359 | -6x | +74 | +1x |
- lower = lower,+ if (!is.null(.labels)) extra_args[[".labels"]] <- .labels |
| 360 | -6x | +75 | +1x |
- upper = upper+ if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods |
| 361 | +76 |
- ),+ |
||
| 362 | -6x | -
- weights = weights_new- |
- ||
| 363 | -- |
- )- |
- ||
| 364 | -+ | 77 | +3x |
- } else {
+ analyze_colvars( |
| 365 | -14x | +78 | +3x |
- list(+ lyt, |
| 366 | -14x | +79 | +3x |
- conf_int = c(+ afun = a_summary, |
| 367 | -14x | +80 | +3x |
- lower = lower,+ na_str = na_str, |
| 368 | -14x | -
- upper = upper- |
- ||
| 369 | -- |
- )- |
- ||
| 370 | -+ | 81 | +3x |
- )+ extra_args = extra_args |
| 371 | +82 |
- }+ ) |
||
| 372 | +83 |
} |
| 373 | +1 |
-
+ #' Count the number of patients with a particular event |
||
| 374 | +2 |
- #' @describeIn h_proportions Calculates the Clopper-Pearson interval by calling [stats::binom.test()].+ #' |
||
| 375 | +3 |
- #' Also referred to as the `exact` method.+ #' @description `r lifecycle::badge("stable")`
|
||
| 376 | +4 |
#' |
||
| 377 | +5 |
- #' @examples+ #' The analyze function [count_patients_with_event()] creates a layout element to calculate patient counts for a |
||
| 378 | +6 |
- #' prop_clopper_pearson(rsp, conf_level = .95)+ #' user-specified set of events. |
||
| 379 | +7 |
#' |
||
| 380 | +8 |
- #' @export+ #' This function analyzes primary analysis variable `vars` which indicates unique subject identifiers. Events |
||
| 381 | +9 |
- prop_clopper_pearson <- function(rsp,+ #' are defined by the user as a named vector via the `filters` argument, where each name corresponds to a |
||
| 382 | +10 |
- conf_level) {
- |
- ||
| 383 | -1x | -
- y <- stats::binom.test(- |
- ||
| 384 | -1x | -
- x = sum(rsp),+ #' variable and each value is the value(s) that that variable takes for the event. |
||
| 385 | -1x | +|||
| 11 | +
- n = length(rsp),+ #' |
|||
| 386 | -1x | +|||
| 12 | +
- conf.level = conf_level+ #' If there are multiple records with the same event recorded for a patient, only one occurrence is counted. |
|||
| 387 | +13 |
- )+ #' |
||
| 388 | -1x | +|||
| 14 | +
- as.numeric(y$conf.int)+ #' @inheritParams argument_convention |
|||
| 389 | +15 |
- }+ #' @param filters (`character`)\cr a character vector specifying the column names and flag variables |
||
| 390 | +16 |
-
+ #' to be used for counting the number of unique identifiers satisfying such conditions. |
||
| 391 | +17 |
- #' @describeIn h_proportions Calculates the Wald interval by following the usual textbook definition+ #' Multiple column names and flags are accepted in this format |
||
| 392 | +18 |
- #' for a single proportion confidence interval using the normal approximation.+ #' `c("column_name1" = "flag1", "column_name2" = "flag2")`.
|
||
| 393 | +19 |
- #'+ #' Note that only equality is being accepted as condition. |
||
| 394 | +20 |
- #' @param correct (`flag`)\cr whether to apply continuity correction.+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 395 | +21 |
#' |
||
| 396 | +22 |
- #' @examples+ #' Options are: ``r shQuote(get_stats("count_patients_with_event"), type = "sh")``
|
||
| 397 | +23 |
- #' prop_wald(rsp, conf_level = 0.95)+ #' |
||
| 398 | +24 |
- #' prop_wald(rsp, conf_level = 0.95, correct = TRUE)+ #' @seealso [count_patients_with_flags()] |
||
| 399 | +25 |
#' |
||
| 400 | +26 |
- #' @export+ #' @name count_patients_with_event |
||
| 401 | +27 |
- prop_wald <- function(rsp, conf_level, correct = FALSE) {
- |
- ||
| 402 | -163x | -
- n <- length(rsp)- |
- ||
| 403 | -163x | -
- p_hat <- mean(rsp)- |
- ||
| 404 | -163x | -
- z <- stats::qnorm((1 + conf_level) / 2)- |
- ||
| 405 | -163x | -
- q_hat <- 1 - p_hat- |
- ||
| 406 | -163x | -
- correct <- if (correct) 1 / (2 * n) else 0+ #' @order 1 |
||
| 407 | +28 | - - | -||
| 408 | -163x | -
- err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correct- |
- ||
| 409 | -163x | -
- l_ci <- max(0, p_hat - err)- |
- ||
| 410 | -163x | -
- u_ci <- min(1, p_hat + err)+ NULL |
||
| 411 | +29 | |||
| 412 | -163x | +|||
| 30 | +
- c(l_ci, u_ci)+ #' @describeIn count_patients_with_event Statistics function which counts the number of patients for which |
|||
| 413 | +31 |
- }+ #' the defined event has occurred. |
||
| 414 | +32 |
-
+ #' |
||
| 415 | +33 |
- #' @describeIn h_proportions Calculates the Agresti-Coull interval. Constructed (for 95% CI) by adding two successes+ #' @inheritParams analyze_variables |
||
| 416 | +34 |
- #' and two failures to the data and then using the Wald formula to construct a CI.+ #' @param .var (`string`)\cr name of the column that contains the unique identifier. |
||
| 417 | +35 |
#' |
||
| 418 | +36 |
- #' @examples+ #' @return |
||
| 419 | +37 |
- #' prop_agresti_coull(rsp, conf_level = 0.95)+ #' * `s_count_patients_with_event()` returns the count and fraction of unique identifiers with the defined event. |
||
| 420 | +38 |
#' |
||
| 421 | +39 |
- #' @export+ #' @examples |
||
| 422 | +40 |
- prop_agresti_coull <- function(rsp, conf_level) {
- |
- ||
| 423 | -3x | -
- n <- length(rsp)+ #' s_count_patients_with_event( |
||
| 424 | -3x | +|||
| 41 | +
- x_sum <- sum(rsp)+ #' tern_ex_adae, |
|||
| 425 | -3x | +|||
| 42 | +
- z <- stats::qnorm((1 + conf_level) / 2)+ #' .var = "SUBJID", |
|||
| 426 | +43 |
-
+ #' filters = c("TRTEMFL" = "Y"),
|
||
| 427 | +44 |
- # Add here both z^2 / 2 successes and failures.+ #' ) |
||
| 428 | -3x | +|||
| 45 | +
- x_sum_tilde <- x_sum + z^2 / 2+ #' |
|||
| 429 | -3x | +|||
| 46 | +
- n_tilde <- n + z^2+ #' s_count_patients_with_event( |
|||
| 430 | +47 |
-
+ #' tern_ex_adae, |
||
| 431 | +48 |
- # Then proceed as with the Wald interval.+ #' .var = "SUBJID", |
||
| 432 | -3x | +|||
| 49 | +
- p_tilde <- x_sum_tilde / n_tilde+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL")
|
|||
| 433 | -3x | +|||
| 50 | +
- q_tilde <- 1 - p_tilde+ #' ) |
|||
| 434 | -3x | +|||
| 51 | +
- err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)+ #' |
|||
| 435 | -3x | +|||
| 52 | +
- l_ci <- max(0, p_tilde - err)+ #' s_count_patients_with_event( |
|||
| 436 | -3x | +|||
| 53 | +
- u_ci <- min(1, p_tilde + err)+ #' tern_ex_adae, |
|||
| 437 | +54 |
-
+ #' .var = "SUBJID", |
||
| 438 | -3x | +|||
| 55 | +
- c(l_ci, u_ci)+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
|
|||
| 439 | +56 |
- }+ #' denom = "N_col", |
||
| 440 | +57 |
-
+ #' .N_col = 456 |
||
| 441 | +58 |
- #' @describeIn h_proportions Calculates the Jeffreys interval, an equal-tailed interval based on the+ #' ) |
||
| 442 | +59 |
- #' non-informative Jeffreys prior for a binomial proportion.+ #' |
||
| 443 | +60 |
- #'+ #' @export |
||
| 444 | +61 |
- #' @examples+ s_count_patients_with_event <- function(df, |
||
| 445 | +62 |
- #' prop_jeffreys(rsp, conf_level = 0.95)+ .var, |
||
| 446 | +63 |
- #'+ filters, |
||
| 447 | +64 |
- #' @export+ .N_col = ncol(df), # nolint |
||
| 448 | +65 |
- prop_jeffreys <- function(rsp,+ .N_row = nrow(df), # nolint |
||
| 449 | +66 |
- conf_level) {
+ denom = c("n", "N_col", "N_row")) {
|
||
| 450 | -5x | +67 | +51x |
- n <- length(rsp)+ col_names <- names(filters) |
| 451 | -5x | +68 | +51x |
- x_sum <- sum(rsp)+ filter_values <- filters |
| 452 | +69 | |||
| 453 | -5x | +70 | +51x |
- alpha <- 1 - conf_level+ checkmate::assert_subset(col_names, colnames(df))+ |
+
| 71 | ++ | + | ||
| 454 | -5x | +72 | +51x |
- l_ci <- ifelse(+ temp <- Map( |
| 455 | -5x | +73 | +51x |
- x_sum == 0,+ function(x, y) which(df[[x]] == y), |
| 456 | -5x | +74 | +51x |
- 0,+ col_names, |
| 457 | -5x | +75 | +51x |
- stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ filter_values |
| 458 | +76 |
) |
||
| 459 | -+ | |||
| 77 | +51x |
-
+ position_satisfy_filters <- Reduce(intersect, temp) |
||
| 460 | -5x | +78 | +51x |
- u_ci <- ifelse(+ id_satisfy_filters <- as.character(unique(df[position_satisfy_filters, ][[.var]])) |
| 461 | -5x | +79 | +51x |
- x_sum == n,+ result <- s_count_values( |
| 462 | -5x | +80 | +51x |
- 1,+ as.character(unique(df[[.var]])), |
| 463 | -5x | +81 | +51x |
- stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ id_satisfy_filters, |
| 464 | -+ | |||
| 82 | +51x |
- )+ denom = denom,+ |
+ ||
| 83 | +51x | +
+ .N_col = .N_col,+ |
+ ||
| 84 | +51x | +
+ .N_row = .N_row |
||
| 465 | +85 |
-
+ ) |
||
| 466 | -5x | +86 | +51x |
- c(l_ci, u_ci)+ result |
| 467 | +87 |
} |
||
| 468 | +88 | |||
| 469 | +89 |
- #' Description of the proportion summary+ #' @describeIn count_patients_with_event Formatted analysis function which is used as `afun` |
||
| 470 | +90 |
- #'+ #' in `count_patients_with_event()`. |
||
| 471 | +91 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
||
| 472 | +92 |
- #'+ #' @return |
||
| 473 | +93 |
- #' This is a helper function that describes the analysis in [s_proportion()].+ #' * `a_count_patients_with_event()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 474 | +94 |
#' |
||
| 475 | +95 |
- #' @inheritParams s_proportion+ #' @examples |
||
| 476 | +96 |
- #' @param long (`flag`)\cr whether a long or a short (default) description is required.+ #' a_count_patients_with_event( |
||
| 477 | +97 |
- #'+ #' tern_ex_adae, |
||
| 478 | +98 |
- #' @return String describing the analysis.+ #' .var = "SUBJID", |
||
| 479 | +99 |
- #'+ #' filters = c("TRTEMFL" = "Y"),
|
||
| 480 | +100 |
- #' @export+ #' .N_col = 100, |
||
| 481 | +101 |
- d_proportion <- function(conf_level,+ #' .N_row = 100 |
||
| 482 | +102 |
- method,+ #' ) |
||
| 483 | +103 |
- long = FALSE) {
+ #' |
||
| 484 | -179x | +|||
| 104 | +
- label <- paste0(conf_level * 100, "% CI")+ #' @export |
|||
| 485 | +105 |
-
+ a_count_patients_with_event <- function(df, |
||
| 486 | -! | +|||
| 106 | +
- if (long) label <- paste(label, "for Response Rates")+ labelstr = "", |
|||
| 487 | +107 |
-
+ filters, |
||
| 488 | -179x | +|||
| 108 | +
- method_part <- switch(method,+ .N_col, # nolint |
|||
| 489 | -179x | +|||
| 109 | +
- "clopper-pearson" = "Clopper-Pearson",+ .N_row, # nolint |
|||
| 490 | -179x | +|||
| 110 | +
- "waldcc" = "Wald, with correction",+ denom = c("n", "N_col", "N_row"),
|
|||
| 491 | -179x | +|||
| 111 | +
- "wald" = "Wald, without correction",+ .df_row, |
|||
| 492 | -179x | +|||
| 112 | +
- "wilson" = "Wilson, without correction",+ .var = NULL, |
|||
| 493 | -179x | +|||
| 113 | +
- "strat_wilson" = "Stratified Wilson, without correction",+ .stats = NULL, |
|||
| 494 | -179x | +|||
| 114 | +
- "wilsonc" = "Wilson, with correction",+ .formats = NULL, |
|||
| 495 | -179x | +|||
| 115 | +
- "strat_wilsonc" = "Stratified Wilson, with correction",+ .labels = NULL, |
|||
| 496 | -179x | +|||
| 116 | +
- "agresti-coull" = "Agresti-Coull",+ .indent_mods = NULL,+ |
+ |||
| 117 | ++ |
+ na_str = default_na_str()) {
|
||
| 497 | -179x | +118 | +19x |
- "jeffreys" = "Jeffreys",+ x_stats <- s_count_patients_with_event( |
| 498 | -179x | +119 | +19x |
- stop(paste(method, "does not have a description"))+ df = df, .var = .var, filters = filters, .N_col, .N_row, denom = denom |
| 499 | +120 |
) |
||
| 500 | +121 | |||
| 501 | -179x | +122 | +19x |
- paste0(label, " (", method_part, ")")
+ if (is.null(unlist(x_stats))) {
+ |
+
| 123 | +! | +
+ return(NULL) |
||
| 502 | +124 |
- }+ } |
||
| 503 | +125 | |||
| 504 | +126 |
- #' Helper function for the estimation of stratified quantiles+ # Fill in with formatting defaults if needed |
||
| 505 | -+ | |||
| 127 | +19x |
- #'+ .stats <- get_stats("count_patients_with_event", stats_in = .stats)
|
||
| 506 | -+ | |||
| 128 | +19x |
- #' @description `r lifecycle::badge("stable")`
+ .formats <- get_formats_from_stats(.stats, .formats) |
||
| 507 | -+ | |||
| 129 | +19x |
- #'+ .labels <- get_labels_from_stats(.stats, .labels) |
||
| 508 | -+ | |||
| 130 | +19x |
- #' This function wraps the estimation of stratified percentiles when we assume+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods) |
||
| 509 | +131 |
- #' the approximation for large numbers. This is necessary only in the case+ |
||
| 510 | -+ | |||
| 132 | +19x |
- #' proportions for each strata are unequal.+ x_stats <- x_stats[.stats] |
||
| 511 | +133 |
- #'+ |
||
| 512 | +134 |
- #' @inheritParams argument_convention+ # Auto format handling |
||
| 513 | -+ | |||
| 135 | +19x |
- #' @inheritParams prop_strat_wilson+ .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var) |
||
| 514 | +136 |
- #'+ |
||
| 515 | -+ | |||
| 137 | +19x |
- #' @return Stratified quantile.+ in_rows( |
||
| 516 | -+ | |||
| 138 | +19x |
- #'+ .list = x_stats, |
||
| 517 | -+ | |||
| 139 | +19x |
- #' @seealso [prop_strat_wilson()]+ .formats = .formats, |
||
| 518 | -+ | |||
| 140 | +19x |
- #'+ .names = names(.labels),+ |
+ ||
| 141 | +19x | +
+ .labels = .labels %>% .unlist_keep_nulls(),+ |
+ ||
| 142 | +19x | +
+ .indent_mods = .indent_mods %>% .unlist_keep_nulls(),+ |
+ ||
| 143 | +19x | +
+ .format_na_strs = na_str |
||
| 519 | +144 |
- #' @examples+ ) |
||
| 520 | +145 |
- #' strata_data <- table(data.frame(+ } |
||
| 521 | +146 |
- #' "f1" = sample(c(TRUE, FALSE), 100, TRUE),+ |
||
| 522 | +147 |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ #' @describeIn count_patients_with_event Layout-creating function which can take statistics function |
||
| 523 | +148 |
- #' stringsAsFactors = TRUE+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 524 | +149 |
- #' ))+ #' |
||
| 525 | +150 |
- #' ns <- colSums(strata_data)+ #' @return |
||
| 526 | +151 |
- #' ests <- strata_data["TRUE", ] / ns+ #' * `count_patients_with_event()` returns a layout object suitable for passing to further layouting functions, |
||
| 527 | +152 |
- #' vars <- ests * (1 - ests) / ns+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 528 | +153 |
- #' weights <- rep(1 / length(ns), length(ns))+ #' the statistics from `s_count_patients_with_event()` to the table layout. |
||
| 529 | +154 |
#' |
||
| 530 | +155 |
- #' strata_normal_quantile(vars, weights, 0.95)+ #' @examples |
||
| 531 | +156 |
- #'+ #' lyt <- basic_table() %>% |
||
| 532 | +157 |
- #' @export+ #' split_cols_by("ARM") %>%
|
||
| 533 | +158 |
- strata_normal_quantile <- function(vars, weights, conf_level) {
+ #' add_colcounts() %>% |
||
| 534 | -43x | +|||
| 159 | +
- summands <- weights^2 * vars+ #' count_values( |
|||
| 535 | +160 |
- # Stratified quantile+ #' "STUDYID", |
||
| 536 | -43x | +|||
| 161 | +
- sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf_level) / 2)+ #' values = "AB12345", |
|||
| 537 | +162 |
- }+ #' .stats = "count", |
||
| 538 | +163 |
-
+ #' .labels = c(count = "Total AEs") |
||
| 539 | +164 |
- #' Helper function for the estimation of weights for `prop_strat_wilson()`+ #' ) %>% |
||
| 540 | +165 |
- #'+ #' count_patients_with_event( |
||
| 541 | +166 |
- #' @description `r lifecycle::badge("stable")`
+ #' "SUBJID", |
||
| 542 | +167 |
- #'+ #' filters = c("TRTEMFL" = "Y"),
|
||
| 543 | +168 |
- #' This function wraps the iteration procedure that allows you to estimate+ #' .labels = c(count_fraction = "Total number of patients with at least one adverse event"), |
||
| 544 | +169 |
- #' the weights for each proportional strata. This assumes to minimize the+ #' table_names = "tbl_all" |
||
| 545 | +170 |
- #' weighted squared length of the confidence interval.+ #' ) %>% |
||
| 546 | +171 |
- #'+ #' count_patients_with_event( |
||
| 547 | +172 |
- #' @inheritParams prop_strat_wilson+ #' "SUBJID", |
||
| 548 | +173 |
- #' @param vars (`numeric`)\cr normalized proportions for each strata.+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
|
||
| 549 | +174 |
- #' @param strata_qnorm (`numeric(1)`)\cr initial estimation with identical weights of the quantiles.+ #' .labels = c(count_fraction = "Total number of patients with fatal AEs"), |
||
| 550 | +175 |
- #' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can+ #' table_names = "tbl_fatal" |
||
| 551 | +176 |
- #' be optimized in the future if we need to estimate better initial weights.+ #' ) %>% |
||
| 552 | +177 |
- #' @param n_per_strata (`numeric`)\cr number of elements in each strata.+ #' count_patients_with_event( |
||
| 553 | +178 |
- #' @param max_iterations (`integer(1)`)\cr maximum number of iterations to be tried. Convergence is always checked.+ #' "SUBJID", |
||
| 554 | +179 |
- #' @param tol (`numeric(1)`)\cr tolerance threshold for convergence.+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL", "AEREL" = "Y"),
|
||
| 555 | +180 |
- #'+ #' .labels = c(count_fraction = "Total number of patients with related fatal AEs"), |
||
| 556 | +181 |
- #' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`.+ #' .indent_mods = c(count_fraction = 2L), |
||
| 557 | +182 |
- #'+ #' table_names = "tbl_rel_fatal" |
||
| 558 | +183 |
- #' @seealso For references and details see [prop_strat_wilson()].+ #' ) |
||
| 559 | +184 |
#' |
||
| 560 | +185 |
- #' @examples+ #' build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl) |
||
| 561 | +186 |
- #' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018)+ #' |
||
| 562 | +187 |
- #' sq <- 0.674+ #' @export |
||
| 563 | +188 |
- #' ws <- rep(1 / length(vs), length(vs))+ #' @order 2+ |
+ ||
| 189 | ++ |
+ count_patients_with_event <- function(lyt, |
||
| 564 | +190 |
- #' ns <- c(22, 18, 17, 17, 14, 12)+ vars, |
||
| 565 | +191 |
- #'+ filters, |
||
| 566 | +192 |
- #' update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001)+ riskdiff = FALSE, |
||
| 567 | +193 |
- #'+ na_str = default_na_str(), |
||
| 568 | +194 |
- #' @export+ nested = TRUE, |
||
| 569 | +195 |
- update_weights_strat_wilson <- function(vars,+ ..., |
||
| 570 | +196 |
- strata_qnorm,+ table_names = vars, |
||
| 571 | +197 |
- initial_weights,+ .stats = "count_fraction", |
||
| 572 | +198 |
- n_per_strata,+ .formats = list(count_fraction = format_count_fraction_fixed_dp), |
||
| 573 | +199 |
- max_iterations = 50,+ .labels = NULL, |
||
| 574 | +200 |
- conf_level = 0.95,+ .indent_mods = NULL) {
|
||
| 575 | -+ | |||
| 201 | +7x |
- tol = 0.001) {
+ checkmate::assert_flag(riskdiff) |
||
| 576 | -9x | +202 | +7x |
- it <- 0+ extra_args <- list( |
| 577 | -9x | +203 | +7x |
- diff_v <- NULL+ .stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str |
| 578 | +204 |
-
+ ) |
||
| 579 | -9x | +205 | +7x |
- while (it < max_iterations) {
+ s_args <- list(filters = filters, ...) |
| 580 | -21x | +|||
| 206 | +
- it <- it + 1+ |
|||
| 581 | -21x | +207 | +7x |
- weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2+ if (isFALSE(riskdiff)) {
|
| 582 | -21x | +208 | +5x |
- weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2))+ extra_args <- c(extra_args, s_args) |
| 583 | -21x | +|||
| 209 | +
- weights_new <- weights_new_t / weights_new_b+ } else {
|
|||
| 584 | -21x | +210 | +2x |
- weights_new <- weights_new / sum(weights_new)+ extra_args <- c( |
| 585 | -21x | +211 | +2x |
- strata_qnorm <- strata_normal_quantile(vars, weights_new, conf_level)+ extra_args, |
| 586 | -21x | +212 | +2x |
- diff_v <- c(diff_v, sum(abs(weights_new - initial_weights)))+ list( |
| 587 | -8x | +213 | +2x |
- if (diff_v[length(diff_v)] < tol) break+ afun = list("s_count_patients_with_event" = a_count_patients_with_event),
|
| 588 | -13x | +214 | +2x |
- initial_weights <- weights_new+ s_args = s_args |
| 589 | +215 | ++ |
+ )+ |
+ |
| 216 | ++ |
+ )+ |
+ ||
| 217 |
} |
|||
| 590 | +218 | |||
| 591 | -9x | +219 | +7x |
- if (it == max_iterations) {
+ analyze( |
| 592 | -1x | +220 | +7x |
- warning("The heuristic to find weights did not converge with max_iterations = ", max_iterations)
+ lyt = lyt, |
| 593 | -+ | |||
| 221 | +7x |
- }+ vars = vars, |
||
| 594 | -+ | |||
| 222 | +7x |
-
+ afun = ifelse(isFALSE(riskdiff), a_count_patients_with_event, afun_riskdiff), |
||
| 595 | -9x | +223 | +7x |
- list(+ show_labels = ifelse(length(vars) > 1, "visible", "hidden"), |
| 596 | -9x | +224 | +7x |
- "n_it" = it,+ table_names = table_names, |
| 597 | -9x | +225 | +7x |
- "weights" = weights_new,+ na_str = na_str, |
| 598 | -9x | +226 | +7x |
- "diff_v" = diff_v+ nested = nested,+ |
+
| 227 | +7x | +
+ extra_args = extra_args |
||
| 599 | +228 |
) |
||
| 600 | +229 |
}@@ -156068,14 +158767,14 @@ tern coverage - 95.59% |
| 1 |
- #' Count patients with abnormal range values+ #' Helper function to create a map data frame for `trim_levels_to_map()` |
||
| 5 |
- #' The analyze function [count_abnormal()] creates a layout element to count patients with abnormal analysis range+ #' Helper function to create a map data frame from the input dataset, which can be used as an argument in the |
||
| 6 |
- #' values in each direction.+ #' `trim_levels_to_map` split function. Based on different method, the map is constructed differently. |
||
| 8 |
- #' This function analyzes primary analysis variable `var` which indicates abnormal range results.+ #' @inheritParams argument_convention |
||
| 9 |
- #' Additional analysis variables that can be supplied as a list via the `variables` parameter are+ #' @param abnormal (named `list`)\cr identifying the abnormal range level(s) in `df`. Based on the levels of |
||
| 10 |
- #' `id` (defaults to `USUBJID`), a variable to indicate unique subject identifiers, and `baseline`+ #' abnormality of the input dataset, it can be something like `list(Low = "LOW LOW", High = "HIGH HIGH")` or |
||
| 11 |
- #' (defaults to `BNRIND`), a variable to indicate baseline reference ranges.+ #' `abnormal = list(Low = "LOW", High = "HIGH"))` |
||
| 12 |
- #'+ #' @param method (`string`)\cr indicates how the returned map will be constructed. Can be `"default"` or `"range"`. |
||
| 13 |
- #' For each direction specified via the `abnormal` parameter (e.g. High or Low), a fraction of+ #' |
||
| 14 |
- #' patient counts is returned, with numerator and denominator calculated as follows:+ #' @return A map `data.frame`. |
||
| 15 |
- #' * `num`: The number of patients with this abnormality recorded while on treatment.+ #' |
||
| 16 |
- #' * `denom`: The total number of patients with at least one post-baseline assessment.+ #' @note If method is `"default"`, the returned map will only have the abnormal directions that are observed in the |
||
| 17 |
- #'+ #' `df`, and records with all normal values will be excluded to avoid error in creating layout. If method is |
||
| 18 |
- #' This function assumes that `df` has been filtered to only include post-baseline records.+ #' `"range"`, the returned map will be based on the rule that at least one observation with low range > 0 |
||
| 19 |
- #'+ #' for low direction and at least one observation with high range is not missing for high direction. |
||
| 20 |
- #' @inheritParams argument_convention+ #' |
||
| 21 |
- #' @param abnormal (named `list`)\cr list identifying the abnormal range level(s) in `var`. Defaults to+ #' @examples |
||
| 22 |
- #' `list(Low = "LOW", High = "HIGH")` but you can also group different levels into the named list,+ #' adlb <- df_explicit_na(tern_ex_adlb) |
||
| 23 |
- #' for example, `abnormal = list(Low = c("LOW", "LOW LOW"), High = c("HIGH", "HIGH HIGH"))`.
+ #' |
||
| 24 |
- #' @param exclude_base_abn (`flag`)\cr whether to exclude subjects with baseline abnormality+ #' h_map_for_count_abnormal( |
||
| 25 |
- #' from numerator and denominator.+ #' df = adlb, |
||
| 26 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' variables = list(anl = "ANRIND", split_rows = c("LBCAT", "PARAM")),
|
||
| 27 |
- #'+ #' abnormal = list(low = c("LOW"), high = c("HIGH")),
|
||
| 28 |
- #' Options are: ``r shQuote(get_stats("abnormal"))``
+ #' method = "default", |
||
| 29 |
- #'+ #' na_str = "<Missing>" |
||
| 30 |
- #' @note+ #' ) |
||
| 31 |
- #' * `count_abnormal()` only considers a single variable that contains multiple abnormal levels.+ #' |
||
| 32 |
- #' * `df` should be filtered to only include post-baseline records.+ #' df <- data.frame( |
||
| 33 |
- #' * The denominator includes patients that may have other abnormal levels at baseline,+ #' USUBJID = c(rep("1", 4), rep("2", 4), rep("3", 4)),
|
||
| 34 |
- #' and patients missing baseline records. Patients with these abnormalities at+ #' AVISIT = c( |
||
| 35 |
- #' baseline can be optionally excluded from numerator and denominator via the+ #' rep("WEEK 1", 2),
|
||
| 36 |
- #' `exclude_base_abn` parameter.+ #' rep("WEEK 2", 2),
|
||
| 37 |
- #'+ #' rep("WEEK 1", 2),
|
||
| 38 |
- #' @name abnormal+ #' rep("WEEK 2", 2),
|
||
| 39 |
- #' @include formatting_functions.R+ #' rep("WEEK 1", 2),
|
||
| 40 |
- #' @order 1+ #' rep("WEEK 2", 2)
|
||
| 41 |
- NULL+ #' ), |
||
| 42 |
-
+ #' PARAM = rep(c("ALT", "CPR"), 6),
|
||
| 43 |
- #' @describeIn abnormal Statistics function which counts patients with abnormal range values+ #' ANRIND = c( |
||
| 44 |
- #' for a single `abnormal` level.+ #' "NORMAL", "NORMAL", "LOW", |
||
| 45 |
- #'+ #' "HIGH", "LOW", "LOW", "HIGH", "HIGH", rep("NORMAL", 4)
|
||
| 46 |
- #' @return+ #' ), |
||
| 47 |
- #' * `s_count_abnormal()` returns the statistic `fraction` which is a vector with `num` and `denom` counts of patients.+ #' ANRLO = rep(5, 12), |
||
| 48 |
- #'+ #' ANRHI = rep(20, 12) |
||
| 49 |
- #' @keywords internal+ #' ) |
||
| 50 |
- s_count_abnormal <- function(df,+ #' df$ANRIND <- factor(df$ANRIND, levels = c("LOW", "HIGH", "NORMAL"))
|
||
| 51 |
- .var,+ #' h_map_for_count_abnormal( |
||
| 52 |
- abnormal = list(Low = "LOW", High = "HIGH"),+ #' df = df, |
||
| 53 |
- variables = list(id = "USUBJID", baseline = "BNRIND"),+ #' variables = list( |
||
| 54 |
- exclude_base_abn = FALSE) {
+ #' anl = "ANRIND", |
||
| 55 | -4x | +
- checkmate::assert_list(abnormal, types = "character", names = "named", len = 2, any.missing = FALSE)+ #' split_rows = c("PARAM"),
|
|
| 56 | -4x | +
- checkmate::assert_true(any(unlist(abnormal) %in% levels(df[[.var]])))+ #' range_low = "ANRLO", |
|
| 57 | -4x | +
- checkmate::assert_factor(df[[.var]])+ #' range_high = "ANRHI" |
|
| 58 | -4x | +
- checkmate::assert_flag(exclude_base_abn)+ #' ), |
|
| 59 | -4x | +
- assert_df_with_variables(df, c(range = .var, variables))+ #' abnormal = list(low = c("LOW"), high = c("HIGH")),
|
|
| 60 | -4x | +
- checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
+ #' method = "range", |
|
| 61 | -4x | +
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ #' na_str = "<Missing>" |
|
| 62 |
-
+ #' ) |
||
| 63 | -4x | +
- count_abnormal_single <- function(abn_name, abn) {
+ #' |
|
| 64 |
- # Patients in the denominator fulfill:+ #' @export |
||
| 65 |
- # - have at least one post-baseline visit+ h_map_for_count_abnormal <- function(df, |
||
| 66 |
- # - their baseline must not be abnormal if `exclude_base_abn`.+ variables = list( |
||
| 67 | -8x | +
- if (exclude_base_abn) {
+ anl = "ANRIND", |
|
| 68 | -4x | +
- denom_select <- !(df[[variables$baseline]] %in% abn)+ split_rows = c("PARAM"),
|
|
| 69 |
- } else {
+ range_low = "ANRLO", |
||
| 70 | -4x | +
- denom_select <- TRUE+ range_high = "ANRHI" |
|
| 71 |
- }+ ), |
||
| 72 | -8x | +
- denom <- length(unique(df[denom_select, variables$id, drop = TRUE]))+ abnormal = list(low = c("LOW", "LOW LOW"), high = c("HIGH", "HIGH HIGH")),
|
|
| 73 |
-
+ method = c("default", "range"),
|
||
| 74 |
- # Patients in the numerator fulfill:+ na_str = "<Missing>") {
|
||
| 75 | -+ | 7x |
- # - have at least one post-baseline visit with the required abnormality level+ method <- match.arg(method) |
| 76 | -+ | 7x |
- # - are part of the denominator patients.+ checkmate::assert_subset(c("anl", "split_rows"), names(variables))
|
| 77 | -8x | +7x |
- num_select <- (df[[.var]] %in% abn) & denom_select+ checkmate::assert_false(anyNA(df[variables$split_rows])) |
| 78 | -8x | +7x |
- num <- length(unique(df[num_select, variables$id, drop = TRUE]))+ assert_df_with_variables(df, |
| 79 | -+ | 7x |
-
+ variables = list(anl = variables$anl, split_rows = variables$split_rows), |
| 80 | -8x | +7x |
- formatters::with_label(c(num = num, denom = denom), abn_name)+ na_level = na_str |
| 81 |
- }+ ) |
||
| 82 | -+ | 7x |
-
+ assert_df_with_factors(df, list(val = variables$anl)) |
| 83 | -+ | 7x |
- # This will define the abnormal levels theoretically possible for a specific lab parameter+ assert_valid_factor(df[[variables$anl]], any.missing = FALSE) |
| 84 | -+ | 7x |
- # within a split level of a layout.+ assert_list_of_variables(variables) |
| 85 | -4x | +7x |
- abnormal_lev <- lapply(abnormal, intersect, levels(df[[.var]]))+ checkmate::assert_list(abnormal, types = "character", len = 2) |
| 86 | -4x | +
- abnormal_lev <- abnormal_lev[vapply(abnormal_lev, function(x) length(x) > 0, logical(1))]+ |
|
| 87 |
-
+ # Drop usued levels from df as they are not supposed to be in the final map |
||
| 88 | -4x | +7x |
- result <- sapply(names(abnormal_lev), function(i) count_abnormal_single(i, abnormal_lev[[i]]), simplify = FALSE)+ df <- droplevels(df) |
| 89 | -4x | +
- result <- list(fraction = result)+ |
|
| 90 | -4x | +7x |
- result+ normal_value <- setdiff(levels(df[[variables$anl]]), unlist(abnormal)) |
| 91 |
- }+ |
||
| 92 |
-
+ # Based on the understanding of clinical data, there should only be one level of normal which is "NORMAL" |
||
| 93 | -+ | 7x |
- #' @describeIn abnormal Formatted analysis function which is used as `afun` in `count_abnormal()`.+ checkmate::assert_vector(normal_value, len = 1) |
| 94 |
- #'+ |
||
| 95 |
- #' @return+ # Default method will only have what is observed in the df, and records with all normal values will be excluded to |
||
| 96 |
- #' * `a_count_abnormal()` returns the corresponding list with formatted [rtables::CellValue()].+ # avoid error in layout building. |
||
| 97 | -+ | 7x |
- #'+ if (method == "default") {
|
| 98 | -+ | 3x |
- #' @keywords internal+ df_abnormal <- subset(df, df[[variables$anl]] %in% unlist(abnormal)) |
| 99 | -+ | 3x |
- a_count_abnormal <- make_afun(+ map <- unique(df_abnormal[c(variables$split_rows, variables$anl)]) |
| 100 | -+ | 3x |
- s_count_abnormal,+ map_normal <- unique(subset(map, select = variables$split_rows)) |
| 101 | -+ | 3x |
- .formats = c(fraction = format_fraction)+ map_normal[[variables$anl]] <- normal_value |
| 102 | -+ | 3x |
- )+ map <- rbind(map, map_normal) |
| 103 | -+ | 4x |
-
+ } else if (method == "range") {
|
| 104 |
- #' @describeIn abnormal Layout-creating function which can take statistics function arguments+ # range method follows the rule that at least one observation with ANRLO > 0 for low |
||
| 105 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ # direction and at least one observation with ANRHI is not missing for high direction. |
||
| 106 | -+ | 4x |
- #'+ checkmate::assert_subset(c("range_low", "range_high"), names(variables))
|
| 107 | -+ | 4x |
- #' @return+ checkmate::assert_subset(c("LOW", "HIGH"), toupper(names(abnormal)))
|
| 108 |
- #' * `count_abnormal()` returns a layout object suitable for passing to further layouting functions,+ |
||
| 109 | -+ | 4x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ assert_df_with_variables(df, |
| 110 | -+ | 4x |
- #' the statistics from `s_count_abnormal()` to the table layout.+ variables = list( |
| 111 | -+ | 4x |
- #'+ range_low = variables$range_low, |
| 112 | -+ | 4x |
- #' @examples+ range_high = variables$range_high |
| 113 |
- #' library(dplyr)+ ) |
||
| 114 |
- #'+ ) |
||
| 115 |
- #' df <- data.frame(+ |
||
| 116 |
- #' USUBJID = as.character(c(1, 1, 2, 2)),+ # Define low direction of map |
||
| 117 | -+ | 4x |
- #' ANRIND = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
+ df_low <- subset(df, df[[variables$range_low]] > 0) |
| 118 | -+ | 4x |
- #' BNRIND = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
+ map_low <- unique(df_low[variables$split_rows]) |
| 119 | -+ | 4x |
- #' ONTRTFL = c("", "Y", "", "Y"),
+ low_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "LOW"])) |
| 120 | -+ | 4x |
- #' stringsAsFactors = FALSE+ low_levels_df <- as.data.frame(low_levels) |
| 121 | -+ | 4x |
- #' )+ colnames(low_levels_df) <- variables$anl |
| 122 | -+ | 4x |
- #'+ low_levels_df <- do.call("rbind", replicate(nrow(map_low), low_levels_df, simplify = FALSE))
|
| 123 | -+ | 4x |
- #' # Select only post-baseline records.+ rownames(map_low) <- NULL # Just to avoid strange row index in case upstream functions changed |
| 124 | -+ | 4x |
- #' df <- df %>%+ map_low <- map_low[rep(seq_len(nrow(map_low)), each = length(low_levels)), , drop = FALSE] |
| 125 | -+ | 4x |
- #' filter(ONTRTFL == "Y")+ map_low <- cbind(map_low, low_levels_df) |
| 126 |
- #'+ |
||
| 127 |
- #' # Layout creating function.+ # Define high direction of map |
||
| 128 | -+ | 4x |
- #' basic_table() %>%+ df_high <- subset(df, df[[variables$range_high]] != na_str | !is.na(df[[variables$range_high]])) |
| 129 | -+ | 4x |
- #' count_abnormal(var = "ANRIND", abnormal = list(high = "HIGH", low = "LOW")) %>%+ map_high <- unique(df_high[variables$split_rows]) |
| 130 | -+ | 4x |
- #' build_table(df)+ high_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "HIGH"])) |
| 131 | -+ | 4x |
- #'+ high_levels_df <- as.data.frame(high_levels) |
| 132 | -+ | 4x |
- #' # Passing of statistics function and formatting arguments.+ colnames(high_levels_df) <- variables$anl |
| 133 | -+ | 4x |
- #' df2 <- data.frame(+ high_levels_df <- do.call("rbind", replicate(nrow(map_high), high_levels_df, simplify = FALSE))
|
| 134 | -+ | 4x |
- #' ID = as.character(c(1, 1, 2, 2)),+ rownames(map_high) <- NULL |
| 135 | -+ | 4x |
- #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
+ map_high <- map_high[rep(seq_len(nrow(map_high)), each = length(high_levels)), , drop = FALSE] |
| 136 | -+ | 4x |
- #' BL_RANGE = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
+ map_high <- cbind(map_high, high_levels_df) |
| 137 |
- #' ONTRTFL = c("", "Y", "", "Y"),
+
|
||
| 138 |
- #' stringsAsFactors = FALSE+ # Define normal of map |
||
| 139 | -+ | 4x |
- #' )+ map_normal <- unique(rbind(map_low, map_high)[variables$split_rows]) |
| 140 | -+ | 4x |
- #'+ map_normal[variables$anl] <- normal_value |
| 141 |
- #' # Select only post-baseline records.+ |
||
| 142 | -+ | 4x |
- #' df2 <- df2 %>%+ map <- rbind(map_low, map_high, map_normal) |
| 143 |
- #' filter(ONTRTFL == "Y")+ } |
||
| 144 |
- #'+ |
||
| 145 |
- #' basic_table() %>%+ # map should be all characters |
||
| 146 | -+ | 7x |
- #' count_abnormal(+ map <- data.frame(lapply(map, as.character), stringsAsFactors = FALSE) |
| 147 |
- #' var = "RANGE",+ |
||
| 148 |
- #' abnormal = list(low = "LOW", high = "HIGH"),+ # sort the map final output by split_rows variables |
||
| 149 | -+ | 7x |
- #' variables = list(id = "ID", baseline = "BL_RANGE")+ for (i in rev(seq_len(length(variables$split_rows)))) {
|
| 150 | -+ | 7x |
- #' ) %>%+ map <- map[order(map[[i]]), ] |
| 151 |
- #' build_table(df2)+ } |
||
| 152 | -+ | 7x |
- #'+ map |
| 153 | - |
- #' @export- |
- |
| 154 | -- |
- #' @order 2- |
- |
| 155 | -- |
- count_abnormal <- function(lyt,- |
- |
| 156 | -- |
- var,- |
- |
| 157 | -- |
- abnormal = list(Low = "LOW", High = "HIGH"),- |
- |
| 158 | -- |
- variables = list(id = "USUBJID", baseline = "BNRIND"),- |
- |
| 159 | -- |
- exclude_base_abn = FALSE,- |
- |
| 160 | -- |
- na_str = default_na_str(),- |
- |
| 161 | -- |
- nested = TRUE,- |
- |
| 162 | -- |
- ...,- |
- |
| 163 | -- |
- table_names = var,- |
- |
| 164 | -- |
- .stats = NULL,- |
- |
| 165 | -- |
- .formats = NULL,- |
- |
| 166 | -- |
- .labels = NULL,- |
- |
| 167 | -- |
- .indent_mods = NULL) {
- |
- |
| 168 | -3x | -
- extra_args <- list(abnormal = abnormal, variables = variables, exclude_base_abn = exclude_base_abn, ...)- |
- |
| 169 | -- | - - | -|
| 170 | -3x | -
- afun <- make_afun(- |
- |
| 171 | -3x | -
- a_count_abnormal,- |
- |
| 172 | -3x | -
- .stats = .stats,- |
- |
| 173 | -3x | -
- .formats = .formats,- |
- |
| 174 | -3x | -
- .labels = .labels,- |
- |
| 175 | -3x | -
- .indent_mods = .indent_mods,- |
- |
| 176 | -3x | -
- .ungroup_stats = "fraction"- |
- |
| 177 | -- |
- )- |
- |
| 178 | -- | - - | -|
| 179 | -3x | -
- checkmate::assert_string(var)- |
- |
| 180 | -- | - - | -|
| 181 | -3x | -
- analyze(- |
- |
| 182 | -3x | -
- lyt = lyt,- |
- |
| 183 | -3x | -
- vars = var,- |
- |
| 184 | -3x | -
- afun = afun,- |
- |
| 185 | -3x | -
- na_str = na_str,- |
- |
| 186 | -3x | -
- nested = nested,- |
- |
| 187 | -3x | -
- table_names = table_names,- |
- |
| 188 | -3x | -
- extra_args = extra_args,- |
- |
| 189 | -3x | -
- show_labels = "hidden"- |
- |
| 190 | -- |
- )- |
- |
| 191 | -
} |
@@ -161155,14 +163588,14 @@
| 1 |
- #' Estimate proportions of each level of a variable+ #' Helper functions for accessing information from `rtables` |
|||
| 5 |
- #' The analyze & summarize function [estimate_multinomial_response()] creates a layout element to estimate the+ #' These are a couple of functions that help with accessing the data in `rtables` objects. |
|||
| 6 |
- #' proportion and proportion confidence interval for each level of a factor variable. The primary analysis variable,+ #' Currently these work for occurrence tables, which are defined as having a count as the first |
|||
| 7 |
- #' `var`, should be a factor variable, the values of which will be used as labels within the output table.+ #' element and a fraction as the second element in each cell. |
|||
| 9 |
- #' @inheritParams argument_convention+ #' @seealso [prune_occurrences] for usage of these functions. |
|||
| 10 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' |
|||
| 11 |
- #'+ #' @name rtables_access |
|||
| 12 |
- #' Options are: ``r shQuote(get_stats("estimate_multinomial_response"))``
+ NULL |
|||
| 13 |
- #'+ |
|||
| 14 |
- #' @seealso Relevant description function [d_onco_rsp_label()].+ #' @describeIn rtables_access Helper function to extract the first values from each content |
|||
| 15 |
- #'+ #' cell and from specified columns in a `TableRow`. Defaults to all columns. |
|||
| 16 |
- #' @name estimate_multinomial_rsp+ #' |
|||
| 17 |
- #' @order 1+ #' @param table_row (`TableRow`)\cr an analysis row in a occurrence table. |
|||
| 18 |
- NULL+ #' @param col_names (`character`)\cr the names of the columns to extract from. |
|||
| 19 |
-
+ #' @param col_indices (`integer`)\cr the indices of the columns to extract from. If `col_names` are provided, |
|||
| 20 |
- #' Description of standard oncology response+ #' then these are inferred from the names of `table_row`. Note that this currently only works well with a single |
|||
| 21 |
- #'+ #' column split. |
|||
| 22 |
- #' @description `r lifecycle::badge("stable")`
+ #' |
|||
| 23 |
- #'+ #' @return |
|||
| 24 |
- #' Describe the oncology response in a standard way.+ #' * `h_row_first_values()` returns a `vector` of numeric values. |
|||
| 26 |
- #' @param x (`character`)\cr the standard oncology codes to be described.+ #' @examples |
|||
| 27 |
- #'+ #' tbl <- basic_table() %>% |
|||
| 28 |
- #' @return Response labels.+ #' split_cols_by("ARM") %>%
|
|||
| 29 |
- #'+ #' split_rows_by("RACE") %>%
|
|||
| 30 |
- #' @seealso [estimate_multinomial_rsp()]+ #' analyze("AGE", function(x) {
|
|||
| 31 |
- #'+ #' list( |
|||
| 32 |
- #' @examples+ #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.x (xx.x)"), |
|||
| 33 |
- #' d_onco_rsp_label(+ #' "n" = length(x), |
|||
| 34 |
- #' c("CR", "PR", "SD", "NON CR/PD", "PD", "NE", "Missing", "<Missing>", "NE/Missing")
+ #' "frac" = rcell(c(0.1, 0.1), format = "xx (xx)") |
|||
| 35 |
- #' )+ #' ) |
|||
| 36 |
- #'+ #' }) %>% |
|||
| 37 |
- #' # Adding some values not considered in d_onco_rsp_label+ #' build_table(tern_ex_adsl) %>% |
|||
| 38 |
- #'+ #' prune_table() |
|||
| 39 |
- #' d_onco_rsp_label(+ #' tree_row_elem <- collect_leaves(tbl[2, ])[[1]] |
|||
| 40 |
- #' c("CR", "PR", "hello", "hi")
+ #' result <- max(h_row_first_values(tree_row_elem)) |
|||
| 41 |
- #' )+ #' result |
|||
| 44 |
- d_onco_rsp_label <- function(x) {
+ h_row_first_values <- function(table_row, |
|||
| 45 | -2x | +
- x <- as.character(x)+ col_names = NULL, |
||
| 46 | -2x | +
- desc <- c(+ col_indices = NULL) {
|
||
| 47 | -2x | +745x |
- CR = "Complete Response (CR)",+ col_indices <- check_names_indices(table_row, col_names, col_indices) |
|
| 48 | -2x | +744x |
- PR = "Partial Response (PR)",+ checkmate::assert_integerish(col_indices) |
|
| 49 | -2x | +744x |
- MR = "Minimal/Minor Response (MR)",+ checkmate::assert_subset(col_indices, seq_len(ncol(table_row))) |
|
| 50 | -2x | +
- MRD = "Minimal Residual Disease (MRD)",+ |
||
| 51 | -2x | +
- SD = "Stable Disease (SD)",+ # Main values are extracted |
||
| 52 | -2x | +744x |
- PD = "Progressive Disease (PD)",+ row_vals <- row_values(table_row)[col_indices] |
|
| 53 | -2x | +
- `NON CR/PD` = "Non-CR or Non-PD (NON CR/PD)",+ |
||
| 54 | -2x | +
- NE = "Not Evaluable (NE)",+ # Main return |
||
| 55 | -2x | +744x |
- `NE/Missing` = "Missing or unevaluable",+ vapply(row_vals, function(rv) {
|
|
| 56 | -2x | +2096x |
- Missing = "Missing",+ if (is.null(rv)) {
|
|
| 57 | -2x | -
- `NA` = "Not Applicable (NA)",- |
- ||
| 58 | -2x | -
- ND = "Not Done (ND)"- |
- ||
| 59 | -+ | 744x |
- )+ NA_real_ |
|
| 60 | +58 | - - | -||
| 61 | -2x | -
- values_label <- vapply(- |
- ||
| 62 | -2x | -
- X = x,- |
- ||
| 63 | -2x | -
- FUN.VALUE = character(1),+ } else {
|
||
| 64 | -2x | -
- function(val) {
- |
- ||
| 65 | -! | +59 | +2090x |
- if (val %in% names(desc)) desc[val] else val+ rv[1L] |
| 66 | +60 |
} |
||
| 67 | -- |
- )- |
- ||
| 68 | -- | - - | -||
| 69 | -2x | -
- return(factor(values_label, levels = c(intersect(desc, values_label), setdiff(values_label, desc))))- |
- ||
| 70 | -- |
- }- |
- ||
| 71 | -- | - - | -||
| 72 | -- |
- #' @describeIn estimate_multinomial_rsp Statistics function which feeds the length of `x` as number- |
- ||
| 73 | -- |
- #' of successes, and `.N_col` as total number of successes and failures into [s_proportion()].- |
- ||
| 74 | -- |
- #'- |
- ||
| 75 | -- |
- #' @return- |
- ||
| 76 | -- |
- #' * `s_length_proportion()` returns statistics from [s_proportion()].- |
- ||
| 77 | -- |
- #'- |
- ||
| 78 | -- |
- #' @examples- |
- ||
| 79 | -- |
- #' s_length_proportion(rep("CR", 10), .N_col = 100)
- |
- ||
| 80 | -- |
- #' s_length_proportion(factor(character(0)), .N_col = 100)- |
- ||
| 81 | -- |
- #'- |
- ||
| 82 | -- |
- #' @export- |
- ||
| 83 | -- |
- s_length_proportion <- function(x,- |
- ||
| 84 | -- |
- .N_col, # nolint- |
- ||
| 85 | -- |
- ...) {
- |
- ||
| 86 | -4x | -
- checkmate::assert_multi_class(x, classes = c("factor", "character"))
- |
- ||
| 87 | -3x | -
- checkmate::assert_vector(x, min.len = 0, max.len = .N_col)- |
- ||
| 88 | -2x | -
- checkmate::assert_vector(unique(x), min.len = 0, max.len = 1)- |
- ||
| 89 | -- | - - | -||
| 90 | -1x | -
- n_true <- length(x)- |
- ||
| 91 | -1x | -
- n_false <- .N_col - n_true- |
- ||
| 92 | -1x | -
- x_logical <- rep(c(TRUE, FALSE), c(n_true, n_false))- |
- ||
| 93 | -1x | +61 | +744x |
- s_proportion(df = x_logical, ...)+ }, FUN.VALUE = numeric(1)) |
| 94 | +62 |
} |
||
| 95 | -- | - - | -||
| 96 | -- |
- #' @describeIn estimate_multinomial_rsp Formatted analysis function which is used as `afun`- |
- ||
| 97 | -- |
- #' in `estimate_multinomial_response()`.- |
- ||
| 98 | -- |
- #'- |
- ||
| 99 | -- |
- #' @return- |
- ||
| 100 | -- |
- #' * `a_length_proportion()` returns the corresponding list with formatted [rtables::CellValue()].- |
- ||
| 101 | -- |
- #'- |
- ||
| 102 | -- |
- #' @examples- |
- ||
| 103 | -- |
- #' a_length_proportion(rep("CR", 10), .N_col = 100)
- |
- ||
| 104 | -- |
- #' a_length_proportion(factor(character(0)), .N_col = 100)- |
- ||
| 105 | -- |
- #'- |
- ||
| 106 | -- |
- #' @export- |
- ||
| 107 | -- |
- a_length_proportion <- make_afun(- |
- ||
| 108 | -- |
- s_length_proportion,- |
- ||
| 109 | -- |
- .formats = c(- |
- ||
| 110 | -- |
- n_prop = "xx (xx.x%)",- |
- ||
| 111 | -- |
- prop_ci = "(xx.xx, xx.xx)"- |
- ||
| 112 | -- |
- )- |
- ||
| 113 | -- |
- )- |
- ||
| 114 | +63 | |||
| 115 | -- |
- #' @describeIn estimate_multinomial_rsp Layout-creating function which can take statistics function arguments- |
- ||
| 116 | +64 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()] and+ #' @describeIn rtables_access Helper function that extracts row values and checks if they are |
||
| 117 | +65 |
- #' [rtables::summarize_row_groups()].+ #' convertible to integers (`integerish` values). |
||
| 118 | +66 |
#' |
||
| 119 | +67 |
#' @return |
||
| 120 | -- |
- #' * `estimate_multinomial_response()` returns a layout object suitable for passing to further layouting functions,- |
- ||
| 121 | -- |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing- |
- ||
| 122 | -- |
- #' the statistics from `s_length_proportion()` to the table layout.- |
- ||
| 123 | -- |
- #'- |
- ||
| 124 | -- |
- #' @examples- |
- ||
| 125 | -- |
- #' library(dplyr)- |
- ||
| 126 | -- |
- #'- |
- ||
| 127 | -- |
- #' # Use of the layout creating function.- |
- ||
| 128 | -- |
- #' dta_test <- data.frame(- |
- ||
| 129 | -- |
- #' USUBJID = paste0("S", 1:12),
- |
- ||
| 130 | -- |
- #' ARM = factor(rep(LETTERS[1:3], each = 4)),- |
- ||
| 131 | -- |
- #' AVAL = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0))- |
- ||
| 132 | -- |
- #' ) %>% mutate(- |
- ||
| 133 | -- |
- #' AVALC = factor(AVAL,- |
- ||
| 134 | -- |
- #' levels = c(0, 1),- |
- ||
| 135 | -- |
- #' labels = c("Complete Response (CR)", "Partial Response (PR)")
- |
- ||
| 136 | -- |
- #' )- |
- ||
| 137 | -- |
- #' )- |
- ||
| 138 | -- |
- #'- |
- ||
| 139 | -- |
- #' lyt <- basic_table() %>%- |
- ||
| 140 | -- |
- #' split_cols_by("ARM") %>%
- |
- ||
| 141 | -- |
- #' estimate_multinomial_response(var = "AVALC")- |
- ||
| 142 | -- |
- #'- |
- ||
| 143 | -- |
- #' tbl <- build_table(lyt, dta_test)- |
- ||
| 144 | -- |
- #'- |
- ||
| 145 | -- |
- #' tbl- |
- ||
| 146 | -- |
- #'- |
- ||
| 147 | -- |
- #' @export- |
- ||
| 148 | -- |
- #' @order 2- |
- ||
| 149 | -- |
- estimate_multinomial_response <- function(lyt,- |
- ||
| 150 | -- |
- var,- |
- ||
| 151 | -- |
- na_str = default_na_str(),- |
- ||
| 152 | -- |
- nested = TRUE,- |
- ||
| 153 | -- |
- ...,- |
- ||
| 154 | -- |
- show_labels = "hidden",- |
- ||
| 155 | -- |
- table_names = var,- |
- ||
| 156 | -- |
- .stats = "prop_ci",- |
- ||
| 157 | -- |
- .formats = NULL,- |
- ||
| 158 | -- |
- .labels = NULL,- |
- ||
| 159 | -- |
- .indent_mods = NULL) {
- |
- ||
| 160 | -1x | -
- extra_args <- list(...)- |
- ||
| 161 | +68 | - - | -||
| 162 | -1x | -
- afun <- make_afun(- |
- ||
| 163 | -1x | -
- a_length_proportion,- |
- ||
| 164 | -1x | -
- .stats = .stats,+ #' * `h_row_counts()` returns a `vector` of numeric values. |
||
| 165 | -1x | +|||
| 69 | +
- .formats = .formats,+ #' |
|||
| 166 | -1x | +|||
| 70 | +
- .labels = .labels,+ #' @examples |
|||
| 167 | -1x | +|||
| 71 | +
- .indent_mods = .indent_mods+ #' # Row counts (integer values) |
|||
| 168 | +72 |
- )+ #' # h_row_counts(tree_row_elem) # Fails because there are no integers |
||
| 169 | -1x | +|||
| 73 | +
- lyt <- split_rows_by(lyt, var = var)+ #' # Using values with integers |
|||
| 170 | -1x | +|||
| 74 | +
- lyt <- summarize_row_groups(lyt, na_str = na_str)+ #' tree_row_elem <- collect_leaves(tbl[3, ])[[1]] |
|||
| 171 | +75 |
-
+ #' result <- h_row_counts(tree_row_elem) |
||
| 172 | -1x | +|||
| 76 | +
- analyze(+ #' # result |
|||
| 173 | -1x | +|||
| 77 | +
- lyt,+ #' |
|||
| 174 | -1x | +|||
| 78 | +
- vars = var,+ #' @export |
|||
| 175 | -1x | +|||
| 79 | +
- afun = afun,+ h_row_counts <- function(table_row, |
|||
| 176 | -1x | +|||
| 80 | +
- show_labels = show_labels,+ col_names = NULL, |
|||
| 177 | -1x | +|||
| 81 | +
- table_names = table_names,+ col_indices = NULL) {
|
|||
| 178 | -1x | +82 | +741x |
- na_str = na_str,+ counts <- h_row_first_values(table_row, col_names, col_indices) |
| 179 | -1x | +83 | +741x |
- nested = nested,+ checkmate::assert_integerish(counts) |
| 180 | -1x | -
- extra_args = extra_args- |
- ||
| 181 | -+ | 84 | +741x |
- )+ counts |
| 182 | +85 |
} |
| 1 | +86 |
- #' Summarize variables in columns+ |
||
| 2 | +87 |
- #'+ #' @describeIn rtables_access Helper function to extract fractions from specified columns in a `TableRow`. |
||
| 3 | +88 |
- #' @description `r lifecycle::badge("stable")`
+ #' More specifically it extracts the second values from each content cell and checks it is a fraction. |
||
| 4 | +89 |
#' |
||
| 5 | +90 |
- #' The analyze function [summarize_colvars()] uses the statistics function [s_summary()] to analyze variables that are+ #' @return |
||
| 6 | +91 |
- #' arranged in columns. The variables to analyze should be specified in the table layout via column splits (see+ #' * `h_row_fractions()` returns a `vector` of proportions. |
||
| 7 | +92 |
- #' [rtables::split_cols_by()] and [rtables::split_cols_by_multivar()]) prior to using [summarize_colvars()].+ #' |
||
| 8 | +93 |
- #'+ #' @examples |
||
| 9 | +94 |
- #' The function is a minimal wrapper for [rtables::analyze_colvars()], a function typically used to apply different+ #' # Row fractions |
||
| 10 | +95 |
- #' analysis methods in rows for each column variable. To use the analysis methods as column labels, please refer to+ #' tree_row_elem <- collect_leaves(tbl[4, ])[[1]] |
||
| 11 | +96 |
- #' the [analyze_vars_in_cols()] function.+ #' h_row_fractions(tree_row_elem) |
||
| 12 | +97 |
#' |
||
| 13 | +98 |
- #' @inheritParams argument_convention+ #' @export |
||
| 14 | +99 |
- #' @param ... arguments passed to [s_summary()].+ h_row_fractions <- function(table_row, |
||
| 15 | +100 |
- #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ col_names = NULL, |
||
| 16 | +101 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ col_indices = NULL) {
|
||
| 17 | -+ | |||
| 102 | +250x |
- #' for that statistic's row label.+ col_indices <- check_names_indices(table_row, col_names, col_indices) |
||
| 18 | -+ | |||
| 103 | +250x |
- #'+ row_vals <- row_values(table_row)[col_indices] |
||
| 19 | -+ | |||
| 104 | +250x |
- #' @return+ fractions <- sapply(row_vals, "[", 2L) |
||
| 20 | -+ | |||
| 105 | +250x |
- #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()].+ checkmate::assert_numeric(fractions, lower = 0, upper = 1) |
||
| 21 | -+ | |||
| 106 | +250x |
- #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output+ fractions |
||
| 22 | +107 |
- #' in columns, and add it to the table layout.+ } |
||
| 23 | +108 |
- #'+ |
||
| 24 | +109 |
- #' @seealso [rtables::split_cols_by_multivar()] and [`analyze_colvars_functions`].+ #' @describeIn rtables_access Helper function to extract column counts from specified columns in a table. |
||
| 25 | +110 |
#' |
||
| 26 | +111 |
- #' @examples+ #' @param table (`VTableNodeInfo`)\cr an occurrence table or row. |
||
| 27 | +112 |
- #' dta_test <- data.frame(+ #' |
||
| 28 | +113 |
- #' USUBJID = rep(1:6, each = 3),+ #' @return |
||
| 29 | +114 |
- #' PARAMCD = rep("lab", 6 * 3),
+ #' * `h_col_counts()` returns a `vector` of column counts. |
||
| 30 | +115 |
- #' AVISIT = rep(paste0("V", 1:3), 6),
+ #' |
||
| 31 | +116 |
- #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ #' @export |
||
| 32 | +117 |
- #' AVAL = c(9:1, rep(NA, 9)),+ h_col_counts <- function(table, |
||
| 33 | +118 |
- #' CHG = c(1:9, rep(NA, 9))+ col_names = NULL, |
||
| 34 | +119 |
- #' )+ col_indices = NULL) {
|
||
| 35 | -+ | |||
| 120 | +307x |
- #'+ col_indices <- check_names_indices(table, col_names, col_indices) |
||
| 36 | -+ | |||
| 121 | +307x |
- #' ## Default output within a `rtables` pipeline.+ counts <- col_counts(table)[col_indices] |
||
| 37 | -+ | |||
| 122 | +307x |
- #' basic_table() %>%+ stats::setNames(counts, col_names) |
||
| 38 | +123 |
- #' split_cols_by("ARM") %>%
+ } |
||
| 39 | +124 |
- #' split_rows_by("AVISIT") %>%
+
|
||
| 40 | +125 |
- #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
+ #' @describeIn rtables_access Helper function to get first row of content table of current table. |
||
| 41 | +126 |
- #' summarize_colvars() %>%+ #' |
||
| 42 | +127 |
- #' build_table(dta_test)+ #' @return |
||
| 43 | +128 |
- #'+ #' * `h_content_first_row()` returns a row from an `rtables` table. |
||
| 44 | +129 |
- #' ## Selection of statistics, formats and labels also work.+ #' |
||
| 45 | +130 |
- #' basic_table() %>%+ #' @export |
||
| 46 | +131 |
- #' split_cols_by("ARM") %>%
+ h_content_first_row <- function(table) {
|
||
| 47 | -+ | |||
| 132 | +27x |
- #' split_rows_by("AVISIT") %>%
+ ct <- content_table(table) |
||
| 48 | -+ | |||
| 133 | +27x |
- #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
+ tree_children(ct)[[1]] |
||
| 49 | +134 |
- #' summarize_colvars(+ } |
||
| 50 | +135 |
- #' .stats = c("n", "mean_sd"),
+
|
||
| 51 | +136 |
- #' .formats = c("mean_sd" = "xx.x, xx.x"),
+ #' @describeIn rtables_access Helper function which says whether current table is a leaf in the tree. |
||
| 52 | +137 |
- #' .labels = c(n = "n", mean_sd = "Mean, SD")+ #' |
||
| 53 | +138 |
- #' ) %>%+ #' @return |
||
| 54 | +139 |
- #' build_table(dta_test)+ #' * `is_leaf_table()` returns a `logical` value indicating whether current table is a leaf. |
||
| 55 | +140 |
#' |
||
| 56 | +141 |
- #' ## Use arguments interpreted by `s_summary`.+ #' @keywords internal |
||
| 57 | +142 |
- #' basic_table() %>%+ is_leaf_table <- function(table) {
|
||
| 58 | -+ | |||
| 143 | +168x |
- #' split_cols_by("ARM") %>%
+ children <- tree_children(table) |
||
| 59 | -+ | |||
| 144 | +168x |
- #' split_rows_by("AVISIT") %>%
+ child_classes <- unique(sapply(children, class))+ |
+ ||
| 145 | +168x | +
+ identical(child_classes, "ElementaryTable") |
||
| 60 | +146 |
- #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
+ } |
||
| 61 | +147 |
- #' summarize_colvars(na.rm = FALSE) %>%+ |
||
| 62 | +148 |
- #' build_table(dta_test)+ #' @describeIn rtables_access Internal helper function that tests standard inputs for column indices. |
||
| 63 | +149 |
#' |
||
| 64 | +150 |
- #' @export+ #' @return |
||
| 65 | +151 |
- summarize_colvars <- function(lyt,+ #' * `check_names_indices` returns column indices. |
||
| 66 | +152 |
- ...,+ #' |
||
| 67 | +153 |
- na_str = default_na_str(),+ #' @keywords internal |
||
| 68 | +154 |
- .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
+ check_names_indices <- function(table_row, |
||
| 69 | +155 |
- .formats = NULL,+ col_names = NULL, |
||
| 70 | +156 |
- .labels = NULL,+ col_indices = NULL) {
|
||
| 71 | -+ | |||
| 157 | +1302x |
- .indent_mods = NULL) {
+ if (!is.null(col_names)) {
|
||
| 72 | -3x | +158 | +1256x |
- extra_args <- list(.stats = .stats, na_str = na_str, ...)+ if (!is.null(col_indices)) {
|
| 73 | +159 | 1x |
- if (!is.null(.formats)) extra_args[[".formats"]] <- .formats+ stop( |
|
| 74 | +160 | 1x |
- if (!is.null(.labels)) extra_args[[".labels"]] <- .labels+ "Inserted both col_names and col_indices when selecting row values. ", |
|
| 75 | +161 | 1x |
- if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods+ "Please choose one." |
|
| 76 | +162 |
-
+ ) |
||
| 77 | -3x | +|||
| 163 | +
- analyze_colvars(+ } |
|||
| 78 | -3x | +164 | +1255x |
- lyt,+ col_indices <- h_col_indices(table_row, col_names)+ |
+
| 165 | ++ |
+ } |
||
| 79 | -3x | +166 | +1301x |
- afun = a_summary,+ if (is.null(col_indices)) {
|
| 80 | -3x | +167 | +39x |
- na_str = na_str,+ ll <- ifelse(is.null(ncol(table_row)), length(table_row), ncol(table_row)) |
| 81 | -3x | +168 | +39x |
- extra_args = extra_args+ col_indices <- seq_len(ll) |
| 82 | +169 |
- )+ } |
||
| 83 | +170 | ++ | + + | +|
| 171 | +1301x | +
+ return(col_indices)+ |
+ ||
| 172 |
}@@ -163022,14 +164798,14 @@ tern coverage - 95.59% |
| 1 |
- #' Helper function to create a map data frame for `trim_levels_to_map()`+ #' Occurrence table sorting |
|||
| 5 |
- #' Helper function to create a map data frame from the input dataset, which can be used as an argument in the+ #' Functions to score occurrence table subtables and rows which can be used in the |
|||
| 6 |
- #' `trim_levels_to_map` split function. Based on different method, the map is constructed differently.+ #' sorting of occurrence tables. |
|||
| 8 |
- #' @inheritParams argument_convention+ #' @name score_occurrences |
|||
| 9 |
- #' @param abnormal (named `list`)\cr identifying the abnormal range level(s) in `df`. Based on the levels of+ NULL |
|||
| 10 |
- #' abnormality of the input dataset, it can be something like `list(Low = "LOW LOW", High = "HIGH HIGH")` or+ |
|||
| 11 |
- #' `abnormal = list(Low = "LOW", High = "HIGH"))`+ #' @describeIn score_occurrences Scoring function which sums the counts across all |
|||
| 12 |
- #' @param method (`string`)\cr indicates how the returned map will be constructed. Can be `"default"` or `"range"`.+ #' columns. It will fail if anything else but counts are used. |
|||
| 14 |
- #' @return A map `data.frame`.+ #' @inheritParams rtables_access |
|||
| 16 |
- #' @note If method is `"default"`, the returned map will only have the abnormal directions that are observed in the+ #' @return |
|||
| 17 |
- #' `df`, and records with all normal values will be excluded to avoid error in creating layout. If method is+ #' * `score_occurrences()` returns the sum of counts across all columns of a table row. |
|||
| 18 |
- #' `"range"`, the returned map will be based on the rule that at least one observation with low range > 0+ #' |
|||
| 19 |
- #' for low direction and at least one observation with high range is not missing for high direction.+ #' @seealso [h_row_first_values()] |
|||
| 22 |
- #' adlb <- df_explicit_na(tern_ex_adlb)+ #' lyt <- basic_table() %>% |
|||
| 23 |
- #'+ #' split_cols_by("ARM") %>%
|
|||
| 24 |
- #' h_map_for_count_abnormal(+ #' add_colcounts() %>% |
|||
| 25 |
- #' df = adlb,+ #' analyze_num_patients( |
|||
| 26 |
- #' variables = list(anl = "ANRIND", split_rows = c("LBCAT", "PARAM")),
+ #' vars = "USUBJID", |
|||
| 27 |
- #' abnormal = list(low = c("LOW"), high = c("HIGH")),
+ #' .stats = c("unique"),
|
|||
| 28 |
- #' method = "default",+ #' .labels = c("Total number of patients with at least one event")
|
|||
| 29 |
- #' na_str = "<Missing>"+ #' ) %>% |
|||
| 30 |
- #' )+ #' split_rows_by("AEBODSYS", child_labels = "visible", nested = FALSE) %>%
|
|||
| 31 |
- #'+ #' summarize_num_patients( |
|||
| 32 |
- #' df <- data.frame(+ #' var = "USUBJID", |
|||
| 33 |
- #' USUBJID = c(rep("1", 4), rep("2", 4), rep("3", 4)),
+ #' .stats = c("unique", "nonunique"),
|
|||
| 34 |
- #' AVISIT = c(+ #' .labels = c( |
|||
| 35 |
- #' rep("WEEK 1", 2),
+ #' "Total number of patients with at least one event", |
|||
| 36 |
- #' rep("WEEK 2", 2),
+ #' "Total number of events" |
|||
| 37 |
- #' rep("WEEK 1", 2),
+ #' ) |
|||
| 38 |
- #' rep("WEEK 2", 2),
+ #' ) %>% |
|||
| 39 |
- #' rep("WEEK 1", 2),
+ #' count_occurrences(vars = "AEDECOD") |
|||
| 40 |
- #' rep("WEEK 2", 2)
+ #' |
|||
| 41 |
- #' ),+ #' tbl <- build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl) %>% |
|||
| 42 |
- #' PARAM = rep(c("ALT", "CPR"), 6),
+ #' prune_table() |
|||
| 43 |
- #' ANRIND = c(+ #' |
|||
| 44 |
- #' "NORMAL", "NORMAL", "LOW",+ #' tbl_sorted <- tbl %>% |
|||
| 45 |
- #' "HIGH", "LOW", "LOW", "HIGH", "HIGH", rep("NORMAL", 4)
+ #' sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_occurrences)
|
|||
| 46 |
- #' ),+ #' |
|||
| 47 |
- #' ANRLO = rep(5, 12),+ #' tbl_sorted |
|||
| 48 |
- #' ANRHI = rep(20, 12)+ #' |
|||
| 49 |
- #' )+ #' @export |
|||
| 50 |
- #' df$ANRIND <- factor(df$ANRIND, levels = c("LOW", "HIGH", "NORMAL"))
+ score_occurrences <- function(table_row) {
|
|||
| 51 | -+ | 37x |
- #' h_map_for_count_abnormal(+ row_counts <- h_row_counts(table_row) |
|
| 52 | -+ | 37x |
- #' df = df,+ sum(row_counts) |
|
| 53 |
- #' variables = list(+ } |
|||
| 54 |
- #' anl = "ANRIND",+ |
|||
| 55 |
- #' split_rows = c("PARAM"),
+ #' @describeIn score_occurrences Scoring functions can be produced by this constructor to only include |
|||
| 56 |
- #' range_low = "ANRLO",+ #' specific columns in the scoring. See [h_row_counts()] for further information. |
|||
| 57 |
- #' range_high = "ANRHI"+ #' |
|||
| 58 |
- #' ),+ #' @inheritParams has_count_in_cols |
|||
| 59 |
- #' abnormal = list(low = c("LOW"), high = c("HIGH")),
+ #' |
|||
| 60 |
- #' method = "range",+ #' @return |
|||
| 61 |
- #' na_str = "<Missing>"+ #' * `score_occurrences_cols()` returns a function that sums counts across all specified columns |
|||
| 62 |
- #' )+ #' of a table row. |
|||
| 64 |
- #' @export+ #' @seealso [h_row_counts()] |
|||
| 65 |
- h_map_for_count_abnormal <- function(df,+ #' |
|||
| 66 |
- variables = list(+ #' @examples |
|||
| 67 |
- anl = "ANRIND",+ #' score_cols_a_and_b <- score_occurrences_cols(col_names = c("A: Drug X", "B: Placebo"))
|
|||
| 68 |
- split_rows = c("PARAM"),
+ #' |
|||
| 69 |
- range_low = "ANRLO",+ #' # Note that this here just sorts the AEDECOD inside the AEBODSYS. The AEBODSYS are not sorted. |
|||
| 70 |
- range_high = "ANRHI"+ #' # That would require a second pass of `sort_at_path`. |
|||
| 71 |
- ),+ #' tbl_sorted <- tbl %>% |
|||
| 72 |
- abnormal = list(low = c("LOW", "LOW LOW"), high = c("HIGH", "HIGH HIGH")),
+ #' sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_cols_a_and_b)
|
|||
| 73 |
- method = c("default", "range"),
+ #' |
|||
| 74 |
- na_str = "<Missing>") {
+ #' tbl_sorted |
|||
| 75 | -7x | +
- method <- match.arg(method)+ #' |
||
| 76 | -7x | +
- checkmate::assert_subset(c("anl", "split_rows"), names(variables))
+ #' @export |
||
| 77 | -7x | +
- checkmate::assert_false(anyNA(df[variables$split_rows]))+ score_occurrences_cols <- function(...) {
|
||
| 78 | -7x | +4x |
- assert_df_with_variables(df,+ function(table_row) {
|
|
| 79 | -7x | +20x |
- variables = list(anl = variables$anl, split_rows = variables$split_rows),+ row_counts <- h_row_counts(table_row, ...) |
|
| 80 | -7x | +20x |
- na_level = na_str+ sum(row_counts) |
|
| 81 |
- )+ } |
|||
| 82 | -7x | +
- assert_df_with_factors(df, list(val = variables$anl))+ } |
||
| 83 | -7x | +
- assert_valid_factor(df[[variables$anl]], any.missing = FALSE)+ |
||
| 84 | -7x | +
- assert_list_of_variables(variables)+ #' @describeIn score_occurrences Scoring functions produced by this constructor can be used on |
||
| 85 | -7x | +
- checkmate::assert_list(abnormal, types = "character", len = 2)+ #' subtables: They sum up all specified column counts in the subtable. This is useful when |
||
| 86 |
-
+ #' there is no available content row summing up these counts. |
|||
| 87 |
- # Drop usued levels from df as they are not supposed to be in the final map+ #' |
|||
| 88 | -7x | +
- df <- droplevels(df)+ #' @return |
||
| 89 |
-
+ #' * `score_occurrences_subtable()` returns a function that sums counts in each subtable |
|||
| 90 | -7x | +
- normal_value <- setdiff(levels(df[[variables$anl]]), unlist(abnormal))+ #' across all specified columns. |
||
| 91 |
-
+ #' |
|||
| 92 |
- # Based on the understanding of clinical data, there should only be one level of normal which is "NORMAL"+ #' @examples |
|||
| 93 | -7x | +
- checkmate::assert_vector(normal_value, len = 1)+ #' score_subtable_all <- score_occurrences_subtable(col_names = names(tbl)) |
||
| 94 |
-
+ #' |
|||
| 95 |
- # Default method will only have what is observed in the df, and records with all normal values will be excluded to+ #' # Note that this code just sorts the AEBODSYS, not the AEDECOD within AEBODSYS. That |
|||
| 96 |
- # avoid error in layout building.- |
- |||
| 97 | -7x | -
- if (method == "default") {
- |
- ||
| 98 | -3x | -
- df_abnormal <- subset(df, df[[variables$anl]] %in% unlist(abnormal))- |
- ||
| 99 | -3x | -
- map <- unique(df_abnormal[c(variables$split_rows, variables$anl)])- |
- ||
| 100 | -3x | -
- map_normal <- unique(subset(map, select = variables$split_rows))- |
- ||
| 101 | -3x | -
- map_normal[[variables$anl]] <- normal_value- |
- ||
| 102 | -3x | -
- map <- rbind(map, map_normal)- |
- ||
| 103 | -4x | -
- } else if (method == "range") {
+ #' # would require a second pass of `sort_at_path`. |
||
| 104 | +97 |
- # range method follows the rule that at least one observation with ANRLO > 0 for low+ #' tbl_sorted <- tbl %>% |
||
| 105 | +98 |
- # direction and at least one observation with ANRHI is not missing for high direction.- |
- ||
| 106 | -4x | -
- checkmate::assert_subset(c("range_low", "range_high"), names(variables))
- |
- ||
| 107 | -4x | -
- checkmate::assert_subset(c("LOW", "HIGH"), toupper(names(abnormal)))
+ #' sort_at_path(path = c("AEBODSYS"), scorefun = score_subtable_all, decreasing = FALSE)
|
||
| 108 | +99 | - - | -||
| 109 | -4x | -
- assert_df_with_variables(df,- |
- ||
| 110 | -4x | -
- variables = list(- |
- ||
| 111 | -4x | -
- range_low = variables$range_low,- |
- ||
| 112 | -4x | -
- range_high = variables$range_high+ #' |
||
| 113 | +100 |
- )+ #' tbl_sorted |
||
| 114 | +101 |
- )+ #' |
||
| 115 | +102 |
-
+ #' @export |
||
| 116 | +103 |
- # Define low direction of map- |
- ||
| 117 | -4x | -
- df_low <- subset(df, df[[variables$range_low]] > 0)- |
- ||
| 118 | -4x | -
- map_low <- unique(df_low[variables$split_rows])- |
- ||
| 119 | -4x | -
- low_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "LOW"]))- |
- ||
| 120 | -4x | -
- low_levels_df <- as.data.frame(low_levels)+ score_occurrences_subtable <- function(...) {
|
||
| 121 | -4x | +104 | +1x |
- colnames(low_levels_df) <- variables$anl+ score_table_row <- score_occurrences_cols(...) |
| 122 | -4x | +105 | +1x |
- low_levels_df <- do.call("rbind", replicate(nrow(map_low), low_levels_df, simplify = FALSE))
+ function(table_tree) {
|
| 123 | -4x | +106 | +2x |
- rownames(map_low) <- NULL # Just to avoid strange row index in case upstream functions changed+ table_rows <- collect_leaves(table_tree) |
| 124 | -4x | +107 | +2x |
- map_low <- map_low[rep(seq_len(nrow(map_low)), each = length(low_levels)), , drop = FALSE]+ counts <- vapply(table_rows, score_table_row, numeric(1)) |
| 125 | -4x | +108 | +2x |
- map_low <- cbind(map_low, low_levels_df)+ sum(counts) |
| 126 | +109 |
-
+ } |
||
| 127 | +110 |
- # Define high direction of map- |
- ||
| 128 | -4x | -
- df_high <- subset(df, df[[variables$range_high]] != na_str | !is.na(df[[variables$range_high]]))- |
- ||
| 129 | -4x | -
- map_high <- unique(df_high[variables$split_rows])- |
- ||
| 130 | -4x | -
- high_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "HIGH"]))- |
- ||
| 131 | -4x | -
- high_levels_df <- as.data.frame(high_levels)- |
- ||
| 132 | -4x | -
- colnames(high_levels_df) <- variables$anl- |
- ||
| 133 | -4x | -
- high_levels_df <- do.call("rbind", replicate(nrow(map_high), high_levels_df, simplify = FALSE))
- |
- ||
| 134 | -4x | -
- rownames(map_high) <- NULL- |
- ||
| 135 | -4x | -
- map_high <- map_high[rep(seq_len(nrow(map_high)), each = length(high_levels)), , drop = FALSE]+ } |
||
| 136 | -4x | +|||
| 111 | +
- map_high <- cbind(map_high, high_levels_df)+ |
|||
| 137 | +112 |
-
+ #' @describeIn score_occurrences Produces a score function for sorting table by summing the first content row in |
||
| 138 | +113 |
- # Define normal of map+ #' specified columns. Note that this is extending [rtables::cont_n_onecol()] and [rtables::cont_n_allcols()]. |
||
| 139 | -4x | +|||
| 114 | +
- map_normal <- unique(rbind(map_low, map_high)[variables$split_rows])+ #' |
|||
| 140 | -4x | +|||
| 115 | +
- map_normal[variables$anl] <- normal_value+ #' @return |
|||
| 141 | +116 |
-
+ #' * `score_occurrences_cont_cols()` returns a function that sums counts in the first content row in |
||
| 142 | -4x | +|||
| 117 | +
- map <- rbind(map_low, map_high, map_normal)+ #' specified columns. |
|||
| 143 | +118 |
- }+ #' |
||
| 144 | +119 |
-
+ #' @export |
||
| 145 | +120 |
- # map should be all characters+ score_occurrences_cont_cols <- function(...) {
|
||
| 146 | -7x | +121 | +1x |
- map <- data.frame(lapply(map, as.character), stringsAsFactors = FALSE)+ score_table_row <- score_occurrences_cols(...) |
| 147 | -+ | |||
| 122 | +1x |
-
+ function(table_tree) {
+ |
+ ||
| 123 | +2x | +
+ if (inherits(table_tree, "ContentRow")) {
+ |
+ ||
| 124 | +! | +
+ return(NA) |
||
| 148 | +125 |
- # sort the map final output by split_rows variables+ } |
||
| 149 | -7x | +126 | +2x |
- for (i in rev(seq_len(length(variables$split_rows)))) {
+ content_row <- h_content_first_row(table_tree) |
| 150 | -7x | +127 | +2x |
- map <- map[order(map[[i]]), ]+ score_table_row(content_row) |
| 151 | +128 |
} |
||
| 152 | -7x | -
- map- |
- ||
| 153 | +129 |
}@@ -164099,14 +165707,14 @@ tern coverage - 95.59% |
| 1 |
- #' Helper functions for accessing information from `rtables`+ #' Bland-Altman analysis |
||
| 3 |
- #' @description `r lifecycle::badge("stable")`
+ #' @description `r lifecycle::badge("experimental")`
|
||
| 5 |
- #' These are a couple of functions that help with accessing the data in `rtables` objects.+ #' Statistics function that uses the Bland-Altman method to assess the agreement between two numerical vectors |
||
| 6 |
- #' Currently these work for occurrence tables, which are defined as having a count as the first+ #' and calculates a variety of statistics. |
||
| 7 |
- #' element and a fraction as the second element in each cell.+ #' |
||
| 8 |
- #'+ #' @inheritParams argument_convention |
||
| 9 |
- #' @seealso [prune_occurrences] for usage of these functions.+ #' @param y (`numeric`)\cr vector of numbers we want to analyze, to be compared with `x`. |
||
| 11 |
- #' @name rtables_access+ #' @return |
||
| 12 |
- NULL+ #' A named list of the following elements: |
||
| 13 |
-
+ #' * `df` |
||
| 14 |
- #' @describeIn rtables_access Helper function to extract the first values from each content+ #' * `difference_mean` |
||
| 15 |
- #' cell and from specified columns in a `TableRow`. Defaults to all columns.+ #' * `ci_mean` |
||
| 16 |
- #'+ #' * `difference_sd` |
||
| 17 |
- #' @param table_row (`TableRow`)\cr an analysis row in a occurrence table.+ #' * `difference_se` |
||
| 18 |
- #' @param col_names (`character`)\cr the names of the columns to extract from.+ #' * `upper_agreement_limit` |
||
| 19 |
- #' @param col_indices (`integer`)\cr the indices of the columns to extract from. If `col_names` are provided,+ #' * `lower_agreement_limit` |
||
| 20 |
- #' then these are inferred from the names of `table_row`. Note that this currently only works well with a single+ #' * `agreement_limit_se` |
||
| 21 |
- #' column split.+ #' * `upper_agreement_limit_ci` |
||
| 22 |
- #'+ #' * `lower_agreement_limit_ci` |
||
| 23 |
- #' @return+ #' * `t_value` |
||
| 24 |
- #' * `h_row_first_values()` returns a `vector` of numeric values.+ #' * `n` |
||
| 27 |
- #' tbl <- basic_table() %>%+ #' x <- seq(1, 60, 5) |
||
| 28 |
- #' split_cols_by("ARM") %>%
+ #' y <- seq(5, 50, 4) |
||
| 29 |
- #' split_rows_by("RACE") %>%
+ #' |
||
| 30 |
- #' analyze("AGE", function(x) {
+ #' s_bland_altman(x, y, conf_level = 0.9) |
||
| 31 |
- #' list(+ #' |
||
| 32 |
- #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.x (xx.x)"),+ #' @export |
||
| 33 |
- #' "n" = length(x),+ s_bland_altman <- function(x, y, conf_level = 0.95) {
|
||
| 34 | -+ | 7x |
- #' "frac" = rcell(c(0.1, 0.1), format = "xx (xx)")+ checkmate::assert_numeric(x, min.len = 1, any.missing = TRUE) |
| 35 | -+ | 6x |
- #' )+ checkmate::assert_numeric(y, len = length(x), any.missing = TRUE) |
| 36 | -+ | 5x |
- #' }) %>%+ checkmate::assert_numeric(conf_level, lower = 0, upper = 1, any.missing = TRUE) |
| 37 |
- #' build_table(tern_ex_adsl) %>%+ |
||
| 38 | -+ | 4x |
- #' prune_table()+ alpha <- 1 - conf_level |
| 39 |
- #' tree_row_elem <- collect_leaves(tbl[2, ])[[1]]+ |
||
| 40 | -+ | 4x |
- #' result <- max(h_row_first_values(tree_row_elem))+ ind <- complete.cases(x, y) # use only pairwise complete observations, and check if x and y have the same length |
| 41 | -+ | 4x |
- #' result+ x <- x[ind] |
| 42 | -+ | 4x |
- #'+ y <- y[ind] |
| 43 | -+ | 4x |
- #' @export+ n <- sum(ind) # number of 'observations' |
| 44 |
- h_row_first_values <- function(table_row,+ |
||
| 45 | -+ | 4x |
- col_names = NULL,+ if (n == 0) {
|
| 46 | -+ | ! |
- col_indices = NULL) {
+ stop("there is no valid paired data")
|
| 47 | -745x | +
- col_indices <- check_names_indices(table_row, col_names, col_indices)+ } |
|
| 48 | -744x | +
- checkmate::assert_integerish(col_indices)+ |
|
| 49 | -744x | +4x |
- checkmate::assert_subset(col_indices, seq_len(ncol(table_row)))+ difference <- x - y # vector of differences |
| 50 | -+ | 4x |
-
+ average <- (x + y) / 2 # vector of means |
| 51 | -+ | 4x |
- # Main values are extracted+ difference_mean <- mean(difference) # mean difference |
| 52 | -744x | +4x |
- row_vals <- row_values(table_row)[col_indices]+ difference_sd <- sd(difference) # SD of differences |
| 53 | -+ | 4x |
-
+ al <- qnorm(1 - alpha / 2) * difference_sd |
| 54 | -+ | 4x |
- # Main return+ upper_agreement_limit <- difference_mean + al # agreement limits |
| 55 | -744x | +4x |
- vapply(row_vals, function(rv) {
+ lower_agreement_limit <- difference_mean - al |
| 56 | -2096x | +
- if (is.null(rv)) {
+
|
|
| 57 | -744x | +4x |
- NA_real_+ difference_se <- difference_sd / sqrt(n) # standard error of the mean |
| 58 | -+ | 4x |
- } else {
+ al_se <- difference_sd * sqrt(3) / sqrt(n) # standard error of the agreement limit |
| 59 | -2090x | +4x |
- rv[1L]+ tvalue <- qt(1 - alpha / 2, n - 1) # t value for 95% CI calculation |
| 60 | -+ | 4x |
- }+ difference_mean_ci <- difference_se * tvalue |
| 61 | -744x | +4x |
- }, FUN.VALUE = numeric(1))+ al_ci <- al_se * tvalue |
| 62 | -+ | 4x |
- }+ upper_agreement_limit_ci <- c(upper_agreement_limit - al_ci, upper_agreement_limit + al_ci) |
| 63 | -+ | 4x |
-
+ lower_agreement_limit_ci <- c(lower_agreement_limit - al_ci, lower_agreement_limit + al_ci) |
| 64 |
- #' @describeIn rtables_access Helper function that extracts row values and checks if they are+ |
||
| 65 | -+ | 4x |
- #' convertible to integers (`integerish` values).+ list( |
| 66 | -+ | 4x |
- #'+ df = data.frame(average, difference), |
| 67 | -+ | 4x |
- #' @return+ difference_mean = difference_mean, |
| 68 | -+ | 4x |
- #' * `h_row_counts()` returns a `vector` of numeric values.+ ci_mean = difference_mean + c(-1, 1) * difference_mean_ci, |
| 69 | -+ | 4x |
- #'+ difference_sd = difference_sd, |
| 70 | -+ | 4x |
- #' @examples+ difference_se = difference_se, |
| 71 | -+ | 4x |
- #' # Row counts (integer values)+ upper_agreement_limit = upper_agreement_limit, |
| 72 | -+ | 4x |
- #' # h_row_counts(tree_row_elem) # Fails because there are no integers+ lower_agreement_limit = lower_agreement_limit, |
| 73 | -+ | 4x |
- #' # Using values with integers+ agreement_limit_se = al_se, |
| 74 | -+ | 4x |
- #' tree_row_elem <- collect_leaves(tbl[3, ])[[1]]+ upper_agreement_limit_ci = upper_agreement_limit_ci, |
| 75 | -+ | 4x |
- #' result <- h_row_counts(tree_row_elem)+ lower_agreement_limit_ci = lower_agreement_limit_ci, |
| 76 | -+ | 4x |
- #' # result+ t_value = tvalue, |
| 77 | -+ | 4x |
- #'+ n = n |
| 78 |
- #' @export+ ) |
||
| 79 |
- h_row_counts <- function(table_row,+ } |
||
| 80 |
- col_names = NULL,+ |
||
| 81 |
- col_indices = NULL) {
+ #' Bland-Altman plot |
||
| 82 | -741x | +
- counts <- h_row_first_values(table_row, col_names, col_indices)+ #' |
|
| 83 | -741x | +
- checkmate::assert_integerish(counts)+ #' @description `r lifecycle::badge("experimental")`
|
|
| 84 | -741x | +
- counts+ #' |
|
| 85 |
- }+ #' Graphing function that produces a Bland-Altman plot. |
||
| 86 |
-
+ #' |
||
| 87 |
- #' @describeIn rtables_access Helper function to extract fractions from specified columns in a `TableRow`.+ #' @inheritParams s_bland_altman |
||
| 88 |
- #' More specifically it extracts the second values from each content cell and checks it is a fraction.+ #' |
||
| 89 |
- #'+ #' @return A `ggplot` Bland-Altman plot. |
||
| 90 |
- #' @return+ #' |
||
| 91 |
- #' * `h_row_fractions()` returns a `vector` of proportions.+ #' @examples |
||
| 92 |
- #'+ #' x <- seq(1, 60, 5) |
||
| 93 |
- #' @examples+ #' y <- seq(5, 50, 4) |
||
| 94 |
- #' # Row fractions+ #' |
||
| 95 |
- #' tree_row_elem <- collect_leaves(tbl[4, ])[[1]]+ #' g_bland_altman(x = x, y = y, conf_level = 0.9) |
||
| 96 |
- #' h_row_fractions(tree_row_elem)+ #' |
||
| 97 |
- #'+ #' @export |
||
| 98 |
- #' @export+ #' @aliases bland_altman |
||
| 99 |
- h_row_fractions <- function(table_row,+ g_bland_altman <- function(x, y, conf_level = 0.95) {
|
||
| 100 | -+ | 1x |
- col_names = NULL,+ result_tem <- s_bland_altman(x, y, conf_level = conf_level) |
| 101 | -+ | 1x |
- col_indices = NULL) {
+ xpos <- max(result_tem$df$average) * 0.9 + min(result_tem$df$average) * 0.1 |
| 102 | -250x | +1x |
- col_indices <- check_names_indices(table_row, col_names, col_indices)+ yrange <- diff(range(result_tem$df$difference)) |
| 103 | -250x | +
- row_vals <- row_values(table_row)[col_indices]+ |
|
| 104 | -250x | +1x |
- fractions <- sapply(row_vals, "[", 2L)+ p <- ggplot(result_tem$df) + |
| 105 | -250x | +1x |
- checkmate::assert_numeric(fractions, lower = 0, upper = 1)+ geom_point(aes(x = average, y = difference), color = "blue") + |
| 106 | -250x | +1x |
- fractions+ geom_hline(yintercept = result_tem$difference_mean, color = "blue", linetype = 1) + |
| 107 | -+ | 1x |
- }+ geom_hline(yintercept = 0, color = "blue", linetype = 2) + |
| 108 | -+ | 1x |
-
+ geom_hline(yintercept = result_tem$lower_agreement_limit, color = "red", linetype = 2) + |
| 109 | -+ | 1x |
- #' @describeIn rtables_access Helper function to extract column counts from specified columns in a table.+ geom_hline(yintercept = result_tem$upper_agreement_limit, color = "red", linetype = 2) + |
| 110 | -+ | 1x |
- #'+ annotate( |
| 111 | -+ | 1x |
- #' @param table (`VTableNodeInfo`)\cr an occurrence table or row.+ "text", |
| 112 | -+ | 1x |
- #'+ x = xpos, |
| 113 | -+ | 1x |
- #' @return+ y = result_tem$lower_agreement_limit + 0.03 * yrange, |
| 114 | -+ | 1x |
- #' * `h_col_counts()` returns a `vector` of column counts.+ label = "lower limits of agreement", |
| 115 | -+ | 1x |
- #'+ color = "red" |
| 116 |
- #' @export+ ) + |
||
| 117 | -+ | 1x |
- h_col_counts <- function(table,+ annotate( |
| 118 | -+ | 1x |
- col_names = NULL,+ "text", |
| 119 | -+ | 1x |
- col_indices = NULL) {
+ x = xpos, |
| 120 | -307x | +1x |
- col_indices <- check_names_indices(table, col_names, col_indices)+ y = result_tem$upper_agreement_limit + 0.03 * yrange, |
| 121 | -307x | +1x |
- counts <- col_counts(table)[col_indices]+ label = "upper limits of agreement", |
| 122 | -307x | +1x |
- stats::setNames(counts, col_names)+ color = "red" |
| 123 |
- }+ ) + |
||
| 124 | +1x | +
+ annotate(+ |
+ |
| 125 | +1x | +
+ "text",+ |
+ |
| 126 | +1x | +
+ x = xpos,+ |
+ |
| 127 | +1x | +
+ y = result_tem$difference_mean + 0.03 * yrange,+ |
+ |
| 128 | +1x | +
+ label = "mean of difference between two measures",+ |
+ |
| 129 | +1x | +
+ color = "blue"+ |
+ |
| 130 | ++ |
+ ) ++ |
+ |
| 131 | +1x | +
+ annotate(+ |
+ |
| 132 | +1x | +
+ "text",+ |
+ |
| 133 | +1x | +
+ x = xpos,+ |
+ |
| 134 | +1x | +
+ y = result_tem$lower_agreement_limit - 0.03 * yrange,+ |
+ |
| 135 | +1x | +
+ label = sprintf("%.2f", result_tem$lower_agreement_limit),
+ |
+ |
| 136 | +1x | +
+ color = "red"+ |
+ |
| 137 | ++ |
+ ) ++ |
+ |
| 138 | +1x | +
+ annotate(+ |
+ |
| 139 | +1x | +
+ "text",+ |
+ |
| 140 | +1x | +
+ x = xpos,+ |
+ |
| 141 | +1x | +
+ y = result_tem$upper_agreement_limit - 0.03 * yrange,+ |
+ |
| 142 | +1x | +
+ label = sprintf("%.2f", result_tem$upper_agreement_limit),
+ |
+ |
| 143 | +1x | +
+ color = "red"+ |
+ |
| 144 | ++ |
+ ) ++ |
+ |
| 145 | +1x | +
+ annotate(+ |
+ |
| 146 | +1x | +
+ "text",+ |
+ |
| 147 | +1x | +
+ x = xpos,+ |
+ |
| 148 | +1x | +
+ y = result_tem$difference_mean - 0.03 * yrange,+ |
+ |
| 149 | +1x | +
+ label = sprintf("%.2f", result_tem$difference_meanm),
+ |
+ |
| 150 | +1x | +
+ color = "blue"+ |
+ |
| 151 | ++ |
+ ) ++ |
+ |
| 152 | +1x | +
+ xlab("Average of two measures") +
+ |
+ |
| 153 | +1x | +
+ ylab("Difference between two measures")
+ |
+ |
| 154 | |||
| 155 | +1x | +
+ return(p)+ |
+ |
| 125 | +156 |
- #' @describeIn rtables_access Helper function to get first row of content table of current table.+ } |
| 126 | +1 |
- #'+ #' Apply 1/3 or 1/2 imputation rule to data |
||
| 127 | +2 |
- #' @return+ #' |
||
| 128 | +3 |
- #' * `h_content_first_row()` returns a row from an `rtables` table.+ #' @description `r lifecycle::badge("stable")`
|
||
| 129 | +4 |
#' |
||
| 130 | +5 |
- #' @export+ #' @inheritParams argument_convention |
||
| 131 | +6 |
- h_content_first_row <- function(table) {
+ #' @param x_stats (named `list`)\cr a named list of statistics, typically the results of [s_summary()]. |
||
| 132 | -27x | +|||
| 7 | +
- ct <- content_table(table)+ #' @param stat (`string`)\cr statistic to return the value/NA level of according to the imputation |
|||
| 133 | -27x | +|||
| 8 | +
- tree_children(ct)[[1]]+ #' rule applied. |
|||
| 134 | +9 |
- }+ #' @param imp_rule (`string`)\cr imputation rule setting. Set to `"1/3"` to implement 1/3 imputation |
||
| 135 | +10 |
-
+ #' rule or `"1/2"` to implement 1/2 imputation rule. |
||
| 136 | +11 |
- #' @describeIn rtables_access Helper function which says whether current table is a leaf in the tree.+ #' @param post (`flag`)\cr whether the data corresponds to a post-dose time-point (defaults to `FALSE`). |
||
| 137 | +12 | ++ |
+ #' This parameter is only used when `imp_rule` is set to `"1/3"`.+ |
+ |
| 13 | ++ |
+ #' @param avalcat_var (`string`)\cr name of variable that indicates whether a row in `df` corresponds+ |
+ ||
| 14 | ++ |
+ #' to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of the above+ |
+ ||
| 15 | ++ |
+ #' (defaults to `"AVALCAT1"`). Variable `avalcat_var` must be present in `df`.+ |
+ ||
| 16 |
#' |
|||
| 138 | +17 |
- #' @return+ #' @return A `list` containing statistic value (`val`) and NA level (`na_str`) that should be displayed |
||
| 139 | +18 |
- #' * `is_leaf_table()` returns a `logical` value indicating whether current table is a leaf.+ #' according to the specified imputation rule. |
||
| 140 | +19 |
#' |
||
| 141 | +20 |
- #' @keywords internal+ #' @seealso [analyze_vars_in_cols()] where this function can be implemented by setting the `imp_rule` |
||
| 142 | +21 |
- is_leaf_table <- function(table) {
+ #' argument. |
||
| 143 | -168x | +|||
| 22 | +
- children <- tree_children(table)+ #' |
|||
| 144 | -168x | +|||
| 23 | +
- child_classes <- unique(sapply(children, class))+ #' @examples |
|||
| 145 | -168x | +|||
| 24 | +
- identical(child_classes, "ElementaryTable")+ #' set.seed(1) |
|||
| 146 | +25 |
- }+ #' df <- data.frame( |
||
| 147 | +26 |
-
+ #' AVAL = runif(50, 0, 1), |
||
| 148 | +27 |
- #' @describeIn rtables_access Internal helper function that tests standard inputs for column indices.+ #' AVALCAT1 = sample(c(1, "BLQ"), 50, replace = TRUE) |
||
| 149 | +28 |
- #'+ #' ) |
||
| 150 | +29 |
- #' @return+ #' x_stats <- s_summary(df$AVAL) |
||
| 151 | +30 |
- #' * `check_names_indices` returns column indices.+ #' imputation_rule(df, x_stats, "max", "1/3") |
||
| 152 | +31 | ++ |
+ #' imputation_rule(df, x_stats, "geom_mean", "1/3")+ |
+ |
| 32 | ++ |
+ #' imputation_rule(df, x_stats, "mean", "1/2")+ |
+ ||
| 33 |
#' |
|||
| 153 | +34 |
- #' @keywords internal+ #' @export |
||
| 154 | +35 |
- check_names_indices <- function(table_row,+ imputation_rule <- function(df, x_stats, stat, imp_rule, post = FALSE, avalcat_var = "AVALCAT1") {
+ |
+ ||
| 36 | +128x | +
+ checkmate::assert_choice(avalcat_var, names(df))+ |
+ ||
| 37 | +128x | +
+ checkmate::assert_choice(imp_rule, c("1/3", "1/2"))
+ |
+ ||
| 38 | +128x | +
+ n_blq <- sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", df[[avalcat_var]]))
+ |
+ ||
| 39 | +128x | +
+ ltr_blq_ratio <- n_blq / max(1, nrow(df)) |
||
| 155 | +40 | ++ | + + | +|
| 41 |
- col_names = NULL,+ # defaults+ |
+ |||
| 42 | +128x | +
+ val <- x_stats[[stat]]+ |
+ ||
| 43 | +128x | +
+ na_str <- "NE" |
||
| 156 | +44 |
- col_indices = NULL) {
+
|
||
| 157 | -1302x | +45 | +128x |
- if (!is.null(col_names)) {
+ if (imp_rule == "1/3") {
|
| 158 | -1256x | +46 | +2x |
- if (!is.null(col_indices)) {
+ if (!post && stat == "geom_mean") val <- NA # 1/3_pre_LT, 1/3_pre_GT |
| 159 | -1x | +47 | +84x |
- stop(+ if (ltr_blq_ratio > 1 / 3) {
|
| 160 | -1x | +48 | +63x |
- "Inserted both col_names and col_indices when selecting row values. ",+ if (stat != "geom_mean") na_str <- "ND" # 1/3_pre_GT, 1/3_post_GT |
| 161 | -1x | +49 | +9x |
- "Please choose one."+ if (!post && !stat %in% c("median", "max")) val <- NA # 1/3_pre_GT
|
| 162 | -+ | |||
| 50 | +39x |
- )+ if (post && !stat %in% c("median", "max", "geom_mean")) val <- NA # 1/3_post_GT
|
||
| 163 | +51 |
} |
||
| 164 | -1255x | +52 | +44x |
- col_indices <- h_col_indices(table_row, col_names)+ } else if (imp_rule == "1/2") {
|
| 165 | -+ | |||
| 53 | +44x |
- }+ if (ltr_blq_ratio > 1 / 2 && !stat == "max") {
|
||
| 166 | -1301x | +54 | +12x |
- if (is.null(col_indices)) {
+ val <- NA # 1/2_GT |
| 167 | -39x | +55 | +12x |
- ll <- ifelse(is.null(ncol(table_row)), length(table_row), ncol(table_row))+ na_str <- "ND" # 1/2_GT |
| 168 | -39x | +|||
| 56 | +
- col_indices <- seq_len(ll)+ } |
|||
| 169 | +57 |
} |
||
| 170 | +58 | |||
| 171 | -1301x | +59 | +128x |
- return(col_indices)+ list(val = val, na_str = na_str) |
| 172 | +60 |
}@@ -165309,14 +167231,14 @@ tern coverage - 95.59% |
| 1 |
- #' Occurrence table sorting+ #' Add titles, footnotes, page Number, and a bounding box to a grid grob |
||
| 5 |
- #' Functions to score occurrence table subtables and rows which can be used in the+ #' This function is useful to label grid grobs (also `ggplot2`, and `lattice` plots) |
||
| 6 |
- #' sorting of occurrence tables.+ #' with title, footnote, and page numbers. |
||
| 8 |
- #' @name score_occurrences+ #' @inheritParams grid::grob |
||
| 9 |
- NULL+ #' @param grob (`grob`)\cr a grid grob object, optionally `NULL` if only a `grob` with the decoration should be shown. |
||
| 10 |
-
+ #' @param titles (`character`)\cr titles given as a vector of strings that are each separated by a newline and wrapped |
||
| 11 |
- #' @describeIn score_occurrences Scoring function which sums the counts across all+ #' according to the page width. |
||
| 12 |
- #' columns. It will fail if anything else but counts are used.+ #' @param footnotes (`character`)\cr footnotes. Uses the same formatting rules as `titles`. |
||
| 13 |
- #'+ #' @param page (`string` or `NULL`)\cr page numeration. If `NULL` then no page number is displayed. |
||
| 14 |
- #' @inheritParams rtables_access+ #' @param width_titles (`grid::unit`)\cr width of titles. Usually defined as all the available space |
||
| 15 |
- #'+ #' `grid::unit(1, "npc")`, it is affected by the parameter `outer_margins`. Right margins (`outer_margins[4]`) |
||
| 16 |
- #' @return+ #' need to be subtracted to the allowed width. |
||
| 17 |
- #' * `score_occurrences()` returns the sum of counts across all columns of a table row.+ #' @param width_footnotes (`grid::unit`)\cr width of footnotes. Same default and margin correction as `width_titles`. |
||
| 18 |
- #'+ #' @param border (`flag`)\cr whether a border should be drawn around the plot or not. |
||
| 19 |
- #' @seealso [h_row_first_values()]+ #' @param padding (`grid::unit`)\cr padding. A unit object of length 4. Innermost margin between the plot (`grob`) |
||
| 20 |
- #'+ #' and, possibly, the border of the plot. Usually expressed in 4 identical values (usually `"lines"`). It defaults |
||
| 21 |
- #' @examples+ #' to `grid::unit(rep(1, 4), "lines")`. |
||
| 22 |
- #' lyt <- basic_table() %>%+ #' @param margins (`grid::unit`)\cr margins. A unit object of length 4. Margins between the plot and the other |
||
| 23 |
- #' split_cols_by("ARM") %>%
+ #' elements in the list (e.g. titles, plot, and footers). This is usually expressed in 4 `"lines"`, where the |
||
| 24 |
- #' add_colcounts() %>%+ #' lateral ones are 0s, while top and bottom are 1s. It defaults to `grid::unit(c(1, 0, 1, 0), "lines")`. |
||
| 25 |
- #' analyze_num_patients(+ #' @param outer_margins (`grid::unit`)\cr outer margins. A unit object of length 4. It defines the general margin of |
||
| 26 |
- #' vars = "USUBJID",+ #' the plot, considering also decorations like titles, footnotes, and page numbers. It defaults to |
||
| 27 |
- #' .stats = c("unique"),
+ #' `grid::unit(c(2, 1.5, 3, 1.5), "cm")`. |
||
| 28 |
- #' .labels = c("Total number of patients with at least one event")
+ #' @param gp_titles (`gpar`)\cr a `gpar` object. Mainly used to set different `"fontsize"`. |
||
| 29 |
- #' ) %>%+ #' @param gp_footnotes (`gpar`)\cr a `gpar` object. Mainly used to set different `"fontsize"`. |
||
| 30 |
- #' split_rows_by("AEBODSYS", child_labels = "visible", nested = FALSE) %>%
+ #' |
||
| 31 |
- #' summarize_num_patients(+ #' @return A grid grob (`gTree`). |
||
| 32 |
- #' var = "USUBJID",+ #' |
||
| 33 |
- #' .stats = c("unique", "nonunique"),
+ #' @details The titles and footnotes will be ragged, i.e. each title will be wrapped individually. |
||
| 34 |
- #' .labels = c(+ #' |
||
| 35 |
- #' "Total number of patients with at least one event",+ #' @examples |
||
| 36 |
- #' "Total number of events"+ #' library(grid) |
||
| 37 |
- #' )+ #' |
||
| 38 |
- #' ) %>%+ #' titles <- c( |
||
| 39 |
- #' count_occurrences(vars = "AEDECOD")+ #' "Edgar Anderson's Iris Data", |
||
| 40 |
- #'+ #' paste( |
||
| 41 |
- #' tbl <- build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl) %>%+ #' "This famous (Fisher's or Anderson's) iris data set gives the measurements", |
||
| 42 |
- #' prune_table()+ #' "in centimeters of the variables sepal length and width and petal length", |
||
| 43 |
- #'+ #' "and width, respectively, for 50 flowers from each of 3 species of iris." |
||
| 44 |
- #' tbl_sorted <- tbl %>%+ #' ) |
||
| 45 |
- #' sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_occurrences)
+ #' ) |
||
| 47 |
- #' tbl_sorted+ #' footnotes <- c( |
||
| 48 |
- #'+ #' "The species are Iris setosa, versicolor, and virginica.", |
||
| 49 |
- #' @export+ #' paste( |
||
| 50 |
- score_occurrences <- function(table_row) {
+ #' "iris is a data frame with 150 cases (rows) and 5 variables (columns) named", |
||
| 51 | -37x | +
- row_counts <- h_row_counts(table_row)+ #' "Sepal.Length, Sepal.Width, Petal.Length, Petal.Width, and Species." |
|
| 52 | -37x | +
- sum(row_counts)+ #' ) |
|
| 53 |
- }+ #' ) |
||
| 54 |
-
+ #' |
||
| 55 |
- #' @describeIn score_occurrences Scoring functions can be produced by this constructor to only include+ #' ## empty plot |
||
| 56 |
- #' specific columns in the scoring. See [h_row_counts()] for further information.+ #' grid.newpage() |
||
| 58 |
- #' @inheritParams has_count_in_cols+ #' grid.draw( |
||
| 59 |
- #'+ #' decorate_grob( |
||
| 60 |
- #' @return+ #' NULL, |
||
| 61 |
- #' * `score_occurrences_cols()` returns a function that sums counts across all specified columns+ #' titles = titles, |
||
| 62 |
- #' of a table row.+ #' footnotes = footnotes, |
||
| 63 |
- #'+ #' page = "Page 4 of 10" |
||
| 64 |
- #' @seealso [h_row_counts()]+ #' ) |
||
| 65 |
- #'+ #' ) |
||
| 66 |
- #' @examples+ #' |
||
| 67 |
- #' score_cols_a_and_b <- score_occurrences_cols(col_names = c("A: Drug X", "B: Placebo"))
+ #' # grid |
||
| 68 |
- #'+ #' p <- gTree( |
||
| 69 |
- #' # Note that this here just sorts the AEDECOD inside the AEBODSYS. The AEBODSYS are not sorted.+ #' children = gList( |
||
| 70 |
- #' # That would require a second pass of `sort_at_path`.+ #' rectGrob(), |
||
| 71 |
- #' tbl_sorted <- tbl %>%+ #' xaxisGrob(), |
||
| 72 |
- #' sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_cols_a_and_b)
+ #' yaxisGrob(), |
||
| 73 |
- #'+ #' textGrob("Sepal.Length", y = unit(-4, "lines")),
|
||
| 74 |
- #' tbl_sorted+ #' textGrob("Petal.Length", x = unit(-3.5, "lines"), rot = 90),
|
||
| 75 |
- #'+ #' pointsGrob(iris$Sepal.Length, iris$Petal.Length, gp = gpar(col = iris$Species), pch = 16) |
||
| 76 |
- #' @export+ #' ), |
||
| 77 |
- score_occurrences_cols <- function(...) {
+ #' vp = vpStack(plotViewport(), dataViewport(xData = iris$Sepal.Length, yData = iris$Petal.Length)) |
||
| 78 | -4x | +
- function(table_row) {
+ #' ) |
|
| 79 | -20x | +
- row_counts <- h_row_counts(table_row, ...)+ #' grid.newpage() |
|
| 80 | -20x | +
- sum(row_counts)+ #' grid.draw(p) |
|
| 81 |
- }+ #' |
||
| 82 |
- }+ #' grid.newpage() |
||
| 83 |
-
+ #' grid.draw( |
||
| 84 |
- #' @describeIn score_occurrences Scoring functions produced by this constructor can be used on+ #' decorate_grob( |
||
| 85 |
- #' subtables: They sum up all specified column counts in the subtable. This is useful when+ #' grob = p, |
||
| 86 |
- #' there is no available content row summing up these counts.+ #' titles = titles, |
||
| 87 |
- #'+ #' footnotes = footnotes, |
||
| 88 |
- #' @return+ #' page = "Page 6 of 129" |
||
| 89 |
- #' * `score_occurrences_subtable()` returns a function that sums counts in each subtable+ #' ) |
||
| 90 |
- #' across all specified columns.+ #' ) |
||
| 92 |
- #' @examples+ #' ## with ggplot2 |
||
| 93 |
- #' score_subtable_all <- score_occurrences_subtable(col_names = names(tbl))+ #' library(ggplot2) |
||
| 95 |
- #' # Note that this code just sorts the AEBODSYS, not the AEDECOD within AEBODSYS. That+ #' p_gg <- ggplot2::ggplot(iris, aes(Sepal.Length, Sepal.Width, col = Species)) + |
||
| 96 |
- #' # would require a second pass of `sort_at_path`.+ #' ggplot2::geom_point() |
||
| 97 |
- #' tbl_sorted <- tbl %>%+ #' p_gg |
||
| 98 |
- #' sort_at_path(path = c("AEBODSYS"), scorefun = score_subtable_all, decreasing = FALSE)
+ #' p <- ggplotGrob(p_gg) |
||
| 99 |
- #'+ #' grid.newpage() |
||
| 100 |
- #' tbl_sorted+ #' grid.draw( |
||
| 101 |
- #'+ #' decorate_grob( |
||
| 102 |
- #' @export+ #' grob = p, |
||
| 103 |
- score_occurrences_subtable <- function(...) {
+ #' titles = titles, |
||
| 104 | -1x | +
- score_table_row <- score_occurrences_cols(...)+ #' footnotes = footnotes, |
|
| 105 | -1x | +
- function(table_tree) {
+ #' page = "Page 6 of 129" |
|
| 106 | -2x | +
- table_rows <- collect_leaves(table_tree)+ #' ) |
|
| 107 | -2x | +
- counts <- vapply(table_rows, score_table_row, numeric(1))+ #' ) |
|
| 108 | -2x | +
- sum(counts)+ #' |
|
| 109 |
- }+ #' ## with lattice |
||
| 110 |
- }+ #' library(lattice) |
||
| 111 |
-
+ #' |
||
| 112 |
- #' @describeIn score_occurrences Produces a score function for sorting table by summing the first content row in+ #' xyplot(Sepal.Length ~ Petal.Length, data = iris, col = iris$Species) |
||
| 113 |
- #' specified columns. Note that this is extending [rtables::cont_n_onecol()] and [rtables::cont_n_allcols()].+ #' p <- grid.grab() |
||
| 114 |
- #'+ #' grid.newpage() |
||
| 115 |
- #' @return+ #' grid.draw( |
||
| 116 |
- #' * `score_occurrences_cont_cols()` returns a function that sums counts in the first content row in+ #' decorate_grob( |
||
| 117 |
- #' specified columns.+ #' grob = p, |
||
| 118 |
- #'+ #' titles = titles, |
||
| 119 |
- #' @export+ #' footnotes = footnotes, |
||
| 120 |
- score_occurrences_cont_cols <- function(...) {
+ #' page = "Page 6 of 129" |
||
| 121 | -1x | +
- score_table_row <- score_occurrences_cols(...)+ #' ) |
|
| 122 | -1x | +
- function(table_tree) {
+ #' ) |
|
| 123 | -2x | +
- if (inherits(table_tree, "ContentRow")) {
+ #' |
|
| 124 | -! | +
- return(NA)+ #' # with gridExtra - no borders |
|
| 125 |
- }+ #' library(gridExtra) |
||
| 126 | -2x | +
- content_row <- h_content_first_row(table_tree)+ #' grid.newpage() |
|
| 127 | -2x | +
- score_table_row(content_row)+ #' grid.draw( |
|
| 128 |
- }+ #' decorate_grob( |
||
| 129 |
- }+ #' tableGrob( |
| 1 | +130 |
- #' Apply 1/3 or 1/2 imputation rule to data+ #' head(mtcars) |
||
| 2 | +131 |
- #'+ #' ), |
||
| 3 | +132 |
- #' @description `r lifecycle::badge("stable")`
+ #' titles = "title", |
||
| 4 | +133 |
- #'+ #' footnotes = "footnote", |
||
| 5 | +134 |
- #' @inheritParams argument_convention+ #' border = FALSE |
||
| 6 | +135 |
- #' @param x_stats (named `list`)\cr a named list of statistics, typically the results of [s_summary()].+ #' ) |
||
| 7 | +136 |
- #' @param stat (`string`)\cr statistic to return the value/NA level of according to the imputation+ #' ) |
||
| 8 | +137 |
- #' rule applied.+ #' |
||
| 9 | +138 |
- #' @param imp_rule (`string`)\cr imputation rule setting. Set to `"1/3"` to implement 1/3 imputation+ #' @export |
||
| 10 | +139 |
- #' rule or `"1/2"` to implement 1/2 imputation rule.+ decorate_grob <- function(grob, |
||
| 11 | +140 |
- #' @param post (`flag`)\cr whether the data corresponds to a post-dose time-point (defaults to `FALSE`).+ titles, |
||
| 12 | +141 |
- #' This parameter is only used when `imp_rule` is set to `"1/3"`.+ footnotes, |
||
| 13 | +142 |
- #' @param avalcat_var (`string`)\cr name of variable that indicates whether a row in `df` corresponds+ page = "", |
||
| 14 | +143 |
- #' to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of the above+ width_titles = grid::unit(1, "npc"), |
||
| 15 | +144 |
- #' (defaults to `"AVALCAT1"`). Variable `avalcat_var` must be present in `df`.+ width_footnotes = grid::unit(1, "npc"), |
||
| 16 | +145 |
- #'+ border = TRUE, |
||
| 17 | +146 |
- #' @return A `list` containing statistic value (`val`) and NA level (`na_str`) that should be displayed+ padding = grid::unit(rep(1, 4), "lines"), |
||
| 18 | +147 |
- #' according to the specified imputation rule.+ margins = grid::unit(c(1, 0, 1, 0), "lines"), |
||
| 19 | +148 |
- #'+ outer_margins = grid::unit(c(2, 1.5, 3, 1.5), "cm"), |
||
| 20 | +149 |
- #' @seealso [analyze_vars_in_cols()] where this function can be implemented by setting the `imp_rule`+ gp_titles = grid::gpar(), |
||
| 21 | +150 |
- #' argument.+ gp_footnotes = grid::gpar(fontsize = 8), |
||
| 22 | +151 |
- #'+ name = NULL, |
||
| 23 | +152 |
- #' @examples+ gp = grid::gpar(), |
||
| 24 | +153 |
- #' set.seed(1)+ vp = NULL) {
|
||
| 25 | +154 |
- #' df <- data.frame(+ # External margins need to be taken into account when defining the width of titles and footers |
||
| 26 | +155 |
- #' AVAL = runif(50, 0, 1),+ # because the text is split in advance depending on only the width of the viewport. |
||
| 27 | -+ | |||
| 156 | +9x |
- #' AVALCAT1 = sample(c(1, "BLQ"), 50, replace = TRUE)+ if (any(as.numeric(outer_margins) > 0)) {
|
||
| 28 | -+ | |||
| 157 | +9x |
- #' )+ width_titles <- width_titles - outer_margins[4] |
||
| 29 | -+ | |||
| 158 | +9x |
- #' x_stats <- s_summary(df$AVAL)+ width_footnotes <- width_footnotes - outer_margins[4] |
||
| 30 | +159 |
- #' imputation_rule(df, x_stats, "max", "1/3")+ } |
||
| 31 | +160 |
- #' imputation_rule(df, x_stats, "geom_mean", "1/3")+ |
||
| 32 | -+ | |||
| 161 | +9x |
- #' imputation_rule(df, x_stats, "mean", "1/2")+ st_titles <- split_text_grob( |
||
| 33 | -+ | |||
| 162 | +9x |
- #'+ titles,+ |
+ ||
| 163 | +9x | +
+ x = 0, y = 1,+ |
+ ||
| 164 | +9x | +
+ just = c("left", "top"),
+ |
+ ||
| 165 | +9x | +
+ width = width_titles,+ |
+ ||
| 166 | +9x | +
+ vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 1),+ |
+ ||
| 167 | +9x | +
+ gp = gp_titles |
||
| 34 | +168 |
- #' @export+ ) |
||
| 35 | +169 |
- imputation_rule <- function(df, x_stats, stat, imp_rule, post = FALSE, avalcat_var = "AVALCAT1") {
+
|
||
| 36 | -128x | +170 | +9x |
- checkmate::assert_choice(avalcat_var, names(df))+ st_footnotes <- split_text_grob( |
| 37 | -128x | +171 | +9x |
- checkmate::assert_choice(imp_rule, c("1/3", "1/2"))
+ footnotes, |
| 38 | -128x | +172 | +9x |
- n_blq <- sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", df[[avalcat_var]]))
+ x = 0, y = 1, |
| 39 | -128x | +173 | +9x |
- ltr_blq_ratio <- n_blq / max(1, nrow(df))+ just = c("left", "top"),
|
| 40 | -+ | |||
| 174 | +9x |
-
+ width = width_footnotes, |
||
| 41 | -+ | |||
| 175 | +9x |
- # defaults+ vp = grid::viewport(layout.pos.row = 3, layout.pos.col = 1), |
||
| 42 | -128x | +176 | +9x |
- val <- x_stats[[stat]]+ gp = gp_footnotes |
| 43 | -128x | +|||
| 177 | +
- na_str <- "NE"+ ) |
|||
| 44 | +178 | |||
| 45 | -128x | +179 | +9x |
- if (imp_rule == "1/3") {
+ pg_footnote <- grid::textGrob( |
| 46 | -2x | +180 | +9x |
- if (!post && stat == "geom_mean") val <- NA # 1/3_pre_LT, 1/3_pre_GT+ paste("\n", page),
|
| 47 | -84x | +181 | +9x |
- if (ltr_blq_ratio > 1 / 3) {
+ x = 1, y = 0, |
| 48 | -63x | +182 | +9x |
- if (stat != "geom_mean") na_str <- "ND" # 1/3_pre_GT, 1/3_post_GT+ just = c("right", "bottom"),
|
| 49 | +183 | 9x |
- if (!post && !stat %in% c("median", "max")) val <- NA # 1/3_pre_GT
+ vp = grid::viewport(layout.pos.row = 4, layout.pos.col = 1), |
|
| 50 | -39x | +184 | +9x |
- if (post && !stat %in% c("median", "max", "geom_mean")) val <- NA # 1/3_post_GT
+ gp = gp_footnotes |
| 51 | +185 |
- }+ )+ |
+ ||
| 186 | ++ | + + | +||
| 187 | ++ |
+ # Initial decoration of the grob -> border, paddings, and margins are used here |
||
| 52 | -44x | +188 | +9x |
- } else if (imp_rule == "1/2") {
+ main_plot <- grid::gTree( |
| 53 | -44x | +189 | +9x |
- if (ltr_blq_ratio > 1 / 2 && !stat == "max") {
+ children = grid::gList( |
| 54 | -12x | +190 | +9x |
- val <- NA # 1/2_GT+ if (border) grid::rectGrob(), |
| 55 | -12x | +191 | +9x |
- na_str <- "ND" # 1/2_GT+ grid::gTree( |
| 56 | -+ | |||
| 192 | +9x |
- }+ children = grid::gList( |
||
| 57 | -+ | |||
| 193 | +9x |
- }+ grob |
||
| 58 | +194 |
-
+ ), |
||
| 59 | -128x | +195 | +9x |
- list(val = val, na_str = na_str)+ vp = grid::plotViewport(margins = padding) # innermost margins of the grob plot |
| 60 | +196 |
- }+ ) |
| 1 | +197 |
- #' Add titles, footnotes, page Number, and a bounding box to a grid grob+ ), |
||
| 2 | -+ | |||
| 198 | +9x |
- #'+ vp = grid::vpStack( |
||
| 3 | -+ | |||
| 199 | +9x |
- #' @description `r lifecycle::badge("stable")`
+ grid::viewport(layout.pos.row = 2, layout.pos.col = 1), |
||
| 4 | -+ | |||
| 200 | +9x |
- #'+ grid::plotViewport(margins = margins) # margins around the border plot |
||
| 5 | +201 |
- #' This function is useful to label grid grobs (also `ggplot2`, and `lattice` plots)+ ) |
||
| 6 | +202 |
- #' with title, footnote, and page numbers.+ ) |
||
| 7 | +203 |
- #'+ |
||
| 8 | -+ | |||
| 204 | +9x |
- #' @inheritParams grid::grob+ grid::gTree( |
||
| 9 | -+ | |||
| 205 | +9x |
- #' @param grob (`grob`)\cr a grid grob object, optionally `NULL` if only a `grob` with the decoration should be shown.+ grob = grob, |
||
| 10 | -+ | |||
| 206 | +9x |
- #' @param titles (`character`)\cr titles given as a vector of strings that are each separated by a newline and wrapped+ titles = titles, |
||
| 11 | -+ | |||
| 207 | +9x |
- #' according to the page width.+ footnotes = footnotes, |
||
| 12 | -+ | |||
| 208 | +9x |
- #' @param footnotes (`character`)\cr footnotes. Uses the same formatting rules as `titles`.+ page = page, |
||
| 13 | -+ | |||
| 209 | +9x |
- #' @param page (`string` or `NULL`)\cr page numeration. If `NULL` then no page number is displayed.+ width_titles = width_titles, |
||
| 14 | -+ | |||
| 210 | +9x |
- #' @param width_titles (`grid::unit`)\cr width of titles. Usually defined as all the available space+ width_footnotes = width_footnotes,+ |
+ ||
| 211 | +9x | +
+ outer_margins = outer_margins,+ |
+ ||
| 212 | +9x | +
+ gp_titles = gp_titles,+ |
+ ||
| 213 | +9x | +
+ gp_footnotes = gp_footnotes,+ |
+ ||
| 214 | +9x | +
+ children = grid::gList(+ |
+ ||
| 215 | +9x | +
+ grid::gTree(+ |
+ ||
| 216 | +9x | +
+ children = grid::gList(+ |
+ ||
| 217 | +9x | +
+ st_titles,+ |
+ ||
| 218 | +9x | +
+ main_plot, # main plot with border, padding, and margins+ |
+ ||
| 219 | +9x | +
+ st_footnotes,+ |
+ ||
| 220 | +9x | +
+ pg_footnote |
||
| 15 | +221 |
- #' `grid::unit(1, "npc")`, it is affected by the parameter `outer_margins`. Right margins (`outer_margins[4]`)+ ),+ |
+ ||
| 222 | +9x | +
+ childrenvp = NULL,+ |
+ ||
| 223 | +9x | +
+ name = "titles_grob_footnotes",+ |
+ ||
| 224 | +9x | +
+ vp = grid::vpStack(+ |
+ ||
| 225 | +9x | +
+ grid::plotViewport(margins = outer_margins), # Main external margins+ |
+ ||
| 226 | +9x | +
+ grid::viewport(+ |
+ ||
| 227 | +9x | +
+ layout = grid::grid.layout(+ |
+ ||
| 228 | +9x | +
+ nrow = 4, ncol = 1,+ |
+ ||
| 229 | +9x | +
+ heights = grid::unit.c(+ |
+ ||
| 230 | +9x | +
+ grid::grobHeight(st_titles),+ |
+ ||
| 231 | +9x | +
+ grid::unit(1, "null"),+ |
+ ||
| 232 | +9x | +
+ grid::grobHeight(st_footnotes),+ |
+ ||
| 233 | +9x | +
+ grid::grobHeight(pg_footnote) |
||
| 16 | +234 |
- #' need to be subtracted to the allowed width.+ ) |
||
| 17 | +235 |
- #' @param width_footnotes (`grid::unit`)\cr width of footnotes. Same default and margin correction as `width_titles`.+ ) |
||
| 18 | +236 |
- #' @param border (`flag`)\cr whether a border should be drawn around the plot or not.+ ) |
||
| 19 | +237 |
- #' @param padding (`grid::unit`)\cr padding. A unit object of length 4. Innermost margin between the plot (`grob`)+ ) |
||
| 20 | +238 |
- #' and, possibly, the border of the plot. Usually expressed in 4 identical values (usually `"lines"`). It defaults+ ) |
||
| 21 | +239 |
- #' to `grid::unit(rep(1, 4), "lines")`.+ ), |
||
| 22 | -+ | |||
| 240 | +9x |
- #' @param margins (`grid::unit`)\cr margins. A unit object of length 4. Margins between the plot and the other+ name = name, |
||
| 23 | -+ | |||
| 241 | +9x |
- #' elements in the list (e.g. titles, plot, and footers). This is usually expressed in 4 `"lines"`, where the+ gp = gp, |
||
| 24 | -+ | |||
| 242 | +9x |
- #' lateral ones are 0s, while top and bottom are 1s. It defaults to `grid::unit(c(1, 0, 1, 0), "lines")`.+ vp = vp, |
||
| 25 | -+ | |||
| 243 | +9x |
- #' @param outer_margins (`grid::unit`)\cr outer margins. A unit object of length 4. It defines the general margin of+ cl = "decoratedGrob" |
||
| 26 | +244 |
- #' the plot, considering also decorations like titles, footnotes, and page numbers. It defaults to+ ) |
||
| 27 | +245 |
- #' `grid::unit(c(2, 1.5, 3, 1.5), "cm")`.+ } |
||
| 28 | +246 |
- #' @param gp_titles (`gpar`)\cr a `gpar` object. Mainly used to set different `"fontsize"`.+ |
||
| 29 | +247 |
- #' @param gp_footnotes (`gpar`)\cr a `gpar` object. Mainly used to set different `"fontsize"`.+ # nocov start |
||
| 30 | +248 |
- #'+ #' @importFrom grid validDetails |
||
| 31 | +249 |
- #' @return A grid grob (`gTree`).+ #' @noRd |
||
| 32 | +250 |
- #'+ validDetails.decoratedGrob <- function(x) {
|
||
| 33 | +251 |
- #' @details The titles and footnotes will be ragged, i.e. each title will be wrapped individually.+ checkmate::assert_character(x$titles) |
||
| 34 | +252 |
- #'+ checkmate::assert_character(x$footnotes) |
||
| 35 | +253 |
- #' @examples+ |
||
| 36 | +254 |
- #' library(grid)+ if (!is.null(x$grob)) {
|
||
| 37 | +255 |
- #'+ checkmate::assert_true(grid::is.grob(x$grob)) |
||
| 38 | +256 |
- #' titles <- c(+ } |
||
| 39 | +257 |
- #' "Edgar Anderson's Iris Data",+ if (length(x$page) == 1) {
|
||
| 40 | +258 |
- #' paste(+ checkmate::assert_character(x$page) |
||
| 41 | +259 |
- #' "This famous (Fisher's or Anderson's) iris data set gives the measurements",+ } |
||
| 42 | +260 |
- #' "in centimeters of the variables sepal length and width and petal length",+ if (!grid::is.unit(x$outer_margins)) {
|
||
| 43 | +261 |
- #' "and width, respectively, for 50 flowers from each of 3 species of iris."+ checkmate::assert_vector(x$outer_margins, len = 4) |
||
| 44 | +262 |
- #' )+ } |
||
| 45 | +263 |
- #' )+ if (!grid::is.unit(x$margins)) {
|
||
| 46 | +264 |
- #'+ checkmate::assert_vector(x$margins, len = 4) |
||
| 47 | +265 |
- #' footnotes <- c(+ } |
||
| 48 | +266 |
- #' "The species are Iris setosa, versicolor, and virginica.",+ if (!grid::is.unit(x$padding)) {
|
||
| 49 | +267 |
- #' paste(+ checkmate::assert_vector(x$padding, len = 4) |
||
| 50 | +268 |
- #' "iris is a data frame with 150 cases (rows) and 5 variables (columns) named",+ } |
||
| 51 | +269 |
- #' "Sepal.Length, Sepal.Width, Petal.Length, Petal.Width, and Species."+ |
||
| 52 | +270 |
- #' )+ x |
||
| 53 | +271 |
- #' )+ } |
||
| 54 | +272 |
- #'+ |
||
| 55 | +273 |
- #' ## empty plot+ #' @importFrom grid widthDetails |
||
| 56 | +274 |
- #' grid.newpage()+ #' @noRd |
||
| 57 | +275 |
- #'+ widthDetails.decoratedGrob <- function(x) {
|
||
| 58 | +276 |
- #' grid.draw(+ grid::unit(1, "null") |
||
| 59 | +277 |
- #' decorate_grob(+ } |
||
| 60 | +278 |
- #' NULL,+ |
||
| 61 | +279 |
- #' titles = titles,+ #' @importFrom grid heightDetails |
||
| 62 | +280 |
- #' footnotes = footnotes,+ #' @noRd |
||
| 63 | +281 |
- #' page = "Page 4 of 10"+ heightDetails.decoratedGrob <- function(x) {
|
||
| 64 | +282 |
- #' )+ grid::unit(1, "null") |
||
| 65 | +283 |
- #' )+ } |
||
| 66 | +284 |
- #'+ |
||
| 67 | +285 |
- #' # grid+ #' Split text according to available text width |
||
| 68 | +286 |
- #' p <- gTree(+ #' |
||
| 69 | +287 |
- #' children = gList(+ #' Dynamically wrap text. |
||
| 70 | +288 |
- #' rectGrob(),+ #' |
||
| 71 | +289 |
- #' xaxisGrob(),+ #' @inheritParams grid::grid.text |
||
| 72 | +290 |
- #' yaxisGrob(),+ #' @param text (`string`)\cr the text to wrap. |
||
| 73 | +291 |
- #' textGrob("Sepal.Length", y = unit(-4, "lines")),
+ #' @param width (`grid::unit`)\cr a unit object specifying maximum width of text. |
||
| 74 | +292 |
- #' textGrob("Petal.Length", x = unit(-3.5, "lines"), rot = 90),
+ #' |
||
| 75 | +293 |
- #' pointsGrob(iris$Sepal.Length, iris$Petal.Length, gp = gpar(col = iris$Species), pch = 16)+ #' @return A text `grob`. |
||
| 76 | +294 |
- #' ),+ #' |
||
| 77 | +295 |
- #' vp = vpStack(plotViewport(), dataViewport(xData = iris$Sepal.Length, yData = iris$Petal.Length))+ #' @details This code is taken from `R Graphics by Paul Murell, 2nd edition` |
||
| 78 | +296 |
- #' )+ #' |
||
| 79 | +297 |
- #' grid.newpage()+ #' @keywords internal |
||
| 80 | +298 |
- #' grid.draw(p)+ split_text_grob <- function(text, |
||
| 81 | +299 |
- #'+ x = grid::unit(0.5, "npc"), |
||
| 82 | +300 |
- #' grid.newpage()+ y = grid::unit(0.5, "npc"), |
||
| 83 | +301 |
- #' grid.draw(+ width = grid::unit(1, "npc"), |
||
| 84 | +302 |
- #' decorate_grob(+ just = "centre", |
||
| 85 | +303 |
- #' grob = p,+ hjust = NULL, |
||
| 86 | +304 |
- #' titles = titles,+ vjust = NULL, |
||
| 87 | +305 |
- #' footnotes = footnotes,+ default.units = "npc", # nolint |
||
| 88 | +306 |
- #' page = "Page 6 of 129"+ name = NULL, |
||
| 89 | +307 |
- #' )+ gp = grid::gpar(), |
||
| 90 | +308 |
- #' )+ vp = NULL) {
|
||
| 91 | +309 |
- #'+ text <- gsub("\\\\n", "\n", text) # fixing cases of mixed behavior (\n and \\n)
|
||
| 92 | +310 |
- #' ## with ggplot2+ |
||
| 93 | +311 |
- #' library(ggplot2)+ if (!grid::is.unit(x)) x <- grid::unit(x, default.units) |
||
| 94 | +312 |
- #'+ if (!grid::is.unit(y)) y <- grid::unit(y, default.units) |
||
| 95 | +313 |
- #' p_gg <- ggplot2::ggplot(iris, aes(Sepal.Length, Sepal.Width, col = Species)) ++ if (!grid::is.unit(width)) width <- grid::unit(width, default.units) |
||
| 96 | +314 |
- #' ggplot2::geom_point()+ if (grid::unitType(x) %in% c("sum", "min", "max")) x <- grid::convertUnit(x, default.units)
|
||
| 97 | +315 |
- #' p_gg+ if (grid::unitType(y) %in% c("sum", "min", "max")) y <- grid::convertUnit(y, default.units)
|
||
| 98 | +316 |
- #' p <- ggplotGrob(p_gg)+ if (grid::unitType(width) %in% c("sum", "min", "max")) width <- grid::convertUnit(width, default.units)
|
||
| 99 | +317 |
- #' grid.newpage()+ |
||
| 100 | +318 |
- #' grid.draw(+ if (length(gp) > 0) { # account for effect of gp on text width -> it was bugging when text was empty
|
||
| 101 | +319 |
- #' decorate_grob(+ horizontal_npc_width_no_gp <- grid::convertWidth( |
||
| 102 | +320 |
- #' grob = p,+ grid::grobWidth( |
||
| 103 | +321 |
- #' titles = titles,+ grid::textGrob( |
||
| 104 | +322 |
- #' footnotes = footnotes,+ paste0(text, collapse = "\n") |
||
| 105 | +323 |
- #' page = "Page 6 of 129"+ ) |
||
| 106 | +324 |
- #' )+ ), "npc", |
||
| 107 | +325 |
- #' )+ valueOnly = TRUE |
||
| 108 | +326 |
- #'+ ) |
||
| 109 | +327 |
- #' ## with lattice+ horizontal_npc_width_with_gp <- grid::convertWidth(grid::grobWidth( |
||
| 110 | +328 |
- #' library(lattice)+ grid::textGrob( |
||
| 111 | +329 |
- #'+ paste0(text, collapse = "\n"), |
||
| 112 | +330 |
- #' xyplot(Sepal.Length ~ Petal.Length, data = iris, col = iris$Species)+ gp = gp |
||
| 113 | +331 |
- #' p <- grid.grab()+ ) |
||
| 114 | +332 |
- #' grid.newpage()+ ), "npc", valueOnly = TRUE) |
||
| 115 | +333 |
- #' grid.draw(+ |
||
| 116 | +334 |
- #' decorate_grob(+ # Adapting width to the input gpar (it is normalized so does not matter what is text) |
||
| 117 | +335 |
- #' grob = p,+ width <- width * horizontal_npc_width_no_gp / horizontal_npc_width_with_gp |
||
| 118 | +336 |
- #' titles = titles,+ } |
||
| 119 | +337 |
- #' footnotes = footnotes,+ |
||
| 120 | +338 |
- #' page = "Page 6 of 129"+ ## if it is a fixed unit then we do not need to recalculate when viewport resized |
||
| 121 | +339 |
- #' )+ if (!inherits(width, "unit.arithmetic") && !is.null(attr(width, "unit")) && |
||
| 122 | +340 |
- #' )+ attr(width, "unit") %in% c("cm", "inches", "mm", "points", "picas", "bigpts", "dida", "cicero", "scaledpts")) { # nolint
|
||
| 123 | +341 |
- #'+ attr(text, "fixed_text") <- paste(vapply(text, split_string, character(1), width = width), collapse = "\n") |
||
| 124 | +342 |
- #' # with gridExtra - no borders+ } |
||
| 125 | +343 |
- #' library(gridExtra)+ |
||
| 126 | +344 |
- #' grid.newpage()+ # Fix for split_string in case of residual \n (otherwise is counted as character) |
||
| 127 | +345 |
- #' grid.draw(+ text2 <- unlist( |
||
| 128 | +346 |
- #' decorate_grob(+ strsplit( |
||
| 129 | +347 |
- #' tableGrob(+ paste0(text, collapse = "\n"), # for "" cases |
||
| 130 | +348 |
- #' head(mtcars)+ "\n" |
||
| 131 | +349 |
- #' ),+ ) |
||
| 132 | +350 |
- #' titles = "title",+ ) |
||
| 133 | +351 |
- #' footnotes = "footnote",+ |
||
| 134 | +352 |
- #' border = FALSE+ # Final grid text with cat-friendly split_string |
||
| 135 | +353 |
- #' )+ grid::grid.text( |
||
| 136 | +354 |
- #' )+ label = split_string(text2, width), |
||
| 137 | +355 |
- #'+ x = x, y = y, |
||
| 138 | +356 |
- #' @export+ just = just, |
||
| 139 | +357 |
- decorate_grob <- function(grob,+ hjust = hjust, |
||
| 140 | +358 |
- titles,+ vjust = vjust, |
||
| 141 | +359 |
- footnotes,+ rot = 0, |
||
| 142 | +360 |
- page = "",+ check.overlap = FALSE, |
||
| 143 | +361 |
- width_titles = grid::unit(1, "npc"),+ name = name, |
||
| 144 | +362 |
- width_footnotes = grid::unit(1, "npc"),+ gp = gp, |
||
| 145 | +363 |
- border = TRUE,+ vp = vp, |
||
| 146 | +364 |
- padding = grid::unit(rep(1, 4), "lines"),+ draw = FALSE |
||
| 147 | +365 |
- margins = grid::unit(c(1, 0, 1, 0), "lines"),+ ) |
||
| 148 | +366 |
- outer_margins = grid::unit(c(2, 1.5, 3, 1.5), "cm"),+ } |
||
| 149 | +367 |
- gp_titles = grid::gpar(),+ |
||
| 150 | +368 |
- gp_footnotes = grid::gpar(fontsize = 8),+ #' @importFrom grid validDetails |
||
| 151 | +369 |
- name = NULL,+ #' @noRd |
||
| 152 | +370 |
- gp = grid::gpar(),+ validDetails.dynamicSplitText <- function(x) {
|
||
| 153 | +371 |
- vp = NULL) {
+ checkmate::assert_character(x$text) |
||
| 154 | +372 |
- # External margins need to be taken into account when defining the width of titles and footers+ checkmate::assert_true(grid::is.unit(x$width)) |
||
| 155 | +373 |
- # because the text is split in advance depending on only the width of the viewport.- |
- ||
| 156 | -9x | -
- if (any(as.numeric(outer_margins) > 0)) {
- |
- ||
| 157 | -9x | -
- width_titles <- width_titles - outer_margins[4]+ checkmate::assert_vector(x$width, len = 1) |
||
| 158 | -9x | +|||
| 374 | +
- width_footnotes <- width_footnotes - outer_margins[4]+ x |
|||
| 159 | +375 |
- }+ } |
||
| 160 | +376 | |||
| 161 | -9x | -
- st_titles <- split_text_grob(- |
- ||
| 162 | -9x | -
- titles,- |
- ||
| 163 | -9x | -
- x = 0, y = 1,- |
- ||
| 164 | -9x | -
- just = c("left", "top"),
- |
- ||
| 165 | -9x | -
- width = width_titles,- |
- ||
| 166 | -9x | -
- vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 1),- |
- ||
| 167 | -9x | -
- gp = gp_titles- |
- ||
| 168 | +377 |
- )+ #' @importFrom grid heightDetails |
||
| 169 | +378 |
-
+ #' @noRd |
||
| 170 | -9x | +|||
| 379 | +
- st_footnotes <- split_text_grob(+ heightDetails.dynamicSplitText <- function(x) {
|
|||
| 171 | -9x | +|||
| 380 | +
- footnotes,+ txt <- if (!is.null(attr(x$text, "fixed_text"))) {
|
|||
| 172 | -9x | +|||
| 381 | +
- x = 0, y = 1,+ attr(x$text, "fixed_text") |
|||
| 173 | -9x | +|||
| 382 | +
- just = c("left", "top"),
+ } else {
|
|||
| 174 | -9x | +|||
| 383 | +
- width = width_footnotes,+ paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n") |
|||
| 175 | -9x | +|||
| 384 | +
- vp = grid::viewport(layout.pos.row = 3, layout.pos.col = 1),+ } |
|||
| 176 | -9x | +|||
| 385 | +
- gp = gp_footnotes+ grid::stringHeight(txt) |
|||
| 177 | +386 |
- )+ } |
||
| 178 | +387 | |||
| 179 | -9x | -
- pg_footnote <- grid::textGrob(- |
- ||
| 180 | -9x | +|||
| 388 | +
- paste("\n", page),
+ #' @importFrom grid widthDetails |
|||
| 181 | -9x | +|||
| 389 | +
- x = 1, y = 0,+ #' @noRd |
|||
| 182 | -9x | +|||
| 390 | +
- just = c("right", "bottom"),
+ widthDetails.dynamicSplitText <- function(x) {
|
|||
| 183 | -9x | +|||
| 391 | +
- vp = grid::viewport(layout.pos.row = 4, layout.pos.col = 1),+ x$width |
|||
| 184 | -9x | +|||
| 392 | +
- gp = gp_footnotes+ } |
|||
| 185 | +393 |
- )+ |
||
| 186 | +394 |
-
+ #' @importFrom grid drawDetails |
||
| 187 | +395 |
- # Initial decoration of the grob -> border, paddings, and margins are used here+ #' @noRd |
||
| 188 | -9x | +|||
| 396 | +
- main_plot <- grid::gTree(+ drawDetails.dynamicSplitText <- function(x, recording) {
|
|||
| 189 | -9x | +|||
| 397 | +
- children = grid::gList(+ txt <- if (!is.null(attr(x$text, "fixed_text"))) {
|
|||
| 190 | -9x | +|||
| 398 | +
- if (border) grid::rectGrob(),+ attr(x$text, "fixed_text") |
|||
| 191 | -9x | +|||
| 399 | +
- grid::gTree(+ } else {
|
|||
| 192 | -9x | +|||
| 400 | +
- children = grid::gList(+ paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n") |
|||
| 193 | -9x | +|||
| 401 | +
- grob+ } |
|||
| 194 | +402 |
- ),+ |
||
| 195 | -9x | +|||
| 403 | +
- vp = grid::plotViewport(margins = padding) # innermost margins of the grob plot+ x$width <- NULL |
|||
| 196 | +404 |
- )+ x$label <- txt |
||
| 197 | +405 |
- ),+ x$text <- NULL |
||
| 198 | -9x | +|||
| 406 | +
- vp = grid::vpStack(+ class(x) <- c("text", class(x)[-1])
|
|||
| 199 | -9x | +|||
| 407 | +
- grid::viewport(layout.pos.row = 2, layout.pos.col = 1),+ |
|||
| 200 | -9x | +|||
| 408 | +
- grid::plotViewport(margins = margins) # margins around the border plot+ grid::grid.draw(x) |
|||
| 201 | +409 |
- )+ } |
||
| 202 | +410 |
- )+ # nocov end |
||
| 203 | +411 | |||
| 204 | -9x | +|||
| 412 | +
- grid::gTree(+ # Adapted from Paul Murell R Graphics 2nd Edition |
|||
| 205 | -9x | +|||
| 413 | +
- grob = grob,+ # https://www.stat.auckland.ac.nz/~paul/RG2e/interactgrid-splittext.R |
|||
| 206 | -9x | +|||
| 414 | +
- titles = titles,+ split_string <- function(text, width) {
|
|||
| 207 | -9x | +415 | +26x |
- footnotes = footnotes,+ strings <- strsplit(text, " ") |
| 208 | -9x | +416 | +26x |
- page = page,+ out_string <- NA |
| 209 | -9x | +417 | +26x |
- width_titles = width_titles,+ for (string_i in seq_along(strings)) {
|
| 210 | -9x | +418 | +48x |
- width_footnotes = width_footnotes,+ newline_str <- strings[[string_i]] |
| 211 | -9x | +419 | +6x |
- outer_margins = outer_margins,+ if (length(newline_str) == 0) newline_str <- "" |
| 212 | -9x | +420 | +48x |
- gp_titles = gp_titles,+ if (is.na(out_string[string_i])) {
|
| 213 | -9x | +421 | +48x |
- gp_footnotes = gp_footnotes,+ out_string[string_i] <- newline_str[[1]][[1]] |
| 214 | -9x | +422 | +48x |
- children = grid::gList(+ linewidth <- grid::stringWidth(out_string[string_i]) |
| 215 | -9x | +|||
| 423 | +
- grid::gTree(+ } |
|||
| 216 | -9x | +424 | +48x |
- children = grid::gList(+ gapwidth <- grid::stringWidth(" ")
|
| 217 | -9x | +425 | +48x |
- st_titles,+ availwidth <- as.numeric(width) |
| 218 | -9x | +426 | +48x |
- main_plot, # main plot with border, padding, and margins+ if (length(newline_str) > 1) {
|
| 219 | -9x | +427 | +12x |
- st_footnotes,+ for (i in seq(2, length(newline_str))) {
|
| 220 | -9x | +428 | +184x |
- pg_footnote+ width_i <- grid::stringWidth(newline_str[i]) |
| 221 | -- |
- ),- |
- ||
| 222 | -9x | -
- childrenvp = NULL,- |
- ||
| 223 | -9x | -
- name = "titles_grob_footnotes",- |
- ||
| 224 | -9x | -
- vp = grid::vpStack(- |
- ||
| 225 | -9x | +429 | +
- grid::plotViewport(margins = outer_margins), # Main external margins+ # Main conversion of allowed text width -> npc units are 0<npc<1. External viewport is used for conversion |
|
| 226 | -9x | +430 | +184x |
- grid::viewport(+ if (grid::convertWidth(linewidth + gapwidth + width_i, grid::unitType(width), valueOnly = TRUE) < availwidth) {
|
| 227 | -9x | +431 | +177x |
- layout = grid::grid.layout(+ sep <- " " |
| 228 | -9x | +432 | +177x |
- nrow = 4, ncol = 1,+ linewidth <- linewidth + gapwidth + width_i |
| 229 | -9x | +|||
| 433 | +
- heights = grid::unit.c(+ } else {
|
|||
| 230 | -9x | +434 | +7x |
- grid::grobHeight(st_titles),+ sep <- "\n" |
| 231 | -9x | +435 | +7x |
- grid::unit(1, "null"),+ linewidth <- width_i |
| 232 | -9x | +|||
| 436 | +
- grid::grobHeight(st_footnotes),+ } |
|||
| 233 | -9x | +437 | +184x |
- grid::grobHeight(pg_footnote)+ out_string[string_i] <- paste(out_string[string_i], newline_str[i], sep = sep) |
| 234 | +438 |
- )+ } |
||
| 235 | +439 |
- )+ } |
||
| 236 | +440 |
- )+ } |
||
| 237 | -+ | |||
| 441 | +26x |
- )+ paste(out_string, collapse = "\n") |
||
| 238 | +442 |
- )+ } |
||
| 239 | +443 |
- ),+ |
||
| 240 | -9x | +|||
| 444 | +
- name = name,+ #' Update page number |
|||
| 241 | -9x | +|||
| 445 | +
- gp = gp,+ #' |
|||
| 242 | -9x | +|||
| 446 | +
- vp = vp,+ #' Automatically updates page number. |
|||
| 243 | -9x | +|||
| 447 | +
- cl = "decoratedGrob"+ #' |
|||
| 244 | +448 |
- )+ #' @param npages (`numeric(1)`)\cr total number of pages. |
||
| 245 | +449 |
- }+ #' @param ... arguments passed on to [decorate_grob()]. |
||
| 246 | +450 |
-
+ #' |
||
| 247 | +451 |
- # nocov start+ #' @return Closure that increments the page number. |
||
| 248 | +452 |
- #' @importFrom grid validDetails+ #' |
||
| 249 | +453 |
- #' @noRd+ #' @keywords internal |
||
| 250 | +454 |
- validDetails.decoratedGrob <- function(x) {
+ decorate_grob_factory <- function(npages, ...) {
|
||
| 251 | -+ | |||
| 455 | +2x |
- checkmate::assert_character(x$titles)+ current_page <- 0 |
||
| 252 | -+ | |||
| 456 | +2x |
- checkmate::assert_character(x$footnotes)+ function(grob) {
|
||
| 253 | -+ | |||
| 457 | +7x |
-
+ current_page <<- current_page + 1 |
||
| 254 | -+ | |||
| 458 | +7x |
- if (!is.null(x$grob)) {
+ if (current_page > npages) {
+ |
+ ||
| 459 | +1x | +
+ stop(paste("current page is", current_page, "but max.", npages, "specified."))
|
||
| 255 | +460 |
- checkmate::assert_true(grid::is.grob(x$grob))+ }+ |
+ ||
| 461 | +6x | +
+ decorate_grob(grob = grob, page = paste("Page", current_page, "of", npages), ...)
|
||
| 256 | +462 |
} |
||
| 257 | +463 |
- if (length(x$page) == 1) {
+ } |
||
| 258 | +464 |
- checkmate::assert_character(x$page)+ |
||
| 259 | +465 |
- }+ #' Decorate set of `grob`s and add page numbering |
||
| 260 | +466 |
- if (!grid::is.unit(x$outer_margins)) {
+ #' |
||
| 261 | +467 |
- checkmate::assert_vector(x$outer_margins, len = 4)+ #' @description `r lifecycle::badge("stable")`
|
||
| 262 | +468 |
- }+ #' |
||
| 263 | +469 |
- if (!grid::is.unit(x$margins)) {
+ #' Note that this uses the [decorate_grob_factory()] function. |
||
| 264 | +470 |
- checkmate::assert_vector(x$margins, len = 4)+ #' |
||
| 265 | +471 |
- }+ #' @param grobs (`list` of `grob`)\cr a list of grid grobs. |
||
| 266 | +472 |
- if (!grid::is.unit(x$padding)) {
+ #' @param ... arguments passed on to [decorate_grob()]. |
||
| 267 | +473 |
- checkmate::assert_vector(x$padding, len = 4)+ #' |
||
| 268 | +474 |
- }+ #' @return A decorated grob. |
||
| 269 | +475 |
-
+ #' |
||
| 270 | +476 |
- x+ #' @examples |
||
| 271 | +477 |
- }+ #' library(ggplot2) |
||
| 272 | +478 |
-
+ #' library(grid) |
||
| 273 | +479 |
- #' @importFrom grid widthDetails+ #' g <- with(data = iris, {
|
||
| 274 | +480 |
- #' @noRd+ #' list( |
||
| 275 | +481 |
- widthDetails.decoratedGrob <- function(x) {
+ #' ggplot2::ggplotGrob( |
||
| 276 | +482 |
- grid::unit(1, "null")+ #' ggplot2::ggplot(mapping = aes(Sepal.Length, Sepal.Width, col = Species)) + |
||
| 277 | +483 |
- }+ #' ggplot2::geom_point() |
||
| 278 | +484 |
-
+ #' ), |
||
| 279 | +485 |
- #' @importFrom grid heightDetails+ #' ggplot2::ggplotGrob( |
||
| 280 | +486 |
- #' @noRd+ #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Length, col = Species)) + |
||
| 281 | +487 |
- heightDetails.decoratedGrob <- function(x) {
+ #' ggplot2::geom_point() |
||
| 282 | +488 |
- grid::unit(1, "null")+ #' ), |
||
| 283 | +489 |
- }+ #' ggplot2::ggplotGrob( |
||
| 284 | +490 |
-
+ #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Width, col = Species)) + |
||
| 285 | +491 |
- #' Split text according to available text width+ #' ggplot2::geom_point() |
||
| 286 | +492 |
- #'+ #' ), |
||
| 287 | +493 |
- #' Dynamically wrap text.+ #' ggplot2::ggplotGrob( |
||
| 288 | +494 |
- #'+ #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Length, col = Species)) + |
||
| 289 | +495 |
- #' @inheritParams grid::grid.text+ #' ggplot2::geom_point() |
||
| 290 | +496 |
- #' @param text (`string`)\cr the text to wrap.+ #' ), |
||
| 291 | +497 |
- #' @param width (`grid::unit`)\cr a unit object specifying maximum width of text.+ #' ggplot2::ggplotGrob( |
||
| 292 | +498 |
- #'+ #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Width, col = Species)) + |
||
| 293 | +499 |
- #' @return A text `grob`.+ #' ggplot2::geom_point() |
||
| 294 | +500 |
- #'+ #' ), |
||
| 295 | +501 |
- #' @details This code is taken from `R Graphics by Paul Murell, 2nd edition`+ #' ggplot2::ggplotGrob( |
||
| 296 | +502 |
- #'+ #' ggplot2::ggplot(mapping = aes(Petal.Length, Petal.Width, col = Species)) + |
||
| 297 | +503 |
- #' @keywords internal+ #' ggplot2::geom_point() |
||
| 298 | +504 |
- split_text_grob <- function(text,+ #' ) |
||
| 299 | +505 |
- x = grid::unit(0.5, "npc"),+ #' ) |
||
| 300 | +506 |
- y = grid::unit(0.5, "npc"),+ #' }) |
||
| 301 | +507 |
- width = grid::unit(1, "npc"),+ #' lg <- decorate_grob_set(grobs = g, titles = "Hello\nOne\nTwo\nThree", footnotes = "") |
||
| 302 | +508 |
- just = "centre",+ #' |
||
| 303 | +509 |
- hjust = NULL,+ #' draw_grob(lg[[1]]) |
||
| 304 | +510 |
- vjust = NULL,+ #' draw_grob(lg[[2]]) |
||
| 305 | +511 |
- default.units = "npc", # nolint+ #' draw_grob(lg[[6]]) |
||
| 306 | +512 |
- name = NULL,+ #' |
||
| 307 | +513 |
- gp = grid::gpar(),+ #' @export |
||
| 308 | +514 |
- vp = NULL) {
+ decorate_grob_set <- function(grobs, ...) {
|
||
| 309 | -+ | |||
| 515 | +1x |
- text <- gsub("\\\\n", "\n", text) # fixing cases of mixed behavior (\n and \\n)
+ n <- length(grobs) |
||
| 310 | -+ | |||
| 516 | +1x |
-
+ lgf <- decorate_grob_factory(npages = n, ...) |
||
| 311 | -+ | |||
| 517 | +1x |
- if (!grid::is.unit(x)) x <- grid::unit(x, default.units)+ lapply(grobs, lgf) |
||
| 312 | +518 |
- if (!grid::is.unit(y)) y <- grid::unit(y, default.units)+ } |
| 313 | +1 |
- if (!grid::is.unit(width)) width <- grid::unit(width, default.units)+ #' Horizontal waterfall plot |
||
| 314 | +2 |
- if (grid::unitType(x) %in% c("sum", "min", "max")) x <- grid::convertUnit(x, default.units)
+ #' |
||
| 315 | +3 |
- if (grid::unitType(y) %in% c("sum", "min", "max")) y <- grid::convertUnit(y, default.units)
+ #' @description `r lifecycle::badge("stable")`
|
||
| 316 | +4 |
- if (grid::unitType(width) %in% c("sum", "min", "max")) width <- grid::convertUnit(width, default.units)
+ #' |
||
| 317 | +5 |
-
+ #' This basic waterfall plot visualizes a quantity `height` ordered by value with some markup. |
||
| 318 | +6 |
- if (length(gp) > 0) { # account for effect of gp on text width -> it was bugging when text was empty
+ #' |
||
| 319 | +7 |
- horizontal_npc_width_no_gp <- grid::convertWidth(+ #' @param height (`numeric`)\cr vector containing values to be plotted as the waterfall bars. |
||
| 320 | +8 |
- grid::grobWidth(+ #' @param id (`character`)\cr vector containing identifiers to use as the x-axis label for the waterfall bars. |
||
| 321 | +9 |
- grid::textGrob(+ #' @param col (`character`)\cr color(s). |
||
| 322 | +10 |
- paste0(text, collapse = "\n")+ #' @param col_var (`factor`, `character`, or `NULL`)\cr categorical variable for bar coloring. `NULL` by default. |
||
| 323 | +11 |
- )+ #' @param xlab (`string`)\cr x label. Default is `"ID"`. |
||
| 324 | +12 |
- ), "npc",+ #' @param ylab (`string`)\cr y label. Default is `"Value"`. |
||
| 325 | +13 |
- valueOnly = TRUE+ #' @param title (`string`)\cr text to be displayed as plot title. |
||
| 326 | +14 |
- )+ #' @param col_legend_title (`string`)\cr text to be displayed as legend title. |
||
| 327 | +15 |
- horizontal_npc_width_with_gp <- grid::convertWidth(grid::grobWidth(+ #' |
||
| 328 | +16 |
- grid::textGrob(+ #' @return A `ggplot` waterfall plot. |
||
| 329 | +17 |
- paste0(text, collapse = "\n"),+ #' |
||
| 330 | +18 |
- gp = gp+ #' @examples |
||
| 331 | +19 |
- )+ #' library(dplyr) |
||
| 332 | +20 |
- ), "npc", valueOnly = TRUE)+ #' |
||
| 333 | +21 |
-
+ #' g_waterfall(height = c(3, 5, -1), id = letters[1:3]) |
||
| 334 | +22 |
- # Adapting width to the input gpar (it is normalized so does not matter what is text)+ #' |
||
| 335 | +23 |
- width <- width * horizontal_npc_width_no_gp / horizontal_npc_width_with_gp+ #' g_waterfall( |
||
| 336 | +24 |
- }+ #' height = c(3, 5, -1), |
||
| 337 | +25 |
-
+ #' id = letters[1:3], |
||
| 338 | +26 |
- ## if it is a fixed unit then we do not need to recalculate when viewport resized+ #' col_var = letters[1:3] |
||
| 339 | +27 |
- if (!inherits(width, "unit.arithmetic") && !is.null(attr(width, "unit")) &&+ #' ) |
||
| 340 | +28 |
- attr(width, "unit") %in% c("cm", "inches", "mm", "points", "picas", "bigpts", "dida", "cicero", "scaledpts")) { # nolint
+ #' |
||
| 341 | +29 |
- attr(text, "fixed_text") <- paste(vapply(text, split_string, character(1), width = width), collapse = "\n")+ #' adsl_f <- tern_ex_adsl %>% |
||
| 342 | +30 |
- }+ #' select(USUBJID, STUDYID, ARM, ARMCD, SEX) |
||
| 343 | +31 |
-
+ #' |
||
| 344 | +32 |
- # Fix for split_string in case of residual \n (otherwise is counted as character)+ #' adrs_f <- tern_ex_adrs %>% |
||
| 345 | +33 |
- text2 <- unlist(+ #' filter(PARAMCD == "OVRINV") %>% |
||
| 346 | +34 |
- strsplit(+ #' mutate(pchg = rnorm(n(), 10, 50)) |
||
| 347 | +35 |
- paste0(text, collapse = "\n"), # for "" cases+ #' |
||
| 348 | +36 |
- "\n"+ #' adrs_f <- head(adrs_f, 30) |
||
| 349 | +37 |
- )+ #' adrs_f <- adrs_f[!duplicated(adrs_f$USUBJID), ] |
||
| 350 | +38 |
- )+ #' head(adrs_f) |
||
| 351 | +39 |
-
+ #' |
||
| 352 | +40 |
- # Final grid text with cat-friendly split_string+ #' g_waterfall( |
||
| 353 | +41 |
- grid::grid.text(+ #' height = adrs_f$pchg, |
||
| 354 | +42 |
- label = split_string(text2, width),+ #' id = adrs_f$USUBJID, |
||
| 355 | +43 |
- x = x, y = y,+ #' col_var = adrs_f$AVALC |
||
| 356 | +44 |
- just = just,+ #' ) |
||
| 357 | +45 |
- hjust = hjust,+ #' |
||
| 358 | +46 |
- vjust = vjust,+ #' g_waterfall( |
||
| 359 | +47 |
- rot = 0,+ #' height = adrs_f$pchg, |
||
| 360 | +48 |
- check.overlap = FALSE,+ #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
|
||
| 361 | +49 |
- name = name,+ #' col_var = adrs_f$SEX |
||
| 362 | +50 |
- gp = gp,+ #' ) |
||
| 363 | +51 |
- vp = vp,+ #' |
||
| 364 | +52 |
- draw = FALSE+ #' g_waterfall( |
||
| 365 | +53 |
- )+ #' height = adrs_f$pchg, |
||
| 366 | +54 |
- }+ #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
|
||
| 367 | +55 |
-
+ #' xlab = "ID", |
||
| 368 | +56 |
- #' @importFrom grid validDetails+ #' ylab = "Percentage Change", |
||
| 369 | +57 |
- #' @noRd+ #' title = "Waterfall plot" |
||
| 370 | +58 |
- validDetails.dynamicSplitText <- function(x) {
+ #' ) |
||
| 371 | +59 |
- checkmate::assert_character(x$text)+ #' |
||
| 372 | +60 |
- checkmate::assert_true(grid::is.unit(x$width))+ #' @export |
||
| 373 | +61 |
- checkmate::assert_vector(x$width, len = 1)+ g_waterfall <- function(height, |
||
| 374 | +62 |
- x+ id, |
||
| 375 | +63 |
- }+ col_var = NULL, |
||
| 376 | +64 |
-
+ col = getOption("ggplot2.discrete.colour"),
|
||
| 377 | +65 |
- #' @importFrom grid heightDetails+ xlab = NULL, |
||
| 378 | +66 |
- #' @noRd+ ylab = NULL, |
||
| 379 | +67 |
- heightDetails.dynamicSplitText <- function(x) {
+ col_legend_title = NULL, |
||
| 380 | +68 |
- txt <- if (!is.null(attr(x$text, "fixed_text"))) {
+ title = NULL) {
|
||
| 381 | -+ | |||
| 69 | +2x |
- attr(x$text, "fixed_text")+ if (!is.null(col_var)) {
+ |
+ ||
| 70 | +1x | +
+ check_same_n(height = height, id = id, col_var = col_var) |
||
| 382 | +71 |
} else {
|
||
| 383 | -+ | |||
| 72 | +1x |
- paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n")+ check_same_n(height = height, id = id) |
||
| 384 | +73 |
} |
||
| 385 | +74 |
- grid::stringHeight(txt)+ |
||
| 386 | -+ | |||
| 75 | +2x |
- }+ checkmate::assert_multi_class(col_var, c("character", "factor"), null.ok = TRUE)
+ |
+ ||
| 76 | +2x | +
+ checkmate::assert_character(col, null.ok = TRUE) |
||
| 387 | +77 | |||
| 388 | -+ | |||
| 78 | +2x |
- #' @importFrom grid widthDetails+ xlabel <- deparse(substitute(id)) |
||
| 389 | -+ | |||
| 79 | +2x |
- #' @noRd+ ylabel <- deparse(substitute(height)) |
||
| 390 | +80 |
- widthDetails.dynamicSplitText <- function(x) {
+
|
||
| 391 | -+ | |||
| 81 | +2x |
- x$width+ col_label <- if (!missing(col_var)) {
|
||
| 392 | -+ | |||
| 82 | +1x |
- }+ deparse(substitute(col_var)) |
||
| 393 | +83 |
-
+ } |
||
| 394 | +84 |
- #' @importFrom grid drawDetails+ |
||
| 395 | -+ | |||
| 85 | +2x |
- #' @noRd+ xlab <- if (is.null(xlab)) xlabel else xlab |
||
| 396 | -+ | |||
| 86 | +2x |
- drawDetails.dynamicSplitText <- function(x, recording) {
+ ylab <- if (is.null(ylab)) ylabel else ylab |
||
| 397 | -+ | |||
| 87 | +2x |
- txt <- if (!is.null(attr(x$text, "fixed_text"))) {
+ col_legend_title <- if (is.null(col_legend_title)) col_label else col_legend_title |
||
| 398 | +88 |
- attr(x$text, "fixed_text")+ |
||
| 399 | -+ | |||
| 89 | +2x |
- } else {
+ plot_data <- data.frame( |
||
| 400 | -+ | |||
| 90 | +2x |
- paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n")+ height = height, |
||
| 401 | -+ | |||
| 91 | +2x |
- }+ id = as.character(id), |
||
| 402 | -+ | |||
| 92 | +2x |
-
+ col_var = if (is.null(col_var)) "x" else to_n(col_var, length(height)), |
||
| 403 | -+ | |||
| 93 | +2x |
- x$width <- NULL+ stringsAsFactors = FALSE |
||
| 404 | +94 |
- x$label <- txt+ ) |
||
| 405 | +95 |
- x$text <- NULL+ |
||
| 406 | -+ | |||
| 96 | +2x |
- class(x) <- c("text", class(x)[-1])
+ plot_data_ord <- plot_data[order(plot_data$height, decreasing = TRUE), ] |
||
| 407 | +97 | |||
| 408 | -+ | |||
| 98 | +2x |
- grid::grid.draw(x)+ p <- ggplot2::ggplot(plot_data_ord, ggplot2::aes(x = factor(id, levels = id), y = height)) + |
||
| 409 | -+ | |||
| 99 | +2x |
- }+ ggplot2::geom_col() + |
||
| 410 | -+ | |||
| 100 | +2x |
- # nocov end+ ggplot2::geom_text( |
||
| 411 | -+ | |||
| 101 | +2x |
-
+ label = format(plot_data_ord$height, digits = 2), |
||
| 412 | -+ | |||
| 102 | +2x |
- # Adapted from Paul Murell R Graphics 2nd Edition+ vjust = ifelse(plot_data_ord$height >= 0, -0.5, 1.5) |
||
| 413 | +103 |
- # https://www.stat.auckland.ac.nz/~paul/RG2e/interactgrid-splittext.R+ ) + |
||
| 414 | -+ | |||
| 104 | +2x |
- split_string <- function(text, width) {
+ ggplot2::xlab(xlab) + |
||
| 415 | -26x | +105 | +2x |
- strings <- strsplit(text, " ")+ ggplot2::ylab(ylab) + |
| 416 | -26x | +106 | +2x |
- out_string <- NA+ ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 0, vjust = .5)) |
| 417 | -26x | +|||
| 107 | +
- for (string_i in seq_along(strings)) {
+
|
|||
| 418 | -48x | +108 | +2x |
- newline_str <- strings[[string_i]]+ if (!is.null(col_var)) {
|
| 419 | -6x | +109 | +1x |
- if (length(newline_str) == 0) newline_str <- ""+ p <- p + |
| 420 | -48x | +110 | +1x |
- if (is.na(out_string[string_i])) {
+ ggplot2::aes(fill = col_var) + |
| 421 | -48x | +111 | +1x |
- out_string[string_i] <- newline_str[[1]][[1]]+ ggplot2::labs(fill = col_legend_title) + |
| 422 | -48x | +112 | +1x |
- linewidth <- grid::stringWidth(out_string[string_i])+ ggplot2::theme( |
| 423 | -+ | |||
| 113 | +1x |
- }+ legend.position = "bottom", |
||
| 424 | -48x | +114 | +1x |
- gapwidth <- grid::stringWidth(" ")
+ legend.background = ggplot2::element_blank(), |
| 425 | -48x | +115 | +1x |
- availwidth <- as.numeric(width)+ legend.title = ggplot2::element_text(face = "bold"), |
| 426 | -48x | +116 | +1x |
- if (length(newline_str) > 1) {
+ legend.box.background = ggplot2::element_rect(colour = "black") |
| 427 | -12x | +|||
| 117 | +
- for (i in seq(2, length(newline_str))) {
+ ) |
|||
| 428 | -184x | +|||
| 118 | +
- width_i <- grid::stringWidth(newline_str[i])+ } |
|||
| 429 | +119 |
- # Main conversion of allowed text width -> npc units are 0<npc<1. External viewport is used for conversion+ |
||
| 430 | -184x | +120 | +2x |
- if (grid::convertWidth(linewidth + gapwidth + width_i, grid::unitType(width), valueOnly = TRUE) < availwidth) {
+ if (!is.null(col)) {
|
| 431 | -177x | +121 | +1x |
- sep <- " "+ p <- p + |
| 432 | -177x | +122 | +1x |
- linewidth <- linewidth + gapwidth + width_i+ ggplot2::scale_fill_manual(values = col) |
| 433 | +123 |
- } else {
+ } |
||
| 434 | -7x | +|||
| 124 | +
- sep <- "\n"+ |
|||
| 435 | -7x | +125 | +2x |
- linewidth <- width_i+ if (!is.null(title)) {
|
| 436 | -+ | |||
| 126 | +1x |
- }+ p <- p + |
||
| 437 | -184x | +127 | +1x |
- out_string[string_i] <- paste(out_string[string_i], newline_str[i], sep = sep)+ ggplot2::labs(title = title) + |
| 438 | -+ | |||
| 128 | +1x |
- }+ ggplot2::theme(plot.title = ggplot2::element_text(face = "bold")) |
||
| 439 | +129 |
- }+ } |
||
| 440 | +130 |
- }+ |
||
| 441 | -26x | +131 | +2x |
- paste(out_string, collapse = "\n")+ p |
| 442 | +132 |
} |
| 443 | -- | - - | -||
| 444 | +1 |
- #' Update page number+ #' Cox regression helper function for interactions |
||
| 445 | +2 |
#' |
||
| 446 | +3 |
- #' Automatically updates page number.+ #' @description `r lifecycle::badge("stable")`
|
||
| 447 | +4 |
#' |
||
| 448 | +5 |
- #' @param npages (`numeric(1)`)\cr total number of pages.+ #' Test and estimate the effect of a treatment in interaction with a covariate. |
||
| 449 | +6 |
- #' @param ... arguments passed on to [decorate_grob()].+ #' The effect is estimated as the HR of the tested treatment for a given level |
||
| 450 | +7 |
- #'+ #' of the covariate, in comparison to the treatment control. |
||
| 451 | +8 |
- #' @return Closure that increments the page number.+ #' |
||
| 452 | +9 |
- #'+ #' @inheritParams argument_convention |
||
| 453 | +10 |
- #' @keywords internal+ #' @param x (`numeric` or `factor`)\cr the values of the covariate to be tested. |
||
| 454 | +11 |
- decorate_grob_factory <- function(npages, ...) {
- |
- ||
| 455 | -2x | -
- current_page <- 0- |
- ||
| 456 | -2x | -
- function(grob) {
- |
- ||
| 457 | -7x | -
- current_page <<- current_page + 1- |
- ||
| 458 | -7x | -
- if (current_page > npages) {
- |
- ||
| 459 | -1x | -
- stop(paste("current page is", current_page, "but max.", npages, "specified."))
+ #' @param effect (`string`)\cr the name of the effect to be tested and estimated. |
||
| 460 | +12 |
- }- |
- ||
| 461 | -6x | -
- decorate_grob(grob = grob, page = paste("Page", current_page, "of", npages), ...)
+ #' @param covar (`string`)\cr the name of the covariate in the model. |
||
| 462 | +13 |
- }+ #' @param mod (`coxph`)\cr the Cox regression model. |
||
| 463 | +14 |
- }+ #' @param label (`string`)\cr the label to be returned as `term_label`. |
||
| 464 | +15 |
-
+ #' @param control (`list`)\cr a list of controls as returned by [control_coxreg()]. |
||
| 465 | +16 |
- #' Decorate set of `grob`s and add page numbering+ #' @param ... see methods. |
||
| 466 | +17 |
#' |
||
| 467 | +18 |
- #' @description `r lifecycle::badge("stable")`
+ #' @examples |
||
| 468 | +19 |
- #'+ #' library(survival) |
||
| 469 | +20 |
- #' Note that this uses the [decorate_grob_factory()] function.+ #' |
||
| 470 | +21 |
- #'+ #' set.seed(1, kind = "Mersenne-Twister") |
||
| 471 | +22 |
- #' @param grobs (`list` of `grob`)\cr a list of grid grobs.+ #' |
||
| 472 | +23 |
- #' @param ... arguments passed on to [decorate_grob()].+ #' # Testing dataset [survival::bladder]. |
||
| 473 | +24 |
- #'+ #' dta_bladder <- with( |
||
| 474 | +25 |
- #' @return A decorated grob.+ #' data = bladder[bladder$enum < 5, ], |
||
| 475 | +26 |
- #'+ #' data.frame( |
||
| 476 | +27 |
- #' @examples+ #' time = stop, |
||
| 477 | +28 |
- #' library(ggplot2)+ #' status = event, |
||
| 478 | +29 |
- #' library(grid)+ #' armcd = as.factor(rx), |
||
| 479 | +30 |
- #' g <- with(data = iris, {
+ #' covar1 = as.factor(enum), |
||
| 480 | +31 |
- #' list(+ #' covar2 = factor( |
||
| 481 | +32 |
- #' ggplot2::ggplotGrob(+ #' sample(as.factor(enum)), |
||
| 482 | +33 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Length, Sepal.Width, col = Species)) ++ #' levels = 1:4, |
||
| 483 | +34 |
- #' ggplot2::geom_point()+ #' labels = c("F", "F", "M", "M")
|
||
| 484 | +35 |
- #' ),+ #' ) |
||
| 485 | +36 |
- #' ggplot2::ggplotGrob(+ #' ) |
||
| 486 | +37 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Length, col = Species)) ++ #' ) |
||
| 487 | +38 |
- #' ggplot2::geom_point()+ #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
|
||
| 488 | +39 |
- #' ),+ #' formatters::var_labels(dta_bladder)[names(labels)] <- labels |
||
| 489 | +40 |
- #' ggplot2::ggplotGrob(+ #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE) |
||
| 490 | +41 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Width, col = Species)) ++ #' |
||
| 491 | +42 |
- #' ggplot2::geom_point()+ #' plot( |
||
| 492 | +43 |
- #' ),+ #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder), |
||
| 493 | +44 |
- #' ggplot2::ggplotGrob(+ #' lty = 2:4, |
||
| 494 | +45 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Length, col = Species)) ++ #' xlab = "Months", |
||
| 495 | +46 |
- #' ggplot2::geom_point()+ #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
|
||
| 496 | +47 |
- #' ),+ #' ) |
||
| 497 | +48 |
- #' ggplot2::ggplotGrob(+ #' |
||
| 498 | +49 |
- #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Width, col = Species)) ++ #' @name cox_regression_inter |
||
| 499 | +50 |
- #' ggplot2::geom_point()+ NULL |
||
| 500 | +51 |
- #' ),+ |
||
| 501 | +52 |
- #' ggplot2::ggplotGrob(+ #' @describeIn cox_regression_inter S3 generic helper function to determine interaction effect. |
||
| 502 | +53 |
- #' ggplot2::ggplot(mapping = aes(Petal.Length, Petal.Width, col = Species)) ++ #' |
||
| 503 | +54 |
- #' ggplot2::geom_point()+ #' @return |
||
| 504 | +55 |
- #' )+ #' * `h_coxreg_inter_effect()` returns a `data.frame` of covariate interaction effects consisting of the following |
||
| 505 | +56 |
- #' )+ #' variables: `effect`, `term`, `term_label`, `level`, `n`, `hr`, `lcl`, `ucl`, `pval`, and `pval_inter`. |
||
| 506 | +57 |
- #' })+ #' |
||
| 507 | +58 |
- #' lg <- decorate_grob_set(grobs = g, titles = "Hello\nOne\nTwo\nThree", footnotes = "")+ #' @export |
||
| 508 | +59 |
- #'+ h_coxreg_inter_effect <- function(x, |
||
| 509 | +60 |
- #' draw_grob(lg[[1]])+ effect, |
||
| 510 | +61 |
- #' draw_grob(lg[[2]])+ covar, |
||
| 511 | +62 |
- #' draw_grob(lg[[6]])+ mod, |
||
| 512 | +63 |
- #'+ label, |
||
| 513 | +64 |
- #' @export+ control, |
||
| 514 | +65 |
- decorate_grob_set <- function(grobs, ...) {
- |
- ||
| 515 | -1x | -
- n <- length(grobs)+ ...) {
|
||
| 516 | -1x | +66 | +29x |
- lgf <- decorate_grob_factory(npages = n, ...)+ UseMethod("h_coxreg_inter_effect", x)
|
| 517 | -1x | +|||
| 67 | +
- lapply(grobs, lgf)+ } |
|||
| 518 | +68 |
- }+ |
| 1 | +69 |
- #' Horizontal waterfall plot+ #' @describeIn cox_regression_inter Method for `numeric` class. Estimates the interaction with a `numeric` covariate. |
||
| 2 | +70 |
#' |
||
| 3 | +71 |
- #' @description `r lifecycle::badge("stable")`
+ #' @method h_coxreg_inter_effect numeric |
||
| 4 | +72 |
#' |
||
| 5 | +73 |
- #' This basic waterfall plot visualizes a quantity `height` ordered by value with some markup.+ #' @param at (`list`)\cr a list with items named after the covariate, every |
||
| 6 | +74 |
- #'+ #' item is a vector of levels at which the interaction should be estimated. |
||
| 7 | +75 |
- #' @param height (`numeric`)\cr vector containing values to be plotted as the waterfall bars.+ #' |
||
| 8 | +76 |
- #' @param id (`character`)\cr vector containing identifiers to use as the x-axis label for the waterfall bars.+ #' @export |
||
| 9 | +77 |
- #' @param col (`character`)\cr color(s).+ h_coxreg_inter_effect.numeric <- function(x, |
||
| 10 | +78 |
- #' @param col_var (`factor`, `character`, or `NULL`)\cr categorical variable for bar coloring. `NULL` by default.+ effect, |
||
| 11 | +79 |
- #' @param xlab (`string`)\cr x label. Default is `"ID"`.+ covar, |
||
| 12 | +80 |
- #' @param ylab (`string`)\cr y label. Default is `"Value"`.+ mod, |
||
| 13 | +81 |
- #' @param title (`string`)\cr text to be displayed as plot title.+ label, |
||
| 14 | +82 |
- #' @param col_legend_title (`string`)\cr text to be displayed as legend title.+ control, |
||
| 15 | +83 |
- #'+ at, |
||
| 16 | +84 |
- #' @return A `ggplot` waterfall plot.+ ...) {
|
||
| 17 | -+ | |||
| 85 | +7x |
- #'+ betas <- stats::coef(mod) |
||
| 18 | -+ | |||
| 86 | +7x |
- #' @examples+ attrs <- attr(stats::terms(mod), "term.labels") |
||
| 19 | -+ | |||
| 87 | +7x |
- #' library(dplyr)+ term_indices <- grep( |
||
| 20 | -+ | |||
| 88 | +7x |
- #'+ pattern = effect, |
||
| 21 | -+ | |||
| 89 | +7x |
- #' g_waterfall(height = c(3, 5, -1), id = letters[1:3])+ x = attrs[!grepl("strata\\(", attrs)]
|
||
| 22 | +90 |
- #'+ ) |
||
| 23 | -+ | |||
| 91 | +7x |
- #' g_waterfall(+ checkmate::assert_vector(term_indices, len = 2) |
||
| 24 | -+ | |||
| 92 | +7x |
- #' height = c(3, 5, -1),+ betas <- betas[term_indices] |
||
| 25 | -+ | |||
| 93 | +7x |
- #' id = letters[1:3],+ betas_var <- diag(stats::vcov(mod))[term_indices] |
||
| 26 | -+ | |||
| 94 | +7x |
- #' col_var = letters[1:3]+ betas_cov <- stats::vcov(mod)[term_indices[1], term_indices[2]] |
||
| 27 | -+ | |||
| 95 | +7x |
- #' )+ xval <- if (is.null(at[[covar]])) {
|
||
| 28 | -+ | |||
| 96 | +6x |
- #'+ stats::median(x) |
||
| 29 | +97 |
- #' adsl_f <- tern_ex_adsl %>%+ } else {
|
||
| 30 | -+ | |||
| 98 | +1x |
- #' select(USUBJID, STUDYID, ARM, ARMCD, SEX)+ at[[covar]] |
||
| 31 | +99 |
- #'+ } |
||
| 32 | -+ | |||
| 100 | +7x |
- #' adrs_f <- tern_ex_adrs %>%+ effect_index <- !grepl(covar, names(betas)) |
||
| 33 | -+ | |||
| 101 | +7x |
- #' filter(PARAMCD == "OVRINV") %>%+ coef_hat <- betas[effect_index] + xval * betas[!effect_index] |
||
| 34 | -+ | |||
| 102 | +7x |
- #' mutate(pchg = rnorm(n(), 10, 50))+ coef_se <- sqrt( |
||
| 35 | -+ | |||
| 103 | +7x |
- #'+ betas_var[effect_index] + |
||
| 36 | -+ | |||
| 104 | +7x |
- #' adrs_f <- head(adrs_f, 30)+ xval ^ 2 * betas_var[!effect_index] + # styler: off |
||
| 37 | -+ | |||
| 105 | +7x |
- #' adrs_f <- adrs_f[!duplicated(adrs_f$USUBJID), ]+ 2 * xval * betas_cov |
||
| 38 | +106 |
- #' head(adrs_f)+ ) |
||
| 39 | -+ | |||
| 107 | +7x |
- #'+ q_norm <- stats::qnorm((1 + control$conf_level) / 2) |
||
| 40 | -+ | |||
| 108 | +7x |
- #' g_waterfall(+ data.frame( |
||
| 41 | -+ | |||
| 109 | +7x |
- #' height = adrs_f$pchg,+ effect = "Covariate:", |
||
| 42 | -+ | |||
| 110 | +7x |
- #' id = adrs_f$USUBJID,+ term = rep(covar, length(xval)), |
||
| 43 | -+ | |||
| 111 | +7x |
- #' col_var = adrs_f$AVALC+ term_label = paste0(" ", xval),
|
||
| 44 | -+ | |||
| 112 | +7x |
- #' )+ level = as.character(xval), |
||
| 45 | -+ | |||
| 113 | +7x |
- #'+ n = NA, |
||
| 46 | -+ | |||
| 114 | +7x |
- #' g_waterfall(+ hr = exp(coef_hat), |
||
| 47 | -+ | |||
| 115 | +7x |
- #' height = adrs_f$pchg,+ lcl = exp(coef_hat - q_norm * coef_se), |
||
| 48 | -+ | |||
| 116 | +7x |
- #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
+ ucl = exp(coef_hat + q_norm * coef_se), |
||
| 49 | -+ | |||
| 117 | +7x |
- #' col_var = adrs_f$SEX+ pval = NA, |
||
| 50 | -+ | |||
| 118 | +7x |
- #' )+ pval_inter = NA,+ |
+ ||
| 119 | +7x | +
+ stringsAsFactors = FALSE |
||
| 51 | +120 |
- #'+ ) |
||
| 52 | +121 |
- #' g_waterfall(+ } |
||
| 53 | +122 |
- #' height = adrs_f$pchg,+ |
||
| 54 | +123 |
- #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
+ #' @describeIn cox_regression_inter Method for `factor` class. Estimate the interaction with a `factor` covariate. |
||
| 55 | +124 |
- #' xlab = "ID",+ #' |
||
| 56 | +125 |
- #' ylab = "Percentage Change",+ #' @method h_coxreg_inter_effect factor |
||
| 57 | +126 |
- #' title = "Waterfall plot"+ #' |
||
| 58 | +127 |
- #' )+ #' @param data (`data.frame`)\cr the data frame on which the model was fit. |
||
| 59 | +128 |
#' |
||
| 60 | +129 |
#' @export |
||
| 61 | +130 |
- g_waterfall <- function(height,+ h_coxreg_inter_effect.factor <- function(x, |
||
| 62 | +131 |
- id,+ effect, |
||
| 63 | +132 |
- col_var = NULL,+ covar, |
||
| 64 | +133 |
- col = getOption("ggplot2.discrete.colour"),
+ mod, |
||
| 65 | +134 |
- xlab = NULL,+ label, |
||
| 66 | +135 |
- ylab = NULL,+ control, |
||
| 67 | +136 |
- col_legend_title = NULL,+ data, |
||
| 68 | +137 |
- title = NULL) {
+ ...) {
|
||
| 69 | -2x | +138 | +17x |
- if (!is.null(col_var)) {
+ lvl_given <- levels(x) |
| 70 | -1x | -
- check_same_n(height = height, id = id, col_var = col_var)- |
- ||
| 71 | -+ | 139 | +17x |
- } else {
+ y <- h_coxreg_inter_estimations( |
| 72 | -1x | -
- check_same_n(height = height, id = id)- |
- ||
| 73 | -- |
- }- |
- ||
| 74 | -+ | 140 | +17x |
-
+ variable = effect, given = covar, |
| 75 | -2x | +141 | +17x |
- checkmate::assert_multi_class(col_var, c("character", "factor"), null.ok = TRUE)
+ lvl_var = levels(data[[effect]]), |
| 76 | -2x | +142 | +17x |
- checkmate::assert_character(col, null.ok = TRUE)+ lvl_given = lvl_given, |
| 77 | -+ | |||
| 143 | +17x |
-
+ mod = mod, |
||
| 78 | -2x | +144 | +17x |
- xlabel <- deparse(substitute(id))+ conf_level = 0.95 |
| 79 | -2x | +145 | +17x |
- ylabel <- deparse(substitute(height))+ )[[1]] |
| 80 | +146 | |||
| 81 | -2x | +147 | +17x |
- col_label <- if (!missing(col_var)) {
+ data.frame( |
| 82 | -1x | -
- deparse(substitute(col_var))- |
- ||
| 83 | -+ | 148 | +17x |
- }+ effect = "Covariate:", |
| 84 | -+ | |||
| 149 | +17x |
-
+ term = rep(covar, nrow(y)), |
||
| 85 | -2x | +150 | +17x |
- xlab <- if (is.null(xlab)) xlabel else xlab+ term_label = paste0(" ", lvl_given),
|
| 86 | -2x | +151 | +17x |
- ylab <- if (is.null(ylab)) ylabel else ylab+ level = lvl_given, |
| 87 | -2x | +152 | +17x |
- col_legend_title <- if (is.null(col_legend_title)) col_label else col_legend_title+ n = NA, |
| 88 | -+ | |||
| 153 | +17x |
-
+ hr = y[, "hr"], |
||
| 89 | -2x | +154 | +17x |
- plot_data <- data.frame(+ lcl = y[, "lcl"], |
| 90 | -2x | +155 | +17x |
- height = height,+ ucl = y[, "ucl"], |
| 91 | -2x | +156 | +17x |
- id = as.character(id),+ pval = NA, |
| 92 | -2x | +157 | +17x |
- col_var = if (is.null(col_var)) "x" else to_n(col_var, length(height)),+ pval_inter = NA, |
| 93 | -2x | +158 | +17x |
stringsAsFactors = FALSE |
| 94 | +159 |
) |
||
| 95 | +160 | - - | -||
| 96 | -2x | -
- plot_data_ord <- plot_data[order(plot_data$height, decreasing = TRUE), ]+ } |
||
| 97 | +161 | |||
| 98 | -2x | -
- p <- ggplot2::ggplot(plot_data_ord, ggplot2::aes(x = factor(id, levels = id), y = height)) +- |
- ||
| 99 | -2x | +|||
| 162 | +
- ggplot2::geom_col() ++ #' @describeIn cox_regression_inter Method for `character` class. Estimate the interaction with a `character` covariate. |
|||
| 100 | -2x | +|||
| 163 | +
- ggplot2::geom_text(+ #' This makes an automatic conversion to `factor` and then forwards to the method for factors. |
|||
| 101 | -2x | +|||
| 164 | +
- label = format(plot_data_ord$height, digits = 2),+ #' |
|||
| 102 | -2x | +|||
| 165 | +
- vjust = ifelse(plot_data_ord$height >= 0, -0.5, 1.5)+ #' @method h_coxreg_inter_effect character |
|||
| 103 | +166 |
- ) ++ #' |
||
| 104 | -2x | +|||
| 167 | +
- ggplot2::xlab(xlab) ++ #' @note |
|||
| 105 | -2x | +|||
| 168 | +
- ggplot2::ylab(ylab) ++ #' * Automatic conversion of character to factor does not guarantee results can be generated correctly. It is |
|||
| 106 | -2x | +|||
| 169 | +
- ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 0, vjust = .5))+ #' therefore better to always pre-process the dataset such that factors are manually created from character |
|||
| 107 | +170 |
-
+ #' variables before passing the dataset to [rtables::build_table()]. |
||
| 108 | -2x | +|||
| 171 | +
- if (!is.null(col_var)) {
+ #' |
|||
| 109 | -1x | +|||
| 172 | +
- p <- p ++ #' @export |
|||
| 110 | -1x | +|||
| 173 | +
- ggplot2::aes(fill = col_var) ++ h_coxreg_inter_effect.character <- function(x, |
|||
| 111 | -1x | +|||
| 174 | +
- ggplot2::labs(fill = col_legend_title) ++ effect, |
|||
| 112 | -1x | +|||
| 175 | +
- ggplot2::theme(+ covar, |
|||
| 113 | -1x | +|||
| 176 | +
- legend.position = "bottom",+ mod, |
|||
| 114 | -1x | +|||
| 177 | +
- legend.background = ggplot2::element_blank(),+ label, |
|||
| 115 | -1x | +|||
| 178 | +
- legend.title = ggplot2::element_text(face = "bold"),+ control, |
|||
| 116 | -1x | +|||
| 179 | +
- legend.box.background = ggplot2::element_rect(colour = "black")+ data, |
|||
| 117 | +180 |
- )+ ...) {
|
||
| 118 | -+ | |||
| 181 | +5x |
- }+ y <- as.factor(x) |
||
| 119 | +182 | |||
| 120 | -2x | +183 | +5x |
- if (!is.null(col)) {
+ h_coxreg_inter_effect( |
| 121 | -1x | +184 | +5x |
- p <- p ++ x = y, |
| 122 | -1x | -
- ggplot2::scale_fill_manual(values = col)- |
- ||
| 123 | -+ | 185 | +5x |
- }+ effect = effect, |
| 124 | -+ | |||
| 186 | +5x |
-
+ covar = covar, |
||
| 125 | -2x | +187 | +5x |
- if (!is.null(title)) {
+ mod = mod, |
| 126 | -1x | +188 | +5x |
- p <- p ++ label = label, |
| 127 | -1x | +189 | +5x |
- ggplot2::labs(title = title) ++ control = control, |
| 128 | -1x | +190 | +5x |
- ggplot2::theme(plot.title = ggplot2::element_text(face = "bold"))+ data = data, |
| 129 | +191 |
- }+ ... |
||
| 130 | +192 | - - | -||
| 131 | -2x | -
- p+ ) |
||
| 132 | +193 |
} |
| 1 | +194 |
- #' Cox regression helper function for interactions+ |
||
| 2 | +195 |
- #'+ #' @describeIn cox_regression_inter A higher level function to get |
||
| 3 | +196 |
- #' @description `r lifecycle::badge("stable")`
+ #' the results of the interaction test and the estimated values. |
||
| 4 | +197 |
#' |
||
| 5 | +198 |
- #' Test and estimate the effect of a treatment in interaction with a covariate.+ #' @return |
||
| 6 | +199 |
- #' The effect is estimated as the HR of the tested treatment for a given level+ #' * `h_coxreg_extract_interaction()` returns the result of an interaction test and the estimated values. If |
||
| 7 | +200 |
- #' of the covariate, in comparison to the treatment control.+ #' no interaction, [h_coxreg_univar_extract()] is applied instead. |
||
| 8 | +201 |
#' |
||
| 9 | +202 |
- #' @inheritParams argument_convention+ #' @examples |
||
| 10 | +203 |
- #' @param x (`numeric` or `factor`)\cr the values of the covariate to be tested.+ #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder) |
||
| 11 | +204 |
- #' @param effect (`string`)\cr the name of the effect to be tested and estimated.+ #' h_coxreg_extract_interaction( |
||
| 12 | +205 |
- #' @param covar (`string`)\cr the name of the covariate in the model.+ #' mod = mod, effect = "armcd", covar = "covar1", data = dta_bladder, |
||
| 13 | +206 |
- #' @param mod (`coxph`)\cr the Cox regression model.+ #' control = control_coxreg() |
||
| 14 | +207 |
- #' @param label (`string`)\cr the label to be returned as `term_label`.+ #' ) |
||
| 15 | +208 |
- #' @param control (`list`)\cr a list of controls as returned by [control_coxreg()].+ #' |
||
| 16 | +209 |
- #' @param ... see methods.+ #' @export |
||
| 17 | +210 |
- #'+ h_coxreg_extract_interaction <- function(effect, |
||
| 18 | +211 |
- #' @examples+ covar, |
||
| 19 | +212 |
- #' library(survival)+ mod, |
||
| 20 | +213 |
- #'+ data, |
||
| 21 | +214 |
- #' set.seed(1, kind = "Mersenne-Twister")+ at, |
||
| 22 | +215 |
- #'+ control) {
|
||
| 23 | -+ | |||
| 216 | +31x |
- #' # Testing dataset [survival::bladder].+ if (!any(attr(stats::terms(mod), "order") == 2)) {
|
||
| 24 | -+ | |||
| 217 | +12x |
- #' dta_bladder <- with(+ y <- h_coxreg_univar_extract( |
||
| 25 | -+ | |||
| 218 | +12x |
- #' data = bladder[bladder$enum < 5, ],+ effect = effect, covar = covar, mod = mod, data = data, control = control |
||
| 26 | +219 |
- #' data.frame(+ ) |
||
| 27 | -+ | |||
| 220 | +12x |
- #' time = stop,+ y$pval_inter <- NA |
||
| 28 | -+ | |||
| 221 | +12x |
- #' status = event,+ y |
||
| 29 | +222 |
- #' armcd = as.factor(rx),+ } else {
|
||
| 30 | -+ | |||
| 223 | +19x |
- #' covar1 = as.factor(enum),+ test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method] |
||
| 31 | +224 |
- #' covar2 = factor(+ |
||
| 32 | +225 |
- #' sample(as.factor(enum)),+ # Test the main treatment effect. |
||
| 33 | -+ | |||
| 226 | +19x |
- #' levels = 1:4,+ mod_aov <- muffled_car_anova(mod, test_statistic) |
||
| 34 | -+ | |||
| 227 | +19x |
- #' labels = c("F", "F", "M", "M")
+ sum_anova <- broom::tidy(mod_aov) |
||
| 35 | -+ | |||
| 228 | +19x |
- #' )+ pval <- sum_anova[sum_anova$term == effect, ][["p.value"]] |
||
| 36 | +229 |
- #' )+ |
||
| 37 | +230 |
- #' )+ # Test the interaction effect. |
||
| 38 | -+ | |||
| 231 | +19x |
- #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
+ pval_inter <- sum_anova[grep(":", sum_anova$term), ][["p.value"]]
|
||
| 39 | -+ | |||
| 232 | +19x |
- #' formatters::var_labels(dta_bladder)[names(labels)] <- labels+ covar_test <- data.frame( |
||
| 40 | -+ | |||
| 233 | +19x |
- #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ effect = "Covariate:", |
||
| 41 | -+ | |||
| 234 | +19x |
- #'+ term = covar, |
||
| 42 | -+ | |||
| 235 | +19x |
- #' plot(+ term_label = unname(labels_or_names(data[covar])), |
||
| 43 | -+ | |||
| 236 | +19x |
- #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder),+ level = "", |
||
| 44 | -+ | |||
| 237 | +19x |
- #' lty = 2:4,+ n = mod$n, hr = NA, lcl = NA, ucl = NA, pval = pval, |
||
| 45 | -+ | |||
| 238 | +19x |
- #' xlab = "Months",+ pval_inter = pval_inter, |
||
| 46 | -+ | |||
| 239 | +19x |
- #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
+ stringsAsFactors = FALSE |
||
| 47 | +240 |
- #' )+ ) |
||
| 48 | +241 |
- #'+ # Estimate the interaction. |
||
| 49 | -+ | |||
| 242 | +19x |
- #' @name cox_regression_inter+ y <- h_coxreg_inter_effect( |
||
| 50 | -+ | |||
| 243 | +19x |
- NULL+ data[[covar]], |
||
| 51 | -+ | |||
| 244 | +19x |
-
+ covar = covar, |
||
| 52 | -+ | |||
| 245 | +19x |
- #' @describeIn cox_regression_inter S3 generic helper function to determine interaction effect.+ effect = effect, |
||
| 53 | -+ | |||
| 246 | +19x |
- #'+ mod = mod, |
||
| 54 | -+ | |||
| 247 | +19x |
- #' @return+ label = unname(labels_or_names(data[covar])), |
||
| 55 | -+ | |||
| 248 | +19x |
- #' * `h_coxreg_inter_effect()` returns a `data.frame` of covariate interaction effects consisting of the following+ at = at, |
||
| 56 | -+ | |||
| 249 | +19x |
- #' variables: `effect`, `term`, `term_label`, `level`, `n`, `hr`, `lcl`, `ucl`, `pval`, and `pval_inter`.+ control = control, |
||
| 57 | -+ | |||
| 250 | +19x |
- #'+ data = data |
||
| 58 | +251 |
- #' @export+ )+ |
+ ||
| 252 | +19x | +
+ rbind(covar_test, y) |
||
| 59 | +253 |
- h_coxreg_inter_effect <- function(x,+ } |
||
| 60 | +254 |
- effect,+ } |
||
| 61 | +255 |
- covar,+ |
||
| 62 | +256 |
- mod,+ #' @describeIn cox_regression_inter Hazard ratio estimation in interactions. |
||
| 63 | +257 |
- label,+ #' |
||
| 64 | +258 |
- control,+ #' @param variable,given (`string`)\cr the name of variables in interaction. We seek the estimation |
||
| 65 | +259 |
- ...) {
+ #' of the levels of `variable` given the levels of `given`. |
||
| 66 | -29x | +|||
| 260 | +
- UseMethod("h_coxreg_inter_effect", x)
+ #' @param lvl_var,lvl_given (`character`)\cr corresponding levels as given by [levels()]. |
|||
| 67 | +261 |
- }+ #' @param mod (`coxph`)\cr a fitted Cox regression model (see [survival::coxph()]). |
||
| 68 | +262 |
-
+ #' |
||
| 69 | +263 |
- #' @describeIn cox_regression_inter Method for `numeric` class. Estimates the interaction with a `numeric` covariate.+ #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A) |
||
| 70 | +264 |
- #'+ #' and Sex (F, M; reference Female) and the model being abbreviated: y ~ Arm + Sex + Arm:Sex. |
||
| 71 | +265 |
- #' @method h_coxreg_inter_effect numeric+ #' The cox regression estimates the coefficients along with a variance-covariance matrix for: |
||
| 72 | +266 |
#' |
||
| 73 | +267 |
- #' @param at (`list`)\cr a list with items named after the covariate, every+ #' - b1 (arm b), b2 (arm c) |
||
| 74 | +268 |
- #' item is a vector of levels at which the interaction should be estimated.+ #' - b3 (sex m) |
||
| 75 | +269 |
- #'+ #' - b4 (arm b: sex m), b5 (arm c: sex m) |
||
| 76 | +270 |
- #' @export+ #' |
||
| 77 | +271 |
- h_coxreg_inter_effect.numeric <- function(x,+ #' The estimation of the Hazard Ratio for arm C/sex M is given in reference |
||
| 78 | +272 |
- effect,+ #' to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5). |
||
| 79 | +273 |
- covar,+ #' The interaction coefficient is deduced by b2 + b5 while the standard error |
||
| 80 | +274 |
- mod,+ #' is obtained as $sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$. |
||
| 81 | +275 |
- label,+ #' |
||
| 82 | +276 |
- control,+ #' @return |
||
| 83 | +277 |
- at,+ #' * `h_coxreg_inter_estimations()` returns a list of matrices (one per level of variable) with rows corresponding |
||
| 84 | +278 |
- ...) {
+ #' to the combinations of `variable` and `given`, with columns: |
||
| 85 | -7x | +|||
| 279 | +
- betas <- stats::coef(mod)+ #' * `coef_hat`: Estimation of the coefficient. |
|||
| 86 | -7x | +|||
| 280 | +
- attrs <- attr(stats::terms(mod), "term.labels")+ #' * `coef_se`: Standard error of the estimation. |
|||
| 87 | -7x | +|||
| 281 | +
- term_indices <- grep(+ #' * `hr`: Hazard ratio. |
|||
| 88 | -7x | +|||
| 282 | +
- pattern = effect,+ #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio. |
|||
| 89 | -7x | +|||
| 283 | +
- x = attrs[!grepl("strata\\(", attrs)]
+ #' |
|||
| 90 | +284 |
- )+ #' @examples |
||
| 91 | -7x | +|||
| 285 | +
- checkmate::assert_vector(term_indices, len = 2)+ #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder) |
|||
| 92 | -7x | +|||
| 286 | +
- betas <- betas[term_indices]+ #' result <- h_coxreg_inter_estimations( |
|||
| 93 | -7x | +|||
| 287 | +
- betas_var <- diag(stats::vcov(mod))[term_indices]+ #' variable = "armcd", given = "covar1", |
|||
| 94 | -7x | +|||
| 288 | +
- betas_cov <- stats::vcov(mod)[term_indices[1], term_indices[2]]+ #' lvl_var = levels(dta_bladder$armcd), |
|||
| 95 | -7x | +|||
| 289 | +
- xval <- if (is.null(at[[covar]])) {
+ #' lvl_given = levels(dta_bladder$covar1), |
|||
| 96 | -6x | +|||
| 290 | +
- stats::median(x)+ #' mod = mod, conf_level = .95 |
|||
| 97 | +291 |
- } else {
+ #' ) |
||
| 98 | -1x | +|||
| 292 | +
- at[[covar]]+ #' result |
|||
| 99 | +293 |
- }+ #' |
||
| 100 | -7x | +|||
| 294 | +
- effect_index <- !grepl(covar, names(betas))+ #' @export |
|||
| 101 | -7x | +|||
| 295 | +
- coef_hat <- betas[effect_index] + xval * betas[!effect_index]+ h_coxreg_inter_estimations <- function(variable, |
|||
| 102 | -7x | +|||
| 296 | +
- coef_se <- sqrt(+ given, |
|||
| 103 | -7x | +|||
| 297 | +
- betas_var[effect_index] ++ lvl_var, |
|||
| 104 | -7x | +|||
| 298 | +
- xval ^ 2 * betas_var[!effect_index] + # styler: off+ lvl_given, |
|||
| 105 | -7x | +|||
| 299 | +
- 2 * xval * betas_cov+ mod, |
|||
| 106 | +300 |
- )+ conf_level = 0.95) {
|
||
| 107 | -7x | +301 | +18x |
- q_norm <- stats::qnorm((1 + control$conf_level) / 2)+ var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level |
| 108 | -7x | +302 | +18x |
- data.frame(+ giv_lvl <- paste0(given, lvl_given) |
| 109 | -7x | +303 | +18x |
- effect = "Covariate:",+ design_mat <- expand.grid(variable = var_lvl, given = giv_lvl) |
| 110 | -7x | +304 | +18x |
- term = rep(covar, length(xval)),+ design_mat <- design_mat[order(design_mat$variable, design_mat$given), ] |
| 111 | -7x | +305 | +18x |
- term_label = paste0(" ", xval),
+ design_mat <- within( |
| 112 | -7x | +306 | +18x |
- level = as.character(xval),+ data = design_mat, |
| 113 | -7x | +307 | +18x |
- n = NA,+ expr = {
|
| 114 | -7x | +308 | +18x |
- hr = exp(coef_hat),+ inter <- paste0(variable, ":", given) |
| 115 | -7x | +309 | +18x |
- lcl = exp(coef_hat - q_norm * coef_se),+ rev_inter <- paste0(given, ":", variable) |
| 116 | -7x | +|||
| 310 | +
- ucl = exp(coef_hat + q_norm * coef_se),+ } |
|||
| 117 | -7x | +|||
| 311 | +
- pval = NA,+ ) |
|||
| 118 | -7x | +312 | +18x |
- pval_inter = NA,+ split_by_variable <- design_mat$variable |
| 119 | -7x | +313 | +18x |
- stringsAsFactors = FALSE+ interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/") |
| 120 | +314 |
- )+ |
||
| 121 | -+ | |||
| 315 | +18x |
- }+ mmat <- stats::model.matrix(mod)[1, ]+ |
+ ||
| 316 | +18x | +
+ mmat[!mmat == 0] <- 0 |
||
| 122 | +317 | |||
| 123 | -+ | |||
| 318 | +18x |
- #' @describeIn cox_regression_inter Method for `factor` class. Estimate the interaction with a `factor` covariate.+ design_mat <- apply( |
||
| 124 | -+ | |||
| 319 | +18x |
- #'+ X = design_mat, MARGIN = 1, FUN = function(x) {
|
||
| 125 | -+ | |||
| 320 | +52x |
- #' @method h_coxreg_inter_effect factor+ mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1 |
||
| 126 | -+ | |||
| 321 | +52x |
- #'+ mmat |
||
| 127 | +322 |
- #' @param data (`data.frame`)\cr the data frame on which the model was fit.+ } |
||
| 128 | +323 |
- #'+ ) |
||
| 129 | -+ | |||
| 324 | +18x |
- #' @export+ colnames(design_mat) <- interaction_names |
||
| 130 | +325 |
- h_coxreg_inter_effect.factor <- function(x,+ |
||
| 131 | -+ | |||
| 326 | +18x |
- effect,+ coef <- stats::coef(mod) |
||
| 132 | -+ | |||
| 327 | +18x |
- covar,+ vcov <- stats::vcov(mod) |
||
| 133 | -+ | |||
| 328 | +18x |
- mod,+ betas <- as.matrix(coef) |
||
| 134 | -+ | |||
| 329 | +18x |
- label,+ coef_hat <- t(design_mat) %*% betas |
||
| 135 | -+ | |||
| 330 | +18x |
- control,+ dimnames(coef_hat)[2] <- "coef" |
||
| 136 | -+ | |||
| 331 | +18x |
- data,+ coef_se <- apply( |
||
| 137 | -+ | |||
| 332 | +18x | +
+ design_mat, 2,+ |
+ ||
| 333 | +18x |
- ...) {
+ function(x) {
|
||
| 138 | -17x | +334 | +52x |
- lvl_given <- levels(x)+ vcov_el <- as.logical(x) |
| 139 | -17x | +335 | +52x |
- y <- h_coxreg_inter_estimations(+ y <- vcov[vcov_el, vcov_el] |
| 140 | -17x | +336 | +52x |
- variable = effect, given = covar,+ y <- sum(y) |
| 141 | -17x | +337 | +52x |
- lvl_var = levels(data[[effect]]),+ y <- sqrt(y) |
| 142 | -17x | +338 | +52x |
- lvl_given = lvl_given,+ return(y) |
| 143 | -17x | +|||
| 339 | +
- mod = mod,+ } |
|||
| 144 | -17x | +|||
| 340 | +
- conf_level = 0.95+ ) |
|||
| 145 | -17x | +341 | +18x |
- )[[1]]+ q_norm <- stats::qnorm((1 + conf_level) / 2) |
| 146 | -+ | |||
| 342 | +18x |
-
+ y <- cbind(coef_hat, `se(coef)` = coef_se) |
||
| 147 | -17x | +343 | +18x |
- data.frame(+ y <- apply(y, 1, function(x) {
|
| 148 | -17x | +344 | +52x |
- effect = "Covariate:",+ x["hr"] <- exp(x["coef"]) |
| 149 | -17x | +345 | +52x |
- term = rep(covar, nrow(y)),+ x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"]) |
| 150 | -17x | +346 | +52x |
- term_label = paste0(" ", lvl_given),
+ x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"]) |
| 151 | -17x | +347 | +52x |
- level = lvl_given,+ x+ |
+
| 348 | ++ |
+ }) |
||
| 152 | -17x | +349 | +18x |
- n = NA,+ y <- t(y) |
| 153 | -17x | +350 | +18x |
- hr = y[, "hr"],+ y <- by(y, split_by_variable, identity) |
| 154 | -17x | +351 | +18x |
- lcl = y[, "lcl"],+ y <- lapply(y, as.matrix) |
| 155 | -17x | +352 | +18x |
- ucl = y[, "ucl"],+ attr(y, "details") <- paste0( |
| 156 | -17x | +353 | +18x |
- pval = NA,+ "Estimations of ", variable, |
| 157 | -17x | +354 | +18x |
- pval_inter = NA,+ " hazard ratio given the level of ", given, " compared to ", |
| 158 | -17x | +355 | +18x |
- stringsAsFactors = FALSE+ variable, " level ", lvl_var[1], "." |
| 159 | +356 |
) |
||
| 357 | +18x | +
+ y+ |
+ ||
| 160 | +358 |
} |
| 161 | +1 |
-
+ #' Survival time point analysis |
||
| 162 | +2 |
- #' @describeIn cox_regression_inter Method for `character` class. Estimate the interaction with a `character` covariate.+ #' |
||
| 163 | +3 |
- #' This makes an automatic conversion to `factor` and then forwards to the method for factors.+ #' @description `r lifecycle::badge("stable")`
|
||
| 164 | +4 |
#' |
||
| 165 | +5 |
- #' @method h_coxreg_inter_effect character+ #' The analyze function [surv_timepoint()] creates a layout element to analyze patient survival rates and difference |
||
| 166 | +6 |
- #'+ #' of survival rates between groups at a given time point. The primary analysis variable `vars` is the time variable. |
||
| 167 | +7 |
- #' @note+ #' Other required inputs are `time_point`, the numeric time point of interest, and `is_event`, a variable that |
||
| 168 | +8 |
- #' * Automatic conversion of character to factor does not guarantee results can be generated correctly. It is+ #' indicates whether or not an event has occurred. The `method` argument is used to specify whether you want to analyze |
||
| 169 | +9 |
- #' therefore better to always pre-process the dataset such that factors are manually created from character+ #' survival estimations (`"surv"`), difference in survival with the control (`"surv_diff"`), or both of these |
||
| 170 | +10 |
- #' variables before passing the dataset to [rtables::build_table()].+ #' (`"both"`). |
||
| 171 | +11 |
#' |
||
| 172 | +12 |
- #' @export+ #' @inheritParams argument_convention |
||
| 173 | +13 |
- h_coxreg_inter_effect.character <- function(x,+ #' @inheritParams s_surv_time |
||
| 174 | +14 |
- effect,+ #' @param time_point (`numeric(1)`)\cr survival time point of interest. |
||
| 175 | +15 |
- covar,+ #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function |
||
| 176 | +16 |
- mod,+ #' [control_surv_timepoint()]. Some possible parameter options are: |
||
| 177 | +17 |
- label,+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate. |
||
| 178 | +18 |
- control,+ #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log", |
||
| 179 | +19 |
- data,+ #' see more in [survival::survfit()]. Note option "none" is no longer supported. |
||
| 180 | +20 |
- ...) {
- |
- ||
| 181 | -5x | -
- y <- as.factor(x)+ #' @param method (`string`)\cr `"surv"` (survival estimations), `"surv_diff"` (difference in survival with the |
||
| 182 | +21 | - - | -||
| 183 | -5x | -
- h_coxreg_inter_effect(- |
- ||
| 184 | -5x | -
- x = y,- |
- ||
| 185 | -5x | -
- effect = effect,- |
- ||
| 186 | -5x | -
- covar = covar,+ #' control), or `"both"`. |
||
| 187 | -5x | +|||
| 22 | +
- mod = mod,+ #' @param table_names_suffix (`string`)\cr optional suffix for the `table_names` used for the `rtables` to |
|||
| 188 | -5x | +|||
| 23 | +
- label = label,+ #' avoid warnings from duplicate table names. |
|||
| 189 | -5x | +|||
| 24 | +
- control = control,+ #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector |
|||
| 190 | -5x | +|||
| 25 | +
- data = data,+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation |
|||
| 191 | +26 |
- ...+ #' for that statistic's row label. |
||
| 192 | +27 |
- )+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 193 | +28 |
- }+ #' |
||
| 194 | +29 |
-
+ #' Options are: ``r shQuote(get_stats("surv_timepoint"), type = "sh")``
|
||
| 195 | +30 |
- #' @describeIn cox_regression_inter A higher level function to get+ #' |
||
| 196 | +31 |
- #' the results of the interaction test and the estimated values.+ #' @name survival_timepoint |
||
| 197 | +32 |
- #'+ #' @order 1 |
||
| 198 | +33 |
- #' @return+ NULL |
||
| 199 | +34 |
- #' * `h_coxreg_extract_interaction()` returns the result of an interaction test and the estimated values. If+ |
||
| 200 | +35 |
- #' no interaction, [h_coxreg_univar_extract()] is applied instead.+ #' @describeIn survival_timepoint Statistics function which analyzes survival rate. |
||
| 201 | +36 |
#' |
||
| 202 | +37 |
- #' @examples+ #' @return |
||
| 203 | +38 |
- #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder)+ #' * `s_surv_timepoint()` returns the statistics: |
||
| 204 | +39 |
- #' h_coxreg_extract_interaction(+ #' * `pt_at_risk`: Patients remaining at risk. |
||
| 205 | +40 |
- #' mod = mod, effect = "armcd", covar = "covar1", data = dta_bladder,+ #' * `event_free_rate`: Event-free rate (%). |
||
| 206 | +41 |
- #' control = control_coxreg()+ #' * `rate_se`: Standard error of event free rate. |
||
| 207 | +42 |
- #' )+ #' * `rate_ci`: Confidence interval for event free rate. |
||
| 208 | +43 |
- #'+ #' * `event_free_rate_3d`: Event-free rate (%) with Confidence interval. |
||
| 209 | +44 |
- #' @export+ #' |
||
| 210 | +45 |
- h_coxreg_extract_interaction <- function(effect,+ #' @keywords internal |
||
| 211 | +46 |
- covar,+ s_surv_timepoint <- function(df, |
||
| 212 | +47 |
- mod,+ .var, |
||
| 213 | +48 |
- data,+ time_point, |
||
| 214 | +49 |
- at,+ is_event, |
||
| 215 | +50 |
- control) {
+ control = control_surv_timepoint()) {
|
||
| 216 | -31x | +51 | +23x |
- if (!any(attr(stats::terms(mod), "order") == 2)) {
+ checkmate::assert_string(.var) |
| 217 | -12x | +52 | +23x |
- y <- h_coxreg_univar_extract(+ assert_df_with_variables(df, list(tte = .var, is_event = is_event)) |
| 218 | -12x | -
- effect = effect, covar = covar, mod = mod, data = data, control = control- |
- ||
| 219 | -+ | 53 | +23x |
- )+ checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE) |
| 220 | -12x | +54 | +23x |
- y$pval_inter <- NA+ checkmate::assert_number(time_point) |
| 221 | -12x | +55 | +23x |
- y+ checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE) |
| 222 | +56 |
- } else {
+
|
||
| 223 | -19x | +57 | +23x |
- test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]+ conf_type <- control$conf_type |
| 224 | -+ | |||
| 58 | +23x |
-
+ conf_level <- control$conf_level |
||
| 225 | +59 |
- # Test the main treatment effect.+ |
||
| 226 | -19x | +60 | +23x |
- mod_aov <- muffled_car_anova(mod, test_statistic)+ formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
|
| 227 | -19x | +61 | +23x |
- sum_anova <- broom::tidy(mod_aov)+ srv_fit <- survival::survfit( |
| 228 | -19x | -
- pval <- sum_anova[sum_anova$term == effect, ][["p.value"]]- |
- ||
| 229 | -- | - - | -||
| 230 | -+ | 62 | +23x |
- # Test the interaction effect.+ formula = formula, |
| 231 | -19x | +63 | +23x |
- pval_inter <- sum_anova[grep(":", sum_anova$term), ][["p.value"]]
+ data = df, |
| 232 | -19x | +64 | +23x |
- covar_test <- data.frame(+ conf.int = conf_level, |
| 233 | -19x | +65 | +23x |
- effect = "Covariate:",+ conf.type = conf_type |
| 234 | -19x | +|||
| 66 | +
- term = covar,+ ) |
|||
| 235 | -19x | +67 | +23x |
- term_label = unname(labels_or_names(data[covar])),+ s_srv_fit <- summary(srv_fit, times = time_point, extend = TRUE) |
| 236 | -19x | +68 | +23x |
- level = "",+ df_srv_fit <- as.data.frame(s_srv_fit[c("time", "n.risk", "surv", "lower", "upper", "std.err")])
|
| 237 | -19x | +69 | +23x |
- n = mod$n, hr = NA, lcl = NA, ucl = NA, pval = pval,+ if (df_srv_fit[["n.risk"]] == 0) {
|
| 238 | -19x | +70 | +1x |
- pval_inter = pval_inter,+ pt_at_risk <- event_free_rate <- rate_se <- NA_real_ |
| 239 | -19x | -
- stringsAsFactors = FALSE- |
- ||
| 240 | -+ | 71 | +1x |
- )+ rate_ci <- c(NA_real_, NA_real_) |
| 241 | +72 |
- # Estimate the interaction.+ } else {
|
||
| 242 | -19x | +73 | +22x |
- y <- h_coxreg_inter_effect(+ pt_at_risk <- df_srv_fit$n.risk |
| 243 | -19x | +74 | +22x |
- data[[covar]],+ event_free_rate <- df_srv_fit$surv |
| 244 | -19x | +75 | +22x |
- covar = covar,+ rate_se <- df_srv_fit$std.err |
| 245 | -19x | +76 | +22x |
- effect = effect,+ rate_ci <- c(df_srv_fit$lower, df_srv_fit$upper) |
| 246 | -19x | +|||
| 77 | +
- mod = mod,+ } |
|||
| 247 | -19x | +78 | +23x |
- label = unname(labels_or_names(data[covar])),+ event_free_rate_3d <- c(event_free_rate, rate_ci) |
| 248 | -19x | +79 | +23x |
- at = at,+ list( |
| 249 | -19x | +80 | +23x |
- control = control,+ pt_at_risk = formatters::with_label(pt_at_risk, "Patients remaining at risk"), |
| 250 | -19x | -
- data = data- |
- ||
| 251 | -+ | 81 | +23x |
- )+ event_free_rate = formatters::with_label(event_free_rate * 100, "Event Free Rate (%)"), |
| 252 | -19x | +82 | +23x |
- rbind(covar_test, y)+ rate_se = formatters::with_label(rate_se * 100, "Standard Error of Event Free Rate"), |
| 253 | -+ | |||
| 83 | +23x |
- }+ rate_ci = formatters::with_label(rate_ci * 100, f_conf_level(conf_level)), |
||
| 254 | -+ | |||
| 84 | +23x |
- }+ event_free_rate_3d = formatters::with_label( |
||
| 255 | -+ | |||
| 85 | +23x |
-
+ event_free_rate_3d * 100, paste0("Event Free Rate (", f_conf_level(conf_level), ")")
|
||
| 256 | +86 |
- #' @describeIn cox_regression_inter Hazard ratio estimation in interactions.+ ) |
||
| 257 | +87 |
- #'+ ) |
||
| 258 | +88 |
- #' @param variable,given (`string`)\cr the name of variables in interaction. We seek the estimation+ } |
||
| 259 | +89 |
- #' of the levels of `variable` given the levels of `given`.+ |
||
| 260 | +90 |
- #' @param lvl_var,lvl_given (`character`)\cr corresponding levels as given by [levels()].+ #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()` |
||
| 261 | +91 |
- #' @param mod (`coxph`)\cr a fitted Cox regression model (see [survival::coxph()]).+ #' when `method = "surv"`. |
||
| 262 | +92 |
#' |
||
| 263 | -- |
- #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A)- |
- ||
| 264 | +93 |
- #' and Sex (F, M; reference Female) and the model being abbreviated: y ~ Arm + Sex + Arm:Sex.+ #' @return |
||
| 265 | +94 |
- #' The cox regression estimates the coefficients along with a variance-covariance matrix for:+ #' * `a_surv_timepoint()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 266 | +95 |
#' |
||
| 267 | -- |
- #' - b1 (arm b), b2 (arm c)- |
- ||
| 268 | +96 |
- #' - b3 (sex m)+ #' @keywords internal |
||
| 269 | +97 |
- #' - b4 (arm b: sex m), b5 (arm c: sex m)+ a_surv_timepoint <- make_afun( |
||
| 270 | +98 |
- #'+ s_surv_timepoint, |
||
| 271 | +99 |
- #' The estimation of the Hazard Ratio for arm C/sex M is given in reference+ .indent_mods = c( |
||
| 272 | +100 |
- #' to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5).+ pt_at_risk = 0L, |
||
| 273 | +101 |
- #' The interaction coefficient is deduced by b2 + b5 while the standard error+ event_free_rate = 0L, |
||
| 274 | +102 |
- #' is obtained as $sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$.+ rate_se = 1L, |
||
| 275 | +103 |
- #'+ rate_ci = 1L |
||
| 276 | +104 |
- #' @return+ ), |
||
| 277 | +105 |
- #' * `h_coxreg_inter_estimations()` returns a list of matrices (one per level of variable) with rows corresponding+ .formats = c( |
||
| 278 | +106 |
- #' to the combinations of `variable` and `given`, with columns:+ pt_at_risk = "xx", |
||
| 279 | +107 |
- #' * `coef_hat`: Estimation of the coefficient.+ event_free_rate = "xx.xx", |
||
| 280 | +108 |
- #' * `coef_se`: Standard error of the estimation.+ rate_se = "xx.xx", |
||
| 281 | +109 |
- #' * `hr`: Hazard ratio.+ rate_ci = "(xx.xx, xx.xx)" |
||
| 282 | +110 |
- #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio.+ ) |
||
| 283 | +111 |
- #'+ ) |
||
| 284 | +112 |
- #' @examples+ |
||
| 285 | +113 |
- #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder)+ #' @describeIn survival_timepoint Statistics function which analyzes difference between two survival rates. |
||
| 286 | +114 |
- #' result <- h_coxreg_inter_estimations(+ #' |
||
| 287 | +115 |
- #' variable = "armcd", given = "covar1",+ #' @return |
||
| 288 | +116 |
- #' lvl_var = levels(dta_bladder$armcd),+ #' * `s_surv_timepoint_diff()` returns the statistics: |
||
| 289 | +117 |
- #' lvl_given = levels(dta_bladder$covar1),+ #' * `rate_diff`: Event-free rate difference between two groups. |
||
| 290 | +118 |
- #' mod = mod, conf_level = .95+ #' * `rate_diff_ci`: Confidence interval for the difference. |
||
| 291 | +119 |
- #' )+ #' * `rate_diff_ci_3d`: Event-free rate difference and confidence interval between two groups. |
||
| 292 | +120 |
- #' result+ #' * `ztest_pval`: p-value to test the difference is 0. |
||
| 293 | +121 |
#' |
||
| 294 | -- |
- #' @export- |
- ||
| 295 | -- |
- h_coxreg_inter_estimations <- function(variable,- |
- ||
| 296 | +122 |
- given,+ #' @keywords internal |
||
| 297 | +123 |
- lvl_var,+ s_surv_timepoint_diff <- function(df, |
||
| 298 | +124 |
- lvl_given,+ .var, |
||
| 299 | +125 |
- mod,+ .ref_group, |
||
| 300 | +126 |
- conf_level = 0.95) {
- |
- ||
| 301 | -18x | -
- var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level- |
- ||
| 302 | -18x | -
- giv_lvl <- paste0(given, lvl_given)- |
- ||
| 303 | -18x | -
- design_mat <- expand.grid(variable = var_lvl, given = giv_lvl)- |
- ||
| 304 | -18x | -
- design_mat <- design_mat[order(design_mat$variable, design_mat$given), ]- |
- ||
| 305 | -18x | -
- design_mat <- within(- |
- ||
| 306 | -18x | -
- data = design_mat,- |
- ||
| 307 | -18x | -
- expr = {
- |
- ||
| 308 | -18x | -
- inter <- paste0(variable, ":", given)- |
- ||
| 309 | -18x | -
- rev_inter <- paste0(given, ":", variable)+ .in_ref_col, |
||
| 310 | +127 |
- }+ time_point, |
||
| 311 | +128 |
- )- |
- ||
| 312 | -18x | -
- split_by_variable <- design_mat$variable- |
- ||
| 313 | -18x | -
- interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/")+ control = control_surv_timepoint(), |
||
| 314 | +129 | - - | -||
| 315 | -18x | -
- mmat <- stats::model.matrix(mod)[1, ]+ ...) {
|
||
| 316 | -18x | +130 | +2x |
- mmat[!mmat == 0] <- 0+ if (.in_ref_col) {
|
| 317 | -+ | |||
| 131 | +! |
-
+ return( |
||
| 318 | -18x | +|||
| 132 | +! |
- design_mat <- apply(+ list( |
||
| 319 | -18x | +|||
| 133 | +! |
- X = design_mat, MARGIN = 1, FUN = function(x) {
+ rate_diff = formatters::with_label("", "Difference in Event Free Rate"),
|
||
| 320 | -52x | +|||
| 134 | +! |
- mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1+ rate_diff_ci = formatters::with_label("", f_conf_level(control$conf_level)),
|
||
| 321 | -52x | +|||
| 135 | +! |
- mmat+ rate_diff_ci_3d = formatters::with_label( |
||
| 322 | -+ | |||
| 136 | +! |
- }+ "", paste0("Difference in Event Free Rate", f_conf_level(control$conf_level))
|
||
| 323 | +137 |
- )+ ), |
||
| 324 | -18x | +|||
| 138 | +! |
- colnames(design_mat) <- interaction_names+ ztest_pval = formatters::with_label("", "p-value (Z-test)")
|
||
| 325 | +139 | - - | -||
| 326 | -18x | -
- coef <- stats::coef(mod)- |
- ||
| 327 | -18x | -
- vcov <- stats::vcov(mod)+ ) |
||
| 328 | -18x | +|||
| 140 | +
- betas <- as.matrix(coef)+ ) |
|||
| 329 | -18x | +|||
| 141 | +
- coef_hat <- t(design_mat) %*% betas+ } |
|||
| 330 | -18x | +142 | +2x |
- dimnames(coef_hat)[2] <- "coef"+ data <- rbind(.ref_group, df) |
| 331 | -18x | +143 | +2x |
- coef_se <- apply(+ group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
|
| 332 | -18x | +144 | +2x |
- design_mat, 2,+ res_per_group <- lapply(split(data, group), function(x) {
|
| 333 | -18x | +145 | +4x |
- function(x) {
+ s_surv_timepoint(df = x, .var = .var, time_point = time_point, control = control, ...) |
| 334 | -52x | +|||
| 146 | +
- vcov_el <- as.logical(x)+ }) |
|||
| 335 | -52x | +|||
| 147 | +
- y <- vcov[vcov_el, vcov_el]+ |
|||
| 336 | -52x | +148 | +2x |
- y <- sum(y)+ res_x <- res_per_group[[2]] |
| 337 | -52x | +149 | +2x |
- y <- sqrt(y)+ res_ref <- res_per_group[[1]] |
| 338 | -52x | +150 | +2x |
- return(y)+ rate_diff <- res_x$event_free_rate - res_ref$event_free_rate |
| 339 | -+ | |||
| 151 | +2x |
- }+ se_diff <- sqrt(res_x$rate_se^2 + res_ref$rate_se^2) |
||
| 340 | +152 |
- )+ |
||
| 341 | -18x | +153 | +2x |
- q_norm <- stats::qnorm((1 + conf_level) / 2)+ qs <- c(-1, 1) * stats::qnorm(1 - (1 - control$conf_level) / 2) |
| 342 | -18x | +154 | +2x |
- y <- cbind(coef_hat, `se(coef)` = coef_se)+ rate_diff_ci <- rate_diff + qs * se_diff |
| 343 | -18x | +155 | +2x |
- y <- apply(y, 1, function(x) {
+ rate_diff_ci_3d <- c(rate_diff, rate_diff_ci) |
| 344 | -52x | +156 | +2x |
- x["hr"] <- exp(x["coef"])+ ztest_pval <- if (is.na(rate_diff)) {
|
| 345 | -52x | +157 | +2x |
- x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"])+ NA |
| 346 | -52x | +|||
| 158 | +
- x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"])+ } else {
|
|||
| 347 | -52x | +159 | +2x |
- x+ 2 * (1 - stats::pnorm(abs(rate_diff) / se_diff)) |
| 348 | +160 |
- })+ } |
||
| 349 | -18x | +161 | +2x |
- y <- t(y)+ list( |
| 350 | -18x | +162 | +2x |
- y <- by(y, split_by_variable, identity)+ rate_diff = formatters::with_label(rate_diff, "Difference in Event Free Rate"), |
| 351 | -18x | +163 | +2x |
- y <- lapply(y, as.matrix)+ rate_diff_ci = formatters::with_label(rate_diff_ci, f_conf_level(control$conf_level)), |
| 352 | -18x | +164 | +2x |
- attr(y, "details") <- paste0(+ rate_diff_ci_3d = formatters::with_label( |
| 353 | -18x | +165 | +2x |
- "Estimations of ", variable,+ rate_diff_ci_3d, paste0("Difference in Event Free Rate", f_conf_level(control$conf_level))
|
| 354 | -18x | +|||
| 166 | +
- " hazard ratio given the level of ", given, " compared to ",+ ), |
|||
| 355 | -18x | +167 | +2x |
- variable, " level ", lvl_var[1], "."+ ztest_pval = formatters::with_label(ztest_pval, "p-value (Z-test)") |
| 356 | +168 |
) |
||
| 357 | -18x | -
- y- |
- ||
| 358 | +169 |
} |
| 1 | +170 |
- #' Survival time point analysis+ |
||
| 2 | +171 |
- #'+ #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()` |
||
| 3 | +172 |
- #' @description `r lifecycle::badge("stable")`
+ #' when `method = "surv_diff"`. |
||
| 4 | +173 |
#' |
||
| 5 | +174 |
- #' The analyze function [surv_timepoint()] creates a layout element to analyze patient survival rates and difference+ #' @return |
||
| 6 | +175 |
- #' of survival rates between groups at a given time point. The primary analysis variable `vars` is the time variable.+ #' * `a_surv_timepoint_diff()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 7 | +176 |
- #' Other required inputs are `time_point`, the numeric time point of interest, and `is_event`, a variable that+ #' |
||
| 8 | +177 |
- #' indicates whether or not an event has occurred. The `method` argument is used to specify whether you want to analyze+ #' @keywords internal |
||
| 9 | +178 |
- #' survival estimations (`"surv"`), difference in survival with the control (`"surv_diff"`), or both of these+ a_surv_timepoint_diff <- make_afun( |
||
| 10 | +179 |
- #' (`"both"`).+ s_surv_timepoint_diff, |
||
| 11 | +180 |
- #'+ .formats = c( |
||
| 12 | +181 |
- #' @inheritParams argument_convention+ rate_diff = "xx.xx", |
||
| 13 | +182 |
- #' @inheritParams s_surv_time+ rate_diff_ci = "(xx.xx, xx.xx)", |
||
| 14 | +183 |
- #' @param time_point (`numeric(1)`)\cr survival time point of interest.+ rate_diff_ci_3d = format_xx("xx.xx (xx.xx, xx.xx)"),
|
||
| 15 | +184 |
- #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function+ ztest_pval = "x.xxxx | (<0.0001)" |
||
| 16 | +185 |
- #' [control_surv_timepoint()]. Some possible parameter options are:+ ) |
||
| 17 | +186 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate.+ ) |
||
| 18 | +187 |
- #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log",+ |
||
| 19 | +188 |
- #' see more in [survival::survfit()]. Note option "none" is no longer supported.+ #' @describeIn survival_timepoint Layout-creating function which can take statistics function arguments |
||
| 20 | +189 |
- #' @param method (`string`)\cr `"surv"` (survival estimations), `"surv_diff"` (difference in survival with the+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 21 | +190 |
- #' control), or `"both"`.+ #' |
||
| 22 | +191 |
- #' @param table_names_suffix (`string`)\cr optional suffix for the `table_names` used for the `rtables` to+ #' @return |
||
| 23 | +192 |
- #' avoid warnings from duplicate table names.+ #' * `surv_timepoint()` returns a layout object suitable for passing to further layouting functions, |
||
| 24 | +193 |
- #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 25 | +194 |
- #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ #' the statistics from `s_surv_timepoint()` and/or `s_surv_timepoint_diff()` to the table layout depending on |
||
| 26 | +195 |
- #' for that statistic's row label.+ #' the value of `method`. |
||
| 27 | +196 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' |
||
| 28 | +197 |
- #'+ #' @examples |
||
| 29 | +198 |
- #' Options are: ``r shQuote(get_stats("surv_timepoint"))``
+ #' library(dplyr) |
||
| 30 | +199 |
#' |
||
| 31 | +200 |
- #' @name survival_timepoint+ #' adtte_f <- tern_ex_adtte %>% |
||
| 32 | +201 |
- #' @order 1+ #' filter(PARAMCD == "OS") %>% |
||
| 33 | +202 |
- NULL+ #' mutate( |
||
| 34 | +203 |
-
+ #' AVAL = day2month(AVAL), |
||
| 35 | +204 |
- #' @describeIn survival_timepoint Statistics function which analyzes survival rate.+ #' is_event = CNSR == 0 |
||
| 36 | +205 |
- #'+ #' ) |
||
| 37 | +206 |
- #' @return+ #' |
||
| 38 | +207 |
- #' * `s_surv_timepoint()` returns the statistics:+ #' # Survival at given time points. |
||
| 39 | +208 |
- #' * `pt_at_risk`: Patients remaining at risk.+ #' basic_table() %>% |
||
| 40 | +209 |
- #' * `event_free_rate`: Event-free rate (%).+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
||
| 41 | +210 |
- #' * `rate_se`: Standard error of event free rate.+ #' add_colcounts() %>% |
||
| 42 | +211 |
- #' * `rate_ci`: Confidence interval for event free rate.+ #' surv_timepoint( |
||
| 43 | +212 |
- #' * `event_free_rate_3d`: Event-free rate (%) with Confidence interval.+ #' vars = "AVAL", |
||
| 44 | +213 |
- #'+ #' var_labels = "Months", |
||
| 45 | +214 |
- #' @keywords internal+ #' is_event = "is_event", |
||
| 46 | +215 |
- s_surv_timepoint <- function(df,+ #' time_point = 7 |
||
| 47 | +216 |
- .var,+ #' ) %>% |
||
| 48 | +217 |
- time_point,+ #' build_table(df = adtte_f) |
||
| 49 | +218 |
- is_event,+ #' |
||
| 50 | +219 |
- control = control_surv_timepoint()) {
- |
- ||
| 51 | -23x | -
- checkmate::assert_string(.var)- |
- ||
| 52 | -23x | -
- assert_df_with_variables(df, list(tte = .var, is_event = is_event))- |
- ||
| 53 | -23x | -
- checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE)- |
- ||
| 54 | -23x | -
- checkmate::assert_number(time_point)- |
- ||
| 55 | -23x | -
- checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)+ #' # Difference in survival at given time points. |
||
| 56 | +220 | - - | -||
| 57 | -23x | -
- conf_type <- control$conf_type+ #' basic_table() %>% |
||
| 58 | -23x | +|||
| 221 | +
- conf_level <- control$conf_level+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
|||
| 59 | +222 |
-
+ #' add_colcounts() %>% |
||
| 60 | -23x | +|||
| 223 | +
- formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
+ #' surv_timepoint( |
|||
| 61 | -23x | +|||
| 224 | +
- srv_fit <- survival::survfit(+ #' vars = "AVAL", |
|||
| 62 | -23x | +|||
| 225 | +
- formula = formula,+ #' var_labels = "Months", |
|||
| 63 | -23x | +|||
| 226 | +
- data = df,+ #' is_event = "is_event", |
|||
| 64 | -23x | +|||
| 227 | +
- conf.int = conf_level,+ #' time_point = 9, |
|||
| 65 | -23x | +|||
| 228 | +
- conf.type = conf_type+ #' method = "surv_diff", |
|||
| 66 | +229 |
- )+ #' .indent_mods = c("rate_diff" = 0L, "rate_diff_ci" = 2L, "ztest_pval" = 2L)
|
||
| 67 | -23x | +|||
| 230 | +
- s_srv_fit <- summary(srv_fit, times = time_point, extend = TRUE)+ #' ) %>% |
|||
| 68 | -23x | +|||
| 231 | +
- df_srv_fit <- as.data.frame(s_srv_fit[c("time", "n.risk", "surv", "lower", "upper", "std.err")])
+ #' build_table(df = adtte_f) |
|||
| 69 | -23x | +|||
| 232 | +
- if (df_srv_fit[["n.risk"]] == 0) {
+ #' |
|||
| 70 | -1x | +|||
| 233 | +
- pt_at_risk <- event_free_rate <- rate_se <- NA_real_+ #' # Survival and difference in survival at given time points. |
|||
| 71 | -1x | +|||
| 234 | +
- rate_ci <- c(NA_real_, NA_real_)+ #' basic_table() %>% |
|||
| 72 | +235 |
- } else {
+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
||
| 73 | -22x | +|||
| 236 | +
- pt_at_risk <- df_srv_fit$n.risk+ #' add_colcounts() %>% |
|||
| 74 | -22x | +|||
| 237 | +
- event_free_rate <- df_srv_fit$surv+ #' surv_timepoint( |
|||
| 75 | -22x | +|||
| 238 | +
- rate_se <- df_srv_fit$std.err+ #' vars = "AVAL", |
|||
| 76 | -22x | +|||
| 239 | +
- rate_ci <- c(df_srv_fit$lower, df_srv_fit$upper)+ #' var_labels = "Months", |
|||
| 77 | +240 |
- }+ #' is_event = "is_event", |
||
| 78 | -23x | +|||
| 241 | +
- event_free_rate_3d <- c(event_free_rate, rate_ci)+ #' time_point = 9, |
|||
| 79 | -23x | +|||
| 242 | +
- list(+ #' method = "both" |
|||
| 80 | -23x | +|||
| 243 | +
- pt_at_risk = formatters::with_label(pt_at_risk, "Patients remaining at risk"),+ #' ) %>% |
|||
| 81 | -23x | +|||
| 244 | +
- event_free_rate = formatters::with_label(event_free_rate * 100, "Event Free Rate (%)"),+ #' build_table(df = adtte_f) |
|||
| 82 | -23x | +|||
| 245 | +
- rate_se = formatters::with_label(rate_se * 100, "Standard Error of Event Free Rate"),+ #' |
|||
| 83 | -23x | +|||
| 246 | +
- rate_ci = formatters::with_label(rate_ci * 100, f_conf_level(conf_level)),+ #' @export |
|||
| 84 | -23x | +|||
| 247 | +
- event_free_rate_3d = formatters::with_label(+ #' @order 2 |
|||
| 85 | -23x | +|||
| 248 | +
- event_free_rate_3d * 100, paste0("Event Free Rate (", f_conf_level(conf_level), ")")
+ surv_timepoint <- function(lyt, |
|||
| 86 | +249 |
- )+ vars, |
||
| 87 | +250 |
- )+ time_point, |
||
| 88 | +251 |
- }+ is_event, |
||
| 89 | +252 |
-
+ control = control_surv_timepoint(), |
||
| 90 | +253 |
- #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()`+ method = c("surv", "surv_diff", "both"),
|
||
| 91 | +254 |
- #' when `method = "surv"`.+ na_str = default_na_str(), |
||
| 92 | +255 |
- #'+ nested = TRUE, |
||
| 93 | +256 |
- #' @return+ ..., |
||
| 94 | +257 |
- #' * `a_surv_timepoint()` returns the corresponding list with formatted [rtables::CellValue()].+ table_names_suffix = "", |
||
| 95 | +258 |
- #'+ var_labels = "Time", |
||
| 96 | +259 |
- #' @keywords internal+ show_labels = "visible", |
||
| 97 | +260 |
- a_surv_timepoint <- make_afun(+ .stats = c( |
||
| 98 | +261 |
- s_surv_timepoint,+ "pt_at_risk", "event_free_rate", "rate_ci", |
||
| 99 | +262 |
- .indent_mods = c(+ "rate_diff", "rate_diff_ci", "ztest_pval" |
||
| 100 | +263 |
- pt_at_risk = 0L,+ ), |
||
| 101 | +264 |
- event_free_rate = 0L,+ .formats = NULL, |
||
| 102 | +265 |
- rate_se = 1L,+ .labels = NULL, |
||
| 103 | +266 |
- rate_ci = 1L+ .indent_mods = if (method == "both") {
|
||
| 104 | -+ | |||
| 267 | +2x |
- ),+ c(rate_diff = 1L, rate_diff_ci = 2L, ztest_pval = 2L) |
||
| 105 | +268 |
- .formats = c(+ } else {
|
||
| 106 | -+ | |||
| 269 | +4x |
- pt_at_risk = "xx",+ c(rate_diff_ci = 1L, ztest_pval = 1L) |
||
| 107 | +270 |
- event_free_rate = "xx.xx",+ }) {
|
||
| 108 | -+ | |||
| 271 | +6x |
- rate_se = "xx.xx",+ method <- match.arg(method) |
||
| 109 | -+ | |||
| 272 | +6x |
- rate_ci = "(xx.xx, xx.xx)"+ checkmate::assert_string(table_names_suffix) |
||
| 110 | +273 |
- )+ |
||
| 111 | -+ | |||
| 274 | +6x |
- )+ extra_args <- list(time_point = time_point, is_event = is_event, control = control, ...) |
||
| 112 | +275 | |||
| 113 | -+ | |||
| 276 | +6x |
- #' @describeIn survival_timepoint Statistics function which analyzes difference between two survival rates.+ f <- list( |
||
| 114 | -+ | |||
| 277 | +6x |
- #'+ surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci", "event_free_rate_3d"),
|
||
| 115 | -+ | |||
| 278 | +6x |
- #' @return+ surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval", "rate_diff_ci_3d")
|
||
| 116 | +279 |
- #' * `s_surv_timepoint_diff()` returns the statistics:+ ) |
||
| 117 | -+ | |||
| 280 | +6x |
- #' * `rate_diff`: Event-free rate difference between two groups.+ .stats <- h_split_param(.stats, .stats, f = f) |
||
| 118 | -+ | |||
| 281 | +6x |
- #' * `rate_diff_ci`: Confidence interval for the difference.+ .formats <- h_split_param(.formats, names(.formats), f = f) |
||
| 119 | -+ | |||
| 282 | +6x |
- #' * `rate_diff_ci_3d`: Event-free rate difference and confidence interval between two groups.+ .labels <- h_split_param(.labels, names(.labels), f = f) |
||
| 120 | -+ | |||
| 283 | +6x |
- #' * `ztest_pval`: p-value to test the difference is 0.+ .indent_mods <- h_split_param(.indent_mods, names(.indent_mods), f = f) |
||
| 121 | +284 |
- #'+ |
||
| 122 | -+ | |||
| 285 | +6x |
- #' @keywords internal+ afun_surv <- make_afun( |
||
| 123 | -+ | |||
| 286 | +6x |
- s_surv_timepoint_diff <- function(df,+ a_surv_timepoint, |
||
| 124 | -+ | |||
| 287 | +6x |
- .var,+ .stats = .stats$surv, |
||
| 125 | -+ | |||
| 288 | +6x |
- .ref_group,+ .formats = .formats$surv, |
||
| 126 | -+ | |||
| 289 | +6x |
- .in_ref_col,+ .labels = .labels$surv, |
||
| 127 | -+ | |||
| 290 | +6x |
- time_point,+ .indent_mods = .indent_mods$surv |
||
| 128 | +291 |
- control = control_surv_timepoint(),+ ) |
||
| 129 | +292 |
- ...) {
+
|
||
| 130 | -2x | +293 | +6x |
- if (.in_ref_col) {
+ afun_surv_diff <- make_afun( |
| 131 | -! | +|||
| 294 | +6x |
- return(+ a_surv_timepoint_diff, |
||
| 132 | -! | +|||
| 295 | +6x |
- list(+ .stats = .stats$surv_diff, |
||
| 133 | -! | +|||
| 296 | +6x |
- rate_diff = formatters::with_label("", "Difference in Event Free Rate"),
+ .formats = .formats$surv_diff, |
||
| 134 | -! | +|||
| 297 | +6x |
- rate_diff_ci = formatters::with_label("", f_conf_level(control$conf_level)),
+ .labels = .labels$surv_diff, |
||
| 135 | -! | +|||
| 298 | +6x |
- rate_diff_ci_3d = formatters::with_label(+ .indent_mods = .indent_mods$surv_diff |
||
| 136 | -! | +|||
| 299 | +
- "", paste0("Difference in Event Free Rate", f_conf_level(control$conf_level))
+ ) |
|||
| 137 | +300 |
- ),+ |
||
| 138 | -! | +|||
| 301 | +6x |
- ztest_pval = formatters::with_label("", "p-value (Z-test)")
+ time_point <- extra_args$time_point |
||
| 139 | +302 |
- )+ |
||
| 140 | -+ | |||
| 303 | +6x |
- )+ for (i in seq_along(time_point)) {
+ |
+ ||
| 304 | +6x | +
+ extra_args[["time_point"]] <- time_point[i] |
||
| 141 | +305 |
- }+ |
||
| 142 | -2x | +306 | +6x |
- data <- rbind(.ref_group, df)+ if (method %in% c("surv", "both")) {
|
| 143 | -2x | +307 | +4x |
- group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
+ lyt <- analyze( |
| 144 | -2x | +308 | +4x |
- res_per_group <- lapply(split(data, group), function(x) {
+ lyt, |
| 145 | +309 | 4x |
- s_surv_timepoint(df = x, .var = .var, time_point = time_point, control = control, ...)+ vars, |
|
| 146 | -+ | |||
| 310 | +4x |
- })+ var_labels = paste(time_point[i], var_labels), |
||
| 147 | -+ | |||
| 311 | +4x |
-
+ table_names = paste0("surv_", time_point[i], table_names_suffix),
|
||
| 148 | -2x | +312 | +4x |
- res_x <- res_per_group[[2]]+ show_labels = show_labels,+ |
+
| 313 | +4x | +
+ afun = afun_surv, |
||
| 149 | -2x | +314 | +4x |
- res_ref <- res_per_group[[1]]+ na_str = na_str, |
| 150 | -2x | +315 | +4x |
- rate_diff <- res_x$event_free_rate - res_ref$event_free_rate+ nested = nested, |
| 151 | -2x | +316 | +4x |
- se_diff <- sqrt(res_x$rate_se^2 + res_ref$rate_se^2)+ extra_args = extra_args |
| 152 | +317 |
-
+ ) |
||
| 153 | -2x | +|||
| 318 | +
- qs <- c(-1, 1) * stats::qnorm(1 - (1 - control$conf_level) / 2)+ } |
|||
| 154 | -2x | +|||
| 319 | +
- rate_diff_ci <- rate_diff + qs * se_diff+ |
|||
| 155 | -2x | +320 | +6x |
- rate_diff_ci_3d <- c(rate_diff, rate_diff_ci)+ if (method %in% c("surv_diff", "both")) {
|
| 156 | -2x | +321 | +4x |
- ztest_pval <- if (is.na(rate_diff)) {
+ lyt <- analyze( |
| 157 | -2x | +322 | +4x |
- NA+ lyt, |
| 158 | -+ | |||
| 323 | +4x |
- } else {
+ vars, |
||
| 159 | -2x | +324 | +4x |
- 2 * (1 - stats::pnorm(abs(rate_diff) / se_diff))+ var_labels = paste(time_point[i], var_labels), |
| 160 | -+ | |||
| 325 | +4x |
- }+ table_names = paste0("surv_diff_", time_point[i], table_names_suffix),
|
||
| 161 | -2x | +326 | +4x |
- list(+ show_labels = ifelse(method == "both", "hidden", show_labels), |
| 162 | -2x | +327 | +4x |
- rate_diff = formatters::with_label(rate_diff, "Difference in Event Free Rate"),+ afun = afun_surv_diff, |
| 163 | -2x | +328 | +4x |
- rate_diff_ci = formatters::with_label(rate_diff_ci, f_conf_level(control$conf_level)),+ na_str = na_str, |
| 164 | -2x | +329 | +4x |
- rate_diff_ci_3d = formatters::with_label(+ nested = nested, |
| 165 | -2x | +330 | +4x |
- rate_diff_ci_3d, paste0("Difference in Event Free Rate", f_conf_level(control$conf_level))
+ extra_args = extra_args |
| 166 | +331 |
- ),+ ) |
||
| 167 | -2x | +|||
| 332 | +
- ztest_pval = formatters::with_label(ztest_pval, "p-value (Z-test)")+ } |
|||
| 168 | +333 |
- )+ }+ |
+ ||
| 334 | +6x | +
+ lyt |
||
| 169 | +335 |
} |
| 170 | +1 |
-
+ #' Count number of patients with missed doses by thresholds |
||
| 171 | +2 |
- #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()`+ #' |
||
| 172 | +3 |
- #' when `method = "surv_diff"`.+ #' @description `r lifecycle::badge("stable")`
|
||
| 173 | +4 |
#' |
||
| 174 | +5 |
- #' @return+ #' The analyze function creates a layout element to calculate cumulative counts of patients with number of missed |
||
| 175 | +6 |
- #' * `a_surv_timepoint_diff()` returns the corresponding list with formatted [rtables::CellValue()].+ #' doses at least equal to user-specified threshold values. |
||
| 176 | +7 |
#' |
||
| 177 | +8 |
- #' @keywords internal+ #' This function analyzes numeric variable `vars`, a variable with numbers of missed doses, |
||
| 178 | +9 |
- a_surv_timepoint_diff <- make_afun(+ #' against the threshold values supplied to the `thresholds` argument as a numeric vector. This function |
||
| 179 | +10 |
- s_surv_timepoint_diff,+ #' assumes that every row of the given data frame corresponds to a unique patient. |
||
| 180 | +11 |
- .formats = c(+ #' |
||
| 181 | +12 |
- rate_diff = "xx.xx",+ #' @inheritParams s_count_cumulative |
||
| 182 | +13 |
- rate_diff_ci = "(xx.xx, xx.xx)",+ #' @inheritParams argument_convention |
||
| 183 | +14 |
- rate_diff_ci_3d = format_xx("xx.xx (xx.xx, xx.xx)"),
+ #' @param thresholds (`numeric`)\cr minimum number of missed doses the patients had. |
||
| 184 | +15 |
- ztest_pval = "x.xxxx | (<0.0001)"+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 185 | +16 |
- )+ #' |
||
| 186 | +17 |
- )+ #' Options are: ``r shQuote(get_stats("count_missed_doses"), type = "sh")``
|
||
| 187 | +18 |
-
+ #' |
||
| 188 | +19 |
- #' @describeIn survival_timepoint Layout-creating function which can take statistics function arguments+ #' @seealso |
||
| 189 | +20 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' * Relevant description function [d_count_missed_doses()] which generates labels for [count_missed_doses()]. |
||
| 190 | +21 |
- #'+ #' * Similar analyze function [count_cumulative()] which more generally counts cumulative values and has more |
||
| 191 | +22 |
- #' @return+ #' options for threshold handling, but uses different labels. |
||
| 192 | +23 |
- #' * `surv_timepoint()` returns a layout object suitable for passing to further layouting functions,+ #' |
||
| 193 | +24 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' @name count_missed_doses |
||
| 194 | +25 |
- #' the statistics from `s_surv_timepoint()` and/or `s_surv_timepoint_diff()` to the table layout depending on+ #' @order 1 |
||
| 195 | +26 |
- #' the value of `method`.+ NULL |
||
| 196 | +27 |
- #'+ |
||
| 197 | +28 |
- #' @examples+ #' @describeIn count_missed_doses Statistics function to count non-missing values. |
||
| 198 | +29 |
- #' library(dplyr)+ #' |
||
| 199 | +30 |
- #'+ #' @return |
||
| 200 | +31 |
- #' adtte_f <- tern_ex_adtte %>%+ #' * `s_count_nonmissing()` returns the statistic `n` which is the count of non-missing values in `x`. |
||
| 201 | +32 |
- #' filter(PARAMCD == "OS") %>%+ #' |
||
| 202 | +33 |
- #' mutate(+ #' @keywords internal |
||
| 203 | +34 |
- #' AVAL = day2month(AVAL),+ s_count_nonmissing <- function(x) {
|
||
| 204 | -+ | |||
| 35 | +9x |
- #' is_event = CNSR == 0+ list(n = n_available(x)) |
||
| 205 | +36 |
- #' )+ } |
||
| 206 | +37 |
- #'+ |
||
| 207 | +38 |
- #' # Survival at given time points.+ #' Description function that calculates labels for `s_count_missed_doses()` |
||
| 208 | +39 |
- #' basic_table() %>%+ #' |
||
| 209 | +40 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ #' @description `r lifecycle::badge("stable")`
|
||
| 210 | +41 |
- #' add_colcounts() %>%+ #' |
||
| 211 | +42 |
- #' surv_timepoint(+ #' @inheritParams s_count_missed_doses |
||
| 212 | +43 |
- #' vars = "AVAL",+ #' |
||
| 213 | +44 |
- #' var_labels = "Months",+ #' @return [d_count_missed_doses()] returns a named `character` vector with the labels. |
||
| 214 | +45 |
- #' is_event = "is_event",+ #' |
||
| 215 | +46 |
- #' time_point = 7+ #' @seealso [s_count_missed_doses()] |
||
| 216 | +47 |
- #' ) %>%+ #' |
||
| 217 | +48 |
- #' build_table(df = adtte_f)+ #' @export |
||
| 218 | +49 |
- #'+ d_count_missed_doses <- function(thresholds) {
|
||
| 219 | -+ | |||
| 50 | +8x |
- #' # Difference in survival at given time points.+ paste0("At least ", thresholds, " missed dose", ifelse(thresholds > 1, "s", ""))
|
||
| 220 | +51 |
- #' basic_table() %>%+ } |
||
| 221 | +52 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ |
||
| 222 | +53 |
- #' add_colcounts() %>%+ #' @describeIn count_missed_doses Statistics function to count patients with missed doses. |
||
| 223 | +54 |
- #' surv_timepoint(+ #' |
||
| 224 | +55 |
- #' vars = "AVAL",+ #' @return |
||
| 225 | +56 |
- #' var_labels = "Months",+ #' * `s_count_missed_doses()` returns the statistics `n` and `count_fraction` with one element for each threshold. |
||
| 226 | +57 |
- #' is_event = "is_event",+ #' |
||
| 227 | +58 |
- #' time_point = 9,+ #' @keywords internal |
||
| 228 | +59 |
- #' method = "surv_diff",+ s_count_missed_doses <- function(x, |
||
| 229 | +60 |
- #' .indent_mods = c("rate_diff" = 0L, "rate_diff_ci" = 2L, "ztest_pval" = 2L)
+ thresholds, |
||
| 230 | +61 |
- #' ) %>%+ .N_col, # nolint |
||
| 231 | +62 |
- #' build_table(df = adtte_f)+ .N_row, # nolint |
||
| 232 | +63 |
- #'+ denom = c("N_col", "n", "N_row")) {
|
||
| 233 | -+ | |||
| 64 | +1x |
- #' # Survival and difference in survival at given time points.+ stat <- s_count_cumulative( |
||
| 234 | -+ | |||
| 65 | +1x |
- #' basic_table() %>%+ x = x, |
||
| 235 | -+ | |||
| 66 | +1x |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ thresholds = thresholds, |
||
| 236 | -+ | |||
| 67 | +1x |
- #' add_colcounts() %>%+ lower_tail = FALSE, |
||
| 237 | -+ | |||
| 68 | +1x |
- #' surv_timepoint(+ include_eq = TRUE, |
||
| 238 | -+ | |||
| 69 | +1x |
- #' vars = "AVAL",+ .N_col = .N_col, |
||
| 239 | -+ | |||
| 70 | +1x |
- #' var_labels = "Months",+ .N_row = .N_row, |
||
| 240 | -+ | |||
| 71 | +1x |
- #' is_event = "is_event",+ denom = denom |
||
| 241 | +72 |
- #' time_point = 9,+ ) |
||
| 242 | -+ | |||
| 73 | +1x |
- #' method = "both"+ labels <- d_count_missed_doses(thresholds) |
||
| 243 | -+ | |||
| 74 | +1x |
- #' ) %>%+ for (i in seq_along(stat$count_fraction)) {
|
||
| 244 | -+ | |||
| 75 | +2x |
- #' build_table(df = adtte_f)+ stat$count_fraction[[i]] <- formatters::with_label(stat$count_fraction[[i]], label = labels[i]) |
||
| 245 | +76 |
- #'+ } |
||
| 246 | -+ | |||
| 77 | +1x |
- #' @export+ n_stat <- s_count_nonmissing(x) |
||
| 247 | -+ | |||
| 78 | +1x |
- #' @order 2+ c(n_stat, stat) |
||
| 248 | +79 |
- surv_timepoint <- function(lyt,+ } |
||
| 249 | +80 |
- vars,+ |
||
| 250 | +81 |
- time_point,+ #' @describeIn count_missed_doses Formatted analysis function which is used as `afun` |
||
| 251 | +82 |
- is_event,+ #' in `count_missed_doses()`. |
||
| 252 | +83 |
- control = control_surv_timepoint(),+ #' |
||
| 253 | +84 |
- method = c("surv", "surv_diff", "both"),
+ #' @return |
||
| 254 | +85 |
- na_str = default_na_str(),+ #' * `a_count_missed_doses()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 255 | +86 |
- nested = TRUE,+ #' |
||
| 256 | +87 |
- ...,+ #' @keywords internal |
||
| 257 | +88 |
- table_names_suffix = "",+ a_count_missed_doses <- make_afun( |
||
| 258 | +89 |
- var_labels = "Time",+ s_count_missed_doses, |
||
| 259 | +90 |
- show_labels = "visible",+ .formats = c(n = "xx", count_fraction = format_count_fraction) |
||
| 260 | +91 |
- .stats = c(+ ) |
||
| 261 | +92 |
- "pt_at_risk", "event_free_rate", "rate_ci",+ |
||
| 262 | +93 |
- "rate_diff", "rate_diff_ci", "ztest_pval"+ #' @describeIn count_missed_doses Layout-creating function which can take statistics function arguments |
||
| 263 | +94 |
- ),+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 264 | +95 |
- .formats = NULL,+ #' |
||
| 265 | +96 |
- .labels = NULL,+ #' @return |
||
| 266 | +97 |
- .indent_mods = if (method == "both") {
- |
- ||
| 267 | -2x | -
- c(rate_diff = 1L, rate_diff_ci = 2L, ztest_pval = 2L)+ #' * `count_missed_doses()` returns a layout object suitable for passing to further layouting functions, |
||
| 268 | +98 |
- } else {
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 269 | -4x | +|||
| 99 | +
- c(rate_diff_ci = 1L, ztest_pval = 1L)+ #' the statistics from `s_count_missed_doses()` to the table layout. |
|||
| 270 | +100 |
- }) {
+ #' |
||
| 271 | -6x | +|||
| 101 | +
- method <- match.arg(method)+ #' @examples |
|||
| 272 | -6x | +|||
| 102 | +
- checkmate::assert_string(table_names_suffix)+ #' library(dplyr) |
|||
| 273 | +103 |
-
+ #' |
||
| 274 | -6x | +|||
| 104 | +
- extra_args <- list(time_point = time_point, is_event = is_event, control = control, ...)+ #' anl <- tern_ex_adsl %>% |
|||
| 275 | +105 |
-
+ #' distinct(STUDYID, USUBJID, ARM) %>% |
||
| 276 | -6x | +|||
| 106 | +
- f <- list(+ #' mutate( |
|||
| 277 | -6x | +|||
| 107 | +
- surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci", "event_free_rate_3d"),
+ #' PARAMCD = "TNDOSMIS", |
|||
| 278 | -6x | +|||
| 108 | +
- surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval", "rate_diff_ci_3d")
+ #' PARAM = "Total number of missed doses during study", |
|||
| 279 | +109 |
- )+ #' AVAL = sample(0:20, size = nrow(tern_ex_adsl), replace = TRUE), |
||
| 280 | -6x | +|||
| 110 | +
- .stats <- h_split_param(.stats, .stats, f = f)+ #' AVALC = "" |
|||
| 281 | -6x | +|||
| 111 | +
- .formats <- h_split_param(.formats, names(.formats), f = f)+ #' ) |
|||
| 282 | -6x | +|||
| 112 | +
- .labels <- h_split_param(.labels, names(.labels), f = f)+ #' |
|||
| 283 | -6x | +|||
| 113 | +
- .indent_mods <- h_split_param(.indent_mods, names(.indent_mods), f = f)+ #' basic_table() %>% |
|||
| 284 | +114 |
-
+ #' split_cols_by("ARM") %>%
|
||
| 285 | -6x | +|||
| 115 | +
- afun_surv <- make_afun(+ #' add_colcounts() %>% |
|||
| 286 | -6x | +|||
| 116 | +
- a_surv_timepoint,+ #' count_missed_doses("AVAL", thresholds = c(1, 5, 10, 15), var_labels = "Missed Doses") %>%
|
|||
| 287 | -6x | +|||
| 117 | +
- .stats = .stats$surv,+ #' build_table(anl, alt_counts_df = tern_ex_adsl) |
|||
| 288 | -6x | +|||
| 118 | +
- .formats = .formats$surv,+ #' |
|||
| 289 | -6x | +|||
| 119 | +
- .labels = .labels$surv,+ #' @export |
|||
| 290 | -6x | +|||
| 120 | +
- .indent_mods = .indent_mods$surv+ #' @order 2 |
|||
| 291 | +121 |
- )+ count_missed_doses <- function(lyt, |
||
| 292 | +122 |
-
+ vars, |
||
| 293 | -6x | +|||
| 123 | +
- afun_surv_diff <- make_afun(+ thresholds, |
|||
| 294 | -6x | +|||
| 124 | +
- a_surv_timepoint_diff,+ var_labels = vars, |
|||
| 295 | -6x | +|||
| 125 | +
- .stats = .stats$surv_diff,+ show_labels = "visible", |
|||
| 296 | -6x | +|||
| 126 | +
- .formats = .formats$surv_diff,+ na_str = default_na_str(), |
|||
| 297 | -6x | +|||
| 127 | +
- .labels = .labels$surv_diff,+ nested = TRUE, |
|||
| 298 | -6x | +|||
| 128 | +
- .indent_mods = .indent_mods$surv_diff+ ..., |
|||
| 299 | +129 |
- )+ table_names = vars, |
||
| 300 | +130 |
-
+ .stats = NULL, |
||
| 301 | -6x | +|||
| 131 | +
- time_point <- extra_args$time_point+ .formats = NULL, |
|||
| 302 | +132 |
-
+ .labels = NULL, |
||
| 303 | -6x | +|||
| 133 | +
- for (i in seq_along(time_point)) {
+ .indent_mods = NULL) {
|
|||
| 304 | -6x | +134 | +2x |
- extra_args[["time_point"]] <- time_point[i]+ extra_args <- list(thresholds = thresholds, ...) |
| 305 | +135 | |||
| 306 | -6x | -
- if (method %in% c("surv", "both")) {
- |
- ||
| 307 | -4x | -
- lyt <- analyze(- |
- ||
| 308 | -4x | -
- lyt,- |
- ||
| 309 | -4x | -
- vars,- |
- ||
| 310 | -4x | +136 | +2x |
- var_labels = paste(time_point[i], var_labels),+ afun <- make_afun( |
| 311 | -4x | +137 | +2x |
- table_names = paste0("surv_", time_point[i], table_names_suffix),
+ a_count_missed_doses, |
| 312 | -4x | +138 | +2x |
- show_labels = show_labels,+ .stats = .stats, |
| 313 | -4x | +139 | +2x |
- afun = afun_surv,+ .formats = .formats, |
| 314 | -4x | +140 | +2x |
- na_str = na_str,+ .labels = .labels, |
| 315 | -4x | +141 | +2x |
- nested = nested,+ .indent_mods = .indent_mods, |
| 316 | -4x | -
- extra_args = extra_args- |
- ||
| 317 | -- |
- )- |
- ||
| 318 | -+ | 142 | +2x |
- }+ .ungroup_stats = "count_fraction" |
| 319 | +143 | - - | -||
| 320 | -6x | -
- if (method %in% c("surv_diff", "both")) {
+ ) |
||
| 321 | -4x | +144 | +2x |
- lyt <- analyze(+ analyze( |
| 322 | -4x | +145 | +2x |
- lyt,+ lyt = lyt, |
| 323 | -4x | +146 | +2x |
- vars,+ vars = vars, |
| 324 | -4x | +147 | +2x |
- var_labels = paste(time_point[i], var_labels),+ afun = afun, |
| 325 | -4x | +148 | +2x |
- table_names = paste0("surv_diff_", time_point[i], table_names_suffix),
+ var_labels = var_labels, |
| 326 | -4x | +149 | +2x |
- show_labels = ifelse(method == "both", "hidden", show_labels),+ table_names = table_names, |
| 327 | -4x | +150 | +2x |
- afun = afun_surv_diff,+ show_labels = show_labels, |
| 328 | -4x | +151 | +2x |
- na_str = na_str,+ na_str = na_str, |
| 329 | -4x | +152 | +2x |
- nested = nested,+ nested = nested, |
| 330 | -4x | -
- extra_args = extra_args- |
- ||
| 331 | -- |
- )- |
- ||
| 332 | -+ | 153 | +2x |
- }+ extra_args = extra_args |
| 333 | +154 |
- }- |
- ||
| 334 | -6x | -
- lyt+ ) |
||
| 335 | +155 |
}@@ -176586,14 +178264,14 @@ tern coverage - 95.59% |
| 1 |
- #' Convert `rtable` objects to `ggplot` objects+ #' Compare variables between groups |
|||
| 3 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @description `r lifecycle::badge("stable")`
|
|||
| 5 |
- #' Given a [rtables::rtable()] object, performs basic conversion to a [ggplot2::ggplot()] object built using+ #' The analyze function [compare_vars()] creates a layout element to summarize and compare one or more variables, using |
|||
| 6 |
- #' functions from the `ggplot2` package. Any table titles and/or footnotes are ignored.+ #' the S3 generic function [s_summary()] to calculate a list of summary statistics. A list of all available statistics |
|||
| 7 |
- #'+ #' for numeric variables can be viewed by running `get_stats("analyze_vars_numeric", add_pval = TRUE)` and for
|
|||
| 8 |
- #' @param tbl (`VTableTree`)\cr `rtables` table object.+ #' non-numeric variables by running `get_stats("analyze_vars_counts", add_pval = TRUE)`. Use the `.stats` parameter to
|
|||
| 9 |
- #' @param fontsize (`numeric(1)`)\cr font size.+ #' specify the statistics to include in your output summary table. |
|||
| 10 |
- #' @param colwidths (`numeric` or `NULL`)\cr a vector of column widths. Each element's position in+ #' |
|||
| 11 |
- #' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths+ #' Prior to using this function in your table layout you must use [rtables::split_cols_by()] to create a column |
|||
| 12 |
- #' are calculated according to maximum number of characters per column.+ #' split on the variable to be used in comparisons, and specify a reference group via the `ref_group` parameter. |
|||
| 13 |
- #' @param lbl_col_padding (`numeric`)\cr additional padding to use when calculating spacing between+ #' Comparisons can be performed for each group (column) against the specified reference group by including the p-value |
|||
| 14 |
- #' the first (label) column and the second column of `tbl`. If `colwidths` is specified,+ #' statistic. |
|||
| 15 |
- #' the width of the first column becomes `colwidths[1] + lbl_col_padding`. Defaults to 0.+ #' |
|||
| 16 |
- #'+ #' @inheritParams argument_convention |
|||
| 17 |
- #' @return A `ggplot` object.+ #' @param .stats (`character`)\cr statistics to select for the table. |
|||
| 19 |
- #' @examples+ #' Options for numeric variables are: ``r shQuote(get_stats("analyze_vars_numeric", add_pval = TRUE), type = "sh")``
|
|||
| 20 |
- #' dta <- data.frame(+ #' |
|||
| 21 |
- #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ #' Options for non-numeric variables are: ``r shQuote(get_stats("analyze_vars_counts", add_pval = TRUE), type = "sh")``
|
|||
| 22 |
- #' AVISIT = rep(paste0("V", 1:3), 6),
+ #' |
|||
| 23 |
- #' AVAL = c(9:1, rep(NA, 9))+ #' @note |
|||
| 24 |
- #' )+ #' * For factor variables, `denom` for factor proportions can only be `n` since the purpose is to compare proportions |
|||
| 25 |
- #'+ #' between columns, therefore a row-based proportion would not make sense. Proportion based on `N_col` would |
|||
| 26 |
- #' lyt <- basic_table() %>%+ #' be difficult since we use counts for the chi-squared test statistic, therefore missing values should be accounted |
|||
| 27 |
- #' split_cols_by(var = "ARM") %>%+ #' for as explicit factor levels. |
|||
| 28 |
- #' split_rows_by(var = "AVISIT") %>%+ #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values |
|||
| 29 |
- #' analyze_vars(vars = "AVAL")+ #' set `na.rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit |
|||
| 30 |
- #'+ #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the |
|||
| 31 |
- #' tbl <- build_table(lyt, df = dta)+ #' default `na_level` (`"<Missing>"`) will also be excluded when `na.rm` is set to `TRUE`. |
|||
| 32 |
- #'+ #' * For character variables, automatic conversion to factor does not guarantee that the table |
|||
| 33 |
- #' rtable2gg(tbl)+ #' will be generated correctly. In particular for sparse tables this very likely can fail. |
|||
| 34 |
- #'+ #' Therefore it is always better to manually convert character variables to factors during pre-processing. |
|||
| 35 |
- #' rtable2gg(tbl, fontsize = 15, colwidths = c(2, 1, 1, 1))+ #' * For `compare_vars()`, the column split must define a reference group via `ref_group` so that the comparison |
|||
| 36 |
- #'+ #' is well defined. |
|||
| 37 |
- #' @export+ #' |
|||
| 38 |
- rtable2gg <- function(tbl, fontsize = 12, colwidths = NULL, lbl_col_padding = 0) {
+ #' @seealso [s_summary()] which is used internally to compute a summary within `s_compare()`, and [a_summary()] |
|||
| 39 | -6x | +
- mat <- rtables::matrix_form(tbl, indent_rownames = TRUE)+ #' which is used (with `compare = TRUE`) as the analysis function for `compare_vars()`. |
||
| 40 | -6x | +
- mat_strings <- formatters::mf_strings(mat)+ #' |
||
| 41 | -6x | +
- mat_aligns <- formatters::mf_aligns(mat)+ #' @name compare_variables |
||
| 42 | -6x | +
- mat_indent <- formatters::mf_rinfo(mat)$indent+ #' @include analyze_variables.R |
||
| 43 | -6x | +
- mat_display <- formatters::mf_display(mat)+ #' @order 1 |
||
| 44 | -6x | +
- nlines_hdr <- formatters::mf_nlheader(mat)+ NULL |
||
| 45 | -6x | +
- shared_hdr_rows <- which(apply(mat_display, 1, function(x) (any(!x))))+ |
||
| 46 |
-
+ #' @describeIn compare_variables S3 generic function to produce a comparison summary. |
|||
| 47 | -6x | +
- tbl_df <- data.frame(mat_strings)+ #' |
||
| 48 | -6x | +
- body_rows <- seq(nlines_hdr + 1, nrow(tbl_df))+ #' @return |
||
| 49 | -6x | +
- mat_aligns <- apply(mat_aligns, 1:2, function(x) if (x == "left") 0 else if (x == "right") 1 else 0.5)+ #' * `s_compare()` returns output of [s_summary()] and comparisons versus the reference group in the form of p-values. |
||
| 50 |
-
+ #' |
|||
| 51 |
- # Apply indentation in first column+ #' @export |
|||
| 52 | -6x | +
- tbl_df[body_rows, 1] <- sapply(body_rows, function(i) {
+ s_compare <- function(x, |
||
| 53 | -42x | +
- ind_i <- mat_indent[i - nlines_hdr] * 4+ ...) {
|
||
| 54 | -18x | +9x |
- if (ind_i > 0) paste0(paste(rep(" ", ind_i), collapse = ""), tbl_df[i, 1]) else tbl_df[i, 1]
+ UseMethod("s_compare", x)
|
|
| 55 |
- })+ } |
|||
| 57 |
- # Get column widths+ #' @describeIn compare_variables Method for `numeric` class. This uses the standard t-test |
|||
| 58 | -6x | +
- if (is.null(colwidths)) {
+ #' to calculate the p-value. |
||
| 59 | -6x | +
- colwidths <- apply(tbl_df, 2, function(x) max(nchar(x))) + 1+ #' |
||
| 60 |
- }+ #' @method s_compare numeric |
|||
| 61 | -6x | +
- tot_width <- sum(colwidths) + lbl_col_padding+ #' |
||
| 62 |
-
+ #' @examples |
|||
| 63 | -6x | +
- if (length(shared_hdr_rows) > 0) {
+ #' # `s_compare.numeric` |
||
| 64 | -5x | +
- tbl_df <- tbl_df[-shared_hdr_rows, ]+ #' |
||
| 65 | -5x | +
- mat_aligns <- mat_aligns[-shared_hdr_rows, ]+ #' ## Usual case where both this and the reference group vector have more than 1 value. |
||
| 66 |
- }+ #' s_compare(rnorm(10, 5, 1), .ref_group = rnorm(5, -5, 1), .in_ref_col = FALSE) |
|||
| 67 |
-
+ #' |
|||
| 68 | -6x | +
- res <- ggplot(data = tbl_df) ++ #' ## If one group has not more than 1 value, then p-value is not calculated. |
||
| 69 | -6x | +
- theme_void() ++ #' s_compare(rnorm(10, 5, 1), .ref_group = 1, .in_ref_col = FALSE) |
||
| 70 | -6x | +
- scale_x_continuous(limits = c(0, tot_width)) ++ #' |
||
| 71 | -6x | +
- scale_y_continuous(limits = c(0, nrow(mat_strings))) ++ #' ## Empty numeric does not fail, it returns NA-filled items and no p-value. |
||
| 72 | -6x | +
- annotate(+ #' s_compare(numeric(), .ref_group = numeric(), .in_ref_col = FALSE) |
||
| 73 | -6x | +
- "segment",+ #' |
||
| 74 | -6x | +
- x = 0, xend = tot_width,+ #' @export |
||
| 75 | -6x | +
- y = nrow(mat_strings) - nlines_hdr + 0.5, yend = nrow(mat_strings) - nlines_hdr + 0.5+ s_compare.numeric <- function(x, ...) {
|
||
| 76 | -+ | 2x |
- )+ s_summary.numeric(x = x, compare_with_ref_group = TRUE, ...) |
|
| 77 |
-
+ } |
|||
| 78 |
- # If header content spans multiple columns, center over these columns+ |
|||
| 79 | -6x | +
- if (length(shared_hdr_rows) > 0) {
+ #' @describeIn compare_variables Method for `factor` class. This uses the chi-squared test |
||
| 80 | -5x | +
- mat_strings[shared_hdr_rows, ] <- trimws(mat_strings[shared_hdr_rows, ])+ #' to calculate the p-value. |
||
| 81 | -5x | +
- for (hr in shared_hdr_rows) {
+ #' |
||
| 82 | -6x | +
- hdr_lbls <- mat_strings[1:hr, mat_display[hr, -1]]+ #' @method s_compare factor |
||
| 83 | -6x | +
- hdr_lbls <- matrix(hdr_lbls[nzchar(hdr_lbls)], nrow = hr)+ #' |
||
| 84 | -6x | +
- for (idx_hl in seq_len(ncol(hdr_lbls))) {
+ #' @examples |
||
| 85 | -13x | +
- cur_lbl <- tail(hdr_lbls[, idx_hl], 1)+ #' # `s_compare.factor` |
||
| 86 | -13x | +
- which_cols <- if (hr == 1) {
+ #' |
||
| 87 | -9x | +
- which(mat_strings[hr, ] == hdr_lbls[idx_hl])+ #' ## Basic usage: |
||
| 88 | -13x | +
- } else { # for >2 col splits, only print labels for each unique combo of nested columns
+ #' x <- factor(c("a", "a", "b", "c", "a"))
|
||
| 89 | -4x | +
- which(+ #' y <- factor(c("a", "b", "c"))
|
||
| 90 | -4x | +
- apply(mat_strings[1:hr, ], 2, function(x) all(x == hdr_lbls[1:hr, idx_hl]))+ #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE) |
||
| 91 |
- )+ #' |
|||
| 92 |
- }+ #' ## Management of NA values. |
|||
| 93 | -13x | +
- line_pos <- c(+ #' x <- explicit_na(factor(c("a", "a", "b", "c", "a", NA, NA)))
|
||
| 94 | -13x | +
- sum(colwidths[1:(which_cols[1] - 1)]) + 1 + lbl_col_padding,+ #' y <- explicit_na(factor(c("a", "b", "c", NA)))
|
||
| 95 | -13x | +
- sum(colwidths[1:max(which_cols)]) - 1 + lbl_col_padding+ #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na_rm = TRUE) |
||
| 96 |
- )+ #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na_rm = FALSE) |
|||
| 97 |
-
+ #' |
|||
| 98 | -13x | +
- res <- res ++ #' @export |
||
| 99 | -13x | +
- annotate(+ s_compare.factor <- function(x, ...) {
|
||
| 100 | -13x | +3x |
- "text",+ s_summary.factor( |
|
| 101 | -13x | +3x |
- x = mean(line_pos),+ x = x, |
|
| 102 | -13x | +3x |
- y = nrow(mat_strings) + 1 - hr,+ compare_with_ref_group = TRUE, |
|
| 103 | -13x | +
- label = cur_lbl,+ ... |
||
| 104 | -13x | +
- size = fontsize / .pt+ ) |
||
| 105 |
- ) ++ } |
|||
| 106 | -13x | +
- annotate(+ |
||
| 107 | -13x | +
- "segment",+ #' @describeIn compare_variables Method for `character` class. This makes an automatic |
||
| 108 | -13x | +
- x = line_pos[1],+ #' conversion to `factor` (with a warning) and then forwards to the method for factors. |
||
| 109 | -13x | +
- xend = line_pos[2],+ #' |
||
| 110 | -13x | +
- y = nrow(mat_strings) - hr + 0.5,+ #' @method s_compare character |
||
| 111 | -13x | +
- yend = nrow(mat_strings) - hr + 0.5+ #' |
||
| 112 |
- )+ #' @examples |
|||
| 113 |
- }+ #' # `s_compare.character` |
|||
| 114 |
- }+ #' |
|||
| 115 |
- }+ #' ## Basic usage: |
|||
| 116 |
-
+ #' x <- c("a", "a", "b", "c", "a")
|
|||
| 117 |
- # Add table columns+ #' y <- c("a", "b", "c")
|
|||
| 118 | -6x | +
- for (i in seq_len(ncol(tbl_df))) {
+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, .var = "x", verbose = FALSE) |
||
| 119 | -40x | +
- res <- res + annotate(+ #' |
||
| 120 | -40x | +
- "text",+ #' ## Note that missing values handling can make a large difference: |
||
| 121 | -40x | +
- x = if (i == 1) 0 else sum(colwidths[1:i]) - 0.5 * colwidths[i] + lbl_col_padding,+ #' x <- c("a", "a", "b", "c", "a", NA)
|
||
| 122 | -40x | +
- y = rev(seq_len(nrow(tbl_df))),+ #' y <- c("a", "b", "c", rep(NA, 20))
|
||
| 123 | -40x | +
- label = tbl_df[, i],+ #' s_compare(x, |
||
| 124 | -40x | +
- hjust = mat_aligns[, i],+ #' .ref_group = y, .in_ref_col = FALSE, |
||
| 125 | -40x | +
- size = fontsize / .pt+ #' .var = "x", verbose = FALSE |
||
| 126 |
- )+ #' ) |
|||
| 127 |
- }+ #' s_compare(x, |
|||
| 128 |
-
+ #' .ref_group = y, .in_ref_col = FALSE, .var = "x", |
|||
| 129 | -6x | +
- res+ #' na.rm = FALSE, verbose = FALSE |
||
| 130 |
- }+ #' ) |
|||
| 131 |
-
+ #' |
|||
| 132 |
- #' Convert `data.frame` object to `ggplot` object+ #' @export |
|||
| 133 |
- #'+ s_compare.character <- function(x, ...) {
|
|||
| 134 | -+ | 1x |
- #' @description `r lifecycle::badge("experimental")`
+ s_summary.character( |
|
| 135 | -+ | 1x |
- #'+ x, |
|
| 136 | -+ | 1x |
- #' Given a `data.frame` object, performs basic conversion to a [ggplot2::ggplot()] object built using+ compare_with_ref_group = TRUE, |
|
| 137 |
- #' functions from the `ggplot2` package.+ ... |
|||
| 138 |
- #'+ ) |
|||
| 139 |
- #' @param df (`data.frame`)\cr a data frame.+ } |
|||
| 140 |
- #' @param colwidths (`numeric` or `NULL`)\cr a vector of column widths. Each element's position in+ |
|||
| 141 |
- #' `colwidths` corresponds to the column of `df` in the same position. If `NULL`, column widths+ #' @describeIn compare_variables Method for `logical` class. A chi-squared test |
|||
| 142 |
- #' are calculated according to maximum number of characters per column.+ #' is used. If missing values are not removed, then they are counted as `FALSE`. |
|||
| 143 |
- #' @param font_size (`numeric(1)`)\cr font size.+ #' |
|||
| 144 |
- #' @param col_labels (`flag`)\cr whether the column names (labels) of `df` should be used as the first row+ #' @method s_compare logical |
|||
| 145 |
- #' of the output table.+ #' |
|||
| 146 |
- #' @param col_lab_fontface (`string`)\cr font face to apply to the first row (of column labels+ #' @examples |
|||
| 147 |
- #' if `col_labels = TRUE`). Defaults to `"bold"`.+ #' # `s_compare.logical` |
|||
| 148 |
- #' @param hline (`flag`)\cr whether a horizontal line should be printed below the first row of the table.+ #' |
|||
| 149 |
- #' @param bg_fill (`string`)\cr table background fill color.+ #' ## Basic usage: |
|||
| 150 |
- #'+ #' x <- c(TRUE, FALSE, TRUE, TRUE) |
|||
| 151 |
- #' @return A `ggplot` object.+ #' y <- c(FALSE, FALSE, TRUE) |
|||
| 152 |
- #'+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE) |
|||
| 153 |
- #' @examples+ #' |
|||
| 154 |
- #' \dontrun{
+ #' ## Management of NA values. |
|||
| 155 |
- #' df2gg(head(iris, 5))+ #' x <- c(NA, TRUE, FALSE) |
|||
| 156 |
- #'+ #' y <- c(NA, NA, NA, NA, FALSE) |
|||
| 157 |
- #' df2gg(head(iris, 5), font_size = 15, colwidths = c(1, 1, 1, 1, 1))+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na_rm = TRUE) |
|||
| 158 |
- #' }+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na_rm = FALSE) |
|||
| 159 |
- #' @keywords internal+ #' |
|||
| 160 |
- df2gg <- function(df,+ #' @export+ |
+ |||
| 161 | ++ |
+ s_compare.logical <- function(x, ...) {
+ |
+ ||
| 162 | +3x | +
+ s_summary.logical(+ |
+ ||
| 163 | +3x | +
+ x = x,+ |
+ ||
| 164 | +3x | +
+ compare_with_ref_group = TRUE,+ |
+ ||
| 165 | ++ |
+ ...+ |
+ ||
| 166 | ++ |
+ )+ |
+ ||
| 167 | ++ |
+ }+ |
+ ||
| 168 | ++ | + + | +||
| 169 | ++ |
+ #' @describeIn compare_variables Layout-creating function which can take statistics function arguments+ |
+ ||
| 170 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+ ||
| 171 | ++ |
+ #'+ |
+ ||
| 172 | ++ |
+ #' @param ... additional arguments passed to `s_compare()`, including:+ |
+ ||
| 173 | ++ |
+ #' * `denom`: (`string`) choice of denominator. Options are `c("n", "N_col", "N_row")`. For factor variables, can
+ |
+ ||
| 174 | ++ |
+ #' only be `"n"` (number of values in this row and column intersection).+ |
+ ||
| 175 | ++ |
+ #' * `.N_row`: (`numeric(1)`) Row-wise N (row group count) for the group of observations being analyzed (i.e. with no+ |
+ ||
| 176 | ++ |
+ #' column-based subsetting).+ |
+ ||
| 177 | ++ |
+ #' * `.N_col`: (`numeric(1)`) Column-wise N (column count) for the full column being tabulated within.+ |
+ ||
| 178 | ++ |
+ #' * `verbose`: (`flag`) Whether additional warnings and messages should be printed. Mainly used to print out+ |
+ ||
| 179 | ++ |
+ #' information about factor casting. Defaults to `TRUE`. Used for `character`/`factor` variables only.+ |
+ ||
| 180 | ++ |
+ #' @param .indent_mods (named `integer`)\cr indent modifiers for the labels. Each element of the vector+ |
+ ||
| 181 | ++ |
+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ |
+ ||
| 182 | ++ |
+ #' for that statistic's row label.+ |
+ ||
| 183 | ++ |
+ #'+ |
+ ||
| 184 | ++ |
+ #' @return+ |
+ ||
| 185 | ++ |
+ #' * `compare_vars()` returns a layout object suitable for passing to further layouting functions,+ |
+ ||
| 186 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+ ||
| 187 | ++ |
+ #' the statistics from `s_compare()` to the table layout.+ |
+ ||
| 188 | ++ |
+ #'+ |
+ ||
| 189 | ++ |
+ #' @examples |
||
| 161 | +190 |
- colwidths = NULL,+ #' # `compare_vars()` in `rtables` pipelines |
||
| 162 | +191 |
- font_size = 10,+ #' |
||
| 163 | +192 |
- col_labels = TRUE,+ #' ## Default output within a `rtables` pipeline. |
||
| 164 | +193 |
- col_lab_fontface = "bold",+ #' lyt <- basic_table() %>% |
||
| 165 | +194 |
- hline = TRUE,+ #' split_cols_by("ARMCD", ref_group = "ARM B") %>%
|
||
| 166 | +195 |
- bg_fill = NULL) {
+ #' compare_vars(c("AGE", "SEX"))
|
||
| 167 | +196 |
- # convert to text+ #' build_table(lyt, tern_ex_adsl) |
||
| 168 | -19x | +|||
| 197 | +
- df <- as.data.frame(apply(df, 1:2, function(x) if (is.na(x)) "NA" else as.character(x)))+ #' |
|||
| 169 | +198 |
-
+ #' ## Select and format statistics output. |
||
| 170 | -19x | +|||
| 199 | +
- if (col_labels) {
+ #' lyt <- basic_table() %>% |
|||
| 171 | -10x | +|||
| 200 | +
- df <- as.matrix(df)+ #' split_cols_by("ARMCD", ref_group = "ARM C") %>%
|
|||
| 172 | -10x | +|||
| 201 | +
- df <- rbind(colnames(df), df)+ #' compare_vars( |
|||
| 173 | +202 |
- }+ #' vars = "AGE", |
||
| 174 | +203 |
-
+ #' .stats = c("mean_sd", "pval"),
|
||
| 175 | +204 |
- # Get column widths+ #' .formats = c(mean_sd = "xx.x, xx.x"), |
||
| 176 | -19x | +|||
| 205 | +
- if (is.null(colwidths)) {
+ #' .labels = c(mean_sd = "Mean, SD") |
|||
| 177 | -1x | +|||
| 206 | +
- colwidths <- apply(df, 2, function(x) max(nchar(x), na.rm = TRUE))+ #' ) |
|||
| 178 | +207 |
- }+ #' build_table(lyt, df = tern_ex_adsl) |
||
| 179 | -19x | +|||
| 208 | +
- tot_width <- sum(colwidths)+ #' |
|||
| 180 | +209 |
-
+ #' @export |
||
| 181 | -19x | +|||
| 210 | +
- res <- ggplot(data = df) ++ #' @order 2 |
|||
| 182 | -19x | +|||
| 211 | +
- theme_void() ++ compare_vars <- function(lyt, |
|||
| 183 | -19x | +|||
| 212 | +
- scale_x_continuous(limits = c(0, tot_width)) ++ vars, |
|||
| 184 | -19x | +|||
| 213 | +
- scale_y_continuous(limits = c(1, nrow(df)))+ var_labels = vars, |
|||
| 185 | +214 |
-
+ na_str = default_na_str(), |
||
| 186 | -9x | +|||
| 215 | +
- if (!is.null(bg_fill)) res <- res + theme(plot.background = element_rect(fill = bg_fill))+ nested = TRUE, |
|||
| 187 | +216 |
-
+ ..., |
||
| 188 | -19x | +|||
| 217 | +
- if (hline) {
+ na_rm = TRUE, |
|||
| 189 | -10x | +|||
| 218 | +
- res <- res ++ show_labels = "default", |
|||
| 190 | -10x | +|||
| 219 | +
- annotate(+ table_names = vars, |
|||
| 191 | -10x | +|||
| 220 | +
- "segment",+ section_div = NA_character_, |
|||
| 192 | -10x | +|||
| 221 | +
- x = 0 + 0.2 * colwidths[2], xend = tot_width - 0.1 * tail(colwidths, 1),+ .stats = c("n", "mean_sd", "count_fraction", "pval"),
|
|||
| 193 | -10x | +|||
| 222 | +
- y = nrow(df) - 0.5, yend = nrow(df) - 0.5+ .stat_names = NULL, |
|||
| 194 | +223 |
- )+ .formats = NULL, |
||
| 195 | +224 |
- }+ .labels = NULL, |
||
| 196 | +225 |
-
+ .indent_mods = NULL) {
|
||
| 197 | -19x | +226 | +4x |
- for (i in seq_len(ncol(df))) {
+ analyze_vars( |
| 198 | -86x | +227 | +4x |
- line_pos <- c(+ lyt = lyt, |
| 199 | -86x | +228 | +4x |
- if (i == 1) 0 else sum(colwidths[1:(i - 1)]),+ compare_with_ref_group = TRUE, |
| 200 | -86x | -
- sum(colwidths[1:i])- |
- ||
| 201 | -+ | 229 | +4x |
- )+ vars = vars, |
| 202 | -86x | +230 | +4x |
- res <- res ++ var_labels = var_labels, |
| 203 | -86x | +231 | +4x |
- annotate(+ na_str = na_str, |
| 204 | -86x | +232 | +4x |
- "text",+ nested = nested, |
| 205 | -86x | +233 | +4x |
- x = mean(line_pos),+ na_rm = na_rm, |
| 206 | -86x | +234 | +4x |
- y = rev(seq_len(nrow(df))),+ show_labels = show_labels, |
| 207 | -86x | +235 | +4x |
- label = df[, i],+ table_names = table_names, |
| 208 | -86x | +236 | +4x |
- size = font_size / .pt,+ section_div = section_div, |
| 209 | -86x | +237 | +4x |
- fontface = if (col_labels) {
+ .stats = .stats, |
| 210 | -32x | -
- c(col_lab_fontface, rep("plain", nrow(df) - 1))
- |
- ||
| 211 | -+ | 238 | +4x |
- } else {
+ .stat_names = .stat_names, |
| 212 | -54x | +239 | +4x |
- rep("plain", nrow(df))
+ .formats = .formats, |
| 213 | -+ | |||
| 240 | +4x |
- }+ .labels = .labels, |
||
| 214 | -+ | |||
| 241 | +4x |
- )+ .indent_mods = .indent_mods, |
||
| 215 | +242 |
- }+ ... |
||
| 216 | +243 | - - | -||
| 217 | -19x | -
- res+ ) |
||
| 218 | +244 |
}@@ -178118,14 +179978,14 @@ tern coverage - 95.59% |
| 1 |
- #' Subgroup treatment effect pattern (STEP) fit for survival outcome+ #' Count patient events in columns |
|||
| 5 |
- #' This fits the subgroup treatment effect pattern (STEP) models for a survival outcome. The treatment arm+ #' The summarize function [summarize_patients_events_in_cols()] creates a layout element to summarize patient |
|||
| 6 |
- #' variable must have exactly 2 levels, where the first one is taken as reference and the estimated+ #' event counts in columns. |
|||
| 7 |
- #' hazard ratios are for the comparison of the second level vs. the first one.+ #' |
|||
| 8 |
- #'+ #' This function analyzes the elements (events) supplied via the `filters_list` parameter and returns a row |
|||
| 9 |
- #' The model which is fit is:+ #' with counts of number of patients for each event as well as the total numbers of patients and events. |
|||
| 10 |
- #'+ #' The `id` variable is used to indicate unique subject identifiers (defaults to `USUBJID`). |
|||
| 11 |
- #' `Surv(time, event) ~ arm * poly(biomarker, degree) + covariates + strata(strata)`+ #' |
|||
| 12 |
- #'+ #' If there are multiple occurrences of the same event recorded for a patient, the event is only counted once. |
|||
| 13 |
- #' where `degree` is specified by `control_step()`.+ #' |
|||
| 14 |
- #'+ #' @inheritParams argument_convention |
|||
| 15 |
- #' @inheritParams argument_convention+ #' @param filters_list (named `list` of `character`)\cr list where each element in this list describes one |
|||
| 16 |
- #' @param variables (named `list` of `character`)\cr list of analysis variables: needs `time`, `event`,+ #' type of event describe by filters, in the same format as [s_count_patients_with_event()]. |
|||
| 17 |
- #' `arm`, `biomarker`, and optional `covariates` and `strata`.+ #' If it has a label, then this will be used for the column title. |
|||
| 18 |
- #' @param control (named `list`)\cr combined control list from [control_step()] and [control_coxph()].+ #' @param empty_stats (`character`)\cr optional names of the statistics that should be returned empty such |
|||
| 19 |
- #'+ #' that corresponding table cells will stay blank. |
|||
| 20 |
- #' @return A matrix of class `step`. The first part of the columns describe the subgroup intervals used+ #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will |
|||
| 21 |
- #' for the biomarker variable, including where the center of the intervals are and their bounds. The+ #' be used as label. |
|||
| 22 |
- #' second part of the columns contain the estimates for the treatment arm comparison.+ #' @param .stats (`character`)\cr statistics to select for the table. |
|||
| 24 |
- #' @note For the default degree 0 the `biomarker` variable is not included in the model.+ #' In addition to any statistics added using `filters_list`, statistic options are: |
|||
| 25 |
- #'+ #' ``r shQuote(get_stats("summarize_patients_events_in_cols"), type = "sh")``
|
|||
| 26 |
- #' @seealso [control_step()] and [control_coxph()] for the available customization options.+ #' |
|||
| 27 |
- #'+ #' @name count_patients_events_in_cols |
|||
| 28 |
- #' @examples+ #' @order 1 |
|||
| 29 |
- #' # Testing dataset with just two treatment arms.+ NULL |
|||
| 30 |
- #' library(dplyr)+ |
|||
| 31 |
- #'+ #' @describeIn count_patients_events_in_cols Statistics function which counts numbers of patients and multiple |
|||
| 32 |
- #' adtte_f <- tern_ex_adtte %>%+ #' events defined by filters. Used as analysis function `afun` in `summarize_patients_events_in_cols()`. |
|||
| 33 |
- #' filter(+ #' |
|||
| 34 |
- #' PARAMCD == "OS",+ #' @return |
|||
| 35 |
- #' ARM %in% c("B: Placebo", "A: Drug X")
+ #' * `s_count_patients_and_multiple_events()` returns a list with the statistics: |
|||
| 36 |
- #' ) %>%+ #' - `unique`: number of unique patients in `df`. |
|||
| 37 |
- #' mutate(+ #' - `all`: number of rows in `df`. |
|||
| 38 |
- #' # Reorder levels of ARM to display reference arm before treatment arm.+ #' - one element with the same name as in `filters_list`: number of rows in `df`, |
|||
| 39 |
- #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")),+ #' i.e. events, fulfilling the filter condition. |
|||
| 40 |
- #' is_event = CNSR == 0+ #' |
|||
| 41 |
- #' )+ #' @keywords internal |
|||
| 42 |
- #' labels <- c("ARM" = "Treatment Arm", "is_event" = "Event Flag")
+ s_count_patients_and_multiple_events <- function(df, # nolint |
|||
| 43 |
- #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ id, |
|||
| 44 |
- #'+ filters_list, |
|||
| 45 |
- #' variables <- list(+ empty_stats = character(), |
|||
| 46 |
- #' arm = "ARM",+ labelstr = "", |
|||
| 47 |
- #' biomarker = "BMRKR1",+ custom_label = NULL) {
|
|||
| 48 | -+ | 9x |
- #' covariates = c("AGE", "BMRKR2"),
+ checkmate::assert_list(filters_list, names = "named") |
|
| 49 | -+ | 9x |
- #' event = "is_event",+ checkmate::assert_data_frame(df) |
|
| 50 | -+ | 9x |
- #' time = "AVAL"+ checkmate::assert_string(id) |
|
| 51 | -+ | 9x |
- #' )+ checkmate::assert_disjunct(c("unique", "all"), names(filters_list))
|
|
| 52 | -+ | 9x |
- #'+ checkmate::assert_character(empty_stats) |
|
| 53 | -+ | 9x |
- #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup.+ checkmate::assert_string(labelstr) |
|
| 54 | -+ | 9x |
- #' step_matrix <- fit_survival_step(+ checkmate::assert_string(custom_label, null.ok = TRUE) |
|
| 55 |
- #' variables = variables,+ |
|||
| 56 |
- #' data = adtte_f+ # Below we want to count each row in `df` once, therefore introducing this helper index column. |
|||
| 57 | -+ | 9x |
- #' )+ df$.row_index <- as.character(seq_len(nrow(df))) |
|
| 58 | -+ | 9x |
- #' dim(step_matrix)+ y <- list() |
|
| 59 | -+ | 9x |
- #' head(step_matrix)+ row_label <- if (labelstr != "") {
|
|
| 60 | -+ | ! |
- #'+ labelstr |
|
| 61 | -+ | 9x |
- #' # Specify different polynomial degree for the biomarker interaction to use more flexible local+ } else if (!is.null(custom_label)) {
|
|
| 62 | -+ | 2x |
- #' # models. Or specify different Cox regression options.+ custom_label |
|
| 63 |
- #' step_matrix2 <- fit_survival_step(+ } else {
|
|||
| 64 | -+ | 7x |
- #' variables = variables,+ "counts" |
|
| 65 |
- #' data = adtte_f,+ } |
|||
| 66 | -+ | 9x |
- #' control = c(control_coxph(conf_level = 0.9), control_step(degree = 2))+ y$unique <- formatters::with_label( |
|
| 67 | -+ | 9x |
- #' )+ s_num_patients_content(df = df, .N_col = 1, .var = id, required = NULL)$unique[1L], |
|
| 68 | -+ | 9x |
- #'+ row_label |
|
| 69 |
- #' # Use a global model with cubic interaction and only 5 points.+ ) |
|||
| 70 | -+ | 9x |
- #' step_matrix3 <- fit_survival_step(+ y$all <- formatters::with_label( |
|
| 71 | -+ | 9x |
- #' variables = variables,+ nrow(df), |
|
| 72 | -+ | 9x |
- #' data = adtte_f,+ row_label |
|
| 73 |
- #' control = c(control_coxph(), control_step(bandwidth = NULL, degree = 3, num_points = 5L))+ ) |
|||
| 74 | -+ | 9x |
- #' )+ events <- Map( |
|
| 75 | -+ | 9x |
- #'+ function(filters) {
|
|
| 76 | -+ | 25x |
- #' @export+ formatters::with_label( |
|
| 77 | -+ | 25x |
- fit_survival_step <- function(variables,+ s_count_patients_with_event(df = df, .var = ".row_index", filters = filters, .N_col = 1, .N_row = 1)$count, |
|
| 78 | -+ | 25x |
- data,+ row_label |
|
| 79 |
- control = c(control_step(), control_coxph())) {
+ ) |
|||
| 80 | -4x | +
- checkmate::assert_list(control)+ }, |
||
| 81 | -4x | +9x |
- assert_df_with_variables(data, variables)+ filters = filters_list |
|
| 82 | -4x | +
- data <- data[!is.na(data[[variables$biomarker]]), ]+ ) |
||
| 83 | -4x | +9x |
- window_sel <- h_step_window(x = data[[variables$biomarker]], control = control)+ y_complete <- c(y, events) |
|
| 84 | -4x | +9x |
- interval_center <- window_sel$interval[, "Interval Center"]+ y <- if (length(empty_stats) > 0) {
|
|
| 85 | -4x | +3x |
- form <- h_step_survival_formula(variables = variables, control = control)+ y_reduced <- y_complete |
|
| 86 | -4x | +3x |
- estimates <- if (is.null(control$bandwidth)) {
+ for (stat in intersect(names(y_complete), empty_stats)) {
|
|
| 87 | -1x | -
- h_step_survival_est(- |
- ||
| 88 | -1x | -
- formula = form,- |
- ||
| 89 | -1x | -
- data = data,- |
- ||
| 90 | -1x | -
- variables = variables,- |
- ||
| 91 | -1x | -
- x = interval_center,- |
- ||
| 92 | -1x | -
- control = control- |
- ||
| 93 | -+ | 4x |
- )+ y_reduced[[stat]] <- formatters::with_label(character(), obj_label(y_reduced[[stat]])) |
|
| 94 | +88 |
- } else {
- |
- ||
| 95 | -3x | -
- tmp <- mapply(- |
- ||
| 96 | -3x | -
- FUN = h_step_survival_est,- |
- ||
| 97 | -3x | -
- x = interval_center,- |
- ||
| 98 | -3x | -
- subset = as.list(as.data.frame(window_sel$sel)),- |
- ||
| 99 | -3x | -
- MoreArgs = list(- |
- ||
| 100 | -3x | -
- formula = form,- |
- ||
| 101 | -3x | -
- data = data,- |
- ||
| 102 | -3x | -
- variables = variables,+ } |
||
| 103 | +89 | 3x |
- control = control- |
- |
| 104 | -- |
- )- |
- ||
| 105 | -- |
- )+ y_reduced |
||
| 106 | +90 |
- # Maybe we find a more elegant solution than this.- |
- ||
| 107 | -3x | -
- rownames(tmp) <- c("n", "events", "loghr", "se", "ci_lower", "ci_upper")
+ } else {
|
||
| 108 | -3x | +91 | +6x |
- t(tmp)+ y_complete |
| 109 | +92 |
} |
||
| 110 | -4x | -
- result <- cbind(window_sel$interval, estimates)- |
- ||
| 111 | -4x | -
- structure(- |
- ||
| 112 | -4x | -
- result,- |
- ||
| 113 | -4x | -
- class = c("step", "matrix"),
- |
- ||
| 114 | -4x | -
- variables = variables,- |
- ||
| 115 | -4x | -
- control = control- |
- ||
| 116 | -+ | 93 | +9x |
- )+ y |
| 117 | +94 |
} |
| 1 | -- |
- #' Analyze a pairwise Cox-PH model- |
- ||
| 2 | -- |
- #'- |
- ||
| 3 | +95 |
- #' @description `r lifecycle::badge("stable")`
+
|
||
| 4 | +96 |
- #'+ #' @describeIn count_patients_events_in_cols Layout-creating function which can take statistics function |
||
| 5 | +97 |
- #' The analyze function [coxph_pairwise()] creates a layout element to analyze a pairwise Cox-PH model.+ #' arguments and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 6 | +98 |
#' |
||
| 7 | -- |
- #' This function can return statistics including p-value, hazard ratio (HR), and HR confidence intervals from both- |
- ||
| 8 | +99 |
- #' stratified and unstratified Cox-PH models. The variable(s) to be analyzed is specified via the `vars` argument and+ #' @param col_split (`flag`)\cr whether the columns should be split. |
||
| 9 | +100 |
- #' any stratification factors via the `strata` argument.+ #' Set to `FALSE` when the required column split has been done already earlier in the layout pipe. |
||
| 10 | +101 |
#' |
||
| 11 | -- |
- #' @inheritParams argument_convention- |
- ||
| 12 | -- |
- #' @inheritParams s_surv_time- |
- ||
| 13 | -- |
- #' @param strata (`character` or `NULL`)\cr variable names indicating stratification factors.- |
- ||
| 14 | -- |
- #' @param strat `r lifecycle::badge("deprecated")` Please use the `strata` argument instead.
- |
- ||
| 15 | -- |
- #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function- |
- ||
| 16 | -- |
- #' [control_coxph()]. Some possible parameter options are:- |
- ||
| 17 | -- |
- #' * `pval_method` (`string`)\cr p-value method for testing the null hypothesis that hazard ratio = 1. Default- |
- ||
| 18 | -- |
- #' method is `"log-rank"` which comes from [survival::survdiff()], can also be set to `"wald"` or `"likelihood"`- |
- ||
| 19 | -- |
- #' (from [survival::coxph()]).- |
- ||
| 20 | -- |
- #' * `ties` (`string`)\cr specifying the method for tie handling. Default is `"efron"`,- |
- ||
| 21 | -- |
- #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()].- |
- ||
| 22 | +102 |
- #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR.+ #' @return |
||
| 23 | +103 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' * `summarize_patients_events_in_cols()` returns a layout object suitable for passing to further layouting functions, |
||
| 24 | +104 |
- #'+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows |
||
| 25 | +105 |
- #' Options are: ``r shQuote(get_stats("coxph_pairwise"))``
+ #' containing the statistics from `s_count_patients_and_multiple_events()` to the table layout. |
||
| 26 | +106 |
#' |
||
| 27 | -- |
- #' @name survival_coxph_pairwise- |
- ||
| 28 | -- |
- #' @order 1- |
- ||
| 29 | -- |
- NULL- |
- ||
| 30 | +107 |
-
+ #' @examples |
||
| 31 | +108 |
- #' @describeIn survival_coxph_pairwise Statistics function which analyzes HR, CIs of HR, and p-value of a Cox-PH model.+ #' df <- data.frame( |
||
| 32 | +109 |
- #'+ #' USUBJID = rep(c("id1", "id2", "id3", "id4"), c(2, 3, 1, 1)),
|
||
| 33 | +110 |
- #' @return+ #' ARM = c("A", "A", "B", "B", "B", "B", "A"),
|
||
| 34 | +111 |
- #' * `s_coxph_pairwise()` returns the statistics:+ #' AESER = rep("Y", 7),
|
||
| 35 | +112 |
- #' * `pvalue`: p-value to test the null hypothesis that hazard ratio = 1.+ #' AESDTH = c("Y", "Y", "N", "Y", "Y", "N", "N"),
|
||
| 36 | +113 |
- #' * `hr`: Hazard ratio.+ #' AEREL = c("Y", "Y", "N", "Y", "Y", "N", "Y"),
|
||
| 37 | +114 |
- #' * `hr_ci`: Confidence interval for hazard ratio.+ #' AEDECOD = c("A", "A", "A", "B", "B", "C", "D"),
|
||
| 38 | +115 |
- #' * `n_tot`: Total number of observations.+ #' AEBODSYS = rep(c("SOC1", "SOC2", "SOC3"), c(3, 3, 1))
|
||
| 39 | +116 |
- #' * `n_tot_events`: Total number of events.+ #' ) |
||
| 40 | +117 |
#' |
||
| 41 | +118 |
- #' @keywords internal+ #' # `summarize_patients_events_in_cols()` |
||
| 42 | +119 |
- s_coxph_pairwise <- function(df,+ #' basic_table() %>% |
||
| 43 | +120 |
- .ref_group,+ #' summarize_patients_events_in_cols( |
||
| 44 | +121 |
- .in_ref_col,+ #' filters_list = list( |
||
| 45 | +122 |
- .var,+ #' related = formatters::with_label(c(AEREL = "Y"), "Events (Related)"), |
||
| 46 | +123 |
- is_event,+ #' fatal = c(AESDTH = "Y"), |
||
| 47 | +124 |
- strata = NULL,+ #' fatal_related = c(AEREL = "Y", AESDTH = "Y") |
||
| 48 | +125 |
- strat = lifecycle::deprecated(),+ #' ), |
||
| 49 | +126 |
- control = control_coxph()) {
- |
- ||
| 50 | -92x | -
- if (lifecycle::is_present(strat)) {
+ #' custom_label = "%s Total number of patients and events" |
||
| 51 | -! | +|||
| 127 | +
- lifecycle::deprecate_warn("0.9.4", "s_coxph_pairwise(strat)", "s_coxph_pairwise(strata)")
+ #' ) %>% |
|||
| 52 | -! | +|||
| 128 | +
- strata <- strat+ #' build_table(df) |
|||
| 53 | +129 |
- }+ #' |
||
| 54 | +130 |
-
+ #' @export |
||
| 55 | -92x | +|||
| 131 | +
- checkmate::assert_string(.var)+ #' @order 2 |
|||
| 56 | -92x | +|||
| 132 | +
- checkmate::assert_numeric(df[[.var]])+ summarize_patients_events_in_cols <- function(lyt, # nolint |
|||
| 57 | -92x | +|||
| 133 | +
- checkmate::assert_logical(df[[is_event]])+ id = "USUBJID", |
|||
| 58 | -92x | +|||
| 134 | +
- assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ filters_list = list(), |
|||
| 59 | -92x | +|||
| 135 | +
- pval_method <- control$pval_method+ empty_stats = character(), |
|||
| 60 | -92x | +|||
| 136 | +
- ties <- control$ties+ na_str = default_na_str(), |
|||
| 61 | -92x | +|||
| 137 | +
- conf_level <- control$conf_level+ ..., |
|||
| 62 | +138 |
-
+ .stats = c( |
||
| 63 | -92x | +|||
| 139 | +
- if (.in_ref_col) {
+ "unique", |
|||
| 64 | -! | +|||
| 140 | +
- return(+ "all", |
|||
| 65 | -! | +|||
| 141 | +
- list(+ names(filters_list) |
|||
| 66 | -! | +|||
| 142 | +
- pvalue = formatters::with_label("", paste0("p-value (", pval_method, ")")),
+ ), |
|||
| 67 | -! | +|||
| 143 | +
- hr = formatters::with_label("", "Hazard Ratio"),
+ .labels = c( |
|||
| 68 | -! | +|||
| 144 | +
- hr_ci = formatters::with_label("", f_conf_level(conf_level)),
+ unique = "Patients (All)", |
|||
| 69 | -! | +|||
| 145 | +
- hr_ci_3d = formatters::with_label("", paste0("Hazard Ratio (", f_conf_level(conf_level), ")")),
+ all = "Events (All)", |
|||
| 70 | -! | +|||
| 146 | +
- n_tot = formatters::with_label("", "Total n"),
+ labels_or_names(filters_list) |
|||
| 71 | -! | +|||
| 147 | +
- n_tot_events = formatters::with_label("", "Total events")
+ ), |
|||
| 72 | +148 |
- )+ col_split = TRUE) {
|
||
| 73 | -+ | |||
| 149 | +2x |
- )+ extra_args <- list(id = id, filters_list = filters_list, empty_stats = empty_stats, ...) |
||
| 74 | +150 |
- }+ |
||
| 75 | -92x | +151 | +2x |
- data <- rbind(.ref_group, df)+ afun_list <- Map( |
| 76 | -92x | -
- group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
- |
- ||
| 77 | -+ | 152 | +2x |
-
+ function(stat) {
|
| 78 | -92x | +153 | +7x |
- df_cox <- data.frame(+ make_afun( |
| 79 | -92x | +154 | +7x |
- tte = data[[.var]],+ s_count_patients_and_multiple_events, |
| 80 | -92x | +155 | +7x |
- is_event = data[[is_event]],+ .stats = stat, |
| 81 | -92x | +156 | +7x |
- arm = group+ .formats = "xx." |
| 82 | +157 |
- )+ ) |
||
| 83 | -92x | +|||
| 158 | +
- if (is.null(strata)) {
+ }, |
|||
| 84 | -83x | +159 | +2x |
- formula_cox <- survival::Surv(tte, is_event) ~ arm+ stat = .stats |
| 85 | +160 |
- } else {
+ ) |
||
| 86 | -9x | +161 | +2x |
- formula_cox <- stats::as.formula(+ if (col_split) {
|
| 87 | -9x | +162 | +2x |
- paste0(+ lyt <- split_cols_by_multivar( |
| 88 | -9x | +163 | +2x |
- "survival::Surv(tte, is_event) ~ arm + strata(",
+ lyt = lyt, |
| 89 | -9x | +164 | +2x |
- paste(strata, collapse = ","),+ vars = rep(id, length(.stats)), |
| 90 | -+ | |||
| 165 | +2x |
- ")"+ varlabels = .labels[.stats] |
||
| 91 | +166 |
- )+ ) |
||
| 92 | +167 |
- )+ } |
||
| 93 | -9x | -
- df_cox <- cbind(df_cox, data[strata])- |
- ||
| 94 | -+ | 168 | +2x |
- }+ summarize_row_groups( |
| 95 | -92x | +169 | +2x |
- cox_fit <- survival::coxph(+ lyt = lyt, |
| 96 | -92x | +170 | +2x |
- formula = formula_cox,+ cfun = afun_list, |
| 97 | -92x | +171 | +2x |
- data = df_cox,+ na_str = na_str, |
| 98 | -92x | +172 | +2x |
- ties = ties+ extra_args = extra_args |
| 99 | +173 |
) |
||
| 100 | -92x | -
- sum_cox <- summary(cox_fit, conf.int = conf_level, extend = TRUE)- |
- ||
| 101 | -92x | -
- orginal_survdiff <- survival::survdiff(- |
- ||
| 102 | -92x | -
- formula_cox,- |
- ||
| 103 | -92x | +|||
| 174 | +
- data = df_cox+ } |
| 104 | +1 |
- )+ #' Subgroup treatment effect pattern (STEP) fit for survival outcome |
||
| 105 | -92x | +|||
| 2 | +
- log_rank_pvalue <- 1 - pchisq(orginal_survdiff$chisq, length(orginal_survdiff$n) - 1)+ #' |
|||
| 106 | +3 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 107 | -92x | +|||
| 4 | +
- pval <- switch(pval_method,+ #' |
|||
| 108 | -92x | +|||
| 5 | +
- "wald" = sum_cox$waldtest["pvalue"],+ #' This fits the subgroup treatment effect pattern (STEP) models for a survival outcome. The treatment arm |
|||
| 109 | -92x | +|||
| 6 | +
- "log-rank" = log_rank_pvalue, # pvalue from original log-rank test survival::survdiff()+ #' variable must have exactly 2 levels, where the first one is taken as reference and the estimated |
|||
| 110 | -92x | +|||
| 7 | +
- "likelihood" = sum_cox$logtest["pvalue"]+ #' hazard ratios are for the comparison of the second level vs. the first one. |
|||
| 111 | +8 |
- )+ #' |
||
| 112 | -92x | +|||
| 9 | +
- list(+ #' The model which is fit is: |
|||
| 113 | -92x | +|||
| 10 | +
- pvalue = formatters::with_label(unname(pval), paste0("p-value (", pval_method, ")")),
+ #' |
|||
| 114 | -92x | +|||
| 11 | +
- hr = formatters::with_label(sum_cox$conf.int[1, 1], "Hazard Ratio"),+ #' `Surv(time, event) ~ arm * poly(biomarker, degree) + covariates + strata(strata)` |
|||
| 115 | -92x | +|||
| 12 | +
- hr_ci = formatters::with_label(unname(sum_cox$conf.int[1, 3:4]), f_conf_level(conf_level)),+ #' |
|||
| 116 | -92x | +|||
| 13 | +
- hr_ci_3d = formatters::with_label(+ #' where `degree` is specified by `control_step()`. |
|||
| 117 | -92x | +|||
| 14 | +
- c(sum_cox$conf.int[1, 1], unname(sum_cox$conf.int[1, 3:4])),+ #' |
|||
| 118 | -92x | +|||
| 15 | +
- paste0("Hazard Ratio (", f_conf_level(conf_level), ")")
+ #' @inheritParams argument_convention |
|||
| 119 | +16 |
- ),+ #' @param variables (named `list` of `character`)\cr list of analysis variables: needs `time`, `event`, |
||
| 120 | -92x | +|||
| 17 | +
- n_tot = formatters::with_label(sum_cox$n, "Total n"),+ #' `arm`, `biomarker`, and optional `covariates` and `strata`. |
|||
| 121 | -92x | +|||
| 18 | +
- n_tot_events = formatters::with_label(sum_cox$nevent, "Total events")+ #' @param control (named `list`)\cr combined control list from [control_step()] and [control_coxph()]. |
|||
| 122 | +19 |
- )+ #' |
||
| 123 | +20 |
- }+ #' @return A matrix of class `step`. The first part of the columns describe the subgroup intervals used |
||
| 124 | +21 |
-
+ #' for the biomarker variable, including where the center of the intervals are and their bounds. The |
||
| 125 | +22 |
- #' @describeIn survival_coxph_pairwise Formatted analysis function which is used as `afun` in `coxph_pairwise()`.+ #' second part of the columns contain the estimates for the treatment arm comparison. |
||
| 126 | +23 |
#' |
||
| 127 | +24 |
- #' @return+ #' @note For the default degree 0 the `biomarker` variable is not included in the model. |
||
| 128 | +25 |
- #' * `a_coxph_pairwise()` returns the corresponding list with formatted [rtables::CellValue()].+ #' |
||
| 129 | +26 |
- #'+ #' @seealso [control_step()] and [control_coxph()] for the available customization options. |
||
| 130 | +27 |
- #' @keywords internal+ #' |
||
| 131 | +28 |
- a_coxph_pairwise <- make_afun(+ #' @examples |
||
| 132 | +29 |
- s_coxph_pairwise,+ #' # Testing dataset with just two treatment arms. |
||
| 133 | +30 |
- .indent_mods = c(pvalue = 0L, hr = 0L, hr_ci = 1L, n_tot = 0L, n_tot_events = 0L, hr_ci_3d = 0L),+ #' library(dplyr) |
||
| 134 | +31 |
- .formats = c(+ #' |
||
| 135 | +32 |
- pvalue = "x.xxxx | (<0.0001)",+ #' adtte_f <- tern_ex_adtte %>% |
||
| 136 | +33 |
- hr = "xx.xx",+ #' filter( |
||
| 137 | +34 |
- hr_ci = "(xx.xx, xx.xx)",+ #' PARAMCD == "OS", |
||
| 138 | +35 |
- hr_ci_3d = "xx.xx (xx.xx - xx.xx)",+ #' ARM %in% c("B: Placebo", "A: Drug X")
|
||
| 139 | +36 |
- n_tot = "xx.xx",+ #' ) %>% |
||
| 140 | +37 |
- n_tot_events = "xx.xx"+ #' mutate( |
||
| 141 | +38 |
- )+ #' # Reorder levels of ARM to display reference arm before treatment arm. |
||
| 142 | +39 |
- )+ #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")), |
||
| 143 | +40 |
-
+ #' is_event = CNSR == 0 |
||
| 144 | +41 |
- #' @describeIn survival_coxph_pairwise Layout-creating function which can take statistics function arguments+ #' ) |
||
| 145 | +42 |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ #' labels <- c("ARM" = "Treatment Arm", "is_event" = "Event Flag")
|
||
| 146 | +43 |
- #'+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels |
||
| 147 | +44 |
- #' @return+ #' |
||
| 148 | +45 |
- #' * `coxph_pairwise()` returns a layout object suitable for passing to further layouting functions,+ #' variables <- list( |
||
| 149 | +46 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ #' arm = "ARM", |
||
| 150 | +47 |
- #' the statistics from `s_coxph_pairwise()` to the table layout.+ #' biomarker = "BMRKR1", |
||
| 151 | +48 |
- #'+ #' covariates = c("AGE", "BMRKR2"),
|
||
| 152 | +49 |
- #' @examples+ #' event = "is_event", |
||
| 153 | +50 |
- #' library(dplyr)+ #' time = "AVAL" |
||
| 154 | +51 |
- #'+ #' ) |
||
| 155 | +52 |
- #' adtte_f <- tern_ex_adtte %>%+ #' |
||
| 156 | +53 |
- #' filter(PARAMCD == "OS") %>%+ #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup. |
||
| 157 | +54 |
- #' mutate(is_event = CNSR == 0)+ #' step_matrix <- fit_survival_step( |
||
| 158 | +55 |
- #'+ #' variables = variables, |
||
| 159 | +56 |
- #' df <- adtte_f %>% filter(ARMCD == "ARM A")+ #' data = adtte_f |
||
| 160 | +57 |
- #' df_ref_group <- adtte_f %>% filter(ARMCD == "ARM B")+ #' ) |
||
| 161 | +58 |
- #'+ #' dim(step_matrix) |
||
| 162 | +59 |
- #' basic_table() %>%+ #' head(step_matrix) |
||
| 163 | +60 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ #' |
||
| 164 | +61 |
- #' add_colcounts() %>%+ #' # Specify different polynomial degree for the biomarker interaction to use more flexible local |
||
| 165 | +62 |
- #' coxph_pairwise(+ #' # models. Or specify different Cox regression options. |
||
| 166 | +63 |
- #' vars = "AVAL",+ #' step_matrix2 <- fit_survival_step( |
||
| 167 | +64 |
- #' is_event = "is_event",+ #' variables = variables, |
||
| 168 | +65 |
- #' var_labels = "Unstratified Analysis"+ #' data = adtte_f, |
||
| 169 | +66 |
- #' ) %>%+ #' control = c(control_coxph(conf_level = 0.9), control_step(degree = 2)) |
||
| 170 | +67 |
- #' build_table(df = adtte_f)+ #' ) |
||
| 171 | +68 |
#' |
||
| 172 | +69 |
- #' basic_table() %>%+ #' # Use a global model with cubic interaction and only 5 points. |
||
| 173 | +70 |
- #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ #' step_matrix3 <- fit_survival_step( |
||
| 174 | +71 |
- #' add_colcounts() %>%+ #' variables = variables, |
||
| 175 | +72 |
- #' coxph_pairwise(+ #' data = adtte_f, |
||
| 176 | +73 |
- #' vars = "AVAL",+ #' control = c(control_coxph(), control_step(bandwidth = NULL, degree = 3, num_points = 5L)) |
||
| 177 | +74 |
- #' is_event = "is_event",+ #' ) |
||
| 178 | +75 |
- #' var_labels = "Stratified Analysis",+ #' |
||
| 179 | +76 |
- #' strata = "SEX",+ #' @export |
||
| 180 | +77 |
- #' control = control_coxph(pval_method = "wald")+ fit_survival_step <- function(variables, |
||
| 181 | +78 |
- #' ) %>%+ data, |
||
| 182 | +79 |
- #' build_table(df = adtte_f)+ control = c(control_step(), control_coxph())) {
|
||
| 183 | -+ | |||
| 80 | +4x |
- #'+ checkmate::assert_list(control) |
||
| 184 | -+ | |||
| 81 | +4x |
- #' @export+ assert_df_with_variables(data, variables) |
||
| 185 | -+ | |||
| 82 | +4x |
- #' @order 2+ data <- data[!is.na(data[[variables$biomarker]]), ] |
||
| 186 | -+ | |||
| 83 | +4x |
- coxph_pairwise <- function(lyt,+ window_sel <- h_step_window(x = data[[variables$biomarker]], control = control) |
||
| 187 | -+ | |||
| 84 | +4x |
- vars,+ interval_center <- window_sel$interval[, "Interval Center"] |
||
| 188 | -+ | |||
| 85 | +4x |
- strata = NULL,+ form <- h_step_survival_formula(variables = variables, control = control) |
||
| 189 | -+ | |||
| 86 | +4x |
- control = control_coxph(),+ estimates <- if (is.null(control$bandwidth)) {
|
||
| 190 | -+ | |||
| 87 | +1x |
- na_str = default_na_str(),+ h_step_survival_est( |
||
| 191 | -+ | |||
| 88 | +1x |
- nested = TRUE,+ formula = form, |
||
| 192 | -+ | |||
| 89 | +1x |
- ...,+ data = data, |
||
| 193 | -+ | |||
| 90 | +1x |
- var_labels = "CoxPH",+ variables = variables, |
||
| 194 | -+ | |||
| 91 | +1x |
- show_labels = "visible",+ x = interval_center, |
||
| 195 | -+ | |||
| 92 | +1x |
- table_names = vars,+ control = control |
||
| 196 | +93 |
- .stats = c("pvalue", "hr", "hr_ci"),
+ ) |
||
| 197 | +94 |
- .formats = NULL,+ } else {
|
||
| 198 | -+ | |||
| 95 | +3x |
- .labels = NULL,+ tmp <- mapply( |
||
| 199 | -+ | |||
| 96 | +3x |
- .indent_mods = NULL) {
+ FUN = h_step_survival_est, |
||
| 200 | -5x | +97 | +3x |
- extra_args <- list(strata = strata, control = control, ...)+ x = interval_center, |
| 201 | -+ | |||
| 98 | +3x |
-
+ subset = as.list(as.data.frame(window_sel$sel)), |
||
| 202 | -5x | +99 | +3x |
- afun <- make_afun(+ MoreArgs = list( |
| 203 | -5x | +100 | +3x |
- a_coxph_pairwise,+ formula = form, |
| 204 | -5x | +101 | +3x |
- .stats = .stats,+ data = data, |
| 205 | -5x | +102 | +3x |
- .formats = .formats,+ variables = variables, |
| 206 | -5x | +103 | +3x |
- .labels = .labels,+ control = control |
| 207 | -5x | +|||
| 104 | +
- .indent_mods = .indent_mods+ ) |
|||
| 208 | +105 |
- )+ ) |
||
| 209 | -5x | +|||
| 106 | +
- analyze(+ # Maybe we find a more elegant solution than this. |
|||
| 210 | -5x | +107 | +3x |
- lyt,+ rownames(tmp) <- c("n", "events", "loghr", "se", "ci_lower", "ci_upper")
|
| 211 | -5x | +108 | +3x |
- vars,+ t(tmp) |
| 212 | -5x | +|||
| 109 | +
- var_labels = var_labels,+ } |
|||
| 213 | -5x | +110 | +4x |
- show_labels = show_labels,+ result <- cbind(window_sel$interval, estimates) |
| 214 | -5x | +111 | +4x |
- table_names = table_names,+ structure( |
| 215 | -5x | +112 | +4x |
- afun = afun,+ result, |
| 216 | -5x | +113 | +4x |
- na_str = na_str,+ class = c("step", "matrix"),
|
| 217 | -5x | +114 | +4x |
- nested = nested,+ variables = variables, |
| 218 | -5x | +115 | +4x |
- extra_args = extra_args+ control = control |
| 219 | +116 |
) |
||
| 220 | +117 |
}@@ -180489,14 +182027,14 @@ tern coverage - 95.59% |
| 1 |
- #' Count patients with abnormal analysis range values by baseline status+ #' Count the number of patients with particular flags |
||
| 5 |
- #' The analyze function [count_abnormal_by_baseline()] creates a layout element to count patients with abnormal+ #' The analyze function [count_patients_with_flags()] creates a layout element to calculate counts of patients for |
||
| 6 |
- #' analysis range values, categorized by baseline status.+ #' which user-specified flags are present. |
||
| 8 |
- #' This function analyzes primary analysis variable `var` which indicates abnormal range results. Additional+ #' This function analyzes primary analysis variable `var` which indicates unique subject identifiers. Flags |
||
| 9 |
- #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to+ #' variables to analyze are specified by the user via the `flag_variables` argument, and must either take value |
||
| 10 |
- #' `USUBJID`), a variable to indicate unique subject identifiers, and `baseline` (defaults to `BNRIND`), a+ #' `TRUE` (flag present) or `FALSE` (flag absent) for each record. |
||
| 11 |
- #' variable to indicate baseline reference ranges.+ #' |
||
| 12 |
- #'+ #' If there are multiple records with the same flag present for a patient, only one occurrence is counted. |
||
| 13 |
- #' For each direction specified via the `abnormal` parameter (e.g. High or Low), we condition on baseline+ #' |
||
| 14 |
- #' range result and count patients in the numerator and denominator as follows for each of the following+ #' @inheritParams argument_convention |
||
| 15 |
- #' categories:+ #' @param flag_variables (`character`)\cr a vector specifying the names of `logical` variables from analysis dataset |
||
| 16 |
- #' * `Not <abnormality>`+ #' used for counting the number of unique identifiers. |
||
| 17 |
- #' * `num`: The number of patients without abnormality at baseline (excluding those with missing baseline)+ #' @param flag_labels (`character`)\cr vector of labels to use for flag variables. If any labels are also specified via |
||
| 18 |
- #' and with at least one abnormality post-baseline.+ #' the `.labels` parameter, the `.labels` values will take precedence and replace these labels. |
||
| 19 |
- #' * `denom`: The number of patients without abnormality at baseline (excluding those with missing baseline).+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 20 |
- #' * `<Abnormality>`+ #' |
||
| 21 |
- #' * `num`: The number of patients with abnormality as baseline and at least one abnormality post-baseline.+ #' Options are: ``r shQuote(get_stats("count_patients_with_flags"), type = "sh")``
|
||
| 22 |
- #' * `denom`: The number of patients with abnormality at baseline.+ #' |
||
| 23 |
- #' * `Total`+ #' @seealso [count_patients_with_event] |
||
| 24 |
- #' * `num`: The number of patients with at least one post-baseline record and at least one abnormality+ #' |
||
| 25 |
- #' post-baseline.+ #' @name count_patients_with_flags |
||
| 26 |
- #' * `denom`: The number of patients with at least one post-baseline record.+ #' @order 1 |
||
| 27 |
- #'+ NULL |
||
| 28 |
- #' This function assumes that `df` has been filtered to only include post-baseline records.+ |
||
| 29 |
- #'+ #' @describeIn count_patients_with_flags Statistics function which counts the number of patients for which |
||
| 30 |
- #' @inheritParams argument_convention+ #' a particular flag variable is `TRUE`. |
||
| 31 |
- #' @param abnormal (`character`)\cr values identifying the abnormal range level(s) in `.var`.+ #' |
||
| 32 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' @inheritParams analyze_variables |
||
| 33 |
- #'+ #' @param .var (`string`)\cr name of the column that contains the unique identifier. |
||
| 34 |
- #' Options are: ``r shQuote(get_stats("abnormal_by_baseline"))``
+ #' |
||
| 35 |
- #'+ #' @note If `flag_labels` is not specified, variables labels will be extracted from `df`. If variables are not |
||
| 36 |
- #' @note+ #' labeled, variable names will be used instead. Alternatively, a named `vector` can be supplied to |
||
| 37 |
- #' * `df` should be filtered to include only post-baseline records.+ #' `flag_variables` such that within each name-value pair the name corresponds to the variable name and the value is |
||
| 38 |
- #' * If the baseline variable or analysis variable contains `NA` records, it is expected that `df` has been+ #' the label to use for this variable. |
||
| 39 |
- #' pre-processed using [df_explicit_na()] or [explicit_na()].+ #' |
||
| 40 |
- #'+ #' @return |
||
| 41 |
- #' @seealso Relevant description function [d_count_abnormal_by_baseline()].+ #' * `s_count_patients_with_flags()` returns the count and the fraction of unique identifiers with each particular |
||
| 42 |
- #'+ #' flag as a list of statistics `n`, `count`, `count_fraction`, and `n_blq`, with one element per flag. |
||
| 43 |
- #' @name abnormal_by_baseline+ #' |
||
| 44 |
- #' @order 1+ #' @examples |
||
| 45 |
- NULL+ #' # `s_count_patients_with_flags()` |
||
| 46 |
-
+ #' |
||
| 47 |
- #' Description function for `s_count_abnormal_by_baseline()`+ #' s_count_patients_with_flags( |
||
| 48 |
- #'+ #' adae, |
||
| 49 |
- #' @description `r lifecycle::badge("stable")`
+ #' "SUBJID", |
||
| 50 |
- #'+ #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
|
||
| 51 |
- #' Description function that produces the labels for [s_count_abnormal_by_baseline()].+ #' denom = "N_col", |
||
| 52 |
- #'+ #' .N_col = 1000 |
||
| 53 |
- #' @inheritParams abnormal_by_baseline+ #' ) |
||
| 55 |
- #' @return Abnormal category labels for [s_count_abnormal_by_baseline()].+ #' @export |
||
| 56 |
- #'+ s_count_patients_with_flags <- function(df, |
||
| 57 |
- #' @examples+ .var, |
||
| 58 |
- #' d_count_abnormal_by_baseline("LOW")
+ flag_variables, |
||
| 59 |
- #'+ flag_labels = NULL, |
||
| 60 |
- #' @export+ .N_col = ncol(df), # nolint |
||
| 61 |
- d_count_abnormal_by_baseline <- function(abnormal) {
+ .N_row = nrow(df), # nolint |
||
| 62 | -9x | +
- not_abn_name <- paste("Not", tolower(abnormal))
+ denom = c("n", "N_col", "N_row")) {
|
|
| 63 | -9x | +41x |
- abn_name <- paste0(toupper(substr(abnormal, 1, 1)), tolower(substring(abnormal, 2)))+ checkmate::assert_character(flag_variables) |
| 64 | -9x | +41x |
- total_name <- "Total"+ if (!is.null(flag_labels)) {
|
| 65 | -+ | 6x |
-
+ checkmate::assert_character(flag_labels, len = length(flag_variables), any.missing = FALSE) |
| 66 | -9x | +6x |
- list(+ flag_names <- flag_labels |
| 67 | -9x | +
- not_abnormal = not_abn_name,+ } else {
|
|
| 68 | -9x | +35x |
- abnormal = abn_name,+ if (is.null(names(flag_variables))) {
|
| 69 | -9x | +20x |
- total = total_name+ flag_names <- formatters::var_labels(df[flag_variables], fill = TRUE) |
| 70 |
- )+ } else {
|
||
| 71 | -+ | 15x |
- }+ flag_names <- unname(flag_variables) |
| 72 | -+ | 15x |
-
+ flag_variables <- names(flag_variables) |
| 73 |
- #' @describeIn abnormal_by_baseline Statistics function for a single `abnormal` level.+ } |
||
| 74 |
- #'+ } |
||
| 75 |
- #' @param na_str (`string`)\cr the explicit `na_level` argument you used in the pre-processing steps (maybe with+ |
||
| 76 | -+ | 41x |
- #' [df_explicit_na()]). The default is `"<Missing>"`.+ checkmate::assert_subset(flag_variables, colnames(df)) |
| 77 | -+ | 41x |
- #'+ temp <- sapply(flag_variables, function(x) {
|
| 78 | -+ | 123x |
- #' @return+ tmp <- Map(function(y) which(df[[y]]), x) |
| 79 | -+ | 123x |
- #' * `s_count_abnormal_by_baseline()` returns statistic `fraction` which is a named list with 3 labeled elements:+ position_satisfy_flags <- Reduce(intersect, tmp) |
| 80 | -+ | 123x |
- #' `not_abnormal`, `abnormal`, and `total`. Each element contains a vector with `num` and `denom` patient counts.+ id_satisfy_flags <- as.character(unique(df[position_satisfy_flags, ][[.var]])) |
| 81 | -+ | 123x |
- #'+ s_count_values( |
| 82 | -+ | 123x |
- #' @keywords internal+ x = as.character(unique(df[[.var]])), |
| 83 | -+ | 123x |
- s_count_abnormal_by_baseline <- function(df,+ values = id_satisfy_flags, |
| 84 | -+ | 123x |
- .var,+ denom = denom, |
| 85 | -+ | 123x |
- abnormal,+ .N_col = .N_col, |
| 86 | -+ | 123x |
- na_str = "<Missing>",+ .N_row = .N_row |
| 87 |
- variables = list(id = "USUBJID", baseline = "BNRIND")) {
+ ) |
||
| 88 | -7x | +
- checkmate::assert_string(.var)+ }) |
|
| 89 | -7x | +41x |
- checkmate::assert_string(abnormal)+ colnames(temp) <- flag_names |
| 90 | -7x | +41x |
- checkmate::assert_string(na_str)+ temp <- data.frame(t(temp)) |
| 91 | -7x | +41x |
- assert_df_with_variables(df, c(range = .var, variables))+ result <- as.list(temp) |
| 92 | -7x | +41x |
- checkmate::assert_subset(names(variables), c("id", "baseline"))
+ if (length(flag_variables) == 1) {
|
| 93 | -7x | +1x |
- checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ for (i in seq(3)) names(result[[i]]) <- flag_names[1] |
| 94 | -7x | +
- checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
+ } |
|
| 95 | -7x | +41x |
- checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
+ result |
| 96 |
-
+ } |
||
| 97 |
- # If input is passed as character, changed to factor+ |
||
| 98 | -7x | +
- df[[.var]] <- as_factor_keep_attributes(df[[.var]], na_level = na_str)+ #' @describeIn count_patients_with_flags Formatted analysis function which is used as `afun` |
|
| 99 | -7x | +
- df[[variables$baseline]] <- as_factor_keep_attributes(df[[variables$baseline]], na_level = na_str)+ #' in `count_patients_with_flags()`. |
|
| 100 |
-
+ #' |
||
| 101 | -7x | +
- assert_valid_factor(df[[.var]], any.missing = FALSE)+ #' @return |
|
| 102 | -6x | +
- assert_valid_factor(df[[variables$baseline]], any.missing = FALSE)+ #' * `a_count_patients_with_flags()` returns the corresponding list with formatted [rtables::CellValue()]. |
|
| 103 |
-
+ #' |
||
| 104 |
- # Keep only records with valid analysis value.+ #' @examples |
||
| 105 | -5x | +
- df <- df[df[[.var]] != na_str, ]+ #' a_count_patients_with_flags( |
|
| 106 |
-
+ #' adae, |
||
| 107 | -5x | +
- anl <- data.frame(+ #' .N_col = 10L, |
|
| 108 | -5x | +
- id = df[[variables$id]],+ #' .N_row = 10L, |
|
| 109 | -5x | +
- var = df[[.var]],+ #' .var = "USUBJID", |
|
| 110 | -5x | +
- baseline = df[[variables$baseline]],+ #' flag_variables = c("fl1", "fl2", "fl3", "fl4")
|
|
| 111 | -5x | +
- stringsAsFactors = FALSE+ #' ) |
|
| 112 |
- )+ #' |
||
| 113 |
-
+ #' @export |
||
| 114 |
- # Total:+ a_count_patients_with_flags <- function(df, |
||
| 115 |
- # - Patients in denominator: have at least one valid measurement post-baseline.+ labelstr = "", |
||
| 116 |
- # - Patients in numerator: have at least one abnormality.+ flag_variables, |
||
| 117 | -5x | +
- total_denom <- length(unique(anl$id))+ flag_labels = NULL, |
|
| 118 | -5x | +
- total_num <- length(unique(anl$id[anl$var == abnormal]))+ denom = c("n", "N_col", "N_row"),
|
|
| 119 |
-
+ .N_col = ncol(df), # nolint |
||
| 120 |
- # Baseline NA records are counted only in total rows.+ .N_row = nrow(df), # nolint |
||
| 121 | -5x | +
- anl <- anl[anl$baseline != na_str, ]+ .df_row, |
|
| 122 |
-
+ .var = NULL, |
||
| 123 |
- # Abnormal:+ .stats = NULL, |
||
| 124 |
- # - Patients in denominator: have abnormality at baseline.+ .stat_names = NULL, |
||
| 125 |
- # - Patients in numerator: have abnormality at baseline AND+ .formats = NULL, |
||
| 126 |
- # have at least one abnormality post-baseline.+ .labels = NULL, |
||
| 127 | -5x | +
- abn_denom <- length(unique(anl$id[anl$baseline == abnormal]))+ .indent_mods = NULL, |
|
| 128 | -5x | +
- abn_num <- length(unique(anl$id[anl$baseline == abnormal & anl$var == abnormal]))+ na_str = default_na_str()) {
|
|
| 129 | -+ | 31x |
-
+ x_stats <- s_count_patients_with_flags( |
| 130 | -+ | 31x |
- # Not abnormal:+ df = df, .var = .var, flag_variables = flag_variables, flag_labels = flag_labels, |
| 131 | -+ | 31x |
- # - Patients in denominator: do not have abnormality at baseline.+ .N_col = .N_col, .N_row = .N_row, denom = denom |
| 132 |
- # - Patients in numerator: do not have abnormality at baseline AND+ ) |
||
| 133 | -+ | 17x |
- # have at least one abnormality post-baseline.+ if (is.null(names(flag_variables))) flag_variables <- formatters::var_labels(df, fill = TRUE)[flag_variables] |
| 134 | -5x | +26x |
- not_abn_denom <- length(unique(anl$id[anl$baseline != abnormal]))+ if (is.null(flag_labels)) flag_labels <- flag_variables |
| 135 | -5x | +
- not_abn_num <- length(unique(anl$id[anl$baseline != abnormal & anl$var == abnormal]))+ |
|
| 136 | -+ | 31x |
-
+ if (is.null(unlist(x_stats))) {
|
| 137 | -5x | +! |
- labels <- d_count_abnormal_by_baseline(abnormal)+ return(NULL) |
| 138 | -5x | +
- list(fraction = list(+ } |
|
| 139 | -5x | +
- not_abnormal = formatters::with_label(c(num = not_abn_num, denom = not_abn_denom), labels$not_abnormal),+ |
|
| 140 | -5x | +
- abnormal = formatters::with_label(c(num = abn_num, denom = abn_denom), labels$abnormal),+ # Fill in with formatting defaults if needed |
|
| 141 | -5x | +31x |
- total = formatters::with_label(c(num = total_num, denom = total_denom), labels$total)+ .stats <- get_stats("count_patients_with_flags", stats_in = .stats)
|
| 142 | -+ | 31x |
- ))+ levels_per_stats <- rep(list(names(flag_variables)), length(.stats)) %>% setNames(.stats) |
| 143 | -+ | 31x |
- }+ .formats <- get_formats_from_stats(.stats, .formats, levels_per_stats) |
| 144 | -+ | 31x |
-
+ .indent_mods <- get_indents_from_stats(.stats, .indent_mods, levels_per_stats) |
| 145 | -+ | 31x |
- #' @describeIn abnormal_by_baseline Formatted analysis function which is used as `afun`+ .labels <- get_labels_from_stats( |
| 146 | -+ | 31x |
- #' in `count_abnormal_by_baseline()`.+ .stats, .labels, levels_per_stats, |
| 147 | -+ | 31x |
- #'+ flag_labels %>% setNames(names(flag_variables)) |
| 148 |
- #' @return+ ) |
||
| 149 |
- #' * `a_count_abnormal_by_baseline()` returns the corresponding list with formatted [rtables::CellValue()].+ |
||
| 150 | -+ | 31x |
- #'+ x_stats <- x_stats[.stats] |
| 151 |
- #' @keywords internal+ |
||
| 152 |
- a_count_abnormal_by_baseline <- make_afun(+ # Unlist stats |
||
| 153 | -+ | 31x |
- s_count_abnormal_by_baseline,+ x_stats <- x_stats %>% |
| 154 | -+ | 31x |
- .formats = c(fraction = format_fraction)+ .unlist_keep_nulls() %>% |
| 155 | -+ | 31x |
- )+ setNames(names(.formats)) |
| 157 |
- #' @describeIn abnormal_by_baseline Layout-creating function which can take statistics function arguments+ # Auto format handling |
||
| 158 | -+ | 31x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ .formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var) |
| 159 |
- #'+ |
||
| 160 |
- #' @return+ # Get and check statistical names from defaults |
||
| 161 | -+ | 31x |
- #' * `count_abnormal_by_baseline()` returns a layout object suitable for passing to further layouting functions,+ .stat_names <- get_stat_names(x_stats, .stat_names) |
| 162 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
||
| 163 | -+ | 31x |
- #' the statistics from `s_count_abnormal_by_baseline()` to the table layout.+ in_rows( |
| 164 | -+ | 31x |
- #'+ .list = x_stats, |
| 165 | -+ | 31x |
- #' @examples+ .formats = .formats, |
| 166 | -+ | 31x |
- #' df <- data.frame(+ .names = names(.labels), |
| 167 | -+ | 31x |
- #' USUBJID = as.character(c(1:6)),+ .stat_names = .stat_names, |
| 168 | -+ | 31x |
- #' ANRIND = factor(c(rep("LOW", 4), "NORMAL", "HIGH")),
+ .labels = .labels %>% .unlist_keep_nulls(), |
| 169 | -+ | 31x |
- #' BNRIND = factor(c("LOW", "NORMAL", "HIGH", NA, "LOW", "NORMAL"))
+ .indent_mods = .indent_mods %>% .unlist_keep_nulls(), |
| 170 | -+ | 31x |
- #' )+ .format_na_strs = na_str |
| 171 |
- #' df <- df_explicit_na(df)+ ) |
||
| 172 |
- #'+ } |
||
| 173 |
- #' # Layout creating function.+ |
||
| 174 |
- #' basic_table() %>%+ #' @describeIn count_patients_with_flags Layout-creating function which can take statistics function |
||
| 175 |
- #' count_abnormal_by_baseline(var = "ANRIND", abnormal = c(High = "HIGH")) %>%+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 176 |
- #' build_table(df)+ #' |
||
| 177 |
- #'+ #' @return |
||
| 178 |
- #' # Passing of statistics function and formatting arguments.+ #' * `count_patients_with_flags()` returns a layout object suitable for passing to further layouting functions, |
||
| 179 |
- #' df2 <- data.frame(+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 180 |
- #' ID = as.character(c(1, 2, 3, 4)),+ #' the statistics from `s_count_patients_with_flags()` to the table layout. |
||
| 181 |
- #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
+ #' |
||
| 182 |
- #' BLRANGE = factor(c("LOW", "HIGH", "HIGH", "NORMAL"))
+ #' @examples |
||
| 183 |
- #' )+ #' # Add labelled flag variables to analysis dataset. |
||
| 184 |
- #'+ #' adae <- tern_ex_adae %>% |
||
| 185 |
- #' basic_table() %>%+ #' dplyr::mutate( |
||
| 186 |
- #' count_abnormal_by_baseline(+ #' fl1 = TRUE %>% with_label("Total AEs"),
|
||
| 187 |
- #' var = "RANGE",+ #' fl2 = (TRTEMFL == "Y") %>% |
||
| 188 |
- #' abnormal = c(Low = "LOW"),+ #' with_label("Total number of patients with at least one adverse event"),
|
||
| 189 |
- #' variables = list(id = "ID", baseline = "BLRANGE"),+ #' fl3 = (TRTEMFL == "Y" & AEOUT == "FATAL") %>% |
||
| 190 |
- #' .formats = c(fraction = "xx / xx"),+ #' with_label("Total number of patients with fatal AEs"),
|
||
| 191 |
- #' .indent_mods = c(fraction = 2L)+ #' fl4 = (TRTEMFL == "Y" & AEOUT == "FATAL" & AEREL == "Y") %>% |
||
| 192 |
- #' ) %>%+ #' with_label("Total number of patients with related fatal AEs")
|
||
| 193 |
- #' build_table(df2)+ #' ) |
||
| 195 |
- #' @export+ #' lyt <- basic_table() %>% |
||
| 196 |
- #' @order 2+ #' split_cols_by("ARM") %>%
|
||
| 197 |
- count_abnormal_by_baseline <- function(lyt,+ #' add_colcounts() %>% |
||
| 198 |
- var,+ #' count_patients_with_flags( |
||
| 199 |
- abnormal,+ #' "SUBJID", |
||
| 200 |
- variables = list(id = "USUBJID", baseline = "BNRIND"),+ #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
|
||
| 201 |
- na_str = "<Missing>",+ #' denom = "N_col" |
||
| 202 |
- nested = TRUE,+ #' ) |
||
| 203 |
- ...,+ #' |
||
| 204 |
- table_names = abnormal,+ #' build_table(lyt, adae, alt_counts_df = tern_ex_adsl) |
||
| 205 |
- .stats = NULL,+ #' |
||
| 206 |
- .formats = NULL,+ #' @export |
||
| 207 |
- .labels = NULL,+ #' @order 2 |
||
| 208 |
- .indent_mods = NULL) {
+ count_patients_with_flags <- function(lyt, |
||
| 209 | -2x | +
- checkmate::assert_character(abnormal, len = length(table_names), names = "named")+ var, |
|
| 210 | -2x | +
- checkmate::assert_string(var)+ flag_variables, |
|
| 211 |
-
+ flag_labels = NULL, |
||
| 212 | -2x | +
- extra_args <- list(abnormal = abnormal, variables = variables, na_str = na_str, ...)+ var_labels = var, |
|
| 213 |
-
+ show_labels = "hidden", |
||
| 214 | -2x | +
- afun <- make_afun(+ riskdiff = FALSE, |
|
| 215 | -2x | +
- a_count_abnormal_by_baseline,+ na_str = default_na_str(), |
|
| 216 | -2x | +
- .stats = .stats,+ nested = TRUE, |
|
| 217 | -2x | +
- .formats = .formats,+ ..., |
|
| 218 | -2x | +
- .labels = .labels,+ table_names = paste0("tbl_flags_", var),
|
|
| 219 | -2x | +
- .indent_mods = .indent_mods,+ .stats = "count_fraction", |
|
| 220 | -2x | +
- .ungroup_stats = "fraction"+ .stat_names = NULL, |
|
| 221 |
- )+ .formats = list(count_fraction = format_count_fraction_fixed_dp), |
||
| 222 | -2x | +
- for (i in seq_along(abnormal)) {
+ .indent_mods = NULL, |
|
| 223 | -4x | +
- extra_args[["abnormal"]] <- abnormal[i]+ .labels = NULL) {
|
|
| 224 | -+ | 11x |
-
+ checkmate::assert_flag(riskdiff) |
| 225 | -4x | +11x |
- lyt <- analyze(+ extra_args <- list( |
| 226 | -4x | +11x |
- lyt = lyt,+ .stats = .stats, .stat_names = .stat_names, .formats = .formats, .labels = .labels, |
| 227 | -4x | +11x |
- vars = var,+ .indent_mods = .indent_mods, na_str = na_str |
| 228 | -4x | +
- var_labels = names(abnormal[i]),+ ) |
|
| 229 | -4x | +11x |
- afun = afun,+ s_args <- list(flag_variables = flag_variables, flag_labels = flag_labels, ...) |
| 230 | -4x | +
- na_str = na_str,+ |
|
| 231 | -4x | +11x |
- nested = nested,+ if (isFALSE(riskdiff)) {
|
| 232 | -4x | +9x |
- table_names = table_names[i],+ extra_args <- c(extra_args, s_args) |
| 233 | -4x | +
- extra_args = extra_args,+ } else {
|
|
| 234 | -4x | +2x |
- show_labels = "visible"+ extra_args <- c( |
| 235 | -+ | 2x |
- )+ extra_args, |
| 236 | -+ | 2x |
- }+ list( |
| 237 | 2x |
- lyt+ afun = list("s_count_patients_with_flags" = a_count_patients_with_flags),
|
|
| 238 | -- |
- }- |
-
| 1 | -- |
- #' Sort pharmacokinetic data by `PARAM` variable- |
- ||
| 2 | -- |
- #'- |
- ||
| 3 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- ||
| 4 | -- |
- #'- |
- ||
| 5 | -- |
- #' @param pk_data (`data.frame`)\cr pharmacokinetic data frame.- |
- ||
| 6 | -- |
- #' @param key_var (`string`)\cr key variable used to merge pk_data and metadata created by [d_pkparam()].- |
- ||
| 7 | -- |
- #'- |
- ||
| 8 | -- |
- #' @return A pharmacokinetic `data.frame` sorted by a `PARAM` variable.- |
- ||
| 9 | -- |
- #'- |
- ||
| 10 | -- |
- #' @examples- |
- ||
| 11 | -- |
- #' library(dplyr)- |
- ||
| 12 | -- |
- #'- |
- ||
| 13 | -- |
- #' adpp <- tern_ex_adpp %>% mutate(PKPARAM = factor(paste0(PARAM, " (", AVALU, ")")))
- |
- ||
| 14 | -+ | 2x |
- #' pk_ordered_data <- h_pkparam_sort(adpp)+ s_args = s_args |
|
| 15 | +239 |
- #'+ ) |
||
| 16 | +240 |
- #' @export+ ) |
||
| 17 | +241 |
- h_pkparam_sort <- function(pk_data, key_var = "PARAMCD") {
- |
- ||
| 18 | -4x | -
- assert_df_with_variables(pk_data, list(key_var = key_var))- |
- ||
| 19 | -4x | -
- pk_data$PARAMCD <- pk_data[[key_var]]+ } |
||
| 20 | +242 | |||
| 21 | -4x | -
- ordered_pk_data <- d_pkparam()- |
- ||
| 22 | -- | - - | -||
| 23 | -+ | 243 | +11x |
- # Add the numeric values from ordered_pk_data to pk_data+ analyze( |
| 24 | -4x | -
- joined_data <- merge(pk_data, ordered_pk_data, by = "PARAMCD", suffixes = c("", ".y"))
- |
- ||
| 25 | -+ | 244 | +11x |
-
+ lyt = lyt, |
| 26 | -4x | -
- joined_data <- joined_data[, -grep(".*.y$", colnames(joined_data))]
- |
- ||
| 27 | -+ | 245 | +11x |
-
+ vars = var, |
| 28 | -4x | -
- joined_data$TLG_ORDER <- as.numeric(joined_data$TLG_ORDER)- |
- ||
| 29 | -- | - - | -||
| 30 | -+ | 246 | +11x |
- # Then order PARAM based on this column+ afun = ifelse(isFALSE(riskdiff), a_count_patients_with_flags, afun_riskdiff), |
| 31 | -4x | +247 | +11x |
- joined_data$PARAM <- factor(joined_data$PARAM,+ var_labels = var_labels, |
| 32 | -4x | +248 | +11x |
- levels = unique(joined_data$PARAM[order(joined_data$TLG_ORDER)]),+ show_labels = show_labels, |
| 33 | -4x | -
- ordered = TRUE- |
- ||
| 34 | -- |
- )- |
- ||
| 35 | -+ | 249 | +11x |
-
+ table_names = table_names, |
| 36 | -4x | +250 | +11x |
- joined_data$TLG_DISPLAY <- factor(joined_data$TLG_DISPLAY,+ na_str = na_str, |
| 37 | -4x | +251 | +11x |
- levels = unique(joined_data$TLG_DISPLAY[order(joined_data$TLG_ORDER)]),+ nested = nested, |
| 38 | -4x | +252 | +11x |
- ordered = TRUE+ extra_args = extra_args |
| 39 | +253 |
) |
||
| 40 | -- | - - | -||
| 41 | -4x | -
- joined_data- |
- ||
| 42 | +254 |
}@@ -182461,14 +183811,14 @@ tern coverage - 95.59% |
| 1 |
- #' Count patient events in columns+ #' Analyze a pairwise Cox-PH model |
||
| 5 |
- #' The summarize function [summarize_patients_events_in_cols()] creates a layout element to summarize patient+ #' The analyze function [coxph_pairwise()] creates a layout element to analyze a pairwise Cox-PH model. |
||
| 6 |
- #' event counts in columns.+ #' |
||
| 7 |
- #'+ #' This function can return statistics including p-value, hazard ratio (HR), and HR confidence intervals from both |
||
| 8 |
- #' This function analyzes the elements (events) supplied via the `filters_list` parameter and returns a row+ #' stratified and unstratified Cox-PH models. The variable(s) to be analyzed is specified via the `vars` argument and |
||
| 9 |
- #' with counts of number of patients for each event as well as the total numbers of patients and events.+ #' any stratification factors via the `strata` argument. |
||
| 10 |
- #' The `id` variable is used to indicate unique subject identifiers (defaults to `USUBJID`).+ #' |
||
| 11 |
- #'+ #' @inheritParams argument_convention |
||
| 12 |
- #' If there are multiple occurrences of the same event recorded for a patient, the event is only counted once.+ #' @inheritParams s_surv_time |
||
| 13 |
- #'+ #' @param strata (`character` or `NULL`)\cr variable names indicating stratification factors. |
||
| 14 |
- #' @inheritParams argument_convention+ #' @param strat `r lifecycle::badge("deprecated")` Please use the `strata` argument instead.
|
||
| 15 |
- #' @param filters_list (named `list` of `character`)\cr list where each element in this list describes one+ #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function |
||
| 16 |
- #' type of event describe by filters, in the same format as [s_count_patients_with_event()].+ #' [control_coxph()]. Some possible parameter options are: |
||
| 17 |
- #' If it has a label, then this will be used for the column title.+ #' * `pval_method` (`string`)\cr p-value method for testing the null hypothesis that hazard ratio = 1. Default |
||
| 18 |
- #' @param empty_stats (`character`)\cr optional names of the statistics that should be returned empty such+ #' method is `"log-rank"` which comes from [survival::survdiff()], can also be set to `"wald"` or `"likelihood"` |
||
| 19 |
- #' that corresponding table cells will stay blank.+ #' (from [survival::coxph()]). |
||
| 20 |
- #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will+ #' * `ties` (`string`)\cr specifying the method for tie handling. Default is `"efron"`, |
||
| 21 |
- #' be used as label.+ #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()]. |
||
| 22 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR. |
||
| 23 |
- #'+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 24 |
- #' In addition to any statistics added using `filters_list`, statistic options are:+ #' |
||
| 25 |
- #' ``r shQuote(get_stats("summarize_patients_events_in_cols"))``
+ #' Options are: ``r shQuote(get_stats("coxph_pairwise"), type = "sh")``
|
||
| 27 |
- #' @name count_patients_events_in_cols+ #' @name survival_coxph_pairwise |
||
| 31 |
- #' @describeIn count_patients_events_in_cols Statistics function which counts numbers of patients and multiple+ #' @describeIn survival_coxph_pairwise Statistics function which analyzes HR, CIs of HR, and p-value of a Cox-PH model. |
||
| 32 |
- #' events defined by filters. Used as analysis function `afun` in `summarize_patients_events_in_cols()`.+ #' |
||
| 33 |
- #'+ #' @return |
||
| 34 |
- #' @return+ #' * `s_coxph_pairwise()` returns the statistics: |
||
| 35 |
- #' * `s_count_patients_and_multiple_events()` returns a list with the statistics:+ #' * `pvalue`: p-value to test the null hypothesis that hazard ratio = 1. |
||
| 36 |
- #' - `unique`: number of unique patients in `df`.+ #' * `hr`: Hazard ratio. |
||
| 37 |
- #' - `all`: number of rows in `df`.+ #' * `hr_ci`: Confidence interval for hazard ratio. |
||
| 38 |
- #' - one element with the same name as in `filters_list`: number of rows in `df`,+ #' * `n_tot`: Total number of observations. |
||
| 39 |
- #' i.e. events, fulfilling the filter condition.+ #' * `n_tot_events`: Total number of events. |
||
| 42 |
- s_count_patients_and_multiple_events <- function(df, # nolint+ s_coxph_pairwise <- function(df, |
||
| 43 |
- id,+ .ref_group, |
||
| 44 |
- filters_list,+ .in_ref_col, |
||
| 45 |
- empty_stats = character(),+ .var, |
||
| 46 |
- labelstr = "",+ is_event, |
||
| 47 |
- custom_label = NULL) {
+ strata = NULL, |
||
| 48 | -9x | +
- checkmate::assert_list(filters_list, names = "named")+ strat = lifecycle::deprecated(), |
|
| 49 | -9x | +
- checkmate::assert_data_frame(df)+ control = control_coxph()) {
|
|
| 50 | -9x | +92x |
- checkmate::assert_string(id)+ if (lifecycle::is_present(strat)) {
|
| 51 | -9x | +! |
- checkmate::assert_disjunct(c("unique", "all"), names(filters_list))
+ lifecycle::deprecate_warn("0.9.4", "s_coxph_pairwise(strat)", "s_coxph_pairwise(strata)")
|
| 52 | -9x | +! |
- checkmate::assert_character(empty_stats)+ strata <- strat |
| 53 | -9x | +
- checkmate::assert_string(labelstr)+ } |
|
| 54 | -9x | +
- checkmate::assert_string(custom_label, null.ok = TRUE)+ |
|
| 55 | -+ | 92x |
-
+ checkmate::assert_string(.var) |
| 56 | -+ | 92x |
- # Below we want to count each row in `df` once, therefore introducing this helper index column.+ checkmate::assert_numeric(df[[.var]]) |
| 57 | -9x | +92x |
- df$.row_index <- as.character(seq_len(nrow(df)))+ checkmate::assert_logical(df[[is_event]]) |
| 58 | -9x | +92x |
- y <- list()+ assert_df_with_variables(df, list(tte = .var, is_event = is_event)) |
| 59 | -9x | +92x |
- row_label <- if (labelstr != "") {
+ pval_method <- control$pval_method |
| 60 | -! | +92x |
- labelstr+ ties <- control$ties |
| 61 | -9x | +92x |
- } else if (!is.null(custom_label)) {
+ conf_level <- control$conf_level |
| 62 | -2x | +
- custom_label+ |
|
| 63 | -+ | 92x |
- } else {
+ if (.in_ref_col) {
|
| 64 | -7x | +! |
- "counts"+ return( |
| 65 | -+ | ! |
- }+ list( |
| 66 | -9x | +! |
- y$unique <- formatters::with_label(+ pvalue = formatters::with_label("", paste0("p-value (", pval_method, ")")),
|
| 67 | -9x | +! |
- s_num_patients_content(df = df, .N_col = 1, .var = id, required = NULL)$unique[1L],+ hr = formatters::with_label("", "Hazard Ratio"),
|
| 68 | -9x | +! |
- row_label+ hr_ci = formatters::with_label("", f_conf_level(conf_level)),
|
| 69 | -+ | ! |
- )+ hr_ci_3d = formatters::with_label("", paste0("Hazard Ratio (", f_conf_level(conf_level), ")")),
|
| 70 | -9x | +! |
- y$all <- formatters::with_label(+ n_tot = formatters::with_label("", "Total n"),
|
| 71 | -9x | +! |
- nrow(df),+ n_tot_events = formatters::with_label("", "Total events")
|
| 72 | -9x | +
- row_label+ ) |
|
| 73 |
- )+ ) |
||
| 74 | -9x | +
- events <- Map(+ } |
|
| 75 | -9x | +92x |
- function(filters) {
+ data <- rbind(.ref_group, df) |
| 76 | -25x | +92x |
- formatters::with_label(+ group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
|
| 77 | -25x | +
- s_count_patients_with_event(df = df, .var = ".row_index", filters = filters, .N_col = 1, .N_row = 1)$count,+ |
|
| 78 | -25x | +92x |
- row_label+ df_cox <- data.frame( |
| 79 | -+ | 92x |
- )+ tte = data[[.var]], |
| 80 | -+ | 92x |
- },+ is_event = data[[is_event]], |
| 81 | -9x | +92x |
- filters = filters_list+ arm = group |
| 83 | -9x | +92x |
- y_complete <- c(y, events)+ if (is.null(strata)) {
|
| 84 | -9x | +83x |
- y <- if (length(empty_stats) > 0) {
+ formula_cox <- survival::Surv(tte, is_event) ~ arm |
| 85 | -3x | +
- y_reduced <- y_complete+ } else {
|
|
| 86 | -3x | +9x |
- for (stat in intersect(names(y_complete), empty_stats)) {
+ formula_cox <- stats::as.formula( |
| 87 | -4x | +9x |
- y_reduced[[stat]] <- formatters::with_label(character(), obj_label(y_reduced[[stat]]))+ paste0( |
| 88 | -+ | 9x |
- }+ "survival::Surv(tte, is_event) ~ arm + strata(",
|
| 89 | -3x | +9x |
- y_reduced+ paste(strata, collapse = ","), |
| 90 |
- } else {
+ ")" |
||
| 91 | -6x | +
- y_complete+ ) |
|
| 92 |
- }+ ) |
||
| 93 | 9x |
- y+ df_cox <- cbind(df_cox, data[strata]) |
|
| 94 |
- }+ } |
||
| 95 | -+ | 92x |
-
+ cox_fit <- survival::coxph( |
| 96 | -+ | 92x |
- #' @describeIn count_patients_events_in_cols Layout-creating function which can take statistics function+ formula = formula_cox, |
| 97 | -+ | 92x |
- #' arguments and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ data = df_cox, |
| 98 | -+ | 92x |
- #'+ ties = ties |
| 99 |
- #' @param col_split (`flag`)\cr whether the columns should be split.+ ) |
||
| 100 | -+ | 92x |
- #' Set to `FALSE` when the required column split has been done already earlier in the layout pipe.+ sum_cox <- summary(cox_fit, conf.int = conf_level, extend = TRUE) |
| 101 | -+ | 92x |
- #'+ orginal_survdiff <- survival::survdiff( |
| 102 | -+ | 92x |
- #' @return+ formula_cox, |
| 103 | -+ | 92x |
- #' * `summarize_patients_events_in_cols()` returns a layout object suitable for passing to further layouting functions,+ data = df_cox |
| 104 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows+ ) |
||
| 105 | -+ | 92x |
- #' containing the statistics from `s_count_patients_and_multiple_events()` to the table layout.+ log_rank_pvalue <- 1 - pchisq(orginal_survdiff$chisq, length(orginal_survdiff$n) - 1) |
| 106 |
- #'+ |
||
| 107 | -+ | 92x |
- #' @examples+ pval <- switch(pval_method, |
| 108 | -+ | 92x |
- #' df <- data.frame(+ "wald" = sum_cox$waldtest["pvalue"], |
| 109 | -+ | 92x |
- #' USUBJID = rep(c("id1", "id2", "id3", "id4"), c(2, 3, 1, 1)),
+ "log-rank" = log_rank_pvalue, # pvalue from original log-rank test survival::survdiff() |
| 110 | -+ | 92x |
- #' ARM = c("A", "A", "B", "B", "B", "B", "A"),
+ "likelihood" = sum_cox$logtest["pvalue"] |
| 111 |
- #' AESER = rep("Y", 7),
+ ) |
||
| 112 | -+ | 92x |
- #' AESDTH = c("Y", "Y", "N", "Y", "Y", "N", "N"),
+ list( |
| 113 | -+ | 92x |
- #' AEREL = c("Y", "Y", "N", "Y", "Y", "N", "Y"),
+ pvalue = formatters::with_label(unname(pval), paste0("p-value (", pval_method, ")")),
|
| 114 | -+ | 92x |
- #' AEDECOD = c("A", "A", "A", "B", "B", "C", "D"),
+ hr = formatters::with_label(sum_cox$conf.int[1, 1], "Hazard Ratio"), |
| 115 | -+ | 92x |
- #' AEBODSYS = rep(c("SOC1", "SOC2", "SOC3"), c(3, 3, 1))
+ hr_ci = formatters::with_label(unname(sum_cox$conf.int[1, 3:4]), f_conf_level(conf_level)), |
| 116 | -+ | 92x |
- #' )+ hr_ci_3d = formatters::with_label( |
| 117 | -+ | 92x |
- #'+ c(sum_cox$conf.int[1, 1], unname(sum_cox$conf.int[1, 3:4])), |
| 118 | -+ | 92x |
- #' # `summarize_patients_events_in_cols()`+ paste0("Hazard Ratio (", f_conf_level(conf_level), ")")
|
| 119 |
- #' basic_table() %>%+ ), |
||
| 120 | -+ | 92x |
- #' summarize_patients_events_in_cols(+ n_tot = formatters::with_label(sum_cox$n, "Total n"), |
| 121 | -+ | 92x |
- #' filters_list = list(+ n_tot_events = formatters::with_label(sum_cox$nevent, "Total events") |
| 122 |
- #' related = formatters::with_label(c(AEREL = "Y"), "Events (Related)"),+ ) |
||
| 123 |
- #' fatal = c(AESDTH = "Y"),+ } |
||
| 124 |
- #' fatal_related = c(AEREL = "Y", AESDTH = "Y")+ |
||
| 125 |
- #' ),+ #' @describeIn survival_coxph_pairwise Formatted analysis function which is used as `afun` in `coxph_pairwise()`. |
||
| 126 |
- #' custom_label = "%s Total number of patients and events"+ #' |
||
| 127 |
- #' ) %>%+ #' @return |
||
| 128 |
- #' build_table(df)+ #' * `a_coxph_pairwise()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 130 |
- #' @export+ #' @keywords internal |
||
| 131 |
- #' @order 2+ a_coxph_pairwise <- make_afun( |
||
| 132 |
- summarize_patients_events_in_cols <- function(lyt, # nolint+ s_coxph_pairwise, |
||
| 133 |
- id = "USUBJID",+ .indent_mods = c(pvalue = 0L, hr = 0L, hr_ci = 1L, n_tot = 0L, n_tot_events = 0L, hr_ci_3d = 0L), |
||
| 134 |
- filters_list = list(),+ .formats = c( |
||
| 135 |
- empty_stats = character(),+ pvalue = "x.xxxx | (<0.0001)", |
||
| 136 |
- na_str = default_na_str(),+ hr = "xx.xx", |
||
| 137 |
- ...,+ hr_ci = "(xx.xx, xx.xx)", |
||
| 138 |
- .stats = c(+ hr_ci_3d = "xx.xx (xx.xx - xx.xx)", |
||
| 139 |
- "unique",+ n_tot = "xx.xx", |
||
| 140 |
- "all",+ n_tot_events = "xx.xx" |
||
| 141 |
- names(filters_list)+ ) |
||
| 142 |
- ),+ ) |
||
| 143 |
- .labels = c(+ |
||
| 144 |
- unique = "Patients (All)",+ #' @describeIn survival_coxph_pairwise Layout-creating function which can take statistics function arguments |
||
| 145 |
- all = "Events (All)",+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 146 |
- labels_or_names(filters_list)+ #' |
||
| 147 |
- ),+ #' @return |
||
| 148 |
- col_split = TRUE) {
+ #' * `coxph_pairwise()` returns a layout object suitable for passing to further layouting functions, |
||
| 149 | -2x | +
- extra_args <- list(id = id, filters_list = filters_list, empty_stats = empty_stats, ...)+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|
| 150 |
-
+ #' the statistics from `s_coxph_pairwise()` to the table layout. |
||
| 151 | -2x | +
- afun_list <- Map(+ #' |
|
| 152 | -2x | +
- function(stat) {
+ #' @examples |
|
| 153 | -7x | +
- make_afun(+ #' library(dplyr) |
|
| 154 | -7x | +
- s_count_patients_and_multiple_events,+ #' |
|
| 155 | -7x | +
- .stats = stat,+ #' adtte_f <- tern_ex_adtte %>% |
|
| 156 | -7x | +
- .formats = "xx."+ #' filter(PARAMCD == "OS") %>% |
|
| 157 |
- )+ #' mutate(is_event = CNSR == 0) |
||
| 158 |
- },+ #' |
||
| 159 | -2x | +
- stat = .stats+ #' df <- adtte_f %>% filter(ARMCD == "ARM A") |
|
| 160 |
- )+ #' df_ref_group <- adtte_f %>% filter(ARMCD == "ARM B") |
||
| 161 | -2x | +
- if (col_split) {
+ #' |
|
| 162 | -2x | +
- lyt <- split_cols_by_multivar(+ #' basic_table() %>% |
|
| 163 | -2x | +
- lyt = lyt,+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
|
| 164 | -2x | +
- vars = rep(id, length(.stats)),+ #' add_colcounts() %>% |
|
| 165 | -2x | +
- varlabels = .labels[.stats]+ #' coxph_pairwise( |
|
| 166 |
- )+ #' vars = "AVAL", |
||
| 167 |
- }+ #' is_event = "is_event", |
||
| 168 | -2x | +
- summarize_row_groups(+ #' var_labels = "Unstratified Analysis" |
|
| 169 | -2x | +
- lyt = lyt,+ #' ) %>% |
|
| 170 | -2x | +
- cfun = afun_list,+ #' build_table(df = adtte_f) |
|
| 171 | -2x | +
- na_str = na_str,+ #' |
|
| 172 | -2x | +
- extra_args = extra_args+ #' basic_table() %>% |
|
| 173 |
- )+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>% |
||
| 174 |
- }+ #' add_colcounts() %>% |
| 1 | +175 |
- #' Summarize analysis of covariance (ANCOVA) results+ #' coxph_pairwise( |
|
| 2 | +176 |
- #'+ #' vars = "AVAL", |
|
| 3 | +177 |
- #' @description `r lifecycle::badge("stable")`
+ #' is_event = "is_event", |
|
| 4 | +178 |
- #'+ #' var_labels = "Stratified Analysis", |
|
| 5 | +179 |
- #' The analyze function [summarize_ancova()] creates a layout element to summarize ANCOVA results.+ #' strata = "SEX", |
|
| 6 | +180 |
- #'+ #' control = control_coxph(pval_method = "wald") |
|
| 7 | +181 |
- #' This function can be used to analyze multiple endpoints and/or multiple timepoints within the response variable(s)+ #' ) %>% |
|
| 8 | +182 |
- #' specified as `vars`.+ #' build_table(df = adtte_f) |
|
| 9 | +183 |
#' |
|
| 10 | +184 |
- #' Additional variables for the analysis, namely an arm (grouping) variable and covariate variables, can be defined+ #' @export |
|
| 11 | +185 |
- #' via the `variables` argument. See below for more details on how to specify `variables`. An interaction term can+ #' @order 2 |
|
| 12 | +186 |
- #' be implemented in the model if needed. The interaction variable that should interact with the arm variable is+ coxph_pairwise <- function(lyt, |
|
| 13 | +187 |
- #' specified via the `interaction_term` parameter, and the specific value of `interaction_term` for which to extract+ vars, |
|
| 14 | +188 |
- #' the ANCOVA results via the `interaction_y` parameter.+ strata = NULL, |
|
| 15 | +189 |
- #'+ control = control_coxph(), |
|
| 16 | +190 |
- #' @inheritParams h_ancova+ na_str = default_na_str(), |
|
| 17 | +191 |
- #' @inheritParams argument_convention+ nested = TRUE, |
|
| 18 | +192 |
- #' @param interaction_y (`string` or `flag`)\cr a selected item inside of the `interaction_item` variable which will be+ ..., |
|
| 19 | +193 |
- #' used to select the specific ANCOVA results. if the interaction is not needed, the default option is `FALSE`.+ var_labels = "CoxPH", |
|
| 20 | +194 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ show_labels = "visible", |
|
| 21 | +195 |
- #'+ table_names = vars, |
|
| 22 | +196 |
- #' Options are: ``r shQuote(get_stats("summarize_ancova"))``
+ .stats = c("pvalue", "hr", "hr_ci"),
|
|
| 23 | +197 |
- #'+ .formats = NULL, |
|
| 24 | +198 |
- #' @name summarize_ancova+ .labels = NULL, |
|
| 25 | +199 |
- #' @order 1+ .indent_mods = NULL) {
|
|
| 26 | -+ | ||
| 200 | +5x |
- NULL+ extra_args <- list(strata = strata, control = control, ...) |
|
| 27 | +201 | ||
| 28 | -+ | ||
| 202 | +5x |
- #' Helper function to return results of a linear model+ afun <- make_afun( |
|
| 29 | -+ | ||
| 203 | +5x |
- #'+ a_coxph_pairwise, |
|
| 30 | -+ | ||
| 204 | +5x |
- #' @description `r lifecycle::badge("stable")`
+ .stats = .stats, |
|
| 31 | -+ | ||
| 205 | +5x |
- #'+ .formats = .formats, |
|
| 32 | -+ | ||
| 206 | +5x |
- #' @inheritParams argument_convention+ .labels = .labels, |
|
| 33 | -+ | ||
| 207 | +5x |
- #' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called in `.var` and `variables`.+ .indent_mods = .indent_mods |
|
| 34 | +208 |
- #' @param variables (named `list` of `string`)\cr list of additional analysis variables, with expected elements:+ ) |
|
| 35 | -+ | ||
| 209 | +5x |
- #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be+ analyze( |
|
| 36 | -+ | ||
| 210 | +5x |
- #' summarized. Specifically, the first level of `arm` variable is taken as the reference group.+ lyt, |
|
| 37 | -+ | ||
| 211 | +5x |
- #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as `"X1"`), and/or+ vars, |
|
| 38 | -+ | ||
| 212 | +5x |
- #' interaction terms indicated by `"X1 * X2"`.+ var_labels = var_labels, |
|
| 39 | -+ | ||
| 213 | +5x |
- #' @param interaction_item (`string` or `NULL`)\cr name of the variable that should have interactions+ show_labels = show_labels, |
|
| 40 | -+ | ||
| 214 | +5x |
- #' with arm. if the interaction is not needed, the default option is `NULL`.+ table_names = table_names, |
|
| 41 | -+ | ||
| 215 | +5x |
- #'+ afun = afun, |
|
| 42 | -+ | ||
| 216 | +5x |
- #' @return The summary of a linear model.+ na_str = na_str, |
|
| 43 | -+ | ||
| 217 | +5x |
- #'+ nested = nested, |
|
| 44 | -+ | ||
| 218 | +5x |
- #' @examples+ extra_args = extra_args |
|
| 45 | +219 |
- #' h_ancova(+ ) |
|
| 46 | +220 |
- #' .var = "Sepal.Length",+ } |
| 47 | +1 |
- #' .df_row = iris,+ #' Count patients with abnormal analysis range values by baseline status |
||
| 48 | +2 |
- #' variables = list(arm = "Species", covariates = c("Petal.Length * Petal.Width", "Sepal.Width"))
+ #' |
||
| 49 | +3 |
- #' )+ #' @description `r lifecycle::badge("stable")`
|
||
| 50 | +4 |
#' |
||
| 51 | +5 |
- #' @export+ #' The analyze function [count_abnormal_by_baseline()] creates a layout element to count patients with abnormal |
||
| 52 | +6 |
- h_ancova <- function(.var,+ #' analysis range values, categorized by baseline status. |
||
| 53 | +7 |
- .df_row,+ #' |
||
| 54 | +8 |
- variables,+ #' This function analyzes primary analysis variable `var` which indicates abnormal range results. Additional |
||
| 55 | +9 |
- interaction_item = NULL) {
- |
- ||
| 56 | -27x | -
- checkmate::assert_string(.var)- |
- ||
| 57 | -27x | -
- checkmate::assert_list(variables)- |
- ||
| 58 | -27x | -
- checkmate::assert_subset(names(variables), c("arm", "covariates"))
- |
- ||
| 59 | -27x | -
- assert_df_with_variables(.df_row, list(rsp = .var))+ #' analysis variables that can be supplied as a list via the `variables` parameter are `id` (defaults to |
||
| 60 | +10 | - - | -||
| 61 | -26x | -
- arm <- variables$arm- |
- ||
| 62 | -26x | -
- covariates <- variables$covariates- |
- ||
| 63 | -26x | -
- if (!is.null(covariates) && length(covariates) > 0) {
+ #' `USUBJID`), a variable to indicate unique subject identifiers, and `baseline` (defaults to `BNRIND`), a |
||
| 64 | +11 |
- # Get all covariate variable names in the model.- |
- ||
| 65 | -11x | -
- var_list <- get_covariates(covariates)- |
- ||
| 66 | -11x | -
- assert_df_with_variables(.df_row, var_list)+ #' variable to indicate baseline reference ranges. |
||
| 67 | +12 |
- }+ #' |
||
| 68 | +13 | - - | -||
| 69 | -25x | -
- covariates_part <- paste(covariates, collapse = " + ")- |
- ||
| 70 | -25x | -
- if (covariates_part != "") {
- |
- ||
| 71 | -10x | -
- formula <- stats::as.formula(paste0(.var, " ~ ", covariates_part, " + ", arm))+ #' For each direction specified via the `abnormal` parameter (e.g. High or Low), we condition on baseline |
||
| 72 | +14 |
- } else {
- |
- ||
| 73 | -15x | -
- formula <- stats::as.formula(paste0(.var, " ~ ", arm))+ #' range result and count patients in the numerator and denominator as follows for each of the following |
||
| 74 | +15 |
- }+ #' categories: |
||
| 75 | +16 | - - | -||
| 76 | -25x | -
- if (is.null(interaction_item)) {
- |
- ||
| 77 | -21x | -
- specs <- arm+ #' * `Not <abnormality>` |
||
| 78 | +17 |
- } else {
- |
- ||
| 79 | -4x | -
- specs <- c(arm, interaction_item)+ #' * `num`: The number of patients without abnormality at baseline (excluding those with missing baseline) |
||
| 80 | +18 |
- }+ #' and with at least one abnormality post-baseline. |
||
| 81 | +19 | - - | -||
| 82 | -25x | -
- lm_fit <- stats::lm(- |
- ||
| 83 | -25x | -
- formula = formula,- |
- ||
| 84 | -25x | -
- data = .df_row+ #' * `denom`: The number of patients without abnormality at baseline (excluding those with missing baseline). |
||
| 85 | +20 |
- )- |
- ||
| 86 | -25x | -
- emmeans_fit <- emmeans::emmeans(- |
- ||
| 87 | -25x | -
- lm_fit,+ #' * `<Abnormality>` |
||
| 88 | +21 |
- # Specify here the group variable over which EMM are desired.- |
- ||
| 89 | -25x | -
- specs = specs,+ #' * `num`: The number of patients with abnormality as baseline and at least one abnormality post-baseline. |
||
| 90 | +22 |
- # Pass the data again so that the factor levels of the arm variable can be inferred.- |
- ||
| 91 | -25x | -
- data = .df_row+ #' * `denom`: The number of patients with abnormality at baseline. |
||
| 92 | +23 |
- )+ #' * `Total` |
||
| 93 | +24 | - - | -||
| 94 | -25x | -
- emmeans_fit+ #' * `num`: The number of patients with at least one post-baseline record and at least one abnormality |
||
| 95 | +25 |
- }+ #' post-baseline. |
||
| 96 | +26 |
-
+ #' * `denom`: The number of patients with at least one post-baseline record. |
||
| 97 | +27 |
- #' @describeIn summarize_ancova Statistics function that produces a named list of results+ #' |
||
| 98 | +28 |
- #' of the investigated linear model.+ #' This function assumes that `df` has been filtered to only include post-baseline records. |
||
| 99 | +29 |
#' |
||
| 100 | +30 |
- #' @return+ #' @inheritParams argument_convention |
||
| 101 | +31 |
- #' * `s_ancova()` returns a named list of 5 statistics:+ #' @param abnormal (`character`)\cr values identifying the abnormal range level(s) in `.var`. |
||
| 102 | +32 |
- #' * `n`: Count of complete sample size for the group.+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 103 | +33 |
- #' * `lsmean`: Estimated marginal means in the group.+ #' |
||
| 104 | +34 |
- #' * `lsmean_diff`: Difference in estimated marginal means in comparison to the reference group.+ #' Options are: ``r shQuote(get_stats("abnormal_by_baseline"), type = "sh")``
|
||
| 105 | +35 |
- #' If working with the reference group, this will be empty.+ #' |
||
| 106 | +36 |
- #' * `lsmean_diff_ci`: Confidence level for difference in estimated marginal means in comparison+ #' @note |
||
| 107 | +37 |
- #' to the reference group.+ #' * `df` should be filtered to include only post-baseline records. |
||
| 108 | +38 |
- #' * `pval`: p-value (not adjusted for multiple comparisons).+ #' * If the baseline variable or analysis variable contains `NA` records, it is expected that `df` has been |
||
| 109 | +39 |
- #'+ #' pre-processed using [df_explicit_na()] or [explicit_na()]. |
||
| 110 | +40 |
- #' @keywords internal+ #' |
||
| 111 | +41 |
- s_ancova <- function(df,+ #' @seealso Relevant description function [d_count_abnormal_by_baseline()]. |
||
| 112 | +42 |
- .var,+ #' |
||
| 113 | +43 |
- .df_row,+ #' @name abnormal_by_baseline |
||
| 114 | +44 |
- variables,+ #' @order 1 |
||
| 115 | +45 |
- .ref_group,+ NULL |
||
| 116 | +46 |
- .in_ref_col,+ |
||
| 117 | +47 |
- conf_level,+ #' Description function for `s_count_abnormal_by_baseline()` |
||
| 118 | +48 |
- interaction_y = FALSE,+ #' |
||
| 119 | +49 |
- interaction_item = NULL) {
- |
- ||
| 120 | -3x | -
- emmeans_fit <- h_ancova(.var = .var, variables = variables, .df_row = .df_row, interaction_item = interaction_item)+ #' @description `r lifecycle::badge("stable")`
|
||
| 121 | +50 | - - | -||
| 122 | -3x | -
- sum_fit <- summary(- |
- ||
| 123 | -3x | -
- emmeans_fit,- |
- ||
| 124 | -3x | -
- level = conf_level+ #' |
||
| 125 | +51 |
- )+ #' Description function that produces the labels for [s_count_abnormal_by_baseline()]. |
||
| 126 | +52 | - - | -||
| 127 | -3x | -
- arm <- variables$arm+ #' |
||
| 128 | +53 | - - | -||
| 129 | -3x | -
- sum_level <- as.character(unique(df[[arm]]))+ #' @inheritParams abnormal_by_baseline |
||
| 130 | +54 |
-
+ #' |
||
| 131 | +55 |
- # Ensure that there is only one element in sum_level.- |
- ||
| 132 | -3x | -
- checkmate::assert_scalar(sum_level)+ #' @return Abnormal category labels for [s_count_abnormal_by_baseline()]. |
||
| 133 | +56 | - - | -||
| 134 | -2x | -
- sum_fit_level <- sum_fit[sum_fit[[arm]] == sum_level, ]+ #' |
||
| 135 | +57 |
-
+ #' @examples |
||
| 136 | +58 |
- # Get the index of the ref arm- |
- ||
| 137 | -2x | -
- if (interaction_y != FALSE) {
- |
- ||
| 138 | -1x | -
- y <- unlist(df[(df[[interaction_item]] == interaction_y), .var])+ #' d_count_abnormal_by_baseline("LOW")
|
||
| 139 | +59 |
- # convert characters selected in interaction_y into the numeric order- |
- ||
| 140 | -1x | -
- interaction_y <- which(sum_fit_level[[interaction_item]] == interaction_y)+ #' |
||
| 141 | -1x | +|||
| 60 | +
- sum_fit_level <- sum_fit_level[interaction_y, ]+ #' @export |
|||
| 142 | +61 |
- # if interaction is called, reset the index+ d_count_abnormal_by_baseline <- function(abnormal) {
|
||
| 143 | -1x | +62 | +9x |
- ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])])+ not_abn_name <- paste("Not", tolower(abnormal))
|
| 144 | -1x | +63 | +9x |
- ref_key <- tail(ref_key, n = 1)+ abn_name <- paste0(toupper(substr(abnormal, 1, 1)), tolower(substring(abnormal, 2))) |
| 145 | -1x | +64 | +9x |
- ref_key <- (interaction_y - 1) * length(unique(.df_row[[arm]])) + ref_key+ total_name <- "Total" |
| 146 | +65 |
- } else {
+
|
||
| 147 | -1x | +66 | +9x |
- y <- df[[.var]]+ list( |
| 148 | -+ | |||
| 67 | +9x |
- # Get the index of the ref arm when interaction is not called+ not_abnormal = not_abn_name, |
||
| 149 | -1x | +68 | +9x |
- ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])])+ abnormal = abn_name, |
| 150 | -1x | +69 | +9x |
- ref_key <- tail(ref_key, n = 1)+ total = total_name |
| 151 | +70 |
- }+ ) |
||
| 152 | +71 |
-
+ } |
||
| 153 | -2x | +|||
| 72 | +
- if (.in_ref_col) {
+
|
|||
| 154 | -1x | +|||
| 73 | +
- list(+ #' @describeIn abnormal_by_baseline Statistics function for a single `abnormal` level. |
|||
| 155 | -1x | +|||
| 74 | +
- n = length(y[!is.na(y)]),+ #' |
|||
| 156 | -1x | +|||
| 75 | +
- lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"),+ #' @param na_str (`string`)\cr the explicit `na_level` argument you used in the pre-processing steps (maybe with |
|||
| 157 | -1x | +|||
| 76 | +
- lsmean_diff = formatters::with_label(character(), "Difference in Adjusted Means"),+ #' [df_explicit_na()]). The default is `"<Missing>"`. |
|||
| 158 | -1x | +|||
| 77 | +
- lsmean_diff_ci = formatters::with_label(character(), f_conf_level(conf_level)),+ #' |
|||
| 159 | -1x | +|||
| 78 | +
- pval = formatters::with_label(character(), "p-value")+ #' @return |
|||
| 160 | +79 |
- )+ #' * `s_count_abnormal_by_baseline()` returns statistic `fraction` which is a named list with 3 labeled elements: |
||
| 161 | +80 |
- } else {
+ #' `not_abnormal`, `abnormal`, and `total`. Each element contains a vector with `num` and `denom` patient counts. |
||
| 162 | +81 |
- # Estimate the differences between the marginal means.+ #' |
||
| 163 | -1x | +|||
| 82 | +
- emmeans_contrasts <- emmeans::contrast(+ #' @keywords internal |
|||
| 164 | -1x | +|||
| 83 | +
- emmeans_fit,+ s_count_abnormal_by_baseline <- function(df, |
|||
| 165 | +84 |
- # Compare all arms versus the control arm.+ .var, |
||
| 166 | -1x | +|||
| 85 | +
- method = "trt.vs.ctrl",+ abnormal, |
|||
| 167 | +86 |
- # Take the arm factor from .ref_group as the control arm.+ na_str = "<Missing>", |
||
| 168 | -1x | +|||
| 87 | +
- ref = ref_key,+ variables = list(id = "USUBJID", baseline = "BNRIND")) {
|
|||
| 169 | -1x | +88 | +7x |
- level = conf_level+ checkmate::assert_string(.var) |
| 170 | -+ | |||
| 89 | +7x |
- )+ checkmate::assert_string(abnormal) |
||
| 171 | -1x | +90 | +7x |
- sum_contrasts <- summary(+ checkmate::assert_string(na_str) |
| 172 | -1x | +91 | +7x |
- emmeans_contrasts,+ assert_df_with_variables(df, c(range = .var, variables)) |
| 173 | -+ | |||
| 92 | +7x |
- # Derive confidence intervals, t-tests and p-values.+ checkmate::assert_subset(names(variables), c("id", "baseline"))
|
||
| 174 | -1x | +93 | +7x |
- infer = TRUE,+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
|
| 175 | -+ | |||
| 94 | +7x |
- # Do not adjust the p-values for multiplicity.+ checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
|
||
| 176 | -1x | +95 | +7x |
- adjust = "none"+ checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
|
| 177 | +96 |
- )+ |
||
| 178 | +97 |
-
+ # If input is passed as character, changed to factor |
||
| 179 | -1x | +98 | +7x |
- contrast_lvls <- gsub(+ df[[.var]] <- as_factor_keep_attributes(df[[.var]], na_level = na_str) |
| 180 | -1x | +99 | +7x |
- "^\\(|\\)$", "", gsub(paste0(" - \\(*", .ref_group[[arm]][1], ".*"), "", sum_contrasts$contrast)
+ df[[variables$baseline]] <- as_factor_keep_attributes(df[[variables$baseline]], na_level = na_str) |
| 181 | +100 |
- )+ |
||
| 182 | -1x | +101 | +7x |
- if (!is.null(interaction_item)) {
+ assert_valid_factor(df[[.var]], any.missing = FALSE) |
| 183 | -! | +|||
| 102 | +6x |
- sum_contrasts_level <- sum_contrasts[grepl(sum_level, contrast_lvls, fixed = TRUE), ]+ assert_valid_factor(df[[variables$baseline]], any.missing = FALSE) |
||
| 184 | +103 |
- } else {
- |
- ||
| 185 | -1x | -
- sum_contrasts_level <- sum_contrasts[sum_level == contrast_lvls, ]+ |
||
| 186 | +104 |
- }+ # Keep only records with valid analysis value. |
||
| 187 | -1x | -
- if (interaction_y != FALSE) {
- |
- ||
| 188 | -! | -
- sum_contrasts_level <- sum_contrasts_level[interaction_y, ]- |
- ||
| 189 | -+ | 105 | +5x |
- }+ df <- df[df[[.var]] != na_str, ] |
| 190 | +106 | |||
| 191 | -1x | -
- list(- |
- ||
| 192 | -1x | -
- n = length(y[!is.na(y)]),- |
- ||
| 193 | -1x | +107 | +5x |
- lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"),+ anl <- data.frame( |
| 194 | -1x | +108 | +5x |
- lsmean_diff = formatters::with_label(sum_contrasts_level$estimate, "Difference in Adjusted Means"),+ id = df[[variables$id]], |
| 195 | -1x | +109 | +5x |
- lsmean_diff_ci = formatters::with_label(+ var = df[[.var]], |
| 196 | -1x | +110 | +5x |
- c(sum_contrasts_level$lower.CL, sum_contrasts_level$upper.CL),+ baseline = df[[variables$baseline]], |
| 197 | -1x | +111 | +5x |
- f_conf_level(conf_level)+ stringsAsFactors = FALSE |
| 198 | +112 |
- ),+ ) |
||
| 199 | -1x | +|||
| 113 | +
- pval = formatters::with_label(sum_contrasts_level$p.value, "p-value")+ |
|||
| 200 | +114 |
- )+ # Total: |
||
| 201 | +115 |
- }+ # - Patients in denominator: have at least one valid measurement post-baseline. |
||
| 202 | +116 |
- }+ # - Patients in numerator: have at least one abnormality. |
||
| 203 | -+ | |||
| 117 | +5x |
-
+ total_denom <- length(unique(anl$id)) |
||
| 204 | -+ | |||
| 118 | +5x |
- #' @describeIn summarize_ancova Formatted analysis function which is used as `afun` in `summarize_ancova()`.+ total_num <- length(unique(anl$id[anl$var == abnormal])) |
||
| 205 | +119 |
- #'+ |
||
| 206 | +120 |
- #' @return+ # Baseline NA records are counted only in total rows. |
||
| 207 | -+ | |||
| 121 | +5x |
- #' * `a_ancova()` returns the corresponding list with formatted [rtables::CellValue()].+ anl <- anl[anl$baseline != na_str, ] |
||
| 208 | +122 |
- #'+ |
||
| 209 | +123 |
- #' @keywords internal+ # Abnormal: |
||
| 210 | +124 |
- a_ancova <- make_afun(+ # - Patients in denominator: have abnormality at baseline. |
||
| 211 | +125 |
- s_ancova,+ # - Patients in numerator: have abnormality at baseline AND |
||
| 212 | +126 |
- .indent_mods = c("n" = 0L, "lsmean" = 0L, "lsmean_diff" = 0L, "lsmean_diff_ci" = 1L, "pval" = 1L),
+ # have at least one abnormality post-baseline. |
||
| 213 | -+ | |||
| 127 | +5x |
- .formats = c(+ abn_denom <- length(unique(anl$id[anl$baseline == abnormal])) |
||
| 214 | -+ | |||
| 128 | +5x |
- "n" = "xx",+ abn_num <- length(unique(anl$id[anl$baseline == abnormal & anl$var == abnormal])) |
||
| 215 | +129 |
- "lsmean" = "xx.xx",+ |
||
| 216 | +130 |
- "lsmean_diff" = "xx.xx",+ # Not abnormal: |
||
| 217 | +131 |
- "lsmean_diff_ci" = "(xx.xx, xx.xx)",+ # - Patients in denominator: do not have abnormality at baseline. |
||
| 218 | +132 |
- "pval" = "x.xxxx | (<0.0001)"+ # - Patients in numerator: do not have abnormality at baseline AND |
||
| 219 | +133 |
- ),+ # have at least one abnormality post-baseline. |
||
| 220 | -+ | |||
| 134 | +5x |
- .null_ref_cells = FALSE+ not_abn_denom <- length(unique(anl$id[anl$baseline != abnormal])) |
||
| 221 | -+ | |||
| 135 | +5x |
- )+ not_abn_num <- length(unique(anl$id[anl$baseline != abnormal & anl$var == abnormal])) |
||
| 222 | +136 | |||
| 223 | -+ | |||
| 137 | +5x |
- #' @describeIn summarize_ancova Layout-creating function which can take statistics function arguments+ labels <- d_count_abnormal_by_baseline(abnormal) |
||
| 224 | -+ | |||
| 138 | +5x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ list(fraction = list( |
||
| 225 | -+ | |||
| 139 | +5x |
- #'+ not_abnormal = formatters::with_label(c(num = not_abn_num, denom = not_abn_denom), labels$not_abnormal), |
||
| 226 | -+ | |||
| 140 | +5x |
- #' @return+ abnormal = formatters::with_label(c(num = abn_num, denom = abn_denom), labels$abnormal), |
||
| 227 | -+ | |||
| 141 | +5x |
- #' * `summarize_ancova()` returns a layout object suitable for passing to further layouting functions,+ total = formatters::with_label(c(num = total_num, denom = total_denom), labels$total) |
||
| 228 | +142 |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ )) |
||
| 229 | +143 |
- #' the statistics from `s_ancova()` to the table layout.+ } |
||
| 230 | +144 |
- #'+ |
||
| 231 | +145 |
- #' @examples+ #' @describeIn abnormal_by_baseline Formatted analysis function which is used as `afun` |
||
| 232 | +146 |
- #' basic_table() %>%+ #' in `count_abnormal_by_baseline()`. |
||
| 233 | +147 |
- #' split_cols_by("Species", ref_group = "setosa") %>%
+ #' |
||
| 234 | +148 |
- #' add_colcounts() %>%+ #' @return |
||
| 235 | +149 |
- #' summarize_ancova(+ #' * `a_count_abnormal_by_baseline()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 236 | +150 |
- #' vars = "Petal.Length",+ #' |
||
| 237 | +151 |
- #' variables = list(arm = "Species", covariates = NULL),+ #' @keywords internal |
||
| 238 | +152 |
- #' table_names = "unadj",+ a_count_abnormal_by_baseline <- make_afun( |
||
| 239 | +153 |
- #' conf_level = 0.95, var_labels = "Unadjusted comparison",+ s_count_abnormal_by_baseline, |
||
| 240 | +154 |
- #' .labels = c(lsmean = "Mean", lsmean_diff = "Difference in Means")+ .formats = c(fraction = format_fraction) |
||
| 241 | +155 |
- #' ) %>%+ ) |
||
| 242 | +156 |
- #' summarize_ancova(+ |
||
| 243 | +157 |
- #' vars = "Petal.Length",+ #' @describeIn abnormal_by_baseline Layout-creating function which can take statistics function arguments |
||
| 244 | +158 |
- #' variables = list(arm = "Species", covariates = c("Sepal.Length", "Sepal.Width")),
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
||
| 245 | +159 |
- #' table_names = "adj",+ #' |
||
| 246 | +160 |
- #' conf_level = 0.95, var_labels = "Adjusted comparison (covariates: Sepal.Length and Sepal.Width)"+ #' @return |
||
| 247 | +161 |
- #' ) %>%+ #' * `count_abnormal_by_baseline()` returns a layout object suitable for passing to further layouting functions, |
||
| 248 | +162 |
- #' build_table(iris)+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
||
| 249 | +163 |
- #'+ #' the statistics from `s_count_abnormal_by_baseline()` to the table layout. |
||
| 250 | +164 |
- #' @export+ #' |
||
| 251 | +165 |
- #' @order 2+ #' @examples |
||
| 252 | +166 |
- summarize_ancova <- function(lyt,+ #' df <- data.frame( |
||
| 253 | +167 |
- vars,+ #' USUBJID = as.character(c(1:6)), |
||
| 254 | +168 |
- variables,+ #' ANRIND = factor(c(rep("LOW", 4), "NORMAL", "HIGH")),
|
||
| 255 | +169 |
- conf_level,+ #' BNRIND = factor(c("LOW", "NORMAL", "HIGH", NA, "LOW", "NORMAL"))
|
||
| 256 | +170 |
- interaction_y = FALSE,+ #' ) |
||
| 257 | +171 |
- interaction_item = NULL,+ #' df <- df_explicit_na(df) |
||
| 258 | +172 |
- var_labels,+ #' |
||
| 259 | +173 |
- na_str = default_na_str(),+ #' # Layout creating function. |
||
| 260 | +174 |
- nested = TRUE,+ #' basic_table() %>% |
||
| 261 | +175 |
- ...,+ #' count_abnormal_by_baseline(var = "ANRIND", abnormal = c(High = "HIGH")) %>% |
||
| 262 | +176 |
- show_labels = "visible",+ #' build_table(df) |
||
| 263 | +177 |
- table_names = vars,+ #' |
||
| 264 | +178 |
- .stats = NULL,+ #' # Passing of statistics function and formatting arguments. |
||
| 265 | +179 |
- .formats = NULL,+ #' df2 <- data.frame( |
||
| 266 | +180 |
- .labels = NULL,+ #' ID = as.character(c(1, 2, 3, 4)), |
||
| 267 | +181 |
- .indent_mods = NULL) {
- |
- ||
| 268 | -7x | -
- extra_args <- list(- |
- ||
| 269 | -7x | -
- variables = variables, conf_level = conf_level, interaction_y = interaction_y,- |
- ||
| 270 | -7x | -
- interaction_item = interaction_item, ...+ #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
|
||
| 271 | +182 |
- )+ #' BLRANGE = factor(c("LOW", "HIGH", "HIGH", "NORMAL"))
|
||
| 272 | +183 | - - | -||
| 273 | -7x | -
- afun <- make_afun(- |
- ||
| 274 | -7x | -
- a_ancova,- |
- ||
| 275 | -7x | -
- interaction_y = interaction_y,- |
- ||
| 276 | -7x | -
- interaction_item = interaction_item,- |
- ||
| 277 | -7x | -
- .stats = .stats,- |
- ||
| 278 | -7x | -
- .formats = .formats,- |
- ||
| 279 | -7x | -
- .labels = .labels,- |
- ||
| 280 | -7x | -
- .indent_mods = .indent_mods+ #' ) |
||
| 281 | +184 |
- )+ #' |
||
| 282 | +185 |
-
+ #' basic_table() %>% |
||
| 283 | -7x | +|||
| 186 | +
- analyze(+ #' count_abnormal_by_baseline( |
|||
| 284 | -7x | +|||
| 187 | +
- lyt,+ #' var = "RANGE", |
|||
| 285 | -7x | +|||
| 188 | +
- vars,+ #' abnormal = c(Low = "LOW"), |
|||
| 286 | -7x | +|||
| 189 | +
- var_labels = var_labels,+ #' variables = list(id = "ID", baseline = "BLRANGE"), |
|||
| 287 | -7x | +|||
| 190 | +
- show_labels = show_labels,+ #' .formats = c(fraction = "xx / xx"), |
|||
| 288 | -7x | +|||
| 191 | +
- table_names = table_names,+ #' .indent_mods = c(fraction = 2L) |
|||
| 289 | -7x | +|||
| 192 | +
- afun = afun,+ #' ) %>% |
|||
| 290 | -7x | +|||
| 193 | +
- na_str = na_str,+ #' build_table(df2) |
|||
| 291 | -7x | +|||
| 194 | +
- nested = nested,+ #' |
|||
| 292 | -7x | +|||
| 195 | +
- extra_args = extra_args+ #' @export |
|||
| 293 | +196 |
- )+ #' @order 2 |
||
| 294 | +197 |
- }+ count_abnormal_by_baseline <- function(lyt, |
| 1 | +198 |
- #' Count specific values+ var, |
|
| 2 | +199 |
- #'+ abnormal, |
|
| 3 | +200 |
- #' @description `r lifecycle::badge("stable")`
+ variables = list(id = "USUBJID", baseline = "BNRIND"), |
|
| 4 | +201 |
- #'+ na_str = "<Missing>", |
|
| 5 | +202 |
- #' The analyze function [count_values()] creates a layout element to calculate counts of specific values within a+ nested = TRUE, |
|
| 6 | +203 |
- #' variable of interest.+ ..., |
|
| 7 | +204 |
- #'+ table_names = abnormal, |
|
| 8 | +205 |
- #' This function analyzes one or more variables of interest supplied as a vector to `vars`. Values to+ .stats = NULL, |
|
| 9 | +206 |
- #' count for variable(s) in `vars` can be given as a vector via the `values` argument. One row of+ .formats = NULL, |
|
| 10 | +207 |
- #' counts will be generated for each variable.+ .labels = NULL, |
|
| 11 | +208 |
- #'+ .indent_mods = NULL) {
|
|
| 12 | -+ | ||
| 209 | +2x |
- #' @inheritParams argument_convention+ checkmate::assert_character(abnormal, len = length(table_names), names = "named") |
|
| 13 | -+ | ||
| 210 | +2x |
- #' @param values (`character`)\cr specific values that should be counted.+ checkmate::assert_string(var) |
|
| 14 | +211 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ |
|
| 15 | -+ | ||
| 212 | +2x |
- #'+ extra_args <- list(abnormal = abnormal, variables = variables, na_str = na_str, ...) |
|
| 16 | +213 |
- #' Options are: ``r shQuote(get_stats("count_values"))``
+
|
|
| 17 | -+ | ||
| 214 | +2x |
- #'+ afun <- make_afun( |
|
| 18 | -+ | ||
| 215 | +2x |
- #' @note+ a_count_abnormal_by_baseline, |
|
| 19 | -+ | ||
| 216 | +2x |
- #' * For `factor` variables, `s_count_values` checks whether `values` are all included in the levels of `x`+ .stats = .stats, |
|
| 20 | -+ | ||
| 217 | +2x |
- #' and fails otherwise.+ .formats = .formats, |
|
| 21 | -+ | ||
| 218 | +2x |
- #' * For `count_values()`, variable labels are shown when there is more than one element in `vars`,+ .labels = .labels, |
|
| 22 | -+ | ||
| 219 | +2x |
- #' otherwise they are hidden.+ .indent_mods = .indent_mods, |
|
| 23 | -+ | ||
| 220 | +2x |
- #'+ .ungroup_stats = "fraction" |
|
| 24 | +221 |
- #' @name count_values+ ) |
|
| 25 | -+ | ||
| 222 | +2x |
- #' @order 1+ for (i in seq_along(abnormal)) {
|
|
| 26 | -+ | ||
| 223 | +4x |
- NULL+ extra_args[["abnormal"]] <- abnormal[i] |
|
| 27 | +224 | ||
| 28 | -+ | ||
| 225 | +4x |
- #' @describeIn count_values S3 generic function to count values.+ lyt <- analyze( |
|
| 29 | -+ | ||
| 226 | +4x |
- #'+ lyt = lyt, |
|
| 30 | -+ | ||
| 227 | +4x |
- #' @inheritParams s_summary.logical+ vars = var, |
|
| 31 | -+ | ||
| 228 | +4x |
- #'+ var_labels = names(abnormal[i]), |
|
| 32 | -+ | ||
| 229 | +4x |
- #' @return+ afun = afun, |
|
| 33 | -+ | ||
| 230 | +4x |
- #' * `s_count_values()` returns output of [s_summary()] for specified values of a non-numeric variable.+ na_str = na_str, |
|
| 34 | -+ | ||
| 231 | +4x |
- #'+ nested = nested, |
|
| 35 | -+ | ||
| 232 | +4x |
- #' @export+ table_names = table_names[i], |
|
| 36 | -+ | ||
| 233 | +4x |
- s_count_values <- function(x,+ extra_args = extra_args, |
|
| 37 | -+ | ||
| 234 | +4x |
- values,+ show_labels = "visible" |
|
| 38 | +235 |
- na.rm = TRUE, # nolint+ ) |
|
| 39 | +236 |
- denom = c("n", "N_col", "N_row"),
+ }+ |
+ |
| 237 | +2x | +
+ lyt |
|
| 40 | +238 |
- ...) {
+ } |
|
| 41 | -207x | +
| 1 | +
- UseMethod("s_count_values", x)
+ #' Sort pharmacokinetic data by `PARAM` variable |
|||
| 42 | +2 |
- }+ #' |
||
| 43 | +3 |
-
+ #' @description `r lifecycle::badge("stable")`
|
||
| 44 | +4 |
- #' @describeIn count_values Method for `character` class.+ #' |
||
| 45 | +5 |
- #'+ #' @param pk_data (`data.frame`)\cr pharmacokinetic data frame. |
||
| 46 | +6 |
- #' @method s_count_values character+ #' @param key_var (`string`)\cr key variable used to merge pk_data and metadata created by [d_pkparam()]. |
||
| 47 | +7 |
#' |
||
| 48 | +8 |
- #' @examples+ #' @return A pharmacokinetic `data.frame` sorted by a `PARAM` variable. |
||
| 49 | +9 |
- #' # `s_count_values.character`+ #' |
||
| 50 | +10 |
- #' s_count_values(x = c("a", "b", "a"), values = "a")
+ #' @examples |
||
| 51 | +11 |
- #' s_count_values(x = c("a", "b", "a", NA, NA), values = "b", na.rm = FALSE)
+ #' library(dplyr) |
||
| 52 | +12 |
#' |
||
| 53 | +13 |
- #' @export+ #' adpp <- tern_ex_adpp %>% mutate(PKPARAM = factor(paste0(PARAM, " (", AVALU, ")")))
|
||
| 54 | +14 |
- s_count_values.character <- function(x,+ #' pk_ordered_data <- h_pkparam_sort(adpp) |
||
| 55 | +15 |
- values = "Y",+ #' |
||
| 56 | +16 |
- na.rm = TRUE, # nolint+ #' @export |
||
| 57 | +17 |
- ...) {
+ h_pkparam_sort <- function(pk_data, key_var = "PARAMCD") {
|
||
| 58 | -200x | +18 | +4x |
- checkmate::assert_character(values)+ assert_df_with_variables(pk_data, list(key_var = key_var))+ |
+
| 19 | +4x | +
+ pk_data$PARAMCD <- pk_data[[key_var]] |
||
| 59 | +20 | |||
| 60 | -200x | +21 | +4x |
- if (na.rm) {
+ ordered_pk_data <- d_pkparam() |
| 61 | -199x | +|||
| 22 | +
- x <- x[!is.na(x)]+ |
|||
| 62 | +23 |
- }+ # Add the numeric values from ordered_pk_data to pk_data+ |
+ ||
| 24 | +4x | +
+ joined_data <- merge(pk_data, ordered_pk_data, by = "PARAMCD", suffixes = c("", ".y"))
|
||
| 63 | +25 | |||
| 64 | -200x | +26 | +4x |
- is_in_values <- x %in% values+ joined_data <- joined_data[, -grep(".*.y$", colnames(joined_data))]
|
| 65 | +27 | |||
| 66 | -200x | +28 | +4x |
- s_summary(is_in_values, na_rm = na.rm, ...)+ joined_data$TLG_ORDER <- as.numeric(joined_data$TLG_ORDER) |
| 67 | +29 |
- }+ |
||
| 68 | +30 |
-
+ # Then order PARAM based on this column |
||
| 69 | -+ | |||
| 31 | +4x |
- #' @describeIn count_values Method for `factor` class. This makes an automatic+ joined_data$PARAM <- factor(joined_data$PARAM, |
||
| 70 | -+ | |||
| 32 | +4x |
- #' conversion to `character` and then forwards to the method for characters.+ levels = unique(joined_data$PARAM[order(joined_data$TLG_ORDER)]), |
||
| 71 | -+ | |||
| 33 | +4x |
- #'+ ordered = TRUE |
||
| 72 | +34 |
- #' @method s_count_values factor+ ) |
||
| 73 | +35 |
- #'+ |
||
| 74 | -+ | |||
| 36 | +4x |
- #' @examples+ joined_data$TLG_DISPLAY <- factor(joined_data$TLG_DISPLAY,+ |
+ ||
| 37 | +4x | +
+ levels = unique(joined_data$TLG_DISPLAY[order(joined_data$TLG_ORDER)]),+ |
+ ||
| 38 | +4x | +
+ ordered = TRUE |
||
| 75 | +39 |
- #' # `s_count_values.factor`+ ) |
||
| 76 | +40 |
- #' s_count_values(x = factor(c("a", "b", "a")), values = "a")
+
+ |
+ ||
| 41 | +4x | +
+ joined_data |
||
| 77 | +42 |
- #'+ } |
| 78 | +1 |
- #' @export+ #' Summarize analysis of covariance (ANCOVA) results |
||
| 79 | +2 |
- s_count_values.factor <- function(x,+ #' |
||
| 80 | +3 |
- values = "Y",+ #' @description `r lifecycle::badge("stable")`
|
||
| 81 | +4 |
- ...) {
+ #' |
||
| 82 | -4x | +|||
| 5 | +
- s_count_values(as.character(x), values = as.character(values), ...)+ #' The analyze function [summarize_ancova()] creates a layout element to summarize ANCOVA results. |
|||
| 83 | +6 |
- }+ #' |
||
| 84 | +7 |
-
+ #' This function can be used to analyze multiple endpoints and/or multiple timepoints within the response variable(s) |
||
| 85 | +8 |
- #' @describeIn count_values Method for `logical` class.+ #' specified as `vars`. |
||
| 86 | +9 |
#' |
||
| 87 | +10 |
- #' @method s_count_values logical+ #' Additional variables for the analysis, namely an arm (grouping) variable and covariate variables, can be defined |
||
| 88 | +11 |
- #'+ #' via the `variables` argument. See below for more details on how to specify `variables`. An interaction term can |
||
| 89 | +12 |
- #' @examples+ #' be implemented in the model if needed. The interaction variable that should interact with the arm variable is |
||
| 90 | +13 |
- #' # `s_count_values.logical`+ #' specified via the `interaction_term` parameter, and the specific value of `interaction_term` for which to extract |
||
| 91 | +14 |
- #' s_count_values(x = c(TRUE, FALSE, TRUE))+ #' the ANCOVA results via the `interaction_y` parameter. |
||
| 92 | +15 |
#' |
||
| 93 | +16 |
- #' @export+ #' @inheritParams h_ancova |
||
| 94 | +17 |
- s_count_values.logical <- function(x, values = TRUE, ...) {
+ #' @inheritParams argument_convention |
||
| 95 | -3x | +|||
| 18 | +
- checkmate::assert_logical(values)+ #' @param interaction_y (`string` or `flag`)\cr a selected item inside of the `interaction_item` variable which will be |
|||
| 96 | -3x | +|||
| 19 | +
- s_count_values(as.character(x), values = as.character(values), ...)+ #' used to select the specific ANCOVA results. if the interaction is not needed, the default option is `FALSE`. |
|||
| 97 | +20 |
- }+ #' @param .stats (`character`)\cr statistics to select for the table. |
||
| 98 | +21 |
-
+ #' |
||
| 99 | +22 |
- #' @describeIn count_values Formatted analysis function which is used as `afun`+ #' Options are: ``r shQuote(get_stats("summarize_ancova"), type = "sh")``
|
||
| 100 | +23 |
- #' in `count_values()`.+ #' |
||
| 101 | +24 |
- #'+ #' @name summarize_ancova |
||
| 102 | +25 |
- #' @return+ #' @order 1 |
||
| 103 | +26 |
- #' * `a_count_values()` returns the corresponding list with formatted [rtables::CellValue()].+ NULL |
||
| 104 | +27 |
- #'+ |
||
| 105 | +28 |
- #' @examples+ #' Helper function to return results of a linear model |
||
| 106 | +29 |
- #' # `a_count_values`+ #' |
||
| 107 | +30 |
- #' a_count_values(x = factor(c("a", "b", "a")), values = "a", .N_col = 10, .N_row = 10)
+ #' @description `r lifecycle::badge("stable")`
|
||
| 108 | +31 |
#' |
||
| 109 | +32 |
- #' @export+ #' @inheritParams argument_convention |
||
| 110 | +33 |
- a_count_values <- function(x,+ #' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called in `.var` and `variables`. |
||
| 111 | +34 |
- ...,+ #' @param variables (named `list` of `string`)\cr list of additional analysis variables, with expected elements: |
||
| 112 | +35 |
- .stats = NULL,+ #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be |
||
| 113 | +36 |
- .formats = NULL,+ #' summarized. Specifically, the first level of `arm` variable is taken as the reference group. |
||
| 114 | +37 |
- .labels = NULL,+ #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as `"X1"`), and/or |
||
| 115 | +38 |
- .indent_mods = NULL) {
+ #' interaction terms indicated by `"X1 * X2"`. |
||
| 116 | -17x | +|||
| 39 | +
- dots_extra_args <- list(...)+ #' @param interaction_item (`string` or `NULL`)\cr name of the variable that should have interactions |
|||
| 117 | +40 |
-
+ #' with arm. if the interaction is not needed, the default option is `NULL`. |
||
| 118 | +41 |
- # Check for user-defined functions+ #' |
||
| 119 | -17x | +|||
| 42 | +
- default_and_custom_stats_list <- .split_std_from_custom_stats(.stats)+ #' @return The summary of a linear model. |
|||
| 120 | -17x | +|||
| 43 | +
- .stats <- default_and_custom_stats_list$default_stats+ #' |
|||
| 121 | -17x | +|||
| 44 | +
- custom_stat_functions <- default_and_custom_stats_list$custom_stats+ #' @examples |
|||
| 122 | +45 |
-
+ #' h_ancova( |
||
| 123 | +46 |
- # Add extra parameters to the s_* function+ #' .var = "Sepal.Length", |
||
| 124 | -17x | +|||
| 47 | +
- extra_afun_params <- retrieve_extra_afun_params(+ #' .df_row = iris, |
|||
| 125 | -17x | +|||
| 48 | +
- names(dots_extra_args$.additional_fun_parameters)+ #' variables = list(arm = "Species", covariates = c("Petal.Length * Petal.Width", "Sepal.Width"))
|
|||
| 126 | +49 |
- )+ #' ) |
||
| 127 | -17x | +|||
| 50 | +
- dots_extra_args$.additional_fun_parameters <- NULL+ #' |
|||
| 128 | +51 |
-
+ #' @export |
||
| 129 | +52 |
- # Main statistic calculations+ h_ancova <- function(.var, |
||
| 130 | -17x | +|||
| 53 | +
- x_stats <- .apply_stat_functions(+ .df_row, |
|||
| 131 | -17x | +|||
| 54 | +
- default_stat_fnc = s_count_values,+ variables, |
|||
| 132 | -17x | +|||
| 55 | +
- custom_stat_fnc_list = custom_stat_functions,+ interaction_item = NULL) {
|
|||
| 133 | -17x | +56 | +27x |
- args_list = c(+ checkmate::assert_string(.var) |
| 134 | -17x | +57 | +27x |
- x = list(x),+ checkmate::assert_list(variables) |
| 135 | -17x | +58 | +27x |
- extra_afun_params,+ checkmate::assert_subset(names(variables), c("arm", "covariates"))
|
| 136 | -17x | -
- dots_extra_args- |
- ||
| 137 | -- |
- )- |
- ||
| 138 | -+ | 59 | +27x |
- )+ assert_df_with_variables(.df_row, list(rsp = .var)) |
| 139 | +60 | |||
| 140 | -- |
- # Fill in formatting defaults- |
- ||
| 141 | -17x | +61 | +26x |
- .stats <- c(+ arm <- variables$arm |
| 142 | -17x | +62 | +26x |
- get_stats("analyze_vars_counts", stats_in = .stats),
+ covariates <- variables$covariates |
| 143 | -17x | +63 | +26x |
- names(custom_stat_functions) # Additional stats from custom functions+ if (!is.null(covariates) && length(covariates) > 0) {
|
| 144 | +64 |
- )- |
- ||
| 145 | -17x | -
- .formats <- get_formats_from_stats(.stats, .formats)+ # Get all covariate variable names in the model. |
||
| 146 | -17x | +65 | +11x |
- .labels <- get_labels_from_stats(.stats, .labels)+ var_list <- get_covariates(covariates) |
| 147 | -17x | +66 | +11x |
- .indent_mods <- get_indents_from_stats(.stats, .indent_mods)+ assert_df_with_variables(.df_row, var_list) |
| 148 | +67 |
-
+ } |
||
| 149 | +68 |
- # Auto format handling+ |
||
| 150 | -17x | +69 | +25x |
- .formats <- apply_auto_formatting(+ covariates_part <- paste(covariates, collapse = " + ") |
| 151 | -17x | +70 | +25x |
- .formats,+ if (covariates_part != "") {
|
| 152 | -17x | +71 | +10x |
- x_stats,+ formula <- stats::as.formula(paste0(.var, " ~ ", covariates_part, " + ", arm)) |
| 153 | -17x | +|||
| 72 | +
- extra_afun_params$.df_row,+ } else {
|
|||
| 154 | -17x | +73 | +15x |
- extra_afun_params$.var+ formula <- stats::as.formula(paste0(.var, " ~ ", arm)) |
| 155 | +74 |
- )+ } |
||
| 156 | +75 | |||
| 157 | -17x | +76 | +25x |
- in_rows(+ if (is.null(interaction_item)) {
|
| 158 | -17x | +77 | +21x |
- .list = x_stats[.stats],+ specs <- arm |
| 159 | -17x | +|||
| 78 | +
- .formats = .formats,+ } else {
|
|||
| 160 | -17x | +79 | +4x |
- .names = names(.labels),+ specs <- c(arm, interaction_item) |
| 161 | -17x | +|||
| 80 | +
- .labels = .labels,+ }+ |
+ |||
| 81 | ++ | + | ||
| 162 | -17x | +82 | +25x |
- .indent_mods = .indent_mods+ lm_fit <- stats::lm( |
| 163 | -+ | |||
| 83 | +25x |
- )+ formula = formula, |
||
| 164 | -+ | |||
| 84 | +25x |
- }+ data = .df_row |
||
| 165 | +85 |
-
+ ) |
||
| 166 | -+ | |||
| 86 | +25x |
- #' @describeIn count_values Layout-creating function which can take statistics function arguments+ emmeans_fit <- emmeans::emmeans( |
||
| 167 | -+ | |||
| 87 | +25x |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ lm_fit, |
||
| 168 | +88 |
- #'+ # Specify here the group variable over which EMM are desired. |
||
| 169 | -+ | |||
| 89 | +25x |
- #' @return+ specs = specs, |
||
| 170 | +90 |
- #' * `count_values()` returns a layout object suitable for passing to further layouting functions,+ # Pass the data again so that the factor levels of the arm variable can be inferred. |
||
| 171 | -+ | |||
| 91 | +25x |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ data = .df_row |
||
| 172 | +92 |
- #' the statistics from `s_count_values()` to the table layout.+ ) |
||
| 173 | +93 |
- #'+ |
||
| 174 | -+ | |||
| 94 | +25x |
- #' @examples+ emmeans_fit |
||
| 175 | +95 |
- #' # `count_values`+ } |
||
| 176 | +96 |
- #' basic_table() %>%+ |
||
| 177 | +97 |
- #' count_values("Species", values = "setosa") %>%
+ #' @describeIn summarize_ancova Statistics function that produces a named list of results |
||
| 178 | +98 |
- #' build_table(iris)+ #' of the investigated linear model. |
||
| 179 | +99 |
#' |
||
| 180 | +100 |
- #' @export+ #' @return |
||
| 181 | +101 |
- #' @order 2+ #' * `s_ancova()` returns a named list of 5 statistics: |
||
| 182 | +102 |
- count_values <- function(lyt,+ #' * `n`: Count of complete sample size for the group. |
||
| 183 | +103 |
- vars,+ #' * `lsmean`: Estimated marginal means in the group. |
||
| 184 | +104 |
- values,+ #' * `lsmean_diff`: Difference in estimated marginal means in comparison to the reference group. |
||
| 185 | +105 |
- na_str = default_na_str(),+ #' If working with the reference group, this will be empty. |
||
| 186 | +106 |
- na_rm = TRUE,+ #' * `lsmean_diff_ci`: Confidence level for difference in estimated marginal means in comparison |
||
| 187 | +107 |
- nested = TRUE,+ #' to the reference group. |
||
| 188 | +108 |
- ...,+ #' * `pval`: p-value (not adjusted for multiple comparisons). |
||
| 189 | +109 |
- table_names = vars,+ #' |
||
| 190 | +110 |
- .stats = "count_fraction",+ #' @keywords internal |
||
| 191 | +111 |
- .formats = c(count_fraction = "xx (xx.xx%)", count = "xx"),+ s_ancova <- function(df, |
||
| 192 | +112 |
- .labels = c(count_fraction = paste(values, collapse = ", ")),+ .var, |
||
| 193 | +113 |
- .indent_mods = NULL) {
+ .df_row, |
||
| 194 | +114 |
- # Process extra args- |
- ||
| 195 | -8x | -
- extra_args <- list(".stats" = .stats)
- |
- ||
| 196 | -8x | -
- if (!is.null(.formats)) extra_args[[".formats"]] <- .formats- |
- ||
| 197 | -8x | -
- if (!is.null(.labels)) extra_args[[".labels"]] <- .labels- |
- ||
| 198 | -! | -
- if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods+ variables, |
||
| 199 | +115 |
-
+ .ref_group, |
||
| 200 | +116 |
- # Add additional arguments to the analysis function- |
- ||
| 201 | -8x | -
- extra_args <- c(extra_args, "na_rm" = na_rm, "values" = list(values), ...)+ .in_ref_col, |
||
| 202 | +117 |
-
+ conf_level, |
||
| 203 | +118 |
- # Adding additional info from layout to analysis function+ interaction_y = FALSE, |
||
| 204 | -8x | +|||
| 119 | +
- extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE)+ interaction_item = NULL) {
|
|||
| 205 | -8x | +120 | +3x |
- formals(a_count_values) <- c(formals(a_count_values), extra_args[[".additional_fun_parameters"]])+ emmeans_fit <- h_ancova(.var = .var, variables = variables, .df_row = .df_row, interaction_item = interaction_item) |
| 206 | +121 | |||
| 207 | -8x | -
- analyze(- |
- ||
| 208 | -8x | -
- lyt,- |
- ||
| 209 | -8x | -
- vars,- |
- ||
| 210 | -8x | -
- afun = a_count_values,- |
- ||
| 211 | -8x | -
- na_str = na_str,- |
- ||
| 212 | -8x | -
- nested = nested,- |
- ||
| 213 | -8x | +122 | +3x |
- extra_args = extra_args,+ sum_fit <- summary( |
| 214 | -8x | +123 | +3x |
- show_labels = ifelse(length(vars) > 1, "visible", "hidden"),+ emmeans_fit, |
| 215 | -8x | +124 | +3x |
- table_names = table_names+ level = conf_level |
| 216 | +125 |
) |
||
| 217 | -- |
- }- |
-
| 1 | -- |
- #' Bland-Altman analysis- |
- ||
| 2 | -- |
- #'- |
- ||
| 3 | -- |
- #' @description `r lifecycle::badge("experimental")`
- |
- ||
| 4 | -- |
- #'- |
- ||
| 5 | -- |
- #' Statistics function that uses the Bland-Altman method to assess the agreement between two numerical vectors- |
- ||
| 6 | -- |
- #' and calculates a variety of statistics.- |
- ||
| 7 | +126 |
- #'+ |
||
| 8 | -+ | |||
| 127 | +3x |
- #' @inheritParams argument_convention+ arm <- variables$arm |
||
| 9 | +128 |
- #' @param y (`numeric`)\cr vector of numbers we want to analyze, to be compared with `x`.+ |
||
| 10 | -+ | |||
| 129 | +3x |
- #'+ sum_level <- as.character(unique(df[[arm]])) |
||
| 11 | +130 |
- #' @return+ |
||
| 12 | +131 |
- #' A named list of the following elements:+ # Ensure that there is only one element in sum_level. |
||
| 13 | -+ | |||
| 132 | +3x |
- #' * `df`+ checkmate::assert_scalar(sum_level) |
||
| 14 | +133 |
- #' * `difference_mean`+ |
||
| 15 | -+ | |||
| 134 | +2x |
- #' * `ci_mean`+ sum_fit_level <- sum_fit[sum_fit[[arm]] == sum_level, ] |
||
| 16 | +135 |
- #' * `difference_sd`+ |
||
| 17 | +136 |
- #' * `difference_se`+ # Get the index of the ref arm |
||
| 18 | -+ | |||
| 137 | +2x |
- #' * `upper_agreement_limit`+ if (interaction_y != FALSE) {
|
||
| 19 | -+ | |||
| 138 | +1x |
- #' * `lower_agreement_limit`+ y <- unlist(df[(df[[interaction_item]] == interaction_y), .var]) |
||
| 20 | +139 |
- #' * `agreement_limit_se`+ # convert characters selected in interaction_y into the numeric order |
||
| 21 | -+ | |||
| 140 | +1x |
- #' * `upper_agreement_limit_ci`+ interaction_y <- which(sum_fit_level[[interaction_item]] == interaction_y) |
||
| 22 | -+ | |||
| 141 | +1x |
- #' * `lower_agreement_limit_ci`+ sum_fit_level <- sum_fit_level[interaction_y, ] |
||
| 23 | +142 |
- #' * `t_value`+ # if interaction is called, reset the index |
||
| 24 | -+ | |||
| 143 | +1x |
- #' * `n`+ ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])]) |
||
| 25 | -+ | |||
| 144 | +1x |
- #'+ ref_key <- tail(ref_key, n = 1) |
||
| 26 | -+ | |||
| 145 | +1x |
- #' @examples+ ref_key <- (interaction_y - 1) * length(unique(.df_row[[arm]])) + ref_key |
||
| 27 | +146 |
- #' x <- seq(1, 60, 5)+ } else {
|
||
| 28 | -+ | |||
| 147 | +1x |
- #' y <- seq(5, 50, 4)+ y <- df[[.var]] |
||
| 29 | +148 |
- #'+ # Get the index of the ref arm when interaction is not called |
||
| 30 | -+ | |||
| 149 | +1x |
- #' s_bland_altman(x, y, conf_level = 0.9)+ ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])]) |
||
| 31 | -+ | |||
| 150 | +1x |
- #'+ ref_key <- tail(ref_key, n = 1) |
||
| 32 | +151 |
- #' @export+ } |
||
| 33 | +152 |
- s_bland_altman <- function(x, y, conf_level = 0.95) {
+
|
||
| 34 | -7x | +153 | +2x |
- checkmate::assert_numeric(x, min.len = 1, any.missing = TRUE)+ if (.in_ref_col) {
|
| 35 | -6x | +154 | +1x |
- checkmate::assert_numeric(y, len = length(x), any.missing = TRUE)+ list( |
| 36 | -5x | -
- checkmate::assert_numeric(conf_level, lower = 0, upper = 1, any.missing = TRUE)- |
- ||
| 37 | -+ | 155 | +1x |
-
+ n = length(y[!is.na(y)]), |
| 38 | -4x | +156 | +1x |
- alpha <- 1 - conf_level+ lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"), |
| 39 | -+ | |||
| 157 | +1x |
-
+ lsmean_diff = formatters::with_label(character(), "Difference in Adjusted Means"), |
||
| 40 | -4x | +158 | +1x |
- ind <- complete.cases(x, y) # use only pairwise complete observations, and check if x and y have the same length+ lsmean_diff_ci = formatters::with_label(character(), f_conf_level(conf_level)), |
| 41 | -4x | +159 | +1x |
- x <- x[ind]+ pval = formatters::with_label(character(), "p-value") |
| 42 | -4x | +|||
| 160 | +
- y <- y[ind]+ ) |
|||
| 43 | -4x | +|||
| 161 | +
- n <- sum(ind) # number of 'observations'+ } else {
|
|||
| 44 | +162 |
-
+ # Estimate the differences between the marginal means. |
||
| 45 | -4x | +163 | +1x |
- if (n == 0) {
+ emmeans_contrasts <- emmeans::contrast( |
| 46 | -! | +|||
| 164 | +1x |
- stop("there is no valid paired data")
+ emmeans_fit, |
||
| 47 | +165 |
- }+ # Compare all arms versus the control arm.+ |
+ ||
| 166 | +1x | +
+ method = "trt.vs.ctrl", |
||
| 48 | +167 |
-
+ # Take the arm factor from .ref_group as the control arm. |
||
| 49 | -4x | +168 | +1x |
- difference <- x - y # vector of differences+ ref = ref_key, |
| 50 | -4x | +169 | +1x |
- average <- (x + y) / 2 # vector of means+ level = conf_level |
| 51 | -4x | +|||
| 170 | +
- difference_mean <- mean(difference) # mean difference+ ) |
|||
| 52 | -4x | +171 | +1x |
- difference_sd <- sd(difference) # SD of differences+ sum_contrasts <- summary( |
| 53 | -4x | +172 | +1x |
- al <- qnorm(1 - alpha / 2) * difference_sd+ emmeans_contrasts, |
| 54 | -4x | +|||
| 173 | +
- upper_agreement_limit <- difference_mean + al # agreement limits+ # Derive confidence intervals, t-tests and p-values. |
|||
| 55 | -4x | +174 | +1x |
- lower_agreement_limit <- difference_mean - al+ infer = TRUE, |
| 56 | +175 |
-
+ # Do not adjust the p-values for multiplicity. |
||
| 57 | -4x | +176 | +1x |
- difference_se <- difference_sd / sqrt(n) # standard error of the mean+ adjust = "none" |
| 58 | -4x | +|||
| 177 | +
- al_se <- difference_sd * sqrt(3) / sqrt(n) # standard error of the agreement limit+ ) |
|||
| 59 | -4x | +|||
| 178 | +
- tvalue <- qt(1 - alpha / 2, n - 1) # t value for 95% CI calculation+ |
|||
| 60 | -4x | +179 | +1x |
- difference_mean_ci <- difference_se * tvalue+ contrast_lvls <- gsub( |
| 61 | -4x | +180 | +1x |
- al_ci <- al_se * tvalue+ "^\\(|\\)$", "", gsub(paste0(" - \\(*", .ref_group[[arm]][1], ".*"), "", sum_contrasts$contrast)
|
| 62 | -4x | +|||
| 181 | +
- upper_agreement_limit_ci <- c(upper_agreement_limit - al_ci, upper_agreement_limit + al_ci)+ ) |
|||
| 63 | -4x | +182 | +1x |
- lower_agreement_limit_ci <- c(lower_agreement_limit - al_ci, lower_agreement_limit + al_ci)+ if (!is.null(interaction_item)) {
+ |
+
| 183 | +! | +
+ sum_contrasts_level <- sum_contrasts[grepl(sum_level, contrast_lvls, fixed = TRUE), ] |
||
| 64 | +184 |
-
+ } else {
|
||
| 65 | -4x | +185 | +1x |
- list(+ sum_contrasts_level <- sum_contrasts[sum_level == contrast_lvls, ] |
| 66 | -4x | +|||
| 186 | +
- df = data.frame(average, difference),+ } |
|||
| 67 | -4x | +187 | +1x |
- difference_mean = difference_mean,+ if (interaction_y != FALSE) {
|
| 68 | -4x | +|||
| 188 | +! |
- ci_mean = difference_mean + c(-1, 1) * difference_mean_ci,+ sum_contrasts_level <- sum_contrasts_level[interaction_y, ] |
||
| 69 | -4x | +|||
| 189 | +
- difference_sd = difference_sd,+ } |
|||
| 70 | -4x | +|||
| 190 | +
- difference_se = difference_se,+ |
|||
| 71 | -4x | +191 | +1x |
- upper_agreement_limit = upper_agreement_limit,+ list( |
| 72 | -4x | +192 | +1x |
- lower_agreement_limit = lower_agreement_limit,+ n = length(y[!is.na(y)]), |
| 73 | -4x | +193 | +1x |
- agreement_limit_se = al_se,+ lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"), |
| 74 | -4x | +194 | +1x |
- upper_agreement_limit_ci = upper_agreement_limit_ci,+ lsmean_diff = formatters::with_label(sum_contrasts_level$estimate, "Difference in Adjusted Means"), |
| 75 | -4x | +195 | +1x |
- lower_agreement_limit_ci = lower_agreement_limit_ci,+ lsmean_diff_ci = formatters::with_label( |
| 76 | -4x | +196 | +1x |
- t_value = tvalue,+ c(sum_contrasts_level$lower.CL, sum_contrasts_level$upper.CL), |
| 77 | -4x | +197 | +1x |
- n = n+ f_conf_level(conf_level) |
| 78 | +198 |
- )+ ), |
||
| 79 | -+ | |||
| 199 | +1x |
- }+ pval = formatters::with_label(sum_contrasts_level$p.value, "p-value") |
||
| 80 | +200 |
-
+ ) |
||
| 81 | +201 |
- #' Bland-Altman plot+ } |
||
| 82 | +202 |
- #'+ } |
||
| 83 | +203 |
- #' @description `r lifecycle::badge("experimental")`
+
|
||
| 84 | +204 |
- #'+ #' @describeIn summarize_ancova Formatted analysis function which is used as `afun` in `summarize_ancova()`. |
||
| 85 | +205 |
- #' Graphing function that produces a Bland-Altman plot.+ #' |
||
| 86 | +206 |
- #'+ #' @return |
||
| 87 | +207 |
- #' @inheritParams s_bland_altman+ #' * `a_ancova()` returns the corresponding list with formatted [rtables::CellValue()]. |
||
| 88 | +208 |
#' |
||
| 89 | +209 |
- #' @return A `ggplot` Bland-Altman plot.+ #' @keywords internal |
||
| 90 | +210 |
- #'+ a_ancova <- make_afun( |
||
| 91 | +211 |
- #' @examples+ s_ancova, |
||
| 92 | +212 |
- #' x <- seq(1, 60, 5)+ .indent_mods = c("n" = 0L, "lsmean" = 0L, "lsmean_diff" = 0L, "lsmean_diff_ci" = 1L, "pval" = 1L),
|
||
| 93 | +213 |
- #' y <- seq(5, 50, 4)+ .formats = c( |
||
| 94 | +214 |
- #'+ "n" = "xx", |
||
| 95 | +215 |
- #' g_bland_altman(x = x, y = y, conf_level = 0.9)+ "lsmean" = "xx.xx", |
||
| 96 | +216 |
- #'+ "lsmean_diff" = "xx.xx", |
||
| 97 | +217 |
- #' @export+ "lsmean_diff_ci" = "(xx.xx, xx.xx)", |
||
| 98 | +218 |
- #' @aliases bland_altman+ "pval" = "x.xxxx | (<0.0001)" |
||
| 99 | +219 |
- g_bland_altman <- function(x, y, conf_level = 0.95) {
- |
- ||
| 100 | -1x | -
- result_tem <- s_bland_altman(x, y, conf_level = conf_level)+ ), |
||
| 101 | -1x | +|||
| 220 | +
- xpos <- max(result_tem$df$average) * 0.9 + min(result_tem$df$average) * 0.1+ .null_ref_cells = FALSE |
|||
| 102 | -1x | +|||
| 221 | +
- yrange <- diff(range(result_tem$df$difference))+ ) |
|||
| 103 | +222 | |||
| 104 | -1x | -
- p <- ggplot(result_tem$df) +- |
- ||
| 105 | -1x | -
- geom_point(aes(x = average, y = difference), color = "blue") +- |
- ||
| 106 | -1x | -
- geom_hline(yintercept = result_tem$difference_mean, color = "blue", linetype = 1) +- |
- ||
| 107 | -1x | -
- geom_hline(yintercept = 0, color = "blue", linetype = 2) +- |
- ||
| 108 | -1x | -
- geom_hline(yintercept = result_tem$lower_agreement_limit, color = "red", linetype = 2) +- |
- ||
| 109 | -1x | -
- geom_hline(yintercept = result_tem$upper_agreement_limit, color = "red", linetype = 2) +- |
- ||
| 110 | -1x | +|||
| 223 | +
- annotate(+ #' @describeIn summarize_ancova Layout-creating function which can take statistics function arguments |
|||
| 111 | -1x | +|||
| 224 | +
- "text",+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. |
|||
| 112 | -1x | +|||
| 225 | +
- x = xpos,+ #' |
|||
| 113 | -1x | +|||
| 226 | +
- y = result_tem$lower_agreement_limit + 0.03 * yrange,+ #' @return |
|||
| 114 | -1x | +|||
| 227 | +
- label = "lower limits of agreement",+ #' * `summarize_ancova()` returns a layout object suitable for passing to further layouting functions, |
|||
| 115 | -1x | +|||
| 228 | +
- color = "red"+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing |
|||
| 116 | +229 |
- ) ++ #' the statistics from `s_ancova()` to the table layout. |
||
| 117 | -1x | +|||
| 230 | +
- annotate(+ #' |
|||
| 118 | -1x | +|||
| 231 | +
- "text",+ #' @examples |
|||
| 119 | -1x | +|||
| 232 | +
- x = xpos,+ #' basic_table() %>% |
|||
| 120 | -1x | +|||
| 233 | +
- y = result_tem$upper_agreement_limit + 0.03 * yrange,+ #' split_cols_by("Species", ref_group = "setosa") %>%
|
|||
| 121 | -1x | +|||
| 234 | +
- label = "upper limits of agreement",+ #' add_colcounts() %>% |
|||
| 122 | -1x | +|||
| 235 | +
- color = "red"+ #' summarize_ancova( |
|||
| 123 | +236 |
- ) ++ #' vars = "Petal.Length", |
||
| 124 | -1x | +|||
| 237 | +
- annotate(+ #' variables = list(arm = "Species", covariates = NULL), |
|||
| 125 | -1x | +|||
| 238 | +
- "text",+ #' table_names = "unadj", |
|||
| 126 | -1x | +|||
| 239 | +
- x = xpos,+ #' conf_level = 0.95, var_labels = "Unadjusted comparison", |
|||
| 127 | -1x | +|||
| 240 | +
- y = result_tem$difference_mean + 0.03 * yrange,+ #' .labels = c(lsmean = "Mean", lsmean_diff = "Difference in Means") |
|||
| 128 | -1x | +|||
| 241 | +
- label = "mean of difference between two measures",+ #' ) %>% |
|||
| 129 | -1x | +|||
| 242 | +
- color = "blue"+ #' summarize_ancova( |
|||
| 130 | +243 |
- ) ++ #' vars = "Petal.Length", |
||
| 131 | -1x | +|||
| 244 | +
- annotate(+ #' variables = list(arm = "Species", covariates = c("Sepal.Length", "Sepal.Width")),
|
|||
| 132 | -1x | +|||
| 245 | +
- "text",+ #' table_names = "adj", |
|||
| 133 | -1x | +|||
| 246 | +
- x = xpos,+ #' conf_level = 0.95, var_labels = "Adjusted comparison (covariates: Sepal.Length and Sepal.Width)" |
|||
| 134 | -1x | +|||
| 247 | +
- y = result_tem$lower_agreement_limit - 0.03 * yrange,+ #' ) %>% |
|||
| 135 | -1x | +|||
| 248 | +
- label = sprintf("%.2f", result_tem$lower_agreement_limit),
+ #' build_table(iris) |
|||
| 136 | -1x | +|||
| 249 | +
- color = "red"+ #' |
|||
| 137 | +250 |
- ) ++ #' @export |
||
| 138 | -1x | +|||
| 251 | +
- annotate(+ #' @order 2 |
|||
| 139 | -1x | +|||
| 252 | +
- "text",+ summarize_ancova <- function(lyt, |
|||
| 140 | -1x | +|||
| 253 | +
- x = xpos,+ vars, |
|||
| 141 | -1x | +|||
| 254 | +
- y = result_tem$upper_agreement_limit - 0.03 * yrange,+ variables, |
|||
| 142 | -1x | +|||
| 255 | +
- label = sprintf("%.2f", result_tem$upper_agreement_limit),
+ conf_level, |
|||
| 143 | -1x | +|||
| 256 | +
- color = "red"+ interaction_y = FALSE, |
|||
| 144 | +257 |
- ) ++ interaction_item = NULL, |
||
| 145 | -1x | +|||
| 258 | +
- annotate(+ var_labels, |
|||
| 146 | -1x | +|||
| 259 | +
- "text",+ na_str = default_na_str(), |
|||
| 147 | -1x | +|||
| 260 | +
- x = xpos,+ nested = TRUE, |
|||
| 148 | -1x | +|||
| 261 | +
- y = result_tem$difference_mean - 0.03 * yrange,+ ..., |
|||
| 149 | -1x | +|||
| 262 | +
- label = sprintf("%.2f", result_tem$difference_meanm),
+ show_labels = "visible", |
|||
| 150 | -1x | +|||
| 263 | +
- color = "blue"+ table_names = vars, |
|||
| 151 | +264 |
- ) ++ .stats = NULL, |
||
| 152 | -1x | +|||
| 265 | +
- xlab("Average of two measures") +
+ .formats = NULL, |
|||
| 153 | -1x | +|||
| 266 | +
- ylab("Difference between two measures")
+ .labels = NULL, |
|||
| 154 | +267 |
-
+ .indent_mods = NULL) {
|
||
| 155 | -1x | -
- return(p)- |
- ||
| 156 | -+ | 268 | +7x |
- }+ extra_args <- list( |
| 1 | -+ | ||
| 269 | +7x |
- #' Control function for subgroup treatment effect pattern (STEP) calculations+ variables = variables, conf_level = conf_level, interaction_y = interaction_y, |
|
| 2 | -+ | ||
| 270 | +7x |
- #'+ interaction_item = interaction_item, ... |
|
| 3 | +271 |
- #' @description `r lifecycle::badge("stable")`
+ ) |
|
| 4 | +272 |
- #'+ |
|
| 5 | -+ | ||
| 273 | +7x |
- #' This is an auxiliary function for controlling arguments for STEP calculations.+ afun <- make_afun( |
|
| 6 | -+ | ||
| 274 | +7x |
- #'+ a_ancova, |
|
| 7 | -+ | ||
| 275 | +7x |
- #' @param biomarker (`numeric` or `NULL`)\cr optional provision of the numeric biomarker variable, which+ interaction_y = interaction_y, |
|
| 8 | -+ | ||
| 276 | +7x |
- #' could be used to infer `bandwidth`, see below.+ interaction_item = interaction_item, |
|
| 9 | -+ | ||
| 277 | +7x |
- #' @param use_percentile (`flag`)\cr if `TRUE`, the running windows are created according to+ .stats = .stats, |
|
| 10 | -+ | ||
| 278 | +7x |
- #' quantiles rather than actual values, i.e. the bandwidth refers to the percentage of data+ .formats = .formats, |
|
| 11 | -+ | ||
| 279 | +7x |
- #' covered in each window. Suggest `TRUE` if the biomarker variable is not uniformly+ .labels = .labels, |
|
| 12 | -+ | ||
| 280 | +7x |
- #' distributed.+ .indent_mods = .indent_mods |
|
| 13 | +281 |
- #' @param bandwidth (`numeric(1)` or `NULL`)\cr indicating the bandwidth of each window.+ ) |
|
| 14 | +282 |
- #' Depending on the argument `use_percentile`, it can be either the length of actual-value+ |
|
| 15 | -+ | ||
| 283 | +7x |
- #' windows on the real biomarker scale, or percentage windows.+ analyze( |
|
| 16 | -+ | ||
| 284 | +7x |
- #' If `use_percentile = TRUE`, it should be a number between 0 and 1.+ lyt, |
|
| 17 | -+ | ||
| 285 | +7x |
- #' If `NULL`, treat the bandwidth to be infinity, which means only one global model will be fitted.+ vars, |
|
| 18 | -+ | ||
| 286 | +7x |
- #' By default, `0.25` is used for percentage windows and one quarter of the range of the `biomarker`+ var_labels = var_labels, |
|
| 19 | -+ | ||
| 287 | +7x |
- #' variable for actual-value windows.+ show_labels = show_labels, |
|
| 20 | -+ | ||
| 288 | +7x |
- #' @param degree (`integer(1)`)\cr the degree of polynomial function of the biomarker as an interaction term+ table_names = table_names, |
|
| 21 | -+ | ||
| 289 | +7x |
- #' with the treatment arm fitted at each window. If 0 (default), then the biomarker variable+ afun = afun, |
|
| 22 | -+ | ||
| 290 | +7x |
- #' is not included in the model fitted in each biomarker window.+ na_str = na_str, |
|
| 23 | -+ | ||
| 291 | +7x |
- #' @param num_points (`integer(1)`)\cr the number of points at which the hazard ratios are estimated. The+ nested = nested, |
|
| 24 | -+ | ||
| 292 | +7x |
- #' smallest number is 2.+ extra_args = extra_args |
|
| 25 | +293 |
- #'+ ) |
|
| 26 | +294 |
- #' @return A list of components with the same names as the arguments, except `biomarker` which is+ } |
| 27 | +1 |
- #' just used to calculate the `bandwidth` in case that actual biomarker windows are requested.+ #' Control function for incidence rate |
||
| 28 | +2 |
#' |
||
| 29 | +3 |
- #' @examples+ #' @description `r lifecycle::badge("stable")`
|
||
| 30 | +4 |
- #' # Provide biomarker values and request actual values to be used,+ #' |
||
| 31 | +5 |
- #' # so that bandwidth is chosen from range.+ #' This is an auxiliary function for controlling arguments for the incidence rate, used |
||
| 32 | +6 |
- #' control_step(biomarker = 1:10, use_percentile = FALSE)+ #' internally to specify details in `s_incidence_rate()`. |
||
| 33 | +7 |
#' |
||
| 34 | +8 |
- #' # Use a global model with quadratic biomarker interaction term.+ #' @inheritParams argument_convention |
||
| 35 | +9 |
- #' control_step(bandwidth = NULL, degree = 2)+ #' @param conf_type (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar` |
||
| 36 | +10 |
- #'+ #' for confidence interval type. |
||
| 37 | +11 |
- #' # Reduce number of points to be used.+ #' @param input_time_unit (`string`)\cr `day`, `week`, `month`, or `year` (default) |
||
| 38 | +12 |
- #' control_step(num_points = 10)+ #' indicating time unit for data input. |
||
| 39 | +13 |
- #'+ #' @param num_pt_year (`numeric(1)`)\cr number of patient-years to use when calculating adverse event rates. |
||
| 40 | +14 |
- #' @export+ #' |
||
| 41 | +15 |
- control_step <- function(biomarker = NULL,+ #' @return A list of components with the same names as the arguments. |
||
| 42 | +16 |
- use_percentile = TRUE,+ #' |
||
| 43 | +17 |
- bandwidth,+ #' @seealso [incidence_rate] |
||
| 44 | +18 |
- degree = 0L,+ #' |
||
| 45 | +19 |
- num_points = 39L) {
- |
- ||
| 46 | -31x | -
- checkmate::assert_numeric(biomarker, null.ok = TRUE)- |
- ||
| 47 | -30x | -
- checkmate::assert_flag(use_percentile)- |
- ||
| 48 | -30x | -
- checkmate::assert_int(num_points, lower = 2)- |
- ||
| 49 | -29x | -
- checkmate::assert_count(degree)+ #' @examples |
||
| 50 | +20 | - - | -||
| 51 | -29x | -
- if (missing(bandwidth)) {
+ #' control_incidence_rate(0.9, "exact", "month", 100) |
||
| 52 | +21 |
- # Infer bandwidth- |
- ||
| 53 | -21x | -
- bandwidth <- if (use_percentile) {
- |
- ||
| 54 | -18x | -
- 0.25- |
- ||
| 55 | -21x | -
- } else if (!is.null(biomarker)) {
- |
- ||
| 56 | -3x | -
- diff(range(biomarker, na.rm = TRUE)) / 4+ #' |
||
| 57 | +22 |
- } else {
- |
- ||
| 58 | -! | -
- NULL+ #' @export |
||
| 59 | +23 |
- }+ control_incidence_rate <- function(conf_level = 0.95, |
||
| 60 | +24 |
- } else {
+ conf_type = c("normal", "normal_log", "exact", "byar"),
|
||
| 61 | +25 |
- # Check bandwidth- |
- ||
| 62 | -8x | -
- if (!is.null(bandwidth)) {
- |
- ||
| 63 | -5x | -
- if (use_percentile) {
- |
- ||
| 64 | -4x | -
- assert_proportion_value(bandwidth)+ input_time_unit = c("year", "day", "week", "month"),
|
||
| 65 | +26 |
- } else {
+ num_pt_year = 100) {
|
||
| 66 | -1x | +27 | +14x |
- checkmate::assert_scalar(bandwidth)+ conf_type <- match.arg(conf_type) |
| 67 | -1x | +28 | +13x |
- checkmate::assert_true(bandwidth > 0)+ input_time_unit <- match.arg(input_time_unit) |
| 68 | -+ | |||
| 29 | +12x |
- }+ checkmate::assert_number(num_pt_year) |
||
| 69 | -+ | |||
| 30 | +11x |
- }+ assert_proportion_value(conf_level) |
||
| 70 | +31 |
- }+ |
||
| 71 | -28x | +32 | +10x |
list( |
| 72 | -28x | +33 | +10x |
- use_percentile = use_percentile,+ conf_level = conf_level, |
| 73 | -28x | +34 | +10x |
- bandwidth = bandwidth,+ conf_type = conf_type, |
| 74 | -28x | +35 | +10x |
- degree = as.integer(degree),+ input_time_unit = input_time_unit, |
| 75 | -28x | +36 | +10x |
- num_points = as.integer(num_points)+ num_pt_year = num_pt_year |
| 76 | +37 |
) |
||
| 77 | +38 |
}@@ -188917,14 +189665,14 @@ tern coverage - 95.59% |
| 1 |
- #' Class for `CombinationFunction`+ #' Helper function for tabulation of a single biomarker result |
||
| 5 |
- #' `CombinationFunction` is an S4 class which extends standard functions. These are special functions that+ #' Please see [h_tab_surv_one_biomarker()] and [h_tab_rsp_one_biomarker()], which use this function for examples. |
||
| 6 |
- #' can be combined and negated with the logical operators.+ #' This function is a wrapper for [rtables::summarize_row_groups()]. |
||
| 8 |
- #' @param e1 (`CombinationFunction`)\cr left hand side of logical operator.+ #' @inheritParams argument_convention |
||
| 9 |
- #' @param e2 (`CombinationFunction`)\cr right hand side of logical operator.+ #' @param df (`data.frame`)\cr results for a single biomarker. |
||
| 10 |
- #' @param x (`CombinationFunction`)\cr the function which should be negated.+ #' @param afuns (named `list` of `function`)\cr analysis functions. |
||
| 11 |
- #'+ #' @param colvars (named `list`)\cr named list with elements `vars` (variables to tabulate) and `labels` (their labels). |
||
| 12 |
- #' @return A logical value indicating whether the left hand side of the equation equals the right hand side.+ #' |
||
| 13 |
- #'+ #' @return An `rtables` table object with statistics in columns. |
||
| 14 |
- #' @examples+ #' |
||
| 15 |
- #' higher <- function(a) {
+ #' @export |
||
| 16 |
- #' force(a)+ h_tab_one_biomarker <- function(df, |
||
| 17 |
- #' CombinationFunction(+ afuns, |
||
| 18 |
- #' function(x) {
+ colvars, |
||
| 19 |
- #' x > a+ na_str = default_na_str(), |
||
| 20 |
- #' }+ .indent_mods = 0L, |
||
| 21 |
- #' )+ ...) {
|
||
| 22 | -+ | 18x |
- #' }+ extra_args <- list(...) |
| 23 |
- #'+ |
||
| 24 |
- #' lower <- function(b) {
+ # Create "ci" column from "lcl" and "ucl" |
||
| 25 | -+ | 18x |
- #' force(b)+ df$ci <- combine_vectors(df$lcl, df$ucl) |
| 26 |
- #' CombinationFunction(+ |
||
| 27 | -+ | 18x |
- #' function(x) {
+ lyt <- basic_table() |
| 28 |
- #' x < b+ |
||
| 29 |
- #' }+ # Row split by row type - only keep the content rows here. |
||
| 30 | -+ | 18x |
- #' )+ lyt <- split_rows_by( |
| 31 | -+ | 18x |
- #' }+ lyt = lyt, |
| 32 | -+ | 18x |
- #'+ var = "row_type", |
| 33 | -+ | 18x |
- #' c1 <- higher(5)+ split_fun = keep_split_levels("content"),
|
| 34 | -+ | 18x |
- #' c2 <- lower(10)+ nested = FALSE |
| 35 |
- #' c3 <- higher(5) & lower(10)+ ) |
||
| 36 |
- #' c3(7)+ |
||
| 37 |
- #'+ # Summarize rows with all patients. |
||
| 38 | -+ | 18x |
- #' @name combination_function+ lyt <- summarize_row_groups( |
| 39 | -+ | 18x |
- #' @aliases CombinationFunction-class+ lyt = lyt, |
| 40 | -+ | 18x |
- #' @exportClass CombinationFunction+ var = "var_label", |
| 41 | -+ | 18x |
- #' @export CombinationFunction+ cfun = afuns, |
| 42 | -+ | 18x |
- CombinationFunction <- methods::setClass("CombinationFunction", contains = "function") # nolint
+ na_str = na_str, |
| 43 | -+ | 18x |
-
+ indent_mod = .indent_mods, |
| 44 | -+ | 18x |
- #' @describeIn combination_function Logical "AND" combination of `CombinationFunction` functions.+ extra_args = extra_args |
| 45 |
- #' The resulting object is of the same class, and evaluates the two argument functions. The result+ ) |
||
| 46 |
- #' is then the "AND" of the two individual results.+ |
||
| 47 |
- #'+ # Split cols by the multiple variables to populate into columns. |
||
| 48 | -+ | 18x |
- #' @export+ lyt <- split_cols_by_multivar( |
| 49 | -+ | 18x |
- methods::setMethod(+ lyt = lyt, |
| 50 | -+ | 18x |
- "&",+ vars = colvars$vars, |
| 51 | -+ | 18x |
- signature = c(e1 = "CombinationFunction", e2 = "CombinationFunction"),+ varlabels = colvars$labels |
| 52 |
- definition = function(e1, e2) {
+ ) |
||
| 53 | -4x | +
- CombinationFunction(function(...) {
+
|
|
| 54 | -490x | +
- e1(...) && e2(...)+ # If there is any subgroup variables, we extend the layout accordingly. |
|
| 55 | -+ | 18x |
- })+ if ("analysis" %in% df$row_type) {
|
| 56 |
- }+ # Now only continue with the subgroup rows. |
||
| 57 | -+ | 10x |
- )+ lyt <- split_rows_by( |
| 58 | -+ | 10x |
-
+ lyt = lyt, |
| 59 | -+ | 10x |
- #' @describeIn combination_function Logical "OR" combination of `CombinationFunction` functions.+ var = "row_type", |
| 60 | -+ | 10x |
- #' The resulting object is of the same class, and evaluates the two argument functions. The result+ split_fun = keep_split_levels("analysis"),
|
| 61 | -+ | 10x |
- #' is then the "OR" of the two individual results.+ nested = FALSE, |
| 62 | -+ | 10x |
- #'+ child_labels = "hidden" |
| 63 |
- #' @export+ ) |
||
| 64 |
- methods::setMethod(+ |
||
| 65 |
- "|",+ # Split by the subgroup variable. |
||
| 66 | -+ | 10x |
- signature = c(e1 = "CombinationFunction", e2 = "CombinationFunction"),+ lyt <- split_rows_by( |
| 67 | -+ | 10x |
- definition = function(e1, e2) {
+ lyt = lyt, |
| 68 | -2x | +10x |
- CombinationFunction(function(...) {
+ var = "var", |
| 69 | -4x | +10x |
- e1(...) || e2(...)+ labels_var = "var_label", |
| 70 | -+ | 10x |
- })+ nested = TRUE, |
| 71 | -+ | 10x |
- }+ child_labels = "visible", |
| 72 | -+ | 10x |
- )+ indent_mod = .indent_mods * 2 |
| 73 |
-
+ ) |
||
| 74 |
- #' @describeIn combination_function Logical negation of `CombinationFunction` functions.+ |
||
| 75 |
- #' The resulting object is of the same class, and evaluates the original function. The result+ # Then analyze colvars for each subgroup. |
||
| 76 | -+ | 10x |
- #' is then the opposite of this results.+ lyt <- summarize_row_groups( |
| 77 | -+ | 10x |
- #'+ lyt = lyt, |
| 78 | -+ | 10x |
- #' @export+ cfun = afuns, |
| 79 | -+ | 10x |
- methods::setMethod(+ var = "subgroup", |
| 80 | -+ | 10x |
- "!",+ na_str = na_str, |
| 81 | -+ | 10x |
- signature = c(x = "CombinationFunction"),+ extra_args = extra_args |
| 82 |
- definition = function(x) {
+ ) |
||
| 83 | -2x | +
- CombinationFunction(function(...) {
+ } |
|
| 84 | -305x | +18x |
- !x(...)+ build_table(lyt, df = df) |
| 85 |
- })- |
- ||
| 86 | -- |
- }- |
- |
| 87 | -- |
- )+ } |
| 1 |
- #' Helper function for tabulation of a single biomarker result+ #' Class for `CombinationFunction` |
||
| 5 |
- #' Please see [h_tab_surv_one_biomarker()] and [h_tab_rsp_one_biomarker()], which use this function for examples.+ #' `CombinationFunction` is an S4 class which extends standard functions. These are special functions that |
||
| 6 |
- #' This function is a wrapper for [rtables::summarize_row_groups()].+ #' can be combined and negated with the logical operators. |
||
| 8 |
- #' @inheritParams argument_convention+ #' @param e1 (`CombinationFunction`)\cr left hand side of logical operator. |
||
| 9 |
- #' @param df (`data.frame`)\cr results for a single biomarker.+ #' @param e2 (`CombinationFunction`)\cr right hand side of logical operator. |
||
| 10 |
- #' @param afuns (named `list` of `function`)\cr analysis functions.+ #' @param x (`CombinationFunction`)\cr the function which should be negated. |
||
| 11 |
- #' @param colvars (named `list`)\cr named list with elements `vars` (variables to tabulate) and `labels` (their labels).+ #' |
||
| 12 |
- #'+ #' @return A logical value indicating whether the left hand side of the equation equals the right hand side. |
||
| 13 |
- #' @return An `rtables` table object with statistics in columns.+ #' |
||
| 14 |
- #'+ #' @examples |
||
| 15 |
- #' @export+ #' higher <- function(a) {
|
||
| 16 |
- h_tab_one_biomarker <- function(df,+ #' force(a) |
||
| 17 |
- afuns,+ #' CombinationFunction( |
||
| 18 |
- colvars,+ #' function(x) {
|
||
| 19 |
- na_str = default_na_str(),+ #' x > a |
||
| 20 |
- .indent_mods = 0L,+ #' } |
||
| 21 |
- ...) {
+ #' ) |
||
| 22 | -18x | +
- extra_args <- list(...)+ #' } |
|
| 23 |
-
+ #' |
||
| 24 |
- # Create "ci" column from "lcl" and "ucl"+ #' lower <- function(b) {
|
||
| 25 | -18x | +
- df$ci <- combine_vectors(df$lcl, df$ucl)+ #' force(b) |
|
| 26 |
-
+ #' CombinationFunction( |
||
| 27 | -18x | +
- lyt <- basic_table()+ #' function(x) {
|
|
| 28 |
-
+ #' x < b |
||
| 29 |
- # Row split by row type - only keep the content rows here.+ #' } |
||
| 30 | -18x | +
- lyt <- split_rows_by(+ #' ) |
|
| 31 | -18x | +
- lyt = lyt,+ #' } |
|
| 32 | -18x | +
- var = "row_type",+ #' |
|
| 33 | -18x | +
- split_fun = keep_split_levels("content"),
+ #' c1 <- higher(5) |
|
| 34 | -18x | +
- nested = FALSE+ #' c2 <- lower(10) |
|
| 35 |
- )+ #' c3 <- higher(5) & lower(10) |
||
| 36 |
-
+ #' c3(7) |
||
| 37 |
- # Summarize rows with all patients.+ #' |
||
| 38 | -18x | +
- lyt <- summarize_row_groups(+ #' @name combination_function |
|
| 39 | -18x | +
- lyt = lyt,+ #' @aliases CombinationFunction-class |
|
| 40 | -18x | +
- var = "var_label",+ #' @exportClass CombinationFunction |
|
| 41 | -18x | +
- cfun = afuns,+ #' @export CombinationFunction |
|
| 42 | -18x | +
- na_str = na_str,+ CombinationFunction <- methods::setClass("CombinationFunction", contains = "function") # nolint
|
|
| 43 | -18x | +
- indent_mod = .indent_mods,+ |
|
| 44 | -18x | +
- extra_args = extra_args+ #' @describeIn combination_function Logical "AND" combination of `CombinationFunction` functions. |
|
| 45 |
- )+ #' The resulting object is of the same class, and evaluates the two argument functions. The result |
||
| 46 |
-
+ #' is then the "AND" of the two individual results. |
||
| 47 |
- # Split cols by the multiple variables to populate into columns.+ #' |
||
| 48 | -18x | +
- lyt <- split_cols_by_multivar(+ #' @export |
|
| 49 | -18x | +
- lyt = lyt,+ methods::setMethod( |
|
| 50 | -18x | +
- vars = colvars$vars,+ "&", |
|
| 51 | -18x | +
- varlabels = colvars$labels+ signature = c(e1 = "CombinationFunction", e2 = "CombinationFunction"), |
|
| 52 |
- )+ definition = function(e1, e2) {
|
||
| 53 | -+ | 4x |
-
+ CombinationFunction(function(...) {
|
| 54 | -+ | 490x |
- # If there is any subgroup variables, we extend the layout accordingly.+ e1(...) && e2(...) |
| 55 | -18x | +
- if ("analysis" %in% df$row_type) {
+ }) |
|
| 56 |
- # Now only continue with the subgroup rows.+ } |
||
| 57 | -10x | +
- lyt <- split_rows_by(+ ) |
|
| 58 | -10x | +
- lyt = lyt,+ |
|
| 59 | -10x | +
- var = "row_type",+ #' @describeIn combination_function Logical "OR" combination of `CombinationFunction` functions. |
|
| 60 | -10x | +
- split_fun = keep_split_levels("analysis"),
+ #' The resulting object is of the same class, and evaluates the two argument functions. The result |
|
| 61 | -10x | +
- nested = FALSE,+ #' is then the "OR" of the two individual results. |
|
| 62 | -10x | +
- child_labels = "hidden"+ #' |
|
| 63 |
- )+ #' @export |
||
| 64 |
-
+ methods::setMethod( |
||
| 65 |
- # Split by the subgroup variable.+ "|", |
||
| 66 | -10x | +
- lyt <- split_rows_by(+ signature = c(e1 = "CombinationFunction", e2 = "CombinationFunction"), |
|
| 67 | -10x | +
- lyt = lyt,+ definition = function(e1, e2) {
|
|
| 68 | -10x | +2x |
- var = "var",+ CombinationFunction(function(...) {
|
| 69 | -10x | +4x |
- labels_var = "var_label",+ e1(...) || e2(...) |
| 70 | -10x | +
- nested = TRUE,+ }) |
|
| 71 | -10x | +
- child_labels = "visible",+ } |
|
| 72 | -10x | +
- indent_mod = .indent_mods * 2+ ) |
|
| 73 |
- )+ |
||
| 74 |
-
+ #' @describeIn combination_function Logical negation of `CombinationFunction` functions. |
||
| 75 |
- # Then analyze colvars for each subgroup.+ #' The resulting object is of the same class, and evaluates the original function. The result |
||
| 76 | -10x | +
- lyt <- summarize_row_groups(+ #' is then the opposite of this results. |
|
| 77 | -10x | +
- lyt = lyt,+ #' |
|
| 78 | -10x | +
- cfun = afuns,+ #' @export |
|
| 79 | -10x | +
- var = "subgroup",+ methods::setMethod( |
|
| 80 | -10x | +
- na_str = na_str,+ "!", |
|
| 81 | -10x | +
- extra_args = extra_args+ signature = c(x = "CombinationFunction"), |
|
| 82 |
- )+ definition = function(x) {
|
||
| 83 | -+ | 2x |
- }+ CombinationFunction(function(...) {
|
| 84 | -18x | +305x |
- build_table(lyt, df = df)+ !x(...) |
| 85 |
- }+ })+ |
+ ||
| 86 | ++ |
+ }+ |
+ |
| 87 | ++ |
+ ) |
| 1 |
- #' Count number of patients with missed doses by thresholds+ #' Control function for logistic regression model fitting |
||
| 5 |
- #' The analyze function creates a layout element to calculate cumulative counts of patients with number of missed+ #' This is an auxiliary function for controlling arguments for logistic regression models. |
||
| 6 |
- #' doses at least equal to user-specified threshold values.+ #' `conf_level` refers to the confidence level used for the Odds Ratio CIs. |
||
| 8 |
- #' This function analyzes numeric variable `vars`, a variable with numbers of missed doses,+ #' @inheritParams argument_convention |
||
| 9 |
- #' against the threshold values supplied to the `thresholds` argument as a numeric vector. This function+ #' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`. |
||
| 10 |
- #' assumes that every row of the given data frame corresponds to a unique patient.+ #' This will be used when fitting the logistic regression model on the left hand side of the formula. |
||
| 11 |
- #'+ #' Note that the evaluated expression should result in either a logical vector or a factor with 2 |
||
| 12 |
- #' @inheritParams s_count_cumulative+ #' levels. By default this is just `"response"` such that the original response variable is used |
||
| 13 |
- #' @inheritParams argument_convention+ #' and not modified further. |
||
| 14 |
- #' @param thresholds (`numeric`)\cr minimum number of missed doses the patients had.+ #' |
||
| 15 |
- #' @param .stats (`character`)\cr statistics to select for the table.+ #' @return A list of components with the same names as the arguments. |
||
| 17 |
- #' Options are: ``r shQuote(get_stats("count_missed_doses"))``
+ #' @examples |
||
| 18 |
- #'+ #' # Standard options. |
||
| 19 |
- #' @seealso+ #' control_logistic() |
||
| 20 |
- #' * Relevant description function [d_count_missed_doses()] which generates labels for [count_missed_doses()].+ #' |
||
| 21 |
- #' * Similar analyze function [count_cumulative()] which more generally counts cumulative values and has more+ #' # Modify confidence level. |
||
| 22 |
- #' options for threshold handling, but uses different labels.+ #' control_logistic(conf_level = 0.9) |
||
| 24 |
- #' @name count_missed_doses+ #' # Use a different response definition. |
||
| 25 |
- #' @order 1+ #' control_logistic(response_definition = "I(response %in% c('CR', 'PR'))")
|
||
| 26 |
- NULL+ #' |
||
| 27 |
-
+ #' @export |
||
| 28 |
- #' @describeIn count_missed_doses Statistics function to count non-missing values.+ control_logistic <- function(response_definition = "response", |
||
| 29 |
- #'+ conf_level = 0.95) {
|
||
| 30 | -+ | 29x |
- #' @return+ checkmate::assert_true(grepl("response", response_definition))
|
| 31 | -+ | 28x |
- #' * `s_count_nonmissing()` returns the statistic `n` which is the count of non-missing values in `x`.+ checkmate::assert_string(response_definition) |
| 32 | -+ | 28x |
- #'+ assert_proportion_value(conf_level) |
| 33 | -+ | 27x |
- #' @keywords internal+ list( |
| 34 | -+ | 27x |
- s_count_nonmissing <- function(x) {
+ response_definition = response_definition, |
| 35 | -9x | +27x |
- list(n = n_available(x))+ conf_level = conf_level |
| 36 | - |
- }- |
- |
| 37 | -- | - - | -|
| 38 | -- |
- #' Description function that calculates labels for `s_count_missed_doses()`- |
- |
| 39 | -- |
- #'- |
- |
| 40 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
- |
| 41 | -- |
- #'- |
- |
| 42 | -- |
- #' @inheritParams s_count_missed_doses- |
- |
| 43 | -- |
- #'- |
- |
| 44 | -- |
- #' @return [d_count_missed_doses()] returns a named `character` vector with the labels.- |
- |
| 45 | -- |
- #'- |
- |
| 46 | -- |
- #' @seealso [s_count_missed_doses()]- |
- |
| 47 | -- |
- #'- |
- |
| 48 | -- |
- #' @export- |
- |
| 49 | -- |
- d_count_missed_doses <- function(thresholds) {
- |
- |
| 50 | -8x | -
- paste0("At least ", thresholds, " missed dose", ifelse(thresholds > 1, "s", ""))
- |
- |
| 51 | -- |
- }- |
- |
| 52 | -- | - - | -|
| 53 | -- |
- #' @describeIn count_missed_doses Statistics function to count patients with missed doses.- |
- |
| 54 | -- |
- #'- |
- |
| 55 | -- |
- #' @return- |
- |
| 56 | -- |
- #' * `s_count_missed_doses()` returns the statistics `n` and `count_fraction` with one element for each threshold.- |
- |
| 57 | -- |
- #'- |
- |
| 58 | -- |
- #' @keywords internal- |
- |
| 59 | -- |
- s_count_missed_doses <- function(x,- |
- |
| 60 | -- |
- thresholds,- |
- |
| 61 | -- |
- .N_col, # nolint- |
- |
| 62 | -- |
- .N_row, # nolint- |
- |
| 63 | -- |
- denom = c("N_col", "n", "N_row")) {
- |
- |
| 64 | -1x | -
- stat <- s_count_cumulative(- |
- |
| 65 | -1x | -
- x = x,- |
- |
| 66 | -1x | -
- thresholds = thresholds,- |
- |
| 67 | -1x | -
- lower_tail = FALSE,- |
- |
| 68 | -1x | -
- include_eq = TRUE,- |
- |
| 69 | -1x | -
- .N_col = .N_col,- |
- |
| 70 | -1x | -
- .N_row = .N_row,- |
- |
| 71 | -1x | -
- denom = denom- |
- |
| 72 | -
) |
||
| 73 | -1x | -
- labels <- d_count_missed_doses(thresholds)- |
- |
| 74 | -1x | -
- for (i in seq_along(stat$count_fraction)) {
- |
- |
| 75 | -2x | -
- stat$count_fraction[[i]] <- formatters::with_label(stat$count_fraction[[i]], label = labels[i])- |
- |
| 76 | -- |
- }- |
- |
| 77 | -1x | -
- n_stat <- s_count_nonmissing(x)- |
- |
| 78 | -1x | -
- c(n_stat, stat)- |
- |
| 79 | -- |
- }- |
- |
| 80 | -- | - - | -|
| 81 | -- |
- #' @describeIn count_missed_doses Formatted analysis function which is used as `afun`- |
- |
| 82 | -- |
- #' in `count_missed_doses()`.- |
- |
| 83 | -- |
- #'- |
- |
| 84 | -- |
- #' @return- |
- |
| 85 | -- |
- #' * `a_count_missed_doses()` returns the corresponding list with formatted [rtables::CellValue()].- |
- |
| 86 | -- |
- #'- |
- |
| 87 | -- |
- #' @keywords internal- |
- |
| 88 | -- |
- a_count_missed_doses <- make_afun(- |
- |
| 89 | -- |
- s_count_missed_doses,- |
- |
| 90 | -- |
- .formats = c(n = "xx", count_fraction = format_count_fraction)- |
- |
| 91 | -- |
- )- |
- |
| 92 | -- | - - | -|
| 93 | -- |
- #' @describeIn count_missed_doses Layout-creating function which can take statistics function arguments- |
- |
| 94 | -- |
- #' and additional format arguments. This function is a wrapper for [rtables::analyze()].- |
- |
| 95 | -- |
- #'- |
- |
| 96 | -- |
- #' @return- |
- |
| 97 | -- |
- #' * `count_missed_doses()` returns a layout object suitable for passing to further layouting functions,- |
- |
| 98 | -- |
- #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing- |
- |
| 99 | -- |
- #' the statistics from `s_count_missed_doses()` to the table layout.- |
- |
| 100 | -- |
- #'- |
- |
| 101 | -- |
- #' @examples- |
- |
| 102 | -- |
- #' library(dplyr)- |
- |
| 103 | -- |
- #'- |
- |
| 104 | -- |
- #' anl <- tern_ex_adsl %>%- |
- |
| 105 | -- |
- #' distinct(STUDYID, USUBJID, ARM) %>%- |
- |
| 106 | -- |
- #' mutate(- |
- |
| 107 | -- |
- #' PARAMCD = "TNDOSMIS",- |
- |
| 108 | -- |
- #' PARAM = "Total number of missed doses during study",- |
- |
| 109 | -- |
- #' AVAL = sample(0:20, size = nrow(tern_ex_adsl), replace = TRUE),- |
- |
| 110 | -- |
- #' AVALC = ""- |
- |
| 111 | -- |
- #' )- |
- |
| 112 | -- |
- #'- |
- |
| 113 | -- |
- #' basic_table() %>%- |
- |
| 114 | -- |
- #' split_cols_by("ARM") %>%
- |
- |
| 115 | -- |
- #' add_colcounts() %>%- |
- |
| 116 | -- |
- #' count_missed_doses("AVAL", thresholds = c(1, 5, 10, 15), var_labels = "Missed Doses") %>%
- |
- |
| 117 | -- |
- #' build_table(anl, alt_counts_df = tern_ex_adsl)- |
- |
| 118 | -- |
- #'- |
- |
| 119 | -- |
- #' @export- |
- |
| 120 | -- |
- #' @order 2- |
- |
| 121 | -- |
- count_missed_doses <- function(lyt,- |
- |
| 122 | -- |
- vars,- |
- |
| 123 | -- |
- thresholds,- |
- |
| 124 | -- |
- var_labels = vars,- |
- |
| 125 | -- |
- show_labels = "visible",- |
- |
| 126 | -- |
- na_str = default_na_str(),- |
- |
| 127 | -- |
- nested = TRUE,- |
- |
| 128 | -- |
- ...,- |
- |
| 129 | -- |
- table_names = vars,- |
- |
| 130 | -- |
- .stats = NULL,- |
- |
| 131 | -- |
- .formats = NULL,- |
- |
| 132 | -- |
- .labels = NULL,- |
- |
| 133 | -- |
- .indent_mods = NULL) {
- |
- |
| 134 | -2x | -
- extra_args <- list(thresholds = thresholds, ...)- |
- |
| 135 | -- | - - | -|
| 136 | -2x | -
- afun <- make_afun(- |
- |
| 137 | -2x | -
- a_count_missed_doses,- |
- |
| 138 | -2x | -
- .stats = .stats,- |
- |
| 139 | -2x | -
- .formats = .formats,- |
- |
| 140 | -2x | -
- .labels = .labels,- |
- |
| 141 | -2x | -
- .indent_mods = .indent_mods,- |
- |
| 142 | -2x | -
- .ungroup_stats = "count_fraction"- |
- |
| 143 | -- |
- )- |
- |
| 144 | -2x | -
- analyze(- |
- |
| 145 | -2x | -
- lyt = lyt,- |
- |
| 146 | -2x | -
- vars = vars,- |
- |
| 147 | -2x | -
- afun = afun,- |
- |
| 148 | -2x | -
- var_labels = var_labels,- |
- |
| 149 | -2x | -
- table_names = table_names,- |
- |
| 150 | -2x | -
- show_labels = show_labels,- |
- |
| 151 | -2x | -
- na_str = na_str,- |
- |
| 152 | -2x | -
- nested = nested,- |
- |
| 153 | -2x | -
- extra_args = extra_args- |
- |
| 154 | -- |
- )- |
- |
| 155 | +37 |
}@@ -195121,271 +195043,6 @@ tern coverage - 95.59% |
| 1 | -- |
- #' Control function for logistic regression model fitting- |
-
| 2 | -- |
- #'- |
-
| 3 | -- |
- #' @description `r lifecycle::badge("stable")`
- |
-
| 4 | -- |
- #'- |
-
| 5 | -- |
- #' This is an auxiliary function for controlling arguments for logistic regression models.- |
-
| 6 | -- |
- #' `conf_level` refers to the confidence level used for the Odds Ratio CIs.- |
-
| 7 | -- |
- #'- |
-
| 8 | -- |
- #' @inheritParams argument_convention- |
-
| 9 | -- |
- #' @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 | -- |
- #' 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 | -- |
- #' and not modified further.- |
-
| 14 | -- |
- #'- |
-
| 15 | -- |
- #' @return A list of components with the same names as the arguments.- |
-
| 16 | -- |
- #'- |
-
| 17 | -- |
- #' @examples- |
-
| 18 | -- |
- #' # Standard options.- |
-
| 19 | -- |
- #' control_logistic()- |
-
| 20 | -- |
- #'- |
-
| 21 | -- |
- #' # Modify confidence level.- |
-
| 22 | -- |
- #' control_logistic(conf_level = 0.9)- |
-
| 23 | -- |
- #'- |
-
| 24 | -- |
- #' # Use a different response definition.- |
-
| 25 | -- |
- #' control_logistic(response_definition = "I(response %in% c('CR', 'PR'))")
- |
-
| 26 | -- |
- #'- |
-
| 27 | -- |
- #' @export- |
-
| 28 | -- |
- control_logistic <- function(response_definition = "response",- |
-
| 29 | -- |
- conf_level = 0.95) {
- |
-
| 30 | -29x | -
- checkmate::assert_true(grepl("response", response_definition))
- |
-
| 31 | -28x | -
- checkmate::assert_string(response_definition)- |
-
| 32 | -28x | -
- assert_proportion_value(conf_level)- |
-
| 33 | -27x | -
- list(- |
-
| 34 | -27x | -
- response_definition = response_definition,- |
-
| 35 | -27x | -
- conf_level = conf_level- |
-
| 36 | -- |
- )- |
-
| 37 | -- |
- }- |
-