| 1 | ++ |
+ #' Add Titles, Footnotes, Page Number, and a Bounding Box to a Grid Grob+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' This function is useful to label grid grobs (also `ggplot2`, and `lattice` plots)+ |
+
| 6 | ++ |
+ #' with title, footnote, and page numbers.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams grid::grob+ |
+
| 9 | ++ |
+ #' @param grob a grid grob object, optionally `NULL` if only a `grob` with the decoration should be shown.+ |
+
| 10 | ++ |
+ #' @param titles vector of character strings. Vector elements are separated by a newline and strings are wrapped+ |
+
| 11 | ++ |
+ #' according to the page width.+ |
+
| 12 | ++ |
+ #' @param footnotes vector of character string. Same rules as for `titles`.+ |
+
| 13 | ++ |
+ #' @param page string with page numeration, if `NULL` then no page number is displayed.+ |
+
| 14 | ++ |
+ #' @param width_titles unit object+ |
+
| 15 | ++ |
+ #' @param width_footnotes unit object+ |
+
| 16 | ++ |
+ #' @param border boolean, whether a a border should be drawn around the plot or not.+ |
+
| 17 | ++ |
+ #' @param margins unit object of length 4+ |
+
| 18 | ++ |
+ #' @param padding unit object of length 4+ |
+
| 19 | ++ |
+ #' @param outer_margins unit object of length 4+ |
+
| 20 | ++ |
+ #' @param gp_titles a `gpar` object+ |
+
| 21 | ++ |
+ #' @param gp_footnotes a `gpar` object+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @return A grid grob (`gTree`).+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @details The titles and footnotes will be ragged, i.e. each title will be wrapped individually.+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' @examples+ |
+
| 28 | ++ |
+ #' library(grid)+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' titles <- c(+ |
+
| 31 | ++ |
+ #' "Edgar Anderson's Iris Data",+ |
+
| 32 | ++ |
+ #' paste(+ |
+
| 33 | ++ |
+ #' "This famous (Fisher's or Anderson's) iris data set gives the measurements",+ |
+
| 34 | ++ |
+ #' "in centimeters of the variables sepal length and width and petal length",+ |
+
| 35 | ++ |
+ #' "and width, respectively, for 50 flowers from each of 3 species of iris."+ |
+
| 36 | ++ |
+ #' )+ |
+
| 37 | ++ |
+ #' )+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' footnotes <- c(+ |
+
| 40 | ++ |
+ #' "The species are Iris setosa, versicolor, and virginica.",+ |
+
| 41 | ++ |
+ #' paste(+ |
+
| 42 | ++ |
+ #' "iris is a data frame with 150 cases (rows) and 5 variables (columns) named",+ |
+
| 43 | ++ |
+ #' "Sepal.Length, Sepal.Width, Petal.Length, Petal.Width, and Species."+ |
+
| 44 | ++ |
+ #' )+ |
+
| 45 | ++ |
+ #' )+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ #' ## empty plot+ |
+
| 48 | ++ |
+ #' grid.newpage()+ |
+
| 49 | ++ |
+ #'+ |
+
| 50 | ++ |
+ #' grid.draw(+ |
+
| 51 | ++ |
+ #' decorate_grob(+ |
+
| 52 | ++ |
+ #' NULL,+ |
+
| 53 | ++ |
+ #' titles = titles,+ |
+
| 54 | ++ |
+ #' footnotes = footnotes,+ |
+
| 55 | ++ |
+ #' page = "Page 4 of 10"+ |
+
| 56 | ++ |
+ #' )+ |
+
| 57 | ++ |
+ #' )+ |
+
| 58 | ++ |
+ #'+ |
+
| 59 | ++ |
+ #' # grid+ |
+
| 60 | ++ |
+ #' p <- gTree(+ |
+
| 61 | ++ |
+ #' children = gList(+ |
+
| 62 | ++ |
+ #' rectGrob(),+ |
+
| 63 | ++ |
+ #' xaxisGrob(),+ |
+
| 64 | ++ |
+ #' yaxisGrob(),+ |
+
| 65 | ++ |
+ #' textGrob("Sepal.Length", y = unit(-4, "lines")),
+ |
+
| 66 | ++ |
+ #' textGrob("Petal.Length", x = unit(-3.5, "lines"), rot = 90),
+ |
+
| 67 | ++ |
+ #' pointsGrob(iris$Sepal.Length, iris$Petal.Length, gp = gpar(col = iris$Species), pch = 16)+ |
+
| 68 | ++ |
+ #' ),+ |
+
| 69 | ++ |
+ #' vp = vpStack(plotViewport(), dataViewport(xData = iris$Sepal.Length, yData = iris$Petal.Length))+ |
+
| 70 | ++ |
+ #' )+ |
+
| 71 | ++ |
+ #' grid.newpage()+ |
+
| 72 | ++ |
+ #' grid.draw(p)+ |
+
| 73 | ++ |
+ #'+ |
+
| 74 | ++ |
+ #' grid.newpage()+ |
+
| 75 | ++ |
+ #' grid.draw(+ |
+
| 76 | ++ |
+ #' decorate_grob(+ |
+
| 77 | ++ |
+ #' grob = p,+ |
+
| 78 | ++ |
+ #' titles = titles,+ |
+
| 79 | ++ |
+ #' footnotes = footnotes,+ |
+
| 80 | ++ |
+ #' page = "Page 6 of 129"+ |
+
| 81 | ++ |
+ #' )+ |
+
| 82 | ++ |
+ #' )+ |
+
| 83 | ++ |
+ #'+ |
+
| 84 | ++ |
+ #' ## with ggplot2+ |
+
| 85 | ++ |
+ #' library(ggplot2)+ |
+
| 86 | ++ |
+ #'+ |
+
| 87 | ++ |
+ #' p_gg <- ggplot2::ggplot(iris, aes(Sepal.Length, Sepal.Width, col = Species)) ++ |
+
| 88 | ++ |
+ #' ggplot2::geom_point()+ |
+
| 89 | ++ |
+ #' p_gg+ |
+
| 90 | ++ |
+ #' p <- ggplotGrob(p_gg)+ |
+
| 91 | ++ |
+ #' grid.newpage()+ |
+
| 92 | ++ |
+ #' grid.draw(+ |
+
| 93 | ++ |
+ #' decorate_grob(+ |
+
| 94 | ++ |
+ #' grob = p,+ |
+
| 95 | ++ |
+ #' titles = titles,+ |
+
| 96 | ++ |
+ #' footnotes = footnotes,+ |
+
| 97 | ++ |
+ #' page = "Page 6 of 129"+ |
+
| 98 | ++ |
+ #' )+ |
+
| 99 | ++ |
+ #' )+ |
+
| 100 | ++ |
+ #'+ |
+
| 101 | ++ |
+ #' ## with lattice+ |
+
| 102 | ++ |
+ #' library(lattice)+ |
+
| 103 | ++ |
+ #'+ |
+
| 104 | ++ |
+ #' xyplot(Sepal.Length ~ Petal.Length, data = iris, col = iris$Species)+ |
+
| 105 | ++ |
+ #' p <- grid.grab()+ |
+
| 106 | ++ |
+ #' grid.newpage()+ |
+
| 107 | ++ |
+ #' grid.draw(+ |
+
| 108 | ++ |
+ #' decorate_grob(+ |
+
| 109 | ++ |
+ #' grob = p,+ |
+
| 110 | ++ |
+ #' titles = titles,+ |
+
| 111 | ++ |
+ #' footnotes = footnotes,+ |
+
| 112 | ++ |
+ #' page = "Page 6 of 129"+ |
+
| 113 | ++ |
+ #' )+ |
+
| 114 | ++ |
+ #' )+ |
+
| 115 | ++ |
+ #'+ |
+
| 116 | ++ |
+ #' # with gridExtra - no borders+ |
+
| 117 | ++ |
+ #' library(gridExtra)+ |
+
| 118 | ++ |
+ #' grid.newpage()+ |
+
| 119 | ++ |
+ #' grid.draw(+ |
+
| 120 | ++ |
+ #' decorate_grob(+ |
+
| 121 | ++ |
+ #' tableGrob(+ |
+
| 122 | ++ |
+ #' head(mtcars)+ |
+
| 123 | ++ |
+ #' ),+ |
+
| 124 | ++ |
+ #' titles = "title",+ |
+
| 125 | ++ |
+ #' footnotes = "footnote",+ |
+
| 126 | ++ |
+ #' border = FALSE+ |
+
| 127 | ++ |
+ #' )+ |
+
| 128 | ++ |
+ #' )+ |
+
| 129 | ++ |
+ #'+ |
+
| 130 | ++ |
+ #' @export+ |
+
| 131 | ++ |
+ decorate_grob <- function(grob,+ |
+
| 132 | ++ |
+ titles,+ |
+
| 133 | ++ |
+ footnotes,+ |
+
| 134 | ++ |
+ page = "",+ |
+
| 135 | ++ |
+ width_titles = grid::unit(1, "npc") - grid::stringWidth(page),+ |
+
| 136 | ++ |
+ width_footnotes = grid::unit(1, "npc") - grid::stringWidth(page),+ |
+
| 137 | ++ |
+ border = TRUE,+ |
+
| 138 | ++ |
+ margins = grid::unit(c(1, 0, 1, 0), "lines"),+ |
+
| 139 | ++ |
+ padding = grid::unit(rep(1, 4), "lines"),+ |
+
| 140 | ++ |
+ outer_margins = grid::unit(c(2, 1.5, 3, 1.5), "cm"),+ |
+
| 141 | ++ |
+ gp_titles = grid::gpar(),+ |
+
| 142 | ++ |
+ gp_footnotes = grid::gpar(fontsize = 8),+ |
+
| 143 | ++ |
+ name = NULL,+ |
+
| 144 | ++ |
+ gp = grid::gpar(),+ |
+
| 145 | ++ |
+ vp = NULL) {
+ |
+
| 146 | +8x | +
+ st_titles <- split_text_grob(+ |
+
| 147 | +8x | +
+ titles,+ |
+
| 148 | +8x | +
+ x = 0, y = 1,+ |
+
| 149 | +8x | +
+ just = c("left", "top"),
+ |
+
| 150 | +8x | +
+ width = width_titles,+ |
+
| 151 | +8x | +
+ vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 1),+ |
+
| 152 | +8x | +
+ gp = gp_titles+ |
+
| 153 | ++ |
+ )+ |
+
| 154 | ++ | + + | +
| 155 | +8x | +
+ st_footnotes <- split_text_grob(+ |
+
| 156 | +8x | +
+ footnotes,+ |
+
| 157 | +8x | +
+ x = 0, y = 1,+ |
+
| 158 | +8x | +
+ just = c("left", "top"),
+ |
+
| 159 | +8x | +
+ width = width_footnotes,+ |
+
| 160 | +8x | +
+ vp = grid::viewport(layout.pos.row = 3, layout.pos.col = 1),+ |
+
| 161 | +8x | +
+ gp = gp_footnotes+ |
+
| 162 | ++ |
+ )+ |
+
| 163 | ++ | + + | +
| 164 | +8x | +
+ grid::gTree(+ |
+
| 165 | +8x | +
+ grob = grob,+ |
+
| 166 | +8x | +
+ titles = titles,+ |
+
| 167 | +8x | +
+ footnotes = footnotes,+ |
+
| 168 | +8x | +
+ page = page,+ |
+
| 169 | +8x | +
+ width_titles = width_titles,+ |
+
| 170 | +8x | +
+ width_footnotes = width_footnotes,+ |
+
| 171 | +8x | +
+ border = border,+ |
+
| 172 | +8x | +
+ margins = margins,+ |
+
| 173 | +8x | +
+ padding = padding,+ |
+
| 174 | +8x | +
+ outer_margins = outer_margins,+ |
+
| 175 | +8x | +
+ gp_titles = gp_titles,+ |
+
| 176 | +8x | +
+ gp_footnotes = gp_footnotes,+ |
+
| 177 | +8x | +
+ children = grid::gList(+ |
+
| 178 | +8x | +
+ grid::gTree(+ |
+
| 179 | +8x | +
+ children = grid::gList(+ |
+
| 180 | +8x | +
+ st_titles,+ |
+
| 181 | +8x | +
+ grid::gTree(+ |
+
| 182 | +8x | +
+ children = grid::gList(+ |
+
| 183 | +8x | +
+ if (border) grid::rectGrob(),+ |
+
| 184 | +8x | +
+ grid::gTree(+ |
+
| 185 | +8x | +
+ children = grid::gList(+ |
+
| 186 | +8x | +
+ grob+ |
+
| 187 | ++ |
+ ),+ |
+
| 188 | +8x | +
+ vp = grid::plotViewport(margins = padding)+ |
+
| 189 | ++ |
+ )+ |
+
| 190 | ++ |
+ ),+ |
+
| 191 | +8x | +
+ vp = grid::vpStack(+ |
+
| 192 | +8x | +
+ grid::viewport(layout.pos.row = 2, layout.pos.col = 1),+ |
+
| 193 | +8x | +
+ grid::plotViewport(margins = margins)+ |
+
| 194 | ++ |
+ )+ |
+
| 195 | ++ |
+ ),+ |
+
| 196 | +8x | +
+ st_footnotes,+ |
+
| 197 | +8x | +
+ grid::textGrob(+ |
+
| 198 | +8x | +
+ page,+ |
+
| 199 | +8x | +
+ x = 1, y = 0,+ |
+
| 200 | +8x | +
+ just = c("right", "bottom"),
+ |
+
| 201 | +8x | +
+ vp = grid::viewport(layout.pos.row = 3, layout.pos.col = 1),+ |
+
| 202 | +8x | +
+ gp = gp_footnotes+ |
+
| 203 | ++ |
+ )+ |
+
| 204 | ++ |
+ ),+ |
+
| 205 | +8x | +
+ childrenvp = NULL,+ |
+
| 206 | +8x | +
+ name = "titles_grob_footnotes",+ |
+
| 207 | +8x | +
+ vp = grid::vpStack(+ |
+
| 208 | +8x | +
+ grid::plotViewport(margins = outer_margins),+ |
+
| 209 | +8x | +
+ grid::viewport(+ |
+
| 210 | +8x | +
+ layout = grid::grid.layout(+ |
+
| 211 | +8x | +
+ nrow = 3, ncol = 1,+ |
+
| 212 | +8x | +
+ heights = grid::unit.c(+ |
+
| 213 | +8x | +
+ grid::grobHeight(st_titles),+ |
+
| 214 | +8x | +
+ grid::unit(1, "null"),+ |
+
| 215 | +8x | +
+ grid::grobHeight(st_footnotes)+ |
+
| 216 | ++ |
+ )+ |
+
| 217 | ++ |
+ )+ |
+
| 218 | ++ |
+ )+ |
+
| 219 | ++ |
+ )+ |
+
| 220 | ++ |
+ )+ |
+
| 221 | ++ |
+ ),+ |
+
| 222 | +8x | +
+ name = name,+ |
+
| 223 | +8x | +
+ gp = gp,+ |
+
| 224 | +8x | +
+ vp = vp,+ |
+
| 225 | +8x | +
+ cl = "decoratedGrob"+ |
+
| 226 | ++ |
+ )+ |
+
| 227 | ++ |
+ }+ |
+
| 228 | ++ | + + | +
| 229 | ++ |
+ #' @importFrom grid validDetails+ |
+
| 230 | ++ |
+ #' @noRd+ |
+
| 231 | ++ |
+ validDetails.decoratedGrob <- function(x) {
+ |
+
| 232 | +! | +
+ checkmate::assert_character(x$titles)+ |
+
| 233 | +! | +
+ checkmate::assert_character(x$footnotes)+ |
+
| 234 | ++ | + + | +
| 235 | +! | +
+ if (!is.null(x$grob)) {
+ |
+
| 236 | +! | +
+ checkmate::assert_true(grid::is.grob(x$grob))+ |
+
| 237 | ++ |
+ }+ |
+
| 238 | +! | +
+ if (length(x$page) == 1) {
+ |
+
| 239 | +! | +
+ checkmate::assert_character(x$page)+ |
+
| 240 | ++ |
+ }+ |
+
| 241 | +! | +
+ if (!grid::is.unit(x$outer_margins)) {
+ |
+
| 242 | +! | +
+ checkmate::assert_vector(x$outer_margins, len = 4)+ |
+
| 243 | ++ |
+ }+ |
+
| 244 | +! | +
+ if (!grid::is.unit(x$margins)) {
+ |
+
| 245 | +! | +
+ checkmate::assert_vector(x$margins, len = 4)+ |
+
| 246 | ++ |
+ }+ |
+
| 247 | +! | +
+ if (!grid::is.unit(x$padding)) {
+ |
+
| 248 | +! | +
+ checkmate::assert_vector(x$padding, len = 4)+ |
+
| 249 | ++ |
+ }+ |
+
| 250 | ++ | + + | +
| 251 | +! | +
+ x+ |
+
| 252 | ++ |
+ }+ |
+
| 253 | ++ | + + | +
| 254 | ++ |
+ #' @importFrom grid widthDetails+ |
+
| 255 | ++ |
+ #' @noRd+ |
+
| 256 | ++ |
+ widthDetails.decoratedGrob <- function(x) {
+ |
+
| 257 | +! | +
+ grid::unit(1, "null")+ |
+
| 258 | ++ |
+ }+ |
+
| 259 | ++ | + + | +
| 260 | ++ |
+ #' @importFrom grid heightDetails+ |
+
| 261 | ++ |
+ #' @noRd+ |
+
| 262 | ++ |
+ heightDetails.decoratedGrob <- function(x) {
+ |
+
| 263 | +! | +
+ grid::unit(1, "null")+ |
+
| 264 | ++ |
+ }+ |
+
| 265 | ++ | + + | +
| 266 | ++ |
+ # Adapted from Paul Murell R Graphics 2nd Edition+ |
+
| 267 | ++ |
+ # https://www.stat.auckland.ac.nz/~paul/RG2e/interactgrid-splittext.R+ |
+
| 268 | ++ |
+ split_string <- function(text, width) {
+ |
+
| 269 | +17x | +
+ strings <- strsplit(text, " ")+ |
+
| 270 | +17x | +
+ out_string <- NA+ |
+
| 271 | +17x | +
+ for (string_i in seq_along(strings)) {
+ |
+
| 272 | +17x | +
+ newline_str <- strings[[string_i]]+ |
+
| 273 | +6x | +
+ if (length(newline_str) == 0) newline_str <- ""+ |
+
| 274 | +17x | +
+ if (is.na(out_string[string_i])) {
+ |
+
| 275 | +17x | +
+ out_string[string_i] <- newline_str[[1]][[1]]+ |
+
| 276 | +17x | +
+ linewidth <- grid::stringWidth(out_string[string_i])+ |
+
| 277 | ++ |
+ }+ |
+
| 278 | +17x | +
+ gapwidth <- grid::stringWidth(" ")
+ |
+
| 279 | +17x | +
+ availwidth <- as.numeric(width)+ |
+
| 280 | +17x | +
+ if (length(newline_str) > 1) {
+ |
+
| 281 | +5x | +
+ for (i in seq(2, length(newline_str))) {
+ |
+
| 282 | +27x | +
+ width_i <- grid::stringWidth(newline_str[i])+ |
+
| 283 | +27x | +
+ if (grid::convertWidth(linewidth + gapwidth + width_i, grid::unitType(width), valueOnly = TRUE) < availwidth) {
+ |
+
| 284 | +25x | +
+ sep <- " "+ |
+
| 285 | +25x | +
+ linewidth <- linewidth + gapwidth + width_i+ |
+
| 286 | ++ |
+ } else {
+ |
+
| 287 | +2x | +
+ sep <- "\n"+ |
+
| 288 | +2x | +
+ linewidth <- width_i+ |
+
| 289 | ++ |
+ }+ |
+
| 290 | +27x | +
+ out_string[string_i] <- paste(out_string[string_i], newline_str[i], sep = sep)+ |
+
| 291 | ++ |
+ }+ |
+
| 292 | ++ |
+ }+ |
+
| 293 | ++ |
+ }+ |
+
| 294 | +17x | +
+ paste(out_string, collapse = "\n")+ |
+
| 295 | ++ |
+ }+ |
+
| 296 | ++ | + + | +
| 297 | ++ |
+ #' Split Text According To Available Text Width+ |
+
| 298 | ++ |
+ #'+ |
+
| 299 | ++ |
+ #' Dynamically wrap text.+ |
+
| 300 | ++ |
+ #'+ |
+
| 301 | ++ |
+ #' @inheritParams grid::grid.text+ |
+
| 302 | ++ |
+ #' @param text character string+ |
+
| 303 | ++ |
+ #' @param width a unit object specifying max width of text+ |
+
| 304 | ++ |
+ #'+ |
+
| 305 | ++ |
+ #' @return A text grob.+ |
+
| 306 | ++ |
+ #'+ |
+
| 307 | ++ |
+ #' @details This code is taken from `R Graphics by Paul Murell, 2nd edition`+ |
+
| 308 | ++ |
+ #'+ |
+
| 309 | ++ |
+ #' @keywords internal+ |
+
| 310 | ++ |
+ split_text_grob <- function(text,+ |
+
| 311 | ++ |
+ x = grid::unit(0.5, "npc"),+ |
+
| 312 | ++ |
+ y = grid::unit(0.5, "npc"),+ |
+
| 313 | ++ |
+ width = grid::unit(1, "npc"),+ |
+
| 314 | ++ |
+ just = "centre",+ |
+
| 315 | ++ |
+ hjust = NULL,+ |
+
| 316 | ++ |
+ vjust = NULL,+ |
+
| 317 | ++ |
+ default.units = "npc", # nolint+ |
+
| 318 | ++ |
+ name = NULL,+ |
+
| 319 | ++ |
+ gp = grid::gpar(),+ |
+
| 320 | ++ |
+ vp = NULL) {
+ |
+
| 321 | +16x | +
+ if (!grid::is.unit(x)) x <- grid::unit(x, default.units)+ |
+
| 322 | +16x | +
+ if (!grid::is.unit(y)) y <- grid::unit(y, default.units)+ |
+
| 323 | +! | +
+ if (!grid::is.unit(width)) width <- grid::unit(width, default.units)+ |
+
| 324 | +! | +
+ if (grid::unitType(x) %in% c("sum", "min", "max")) x <- grid::convertUnit(x, default.units)
+ |
+
| 325 | +! | +
+ if (grid::unitType(y) %in% c("sum", "min", "max")) y <- grid::convertUnit(y, default.units)
+ |
+
| 326 | +16x | +
+ if (grid::unitType(width) %in% c("sum", "min", "max")) width <- grid::convertUnit(width, default.units)
+ |
+
| 327 | ++ | + + | +
| 328 | ++ |
+ ## if it is a fixed unit then we do not need to recalculate when viewport resized+ |
+
| 329 | +16x | +
+ if (!inherits(width, "unit.arithmetic") && !is.null(attr(width, "unit")) &&+ |
+
| 330 | +16x | +
+ attr(width, "unit") %in% c("cm", "inches", "mm", "points", "picas", "bigpts", "dida", "cicero", "scaledpts")) { # nolint
+ |
+
| 331 | +! | +
+ attr(text, "fixed_text") <- paste(vapply(text, split_string, character(1), width = width), collapse = "\n")+ |
+
| 332 | ++ |
+ }+ |
+
| 333 | ++ | + + | +
| 334 | +16x | +
+ grid::grid.text(+ |
+
| 335 | +16x | +
+ label = split_string(text, width),+ |
+
| 336 | +16x | +
+ x = x, y = y,+ |
+
| 337 | +16x | +
+ just = just,+ |
+
| 338 | +16x | +
+ hjust = hjust,+ |
+
| 339 | +16x | +
+ vjust = vjust,+ |
+
| 340 | +16x | +
+ rot = 0,+ |
+
| 341 | +16x | +
+ check.overlap = FALSE,+ |
+
| 342 | +16x | +
+ name = name,+ |
+
| 343 | +16x | +
+ gp = gp,+ |
+
| 344 | +16x | +
+ vp = vp,+ |
+
| 345 | +16x | +
+ draw = FALSE+ |
+
| 346 | ++ |
+ )+ |
+
| 347 | ++ |
+ }+ |
+
| 348 | ++ | + + | +
| 349 | ++ |
+ #' @importFrom grid validDetails+ |
+
| 350 | ++ |
+ #' @noRd+ |
+
| 351 | ++ |
+ validDetails.dynamicSplitText <- function(x) {
+ |
+
| 352 | +! | +
+ checkmate::assert_character(x$text)+ |
+
| 353 | +! | +
+ checkmate::assert_true(grid::is.unit(x$width))+ |
+
| 354 | +! | +
+ checkmate::assert_vector(x$width, len = 1)+ |
+
| 355 | +! | +
+ x+ |
+
| 356 | ++ |
+ }+ |
+
| 357 | ++ | + + | +
| 358 | ++ |
+ #' @importFrom grid heightDetails+ |
+
| 359 | ++ |
+ #' @noRd+ |
+
| 360 | ++ |
+ heightDetails.dynamicSplitText <- function(x) {
+ |
+
| 361 | +! | +
+ txt <- if (!is.null(attr(x$text, "fixed_text"))) {
+ |
+
| 362 | +! | +
+ attr(x$text, "fixed_text")+ |
+
| 363 | ++ |
+ } else {
+ |
+
| 364 | +! | +
+ paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n")+ |
+
| 365 | ++ |
+ }+ |
+
| 366 | +! | +
+ grid::stringHeight(txt)+ |
+
| 367 | ++ |
+ }+ |
+
| 368 | ++ | + + | +
| 369 | ++ |
+ #' @importFrom grid widthDetails+ |
+
| 370 | ++ |
+ #' @noRd+ |
+
| 371 | ++ |
+ widthDetails.dynamicSplitText <- function(x) {
+ |
+
| 372 | +! | +
+ x$width+ |
+
| 373 | ++ |
+ }+ |
+
| 374 | ++ | + + | +
| 375 | ++ |
+ #' @importFrom grid drawDetails+ |
+
| 376 | ++ |
+ #' @noRd+ |
+
| 377 | ++ |
+ drawDetails.dynamicSplitText <- function(x, recording) {
+ |
+
| 378 | +! | +
+ txt <- if (!is.null(attr(x$text, "fixed_text"))) {
+ |
+
| 379 | +! | +
+ attr(x$text, "fixed_text")+ |
+
| 380 | ++ |
+ } else {
+ |
+
| 381 | +! | +
+ paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n")+ |
+
| 382 | ++ |
+ }+ |
+
| 383 | ++ | + + | +
| 384 | +! | +
+ x$width <- NULL+ |
+
| 385 | +! | +
+ x$label <- txt+ |
+
| 386 | +! | +
+ x$text <- NULL+ |
+
| 387 | +! | +
+ class(x) <- c("text", class(x)[-1])
+ |
+
| 388 | ++ | + + | +
| 389 | +! | +
+ grid::grid.draw(x)+ |
+
| 390 | ++ |
+ }+ |
+
| 391 | ++ | + + | +
| 392 | ++ |
+ #' Update Page Number+ |
+
| 393 | ++ |
+ #'+ |
+
| 394 | ++ |
+ #' Automatically updates page number.+ |
+
| 395 | ++ |
+ #'+ |
+
| 396 | ++ |
+ #' @param npages number of pages in total+ |
+
| 397 | ++ |
+ #' @param ... passed on to [decorate_grob()]+ |
+
| 398 | ++ |
+ #'+ |
+
| 399 | ++ |
+ #' @return Closure that increments the page number.+ |
+
| 400 | ++ |
+ #'+ |
+
| 401 | ++ |
+ #' @keywords internal+ |
+
| 402 | ++ |
+ decorate_grob_factory <- function(npages, ...) {
+ |
+
| 403 | +2x | +
+ current_page <- 0+ |
+
| 404 | +2x | +
+ function(grob) {
+ |
+
| 405 | +7x | +
+ current_page <<- current_page + 1+ |
+
| 406 | +7x | +
+ if (current_page > npages) {
+ |
+
| 407 | +1x | +
+ stop(paste("current page is", current_page, "but max.", npages, "specified."))
+ |
+
| 408 | ++ |
+ }+ |
+
| 409 | +6x | +
+ decorate_grob(grob = grob, page = paste("Page", current_page, "of", npages), ...)
+ |
+
| 410 | ++ |
+ }+ |
+
| 411 | ++ |
+ }+ |
+
| 412 | ++ | + + | +
| 413 | ++ |
+ #' Decorate Set of `grobs` and Add Page Numbering+ |
+
| 414 | ++ |
+ #'+ |
+
| 415 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 416 | ++ |
+ #'+ |
+
| 417 | ++ |
+ #' Note that this uses the [decorate_grob_factory()] function.+ |
+
| 418 | ++ |
+ #'+ |
+
| 419 | ++ |
+ #' @param grobs a list of grid grobs+ |
+
| 420 | ++ |
+ #' @param ... arguments passed on to [decorate_grob()].+ |
+
| 421 | ++ |
+ #'+ |
+
| 422 | ++ |
+ #' @return A decorated grob.+ |
+
| 423 | ++ |
+ #'+ |
+
| 424 | ++ |
+ #' @examples+ |
+
| 425 | ++ |
+ #' library(ggplot2)+ |
+
| 426 | ++ |
+ #' library(grid)+ |
+
| 427 | ++ |
+ #' g <- with(data = iris, {
+ |
+
| 428 | ++ |
+ #' list(+ |
+
| 429 | ++ |
+ #' ggplot2::ggplotGrob(+ |
+
| 430 | ++ |
+ #' ggplot2::ggplot(mapping = aes(Sepal.Length, Sepal.Width, col = Species)) ++ |
+
| 431 | ++ |
+ #' ggplot2::geom_point()+ |
+
| 432 | ++ |
+ #' ),+ |
+
| 433 | ++ |
+ #' ggplot2::ggplotGrob(+ |
+
| 434 | ++ |
+ #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Length, col = Species)) ++ |
+
| 435 | ++ |
+ #' ggplot2::geom_point()+ |
+
| 436 | ++ |
+ #' ),+ |
+
| 437 | ++ |
+ #' ggplot2::ggplotGrob(+ |
+
| 438 | ++ |
+ #' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Width, col = Species)) ++ |
+
| 439 | ++ |
+ #' ggplot2::geom_point()+ |
+
| 440 | ++ |
+ #' ),+ |
+
| 441 | ++ |
+ #' ggplot2::ggplotGrob(+ |
+
| 442 | ++ |
+ #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Length, col = Species)) ++ |
+
| 443 | ++ |
+ #' ggplot2::geom_point()+ |
+
| 444 | ++ |
+ #' ),+ |
+
| 445 | ++ |
+ #' ggplot2::ggplotGrob(+ |
+
| 446 | ++ |
+ #' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Width, col = Species)) ++ |
+
| 447 | ++ |
+ #' ggplot2::geom_point()+ |
+
| 448 | ++ |
+ #' ),+ |
+
| 449 | ++ |
+ #' ggplot2::ggplotGrob(+ |
+
| 450 | ++ |
+ #' ggplot2::ggplot(mapping = aes(Petal.Length, Petal.Width, col = Species)) ++ |
+
| 451 | ++ |
+ #' ggplot2::geom_point()+ |
+
| 452 | ++ |
+ #' )+ |
+
| 453 | ++ |
+ #' )+ |
+
| 454 | ++ |
+ #' })+ |
+
| 455 | ++ |
+ #' lg <- decorate_grob_set(grobs = g, titles = "Hello\nOne\nTwo\nThree", footnotes = "")+ |
+
| 456 | ++ |
+ #'+ |
+
| 457 | ++ |
+ #' draw_grob(lg[[1]])+ |
+
| 458 | ++ |
+ #' draw_grob(lg[[2]])+ |
+
| 459 | ++ |
+ #' draw_grob(lg[[6]])+ |
+
| 460 | ++ |
+ #'+ |
+
| 461 | ++ |
+ #' @export+ |
+
| 462 | ++ |
+ decorate_grob_set <- function(grobs, ...) {
+ |
+
| 463 | +1x | +
+ n <- length(grobs)+ |
+
| 464 | +1x | +
+ lgf <- decorate_grob_factory(npages = n, ...)+ |
+
| 465 | +1x | +
+ lapply(grobs, lgf)+ |
+
| 466 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Survival Time Point Analysis+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Summarize patients' survival rate and difference of survival rates between groups at a time point.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 8 | ++ |
+ #' @inheritParams s_surv_time+ |
+
| 9 | ++ |
+ #' @param time_point (`number`)\cr survival time point of interest.+ |
+
| 10 | ++ |
+ #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function+ |
+
| 11 | ++ |
+ #' [control_surv_timepoint()]. Some possible parameter options are:+ |
+
| 12 | ++ |
+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate.+ |
+
| 13 | ++ |
+ #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log",+ |
+
| 14 | ++ |
+ #' see more in [survival::survfit()]. Note option "none" is no longer supported.+ |
+
| 15 | ++ |
+ #' * `time_point` (`number`)\cr survival time point of interest.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @name survival_timepoint+ |
+
| 18 | ++ |
+ NULL+ |
+
| 19 | ++ | + + | +
| 20 | ++ |
+ #' @describeIn survival_timepoint Statistics function which analyzes survival rate.+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @return+ |
+
| 23 | ++ |
+ #' * `s_surv_timepoint()` returns the statistics:+ |
+
| 24 | ++ |
+ #' * `pt_at_risk`: Patients remaining at risk.+ |
+
| 25 | ++ |
+ #' * `event_free_rate`: Event-free rate (%).+ |
+
| 26 | ++ |
+ #' * `rate_se`: Standard error of event free rate.+ |
+
| 27 | ++ |
+ #' * `rate_ci`: Confidence interval for event free rate.+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @examples+ |
+
| 30 | ++ |
+ #' library(dplyr)+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' adtte_f <- tern_ex_adtte %>%+ |
+
| 33 | ++ |
+ #' filter(PARAMCD == "OS") %>%+ |
+
| 34 | ++ |
+ #' mutate(+ |
+
| 35 | ++ |
+ #' AVAL = day2month(AVAL),+ |
+
| 36 | ++ |
+ #' is_event = CNSR == 0+ |
+
| 37 | ++ |
+ #' )+ |
+
| 38 | ++ |
+ #' df <- adtte_f %>%+ |
+
| 39 | ++ |
+ #' filter(ARMCD == "ARM A")+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' @keywords internal+ |
+
| 42 | ++ |
+ s_surv_timepoint <- function(df,+ |
+
| 43 | ++ |
+ .var,+ |
+
| 44 | ++ |
+ time_point,+ |
+
| 45 | ++ |
+ is_event,+ |
+
| 46 | ++ |
+ control = control_surv_timepoint()) {
+ |
+
| 47 | +19x | +
+ checkmate::assert_string(.var)+ |
+
| 48 | +19x | +
+ assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ |
+
| 49 | +19x | +
+ checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE)+ |
+
| 50 | +19x | +
+ checkmate::assert_number(time_point)+ |
+
| 51 | +19x | +
+ checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)+ |
+
| 52 | ++ | + + | +
| 53 | +19x | +
+ conf_type <- control$conf_type+ |
+
| 54 | +19x | +
+ conf_level <- control$conf_level+ |
+
| 55 | ++ | + + | +
| 56 | +19x | +
+ formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
+ |
+
| 57 | +19x | +
+ srv_fit <- survival::survfit(+ |
+
| 58 | +19x | +
+ formula = formula,+ |
+
| 59 | +19x | +
+ data = df,+ |
+
| 60 | +19x | +
+ conf.int = conf_level,+ |
+
| 61 | +19x | +
+ conf.type = conf_type+ |
+
| 62 | ++ |
+ )+ |
+
| 63 | +19x | +
+ s_srv_fit <- summary(srv_fit, times = time_point, extend = TRUE)+ |
+
| 64 | +19x | +
+ df_srv_fit <- as.data.frame(s_srv_fit[c("time", "n.risk", "surv", "lower", "upper", "std.err")])
+ |
+
| 65 | +19x | +
+ if (df_srv_fit[["n.risk"]] == 0) {
+ |
+
| 66 | +1x | +
+ pt_at_risk <- event_free_rate <- rate_se <- NA_real_+ |
+
| 67 | +1x | +
+ rate_ci <- c(NA_real_, NA_real_)+ |
+
| 68 | ++ |
+ } else {
+ |
+
| 69 | +18x | +
+ pt_at_risk <- df_srv_fit$n.risk+ |
+
| 70 | +18x | +
+ event_free_rate <- df_srv_fit$surv+ |
+
| 71 | +18x | +
+ rate_se <- df_srv_fit$std.err+ |
+
| 72 | +18x | +
+ rate_ci <- c(df_srv_fit$lower, df_srv_fit$upper)+ |
+
| 73 | ++ |
+ }+ |
+
| 74 | +19x | +
+ list(+ |
+
| 75 | +19x | +
+ pt_at_risk = formatters::with_label(pt_at_risk, "Patients remaining at risk"),+ |
+
| 76 | +19x | +
+ event_free_rate = formatters::with_label(event_free_rate * 100, "Event Free Rate (%)"),+ |
+
| 77 | +19x | +
+ rate_se = formatters::with_label(rate_se * 100, "Standard Error of Event Free Rate"),+ |
+
| 78 | +19x | +
+ rate_ci = formatters::with_label(rate_ci * 100, f_conf_level(conf_level))+ |
+
| 79 | ++ |
+ )+ |
+
| 80 | ++ |
+ }+ |
+
| 81 | ++ | + + | +
| 82 | ++ |
+ #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()`+ |
+
| 83 | ++ |
+ #' when `method = "surv"`.+ |
+
| 84 | ++ |
+ #'+ |
+
| 85 | ++ |
+ #' @return+ |
+
| 86 | ++ |
+ #' * `a_surv_timepoint()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 87 | ++ |
+ #'+ |
+
| 88 | ++ |
+ #' @keywords internal+ |
+
| 89 | ++ |
+ a_surv_timepoint <- make_afun(+ |
+
| 90 | ++ |
+ s_surv_timepoint,+ |
+
| 91 | ++ |
+ .indent_mods = c(+ |
+
| 92 | ++ |
+ pt_at_risk = 0L,+ |
+
| 93 | ++ |
+ event_free_rate = 0L,+ |
+
| 94 | ++ |
+ rate_se = 1L,+ |
+
| 95 | ++ |
+ rate_ci = 1L+ |
+
| 96 | ++ |
+ ),+ |
+
| 97 | ++ |
+ .formats = c(+ |
+
| 98 | ++ |
+ pt_at_risk = "xx",+ |
+
| 99 | ++ |
+ event_free_rate = "xx.xx",+ |
+
| 100 | ++ |
+ rate_se = "xx.xx",+ |
+
| 101 | ++ |
+ rate_ci = "(xx.xx, xx.xx)"+ |
+
| 102 | ++ |
+ )+ |
+
| 103 | ++ |
+ )+ |
+
| 104 | ++ | + + | +
| 105 | ++ |
+ #' @describeIn survival_timepoint Statistics function which analyzes difference between two survival rates.+ |
+
| 106 | ++ |
+ #'+ |
+
| 107 | ++ |
+ #' @return+ |
+
| 108 | ++ |
+ #' * `s_surv_timepoint_diff()` returns the statistics:+ |
+
| 109 | ++ |
+ #' * `rate_diff`: Event-free rate difference between two groups.+ |
+
| 110 | ++ |
+ #' * `rate_diff_ci`: Confidence interval for the difference.+ |
+
| 111 | ++ |
+ #' * `ztest_pval`: p-value to test the difference is 0.+ |
+
| 112 | ++ |
+ #'+ |
+
| 113 | ++ |
+ #' @examples+ |
+
| 114 | ++ |
+ #' df_ref_group <- adtte_f %>%+ |
+
| 115 | ++ |
+ #' filter(ARMCD == "ARM B")+ |
+
| 116 | ++ |
+ #'+ |
+
| 117 | ++ |
+ #' @keywords internal+ |
+
| 118 | ++ |
+ s_surv_timepoint_diff <- function(df,+ |
+
| 119 | ++ |
+ .var,+ |
+
| 120 | ++ |
+ .ref_group,+ |
+
| 121 | ++ |
+ .in_ref_col,+ |
+
| 122 | ++ |
+ time_point,+ |
+
| 123 | ++ |
+ control = control_surv_timepoint(),+ |
+
| 124 | ++ |
+ ...) {
+ |
+
| 125 | +2x | +
+ if (.in_ref_col) {
+ |
+
| 126 | +! | +
+ return(+ |
+
| 127 | +! | +
+ list(+ |
+
| 128 | +! | +
+ rate_diff = formatters::with_label("", "Difference in Event Free Rate"),
+ |
+
| 129 | +! | +
+ rate_diff_ci = formatters::with_label("", f_conf_level(control$conf_level)),
+ |
+
| 130 | +! | +
+ ztest_pval = formatters::with_label("", "p-value (Z-test)")
+ |
+
| 131 | ++ |
+ )+ |
+
| 132 | ++ |
+ )+ |
+
| 133 | ++ |
+ }+ |
+
| 134 | +2x | +
+ data <- rbind(.ref_group, df)+ |
+
| 135 | +2x | +
+ group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
+ |
+
| 136 | +2x | +
+ res_per_group <- lapply(split(data, group), function(x) {
+ |
+
| 137 | +4x | +
+ s_surv_timepoint(df = x, .var = .var, time_point = time_point, control = control, ...)+ |
+
| 138 | ++ |
+ })+ |
+
| 139 | ++ | + + | +
| 140 | +2x | +
+ res_x <- res_per_group[[2]]+ |
+
| 141 | +2x | +
+ res_ref <- res_per_group[[1]]+ |
+
| 142 | +2x | +
+ rate_diff <- res_x$event_free_rate - res_ref$event_free_rate+ |
+
| 143 | +2x | +
+ se_diff <- sqrt(res_x$rate_se^2 + res_ref$rate_se^2)+ |
+
| 144 | ++ | + + | +
| 145 | +2x | +
+ qs <- c(-1, 1) * stats::qnorm(1 - (1 - control$conf_level) / 2)+ |
+
| 146 | +2x | +
+ rate_diff_ci <- rate_diff + qs * se_diff+ |
+
| 147 | +2x | +
+ ztest_pval <- if (is.na(rate_diff)) {
+ |
+
| 148 | +2x | +
+ NA+ |
+
| 149 | ++ |
+ } else {
+ |
+
| 150 | +2x | +
+ 2 * (1 - stats::pnorm(abs(rate_diff) / se_diff))+ |
+
| 151 | ++ |
+ }+ |
+
| 152 | +2x | +
+ list(+ |
+
| 153 | +2x | +
+ rate_diff = formatters::with_label(rate_diff, "Difference in Event Free Rate"),+ |
+
| 154 | +2x | +
+ rate_diff_ci = formatters::with_label(rate_diff_ci, f_conf_level(control$conf_level)),+ |
+
| 155 | +2x | +
+ ztest_pval = formatters::with_label(ztest_pval, "p-value (Z-test)")+ |
+
| 156 | ++ |
+ )+ |
+
| 157 | ++ |
+ }+ |
+
| 158 | ++ | + + | +
| 159 | ++ |
+ #' @describeIn survival_timepoint Formatted analysis function which is used as `afun` in `surv_timepoint()`+ |
+
| 160 | ++ |
+ #' when `method = "surv_diff"`.+ |
+
| 161 | ++ |
+ #'+ |
+
| 162 | ++ |
+ #' @return+ |
+
| 163 | ++ |
+ #' * `a_surv_timepoint_diff()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 164 | ++ |
+ #'+ |
+
| 165 | ++ |
+ #' @keywords internal+ |
+
| 166 | ++ |
+ a_surv_timepoint_diff <- make_afun(+ |
+
| 167 | ++ |
+ s_surv_timepoint_diff,+ |
+
| 168 | ++ |
+ .formats = c(+ |
+
| 169 | ++ |
+ rate_diff = "xx.xx",+ |
+
| 170 | ++ |
+ rate_diff_ci = "(xx.xx, xx.xx)",+ |
+
| 171 | ++ |
+ ztest_pval = "x.xxxx | (<0.0001)"+ |
+
| 172 | ++ |
+ )+ |
+
| 173 | ++ |
+ )+ |
+
| 174 | ++ | + + | +
| 175 | ++ |
+ #' @describeIn survival_timepoint Layout-creating function which can take statistics function arguments+ |
+
| 176 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 177 | ++ |
+ #'+ |
+
| 178 | ++ |
+ #' @param method (`string`)\cr either `surv` (survival estimations),+ |
+
| 179 | ++ |
+ #' `surv_diff` (difference in survival with the control) or `both`.+ |
+
| 180 | ++ |
+ #' @param table_names_suffix (`string`)\cr optional suffix for the `table_names` used for the `rtables` to+ |
+
| 181 | ++ |
+ #' avoid warnings from duplicate table names.+ |
+
| 182 | ++ |
+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ |
+
| 183 | ++ |
+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ |
+
| 184 | ++ |
+ #' for that statistic's row label.+ |
+
| 185 | ++ |
+ #'+ |
+
| 186 | ++ |
+ #' @return+ |
+
| 187 | ++ |
+ #' * `surv_timepoint()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 188 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 189 | ++ |
+ #' the statistics from `s_surv_timepoint()` and/or `s_surv_timepoint_diff()` to the table layout depending on+ |
+
| 190 | ++ |
+ #' the value of `method`.+ |
+
| 191 | ++ |
+ #'+ |
+
| 192 | ++ |
+ #' @examples+ |
+
| 193 | ++ |
+ #' # Survival at given time points.+ |
+
| 194 | ++ |
+ #' basic_table() %>%+ |
+
| 195 | ++ |
+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ |
+
| 196 | ++ |
+ #' add_colcounts() %>%+ |
+
| 197 | ++ |
+ #' surv_timepoint(+ |
+
| 198 | ++ |
+ #' vars = "AVAL",+ |
+
| 199 | ++ |
+ #' var_labels = "Months",+ |
+
| 200 | ++ |
+ #' is_event = "is_event",+ |
+
| 201 | ++ |
+ #' time_point = 7+ |
+
| 202 | ++ |
+ #' ) %>%+ |
+
| 203 | ++ |
+ #' build_table(df = adtte_f)+ |
+
| 204 | ++ |
+ #'+ |
+
| 205 | ++ |
+ #' # Difference in survival at given time points.+ |
+
| 206 | ++ |
+ #' basic_table() %>%+ |
+
| 207 | ++ |
+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ |
+
| 208 | ++ |
+ #' add_colcounts() %>%+ |
+
| 209 | ++ |
+ #' surv_timepoint(+ |
+
| 210 | ++ |
+ #' vars = "AVAL",+ |
+
| 211 | ++ |
+ #' var_labels = "Months",+ |
+
| 212 | ++ |
+ #' is_event = "is_event",+ |
+
| 213 | ++ |
+ #' time_point = 9,+ |
+
| 214 | ++ |
+ #' method = "surv_diff",+ |
+
| 215 | ++ |
+ #' .indent_mods = c("rate_diff" = 0L, "rate_diff_ci" = 2L, "ztest_pval" = 2L)
+ |
+
| 216 | ++ |
+ #' ) %>%+ |
+
| 217 | ++ |
+ #' build_table(df = adtte_f)+ |
+
| 218 | ++ |
+ #'+ |
+
| 219 | ++ |
+ #' # Survival and difference in survival at given time points.+ |
+
| 220 | ++ |
+ #' basic_table() %>%+ |
+
| 221 | ++ |
+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ |
+
| 222 | ++ |
+ #' add_colcounts() %>%+ |
+
| 223 | ++ |
+ #' surv_timepoint(+ |
+
| 224 | ++ |
+ #' vars = "AVAL",+ |
+
| 225 | ++ |
+ #' var_labels = "Months",+ |
+
| 226 | ++ |
+ #' is_event = "is_event",+ |
+
| 227 | ++ |
+ #' time_point = 9,+ |
+
| 228 | ++ |
+ #' method = "both"+ |
+
| 229 | ++ |
+ #' ) %>%+ |
+
| 230 | ++ |
+ #' build_table(df = adtte_f)+ |
+
| 231 | ++ |
+ #'+ |
+
| 232 | ++ |
+ #' @export+ |
+
| 233 | ++ |
+ surv_timepoint <- function(lyt,+ |
+
| 234 | ++ |
+ vars,+ |
+
| 235 | ++ |
+ na_str = NA_character_,+ |
+
| 236 | ++ |
+ nested = TRUE,+ |
+
| 237 | ++ |
+ ...,+ |
+
| 238 | ++ |
+ table_names_suffix = "",+ |
+
| 239 | ++ |
+ var_labels = "Time",+ |
+
| 240 | ++ |
+ show_labels = "visible",+ |
+
| 241 | ++ |
+ method = c("surv", "surv_diff", "both"),
+ |
+
| 242 | ++ |
+ .stats = c(+ |
+
| 243 | ++ |
+ "pt_at_risk", "event_free_rate", "rate_ci",+ |
+
| 244 | ++ |
+ "rate_diff", "rate_diff_ci", "ztest_pval"+ |
+
| 245 | ++ |
+ ),+ |
+
| 246 | ++ |
+ .formats = NULL,+ |
+
| 247 | ++ |
+ .labels = NULL,+ |
+
| 248 | ++ |
+ .indent_mods = if (method == "both") {
+ |
+
| 249 | +1x | +
+ c(rate_diff = 1L, rate_diff_ci = 2L, ztest_pval = 2L)+ |
+
| 250 | ++ |
+ } else {
+ |
+
| 251 | +4x | +
+ c(rate_diff_ci = 1L, ztest_pval = 1L)+ |
+
| 252 | ++ |
+ }) {
+ |
+
| 253 | +5x | +
+ method <- match.arg(method)+ |
+
| 254 | +5x | +
+ checkmate::assert_string(table_names_suffix)+ |
+
| 255 | ++ | + + | +
| 256 | +5x | +
+ f <- list(+ |
+
| 257 | +5x | +
+ surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
+ |
+
| 258 | +5x | +
+ surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
+ |
+
| 259 | ++ |
+ )+ |
+
| 260 | +5x | +
+ .stats <- h_split_param(.stats, .stats, f = f)+ |
+
| 261 | +5x | +
+ .formats <- h_split_param(.formats, names(.formats), f = f)+ |
+
| 262 | +5x | +
+ .labels <- h_split_param(.labels, names(.labels), f = f)+ |
+
| 263 | +5x | +
+ .indent_mods <- h_split_param(.indent_mods, names(.indent_mods), f = f)+ |
+
| 264 | ++ | + + | +
| 265 | +5x | +
+ afun_surv <- make_afun(+ |
+
| 266 | +5x | +
+ a_surv_timepoint,+ |
+
| 267 | +5x | +
+ .stats = .stats$surv,+ |
+
| 268 | +5x | +
+ .formats = .formats$surv,+ |
+
| 269 | +5x | +
+ .labels = .labels$surv,+ |
+
| 270 | +5x | +
+ .indent_mods = .indent_mods$surv+ |
+
| 271 | ++ |
+ )+ |
+
| 272 | ++ | + + | +
| 273 | +5x | +
+ afun_surv_diff <- make_afun(+ |
+
| 274 | +5x | +
+ a_surv_timepoint_diff,+ |
+
| 275 | +5x | +
+ .stats = .stats$surv_diff,+ |
+
| 276 | +5x | +
+ .formats = .formats$surv_diff,+ |
+
| 277 | +5x | +
+ .labels = .labels$surv_diff,+ |
+
| 278 | +5x | +
+ .indent_mods = .indent_mods$surv_diff+ |
+
| 279 | ++ |
+ )+ |
+
| 280 | ++ | + + | +
| 281 | +5x | +
+ time_point <- list(...)$time_point+ |
+
| 282 | ++ | + + | +
| 283 | +5x | +
+ for (i in seq_along(time_point)) {
+ |
+
| 284 | +5x | +
+ tpt <- time_point[i]+ |
+
| 285 | ++ | + + | +
| 286 | +5x | +
+ if (method %in% c("surv", "both")) {
+ |
+
| 287 | +3x | +
+ lyt <- analyze(+ |
+
| 288 | +3x | +
+ lyt,+ |
+
| 289 | +3x | +
+ vars,+ |
+
| 290 | +3x | +
+ var_labels = paste(tpt, var_labels),+ |
+
| 291 | +3x | +
+ table_names = paste0("surv_", tpt, table_names_suffix),
+ |
+
| 292 | +3x | +
+ show_labels = show_labels,+ |
+
| 293 | +3x | +
+ afun = afun_surv,+ |
+
| 294 | +3x | +
+ na_str = na_str,+ |
+
| 295 | +3x | +
+ nested = nested,+ |
+
| 296 | +3x | +
+ extra_args = list(+ |
+
| 297 | +3x | +
+ is_event = list(...)$is_event,+ |
+
| 298 | +3x | +
+ control = list(...)$control,+ |
+
| 299 | +3x | +
+ time_point = tpt+ |
+
| 300 | ++ |
+ )+ |
+
| 301 | ++ |
+ )+ |
+
| 302 | ++ |
+ }+ |
+
| 303 | ++ | + + | +
| 304 | +5x | +
+ if (method %in% c("surv_diff", "both")) {
+ |
+
| 305 | +3x | +
+ lyt <- analyze(+ |
+
| 306 | +3x | +
+ lyt,+ |
+
| 307 | +3x | +
+ vars,+ |
+
| 308 | +3x | +
+ var_labels = paste(tpt, var_labels),+ |
+
| 309 | +3x | +
+ table_names = paste0("surv_diff_", tpt, table_names_suffix),
+ |
+
| 310 | +3x | +
+ show_labels = ifelse(method == "both", "hidden", show_labels),+ |
+
| 311 | +3x | +
+ afun = afun_surv_diff,+ |
+
| 312 | +3x | +
+ na_str = na_str,+ |
+
| 313 | +3x | +
+ nested = nested,+ |
+
| 314 | +3x | +
+ extra_args = list(+ |
+
| 315 | +3x | +
+ is_event = list(...)$is_event,+ |
+
| 316 | +3x | +
+ control = list(...)$control,+ |
+
| 317 | +3x | +
+ time_point = tpt+ |
+
| 318 | ++ |
+ )+ |
+
| 319 | ++ |
+ )+ |
+
| 320 | ++ |
+ }+ |
+
| 321 | ++ |
+ }+ |
+
| 322 | +5x | +
+ lyt+ |
+
| 323 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Count the Number of Patients with Particular Flags+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' The primary analysis variable `.var` denotes the unique patient identifier.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @seealso [count_patients_with_event]+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @name count_patients_with_flags+ |
+
| 12 | ++ |
+ NULL+ |
+
| 13 | ++ | + + | +
| 14 | ++ |
+ #' @describeIn count_patients_with_flags Statistics function which counts the number of patients for which+ |
+
| 15 | ++ |
+ #' a particular flag variable is `TRUE`.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @inheritParams analyze_variables+ |
+
| 18 | ++ |
+ #' @param .var (`character`)\cr name of the column that contains the unique identifier.+ |
+
| 19 | ++ |
+ #' @param flag_variables (`character`)\cr a character vector specifying the names of `logical`+ |
+
| 20 | ++ |
+ #' variables from analysis dataset used for counting the number of unique identifiers.+ |
+
| 21 | ++ |
+ #' @param flag_labels (`character`)\cr vector of labels to use for flag variables.+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @note If `flag_labels` is not specified, variables labels will be extracted from `df`. If variables are not+ |
+
| 24 | ++ |
+ #' labeled, variable names will be used instead. Alternatively, a named `vector` can be supplied to+ |
+
| 25 | ++ |
+ #' `flag_variables` such that within each name-value pair the name corresponds to the variable name and the value is+ |
+
| 26 | ++ |
+ #' the label to use for this variable.+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @return+ |
+
| 29 | ++ |
+ #' * `s_count_patients_with_flags()` returns the count and the fraction of unique identifiers with each particular+ |
+
| 30 | ++ |
+ #' flag as a list of statistics `n`, `count`, `count_fraction`, and `n_blq`, with one element per flag.+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @examples+ |
+
| 33 | ++ |
+ #' library(dplyr)+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' # `s_count_patients_with_flags()`+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' # Add labelled flag variables to analysis dataset.+ |
+
| 38 | ++ |
+ #' adae <- tern_ex_adae %>%+ |
+
| 39 | ++ |
+ #' mutate(+ |
+
| 40 | ++ |
+ #' fl1 = TRUE,+ |
+
| 41 | ++ |
+ #' fl2 = TRTEMFL == "Y",+ |
+
| 42 | ++ |
+ #' fl3 = TRTEMFL == "Y" & AEOUT == "FATAL",+ |
+
| 43 | ++ |
+ #' fl4 = TRTEMFL == "Y" & AEOUT == "FATAL" & AEREL == "Y"+ |
+
| 44 | ++ |
+ #' )+ |
+
| 45 | ++ |
+ #' labels <- c(+ |
+
| 46 | ++ |
+ #' "fl1" = "Total AEs",+ |
+
| 47 | ++ |
+ #' "fl2" = "Total number of patients with at least one adverse event",+ |
+
| 48 | ++ |
+ #' "fl3" = "Total number of patients with fatal AEs",+ |
+
| 49 | ++ |
+ #' "fl4" = "Total number of patients with related fatal AEs"+ |
+
| 50 | ++ |
+ #' )+ |
+
| 51 | ++ |
+ #' formatters::var_labels(adae)[names(labels)] <- labels+ |
+
| 52 | ++ |
+ #'+ |
+
| 53 | ++ |
+ #' s_count_patients_with_flags(+ |
+
| 54 | ++ |
+ #' adae,+ |
+
| 55 | ++ |
+ #' "SUBJID",+ |
+
| 56 | ++ |
+ #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
+ |
+
| 57 | ++ |
+ #' denom = "N_col",+ |
+
| 58 | ++ |
+ #' .N_col = 1000+ |
+
| 59 | ++ |
+ #' )+ |
+
| 60 | ++ |
+ #'+ |
+
| 61 | ++ |
+ #' @export+ |
+
| 62 | ++ |
+ s_count_patients_with_flags <- function(df,+ |
+
| 63 | ++ |
+ .var,+ |
+
| 64 | ++ |
+ flag_variables,+ |
+
| 65 | ++ |
+ flag_labels = NULL,+ |
+
| 66 | ++ |
+ .N_col, # nolint+ |
+
| 67 | ++ |
+ .N_row, # nolint+ |
+
| 68 | ++ |
+ denom = c("n", "N_row", "N_col")) {
+ |
+
| 69 | +5x | +
+ checkmate::assert_character(flag_variables)+ |
+
| 70 | +5x | +
+ if (!is.null(flag_labels)) {
+ |
+
| 71 | +! | +
+ checkmate::assert_character(flag_labels, len = length(flag_variables), any.missing = FALSE)+ |
+
| 72 | +! | +
+ flag_names <- flag_labels+ |
+
| 73 | ++ |
+ } else {
+ |
+
| 74 | +5x | +
+ if (is.null(names(flag_variables))) {
+ |
+
| 75 | +5x | +
+ flag_names <- formatters::var_labels(df[flag_variables], fill = TRUE)+ |
+
| 76 | ++ |
+ } else {
+ |
+
| 77 | +! | +
+ flag_names <- unname(flag_variables)+ |
+
| 78 | +! | +
+ flag_variables <- names(flag_variables)+ |
+
| 79 | ++ |
+ }+ |
+
| 80 | ++ |
+ }+ |
+
| 81 | ++ | + + | +
| 82 | +5x | +
+ checkmate::assert_subset(flag_variables, colnames(df))+ |
+
| 83 | +5x | +
+ temp <- sapply(flag_variables, function(x) {
+ |
+
| 84 | +11x | +
+ tmp <- Map(function(y) which(df[[y]]), x)+ |
+
| 85 | +11x | +
+ position_satisfy_flags <- Reduce(intersect, tmp)+ |
+
| 86 | +11x | +
+ id_satisfy_flags <- as.character(unique(df[position_satisfy_flags, ][[.var]]))+ |
+
| 87 | +11x | +
+ s_count_values(+ |
+
| 88 | +11x | +
+ as.character(unique(df[[.var]])),+ |
+
| 89 | +11x | +
+ id_satisfy_flags,+ |
+
| 90 | +11x | +
+ denom = denom,+ |
+
| 91 | +11x | +
+ .N_col = .N_col,+ |
+
| 92 | +11x | +
+ .N_row = .N_row+ |
+
| 93 | ++ |
+ )+ |
+
| 94 | ++ |
+ })+ |
+
| 95 | +5x | +
+ colnames(temp) <- flag_names+ |
+
| 96 | +5x | +
+ temp <- data.frame(t(temp))+ |
+
| 97 | +5x | +
+ result <- temp %>% as.list()+ |
+
| 98 | +5x | +
+ if (length(flag_variables) == 1) {
+ |
+
| 99 | +1x | +
+ for (i in 1:3) names(result[[i]]) <- flag_names[1]+ |
+
| 100 | ++ |
+ }+ |
+
| 101 | +5x | +
+ result+ |
+
| 102 | ++ |
+ }+ |
+
| 103 | ++ | + + | +
| 104 | ++ |
+ #' @describeIn count_patients_with_flags Formatted analysis function which is used as `afun`+ |
+
| 105 | ++ |
+ #' in `count_patients_with_flags()`.+ |
+
| 106 | ++ |
+ #'+ |
+
| 107 | ++ |
+ #' @return+ |
+
| 108 | ++ |
+ #' * `a_count_patients_with_flags()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 109 | ++ |
+ #'+ |
+
| 110 | ++ |
+ #' @examples+ |
+
| 111 | ++ |
+ #' # We need to ungroup `count_fraction` first so that the `rtables` formatting+ |
+
| 112 | ++ |
+ #' # function `format_count_fraction()` can be applied correctly.+ |
+
| 113 | ++ |
+ #'+ |
+
| 114 | ++ |
+ #' # `a_count_patients_with_flags()`+ |
+
| 115 | ++ |
+ #'+ |
+
| 116 | ++ |
+ #' afun <- make_afun(a_count_patients_with_flags,+ |
+
| 117 | ++ |
+ #' .stats = "count_fraction",+ |
+
| 118 | ++ |
+ #' .ungroup_stats = "count_fraction"+ |
+
| 119 | ++ |
+ #' )+ |
+
| 120 | ++ |
+ #' afun(+ |
+
| 121 | ++ |
+ #' adae,+ |
+
| 122 | ++ |
+ #' .N_col = 10L,+ |
+
| 123 | ++ |
+ #' .N_row = 10L,+ |
+
| 124 | ++ |
+ #' .var = "USUBJID",+ |
+
| 125 | ++ |
+ #' flag_variables = c("fl1", "fl2", "fl3", "fl4")
+ |
+
| 126 | ++ |
+ #' )+ |
+
| 127 | ++ |
+ #'+ |
+
| 128 | ++ |
+ #' @export+ |
+
| 129 | ++ |
+ a_count_patients_with_flags <- make_afun(+ |
+
| 130 | ++ |
+ s_count_patients_with_flags,+ |
+
| 131 | ++ |
+ .formats = c("count_fraction" = format_count_fraction_fixed_dp)
+ |
+
| 132 | ++ |
+ )+ |
+
| 133 | ++ | + + | +
| 134 | ++ |
+ #' @describeIn count_patients_with_flags Layout-creating function which can take statistics function+ |
+
| 135 | ++ |
+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 136 | ++ |
+ #'+ |
+
| 137 | ++ |
+ #' @return+ |
+
| 138 | ++ |
+ #' * `count_patients_with_flags()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 139 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 140 | ++ |
+ #' the statistics from `s_count_patients_with_flags()` to the table layout.+ |
+
| 141 | ++ |
+ #'+ |
+
| 142 | ++ |
+ #' @examples+ |
+
| 143 | ++ |
+ #' # `count_patients_with_flags()`+ |
+
| 144 | ++ |
+ #'+ |
+
| 145 | ++ |
+ #' lyt2 <- basic_table() %>%+ |
+
| 146 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 147 | ++ |
+ #' add_colcounts() %>%+ |
+
| 148 | ++ |
+ #' count_patients_with_flags(+ |
+
| 149 | ++ |
+ #' "SUBJID",+ |
+
| 150 | ++ |
+ #' flag_variables = c("fl1", "fl2", "fl3", "fl4"),
+ |
+
| 151 | ++ |
+ #' denom = "N_col"+ |
+
| 152 | ++ |
+ #' )+ |
+
| 153 | ++ |
+ #' build_table(lyt2, adae, alt_counts_df = tern_ex_adsl)+ |
+
| 154 | ++ |
+ #'+ |
+
| 155 | ++ |
+ #' @export+ |
+
| 156 | ++ |
+ count_patients_with_flags <- function(lyt,+ |
+
| 157 | ++ |
+ var,+ |
+
| 158 | ++ |
+ var_labels = var,+ |
+
| 159 | ++ |
+ show_labels = "hidden",+ |
+
| 160 | ++ |
+ riskdiff = FALSE,+ |
+
| 161 | ++ |
+ na_str = NA_character_,+ |
+
| 162 | ++ |
+ nested = TRUE,+ |
+
| 163 | ++ |
+ ...,+ |
+
| 164 | ++ |
+ table_names = paste0("tbl_flags_", var),
+ |
+
| 165 | ++ |
+ .stats = "count_fraction",+ |
+
| 166 | ++ |
+ .formats = NULL,+ |
+
| 167 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 168 | +6x | +
+ checkmate::assert_flag(riskdiff)+ |
+
| 169 | ++ | + + | +
| 170 | +6x | +
+ afun <- make_afun(+ |
+
| 171 | +6x | +
+ a_count_patients_with_flags,+ |
+
| 172 | +6x | +
+ .stats = .stats,+ |
+
| 173 | +6x | +
+ .formats = .formats,+ |
+
| 174 | +6x | +
+ .indent_mods = .indent_mods,+ |
+
| 175 | +6x | +
+ .ungroup_stats = .stats+ |
+
| 176 | ++ |
+ )+ |
+
| 177 | ++ | + + | +
| 178 | +6x | +
+ extra_args <- if (isFALSE(riskdiff)) {
+ |
+
| 179 | +5x | +
+ list(...)+ |
+
| 180 | ++ |
+ } else {
+ |
+
| 181 | +1x | +
+ list(+ |
+
| 182 | +1x | +
+ afun = list("s_count_patients_with_flags" = afun),
+ |
+
| 183 | +1x | +
+ .stats = .stats,+ |
+
| 184 | +1x | +
+ .indent_mods = .indent_mods,+ |
+
| 185 | +1x | +
+ s_args = list(...)+ |
+
| 186 | ++ |
+ )+ |
+
| 187 | ++ |
+ }+ |
+
| 188 | ++ | + + | +
| 189 | +6x | +
+ lyt <- analyze(+ |
+
| 190 | +6x | +
+ lyt = lyt,+ |
+
| 191 | +6x | +
+ vars = var,+ |
+
| 192 | +6x | +
+ var_labels = var_labels,+ |
+
| 193 | +6x | +
+ show_labels = show_labels,+ |
+
| 194 | +6x | +
+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ |
+
| 195 | +6x | +
+ table_names = table_names,+ |
+
| 196 | +6x | +
+ na_str = na_str,+ |
+
| 197 | +6x | +
+ nested = nested,+ |
+
| 198 | +6x | +
+ extra_args = extra_args+ |
+
| 199 | ++ |
+ )+ |
+
| 200 | ++ | + + | +
| 201 | +6x | +
+ lyt+ |
+
| 202 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Counting Missed Doses+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' These are specific functions to count patients with missed doses. The difference to [count_cumulative()] is+ |
+
| 6 | ++ |
+ #' mainly the special labels.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @seealso Relevant description function [d_count_missed_doses()].+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @name count_missed_doses+ |
+
| 13 | ++ |
+ NULL+ |
+
| 14 | ++ | + + | +
| 15 | ++ |
+ #' @describeIn count_missed_doses Statistics function to count non-missing values.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @return+ |
+
| 18 | ++ |
+ #' * `s_count_nonmissing()` returns the statistic `n` which is the count of non-missing values in `x`.+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @examples+ |
+
| 21 | ++ |
+ #' set.seed(1)+ |
+
| 22 | ++ |
+ #' x <- c(sample(1:10, 10), NA)+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @keywords internal+ |
+
| 25 | ++ |
+ s_count_nonmissing <- function(x) {
+ |
+
| 26 | +5x | +
+ list(n = n_available(x))+ |
+
| 27 | ++ |
+ }+ |
+
| 28 | ++ | + + | +
| 29 | ++ |
+ #' Description Function that Calculates Labels for [s_count_missed_doses()].+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' @inheritParams s_count_missed_doses+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' @return [d_count_missed_doses()] returns a named `character` vector with the labels.+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' @seealso [s_count_missed_doses()]+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' @export+ |
+
| 40 | ++ |
+ d_count_missed_doses <- function(thresholds) {
+ |
+
| 41 | +4x | +
+ paste0("At least ", thresholds, " missed dose", ifelse(thresholds > 1, "s", ""))
+ |
+
| 42 | ++ |
+ }+ |
+
| 43 | ++ | + + | +
| 44 | ++ |
+ #' @describeIn count_missed_doses Statistics function to count patients with missed doses.+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' @param thresholds (vector of `count`)\cr number of missed doses the patients at least had.+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ #' @return+ |
+
| 49 | ++ |
+ #' * `s_count_missed_doses()` returns the statistics `n` and `count_fraction` with one element for each threshold.+ |
+
| 50 | ++ |
+ #'+ |
+
| 51 | ++ |
+ #' @keywords internal+ |
+
| 52 | ++ |
+ s_count_missed_doses <- function(x,+ |
+
| 53 | ++ |
+ thresholds,+ |
+
| 54 | ++ |
+ .N_col) { # nolint
+ |
+
| 55 | +1x | +
+ stat <- s_count_cumulative(+ |
+
| 56 | +1x | +
+ x = x,+ |
+
| 57 | +1x | +
+ thresholds = thresholds,+ |
+
| 58 | +1x | +
+ lower_tail = FALSE,+ |
+
| 59 | +1x | +
+ include_eq = TRUE,+ |
+
| 60 | +1x | +
+ .N_col = .N_col+ |
+
| 61 | ++ |
+ )+ |
+
| 62 | +1x | +
+ labels <- d_count_missed_doses(thresholds)+ |
+
| 63 | +1x | +
+ for (i in seq_along(stat$count_fraction)) {
+ |
+
| 64 | +2x | +
+ stat$count_fraction[[i]] <- formatters::with_label(stat$count_fraction[[i]], label = labels[i])+ |
+
| 65 | ++ |
+ }+ |
+
| 66 | +1x | +
+ n_stat <- s_count_nonmissing(x)+ |
+
| 67 | +1x | +
+ c(n_stat, stat)+ |
+
| 68 | ++ |
+ }+ |
+
| 69 | ++ | + + | +
| 70 | ++ |
+ #' @describeIn count_missed_doses Formatted analysis function which is used as `afun`+ |
+
| 71 | ++ |
+ #' in `count_missed_doses()`.+ |
+
| 72 | ++ |
+ #'+ |
+
| 73 | ++ |
+ #' @return+ |
+
| 74 | ++ |
+ #' * `a_count_missed_doses()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ #' @keywords internal+ |
+
| 77 | ++ |
+ a_count_missed_doses <- make_afun(+ |
+
| 78 | ++ |
+ s_count_missed_doses,+ |
+
| 79 | ++ |
+ .formats = c(n = "xx", count_fraction = format_count_fraction)+ |
+
| 80 | ++ |
+ )+ |
+
| 81 | ++ | + + | +
| 82 | ++ |
+ #' @describeIn count_missed_doses Layout-creating function which can take statistics function arguments+ |
+
| 83 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 84 | ++ |
+ #'+ |
+
| 85 | ++ |
+ #' @inheritParams s_count_cumulative+ |
+
| 86 | ++ |
+ #'+ |
+
| 87 | ++ |
+ #' @return+ |
+
| 88 | ++ |
+ #' * `count_missed_doses()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 89 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 90 | ++ |
+ #' the statistics from `s_count_missed_doses()` to the table layout.+ |
+
| 91 | ++ |
+ #'+ |
+
| 92 | ++ |
+ #' @examples+ |
+
| 93 | ++ |
+ #' library(dplyr)+ |
+
| 94 | ++ |
+ #'+ |
+
| 95 | ++ |
+ #' anl <- tern_ex_adsl %>%+ |
+
| 96 | ++ |
+ #' distinct(STUDYID, USUBJID, ARM) %>%+ |
+
| 97 | ++ |
+ #' mutate(+ |
+
| 98 | ++ |
+ #' PARAMCD = "TNDOSMIS",+ |
+
| 99 | ++ |
+ #' PARAM = "Total number of missed doses during study",+ |
+
| 100 | ++ |
+ #' AVAL = sample(0:20, size = nrow(tern_ex_adsl), replace = TRUE),+ |
+
| 101 | ++ |
+ #' AVALC = ""+ |
+
| 102 | ++ |
+ #' )+ |
+
| 103 | ++ |
+ #'+ |
+
| 104 | ++ |
+ #' basic_table() %>%+ |
+
| 105 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 106 | ++ |
+ #' add_colcounts() %>%+ |
+
| 107 | ++ |
+ #' count_missed_doses("AVAL", thresholds = c(1, 5, 10, 15), var_labels = "Missed Doses") %>%
+ |
+
| 108 | ++ |
+ #' build_table(anl, alt_counts_df = tern_ex_adsl)+ |
+
| 109 | ++ |
+ #'+ |
+
| 110 | ++ |
+ #' @export+ |
+
| 111 | ++ |
+ count_missed_doses <- function(lyt,+ |
+
| 112 | ++ |
+ vars,+ |
+
| 113 | ++ |
+ var_labels = vars,+ |
+
| 114 | ++ |
+ show_labels = "visible",+ |
+
| 115 | ++ |
+ na_str = NA_character_,+ |
+
| 116 | ++ |
+ nested = TRUE,+ |
+
| 117 | ++ |
+ ...,+ |
+
| 118 | ++ |
+ table_names = vars,+ |
+
| 119 | ++ |
+ .stats = NULL,+ |
+
| 120 | ++ |
+ .formats = NULL,+ |
+
| 121 | ++ |
+ .labels = NULL,+ |
+
| 122 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 123 | +1x | +
+ afun <- make_afun(+ |
+
| 124 | +1x | +
+ a_count_missed_doses,+ |
+
| 125 | +1x | +
+ .stats = .stats,+ |
+
| 126 | +1x | +
+ .formats = .formats,+ |
+
| 127 | +1x | +
+ .labels = .labels,+ |
+
| 128 | +1x | +
+ .indent_mods = .indent_mods,+ |
+
| 129 | +1x | +
+ .ungroup_stats = "count_fraction"+ |
+
| 130 | ++ |
+ )+ |
+
| 131 | +1x | +
+ analyze(+ |
+
| 132 | +1x | +
+ lyt = lyt,+ |
+
| 133 | +1x | +
+ vars = vars,+ |
+
| 134 | +1x | +
+ afun = afun,+ |
+
| 135 | +1x | +
+ var_labels = var_labels,+ |
+
| 136 | +1x | +
+ table_names = table_names,+ |
+
| 137 | +1x | +
+ show_labels = show_labels,+ |
+
| 138 | +1x | +
+ na_str = na_str,+ |
+
| 139 | +1x | +
+ nested = nested,+ |
+
| 140 | +1x | +
+ extra_args = list(...)+ |
+
| 141 | ++ |
+ )+ |
+
| 142 | ++ |
+ }+ |
+
| 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 (`logical`)\cr indicating if `NA` should be omitted.+ |
+
| 8 | ++ |
+ #' @param finite (`logical`)\cr 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 | +835x | +
+ checkmate::assert_numeric(x)+ |
+
| 16 | ++ | + + | +
| 17 | +835x | +
+ if (finite) {
+ |
+
| 18 | +24x | +
+ x <- x[is.finite(x)] # removes NAs too+ |
+
| 19 | +811x | +
+ } else if (na.rm) {
+ |
+
| 20 | +468x | +
+ x <- x[!is.na(x)]+ |
+
| 21 | ++ |
+ }+ |
+
| 22 | ++ | + + | +
| 23 | +835x | +
+ if (length(x) == 0) {
+ |
+
| 24 | +47x | +
+ rval <- c(NA, NA)+ |
+
| 25 | +47x | +
+ mode(rval) <- typeof(x)+ |
+
| 26 | ++ |
+ } else {
+ |
+
| 27 | +788x | +
+ rval <- c(min(x, na.rm = FALSE), max(x, na.rm = FALSE))+ |
+
| 28 | ++ |
+ }+ |
+
| 29 | ++ | + + | +
| 30 | +835x | +
+ 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 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' @return A `string`.+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' @export+ |
+
| 42 | ++ |
+ f_conf_level <- function(conf_level) {
+ |
+
| 43 | +1305x | +
+ assert_proportion_value(conf_level)+ |
+
| 44 | +1303x | +
+ 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 (`number`)\cr mean value to test under the null hypothesis.+ |
+
| 52 | ++ |
+ #'+ |
+
| 53 | ++ |
+ #' @return A `string`.+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' @export+ |
+
| 56 | ++ |
+ f_pval <- function(test_mean) {
+ |
+
| 57 | +334x | +
+ checkmate::assert_numeric(test_mean, len = 1)+ |
+
| 58 | +332x | +
+ paste0("p-value (H0: mean = ", test_mean, ")")
+ |
+
| 59 | ++ |
+ }+ |
+
| 60 | ++ | + + | +
| 61 | ++ |
+ #' Utility function to return a named list of covariate names.+ |
+
| 62 | ++ |
+ #'+ |
+
| 63 | ++ |
+ #' @param covariates (`character`)\cr a vector that can contain single variable names (such as+ |
+
| 64 | ++ |
+ #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`.+ |
+
| 65 | ++ |
+ #'+ |
+
| 66 | ++ |
+ #' @return A named `list` of `character` vector.+ |
+
| 67 | ++ |
+ #'+ |
+
| 68 | ++ |
+ #' @keywords internal+ |
+
| 69 | ++ |
+ 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)+ |
+
| 73 | ++ |
+ }+ |
+
| 74 | ++ | + + | +
| 75 | ++ |
+ #' Replicate Entries of a Vector if Required+ |
+
| 76 | ++ |
+ #'+ |
+
| 77 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 78 | ++ |
+ #'+ |
+
| 79 | ++ |
+ #' Replicate entries of a vector if required.+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 82 | ++ |
+ #' @param n (`count`)\cr how many entries we need.+ |
+
| 83 | ++ |
+ #'+ |
+
| 84 | ++ |
+ #' @return `x` if it has the required length already or is `NULL`,+ |
+
| 85 | ++ |
+ #' otherwise if it is scalar the replicated version of it with `n` entries.+ |
+
| 86 | ++ |
+ #'+ |
+
| 87 | ++ |
+ #' @note This function will fail if `x` is not of length `n` and/or is not a scalar.+ |
+
| 88 | ++ |
+ #'+ |
+
| 89 | ++ |
+ #' @export+ |
+
| 90 | ++ |
+ to_n <- function(x, n) {
+ |
+
| 91 | +1x | +
+ if (is.null(x)) {
+ |
+
| 92 | +! | +
+ NULL+ |
+
| 93 | +1x | +
+ } else if (length(x) == 1) {
+ |
+
| 94 | +! | +
+ rep(x, n)+ |
+
| 95 | +1x | +
+ } else if (length(x) == n) {
+ |
+
| 96 | +1x | +
+ x+ |
+
| 97 | ++ |
+ } else {
+ |
+
| 98 | +! | +
+ stop("dimension mismatch")
+ |
+
| 99 | ++ |
+ }+ |
+
| 100 | ++ |
+ }+ |
+
| 101 | ++ | + + | +
| 102 | ++ |
+ #' Check Element Dimension+ |
+
| 103 | ++ |
+ #'+ |
+
| 104 | ++ |
+ #' Checks if the elements in `...` have the same dimension.+ |
+
| 105 | ++ |
+ #'+ |
+
| 106 | ++ |
+ #' @param ... (`data.frame`s or `vector`s)\cr any data frames/vectors.+ |
+
| 107 | ++ |
+ #' @param omit_null (`logical`)\cr whether `NULL` elements in `...` should be omitted from the check.+ |
+
| 108 | ++ |
+ #'+ |
+
| 109 | ++ |
+ #' @return A `logical` value.+ |
+
| 110 | ++ |
+ #'+ |
+
| 111 | ++ |
+ #' @keywords internal+ |
+
| 112 | ++ |
+ check_same_n <- function(..., omit_null = TRUE) {
+ |
+
| 113 | +2x | +
+ dots <- list(...)+ |
+
| 114 | ++ | + + | +
| 115 | +2x | +
+ n_list <- Map(+ |
+
| 116 | +2x | +
+ function(x, name) {
+ |
+
| 117 | +5x | +
+ if (is.null(x)) {
+ |
+
| 118 | +! | +
+ if (omit_null) {
+ |
+
| 119 | +2x | +
+ NA_integer_+ |
+
| 120 | ++ |
+ } else {
+ |
+
| 121 | +! | +
+ stop("arg", name, "is not supposed to be NULL")
+ |
+
| 122 | ++ |
+ }+ |
+
| 123 | +5x | +
+ } else if (is.data.frame(x)) {
+ |
+
| 124 | +! | +
+ nrow(x)+ |
+
| 125 | +5x | +
+ } else if (is.atomic(x)) {
+ |
+
| 126 | +5x | +
+ length(x)+ |
+
| 127 | ++ |
+ } else {
+ |
+
| 128 | +! | +
+ stop("data structure for ", name, "is currently not supported")
+ |
+
| 129 | ++ |
+ }+ |
+
| 130 | ++ |
+ },+ |
+
| 131 | +2x | +
+ dots, names(dots)+ |
+
| 132 | ++ |
+ )+ |
+
| 133 | ++ | + + | +
| 134 | +2x | +
+ n <- stats::na.omit(unlist(n_list))+ |
+
| 135 | ++ | + + | +
| 136 | +2x | +
+ if (length(unique(n)) > 1) {
+ |
+
| 137 | +! | +
+ sel <- which(n != n[1])+ |
+
| 138 | +! | +
+ stop("dimension mismatch:", paste(names(n)[sel], collapse = ", "), " do not have N=", n[1])
+ |
+
| 139 | ++ |
+ }+ |
+
| 140 | ++ | + + | +
| 141 | +2x | +
+ TRUE+ |
+
| 142 | ++ |
+ }+ |
+
| 143 | ++ | + + | +
| 144 | ++ |
+ #' Make Names Without Dots+ |
+
| 145 | ++ |
+ #'+ |
+
| 146 | ++ |
+ #' @param nams (`character`)\cr vector of original names.+ |
+
| 147 | ++ |
+ #'+ |
+
| 148 | ++ |
+ #' @return A `character` `vector` of proper names, which does not use dots in contrast to [make.names()].+ |
+
| 149 | ++ |
+ #'+ |
+
| 150 | ++ |
+ #' @keywords internal+ |
+
| 151 | ++ |
+ make_names <- function(nams) {
+ |
+
| 152 | +6x | +
+ orig <- make.names(nams)+ |
+
| 153 | +6x | +
+ gsub(".", "", x = orig, fixed = TRUE)
+ |
+
| 154 | ++ |
+ }+ |
+
| 155 | ++ | + + | +
| 156 | ++ |
+ #' Conversion of Months to Days+ |
+
| 157 | ++ |
+ #'+ |
+
| 158 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 159 | ++ |
+ #'+ |
+
| 160 | ++ |
+ #' Conversion of Months to Days. This is an approximative calculation because it+ |
+
| 161 | ++ |
+ #' considers each month as having an average of 30.4375 days.+ |
+
| 162 | ++ |
+ #'+ |
+
| 163 | ++ |
+ #' @param x (`numeric`)\cr time in months.+ |
+
| 164 | ++ |
+ #'+ |
+
| 165 | ++ |
+ #' @return A `numeric` vector with the time in days.+ |
+
| 166 | ++ |
+ #'+ |
+
| 167 | ++ |
+ #' @examples+ |
+
| 168 | ++ |
+ #' x <- c(13.25, 8.15, 1, 2.834)+ |
+
| 169 | ++ |
+ #' month2day(x)+ |
+
| 170 | ++ |
+ #'+ |
+
| 171 | ++ |
+ #' @export+ |
+
| 172 | ++ |
+ month2day <- function(x) {
+ |
+
| 173 | +1x | +
+ checkmate::assert_numeric(x)+ |
+
| 174 | +1x | +
+ x * 30.4375+ |
+
| 175 | ++ |
+ }+ |
+
| 176 | ++ | + + | +
| 177 | ++ |
+ #' Conversion of Days to Months+ |
+
| 178 | ++ |
+ #'+ |
+
| 179 | ++ |
+ #' @param x (`numeric`)\cr time in days.+ |
+
| 180 | ++ |
+ #'+ |
+
| 181 | ++ |
+ #' @return A `numeric` vector with the time in months.+ |
+
| 182 | ++ |
+ #'+ |
+
| 183 | ++ |
+ #' @examples+ |
+
| 184 | ++ |
+ #' x <- c(403, 248, 30, 86)+ |
+
| 185 | ++ |
+ #' day2month(x)+ |
+
| 186 | ++ |
+ #'+ |
+
| 187 | ++ |
+ #' @export+ |
+
| 188 | ++ |
+ day2month <- function(x) {
+ |
+
| 189 | +15x | +
+ checkmate::assert_numeric(x)+ |
+
| 190 | +15x | +
+ x / 30.4375+ |
+
| 191 | ++ |
+ }+ |
+
| 192 | ++ | + + | +
| 193 | ++ |
+ #' Return an empty numeric if all elements are `NA`.+ |
+
| 194 | ++ |
+ #'+ |
+
| 195 | ++ |
+ #' @param x (`numeric`)\cr vector.+ |
+
| 196 | ++ |
+ #'+ |
+
| 197 | ++ |
+ #' @return An empty `numeric` if all elements of `x` are `NA`, otherwise `x`.+ |
+
| 198 | ++ |
+ #'+ |
+
| 199 | ++ |
+ #' @examples+ |
+
| 200 | ++ |
+ #' x <- c(NA, NA, NA)+ |
+
| 201 | ++ |
+ #' # Internal function - empty_vector_if_na+ |
+
| 202 | ++ |
+ #' @keywords internal+ |
+
| 203 | ++ |
+ empty_vector_if_na <- function(x) {
+ |
+
| 204 | +683x | +
+ if (all(is.na(x))) {
+ |
+
| 205 | +220x | +
+ numeric()+ |
+
| 206 | ++ |
+ } else {
+ |
+
| 207 | +463x | +
+ x+ |
+
| 208 | ++ |
+ }+ |
+
| 209 | ++ |
+ }+ |
+
| 210 | ++ | + + | +
| 211 | ++ |
+ #' Combine Two Vectors Element Wise+ |
+
| 212 | ++ |
+ #'+ |
+
| 213 | ++ |
+ #' @param x (`vector`)\cr first vector to combine.+ |
+
| 214 | ++ |
+ #' @param y (`vector`)\cr second vector to combine.+ |
+
| 215 | ++ |
+ #'+ |
+
| 216 | ++ |
+ #' @return A `list` where each element combines corresponding elements of `x` and `y`.+ |
+
| 217 | ++ |
+ #'+ |
+
| 218 | ++ |
+ #' @examples+ |
+
| 219 | ++ |
+ #' combine_vectors(1:3, 4:6)+ |
+
| 220 | ++ |
+ #'+ |
+
| 221 | ++ |
+ #' @export+ |
+
| 222 | ++ |
+ combine_vectors <- function(x, y) {
+ |
+
| 223 | +49x | +
+ checkmate::assert_vector(x)+ |
+
| 224 | +49x | +
+ checkmate::assert_vector(y, len = length(x))+ |
+
| 225 | ++ | + + | +
| 226 | +49x | +
+ result <- lapply(as.data.frame(rbind(x, y)), `c`)+ |
+
| 227 | +49x | +
+ names(result) <- NULL+ |
+
| 228 | +49x | +
+ result+ |
+
| 229 | ++ |
+ }+ |
+
| 230 | ++ | + + | +
| 231 | ++ |
+ #' Extract Elements by Name+ |
+
| 232 | ++ |
+ #'+ |
+
| 233 | ++ |
+ #' This utility function extracts elements from a vector `x` by `names`.+ |
+
| 234 | ++ |
+ #' Differences to the standard `[` function are:+ |
+
| 235 | ++ |
+ #'+ |
+
| 236 | ++ |
+ #' - If `x` is `NULL`, then still always `NULL` is returned (same as in base function).+ |
+
| 237 | ++ |
+ #' - If `x` is not `NULL`, then the intersection of its names is made with `names` and those+ |
+
| 238 | ++ |
+ #' elements are returned. That is, `names` which don't appear in `x` are not returned as `NA`s.+ |
+
| 239 | ++ |
+ #'+ |
+
| 240 | ++ |
+ #' @param x (named `vector`)\cr where to extract named elements from.+ |
+
| 241 | ++ |
+ #' @param names (`character`)\cr vector of names to extract.+ |
+
| 242 | ++ |
+ #'+ |
+
| 243 | ++ |
+ #' @return `NULL` if `x` is `NULL`, otherwise the extracted elements from `x`.+ |
+
| 244 | ++ |
+ #'+ |
+
| 245 | ++ |
+ #' @keywords internal+ |
+
| 246 | ++ |
+ extract_by_name <- function(x, names) {
+ |
+
| 247 | +5x | +
+ if (is.null(x)) {
+ |
+
| 248 | +1x | +
+ return(NULL)+ |
+
| 249 | ++ |
+ }+ |
+
| 250 | +4x | +
+ checkmate::assert_named(x)+ |
+
| 251 | +4x | +
+ checkmate::assert_character(names)+ |
+
| 252 | +4x | +
+ which_extract <- intersect(names(x), names)+ |
+
| 253 | +4x | +
+ if (length(which_extract) > 0) {
+ |
+
| 254 | +3x | +
+ x[which_extract]+ |
+
| 255 | ++ |
+ } else {
+ |
+
| 256 | +1x | +
+ NULL+ |
+
| 257 | ++ |
+ }+ |
+
| 258 | ++ |
+ }+ |
+
| 259 | ++ | + + | +
| 260 | ++ |
+ #' Labels for Adverse Event Baskets+ |
+
| 261 | ++ |
+ #'+ |
+
| 262 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 263 | ++ |
+ #'+ |
+
| 264 | ++ |
+ #' @param aesi (`character`)\cr with standardized `MedDRA` query name (e.g. `SMQzzNAM`) or customized query+ |
+
| 265 | ++ |
+ #' name (e.g. `CQzzNAM`).+ |
+
| 266 | ++ |
+ #' @param scope (`character`)\cr with scope of query (e.g. `SMQzzSC`).+ |
+
| 267 | ++ |
+ #'+ |
+
| 268 | ++ |
+ #' @return A `string` with the standard label for the `AE` basket.+ |
+
| 269 | ++ |
+ #'+ |
+
| 270 | ++ |
+ #' @examples+ |
+
| 271 | ++ |
+ #' adae <- tern_ex_adae+ |
+
| 272 | ++ |
+ #'+ |
+
| 273 | ++ |
+ #' # Standardized query label includes scope.+ |
+
| 274 | ++ |
+ #' aesi_label(adae$SMQ01NAM, scope = adae$SMQ01SC)+ |
+
| 275 | ++ |
+ #'+ |
+
| 276 | ++ |
+ #' # Customized query label.+ |
+
| 277 | ++ |
+ #' aesi_label(adae$CQ01NAM)+ |
+
| 278 | ++ |
+ #'+ |
+
| 279 | ++ |
+ #' @export+ |
+
| 280 | ++ |
+ aesi_label <- function(aesi, scope = NULL) {
+ |
+
| 281 | +3x | +
+ checkmate::assert_character(aesi)+ |
+
| 282 | +3x | +
+ checkmate::assert_character(scope, null.ok = TRUE)+ |
+
| 283 | +3x | +
+ aesi_label <- obj_label(aesi)+ |
+
| 284 | +3x | +
+ aesi <- sas_na(aesi)+ |
+
| 285 | +3x | +
+ aesi <- unique(aesi)[!is.na(unique(aesi))]+ |
+
| 286 | ++ | + + | +
| 287 | +3x | +
+ lbl <- if (length(aesi) == 1 && !is.null(scope)) {
+ |
+
| 288 | +1x | +
+ scope <- sas_na(scope)+ |
+
| 289 | +1x | +
+ scope <- unique(scope)[!is.na(unique(scope))]+ |
+
| 290 | +1x | +
+ checkmate::assert_string(scope)+ |
+
| 291 | +1x | +
+ paste0(aesi, " (", scope, ")")
+ |
+
| 292 | +3x | +
+ } else if (length(aesi) == 1 && is.null(scope)) {
+ |
+
| 293 | +1x | +
+ aesi+ |
+
| 294 | ++ |
+ } else {
+ |
+
| 295 | +1x | +
+ aesi_label+ |
+
| 296 | ++ |
+ }+ |
+
| 297 | ++ | + + | +
| 298 | +3x | +
+ lbl+ |
+
| 299 | ++ |
+ }+ |
+
| 300 | ++ | + + | +
| 301 | ++ |
+ #' Indicate Study Arm Variable in Formula+ |
+
| 302 | ++ |
+ #'+ |
+
| 303 | ++ |
+ #' We use `study_arm` to indicate the study arm variable in `tern` formulas.+ |
+
| 304 | ++ |
+ #'+ |
+
| 305 | ++ |
+ #' @param x arm information+ |
+
| 306 | ++ |
+ #'+ |
+
| 307 | ++ |
+ #' @return `x`+ |
+
| 308 | ++ |
+ #'+ |
+
| 309 | ++ |
+ #' @keywords internal+ |
+
| 310 | ++ |
+ study_arm <- function(x) {
+ |
+
| 311 | +! | +
+ structure(x, varname = deparse(substitute(x)))+ |
+
| 312 | ++ |
+ }+ |
+
| 313 | ++ | + + | +
| 314 | ++ |
+ #' Smooth Function with Optional Grouping+ |
+
| 315 | ++ |
+ #'+ |
+
| 316 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 317 | ++ |
+ #'+ |
+
| 318 | ++ |
+ #' This produces `loess` smoothed estimates of `y` with Student confidence intervals.+ |
+
| 319 | ++ |
+ #'+ |
+
| 320 | ++ |
+ #' @param df (`data.frame`)\cr data set containing all analysis variables.+ |
+
| 321 | ++ |
+ #' @param x (`character`)\cr value with x column name.+ |
+
| 322 | ++ |
+ #' @param y (`character`)\cr value with y column name.+ |
+
| 323 | ++ |
+ #' @param groups (`character`)\cr vector with optional grouping variables names.+ |
+
| 324 | ++ |
+ #' @param level (`numeric`)\cr level of confidence interval to use (0.95 by default).+ |
+
| 325 | ++ |
+ #'+ |
+
| 326 | ++ |
+ #' @return A `data.frame` with original `x`, smoothed `y`, `ylow`, and `yhigh`, and+ |
+
| 327 | ++ |
+ #' optional `groups` variables formatted as `factor` type.+ |
+
| 328 | ++ |
+ #'+ |
+
| 329 | ++ |
+ #' @export+ |
+
| 330 | ++ |
+ get_smooths <- function(df, x, y, groups = NULL, level = 0.95) {
+ |
+
| 331 | +5x | +
+ checkmate::assert_data_frame(df)+ |
+
| 332 | +5x | +
+ df_cols <- colnames(df)+ |
+
| 333 | +5x | +
+ checkmate::assert_string(x)+ |
+
| 334 | +5x | +
+ checkmate::assert_subset(x, df_cols)+ |
+
| 335 | +5x | +
+ checkmate::assert_numeric(df[[x]])+ |
+
| 336 | +5x | +
+ checkmate::assert_string(y)+ |
+
| 337 | +5x | +
+ checkmate::assert_subset(y, df_cols)+ |
+
| 338 | +5x | +
+ checkmate::assert_numeric(df[[y]])+ |
+
| 339 | ++ | + + | +
| 340 | +5x | +
+ if (!is.null(groups)) {
+ |
+
| 341 | +4x | +
+ checkmate::assert_character(groups)+ |
+
| 342 | +4x | +
+ checkmate::assert_subset(groups, df_cols)+ |
+
| 343 | ++ |
+ }+ |
+
| 344 | ++ | + + | +
| 345 | +5x | +
+ smooths <- function(x, y) {
+ |
+
| 346 | +18x | +
+ stats::predict(stats::loess(y ~ x), se = TRUE)+ |
+
| 347 | ++ |
+ }+ |
+
| 348 | ++ | + + | +
| 349 | +5x | +
+ if (!is.null(groups)) {
+ |
+
| 350 | +4x | +
+ cc <- stats::complete.cases(df[c(x, y, groups)])+ |
+
| 351 | +4x | +
+ df_c <- df[cc, c(x, y, groups)]+ |
+
| 352 | +4x | +
+ df_c_ordered <- df_c[do.call("order", as.list(df_c[, groups, drop = FALSE])), , drop = FALSE]
+ |
+
| 353 | +4x | +
+ df_c_g <- data.frame(Map(as.factor, df_c_ordered[groups]))+ |
+
| 354 | ++ | + + | +
| 355 | +4x | +
+ df_smooth_raw <-+ |
+
| 356 | +4x | +
+ by(df_c_ordered, df_c_g, function(d) {
+ |
+
| 357 | +17x | +
+ plx <- smooths(d[[x]], d[[y]])+ |
+
| 358 | +17x | +
+ data.frame(+ |
+
| 359 | +17x | +
+ x = d[[x]],+ |
+
| 360 | +17x | +
+ y = plx$fit,+ |
+
| 361 | +17x | +
+ ylow = plx$fit - stats::qt(level, plx$df) * plx$se,+ |
+
| 362 | +17x | +
+ yhigh = plx$fit + stats::qt(level, plx$df) * plx$se+ |
+
| 363 | ++ |
+ )+ |
+
| 364 | ++ |
+ })+ |
+
| 365 | ++ | + + | +
| 366 | +4x | +
+ df_smooth <- do.call(rbind, df_smooth_raw)+ |
+
| 367 | +4x | +
+ df_smooth[groups] <- df_c_g+ |
+
| 368 | ++ | + + | +
| 369 | +4x | +
+ df_smooth+ |
+
| 370 | ++ |
+ } else {
+ |
+
| 371 | +1x | +
+ cc <- stats::complete.cases(df[c(x, y)])+ |
+
| 372 | +1x | +
+ df_c <- df[cc, ]+ |
+
| 373 | +1x | +
+ plx <- smooths(df_c[[x]], df_c[[y]])+ |
+
| 374 | ++ | + + | +
| 375 | +1x | +
+ df_smooth <- data.frame(+ |
+
| 376 | +1x | +
+ x = df_c[[x]],+ |
+
| 377 | +1x | +
+ y = plx$fit,+ |
+
| 378 | +1x | +
+ ylow = plx$fit - stats::qt(level, plx$df) * plx$se,+ |
+
| 379 | +1x | +
+ yhigh = plx$fit + stats::qt(level, plx$df) * plx$se+ |
+
| 380 | ++ |
+ )+ |
+
| 381 | ++ | + + | +
| 382 | +1x | +
+ df_smooth+ |
+
| 383 | ++ |
+ }+ |
+
| 384 | ++ |
+ }+ |
+
| 385 | ++ | + + | +
| 386 | ++ |
+ #' Number of Available (Non-Missing Entries) in a Vector+ |
+
| 387 | ++ |
+ #'+ |
+
| 388 | ++ |
+ #' Small utility function for better readability.+ |
+
| 389 | ++ |
+ #'+ |
+
| 390 | ++ |
+ #' @param x (`any`)\cr vector in which to count non-missing values.+ |
+
| 391 | ++ |
+ #'+ |
+
| 392 | ++ |
+ #' @return Number of non-missing values.+ |
+
| 393 | ++ |
+ #'+ |
+
| 394 | ++ |
+ #' @keywords internal+ |
+
| 395 | ++ |
+ n_available <- function(x) {
+ |
+
| 396 | +254x | +
+ sum(!is.na(x))+ |
+
| 397 | ++ |
+ }+ |
+
| 398 | ++ | + + | +
| 399 | ++ |
+ #' Reapply Variable Labels+ |
+
| 400 | ++ |
+ #'+ |
+
| 401 | ++ |
+ #' This is a helper function that is used in tests.+ |
+
| 402 | ++ |
+ #'+ |
+
| 403 | ++ |
+ #' @param x (`vector`)\cr vector of elements that needs new labels.+ |
+
| 404 | ++ |
+ #' @param varlabels (`character`)\cr vector of labels for `x`.+ |
+
| 405 | ++ |
+ #' @param ... further parameters to be added to the list.+ |
+
| 406 | ++ |
+ #'+ |
+
| 407 | ++ |
+ #' @return `x` with variable labels reapplied.+ |
+
| 408 | ++ |
+ #'+ |
+
| 409 | ++ |
+ #' @export+ |
+
| 410 | ++ |
+ reapply_varlabels <- function(x, varlabels, ...) {
+ |
+
| 411 | +10x | +
+ named_labels <- c(as.list(varlabels), list(...))+ |
+
| 412 | +10x | +
+ formatters::var_labels(x)[names(named_labels)] <- as.character(named_labels)+ |
+
| 413 | +10x | +
+ x+ |
+
| 414 | ++ |
+ }+ |
+
| 415 | ++ | + + | +
| 416 | ++ |
+ # Wrapper function of survival::clogit so that when model fitting failed, a more useful message would show+ |
+
| 417 | ++ |
+ clogit_with_tryCatch <- function(formula, data, ...) { # nolint
+ |
+
| 418 | +30x | +
+ tryCatch(+ |
+
| 419 | +30x | +
+ survival::clogit(formula = formula, data = data, ...),+ |
+
| 420 | +30x | +
+ error = function(e) stop("model not built successfully with survival::clogit")
+ |
+
| 421 | ++ |
+ )+ |
+
| 422 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Confidence Intervals for a Difference of Binomials+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("experimental")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Several confidence intervals for the difference between proportions.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @name desctools_binom+ |
+
| 8 | ++ |
+ NULL+ |
+
| 9 | ++ | + + | +
| 10 | ++ |
+ #' Recycle List of Parameters+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' This function recycles all supplied elements to the maximal dimension.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @param ... (`any`)\cr Elements to recycle.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @return A `list`.+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @keywords internal+ |
+
| 19 | ++ |
+ #' @noRd+ |
+
| 20 | ++ |
+ h_recycle <- function(...) {
+ |
+
| 21 | +60x | +
+ lst <- list(...)+ |
+
| 22 | +60x | +
+ maxdim <- max(lengths(lst))+ |
+
| 23 | +60x | +
+ res <- lapply(lst, rep, length.out = maxdim)+ |
+
| 24 | +60x | +
+ attr(res, "maxdim") <- maxdim+ |
+
| 25 | +60x | +
+ return(res)+ |
+
| 26 | ++ |
+ }+ |
+
| 27 | ++ | + + | +
| 28 | ++ |
+ #' @describeIn desctools_binom Several confidence intervals for the difference between proportions.+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' @return A `matrix` of 3 values:+ |
+
| 31 | ++ |
+ #' * `est`: estimate of proportion difference.+ |
+
| 32 | ++ |
+ #' * `lwr.ci`: estimate of lower end of the confidence interval.+ |
+
| 33 | ++ |
+ #' * `upr.ci`: estimate of upper end of the confidence interval.+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' @keywords internal+ |
+
| 36 | ++ |
+ desctools_binom <- function(x1,+ |
+
| 37 | ++ |
+ n1,+ |
+
| 38 | ++ |
+ x2,+ |
+
| 39 | ++ |
+ n2,+ |
+
| 40 | ++ |
+ conf.level = 0.95, # nolint+ |
+
| 41 | ++ |
+ sides = c("two.sided", "left", "right"),
+ |
+
| 42 | ++ |
+ method = c(+ |
+
| 43 | ++ |
+ "ac", "wald", "waldcc", "score", "scorecc", "mn", "mee", "blj", "ha", "hal", "jp"+ |
+
| 44 | ++ |
+ )) {
+ |
+
| 45 | +18x | +
+ if (missing(sides)) {
+ |
+
| 46 | +18x | +
+ sides <- match.arg(sides)+ |
+
| 47 | ++ |
+ }+ |
+
| 48 | +18x | +
+ if (missing(method)) {
+ |
+
| 49 | +1x | +
+ method <- match.arg(method)+ |
+
| 50 | ++ |
+ }+ |
+
| 51 | +18x | +
+ iBinomDiffCI <- function(x1, n1, x2, n2, conf.level, sides, method) { # nolint
+ |
+
| 52 | +18x | +
+ if (sides != "two.sided") {
+ |
+
| 53 | +! | +
+ conf.level <- 1 - 2 * (1 - conf.level) # nolint+ |
+
| 54 | ++ |
+ }+ |
+
| 55 | +18x | +
+ alpha <- 1 - conf.level+ |
+
| 56 | +18x | +
+ kappa <- stats::qnorm(1 - alpha / 2)+ |
+
| 57 | +18x | +
+ p1_hat <- x1 / n1+ |
+
| 58 | +18x | +
+ p2_hat <- x2 / n2+ |
+
| 59 | +18x | +
+ est <- p1_hat - p2_hat+ |
+
| 60 | +18x | +
+ switch(method,+ |
+
| 61 | +18x | +
+ wald = {
+ |
+
| 62 | +2x | +
+ vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2+ |
+
| 63 | +2x | +
+ term2 <- kappa * sqrt(vd)+ |
+
| 64 | +2x | +
+ ci_lwr <- max(-1, est - term2)+ |
+
| 65 | +2x | +
+ ci_upr <- min(1, est + term2)+ |
+
| 66 | ++ |
+ },+ |
+
| 67 | +18x | +
+ waldcc = {
+ |
+
| 68 | +2x | +
+ vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2+ |
+
| 69 | +2x | +
+ term2 <- kappa * sqrt(vd)+ |
+
| 70 | +2x | +
+ term2 <- term2 + 0.5 * (1 / n1 + 1 / n2)+ |
+
| 71 | +2x | +
+ ci_lwr <- max(-1, est - term2)+ |
+
| 72 | +2x | +
+ ci_upr <- min(1, est + term2)+ |
+
| 73 | ++ |
+ },+ |
+
| 74 | +18x | +
+ ac = {
+ |
+
| 75 | +2x | +
+ n1 <- n1 + 2+ |
+
| 76 | +2x | +
+ n2 <- n2 + 2+ |
+
| 77 | +2x | +
+ x1 <- x1 + 1+ |
+
| 78 | +2x | +
+ x2 <- x2 + 1+ |
+
| 79 | +2x | +
+ p1_hat <- x1 / n1+ |
+
| 80 | +2x | +
+ p2_hat <- x2 / n2+ |
+
| 81 | +2x | +
+ est1 <- p1_hat - p2_hat+ |
+
| 82 | +2x | +
+ vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2+ |
+
| 83 | +2x | +
+ term2 <- kappa * sqrt(vd)+ |
+
| 84 | +2x | +
+ ci_lwr <- max(-1, est1 - term2)+ |
+
| 85 | +2x | +
+ ci_upr <- min(1, est1 + term2)+ |
+
| 86 | ++ |
+ },+ |
+
| 87 | +18x | +
+ exact = {
+ |
+
| 88 | +! | +
+ ci_lwr <- NA+ |
+
| 89 | +! | +
+ ci_upr <- NA+ |
+
| 90 | ++ |
+ },+ |
+
| 91 | +18x | +
+ score = {
+ |
+
| 92 | +2x | +
+ w1 <- desctools_binomci(+ |
+
| 93 | +2x | +
+ x = x1, n = n1, conf.level = conf.level,+ |
+
| 94 | +2x | +
+ method = "wilson"+ |
+
| 95 | ++ |
+ )+ |
+
| 96 | +2x | +
+ w2 <- desctools_binomci(+ |
+
| 97 | +2x | +
+ x = x2, n = n2, conf.level = conf.level,+ |
+
| 98 | +2x | +
+ method = "wilson"+ |
+
| 99 | ++ |
+ )+ |
+
| 100 | +2x | +
+ l1 <- w1[2]+ |
+
| 101 | +2x | +
+ u1 <- w1[3]+ |
+
| 102 | +2x | +
+ l2 <- w2[2]+ |
+
| 103 | +2x | +
+ u2 <- w2[3]+ |
+
| 104 | +2x | +
+ ci_lwr <- est - kappa * sqrt(l1 * (1 - l1) / n1 + u2 * (1 - u2) / n2)+ |
+
| 105 | +2x | +
+ ci_upr <- est + kappa * sqrt(u1 * (1 - u1) / n1 + l2 * (1 - l2) / n2)+ |
+
| 106 | ++ |
+ },+ |
+
| 107 | +18x | +
+ scorecc = {
+ |
+
| 108 | +1x | +
+ w1 <- desctools_binomci(+ |
+
| 109 | +1x | +
+ x = x1, n = n1, conf.level = conf.level,+ |
+
| 110 | +1x | +
+ method = "wilsoncc"+ |
+
| 111 | ++ |
+ )+ |
+
| 112 | +1x | +
+ w2 <- desctools_binomci(+ |
+
| 113 | +1x | +
+ x = x2, n = n2, conf.level = conf.level,+ |
+
| 114 | +1x | +
+ method = "wilsoncc"+ |
+
| 115 | ++ |
+ )+ |
+
| 116 | +1x | +
+ l1 <- w1[2]+ |
+
| 117 | +1x | +
+ u1 <- w1[3]+ |
+
| 118 | +1x | +
+ l2 <- w2[2]+ |
+
| 119 | +1x | +
+ u2 <- w2[3]+ |
+
| 120 | +1x | +
+ ci_lwr <- max(-1, est - sqrt((p1_hat - l1)^2 + (u2 - p2_hat)^2))+ |
+
| 121 | +1x | +
+ ci_upr <- min(1, est + sqrt((u1 - p1_hat)^2 + (p2_hat - l2)^2))+ |
+
| 122 | ++ |
+ },+ |
+
| 123 | +18x | +
+ mee = {
+ |
+
| 124 | +1x | +
+ .score <- function(p1, n1, p2, n2, dif) {
+ |
+
| 125 | +! | +
+ if (dif > 1) dif <- 1+ |
+
| 126 | +! | +
+ if (dif < -1) dif <- -1+ |
+
| 127 | +24x | +
+ diff <- p1 - p2 - dif+ |
+
| 128 | +24x | +
+ if (abs(diff) == 0) {
+ |
+
| 129 | +! | +
+ res <- 0+ |
+
| 130 | ++ |
+ } else {
+ |
+
| 131 | +24x | +
+ t <- n2 / n1+ |
+
| 132 | +24x | +
+ a <- 1 + t+ |
+
| 133 | +24x | +
+ b <- -(1 + t + p1 + t * p2 + dif * (t + 2))+ |
+
| 134 | +24x | +
+ c <- dif * dif + dif * (2 * p1 + t + 1) + p1 + t * p2+ |
+
| 135 | +24x | +
+ d <- -p1 * dif * (1 + dif)+ |
+
| 136 | +24x | +
+ v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2+ |
+
| 137 | +24x | +
+ if (abs(v) < .Machine$double.eps) v <- 0+ |
+
| 138 | +24x | +
+ s <- sqrt((b / a / 3)^2 - c / a / 3)+ |
+
| 139 | +24x | +
+ u <- ifelse(v > 0, 1, -1) * s+ |
+
| 140 | +24x | +
+ w <- (3.141592654 + acos(v / u^3)) / 3+ |
+
| 141 | +24x | +
+ p1d <- 2 * u * cos(w) - b / a / 3+ |
+
| 142 | +24x | +
+ p2d <- p1d - dif+ |
+
| 143 | +24x | +
+ n <- n1 + n2+ |
+
| 144 | +24x | +
+ res <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2)+ |
+
| 145 | ++ |
+ }+ |
+
| 146 | +24x | +
+ return(sqrt(res))+ |
+
| 147 | ++ |
+ }+ |
+
| 148 | +1x | +
+ pval <- function(delta) {
+ |
+
| 149 | +24x | +
+ z <- (est - delta) / .score(p1_hat, n1, p2_hat, n2, delta)+ |
+
| 150 | +24x | +
+ 2 * min(stats::pnorm(z), 1 - stats::pnorm(z))+ |
+
| 151 | ++ |
+ }+ |
+
| 152 | +1x | +
+ ci_lwr <- max(-1, stats::uniroot(function(delta) {
+ |
+
| 153 | +12x | +
+ pval(delta) - alpha+ |
+
| 154 | +1x | +
+ }, interval = c(-1 + 1e-06, est - 1e-06))$root)+ |
+
| 155 | +1x | +
+ ci_upr <- min(1, stats::uniroot(function(delta) {
+ |
+
| 156 | +12x | +
+ pval(delta) - alpha+ |
+
| 157 | +1x | +
+ }, interval = c(est + 1e-06, 1 - 1e-06))$root)+ |
+
| 158 | ++ |
+ },+ |
+
| 159 | +18x | +
+ blj = {
+ |
+
| 160 | +1x | +
+ p1_dash <- (x1 + 0.5) / (n1 + 1)+ |
+
| 161 | +1x | +
+ p2_dash <- (x2 + 0.5) / (n2 + 1)+ |
+
| 162 | +1x | +
+ vd <- p1_dash * (1 - p1_dash) / n1 + p2_dash * (1 - p2_dash) / n2+ |
+
| 163 | +1x | +
+ term2 <- kappa * sqrt(vd)+ |
+
| 164 | +1x | +
+ est_dash <- p1_dash - p2_dash+ |
+
| 165 | +1x | +
+ ci_lwr <- max(-1, est_dash - term2)+ |
+
| 166 | +1x | +
+ ci_upr <- min(1, est_dash + term2)+ |
+
| 167 | ++ |
+ },+ |
+
| 168 | +18x | +
+ ha = {
+ |
+
| 169 | +4x | +
+ term2 <- 1 /+ |
+
| 170 | +4x | +
+ (2 * min(n1, n2)) + kappa * sqrt(p1_hat * (1 - p1_hat) / (n1 - 1) + p2_hat * (1 - p2_hat) / (n2 - 1))+ |
+
| 171 | +4x | +
+ ci_lwr <- max(-1, est - term2)+ |
+
| 172 | +4x | +
+ ci_upr <- min(1, est + term2)+ |
+
| 173 | ++ |
+ },+ |
+
| 174 | +18x | +
+ mn = {
+ |
+
| 175 | +1x | +
+ .conf <- function(x1, n1, x2, n2, z, lower = FALSE) {
+ |
+
| 176 | +2x | +
+ p1 <- x1 / n1+ |
+
| 177 | +2x | +
+ p2 <- x2 / n2+ |
+
| 178 | +2x | +
+ p_hat <- p1 - p2+ |
+
| 179 | +2x | +
+ dp <- 1 + ifelse(lower, 1, -1) * p_hat+ |
+
| 180 | +2x | +
+ i <- 1+ |
+
| 181 | +2x | +
+ while (i <= 50) {
+ |
+
| 182 | +46x | +
+ dp <- 0.5 * dp+ |
+
| 183 | +46x | +
+ y <- p_hat + ifelse(lower, -1, 1) * dp+ |
+
| 184 | +46x | +
+ score <- .score(p1, n1, p2, n2, y)+ |
+
| 185 | +46x | +
+ if (score < z) {
+ |
+
| 186 | +20x | +
+ p_hat <- y+ |
+
| 187 | ++ |
+ }+ |
+
| 188 | +46x | +
+ if ((dp < 1e-07) || (abs(z - score) < 1e-06)) {
+ |
+
| 189 | +2x | +
+ (break)()+ |
+
| 190 | ++ |
+ } else {
+ |
+
| 191 | +44x | +
+ i <- i + 1+ |
+
| 192 | ++ |
+ }+ |
+
| 193 | ++ |
+ }+ |
+
| 194 | +2x | +
+ return(y)+ |
+
| 195 | ++ |
+ }+ |
+
| 196 | +1x | +
+ .score <- function(p1, n1, p2, n2, dif) {
+ |
+
| 197 | +46x | +
+ diff <- p1 - p2 - dif+ |
+
| 198 | +46x | +
+ if (abs(diff) == 0) {
+ |
+
| 199 | +! | +
+ res <- 0+ |
+
| 200 | ++ |
+ } else {
+ |
+
| 201 | +46x | +
+ t <- n2 / n1+ |
+
| 202 | +46x | +
+ a <- 1 + t+ |
+
| 203 | +46x | +
+ b <- -(1 + t + p1 + t * p2 + dif * (t + 2))+ |
+
| 204 | +46x | +
+ c <- dif * dif + dif * (2 * p1 + t + 1) + p1 + t * p2+ |
+
| 205 | +46x | +
+ d <- -p1 * dif * (1 + dif)+ |
+
| 206 | +46x | +
+ v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2+ |
+
| 207 | +46x | +
+ s <- sqrt((b / a / 3)^2 - c / a / 3)+ |
+
| 208 | +46x | +
+ u <- ifelse(v > 0, 1, -1) * s+ |
+
| 209 | +46x | +
+ w <- (3.141592654 + acos(v / u^3)) / 3+ |
+
| 210 | +46x | +
+ p1d <- 2 * u * cos(w) - b / a / 3+ |
+
| 211 | +46x | +
+ p2d <- p1d - dif+ |
+
| 212 | +46x | +
+ n <- n1 + n2+ |
+
| 213 | +46x | +
+ var <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2) * n / (n - 1)+ |
+
| 214 | +46x | +
+ res <- diff^2 / var+ |
+
| 215 | ++ |
+ }+ |
+
| 216 | +46x | +
+ return(res)+ |
+
| 217 | ++ |
+ }+ |
+
| 218 | +1x | +
+ z <- stats::qchisq(conf.level, 1)+ |
+
| 219 | +1x | +
+ ci_lwr <- max(-1, .conf(x1, n1, x2, n2, z, TRUE))+ |
+
| 220 | +1x | +
+ ci_upr <- min(1, .conf(x1, n1, x2, n2, z, FALSE))+ |
+
| 221 | ++ |
+ },+ |
+
| 222 | +18x | +
+ beal = {
+ |
+
| 223 | +! | +
+ a <- p1_hat + p2_hat+ |
+
| 224 | +! | +
+ b <- p1_hat - p2_hat+ |
+
| 225 | +! | +
+ u <- ((1 / n1) + (1 / n2)) / 4+ |
+
| 226 | +! | +
+ v <- ((1 / n1) - (1 / n2)) / 4+ |
+
| 227 | +! | +
+ V <- u * ((2 - a) * a - b^2) + 2 * v * (1 - a) * b # nolint+ |
+
| 228 | +! | +
+ z <- stats::qchisq(p = 1 - alpha / 2, df = 1)+ |
+
| 229 | +! | +
+ A <- sqrt(z * (V + z * u^2 * (2 - a) * a + z * v^2 * (1 - a)^2)) # nolint+ |
+
| 230 | +! | +
+ B <- (b + z * v * (1 - a)) / (1 + z * u) # nolint+ |
+
| 231 | +! | +
+ ci_lwr <- max(-1, B - A / (1 + z * u))+ |
+
| 232 | +! | +
+ ci_upr <- min(1, B + A / (1 + z * u))+ |
+
| 233 | ++ |
+ },+ |
+
| 234 | +18x | +
+ hal = {
+ |
+
| 235 | +1x | +
+ psi <- (p1_hat + p2_hat) / 2+ |
+
| 236 | +1x | +
+ u <- (1 / n1 + 1 / n2) / 4+ |
+
| 237 | +1x | +
+ v <- (1 / n1 - 1 / n2) / 4+ |
+
| 238 | +1x | +
+ z <- kappa+ |
+
| 239 | +1x | +
+ theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 * psi)) / (1 + z^2 * u)+ |
+
| 240 | +1x | +
+ w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) - (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) *+ |
+
| 241 | +1x | +
+ (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) * psi + z^2 * v^2 * (1 - 2 * psi)^2) # nolint+ |
+
| 242 | +1x | +
+ c(theta + w, theta - w)+ |
+
| 243 | +1x | +
+ ci_lwr <- max(-1, theta - w)+ |
+
| 244 | +1x | +
+ ci_upr <- min(1, theta + w)+ |
+
| 245 | ++ |
+ },+ |
+
| 246 | +18x | +
+ jp = {
+ |
+
| 247 | +1x | +
+ psi <- 0.5 * ((x1 + 0.5) / (n1 + 1) + (x2 + 0.5) / (n2 + 1))+ |
+
| 248 | +1x | +
+ u <- (1 / n1 + 1 / n2) / 4+ |
+
| 249 | +1x | +
+ v <- (1 / n1 - 1 / n2) / 4+ |
+
| 250 | +1x | +
+ z <- kappa+ |
+
| 251 | +1x | +
+ theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 * psi)) / (1 + z^2 * u)+ |
+
| 252 | +1x | +
+ w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) - (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) *+ |
+
| 253 | +1x | +
+ (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) * psi + z^2 * v^2 * (1 - 2 * psi)^2) # nolint+ |
+
| 254 | +1x | +
+ c(theta + w, theta - w)+ |
+
| 255 | +1x | +
+ ci_lwr <- max(-1, theta - w)+ |
+
| 256 | +1x | +
+ ci_upr <- min(1, theta + w)+ |
+
| 257 | ++ |
+ },+ |
+
| 258 | ++ |
+ )+ |
+
| 259 | +18x | +
+ ci <- c(+ |
+
| 260 | +18x | +
+ est = est, lwr.ci = min(ci_lwr, ci_upr),+ |
+
| 261 | +18x | +
+ upr.ci = max(ci_lwr, ci_upr)+ |
+
| 262 | ++ |
+ )+ |
+
| 263 | +18x | +
+ if (sides == "left") {
+ |
+
| 264 | +! | +
+ ci[3] <- 1+ |
+
| 265 | +18x | +
+ } else if (sides == "right") {
+ |
+
| 266 | +! | +
+ ci[2] <- -1+ |
+
| 267 | ++ |
+ }+ |
+
| 268 | +18x | +
+ return(ci)+ |
+
| 269 | ++ |
+ }+ |
+
| 270 | +18x | +
+ method <- match.arg(arg = method, several.ok = TRUE)+ |
+
| 271 | +18x | +
+ sides <- match.arg(arg = sides, several.ok = TRUE)+ |
+
| 272 | +18x | +
+ lst <- h_recycle(+ |
+
| 273 | +18x | +
+ x1 = x1, n1 = n1, x2 = x2, n2 = n2, conf.level = conf.level,+ |
+
| 274 | +18x | +
+ sides = sides, method = method+ |
+
| 275 | ++ |
+ )+ |
+
| 276 | +18x | +
+ res <- t(sapply(1:attr(lst, "maxdim"), function(i) {
+ |
+
| 277 | +18x | +
+ iBinomDiffCI(+ |
+
| 278 | +18x | +
+ x1 = lst$x1[i],+ |
+
| 279 | +18x | +
+ n1 = lst$n1[i], x2 = lst$x2[i], n2 = lst$n2[i], conf.level = lst$conf.level[i],+ |
+
| 280 | +18x | +
+ sides = lst$sides[i], method = lst$method[i]+ |
+
| 281 | ++ |
+ )+ |
+
| 282 | ++ |
+ }))+ |
+
| 283 | +18x | +
+ lgn <- h_recycle(x1 = if (is.null(names(x1))) {
+ |
+
| 284 | +18x | +
+ paste("x1", seq_along(x1), sep = ".")
+ |
+
| 285 | ++ |
+ } else {
+ |
+
| 286 | +! | +
+ names(x1)+ |
+
| 287 | +18x | +
+ }, n1 = if (is.null(names(n1))) {
+ |
+
| 288 | +18x | +
+ paste("n1", seq_along(n1), sep = ".")
+ |
+
| 289 | ++ |
+ } else {
+ |
+
| 290 | +! | +
+ names(n1)+ |
+
| 291 | +18x | +
+ }, x2 = if (is.null(names(x2))) {
+ |
+
| 292 | +18x | +
+ paste("x2", seq_along(x2), sep = ".")
+ |
+
| 293 | ++ |
+ } else {
+ |
+
| 294 | +! | +
+ names(x2)+ |
+
| 295 | +18x | +
+ }, n2 = if (is.null(names(n2))) {
+ |
+
| 296 | +18x | +
+ paste("n2", seq_along(n2), sep = ".")
+ |
+
| 297 | ++ |
+ } else {
+ |
+
| 298 | +! | +
+ names(n2)+ |
+
| 299 | +18x | +
+ }, conf.level = conf.level, sides = sides, method = method)+ |
+
| 300 | +18x | +
+ xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
+ |
+
| 301 | +126x | +
+ length(unique(x)) !=+ |
+
| 302 | +126x | +
+ 1+ |
+
| 303 | +18x | +
+ })]), 1, paste, collapse = ":")+ |
+
| 304 | +18x | +
+ rownames(res) <- xn+ |
+
| 305 | +18x | +
+ return(res)+ |
+
| 306 | ++ |
+ }+ |
+
| 307 | ++ | + + | +
| 308 | ++ |
+ #' @describeIn desctools_binom Compute confidence intervals for binomial proportions.+ |
+
| 309 | ++ |
+ #'+ |
+
| 310 | ++ |
+ #' @param x (`count`)\cr number of successes+ |
+
| 311 | ++ |
+ #' @param n (`count`)\cr number of trials+ |
+
| 312 | ++ |
+ #' @param conf.level (`proportion`)\cr confidence level, defaults to 0.95.+ |
+
| 313 | ++ |
+ #' @param sides (`character`)\cr side of the confidence interval to compute. Must be one of `"two-sided"` (default),+ |
+
| 314 | ++ |
+ #' `"left"`, or `"right"`.+ |
+
| 315 | ++ |
+ #' @param method (`character`)\cr method to use. Can be one out of: `"wald"`, `"wilson"`, `"wilsoncc"`,+ |
+
| 316 | ++ |
+ #' `"agresti-coull"`, `"jeffreys"`, `"modified wilson"`, `"modified jeffreys"`, `"clopper-pearson"`, `"arcsine"`,+ |
+
| 317 | ++ |
+ #' `"logit"`, `"witting"`, `"pratt"`, `"midp"`, `"lik"`, and `"blaker"`.+ |
+
| 318 | ++ |
+ #'+ |
+
| 319 | ++ |
+ #' @return A `matrix` with 3 columns containing:+ |
+
| 320 | ++ |
+ #' * `est`: estimate of proportion difference.+ |
+
| 321 | ++ |
+ #' * `lwr.ci`: lower end of the confidence interval.+ |
+
| 322 | ++ |
+ #' * `upr.ci`: upper end of the confidence interval.+ |
+
| 323 | ++ |
+ #'+ |
+
| 324 | ++ |
+ #' @keywords internal+ |
+
| 325 | ++ |
+ desctools_binomci <- function(x,+ |
+
| 326 | ++ |
+ n,+ |
+
| 327 | ++ |
+ conf.level = 0.95, # nolint+ |
+
| 328 | ++ |
+ sides = c("two.sided", "left", "right"),
+ |
+
| 329 | ++ |
+ method = c(+ |
+
| 330 | ++ |
+ "wilson", "wald", "waldcc", "agresti-coull",+ |
+
| 331 | ++ |
+ "jeffreys", "modified wilson", "wilsoncc", "modified jeffreys",+ |
+
| 332 | ++ |
+ "clopper-pearson", "arcsine", "logit", "witting", "pratt",+ |
+
| 333 | ++ |
+ "midp", "lik", "blaker"+ |
+
| 334 | ++ |
+ ),+ |
+
| 335 | ++ |
+ rand = 123,+ |
+
| 336 | ++ |
+ tol = 1e-05) {
+ |
+
| 337 | +24x | +
+ if (missing(method)) {
+ |
+
| 338 | +1x | +
+ method <- "wilson"+ |
+
| 339 | ++ |
+ }+ |
+
| 340 | +24x | +
+ if (missing(sides)) {
+ |
+
| 341 | +23x | +
+ sides <- "two.sided"+ |
+
| 342 | ++ |
+ }+ |
+
| 343 | +24x | +
+ iBinomCI <- function(x, n, conf.level = 0.95, sides = c("two.sided", "left", "right"), # nolint
+ |
+
| 344 | +24x | +
+ method = c(+ |
+
| 345 | +24x | +
+ "wilson", "wilsoncc", "wald",+ |
+
| 346 | +24x | +
+ "waldcc", "agresti-coull", "jeffreys", "modified wilson",+ |
+
| 347 | +24x | +
+ "modified jeffreys", "clopper-pearson", "arcsine", "logit",+ |
+
| 348 | +24x | +
+ "witting", "pratt", "midp", "lik", "blaker"+ |
+
| 349 | ++ |
+ ),+ |
+
| 350 | +24x | +
+ rand = 123,+ |
+
| 351 | +24x | +
+ tol = 1e-05) {
+ |
+
| 352 | +24x | +
+ if (length(x) != 1) {
+ |
+
| 353 | +! | +
+ stop("'x' has to be of length 1 (number of successes)")
+ |
+
| 354 | ++ |
+ }+ |
+
| 355 | +24x | +
+ if (length(n) != 1) {
+ |
+
| 356 | +! | +
+ stop("'n' has to be of length 1 (number of trials)")
+ |
+
| 357 | ++ |
+ }+ |
+
| 358 | +24x | +
+ if (length(conf.level) != 1) {
+ |
+
| 359 | +! | +
+ stop("'conf.level' has to be of length 1 (confidence level)")
+ |
+
| 360 | ++ |
+ }+ |
+
| 361 | +24x | +
+ if (conf.level < 0.5 || conf.level > 1) {
+ |
+
| 362 | +! | +
+ stop("'conf.level' has to be in [0.5, 1]")
+ |
+
| 363 | ++ |
+ }+ |
+
| 364 | +24x | +
+ sides <- match.arg(sides, choices = c(+ |
+
| 365 | +24x | +
+ "two.sided", "left",+ |
+
| 366 | +24x | +
+ "right"+ |
+
| 367 | +24x | +
+ ), several.ok = FALSE)+ |
+
| 368 | +24x | +
+ if (sides != "two.sided") {
+ |
+
| 369 | +1x | +
+ conf.level <- 1 - 2 * (1 - conf.level) # nolint+ |
+
| 370 | ++ |
+ }+ |
+
| 371 | +24x | +
+ alpha <- 1 - conf.level+ |
+
| 372 | +24x | +
+ kappa <- stats::qnorm(1 - alpha / 2)+ |
+
| 373 | +24x | +
+ p_hat <- x / n+ |
+
| 374 | +24x | +
+ q_hat <- 1 - p_hat+ |
+
| 375 | +24x | +
+ est <- p_hat+ |
+
| 376 | +24x | +
+ switch(match.arg(arg = method, choices = c(+ |
+
| 377 | +24x | +
+ "wilson",+ |
+
| 378 | +24x | +
+ "wald", "waldcc", "wilsoncc", "agresti-coull", "jeffreys",+ |
+
| 379 | +24x | +
+ "modified wilson", "modified jeffreys", "clopper-pearson",+ |
+
| 380 | +24x | +
+ "arcsine", "logit", "witting", "pratt", "midp", "lik",+ |
+
| 381 | +24x | +
+ "blaker"+ |
+
| 382 | ++ |
+ )),+ |
+
| 383 | +24x | +
+ wald = {
+ |
+
| 384 | +1x | +
+ term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n)+ |
+
| 385 | +1x | +
+ ci_lwr <- max(0, p_hat - term2)+ |
+
| 386 | +1x | +
+ ci_upr <- min(1, p_hat + term2)+ |
+
| 387 | ++ |
+ },+ |
+
| 388 | +24x | +
+ waldcc = {
+ |
+
| 389 | +1x | +
+ term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n)+ |
+
| 390 | +1x | +
+ term2 <- term2 + 1 / (2 * n)+ |
+
| 391 | +1x | +
+ ci_lwr <- max(0, p_hat - term2)+ |
+
| 392 | +1x | +
+ ci_upr <- min(1, p_hat + term2)+ |
+
| 393 | ++ |
+ },+ |
+
| 394 | +24x | +
+ wilson = {
+ |
+
| 395 | +6x | +
+ term1 <- (x + kappa^2 / 2) / (n + kappa^2)+ |
+
| 396 | +6x | +
+ term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat * q_hat + kappa^2 / (4 * n))+ |
+
| 397 | +6x | +
+ ci_lwr <- max(0, term1 - term2)+ |
+
| 398 | +6x | +
+ ci_upr <- min(1, term1 + term2)+ |
+
| 399 | ++ |
+ },+ |
+
| 400 | +24x | +
+ wilsoncc = {
+ |
+
| 401 | +3x | +
+ lci <- (+ |
+
| 402 | +3x | +
+ 2 * x + kappa^2 - 1 - kappa * sqrt(kappa^2 - 2 - 1 / n + 4 * p_hat * (n * q_hat + 1))+ |
+
| 403 | +3x | +
+ ) / (2 * (n + kappa^2))+ |
+
| 404 | +3x | +
+ uci <- (+ |
+
| 405 | +3x | +
+ 2 * x + kappa^2 + 1 + kappa * sqrt(kappa^2 + 2 - 1 / n + 4 * p_hat * (n * q_hat - 1))+ |
+
| 406 | +3x | +
+ ) / (2 * (n + kappa^2))+ |
+
| 407 | +3x | +
+ ci_lwr <- max(0, ifelse(p_hat == 0, 0, lci))+ |
+
| 408 | +3x | +
+ ci_upr <- min(1, ifelse(p_hat == 1, 1, uci))+ |
+
| 409 | ++ |
+ },+ |
+
| 410 | +24x | +
+ `agresti-coull` = {
+ |
+
| 411 | +1x | +
+ x_tilde <- x + kappa^2 / 2+ |
+
| 412 | +1x | +
+ n_tilde <- n + kappa^2+ |
+
| 413 | +1x | +
+ p_tilde <- x_tilde / n_tilde+ |
+
| 414 | +1x | +
+ q_tilde <- 1 - p_tilde+ |
+
| 415 | +1x | +
+ est <- p_tilde+ |
+
| 416 | +1x | +
+ term2 <- kappa * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)+ |
+
| 417 | +1x | +
+ ci_lwr <- max(0, p_tilde - term2)+ |
+
| 418 | +1x | +
+ ci_upr <- min(1, p_tilde + term2)+ |
+
| 419 | ++ |
+ },+ |
+
| 420 | +24x | +
+ jeffreys = {
+ |
+
| 421 | +1x | +
+ if (x == 0) {
+ |
+
| 422 | +! | +
+ ci_lwr <- 0+ |
+
| 423 | ++ |
+ } else {
+ |
+
| 424 | +1x | +
+ ci_lwr <- stats::qbeta(+ |
+
| 425 | +1x | +
+ alpha / 2,+ |
+
| 426 | +1x | +
+ x + 0.5, n - x + 0.5+ |
+
| 427 | ++ |
+ )+ |
+
| 428 | ++ |
+ }+ |
+
| 429 | +1x | +
+ if (x == n) {
+ |
+
| 430 | +! | +
+ ci_upr <- 1+ |
+
| 431 | ++ |
+ } else {
+ |
+
| 432 | +1x | +
+ ci_upr <- stats::qbeta(1 - alpha / 2, x + 0.5, n - x + 0.5)+ |
+
| 433 | ++ |
+ }+ |
+
| 434 | ++ |
+ },+ |
+
| 435 | +24x | +
+ `modified wilson` = {
+ |
+
| 436 | +1x | +
+ term1 <- (x + kappa^2 / 2) / (n + kappa^2)+ |
+
| 437 | +1x | +
+ term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat * q_hat + kappa^2 / (4 * n))+ |
+
| 438 | +1x | +
+ if ((n <= 50 & x %in% c(1, 2)) | (n >= 51 & x %in% c(1:3))) {
+ |
+
| 439 | +! | +
+ ci_lwr <- 0.5 * stats::qchisq(alpha, 2 * x) / n+ |
+
| 440 | ++ |
+ } else {
+ |
+
| 441 | +1x | +
+ ci_lwr <- max(0, term1 - term2)+ |
+
| 442 | ++ |
+ }+ |
+
| 443 | +1x | +
+ if ((n <= 50 & x %in% c(n - 1, n - 2)) | (n >= 51 & x %in% c(n - (1:3)))) {
+ |
+
| 444 | +! | +
+ ci_upr <- 1 - 0.5 * stats::qchisq(+ |
+
| 445 | +! | +
+ alpha,+ |
+
| 446 | +! | +
+ 2 * (n - x)+ |
+
| 447 | +! | +
+ ) / n+ |
+
| 448 | ++ |
+ } else {
+ |
+
| 449 | +1x | +
+ ci_upr <- min(1, term1 + term2)+ |
+
| 450 | ++ |
+ }+ |
+
| 451 | ++ |
+ },+ |
+
| 452 | +24x | +
+ `modified jeffreys` = {
+ |
+
| 453 | +1x | +
+ if (x == n) {
+ |
+
| 454 | +! | +
+ ci_lwr <- (alpha / 2)^(1 / n)+ |
+
| 455 | ++ |
+ } else {
+ |
+
| 456 | +1x | +
+ if (x <= 1) {
+ |
+
| 457 | +! | +
+ ci_lwr <- 0+ |
+
| 458 | ++ |
+ } else {
+ |
+
| 459 | +1x | +
+ ci_lwr <- stats::qbeta(+ |
+
| 460 | +1x | +
+ alpha / 2,+ |
+
| 461 | +1x | +
+ x + 0.5, n - x + 0.5+ |
+
| 462 | ++ |
+ )+ |
+
| 463 | ++ |
+ }+ |
+
| 464 | ++ |
+ }+ |
+
| 465 | +1x | +
+ if (x == 0) {
+ |
+
| 466 | +! | +
+ ci_upr <- 1 - (alpha / 2)^(1 / n)+ |
+
| 467 | ++ |
+ } else {
+ |
+
| 468 | +1x | +
+ if (x >= n - 1) {
+ |
+
| 469 | +! | +
+ ci_upr <- 1+ |
+
| 470 | ++ |
+ } else {
+ |
+
| 471 | +1x | +
+ ci_upr <- stats::qbeta(1 - alpha / 2, x + 0.5, n - x + 0.5)+ |
+
| 472 | ++ |
+ }+ |
+
| 473 | ++ |
+ }+ |
+
| 474 | ++ |
+ },+ |
+
| 475 | +24x | +
+ `clopper-pearson` = {
+ |
+
| 476 | +1x | +
+ ci_lwr <- stats::qbeta(alpha / 2, x, n - x + 1)+ |
+
| 477 | +1x | +
+ ci_upr <- stats::qbeta(1 - alpha / 2, x + 1, n - x)+ |
+
| 478 | ++ |
+ },+ |
+
| 479 | +24x | +
+ arcsine = {
+ |
+
| 480 | +1x | +
+ p_tilde <- (x + 0.375) / (n + 0.75)+ |
+
| 481 | +1x | +
+ est <- p_tilde+ |
+
| 482 | +1x | +
+ ci_lwr <- sin(asin(sqrt(p_tilde)) - 0.5 * kappa / sqrt(n))^2+ |
+
| 483 | +1x | +
+ ci_upr <- sin(asin(sqrt(p_tilde)) + 0.5 * kappa / sqrt(n))^2+ |
+
| 484 | ++ |
+ },+ |
+
| 485 | +24x | +
+ logit = {
+ |
+
| 486 | +1x | +
+ lambda_hat <- log(x / (n - x))+ |
+
| 487 | +1x | +
+ V_hat <- n / (x * (n - x)) # nolint+ |
+
| 488 | +1x | +
+ lambda_lower <- lambda_hat - kappa * sqrt(V_hat)+ |
+
| 489 | +1x | +
+ lambda_upper <- lambda_hat + kappa * sqrt(V_hat)+ |
+
| 490 | +1x | +
+ ci_lwr <- exp(lambda_lower) / (1 + exp(lambda_lower))+ |
+
| 491 | +1x | +
+ ci_upr <- exp(lambda_upper) / (1 + exp(lambda_upper))+ |
+
| 492 | ++ |
+ },+ |
+
| 493 | +24x | +
+ witting = {
+ |
+
| 494 | +1x | +
+ set.seed(rand)+ |
+
| 495 | +1x | +
+ x_tilde <- x + stats::runif(1, min = 0, max = 1)+ |
+
| 496 | +1x | +
+ pbinom_abscont <- function(q, size, prob) {
+ |
+
| 497 | +22x | +
+ v <- trunc(q)+ |
+
| 498 | +22x | +
+ term1 <- stats::pbinom(v - 1, size = size, prob = prob)+ |
+
| 499 | +22x | +
+ term2 <- (q - v) * stats::dbinom(v, size = size, prob = prob)+ |
+
| 500 | +22x | +
+ return(term1 + term2)+ |
+
| 501 | ++ |
+ }+ |
+
| 502 | +1x | +
+ qbinom_abscont <- function(p, size, x) {
+ |
+
| 503 | +2x | +
+ fun <- function(prob, size, x, p) {
+ |
+
| 504 | +22x | +
+ pbinom_abscont(x, size, prob) - p+ |
+
| 505 | ++ |
+ }+ |
+
| 506 | +2x | +
+ stats::uniroot(fun,+ |
+
| 507 | +2x | +
+ interval = c(0, 1), size = size,+ |
+
| 508 | +2x | +
+ x = x, p = p+ |
+
| 509 | +2x | +
+ )$root+ |
+
| 510 | ++ |
+ }+ |
+
| 511 | +1x | +
+ ci_lwr <- qbinom_abscont(1 - alpha, size = n, x = x_tilde)+ |
+
| 512 | +1x | +
+ ci_upr <- qbinom_abscont(alpha, size = n, x = x_tilde)+ |
+
| 513 | ++ |
+ },+ |
+
| 514 | +24x | +
+ pratt = {
+ |
+
| 515 | +1x | +
+ if (x == 0) {
+ |
+
| 516 | +! | +
+ ci_lwr <- 0+ |
+
| 517 | +! | +
+ ci_upr <- 1 - alpha^(1 / n)+ |
+
| 518 | +1x | +
+ } else if (x == 1) {
+ |
+
| 519 | +! | +
+ ci_lwr <- 1 - (1 - alpha / 2)^(1 / n)+ |
+
| 520 | +! | +
+ ci_upr <- 1 - (alpha / 2)^(1 / n)+ |
+
| 521 | +1x | +
+ } else if (x == (n - 1)) {
+ |
+
| 522 | +! | +
+ ci_lwr <- (alpha / 2)^(1 / n)+ |
+
| 523 | +! | +
+ ci_upr <- (1 - alpha / 2)^(1 / n)+ |
+
| 524 | +1x | +
+ } else if (x == n) {
+ |
+
| 525 | +! | +
+ ci_lwr <- alpha^(1 / n)+ |
+
| 526 | +! | +
+ ci_upr <- 1+ |
+
| 527 | ++ |
+ } else {
+ |
+
| 528 | +1x | +
+ z <- stats::qnorm(1 - alpha / 2)+ |
+
| 529 | +1x | +
+ A <- ((x + 1) / (n - x))^2 # nolint+ |
+
| 530 | +1x | +
+ B <- 81 * (x + 1) * (n - x) - 9 * n - 8 # nolint+ |
+
| 531 | +1x | +
+ C <- (0 - 3) * z * sqrt(9 * (x + 1) * (n - x) * (9 * n + 5 - z^2) + n + 1) # nolint+ |
+
| 532 | +1x | +
+ D <- 81 * (x + 1)^2 - 9 * (x + 1) * (2 + z^2) + 1 # nolint+ |
+
| 533 | +1x | +
+ E <- 1 + A * ((B + C) / D)^3 # nolint+ |
+
| 534 | +1x | +
+ ci_upr <- 1 / E+ |
+
| 535 | +1x | +
+ A <- (x / (n - x - 1))^2 # nolint+ |
+
| 536 | +1x | +
+ B <- 81 * x * (n - x - 1) - 9 * n - 8 # nolint+ |
+
| 537 | +1x | +
+ C <- 3 * z * sqrt(9 * x * (n - x - 1) * (9 * n + 5 - z^2) + n + 1) # nolint+ |
+
| 538 | +1x | +
+ D <- 81 * x^2 - 9 * x * (2 + z^2) + 1 # nolint+ |
+
| 539 | +1x | +
+ E <- 1 + A * ((B + C) / D)^3 # nolint+ |
+
| 540 | +1x | +
+ ci_lwr <- 1 / E+ |
+
| 541 | ++ |
+ }+ |
+
| 542 | ++ |
+ },+ |
+
| 543 | +24x | +
+ midp = {
+ |
+
| 544 | +1x | +
+ f_low <- function(pi, x, n) {
+ |
+
| 545 | +12x | +
+ 1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x,+ |
+
| 546 | +12x | +
+ size = n, prob = pi, lower.tail = FALSE+ |
+
| 547 | ++ |
+ ) -+ |
+
| 548 | +12x | +
+ (1 - conf.level) / 2+ |
+
| 549 | ++ |
+ }+ |
+
| 550 | +1x | +
+ f_up <- function(pi, x, n) {
+ |
+
| 551 | +12x | +
+ 1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x - 1, size = n, prob = pi) - (1 - conf.level) / 2+ |
+
| 552 | ++ |
+ }+ |
+
| 553 | +1x | +
+ ci_lwr <- 0+ |
+
| 554 | +1x | +
+ ci_upr <- 1+ |
+
| 555 | +1x | +
+ if (x != 0) {
+ |
+
| 556 | +1x | +
+ ci_lwr <- stats::uniroot(f_low,+ |
+
| 557 | +1x | +
+ interval = c(0, p_hat),+ |
+
| 558 | +1x | +
+ x = x, n = n+ |
+
| 559 | +1x | +
+ )$root+ |
+
| 560 | ++ |
+ }+ |
+
| 561 | +1x | +
+ if (x != n) {
+ |
+
| 562 | +1x | +
+ ci_upr <- stats::uniroot(f_up, interval = c(+ |
+
| 563 | +1x | +
+ p_hat,+ |
+
| 564 | +1x | +
+ 1+ |
+
| 565 | +1x | +
+ ), x = x, n = n)$root+ |
+
| 566 | ++ |
+ }+ |
+
| 567 | ++ |
+ },+ |
+
| 568 | +24x | +
+ lik = {
+ |
+
| 569 | +2x | +
+ ci_lwr <- 0+ |
+
| 570 | +2x | +
+ ci_upr <- 1+ |
+
| 571 | +2x | +
+ z <- stats::qnorm(1 - alpha * 0.5)+ |
+
| 572 | +2x | +
+ tol <- .Machine$double.eps^0.5+ |
+
| 573 | +2x | +
+ BinDev <- function(y, x, mu, wt, bound = 0, tol = .Machine$double.eps^0.5, # nolint+ |
+
| 574 | ++ |
+ ...) {
+ |
+
| 575 | +40x | +
+ ll_y <- ifelse(y %in% c(0, 1), 0, stats::dbinom(x, wt,+ |
+
| 576 | +40x | +
+ y,+ |
+
| 577 | +40x | +
+ log = TRUE+ |
+
| 578 | ++ |
+ ))+ |
+
| 579 | +40x | +
+ ll_mu <- ifelse(mu %in% c(0, 1), 0, stats::dbinom(x,+ |
+
| 580 | +40x | +
+ wt, mu,+ |
+
| 581 | +40x | +
+ log = TRUE+ |
+
| 582 | ++ |
+ ))+ |
+
| 583 | +40x | +
+ res <- ifelse(abs(y - mu) < tol, 0, sign(y - mu) * sqrt(-2 * (ll_y - ll_mu)))+ |
+
| 584 | +40x | +
+ return(res - bound)+ |
+
| 585 | ++ |
+ }+ |
+
| 586 | +2x | +
+ if (x != 0 && tol < p_hat) {
+ |
+
| 587 | +2x | +
+ ci_lwr <- if (BinDev(+ |
+
| 588 | +2x | +
+ tol, x, p_hat, n, -z,+ |
+
| 589 | +2x | +
+ tol+ |
+
| 590 | +2x | +
+ ) <= 0) {
+ |
+
| 591 | +2x | +
+ stats::uniroot(+ |
+
| 592 | +2x | +
+ f = BinDev, interval = c(tol, if (p_hat < tol || p_hat == 1) {
+ |
+
| 593 | +! | +
+ 1 - tol+ |
+
| 594 | ++ |
+ } else {
+ |
+
| 595 | +2x | +
+ p_hat+ |
+
| 596 | +2x | +
+ }), bound = -z,+ |
+
| 597 | +2x | +
+ x = x, mu = p_hat, wt = n+ |
+
| 598 | +2x | +
+ )$root+ |
+
| 599 | ++ |
+ }+ |
+
| 600 | ++ |
+ }+ |
+
| 601 | +2x | +
+ if (x != n && p_hat < (1 - tol)) {
+ |
+
| 602 | +2x | +
+ ci_upr <- if (+ |
+
| 603 | +2x | +
+ BinDev(y = 1 - tol, x = x, mu = ifelse(p_hat > 1 - tol, tol, p_hat), wt = n, bound = z, tol = tol) < 0) { # nolint
+ |
+
| 604 | +! | +
+ ci_lwr <- if (BinDev(+ |
+
| 605 | +! | +
+ tol, x, if (p_hat < tol || p_hat == 1) {
+ |
+
| 606 | +! | +
+ 1 - tol+ |
+
| 607 | ++ |
+ } else {
+ |
+
| 608 | +! | +
+ p_hat+ |
+
| 609 | +! | +
+ }, n,+ |
+
| 610 | +! | +
+ -z, tol+ |
+
| 611 | +! | +
+ ) <= 0) {
+ |
+
| 612 | +! | +
+ stats::uniroot(+ |
+
| 613 | +! | +
+ f = BinDev, interval = c(tol, p_hat),+ |
+
| 614 | +! | +
+ bound = -z, x = x, mu = p_hat, wt = n+ |
+
| 615 | +! | +
+ )$root+ |
+
| 616 | ++ |
+ }+ |
+
| 617 | ++ |
+ } else {
+ |
+
| 618 | +2x | +
+ stats::uniroot(+ |
+
| 619 | +2x | +
+ f = BinDev, interval = c(if (p_hat > 1 - tol) {
+ |
+
| 620 | +! | +
+ tol+ |
+
| 621 | ++ |
+ } else {
+ |
+
| 622 | +2x | +
+ p_hat+ |
+
| 623 | +2x | +
+ }, 1 - tol), bound = z,+ |
+
| 624 | +2x | +
+ x = x, mu = p_hat, wt = n+ |
+
| 625 | +2x | +
+ )$root+ |
+
| 626 | ++ |
+ }+ |
+
| 627 | ++ |
+ }+ |
+
| 628 | ++ |
+ },+ |
+
| 629 | +24x | +
+ blaker = {
+ |
+
| 630 | +1x | +
+ acceptbin <- function(x, n, p) {
+ |
+
| 631 | +3954x | +
+ p1 <- 1 - stats::pbinom(x - 1, n, p)+ |
+
| 632 | +3954x | +
+ p2 <- stats::pbinom(x, n, p)+ |
+
| 633 | +3954x | +
+ a1 <- p1 + stats::pbinom(stats::qbinom(p1, n, p) - 1, n, p)+ |
+
| 634 | +3954x | +
+ a2 <- p2 + 1 - stats::pbinom(+ |
+
| 635 | +3954x | +
+ stats::qbinom(1 - p2, n, p), n,+ |
+
| 636 | +3954x | +
+ p+ |
+
| 637 | ++ |
+ )+ |
+
| 638 | +3954x | +
+ return(min(a1, a2))+ |
+
| 639 | ++ |
+ }+ |
+
| 640 | +1x | +
+ ci_lwr <- 0+ |
+
| 641 | +1x | +
+ ci_upr <- 1+ |
+
| 642 | +1x | +
+ if (x != 0) {
+ |
+
| 643 | +1x | +
+ ci_lwr <- stats::qbeta((1 - conf.level) / 2, x, n - x + 1)+ |
+
| 644 | +1x | +
+ while (acceptbin(x, n, ci_lwr + tol) < (1 - conf.level)) {
+ |
+
| 645 | +1976x | +
+ ci_lwr <- ci_lwr + tol+ |
+
| 646 | ++ |
+ }+ |
+
| 647 | ++ |
+ }+ |
+
| 648 | +1x | +
+ if (x != n) {
+ |
+
| 649 | +1x | +
+ ci_upr <- stats::qbeta(1 - (1 - conf.level) / 2, x + 1, n - x)+ |
+
| 650 | +1x | +
+ while (acceptbin(x, n, ci_upr - tol) < (1 - conf.level)) {
+ |
+
| 651 | +1976x | +
+ ci_upr <- ci_upr - tol+ |
+
| 652 | ++ |
+ }+ |
+
| 653 | ++ |
+ }+ |
+
| 654 | ++ |
+ }+ |
+
| 655 | ++ |
+ )+ |
+
| 656 | +24x | +
+ ci <- c(est = est, lwr.ci = max(0, ci_lwr), upr.ci = min(+ |
+
| 657 | +24x | +
+ 1,+ |
+
| 658 | +24x | +
+ ci_upr+ |
+
| 659 | ++ |
+ ))+ |
+
| 660 | +24x | +
+ if (sides == "left") {
+ |
+
| 661 | +1x | +
+ ci[3] <- 1+ |
+
| 662 | +23x | +
+ } else if (sides == "right") {
+ |
+
| 663 | +! | +
+ ci[2] <- 0+ |
+
| 664 | ++ |
+ }+ |
+
| 665 | +24x | +
+ return(ci)+ |
+
| 666 | ++ |
+ }+ |
+
| 667 | +24x | +
+ lst <- list(+ |
+
| 668 | +24x | +
+ x = x, n = n, conf.level = conf.level, sides = sides,+ |
+
| 669 | +24x | +
+ method = method, rand = rand+ |
+
| 670 | ++ |
+ )+ |
+
| 671 | +24x | +
+ maxdim <- max(unlist(lapply(lst, length)))+ |
+
| 672 | +24x | +
+ lgp <- lapply(lst, rep, length.out = maxdim)+ |
+
| 673 | +24x | +
+ lgn <- h_recycle(x = if (is.null(names(x))) {
+ |
+
| 674 | +24x | +
+ paste("x", seq_along(x), sep = ".")
+ |
+
| 675 | ++ |
+ } else {
+ |
+
| 676 | +! | +
+ names(x)+ |
+
| 677 | +24x | +
+ }, n = if (is.null(names(n))) {
+ |
+
| 678 | +24x | +
+ paste("n", seq_along(n), sep = ".")
+ |
+
| 679 | ++ |
+ } else {
+ |
+
| 680 | +! | +
+ names(n)+ |
+
| 681 | +24x | +
+ }, conf.level = conf.level, sides = sides, method = method)+ |
+
| 682 | +24x | +
+ xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
+ |
+
| 683 | +120x | +
+ length(unique(x)) !=+ |
+
| 684 | +120x | +
+ 1+ |
+
| 685 | +24x | +
+ })]), 1, paste, collapse = ":")+ |
+
| 686 | +24x | +
+ res <- t(sapply(1:maxdim, function(i) {
+ |
+
| 687 | +24x | +
+ iBinomCI(+ |
+
| 688 | +24x | +
+ x = lgp$x[i],+ |
+
| 689 | +24x | +
+ n = lgp$n[i], conf.level = lgp$conf.level[i], sides = lgp$sides[i],+ |
+
| 690 | +24x | +
+ method = lgp$method[i], rand = lgp$rand[i]+ |
+
| 691 | ++ |
+ )+ |
+
| 692 | ++ |
+ }))+ |
+
| 693 | +24x | +
+ colnames(res)[1] <- c("est")
+ |
+
| 694 | +24x | +
+ rownames(res) <- xn+ |
+
| 695 | +24x | +
+ return(res)+ |
+
| 696 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Proportion Difference+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @seealso [d_proportion_diff()]+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @name prop_diff+ |
+
| 10 | ++ |
+ NULL+ |
+
| 11 | ++ | + + | +
| 12 | ++ |
+ #' @describeIn prop_diff Statistics function estimating the difference+ |
+
| 13 | ++ |
+ #' in terms of responder proportion.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @inheritParams prop_diff_strat_nc+ |
+
| 16 | ++ |
+ #' @param method (`string`)\cr the method used for the confidence interval estimation.+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @return+ |
+
| 19 | ++ |
+ #' * `s_proportion_diff()` returns a named list of elements `diff` and `diff_ci`.+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @note When performing an unstratified analysis, methods `"cmh"`, `"strat_newcombe"`, and `"strat_newcombecc"` are+ |
+
| 22 | ++ |
+ #' not permitted.+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @examples+ |
+
| 25 | ++ |
+ #' # Summary+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' ## "Mid" case: 4/4 respond in group A, 1/2 respond in group B.+ |
+
| 28 | ++ |
+ #' nex <- 100 # Number of example rows+ |
+
| 29 | ++ |
+ #' dta <- data.frame(+ |
+
| 30 | ++ |
+ #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE),+ |
+
| 31 | ++ |
+ #' "grp" = sample(c("A", "B"), nex, TRUE),
+ |
+
| 32 | ++ |
+ #' "f1" = sample(c("a1", "a2"), nex, TRUE),
+ |
+
| 33 | ++ |
+ #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
+ |
+
| 34 | ++ |
+ #' stringsAsFactors = TRUE+ |
+
| 35 | ++ |
+ #' )+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' s_proportion_diff(+ |
+
| 38 | ++ |
+ #' df = subset(dta, grp == "A"),+ |
+
| 39 | ++ |
+ #' .var = "rsp",+ |
+
| 40 | ++ |
+ #' .ref_group = subset(dta, grp == "B"),+ |
+
| 41 | ++ |
+ #' .in_ref_col = FALSE,+ |
+
| 42 | ++ |
+ #' conf_level = 0.90,+ |
+
| 43 | ++ |
+ #' method = "ha"+ |
+
| 44 | ++ |
+ #' )+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' # CMH example with strata+ |
+
| 47 | ++ |
+ #' s_proportion_diff(+ |
+
| 48 | ++ |
+ #' df = subset(dta, grp == "A"),+ |
+
| 49 | ++ |
+ #' .var = "rsp",+ |
+
| 50 | ++ |
+ #' .ref_group = subset(dta, grp == "B"),+ |
+
| 51 | ++ |
+ #' .in_ref_col = FALSE,+ |
+
| 52 | ++ |
+ #' variables = list(strata = c("f1", "f2")),
+ |
+
| 53 | ++ |
+ #' conf_level = 0.90,+ |
+
| 54 | ++ |
+ #' method = "cmh"+ |
+
| 55 | ++ |
+ #' )+ |
+
| 56 | ++ |
+ #'+ |
+
| 57 | ++ |
+ #' @export+ |
+
| 58 | ++ |
+ s_proportion_diff <- function(df,+ |
+
| 59 | ++ |
+ .var,+ |
+
| 60 | ++ |
+ .ref_group,+ |
+
| 61 | ++ |
+ .in_ref_col,+ |
+
| 62 | ++ |
+ variables = list(strata = NULL),+ |
+
| 63 | ++ |
+ conf_level = 0.95,+ |
+
| 64 | ++ |
+ method = c(+ |
+
| 65 | ++ |
+ "waldcc", "wald", "cmh",+ |
+
| 66 | ++ |
+ "ha", "newcombe", "newcombecc",+ |
+
| 67 | ++ |
+ "strat_newcombe", "strat_newcombecc"+ |
+
| 68 | ++ |
+ ),+ |
+
| 69 | ++ |
+ weights_method = "cmh") {
+ |
+
| 70 | +2x | +
+ method <- match.arg(method)+ |
+
| 71 | +2x | +
+ if (is.null(variables$strata) && checkmate::test_subset(method, c("cmh", "strat_newcombe", "strat_newcombecc"))) {
+ |
+
| 72 | +! | +
+ stop(paste(+ |
+
| 73 | +! | +
+ "When performing an unstratified analysis, methods 'cmh', 'strat_newcombe', and 'strat_newcombecc' are not",+ |
+
| 74 | +! | +
+ "permitted. Please choose a different method."+ |
+
| 75 | ++ |
+ ))+ |
+
| 76 | ++ |
+ }+ |
+
| 77 | +2x | +
+ y <- list(diff = "", diff_ci = "")+ |
+
| 78 | ++ | + + | +
| 79 | +2x | +
+ if (!.in_ref_col) {
+ |
+
| 80 | +2x | +
+ rsp <- c(.ref_group[[.var]], df[[.var]])+ |
+
| 81 | +2x | +
+ grp <- factor(+ |
+
| 82 | +2x | +
+ rep(+ |
+
| 83 | +2x | +
+ c("ref", "Not-ref"),
+ |
+
| 84 | +2x | +
+ c(nrow(.ref_group), nrow(df))+ |
+
| 85 | ++ |
+ ),+ |
+
| 86 | +2x | +
+ levels = c("ref", "Not-ref")
+ |
+
| 87 | ++ |
+ )+ |
+
| 88 | ++ | + + | +
| 89 | +2x | +
+ if (!is.null(variables$strata)) {
+ |
+
| 90 | +1x | +
+ strata_colnames <- variables$strata+ |
+
| 91 | +1x | +
+ checkmate::assert_character(strata_colnames, null.ok = FALSE)+ |
+
| 92 | +1x | +
+ strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)+ |
+
| 93 | ++ | + + | +
| 94 | +1x | +
+ assert_df_with_variables(df, strata_vars)+ |
+
| 95 | +1x | +
+ assert_df_with_variables(.ref_group, strata_vars)+ |
+
| 96 | ++ | + + | +
| 97 | ++ |
+ # Merging interaction strata for reference group rows data and remaining+ |
+
| 98 | +1x | +
+ strata <- c(+ |
+
| 99 | +1x | +
+ interaction(.ref_group[strata_colnames]),+ |
+
| 100 | +1x | +
+ interaction(df[strata_colnames])+ |
+
| 101 | ++ |
+ )+ |
+
| 102 | +1x | +
+ strata <- as.factor(strata)+ |
+
| 103 | ++ |
+ }+ |
+
| 104 | ++ | + + | +
| 105 | ++ |
+ # Defining the std way to calculate weights for strat_newcombe+ |
+
| 106 | +2x | +
+ if (!is.null(variables$weights_method)) {
+ |
+
| 107 | +! | +
+ weights_method <- variables$weights_method+ |
+
| 108 | ++ |
+ } else {
+ |
+
| 109 | +2x | +
+ weights_method <- "cmh"+ |
+
| 110 | ++ |
+ }+ |
+
| 111 | ++ | + + | +
| 112 | +2x | +
+ y <- switch(method,+ |
+
| 113 | +2x | +
+ "wald" = prop_diff_wald(rsp, grp, conf_level, correct = FALSE),+ |
+
| 114 | +2x | +
+ "waldcc" = prop_diff_wald(rsp, grp, conf_level, correct = TRUE),+ |
+
| 115 | +2x | +
+ "ha" = prop_diff_ha(rsp, grp, conf_level),+ |
+
| 116 | +2x | +
+ "newcombe" = prop_diff_nc(rsp, grp, conf_level, correct = FALSE),+ |
+
| 117 | +2x | +
+ "newcombecc" = prop_diff_nc(rsp, grp, conf_level, correct = TRUE),+ |
+
| 118 | +2x | +
+ "strat_newcombe" = prop_diff_strat_nc(rsp,+ |
+
| 119 | +2x | +
+ grp,+ |
+
| 120 | +2x | +
+ strata,+ |
+
| 121 | +2x | +
+ weights_method,+ |
+
| 122 | +2x | +
+ conf_level,+ |
+
| 123 | +2x | +
+ correct = FALSE+ |
+
| 124 | ++ |
+ ),+ |
+
| 125 | +2x | +
+ "strat_newcombecc" = prop_diff_strat_nc(rsp,+ |
+
| 126 | +2x | +
+ grp,+ |
+
| 127 | +2x | +
+ strata,+ |
+
| 128 | +2x | +
+ weights_method,+ |
+
| 129 | +2x | +
+ conf_level,+ |
+
| 130 | +2x | +
+ correct = TRUE+ |
+
| 131 | ++ |
+ ),+ |
+
| 132 | +2x | +
+ "cmh" = prop_diff_cmh(rsp, grp, strata, conf_level)[c("diff", "diff_ci")]
+ |
+
| 133 | ++ |
+ )+ |
+
| 134 | ++ | + + | +
| 135 | +2x | +
+ y$diff <- y$diff * 100+ |
+
| 136 | +2x | +
+ y$diff_ci <- y$diff_ci * 100+ |
+
| 137 | ++ |
+ }+ |
+
| 138 | ++ | + + | +
| 139 | +2x | +
+ attr(y$diff, "label") <- "Difference in Response rate (%)"+ |
+
| 140 | +2x | +
+ attr(y$diff_ci, "label") <- d_proportion_diff(+ |
+
| 141 | +2x | +
+ conf_level, method,+ |
+
| 142 | +2x | +
+ long = FALSE+ |
+
| 143 | ++ |
+ )+ |
+
| 144 | ++ | + + | +
| 145 | +2x | +
+ y+ |
+
| 146 | ++ |
+ }+ |
+
| 147 | ++ | + + | +
| 148 | ++ |
+ #' @describeIn prop_diff Formatted analysis function which is used as `afun` in `estimate_proportion_diff()`.+ |
+
| 149 | ++ |
+ #'+ |
+
| 150 | ++ |
+ #' @return+ |
+
| 151 | ++ |
+ #' * `a_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 152 | ++ |
+ #'+ |
+
| 153 | ++ |
+ #' @examples+ |
+
| 154 | ++ |
+ #' a_proportion_diff(+ |
+
| 155 | ++ |
+ #' df = subset(dta, grp == "A"),+ |
+
| 156 | ++ |
+ #' .var = "rsp",+ |
+
| 157 | ++ |
+ #' .ref_group = subset(dta, grp == "B"),+ |
+
| 158 | ++ |
+ #' .in_ref_col = FALSE,+ |
+
| 159 | ++ |
+ #' conf_level = 0.90,+ |
+
| 160 | ++ |
+ #' method = "ha"+ |
+
| 161 | ++ |
+ #' )+ |
+
| 162 | ++ |
+ #'+ |
+
| 163 | ++ |
+ #' @export+ |
+
| 164 | ++ |
+ a_proportion_diff <- make_afun(+ |
+
| 165 | ++ |
+ s_proportion_diff,+ |
+
| 166 | ++ |
+ .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"),+ |
+
| 167 | ++ |
+ .indent_mods = c(diff = 0L, diff_ci = 1L)+ |
+
| 168 | ++ |
+ )+ |
+
| 169 | ++ | + + | +
| 170 | ++ |
+ #' @describeIn prop_diff Layout-creating function which can take statistics function arguments+ |
+
| 171 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 172 | ++ |
+ #'+ |
+
| 173 | ++ |
+ #' @param ... arguments passed to `s_proportion_diff()`.+ |
+
| 174 | ++ |
+ #'+ |
+
| 175 | ++ |
+ #' @return+ |
+
| 176 | ++ |
+ #' * `estimate_proportion_diff()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 177 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 178 | ++ |
+ #' the statistics from `s_proportion_diff()` to the table layout.+ |
+
| 179 | ++ |
+ #'+ |
+
| 180 | ++ |
+ #' @examples+ |
+
| 181 | ++ |
+ #' l <- basic_table() %>%+ |
+
| 182 | ++ |
+ #' split_cols_by(var = "grp", ref_group = "B") %>%+ |
+
| 183 | ++ |
+ #' estimate_proportion_diff(+ |
+
| 184 | ++ |
+ #' vars = "rsp",+ |
+
| 185 | ++ |
+ #' conf_level = 0.90,+ |
+
| 186 | ++ |
+ #' method = "ha"+ |
+
| 187 | ++ |
+ #' )+ |
+
| 188 | ++ |
+ #'+ |
+
| 189 | ++ |
+ #' build_table(l, df = dta)+ |
+
| 190 | ++ |
+ #'+ |
+
| 191 | ++ |
+ #' @export+ |
+
| 192 | ++ |
+ estimate_proportion_diff <- function(lyt,+ |
+
| 193 | ++ |
+ vars,+ |
+
| 194 | ++ |
+ na_str = NA_character_,+ |
+
| 195 | ++ |
+ nested = TRUE,+ |
+
| 196 | ++ |
+ ...,+ |
+
| 197 | ++ |
+ var_labels = vars,+ |
+
| 198 | ++ |
+ show_labels = "hidden",+ |
+
| 199 | ++ |
+ table_names = vars,+ |
+
| 200 | ++ |
+ .stats = NULL,+ |
+
| 201 | ++ |
+ .formats = NULL,+ |
+
| 202 | ++ |
+ .labels = NULL,+ |
+
| 203 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 204 | +3x | +
+ afun <- make_afun(+ |
+
| 205 | +3x | +
+ a_proportion_diff,+ |
+
| 206 | +3x | +
+ .stats = .stats,+ |
+
| 207 | +3x | +
+ .formats = .formats,+ |
+
| 208 | +3x | +
+ .labels = .labels,+ |
+
| 209 | +3x | +
+ .indent_mods = .indent_mods+ |
+
| 210 | ++ |
+ )+ |
+
| 211 | ++ | + + | +
| 212 | +3x | +
+ analyze(+ |
+
| 213 | +3x | +
+ lyt,+ |
+
| 214 | +3x | +
+ vars,+ |
+
| 215 | +3x | +
+ afun = afun,+ |
+
| 216 | +3x | +
+ var_labels = var_labels,+ |
+
| 217 | +3x | +
+ na_str = na_str,+ |
+
| 218 | +3x | +
+ nested = nested,+ |
+
| 219 | +3x | +
+ extra_args = list(...),+ |
+
| 220 | +3x | +
+ show_labels = show_labels,+ |
+
| 221 | +3x | +
+ table_names = table_names+ |
+
| 222 | ++ |
+ )+ |
+
| 223 | ++ |
+ }+ |
+
| 224 | ++ | + + | +
| 225 | ++ |
+ #' Check: Proportion Difference Arguments+ |
+
| 226 | ++ |
+ #'+ |
+
| 227 | ++ |
+ #' Verifies that and/or convert arguments into valid values to be used in the+ |
+
| 228 | ++ |
+ #' estimation of difference in responder proportions.+ |
+
| 229 | ++ |
+ #'+ |
+
| 230 | ++ |
+ #' @inheritParams prop_diff+ |
+
| 231 | ++ |
+ #' @inheritParams prop_diff_wald+ |
+
| 232 | ++ |
+ #'+ |
+
| 233 | ++ |
+ #' @keywords internal+ |
+
| 234 | ++ |
+ check_diff_prop_ci <- function(rsp,+ |
+
| 235 | ++ |
+ grp,+ |
+
| 236 | ++ |
+ strata = NULL,+ |
+
| 237 | ++ |
+ conf_level,+ |
+
| 238 | ++ |
+ correct = NULL) {
+ |
+
| 239 | +17x | +
+ checkmate::assert_logical(rsp, any.missing = FALSE)+ |
+
| 240 | +17x | +
+ checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2)+ |
+
| 241 | +17x | +
+ checkmate::assert_number(conf_level, lower = 0, upper = 1)+ |
+
| 242 | +17x | +
+ checkmate::assert_flag(correct, null.ok = TRUE)+ |
+
| 243 | ++ | + + | +
| 244 | +17x | +
+ if (!is.null(strata)) {
+ |
+
| 245 | +11x | +
+ checkmate::assert_factor(strata, len = length(rsp))+ |
+
| 246 | ++ |
+ }+ |
+
| 247 | ++ | + + | +
| 248 | +17x | +
+ invisible()+ |
+
| 249 | ++ |
+ }+ |
+
| 250 | ++ | + + | +
| 251 | ++ |
+ #' Description of Method Used for Proportion Comparison+ |
+
| 252 | ++ |
+ #'+ |
+
| 253 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 254 | ++ |
+ #'+ |
+
| 255 | ++ |
+ #' This is an auxiliary function that describes the analysis in+ |
+
| 256 | ++ |
+ #' `s_proportion_diff`.+ |
+
| 257 | ++ |
+ #'+ |
+
| 258 | ++ |
+ #' @inheritParams s_proportion_diff+ |
+
| 259 | ++ |
+ #' @param long (`logical`)\cr Whether a long or a short (default) description is required.+ |
+
| 260 | ++ |
+ #'+ |
+
| 261 | ++ |
+ #' @return A `string` describing the analysis.+ |
+
| 262 | ++ |
+ #'+ |
+
| 263 | ++ |
+ #' @seealso [prop_diff]+ |
+
| 264 | ++ |
+ #'+ |
+
| 265 | ++ |
+ #' @export+ |
+
| 266 | ++ |
+ d_proportion_diff <- function(conf_level,+ |
+
| 267 | ++ |
+ method,+ |
+
| 268 | ++ |
+ long = FALSE) {
+ |
+
| 269 | +8x | +
+ label <- paste0(conf_level * 100, "% CI")+ |
+
| 270 | +8x | +
+ if (long) {
+ |
+
| 271 | +! | +
+ label <- paste(+ |
+
| 272 | +! | +
+ label,+ |
+
| 273 | +! | +
+ ifelse(+ |
+
| 274 | +! | +
+ method == "cmh",+ |
+
| 275 | +! | +
+ "for adjusted difference",+ |
+
| 276 | +! | +
+ "for difference"+ |
+
| 277 | ++ |
+ )+ |
+
| 278 | ++ |
+ )+ |
+
| 279 | ++ |
+ }+ |
+
| 280 | ++ | + + | +
| 281 | +8x | +
+ method_part <- switch(method,+ |
+
| 282 | +8x | +
+ "cmh" = "CMH, without correction",+ |
+
| 283 | +8x | +
+ "waldcc" = "Wald, with correction",+ |
+
| 284 | +8x | +
+ "wald" = "Wald, without correction",+ |
+
| 285 | +8x | +
+ "ha" = "Anderson-Hauck",+ |
+
| 286 | +8x | +
+ "newcombe" = "Newcombe, without correction",+ |
+
| 287 | +8x | +
+ "newcombecc" = "Newcombe, with correction",+ |
+
| 288 | +8x | +
+ "strat_newcombe" = "Stratified Newcombe, without correction",+ |
+
| 289 | +8x | +
+ "strat_newcombecc" = "Stratified Newcombe, with correction",+ |
+
| 290 | +8x | +
+ stop(paste(method, "does not have a description"))+ |
+
| 291 | ++ |
+ )+ |
+
| 292 | +8x | +
+ paste0(label, " (", method_part, ")")
+ |
+
| 293 | ++ |
+ }+ |
+
| 294 | ++ | + + | +
| 295 | ++ |
+ #' Helper Functions to Calculate Proportion Difference+ |
+
| 296 | ++ |
+ #'+ |
+
| 297 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 298 | ++ |
+ #'+ |
+
| 299 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 300 | ++ |
+ #' @inheritParams prop_diff+ |
+
| 301 | ++ |
+ #' @param grp (`factor`)\cr vector assigning observations to one out of two groups+ |
+
| 302 | ++ |
+ #' (e.g. reference and treatment group).+ |
+
| 303 | ++ |
+ #'+ |
+
| 304 | ++ |
+ #' @return A named `list` of elements `diff` (proportion difference) and `diff_ci`+ |
+
| 305 | ++ |
+ #' (proportion difference confidence interval).+ |
+
| 306 | ++ |
+ #'+ |
+
| 307 | ++ |
+ #' @seealso [prop_diff()] for implementation of these helper functions.+ |
+
| 308 | ++ |
+ #'+ |
+
| 309 | ++ |
+ #' @name h_prop_diff+ |
+
| 310 | ++ |
+ NULL+ |
+
| 311 | ++ | + + | +
| 312 | ++ |
+ #' @describeIn h_prop_diff The Wald interval follows the usual textbook+ |
+
| 313 | ++ |
+ #' definition for a single proportion confidence interval using the normal+ |
+
| 314 | ++ |
+ #' approximation. It is possible to include a continuity correction for Wald's+ |
+
| 315 | ++ |
+ #' interval.+ |
+
| 316 | ++ |
+ #'+ |
+
| 317 | ++ |
+ #' @param correct (`logical`)\cr whether to include the continuity correction. For further+ |
+
| 318 | ++ |
+ #' information, see [stats::prop.test()].+ |
+
| 319 | ++ |
+ #'+ |
+
| 320 | ++ |
+ #' @examples+ |
+
| 321 | ++ |
+ #' # Wald confidence interval+ |
+
| 322 | ++ |
+ #' set.seed(2)+ |
+
| 323 | ++ |
+ #' rsp <- sample(c(TRUE, FALSE), replace = TRUE, size = 20)+ |
+
| 324 | ++ |
+ #' grp <- factor(c(rep("A", 10), rep("B", 10)))
+ |
+
| 325 | ++ |
+ #' prop_diff_wald(rsp = rsp, grp = grp, conf_level = 0.95, correct = FALSE)+ |
+
| 326 | ++ |
+ #'+ |
+
| 327 | ++ |
+ #' @export+ |
+
| 328 | ++ |
+ prop_diff_wald <- function(rsp,+ |
+
| 329 | ++ |
+ grp,+ |
+
| 330 | ++ |
+ conf_level = 0.95,+ |
+
| 331 | ++ |
+ correct = FALSE) {
+ |
+
| 332 | +2x | +
+ if (isTRUE(correct)) {
+ |
+
| 333 | +1x | +
+ mthd <- "waldcc"+ |
+
| 334 | ++ |
+ } else {
+ |
+
| 335 | +1x | +
+ mthd <- "wald"+ |
+
| 336 | ++ |
+ }+ |
+
| 337 | +2x | +
+ grp <- as_factor_keep_attributes(grp)+ |
+
| 338 | +2x | +
+ check_diff_prop_ci(+ |
+
| 339 | +2x | +
+ rsp = rsp, grp = grp, conf_level = conf_level, correct = correct+ |
+
| 340 | ++ |
+ )+ |
+
| 341 | ++ | + + | +
| 342 | ++ |
+ # check if binary response is coded as logical+ |
+
| 343 | +2x | +
+ checkmate::assert_logical(rsp, any.missing = FALSE)+ |
+
| 344 | +2x | +
+ checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2)+ |
+
| 345 | ++ | + + | +
| 346 | +2x | +
+ tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ |
+
| 347 | ++ |
+ # x1 and n1 are non-reference groups.+ |
+
| 348 | +2x | +
+ diff_ci <- desctools_binom(+ |
+
| 349 | +2x | +
+ x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ |
+
| 350 | +2x | +
+ x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ |
+
| 351 | +2x | +
+ conf.level = conf_level,+ |
+
| 352 | +2x | +
+ method = mthd+ |
+
| 353 | ++ |
+ )+ |
+
| 354 | ++ | + + | +
| 355 | +2x | +
+ list(+ |
+
| 356 | +2x | +
+ "diff" = unname(diff_ci[, "est"]),+ |
+
| 357 | +2x | +
+ "diff_ci" = unname(diff_ci[, c("lwr.ci", "upr.ci")])
+ |
+
| 358 | ++ |
+ )+ |
+
| 359 | ++ |
+ }+ |
+
| 360 | ++ | + + | +
| 361 | ++ |
+ #' @describeIn h_prop_diff Anderson-Hauck confidence interval.+ |
+
| 362 | ++ |
+ #'+ |
+
| 363 | ++ |
+ #' @examples+ |
+
| 364 | ++ |
+ #' # Anderson-Hauck confidence interval+ |
+
| 365 | ++ |
+ #' ## "Mid" case: 3/4 respond in group A, 1/2 respond in group B.+ |
+
| 366 | ++ |
+ #' rsp <- c(TRUE, FALSE, FALSE, TRUE, TRUE, TRUE)+ |
+
| 367 | ++ |
+ #' grp <- factor(c("A", "B", "A", "B", "A", "A"), levels = c("B", "A"))
+ |
+
| 368 | ++ |
+ #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.90)+ |
+
| 369 | ++ |
+ #'+ |
+
| 370 | ++ |
+ #' ## Edge case: Same proportion of response in A and B.+ |
+
| 371 | ++ |
+ #' rsp <- c(TRUE, FALSE, TRUE, FALSE)+ |
+
| 372 | ++ |
+ #' grp <- factor(c("A", "A", "B", "B"), levels = c("A", "B"))
+ |
+
| 373 | ++ |
+ #' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.6)+ |
+
| 374 | ++ |
+ #'+ |
+
| 375 | ++ |
+ #' @export+ |
+
| 376 | ++ |
+ prop_diff_ha <- function(rsp,+ |
+
| 377 | ++ |
+ grp,+ |
+
| 378 | ++ |
+ conf_level) {
+ |
+
| 379 | +3x | +
+ grp <- as_factor_keep_attributes(grp)+ |
+
| 380 | +3x | +
+ check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level)+ |
+
| 381 | ++ | + + | +
| 382 | +3x | +
+ tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ |
+
| 383 | ++ |
+ # x1 and n1 are non-reference groups.+ |
+
| 384 | +3x | +
+ ci <- desctools_binom(+ |
+
| 385 | +3x | +
+ x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ |
+
| 386 | +3x | +
+ x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ |
+
| 387 | +3x | +
+ conf.level = conf_level,+ |
+
| 388 | +3x | +
+ method = "ha"+ |
+
| 389 | ++ |
+ )+ |
+
| 390 | +3x | +
+ list(+ |
+
| 391 | +3x | +
+ "diff" = unname(ci[, "est"]),+ |
+
| 392 | +3x | +
+ "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
+ |
+
| 393 | ++ |
+ )+ |
+
| 394 | ++ |
+ }+ |
+
| 395 | ++ | + + | +
| 396 | ++ |
+ #' @describeIn h_prop_diff `Newcombe` confidence interval. It is based on+ |
+
| 397 | ++ |
+ #' the Wilson score confidence interval for a single binomial proportion.+ |
+
| 398 | ++ |
+ #'+ |
+
| 399 | ++ |
+ #' @examples+ |
+
| 400 | ++ |
+ #' # `Newcombe` confidence interval+ |
+
| 401 | ++ |
+ #'+ |
+
| 402 | ++ |
+ #' set.seed(1)+ |
+
| 403 | ++ |
+ #' rsp <- c(+ |
+
| 404 | ++ |
+ #' sample(c(TRUE, FALSE), size = 40, prob = c(3 / 4, 1 / 4), replace = TRUE),+ |
+
| 405 | ++ |
+ #' sample(c(TRUE, FALSE), size = 40, prob = c(1 / 2, 1 / 2), replace = TRUE)+ |
+
| 406 | ++ |
+ #' )+ |
+
| 407 | ++ |
+ #' grp <- factor(rep(c("A", "B"), each = 40), levels = c("B", "A"))
+ |
+
| 408 | ++ |
+ #' table(rsp, grp)+ |
+
| 409 | ++ |
+ #' prop_diff_nc(rsp = rsp, grp = grp, conf_level = 0.9)+ |
+
| 410 | ++ |
+ #'+ |
+
| 411 | ++ |
+ #' @export+ |
+
| 412 | ++ |
+ prop_diff_nc <- function(rsp,+ |
+
| 413 | ++ |
+ grp,+ |
+
| 414 | ++ |
+ conf_level,+ |
+
| 415 | ++ |
+ correct = FALSE) {
+ |
+
| 416 | +1x | +
+ if (isTRUE(correct)) {
+ |
+
| 417 | +! | +
+ mthd <- "scorecc"+ |
+
| 418 | ++ |
+ } else {
+ |
+
| 419 | +1x | +
+ mthd <- "score"+ |
+
| 420 | ++ |
+ }+ |
+
| 421 | +1x | +
+ grp <- as_factor_keep_attributes(grp)+ |
+
| 422 | +1x | +
+ check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level)+ |
+
| 423 | ++ | + + | +
| 424 | +1x | +
+ p_grp <- tapply(rsp, grp, mean)+ |
+
| 425 | +1x | +
+ diff_p <- unname(diff(p_grp))+ |
+
| 426 | +1x | +
+ tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))+ |
+
| 427 | +1x | +
+ ci <- desctools_binom(+ |
+
| 428 | ++ |
+ # x1 and n1 are non-reference groups.+ |
+
| 429 | +1x | +
+ x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),+ |
+
| 430 | +1x | +
+ x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),+ |
+
| 431 | +1x | +
+ conf.level = conf_level,+ |
+
| 432 | +1x | +
+ method = mthd+ |
+
| 433 | ++ |
+ )+ |
+
| 434 | +1x | +
+ list(+ |
+
| 435 | +1x | +
+ "diff" = unname(ci[, "est"]),+ |
+
| 436 | +1x | +
+ "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
+ |
+
| 437 | ++ |
+ )+ |
+
| 438 | ++ |
+ }+ |
+
| 439 | ++ | + + | +
| 440 | ++ |
+ #' @describeIn h_prop_diff Calculates the weighted difference. This is defined as the difference in+ |
+
| 441 | ++ |
+ #' response rates between the experimental treatment group and the control treatment group, adjusted+ |
+
| 442 | ++ |
+ #' for stratification factors by applying `Cochran-Mantel-Haenszel` (`CMH`) weights. For the `CMH` chi-squared+ |
+
| 443 | ++ |
+ #' test, use [stats::mantelhaen.test()].+ |
+
| 444 | ++ |
+ #'+ |
+
| 445 | ++ |
+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ |
+
| 446 | ++ |
+ #'+ |
+
| 447 | ++ |
+ #' @examples+ |
+
| 448 | ++ |
+ #' # Cochran-Mantel-Haenszel confidence interval+ |
+
| 449 | ++ |
+ #'+ |
+
| 450 | ++ |
+ #' set.seed(2)+ |
+
| 451 | ++ |
+ #' rsp <- sample(c(TRUE, FALSE), 100, TRUE)+ |
+
| 452 | ++ |
+ #' grp <- sample(c("Placebo", "Treatment"), 100, TRUE)
+ |
+
| 453 | ++ |
+ #' grp <- factor(grp, levels = c("Placebo", "Treatment"))
+ |
+
| 454 | ++ |
+ #' strata_data <- data.frame(+ |
+
| 455 | ++ |
+ #' "f1" = sample(c("a", "b"), 100, TRUE),
+ |
+
| 456 | ++ |
+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ |
+
| 457 | ++ |
+ #' stringsAsFactors = TRUE+ |
+
| 458 | ++ |
+ #' )+ |
+
| 459 | ++ |
+ #'+ |
+
| 460 | ++ |
+ #' prop_diff_cmh(+ |
+
| 461 | ++ |
+ #' rsp = rsp, grp = grp, strata = interaction(strata_data),+ |
+
| 462 | ++ |
+ #' conf_level = 0.90+ |
+
| 463 | ++ |
+ #' )+ |
+
| 464 | ++ |
+ #'+ |
+
| 465 | ++ |
+ #' @export+ |
+
| 466 | ++ |
+ prop_diff_cmh <- function(rsp,+ |
+
| 467 | ++ |
+ grp,+ |
+
| 468 | ++ |
+ strata,+ |
+
| 469 | ++ |
+ conf_level = 0.95) {
+ |
+
| 470 | +7x | +
+ grp <- as_factor_keep_attributes(grp)+ |
+
| 471 | +7x | +
+ strata <- as_factor_keep_attributes(strata)+ |
+
| 472 | +7x | +
+ check_diff_prop_ci(+ |
+
| 473 | +7x | +
+ rsp = rsp, grp = grp, conf_level = conf_level, strata = strata+ |
+
| 474 | ++ |
+ )+ |
+
| 475 | ++ | + + | +
| 476 | +7x | +
+ if (any(tapply(rsp, strata, length) < 5)) {
+ |
+
| 477 | +! | +
+ warning("Less than 5 observations in some strata.")
+ |
+
| 478 | ++ |
+ }+ |
+
| 479 | ++ | + + | +
| 480 | ++ |
+ # first dimension: FALSE, TRUE+ |
+
| 481 | ++ |
+ # 2nd dimension: CONTROL, TX+ |
+
| 482 | ++ |
+ # 3rd dimension: levels of strat+ |
+
| 483 | ++ |
+ # rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records+ |
+
| 484 | +7x | +
+ t_tbl <- table(+ |
+
| 485 | +7x | +
+ factor(rsp, levels = c("FALSE", "TRUE")),
+ |
+
| 486 | +7x | +
+ grp,+ |
+
| 487 | +7x | +
+ strata+ |
+
| 488 | ++ |
+ )+ |
+
| 489 | +7x | +
+ n1 <- colSums(t_tbl[1:2, 1, ])+ |
+
| 490 | +7x | +
+ n2 <- colSums(t_tbl[1:2, 2, ])+ |
+
| 491 | +7x | +
+ p1 <- t_tbl[2, 1, ] / n1+ |
+
| 492 | +7x | +
+ p2 <- t_tbl[2, 2, ] / n2+ |
+
| 493 | ++ |
+ # CMH weights+ |
+
| 494 | +7x | +
+ use_stratum <- (n1 > 0) & (n2 > 0)+ |
+
| 495 | +7x | +
+ n1 <- n1[use_stratum]+ |
+
| 496 | +7x | +
+ n2 <- n2[use_stratum]+ |
+
| 497 | +7x | +
+ p1 <- p1[use_stratum]+ |
+
| 498 | +7x | +
+ p2 <- p2[use_stratum]+ |
+
| 499 | +7x | +
+ wt <- (n1 * n2 / (n1 + n2))+ |
+
| 500 | +7x | +
+ wt_normalized <- wt / sum(wt)+ |
+
| 501 | +7x | +
+ est1 <- sum(wt_normalized * p1)+ |
+
| 502 | +7x | +
+ est2 <- sum(wt_normalized * p2)+ |
+
| 503 | +7x | +
+ estimate <- c(est1, est2)+ |
+
| 504 | +7x | +
+ names(estimate) <- levels(grp)+ |
+
| 505 | +7x | +
+ se1 <- sqrt(sum(wt_normalized^2 * p1 * (1 - p1) / n1))+ |
+
| 506 | +7x | +
+ se2 <- sqrt(sum(wt_normalized^2 * p2 * (1 - p2) / n2))+ |
+
| 507 | +7x | +
+ z <- stats::qnorm((1 + conf_level) / 2)+ |
+
| 508 | +7x | +
+ err1 <- z * se1+ |
+
| 509 | +7x | +
+ err2 <- z * se2+ |
+
| 510 | +7x | +
+ ci1 <- c((est1 - err1), (est1 + err1))+ |
+
| 511 | +7x | +
+ ci2 <- c((est2 - err2), (est2 + err2))+ |
+
| 512 | +7x | +
+ estimate_ci <- list(ci1, ci2)+ |
+
| 513 | +7x | +
+ names(estimate_ci) <- levels(grp)+ |
+
| 514 | +7x | +
+ diff_est <- est2 - est1+ |
+
| 515 | +7x | +
+ se_diff <- sqrt(sum(((p1 * (1 - p1) / n1) + (p2 * (1 - p2) / n2)) * wt_normalized^2))+ |
+
| 516 | +7x | +
+ diff_ci <- c(diff_est - z * se_diff, diff_est + z * se_diff)+ |
+
| 517 | ++ | + + | +
| 518 | +7x | +
+ list(+ |
+
| 519 | +7x | +
+ prop = estimate,+ |
+
| 520 | +7x | +
+ prop_ci = estimate_ci,+ |
+
| 521 | +7x | +
+ diff = diff_est,+ |
+
| 522 | +7x | +
+ diff_ci = diff_ci,+ |
+
| 523 | +7x | +
+ weights = wt_normalized,+ |
+
| 524 | +7x | +
+ n1 = n1,+ |
+
| 525 | +7x | +
+ n2 = n2+ |
+
| 526 | ++ |
+ )+ |
+
| 527 | ++ |
+ }+ |
+
| 528 | ++ | + + | +
| 529 | ++ |
+ #' @describeIn h_prop_diff Calculates the stratified `Newcombe` confidence interval and difference in response+ |
+
| 530 | ++ |
+ #' rates between the experimental treatment group and the control treatment group, adjusted for stratification+ |
+
| 531 | ++ |
+ #' factors. This implementation follows closely the one proposed by \insertCite{Yan2010-jt;textual}{tern}.
+ |
+
| 532 | ++ |
+ #' Weights can be estimated from the heuristic proposed in [prop_strat_wilson()] or from `CMH`-derived weights+ |
+
| 533 | ++ |
+ #' (see [prop_diff_cmh()]).+ |
+
| 534 | ++ |
+ #'+ |
+
| 535 | ++ |
+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ |
+
| 536 | ++ |
+ #' @param weights_method (`string`)\cr weights method. Can be either `"cmh"` or `"heuristic"`+ |
+
| 537 | ++ |
+ #' and directs the way weights are estimated.+ |
+
| 538 | ++ |
+ #'+ |
+
| 539 | ++ |
+ #' @references+ |
+
| 540 | ++ |
+ #' \insertRef{Yan2010-jt}{tern}
+ |
+
| 541 | ++ |
+ #'+ |
+
| 542 | ++ |
+ #' @examples+ |
+
| 543 | ++ |
+ #' # Stratified `Newcombe` confidence interval+ |
+
| 544 | ++ |
+ #'+ |
+
| 545 | ++ |
+ #' set.seed(2)+ |
+
| 546 | ++ |
+ #' data_set <- data.frame(+ |
+
| 547 | ++ |
+ #' "rsp" = sample(c(TRUE, FALSE), 100, TRUE),+ |
+
| 548 | ++ |
+ #' "f1" = sample(c("a", "b"), 100, TRUE),
+ |
+
| 549 | ++ |
+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ |
+
| 550 | ++ |
+ #' "grp" = sample(c("Placebo", "Treatment"), 100, TRUE),
+ |
+
| 551 | ++ |
+ #' stringsAsFactors = TRUE+ |
+
| 552 | ++ |
+ #' )+ |
+
| 553 | ++ |
+ #'+ |
+
| 554 | ++ |
+ #' prop_diff_strat_nc(+ |
+
| 555 | ++ |
+ #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]),+ |
+
| 556 | ++ |
+ #' weights_method = "cmh",+ |
+
| 557 | ++ |
+ #' conf_level = 0.90+ |
+
| 558 | ++ |
+ #' )+ |
+
| 559 | ++ |
+ #'+ |
+
| 560 | ++ |
+ #' prop_diff_strat_nc(+ |
+
| 561 | ++ |
+ #' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]),+ |
+
| 562 | ++ |
+ #' weights_method = "wilson_h",+ |
+
| 563 | ++ |
+ #' conf_level = 0.90+ |
+
| 564 | ++ |
+ #' )+ |
+
| 565 | ++ |
+ #'+ |
+
| 566 | ++ |
+ #' @export+ |
+
| 567 | ++ |
+ prop_diff_strat_nc <- function(rsp,+ |
+
| 568 | ++ |
+ grp,+ |
+
| 569 | ++ |
+ strata,+ |
+
| 570 | ++ |
+ weights_method = c("cmh", "wilson_h"),
+ |
+
| 571 | ++ |
+ conf_level = 0.95,+ |
+
| 572 | ++ |
+ correct = FALSE) {
+ |
+
| 573 | +4x | +
+ weights_method <- match.arg(weights_method)+ |
+
| 574 | +4x | +
+ grp <- as_factor_keep_attributes(grp)+ |
+
| 575 | +4x | +
+ strata <- as_factor_keep_attributes(strata)+ |
+
| 576 | +4x | +
+ check_diff_prop_ci(+ |
+
| 577 | +4x | +
+ rsp = rsp, grp = grp, conf_level = conf_level, strata = strata+ |
+
| 578 | ++ |
+ )+ |
+
| 579 | +4x | +
+ checkmate::assert_number(conf_level, lower = 0, upper = 1)+ |
+
| 580 | +4x | +
+ checkmate::assert_flag(correct)+ |
+
| 581 | +4x | +
+ if (any(tapply(rsp, strata, length) < 5)) {
+ |
+
| 582 | +! | +
+ warning("Less than 5 observations in some strata.")
+ |
+
| 583 | ++ |
+ }+ |
+
| 584 | ++ | + + | +
| 585 | +4x | +
+ rsp_by_grp <- split(rsp, f = grp)+ |
+
| 586 | +4x | +
+ strata_by_grp <- split(strata, f = grp)+ |
+
| 587 | ++ | + + | +
| 588 | ++ |
+ # Finding the weights+ |
+
| 589 | +4x | +
+ weights <- if (identical(weights_method, "cmh")) {
+ |
+
| 590 | +3x | +
+ prop_diff_cmh(rsp = rsp, grp = grp, strata = strata)$weights+ |
+
| 591 | +4x | +
+ } else if (identical(weights_method, "wilson_h")) {
+ |
+
| 592 | +1x | +
+ prop_strat_wilson(rsp, strata, conf_level = conf_level, correct = correct)$weights+ |
+
| 593 | ++ |
+ }+ |
+
| 594 | +4x | +
+ weights[levels(strata)[!levels(strata) %in% names(weights)]] <- 0+ |
+
| 595 | ++ | + + | +
| 596 | ++ |
+ # Calculating lower (`l`) and upper (`u`) confidence bounds per group.+ |
+
| 597 | +4x | +
+ strat_wilson_by_grp <- Map(+ |
+
| 598 | +4x | +
+ prop_strat_wilson,+ |
+
| 599 | +4x | +
+ rsp = rsp_by_grp,+ |
+
| 600 | +4x | +
+ strata = strata_by_grp,+ |
+
| 601 | +4x | +
+ weights = list(weights, weights),+ |
+
| 602 | +4x | +
+ conf_level = conf_level,+ |
+
| 603 | +4x | +
+ correct = correct+ |
+
| 604 | ++ |
+ )+ |
+
| 605 | ++ | + + | +
| 606 | +4x | +
+ ci_ref <- strat_wilson_by_grp[[1]]+ |
+
| 607 | +4x | +
+ ci_trt <- strat_wilson_by_grp[[2]]+ |
+
| 608 | +4x | +
+ l_ref <- as.numeric(ci_ref$conf_int[1])+ |
+
| 609 | +4x | +
+ u_ref <- as.numeric(ci_ref$conf_int[2])+ |
+
| 610 | +4x | +
+ l_trt <- as.numeric(ci_trt$conf_int[1])+ |
+
| 611 | +4x | +
+ u_trt <- as.numeric(ci_trt$conf_int[2])+ |
+
| 612 | ++ | + + | +
| 613 | ++ |
+ # Estimating the diff and n_ref, n_trt (it allows different weights to be used)+ |
+
| 614 | +4x | +
+ t_tbl <- table(+ |
+
| 615 | +4x | +
+ factor(rsp, levels = c("FALSE", "TRUE")),
+ |
+
| 616 | +4x | +
+ grp,+ |
+
| 617 | +4x | +
+ strata+ |
+
| 618 | ++ |
+ )+ |
+
| 619 | +4x | +
+ n_ref <- colSums(t_tbl[1:2, 1, ])+ |
+
| 620 | +4x | +
+ n_trt <- colSums(t_tbl[1:2, 2, ])+ |
+
| 621 | +4x | +
+ use_stratum <- (n_ref > 0) & (n_trt > 0)+ |
+
| 622 | +4x | +
+ n_ref <- n_ref[use_stratum]+ |
+
| 623 | +4x | +
+ n_trt <- n_trt[use_stratum]+ |
+
| 624 | +4x | +
+ p_ref <- t_tbl[2, 1, use_stratum] / n_ref+ |
+
| 625 | +4x | +
+ p_trt <- t_tbl[2, 2, use_stratum] / n_trt+ |
+
| 626 | +4x | +
+ est1 <- sum(weights * p_ref)+ |
+
| 627 | +4x | +
+ est2 <- sum(weights * p_trt)+ |
+
| 628 | +4x | +
+ diff_est <- est2 - est1+ |
+
| 629 | ++ | + + | +
| 630 | +4x | +
+ lambda1 <- sum(weights^2 / n_ref)+ |
+
| 631 | +4x | +
+ lambda2 <- sum(weights^2 / n_trt)+ |
+
| 632 | +4x | +
+ z <- stats::qnorm((1 + conf_level) / 2)+ |
+
| 633 | ++ | + + | +
| 634 | +4x | +
+ lower <- diff_est - z * sqrt(lambda2 * l_trt * (1 - l_trt) + lambda1 * u_ref * (1 - u_ref))+ |
+
| 635 | +4x | +
+ upper <- diff_est + z * sqrt(lambda1 * l_ref * (1 - l_ref) + lambda2 * u_trt * (1 - u_trt))+ |
+
| 636 | ++ | + + | +
| 637 | +4x | +
+ list(+ |
+
| 638 | +4x | +
+ "diff" = diff_est,+ |
+
| 639 | +4x | +
+ "diff_ci" = c("lower" = lower, "upper" = upper)
+ |
+
| 640 | ++ |
+ )+ |
+
| 641 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Helper Functions for Tabulating Survival Duration by Subgroup+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Helper functions that tabulate in a data frame statistics such as median survival+ |
+
| 6 | ++ |
+ #' time and hazard ratio for population subgroups.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #' @inheritParams survival_coxph_pairwise+ |
+
| 10 | ++ |
+ #' @inheritParams survival_duration_subgroups+ |
+
| 11 | ++ |
+ #' @param arm (`factor`)\cr the treatment group variable.+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' @details Main functionality is to prepare data for use in a layout-creating function.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @examples+ |
+
| 16 | ++ |
+ #' library(dplyr)+ |
+
| 17 | ++ |
+ #' library(forcats)+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' adtte <- tern_ex_adtte+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' # Save variable labels before data processing steps.+ |
+
| 22 | ++ |
+ #' adtte_labels <- formatters::var_labels(adtte)+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' adtte_f <- adtte %>%+ |
+
| 25 | ++ |
+ #' filter(+ |
+
| 26 | ++ |
+ #' PARAMCD == "OS",+ |
+
| 27 | ++ |
+ #' ARM %in% c("B: Placebo", "A: Drug X"),
+ |
+
| 28 | ++ |
+ #' SEX %in% c("M", "F")
+ |
+
| 29 | ++ |
+ #' ) %>%+ |
+
| 30 | ++ |
+ #' mutate(+ |
+
| 31 | ++ |
+ #' # Reorder levels of ARM to display reference arm before treatment arm.+ |
+
| 32 | ++ |
+ #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),+ |
+
| 33 | ++ |
+ #' SEX = droplevels(SEX),+ |
+
| 34 | ++ |
+ #' is_event = CNSR == 0+ |
+
| 35 | ++ |
+ #' )+ |
+
| 36 | ++ |
+ #' labels <- c("ARM" = adtte_labels[["ARM"]], "SEX" = adtte_labels[["SEX"]], "is_event" = "Event Flag")
+ |
+
| 37 | ++ |
+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' @name h_survival_duration_subgroups+ |
+
| 40 | ++ |
+ NULL+ |
+
| 41 | ++ | + + | +
| 42 | ++ |
+ #' @describeIn h_survival_duration_subgroups helper to prepare a data frame of median survival times by arm.+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' @return+ |
+
| 45 | ++ |
+ #' * `h_survtime_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, and `median`.+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ #' @examples+ |
+
| 48 | ++ |
+ #' # Extract median survival time for one group.+ |
+
| 49 | ++ |
+ #' h_survtime_df(+ |
+
| 50 | ++ |
+ #' tte = adtte_f$AVAL,+ |
+
| 51 | ++ |
+ #' is_event = adtte_f$is_event,+ |
+
| 52 | ++ |
+ #' arm = adtte_f$ARM+ |
+
| 53 | ++ |
+ #' )+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' @export+ |
+
| 56 | ++ |
+ h_survtime_df <- function(tte, is_event, arm) {
+ |
+
| 57 | +55x | +
+ checkmate::assert_numeric(tte)+ |
+
| 58 | +54x | +
+ checkmate::assert_logical(is_event, len = length(tte))+ |
+
| 59 | +54x | +
+ assert_valid_factor(arm, len = length(tte))+ |
+
| 60 | ++ | + + | +
| 61 | +54x | +
+ df_tte <- data.frame(+ |
+
| 62 | +54x | +
+ tte = tte,+ |
+
| 63 | +54x | +
+ is_event = is_event,+ |
+
| 64 | +54x | +
+ stringsAsFactors = FALSE+ |
+
| 65 | ++ |
+ )+ |
+
| 66 | ++ | + + | +
| 67 | ++ |
+ # Delete NAs+ |
+
| 68 | +54x | +
+ non_missing_rows <- stats::complete.cases(df_tte)+ |
+
| 69 | +54x | +
+ df_tte <- df_tte[non_missing_rows, ]+ |
+
| 70 | +54x | +
+ arm <- arm[non_missing_rows]+ |
+
| 71 | ++ | + + | +
| 72 | +54x | +
+ lst_tte <- split(df_tte, arm)+ |
+
| 73 | +54x | +
+ lst_results <- Map(function(x, arm) {
+ |
+
| 74 | +108x | +
+ if (nrow(x) > 0) {
+ |
+
| 75 | +104x | +
+ s_surv <- s_surv_time(x, .var = "tte", is_event = "is_event")+ |
+
| 76 | +104x | +
+ median_est <- unname(as.numeric(s_surv$median))+ |
+
| 77 | +104x | +
+ n_events <- sum(x$is_event)+ |
+
| 78 | ++ |
+ } else {
+ |
+
| 79 | +4x | +
+ median_est <- NA+ |
+
| 80 | +4x | +
+ n_events <- NA+ |
+
| 81 | ++ |
+ }+ |
+
| 82 | ++ | + + | +
| 83 | +108x | +
+ data.frame(+ |
+
| 84 | +108x | +
+ arm = arm,+ |
+
| 85 | +108x | +
+ n = nrow(x),+ |
+
| 86 | +108x | +
+ n_events = n_events,+ |
+
| 87 | +108x | +
+ median = median_est,+ |
+
| 88 | +108x | +
+ stringsAsFactors = FALSE+ |
+
| 89 | ++ |
+ )+ |
+
| 90 | +54x | +
+ }, lst_tte, names(lst_tte))+ |
+
| 91 | ++ | + + | +
| 92 | +54x | +
+ df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE))+ |
+
| 93 | +54x | +
+ df$arm <- factor(df$arm, levels = levels(arm))+ |
+
| 94 | +54x | +
+ df+ |
+
| 95 | ++ |
+ }+ |
+
| 96 | ++ | + + | +
| 97 | ++ |
+ #' @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 | ++ |
+ #' @return+ |
+
| 103 | ++ |
+ #' * `h_survtime_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_events`, `median`, `subgroup`,+ |
+
| 104 | ++ |
+ #' `var`, `var_label`, and `row_type`.+ |
+
| 105 | ++ |
+ #'+ |
+
| 106 | ++ |
+ #' @examples+ |
+
| 107 | ++ |
+ #' # Extract median survival time for multiple groups.+ |
+
| 108 | ++ |
+ #' h_survtime_subgroups_df(+ |
+
| 109 | ++ |
+ #' variables = list(+ |
+
| 110 | ++ |
+ #' tte = "AVAL",+ |
+
| 111 | ++ |
+ #' is_event = "is_event",+ |
+
| 112 | ++ |
+ #' arm = "ARM",+ |
+
| 113 | ++ |
+ #' subgroups = c("SEX", "BMRKR2")
+ |
+
| 114 | ++ |
+ #' ),+ |
+
| 115 | ++ |
+ #' data = adtte_f+ |
+
| 116 | ++ |
+ #' )+ |
+
| 117 | ++ |
+ #'+ |
+
| 118 | ++ |
+ #' # Define groupings for BMRKR2 levels.+ |
+
| 119 | ++ |
+ #' h_survtime_subgroups_df(+ |
+
| 120 | ++ |
+ #' variables = list(+ |
+
| 121 | ++ |
+ #' tte = "AVAL",+ |
+
| 122 | ++ |
+ #' is_event = "is_event",+ |
+
| 123 | ++ |
+ #' arm = "ARM",+ |
+
| 124 | ++ |
+ #' subgroups = c("SEX", "BMRKR2")
+ |
+
| 125 | ++ |
+ #' ),+ |
+
| 126 | ++ |
+ #' data = adtte_f,+ |
+
| 127 | ++ |
+ #' groups_lists = list(+ |
+
| 128 | ++ |
+ #' BMRKR2 = list(+ |
+
| 129 | ++ |
+ #' "low" = "LOW",+ |
+
| 130 | ++ |
+ #' "low/medium" = c("LOW", "MEDIUM"),
+ |
+
| 131 | ++ |
+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ |
+
| 132 | ++ |
+ #' )+ |
+
| 133 | ++ |
+ #' )+ |
+
| 134 | ++ |
+ #' )+ |
+
| 135 | ++ |
+ #'+ |
+
| 136 | ++ |
+ #' @export+ |
+
| 137 | ++ |
+ h_survtime_subgroups_df <- function(variables,+ |
+
| 138 | ++ |
+ data,+ |
+
| 139 | ++ |
+ groups_lists = list(),+ |
+
| 140 | ++ |
+ label_all = "All Patients") {
+ |
+
| 141 | +11x | +
+ checkmate::assert_character(variables$tte)+ |
+
| 142 | +11x | +
+ checkmate::assert_character(variables$is_event)+ |
+
| 143 | +11x | +
+ checkmate::assert_character(variables$arm)+ |
+
| 144 | +11x | +
+ checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ |
+
| 145 | ++ | + + | +
| 146 | +11x | +
+ assert_df_with_variables(data, variables)+ |
+
| 147 | ++ | + + | +
| 148 | +11x | +
+ checkmate::assert_string(label_all)+ |
+
| 149 | ++ | + + | +
| 150 | ++ |
+ # Add All Patients.+ |
+
| 151 | +11x | +
+ result_all <- h_survtime_df(data[[variables$tte]], data[[variables$is_event]], data[[variables$arm]])+ |
+
| 152 | +11x | +
+ result_all$subgroup <- label_all+ |
+
| 153 | +11x | +
+ result_all$var <- "ALL"+ |
+
| 154 | +11x | +
+ result_all$var_label <- label_all+ |
+
| 155 | +11x | +
+ result_all$row_type <- "content"+ |
+
| 156 | ++ | + + | +
| 157 | ++ |
+ # Add Subgroups.+ |
+
| 158 | +11x | +
+ if (is.null(variables$subgroups)) {
+ |
+
| 159 | +3x | +
+ result_all+ |
+
| 160 | ++ |
+ } else {
+ |
+
| 161 | +8x | +
+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ |
+
| 162 | +8x | +
+ l_result <- lapply(l_data, function(grp) {
+ |
+
| 163 | +40x | +
+ result <- h_survtime_df(grp$df[[variables$tte]], grp$df[[variables$is_event]], grp$df[[variables$arm]])+ |
+
| 164 | +40x | +
+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ |
+
| 165 | +40x | +
+ cbind(result, result_labels)+ |
+
| 166 | ++ |
+ })+ |
+
| 167 | +8x | +
+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ |
+
| 168 | +8x | +
+ result_subgroups$row_type <- "analysis"+ |
+
| 169 | +8x | +
+ rbind(+ |
+
| 170 | +8x | +
+ result_all,+ |
+
| 171 | +8x | +
+ result_subgroups+ |
+
| 172 | ++ |
+ )+ |
+
| 173 | ++ |
+ }+ |
+
| 174 | ++ |
+ }+ |
+
| 175 | ++ | + + | +
| 176 | ++ |
+ #' @describeIn h_survival_duration_subgroups helper to prepare a data frame with estimates of+ |
+
| 177 | ++ |
+ #' treatment hazard ratio.+ |
+
| 178 | ++ |
+ #'+ |
+
| 179 | ++ |
+ #' @param strata_data (`factor`, `data.frame` or `NULL`)\cr required if stratified analysis is performed.+ |
+
| 180 | ++ |
+ #'+ |
+
| 181 | ++ |
+ #' @return+ |
+
| 182 | ++ |
+ #' * `h_coxph_df()` returns a `data.frame` with columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`,+ |
+
| 183 | ++ |
+ #' `conf_level`, `pval` and `pval_label`.+ |
+
| 184 | ++ |
+ #'+ |
+
| 185 | ++ |
+ #' @examples+ |
+
| 186 | ++ |
+ #' # Extract hazard ratio for one group.+ |
+
| 187 | ++ |
+ #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM)+ |
+
| 188 | ++ |
+ #'+ |
+
| 189 | ++ |
+ #' # Extract hazard ratio for one group with stratification factor.+ |
+
| 190 | ++ |
+ #' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM, strata_data = adtte_f$STRATA1)+ |
+
| 191 | ++ |
+ #'+ |
+
| 192 | ++ |
+ #' @export+ |
+
| 193 | ++ |
+ h_coxph_df <- function(tte, is_event, arm, strata_data = NULL, control = control_coxph()) {
+ |
+
| 194 | +58x | +
+ checkmate::assert_numeric(tte)+ |
+
| 195 | +58x | +
+ checkmate::assert_logical(is_event, len = length(tte))+ |
+
| 196 | +58x | +
+ assert_valid_factor(arm, n.levels = 2, len = length(tte))+ |
+
| 197 | ++ | + + | +
| 198 | +58x | +
+ df_tte <- data.frame(tte = tte, is_event = is_event)+ |
+
| 199 | +58x | +
+ strata_vars <- NULL+ |
+
| 200 | ++ | + + | +
| 201 | +58x | +
+ if (!is.null(strata_data)) {
+ |
+
| 202 | +5x | +
+ if (is.data.frame(strata_data)) {
+ |
+
| 203 | +4x | +
+ strata_vars <- names(strata_data)+ |
+
| 204 | +4x | +
+ checkmate::assert_data_frame(strata_data, nrows = nrow(df_tte))+ |
+
| 205 | +4x | +
+ assert_df_with_factors(strata_data, as.list(stats::setNames(strata_vars, strata_vars)))+ |
+
| 206 | ++ |
+ } else {
+ |
+
| 207 | +1x | +
+ assert_valid_factor(strata_data, len = nrow(df_tte))+ |
+
| 208 | +1x | +
+ strata_vars <- "strata_data"+ |
+
| 209 | ++ |
+ }+ |
+
| 210 | +5x | +
+ df_tte[strata_vars] <- strata_data+ |
+
| 211 | ++ |
+ }+ |
+
| 212 | ++ | + + | +
| 213 | +58x | +
+ l_df <- split(df_tte, arm)+ |
+
| 214 | ++ | + + | +
| 215 | +58x | +
+ if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
+ |
+
| 216 | ++ |
+ # Hazard ratio and CI.+ |
+
| 217 | +54x | +
+ result <- s_coxph_pairwise(+ |
+
| 218 | +54x | +
+ df = l_df[[2]],+ |
+
| 219 | +54x | +
+ .ref_group = l_df[[1]],+ |
+
| 220 | +54x | +
+ .in_ref_col = FALSE,+ |
+
| 221 | +54x | +
+ .var = "tte",+ |
+
| 222 | +54x | +
+ is_event = "is_event",+ |
+
| 223 | +54x | +
+ strat = strata_vars,+ |
+
| 224 | +54x | +
+ control = control+ |
+
| 225 | ++ |
+ )+ |
+
| 226 | ++ | + + | +
| 227 | +54x | +
+ df <- data.frame(+ |
+
| 228 | ++ |
+ # Dummy column needed downstream to create a nested header.+ |
+
| 229 | +54x | +
+ arm = " ",+ |
+
| 230 | +54x | +
+ n_tot = unname(as.numeric(result$n_tot)),+ |
+
| 231 | +54x | +
+ n_tot_events = unname(as.numeric(result$n_tot_events)),+ |
+
| 232 | +54x | +
+ hr = unname(as.numeric(result$hr)),+ |
+
| 233 | +54x | +
+ lcl = unname(result$hr_ci[1]),+ |
+
| 234 | +54x | +
+ ucl = unname(result$hr_ci[2]),+ |
+
| 235 | +54x | +
+ conf_level = control[["conf_level"]],+ |
+
| 236 | +54x | +
+ pval = as.numeric(result$pvalue),+ |
+
| 237 | +54x | +
+ pval_label = obj_label(result$pvalue),+ |
+
| 238 | +54x | +
+ stringsAsFactors = FALSE+ |
+
| 239 | ++ |
+ )+ |
+
| 240 | ++ |
+ } else if (+ |
+
| 241 | +4x | +
+ (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) ||+ |
+
| 242 | +4x | +
+ (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0)+ |
+
| 243 | ++ |
+ ) {
+ |
+
| 244 | +4x | +
+ df_tte_complete <- df_tte[stats::complete.cases(df_tte), ]+ |
+
| 245 | +4x | +
+ df <- data.frame(+ |
+
| 246 | ++ |
+ # Dummy column needed downstream to create a nested header.+ |
+
| 247 | +4x | +
+ arm = " ",+ |
+
| 248 | +4x | +
+ n_tot = nrow(df_tte_complete),+ |
+
| 249 | +4x | +
+ n_tot_events = sum(df_tte_complete$is_event),+ |
+
| 250 | +4x | +
+ hr = NA,+ |
+
| 251 | +4x | +
+ lcl = NA,+ |
+
| 252 | +4x | +
+ ucl = NA,+ |
+
| 253 | +4x | +
+ conf_level = control[["conf_level"]],+ |
+
| 254 | +4x | +
+ pval = NA,+ |
+
| 255 | +4x | +
+ pval_label = NA,+ |
+
| 256 | +4x | +
+ stringsAsFactors = FALSE+ |
+
| 257 | ++ |
+ )+ |
+
| 258 | ++ |
+ } else {
+ |
+
| 259 | +! | +
+ df <- data.frame(+ |
+
| 260 | ++ |
+ # Dummy column needed downstream to create a nested header.+ |
+
| 261 | +! | +
+ arm = " ",+ |
+
| 262 | +! | +
+ n_tot = 0L,+ |
+
| 263 | +! | +
+ n_tot_events = 0L,+ |
+
| 264 | +! | +
+ hr = NA,+ |
+
| 265 | +! | +
+ lcl = NA,+ |
+
| 266 | +! | +
+ ucl = NA,+ |
+
| 267 | +! | +
+ conf_level = control[["conf_level"]],+ |
+
| 268 | +! | +
+ pval = NA,+ |
+
| 269 | +! | +
+ pval_label = NA,+ |
+
| 270 | +! | +
+ stringsAsFactors = FALSE+ |
+
| 271 | ++ |
+ )+ |
+
| 272 | ++ |
+ }+ |
+
| 273 | ++ | + + | +
| 274 | +58x | +
+ df+ |
+
| 275 | ++ |
+ }+ |
+
| 276 | ++ | + + | +
| 277 | ++ |
+ #' @describeIn h_survival_duration_subgroups summarizes estimates of the treatment hazard ratio+ |
+
| 278 | ++ |
+ #' across subgroups in a data frame. `variables` corresponds to the names of variables found in+ |
+
| 279 | ++ |
+ #' `data`, passed as a named list and requires elements `tte`, `is_event`, `arm` and+ |
+
| 280 | ++ |
+ #' optionally `subgroups` and `strat`. `groups_lists` optionally specifies+ |
+
| 281 | ++ |
+ #' groupings for `subgroups` variables.+ |
+
| 282 | ++ |
+ #'+ |
+
| 283 | ++ |
+ #' @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 | ++ |
+ #'+ |
+
| 287 | ++ |
+ #' @examples+ |
+
| 288 | ++ |
+ #' # Extract hazard ratio for multiple groups.+ |
+
| 289 | ++ |
+ #' h_coxph_subgroups_df(+ |
+
| 290 | ++ |
+ #' variables = list(+ |
+
| 291 | ++ |
+ #' tte = "AVAL",+ |
+
| 292 | ++ |
+ #' is_event = "is_event",+ |
+
| 293 | ++ |
+ #' arm = "ARM",+ |
+
| 294 | ++ |
+ #' subgroups = c("SEX", "BMRKR2")
+ |
+
| 295 | ++ |
+ #' ),+ |
+
| 296 | ++ |
+ #' data = adtte_f+ |
+
| 297 | ++ |
+ #' )+ |
+
| 298 | ++ |
+ #'+ |
+
| 299 | ++ |
+ #' # Define groupings of BMRKR2 levels.+ |
+
| 300 | ++ |
+ #' h_coxph_subgroups_df(+ |
+
| 301 | ++ |
+ #' variables = list(+ |
+
| 302 | ++ |
+ #' tte = "AVAL",+ |
+
| 303 | ++ |
+ #' is_event = "is_event",+ |
+
| 304 | ++ |
+ #' arm = "ARM",+ |
+
| 305 | ++ |
+ #' subgroups = c("SEX", "BMRKR2")
+ |
+
| 306 | ++ |
+ #' ),+ |
+
| 307 | ++ |
+ #' data = adtte_f,+ |
+
| 308 | ++ |
+ #' groups_lists = list(+ |
+
| 309 | ++ |
+ #' BMRKR2 = list(+ |
+
| 310 | ++ |
+ #' "low" = "LOW",+ |
+
| 311 | ++ |
+ #' "low/medium" = c("LOW", "MEDIUM"),
+ |
+
| 312 | ++ |
+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ |
+
| 313 | ++ |
+ #' )+ |
+
| 314 | ++ |
+ #' )+ |
+
| 315 | ++ |
+ #' )+ |
+
| 316 | ++ |
+ #'+ |
+
| 317 | ++ |
+ #' # Extract hazard ratio for multiple groups with stratification factors.+ |
+
| 318 | ++ |
+ #' h_coxph_subgroups_df(+ |
+
| 319 | ++ |
+ #' variables = list(+ |
+
| 320 | ++ |
+ #' tte = "AVAL",+ |
+
| 321 | ++ |
+ #' is_event = "is_event",+ |
+
| 322 | ++ |
+ #' arm = "ARM",+ |
+
| 323 | ++ |
+ #' subgroups = c("SEX", "BMRKR2"),
+ |
+
| 324 | ++ |
+ #' strat = c("STRATA1", "STRATA2")
+ |
+
| 325 | ++ |
+ #' ),+ |
+
| 326 | ++ |
+ #' data = adtte_f+ |
+
| 327 | ++ |
+ #' )+ |
+
| 328 | ++ |
+ #'+ |
+
| 329 | ++ |
+ #' @export+ |
+
| 330 | ++ |
+ h_coxph_subgroups_df <- function(variables,+ |
+
| 331 | ++ |
+ data,+ |
+
| 332 | ++ |
+ groups_lists = list(),+ |
+
| 333 | ++ |
+ control = control_coxph(),+ |
+
| 334 | ++ |
+ label_all = "All Patients") {
+ |
+
| 335 | +12x | +
+ checkmate::assert_character(variables$tte)+ |
+
| 336 | +12x | +
+ checkmate::assert_character(variables$is_event)+ |
+
| 337 | +12x | +
+ checkmate::assert_character(variables$arm)+ |
+
| 338 | +12x | +
+ checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ |
+
| 339 | +12x | +
+ checkmate::assert_character(variables$strat, null.ok = TRUE)+ |
+
| 340 | +12x | +
+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ |
+
| 341 | +12x | +
+ assert_df_with_variables(data, variables)+ |
+
| 342 | +12x | +
+ checkmate::assert_string(label_all)+ |
+
| 343 | ++ | + + | +
| 344 | ++ |
+ # Add All Patients.+ |
+
| 345 | +12x | +
+ result_all <- h_coxph_df(+ |
+
| 346 | +12x | +
+ tte = data[[variables$tte]],+ |
+
| 347 | +12x | +
+ is_event = data[[variables$is_event]],+ |
+
| 348 | +12x | +
+ arm = data[[variables$arm]],+ |
+
| 349 | +12x | +
+ strata_data = if (is.null(variables$strat)) NULL else data[variables$strat],+ |
+
| 350 | +12x | +
+ control = control+ |
+
| 351 | ++ |
+ )+ |
+
| 352 | +12x | +
+ result_all$subgroup <- label_all+ |
+
| 353 | +12x | +
+ result_all$var <- "ALL"+ |
+
| 354 | +12x | +
+ result_all$var_label <- label_all+ |
+
| 355 | +12x | +
+ result_all$row_type <- "content"+ |
+
| 356 | ++ | + + | +
| 357 | ++ |
+ # Add Subgroups.+ |
+
| 358 | +12x | +
+ if (is.null(variables$subgroups)) {
+ |
+
| 359 | +3x | +
+ result_all+ |
+
| 360 | ++ |
+ } else {
+ |
+
| 361 | +9x | +
+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ |
+
| 362 | ++ | + + | +
| 363 | +9x | +
+ l_result <- lapply(l_data, function(grp) {
+ |
+
| 364 | +42x | +
+ result <- h_coxph_df(+ |
+
| 365 | +42x | +
+ tte = grp$df[[variables$tte]],+ |
+
| 366 | +42x | +
+ is_event = grp$df[[variables$is_event]],+ |
+
| 367 | +42x | +
+ arm = grp$df[[variables$arm]],+ |
+
| 368 | +42x | +
+ strata_data = if (is.null(variables$strat)) NULL else grp$df[variables$strat],+ |
+
| 369 | +42x | +
+ control = control+ |
+
| 370 | ++ |
+ )+ |
+
| 371 | +42x | +
+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ |
+
| 372 | +42x | +
+ cbind(result, result_labels)+ |
+
| 373 | ++ |
+ })+ |
+
| 374 | ++ | + + | +
| 375 | +9x | +
+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ |
+
| 376 | +9x | +
+ result_subgroups$row_type <- "analysis"+ |
+
| 377 | ++ | + + | +
| 378 | +9x | +
+ rbind(+ |
+
| 379 | +9x | +
+ result_all,+ |
+
| 380 | +9x | +
+ result_subgroups+ |
+
| 381 | ++ |
+ )+ |
+
| 382 | ++ |
+ }+ |
+
| 383 | ++ |
+ }+ |
+
| 384 | ++ | + + | +
| 385 | ++ |
+ #' Split Dataframe by Subgroups+ |
+
| 386 | ++ |
+ #'+ |
+
| 387 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 388 | ++ |
+ #'+ |
+
| 389 | ++ |
+ #' Split a dataframe into a non-nested list of subsets.+ |
+
| 390 | ++ |
+ #'+ |
+
| 391 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 392 | ++ |
+ #' @inheritParams survival_duration_subgroups+ |
+
| 393 | ++ |
+ #' @param data (`data.frame`)\cr dataset to split.+ |
+
| 394 | ++ |
+ #' @param subgroups (`character`)\cr names of factor variables from `data` used to create subsets.+ |
+
| 395 | ++ |
+ #' Unused levels not present in `data` are dropped. Note that the order in this vector+ |
+
| 396 | ++ |
+ #' determines the order in the downstream table.+ |
+
| 397 | ++ |
+ #'+ |
+
| 398 | ++ |
+ #' @return A list with subset data (`df`) and metadata about the subset (`df_labels`).+ |
+
| 399 | ++ |
+ #'+ |
+
| 400 | ++ |
+ #' @details Main functionality is to prepare data for use in forest plot layouts.+ |
+
| 401 | ++ |
+ #'+ |
+
| 402 | ++ |
+ #' @examples+ |
+
| 403 | ++ |
+ #' df <- data.frame(+ |
+
| 404 | ++ |
+ #' x = c(1:5),+ |
+
| 405 | ++ |
+ #' y = factor(c("A", "B", "A", "B", "A"), levels = c("A", "B", "C")),
+ |
+
| 406 | ++ |
+ #' z = factor(c("C", "C", "D", "D", "D"), levels = c("D", "C"))
+ |
+
| 407 | ++ |
+ #' )+ |
+
| 408 | ++ |
+ #' formatters::var_labels(df) <- paste("label for", names(df))
+ |
+
| 409 | ++ |
+ #'+ |
+
| 410 | ++ |
+ #' h_split_by_subgroups(+ |
+
| 411 | ++ |
+ #' data = df,+ |
+
| 412 | ++ |
+ #' subgroups = c("y", "z")
+ |
+
| 413 | ++ |
+ #' )+ |
+
| 414 | ++ |
+ #'+ |
+
| 415 | ++ |
+ #' h_split_by_subgroups(+ |
+
| 416 | ++ |
+ #' data = df,+ |
+
| 417 | ++ |
+ #' subgroups = c("y", "z"),
+ |
+
| 418 | ++ |
+ #' groups_lists = list(+ |
+
| 419 | ++ |
+ #' y = list("AB" = c("A", "B"), "C" = "C")
+ |
+
| 420 | ++ |
+ #' )+ |
+
| 421 | ++ |
+ #' )+ |
+
| 422 | ++ |
+ #'+ |
+
| 423 | ++ |
+ #' @export+ |
+
| 424 | ++ |
+ h_split_by_subgroups <- function(data,+ |
+
| 425 | ++ |
+ subgroups,+ |
+
| 426 | ++ |
+ groups_lists = list()) {
+ |
+
| 427 | +46x | +
+ checkmate::assert_character(subgroups, min.len = 1, any.missing = FALSE)+ |
+
| 428 | +46x | +
+ checkmate::assert_list(groups_lists, names = "named")+ |
+
| 429 | +46x | +
+ checkmate::assert_subset(names(groups_lists), subgroups)+ |
+
| 430 | +46x | +
+ assert_df_with_factors(data, as.list(stats::setNames(subgroups, subgroups)))+ |
+
| 431 | ++ | + + | +
| 432 | +46x | +
+ data_labels <- unname(formatters::var_labels(data))+ |
+
| 433 | +46x | +
+ df_subgroups <- data[, subgroups, drop = FALSE]+ |
+
| 434 | +46x | +
+ subgroup_labels <- formatters::var_labels(df_subgroups, fill = TRUE)+ |
+
| 435 | ++ | + + | +
| 436 | +46x | +
+ l_labels <- Map(function(grp_i, name_i) {
+ |
+
| 437 | +81x | +
+ existing_levels <- levels(droplevels(grp_i))+ |
+
| 438 | +81x | +
+ grp_levels <- if (name_i %in% names(groups_lists)) {
+ |
+
| 439 | ++ |
+ # For this variable groupings are defined. We check which groups are contained in the data.+ |
+
| 440 | +11x | +
+ group_list_i <- groups_lists[[name_i]]+ |
+
| 441 | +11x | +
+ group_has_levels <- vapply(group_list_i, function(lvls) any(lvls %in% existing_levels), TRUE)+ |
+
| 442 | +11x | +
+ names(which(group_has_levels))+ |
+
| 443 | ++ |
+ } else {
+ |
+
| 444 | +70x | +
+ existing_levels+ |
+
| 445 | ++ |
+ }+ |
+
| 446 | +81x | +
+ df_labels <- data.frame(+ |
+
| 447 | +81x | +
+ subgroup = grp_levels,+ |
+
| 448 | +81x | +
+ var = name_i,+ |
+
| 449 | +81x | +
+ var_label = unname(subgroup_labels[name_i]),+ |
+
| 450 | +81x | +
+ stringsAsFactors = FALSE # Rationale is that subgroups may not be unique.+ |
+
| 451 | ++ |
+ )+ |
+
| 452 | +46x | +
+ }, df_subgroups, names(df_subgroups))+ |
+
| 453 | ++ | + + | +
| 454 | ++ |
+ # Create a dataframe with one row per subgroup.+ |
+
| 455 | +46x | +
+ df_labels <- do.call(rbind, args = c(l_labels, make.row.names = FALSE))+ |
+
| 456 | +46x | +
+ row_label <- paste0(df_labels$var, ".", df_labels$subgroup)+ |
+
| 457 | +46x | +
+ row_split_var <- factor(row_label, levels = row_label)+ |
+
| 458 | ++ | + + | +
| 459 | ++ |
+ # Create a list of data subsets.+ |
+
| 460 | +46x | +
+ lapply(split(df_labels, row_split_var), function(row_i) {
+ |
+
| 461 | +205x | +
+ which_row <- if (row_i$var %in% names(groups_lists)) {
+ |
+
| 462 | +31x | +
+ data[[row_i$var]] %in% groups_lists[[row_i$var]][[row_i$subgroup]]+ |
+
| 463 | ++ |
+ } else {
+ |
+
| 464 | +174x | +
+ data[[row_i$var]] == row_i$subgroup+ |
+
| 465 | ++ |
+ }+ |
+
| 466 | +205x | +
+ df <- data[which_row, ]+ |
+
| 467 | +205x | +
+ rownames(df) <- NULL+ |
+
| 468 | +205x | +
+ formatters::var_labels(df) <- data_labels+ |
+
| 469 | ++ | + + | +
| 470 | +205x | +
+ list(+ |
+
| 471 | +205x | +
+ df = df,+ |
+
| 472 | +205x | +
+ df_labels = data.frame(row_i, row.names = NULL)+ |
+
| 473 | ++ |
+ )+ |
+
| 474 | ++ |
+ })+ |
+
| 475 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Control Function for Descriptive Statistics+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Sets a list of parameters for summaries of descriptive statistics. Typically used internally to specify+ |
+
| 6 | ++ |
+ #' details for [s_summary()]. This function family is mainly used by [analyze_vars()].+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #' @param quantiles (`numeric`)\cr of length two to specify the quantiles to calculate.+ |
+
| 10 | ++ |
+ #' @param quantile_type (`numeric`)\cr between 1 and 9 selecting quantile algorithms to be used.+ |
+
| 11 | ++ |
+ #' Default is set to 2 as this matches the default quantile algorithm in SAS `proc univariate` set by `QNTLDEF=5`.+ |
+
| 12 | ++ |
+ #' This differs from R's default. See more about `type` in [stats::quantile()].+ |
+
| 13 | ++ |
+ #' @param test_mean (`numeric`)\cr to test against the mean under the null hypothesis when calculating p-value.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @note Deprecation cycle started for `control_summarize_vars` as it is going to renamed into+ |
+
| 16 | ++ |
+ #' `control_analyze_vars`. Intention is to reflect better the core underlying `rtables`+ |
+
| 17 | ++ |
+ #' functions; in this case [analyze_vars()] wraps [rtables::analyze()].+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @return A list of components with the same names as the arguments.+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @export control_analyze_vars control_summarize_vars+ |
+
| 22 | ++ |
+ #' @aliases control_summarize_vars+ |
+
| 23 | ++ |
+ control_analyze_vars <- function(conf_level = 0.95,+ |
+
| 24 | ++ |
+ quantiles = c(0.25, 0.75),+ |
+
| 25 | ++ |
+ quantile_type = 2,+ |
+
| 26 | ++ |
+ test_mean = 0) {
+ |
+
| 27 | +268x | +
+ checkmate::assert_vector(quantiles, len = 2)+ |
+
| 28 | +268x | +
+ checkmate::assert_int(quantile_type, lower = 1, upper = 9)+ |
+
| 29 | +268x | +
+ checkmate::assert_numeric(test_mean)+ |
+
| 30 | +268x | +
+ lapply(quantiles, assert_proportion_value)+ |
+
| 31 | +267x | +
+ assert_proportion_value(conf_level)+ |
+
| 32 | +266x | +
+ list(conf_level = conf_level, quantiles = quantiles, quantile_type = quantile_type, test_mean = test_mean)+ |
+
| 33 | ++ |
+ }+ |
+
| 34 | ++ | + + | +
| 35 | ++ |
+ control_summarize_vars <- control_analyze_vars+ |
+
| 36 | ++ | + + | +
| 37 | ++ | + + | +
| 38 | ++ |
+ #' Analyze Variables+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' We use the S3 generic function [s_summary()] to implement summaries for different `x` objects. This+ |
+
| 43 | ++ |
+ #' is used as a statistics function in combination with the analyze function [analyze_vars()].+ |
+
| 44 | ++ |
+ #' Deprecation cycle started for `summarize_vars` as it is going to renamed into+ |
+
| 45 | ++ |
+ #' `analyze_vars`. Intention is to reflect better the core underlying `rtables`+ |
+
| 46 | ++ |
+ #' functions; in this case [rtables::analyze()].+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 49 | ++ |
+ #'+ |
+
| 50 | ++ |
+ #' @name analyze_variables+ |
+
| 51 | ++ |
+ NULL+ |
+
| 52 | ++ | + + | +
| 53 | ++ |
+ #' @describeIn analyze_variables S3 generic function to produces a variable summary.+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' @return+ |
+
| 56 | ++ |
+ #' * `s_summary()` returns different statistics depending on the class of `x`.+ |
+
| 57 | ++ |
+ #'+ |
+
| 58 | ++ |
+ #' @export+ |
+
| 59 | ++ |
+ s_summary <- function(x,+ |
+
| 60 | ++ |
+ na.rm = TRUE, # nolint+ |
+
| 61 | ++ |
+ denom,+ |
+
| 62 | ++ |
+ .N_row, # nolint+ |
+
| 63 | ++ |
+ .N_col, # nolint+ |
+
| 64 | ++ |
+ .var,+ |
+
| 65 | ++ |
+ ...) {
+ |
+
| 66 | +700x | +
+ checkmate::assert_flag(na.rm)+ |
+
| 67 | +700x | +
+ UseMethod("s_summary", x)
+ |
+
| 68 | ++ |
+ }+ |
+
| 69 | ++ | + + | +
| 70 | ++ |
+ #' @describeIn analyze_variables Method for `numeric` class.+ |
+
| 71 | ++ |
+ #'+ |
+
| 72 | ++ |
+ #' @param control (`list`)\cr parameters for descriptive statistics details, specified by using+ |
+
| 73 | ++ |
+ #' the helper function [control_analyze_vars()]. Some possible parameter options are:+ |
+
| 74 | ++ |
+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for mean and median.+ |
+
| 75 | ++ |
+ #' * `quantiles` (`numeric`)\cr vector of length two to specify the quantiles.+ |
+
| 76 | ++ |
+ #' * `quantile_type` (`numeric`)\cr between 1 and 9 selecting quantile algorithms to be used.+ |
+
| 77 | ++ |
+ #' See more about `type` in [stats::quantile()].+ |
+
| 78 | ++ |
+ #' * `test_mean` (`numeric`)\cr value to test against the mean under the null hypothesis when calculating p-value.+ |
+
| 79 | ++ |
+ #'+ |
+
| 80 | ++ |
+ #' @return+ |
+
| 81 | ++ |
+ #' * If `x` is of class `numeric`, returns a `list` with the following named `numeric` items:+ |
+
| 82 | ++ |
+ #' * `n`: The [length()] of `x`.+ |
+
| 83 | ++ |
+ #' * `sum`: The [sum()] of `x`.+ |
+
| 84 | ++ |
+ #' * `mean`: The [mean()] of `x`.+ |
+
| 85 | ++ |
+ #' * `sd`: The [stats::sd()] of `x`.+ |
+
| 86 | ++ |
+ #' * `se`: The standard error of `x` mean, i.e.: (`sd(x) / sqrt(length(x))`).+ |
+
| 87 | ++ |
+ #' * `mean_sd`: The [mean()] and [stats::sd()] of `x`.+ |
+
| 88 | ++ |
+ #' * `mean_se`: The [mean()] of `x` and its standard error (see above).+ |
+
| 89 | ++ |
+ #' * `mean_ci`: The CI for the mean of `x` (from [stat_mean_ci()]).+ |
+
| 90 | ++ |
+ #' * `mean_sei`: The SE interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()] / [sqrt()]).+ |
+
| 91 | ++ |
+ #' * `mean_sdi`: The SD interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()]).+ |
+
| 92 | ++ |
+ #' * `mean_pval`: The two-sided p-value of the mean of `x` (from [stat_mean_pval()]).+ |
+
| 93 | ++ |
+ #' * `median`: The [stats::median()] of `x`.+ |
+
| 94 | ++ |
+ #' * `mad`: The median absolute deviation of `x`, i.e.: ([stats::median()] of `xc`,+ |
+
| 95 | ++ |
+ #' where `xc` = `x` - [stats::median()]).+ |
+
| 96 | ++ |
+ #' * `median_ci`: The CI for the median of `x` (from [stat_median_ci()]).+ |
+
| 97 | ++ |
+ #' * `quantiles`: Two sample quantiles of `x` (from [stats::quantile()]).+ |
+
| 98 | ++ |
+ #' * `iqr`: The [stats::IQR()] of `x`.+ |
+
| 99 | ++ |
+ #' * `range`: The [range_noinf()] of `x`.+ |
+
| 100 | ++ |
+ #' * `min`: The [max()] of `x`.+ |
+
| 101 | ++ |
+ #' * `max`: The [min()] of `x`.+ |
+
| 102 | ++ |
+ #' * `median_range`: The [median()] and [range_noinf()] of `x`.+ |
+
| 103 | ++ |
+ #' * `cv`: The coefficient of variation of `x`, i.e.: ([stats::sd()] / [mean()] * 100).+ |
+
| 104 | ++ |
+ #' * `geom_mean`: The geometric mean of `x`, i.e.: (`exp(mean(log(x)))`).+ |
+
| 105 | ++ |
+ #' * `geom_cv`: The geometric coefficient of variation of `x`, i.e.: (`sqrt(exp(sd(log(x)) ^ 2) - 1) * 100`).+ |
+
| 106 | ++ |
+ #'+ |
+
| 107 | ++ |
+ #' @note+ |
+
| 108 | ++ |
+ #' * If `x` is an empty vector, `NA` is returned. This is the expected feature so as to return `rcell` content in+ |
+
| 109 | ++ |
+ #' `rtables` when the intersection of a column and a row delimits an empty data selection.+ |
+
| 110 | ++ |
+ #' * When the `mean` function is applied to an empty vector, `NA` will be returned instead of `NaN`, the latter+ |
+
| 111 | ++ |
+ #' being standard behavior in R.+ |
+
| 112 | ++ |
+ #'+ |
+
| 113 | ++ |
+ #' @method s_summary numeric+ |
+
| 114 | ++ |
+ #'+ |
+
| 115 | ++ |
+ #' @examples+ |
+
| 116 | ++ |
+ #' # `s_summary.numeric`+ |
+
| 117 | ++ |
+ #'+ |
+
| 118 | ++ |
+ #' ## Basic usage: empty numeric returns NA-filled items.+ |
+
| 119 | ++ |
+ #' s_summary(numeric())+ |
+
| 120 | ++ |
+ #'+ |
+
| 121 | ++ |
+ #' ## Management of NA values.+ |
+
| 122 | ++ |
+ #' x <- c(NA_real_, 1)+ |
+
| 123 | ++ |
+ #' s_summary(x, na.rm = TRUE)+ |
+
| 124 | ++ |
+ #' s_summary(x, na.rm = FALSE)+ |
+
| 125 | ++ |
+ #'+ |
+
| 126 | ++ |
+ #' x <- c(NA_real_, 1, 2)+ |
+
| 127 | ++ |
+ #' s_summary(x, stats = NULL)+ |
+
| 128 | ++ |
+ #'+ |
+
| 129 | ++ |
+ #' ## Benefits in `rtables` contructions:+ |
+
| 130 | ++ |
+ #' require(rtables)+ |
+
| 131 | ++ |
+ #' dta_test <- data.frame(+ |
+
| 132 | ++ |
+ #' Group = rep(LETTERS[1:3], each = 2),+ |
+
| 133 | ++ |
+ #' sub_group = rep(letters[1:2], each = 3),+ |
+
| 134 | ++ |
+ #' x = 1:6+ |
+
| 135 | ++ |
+ #' )+ |
+
| 136 | ++ |
+ #'+ |
+
| 137 | ++ |
+ #' ## The summary obtained in with `rtables`:+ |
+
| 138 | ++ |
+ #' basic_table() %>%+ |
+
| 139 | ++ |
+ #' split_cols_by(var = "Group") %>%+ |
+
| 140 | ++ |
+ #' split_rows_by(var = "sub_group") %>%+ |
+
| 141 | ++ |
+ #' analyze(vars = "x", afun = s_summary) %>%+ |
+
| 142 | ++ |
+ #' build_table(df = dta_test)+ |
+
| 143 | ++ |
+ #'+ |
+
| 144 | ++ |
+ #' ## By comparison with `lapply`:+ |
+
| 145 | ++ |
+ #' X <- split(dta_test, f = with(dta_test, interaction(Group, sub_group)))+ |
+
| 146 | ++ |
+ #' lapply(X, function(x) s_summary(x$x))+ |
+
| 147 | ++ |
+ #'+ |
+
| 148 | ++ |
+ #' @export+ |
+
| 149 | ++ |
+ s_summary.numeric <- function(x,+ |
+
| 150 | ++ |
+ na.rm = TRUE, # nolint+ |
+
| 151 | ++ |
+ denom,+ |
+
| 152 | ++ |
+ .N_row, # nolint+ |
+
| 153 | ++ |
+ .N_col, # nolint+ |
+
| 154 | ++ |
+ .var,+ |
+
| 155 | ++ |
+ control = control_analyze_vars(),+ |
+
| 156 | ++ |
+ ...) {
+ |
+
| 157 | +331x | +
+ checkmate::assert_numeric(x)+ |
+
| 158 | ++ | + + | +
| 159 | +331x | +
+ if (na.rm) {
+ |
+
| 160 | +330x | +
+ x <- x[!is.na(x)]+ |
+
| 161 | ++ |
+ }+ |
+
| 162 | ++ | + + | +
| 163 | +331x | +
+ y <- list()+ |
+
| 164 | ++ | + + | +
| 165 | +331x | +
+ y$n <- c("n" = length(x))
+ |
+
| 166 | ++ | + + | +
| 167 | +331x | +
+ y$sum <- c("sum" = ifelse(length(x) == 0, NA_real_, sum(x, na.rm = FALSE)))
+ |
+
| 168 | ++ | + + | +
| 169 | +331x | +
+ y$mean <- c("mean" = ifelse(length(x) == 0, NA_real_, mean(x, na.rm = FALSE)))
+ |
+
| 170 | ++ | + + | +
| 171 | +331x | +
+ y$sd <- c("sd" = stats::sd(x, na.rm = FALSE))
+ |
+
| 172 | ++ | + + | +
| 173 | +331x | +
+ y$se <- c("se" = stats::sd(x, na.rm = FALSE) / sqrt(length(stats::na.omit(x))))
+ |
+
| 174 | ++ | + + | +
| 175 | +331x | +
+ y$mean_sd <- c(y$mean, "sd" = stats::sd(x, na.rm = FALSE))+ |
+
| 176 | ++ | + + | +
| 177 | +331x | +
+ y$mean_se <- c(y$mean, y$se)+ |
+
| 178 | ++ | + + | +
| 179 | +331x | +
+ mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE)+ |
+
| 180 | +331x | +
+ y$mean_ci <- formatters::with_label(mean_ci, paste("Mean", f_conf_level(control$conf_level)))
+ |
+
| 181 | ++ | + + | +
| 182 | +331x | +
+ mean_sei <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE) / sqrt(y$n)+ |
+
| 183 | +331x | +
+ names(mean_sei) <- c("mean_sei_lwr", "mean_sei_upr")
+ |
+
| 184 | +331x | +
+ y$mean_sei <- formatters::with_label(mean_sei, "Mean -/+ 1xSE")+ |
+
| 185 | ++ | + + | +
| 186 | +331x | +
+ mean_sdi <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE)+ |
+
| 187 | +331x | +
+ names(mean_sdi) <- c("mean_sdi_lwr", "mean_sdi_upr")
+ |
+
| 188 | +331x | +
+ y$mean_sdi <- formatters::with_label(mean_sdi, "Mean -/+ 1xSD")+ |
+
| 189 | ++ | + + | +
| 190 | +331x | +
+ mean_pval <- stat_mean_pval(x, test_mean = control$test_mean, na.rm = FALSE, n_min = 2)+ |
+
| 191 | +331x | +
+ y$mean_pval <- formatters::with_label(mean_pval, paste("Mean", f_pval(control$test_mean)))
+ |
+
| 192 | ++ | + + | +
| 193 | +331x | +
+ y$median <- c("median" = stats::median(x, na.rm = FALSE))
+ |
+
| 194 | ++ | + + | +
| 195 | +331x | +
+ y$mad <- c("mad" = stats::median(x - y$median, na.rm = FALSE))
+ |
+
| 196 | ++ | + + | +
| 197 | +331x | +
+ median_ci <- stat_median_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE)+ |
+
| 198 | +331x | +
+ y$median_ci <- formatters::with_label(median_ci, paste("Median", f_conf_level(control$conf_level)))
+ |
+
| 199 | ++ | + + | +
| 200 | +331x | +
+ q <- control$quantiles+ |
+
| 201 | +331x | +
+ if (any(is.na(x))) {
+ |
+
| 202 | +1x | +
+ qnts <- rep(NA_real_, length(q))+ |
+
| 203 | ++ |
+ } else {
+ |
+
| 204 | +330x | +
+ qnts <- stats::quantile(x, probs = q, type = control$quantile_type, na.rm = FALSE)+ |
+
| 205 | ++ |
+ }+ |
+
| 206 | +331x | +
+ names(qnts) <- paste("quantile", q, sep = "_")
+ |
+
| 207 | +331x | +
+ y$quantiles <- formatters::with_label(qnts, paste0(paste(paste0(q * 100, "%"), collapse = " and "), "-ile"))+ |
+
| 208 | ++ | + + | +
| 209 | +331x | +
+ y$iqr <- c("iqr" = ifelse(
+ |
+
| 210 | +331x | +
+ any(is.na(x)),+ |
+
| 211 | +331x | +
+ NA_real_,+ |
+
| 212 | +331x | +
+ stats::IQR(x, na.rm = FALSE, type = control$quantile_type)+ |
+
| 213 | ++ |
+ ))+ |
+
| 214 | ++ | + + | +
| 215 | +331x | +
+ y$range <- stats::setNames(range_noinf(x, na.rm = FALSE), c("min", "max"))
+ |
+
| 216 | +331x | +
+ y$min <- y$range[1]+ |
+
| 217 | +331x | +
+ y$max <- y$range[2]+ |
+
| 218 | ++ | + + | +
| 219 | +331x | +
+ y$median_range <- formatters::with_label(c(y$median, y$range), "Median (Min - Max)")+ |
+
| 220 | ++ | + + | +
| 221 | +331x | +
+ y$cv <- c("cv" = unname(y$sd) / unname(y$mean) * 100)
+ |
+
| 222 | ++ | + + | +
| 223 | ++ |
+ # Convert negative values to NA for log calculation.+ |
+
| 224 | +331x | +
+ x_no_negative_vals <- x+ |
+
| 225 | +331x | +
+ x_no_negative_vals[x_no_negative_vals <= 0] <- NA+ |
+
| 226 | +331x | +
+ y$geom_mean <- c("geom_mean" = exp(mean(log(x_no_negative_vals), na.rm = FALSE)))
+ |
+
| 227 | +331x | +
+ geom_mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE, geom_mean = TRUE)+ |
+
| 228 | +331x | +
+ y$geom_mean_ci <- formatters::with_label(geom_mean_ci, paste("Geometric Mean", f_conf_level(control$conf_level)))
+ |
+
| 229 | ++ | + + | +
| 230 | +331x | +
+ y$geom_cv <- c("geom_cv" = sqrt(exp(stats::sd(log(x_no_negative_vals), na.rm = FALSE) ^ 2) - 1) * 100) # styler: off
+ |
+
| 231 | ++ | + + | +
| 232 | +331x | +
+ y+ |
+
| 233 | ++ |
+ }+ |
+
| 234 | ++ | + + | +
| 235 | ++ |
+ #' @describeIn analyze_variables Method for `factor` class.+ |
+
| 236 | ++ |
+ #'+ |
+
| 237 | ++ |
+ #' @param denom (`string`)\cr choice of denominator for factor proportions. Options are:+ |
+
| 238 | ++ |
+ #' * `n`: number of values in this row and column intersection.+ |
+
| 239 | ++ |
+ #' * `N_row`: total number of values in this row across columns.+ |
+
| 240 | ++ |
+ #' * `N_col`: total number of values in this column across rows.+ |
+
| 241 | ++ |
+ #'+ |
+
| 242 | ++ |
+ #' @return+ |
+
| 243 | ++ |
+ #' * If `x` is of class `factor` or converted from `character`, returns a `list` with named `numeric` items:+ |
+
| 244 | ++ |
+ #' * `n`: The [length()] of `x`.+ |
+
| 245 | ++ |
+ #' * `count`: A list with the number of cases for each level of the factor `x`.+ |
+
| 246 | ++ |
+ #' * `count_fraction`: Similar to `count` but also includes the proportion of cases for each level of the+ |
+
| 247 | ++ |
+ #' factor `x` relative to the denominator, or `NA` if the denominator is zero.+ |
+
| 248 | ++ |
+ #'+ |
+
| 249 | ++ |
+ #' @note+ |
+
| 250 | ++ |
+ #' * If `x` is an empty `factor`, a list is still returned for `counts` with one element+ |
+
| 251 | ++ |
+ #' per factor level. If there are no levels in `x`, the function fails.+ |
+
| 252 | ++ |
+ #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values+ |
+
| 253 | ++ |
+ #' set `na.rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit+ |
+
| 254 | ++ |
+ #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the+ |
+
| 255 | ++ |
+ #' default `na_level` (`"<Missing>"`) will also be excluded when `na.rm` is set to `TRUE`.+ |
+
| 256 | ++ |
+ #'+ |
+
| 257 | ++ |
+ #' @method s_summary factor+ |
+
| 258 | ++ |
+ #'+ |
+
| 259 | ++ |
+ #' @examples+ |
+
| 260 | ++ |
+ #' # `s_summary.factor`+ |
+
| 261 | ++ |
+ #'+ |
+
| 262 | ++ |
+ #' ## Basic usage:+ |
+
| 263 | ++ |
+ #' s_summary(factor(c("a", "a", "b", "c", "a")))
+ |
+
| 264 | ++ |
+ #'+ |
+
| 265 | ++ |
+ #' # Empty factor returns zero-filled items.+ |
+
| 266 | ++ |
+ #' s_summary(factor(levels = c("a", "b", "c")))
+ |
+
| 267 | ++ |
+ #'+ |
+
| 268 | ++ |
+ #' ## Management of NA values.+ |
+
| 269 | ++ |
+ #' x <- factor(c(NA, "Female"))+ |
+
| 270 | ++ |
+ #' x <- explicit_na(x)+ |
+
| 271 | ++ |
+ #' s_summary(x, na.rm = TRUE)+ |
+
| 272 | ++ |
+ #' s_summary(x, na.rm = FALSE)+ |
+
| 273 | ++ |
+ #'+ |
+
| 274 | ++ |
+ #' ## Different denominators.+ |
+
| 275 | ++ |
+ #' x <- factor(c("a", "a", "b", "c", "a"))
+ |
+
| 276 | ++ |
+ #' s_summary(x, denom = "N_row", .N_row = 10L)+ |
+
| 277 | ++ |
+ #' s_summary(x, denom = "N_col", .N_col = 20L)+ |
+
| 278 | ++ |
+ #'+ |
+
| 279 | ++ |
+ #' @export+ |
+
| 280 | ++ |
+ s_summary.factor <- function(x,+ |
+
| 281 | ++ |
+ na.rm = TRUE, # nolint+ |
+
| 282 | ++ |
+ denom = c("n", "N_row", "N_col"),
+ |
+
| 283 | ++ |
+ .N_row, # nolint+ |
+
| 284 | ++ |
+ .N_col, # nolint+ |
+
| 285 | ++ |
+ ...) {
+ |
+
| 286 | +274x | +
+ assert_valid_factor(x)+ |
+
| 287 | +271x | +
+ denom <- match.arg(denom)+ |
+
| 288 | ++ | + + | +
| 289 | +271x | +
+ if (na.rm) {
+ |
+
| 290 | +267x | +
+ x <- x[!is.na(x)] %>% fct_discard("<Missing>")
+ |
+
| 291 | ++ |
+ } else {
+ |
+
| 292 | +4x | +
+ x <- x %>% explicit_na(label = "NA")+ |
+
| 293 | ++ |
+ }+ |
+
| 294 | ++ | + + | +
| 295 | +271x | +
+ y <- list()+ |
+
| 296 | ++ | + + | +
| 297 | +271x | +
+ y$n <- length(x)+ |
+
| 298 | ++ | + + | +
| 299 | +271x | +
+ y$count <- as.list(table(x, useNA = "ifany"))+ |
+
| 300 | +271x | +
+ dn <- switch(denom,+ |
+
| 301 | +271x | +
+ n = length(x),+ |
+
| 302 | +271x | +
+ N_row = .N_row,+ |
+
| 303 | +271x | +
+ N_col = .N_col+ |
+
| 304 | ++ |
+ )+ |
+
| 305 | +271x | +
+ y$count_fraction <- lapply(+ |
+
| 306 | +271x | +
+ y$count,+ |
+
| 307 | +271x | +
+ function(x) {
+ |
+
| 308 | +2089x | +
+ c(x, ifelse(dn > 0, x / dn, 0))+ |
+
| 309 | ++ |
+ }+ |
+
| 310 | ++ |
+ )+ |
+
| 311 | ++ | + + | +
| 312 | +271x | +
+ y$n_blq <- sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", x))
+ |
+
| 313 | ++ | + + | +
| 314 | +271x | +
+ y+ |
+
| 315 | ++ |
+ }+ |
+
| 316 | ++ | + + | +
| 317 | ++ |
+ #' @describeIn analyze_variables Method for `character` class. This makes an automatic+ |
+
| 318 | ++ |
+ #' conversion to factor (with a warning) and then forwards to the method for factors.+ |
+
| 319 | ++ |
+ #'+ |
+
| 320 | ++ |
+ #' @param verbose (`logical`)\cr Defaults to `TRUE`, which prints out warnings and messages. It is mainly used+ |
+
| 321 | ++ |
+ #' to print out information about factor casting.+ |
+
| 322 | ++ |
+ #'+ |
+
| 323 | ++ |
+ #' @note+ |
+
| 324 | ++ |
+ #' * Automatic conversion of character to factor does not guarantee that the table+ |
+
| 325 | ++ |
+ #' can be generated correctly. In particular for sparse tables this very likely can fail.+ |
+
| 326 | ++ |
+ #' It is therefore better to always pre-process the dataset such that factors are manually+ |
+
| 327 | ++ |
+ #' created from character variables before passing the dataset to [rtables::build_table()].+ |
+
| 328 | ++ |
+ #'+ |
+
| 329 | ++ |
+ #' @method s_summary character+ |
+
| 330 | ++ |
+ #'+ |
+
| 331 | ++ |
+ #' @examples+ |
+
| 332 | ++ |
+ #' # `s_summary.character`+ |
+
| 333 | ++ |
+ #'+ |
+
| 334 | ++ |
+ #' ## Basic usage:+ |
+
| 335 | ++ |
+ #' s_summary(c("a", "a", "b", "c", "a"), .var = "x", verbose = FALSE)
+ |
+
| 336 | ++ |
+ #' s_summary(c("a", "a", "b", "c", "a", ""), .var = "x", na.rm = FALSE, verbose = FALSE)
+ |
+
| 337 | ++ |
+ #'+ |
+
| 338 | ++ |
+ #' @export+ |
+
| 339 | ++ | + + | +
| 340 | ++ |
+ s_summary.character <- function(x,+ |
+
| 341 | ++ |
+ na.rm = TRUE, # nolint+ |
+
| 342 | ++ |
+ denom = c("n", "N_row", "N_col"),
+ |
+
| 343 | ++ |
+ .N_row, # nolint+ |
+
| 344 | ++ |
+ .N_col, # nolint+ |
+
| 345 | ++ |
+ .var,+ |
+
| 346 | ++ |
+ verbose = TRUE,+ |
+
| 347 | ++ |
+ ...) {
+ |
+
| 348 | +6x | +
+ if (na.rm) {
+ |
+
| 349 | +5x | +
+ y <- as_factor_keep_attributes(x, verbose = verbose)+ |
+
| 350 | ++ |
+ } else {
+ |
+
| 351 | +1x | +
+ y <- as_factor_keep_attributes(x, verbose = verbose, na_level = "NA")+ |
+
| 352 | ++ |
+ }+ |
+
| 353 | ++ | + + | +
| 354 | +6x | +
+ s_summary(+ |
+
| 355 | +6x | +
+ x = y,+ |
+
| 356 | +6x | +
+ na.rm = na.rm,+ |
+
| 357 | +6x | +
+ denom = denom,+ |
+
| 358 | +6x | +
+ .N_row = .N_row,+ |
+
| 359 | +6x | +
+ .N_col = .N_col,+ |
+
| 360 | ++ |
+ ...+ |
+
| 361 | ++ |
+ )+ |
+
| 362 | ++ |
+ }+ |
+
| 363 | ++ | + + | +
| 364 | ++ |
+ #' @describeIn analyze_variables Method for `logical` class.+ |
+
| 365 | ++ |
+ #'+ |
+
| 366 | ++ |
+ #' @param denom (`string`)\cr choice of denominator for proportion. Options are:+ |
+
| 367 | ++ |
+ #' * `n`: number of values in this row and column intersection.+ |
+
| 368 | ++ |
+ #' * `N_row`: total number of values in this row across columns.+ |
+
| 369 | ++ |
+ #' * `N_col`: total number of values in this column across rows.+ |
+
| 370 | ++ |
+ #'+ |
+
| 371 | ++ |
+ #' @return+ |
+
| 372 | ++ |
+ #' * If `x` is of class `logical`, returns a `list` with named `numeric` items:+ |
+
| 373 | ++ |
+ #' * `n`: The [length()] of `x` (possibly after removing `NA`s).+ |
+
| 374 | ++ |
+ #' * `count`: Count of `TRUE` in `x`.+ |
+
| 375 | ++ |
+ #' * `count_fraction`: Count and proportion of `TRUE` in `x` relative to the denominator, or `NA` if the+ |
+
| 376 | ++ |
+ #' denominator is zero. Note that `NA`s in `x` are never counted or leading to `NA` here.+ |
+
| 377 | ++ |
+ #'+ |
+
| 378 | ++ |
+ #' @method s_summary logical+ |
+
| 379 | ++ |
+ #'+ |
+
| 380 | ++ |
+ #' @examples+ |
+
| 381 | ++ |
+ #' # `s_summary.logical`+ |
+
| 382 | ++ |
+ #'+ |
+
| 383 | ++ |
+ #' ## Basic usage:+ |
+
| 384 | ++ |
+ #' s_summary(c(TRUE, FALSE, TRUE, TRUE))+ |
+
| 385 | ++ |
+ #'+ |
+
| 386 | ++ |
+ #' # Empty factor returns zero-filled items.+ |
+
| 387 | ++ |
+ #' s_summary(as.logical(c()))+ |
+
| 388 | ++ |
+ #'+ |
+
| 389 | ++ |
+ #' ## Management of NA values.+ |
+
| 390 | ++ |
+ #' x <- c(NA, TRUE, FALSE)+ |
+
| 391 | ++ |
+ #' s_summary(x, na.rm = TRUE)+ |
+
| 392 | ++ |
+ #' s_summary(x, na.rm = FALSE)+ |
+
| 393 | ++ |
+ #'+ |
+
| 394 | ++ |
+ #' ## Different denominators.+ |
+
| 395 | ++ |
+ #' x <- c(TRUE, FALSE, TRUE, TRUE)+ |
+
| 396 | ++ |
+ #' s_summary(x, denom = "N_row", .N_row = 10L)+ |
+
| 397 | ++ |
+ #' s_summary(x, denom = "N_col", .N_col = 20L)+ |
+
| 398 | ++ |
+ #'+ |
+
| 399 | ++ |
+ #' @export+ |
+
| 400 | ++ |
+ s_summary.logical <- function(x,+ |
+
| 401 | ++ |
+ na.rm = TRUE, # nolint+ |
+
| 402 | ++ |
+ denom = c("n", "N_row", "N_col"),
+ |
+
| 403 | ++ |
+ .N_row, # nolint+ |
+
| 404 | ++ |
+ .N_col, # nolint+ |
+
| 405 | ++ |
+ ...) {
+ |
+
| 406 | +116x | +
+ denom <- match.arg(denom)+ |
+
| 407 | +114x | +
+ if (na.rm) x <- x[!is.na(x)]+ |
+
| 408 | +116x | +
+ y <- list()+ |
+
| 409 | +116x | +
+ y$n <- length(x)+ |
+
| 410 | +116x | +
+ count <- sum(x, na.rm = TRUE)+ |
+
| 411 | +116x | +
+ dn <- switch(denom,+ |
+
| 412 | +116x | +
+ n = length(x),+ |
+
| 413 | +116x | +
+ N_row = .N_row,+ |
+
| 414 | +116x | +
+ N_col = .N_col+ |
+
| 415 | ++ |
+ )+ |
+
| 416 | +116x | +
+ y$count <- count+ |
+
| 417 | +116x | +
+ y$count_fraction <- c(count, ifelse(dn > 0, count / dn, 0))+ |
+
| 418 | +116x | +
+ y$n_blq <- 0L+ |
+
| 419 | +116x | +
+ y+ |
+
| 420 | ++ |
+ }+ |
+
| 421 | ++ | + + | +
| 422 | ++ |
+ #' @describeIn analyze_variables Formatted analysis function which is used as `afun` in `analyze_vars()` and+ |
+
| 423 | ++ |
+ #' `compare_vars()` and as `cfun` in `summarize_colvars()`.+ |
+
| 424 | ++ |
+ #'+ |
+
| 425 | ++ |
+ #' @param compare (`logical`)\cr Whether comparison statistics should be analyzed instead of summary statistics+ |
+
| 426 | ++ |
+ #' (`compare = TRUE` adds `pval` statistic comparing against reference group).+ |
+
| 427 | ++ |
+ #'+ |
+
| 428 | ++ |
+ #' @return+ |
+
| 429 | ++ |
+ #' * `a_summary()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 430 | ++ |
+ #'+ |
+
| 431 | ++ |
+ #' @note+ |
+
| 432 | ++ |
+ #' * To use for comparison (with additional p-value statistic), parameter `compare` must be set to `TRUE`.+ |
+
| 433 | ++ |
+ #' * Ensure that either all `NA` values are converted to an explicit `NA` level or all `NA` values are left as is.+ |
+
| 434 | ++ |
+ #'+ |
+
| 435 | ++ |
+ #' @examples+ |
+
| 436 | ++ |
+ #' a_summary(factor(c("a", "a", "b", "c", "a")), .N_row = 10, .N_col = 10)
+ |
+
| 437 | ++ |
+ #' a_summary(+ |
+
| 438 | ++ |
+ #' factor(c("a", "a", "b", "c", "a")),
+ |
+
| 439 | ++ |
+ #' .ref_group = factor(c("a", "a", "b", "c")), compare = TRUE
+ |
+
| 440 | ++ |
+ #' )+ |
+
| 441 | ++ |
+ #'+ |
+
| 442 | ++ |
+ #' a_summary(c("A", "B", "A", "C"), .var = "x", .N_col = 10, .N_row = 10, verbose = FALSE)
+ |
+
| 443 | ++ |
+ #' a_summary(+ |
+
| 444 | ++ |
+ #' c("A", "B", "A", "C"),
+ |
+
| 445 | ++ |
+ #' .ref_group = c("B", "A", "C"), .var = "x", compare = TRUE, verbose = FALSE
+ |
+
| 446 | ++ |
+ #' )+ |
+
| 447 | ++ |
+ #'+ |
+
| 448 | ++ |
+ #' a_summary(c(TRUE, FALSE, FALSE, TRUE, TRUE), .N_row = 10, .N_col = 10)+ |
+
| 449 | ++ |
+ #' a_summary(+ |
+
| 450 | ++ |
+ #' c(TRUE, FALSE, FALSE, TRUE, TRUE),+ |
+
| 451 | ++ |
+ #' .ref_group = c(TRUE, FALSE), .in_ref_col = TRUE, compare = TRUE+ |
+
| 452 | ++ |
+ #' )+ |
+
| 453 | ++ |
+ #'+ |
+
| 454 | ++ |
+ #' a_summary(rnorm(10), .N_col = 10, .N_row = 20, .var = "bla")+ |
+
| 455 | ++ |
+ #' a_summary(rnorm(10, 5, 1), .ref_group = rnorm(20, -5, 1), .var = "bla", compare = TRUE)+ |
+
| 456 | ++ |
+ #'+ |
+
| 457 | ++ | + + | +
| 458 | ++ |
+ #' @export+ |
+
| 459 | ++ |
+ a_summary <- function(x,+ |
+
| 460 | ++ |
+ .N_col, # nolint+ |
+
| 461 | ++ |
+ .N_row, # nolint+ |
+
| 462 | ++ |
+ .var = NULL,+ |
+
| 463 | ++ |
+ .df_row = NULL,+ |
+
| 464 | ++ |
+ .ref_group = NULL,+ |
+
| 465 | ++ |
+ .in_ref_col = FALSE,+ |
+
| 466 | ++ |
+ compare = FALSE,+ |
+
| 467 | ++ |
+ .stats = NULL,+ |
+
| 468 | ++ |
+ .formats = NULL,+ |
+
| 469 | ++ |
+ .labels = NULL,+ |
+
| 470 | ++ |
+ .indent_mods = NULL,+ |
+
| 471 | ++ |
+ na.rm = TRUE, # nolint+ |
+
| 472 | ++ |
+ na_level = lifecycle::deprecated(),+ |
+
| 473 | ++ |
+ na_str = NA_character_,+ |
+
| 474 | ++ |
+ ...) {
+ |
+
| 475 | +293x | +
+ if (lifecycle::is_present(na_level)) {
+ |
+
| 476 | +! | +
+ lifecycle::deprecate_warn("0.9.1", "a_summary(na_level)", "a_summary(na_str)")
+ |
+
| 477 | +! | +
+ na_str <- na_level+ |
+
| 478 | ++ |
+ }+ |
+
| 479 | ++ | + + | +
| 480 | +293x | +
+ if (is.numeric(x)) {
+ |
+
| 481 | +68x | +
+ type <- "numeric"+ |
+
| 482 | +68x | +
+ if (!is.null(.stats) && any(grepl("^pval", .stats))) {
+ |
+
| 483 | +9x | +
+ .stats[grepl("^pval", .stats)] <- "pval" # tmp fix xxx
+ |
+
| 484 | ++ |
+ }+ |
+
| 485 | ++ |
+ } else {
+ |
+
| 486 | +225x | +
+ type <- "counts"+ |
+
| 487 | +225x | +
+ if (!is.null(.stats) && any(grepl("^pval", .stats))) {
+ |
+
| 488 | +9x | +
+ .stats[grepl("^pval", .stats)] <- "pval_counts" # tmp fix xxx
+ |
+
| 489 | ++ |
+ }+ |
+
| 490 | ++ |
+ }+ |
+
| 491 | ++ | + + | +
| 492 | ++ |
+ # If one col has NA vals, must add NA row to other cols (using placeholder lvl `fill-na-level`)+ |
+
| 493 | +! | +
+ if (any(is.na(.df_row[[.var]])) && !any(is.na(x)) && !na.rm) levels(x) <- c(levels(x), "fill-na-level")+ |
+
| 494 | ++ | + + | +
| 495 | +293x | +
+ x_stats <- if (!compare) {
+ |
+
| 496 | +274x | +
+ s_summary(x = x, .N_col = .N_col, .N_row = .N_row, na.rm = na.rm, ...)+ |
+
| 497 | ++ |
+ } else {
+ |
+
| 498 | +19x | +
+ s_compare(+ |
+
| 499 | +19x | +
+ x = x, .N_col = .N_col, .N_row = .N_row, na.rm = na.rm, .ref_group = .ref_group, .in_ref_col = .in_ref_col, ...+ |
+
| 500 | ++ |
+ )+ |
+
| 501 | ++ |
+ }+ |
+
| 502 | ++ | + + | +
| 503 | ++ |
+ # Fill in with formatting defaults if needed+ |
+
| 504 | +293x | +
+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ |
+
| 505 | +293x | +
+ .stats <- get_stats(met_grp, stats_in = .stats, add_pval = compare)+ |
+
| 506 | +293x | +
+ .formats <- get_formats_from_stats(.stats, .formats)+ |
+
| 507 | +293x | +
+ .labels <- get_labels_from_stats(.stats, .labels)+ |
+
| 508 | ++ | + + | +
| 509 | +293x | +
+ indent_mods_custom <- .indent_mods+ |
+
| 510 | +293x | +
+ .indent_mods <- stats::setNames(rep(0L, length(.stats)), .stats)+ |
+
| 511 | +293x | +
+ if (!is.null(indent_mods_custom)) {
+ |
+
| 512 | +32x | +
+ if (is.null(names(indent_mods_custom)) && length(indent_mods_custom) == 1) {
+ |
+
| 513 | +2x | +
+ .indent_mods[names(.indent_mods)] <- indent_mods_custom+ |
+
| 514 | ++ |
+ } else {
+ |
+
| 515 | +30x | +
+ .indent_mods[names(indent_mods_custom)] <- indent_mods_custom+ |
+
| 516 | ++ |
+ }+ |
+
| 517 | ++ |
+ }+ |
+
| 518 | ++ | + + | +
| 519 | +293x | +
+ x_stats <- x_stats[.stats]+ |
+
| 520 | ++ | + + | +
| 521 | ++ |
+ # Check for custom labels from control_analyze_vars+ |
+
| 522 | +293x | +
+ if (is.numeric(x)) {
+ |
+
| 523 | +68x | +
+ default_labels <- get_labels_from_stats(.stats)+ |
+
| 524 | +68x | +
+ for (i in intersect(.stats, c("mean_ci", "mean_pval", "median_ci", "quantiles"))) {
+ |
+
| 525 | +25x | +
+ if (!i %in% names(.labels) || .labels[[i]] == default_labels[[i]]) {
+ |
+
| 526 | +25x | +
+ .labels[[i]] <- attr(x_stats[[i]], "label")+ |
+
| 527 | ++ |
+ }+ |
+
| 528 | ++ |
+ }+ |
+
| 529 | ++ |
+ }+ |
+
| 530 | ++ | + + | +
| 531 | +293x | +
+ if (is.factor(x) || is.character(x)) {
+ |
+
| 532 | ++ |
+ # Ungroup statistics with values for each level of x+ |
+
| 533 | +224x | +
+ x_ungrp <- ungroup_stats(x_stats, .formats, .labels, .indent_mods)+ |
+
| 534 | +224x | +
+ x_stats <- x_ungrp[["x"]]+ |
+
| 535 | +224x | +
+ .formats <- x_ungrp[[".formats"]]+ |
+
| 536 | +224x | +
+ .labels <- gsub("fill-na-level", "NA", x_ungrp[[".labels"]])
+ |
+
| 537 | +224x | +
+ .indent_mods <- x_ungrp[[".indent_mods"]]+ |
+
| 538 | ++ |
+ }+ |
+
| 539 | ++ | + + | +
| 540 | ++ |
+ # auto formats handling+ |
+
| 541 | +293x | +
+ fmt_is_auto <- vapply(.formats, function(ii) is.character(ii) && ii == "auto", logical(1))+ |
+
| 542 | +293x | +
+ if (any(fmt_is_auto)) {
+ |
+
| 543 | +1x | +
+ res_l_auto <- x_stats[fmt_is_auto]+ |
+
| 544 | +1x | +
+ tmp_dt_var <- .df_row[[.var]] # xxx this can be extended for the WHOLE data or single facets+ |
+
| 545 | +1x | +
+ .formats[fmt_is_auto] <- lapply(seq_along(res_l_auto), function(rla) {
+ |
+
| 546 | +2x | +
+ format_auto(tmp_dt_var, names(res_l_auto)[rla])+ |
+
| 547 | ++ |
+ })+ |
+
| 548 | ++ |
+ }+ |
+
| 549 | ++ | + + | +
| 550 | +293x | +
+ in_rows(+ |
+
| 551 | +293x | +
+ .list = x_stats,+ |
+
| 552 | +293x | +
+ .formats = .formats,+ |
+
| 553 | +293x | +
+ .names = .labels,+ |
+
| 554 | +293x | +
+ .labels = .labels,+ |
+
| 555 | +293x | +
+ .indent_mods = .indent_mods,+ |
+
| 556 | +293x | +
+ .format_na_strs = na_str+ |
+
| 557 | ++ |
+ )+ |
+
| 558 | ++ |
+ }+ |
+
| 559 | ++ | + + | +
| 560 | ++ |
+ #' Constructor Function for [analyze_vars()] and [summarize_colvars()]+ |
+
| 561 | ++ |
+ #'+ |
+
| 562 | ++ |
+ #' @description `r lifecycle::badge("deprecated")`
+ |
+
| 563 | ++ |
+ #'+ |
+
| 564 | ++ |
+ #' Constructor function which creates a combined formatted analysis function.+ |
+
| 565 | ++ |
+ #'+ |
+
| 566 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 567 | ++ |
+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ |
+
| 568 | ++ |
+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ |
+
| 569 | ++ |
+ #' for that statistic's row label.+ |
+
| 570 | ++ |
+ #'+ |
+
| 571 | ++ |
+ #' @return Combined formatted analysis function for use in [analyze_vars()].+ |
+
| 572 | ++ |
+ #'+ |
+
| 573 | ++ |
+ #' @note This function has been deprecated in favor of direct implementation of `a_summary()`.+ |
+
| 574 | ++ |
+ #'+ |
+
| 575 | ++ |
+ #' @seealso [analyze_vars()]+ |
+
| 576 | ++ |
+ #'+ |
+
| 577 | ++ |
+ #' @export+ |
+
| 578 | ++ |
+ create_afun_summary <- function(.stats, .formats, .labels, .indent_mods) {
+ |
+
| 579 | +1x | +
+ lifecycle::deprecate_warn(+ |
+
| 580 | +1x | +
+ "0.8.5.9010",+ |
+
| 581 | +1x | +
+ "create_afun_summary()",+ |
+
| 582 | +1x | +
+ details = "Please use a_summary() directly instead."+ |
+
| 583 | ++ |
+ )+ |
+
| 584 | +1x | +
+ function(x,+ |
+
| 585 | +1x | +
+ .ref_group,+ |
+
| 586 | +1x | +
+ .in_ref_col,+ |
+
| 587 | ++ |
+ ...,+ |
+
| 588 | +1x | +
+ .var) {
+ |
+
| 589 | +18x | +
+ a_summary(x,+ |
+
| 590 | +18x | +
+ .stats = .stats,+ |
+
| 591 | +18x | +
+ .formats = .formats,+ |
+
| 592 | +18x | +
+ .labels = .labels,+ |
+
| 593 | +18x | +
+ .indent_mods = .indent_mods,+ |
+
| 594 | +18x | +
+ .ref_group = .ref_group,+ |
+
| 595 | +18x | +
+ .in_ref_col = .in_ref_col,+ |
+
| 596 | +18x | +
+ .var = .var, ...+ |
+
| 597 | ++ |
+ )+ |
+
| 598 | ++ |
+ }+ |
+
| 599 | ++ |
+ }+ |
+
| 600 | ++ | + + | +
| 601 | ++ |
+ #' @describeIn analyze_variables Layout-creating function which can take statistics function arguments+ |
+
| 602 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 603 | ++ |
+ #'+ |
+
| 604 | ++ |
+ #' @param ... arguments passed to `s_summary()`.+ |
+
| 605 | ++ |
+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ |
+
| 606 | ++ |
+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ |
+
| 607 | ++ |
+ #' for that statistic's row label.+ |
+
| 608 | ++ |
+ #'+ |
+
| 609 | ++ |
+ #' @details+ |
+
| 610 | ++ |
+ #' It is possible to use `"auto"` for `analyze_vars` on a subset of methods. This uses [format_auto()] to+ |
+
| 611 | ++ |
+ #' determine automatically the number of digits from the analyzed variable (`.vars`), but only for the+ |
+
| 612 | ++ |
+ #' current row data (`.df_row[[.var]]`, see `?rtables::additional_fun_params`), and not for the whole+ |
+
| 613 | ++ |
+ #' data. Also no column split is considered.+ |
+
| 614 | ++ |
+ #'+ |
+
| 615 | ++ |
+ #' @return+ |
+
| 616 | ++ |
+ #' * `analyze_vars()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 617 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 618 | ++ |
+ #' the statistics from `s_summary()` to the table layout.+ |
+
| 619 | ++ |
+ #'+ |
+
| 620 | ++ |
+ #' @examples+ |
+
| 621 | ++ |
+ #' ## Fabricated dataset.+ |
+
| 622 | ++ |
+ #' dta_test <- data.frame(+ |
+
| 623 | ++ |
+ #' USUBJID = rep(1:6, each = 3),+ |
+
| 624 | ++ |
+ #' PARAMCD = rep("lab", 6 * 3),
+ |
+
| 625 | ++ |
+ #' AVISIT = rep(paste0("V", 1:3), 6),
+ |
+
| 626 | ++ |
+ #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ |
+
| 627 | ++ |
+ #' AVAL = c(9:1, rep(NA, 9))+ |
+
| 628 | ++ |
+ #' )+ |
+
| 629 | ++ |
+ #'+ |
+
| 630 | ++ |
+ #' # `analyze_vars()` in `rtables` pipelines+ |
+
| 631 | ++ |
+ #' ## Default output within a `rtables` pipeline.+ |
+
| 632 | ++ |
+ #' l <- basic_table() %>%+ |
+
| 633 | ++ |
+ #' split_cols_by(var = "ARM") %>%+ |
+
| 634 | ++ |
+ #' split_rows_by(var = "AVISIT") %>%+ |
+
| 635 | ++ |
+ #' analyze_vars(vars = "AVAL")+ |
+
| 636 | ++ |
+ #'+ |
+
| 637 | ++ |
+ #' build_table(l, df = dta_test)+ |
+
| 638 | ++ |
+ #'+ |
+
| 639 | ++ |
+ #' ## Select and format statistics output.+ |
+
| 640 | ++ |
+ #' l <- basic_table() %>%+ |
+
| 641 | ++ |
+ #' split_cols_by(var = "ARM") %>%+ |
+
| 642 | ++ |
+ #' split_rows_by(var = "AVISIT") %>%+ |
+
| 643 | ++ |
+ #' analyze_vars(+ |
+
| 644 | ++ |
+ #' vars = "AVAL",+ |
+
| 645 | ++ |
+ #' .stats = c("n", "mean_sd", "quantiles"),
+ |
+
| 646 | ++ |
+ #' .formats = c("mean_sd" = "xx.x, xx.x"),
+ |
+
| 647 | ++ |
+ #' .labels = c(n = "n", mean_sd = "Mean, SD", quantiles = c("Q1 - Q3"))
+ |
+
| 648 | ++ |
+ #' )+ |
+
| 649 | ++ |
+ #'+ |
+
| 650 | ++ |
+ #' build_table(l, df = dta_test)+ |
+
| 651 | ++ |
+ #'+ |
+
| 652 | ++ |
+ #' ## Use arguments interpreted by `s_summary`.+ |
+
| 653 | ++ |
+ #' l <- basic_table() %>%+ |
+
| 654 | ++ |
+ #' split_cols_by(var = "ARM") %>%+ |
+
| 655 | ++ |
+ #' split_rows_by(var = "AVISIT") %>%+ |
+
| 656 | ++ |
+ #' analyze_vars(vars = "AVAL", na.rm = FALSE)+ |
+
| 657 | ++ |
+ #'+ |
+
| 658 | ++ |
+ #' build_table(l, df = dta_test)+ |
+
| 659 | ++ |
+ #'+ |
+
| 660 | ++ |
+ #' ## Handle `NA` levels first when summarizing factors.+ |
+
| 661 | ++ |
+ #' dta_test$AVISIT <- NA_character_+ |
+
| 662 | ++ |
+ #' dta_test <- df_explicit_na(dta_test)+ |
+
| 663 | ++ |
+ #' l <- basic_table() %>%+ |
+
| 664 | ++ |
+ #' split_cols_by(var = "ARM") %>%+ |
+
| 665 | ++ |
+ #' analyze_vars(vars = "AVISIT", na.rm = FALSE)+ |
+
| 666 | ++ |
+ #'+ |
+
| 667 | ++ |
+ #' build_table(l, df = dta_test)+ |
+
| 668 | ++ |
+ #'+ |
+
| 669 | ++ |
+ #' # auto format+ |
+
| 670 | ++ |
+ #' dt <- data.frame("VAR" = c(0.001, 0.2, 0.0011000, 3, 4))
+ |
+
| 671 | ++ |
+ #' basic_table() %>%+ |
+
| 672 | ++ |
+ #' analyze_vars(+ |
+
| 673 | ++ |
+ #' vars = "VAR",+ |
+
| 674 | ++ |
+ #' .stats = c("n", "mean", "mean_sd", "range"),
+ |
+
| 675 | ++ |
+ #' .formats = c("mean_sd" = "auto", "range" = "auto")
+ |
+
| 676 | ++ |
+ #' ) %>%+ |
+
| 677 | ++ |
+ #' build_table(dt)+ |
+
| 678 | ++ |
+ #'+ |
+
| 679 | ++ |
+ #' @export analyze_vars summarize_vars+ |
+
| 680 | ++ |
+ analyze_vars <- function(lyt,+ |
+
| 681 | ++ |
+ vars,+ |
+
| 682 | ++ |
+ var_labels = vars,+ |
+
| 683 | ++ |
+ na_level = lifecycle::deprecated(),+ |
+
| 684 | ++ |
+ na_str = NA_character_,+ |
+
| 685 | ++ |
+ nested = TRUE,+ |
+
| 686 | ++ |
+ ...,+ |
+
| 687 | ++ |
+ na.rm = TRUE, # nolint+ |
+
| 688 | ++ |
+ show_labels = "default",+ |
+
| 689 | ++ |
+ table_names = vars,+ |
+
| 690 | ++ |
+ section_div = NA_character_,+ |
+
| 691 | ++ |
+ .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
+ |
+
| 692 | ++ |
+ .formats = NULL,+ |
+
| 693 | ++ |
+ .labels = NULL,+ |
+
| 694 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 695 | +20x | +
+ if (lifecycle::is_present(na_level)) {
+ |
+
| 696 | +! | +
+ lifecycle::deprecate_warn("0.9.1", "analyze_vars(na_level)", "analyze_vars(na_str)")
+ |
+
| 697 | +! | +
+ na_str <- na_level+ |
+
| 698 | ++ |
+ }+ |
+
| 699 | ++ | + + | +
| 700 | +20x | +
+ extra_args <- list(.stats = .stats, na.rm = na.rm, na_str = na_str, ...)+ |
+
| 701 | +2x | +
+ if (!is.null(.formats)) extra_args[[".formats"]] <- .formats+ |
+
| 702 | +! | +
+ if (!is.null(.labels)) extra_args[[".labels"]] <- .labels+ |
+
| 703 | +! | +
+ if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods+ |
+
| 704 | ++ | + + | +
| 705 | +20x | +
+ analyze(+ |
+
| 706 | +20x | +
+ lyt = lyt,+ |
+
| 707 | +20x | +
+ vars = vars,+ |
+
| 708 | +20x | +
+ var_labels = var_labels,+ |
+
| 709 | +20x | +
+ afun = a_summary,+ |
+
| 710 | +20x | +
+ na_str = na_str,+ |
+
| 711 | +20x | +
+ nested = nested,+ |
+
| 712 | +20x | +
+ extra_args = extra_args,+ |
+
| 713 | +20x | +
+ inclNAs = TRUE,+ |
+
| 714 | +20x | +
+ show_labels = show_labels,+ |
+
| 715 | +20x | +
+ table_names = table_names,+ |
+
| 716 | +20x | +
+ section_div = section_div+ |
+
| 717 | ++ |
+ )+ |
+
| 718 | ++ |
+ }+ |
+
| 719 | ++ |
+ #' @describeIn analyze_variables `r lifecycle::badge("deprecated")` Use `analyze_vars` instead.
+ |
+
| 720 | ++ |
+ summarize_vars <- function(...) {
+ |
+
| 721 | +! | +
+ lifecycle::deprecate_warn(when = "0.8.5.9010", "summarize_vars()", "analyze_vars()")+ |
+
| 722 | +! | +
+ analyze_vars(...)+ |
+
| 723 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Kaplan-Meier Plot+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' From a survival model, a graphic is rendered along with tabulated annotation+ |
+
| 6 | ++ |
+ #' including the number of patient at risk at given time and the median survival+ |
+
| 7 | ++ |
+ #' per group.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @inheritParams grid::gTree+ |
+
| 10 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 11 | ++ |
+ #' @param df (`data.frame`)\cr data set containing all analysis variables.+ |
+
| 12 | ++ |
+ #' @param variables (named `list`)\cr variable names. Details are:+ |
+
| 13 | ++ |
+ #' * `tte` (`numeric`)\cr variable indicating time-to-event duration values.+ |
+
| 14 | ++ |
+ #' * `is_event` (`logical`)\cr event variable. `TRUE` if event, `FALSE` if time to event is censored.+ |
+
| 15 | ++ |
+ #' * `arm` (`factor`)\cr the treatment group variable.+ |
+
| 16 | ++ |
+ #' * `strat` (`character` or `NULL`)\cr variable names indicating stratification factors.+ |
+
| 17 | ++ |
+ #' @param control_surv (`list`)\cr parameters for comparison details, specified by using+ |
+
| 18 | ++ |
+ #' the helper function [control_surv_timepoint()]. Some possible parameter options are:+ |
+
| 19 | ++ |
+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate.+ |
+
| 20 | ++ |
+ #' * `conf_type` (`string`)\cr `"plain"` (default), `"log"`, `"log-log"` for confidence interval type,+ |
+
| 21 | ++ |
+ #' see more in [survival::survfit()]. Note that the option "none" is no longer supported.+ |
+
| 22 | ++ |
+ #' @param xticks (`numeric`, `number`, or `NULL`)\cr numeric vector of ticks or single number with spacing+ |
+
| 23 | ++ |
+ #' between ticks on the x axis. If `NULL` (default), [labeling::extended()] is used to determine+ |
+
| 24 | ++ |
+ #' an optimal tick position on the x axis.+ |
+
| 25 | ++ |
+ #' @param yval (`string`)\cr value of y-axis. Options are `Survival` (default) and `Failure` probability.+ |
+
| 26 | ++ |
+ #' @param censor_show (`flag`)\cr whether to show censored.+ |
+
| 27 | ++ |
+ #' @param xlab (`string`)\cr label of x-axis.+ |
+
| 28 | ++ |
+ #' @param ylab (`string`)\cr label of y-axis.+ |
+
| 29 | ++ |
+ #' @param ylim (`vector` of `numeric`)\cr vector of length 2 containing lower and upper limits for the y-axis.+ |
+
| 30 | ++ |
+ #' If `NULL` (default), the minimum and maximum y-values displayed are used as limits.+ |
+
| 31 | ++ |
+ #' @param title (`string`)\cr title for plot.+ |
+
| 32 | ++ |
+ #' @param footnotes (`string`)\cr footnotes for plot.+ |
+
| 33 | ++ |
+ #' @param col (`character`)\cr lines colors. Length of a vector should be equal+ |
+
| 34 | ++ |
+ #' to number of strata from [survival::survfit()].+ |
+
| 35 | ++ |
+ #' @param lty (`numeric`)\cr line type. Length of a vector should be equal+ |
+
| 36 | ++ |
+ #' to number of strata from [survival::survfit()].+ |
+
| 37 | ++ |
+ #' @param lwd (`numeric`)\cr line width. Length of a vector should be equal+ |
+
| 38 | ++ |
+ #' to number of strata from [survival::survfit()].+ |
+
| 39 | ++ |
+ #' @param pch (`numeric`, `string`)\cr value or character of points symbol to indicate censored cases.+ |
+
| 40 | ++ |
+ #' @param size (`numeric`)\cr size of censored point, a class of `unit`.+ |
+
| 41 | ++ |
+ #' @param max_time (`numeric`)\cr maximum value to show on X axis. Only data values less than or up to+ |
+
| 42 | ++ |
+ #' this threshold value will be plotted (defaults to `NULL`).+ |
+
| 43 | ++ |
+ #' @param font_size (`number`)\cr font size to be used.+ |
+
| 44 | ++ |
+ #' @param ci_ribbon (`flag`)\cr draw the confidence interval around the Kaplan-Meier curve.+ |
+
| 45 | ++ |
+ #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control outlook of the Kaplan-Meier curve.+ |
+
| 46 | ++ |
+ #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of patient at risk+ |
+
| 47 | ++ |
+ #' matching the main grid of the Kaplan-Meier curve.+ |
+
| 48 | ++ |
+ #' @param annot_at_risk_title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk`+ |
+
| 49 | ++ |
+ #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`.+ |
+
| 50 | ++ |
+ #' @param annot_surv_med (`flag`)\cr compute and add the annotation table on the Kaplan-Meier curve estimating the+ |
+
| 51 | ++ |
+ #' median survival time per group.+ |
+
| 52 | ++ |
+ #' @param annot_coxph (`flag`)\cr add the annotation table from a [survival::coxph()] model.+ |
+
| 53 | ++ |
+ #' @param annot_stats (`string`)\cr statistics annotations to add to the plot. Options are+ |
+
| 54 | ++ |
+ #' `median` (median survival follow-up time) and `min` (minimum survival follow-up time).+ |
+
| 55 | ++ |
+ #' @param annot_stats_vlines (`flag`)\cr add vertical lines corresponding to each of the statistics+ |
+
| 56 | ++ |
+ #' specified by `annot_stats`. If `annot_stats` is `NULL` no lines will be added.+ |
+
| 57 | ++ |
+ #' @param control_coxph_pw (`list`)\cr parameters for comparison details, specified by using+ |
+
| 58 | ++ |
+ #' the helper function [control_coxph()]. Some possible parameter options are:+ |
+
| 59 | ++ |
+ #' * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1.+ |
+
| 60 | ++ |
+ #' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`.+ |
+
| 61 | ++ |
+ #' * `ties` (`string`)\cr method for tie handling. Default is `"efron"`,+ |
+
| 62 | ++ |
+ #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()]+ |
+
| 63 | ++ |
+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR.+ |
+
| 64 | ++ |
+ #' @param position_coxph (`numeric`)\cr x and y positions for plotting [survival::coxph()] model.+ |
+
| 65 | ++ |
+ #' @param position_surv_med (`numeric`)\cr x and y positions for plotting annotation table estimating median survival+ |
+
| 66 | ++ |
+ #' time per group.+ |
+
| 67 | ++ |
+ #' @param width_annots (named `list` of `unit`s)\cr a named list of widths for annotation tables with names `surv_med`+ |
+
| 68 | ++ |
+ #' (median survival time table) and `coxph` ([survival::coxph()] model table), where each value is the width+ |
+
| 69 | ++ |
+ #' (in units) to implement when printing the annotation table.+ |
+
| 70 | ++ |
+ #'+ |
+
| 71 | ++ |
+ #' @return A `grob` of class `gTree`.+ |
+
| 72 | ++ |
+ #'+ |
+
| 73 | ++ |
+ #' @examples+ |
+
| 74 | ++ |
+ #' \donttest{
+ |
+
| 75 | ++ |
+ #' library(dplyr)+ |
+
| 76 | ++ |
+ #' library(ggplot2)+ |
+
| 77 | ++ |
+ #' library(survival)+ |
+
| 78 | ++ |
+ #' library(grid)+ |
+
| 79 | ++ |
+ #' library(nestcolor)+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ #' df <- tern_ex_adtte %>%+ |
+
| 82 | ++ |
+ #' filter(PARAMCD == "OS") %>%+ |
+
| 83 | ++ |
+ #' mutate(is_event = CNSR == 0)+ |
+
| 84 | ++ |
+ #' variables <- list(tte = "AVAL", is_event = "is_event", arm = "ARMCD")+ |
+
| 85 | ++ |
+ #'+ |
+
| 86 | ++ |
+ #' # 1. Example - basic option+ |
+
| 87 | ++ |
+ #'+ |
+
| 88 | ++ |
+ #' res <- g_km(df = df, variables = variables)+ |
+
| 89 | ++ |
+ #' res <- g_km(df = df, variables = variables, yval = "Failure")+ |
+
| 90 | ++ |
+ #' res <- g_km(+ |
+
| 91 | ++ |
+ #' df = df,+ |
+
| 92 | ++ |
+ #' variables = variables,+ |
+
| 93 | ++ |
+ #' control_surv = control_surv_timepoint(conf_level = 0.9),+ |
+
| 94 | ++ |
+ #' col = c("grey25", "grey50", "grey75"),
+ |
+
| 95 | ++ |
+ #' annot_at_risk_title = FALSE+ |
+
| 96 | ++ |
+ #' )+ |
+
| 97 | ++ |
+ #' res <- g_km(df = df, variables = variables, ggtheme = theme_minimal())+ |
+
| 98 | ++ |
+ #' res <- g_km(df = df, variables = variables, ggtheme = theme_minimal(), lty = 1:3)+ |
+
| 99 | ++ |
+ #' res <- g_km(df = df, variables = variables, max = 2000)+ |
+
| 100 | ++ |
+ #' res <- g_km(+ |
+
| 101 | ++ |
+ #' df = df,+ |
+
| 102 | ++ |
+ #' variables = variables,+ |
+
| 103 | ++ |
+ #' annot_stats = c("min", "median"),
+ |
+
| 104 | ++ |
+ #' annot_stats_vlines = TRUE+ |
+
| 105 | ++ |
+ #' )+ |
+
| 106 | ++ |
+ #'+ |
+
| 107 | ++ |
+ #' # 2. Example - Arrange several KM curve on a single graph device+ |
+
| 108 | ++ |
+ #'+ |
+
| 109 | ++ |
+ #' # 2.1 Use case: A general graph on the top, a zoom on the bottom.+ |
+
| 110 | ++ |
+ #' grid.newpage()+ |
+
| 111 | ++ |
+ #' lyt <- grid.layout(nrow = 2, ncol = 1) %>%+ |
+
| 112 | ++ |
+ #' viewport(layout = .) %>%+ |
+
| 113 | ++ |
+ #' pushViewport()+ |
+
| 114 | ++ |
+ #'+ |
+
| 115 | ++ |
+ #' res <- g_km(+ |
+
| 116 | ++ |
+ #' df = df, variables = variables, newpage = FALSE, annot_surv_med = FALSE,+ |
+
| 117 | ++ |
+ #' vp = viewport(layout.pos.row = 1, layout.pos.col = 1)+ |
+
| 118 | ++ |
+ #' )+ |
+
| 119 | ++ |
+ #' res <- g_km(+ |
+
| 120 | ++ |
+ #' df = df, variables = variables, max = 1000, newpage = FALSE, annot_surv_med = FALSE,+ |
+
| 121 | ++ |
+ #' ggtheme = theme_dark(),+ |
+
| 122 | ++ |
+ #' vp = viewport(layout.pos.row = 2, layout.pos.col = 1)+ |
+
| 123 | ++ |
+ #' )+ |
+
| 124 | ++ |
+ #'+ |
+
| 125 | ++ |
+ #' # 2.1 Use case: No annotations on top, annotated graph on bottom+ |
+
| 126 | ++ |
+ #' grid.newpage()+ |
+
| 127 | ++ |
+ #' lyt <- grid.layout(nrow = 2, ncol = 1) %>%+ |
+
| 128 | ++ |
+ #' viewport(layout = .) %>%+ |
+
| 129 | ++ |
+ #' pushViewport()+ |
+
| 130 | ++ |
+ #'+ |
+
| 131 | ++ |
+ #' res <- g_km(+ |
+
| 132 | ++ |
+ #' df = df, variables = variables, newpage = FALSE,+ |
+
| 133 | ++ |
+ #' annot_surv_med = FALSE, annot_at_risk = FALSE,+ |
+
| 134 | ++ |
+ #' vp = viewport(layout.pos.row = 1, layout.pos.col = 1)+ |
+
| 135 | ++ |
+ #' )+ |
+
| 136 | ++ |
+ #' res <- g_km(+ |
+
| 137 | ++ |
+ #' df = df, variables = variables, max = 2000, newpage = FALSE, annot_surv_med = FALSE,+ |
+
| 138 | ++ |
+ #' annot_at_risk = TRUE,+ |
+
| 139 | ++ |
+ #' ggtheme = theme_dark(),+ |
+
| 140 | ++ |
+ #' vp = viewport(layout.pos.row = 2, layout.pos.col = 1)+ |
+
| 141 | ++ |
+ #' )+ |
+
| 142 | ++ |
+ #'+ |
+
| 143 | ++ |
+ #' # Add annotation from a pairwise coxph analysis+ |
+
| 144 | ++ |
+ #' g_km(+ |
+
| 145 | ++ |
+ #' df = df, variables = variables,+ |
+
| 146 | ++ |
+ #' annot_coxph = TRUE+ |
+
| 147 | ++ |
+ #' )+ |
+
| 148 | ++ |
+ #'+ |
+
| 149 | ++ |
+ #' # Change widths/sizes of surv_med and coxph annotation tables.+ |
+
| 150 | ++ |
+ #' g_km(+ |
+
| 151 | ++ |
+ #' df = df, variables = c(variables, list(strat = "SEX")),+ |
+
| 152 | ++ |
+ #' annot_coxph = TRUE,+ |
+
| 153 | ++ |
+ #' width_annots = list(surv_med = grid::unit(2, "in"), coxph = grid::unit(3, "in"))+ |
+
| 154 | ++ |
+ #' )+ |
+
| 155 | ++ |
+ #'+ |
+
| 156 | ++ |
+ #' g_km(+ |
+
| 157 | ++ |
+ #' df = df, variables = c(variables, list(strat = "SEX")),+ |
+
| 158 | ++ |
+ #' font_size = 15,+ |
+
| 159 | ++ |
+ #' annot_coxph = TRUE,+ |
+
| 160 | ++ |
+ #' control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99),+ |
+
| 161 | ++ |
+ #' position_coxph = c(0.5, 0.5)+ |
+
| 162 | ++ |
+ #' )+ |
+
| 163 | ++ |
+ #'+ |
+
| 164 | ++ |
+ #' # Change position of the treatment group annotation table.+ |
+
| 165 | ++ |
+ #' g_km(+ |
+
| 166 | ++ |
+ #' df = df, variables = c(variables, list(strat = "SEX")),+ |
+
| 167 | ++ |
+ #' font_size = 15,+ |
+
| 168 | ++ |
+ #' annot_coxph = TRUE,+ |
+
| 169 | ++ |
+ #' control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99),+ |
+
| 170 | ++ |
+ #' position_surv_med = c(1, 0.7)+ |
+
| 171 | ++ |
+ #' )+ |
+
| 172 | ++ |
+ #' }+ |
+
| 173 | ++ |
+ #'+ |
+
| 174 | ++ |
+ #' @export+ |
+
| 175 | ++ |
+ g_km <- function(df,+ |
+
| 176 | ++ |
+ variables,+ |
+
| 177 | ++ |
+ control_surv = control_surv_timepoint(),+ |
+
| 178 | ++ |
+ col = NULL,+ |
+
| 179 | ++ |
+ lty = NULL,+ |
+
| 180 | ++ |
+ lwd = .5,+ |
+
| 181 | ++ |
+ censor_show = TRUE,+ |
+
| 182 | ++ |
+ pch = 3,+ |
+
| 183 | ++ |
+ size = 2,+ |
+
| 184 | ++ |
+ max_time = NULL,+ |
+
| 185 | ++ |
+ xticks = NULL,+ |
+
| 186 | ++ |
+ xlab = "Days",+ |
+
| 187 | ++ |
+ yval = c("Survival", "Failure"),
+ |
+
| 188 | ++ |
+ ylab = paste(yval, "Probability"),+ |
+
| 189 | ++ |
+ ylim = NULL,+ |
+
| 190 | ++ |
+ title = NULL,+ |
+
| 191 | ++ |
+ footnotes = NULL,+ |
+
| 192 | ++ |
+ draw = TRUE,+ |
+
| 193 | ++ |
+ newpage = TRUE,+ |
+
| 194 | ++ |
+ gp = NULL,+ |
+
| 195 | ++ |
+ vp = NULL,+ |
+
| 196 | ++ |
+ name = NULL,+ |
+
| 197 | ++ |
+ font_size = 12,+ |
+
| 198 | ++ |
+ ci_ribbon = FALSE,+ |
+
| 199 | ++ |
+ ggtheme = nestcolor::theme_nest(),+ |
+
| 200 | ++ |
+ annot_at_risk = TRUE,+ |
+
| 201 | ++ |
+ annot_at_risk_title = TRUE,+ |
+
| 202 | ++ |
+ annot_surv_med = TRUE,+ |
+
| 203 | ++ |
+ annot_coxph = FALSE,+ |
+
| 204 | ++ |
+ annot_stats = NULL,+ |
+
| 205 | ++ |
+ annot_stats_vlines = FALSE,+ |
+
| 206 | ++ |
+ control_coxph_pw = control_coxph(),+ |
+
| 207 | ++ |
+ position_coxph = c(-0.03, -0.02),+ |
+
| 208 | ++ |
+ position_surv_med = c(0.95, 0.9),+ |
+
| 209 | ++ |
+ width_annots = list(surv_med = grid::unit(0.3, "npc"), coxph = grid::unit(0.4, "npc"))) {
+ |
+
| 210 | +8x | +
+ checkmate::assert_list(variables)+ |
+
| 211 | +8x | +
+ checkmate::assert_subset(c("tte", "arm", "is_event"), names(variables))
+ |
+
| 212 | +8x | +
+ checkmate::assert_string(title, null.ok = TRUE)+ |
+
| 213 | +8x | +
+ checkmate::assert_string(footnotes, null.ok = TRUE)+ |
+
| 214 | +8x | +
+ checkmate::assert_character(col, null.ok = TRUE)+ |
+
| 215 | +8x | +
+ checkmate::assert_subset(annot_stats, c("median", "min"))
+ |
+
| 216 | +8x | +
+ checkmate::assert_logical(annot_stats_vlines)+ |
+
| 217 | +8x | +
+ checkmate::assert_true(all(sapply(width_annots, grid::is.unit)))+ |
+
| 218 | ++ | + + | +
| 219 | +8x | +
+ tte <- variables$tte+ |
+
| 220 | +8x | +
+ is_event <- variables$is_event+ |
+
| 221 | +8x | +
+ arm <- variables$arm+ |
+
| 222 | ++ | + + | +
| 223 | +8x | +
+ assert_valid_factor(df[[arm]])+ |
+
| 224 | +8x | +
+ assert_df_with_variables(df, list(tte = tte, is_event = is_event, arm = arm))+ |
+
| 225 | +8x | +
+ checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)+ |
+
| 226 | +8x | +
+ checkmate::assert_numeric(df[[tte]], min.len = 1, any.missing = FALSE)+ |
+
| 227 | ++ | + + | +
| 228 | +8x | +
+ armval <- as.character(unique(df[[arm]]))+ |
+
| 229 | +8x | +
+ if (annot_coxph && length(armval) < 2) {
+ |
+
| 230 | +! | +
+ stop(paste(+ |
+
| 231 | +! | +
+ "When `annot_coxph` = TRUE, `df` must contain at least 2 levels of `variables$arm`",+ |
+
| 232 | +! | +
+ "in order to calculate the hazard ratio."+ |
+
| 233 | ++ |
+ ))+ |
+
| 234 | +8x | +
+ } else if (length(armval) > 1) {
+ |
+
| 235 | +8x | +
+ armval <- NULL+ |
+
| 236 | ++ |
+ }+ |
+
| 237 | +8x | +
+ yval <- match.arg(yval)+ |
+
| 238 | +8x | +
+ formula <- stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", arm))
+ |
+
| 239 | +8x | +
+ fit_km <- survival::survfit(+ |
+
| 240 | +8x | +
+ formula = formula,+ |
+
| 241 | +8x | +
+ data = df,+ |
+
| 242 | +8x | +
+ conf.int = control_surv$conf_level,+ |
+
| 243 | +8x | +
+ conf.type = control_surv$conf_type+ |
+
| 244 | ++ |
+ )+ |
+
| 245 | +8x | +
+ data_plot <- h_data_plot(+ |
+
| 246 | +8x | +
+ fit_km = fit_km,+ |
+
| 247 | +8x | +
+ armval = armval,+ |
+
| 248 | +8x | +
+ max_time = max_time+ |
+
| 249 | ++ |
+ )+ |
+
| 250 | ++ | + + | +
| 251 | +8x | +
+ xticks <- h_xticks(data = data_plot, xticks = xticks, max_time = max_time)+ |
+
| 252 | +8x | +
+ gg <- h_ggkm(+ |
+
| 253 | +8x | +
+ data = data_plot,+ |
+
| 254 | +8x | +
+ censor_show = censor_show,+ |
+
| 255 | +8x | +
+ pch = pch,+ |
+
| 256 | +8x | +
+ size = size,+ |
+
| 257 | +8x | +
+ xticks = xticks,+ |
+
| 258 | +8x | +
+ xlab = xlab,+ |
+
| 259 | +8x | +
+ yval = yval,+ |
+
| 260 | +8x | +
+ ylab = ylab,+ |
+
| 261 | +8x | +
+ ylim = ylim,+ |
+
| 262 | +8x | +
+ title = title,+ |
+
| 263 | +8x | +
+ footnotes = footnotes,+ |
+
| 264 | +8x | +
+ max_time = max_time,+ |
+
| 265 | +8x | +
+ lwd = lwd,+ |
+
| 266 | +8x | +
+ lty = lty,+ |
+
| 267 | +8x | +
+ col = col,+ |
+
| 268 | +8x | +
+ ggtheme = ggtheme,+ |
+
| 269 | +8x | +
+ ci_ribbon = ci_ribbon+ |
+
| 270 | ++ |
+ )+ |
+
| 271 | ++ | + + | +
| 272 | +8x | +
+ if (!is.null(annot_stats)) {
+ |
+
| 273 | +! | +
+ if ("median" %in% annot_stats) {
+ |
+
| 274 | +! | +
+ fit_km_all <- survival::survfit(+ |
+
| 275 | +! | +
+ formula = stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", 1)),
+ |
+
| 276 | +! | +
+ data = df,+ |
+
| 277 | +! | +
+ conf.int = control_surv$conf_level,+ |
+
| 278 | +! | +
+ conf.type = control_surv$conf_type+ |
+
| 279 | ++ |
+ )+ |
+
| 280 | +! | +
+ gg <- gg ++ |
+
| 281 | +! | +
+ geom_text(+ |
+
| 282 | +! | +
+ size = 8 / ggplot2::.pt, col = 1,+ |
+
| 283 | +! | +
+ x = stats::median(fit_km_all) + 0.065 * max(data_plot$time),+ |
+
| 284 | +! | +
+ y = ifelse(yval == "Survival", 0.62, 0.38),+ |
+
| 285 | +! | +
+ label = paste("Median F/U:\n", round(stats::median(fit_km_all), 1), tolower(df$AVALU[1]))
+ |
+
| 286 | ++ |
+ )+ |
+
| 287 | +! | +
+ if (annot_stats_vlines) {
+ |
+
| 288 | +! | +
+ gg <- gg ++ |
+
| 289 | +! | +
+ geom_segment(aes(x = stats::median(fit_km_all), xend = stats::median(fit_km_all), y = -Inf, yend = Inf),+ |
+
| 290 | +! | +
+ linetype = 2, col = "darkgray"+ |
+
| 291 | ++ |
+ )+ |
+
| 292 | ++ |
+ }+ |
+
| 293 | ++ |
+ }+ |
+
| 294 | +! | +
+ if ("min" %in% annot_stats) {
+ |
+
| 295 | +! | +
+ min_fu <- min(df[[tte]])+ |
+
| 296 | +! | +
+ gg <- gg ++ |
+
| 297 | +! | +
+ geom_text(+ |
+
| 298 | +! | +
+ size = 8 / ggplot2::.pt, col = 1,+ |
+
| 299 | +! | +
+ x = min_fu + max(data_plot$time) * ifelse(yval == "Survival", 0.05, 0.07),+ |
+
| 300 | +! | +
+ y = ifelse(yval == "Survival", 1.0, 0.05),+ |
+
| 301 | +! | +
+ label = paste("Min. F/U:\n", round(min_fu, 1), tolower(df$AVALU[1]))
+ |
+
| 302 | ++ |
+ )+ |
+
| 303 | +! | +
+ if (annot_stats_vlines) {
+ |
+
| 304 | +! | +
+ gg <- gg ++ |
+
| 305 | +! | +
+ geom_segment(aes(x = min_fu, xend = min_fu, y = Inf, yend = -Inf), linetype = 2, col = "darkgray")+ |
+
| 306 | ++ |
+ }+ |
+
| 307 | ++ |
+ }+ |
+
| 308 | +! | +
+ gg <- gg + ggplot2::guides(fill = ggplot2::guide_legend(override.aes = list(shape = NA, label = "")))+ |
+
| 309 | ++ |
+ }+ |
+
| 310 | ++ | + + | +
| 311 | +8x | +
+ g_el <- h_decompose_gg(gg)+ |
+
| 312 | ++ | + + | +
| 313 | +8x | +
+ if (annot_at_risk) {
+ |
+
| 314 | ++ |
+ # This is the content of the table that will be below the graph.+ |
+
| 315 | +6x | +
+ annot_tbl <- summary(fit_km, time = xticks)+ |
+
| 316 | +6x | +
+ annot_tbl <- if (is.null(fit_km$strata)) {
+ |
+
| 317 | +! | +
+ data.frame(+ |
+
| 318 | +! | +
+ n.risk = annot_tbl$n.risk,+ |
+
| 319 | +! | +
+ time = annot_tbl$time,+ |
+
| 320 | +! | +
+ strata = as.factor(armval)+ |
+
| 321 | ++ |
+ )+ |
+
| 322 | ++ |
+ } else {
+ |
+
| 323 | +6x | +
+ strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
+ |
+
| 324 | +6x | +
+ levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2]+ |
+
| 325 | +6x | +
+ data.frame(+ |
+
| 326 | +6x | +
+ n.risk = annot_tbl$n.risk,+ |
+
| 327 | +6x | +
+ time = annot_tbl$time,+ |
+
| 328 | +6x | +
+ strata = annot_tbl$strata+ |
+
| 329 | ++ |
+ )+ |
+
| 330 | ++ |
+ }+ |
+
| 331 | ++ | + + | +
| 332 | +6x | +
+ grobs_patient <- h_grob_tbl_at_risk(+ |
+
| 333 | +6x | +
+ data = data_plot,+ |
+
| 334 | +6x | +
+ annot_tbl = annot_tbl,+ |
+
| 335 | +6x | +
+ xlim = max(max_time, data_plot$time, xticks),+ |
+
| 336 | +6x | +
+ title = annot_at_risk_title+ |
+
| 337 | ++ |
+ )+ |
+
| 338 | ++ |
+ }+ |
+
| 339 | ++ | + + | +
| 340 | +8x | +
+ if (annot_at_risk || annot_surv_med || annot_coxph) {
+ |
+
| 341 | +6x | +
+ lyt <- h_km_layout(+ |
+
| 342 | +6x | +
+ data = data_plot, g_el = g_el, title = title, footnotes = footnotes,+ |
+
| 343 | +6x | +
+ annot_at_risk = annot_at_risk, annot_at_risk_title = annot_at_risk_title+ |
+
| 344 | ++ |
+ )+ |
+
| 345 | +6x | +
+ at_risk_ttl <- as.numeric(annot_at_risk_title)+ |
+
| 346 | +6x | +
+ ttl_row <- as.numeric(!is.null(title))+ |
+
| 347 | +6x | +
+ foot_row <- as.numeric(!is.null(footnotes))+ |
+
| 348 | +6x | +
+ km_grob <- grid::gTree(+ |
+
| 349 | +6x | +
+ vp = grid::viewport(layout = lyt, height = .95, width = .95),+ |
+
| 350 | +6x | +
+ children = grid::gList(+ |
+
| 351 | ++ |
+ # Title.+ |
+
| 352 | +6x | +
+ if (ttl_row == 1) {
+ |
+
| 353 | +1x | +
+ grid::gTree(+ |
+
| 354 | +1x | +
+ vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 2),+ |
+
| 355 | +1x | +
+ children = grid::gList(grid::textGrob(label = title, x = grid::unit(0, "npc"), hjust = 0))+ |
+
| 356 | ++ |
+ )+ |
+
| 357 | ++ |
+ },+ |
+
| 358 | ++ | + + | +
| 359 | ++ |
+ # The Kaplan - Meier curve (top-right corner).+ |
+
| 360 | +6x | +
+ grid::gTree(+ |
+
| 361 | +6x | +
+ vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 2),+ |
+
| 362 | +6x | +
+ children = grid::gList(g_el$panel)+ |
+
| 363 | ++ |
+ ),+ |
+
| 364 | ++ | + + | +
| 365 | ++ |
+ # Survfit summary table (top-right corner).+ |
+
| 366 | +6x | +
+ if (annot_surv_med) {
+ |
+
| 367 | +5x | +
+ grid::gTree(+ |
+
| 368 | +5x | +
+ vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 2),+ |
+
| 369 | +5x | +
+ children = h_grob_median_surv(+ |
+
| 370 | +5x | +
+ fit_km = fit_km,+ |
+
| 371 | +5x | +
+ armval = armval,+ |
+
| 372 | +5x | +
+ x = position_surv_med[1],+ |
+
| 373 | +5x | +
+ y = position_surv_med[2],+ |
+
| 374 | +5x | +
+ width = if (!is.null(width_annots[["surv_med"]])) width_annots[["surv_med"]] else grid::unit(0.3, "npc"),+ |
+
| 375 | +5x | +
+ ttheme = gridExtra::ttheme_default(base_size = font_size)+ |
+
| 376 | ++ |
+ )+ |
+
| 377 | ++ |
+ )+ |
+
| 378 | ++ |
+ },+ |
+
| 379 | +6x | +
+ if (annot_coxph) {
+ |
+
| 380 | +1x | +
+ grid::gTree(+ |
+
| 381 | +1x | +
+ vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 2),+ |
+
| 382 | +1x | +
+ children = h_grob_coxph(+ |
+
| 383 | +1x | +
+ df = df,+ |
+
| 384 | +1x | +
+ variables = variables,+ |
+
| 385 | +1x | +
+ control_coxph_pw = control_coxph_pw,+ |
+
| 386 | +1x | +
+ x = position_coxph[1],+ |
+
| 387 | +1x | +
+ y = position_coxph[2],+ |
+
| 388 | +1x | +
+ width = if (!is.null(width_annots[["coxph"]])) width_annots[["coxph"]] else grid::unit(0.4, "npc"),+ |
+
| 389 | +1x | +
+ ttheme = gridExtra::ttheme_default(+ |
+
| 390 | +1x | +
+ base_size = font_size,+ |
+
| 391 | +1x | +
+ padding = grid::unit(c(1, .5), "lines"),+ |
+
| 392 | +1x | +
+ core = list(bg_params = list(fill = c("grey95", "grey90"), alpha = .5))
+ |
+
| 393 | ++ |
+ )+ |
+
| 394 | ++ |
+ )+ |
+
| 395 | ++ |
+ )+ |
+
| 396 | ++ |
+ },+ |
+
| 397 | ++ | + + | +
| 398 | ++ |
+ # Add the y-axis annotation (top-left corner).+ |
+
| 399 | +6x | +
+ grid::gTree(+ |
+
| 400 | +6x | +
+ vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 1),+ |
+
| 401 | +6x | +
+ children = h_grob_y_annot(ylab = g_el$ylab, yaxis = g_el$yaxis)+ |
+
| 402 | ++ |
+ ),+ |
+
| 403 | ++ | + + | +
| 404 | ++ |
+ # Add the x-axis annotation (second row below the Kaplan Meier Curve).+ |
+
| 405 | +6x | +
+ grid::gTree(+ |
+
| 406 | +6x | +
+ vp = grid::viewport(layout.pos.row = 2 + ttl_row, layout.pos.col = 2),+ |
+
| 407 | +6x | +
+ children = grid::gList(rbind(g_el$xaxis, g_el$xlab))+ |
+
| 408 | ++ |
+ ),+ |
+
| 409 | ++ | + + | +
| 410 | ++ |
+ # Add the legend.+ |
+
| 411 | +6x | +
+ grid::gTree(+ |
+
| 412 | +6x | +
+ vp = grid::viewport(layout.pos.row = 3 + ttl_row, layout.pos.col = 2),+ |
+
| 413 | +6x | +
+ children = grid::gList(g_el$guide)+ |
+
| 414 | ++ |
+ ),+ |
+
| 415 | ++ | + + | +
| 416 | ++ |
+ # Add the table with patient-at-risk numbers.+ |
+
| 417 | +6x | +
+ if (annot_at_risk && annot_at_risk_title) {
+ |
+
| 418 | +6x | +
+ grid::gTree(+ |
+
| 419 | +6x | +
+ vp = grid::viewport(layout.pos.row = 4 + ttl_row, layout.pos.col = 1),+ |
+
| 420 | +6x | +
+ children = grobs_patient$title+ |
+
| 421 | ++ |
+ )+ |
+
| 422 | ++ |
+ },+ |
+
| 423 | +6x | +
+ if (annot_at_risk) {
+ |
+
| 424 | +6x | +
+ grid::gTree(+ |
+
| 425 | +6x | +
+ vp = grid::viewport(layout.pos.row = 4 + at_risk_ttl + ttl_row, layout.pos.col = 2),+ |
+
| 426 | +6x | +
+ children = grobs_patient$at_risk+ |
+
| 427 | ++ |
+ )+ |
+
| 428 | ++ |
+ },+ |
+
| 429 | +6x | +
+ if (annot_at_risk) {
+ |
+
| 430 | +6x | +
+ grid::gTree(+ |
+
| 431 | +6x | +
+ vp = grid::viewport(layout.pos.row = 4 + at_risk_ttl + ttl_row, layout.pos.col = 1),+ |
+
| 432 | +6x | +
+ children = grobs_patient$label+ |
+
| 433 | ++ |
+ )+ |
+
| 434 | ++ |
+ },+ |
+
| 435 | +6x | +
+ if (annot_at_risk) {
+ |
+
| 436 | ++ |
+ # Add the x-axis for the table.+ |
+
| 437 | +6x | +
+ grid::gTree(+ |
+
| 438 | +6x | +
+ vp = grid::viewport(layout.pos.row = 5 + at_risk_ttl + ttl_row, layout.pos.col = 2),+ |
+
| 439 | +6x | +
+ children = grid::gList(rbind(g_el$xaxis, g_el$xlab))+ |
+
| 440 | ++ |
+ )+ |
+
| 441 | ++ |
+ },+ |
+
| 442 | ++ | + + | +
| 443 | ++ |
+ # Footnotes.+ |
+
| 444 | +6x | +
+ if (foot_row == 1) {
+ |
+
| 445 | +1x | +
+ grid::gTree(+ |
+
| 446 | +1x | +
+ vp = grid::viewport(+ |
+
| 447 | +1x | +
+ layout.pos.row = ifelse(annot_at_risk, 6 + at_risk_ttl + ttl_row, 4 + ttl_row),+ |
+
| 448 | +1x | +
+ layout.pos.col = 2+ |
+
| 449 | ++ |
+ ),+ |
+
| 450 | +1x | +
+ children = grid::gList(grid::textGrob(label = footnotes, x = grid::unit(0, "npc"), hjust = 0))+ |
+
| 451 | ++ |
+ )+ |
+
| 452 | ++ |
+ }+ |
+
| 453 | ++ |
+ )+ |
+
| 454 | ++ |
+ )+ |
+
| 455 | ++ | + + | +
| 456 | +6x | +
+ result <- grid::gTree(+ |
+
| 457 | +6x | +
+ vp = vp,+ |
+
| 458 | +6x | +
+ gp = gp,+ |
+
| 459 | +6x | +
+ name = name,+ |
+
| 460 | +6x | +
+ children = grid::gList(km_grob)+ |
+
| 461 | ++ |
+ )+ |
+
| 462 | ++ |
+ } else {
+ |
+
| 463 | +2x | +
+ result <- grid::gTree(+ |
+
| 464 | +2x | +
+ vp = vp,+ |
+
| 465 | +2x | +
+ gp = gp,+ |
+
| 466 | +2x | +
+ name = name,+ |
+
| 467 | +2x | +
+ children = grid::gList(ggplot2::ggplotGrob(gg))+ |
+
| 468 | ++ |
+ )+ |
+
| 469 | ++ |
+ }+ |
+
| 470 | ++ | + + | +
| 471 | +8x | +
+ if (newpage && draw) grid::grid.newpage()+ |
+
| 472 | +8x | +
+ if (draw) grid::grid.draw(result)+ |
+
| 473 | +8x | +
+ invisible(result)+ |
+
| 474 | ++ |
+ }+ |
+
| 475 | ++ | + + | +
| 476 | ++ |
+ #' Helper function: tidy survival fit+ |
+
| 477 | ++ |
+ #'+ |
+
| 478 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 479 | ++ |
+ #'+ |
+
| 480 | ++ |
+ #' Convert the survival fit data into a data frame designed for plotting+ |
+
| 481 | ++ |
+ #' within `g_km`.+ |
+
| 482 | ++ |
+ #'+ |
+
| 483 | ++ |
+ #' This starts from the [broom::tidy()] result, and then:+ |
+
| 484 | ++ |
+ #' * Post-processes the `strata` column into a factor.+ |
+
| 485 | ++ |
+ #' * Extends each stratum by an additional first row with time 0 and probability 1 so that+ |
+
| 486 | ++ |
+ #' downstream plot lines start at those coordinates.+ |
+
| 487 | ++ |
+ #' * Adds a `censor` column.+ |
+
| 488 | ++ |
+ #' * Filters the rows before `max_time`.+ |
+
| 489 | ++ |
+ #'+ |
+
| 490 | ++ |
+ #' @inheritParams g_km+ |
+
| 491 | ++ |
+ #' @param fit_km (`survfit`)\cr result of [survival::survfit()].+ |
+
| 492 | ++ |
+ #' @param armval (`string`)\cr used as strata name when treatment arm variable only has one level. Default is `"All"`.+ |
+
| 493 | ++ |
+ #'+ |
+
| 494 | ++ |
+ #' @return A `tibble` with columns `time`, `n.risk`, `n.event`, `n.censor`, `estimate`, `std.error`, `conf.high`,+ |
+
| 495 | ++ |
+ #' `conf.low`, `strata`, and `censor`.+ |
+
| 496 | ++ |
+ #'+ |
+
| 497 | ++ |
+ #' @examples+ |
+
| 498 | ++ |
+ #' \donttest{
+ |
+
| 499 | ++ |
+ #' library(dplyr)+ |
+
| 500 | ++ |
+ #' library(survival)+ |
+
| 501 | ++ |
+ #'+ |
+
| 502 | ++ |
+ #' # Test with multiple arms+ |
+
| 503 | ++ |
+ #' tern_ex_adtte %>%+ |
+
| 504 | ++ |
+ #' filter(PARAMCD == "OS") %>%+ |
+
| 505 | ++ |
+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ |
+
| 506 | ++ |
+ #' h_data_plot()+ |
+
| 507 | ++ |
+ #'+ |
+
| 508 | ++ |
+ #' # Test with single arm+ |
+
| 509 | ++ |
+ #' tern_ex_adtte %>%+ |
+
| 510 | ++ |
+ #' filter(PARAMCD == "OS", ARMCD == "ARM B") %>%+ |
+
| 511 | ++ |
+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ |
+
| 512 | ++ |
+ #' h_data_plot(armval = "ARM B")+ |
+
| 513 | ++ |
+ #' }+ |
+
| 514 | ++ |
+ #'+ |
+
| 515 | ++ |
+ #' @export+ |
+
| 516 | ++ |
+ h_data_plot <- function(fit_km,+ |
+
| 517 | ++ |
+ armval = "All",+ |
+
| 518 | ++ |
+ max_time = NULL) {
+ |
+
| 519 | +15x | +
+ y <- broom::tidy(fit_km)+ |
+
| 520 | ++ | + + | +
| 521 | +15x | +
+ if (!is.null(fit_km$strata)) {
+ |
+
| 522 | +15x | +
+ fit_km_var_level <- strsplit(sub("=", "equals", names(fit_km$strata)), "equals")
+ |
+
| 523 | +15x | +
+ strata_levels <- vapply(fit_km_var_level, FUN = "[", FUN.VALUE = "a", i = 2)+ |
+
| 524 | +15x | +
+ strata_var_level <- strsplit(sub("=", "equals", y$strata), "equals")
+ |
+
| 525 | +15x | +
+ y$strata <- factor(+ |
+
| 526 | +15x | +
+ vapply(strata_var_level, FUN = "[", FUN.VALUE = "a", i = 2),+ |
+
| 527 | +15x | +
+ levels = strata_levels+ |
+
| 528 | ++ |
+ )+ |
+
| 529 | ++ |
+ } else {
+ |
+
| 530 | +! | +
+ y$strata <- armval+ |
+
| 531 | ++ |
+ }+ |
+
| 532 | ++ | + + | +
| 533 | +15x | +
+ y_by_strata <- split(y, y$strata)+ |
+
| 534 | +15x | +
+ y_by_strata_extended <- lapply(+ |
+
| 535 | +15x | +
+ y_by_strata,+ |
+
| 536 | +15x | +
+ FUN = function(tbl) {
+ |
+
| 537 | +44x | +
+ first_row <- tbl[1L, ]+ |
+
| 538 | +44x | +
+ first_row$time <- 0+ |
+
| 539 | +44x | +
+ first_row$n.risk <- sum(first_row[, c("n.risk", "n.event", "n.censor")])
+ |
+
| 540 | +44x | +
+ first_row$n.event <- first_row$n.censor <- 0+ |
+
| 541 | +44x | +
+ first_row$estimate <- first_row$conf.high <- first_row$conf.low <- 1+ |
+
| 542 | +44x | +
+ first_row$std.error <- 0+ |
+
| 543 | +44x | +
+ rbind(+ |
+
| 544 | +44x | +
+ first_row,+ |
+
| 545 | +44x | +
+ tbl+ |
+
| 546 | ++ |
+ )+ |
+
| 547 | ++ |
+ }+ |
+
| 548 | ++ |
+ )+ |
+
| 549 | +15x | +
+ y <- do.call(rbind, y_by_strata_extended)+ |
+
| 550 | ++ | + + | +
| 551 | +15x | +
+ y$censor <- ifelse(y$n.censor > 0, y$estimate, NA)+ |
+
| 552 | +15x | +
+ if (!is.null(max_time)) {
+ |
+
| 553 | +3x | +
+ y <- y[y$time <= max(max_time), ]+ |
+
| 554 | ++ |
+ }+ |
+
| 555 | +15x | +
+ y+ |
+
| 556 | ++ |
+ }+ |
+
| 557 | ++ | + + | +
| 558 | ++ |
+ #' Helper function: x tick positions+ |
+
| 559 | ++ |
+ #'+ |
+
| 560 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 561 | ++ |
+ #'+ |
+
| 562 | ++ |
+ #' Calculate the positions of ticks on the x-axis. However, if `xticks` already+ |
+
| 563 | ++ |
+ #' exists it is kept as is. It is based on the same function `ggplot2` relies on,+ |
+
| 564 | ++ |
+ #' and is required in the graphic and the patient-at-risk annotation table.+ |
+
| 565 | ++ |
+ #'+ |
+
| 566 | ++ |
+ #' @inheritParams g_km+ |
+
| 567 | ++ |
+ #' @inheritParams h_ggkm+ |
+
| 568 | ++ |
+ #'+ |
+
| 569 | ++ |
+ #' @return A vector of positions to use for x-axis ticks on a `ggplot` object.+ |
+
| 570 | ++ |
+ #'+ |
+
| 571 | ++ |
+ #' @examples+ |
+
| 572 | ++ |
+ #' \donttest{
+ |
+
| 573 | ++ |
+ #' library(dplyr)+ |
+
| 574 | ++ |
+ #' library(survival)+ |
+
| 575 | ++ |
+ #'+ |
+
| 576 | ++ |
+ #' data <- tern_ex_adtte %>%+ |
+
| 577 | ++ |
+ #' filter(PARAMCD == "OS") %>%+ |
+
| 578 | ++ |
+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ |
+
| 579 | ++ |
+ #' h_data_plot()+ |
+
| 580 | ++ |
+ #'+ |
+
| 581 | ++ |
+ #' h_xticks(data)+ |
+
| 582 | ++ |
+ #' h_xticks(data, xticks = seq(0, 3000, 500))+ |
+
| 583 | ++ |
+ #' h_xticks(data, xticks = 500)+ |
+
| 584 | ++ |
+ #' h_xticks(data, xticks = 500, max_time = 6000)+ |
+
| 585 | ++ |
+ #' h_xticks(data, xticks = c(0, 500), max_time = 300)+ |
+
| 586 | ++ |
+ #' h_xticks(data, xticks = 500, max_time = 300)+ |
+
| 587 | ++ |
+ #' }+ |
+
| 588 | ++ |
+ #'+ |
+
| 589 | ++ |
+ #' @export+ |
+
| 590 | ++ |
+ h_xticks <- function(data, xticks = NULL, max_time = NULL) {
+ |
+
| 591 | +15x | +
+ if (is.null(xticks)) {
+ |
+
| 592 | +9x | +
+ if (is.null(max_time)) {
+ |
+
| 593 | +7x | +
+ labeling::extended(range(data$time)[1], range(data$time)[2], m = 5)+ |
+
| 594 | ++ |
+ } else {
+ |
+
| 595 | +2x | +
+ labeling::extended(range(data$time)[1], max(range(data$time)[2], max_time), m = 5)+ |
+
| 596 | ++ |
+ }+ |
+
| 597 | +6x | +
+ } else if (checkmate::test_number(xticks)) {
+ |
+
| 598 | +3x | +
+ if (is.null(max_time)) {
+ |
+
| 599 | +2x | +
+ seq(0, max(data$time), xticks)+ |
+
| 600 | ++ |
+ } else {
+ |
+
| 601 | +1x | +
+ seq(0, max(data$time, max_time), xticks)+ |
+
| 602 | ++ |
+ }+ |
+
| 603 | +3x | +
+ } else if (is.numeric(xticks)) {
+ |
+
| 604 | +2x | +
+ xticks+ |
+
| 605 | ++ |
+ } else {
+ |
+
| 606 | +1x | +
+ stop(+ |
+
| 607 | +1x | +
+ paste(+ |
+
| 608 | +1x | +
+ "xticks should be either `NULL`",+ |
+
| 609 | +1x | +
+ "or a single number (interval between x ticks)",+ |
+
| 610 | +1x | +
+ "or a numeric vector (position of ticks on the x axis)"+ |
+
| 611 | ++ |
+ )+ |
+
| 612 | ++ |
+ )+ |
+
| 613 | ++ |
+ }+ |
+
| 614 | ++ |
+ }+ |
+
| 615 | ++ | + + | +
| 616 | ++ |
+ #' Helper function: KM plot+ |
+
| 617 | ++ |
+ #'+ |
+
| 618 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 619 | ++ |
+ #'+ |
+
| 620 | ++ |
+ #' Draw the Kaplan-Meier plot using `ggplot2`.+ |
+
| 621 | ++ |
+ #'+ |
+
| 622 | ++ |
+ #' @inheritParams g_km+ |
+
| 623 | ++ |
+ #' @param data (`data.frame`)\cr survival data as pre-processed by `h_data_plot`.+ |
+
| 624 | ++ |
+ #'+ |
+
| 625 | ++ |
+ #' @return A `ggplot` object.+ |
+
| 626 | ++ |
+ #'+ |
+
| 627 | ++ |
+ #' @examples+ |
+
| 628 | ++ |
+ #' \donttest{
+ |
+
| 629 | ++ |
+ #' library(dplyr)+ |
+
| 630 | ++ |
+ #' library(survival)+ |
+
| 631 | ++ |
+ #'+ |
+
| 632 | ++ |
+ #' fit_km <- tern_ex_adtte %>%+ |
+
| 633 | ++ |
+ #' filter(PARAMCD == "OS") %>%+ |
+
| 634 | ++ |
+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ |
+
| 635 | ++ |
+ #' data_plot <- h_data_plot(fit_km = fit_km)+ |
+
| 636 | ++ |
+ #' xticks <- h_xticks(data = data_plot)+ |
+
| 637 | ++ |
+ #' gg <- h_ggkm(+ |
+
| 638 | ++ |
+ #' data = data_plot,+ |
+
| 639 | ++ |
+ #' censor_show = TRUE,+ |
+
| 640 | ++ |
+ #' xticks = xticks,+ |
+
| 641 | ++ |
+ #' xlab = "Days",+ |
+
| 642 | ++ |
+ #' yval = "Survival",+ |
+
| 643 | ++ |
+ #' ylab = "Survival Probability",+ |
+
| 644 | ++ |
+ #' title = "Survival"+ |
+
| 645 | ++ |
+ #' )+ |
+
| 646 | ++ |
+ #' gg+ |
+
| 647 | ++ |
+ #' }+ |
+
| 648 | ++ |
+ #'+ |
+
| 649 | ++ |
+ #' @export+ |
+
| 650 | ++ |
+ h_ggkm <- function(data,+ |
+
| 651 | ++ |
+ xticks = NULL,+ |
+
| 652 | ++ |
+ yval = "Survival",+ |
+
| 653 | ++ |
+ censor_show,+ |
+
| 654 | ++ |
+ xlab,+ |
+
| 655 | ++ |
+ ylab,+ |
+
| 656 | ++ |
+ ylim = NULL,+ |
+
| 657 | ++ |
+ title,+ |
+
| 658 | ++ |
+ footnotes = NULL,+ |
+
| 659 | ++ |
+ max_time = NULL,+ |
+
| 660 | ++ |
+ lwd = 1,+ |
+
| 661 | ++ |
+ lty = NULL,+ |
+
| 662 | ++ |
+ pch = 3,+ |
+
| 663 | ++ |
+ size = 2,+ |
+
| 664 | ++ |
+ col = NULL,+ |
+
| 665 | ++ |
+ ci_ribbon = FALSE,+ |
+
| 666 | ++ |
+ ggtheme = nestcolor::theme_nest()) {
+ |
+
| 667 | +8x | +
+ checkmate::assert_numeric(lty, null.ok = TRUE)+ |
+
| 668 | +8x | +
+ checkmate::assert_character(col, null.ok = TRUE)+ |
+
| 669 | ++ | + + | +
| 670 | +8x | +
+ if (is.null(ylim)) {
+ |
+
| 671 | +8x | +
+ data_lims <- data+ |
+
| 672 | +1x | +
+ if (yval == "Failure") data_lims[["estimate"]] <- 1 - data_lims[["estimate"]]+ |
+
| 673 | +8x | +
+ if (!is.null(max_time)) {
+ |
+
| 674 | +1x | +
+ y_lwr <- min(data_lims[data_lims$time < max_time, ][["estimate"]])+ |
+
| 675 | +1x | +
+ y_upr <- max(data_lims[data_lims$time < max_time, ][["estimate"]])+ |
+
| 676 | ++ |
+ } else {
+ |
+
| 677 | +7x | +
+ y_lwr <- min(data_lims[["estimate"]])+ |
+
| 678 | +7x | +
+ y_upr <- max(data_lims[["estimate"]])+ |
+
| 679 | ++ |
+ }+ |
+
| 680 | +8x | +
+ ylim <- c(y_lwr, y_upr)+ |
+
| 681 | ++ |
+ }+ |
+
| 682 | +8x | +
+ checkmate::assert_numeric(ylim, finite = TRUE, any.missing = FALSE, len = 2, sorted = TRUE)+ |
+
| 683 | ++ | + + | +
| 684 | ++ |
+ # change estimates of survival to estimates of failure (1 - survival)+ |
+
| 685 | +8x | +
+ if (yval == "Failure") {
+ |
+
| 686 | +1x | +
+ data$estimate <- 1 - data$estimate+ |
+
| 687 | +1x | +
+ data[c("conf.high", "conf.low")] <- list(1 - data$conf.low, 1 - data$conf.high)
+ |
+
| 688 | +1x | +
+ data$censor <- 1 - data$censor+ |
+
| 689 | ++ |
+ }+ |
+
| 690 | ++ | + + | +
| 691 | +8x | +
+ gg <- {
+ |
+
| 692 | +8x | +
+ ggplot2::ggplot(+ |
+
| 693 | +8x | +
+ data = data,+ |
+
| 694 | +8x | +
+ mapping = ggplot2::aes(+ |
+
| 695 | +8x | +
+ x = .data[["time"]],+ |
+
| 696 | +8x | +
+ y = .data[["estimate"]],+ |
+
| 697 | +8x | +
+ ymin = .data[["conf.low"]],+ |
+
| 698 | +8x | +
+ ymax = .data[["conf.high"]],+ |
+
| 699 | +8x | +
+ color = .data[["strata"]],+ |
+
| 700 | +8x | +
+ fill = .data[["strata"]]+ |
+
| 701 | ++ |
+ )+ |
+
| 702 | ++ |
+ ) ++ |
+
| 703 | +8x | +
+ ggplot2::geom_hline(yintercept = 0)+ |
+
| 704 | ++ |
+ }+ |
+
| 705 | ++ | + + | +
| 706 | +8x | +
+ if (ci_ribbon) {
+ |
+
| 707 | +1x | +
+ gg <- gg + ggplot2::geom_ribbon(alpha = .3, lty = 0)+ |
+
| 708 | ++ |
+ }+ |
+
| 709 | ++ | + + | +
| 710 | +8x | +
+ gg <- if (is.null(lty)) {
+ |
+
| 711 | +7x | +
+ gg ++ |
+
| 712 | +7x | +
+ ggplot2::geom_step(linewidth = lwd)+ |
+
| 713 | +8x | +
+ } else if (checkmate::test_number(lty)) {
+ |
+
| 714 | +1x | +
+ gg ++ |
+
| 715 | +1x | +
+ ggplot2::geom_step(linewidth = lwd, lty = lty)+ |
+
| 716 | +8x | +
+ } else if (is.numeric(lty)) {
+ |
+
| 717 | +! | +
+ gg ++ |
+
| 718 | +! | +
+ ggplot2::geom_step(mapping = ggplot2::aes(linetype = .data[["strata"]]), linewidth = lwd) ++ |
+
| 719 | +! | +
+ ggplot2::scale_linetype_manual(values = lty)+ |
+
| 720 | ++ |
+ }+ |
+
| 721 | ++ | + + | +
| 722 | +8x | +
+ gg <- gg ++ |
+
| 723 | +8x | +
+ ggplot2::coord_cartesian(ylim = ylim) ++ |
+
| 724 | +8x | +
+ ggplot2::labs(x = xlab, y = ylab, title = title, caption = footnotes)+ |
+
| 725 | ++ | + + | +
| 726 | +8x | +
+ if (!is.null(col)) {
+ |
+
| 727 | +! | +
+ gg <- gg ++ |
+
| 728 | +! | +
+ ggplot2::scale_color_manual(values = col) ++ |
+
| 729 | +! | +
+ ggplot2::scale_fill_manual(values = col)+ |
+
| 730 | ++ |
+ }+ |
+
| 731 | +8x | +
+ if (censor_show) {
+ |
+
| 732 | +8x | +
+ dt <- data[data$n.censor != 0, ]+ |
+
| 733 | +8x | +
+ dt$censor_lbl <- factor("Censored")
+ |
+
| 734 | ++ | + + | +
| 735 | +8x | +
+ gg <- gg + ggplot2::geom_point(+ |
+
| 736 | +8x | +
+ data = dt,+ |
+
| 737 | +8x | +
+ ggplot2::aes(+ |
+
| 738 | +8x | +
+ x = .data[["time"]],+ |
+
| 739 | +8x | +
+ y = .data[["censor"]],+ |
+
| 740 | +8x | +
+ shape = .data[["censor_lbl"]]+ |
+
| 741 | ++ |
+ ),+ |
+
| 742 | +8x | +
+ size = size,+ |
+
| 743 | +8x | +
+ show.legend = TRUE,+ |
+
| 744 | +8x | +
+ inherit.aes = TRUE+ |
+
| 745 | ++ |
+ ) ++ |
+
| 746 | +8x | +
+ ggplot2::scale_shape_manual(name = NULL, values = pch) ++ |
+
| 747 | +8x | +
+ ggplot2::guides(+ |
+
| 748 | +8x | +
+ shape = ggplot2::guide_legend(override.aes = list(linetype = NA)),+ |
+
| 749 | +8x | +
+ fill = ggplot2::guide_legend(override.aes = list(shape = NA))+ |
+
| 750 | ++ |
+ )+ |
+
| 751 | ++ |
+ }+ |
+
| 752 | ++ | + + | +
| 753 | +8x | +
+ if (!is.null(max_time) && !is.null(xticks)) {
+ |
+
| 754 | +1x | +
+ gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, xticks), max(c(xticks, max_time))))+ |
+
| 755 | +7x | +
+ } else if (!is.null(xticks)) {
+ |
+
| 756 | +7x | +
+ if (max(data$time) <= max(xticks)) {
+ |
+
| 757 | +6x | +
+ gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, min(xticks)), max(xticks)))+ |
+
| 758 | ++ |
+ } else {
+ |
+
| 759 | +1x | +
+ gg <- gg + ggplot2::scale_x_continuous(breaks = xticks)+ |
+
| 760 | ++ |
+ }+ |
+
| 761 | +! | +
+ } else if (!is.null(max_time)) {
+ |
+
| 762 | +! | +
+ gg <- gg + ggplot2::scale_x_continuous(limits = c(0, max_time))+ |
+
| 763 | ++ |
+ }+ |
+
| 764 | ++ | + + | +
| 765 | +8x | +
+ if (!is.null(ggtheme)) {
+ |
+
| 766 | +8x | +
+ gg <- gg + ggtheme+ |
+
| 767 | ++ |
+ }+ |
+
| 768 | ++ | + + | +
| 769 | +8x | +
+ gg + ggplot2::theme(+ |
+
| 770 | +8x | +
+ legend.position = "bottom",+ |
+
| 771 | +8x | +
+ legend.title = ggplot2::element_blank(),+ |
+
| 772 | +8x | +
+ legend.key.height = unit(0.02, "npc"),+ |
+
| 773 | +8x | +
+ panel.grid.major.x = ggplot2::element_line(linewidth = 2)+ |
+
| 774 | ++ |
+ )+ |
+
| 775 | ++ |
+ }+ |
+
| 776 | ++ | + + | +
| 777 | ++ |
+ #' `ggplot` Decomposition+ |
+
| 778 | ++ |
+ #'+ |
+
| 779 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 780 | ++ |
+ #'+ |
+
| 781 | ++ |
+ #' The elements composing the `ggplot` are extracted and organized in a `list`.+ |
+
| 782 | ++ |
+ #'+ |
+
| 783 | ++ |
+ #' @param gg (`ggplot`)\cr a graphic to decompose.+ |
+
| 784 | ++ |
+ #'+ |
+
| 785 | ++ |
+ #' @return A named `list` with elements:+ |
+
| 786 | ++ |
+ #' * `panel`: The panel.+ |
+
| 787 | ++ |
+ #' * `yaxis`: The y-axis.+ |
+
| 788 | ++ |
+ #' * `xaxis`: The x-axis.+ |
+
| 789 | ++ |
+ #' * `xlab`: The x-axis label.+ |
+
| 790 | ++ |
+ #' * `ylab`: The y-axis label.+ |
+
| 791 | ++ |
+ #' * `guide`: The legend.+ |
+
| 792 | ++ |
+ #'+ |
+
| 793 | ++ |
+ #' @examples+ |
+
| 794 | ++ |
+ #' \donttest{
+ |
+
| 795 | ++ |
+ #' library(dplyr)+ |
+
| 796 | ++ |
+ #' library(survival)+ |
+
| 797 | ++ |
+ #' library(grid)+ |
+
| 798 | ++ |
+ #'+ |
+
| 799 | ++ |
+ #' fit_km <- tern_ex_adtte %>%+ |
+
| 800 | ++ |
+ #' filter(PARAMCD == "OS") %>%+ |
+
| 801 | ++ |
+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ |
+
| 802 | ++ |
+ #' data_plot <- h_data_plot(fit_km = fit_km)+ |
+
| 803 | ++ |
+ #' xticks <- h_xticks(data = data_plot)+ |
+
| 804 | ++ |
+ #' gg <- h_ggkm(+ |
+
| 805 | ++ |
+ #' data = data_plot,+ |
+
| 806 | ++ |
+ #' yval = "Survival",+ |
+
| 807 | ++ |
+ #' censor_show = TRUE,+ |
+
| 808 | ++ |
+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ |
+
| 809 | ++ |
+ #' title = "tt",+ |
+
| 810 | ++ |
+ #' footnotes = "ff"+ |
+
| 811 | ++ |
+ #' )+ |
+
| 812 | ++ |
+ #'+ |
+
| 813 | ++ |
+ #' g_el <- h_decompose_gg(gg)+ |
+
| 814 | ++ |
+ #' grid::grid.newpage()+ |
+
| 815 | ++ |
+ #' grid.rect(gp = grid::gpar(lty = 1, col = "red", fill = "gray85", lwd = 5))+ |
+
| 816 | ++ |
+ #' grid::grid.draw(g_el$panel)+ |
+
| 817 | ++ |
+ #'+ |
+
| 818 | ++ |
+ #' grid::grid.newpage()+ |
+
| 819 | ++ |
+ #' grid.rect(gp = grid::gpar(lty = 1, col = "royalblue", fill = "gray85", lwd = 5))+ |
+
| 820 | ++ |
+ #' grid::grid.draw(with(g_el, cbind(ylab, yaxis)))+ |
+
| 821 | ++ |
+ #' }+ |
+
| 822 | ++ |
+ #'+ |
+
| 823 | ++ |
+ #' @export+ |
+
| 824 | ++ |
+ h_decompose_gg <- function(gg) {
+ |
+
| 825 | +8x | +
+ g_el <- ggplot2::ggplotGrob(gg)+ |
+
| 826 | +8x | +
+ y <- c(+ |
+
| 827 | +8x | +
+ panel = "panel",+ |
+
| 828 | +8x | +
+ yaxis = "axis-l",+ |
+
| 829 | +8x | +
+ xaxis = "axis-b",+ |
+
| 830 | +8x | +
+ xlab = "xlab-b",+ |
+
| 831 | +8x | +
+ ylab = "ylab-l",+ |
+
| 832 | +8x | +
+ guide = "guide"+ |
+
| 833 | ++ |
+ )+ |
+
| 834 | +8x | +
+ lapply(X = y, function(x) gtable::gtable_filter(g_el, x))+ |
+
| 835 | ++ |
+ }+ |
+
| 836 | ++ | + + | +
| 837 | ++ |
+ #' Helper: KM Layout+ |
+
| 838 | ++ |
+ #'+ |
+
| 839 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 840 | ++ |
+ #'+ |
+
| 841 | ++ |
+ #' Prepares a (5 rows) x (2 cols) layout for the Kaplan-Meier curve.+ |
+
| 842 | ++ |
+ #'+ |
+
| 843 | ++ |
+ #' @inheritParams g_km+ |
+
| 844 | ++ |
+ #' @inheritParams h_ggkm+ |
+
| 845 | ++ |
+ #' @param g_el (`list` of `gtable`)\cr list as obtained by `h_decompose_gg()`.+ |
+
| 846 | ++ |
+ #' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of+ |
+
| 847 | ++ |
+ #' patient at risk matching the main grid of the Kaplan-Meier curve.+ |
+
| 848 | ++ |
+ #'+ |
+
| 849 | ++ |
+ #' @return A grid layout.+ |
+
| 850 | ++ |
+ #'+ |
+
| 851 | ++ |
+ #' @details The layout corresponds to a grid of two columns and five rows of unequal dimensions. Most of the+ |
+
| 852 | ++ |
+ #' dimension are fixed, only the curve is flexible and will accommodate with the remaining free space.+ |
+
| 853 | ++ |
+ #' * The left column gets the annotation of the `ggplot` (y-axis) and the names of the strata for the patient+ |
+
| 854 | ++ |
+ #' at risk tabulation. The main constraint is about the width of the columns which must allow the writing of+ |
+
| 855 | ++ |
+ #' the strata name.+ |
+
| 856 | ++ |
+ #' * The right column receive the `ggplot`, the legend, the x-axis and the patient at risk table.+ |
+
| 857 | ++ |
+ #'+ |
+
| 858 | ++ |
+ #' @examples+ |
+
| 859 | ++ |
+ #' \donttest{
+ |
+
| 860 | ++ |
+ #' library(dplyr)+ |
+
| 861 | ++ |
+ #' library(survival)+ |
+
| 862 | ++ |
+ #' library(grid)+ |
+
| 863 | ++ |
+ #'+ |
+
| 864 | ++ |
+ #' fit_km <- tern_ex_adtte %>%+ |
+
| 865 | ++ |
+ #' filter(PARAMCD == "OS") %>%+ |
+
| 866 | ++ |
+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ |
+
| 867 | ++ |
+ #' data_plot <- h_data_plot(fit_km = fit_km)+ |
+
| 868 | ++ |
+ #' xticks <- h_xticks(data = data_plot)+ |
+
| 869 | ++ |
+ #' gg <- h_ggkm(+ |
+
| 870 | ++ |
+ #' data = data_plot,+ |
+
| 871 | ++ |
+ #' censor_show = TRUE,+ |
+
| 872 | ++ |
+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ |
+
| 873 | ++ |
+ #' title = "tt", footnotes = "ff", yval = "Survival"+ |
+
| 874 | ++ |
+ #' )+ |
+
| 875 | ++ |
+ #' g_el <- h_decompose_gg(gg)+ |
+
| 876 | ++ |
+ #' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f")+ |
+
| 877 | ++ |
+ #' grid.show.layout(lyt)+ |
+
| 878 | ++ |
+ #' }+ |
+
| 879 | ++ |
+ #'+ |
+
| 880 | ++ |
+ #' @export+ |
+
| 881 | ++ |
+ h_km_layout <- function(data, g_el, title, footnotes, annot_at_risk = TRUE, annot_at_risk_title = TRUE) {
+ |
+
| 882 | +6x | +
+ txtlines <- levels(as.factor(data$strata))+ |
+
| 883 | +6x | +
+ nlines <- nlevels(as.factor(data$strata))+ |
+
| 884 | +6x | +
+ col_annot_width <- max(+ |
+
| 885 | +6x | +
+ c(+ |
+
| 886 | +6x | +
+ as.numeric(grid::convertX(g_el$yaxis$width + g_el$ylab$width, "pt")),+ |
+
| 887 | +6x | +
+ as.numeric(+ |
+
| 888 | +6x | +
+ grid::convertX(+ |
+
| 889 | +6x | +
+ grid::stringWidth(txtlines) + grid::unit(7, "pt"), "pt"+ |
+
| 890 | ++ |
+ )+ |
+
| 891 | ++ |
+ )+ |
+
| 892 | ++ |
+ )+ |
+
| 893 | ++ |
+ )+ |
+
| 894 | ++ | + + | +
| 895 | +6x | +
+ ttl_row <- as.numeric(!is.null(title))+ |
+
| 896 | +6x | +
+ foot_row <- as.numeric(!is.null(footnotes))+ |
+
| 897 | +6x | +
+ no_tbl_ind <- c()+ |
+
| 898 | +6x | +
+ ht_x <- c()+ |
+
| 899 | +6x | +
+ ht_units <- c()+ |
+
| 900 | ++ | + + | +
| 901 | +6x | +
+ if (ttl_row == 1) {
+ |
+
| 902 | +1x | +
+ no_tbl_ind <- c(no_tbl_ind, TRUE)+ |
+
| 903 | +1x | +
+ ht_x <- c(ht_x, 2)+ |
+
| 904 | +1x | +
+ ht_units <- c(ht_units, "lines")+ |
+
| 905 | ++ |
+ }+ |
+
| 906 | ++ | + + | +
| 907 | +6x | +
+ no_tbl_ind <- c(no_tbl_ind, rep(TRUE, 3), rep(FALSE, 2))+ |
+
| 908 | +6x | +
+ ht_x <- c(+ |
+
| 909 | +6x | +
+ ht_x,+ |
+
| 910 | +6x | +
+ 1,+ |
+
| 911 | +6x | +
+ grid::convertX(with(g_el, xaxis$height + ylab$width), "pt") + grid::unit(5, "pt"),+ |
+
| 912 | +6x | +
+ grid::convertX(g_el$guide$heights, "pt") + grid::unit(2, "pt"),+ |
+
| 913 | +6x | +
+ 1,+ |
+
| 914 | +6x | +
+ nlines + 0.5,+ |
+
| 915 | +6x | +
+ grid::convertX(with(g_el, xaxis$height + ylab$width), "pt")+ |
+
| 916 | ++ |
+ )+ |
+
| 917 | +6x | +
+ ht_units <- c(+ |
+
| 918 | +6x | +
+ ht_units,+ |
+
| 919 | +6x | +
+ "null",+ |
+
| 920 | +6x | +
+ "pt",+ |
+
| 921 | +6x | +
+ "pt",+ |
+
| 922 | +6x | +
+ "lines",+ |
+
| 923 | +6x | +
+ "lines",+ |
+
| 924 | +6x | +
+ "pt"+ |
+
| 925 | ++ |
+ )+ |
+
| 926 | ++ | + + | +
| 927 | +6x | +
+ if (foot_row == 1) {
+ |
+
| 928 | +1x | +
+ no_tbl_ind <- c(no_tbl_ind, TRUE)+ |
+
| 929 | +1x | +
+ ht_x <- c(ht_x, 1)+ |
+
| 930 | +1x | +
+ ht_units <- c(ht_units, "lines")+ |
+
| 931 | ++ |
+ }+ |
+
| 932 | +6x | +
+ if (annot_at_risk) {
+ |
+
| 933 | +6x | +
+ no_at_risk_tbl <- rep(TRUE, 6 + ttl_row + foot_row)+ |
+
| 934 | +6x | +
+ if (!annot_at_risk_title) {
+ |
+
| 935 | +! | +
+ no_at_risk_tbl[length(no_at_risk_tbl) - 2 - foot_row] <- FALSE+ |
+
| 936 | ++ |
+ }+ |
+
| 937 | ++ |
+ } else {
+ |
+
| 938 | +! | +
+ no_at_risk_tbl <- no_tbl_ind+ |
+
| 939 | ++ |
+ }+ |
+
| 940 | ++ | + + | +
| 941 | +6x | +
+ grid::grid.layout(+ |
+
| 942 | +6x | +
+ nrow = sum(no_at_risk_tbl), ncol = 2,+ |
+
| 943 | +6x | +
+ widths = grid::unit(c(col_annot_width, 1), c("pt", "null")),
+ |
+
| 944 | +6x | +
+ heights = grid::unit(+ |
+
| 945 | +6x | +
+ x = ht_x[no_at_risk_tbl],+ |
+
| 946 | +6x | +
+ units = ht_units[no_at_risk_tbl]+ |
+
| 947 | ++ |
+ )+ |
+
| 948 | ++ |
+ )+ |
+
| 949 | ++ |
+ }+ |
+
| 950 | ++ | + + | +
| 951 | ++ |
+ #' Helper: Patient-at-Risk Grobs+ |
+
| 952 | ++ |
+ #'+ |
+
| 953 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 954 | ++ |
+ #'+ |
+
| 955 | ++ |
+ #' Two graphical objects are obtained, one corresponding to row labeling and the second to the table of+ |
+
| 956 | ++ |
+ #' numbers of patients at risk. If `title = TRUE`, a third object corresponding to the table title is+ |
+
| 957 | ++ |
+ #' also obtained.+ |
+
| 958 | ++ |
+ #'+ |
+
| 959 | ++ |
+ #' @inheritParams g_km+ |
+
| 960 | ++ |
+ #' @inheritParams h_ggkm+ |
+
| 961 | ++ |
+ #' @param annot_tbl (`data.frame`)\cr annotation as prepared by [survival::summary.survfit()] which+ |
+
| 962 | ++ |
+ #' includes the number of patients at risk at given time points.+ |
+
| 963 | ++ |
+ #' @param xlim (`numeric`)\cr the maximum value on the x-axis (used to+ |
+
| 964 | ++ |
+ #' ensure the at risk table aligns with the KM graph).+ |
+
| 965 | ++ |
+ #' @param title (`flag`)\cr whether the "Patients at Risk" title should be added above the `annot_at_risk`+ |
+
| 966 | ++ |
+ #' table. Has no effect if `annot_at_risk` is `FALSE`. Defaults to `TRUE`.+ |
+
| 967 | ++ |
+ #'+ |
+
| 968 | ++ |
+ #' @return A named `list` of two `gTree` objects if `title = FALSE`: `at_risk` and `label`, or three+ |
+
| 969 | ++ |
+ #' `gTree` objects if `title = TRUE`: `at_risk`, `label`, and `title`.+ |
+
| 970 | ++ |
+ #'+ |
+
| 971 | ++ |
+ #' @examples+ |
+
| 972 | ++ |
+ #' \donttest{
+ |
+
| 973 | ++ |
+ #' library(dplyr)+ |
+
| 974 | ++ |
+ #' library(survival)+ |
+
| 975 | ++ |
+ #' library(grid)+ |
+
| 976 | ++ |
+ #'+ |
+
| 977 | ++ |
+ #' fit_km <- tern_ex_adtte %>%+ |
+
| 978 | ++ |
+ #' filter(PARAMCD == "OS") %>%+ |
+
| 979 | ++ |
+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ |
+
| 980 | ++ |
+ #'+ |
+
| 981 | ++ |
+ #' data_plot <- h_data_plot(fit_km = fit_km)+ |
+
| 982 | ++ |
+ #'+ |
+
| 983 | ++ |
+ #' xticks <- h_xticks(data = data_plot)+ |
+
| 984 | ++ |
+ #'+ |
+
| 985 | ++ |
+ #' gg <- h_ggkm(+ |
+
| 986 | ++ |
+ #' data = data_plot,+ |
+
| 987 | ++ |
+ #' censor_show = TRUE,+ |
+
| 988 | ++ |
+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ |
+
| 989 | ++ |
+ #' title = "tt", footnotes = "ff", yval = "Survival"+ |
+
| 990 | ++ |
+ #' )+ |
+
| 991 | ++ |
+ #'+ |
+
| 992 | ++ |
+ #' # The annotation table reports the patient at risk for a given strata and+ |
+
| 993 | ++ |
+ #' # time (`xticks`).+ |
+
| 994 | ++ |
+ #' annot_tbl <- summary(fit_km, time = xticks)+ |
+
| 995 | ++ |
+ #' if (is.null(fit_km$strata)) {
+ |
+
| 996 | ++ |
+ #' annot_tbl <- with(annot_tbl, data.frame(n.risk = n.risk, time = time, strata = "All"))+ |
+
| 997 | ++ |
+ #' } else {
+ |
+
| 998 | ++ |
+ #' strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
+ |
+
| 999 | ++ |
+ #' levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2]+ |
+
| 1000 | ++ |
+ #' annot_tbl <- data.frame(+ |
+
| 1001 | ++ |
+ #' n.risk = annot_tbl$n.risk,+ |
+
| 1002 | ++ |
+ #' time = annot_tbl$time,+ |
+
| 1003 | ++ |
+ #' strata = annot_tbl$strata+ |
+
| 1004 | ++ |
+ #' )+ |
+
| 1005 | ++ |
+ #' }+ |
+
| 1006 | ++ |
+ #'+ |
+
| 1007 | ++ |
+ #' # The annotation table is transformed into a grob.+ |
+
| 1008 | ++ |
+ #' tbl <- h_grob_tbl_at_risk(data = data_plot, annot_tbl = annot_tbl, xlim = max(xticks))+ |
+
| 1009 | ++ |
+ #'+ |
+
| 1010 | ++ |
+ #' # For the representation, the layout is estimated for which the decomposition+ |
+
| 1011 | ++ |
+ #' # of the graphic element is necessary.+ |
+
| 1012 | ++ |
+ #' g_el <- h_decompose_gg(gg)+ |
+
| 1013 | ++ |
+ #' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f")+ |
+
| 1014 | ++ |
+ #'+ |
+
| 1015 | ++ |
+ #' grid::grid.newpage()+ |
+
| 1016 | ++ |
+ #' pushViewport(viewport(layout = lyt, height = .95, width = .95))+ |
+
| 1017 | ++ |
+ #' grid.rect(gp = grid::gpar(lty = 1, col = "purple", fill = "gray85", lwd = 1))+ |
+
| 1018 | ++ |
+ #' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 2))+ |
+
| 1019 | ++ |
+ #' grid.rect(gp = grid::gpar(lty = 1, col = "orange", fill = "gray85", lwd = 1))+ |
+
| 1020 | ++ |
+ #' grid::grid.draw(tbl$at_risk)+ |
+
| 1021 | ++ |
+ #' popViewport()+ |
+
| 1022 | ++ |
+ #' pushViewport(viewport(layout.pos.row = 3:4, layout.pos.col = 1))+ |
+
| 1023 | ++ |
+ #' grid.rect(gp = grid::gpar(lty = 1, col = "green3", fill = "gray85", lwd = 1))+ |
+
| 1024 | ++ |
+ #' grid::grid.draw(tbl$label)+ |
+
| 1025 | ++ |
+ #' }+ |
+
| 1026 | ++ |
+ #'+ |
+
| 1027 | ++ |
+ #' @export+ |
+
| 1028 | ++ |
+ h_grob_tbl_at_risk <- function(data, annot_tbl, xlim, title = TRUE) {
+ |
+
| 1029 | +6x | +
+ txtlines <- levels(as.factor(data$strata))+ |
+
| 1030 | +6x | +
+ nlines <- nlevels(as.factor(data$strata))+ |
+
| 1031 | +6x | +
+ y_int <- annot_tbl$time[2] - annot_tbl$time[1]+ |
+
| 1032 | +6x | +
+ annot_tbl <- expand.grid(+ |
+
| 1033 | +6x | +
+ time = seq(0, xlim, y_int),+ |
+
| 1034 | +6x | +
+ strata = unique(annot_tbl$strata)+ |
+
| 1035 | +6x | +
+ ) %>% dplyr::left_join(annot_tbl, by = c("time", "strata"))
+ |
+
| 1036 | +6x | +
+ annot_tbl[is.na(annot_tbl)] <- 0+ |
+
| 1037 | +6x | +
+ y_str_unit <- as.numeric(annot_tbl$strata)+ |
+
| 1038 | +6x | +
+ vp_table <- grid::plotViewport(margins = grid::unit(c(0, 0, 0, 0), "lines"))+ |
+
| 1039 | +6x | +
+ if (title) {
+ |
+
| 1040 | +6x | +
+ gb_table_title <- grid::gList(+ |
+
| 1041 | +6x | +
+ grid::textGrob(+ |
+
| 1042 | +6x | +
+ label = "Patients at Risk:",+ |
+
| 1043 | +6x | +
+ x = 1,+ |
+
| 1044 | +6x | +
+ y = grid::unit(0.2, "native"),+ |
+
| 1045 | +6x | +
+ gp = grid::gpar(fontface = "bold", fontsize = 10)+ |
+
| 1046 | ++ |
+ )+ |
+
| 1047 | ++ |
+ )+ |
+
| 1048 | ++ |
+ }+ |
+
| 1049 | +6x | +
+ gb_table_left_annot <- grid::gList(+ |
+
| 1050 | +6x | +
+ grid::rectGrob(+ |
+
| 1051 | +6x | +
+ x = 0, y = grid::unit(c(1:nlines) - 1, "lines"),+ |
+
| 1052 | +6x | +
+ gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
+ |
+
| 1053 | +6x | +
+ height = grid::unit(1, "lines"), just = "bottom", hjust = 0+ |
+
| 1054 | ++ |
+ ),+ |
+
| 1055 | +6x | +
+ grid::textGrob(+ |
+
| 1056 | +6x | +
+ label = unique(annot_tbl$strata),+ |
+
| 1057 | +6x | +
+ x = 0.5,+ |
+
| 1058 | +6x | +
+ y = grid::unit(+ |
+
| 1059 | +6x | +
+ (max(unique(y_str_unit)) - unique(y_str_unit)) + 0.75,+ |
+
| 1060 | +6x | +
+ "native"+ |
+
| 1061 | ++ |
+ ),+ |
+
| 1062 | +6x | +
+ gp = grid::gpar(fontface = "italic", fontsize = 10)+ |
+
| 1063 | ++ |
+ )+ |
+
| 1064 | ++ |
+ )+ |
+
| 1065 | +6x | +
+ gb_patient_at_risk <- grid::gList(+ |
+
| 1066 | +6x | +
+ grid::rectGrob(+ |
+
| 1067 | +6x | +
+ x = 0, y = grid::unit(c(1:nlines) - 1, "lines"),+ |
+
| 1068 | +6x | +
+ gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
+ |
+
| 1069 | +6x | +
+ height = grid::unit(1, "lines"), just = "bottom", hjust = 0+ |
+
| 1070 | ++ |
+ ),+ |
+
| 1071 | +6x | +
+ grid::textGrob(+ |
+
| 1072 | +6x | +
+ label = annot_tbl$n.risk,+ |
+
| 1073 | +6x | +
+ x = grid::unit(annot_tbl$time, "native"),+ |
+
| 1074 | +6x | +
+ y = grid::unit(+ |
+
| 1075 | +6x | +
+ (max(y_str_unit) - y_str_unit) + .5,+ |
+
| 1076 | +6x | +
+ "line"+ |
+
| 1077 | +6x | +
+ ) # maybe native+ |
+
| 1078 | ++ |
+ )+ |
+
| 1079 | ++ |
+ )+ |
+
| 1080 | ++ | + + | +
| 1081 | +6x | +
+ ret <- list(+ |
+
| 1082 | +6x | +
+ at_risk = grid::gList(+ |
+
| 1083 | +6x | +
+ grid::gTree(+ |
+
| 1084 | +6x | +
+ vp = vp_table,+ |
+
| 1085 | +6x | +
+ children = grid::gList(+ |
+
| 1086 | +6x | +
+ grid::gTree(+ |
+
| 1087 | +6x | +
+ vp = grid::dataViewport(+ |
+
| 1088 | +6x | +
+ xscale = c(0, xlim) + c(-0.05, 0.05) * xlim,+ |
+
| 1089 | +6x | +
+ yscale = c(0, nlines + 1),+ |
+
| 1090 | +6x | +
+ extension = c(0.05, 0)+ |
+
| 1091 | ++ |
+ ),+ |
+
| 1092 | +6x | +
+ children = grid::gList(gb_patient_at_risk)+ |
+
| 1093 | ++ |
+ )+ |
+
| 1094 | ++ |
+ )+ |
+
| 1095 | ++ |
+ )+ |
+
| 1096 | ++ |
+ ),+ |
+
| 1097 | +6x | +
+ label = grid::gList(+ |
+
| 1098 | +6x | +
+ grid::gTree(+ |
+
| 1099 | +6x | +
+ vp = grid::viewport(width = max(grid::stringWidth(txtlines))),+ |
+
| 1100 | +6x | +
+ children = grid::gList(+ |
+
| 1101 | +6x | +
+ grid::gTree(+ |
+
| 1102 | +6x | +
+ vp = grid::dataViewport(+ |
+
| 1103 | +6x | +
+ xscale = 0:1,+ |
+
| 1104 | +6x | +
+ yscale = c(0, nlines + 1),+ |
+
| 1105 | +6x | +
+ extension = c(0.0, 0)+ |
+
| 1106 | ++ |
+ ),+ |
+
| 1107 | +6x | +
+ children = grid::gList(gb_table_left_annot)+ |
+
| 1108 | ++ |
+ )+ |
+
| 1109 | ++ |
+ )+ |
+
| 1110 | ++ |
+ )+ |
+
| 1111 | ++ |
+ )+ |
+
| 1112 | ++ |
+ )+ |
+
| 1113 | ++ | + + | +
| 1114 | +6x | +
+ if (title) {
+ |
+
| 1115 | +6x | +
+ ret[["title"]] <- grid::gList(+ |
+
| 1116 | +6x | +
+ grid::gTree(+ |
+
| 1117 | +6x | +
+ vp = grid::viewport(width = max(grid::stringWidth(txtlines))),+ |
+
| 1118 | +6x | +
+ children = grid::gList(+ |
+
| 1119 | +6x | +
+ grid::gTree(+ |
+
| 1120 | +6x | +
+ vp = grid::dataViewport(+ |
+
| 1121 | +6x | +
+ xscale = 0:1,+ |
+
| 1122 | +6x | +
+ yscale = c(0, 1),+ |
+
| 1123 | +6x | +
+ extension = c(0, 0)+ |
+
| 1124 | ++ |
+ ),+ |
+
| 1125 | +6x | +
+ children = grid::gList(gb_table_title)+ |
+
| 1126 | ++ |
+ )+ |
+
| 1127 | ++ |
+ )+ |
+
| 1128 | ++ |
+ )+ |
+
| 1129 | ++ |
+ )+ |
+
| 1130 | ++ |
+ }+ |
+
| 1131 | ++ | + + | +
| 1132 | +6x | +
+ ret+ |
+
| 1133 | ++ |
+ }+ |
+
| 1134 | ++ | + + | +
| 1135 | ++ |
+ #' Helper Function: Survival Estimations+ |
+
| 1136 | ++ |
+ #'+ |
+
| 1137 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 1138 | ++ |
+ #'+ |
+
| 1139 | ++ |
+ #' Transform a survival fit to a table with groups in rows characterized by N, median and confidence interval.+ |
+
| 1140 | ++ |
+ #'+ |
+
| 1141 | ++ |
+ #' @inheritParams h_data_plot+ |
+
| 1142 | ++ |
+ #'+ |
+
| 1143 | ++ |
+ #' @return A summary table with statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`).+ |
+
| 1144 | ++ |
+ #'+ |
+
| 1145 | ++ |
+ #' @examples+ |
+
| 1146 | ++ |
+ #' \donttest{
+ |
+
| 1147 | ++ |
+ #' library(dplyr)+ |
+
| 1148 | ++ |
+ #' library(survival)+ |
+
| 1149 | ++ |
+ #'+ |
+
| 1150 | ++ |
+ #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "OS")+ |
+
| 1151 | ++ |
+ #' fit <- survfit(+ |
+
| 1152 | ++ |
+ #' form = Surv(AVAL, 1 - CNSR) ~ ARMCD,+ |
+
| 1153 | ++ |
+ #' data = adtte+ |
+
| 1154 | ++ |
+ #' )+ |
+
| 1155 | ++ |
+ #' h_tbl_median_surv(fit_km = fit)+ |
+
| 1156 | ++ |
+ #' }+ |
+
| 1157 | ++ |
+ #'+ |
+
| 1158 | ++ |
+ #' @export+ |
+
| 1159 | ++ |
+ h_tbl_median_surv <- function(fit_km, armval = "All") {
+ |
+
| 1160 | +6x | +
+ y <- if (is.null(fit_km$strata)) {
+ |
+
| 1161 | +! | +
+ as.data.frame(t(summary(fit_km)$table), row.names = armval)+ |
+
| 1162 | ++ |
+ } else {
+ |
+
| 1163 | +6x | +
+ tbl <- summary(fit_km)$table+ |
+
| 1164 | +6x | +
+ rownames_lst <- strsplit(sub("=", "equals", rownames(tbl)), "equals")
+ |
+
| 1165 | +6x | +
+ rownames(tbl) <- matrix(unlist(rownames_lst), ncol = 2, byrow = TRUE)[, 2]+ |
+
| 1166 | +6x | +
+ as.data.frame(tbl)+ |
+
| 1167 | ++ |
+ }+ |
+
| 1168 | +6x | +
+ conf.int <- summary(fit_km)$conf.int # nolint+ |
+
| 1169 | +6x | +
+ y$records <- round(y$records)+ |
+
| 1170 | +6x | +
+ y$median <- signif(y$median, 4)+ |
+
| 1171 | +6x | +
+ y$`CI` <- paste0(+ |
+
| 1172 | +6x | +
+ "(", signif(y[[paste0(conf.int, "LCL")]], 4), ", ", signif(y[[paste0(conf.int, "UCL")]], 4), ")"
+ |
+
| 1173 | ++ |
+ )+ |
+
| 1174 | +6x | +
+ stats::setNames(+ |
+
| 1175 | +6x | +
+ y[c("records", "median", "CI")],
+ |
+
| 1176 | +6x | +
+ c("N", "Median", f_conf_level(conf.int))
+ |
+
| 1177 | ++ |
+ )+ |
+
| 1178 | ++ |
+ }+ |
+
| 1179 | ++ | + + | +
| 1180 | ++ |
+ #' Helper Function: Survival Estimation Grob+ |
+
| 1181 | ++ |
+ #'+ |
+
| 1182 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 1183 | ++ |
+ #'+ |
+
| 1184 | ++ |
+ #' The survival fit is transformed in a grob containing a table with groups in+ |
+
| 1185 | ++ |
+ #' rows characterized by N, median and 95% confidence interval.+ |
+
| 1186 | ++ |
+ #'+ |
+
| 1187 | ++ |
+ #' @inheritParams g_km+ |
+
| 1188 | ++ |
+ #' @inheritParams h_data_plot+ |
+
| 1189 | ++ |
+ #' @param ttheme (`list`)\cr see [gridExtra::ttheme_default()].+ |
+
| 1190 | ++ |
+ #' @param x (`numeric`)\cr a value between 0 and 1 specifying x-location.+ |
+
| 1191 | ++ |
+ #' @param y (`numeric`)\cr a value between 0 and 1 specifying y-location.+ |
+
| 1192 | ++ |
+ #' @param width (`unit`)\cr width (as a unit) to use when printing the grob.+ |
+
| 1193 | ++ |
+ #'+ |
+
| 1194 | ++ |
+ #' @return A `grob` of a table containing statistics `N`, `Median`, and `XX% CI` (`XX` taken from `fit_km`).+ |
+
| 1195 | ++ |
+ #'+ |
+
| 1196 | ++ |
+ #' @examples+ |
+
| 1197 | ++ |
+ #' \donttest{
+ |
+
| 1198 | ++ |
+ #' library(dplyr)+ |
+
| 1199 | ++ |
+ #' library(survival)+ |
+
| 1200 | ++ |
+ #' library(grid)+ |
+
| 1201 | ++ |
+ #'+ |
+
| 1202 | ++ |
+ #' grid::grid.newpage()+ |
+
| 1203 | ++ |
+ #' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1))+ |
+
| 1204 | ++ |
+ #' tern_ex_adtte %>%+ |
+
| 1205 | ++ |
+ #' filter(PARAMCD == "OS") %>%+ |
+
| 1206 | ++ |
+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%+ |
+
| 1207 | ++ |
+ #' h_grob_median_surv() %>%+ |
+
| 1208 | ++ |
+ #' grid::grid.draw()+ |
+
| 1209 | ++ |
+ #' }+ |
+
| 1210 | ++ |
+ #'+ |
+
| 1211 | ++ |
+ #' @export+ |
+
| 1212 | ++ |
+ h_grob_median_surv <- function(fit_km,+ |
+
| 1213 | ++ |
+ armval = "All",+ |
+
| 1214 | ++ |
+ x = 0.9,+ |
+
| 1215 | ++ |
+ y = 0.9,+ |
+
| 1216 | ++ |
+ width = grid::unit(0.3, "npc"),+ |
+
| 1217 | ++ |
+ ttheme = gridExtra::ttheme_default()) {
+ |
+
| 1218 | +5x | +
+ data <- h_tbl_median_surv(fit_km, armval = armval)+ |
+
| 1219 | ++ | + + | +
| 1220 | +5x | +
+ width <- grid::convertUnit(grid::unit(as.numeric(width), grid::unitType(width)), "in")+ |
+
| 1221 | +5x | +
+ height <- width * (nrow(data) + 1) / 12+ |
+
| 1222 | ++ | + + | +
| 1223 | +5x | +
+ w <- paste(" ", c(
+ |
+
| 1224 | +5x | +
+ rownames(data)[which.max(nchar(rownames(data)))],+ |
+
| 1225 | +5x | +
+ sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))])+ |
+
| 1226 | ++ |
+ ))+ |
+
| 1227 | +5x | +
+ w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE)+ |
+
| 1228 | ++ | + + | +
| 1229 | +5x | +
+ w_txt <- sapply(1:64, function(x) {
+ |
+
| 1230 | +320x | +
+ graphics::par(ps = x)+ |
+
| 1231 | +320x | +
+ graphics::strwidth(w[4], units = "in")+ |
+
| 1232 | ++ |
+ })+ |
+
| 1233 | +5x | +
+ f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]])+ |
+
| 1234 | ++ | + + | +
| 1235 | +5x | +
+ h_txt <- sapply(1:64, function(x) {
+ |
+
| 1236 | +320x | +
+ graphics::par(ps = x)+ |
+
| 1237 | +320x | +
+ graphics::strheight(grid::stringHeight("X"), units = "in")
+ |
+
| 1238 | ++ |
+ })+ |
+
| 1239 | +5x | +
+ f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))])+ |
+
| 1240 | ++ | + + | +
| 1241 | +5x | +
+ if (ttheme$core$fg_params$fontsize == 12) {
+ |
+
| 1242 | +5x | +
+ ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h)+ |
+
| 1243 | +5x | +
+ ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ |
+
| 1244 | +5x | +
+ ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ |
+
| 1245 | ++ |
+ }+ |
+
| 1246 | ++ | + + | +
| 1247 | +5x | +
+ gt <- gridExtra::tableGrob(+ |
+
| 1248 | +5x | +
+ d = data,+ |
+
| 1249 | +5x | +
+ theme = ttheme+ |
+
| 1250 | ++ |
+ )+ |
+
| 1251 | +5x | +
+ gt$widths <- ((w_unit / sum(w_unit)) * width)+ |
+
| 1252 | +5x | +
+ gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt))+ |
+
| 1253 | ++ | + + | +
| 1254 | +5x | +
+ vp <- grid::viewport(+ |
+
| 1255 | +5x | +
+ x = grid::unit(x, "npc") + grid::unit(1, "lines"),+ |
+
| 1256 | +5x | +
+ y = grid::unit(y, "npc") + grid::unit(1.5, "lines"),+ |
+
| 1257 | +5x | +
+ height = height,+ |
+
| 1258 | +5x | +
+ width = width,+ |
+
| 1259 | +5x | +
+ just = c("right", "top")
+ |
+
| 1260 | ++ |
+ )+ |
+
| 1261 | ++ | + + | +
| 1262 | +5x | +
+ grid::gList(+ |
+
| 1263 | +5x | +
+ grid::gTree(+ |
+
| 1264 | +5x | +
+ vp = vp,+ |
+
| 1265 | +5x | +
+ children = grid::gList(gt)+ |
+
| 1266 | ++ |
+ )+ |
+
| 1267 | ++ |
+ )+ |
+
| 1268 | ++ |
+ }+ |
+
| 1269 | ++ | + + | +
| 1270 | ++ |
+ #' Helper: Grid Object with y-axis Annotation+ |
+
| 1271 | ++ |
+ #'+ |
+
| 1272 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 1273 | ++ |
+ #'+ |
+
| 1274 | ++ |
+ #' Build the y-axis annotation from a decomposed `ggplot`.+ |
+
| 1275 | ++ |
+ #'+ |
+
| 1276 | ++ |
+ #' @param ylab (`gtable`)\cr the y-lab as a graphical object derived from a `ggplot`.+ |
+
| 1277 | ++ |
+ #' @param yaxis (`gtable`)\cr the y-axis as a graphical object derived from a `ggplot`.+ |
+
| 1278 | ++ |
+ #'+ |
+
| 1279 | ++ |
+ #' @return a `gTree` object containing the y-axis annotation from a `ggplot`.+ |
+
| 1280 | ++ |
+ #'+ |
+
| 1281 | ++ |
+ #' @examples+ |
+
| 1282 | ++ |
+ #' \donttest{
+ |
+
| 1283 | ++ |
+ #' library(dplyr)+ |
+
| 1284 | ++ |
+ #' library(survival)+ |
+
| 1285 | ++ |
+ #' library(grid)+ |
+
| 1286 | ++ |
+ #'+ |
+
| 1287 | ++ |
+ #' fit_km <- tern_ex_adtte %>%+ |
+
| 1288 | ++ |
+ #' filter(PARAMCD == "OS") %>%+ |
+
| 1289 | ++ |
+ #' survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)+ |
+
| 1290 | ++ |
+ #' data_plot <- h_data_plot(fit_km = fit_km)+ |
+
| 1291 | ++ |
+ #' xticks <- h_xticks(data = data_plot)+ |
+
| 1292 | ++ |
+ #' gg <- h_ggkm(+ |
+
| 1293 | ++ |
+ #' data = data_plot,+ |
+
| 1294 | ++ |
+ #' censor_show = TRUE,+ |
+
| 1295 | ++ |
+ #' xticks = xticks, xlab = "Days", ylab = "Survival Probability",+ |
+
| 1296 | ++ |
+ #' title = "title", footnotes = "footnotes", yval = "Survival"+ |
+
| 1297 | ++ |
+ #' )+ |
+
| 1298 | ++ |
+ #'+ |
+
| 1299 | ++ |
+ #' g_el <- h_decompose_gg(gg)+ |
+
| 1300 | ++ |
+ #'+ |
+
| 1301 | ++ |
+ #' grid::grid.newpage()+ |
+
| 1302 | ++ |
+ #' pvp <- grid::plotViewport(margins = c(5, 4, 2, 20))+ |
+
| 1303 | ++ |
+ #' pushViewport(pvp)+ |
+
| 1304 | ++ |
+ #' grid::grid.draw(h_grob_y_annot(ylab = g_el$ylab, yaxis = g_el$yaxis))+ |
+
| 1305 | ++ |
+ #' grid.rect(gp = grid::gpar(lty = 1, col = "gray35", fill = NA))+ |
+
| 1306 | ++ |
+ #' }+ |
+
| 1307 | ++ |
+ #'+ |
+
| 1308 | ++ |
+ #' @export+ |
+
| 1309 | ++ |
+ h_grob_y_annot <- function(ylab, yaxis) {
+ |
+
| 1310 | +6x | +
+ grid::gList(+ |
+
| 1311 | +6x | +
+ grid::gTree(+ |
+
| 1312 | +6x | +
+ vp = grid::viewport(+ |
+
| 1313 | +6x | +
+ width = grid::convertX(yaxis$width + ylab$width, "pt"),+ |
+
| 1314 | +6x | +
+ x = grid::unit(1, "npc"),+ |
+
| 1315 | +6x | +
+ just = "right"+ |
+
| 1316 | ++ |
+ ),+ |
+
| 1317 | +6x | +
+ children = grid::gList(cbind(ylab, yaxis))+ |
+
| 1318 | ++ |
+ )+ |
+
| 1319 | ++ |
+ )+ |
+
| 1320 | ++ |
+ }+ |
+
| 1321 | ++ | + + | +
| 1322 | ++ |
+ #' Helper Function: Pairwise `CoxPH` table+ |
+
| 1323 | ++ |
+ #'+ |
+
| 1324 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 1325 | ++ |
+ #'+ |
+
| 1326 | ++ |
+ #' Create a `data.frame` of pairwise stratified or unstratified `CoxPH` analysis results.+ |
+
| 1327 | ++ |
+ #'+ |
+
| 1328 | ++ |
+ #' @inheritParams g_km+ |
+
| 1329 | ++ |
+ #'+ |
+
| 1330 | ++ |
+ #' @return A `data.frame` containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`),+ |
+
| 1331 | ++ |
+ #' and `p-value (log-rank)`.+ |
+
| 1332 | ++ |
+ #'+ |
+
| 1333 | ++ |
+ #' @examples+ |
+
| 1334 | ++ |
+ #' \donttest{
+ |
+
| 1335 | ++ |
+ #' library(dplyr)+ |
+
| 1336 | ++ |
+ #'+ |
+
| 1337 | ++ |
+ #' adtte <- tern_ex_adtte %>%+ |
+
| 1338 | ++ |
+ #' filter(PARAMCD == "OS") %>%+ |
+
| 1339 | ++ |
+ #' mutate(is_event = CNSR == 0)+ |
+
| 1340 | ++ |
+ #'+ |
+
| 1341 | ++ |
+ #' h_tbl_coxph_pairwise(+ |
+
| 1342 | ++ |
+ #' df = adtte,+ |
+
| 1343 | ++ |
+ #' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARM"),+ |
+
| 1344 | ++ |
+ #' control_coxph_pw = control_coxph(conf_level = 0.9)+ |
+
| 1345 | ++ |
+ #' )+ |
+
| 1346 | ++ |
+ #' }+ |
+
| 1347 | ++ |
+ #'+ |
+
| 1348 | ++ |
+ #' @export+ |
+
| 1349 | ++ |
+ h_tbl_coxph_pairwise <- function(df,+ |
+
| 1350 | ++ |
+ variables,+ |
+
| 1351 | ++ |
+ control_coxph_pw = control_coxph()) {
+ |
+
| 1352 | +3x | +
+ assert_df_with_variables(df, variables)+ |
+
| 1353 | +3x | +
+ arm <- variables$arm+ |
+
| 1354 | +3x | +
+ df[[arm]] <- factor(df[[arm]])+ |
+
| 1355 | +3x | +
+ ref_group <- levels(df[[arm]])[1]+ |
+
| 1356 | +3x | +
+ comp_group <- levels(df[[arm]])[-1]+ |
+
| 1357 | +3x | +
+ results <- Map(function(comp) {
+ |
+
| 1358 | +6x | +
+ res <- s_coxph_pairwise(+ |
+
| 1359 | +6x | +
+ df = df[df[[arm]] == comp, , drop = FALSE],+ |
+
| 1360 | +6x | +
+ .ref_group = df[df[[arm]] == ref_group, , drop = FALSE],+ |
+
| 1361 | +6x | +
+ .in_ref_col = FALSE,+ |
+
| 1362 | +6x | +
+ .var = variables$tte,+ |
+
| 1363 | +6x | +
+ is_event = variables$is_event,+ |
+
| 1364 | +6x | +
+ strat = variables$strat,+ |
+
| 1365 | +6x | +
+ control = control_coxph_pw+ |
+
| 1366 | ++ |
+ )+ |
+
| 1367 | +6x | +
+ res_df <- data.frame(+ |
+
| 1368 | +6x | +
+ hr = format(round(res$hr, 2), nsmall = 2),+ |
+
| 1369 | +6x | +
+ hr_ci = paste0(+ |
+
| 1370 | +6x | +
+ "(", format(round(res$hr_ci[1], 2), nsmall = 2), ", ",
+ |
+
| 1371 | +6x | +
+ format(round(res$hr_ci[2], 2), nsmall = 2), ")"+ |
+
| 1372 | ++ |
+ ),+ |
+
| 1373 | +6x | +
+ pvalue = if (res$pvalue < 0.0001) "<0.0001" else format(round(res$pvalue, 4), 4),+ |
+
| 1374 | +6x | +
+ stringsAsFactors = FALSE+ |
+
| 1375 | ++ |
+ )+ |
+
| 1376 | +6x | +
+ colnames(res_df) <- c("HR", vapply(res[c("hr_ci", "pvalue")], obj_label, FUN.VALUE = "character"))
+ |
+
| 1377 | +6x | +
+ row.names(res_df) <- comp+ |
+
| 1378 | +6x | +
+ res_df+ |
+
| 1379 | +3x | +
+ }, comp_group)+ |
+
| 1380 | +3x | +
+ do.call(rbind, results)+ |
+
| 1381 | ++ |
+ }+ |
+
| 1382 | ++ | + + | +
| 1383 | ++ |
+ #' Helper Function: `CoxPH` Grob+ |
+
| 1384 | ++ |
+ #'+ |
+
| 1385 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 1386 | ++ |
+ #'+ |
+
| 1387 | ++ |
+ #' Grob of `rtable` output from [h_tbl_coxph_pairwise()]+ |
+
| 1388 | ++ |
+ #'+ |
+
| 1389 | ++ |
+ #' @inheritParams h_grob_median_surv+ |
+
| 1390 | ++ |
+ #' @param ... arguments will be passed to [h_tbl_coxph_pairwise()].+ |
+
| 1391 | ++ |
+ #' @param x (`numeric`)\cr a value between 0 and 1 specifying x-location.+ |
+
| 1392 | ++ |
+ #' @param y (`numeric`)\cr a value between 0 and 1 specifying y-location.+ |
+
| 1393 | ++ |
+ #' @param width (`unit`)\cr width (as a unit) to use when printing the grob.+ |
+
| 1394 | ++ |
+ #'+ |
+
| 1395 | ++ |
+ #' @return A `grob` of a table containing statistics `HR`, `XX% CI` (`XX` taken from `control_coxph_pw`),+ |
+
| 1396 | ++ |
+ #' and `p-value (log-rank)`.+ |
+
| 1397 | ++ |
+ #'+ |
+
| 1398 | ++ |
+ #' @examples+ |
+
| 1399 | ++ |
+ #' \donttest{
+ |
+
| 1400 | ++ |
+ #' library(dplyr)+ |
+
| 1401 | ++ |
+ #' library(survival)+ |
+
| 1402 | ++ |
+ #' library(grid)+ |
+
| 1403 | ++ |
+ #'+ |
+
| 1404 | ++ |
+ #' grid::grid.newpage()+ |
+
| 1405 | ++ |
+ #' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1))+ |
+
| 1406 | ++ |
+ #' data <- tern_ex_adtte %>%+ |
+
| 1407 | ++ |
+ #' filter(PARAMCD == "OS") %>%+ |
+
| 1408 | ++ |
+ #' mutate(is_event = CNSR == 0)+ |
+
| 1409 | ++ |
+ #' tbl_grob <- h_grob_coxph(+ |
+
| 1410 | ++ |
+ #' df = data,+ |
+
| 1411 | ++ |
+ #' variables = list(tte = "AVAL", is_event = "is_event", arm = "ARMCD"),+ |
+
| 1412 | ++ |
+ #' control_coxph_pw = control_coxph(conf_level = 0.9), x = 0.5, y = 0.5+ |
+
| 1413 | ++ |
+ #' )+ |
+
| 1414 | ++ |
+ #' grid::grid.draw(tbl_grob)+ |
+
| 1415 | ++ |
+ #' }+ |
+
| 1416 | ++ |
+ #'+ |
+
| 1417 | ++ |
+ #' @export+ |
+
| 1418 | ++ |
+ h_grob_coxph <- function(...,+ |
+
| 1419 | ++ |
+ x = 0,+ |
+
| 1420 | ++ |
+ y = 0,+ |
+
| 1421 | ++ |
+ width = grid::unit(0.4, "npc"),+ |
+
| 1422 | ++ |
+ ttheme = gridExtra::ttheme_default(+ |
+
| 1423 | ++ |
+ padding = grid::unit(c(1, .5), "lines"),+ |
+
| 1424 | ++ |
+ core = list(bg_params = list(fill = c("grey95", "grey90"), alpha = .5))
+ |
+
| 1425 | ++ |
+ )) {
+ |
+
| 1426 | +2x | +
+ data <- h_tbl_coxph_pairwise(...)+ |
+
| 1427 | ++ | + + | +
| 1428 | +2x | +
+ width <- grid::convertUnit(grid::unit(as.numeric(width), grid::unitType(width)), "in")+ |
+
| 1429 | +2x | +
+ height <- width * (nrow(data) + 1) / 12+ |
+
| 1430 | ++ | + + | +
| 1431 | +2x | +
+ w <- paste(" ", c(
+ |
+
| 1432 | +2x | +
+ rownames(data)[which.max(nchar(rownames(data)))],+ |
+
| 1433 | +2x | +
+ sapply(names(data), function(x) c(x, data[[x]])[which.max(nchar(c(x, data[[x]])))])+ |
+
| 1434 | ++ |
+ ))+ |
+
| 1435 | +2x | +
+ w_unit <- grid::convertWidth(grid::stringWidth(w), "in", valueOnly = TRUE)+ |
+
| 1436 | ++ | + + | +
| 1437 | +2x | +
+ w_txt <- sapply(1:64, function(x) {
+ |
+
| 1438 | +128x | +
+ graphics::par(ps = x)+ |
+
| 1439 | +128x | +
+ graphics::strwidth(w[4], units = "in")+ |
+
| 1440 | ++ |
+ })+ |
+
| 1441 | +2x | +
+ f_size_w <- which.max(w_txt[w_txt < as.numeric((w_unit / sum(w_unit)) * width)[4]])+ |
+
| 1442 | ++ | + + | +
| 1443 | +2x | +
+ h_txt <- sapply(1:64, function(x) {
+ |
+
| 1444 | +128x | +
+ graphics::par(ps = x)+ |
+
| 1445 | +128x | +
+ graphics::strheight(grid::stringHeight("X"), units = "in")
+ |
+
| 1446 | ++ |
+ })+ |
+
| 1447 | +2x | +
+ f_size_h <- which.max(h_txt[h_txt < as.numeric(grid::unit(as.numeric(height) / 4, grid::unitType(height)))])+ |
+
| 1448 | ++ | + + | +
| 1449 | +2x | +
+ if (ttheme$core$fg_params$fontsize == 12) {
+ |
+
| 1450 | +2x | +
+ ttheme$core$fg_params$fontsize <- min(f_size_w, f_size_h)+ |
+
| 1451 | +2x | +
+ ttheme$colhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ |
+
| 1452 | +2x | +
+ ttheme$rowhead$fg_params$fontsize <- min(f_size_w, f_size_h)+ |
+
| 1453 | ++ |
+ }+ |
+
| 1454 | ++ | + + | +
| 1455 | +2x | +
+ tryCatch(+ |
+
| 1456 | +2x | +
+ expr = {
+ |
+
| 1457 | +2x | +
+ gt <- gridExtra::tableGrob(+ |
+
| 1458 | +2x | +
+ d = data,+ |
+
| 1459 | +2x | +
+ theme = ttheme+ |
+
| 1460 | +2x | +
+ ) # ERROR 'data' must be of a vector type, was 'NULL'+ |
+
| 1461 | +2x | +
+ gt$widths <- ((w_unit / sum(w_unit)) * width)+ |
+
| 1462 | +2x | +
+ gt$heights <- rep(grid::unit(as.numeric(height) / 4, grid::unitType(height)), nrow(gt))+ |
+
| 1463 | +2x | +
+ vp <- grid::viewport(+ |
+
| 1464 | +2x | +
+ x = grid::unit(x, "npc") + grid::unit(1, "lines"),+ |
+
| 1465 | +2x | +
+ y = grid::unit(y, "npc") + grid::unit(1.5, "lines"),+ |
+
| 1466 | +2x | +
+ height = height,+ |
+
| 1467 | +2x | +
+ width = width,+ |
+
| 1468 | +2x | +
+ just = c("left", "bottom")
+ |
+
| 1469 | ++ |
+ )+ |
+
| 1470 | +2x | +
+ grid::gList(+ |
+
| 1471 | +2x | +
+ grid::gTree(+ |
+
| 1472 | +2x | +
+ vp = vp,+ |
+
| 1473 | +2x | +
+ children = grid::gList(gt)+ |
+
| 1474 | ++ |
+ )+ |
+
| 1475 | ++ |
+ )+ |
+
| 1476 | ++ |
+ },+ |
+
| 1477 | +2x | +
+ error = function(w) {
+ |
+
| 1478 | +! | +
+ message(paste(+ |
+
| 1479 | +! | +
+ "Warning: Cox table will not be displayed as there is",+ |
+
| 1480 | +! | +
+ "not any level to be compared in the arm variable."+ |
+
| 1481 | ++ |
+ ))+ |
+
| 1482 | +! | +
+ return(+ |
+
| 1483 | +! | +
+ grid::gList(+ |
+
| 1484 | +! | +
+ grid::gTree(+ |
+
| 1485 | +! | +
+ vp = NULL,+ |
+
| 1486 | +! | +
+ children = NULL+ |
+
| 1487 | ++ |
+ )+ |
+
| 1488 | ++ |
+ )+ |
+
| 1489 | ++ |
+ )+ |
+
| 1490 | ++ |
+ }+ |
+
| 1491 | ++ |
+ )+ |
+
| 1492 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Helper Function for Tabulation of a Single Biomarker Result+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Please see [h_tab_surv_one_biomarker()] and [h_tab_rsp_one_biomarker()], which use this function for examples.+ |
+
| 6 | ++ |
+ #' This function is a wrapper for [rtables::summarize_row_groups()].+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #' @param df (`data.frame`)\cr results for a single biomarker.+ |
+
| 10 | ++ |
+ #' @param afuns (named `list` of `function`)\cr analysis functions.+ |
+
| 11 | ++ |
+ #' @param colvars (`list` with `vars` and `labels`)\cr variables to tabulate and their labels.+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' @return An `rtables` table object with statistics in columns.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @export+ |
+
| 16 | ++ |
+ h_tab_one_biomarker <- function(df,+ |
+
| 17 | ++ |
+ afuns,+ |
+
| 18 | ++ |
+ colvars,+ |
+
| 19 | ++ |
+ na_str = NA_character_,+ |
+
| 20 | ++ |
+ .indent_mods = 0L) {
+ |
+
| 21 | +12x | +
+ lyt <- basic_table()+ |
+
| 22 | ++ | + + | +
| 23 | ++ |
+ # Row split by row type - only keep the content rows here.+ |
+
| 24 | +12x | +
+ lyt <- split_rows_by(+ |
+
| 25 | +12x | +
+ lyt = lyt,+ |
+
| 26 | +12x | +
+ var = "row_type",+ |
+
| 27 | +12x | +
+ split_fun = keep_split_levels("content"),
+ |
+
| 28 | +12x | +
+ nested = FALSE+ |
+
| 29 | ++ |
+ )+ |
+
| 30 | ++ | + + | +
| 31 | ++ |
+ # Summarize rows with all patients.+ |
+
| 32 | +12x | +
+ lyt <- summarize_row_groups(+ |
+
| 33 | +12x | +
+ lyt = lyt,+ |
+
| 34 | +12x | +
+ var = "var_label",+ |
+
| 35 | +12x | +
+ cfun = afuns,+ |
+
| 36 | +12x | +
+ na_str = na_str,+ |
+
| 37 | +12x | +
+ indent_mod = .indent_mods+ |
+
| 38 | ++ |
+ )+ |
+
| 39 | ++ | + + | +
| 40 | ++ |
+ # Split cols by the multiple variables to populate into columns.+ |
+
| 41 | +12x | +
+ lyt <- split_cols_by_multivar(+ |
+
| 42 | +12x | +
+ lyt = lyt,+ |
+
| 43 | +12x | +
+ vars = colvars$vars,+ |
+
| 44 | +12x | +
+ varlabels = colvars$labels+ |
+
| 45 | ++ |
+ )+ |
+
| 46 | ++ | + + | +
| 47 | ++ |
+ # If there is any subgroup variables, we extend the layout accordingly.+ |
+
| 48 | +12x | +
+ if ("analysis" %in% df$row_type) {
+ |
+
| 49 | ++ |
+ # Now only continue with the subgroup rows.+ |
+
| 50 | +4x | +
+ lyt <- split_rows_by(+ |
+
| 51 | +4x | +
+ lyt = lyt,+ |
+
| 52 | +4x | +
+ var = "row_type",+ |
+
| 53 | +4x | +
+ split_fun = keep_split_levels("analysis"),
+ |
+
| 54 | +4x | +
+ nested = FALSE,+ |
+
| 55 | +4x | +
+ child_labels = "hidden"+ |
+
| 56 | ++ |
+ )+ |
+
| 57 | ++ | + + | +
| 58 | ++ |
+ # Split by the subgroup variable.+ |
+
| 59 | +4x | +
+ lyt <- split_rows_by(+ |
+
| 60 | +4x | +
+ lyt = lyt,+ |
+
| 61 | +4x | +
+ var = "var",+ |
+
| 62 | +4x | +
+ labels_var = "var_label",+ |
+
| 63 | +4x | +
+ nested = TRUE,+ |
+
| 64 | +4x | +
+ child_labels = "visible",+ |
+
| 65 | +4x | +
+ indent_mod = .indent_mods * 2+ |
+
| 66 | ++ |
+ )+ |
+
| 67 | ++ | + + | +
| 68 | ++ |
+ # Then analyze colvars for each subgroup.+ |
+
| 69 | +4x | +
+ lyt <- summarize_row_groups(+ |
+
| 70 | +4x | +
+ lyt = lyt,+ |
+
| 71 | +4x | +
+ cfun = afuns,+ |
+
| 72 | +4x | +
+ var = "subgroup",+ |
+
| 73 | +4x | +
+ na_str = na_str+ |
+
| 74 | ++ |
+ )+ |
+
| 75 | ++ |
+ }+ |
+
| 76 | +12x | +
+ build_table(lyt, df = df)+ |
+
| 77 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Patient Counts with Abnormal Range Values+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Primary analysis variable `.var` indicates the abnormal range result (`character` or `factor`)+ |
+
| 6 | ++ |
+ #' and additional analysis variables are `id` (`character` or `factor`) and `baseline` (`character` or+ |
+
| 7 | ++ |
+ #' `factor`). For each direction specified in `abnormal` (e.g. high or low) count patients in the+ |
+
| 8 | ++ |
+ #' numerator and denominator as follows:+ |
+
| 9 | ++ |
+ #' * `num` : The number of patients with this abnormality recorded while on treatment.+ |
+
| 10 | ++ |
+ #' * `denom`: The number of patients with at least one post-baseline assessment.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 13 | ++ |
+ #' @param abnormal (named `list`)\cr list identifying the abnormal range level(s) in `var`. Defaults to+ |
+
| 14 | ++ |
+ #' `list(Low = "LOW", High = "HIGH")` but you can also group different levels into the named list,+ |
+
| 15 | ++ |
+ #' for example, `abnormal = list(Low = c("LOW", "LOW LOW"), High = c("HIGH", "HIGH HIGH"))`.
+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @note+ |
+
| 18 | ++ |
+ #' * `count_abnormal()` only works with a single variable containing multiple abnormal levels.+ |
+
| 19 | ++ |
+ #' * `df` should be filtered to include only post-baseline records.+ |
+
| 20 | ++ |
+ #' * the denominator includes patients that might have other abnormal levels at baseline,+ |
+
| 21 | ++ |
+ #' and patients with missing baseline. Patients with these abnormalities at+ |
+
| 22 | ++ |
+ #' baseline can be optionally excluded from numerator and denominator.+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @name abnormal+ |
+
| 25 | ++ |
+ #' @include formatting_functions.R+ |
+
| 26 | ++ |
+ NULL+ |
+
| 27 | ++ | + + | +
| 28 | ++ |
+ #' @describeIn abnormal Statistics function which counts patients with abnormal range values+ |
+
| 29 | ++ |
+ #' for a single `abnormal` level.+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' @param exclude_base_abn (`flag`)\cr whether to exclude subjects with baseline abnormality+ |
+
| 32 | ++ |
+ #' from numerator and denominator.+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' @return+ |
+
| 35 | ++ |
+ #' * `s_count_abnormal()` returns the statistic `fraction` which is a vector with `num` and `denom` counts of patients.+ |
+
| 36 | ++ |
+ #' @examples+ |
+
| 37 | ++ |
+ #' library(dplyr)+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' df <- data.frame(+ |
+
| 40 | ++ |
+ #' USUBJID = as.character(c(1, 1, 2, 2)),+ |
+
| 41 | ++ |
+ #' ANRIND = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
+ |
+
| 42 | ++ |
+ #' BNRIND = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
+ |
+
| 43 | ++ |
+ #' ONTRTFL = c("", "Y", "", "Y"),
+ |
+
| 44 | ++ |
+ #' stringsAsFactors = FALSE+ |
+
| 45 | ++ |
+ #' )+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ #' # Select only post-baseline records.+ |
+
| 48 | ++ |
+ #' df <- df %>%+ |
+
| 49 | ++ |
+ #' filter(ONTRTFL == "Y")+ |
+
| 50 | ++ |
+ #' @keywords internal+ |
+
| 51 | ++ |
+ s_count_abnormal <- function(df,+ |
+
| 52 | ++ |
+ .var,+ |
+
| 53 | ++ |
+ abnormal = list(Low = "LOW", High = "HIGH"),+ |
+
| 54 | ++ |
+ variables = list(id = "USUBJID", baseline = "BNRIND"),+ |
+
| 55 | ++ |
+ exclude_base_abn = FALSE) {
+ |
+
| 56 | +4x | +
+ checkmate::assert_list(abnormal, types = "character", names = "named", len = 2, any.missing = FALSE)+ |
+
| 57 | +4x | +
+ checkmate::assert_true(any(unlist(abnormal) %in% levels(df[[.var]])))+ |
+
| 58 | +4x | +
+ checkmate::assert_factor(df[[.var]])+ |
+
| 59 | +4x | +
+ checkmate::assert_flag(exclude_base_abn)+ |
+
| 60 | +4x | +
+ assert_df_with_variables(df, c(range = .var, variables))+ |
+
| 61 | +4x | +
+ checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
+ |
+
| 62 | +4x | +
+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ |
+
| 63 | ++ | + + | +
| 64 | +4x | +
+ count_abnormal_single <- function(abn_name, abn) {
+ |
+
| 65 | ++ |
+ # Patients in the denominator fulfill:+ |
+
| 66 | ++ |
+ # - have at least one post-baseline visit+ |
+
| 67 | ++ |
+ # - their baseline must not be abnormal if `exclude_base_abn`.+ |
+
| 68 | +8x | +
+ if (exclude_base_abn) {
+ |
+
| 69 | +4x | +
+ denom_select <- !(df[[variables$baseline]] %in% abn)+ |
+
| 70 | ++ |
+ } else {
+ |
+
| 71 | +4x | +
+ denom_select <- TRUE+ |
+
| 72 | ++ |
+ }+ |
+
| 73 | +8x | +
+ denom <- length(unique(df[denom_select, variables$id, drop = TRUE]))+ |
+
| 74 | ++ | + + | +
| 75 | ++ |
+ # Patients in the numerator fulfill:+ |
+
| 76 | ++ |
+ # - have at least one post-baseline visit with the required abnormality level+ |
+
| 77 | ++ |
+ # - are part of the denominator patients.+ |
+
| 78 | +8x | +
+ num_select <- (df[[.var]] %in% abn) & denom_select+ |
+
| 79 | +8x | +
+ num <- length(unique(df[num_select, variables$id, drop = TRUE]))+ |
+
| 80 | ++ | + + | +
| 81 | +8x | +
+ formatters::with_label(c(num = num, denom = denom), abn_name)+ |
+
| 82 | ++ |
+ }+ |
+
| 83 | ++ | + + | +
| 84 | ++ |
+ # This will define the abnormal levels theoretically possible for a specific lab parameter+ |
+
| 85 | ++ |
+ # within a split level of a layout.+ |
+
| 86 | +4x | +
+ abnormal_lev <- lapply(abnormal, intersect, levels(df[[.var]]))+ |
+
| 87 | +4x | +
+ abnormal_lev <- abnormal_lev[vapply(abnormal_lev, function(x) length(x) > 0, logical(1))]+ |
+
| 88 | ++ | + + | +
| 89 | +4x | +
+ result <- sapply(names(abnormal_lev), function(i) count_abnormal_single(i, abnormal_lev[[i]]), simplify = FALSE)+ |
+
| 90 | +4x | +
+ result <- list(fraction = result)+ |
+
| 91 | +4x | +
+ result+ |
+
| 92 | ++ |
+ }+ |
+
| 93 | ++ | + + | +
| 94 | ++ |
+ #' @describeIn abnormal Formatted analysis function which is used as `afun` in `count_abnormal()`.+ |
+
| 95 | ++ |
+ #'+ |
+
| 96 | ++ |
+ #' @return+ |
+
| 97 | ++ |
+ #' * `a_count_abnormal()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 98 | ++ |
+ #'+ |
+
| 99 | ++ |
+ #' @keywords internal+ |
+
| 100 | ++ |
+ a_count_abnormal <- make_afun(+ |
+
| 101 | ++ |
+ s_count_abnormal,+ |
+
| 102 | ++ |
+ .formats = c(fraction = format_fraction)+ |
+
| 103 | ++ |
+ )+ |
+
| 104 | ++ | + + | +
| 105 | ++ |
+ #' @describeIn abnormal Layout-creating function which can take statistics function arguments+ |
+
| 106 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 107 | ++ |
+ #'+ |
+
| 108 | ++ |
+ #' @return+ |
+
| 109 | ++ |
+ #' * `count_abnormal()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 110 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 111 | ++ |
+ #' the statistics from `s_count_abnormal()` to the table layout.+ |
+
| 112 | ++ |
+ #'+ |
+
| 113 | ++ |
+ #' @examples+ |
+
| 114 | ++ |
+ #' # Layout creating function.+ |
+
| 115 | ++ |
+ #' basic_table() %>%+ |
+
| 116 | ++ |
+ #' count_abnormal(var = "ANRIND", abnormal = list(high = "HIGH", low = "LOW")) %>%+ |
+
| 117 | ++ |
+ #' build_table(df)+ |
+
| 118 | ++ |
+ #'+ |
+
| 119 | ++ |
+ #' # Passing of statistics function and formatting arguments.+ |
+
| 120 | ++ |
+ #' df2 <- data.frame(+ |
+
| 121 | ++ |
+ #' ID = as.character(c(1, 1, 2, 2)),+ |
+
| 122 | ++ |
+ #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
+ |
+
| 123 | ++ |
+ #' BL_RANGE = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
+ |
+
| 124 | ++ |
+ #' ONTRTFL = c("", "Y", "", "Y"),
+ |
+
| 125 | ++ |
+ #' stringsAsFactors = FALSE+ |
+
| 126 | ++ |
+ #' )+ |
+
| 127 | ++ |
+ #'+ |
+
| 128 | ++ |
+ #' # Select only post-baseline records.+ |
+
| 129 | ++ |
+ #' df2 <- df2 %>%+ |
+
| 130 | ++ |
+ #' filter(ONTRTFL == "Y")+ |
+
| 131 | ++ |
+ #'+ |
+
| 132 | ++ |
+ #' basic_table() %>%+ |
+
| 133 | ++ |
+ #' count_abnormal(+ |
+
| 134 | ++ |
+ #' var = "RANGE",+ |
+
| 135 | ++ |
+ #' abnormal = list(low = "LOW", high = "HIGH"),+ |
+
| 136 | ++ |
+ #' variables = list(id = "ID", baseline = "BL_RANGE")+ |
+
| 137 | ++ |
+ #' ) %>%+ |
+
| 138 | ++ |
+ #' build_table(df2)+ |
+
| 139 | ++ |
+ #'+ |
+
| 140 | ++ |
+ #' @export+ |
+
| 141 | ++ |
+ count_abnormal <- function(lyt,+ |
+
| 142 | ++ |
+ var,+ |
+
| 143 | ++ |
+ na_str = NA_character_,+ |
+
| 144 | ++ |
+ nested = TRUE,+ |
+
| 145 | ++ |
+ ...,+ |
+
| 146 | ++ |
+ table_names = var,+ |
+
| 147 | ++ |
+ .stats = NULL,+ |
+
| 148 | ++ |
+ .formats = NULL,+ |
+
| 149 | ++ |
+ .labels = NULL,+ |
+
| 150 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 151 | +3x | +
+ afun <- make_afun(+ |
+
| 152 | +3x | +
+ a_count_abnormal,+ |
+
| 153 | +3x | +
+ .stats = .stats,+ |
+
| 154 | +3x | +
+ .formats = .formats,+ |
+
| 155 | +3x | +
+ .labels = .labels,+ |
+
| 156 | +3x | +
+ .indent_mods = .indent_mods,+ |
+
| 157 | +3x | +
+ .ungroup_stats = "fraction"+ |
+
| 158 | ++ |
+ )+ |
+
| 159 | ++ | + + | +
| 160 | +3x | +
+ checkmate::assert_string(var)+ |
+
| 161 | ++ | + + | +
| 162 | +3x | +
+ analyze(+ |
+
| 163 | +3x | +
+ lyt = lyt,+ |
+
| 164 | +3x | +
+ vars = var,+ |
+
| 165 | +3x | +
+ afun = afun,+ |
+
| 166 | +3x | +
+ na_str = na_str,+ |
+
| 167 | +3x | +
+ nested = nested,+ |
+
| 168 | +3x | +
+ table_names = table_names,+ |
+
| 169 | +3x | +
+ extra_args = list(...),+ |
+
| 170 | +3x | +
+ show_labels = "hidden"+ |
+
| 171 | ++ |
+ )+ |
+
| 172 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Estimation of Proportions per Level of Factor+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Estimate the proportion along with confidence interval of a proportion+ |
+
| 6 | ++ |
+ #' regarding the level of a factor.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @seealso Relevant description function [d_onco_rsp_label()].+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @name estimate_multinomial_rsp+ |
+
| 13 | ++ |
+ NULL+ |
+
| 14 | ++ | + + | +
| 15 | ++ |
+ #' Description of Standard Oncology Response+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' Describe the oncology response in a standard way.+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @param x (`character`)\cr the standard oncology code to be described.+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @return Response labels.+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @seealso [estimate_multinomial_rsp()]+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' @examples+ |
+
| 28 | ++ |
+ #' d_onco_rsp_label(+ |
+
| 29 | ++ |
+ #' c("CR", "PR", "SD", "NON CR/PD", "PD", "NE", "Missing", "<Missing>", "NE/Missing")
+ |
+
| 30 | ++ |
+ #' )+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' # Adding some values not considered in d_onco_rsp_label+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' d_onco_rsp_label(+ |
+
| 35 | ++ |
+ #' c("CR", "PR", "hello", "hi")
+ |
+
| 36 | ++ |
+ #' )+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' @export+ |
+
| 39 | ++ |
+ d_onco_rsp_label <- function(x) {
+ |
+
| 40 | +2x | +
+ x <- as.character(x)+ |
+
| 41 | +2x | +
+ desc <- c(+ |
+
| 42 | +2x | +
+ CR = "Complete Response (CR)",+ |
+
| 43 | +2x | +
+ PR = "Partial Response (PR)",+ |
+
| 44 | +2x | +
+ MR = "Minimal/Minor Response (MR)",+ |
+
| 45 | +2x | +
+ MRD = "Minimal Residual Disease (MRD)",+ |
+
| 46 | +2x | +
+ SD = "Stable Disease (SD)",+ |
+
| 47 | +2x | +
+ PD = "Progressive Disease (PD)",+ |
+
| 48 | +2x | +
+ `NON CR/PD` = "Non-CR or Non-PD (NON CR/PD)",+ |
+
| 49 | +2x | +
+ NE = "Not Evaluable (NE)",+ |
+
| 50 | +2x | +
+ `NE/Missing` = "Missing or unevaluable",+ |
+
| 51 | +2x | +
+ Missing = "Missing",+ |
+
| 52 | +2x | +
+ `NA` = "Not Applicable (NA)",+ |
+
| 53 | +2x | +
+ ND = "Not Done (ND)"+ |
+
| 54 | ++ |
+ )+ |
+
| 55 | ++ | + + | +
| 56 | +2x | +
+ values_label <- vapply(+ |
+
| 57 | +2x | +
+ X = x,+ |
+
| 58 | +2x | +
+ FUN.VALUE = character(1),+ |
+
| 59 | +2x | +
+ function(val) {
+ |
+
| 60 | +! | +
+ if (val %in% names(desc)) desc[val] else val+ |
+
| 61 | ++ |
+ }+ |
+
| 62 | ++ |
+ )+ |
+
| 63 | ++ | + + | +
| 64 | +2x | +
+ return(factor(values_label, levels = c(intersect(desc, values_label), setdiff(values_label, desc))))+ |
+
| 65 | ++ |
+ }+ |
+
| 66 | ++ | + + | +
| 67 | ++ |
+ #' @describeIn estimate_multinomial_rsp Statistics function which feeds the length of `x` as number+ |
+
| 68 | ++ |
+ #' of successes, and `.N_col` as total number of successes and failures into [s_proportion()].+ |
+
| 69 | ++ |
+ #'+ |
+
| 70 | ++ |
+ #' @return+ |
+
| 71 | ++ |
+ #' * `s_length_proportion()` returns statistics from [s_proportion()].+ |
+
| 72 | ++ |
+ #'+ |
+
| 73 | ++ |
+ #' @examples+ |
+
| 74 | ++ |
+ #' s_length_proportion(rep("CR", 10), .N_col = 100)
+ |
+
| 75 | ++ |
+ #' s_length_proportion(factor(character(0)), .N_col = 100)+ |
+
| 76 | ++ |
+ #'+ |
+
| 77 | ++ |
+ #' @export+ |
+
| 78 | ++ |
+ s_length_proportion <- function(x,+ |
+
| 79 | ++ |
+ .N_col, # nolint+ |
+
| 80 | ++ |
+ ...) {
+ |
+
| 81 | +4x | +
+ checkmate::assert_multi_class(x, classes = c("factor", "character"))
+ |
+
| 82 | +3x | +
+ checkmate::assert_vector(x, min.len = 0, max.len = .N_col)+ |
+
| 83 | +2x | +
+ checkmate::assert_vector(unique(x), min.len = 0, max.len = 1)+ |
+
| 84 | ++ | + + | +
| 85 | +1x | +
+ n_true <- length(x)+ |
+
| 86 | +1x | +
+ n_false <- .N_col - n_true+ |
+
| 87 | +1x | +
+ x_logical <- rep(c(TRUE, FALSE), c(n_true, n_false))+ |
+
| 88 | +1x | +
+ s_proportion(df = x_logical, ...)+ |
+
| 89 | ++ |
+ }+ |
+
| 90 | ++ | + + | +
| 91 | ++ |
+ #' @describeIn estimate_multinomial_rsp Formatted analysis function which is used as `afun`+ |
+
| 92 | ++ |
+ #' in `estimate_multinomial_response()`.+ |
+
| 93 | ++ |
+ #'+ |
+
| 94 | ++ |
+ #' @return+ |
+
| 95 | ++ |
+ #' * `a_length_proportion()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 96 | ++ |
+ #'+ |
+
| 97 | ++ |
+ #' @examples+ |
+
| 98 | ++ |
+ #' a_length_proportion(rep("CR", 10), .N_col = 100)
+ |
+
| 99 | ++ |
+ #' a_length_proportion(factor(character(0)), .N_col = 100)+ |
+
| 100 | ++ |
+ #'+ |
+
| 101 | ++ |
+ #' @export+ |
+
| 102 | ++ |
+ a_length_proportion <- make_afun(+ |
+
| 103 | ++ |
+ s_length_proportion,+ |
+
| 104 | ++ |
+ .formats = c(+ |
+
| 105 | ++ |
+ n_prop = "xx (xx.x%)",+ |
+
| 106 | ++ |
+ prop_ci = "(xx.xx, xx.xx)"+ |
+
| 107 | ++ |
+ )+ |
+
| 108 | ++ |
+ )+ |
+
| 109 | ++ | + + | +
| 110 | ++ |
+ #' @describeIn estimate_multinomial_rsp Layout-creating function which can take statistics function arguments+ |
+
| 111 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()] and+ |
+
| 112 | ++ |
+ #' [rtables::summarize_row_groups()].+ |
+
| 113 | ++ |
+ #'+ |
+
| 114 | ++ |
+ #' @return+ |
+
| 115 | ++ |
+ #' * `estimate_multinomial_response()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 116 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 117 | ++ |
+ #' the statistics from `s_length_proportion()` to the table layout.+ |
+
| 118 | ++ |
+ #'+ |
+
| 119 | ++ |
+ #' @examples+ |
+
| 120 | ++ |
+ #' library(dplyr)+ |
+
| 121 | ++ |
+ #'+ |
+
| 122 | ++ |
+ #' # Use of the layout creating function.+ |
+
| 123 | ++ |
+ #' dta_test <- data.frame(+ |
+
| 124 | ++ |
+ #' USUBJID = paste0("S", 1:12),
+ |
+
| 125 | ++ |
+ #' ARM = factor(rep(LETTERS[1:3], each = 4)),+ |
+
| 126 | ++ |
+ #' AVAL = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0))+ |
+
| 127 | ++ |
+ #' ) %>% mutate(+ |
+
| 128 | ++ |
+ #' AVALC = factor(AVAL,+ |
+
| 129 | ++ |
+ #' levels = c(0, 1),+ |
+
| 130 | ++ |
+ #' labels = c("Complete Response (CR)", "Partial Response (PR)")
+ |
+
| 131 | ++ |
+ #' )+ |
+
| 132 | ++ |
+ #' )+ |
+
| 133 | ++ |
+ #'+ |
+
| 134 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 135 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 136 | ++ |
+ #' estimate_multinomial_response(var = "AVALC")+ |
+
| 137 | ++ |
+ #'+ |
+
| 138 | ++ |
+ #' tbl <- build_table(lyt, dta_test)+ |
+
| 139 | ++ |
+ #'+ |
+
| 140 | ++ |
+ #' html <- as_html(tbl)+ |
+
| 141 | ++ |
+ #' html+ |
+
| 142 | ++ |
+ #' \donttest{
+ |
+
| 143 | ++ |
+ #' Viewer(html)+ |
+
| 144 | ++ |
+ #' }+ |
+
| 145 | ++ |
+ #'+ |
+
| 146 | ++ |
+ #' @export+ |
+
| 147 | ++ |
+ estimate_multinomial_response <- function(lyt,+ |
+
| 148 | ++ |
+ var,+ |
+
| 149 | ++ |
+ na_str = NA_character_,+ |
+
| 150 | ++ |
+ nested = TRUE,+ |
+
| 151 | ++ |
+ ...,+ |
+
| 152 | ++ |
+ show_labels = "hidden",+ |
+
| 153 | ++ |
+ table_names = var,+ |
+
| 154 | ++ |
+ .stats = "prop_ci",+ |
+
| 155 | ++ |
+ .formats = NULL,+ |
+
| 156 | ++ |
+ .labels = NULL,+ |
+
| 157 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 158 | +1x | +
+ afun <- make_afun(+ |
+
| 159 | +1x | +
+ a_length_proportion,+ |
+
| 160 | +1x | +
+ .stats = .stats,+ |
+
| 161 | +1x | +
+ .formats = .formats,+ |
+
| 162 | +1x | +
+ .labels = .labels,+ |
+
| 163 | +1x | +
+ .indent_mods = .indent_mods+ |
+
| 164 | ++ |
+ )+ |
+
| 165 | +1x | +
+ lyt <- split_rows_by(lyt, var = var)+ |
+
| 166 | +1x | +
+ lyt <- summarize_row_groups(lyt, na_str = na_str)+ |
+
| 167 | ++ | + + | +
| 168 | +1x | +
+ analyze(+ |
+
| 169 | +1x | +
+ lyt,+ |
+
| 170 | +1x | +
+ vars = var,+ |
+
| 171 | +1x | +
+ afun = afun,+ |
+
| 172 | +1x | +
+ show_labels = show_labels,+ |
+
| 173 | +1x | +
+ table_names = table_names,+ |
+
| 174 | +1x | +
+ na_str = na_str,+ |
+
| 175 | +1x | +
+ nested = nested,+ |
+
| 176 | +1x | +
+ extra_args = list(...)+ |
+
| 177 | ++ |
+ )+ |
+
| 178 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Line plot with the optional table+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Line plot with the optional table.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param df (`data.frame`)\cr data set containing all analysis variables.+ |
+
| 8 | ++ |
+ #' @param alt_counts_df (`data.frame` or `NULL`)\cr data set that will be used (only) to counts objects in strata.+ |
+
| 9 | ++ |
+ #' @param variables (named `character` vector) of variable names in `df` data set. Details are:+ |
+
| 10 | ++ |
+ #' * `x` (`character`)\cr name of x-axis variable.+ |
+
| 11 | ++ |
+ #' * `y` (`character`)\cr name of y-axis variable.+ |
+
| 12 | ++ |
+ #' * `strata` (`character`)\cr name of grouping variable, i.e. treatment arm. Can be `NA` to indicate lack of groups.+ |
+
| 13 | ++ |
+ #' * `cohort_id` (`character`)\cr name of the variable that identifies group belonging. Only applies if `strata` is+ |
+
| 14 | ++ |
+ #' not NULL.+ |
+
| 15 | ++ |
+ #' * `paramcd` (`character`)\cr name of the variable for parameter's code. Used for y-axis label and plot's subtitle.+ |
+
| 16 | ++ |
+ #' Can be `NA` if `paramcd` is not to be added to the y-axis label or subtitle.+ |
+
| 17 | ++ |
+ #' * `y_unit` (`character`)\cr name of variable with units of `y`. Used for y-axis label and plot's subtitle.+ |
+
| 18 | ++ |
+ #' Can be `NA` if y unit is not to be added to the y-axis label or subtitle.+ |
+
| 19 | ++ |
+ #' @param mid (`character` or `NULL`)\cr names of the statistics that will be plotted as midpoints.+ |
+
| 20 | ++ |
+ #' All the statistics indicated in `mid` variable must be present in the object returned by `sfun`,+ |
+
| 21 | ++ |
+ #' and be of a `double` or `numeric` type vector of length one.+ |
+
| 22 | ++ |
+ #' @param interval (`character` or `NULL`)\cr names of the statistics that will be plotted as intervals.+ |
+
| 23 | ++ |
+ #' All the statistics indicated in `interval` variable must be present in the object returned by `sfun`,+ |
+
| 24 | ++ |
+ #' and be of a `double` or `numeric` type vector of length two.+ |
+
| 25 | ++ |
+ #' @param whiskers (`character`)\cr names of the interval whiskers that will be plotted. Must match the `names`+ |
+
| 26 | ++ |
+ #' attribute of the `interval` element in the list returned by `sfun`. It is possible to specify one whisker only,+ |
+
| 27 | ++ |
+ #' lower or upper.+ |
+
| 28 | ++ |
+ #' @param table (`character` or `NULL`)\cr names of the statistics that will be displayed in the table below the plot.+ |
+
| 29 | ++ |
+ #' All the statistics indicated in `table` variable must be present in the object returned by `sfun`.+ |
+
| 30 | ++ |
+ #' @param sfun (`closure`)\cr the function to compute the values of required statistics. It must return a named `list`+ |
+
| 31 | ++ |
+ #' with atomic vectors. The names of the `list` elements refer to the names of the statistics and are used by `mid`,+ |
+
| 32 | ++ |
+ #' `interval`, `table`. It must be able to accept as input a vector with data for which statistics are computed.+ |
+
| 33 | ++ |
+ #' @param ... optional arguments to `sfun`.+ |
+
| 34 | ++ |
+ #' @param mid_type (`character`)\cr controls the type of the `mid` plot, it can be point (`p`), line (`l`),+ |
+
| 35 | ++ |
+ #' or point and line (`pl`).+ |
+
| 36 | ++ |
+ #' @param mid_point_size (`integer` or `double`)\cr controls the font size of the point for `mid` plot.+ |
+
| 37 | ++ |
+ #' @param position (`character` or `call`)\cr geom element position adjustment, either as a string, or the result of+ |
+
| 38 | ++ |
+ #' a call to a position adjustment function.+ |
+
| 39 | ++ |
+ #' @param legend_title (`character` string)\cr legend title.+ |
+
| 40 | ++ |
+ #' @param legend_position (`character`)\cr the position of the plot legend (`none`, `left`, `right`, `bottom`, `top`,+ |
+
| 41 | ++ |
+ #' or two-element numeric vector).+ |
+
| 42 | ++ |
+ #' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot.+ |
+
| 43 | ++ |
+ #' @param y_lab (`character`)\cr y-axis label. If equal to `NULL`, then no label will be added.+ |
+
| 44 | ++ |
+ #' @param y_lab_add_paramcd (`logical`)\cr should `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` be added to the+ |
+
| 45 | ++ |
+ #' y-axis label `y_lab`?+ |
+
| 46 | ++ |
+ #' @param y_lab_add_unit (`logical`)\cr should y unit, i.e. `unique(df[[variables["y_unit"]]])` be added to the y-axis+ |
+
| 47 | ++ |
+ #' label `y_lab`?+ |
+
| 48 | ++ |
+ #' @param title (`character`)\cr plot title.+ |
+
| 49 | ++ |
+ #' @param subtitle (`character`)\cr plot subtitle.+ |
+
| 50 | ++ |
+ #' @param subtitle_add_paramcd (`logical`)\cr should `paramcd`, i.e. `unique(df[[variables["paramcd"]]])` be added to+ |
+
| 51 | ++ |
+ #' the plot's subtitle `subtitle`?+ |
+
| 52 | ++ |
+ #' @param subtitle_add_unit (`logical`)\cr should y unit, i.e. `unique(df[[variables["y_unit"]]])` be added to the+ |
+
| 53 | ++ |
+ #' plot's subtitle `subtitle`?+ |
+
| 54 | ++ |
+ #' @param caption (`character`)\cr optional caption below the plot.+ |
+
| 55 | ++ |
+ #' @param table_format (named `character` or `NULL`)\cr format patterns for descriptive statistics used in the+ |
+
| 56 | ++ |
+ #' (optional) table appended to the plot. It is passed directly to the `h_format_row` function through the `format`+ |
+
| 57 | ++ |
+ #' parameter. Names of `table_format` must match the names of statistics returned by `sfun` function.+ |
+
| 58 | ++ |
+ #' @param table_labels (named `character` or `NULL`)\cr labels for descriptive statistics used in the (optional) table+ |
+
| 59 | ++ |
+ #' appended to the plot. Names of `table_labels` must match the names of statistics returned by `sfun` function.+ |
+
| 60 | ++ |
+ #' @param table_font_size (`integer` or `double`)\cr controls the font size of values in the table.+ |
+
| 61 | ++ |
+ #' @param newpage (`logical`)\cr should plot be drawn on new page?+ |
+
| 62 | ++ |
+ #' @param col (`character`)\cr colors.+ |
+
| 63 | ++ |
+ #'+ |
+
| 64 | ++ |
+ #' @return A `ggplot` line plot (and statistics table if applicable).+ |
+
| 65 | ++ |
+ #'+ |
+
| 66 | ++ |
+ #' @examples+ |
+
| 67 | ++ |
+ #' library(nestcolor)+ |
+
| 68 | ++ |
+ #'+ |
+
| 69 | ++ |
+ #' adsl <- tern_ex_adsl+ |
+
| 70 | ++ |
+ #' adlb <- tern_ex_adlb %>% dplyr::filter(ANL01FL == "Y", PARAMCD == "ALT", AVISIT != "SCREENING")+ |
+
| 71 | ++ |
+ #' adlb$AVISIT <- droplevels(adlb$AVISIT)+ |
+
| 72 | ++ |
+ #' adlb <- dplyr::mutate(adlb, AVISIT = forcats::fct_reorder(AVISIT, AVISITN, min))+ |
+
| 73 | ++ |
+ #'+ |
+
| 74 | ++ |
+ #' # Mean with CI+ |
+
| 75 | ++ |
+ #' g_lineplot(adlb, adsl, subtitle = "Laboratory Test:")+ |
+
| 76 | ++ |
+ #'+ |
+
| 77 | ++ |
+ #' # Mean with CI, no stratification+ |
+
| 78 | ++ |
+ #' g_lineplot(adlb, variables = control_lineplot_vars(strata = NA))+ |
+
| 79 | ++ |
+ #'+ |
+
| 80 | ++ |
+ #' # Mean, upper whisker of CI, no strata counts N+ |
+
| 81 | ++ |
+ #' g_lineplot(+ |
+
| 82 | ++ |
+ #' adlb,+ |
+
| 83 | ++ |
+ #' whiskers = "mean_ci_upr",+ |
+
| 84 | ++ |
+ #' title = "Plot of Mean and Upper 95% Confidence Limit by Visit"+ |
+
| 85 | ++ |
+ #' )+ |
+
| 86 | ++ |
+ #'+ |
+
| 87 | ++ |
+ #' # Median with CI+ |
+
| 88 | ++ |
+ #' g_lineplot(+ |
+
| 89 | ++ |
+ #' adlb,+ |
+
| 90 | ++ |
+ #' adsl,+ |
+
| 91 | ++ |
+ #' mid = "median",+ |
+
| 92 | ++ |
+ #' interval = "median_ci",+ |
+
| 93 | ++ |
+ #' whiskers = c("median_ci_lwr", "median_ci_upr"),
+ |
+
| 94 | ++ |
+ #' title = "Plot of Median and 95% Confidence Limits by Visit"+ |
+
| 95 | ++ |
+ #' )+ |
+
| 96 | ++ |
+ #'+ |
+
| 97 | ++ |
+ #' # Mean, +/- SD+ |
+
| 98 | ++ |
+ #' g_lineplot(adlb, adsl,+ |
+
| 99 | ++ |
+ #' interval = "mean_sdi",+ |
+
| 100 | ++ |
+ #' whiskers = c("mean_sdi_lwr", "mean_sdi_upr"),
+ |
+
| 101 | ++ |
+ #' title = "Plot of Median +/- SD by Visit"+ |
+
| 102 | ++ |
+ #' )+ |
+
| 103 | ++ |
+ #'+ |
+
| 104 | ++ |
+ #' # Mean with CI plot with stats table+ |
+
| 105 | ++ |
+ #' g_lineplot(adlb, adsl, table = c("n", "mean", "mean_ci"))
+ |
+
| 106 | ++ |
+ #'+ |
+
| 107 | ++ |
+ #' # Mean with CI, table and customized confidence level+ |
+
| 108 | ++ |
+ #' g_lineplot(+ |
+
| 109 | ++ |
+ #' adlb,+ |
+
| 110 | ++ |
+ #' adsl,+ |
+
| 111 | ++ |
+ #' table = c("n", "mean", "mean_ci"),
+ |
+
| 112 | ++ |
+ #' control = control_analyze_vars(conf_level = 0.80),+ |
+
| 113 | ++ |
+ #' title = "Plot of Mean and 80% Confidence Limits by Visit"+ |
+
| 114 | ++ |
+ #' )+ |
+
| 115 | ++ |
+ #'+ |
+
| 116 | ++ |
+ #' # Mean with CI, table, filtered data+ |
+
| 117 | ++ |
+ #' adlb_f <- dplyr::filter(adlb, ARMCD != "ARM A" | AVISIT == "BASELINE")+ |
+
| 118 | ++ |
+ #' g_lineplot(adlb_f, table = c("n", "mean"))
+ |
+
| 119 | ++ |
+ #'+ |
+
| 120 | ++ |
+ #' @export+ |
+
| 121 | ++ |
+ g_lineplot <- function(df,+ |
+
| 122 | ++ |
+ alt_counts_df = NULL,+ |
+
| 123 | ++ |
+ variables = control_lineplot_vars(),+ |
+
| 124 | ++ |
+ mid = "mean",+ |
+
| 125 | ++ |
+ interval = "mean_ci",+ |
+
| 126 | ++ |
+ whiskers = c("mean_ci_lwr", "mean_ci_upr"),
+ |
+
| 127 | ++ |
+ table = NULL,+ |
+
| 128 | ++ |
+ sfun = tern::s_summary,+ |
+
| 129 | ++ |
+ ...,+ |
+
| 130 | ++ |
+ mid_type = "pl",+ |
+
| 131 | ++ |
+ mid_point_size = 2,+ |
+
| 132 | ++ |
+ position = ggplot2::position_dodge(width = 0.4),+ |
+
| 133 | ++ |
+ legend_title = NULL,+ |
+
| 134 | ++ |
+ legend_position = "bottom",+ |
+
| 135 | ++ |
+ ggtheme = nestcolor::theme_nest(),+ |
+
| 136 | ++ |
+ y_lab = NULL,+ |
+
| 137 | ++ |
+ y_lab_add_paramcd = TRUE,+ |
+
| 138 | ++ |
+ y_lab_add_unit = TRUE,+ |
+
| 139 | ++ |
+ title = "Plot of Mean and 95% Confidence Limits by Visit",+ |
+
| 140 | ++ |
+ subtitle = "",+ |
+
| 141 | ++ |
+ subtitle_add_paramcd = TRUE,+ |
+
| 142 | ++ |
+ subtitle_add_unit = TRUE,+ |
+
| 143 | ++ |
+ caption = NULL,+ |
+
| 144 | ++ |
+ table_format = summary_formats(),+ |
+
| 145 | ++ |
+ table_labels = summary_labels(),+ |
+
| 146 | ++ |
+ table_font_size = 3,+ |
+
| 147 | ++ |
+ newpage = TRUE,+ |
+
| 148 | ++ |
+ col = NULL) {
+ |
+
| 149 | +3x | +
+ checkmate::assert_character(variables, any.missing = TRUE)+ |
+
| 150 | +3x | +
+ checkmate::assert_character(mid, null.ok = TRUE)+ |
+
| 151 | +3x | +
+ checkmate::assert_character(interval, null.ok = TRUE)+ |
+
| 152 | +3x | +
+ checkmate::assert_character(col, null.ok = TRUE)+ |
+
| 153 | ++ | + + | +
| 154 | +3x | +
+ checkmate::assert_string(title, null.ok = TRUE)+ |
+
| 155 | +3x | +
+ checkmate::assert_string(subtitle, null.ok = TRUE)+ |
+
| 156 | ++ | + + | +
| 157 | +3x | +
+ if (is.character(interval)) {
+ |
+
| 158 | +3x | +
+ checkmate::assert_vector(whiskers, min.len = 0, max.len = 2)+ |
+
| 159 | ++ |
+ }+ |
+
| 160 | ++ | + + | +
| 161 | +3x | +
+ if (length(whiskers) == 1) {
+ |
+
| 162 | +! | +
+ checkmate::assert_character(mid)+ |
+
| 163 | ++ |
+ }+ |
+
| 164 | ++ | + + | +
| 165 | +3x | +
+ if (is.character(mid)) {
+ |
+
| 166 | +3x | +
+ checkmate::assert_scalar(mid_type)+ |
+
| 167 | +3x | +
+ checkmate::assert_subset(mid_type, c("pl", "p", "l"))
+ |
+
| 168 | ++ |
+ }+ |
+
| 169 | ++ | + + | +
| 170 | +3x | +
+ x <- variables[["x"]]+ |
+
| 171 | +3x | +
+ y <- variables[["y"]]+ |
+
| 172 | +3x | +
+ paramcd <- variables["paramcd"] # NA if paramcd == NA or it is not in variables+ |
+
| 173 | +3x | +
+ y_unit <- variables["y_unit"] # NA if y_unit == NA or it is not in variables+ |
+
| 174 | +3x | +
+ if (is.na(variables["strata"])) {
+ |
+
| 175 | +! | +
+ strata <- NULL # NULL if strata == NA or it is not in variables+ |
+
| 176 | ++ |
+ } else {
+ |
+
| 177 | +3x | +
+ strata <- variables[["strata"]]+ |
+
| 178 | +3x | +
+ cohort_id <- variables[["cohort_id"]]+ |
+
| 179 | ++ |
+ }+ |
+
| 180 | +3x | +
+ checkmate::assert_flag(y_lab_add_paramcd, null.ok = TRUE)+ |
+
| 181 | +3x | +
+ checkmate::assert_flag(subtitle_add_paramcd, null.ok = TRUE)+ |
+
| 182 | +3x | +
+ if ((!is.null(y_lab) && y_lab_add_paramcd) || (!is.null(subtitle) && subtitle_add_paramcd)) {
+ |
+
| 183 | +3x | +
+ checkmate::assert_false(is.na(paramcd))+ |
+
| 184 | +3x | +
+ checkmate::assert_scalar(unique(df[[paramcd]]))+ |
+
| 185 | ++ |
+ }+ |
+
| 186 | ++ | + + | +
| 187 | +3x | +
+ checkmate::assert_flag(y_lab_add_unit, null.ok = TRUE)+ |
+
| 188 | +3x | +
+ checkmate::assert_flag(subtitle_add_unit, null.ok = TRUE)+ |
+
| 189 | +3x | +
+ if ((!is.null(y_lab) && y_lab_add_unit) || (!is.null(subtitle) && subtitle_add_unit)) {
+ |
+
| 190 | +3x | +
+ checkmate::assert_false(is.na(y_unit))+ |
+
| 191 | +3x | +
+ checkmate::assert_scalar(unique(df[[y_unit]]))+ |
+
| 192 | ++ |
+ }+ |
+
| 193 | ++ | + + | +
| 194 | +3x | +
+ if (!is.null(strata) && !is.null(alt_counts_df)) {
+ |
+
| 195 | +3x | +
+ checkmate::assert_set_equal(unique(alt_counts_df[[strata]]), unique(df[[strata]]))+ |
+
| 196 | ++ |
+ }+ |
+
| 197 | ++ | + + | +
| 198 | ++ |
+ ####################################### |+ |
+
| 199 | ++ |
+ # ---- Compute required statistics ----+ |
+
| 200 | ++ |
+ ####################################### |+ |
+
| 201 | +3x | +
+ if (!is.null(strata)) {
+ |
+
| 202 | +3x | +
+ df_grp <- tidyr::expand(df, .data[[strata]], .data[[x]]) # expand based on levels of factors+ |
+
| 203 | ++ |
+ } else {
+ |
+
| 204 | +! | +
+ df_grp <- tidyr::expand(df, NULL, .data[[x]])+ |
+
| 205 | ++ |
+ }+ |
+
| 206 | +3x | +
+ df_grp <- df_grp %>%+ |
+
| 207 | +3x | +
+ dplyr::full_join(y = df[, c(strata, x, y)], by = c(strata, x), multiple = "all") %>%+ |
+
| 208 | +3x | +
+ dplyr::group_by_at(c(strata, x))+ |
+
| 209 | ++ | + + | +
| 210 | +3x | +
+ df_stats <- df_grp %>%+ |
+
| 211 | +3x | +
+ dplyr::summarise(+ |
+
| 212 | +3x | +
+ data.frame(t(do.call(c, unname(sfun(.data[[y]], ...)[c(mid, interval)])))),+ |
+
| 213 | +3x | +
+ .groups = "drop"+ |
+
| 214 | ++ |
+ )+ |
+
| 215 | ++ | + + | +
| 216 | +3x | +
+ df_stats <- df_stats[!is.na(df_stats[[mid]]), ]+ |
+
| 217 | ++ | + + | +
| 218 | ++ |
+ # add number of objects N in strata+ |
+
| 219 | +3x | +
+ if (!is.null(strata) && !is.null(alt_counts_df)) {
+ |
+
| 220 | +3x | +
+ strata_N <- paste0(strata, "_N") # nolint+ |
+
| 221 | ++ | + + | +
| 222 | +3x | +
+ df_N <- stats::aggregate(eval(parse(text = cohort_id)) ~ eval(parse(text = strata)), data = alt_counts_df, FUN = function(x) length(unique(x))) # nolint+ |
+
| 223 | +3x | +
+ colnames(df_N) <- c(strata, "N") # nolint+ |
+
| 224 | +3x | +
+ df_N[[strata_N]] <- paste0(df_N[[strata]], " (N = ", df_N$N, ")") # nolint+ |
+
| 225 | ++ | + + | +
| 226 | ++ |
+ # strata_N should not be in clonames(df_stats)+ |
+
| 227 | +3x | +
+ checkmate::assert_disjunct(strata_N, colnames(df_stats))+ |
+
| 228 | ++ | + + | +
| 229 | +3x | +
+ df_stats <- merge(x = df_stats, y = df_N[, c(strata, strata_N)], by = strata)+ |
+
| 230 | +! | +
+ } else if (!is.null(strata)) {
+ |
+
| 231 | +! | +
+ strata_N <- strata # nolint+ |
+
| 232 | ++ |
+ } else {
+ |
+
| 233 | +! | +
+ strata_N <- NULL # nolint+ |
+
| 234 | ++ |
+ }+ |
+
| 235 | ++ | + + | +
| 236 | ++ |
+ ############################################### |+ |
+
| 237 | ++ |
+ # ---- Prepare certain plot's properties. ----+ |
+
| 238 | ++ |
+ ############################################### |+ |
+
| 239 | ++ |
+ # legend title+ |
+
| 240 | +3x | +
+ if (is.null(legend_title) && !is.null(strata) && legend_position != "none") {
+ |
+
| 241 | +3x | +
+ legend_title <- attr(df[[strata]], "label")+ |
+
| 242 | ++ |
+ }+ |
+
| 243 | ++ | + + | +
| 244 | ++ |
+ # y label+ |
+
| 245 | +3x | +
+ if (!is.null(y_lab)) {
+ |
+
| 246 | +2x | +
+ if (y_lab_add_paramcd) {
+ |
+
| 247 | +2x | +
+ y_lab <- paste(y_lab, unique(df[[paramcd]]))+ |
+
| 248 | ++ |
+ }+ |
+
| 249 | ++ | + + | +
| 250 | +2x | +
+ if (y_lab_add_unit) {
+ |
+
| 251 | +2x | +
+ y_lab <- paste0(y_lab, " (", unique(df[[y_unit]]), ")")
+ |
+
| 252 | ++ |
+ }+ |
+
| 253 | ++ | + + | +
| 254 | +2x | +
+ y_lab <- trimws(y_lab)+ |
+
| 255 | ++ |
+ }+ |
+
| 256 | ++ | + + | +
| 257 | ++ |
+ # subtitle+ |
+
| 258 | +3x | +
+ if (!is.null(subtitle)) {
+ |
+
| 259 | +3x | +
+ if (subtitle_add_paramcd) {
+ |
+
| 260 | +3x | +
+ subtitle <- paste(subtitle, unique(df[[paramcd]]))+ |
+
| 261 | ++ |
+ }+ |
+
| 262 | ++ | + + | +
| 263 | +3x | +
+ if (subtitle_add_unit) {
+ |
+
| 264 | +3x | +
+ subtitle <- paste0(subtitle, " (", unique(df[[y_unit]]), ")")
+ |
+
| 265 | ++ |
+ }+ |
+
| 266 | ++ | + + | +
| 267 | +3x | +
+ subtitle <- trimws(subtitle)+ |
+
| 268 | ++ |
+ }+ |
+
| 269 | ++ | + + | +
| 270 | ++ |
+ ############################### |+ |
+
| 271 | ++ |
+ # ---- Build plot object. ----+ |
+
| 272 | ++ |
+ ############################### |+ |
+
| 273 | +3x | +
+ p <- ggplot2::ggplot(+ |
+
| 274 | +3x | +
+ data = df_stats,+ |
+
| 275 | +3x | +
+ mapping = ggplot2::aes(+ |
+
| 276 | +3x | +
+ x = .data[[x]], y = .data[[mid]],+ |
+
| 277 | +3x | +
+ color = if (is.null(strata_N)) NULL else .data[[strata_N]],+ |
+
| 278 | +3x | +
+ shape = if (is.null(strata_N)) NULL else .data[[strata_N]],+ |
+
| 279 | +3x | +
+ lty = if (is.null(strata_N)) NULL else .data[[strata_N]],+ |
+
| 280 | +3x | +
+ group = if (is.null(strata_N)) NULL else .data[[strata_N]]+ |
+
| 281 | ++ |
+ )+ |
+
| 282 | ++ |
+ )+ |
+
| 283 | ++ | + + | +
| 284 | +3x | +
+ if (!is.null(mid)) {
+ |
+
| 285 | ++ |
+ # points+ |
+
| 286 | +3x | +
+ if (grepl("p", mid_type, fixed = TRUE)) {
+ |
+
| 287 | +3x | +
+ p <- p + ggplot2::geom_point(position = position, size = mid_point_size, na.rm = TRUE)+ |
+
| 288 | ++ |
+ }+ |
+
| 289 | ++ | + + | +
| 290 | ++ |
+ # lines+ |
+
| 291 | ++ |
+ # further conditions in if are to ensure that not all of the groups consist of only one observation+ |
+
| 292 | +3x | +
+ if (grepl("l", mid_type, fixed = TRUE) && !is.null(strata) &&
+ |
+
| 293 | +3x | +
+ !all(dplyr::summarise(df_grp, count_n = dplyr::n())[["count_n"]] == 1L)) { # nolint
+ |
+
| 294 | +3x | +
+ p <- p + ggplot2::geom_line(position = position, na.rm = TRUE)+ |
+
| 295 | ++ |
+ }+ |
+
| 296 | ++ |
+ }+ |
+
| 297 | ++ | + + | +
| 298 | ++ |
+ # interval+ |
+
| 299 | +3x | +
+ if (!is.null(interval)) {
+ |
+
| 300 | +3x | +
+ p <- p ++ |
+
| 301 | +3x | +
+ ggplot2::geom_errorbar(+ |
+
| 302 | +3x | +
+ ggplot2::aes(ymin = .data[[whiskers[1]]], ymax = .data[[whiskers[max(1, length(whiskers))]]]),+ |
+
| 303 | +3x | +
+ width = 0.45,+ |
+
| 304 | +3x | +
+ position = position+ |
+
| 305 | ++ |
+ )+ |
+
| 306 | ++ | + + | +
| 307 | +3x | +
+ if (length(whiskers) == 1) { # lwr or upr only; mid is then required
+ |
+
| 308 | ++ |
+ # workaround as geom_errorbar does not provide single-direction whiskers+ |
+
| 309 | +! | +
+ p <- p ++ |
+
| 310 | +! | +
+ ggplot2::geom_linerange(+ |
+
| 311 | +! | +
+ data = df_stats[!is.na(df_stats[[whiskers]]), ], # as na.rm =TRUE does not suppress warnings+ |
+
| 312 | +! | +
+ ggplot2::aes(ymin = .data[[mid]], ymax = .data[[whiskers]]),+ |
+
| 313 | +! | +
+ position = position,+ |
+
| 314 | +! | +
+ na.rm = TRUE,+ |
+
| 315 | +! | +
+ show.legend = FALSE+ |
+
| 316 | ++ |
+ )+ |
+
| 317 | ++ |
+ }+ |
+
| 318 | ++ |
+ }+ |
+
| 319 | ++ | + + | +
| 320 | +3x | +
+ p <- p ++ |
+
| 321 | +3x | +
+ ggplot2::scale_y_continuous(labels = scales::comma, expand = ggplot2::expansion(c(0.25, .25))) ++ |
+
| 322 | +3x | +
+ ggplot2::labs(+ |
+
| 323 | +3x | +
+ title = title,+ |
+
| 324 | +3x | +
+ subtitle = subtitle,+ |
+
| 325 | +3x | +
+ caption = caption,+ |
+
| 326 | +3x | +
+ color = legend_title,+ |
+
| 327 | +3x | +
+ lty = legend_title,+ |
+
| 328 | +3x | +
+ shape = legend_title,+ |
+
| 329 | +3x | +
+ x = attr(df[[x]], "label"),+ |
+
| 330 | +3x | +
+ y = y_lab+ |
+
| 331 | ++ |
+ )+ |
+
| 332 | ++ | + + | +
| 333 | +3x | +
+ if (!is.null(col)) {
+ |
+
| 334 | +! | +
+ p <- p ++ |
+
| 335 | +! | +
+ ggplot2::scale_color_manual(values = col)+ |
+
| 336 | ++ |
+ }+ |
+
| 337 | ++ | + + | +
| 338 | +3x | +
+ if (!is.null(ggtheme)) {
+ |
+
| 339 | +3x | +
+ p <- p + ggtheme+ |
+
| 340 | ++ |
+ } else {
+ |
+
| 341 | +! | +
+ p <- p ++ |
+
| 342 | +! | +
+ ggplot2::theme_bw() ++ |
+
| 343 | +! | +
+ ggplot2::theme(+ |
+
| 344 | +! | +
+ legend.key.width = grid::unit(1, "cm"),+ |
+
| 345 | +! | +
+ legend.position = legend_position,+ |
+
| 346 | +! | +
+ legend.direction = ifelse(+ |
+
| 347 | +! | +
+ legend_position %in% c("top", "bottom"),
+ |
+
| 348 | +! | +
+ "horizontal",+ |
+
| 349 | +! | +
+ "vertical"+ |
+
| 350 | ++ |
+ )+ |
+
| 351 | ++ |
+ )+ |
+
| 352 | ++ |
+ }+ |
+
| 353 | ++ | + + | +
| 354 | ++ |
+ ############################################################# |+ |
+
| 355 | ++ |
+ # ---- Optionally, add table to the bottom of the plot. ----+ |
+
| 356 | ++ |
+ ############################################################# |+ |
+
| 357 | +3x | +
+ if (!is.null(table)) {
+ |
+
| 358 | +2x | +
+ df_stats_table <- df_grp %>%+ |
+
| 359 | +2x | +
+ dplyr::summarise(+ |
+
| 360 | +2x | +
+ h_format_row(+ |
+
| 361 | +2x | +
+ x = sfun(.data[[y]], ...)[table],+ |
+
| 362 | +2x | +
+ format = table_format,+ |
+
| 363 | +2x | +
+ labels = table_labels+ |
+
| 364 | ++ |
+ ),+ |
+
| 365 | +2x | +
+ .groups = "drop"+ |
+
| 366 | ++ |
+ )+ |
+
| 367 | ++ | + + | +
| 368 | +2x | +
+ stats_lev <- rev(setdiff(colnames(df_stats_table), c(strata, x)))+ |
+
| 369 | ++ | + + | +
| 370 | +2x | +
+ df_stats_table <- df_stats_table %>%+ |
+
| 371 | +2x | +
+ tidyr::pivot_longer(+ |
+
| 372 | +2x | +
+ cols = -dplyr::all_of(c(strata, x)),+ |
+
| 373 | +2x | +
+ names_to = "stat",+ |
+
| 374 | +2x | +
+ values_to = "value",+ |
+
| 375 | +2x | +
+ names_ptypes = list(stat = factor(levels = stats_lev))+ |
+
| 376 | ++ |
+ )+ |
+
| 377 | ++ | + + | +
| 378 | +2x | +
+ tbl <- ggplot2::ggplot(+ |
+
| 379 | +2x | +
+ df_stats_table,+ |
+
| 380 | +2x | +
+ ggplot2::aes(x = .data[[x]], y = .data[["stat"]], label = .data[["value"]])+ |
+
| 381 | ++ |
+ ) ++ |
+
| 382 | +2x | +
+ ggplot2::geom_text(size = table_font_size) ++ |
+
| 383 | +2x | +
+ ggplot2::theme_bw() ++ |
+
| 384 | +2x | +
+ ggplot2::theme(+ |
+
| 385 | +2x | +
+ panel.border = ggplot2::element_blank(),+ |
+
| 386 | +2x | +
+ panel.grid.major = ggplot2::element_blank(),+ |
+
| 387 | +2x | +
+ panel.grid.minor = ggplot2::element_blank(),+ |
+
| 388 | +2x | +
+ axis.ticks = ggplot2::element_blank(),+ |
+
| 389 | +2x | +
+ axis.title = ggplot2::element_blank(),+ |
+
| 390 | +2x | +
+ axis.text.x = ggplot2::element_blank(),+ |
+
| 391 | +2x | +
+ axis.text.y = ggplot2::element_text(margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 5)),+ |
+
| 392 | +2x | +
+ strip.text = ggplot2::element_text(hjust = 0),+ |
+
| 393 | +2x | +
+ strip.text.x = ggplot2::element_text(margin = ggplot2::margin(1.5, 0, 1.5, 0, "pt")),+ |
+
| 394 | +2x | +
+ strip.background = ggplot2::element_rect(fill = "grey95", color = NA),+ |
+
| 395 | +2x | +
+ legend.position = "none"+ |
+
| 396 | ++ |
+ )+ |
+
| 397 | ++ | + + | +
| 398 | +2x | +
+ if (!is.null(strata)) {
+ |
+
| 399 | +2x | +
+ tbl <- tbl + ggplot2::facet_wrap(facets = strata, ncol = 1)+ |
+
| 400 | ++ |
+ }+ |
+
| 401 | ++ | + + | +
| 402 | ++ |
+ # align plot and table+ |
+
| 403 | +2x | +
+ cowplot::plot_grid(p, tbl, ncol = 1)+ |
+
| 404 | ++ |
+ } else {
+ |
+
| 405 | +1x | +
+ p+ |
+
| 406 | ++ |
+ }+ |
+
| 407 | ++ |
+ }+ |
+
| 408 | ++ | + + | +
| 409 | ++ |
+ #' Helper function to get the right formatting in the optional table in `g_lineplot`.+ |
+
| 410 | ++ |
+ #'+ |
+
| 411 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 412 | ++ |
+ #'+ |
+
| 413 | ++ |
+ #' @param x (named `list`)\cr list of numerical values to be formatted and optionally labeled.+ |
+
| 414 | ++ |
+ #' Elements of `x` must be `numeric` vectors.+ |
+
| 415 | ++ |
+ #' @param format (named `character` or `NULL`)\cr format patterns for `x`. Names of the `format` must+ |
+
| 416 | ++ |
+ #' match the names of `x`. This parameter is passed directly to the `rtables::format_rcell`+ |
+
| 417 | ++ |
+ #' function through the `format` parameter.+ |
+
| 418 | ++ |
+ #' @param labels (named `character` or `NULL`)\cr optional labels for `x`. Names of the `labels` must+ |
+
| 419 | ++ |
+ #' match the names of `x`. When a label is not specified for an element of `x`,+ |
+
| 420 | ++ |
+ #' then this function tries to use `label` or `names` (in this order) attribute of that element+ |
+
| 421 | ++ |
+ #' (depending on which one exists and it is not `NULL` or `NA` or `NaN`). If none of these attributes+ |
+
| 422 | ++ |
+ #' are attached to a given element of `x`, then the label is automatically generated.+ |
+
| 423 | ++ |
+ #'+ |
+
| 424 | ++ |
+ #' @return A single row `data.frame` object.+ |
+
| 425 | ++ |
+ #'+ |
+
| 426 | ++ |
+ #' @examples+ |
+
| 427 | ++ |
+ #' mean_ci <- c(48, 51)+ |
+
| 428 | ++ |
+ #' x <- list(mean = 50, mean_ci = mean_ci)+ |
+
| 429 | ++ |
+ #' format <- c(mean = "xx.x", mean_ci = "(xx.xx, xx.xx)")+ |
+
| 430 | ++ |
+ #' labels <- c(mean = "My Mean")+ |
+
| 431 | ++ |
+ #' h_format_row(x, format, labels)+ |
+
| 432 | ++ |
+ #'+ |
+
| 433 | ++ |
+ #' attr(mean_ci, "label") <- "Mean 95% CI"+ |
+
| 434 | ++ |
+ #' x <- list(mean = 50, mean_ci = mean_ci)+ |
+
| 435 | ++ |
+ #' h_format_row(x, format, labels)+ |
+
| 436 | ++ |
+ #'+ |
+
| 437 | ++ |
+ #' @export+ |
+
| 438 | ++ |
+ h_format_row <- function(x, format, labels = NULL) {
+ |
+
| 439 | ++ |
+ # cell: one row, one column data.frame+ |
+
| 440 | +37x | +
+ format_cell <- function(x, format, label = NULL) {
+ |
+
| 441 | +110x | +
+ fc <- format_rcell(x = x, format = unlist(format))+ |
+
| 442 | +110x | +
+ if (is.na(fc)) {
+ |
+
| 443 | +! | +
+ fc <- "NA"+ |
+
| 444 | ++ |
+ }+ |
+
| 445 | +110x | +
+ x_label <- attr(x, "label")+ |
+
| 446 | +110x | +
+ if (!is.null(label) && !is.na(label)) {
+ |
+
| 447 | +109x | +
+ names(fc) <- label+ |
+
| 448 | +1x | +
+ } else if (!is.null(x_label) && !is.na(x_label)) {
+ |
+
| 449 | +! | +
+ names(fc) <- x_label+ |
+
| 450 | +1x | +
+ } else if (length(x) == length(fc)) {
+ |
+
| 451 | +! | +
+ names(fc) <- names(x)+ |
+
| 452 | ++ |
+ }+ |
+
| 453 | +110x | +
+ as.data.frame(t(fc))+ |
+
| 454 | ++ |
+ }+ |
+
| 455 | ++ | + + | +
| 456 | +37x | +
+ row <- do.call(+ |
+
| 457 | +37x | +
+ cbind,+ |
+
| 458 | +37x | +
+ lapply(+ |
+
| 459 | +37x | +
+ names(x), function(xn) format_cell(x[[xn]], format = format[xn], label = labels[xn])+ |
+
| 460 | ++ |
+ )+ |
+
| 461 | ++ |
+ )+ |
+
| 462 | ++ | + + | +
| 463 | +37x | +
+ row+ |
+
| 464 | ++ |
+ }+ |
+
| 465 | ++ | + + | +
| 466 | ++ |
+ #' Control Function for `g_lineplot` Function+ |
+
| 467 | ++ |
+ #'+ |
+
| 468 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 469 | ++ |
+ #'+ |
+
| 470 | ++ |
+ #' Default values for `variables` parameter in `g_lineplot` function.+ |
+
| 471 | ++ |
+ #' A variable's default value can be overwritten for any variable.+ |
+
| 472 | ++ |
+ #'+ |
+
| 473 | ++ |
+ #' @param x (`character`)\cr x variable name.+ |
+
| 474 | ++ |
+ #' @param y (`character`)\cr y variable name.+ |
+
| 475 | ++ |
+ #' @param strata (`character` or `NA`)\cr strata variable name.+ |
+
| 476 | ++ |
+ #' @param cohort_id (`character` or `NA`)\cr variable to identify subjects in cohorts.+ |
+
| 477 | ++ |
+ #' @param paramcd (`character` or `NA`)\cr `paramcd` variable name.+ |
+
| 478 | ++ |
+ #' @param y_unit (`character` or `NA`)\cr `y_unit` variable name.+ |
+
| 479 | ++ |
+ #'+ |
+
| 480 | ++ |
+ #' @return A named character vector of variable names.+ |
+
| 481 | ++ |
+ #'+ |
+
| 482 | ++ |
+ #' @examples+ |
+
| 483 | ++ |
+ #' control_lineplot_vars()+ |
+
| 484 | ++ |
+ #' control_lineplot_vars(strata = NA)+ |
+
| 485 | ++ |
+ #'+ |
+
| 486 | ++ |
+ #' @export+ |
+
| 487 | ++ |
+ control_lineplot_vars <- function(x = "AVISIT", y = "AVAL", strata = "ARM", paramcd = "PARAMCD", y_unit = "AVALU",+ |
+
| 488 | ++ |
+ cohort_id = "USUBJID") {
+ |
+
| 489 | +3x | +
+ checkmate::assert_string(x)+ |
+
| 490 | +3x | +
+ checkmate::assert_string(y)+ |
+
| 491 | +3x | +
+ checkmate::assert_string(strata, na.ok = TRUE)+ |
+
| 492 | +3x | +
+ checkmate::assert_string(cohort_id, na.ok = TRUE)+ |
+
| 493 | +3x | +
+ checkmate::assert_string(paramcd, na.ok = TRUE)+ |
+
| 494 | +3x | +
+ checkmate::assert_string(y_unit, na.ok = TRUE)+ |
+
| 495 | ++ | + + | +
| 496 | +3x | +
+ variables <- c(x = x, y = y, strata = strata, paramcd = paramcd, y_unit = y_unit, cohort_id = cohort_id)+ |
+
| 497 | +3x | +
+ return(variables)+ |
+
| 498 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Split Function to Configure Risk Difference Column+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Wrapper function for [rtables::add_combo_levels()] which configures settings for the risk difference+ |
+
| 6 | ++ |
+ #' column to be added to an `rtables` object. To add a risk difference column to a table, this function+ |
+
| 7 | ++ |
+ #' should be used as `split_fun` in calls to [rtables::split_cols_by()], followed by setting argument+ |
+
| 8 | ++ |
+ #' `riskdiff` to `TRUE` in all following analyze function calls.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @param arm_x (`character`)\cr Name of reference arm to use in risk difference calculations.+ |
+
| 11 | ++ |
+ #' @param arm_y (`character`)\cr Name of arm to compare to reference arm in risk difference calculations.+ |
+
| 12 | ++ |
+ #' @param col_label (`character`)\cr Label to use when rendering the risk difference column within the table.+ |
+
| 13 | ++ |
+ #' @param pct (`flag`)\cr whether output should be returned as percentages. Defaults to `TRUE`.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @return A closure suitable for use as a split function (`split_fun`) within [rtables::split_cols_by()]+ |
+
| 16 | ++ |
+ #' when creating a table layout.+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @seealso [stat_propdiff_ci()] for details on risk difference calculation.+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @examples+ |
+
| 21 | ++ |
+ #' adae <- tern_ex_adae+ |
+
| 22 | ++ |
+ #' adae$AESEV <- factor(adae$AESEV)+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 25 | ++ |
+ #' split_cols_by("ARMCD", split_fun = add_riskdiff(arm_x = "ARM A", arm_y = "ARM B")) %>%
+ |
+
| 26 | ++ |
+ #' count_occurrences_by_grade(+ |
+
| 27 | ++ |
+ #' var = "AESEV",+ |
+
| 28 | ++ |
+ #' riskdiff = TRUE+ |
+
| 29 | ++ |
+ #' )+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' tbl <- build_table(lyt, df = adae)+ |
+
| 32 | ++ |
+ #' tbl+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' @export+ |
+
| 35 | ++ |
+ add_riskdiff <- function(arm_x,+ |
+
| 36 | ++ |
+ arm_y,+ |
+
| 37 | ++ |
+ col_label = "Risk Difference (%) (95% CI)",+ |
+
| 38 | ++ |
+ pct = TRUE) {
+ |
+
| 39 | +6x | +
+ sapply(c(arm_x, arm_y, col_label), checkmate::assert_character, len = 1)+ |
+
| 40 | +6x | +
+ combodf <- tibble::tribble(+ |
+
| 41 | +6x | +
+ ~valname, ~label, ~levelcombo, ~exargs,+ |
+
| 42 | +6x | +
+ paste("riskdiff", arm_x, arm_y, sep = "_"), col_label, c(arm_x, arm_y), list()
+ |
+
| 43 | ++ |
+ )+ |
+
| 44 | +6x | +
+ if (pct) combodf$valname <- paste0(combodf$valname, "_pct")+ |
+
| 45 | +6x | +
+ add_combo_levels(combodf)+ |
+
| 46 | ++ |
+ }+ |
+
| 47 | ++ | + + | +
| 48 | ++ |
+ #' Analysis Function to Calculate Risk Difference Column Values+ |
+
| 49 | ++ |
+ #'+ |
+
| 50 | ++ |
+ #' In the risk difference column, this function uses the statistics function associated with `afun` to+ |
+
| 51 | ++ |
+ #' calculates risk difference values from arm X (reference group) and arm Y. These arms are specified+ |
+
| 52 | ++ |
+ #' when configuring the risk difference column which is done using the [add_riskdiff()] split function in+ |
+
| 53 | ++ |
+ #' the previous call to [rtables::split_cols_by()]. For all other columns, applies `afun` as usual. This+ |
+
| 54 | ++ |
+ #' function utilizes the [stat_propdiff_ci()] function to perform risk difference calculations.+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 57 | ++ |
+ #' @param afun (named `list`)\cr A named list containing one name-value pair where the name corresponds to+ |
+
| 58 | ++ |
+ #' the name of the statistics function that should be used in calculations and the value is the corresponding+ |
+
| 59 | ++ |
+ #' analysis function.+ |
+
| 60 | ++ |
+ #' @param s_args (named `list`)\cr Additional arguments to be passed to the statistics function and analysis+ |
+
| 61 | ++ |
+ #' function supplied in `afun`.+ |
+
| 62 | ++ |
+ #'+ |
+
| 63 | ++ |
+ #' @return A list of formatted [rtables::CellValue()].+ |
+
| 64 | ++ |
+ #'+ |
+
| 65 | ++ |
+ #' @seealso+ |
+
| 66 | ++ |
+ #' * [stat_propdiff_ci()] for details on risk difference calculation.+ |
+
| 67 | ++ |
+ #' * Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()] with+ |
+
| 68 | ++ |
+ #' `riskdiff` argument set to `TRUE` in subsequent analyze functions calls, adds a risk difference column+ |
+
| 69 | ++ |
+ #' to a table layout.+ |
+
| 70 | ++ |
+ #'+ |
+
| 71 | ++ |
+ #' @keywords internal+ |
+
| 72 | ++ |
+ afun_riskdiff <- function(df,+ |
+
| 73 | ++ |
+ labelstr = "",+ |
+
| 74 | ++ |
+ .var,+ |
+
| 75 | ++ |
+ .N_col, # nolint+ |
+
| 76 | ++ |
+ .N_row, # nolint+ |
+
| 77 | ++ |
+ .df_row,+ |
+
| 78 | ++ |
+ .spl_context,+ |
+
| 79 | ++ |
+ .all_col_counts,+ |
+
| 80 | ++ |
+ .stats,+ |
+
| 81 | ++ |
+ .indent_mods,+ |
+
| 82 | ++ |
+ afun,+ |
+
| 83 | ++ |
+ s_args = list()) {
+ |
+
| 84 | +36x | +
+ if (!any(grepl("riskdiff", names(.spl_context)))) {
+ |
+
| 85 | +! | +
+ stop(+ |
+
| 86 | +! | +
+ "Please set up levels to use in risk difference calculations using the `add_riskdiff` ",+ |
+
| 87 | +! | +
+ "split function within `split_cols_by`. See ?add_riskdiff for details."+ |
+
| 88 | ++ |
+ )+ |
+
| 89 | ++ |
+ }+ |
+
| 90 | +36x | +
+ checkmate::assert_list(afun, len = 1, types = "function")+ |
+
| 91 | +36x | +
+ checkmate::assert_named(afun)+ |
+
| 92 | ++ | + + | +
| 93 | +36x | +
+ afun_args <- list(.var = .var, .df_row = .df_row, .N_row = .N_row, denom = "N_col", labelstr = labelstr)+ |
+
| 94 | +36x | +
+ afun_args <- afun_args[intersect(names(afun_args), names(as.list(args(afun[[1]]))))]+ |
+
| 95 | +! | +
+ if ("denom" %in% names(s_args)) afun_args[["denom"]] <- NULL
+ |
+
| 96 | ++ | + + | +
| 97 | +36x | +
+ cur_split <- tail(.spl_context$cur_col_split_val[[1]], 1)+ |
+
| 98 | +36x | +
+ if (!grepl("^riskdiff", cur_split)) {
+ |
+
| 99 | ++ |
+ # Apply basic afun (no risk difference) in all other columns+ |
+
| 100 | +27x | +
+ do.call(afun[[1]], args = c(list(df = df, .N_col = .N_col), afun_args, s_args))+ |
+
| 101 | ++ |
+ } else {
+ |
+
| 102 | +9x | +
+ arm_x <- strsplit(cur_split, "_")[[1]][2]+ |
+
| 103 | +9x | +
+ arm_y <- strsplit(cur_split, "_")[[1]][3]+ |
+
| 104 | +9x | +
+ if (length(.spl_context$cur_col_split[[1]]) > 1) { # Different split name for nested column splits
+ |
+
| 105 | +! | +
+ arm_spl_x <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 2)], collapse = ""))
+ |
+
| 106 | +! | +
+ arm_spl_y <- gsub("riskdiff", "", paste0(strsplit(.spl_context$cur_col_id[1], "_")[[1]][c(1, 3)], collapse = ""))
+ |
+
| 107 | ++ |
+ } else {
+ |
+
| 108 | +9x | +
+ arm_spl_x <- arm_x+ |
+
| 109 | +9x | +
+ arm_spl_y <- arm_y+ |
+
| 110 | ++ |
+ }+ |
+
| 111 | +9x | +
+ N_col_x <- .all_col_counts[[arm_spl_x]] # nolint+ |
+
| 112 | +9x | +
+ N_col_y <- .all_col_counts[[arm_spl_y]] # nolint+ |
+
| 113 | +9x | +
+ cur_var <- tail(.spl_context$cur_col_split[[1]], 1)+ |
+
| 114 | ++ | + + | +
| 115 | ++ |
+ # Apply statistics function to arm X and arm Y data+ |
+
| 116 | +9x | +
+ s_x <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_x, ], .N_col = N_col_x), afun_args, s_args))+ |
+
| 117 | +9x | +
+ s_y <- do.call(names(afun), args = c(list(df = df[df[[cur_var]] == arm_y, ], .N_col = N_col_y), afun_args, s_args))+ |
+
| 118 | ++ | + + | +
| 119 | ++ |
+ # Get statistic name and row names+ |
+
| 120 | +9x | +
+ stat <- ifelse("count_fraction" %in% names(s_x), "count_fraction", "unique")
+ |
+
| 121 | +9x | +
+ if ("flag_variables" %in% names(s_args)) {
+ |
+
| 122 | +1x | +
+ var_nms <- s_args$flag_variables+ |
+
| 123 | +8x | +
+ } else if (!is.null(names(s_x[[stat]]))) {
+ |
+
| 124 | +2x | +
+ var_nms <- names(s_x[[stat]])+ |
+
| 125 | ++ |
+ } else {
+ |
+
| 126 | +6x | +
+ var_nms <- ""+ |
+
| 127 | +6x | +
+ s_x[[stat]] <- list(s_x[[stat]])+ |
+
| 128 | +6x | +
+ s_y[[stat]] <- list(s_y[[stat]])+ |
+
| 129 | ++ |
+ }+ |
+
| 130 | ++ | + + | +
| 131 | ++ |
+ # Calculate risk difference for each row, repeated if multiple statistics in table+ |
+
| 132 | +9x | +
+ pct <- tail(strsplit(cur_split, "_")[[1]], 1) == "pct"+ |
+
| 133 | +9x | +
+ rd_ci <- rep(stat_propdiff_ci(+ |
+
| 134 | +9x | +
+ lapply(s_x[[stat]], `[`, 1), lapply(s_y[[stat]], `[`, 1),+ |
+
| 135 | +9x | +
+ N_col_x, N_col_y,+ |
+
| 136 | +9x | +
+ list_names = var_nms,+ |
+
| 137 | +9x | +
+ pct = pct+ |
+
| 138 | +9x | +
+ ), max(1, length(.stats)))+ |
+
| 139 | ++ | + + | +
| 140 | +9x | +
+ in_rows(.list = rd_ci, .formats = "xx.x (xx.x - xx.x)", .indent_mods = .indent_mods)+ |
+
| 141 | ++ |
+ }+ |
+
| 142 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Combine Factor Levels+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Combine specified old factor Levels in a single new level.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param x factor+ |
+
| 8 | ++ |
+ #' @param levels level names to be combined+ |
+
| 9 | ++ |
+ #' @param new_level name of new level+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @return A `factor` with the new levels.+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' @examples+ |
+
| 14 | ++ |
+ #' x <- factor(letters[1:5], levels = letters[5:1])+ |
+
| 15 | ++ |
+ #' combine_levels(x, levels = c("a", "b"))
+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' combine_levels(x, c("e", "b"))
+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @export+ |
+
| 20 | ++ |
+ combine_levels <- function(x, levels, new_level = paste(levels, collapse = "/")) {
+ |
+
| 21 | +4x | +
+ checkmate::assert_factor(x)+ |
+
| 22 | +4x | +
+ checkmate::assert_subset(levels, levels(x))+ |
+
| 23 | ++ | + + | +
| 24 | +4x | +
+ lvls <- levels(x)+ |
+
| 25 | ++ | + + | +
| 26 | +4x | +
+ lvls[lvls %in% levels] <- new_level+ |
+
| 27 | ++ | + + | +
| 28 | +4x | +
+ levels(x) <- lvls+ |
+
| 29 | ++ | + + | +
| 30 | +4x | +
+ x+ |
+
| 31 | ++ |
+ }+ |
+
| 32 | ++ | + + | +
| 33 | ++ |
+ #' Conversion of a Vector to a Factor+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' Converts `x` to a factor and keeps its attributes. Warns appropriately such that the user+ |
+
| 36 | ++ |
+ #' can decide whether they prefer converting to factor manually (e.g. for full control of+ |
+
| 37 | ++ |
+ #' factor levels).+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' @param x (`atomic`)\cr object to convert.+ |
+
| 40 | ++ |
+ #' @param x_name (`string`)\cr name of `x`.+ |
+
| 41 | ++ |
+ #' @param na_level (`string`)\cr the explicit missing level which should be used when converting a character vector.+ |
+
| 42 | ++ |
+ #' @param verbose defaults to `TRUE`. It prints out warnings and messages.+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' @return A `factor` with same attributes (except class) as `x`. Does not modify `x` if already a `factor`.+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' @keywords internal+ |
+
| 47 | ++ |
+ as_factor_keep_attributes <- function(x,+ |
+
| 48 | ++ |
+ x_name = deparse(substitute(x)),+ |
+
| 49 | ++ |
+ na_level = "<Missing>",+ |
+
| 50 | ++ |
+ verbose = TRUE) {
+ |
+
| 51 | +159x | +
+ checkmate::assert_atomic(x)+ |
+
| 52 | +159x | +
+ checkmate::assert_string(x_name)+ |
+
| 53 | +159x | +
+ checkmate::assert_string(na_level)+ |
+
| 54 | +159x | +
+ checkmate::assert_flag(verbose)+ |
+
| 55 | +159x | +
+ if (is.factor(x)) {
+ |
+
| 56 | +144x | +
+ return(x)+ |
+
| 57 | ++ |
+ }+ |
+
| 58 | +15x | +
+ x_class <- class(x)[1]+ |
+
| 59 | +15x | +
+ if (verbose) {
+ |
+
| 60 | +15x | +
+ warning(paste(+ |
+
| 61 | +15x | +
+ "automatically converting", x_class, "variable", x_name,+ |
+
| 62 | +15x | +
+ "to factor, better manually convert to factor to avoid failures"+ |
+
| 63 | ++ |
+ ))+ |
+
| 64 | ++ |
+ }+ |
+
| 65 | +15x | +
+ if (identical(length(x), 0L)) {
+ |
+
| 66 | +1x | +
+ warning(paste(+ |
+
| 67 | +1x | +
+ x_name, "has length 0, this can lead to tabulation failures, better convert to factor"+ |
+
| 68 | ++ |
+ ))+ |
+
| 69 | ++ |
+ }+ |
+
| 70 | +15x | +
+ if (is.character(x)) {
+ |
+
| 71 | +15x | +
+ x_no_na <- explicit_na(sas_na(x), label = na_level)+ |
+
| 72 | +15x | +
+ if (any(na_level %in% x_no_na)) {
+ |
+
| 73 | +3x | +
+ do.call(+ |
+
| 74 | +3x | +
+ structure,+ |
+
| 75 | +3x | +
+ c(+ |
+
| 76 | +3x | +
+ list(.Data = forcats::fct_relevel(x_no_na, na_level, after = Inf)),+ |
+
| 77 | +3x | +
+ attributes(x)+ |
+
| 78 | ++ |
+ )+ |
+
| 79 | ++ |
+ )+ |
+
| 80 | ++ |
+ } else {
+ |
+
| 81 | +12x | +
+ do.call(structure, c(list(.Data = as.factor(x)), attributes(x)))+ |
+
| 82 | ++ |
+ }+ |
+
| 83 | ++ |
+ } else {
+ |
+
| 84 | +! | +
+ do.call(structure, c(list(.Data = as.factor(x)), attributes(x)))+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | ++ |
+ }+ |
+
| 87 | ++ | + + | +
| 88 | ++ |
+ #' Labels for Bins in Percent+ |
+
| 89 | ++ |
+ #'+ |
+
| 90 | ++ |
+ #' This creates labels for quantile based bins in percent. This assumes the right-closed+ |
+
| 91 | ++ |
+ #' intervals as produced by [cut_quantile_bins()].+ |
+
| 92 | ++ |
+ #'+ |
+
| 93 | ++ |
+ #' @param probs (`proportion` vector)\cr the probabilities identifying the quantiles.+ |
+
| 94 | ++ |
+ #' This is a sorted vector of unique `proportion` values, i.e. between 0 and 1, where+ |
+
| 95 | ++ |
+ #' the boundaries 0 and 1 must not be included.+ |
+
| 96 | ++ |
+ #' @param digits (`integer`)\cr number of decimal places to round the percent numbers.+ |
+
| 97 | ++ |
+ #'+ |
+
| 98 | ++ |
+ #' @return A `character` vector with labels in the format `[0%,20%]`, `(20%,50%]`, etc.+ |
+
| 99 | ++ |
+ #'+ |
+
| 100 | ++ |
+ #' @keywords internal+ |
+
| 101 | ++ |
+ bins_percent_labels <- function(probs,+ |
+
| 102 | ++ |
+ digits = 0) {
+ |
+
| 103 | +1x | +
+ if (isFALSE(0 %in% probs)) probs <- c(0, probs)+ |
+
| 104 | +1x | +
+ if (isFALSE(1 %in% probs)) probs <- c(probs, 1)+ |
+
| 105 | +8x | +
+ checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE)+ |
+
| 106 | +8x | +
+ percent <- round(probs * 100, digits = digits)+ |
+
| 107 | +8x | +
+ left <- paste0(utils::head(percent, -1), "%")+ |
+
| 108 | +8x | +
+ right <- paste0(utils::tail(percent, -1), "%")+ |
+
| 109 | +8x | +
+ without_left_bracket <- paste0(left, ",", right, "]")+ |
+
| 110 | +8x | +
+ with_left_bracket <- paste0("[", utils::head(without_left_bracket, 1))
+ |
+
| 111 | +8x | +
+ if (length(without_left_bracket) > 1) {
+ |
+
| 112 | +6x | +
+ with_left_bracket <- c(+ |
+
| 113 | +6x | +
+ with_left_bracket,+ |
+
| 114 | +6x | +
+ paste0("(", utils::tail(without_left_bracket, -1))
+ |
+
| 115 | ++ |
+ )+ |
+
| 116 | ++ |
+ }+ |
+
| 117 | +8x | +
+ with_left_bracket+ |
+
| 118 | ++ |
+ }+ |
+
| 119 | ++ | + + | +
| 120 | ++ |
+ #' Cutting Numeric Vector into Empirical Quantile Bins+ |
+
| 121 | ++ |
+ #'+ |
+
| 122 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 123 | ++ |
+ #'+ |
+
| 124 | ++ |
+ #' This cuts a numeric vector into sample quantile bins.+ |
+
| 125 | ++ |
+ #'+ |
+
| 126 | ++ |
+ #' @inheritParams bins_percent_labels+ |
+
| 127 | ++ |
+ #' @param x (`numeric`)\cr the continuous variable values which should be cut into+ |
+
| 128 | ++ |
+ #' quantile bins. This may contain `NA` values, which are then+ |
+
| 129 | ++ |
+ #' not used for the quantile calculations, but included in the return vector.+ |
+
| 130 | ++ |
+ #' @param labels (`character`)\cr the unique labels for the quantile bins. When there are `n`+ |
+
| 131 | ++ |
+ #' probabilities in `probs`, then this must be `n + 1` long.+ |
+
| 132 | ++ |
+ #' @param type (`integer`)\cr type of quantiles to use, see [stats::quantile()] for details.+ |
+
| 133 | ++ |
+ #' @param ordered (`flag`)\cr should the result be an ordered factor.+ |
+
| 134 | ++ |
+ #'+ |
+
| 135 | ++ |
+ #' @return A `factor` variable with appropriately-labeled bins as levels.+ |
+
| 136 | ++ |
+ #'+ |
+
| 137 | ++ |
+ #' @note Intervals are closed on the right side. That is, the first bin is the interval+ |
+
| 138 | ++ |
+ #' `[-Inf, q1]` where `q1` is the first quantile, the second bin is then `(q1, q2]`, etc.,+ |
+
| 139 | ++ |
+ #' and the last bin is `(qn, +Inf]` where `qn` is the last quantile.+ |
+
| 140 | ++ |
+ #'+ |
+
| 141 | ++ |
+ #' @examples+ |
+
| 142 | ++ |
+ #' # Default is to cut into quartile bins.+ |
+
| 143 | ++ |
+ #' cut_quantile_bins(cars$speed)+ |
+
| 144 | ++ |
+ #'+ |
+
| 145 | ++ |
+ #' # Use custom quantiles.+ |
+
| 146 | ++ |
+ #' cut_quantile_bins(cars$speed, probs = c(0.1, 0.2, 0.6, 0.88))+ |
+
| 147 | ++ |
+ #'+ |
+
| 148 | ++ |
+ #' # Use custom labels.+ |
+
| 149 | ++ |
+ #' cut_quantile_bins(cars$speed, labels = paste0("Q", 1:4))
+ |
+
| 150 | ++ |
+ #'+ |
+
| 151 | ++ |
+ #' # NAs are preserved in result factor.+ |
+
| 152 | ++ |
+ #' ozone_binned <- cut_quantile_bins(airquality$Ozone)+ |
+
| 153 | ++ |
+ #' which(is.na(ozone_binned))+ |
+
| 154 | ++ |
+ #' # So you might want to make these explicit.+ |
+
| 155 | ++ |
+ #' explicit_na(ozone_binned)+ |
+
| 156 | ++ |
+ #'+ |
+
| 157 | ++ |
+ #' @export+ |
+
| 158 | ++ |
+ cut_quantile_bins <- function(x,+ |
+
| 159 | ++ |
+ probs = c(0.25, 0.5, 0.75),+ |
+
| 160 | ++ |
+ labels = NULL,+ |
+
| 161 | ++ |
+ type = 7,+ |
+
| 162 | ++ |
+ ordered = TRUE) {
+ |
+
| 163 | +8x | +
+ checkmate::assert_flag(ordered)+ |
+
| 164 | +8x | +
+ checkmate::assert_numeric(x)+ |
+
| 165 | +7x | +
+ if (isFALSE(0 %in% probs)) probs <- c(0, probs)+ |
+
| 166 | +7x | +
+ if (isFALSE(1 %in% probs)) probs <- c(probs, 1)+ |
+
| 167 | +8x | +
+ checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE)+ |
+
| 168 | +7x | +
+ 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 | ++ |
+ # Early return if there are only NAs in input.+ |
+
| 173 | +1x | +
+ return(factor(x, ordered = ordered, levels = labels))+ |
+
| 174 | ++ |
+ }+ |
+
| 175 | ++ | + + | +
| 176 | +7x | +
+ quantiles <- stats::quantile(+ |
+
| 177 | +7x | +
+ x,+ |
+
| 178 | +7x | +
+ probs = probs,+ |
+
| 179 | +7x | +
+ type = type,+ |
+
| 180 | +7x | +
+ na.rm = TRUE+ |
+
| 181 | ++ |
+ )+ |
+
| 182 | ++ | + + | +
| 183 | +7x | +
+ checkmate::assert_numeric(quantiles, unique = TRUE)+ |
+
| 184 | ++ | + + | +
| 185 | +6x | +
+ cut(+ |
+
| 186 | +6x | +
+ x,+ |
+
| 187 | +6x | +
+ breaks = quantiles,+ |
+
| 188 | +6x | +
+ labels = labels,+ |
+
| 189 | +6x | +
+ ordered_result = ordered,+ |
+
| 190 | +6x | +
+ include.lowest = TRUE,+ |
+
| 191 | +6x | +
+ right = TRUE+ |
+
| 192 | ++ |
+ )+ |
+
| 193 | ++ |
+ }+ |
+
| 194 | ++ | + + | +
| 195 | ++ |
+ #' Discard Certain Levels from a Factor+ |
+
| 196 | ++ |
+ #'+ |
+
| 197 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 198 | ++ |
+ #'+ |
+
| 199 | ++ |
+ #' This discards the observations as well as the levels specified from a factor.+ |
+
| 200 | ++ |
+ #'+ |
+
| 201 | ++ |
+ #' @param x (`factor`)\cr the original factor.+ |
+
| 202 | ++ |
+ #' @param discard (`character`)\cr which levels to discard.+ |
+
| 203 | ++ |
+ #'+ |
+
| 204 | ++ |
+ #' @return A modified `factor` with observations as well as levels from `discard` dropped.+ |
+
| 205 | ++ |
+ #'+ |
+
| 206 | ++ |
+ #' @examples+ |
+
| 207 | ++ |
+ #' fct_discard(factor(c("a", "b", "c")), "c")
+ |
+
| 208 | ++ |
+ #'+ |
+
| 209 | ++ |
+ #' @export+ |
+
| 210 | ++ |
+ fct_discard <- function(x, discard) {
+ |
+
| 211 | +292x | +
+ checkmate::assert_factor(x)+ |
+
| 212 | +292x | +
+ checkmate::assert_character(discard, any.missing = FALSE)+ |
+
| 213 | +292x | +
+ new_obs <- x[!(x %in% discard)]+ |
+
| 214 | +292x | +
+ new_levels <- setdiff(levels(x), discard)+ |
+
| 215 | +292x | +
+ factor(new_obs, levels = new_levels)+ |
+
| 216 | ++ |
+ }+ |
+
| 217 | ++ | + + | +
| 218 | ++ |
+ #' Insertion of Explicit Missings in a Factor+ |
+
| 219 | ++ |
+ #'+ |
+
| 220 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 221 | ++ |
+ #'+ |
+
| 222 | ++ |
+ #' This inserts explicit missings in a factor based on a condition. Additionally,+ |
+
| 223 | ++ |
+ #' existing `NA` values will be explicitly converted to given `na_level`.+ |
+
| 224 | ++ |
+ #'+ |
+
| 225 | ++ |
+ #' @param x (`factor`)\cr the original factor.+ |
+
| 226 | ++ |
+ #' @param condition (`logical`)\cr where to insert missings.+ |
+
| 227 | ++ |
+ #' @param na_level (`string`)\cr which level to use for missings.+ |
+
| 228 | ++ |
+ #'+ |
+
| 229 | ++ |
+ #' @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 | ++ |
+ #'+ |
+
| 233 | ++ |
+ #' @examples+ |
+
| 234 | ++ |
+ #' fct_explicit_na_if(factor(c("a", "b", NA)), c(TRUE, FALSE, FALSE))
+ |
+
| 235 | ++ |
+ #'+ |
+
| 236 | ++ |
+ #' @export+ |
+
| 237 | ++ |
+ fct_explicit_na_if <- function(x, condition, na_level = "<Missing>") {
+ |
+
| 238 | +1x | +
+ checkmate::assert_factor(x, len = length(condition))+ |
+
| 239 | +1x | +
+ checkmate::assert_logical(condition)+ |
+
| 240 | +1x | +
+ x[condition] <- NA+ |
+
| 241 | +1x | +
+ x <- forcats::fct_na_value_to_level(x, level = na_level)+ |
+
| 242 | +1x | +
+ forcats::fct_drop(x, only = na_level)+ |
+
| 243 | ++ |
+ }+ |
+
| 244 | ++ | + + | +
| 245 | ++ |
+ #' Collapsing of Factor Levels and Keeping Only Those New Group Levels+ |
+
| 246 | ++ |
+ #'+ |
+
| 247 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 248 | ++ |
+ #'+ |
+
| 249 | ++ |
+ #' This collapses levels and only keeps those new group levels, in the order provided.+ |
+
| 250 | ++ |
+ #' The returned factor has levels in the order given, with the possible missing level last (this will+ |
+
| 251 | ++ |
+ #' only be included if there are missing values).+ |
+
| 252 | ++ |
+ #'+ |
+
| 253 | ++ |
+ #' @param .f (`factor` or `character`)\cr original vector.+ |
+
| 254 | ++ |
+ #' @param ... (named `character` vectors)\cr levels in each vector provided will be collapsed into+ |
+
| 255 | ++ |
+ #' the new level given by the respective name.+ |
+
| 256 | ++ |
+ #' @param .na_level (`string`)\cr which level to use for other levels, which should be missing in the+ |
+
| 257 | ++ |
+ #' new factor. Note that this level must not be contained in the new levels specified in `...`.+ |
+
| 258 | ++ |
+ #'+ |
+
| 259 | ++ |
+ #' @return A modified `factor` with collapsed levels. Values and levels which are not included+ |
+
| 260 | ++ |
+ #' in the given `character` vector input will be set to the missing level `.na_level`.+ |
+
| 261 | ++ |
+ #'+ |
+
| 262 | ++ |
+ #' @note Any existing `NA`s in the input vector will not be replaced by the missing level. If needed,+ |
+
| 263 | ++ |
+ #' [explicit_na()] can be called separately on the result.+ |
+
| 264 | ++ |
+ #'+ |
+
| 265 | ++ |
+ #' @seealso [forcats::fct_collapse()], [forcats::fct_relevel()] which are used internally.+ |
+
| 266 | ++ |
+ #'+ |
+
| 267 | ++ |
+ #' @examples+ |
+
| 268 | ++ |
+ #' fct_collapse_only(factor(c("a", "b", "c", "d")), TRT = "b", CTRL = c("c", "d"))
+ |
+
| 269 | ++ |
+ #'+ |
+
| 270 | ++ |
+ #' @export+ |
+
| 271 | ++ |
+ fct_collapse_only <- function(.f, ..., .na_level = "<Missing>") {
+ |
+
| 272 | +4x | +
+ new_lvls <- names(list(...))+ |
+
| 273 | +4x | +
+ if (checkmate::test_subset(.na_level, new_lvls)) {
+ |
+
| 274 | +1x | +
+ stop(paste0(".na_level currently set to '", .na_level, "' must not be contained in the new levels"))
+ |
+
| 275 | ++ |
+ }+ |
+
| 276 | +3x | +
+ x <- forcats::fct_collapse(.f, ..., other_level = .na_level)+ |
+
| 277 | +3x | +
+ do.call(forcats::fct_relevel, args = c(list(.f = x), as.list(new_lvls)))+ |
+
| 278 | ++ |
+ }+ |
+
| 279 | ++ | + + | +
| 280 | ++ |
+ #' Ungroup Non-Numeric Statistics+ |
+
| 281 | ++ |
+ #'+ |
+
| 282 | ++ |
+ #' Ungroups grouped non-numeric statistics within input vectors `.formats`, `.labels`, and `.indent_mods`.+ |
+
| 283 | ++ |
+ #'+ |
+
| 284 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 285 | ++ |
+ #' @param x (`named list` of `numeric`)\cr list of numeric statistics containing the statistics to ungroup.+ |
+
| 286 | ++ |
+ #'+ |
+
| 287 | ++ |
+ #' @return A `list` with modified elements `x`, `.formats`, `.labels`, and `.indent_mods`.+ |
+
| 288 | ++ |
+ #'+ |
+
| 289 | ++ |
+ #' @seealso [a_summary()] which uses this function internally.+ |
+
| 290 | ++ |
+ #'+ |
+
| 291 | ++ |
+ #' @keywords internal+ |
+
| 292 | ++ |
+ ungroup_stats <- function(x,+ |
+
| 293 | ++ |
+ .formats,+ |
+
| 294 | ++ |
+ .labels,+ |
+
| 295 | ++ |
+ .indent_mods) {
+ |
+
| 296 | +224x | +
+ checkmate::assert_list(x)+ |
+
| 297 | +224x | +
+ empty_pval <- "pval" %in% names(x) && length(x[["pval"]]) == 0+ |
+
| 298 | +224x | +
+ empty_pval_counts <- "pval_counts" %in% names(x) && length(x[["pval_counts"]]) == 0+ |
+
| 299 | +224x | +
+ x <- unlist(x, recursive = FALSE)+ |
+
| 300 | ++ | + + | +
| 301 | ++ |
+ # If p-value is empty it is removed by unlist and needs to be re-added+ |
+
| 302 | +! | +
+ if (empty_pval) x[["pval"]] <- character()+ |
+
| 303 | +3x | +
+ if (empty_pval_counts) x[["pval_counts"]] <- character()+ |
+
| 304 | +224x | +
+ .stats <- names(x)+ |
+
| 305 | ++ | + + | +
| 306 | ++ |
+ # Ungroup stats+ |
+
| 307 | +224x | +
+ .formats <- lapply(.stats, function(x) {
+ |
+
| 308 | +2049x | +
+ .formats[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
+ |
+
| 309 | ++ |
+ })+ |
+
| 310 | +224x | +
+ .indent_mods <- sapply(.stats, function(x) {
+ |
+
| 311 | +2049x | +
+ .indent_mods[[if (!grepl("\\.", x)) x else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][1]]]
+ |
+
| 312 | ++ |
+ })+ |
+
| 313 | +224x | +
+ .labels <- sapply(.stats, function(x) {
+ |
+
| 314 | +1998x | +
+ if (!grepl("\\.", x)) .labels[[x]] else regmatches(x, regexpr("\\.", x), invert = TRUE)[[1]][2]
+ |
+
| 315 | ++ |
+ })+ |
+
| 316 | ++ | + + | +
| 317 | +224x | +
+ list(+ |
+
| 318 | +224x | +
+ x = x,+ |
+
| 319 | +224x | +
+ .formats = .formats,+ |
+
| 320 | +224x | +
+ .labels = .labels,+ |
+
| 321 | +224x | +
+ .indent_mods = .indent_mods+ |
+
| 322 | ++ |
+ )+ |
+
| 323 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Patient Counts for Laboratory Events (Worsen From Baseline) by Highest Grade Post-Baseline+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Patient count and fraction for laboratory events (worsen from baseline) shift table.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @seealso Relevant helper functions [h_adlb_worsen()] and [h_worsen_counter()]+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @name abnormal_by_worst_grade_worsen+ |
+
| 12 | ++ |
+ NULL+ |
+
| 13 | ++ | + + | +
| 14 | ++ |
+ #' Helper Function to Prepare `ADLB` with Worst Labs+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' Helper function to prepare a `df` for generate the patient count shift table+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @param adlb (`data.frame`)\cr `ADLB` dataframe+ |
+
| 21 | ++ |
+ #' @param worst_flag_low (named `vector`)\cr Worst low post-baseline lab grade flag variable+ |
+
| 22 | ++ |
+ #' @param worst_flag_high (named `vector`)\cr Worst high post-baseline lab grade flag variable+ |
+
| 23 | ++ |
+ #' @param direction_var (`string`)\cr Direction variable specifying the direction of the shift table of interest.+ |
+
| 24 | ++ |
+ #' Only lab records flagged by `L`, `H` or `B` are included in the shift table.+ |
+
| 25 | ++ |
+ #' * `L`: low direction only+ |
+
| 26 | ++ |
+ #' * `H`: high direction only+ |
+
| 27 | ++ |
+ #' * `B`: both low and high directions+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @return `h_adlb_worsen()` returns the `adlb` `data.frame` containing only the+ |
+
| 30 | ++ |
+ #' worst labs specified according to `worst_flag_low` or `worst_flag_high` for the+ |
+
| 31 | ++ |
+ #' direction specified according to `direction_var`. For instance, for a lab that is+ |
+
| 32 | ++ |
+ #' needed for the low direction only, only records flagged by `worst_flag_low` are+ |
+
| 33 | ++ |
+ #' selected. For a lab that is needed for both low and high directions, the worst+ |
+
| 34 | ++ |
+ #' low records are selected for the low direction, and the worst high record are selected+ |
+
| 35 | ++ |
+ #' for the high direction.+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' @seealso [abnormal_by_worst_grade_worsen]+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' @examples+ |
+
| 40 | ++ |
+ #' library(dplyr)+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' # The direction variable, GRADDR, is based on metadata+ |
+
| 43 | ++ |
+ #' adlb <- tern_ex_adlb %>%+ |
+
| 44 | ++ |
+ #' mutate(+ |
+
| 45 | ++ |
+ #' GRADDR = case_when(+ |
+
| 46 | ++ |
+ #' PARAMCD == "ALT" ~ "B",+ |
+
| 47 | ++ |
+ #' PARAMCD == "CRP" ~ "L",+ |
+
| 48 | ++ |
+ #' PARAMCD == "IGA" ~ "H"+ |
+
| 49 | ++ |
+ #' )+ |
+
| 50 | ++ |
+ #' ) %>%+ |
+
| 51 | ++ |
+ #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")+ |
+
| 52 | ++ |
+ #'+ |
+
| 53 | ++ |
+ #' df <- h_adlb_worsen(+ |
+
| 54 | ++ |
+ #' adlb,+ |
+
| 55 | ++ |
+ #' worst_flag_low = c("WGRLOFL" = "Y"),
+ |
+
| 56 | ++ |
+ #' worst_flag_high = c("WGRHIFL" = "Y"),
+ |
+
| 57 | ++ |
+ #' direction_var = "GRADDR"+ |
+
| 58 | ++ |
+ #' )+ |
+
| 59 | ++ |
+ #'+ |
+
| 60 | ++ |
+ #' @export+ |
+
| 61 | ++ |
+ h_adlb_worsen <- function(adlb,+ |
+
| 62 | ++ |
+ worst_flag_low = NULL,+ |
+
| 63 | ++ |
+ worst_flag_high = NULL,+ |
+
| 64 | ++ |
+ direction_var) {
+ |
+
| 65 | +5x | +
+ checkmate::assert_string(direction_var)+ |
+
| 66 | +5x | +
+ checkmate::assert_subset(as.character(unique(adlb[[direction_var]])), c("B", "L", "H"))
+ |
+
| 67 | +5x | +
+ assert_df_with_variables(adlb, list("Col" = direction_var))
+ |
+
| 68 | ++ | + + | +
| 69 | +5x | +
+ if (any(unique(adlb[[direction_var]]) == "H")) {
+ |
+
| 70 | +4x | +
+ assert_df_with_variables(adlb, list("High" = names(worst_flag_high)))
+ |
+
| 71 | ++ |
+ }+ |
+
| 72 | ++ | + + | +
| 73 | +5x | +
+ if (any(unique(adlb[[direction_var]]) == "L")) {
+ |
+
| 74 | +4x | +
+ assert_df_with_variables(adlb, list("Low" = names(worst_flag_low)))
+ |
+
| 75 | ++ |
+ }+ |
+
| 76 | ++ | + + | +
| 77 | +5x | +
+ if (any(unique(adlb[[direction_var]]) == "B")) {
+ |
+
| 78 | +3x | +
+ assert_df_with_variables(+ |
+
| 79 | +3x | +
+ adlb,+ |
+
| 80 | +3x | +
+ list(+ |
+
| 81 | +3x | +
+ "Low" = names(worst_flag_low),+ |
+
| 82 | +3x | +
+ "High" = names(worst_flag_high)+ |
+
| 83 | ++ |
+ )+ |
+
| 84 | ++ |
+ )+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | ++ | + + | +
| 87 | ++ |
+ # extract patients with worst post-baseline lab, either low or high or both+ |
+
| 88 | +5x | +
+ worst_flag <- c(worst_flag_low, worst_flag_high)+ |
+
| 89 | +5x | +
+ col_names <- names(worst_flag)+ |
+
| 90 | +5x | +
+ filter_values <- worst_flag+ |
+
| 91 | +5x | +
+ temp <- Map(+ |
+
| 92 | +5x | +
+ function(x, y) which(adlb[[x]] == y),+ |
+
| 93 | +5x | +
+ col_names,+ |
+
| 94 | +5x | +
+ filter_values+ |
+
| 95 | ++ |
+ )+ |
+
| 96 | +5x | +
+ position_satisfy_filters <- Reduce(union, temp)+ |
+
| 97 | ++ | + + | +
| 98 | ++ |
+ # select variables of interest+ |
+
| 99 | +5x | +
+ adlb_f <- adlb[position_satisfy_filters, ]+ |
+
| 100 | ++ | + + | +
| 101 | ++ |
+ # generate subsets for different directionality+ |
+
| 102 | +5x | +
+ adlb_f_h <- adlb_f[which(adlb_f[[direction_var]] == "H"), ]+ |
+
| 103 | +5x | +
+ adlb_f_l <- adlb_f[which(adlb_f[[direction_var]] == "L"), ]+ |
+
| 104 | +5x | +
+ adlb_f_b <- adlb_f[which(adlb_f[[direction_var]] == "B"), ]+ |
+
| 105 | ++ | + + | +
| 106 | ++ |
+ # for labs requiring both high and low, data is duplicated and will be stacked on top of each other+ |
+
| 107 | +5x | +
+ adlb_f_b_h <- adlb_f_b+ |
+
| 108 | +5x | +
+ adlb_f_b_l <- adlb_f_b+ |
+
| 109 | ++ | + + | +
| 110 | ++ |
+ # extract data with worst lab+ |
+
| 111 | +5x | +
+ if (!is.null(worst_flag_high) && !is.null(worst_flag_low)) {
+ |
+
| 112 | ++ |
+ # change H to High, L to Low+ |
+
| 113 | +3x | +
+ adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
+ |
+
| 114 | +3x | +
+ adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
+ |
+
| 115 | ++ | + + | +
| 116 | ++ |
+ # change, B to High and Low+ |
+
| 117 | +3x | +
+ adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
+ |
+
| 118 | +3x | +
+ adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
+ |
+
| 119 | ++ | + + | +
| 120 | +3x | +
+ adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ]+ |
+
| 121 | +3x | +
+ adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ]+ |
+
| 122 | +3x | +
+ adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ]+ |
+
| 123 | +3x | +
+ adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ]+ |
+
| 124 | ++ | + + | +
| 125 | +3x | +
+ out <- rbind(adlb_out_h, adlb_out_b_h, adlb_out_l, adlb_out_b_l)+ |
+
| 126 | +2x | +
+ } else if (!is.null(worst_flag_high)) {
+ |
+
| 127 | +1x | +
+ adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
+ |
+
| 128 | +1x | +
+ adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
+ |
+
| 129 | ++ | + + | +
| 130 | +1x | +
+ adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ]+ |
+
| 131 | +1x | +
+ adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ]+ |
+
| 132 | ++ | + + | +
| 133 | +1x | +
+ out <- rbind(adlb_out_h, adlb_out_b_h)+ |
+
| 134 | +1x | +
+ } else if (!is.null(worst_flag_low)) {
+ |
+
| 135 | +1x | +
+ adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
+ |
+
| 136 | +1x | +
+ adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
+ |
+
| 137 | ++ | + + | +
| 138 | +1x | +
+ adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ]+ |
+
| 139 | +1x | +
+ adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ]+ |
+
| 140 | ++ | + + | +
| 141 | +1x | +
+ out <- rbind(adlb_out_l, adlb_out_b_l)+ |
+
| 142 | ++ |
+ }+ |
+
| 143 | ++ | + + | +
| 144 | ++ |
+ # label+ |
+
| 145 | +5x | +
+ formatters::var_labels(out) <- formatters::var_labels(adlb_f, fill = FALSE)+ |
+
| 146 | ++ |
+ # NA+ |
+
| 147 | +5x | +
+ out+ |
+
| 148 | ++ |
+ }+ |
+
| 149 | ++ | + + | +
| 150 | ++ |
+ #' Helper Function to Analyze Patients for [s_count_abnormal_lab_worsen_by_baseline()]+ |
+
| 151 | ++ |
+ #'+ |
+
| 152 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 153 | ++ |
+ #'+ |
+
| 154 | ++ |
+ #' Helper function to count the number of patients and the fraction of patients according to+ |
+
| 155 | ++ |
+ #' highest post-baseline lab grade variable `.var`, baseline lab grade variable `baseline_var`,+ |
+
| 156 | ++ |
+ #' and the direction of interest specified in `direction_var`.+ |
+
| 157 | ++ |
+ #'+ |
+
| 158 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 159 | ++ |
+ #' @inheritParams h_adlb_worsen+ |
+
| 160 | ++ |
+ #' @param baseline_var (`string`)\cr baseline lab grade variable+ |
+
| 161 | ++ |
+ #'+ |
+
| 162 | ++ |
+ #' @return `h_worsen_counter()` returns the counts and fraction of patients+ |
+
| 163 | ++ |
+ #' whose worst post-baseline lab grades are worse than their baseline grades, for+ |
+
| 164 | ++ |
+ #' post-baseline worst grades "1", "2", "3", "4" and "Any".+ |
+
| 165 | ++ |
+ #'+ |
+
| 166 | ++ |
+ #' @seealso [abnormal_by_worst_grade_worsen]+ |
+
| 167 | ++ |
+ #'+ |
+
| 168 | ++ |
+ #' @examples+ |
+
| 169 | ++ |
+ #' library(dplyr)+ |
+
| 170 | ++ |
+ #'+ |
+
| 171 | ++ |
+ #' # The direction variable, GRADDR, is based on metadata+ |
+
| 172 | ++ |
+ #' adlb <- tern_ex_adlb %>%+ |
+
| 173 | ++ |
+ #' mutate(+ |
+
| 174 | ++ |
+ #' GRADDR = case_when(+ |
+
| 175 | ++ |
+ #' PARAMCD == "ALT" ~ "B",+ |
+
| 176 | ++ |
+ #' PARAMCD == "CRP" ~ "L",+ |
+
| 177 | ++ |
+ #' PARAMCD == "IGA" ~ "H"+ |
+
| 178 | ++ |
+ #' )+ |
+
| 179 | ++ |
+ #' ) %>%+ |
+
| 180 | ++ |
+ #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")+ |
+
| 181 | ++ |
+ #'+ |
+
| 182 | ++ |
+ #' df <- h_adlb_worsen(+ |
+
| 183 | ++ |
+ #' adlb,+ |
+
| 184 | ++ |
+ #' worst_flag_low = c("WGRLOFL" = "Y"),
+ |
+
| 185 | ++ |
+ #' worst_flag_high = c("WGRHIFL" = "Y"),
+ |
+
| 186 | ++ |
+ #' direction_var = "GRADDR"+ |
+
| 187 | ++ |
+ #' )+ |
+
| 188 | ++ |
+ #'+ |
+
| 189 | ++ |
+ #' # `h_worsen_counter`+ |
+
| 190 | ++ |
+ #' h_worsen_counter(+ |
+
| 191 | ++ |
+ #' df %>% filter(PARAMCD == "CRP" & GRADDR == "Low"),+ |
+
| 192 | ++ |
+ #' id = "USUBJID",+ |
+
| 193 | ++ |
+ #' .var = "ATOXGR",+ |
+
| 194 | ++ |
+ #' baseline_var = "BTOXGR",+ |
+
| 195 | ++ |
+ #' direction_var = "GRADDR"+ |
+
| 196 | ++ |
+ #' )+ |
+
| 197 | ++ |
+ #'+ |
+
| 198 | ++ |
+ #' @export+ |
+
| 199 | ++ |
+ h_worsen_counter <- function(df, id, .var, baseline_var, direction_var) {
+ |
+
| 200 | +17x | +
+ checkmate::assert_string(id)+ |
+
| 201 | +17x | +
+ checkmate::assert_string(.var)+ |
+
| 202 | +17x | +
+ checkmate::assert_string(baseline_var)+ |
+
| 203 | +17x | +
+ checkmate::assert_scalar(unique(df[[direction_var]]))+ |
+
| 204 | +17x | +
+ checkmate::assert_subset(unique(df[[direction_var]]), c("High", "Low"))
+ |
+
| 205 | +17x | +
+ assert_df_with_variables(df, list(val = c(id, .var, baseline_var, direction_var)))+ |
+
| 206 | ++ | + + | +
| 207 | ++ |
+ # remove post-baseline missing+ |
+
| 208 | +17x | +
+ df <- df[df[[.var]] != "<Missing>", ]+ |
+
| 209 | ++ | + + | +
| 210 | ++ |
+ # obtain directionality+ |
+
| 211 | +17x | +
+ direction <- unique(df[[direction_var]])+ |
+
| 212 | ++ | + + | +
| 213 | +17x | +
+ if (direction == "Low") {
+ |
+
| 214 | +10x | +
+ grade <- -1:-4+ |
+
| 215 | +10x | +
+ worst_grade <- -4+ |
+
| 216 | +7x | +
+ } else if (direction == "High") {
+ |
+
| 217 | +7x | +
+ grade <- 1:4+ |
+
| 218 | +7x | +
+ worst_grade <- 4+ |
+
| 219 | ++ |
+ }+ |
+
| 220 | ++ | + + | +
| 221 | +17x | +
+ if (nrow(df) > 0) {
+ |
+
| 222 | +17x | +
+ by_grade <- lapply(grade, function(i) {
+ |
+
| 223 | ++ |
+ # filter baseline values that is less than i or <Missing>+ |
+
| 224 | +68x | +
+ df_temp <- df[df[[baseline_var]] %in% c((i + sign(i) * -1):(-1 * worst_grade), "<Missing>"), ]+ |
+
| 225 | ++ |
+ # num: number of patients with post-baseline worst lab equal to i+ |
+
| 226 | +68x | +
+ num <- length(unique(df_temp[df_temp[[.var]] %in% i, id, drop = TRUE]))+ |
+
| 227 | ++ |
+ # denom: number of patients with baseline values less than i or <missing> and post-baseline in the same direction+ |
+
| 228 | +68x | +
+ denom <- length(unique(df_temp[[id]]))+ |
+
| 229 | +68x | +
+ rm(df_temp)+ |
+
| 230 | +68x | +
+ c(num = num, denom = denom)+ |
+
| 231 | ++ |
+ })+ |
+
| 232 | ++ |
+ } else {
+ |
+
| 233 | +! | +
+ by_grade <- lapply(1, function(i) {
+ |
+
| 234 | +! | +
+ c(num = 0, denom = 0)+ |
+
| 235 | ++ |
+ })+ |
+
| 236 | ++ |
+ }+ |
+
| 237 | ++ | + + | +
| 238 | +17x | +
+ names(by_grade) <- as.character(seq_along(by_grade))+ |
+
| 239 | ++ | + + | +
| 240 | ++ |
+ # baseline grade less 4 or missing+ |
+
| 241 | +17x | +
+ df_temp <- df[!df[[baseline_var]] %in% worst_grade, ]+ |
+
| 242 | ++ | + + | +
| 243 | ++ |
+ # denom: number of patients with baseline values less than 4 or <missing> and post-baseline in the same direction+ |
+
| 244 | +17x | +
+ denom <- length(unique(df_temp[, id, drop = TRUE]))+ |
+
| 245 | ++ | + + | +
| 246 | ++ |
+ # condition 1: missing baseline and in the direction of abnormality+ |
+
| 247 | +17x | +
+ con1 <- which(df_temp[[baseline_var]] == "<Missing>" & df_temp[[.var]] %in% grade)+ |
+
| 248 | +17x | +
+ df_temp_nm <- df_temp[which(df_temp[[baseline_var]] != "<Missing>" & df_temp[[.var]] %in% grade), ]+ |
+
| 249 | ++ | + + | +
| 250 | ++ |
+ # condition 2: if post-baseline values are present then post-baseline values must be worse than baseline+ |
+
| 251 | +17x | +
+ if (direction == "Low") {
+ |
+
| 252 | +10x | +
+ con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) < as.numeric(as.character(df_temp_nm[[baseline_var]])))+ |
+
| 253 | ++ |
+ } else {
+ |
+
| 254 | +7x | +
+ con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) > as.numeric(as.character(df_temp_nm[[baseline_var]])))+ |
+
| 255 | ++ |
+ }+ |
+
| 256 | ++ | + + | +
| 257 | ++ |
+ # number of patients satisfy either conditions 1 or 2+ |
+
| 258 | +17x | +
+ num <- length(unique(df_temp[union(con1, con2), id, drop = TRUE]))+ |
+
| 259 | ++ | + + | +
| 260 | +17x | +
+ list(fraction = c(by_grade, list("Any" = c(num = num, denom = denom))))
+ |
+
| 261 | ++ |
+ }+ |
+
| 262 | ++ | + + | +
| 263 | ++ |
+ #' @describeIn abnormal_by_worst_grade_worsen Statistics function for patients whose worst post-baseline+ |
+
| 264 | ++ |
+ #' lab grades are worse than their baseline grades.+ |
+
| 265 | ++ |
+ #'+ |
+
| 266 | ++ |
+ #' @param variables (named `list` of `string`)\cr list of additional analysis variables including:+ |
+
| 267 | ++ |
+ #' * `id` (`string`)\cr subject variable name.+ |
+
| 268 | ++ |
+ #' * `baseline_var` (`string`)\cr name of the data column containing baseline toxicity variable.+ |
+
| 269 | ++ |
+ #' * `direction_var` (`string`)\cr see `direction_var` for more details.+ |
+
| 270 | ++ |
+ #'+ |
+
| 271 | ++ |
+ #' @return+ |
+
| 272 | ++ |
+ #' * `s_count_abnormal_lab_worsen_by_baseline()` returns the counts and fraction of patients whose worst+ |
+
| 273 | ++ |
+ #' post-baseline lab grades are worse than their baseline grades, for post-baseline worst grades+ |
+
| 274 | ++ |
+ #' "1", "2", "3", "4" and "Any".+ |
+
| 275 | ++ |
+ #'+ |
+
| 276 | ++ |
+ #' @examples+ |
+
| 277 | ++ |
+ #' library(dplyr)+ |
+
| 278 | ++ |
+ #'+ |
+
| 279 | ++ |
+ #' # The direction variable, GRADDR, is based on metadata+ |
+
| 280 | ++ |
+ #' adlb <- tern_ex_adlb %>%+ |
+
| 281 | ++ |
+ #' mutate(+ |
+
| 282 | ++ |
+ #' GRADDR = case_when(+ |
+
| 283 | ++ |
+ #' PARAMCD == "ALT" ~ "B",+ |
+
| 284 | ++ |
+ #' PARAMCD == "CRP" ~ "L",+ |
+
| 285 | ++ |
+ #' PARAMCD == "IGA" ~ "H"+ |
+
| 286 | ++ |
+ #' )+ |
+
| 287 | ++ |
+ #' ) %>%+ |
+
| 288 | ++ |
+ #' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")+ |
+
| 289 | ++ |
+ #'+ |
+
| 290 | ++ |
+ #' df <- h_adlb_worsen(+ |
+
| 291 | ++ |
+ #' adlb,+ |
+
| 292 | ++ |
+ #' worst_flag_low = c("WGRLOFL" = "Y"),
+ |
+
| 293 | ++ |
+ #' worst_flag_high = c("WGRHIFL" = "Y"),
+ |
+
| 294 | ++ |
+ #' direction_var = "GRADDR"+ |
+
| 295 | ++ |
+ #' )+ |
+
| 296 | ++ |
+ #'+ |
+
| 297 | ++ |
+ #' @keywords internal+ |
+
| 298 | ++ |
+ s_count_abnormal_lab_worsen_by_baseline <- function(df, # nolint+ |
+
| 299 | ++ |
+ .var = "ATOXGR",+ |
+
| 300 | ++ |
+ variables = list(+ |
+
| 301 | ++ |
+ id = "USUBJID",+ |
+
| 302 | ++ |
+ baseline_var = "BTOXGR",+ |
+
| 303 | ++ |
+ direction_var = "GRADDR"+ |
+
| 304 | ++ |
+ )) {
+ |
+
| 305 | +1x | +
+ checkmate::assert_string(.var)+ |
+
| 306 | +1x | +
+ checkmate::assert_set_equal(names(variables), c("id", "baseline_var", "direction_var"))
+ |
+
| 307 | +1x | +
+ checkmate::assert_string(variables$id)+ |
+
| 308 | +1x | +
+ checkmate::assert_string(variables$baseline_var)+ |
+
| 309 | +1x | +
+ checkmate::assert_string(variables$direction_var)+ |
+
| 310 | +1x | +
+ assert_df_with_variables(df, c(aval = .var, variables[1:3]))+ |
+
| 311 | +1x | +
+ assert_list_of_variables(variables)+ |
+
| 312 | ++ | + + | +
| 313 | +1x | +
+ h_worsen_counter(df, variables$id, .var, variables$baseline_var, variables$direction_var)+ |
+
| 314 | ++ |
+ }+ |
+
| 315 | ++ | + + | +
| 316 | ++ | + + | +
| 317 | ++ |
+ #' @describeIn abnormal_by_worst_grade_worsen Formatted analysis function which is used as `afun`+ |
+
| 318 | ++ |
+ #' in `count_abnormal_lab_worsen_by_baseline()`.+ |
+
| 319 | ++ |
+ #'+ |
+
| 320 | ++ |
+ #' @return+ |
+
| 321 | ++ |
+ #' * `a_count_abnormal_lab_worsen_by_baseline()` returns the corresponding list with+ |
+
| 322 | ++ |
+ #' formatted [rtables::CellValue()].+ |
+
| 323 | ++ |
+ #'+ |
+
| 324 | ++ |
+ #' @keywords internal+ |
+
| 325 | ++ |
+ a_count_abnormal_lab_worsen_by_baseline <- make_afun( # nolint+ |
+
| 326 | ++ |
+ s_count_abnormal_lab_worsen_by_baseline,+ |
+
| 327 | ++ |
+ .formats = c(fraction = format_fraction),+ |
+
| 328 | ++ |
+ .ungroup_stats = "fraction"+ |
+
| 329 | ++ |
+ )+ |
+
| 330 | ++ | + + | +
| 331 | ++ |
+ #' @describeIn abnormal_by_worst_grade_worsen Layout-creating function which can take statistics function+ |
+
| 332 | ++ |
+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 333 | ++ |
+ #'+ |
+
| 334 | ++ |
+ #' @return+ |
+
| 335 | ++ |
+ #' * `count_abnormal_lab_worsen_by_baseline()` returns a layout object suitable for passing to further layouting+ |
+
| 336 | ++ |
+ #' functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted+ |
+
| 337 | ++ |
+ #' rows containing the statistics from `s_count_abnormal_lab_worsen_by_baseline()` to the table layout.+ |
+
| 338 | ++ |
+ #'+ |
+
| 339 | ++ |
+ #' @examples+ |
+
| 340 | ++ |
+ #' basic_table() %>%+ |
+
| 341 | ++ |
+ #' split_cols_by("ARMCD") %>%
+ |
+
| 342 | ++ |
+ #' add_colcounts() %>%+ |
+
| 343 | ++ |
+ #' split_rows_by("PARAMCD") %>%
+ |
+
| 344 | ++ |
+ #' split_rows_by("GRADDR") %>%
+ |
+
| 345 | ++ |
+ #' count_abnormal_lab_worsen_by_baseline(+ |
+
| 346 | ++ |
+ #' var = "ATOXGR",+ |
+
| 347 | ++ |
+ #' variables = list(+ |
+
| 348 | ++ |
+ #' id = "USUBJID",+ |
+
| 349 | ++ |
+ #' baseline_var = "BTOXGR",+ |
+
| 350 | ++ |
+ #' direction_var = "GRADDR"+ |
+
| 351 | ++ |
+ #' )+ |
+
| 352 | ++ |
+ #' ) %>%+ |
+
| 353 | ++ |
+ #' append_topleft("Direction of Abnormality") %>%
+ |
+
| 354 | ++ |
+ #' build_table(df = df, alt_counts_df = tern_ex_adsl)+ |
+
| 355 | ++ |
+ #'+ |
+
| 356 | ++ |
+ #' @export+ |
+
| 357 | ++ |
+ count_abnormal_lab_worsen_by_baseline <- function(lyt, # nolint+ |
+
| 358 | ++ |
+ var,+ |
+
| 359 | ++ |
+ na_str = NA_character_,+ |
+
| 360 | ++ |
+ nested = TRUE,+ |
+
| 361 | ++ |
+ ...,+ |
+
| 362 | ++ |
+ table_names = NULL,+ |
+
| 363 | ++ |
+ .stats = NULL,+ |
+
| 364 | ++ |
+ .formats = NULL,+ |
+
| 365 | ++ |
+ .labels = NULL,+ |
+
| 366 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 367 | +1x | +
+ checkmate::assert_string(var)+ |
+
| 368 | ++ | + + | +
| 369 | +1x | +
+ afun <- make_afun(+ |
+
| 370 | +1x | +
+ a_count_abnormal_lab_worsen_by_baseline,+ |
+
| 371 | +1x | +
+ .stats = .stats,+ |
+
| 372 | +1x | +
+ .formats = .formats,+ |
+
| 373 | +1x | +
+ .labels = .labels,+ |
+
| 374 | +1x | +
+ .indent_mods = .indent_mods+ |
+
| 375 | ++ |
+ )+ |
+
| 376 | ++ | + + | +
| 377 | +1x | +
+ lyt <- analyze(+ |
+
| 378 | +1x | +
+ lyt = lyt,+ |
+
| 379 | +1x | +
+ vars = var,+ |
+
| 380 | +1x | +
+ afun = afun,+ |
+
| 381 | +1x | +
+ na_str = na_str,+ |
+
| 382 | +1x | +
+ nested = nested,+ |
+
| 383 | +1x | +
+ extra_args = list(...),+ |
+
| 384 | +1x | +
+ show_labels = "hidden"+ |
+
| 385 | ++ |
+ )+ |
+
| 386 | ++ | + + | +
| 387 | +1x | +
+ lyt+ |
+
| 388 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Cox Proportional Hazards Regression+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Fits a Cox regression model and estimates hazard ratio to describe the effect size in a survival analysis.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @details Cox models are the most commonly used methods to estimate the magnitude of+ |
+
| 10 | ++ |
+ #' the effect in survival analysis. It assumes proportional hazards: the ratio+ |
+
| 11 | ++ |
+ #' of the hazards between groups (e.g., two arms) is constant over time.+ |
+
| 12 | ++ |
+ #' This ratio is referred to as the "hazard ratio" (HR) and is one of the+ |
+
| 13 | ++ |
+ #' most commonly reported metrics to describe the effect size in survival+ |
+
| 14 | ++ |
+ #' analysis (NEST Team, 2020).+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @seealso [fit_coxreg] for relevant fitting functions, [h_cox_regression] for relevant+ |
+
| 17 | ++ |
+ #' helper functions, and [tidy_coxreg] for custom tidy methods.+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @examples+ |
+
| 20 | ++ |
+ #' library(survival)+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' # Testing dataset [survival::bladder].+ |
+
| 23 | ++ |
+ #' set.seed(1, kind = "Mersenne-Twister")+ |
+
| 24 | ++ |
+ #' dta_bladder <- with(+ |
+
| 25 | ++ |
+ #' data = bladder[bladder$enum < 5, ],+ |
+
| 26 | ++ |
+ #' tibble::tibble(+ |
+
| 27 | ++ |
+ #' TIME = stop,+ |
+
| 28 | ++ |
+ #' STATUS = event,+ |
+
| 29 | ++ |
+ #' ARM = as.factor(rx),+ |
+
| 30 | ++ |
+ #' COVAR1 = as.factor(enum) %>% formatters::with_label("A Covariate Label"),
+ |
+
| 31 | ++ |
+ #' COVAR2 = factor(+ |
+
| 32 | ++ |
+ #' sample(as.factor(enum)),+ |
+
| 33 | ++ |
+ #' levels = 1:4, labels = c("F", "F", "M", "M")
+ |
+
| 34 | ++ |
+ #' ) %>% formatters::with_label("Sex (F/M)")
+ |
+
| 35 | ++ |
+ #' )+ |
+
| 36 | ++ |
+ #' )+ |
+
| 37 | ++ |
+ #' dta_bladder$AGE <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ |
+
| 38 | ++ |
+ #' dta_bladder$STUDYID <- factor("X")
+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' plot(+ |
+
| 41 | ++ |
+ #' survfit(Surv(TIME, STATUS) ~ ARM + COVAR1, data = dta_bladder),+ |
+
| 42 | ++ |
+ #' lty = 2:4,+ |
+
| 43 | ++ |
+ #' xlab = "Months",+ |
+
| 44 | ++ |
+ #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
+ |
+
| 45 | ++ |
+ #' )+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ #' @name cox_regression+ |
+
| 48 | ++ |
+ NULL+ |
+
| 49 | ++ | + + | +
| 50 | ++ |
+ #' @describeIn cox_regression Statistics function that transforms results tabulated+ |
+
| 51 | ++ |
+ #' from [fit_coxreg_univar()] or [fit_coxreg_multivar()] into a list.+ |
+
| 52 | ++ |
+ #'+ |
+
| 53 | ++ |
+ #' @param model_df (`data.frame`)\cr contains the resulting model fit from a [fit_coxreg]+ |
+
| 54 | ++ |
+ #' function with tidying applied via [broom::tidy()].+ |
+
| 55 | ++ |
+ #' @param .stats (`character`)\cr the name of statistics to be reported among:+ |
+
| 56 | ++ |
+ #' * `n`: number of observations (univariate only)+ |
+
| 57 | ++ |
+ #' * `hr`: hazard ratio+ |
+
| 58 | ++ |
+ #' * `ci`: confidence interval+ |
+
| 59 | ++ |
+ #' * `pval`: p-value of the treatment effect+ |
+
| 60 | ++ |
+ #' * `pval_inter`: p-value of the interaction effect between the treatment and the covariate (univariate only)+ |
+
| 61 | ++ |
+ #' @param .which_vars (`character`)\cr which rows should statistics be returned for from the given model.+ |
+
| 62 | ++ |
+ #' Defaults to "all". Other options include "var_main" for main effects, `"inter"` for interaction effects,+ |
+
| 63 | ++ |
+ #' and `"multi_lvl"` for multivariate model covariate level rows. When `.which_vars` is "all" specific+ |
+
| 64 | ++ |
+ #' variables can be selected by specifying `.var_nms`.+ |
+
| 65 | ++ |
+ #' @param .var_nms (`character`)\cr the `term` value of rows in `df` for which `.stats` should be returned. Typically+ |
+
| 66 | ++ |
+ #' this is the name of a variable. If using variable labels, `var` should be a vector of both the desired+ |
+
| 67 | ++ |
+ #' variable name and the variable label in that order to see all `.stats` related to that variable. When `.which_vars`+ |
+
| 68 | ++ |
+ #' is `"var_main"` `.var_nms` should be only the variable name.+ |
+
| 69 | ++ |
+ #'+ |
+
| 70 | ++ |
+ #' @return+ |
+
| 71 | ++ |
+ #' * `s_coxreg()` returns the selected statistic for from the Cox regression model for the selected variable(s).+ |
+
| 72 | ++ |
+ #'+ |
+
| 73 | ++ |
+ #' @examples+ |
+
| 74 | ++ |
+ #' # s_coxreg+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ #' # Univariate+ |
+
| 77 | ++ |
+ #' u1_variables <- list(+ |
+
| 78 | ++ |
+ #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
+ |
+
| 79 | ++ |
+ #' )+ |
+
| 80 | ++ |
+ #' univar_model <- fit_coxreg_univar(variables = u1_variables, data = dta_bladder)+ |
+
| 81 | ++ |
+ #' df1 <- broom::tidy(univar_model)+ |
+
| 82 | ++ |
+ #' s_coxreg(model_df = df1, .stats = "hr")+ |
+
| 83 | ++ |
+ #'+ |
+
| 84 | ++ |
+ #' # Univariate with interactions+ |
+
| 85 | ++ |
+ #' univar_model_inter <- fit_coxreg_univar(+ |
+
| 86 | ++ |
+ #' variables = u1_variables, control = control_coxreg(interaction = TRUE), data = dta_bladder+ |
+
| 87 | ++ |
+ #' )+ |
+
| 88 | ++ |
+ #' df1_inter <- broom::tidy(univar_model_inter)+ |
+
| 89 | ++ |
+ #' s_coxreg(model_df = df1_inter, .stats = "hr", .which_vars = "inter", .var_nms = "COVAR1")+ |
+
| 90 | ++ |
+ #'+ |
+
| 91 | ++ |
+ #' # Univariate without treatment arm - only "COVAR2" covariate effects+ |
+
| 92 | ++ |
+ #' u2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
+ |
+
| 93 | ++ |
+ #' univar_covs_model <- fit_coxreg_univar(variables = u2_variables, data = dta_bladder)+ |
+
| 94 | ++ |
+ #' df1_covs <- broom::tidy(univar_covs_model)+ |
+
| 95 | ++ |
+ #' s_coxreg(model_df = df1_covs, .stats = "hr", .var_nms = c("COVAR2", "Sex (F/M)"))
+ |
+
| 96 | ++ |
+ #'+ |
+
| 97 | ++ |
+ #' # Multivariate.+ |
+
| 98 | ++ |
+ #' m1_variables <- list(+ |
+
| 99 | ++ |
+ #' time = "TIME", event = "STATUS", arm = "ARM", covariates = c("COVAR1", "COVAR2")
+ |
+
| 100 | ++ |
+ #' )+ |
+
| 101 | ++ |
+ #' multivar_model <- fit_coxreg_multivar(variables = m1_variables, data = dta_bladder)+ |
+
| 102 | ++ |
+ #' df2 <- broom::tidy(multivar_model)+ |
+
| 103 | ++ |
+ #' s_coxreg(model_df = df2, .stats = "pval", .which_vars = "var_main", .var_nms = "COVAR1")+ |
+
| 104 | ++ |
+ #' s_coxreg(+ |
+
| 105 | ++ |
+ #' model_df = df2, .stats = "pval", .which_vars = "multi_lvl",+ |
+
| 106 | ++ |
+ #' .var_nms = c("COVAR1", "A Covariate Label")
+ |
+
| 107 | ++ |
+ #' )+ |
+
| 108 | ++ |
+ #'+ |
+
| 109 | ++ |
+ #' # Multivariate without treatment arm - only "COVAR1" main effect+ |
+
| 110 | ++ |
+ #' m2_variables <- list(time = "TIME", event = "STATUS", covariates = c("COVAR1", "COVAR2"))
+ |
+
| 111 | ++ |
+ #' multivar_covs_model <- fit_coxreg_multivar(variables = m2_variables, data = dta_bladder)+ |
+
| 112 | ++ |
+ #' df2_covs <- broom::tidy(multivar_covs_model)+ |
+
| 113 | ++ |
+ #' s_coxreg(model_df = df2_covs, .stats = "hr")+ |
+
| 114 | ++ |
+ #'+ |
+
| 115 | ++ |
+ #' @export+ |
+
| 116 | ++ |
+ s_coxreg <- function(model_df, .stats, .which_vars = "all", .var_nms = NULL) {
+ |
+
| 117 | +194x | +
+ assert_df_with_variables(model_df, list(term = "term", stat = .stats))+ |
+
| 118 | +194x | +
+ checkmate::assert_multi_class(model_df$term, classes = c("factor", "character"))
+ |
+
| 119 | +194x | +
+ model_df$term <- as.character(model_df$term)+ |
+
| 120 | +194x | +
+ .var_nms <- .var_nms[!is.na(.var_nms)]+ |
+
| 121 | ++ | + + | +
| 122 | +192x | +
+ if (length(.var_nms) > 0) model_df <- model_df[model_df$term %in% .var_nms, ]+ |
+
| 123 | +39x | +
+ if (.which_vars == "multi_lvl") model_df$term <- tail(.var_nms, 1)+ |
+
| 124 | ++ | + + | +
| 125 | ++ |
+ # We need a list with names corresponding to the stats to display of equal length to the list of stats.+ |
+
| 126 | +194x | +
+ y <- split(model_df, f = model_df$term, drop = FALSE)+ |
+
| 127 | +194x | +
+ y <- stats::setNames(y, nm = rep(.stats, length(y)))+ |
+
| 128 | ++ | + + | +
| 129 | +194x | +
+ if (.which_vars == "var_main") {
+ |
+
| 130 | +84x | +
+ y <- lapply(y, function(x) x[1, ]) # only main effect+ |
+
| 131 | +110x | +
+ } else if (.which_vars %in% c("inter", "multi_lvl")) {
+ |
+
| 132 | +80x | +
+ y <- lapply(y, function(x) if (nrow(y[[1]]) > 1) x[-1, ] else x) # exclude main effect+ |
+
| 133 | ++ |
+ }+ |
+
| 134 | ++ | + + | +
| 135 | +194x | +
+ lapply(+ |
+
| 136 | +194x | +
+ X = y,+ |
+
| 137 | +194x | +
+ FUN = function(x) {
+ |
+
| 138 | +198x | +
+ z <- as.list(x[[.stats]])+ |
+
| 139 | +198x | +
+ stats::setNames(z, nm = x$term_label)+ |
+
| 140 | ++ |
+ }+ |
+
| 141 | ++ |
+ )+ |
+
| 142 | ++ |
+ }+ |
+
| 143 | ++ | + + | +
| 144 | ++ |
+ #' @describeIn cox_regression Analysis function which is used as `afun` in [rtables::analyze()]+ |
+
| 145 | ++ |
+ #' and `cfun` in [rtables::summarize_row_groups()] within `summarize_coxreg()`.+ |
+
| 146 | ++ |
+ #'+ |
+
| 147 | ++ |
+ #' @param eff (`flag`)\cr whether treatment effect should be calculated. Defaults to `FALSE`.+ |
+
| 148 | ++ |
+ #' @param var_main (`flag`)\cr whether main effects should be calculated. Defaults to `FALSE`.+ |
+
| 149 | ++ |
+ #' @param na_str (`string`)\cr custom string to replace all `NA` values with. Defaults to `""`.+ |
+
| 150 | ++ |
+ #' @param cache_env (`environment`)\cr an environment object used to cache the regression model in order to+ |
+
| 151 | ++ |
+ #' avoid repeatedly fitting the same model for every row in the table. Defaults to `NULL` (no caching).+ |
+
| 152 | ++ |
+ #' @param varlabels (`list`)\cr a named list corresponds to the names of variables found in data, passed+ |
+
| 153 | ++ |
+ #' as a named list and corresponding to time, event, arm, strata, and covariates terms. If arm is missing+ |
+
| 154 | ++ |
+ #' from variables, then only Cox model(s) including the covariates will be fitted and the corresponding+ |
+
| 155 | ++ |
+ #' effect estimates will be tabulated later.+ |
+
| 156 | ++ |
+ #'+ |
+
| 157 | ++ |
+ #' @return+ |
+
| 158 | ++ |
+ #' * `a_coxreg()` returns formatted [rtables::CellValue()].+ |
+
| 159 | ++ |
+ #'+ |
+
| 160 | ++ |
+ #' @examples+ |
+
| 161 | ++ |
+ #' a_coxreg(+ |
+
| 162 | ++ |
+ #' df = dta_bladder,+ |
+
| 163 | ++ |
+ #' labelstr = "Label 1",+ |
+
| 164 | ++ |
+ #' variables = u1_variables,+ |
+
| 165 | ++ |
+ #' .spl_context = list(value = "COVAR1"),+ |
+
| 166 | ++ |
+ #' .stats = "n",+ |
+
| 167 | ++ |
+ #' .formats = "xx"+ |
+
| 168 | ++ |
+ #' )+ |
+
| 169 | ++ |
+ #'+ |
+
| 170 | ++ |
+ #' a_coxreg(+ |
+
| 171 | ++ |
+ #' df = dta_bladder,+ |
+
| 172 | ++ |
+ #' labelstr = "",+ |
+
| 173 | ++ |
+ #' variables = u1_variables,+ |
+
| 174 | ++ |
+ #' .spl_context = list(value = "COVAR2"),+ |
+
| 175 | ++ |
+ #' .stats = "pval",+ |
+
| 176 | ++ |
+ #' .formats = "xx.xxxx"+ |
+
| 177 | ++ |
+ #' )+ |
+
| 178 | ++ |
+ #'+ |
+
| 179 | ++ |
+ #' @export+ |
+
| 180 | ++ |
+ a_coxreg <- function(df,+ |
+
| 181 | ++ |
+ labelstr,+ |
+
| 182 | ++ |
+ eff = FALSE,+ |
+
| 183 | ++ |
+ var_main = FALSE,+ |
+
| 184 | ++ |
+ multivar = FALSE,+ |
+
| 185 | ++ |
+ variables,+ |
+
| 186 | ++ |
+ at = list(),+ |
+
| 187 | ++ |
+ control = control_coxreg(),+ |
+
| 188 | ++ |
+ .spl_context,+ |
+
| 189 | ++ |
+ .stats,+ |
+
| 190 | ++ |
+ .formats,+ |
+
| 191 | ++ |
+ .indent_mods = NULL,+ |
+
| 192 | ++ |
+ na_level = lifecycle::deprecated(),+ |
+
| 193 | ++ |
+ na_str = "",+ |
+
| 194 | ++ |
+ cache_env = NULL) {
+ |
+
| 195 | +191x | +
+ if (lifecycle::is_present(na_level)) {
+ |
+
| 196 | +! | +
+ lifecycle::deprecate_warn("0.9.1", "a_coxreg(na_level)", "a_coxreg(na_str)")
+ |
+
| 197 | +! | +
+ na_str <- na_level+ |
+
| 198 | ++ |
+ }+ |
+
| 199 | ++ | + + | +
| 200 | +191x | +
+ cov_no_arm <- !multivar && !"arm" %in% names(variables) && control$interaction # special case: univar no arm+ |
+
| 201 | +191x | +
+ cov <- tail(.spl_context$value, 1) # current variable/covariate+ |
+
| 202 | +191x | +
+ var_lbl <- formatters::var_labels(df)[cov] # check for df labels+ |
+
| 203 | +191x | +
+ if (length(labelstr) > 1) {
+ |
+
| 204 | +! | +
+ labelstr <- if (cov %in% names(labelstr)) labelstr[[cov]] else var_lbl # use df labels if none+ |
+
| 205 | +191x | +
+ } else if (!is.na(var_lbl) && labelstr == cov && cov %in% variables$covariates) {
+ |
+
| 206 | +62x | +
+ labelstr <- var_lbl+ |
+
| 207 | ++ |
+ }+ |
+
| 208 | +191x | +
+ if (eff || multivar || cov_no_arm) {
+ |
+
| 209 | +82x | +
+ control$interaction <- FALSE+ |
+
| 210 | ++ |
+ } else {
+ |
+
| 211 | +109x | +
+ variables$covariates <- cov+ |
+
| 212 | +40x | +
+ if (var_main) control$interaction <- TRUE+ |
+
| 213 | ++ |
+ }+ |
+
| 214 | ++ | + + | +
| 215 | +191x | +
+ if (is.null(cache_env[[cov]])) {
+ |
+
| 216 | +30x | +
+ if (!multivar) {
+ |
+
| 217 | +23x | +
+ model <- fit_coxreg_univar(variables = variables, data = df, at = at, control = control) %>% broom::tidy()+ |
+
| 218 | ++ |
+ } else {
+ |
+
| 219 | +7x | +
+ model <- fit_coxreg_multivar(variables = variables, data = df, control = control) %>% broom::tidy()+ |
+
| 220 | ++ |
+ }+ |
+
| 221 | +30x | +
+ cache_env[[cov]] <- model+ |
+
| 222 | ++ |
+ } else {
+ |
+
| 223 | +161x | +
+ model <- cache_env[[cov]]+ |
+
| 224 | ++ |
+ }+ |
+
| 225 | +109x | +
+ if (!multivar && !var_main) model[, "pval_inter"] <- NA_real_+ |
+
| 226 | ++ | + + | +
| 227 | +191x | +
+ if (cov_no_arm || (!cov_no_arm && !"arm" %in% names(variables) && is.numeric(df[[cov]]))) {
+ |
+
| 228 | +15x | +
+ multivar <- TRUE+ |
+
| 229 | +3x | +
+ if (!cov_no_arm) var_main <- TRUE+ |
+
| 230 | ++ |
+ }+ |
+
| 231 | ++ | + + | +
| 232 | +191x | +
+ vars_coxreg <- list(which_vars = "all", var_nms = NULL)+ |
+
| 233 | +191x | +
+ if (eff) {
+ |
+
| 234 | +40x | +
+ if (multivar && !var_main) { # multivar treatment level
+ |
+
| 235 | +6x | +
+ var_lbl_arm <- formatters::var_labels(df)[[variables$arm]]+ |
+
| 236 | +6x | +
+ vars_coxreg[c("var_nms", "which_vars")] <- list(c(variables$arm, var_lbl_arm), "multi_lvl")
+ |
+
| 237 | ++ |
+ } else { # treatment effect
+ |
+
| 238 | +34x | +
+ vars_coxreg["var_nms"] <- variables$arm+ |
+
| 239 | +6x | +
+ if (var_main) vars_coxreg["which_vars"] <- "var_main"+ |
+
| 240 | ++ |
+ }+ |
+
| 241 | ++ |
+ } else {
+ |
+
| 242 | +151x | +
+ if (!multivar || (multivar && var_main && !is.numeric(df[[cov]]))) { # covariate effect/level
+ |
+
| 243 | +118x | +
+ vars_coxreg[c("var_nms", "which_vars")] <- list(cov, "var_main")
+ |
+
| 244 | +33x | +
+ } else if (multivar) { # multivar covariate level
+ |
+
| 245 | +33x | +
+ vars_coxreg[c("var_nms", "which_vars")] <- list(c(cov, var_lbl), "multi_lvl")
+ |
+
| 246 | +6x | +
+ if (var_main) model[cov, .stats] <- NA_real_+ |
+
| 247 | ++ |
+ }+ |
+
| 248 | +40x | +
+ if (!multivar && !var_main && control$interaction) vars_coxreg["which_vars"] <- "inter" # interaction effect+ |
+
| 249 | ++ |
+ }+ |
+
| 250 | +191x | +
+ var_vals <- s_coxreg(model, .stats, .which_vars = vars_coxreg$which_vars, .var_nms = vars_coxreg$var_nms)[[1]]+ |
+
| 251 | +191x | +
+ var_names <- if (all(grepl("\\(reference = ", names(var_vals))) && labelstr != tail(.spl_context$value, 1)) {
+ |
+
| 252 | +21x | +
+ paste(c(labelstr, tail(strsplit(names(var_vals), " ")[[1]], 3)), collapse = " ") # "reference" main effect labels+ |
+
| 253 | +191x | +
+ } else if ((!multivar && !eff && !(!var_main && control$interaction) && nchar(labelstr) > 0) ||+ |
+
| 254 | +191x | +
+ (multivar && var_main && is.numeric(df[[cov]]))) { # nolint
+ |
+
| 255 | +47x | +
+ labelstr # other main effect labels+ |
+
| 256 | +191x | +
+ } else if (multivar && !eff && !var_main && is.numeric(df[[cov]])) {
+ |
+
| 257 | +6x | +
+ "All" # multivar numeric covariate+ |
+
| 258 | ++ |
+ } else {
+ |
+
| 259 | +117x | +
+ names(var_vals)+ |
+
| 260 | ++ |
+ }+ |
+
| 261 | +191x | +
+ in_rows(+ |
+
| 262 | +191x | +
+ .list = var_vals, .names = var_names, .labels = var_names, .indent_mods = .indent_mods,+ |
+
| 263 | +191x | +
+ .formats = stats::setNames(rep(.formats, length(var_names)), var_names),+ |
+
| 264 | +191x | +
+ .format_na_strs = stats::setNames(rep(na_str, length(var_names)), var_names)+ |
+
| 265 | ++ |
+ )+ |
+
| 266 | ++ |
+ }+ |
+
| 267 | ++ | + + | +
| 268 | ++ |
+ #' @describeIn cox_regression Layout-creating function which creates a Cox regression summary table+ |
+
| 269 | ++ |
+ #' layout. This function is a wrapper for several `rtables` layouting functions. This function+ |
+
| 270 | ++ |
+ #' is a wrapper for [rtables::analyze_colvars()] and [rtables::summarize_row_groups()].+ |
+
| 271 | ++ |
+ #'+ |
+
| 272 | ++ |
+ #' @inheritParams fit_coxreg_univar+ |
+
| 273 | ++ |
+ #' @param multivar (`flag`)\cr Defaults to `FALSE`. If `TRUE` multivariate Cox regression will run, otherwise+ |
+
| 274 | ++ |
+ #' univariate Cox regression will run.+ |
+
| 275 | ++ |
+ #' @param common_var (`character`)\cr the name of a factor variable in the dataset which takes the same value+ |
+
| 276 | ++ |
+ #' for all rows. This should be created during pre-processing if no such variable currently exists.+ |
+
| 277 | ++ |
+ #' @param .section_div (`character`)\cr string which should be repeated as a section divider between sections.+ |
+
| 278 | ++ |
+ #' Defaults to `NA` for no section divider. If a vector of two strings are given, the first will be used between+ |
+
| 279 | ++ |
+ #' treatment and covariate sections and the second between different covariates.+ |
+
| 280 | ++ |
+ #'+ |
+
| 281 | ++ |
+ #' @return+ |
+
| 282 | ++ |
+ #' * `summarize_coxreg()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 283 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add a Cox regression table+ |
+
| 284 | ++ |
+ #' containing the chosen statistics to the table layout.+ |
+
| 285 | ++ |
+ #'+ |
+
| 286 | ++ |
+ #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()] which also take the `variables`, `data`,+ |
+
| 287 | ++ |
+ #' `at` (univariate only), and `control` arguments but return unformatted univariate and multivariate+ |
+
| 288 | ++ |
+ #' Cox regression models, respectively.+ |
+
| 289 | ++ |
+ #'+ |
+
| 290 | ++ |
+ #' @examples+ |
+
| 291 | ++ |
+ #' # summarize_coxreg+ |
+
| 292 | ++ |
+ #'+ |
+
| 293 | ++ |
+ #' result_univar <- basic_table() %>%+ |
+
| 294 | ++ |
+ #' summarize_coxreg(variables = u1_variables) %>%+ |
+
| 295 | ++ |
+ #' build_table(dta_bladder)+ |
+
| 296 | ++ |
+ #' result_univar+ |
+
| 297 | ++ |
+ #'+ |
+
| 298 | ++ |
+ #' result_multivar <- basic_table() %>%+ |
+
| 299 | ++ |
+ #' summarize_coxreg(+ |
+
| 300 | ++ |
+ #' variables = m1_variables,+ |
+
| 301 | ++ |
+ #' multivar = TRUE,+ |
+
| 302 | ++ |
+ #' ) %>%+ |
+
| 303 | ++ |
+ #' build_table(dta_bladder)+ |
+
| 304 | ++ |
+ #' result_multivar+ |
+
| 305 | ++ |
+ #'+ |
+
| 306 | ++ |
+ #' result_univar_covs <- basic_table() %>%+ |
+
| 307 | ++ |
+ #' summarize_coxreg(+ |
+
| 308 | ++ |
+ #' variables = u2_variables,+ |
+
| 309 | ++ |
+ #' ) %>%+ |
+
| 310 | ++ |
+ #' build_table(dta_bladder)+ |
+
| 311 | ++ |
+ #' result_univar_covs+ |
+
| 312 | ++ |
+ #'+ |
+
| 313 | ++ |
+ #' result_multivar_covs <- basic_table() %>%+ |
+
| 314 | ++ |
+ #' summarize_coxreg(+ |
+
| 315 | ++ |
+ #' variables = m2_variables,+ |
+
| 316 | ++ |
+ #' multivar = TRUE,+ |
+
| 317 | ++ |
+ #' varlabels = c("Covariate 1", "Covariate 2") # custom labels
+ |
+
| 318 | ++ |
+ #' ) %>%+ |
+
| 319 | ++ |
+ #' build_table(dta_bladder)+ |
+
| 320 | ++ |
+ #' result_multivar_covs+ |
+
| 321 | ++ |
+ #'+ |
+
| 322 | ++ |
+ #' @export+ |
+
| 323 | ++ |
+ summarize_coxreg <- function(lyt,+ |
+
| 324 | ++ |
+ variables,+ |
+
| 325 | ++ |
+ control = control_coxreg(),+ |
+
| 326 | ++ |
+ at = list(),+ |
+
| 327 | ++ |
+ multivar = FALSE,+ |
+
| 328 | ++ |
+ common_var = "STUDYID",+ |
+
| 329 | ++ |
+ .stats = c("n", "hr", "ci", "pval", "pval_inter"),
+ |
+
| 330 | ++ |
+ .formats = c(+ |
+
| 331 | ++ |
+ n = "xx", hr = "xx.xx", ci = "(xx.xx, xx.xx)",+ |
+
| 332 | ++ |
+ pval = "x.xxxx | (<0.0001)", pval_inter = "x.xxxx | (<0.0001)"+ |
+
| 333 | ++ |
+ ),+ |
+
| 334 | ++ |
+ varlabels = NULL,+ |
+
| 335 | ++ |
+ .indent_mods = NULL,+ |
+
| 336 | ++ |
+ na_level = lifecycle::deprecated(),+ |
+
| 337 | ++ |
+ na_str = "",+ |
+
| 338 | ++ |
+ .section_div = NA_character_) {
+ |
+
| 339 | +11x | +
+ if (lifecycle::is_present(na_level)) {
+ |
+
| 340 | +! | +
+ lifecycle::deprecate_warn("0.9.1", "summarize_coxreg(na_level)", "summarize_coxreg(na_str)")
+ |
+
| 341 | +! | +
+ na_str <- na_level+ |
+
| 342 | ++ |
+ }+ |
+
| 343 | ++ | + + | +
| 344 | +11x | +
+ if (multivar && control$interaction) {
+ |
+
| 345 | +1x | +
+ warning(paste(+ |
+
| 346 | +1x | +
+ "Interactions are not available for multivariate cox regression using summarize_coxreg.",+ |
+
| 347 | +1x | +
+ "The model will be calculated without interaction effects."+ |
+
| 348 | ++ |
+ ))+ |
+
| 349 | ++ |
+ }+ |
+
| 350 | +11x | +
+ if (control$interaction && !"arm" %in% names(variables)) {
+ |
+
| 351 | +1x | +
+ stop("To include interactions please specify 'arm' in variables.")
+ |
+
| 352 | ++ |
+ }+ |
+
| 353 | ++ | + + | +
| 354 | +10x | +
+ .stats <- if (!"arm" %in% names(variables) || multivar) { # only valid statistics
+ |
+
| 355 | +4x | +
+ intersect(c("hr", "ci", "pval"), .stats)
+ |
+
| 356 | +10x | +
+ } else if (control$interaction) {
+ |
+
| 357 | +4x | +
+ intersect(c("n", "hr", "ci", "pval", "pval_inter"), .stats)
+ |
+
| 358 | ++ |
+ } else {
+ |
+
| 359 | +2x | +
+ intersect(c("n", "hr", "ci", "pval"), .stats)
+ |
+
| 360 | ++ |
+ }+ |
+
| 361 | +10x | +
+ stat_labels <- c(+ |
+
| 362 | +10x | +
+ n = "n", hr = "Hazard Ratio", ci = paste0(control$conf_level * 100, "% CI"),+ |
+
| 363 | +10x | +
+ pval = "p-value", pval_inter = "Interaction p-value"+ |
+
| 364 | ++ |
+ )+ |
+
| 365 | +10x | +
+ stat_labels <- stat_labels[names(stat_labels) %in% .stats]+ |
+
| 366 | +10x | +
+ .formats <- .formats[names(.formats) %in% .stats]+ |
+
| 367 | +10x | +
+ env <- new.env() # create caching environment+ |
+
| 368 | ++ | + + | +
| 369 | +10x | +
+ lyt <- lyt %>%+ |
+
| 370 | +10x | +
+ split_cols_by_multivar(+ |
+
| 371 | +10x | +
+ vars = rep(common_var, length(.stats)),+ |
+
| 372 | +10x | +
+ varlabels = stat_labels,+ |
+
| 373 | +10x | +
+ extra_args = list(+ |
+
| 374 | +10x | +
+ .stats = .stats, .formats = .formats, .indent_mods = .indent_mods, na_str = rep(na_str, length(.stats)),+ |
+
| 375 | +10x | +
+ cache_env = replicate(length(.stats), list(env))+ |
+
| 376 | ++ |
+ )+ |
+
| 377 | ++ |
+ )+ |
+
| 378 | ++ | + + | +
| 379 | +10x | +
+ if ("arm" %in% names(variables)) { # treatment effect
+ |
+
| 380 | +8x | +
+ lyt <- lyt %>%+ |
+
| 381 | +8x | +
+ split_rows_by(+ |
+
| 382 | +8x | +
+ common_var,+ |
+
| 383 | +8x | +
+ split_label = "Treatment:",+ |
+
| 384 | +8x | +
+ label_pos = "visible",+ |
+
| 385 | +8x | +
+ child_labels = "hidden",+ |
+
| 386 | +8x | +
+ section_div = head(.section_div, 1)+ |
+
| 387 | ++ |
+ )+ |
+
| 388 | +8x | +
+ if (!multivar) {
+ |
+
| 389 | +6x | +
+ lyt <- lyt %>%+ |
+
| 390 | +6x | +
+ analyze_colvars(+ |
+
| 391 | +6x | +
+ afun = a_coxreg,+ |
+
| 392 | +6x | +
+ extra_args = list(+ |
+
| 393 | +6x | +
+ variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar,+ |
+
| 394 | +6x | +
+ labelstr = ""+ |
+
| 395 | ++ |
+ )+ |
+
| 396 | ++ |
+ )+ |
+
| 397 | ++ |
+ } else { # treatment level effects
+ |
+
| 398 | +2x | +
+ lyt <- lyt %>%+ |
+
| 399 | +2x | +
+ summarize_row_groups(+ |
+
| 400 | +2x | +
+ cfun = a_coxreg,+ |
+
| 401 | +2x | +
+ na_str = na_str,+ |
+
| 402 | +2x | +
+ extra_args = list(+ |
+
| 403 | +2x | +
+ variables = variables, control = control, multivar = multivar, eff = TRUE, var_main = multivar+ |
+
| 404 | ++ |
+ )+ |
+
| 405 | ++ |
+ ) %>%+ |
+
| 406 | +2x | +
+ analyze_colvars(+ |
+
| 407 | +2x | +
+ afun = a_coxreg,+ |
+
| 408 | +2x | +
+ extra_args = list(eff = TRUE, control = control, variables = variables, multivar = multivar, labelstr = "")+ |
+
| 409 | ++ |
+ )+ |
+
| 410 | ++ |
+ }+ |
+
| 411 | ++ |
+ }+ |
+
| 412 | ++ | + + | +
| 413 | +10x | +
+ if ("covariates" %in% names(variables)) { # covariate main effects
+ |
+
| 414 | +10x | +
+ lyt <- lyt %>%+ |
+
| 415 | +10x | +
+ split_rows_by_multivar(+ |
+
| 416 | +10x | +
+ vars = variables$covariates,+ |
+
| 417 | +10x | +
+ varlabels = varlabels,+ |
+
| 418 | +10x | +
+ split_label = "Covariate:",+ |
+
| 419 | +10x | +
+ nested = FALSE,+ |
+
| 420 | +10x | +
+ child_labels = if (multivar || control$interaction || !"arm" %in% names(variables)) "default" else "hidden",+ |
+
| 421 | +10x | +
+ section_div = tail(.section_div, 1)+ |
+
| 422 | ++ |
+ )+ |
+
| 423 | +10x | +
+ if (multivar || control$interaction || !"arm" %in% names(variables)) {
+ |
+
| 424 | +8x | +
+ lyt <- lyt %>%+ |
+
| 425 | +8x | +
+ summarize_row_groups(+ |
+
| 426 | +8x | +
+ cfun = a_coxreg,+ |
+
| 427 | +8x | +
+ na_str = na_str,+ |
+
| 428 | +8x | +
+ extra_args = list(+ |
+
| 429 | +8x | +
+ variables = variables, at = at, control = control, multivar = multivar,+ |
+
| 430 | +8x | +
+ var_main = if (multivar) multivar else control$interaction+ |
+
| 431 | ++ |
+ )+ |
+
| 432 | ++ |
+ )+ |
+
| 433 | ++ |
+ } else {
+ |
+
| 434 | +! | +
+ if (!is.null(varlabels)) names(varlabels) <- variables$covariates+ |
+
| 435 | +2x | +
+ lyt <- lyt %>%+ |
+
| 436 | +2x | +
+ analyze_colvars(+ |
+
| 437 | +2x | +
+ afun = a_coxreg,+ |
+
| 438 | +2x | +
+ extra_args = list(+ |
+
| 439 | +2x | +
+ variables = variables, at = at, control = control, multivar = multivar,+ |
+
| 440 | +2x | +
+ var_main = if (multivar) multivar else control$interaction,+ |
+
| 441 | +2x | +
+ labelstr = if (is.null(varlabels)) "" else varlabels+ |
+
| 442 | ++ |
+ )+ |
+
| 443 | ++ |
+ )+ |
+
| 444 | ++ |
+ }+ |
+
| 445 | ++ | + + | +
| 446 | +2x | +
+ if (!"arm" %in% names(variables)) control$interaction <- TRUE # special case: univar no arm+ |
+
| 447 | +10x | +
+ if (multivar || control$interaction) { # covariate level effects
+ |
+
| 448 | +8x | +
+ lyt <- lyt %>%+ |
+
| 449 | +8x | +
+ analyze_colvars(+ |
+
| 450 | +8x | +
+ afun = a_coxreg,+ |
+
| 451 | +8x | +
+ extra_args = list(variables = variables, at = at, control = control, multivar = multivar, labelstr = ""),+ |
+
| 452 | +8x | +
+ indent_mod = if (!"arm" %in% names(variables) || multivar) 0L else -1L+ |
+
| 453 | ++ |
+ )+ |
+
| 454 | ++ |
+ }+ |
+
| 455 | ++ |
+ }+ |
+
| 456 | ++ | + + | +
| 457 | +10x | +
+ lyt+ |
+
| 458 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Summary numeric variables in columns+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("experimental")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Layout-creating function which can be used for creating column-wise summary tables.+ |
+
| 6 | ++ |
+ #' This function sets the analysis methods as column labels and is a wrapper for+ |
+
| 7 | ++ |
+ #' [rtables::analyze_colvars()]. It was designed principally for PK tables.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 10 | ++ |
+ #' @inheritParams rtables::analyze_colvars+ |
+
| 11 | ++ |
+ #' @param imp_rule (`character`)\cr imputation rule setting. Defaults to `NULL` for no imputation rule. Can+ |
+
| 12 | ++ |
+ #' also be `"1/3"` to implement 1/3 imputation rule or `"1/2"` to implement 1/2 imputation rule. In order+ |
+
| 13 | ++ |
+ #' to use an imputation rule, the `avalcat_var` argument must be specified. See [imputation_rule()]+ |
+
| 14 | ++ |
+ #' for more details on imputation.+ |
+
| 15 | ++ |
+ #' @param avalcat_var (`character`)\cr if `imp_rule` is not `NULL`, name of variable that indicates whether a+ |
+
| 16 | ++ |
+ #' row in the data corresponds to an analysis value in category `"BLQ"`, `"LTR"`, `"<PCLLOQ"`, or none of+ |
+
| 17 | ++ |
+ #' the above (defaults to `"AVALCAT1"`). Variable must be present in the data and should match the variable+ |
+
| 18 | ++ |
+ #' used to calculate the `n_blq` statistic (if included in `.stats`).+ |
+
| 19 | ++ |
+ #' @param cache (`flag`)\cr whether to store computed values in a temporary caching environment. This will+ |
+
| 20 | ++ |
+ #' speed up calculations in large tables, but should be set to `FALSE` if the same `rtable` layout is+ |
+
| 21 | ++ |
+ #' used for multiple tables with different data. Defaults to `FALSE`.+ |
+
| 22 | ++ |
+ #' @param row_labels (`character`)\cr as this function works in columns space, usual `.labels`+ |
+
| 23 | ++ |
+ #' character vector applies on the column space. You can change the row labels by defining this+ |
+
| 24 | ++ |
+ #' parameter to a named character vector with names corresponding to the split values. It defaults+ |
+
| 25 | ++ |
+ #' to `NULL` and if it contains only one `string`, it will duplicate that as a row label.+ |
+
| 26 | ++ |
+ #' @param do_summarize_row_groups (`flag`)\cr defaults to `FALSE` and applies the analysis to the current+ |
+
| 27 | ++ |
+ #' label rows. This is a wrapper of [rtables::summarize_row_groups()] and it can accept `labelstr`+ |
+
| 28 | ++ |
+ #' to define row labels. This behavior is not supported as we never need to overload row labels.+ |
+
| 29 | ++ |
+ #' @param split_col_vars (`flag`)\cr defaults to `TRUE` and puts the analysis results onto the columns.+ |
+
| 30 | ++ |
+ #' This option allows you to add multiple instances of this functions, also in a nested fashion,+ |
+
| 31 | ++ |
+ #' without adding more splits. This split must happen only one time on a single layout.+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' @return+ |
+
| 34 | ++ |
+ #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()].+ |
+
| 35 | ++ |
+ #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output+ |
+
| 36 | ++ |
+ #' in columns, and add it to the table layout.+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' @note This is an experimental implementation of [rtables::summarize_row_groups()] and+ |
+
| 39 | ++ |
+ #' [rtables::analyze_colvars()] that may be subjected to changes as `rtables` extends its+ |
+
| 40 | ++ |
+ #' support to more complex analysis pipelines on the column space. For the same reasons,+ |
+
| 41 | ++ |
+ #' we encourage to read the examples carefully and file issues for cases that differ from+ |
+
| 42 | ++ |
+ #' them.+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' Here `labelstr` behaves differently than usual. If it is not defined (default as `NULL`),+ |
+
| 45 | ++ |
+ #' row labels are assigned automatically to the split values in case of `rtables::analyze_colvars`+ |
+
| 46 | ++ |
+ #' (`do_summarize_row_groups = FALSE`, the default), and to the group label for+ |
+
| 47 | ++ |
+ #' `do_summarize_row_groups = TRUE`.+ |
+
| 48 | ++ |
+ #'+ |
+
| 49 | ++ |
+ #' @seealso [analyze_vars()], [rtables::analyze_colvars()].+ |
+
| 50 | ++ |
+ #'+ |
+
| 51 | ++ |
+ #' @examples+ |
+
| 52 | ++ |
+ #' library(dplyr)+ |
+
| 53 | ++ |
+ #'+ |
+
| 54 | ++ |
+ #' # Data preparation+ |
+
| 55 | ++ |
+ #' adpp <- tern_ex_adpp %>% h_pkparam_sort()+ |
+
| 56 | ++ |
+ #'+ |
+
| 57 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 58 | ++ |
+ #' split_rows_by(var = "STRATA1", label_pos = "topleft") %>%+ |
+
| 59 | ++ |
+ #' split_rows_by(+ |
+
| 60 | ++ |
+ #' var = "SEX",+ |
+
| 61 | ++ |
+ #' label_pos = "topleft",+ |
+
| 62 | ++ |
+ #' child_label = "hidden"+ |
+
| 63 | ++ |
+ #' ) %>% # Removes duplicated labels+ |
+
| 64 | ++ |
+ #' analyze_vars_in_cols(vars = "AGE")+ |
+
| 65 | ++ |
+ #' result <- build_table(lyt = lyt, df = adpp)+ |
+
| 66 | ++ |
+ #' result+ |
+
| 67 | ++ |
+ #'+ |
+
| 68 | ++ |
+ #' # By selecting just some statistics and ad-hoc labels+ |
+
| 69 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 70 | ++ |
+ #' split_rows_by(var = "ARM", label_pos = "topleft") %>%+ |
+
| 71 | ++ |
+ #' split_rows_by(+ |
+
| 72 | ++ |
+ #' var = "SEX",+ |
+
| 73 | ++ |
+ #' label_pos = "topleft",+ |
+
| 74 | ++ |
+ #' child_labels = "hidden",+ |
+
| 75 | ++ |
+ #' split_fun = drop_split_levels+ |
+
| 76 | ++ |
+ #' ) %>%+ |
+
| 77 | ++ |
+ #' analyze_vars_in_cols(+ |
+
| 78 | ++ |
+ #' vars = "AGE",+ |
+
| 79 | ++ |
+ #' .stats = c("n", "cv", "geom_mean"),
+ |
+
| 80 | ++ |
+ #' .labels = c(+ |
+
| 81 | ++ |
+ #' n = "aN",+ |
+
| 82 | ++ |
+ #' cv = "aCV",+ |
+
| 83 | ++ |
+ #' geom_mean = "aGeomMean"+ |
+
| 84 | ++ |
+ #' )+ |
+
| 85 | ++ |
+ #' )+ |
+
| 86 | ++ |
+ #' result <- build_table(lyt = lyt, df = adpp)+ |
+
| 87 | ++ |
+ #' result+ |
+
| 88 | ++ |
+ #'+ |
+
| 89 | ++ |
+ #' # Changing row labels+ |
+
| 90 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 91 | ++ |
+ #' analyze_vars_in_cols(+ |
+
| 92 | ++ |
+ #' vars = "AGE",+ |
+
| 93 | ++ |
+ #' row_labels = "some custom label"+ |
+
| 94 | ++ |
+ #' )+ |
+
| 95 | ++ |
+ #' result <- build_table(lyt, df = adpp)+ |
+
| 96 | ++ |
+ #' result+ |
+
| 97 | ++ |
+ #'+ |
+
| 98 | ++ |
+ #' # Pharmacokinetic parameters+ |
+
| 99 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 100 | ++ |
+ #' split_rows_by(+ |
+
| 101 | ++ |
+ #' var = "TLG_DISPLAY",+ |
+
| 102 | ++ |
+ #' split_label = "PK Parameter",+ |
+
| 103 | ++ |
+ #' label_pos = "topleft",+ |
+
| 104 | ++ |
+ #' child_label = "hidden"+ |
+
| 105 | ++ |
+ #' ) %>%+ |
+
| 106 | ++ |
+ #' analyze_vars_in_cols(+ |
+
| 107 | ++ |
+ #' vars = "AVAL"+ |
+
| 108 | ++ |
+ #' )+ |
+
| 109 | ++ |
+ #' result <- build_table(lyt, df = adpp)+ |
+
| 110 | ++ |
+ #' result+ |
+
| 111 | ++ |
+ #'+ |
+
| 112 | ++ |
+ #' # Multiple calls (summarize label and analyze underneath)+ |
+
| 113 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 114 | ++ |
+ #' split_rows_by(+ |
+
| 115 | ++ |
+ #' var = "TLG_DISPLAY",+ |
+
| 116 | ++ |
+ #' split_label = "PK Parameter",+ |
+
| 117 | ++ |
+ #' label_pos = "topleft"+ |
+
| 118 | ++ |
+ #' ) %>%+ |
+
| 119 | ++ |
+ #' analyze_vars_in_cols(+ |
+
| 120 | ++ |
+ #' vars = "AVAL",+ |
+
| 121 | ++ |
+ #' do_summarize_row_groups = TRUE # does a summarize level+ |
+
| 122 | ++ |
+ #' ) %>%+ |
+
| 123 | ++ |
+ #' split_rows_by("SEX",
+ |
+
| 124 | ++ |
+ #' child_label = "hidden",+ |
+
| 125 | ++ |
+ #' label_pos = "topleft"+ |
+
| 126 | ++ |
+ #' ) %>%+ |
+
| 127 | ++ |
+ #' analyze_vars_in_cols(+ |
+
| 128 | ++ |
+ #' vars = "AVAL",+ |
+
| 129 | ++ |
+ #' split_col_vars = FALSE # avoids re-splitting the columns+ |
+
| 130 | ++ |
+ #' )+ |
+
| 131 | ++ |
+ #' result <- build_table(lyt, df = adpp)+ |
+
| 132 | ++ |
+ #' result+ |
+
| 133 | ++ |
+ #'+ |
+
| 134 | ++ |
+ #' @export+ |
+
| 135 | ++ |
+ analyze_vars_in_cols <- function(lyt,+ |
+
| 136 | ++ |
+ vars,+ |
+
| 137 | ++ |
+ ...,+ |
+
| 138 | ++ |
+ .stats = c(+ |
+
| 139 | ++ |
+ "n",+ |
+
| 140 | ++ |
+ "mean",+ |
+
| 141 | ++ |
+ "sd",+ |
+
| 142 | ++ |
+ "se",+ |
+
| 143 | ++ |
+ "cv",+ |
+
| 144 | ++ |
+ "geom_cv"+ |
+
| 145 | ++ |
+ ),+ |
+
| 146 | ++ |
+ .labels = c(+ |
+
| 147 | ++ |
+ n = "n",+ |
+
| 148 | ++ |
+ mean = "Mean",+ |
+
| 149 | ++ |
+ sd = "SD",+ |
+
| 150 | ++ |
+ se = "SE",+ |
+
| 151 | ++ |
+ cv = "CV (%)",+ |
+
| 152 | ++ |
+ geom_cv = "CV % Geometric Mean"+ |
+
| 153 | ++ |
+ ),+ |
+
| 154 | ++ |
+ row_labels = NULL,+ |
+
| 155 | ++ |
+ do_summarize_row_groups = FALSE,+ |
+
| 156 | ++ |
+ split_col_vars = TRUE,+ |
+
| 157 | ++ |
+ imp_rule = NULL,+ |
+
| 158 | ++ |
+ avalcat_var = "AVALCAT1",+ |
+
| 159 | ++ |
+ cache = FALSE,+ |
+
| 160 | ++ |
+ .indent_mods = NULL,+ |
+
| 161 | ++ |
+ na_level = lifecycle::deprecated(),+ |
+
| 162 | ++ |
+ na_str = NA_character_,+ |
+
| 163 | ++ |
+ nested = TRUE,+ |
+
| 164 | ++ |
+ .formats = NULL,+ |
+
| 165 | ++ |
+ .aligns = NULL) {
+ |
+
| 166 | +10x | +
+ if (lifecycle::is_present(na_level)) {
+ |
+
| 167 | +! | +
+ lifecycle::deprecate_warn("0.9.1", "analyze_vars_in_cols(na_level)", "analyze_vars_in_cols(na_str)")
+ |
+
| 168 | +! | +
+ na_str <- na_level+ |
+
| 169 | ++ |
+ }+ |
+
| 170 | ++ | + + | +
| 171 | +10x | +
+ checkmate::assert_string(na_str, na.ok = TRUE, null.ok = TRUE)+ |
+
| 172 | +10x | +
+ checkmate::assert_character(row_labels, null.ok = TRUE)+ |
+
| 173 | +10x | +
+ checkmate::assert_int(.indent_mods, null.ok = TRUE)+ |
+
| 174 | +10x | +
+ checkmate::assert_flag(nested)+ |
+
| 175 | +10x | +
+ checkmate::assert_flag(split_col_vars)+ |
+
| 176 | +10x | +
+ checkmate::assert_flag(do_summarize_row_groups)+ |
+
| 177 | ++ | + + | +
| 178 | ++ |
+ # Filtering+ |
+
| 179 | +10x | +
+ met_grps <- paste0("analyze_vars", c("_numeric", "_counts"))
+ |
+
| 180 | +10x | +
+ .stats <- get_stats(met_grps, stats_in = .stats)+ |
+
| 181 | +10x | +
+ formats_v <- get_formats_from_stats(stats = .stats, formats_in = .formats)+ |
+
| 182 | +10x | +
+ labels_v <- get_labels_from_stats(stats = .stats, labels_in = .labels)+ |
+
| 183 | ++ | + + | +
| 184 | ++ |
+ # Check for vars in the case that one or more are used+ |
+
| 185 | +10x | +
+ if (length(vars) == 1) {
+ |
+
| 186 | +7x | +
+ vars <- rep(vars, length(.stats))+ |
+
| 187 | +3x | +
+ } else if (length(vars) != length(.stats)) {
+ |
+
| 188 | +1x | +
+ stop(+ |
+
| 189 | +1x | +
+ "Analyzed variables (vars) does not have the same ",+ |
+
| 190 | +1x | +
+ "number of elements of specified statistics (.stats)."+ |
+
| 191 | ++ |
+ )+ |
+
| 192 | ++ |
+ }+ |
+
| 193 | ++ | + + | +
| 194 | +9x | +
+ if (split_col_vars) {
+ |
+
| 195 | ++ |
+ # Checking there is not a previous identical column split+ |
+
| 196 | +8x | +
+ clyt <- tail(clayout(lyt), 1)[[1]]+ |
+
| 197 | ++ | + + | +
| 198 | +8x | +
+ dummy_lyt <- split_cols_by_multivar(+ |
+
| 199 | +8x | +
+ lyt = basic_table(),+ |
+
| 200 | +8x | +
+ vars = vars,+ |
+
| 201 | +8x | +
+ varlabels = labels_v+ |
+
| 202 | ++ |
+ )+ |
+
| 203 | ++ | + + | +
| 204 | +8x | +
+ if (any(sapply(clyt, identical, y = get_last_col_split(dummy_lyt)))) {
+ |
+
| 205 | +! | +
+ stop(+ |
+
| 206 | +! | +
+ "Column split called again with the same values. ",+ |
+
| 207 | +! | +
+ "This can create many unwanted columns. Please consider adding ",+ |
+
| 208 | +! | +
+ "split_col_vars = FALSE to the last call of ",+ |
+
| 209 | +! | +
+ deparse(sys.calls()[[sys.nframe() - 1]]), "."+ |
+
| 210 | ++ |
+ )+ |
+
| 211 | ++ |
+ }+ |
+
| 212 | ++ | + + | +
| 213 | ++ |
+ # Main col split+ |
+
| 214 | +8x | +
+ lyt <- split_cols_by_multivar(+ |
+
| 215 | +8x | +
+ lyt = lyt,+ |
+
| 216 | +8x | +
+ vars = vars,+ |
+
| 217 | +8x | +
+ varlabels = labels_v+ |
+
| 218 | ++ |
+ )+ |
+
| 219 | ++ |
+ }+ |
+
| 220 | ++ | + + | +
| 221 | +9x | +
+ env <- new.env() # create caching environment+ |
+
| 222 | ++ | + + | +
| 223 | +9x | +
+ if (do_summarize_row_groups) {
+ |
+
| 224 | +2x | +
+ if (length(unique(vars)) > 1) {
+ |
+
| 225 | +! | +
+ stop("When using do_summarize_row_groups only one label level var should be inserted.")
+ |
+
| 226 | ++ |
+ }+ |
+
| 227 | ++ | + + | +
| 228 | ++ |
+ # Function list for do_summarize_row_groups. Slightly different handling of labels+ |
+
| 229 | +2x | +
+ cfun_list <- Map(+ |
+
| 230 | +2x | +
+ function(stat, use_cache, cache_env) {
+ |
+
| 231 | +12x | +
+ function(u, .spl_context, labelstr, .df_row, ...) {
+ |
+
| 232 | ++ |
+ # Statistic+ |
+
| 233 | +24x | +
+ var_row_val <- paste(+ |
+
| 234 | +24x | +
+ gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
+ |
+
| 235 | +24x | +
+ paste(.spl_context$value, collapse = "_"),+ |
+
| 236 | +24x | +
+ sep = "_"+ |
+
| 237 | ++ |
+ )+ |
+
| 238 | +24x | +
+ if (use_cache) {
+ |
+
| 239 | +! | +
+ if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...)+ |
+
| 240 | +! | +
+ x_stats <- cache_env[[var_row_val]]+ |
+
| 241 | ++ |
+ } else {
+ |
+
| 242 | +24x | +
+ x_stats <- s_summary(u, ...)+ |
+
| 243 | ++ |
+ }+ |
+
| 244 | ++ | + + | +
| 245 | +24x | +
+ if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
+ |
+
| 246 | +24x | +
+ res <- x_stats[[stat]]+ |
+
| 247 | ++ |
+ } else {
+ |
+
| 248 | +! | +
+ timept <- as.numeric(gsub(".*?([0-9\\.]+).*", "\\1", tail(.spl_context$value, 1)))
+ |
+
| 249 | +! | +
+ res_imp <- imputation_rule(+ |
+
| 250 | +! | +
+ .df_row, x_stats, stat,+ |
+
| 251 | +! | +
+ imp_rule = imp_rule,+ |
+
| 252 | +! | +
+ post = grepl("Predose", tail(.spl_context$value, 1)) || timept > 0,
+ |
+
| 253 | +! | +
+ avalcat_var = avalcat_var+ |
+
| 254 | ++ |
+ )+ |
+
| 255 | +! | +
+ res <- res_imp[["val"]]+ |
+
| 256 | +! | +
+ na_str <- res_imp[["na_str"]]+ |
+
| 257 | ++ |
+ }+ |
+
| 258 | ++ | + + | +
| 259 | ++ |
+ # Label check and replacement+ |
+
| 260 | +24x | +
+ if (length(row_labels) > 1) {
+ |
+
| 261 | +12x | +
+ if (!(labelstr %in% names(row_labels))) {
+ |
+
| 262 | +! | +
+ stop(+ |
+
| 263 | +! | +
+ "Replacing the labels in do_summarize_row_groups needs a named vector",+ |
+
| 264 | +! | +
+ "that contains the split values. In the current split variable ",+ |
+
| 265 | +! | +
+ .spl_context$split[nrow(.spl_context)],+ |
+
| 266 | +! | +
+ " the labelstr value (split value by default) ", labelstr, " is not in",+ |
+
| 267 | +! | +
+ " row_labels names: ", names(row_labels)+ |
+
| 268 | ++ |
+ )+ |
+
| 269 | ++ |
+ }+ |
+
| 270 | +12x | +
+ lbl <- unlist(row_labels[labelstr])+ |
+
| 271 | ++ |
+ } else {
+ |
+
| 272 | +12x | +
+ lbl <- labelstr+ |
+
| 273 | ++ |
+ }+ |
+
| 274 | ++ | + + | +
| 275 | ++ |
+ # Cell creation+ |
+
| 276 | +24x | +
+ rcell(res,+ |
+
| 277 | +24x | +
+ label = lbl,+ |
+
| 278 | +24x | +
+ format = formats_v[names(formats_v) == stat][[1]],+ |
+
| 279 | +24x | +
+ format_na_str = na_str,+ |
+
| 280 | +24x | +
+ indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods),+ |
+
| 281 | +24x | +
+ align = .aligns+ |
+
| 282 | ++ |
+ )+ |
+
| 283 | ++ |
+ }+ |
+
| 284 | ++ |
+ },+ |
+
| 285 | +2x | +
+ stat = .stats,+ |
+
| 286 | +2x | +
+ use_cache = cache,+ |
+
| 287 | +2x | +
+ cache_env = replicate(length(.stats), env)+ |
+
| 288 | ++ |
+ )+ |
+
| 289 | ++ | + + | +
| 290 | ++ |
+ # Main call to rtables+ |
+
| 291 | +2x | +
+ summarize_row_groups(+ |
+
| 292 | +2x | +
+ lyt = lyt,+ |
+
| 293 | +2x | +
+ var = unique(vars),+ |
+
| 294 | +2x | +
+ cfun = cfun_list,+ |
+
| 295 | +2x | +
+ na_str = na_str,+ |
+
| 296 | +2x | +
+ extra_args = list(...)+ |
+
| 297 | ++ |
+ )+ |
+
| 298 | ++ |
+ } else {
+ |
+
| 299 | ++ |
+ # Function list for analyze_colvars+ |
+
| 300 | +7x | +
+ afun_list <- Map(+ |
+
| 301 | +7x | +
+ function(stat, use_cache, cache_env) {
+ |
+
| 302 | +32x | +
+ function(u, .spl_context, .df_row, ...) {
+ |
+
| 303 | ++ |
+ # Main statistics+ |
+
| 304 | +210x | +
+ var_row_val <- paste(+ |
+
| 305 | +210x | +
+ gsub("\\._\\[\\[[0-9]+\\]\\]_\\.", "", paste(tail(.spl_context$cur_col_split_val, 1)[[1]], collapse = "_")),
+ |
+
| 306 | +210x | +
+ paste(.spl_context$value, collapse = "_"),+ |
+
| 307 | +210x | +
+ sep = "_"+ |
+
| 308 | ++ |
+ )+ |
+
| 309 | +210x | +
+ if (use_cache) {
+ |
+
| 310 | +16x | +
+ if (is.null(cache_env[[var_row_val]])) cache_env[[var_row_val]] <- s_summary(u, ...)+ |
+
| 311 | +56x | +
+ x_stats <- cache_env[[var_row_val]]+ |
+
| 312 | ++ |
+ } else {
+ |
+
| 313 | +154x | +
+ x_stats <- s_summary(u, ...)+ |
+
| 314 | ++ |
+ }+ |
+
| 315 | ++ | + + | +
| 316 | +210x | +
+ if (is.null(imp_rule) || !stat %in% c("mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max")) {
+ |
+
| 317 | +170x | +
+ res <- x_stats[[stat]]+ |
+
| 318 | ++ |
+ } else {
+ |
+
| 319 | +40x | +
+ timept <- as.numeric(gsub(".*?([0-9\\.]+).*", "\\1", tail(.spl_context$value, 1)))
+ |
+
| 320 | +40x | +
+ res_imp <- imputation_rule(+ |
+
| 321 | +40x | +
+ .df_row, x_stats, stat,+ |
+
| 322 | +40x | +
+ imp_rule = imp_rule,+ |
+
| 323 | +40x | +
+ post = grepl("Predose", tail(.spl_context$value, 1)) || timept > 0,
+ |
+
| 324 | +40x | +
+ avalcat_var = avalcat_var+ |
+
| 325 | ++ |
+ )+ |
+
| 326 | +40x | +
+ res <- res_imp[["val"]]+ |
+
| 327 | +40x | +
+ na_str <- res_imp[["na_str"]]+ |
+
| 328 | ++ |
+ }+ |
+
| 329 | ++ | + + | +
| 330 | +210x | +
+ if (is.list(res)) {
+ |
+
| 331 | +19x | +
+ if (length(res) > 1) {
+ |
+
| 332 | +1x | +
+ stop("The analyzed column produced more than one category of results.")
+ |
+
| 333 | ++ |
+ } else {
+ |
+
| 334 | +18x | +
+ res <- unlist(res)+ |
+
| 335 | ++ |
+ }+ |
+
| 336 | ++ |
+ }+ |
+
| 337 | ++ | + + | +
| 338 | ++ |
+ # Label from context+ |
+
| 339 | +209x | +
+ label_from_context <- .spl_context$value[nrow(.spl_context)]+ |
+
| 340 | ++ | + + | +
| 341 | ++ |
+ # Label switcher+ |
+
| 342 | +209x | +
+ if (is.null(row_labels)) {
+ |
+
| 343 | +149x | +
+ lbl <- label_from_context+ |
+
| 344 | ++ |
+ } else {
+ |
+
| 345 | +60x | +
+ if (length(row_labels) > 1) {
+ |
+
| 346 | +48x | +
+ if (!(label_from_context %in% names(row_labels))) {
+ |
+
| 347 | +! | +
+ stop(+ |
+
| 348 | +! | +
+ "Replacing the labels in do_summarize_row_groups needs a named vector",+ |
+
| 349 | +! | +
+ "that contains the split values. In the current split variable ",+ |
+
| 350 | +! | +
+ .spl_context$split[nrow(.spl_context)],+ |
+
| 351 | +! | +
+ " the split value ", label_from_context, " is not in",+ |
+
| 352 | +! | +
+ " row_labels names: ", names(row_labels)+ |
+
| 353 | ++ |
+ )+ |
+
| 354 | ++ |
+ }+ |
+
| 355 | +48x | +
+ lbl <- unlist(row_labels[label_from_context])+ |
+
| 356 | ++ |
+ } else {
+ |
+
| 357 | +12x | +
+ lbl <- row_labels+ |
+
| 358 | ++ |
+ }+ |
+
| 359 | ++ |
+ }+ |
+
| 360 | ++ | + + | +
| 361 | ++ |
+ # Cell creation+ |
+
| 362 | +209x | +
+ rcell(res,+ |
+
| 363 | +209x | +
+ label = lbl,+ |
+
| 364 | +209x | +
+ format = formats_v[names(formats_v) == stat][[1]],+ |
+
| 365 | +209x | +
+ format_na_str = na_str,+ |
+
| 366 | +209x | +
+ indent_mod = ifelse(is.null(.indent_mods), 0L, .indent_mods),+ |
+
| 367 | +209x | +
+ align = .aligns+ |
+
| 368 | ++ |
+ )+ |
+
| 369 | ++ |
+ }+ |
+
| 370 | ++ |
+ },+ |
+
| 371 | +7x | +
+ stat = .stats,+ |
+
| 372 | +7x | +
+ use_cache = cache,+ |
+
| 373 | +7x | +
+ cache_env = replicate(length(.stats), env)+ |
+
| 374 | ++ |
+ )+ |
+
| 375 | ++ | + + | +
| 376 | ++ |
+ # Main call to rtables+ |
+
| 377 | +7x | +
+ analyze_colvars(lyt,+ |
+
| 378 | +7x | +
+ afun = afun_list,+ |
+
| 379 | +7x | +
+ nested = nested,+ |
+
| 380 | +7x | +
+ extra_args = list(...)+ |
+
| 381 | ++ |
+ )+ |
+
| 382 | ++ |
+ }+ |
+
| 383 | ++ |
+ }+ |
+
| 384 | ++ | + + | +
| 385 | ++ |
+ # Help function+ |
+
| 386 | ++ |
+ get_last_col_split <- function(lyt) {
+ |
+
| 387 | +1x | +
+ tail(tail(clayout(lyt), 1)[[1]], 1)[[1]]+ |
+
| 388 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Controls for Cox Regression+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Sets a list of parameters for Cox regression fit. Used internally.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 8 | ++ |
+ #' @param pval_method (`string`)\cr the method used for estimation of p.values; `wald` (default) or `likelihood`.+ |
+
| 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+ |
+
| 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`,+ |
+
| 13 | ++ |
+ #' see [survival::coxph()]. Note: there is no equivalent of SAS `EXACT` method in R.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @return A `list` of items with names corresponding to the arguments.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @seealso [fit_coxreg_univar()] and [fit_coxreg_multivar()].+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @examples+ |
+
| 20 | ++ |
+ #' control_coxreg()+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @export+ |
+
| 23 | ++ |
+ control_coxreg <- function(pval_method = c("wald", "likelihood"),
+ |
+
| 24 | ++ |
+ ties = c("exact", "efron", "breslow"),
+ |
+
| 25 | ++ |
+ conf_level = 0.95,+ |
+
| 26 | ++ |
+ interaction = FALSE) {
+ |
+
| 27 | +43x | +
+ pval_method <- match.arg(pval_method)+ |
+
| 28 | +43x | +
+ ties <- match.arg(ties)+ |
+
| 29 | +43x | +
+ checkmate::assert_flag(interaction)+ |
+
| 30 | +43x | +
+ assert_proportion_value(conf_level)+ |
+
| 31 | +43x | +
+ list(+ |
+
| 32 | +43x | +
+ pval_method = pval_method,+ |
+
| 33 | +43x | +
+ ties = ties,+ |
+
| 34 | +43x | +
+ conf_level = conf_level,+ |
+
| 35 | +43x | +
+ interaction = interaction+ |
+
| 36 | ++ |
+ )+ |
+
| 37 | ++ |
+ }+ |
+
| 38 | ++ | + + | +
| 39 | ++ |
+ #' Custom Tidy Methods for Cox Regression+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 44 | ++ |
+ #' @param x (`list`)\cr Result of the Cox regression model fitted by [fit_coxreg_univar()] (for univariate models)+ |
+
| 45 | ++ |
+ #' or [fit_coxreg_multivar()] (for multivariate models).+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ #' @return [tidy()] returns:+ |
+
| 48 | ++ |
+ #' * For `summary.coxph` objects, a `data.frame` with columns: `Pr(>|z|)`, `exp(coef)`, `exp(-coef)`, `lower .95`,+ |
+
| 49 | ++ |
+ #' `upper .95`, `level`, and `n`.+ |
+
| 50 | ++ |
+ #' * For `coxreg.univar` objects, a `data.frame` with columns: `effect`, `term`, `term_label`, `level`, `n`, `hr`,+ |
+
| 51 | ++ |
+ #' `lcl`, `ucl`, `pval`, and `ci`.+ |
+
| 52 | ++ |
+ #' * For `coxreg.multivar` objects, a `data.frame` with columns: `term`, `pval`, `term_label`, `hr`, `lcl`, `ucl`,+ |
+
| 53 | ++ |
+ #' `level`, and `ci`.+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' @seealso [cox_regression]+ |
+
| 56 | ++ |
+ #'+ |
+
| 57 | ++ |
+ #' @name tidy_coxreg+ |
+
| 58 | ++ |
+ NULL+ |
+
| 59 | ++ | + + | +
| 60 | ++ |
+ #' @describeIn tidy_coxreg Custom tidy method for [survival::coxph()] summary results.+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' Tidy the [survival::coxph()] results into a `data.frame` to extract model results.+ |
+
| 63 | ++ |
+ #'+ |
+
| 64 | ++ |
+ #' @method tidy summary.coxph+ |
+
| 65 | ++ |
+ #'+ |
+
| 66 | ++ |
+ #' @examples+ |
+
| 67 | ++ |
+ #' library(survival)+ |
+
| 68 | ++ |
+ #' library(broom)+ |
+
| 69 | ++ |
+ #'+ |
+
| 70 | ++ |
+ #' set.seed(1, kind = "Mersenne-Twister")+ |
+
| 71 | ++ |
+ #'+ |
+
| 72 | ++ |
+ #' dta_bladder <- with(+ |
+
| 73 | ++ |
+ #' data = bladder[bladder$enum < 5, ],+ |
+
| 74 | ++ |
+ #' data.frame(+ |
+
| 75 | ++ |
+ #' time = stop,+ |
+
| 76 | ++ |
+ #' status = event,+ |
+
| 77 | ++ |
+ #' armcd = as.factor(rx),+ |
+
| 78 | ++ |
+ #' covar1 = as.factor(enum),+ |
+
| 79 | ++ |
+ #' covar2 = factor(+ |
+
| 80 | ++ |
+ #' sample(as.factor(enum)),+ |
+
| 81 | ++ |
+ #' levels = 1:4, labels = c("F", "F", "M", "M")
+ |
+
| 82 | ++ |
+ #' )+ |
+
| 83 | ++ |
+ #' )+ |
+
| 84 | ++ |
+ #' )+ |
+
| 85 | ++ |
+ #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
+ |
+
| 86 | ++ |
+ #' formatters::var_labels(dta_bladder)[names(labels)] <- labels+ |
+
| 87 | ++ |
+ #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ |
+
| 88 | ++ |
+ #'+ |
+
| 89 | ++ |
+ #' formula <- "survival::Surv(time, status) ~ armcd + covar1"+ |
+
| 90 | ++ |
+ #' msum <- summary(coxph(stats::as.formula(formula), data = dta_bladder))+ |
+
| 91 | ++ |
+ #' tidy(msum)+ |
+
| 92 | ++ |
+ #'+ |
+
| 93 | ++ |
+ #' @export+ |
+
| 94 | ++ |
+ tidy.summary.coxph <- function(x, # nolint+ |
+
| 95 | ++ |
+ ...) {
+ |
+
| 96 | +124x | +
+ checkmate::assert_class(x, "summary.coxph")+ |
+
| 97 | +124x | +
+ pval <- x$coefficients+ |
+
| 98 | +124x | +
+ confint <- x$conf.int+ |
+
| 99 | +124x | +
+ levels <- rownames(pval)+ |
+
| 100 | ++ | + + | +
| 101 | +124x | +
+ pval <- tibble::as_tibble(pval)+ |
+
| 102 | +124x | +
+ confint <- tibble::as_tibble(confint)+ |
+
| 103 | ++ | + + | +
| 104 | +124x | +
+ ret <- cbind(pval[, grepl("Pr", names(pval))], confint)
+ |
+
| 105 | +124x | +
+ ret$level <- levels+ |
+
| 106 | +124x | +
+ ret$n <- x[["n"]]+ |
+
| 107 | +124x | +
+ ret+ |
+
| 108 | ++ |
+ }+ |
+
| 109 | ++ | + + | +
| 110 | ++ |
+ #' @describeIn tidy_coxreg Custom tidy method for a univariate Cox regression.+ |
+
| 111 | ++ |
+ #'+ |
+
| 112 | ++ |
+ #' Tidy up the result of a Cox regression model fitted by [fit_coxreg_univar()].+ |
+
| 113 | ++ |
+ #'+ |
+
| 114 | ++ |
+ #' @method tidy coxreg.univar+ |
+
| 115 | ++ |
+ #'+ |
+
| 116 | ++ |
+ #' @examples+ |
+
| 117 | ++ |
+ #' ## Cox regression: arm + 1 covariate.+ |
+
| 118 | ++ |
+ #' mod1 <- fit_coxreg_univar(+ |
+
| 119 | ++ |
+ #' variables = list(+ |
+
| 120 | ++ |
+ #' time = "time", event = "status", arm = "armcd",+ |
+
| 121 | ++ |
+ #' covariates = "covar1"+ |
+
| 122 | ++ |
+ #' ),+ |
+
| 123 | ++ |
+ #' data = dta_bladder,+ |
+
| 124 | ++ |
+ #' control = control_coxreg(conf_level = 0.91)+ |
+
| 125 | ++ |
+ #' )+ |
+
| 126 | ++ |
+ #'+ |
+
| 127 | ++ |
+ #' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates.+ |
+
| 128 | ++ |
+ #' mod2 <- fit_coxreg_univar(+ |
+
| 129 | ++ |
+ #' variables = list(+ |
+
| 130 | ++ |
+ #' time = "time", event = "status", arm = "armcd",+ |
+
| 131 | ++ |
+ #' covariates = c("covar1", "covar2")
+ |
+
| 132 | ++ |
+ #' ),+ |
+
| 133 | ++ |
+ #' data = dta_bladder,+ |
+
| 134 | ++ |
+ #' control = control_coxreg(conf_level = 0.91, interaction = TRUE)+ |
+
| 135 | ++ |
+ #' )+ |
+
| 136 | ++ |
+ #'+ |
+
| 137 | ++ |
+ #' tidy(mod1)+ |
+
| 138 | ++ |
+ #' tidy(mod2)+ |
+
| 139 | ++ |
+ #'+ |
+
| 140 | ++ |
+ #' @export+ |
+
| 141 | ++ |
+ tidy.coxreg.univar <- function(x, # nolint+ |
+
| 142 | ++ |
+ ...) {
+ |
+
| 143 | +29x | +
+ checkmate::assert_class(x, "coxreg.univar")+ |
+
| 144 | +29x | +
+ mod <- x$mod+ |
+
| 145 | +29x | +
+ vars <- c(x$vars$arm, x$vars$covariates)+ |
+
| 146 | +29x | +
+ has_arm <- "arm" %in% names(x$vars)+ |
+
| 147 | ++ | + + | +
| 148 | +29x | +
+ result <- if (!has_arm) {
+ |
+
| 149 | +5x | +
+ Map(+ |
+
| 150 | +5x | +
+ mod = mod, vars = vars,+ |
+
| 151 | +5x | +
+ f = function(mod, vars) {
+ |
+
| 152 | +6x | +
+ h_coxreg_multivar_extract(+ |
+
| 153 | +6x | +
+ var = vars,+ |
+
| 154 | +6x | +
+ data = x$data,+ |
+
| 155 | +6x | +
+ mod = mod,+ |
+
| 156 | +6x | +
+ control = x$control+ |
+
| 157 | ++ |
+ )+ |
+
| 158 | ++ |
+ }+ |
+
| 159 | ++ |
+ )+ |
+
| 160 | +29x | +
+ } else if (x$control$interaction) {
+ |
+
| 161 | +10x | +
+ Map(+ |
+
| 162 | +10x | +
+ mod = mod, covar = vars,+ |
+
| 163 | +10x | +
+ f = function(mod, covar) {
+ |
+
| 164 | +22x | +
+ h_coxreg_extract_interaction(+ |
+
| 165 | +22x | +
+ effect = x$vars$arm, covar = covar, mod = mod, data = x$data,+ |
+
| 166 | +22x | +
+ at = x$at, control = x$control+ |
+
| 167 | ++ |
+ )+ |
+
| 168 | ++ |
+ }+ |
+
| 169 | ++ |
+ )+ |
+
| 170 | ++ |
+ } else {
+ |
+
| 171 | +14x | +
+ Map(+ |
+
| 172 | +14x | +
+ mod = mod, vars = vars,+ |
+
| 173 | +14x | +
+ f = function(mod, vars) {
+ |
+
| 174 | +36x | +
+ h_coxreg_univar_extract(+ |
+
| 175 | +36x | +
+ effect = x$vars$arm, covar = vars, data = x$data, mod = mod,+ |
+
| 176 | +36x | +
+ control = x$control+ |
+
| 177 | ++ |
+ )+ |
+
| 178 | ++ |
+ }+ |
+
| 179 | ++ |
+ )+ |
+
| 180 | ++ |
+ }+ |
+
| 181 | +29x | +
+ result <- do.call(rbind, result)+ |
+
| 182 | ++ | + + | +
| 183 | +29x | +
+ result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl))+ |
+
| 184 | +29x | +
+ result$n <- lapply(result$n, empty_vector_if_na)+ |
+
| 185 | +29x | +
+ result$ci <- lapply(result$ci, empty_vector_if_na)+ |
+
| 186 | +29x | +
+ result$hr <- lapply(result$hr, empty_vector_if_na)+ |
+
| 187 | +29x | +
+ if (x$control$interaction) {
+ |
+
| 188 | +10x | +
+ result$pval_inter <- lapply(result$pval_inter, empty_vector_if_na)+ |
+
| 189 | ++ |
+ # Remove interaction p-values due to change in specifications.+ |
+
| 190 | +10x | +
+ result$pval[result$effect != "Treatment:"] <- NA+ |
+
| 191 | ++ |
+ }+ |
+
| 192 | +29x | +
+ result$pval <- lapply(result$pval, empty_vector_if_na)+ |
+
| 193 | +29x | +
+ attr(result, "conf_level") <- x$control$conf_level+ |
+
| 194 | +29x | +
+ result+ |
+
| 195 | ++ |
+ }+ |
+
| 196 | ++ | + + | +
| 197 | ++ |
+ #' @describeIn tidy_coxreg Custom tidy method for a multivariate Cox regression.+ |
+
| 198 | ++ |
+ #'+ |
+
| 199 | ++ |
+ #' Tidy up the result of a Cox regression model fitted by [fit_coxreg_multivar()].+ |
+
| 200 | ++ |
+ #'+ |
+
| 201 | ++ |
+ #' @method tidy coxreg.multivar+ |
+
| 202 | ++ |
+ #'+ |
+
| 203 | ++ |
+ #' @examples+ |
+
| 204 | ++ |
+ #' multivar_model <- fit_coxreg_multivar(+ |
+
| 205 | ++ |
+ #' variables = list(+ |
+
| 206 | ++ |
+ #' time = "time", event = "status", arm = "armcd",+ |
+
| 207 | ++ |
+ #' covariates = c("covar1", "covar2")
+ |
+
| 208 | ++ |
+ #' ),+ |
+
| 209 | ++ |
+ #' data = dta_bladder+ |
+
| 210 | ++ |
+ #' )+ |
+
| 211 | ++ |
+ #' broom::tidy(multivar_model)+ |
+
| 212 | ++ |
+ #'+ |
+
| 213 | ++ |
+ #' @export+ |
+
| 214 | ++ |
+ tidy.coxreg.multivar <- function(x, # nolint+ |
+
| 215 | ++ |
+ ...) {
+ |
+
| 216 | +8x | +
+ checkmate::assert_class(x, "coxreg.multivar")+ |
+
| 217 | +8x | +
+ vars <- c(x$vars$arm, x$vars$covariates)+ |
+
| 218 | ++ | + + | +
| 219 | ++ |
+ # Convert the model summaries to data.+ |
+
| 220 | +8x | +
+ result <- Map(+ |
+
| 221 | +8x | +
+ vars = vars,+ |
+
| 222 | +8x | +
+ f = function(vars) {
+ |
+
| 223 | +28x | +
+ h_coxreg_multivar_extract(+ |
+
| 224 | +28x | +
+ var = vars, data = x$data,+ |
+
| 225 | +28x | +
+ mod = x$mod, control = x$control+ |
+
| 226 | ++ |
+ )+ |
+
| 227 | ++ |
+ }+ |
+
| 228 | ++ |
+ )+ |
+
| 229 | +8x | +
+ result <- do.call(rbind, result)+ |
+
| 230 | ++ | + + | +
| 231 | +8x | +
+ result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl))+ |
+
| 232 | +8x | +
+ result$ci <- lapply(result$ci, empty_vector_if_na)+ |
+
| 233 | +8x | +
+ result$hr <- lapply(result$hr, empty_vector_if_na)+ |
+
| 234 | +8x | +
+ result$pval <- lapply(result$pval, empty_vector_if_na)+ |
+
| 235 | +8x | +
+ result <- result[, names(result) != "n"]+ |
+
| 236 | +8x | +
+ attr(result, "conf_level") <- x$control$conf_level+ |
+
| 237 | ++ | + + | +
| 238 | +8x | +
+ result+ |
+
| 239 | ++ |
+ }+ |
+
| 240 | ++ | + + | +
| 241 | ++ |
+ #' Fits for Cox Proportional Hazards Regression+ |
+
| 242 | ++ |
+ #'+ |
+
| 243 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 244 | ++ |
+ #'+ |
+
| 245 | ++ |
+ #' Fitting functions for univariate and multivariate Cox regression models.+ |
+
| 246 | ++ |
+ #'+ |
+
| 247 | ++ |
+ #' @param variables (`list`)\cr a named list corresponds to the names of variables found in `data`, passed as a named+ |
+
| 248 | ++ |
+ #' list and corresponding to `time`, `event`, `arm`, `strata`, and `covariates` terms. If `arm` is missing from+ |
+
| 249 | ++ |
+ #' `variables`, then only Cox model(s) including the `covariates` will be fitted and the corresponding effect+ |
+
| 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+ |
+
| 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()].+ |
+
| 255 | ++ |
+ #'+ |
+
| 256 | ++ |
+ #' @seealso [h_cox_regression] for relevant helper functions, [cox_regression].+ |
+
| 257 | ++ |
+ #'+ |
+
| 258 | ++ |
+ #' @examples+ |
+
| 259 | ++ |
+ #' library(survival)+ |
+
| 260 | ++ |
+ #'+ |
+
| 261 | ++ |
+ #' set.seed(1, kind = "Mersenne-Twister")+ |
+
| 262 | ++ |
+ #'+ |
+
| 263 | ++ |
+ #' # Testing dataset [survival::bladder].+ |
+
| 264 | ++ |
+ #' dta_bladder <- with(+ |
+
| 265 | ++ |
+ #' data = bladder[bladder$enum < 5, ],+ |
+
| 266 | ++ |
+ #' data.frame(+ |
+
| 267 | ++ |
+ #' time = stop,+ |
+
| 268 | ++ |
+ #' status = event,+ |
+
| 269 | ++ |
+ #' armcd = as.factor(rx),+ |
+
| 270 | ++ |
+ #' covar1 = as.factor(enum),+ |
+
| 271 | ++ |
+ #' covar2 = factor(+ |
+
| 272 | ++ |
+ #' sample(as.factor(enum)),+ |
+
| 273 | ++ |
+ #' levels = 1:4, labels = c("F", "F", "M", "M")
+ |
+
| 274 | ++ |
+ #' )+ |
+
| 275 | ++ |
+ #' )+ |
+
| 276 | ++ |
+ #' )+ |
+
| 277 | ++ |
+ #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
+ |
+
| 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(+ |
+
| 282 | ++ |
+ #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder),+ |
+
| 283 | ++ |
+ #' lty = 2:4,+ |
+
| 284 | ++ |
+ #' xlab = "Months",+ |
+
| 285 | ++ |
+ #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
+ |
+
| 286 | ++ |
+ #' )+ |
+
| 287 | ++ |
+ #'+ |
+
| 288 | ++ |
+ #' @name fit_coxreg+ |
+
| 289 | ++ |
+ NULL+ |
+
| 290 | ++ | + + | +
| 291 | ++ |
+ #' @describeIn fit_coxreg Fit a series of univariate Cox regression models given the inputs.+ |
+
| 292 | ++ |
+ #'+ |
+
| 293 | ++ |
+ #' @return+ |
+
| 294 | ++ |
+ #' * `fit_coxreg_univar()` returns a `coxreg.univar` class object which is a named `list`+ |
+
| 295 | ++ |
+ #' with 5 elements:+ |
+
| 296 | ++ |
+ #' * `mod`: Cox regression models fitted by [survival::coxph()].+ |
+
| 297 | ++ |
+ #' * `data`: The original data frame input.+ |
+
| 298 | ++ |
+ #' * `control`: The original control input.+ |
+
| 299 | ++ |
+ #' * `vars`: The variables used in the model.+ |
+
| 300 | ++ |
+ #' * `at`: Value of the covariate at which the effect should be estimated.+ |
+
| 301 | ++ |
+ #'+ |
+
| 302 | ++ |
+ #' @note When using `fit_coxreg_univar` there should be two study arms.+ |
+
| 303 | ++ |
+ #'+ |
+
| 304 | ++ |
+ #' @examples+ |
+
| 305 | ++ |
+ #' # fit_coxreg_univar+ |
+
| 306 | ++ |
+ #'+ |
+
| 307 | ++ |
+ #' ## Cox regression: arm + 1 covariate.+ |
+
| 308 | ++ |
+ #' mod1 <- fit_coxreg_univar(+ |
+
| 309 | ++ |
+ #' variables = list(+ |
+
| 310 | ++ |
+ #' time = "time", event = "status", arm = "armcd",+ |
+
| 311 | ++ |
+ #' covariates = "covar1"+ |
+
| 312 | ++ |
+ #' ),+ |
+
| 313 | ++ |
+ #' data = dta_bladder,+ |
+
| 314 | ++ |
+ #' control = control_coxreg(conf_level = 0.91)+ |
+
| 315 | ++ |
+ #' )+ |
+
| 316 | ++ |
+ #'+ |
+
| 317 | ++ |
+ #' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates.+ |
+
| 318 | ++ |
+ #' mod2 <- fit_coxreg_univar(+ |
+
| 319 | ++ |
+ #' variables = list(+ |
+
| 320 | ++ |
+ #' time = "time", event = "status", arm = "armcd",+ |
+
| 321 | ++ |
+ #' covariates = c("covar1", "covar2")
+ |
+
| 322 | ++ |
+ #' ),+ |
+
| 323 | ++ |
+ #' data = dta_bladder,+ |
+
| 324 | ++ |
+ #' control = control_coxreg(conf_level = 0.91, interaction = TRUE)+ |
+
| 325 | ++ |
+ #' )+ |
+
| 326 | ++ |
+ #'+ |
+
| 327 | ++ |
+ #' ## Cox regression: arm + 1 covariate, stratified analysis.+ |
+
| 328 | ++ |
+ #' mod3 <- fit_coxreg_univar(+ |
+
| 329 | ++ |
+ #' variables = list(+ |
+
| 330 | ++ |
+ #' time = "time", event = "status", arm = "armcd", strata = "covar2",+ |
+
| 331 | ++ |
+ #' covariates = c("covar1")
+ |
+
| 332 | ++ |
+ #' ),+ |
+
| 333 | ++ |
+ #' data = dta_bladder,+ |
+
| 334 | ++ |
+ #' control = control_coxreg(conf_level = 0.91)+ |
+
| 335 | ++ |
+ #' )+ |
+
| 336 | ++ |
+ #'+ |
+
| 337 | ++ |
+ #' ## Cox regression: no arm, only covariates.+ |
+
| 338 | ++ |
+ #' mod4 <- fit_coxreg_univar(+ |
+
| 339 | ++ |
+ #' variables = list(+ |
+
| 340 | ++ |
+ #' time = "time", event = "status",+ |
+
| 341 | ++ |
+ #' covariates = c("covar1", "covar2")
+ |
+
| 342 | ++ |
+ #' ),+ |
+
| 343 | ++ |
+ #' data = dta_bladder+ |
+
| 344 | ++ |
+ #' )+ |
+
| 345 | ++ |
+ #'+ |
+
| 346 | ++ |
+ #' @export+ |
+
| 347 | ++ |
+ fit_coxreg_univar <- function(variables,+ |
+
| 348 | ++ |
+ data,+ |
+
| 349 | ++ |
+ at = list(),+ |
+
| 350 | ++ |
+ control = control_coxreg()) {
+ |
+
| 351 | +34x | +
+ checkmate::assert_list(variables, names = "named")+ |
+
| 352 | +34x | +
+ has_arm <- "arm" %in% names(variables)+ |
+
| 353 | +34x | +
+ arm_name <- if (has_arm) "arm" else NULL+ |
+
| 354 | ++ | + + | +
| 355 | +34x | +
+ checkmate::assert_character(variables$covariates, null.ok = TRUE)+ |
+
| 356 | ++ | + + | +
| 357 | +34x | +
+ assert_df_with_variables(data, variables)+ |
+
| 358 | +34x | +
+ assert_list_of_variables(variables[c(arm_name, "event", "time")])+ |
+
| 359 | ++ | + + | +
| 360 | +34x | +
+ if (!is.null(variables$strata)) {
+ |
+
| 361 | +4x | +
+ checkmate::assert_disjunct(control$pval_method, "likelihood")+ |
+
| 362 | ++ |
+ }+ |
+
| 363 | +33x | +
+ if (has_arm) {
+ |
+
| 364 | +27x | +
+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ |
+
| 365 | ++ |
+ }+ |
+
| 366 | +32x | +
+ vars <- unlist(variables[c(arm_name, "covariates", "strata")], use.names = FALSE)+ |
+
| 367 | +32x | +
+ for (i in vars) {
+ |
+
| 368 | +73x | +
+ if (is.factor(data[[i]])) {
+ |
+
| 369 | +63x | +
+ attr(data[[i]], "levels") <- levels(droplevels(data[[i]]))+ |
+
| 370 | ++ |
+ }+ |
+
| 371 | ++ |
+ }+ |
+
| 372 | +32x | +
+ forms <- h_coxreg_univar_formulas(variables, interaction = control$interaction)+ |
+
| 373 | +32x | +
+ mod <- lapply(+ |
+
| 374 | +32x | +
+ forms, function(x) {
+ |
+
| 375 | +69x | +
+ survival::coxph(formula = stats::as.formula(x), data = data, ties = control$ties)+ |
+
| 376 | ++ |
+ }+ |
+
| 377 | ++ |
+ )+ |
+
| 378 | +32x | +
+ structure(+ |
+
| 379 | +32x | +
+ list(+ |
+
| 380 | +32x | +
+ mod = mod,+ |
+
| 381 | +32x | +
+ data = data,+ |
+
| 382 | +32x | +
+ control = control,+ |
+
| 383 | +32x | +
+ vars = variables,+ |
+
| 384 | +32x | +
+ at = at+ |
+
| 385 | ++ |
+ ),+ |
+
| 386 | +32x | +
+ class = "coxreg.univar"+ |
+
| 387 | ++ |
+ )+ |
+
| 388 | ++ |
+ }+ |
+
| 389 | ++ | + + | +
| 390 | ++ |
+ #' @describeIn fit_coxreg Fit a multivariate Cox regression model.+ |
+
| 391 | ++ |
+ #'+ |
+
| 392 | ++ |
+ #' @return+ |
+
| 393 | ++ |
+ #' * `fit_coxreg_multivar()` returns a `coxreg.multivar` class object which is a named list+ |
+
| 394 | ++ |
+ #' with 4 elements:+ |
+
| 395 | ++ |
+ #' * `mod`: Cox regression model fitted by [survival::coxph()].+ |
+
| 396 | ++ |
+ #' * `data`: The original data frame input.+ |
+
| 397 | ++ |
+ #' * `control`: The original control input.+ |
+
| 398 | ++ |
+ #' * `vars`: The variables used in the model.+ |
+
| 399 | ++ |
+ #'+ |
+
| 400 | ++ |
+ #' @examples+ |
+
| 401 | ++ |
+ #' # fit_coxreg_multivar+ |
+
| 402 | ++ |
+ #'+ |
+
| 403 | ++ |
+ #' ## Cox regression: multivariate Cox regression.+ |
+
| 404 | ++ |
+ #' multivar_model <- fit_coxreg_multivar(+ |
+
| 405 | ++ |
+ #' variables = list(+ |
+
| 406 | ++ |
+ #' time = "time", event = "status", arm = "armcd",+ |
+
| 407 | ++ |
+ #' covariates = c("covar1", "covar2")
+ |
+
| 408 | ++ |
+ #' ),+ |
+
| 409 | ++ |
+ #' data = dta_bladder+ |
+
| 410 | ++ |
+ #' )+ |
+
| 411 | ++ |
+ #'+ |
+
| 412 | ++ |
+ #' # Example without treatment arm.+ |
+
| 413 | ++ |
+ #' multivar_covs_model <- fit_coxreg_multivar(+ |
+
| 414 | ++ |
+ #' variables = list(+ |
+
| 415 | ++ |
+ #' time = "time", event = "status",+ |
+
| 416 | ++ |
+ #' covariates = c("covar1", "covar2")
+ |
+
| 417 | ++ |
+ #' ),+ |
+
| 418 | ++ |
+ #' data = dta_bladder+ |
+
| 419 | ++ |
+ #' )+ |
+
| 420 | ++ |
+ #'+ |
+
| 421 | ++ |
+ #' @export+ |
+
| 422 | ++ |
+ fit_coxreg_multivar <- function(variables,+ |
+
| 423 | ++ |
+ data,+ |
+
| 424 | ++ |
+ control = control_coxreg()) {
+ |
+
| 425 | +51x | +
+ checkmate::assert_list(variables, names = "named")+ |
+
| 426 | +51x | +
+ has_arm <- "arm" %in% names(variables)+ |
+
| 427 | +51x | +
+ arm_name <- if (has_arm) "arm" else NULL+ |
+
| 428 | ++ | + + | +
| 429 | +51x | +
+ if (!is.null(variables$covariates)) {
+ |
+
| 430 | +13x | +
+ checkmate::assert_character(variables$covariates)+ |
+
| 431 | ++ |
+ }+ |
+
| 432 | ++ | + + | +
| 433 | +51x | +
+ checkmate::assert_false(control$interaction)+ |
+
| 434 | +51x | +
+ assert_df_with_variables(data, variables)+ |
+
| 435 | +51x | +
+ assert_list_of_variables(variables[c(arm_name, "event", "time")])+ |
+
| 436 | ++ | + + | +
| 437 | +51x | +
+ if (!is.null(variables$strata)) {
+ |
+
| 438 | +3x | +
+ checkmate::assert_disjunct(control$pval_method, "likelihood")+ |
+
| 439 | ++ |
+ }+ |
+
| 440 | ++ | + + | +
| 441 | +50x | +
+ form <- h_coxreg_multivar_formula(variables)+ |
+
| 442 | +50x | +
+ mod <- survival::coxph(+ |
+
| 443 | +50x | +
+ formula = stats::as.formula(form),+ |
+
| 444 | +50x | +
+ data = data,+ |
+
| 445 | +50x | +
+ ties = control$ties+ |
+
| 446 | ++ |
+ )+ |
+
| 447 | +50x | +
+ structure(+ |
+
| 448 | +50x | +
+ list(+ |
+
| 449 | +50x | +
+ mod = mod,+ |
+
| 450 | +50x | +
+ data = data,+ |
+
| 451 | +50x | +
+ control = control,+ |
+
| 452 | +50x | +
+ vars = variables+ |
+
| 453 | ++ |
+ ),+ |
+
| 454 | +50x | +
+ class = "coxreg.multivar"+ |
+
| 455 | ++ |
+ )+ |
+
| 456 | ++ |
+ }+ |
+
| 457 | ++ | + + | +
| 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 Returns the output of [car::Anova()], with convergence message muffled.+ |
+
| 467 | ++ |
+ #'+ |
+
| 468 | ++ |
+ #' @keywords internal+ |
+
| 469 | ++ |
+ muffled_car_anova <- function(mod, test_statistic) {
+ |
+
| 470 | +142x | +
+ tryCatch(+ |
+
| 471 | +142x | +
+ withCallingHandlers(+ |
+
| 472 | +142x | +
+ expr = {
+ |
+
| 473 | +142x | +
+ car::Anova(+ |
+
| 474 | +142x | +
+ mod,+ |
+
| 475 | +142x | +
+ test.statistic = test_statistic,+ |
+
| 476 | +142x | +
+ type = "III"+ |
+
| 477 | ++ |
+ )+ |
+
| 478 | ++ |
+ },+ |
+
| 479 | +142x | +
+ message = function(m) invokeRestart("muffleMessage"),
+ |
+
| 480 | +142x | +
+ 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 | ++ |
+ }+ |
+
| 487 | ++ |
+ )+ |
+
| 488 | ++ |
+ )+ |
+
| 489 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Occurrence Counts by Grade+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Functions for analyzing frequencies and fractions of occurrences by grade for patients+ |
+
| 6 | ++ |
+ #' with occurrence data. Multiple occurrences within one individual are counted once at the+ |
+
| 7 | ++ |
+ #' greatest intensity/highest grade level.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 10 | ++ |
+ #' @param grade_groups (named `list` of `character`)\cr containing groupings of grades.+ |
+
| 11 | ++ |
+ #' @param remove_single (`logical`)\cr `TRUE` to not include the elements of one-element grade groups+ |
+
| 12 | ++ |
+ #' in the the output list; in this case only the grade groups names will be included in the output.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @seealso Relevant helper function [h_append_grade_groups()].+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @name count_occurrences_by_grade+ |
+
| 17 | ++ |
+ NULL+ |
+
| 18 | ++ | + + | +
| 19 | ++ |
+ #' Helper function for [s_count_occurrences_by_grade()]+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' Helper function for [s_count_occurrences_by_grade()] to insert grade groupings into list with+ |
+
| 24 | ++ |
+ #' individual grade frequencies. The order of the final result follows the order of `grade_groups`.+ |
+
| 25 | ++ |
+ #' The elements under any-grade group (if any), i.e. the grade group equal to `refs` will be moved to+ |
+
| 26 | ++ |
+ #' the end. Grade groups names must be unique.+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @inheritParams count_occurrences_by_grade+ |
+
| 29 | ++ |
+ #' @param refs (named `list` of `numeric`)\cr where each name corresponds to a reference grade level+ |
+
| 30 | ++ |
+ #' and each entry represents a count.+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @return Formatted list of grade groupings.+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' @examples+ |
+
| 35 | ++ |
+ #' h_append_grade_groups(+ |
+
| 36 | ++ |
+ #' list(+ |
+
| 37 | ++ |
+ #' "Any Grade" = as.character(1:5),+ |
+
| 38 | ++ |
+ #' "Grade 1-2" = c("1", "2"),
+ |
+
| 39 | ++ |
+ #' "Grade 3-4" = c("3", "4")
+ |
+
| 40 | ++ |
+ #' ),+ |
+
| 41 | ++ |
+ #' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
+ |
+
| 42 | ++ |
+ #' )+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' h_append_grade_groups(+ |
+
| 45 | ++ |
+ #' list(+ |
+
| 46 | ++ |
+ #' "Any Grade" = as.character(5:1),+ |
+
| 47 | ++ |
+ #' "Grade A" = "5",+ |
+
| 48 | ++ |
+ #' "Grade B" = c("4", "3")
+ |
+
| 49 | ++ |
+ #' ),+ |
+
| 50 | ++ |
+ #' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
+ |
+
| 51 | ++ |
+ #' )+ |
+
| 52 | ++ |
+ #'+ |
+
| 53 | ++ |
+ #' h_append_grade_groups(+ |
+
| 54 | ++ |
+ #' list(+ |
+
| 55 | ++ |
+ #' "Any Grade" = as.character(1:5),+ |
+
| 56 | ++ |
+ #' "Grade 1-2" = c("1", "2"),
+ |
+
| 57 | ++ |
+ #' "Grade 3-4" = c("3", "4")
+ |
+
| 58 | ++ |
+ #' ),+ |
+
| 59 | ++ |
+ #' list("1" = 10, "2" = 5, "3" = 0)
+ |
+
| 60 | ++ |
+ #' )+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' @export+ |
+
| 63 | ++ |
+ h_append_grade_groups <- function(grade_groups, refs, remove_single = TRUE) {
+ |
+
| 64 | +13x | +
+ checkmate::assert_list(grade_groups)+ |
+
| 65 | +13x | +
+ checkmate::assert_list(refs)+ |
+
| 66 | +13x | +
+ refs_orig <- refs+ |
+
| 67 | +13x | +
+ elements <- unique(unlist(grade_groups))+ |
+
| 68 | ++ | + + | +
| 69 | ++ |
+ ### compute sums in groups+ |
+
| 70 | +13x | +
+ grp_sum <- lapply(grade_groups, function(i) do.call(sum, refs[i]))+ |
+
| 71 | +13x | +
+ if (!checkmate::test_subset(elements, names(refs))) {
+ |
+
| 72 | +2x | +
+ padding_el <- setdiff(elements, names(refs))+ |
+
| 73 | +2x | +
+ refs[padding_el] <- 0+ |
+
| 74 | ++ |
+ }+ |
+
| 75 | +13x | +
+ result <- c(grp_sum, refs)+ |
+
| 76 | ++ | + + | +
| 77 | ++ |
+ ### order result while keeping grade_groups's ordering+ |
+
| 78 | +13x | +
+ ordr <- grade_groups+ |
+
| 79 | ++ | + + | +
| 80 | ++ |
+ # elements of any-grade group (if any) will be moved to the end+ |
+
| 81 | +13x | +
+ is_any <- sapply(grade_groups, setequal, y = names(refs))+ |
+
| 82 | +13x | +
+ ordr[is_any] <- list(character(0)) # hide elements under any-grade group+ |
+
| 83 | ++ | + + | +
| 84 | ++ |
+ # groups-elements combined sequence+ |
+
| 85 | +13x | +
+ ordr <- c(lapply(names(ordr), function(g) c(g, ordr[[g]])), recursive = TRUE, use.names = FALSE)+ |
+
| 86 | +13x | +
+ ordr <- ordr[!duplicated(ordr)]+ |
+
| 87 | ++ | + + | +
| 88 | ++ |
+ # append remaining elements (if any)+ |
+
| 89 | +13x | +
+ ordr <- union(ordr, unlist(grade_groups[is_any])) # from any-grade group+ |
+
| 90 | +13x | +
+ ordr <- union(ordr, names(refs)) # from refs+ |
+
| 91 | ++ | + + | +
| 92 | ++ |
+ # remove elements of single-element groups, if any+ |
+
| 93 | +13x | +
+ if (remove_single) {
+ |
+
| 94 | +13x | +
+ is_single <- sapply(grade_groups, length) == 1L+ |
+
| 95 | +13x | +
+ ordr <- setdiff(ordr, unlist(grade_groups[is_single]))+ |
+
| 96 | ++ |
+ }+ |
+
| 97 | ++ | + + | +
| 98 | ++ |
+ # apply the order+ |
+
| 99 | +13x | +
+ result <- result[ordr]+ |
+
| 100 | ++ | + + | +
| 101 | ++ |
+ # remove groups without any elements in the original refs+ |
+
| 102 | ++ |
+ # note: it's OK if groups have 0 value+ |
+
| 103 | +13x | +
+ keep_grp <- vapply(grade_groups, function(x, rf) {
+ |
+
| 104 | +37x | +
+ any(x %in% rf)+ |
+
| 105 | +13x | +
+ }, rf = names(refs_orig), logical(1))+ |
+
| 106 | ++ | + + | +
| 107 | +13x | +
+ keep_el <- names(result) %in% names(refs_orig) | names(result) %in% names(keep_grp)[keep_grp]+ |
+
| 108 | +13x | +
+ result <- result[keep_el]+ |
+
| 109 | ++ | + + | +
| 110 | +13x | +
+ result+ |
+
| 111 | ++ |
+ }+ |
+
| 112 | ++ | + + | +
| 113 | ++ |
+ #' @describeIn count_occurrences_by_grade Statistics function which counts the+ |
+
| 114 | ++ |
+ #' number of patients by highest grade.+ |
+
| 115 | ++ |
+ #'+ |
+
| 116 | ++ |
+ #' @return+ |
+
| 117 | ++ |
+ #' * `s_count_occurrences_by_grade()` returns a list of counts and fractions with one element per grade level or+ |
+
| 118 | ++ |
+ #' grade level grouping.+ |
+
| 119 | ++ |
+ #'+ |
+
| 120 | ++ |
+ #' @examples+ |
+
| 121 | ++ |
+ #' library(dplyr)+ |
+
| 122 | ++ |
+ #' df <- data.frame(+ |
+
| 123 | ++ |
+ #' USUBJID = as.character(c(1:6, 1)),+ |
+
| 124 | ++ |
+ #' ARM = factor(c("A", "A", "A", "B", "B", "B", "A"), levels = c("A", "B")),
+ |
+
| 125 | ++ |
+ #' AETOXGR = factor(c(1, 2, 3, 4, 1, 2, 3), levels = c(1:5)),+ |
+
| 126 | ++ |
+ #' AESEV = factor(+ |
+
| 127 | ++ |
+ #' x = c("MILD", "MODERATE", "SEVERE", "MILD", "MILD", "MODERATE", "SEVERE"),
+ |
+
| 128 | ++ |
+ #' levels = c("MILD", "MODERATE", "SEVERE")
+ |
+
| 129 | ++ |
+ #' ),+ |
+
| 130 | ++ |
+ #' stringsAsFactors = FALSE+ |
+
| 131 | ++ |
+ #' )+ |
+
| 132 | ++ |
+ #' df_adsl <- df %>%+ |
+
| 133 | ++ |
+ #' select(USUBJID, ARM) %>%+ |
+
| 134 | ++ |
+ #' unique()+ |
+
| 135 | ++ |
+ #'+ |
+
| 136 | ++ |
+ #' s_count_occurrences_by_grade(+ |
+
| 137 | ++ |
+ #' df,+ |
+
| 138 | ++ |
+ #' .N_col = 10L,+ |
+
| 139 | ++ |
+ #' .var = "AETOXGR",+ |
+
| 140 | ++ |
+ #' id = "USUBJID",+ |
+
| 141 | ++ |
+ #' grade_groups = list("ANY" = levels(df$AETOXGR))
+ |
+
| 142 | ++ |
+ #' )+ |
+
| 143 | ++ |
+ #'+ |
+
| 144 | ++ |
+ #' @export+ |
+
| 145 | ++ |
+ s_count_occurrences_by_grade <- function(df,+ |
+
| 146 | ++ |
+ .var,+ |
+
| 147 | ++ |
+ .N_col, # nolint+ |
+
| 148 | ++ |
+ id = "USUBJID",+ |
+
| 149 | ++ |
+ grade_groups = list(),+ |
+
| 150 | ++ |
+ remove_single = TRUE,+ |
+
| 151 | ++ |
+ labelstr = "") {
+ |
+
| 152 | +6x | +
+ assert_valid_factor(df[[.var]])+ |
+
| 153 | +6x | +
+ assert_df_with_variables(df, list(grade = .var, id = id))+ |
+
| 154 | ++ | + + | +
| 155 | +6x | +
+ if (nrow(df) < 1) {
+ |
+
| 156 | +! | +
+ grade_levels <- levels(df[[.var]])+ |
+
| 157 | +! | +
+ l_count <- as.list(rep(0, length(grade_levels)))+ |
+
| 158 | +! | +
+ names(l_count) <- grade_levels+ |
+
| 159 | ++ |
+ } else {
+ |
+
| 160 | +6x | +
+ if (isTRUE(is.factor(df[[id]]))) {
+ |
+
| 161 | +! | +
+ assert_valid_factor(df[[id]], any.missing = FALSE)+ |
+
| 162 | ++ |
+ } else {
+ |
+
| 163 | +6x | +
+ checkmate::assert_character(df[[id]], min.chars = 1, any.missing = FALSE)+ |
+
| 164 | ++ |
+ }+ |
+
| 165 | +6x | +
+ checkmate::assert_count(.N_col)+ |
+
| 166 | ++ | + + | +
| 167 | +6x | +
+ id <- df[[id]]+ |
+
| 168 | +6x | +
+ grade <- df[[.var]]+ |
+
| 169 | ++ | + + | +
| 170 | +6x | +
+ if (!is.ordered(grade)) {
+ |
+
| 171 | +6x | +
+ grade_lbl <- obj_label(grade)+ |
+
| 172 | +6x | +
+ lvls <- levels(grade)+ |
+
| 173 | +6x | +
+ if (sum(grepl("^\\d+$", lvls)) %in% c(0, length(lvls))) {
+ |
+
| 174 | +5x | +
+ lvl_ord <- lvls+ |
+
| 175 | ++ |
+ } else {
+ |
+
| 176 | +1x | +
+ lvls[!grepl("^\\d+$", lvls)] <- min(as.numeric(lvls[grepl("^\\d+$", lvls)])) - 1
+ |
+
| 177 | +1x | +
+ lvl_ord <- levels(grade)[order(as.numeric(lvls))]+ |
+
| 178 | ++ |
+ }+ |
+
| 179 | +6x | +
+ grade <- formatters::with_label(factor(grade, levels = lvl_ord, ordered = TRUE), grade_lbl)+ |
+
| 180 | ++ |
+ }+ |
+
| 181 | ++ | + + | +
| 182 | +6x | +
+ missing_lvl <- grepl("missing", tolower(levels(grade)))
+ |
+
| 183 | +6x | +
+ if (any(missing_lvl)) {
+ |
+
| 184 | +1x | +
+ grade <- factor(+ |
+
| 185 | +1x | +
+ grade,+ |
+
| 186 | +1x | +
+ levels = c(levels(grade)[!missing_lvl], levels(grade)[missing_lvl]),+ |
+
| 187 | +1x | +
+ ordered = is.ordered(grade)+ |
+
| 188 | ++ |
+ )+ |
+
| 189 | ++ |
+ }+ |
+
| 190 | +6x | +
+ df_max <- stats::aggregate(grade ~ id, FUN = max, drop = FALSE)+ |
+
| 191 | +6x | +
+ l_count <- as.list(table(df_max$grade))+ |
+
| 192 | ++ |
+ }+ |
+
| 193 | ++ | + + | +
| 194 | +6x | +
+ if (length(grade_groups) > 0) {
+ |
+
| 195 | +2x | +
+ l_count <- h_append_grade_groups(grade_groups, l_count, remove_single)+ |
+
| 196 | ++ |
+ }+ |
+
| 197 | ++ | + + | +
| 198 | +6x | +
+ l_count_fraction <- lapply(l_count, function(i, denom) c(i, i / denom), denom = .N_col)+ |
+
| 199 | ++ | + + | +
| 200 | +6x | +
+ list(+ |
+
| 201 | +6x | +
+ count_fraction = l_count_fraction+ |
+
| 202 | ++ |
+ )+ |
+
| 203 | ++ |
+ }+ |
+
| 204 | ++ | + + | +
| 205 | ++ |
+ #' @describeIn count_occurrences_by_grade Formatted analysis function which is used as `afun`+ |
+
| 206 | ++ |
+ #' in `count_occurrences_by_grade()`.+ |
+
| 207 | ++ |
+ #'+ |
+
| 208 | ++ |
+ #' @return+ |
+
| 209 | ++ |
+ #' * `a_count_occurrences_by_grade()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 210 | ++ |
+ #'+ |
+
| 211 | ++ |
+ #' @examples+ |
+
| 212 | ++ |
+ #' # We need to ungroup `count_fraction` first so that the `rtables` formatting+ |
+
| 213 | ++ |
+ #' # function `format_count_fraction()` can be applied correctly.+ |
+
| 214 | ++ |
+ #' afun <- make_afun(a_count_occurrences_by_grade, .ungroup_stats = "count_fraction")+ |
+
| 215 | ++ |
+ #' afun(+ |
+
| 216 | ++ |
+ #' df,+ |
+
| 217 | ++ |
+ #' .N_col = 10L,+ |
+
| 218 | ++ |
+ #' .var = "AETOXGR",+ |
+
| 219 | ++ |
+ #' id = "USUBJID",+ |
+
| 220 | ++ |
+ #' grade_groups = list("ANY" = levels(df$AETOXGR))
+ |
+
| 221 | ++ |
+ #' )+ |
+
| 222 | ++ |
+ #'+ |
+
| 223 | ++ |
+ #' @export+ |
+
| 224 | ++ |
+ a_count_occurrences_by_grade <- make_afun(+ |
+
| 225 | ++ |
+ s_count_occurrences_by_grade,+ |
+
| 226 | ++ |
+ .formats = c("count_fraction" = format_count_fraction_fixed_dp)
+ |
+
| 227 | ++ |
+ )+ |
+
| 228 | ++ | + + | +
| 229 | ++ |
+ #' @describeIn count_occurrences_by_grade Layout-creating function which can take statistics function+ |
+
| 230 | ++ |
+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 231 | ++ |
+ #'+ |
+
| 232 | ++ |
+ #' @param var_labels (`character`)\cr labels to show in the result table.+ |
+
| 233 | ++ |
+ #'+ |
+
| 234 | ++ |
+ #' @return+ |
+
| 235 | ++ |
+ #' * `count_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 236 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 237 | ++ |
+ #' the statistics from `s_count_occurrences_by_grade()` to the table layout.+ |
+
| 238 | ++ |
+ #'+ |
+
| 239 | ++ |
+ #' @examples+ |
+
| 240 | ++ |
+ #' # Layout creating function with custom format.+ |
+
| 241 | ++ |
+ #' basic_table() %>%+ |
+
| 242 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 243 | ++ |
+ #' add_colcounts() %>%+ |
+
| 244 | ++ |
+ #' count_occurrences_by_grade(+ |
+
| 245 | ++ |
+ #' var = "AESEV",+ |
+
| 246 | ++ |
+ #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
+ |
+
| 247 | ++ |
+ #' ) %>%+ |
+
| 248 | ++ |
+ #' build_table(df, alt_counts_df = df_adsl)+ |
+
| 249 | ++ |
+ #'+ |
+
| 250 | ++ |
+ #' # Define additional grade groupings.+ |
+
| 251 | ++ |
+ #' grade_groups <- list(+ |
+
| 252 | ++ |
+ #' "-Any-" = c("1", "2", "3", "4", "5"),
+ |
+
| 253 | ++ |
+ #' "Grade 1-2" = c("1", "2"),
+ |
+
| 254 | ++ |
+ #' "Grade 3-5" = c("3", "4", "5")
+ |
+
| 255 | ++ |
+ #' )+ |
+
| 256 | ++ |
+ #'+ |
+
| 257 | ++ |
+ #' basic_table() %>%+ |
+
| 258 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 259 | ++ |
+ #' add_colcounts() %>%+ |
+
| 260 | ++ |
+ #' count_occurrences_by_grade(+ |
+
| 261 | ++ |
+ #' var = "AETOXGR",+ |
+
| 262 | ++ |
+ #' grade_groups = grade_groups+ |
+
| 263 | ++ |
+ #' ) %>%+ |
+
| 264 | ++ |
+ #' build_table(df, alt_counts_df = df_adsl)+ |
+
| 265 | ++ |
+ #'+ |
+
| 266 | ++ |
+ #' @export+ |
+
| 267 | ++ |
+ count_occurrences_by_grade <- function(lyt,+ |
+
| 268 | ++ |
+ var,+ |
+
| 269 | ++ |
+ var_labels = var,+ |
+
| 270 | ++ |
+ show_labels = "default",+ |
+
| 271 | ++ |
+ riskdiff = FALSE,+ |
+
| 272 | ++ |
+ na_str = NA_character_,+ |
+
| 273 | ++ |
+ nested = TRUE,+ |
+
| 274 | ++ |
+ ...,+ |
+
| 275 | ++ |
+ table_names = var,+ |
+
| 276 | ++ |
+ .stats = NULL,+ |
+
| 277 | ++ |
+ .formats = NULL,+ |
+
| 278 | ++ |
+ .indent_mods = NULL,+ |
+
| 279 | ++ |
+ .labels = NULL) {
+ |
+
| 280 | +8x | +
+ checkmate::assert_flag(riskdiff)+ |
+
| 281 | ++ | + + | +
| 282 | +8x | +
+ afun <- make_afun(+ |
+
| 283 | +8x | +
+ a_count_occurrences_by_grade,+ |
+
| 284 | +8x | +
+ .stats = .stats,+ |
+
| 285 | +8x | +
+ .formats = .formats,+ |
+
| 286 | +8x | +
+ .indent_mods = .indent_mods,+ |
+
| 287 | +8x | +
+ .ungroup_stats = "count_fraction"+ |
+
| 288 | ++ |
+ )+ |
+
| 289 | ++ | + + | +
| 290 | +8x | +
+ extra_args <- if (isFALSE(riskdiff)) {
+ |
+
| 291 | +7x | +
+ list(...)+ |
+
| 292 | ++ |
+ } else {
+ |
+
| 293 | +1x | +
+ list(+ |
+
| 294 | +1x | +
+ afun = list("s_count_occurrences_by_grade" = afun),
+ |
+
| 295 | +1x | +
+ .stats = .stats,+ |
+
| 296 | +1x | +
+ .indent_mods = .indent_mods,+ |
+
| 297 | +1x | +
+ s_args = list(...)+ |
+
| 298 | ++ |
+ )+ |
+
| 299 | ++ |
+ }+ |
+
| 300 | ++ | + + | +
| 301 | +8x | +
+ analyze(+ |
+
| 302 | +8x | +
+ lyt = lyt,+ |
+
| 303 | +8x | +
+ vars = var,+ |
+
| 304 | +8x | +
+ var_labels = var_labels,+ |
+
| 305 | +8x | +
+ show_labels = show_labels,+ |
+
| 306 | +8x | +
+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ |
+
| 307 | +8x | +
+ table_names = table_names,+ |
+
| 308 | +8x | +
+ na_str = na_str,+ |
+
| 309 | +8x | +
+ nested = nested,+ |
+
| 310 | +8x | +
+ extra_args = extra_args+ |
+
| 311 | ++ |
+ )+ |
+
| 312 | ++ |
+ }+ |
+
| 313 | ++ | + + | +
| 314 | ++ |
+ #' @describeIn count_occurrences_by_grade Layout-creating function which can take content function arguments+ |
+
| 315 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ |
+
| 316 | ++ |
+ #'+ |
+
| 317 | ++ |
+ #' @return+ |
+
| 318 | ++ |
+ #' * `summarize_occurrences_by_grade()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 319 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows+ |
+
| 320 | ++ |
+ #' containing the statistics from `s_count_occurrences_by_grade()` to the table layout.+ |
+
| 321 | ++ |
+ #'+ |
+
| 322 | ++ |
+ #' @examples+ |
+
| 323 | ++ |
+ #' # Layout creating function with custom format.+ |
+
| 324 | ++ |
+ #' basic_table() %>%+ |
+
| 325 | ++ |
+ #' add_colcounts() %>%+ |
+
| 326 | ++ |
+ #' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
+ |
+
| 327 | ++ |
+ #' summarize_occurrences_by_grade(+ |
+
| 328 | ++ |
+ #' var = "AESEV",+ |
+
| 329 | ++ |
+ #' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
+ |
+
| 330 | ++ |
+ #' ) %>%+ |
+
| 331 | ++ |
+ #' build_table(df, alt_counts_df = df_adsl)+ |
+
| 332 | ++ |
+ #'+ |
+
| 333 | ++ |
+ #' basic_table() %>%+ |
+
| 334 | ++ |
+ #' add_colcounts() %>%+ |
+
| 335 | ++ |
+ #' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
+ |
+
| 336 | ++ |
+ #' summarize_occurrences_by_grade(+ |
+
| 337 | ++ |
+ #' var = "AETOXGR",+ |
+
| 338 | ++ |
+ #' grade_groups = grade_groups+ |
+
| 339 | ++ |
+ #' ) %>%+ |
+
| 340 | ++ |
+ #' build_table(df, alt_counts_df = df_adsl)+ |
+
| 341 | ++ |
+ #'+ |
+
| 342 | ++ |
+ #' @export+ |
+
| 343 | ++ |
+ summarize_occurrences_by_grade <- function(lyt,+ |
+
| 344 | ++ |
+ var,+ |
+
| 345 | ++ |
+ na_str = NA_character_,+ |
+
| 346 | ++ |
+ ...,+ |
+
| 347 | ++ |
+ .stats = NULL,+ |
+
| 348 | ++ |
+ .formats = NULL,+ |
+
| 349 | ++ |
+ .indent_mods = NULL,+ |
+
| 350 | ++ |
+ .labels = NULL) {
+ |
+
| 351 | +2x | +
+ cfun <- make_afun(+ |
+
| 352 | +2x | +
+ a_count_occurrences_by_grade,+ |
+
| 353 | +2x | +
+ .stats = .stats,+ |
+
| 354 | +2x | +
+ .formats = .formats,+ |
+
| 355 | +2x | +
+ .labels = .labels,+ |
+
| 356 | +2x | +
+ .indent_mods = .indent_mods,+ |
+
| 357 | +2x | +
+ .ungroup_stats = "count_fraction"+ |
+
| 358 | ++ |
+ )+ |
+
| 359 | ++ | + + | +
| 360 | +2x | +
+ summarize_row_groups(+ |
+
| 361 | +2x | +
+ lyt = lyt,+ |
+
| 362 | +2x | +
+ var = var,+ |
+
| 363 | +2x | +
+ cfun = cfun,+ |
+
| 364 | +2x | +
+ na_str = na_str,+ |
+
| 365 | +2x | +
+ extra_args = list(...)+ |
+
| 366 | ++ |
+ )+ |
+
| 367 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Create a Forest Plot based on a Table+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Create a forest plot from any [rtables::rtable()] object that has a+ |
+
| 4 | ++ |
+ #' column with a single value and a column with 2 values.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams grid::gTree+ |
+
| 9 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 10 | ++ |
+ #' @param tbl (`rtable`)+ |
+
| 11 | ++ |
+ #' @param col_x (`integer`)\cr column index with estimator. By default tries to get this from+ |
+
| 12 | ++ |
+ #' `tbl` attribute `col_x`, otherwise needs to be manually specified.+ |
+
| 13 | ++ |
+ #' @param col_ci (`integer`)\cr column index with confidence intervals. By default tries+ |
+
| 14 | ++ |
+ #' to get this from `tbl` attribute `col_ci`, otherwise needs to be manually specified.+ |
+
| 15 | ++ |
+ #' @param vline (`number`)\cr x coordinate for vertical line, if `NULL` then the line is omitted.+ |
+
| 16 | ++ |
+ #' @param forest_header (`character`, length 2)\cr text displayed to the left and right of `vline`, respectively.+ |
+
| 17 | ++ |
+ #' If `vline = NULL` then `forest_header` needs to be `NULL` too.+ |
+
| 18 | ++ |
+ #' By default tries to get this from `tbl` attribute `forest_header`.+ |
+
| 19 | ++ |
+ #' @param xlim (`numeric`)\cr limits for x axis.+ |
+
| 20 | ++ |
+ #' @param logx (`flag`)\cr show the x-values on logarithm scale.+ |
+
| 21 | ++ |
+ #' @param x_at (`numeric`)\cr x-tick locations, if `NULL` they get automatically chosen.+ |
+
| 22 | ++ |
+ #' @param width_row_names (`unit`)\cr width for row names.+ |
+
| 23 | ++ |
+ #' If `NULL` the widths get automatically calculated. See [grid::unit()].+ |
+
| 24 | ++ |
+ #' @param width_columns (`unit`)\cr widths for the table columns.+ |
+
| 25 | ++ |
+ #' If `NULL` the widths get automatically calculated. See [grid::unit()].+ |
+
| 26 | ++ |
+ #' @param width_forest (`unit`)\cr width for the forest column.+ |
+
| 27 | ++ |
+ #' If `NULL` the widths get automatically calculated. See [grid::unit()].+ |
+
| 28 | ++ |
+ #' @param col_symbol_size (`integer`)\cr column index from `tbl` containing data to be used+ |
+
| 29 | ++ |
+ #' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional+ |
+
| 30 | ++ |
+ #' to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups.+ |
+
| 31 | ++ |
+ #' By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified.+ |
+
| 32 | ++ |
+ #' @param col (`character`)\cr color(s).+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' @return `gTree` object containing the forest plot and table.+ |
+
| 35 | ++ |
+ #'+ |
+
| 36 | ++ |
+ #' @examples+ |
+
| 37 | ++ |
+ #' \donttest{
+ |
+
| 38 | ++ |
+ #' library(dplyr)+ |
+
| 39 | ++ |
+ #' library(forcats)+ |
+
| 40 | ++ |
+ #' library(nestcolor)+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' adrs <- tern_ex_adrs+ |
+
| 43 | ++ |
+ #' n_records <- 20+ |
+
| 44 | ++ |
+ #' adrs_labels <- formatters::var_labels(adrs, fill = TRUE)+ |
+
| 45 | ++ |
+ #' adrs <- adrs %>%+ |
+
| 46 | ++ |
+ #' filter(PARAMCD == "BESRSPI") %>%+ |
+
| 47 | ++ |
+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+ |
+
| 48 | ++ |
+ #' slice(seq_len(n_records)) %>%+ |
+
| 49 | ++ |
+ #' droplevels() %>%+ |
+
| 50 | ++ |
+ #' mutate(+ |
+
| 51 | ++ |
+ #' # Reorder levels of factor to make the placebo group the reference arm.+ |
+
| 52 | ++ |
+ #' ARM = fct_relevel(ARM, "B: Placebo"),+ |
+
| 53 | ++ |
+ #' rsp = AVALC == "CR"+ |
+
| 54 | ++ |
+ #' )+ |
+
| 55 | ++ |
+ #' formatters::var_labels(adrs) <- c(adrs_labels, "Response")+ |
+
| 56 | ++ |
+ #' df <- extract_rsp_subgroups(+ |
+
| 57 | ++ |
+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")),
+ |
+
| 58 | ++ |
+ #' data = adrs+ |
+
| 59 | ++ |
+ #' )+ |
+
| 60 | ++ |
+ #' # Full commonly used response table.+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' tbl <- basic_table() %>%+ |
+
| 63 | ++ |
+ #' tabulate_rsp_subgroups(df)+ |
+
| 64 | ++ |
+ #' p <- g_forest(tbl, gp = grid::gpar(fontsize = 10))+ |
+
| 65 | ++ |
+ #'+ |
+
| 66 | ++ |
+ #' draw_grob(p)+ |
+
| 67 | ++ |
+ #'+ |
+
| 68 | ++ |
+ #' # Odds ratio only table.+ |
+
| 69 | ++ |
+ #'+ |
+
| 70 | ++ |
+ #' tbl_or <- basic_table() %>%+ |
+
| 71 | ++ |
+ #' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci"))
+ |
+
| 72 | ++ |
+ #' tbl_or+ |
+
| 73 | ++ |
+ #' p <- g_forest(+ |
+
| 74 | ++ |
+ #' tbl_or,+ |
+
| 75 | ++ |
+ #' forest_header = c("Comparison\nBetter", "Treatment\nBetter")
+ |
+
| 76 | ++ |
+ #' )+ |
+
| 77 | ++ |
+ #'+ |
+
| 78 | ++ |
+ #' draw_grob(p)+ |
+
| 79 | ++ |
+ #'+ |
+
| 80 | ++ |
+ #' # Survival forest plot example.+ |
+
| 81 | ++ |
+ #' adtte <- tern_ex_adtte+ |
+
| 82 | ++ |
+ #' # Save variable labels before data processing steps.+ |
+
| 83 | ++ |
+ #' adtte_labels <- formatters::var_labels(adtte, fill = TRUE)+ |
+
| 84 | ++ |
+ #' adtte_f <- adtte %>%+ |
+
| 85 | ++ |
+ #' filter(+ |
+
| 86 | ++ |
+ #' PARAMCD == "OS",+ |
+
| 87 | ++ |
+ #' ARM %in% c("B: Placebo", "A: Drug X"),
+ |
+
| 88 | ++ |
+ #' SEX %in% c("M", "F")
+ |
+
| 89 | ++ |
+ #' ) %>%+ |
+
| 90 | ++ |
+ #' mutate(+ |
+
| 91 | ++ |
+ #' # Reorder levels of ARM to display reference arm before treatment arm.+ |
+
| 92 | ++ |
+ #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),+ |
+
| 93 | ++ |
+ #' SEX = droplevels(SEX),+ |
+
| 94 | ++ |
+ #' AVALU = as.character(AVALU),+ |
+
| 95 | ++ |
+ #' is_event = CNSR == 0+ |
+
| 96 | ++ |
+ #' )+ |
+
| 97 | ++ |
+ #' labels <- list(+ |
+
| 98 | ++ |
+ #' "ARM" = adtte_labels["ARM"],+ |
+
| 99 | ++ |
+ #' "SEX" = adtte_labels["SEX"],+ |
+
| 100 | ++ |
+ #' "AVALU" = adtte_labels["AVALU"],+ |
+
| 101 | ++ |
+ #' "is_event" = "Event Flag"+ |
+
| 102 | ++ |
+ #' )+ |
+
| 103 | ++ |
+ #' formatters::var_labels(adtte_f)[names(labels)] <- as.character(labels)+ |
+
| 104 | ++ |
+ #' df <- extract_survival_subgroups(+ |
+
| 105 | ++ |
+ #' variables = list(+ |
+
| 106 | ++ |
+ #' tte = "AVAL",+ |
+
| 107 | ++ |
+ #' is_event = "is_event",+ |
+
| 108 | ++ |
+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ |
+
| 109 | ++ |
+ #' ),+ |
+
| 110 | ++ |
+ #' data = adtte_f+ |
+
| 111 | ++ |
+ #' )+ |
+
| 112 | ++ |
+ #' table_hr <- basic_table() %>%+ |
+
| 113 | ++ |
+ #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1])+ |
+
| 114 | ++ |
+ #' g_forest(table_hr)+ |
+
| 115 | ++ |
+ #' # Works with any `rtable`.+ |
+
| 116 | ++ |
+ #' tbl <- rtable(+ |
+
| 117 | ++ |
+ #' header = c("E", "CI", "N"),
+ |
+
| 118 | ++ |
+ #' rrow("", 1, c(.8, 1.2), 200),
+ |
+
| 119 | ++ |
+ #' rrow("", 1.2, c(1.1, 1.4), 50)
+ |
+
| 120 | ++ |
+ #' )+ |
+
| 121 | ++ |
+ #' g_forest(+ |
+
| 122 | ++ |
+ #' tbl = tbl,+ |
+
| 123 | ++ |
+ #' col_x = 1,+ |
+
| 124 | ++ |
+ #' col_ci = 2,+ |
+
| 125 | ++ |
+ #' xlim = c(0.5, 2),+ |
+
| 126 | ++ |
+ #' x_at = c(0.5, 1, 2),+ |
+
| 127 | ++ |
+ #' col_symbol_size = 3+ |
+
| 128 | ++ |
+ #' )+ |
+
| 129 | ++ |
+ #' tbl <- rtable(+ |
+
| 130 | ++ |
+ #' header = rheader(+ |
+
| 131 | ++ |
+ #' rrow("", rcell("A", colspan = 2)),
+ |
+
| 132 | ++ |
+ #' rrow("", "c1", "c2")
+ |
+
| 133 | ++ |
+ #' ),+ |
+
| 134 | ++ |
+ #' rrow("row 1", 1, c(.8, 1.2)),
+ |
+
| 135 | ++ |
+ #' rrow("row 2", 1.2, c(1.1, 1.4))
+ |
+
| 136 | ++ |
+ #' )+ |
+
| 137 | ++ |
+ #' g_forest(+ |
+
| 138 | ++ |
+ #' tbl = tbl,+ |
+
| 139 | ++ |
+ #' col_x = 1,+ |
+
| 140 | ++ |
+ #' col_ci = 2,+ |
+
| 141 | ++ |
+ #' xlim = c(0.5, 2),+ |
+
| 142 | ++ |
+ #' x_at = c(0.5, 1, 2),+ |
+
| 143 | ++ |
+ #' vline = 1,+ |
+
| 144 | ++ |
+ #' forest_header = c("Hello", "World")
+ |
+
| 145 | ++ |
+ #' )+ |
+
| 146 | ++ |
+ #' }+ |
+
| 147 | ++ |
+ #'+ |
+
| 148 | ++ |
+ #' @export+ |
+
| 149 | ++ |
+ g_forest <- function(tbl,+ |
+
| 150 | ++ |
+ col_x = attr(tbl, "col_x"),+ |
+
| 151 | ++ |
+ col_ci = attr(tbl, "col_ci"),+ |
+
| 152 | ++ |
+ vline = 1,+ |
+
| 153 | ++ |
+ forest_header = attr(tbl, "forest_header"),+ |
+
| 154 | ++ |
+ xlim = c(0.1, 10),+ |
+
| 155 | ++ |
+ logx = TRUE,+ |
+
| 156 | ++ |
+ x_at = c(0.1, 1, 10),+ |
+
| 157 | ++ |
+ width_row_names = NULL,+ |
+
| 158 | ++ |
+ width_columns = NULL,+ |
+
| 159 | ++ |
+ width_forest = grid::unit(1, "null"),+ |
+
| 160 | ++ |
+ col_symbol_size = attr(tbl, "col_symbol_size"),+ |
+
| 161 | ++ |
+ col = getOption("ggplot2.discrete.colour")[1],
+ |
+
| 162 | ++ |
+ gp = NULL,+ |
+
| 163 | ++ |
+ draw = TRUE,+ |
+
| 164 | ++ |
+ newpage = TRUE) {
+ |
+
| 165 | +2x | +
+ checkmate::assert_class(tbl, "VTableTree")+ |
+
| 166 | ++ | + + | +
| 167 | +2x | +
+ nr <- nrow(tbl)+ |
+
| 168 | +2x | +
+ nc <- ncol(tbl)+ |
+
| 169 | +2x | +
+ if (is.null(col)) {
+ |
+
| 170 | +2x | +
+ col <- "blue"+ |
+
| 171 | ++ |
+ }+ |
+
| 172 | ++ | + + | +
| 173 | +2x | +
+ checkmate::assert_number(col_x, lower = 0, upper = nc, null.ok = FALSE)+ |
+
| 174 | +2x | +
+ checkmate::assert_number(col_ci, lower = 0, upper = nc, null.ok = FALSE)+ |
+
| 175 | +2x | +
+ checkmate::assert_number(col_symbol_size, lower = 0, upper = nc, null.ok = TRUE)+ |
+
| 176 | +2x | +
+ checkmate::assert_true(col_x > 0)+ |
+
| 177 | +2x | +
+ checkmate::assert_true(col_ci > 0)+ |
+
| 178 | +2x | +
+ checkmate::assert_character(col)+ |
+
| 179 | +2x | +
+ if (!is.null(col_symbol_size)) {
+ |
+
| 180 | +1x | +
+ checkmate::assert_true(col_symbol_size > 0)+ |
+
| 181 | ++ |
+ }+ |
+
| 182 | ++ | + + | +
| 183 | +2x | +
+ x_e <- vapply(seq_len(nr), function(i) {
+ |
+
| 184 | ++ |
+ # If a label row is selected NULL is returned with a warning (suppressed)+ |
+
| 185 | +9x | +
+ xi <- suppressWarnings(as.vector(tbl[i, col_x, drop = TRUE]))+ |
+
| 186 | ++ | + + | +
| 187 | +9x | +
+ if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) {
+ |
+
| 188 | +7x | +
+ xi+ |
+
| 189 | ++ |
+ } else {
+ |
+
| 190 | +2x | +
+ NA_real_+ |
+
| 191 | ++ |
+ }+ |
+
| 192 | +2x | +
+ }, numeric(1))+ |
+
| 193 | ++ | + + | +
| 194 | +2x | +
+ x_ci <- lapply(seq_len(nr), function(i) {
+ |
+
| 195 | +9x | +
+ xi <- suppressWarnings(as.vector(tbl[i, col_ci, drop = TRUE])) # as above+ |
+
| 196 | ++ | + + | +
| 197 | +9x | +
+ if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) {
+ |
+
| 198 | +7x | +
+ if (length(xi) != 2) {
+ |
+
| 199 | +! | +
+ stop("ci column needs two elements")
+ |
+
| 200 | ++ |
+ }+ |
+
| 201 | +7x | +
+ xi+ |
+
| 202 | ++ |
+ } else {
+ |
+
| 203 | +2x | +
+ c(NA_real_, NA_real_)+ |
+
| 204 | ++ |
+ }+ |
+
| 205 | ++ |
+ })+ |
+
| 206 | ++ | + + | +
| 207 | +2x | +
+ lower <- vapply(x_ci, `[`, numeric(1), 1)+ |
+
| 208 | +2x | +
+ upper <- vapply(x_ci, `[`, numeric(1), 2)+ |
+
| 209 | ++ | + + | +
| 210 | +2x | +
+ symbol_size <- if (!is.null(col_symbol_size)) {
+ |
+
| 211 | +1x | +
+ tmp_symbol_size <- vapply(seq_len(nr), function(i) {
+ |
+
| 212 | +7x | +
+ suppressWarnings(xi <- as.vector(tbl[i, col_symbol_size, drop = TRUE]))+ |
+
| 213 | ++ | + + | +
| 214 | +7x | +
+ if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) {
+ |
+
| 215 | +5x | +
+ xi+ |
+
| 216 | ++ |
+ } else {
+ |
+
| 217 | +1x | +
+ NA_real_+ |
+
| 218 | ++ |
+ }+ |
+
| 219 | +1x | +
+ }, numeric(1))+ |
+
| 220 | ++ | + + | +
| 221 | ++ |
+ # Scale symbol size.+ |
+
| 222 | +1x | +
+ tmp_symbol_size <- sqrt(tmp_symbol_size)+ |
+
| 223 | +1x | +
+ max_size <- max(tmp_symbol_size, na.rm = TRUE)+ |
+
| 224 | ++ |
+ # Biggest points have radius is 2 * (1/3.5) lines not to overlap.+ |
+
| 225 | ++ |
+ # See forest_dot_line.+ |
+
| 226 | +1x | +
+ 2 * tmp_symbol_size / max_size+ |
+
| 227 | ++ |
+ } else {
+ |
+
| 228 | +1x | +
+ NULL+ |
+
| 229 | ++ |
+ }+ |
+
| 230 | ++ | + + | +
| 231 | +2x | +
+ grob_forest <- forest_grob(+ |
+
| 232 | +2x | +
+ tbl,+ |
+
| 233 | +2x | +
+ x_e,+ |
+
| 234 | +2x | +
+ lower,+ |
+
| 235 | +2x | +
+ upper,+ |
+
| 236 | +2x | +
+ vline,+ |
+
| 237 | +2x | +
+ forest_header,+ |
+
| 238 | +2x | +
+ xlim,+ |
+
| 239 | +2x | +
+ logx,+ |
+
| 240 | +2x | +
+ x_at,+ |
+
| 241 | +2x | +
+ width_row_names,+ |
+
| 242 | +2x | +
+ width_columns,+ |
+
| 243 | +2x | +
+ width_forest,+ |
+
| 244 | +2x | +
+ symbol_size = symbol_size,+ |
+
| 245 | +2x | +
+ col = col,+ |
+
| 246 | +2x | +
+ gp = gp,+ |
+
| 247 | +2x | +
+ vp = grid::plotViewport(margins = rep(1, 4))+ |
+
| 248 | ++ |
+ )+ |
+
| 249 | ++ | + + | +
| 250 | +2x | +
+ if (draw) {
+ |
+
| 251 | +2x | +
+ if (newpage) grid::grid.newpage()+ |
+
| 252 | +2x | +
+ grid::grid.draw(grob_forest)+ |
+
| 253 | ++ |
+ }+ |
+
| 254 | ++ | + + | +
| 255 | +2x | +
+ invisible(grob_forest)+ |
+
| 256 | ++ |
+ }+ |
+
| 257 | ++ | + + | +
| 258 | ++ |
+ #' Forest Plot Grob+ |
+
| 259 | ++ |
+ #'+ |
+
| 260 | ++ |
+ #' @inheritParams g_forest+ |
+
| 261 | ++ |
+ #' @param tbl ([rtables::rtable()])+ |
+
| 262 | ++ |
+ #' @param x (`numeric`)\cr coordinate of point.+ |
+
| 263 | ++ |
+ #' @param lower,upper (`numeric`)\cr lower/upper bound of the confidence interval.+ |
+
| 264 | ++ |
+ #' @param symbol_size (`numeric`)\cr vector with relative size for plot symbol.+ |
+
| 265 | ++ |
+ #' If `NULL`, the same symbol size is used.+ |
+
| 266 | ++ |
+ #'+ |
+
| 267 | ++ |
+ #' @details+ |
+
| 268 | ++ |
+ #' The heights get automatically determined.+ |
+
| 269 | ++ |
+ #'+ |
+
| 270 | ++ |
+ #' @noRd+ |
+
| 271 | ++ |
+ #'+ |
+
| 272 | ++ |
+ #' @examples+ |
+
| 273 | ++ |
+ #' tbl <- rtable(+ |
+
| 274 | ++ |
+ #' header = rheader(+ |
+
| 275 | ++ |
+ #' rrow("", "E", rcell("CI", colspan = 2), "N"),
+ |
+
| 276 | ++ |
+ #' rrow("", "A", "B", "C", "D")
+ |
+
| 277 | ++ |
+ #' ),+ |
+
| 278 | ++ |
+ #' rrow("row 1", 1, 0.8, 1.1, 16),
+ |
+
| 279 | ++ |
+ #' rrow("row 2", 1.4, 0.8, 1.6, 25),
+ |
+
| 280 | ++ |
+ #' rrow("row 3", 1.2, 0.8, 1.6, 36)
+ |
+
| 281 | ++ |
+ #' )+ |
+
| 282 | ++ |
+ #'+ |
+
| 283 | ++ |
+ #' x <- c(1, 1.4, 1.2)+ |
+
| 284 | ++ |
+ #' lower <- c(0.8, 0.8, 0.8)+ |
+
| 285 | ++ |
+ #' upper <- c(1.1, 1.6, 1.6)+ |
+
| 286 | ++ |
+ #' # numeric vector with multiplication factor to scale each circle radius+ |
+
| 287 | ++ |
+ #' # default radius is 1/3.5 lines+ |
+
| 288 | ++ |
+ #' symbol_scale <- c(1, 1.25, 1.5)+ |
+
| 289 | ++ |
+ #'+ |
+
| 290 | ++ |
+ #' # Internal function - forest_grob+ |
+
| 291 | ++ |
+ #' \donttest{
+ |
+
| 292 | ++ |
+ #' p <- forest_grob(tbl, x, lower, upper,+ |
+
| 293 | ++ |
+ #' vline = 1, forest_header = c("A", "B"),
+ |
+
| 294 | ++ |
+ #' x_at = c(.1, 1, 10), xlim = c(0.1, 10), logx = TRUE, symbol_size = symbol_scale,+ |
+
| 295 | ++ |
+ #' vp = grid::plotViewport(margins = c(1, 1, 1, 1))+ |
+
| 296 | ++ |
+ #' )+ |
+
| 297 | ++ |
+ #'+ |
+
| 298 | ++ |
+ #' draw_grob(p)+ |
+
| 299 | ++ |
+ #' }+ |
+
| 300 | ++ |
+ forest_grob <- function(tbl,+ |
+
| 301 | ++ |
+ x,+ |
+
| 302 | ++ |
+ lower,+ |
+
| 303 | ++ |
+ upper,+ |
+
| 304 | ++ |
+ vline,+ |
+
| 305 | ++ |
+ forest_header,+ |
+
| 306 | ++ |
+ xlim = NULL,+ |
+
| 307 | ++ |
+ logx = FALSE,+ |
+
| 308 | ++ |
+ x_at = NULL,+ |
+
| 309 | ++ |
+ width_row_names = NULL,+ |
+
| 310 | ++ |
+ width_columns = NULL,+ |
+
| 311 | ++ |
+ width_forest = grid::unit(1, "null"),+ |
+
| 312 | ++ |
+ symbol_size = NULL,+ |
+
| 313 | ++ |
+ col = "blue",+ |
+
| 314 | ++ |
+ name = NULL,+ |
+
| 315 | ++ |
+ gp = NULL,+ |
+
| 316 | ++ |
+ vp = NULL) {
+ |
+
| 317 | +2x | +
+ nr <- nrow(tbl)+ |
+
| 318 | +2x | +
+ if (is.null(vline)) {
+ |
+
| 319 | +! | +
+ checkmate::assert_true(is.null(forest_header))+ |
+
| 320 | ++ |
+ } else {
+ |
+
| 321 | +2x | +
+ checkmate::assert_number(vline)+ |
+
| 322 | +2x | +
+ checkmate::assert_character(forest_header, len = 2, null.ok = TRUE)+ |
+
| 323 | ++ |
+ }+ |
+
| 324 | ++ | + + | +
| 325 | +2x | +
+ checkmate::assert_numeric(x, len = nr)+ |
+
| 326 | +2x | +
+ checkmate::assert_numeric(lower, len = nr)+ |
+
| 327 | +2x | +
+ checkmate::assert_numeric(upper, len = nr)+ |
+
| 328 | +2x | +
+ checkmate::assert_numeric(symbol_size, len = nr, null.ok = TRUE)+ |
+
| 329 | +2x | +
+ checkmate::assert_character(col)+ |
+
| 330 | ++ | + + | +
| 331 | +2x | +
+ if (is.null(symbol_size)) {
+ |
+
| 332 | +1x | +
+ symbol_size <- rep(1, nr)+ |
+
| 333 | ++ |
+ }+ |
+
| 334 | ++ | + + | +
| 335 | +2x | +
+ if (is.null(xlim)) {
+ |
+
| 336 | +! | +
+ r <- range(c(x, lower, upper), na.rm = TRUE)+ |
+
| 337 | +! | +
+ xlim <- r + c(-0.05, 0.05) * diff(r)+ |
+
| 338 | ++ |
+ }+ |
+
| 339 | ++ | + + | +
| 340 | +2x | +
+ if (logx) {
+ |
+
| 341 | +2x | +
+ if (is.null(x_at)) {
+ |
+
| 342 | +! | +
+ x_at <- pretty(log(stats::na.omit(c(x, lower, upper))))+ |
+
| 343 | +! | +
+ x_labels <- exp(x_at)+ |
+
| 344 | ++ |
+ } else {
+ |
+
| 345 | +2x | +
+ x_labels <- x_at+ |
+
| 346 | +2x | +
+ x_at <- log(x_at)+ |
+
| 347 | ++ |
+ }+ |
+
| 348 | +2x | +
+ xlim <- log(xlim)+ |
+
| 349 | +2x | +
+ x <- log(x)+ |
+
| 350 | +2x | +
+ lower <- log(lower)+ |
+
| 351 | +2x | +
+ upper <- log(upper)+ |
+
| 352 | +2x | +
+ if (!is.null(vline)) {
+ |
+
| 353 | +2x | +
+ vline <- log(vline)+ |
+
| 354 | ++ |
+ }+ |
+
| 355 | ++ |
+ } else {
+ |
+
| 356 | +! | +
+ x_labels <- TRUE+ |
+
| 357 | ++ |
+ }+ |
+
| 358 | ++ | + + | +
| 359 | +2x | +
+ data_forest_vp <- grid::dataViewport(xlim, c(0, 1))+ |
+
| 360 | ++ | + + | +
| 361 | ++ |
+ # Get table content as matrix form.+ |
+
| 362 | +2x | +
+ mf <- matrix_form(tbl)+ |
+
| 363 | ++ | + + | +
| 364 | ++ |
+ # Use `rtables` indent_string eventually.+ |
+
| 365 | +2x | +
+ mf$strings[, 1] <- paste0(+ |
+
| 366 | +2x | +
+ strrep(" ", c(rep(0, attr(mf, "nrow_header")), mf$row_info$indent)),
+ |
+
| 367 | +2x | +
+ mf$strings[, 1]+ |
+
| 368 | ++ |
+ )+ |
+
| 369 | ++ | + + | +
| 370 | +2x | +
+ n_header <- attr(mf, "nrow_header")+ |
+
| 371 | ++ | + + | +
| 372 | +! | +
+ if (any(mf$display[, 1] == FALSE)) stop("row names need to be always displayed")
+ |
+
| 373 | ++ | + + | +
| 374 | ++ |
+ # Pre-process the data to be used in lapply and cell_in_rows.+ |
+
| 375 | +2x | +
+ to_args_for_cell_in_rows_fun <- function(part = c("body", "header"),
+ |
+
| 376 | +2x | +
+ underline_colspan = FALSE) {
+ |
+
| 377 | +4x | +
+ part <- match.arg(part)+ |
+
| 378 | +4x | +
+ if (part == "body") {
+ |
+
| 379 | +2x | +
+ mat_row_indices <- seq_len(nrow(tbl)) + n_header+ |
+
| 380 | +2x | +
+ row_ind_offset <- -n_header+ |
+
| 381 | ++ |
+ } else {
+ |
+
| 382 | +2x | +
+ mat_row_indices <- seq_len(n_header)+ |
+
| 383 | +2x | +
+ row_ind_offset <- 0+ |
+
| 384 | ++ |
+ }+ |
+
| 385 | ++ | + + | +
| 386 | +4x | +
+ lapply(mat_row_indices, function(i) {
+ |
+
| 387 | +13x | +
+ disp <- mf$display[i, -1]+ |
+
| 388 | +13x | +
+ list(+ |
+
| 389 | +13x | +
+ row_name = mf$strings[i, 1],+ |
+
| 390 | +13x | +
+ cells = mf$strings[i, -1][disp],+ |
+
| 391 | +13x | +
+ cell_spans = mf$spans[i, -1][disp],+ |
+
| 392 | +13x | +
+ row_index = i + row_ind_offset,+ |
+
| 393 | +13x | +
+ underline_colspan = underline_colspan+ |
+
| 394 | ++ |
+ )+ |
+
| 395 | ++ |
+ })+ |
+
| 396 | ++ |
+ }+ |
+
| 397 | ++ | + + | +
| 398 | +2x | +
+ args_header <- to_args_for_cell_in_rows_fun("header", underline_colspan = TRUE)
+ |
+
| 399 | +2x | +
+ args_body <- to_args_for_cell_in_rows_fun("body", underline_colspan = FALSE)
+ |
+
| 400 | ++ | + + | +
| 401 | +2x | +
+ grid::gTree(+ |
+
| 402 | +2x | +
+ name = name,+ |
+
| 403 | +2x | +
+ children = grid::gList(+ |
+
| 404 | +2x | +
+ grid::gTree(+ |
+
| 405 | +2x | +
+ children = do.call(grid::gList, lapply(args_header, do.call, what = cell_in_rows)),+ |
+
| 406 | +2x | +
+ vp = grid::vpPath("vp_table_layout", "vp_header")
+ |
+
| 407 | ++ |
+ ),+ |
+
| 408 | +2x | +
+ grid::gTree(+ |
+
| 409 | +2x | +
+ children = do.call(grid::gList, lapply(args_body, do.call, what = cell_in_rows)),+ |
+
| 410 | +2x | +
+ vp = grid::vpPath("vp_table_layout", "vp_body")
+ |
+
| 411 | ++ |
+ ),+ |
+
| 412 | +2x | +
+ grid::linesGrob(+ |
+
| 413 | +2x | +
+ grid::unit(c(0, 1), "npc"),+ |
+
| 414 | +2x | +
+ y = grid::unit(c(.5, .5), "npc"),+ |
+
| 415 | +2x | +
+ vp = grid::vpPath("vp_table_layout", "vp_spacer")
+ |
+
| 416 | ++ |
+ ),+ |
+
| 417 | ++ |
+ # forest part+ |
+
| 418 | +2x | +
+ if (is.null(vline)) {
+ |
+
| 419 | +! | +
+ NULL+ |
+
| 420 | ++ |
+ } else {
+ |
+
| 421 | +2x | +
+ grid::gTree(+ |
+
| 422 | +2x | +
+ children = grid::gList(+ |
+
| 423 | +2x | +
+ grid::gTree(+ |
+
| 424 | +2x | +
+ children = grid::gList(+ |
+
| 425 | ++ |
+ # this may overflow, to fix, look here+ |
+
| 426 | ++ |
+ # https://stackoverflow.com/questions/33623169/add-multi-line-footnote-to-tablegrob-while-using-gridextra-in-r #nolintr+ |
+
| 427 | +2x | +
+ grid::textGrob(+ |
+
| 428 | +2x | +
+ forest_header[1],+ |
+
| 429 | +2x | +
+ x = grid::unit(vline, "native") - grid::unit(1, "lines"),+ |
+
| 430 | +2x | +
+ just = c("right", "center")
+ |
+
| 431 | ++ |
+ ),+ |
+
| 432 | +2x | +
+ grid::textGrob(+ |
+
| 433 | +2x | +
+ forest_header[2],+ |
+
| 434 | +2x | +
+ x = grid::unit(vline, "native") + grid::unit(1, "lines"),+ |
+
| 435 | +2x | +
+ just = c("left", "center")
+ |
+
| 436 | ++ |
+ )+ |
+
| 437 | ++ |
+ ),+ |
+
| 438 | +2x | +
+ vp = grid::vpStack(grid::viewport(layout.pos.col = ncol(tbl) + 2), data_forest_vp)+ |
+
| 439 | ++ |
+ )+ |
+
| 440 | ++ |
+ ),+ |
+
| 441 | +2x | +
+ vp = grid::vpPath("vp_table_layout", "vp_header")
+ |
+
| 442 | ++ |
+ )+ |
+
| 443 | ++ |
+ },+ |
+
| 444 | +2x | +
+ grid::gTree(+ |
+
| 445 | +2x | +
+ children = grid::gList(+ |
+
| 446 | +2x | +
+ grid::gTree(+ |
+
| 447 | +2x | +
+ children = grid::gList(+ |
+
| 448 | +2x | +
+ grid::rectGrob(gp = grid::gpar(col = "gray90", fill = "gray90")),+ |
+
| 449 | +2x | +
+ if (is.null(vline)) {
+ |
+
| 450 | +! | +
+ NULL+ |
+
| 451 | ++ |
+ } else {
+ |
+
| 452 | +2x | +
+ grid::linesGrob(+ |
+
| 453 | +2x | +
+ x = grid::unit(rep(vline, 2), "native"),+ |
+
| 454 | +2x | +
+ y = grid::unit(c(0, 1), "npc"),+ |
+
| 455 | +2x | +
+ gp = grid::gpar(lwd = 2),+ |
+
| 456 | +2x | +
+ vp = data_forest_vp+ |
+
| 457 | ++ |
+ )+ |
+
| 458 | ++ |
+ },+ |
+
| 459 | +2x | +
+ grid::xaxisGrob(at = x_at, label = x_labels, vp = data_forest_vp)+ |
+
| 460 | ++ |
+ ),+ |
+
| 461 | +2x | +
+ vp = grid::viewport(layout.pos.col = ncol(tbl) + 2)+ |
+
| 462 | ++ |
+ )+ |
+
| 463 | ++ |
+ ),+ |
+
| 464 | +2x | +
+ vp = grid::vpPath("vp_table_layout", "vp_body")
+ |
+
| 465 | ++ |
+ ),+ |
+
| 466 | +2x | +
+ grid::gTree(+ |
+
| 467 | +2x | +
+ children = do.call(+ |
+
| 468 | +2x | +
+ grid::gList,+ |
+
| 469 | +2x | +
+ Map(+ |
+
| 470 | +2x | +
+ function(xi, li, ui, row_index, size_i, col) {
+ |
+
| 471 | +9x | +
+ forest_dot_line(+ |
+
| 472 | +9x | +
+ xi,+ |
+
| 473 | +9x | +
+ li,+ |
+
| 474 | +9x | +
+ ui,+ |
+
| 475 | +9x | +
+ row_index,+ |
+
| 476 | +9x | +
+ xlim,+ |
+
| 477 | +9x | +
+ symbol_size = size_i,+ |
+
| 478 | +9x | +
+ col = col,+ |
+
| 479 | +9x | +
+ datavp = data_forest_vp+ |
+
| 480 | ++ |
+ )+ |
+
| 481 | ++ |
+ },+ |
+
| 482 | +2x | +
+ x,+ |
+
| 483 | +2x | +
+ lower,+ |
+
| 484 | +2x | +
+ upper,+ |
+
| 485 | +2x | +
+ seq_along(x),+ |
+
| 486 | +2x | +
+ symbol_size,+ |
+
| 487 | +2x | +
+ col,+ |
+
| 488 | +2x | +
+ USE.NAMES = FALSE+ |
+
| 489 | ++ |
+ )+ |
+
| 490 | ++ |
+ ),+ |
+
| 491 | +2x | +
+ vp = grid::vpPath("vp_table_layout", "vp_body")
+ |
+
| 492 | ++ |
+ )+ |
+
| 493 | ++ |
+ ),+ |
+
| 494 | +2x | +
+ childrenvp = forest_viewport(tbl, width_row_names, width_columns, width_forest),+ |
+
| 495 | +2x | +
+ vp = vp,+ |
+
| 496 | +2x | +
+ gp = gp+ |
+
| 497 | ++ |
+ )+ |
+
| 498 | ++ |
+ }+ |
+
| 499 | ++ | + + | +
| 500 | ++ | + + | +
| 501 | ++ |
+ cell_in_rows <- function(row_name,+ |
+
| 502 | ++ |
+ cells,+ |
+
| 503 | ++ |
+ cell_spans,+ |
+
| 504 | ++ |
+ row_index,+ |
+
| 505 | ++ |
+ underline_colspan = FALSE) {
+ |
+
| 506 | +13x | +
+ checkmate::assert_string(row_name)+ |
+
| 507 | +13x | +
+ checkmate::assert_character(cells, min.len = 1, any.missing = FALSE)+ |
+
| 508 | +13x | +
+ checkmate::assert_numeric(cell_spans, len = length(cells), any.missing = FALSE)+ |
+
| 509 | +13x | +
+ checkmate::assert_number(row_index)+ |
+
| 510 | +13x | +
+ checkmate::assert_flag(underline_colspan)+ |
+
| 511 | ++ | + + | +
| 512 | +13x | +
+ vp_name_rn <- paste0("rowname-", row_index)
+ |
+
| 513 | +13x | +
+ g_rowname <- if (!is.null(row_name) && row_name != "") {
+ |
+
| 514 | +10x | +
+ grid::textGrob(+ |
+
| 515 | +10x | +
+ name = vp_name_rn,+ |
+
| 516 | +10x | +
+ label = row_name,+ |
+
| 517 | +10x | +
+ x = grid::unit(0, "npc"),+ |
+
| 518 | +10x | +
+ just = c("left", "center"),
+ |
+
| 519 | +10x | +
+ vp = grid::vpPath(paste0("rowname-", row_index))
+ |
+
| 520 | ++ |
+ )+ |
+
| 521 | ++ |
+ } else {
+ |
+
| 522 | +3x | +
+ NULL+ |
+
| 523 | ++ |
+ }+ |
+
| 524 | ++ | + + | +
| 525 | +13x | +
+ gl_cols <- if (!(length(cells) > 0)) {
+ |
+
| 526 | +! | +
+ list(NULL)+ |
+
| 527 | ++ |
+ } else {
+ |
+
| 528 | +13x | +
+ j <- 1 # column index of cell+ |
+
| 529 | ++ | + + | +
| 530 | +13x | +
+ lapply(seq_along(cells), function(k) {
+ |
+
| 531 | +67x | +
+ cell_ascii <- cells[[k]]+ |
+
| 532 | +67x | +
+ cs <- cell_spans[[k]]+ |
+
| 533 | ++ | + + | +
| 534 | +67x | +
+ if (is.na(cell_ascii) || is.null(cell_ascii)) {
+ |
+
| 535 | +! | +
+ cell_ascii <- "NA"+ |
+
| 536 | ++ |
+ }+ |
+
| 537 | ++ | + + | +
| 538 | +67x | +
+ cell_name <- paste0("g-cell-", row_index, "-", j)
+ |
+
| 539 | ++ | + + | +
| 540 | +67x | +
+ cell_grobs <- if (identical(cell_ascii, "")) {
+ |
+
| 541 | +14x | +
+ NULL+ |
+
| 542 | ++ |
+ } else {
+ |
+
| 543 | +53x | +
+ if (cs == 1) {
+ |
+
| 544 | +49x | +
+ grid::textGrob(+ |
+
| 545 | +49x | +
+ label = cell_ascii,+ |
+
| 546 | +49x | +
+ name = cell_name,+ |
+
| 547 | +49x | +
+ vp = grid::vpPath(paste0("cell-", row_index, "-", j))
+ |
+
| 548 | ++ |
+ )+ |
+
| 549 | ++ |
+ } else {
+ |
+
| 550 | ++ |
+ # +1 because of rowname+ |
+
| 551 | +4x | +
+ vp_joined_cols <- grid::viewport(layout.pos.row = row_index, layout.pos.col = seq(j + 1, j + cs))+ |
+
| 552 | ++ | + + | +
| 553 | +4x | +
+ lab <- grid::textGrob(+ |
+
| 554 | +4x | +
+ label = cell_ascii,+ |
+
| 555 | +4x | +
+ name = cell_name,+ |
+
| 556 | +4x | +
+ vp = vp_joined_cols+ |
+
| 557 | ++ |
+ )+ |
+
| 558 | ++ | + + | +
| 559 | +4x | +
+ if (!underline_colspan || grepl("^[[:space:]]*$", cell_ascii)) {
+ |
+
| 560 | +1x | +
+ lab+ |
+
| 561 | ++ |
+ } else {
+ |
+
| 562 | +3x | +
+ grid::gList(+ |
+
| 563 | +3x | +
+ lab,+ |
+
| 564 | +3x | +
+ grid::linesGrob(+ |
+
| 565 | +3x | +
+ x = grid::unit.c(grid::unit(.2, "lines"), grid::unit(1, "npc") - grid::unit(.2, "lines")),+ |
+
| 566 | +3x | +
+ y = grid::unit(c(0, 0), "npc"),+ |
+
| 567 | +3x | +
+ vp = vp_joined_cols+ |
+
| 568 | ++ |
+ )+ |
+
| 569 | ++ |
+ )+ |
+
| 570 | ++ |
+ }+ |
+
| 571 | ++ |
+ }+ |
+
| 572 | ++ |
+ }+ |
+
| 573 | +67x | +
+ j <<- j + cs+ |
+
| 574 | ++ | + + | +
| 575 | +67x | +
+ cell_grobs+ |
+
| 576 | ++ |
+ })+ |
+
| 577 | ++ |
+ }+ |
+
| 578 | ++ | + + | +
| 579 | +13x | +
+ grid::gList(+ |
+
| 580 | +13x | +
+ g_rowname,+ |
+
| 581 | +13x | +
+ do.call(grid::gList, gl_cols)+ |
+
| 582 | ++ |
+ )+ |
+
| 583 | ++ |
+ }+ |
+
| 584 | ++ | + + | +
| 585 | ++ |
+ #' Graphic Object: Forest Dot Line+ |
+
| 586 | ++ |
+ #'+ |
+
| 587 | ++ |
+ #' Calculate the `grob` corresponding to the dot line within the forest plot.+ |
+
| 588 | ++ |
+ #'+ |
+
| 589 | ++ |
+ #' @noRd+ |
+
| 590 | ++ |
+ forest_dot_line <- function(x,+ |
+
| 591 | ++ |
+ lower,+ |
+
| 592 | ++ |
+ upper,+ |
+
| 593 | ++ |
+ row_index,+ |
+
| 594 | ++ |
+ xlim,+ |
+
| 595 | ++ |
+ symbol_size = 1,+ |
+
| 596 | ++ |
+ col = "blue",+ |
+
| 597 | ++ |
+ datavp) {
+ |
+
| 598 | +9x | +
+ ci <- c(lower, upper)+ |
+
| 599 | +9x | +
+ if (any(!is.na(c(x, ci)))) {
+ |
+
| 600 | ++ |
+ # line+ |
+
| 601 | +7x | +
+ y <- grid::unit(c(0.5, 0.5), "npc")+ |
+
| 602 | ++ | + + | +
| 603 | +7x | +
+ g_line <- if (all(!is.na(ci)) && ci[2] > xlim[1] && ci[1] < xlim[2]) {
+ |
+
| 604 | ++ |
+ # -+ |
+
| 605 | +7x | +
+ if (ci[1] >= xlim[1] && ci[2] <= xlim[2]) {
+ |
+
| 606 | +2x | +
+ grid::linesGrob(x = grid::unit(c(ci[1], ci[2]), "native"), y = y)+ |
+
| 607 | +5x | +
+ } else if (ci[1] < xlim[1] && ci[2] > xlim[2]) {
+ |
+
| 608 | ++ |
+ # <->+ |
+
| 609 | +3x | +
+ grid::linesGrob(+ |
+
| 610 | +3x | +
+ x = grid::unit(xlim, "native"),+ |
+
| 611 | +3x | +
+ y = y,+ |
+
| 612 | +3x | +
+ arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "both")+ |
+
| 613 | ++ |
+ )+ |
+
| 614 | +2x | +
+ } else if (ci[1] < xlim[1] && ci[2] <= xlim[2]) {
+ |
+
| 615 | ++ |
+ # <-+ |
+
| 616 | +! | +
+ grid::linesGrob(+ |
+
| 617 | +! | +
+ x = grid::unit(c(xlim[1], ci[2]), "native"),+ |
+
| 618 | +! | +
+ y = y,+ |
+
| 619 | +! | +
+ arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "first")+ |
+
| 620 | ++ |
+ )+ |
+
| 621 | +2x | +
+ } else if (ci[1] >= xlim[1] && ci[2] > xlim[2]) {
+ |
+
| 622 | ++ |
+ # ->+ |
+
| 623 | +2x | +
+ grid::linesGrob(+ |
+
| 624 | +2x | +
+ x = grid::unit(c(ci[1], xlim[2]), "native"),+ |
+
| 625 | +2x | +
+ y = y,+ |
+
| 626 | +2x | +
+ arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "last")+ |
+
| 627 | ++ |
+ )+ |
+
| 628 | ++ |
+ }+ |
+
| 629 | ++ |
+ } else {
+ |
+
| 630 | +! | +
+ NULL+ |
+
| 631 | ++ |
+ }+ |
+
| 632 | ++ | + + | +
| 633 | +7x | +
+ g_circle <- if (!is.na(x) && x >= xlim[1] && x <= xlim[2]) {
+ |
+
| 634 | +6x | +
+ grid::circleGrob(+ |
+
| 635 | +6x | +
+ x = grid::unit(x, "native"),+ |
+
| 636 | +6x | +
+ y = y,+ |
+
| 637 | +6x | +
+ r = grid::unit(1 / 3.5 * symbol_size, "lines"),+ |
+
| 638 | +6x | +
+ name = "point"+ |
+
| 639 | ++ |
+ )+ |
+
| 640 | ++ |
+ } else {
+ |
+
| 641 | +1x | +
+ NULL+ |
+
| 642 | ++ |
+ }+ |
+
| 643 | ++ | + + | +
| 644 | +7x | +
+ grid::gTree(+ |
+
| 645 | +7x | +
+ children = grid::gList(+ |
+
| 646 | +7x | +
+ grid::gTree(+ |
+
| 647 | +7x | +
+ children = grid::gList(+ |
+
| 648 | +7x | +
+ grid::gList(+ |
+
| 649 | +7x | +
+ g_line,+ |
+
| 650 | +7x | +
+ g_circle+ |
+
| 651 | ++ |
+ )+ |
+
| 652 | ++ |
+ ),+ |
+
| 653 | +7x | +
+ vp = datavp,+ |
+
| 654 | +7x | +
+ gp = grid::gpar(col = col, fill = col)+ |
+
| 655 | ++ |
+ )+ |
+
| 656 | ++ |
+ ),+ |
+
| 657 | +7x | +
+ vp = grid::vpPath(paste0("forest-", row_index))
+ |
+
| 658 | ++ |
+ )+ |
+
| 659 | ++ |
+ } else {
+ |
+
| 660 | +2x | +
+ NULL+ |
+
| 661 | ++ |
+ }+ |
+
| 662 | ++ |
+ }+ |
+
| 663 | ++ | + + | +
| 664 | ++ |
+ #' Create a Viewport Tree for the Forest Plot+ |
+
| 665 | ++ |
+ #' @param tbl (`rtable`)+ |
+
| 666 | ++ |
+ #' @param width_row_names (`grid::unit`)\cr Width of row names+ |
+
| 667 | ++ |
+ #' @param width_columns (`grid::unit`)\cr Width of column spans+ |
+
| 668 | ++ |
+ #' @param width_forest (`grid::unit`)\cr Width of the forest plot+ |
+
| 669 | ++ |
+ #' @param gap_column (`grid::unit`)\cr Gap width between the columns+ |
+
| 670 | ++ |
+ #' @param gap_header (`grid::unit`)\cr Gap width between the header+ |
+
| 671 | ++ |
+ #' @param mat_form matrix print form of the table+ |
+
| 672 | ++ |
+ #' @return A viewport tree.+ |
+
| 673 | ++ |
+ #'+ |
+
| 674 | ++ |
+ #' @examples+ |
+
| 675 | ++ |
+ #' library(grid)+ |
+
| 676 | ++ |
+ #'+ |
+
| 677 | ++ |
+ #' tbl <- rtable(+ |
+
| 678 | ++ |
+ #' header = rheader(+ |
+
| 679 | ++ |
+ #' rrow("", "E", rcell("CI", colspan = 2)),
+ |
+
| 680 | ++ |
+ #' rrow("", "A", "B", "C")
+ |
+
| 681 | ++ |
+ #' ),+ |
+
| 682 | ++ |
+ #' rrow("row 1", 1, 0.8, 1.1),
+ |
+
| 683 | ++ |
+ #' rrow("row 2", 1.4, 0.8, 1.6),
+ |
+
| 684 | ++ |
+ #' rrow("row 3", 1.2, 0.8, 1.2)
+ |
+
| 685 | ++ |
+ #' )+ |
+
| 686 | ++ |
+ #'+ |
+
| 687 | ++ |
+ #' \donttest{
+ |
+
| 688 | ++ |
+ #' v <- forest_viewport(tbl)+ |
+
| 689 | ++ |
+ #'+ |
+
| 690 | ++ |
+ #' grid::grid.newpage()+ |
+
| 691 | ++ |
+ #' showViewport(v)+ |
+
| 692 | ++ |
+ #' }+ |
+
| 693 | ++ |
+ #'+ |
+
| 694 | ++ |
+ #' @export+ |
+
| 695 | ++ |
+ forest_viewport <- function(tbl,+ |
+
| 696 | ++ |
+ width_row_names = NULL,+ |
+
| 697 | ++ |
+ width_columns = NULL,+ |
+
| 698 | ++ |
+ width_forest = grid::unit(1, "null"),+ |
+
| 699 | ++ |
+ gap_column = grid::unit(1, "lines"),+ |
+
| 700 | ++ |
+ gap_header = grid::unit(1, "lines"),+ |
+
| 701 | ++ |
+ mat_form = NULL) {
+ |
+
| 702 | +2x | +
+ checkmate::assert_class(tbl, "VTableTree")+ |
+
| 703 | +2x | +
+ checkmate::assert_true(grid::is.unit(width_forest))+ |
+
| 704 | +2x | +
+ if (!is.null(width_row_names)) {
+ |
+
| 705 | +! | +
+ checkmate::assert_true(grid::is.unit(width_row_names))+ |
+
| 706 | ++ |
+ }+ |
+
| 707 | +2x | +
+ if (!is.null(width_columns)) {
+ |
+
| 708 | +! | +
+ checkmate::assert_true(grid::is.unit(width_columns))+ |
+
| 709 | ++ |
+ }+ |
+
| 710 | ++ | + + | +
| 711 | +2x | +
+ if (is.null(mat_form)) mat_form <- matrix_form(tbl)+ |
+
| 712 | ++ | + + | +
| 713 | +2x | +
+ mat_form$strings[!mat_form$display] <- ""+ |
+
| 714 | ++ | + + | +
| 715 | +2x | +
+ nr <- nrow(tbl)+ |
+
| 716 | +2x | +
+ nc <- ncol(tbl)+ |
+
| 717 | +2x | +
+ nr_h <- attr(mat_form, "nrow_header")+ |
+
| 718 | ++ | + + | +
| 719 | +2x | +
+ if (is.null(width_row_names) || is.null(width_columns)) {
+ |
+
| 720 | +2x | +
+ tbl_widths <- formatters::propose_column_widths(mat_form)+ |
+
| 721 | +2x | +
+ strs_with_width <- strrep("x", tbl_widths) # that works for mono spaced fonts
+ |
+
| 722 | +2x | +
+ if (is.null(width_row_names)) width_row_names <- grid::stringWidth(strs_with_width[1])+ |
+
| 723 | +2x | +
+ if (is.null(width_columns)) width_columns <- grid::stringWidth(strs_with_width[-1])+ |
+
| 724 | ++ |
+ }+ |
+
| 725 | ++ | + + | +
| 726 | ++ |
+ # Widths for row name, cols, forest.+ |
+
| 727 | +2x | +
+ widths <- grid::unit.c(+ |
+
| 728 | +2x | +
+ width_row_names + gap_column,+ |
+
| 729 | +2x | +
+ width_columns + gap_column,+ |
+
| 730 | +2x | +
+ width_forest+ |
+
| 731 | ++ |
+ )+ |
+
| 732 | ++ | + + | +
| 733 | +2x | +
+ n_lines_per_row <- apply(+ |
+
| 734 | +2x | +
+ X = mat_form$strings,+ |
+
| 735 | +2x | +
+ MARGIN = 1,+ |
+
| 736 | +2x | +
+ FUN = function(row) {
+ |
+
| 737 | +13x | +
+ tmp <- vapply(+ |
+
| 738 | +13x | +
+ gregexpr("\n", row, fixed = TRUE),
+ |
+
| 739 | +13x | +
+ attr, numeric(1),+ |
+
| 740 | +13x | +
+ "match.length"+ |
+
| 741 | +13x | +
+ ) + 1+ |
+
| 742 | +13x | +
+ max(c(tmp, 1))+ |
+
| 743 | ++ |
+ }+ |
+
| 744 | ++ |
+ )+ |
+
| 745 | ++ | + + | +
| 746 | +2x | +
+ i_header <- seq_len(nr_h)+ |
+
| 747 | ++ | + + | +
| 748 | +2x | +
+ height_body_rows <- grid::unit(n_lines_per_row[-i_header] * 1.2, "lines")+ |
+
| 749 | +2x | +
+ height_header_rows <- grid::unit(n_lines_per_row[i_header] * 1.2, "lines")+ |
+
| 750 | ++ | + + | +
| 751 | +2x | +
+ height_body <- grid::unit(sum(n_lines_per_row[-i_header]) * 1.2, "lines")+ |
+
| 752 | +2x | +
+ height_header <- grid::unit(sum(n_lines_per_row[i_header]) * 1.2, "lines")+ |
+
| 753 | ++ | + + | +
| 754 | +2x | +
+ nc_g <- nc + 2 # number of columns incl. row names and forest+ |
+
| 755 | ++ | + + | +
| 756 | +2x | +
+ vp_tbl <- grid::vpTree(+ |
+
| 757 | +2x | +
+ parent = grid::viewport(+ |
+
| 758 | +2x | +
+ name = "vp_table_layout",+ |
+
| 759 | +2x | +
+ layout = grid::grid.layout(+ |
+
| 760 | +2x | +
+ nrow = 3, ncol = 1,+ |
+
| 761 | +2x | +
+ heights = grid::unit.c(height_header, gap_header, height_body)+ |
+
| 762 | ++ |
+ )+ |
+
| 763 | ++ |
+ ),+ |
+
| 764 | +2x | +
+ children = grid::vpList(+ |
+
| 765 | +2x | +
+ vp_forest_table_part(nr_h, nc_g, 1, 1, widths, height_header_rows, "vp_header"),+ |
+
| 766 | +2x | +
+ vp_forest_table_part(nr, nc_g, 3, 1, widths, height_body_rows, "vp_body"),+ |
+
| 767 | +2x | +
+ grid::viewport(name = "vp_spacer", layout.pos.row = 2, layout.pos.col = 1)+ |
+
| 768 | ++ |
+ )+ |
+
| 769 | ++ |
+ )+ |
+
| 770 | +2x | +
+ vp_tbl+ |
+
| 771 | ++ |
+ }+ |
+
| 772 | ++ | + + | +
| 773 | ++ |
+ #' Viewport Forest Plot: Table Part+ |
+
| 774 | ++ |
+ #'+ |
+
| 775 | ++ |
+ #' Prepares a viewport for the table included in the forest plot.+ |
+
| 776 | ++ |
+ #'+ |
+
| 777 | ++ |
+ #' @noRd+ |
+
| 778 | ++ |
+ vp_forest_table_part <- function(nrow,+ |
+
| 779 | ++ |
+ ncol,+ |
+
| 780 | ++ |
+ l_row,+ |
+
| 781 | ++ |
+ l_col,+ |
+
| 782 | ++ |
+ widths,+ |
+
| 783 | ++ |
+ heights,+ |
+
| 784 | ++ |
+ name) {
+ |
+
| 785 | +4x | +
+ grid::vpTree(+ |
+
| 786 | +4x | +
+ grid::viewport(+ |
+
| 787 | +4x | +
+ name = name,+ |
+
| 788 | +4x | +
+ layout.pos.row = l_row,+ |
+
| 789 | +4x | +
+ layout.pos.col = l_col,+ |
+
| 790 | +4x | +
+ layout = grid::grid.layout(nrow = nrow, ncol = ncol, widths = widths, heights = heights)+ |
+
| 791 | ++ |
+ ),+ |
+
| 792 | +4x | +
+ children = grid::vpList(+ |
+
| 793 | +4x | +
+ do.call(+ |
+
| 794 | +4x | +
+ grid::vpList,+ |
+
| 795 | +4x | +
+ lapply(+ |
+
| 796 | +4x | +
+ seq_len(nrow), function(i) {
+ |
+
| 797 | +13x | +
+ grid::viewport(layout.pos.row = i, layout.pos.col = 1, name = paste0("rowname-", i))
+ |
+
| 798 | ++ |
+ }+ |
+
| 799 | ++ |
+ )+ |
+
| 800 | ++ |
+ ),+ |
+
| 801 | +4x | +
+ do.call(+ |
+
| 802 | +4x | +
+ grid::vpList,+ |
+
| 803 | +4x | +
+ apply(+ |
+
| 804 | +4x | +
+ expand.grid(seq_len(nrow), seq_len(ncol - 2)),+ |
+
| 805 | +4x | +
+ 1,+ |
+
| 806 | +4x | +
+ function(x) {
+ |
+
| 807 | +71x | +
+ i <- x[1]+ |
+
| 808 | +71x | +
+ j <- x[2]+ |
+
| 809 | +71x | +
+ grid::viewport(layout.pos.row = i, layout.pos.col = j + 1, name = paste0("cell-", i, "-", j))
+ |
+
| 810 | ++ |
+ }+ |
+
| 811 | ++ |
+ )+ |
+
| 812 | ++ |
+ ),+ |
+
| 813 | +4x | +
+ do.call(+ |
+
| 814 | +4x | +
+ grid::vpList,+ |
+
| 815 | +4x | +
+ lapply(+ |
+
| 816 | +4x | +
+ seq_len(nrow),+ |
+
| 817 | +4x | +
+ function(i) {
+ |
+
| 818 | +13x | +
+ grid::viewport(layout.pos.row = i, layout.pos.col = ncol, name = paste0("forest-", i))
+ |
+
| 819 | ++ |
+ }+ |
+
| 820 | ++ |
+ )+ |
+
| 821 | ++ |
+ )+ |
+
| 822 | ++ |
+ )+ |
+
| 823 | ++ |
+ )+ |
+
| 824 | ++ |
+ }+ |
+
| 825 | ++ | + + | +
| 826 | ++ |
+ #' Forest Rendering+ |
+
| 827 | ++ |
+ #'+ |
+
| 828 | ++ |
+ #' Renders the forest grob.+ |
+
| 829 | ++ |
+ #'+ |
+
| 830 | ++ |
+ #' @noRd+ |
+
| 831 | ++ |
+ grid.forest <- function(...) { # nolint
+ |
+
| 832 | +! | +
+ grid::grid.draw(forest_grob(...))+ |
+
| 833 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Odds Ratio Estimation+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Compares bivariate responses between two groups in terms of odds ratios+ |
+
| 6 | ++ |
+ #' along with a confidence interval.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @details This function uses either logistic regression for unstratified+ |
+
| 11 | ++ |
+ #' analyses, or conditional logistic regression for stratified analyses.+ |
+
| 12 | ++ |
+ #' The Wald confidence interval with the specified confidence level is+ |
+
| 13 | ++ |
+ #' calculated.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @note For stratified analyses, there is currently no implementation for conditional+ |
+
| 16 | ++ |
+ #' likelihood confidence intervals, therefore the likelihood confidence interval is not+ |
+
| 17 | ++ |
+ #' yet available as an option. Besides, when `rsp` contains only responders or non-responders,+ |
+
| 18 | ++ |
+ #' then the result values will be `NA`, because no odds ratio estimation is possible.+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @seealso Relevant helper function [h_odds_ratio()].+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @name odds_ratio+ |
+
| 23 | ++ |
+ NULL+ |
+
| 24 | ++ | + + | +
| 25 | ++ |
+ #' @describeIn odds_ratio Statistics function which estimates the odds ratio+ |
+
| 26 | ++ |
+ #' between a treatment and a control. A `variables` list with `arm` and `strata`+ |
+
| 27 | ++ |
+ #' variable names must be passed if a stratified analysis is required.+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @inheritParams split_cols_by_groups+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' @return+ |
+
| 32 | ++ |
+ #' * `s_odds_ratio()` returns a named list with the statistics `or_ci`+ |
+
| 33 | ++ |
+ #' (containing `est`, `lcl`, and `ucl`) and `n_tot`.+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' @examples+ |
+
| 36 | ++ |
+ #' set.seed(12)+ |
+
| 37 | ++ |
+ #' dta <- data.frame(+ |
+
| 38 | ++ |
+ #' rsp = sample(c(TRUE, FALSE), 100, TRUE),+ |
+
| 39 | ++ |
+ #' grp = factor(rep(c("A", "B"), each = 50), levels = c("B", "A")),
+ |
+
| 40 | ++ |
+ #' strata = factor(sample(c("C", "D"), 100, TRUE))
+ |
+
| 41 | ++ |
+ #' )+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' # Unstratified analysis.+ |
+
| 44 | ++ |
+ #' s_odds_ratio(+ |
+
| 45 | ++ |
+ #' df = subset(dta, grp == "A"),+ |
+
| 46 | ++ |
+ #' .var = "rsp",+ |
+
| 47 | ++ |
+ #' .ref_group = subset(dta, grp == "B"),+ |
+
| 48 | ++ |
+ #' .in_ref_col = FALSE,+ |
+
| 49 | ++ |
+ #' .df_row = dta+ |
+
| 50 | ++ |
+ #' )+ |
+
| 51 | ++ |
+ #'+ |
+
| 52 | ++ |
+ #' # Stratified analysis.+ |
+
| 53 | ++ |
+ #' s_odds_ratio(+ |
+
| 54 | ++ |
+ #' df = subset(dta, grp == "A"),+ |
+
| 55 | ++ |
+ #' .var = "rsp",+ |
+
| 56 | ++ |
+ #' .ref_group = subset(dta, grp == "B"),+ |
+
| 57 | ++ |
+ #' .in_ref_col = FALSE,+ |
+
| 58 | ++ |
+ #' .df_row = dta,+ |
+
| 59 | ++ |
+ #' variables = list(arm = "grp", strata = "strata")+ |
+
| 60 | ++ |
+ #' )+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' @export+ |
+
| 63 | ++ |
+ s_odds_ratio <- function(df,+ |
+
| 64 | ++ |
+ .var,+ |
+
| 65 | ++ |
+ .ref_group,+ |
+
| 66 | ++ |
+ .in_ref_col,+ |
+
| 67 | ++ |
+ .df_row,+ |
+
| 68 | ++ |
+ variables = list(arm = NULL, strata = NULL),+ |
+
| 69 | ++ |
+ conf_level = 0.95,+ |
+
| 70 | ++ |
+ groups_list = NULL) {
+ |
+
| 71 | +65x | +
+ y <- list(or_ci = "", n_tot = "")+ |
+
| 72 | ++ | + + | +
| 73 | +65x | +
+ if (!.in_ref_col) {
+ |
+
| 74 | +65x | +
+ assert_proportion_value(conf_level)+ |
+
| 75 | +65x | +
+ assert_df_with_variables(df, list(rsp = .var))+ |
+
| 76 | +65x | +
+ assert_df_with_variables(.ref_group, list(rsp = .var))+ |
+
| 77 | ++ | + + | +
| 78 | +65x | +
+ if (is.null(variables$strata)) {
+ |
+
| 79 | +52x | +
+ data <- data.frame(+ |
+
| 80 | +52x | +
+ rsp = c(.ref_group[[.var]], df[[.var]]),+ |
+
| 81 | +52x | +
+ grp = factor(+ |
+
| 82 | +52x | +
+ rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
+ |
+
| 83 | +52x | +
+ levels = c("ref", "Not-ref")
+ |
+
| 84 | ++ |
+ )+ |
+
| 85 | ++ |
+ )+ |
+
| 86 | +52x | +
+ y <- or_glm(data, conf_level = conf_level)+ |
+
| 87 | ++ |
+ } else {
+ |
+
| 88 | +13x | +
+ assert_df_with_variables(.df_row, c(list(rsp = .var), variables))+ |
+
| 89 | ++ | + + | +
| 90 | ++ |
+ # The group variable prepared for clogit must be synchronised with combination groups definition.+ |
+
| 91 | +13x | +
+ if (is.null(groups_list)) {
+ |
+
| 92 | +12x | +
+ ref_grp <- as.character(unique(.ref_group[[variables$arm]]))+ |
+
| 93 | +12x | +
+ trt_grp <- as.character(unique(df[[variables$arm]]))+ |
+
| 94 | +12x | +
+ grp <- stats::relevel(factor(.df_row[[variables$arm]]), ref = ref_grp)+ |
+
| 95 | ++ |
+ } else {
+ |
+
| 96 | ++ |
+ # If more than one level in reference col.+ |
+
| 97 | +1x | +
+ reference <- as.character(unique(.ref_group[[variables$arm]]))+ |
+
| 98 | +1x | +
+ grp_ref_flag <- vapply(+ |
+
| 99 | +1x | +
+ X = groups_list,+ |
+
| 100 | +1x | +
+ FUN.VALUE = TRUE,+ |
+
| 101 | +1x | +
+ FUN = function(x) all(reference %in% x)+ |
+
| 102 | ++ |
+ )+ |
+
| 103 | +1x | +
+ ref_grp <- names(groups_list)[grp_ref_flag]+ |
+
| 104 | ++ | + + | +
| 105 | ++ |
+ # If more than one level in treatment col.+ |
+
| 106 | +1x | +
+ treatment <- as.character(unique(df[[variables$arm]]))+ |
+
| 107 | +1x | +
+ grp_trt_flag <- vapply(+ |
+
| 108 | +1x | +
+ X = groups_list,+ |
+
| 109 | +1x | +
+ FUN.VALUE = TRUE,+ |
+
| 110 | +1x | +
+ FUN = function(x) all(treatment %in% x)+ |
+
| 111 | ++ |
+ )+ |
+
| 112 | +1x | +
+ trt_grp <- names(groups_list)[grp_trt_flag]+ |
+
| 113 | ++ | + + | +
| 114 | +1x | +
+ grp <- combine_levels(.df_row[[variables$arm]], levels = reference, new_level = ref_grp)+ |
+
| 115 | +1x | +
+ grp <- combine_levels(grp, levels = treatment, new_level = trt_grp)+ |
+
| 116 | ++ |
+ }+ |
+
| 117 | ++ | + + | +
| 118 | ++ |
+ # The reference level in `grp` must be the same as in the `rtables` column split.+ |
+
| 119 | +13x | +
+ data <- data.frame(+ |
+
| 120 | +13x | +
+ rsp = .df_row[[.var]],+ |
+
| 121 | +13x | +
+ grp = grp,+ |
+
| 122 | +13x | +
+ strata = interaction(.df_row[variables$strata])+ |
+
| 123 | ++ |
+ )+ |
+
| 124 | +13x | +
+ y_all <- or_clogit(data, conf_level = conf_level)+ |
+
| 125 | +13x | +
+ checkmate::assert_string(trt_grp)+ |
+
| 126 | +13x | +
+ checkmate::assert_subset(trt_grp, names(y_all$or_ci))+ |
+
| 127 | +12x | +
+ y$or_ci <- y_all$or_ci[[trt_grp]]+ |
+
| 128 | +12x | +
+ y$n_tot <- y_all$n_tot+ |
+
| 129 | ++ |
+ }+ |
+
| 130 | ++ |
+ }+ |
+
| 131 | ++ | + + | +
| 132 | +64x | +
+ y$or_ci <- formatters::with_label(+ |
+
| 133 | +64x | +
+ x = y$or_ci,+ |
+
| 134 | +64x | +
+ label = paste0("Odds Ratio (", 100 * conf_level, "% CI)")
+ |
+
| 135 | ++ |
+ )+ |
+
| 136 | ++ | + + | +
| 137 | +64x | +
+ y$n_tot <- formatters::with_label(+ |
+
| 138 | +64x | +
+ x = y$n_tot,+ |
+
| 139 | +64x | +
+ label = "Total n"+ |
+
| 140 | ++ |
+ )+ |
+
| 141 | ++ | + + | +
| 142 | +64x | +
+ y+ |
+
| 143 | ++ |
+ }+ |
+
| 144 | ++ | + + | +
| 145 | ++ |
+ #' @describeIn odds_ratio Formatted analysis function which is used as `afun` in `estimate_odds_ratio()`.+ |
+
| 146 | ++ |
+ #'+ |
+
| 147 | ++ |
+ #' @return+ |
+
| 148 | ++ |
+ #' * `a_odds_ratio()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 149 | ++ |
+ #'+ |
+
| 150 | ++ |
+ #' @examples+ |
+
| 151 | ++ |
+ #' a_odds_ratio(+ |
+
| 152 | ++ |
+ #' df = subset(dta, grp == "A"),+ |
+
| 153 | ++ |
+ #' .var = "rsp",+ |
+
| 154 | ++ |
+ #' .ref_group = subset(dta, grp == "B"),+ |
+
| 155 | ++ |
+ #' .in_ref_col = FALSE,+ |
+
| 156 | ++ |
+ #' .df_row = dta+ |
+
| 157 | ++ |
+ #' )+ |
+
| 158 | ++ |
+ #'+ |
+
| 159 | ++ |
+ #' @export+ |
+
| 160 | ++ |
+ a_odds_ratio <- make_afun(+ |
+
| 161 | ++ |
+ s_odds_ratio,+ |
+
| 162 | ++ |
+ .formats = c(or_ci = "xx.xx (xx.xx - xx.xx)"),+ |
+
| 163 | ++ |
+ .indent_mods = c(or_ci = 1L)+ |
+
| 164 | ++ |
+ )+ |
+
| 165 | ++ | + + | +
| 166 | ++ |
+ #' @describeIn odds_ratio Layout-creating function which can take statistics function arguments+ |
+
| 167 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 168 | ++ |
+ #'+ |
+
| 169 | ++ |
+ #' @param ... arguments passed to `s_odds_ratio()`.+ |
+
| 170 | ++ |
+ #'+ |
+
| 171 | ++ |
+ #' @return+ |
+
| 172 | ++ |
+ #' * `estimate_odds_ratio()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 173 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 174 | ++ |
+ #' the statistics from `s_odds_ratio()` to the table layout.+ |
+
| 175 | ++ |
+ #'+ |
+
| 176 | ++ |
+ #' @examples+ |
+
| 177 | ++ |
+ #' dta <- data.frame(+ |
+
| 178 | ++ |
+ #' rsp = sample(c(TRUE, FALSE), 100, TRUE),+ |
+
| 179 | ++ |
+ #' grp = factor(rep(c("A", "B"), each = 50))
+ |
+
| 180 | ++ |
+ #' )+ |
+
| 181 | ++ |
+ #'+ |
+
| 182 | ++ |
+ #' l <- basic_table() %>%+ |
+
| 183 | ++ |
+ #' split_cols_by(var = "grp", ref_group = "B") %>%+ |
+
| 184 | ++ |
+ #' estimate_odds_ratio(vars = "rsp")+ |
+
| 185 | ++ |
+ #'+ |
+
| 186 | ++ |
+ #' build_table(l, df = dta)+ |
+
| 187 | ++ |
+ #'+ |
+
| 188 | ++ |
+ #' @export+ |
+
| 189 | ++ |
+ estimate_odds_ratio <- function(lyt,+ |
+
| 190 | ++ |
+ vars,+ |
+
| 191 | ++ |
+ na_str = NA_character_,+ |
+
| 192 | ++ |
+ nested = TRUE,+ |
+
| 193 | ++ |
+ ...,+ |
+
| 194 | ++ |
+ show_labels = "hidden",+ |
+
| 195 | ++ |
+ table_names = vars,+ |
+
| 196 | ++ |
+ .stats = "or_ci",+ |
+
| 197 | ++ |
+ .formats = NULL,+ |
+
| 198 | ++ |
+ .labels = NULL,+ |
+
| 199 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 200 | +3x | +
+ afun <- make_afun(+ |
+
| 201 | +3x | +
+ a_odds_ratio,+ |
+
| 202 | +3x | +
+ .stats = .stats,+ |
+
| 203 | +3x | +
+ .formats = .formats,+ |
+
| 204 | +3x | +
+ .labels = .labels,+ |
+
| 205 | +3x | +
+ .indent_mods = .indent_mods+ |
+
| 206 | ++ |
+ )+ |
+
| 207 | ++ | + + | +
| 208 | +3x | +
+ analyze(+ |
+
| 209 | +3x | +
+ lyt,+ |
+
| 210 | +3x | +
+ vars,+ |
+
| 211 | +3x | +
+ afun = afun,+ |
+
| 212 | +3x | +
+ na_str = na_str,+ |
+
| 213 | +3x | +
+ nested = nested,+ |
+
| 214 | +3x | +
+ extra_args = list(...),+ |
+
| 215 | +3x | +
+ show_labels = show_labels,+ |
+
| 216 | +3x | +
+ table_names = table_names+ |
+
| 217 | ++ |
+ )+ |
+
| 218 | ++ |
+ }+ |
+
| 219 | ++ | + + | +
| 220 | ++ |
+ #' Helper Functions for Odds Ratio Estimation+ |
+
| 221 | ++ |
+ #'+ |
+
| 222 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 223 | ++ |
+ #'+ |
+
| 224 | ++ |
+ #' Functions to calculate odds ratios in [estimate_odds_ratio()].+ |
+
| 225 | ++ |
+ #'+ |
+
| 226 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 227 | ++ |
+ #' @param data (`data.frame`)\cr data frame containing at least the variables `rsp` and `grp`, and optionally+ |
+
| 228 | ++ |
+ #' `strata` for [or_clogit()].+ |
+
| 229 | ++ |
+ #'+ |
+
| 230 | ++ |
+ #' @return A named `list` of elements `or_ci` and `n_tot`.+ |
+
| 231 | ++ |
+ #'+ |
+
| 232 | ++ |
+ #' @seealso [odds_ratio]+ |
+
| 233 | ++ |
+ #'+ |
+
| 234 | ++ |
+ #' @name h_odds_ratio+ |
+
| 235 | ++ |
+ NULL+ |
+
| 236 | ++ | + + | +
| 237 | ++ |
+ #' @describeIn h_odds_ratio Estimates the odds ratio based on [stats::glm()]. Note that there must be+ |
+
| 238 | ++ |
+ #' exactly 2 groups in `data` as specified by the `grp` variable.+ |
+
| 239 | ++ |
+ #'+ |
+
| 240 | ++ |
+ #' @examples+ |
+
| 241 | ++ |
+ #' # Data with 2 groups.+ |
+
| 242 | ++ |
+ #' data <- data.frame(+ |
+
| 243 | ++ |
+ #' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1)),+ |
+
| 244 | ++ |
+ #' grp = letters[c(1, 1, 1, 2, 2, 2, 1, 2)],+ |
+
| 245 | ++ |
+ #' strata = letters[c(1, 2, 1, 2, 2, 2, 1, 2)],+ |
+
| 246 | ++ |
+ #' stringsAsFactors = TRUE+ |
+
| 247 | ++ |
+ #' )+ |
+
| 248 | ++ |
+ #'+ |
+
| 249 | ++ |
+ #' # Odds ratio based on glm.+ |
+
| 250 | ++ |
+ #' or_glm(data, conf_level = 0.95)+ |
+
| 251 | ++ |
+ #'+ |
+
| 252 | ++ |
+ #' @export+ |
+
| 253 | ++ |
+ or_glm <- function(data, conf_level) {
+ |
+
| 254 | +55x | +
+ checkmate::assert_logical(data$rsp)+ |
+
| 255 | +55x | +
+ assert_proportion_value(conf_level)+ |
+
| 256 | +55x | +
+ assert_df_with_variables(data, list(rsp = "rsp", grp = "grp"))+ |
+
| 257 | +55x | +
+ checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
+ |
+
| 258 | ++ | + + | +
| 259 | +55x | +
+ data$grp <- as_factor_keep_attributes(data$grp)+ |
+
| 260 | +55x | +
+ assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2)+ |
+
| 261 | +55x | +
+ formula <- stats::as.formula("rsp ~ grp")
+ |
+
| 262 | +55x | +
+ model_fit <- stats::glm(+ |
+
| 263 | +55x | +
+ formula = formula, data = data,+ |
+
| 264 | +55x | +
+ family = stats::binomial(link = "logit")+ |
+
| 265 | ++ |
+ )+ |
+
| 266 | ++ | + + | +
| 267 | ++ |
+ # Note that here we need to discard the intercept.+ |
+
| 268 | +55x | +
+ or <- exp(stats::coef(model_fit)[-1])+ |
+
| 269 | +55x | +
+ or_ci <- exp(+ |
+
| 270 | +55x | +
+ stats::confint.default(model_fit, level = conf_level)[-1, , drop = FALSE]+ |
+
| 271 | ++ |
+ )+ |
+
| 272 | ++ | + + | +
| 273 | +55x | +
+ values <- stats::setNames(c(or, or_ci), c("est", "lcl", "ucl"))
+ |
+
| 274 | +55x | +
+ n_tot <- stats::setNames(nrow(model_fit$model), "n_tot")+ |
+
| 275 | ++ | + + | +
| 276 | +55x | +
+ list(or_ci = values, n_tot = n_tot)+ |
+
| 277 | ++ |
+ }+ |
+
| 278 | ++ | + + | +
| 279 | ++ |
+ #' @describeIn h_odds_ratio estimates the odds ratio based on [survival::clogit()]. This is done for+ |
+
| 280 | ++ |
+ #' the whole data set including all groups, since the results are not the same as when doing+ |
+
| 281 | ++ |
+ #' pairwise comparisons between the groups.+ |
+
| 282 | ++ |
+ #'+ |
+
| 283 | ++ |
+ #' @examples+ |
+
| 284 | ++ |
+ #' # Data with 3 groups.+ |
+
| 285 | ++ |
+ #' data <- data.frame(+ |
+
| 286 | ++ |
+ #' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0)),+ |
+
| 287 | ++ |
+ #' grp = letters[c(1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3)],+ |
+
| 288 | ++ |
+ #' strata = LETTERS[c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)],+ |
+
| 289 | ++ |
+ #' stringsAsFactors = TRUE+ |
+
| 290 | ++ |
+ #' )+ |
+
| 291 | ++ |
+ #'+ |
+
| 292 | ++ |
+ #' # Odds ratio based on stratified estimation by conditional logistic regression.+ |
+
| 293 | ++ |
+ #' or_clogit(data, conf_level = 0.95)+ |
+
| 294 | ++ |
+ #'+ |
+
| 295 | ++ |
+ #' @export+ |
+
| 296 | ++ |
+ or_clogit <- function(data, conf_level) {
+ |
+
| 297 | +16x | +
+ checkmate::assert_logical(data$rsp)+ |
+
| 298 | +16x | +
+ assert_proportion_value(conf_level)+ |
+
| 299 | +16x | +
+ assert_df_with_variables(data, list(rsp = "rsp", grp = "grp", strata = "strata"))+ |
+
| 300 | +16x | +
+ checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
+ |
+
| 301 | +16x | +
+ checkmate::assert_multi_class(data$strata, classes = c("factor", "character"))
+ |
+
| 302 | ++ | + + | +
| 303 | +16x | +
+ data$grp <- as_factor_keep_attributes(data$grp)+ |
+
| 304 | +16x | +
+ data$strata <- as_factor_keep_attributes(data$strata)+ |
+
| 305 | ++ | + + | +
| 306 | ++ |
+ # Deviation from convention: `survival::strata` must be simply `strata`.+ |
+
| 307 | +16x | +
+ formula <- stats::as.formula("rsp ~ grp + strata(strata)")
+ |
+
| 308 | +16x | +
+ model_fit <- clogit_with_tryCatch(formula = formula, data = data)+ |
+
| 309 | ++ | + + | +
| 310 | ++ |
+ # Create a list with one set of OR estimates and CI per coefficient, i.e.+ |
+
| 311 | ++ |
+ # comparison of one group vs. the reference group.+ |
+
| 312 | +16x | +
+ coef_est <- stats::coef(model_fit)+ |
+
| 313 | +16x | +
+ ci_est <- stats::confint(model_fit, level = conf_level)+ |
+
| 314 | +16x | +
+ or_ci <- list()+ |
+
| 315 | +16x | +
+ for (coef_name in names(coef_est)) {
+ |
+
| 316 | +18x | +
+ grp_name <- gsub("^grp", "", x = coef_name)
+ |
+
| 317 | +18x | +
+ or_ci[[grp_name]] <- stats::setNames(+ |
+
| 318 | +18x | +
+ object = exp(c(coef_est[coef_name], ci_est[coef_name, , drop = TRUE])),+ |
+
| 319 | +18x | +
+ nm = c("est", "lcl", "ucl")
+ |
+
| 320 | ++ |
+ )+ |
+
| 321 | ++ |
+ }+ |
+
| 322 | +16x | +
+ list(or_ci = or_ci, n_tot = c(n_tot = model_fit$n))+ |
+
| 323 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Estimation of Proportions+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Estimate the proportion of responders within a studied population.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @seealso [h_proportions]+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @name estimate_proportions+ |
+
| 12 | ++ |
+ NULL+ |
+
| 13 | ++ | + + | +
| 14 | ++ |
+ #' @describeIn estimate_proportions Statistics function estimating a+ |
+
| 15 | ++ |
+ #' proportion along with its confidence interval.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @inheritParams prop_strat_wilson+ |
+
| 18 | ++ |
+ #' @param df (`logical` or `data.frame`)\cr if only a logical vector is used,+ |
+
| 19 | ++ |
+ #' it indicates whether each subject is a responder or not. `TRUE` represents+ |
+
| 20 | ++ |
+ #' a successful outcome. If a `data.frame` is provided, also the `strata` variable+ |
+
| 21 | ++ |
+ #' names must be provided in `variables` as a list element with the strata strings.+ |
+
| 22 | ++ |
+ #' In the case of `data.frame`, the logical vector of responses must be indicated as a+ |
+
| 23 | ++ |
+ #' variable name in `.var`.+ |
+
| 24 | ++ |
+ #' @param method (`string`)\cr the method used to construct the confidence interval+ |
+
| 25 | ++ |
+ #' for proportion of successful outcomes; one of `waldcc`, `wald`, `clopper-pearson`,+ |
+
| 26 | ++ |
+ #' `wilson`, `wilsonc`, `strat_wilson`, `strat_wilsonc`, `agresti-coull` or `jeffreys`.+ |
+
| 27 | ++ |
+ #' @param long (`flag`)\cr a long description is required.+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @return+ |
+
| 30 | ++ |
+ #' * `s_proportion()` returns statistics `n_prop` (`n` and proportion) and `prop_ci` (proportion CI) for a+ |
+
| 31 | ++ |
+ #' given variable.+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' @examples+ |
+
| 34 | ++ |
+ #' # Case with only logical vector.+ |
+
| 35 | ++ |
+ #' rsp_v <- c(1, 0, 1, 0, 1, 1, 0, 0)+ |
+
| 36 | ++ |
+ #' s_proportion(rsp_v)+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' # Example for Stratified Wilson CI+ |
+
| 39 | ++ |
+ #' nex <- 100 # Number of example rows+ |
+
| 40 | ++ |
+ #' dta <- data.frame(+ |
+
| 41 | ++ |
+ #' "rsp" = sample(c(TRUE, FALSE), nex, TRUE),+ |
+
| 42 | ++ |
+ #' "grp" = sample(c("A", "B"), nex, TRUE),
+ |
+
| 43 | ++ |
+ #' "f1" = sample(c("a1", "a2"), nex, TRUE),
+ |
+
| 44 | ++ |
+ #' "f2" = sample(c("x", "y", "z"), nex, TRUE),
+ |
+
| 45 | ++ |
+ #' stringsAsFactors = TRUE+ |
+
| 46 | ++ |
+ #' )+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ #' s_proportion(+ |
+
| 49 | ++ |
+ #' df = dta,+ |
+
| 50 | ++ |
+ #' .var = "rsp",+ |
+
| 51 | ++ |
+ #' variables = list(strata = c("f1", "f2")),
+ |
+
| 52 | ++ |
+ #' conf_level = 0.90,+ |
+
| 53 | ++ |
+ #' method = "strat_wilson"+ |
+
| 54 | ++ |
+ #' )+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' @export+ |
+
| 57 | ++ |
+ s_proportion <- function(df,+ |
+
| 58 | ++ |
+ .var,+ |
+
| 59 | ++ |
+ conf_level = 0.95,+ |
+
| 60 | ++ |
+ method = c(+ |
+
| 61 | ++ |
+ "waldcc", "wald", "clopper-pearson",+ |
+
| 62 | ++ |
+ "wilson", "wilsonc", "strat_wilson", "strat_wilsonc",+ |
+
| 63 | ++ |
+ "agresti-coull", "jeffreys"+ |
+
| 64 | ++ |
+ ),+ |
+
| 65 | ++ |
+ weights = NULL,+ |
+
| 66 | ++ |
+ max_iterations = 50,+ |
+
| 67 | ++ |
+ variables = list(strata = NULL),+ |
+
| 68 | ++ |
+ long = FALSE) {
+ |
+
| 69 | +125x | +
+ method <- match.arg(method)+ |
+
| 70 | +125x | +
+ checkmate::assert_flag(long)+ |
+
| 71 | +125x | +
+ assert_proportion_value(conf_level)+ |
+
| 72 | ++ | + + | +
| 73 | +125x | +
+ if (!is.null(variables$strata)) {
+ |
+
| 74 | ++ |
+ # Checks for strata+ |
+
| 75 | +! | +
+ if (missing(df)) stop("When doing stratified analysis a data.frame with specific columns is needed.")
+ |
+
| 76 | +! | +
+ strata_colnames <- variables$strata+ |
+
| 77 | +! | +
+ checkmate::assert_character(strata_colnames, null.ok = FALSE)+ |
+
| 78 | +! | +
+ strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)+ |
+
| 79 | +! | +
+ assert_df_with_variables(df, strata_vars)+ |
+
| 80 | ++ | + + | +
| 81 | +! | +
+ strata <- interaction(df[strata_colnames])+ |
+
| 82 | +! | +
+ strata <- as.factor(strata)+ |
+
| 83 | ++ | + + | +
| 84 | ++ |
+ # Pushing down checks to prop_strat_wilson+ |
+
| 85 | +125x | +
+ } else if (checkmate::test_subset(method, c("strat_wilson", "strat_wilsonc"))) {
+ |
+
| 86 | +! | +
+ stop("To use stratified methods you need to specify the strata variables.")
+ |
+
| 87 | ++ |
+ }+ |
+
| 88 | +125x | +
+ if (checkmate::test_atomic_vector(df)) {
+ |
+
| 89 | +125x | +
+ rsp <- as.logical(df)+ |
+
| 90 | ++ |
+ } else {
+ |
+
| 91 | +! | +
+ rsp <- as.logical(df[[.var]])+ |
+
| 92 | ++ |
+ }+ |
+
| 93 | +125x | +
+ n <- sum(rsp)+ |
+
| 94 | +125x | +
+ p_hat <- mean(rsp)+ |
+
| 95 | ++ | + + | +
| 96 | +125x | +
+ prop_ci <- switch(method,+ |
+
| 97 | +125x | +
+ "clopper-pearson" = prop_clopper_pearson(rsp, conf_level),+ |
+
| 98 | +125x | +
+ "wilson" = prop_wilson(rsp, conf_level),+ |
+
| 99 | +125x | +
+ "wilsonc" = prop_wilson(rsp, conf_level, correct = TRUE),+ |
+
| 100 | +125x | +
+ "strat_wilson" = prop_strat_wilson(rsp,+ |
+
| 101 | +125x | +
+ strata,+ |
+
| 102 | +125x | +
+ weights,+ |
+
| 103 | +125x | +
+ conf_level,+ |
+
| 104 | +125x | +
+ max_iterations,+ |
+
| 105 | +125x | +
+ correct = FALSE+ |
+
| 106 | +125x | +
+ )$conf_int,+ |
+
| 107 | +125x | +
+ "strat_wilsonc" = prop_strat_wilson(rsp,+ |
+
| 108 | +125x | +
+ strata,+ |
+
| 109 | +125x | +
+ weights,+ |
+
| 110 | +125x | +
+ conf_level,+ |
+
| 111 | +125x | +
+ max_iterations,+ |
+
| 112 | +125x | +
+ correct = TRUE+ |
+
| 113 | +125x | +
+ )$conf_int,+ |
+
| 114 | +125x | +
+ "wald" = prop_wald(rsp, conf_level),+ |
+
| 115 | +125x | +
+ "waldcc" = prop_wald(rsp, conf_level, correct = TRUE),+ |
+
| 116 | +125x | +
+ "agresti-coull" = prop_agresti_coull(rsp, conf_level),+ |
+
| 117 | +125x | +
+ "jeffreys" = prop_jeffreys(rsp, conf_level)+ |
+
| 118 | ++ |
+ )+ |
+
| 119 | ++ | + + | +
| 120 | +125x | +
+ list(+ |
+
| 121 | +125x | +
+ "n_prop" = formatters::with_label(c(n, p_hat), "Responders"),+ |
+
| 122 | +125x | +
+ "prop_ci" = formatters::with_label(+ |
+
| 123 | +125x | +
+ x = 100 * prop_ci, label = d_proportion(conf_level, method, long = long)+ |
+
| 124 | ++ |
+ )+ |
+
| 125 | ++ |
+ )+ |
+
| 126 | ++ |
+ }+ |
+
| 127 | ++ | + + | +
| 128 | ++ |
+ #' @describeIn estimate_proportions Formatted analysis function which is used as `afun`+ |
+
| 129 | ++ |
+ #' in `estimate_proportion()`.+ |
+
| 130 | ++ |
+ #'+ |
+
| 131 | ++ |
+ #' @return+ |
+
| 132 | ++ |
+ #' * `a_proportion()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 133 | ++ |
+ #'+ |
+
| 134 | ++ |
+ #' @export+ |
+
| 135 | ++ |
+ a_proportion <- make_afun(+ |
+
| 136 | ++ |
+ s_proportion,+ |
+
| 137 | ++ |
+ .formats = c(n_prop = "xx (xx.x%)", prop_ci = "(xx.x, xx.x)")+ |
+
| 138 | ++ |
+ )+ |
+
| 139 | ++ | + + | +
| 140 | ++ |
+ #' @describeIn estimate_proportions Layout-creating function which can take statistics function arguments+ |
+
| 141 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 142 | ++ |
+ #'+ |
+
| 143 | ++ |
+ #' @param ... other arguments are ultimately conveyed to [s_proportion()].+ |
+
| 144 | ++ |
+ #'+ |
+
| 145 | ++ |
+ #' @return+ |
+
| 146 | ++ |
+ #' * `estimate_proportion()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 147 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 148 | ++ |
+ #' the statistics from `s_proportion()` to the table layout.+ |
+
| 149 | ++ |
+ #'+ |
+
| 150 | ++ |
+ #' @examples+ |
+
| 151 | ++ |
+ #' dta_test <- data.frame(+ |
+
| 152 | ++ |
+ #' USUBJID = paste0("S", 1:12),
+ |
+
| 153 | ++ |
+ #' ARM = rep(LETTERS[1:3], each = 4),+ |
+
| 154 | ++ |
+ #' AVAL = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0))+ |
+
| 155 | ++ |
+ #' )+ |
+
| 156 | ++ |
+ #'+ |
+
| 157 | ++ |
+ #' basic_table() %>%+ |
+
| 158 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 159 | ++ |
+ #' estimate_proportion(vars = "AVAL") %>%+ |
+
| 160 | ++ |
+ #' build_table(df = dta_test)+ |
+
| 161 | ++ |
+ #'+ |
+
| 162 | ++ |
+ #' @export+ |
+
| 163 | ++ |
+ estimate_proportion <- function(lyt,+ |
+
| 164 | ++ |
+ vars,+ |
+
| 165 | ++ |
+ na_str = NA_character_,+ |
+
| 166 | ++ |
+ nested = TRUE,+ |
+
| 167 | ++ |
+ ...,+ |
+
| 168 | ++ |
+ show_labels = "hidden",+ |
+
| 169 | ++ |
+ table_names = vars,+ |
+
| 170 | ++ |
+ .stats = NULL,+ |
+
| 171 | ++ |
+ .formats = NULL,+ |
+
| 172 | ++ |
+ .labels = NULL,+ |
+
| 173 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 174 | +3x | +
+ afun <- make_afun(+ |
+
| 175 | +3x | +
+ a_proportion,+ |
+
| 176 | +3x | +
+ .stats = .stats,+ |
+
| 177 | +3x | +
+ .formats = .formats,+ |
+
| 178 | +3x | +
+ .labels = .labels,+ |
+
| 179 | +3x | +
+ .indent_mods = .indent_mods+ |
+
| 180 | ++ |
+ )+ |
+
| 181 | +3x | +
+ analyze(+ |
+
| 182 | +3x | +
+ lyt,+ |
+
| 183 | +3x | +
+ vars,+ |
+
| 184 | +3x | +
+ afun = afun,+ |
+
| 185 | +3x | +
+ na_str = na_str,+ |
+
| 186 | +3x | +
+ nested = nested,+ |
+
| 187 | +3x | +
+ extra_args = list(...),+ |
+
| 188 | +3x | +
+ show_labels = show_labels,+ |
+
| 189 | +3x | +
+ table_names = table_names+ |
+
| 190 | ++ |
+ )+ |
+
| 191 | ++ |
+ }+ |
+
| 192 | ++ | + + | +
| 193 | ++ |
+ #' Helper Functions for Calculating Proportion Confidence Intervals+ |
+
| 194 | ++ |
+ #'+ |
+
| 195 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 196 | ++ |
+ #'+ |
+
| 197 | ++ |
+ #' Functions to calculate different proportion confidence intervals for use in [estimate_proportion()].+ |
+
| 198 | ++ |
+ #'+ |
+
| 199 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 200 | ++ |
+ #' @inheritParams estimate_proportions+ |
+
| 201 | ++ |
+ #'+ |
+
| 202 | ++ |
+ #' @return Confidence interval of a proportion.+ |
+
| 203 | ++ |
+ #'+ |
+
| 204 | ++ |
+ #' @seealso [estimate_proportions], descriptive function [d_proportion()],+ |
+
| 205 | ++ |
+ #' and helper functions [strata_normal_quantile()] and [update_weights_strat_wilson()].+ |
+
| 206 | ++ |
+ #'+ |
+
| 207 | ++ |
+ #' @name h_proportions+ |
+
| 208 | ++ |
+ NULL+ |
+
| 209 | ++ | + + | +
| 210 | ++ |
+ #' @describeIn h_proportions Calculates the Wilson interval by calling [stats::prop.test()].+ |
+
| 211 | ++ |
+ #' Also referred to as Wilson score interval.+ |
+
| 212 | ++ |
+ #'+ |
+
| 213 | ++ |
+ #' @examples+ |
+
| 214 | ++ |
+ #' rsp <- c(+ |
+
| 215 | ++ |
+ #' TRUE, TRUE, TRUE, TRUE, TRUE,+ |
+
| 216 | ++ |
+ #' FALSE, FALSE, FALSE, FALSE, FALSE+ |
+
| 217 | ++ |
+ #' )+ |
+
| 218 | ++ |
+ #' prop_wilson(rsp, conf_level = 0.9)+ |
+
| 219 | ++ |
+ #'+ |
+
| 220 | ++ |
+ #' @export+ |
+
| 221 | ++ |
+ prop_wilson <- function(rsp, conf_level, correct = FALSE) {
+ |
+
| 222 | +5x | +
+ y <- stats::prop.test(+ |
+
| 223 | +5x | +
+ sum(rsp),+ |
+
| 224 | +5x | +
+ length(rsp),+ |
+
| 225 | +5x | +
+ correct = correct,+ |
+
| 226 | +5x | +
+ conf.level = conf_level+ |
+
| 227 | ++ |
+ )+ |
+
| 228 | ++ | + + | +
| 229 | +5x | +
+ as.numeric(y$conf.int)+ |
+
| 230 | ++ |
+ }+ |
+
| 231 | ++ | + + | +
| 232 | ++ |
+ #' @describeIn h_proportions Calculates the stratified Wilson confidence+ |
+
| 233 | ++ |
+ #' interval for unequal proportions as described in \insertCite{Yan2010-jt;textual}{tern}
+ |
+
| 234 | ++ |
+ #'+ |
+
| 235 | ++ |
+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.+ |
+
| 236 | ++ |
+ #' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are+ |
+
| 237 | ++ |
+ #' estimated using the iterative algorithm proposed in \insertCite{Yan2010-jt;textual}{tern} that
+ |
+
| 238 | ++ |
+ #' minimizes the weighted squared length of the confidence interval.+ |
+
| 239 | ++ |
+ #' @param max_iterations (`count`)\cr maximum number of iterations for the iterative procedure used+ |
+
| 240 | ++ |
+ #' to find estimates of optimal weights.+ |
+
| 241 | ++ |
+ #' @param correct (`flag`)\cr include the continuity correction. For further information, see for example+ |
+
| 242 | ++ |
+ #' [stats::prop.test()].+ |
+
| 243 | ++ |
+ #'+ |
+
| 244 | ++ |
+ #' @references+ |
+
| 245 | ++ |
+ #' \insertRef{Yan2010-jt}{tern}
+ |
+
| 246 | ++ |
+ #'+ |
+
| 247 | ++ |
+ #' @examples+ |
+
| 248 | ++ |
+ #' # Stratified Wilson confidence interval with unequal probabilities+ |
+
| 249 | ++ |
+ #'+ |
+
| 250 | ++ |
+ #' set.seed(1)+ |
+
| 251 | ++ |
+ #' rsp <- sample(c(TRUE, FALSE), 100, TRUE)+ |
+
| 252 | ++ |
+ #' strata_data <- data.frame(+ |
+
| 253 | ++ |
+ #' "f1" = sample(c("a", "b"), 100, TRUE),
+ |
+
| 254 | ++ |
+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ |
+
| 255 | ++ |
+ #' stringsAsFactors = TRUE+ |
+
| 256 | ++ |
+ #' )+ |
+
| 257 | ++ |
+ #' strata <- interaction(strata_data)+ |
+
| 258 | ++ |
+ #' n_strata <- ncol(table(rsp, strata)) # Number of strata+ |
+
| 259 | ++ |
+ #'+ |
+
| 260 | ++ |
+ #' prop_strat_wilson(+ |
+
| 261 | ++ |
+ #' rsp = rsp, strata = strata,+ |
+
| 262 | ++ |
+ #' conf_level = 0.90+ |
+
| 263 | ++ |
+ #' )+ |
+
| 264 | ++ |
+ #'+ |
+
| 265 | ++ |
+ #' # Not automatic setting of weights+ |
+
| 266 | ++ |
+ #' prop_strat_wilson(+ |
+
| 267 | ++ |
+ #' rsp = rsp, strata = strata,+ |
+
| 268 | ++ |
+ #' weights = rep(1 / n_strata, n_strata),+ |
+
| 269 | ++ |
+ #' conf_level = 0.90+ |
+
| 270 | ++ |
+ #' )+ |
+
| 271 | ++ |
+ #'+ |
+
| 272 | ++ |
+ #' @export+ |
+
| 273 | ++ |
+ prop_strat_wilson <- function(rsp,+ |
+
| 274 | ++ |
+ strata,+ |
+
| 275 | ++ |
+ weights = NULL,+ |
+
| 276 | ++ |
+ conf_level = 0.95,+ |
+
| 277 | ++ |
+ max_iterations = NULL,+ |
+
| 278 | ++ |
+ correct = FALSE) {
+ |
+
| 279 | +20x | +
+ checkmate::assert_logical(rsp, any.missing = FALSE)+ |
+
| 280 | +20x | +
+ checkmate::assert_factor(strata, len = length(rsp))+ |
+
| 281 | +20x | +
+ assert_proportion_value(conf_level)+ |
+
| 282 | ++ | + + | +
| 283 | +20x | +
+ tbl <- table(rsp, strata)+ |
+
| 284 | +20x | +
+ n_strata <- length(unique(strata))+ |
+
| 285 | ++ | + + | +
| 286 | ++ |
+ # Checking the weights and maximum number of iterations.+ |
+
| 287 | +20x | +
+ do_iter <- FALSE+ |
+
| 288 | +20x | +
+ if (is.null(weights)) {
+ |
+
| 289 | +6x | +
+ weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure+ |
+
| 290 | +6x | +
+ do_iter <- TRUE+ |
+
| 291 | ++ | + + | +
| 292 | ++ |
+ # Iteration parameters+ |
+
| 293 | +2x | +
+ if (is.null(max_iterations)) max_iterations <- 10+ |
+
| 294 | +6x | +
+ checkmate::assert_int(max_iterations, na.ok = FALSE, null.ok = FALSE, lower = 1)+ |
+
| 295 | ++ |
+ }+ |
+
| 296 | +20x | +
+ checkmate::assert_numeric(weights, lower = 0, upper = 1, any.missing = FALSE, len = n_strata)+ |
+
| 297 | +20x | +
+ sum_weights <- checkmate::assert_int(sum(weights))+ |
+
| 298 | +! | +
+ if (as.integer(sum_weights + 0.5) != 1L) stop("Sum of weights must be 1L.")
+ |
+
| 299 | ++ | + + | +
| 300 | ++ | + + | +
| 301 | +20x | +
+ xs <- tbl["TRUE", ]+ |
+
| 302 | +20x | +
+ ns <- colSums(tbl)+ |
+
| 303 | +20x | +
+ use_stratum <- (ns > 0)+ |
+
| 304 | +20x | +
+ ns <- ns[use_stratum]+ |
+
| 305 | +20x | +
+ xs <- xs[use_stratum]+ |
+
| 306 | +20x | +
+ ests <- xs / ns+ |
+
| 307 | +20x | +
+ vars <- ests * (1 - ests) / ns+ |
+
| 308 | ++ | + + | +
| 309 | +20x | +
+ strata_qnorm <- strata_normal_quantile(vars, weights, conf_level)+ |
+
| 310 | ++ | + + | +
| 311 | ++ |
+ # Iterative setting of weights if they were not set externally+ |
+
| 312 | +20x | +
+ weights_new <- if (do_iter) {
+ |
+
| 313 | +6x | +
+ update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max_iterations, conf_level)$weights+ |
+
| 314 | ++ |
+ } else {
+ |
+
| 315 | +14x | +
+ weights+ |
+
| 316 | ++ |
+ }+ |
+
| 317 | ++ | + + | +
| 318 | +20x | +
+ strata_conf_level <- 2 * stats::pnorm(strata_qnorm) - 1+ |
+
| 319 | ++ | + + | +
| 320 | +20x | +
+ ci_by_strata <- Map(+ |
+
| 321 | +20x | +
+ function(x, n) {
+ |
+
| 322 | ++ |
+ # Classic Wilson's confidence interval+ |
+
| 323 | +139x | +
+ suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf_level)$conf.int)+ |
+
| 324 | ++ |
+ },+ |
+
| 325 | +20x | +
+ x = xs,+ |
+
| 326 | +20x | +
+ n = ns+ |
+
| 327 | ++ |
+ )+ |
+
| 328 | +20x | +
+ lower_by_strata <- sapply(ci_by_strata, "[", 1L)+ |
+
| 329 | +20x | +
+ upper_by_strata <- sapply(ci_by_strata, "[", 2L)+ |
+
| 330 | ++ | + + | +
| 331 | +20x | +
+ lower <- sum(weights_new * lower_by_strata)+ |
+
| 332 | +20x | +
+ upper <- sum(weights_new * upper_by_strata)+ |
+
| 333 | ++ | + + | +
| 334 | ++ |
+ # Return values+ |
+
| 335 | +20x | +
+ if (do_iter) {
+ |
+
| 336 | +6x | +
+ list(+ |
+
| 337 | +6x | +
+ conf_int = c(+ |
+
| 338 | +6x | +
+ lower = lower,+ |
+
| 339 | +6x | +
+ upper = upper+ |
+
| 340 | ++ |
+ ),+ |
+
| 341 | +6x | +
+ weights = weights_new+ |
+
| 342 | ++ |
+ )+ |
+
| 343 | ++ |
+ } else {
+ |
+
| 344 | +14x | +
+ list(+ |
+
| 345 | +14x | +
+ conf_int = c(+ |
+
| 346 | +14x | +
+ lower = lower,+ |
+
| 347 | +14x | +
+ upper = upper+ |
+
| 348 | ++ |
+ )+ |
+
| 349 | ++ |
+ )+ |
+
| 350 | ++ |
+ }+ |
+
| 351 | ++ |
+ }+ |
+
| 352 | ++ | + + | +
| 353 | ++ |
+ #' @describeIn h_proportions Calculates the Clopper-Pearson interval by calling [stats::binom.test()].+ |
+
| 354 | ++ |
+ #' Also referred to as the `exact` method.+ |
+
| 355 | ++ |
+ #'+ |
+
| 356 | ++ |
+ #' @examples+ |
+
| 357 | ++ |
+ #' prop_clopper_pearson(rsp, conf_level = .95)+ |
+
| 358 | ++ |
+ #'+ |
+
| 359 | ++ |
+ #' @export+ |
+
| 360 | ++ |
+ prop_clopper_pearson <- function(rsp,+ |
+
| 361 | ++ |
+ conf_level) {
+ |
+
| 362 | +1x | +
+ y <- stats::binom.test(+ |
+
| 363 | +1x | +
+ x = sum(rsp),+ |
+
| 364 | +1x | +
+ n = length(rsp),+ |
+
| 365 | +1x | +
+ conf.level = conf_level+ |
+
| 366 | ++ |
+ )+ |
+
| 367 | +1x | +
+ as.numeric(y$conf.int)+ |
+
| 368 | ++ |
+ }+ |
+
| 369 | ++ | + + | +
| 370 | ++ |
+ #' @describeIn h_proportions Calculates the Wald interval by following the usual textbook definition+ |
+
| 371 | ++ |
+ #' for a single proportion confidence interval using the normal approximation.+ |
+
| 372 | ++ |
+ #'+ |
+
| 373 | ++ |
+ #' @param correct (`flag`)\cr apply continuity correction.+ |
+
| 374 | ++ |
+ #'+ |
+
| 375 | ++ |
+ #' @examples+ |
+
| 376 | ++ |
+ #' prop_wald(rsp, conf_level = 0.95)+ |
+
| 377 | ++ |
+ #' prop_wald(rsp, conf_level = 0.95, correct = TRUE)+ |
+
| 378 | ++ |
+ #'+ |
+
| 379 | ++ |
+ #' @export+ |
+
| 380 | ++ |
+ prop_wald <- function(rsp, conf_level, correct = FALSE) {
+ |
+
| 381 | +122x | +
+ n <- length(rsp)+ |
+
| 382 | +122x | +
+ p_hat <- mean(rsp)+ |
+
| 383 | +122x | +
+ z <- stats::qnorm((1 + conf_level) / 2)+ |
+
| 384 | +122x | +
+ q_hat <- 1 - p_hat+ |
+
| 385 | +122x | +
+ correct <- if (correct) 1 / (2 * n) else 0+ |
+
| 386 | ++ | + + | +
| 387 | +122x | +
+ err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correct+ |
+
| 388 | +122x | +
+ l_ci <- max(0, p_hat - err)+ |
+
| 389 | +122x | +
+ u_ci <- min(1, p_hat + err)+ |
+
| 390 | ++ | + + | +
| 391 | +122x | +
+ c(l_ci, u_ci)+ |
+
| 392 | ++ |
+ }+ |
+
| 393 | ++ | + + | +
| 394 | ++ |
+ #' @describeIn h_proportions Calculates the `Agresti-Coull` interval (created by `Alan Agresti` and `Brent Coull`) by+ |
+
| 395 | ++ |
+ #' (for 95% CI) adding two successes and two failures to the data and then using the Wald formula to construct a CI.+ |
+
| 396 | ++ |
+ #'+ |
+
| 397 | ++ |
+ #' @examples+ |
+
| 398 | ++ |
+ #' prop_agresti_coull(rsp, conf_level = 0.95)+ |
+
| 399 | ++ |
+ #'+ |
+
| 400 | ++ |
+ #' @export+ |
+
| 401 | ++ |
+ prop_agresti_coull <- function(rsp, conf_level) {
+ |
+
| 402 | +2x | +
+ n <- length(rsp)+ |
+
| 403 | +2x | +
+ x_sum <- sum(rsp)+ |
+
| 404 | +2x | +
+ z <- stats::qnorm((1 + conf_level) / 2)+ |
+
| 405 | ++ | + + | +
| 406 | ++ |
+ # Add here both z^2 / 2 successes and failures.+ |
+
| 407 | +2x | +
+ x_sum_tilde <- x_sum + z^2 / 2+ |
+
| 408 | +2x | +
+ n_tilde <- n + z^2+ |
+
| 409 | ++ | + + | +
| 410 | ++ |
+ # Then proceed as with the Wald interval.+ |
+
| 411 | +2x | +
+ p_tilde <- x_sum_tilde / n_tilde+ |
+
| 412 | +2x | +
+ q_tilde <- 1 - p_tilde+ |
+
| 413 | +2x | +
+ err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)+ |
+
| 414 | +2x | +
+ l_ci <- max(0, p_tilde - err)+ |
+
| 415 | +2x | +
+ u_ci <- min(1, p_tilde + err)+ |
+
| 416 | ++ | + + | +
| 417 | +2x | +
+ c(l_ci, u_ci)+ |
+
| 418 | ++ |
+ }+ |
+
| 419 | ++ | + + | +
| 420 | ++ |
+ #' @describeIn h_proportions Calculates the Jeffreys interval, an equal-tailed interval based on the+ |
+
| 421 | ++ |
+ #' non-informative Jeffreys prior for a binomial proportion.+ |
+
| 422 | ++ |
+ #'+ |
+
| 423 | ++ |
+ #' @examples+ |
+
| 424 | ++ |
+ #' prop_jeffreys(rsp, conf_level = 0.95)+ |
+
| 425 | ++ |
+ #'+ |
+
| 426 | ++ |
+ #' @export+ |
+
| 427 | ++ |
+ prop_jeffreys <- function(rsp,+ |
+
| 428 | ++ |
+ conf_level) {
+ |
+
| 429 | +4x | +
+ n <- length(rsp)+ |
+
| 430 | +4x | +
+ x_sum <- sum(rsp)+ |
+
| 431 | ++ | + + | +
| 432 | +4x | +
+ alpha <- 1 - conf_level+ |
+
| 433 | +4x | +
+ l_ci <- ifelse(+ |
+
| 434 | +4x | +
+ x_sum == 0,+ |
+
| 435 | +4x | +
+ 0,+ |
+
| 436 | +4x | +
+ stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ |
+
| 437 | ++ |
+ )+ |
+
| 438 | ++ | + + | +
| 439 | +4x | +
+ u_ci <- ifelse(+ |
+
| 440 | +4x | +
+ x_sum == n,+ |
+
| 441 | +4x | +
+ 1,+ |
+
| 442 | +4x | +
+ stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ |
+
| 443 | ++ |
+ )+ |
+
| 444 | ++ | + + | +
| 445 | +4x | +
+ c(l_ci, u_ci)+ |
+
| 446 | ++ |
+ }+ |
+
| 447 | ++ | + + | +
| 448 | ++ |
+ #' Description of the Proportion Summary+ |
+
| 449 | ++ |
+ #'+ |
+
| 450 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 451 | ++ |
+ #'+ |
+
| 452 | ++ |
+ #' This is a helper function that describes the analysis in [s_proportion()].+ |
+
| 453 | ++ |
+ #'+ |
+
| 454 | ++ |
+ #' @inheritParams s_proportion+ |
+
| 455 | ++ |
+ #' @param long (`flag`)\cr whether a long or a short (default) description is required.+ |
+
| 456 | ++ |
+ #'+ |
+
| 457 | ++ |
+ #' @return String describing the analysis.+ |
+
| 458 | ++ |
+ #'+ |
+
| 459 | ++ |
+ #' @export+ |
+
| 460 | ++ |
+ d_proportion <- function(conf_level,+ |
+
| 461 | ++ |
+ method,+ |
+
| 462 | ++ |
+ long = FALSE) {
+ |
+
| 463 | +137x | +
+ label <- paste0(conf_level * 100, "% CI")+ |
+
| 464 | ++ | + + | +
| 465 | +! | +
+ if (long) label <- paste(label, "for Response Rates")+ |
+
| 466 | ++ | + + | +
| 467 | +137x | +
+ method_part <- switch(method,+ |
+
| 468 | +137x | +
+ "clopper-pearson" = "Clopper-Pearson",+ |
+
| 469 | +137x | +
+ "waldcc" = "Wald, with correction",+ |
+
| 470 | +137x | +
+ "wald" = "Wald, without correction",+ |
+
| 471 | +137x | +
+ "wilson" = "Wilson, without correction",+ |
+
| 472 | +137x | +
+ "strat_wilson" = "Stratified Wilson, without correction",+ |
+
| 473 | +137x | +
+ "wilsonc" = "Wilson, with correction",+ |
+
| 474 | +137x | +
+ "strat_wilsonc" = "Stratified Wilson, with correction",+ |
+
| 475 | +137x | +
+ "agresti-coull" = "Agresti-Coull",+ |
+
| 476 | +137x | +
+ "jeffreys" = "Jeffreys",+ |
+
| 477 | +137x | +
+ stop(paste(method, "does not have a description"))+ |
+
| 478 | ++ |
+ )+ |
+
| 479 | ++ | + + | +
| 480 | +137x | +
+ paste0(label, " (", method_part, ")")
+ |
+
| 481 | ++ |
+ }+ |
+
| 482 | ++ | + + | +
| 483 | ++ |
+ #' Helper Function for the Estimation of Stratified Quantiles+ |
+
| 484 | ++ |
+ #'+ |
+
| 485 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 486 | ++ |
+ #'+ |
+
| 487 | ++ |
+ #' This function wraps the estimation of stratified percentiles when we assume+ |
+
| 488 | ++ |
+ #' the approximation for large numbers. This is necessary only in the case+ |
+
| 489 | ++ |
+ #' proportions for each strata are unequal.+ |
+
| 490 | ++ |
+ #'+ |
+
| 491 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 492 | ++ |
+ #' @inheritParams prop_strat_wilson+ |
+
| 493 | ++ |
+ #'+ |
+
| 494 | ++ |
+ #' @return Stratified quantile.+ |
+
| 495 | ++ |
+ #'+ |
+
| 496 | ++ |
+ #' @seealso [prop_strat_wilson()]+ |
+
| 497 | ++ |
+ #'+ |
+
| 498 | ++ |
+ #' @examples+ |
+
| 499 | ++ |
+ #' strata_data <- table(data.frame(+ |
+
| 500 | ++ |
+ #' "f1" = sample(c(TRUE, FALSE), 100, TRUE),+ |
+
| 501 | ++ |
+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ |
+
| 502 | ++ |
+ #' stringsAsFactors = TRUE+ |
+
| 503 | ++ |
+ #' ))+ |
+
| 504 | ++ |
+ #' ns <- colSums(strata_data)+ |
+
| 505 | ++ |
+ #' ests <- strata_data["TRUE", ] / ns+ |
+
| 506 | ++ |
+ #' vars <- ests * (1 - ests) / ns+ |
+
| 507 | ++ |
+ #' weights <- rep(1 / length(ns), length(ns))+ |
+
| 508 | ++ |
+ #' strata_normal_quantile(vars, weights, 0.95)+ |
+
| 509 | ++ |
+ #'+ |
+
| 510 | ++ |
+ #' @export+ |
+
| 511 | ++ |
+ strata_normal_quantile <- function(vars, weights, conf_level) {
+ |
+
| 512 | +41x | +
+ summands <- weights^2 * vars+ |
+
| 513 | ++ |
+ # Stratified quantile+ |
+
| 514 | +41x | +
+ sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf_level) / 2)+ |
+
| 515 | ++ |
+ }+ |
+
| 516 | ++ | + + | +
| 517 | ++ |
+ #' Helper Function for the Estimation of Weights for `prop_strat_wilson`+ |
+
| 518 | ++ |
+ #'+ |
+
| 519 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 520 | ++ |
+ #'+ |
+
| 521 | ++ |
+ #' This function wraps the iteration procedure that allows you to estimate+ |
+
| 522 | ++ |
+ #' the weights for each proportional strata. This assumes to minimize the+ |
+
| 523 | ++ |
+ #' weighted squared length of the confidence interval.+ |
+
| 524 | ++ |
+ #'+ |
+
| 525 | ++ |
+ #' @inheritParams prop_strat_wilson+ |
+
| 526 | ++ |
+ #' @param vars (`numeric`)\cr normalized proportions for each strata.+ |
+
| 527 | ++ |
+ #' @param strata_qnorm (`numeric`)\cr initial estimation with identical weights of the quantiles.+ |
+
| 528 | ++ |
+ #' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can+ |
+
| 529 | ++ |
+ #' be optimized in the future if we need to estimate better initial weights.+ |
+
| 530 | ++ |
+ #' @param n_per_strata (`numeric`)\cr number of elements in each strata.+ |
+
| 531 | ++ |
+ #' @param max_iterations (`count`)\cr maximum number of iterations to be tried. Convergence is always checked.+ |
+
| 532 | ++ |
+ #' @param tol (`number`)\cr tolerance threshold for convergence.+ |
+
| 533 | ++ |
+ #'+ |
+
| 534 | ++ |
+ #' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`.+ |
+
| 535 | ++ |
+ #'+ |
+
| 536 | ++ |
+ #' @seealso For references and details see [prop_strat_wilson()].+ |
+
| 537 | ++ |
+ #'+ |
+
| 538 | ++ |
+ #' @examples+ |
+
| 539 | ++ |
+ #' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018)+ |
+
| 540 | ++ |
+ #' sq <- 0.674+ |
+
| 541 | ++ |
+ #' ws <- rep(1 / length(vs), length(vs))+ |
+
| 542 | ++ |
+ #' ns <- c(22, 18, 17, 17, 14, 12)+ |
+
| 543 | ++ |
+ #'+ |
+
| 544 | ++ |
+ #' update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001)+ |
+
| 545 | ++ |
+ #'+ |
+
| 546 | ++ |
+ #' @export+ |
+
| 547 | ++ |
+ update_weights_strat_wilson <- function(vars,+ |
+
| 548 | ++ |
+ strata_qnorm,+ |
+
| 549 | ++ |
+ initial_weights,+ |
+
| 550 | ++ |
+ n_per_strata,+ |
+
| 551 | ++ |
+ max_iterations = 50,+ |
+
| 552 | ++ |
+ conf_level = 0.95,+ |
+
| 553 | ++ |
+ tol = 0.001) {
+ |
+
| 554 | +8x | +
+ it <- 0+ |
+
| 555 | +8x | +
+ diff_v <- NULL+ |
+
| 556 | ++ | + + | +
| 557 | +8x | +
+ while (it < max_iterations) {
+ |
+
| 558 | +19x | +
+ it <- it + 1+ |
+
| 559 | +19x | +
+ weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2+ |
+
| 560 | +19x | +
+ weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2))+ |
+
| 561 | +19x | +
+ weights_new <- weights_new_t / weights_new_b+ |
+
| 562 | +19x | +
+ weights_new <- weights_new / sum(weights_new)+ |
+
| 563 | +19x | +
+ strata_qnorm <- strata_normal_quantile(vars, weights_new, conf_level)+ |
+
| 564 | +19x | +
+ diff_v <- c(diff_v, sum(abs(weights_new - initial_weights)))+ |
+
| 565 | +8x | +
+ if (diff_v[length(diff_v)] < tol) break+ |
+
| 566 | +11x | +
+ initial_weights <- weights_new+ |
+
| 567 | ++ |
+ }+ |
+
| 568 | ++ | + + | +
| 569 | +8x | +
+ if (it == max_iterations) {
+ |
+
| 570 | +! | +
+ warning("The heuristic to find weights did not converge with max_iterations = ", max_iterations)
+ |
+
| 571 | ++ |
+ }+ |
+
| 572 | ++ | + + | +
| 573 | +8x | +
+ list(+ |
+
| 574 | +8x | +
+ "n_it" = it,+ |
+
| 575 | +8x | +
+ "weights" = weights_new,+ |
+
| 576 | +8x | +
+ "diff_v" = diff_v+ |
+
| 577 | ++ |
+ )+ |
+
| 578 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Encode Categorical Missing Values in a Data Frame+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' This is a helper function to encode missing entries across groups of categorical+ |
+
| 6 | ++ |
+ #' variables in a data frame.+ |
+
| 7 | ++ |
+ #'+ |
+
| 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+ |
+
| 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 | ++ |
+ #' with the `char_as_factor` or `logical_as_factor` options, the missing values will+ |
+
| 13 | ++ |
+ #' be set as the last level.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @param data (`data.frame`)\cr data set.+ |
+
| 16 | ++ |
+ #' @param omit_columns (`character`)\cr names of variables from `data` that should+ |
+
| 17 | ++ |
+ #' not be modified by this function.+ |
+
| 18 | ++ |
+ #' @param char_as_factor (`flag`)\cr whether to convert character variables+ |
+
| 19 | ++ |
+ #' in `data` to factors.+ |
+
| 20 | ++ |
+ #' @param logical_as_factor (`flag`)\cr whether to convert logical variables+ |
+
| 21 | ++ |
+ #' in `data` to factors.+ |
+
| 22 | ++ |
+ #' @param na_level (`string`)\cr used to replace all `NA` or empty+ |
+
| 23 | ++ |
+ #' values inside non-`omit_columns` columns.+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @return A `data.frame` with the chosen modifications applied.+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' @seealso [sas_na()] and [explicit_na()] for other missing data helper functions.+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @examples+ |
+
| 30 | ++ |
+ #' my_data <- data.frame(+ |
+
| 31 | ++ |
+ #' u = c(TRUE, FALSE, NA, TRUE),+ |
+
| 32 | ++ |
+ #' v = factor(c("A", NA, NA, NA), levels = c("Z", "A")),
+ |
+
| 33 | ++ |
+ #' w = c("A", "B", NA, "C"),
+ |
+
| 34 | ++ |
+ #' x = c("D", "E", "F", NA),
+ |
+
| 35 | ++ |
+ #' y = c("G", "H", "I", ""),
+ |
+
| 36 | ++ |
+ #' z = c(1, 2, 3, 4),+ |
+
| 37 | ++ |
+ #' stringsAsFactors = FALSE+ |
+
| 38 | ++ |
+ #' )+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' # Example 1+ |
+
| 41 | ++ |
+ #' # Encode missing values in all character or factor columns.+ |
+
| 42 | ++ |
+ #' df_explicit_na(my_data)+ |
+
| 43 | ++ |
+ #' # Also convert logical columns to factor columns.+ |
+
| 44 | ++ |
+ #' df_explicit_na(my_data, logical_as_factor = TRUE)+ |
+
| 45 | ++ |
+ #' # Encode missing values in a subset of columns.+ |
+
| 46 | ++ |
+ #' df_explicit_na(my_data, omit_columns = c("x", "y"))
+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ #' # Example 2+ |
+
| 49 | ++ |
+ #' # Here we purposefully convert all `M` values to `NA` in the `SEX` variable.+ |
+
| 50 | ++ |
+ #' # After running `df_explicit_na` the `NA` values are encoded as `<Missing>` but they are not+ |
+
| 51 | ++ |
+ #' # included when generating `rtables`.+ |
+
| 52 | ++ |
+ #' adsl <- tern_ex_adsl+ |
+
| 53 | ++ |
+ #' adsl$SEX[adsl$SEX == "M"] <- NA+ |
+
| 54 | ++ |
+ #' adsl <- df_explicit_na(adsl)+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' # If you want the `Na` values to be displayed in the table use the `na_level` argument.+ |
+
| 57 | ++ |
+ #' adsl <- tern_ex_adsl+ |
+
| 58 | ++ |
+ #' adsl$SEX[adsl$SEX == "M"] <- NA+ |
+
| 59 | ++ |
+ #' adsl <- df_explicit_na(adsl, na_level = "Missing Values")+ |
+
| 60 | ++ |
+ #'+ |
+
| 61 | ++ |
+ #' # Example 3+ |
+
| 62 | ++ |
+ #' # Numeric variables that have missing values are not altered. This means that any `NA` value in+ |
+
| 63 | ++ |
+ #' # a numeric variable will not be included in the summary statistics, nor will they be included+ |
+
| 64 | ++ |
+ #' # in the denominator value for calculating the percent values.+ |
+
| 65 | ++ |
+ #' adsl <- tern_ex_adsl+ |
+
| 66 | ++ |
+ #' adsl$AGE[adsl$AGE < 30] <- NA+ |
+
| 67 | ++ |
+ #' adsl <- df_explicit_na(adsl)+ |
+
| 68 | ++ |
+ #'+ |
+
| 69 | ++ |
+ #' @export+ |
+
| 70 | ++ |
+ df_explicit_na <- function(data,+ |
+
| 71 | ++ |
+ omit_columns = NULL,+ |
+
| 72 | ++ |
+ char_as_factor = TRUE,+ |
+
| 73 | ++ |
+ logical_as_factor = FALSE,+ |
+
| 74 | ++ |
+ na_level = "<Missing>") {
+ |
+
| 75 | +22x | +
+ checkmate::assert_character(omit_columns, null.ok = TRUE, min.len = 1, any.missing = FALSE)+ |
+
| 76 | +21x | +
+ checkmate::assert_data_frame(data)+ |
+
| 77 | +20x | +
+ checkmate::assert_flag(char_as_factor)+ |
+
| 78 | +19x | +
+ checkmate::assert_flag(logical_as_factor)+ |
+
| 79 | +19x | +
+ checkmate::assert_string(na_level)+ |
+
| 80 | ++ | + + | +
| 81 | +17x | +
+ target_vars <- if (is.null(omit_columns)) {
+ |
+
| 82 | +15x | +
+ names(data)+ |
+
| 83 | ++ |
+ } else {
+ |
+
| 84 | +2x | +
+ setdiff(names(data), omit_columns) # May have duplicates.+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | +17x | +
+ if (length(target_vars) == 0) {
+ |
+
| 87 | +1x | +
+ return(data)+ |
+
| 88 | ++ |
+ }+ |
+
| 89 | ++ | + + | +
| 90 | +16x | +
+ l_target_vars <- split(target_vars, target_vars)+ |
+
| 91 | ++ | + + | +
| 92 | ++ |
+ # Makes sure target_vars exist in data and names are not duplicated.+ |
+
| 93 | +16x | +
+ assert_df_with_variables(data, l_target_vars)+ |
+
| 94 | ++ | + + | +
| 95 | +16x | +
+ for (x in target_vars) {
+ |
+
| 96 | +304x | +
+ xi <- data[[x]]+ |
+
| 97 | +304x | +
+ xi_label <- obj_label(xi)+ |
+
| 98 | ++ | + + | +
| 99 | ++ |
+ # Determine whether to convert character or logical input.+ |
+
| 100 | +304x | +
+ do_char_conversion <- is.character(xi) && char_as_factor+ |
+
| 101 | +304x | +
+ do_logical_conversion <- is.logical(xi) && logical_as_factor+ |
+
| 102 | ++ | + + | +
| 103 | ++ |
+ # Pre-convert logical to character to deal correctly with replacing NA+ |
+
| 104 | ++ |
+ # values below.+ |
+
| 105 | +304x | +
+ if (do_logical_conversion) {
+ |
+
| 106 | +2x | +
+ xi <- as.character(xi)+ |
+
| 107 | ++ |
+ }+ |
+
| 108 | ++ | + + | +
| 109 | +304x | +
+ if (is.factor(xi) || is.character(xi)) {
+ |
+
| 110 | ++ |
+ # Handle empty strings and NA values.+ |
+
| 111 | +217x | +
+ xi <- explicit_na(sas_na(xi), label = na_level)+ |
+
| 112 | ++ | + + | +
| 113 | ++ |
+ # Convert to factors if requested for the original type,+ |
+
| 114 | ++ |
+ # set na_level as the last value.+ |
+
| 115 | +217x | +
+ 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 | +217x | +
+ data[, x] <- formatters::with_label(xi, label = xi_label)+ |
+
| 125 | ++ |
+ }+ |
+
| 126 | ++ |
+ }+ |
+
| 127 | +16x | +
+ return(data)+ |
+
| 128 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Defaults for statistical method names and their associated formats & labels+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("experimental")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Utility functions to get valid statistic methods for different method groups+ |
+
| 6 | ++ |
+ #' (`.stats`) and their associated formats (`.formats`) and labels (`.labels`). This utility+ |
+
| 7 | ++ |
+ #' is used across `tern`, but some of its working principles can be seen in [analyze_vars()].+ |
+
| 8 | ++ |
+ #' See notes to understand why this is experimental.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @param stats (`character`)\cr statistical methods to get defaults formats or labels for.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @details+ |
+
| 13 | ++ |
+ #' Current choices for `type` are `counts` and `numeric` for [analyze_vars()] and affect `get_stats()`.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @note+ |
+
| 16 | ++ |
+ #' These defaults are experimental because we use the names of functions to retrieve the default+ |
+
| 17 | ++ |
+ #' statistics. This should be generalized in groups of methods according to more reasonable groupings.+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @name default_stats_formats_labels+ |
+
| 20 | ++ |
+ NULL+ |
+
| 21 | ++ | + + | +
| 22 | ++ |
+ #' @describeIn default_stats_formats_labels Get defaults statistical methods for different+ |
+
| 23 | ++ |
+ #' groups of methods.+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @param method_groups (`character`)\cr indicates the group of statistical methods that+ |
+
| 26 | ++ |
+ #' we need the defaults from. A character vector can be used to collect more than one group of statistical+ |
+
| 27 | ++ |
+ #' methods.+ |
+
| 28 | ++ |
+ #' @param stats_in (`character`)\cr desired stats to be picked out from the selected method group.+ |
+
| 29 | ++ |
+ #' @param add_pval (`flag`)\cr should `"pval"` or `"pval_counts"` (if `method_groups` contains+ |
+
| 30 | ++ |
+ #' `"analyze_vars_counts"`) be added to the statistical methods?+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @return+ |
+
| 33 | ++ |
+ #' * `get_stats()` returns a character vector with all default statistical methods.+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' @examples+ |
+
| 36 | ++ |
+ #' # analyze_vars is numeric+ |
+
| 37 | ++ |
+ #' num_stats <- get_stats("analyze_vars_numeric") # also the default
+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' # Other type+ |
+
| 40 | ++ |
+ #' cnt_stats <- get_stats("analyze_vars_counts")
+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' # Weirdly taking the pval from count_occurrences+ |
+
| 43 | ++ |
+ #' only_pval <- get_stats("count_occurrences", add_pval = TRUE, stats_in = "pval")
+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' # All count_occurrences+ |
+
| 46 | ++ |
+ #' all_cnt_occ <- get_stats("count_occurrences")
+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ #' # Multiple+ |
+
| 49 | ++ |
+ #' get_stats(c("count_occurrences", "analyze_vars_counts"))
+ |
+
| 50 | ++ |
+ #'+ |
+
| 51 | ++ |
+ #' @export+ |
+
| 52 | ++ |
+ get_stats <- function(method_groups = "analyze_vars_numeric", stats_in = NULL, add_pval = FALSE) {
+ |
+
| 53 | +323x | +
+ checkmate::assert_character(method_groups)+ |
+
| 54 | +323x | +
+ checkmate::assert_character(stats_in, null.ok = TRUE)+ |
+
| 55 | +323x | +
+ checkmate::assert_flag(add_pval)+ |
+
| 56 | ++ | + + | +
| 57 | ++ |
+ # Default is still numeric+ |
+
| 58 | +323x | +
+ if (any(method_groups == "analyze_vars")) {
+ |
+
| 59 | +2x | +
+ method_groups[method_groups == "analyze_vars"] <- "analyze_vars_numeric"+ |
+
| 60 | ++ |
+ }+ |
+
| 61 | ++ | + + | +
| 62 | +323x | +
+ type_tmp <- ifelse(any(grepl("counts", method_groups)), "counts", "numeric") # for pval checks
+ |
+
| 63 | ++ | + + | +
| 64 | ++ |
+ # Defaults for loop+ |
+
| 65 | +323x | +
+ out <- NULL+ |
+
| 66 | ++ | + + | +
| 67 | ++ |
+ # Loop for multiple method groups+ |
+
| 68 | +323x | +
+ for (mgi in method_groups) {
+ |
+
| 69 | ++ |
+ # Main switcher+ |
+
| 70 | +333x | +
+ out_tmp <- switch(mgi,+ |
+
| 71 | +333x | +
+ "count_occurrences" = c("count", "count_fraction_fixed_dp", "fraction"),
+ |
+
| 72 | +333x | +
+ "summarize_num_patients" = c("unique", "nonunique", "unique_count"),
+ |
+
| 73 | +333x | +
+ "analyze_vars_counts" = c("n", "count", "count_fraction", "n_blq"),
+ |
+
| 74 | +333x | +
+ "analyze_vars_numeric" = c(+ |
+
| 75 | +333x | +
+ "n", "sum", "mean", "sd", "se", "mean_sd", "mean_se", "mean_ci", "mean_sei",+ |
+
| 76 | +333x | +
+ "mean_sdi", "mean_pval", "median", "mad", "median_ci", "quantiles", "iqr",+ |
+
| 77 | +333x | +
+ "range", "min", "max", "median_range", "cv", "geom_mean", "geom_mean_ci",+ |
+
| 78 | +333x | +
+ "geom_cv"+ |
+
| 79 | ++ |
+ ),+ |
+
| 80 | +333x | +
+ stop(+ |
+
| 81 | +333x | +
+ "The selected method group (", mgi, ") has no default statistical method."
+ |
+
| 82 | ++ |
+ )+ |
+
| 83 | ++ |
+ )+ |
+
| 84 | +333x | +
+ out <- unique(c(out, out_tmp))+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | ++ | + + | +
| 87 | ++ |
+ # If you added pval to the stats_in you certainly want it+ |
+
| 88 | +323x | +
+ if (!is.null(stats_in) && any(grepl("^pval", stats_in))) {
+ |
+
| 89 | +21x | +
+ stats_in_pval_value <- stats_in[grepl("^pval", stats_in)]
+ |
+
| 90 | ++ | + + | +
| 91 | ++ |
+ # Must be only one value between choices+ |
+
| 92 | +21x | +
+ checkmate::assert_choice(stats_in_pval_value, c("pval", "pval_counts"))
+ |
+
| 93 | ++ | + + | +
| 94 | ++ |
+ # Mismatch with counts and numeric+ |
+
| 95 | +20x | +
+ if (any(grepl("counts", method_groups)) && stats_in_pval_value != "pval_counts" ||
+ |
+
| 96 | +20x | +
+ any(grepl("numeric", method_groups)) && stats_in_pval_value != "pval") { # nolint
+ |
+
| 97 | +2x | +
+ stop(+ |
+
| 98 | +2x | +
+ "Inserted p-value (", stats_in_pval_value, ") is not valid for type ",
+ |
+
| 99 | +2x | +
+ type_tmp, ". Use ", paste(ifelse(stats_in_pval_value == "pval", "pval_counts", "pval")),+ |
+
| 100 | +2x | +
+ " instead."+ |
+
| 101 | ++ |
+ )+ |
+
| 102 | ++ |
+ }+ |
+
| 103 | ++ | + + | +
| 104 | ++ |
+ # Lets add it even if present (thanks to unique)+ |
+
| 105 | +18x | +
+ add_pval <- TRUE+ |
+
| 106 | ++ |
+ }+ |
+
| 107 | ++ | + + | +
| 108 | ++ |
+ # Mainly used in "analyze_vars" but it could be necessary elsewhere+ |
+
| 109 | +320x | +
+ if (isTRUE(add_pval)) {
+ |
+
| 110 | +22x | +
+ if (any(grepl("counts", method_groups))) {
+ |
+
| 111 | +10x | +
+ out <- unique(c(out, "pval_counts"))+ |
+
| 112 | ++ |
+ } else {
+ |
+
| 113 | +12x | +
+ out <- unique(c(out, "pval"))+ |
+
| 114 | ++ |
+ }+ |
+
| 115 | ++ |
+ }+ |
+
| 116 | ++ | + + | +
| 117 | ++ |
+ # Filtering for stats_in (character vector)+ |
+
| 118 | +320x | +
+ if (!is.null(stats_in)) {
+ |
+
| 119 | +304x | +
+ out <- intersect(stats_in, out) # It orders them too+ |
+
| 120 | ++ |
+ }+ |
+
| 121 | ++ | + + | +
| 122 | ++ |
+ # If intersect did not find matches (and no pval?) -> error+ |
+
| 123 | +320x | +
+ if (length(out) == 0) {
+ |
+
| 124 | +2x | +
+ stop(+ |
+
| 125 | +2x | +
+ "The selected method group(s) (", paste0(method_groups, collapse = ", "), ")",
+ |
+
| 126 | +2x | +
+ " do not have the required default statistical methods:\n",+ |
+
| 127 | +2x | +
+ paste0(stats_in, collapse = " ")+ |
+
| 128 | ++ |
+ )+ |
+
| 129 | ++ |
+ }+ |
+
| 130 | ++ | + + | +
| 131 | +318x | +
+ out+ |
+
| 132 | ++ |
+ }+ |
+
| 133 | ++ | + + | +
| 134 | ++ |
+ #' @describeIn default_stats_formats_labels Get formats from vector of statistical methods. If not+ |
+
| 135 | ++ |
+ #' present `NULL` is returned.+ |
+
| 136 | ++ |
+ #'+ |
+
| 137 | ++ |
+ #' @param formats_in (named `vector`) \cr inserted formats to replace defaults. It can be a+ |
+
| 138 | ++ |
+ #' character vector from [formatters::list_valid_format_labels()] or a custom format function.+ |
+
| 139 | ++ |
+ #'+ |
+
| 140 | ++ |
+ #' @return+ |
+
| 141 | ++ |
+ #' * `get_formats_from_stats()` returns a named list of formats, they being a value from+ |
+
| 142 | ++ |
+ #' [formatters::list_valid_format_labels()] or a custom function (e.g. [formatting_functions]).+ |
+
| 143 | ++ |
+ #'+ |
+
| 144 | ++ |
+ #' @note Formats in `tern` and `rtables` can be functions that take in the table cell value and+ |
+
| 145 | ++ |
+ #' return a string. This is well documented in `vignette("custom_appearance", package = "rtables")`.
+ |
+
| 146 | ++ |
+ #'+ |
+
| 147 | ++ |
+ #' @examples+ |
+
| 148 | ++ |
+ #' # Defaults formats+ |
+
| 149 | ++ |
+ #' get_formats_from_stats(num_stats)+ |
+
| 150 | ++ |
+ #' get_formats_from_stats(cnt_stats)+ |
+
| 151 | ++ |
+ #' get_formats_from_stats(only_pval)+ |
+
| 152 | ++ |
+ #' get_formats_from_stats(all_cnt_occ)+ |
+
| 153 | ++ |
+ #'+ |
+
| 154 | ++ |
+ #' # Addition of customs+ |
+
| 155 | ++ |
+ #' get_formats_from_stats(all_cnt_occ, formats_in = c("fraction" = c("xx")))
+ |
+
| 156 | ++ |
+ #' get_formats_from_stats(all_cnt_occ, formats_in = list("fraction" = c("xx.xx", "xx")))
+ |
+
| 157 | ++ |
+ #'+ |
+
| 158 | ++ |
+ #' @seealso [formatting_functions]+ |
+
| 159 | ++ |
+ #'+ |
+
| 160 | ++ |
+ #' @export+ |
+
| 161 | ++ |
+ get_formats_from_stats <- function(stats, formats_in = NULL) {
+ |
+
| 162 | +323x | +
+ checkmate::assert_character(stats, min.len = 1)+ |
+
| 163 | ++ |
+ # It may be a list if there is a function in the formats+ |
+
| 164 | +323x | +
+ if (checkmate::test_list(formats_in, null.ok = TRUE)) {
+ |
+
| 165 | +280x | +
+ checkmate::assert_list(formats_in, null.ok = TRUE)+ |
+
| 166 | ++ |
+ # Or it may be a vector of characters+ |
+
| 167 | ++ |
+ } else {
+ |
+
| 168 | +43x | +
+ checkmate::assert_character(formats_in, null.ok = TRUE)+ |
+
| 169 | ++ |
+ }+ |
+
| 170 | ++ | + + | +
| 171 | ++ |
+ # Extract global defaults+ |
+
| 172 | +323x | +
+ which_fmt <- match(stats, names(tern_default_formats))+ |
+
| 173 | ++ | + + | +
| 174 | ++ |
+ # Select only needed formats from stats+ |
+
| 175 | +323x | +
+ ret <- vector("list", length = length(stats)) # Returning a list is simpler
+ |
+
| 176 | +323x | +
+ ret[!is.na(which_fmt)] <- tern_default_formats[which_fmt[!is.na(which_fmt)]]+ |
+
| 177 | ++ | + + | +
| 178 | +323x | +
+ out <- setNames(ret, stats)+ |
+
| 179 | ++ | + + | +
| 180 | ++ |
+ # Modify some with custom formats+ |
+
| 181 | +323x | +
+ if (!is.null(formats_in)) {
+ |
+
| 182 | ++ |
+ # Stats is the main+ |
+
| 183 | +45x | +
+ common_names <- intersect(names(out), names(formats_in))+ |
+
| 184 | +45x | +
+ out[common_names] <- formats_in[common_names]+ |
+
| 185 | ++ |
+ }+ |
+
| 186 | ++ | + + | +
| 187 | +323x | +
+ out+ |
+
| 188 | ++ |
+ }+ |
+
| 189 | ++ | + + | +
| 190 | ++ |
+ #' @describeIn default_stats_formats_labels Get labels from vector of statistical methods.+ |
+
| 191 | ++ |
+ #'+ |
+
| 192 | ++ |
+ #' @param labels_in (named `vector`) \cr inserted labels to replace defaults.+ |
+
| 193 | ++ |
+ #'+ |
+
| 194 | ++ |
+ #' @return+ |
+
| 195 | ++ |
+ #' * `get_labels_from_stats()` returns a named character vector of default labels (if present+ |
+
| 196 | ++ |
+ #' otherwise `NULL`).+ |
+
| 197 | ++ |
+ #'+ |
+
| 198 | ++ |
+ #' @examples+ |
+
| 199 | ++ |
+ #' # Defaults labels+ |
+
| 200 | ++ |
+ #' get_labels_from_stats(num_stats)+ |
+
| 201 | ++ |
+ #' get_labels_from_stats(cnt_stats)+ |
+
| 202 | ++ |
+ #' get_labels_from_stats(only_pval)+ |
+
| 203 | ++ |
+ #' get_labels_from_stats(all_cnt_occ)+ |
+
| 204 | ++ |
+ #'+ |
+
| 205 | ++ |
+ #' # Addition of customs+ |
+
| 206 | ++ |
+ #' get_labels_from_stats(all_cnt_occ, labels_in = c("fraction" = "Fraction"))
+ |
+
| 207 | ++ |
+ #' get_labels_from_stats(all_cnt_occ, labels_in = list("fraction" = c("Some more fractions")))
+ |
+
| 208 | ++ |
+ #'+ |
+
| 209 | ++ |
+ #' @export+ |
+
| 210 | ++ |
+ get_labels_from_stats <- function(stats, labels_in = NULL) {
+ |
+
| 211 | +376x | +
+ checkmate::assert_character(stats, min.len = 1)+ |
+
| 212 | ++ |
+ # It may be a list+ |
+
| 213 | +376x | +
+ if (checkmate::test_list(labels_in, null.ok = TRUE)) {
+ |
+
| 214 | +325x | +
+ checkmate::assert_list(labels_in, null.ok = TRUE)+ |
+
| 215 | ++ |
+ # Or it may be a vector of characters+ |
+
| 216 | ++ |
+ } else {
+ |
+
| 217 | +51x | +
+ checkmate::assert_character(labels_in, null.ok = TRUE)+ |
+
| 218 | ++ |
+ }+ |
+
| 219 | ++ | + + | +
| 220 | +376x | +
+ which_lbl <- match(stats, names(tern_default_labels))+ |
+
| 221 | ++ | + + | +
| 222 | +376x | +
+ ret <- vector("character", length = length(stats)) # it needs to be a character vector
+ |
+
| 223 | +376x | +
+ ret[!is.na(which_lbl)] <- tern_default_labels[which_lbl[!is.na(which_lbl)]]+ |
+
| 224 | ++ | + + | +
| 225 | +376x | +
+ out <- setNames(ret, stats)+ |
+
| 226 | ++ | + + | +
| 227 | ++ |
+ # Modify some with custom labels+ |
+
| 228 | +376x | +
+ if (!is.null(labels_in)) {
+ |
+
| 229 | ++ |
+ # Stats is the main+ |
+
| 230 | +51x | +
+ common_names <- intersect(names(out), names(labels_in))+ |
+
| 231 | +51x | +
+ out[common_names] <- labels_in[common_names]+ |
+
| 232 | ++ |
+ }+ |
+
| 233 | ++ | + + | +
| 234 | +376x | +
+ out+ |
+
| 235 | ++ |
+ }+ |
+
| 236 | ++ | + + | +
| 237 | ++ |
+ #' @describeIn default_stats_formats_labels Named list of default formats for `tern`.+ |
+
| 238 | ++ |
+ #' @format+ |
+
| 239 | ++ |
+ #' * `tern_default_formats` is a list of available formats, named after their relevant+ |
+
| 240 | ++ |
+ #' statistic.+ |
+
| 241 | ++ |
+ #' @export+ |
+
| 242 | ++ |
+ tern_default_formats <- c(+ |
+
| 243 | ++ |
+ fraction = format_fraction_fixed_dp,+ |
+
| 244 | ++ |
+ unique = format_count_fraction_fixed_dp,+ |
+
| 245 | ++ |
+ nonunique = "xx",+ |
+
| 246 | ++ |
+ unique_count = "xx",+ |
+
| 247 | ++ |
+ n = "xx.",+ |
+
| 248 | ++ |
+ count = "xx.",+ |
+
| 249 | ++ |
+ count_fraction = format_count_fraction,+ |
+
| 250 | ++ |
+ count_fraction_fixed_dp = format_count_fraction_fixed_dp,+ |
+
| 251 | ++ |
+ n_blq = "xx.",+ |
+
| 252 | ++ |
+ sum = "xx.x",+ |
+
| 253 | ++ |
+ mean = "xx.x",+ |
+
| 254 | ++ |
+ sd = "xx.x",+ |
+
| 255 | ++ |
+ se = "xx.x",+ |
+
| 256 | ++ |
+ mean_sd = "xx.x (xx.x)",+ |
+
| 257 | ++ |
+ mean_se = "xx.x (xx.x)",+ |
+
| 258 | ++ |
+ mean_ci = "(xx.xx, xx.xx)",+ |
+
| 259 | ++ |
+ mean_sei = "(xx.xx, xx.xx)",+ |
+
| 260 | ++ |
+ mean_sdi = "(xx.xx, xx.xx)",+ |
+
| 261 | ++ |
+ mean_pval = "xx.xx",+ |
+
| 262 | ++ |
+ median = "xx.x",+ |
+
| 263 | ++ |
+ mad = "xx.x",+ |
+
| 264 | ++ |
+ median_ci = "(xx.xx, xx.xx)",+ |
+
| 265 | ++ |
+ quantiles = "xx.x - xx.x",+ |
+
| 266 | ++ |
+ iqr = "xx.x",+ |
+
| 267 | ++ |
+ range = "xx.x - xx.x",+ |
+
| 268 | ++ |
+ min = "xx.x",+ |
+
| 269 | ++ |
+ max = "xx.x",+ |
+
| 270 | ++ |
+ median_range = "xx.x (xx.x - xx.x)",+ |
+
| 271 | ++ |
+ cv = "xx.x",+ |
+
| 272 | ++ |
+ geom_mean = "xx.x",+ |
+
| 273 | ++ |
+ geom_mean_ci = "(xx.xx, xx.xx)",+ |
+
| 274 | ++ |
+ geom_cv = "xx.x",+ |
+
| 275 | ++ |
+ pval = "x.xxxx | (<0.0001)",+ |
+
| 276 | ++ |
+ pval_counts = "x.xxxx | (<0.0001)"+ |
+
| 277 | ++ |
+ )+ |
+
| 278 | ++ | + + | +
| 279 | ++ |
+ #' @describeIn default_stats_formats_labels `character` vector that contains default labels+ |
+
| 280 | ++ |
+ #' for `tern`.+ |
+
| 281 | ++ |
+ #' @format+ |
+
| 282 | ++ |
+ #' * `tern_default_labels` is a character vector of available labels, named after their relevant+ |
+
| 283 | ++ |
+ #' statistic.+ |
+
| 284 | ++ |
+ #' @export+ |
+
| 285 | ++ |
+ tern_default_labels <- c(+ |
+
| 286 | ++ |
+ # list of labels -> sorted? xxx it should be not relevant due to match+ |
+
| 287 | ++ |
+ unique = "Number of patients with at least one event",+ |
+
| 288 | ++ |
+ nonunique = "Number of events",+ |
+
| 289 | ++ |
+ n = "n",+ |
+
| 290 | ++ |
+ count = "count",+ |
+
| 291 | ++ |
+ count_fraction = "count_fraction",+ |
+
| 292 | ++ |
+ n_blq = "n_blq",+ |
+
| 293 | ++ |
+ sum = "Sum",+ |
+
| 294 | ++ |
+ mean = "Mean",+ |
+
| 295 | ++ |
+ sd = "SD",+ |
+
| 296 | ++ |
+ se = "SE",+ |
+
| 297 | ++ |
+ mean_sd = "Mean (SD)",+ |
+
| 298 | ++ |
+ mean_se = "Mean (SE)",+ |
+
| 299 | ++ |
+ mean_ci = "Mean 95% CI",+ |
+
| 300 | ++ |
+ mean_sei = "Mean -/+ 1xSE",+ |
+
| 301 | ++ |
+ mean_sdi = "Mean -/+ 1xSD",+ |
+
| 302 | ++ |
+ mean_pval = "Mean p-value (H0: mean = 0)",+ |
+
| 303 | ++ |
+ median = "Median",+ |
+
| 304 | ++ |
+ mad = "Median Absolute Deviation",+ |
+
| 305 | ++ |
+ median_ci = "Median 95% CI",+ |
+
| 306 | ++ |
+ quantiles = "25% and 75%-ile",+ |
+
| 307 | ++ |
+ iqr = "IQR",+ |
+
| 308 | ++ |
+ range = "Min - Max",+ |
+
| 309 | ++ |
+ min = "Minimum",+ |
+
| 310 | ++ |
+ max = "Maximum",+ |
+
| 311 | ++ |
+ median_range = "Median (Min - Max)",+ |
+
| 312 | ++ |
+ cv = "CV (%)",+ |
+
| 313 | ++ |
+ geom_mean = "Geometric Mean",+ |
+
| 314 | ++ |
+ geom_mean_ci = "Geometric Mean 95% CI",+ |
+
| 315 | ++ |
+ geom_cv = "CV % Geometric Mean",+ |
+
| 316 | ++ |
+ pval = "p-value (t-test)", # Default for numeric+ |
+
| 317 | ++ |
+ pval_counts = "p-value (chi-squared test)" # Default for counts+ |
+
| 318 | ++ |
+ )+ |
+
| 319 | ++ | + + | +
| 320 | ++ |
+ # To deprecate ---------+ |
+
| 321 | ++ | + + | +
| 322 | ++ |
+ #' @describeIn default_stats_formats_labels Quick function to retrieve default formats for summary statistics:+ |
+
| 323 | ++ |
+ #' [analyze_vars()] and [analyze_vars_in_cols()] principally.+ |
+
| 324 | ++ |
+ #'+ |
+
| 325 | ++ |
+ #' @param type (`flag`)\cr is it going to be `"numeric"` or `"counts"`?+ |
+
| 326 | ++ |
+ #'+ |
+
| 327 | ++ |
+ #' @return+ |
+
| 328 | ++ |
+ #' * `summary_formats()` returns a named `vector` of default statistic formats for the given data type.+ |
+
| 329 | ++ |
+ #'+ |
+
| 330 | ++ |
+ #' @examples+ |
+
| 331 | ++ |
+ #' summary_formats()+ |
+
| 332 | ++ |
+ #' summary_formats(type = "counts", include_pval = TRUE)+ |
+
| 333 | ++ |
+ #'+ |
+
| 334 | ++ |
+ #' @export+ |
+
| 335 | ++ |
+ summary_formats <- function(type = "numeric", include_pval = FALSE) {
+ |
+
| 336 | +3x | +
+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ |
+
| 337 | +3x | +
+ get_formats_from_stats(get_stats(met_grp, add_pval = include_pval))+ |
+
| 338 | ++ |
+ }+ |
+
| 339 | ++ | + + | +
| 340 | ++ |
+ #' @describeIn default_stats_formats_labels Quick function to retrieve default labels for summary statistics.+ |
+
| 341 | ++ |
+ #' Returns labels of descriptive statistics which are understood by `rtables`. Similar to `summary_formats`+ |
+
| 342 | ++ |
+ #'+ |
+
| 343 | ++ |
+ #' @param include_pval (`flag`)\cr deprecated parameter. Same as `add_pval`.+ |
+
| 344 | ++ |
+ #' @return+ |
+
| 345 | ++ |
+ #' * `summary_labels` returns a named `vector` of default statistic labels for the given data type.+ |
+
| 346 | ++ |
+ #'+ |
+
| 347 | ++ |
+ #' @examples+ |
+
| 348 | ++ |
+ #' summary_labels()+ |
+
| 349 | ++ |
+ #' summary_labels(type = "counts", include_pval = TRUE)+ |
+
| 350 | ++ |
+ #'+ |
+
| 351 | ++ |
+ #' @export+ |
+
| 352 | ++ |
+ summary_labels <- function(type = "numeric", include_pval = FALSE) {
+ |
+
| 353 | +3x | +
+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ |
+
| 354 | +3x | +
+ get_labels_from_stats(get_stats(met_grp, add_pval = include_pval))+ |
+
| 355 | ++ |
+ }+ |
+
| 356 | ++ | + + | +
| 357 | ++ |
+ #' @describeIn default_stats_formats_labels `r lifecycle::badge("deprecated")` Function to
+ |
+
| 358 | ++ |
+ #' configure settings for default or custom summary statistics for a given data type. In+ |
+
| 359 | ++ |
+ #' addition to selecting a custom subset of statistics, the user can also set custom+ |
+
| 360 | ++ |
+ #' formats, labels, and indent modifiers for any of these statistics.+ |
+
| 361 | ++ |
+ #'+ |
+
| 362 | ++ |
+ #' @param stats_custom (`named vector` of `character`)\cr vector of statistics to include if+ |
+
| 363 | ++ |
+ #' not the defaults. This argument overrides `include_pval` and other custom value arguments+ |
+
| 364 | ++ |
+ #' such that only settings for these statistics will be returned.+ |
+
| 365 | ++ |
+ #' @param formats_custom (`named vector` of `character`)\cr vector of custom statistics formats+ |
+
| 366 | ++ |
+ #' to use in place of the defaults defined in [`summary_formats()`]. Names should be a subset+ |
+
| 367 | ++ |
+ #' of the statistics defined in `stats_custom` (or default statistics if this is `NULL`).+ |
+
| 368 | ++ |
+ #' @param labels_custom (`named vector` of `character`)\cr vector of custom statistics labels+ |
+
| 369 | ++ |
+ #' to use in place of the defaults defined in [`summary_labels()`]. Names should be a subset+ |
+
| 370 | ++ |
+ #' of the statistics defined in `stats_custom` (or default statistics if this is `NULL`).+ |
+
| 371 | ++ |
+ #' @param indent_mods_custom (`integer` or `named vector` of `integer`)\cr vector of custom+ |
+
| 372 | ++ |
+ #' indentation modifiers for statistics to use instead of the default of `0L` for all statistics.+ |
+
| 373 | ++ |
+ #' Names should be a subset of the statistics defined in `stats_custom` (or default statistics+ |
+
| 374 | ++ |
+ #' if this is `NULL`). Alternatively, the same indentation modifier can be applied to all+ |
+
| 375 | ++ |
+ #' statistics by setting `indent_mods_custom` to a single integer value.+ |
+
| 376 | ++ |
+ #'+ |
+
| 377 | ++ |
+ #' @return+ |
+
| 378 | ++ |
+ #' * `summary_custom` returns a `list` of 4 named elements: `stats`, `formats`, `labels`,+ |
+
| 379 | ++ |
+ #' and `indent_mods`.+ |
+
| 380 | ++ |
+ #'+ |
+
| 381 | ++ |
+ #' @examples+ |
+
| 382 | ++ |
+ #' summary_custom()+ |
+
| 383 | ++ |
+ #' summary_custom(type = "counts", include_pval = TRUE)+ |
+
| 384 | ++ |
+ #' summary_custom(+ |
+
| 385 | ++ |
+ #' include_pval = TRUE, stats_custom = c("n", "mean", "sd", "pval"),
+ |
+
| 386 | ++ |
+ #' labels_custom = c(sd = "Std. Dev."), indent_mods_custom = 3L+ |
+
| 387 | ++ |
+ #' )+ |
+
| 388 | ++ |
+ #'+ |
+
| 389 | ++ |
+ #' @export+ |
+
| 390 | ++ |
+ summary_custom <- function(type = "numeric",+ |
+
| 391 | ++ |
+ include_pval = FALSE,+ |
+
| 392 | ++ |
+ stats_custom = NULL,+ |
+
| 393 | ++ |
+ formats_custom = NULL,+ |
+
| 394 | ++ |
+ labels_custom = NULL,+ |
+
| 395 | ++ |
+ indent_mods_custom = NULL) {
+ |
+
| 396 | +1x | +
+ lifecycle::deprecate_warn(+ |
+
| 397 | +1x | +
+ "0.9.0.9001",+ |
+
| 398 | +1x | +
+ "summary_custom()",+ |
+
| 399 | +1x | +
+ details = "Please use `get_stats`, `get_formats_from_stats`, and `get_labels_from_stats` directly instead."+ |
+
| 400 | ++ |
+ )+ |
+
| 401 | +1x | +
+ met_grp <- paste0(c("analyze_vars", type), collapse = "_")
+ |
+
| 402 | +1x | +
+ .stats <- get_stats(met_grp, stats_custom, add_pval = include_pval)+ |
+
| 403 | +1x | +
+ .formats <- get_formats_from_stats(.stats, formats_custom)+ |
+
| 404 | +1x | +
+ .labels <- get_labels_from_stats(.stats, labels_custom)+ |
+
| 405 | +1x | +
+ .indent_mods <- stats::setNames(rep(0L, length(.stats)), .stats)+ |
+
| 406 | ++ | + + | +
| 407 | +1x | +
+ if (!is.null(indent_mods_custom)) {
+ |
+
| 408 | +! | +
+ if (is.null(names(indent_mods_custom)) && length(indent_mods_custom) == 1) {
+ |
+
| 409 | +! | +
+ .indent_mods[names(.indent_mods)] <- indent_mods_custom+ |
+
| 410 | ++ |
+ } else {
+ |
+
| 411 | +! | +
+ .indent_mods[names(indent_mods_custom)] <- indent_mods_custom+ |
+
| 412 | ++ |
+ }+ |
+
| 413 | ++ |
+ }+ |
+
| 414 | ++ | + + | +
| 415 | +1x | +
+ list(+ |
+
| 416 | +1x | +
+ stats = .stats,+ |
+
| 417 | +1x | +
+ formats = .formats,+ |
+
| 418 | +1x | +
+ labels = .labels,+ |
+
| 419 | +1x | +
+ indent_mods = .indent_mods[.stats]+ |
+
| 420 | ++ |
+ )+ |
+
| 421 | ++ |
+ }+ |
+
| 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 A vector of variable name 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 | ++ |
+ #' + `y ~ ARM`+ |
+
| 16 | ++ |
+ #' + `y ~ ARM + SEX`+ |
+
| 17 | ++ |
+ #' + `y ~ ARM + AGE`+ |
+
| 18 | ++ |
+ #' + `y ~ ARM + RACE`+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @export+ |
+
| 21 | ++ |
+ univariate <- function(x) {
+ |
+
| 22 | +1x | +
+ structure(x, varname = deparse(substitute(x)))+ |
+
| 23 | ++ |
+ }+ |
+
| 24 | ++ | + + | +
| 25 | ++ |
+ # Get the right-hand-term of a formula+ |
+
| 26 | ++ |
+ rht <- function(x) {
+ |
+
| 27 | +4x | +
+ checkmate::assert_formula(x)+ |
+
| 28 | +4x | +
+ y <- as.character(rev(x)[[1]])+ |
+
| 29 | +4x | +
+ return(y)+ |
+
| 30 | ++ |
+ }+ |
+
| 31 | ++ | + + | +
| 32 | ++ |
+ #' Hazard Ratio Estimation in Interactions+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' This function estimates the hazard ratios between arms when an interaction variable is given with+ |
+
| 35 | ++ |
+ #' specific values.+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' @param variable,given Names of two variable in interaction. We seek the estimation of the levels of `variable`+ |
+
| 38 | ++ |
+ #' given the levels of `given`.+ |
+
| 39 | ++ |
+ #' @param lvl_var,lvl_given corresponding levels has given by `levels`.+ |
+
| 40 | ++ |
+ #' @param mmat A name numeric filled with 0 used as template to obtain the design matrix.+ |
+
| 41 | ++ |
+ #' @param coef Numeric of estimated coefficients.+ |
+
| 42 | ++ |
+ #' @param vcov Variance-covariance matrix of underlying model.+ |
+
| 43 | ++ |
+ #' @param conf_level Single numeric for the confidence level of estimate intervals.+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A)+ |
+
| 46 | ++ |
+ #' and Sex (F, M; reference Female). The model is abbreviated: y ~ Arm + Sex + Arm x Sex.+ |
+
| 47 | ++ |
+ #' The cox regression estimates the coefficients along with a variance-covariance matrix for:+ |
+
| 48 | ++ |
+ #'+ |
+
| 49 | ++ |
+ #' - b1 (arm b), b2 (arm c)+ |
+
| 50 | ++ |
+ #' - b3 (sex m)+ |
+
| 51 | ++ |
+ #' - b4 (arm b: sex m), b5 (arm c: sex m)+ |
+
| 52 | ++ |
+ #'+ |
+
| 53 | ++ |
+ #' Given that I want an estimation of the Hazard Ratio for arm C/sex M, the estimation+ |
+
| 54 | ++ |
+ #' will be given in reference to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5),+ |
+
| 55 | ++ |
+ #' therefore the interaction coefficient is given by b2 + b5 while the standard error is obtained+ |
+
| 56 | ++ |
+ #' as $1.96 * sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$ for a confidence level of 0.95.+ |
+
| 57 | ++ |
+ #'+ |
+
| 58 | ++ |
+ #' @return A list of matrix (one per level of variable) with rows corresponding to the combinations of+ |
+
| 59 | ++ |
+ #' `variable` and `given`, with columns:+ |
+
| 60 | ++ |
+ #' * `coef_hat`: Estimation of the coefficient.+ |
+
| 61 | ++ |
+ #' * `coef_se`: Standard error of the estimation.+ |
+
| 62 | ++ |
+ #' * `hr`: Hazard ratio.+ |
+
| 63 | ++ |
+ #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio.+ |
+
| 64 | ++ |
+ #'+ |
+
| 65 | ++ |
+ #' @seealso [s_cox_multivariate()].+ |
+
| 66 | ++ |
+ #'+ |
+
| 67 | ++ |
+ #' @examples+ |
+
| 68 | ++ |
+ #' library(dplyr)+ |
+
| 69 | ++ |
+ #' library(survival)+ |
+
| 70 | ++ |
+ #'+ |
+
| 71 | ++ |
+ #' ADSL <- tern_ex_adsl %>%+ |
+
| 72 | ++ |
+ #' filter(SEX %in% c("F", "M"))
+ |
+
| 73 | ++ |
+ #'+ |
+
| 74 | ++ |
+ #' adtte <- tern_ex_adtte %>% filter(PARAMCD == "PFS")+ |
+
| 75 | ++ |
+ #' adtte$ARMCD <- droplevels(adtte$ARMCD)+ |
+
| 76 | ++ |
+ #' adtte$SEX <- droplevels(adtte$SEX)+ |
+
| 77 | ++ |
+ #'+ |
+
| 78 | ++ |
+ #' mod <- coxph(+ |
+
| 79 | ++ |
+ #' formula = Surv(time = AVAL, event = 1 - CNSR) ~ (SEX + ARMCD)^2,+ |
+
| 80 | ++ |
+ #' data = adtte+ |
+
| 81 | ++ |
+ #' )+ |
+
| 82 | ++ |
+ #'+ |
+
| 83 | ++ |
+ #' mmat <- stats::model.matrix(mod)[1, ]+ |
+
| 84 | ++ |
+ #' mmat[!mmat == 0] <- 0+ |
+
| 85 | ++ |
+ #'+ |
+
| 86 | ++ |
+ #' @keywords internal+ |
+
| 87 | ++ |
+ estimate_coef <- function(variable, given,+ |
+
| 88 | ++ |
+ lvl_var, lvl_given,+ |
+
| 89 | ++ |
+ coef,+ |
+
| 90 | ++ |
+ mmat,+ |
+
| 91 | ++ |
+ vcov,+ |
+
| 92 | ++ |
+ conf_level = 0.95) {
+ |
+
| 93 | +8x | +
+ var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level+ |
+
| 94 | +8x | +
+ giv_lvl <- paste0(given, lvl_given)+ |
+
| 95 | ++ | + + | +
| 96 | +8x | +
+ design_mat <- expand.grid(variable = var_lvl, given = giv_lvl)+ |
+
| 97 | +8x | +
+ design_mat <- design_mat[order(design_mat$variable, design_mat$given), ]+ |
+
| 98 | +8x | +
+ design_mat <- within(+ |
+
| 99 | +8x | +
+ data = design_mat,+ |
+
| 100 | +8x | +
+ expr = {
+ |
+
| 101 | +8x | +
+ inter <- paste0(variable, ":", given)+ |
+
| 102 | +8x | +
+ rev_inter <- paste0(given, ":", variable)+ |
+
| 103 | ++ |
+ }+ |
+
| 104 | ++ |
+ )+ |
+
| 105 | ++ | + + | +
| 106 | +8x | +
+ split_by_variable <- design_mat$variable+ |
+
| 107 | +8x | +
+ interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/")+ |
+
| 108 | ++ | + + | +
| 109 | +8x | +
+ design_mat <- apply(+ |
+
| 110 | +8x | +
+ X = design_mat, MARGIN = 1, FUN = function(x) {
+ |
+
| 111 | +27x | +
+ mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1+ |
+
| 112 | +27x | +
+ return(mmat)+ |
+
| 113 | ++ |
+ }+ |
+
| 114 | ++ |
+ )+ |
+
| 115 | +8x | +
+ colnames(design_mat) <- interaction_names+ |
+
| 116 | ++ | + + | +
| 117 | +8x | +
+ betas <- as.matrix(coef)+ |
+
| 118 | ++ | + + | +
| 119 | +8x | +
+ coef_hat <- t(design_mat) %*% betas+ |
+
| 120 | +8x | +
+ dimnames(coef_hat)[2] <- "coef"+ |
+
| 121 | ++ | + + | +
| 122 | +8x | +
+ coef_se <- apply(design_mat, 2, function(x) {
+ |
+
| 123 | +27x | +
+ vcov_el <- as.logical(x)+ |
+
| 124 | +27x | +
+ y <- vcov[vcov_el, vcov_el]+ |
+
| 125 | +27x | +
+ y <- sum(y)+ |
+
| 126 | +27x | +
+ y <- sqrt(y)+ |
+
| 127 | +27x | +
+ return(y)+ |
+
| 128 | ++ |
+ })+ |
+
| 129 | ++ | + + | +
| 130 | +8x | +
+ q_norm <- stats::qnorm((1 + conf_level) / 2)+ |
+
| 131 | +8x | +
+ y <- cbind(coef_hat, `se(coef)` = coef_se)+ |
+
| 132 | ++ | + + | +
| 133 | +8x | +
+ y <- apply(y, 1, function(x) {
+ |
+
| 134 | +27x | +
+ x["hr"] <- exp(x["coef"])+ |
+
| 135 | +27x | +
+ x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"])+ |
+
| 136 | +27x | +
+ x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"])+ |
+
| 137 | ++ | + + | +
| 138 | +27x | +
+ return(x)+ |
+
| 139 | ++ |
+ })+ |
+
| 140 | ++ | + + | +
| 141 | +8x | +
+ y <- t(y)+ |
+
| 142 | +8x | +
+ y <- by(y, split_by_variable, identity)+ |
+
| 143 | +8x | +
+ y <- lapply(y, as.matrix)+ |
+
| 144 | ++ | + + | +
| 145 | +8x | +
+ attr(y, "details") <- paste0(+ |
+
| 146 | +8x | +
+ "Estimations of ", variable,+ |
+
| 147 | +8x | +
+ " hazard ratio given the level of ", given, " compared to ",+ |
+
| 148 | +8x | +
+ variable, " level ", lvl_var[1], "."+ |
+
| 149 | ++ |
+ )+ |
+
| 150 | +8x | +
+ return(y)+ |
+
| 151 | ++ |
+ }+ |
+
| 152 | ++ | + + | +
| 153 | ++ |
+ #' `tryCatch` around `car::Anova`+ |
+
| 154 | ++ |
+ #'+ |
+
| 155 | ++ |
+ #' Captures warnings when executing [car::Anova].+ |
+
| 156 | ++ |
+ #'+ |
+
| 157 | ++ |
+ #' @inheritParams car::Anova+ |
+
| 158 | ++ |
+ #'+ |
+
| 159 | ++ |
+ #' @return A list with item `aov` for the result of the model and `error_text` for the captured warnings.+ |
+
| 160 | ++ |
+ #'+ |
+
| 161 | ++ |
+ #' @examples+ |
+
| 162 | ++ |
+ #' # `car::Anova` on cox regression model including strata and expected+ |
+
| 163 | ++ |
+ #' # a likelihood ratio test triggers a warning as only `Wald` method is+ |
+
| 164 | ++ |
+ #' # accepted.+ |
+
| 165 | ++ |
+ #'+ |
+
| 166 | ++ |
+ #' library(survival)+ |
+
| 167 | ++ |
+ #'+ |
+
| 168 | ++ |
+ #' mod <- coxph(+ |
+
| 169 | ++ |
+ #' formula = Surv(time = futime, event = fustat) ~ factor(rx) + strata(ecog.ps),+ |
+
| 170 | ++ |
+ #' data = ovarian+ |
+
| 171 | ++ |
+ #' )+ |
+
| 172 | ++ |
+ #'+ |
+
| 173 | ++ |
+ #' @keywords internal+ |
+
| 174 | ++ |
+ try_car_anova <- function(mod,+ |
+
| 175 | ++ |
+ test.statistic) { # nolint
+ |
+
| 176 | +2x | +
+ y <- tryCatch(+ |
+
| 177 | +2x | +
+ withCallingHandlers(+ |
+
| 178 | +2x | +
+ expr = {
+ |
+
| 179 | +2x | +
+ warn_text <- c()+ |
+
| 180 | +2x | +
+ list(+ |
+
| 181 | +2x | +
+ aov = car::Anova(+ |
+
| 182 | +2x | +
+ mod,+ |
+
| 183 | +2x | +
+ test.statistic = test.statistic,+ |
+
| 184 | +2x | +
+ type = "III"+ |
+
| 185 | ++ |
+ ),+ |
+
| 186 | +2x | +
+ warn_text = warn_text+ |
+
| 187 | ++ |
+ )+ |
+
| 188 | ++ |
+ },+ |
+
| 189 | +2x | +
+ warning = function(w) {
+ |
+
| 190 | ++ |
+ # If a warning is detected it is handled as "w".+ |
+
| 191 | +! | +
+ warn_text <<- trimws(paste0("Warning in `try_car_anova`: ", w))
+ |
+
| 192 | ++ | + + | +
| 193 | ++ |
+ # A warning is sometimes expected, then, we want to restart+ |
+
| 194 | ++ |
+ # the execution while ignoring the warning.+ |
+
| 195 | +! | +
+ invokeRestart("muffleWarning")
+ |
+
| 196 | ++ |
+ }+ |
+
| 197 | ++ |
+ ),+ |
+
| 198 | +2x | +
+ finally = {
+ |
+
| 199 | ++ |
+ }+ |
+
| 200 | ++ |
+ )+ |
+
| 201 | ++ | + + | +
| 202 | +2x | +
+ return(y)+ |
+
| 203 | ++ |
+ }+ |
+
| 204 | ++ | + + | +
| 205 | ++ |
+ #' Fit the Cox Regression Model and `Anova`+ |
+
| 206 | ++ |
+ #'+ |
+
| 207 | ++ |
+ #' The functions allows to derive from the [survival::coxph()] results the effect p.values using [car::Anova()].+ |
+
| 208 | ++ |
+ #' This last package introduces more flexibility to get the effect p.values.+ |
+
| 209 | ++ |
+ #'+ |
+
| 210 | ++ |
+ #' @inheritParams t_coxreg+ |
+
| 211 | ++ |
+ #'+ |
+
| 212 | ++ |
+ #' @return A list with items `mod` (results of [survival::coxph()]), `msum` (result of `summary`) and+ |
+
| 213 | ++ |
+ #' `aov` (result of [car::Anova()]).+ |
+
| 214 | ++ |
+ #'+ |
+
| 215 | ++ |
+ #' @noRd+ |
+
| 216 | ++ |
+ fit_n_aov <- function(formula,+ |
+
| 217 | ++ |
+ data = data,+ |
+
| 218 | ++ |
+ conf_level = conf_level,+ |
+
| 219 | ++ |
+ pval_method = c("wald", "likelihood"),
+ |
+
| 220 | ++ |
+ ...) {
+ |
+
| 221 | +1x | +
+ pval_method <- match.arg(pval_method)+ |
+
| 222 | ++ | + + | +
| 223 | +1x | +
+ environment(formula) <- environment()+ |
+
| 224 | +1x | +
+ suppressWarnings({
+ |
+
| 225 | ++ |
+ # We expect some warnings due to coxph which fails strict programming.+ |
+
| 226 | +1x | +
+ mod <- survival::coxph(formula, data = data, ...)+ |
+
| 227 | +1x | +
+ msum <- summary(mod, conf.int = conf_level)+ |
+
| 228 | ++ |
+ })+ |
+
| 229 | ++ | + + | +
| 230 | +1x | +
+ aov <- try_car_anova(+ |
+
| 231 | +1x | +
+ mod,+ |
+
| 232 | +1x | +
+ test.statistic = switch(pval_method,+ |
+
| 233 | +1x | +
+ "wald" = "Wald",+ |
+
| 234 | +1x | +
+ "likelihood" = "LR"+ |
+
| 235 | ++ |
+ )+ |
+
| 236 | ++ |
+ )+ |
+
| 237 | ++ | + + | +
| 238 | +1x | +
+ warn_attr <- aov$warn_text+ |
+
| 239 | +! | +
+ if (!is.null(aov$warn_text)) message(warn_attr)+ |
+
| 240 | ++ | + + | +
| 241 | +1x | +
+ aov <- aov$aov+ |
+
| 242 | +1x | +
+ y <- list(mod = mod, msum = msum, aov = aov)+ |
+
| 243 | +1x | +
+ attr(y, "message") <- warn_attr+ |
+
| 244 | ++ | + + | +
| 245 | +1x | +
+ return(y)+ |
+
| 246 | ++ |
+ }+ |
+
| 247 | ++ | + + | +
| 248 | ++ |
+ # argument_checks+ |
+
| 249 | ++ |
+ check_formula <- function(formula) {
+ |
+
| 250 | +1x | +
+ if (!(inherits(formula, "formula"))) {
+ |
+
| 251 | +1x | +
+ stop("Check `formula`. A formula should resemble `Surv(time = AVAL, event = 1 - CNSR) ~ study_arm(ARMCD)`.")
+ |
+
| 252 | ++ |
+ }+ |
+
| 253 | ++ | + + | +
| 254 | +! | +
+ invisible()+ |
+
| 255 | ++ |
+ }+ |
+
| 256 | ++ | + + | +
| 257 | ++ |
+ check_covariate_formulas <- function(covariates) {
+ |
+
| 258 | +1x | +
+ if (!all(vapply(X = covariates, FUN = inherits, what = "formula", FUN.VALUE = TRUE)) || is.null(covariates)) {
+ |
+
| 259 | +1x | +
+ stop("Check `covariates`, it should be a list of right-hand-term formulas, e.g. list(Age = ~AGE).")
+ |
+
| 260 | ++ |
+ }+ |
+
| 261 | ++ | + + | +
| 262 | +! | +
+ invisible()+ |
+
| 263 | ++ |
+ }+ |
+
| 264 | ++ | + + | +
| 265 | ++ |
+ name_covariate_names <- function(covariates) {
+ |
+
| 266 | +1x | +
+ miss_names <- names(covariates) == ""+ |
+
| 267 | +1x | +
+ no_names <- is.null(names(covariates))+ |
+
| 268 | +! | +
+ if (any(miss_names)) names(covariates)[miss_names] <- vapply(covariates[miss_names], FUN = rht, FUN.VALUE = "name")+ |
+
| 269 | +! | +
+ if (no_names) names(covariates) <- vapply(covariates, FUN = rht, FUN.VALUE = "name")+ |
+
| 270 | +1x | +
+ return(covariates)+ |
+
| 271 | ++ |
+ }+ |
+
| 272 | ++ | + + | +
| 273 | ++ |
+ check_increments <- function(increments, covariates) {
+ |
+
| 274 | +1x | +
+ if (!is.null(increments)) {
+ |
+
| 275 | +1x | +
+ covariates <- vapply(covariates, FUN = rht, FUN.VALUE = "name")+ |
+
| 276 | +1x | +
+ lapply(+ |
+
| 277 | +1x | +
+ X = names(increments), FUN = function(x) {
+ |
+
| 278 | +3x | +
+ if (!x %in% covariates) {
+ |
+
| 279 | +1x | +
+ warning(+ |
+
| 280 | +1x | +
+ paste(+ |
+
| 281 | +1x | +
+ "Check `increments`, the `increment` for ", x,+ |
+
| 282 | +1x | +
+ "doesn't match any names in investigated covariate(s)."+ |
+
| 283 | ++ |
+ )+ |
+
| 284 | ++ |
+ )+ |
+
| 285 | ++ |
+ }+ |
+
| 286 | ++ |
+ }+ |
+
| 287 | ++ |
+ )+ |
+
| 288 | ++ |
+ }+ |
+
| 289 | ++ | + + | +
| 290 | +1x | +
+ invisible()+ |
+
| 291 | ++ |
+ }+ |
+
| 292 | ++ | + + | +
| 293 | ++ |
+ #' Multivariate Cox Model - Summarized Results+ |
+
| 294 | ++ |
+ #'+ |
+
| 295 | ++ |
+ #' Analyses based on multivariate Cox model are usually not performed for the Controlled Substance Reporting or+ |
+
| 296 | ++ |
+ #' regulatory documents but serve exploratory purposes only (e.g., for publication). In practice, the model usually+ |
+
| 297 | ++ |
+ #' includes only the main effects (without interaction terms). It produces the hazard ratio estimates for each of the+ |
+
| 298 | ++ |
+ #' covariates included in the model.+ |
+
| 299 | ++ |
+ #' The analysis follows the same principles (e.g., stratified vs. unstratified analysis and tie handling) as the+ |
+
| 300 | ++ |
+ #' usual Cox model analysis. Since there is usually no pre-specified hypothesis testing for such analysis,+ |
+
| 301 | ++ |
+ #' the p.values need to be interpreted with caution. (**Statistical Analysis of Clinical Trials Data with R**,+ |
+
| 302 | ++ |
+ #' `NEST's bookdown`)+ |
+
| 303 | ++ |
+ #'+ |
+
| 304 | ++ |
+ #' @param formula (`formula`)\cr A formula corresponding to the investigated [survival::Surv()] survival model+ |
+
| 305 | ++ |
+ #' including covariates.+ |
+
| 306 | ++ |
+ #' @param data (`data.frame`)\cr A data frame which includes the variable in formula and covariates.+ |
+
| 307 | ++ |
+ #' @param conf_level (`proportion`)\cr The confidence level for the hazard ratio interval estimations. Default is 0.95.+ |
+
| 308 | ++ |
+ #' @param pval_method (`character`)\cr The method used for the estimation of p-values, should be one of+ |
+
| 309 | ++ |
+ #' `"wald"` (default) or `"likelihood"`.+ |
+
| 310 | ++ |
+ #' @param ... Optional parameters passed to [survival::coxph()]. Can include `ties`, a character string specifying the+ |
+
| 311 | ++ |
+ #' method for tie handling, one of `exact` (default), `efron`, `breslow`.+ |
+
| 312 | ++ |
+ #'+ |
+
| 313 | ++ |
+ #' @return A `list` with elements `mod`, `msum`, `aov`, and `coef_inter`.+ |
+
| 314 | ++ |
+ #'+ |
+
| 315 | ++ |
+ #' @details The output is limited to single effect terms. Work in ongoing for estimation of interaction terms+ |
+
| 316 | ++ |
+ #' but is out of scope as defined by the Global Data Standards Repository+ |
+
| 317 | ++ |
+ #' (**`GDS_Standard_TLG_Specs_Tables_2.doc`**).+ |
+
| 318 | ++ |
+ #'+ |
+
| 319 | ++ |
+ #' @seealso [estimate_coef()].+ |
+
| 320 | ++ |
+ #'+ |
+
| 321 | ++ |
+ #' @examples+ |
+
| 322 | ++ |
+ #' library(dplyr)+ |
+
| 323 | ++ |
+ #'+ |
+
| 324 | ++ |
+ #' adtte <- tern_ex_adtte+ |
+
| 325 | ++ |
+ #' adtte_f <- subset(adtte, PARAMCD == "OS") # _f: filtered+ |
+
| 326 | ++ |
+ #' adtte_f <- filter(+ |
+
| 327 | ++ |
+ #' adtte_f,+ |
+
| 328 | ++ |
+ #' PARAMCD == "OS" &+ |
+
| 329 | ++ |
+ #' SEX %in% c("F", "M") &
+ |
+
| 330 | ++ |
+ #' RACE %in% c("ASIAN", "BLACK OR AFRICAN AMERICAN", "WHITE")
+ |
+
| 331 | ++ |
+ #' )+ |
+
| 332 | ++ |
+ #' adtte_f$SEX <- droplevels(adtte_f$SEX)+ |
+
| 333 | ++ |
+ #' adtte_f$RACE <- droplevels(adtte_f$RACE)+ |
+
| 334 | ++ |
+ #'+ |
+
| 335 | ++ |
+ #' @keywords internal+ |
+
| 336 | ++ |
+ s_cox_multivariate <- function(formula, data,+ |
+
| 337 | ++ |
+ conf_level = 0.95,+ |
+
| 338 | ++ |
+ pval_method = c("wald", "likelihood"),
+ |
+
| 339 | ++ |
+ ...) {
+ |
+
| 340 | +1x | +
+ tf <- stats::terms(formula, specials = c("strata"))
+ |
+
| 341 | +1x | +
+ covariates <- rownames(attr(tf, "factors"))[-c(1, unlist(attr(tf, "specials")))]+ |
+
| 342 | +1x | +
+ lapply(+ |
+
| 343 | +1x | +
+ X = covariates,+ |
+
| 344 | +1x | +
+ FUN = function(x) {
+ |
+
| 345 | +3x | +
+ if (is.character(data[[x]])) {
+ |
+
| 346 | +1x | +
+ data[[x]] <<- as.factor(data[[x]])+ |
+
| 347 | ++ |
+ }+ |
+
| 348 | +3x | +
+ invisible()+ |
+
| 349 | ++ |
+ }+ |
+
| 350 | ++ |
+ )+ |
+
| 351 | +1x | +
+ pval_method <- match.arg(pval_method)+ |
+
| 352 | ++ | + + | +
| 353 | ++ |
+ # Results directly exported from environment(fit_n_aov) to environment(s_function_draft)+ |
+
| 354 | +1x | +
+ y <- fit_n_aov(+ |
+
| 355 | +1x | +
+ formula = formula,+ |
+
| 356 | +1x | +
+ data = data,+ |
+
| 357 | +1x | +
+ conf_level = conf_level,+ |
+
| 358 | +1x | +
+ pval_method = pval_method,+ |
+
| 359 | ++ |
+ ...+ |
+
| 360 | ++ |
+ )+ |
+
| 361 | +1x | +
+ mod <- y$mod+ |
+
| 362 | +1x | +
+ aov <- y$aov+ |
+
| 363 | +1x | +
+ msum <- y$msum+ |
+
| 364 | +1x | +
+ list2env(as.list(y), environment())+ |
+
| 365 | ++ | + + | +
| 366 | +1x | +
+ all_term_labs <- attr(mod$terms, "term.labels")+ |
+
| 367 | +1x | +
+ term_labs <- all_term_labs[which(attr(mod$terms, "order") == 1)]+ |
+
| 368 | +1x | +
+ names(term_labs) <- term_labs+ |
+
| 369 | ++ | + + | +
| 370 | +1x | +
+ coef_inter <- NULL+ |
+
| 371 | +1x | +
+ if (any(attr(mod$terms, "order") > 1)) {
+ |
+
| 372 | +1x | +
+ for_inter <- all_term_labs[attr(mod$terms, "order") > 1]+ |
+
| 373 | +1x | +
+ names(for_inter) <- for_inter+ |
+
| 374 | +1x | +
+ mmat <- stats::model.matrix(mod)[1, ]+ |
+
| 375 | +1x | +
+ mmat[!mmat == 0] <- 0+ |
+
| 376 | +1x | +
+ mcoef <- stats::coef(mod)+ |
+
| 377 | +1x | +
+ mvcov <- stats::vcov(mod)+ |
+
| 378 | ++ | + + | +
| 379 | +1x | +
+ estimate_coef_local <- function(variable, given) {
+ |
+
| 380 | +6x | +
+ estimate_coef(+ |
+
| 381 | +6x | +
+ variable, given,+ |
+
| 382 | +6x | +
+ coef = mcoef, mmat = mmat, vcov = mvcov, conf_level = conf_level,+ |
+
| 383 | +6x | +
+ lvl_var = levels(data[[variable]]), lvl_given = levels(data[[given]])+ |
+
| 384 | ++ |
+ )+ |
+
| 385 | ++ |
+ }+ |
+
| 386 | ++ | + + | +
| 387 | +1x | +
+ coef_inter <- lapply(+ |
+
| 388 | +1x | +
+ for_inter, function(x) {
+ |
+
| 389 | +3x | +
+ y <- attr(mod$terms, "factor")[, x]+ |
+
| 390 | +3x | +
+ y <- names(y[y > 0])+ |
+
| 391 | +3x | +
+ Map(estimate_coef_local, variable = y, given = rev(y))+ |
+
| 392 | ++ |
+ }+ |
+
| 393 | ++ |
+ )+ |
+
| 394 | ++ |
+ }+ |
+
| 395 | ++ | + + | +
| 396 | +1x | +
+ list(mod = mod, msum = msum, aov = aov, coef_inter = coef_inter)+ |
+
| 397 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Convert List of Groups to Data Frame+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' This converts a list of group levels into a data frame format which is expected by [rtables::add_combo_levels()].+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @param groups_list (named `list` of `character`)\cr specifies the new group levels via the names and the+ |
+
| 6 | ++ |
+ #' levels that belong to it in the character vectors that are elements of the list.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @return [tibble::tibble()] in the required format.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @examples+ |
+
| 11 | ++ |
+ #' grade_groups <- list(+ |
+
| 12 | ++ |
+ #' "Any Grade (%)" = c("1", "2", "3", "4", "5"),
+ |
+
| 13 | ++ |
+ #' "Grade 3-4 (%)" = c("3", "4"),
+ |
+
| 14 | ++ |
+ #' "Grade 5 (%)" = "5"+ |
+
| 15 | ++ |
+ #' )+ |
+
| 16 | ++ |
+ #' groups_list_to_df(grade_groups)+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @export+ |
+
| 19 | ++ |
+ groups_list_to_df <- function(groups_list) {
+ |
+
| 20 | +5x | +
+ checkmate::assert_list(groups_list, names = "named")+ |
+
| 21 | +5x | +
+ lapply(groups_list, checkmate::assert_character)+ |
+
| 22 | +5x | +
+ tibble::tibble(+ |
+
| 23 | +5x | +
+ valname = make_names(names(groups_list)),+ |
+
| 24 | +5x | +
+ label = names(groups_list),+ |
+
| 25 | +5x | +
+ levelcombo = unname(groups_list),+ |
+
| 26 | +5x | +
+ exargs = replicate(length(groups_list), list())+ |
+
| 27 | ++ |
+ )+ |
+
| 28 | ++ |
+ }+ |
+
| 29 | ++ | + + | +
| 30 | ++ |
+ #' Reference and Treatment Group Combination+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' Facilitate the re-combination of groups divided as reference and treatment groups; it helps in arranging groups of+ |
+
| 35 | ++ |
+ #' columns in the `rtables` framework and teal modules.+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' @param fct (`factor`)\cr the variable with levels which needs to be grouped.+ |
+
| 38 | ++ |
+ #' @param ref (`string`)\cr the reference level(s).+ |
+
| 39 | ++ |
+ #' @param collapse (`string`)\cr a character string to separate `fct` and `ref`.+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' @return A `list` with first item `ref` (reference) and second item `trt` (treatment).+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' @examples+ |
+
| 44 | ++ |
+ #' groups <- combine_groups(+ |
+
| 45 | ++ |
+ #' fct = DM$ARM,+ |
+
| 46 | ++ |
+ #' ref = c("B: Placebo")
+ |
+
| 47 | ++ |
+ #' )+ |
+
| 48 | ++ |
+ #'+ |
+
| 49 | ++ |
+ #' basic_table() %>%+ |
+
| 50 | ++ |
+ #' split_cols_by_groups("ARM", groups) %>%
+ |
+
| 51 | ++ |
+ #' add_colcounts() %>%+ |
+
| 52 | ++ |
+ #' analyze_vars("AGE") %>%
+ |
+
| 53 | ++ |
+ #' build_table(DM)+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' @export+ |
+
| 56 | ++ |
+ combine_groups <- function(fct,+ |
+
| 57 | ++ |
+ ref = NULL,+ |
+
| 58 | ++ |
+ 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 | ++ | + + | +
| 63 | +10x | +
+ fct <- as_factor_keep_attributes(fct)+ |
+
| 64 | ++ | + + | +
| 65 | +10x | +
+ group_levels <- levels(fct)+ |
+
| 66 | +10x | +
+ if (is.null(ref)) {
+ |
+
| 67 | +6x | +
+ ref <- group_levels[1]+ |
+
| 68 | ++ |
+ } else {
+ |
+
| 69 | +4x | +
+ checkmate::assert_subset(ref, group_levels)+ |
+
| 70 | ++ |
+ }+ |
+
| 71 | ++ | + + | +
| 72 | +10x | +
+ groups <- list(+ |
+
| 73 | +10x | +
+ ref = group_levels[group_levels %in% ref],+ |
+
| 74 | +10x | +
+ trt = group_levels[!group_levels %in% ref]+ |
+
| 75 | ++ |
+ )+ |
+
| 76 | +10x | +
+ stats::setNames(groups, nm = lapply(groups, paste, collapse = collapse))+ |
+
| 77 | ++ |
+ }+ |
+
| 78 | ++ | + + | +
| 79 | ++ |
+ #' Split Columns by Groups of Levels+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 82 | ++ |
+ #'+ |
+
| 83 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 84 | ++ |
+ #' @inheritParams groups_list_to_df+ |
+
| 85 | ++ |
+ #' @param ... additional arguments to [rtables::split_cols_by()] in order. For instance, to+ |
+
| 86 | ++ |
+ #' control formats (`format`), add a joint column for all groups (`incl_all`).+ |
+
| 87 | ++ |
+ #'+ |
+
| 88 | ++ |
+ #' @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 | ++ |
+ #' groups to the table layout.+ |
+
| 91 | ++ |
+ #'+ |
+
| 92 | ++ |
+ #' @seealso [rtables::split_cols_by()]+ |
+
| 93 | ++ |
+ #'+ |
+
| 94 | ++ |
+ #' @examples+ |
+
| 95 | ++ |
+ #' # 1 - Basic use+ |
+
| 96 | ++ |
+ #'+ |
+
| 97 | ++ |
+ #' # Without group combination `split_cols_by_groups` is+ |
+
| 98 | ++ |
+ #' # equivalent to [rtables::split_cols_by()].+ |
+
| 99 | ++ |
+ #' basic_table() %>%+ |
+
| 100 | ++ |
+ #' split_cols_by_groups("ARM") %>%
+ |
+
| 101 | ++ |
+ #' add_colcounts() %>%+ |
+
| 102 | ++ |
+ #' analyze("AGE") %>%
+ |
+
| 103 | ++ |
+ #' build_table(DM)+ |
+
| 104 | ++ |
+ #'+ |
+
| 105 | ++ |
+ #' # Add a reference column.+ |
+
| 106 | ++ |
+ #' basic_table() %>%+ |
+
| 107 | ++ |
+ #' split_cols_by_groups("ARM", ref_group = "B: Placebo") %>%
+ |
+
| 108 | ++ |
+ #' add_colcounts() %>%+ |
+
| 109 | ++ |
+ #' analyze(+ |
+
| 110 | ++ |
+ #' "AGE",+ |
+
| 111 | ++ |
+ #' afun = function(x, .ref_group, .in_ref_col) {
+ |
+
| 112 | ++ |
+ #' if (.in_ref_col) {
+ |
+
| 113 | ++ |
+ #' in_rows("Diff Mean" = rcell(NULL))
+ |
+
| 114 | ++ |
+ #' } else {
+ |
+
| 115 | ++ |
+ #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+ |
+
| 116 | ++ |
+ #' }+ |
+
| 117 | ++ |
+ #' }+ |
+
| 118 | ++ |
+ #' ) %>%+ |
+
| 119 | ++ |
+ #' build_table(DM)+ |
+
| 120 | ++ |
+ #'+ |
+
| 121 | ++ |
+ #' # 2 - Adding group specification+ |
+
| 122 | ++ |
+ #'+ |
+
| 123 | ++ |
+ #' # Manual preparation of the groups.+ |
+
| 124 | ++ |
+ #' groups <- list(+ |
+
| 125 | ++ |
+ #' "Arms A+B" = c("A: Drug X", "B: Placebo"),
+ |
+
| 126 | ++ |
+ #' "Arms A+C" = c("A: Drug X", "C: Combination")
+ |
+
| 127 | ++ |
+ #' )+ |
+
| 128 | ++ |
+ #'+ |
+
| 129 | ++ |
+ #' # Use of split_cols_by_groups without reference column.+ |
+
| 130 | ++ |
+ #' basic_table() %>%+ |
+
| 131 | ++ |
+ #' split_cols_by_groups("ARM", groups) %>%
+ |
+
| 132 | ++ |
+ #' add_colcounts() %>%+ |
+
| 133 | ++ |
+ #' analyze("AGE") %>%
+ |
+
| 134 | ++ |
+ #' build_table(DM)+ |
+
| 135 | ++ |
+ #'+ |
+
| 136 | ++ |
+ #' # Including differentiated output in the reference column.+ |
+
| 137 | ++ |
+ #' basic_table() %>%+ |
+
| 138 | ++ |
+ #' split_cols_by_groups("ARM", groups_list = groups, ref_group = "Arms A+B") %>%
+ |
+
| 139 | ++ |
+ #' analyze(+ |
+
| 140 | ++ |
+ #' "AGE",+ |
+
| 141 | ++ |
+ #' afun = function(x, .ref_group, .in_ref_col) {
+ |
+
| 142 | ++ |
+ #' if (.in_ref_col) {
+ |
+
| 143 | ++ |
+ #' in_rows("Diff. of Averages" = rcell(NULL))
+ |
+
| 144 | ++ |
+ #' } else {
+ |
+
| 145 | ++ |
+ #' in_rows("Diff. of Averages" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+ |
+
| 146 | ++ |
+ #' }+ |
+
| 147 | ++ |
+ #' }+ |
+
| 148 | ++ |
+ #' ) %>%+ |
+
| 149 | ++ |
+ #' build_table(DM)+ |
+
| 150 | ++ |
+ #'+ |
+
| 151 | ++ |
+ #' # 3 - Binary list dividing factor levels into reference and treatment+ |
+
| 152 | ++ |
+ #'+ |
+
| 153 | ++ |
+ #' # `combine_groups` defines reference and treatment.+ |
+
| 154 | ++ |
+ #' groups <- combine_groups(+ |
+
| 155 | ++ |
+ #' fct = DM$ARM,+ |
+
| 156 | ++ |
+ #' ref = c("A: Drug X", "B: Placebo")
+ |
+
| 157 | ++ |
+ #' )+ |
+
| 158 | ++ |
+ #' groups+ |
+
| 159 | ++ |
+ #'+ |
+
| 160 | ++ |
+ #' # Use group definition without reference column.+ |
+
| 161 | ++ |
+ #' basic_table() %>%+ |
+
| 162 | ++ |
+ #' split_cols_by_groups("ARM", groups_list = groups) %>%
+ |
+
| 163 | ++ |
+ #' add_colcounts() %>%+ |
+
| 164 | ++ |
+ #' analyze("AGE") %>%
+ |
+
| 165 | ++ |
+ #' build_table(DM)+ |
+
| 166 | ++ |
+ #'+ |
+
| 167 | ++ |
+ #' # Use group definition with reference column (first item of groups).+ |
+
| 168 | ++ |
+ #' basic_table() %>%+ |
+
| 169 | ++ |
+ #' split_cols_by_groups("ARM", groups, ref_group = names(groups)[1]) %>%
+ |
+
| 170 | ++ |
+ #' add_colcounts() %>%+ |
+
| 171 | ++ |
+ #' analyze(+ |
+
| 172 | ++ |
+ #' "AGE",+ |
+
| 173 | ++ |
+ #' afun = function(x, .ref_group, .in_ref_col) {
+ |
+
| 174 | ++ |
+ #' if (.in_ref_col) {
+ |
+
| 175 | ++ |
+ #' in_rows("Diff Mean" = rcell(NULL))
+ |
+
| 176 | ++ |
+ #' } else {
+ |
+
| 177 | ++ |
+ #' in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
+ |
+
| 178 | ++ |
+ #' }+ |
+
| 179 | ++ |
+ #' }+ |
+
| 180 | ++ |
+ #' ) %>%+ |
+
| 181 | ++ |
+ #' build_table(DM)+ |
+
| 182 | ++ |
+ #'+ |
+
| 183 | ++ |
+ #' @export+ |
+
| 184 | ++ |
+ split_cols_by_groups <- function(lyt,+ |
+
| 185 | ++ |
+ var,+ |
+
| 186 | ++ |
+ groups_list = NULL,+ |
+
| 187 | ++ |
+ ref_group = NULL,+ |
+
| 188 | ++ |
+ ...) {
+ |
+
| 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 | ++ |
+ ...+ |
+
| 195 | ++ |
+ )+ |
+
| 196 | ++ |
+ } else {
+ |
+
| 197 | +4x | +
+ groups_df <- groups_list_to_df(groups_list)+ |
+
| 198 | +4x | +
+ if (!is.null(ref_group)) {
+ |
+
| 199 | +3x | +
+ ref_group <- groups_df$valname[groups_df$label == ref_group]+ |
+
| 200 | ++ |
+ }+ |
+
| 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,+ |
+
| 206 | ++ |
+ ...+ |
+
| 207 | ++ |
+ )+ |
+
| 208 | ++ |
+ }+ |
+
| 209 | ++ |
+ }+ |
+
| 210 | ++ | + + | +
| 211 | ++ |
+ #' Combine Counts+ |
+
| 212 | ++ |
+ #'+ |
+
| 213 | ++ |
+ #' Simplifies the estimation of column counts, especially when group combination is required.+ |
+
| 214 | ++ |
+ #'+ |
+
| 215 | ++ |
+ #' @inheritParams combine_groups+ |
+
| 216 | ++ |
+ #' @inheritParams groups_list_to_df+ |
+
| 217 | ++ |
+ #'+ |
+
| 218 | ++ |
+ #' @return A `vector` of column counts.+ |
+
| 219 | ++ |
+ #'+ |
+
| 220 | ++ |
+ #' @seealso [combine_groups()]+ |
+
| 221 | ++ |
+ #'+ |
+
| 222 | ++ |
+ #' @examples+ |
+
| 223 | ++ |
+ #' ref <- c("A: Drug X", "B: Placebo")
+ |
+
| 224 | ++ |
+ #' groups <- combine_groups(fct = DM$ARM, ref = ref)+ |
+
| 225 | ++ |
+ #'+ |
+
| 226 | ++ |
+ #' col_counts <- combine_counts(+ |
+
| 227 | ++ |
+ #' fct = DM$ARM,+ |
+
| 228 | ++ |
+ #' groups_list = groups+ |
+
| 229 | ++ |
+ #' )+ |
+
| 230 | ++ |
+ #'+ |
+
| 231 | ++ |
+ #' basic_table() %>%+ |
+
| 232 | ++ |
+ #' split_cols_by_groups("ARM", groups) %>%
+ |
+
| 233 | ++ |
+ #' add_colcounts() %>%+ |
+
| 234 | ++ |
+ #' analyze_vars("AGE") %>%
+ |
+
| 235 | ++ |
+ #' build_table(DM, col_counts = col_counts)+ |
+
| 236 | ++ |
+ #'+ |
+
| 237 | ++ |
+ #' ref <- "A: Drug X"+ |
+
| 238 | ++ |
+ #' groups <- combine_groups(fct = DM$ARM, ref = ref)+ |
+
| 239 | ++ |
+ #' col_counts <- combine_counts(+ |
+
| 240 | ++ |
+ #' fct = DM$ARM,+ |
+
| 241 | ++ |
+ #' groups_list = groups+ |
+
| 242 | ++ |
+ #' )+ |
+
| 243 | ++ |
+ #'+ |
+
| 244 | ++ |
+ #' basic_table() %>%+ |
+
| 245 | ++ |
+ #' split_cols_by_groups("ARM", groups) %>%
+ |
+
| 246 | ++ |
+ #' add_colcounts() %>%+ |
+
| 247 | ++ |
+ #' analyze_vars("AGE") %>%
+ |
+
| 248 | ++ |
+ #' build_table(DM, col_counts = col_counts)+ |
+
| 249 | ++ |
+ #'+ |
+
| 250 | ++ |
+ #' @export+ |
+
| 251 | ++ |
+ combine_counts <- function(fct, groups_list = NULL) {
+ |
+
| 252 | +4x | +
+ checkmate::assert_multi_class(fct, classes = c("factor", "character"))
+ |
+
| 253 | ++ | + + | +
| 254 | +4x | +
+ fct <- as_factor_keep_attributes(fct)+ |
+
| 255 | ++ | + + | +
| 256 | +4x | +
+ if (is.null(groups_list)) {
+ |
+
| 257 | +1x | +
+ y <- table(fct)+ |
+
| 258 | +1x | +
+ y <- stats::setNames(as.numeric(y), nm = dimnames(y)[[1]])+ |
+
| 259 | ++ |
+ } else {
+ |
+
| 260 | +3x | +
+ y <- vapply(+ |
+
| 261 | +3x | +
+ X = groups_list,+ |
+
| 262 | +3x | +
+ FUN = function(x) sum(table(fct)[x]),+ |
+
| 263 | +3x | +
+ FUN.VALUE = 1+ |
+
| 264 | ++ |
+ )+ |
+
| 265 | ++ |
+ }+ |
+
| 266 | +4x | +
+ y+ |
+
| 267 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Summary for Poisson Negative Binomial.+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("experimental")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Summarize results of a Poisson Negative Binomial Regression.+ |
+
| 6 | ++ |
+ #' This can be used to analyze count and/or frequency data using a linear model.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @name summarize_glm_count+ |
+
| 11 | ++ |
+ NULL+ |
+
| 12 | ++ | + + | +
| 13 | ++ |
+ #' Helper Functions for Poisson Models.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @description `r lifecycle::badge("experimental")`
+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' Helper functions that can be used to return the results of various Poisson models.+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @seealso [summarize_glm_count]+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @name h_glm_count+ |
+
| 24 | ++ |
+ NULL+ |
+
| 25 | ++ | + + | +
| 26 | ++ |
+ #' @describeIn h_glm_count Helper function to return results of a poisson model.+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called+ |
+
| 29 | ++ |
+ #' in `.var` and `variables`.+ |
+
| 30 | ++ |
+ #' @param variables (named `list` of `strings`)\cr list of additional analysis variables, with+ |
+
| 31 | ++ |
+ #' expected elements:+ |
+
| 32 | ++ |
+ #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple+ |
+
| 33 | ++ |
+ #' groups will be summarized. Specifically, the first level of `arm` variable is taken as the+ |
+
| 34 | ++ |
+ #' reference group.+ |
+
| 35 | ++ |
+ #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as+ |
+
| 36 | ++ |
+ #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`.+ |
+
| 37 | ++ |
+ #' * `offset` (`numeric`)\cr a numeric vector or scalar adding an offset.+ |
+
| 38 | ++ |
+ #' @param weights (`character`)\cr a character vector specifying weights used+ |
+
| 39 | ++ |
+ #' in averaging predictions. Number of weights must equal the number of levels included in the covariates.+ |
+
| 40 | ++ |
+ #' Weights option passed to [emmeans::emmeans()].+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' @return+ |
+
| 43 | ++ |
+ #' * `h_glm_poisson()` returns the results of a Poisson model.+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' @keywords internal+ |
+
| 46 | ++ |
+ h_glm_poisson <- function(.var,+ |
+
| 47 | ++ |
+ .df_row,+ |
+
| 48 | ++ |
+ variables,+ |
+
| 49 | ++ |
+ weights) {
+ |
+
| 50 | +12x | +
+ arm <- variables$arm+ |
+
| 51 | +12x | +
+ covariates <- variables$covariates+ |
+
| 52 | +12x | +
+ offset <- .df_row[[variables$offset]]+ |
+
| 53 | ++ | + + | +
| 54 | +10x | +
+ formula <- stats::as.formula(paste0(+ |
+
| 55 | +10x | +
+ .var, " ~ ",+ |
+
| 56 | ++ |
+ " + ",+ |
+
| 57 | +10x | +
+ paste(covariates, collapse = " + "),+ |
+
| 58 | ++ |
+ " + ",+ |
+
| 59 | +10x | +
+ arm+ |
+
| 60 | ++ |
+ ))+ |
+
| 61 | ++ | + + | +
| 62 | +10x | +
+ glm_fit <- stats::glm(+ |
+
| 63 | +10x | +
+ formula = formula,+ |
+
| 64 | +10x | +
+ offset = offset,+ |
+
| 65 | +10x | +
+ data = .df_row,+ |
+
| 66 | +10x | +
+ family = stats::poisson(link = "log")+ |
+
| 67 | ++ |
+ )+ |
+
| 68 | ++ | + + | +
| 69 | +10x | +
+ emmeans_fit <- emmeans::emmeans(+ |
+
| 70 | +10x | +
+ glm_fit,+ |
+
| 71 | +10x | +
+ specs = arm,+ |
+
| 72 | +10x | +
+ data = .df_row,+ |
+
| 73 | +10x | +
+ type = "response",+ |
+
| 74 | +10x | +
+ offset = 0,+ |
+
| 75 | +10x | +
+ weights = weights+ |
+
| 76 | ++ |
+ )+ |
+
| 77 | ++ | + + | +
| 78 | +10x | +
+ list(+ |
+
| 79 | +10x | +
+ glm_fit = glm_fit,+ |
+
| 80 | +10x | +
+ emmeans_fit = emmeans_fit+ |
+
| 81 | ++ |
+ )+ |
+
| 82 | ++ |
+ }+ |
+
| 83 | ++ | + + | +
| 84 | ++ |
+ #' @describeIn h_glm_count Helper function to return results of a quasipoisson model.+ |
+
| 85 | ++ |
+ #'+ |
+
| 86 | ++ |
+ #' @inheritParams summarize_glm_count+ |
+
| 87 | ++ |
+ #'+ |
+
| 88 | ++ |
+ #' @return+ |
+
| 89 | ++ |
+ #' * `h_glm_quasipoisson()` returns the results of a Quasi-Poisson model.+ |
+
| 90 | ++ |
+ #'+ |
+
| 91 | ++ |
+ #'+ |
+
| 92 | ++ |
+ #' @keywords internal+ |
+
| 93 | ++ |
+ h_glm_quasipoisson <- function(.var,+ |
+
| 94 | ++ |
+ .df_row,+ |
+
| 95 | ++ |
+ variables,+ |
+
| 96 | ++ |
+ weights) {
+ |
+
| 97 | +4x | +
+ arm <- variables$arm+ |
+
| 98 | +4x | +
+ covariates <- variables$covariates+ |
+
| 99 | +4x | +
+ offset <- .df_row[[variables$offset]]+ |
+
| 100 | ++ | + + | +
| 101 | +2x | +
+ formula <- stats::as.formula(paste0(+ |
+
| 102 | +2x | +
+ .var, " ~ ",+ |
+
| 103 | ++ |
+ " + ",+ |
+
| 104 | +2x | +
+ paste(covariates, collapse = " + "),+ |
+
| 105 | ++ |
+ " + ",+ |
+
| 106 | +2x | +
+ arm+ |
+
| 107 | ++ |
+ ))+ |
+
| 108 | ++ | + + | +
| 109 | +2x | +
+ glm_fit <- stats::glm(+ |
+
| 110 | +2x | +
+ formula = formula,+ |
+
| 111 | +2x | +
+ offset = offset,+ |
+
| 112 | +2x | +
+ data = .df_row,+ |
+
| 113 | +2x | +
+ family = stats::quasipoisson(link = "log")+ |
+
| 114 | ++ |
+ )+ |
+
| 115 | ++ | + + | +
| 116 | +2x | +
+ emmeans_fit <- emmeans::emmeans(+ |
+
| 117 | +2x | +
+ glm_fit,+ |
+
| 118 | +2x | +
+ specs = arm,+ |
+
| 119 | +2x | +
+ data = .df_row,+ |
+
| 120 | +2x | +
+ type = "response",+ |
+
| 121 | +2x | +
+ offset = 0,+ |
+
| 122 | +2x | +
+ weights = weights+ |
+
| 123 | ++ |
+ )+ |
+
| 124 | ++ | + + | +
| 125 | +2x | +
+ list(+ |
+
| 126 | +2x | +
+ glm_fit = glm_fit,+ |
+
| 127 | +2x | +
+ emmeans_fit = emmeans_fit+ |
+
| 128 | ++ |
+ )+ |
+
| 129 | ++ |
+ }+ |
+
| 130 | ++ | + + | +
| 131 | ++ |
+ #' @describeIn h_glm_count Helper function to return the results of the+ |
+
| 132 | ++ |
+ #' selected model (poisson, quasipoisson, negative binomial).+ |
+
| 133 | ++ |
+ #'+ |
+
| 134 | ++ |
+ #' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called+ |
+
| 135 | ++ |
+ #' in `.var` and `variables`.+ |
+
| 136 | ++ |
+ #' @param variables (named `list` of `strings`)\cr list of additional analysis variables, with+ |
+
| 137 | ++ |
+ #' expected elements:+ |
+
| 138 | ++ |
+ #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple+ |
+
| 139 | ++ |
+ #' groups will be summarized. Specifically, the first level of `arm` variable is taken as the+ |
+
| 140 | ++ |
+ #' reference group.+ |
+
| 141 | ++ |
+ #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as+ |
+
| 142 | ++ |
+ #' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`.+ |
+
| 143 | ++ |
+ #' * `offset` (`numeric`)\cr a numeric vector or scalar adding an offset.+ |
+
| 144 | ++ |
+ #' @param distribution (`character`)\cr a character value specifying the distribution+ |
+
| 145 | ++ |
+ #' used in the regression (poisson, quasipoisson).+ |
+
| 146 | ++ |
+ #'+ |
+
| 147 | ++ |
+ #' @return+ |
+
| 148 | ++ |
+ #' * `h_glm_count()` returns the results of the selected model.+ |
+
| 149 | ++ |
+ #'+ |
+
| 150 | ++ |
+ #'+ |
+
| 151 | ++ |
+ #' @keywords internal+ |
+
| 152 | ++ |
+ h_glm_count <- function(.var,+ |
+
| 153 | ++ |
+ .df_row,+ |
+
| 154 | ++ |
+ variables,+ |
+
| 155 | ++ |
+ distribution,+ |
+
| 156 | ++ |
+ weights) {
+ |
+
| 157 | +11x | +
+ if (distribution == "negbin") {
+ |
+
| 158 | +! | +
+ stop("negative binomial distribution is not currently available.")
+ |
+
| 159 | ++ |
+ }+ |
+
| 160 | +9x | +
+ switch(distribution,+ |
+
| 161 | +9x | +
+ poisson = h_glm_poisson(.var, .df_row, variables, weights),+ |
+
| 162 | +! | +
+ quasipoisson = h_glm_quasipoisson(.var, .df_row, variables, weights),+ |
+
| 163 | +! | +
+ negbin = list() # h_glm_negbin(.var, .df_row, variables, weights) # nolint+ |
+
| 164 | ++ |
+ )+ |
+
| 165 | ++ |
+ }+ |
+
| 166 | ++ | + + | +
| 167 | ++ |
+ #' @describeIn h_glm_count Helper function to return the estimated means.+ |
+
| 168 | ++ |
+ #'+ |
+
| 169 | ++ |
+ #' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called in `.var` and `variables`.+ |
+
| 170 | ++ |
+ #' @param conf_level (`numeric`)\cr value used to derive the confidence interval for the rate.+ |
+
| 171 | ++ |
+ #' @param obj (`glm.fit`)\cr fitted model object used to derive the mean rate estimates in each treatment arm.+ |
+
| 172 | ++ |
+ #' @param arm (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be+ |
+
| 173 | ++ |
+ #' summarized. Specifically, the first level of `arm` variable is taken as the reference group.+ |
+
| 174 | ++ |
+ #'+ |
+
| 175 | ++ |
+ #' @return+ |
+
| 176 | ++ |
+ #' * `h_ppmeans()` returns the estimated means.+ |
+
| 177 | ++ |
+ #'+ |
+
| 178 | ++ |
+ #'+ |
+
| 179 | ++ |
+ #' @keywords internal+ |
+
| 180 | ++ |
+ h_ppmeans <- function(obj, .df_row, arm, conf_level) {
+ |
+
| 181 | +! | +
+ alpha <- 1 - conf_level+ |
+
| 182 | +! | +
+ p <- 1 - alpha / 2+ |
+
| 183 | ++ | + + | +
| 184 | +! | +
+ arm_levels <- levels(.df_row[[arm]])+ |
+
| 185 | ++ | + + | +
| 186 | +! | +
+ out <- lapply(arm_levels, function(lev) {
+ |
+
| 187 | +! | +
+ temp <- .df_row+ |
+
| 188 | +! | +
+ temp[[arm]] <- factor(lev, levels = arm_levels)+ |
+
| 189 | ++ | + + | +
| 190 | +! | +
+ mf <- stats::model.frame(obj$formula, data = temp)+ |
+
| 191 | +! | +
+ X <- stats::model.matrix(obj$formula, data = mf) # nolint+ |
+
| 192 | ++ | + + | +
| 193 | +! | +
+ rate <- stats::predict(obj, newdata = mf, type = "response")+ |
+
| 194 | +! | +
+ rate_hat <- mean(rate)+ |
+
| 195 | ++ | + + | +
| 196 | +! | +
+ zz <- colMeans(rate * X)+ |
+
| 197 | +! | +
+ se <- sqrt(as.numeric(t(zz) %*% stats::vcov(obj) %*% zz))+ |
+
| 198 | +! | +
+ rate_lwr <- rate_hat * exp(-stats::qnorm(p) * se / rate_hat)+ |
+
| 199 | +! | +
+ rate_upr <- rate_hat * exp(stats::qnorm(p) * se / rate_hat)+ |
+
| 200 | ++ | + + | +
| 201 | +! | +
+ c(rate_hat, rate_lwr, rate_upr)+ |
+
| 202 | ++ |
+ })+ |
+
| 203 | ++ | + + | +
| 204 | +! | +
+ names(out) <- arm_levels+ |
+
| 205 | +! | +
+ out <- do.call(rbind, out)+ |
+
| 206 | +! | +
+ if ("negbin" %in% class(obj)) {
+ |
+
| 207 | +! | +
+ colnames(out) <- c("response", "asymp.LCL", "asymp.UCL")
+ |
+
| 208 | ++ |
+ } else {
+ |
+
| 209 | +! | +
+ colnames(out) <- c("rate", "asymp.LCL", "asymp.UCL")
+ |
+
| 210 | ++ |
+ }+ |
+
| 211 | +! | +
+ out <- as.data.frame(out)+ |
+
| 212 | +! | +
+ out[[arm]] <- rownames(out)+ |
+
| 213 | +! | +
+ out+ |
+
| 214 | ++ |
+ }+ |
+
| 215 | ++ | + + | +
| 216 | ++ |
+ #' @describeIn summarize_glm_count Statistics function that produces a named list of results+ |
+
| 217 | ++ |
+ #' of the investigated Poisson model.+ |
+
| 218 | ++ |
+ #'+ |
+
| 219 | ++ |
+ #' @inheritParams h_glm_count+ |
+
| 220 | ++ |
+ #'+ |
+
| 221 | ++ |
+ #' @return+ |
+
| 222 | ++ |
+ #' * `s_glm_count()` returns a named `list` of 5 statistics:+ |
+
| 223 | ++ |
+ #' * `n`: Count of complete sample size for the group.+ |
+
| 224 | ++ |
+ #' * `rate`: Estimated event rate per follow-up time.+ |
+
| 225 | ++ |
+ #' * `rate_ci`: Confidence level for estimated rate per follow-up time.+ |
+
| 226 | ++ |
+ #' * `rate_ratio`: Ratio of event rates in each treatment arm to the reference arm.+ |
+
| 227 | ++ |
+ #' * `rate_ratio_ci`: Confidence level for the rate ratio.+ |
+
| 228 | ++ |
+ #' * `pval`: p-value.+ |
+
| 229 | ++ |
+ #'+ |
+
| 230 | ++ |
+ #'+ |
+
| 231 | ++ |
+ #' @keywords internal+ |
+
| 232 | ++ |
+ s_glm_count <- function(df,+ |
+
| 233 | ++ |
+ .var,+ |
+
| 234 | ++ |
+ .df_row,+ |
+
| 235 | ++ |
+ variables,+ |
+
| 236 | ++ |
+ .ref_group,+ |
+
| 237 | ++ |
+ .in_ref_col,+ |
+
| 238 | ++ |
+ distribution,+ |
+
| 239 | ++ |
+ conf_level,+ |
+
| 240 | ++ |
+ rate_mean_method,+ |
+
| 241 | ++ |
+ weights,+ |
+
| 242 | ++ |
+ scale = 1) {
+ |
+
| 243 | +3x | +
+ arm <- variables$arm+ |
+
| 244 | ++ | + + | +
| 245 | +3x | +
+ y <- df[[.var]]+ |
+
| 246 | +2x | +
+ smry_level <- as.character(unique(df[[arm]]))+ |
+
| 247 | ++ | + + | +
| 248 | ++ |
+ # ensure there is only 1 value+ |
+
| 249 | +2x | +
+ checkmate::assert_scalar(smry_level)+ |
+
| 250 | ++ | + + | +
| 251 | +2x | +
+ results <- h_glm_count(+ |
+
| 252 | +2x | +
+ .var = .var,+ |
+
| 253 | +2x | +
+ .df_row = .df_row,+ |
+
| 254 | +2x | +
+ variables = variables,+ |
+
| 255 | +2x | +
+ distribution = distribution,+ |
+
| 256 | +2x | +
+ weights+ |
+
| 257 | ++ |
+ )+ |
+
| 258 | ++ | + + | +
| 259 | +2x | +
+ if (rate_mean_method == "emmeans") {
+ |
+
| 260 | +2x | +
+ emmeans_smry <- summary(results$emmeans_fit, level = conf_level)+ |
+
| 261 | +! | +
+ } else if (rate_mean_method == "ppmeans") {
+ |
+
| 262 | +! | +
+ emmeans_smry <- h_ppmeans(results$glm_fit, .df_row, arm, conf_level)+ |
+
| 263 | ++ |
+ }+ |
+
| 264 | ++ | + + | +
| 265 | +2x | +
+ emmeans_smry_level <- emmeans_smry[emmeans_smry[[arm]] == smry_level, ]+ |
+
| 266 | ++ | + + | +
| 267 | +2x | +
+ if (.in_ref_col) {
+ |
+
| 268 | +1x | +
+ list(+ |
+
| 269 | +1x | +
+ n = length(y[!is.na(y)]),+ |
+
| 270 | +1x | +
+ rate = formatters::with_label(+ |
+
| 271 | +1x | +
+ ifelse(distribution == "negbin", emmeans_smry_level$response * scale, emmeans_smry_level$rate),+ |
+
| 272 | +1x | +
+ "Adjusted Rate"+ |
+
| 273 | ++ |
+ ),+ |
+
| 274 | +1x | +
+ rate_ci = formatters::with_label(+ |
+
| 275 | +1x | +
+ c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale),+ |
+
| 276 | +1x | +
+ f_conf_level(conf_level)+ |
+
| 277 | ++ |
+ ),+ |
+
| 278 | +1x | +
+ rate_ratio = formatters::with_label(character(), "Adjusted Rate Ratio"),+ |
+
| 279 | +1x | +
+ rate_ratio_ci = formatters::with_label(character(), f_conf_level(conf_level)),+ |
+
| 280 | +1x | +
+ pval = formatters::with_label(character(), "p-value")+ |
+
| 281 | ++ |
+ )+ |
+
| 282 | ++ |
+ } else {
+ |
+
| 283 | +1x | +
+ emmeans_contrasts <- emmeans::contrast(+ |
+
| 284 | +1x | +
+ results$emmeans_fit,+ |
+
| 285 | +1x | +
+ method = "trt.vs.ctrl",+ |
+
| 286 | +1x | +
+ ref = grep(+ |
+
| 287 | +1x | +
+ as.character(unique(.ref_group[[arm]])),+ |
+
| 288 | +1x | +
+ as.data.frame(results$emmeans_fit)[[arm]]+ |
+
| 289 | ++ |
+ )+ |
+
| 290 | ++ |
+ )+ |
+
| 291 | ++ | + + | +
| 292 | +1x | +
+ contrasts_smry <- summary(+ |
+
| 293 | +1x | +
+ emmeans_contrasts,+ |
+
| 294 | +1x | +
+ infer = TRUE,+ |
+
| 295 | +1x | +
+ adjust = "none"+ |
+
| 296 | ++ |
+ )+ |
+
| 297 | ++ | + + | +
| 298 | +1x | +
+ smry_contrasts_level <- contrasts_smry[grepl(smry_level, contrasts_smry$contrast), ]+ |
+
| 299 | ++ | + + | +
| 300 | +1x | +
+ list(+ |
+
| 301 | +1x | +
+ n = length(y[!is.na(y)]),+ |
+
| 302 | +1x | +
+ rate = formatters::with_label(+ |
+
| 303 | +1x | +
+ ifelse(distribution == "negbin", emmeans_smry_level$response * scale, emmeans_smry_level$rate),+ |
+
| 304 | +1x | +
+ "Adjusted Rate"+ |
+
| 305 | ++ |
+ ),+ |
+
| 306 | +1x | +
+ rate_ci = formatters::with_label(+ |
+
| 307 | +1x | +
+ c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale),+ |
+
| 308 | +1x | +
+ f_conf_level(conf_level)+ |
+
| 309 | ++ |
+ ),+ |
+
| 310 | +1x | +
+ rate_ratio = formatters::with_label(smry_contrasts_level$ratio, "Adjusted Rate Ratio"),+ |
+
| 311 | +1x | +
+ rate_ratio_ci = formatters::with_label(+ |
+
| 312 | +1x | +
+ c(smry_contrasts_level$asymp.LCL, smry_contrasts_level$asymp.UCL),+ |
+
| 313 | +1x | +
+ f_conf_level(conf_level)+ |
+
| 314 | ++ |
+ ),+ |
+
| 315 | +1x | +
+ pval = formatters::with_label(smry_contrasts_level$p.value, "p-value")+ |
+
| 316 | ++ |
+ )+ |
+
| 317 | ++ |
+ }+ |
+
| 318 | ++ |
+ }+ |
+
| 319 | ++ | + + | +
| 320 | ++ |
+ #' @describeIn summarize_glm_count Formatted analysis function which is used as `afun` in `summarize_glm_count()`.+ |
+
| 321 | ++ |
+ #'+ |
+
| 322 | ++ |
+ #' @return+ |
+
| 323 | ++ |
+ #' * `a_glm_count()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 324 | ++ |
+ #'+ |
+
| 325 | ++ |
+ #'+ |
+
| 326 | ++ |
+ #' @keywords internal+ |
+
| 327 | ++ |
+ a_glm_count <- make_afun(+ |
+
| 328 | ++ |
+ s_glm_count,+ |
+
| 329 | ++ |
+ .indent_mods = c(+ |
+
| 330 | ++ |
+ "n" = 0L,+ |
+
| 331 | ++ |
+ "rate" = 0L,+ |
+
| 332 | ++ |
+ "rate_ci" = 1L,+ |
+
| 333 | ++ |
+ "rate_ratio" = 0L,+ |
+
| 334 | ++ |
+ "rate_ratio_ci" = 1L,+ |
+
| 335 | ++ |
+ "pval" = 1L+ |
+
| 336 | ++ |
+ ),+ |
+
| 337 | ++ |
+ .formats = c(+ |
+
| 338 | ++ |
+ "n" = "xx",+ |
+
| 339 | ++ |
+ "rate" = "xx.xxxx",+ |
+
| 340 | ++ |
+ "rate_ci" = "(xx.xxxx, xx.xxxx)",+ |
+
| 341 | ++ |
+ "rate_ratio" = "xx.xxxx",+ |
+
| 342 | ++ |
+ "rate_ratio_ci" = "(xx.xxxx, xx.xxxx)",+ |
+
| 343 | ++ |
+ "pval" = "x.xxxx | (<0.0001)"+ |
+
| 344 | ++ |
+ ),+ |
+
| 345 | ++ |
+ .null_ref_cells = FALSE+ |
+
| 346 | ++ |
+ )+ |
+
| 347 | ++ | + + | +
| 348 | ++ |
+ #' @describeIn summarize_glm_count Layout-creating function which can take statistics function arguments+ |
+
| 349 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 350 | ++ |
+ #'+ |
+
| 351 | ++ |
+ #' @return+ |
+
| 352 | ++ |
+ #' * `summarize_glm_count()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 353 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 354 | ++ |
+ #' the statistics from `s_glm_count()` to the table layout.+ |
+
| 355 | ++ |
+ #'+ |
+
| 356 | ++ |
+ #' @examples+ |
+
| 357 | ++ |
+ #' library(dplyr)+ |
+
| 358 | ++ |
+ #' anl <- tern_ex_adtte %>% filter(PARAMCD == "TNE")+ |
+
| 359 | ++ |
+ #' anl$AVAL_f <- as.factor(anl$AVAL)+ |
+
| 360 | ++ |
+ #'+ |
+
| 361 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 362 | ++ |
+ #' split_cols_by("ARM", ref_group = "B: Placebo") %>%
+ |
+
| 363 | ++ |
+ #' add_colcounts() %>%+ |
+
| 364 | ++ |
+ #' analyze_vars(+ |
+
| 365 | ++ |
+ #' "AVAL_f",+ |
+
| 366 | ++ |
+ #' var_labels = "Number of exacerbations per patient",+ |
+
| 367 | ++ |
+ #' .stats = c("count_fraction"),
+ |
+
| 368 | ++ |
+ #' .formats = c("count_fraction" = "xx (xx.xx%)"),
+ |
+
| 369 | ++ |
+ #' .label = c("Number of exacerbations per patient")
+ |
+
| 370 | ++ |
+ #' ) %>%+ |
+
| 371 | ++ |
+ #' summarize_glm_count(+ |
+
| 372 | ++ |
+ #' vars = "AVAL",+ |
+
| 373 | ++ |
+ #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = NULL),+ |
+
| 374 | ++ |
+ #' conf_level = 0.95,+ |
+
| 375 | ++ |
+ #' distribution = "poisson",+ |
+
| 376 | ++ |
+ #' rate_mean_method = "emmeans",+ |
+
| 377 | ++ |
+ #' var_labels = "Unadjusted exacerbation rate (per year)",+ |
+
| 378 | ++ |
+ #' table_names = "unadj",+ |
+
| 379 | ++ |
+ #' .stats = c("rate"),
+ |
+
| 380 | ++ |
+ #' .labels = c(rate = "Rate")+ |
+
| 381 | ++ |
+ #' ) %>%+ |
+
| 382 | ++ |
+ #' summarize_glm_count(+ |
+
| 383 | ++ |
+ #' vars = "AVAL",+ |
+
| 384 | ++ |
+ #' variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = c("REGION1")),
+ |
+
| 385 | ++ |
+ #' conf_level = 0.95,+ |
+
| 386 | ++ |
+ #' distribution = "quasipoisson",+ |
+
| 387 | ++ |
+ #' rate_mean_method = "ppmeans",+ |
+
| 388 | ++ |
+ #' var_labels = "Adjusted (QP) exacerbation rate (per year)",+ |
+
| 389 | ++ |
+ #' table_names = "adj",+ |
+
| 390 | ++ |
+ #' .stats = c("rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
+ |
+
| 391 | ++ |
+ #' .labels = c(+ |
+
| 392 | ++ |
+ #' rate = "Rate", rate_ci = "Rate CI", rate_ratio = "Rate Ratio",+ |
+
| 393 | ++ |
+ #' rate_ratio_ci = "Rate Ratio CI", pval = "p value"+ |
+
| 394 | ++ |
+ #' )+ |
+
| 395 | ++ |
+ #' )+ |
+
| 396 | ++ |
+ #' build_table(lyt = lyt, df = anl)+ |
+
| 397 | ++ |
+ #'+ |
+
| 398 | ++ |
+ #' @export+ |
+
| 399 | ++ |
+ summarize_glm_count <- function(lyt,+ |
+
| 400 | ++ |
+ vars,+ |
+
| 401 | ++ |
+ var_labels,+ |
+
| 402 | ++ |
+ na_str = NA_character_,+ |
+
| 403 | ++ |
+ nested = TRUE,+ |
+
| 404 | ++ |
+ ...,+ |
+
| 405 | ++ |
+ show_labels = "visible",+ |
+
| 406 | ++ |
+ table_names = vars,+ |
+
| 407 | ++ |
+ .stats = NULL,+ |
+
| 408 | ++ |
+ .formats = NULL,+ |
+
| 409 | ++ |
+ .labels = NULL,+ |
+
| 410 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 411 | +1x | +
+ afun <- make_afun(+ |
+
| 412 | +1x | +
+ a_glm_count,+ |
+
| 413 | +1x | +
+ .stats = .stats,+ |
+
| 414 | +1x | +
+ .formats = .formats,+ |
+
| 415 | +1x | +
+ .labels = .labels,+ |
+
| 416 | +1x | +
+ .indent_mods = .indent_mods+ |
+
| 417 | ++ |
+ )+ |
+
| 418 | ++ | + + | +
| 419 | +1x | +
+ analyze(+ |
+
| 420 | +1x | +
+ lyt,+ |
+
| 421 | +1x | +
+ vars,+ |
+
| 422 | +1x | +
+ var_labels = var_labels,+ |
+
| 423 | +1x | +
+ show_labels = show_labels,+ |
+
| 424 | +1x | +
+ table_names = table_names,+ |
+
| 425 | +1x | +
+ afun = afun,+ |
+
| 426 | +1x | +
+ na_str = na_str,+ |
+
| 427 | +1x | +
+ nested = nested,+ |
+
| 428 | +1x | +
+ extra_args = list(...)+ |
+
| 429 | ++ |
+ )+ |
+
| 430 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Helper Functions for Subgroup Treatment Effect Pattern (STEP) Calculations+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Helper functions that are used internally for the STEP calculations.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @name h_step+ |
+
| 10 | ++ |
+ #' @include control_step.R+ |
+
| 11 | ++ |
+ NULL+ |
+
| 12 | ++ | + + | +
| 13 | ++ |
+ #' @describeIn h_step creates the windows for STEP, based on the control settings+ |
+
| 14 | ++ |
+ #' provided.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @param x (`numeric`)\cr biomarker value(s) to use (without `NA`).+ |
+
| 17 | ++ |
+ #' @param control (named `list`)\cr output from `control_step()`.+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @return+ |
+
| 20 | ++ |
+ #' * `h_step_window()` returns a list containing the window-selection matrix `sel`+ |
+
| 21 | ++ |
+ #' and the interval information matrix `interval`.+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @export+ |
+
| 24 | ++ |
+ h_step_window <- function(x,+ |
+
| 25 | ++ |
+ control = control_step()) {
+ |
+
| 26 | +12x | +
+ checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)+ |
+
| 27 | +12x | +
+ checkmate::assert_list(control, names = "named")+ |
+
| 28 | ++ | + + | +
| 29 | +12x | +
+ sel <- matrix(FALSE, length(x), control$num_points)+ |
+
| 30 | +12x | +
+ out <- matrix(0, control$num_points, 3)+ |
+
| 31 | +12x | +
+ colnames(out) <- paste("Interval", c("Center", "Lower", "Upper"))
+ |
+
| 32 | +12x | +
+ if (control$use_percentile) {
+ |
+
| 33 | ++ |
+ # Create windows according to percentile cutoffs.+ |
+
| 34 | +9x | +
+ out <- cbind(out, out)+ |
+
| 35 | +9x | +
+ colnames(out)[1:3] <- paste("Percentile", c("Center", "Lower", "Upper"))
+ |
+
| 36 | +9x | +
+ xs <- seq(0, 1, length = control$num_points + 2)[-1]+ |
+
| 37 | +9x | +
+ for (i in seq_len(control$num_points)) {
+ |
+
| 38 | +185x | +
+ out[i, 2:3] <- c(+ |
+
| 39 | +185x | +
+ max(xs[i] - control$bandwidth, 0),+ |
+
| 40 | +185x | +
+ min(xs[i] + control$bandwidth, 1)+ |
+
| 41 | ++ |
+ )+ |
+
| 42 | +185x | +
+ out[i, 5:6] <- stats::quantile(x, out[i, 2:3])+ |
+
| 43 | +185x | +
+ sel[, i] <- x >= out[i, 5] & x <= out[i, 6]+ |
+
| 44 | ++ |
+ }+ |
+
| 45 | ++ |
+ # Center is the middle point of the percentile window.+ |
+
| 46 | +9x | +
+ out[, 1] <- xs[-control$num_points - 1]+ |
+
| 47 | +9x | +
+ out[, 4] <- stats::quantile(x, out[, 1])+ |
+
| 48 | ++ |
+ } else {
+ |
+
| 49 | ++ |
+ # Create windows according to cutoffs.+ |
+
| 50 | +3x | +
+ m <- c(min(x), max(x))+ |
+
| 51 | +3x | +
+ xs <- seq(m[1], m[2], length = control$num_points + 2)[-1]+ |
+
| 52 | +3x | +
+ for (i in seq_len(control$num_points)) {
+ |
+
| 53 | +11x | +
+ out[i, 2:3] <- c(+ |
+
| 54 | +11x | +
+ max(xs[i] - control$bandwidth, m[1]),+ |
+
| 55 | +11x | +
+ min(xs[i] + control$bandwidth, m[2])+ |
+
| 56 | ++ |
+ )+ |
+
| 57 | +11x | +
+ sel[, i] <- x >= out[i, 2] & x <= out[i, 3]+ |
+
| 58 | ++ |
+ }+ |
+
| 59 | ++ |
+ # Center is the same as the point for predicting.+ |
+
| 60 | +3x | +
+ out[, 1] <- xs[-control$num_points - 1]+ |
+
| 61 | ++ |
+ }+ |
+
| 62 | +12x | +
+ list(sel = sel, interval = out)+ |
+
| 63 | ++ |
+ }+ |
+
| 64 | ++ | + + | +
| 65 | ++ |
+ #' @describeIn h_step calculates the estimated treatment effect estimate+ |
+
| 66 | ++ |
+ #' on the linear predictor scale and corresponding standard error from a STEP `model` fitted+ |
+
| 67 | ++ |
+ #' on `data` given `variables` specification, for a single biomarker value `x`.+ |
+
| 68 | ++ |
+ #' This works for both `coxph` and `glm` models, i.e. for calculating log hazard ratio or log odds+ |
+
| 69 | ++ |
+ #' ratio estimates.+ |
+
| 70 | ++ |
+ #'+ |
+
| 71 | ++ |
+ #' @param model the regression model object.+ |
+
| 72 | ++ |
+ #'+ |
+
| 73 | ++ |
+ #' @return+ |
+
| 74 | ++ |
+ #' * `h_step_trt_effect()` returns a vector with elements `est` and `se`.+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ #' @export+ |
+
| 77 | ++ |
+ h_step_trt_effect <- function(data,+ |
+
| 78 | ++ |
+ model,+ |
+
| 79 | ++ |
+ variables,+ |
+
| 80 | ++ |
+ x) {
+ |
+
| 81 | +208x | +
+ checkmate::assert_multi_class(model, c("coxph", "glm"))
+ |
+
| 82 | +208x | +
+ checkmate::assert_number(x)+ |
+
| 83 | +208x | +
+ assert_df_with_variables(data, variables)+ |
+
| 84 | +208x | +
+ checkmate::assert_factor(data[[variables$arm]], n.levels = 2)+ |
+
| 85 | ++ | + + | +
| 86 | +208x | +
+ newdata <- data[c(1, 1), ]+ |
+
| 87 | +208x | +
+ newdata[, variables$biomarker] <- x+ |
+
| 88 | +208x | +
+ newdata[, variables$arm] <- levels(data[[variables$arm]])+ |
+
| 89 | +208x | +
+ model_terms <- stats::delete.response(stats::terms(model))+ |
+
| 90 | +208x | +
+ model_frame <- stats::model.frame(model_terms, data = newdata, xlev = model$xlevels)+ |
+
| 91 | +208x | +
+ mat <- stats::model.matrix(model_terms, data = model_frame, contrasts.arg = model$contrasts)+ |
+
| 92 | +208x | +
+ coefs <- stats::coef(model)+ |
+
| 93 | ++ |
+ # Note: It is important to use the coef subset from matrix, otherwise intercept and+ |
+
| 94 | ++ |
+ # strata are included for coxph() models.+ |
+
| 95 | +208x | +
+ mat <- mat[, names(coefs)]+ |
+
| 96 | +208x | +
+ mat_diff <- diff(mat)+ |
+
| 97 | +208x | +
+ est <- mat_diff %*% coefs+ |
+
| 98 | +208x | +
+ var <- mat_diff %*% stats::vcov(model) %*% t(mat_diff)+ |
+
| 99 | +208x | +
+ se <- sqrt(var)+ |
+
| 100 | +208x | +
+ c(+ |
+
| 101 | +208x | +
+ est = est,+ |
+
| 102 | +208x | +
+ se = se+ |
+
| 103 | ++ |
+ )+ |
+
| 104 | ++ |
+ }+ |
+
| 105 | ++ | + + | +
| 106 | ++ |
+ #' @describeIn h_step builds the model formula used in survival STEP calculations.+ |
+
| 107 | ++ |
+ #'+ |
+
| 108 | ++ |
+ #' @return+ |
+
| 109 | ++ |
+ #' * `h_step_survival_formula()` returns a model formula.+ |
+
| 110 | ++ |
+ #'+ |
+
| 111 | ++ |
+ #' @export+ |
+
| 112 | ++ |
+ h_step_survival_formula <- function(variables,+ |
+
| 113 | ++ |
+ control = control_step()) {
+ |
+
| 114 | +10x | +
+ checkmate::assert_character(variables$covariates, null.ok = TRUE)+ |
+
| 115 | ++ | + + | +
| 116 | +10x | +
+ assert_list_of_variables(variables[c("arm", "biomarker", "event", "time")])
+ |
+
| 117 | +10x | +
+ form <- paste0("Surv(", variables$time, ", ", variables$event, ") ~ ", variables$arm)
+ |
+
| 118 | +10x | +
+ if (control$degree > 0) {
+ |
+
| 119 | +5x | +
+ form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
+ |
+
| 120 | ++ |
+ }+ |
+
| 121 | +10x | +
+ if (!is.null(variables$covariates)) {
+ |
+
| 122 | +6x | +
+ form <- paste(form, "+", paste(variables$covariates, collapse = "+"))+ |
+
| 123 | ++ |
+ }+ |
+
| 124 | +10x | +
+ if (!is.null(variables$strata)) {
+ |
+
| 125 | +2x | +
+ form <- paste0(form, " + strata(", paste0(variables$strata, collapse = ", "), ")")
+ |
+
| 126 | ++ |
+ }+ |
+
| 127 | +10x | +
+ stats::as.formula(form)+ |
+
| 128 | ++ |
+ }+ |
+
| 129 | ++ | + + | +
| 130 | ++ |
+ #' @describeIn h_step estimates the model with `formula` built based on+ |
+
| 131 | ++ |
+ #' `variables` in `data` for a given `subset` and `control` parameters for the+ |
+
| 132 | ++ |
+ #' Cox regression.+ |
+
| 133 | ++ |
+ #'+ |
+
| 134 | ++ |
+ #' @param formula (`formula`)\cr the regression model formula.+ |
+
| 135 | ++ |
+ #' @param subset (`logical`)\cr subset vector.+ |
+
| 136 | ++ |
+ #'+ |
+
| 137 | ++ |
+ #' @return+ |
+
| 138 | ++ |
+ #' * `h_step_survival_est()` returns a matrix of number of observations `n`,+ |
+
| 139 | ++ |
+ #' `events`, log hazard ratio estimates `loghr`, standard error `se`,+ |
+
| 140 | ++ |
+ #' and Wald confidence interval bounds `ci_lower` and `ci_upper`. One row is+ |
+
| 141 | ++ |
+ #' included for each biomarker value in `x`.+ |
+
| 142 | ++ |
+ #'+ |
+
| 143 | ++ |
+ #' @export+ |
+
| 144 | ++ |
+ h_step_survival_est <- function(formula,+ |
+
| 145 | ++ |
+ data,+ |
+
| 146 | ++ |
+ variables,+ |
+
| 147 | ++ |
+ x,+ |
+
| 148 | ++ |
+ subset = rep(TRUE, nrow(data)),+ |
+
| 149 | ++ |
+ control = control_coxph()) {
+ |
+
| 150 | +55x | +
+ checkmate::assert_formula(formula)+ |
+
| 151 | +55x | +
+ assert_df_with_variables(data, variables)+ |
+
| 152 | +55x | +
+ checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE)+ |
+
| 153 | +55x | +
+ checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)+ |
+
| 154 | +55x | +
+ checkmate::assert_list(control, names = "named")+ |
+
| 155 | ++ | + + | +
| 156 | ++ |
+ # Note: `subset` in `coxph` needs to be an expression referring to `data` variables.+ |
+
| 157 | +55x | +
+ data$.subset <- subset+ |
+
| 158 | +55x | +
+ coxph_warnings <- NULL+ |
+
| 159 | +55x | +
+ tryCatch(+ |
+
| 160 | +55x | +
+ withCallingHandlers(+ |
+
| 161 | +55x | +
+ expr = {
+ |
+
| 162 | +55x | +
+ fit <- survival::coxph(+ |
+
| 163 | +55x | +
+ formula = formula,+ |
+
| 164 | +55x | +
+ data = data,+ |
+
| 165 | +55x | +
+ subset = .subset,+ |
+
| 166 | +55x | +
+ ties = control$ties+ |
+
| 167 | ++ |
+ )+ |
+
| 168 | ++ |
+ },+ |
+
| 169 | +55x | +
+ warning = function(w) {
+ |
+
| 170 | +1x | +
+ coxph_warnings <<- c(coxph_warnings, w)+ |
+
| 171 | +1x | +
+ invokeRestart("muffleWarning")
+ |
+
| 172 | ++ |
+ }+ |
+
| 173 | ++ |
+ ),+ |
+
| 174 | +55x | +
+ finally = {
+ |
+
| 175 | ++ |
+ }+ |
+
| 176 | ++ |
+ )+ |
+
| 177 | +55x | +
+ if (!is.null(coxph_warnings)) {
+ |
+
| 178 | +1x | +
+ warning(paste(+ |
+
| 179 | +1x | +
+ "Fit warnings occurred, please consider using a simpler model, or",+ |
+
| 180 | +1x | +
+ "larger `bandwidth`, less `num_points` in `control_step()` settings"+ |
+
| 181 | ++ |
+ ))+ |
+
| 182 | ++ |
+ }+ |
+
| 183 | ++ |
+ # Produce a matrix with one row per `x` and columns `est` and `se`.+ |
+
| 184 | +55x | +
+ estimates <- t(vapply(+ |
+
| 185 | +55x | +
+ X = x,+ |
+
| 186 | +55x | +
+ FUN = h_step_trt_effect,+ |
+
| 187 | +55x | +
+ FUN.VALUE = c(1, 2),+ |
+
| 188 | +55x | +
+ data = data,+ |
+
| 189 | +55x | +
+ model = fit,+ |
+
| 190 | +55x | +
+ variables = variables+ |
+
| 191 | ++ |
+ ))+ |
+
| 192 | +55x | +
+ q_norm <- stats::qnorm((1 + control$conf_level) / 2)+ |
+
| 193 | +55x | +
+ cbind(+ |
+
| 194 | +55x | +
+ n = fit$n,+ |
+
| 195 | +55x | +
+ events = fit$nevent,+ |
+
| 196 | +55x | +
+ loghr = estimates[, "est"],+ |
+
| 197 | +55x | +
+ se = estimates[, "se"],+ |
+
| 198 | +55x | +
+ ci_lower = estimates[, "est"] - q_norm * estimates[, "se"],+ |
+
| 199 | +55x | +
+ ci_upper = estimates[, "est"] + q_norm * estimates[, "se"]+ |
+
| 200 | ++ |
+ )+ |
+
| 201 | ++ |
+ }+ |
+
| 202 | ++ | + + | +
| 203 | ++ |
+ #' @describeIn h_step builds the model formula used in response STEP calculations.+ |
+
| 204 | ++ |
+ #'+ |
+
| 205 | ++ |
+ #' @return+ |
+
| 206 | ++ |
+ #' * `h_step_rsp_formula()` returns a model formula.+ |
+
| 207 | ++ |
+ #'+ |
+
| 208 | ++ |
+ #' @export+ |
+
| 209 | ++ |
+ h_step_rsp_formula <- function(variables,+ |
+
| 210 | ++ |
+ control = c(control_step(), control_logistic())) {
+ |
+
| 211 | +14x | +
+ checkmate::assert_character(variables$covariates, null.ok = TRUE)+ |
+
| 212 | +14x | +
+ assert_list_of_variables(variables[c("arm", "biomarker", "response")])
+ |
+
| 213 | +14x | +
+ response_definition <- sub(+ |
+
| 214 | +14x | +
+ pattern = "response",+ |
+
| 215 | +14x | +
+ replacement = variables$response,+ |
+
| 216 | +14x | +
+ x = control$response_definition,+ |
+
| 217 | +14x | +
+ fixed = TRUE+ |
+
| 218 | ++ |
+ )+ |
+
| 219 | +14x | +
+ form <- paste0(response_definition, " ~ ", variables$arm)+ |
+
| 220 | +14x | +
+ if (control$degree > 0) {
+ |
+
| 221 | +8x | +
+ form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
+ |
+
| 222 | ++ |
+ }+ |
+
| 223 | +14x | +
+ if (!is.null(variables$covariates)) {
+ |
+
| 224 | +8x | +
+ form <- paste(form, "+", paste(variables$covariates, collapse = "+"))+ |
+
| 225 | ++ |
+ }+ |
+
| 226 | +14x | +
+ if (!is.null(variables$strata)) {
+ |
+
| 227 | +5x | +
+ strata_arg <- if (length(variables$strata) > 1) {
+ |
+
| 228 | +2x | +
+ paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
+ |
+
| 229 | ++ |
+ } else {
+ |
+
| 230 | +3x | +
+ variables$strata+ |
+
| 231 | ++ |
+ }+ |
+
| 232 | +5x | +
+ form <- paste0(form, "+ strata(", strata_arg, ")")
+ |
+
| 233 | ++ |
+ }+ |
+
| 234 | +14x | +
+ stats::as.formula(form)+ |
+
| 235 | ++ |
+ }+ |
+
| 236 | ++ | + + | +
| 237 | ++ |
+ #' @describeIn h_step estimates the model with `formula` built based on+ |
+
| 238 | ++ |
+ #' `variables` in `data` for a given `subset` and `control` parameters for the+ |
+
| 239 | ++ |
+ #' logistic regression.+ |
+
| 240 | ++ |
+ #'+ |
+
| 241 | ++ |
+ #' @param formula (`formula`)\cr the regression model formula.+ |
+
| 242 | ++ |
+ #' @param subset (`logical`)\cr subset vector.+ |
+
| 243 | ++ |
+ #'+ |
+
| 244 | ++ |
+ #' @return+ |
+
| 245 | ++ |
+ #' * `h_step_rsp_est()` returns a matrix of number of observations `n`, log odds+ |
+
| 246 | ++ |
+ #' ratio estimates `logor`, standard error `se`, and Wald confidence interval bounds+ |
+
| 247 | ++ |
+ #' `ci_lower` and `ci_upper`. One row is included for each biomarker value in `x`.+ |
+
| 248 | ++ |
+ #'+ |
+
| 249 | ++ |
+ #' @export+ |
+
| 250 | ++ |
+ h_step_rsp_est <- function(formula,+ |
+
| 251 | ++ |
+ data,+ |
+
| 252 | ++ |
+ variables,+ |
+
| 253 | ++ |
+ x,+ |
+
| 254 | ++ |
+ subset = rep(TRUE, nrow(data)),+ |
+
| 255 | ++ |
+ control = control_logistic()) {
+ |
+
| 256 | +58x | +
+ checkmate::assert_formula(formula)+ |
+
| 257 | +58x | +
+ assert_df_with_variables(data, variables)+ |
+
| 258 | +58x | +
+ checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE)+ |
+
| 259 | +58x | +
+ checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)+ |
+
| 260 | +58x | +
+ checkmate::assert_list(control, names = "named")+ |
+
| 261 | ++ |
+ # Note: `subset` in `glm` needs to be an expression referring to `data` variables.+ |
+
| 262 | +58x | +
+ data$.subset <- subset+ |
+
| 263 | +58x | +
+ fit_warnings <- NULL+ |
+
| 264 | +58x | +
+ tryCatch(+ |
+
| 265 | +58x | +
+ withCallingHandlers(+ |
+
| 266 | +58x | +
+ expr = {
+ |
+
| 267 | +58x | +
+ fit <- if (is.null(variables$strata)) {
+ |
+
| 268 | +54x | +
+ stats::glm(+ |
+
| 269 | +54x | +
+ formula = formula,+ |
+
| 270 | +54x | +
+ data = data,+ |
+
| 271 | +54x | +
+ subset = .subset,+ |
+
| 272 | +54x | +
+ family = stats::binomial("logit")
+ |
+
| 273 | ++ |
+ )+ |
+
| 274 | ++ |
+ } else {
+ |
+
| 275 | ++ |
+ # clogit needs coxph and strata imported+ |
+
| 276 | +4x | +
+ survival::clogit(+ |
+
| 277 | +4x | +
+ formula = formula,+ |
+
| 278 | +4x | +
+ data = data,+ |
+
| 279 | +4x | +
+ subset = .subset+ |
+
| 280 | ++ |
+ )+ |
+
| 281 | ++ |
+ }+ |
+
| 282 | ++ |
+ },+ |
+
| 283 | +58x | +
+ warning = function(w) {
+ |
+
| 284 | +19x | +
+ fit_warnings <<- c(fit_warnings, w)+ |
+
| 285 | +19x | +
+ invokeRestart("muffleWarning")
+ |
+
| 286 | ++ |
+ }+ |
+
| 287 | ++ |
+ ),+ |
+
| 288 | +58x | +
+ finally = {
+ |
+
| 289 | ++ |
+ }+ |
+
| 290 | ++ |
+ )+ |
+
| 291 | +58x | +
+ if (!is.null(fit_warnings)) {
+ |
+
| 292 | +13x | +
+ warning(paste(+ |
+
| 293 | +13x | +
+ "Fit warnings occurred, please consider using a simpler model, or",+ |
+
| 294 | +13x | +
+ "larger `bandwidth`, less `num_points` in `control_step()` settings"+ |
+
| 295 | ++ |
+ ))+ |
+
| 296 | ++ |
+ }+ |
+
| 297 | ++ |
+ # Produce a matrix with one row per `x` and columns `est` and `se`.+ |
+
| 298 | +58x | +
+ estimates <- t(vapply(+ |
+
| 299 | +58x | +
+ X = x,+ |
+
| 300 | +58x | +
+ FUN = h_step_trt_effect,+ |
+
| 301 | +58x | +
+ FUN.VALUE = c(1, 2),+ |
+
| 302 | +58x | +
+ data = data,+ |
+
| 303 | +58x | +
+ model = fit,+ |
+
| 304 | +58x | +
+ variables = variables+ |
+
| 305 | ++ |
+ ))+ |
+
| 306 | +58x | +
+ q_norm <- stats::qnorm((1 + control$conf_level) / 2)+ |
+
| 307 | +58x | +
+ cbind(+ |
+
| 308 | +58x | +
+ n = length(fit$y),+ |
+
| 309 | +58x | +
+ logor = estimates[, "est"],+ |
+
| 310 | +58x | +
+ se = estimates[, "se"],+ |
+
| 311 | +58x | +
+ ci_lower = estimates[, "est"] - q_norm * estimates[, "se"],+ |
+
| 312 | +58x | +
+ ci_upper = estimates[, "est"] + q_norm * estimates[, "se"]+ |
+
| 313 | ++ |
+ )+ |
+
| 314 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Helper Functions for Multivariate Logistic Regression+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Helper functions used in calculations for logistic regression.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 8 | ++ |
+ #' @param fit_glm (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family.+ |
+
| 9 | ++ |
+ #' Limited functionality is also available for conditional logistic regression models fitted by+ |
+
| 10 | ++ |
+ #' [survival::clogit()], currently this is used only by [extract_rsp_biomarkers()].+ |
+
| 11 | ++ |
+ #' @param x (`string` or `character`)\cr a variable or interaction term in `fit_glm` (depending on the+ |
+
| 12 | ++ |
+ #' helper function).+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @examples+ |
+
| 15 | ++ |
+ #' library(dplyr)+ |
+
| 16 | ++ |
+ #' library(broom)+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' adrs_f <- tern_ex_adrs %>%+ |
+
| 19 | ++ |
+ #' filter(PARAMCD == "BESRSPI") %>%+ |
+
| 20 | ++ |
+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ |
+
| 21 | ++ |
+ #' mutate(+ |
+
| 22 | ++ |
+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ |
+
| 23 | ++ |
+ #' RACE = factor(RACE),+ |
+
| 24 | ++ |
+ #' SEX = factor(SEX)+ |
+
| 25 | ++ |
+ #' )+ |
+
| 26 | ++ |
+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ |
+
| 27 | ++ |
+ #' mod1 <- fit_logistic(+ |
+
| 28 | ++ |
+ #' data = adrs_f,+ |
+
| 29 | ++ |
+ #' variables = list(+ |
+
| 30 | ++ |
+ #' response = "Response",+ |
+
| 31 | ++ |
+ #' arm = "ARMCD",+ |
+
| 32 | ++ |
+ #' covariates = c("AGE", "RACE")
+ |
+
| 33 | ++ |
+ #' )+ |
+
| 34 | ++ |
+ #' )+ |
+
| 35 | ++ |
+ #' mod2 <- fit_logistic(+ |
+
| 36 | ++ |
+ #' data = adrs_f,+ |
+
| 37 | ++ |
+ #' variables = list(+ |
+
| 38 | ++ |
+ #' response = "Response",+ |
+
| 39 | ++ |
+ #' arm = "ARMCD",+ |
+
| 40 | ++ |
+ #' covariates = c("AGE", "RACE"),
+ |
+
| 41 | ++ |
+ #' interaction = "AGE"+ |
+
| 42 | ++ |
+ #' )+ |
+
| 43 | ++ |
+ #' )+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' @name h_logistic_regression+ |
+
| 46 | ++ |
+ NULL+ |
+
| 47 | ++ | + + | +
| 48 | ++ |
+ #' @describeIn h_logistic_regression Helper function to extract interaction variable names from a fitted+ |
+
| 49 | ++ |
+ #' model assuming only one interaction term.+ |
+
| 50 | ++ |
+ #'+ |
+
| 51 | ++ |
+ #' @return Vector of names of interaction variables.+ |
+
| 52 | ++ |
+ #'+ |
+
| 53 | ++ |
+ #' @export+ |
+
| 54 | ++ |
+ h_get_interaction_vars <- function(fit_glm) {
+ |
+
| 55 | +27x | +
+ checkmate::assert_class(fit_glm, "glm")+ |
+
| 56 | +27x | +
+ terms_name <- attr(stats::terms(fit_glm), "term.labels")+ |
+
| 57 | +27x | +
+ terms_order <- attr(stats::terms(fit_glm), "order")+ |
+
| 58 | +27x | +
+ interaction_term <- terms_name[terms_order == 2]+ |
+
| 59 | +27x | +
+ checkmate::assert_string(interaction_term)+ |
+
| 60 | +27x | +
+ strsplit(interaction_term, split = ":")[[1]]+ |
+
| 61 | ++ |
+ }+ |
+
| 62 | ++ | + + | +
| 63 | ++ |
+ #' @describeIn h_logistic_regression Helper function to get the right coefficient name from the+ |
+
| 64 | ++ |
+ #' interaction variable names and the given levels. The main value here is that the order+ |
+
| 65 | ++ |
+ #' of first and second variable is checked in the `interaction_vars` input.+ |
+
| 66 | ++ |
+ #'+ |
+
| 67 | ++ |
+ #' @param interaction_vars (`character` of length 2)\cr interaction variable names.+ |
+
| 68 | ++ |
+ #' @param first_var_with_level (`character` of length 2)\cr the first variable name with+ |
+
| 69 | ++ |
+ #' the interaction level.+ |
+
| 70 | ++ |
+ #' @param second_var_with_level (`character` of length 2)\cr the second variable name with+ |
+
| 71 | ++ |
+ #' the interaction level.+ |
+
| 72 | ++ |
+ #'+ |
+
| 73 | ++ |
+ #' @return Name of coefficient.+ |
+
| 74 | ++ |
+ #'+ |
+
| 75 | ++ |
+ #' @export+ |
+
| 76 | ++ |
+ h_interaction_coef_name <- function(interaction_vars,+ |
+
| 77 | ++ |
+ first_var_with_level,+ |
+
| 78 | ++ |
+ second_var_with_level) {
+ |
+
| 79 | +45x | +
+ checkmate::assert_character(interaction_vars, len = 2, any.missing = FALSE)+ |
+
| 80 | +45x | +
+ checkmate::assert_character(first_var_with_level, len = 2, any.missing = FALSE)+ |
+
| 81 | +45x | +
+ checkmate::assert_character(second_var_with_level, len = 2, any.missing = FALSE)+ |
+
| 82 | +45x | +
+ checkmate::assert_subset(c(first_var_with_level[1], second_var_with_level[1]), interaction_vars)+ |
+
| 83 | ++ | + + | +
| 84 | +45x | +
+ first_name <- paste(first_var_with_level, collapse = "")+ |
+
| 85 | +45x | +
+ second_name <- paste(second_var_with_level, collapse = "")+ |
+
| 86 | +45x | +
+ if (first_var_with_level[1] == interaction_vars[1]) {
+ |
+
| 87 | +34x | +
+ paste(first_name, second_name, sep = ":")+ |
+
| 88 | +11x | +
+ } else if (second_var_with_level[1] == interaction_vars[1]) {
+ |
+
| 89 | +11x | +
+ paste(second_name, first_name, sep = ":")+ |
+
| 90 | ++ |
+ }+ |
+
| 91 | ++ |
+ }+ |
+
| 92 | ++ | + + | +
| 93 | ++ |
+ #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ |
+
| 94 | ++ |
+ #' for the case when both the odds ratio and the interaction variable are categorical.+ |
+
| 95 | ++ |
+ #'+ |
+
| 96 | ++ |
+ #' @param odds_ratio_var (`string`)\cr the odds ratio variable.+ |
+
| 97 | ++ |
+ #' @param interaction_var (`string`)\cr the interaction variable.+ |
+
| 98 | ++ |
+ #'+ |
+
| 99 | ++ |
+ #' @return Odds ratio.+ |
+
| 100 | ++ |
+ #'+ |
+
| 101 | ++ |
+ #' @export+ |
+
| 102 | ++ |
+ h_or_cat_interaction <- function(odds_ratio_var,+ |
+
| 103 | ++ |
+ interaction_var,+ |
+
| 104 | ++ |
+ fit_glm,+ |
+
| 105 | ++ |
+ conf_level = 0.95) {
+ |
+
| 106 | +7x | +
+ interaction_vars <- h_get_interaction_vars(fit_glm)+ |
+
| 107 | +7x | +
+ checkmate::assert_string(odds_ratio_var)+ |
+
| 108 | +7x | +
+ checkmate::assert_string(interaction_var)+ |
+
| 109 | +7x | +
+ checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars)+ |
+
| 110 | +7x | +
+ checkmate::assert_vector(interaction_vars, len = 2)+ |
+
| 111 | ++ | + + | +
| 112 | +7x | +
+ xs_level <- fit_glm$xlevels+ |
+
| 113 | +7x | +
+ xs_coef <- stats::coef(fit_glm)+ |
+
| 114 | +7x | +
+ xs_vcov <- stats::vcov(fit_glm)+ |
+
| 115 | +7x | +
+ y <- list()+ |
+
| 116 | +7x | +
+ for (var_level in xs_level[[odds_ratio_var]][-1]) {
+ |
+
| 117 | +12x | +
+ x <- list()+ |
+
| 118 | +12x | +
+ for (ref_level in xs_level[[interaction_var]]) {
+ |
+
| 119 | +32x | +
+ coef_names <- paste0(odds_ratio_var, var_level)+ |
+
| 120 | +32x | +
+ if (ref_level != xs_level[[interaction_var]][1]) {
+ |
+
| 121 | +20x | +
+ interaction_coef_name <- h_interaction_coef_name(+ |
+
| 122 | +20x | +
+ interaction_vars,+ |
+
| 123 | +20x | +
+ c(odds_ratio_var, var_level),+ |
+
| 124 | +20x | +
+ c(interaction_var, ref_level)+ |
+
| 125 | ++ |
+ )+ |
+
| 126 | +20x | +
+ coef_names <- c(+ |
+
| 127 | +20x | +
+ coef_names,+ |
+
| 128 | +20x | +
+ interaction_coef_name+ |
+
| 129 | ++ |
+ )+ |
+
| 130 | ++ |
+ }+ |
+
| 131 | +32x | +
+ if (length(coef_names) > 1) {
+ |
+
| 132 | +20x | +
+ ones <- t(c(1, 1))+ |
+
| 133 | +20x | +
+ est <- as.numeric(ones %*% xs_coef[coef_names])+ |
+
| 134 | +20x | +
+ se <- sqrt(as.numeric(ones %*% xs_vcov[coef_names, coef_names] %*% t(ones)))+ |
+
| 135 | ++ |
+ } else {
+ |
+
| 136 | +12x | +
+ est <- xs_coef[coef_names]+ |
+
| 137 | +12x | +
+ se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ |
+
| 138 | ++ |
+ }+ |
+
| 139 | +32x | +
+ or <- exp(est)+ |
+
| 140 | +32x | +
+ ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ |
+
| 141 | +32x | +
+ x[[ref_level]] <- list(or = or, ci = ci)+ |
+
| 142 | ++ |
+ }+ |
+
| 143 | +12x | +
+ y[[var_level]] <- x+ |
+
| 144 | ++ |
+ }+ |
+
| 145 | +7x | +
+ y+ |
+
| 146 | ++ |
+ }+ |
+
| 147 | ++ | + + | +
| 148 | ++ |
+ #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ |
+
| 149 | ++ |
+ #' for the case when either the odds ratio or the interaction variable is continuous.+ |
+
| 150 | ++ |
+ #'+ |
+
| 151 | ++ |
+ #' @param at (`NULL` or `numeric`)\cr optional values for the interaction variable. Otherwise+ |
+
| 152 | ++ |
+ #' the median is used.+ |
+
| 153 | ++ |
+ #'+ |
+
| 154 | ++ |
+ #' @return Odds ratio.+ |
+
| 155 | ++ |
+ #'+ |
+
| 156 | ++ |
+ #' @note We don't provide a function for the case when both variables are continuous because+ |
+
| 157 | ++ |
+ #' this does not arise in this table, as the treatment arm variable will always be involved+ |
+
| 158 | ++ |
+ #' and categorical.+ |
+
| 159 | ++ |
+ #'+ |
+
| 160 | ++ |
+ #' @export+ |
+
| 161 | ++ |
+ h_or_cont_interaction <- function(odds_ratio_var,+ |
+
| 162 | ++ |
+ interaction_var,+ |
+
| 163 | ++ |
+ fit_glm,+ |
+
| 164 | ++ |
+ at = NULL,+ |
+
| 165 | ++ |
+ conf_level = 0.95) {
+ |
+
| 166 | +9x | +
+ interaction_vars <- h_get_interaction_vars(fit_glm)+ |
+
| 167 | +9x | +
+ checkmate::assert_string(odds_ratio_var)+ |
+
| 168 | +9x | +
+ checkmate::assert_string(interaction_var)+ |
+
| 169 | +9x | +
+ checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars)+ |
+
| 170 | +9x | +
+ checkmate::assert_vector(interaction_vars, len = 2)+ |
+
| 171 | +9x | +
+ checkmate::assert_numeric(at, min.len = 1, null.ok = TRUE, any.missing = FALSE)+ |
+
| 172 | +9x | +
+ xs_level <- fit_glm$xlevels+ |
+
| 173 | +9x | +
+ xs_coef <- stats::coef(fit_glm)+ |
+
| 174 | +9x | +
+ xs_vcov <- stats::vcov(fit_glm)+ |
+
| 175 | +9x | +
+ xs_class <- attr(fit_glm$terms, "dataClasses")+ |
+
| 176 | +9x | +
+ model_data <- fit_glm$model+ |
+
| 177 | +9x | +
+ if (!is.null(at)) {
+ |
+
| 178 | +2x | +
+ checkmate::assert_set_equal(xs_class[interaction_var], "numeric")+ |
+
| 179 | ++ |
+ }+ |
+
| 180 | +9x | +
+ y <- list()+ |
+
| 181 | +9x | +
+ if (xs_class[interaction_var] == "numeric") {
+ |
+
| 182 | +6x | +
+ if (is.null(at)) {
+ |
+
| 183 | +4x | +
+ at <- ceiling(stats::median(model_data[[interaction_var]]))+ |
+
| 184 | ++ |
+ }+ |
+
| 185 | ++ | + + | +
| 186 | +6x | +
+ for (var_level in xs_level[[odds_ratio_var]][-1]) {
+ |
+
| 187 | +12x | +
+ x <- list()+ |
+
| 188 | +12x | +
+ for (increment in at) {
+ |
+
| 189 | +18x | +
+ coef_names <- paste0(odds_ratio_var, var_level)+ |
+
| 190 | +18x | +
+ if (increment != 0) {
+ |
+
| 191 | +18x | +
+ interaction_coef_name <- h_interaction_coef_name(+ |
+
| 192 | +18x | +
+ interaction_vars,+ |
+
| 193 | +18x | +
+ c(odds_ratio_var, var_level),+ |
+
| 194 | +18x | +
+ c(interaction_var, "")+ |
+
| 195 | ++ |
+ )+ |
+
| 196 | +18x | +
+ coef_names <- c(+ |
+
| 197 | +18x | +
+ coef_names,+ |
+
| 198 | +18x | +
+ interaction_coef_name+ |
+
| 199 | ++ |
+ )+ |
+
| 200 | ++ |
+ }+ |
+
| 201 | +18x | +
+ if (length(coef_names) > 1) {
+ |
+
| 202 | +18x | +
+ xvec <- t(c(1, increment))+ |
+
| 203 | +18x | +
+ est <- as.numeric(xvec %*% xs_coef[coef_names])+ |
+
| 204 | +18x | +
+ se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec)))+ |
+
| 205 | ++ |
+ } else {
+ |
+
| 206 | +! | +
+ est <- xs_coef[coef_names]+ |
+
| 207 | +! | +
+ se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ |
+
| 208 | ++ |
+ }+ |
+
| 209 | +18x | +
+ or <- exp(est)+ |
+
| 210 | +18x | +
+ ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ |
+
| 211 | +18x | +
+ x[[as.character(increment)]] <- list(or = or, ci = ci)+ |
+
| 212 | ++ |
+ }+ |
+
| 213 | +12x | +
+ y[[var_level]] <- x+ |
+
| 214 | ++ |
+ }+ |
+
| 215 | ++ |
+ } else {
+ |
+
| 216 | +3x | +
+ checkmate::assert_set_equal(xs_class[odds_ratio_var], "numeric")+ |
+
| 217 | +3x | +
+ checkmate::assert_set_equal(xs_class[interaction_var], "factor")+ |
+
| 218 | +3x | +
+ for (var_level in xs_level[[interaction_var]]) {
+ |
+
| 219 | +9x | +
+ coef_names <- odds_ratio_var+ |
+
| 220 | +9x | +
+ if (var_level != xs_level[[interaction_var]][1]) {
+ |
+
| 221 | +6x | +
+ interaction_coef_name <- h_interaction_coef_name(+ |
+
| 222 | +6x | +
+ interaction_vars,+ |
+
| 223 | +6x | +
+ c(odds_ratio_var, ""),+ |
+
| 224 | +6x | +
+ c(interaction_var, var_level)+ |
+
| 225 | ++ |
+ )+ |
+
| 226 | +6x | +
+ coef_names <- c(+ |
+
| 227 | +6x | +
+ coef_names,+ |
+
| 228 | +6x | +
+ interaction_coef_name+ |
+
| 229 | ++ |
+ )+ |
+
| 230 | ++ |
+ }+ |
+
| 231 | +9x | +
+ if (length(coef_names) > 1) {
+ |
+
| 232 | +6x | +
+ xvec <- t(c(1, 1))+ |
+
| 233 | +6x | +
+ est <- as.numeric(xvec %*% xs_coef[coef_names])+ |
+
| 234 | +6x | +
+ se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec)))+ |
+
| 235 | ++ |
+ } else {
+ |
+
| 236 | +3x | +
+ est <- xs_coef[coef_names]+ |
+
| 237 | +3x | +
+ se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))+ |
+
| 238 | ++ |
+ }+ |
+
| 239 | +9x | +
+ or <- exp(est)+ |
+
| 240 | +9x | +
+ ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)+ |
+
| 241 | +9x | +
+ y[[var_level]] <- list(or = or, ci = ci)+ |
+
| 242 | ++ |
+ }+ |
+
| 243 | ++ |
+ }+ |
+
| 244 | +9x | +
+ y+ |
+
| 245 | ++ |
+ }+ |
+
| 246 | ++ | + + | +
| 247 | ++ |
+ #' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates+ |
+
| 248 | ++ |
+ #' in case of an interaction. This is a wrapper for [h_or_cont_interaction()] and+ |
+
| 249 | ++ |
+ #' [h_or_cat_interaction()].+ |
+
| 250 | ++ |
+ #'+ |
+
| 251 | ++ |
+ #' @return Odds ratio.+ |
+
| 252 | ++ |
+ #'+ |
+
| 253 | ++ |
+ #' @export+ |
+
| 254 | ++ |
+ h_or_interaction <- function(odds_ratio_var,+ |
+
| 255 | ++ |
+ interaction_var,+ |
+
| 256 | ++ |
+ fit_glm,+ |
+
| 257 | ++ |
+ at = NULL,+ |
+
| 258 | ++ |
+ conf_level = 0.95) {
+ |
+
| 259 | +13x | +
+ xs_class <- attr(fit_glm$terms, "dataClasses")+ |
+
| 260 | +13x | +
+ if (any(xs_class[c(odds_ratio_var, interaction_var)] == "numeric")) {
+ |
+
| 261 | +7x | +
+ h_or_cont_interaction(+ |
+
| 262 | +7x | +
+ odds_ratio_var,+ |
+
| 263 | +7x | +
+ interaction_var,+ |
+
| 264 | +7x | +
+ fit_glm,+ |
+
| 265 | +7x | +
+ at = at,+ |
+
| 266 | +7x | +
+ conf_level = conf_level+ |
+
| 267 | ++ |
+ )+ |
+
| 268 | +6x | +
+ } else if (all(xs_class[c(odds_ratio_var, interaction_var)] == "factor")) {
+ |
+
| 269 | +6x | +
+ h_or_cat_interaction(+ |
+
| 270 | +6x | +
+ odds_ratio_var,+ |
+
| 271 | +6x | +
+ interaction_var,+ |
+
| 272 | +6x | +
+ fit_glm,+ |
+
| 273 | +6x | +
+ conf_level = conf_level+ |
+
| 274 | ++ |
+ )+ |
+
| 275 | ++ |
+ } else {
+ |
+
| 276 | +! | +
+ stop("wrong interaction variable class, the interaction variable is not a numeric nor a factor")
+ |
+
| 277 | ++ |
+ }+ |
+
| 278 | ++ |
+ }+ |
+
| 279 | ++ | + + | +
| 280 | ++ |
+ #' @describeIn h_logistic_regression Helper function to construct term labels from simple terms and the table+ |
+
| 281 | ++ |
+ #' of numbers of patients.+ |
+
| 282 | ++ |
+ #'+ |
+
| 283 | ++ |
+ #' @param terms (`character`)\cr simple terms.+ |
+
| 284 | ++ |
+ #' @param table (`table`)\cr table containing numbers for terms.+ |
+
| 285 | ++ |
+ #'+ |
+
| 286 | ++ |
+ #' @return Term labels containing numbers of patients.+ |
+
| 287 | ++ |
+ #'+ |
+
| 288 | ++ |
+ #' @export+ |
+
| 289 | ++ |
+ h_simple_term_labels <- function(terms,+ |
+
| 290 | ++ |
+ table) {
+ |
+
| 291 | +45x | +
+ checkmate::assert_true(is.table(table))+ |
+
| 292 | +45x | +
+ checkmate::assert_multi_class(terms, classes = c("factor", "character"))
+ |
+
| 293 | +45x | +
+ terms <- as.character(terms)+ |
+
| 294 | +45x | +
+ term_n <- table[terms]+ |
+
| 295 | +45x | +
+ paste0(terms, ", n = ", term_n)+ |
+
| 296 | ++ |
+ }+ |
+
| 297 | ++ | + + | +
| 298 | ++ |
+ #' @describeIn h_logistic_regression Helper function to construct term labels from interaction terms and the table+ |
+
| 299 | ++ |
+ #' of numbers of patients.+ |
+
| 300 | ++ |
+ #'+ |
+
| 301 | ++ |
+ #' @param terms1 (`character`)\cr terms for first dimension (rows).+ |
+
| 302 | ++ |
+ #' @param terms2 (`character`)\cr terms for second dimension (rows).+ |
+
| 303 | ++ |
+ #' @param any (`flag`)\cr whether any of `term1` and `term2` can be fulfilled to count the+ |
+
| 304 | ++ |
+ #' number of patients. In that case they can only be scalar (strings).+ |
+
| 305 | ++ |
+ #'+ |
+
| 306 | ++ |
+ #' @return Term labels containing numbers of patients.+ |
+
| 307 | ++ |
+ #'+ |
+
| 308 | ++ |
+ #' @export+ |
+
| 309 | ++ |
+ h_interaction_term_labels <- function(terms1,+ |
+
| 310 | ++ |
+ terms2,+ |
+
| 311 | ++ |
+ table,+ |
+
| 312 | ++ |
+ any = FALSE) {
+ |
+
| 313 | +8x | +
+ checkmate::assert_true(is.table(table))+ |
+
| 314 | +8x | +
+ checkmate::assert_flag(any)+ |
+
| 315 | +8x | +
+ checkmate::assert_multi_class(terms1, classes = c("factor", "character"))
+ |
+
| 316 | +8x | +
+ checkmate::assert_multi_class(terms2, classes = c("factor", "character"))
+ |
+
| 317 | +8x | +
+ terms1 <- as.character(terms1)+ |
+
| 318 | +8x | +
+ terms2 <- as.character(terms2)+ |
+
| 319 | +8x | +
+ if (any) {
+ |
+
| 320 | +4x | +
+ checkmate::assert_scalar(terms1)+ |
+
| 321 | +4x | +
+ checkmate::assert_scalar(terms2)+ |
+
| 322 | +4x | +
+ paste0(+ |
+
| 323 | +4x | +
+ terms1, " or ", terms2, ", n = ",+ |
+
| 324 | ++ |
+ # Note that we double count in the initial sum the cell [terms1, terms2], therefore subtract.+ |
+
| 325 | +4x | +
+ sum(c(table[terms1, ], table[, terms2])) - table[terms1, terms2]+ |
+
| 326 | ++ |
+ )+ |
+
| 327 | ++ |
+ } else {
+ |
+
| 328 | +4x | +
+ term_n <- table[cbind(terms1, terms2)]+ |
+
| 329 | +4x | +
+ paste0(terms1, " * ", terms2, ", n = ", term_n)+ |
+
| 330 | ++ |
+ }+ |
+
| 331 | ++ |
+ }+ |
+
| 332 | ++ | + + | +
| 333 | ++ |
+ #' @describeIn h_logistic_regression Helper function to tabulate the main effect+ |
+
| 334 | ++ |
+ #' results of a (conditional) logistic regression model.+ |
+
| 335 | ++ |
+ #'+ |
+
| 336 | ++ |
+ #' @return Tabulated main effect results from a logistic regression model.+ |
+
| 337 | ++ |
+ #'+ |
+
| 338 | ++ |
+ #' @examples+ |
+
| 339 | ++ |
+ #' h_glm_simple_term_extract("AGE", mod1)
+ |
+
| 340 | ++ |
+ #' h_glm_simple_term_extract("ARMCD", mod1)
+ |
+
| 341 | ++ |
+ #'+ |
+
| 342 | ++ |
+ #' @export+ |
+
| 343 | ++ |
+ h_glm_simple_term_extract <- function(x, fit_glm) {
+ |
+
| 344 | +61x | +
+ checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
+ |
+
| 345 | +61x | +
+ checkmate::assert_string(x)+ |
+
| 346 | ++ | + + | +
| 347 | +61x | +
+ xs_class <- attr(fit_glm$terms, "dataClasses")+ |
+
| 348 | +61x | +
+ xs_level <- fit_glm$xlevels+ |
+
| 349 | +61x | +
+ xs_coef <- summary(fit_glm)$coefficients+ |
+
| 350 | +61x | +
+ stats <- if (inherits(fit_glm, "glm")) {
+ |
+
| 351 | +49x | +
+ c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
+ |
+
| 352 | ++ |
+ } else {
+ |
+
| 353 | +12x | +
+ c("estimate" = "coef", "std_error" = "se(coef)", "pvalue" = "Pr(>|z|)")
+ |
+
| 354 | ++ |
+ }+ |
+
| 355 | ++ |
+ # Make sure x is not an interaction term.+ |
+
| 356 | +61x | +
+ checkmate::assert_subset(x, names(xs_class))+ |
+
| 357 | +61x | +
+ x_sel <- if (xs_class[x] == "numeric") x else paste0(x, xs_level[[x]][-1])+ |
+
| 358 | +61x | +
+ x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE)+ |
+
| 359 | +61x | +
+ colnames(x_stats) <- names(stats)+ |
+
| 360 | +61x | +
+ x_stats$estimate <- as.list(x_stats$estimate)+ |
+
| 361 | +61x | +
+ x_stats$std_error <- as.list(x_stats$std_error)+ |
+
| 362 | +61x | +
+ x_stats$pvalue <- as.list(x_stats$pvalue)+ |
+
| 363 | +61x | +
+ x_stats$df <- as.list(1)+ |
+
| 364 | +61x | +
+ if (xs_class[x] == "numeric") {
+ |
+
| 365 | +46x | +
+ x_stats$term <- x+ |
+
| 366 | +46x | +
+ x_stats$term_label <- if (inherits(fit_glm, "glm")) {
+ |
+
| 367 | +34x | +
+ formatters::var_labels(fit_glm$data[x], fill = TRUE)+ |
+
| 368 | ++ |
+ } else {
+ |
+
| 369 | ++ |
+ # We just fill in here with the `term` itself as we don't have the data available.+ |
+
| 370 | +12x | +
+ x+ |
+
| 371 | ++ |
+ }+ |
+
| 372 | +46x | +
+ x_stats$is_variable_summary <- FALSE+ |
+
| 373 | +46x | +
+ x_stats$is_term_summary <- TRUE+ |
+
| 374 | ++ |
+ } else {
+ |
+
| 375 | +15x | +
+ checkmate::assert_class(fit_glm, "glm")+ |
+
| 376 | ++ |
+ # The reason is that we don't have the original data set in the `clogit` object+ |
+
| 377 | ++ |
+ # and therefore cannot determine the `x_numbers` here.+ |
+
| 378 | +15x | +
+ x_numbers <- table(fit_glm$data[[x]])+ |
+
| 379 | +15x | +
+ x_stats$term <- xs_level[[x]][-1]+ |
+
| 380 | +15x | +
+ x_stats$term_label <- h_simple_term_labels(x_stats$term, x_numbers)+ |
+
| 381 | +15x | +
+ x_stats$is_variable_summary <- FALSE+ |
+
| 382 | +15x | +
+ x_stats$is_term_summary <- TRUE+ |
+
| 383 | +15x | +
+ main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald")+ |
+
| 384 | +15x | +
+ x_main <- data.frame(+ |
+
| 385 | +15x | +
+ pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE],+ |
+
| 386 | +15x | +
+ term = xs_level[[x]][1],+ |
+
| 387 | +15x | +
+ term_label = paste("Reference", h_simple_term_labels(xs_level[[x]][1], x_numbers)),
+ |
+
| 388 | +15x | +
+ df = main_effects[x, "Df", drop = TRUE],+ |
+
| 389 | +15x | +
+ stringsAsFactors = FALSE+ |
+
| 390 | ++ |
+ )+ |
+
| 391 | +15x | +
+ x_main$pvalue <- as.list(x_main$pvalue)+ |
+
| 392 | +15x | +
+ x_main$df <- as.list(x_main$df)+ |
+
| 393 | +15x | +
+ x_main$estimate <- list(numeric(0))+ |
+
| 394 | +15x | +
+ x_main$std_error <- list(numeric(0))+ |
+
| 395 | +15x | +
+ if (length(xs_level[[x]][-1]) == 1) {
+ |
+
| 396 | +6x | +
+ x_main$pvalue <- list(numeric(0))+ |
+
| 397 | +6x | +
+ x_main$df <- list(numeric(0))+ |
+
| 398 | ++ |
+ }+ |
+
| 399 | +15x | +
+ x_main$is_variable_summary <- TRUE+ |
+
| 400 | +15x | +
+ x_main$is_term_summary <- FALSE+ |
+
| 401 | +15x | +
+ x_stats <- rbind(x_main, x_stats)+ |
+
| 402 | ++ |
+ }+ |
+
| 403 | +61x | +
+ x_stats$variable <- x+ |
+
| 404 | +61x | +
+ x_stats$variable_label <- if (inherits(fit_glm, "glm")) {
+ |
+
| 405 | +49x | +
+ formatters::var_labels(fit_glm$data[x], fill = TRUE)+ |
+
| 406 | ++ |
+ } else {
+ |
+
| 407 | +12x | +
+ x+ |
+
| 408 | ++ |
+ }+ |
+
| 409 | +61x | +
+ x_stats$interaction <- ""+ |
+
| 410 | +61x | +
+ x_stats$interaction_label <- ""+ |
+
| 411 | +61x | +
+ x_stats$reference <- ""+ |
+
| 412 | +61x | +
+ x_stats$reference_label <- ""+ |
+
| 413 | +61x | +
+ rownames(x_stats) <- NULL+ |
+
| 414 | +61x | +
+ x_stats[c(+ |
+
| 415 | +61x | +
+ "variable",+ |
+
| 416 | +61x | +
+ "variable_label",+ |
+
| 417 | +61x | +
+ "term",+ |
+
| 418 | +61x | +
+ "term_label",+ |
+
| 419 | +61x | +
+ "interaction",+ |
+
| 420 | +61x | +
+ "interaction_label",+ |
+
| 421 | +61x | +
+ "reference",+ |
+
| 422 | +61x | +
+ "reference_label",+ |
+
| 423 | +61x | +
+ "estimate",+ |
+
| 424 | +61x | +
+ "std_error",+ |
+
| 425 | +61x | +
+ "df",+ |
+
| 426 | +61x | +
+ "pvalue",+ |
+
| 427 | +61x | +
+ "is_variable_summary",+ |
+
| 428 | +61x | +
+ "is_term_summary"+ |
+
| 429 | ++ |
+ )]+ |
+
| 430 | ++ |
+ }+ |
+
| 431 | ++ | + + | +
| 432 | ++ |
+ #' @describeIn h_logistic_regression Helper function to tabulate the interaction term+ |
+
| 433 | ++ |
+ #' results of a logistic regression model.+ |
+
| 434 | ++ |
+ #'+ |
+
| 435 | ++ |
+ #' @return Tabulated interaction term results from a logistic regression model.+ |
+
| 436 | ++ |
+ #'+ |
+
| 437 | ++ |
+ #' @examples+ |
+
| 438 | ++ |
+ #' h_glm_interaction_extract("ARMCD:AGE", mod2)
+ |
+
| 439 | ++ |
+ #'+ |
+
| 440 | ++ |
+ #' @export+ |
+
| 441 | ++ |
+ h_glm_interaction_extract <- function(x, fit_glm) {
+ |
+
| 442 | +6x | +
+ vars <- h_get_interaction_vars(fit_glm)+ |
+
| 443 | +6x | +
+ xs_class <- attr(fit_glm$terms, "dataClasses")+ |
+
| 444 | ++ | + + | +
| 445 | +6x | +
+ checkmate::assert_string(x)+ |
+
| 446 | ++ | + + | +
| 447 | ++ |
+ # Only take two-way interaction+ |
+
| 448 | +6x | +
+ checkmate::assert_vector(vars, len = 2)+ |
+
| 449 | ++ | + + | +
| 450 | ++ |
+ # Only consider simple case: first variable in interaction is arm, a categorical variable+ |
+
| 451 | +6x | +
+ checkmate::assert_disjunct(xs_class[vars[1]], "numeric")+ |
+
| 452 | ++ | + + | +
| 453 | +6x | +
+ xs_level <- fit_glm$xlevels+ |
+
| 454 | +6x | +
+ xs_coef <- summary(fit_glm)$coefficients+ |
+
| 455 | +6x | +
+ main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald")+ |
+
| 456 | +6x | +
+ stats <- c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
+ |
+
| 457 | +6x | +
+ v1_comp <- xs_level[[vars[1]]][-1]+ |
+
| 458 | +6x | +
+ if (xs_class[vars[2]] == "numeric") {
+ |
+
| 459 | +3x | +
+ x_stats <- as.data.frame(+ |
+
| 460 | +3x | +
+ xs_coef[paste0(vars[1], v1_comp, ":", vars[2]), stats, drop = FALSE],+ |
+
| 461 | +3x | +
+ stringsAsFactors = FALSE+ |
+
| 462 | ++ |
+ )+ |
+
| 463 | +3x | +
+ colnames(x_stats) <- names(stats)+ |
+
| 464 | +3x | +
+ x_stats$term <- v1_comp+ |
+
| 465 | +3x | +
+ x_numbers <- table(fit_glm$data[[vars[1]]])+ |
+
| 466 | +3x | +
+ x_stats$term_label <- h_simple_term_labels(v1_comp, x_numbers)+ |
+
| 467 | +3x | +
+ v1_ref <- xs_level[[vars[1]]][1]+ |
+
| 468 | +3x | +
+ term_main <- v1_ref+ |
+
| 469 | +3x | +
+ ref_label <- h_simple_term_labels(v1_ref, x_numbers)+ |
+
| 470 | +3x | +
+ } else if (xs_class[vars[2]] != "numeric") {
+ |
+
| 471 | +3x | +
+ v2_comp <- xs_level[[vars[2]]][-1]+ |
+
| 472 | +3x | +
+ v1_v2_grid <- expand.grid(v1 = v1_comp, v2 = v2_comp)+ |
+
| 473 | +3x | +
+ x_sel <- paste(+ |
+
| 474 | +3x | +
+ paste0(vars[1], v1_v2_grid$v1),+ |
+
| 475 | +3x | +
+ paste0(vars[2], v1_v2_grid$v2),+ |
+
| 476 | +3x | +
+ sep = ":"+ |
+
| 477 | ++ |
+ )+ |
+
| 478 | +3x | +
+ x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE)+ |
+
| 479 | +3x | +
+ colnames(x_stats) <- names(stats)+ |
+
| 480 | +3x | +
+ x_stats$term <- paste(v1_v2_grid$v1, "*", v1_v2_grid$v2)+ |
+
| 481 | +3x | +
+ x_numbers <- table(fit_glm$data[[vars[1]]], fit_glm$data[[vars[2]]])+ |
+
| 482 | +3x | +
+ x_stats$term_label <- h_interaction_term_labels(v1_v2_grid$v1, v1_v2_grid$v2, x_numbers)+ |
+
| 483 | +3x | +
+ v1_ref <- xs_level[[vars[1]]][1]+ |
+
| 484 | +3x | +
+ v2_ref <- xs_level[[vars[2]]][1]+ |
+
| 485 | +3x | +
+ term_main <- paste(vars[1], vars[2], sep = " * ")+ |
+
| 486 | +3x | +
+ ref_label <- h_interaction_term_labels(v1_ref, v2_ref, x_numbers, any = TRUE)+ |
+
| 487 | ++ |
+ }+ |
+
| 488 | +6x | +
+ x_stats$df <- as.list(1)+ |
+
| 489 | +6x | +
+ x_stats$pvalue <- as.list(x_stats$pvalue)+ |
+
| 490 | +6x | +
+ x_stats$is_variable_summary <- FALSE+ |
+
| 491 | +6x | +
+ x_stats$is_term_summary <- TRUE+ |
+
| 492 | +6x | +
+ x_main <- data.frame(+ |
+
| 493 | +6x | +
+ pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE],+ |
+
| 494 | +6x | +
+ term = term_main,+ |
+
| 495 | +6x | +
+ term_label = paste("Reference", ref_label),
+ |
+
| 496 | +6x | +
+ df = main_effects[x, "Df", drop = TRUE],+ |
+
| 497 | +6x | +
+ stringsAsFactors = FALSE+ |
+
| 498 | ++ |
+ )+ |
+
| 499 | +6x | +
+ x_main$pvalue <- as.list(x_main$pvalue)+ |
+
| 500 | +6x | +
+ x_main$df <- as.list(x_main$df)+ |
+
| 501 | +6x | +
+ x_main$estimate <- list(numeric(0))+ |
+
| 502 | +6x | +
+ x_main$std_error <- list(numeric(0))+ |
+
| 503 | +6x | +
+ x_main$is_variable_summary <- TRUE+ |
+
| 504 | +6x | +
+ x_main$is_term_summary <- FALSE+ |
+
| 505 | ++ | + + | +
| 506 | +6x | +
+ x_stats <- rbind(x_main, x_stats)+ |
+
| 507 | +6x | +
+ x_stats$variable <- x+ |
+
| 508 | +6x | +
+ x_stats$variable_label <- paste(+ |
+
| 509 | +6x | +
+ "Interaction of",+ |
+
| 510 | +6x | +
+ formatters::var_labels(fit_glm$data[vars[1]], fill = TRUE),+ |
+
| 511 | ++ |
+ "*",+ |
+
| 512 | +6x | +
+ formatters::var_labels(fit_glm$data[vars[2]], fill = TRUE)+ |
+
| 513 | ++ |
+ )+ |
+
| 514 | +6x | +
+ x_stats$interaction <- ""+ |
+
| 515 | +6x | +
+ x_stats$interaction_label <- ""+ |
+
| 516 | +6x | +
+ x_stats$reference <- ""+ |
+
| 517 | +6x | +
+ x_stats$reference_label <- ""+ |
+
| 518 | +6x | +
+ rownames(x_stats) <- NULL+ |
+
| 519 | +6x | +
+ x_stats[c(+ |
+
| 520 | +6x | +
+ "variable",+ |
+
| 521 | +6x | +
+ "variable_label",+ |
+
| 522 | +6x | +
+ "term",+ |
+
| 523 | +6x | +
+ "term_label",+ |
+
| 524 | +6x | +
+ "interaction",+ |
+
| 525 | +6x | +
+ "interaction_label",+ |
+
| 526 | +6x | +
+ "reference",+ |
+
| 527 | +6x | +
+ "reference_label",+ |
+
| 528 | +6x | +
+ "estimate",+ |
+
| 529 | +6x | +
+ "std_error",+ |
+
| 530 | +6x | +
+ "df",+ |
+
| 531 | +6x | +
+ "pvalue",+ |
+
| 532 | +6x | +
+ "is_variable_summary",+ |
+
| 533 | +6x | +
+ "is_term_summary"+ |
+
| 534 | ++ |
+ )]+ |
+
| 535 | ++ |
+ }+ |
+
| 536 | ++ | + + | +
| 537 | ++ |
+ #' @describeIn h_logistic_regression Helper function to tabulate the interaction+ |
+
| 538 | ++ |
+ #' results of a logistic regression model. This basically is a wrapper for+ |
+
| 539 | ++ |
+ #' [h_or_interaction()] and [h_glm_simple_term_extract()] which puts the results+ |
+
| 540 | ++ |
+ #' in the right data frame format.+ |
+
| 541 | ++ |
+ #'+ |
+
| 542 | ++ |
+ #' @return A `data.frame` of tabulated interaction term results from a logistic regression model.+ |
+
| 543 | ++ |
+ #'+ |
+
| 544 | ++ |
+ #' @examples+ |
+
| 545 | ++ |
+ #' h_glm_inter_term_extract("AGE", "ARMCD", mod2)
+ |
+
| 546 | ++ |
+ #'+ |
+
| 547 | ++ |
+ #' @export+ |
+
| 548 | ++ |
+ h_glm_inter_term_extract <- function(odds_ratio_var,+ |
+
| 549 | ++ |
+ interaction_var,+ |
+
| 550 | ++ |
+ fit_glm,+ |
+
| 551 | ++ |
+ ...) {
+ |
+
| 552 | ++ |
+ # First obtain the main effects.+ |
+
| 553 | +11x | +
+ main_stats <- h_glm_simple_term_extract(odds_ratio_var, fit_glm)+ |
+
| 554 | +11x | +
+ main_stats$is_reference_summary <- FALSE+ |
+
| 555 | +11x | +
+ main_stats$odds_ratio <- NA+ |
+
| 556 | +11x | +
+ main_stats$lcl <- NA+ |
+
| 557 | +11x | +
+ main_stats$ucl <- NA+ |
+
| 558 | ++ | + + | +
| 559 | ++ |
+ # Then we get the odds ratio estimates and put into df form.+ |
+
| 560 | +11x | +
+ or_numbers <- h_or_interaction(odds_ratio_var, interaction_var, fit_glm, ...)+ |
+
| 561 | +11x | +
+ is_num_or_var <- attr(fit_glm$terms, "dataClasses")[odds_ratio_var] == "numeric"+ |
+
| 562 | ++ | + + | +
| 563 | +11x | +
+ if (is_num_or_var) {
+ |
+
| 564 | ++ |
+ # Numeric OR variable case.+ |
+
| 565 | +3x | +
+ references <- names(or_numbers)+ |
+
| 566 | +3x | +
+ n_ref <- length(references)+ |
+
| 567 | ++ | + + | +
| 568 | +3x | +
+ extract_from_list <- function(l, name, pos = 1) {
+ |
+
| 569 | +9x | +
+ unname(unlist(+ |
+
| 570 | +9x | +
+ lapply(or_numbers, function(x) {
+ |
+
| 571 | +27x | +
+ x[[name]][pos]+ |
+
| 572 | ++ |
+ })+ |
+
| 573 | ++ |
+ ))+ |
+
| 574 | ++ |
+ }+ |
+
| 575 | +3x | +
+ or_stats <- data.frame(+ |
+
| 576 | +3x | +
+ variable = odds_ratio_var,+ |
+
| 577 | +3x | +
+ variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),+ |
+
| 578 | +3x | +
+ term = odds_ratio_var,+ |
+
| 579 | +3x | +
+ term_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),+ |
+
| 580 | +3x | +
+ interaction = interaction_var,+ |
+
| 581 | +3x | +
+ interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)),+ |
+
| 582 | +3x | +
+ reference = references,+ |
+
| 583 | +3x | +
+ reference_label = references,+ |
+
| 584 | +3x | +
+ estimate = NA,+ |
+
| 585 | +3x | +
+ std_error = NA,+ |
+
| 586 | +3x | +
+ odds_ratio = extract_from_list(or_numbers, "or"),+ |
+
| 587 | +3x | +
+ lcl = extract_from_list(or_numbers, "ci", pos = "lcl"),+ |
+
| 588 | +3x | +
+ ucl = extract_from_list(or_numbers, "ci", pos = "ucl"),+ |
+
| 589 | +3x | +
+ df = NA,+ |
+
| 590 | +3x | +
+ pvalue = NA,+ |
+
| 591 | +3x | +
+ is_variable_summary = FALSE,+ |
+
| 592 | +3x | +
+ is_term_summary = FALSE,+ |
+
| 593 | +3x | +
+ is_reference_summary = TRUE+ |
+
| 594 | ++ |
+ )+ |
+
| 595 | ++ |
+ } else {
+ |
+
| 596 | ++ |
+ # Categorical OR variable case.+ |
+
| 597 | +8x | +
+ references <- names(or_numbers[[1]])+ |
+
| 598 | +8x | +
+ n_ref <- length(references)+ |
+
| 599 | ++ | + + | +
| 600 | +8x | +
+ extract_from_list <- function(l, name, pos = 1) {
+ |
+
| 601 | +24x | +
+ unname(unlist(+ |
+
| 602 | +24x | +
+ lapply(or_numbers, function(x) {
+ |
+
| 603 | +42x | +
+ lapply(x, function(y) y[[name]][pos])+ |
+
| 604 | ++ |
+ })+ |
+
| 605 | ++ |
+ ))+ |
+
| 606 | ++ |
+ }+ |
+
| 607 | +8x | +
+ or_stats <- data.frame(+ |
+
| 608 | +8x | +
+ variable = odds_ratio_var,+ |
+
| 609 | +8x | +
+ variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),+ |
+
| 610 | +8x | +
+ term = rep(names(or_numbers), each = n_ref),+ |
+
| 611 | +8x | +
+ term_label = h_simple_term_labels(rep(names(or_numbers), each = n_ref), table(fit_glm$data[[odds_ratio_var]])),+ |
+
| 612 | +8x | +
+ interaction = interaction_var,+ |
+
| 613 | +8x | +
+ interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)),+ |
+
| 614 | +8x | +
+ reference = unlist(lapply(or_numbers, names)),+ |
+
| 615 | +8x | +
+ reference_label = unlist(lapply(or_numbers, names)),+ |
+
| 616 | +8x | +
+ estimate = NA,+ |
+
| 617 | +8x | +
+ std_error = NA,+ |
+
| 618 | +8x | +
+ odds_ratio = extract_from_list(or_numbers, "or"),+ |
+
| 619 | +8x | +
+ lcl = extract_from_list(or_numbers, "ci", pos = "lcl"),+ |
+
| 620 | +8x | +
+ ucl = extract_from_list(or_numbers, "ci", pos = "ucl"),+ |
+
| 621 | +8x | +
+ df = NA,+ |
+
| 622 | +8x | +
+ pvalue = NA,+ |
+
| 623 | +8x | +
+ is_variable_summary = FALSE,+ |
+
| 624 | +8x | +
+ is_term_summary = FALSE,+ |
+
| 625 | +8x | +
+ is_reference_summary = TRUE+ |
+
| 626 | ++ |
+ )+ |
+
| 627 | ++ |
+ }+ |
+
| 628 | ++ | + + | +
| 629 | +11x | +
+ df <- rbind(+ |
+
| 630 | +11x | +
+ main_stats[, names(or_stats)],+ |
+
| 631 | +11x | +
+ or_stats+ |
+
| 632 | ++ |
+ )+ |
+
| 633 | +11x | +
+ df[order(-df$is_variable_summary, df$term, -df$is_term_summary, df$reference), ]+ |
+
| 634 | ++ |
+ }+ |
+
| 635 | ++ | + + | +
| 636 | ++ |
+ #' @describeIn h_logistic_regression Helper function to tabulate the results including+ |
+
| 637 | ++ |
+ #' odds ratios and confidence intervals of simple terms.+ |
+
| 638 | ++ |
+ #'+ |
+
| 639 | ++ |
+ #' @return Tabulated statistics for the given variable(s) from the logistic regression model.+ |
+
| 640 | ++ |
+ #'+ |
+
| 641 | ++ |
+ #' @examples+ |
+
| 642 | ++ |
+ #' h_logistic_simple_terms("AGE", mod1)
+ |
+
| 643 | ++ |
+ #'+ |
+
| 644 | ++ |
+ #' @export+ |
+
| 645 | ++ |
+ h_logistic_simple_terms <- function(x, fit_glm, conf_level = 0.95) {
+ |
+
| 646 | +40x | +
+ checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
+ |
+
| 647 | +40x | +
+ if (inherits(fit_glm, "glm")) {
+ |
+
| 648 | +29x | +
+ checkmate::assert_set_equal(fit_glm$family$family, "binomial")+ |
+
| 649 | ++ |
+ }+ |
+
| 650 | +40x | +
+ terms_name <- attr(stats::terms(fit_glm), "term.labels")+ |
+
| 651 | +40x | +
+ xs_class <- attr(fit_glm$terms, "dataClasses")+ |
+
| 652 | +40x | +
+ interaction <- terms_name[which(!terms_name %in% names(xs_class))]+ |
+
| 653 | +40x | +
+ checkmate::assert_subset(x, terms_name)+ |
+
| 654 | +40x | +
+ if (length(interaction) != 0) {
+ |
+
| 655 | ++ |
+ # Make sure any item in x is not part of interaction term+ |
+
| 656 | +1x | +
+ checkmate::assert_disjunct(x, unlist(strsplit(interaction, ":")))+ |
+
| 657 | ++ |
+ }+ |
+
| 658 | +40x | +
+ x_stats <- lapply(x, h_glm_simple_term_extract, fit_glm)+ |
+
| 659 | +40x | +
+ x_stats <- do.call(rbind, x_stats)+ |
+
| 660 | +40x | +
+ q_norm <- stats::qnorm((1 + conf_level) / 2)+ |
+
| 661 | +40x | +
+ x_stats$odds_ratio <- lapply(x_stats$estimate, exp)+ |
+
| 662 | +40x | +
+ x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error)+ |
+
| 663 | +40x | +
+ x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error)+ |
+
| 664 | +40x | +
+ x_stats$ci <- Map(function(lcl, ucl) c(lcl, ucl), lcl = x_stats$lcl, ucl = x_stats$ucl)+ |
+
| 665 | +40x | +
+ x_stats+ |
+
| 666 | ++ |
+ }+ |
+
| 667 | ++ | + + | +
| 668 | ++ |
+ #' @describeIn h_logistic_regression Helper function to tabulate the results including+ |
+
| 669 | ++ |
+ #' odds ratios and confidence intervals of interaction terms.+ |
+
| 670 | ++ |
+ #'+ |
+
| 671 | ++ |
+ #' @return Tabulated statistics for the given variable(s) from the logistic regression model.+ |
+
| 672 | ++ |
+ #'+ |
+
| 673 | ++ |
+ #' @examples+ |
+
| 674 | ++ |
+ #' h_logistic_inter_terms(c("RACE", "AGE", "ARMCD", "AGE:ARMCD"), mod2)
+ |
+
| 675 | ++ |
+ #'+ |
+
| 676 | ++ |
+ #' @export+ |
+
| 677 | ++ |
+ h_logistic_inter_terms <- function(x,+ |
+
| 678 | ++ |
+ fit_glm,+ |
+
| 679 | ++ |
+ conf_level = 0.95,+ |
+
| 680 | ++ |
+ at = NULL) {
+ |
+
| 681 | ++ |
+ # Find out the interaction variables and interaction term.+ |
+
| 682 | +4x | +
+ inter_vars <- h_get_interaction_vars(fit_glm)+ |
+
| 683 | +4x | +
+ checkmate::assert_vector(inter_vars, len = 2)+ |
+
| 684 | ++ | + + | +
| 685 | ++ | + + | +
| 686 | +4x | +
+ inter_term_index <- intersect(grep(inter_vars[1], x), grep(inter_vars[2], x))+ |
+
| 687 | +4x | +
+ inter_term <- x[inter_term_index]+ |
+
| 688 | ++ | + + | +
| 689 | ++ |
+ # For the non-interaction vars we need the standard stuff.+ |
+
| 690 | +4x | +
+ normal_terms <- setdiff(x, union(inter_vars, inter_term))+ |
+
| 691 | ++ | + + | +
| 692 | +4x | +
+ x_stats <- lapply(normal_terms, h_glm_simple_term_extract, fit_glm)+ |
+
| 693 | +4x | +
+ x_stats <- do.call(rbind, x_stats)+ |
+
| 694 | +4x | +
+ q_norm <- stats::qnorm((1 + conf_level) / 2)+ |
+
| 695 | +4x | +
+ x_stats$odds_ratio <- lapply(x_stats$estimate, exp)+ |
+
| 696 | +4x | +
+ x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error)+ |
+
| 697 | +4x | +
+ x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error)+ |
+
| 698 | +4x | +
+ normal_stats <- x_stats+ |
+
| 699 | +4x | +
+ normal_stats$is_reference_summary <- FALSE+ |
+
| 700 | ++ | + + | +
| 701 | ++ |
+ # Now the interaction term itself.+ |
+
| 702 | +4x | +
+ inter_term_stats <- h_glm_interaction_extract(inter_term, fit_glm)+ |
+
| 703 | +4x | +
+ inter_term_stats$odds_ratio <- NA+ |
+
| 704 | +4x | +
+ inter_term_stats$lcl <- NA+ |
+
| 705 | +4x | +
+ inter_term_stats$ucl <- NA+ |
+
| 706 | +4x | +
+ inter_term_stats$is_reference_summary <- FALSE+ |
+
| 707 | ++ | + + | +
| 708 | +4x | +
+ is_intervar1_numeric <- attr(fit_glm$terms, "dataClasses")[inter_vars[1]] == "numeric"+ |
+
| 709 | ++ | + + | +
| 710 | ++ |
+ # Interaction stuff.+ |
+
| 711 | +4x | +
+ inter_stats_one <- h_glm_inter_term_extract(+ |
+
| 712 | +4x | +
+ inter_vars[1],+ |
+
| 713 | +4x | +
+ inter_vars[2],+ |
+
| 714 | +4x | +
+ fit_glm,+ |
+
| 715 | +4x | +
+ conf_level = conf_level,+ |
+
| 716 | +4x | +
+ at = `if`(is_intervar1_numeric, NULL, at)+ |
+
| 717 | ++ |
+ )+ |
+
| 718 | +4x | +
+ inter_stats_two <- h_glm_inter_term_extract(+ |
+
| 719 | +4x | +
+ inter_vars[2],+ |
+
| 720 | +4x | +
+ inter_vars[1],+ |
+
| 721 | +4x | +
+ fit_glm,+ |
+
| 722 | +4x | +
+ conf_level = conf_level,+ |
+
| 723 | +4x | +
+ at = `if`(is_intervar1_numeric, at, NULL)+ |
+
| 724 | ++ |
+ )+ |
+
| 725 | ++ | + + | +
| 726 | ++ |
+ # Now just combine everything in one data frame.+ |
+
| 727 | +4x | +
+ col_names <- c(+ |
+
| 728 | +4x | +
+ "variable",+ |
+
| 729 | +4x | +
+ "variable_label",+ |
+
| 730 | +4x | +
+ "term",+ |
+
| 731 | +4x | +
+ "term_label",+ |
+
| 732 | +4x | +
+ "interaction",+ |
+
| 733 | +4x | +
+ "interaction_label",+ |
+
| 734 | +4x | +
+ "reference",+ |
+
| 735 | +4x | +
+ "reference_label",+ |
+
| 736 | +4x | +
+ "estimate",+ |
+
| 737 | +4x | +
+ "std_error",+ |
+
| 738 | +4x | +
+ "df",+ |
+
| 739 | +4x | +
+ "pvalue",+ |
+
| 740 | +4x | +
+ "odds_ratio",+ |
+
| 741 | +4x | +
+ "lcl",+ |
+
| 742 | +4x | +
+ "ucl",+ |
+
| 743 | +4x | +
+ "is_variable_summary",+ |
+
| 744 | +4x | +
+ "is_term_summary",+ |
+
| 745 | +4x | +
+ "is_reference_summary"+ |
+
| 746 | ++ |
+ )+ |
+
| 747 | +4x | +
+ df <- rbind(+ |
+
| 748 | +4x | +
+ inter_stats_one[, col_names],+ |
+
| 749 | +4x | +
+ inter_stats_two[, col_names],+ |
+
| 750 | +4x | +
+ inter_term_stats[, col_names]+ |
+
| 751 | ++ |
+ )+ |
+
| 752 | +4x | +
+ if (length(normal_terms) > 0) {
+ |
+
| 753 | +4x | +
+ df <- rbind(+ |
+
| 754 | +4x | +
+ normal_stats[, col_names],+ |
+
| 755 | +4x | +
+ df+ |
+
| 756 | ++ |
+ )+ |
+
| 757 | ++ |
+ }+ |
+
| 758 | +4x | +
+ df$ci <- combine_vectors(df$lcl, df$ucl)+ |
+
| 759 | +4x | +
+ df+ |
+
| 760 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Cox Regression Helper: Interactions+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Test and estimate the effect of a treatment in interaction with a covariate.+ |
+
| 6 | ++ |
+ #' The effect is estimated as the HR of the tested treatment for a given level+ |
+
| 7 | ++ |
+ #' of the covariate, in comparison to the treatment control.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 10 | ++ |
+ #' @param x (`numeric` or `factor`)\cr the values of the covariate to be tested.+ |
+
| 11 | ++ |
+ #' @param effect (`string`)\cr the name of the effect to be tested and estimated.+ |
+
| 12 | ++ |
+ #' @param covar (`string`)\cr the name of the covariate in the model.+ |
+
| 13 | ++ |
+ #' @param mod (`coxph`)\cr the Cox regression model.+ |
+
| 14 | ++ |
+ #' @param label (`string`)\cr the label to be returned as `term_label`.+ |
+
| 15 | ++ |
+ #' @param control (`list`)\cr a list of controls as returned by [control_coxreg()].+ |
+
| 16 | ++ |
+ #' @param ... see methods.+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @examples+ |
+
| 19 | ++ |
+ #' library(survival)+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' set.seed(1, kind = "Mersenne-Twister")+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' # Testing dataset [survival::bladder].+ |
+
| 24 | ++ |
+ #' dta_bladder <- with(+ |
+
| 25 | ++ |
+ #' data = bladder[bladder$enum < 5, ],+ |
+
| 26 | ++ |
+ #' data.frame(+ |
+
| 27 | ++ |
+ #' time = stop,+ |
+
| 28 | ++ |
+ #' status = event,+ |
+
| 29 | ++ |
+ #' armcd = as.factor(rx),+ |
+
| 30 | ++ |
+ #' covar1 = as.factor(enum),+ |
+
| 31 | ++ |
+ #' covar2 = factor(+ |
+
| 32 | ++ |
+ #' sample(as.factor(enum)),+ |
+
| 33 | ++ |
+ #' levels = 1:4,+ |
+
| 34 | ++ |
+ #' labels = c("F", "F", "M", "M")
+ |
+
| 35 | ++ |
+ #' )+ |
+
| 36 | ++ |
+ #' )+ |
+
| 37 | ++ |
+ #' )+ |
+
| 38 | ++ |
+ #' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
+ |
+
| 39 | ++ |
+ #' formatters::var_labels(dta_bladder)[names(labels)] <- labels+ |
+
| 40 | ++ |
+ #' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' plot(+ |
+
| 43 | ++ |
+ #' survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder),+ |
+
| 44 | ++ |
+ #' lty = 2:4,+ |
+
| 45 | ++ |
+ #' xlab = "Months",+ |
+
| 46 | ++ |
+ #' col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
+ |
+
| 47 | ++ |
+ #' )+ |
+
| 48 | ++ |
+ #'+ |
+
| 49 | ++ |
+ #' @name cox_regression_inter+ |
+
| 50 | ++ |
+ NULL+ |
+
| 51 | ++ | + + | +
| 52 | ++ |
+ #' @describeIn cox_regression_inter S3 generic helper function to determine interaction effect.+ |
+
| 53 | ++ |
+ #'+ |
+
| 54 | ++ |
+ #' @return+ |
+
| 55 | ++ |
+ #' * `h_coxreg_inter_effect()` returns a `data.frame` of covariate interaction effects consisting of the following+ |
+
| 56 | ++ |
+ #' variables: `effect`, `term`, `term_label`, `level`, `n`, `hr`, `lcl`, `ucl`, `pval`, and `pval_inter`.+ |
+
| 57 | ++ |
+ #'+ |
+
| 58 | ++ |
+ #' @export+ |
+
| 59 | ++ |
+ h_coxreg_inter_effect <- function(x,+ |
+
| 60 | ++ |
+ effect,+ |
+
| 61 | ++ |
+ covar,+ |
+
| 62 | ++ |
+ mod,+ |
+
| 63 | ++ |
+ label,+ |
+
| 64 | ++ |
+ control,+ |
+
| 65 | ++ |
+ ...) {
+ |
+
| 66 | +26x | +
+ UseMethod("h_coxreg_inter_effect", x)
+ |
+
| 67 | ++ |
+ }+ |
+
| 68 | ++ | + + | +
| 69 | ++ |
+ #' @describeIn cox_regression_inter Method for `numeric` class. Estimates the interaction with a `numeric` covariate.+ |
+
| 70 | ++ |
+ #'+ |
+
| 71 | ++ |
+ #' @method h_coxreg_inter_effect numeric+ |
+
| 72 | ++ |
+ #'+ |
+
| 73 | ++ |
+ #' @param at (`list`)\cr a list with items named after the covariate, every+ |
+
| 74 | ++ |
+ #' item is a vector of levels at which the interaction should be estimated.+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ #' @export+ |
+
| 77 | ++ |
+ h_coxreg_inter_effect.numeric <- function(x,+ |
+
| 78 | ++ |
+ effect,+ |
+
| 79 | ++ |
+ covar,+ |
+
| 80 | ++ |
+ mod,+ |
+
| 81 | ++ |
+ label,+ |
+
| 82 | ++ |
+ control,+ |
+
| 83 | ++ |
+ at,+ |
+
| 84 | ++ |
+ ...) {
+ |
+
| 85 | +7x | +
+ betas <- stats::coef(mod)+ |
+
| 86 | +7x | +
+ attrs <- attr(stats::terms(mod), "term.labels")+ |
+
| 87 | +7x | +
+ term_indices <- grep(+ |
+
| 88 | +7x | +
+ pattern = effect,+ |
+
| 89 | +7x | +
+ x = attrs[!grepl("strata\\(", attrs)]
+ |
+
| 90 | ++ |
+ )+ |
+
| 91 | +7x | +
+ checkmate::assert_vector(term_indices, len = 2)+ |
+
| 92 | +7x | +
+ betas <- betas[term_indices]+ |
+
| 93 | +7x | +
+ betas_var <- diag(stats::vcov(mod))[term_indices]+ |
+
| 94 | +7x | +
+ betas_cov <- stats::vcov(mod)[term_indices[1], term_indices[2]]+ |
+
| 95 | +7x | +
+ xval <- if (is.null(at[[covar]])) {
+ |
+
| 96 | +6x | +
+ stats::median(x)+ |
+
| 97 | ++ |
+ } else {
+ |
+
| 98 | +1x | +
+ at[[covar]]+ |
+
| 99 | ++ |
+ }+ |
+
| 100 | +7x | +
+ effect_index <- !grepl(covar, names(betas))+ |
+
| 101 | +7x | +
+ coef_hat <- betas[effect_index] + xval * betas[!effect_index]+ |
+
| 102 | +7x | +
+ coef_se <- sqrt(+ |
+
| 103 | +7x | +
+ betas_var[effect_index] ++ |
+
| 104 | +7x | +
+ xval ^ 2 * betas_var[!effect_index] + # styler: off+ |
+
| 105 | +7x | +
+ 2 * xval * betas_cov+ |
+
| 106 | ++ |
+ )+ |
+
| 107 | +7x | +
+ q_norm <- stats::qnorm((1 + control$conf_level) / 2)+ |
+
| 108 | +7x | +
+ data.frame(+ |
+
| 109 | +7x | +
+ effect = "Covariate:",+ |
+
| 110 | +7x | +
+ term = rep(covar, length(xval)),+ |
+
| 111 | +7x | +
+ term_label = paste0(" ", xval),
+ |
+
| 112 | +7x | +
+ level = as.character(xval),+ |
+
| 113 | +7x | +
+ n = NA,+ |
+
| 114 | +7x | +
+ hr = exp(coef_hat),+ |
+
| 115 | +7x | +
+ lcl = exp(coef_hat - q_norm * coef_se),+ |
+
| 116 | +7x | +
+ ucl = exp(coef_hat + q_norm * coef_se),+ |
+
| 117 | +7x | +
+ pval = NA,+ |
+
| 118 | +7x | +
+ pval_inter = NA,+ |
+
| 119 | +7x | +
+ stringsAsFactors = FALSE+ |
+
| 120 | ++ |
+ )+ |
+
| 121 | ++ |
+ }+ |
+
| 122 | ++ | + + | +
| 123 | ++ |
+ #' @describeIn cox_regression_inter Method for `factor` class. Estimate the interaction with a `factor` covariate.+ |
+
| 124 | ++ |
+ #'+ |
+
| 125 | ++ |
+ #' @method h_coxreg_inter_effect factor+ |
+
| 126 | ++ |
+ #'+ |
+
| 127 | ++ |
+ #' @param data (`data.frame`)\cr the data frame on which the model was fit.+ |
+
| 128 | ++ |
+ #'+ |
+
| 129 | ++ |
+ #' @export+ |
+
| 130 | ++ |
+ h_coxreg_inter_effect.factor <- function(x,+ |
+
| 131 | ++ |
+ effect,+ |
+
| 132 | ++ |
+ covar,+ |
+
| 133 | ++ |
+ mod,+ |
+
| 134 | ++ |
+ label,+ |
+
| 135 | ++ |
+ control,+ |
+
| 136 | ++ |
+ data,+ |
+
| 137 | ++ |
+ ...) {
+ |
+
| 138 | +15x | +
+ lvl_given <- levels(x)+ |
+
| 139 | +15x | +
+ y <- h_coxreg_inter_estimations(+ |
+
| 140 | +15x | +
+ variable = effect, given = covar,+ |
+
| 141 | +15x | +
+ lvl_var = levels(data[[effect]]),+ |
+
| 142 | +15x | +
+ lvl_given = lvl_given,+ |
+
| 143 | +15x | +
+ mod = mod,+ |
+
| 144 | +15x | +
+ conf_level = 0.95+ |
+
| 145 | +15x | +
+ )[[1]]+ |
+
| 146 | ++ | + + | +
| 147 | +15x | +
+ data.frame(+ |
+
| 148 | +15x | +
+ effect = "Covariate:",+ |
+
| 149 | +15x | +
+ term = rep(covar, nrow(y)),+ |
+
| 150 | +15x | +
+ term_label = paste0(" ", lvl_given),
+ |
+
| 151 | +15x | +
+ level = lvl_given,+ |
+
| 152 | +15x | +
+ n = NA,+ |
+
| 153 | +15x | +
+ hr = y[, "hr"],+ |
+
| 154 | +15x | +
+ lcl = y[, "lcl"],+ |
+
| 155 | +15x | +
+ ucl = y[, "ucl"],+ |
+
| 156 | +15x | +
+ pval = NA,+ |
+
| 157 | +15x | +
+ pval_inter = NA,+ |
+
| 158 | +15x | +
+ stringsAsFactors = FALSE+ |
+
| 159 | ++ |
+ )+ |
+
| 160 | ++ |
+ }+ |
+
| 161 | ++ | + + | +
| 162 | ++ |
+ #' @describeIn cox_regression_inter Method for `character` class. Estimate the interaction with a `character` covariate.+ |
+
| 163 | ++ |
+ #' This makes an automatic conversion to `factor` and then forwards to the method for factors.+ |
+
| 164 | ++ |
+ #'+ |
+
| 165 | ++ |
+ #' @method h_coxreg_inter_effect character+ |
+
| 166 | ++ |
+ #'+ |
+
| 167 | ++ |
+ #' @note+ |
+
| 168 | ++ |
+ #' * Automatic conversion of character to factor does not guarantee results can be generated correctly. It is+ |
+
| 169 | ++ |
+ #' therefore better to always pre-process the dataset such that factors are manually created from character+ |
+
| 170 | ++ |
+ #' variables before passing the dataset to [rtables::build_table()].+ |
+
| 171 | ++ |
+ #'+ |
+
| 172 | ++ |
+ #' @export+ |
+
| 173 | ++ |
+ h_coxreg_inter_effect.character <- function(x,+ |
+
| 174 | ++ |
+ effect,+ |
+
| 175 | ++ |
+ covar,+ |
+
| 176 | ++ |
+ mod,+ |
+
| 177 | ++ |
+ label,+ |
+
| 178 | ++ |
+ control,+ |
+
| 179 | ++ |
+ data,+ |
+
| 180 | ++ |
+ ...) {
+ |
+
| 181 | +4x | +
+ y <- as.factor(x)+ |
+
| 182 | ++ | + + | +
| 183 | +4x | +
+ h_coxreg_inter_effect(+ |
+
| 184 | +4x | +
+ x = y,+ |
+
| 185 | +4x | +
+ effect = effect,+ |
+
| 186 | +4x | +
+ covar = covar,+ |
+
| 187 | +4x | +
+ mod = mod,+ |
+
| 188 | +4x | +
+ label = label,+ |
+
| 189 | +4x | +
+ control = control,+ |
+
| 190 | +4x | +
+ data = data,+ |
+
| 191 | ++ |
+ ...+ |
+
| 192 | ++ |
+ )+ |
+
| 193 | ++ |
+ }+ |
+
| 194 | ++ | + + | +
| 195 | ++ |
+ #' @describeIn cox_regression_inter A higher level function to get+ |
+
| 196 | ++ |
+ #' the results of the interaction test and the estimated values.+ |
+
| 197 | ++ |
+ #'+ |
+
| 198 | ++ |
+ #' @return+ |
+
| 199 | ++ |
+ #' * `h_coxreg_extract_interaction()` returns the result of an interaction test and the estimated values. If+ |
+
| 200 | ++ |
+ #' no interaction, [h_coxreg_univar_extract()] is applied instead.+ |
+
| 201 | ++ |
+ #'+ |
+
| 202 | ++ |
+ #' @examples+ |
+
| 203 | ++ |
+ #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder)+ |
+
| 204 | ++ |
+ #' h_coxreg_extract_interaction(+ |
+
| 205 | ++ |
+ #' mod = mod, effect = "armcd", covar = "covar1", data = dta_bladder,+ |
+
| 206 | ++ |
+ #' control = control_coxreg()+ |
+
| 207 | ++ |
+ #' )+ |
+
| 208 | ++ |
+ #'+ |
+
| 209 | ++ |
+ #' @export+ |
+
| 210 | ++ |
+ h_coxreg_extract_interaction <- function(effect,+ |
+
| 211 | ++ |
+ covar,+ |
+
| 212 | ++ |
+ mod,+ |
+
| 213 | ++ |
+ data,+ |
+
| 214 | ++ |
+ at,+ |
+
| 215 | ++ |
+ control) {
+ |
+
| 216 | +27x | +
+ if (!any(attr(stats::terms(mod), "order") == 2)) {
+ |
+
| 217 | +10x | +
+ y <- h_coxreg_univar_extract(+ |
+
| 218 | +10x | +
+ effect = effect, covar = covar, mod = mod, data = data, control = control+ |
+
| 219 | ++ |
+ )+ |
+
| 220 | +10x | +
+ y$pval_inter <- NA+ |
+
| 221 | +10x | +
+ y+ |
+
| 222 | ++ |
+ } else {
+ |
+
| 223 | +17x | +
+ test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]+ |
+
| 224 | ++ | + + | +
| 225 | ++ |
+ # Test the main treatment effect.+ |
+
| 226 | +17x | +
+ mod_aov <- muffled_car_anova(mod, test_statistic)+ |
+
| 227 | +17x | +
+ sum_anova <- broom::tidy(mod_aov)+ |
+
| 228 | +17x | +
+ pval <- sum_anova[sum_anova$term == effect, ][["p.value"]]+ |
+
| 229 | ++ | + + | +
| 230 | ++ |
+ # Test the interaction effect.+ |
+
| 231 | +17x | +
+ pval_inter <- sum_anova[grep(":", sum_anova$term), ][["p.value"]]
+ |
+
| 232 | +17x | +
+ covar_test <- data.frame(+ |
+
| 233 | +17x | +
+ effect = "Covariate:",+ |
+
| 234 | +17x | +
+ term = covar,+ |
+
| 235 | +17x | +
+ term_label = unname(labels_or_names(data[covar])),+ |
+
| 236 | +17x | +
+ level = "",+ |
+
| 237 | +17x | +
+ n = mod$n, hr = NA, lcl = NA, ucl = NA, pval = pval,+ |
+
| 238 | +17x | +
+ pval_inter = pval_inter,+ |
+
| 239 | +17x | +
+ stringsAsFactors = FALSE+ |
+
| 240 | ++ |
+ )+ |
+
| 241 | ++ |
+ # Estimate the interaction.+ |
+
| 242 | +17x | +
+ y <- h_coxreg_inter_effect(+ |
+
| 243 | +17x | +
+ data[[covar]],+ |
+
| 244 | +17x | +
+ covar = covar,+ |
+
| 245 | +17x | +
+ effect = effect,+ |
+
| 246 | +17x | +
+ mod = mod,+ |
+
| 247 | +17x | +
+ label = unname(labels_or_names(data[covar])),+ |
+
| 248 | +17x | +
+ at = at,+ |
+
| 249 | +17x | +
+ control = control,+ |
+
| 250 | +17x | +
+ data = data+ |
+
| 251 | ++ |
+ )+ |
+
| 252 | +17x | +
+ rbind(covar_test, y)+ |
+
| 253 | ++ |
+ }+ |
+
| 254 | ++ |
+ }+ |
+
| 255 | ++ | + + | +
| 256 | ++ |
+ #' @describeIn cox_regression_inter Hazard ratio estimation in interactions.+ |
+
| 257 | ++ |
+ #'+ |
+
| 258 | ++ |
+ #' @param variable,given (`string`)\cr the name of variables in interaction. We seek the estimation+ |
+
| 259 | ++ |
+ #' of the levels of `variable` given the levels of `given`.+ |
+
| 260 | ++ |
+ #' @param lvl_var,lvl_given (`character`)\cr corresponding levels has given by [levels()].+ |
+
| 261 | ++ |
+ #' @param mod (`coxph`)\cr a fitted Cox regression model (see [survival::coxph()]).+ |
+
| 262 | ++ |
+ #'+ |
+
| 263 | ++ |
+ #' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A)+ |
+
| 264 | ++ |
+ #' and Sex (F, M; reference Female) and the model being abbreviated: y ~ Arm + Sex + Arm:Sex.+ |
+
| 265 | ++ |
+ #' The cox regression estimates the coefficients along with a variance-covariance matrix for:+ |
+
| 266 | ++ |
+ #'+ |
+
| 267 | ++ |
+ #' - b1 (arm b), b2 (arm c)+ |
+
| 268 | ++ |
+ #' - b3 (sex m)+ |
+
| 269 | ++ |
+ #' - b4 (arm b: sex m), b5 (arm c: sex m)+ |
+
| 270 | ++ |
+ #'+ |
+
| 271 | ++ |
+ #' The estimation of the Hazard Ratio for arm C/sex M is given in reference+ |
+
| 272 | ++ |
+ #' to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5).+ |
+
| 273 | ++ |
+ #' The interaction coefficient is deduced by b2 + b5 while the standard error+ |
+
| 274 | ++ |
+ #' is obtained as $sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$.+ |
+
| 275 | ++ |
+ #'+ |
+
| 276 | ++ |
+ #' @return+ |
+
| 277 | ++ |
+ #' * `h_coxreg_inter_estimations()` returns a list of matrices (one per level of variable) with rows corresponding+ |
+
| 278 | ++ |
+ #' to the combinations of `variable` and `given`, with columns:+ |
+
| 279 | ++ |
+ #' * `coef_hat`: Estimation of the coefficient.+ |
+
| 280 | ++ |
+ #' * `coef_se`: Standard error of the estimation.+ |
+
| 281 | ++ |
+ #' * `hr`: Hazard ratio.+ |
+
| 282 | ++ |
+ #' * `lcl, ucl`: Lower/upper confidence limit of the hazard ratio.+ |
+
| 283 | ++ |
+ #'+ |
+
| 284 | ++ |
+ #' @examples+ |
+
| 285 | ++ |
+ #' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder)+ |
+
| 286 | ++ |
+ #' result <- h_coxreg_inter_estimations(+ |
+
| 287 | ++ |
+ #' variable = "armcd", given = "covar1",+ |
+
| 288 | ++ |
+ #' lvl_var = levels(dta_bladder$armcd),+ |
+
| 289 | ++ |
+ #' lvl_given = levels(dta_bladder$covar1),+ |
+
| 290 | ++ |
+ #' mod = mod, conf_level = .95+ |
+
| 291 | ++ |
+ #' )+ |
+
| 292 | ++ |
+ #' result+ |
+
| 293 | ++ |
+ #'+ |
+
| 294 | ++ |
+ #' @export+ |
+
| 295 | ++ |
+ h_coxreg_inter_estimations <- function(variable,+ |
+
| 296 | ++ |
+ given,+ |
+
| 297 | ++ |
+ lvl_var,+ |
+
| 298 | ++ |
+ lvl_given,+ |
+
| 299 | ++ |
+ mod,+ |
+
| 300 | ++ |
+ conf_level = 0.95) {
+ |
+
| 301 | +16x | +
+ var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level+ |
+
| 302 | +16x | +
+ giv_lvl <- paste0(given, lvl_given)+ |
+
| 303 | +16x | +
+ design_mat <- expand.grid(variable = var_lvl, given = giv_lvl)+ |
+
| 304 | +16x | +
+ design_mat <- design_mat[order(design_mat$variable, design_mat$given), ]+ |
+
| 305 | +16x | +
+ design_mat <- within(+ |
+
| 306 | +16x | +
+ data = design_mat,+ |
+
| 307 | +16x | +
+ expr = {
+ |
+
| 308 | +16x | +
+ inter <- paste0(variable, ":", given)+ |
+
| 309 | +16x | +
+ rev_inter <- paste0(given, ":", variable)+ |
+
| 310 | ++ |
+ }+ |
+
| 311 | ++ |
+ )+ |
+
| 312 | +16x | +
+ split_by_variable <- design_mat$variable+ |
+
| 313 | +16x | +
+ interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/")+ |
+
| 314 | ++ | + + | +
| 315 | +16x | +
+ mmat <- stats::model.matrix(mod)[1, ]+ |
+
| 316 | +16x | +
+ mmat[!mmat == 0] <- 0+ |
+
| 317 | ++ | + + | +
| 318 | +16x | +
+ design_mat <- apply(+ |
+
| 319 | +16x | +
+ X = design_mat, MARGIN = 1, FUN = function(x) {
+ |
+
| 320 | +46x | +
+ mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1+ |
+
| 321 | +46x | +
+ mmat+ |
+
| 322 | ++ |
+ }+ |
+
| 323 | ++ |
+ )+ |
+
| 324 | +16x | +
+ colnames(design_mat) <- interaction_names+ |
+
| 325 | ++ | + + | +
| 326 | +16x | +
+ coef <- stats::coef(mod)+ |
+
| 327 | +16x | +
+ vcov <- stats::vcov(mod)+ |
+
| 328 | +16x | +
+ betas <- as.matrix(coef)+ |
+
| 329 | +16x | +
+ coef_hat <- t(design_mat) %*% betas+ |
+
| 330 | +16x | +
+ dimnames(coef_hat)[2] <- "coef"+ |
+
| 331 | +16x | +
+ coef_se <- apply(+ |
+
| 332 | +16x | +
+ design_mat, 2,+ |
+
| 333 | +16x | +
+ function(x) {
+ |
+
| 334 | +46x | +
+ vcov_el <- as.logical(x)+ |
+
| 335 | +46x | +
+ y <- vcov[vcov_el, vcov_el]+ |
+
| 336 | +46x | +
+ y <- sum(y)+ |
+
| 337 | +46x | +
+ y <- sqrt(y)+ |
+
| 338 | +46x | +
+ return(y)+ |
+
| 339 | ++ |
+ }+ |
+
| 340 | ++ |
+ )+ |
+
| 341 | +16x | +
+ q_norm <- stats::qnorm((1 + conf_level) / 2)+ |
+
| 342 | +16x | +
+ y <- cbind(coef_hat, `se(coef)` = coef_se)+ |
+
| 343 | +16x | +
+ y <- apply(y, 1, function(x) {
+ |
+
| 344 | +46x | +
+ x["hr"] <- exp(x["coef"])+ |
+
| 345 | +46x | +
+ x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"])+ |
+
| 346 | +46x | +
+ x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"])+ |
+
| 347 | +46x | +
+ x+ |
+
| 348 | ++ |
+ })+ |
+
| 349 | +16x | +
+ y <- t(y)+ |
+
| 350 | +16x | +
+ y <- by(y, split_by_variable, identity)+ |
+
| 351 | +16x | +
+ y <- lapply(y, as.matrix)+ |
+
| 352 | +16x | +
+ attr(y, "details") <- paste0(+ |
+
| 353 | +16x | +
+ "Estimations of ", variable,+ |
+
| 354 | +16x | +
+ " hazard ratio given the level of ", given, " compared to ",+ |
+
| 355 | +16x | +
+ variable, " level ", lvl_var[1], "."+ |
+
| 356 | ++ |
+ )+ |
+
| 357 | +16x | +
+ y+ |
+
| 358 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Missing Data+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Substitute missing data with a string or factor level.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param x (`factor` or `character` vector)\cr values for which any missing values should be substituted.+ |
+
| 8 | ++ |
+ #' @param label (`character`)\cr string that missing data should be replaced with.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @return `x` with any `NA` values substituted by `label`.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @examples+ |
+
| 13 | ++ |
+ #' explicit_na(c(NA, "a", "b"))+ |
+
| 14 | ++ |
+ #' is.na(explicit_na(c(NA, "a", "b")))+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' explicit_na(factor(c(NA, "a", "b")))+ |
+
| 17 | ++ |
+ #' is.na(explicit_na(factor(c(NA, "a", "b"))))+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' explicit_na(sas_na(c("a", "")))
+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @export+ |
+
| 22 | ++ |
+ explicit_na <- function(x, label = "<Missing>") {
+ |
+
| 23 | +239x | +
+ checkmate::assert_string(label)+ |
+
| 24 | ++ | + + | +
| 25 | +239x | +
+ if (is.factor(x)) {
+ |
+
| 26 | +140x | +
+ x <- forcats::fct_na_value_to_level(x, label)+ |
+
| 27 | +140x | +
+ forcats::fct_drop(x, only = label)+ |
+
| 28 | +99x | +
+ } else if (is.character(x)) {
+ |
+
| 29 | +99x | +
+ x[is.na(x)] <- label+ |
+
| 30 | +99x | +
+ x+ |
+
| 31 | ++ |
+ } else {
+ |
+
| 32 | +! | +
+ stop("only factors and character vectors allowed")
+ |
+
| 33 | ++ |
+ }+ |
+
| 34 | ++ |
+ }+ |
+
| 35 | ++ | + + | +
| 36 | ++ |
+ #' Convert Strings to `NA`+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' SAS imports missing data as empty strings or strings with whitespaces only. This helper function can be used to+ |
+
| 41 | ++ |
+ #' convert these values to `NA`s.+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' @inheritParams explicit_na+ |
+
| 44 | ++ |
+ #' @param empty (`logical`)\cr if `TRUE` empty strings get replaced by `NA`.+ |
+
| 45 | ++ |
+ #' @param whitespaces (`logical`)\cr if `TRUE` then strings made from whitespaces only get replaced with `NA`.+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ #' @return `x` with `""` and/or whitespace-only values substituted by `NA`, depending on the values of+ |
+
| 48 | ++ |
+ #' `empty` and `whitespaces`.+ |
+
| 49 | ++ |
+ #'+ |
+
| 50 | ++ |
+ #' @examples+ |
+
| 51 | ++ |
+ #' sas_na(c("1", "", " ", " ", "b"))
+ |
+
| 52 | ++ |
+ #' sas_na(factor(c("", " ", "b")))
+ |
+
| 53 | ++ |
+ #'+ |
+
| 54 | ++ |
+ #' is.na(sas_na(c("1", "", " ", " ", "b")))
+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' @export+ |
+
| 57 | ++ |
+ sas_na <- function(x, empty = TRUE, whitespaces = TRUE) {
+ |
+
| 58 | +236x | +
+ checkmate::assert_flag(empty)+ |
+
| 59 | +236x | +
+ checkmate::assert_flag(whitespaces)+ |
+
| 60 | ++ | + + | +
| 61 | +236x | +
+ if (is.factor(x)) {
+ |
+
| 62 | +133x | +
+ empty_levels <- levels(x) == ""+ |
+
| 63 | +11x | +
+ if (empty && any(empty_levels)) levels(x)[empty_levels] <- NA+ |
+
| 64 | ++ | + + | +
| 65 | +133x | +
+ ws_levels <- grepl("^\\s+$", levels(x))
+ |
+
| 66 | +! | +
+ if (whitespaces && any(ws_levels)) levels(x)[ws_levels] <- NA+ |
+
| 67 | ++ | + + | +
| 68 | +133x | +
+ x+ |
+
| 69 | +103x | +
+ } else if (is.character(x)) {
+ |
+
| 70 | +103x | +
+ if (empty) x[x == ""] <- NA_character_+ |
+
| 71 | ++ | + + | +
| 72 | +103x | +
+ if (whitespaces) x[grepl("^\\s+$", x)] <- NA_character_
+ |
+
| 73 | ++ | + + | +
| 74 | +103x | +
+ x+ |
+
| 75 | ++ |
+ } else {
+ |
+
| 76 | +! | +
+ stop("only factors and character vectors allowed")
+ |
+
| 77 | ++ |
+ }+ |
+
| 78 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Difference Test for Two Proportions+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Various tests were implemented to test the difference between two proportions.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @seealso [h_prop_diff_test]+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @name prop_diff_test+ |
+
| 12 | ++ |
+ NULL+ |
+
| 13 | ++ | + + | +
| 14 | ++ |
+ #' @describeIn prop_diff_test Statistics function which tests the difference between two proportions.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @param method (`string`)\cr one of `chisq`, `cmh`, `fisher`, or `schouten`; specifies the test used+ |
+
| 17 | ++ |
+ #' to calculate the p-value.+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @return+ |
+
| 20 | ++ |
+ #' * `s_test_proportion_diff()` returns a named `list` with a single item `pval` with an attribute `label`+ |
+
| 21 | ++ |
+ #' describing the method used. The p-value tests the null hypothesis that proportions in two groups are the same.+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @keywords internal+ |
+
| 25 | ++ |
+ s_test_proportion_diff <- function(df,+ |
+
| 26 | ++ |
+ .var,+ |
+
| 27 | ++ |
+ .ref_group,+ |
+
| 28 | ++ |
+ .in_ref_col,+ |
+
| 29 | ++ |
+ variables = list(strata = NULL),+ |
+
| 30 | ++ |
+ method = c("chisq", "schouten", "fisher", "cmh")) {
+ |
+
| 31 | +30x | +
+ method <- match.arg(method)+ |
+
| 32 | +30x | +
+ y <- list(pval = "")+ |
+
| 33 | ++ | + + | +
| 34 | +30x | +
+ if (!.in_ref_col) {
+ |
+
| 35 | +30x | +
+ assert_df_with_variables(df, list(rsp = .var))+ |
+
| 36 | +30x | +
+ assert_df_with_variables(.ref_group, list(rsp = .var))+ |
+
| 37 | +30x | +
+ rsp <- factor(+ |
+
| 38 | +30x | +
+ c(.ref_group[[.var]], df[[.var]]),+ |
+
| 39 | +30x | +
+ levels = c("TRUE", "FALSE")
+ |
+
| 40 | ++ |
+ )+ |
+
| 41 | +30x | +
+ grp <- factor(+ |
+
| 42 | +30x | +
+ rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
+ |
+
| 43 | +30x | +
+ levels = c("ref", "Not-ref")
+ |
+
| 44 | ++ |
+ )+ |
+
| 45 | ++ | + + | +
| 46 | +30x | +
+ if (!is.null(variables$strata) || method == "cmh") {
+ |
+
| 47 | +12x | +
+ strata <- variables$strata+ |
+
| 48 | +12x | +
+ checkmate::assert_false(is.null(strata))+ |
+
| 49 | +12x | +
+ strata_vars <- stats::setNames(as.list(strata), strata)+ |
+
| 50 | +12x | +
+ assert_df_with_variables(df, strata_vars)+ |
+
| 51 | +12x | +
+ assert_df_with_variables(.ref_group, strata_vars)+ |
+
| 52 | +12x | +
+ strata <- c(interaction(.ref_group[strata]), interaction(df[strata]))+ |
+
| 53 | ++ |
+ }+ |
+
| 54 | ++ | + + | +
| 55 | +30x | +
+ tbl <- switch(method,+ |
+
| 56 | +30x | +
+ cmh = table(grp, rsp, strata),+ |
+
| 57 | +30x | +
+ table(grp, rsp)+ |
+
| 58 | ++ |
+ )+ |
+
| 59 | ++ | + + | +
| 60 | +30x | +
+ y$pval <- switch(method,+ |
+
| 61 | +30x | +
+ chisq = prop_chisq(tbl),+ |
+
| 62 | +30x | +
+ cmh = prop_cmh(tbl),+ |
+
| 63 | +30x | +
+ fisher = prop_fisher(tbl),+ |
+
| 64 | +30x | +
+ schouten = prop_schouten(tbl)+ |
+
| 65 | ++ |
+ )+ |
+
| 66 | ++ |
+ }+ |
+
| 67 | ++ | + + | +
| 68 | +30x | +
+ y$pval <- formatters::with_label(y$pval, d_test_proportion_diff(method))+ |
+
| 69 | +30x | +
+ y+ |
+
| 70 | ++ |
+ }+ |
+
| 71 | ++ | + + | +
| 72 | ++ |
+ #' Description of the Difference Test Between Two Proportions+ |
+
| 73 | ++ |
+ #'+ |
+
| 74 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ #' This is an auxiliary function that describes the analysis in `s_test_proportion_diff`.+ |
+
| 77 | ++ |
+ #'+ |
+
| 78 | ++ |
+ #' @inheritParams s_test_proportion_diff+ |
+
| 79 | ++ |
+ #'+ |
+
| 80 | ++ |
+ #' @return `string` describing the test from which the p-value is derived.+ |
+
| 81 | ++ |
+ #'+ |
+
| 82 | ++ |
+ #' @export+ |
+
| 83 | ++ |
+ d_test_proportion_diff <- function(method) {
+ |
+
| 84 | +41x | +
+ checkmate::assert_string(method)+ |
+
| 85 | +41x | +
+ meth_part <- switch(method,+ |
+
| 86 | +41x | +
+ "schouten" = "Chi-Squared Test with Schouten Correction",+ |
+
| 87 | +41x | +
+ "chisq" = "Chi-Squared Test",+ |
+
| 88 | +41x | +
+ "cmh" = "Cochran-Mantel-Haenszel Test",+ |
+
| 89 | +41x | +
+ "fisher" = "Fisher's Exact Test",+ |
+
| 90 | +41x | +
+ stop(paste(method, "does not have a description"))+ |
+
| 91 | ++ |
+ )+ |
+
| 92 | +41x | +
+ paste0("p-value (", meth_part, ")")
+ |
+
| 93 | ++ |
+ }+ |
+
| 94 | ++ | + + | +
| 95 | ++ |
+ #' @describeIn prop_diff_test Formatted analysis function which is used as `afun` in `test_proportion_diff()`.+ |
+
| 96 | ++ |
+ #'+ |
+
| 97 | ++ |
+ #' @return+ |
+
| 98 | ++ |
+ #' * `a_test_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 99 | ++ |
+ #'+ |
+
| 100 | ++ |
+ #'+ |
+
| 101 | ++ |
+ #' @keywords internal+ |
+
| 102 | ++ |
+ a_test_proportion_diff <- make_afun(+ |
+
| 103 | ++ |
+ s_test_proportion_diff,+ |
+
| 104 | ++ |
+ .formats = c(pval = "x.xxxx | (<0.0001)"),+ |
+
| 105 | ++ |
+ .indent_mods = c(pval = 1L)+ |
+
| 106 | ++ |
+ )+ |
+
| 107 | ++ | + + | +
| 108 | ++ |
+ #' @describeIn prop_diff_test Layout-creating function which can take statistics function arguments+ |
+
| 109 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 110 | ++ |
+ #'+ |
+
| 111 | ++ |
+ #' @param ... other arguments are passed to [s_test_proportion_diff()].+ |
+
| 112 | ++ |
+ #'+ |
+
| 113 | ++ |
+ #' @return+ |
+
| 114 | ++ |
+ #' * `test_proportion_diff()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 115 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 116 | ++ |
+ #' the statistics from `s_test_proportion_diff()` to the table layout.+ |
+
| 117 | ++ |
+ #'+ |
+
| 118 | ++ |
+ #' @examples+ |
+
| 119 | ++ |
+ #' dta <- data.frame(+ |
+
| 120 | ++ |
+ #' rsp = sample(c(TRUE, FALSE), 100, TRUE),+ |
+
| 121 | ++ |
+ #' grp = factor(rep(c("A", "B"), each = 50)),
+ |
+
| 122 | ++ |
+ #' strat = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20))
+ |
+
| 123 | ++ |
+ #' )+ |
+
| 124 | ++ |
+ #'+ |
+
| 125 | ++ |
+ #' # With `rtables` pipelines.+ |
+
| 126 | ++ |
+ #' l <- basic_table() %>%+ |
+
| 127 | ++ |
+ #' split_cols_by(var = "grp", ref_group = "B") %>%+ |
+
| 128 | ++ |
+ #' test_proportion_diff(+ |
+
| 129 | ++ |
+ #' vars = "rsp",+ |
+
| 130 | ++ |
+ #' method = "cmh", variables = list(strata = "strat")+ |
+
| 131 | ++ |
+ #' )+ |
+
| 132 | ++ |
+ #'+ |
+
| 133 | ++ |
+ #' build_table(l, df = dta)+ |
+
| 134 | ++ |
+ #'+ |
+
| 135 | ++ |
+ #' @export+ |
+
| 136 | ++ |
+ test_proportion_diff <- function(lyt,+ |
+
| 137 | ++ |
+ vars,+ |
+
| 138 | ++ |
+ na_str = NA_character_,+ |
+
| 139 | ++ |
+ nested = TRUE,+ |
+
| 140 | ++ |
+ ...,+ |
+
| 141 | ++ |
+ var_labels = vars,+ |
+
| 142 | ++ |
+ show_labels = "hidden",+ |
+
| 143 | ++ |
+ table_names = vars,+ |
+
| 144 | ++ |
+ .stats = NULL,+ |
+
| 145 | ++ |
+ .formats = NULL,+ |
+
| 146 | ++ |
+ .labels = NULL,+ |
+
| 147 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 148 | +5x | +
+ afun <- make_afun(+ |
+
| 149 | +5x | +
+ a_test_proportion_diff,+ |
+
| 150 | +5x | +
+ .stats = .stats,+ |
+
| 151 | +5x | +
+ .formats = .formats,+ |
+
| 152 | +5x | +
+ .labels = .labels,+ |
+
| 153 | +5x | +
+ .indent_mods = .indent_mods+ |
+
| 154 | ++ |
+ )+ |
+
| 155 | +5x | +
+ analyze(+ |
+
| 156 | +5x | +
+ lyt,+ |
+
| 157 | +5x | +
+ vars,+ |
+
| 158 | +5x | +
+ afun = afun,+ |
+
| 159 | +5x | +
+ var_labels = var_labels,+ |
+
| 160 | +5x | +
+ na_str = na_str,+ |
+
| 161 | +5x | +
+ nested = nested,+ |
+
| 162 | +5x | +
+ extra_args = list(...),+ |
+
| 163 | +5x | +
+ show_labels = show_labels,+ |
+
| 164 | +5x | +
+ table_names = table_names+ |
+
| 165 | ++ |
+ )+ |
+
| 166 | ++ |
+ }+ |
+
| 167 | ++ | + + | +
| 168 | ++ |
+ #' Helper Functions to Test Proportion Differences+ |
+
| 169 | ++ |
+ #'+ |
+
| 170 | ++ |
+ #' Helper functions to implement various tests on the difference between two proportions.+ |
+
| 171 | ++ |
+ #'+ |
+
| 172 | ++ |
+ #' @param tbl (`matrix`)\cr matrix with two groups in rows and the binary response (`TRUE`/`FALSE`) in columns.+ |
+
| 173 | ++ |
+ #'+ |
+
| 174 | ++ |
+ #' @return A p-value.+ |
+
| 175 | ++ |
+ #'+ |
+
| 176 | ++ |
+ #' @seealso [prop_diff_test()] for implementation of these helper functions.+ |
+
| 177 | ++ |
+ #'+ |
+
| 178 | ++ |
+ #' @name h_prop_diff_test+ |
+
| 179 | ++ |
+ NULL+ |
+
| 180 | ++ | + + | +
| 181 | ++ |
+ #' @describeIn h_prop_diff_test performs Chi-Squared test. Internally calls [stats::prop.test()].+ |
+
| 182 | ++ |
+ #'+ |
+
| 183 | ++ |
+ #'+ |
+
| 184 | ++ |
+ #' @keywords internal+ |
+
| 185 | ++ |
+ prop_chisq <- function(tbl) {
+ |
+
| 186 | +23x | +
+ checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)+ |
+
| 187 | +23x | +
+ tbl <- tbl[, c("TRUE", "FALSE")]
+ |
+
| 188 | +23x | +
+ if (any(colSums(tbl) == 0)) {
+ |
+
| 189 | +2x | +
+ return(1)+ |
+
| 190 | ++ |
+ }+ |
+
| 191 | +21x | +
+ stats::prop.test(tbl, correct = FALSE)$p.value+ |
+
| 192 | ++ |
+ }+ |
+
| 193 | ++ | + + | +
| 194 | ++ |
+ #' @describeIn h_prop_diff_test performs stratified Cochran-Mantel-Haenszel test. Internally calls+ |
+
| 195 | ++ |
+ #' [stats::mantelhaen.test()]. Note that strata with less than two observations are automatically discarded.+ |
+
| 196 | ++ |
+ #'+ |
+
| 197 | ++ |
+ #' @param ary (`array`, 3 dimensions)\cr array with two groups in rows, the binary response+ |
+
| 198 | ++ |
+ #' (`TRUE`/`FALSE`) in columns, and the strata in the third dimension.+ |
+
| 199 | ++ |
+ #'+ |
+
| 200 | ++ |
+ #'+ |
+
| 201 | ++ |
+ #' @keywords internal+ |
+
| 202 | ++ |
+ prop_cmh <- function(ary) {
+ |
+
| 203 | +16x | +
+ checkmate::assert_array(ary)+ |
+
| 204 | +16x | +
+ checkmate::assert_integer(c(ncol(ary), nrow(ary)), lower = 2, upper = 2)+ |
+
| 205 | +16x | +
+ checkmate::assert_integer(length(dim(ary)), lower = 3, upper = 3)+ |
+
| 206 | +16x | +
+ strata_sizes <- apply(ary, MARGIN = 3, sum)+ |
+
| 207 | +16x | +
+ if (any(strata_sizes < 5)) {
+ |
+
| 208 | +1x | +
+ warning("<5 data points in some strata. CMH test may be incorrect.")
+ |
+
| 209 | +1x | +
+ ary <- ary[, , strata_sizes > 1]+ |
+
| 210 | ++ |
+ }+ |
+
| 211 | ++ | + + | +
| 212 | +16x | +
+ stats::mantelhaen.test(ary, correct = FALSE)$p.value+ |
+
| 213 | ++ |
+ }+ |
+
| 214 | ++ | + + | +
| 215 | ++ |
+ #' @describeIn h_prop_diff_test performs the Chi-Squared test with Schouten correction.+ |
+
| 216 | ++ |
+ #'+ |
+
| 217 | ++ |
+ #' @seealso Schouten correction is based upon \insertCite{Schouten1980-kd;textual}{tern}.
+ |
+
| 218 | ++ |
+ #'+ |
+
| 219 | ++ |
+ #'+ |
+
| 220 | ++ |
+ #' @keywords internal+ |
+
| 221 | ++ |
+ prop_schouten <- function(tbl) {
+ |
+
| 222 | +100x | +
+ checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)+ |
+
| 223 | +100x | +
+ tbl <- tbl[, c("TRUE", "FALSE")]
+ |
+
| 224 | +100x | +
+ if (any(colSums(tbl) == 0)) {
+ |
+
| 225 | +1x | +
+ return(1)+ |
+
| 226 | ++ |
+ }+ |
+
| 227 | ++ | + + | +
| 228 | +99x | +
+ n <- sum(tbl)+ |
+
| 229 | +99x | +
+ n1 <- sum(tbl[1, ])+ |
+
| 230 | +99x | +
+ n2 <- sum(tbl[2, ])+ |
+
| 231 | ++ | + + | +
| 232 | +99x | +
+ ad <- diag(tbl)+ |
+
| 233 | +99x | +
+ bc <- diag(apply(tbl, 2, rev))+ |
+
| 234 | +99x | +
+ ac <- tbl[, 1]+ |
+
| 235 | +99x | +
+ bd <- tbl[, 2]+ |
+
| 236 | ++ | + + | +
| 237 | +99x | +
+ t_schouten <- (n - 1) *+ |
+
| 238 | +99x | +
+ (abs(prod(ad) - prod(bc)) - 0.5 * min(n1, n2))^2 /+ |
+
| 239 | +99x | +
+ (n1 * n2 * sum(ac) * sum(bd))+ |
+
| 240 | ++ | + + | +
| 241 | +99x | +
+ 1 - stats::pchisq(t_schouten, df = 1)+ |
+
| 242 | ++ |
+ }+ |
+
| 243 | ++ | + + | +
| 244 | ++ |
+ #' @describeIn h_prop_diff_test performs the Fisher's exact test. Internally calls [stats::fisher.test()].+ |
+
| 245 | ++ |
+ #'+ |
+
| 246 | ++ |
+ #'+ |
+
| 247 | ++ |
+ #' @keywords internal+ |
+
| 248 | ++ |
+ prop_fisher <- function(tbl) {
+ |
+
| 249 | +2x | +
+ checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)+ |
+
| 250 | +2x | +
+ tbl <- tbl[, c("TRUE", "FALSE")]
+ |
+
| 251 | +2x | +
+ stats::fisher.test(tbl)$p.value+ |
+
| 252 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Compare Variables Between Groups+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Comparison with a reference group for different `x` objects.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @note+ |
+
| 10 | ++ |
+ #' * For factor variables, `denom` for factor proportions can only be `n` since the purpose is to compare proportions+ |
+
| 11 | ++ |
+ #' between columns, therefore a row-based proportion would not make sense. Proportion based on `N_col` would+ |
+
| 12 | ++ |
+ #' be difficult since we use counts for the chi-squared test statistic, therefore missing values should be accounted+ |
+
| 13 | ++ |
+ #' for as explicit factor levels.+ |
+
| 14 | ++ |
+ #' * If factor variables contain `NA`, these `NA` values are excluded by default. To include `NA` values+ |
+
| 15 | ++ |
+ #' set `na.rm = FALSE` and missing values will be displayed as an `NA` level. Alternatively, an explicit+ |
+
| 16 | ++ |
+ #' factor level can be defined for `NA` values during pre-processing via [df_explicit_na()] - the+ |
+
| 17 | ++ |
+ #' default `na_level` (`"<Missing>"`) will also be excluded when `na.rm` is set to `TRUE`.+ |
+
| 18 | ++ |
+ #' * For character variables, automatic conversion to factor does not guarantee that the table+ |
+
| 19 | ++ |
+ #' will be generated correctly. In particular for sparse tables this very likely can fail.+ |
+
| 20 | ++ |
+ #' Therefore it is always better to manually convert character variables to factors during pre-processing.+ |
+
| 21 | ++ |
+ #' * For `compare_vars()`, the column split must define a reference group via `ref_group` so that the comparison+ |
+
| 22 | ++ |
+ #' is well defined.+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @seealso Relevant constructor function [create_afun_compare()], [s_summary()] which is used internally+ |
+
| 25 | ++ |
+ #' to compute a summary within `s_compare()`, and [a_compare()] which is used (with `compare = TRUE`) as the analysis+ |
+
| 26 | ++ |
+ #' function for `compare_vars()`.+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @name compare_variables+ |
+
| 29 | ++ |
+ #' @include analyze_variables.R+ |
+
| 30 | ++ |
+ NULL+ |
+
| 31 | ++ | + + | +
| 32 | ++ |
+ #' @describeIn compare_variables S3 generic function to produce a comparison summary.+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' @return+ |
+
| 35 | ++ |
+ #' * `s_compare()` returns output of [s_summary()] and comparisons versus the reference group in the form of p-values.+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' @export+ |
+
| 38 | ++ |
+ s_compare <- function(x,+ |
+
| 39 | ++ |
+ .ref_group,+ |
+
| 40 | ++ |
+ .in_ref_col,+ |
+
| 41 | ++ |
+ ...) {
+ |
+
| 42 | +28x | +
+ UseMethod("s_compare", x)
+ |
+
| 43 | ++ |
+ }+ |
+
| 44 | ++ | + + | +
| 45 | ++ |
+ #' @describeIn compare_variables Method for `numeric` class. This uses the standard t-test+ |
+
| 46 | ++ |
+ #' to calculate the p-value.+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ #' @method s_compare numeric+ |
+
| 49 | ++ |
+ #'+ |
+
| 50 | ++ |
+ #' @examples+ |
+
| 51 | ++ |
+ #' # `s_compare.numeric`+ |
+
| 52 | ++ |
+ #'+ |
+
| 53 | ++ |
+ #' ## Usual case where both this and the reference group vector have more than 1 value.+ |
+
| 54 | ++ |
+ #' s_compare(rnorm(10, 5, 1), .ref_group = rnorm(5, -5, 1), .in_ref_col = FALSE)+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' ## If one group has not more than 1 value, then p-value is not calculated.+ |
+
| 57 | ++ |
+ #' s_compare(rnorm(10, 5, 1), .ref_group = 1, .in_ref_col = FALSE)+ |
+
| 58 | ++ |
+ #'+ |
+
| 59 | ++ |
+ #' ## Empty numeric does not fail, it returns NA-filled items and no p-value.+ |
+
| 60 | ++ |
+ #' s_compare(numeric(), .ref_group = numeric(), .in_ref_col = FALSE)+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' @export+ |
+
| 63 | ++ |
+ s_compare.numeric <- function(x,+ |
+
| 64 | ++ |
+ .ref_group,+ |
+
| 65 | ++ |
+ .in_ref_col,+ |
+
| 66 | ++ |
+ ...) {
+ |
+
| 67 | +12x | +
+ checkmate::assert_numeric(x)+ |
+
| 68 | +12x | +
+ checkmate::assert_numeric(.ref_group)+ |
+
| 69 | +12x | +
+ checkmate::assert_flag(.in_ref_col)+ |
+
| 70 | ++ | + + | +
| 71 | +12x | +
+ y <- s_summary.numeric(x = x, ...)+ |
+
| 72 | ++ | + + | +
| 73 | +12x | +
+ y$pval <- if (!.in_ref_col && n_available(x) > 1 && n_available(.ref_group) > 1) {
+ |
+
| 74 | +9x | +
+ stats::t.test(x, .ref_group)$p.value+ |
+
| 75 | ++ |
+ } else {
+ |
+
| 76 | +3x | +
+ character()+ |
+
| 77 | ++ |
+ }+ |
+
| 78 | ++ | + + | +
| 79 | +12x | +
+ y+ |
+
| 80 | ++ |
+ }+ |
+
| 81 | ++ | + + | +
| 82 | ++ |
+ #' @describeIn compare_variables Method for `factor` class. This uses the chi-squared test+ |
+
| 83 | ++ |
+ #' to calculate the p-value.+ |
+
| 84 | ++ |
+ #'+ |
+
| 85 | ++ |
+ #' @param denom (`string`)\cr choice of denominator for factor proportions,+ |
+
| 86 | ++ |
+ #' can only be `n` (number of values in this row and column intersection).+ |
+
| 87 | ++ |
+ #'+ |
+
| 88 | ++ |
+ #' @method s_compare factor+ |
+
| 89 | ++ |
+ #'+ |
+
| 90 | ++ |
+ #' @examples+ |
+
| 91 | ++ |
+ #' # `s_compare.factor`+ |
+
| 92 | ++ |
+ #'+ |
+
| 93 | ++ |
+ #' ## Basic usage:+ |
+
| 94 | ++ |
+ #' x <- factor(c("a", "a", "b", "c", "a"))
+ |
+
| 95 | ++ |
+ #' y <- factor(c("a", "b", "c"))
+ |
+
| 96 | ++ |
+ #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE)+ |
+
| 97 | ++ |
+ #'+ |
+
| 98 | ++ |
+ #' ## Management of NA values.+ |
+
| 99 | ++ |
+ #' x <- explicit_na(factor(c("a", "a", "b", "c", "a", NA, NA)))
+ |
+
| 100 | ++ |
+ #' y <- explicit_na(factor(c("a", "b", "c", NA)))
+ |
+
| 101 | ++ |
+ #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE)+ |
+
| 102 | ++ |
+ #' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE)+ |
+
| 103 | ++ |
+ #'+ |
+
| 104 | ++ |
+ #' @export+ |
+
| 105 | ++ |
+ s_compare.factor <- function(x,+ |
+
| 106 | ++ |
+ .ref_group,+ |
+
| 107 | ++ |
+ .in_ref_col,+ |
+
| 108 | ++ |
+ denom = "n",+ |
+
| 109 | ++ |
+ na.rm = TRUE, # nolint+ |
+
| 110 | ++ |
+ ...) {
+ |
+
| 111 | +12x | +
+ checkmate::assert_flag(.in_ref_col)+ |
+
| 112 | +12x | +
+ assert_valid_factor(x)+ |
+
| 113 | +12x | +
+ assert_valid_factor(.ref_group)+ |
+
| 114 | +12x | +
+ denom <- match.arg(denom)+ |
+
| 115 | ++ | + + | +
| 116 | +12x | +
+ y <- s_summary.factor(+ |
+
| 117 | +12x | +
+ x = x,+ |
+
| 118 | +12x | +
+ denom = denom,+ |
+
| 119 | +12x | +
+ na.rm = na.rm,+ |
+
| 120 | ++ |
+ ...+ |
+
| 121 | ++ |
+ )+ |
+
| 122 | ++ | + + | +
| 123 | +12x | +
+ if (na.rm) {
+ |
+
| 124 | +12x | +
+ x <- x[!is.na(x)] %>% fct_discard("<Missing>")
+ |
+
| 125 | +12x | +
+ .ref_group <- .ref_group[!is.na(.ref_group)] %>% fct_discard("<Missing>")
+ |
+
| 126 | ++ |
+ } else {
+ |
+
| 127 | +! | +
+ x <- x %>% explicit_na(label = "NA")+ |
+
| 128 | +! | +
+ .ref_group <- .ref_group %>% explicit_na(label = "NA")+ |
+
| 129 | ++ |
+ }+ |
+
| 130 | ++ | + + | +
| 131 | +! | +
+ if ("NA" %in% levels(x)) levels(.ref_group) <- c(levels(.ref_group), "NA")
+ |
+
| 132 | +12x | +
+ checkmate::assert_factor(x, levels = levels(.ref_group), min.levels = 2)+ |
+
| 133 | ++ | + + | +
| 134 | +12x | +
+ y$pval_counts <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
+ |
+
| 135 | +9x | +
+ tab <- rbind(table(x), table(.ref_group))+ |
+
| 136 | +9x | +
+ res <- suppressWarnings(stats::chisq.test(tab))+ |
+
| 137 | +9x | +
+ res$p.value+ |
+
| 138 | ++ |
+ } else {
+ |
+
| 139 | +3x | +
+ character()+ |
+
| 140 | ++ |
+ }+ |
+
| 141 | ++ | + + | +
| 142 | +12x | +
+ y+ |
+
| 143 | ++ |
+ }+ |
+
| 144 | ++ | + + | +
| 145 | ++ |
+ #' @describeIn compare_variables Method for `character` class. This makes an automatic+ |
+
| 146 | ++ |
+ #' conversion to `factor` (with a warning) and then forwards to the method for factors.+ |
+
| 147 | ++ |
+ #'+ |
+
| 148 | ++ |
+ #' @param verbose (`logical`)\cr Whether warnings and messages should be printed. Mainly used+ |
+
| 149 | ++ |
+ #' to print out information about factor casting. Defaults to `TRUE`.+ |
+
| 150 | ++ |
+ #'+ |
+
| 151 | ++ |
+ #' @method s_compare character+ |
+
| 152 | ++ |
+ #'+ |
+
| 153 | ++ |
+ #' @examples+ |
+
| 154 | ++ |
+ #' # `s_compare.character`+ |
+
| 155 | ++ |
+ #'+ |
+
| 156 | ++ |
+ #' ## Basic usage:+ |
+
| 157 | ++ |
+ #' x <- c("a", "a", "b", "c", "a")
+ |
+
| 158 | ++ |
+ #' y <- c("a", "b", "c")
+ |
+
| 159 | ++ |
+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, .var = "x", verbose = FALSE)+ |
+
| 160 | ++ |
+ #'+ |
+
| 161 | ++ |
+ #' ## Note that missing values handling can make a large difference:+ |
+
| 162 | ++ |
+ #' x <- c("a", "a", "b", "c", "a", NA)
+ |
+
| 163 | ++ |
+ #' y <- c("a", "b", "c", rep(NA, 20))
+ |
+
| 164 | ++ |
+ #' s_compare(x,+ |
+
| 165 | ++ |
+ #' .ref_group = y, .in_ref_col = FALSE,+ |
+
| 166 | ++ |
+ #' .var = "x", verbose = FALSE+ |
+
| 167 | ++ |
+ #' )+ |
+
| 168 | ++ |
+ #' s_compare(x,+ |
+
| 169 | ++ |
+ #' .ref_group = y, .in_ref_col = FALSE, .var = "x",+ |
+
| 170 | ++ |
+ #' na.rm = FALSE, verbose = FALSE+ |
+
| 171 | ++ |
+ #' )+ |
+
| 172 | ++ |
+ #'+ |
+
| 173 | ++ |
+ #' @export+ |
+
| 174 | ++ |
+ s_compare.character <- function(x,+ |
+
| 175 | ++ |
+ .ref_group,+ |
+
| 176 | ++ |
+ .in_ref_col,+ |
+
| 177 | ++ |
+ denom = "n",+ |
+
| 178 | ++ |
+ na.rm = TRUE, # nolint+ |
+
| 179 | ++ |
+ .var,+ |
+
| 180 | ++ |
+ verbose = TRUE,+ |
+
| 181 | ++ |
+ ...) {
+ |
+
| 182 | +1x | +
+ x <- as_factor_keep_attributes(x, verbose = verbose)+ |
+
| 183 | +1x | +
+ .ref_group <- as_factor_keep_attributes(.ref_group, verbose = verbose)+ |
+
| 184 | +1x | +
+ s_compare(+ |
+
| 185 | +1x | +
+ x = x,+ |
+
| 186 | +1x | +
+ .ref_group = .ref_group,+ |
+
| 187 | +1x | +
+ .in_ref_col = .in_ref_col,+ |
+
| 188 | +1x | +
+ denom = denom,+ |
+
| 189 | +1x | +
+ na.rm = na.rm,+ |
+
| 190 | ++ |
+ ...+ |
+
| 191 | ++ |
+ )+ |
+
| 192 | ++ |
+ }+ |
+
| 193 | ++ | + + | +
| 194 | ++ |
+ #' @describeIn compare_variables Method for `logical` class. A chi-squared test+ |
+
| 195 | ++ |
+ #' is used. If missing values are not removed, then they are counted as `FALSE`.+ |
+
| 196 | ++ |
+ #'+ |
+
| 197 | ++ |
+ #' @method s_compare logical+ |
+
| 198 | ++ |
+ #'+ |
+
| 199 | ++ |
+ #' @examples+ |
+
| 200 | ++ |
+ #' # `s_compare.logical`+ |
+
| 201 | ++ |
+ #'+ |
+
| 202 | ++ |
+ #' ## Basic usage:+ |
+
| 203 | ++ |
+ #' x <- c(TRUE, FALSE, TRUE, TRUE)+ |
+
| 204 | ++ |
+ #' y <- c(FALSE, FALSE, TRUE)+ |
+
| 205 | ++ |
+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE)+ |
+
| 206 | ++ |
+ #'+ |
+
| 207 | ++ |
+ #' ## Management of NA values.+ |
+
| 208 | ++ |
+ #' x <- c(NA, TRUE, FALSE)+ |
+
| 209 | ++ |
+ #' y <- c(NA, NA, NA, NA, FALSE)+ |
+
| 210 | ++ |
+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE)+ |
+
| 211 | ++ |
+ #' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE)+ |
+
| 212 | ++ |
+ #'+ |
+
| 213 | ++ |
+ #' @export+ |
+
| 214 | ++ |
+ s_compare.logical <- function(x,+ |
+
| 215 | ++ |
+ .ref_group,+ |
+
| 216 | ++ |
+ .in_ref_col,+ |
+
| 217 | ++ |
+ na.rm = TRUE, # nolint+ |
+
| 218 | ++ |
+ denom = "n",+ |
+
| 219 | ++ |
+ ...) {
+ |
+
| 220 | +3x | +
+ denom <- match.arg(denom)+ |
+
| 221 | ++ | + + | +
| 222 | +3x | +
+ y <- s_summary.logical(+ |
+
| 223 | +3x | +
+ x = x,+ |
+
| 224 | +3x | +
+ na.rm = na.rm,+ |
+
| 225 | +3x | +
+ denom = denom,+ |
+
| 226 | ++ |
+ ...+ |
+
| 227 | ++ |
+ )+ |
+
| 228 | ++ | + + | +
| 229 | +3x | +
+ if (na.rm) {
+ |
+
| 230 | +2x | +
+ x <- stats::na.omit(x)+ |
+
| 231 | +2x | +
+ .ref_group <- stats::na.omit(.ref_group)+ |
+
| 232 | ++ |
+ } else {
+ |
+
| 233 | +1x | +
+ x[is.na(x)] <- FALSE+ |
+
| 234 | +1x | +
+ .ref_group[is.na(.ref_group)] <- FALSE+ |
+
| 235 | ++ |
+ }+ |
+
| 236 | ++ | + + | +
| 237 | +3x | +
+ y$pval_counts <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
+ |
+
| 238 | +3x | +
+ x <- factor(x, levels = c(TRUE, FALSE))+ |
+
| 239 | +3x | +
+ .ref_group <- factor(.ref_group, levels = c(TRUE, FALSE))+ |
+
| 240 | +3x | +
+ tbl <- rbind(table(x), table(.ref_group))+ |
+
| 241 | +3x | +
+ suppressWarnings(prop_chisq(tbl))+ |
+
| 242 | ++ |
+ } else {
+ |
+
| 243 | +! | +
+ character()+ |
+
| 244 | ++ |
+ }+ |
+
| 245 | ++ | + + | +
| 246 | +3x | +
+ y+ |
+
| 247 | ++ |
+ }+ |
+
| 248 | ++ | + + | +
| 249 | ++ |
+ #' @describeIn compare_variables Formatted analysis function which is used as `afun`+ |
+
| 250 | ++ |
+ #' in `compare_vars()`.+ |
+
| 251 | ++ |
+ #'+ |
+
| 252 | ++ |
+ #' @return+ |
+
| 253 | ++ |
+ #' * `a_compare()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 254 | ++ |
+ #'+ |
+
| 255 | ++ |
+ #' @note `a_compare()` has been deprecated in favor of `a_summary()` with argument `compare` set to `TRUE`.+ |
+
| 256 | ++ |
+ #'+ |
+
| 257 | ++ |
+ #' @examples+ |
+
| 258 | ++ |
+ #' # `a_compare` deprecated - use `a_summary()` instead+ |
+
| 259 | ++ |
+ #' a_compare(rnorm(10, 5, 1), .ref_group = rnorm(20, -5, 1), .stats = c("n", "pval"))
+ |
+
| 260 | ++ |
+ #'+ |
+
| 261 | ++ |
+ #' @export+ |
+
| 262 | ++ |
+ a_compare <- function(x,+ |
+
| 263 | ++ |
+ .N_col, # nolint+ |
+
| 264 | ++ |
+ .N_row, # nolint+ |
+
| 265 | ++ |
+ .var = NULL,+ |
+
| 266 | ++ |
+ .df_row = NULL,+ |
+
| 267 | ++ |
+ .ref_group = NULL,+ |
+
| 268 | ++ |
+ .in_ref_col = FALSE,+ |
+
| 269 | ++ |
+ ...) {
+ |
+
| 270 | +1x | +
+ lifecycle::deprecate_warn(+ |
+
| 271 | +1x | +
+ "0.8.3",+ |
+
| 272 | +1x | +
+ "a_compare()",+ |
+
| 273 | +1x | +
+ details = "Please use a_summary() with argument `compare` set to TRUE instead."+ |
+
| 274 | ++ |
+ )+ |
+
| 275 | +1x | +
+ a_summary(+ |
+
| 276 | +1x | +
+ x = x,+ |
+
| 277 | +1x | +
+ .N_col = .N_col,+ |
+
| 278 | +1x | +
+ .N_row = .N_row,+ |
+
| 279 | +1x | +
+ .var = .var,+ |
+
| 280 | +1x | +
+ .df_row = .df_row,+ |
+
| 281 | +1x | +
+ .ref_group = .ref_group,+ |
+
| 282 | +1x | +
+ .in_ref_col = .in_ref_col,+ |
+
| 283 | +1x | +
+ compare = TRUE,+ |
+
| 284 | ++ |
+ ...+ |
+
| 285 | ++ |
+ )+ |
+
| 286 | ++ |
+ }+ |
+
| 287 | ++ | + + | +
| 288 | ++ |
+ #' Constructor Function for [compare_vars()]+ |
+
| 289 | ++ |
+ #'+ |
+
| 290 | ++ |
+ #' @description `r lifecycle::badge("deprecated")`
+ |
+
| 291 | ++ |
+ #'+ |
+
| 292 | ++ |
+ #' Constructor function which creates a combined formatted analysis function.+ |
+
| 293 | ++ |
+ #'+ |
+
| 294 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 295 | ++ |
+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ |
+
| 296 | ++ |
+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ |
+
| 297 | ++ |
+ #' for that statistic's row label.+ |
+
| 298 | ++ |
+ #'+ |
+
| 299 | ++ |
+ #' @return Combined formatted analysis function for use in [compare_vars()].+ |
+
| 300 | ++ |
+ #'+ |
+
| 301 | ++ |
+ #' @note This function has been deprecated in favor of direct implementation of `a_summary()` with argument `compare`+ |
+
| 302 | ++ |
+ #' set to `TRUE`.+ |
+
| 303 | ++ |
+ #'+ |
+
| 304 | ++ |
+ #' @seealso [compare_vars()]+ |
+
| 305 | ++ |
+ #'+ |
+
| 306 | ++ |
+ #' @export+ |
+
| 307 | ++ |
+ create_afun_compare <- function(.stats = NULL,+ |
+
| 308 | ++ |
+ .formats = NULL,+ |
+
| 309 | ++ |
+ .labels = NULL,+ |
+
| 310 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 311 | +1x | +
+ lifecycle::deprecate_warn(+ |
+
| 312 | +1x | +
+ "0.8.5.9010",+ |
+
| 313 | +1x | +
+ "create_afun_compare()",+ |
+
| 314 | +1x | +
+ details = "Please use a_summary(compare = TRUE) directly instead."+ |
+
| 315 | ++ |
+ )+ |
+
| 316 | +1x | +
+ function(x,+ |
+
| 317 | +1x | +
+ .ref_group,+ |
+
| 318 | +1x | +
+ .in_ref_col,+ |
+
| 319 | ++ |
+ ...,+ |
+
| 320 | +1x | +
+ .var) {
+ |
+
| 321 | +! | +
+ a_summary(x,+ |
+
| 322 | +! | +
+ compare = TRUE,+ |
+
| 323 | +! | +
+ .stats = .stats,+ |
+
| 324 | +! | +
+ .formats = .formats,+ |
+
| 325 | +! | +
+ .labels = .labels,+ |
+
| 326 | +! | +
+ .indent_mods = .indent_mods,+ |
+
| 327 | +! | +
+ .ref_group = .ref_group,+ |
+
| 328 | +! | +
+ .in_ref_col = .in_ref_col,+ |
+
| 329 | +! | +
+ .var = .var, ...+ |
+
| 330 | ++ |
+ )+ |
+
| 331 | ++ |
+ }+ |
+
| 332 | ++ |
+ }+ |
+
| 333 | ++ | + + | +
| 334 | ++ |
+ #' @describeIn compare_variables Layout-creating function which can take statistics function arguments+ |
+
| 335 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 336 | ++ |
+ #'+ |
+
| 337 | ++ |
+ #' @param ... arguments passed to `s_compare()`.+ |
+
| 338 | ++ |
+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ |
+
| 339 | ++ |
+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ |
+
| 340 | ++ |
+ #' for that statistic's row label.+ |
+
| 341 | ++ |
+ #'+ |
+
| 342 | ++ |
+ #' @return+ |
+
| 343 | ++ |
+ #' * `compare_vars()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 344 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 345 | ++ |
+ #' the statistics from `s_compare()` to the table layout.+ |
+
| 346 | ++ |
+ #'+ |
+
| 347 | ++ |
+ #' @examples+ |
+
| 348 | ++ |
+ #' # `compare_vars()` in `rtables` pipelines+ |
+
| 349 | ++ |
+ #'+ |
+
| 350 | ++ |
+ #' ## Default output within a `rtables` pipeline.+ |
+
| 351 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 352 | ++ |
+ #' split_cols_by("ARMCD", ref_group = "ARM B") %>%
+ |
+
| 353 | ++ |
+ #' compare_vars(c("AGE", "SEX"))
+ |
+
| 354 | ++ |
+ #' build_table(lyt, tern_ex_adsl)+ |
+
| 355 | ++ |
+ #'+ |
+
| 356 | ++ |
+ #' ## Select and format statistics output.+ |
+
| 357 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 358 | ++ |
+ #' split_cols_by("ARMCD", ref_group = "ARM C") %>%
+ |
+
| 359 | ++ |
+ #' compare_vars(+ |
+
| 360 | ++ |
+ #' vars = "AGE",+ |
+
| 361 | ++ |
+ #' .stats = c("mean_sd", "pval"),
+ |
+
| 362 | ++ |
+ #' .formats = c(mean_sd = "xx.x, xx.x"),+ |
+
| 363 | ++ |
+ #' .labels = c(mean_sd = "Mean, SD")+ |
+
| 364 | ++ |
+ #' )+ |
+
| 365 | ++ |
+ #' build_table(lyt, df = tern_ex_adsl)+ |
+
| 366 | ++ |
+ #'+ |
+
| 367 | ++ |
+ #' @export+ |
+
| 368 | ++ |
+ compare_vars <- function(lyt,+ |
+
| 369 | ++ |
+ vars,+ |
+
| 370 | ++ |
+ var_labels = vars,+ |
+
| 371 | ++ |
+ na_level = lifecycle::deprecated(),+ |
+
| 372 | ++ |
+ na_str = NA_character_,+ |
+
| 373 | ++ |
+ nested = TRUE,+ |
+
| 374 | ++ |
+ ...,+ |
+
| 375 | ++ |
+ na.rm = TRUE, # nolint+ |
+
| 376 | ++ |
+ show_labels = "default",+ |
+
| 377 | ++ |
+ table_names = vars,+ |
+
| 378 | ++ |
+ section_div = NA_character_,+ |
+
| 379 | ++ |
+ .stats = c("n", "mean_sd", "count_fraction", "pval"),
+ |
+
| 380 | ++ |
+ .formats = NULL,+ |
+
| 381 | ++ |
+ .labels = NULL,+ |
+
| 382 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 383 | +3x | +
+ if (lifecycle::is_present(na_level)) {
+ |
+
| 384 | +! | +
+ lifecycle::deprecate_warn("0.9.1", "compare_vars(na_level)", "compare_vars(na_str)")
+ |
+
| 385 | +! | +
+ na_str <- na_level+ |
+
| 386 | ++ |
+ }+ |
+
| 387 | ++ | + + | +
| 388 | +3x | +
+ extra_args <- list(.stats = .stats, na.rm = na.rm, na_str = na_str, compare = TRUE, ...)+ |
+
| 389 | +1x | +
+ if (!is.null(.formats)) extra_args[[".formats"]] <- .formats+ |
+
| 390 | +1x | +
+ if (!is.null(.labels)) extra_args[[".labels"]] <- .labels+ |
+
| 391 | +! | +
+ if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods+ |
+
| 392 | ++ | + + | +
| 393 | +3x | +
+ analyze(+ |
+
| 394 | +3x | +
+ lyt = lyt,+ |
+
| 395 | +3x | +
+ vars = vars,+ |
+
| 396 | +3x | +
+ var_labels = var_labels,+ |
+
| 397 | +3x | +
+ afun = a_summary,+ |
+
| 398 | +3x | +
+ na_str = na_str,+ |
+
| 399 | +3x | +
+ nested = nested,+ |
+
| 400 | +3x | +
+ extra_args = extra_args,+ |
+
| 401 | +3x | +
+ inclNAs = TRUE,+ |
+
| 402 | +3x | +
+ show_labels = show_labels,+ |
+
| 403 | +3x | +
+ table_names = table_names,+ |
+
| 404 | +3x | +
+ section_div = section_div+ |
+
| 405 | ++ |
+ )+ |
+
| 406 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Helper Functions for Tabulating Binary Response by Subgroup+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Helper functions that tabulate in a data frame statistics such as response rate+ |
+
| 6 | ++ |
+ #' and odds ratio for population subgroups.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #' @inheritParams response_subgroups+ |
+
| 10 | ++ |
+ #' @param arm (`factor`)\cr the treatment group variable.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @details Main functionality is to prepare data for use in a layout-creating function.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @examples+ |
+
| 15 | ++ |
+ #' library(dplyr)+ |
+
| 16 | ++ |
+ #' library(forcats)+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' adrs <- tern_ex_adrs+ |
+
| 19 | ++ |
+ #' adrs_labels <- formatters::var_labels(adrs)+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' adrs_f <- adrs %>%+ |
+
| 22 | ++ |
+ #' filter(PARAMCD == "BESRSPI") %>%+ |
+
| 23 | ++ |
+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+ |
+
| 24 | ++ |
+ #' droplevels() %>%+ |
+
| 25 | ++ |
+ #' mutate(+ |
+
| 26 | ++ |
+ #' # Reorder levels of factor to make the placebo group the reference arm.+ |
+
| 27 | ++ |
+ #' ARM = fct_relevel(ARM, "B: Placebo"),+ |
+
| 28 | ++ |
+ #' rsp = AVALC == "CR"+ |
+
| 29 | ++ |
+ #' )+ |
+
| 30 | ++ |
+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @name h_response_subgroups+ |
+
| 33 | ++ |
+ NULL+ |
+
| 34 | ++ | + + | +
| 35 | ++ |
+ #' @describeIn h_response_subgroups helper to prepare a data frame of binary responses by arm.+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' @return+ |
+
| 38 | ++ |
+ #' * `h_proportion_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, and `prop`.+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' @examples+ |
+
| 41 | ++ |
+ #' h_proportion_df(+ |
+
| 42 | ++ |
+ #' c(TRUE, FALSE, FALSE),+ |
+
| 43 | ++ |
+ #' arm = factor(c("A", "A", "B"), levels = c("A", "B"))
+ |
+
| 44 | ++ |
+ #' )+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' @export+ |
+
| 47 | ++ |
+ h_proportion_df <- function(rsp, arm) {
+ |
+
| 48 | +59x | +
+ checkmate::assert_logical(rsp)+ |
+
| 49 | +58x | +
+ assert_valid_factor(arm, len = length(rsp))+ |
+
| 50 | +58x | +
+ non_missing_rsp <- !is.na(rsp)+ |
+
| 51 | +58x | +
+ rsp <- rsp[non_missing_rsp]+ |
+
| 52 | +58x | +
+ arm <- arm[non_missing_rsp]+ |
+
| 53 | ++ | + + | +
| 54 | +58x | +
+ lst_rsp <- split(rsp, arm)+ |
+
| 55 | +58x | +
+ lst_results <- Map(function(x, arm) {
+ |
+
| 56 | +116x | +
+ if (length(x) > 0) {
+ |
+
| 57 | +114x | +
+ s_prop <- s_proportion(df = x)+ |
+
| 58 | +114x | +
+ data.frame(+ |
+
| 59 | +114x | +
+ arm = arm,+ |
+
| 60 | +114x | +
+ n = length(x),+ |
+
| 61 | +114x | +
+ n_rsp = unname(s_prop$n_prop[1]),+ |
+
| 62 | +114x | +
+ prop = unname(s_prop$n_prop[2]),+ |
+
| 63 | +114x | +
+ stringsAsFactors = FALSE+ |
+
| 64 | ++ |
+ )+ |
+
| 65 | ++ |
+ } else {
+ |
+
| 66 | +2x | +
+ data.frame(+ |
+
| 67 | +2x | +
+ arm = arm,+ |
+
| 68 | +2x | +
+ n = 0L,+ |
+
| 69 | +2x | +
+ n_rsp = NA,+ |
+
| 70 | +2x | +
+ prop = NA,+ |
+
| 71 | +2x | +
+ stringsAsFactors = FALSE+ |
+
| 72 | ++ |
+ )+ |
+
| 73 | ++ |
+ }+ |
+
| 74 | +58x | +
+ }, lst_rsp, names(lst_rsp))+ |
+
| 75 | ++ | + + | +
| 76 | +58x | +
+ df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE))+ |
+
| 77 | +58x | +
+ df$arm <- factor(df$arm, levels = levels(arm))+ |
+
| 78 | +58x | +
+ df+ |
+
| 79 | ++ |
+ }+ |
+
| 80 | ++ | + + | +
| 81 | ++ |
+ #' @describeIn h_response_subgroups summarizes proportion of binary responses by arm and across subgroups+ |
+
| 82 | ++ |
+ #' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and+ |
+
| 83 | ++ |
+ #' requires elements `rsp`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies+ |
+
| 84 | ++ |
+ #' groupings for `subgroups` variables.+ |
+
| 85 | ++ |
+ #'+ |
+
| 86 | ++ |
+ #' @return+ |
+
| 87 | ++ |
+ #' * `h_proportion_subgroups_df()` returns a `data.frame` with columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`,+ |
+
| 88 | ++ |
+ #' `var`, `var_label`, and `row_type`.+ |
+
| 89 | ++ |
+ #'+ |
+
| 90 | ++ |
+ #' @examples+ |
+
| 91 | ++ |
+ #' h_proportion_subgroups_df(+ |
+
| 92 | ++ |
+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ |
+
| 93 | ++ |
+ #' data = adrs_f+ |
+
| 94 | ++ |
+ #' )+ |
+
| 95 | ++ |
+ #'+ |
+
| 96 | ++ |
+ #' # Define groupings for BMRKR2 levels.+ |
+
| 97 | ++ |
+ #' h_proportion_subgroups_df(+ |
+
| 98 | ++ |
+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ |
+
| 99 | ++ |
+ #' data = adrs_f,+ |
+
| 100 | ++ |
+ #' groups_lists = list(+ |
+
| 101 | ++ |
+ #' BMRKR2 = list(+ |
+
| 102 | ++ |
+ #' "low" = "LOW",+ |
+
| 103 | ++ |
+ #' "low/medium" = c("LOW", "MEDIUM"),
+ |
+
| 104 | ++ |
+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ |
+
| 105 | ++ |
+ #' )+ |
+
| 106 | ++ |
+ #' )+ |
+
| 107 | ++ |
+ #' )+ |
+
| 108 | ++ |
+ #'+ |
+
| 109 | ++ |
+ #' @export+ |
+
| 110 | ++ |
+ h_proportion_subgroups_df <- function(variables,+ |
+
| 111 | ++ |
+ data,+ |
+
| 112 | ++ |
+ groups_lists = list(),+ |
+
| 113 | ++ |
+ label_all = "All Patients") {
+ |
+
| 114 | +13x | +
+ checkmate::assert_character(variables$rsp)+ |
+
| 115 | +13x | +
+ checkmate::assert_character(variables$arm)+ |
+
| 116 | +13x | +
+ checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ |
+
| 117 | +13x | +
+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ |
+
| 118 | +13x | +
+ assert_df_with_variables(data, variables)+ |
+
| 119 | +13x | +
+ checkmate::assert_string(label_all)+ |
+
| 120 | ++ | + + | +
| 121 | ++ |
+ # Add All Patients.+ |
+
| 122 | +13x | +
+ result_all <- h_proportion_df(data[[variables$rsp]], data[[variables$arm]])+ |
+
| 123 | +13x | +
+ result_all$subgroup <- label_all+ |
+
| 124 | +13x | +
+ result_all$var <- "ALL"+ |
+
| 125 | +13x | +
+ result_all$var_label <- label_all+ |
+
| 126 | +13x | +
+ result_all$row_type <- "content"+ |
+
| 127 | ++ | + + | +
| 128 | ++ |
+ # Add Subgroups.+ |
+
| 129 | +13x | +
+ if (is.null(variables$subgroups)) {
+ |
+
| 130 | +3x | +
+ result_all+ |
+
| 131 | ++ |
+ } else {
+ |
+
| 132 | +10x | +
+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ |
+
| 133 | ++ | + + | +
| 134 | +10x | +
+ l_result <- lapply(l_data, function(grp) {
+ |
+
| 135 | +42x | +
+ result <- h_proportion_df(grp$df[[variables$rsp]], grp$df[[variables$arm]])+ |
+
| 136 | +42x | +
+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ |
+
| 137 | +42x | +
+ cbind(result, result_labels)+ |
+
| 138 | ++ |
+ })+ |
+
| 139 | +10x | +
+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ |
+
| 140 | +10x | +
+ result_subgroups$row_type <- "analysis"+ |
+
| 141 | ++ | + + | +
| 142 | +10x | +
+ rbind(+ |
+
| 143 | +10x | +
+ result_all,+ |
+
| 144 | +10x | +
+ result_subgroups+ |
+
| 145 | ++ |
+ )+ |
+
| 146 | ++ |
+ }+ |
+
| 147 | ++ |
+ }+ |
+
| 148 | ++ | + + | +
| 149 | ++ |
+ #' @describeIn h_response_subgroups helper to prepare a data frame with estimates of+ |
+
| 150 | ++ |
+ #' the odds ratio between a treatment and a control arm.+ |
+
| 151 | ++ |
+ #'+ |
+
| 152 | ++ |
+ #' @inheritParams response_subgroups+ |
+
| 153 | ++ |
+ #' @param strata_data (`factor`, `data.frame` or `NULL`)\cr required if stratified analysis is performed.+ |
+
| 154 | ++ |
+ #'+ |
+
| 155 | ++ |
+ #' @return+ |
+
| 156 | ++ |
+ #' * `h_odds_ratio_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`, and+ |
+
| 157 | ++ |
+ #' optionally `pval` and `pval_label`.+ |
+
| 158 | ++ |
+ #'+ |
+
| 159 | ++ |
+ #' @examples+ |
+
| 160 | ++ |
+ #' # Unstratatified analysis.+ |
+
| 161 | ++ |
+ #' h_odds_ratio_df(+ |
+
| 162 | ++ |
+ #' c(TRUE, FALSE, FALSE, TRUE),+ |
+
| 163 | ++ |
+ #' arm = factor(c("A", "A", "B", "B"), levels = c("A", "B"))
+ |
+
| 164 | ++ |
+ #' )+ |
+
| 165 | ++ |
+ #'+ |
+
| 166 | ++ |
+ #' # Include p-value.+ |
+
| 167 | ++ |
+ #' h_odds_ratio_df(adrs_f$rsp, adrs_f$ARM, method = "chisq")+ |
+
| 168 | ++ |
+ #'+ |
+
| 169 | ++ |
+ #' # Stratatified analysis.+ |
+
| 170 | ++ |
+ #' h_odds_ratio_df(+ |
+
| 171 | ++ |
+ #' rsp = adrs_f$rsp,+ |
+
| 172 | ++ |
+ #' arm = adrs_f$ARM,+ |
+
| 173 | ++ |
+ #' strata_data = adrs_f[, c("STRATA1", "STRATA2")],
+ |
+
| 174 | ++ |
+ #' method = "cmh"+ |
+
| 175 | ++ |
+ #' )+ |
+
| 176 | ++ |
+ #'+ |
+
| 177 | ++ |
+ #' @export+ |
+
| 178 | ++ |
+ h_odds_ratio_df <- function(rsp, arm, strata_data = NULL, conf_level = 0.95, method = NULL) {
+ |
+
| 179 | +64x | +
+ assert_valid_factor(arm, n.levels = 2, len = length(rsp))+ |
+
| 180 | ++ | + + | +
| 181 | +64x | +
+ df_rsp <- data.frame(+ |
+
| 182 | +64x | +
+ rsp = rsp,+ |
+
| 183 | +64x | +
+ arm = arm+ |
+
| 184 | ++ |
+ )+ |
+
| 185 | ++ | + + | +
| 186 | +64x | +
+ if (!is.null(strata_data)) {
+ |
+
| 187 | +11x | +
+ strata_var <- interaction(strata_data, drop = TRUE)+ |
+
| 188 | +11x | +
+ strata_name <- "strata"+ |
+
| 189 | ++ | + + | +
| 190 | +11x | +
+ assert_valid_factor(strata_var, len = nrow(df_rsp))+ |
+
| 191 | ++ | + + | +
| 192 | +11x | +
+ df_rsp[[strata_name]] <- strata_var+ |
+
| 193 | ++ |
+ } else {
+ |
+
| 194 | +53x | +
+ strata_name <- NULL+ |
+
| 195 | ++ |
+ }+ |
+
| 196 | ++ | + + | +
| 197 | +64x | +
+ l_df <- split(df_rsp, arm)+ |
+
| 198 | ++ | + + | +
| 199 | +64x | +
+ if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
+ |
+
| 200 | ++ |
+ # Odds ratio and CI.+ |
+
| 201 | +62x | +
+ result_odds_ratio <- s_odds_ratio(+ |
+
| 202 | +62x | +
+ df = l_df[[2]],+ |
+
| 203 | +62x | +
+ .var = "rsp",+ |
+
| 204 | +62x | +
+ .ref_group = l_df[[1]],+ |
+
| 205 | +62x | +
+ .in_ref_col = FALSE,+ |
+
| 206 | +62x | +
+ .df_row = df_rsp,+ |
+
| 207 | +62x | +
+ variables = list(arm = "arm", strata = strata_name),+ |
+
| 208 | +62x | +
+ conf_level = conf_level+ |
+
| 209 | ++ |
+ )+ |
+
| 210 | ++ | + + | +
| 211 | +62x | +
+ df <- data.frame(+ |
+
| 212 | ++ |
+ # Dummy column needed downstream to create a nested header.+ |
+
| 213 | +62x | +
+ arm = " ",+ |
+
| 214 | +62x | +
+ n_tot = unname(result_odds_ratio$n_tot["n_tot"]),+ |
+
| 215 | +62x | +
+ or = unname(result_odds_ratio$or_ci["est"]),+ |
+
| 216 | +62x | +
+ lcl = unname(result_odds_ratio$or_ci["lcl"]),+ |
+
| 217 | +62x | +
+ ucl = unname(result_odds_ratio$or_ci["ucl"]),+ |
+
| 218 | +62x | +
+ conf_level = conf_level,+ |
+
| 219 | +62x | +
+ stringsAsFactors = FALSE+ |
+
| 220 | ++ |
+ )+ |
+
| 221 | ++ | + + | +
| 222 | +62x | +
+ if (!is.null(method)) {
+ |
+
| 223 | ++ |
+ # Test for difference.+ |
+
| 224 | +29x | +
+ result_test <- s_test_proportion_diff(+ |
+
| 225 | +29x | +
+ df = l_df[[2]],+ |
+
| 226 | +29x | +
+ .var = "rsp",+ |
+
| 227 | +29x | +
+ .ref_group = l_df[[1]],+ |
+
| 228 | +29x | +
+ .in_ref_col = FALSE,+ |
+
| 229 | +29x | +
+ variables = list(strata = strata_name),+ |
+
| 230 | +29x | +
+ method = method+ |
+
| 231 | ++ |
+ )+ |
+
| 232 | ++ | + + | +
| 233 | +29x | +
+ df$pval <- as.numeric(result_test$pval)+ |
+
| 234 | +29x | +
+ df$pval_label <- obj_label(result_test$pval)+ |
+
| 235 | ++ |
+ }+ |
+
| 236 | ++ | + + | +
| 237 | ++ |
+ # In those cases cannot go through the model so will obtain n_tot from data.+ |
+
| 238 | ++ |
+ } else if (+ |
+
| 239 | +2x | +
+ (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) ||+ |
+
| 240 | +2x | +
+ (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0)+ |
+
| 241 | ++ |
+ ) {
+ |
+
| 242 | +2x | +
+ 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)),+ |
+
| 246 | +2x | +
+ or = NA,+ |
+
| 247 | +2x | +
+ lcl = NA,+ |
+
| 248 | +2x | +
+ ucl = NA,+ |
+
| 249 | +2x | +
+ conf_level = conf_level,+ |
+
| 250 | +2x | +
+ stringsAsFactors = FALSE+ |
+
| 251 | ++ |
+ )+ |
+
| 252 | +2x | +
+ if (!is.null(method)) {
+ |
+
| 253 | +2x | +
+ df$pval <- NA+ |
+
| 254 | +2x | +
+ df$pval_label <- NA+ |
+
| 255 | ++ |
+ }+ |
+
| 256 | ++ |
+ } else {
+ |
+
| 257 | +! | +
+ df <- data.frame(+ |
+
| 258 | ++ |
+ # Dummy column needed downstream to create a nested header.+ |
+
| 259 | +! | +
+ arm = " ",+ |
+
| 260 | +! | +
+ n_tot = 0L,+ |
+
| 261 | +! | +
+ or = NA,+ |
+
| 262 | +! | +
+ lcl = NA,+ |
+
| 263 | +! | +
+ ucl = NA,+ |
+
| 264 | +! | +
+ conf_level = conf_level,+ |
+
| 265 | +! | +
+ stringsAsFactors = FALSE+ |
+
| 266 | ++ |
+ )+ |
+
| 267 | ++ | + + | +
| 268 | +! | +
+ if (!is.null(method)) {
+ |
+
| 269 | +! | +
+ df$pval <- NA+ |
+
| 270 | +! | +
+ df$pval_label <- NA+ |
+
| 271 | ++ |
+ }+ |
+
| 272 | ++ |
+ }+ |
+
| 273 | ++ | + + | +
| 274 | +64x | +
+ df+ |
+
| 275 | ++ |
+ }+ |
+
| 276 | ++ | + + | +
| 277 | ++ |
+ #' @describeIn h_response_subgroups summarizes estimates of the odds ratio between a treatment and a control+ |
+
| 278 | ++ |
+ #' arm across subgroups in a data frame. `variables` corresponds to the names of variables found in+ |
+
| 279 | ++ |
+ #' `data`, passed as a named list and requires elements `rsp`, `arm` and optionally `subgroups`+ |
+
| 280 | ++ |
+ #' and `strat`. `groups_lists` optionally specifies groupings for `subgroups` variables.+ |
+
| 281 | ++ |
+ #'+ |
+
| 282 | ++ |
+ #' @return+ |
+
| 283 | ++ |
+ #' * `h_odds_ratio_subgroups_df()` returns a `data.frame` with columns `arm`, `n_tot`, `or`, `lcl`, `ucl`,+ |
+
| 284 | ++ |
+ #' `conf_level`, `subgroup`, `var`, `var_label`, and `row_type`.+ |
+
| 285 | ++ |
+ #'+ |
+
| 286 | ++ |
+ #' @examples+ |
+
| 287 | ++ |
+ #' # Unstratified analysis.+ |
+
| 288 | ++ |
+ #' h_odds_ratio_subgroups_df(+ |
+
| 289 | ++ |
+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ |
+
| 290 | ++ |
+ #' data = adrs_f+ |
+
| 291 | ++ |
+ #' )+ |
+
| 292 | ++ |
+ #'+ |
+
| 293 | ++ |
+ #' # Stratified analysis.+ |
+
| 294 | ++ |
+ #' h_odds_ratio_subgroups_df(+ |
+
| 295 | ++ |
+ #' variables = list(+ |
+
| 296 | ++ |
+ #' rsp = "rsp",+ |
+
| 297 | ++ |
+ #' arm = "ARM",+ |
+
| 298 | ++ |
+ #' subgroups = c("SEX", "BMRKR2"),
+ |
+
| 299 | ++ |
+ #' strat = c("STRATA1", "STRATA2")
+ |
+
| 300 | ++ |
+ #' ),+ |
+
| 301 | ++ |
+ #' data = adrs_f+ |
+
| 302 | ++ |
+ #' )+ |
+
| 303 | ++ |
+ #'+ |
+
| 304 | ++ |
+ #' # Define groupings of BMRKR2 levels.+ |
+
| 305 | ++ |
+ #' h_odds_ratio_subgroups_df(+ |
+
| 306 | ++ |
+ #' variables = list(+ |
+
| 307 | ++ |
+ #' rsp = "rsp",+ |
+
| 308 | ++ |
+ #' arm = "ARM",+ |
+
| 309 | ++ |
+ #' subgroups = c("SEX", "BMRKR2")
+ |
+
| 310 | ++ |
+ #' ),+ |
+
| 311 | ++ |
+ #' data = adrs_f,+ |
+
| 312 | ++ |
+ #' groups_lists = list(+ |
+
| 313 | ++ |
+ #' BMRKR2 = list(+ |
+
| 314 | ++ |
+ #' "low" = "LOW",+ |
+
| 315 | ++ |
+ #' "low/medium" = c("LOW", "MEDIUM"),
+ |
+
| 316 | ++ |
+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ |
+
| 317 | ++ |
+ #' )+ |
+
| 318 | ++ |
+ #' )+ |
+
| 319 | ++ |
+ #' )+ |
+
| 320 | ++ |
+ #'+ |
+
| 321 | ++ |
+ #' @export+ |
+
| 322 | ++ |
+ h_odds_ratio_subgroups_df <- function(variables,+ |
+
| 323 | ++ |
+ data,+ |
+
| 324 | ++ |
+ groups_lists = list(),+ |
+
| 325 | ++ |
+ conf_level = 0.95,+ |
+
| 326 | ++ |
+ method = NULL,+ |
+
| 327 | ++ |
+ label_all = "All Patients") {
+ |
+
| 328 | +14x | +
+ checkmate::assert_character(variables$rsp)+ |
+
| 329 | +14x | +
+ checkmate::assert_character(variables$arm)+ |
+
| 330 | +14x | +
+ checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ |
+
| 331 | +14x | +
+ checkmate::assert_character(variables$strat, null.ok = TRUE)+ |
+
| 332 | +14x | +
+ assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)+ |
+
| 333 | +14x | +
+ assert_df_with_variables(data, variables)+ |
+
| 334 | +14x | +
+ checkmate::assert_string(label_all)+ |
+
| 335 | ++ | + + | +
| 336 | +14x | +
+ strata_data <- if (is.null(variables$strat)) {
+ |
+
| 337 | +12x | +
+ NULL+ |
+
| 338 | ++ |
+ } else {
+ |
+
| 339 | +2x | +
+ data[, variables$strat, drop = FALSE]+ |
+
| 340 | ++ |
+ }+ |
+
| 341 | ++ | + + | +
| 342 | ++ |
+ # Add All Patients.+ |
+
| 343 | +14x | +
+ result_all <- h_odds_ratio_df(+ |
+
| 344 | +14x | +
+ rsp = data[[variables$rsp]],+ |
+
| 345 | +14x | +
+ arm = data[[variables$arm]],+ |
+
| 346 | +14x | +
+ strata_data = strata_data,+ |
+
| 347 | +14x | +
+ conf_level = conf_level,+ |
+
| 348 | +14x | +
+ method = method+ |
+
| 349 | ++ |
+ )+ |
+
| 350 | +14x | +
+ result_all$subgroup <- label_all+ |
+
| 351 | +14x | +
+ result_all$var <- "ALL"+ |
+
| 352 | +14x | +
+ result_all$var_label <- label_all+ |
+
| 353 | +14x | +
+ result_all$row_type <- "content"+ |
+
| 354 | ++ | + + | +
| 355 | +14x | +
+ if (is.null(variables$subgroups)) {
+ |
+
| 356 | +3x | +
+ result_all+ |
+
| 357 | ++ |
+ } else {
+ |
+
| 358 | +11x | +
+ l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)+ |
+
| 359 | ++ | + + | +
| 360 | +11x | +
+ l_result <- lapply(l_data, function(grp) {
+ |
+
| 361 | +46x | +
+ grp_strata_data <- if (is.null(variables$strat)) {
+ |
+
| 362 | +38x | +
+ NULL+ |
+
| 363 | ++ |
+ } else {
+ |
+
| 364 | +8x | +
+ grp$df[, variables$strat, drop = FALSE]+ |
+
| 365 | ++ |
+ }+ |
+
| 366 | ++ | + + | +
| 367 | +46x | +
+ result <- h_odds_ratio_df(+ |
+
| 368 | +46x | +
+ rsp = grp$df[[variables$rsp]],+ |
+
| 369 | +46x | +
+ arm = grp$df[[variables$arm]],+ |
+
| 370 | +46x | +
+ strata_data = grp_strata_data,+ |
+
| 371 | +46x | +
+ conf_level = conf_level,+ |
+
| 372 | +46x | +
+ method = method+ |
+
| 373 | ++ |
+ )+ |
+
| 374 | +46x | +
+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ |
+
| 375 | +46x | +
+ cbind(result, result_labels)+ |
+
| 376 | ++ |
+ })+ |
+
| 377 | ++ | + + | +
| 378 | +11x | +
+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ |
+
| 379 | +11x | +
+ result_subgroups$row_type <- "analysis"+ |
+
| 380 | ++ | + + | +
| 381 | +11x | +
+ rbind(+ |
+
| 382 | +11x | +
+ result_all,+ |
+
| 383 | +11x | +
+ result_subgroups+ |
+
| 384 | ++ |
+ )+ |
+
| 385 | ++ |
+ }+ |
+
| 386 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Helper Functions for Cox Proportional Hazards Regression+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Helper functions used in [fit_coxreg_univar()] and [fit_coxreg_multivar()].+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 8 | ++ |
+ #' @inheritParams h_coxreg_univar_extract+ |
+
| 9 | ++ |
+ #' @inheritParams cox_regression_inter+ |
+
| 10 | ++ |
+ #' @inheritParams control_coxreg+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @seealso [cox_regression]+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @name h_cox_regression+ |
+
| 15 | ++ |
+ NULL+ |
+
| 16 | ++ | + + | +
| 17 | ++ |
+ #' @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 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @return+ |
+
| 21 | ++ |
+ #' * `h_coxreg_univar_formulas()` returns a `character` vector coercible into formulas (e.g [stats::as.formula()]).+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @examples+ |
+
| 24 | ++ |
+ #' # `h_coxreg_univar_formulas`+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' ## Simple formulas.+ |
+
| 27 | ++ |
+ #' h_coxreg_univar_formulas(+ |
+
| 28 | ++ |
+ #' variables = list(+ |
+
| 29 | ++ |
+ #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y")
+ |
+
| 30 | ++ |
+ #' )+ |
+
| 31 | ++ |
+ #' )+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' ## Addition of an optional strata.+ |
+
| 34 | ++ |
+ #' h_coxreg_univar_formulas(+ |
+
| 35 | ++ |
+ #' variables = list(+ |
+
| 36 | ++ |
+ #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
+ |
+
| 37 | ++ |
+ #' strata = "SITE"+ |
+
| 38 | ++ |
+ #' )+ |
+
| 39 | ++ |
+ #' )+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' ## Inclusion of the interaction term.+ |
+
| 42 | ++ |
+ #' h_coxreg_univar_formulas(+ |
+
| 43 | ++ |
+ #' variables = list(+ |
+
| 44 | ++ |
+ #' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
+ |
+
| 45 | ++ |
+ #' strata = "SITE"+ |
+
| 46 | ++ |
+ #' ),+ |
+
| 47 | ++ |
+ #' interaction = TRUE+ |
+
| 48 | ++ |
+ #' )+ |
+
| 49 | ++ |
+ #'+ |
+
| 50 | ++ |
+ #' ## Only covariates fitted in separate models.+ |
+
| 51 | ++ |
+ #' h_coxreg_univar_formulas(+ |
+
| 52 | ++ |
+ #' variables = list(+ |
+
| 53 | ++ |
+ #' time = "time", event = "status", covariates = c("X", "y")
+ |
+
| 54 | ++ |
+ #' )+ |
+
| 55 | ++ |
+ #' )+ |
+
| 56 | ++ |
+ #'+ |
+
| 57 | ++ |
+ #' @export+ |
+
| 58 | ++ |
+ h_coxreg_univar_formulas <- function(variables,+ |
+
| 59 | ++ |
+ interaction = FALSE) {
+ |
+
| 60 | +41x | +
+ checkmate::assert_list(variables, names = "named")+ |
+
| 61 | +41x | +
+ has_arm <- "arm" %in% names(variables)+ |
+
| 62 | +41x | +
+ arm_name <- if (has_arm) "arm" else NULL+ |
+
| 63 | ++ | + + | +
| 64 | +41x | +
+ checkmate::assert_character(variables$covariates, null.ok = TRUE)+ |
+
| 65 | ++ | + + | +
| 66 | +41x | +
+ checkmate::assert_flag(interaction)+ |
+
| 67 | ++ | + + | +
| 68 | +41x | +
+ if (!has_arm || is.null(variables$covariates)) {
+ |
+
| 69 | +10x | +
+ checkmate::assert_false(interaction)+ |
+
| 70 | ++ |
+ }+ |
+
| 71 | ++ | + + | +
| 72 | +39x | +
+ assert_list_of_variables(variables[c(arm_name, "event", "time")])+ |
+
| 73 | ++ | + + | +
| 74 | +39x | +
+ if (!is.null(variables$covariates)) {
+ |
+
| 75 | +38x | +
+ forms <- paste0(+ |
+
| 76 | +38x | +
+ "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
+ |
+
| 77 | +38x | +
+ ifelse(has_arm, variables$arm, "1"),+ |
+
| 78 | +38x | +
+ ifelse(interaction, " * ", " + "),+ |
+
| 79 | +38x | +
+ variables$covariates,+ |
+
| 80 | +38x | +
+ ifelse(+ |
+
| 81 | +38x | +
+ !is.null(variables$strata),+ |
+
| 82 | +38x | +
+ paste0(" + strata(", paste0(variables$strata, collapse = ", "), ")"),
+ |
+
| 83 | ++ |
+ ""+ |
+
| 84 | ++ |
+ )+ |
+
| 85 | ++ |
+ )+ |
+
| 86 | ++ |
+ } else {
+ |
+
| 87 | +1x | +
+ forms <- NULL+ |
+
| 88 | ++ |
+ }+ |
+
| 89 | +39x | +
+ nams <- variables$covariates+ |
+
| 90 | +39x | +
+ if (has_arm) {
+ |
+
| 91 | +32x | +
+ ref <- paste0(+ |
+
| 92 | +32x | +
+ "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
+ |
+
| 93 | +32x | +
+ variables$arm,+ |
+
| 94 | +32x | +
+ ifelse(+ |
+
| 95 | +32x | +
+ !is.null(variables$strata),+ |
+
| 96 | +32x | +
+ paste0(+ |
+
| 97 | +32x | +
+ " + strata(", paste0(variables$strata, collapse = ", "), ")"
+ |
+
| 98 | ++ |
+ ),+ |
+
| 99 | ++ |
+ ""+ |
+
| 100 | ++ |
+ )+ |
+
| 101 | ++ |
+ )+ |
+
| 102 | +32x | +
+ forms <- c(ref, forms)+ |
+
| 103 | +32x | +
+ nams <- c("ref", nams)
+ |
+
| 104 | ++ |
+ }+ |
+
| 105 | +39x | +
+ stats::setNames(forms, nams)+ |
+
| 106 | ++ |
+ }+ |
+
| 107 | ++ | + + | +
| 108 | ++ |
+ #' @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 | ++ |
+ #' regression models. Interactions will not be included in multivariate Cox regression model.+ |
+
| 111 | ++ |
+ #'+ |
+
| 112 | ++ |
+ #' @return+ |
+
| 113 | ++ |
+ #' * `h_coxreg_multivar_formula()` returns a `string` coercible into a formula (e.g [stats::as.formula()]).+ |
+
| 114 | ++ |
+ #'+ |
+
| 115 | ++ |
+ #' @examples+ |
+
| 116 | ++ |
+ #' # `h_coxreg_multivar_formula`+ |
+
| 117 | ++ |
+ #'+ |
+
| 118 | ++ |
+ #' h_coxreg_multivar_formula(+ |
+
| 119 | ++ |
+ #' variables = list(+ |
+
| 120 | ++ |
+ #' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE")
+ |
+
| 121 | ++ |
+ #' )+ |
+
| 122 | ++ |
+ #' )+ |
+
| 123 | ++ |
+ #'+ |
+
| 124 | ++ |
+ #' # Addition of an optional strata.+ |
+
| 125 | ++ |
+ #' h_coxreg_multivar_formula(+ |
+
| 126 | ++ |
+ #' variables = list(+ |
+
| 127 | ++ |
+ #' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE"),
+ |
+
| 128 | ++ |
+ #' strata = "SITE"+ |
+
| 129 | ++ |
+ #' )+ |
+
| 130 | ++ |
+ #' )+ |
+
| 131 | ++ |
+ #'+ |
+
| 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"+ |
+
| 137 | ++ |
+ #' )+ |
+
| 138 | ++ |
+ #' )+ |
+
| 139 | ++ |
+ #'+ |
+
| 140 | ++ |
+ #' @export+ |
+
| 141 | ++ |
+ h_coxreg_multivar_formula <- function(variables) {
+ |
+
| 142 | +57x | +
+ checkmate::assert_list(variables, names = "named")+ |
+
| 143 | +57x | +
+ has_arm <- "arm" %in% names(variables)+ |
+
| 144 | +57x | +
+ arm_name <- if (has_arm) "arm" else NULL+ |
+
| 145 | ++ | + + | +
| 146 | +57x | +
+ checkmate::assert_character(variables$covariates, null.ok = TRUE)+ |
+
| 147 | ++ | + + | +
| 148 | +57x | +
+ assert_list_of_variables(variables[c(arm_name, "event", "time")])+ |
+
| 149 | ++ | + + | +
| 150 | +57x | +
+ y <- paste0(+ |
+
| 151 | +57x | +
+ "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
+ |
+
| 152 | +57x | +
+ ifelse(has_arm, variables$arm, "1")+ |
+
| 153 | ++ |
+ )+ |
+
| 154 | +57x | +
+ if (length(variables$covariates) > 0) {
+ |
+
| 155 | +18x | +
+ y <- paste(y, paste(variables$covariates, collapse = " + "), sep = " + ")+ |
+
| 156 | ++ |
+ }+ |
+
| 157 | +57x | +
+ if (!is.null(variables$strata)) {
+ |
+
| 158 | +5x | +
+ y <- paste0(y, " + strata(", paste0(variables$strata, collapse = ", "), ")")
+ |
+
| 159 | ++ |
+ }+ |
+
| 160 | +57x | +
+ y+ |
+
| 161 | ++ |
+ }+ |
+
| 162 | ++ | + + | +
| 163 | ++ |
+ #' @describeIn h_cox_regression Utility function to help tabulate the result of+ |
+
| 164 | ++ |
+ #' 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 | ++ |
+ #' @return+ |
+
| 170 | ++ |
+ #' * `h_coxreg_univar_extract()` returns a `data.frame` with variables `effect`, `term`, `term_label`, `level`,+ |
+
| 171 | ++ |
+ #' `n`, `hr`, `lcl`, `ucl`, and `pval`.+ |
+
| 172 | ++ |
+ #'+ |
+
| 173 | ++ |
+ #' @examples+ |
+
| 174 | ++ |
+ #' library(survival)+ |
+
| 175 | ++ |
+ #'+ |
+
| 176 | ++ |
+ #' dta_simple <- data.frame(+ |
+
| 177 | ++ |
+ #' time = c(5, 5, 10, 10, 5, 5, 10, 10),+ |
+
| 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")),
+ |
+
| 180 | ++ |
+ #' var1 = c(45, 55, 65, 75, 55, 65, 85, 75),+ |
+
| 181 | ++ |
+ #' var2 = c("F", "M", "F", "M", "F", "M", "F", "U")
+ |
+
| 182 | ++ |
+ #' )+ |
+
| 183 | ++ |
+ #' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple)+ |
+
| 184 | ++ |
+ #' result <- h_coxreg_univar_extract(+ |
+
| 185 | ++ |
+ #' effect = "armcd", covar = "armcd", mod = mod, data = dta_simple+ |
+
| 186 | ++ |
+ #' )+ |
+
| 187 | ++ |
+ #' result+ |
+
| 188 | ++ |
+ #'+ |
+
| 189 | ++ |
+ #' @export+ |
+
| 190 | ++ |
+ h_coxreg_univar_extract <- function(effect,+ |
+
| 191 | ++ |
+ covar,+ |
+
| 192 | ++ |
+ data,+ |
+
| 193 | ++ |
+ mod,+ |
+
| 194 | ++ |
+ control = control_coxreg()) {
+ |
+
| 195 | +47x | +
+ checkmate::assert_string(covar)+ |
+
| 196 | +47x | +
+ checkmate::assert_string(effect)+ |
+
| 197 | +47x | +
+ checkmate::assert_class(mod, "coxph")+ |
+
| 198 | +47x | +
+ test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]+ |
+
| 199 | ++ | + + | +
| 200 | +47x | +
+ mod_aov <- muffled_car_anova(mod, test_statistic)+ |
+
| 201 | +47x | +
+ msum <- summary(mod, conf.int = control$conf_level)+ |
+
| 202 | +47x | +
+ sum_cox <- broom::tidy(msum)+ |
+
| 203 | ++ | + + | +
| 204 | ++ |
+ # Combine results together.+ |
+
| 205 | +47x | +
+ effect_aov <- mod_aov[effect, , drop = TRUE]+ |
+
| 206 | +47x | +
+ pval <- effect_aov[[grep(pattern = "Pr", x = names(effect_aov)), drop = TRUE]]+ |
+
| 207 | +47x | +
+ sum_main <- sum_cox[grepl(effect, sum_cox$level), ]+ |
+
| 208 | ++ | + + | +
| 209 | +47x | +
+ term_label <- if (effect == covar) {
+ |
+
| 210 | +25x | +
+ paste0(+ |
+
| 211 | +25x | +
+ levels(data[[covar]])[2],+ |
+
| 212 | +25x | +
+ " vs control (",
+ |
+
| 213 | +25x | +
+ levels(data[[covar]])[1],+ |
+
| 214 | ++ |
+ ")"+ |
+
| 215 | ++ |
+ )+ |
+
| 216 | ++ |
+ } else {
+ |
+
| 217 | +22x | +
+ unname(labels_or_names(data[covar]))+ |
+
| 218 | ++ |
+ }+ |
+
| 219 | +47x | +
+ data.frame(+ |
+
| 220 | +47x | +
+ effect = ifelse(covar == effect, "Treatment:", "Covariate:"),+ |
+
| 221 | +47x | +
+ term = covar,+ |
+
| 222 | +47x | +
+ term_label = term_label,+ |
+
| 223 | +47x | +
+ level = levels(data[[effect]])[2],+ |
+
| 224 | +47x | +
+ n = mod[["n"]],+ |
+
| 225 | +47x | +
+ hr = unname(sum_main["exp(coef)"]),+ |
+
| 226 | +47x | +
+ lcl = unname(sum_main[grep("lower", names(sum_main))]),
+ |
+
| 227 | +47x | +
+ ucl = unname(sum_main[grep("upper", names(sum_main))]),
+ |
+
| 228 | +47x | +
+ pval = pval,+ |
+
| 229 | +47x | +
+ stringsAsFactors = FALSE+ |
+
| 230 | ++ |
+ )+ |
+
| 231 | ++ |
+ }+ |
+
| 232 | ++ | + + | +
| 233 | ++ |
+ #' @describeIn h_cox_regression Tabulation of multivariate Cox regressions. Utility function to help+ |
+
| 234 | ++ |
+ #' tabulate the result of a multivariate Cox regression model for a treatment/covariate variable.+ |
+
| 235 | ++ |
+ #'+ |
+
| 236 | ++ |
+ #' @return+ |
+
| 237 | ++ |
+ #' * `h_coxreg_multivar_extract()` returns a `data.frame` with variables `pval`, `hr`, `lcl`, `ucl`, `level`,+ |
+
| 238 | ++ |
+ #' `n`, `term`, and `term_label`.+ |
+
| 239 | ++ |
+ #'+ |
+
| 240 | ++ |
+ #' @examples+ |
+
| 241 | ++ |
+ #' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple)+ |
+
| 242 | ++ |
+ #' result <- h_coxreg_multivar_extract(+ |
+
| 243 | ++ |
+ #' var = "var1", mod = mod, data = dta_simple+ |
+
| 244 | ++ |
+ #' )+ |
+
| 245 | ++ |
+ #' result+ |
+
| 246 | ++ |
+ #'+ |
+
| 247 | ++ |
+ #' @export+ |
+
| 248 | ++ |
+ h_coxreg_multivar_extract <- function(var,+ |
+
| 249 | ++ |
+ data,+ |
+
| 250 | ++ |
+ mod,+ |
+
| 251 | ++ |
+ control = control_coxreg()) {
+ |
+
| 252 | +76x | +
+ test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]+ |
+
| 253 | +76x | +
+ mod_aov <- muffled_car_anova(mod, test_statistic)+ |
+
| 254 | ++ | + + | +
| 255 | +76x | +
+ msum <- summary(mod, conf.int = control$conf_level)+ |
+
| 256 | +76x | +
+ sum_anova <- broom::tidy(mod_aov)+ |
+
| 257 | +76x | +
+ sum_cox <- broom::tidy(msum)+ |
+
| 258 | ++ | + + | +
| 259 | +76x | +
+ ret_anova <- sum_anova[sum_anova$term == var, c("term", "p.value")]
+ |
+
| 260 | +76x | +
+ names(ret_anova)[2] <- "pval"+ |
+
| 261 | +76x | +
+ if (is.factor(data[[var]])) {
+ |
+
| 262 | +29x | +
+ ret_cox <- sum_cox[startsWith(prefix = var, x = sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")]+ |
+
| 263 | ++ |
+ } else {
+ |
+
| 264 | +47x | +
+ ret_cox <- sum_cox[(var == sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")]+ |
+
| 265 | ++ |
+ }+ |
+
| 266 | +76x | +
+ names(ret_cox)[1:4] <- c("pval", "hr", "lcl", "ucl")
+ |
+
| 267 | +76x | +
+ varlab <- unname(labels_or_names(data[var]))+ |
+
| 268 | +76x | +
+ ret_cox$term <- varlab+ |
+
| 269 | ++ | + + | +
| 270 | +76x | +
+ if (is.numeric(data[[var]])) {
+ |
+
| 271 | +47x | +
+ ret <- ret_cox+ |
+
| 272 | +47x | +
+ ret$term_label <- ret$term+ |
+
| 273 | +29x | +
+ } else if (length(levels(data[[var]])) <= 2) {
+ |
+
| 274 | +18x | +
+ ret_anova$pval <- NA+ |
+
| 275 | +18x | +
+ ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")")+ |
+
| 276 | +18x | +
+ ret_cox$level <- gsub(var, "", ret_cox$level)+ |
+
| 277 | +18x | +
+ ret_cox$term_label <- ret_cox$level+ |
+
| 278 | +18x | +
+ ret <- dplyr::bind_rows(ret_anova, ret_cox)+ |
+
| 279 | ++ |
+ } else {
+ |
+
| 280 | +11x | +
+ ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")")+ |
+
| 281 | +11x | +
+ ret_cox$level <- gsub(var, "", ret_cox$level)+ |
+
| 282 | +11x | +
+ ret_cox$term_label <- ret_cox$level+ |
+
| 283 | +11x | +
+ ret <- dplyr::bind_rows(ret_anova, ret_cox)+ |
+
| 284 | ++ |
+ }+ |
+
| 285 | ++ | + + | +
| 286 | +76x | +
+ as.data.frame(ret)+ |
+
| 287 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Counting Patients and Events in Columns+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Counting the number of unique patients and the total number of all and specific events+ |
+
| 6 | ++ |
+ #' when a column table layout is required.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @name count_patients_events_in_cols+ |
+
| 11 | ++ |
+ NULL+ |
+
| 12 | ++ | + + | +
| 13 | ++ |
+ #' @describeIn count_patients_events_in_cols Statistics function which counts numbers of patients and multiple+ |
+
| 14 | ++ |
+ #' events defined by filters. Used as analysis function `afun` in `summarize_patients_events_in_cols()`.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @param filters_list (named `list` of `character`)\cr each element in this list describes one+ |
+
| 17 | ++ |
+ #' type of event describe by filters, in the same format as [s_count_patients_with_event()].+ |
+
| 18 | ++ |
+ #' If it has a label, then this will be used for the column title.+ |
+
| 19 | ++ |
+ #' @param empty_stats (`character`)\cr optional names of the statistics that should be returned empty such+ |
+
| 20 | ++ |
+ #' that corresponding table cells will stay blank.+ |
+
| 21 | ++ |
+ #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will+ |
+
| 22 | ++ |
+ #' be used as label.+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @return+ |
+
| 25 | ++ |
+ #' * `s_count_patients_and_multiple_events()` returns a list with the statistics:+ |
+
| 26 | ++ |
+ #' - `unique`: number of unique patients in `df`.+ |
+
| 27 | ++ |
+ #' - `all`: number of rows in `df`.+ |
+
| 28 | ++ |
+ #' - one element with the same name as in `filters_list`: number of rows in `df`,+ |
+
| 29 | ++ |
+ #' i.e. events, fulfilling the filter condition.+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' @examples+ |
+
| 32 | ++ |
+ #' # `s_count_patients_and_multiple_events()`+ |
+
| 33 | ++ |
+ #' df <- data.frame(+ |
+
| 34 | ++ |
+ #' USUBJID = rep(c("id1", "id2", "id3", "id4"), c(2, 3, 1, 1)),
+ |
+
| 35 | ++ |
+ #' ARM = c("A", "A", "B", "B", "B", "B", "A"),
+ |
+
| 36 | ++ |
+ #' AESER = rep("Y", 7),
+ |
+
| 37 | ++ |
+ #' AESDTH = c("Y", "Y", "N", "Y", "Y", "N", "N"),
+ |
+
| 38 | ++ |
+ #' AEREL = c("Y", "Y", "N", "Y", "Y", "N", "Y"),
+ |
+
| 39 | ++ |
+ #' AEDECOD = c("A", "A", "A", "B", "B", "C", "D"),
+ |
+
| 40 | ++ |
+ #' AEBODSYS = rep(c("SOC1", "SOC2", "SOC3"), c(3, 3, 1))
+ |
+
| 41 | ++ |
+ #' )+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' @keywords internal+ |
+
| 44 | ++ |
+ s_count_patients_and_multiple_events <- function(df, # nolint+ |
+
| 45 | ++ |
+ id,+ |
+
| 46 | ++ |
+ filters_list,+ |
+
| 47 | ++ |
+ empty_stats = character(),+ |
+
| 48 | ++ |
+ labelstr = "",+ |
+
| 49 | ++ |
+ custom_label = NULL) {
+ |
+
| 50 | +9x | +
+ checkmate::assert_list(filters_list, names = "named")+ |
+
| 51 | +9x | +
+ checkmate::assert_data_frame(df)+ |
+
| 52 | +9x | +
+ checkmate::assert_string(id)+ |
+
| 53 | +9x | +
+ checkmate::assert_disjunct(c("unique", "all"), names(filters_list))
+ |
+
| 54 | +9x | +
+ checkmate::assert_character(empty_stats)+ |
+
| 55 | +9x | +
+ checkmate::assert_string(labelstr)+ |
+
| 56 | +9x | +
+ checkmate::assert_string(custom_label, null.ok = TRUE)+ |
+
| 57 | ++ | + + | +
| 58 | ++ |
+ # Below we want to count each row in `df` once, therefore introducing this helper index column.+ |
+
| 59 | +9x | +
+ df$.row_index <- as.character(seq_len(nrow(df)))+ |
+
| 60 | +9x | +
+ y <- list()+ |
+
| 61 | +9x | +
+ row_label <- if (labelstr != "") {
+ |
+
| 62 | +! | +
+ labelstr+ |
+
| 63 | +9x | +
+ } else if (!is.null(custom_label)) {
+ |
+
| 64 | +2x | +
+ custom_label+ |
+
| 65 | ++ |
+ } else {
+ |
+
| 66 | +7x | +
+ "counts"+ |
+
| 67 | ++ |
+ }+ |
+
| 68 | +9x | +
+ y$unique <- formatters::with_label(+ |
+
| 69 | +9x | +
+ s_num_patients_content(df = df, .N_col = 1, .var = id, required = NULL)$unique[1L],+ |
+
| 70 | +9x | +
+ row_label+ |
+
| 71 | ++ |
+ )+ |
+
| 72 | +9x | +
+ y$all <- formatters::with_label(+ |
+
| 73 | +9x | +
+ nrow(df),+ |
+
| 74 | +9x | +
+ row_label+ |
+
| 75 | ++ |
+ )+ |
+
| 76 | +9x | +
+ events <- Map(+ |
+
| 77 | +9x | +
+ function(filters) {
+ |
+
| 78 | +25x | +
+ formatters::with_label(+ |
+
| 79 | +25x | +
+ s_count_patients_with_event(df = df, .var = ".row_index", filters = filters, .N_col = 1, .N_row = 1)$count,+ |
+
| 80 | +25x | +
+ row_label+ |
+
| 81 | ++ |
+ )+ |
+
| 82 | ++ |
+ },+ |
+
| 83 | +9x | +
+ filters = filters_list+ |
+
| 84 | ++ |
+ )+ |
+
| 85 | +9x | +
+ y_complete <- c(y, events)+ |
+
| 86 | +9x | +
+ y <- if (length(empty_stats) > 0) {
+ |
+
| 87 | +3x | +
+ y_reduced <- y_complete+ |
+
| 88 | +3x | +
+ for (stat in intersect(names(y_complete), empty_stats)) {
+ |
+
| 89 | +4x | +
+ y_reduced[[stat]] <- formatters::with_label(character(), obj_label(y_reduced[[stat]]))+ |
+
| 90 | ++ |
+ }+ |
+
| 91 | +3x | +
+ y_reduced+ |
+
| 92 | ++ |
+ } else {
+ |
+
| 93 | +6x | +
+ y_complete+ |
+
| 94 | ++ |
+ }+ |
+
| 95 | +9x | +
+ y+ |
+
| 96 | ++ |
+ }+ |
+
| 97 | ++ | + + | +
| 98 | ++ |
+ #' @describeIn count_patients_events_in_cols Layout-creating function which can take statistics function+ |
+
| 99 | ++ |
+ #' arguments and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ |
+
| 100 | ++ |
+ #'+ |
+
| 101 | ++ |
+ #' @param col_split (`flag`)\cr whether the columns should be split.+ |
+
| 102 | ++ |
+ #' Set to `FALSE` when the required column split has been done already earlier in the layout pipe.+ |
+
| 103 | ++ |
+ #'+ |
+
| 104 | ++ |
+ #' @return+ |
+
| 105 | ++ |
+ #' * `summarize_patients_events_in_cols()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 106 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted content rows+ |
+
| 107 | ++ |
+ #' containing the statistics from `s_count_patients_and_multiple_events()` to the table layout.+ |
+
| 108 | ++ |
+ #' @examples+ |
+
| 109 | ++ |
+ #' # `summarize_patients_events_in_cols()`+ |
+
| 110 | ++ |
+ #' basic_table() %>%+ |
+
| 111 | ++ |
+ #' summarize_patients_events_in_cols(+ |
+
| 112 | ++ |
+ #' filters_list = list(+ |
+
| 113 | ++ |
+ #' related = formatters::with_label(c(AEREL = "Y"), "Events (Related)"),+ |
+
| 114 | ++ |
+ #' fatal = c(AESDTH = "Y"),+ |
+
| 115 | ++ |
+ #' fatal_related = c(AEREL = "Y", AESDTH = "Y")+ |
+
| 116 | ++ |
+ #' ),+ |
+
| 117 | ++ |
+ #' custom_label = "%s Total number of patients and events"+ |
+
| 118 | ++ |
+ #' ) %>%+ |
+
| 119 | ++ |
+ #' build_table(df)+ |
+
| 120 | ++ |
+ #'+ |
+
| 121 | ++ |
+ #' @export+ |
+
| 122 | ++ |
+ summarize_patients_events_in_cols <- function(lyt, # nolint+ |
+
| 123 | ++ |
+ id = "USUBJID",+ |
+
| 124 | ++ |
+ filters_list = list(),+ |
+
| 125 | ++ |
+ na_str = NA_character_,+ |
+
| 126 | ++ |
+ ...,+ |
+
| 127 | ++ |
+ .stats = c(+ |
+
| 128 | ++ |
+ "unique",+ |
+
| 129 | ++ |
+ "all",+ |
+
| 130 | ++ |
+ names(filters_list)+ |
+
| 131 | ++ |
+ ),+ |
+
| 132 | ++ |
+ .labels = c(+ |
+
| 133 | ++ |
+ unique = "Patients (All)",+ |
+
| 134 | ++ |
+ all = "Events (All)",+ |
+
| 135 | ++ |
+ labels_or_names(filters_list)+ |
+
| 136 | ++ |
+ ),+ |
+
| 137 | ++ |
+ col_split = TRUE) {
+ |
+
| 138 | +2x | +
+ afun_list <- Map(+ |
+
| 139 | +2x | +
+ function(stat) {
+ |
+
| 140 | +7x | +
+ make_afun(+ |
+
| 141 | +7x | +
+ s_count_patients_and_multiple_events,+ |
+
| 142 | +7x | +
+ id = id,+ |
+
| 143 | +7x | +
+ filters_list = filters_list,+ |
+
| 144 | +7x | +
+ .stats = stat,+ |
+
| 145 | +7x | +
+ .formats = "xx."+ |
+
| 146 | ++ |
+ )+ |
+
| 147 | ++ |
+ },+ |
+
| 148 | +2x | +
+ stat = .stats+ |
+
| 149 | ++ |
+ )+ |
+
| 150 | +2x | +
+ if (col_split) {
+ |
+
| 151 | +2x | +
+ lyt <- split_cols_by_multivar(+ |
+
| 152 | +2x | +
+ lyt = lyt,+ |
+
| 153 | +2x | +
+ vars = rep(id, length(.stats)),+ |
+
| 154 | +2x | +
+ varlabels = .labels[.stats]+ |
+
| 155 | ++ |
+ )+ |
+
| 156 | ++ |
+ }+ |
+
| 157 | +2x | +
+ summarize_row_groups(+ |
+
| 158 | +2x | +
+ lyt = lyt,+ |
+
| 159 | +2x | +
+ cfun = afun_list,+ |
+
| 160 | +2x | +
+ na_str = na_str,+ |
+
| 161 | +2x | +
+ extra_args = list(...)+ |
+
| 162 | ++ |
+ )+ |
+
| 163 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Summary for analysis of covariance (`ANCOVA`).+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Summarize results of `ANCOVA`. This can be used to analyze multiple endpoints and/or+ |
+
| 6 | ++ |
+ #' multiple timepoints within the same response variable `.var`.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @name summarize_ancova+ |
+
| 11 | ++ |
+ NULL+ |
+
| 12 | ++ | + + | +
| 13 | ++ |
+ #' Helper Function to Return Results of a Linear Model+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 18 | ++ |
+ #' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called in `.var` and `variables`.+ |
+
| 19 | ++ |
+ #' @param variables (named `list` of `strings`)\cr list of additional analysis variables, with expected elements:+ |
+
| 20 | ++ |
+ #' * `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple groups will be+ |
+
| 21 | ++ |
+ #' summarized. Specifically, the first level of `arm` variable is taken as the reference group.+ |
+
| 22 | ++ |
+ #' * `covariates` (`character`)\cr a vector that can contain single variable names (such as `"X1"`), and/or+ |
+
| 23 | ++ |
+ #' interaction terms indicated by `"X1 * X2"`.+ |
+
| 24 | ++ |
+ #' @param interaction_item (`character`)\cr name of the variable that should have interactions+ |
+
| 25 | ++ |
+ #' with arm. if the interaction is not needed, the default option is `NULL`.+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' @return The summary of a linear model.+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @examples+ |
+
| 30 | ++ |
+ #' h_ancova(+ |
+
| 31 | ++ |
+ #' .var = "Sepal.Length",+ |
+
| 32 | ++ |
+ #' .df_row = iris,+ |
+
| 33 | ++ |
+ #' variables = list(arm = "Species", covariates = c("Petal.Length * Petal.Width", "Sepal.Width"))
+ |
+
| 34 | ++ |
+ #' )+ |
+
| 35 | ++ |
+ #'+ |
+
| 36 | ++ |
+ #' @export+ |
+
| 37 | ++ |
+ h_ancova <- function(.var,+ |
+
| 38 | ++ |
+ .df_row,+ |
+
| 39 | ++ |
+ variables,+ |
+
| 40 | ++ |
+ interaction_item = NULL) {
+ |
+
| 41 | +15x | +
+ checkmate::assert_string(.var)+ |
+
| 42 | +15x | +
+ checkmate::assert_list(variables)+ |
+
| 43 | +15x | +
+ checkmate::assert_subset(names(variables), c("arm", "covariates"))
+ |
+
| 44 | +15x | +
+ assert_df_with_variables(.df_row, list(rsp = .var))+ |
+
| 45 | ++ | + + | +
| 46 | +14x | +
+ arm <- variables$arm+ |
+
| 47 | +14x | +
+ covariates <- variables$covariates+ |
+
| 48 | +14x | +
+ if (!is.null(covariates) && length(covariates) > 0) {
+ |
+
| 49 | ++ |
+ # Get all covariate variable names in the model.+ |
+
| 50 | +11x | +
+ var_list <- get_covariates(covariates)+ |
+
| 51 | +11x | +
+ assert_df_with_variables(.df_row, var_list)+ |
+
| 52 | ++ |
+ }+ |
+
| 53 | ++ | + + | +
| 54 | +13x | +
+ covariates_part <- paste(covariates, collapse = " + ")+ |
+
| 55 | +13x | +
+ if (covariates_part != "") {
+ |
+
| 56 | +10x | +
+ formula <- stats::as.formula(paste0(.var, " ~ ", covariates_part, " + ", arm))+ |
+
| 57 | ++ |
+ } else {
+ |
+
| 58 | +3x | +
+ formula <- stats::as.formula(paste0(.var, " ~ ", arm))+ |
+
| 59 | ++ |
+ }+ |
+
| 60 | ++ | + + | +
| 61 | +13x | +
+ if (is.null(interaction_item)) {
+ |
+
| 62 | +9x | +
+ specs <- arm+ |
+
| 63 | ++ |
+ } else {
+ |
+
| 64 | +4x | +
+ specs <- c(arm, interaction_item)+ |
+
| 65 | ++ |
+ }+ |
+
| 66 | ++ | + + | +
| 67 | +13x | +
+ lm_fit <- stats::lm(+ |
+
| 68 | +13x | +
+ formula = formula,+ |
+
| 69 | +13x | +
+ data = .df_row+ |
+
| 70 | ++ |
+ )+ |
+
| 71 | +13x | +
+ emmeans_fit <- emmeans::emmeans(+ |
+
| 72 | +13x | +
+ lm_fit,+ |
+
| 73 | ++ |
+ # Specify here the group variable over which EMM are desired.+ |
+
| 74 | +13x | +
+ specs = specs,+ |
+
| 75 | ++ |
+ # Pass the data again so that the factor levels of the arm variable can be inferred.+ |
+
| 76 | +13x | +
+ data = .df_row+ |
+
| 77 | ++ |
+ )+ |
+
| 78 | ++ | + + | +
| 79 | +13x | +
+ emmeans_fit+ |
+
| 80 | ++ |
+ }+ |
+
| 81 | ++ | + + | +
| 82 | ++ |
+ #' @describeIn summarize_ancova Statistics function that produces a named list of results+ |
+
| 83 | ++ |
+ #' of the investigated linear model.+ |
+
| 84 | ++ |
+ #'+ |
+
| 85 | ++ |
+ #' @inheritParams h_ancova+ |
+
| 86 | ++ |
+ #' @param interaction_y (`character`)\cr a selected item inside of the interaction_item column which will be used+ |
+
| 87 | ++ |
+ #' to select the specific `ANCOVA` results. if the interaction is not needed, the default option is `FALSE`.+ |
+
| 88 | ++ |
+ #'+ |
+
| 89 | ++ |
+ #' @return+ |
+
| 90 | ++ |
+ #' * `s_ancova()` returns a named list of 5 statistics:+ |
+
| 91 | ++ |
+ #' * `n`: Count of complete sample size for the group.+ |
+
| 92 | ++ |
+ #' * `lsmean`: Estimated marginal means in the group.+ |
+
| 93 | ++ |
+ #' * `lsmean_diff`: Difference in estimated marginal means in comparison to the reference group.+ |
+
| 94 | ++ |
+ #' If working with the reference group, this will be empty.+ |
+
| 95 | ++ |
+ #' * `lsmean_diff_ci`: Confidence level for difference in estimated marginal means in comparison+ |
+
| 96 | ++ |
+ #' to the reference group.+ |
+
| 97 | ++ |
+ #' * `pval`: p-value (not adjusted for multiple comparisons).+ |
+
| 98 | ++ |
+ #'+ |
+
| 99 | ++ |
+ #' @examples+ |
+
| 100 | ++ |
+ #' library(dplyr)+ |
+
| 101 | ++ |
+ #'+ |
+
| 102 | ++ |
+ #' df <- iris %>% filter(Species == "virginica")+ |
+
| 103 | ++ |
+ #' .df_row <- iris+ |
+
| 104 | ++ |
+ #' .var <- "Petal.Length"+ |
+
| 105 | ++ |
+ #' variables <- list(arm = "Species", covariates = "Sepal.Length * Sepal.Width")+ |
+
| 106 | ++ |
+ #' .ref_group <- iris %>% filter(Species == "setosa")+ |
+
| 107 | ++ |
+ #' conf_level <- 0.95+ |
+
| 108 | ++ |
+ #'+ |
+
| 109 | ++ |
+ #' @keywords internal+ |
+
| 110 | ++ |
+ s_ancova <- function(df,+ |
+
| 111 | ++ |
+ .var,+ |
+
| 112 | ++ |
+ .df_row,+ |
+
| 113 | ++ |
+ variables,+ |
+
| 114 | ++ |
+ .ref_group,+ |
+
| 115 | ++ |
+ .in_ref_col,+ |
+
| 116 | ++ |
+ conf_level,+ |
+
| 117 | ++ |
+ interaction_y = FALSE,+ |
+
| 118 | ++ |
+ interaction_item = NULL) {
+ |
+
| 119 | +3x | +
+ emmeans_fit <- h_ancova(.var = .var, variables = variables, .df_row = .df_row, interaction_item = interaction_item)+ |
+
| 120 | ++ | + + | +
| 121 | +3x | +
+ sum_fit <- summary(+ |
+
| 122 | +3x | +
+ emmeans_fit,+ |
+
| 123 | +3x | +
+ level = conf_level+ |
+
| 124 | ++ |
+ )+ |
+
| 125 | ++ | + + | +
| 126 | +3x | +
+ arm <- variables$arm+ |
+
| 127 | ++ | + + | +
| 128 | +3x | +
+ sum_level <- as.character(unique(df[[arm]]))+ |
+
| 129 | ++ | + + | +
| 130 | ++ |
+ # Ensure that there is only one element in sum_level.+ |
+
| 131 | +3x | +
+ checkmate::assert_scalar(sum_level)+ |
+
| 132 | ++ | + + | +
| 133 | +2x | +
+ sum_fit_level <- sum_fit[sum_fit[[arm]] == sum_level, ]+ |
+
| 134 | ++ | + + | +
| 135 | ++ |
+ # Get the index of the ref arm+ |
+
| 136 | +2x | +
+ if (interaction_y != FALSE) {
+ |
+
| 137 | +1x | +
+ y <- unlist(df[(df[[interaction_item]] == interaction_y), .var])+ |
+
| 138 | ++ |
+ # convert characters selected in interaction_y into the numeric order+ |
+
| 139 | +1x | +
+ interaction_y <- which(sum_fit_level[[interaction_item]] == interaction_y)+ |
+
| 140 | +1x | +
+ sum_fit_level <- sum_fit_level[interaction_y, ]+ |
+
| 141 | ++ |
+ # if interaction is called, reset the index+ |
+
| 142 | +1x | +
+ ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])])+ |
+
| 143 | +1x | +
+ ref_key <- tail(ref_key, n = 1)+ |
+
| 144 | +1x | +
+ ref_key <- (interaction_y - 1) * length(unique(.df_row[[arm]])) + ref_key+ |
+
| 145 | ++ |
+ } else {
+ |
+
| 146 | +1x | +
+ y <- df[[.var]]+ |
+
| 147 | ++ |
+ # Get the index of the ref arm when interaction is not called+ |
+
| 148 | +1x | +
+ ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])])+ |
+
| 149 | +1x | +
+ ref_key <- tail(ref_key, n = 1)+ |
+
| 150 | ++ |
+ }+ |
+
| 151 | ++ | + + | +
| 152 | +2x | +
+ if (.in_ref_col) {
+ |
+
| 153 | +1x | +
+ list(+ |
+
| 154 | +1x | +
+ n = length(y[!is.na(y)]),+ |
+
| 155 | +1x | +
+ lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"),+ |
+
| 156 | +1x | +
+ lsmean_diff = formatters::with_label(character(), "Difference in Adjusted Means"),+ |
+
| 157 | +1x | +
+ lsmean_diff_ci = formatters::with_label(character(), f_conf_level(conf_level)),+ |
+
| 158 | +1x | +
+ pval = formatters::with_label(character(), "p-value")+ |
+
| 159 | ++ |
+ )+ |
+
| 160 | ++ |
+ } else {
+ |
+
| 161 | ++ |
+ # Estimate the differences between the marginal means.+ |
+
| 162 | +1x | +
+ emmeans_contrasts <- emmeans::contrast(+ |
+
| 163 | +1x | +
+ emmeans_fit,+ |
+
| 164 | ++ |
+ # Compare all arms versus the control arm.+ |
+
| 165 | +1x | +
+ method = "trt.vs.ctrl",+ |
+
| 166 | ++ |
+ # Take the arm factor from .ref_group as the control arm.+ |
+
| 167 | +1x | +
+ ref = ref_key,+ |
+
| 168 | +1x | +
+ level = conf_level+ |
+
| 169 | ++ |
+ )+ |
+
| 170 | +1x | +
+ sum_contrasts <- summary(+ |
+
| 171 | +1x | +
+ emmeans_contrasts,+ |
+
| 172 | ++ |
+ # Derive confidence intervals, t-tests and p-values.+ |
+
| 173 | +1x | +
+ infer = TRUE,+ |
+
| 174 | ++ |
+ # Do not adjust the p-values for multiplicity.+ |
+
| 175 | +1x | +
+ adjust = "none"+ |
+
| 176 | ++ |
+ )+ |
+
| 177 | ++ | + + | +
| 178 | +1x | +
+ sum_contrasts_level <- sum_contrasts[grepl(sum_level, sum_contrasts$contrast), ]+ |
+
| 179 | +1x | +
+ if (interaction_y != FALSE) {
+ |
+
| 180 | +! | +
+ sum_contrasts_level <- sum_contrasts_level[interaction_y, ]+ |
+
| 181 | ++ |
+ }+ |
+
| 182 | ++ | + + | +
| 183 | +1x | +
+ list(+ |
+
| 184 | +1x | +
+ n = length(y[!is.na(y)]),+ |
+
| 185 | +1x | +
+ lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"),+ |
+
| 186 | +1x | +
+ lsmean_diff = formatters::with_label(sum_contrasts_level$estimate, "Difference in Adjusted Means"),+ |
+
| 187 | +1x | +
+ lsmean_diff_ci = formatters::with_label(+ |
+
| 188 | +1x | +
+ c(sum_contrasts_level$lower.CL, sum_contrasts_level$upper.CL),+ |
+
| 189 | +1x | +
+ f_conf_level(conf_level)+ |
+
| 190 | ++ |
+ ),+ |
+
| 191 | +1x | +
+ pval = formatters::with_label(sum_contrasts_level$p.value, "p-value")+ |
+
| 192 | ++ |
+ )+ |
+
| 193 | ++ |
+ }+ |
+
| 194 | ++ |
+ }+ |
+
| 195 | ++ | + + | +
| 196 | ++ |
+ #' @describeIn summarize_ancova Formatted analysis function which is used as `afun` in `summarize_ancova()`.+ |
+
| 197 | ++ |
+ #'+ |
+
| 198 | ++ |
+ #' @return+ |
+
| 199 | ++ |
+ #' * `a_ancova()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 200 | ++ |
+ #'+ |
+
| 201 | ++ |
+ #'+ |
+
| 202 | ++ |
+ #' @keywords internal+ |
+
| 203 | ++ |
+ a_ancova <- make_afun(+ |
+
| 204 | ++ |
+ s_ancova,+ |
+
| 205 | ++ |
+ .indent_mods = c("n" = 0L, "lsmean" = 0L, "lsmean_diff" = 0L, "lsmean_diff_ci" = 1L, "pval" = 1L),
+ |
+
| 206 | ++ |
+ .formats = c(+ |
+
| 207 | ++ |
+ "n" = "xx",+ |
+
| 208 | ++ |
+ "lsmean" = "xx.xx",+ |
+
| 209 | ++ |
+ "lsmean_diff" = "xx.xx",+ |
+
| 210 | ++ |
+ "lsmean_diff_ci" = "(xx.xx, xx.xx)",+ |
+
| 211 | ++ |
+ "pval" = "x.xxxx | (<0.0001)"+ |
+
| 212 | ++ |
+ ),+ |
+
| 213 | ++ |
+ .null_ref_cells = FALSE+ |
+
| 214 | ++ |
+ )+ |
+
| 215 | ++ | + + | +
| 216 | ++ |
+ #' @describeIn summarize_ancova Layout-creating function which can take statistics function arguments+ |
+
| 217 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 218 | ++ |
+ #'+ |
+
| 219 | ++ |
+ #' @return+ |
+
| 220 | ++ |
+ #' * `summarize_ancova()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 221 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 222 | ++ |
+ #' the statistics from `s_ancova()` to the table layout.+ |
+
| 223 | ++ |
+ #'+ |
+
| 224 | ++ |
+ #' @examples+ |
+
| 225 | ++ |
+ #' basic_table() %>%+ |
+
| 226 | ++ |
+ #' split_cols_by("Species", ref_group = "setosa") %>%
+ |
+
| 227 | ++ |
+ #' add_colcounts() %>%+ |
+
| 228 | ++ |
+ #' summarize_ancova(+ |
+
| 229 | ++ |
+ #' vars = "Petal.Length",+ |
+
| 230 | ++ |
+ #' variables = list(arm = "Species", covariates = NULL),+ |
+
| 231 | ++ |
+ #' table_names = "unadj",+ |
+
| 232 | ++ |
+ #' conf_level = 0.95, var_labels = "Unadjusted comparison",+ |
+
| 233 | ++ |
+ #' .labels = c(lsmean = "Mean", lsmean_diff = "Difference in Means")+ |
+
| 234 | ++ |
+ #' ) %>%+ |
+
| 235 | ++ |
+ #' summarize_ancova(+ |
+
| 236 | ++ |
+ #' vars = "Petal.Length",+ |
+
| 237 | ++ |
+ #' variables = list(arm = "Species", covariates = c("Sepal.Length", "Sepal.Width")),
+ |
+
| 238 | ++ |
+ #' table_names = "adj",+ |
+
| 239 | ++ |
+ #' conf_level = 0.95, var_labels = "Adjusted comparison (covariates: Sepal.Length and Sepal.Width)"+ |
+
| 240 | ++ |
+ #' ) %>%+ |
+
| 241 | ++ |
+ #' build_table(iris)+ |
+
| 242 | ++ |
+ #'+ |
+
| 243 | ++ |
+ #' @export+ |
+
| 244 | ++ |
+ summarize_ancova <- function(lyt,+ |
+
| 245 | ++ |
+ vars,+ |
+
| 246 | ++ |
+ var_labels,+ |
+
| 247 | ++ |
+ na_str = NA_character_,+ |
+
| 248 | ++ |
+ nested = TRUE,+ |
+
| 249 | ++ |
+ ...,+ |
+
| 250 | ++ |
+ show_labels = "visible",+ |
+
| 251 | ++ |
+ table_names = vars,+ |
+
| 252 | ++ |
+ .stats = NULL,+ |
+
| 253 | ++ |
+ .formats = NULL,+ |
+
| 254 | ++ |
+ .labels = NULL,+ |
+
| 255 | ++ |
+ .indent_mods = NULL,+ |
+
| 256 | ++ |
+ interaction_y = FALSE,+ |
+
| 257 | ++ |
+ interaction_item = NULL) {
+ |
+
| 258 | +3x | +
+ afun <- make_afun(+ |
+
| 259 | +3x | +
+ a_ancova,+ |
+
| 260 | +3x | +
+ interaction_y = interaction_y,+ |
+
| 261 | +3x | +
+ interaction_item = interaction_item,+ |
+
| 262 | +3x | +
+ .stats = .stats,+ |
+
| 263 | +3x | +
+ .formats = .formats,+ |
+
| 264 | +3x | +
+ .labels = .labels,+ |
+
| 265 | +3x | +
+ .indent_mods = .indent_mods+ |
+
| 266 | ++ |
+ )+ |
+
| 267 | ++ | + + | +
| 268 | +3x | +
+ analyze(+ |
+
| 269 | +3x | +
+ lyt,+ |
+
| 270 | +3x | +
+ vars,+ |
+
| 271 | +3x | +
+ var_labels = var_labels,+ |
+
| 272 | +3x | +
+ show_labels = show_labels,+ |
+
| 273 | +3x | +
+ table_names = table_names,+ |
+
| 274 | +3x | +
+ afun = afun,+ |
+
| 275 | +3x | +
+ na_str = na_str,+ |
+
| 276 | +3x | +
+ nested = nested,+ |
+
| 277 | +3x | +
+ extra_args = list(...)+ |
+
| 278 | ++ |
+ )+ |
+
| 279 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Incidence Rate+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Estimate the event rate adjusted for person-years at risk, otherwise known+ |
+
| 6 | ++ |
+ #' as incidence rate. Primary analysis variable is the person-years at risk.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #' @param control (`list`)\cr parameters for estimation details, specified by using+ |
+
| 10 | ++ |
+ #' the helper function [control_incidence_rate()]. Possible parameter options are:+ |
+
| 11 | ++ |
+ #' * `conf_level` (`proportion`)\cr confidence level for the estimated incidence rate.+ |
+
| 12 | ++ |
+ #' * `conf_type` (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`+ |
+
| 13 | ++ |
+ #' for confidence interval type.+ |
+
| 14 | ++ |
+ #' * `input_time_unit` (`string`)\cr `day`, `week`, `month`, or `year` (default)+ |
+
| 15 | ++ |
+ #' indicating time unit for data input.+ |
+
| 16 | ++ |
+ #' * `num_pt_year` (`numeric`)\cr time unit for desired output (in person-years).+ |
+
| 17 | ++ |
+ #' @param n_events (`integer`)\cr number of events observed.+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @seealso [control_incidence_rate()] and helper functions [h_incidence_rate].+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @name incidence_rate+ |
+
| 22 | ++ |
+ NULL+ |
+
| 23 | ++ | + + | +
| 24 | ++ |
+ #' @describeIn incidence_rate Statistics function which estimates the incidence rate and the+ |
+
| 25 | ++ |
+ #' associated confidence interval.+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' @return+ |
+
| 28 | ++ |
+ #' * `s_incidence_rate()` returns the following statistics:+ |
+
| 29 | ++ |
+ #' - `person_years`: Total person-years at risk.+ |
+
| 30 | ++ |
+ #' - `n_events`: Total number of events observed.+ |
+
| 31 | ++ |
+ #' - `rate`: Estimated incidence rate.+ |
+
| 32 | ++ |
+ #' - `rate_ci`: Confidence interval for the incidence rate.+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' @examples+ |
+
| 35 | ++ |
+ #' library(dplyr)+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' df <- data.frame(+ |
+
| 38 | ++ |
+ #' USUBJID = as.character(seq(6)),+ |
+
| 39 | ++ |
+ #' CNSR = c(0, 1, 1, 0, 0, 0),+ |
+
| 40 | ++ |
+ #' AVAL = c(10.1, 20.4, 15.3, 20.8, 18.7, 23.4),+ |
+
| 41 | ++ |
+ #' ARM = factor(c("A", "A", "A", "B", "B", "B"))
+ |
+
| 42 | ++ |
+ #' ) %>%+ |
+
| 43 | ++ |
+ #' mutate(is_event = CNSR == 0) %>%+ |
+
| 44 | ++ |
+ #' mutate(n_events = as.integer(is_event))+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' @keywords internal+ |
+
| 47 | ++ |
+ s_incidence_rate <- function(df,+ |
+
| 48 | ++ |
+ .var,+ |
+
| 49 | ++ |
+ n_events,+ |
+
| 50 | ++ |
+ is_event,+ |
+
| 51 | ++ |
+ control = control_incidence_rate()) {
+ |
+
| 52 | +1x | +
+ if (!missing(is_event)) {
+ |
+
| 53 | +! | +
+ warning("argument is_event will be deprecated. Please use n_events.")
+ |
+
| 54 | ++ | + + | +
| 55 | +! | +
+ if (missing(n_events)) {
+ |
+
| 56 | +! | +
+ assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ |
+
| 57 | +! | +
+ checkmate::assert_string(.var)+ |
+
| 58 | +! | +
+ checkmate::assert_logical(df[[is_event]], any.missing = FALSE)+ |
+
| 59 | +! | +
+ checkmate::assert_numeric(df[[.var]], any.missing = FALSE)+ |
+
| 60 | +! | +
+ n_events <- is_event+ |
+
| 61 | ++ |
+ }+ |
+
| 62 | ++ |
+ } else {
+ |
+
| 63 | +1x | +
+ assert_df_with_variables(df, list(tte = .var, n_events = n_events))+ |
+
| 64 | +1x | +
+ checkmate::assert_string(.var)+ |
+
| 65 | +1x | +
+ checkmate::assert_numeric(df[[.var]], any.missing = FALSE)+ |
+
| 66 | +1x | +
+ checkmate::assert_integer(df[[n_events]], any.missing = FALSE)+ |
+
| 67 | ++ |
+ }+ |
+
| 68 | ++ | + + | +
| 69 | +1x | +
+ input_time_unit <- control$input_time_unit+ |
+
| 70 | +1x | +
+ num_pt_year <- control$num_pt_year+ |
+
| 71 | +1x | +
+ conf_level <- control$conf_level+ |
+
| 72 | +1x | +
+ person_years <- sum(df[[.var]], na.rm = TRUE) * (+ |
+
| 73 | +1x | +
+ 1 * (input_time_unit == "year") ++ |
+
| 74 | +1x | +
+ 1 / 12 * (input_time_unit == "month") ++ |
+
| 75 | +1x | +
+ 1 / 52.14 * (input_time_unit == "week") ++ |
+
| 76 | +1x | +
+ 1 / 365.24 * (input_time_unit == "day")+ |
+
| 77 | ++ |
+ )+ |
+
| 78 | +1x | +
+ n_events <- sum(df[[n_events]], na.rm = TRUE)+ |
+
| 79 | ++ | + + | +
| 80 | +1x | +
+ result <- h_incidence_rate(+ |
+
| 81 | +1x | +
+ person_years,+ |
+
| 82 | +1x | +
+ n_events,+ |
+
| 83 | +1x | +
+ control+ |
+
| 84 | ++ |
+ )+ |
+
| 85 | +1x | +
+ list(+ |
+
| 86 | +1x | +
+ person_years = formatters::with_label(person_years, "Total patient-years at risk"),+ |
+
| 87 | +1x | +
+ n_events = formatters::with_label(n_events, "Number of adverse events observed"),+ |
+
| 88 | +1x | +
+ rate = formatters::with_label(result$rate, paste("AE rate per", num_pt_year, "patient-years")),
+ |
+
| 89 | +1x | +
+ rate_ci = formatters::with_label(result$rate_ci, f_conf_level(conf_level))+ |
+
| 90 | ++ |
+ )+ |
+
| 91 | ++ |
+ }+ |
+
| 92 | ++ | + + | +
| 93 | ++ |
+ #' @describeIn incidence_rate Formatted analysis function which is used as `afun`+ |
+
| 94 | ++ |
+ #' in `estimate_incidence_rate()`.+ |
+
| 95 | ++ |
+ #'+ |
+
| 96 | ++ |
+ #' @return+ |
+
| 97 | ++ |
+ #' * `a_incidence_rate()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 98 | ++ |
+ #'+ |
+
| 99 | ++ |
+ #'+ |
+
| 100 | ++ |
+ #' @keywords internal+ |
+
| 101 | ++ |
+ a_incidence_rate <- make_afun(+ |
+
| 102 | ++ |
+ s_incidence_rate,+ |
+
| 103 | ++ |
+ .formats = c(+ |
+
| 104 | ++ |
+ "person_years" = "xx.x",+ |
+
| 105 | ++ |
+ "n_events" = "xx",+ |
+
| 106 | ++ |
+ "rate" = "xx.xx",+ |
+
| 107 | ++ |
+ "rate_ci" = "(xx.xx, xx.xx)"+ |
+
| 108 | ++ |
+ )+ |
+
| 109 | ++ |
+ )+ |
+
| 110 | ++ | + + | +
| 111 | ++ |
+ #' @describeIn incidence_rate Layout-creating function which can take statistics function arguments+ |
+
| 112 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 113 | ++ |
+ #'+ |
+
| 114 | ++ |
+ #' @return+ |
+
| 115 | ++ |
+ #' * `estimate_incidence_rate()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 116 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 117 | ++ |
+ #' the statistics from `s_incidence_rate()` to the table layout.+ |
+
| 118 | ++ |
+ #'+ |
+
| 119 | ++ |
+ #' @examples+ |
+
| 120 | ++ |
+ #' basic_table() %>%+ |
+
| 121 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 122 | ++ |
+ #' add_colcounts() %>%+ |
+
| 123 | ++ |
+ #' estimate_incidence_rate(+ |
+
| 124 | ++ |
+ #' vars = "AVAL",+ |
+
| 125 | ++ |
+ #' n_events = "n_events",+ |
+
| 126 | ++ |
+ #' control = control_incidence_rate(+ |
+
| 127 | ++ |
+ #' input_time_unit = "month",+ |
+
| 128 | ++ |
+ #' num_pt_year = 100+ |
+
| 129 | ++ |
+ #' )+ |
+
| 130 | ++ |
+ #' ) %>%+ |
+
| 131 | ++ |
+ #' build_table(df)+ |
+
| 132 | ++ |
+ #'+ |
+
| 133 | ++ |
+ #' @export+ |
+
| 134 | ++ |
+ estimate_incidence_rate <- function(lyt,+ |
+
| 135 | ++ |
+ vars,+ |
+
| 136 | ++ |
+ na_str = NA_character_,+ |
+
| 137 | ++ |
+ nested = TRUE,+ |
+
| 138 | ++ |
+ ...,+ |
+
| 139 | ++ |
+ show_labels = "hidden",+ |
+
| 140 | ++ |
+ table_names = vars,+ |
+
| 141 | ++ |
+ .stats = NULL,+ |
+
| 142 | ++ |
+ .formats = NULL,+ |
+
| 143 | ++ |
+ .labels = NULL,+ |
+
| 144 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 145 | +1x | +
+ afun <- make_afun(+ |
+
| 146 | +1x | +
+ a_incidence_rate,+ |
+
| 147 | +1x | +
+ .stats = .stats,+ |
+
| 148 | +1x | +
+ .formats = .formats,+ |
+
| 149 | +1x | +
+ .labels = .labels,+ |
+
| 150 | +1x | +
+ .indent_mods = .indent_mods+ |
+
| 151 | ++ |
+ )+ |
+
| 152 | ++ | + + | +
| 153 | +1x | +
+ analyze(+ |
+
| 154 | +1x | +
+ lyt,+ |
+
| 155 | +1x | +
+ vars,+ |
+
| 156 | +1x | +
+ show_labels = show_labels,+ |
+
| 157 | +1x | +
+ table_names = table_names,+ |
+
| 158 | +1x | +
+ afun = afun,+ |
+
| 159 | +1x | +
+ na_str = na_str,+ |
+
| 160 | +1x | +
+ nested = nested,+ |
+
| 161 | +1x | +
+ extra_args = list(...)+ |
+
| 162 | ++ |
+ )+ |
+
| 163 | ++ |
+ }+ |
+
| 164 | ++ | + + | +
| 165 | ++ |
+ #' Helper Functions for Incidence Rate+ |
+
| 166 | ++ |
+ #'+ |
+
| 167 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 168 | ++ |
+ #'+ |
+
| 169 | ++ |
+ #' @param control (`list`)\cr parameters for estimation details, specified by using+ |
+
| 170 | ++ |
+ #' the helper function [control_incidence_rate()]. Possible parameter options are:+ |
+
| 171 | ++ |
+ #' * `conf_level`: (`proportion`)\cr confidence level for the estimated incidence rate.+ |
+
| 172 | ++ |
+ #' * `conf_type`: (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`+ |
+
| 173 | ++ |
+ #' for confidence interval type.+ |
+
| 174 | ++ |
+ #' * `input_time_unit`: (`string`)\cr `day`, `week`, `month`, or `year` (default)+ |
+
| 175 | ++ |
+ #' indicating time unit for data input.+ |
+
| 176 | ++ |
+ #' * `num_pt_year`: (`numeric`)\cr time unit for desired output (in person-years).+ |
+
| 177 | ++ |
+ #' @param person_years (`numeric`)\cr total person-years at risk.+ |
+
| 178 | ++ |
+ #' @param alpha (`numeric`)\cr two-sided alpha-level for confidence interval.+ |
+
| 179 | ++ |
+ #' @param n_events (`integer`)\cr number of events observed.+ |
+
| 180 | ++ |
+ #'+ |
+
| 181 | ++ |
+ #' @return Estimated incidence rate `rate` and associated confidence interval `rate_ci`.+ |
+
| 182 | ++ |
+ #'+ |
+
| 183 | ++ |
+ #' @seealso [incidence_rate]+ |
+
| 184 | ++ |
+ #'+ |
+
| 185 | ++ |
+ #' @name h_incidence_rate+ |
+
| 186 | ++ |
+ NULL+ |
+
| 187 | ++ | + + | +
| 188 | ++ |
+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ |
+
| 189 | ++ |
+ #' associated confidence interval based on the normal approximation for the+ |
+
| 190 | ++ |
+ #' incidence rate. Unit is one person-year.+ |
+
| 191 | ++ |
+ #'+ |
+
| 192 | ++ |
+ #' @examples+ |
+
| 193 | ++ |
+ #' h_incidence_rate_normal(200, 2)+ |
+
| 194 | ++ |
+ #'+ |
+
| 195 | ++ |
+ #' @export+ |
+
| 196 | ++ |
+ h_incidence_rate_normal <- function(person_years,+ |
+
| 197 | ++ |
+ n_events,+ |
+
| 198 | ++ |
+ alpha = 0.05) {
+ |
+
| 199 | +1x | +
+ checkmate::assert_number(person_years)+ |
+
| 200 | +1x | +
+ checkmate::assert_number(n_events)+ |
+
| 201 | +1x | +
+ assert_proportion_value(alpha)+ |
+
| 202 | ++ | + + | +
| 203 | +1x | +
+ est <- n_events / person_years+ |
+
| 204 | +1x | +
+ se <- sqrt(est / person_years)+ |
+
| 205 | +1x | +
+ ci <- est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * se+ |
+
| 206 | ++ | + + | +
| 207 | +1x | +
+ list(rate = est, rate_ci = ci)+ |
+
| 208 | ++ |
+ }+ |
+
| 209 | ++ | + + | +
| 210 | ++ |
+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ |
+
| 211 | ++ |
+ #' associated confidence interval based on the normal approximation for the+ |
+
| 212 | ++ |
+ #' logarithm of the incidence rate. Unit is one person-year.+ |
+
| 213 | ++ |
+ #'+ |
+
| 214 | ++ |
+ #' @examples+ |
+
| 215 | ++ |
+ #' h_incidence_rate_normal_log(200, 2)+ |
+
| 216 | ++ |
+ #'+ |
+
| 217 | ++ |
+ #' @export+ |
+
| 218 | ++ |
+ h_incidence_rate_normal_log <- function(person_years,+ |
+
| 219 | ++ |
+ n_events,+ |
+
| 220 | ++ |
+ alpha = 0.05) {
+ |
+
| 221 | +5x | +
+ checkmate::assert_number(person_years)+ |
+
| 222 | +5x | +
+ checkmate::assert_number(n_events)+ |
+
| 223 | +5x | +
+ assert_proportion_value(alpha)+ |
+
| 224 | ++ | + + | +
| 225 | +5x | +
+ rate_est <- n_events / person_years+ |
+
| 226 | +5x | +
+ rate_se <- sqrt(rate_est / person_years)+ |
+
| 227 | +5x | +
+ lrate_est <- log(rate_est)+ |
+
| 228 | +5x | +
+ lrate_se <- rate_se / rate_est+ |
+
| 229 | +5x | +
+ ci <- exp(lrate_est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * lrate_se)+ |
+
| 230 | ++ | + + | +
| 231 | +5x | +
+ list(rate = rate_est, rate_ci = ci)+ |
+
| 232 | ++ |
+ }+ |
+
| 233 | ++ | + + | +
| 234 | ++ |
+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ |
+
| 235 | ++ |
+ #' associated exact confidence interval. Unit is one person-year.+ |
+
| 236 | ++ |
+ #'+ |
+
| 237 | ++ |
+ #' @examples+ |
+
| 238 | ++ |
+ #' h_incidence_rate_exact(200, 2)+ |
+
| 239 | ++ |
+ #'+ |
+
| 240 | ++ |
+ #' @export+ |
+
| 241 | ++ |
+ h_incidence_rate_exact <- function(person_years,+ |
+
| 242 | ++ |
+ n_events,+ |
+
| 243 | ++ |
+ alpha = 0.05) {
+ |
+
| 244 | +1x | +
+ checkmate::assert_number(person_years)+ |
+
| 245 | +1x | +
+ checkmate::assert_number(n_events)+ |
+
| 246 | +1x | +
+ assert_proportion_value(alpha)+ |
+
| 247 | ++ | + + | +
| 248 | +1x | +
+ est <- n_events / person_years+ |
+
| 249 | +1x | +
+ lcl <- stats::qchisq(p = (alpha) / 2, df = 2 * n_events) / (2 * person_years)+ |
+
| 250 | +1x | +
+ ucl <- stats::qchisq(p = 1 - (alpha) / 2, df = 2 * n_events + 2) / (2 * person_years)+ |
+
| 251 | ++ | + + | +
| 252 | +1x | +
+ list(rate = est, rate_ci = c(lcl, ucl))+ |
+
| 253 | ++ |
+ }+ |
+
| 254 | ++ | + + | +
| 255 | ++ |
+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ |
+
| 256 | ++ |
+ #' associated `Byar`'s confidence interval. Unit is one person-year.+ |
+
| 257 | ++ |
+ #'+ |
+
| 258 | ++ |
+ #' @examples+ |
+
| 259 | ++ |
+ #' h_incidence_rate_byar(200, 2)+ |
+
| 260 | ++ |
+ #'+ |
+
| 261 | ++ |
+ #' @export+ |
+
| 262 | ++ |
+ h_incidence_rate_byar <- function(person_years,+ |
+
| 263 | ++ |
+ n_events,+ |
+
| 264 | ++ |
+ alpha = 0.05) {
+ |
+
| 265 | +1x | +
+ checkmate::assert_number(person_years)+ |
+
| 266 | +1x | +
+ checkmate::assert_number(n_events)+ |
+
| 267 | +1x | +
+ assert_proportion_value(alpha)+ |
+
| 268 | ++ | + + | +
| 269 | +1x | +
+ est <- n_events / person_years+ |
+
| 270 | +1x | +
+ seg_1 <- n_events + 0.5+ |
+
| 271 | +1x | +
+ seg_2 <- 1 - 1 / (9 * (n_events + 0.5))+ |
+
| 272 | +1x | +
+ seg_3 <- stats::qnorm(1 - alpha / 2) * sqrt(1 / (n_events + 0.5)) / 3+ |
+
| 273 | +1x | +
+ lcl <- seg_1 * ((seg_2 - seg_3)^3) / person_years+ |
+
| 274 | +1x | +
+ ucl <- seg_1 * ((seg_2 + seg_3) ^ 3) / person_years # styler: off+ |
+
| 275 | ++ | + + | +
| 276 | +1x | +
+ list(rate = est, rate_ci = c(lcl, ucl))+ |
+
| 277 | ++ |
+ }+ |
+
| 278 | ++ | + + | +
| 279 | ++ |
+ #' @describeIn h_incidence_rate Helper function to estimate the incidence rate and+ |
+
| 280 | ++ |
+ #' associated confidence interval.+ |
+
| 281 | ++ |
+ #'+ |
+
| 282 | ++ |
+ #'+ |
+
| 283 | ++ |
+ #' @keywords internal+ |
+
| 284 | ++ |
+ h_incidence_rate <- function(person_years,+ |
+
| 285 | ++ |
+ n_events,+ |
+
| 286 | ++ |
+ control = control_incidence_rate()) {
+ |
+
| 287 | +4x | +
+ alpha <- 1 - control$conf_level+ |
+
| 288 | +4x | +
+ est <- switch(control$conf_type,+ |
+
| 289 | +4x | +
+ normal = h_incidence_rate_normal(person_years, n_events, alpha),+ |
+
| 290 | +4x | +
+ normal_log = h_incidence_rate_normal_log(person_years, n_events, alpha),+ |
+
| 291 | +4x | +
+ exact = h_incidence_rate_exact(person_years, n_events, alpha),+ |
+
| 292 | +4x | +
+ byar = h_incidence_rate_byar(person_years, n_events, alpha)+ |
+
| 293 | ++ |
+ )+ |
+
| 294 | ++ | + + | +
| 295 | +4x | +
+ num_pt_year <- control$num_pt_year+ |
+
| 296 | +4x | +
+ list(+ |
+
| 297 | +4x | +
+ rate = est$rate * num_pt_year,+ |
+
| 298 | +4x | +
+ rate_ci = est$rate_ci * num_pt_year+ |
+
| 299 | ++ |
+ )+ |
+
| 300 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Confidence Interval for Mean+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Convenient function for calculating the mean confidence interval. It calculates the arithmetic as well as the+ |
+
| 6 | ++ |
+ #' geometric mean. It can be used as a `ggplot` helper function for plotting.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #' @param n_min (`number`)\cr a minimum number of non-missing `x` to estimate the confidence interval for mean.+ |
+
| 10 | ++ |
+ #' @param gg_helper (`logical`)\cr `TRUE` when output should be aligned for the use with `ggplot`.+ |
+
| 11 | ++ |
+ #' @param geom_mean (`logical`)\cr `TRUE` when the geometric mean should be calculated.+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' @return A named `vector` of values `mean_ci_lwr` and `mean_ci_upr`.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @examples+ |
+
| 16 | ++ |
+ #' stat_mean_ci(sample(10), gg_helper = FALSE)+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) ++ |
+
| 19 | ++ |
+ #' ggplot2::geom_point()+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' p + ggplot2::stat_summary(+ |
+
| 22 | ++ |
+ #' fun.data = stat_mean_ci,+ |
+
| 23 | ++ |
+ #' geom = "errorbar"+ |
+
| 24 | ++ |
+ #' )+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' p + ggplot2::stat_summary(+ |
+
| 27 | ++ |
+ #' fun.data = stat_mean_ci,+ |
+
| 28 | ++ |
+ #' fun.args = list(conf_level = 0.5),+ |
+
| 29 | ++ |
+ #' geom = "errorbar"+ |
+
| 30 | ++ |
+ #' )+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' p + ggplot2::stat_summary(+ |
+
| 33 | ++ |
+ #' fun.data = stat_mean_ci,+ |
+
| 34 | ++ |
+ #' fun.args = list(conf_level = 0.5, geom_mean = TRUE),+ |
+
| 35 | ++ |
+ #' geom = "errorbar"+ |
+
| 36 | ++ |
+ #' )+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' @export+ |
+
| 39 | ++ |
+ stat_mean_ci <- function(x,+ |
+
| 40 | ++ |
+ conf_level = 0.95,+ |
+
| 41 | ++ |
+ na.rm = TRUE, # nolint+ |
+
| 42 | ++ |
+ n_min = 2,+ |
+
| 43 | ++ |
+ gg_helper = TRUE,+ |
+
| 44 | ++ |
+ geom_mean = FALSE) {
+ |
+
| 45 | +664x | +
+ if (na.rm) {
+ |
+
| 46 | +2x | +
+ x <- stats::na.omit(x)+ |
+
| 47 | ++ |
+ }+ |
+
| 48 | +664x | +
+ n <- length(x)+ |
+
| 49 | ++ | + + | +
| 50 | +664x | +
+ if (!geom_mean) {
+ |
+
| 51 | +333x | +
+ m <- mean(x)+ |
+
| 52 | ++ |
+ } else {
+ |
+
| 53 | +331x | +
+ negative_values_exist <- any(is.na(x[!is.na(x)]) <- x[!is.na(x)] <= 0)+ |
+
| 54 | +331x | +
+ if (negative_values_exist) {
+ |
+
| 55 | +22x | +
+ m <- NA_real_+ |
+
| 56 | ++ |
+ } else {
+ |
+
| 57 | +309x | +
+ x <- log(x)+ |
+
| 58 | +309x | +
+ m <- mean(x)+ |
+
| 59 | ++ |
+ }+ |
+
| 60 | ++ |
+ }+ |
+
| 61 | ++ | + + | +
| 62 | +664x | +
+ if (n < n_min || is.na(m)) {
+ |
+
| 63 | +100x | +
+ ci <- c(mean_ci_lwr = NA_real_, mean_ci_upr = NA_real_)+ |
+
| 64 | ++ |
+ } else {
+ |
+
| 65 | +564x | +
+ hci <- stats::qt((1 + conf_level) / 2, df = n - 1) * stats::sd(x) / sqrt(n)+ |
+
| 66 | +564x | +
+ ci <- c(mean_ci_lwr = m - hci, mean_ci_upr = m + hci)+ |
+
| 67 | +564x | +
+ if (geom_mean) {
+ |
+
| 68 | +274x | +
+ ci <- exp(ci)+ |
+
| 69 | ++ |
+ }+ |
+
| 70 | ++ |
+ }+ |
+
| 71 | ++ | + + | +
| 72 | +664x | +
+ if (gg_helper) {
+ |
+
| 73 | +! | +
+ m <- ifelse(is.na(m), NA_real_, m)+ |
+
| 74 | +! | +
+ ci <- data.frame(y = ifelse(geom_mean, exp(m), m), ymin = ci[[1]], ymax = ci[[2]])+ |
+
| 75 | ++ |
+ }+ |
+
| 76 | ++ | + + | +
| 77 | +664x | +
+ return(ci)+ |
+
| 78 | ++ |
+ }+ |
+
| 79 | ++ | + + | +
| 80 | ++ |
+ #' Confidence Interval for Median+ |
+
| 81 | ++ |
+ #'+ |
+
| 82 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 83 | ++ |
+ #'+ |
+
| 84 | ++ |
+ #' Convenient function for calculating the median confidence interval. It can be used as a `ggplot` helper+ |
+
| 85 | ++ |
+ #' function for plotting.+ |
+
| 86 | ++ |
+ #'+ |
+
| 87 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 88 | ++ |
+ #' @param gg_helper (`logical`)\cr `TRUE` when output should be aligned for the use with `ggplot`.+ |
+
| 89 | ++ |
+ #'+ |
+
| 90 | ++ |
+ #' @details The function was adapted from `DescTools/versions/0.99.35/source`+ |
+
| 91 | ++ |
+ #'+ |
+
| 92 | ++ |
+ #' @return A named `vector` of values `median_ci_lwr` and `median_ci_upr`.+ |
+
| 93 | ++ |
+ #'+ |
+
| 94 | ++ |
+ #' @examples+ |
+
| 95 | ++ |
+ #' stat_median_ci(sample(10), gg_helper = FALSE)+ |
+
| 96 | ++ |
+ #'+ |
+
| 97 | ++ |
+ #' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) ++ |
+
| 98 | ++ |
+ #' ggplot2::geom_point()+ |
+
| 99 | ++ |
+ #' p + ggplot2::stat_summary(+ |
+
| 100 | ++ |
+ #' fun.data = stat_median_ci,+ |
+
| 101 | ++ |
+ #' geom = "errorbar"+ |
+
| 102 | ++ |
+ #' )+ |
+
| 103 | ++ |
+ #'+ |
+
| 104 | ++ |
+ #' @export+ |
+
| 105 | ++ |
+ stat_median_ci <- function(x,+ |
+
| 106 | ++ |
+ conf_level = 0.95,+ |
+
| 107 | ++ |
+ na.rm = TRUE, # nolint+ |
+
| 108 | ++ |
+ gg_helper = TRUE) {
+ |
+
| 109 | +334x | +
+ x <- unname(x)+ |
+
| 110 | +334x | +
+ if (na.rm) {
+ |
+
| 111 | +3x | +
+ x <- x[!is.na(x)]+ |
+
| 112 | ++ |
+ }+ |
+
| 113 | +334x | +
+ n <- length(x)+ |
+
| 114 | +334x | +
+ med <- stats::median(x)+ |
+
| 115 | ++ | + + | +
| 116 | +334x | +
+ 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 | +334x | +
+ if (k == 0 || is.na(med)) {
+ |
+
| 120 | +79x | +
+ ci <- c(median_ci_lwr = NA_real_, median_ci_upr = NA_real_)+ |
+
| 121 | +79x | +
+ empir_conf_level <- NA_real_+ |
+
| 122 | ++ |
+ } else {
+ |
+
| 123 | +255x | +
+ x_sort <- sort(x)+ |
+
| 124 | +255x | +
+ ci <- c(median_ci_lwr = x_sort[k], median_ci_upr = x_sort[n - k + 1])+ |
+
| 125 | +255x | +
+ empir_conf_level <- 1 - 2 * stats::pbinom(k - 1, size = n, prob = 0.5)+ |
+
| 126 | ++ |
+ }+ |
+
| 127 | ++ | + + | +
| 128 | +334x | +
+ if (gg_helper) {
+ |
+
| 129 | +! | +
+ ci <- data.frame(y = med, ymin = ci[[1]], ymax = ci[[2]])+ |
+
| 130 | ++ |
+ }+ |
+
| 131 | ++ | + + | +
| 132 | +334x | +
+ attr(ci, "conf_level") <- empir_conf_level+ |
+
| 133 | ++ | + + | +
| 134 | +334x | +
+ return(ci)+ |
+
| 135 | ++ |
+ }+ |
+
| 136 | ++ | + + | +
| 137 | ++ |
+ #' p-Value of the Mean+ |
+
| 138 | ++ |
+ #'+ |
+
| 139 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 140 | ++ |
+ #'+ |
+
| 141 | ++ |
+ #' Convenient function for calculating the two-sided p-value of the mean.+ |
+
| 142 | ++ |
+ #'+ |
+
| 143 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 144 | ++ |
+ #' @param n_min (`numeric`)\cr a minimum number of non-missing `x` to estimate the p-value of the mean.+ |
+
| 145 | ++ |
+ #' @param test_mean (`numeric`)\cr mean value to test under the null hypothesis.+ |
+
| 146 | ++ |
+ #'+ |
+
| 147 | ++ |
+ #' @return A p-value.+ |
+
| 148 | ++ |
+ #'+ |
+
| 149 | ++ |
+ #' @examples+ |
+
| 150 | ++ |
+ #' stat_mean_pval(sample(10))+ |
+
| 151 | ++ |
+ #'+ |
+
| 152 | ++ |
+ #' stat_mean_pval(rnorm(10), test_mean = 0.5)+ |
+
| 153 | ++ |
+ #'+ |
+
| 154 | ++ |
+ #' @export+ |
+
| 155 | ++ |
+ stat_mean_pval <- function(x,+ |
+
| 156 | ++ |
+ na.rm = TRUE, # nolint+ |
+
| 157 | ++ |
+ n_min = 2,+ |
+
| 158 | ++ |
+ test_mean = 0) {
+ |
+
| 159 | +335x | +
+ if (na.rm) {
+ |
+
| 160 | +4x | +
+ x <- stats::na.omit(x)+ |
+
| 161 | ++ |
+ }+ |
+
| 162 | +335x | +
+ n <- length(x)+ |
+
| 163 | ++ | + + | +
| 164 | +335x | +
+ x_mean <- mean(x)+ |
+
| 165 | +335x | +
+ x_sd <- stats::sd(x)+ |
+
| 166 | ++ | + + | +
| 167 | +335x | +
+ if (n < n_min) {
+ |
+
| 168 | +42x | +
+ pv <- c(p_value = NA_real_)+ |
+
| 169 | ++ |
+ } else {
+ |
+
| 170 | +293x | +
+ x_se <- stats::sd(x) / sqrt(n)+ |
+
| 171 | +293x | +
+ ttest <- (x_mean - test_mean) / x_se+ |
+
| 172 | +293x | +
+ pv <- c(p_value = 2 * stats::pt(-abs(ttest), df = n - 1))+ |
+
| 173 | ++ |
+ }+ |
+
| 174 | ++ | + + | +
| 175 | +335x | +
+ return(pv)+ |
+
| 176 | ++ |
+ }+ |
+
| 177 | ++ | + + | +
| 178 | ++ |
+ #' Proportion Difference and Confidence Interval+ |
+
| 179 | ++ |
+ #'+ |
+
| 180 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 181 | ++ |
+ #'+ |
+
| 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+ |
+
| 184 | ++ |
+ #' in arm Y from cumulative incidence in arm X.+ |
+
| 185 | ++ |
+ #'+ |
+
| 186 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 187 | ++ |
+ #' @param x (`list` of `integer`)\cr list of number of occurrences in arm X (reference group).+ |
+
| 188 | ++ |
+ #' @param y (`list` of `integer`)\cr list of number of occurrences in arm Y. Must be of equal length to `x`.+ |
+
| 189 | ++ |
+ #' @param N_x (`numeric`)\cr total number of records in arm X.+ |
+
| 190 | ++ |
+ #' @param N_y (`numeric`)\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 | ++ |
+ #'+ |
+
| 195 | ++ |
+ #' @return List of proportion differences and CIs corresponding to each pair of number of occurrences in `x` and+ |
+
| 196 | ++ |
+ #' `y`. Each list element consists of 3 statistics: proportion difference, CI lower bound, and CI upper bound.+ |
+
| 197 | ++ |
+ #'+ |
+
| 198 | ++ |
+ #' @seealso Split function [add_riskdiff()] which, when used as `split_fun` within [rtables::split_cols_by()]+ |
+
| 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 | ++ |
+ #'+ |
+
| 202 | ++ |
+ #' @examples+ |
+
| 203 | ++ |
+ #' stat_propdiff_ci(+ |
+
| 204 | ++ |
+ #' x = list(0.375), y = list(0.01), N_x = 5, N_y = 5, list_names = "x", conf_level = 0.9+ |
+
| 205 | ++ |
+ #' )+ |
+
| 206 | ++ |
+ #'+ |
+
| 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+ |
+
| 212 | ++ |
+ stat_propdiff_ci <- function(x,+ |
+
| 213 | ++ |
+ y,+ |
+
| 214 | ++ |
+ N_x, # nolint+ |
+
| 215 | ++ |
+ N_y, # nolint+ |
+
| 216 | ++ |
+ list_names = NULL,+ |
+
| 217 | ++ |
+ conf_level = 0.95,+ |
+
| 218 | ++ |
+ pct = TRUE) {
+ |
+
| 219 | +11x | +
+ checkmate::assert_list(x, types = "numeric")+ |
+
| 220 | +11x | +
+ checkmate::assert_list(y, types = "numeric", len = length(x))+ |
+
| 221 | +11x | +
+ checkmate::assert_character(list_names, len = length(x), null.ok = TRUE)+ |
+
| 222 | +11x | +
+ rd_list <- lapply(seq_along(x), function(i) {
+ |
+
| 223 | +25x | +
+ p_x <- x[[i]] / N_x+ |
+
| 224 | +25x | +
+ p_y <- y[[i]] / N_y+ |
+
| 225 | +25x | +
+ rd_ci <- p_x - p_y + c(-1, 1) * stats::qnorm((1 + conf_level) / 2) *+ |
+
| 226 | +25x | +
+ sqrt(p_x * (1 - p_x) / N_x + p_y * (1 - p_y) / N_y)+ |
+
| 227 | +25x | +
+ c(p_x - p_y, rd_ci) * ifelse(pct, 100, 1)+ |
+
| 228 | ++ |
+ })+ |
+
| 229 | +11x | +
+ names(rd_list) <- list_names+ |
+
| 230 | +11x | +
+ rd_list+ |
+
| 231 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Summarize the Change from Baseline or Absolute Baseline Values+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' The primary analysis variable `.var` indicates the numerical change from baseline results,+ |
+
| 6 | ++ |
+ #' and additional required secondary analysis variables are `value` and `baseline_flag`.+ |
+
| 7 | ++ |
+ #' Depending on the baseline flag, either the absolute baseline values (at baseline)+ |
+
| 8 | ++ |
+ #' or the change from baseline values (post-baseline) are then summarized.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @name summarize_change+ |
+
| 13 | ++ |
+ NULL+ |
+
| 14 | ++ | + + | +
| 15 | ++ |
+ #' @describeIn summarize_change Statistics function that summarizes baseline or post-baseline visits.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @return+ |
+
| 18 | ++ |
+ #' * `s_change_from_baseline()` returns the same values returned by [s_summary.numeric()].+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @note The data in `df` must be either all be from baseline or post-baseline visits. Otherwise+ |
+
| 21 | ++ |
+ #' an error will be thrown.+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @examples+ |
+
| 24 | ++ |
+ #' df <- data.frame(+ |
+
| 25 | ++ |
+ #' chg = c(1, 2, 3),+ |
+
| 26 | ++ |
+ #' is_bl = c(TRUE, TRUE, TRUE),+ |
+
| 27 | ++ |
+ #' val = c(4, 5, 6)+ |
+
| 28 | ++ |
+ #' )+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' @keywords internal+ |
+
| 31 | ++ |
+ s_change_from_baseline <- function(df,+ |
+
| 32 | ++ |
+ .var,+ |
+
| 33 | ++ |
+ variables,+ |
+
| 34 | ++ |
+ na.rm = TRUE, # nolint+ |
+
| 35 | ++ |
+ ...) {
+ |
+
| 36 | +4x | +
+ checkmate::assert_numeric(df[[variables$value]])+ |
+
| 37 | +4x | +
+ checkmate::assert_numeric(df[[.var]])+ |
+
| 38 | +4x | +
+ checkmate::assert_logical(df[[variables$baseline_flag]])+ |
+
| 39 | +4x | +
+ checkmate::assert_vector(unique(df[[variables$baseline_flag]]), max.len = 1)+ |
+
| 40 | +4x | +
+ assert_df_with_variables(df, c(variables, list(chg = .var)))+ |
+
| 41 | ++ | + + | +
| 42 | +4x | +
+ combined <- ifelse(+ |
+
| 43 | +4x | +
+ df[[variables$baseline_flag]],+ |
+
| 44 | +4x | +
+ df[[variables$value]],+ |
+
| 45 | +4x | +
+ df[[.var]]+ |
+
| 46 | ++ |
+ )+ |
+
| 47 | +4x | +
+ if (is.logical(combined) && identical(length(combined), 0L)) {
+ |
+
| 48 | +1x | +
+ combined <- numeric(0)+ |
+
| 49 | ++ |
+ }+ |
+
| 50 | +4x | +
+ s_summary(combined, na.rm = na.rm, ...)+ |
+
| 51 | ++ |
+ }+ |
+
| 52 | ++ | + + | +
| 53 | ++ |
+ #' @describeIn summarize_change Formatted analysis function which is used as `afun` in `summarize_change()`.+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' @return+ |
+
| 56 | ++ |
+ #' * `a_change_from_baseline()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 57 | ++ |
+ #'+ |
+
| 58 | ++ |
+ #'+ |
+
| 59 | ++ |
+ #' @keywords internal+ |
+
| 60 | ++ |
+ a_change_from_baseline <- make_afun(+ |
+
| 61 | ++ |
+ s_change_from_baseline,+ |
+
| 62 | ++ |
+ .formats = c(+ |
+
| 63 | ++ |
+ n = "xx",+ |
+
| 64 | ++ |
+ mean_sd = "xx.xx (xx.xx)",+ |
+
| 65 | ++ |
+ mean_se = "xx.xx (xx.xx)",+ |
+
| 66 | ++ |
+ median = "xx.xx",+ |
+
| 67 | ++ |
+ range = "xx.xx - xx.xx",+ |
+
| 68 | ++ |
+ mean_ci = "(xx.xx, xx.xx)",+ |
+
| 69 | ++ |
+ median_ci = "(xx.xx, xx.xx)",+ |
+
| 70 | ++ |
+ mean_pval = "xx.xx"+ |
+
| 71 | ++ |
+ ),+ |
+
| 72 | ++ |
+ .labels = c(+ |
+
| 73 | ++ |
+ mean_sd = "Mean (SD)",+ |
+
| 74 | ++ |
+ mean_se = "Mean (SE)",+ |
+
| 75 | ++ |
+ median = "Median",+ |
+
| 76 | ++ |
+ range = "Min - Max"+ |
+
| 77 | ++ |
+ )+ |
+
| 78 | ++ |
+ )+ |
+
| 79 | ++ | + + | +
| 80 | ++ |
+ #' @describeIn summarize_change Layout-creating function which can take statistics function arguments+ |
+
| 81 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 82 | ++ |
+ #'+ |
+
| 83 | ++ |
+ #' @return+ |
+
| 84 | ++ |
+ #' * `summarize_change()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 85 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 86 | ++ |
+ #' the statistics from `s_change_from_baseline()` to the table layout.+ |
+
| 87 | ++ |
+ #'+ |
+
| 88 | ++ |
+ #' @note To be used after a split on visits in the layout, such that each data subset only contains+ |
+
| 89 | ++ |
+ #' either baseline or post-baseline data.+ |
+
| 90 | ++ |
+ #'+ |
+
| 91 | ++ |
+ #' @examples+ |
+
| 92 | ++ |
+ #' # `summarize_change()`+ |
+
| 93 | ++ |
+ #'+ |
+
| 94 | ++ |
+ #' ## Fabricated dataset.+ |
+
| 95 | ++ |
+ #' library(dplyr)+ |
+
| 96 | ++ |
+ #'+ |
+
| 97 | ++ |
+ #' dta_test <- data.frame(+ |
+
| 98 | ++ |
+ #' USUBJID = rep(1:6, each = 3),+ |
+
| 99 | ++ |
+ #' AVISIT = rep(paste0("V", 1:3), 6),
+ |
+
| 100 | ++ |
+ #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ |
+
| 101 | ++ |
+ #' AVAL = c(9:1, rep(NA, 9))+ |
+
| 102 | ++ |
+ #' ) %>%+ |
+
| 103 | ++ |
+ #' mutate(ABLFLL = AVISIT == "V1") %>%+ |
+
| 104 | ++ |
+ #' group_by(USUBJID) %>%+ |
+
| 105 | ++ |
+ #' mutate(+ |
+
| 106 | ++ |
+ #' BLVAL = AVAL[ABLFLL],+ |
+
| 107 | ++ |
+ #' CHG = AVAL - BLVAL+ |
+
| 108 | ++ |
+ #' ) %>%+ |
+
| 109 | ++ |
+ #' ungroup()+ |
+
| 110 | ++ |
+ #'+ |
+
| 111 | ++ |
+ #' results <- basic_table() %>%+ |
+
| 112 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 113 | ++ |
+ #' split_rows_by("AVISIT") %>%
+ |
+
| 114 | ++ |
+ #' summarize_change("CHG", variables = list(value = "AVAL", baseline_flag = "ABLFLL")) %>%
+ |
+
| 115 | ++ |
+ #' build_table(dta_test)+ |
+
| 116 | ++ |
+ #' \donttest{
+ |
+
| 117 | ++ |
+ #' Viewer(results)+ |
+
| 118 | ++ |
+ #' }+ |
+
| 119 | ++ |
+ #'+ |
+
| 120 | ++ |
+ #' @export+ |
+
| 121 | ++ |
+ summarize_change <- function(lyt,+ |
+
| 122 | ++ |
+ vars,+ |
+
| 123 | ++ |
+ na_str = NA_character_,+ |
+
| 124 | ++ |
+ nested = TRUE,+ |
+
| 125 | ++ |
+ ...,+ |
+
| 126 | ++ |
+ table_names = vars,+ |
+
| 127 | ++ |
+ .stats = c("n", "mean_sd", "median", "range"),
+ |
+
| 128 | ++ |
+ .formats = NULL,+ |
+
| 129 | ++ |
+ .labels = NULL,+ |
+
| 130 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 131 | +1x | +
+ afun <- make_afun(+ |
+
| 132 | +1x | +
+ a_change_from_baseline,+ |
+
| 133 | +1x | +
+ .stats = .stats,+ |
+
| 134 | +1x | +
+ .formats = .formats,+ |
+
| 135 | +1x | +
+ .labels = .labels,+ |
+
| 136 | +1x | +
+ .indent_mods = .indent_mods+ |
+
| 137 | ++ |
+ )+ |
+
| 138 | ++ | + + | +
| 139 | +1x | +
+ analyze(+ |
+
| 140 | +1x | +
+ lyt,+ |
+
| 141 | +1x | +
+ vars,+ |
+
| 142 | +1x | +
+ afun = afun,+ |
+
| 143 | +1x | +
+ na_str = na_str,+ |
+
| 144 | +1x | +
+ nested = nested,+ |
+
| 145 | +1x | +
+ extra_args = list(...),+ |
+
| 146 | +1x | +
+ table_names = table_names+ |
+
| 147 | ++ |
+ )+ |
+
| 148 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Occurrence Table Pruning+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Family of constructor and condition functions to flexibly prune occurrence tables.+ |
+
| 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+ |
+
| 8 | ++ |
+ #' functions.+ |
+
| 9 | ++ |
+ #'+ |
+
| 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+ |
+
| 12 | ++ |
+ #' should be pruned, to conform with the [rtables::prune_table()] interface.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @examples+ |
+
| 15 | ++ |
+ #' \donttest{
+ |
+
| 16 | ++ |
+ #' tab <- basic_table() %>%+ |
+
| 17 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 18 | ++ |
+ #' split_rows_by("RACE") %>%
+ |
+
| 19 | ++ |
+ #' split_rows_by("STRATA1") %>%
+ |
+
| 20 | ++ |
+ #' summarize_row_groups() %>%+ |
+
| 21 | ++ |
+ #' analyze_vars("COUNTRY", .stats = "count_fraction") %>%
+ |
+
| 22 | ++ |
+ #' build_table(DM)+ |
+
| 23 | ++ |
+ #' }+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @name prune_occurrences+ |
+
| 26 | ++ |
+ NULL+ |
+
| 27 | ++ | + + | +
| 28 | ++ |
+ #' @describeIn prune_occurrences Constructor for creating pruning functions based on+ |
+
| 29 | ++ |
+ #' a row condition function. This removes all analysis rows (`TableRow`) that should be+ |
+
| 30 | ++ |
+ #' pruned, i.e., don't fulfill the row condition. It removes the sub-tree if there are no+ |
+
| 31 | ++ |
+ #' children left.+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' @param row_condition (`CombinationFunction`)\cr condition function which works on individual+ |
+
| 34 | ++ |
+ #' analysis rows and flags whether these should be kept in the pruned table.+ |
+
| 35 | ++ |
+ #'+ |
+
| 36 | ++ |
+ #' @return+ |
+
| 37 | ++ |
+ #' * `keep_rows()` returns a pruning function that can be used with [rtables::prune_table()]+ |
+
| 38 | ++ |
+ #' to prune an `rtables` table.+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' @examples+ |
+
| 41 | ++ |
+ #' \donttest{
+ |
+
| 42 | ++ |
+ #' # `keep_rows`+ |
+
| 43 | ++ |
+ #' is_non_empty <- !CombinationFunction(all_zero_or_na)+ |
+
| 44 | ++ |
+ #' prune_table(tab, keep_rows(is_non_empty))+ |
+
| 45 | ++ |
+ #' }+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ #' @export+ |
+
| 48 | ++ |
+ keep_rows <- function(row_condition) {
+ |
+
| 49 | +6x | +
+ checkmate::assert_function(row_condition)+ |
+
| 50 | +6x | +
+ function(table_tree) {
+ |
+
| 51 | +2256x | +
+ if (inherits(table_tree, "TableRow")) {
+ |
+
| 52 | +1872x | +
+ return(!row_condition(table_tree))+ |
+
| 53 | ++ |
+ }+ |
+
| 54 | +384x | +
+ children <- tree_children(table_tree)+ |
+
| 55 | +384x | +
+ identical(length(children), 0L)+ |
+
| 56 | ++ |
+ }+ |
+
| 57 | ++ |
+ }+ |
+
| 58 | ++ | + + | +
| 59 | ++ |
+ #' @describeIn prune_occurrences Constructor for creating pruning functions based on+ |
+
| 60 | ++ |
+ #' a condition for the (first) content row in leaf tables. This removes all leaf tables where+ |
+
| 61 | ++ |
+ #' the first content row does not fulfill the condition. It does not check individual rows.+ |
+
| 62 | ++ |
+ #' It then proceeds recursively by removing the sub tree if there are no children left.+ |
+
| 63 | ++ |
+ #'+ |
+
| 64 | ++ |
+ #' @param content_row_condition (`CombinationFunction`)\cr condition function which works on individual+ |
+
| 65 | ++ |
+ #' first content rows of leaf tables and flags whether these leaf tables should be kept in the pruned table.+ |
+
| 66 | ++ |
+ #'+ |
+
| 67 | ++ |
+ #' @return+ |
+
| 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 | ++ |
+ #'+ |
+
| 71 | ++ |
+ #' @examples+ |
+
| 72 | ++ |
+ #' # `keep_content_rows`+ |
+
| 73 | ++ |
+ #' \donttest{
+ |
+
| 74 | ++ |
+ #' more_than_twenty <- has_count_in_cols(atleast = 20L, col_names = names(tab))+ |
+
| 75 | ++ |
+ #' prune_table(tab, keep_content_rows(more_than_twenty))+ |
+
| 76 | ++ |
+ #' }+ |
+
| 77 | ++ |
+ #'+ |
+
| 78 | ++ |
+ #' @export+ |
+
| 79 | ++ |
+ keep_content_rows <- function(content_row_condition) {
+ |
+
| 80 | +1x | +
+ checkmate::assert_function(content_row_condition)+ |
+
| 81 | +1x | +
+ function(table_tree) {
+ |
+
| 82 | +166x | +
+ if (is_leaf_table(table_tree)) {
+ |
+
| 83 | +24x | +
+ content_row <- h_content_first_row(table_tree)+ |
+
| 84 | +24x | +
+ return(!content_row_condition(content_row))+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | +142x | +
+ if (inherits(table_tree, "DataRow")) {
+ |
+
| 87 | +120x | +
+ return(FALSE)+ |
+
| 88 | ++ |
+ }+ |
+
| 89 | +22x | +
+ children <- tree_children(table_tree)+ |
+
| 90 | +22x | +
+ identical(length(children), 0L)+ |
+
| 91 | ++ |
+ }+ |
+
| 92 | ++ |
+ }+ |
+
| 93 | ++ | + + | +
| 94 | ++ |
+ #' @describeIn prune_occurrences Constructor for creating condition functions on total counts in the specified columns.+ |
+
| 95 | ++ |
+ #'+ |
+
| 96 | ++ |
+ #' @param atleast (`count` or `proportion`)\cr threshold which should be met in order to keep the row.+ |
+
| 97 | ++ |
+ #' @param ... arguments for row or column access, see [`rtables_access`]: either `col_names` (`character`) including+ |
+
| 98 | ++ |
+ #' the names of the columns which should be used, or alternatively `col_indices` (`integer`) giving the indices+ |
+
| 99 | ++ |
+ #' directly instead.+ |
+
| 100 | ++ |
+ #'+ |
+
| 101 | ++ |
+ #' @return+ |
+
| 102 | ++ |
+ #' * `has_count_in_cols()` returns a condition function that sums the counts in the specified column.+ |
+
| 103 | ++ |
+ #'+ |
+
| 104 | ++ |
+ #' @examples+ |
+
| 105 | ++ |
+ #' \donttest{
+ |
+
| 106 | ++ |
+ #' more_than_one <- has_count_in_cols(atleast = 1L, col_names = names(tab))+ |
+
| 107 | ++ |
+ #' prune_table(tab, keep_rows(more_than_one))+ |
+
| 108 | ++ |
+ #' }+ |
+
| 109 | ++ |
+ #'+ |
+
| 110 | ++ |
+ #' @export+ |
+
| 111 | ++ |
+ has_count_in_cols <- function(atleast, ...) {
+ |
+
| 112 | +3x | +
+ checkmate::assert_count(atleast)+ |
+
| 113 | +3x | +
+ CombinationFunction(function(table_row) {
+ |
+
| 114 | +334x | +
+ row_counts <- h_row_counts(table_row, ...)+ |
+
| 115 | +334x | +
+ total_count <- sum(row_counts)+ |
+
| 116 | +334x | +
+ total_count >= atleast+ |
+
| 117 | ++ |
+ })+ |
+
| 118 | ++ |
+ }+ |
+
| 119 | ++ | + + | +
| 120 | ++ |
+ #' @describeIn prune_occurrences Constructor for creating condition functions on any of the counts in+ |
+
| 121 | ++ |
+ #' the specified columns satisfying a threshold.+ |
+
| 122 | ++ |
+ #'+ |
+
| 123 | ++ |
+ #' @param atleast (`count` or `proportion`)\cr threshold which should be met in order to keep the row.+ |
+
| 124 | ++ |
+ #'+ |
+
| 125 | ++ |
+ #' @return+ |
+
| 126 | ++ |
+ #' * `has_count_in_any_col()` returns a condition function that compares the counts in the+ |
+
| 127 | ++ |
+ #' specified columns with the threshold.+ |
+
| 128 | ++ |
+ #'+ |
+
| 129 | ++ |
+ #' @examples+ |
+
| 130 | ++ |
+ #' \donttest{
+ |
+
| 131 | ++ |
+ #' # `has_count_in_any_col`+ |
+
| 132 | ++ |
+ #' any_more_than_one <- has_count_in_any_col(atleast = 1L, col_names = names(tab))+ |
+
| 133 | ++ |
+ #' prune_table(tab, keep_rows(any_more_than_one))+ |
+
| 134 | ++ |
+ #' }+ |
+
| 135 | ++ |
+ #'+ |
+
| 136 | ++ |
+ #' @export+ |
+
| 137 | ++ |
+ has_count_in_any_col <- function(atleast, ...) {
+ |
+
| 138 | +! | +
+ checkmate::assert_count(atleast)+ |
+
| 139 | +! | +
+ CombinationFunction(function(table_row) {
+ |
+
| 140 | +! | +
+ row_counts <- h_row_counts(table_row, ...)+ |
+
| 141 | +! | +
+ any(row_counts >= atleast)+ |
+
| 142 | ++ |
+ })+ |
+
| 143 | ++ |
+ }+ |
+
| 144 | ++ | + + | +
| 145 | ++ |
+ #' @describeIn prune_occurrences Constructor for creating condition functions on total fraction in+ |
+
| 146 | ++ |
+ #' the specified columns.+ |
+
| 147 | ++ |
+ #'+ |
+
| 148 | ++ |
+ #' @return+ |
+
| 149 | ++ |
+ #' * `has_fraction_in_cols()` returns a condition function that sums the counts in the+ |
+
| 150 | ++ |
+ #' specified column, and computes the fraction by dividing by the total column counts.+ |
+
| 151 | ++ |
+ #'+ |
+
| 152 | ++ |
+ #' @examples+ |
+
| 153 | ++ |
+ #' \donttest{
+ |
+
| 154 | ++ |
+ #' # `has_fraction_in_cols`+ |
+
| 155 | ++ |
+ #' more_than_five_percent <- has_fraction_in_cols(atleast = 0.05, col_names = names(tab))+ |
+
| 156 | ++ |
+ #' prune_table(tab, keep_rows(more_than_five_percent))+ |
+
| 157 | ++ |
+ #' }+ |
+
| 158 | ++ |
+ #'+ |
+
| 159 | ++ |
+ #' @export+ |
+
| 160 | ++ |
+ has_fraction_in_cols <- function(atleast, ...) {
+ |
+
| 161 | +1x | +
+ assert_proportion_value(atleast, include_boundaries = TRUE)+ |
+
| 162 | +1x | +
+ CombinationFunction(function(table_row) {
+ |
+
| 163 | +303x | +
+ row_counts <- h_row_counts(table_row, ...)+ |
+
| 164 | +303x | +
+ total_count <- sum(row_counts)+ |
+
| 165 | +303x | +
+ col_counts <- h_col_counts(table_row, ...)+ |
+
| 166 | +303x | +
+ total_n <- sum(col_counts)+ |
+
| 167 | +303x | +
+ total_percent <- total_count / total_n+ |
+
| 168 | +303x | +
+ total_percent >= atleast+ |
+
| 169 | ++ |
+ })+ |
+
| 170 | ++ |
+ }+ |
+
| 171 | ++ | + + | +
| 172 | ++ |
+ #' @describeIn prune_occurrences Constructor for creating condition functions on any fraction in+ |
+
| 173 | ++ |
+ #' the specified columns.+ |
+
| 174 | ++ |
+ #'+ |
+
| 175 | ++ |
+ #' @return+ |
+
| 176 | ++ |
+ #' * `has_fraction_in_any_col()` returns a condition function that looks at the fractions+ |
+
| 177 | ++ |
+ #' in the specified columns and checks whether any of them fulfill the threshold.+ |
+
| 178 | ++ |
+ #'+ |
+
| 179 | ++ |
+ #' @examples+ |
+
| 180 | ++ |
+ #' \donttest{
+ |
+
| 181 | ++ |
+ #' # `has_fraction_in_any_col`+ |
+
| 182 | ++ |
+ #' any_atleast_five_percent <- has_fraction_in_any_col(atleast = 0.05, col_names = names(tab))+ |
+
| 183 | ++ |
+ #' prune_table(tab, keep_rows(more_than_five_percent))+ |
+
| 184 | ++ |
+ #' }+ |
+
| 185 | ++ |
+ #'+ |
+
| 186 | ++ |
+ #' @export+ |
+
| 187 | ++ |
+ has_fraction_in_any_col <- function(atleast, ...) {
+ |
+
| 188 | +! | +
+ assert_proportion_value(atleast, include_boundaries = TRUE)+ |
+
| 189 | +! | +
+ CombinationFunction(function(table_row) {
+ |
+
| 190 | +! | +
+ row_fractions <- h_row_fractions(table_row, ...)+ |
+
| 191 | +! | +
+ any(row_fractions >= atleast)+ |
+
| 192 | ++ |
+ })+ |
+
| 193 | ++ |
+ }+ |
+
| 194 | ++ | + + | +
| 195 | ++ |
+ #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference+ |
+
| 196 | ++ |
+ #' between the fractions reported in each specified column.+ |
+
| 197 | ++ |
+ #'+ |
+
| 198 | ++ |
+ #' @return+ |
+
| 199 | ++ |
+ #' * `has_fractions_difference()` returns a condition function that extracts the fractions of each+ |
+
| 200 | ++ |
+ #' specified column, and computes the difference of the minimum and maximum.+ |
+
| 201 | ++ |
+ #'+ |
+
| 202 | ++ |
+ #' @examples+ |
+
| 203 | ++ |
+ #' \donttest{
+ |
+
| 204 | ++ |
+ #' # `has_fractions_difference`+ |
+
| 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))+ |
+
| 207 | ++ |
+ #' }+ |
+
| 208 | ++ |
+ #'+ |
+
| 209 | ++ |
+ #' @export+ |
+
| 210 | ++ |
+ has_fractions_difference <- function(atleast, ...) {
+ |
+
| 211 | +1x | +
+ assert_proportion_value(atleast, include_boundaries = TRUE)+ |
+
| 212 | +1x | +
+ CombinationFunction(function(table_row) {
+ |
+
| 213 | +243x | +
+ fractions <- h_row_fractions(table_row, ...)+ |
+
| 214 | +243x | +
+ difference <- diff(range(fractions))+ |
+
| 215 | +243x | +
+ difference >= atleast+ |
+
| 216 | ++ |
+ })+ |
+
| 217 | ++ |
+ }+ |
+
| 218 | ++ | + + | +
| 219 | ++ |
+ #' @describeIn prune_occurrences Constructor for creating condition function that checks the difference+ |
+
| 220 | ++ |
+ #' between the counts reported in each specified column.+ |
+
| 221 | ++ |
+ #'+ |
+
| 222 | ++ |
+ #' @return+ |
+
| 223 | ++ |
+ #' * `has_counts_difference()` returns a condition function that extracts the counts of each+ |
+
| 224 | ++ |
+ #' specified column, and computes the difference of the minimum and maximum.+ |
+
| 225 | ++ |
+ #'+ |
+
| 226 | ++ |
+ #' @examples+ |
+
| 227 | ++ |
+ #' \donttest{
+ |
+
| 228 | ++ |
+ #' more_than_one_diff <- has_counts_difference(atleast = 1L, col_names = names(tab))+ |
+
| 229 | ++ |
+ #' prune_table(tab, keep_rows(more_than_one_diff))+ |
+
| 230 | ++ |
+ #' }+ |
+
| 231 | ++ |
+ #'+ |
+
| 232 | ++ |
+ #' @export+ |
+
| 233 | ++ |
+ has_counts_difference <- function(atleast, ...) {
+ |
+
| 234 | +1x | +
+ checkmate::assert_count(atleast)+ |
+
| 235 | +1x | +
+ CombinationFunction(function(table_row) {
+ |
+
| 236 | +27x | +
+ counts <- h_row_counts(table_row, ...)+ |
+
| 237 | +27x | +
+ difference <- diff(range(counts))+ |
+
| 238 | +27x | +
+ difference >= atleast+ |
+
| 239 | ++ |
+ })+ |
+
| 240 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' `rtables` Access Helper Functions+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' These are a couple of functions that help with accessing the data in `rtables` objects.+ |
+
| 6 | ++ |
+ #' Currently these work for occurrence tables, which are defined as having a count as the first+ |
+
| 7 | ++ |
+ #' element and a fraction as the second element in each cell.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @seealso [prune_occurrences] for usage of these functions.+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @name rtables_access+ |
+
| 12 | ++ |
+ NULL+ |
+
| 13 | ++ | + + | +
| 14 | ++ |
+ #' @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 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @param table_row (`TableRow`)\cr an analysis row in a occurrence table.+ |
+
| 18 | ++ |
+ #' @param col_names (`character`)\cr the names of the columns to extract from.+ |
+
| 19 | ++ |
+ #' @param col_indices (`integer`)\cr the indices of the columns to extract from. If `col_names` are provided,+ |
+
| 20 | ++ |
+ #' then these are inferred from the names of `table_row`. Note that this currently only works well with a single+ |
+
| 21 | ++ |
+ #' column split.+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @return+ |
+
| 24 | ++ |
+ #' * `h_row_first_values()` returns a `vector` of numeric values.+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' @examples+ |
+
| 27 | ++ |
+ #' tbl <- basic_table() %>%+ |
+
| 28 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 29 | ++ |
+ #' split_rows_by("RACE") %>%
+ |
+
| 30 | ++ |
+ #' analyze("AGE", function(x) {
+ |
+
| 31 | ++ |
+ #' list(+ |
+
| 32 | ++ |
+ #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.x (xx.x)"),+ |
+
| 33 | ++ |
+ #' "n" = length(x),+ |
+
| 34 | ++ |
+ #' "frac" = rcell(c(0.1, 0.1), format = "xx (xx)")+ |
+
| 35 | ++ |
+ #' )+ |
+
| 36 | ++ |
+ #' }) %>%+ |
+
| 37 | ++ |
+ #' build_table(tern_ex_adsl) %>%+ |
+
| 38 | ++ |
+ #' prune_table()+ |
+
| 39 | ++ |
+ #' tree_row_elem <- collect_leaves(tbl[2, ])[[1]]+ |
+
| 40 | ++ |
+ #' result <- max(h_row_first_values(tree_row_elem))+ |
+
| 41 | ++ |
+ #' result+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' @export+ |
+
| 44 | ++ |
+ h_row_first_values <- function(table_row,+ |
+
| 45 | ++ |
+ col_names = NULL,+ |
+
| 46 | ++ |
+ col_indices = NULL) {
+ |
+
| 47 | +727x | +
+ col_indices <- check_names_indices(table_row, col_names, col_indices)+ |
+
| 48 | +727x | +
+ checkmate::assert_integerish(col_indices)+ |
+
| 49 | +727x | +
+ checkmate::assert_subset(col_indices, seq_len(ncol(table_row)))+ |
+
| 50 | ++ | + + | +
| 51 | ++ |
+ # Main values are extracted+ |
+
| 52 | +727x | +
+ row_vals <- row_values(table_row)[col_indices]+ |
+
| 53 | ++ | + + | +
| 54 | ++ |
+ # Main return+ |
+
| 55 | +727x | +
+ vapply(row_vals, function(rv) {
+ |
+
| 56 | +2066x | +
+ if (is.null(rv)) {
+ |
+
| 57 | +727x | +
+ NA_real_+ |
+
| 58 | ++ |
+ } else {
+ |
+
| 59 | +2063x | +
+ rv[1L]+ |
+
| 60 | ++ |
+ }+ |
+
| 61 | +727x | +
+ }, FUN.VALUE = numeric(1))+ |
+
| 62 | ++ |
+ }+ |
+
| 63 | ++ | + + | +
| 64 | ++ |
+ #' @describeIn rtables_access Helper function that extracts row values and checks if they are+ |
+
| 65 | ++ |
+ #' convertible to integers (`integerish` values).+ |
+
| 66 | ++ |
+ #'+ |
+
| 67 | ++ |
+ #' @return+ |
+
| 68 | ++ |
+ #' * `h_row_counts()` returns a `vector` of numeric values.+ |
+
| 69 | ++ |
+ #'+ |
+
| 70 | ++ |
+ #' @examples+ |
+
| 71 | ++ |
+ #' # Row counts (integer values)+ |
+
| 72 | ++ |
+ #' # h_row_counts(tree_row_elem) # Fails because there are no integers+ |
+
| 73 | ++ |
+ #' # Using values with integers+ |
+
| 74 | ++ |
+ #' tree_row_elem <- collect_leaves(tbl[3, ])[[1]]+ |
+
| 75 | ++ |
+ #' result <- h_row_counts(tree_row_elem)+ |
+
| 76 | ++ |
+ #' # result+ |
+
| 77 | ++ |
+ #'+ |
+
| 78 | ++ |
+ #' @export+ |
+
| 79 | ++ |
+ h_row_counts <- function(table_row,+ |
+
| 80 | ++ |
+ col_names = NULL,+ |
+
| 81 | ++ |
+ col_indices = NULL) {
+ |
+
| 82 | +727x | +
+ counts <- h_row_first_values(table_row, col_names, col_indices)+ |
+
| 83 | +727x | +
+ checkmate::assert_integerish(counts)+ |
+
| 84 | +727x | +
+ counts+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | ++ | + + | +
| 87 | ++ |
+ #' @describeIn rtables_access helper function to extract fractions from specified columns in a `TableRow`.+ |
+
| 88 | ++ |
+ #' More specifically it extracts the second values from each content cell and checks it is a fraction.+ |
+
| 89 | ++ |
+ #'+ |
+
| 90 | ++ |
+ #' @return+ |
+
| 91 | ++ |
+ #' * `h_row_fractions()` returns a `vector` of proportions.+ |
+
| 92 | ++ |
+ #'+ |
+
| 93 | ++ |
+ #' @examples+ |
+
| 94 | ++ |
+ #' # Row fractions+ |
+
| 95 | ++ |
+ #' tree_row_elem <- collect_leaves(tbl[4, ])[[1]]+ |
+
| 96 | ++ |
+ #' h_row_fractions(tree_row_elem)+ |
+
| 97 | ++ |
+ #'+ |
+
| 98 | ++ |
+ #' @export+ |
+
| 99 | ++ |
+ h_row_fractions <- function(table_row,+ |
+
| 100 | ++ |
+ col_names = NULL,+ |
+
| 101 | ++ |
+ col_indices = NULL) {
+ |
+
| 102 | +243x | +
+ col_indices <- check_names_indices(table_row, col_names, col_indices)+ |
+
| 103 | +243x | +
+ row_vals <- row_values(table_row)[col_indices]+ |
+
| 104 | +243x | +
+ fractions <- sapply(row_vals, "[", 2L)+ |
+
| 105 | +243x | +
+ checkmate::assert_numeric(fractions, lower = 0, upper = 1)+ |
+
| 106 | +243x | +
+ fractions+ |
+
| 107 | ++ |
+ }+ |
+
| 108 | ++ | + + | +
| 109 | ++ |
+ #' @describeIn rtables_access Helper function to extract column counts from specified columns in a table.+ |
+
| 110 | ++ |
+ #'+ |
+
| 111 | ++ |
+ #' @param table (`VTableNodeInfo`)\cr an occurrence table or row.+ |
+
| 112 | ++ |
+ #'+ |
+
| 113 | ++ |
+ #' @return+ |
+
| 114 | ++ |
+ #' * `h_col_counts()` returns a `vector` of column counts.+ |
+
| 115 | ++ |
+ #'+ |
+
| 116 | ++ |
+ #' @export+ |
+
| 117 | ++ |
+ h_col_counts <- function(table,+ |
+
| 118 | ++ |
+ col_names = NULL,+ |
+
| 119 | ++ |
+ col_indices = NULL) {
+ |
+
| 120 | +304x | +
+ col_indices <- check_names_indices(table, col_names, col_indices)+ |
+
| 121 | +304x | +
+ counts <- col_counts(table)[col_indices]+ |
+
| 122 | +304x | +
+ stats::setNames(counts, col_names)+ |
+
| 123 | ++ |
+ }+ |
+
| 124 | ++ | + + | +
| 125 | ++ |
+ #' @describeIn rtables_access Helper function to get first row of content table of current table.+ |
+
| 126 | ++ |
+ #'+ |
+
| 127 | ++ |
+ #' @return+ |
+
| 128 | ++ |
+ #' * `h_content_first_row()` returns a row from an `rtables` table.+ |
+
| 129 | ++ |
+ #'+ |
+
| 130 | ++ |
+ #' @export+ |
+
| 131 | ++ |
+ h_content_first_row <- function(table) {
+ |
+
| 132 | +27x | +
+ ct <- content_table(table)+ |
+
| 133 | +27x | +
+ tree_children(ct)[[1]]+ |
+
| 134 | ++ |
+ }+ |
+
| 135 | ++ | + + | +
| 136 | ++ |
+ #' @describeIn rtables_access Helper function which says whether current table is a leaf in the tree.+ |
+
| 137 | ++ |
+ #'+ |
+
| 138 | ++ |
+ #' @return+ |
+
| 139 | ++ |
+ #' * `is_leaf_table()` returns a `logical` value indicating whether current table is a leaf.+ |
+
| 140 | ++ |
+ #'+ |
+
| 141 | ++ |
+ #' @keywords internal+ |
+
| 142 | ++ |
+ is_leaf_table <- function(table) {
+ |
+
| 143 | +168x | +
+ children <- tree_children(table)+ |
+
| 144 | +168x | +
+ child_classes <- unique(sapply(children, class))+ |
+
| 145 | +168x | +
+ identical(child_classes, "ElementaryTable")+ |
+
| 146 | ++ |
+ }+ |
+
| 147 | ++ | + + | +
| 148 | ++ |
+ #' @describeIn rtables_access Internal helper function that tests standard inputs for column indices.+ |
+
| 149 | ++ |
+ #'+ |
+
| 150 | ++ |
+ #' @return+ |
+
| 151 | ++ |
+ #' * `check_names_indices` returns column indices.+ |
+
| 152 | ++ |
+ #'+ |
+
| 153 | ++ |
+ #' @keywords internal+ |
+
| 154 | ++ |
+ check_names_indices <- function(table_row,+ |
+
| 155 | ++ |
+ col_names = NULL,+ |
+
| 156 | ++ |
+ col_indices = NULL) {
+ |
+
| 157 | +1274x | +
+ if (!is.null(col_names)) {
+ |
+
| 158 | +1231x | +
+ if (!is.null(col_indices)) {
+ |
+
| 159 | +! | +
+ stop(+ |
+
| 160 | +! | +
+ "Inserted both col_names and col_indices when selecting row values. ",+ |
+
| 161 | +! | +
+ "Please choose one."+ |
+
| 162 | ++ |
+ )+ |
+
| 163 | ++ |
+ }+ |
+
| 164 | +1231x | +
+ col_indices <- h_col_indices(table_row, col_names)+ |
+
| 165 | ++ |
+ }+ |
+
| 166 | +1274x | +
+ if (is.null(col_indices)) {
+ |
+
| 167 | +37x | +
+ ll <- ifelse(is.null(ncol(table_row)), length(table_row), ncol(table_row))+ |
+
| 168 | +37x | +
+ col_indices <- seq_len(ll)+ |
+
| 169 | ++ |
+ }+ |
+
| 170 | ++ | + + | +
| 171 | +1274x | +
+ return(col_indices)+ |
+
| 172 | ++ |
+ }+ |
+
| 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 | ++ |
+ #' mutate(rsp = AVALC == "CR")+ |
+
| 22 | ++ |
+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @name h_response_biomarkers_subgroups+ |
+
| 25 | ++ |
+ NULL+ |
+
| 26 | ++ | + + | +
| 27 | ++ |
+ #' @describeIn h_response_biomarkers_subgroups helps with converting the "response" function variable list+ |
+
| 28 | ++ |
+ #' to the "logistic regression" variable list. The reason is that currently there is an+ |
+
| 29 | ++ |
+ #' inconsistency between the variable names accepted by `extract_rsp_subgroups()` and `fit_logistic()`.+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' @param biomarker (`string`)\cr the name of the biomarker variable.+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' @return+ |
+
| 34 | ++ |
+ #' * `h_rsp_to_logistic_variables()` returns a named `list` of elements `response`, `arm`, `covariates`, and `strata`.+ |
+
| 35 | ++ |
+ #'+ |
+
| 36 | ++ |
+ #' @examples+ |
+
| 37 | ++ |
+ #' # This is how the variable list is converted internally.+ |
+
| 38 | ++ |
+ #' h_rsp_to_logistic_variables(+ |
+
| 39 | ++ |
+ #' variables = list(+ |
+
| 40 | ++ |
+ #' rsp = "RSP",+ |
+
| 41 | ++ |
+ #' covariates = c("A", "B"),
+ |
+
| 42 | ++ |
+ #' strat = "D"+ |
+
| 43 | ++ |
+ #' ),+ |
+
| 44 | ++ |
+ #' biomarker = "AGE"+ |
+
| 45 | ++ |
+ #' )+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ #' @export+ |
+
| 48 | ++ |
+ h_rsp_to_logistic_variables <- function(variables, biomarker) {
+ |
+
| 49 | +37x | +
+ checkmate::assert_list(variables)+ |
+
| 50 | +37x | +
+ checkmate::assert_string(variables$rsp)+ |
+
| 51 | +37x | +
+ checkmate::assert_string(biomarker)+ |
+
| 52 | +37x | +
+ list(+ |
+
| 53 | +37x | +
+ response = variables$rsp,+ |
+
| 54 | +37x | +
+ arm = biomarker,+ |
+
| 55 | +37x | +
+ covariates = variables$covariates,+ |
+
| 56 | +37x | +
+ strata = variables$strat+ |
+
| 57 | ++ |
+ )+ |
+
| 58 | ++ |
+ }+ |
+
| 59 | ++ | + + | +
| 60 | ++ |
+ #' @describeIn h_response_biomarkers_subgroups prepares estimates for number of responses, patients and+ |
+
| 61 | ++ |
+ #' overall response rate, as well as odds ratio estimates, confidence intervals and p-values, for multiple+ |
+
| 62 | ++ |
+ #' biomarkers in a given single data set.+ |
+
| 63 | ++ |
+ #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements+ |
+
| 64 | ++ |
+ #' `rsp` and `biomarkers` (vector of continuous biomarker variables) and optionally `covariates`+ |
+
| 65 | ++ |
+ #' and `strat`.+ |
+
| 66 | ++ |
+ #'+ |
+
| 67 | ++ |
+ #' @return+ |
+
| 68 | ++ |
+ #' * `h_logistic_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers.+ |
+
| 69 | ++ |
+ #'+ |
+
| 70 | ++ |
+ #' @examples+ |
+
| 71 | ++ |
+ #' # For a single population, estimate separately the effects+ |
+
| 72 | ++ |
+ #' # of two biomarkers.+ |
+
| 73 | ++ |
+ #' df <- h_logistic_mult_cont_df(+ |
+
| 74 | ++ |
+ #' variables = list(+ |
+
| 75 | ++ |
+ #' rsp = "rsp",+ |
+
| 76 | ++ |
+ #' biomarkers = c("BMRKR1", "AGE"),
+ |
+
| 77 | ++ |
+ #' covariates = "SEX"+ |
+
| 78 | ++ |
+ #' ),+ |
+
| 79 | ++ |
+ #' data = adrs_f+ |
+
| 80 | ++ |
+ #' )+ |
+
| 81 | ++ |
+ #' df+ |
+
| 82 | ++ |
+ #'+ |
+
| 83 | ++ |
+ #' # If the data set is empty, still the corresponding rows with missings are returned.+ |
+
| 84 | ++ |
+ #' h_coxreg_mult_cont_df(+ |
+
| 85 | ++ |
+ #' variables = list(+ |
+
| 86 | ++ |
+ #' rsp = "rsp",+ |
+
| 87 | ++ |
+ #' biomarkers = c("BMRKR1", "AGE"),
+ |
+
| 88 | ++ |
+ #' covariates = "SEX",+ |
+
| 89 | ++ |
+ #' strat = "STRATA1"+ |
+
| 90 | ++ |
+ #' ),+ |
+
| 91 | ++ |
+ #' data = adrs_f[NULL, ]+ |
+
| 92 | ++ |
+ #' )+ |
+
| 93 | ++ |
+ #'+ |
+
| 94 | ++ |
+ #' @export+ |
+
| 95 | ++ |
+ h_logistic_mult_cont_df <- function(variables,+ |
+
| 96 | ++ |
+ data,+ |
+
| 97 | ++ |
+ control = control_logistic()) {
+ |
+
| 98 | +22x | +
+ assert_df_with_variables(data, variables)+ |
+
| 99 | ++ | + + | +
| 100 | +22x | +
+ checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE)+ |
+
| 101 | +22x | +
+ checkmate::assert_list(control, names = "named")+ |
+
| 102 | ++ | + + | +
| 103 | +22x | +
+ conf_level <- control[["conf_level"]]+ |
+
| 104 | +22x | +
+ pval_label <- "p-value (Wald)"+ |
+
| 105 | ++ | + + | +
| 106 | ++ |
+ # If there is any data, run model, otherwise return empty results.+ |
+
| 107 | +22x | +
+ if (nrow(data) > 0) {
+ |
+
| 108 | +21x | +
+ bm_cols <- match(variables$biomarkers, names(data))+ |
+
| 109 | +21x | +
+ l_result <- lapply(variables$biomarkers, function(bm) {
+ |
+
| 110 | +36x | +
+ model_fit <- fit_logistic(+ |
+
| 111 | +36x | +
+ variables = h_rsp_to_logistic_variables(variables, bm),+ |
+
| 112 | +36x | +
+ data = data,+ |
+
| 113 | +36x | +
+ response_definition = control$response_definition+ |
+
| 114 | ++ |
+ )+ |
+
| 115 | +36x | +
+ result <- h_logistic_simple_terms(+ |
+
| 116 | +36x | +
+ x = bm,+ |
+
| 117 | +36x | +
+ fit_glm = model_fit,+ |
+
| 118 | +36x | +
+ conf_level = control$conf_level+ |
+
| 119 | ++ |
+ )+ |
+
| 120 | +36x | +
+ resp_vector <- if (inherits(model_fit, "glm")) {
+ |
+
| 121 | +26x | +
+ model_fit$model[[variables$rsp]]+ |
+
| 122 | ++ |
+ } else {
+ |
+
| 123 | +10x | +
+ as.logical(as.matrix(model_fit$y)[, "status"])+ |
+
| 124 | ++ |
+ }+ |
+
| 125 | +36x | +
+ data.frame(+ |
+
| 126 | ++ |
+ # Dummy column needed downstream to create a nested header.+ |
+
| 127 | +36x | +
+ biomarker = bm,+ |
+
| 128 | +36x | +
+ biomarker_label = formatters::var_labels(data[bm], fill = TRUE),+ |
+
| 129 | +36x | +
+ n_tot = length(resp_vector),+ |
+
| 130 | +36x | +
+ n_rsp = sum(resp_vector),+ |
+
| 131 | +36x | +
+ prop = mean(resp_vector),+ |
+
| 132 | +36x | +
+ or = as.numeric(result[1L, "odds_ratio"]),+ |
+
| 133 | +36x | +
+ lcl = as.numeric(result[1L, "lcl"]),+ |
+
| 134 | +36x | +
+ ucl = as.numeric(result[1L, "ucl"]),+ |
+
| 135 | +36x | +
+ conf_level = conf_level,+ |
+
| 136 | +36x | +
+ pval = as.numeric(result[1L, "pvalue"]),+ |
+
| 137 | +36x | +
+ pval_label = pval_label,+ |
+
| 138 | +36x | +
+ stringsAsFactors = FALSE+ |
+
| 139 | ++ |
+ )+ |
+
| 140 | ++ |
+ })+ |
+
| 141 | +21x | +
+ do.call(rbind, args = c(l_result, make.row.names = FALSE))+ |
+
| 142 | ++ |
+ } else {
+ |
+
| 143 | +1x | +
+ data.frame(+ |
+
| 144 | +1x | +
+ biomarker = variables$biomarkers,+ |
+
| 145 | +1x | +
+ biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE),+ |
+
| 146 | +1x | +
+ n_tot = 0L,+ |
+
| 147 | +1x | +
+ n_rsp = 0L,+ |
+
| 148 | +1x | +
+ prop = NA,+ |
+
| 149 | +1x | +
+ or = NA,+ |
+
| 150 | +1x | +
+ lcl = NA,+ |
+
| 151 | +1x | +
+ ucl = NA,+ |
+
| 152 | +1x | +
+ conf_level = conf_level,+ |
+
| 153 | +1x | +
+ pval = NA,+ |
+
| 154 | +1x | +
+ pval_label = pval_label,+ |
+
| 155 | +1x | +
+ row.names = seq_along(variables$biomarkers),+ |
+
| 156 | +1x | +
+ stringsAsFactors = FALSE+ |
+
| 157 | ++ |
+ )+ |
+
| 158 | ++ |
+ }+ |
+
| 159 | ++ |
+ }+ |
+
| 160 | ++ | + + | +
| 161 | ++ |
+ #' @describeIn h_response_biomarkers_subgroups prepares a single sub-table given a `df_sub` containing+ |
+
| 162 | ++ |
+ #' the results for a single biomarker.+ |
+
| 163 | ++ |
+ #'+ |
+
| 164 | ++ |
+ #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is+ |
+
| 165 | ++ |
+ #' returned by [extract_rsp_biomarkers()] (it needs a couple of columns which are+ |
+
| 166 | ++ |
+ #' added by that high-level function relative to what is returned by [h_logistic_mult_cont_df()],+ |
+
| 167 | ++ |
+ #' see the example).+ |
+
| 168 | ++ |
+ #'+ |
+
| 169 | ++ |
+ #' @return+ |
+
| 170 | ++ |
+ #' * `h_tab_rsp_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns.+ |
+
| 171 | ++ |
+ #'+ |
+
| 172 | ++ |
+ #' @examples+ |
+
| 173 | ++ |
+ #' # Starting from above `df`, zoom in on one biomarker and add required columns.+ |
+
| 174 | ++ |
+ #' df1 <- df[1, ]+ |
+
| 175 | ++ |
+ #' df1$subgroup <- "All patients"+ |
+
| 176 | ++ |
+ #' df1$row_type <- "content"+ |
+
| 177 | ++ |
+ #' df1$var <- "ALL"+ |
+
| 178 | ++ |
+ #' df1$var_label <- "All patients"+ |
+
| 179 | ++ |
+ #'+ |
+
| 180 | ++ |
+ #' h_tab_rsp_one_biomarker(+ |
+
| 181 | ++ |
+ #' df1,+ |
+
| 182 | ++ |
+ #' vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval")
+ |
+
| 183 | ++ |
+ #' )+ |
+
| 184 | ++ |
+ #'+ |
+
| 185 | ++ |
+ #' @export+ |
+
| 186 | ++ |
+ h_tab_rsp_one_biomarker <- function(df,+ |
+
| 187 | ++ |
+ vars,+ |
+
| 188 | ++ |
+ .indent_mods = 0L) {
+ |
+
| 189 | +6x | +
+ afuns <- a_response_subgroups()[vars]+ |
+
| 190 | +6x | +
+ colvars <- d_rsp_subgroups_colvars(+ |
+
| 191 | +6x | +
+ vars,+ |
+
| 192 | +6x | +
+ conf_level = df$conf_level[1],+ |
+
| 193 | +6x | +
+ method = df$pval_label[1]+ |
+
| 194 | ++ |
+ )+ |
+
| 195 | +6x | +
+ h_tab_one_biomarker(+ |
+
| 196 | +6x | +
+ df = df,+ |
+
| 197 | +6x | +
+ afuns = afuns,+ |
+
| 198 | +6x | +
+ colvars = colvars,+ |
+
| 199 | +6x | +
+ .indent_mods = .indent_mods+ |
+
| 200 | ++ |
+ )+ |
+
| 201 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Count Patients with Marked Laboratory Abnormalities+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Primary analysis variable `.var` indicates whether single, replicated or last marked laboratory+ |
+
| 6 | ++ |
+ #' abnormality was observed (`factor`). Additional analysis variables are `id` (`character` or `factor`)+ |
+
| 7 | ++ |
+ #' and `direction` (`factor`) indicating the direction of the abnormality. Denominator is number of+ |
+
| 8 | ++ |
+ #' patients with at least one valid measurement during the analysis.+ |
+
| 9 | ++ |
+ #' * For `Single, not last` and `Last or replicated`: Numerator is number of patients+ |
+
| 10 | ++ |
+ #' with `Single, not last` and `Last or replicated` levels, respectively.+ |
+
| 11 | ++ |
+ #' * For `Any`: Numerator is the number of patients with either single or+ |
+
| 12 | ++ |
+ #' replicated marked abnormalities.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 15 | ++ |
+ #' @param category (`list`)\cr with different marked category names for single+ |
+
| 16 | ++ |
+ #' and last or replicated.+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @note `Single, not last` and `Last or replicated` levels are mutually exclusive. If a patient has+ |
+
| 19 | ++ |
+ #' abnormalities that meet both the `Single, not last` and `Last or replicated` criteria, then the+ |
+
| 20 | ++ |
+ #' patient will be counted only under the `Last or replicated` category.+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @name abnormal_by_marked+ |
+
| 23 | ++ |
+ NULL+ |
+
| 24 | ++ | + + | +
| 25 | ++ |
+ #' @describeIn abnormal_by_marked Statistics function for patients with marked lab abnormalities.+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' @return+ |
+
| 28 | ++ |
+ #' * `s_count_abnormal_by_marked()` returns statistic `count_fraction` with `Single, not last`,+ |
+
| 29 | ++ |
+ #' `Last or replicated`, and `Any` results.+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' @examples+ |
+
| 32 | ++ |
+ #' library(dplyr)+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' df <- data.frame(+ |
+
| 35 | ++ |
+ #' USUBJID = as.character(c(rep(1, 5), rep(2, 5), rep(1, 5), rep(2, 5))),+ |
+
| 36 | ++ |
+ #' ARMCD = factor(c(rep("ARM A", 5), rep("ARM B", 5), rep("ARM A", 5), rep("ARM B", 5))),
+ |
+
| 37 | ++ |
+ #' ANRIND = factor(c(+ |
+
| 38 | ++ |
+ #' "NORMAL", "HIGH", "HIGH", "HIGH HIGH", "HIGH",+ |
+
| 39 | ++ |
+ #' "HIGH", "HIGH", "HIGH HIGH", "NORMAL", "HIGH HIGH", "NORMAL", "LOW", "LOW", "LOW LOW", "LOW",+ |
+
| 40 | ++ |
+ #' "LOW", "LOW", "LOW LOW", "NORMAL", "LOW LOW"+ |
+
| 41 | ++ |
+ #' )),+ |
+
| 42 | ++ |
+ #' ONTRTFL = rep(c("", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y"), 2),
+ |
+
| 43 | ++ |
+ #' PARAMCD = factor(c(rep("CRP", 10), rep("ALT", 10))),
+ |
+
| 44 | ++ |
+ #' AVALCAT1 = factor(rep(c("", "", "", "SINGLE", "REPLICATED", "", "", "LAST", "", "SINGLE"), 2)),
+ |
+
| 45 | ++ |
+ #' stringsAsFactors = FALSE+ |
+
| 46 | ++ |
+ #' )+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ #' df <- df %>%+ |
+
| 49 | ++ |
+ #' mutate(abn_dir = factor(+ |
+
| 50 | ++ |
+ #' case_when(+ |
+
| 51 | ++ |
+ #' ANRIND == "LOW LOW" ~ "Low",+ |
+
| 52 | ++ |
+ #' ANRIND == "HIGH HIGH" ~ "High",+ |
+
| 53 | ++ |
+ #' TRUE ~ ""+ |
+
| 54 | ++ |
+ #' ),+ |
+
| 55 | ++ |
+ #' levels = c("Low", "High")
+ |
+
| 56 | ++ |
+ #' ))+ |
+
| 57 | ++ |
+ #'+ |
+
| 58 | ++ |
+ #' # Select only post-baseline records.+ |
+
| 59 | ++ |
+ #' df <- df %>% filter(ONTRTFL == "Y")+ |
+
| 60 | ++ |
+ #' df_crp <- df %>%+ |
+
| 61 | ++ |
+ #' filter(PARAMCD == "CRP") %>%+ |
+
| 62 | ++ |
+ #' droplevels()+ |
+
| 63 | ++ |
+ #' full_parent_df <- list(df_crp, "not_needed")+ |
+
| 64 | ++ |
+ #' cur_col_subset <- list(rep(TRUE, nrow(df_crp)), "not_needed")+ |
+
| 65 | ++ |
+ #' spl_context <- data.frame(+ |
+
| 66 | ++ |
+ #' split = c("PARAMCD", "GRADE_DIR"),
+ |
+
| 67 | ++ |
+ #' full_parent_df = I(full_parent_df),+ |
+
| 68 | ++ |
+ #' cur_col_subset = I(cur_col_subset)+ |
+
| 69 | ++ |
+ #' )+ |
+
| 70 | ++ |
+ #'+ |
+
| 71 | ++ |
+ #' @keywords internal+ |
+
| 72 | ++ |
+ s_count_abnormal_by_marked <- function(df,+ |
+
| 73 | ++ |
+ .var = "AVALCAT1",+ |
+
| 74 | ++ |
+ .spl_context,+ |
+
| 75 | ++ |
+ category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
+ |
+
| 76 | ++ |
+ variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir")) {
+ |
+
| 77 | +3x | +
+ checkmate::assert_string(.var)+ |
+
| 78 | +3x | +
+ checkmate::assert_list(variables)+ |
+
| 79 | +3x | +
+ checkmate::assert_list(category)+ |
+
| 80 | +3x | +
+ checkmate::assert_subset(names(category), c("single", "last_replicated"))
+ |
+
| 81 | +3x | +
+ checkmate::assert_subset(names(variables), c("id", "param", "direction"))
+ |
+
| 82 | +3x | +
+ checkmate::assert_vector(unique(df[[variables$direction]]), max.len = 1)+ |
+
| 83 | ++ | + + | +
| 84 | +2x | +
+ assert_df_with_variables(df, c(aval = .var, variables))+ |
+
| 85 | +2x | +
+ checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
+ |
+
| 86 | +2x | +
+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ |
+
| 87 | ++ | + + | +
| 88 | ++ | + + | +
| 89 | +2x | +
+ first_row <- .spl_context[.spl_context$split == variables[["param"]], ]+ |
+
| 90 | ++ |
+ # Patients in the denominator have at least one post-baseline visit.+ |
+
| 91 | +2x | +
+ subj <- first_row$full_parent_df[[1]][[variables[["id"]]]]+ |
+
| 92 | +2x | +
+ subj_cur_col <- subj[first_row$cur_col_subset[[1]]]+ |
+
| 93 | ++ |
+ # Some subjects may have a record for high and low directions but+ |
+
| 94 | ++ |
+ # should be counted only once.+ |
+
| 95 | +2x | +
+ denom <- length(unique(subj_cur_col))+ |
+
| 96 | ++ | + + | +
| 97 | +2x | +
+ if (denom != 0) {
+ |
+
| 98 | +2x | +
+ subjects_last_replicated <- unique(+ |
+
| 99 | +2x | +
+ df[df[[.var]] %in% category[["last_replicated"]], variables$id, drop = TRUE]+ |
+
| 100 | ++ |
+ )+ |
+
| 101 | +2x | +
+ subjects_single <- unique(+ |
+
| 102 | +2x | +
+ df[df[[.var]] %in% category[["single"]], variables$id, drop = TRUE]+ |
+
| 103 | ++ |
+ )+ |
+
| 104 | ++ |
+ # Subjects who have both single and last/replicated abnormalities are counted in only the last/replicated group.+ |
+
| 105 | +2x | +
+ subjects_single <- setdiff(subjects_single, subjects_last_replicated)+ |
+
| 106 | +2x | +
+ n_single <- length(subjects_single)+ |
+
| 107 | +2x | +
+ n_last_replicated <- length(subjects_last_replicated)+ |
+
| 108 | +2x | +
+ n_any <- n_single + n_last_replicated+ |
+
| 109 | +2x | +
+ result <- list(count_fraction = list(+ |
+
| 110 | +2x | +
+ "Single, not last" = c(n_single, n_single / denom),+ |
+
| 111 | +2x | +
+ "Last or replicated" = c(n_last_replicated, n_last_replicated / denom),+ |
+
| 112 | +2x | +
+ "Any Abnormality" = c(n_any, n_any / denom)+ |
+
| 113 | ++ |
+ ))+ |
+
| 114 | ++ |
+ } else {
+ |
+
| 115 | +! | +
+ result <- list(count_fraction = list(+ |
+
| 116 | +! | +
+ "Single, not last" = c(0, 0),+ |
+
| 117 | +! | +
+ "Last or replicated" = c(0, 0),+ |
+
| 118 | +! | +
+ "Any Abnormality" = c(0, 0)+ |
+
| 119 | ++ |
+ ))+ |
+
| 120 | ++ |
+ }+ |
+
| 121 | ++ | + + | +
| 122 | +2x | +
+ result+ |
+
| 123 | ++ |
+ }+ |
+
| 124 | ++ | + + | +
| 125 | ++ |
+ #' @describeIn abnormal_by_marked Formatted analysis function which is used as `afun`+ |
+
| 126 | ++ |
+ #' in `count_abnormal_by_marked()`.+ |
+
| 127 | ++ |
+ #'+ |
+
| 128 | ++ |
+ #' @return+ |
+
| 129 | ++ |
+ #' * `a_count_abnormal_by_marked()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 130 | ++ |
+ #'+ |
+
| 131 | ++ |
+ #'+ |
+
| 132 | ++ |
+ #' @keywords internal+ |
+
| 133 | ++ |
+ a_count_abnormal_by_marked <- make_afun(+ |
+
| 134 | ++ |
+ s_count_abnormal_by_marked,+ |
+
| 135 | ++ |
+ .formats = c(count_fraction = format_count_fraction)+ |
+
| 136 | ++ |
+ )+ |
+
| 137 | ++ | + + | +
| 138 | ++ |
+ #' @describeIn abnormal_by_marked Layout-creating function which can take statistics function arguments+ |
+
| 139 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 140 | ++ |
+ #'+ |
+
| 141 | ++ |
+ #' @return+ |
+
| 142 | ++ |
+ #' * `count_abnormal_by_marked()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 143 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 144 | ++ |
+ #' the statistics from `s_count_abnormal_by_marked()` to the table layout.+ |
+
| 145 | ++ |
+ #'+ |
+
| 146 | ++ |
+ #' @examples+ |
+
| 147 | ++ |
+ #' map <- unique(+ |
+
| 148 | ++ |
+ #' df[df$abn_dir %in% c("Low", "High") & df$AVALCAT1 != "", c("PARAMCD", "abn_dir")]
+ |
+
| 149 | ++ |
+ #' ) %>%+ |
+
| 150 | ++ |
+ #' lapply(as.character) %>%+ |
+
| 151 | ++ |
+ #' as.data.frame() %>%+ |
+
| 152 | ++ |
+ #' arrange(PARAMCD, abn_dir)+ |
+
| 153 | ++ |
+ #'+ |
+
| 154 | ++ |
+ #' basic_table() %>%+ |
+
| 155 | ++ |
+ #' split_cols_by("ARMCD") %>%
+ |
+
| 156 | ++ |
+ #' split_rows_by("PARAMCD") %>%
+ |
+
| 157 | ++ |
+ #' summarize_num_patients(+ |
+
| 158 | ++ |
+ #' var = "USUBJID",+ |
+
| 159 | ++ |
+ #' .stats = "unique_count"+ |
+
| 160 | ++ |
+ #' ) %>%+ |
+
| 161 | ++ |
+ #' split_rows_by(+ |
+
| 162 | ++ |
+ #' "abn_dir",+ |
+
| 163 | ++ |
+ #' split_fun = trim_levels_to_map(map)+ |
+
| 164 | ++ |
+ #' ) %>%+ |
+
| 165 | ++ |
+ #' count_abnormal_by_marked(+ |
+
| 166 | ++ |
+ #' var = "AVALCAT1",+ |
+
| 167 | ++ |
+ #' variables = list(+ |
+
| 168 | ++ |
+ #' id = "USUBJID",+ |
+
| 169 | ++ |
+ #' param = "PARAMCD",+ |
+
| 170 | ++ |
+ #' direction = "abn_dir"+ |
+
| 171 | ++ |
+ #' )+ |
+
| 172 | ++ |
+ #' ) %>%+ |
+
| 173 | ++ |
+ #' build_table(df = df)+ |
+
| 174 | ++ |
+ #'+ |
+
| 175 | ++ |
+ #' basic_table() %>%+ |
+
| 176 | ++ |
+ #' split_cols_by("ARMCD") %>%
+ |
+
| 177 | ++ |
+ #' split_rows_by("PARAMCD") %>%
+ |
+
| 178 | ++ |
+ #' summarize_num_patients(+ |
+
| 179 | ++ |
+ #' var = "USUBJID",+ |
+
| 180 | ++ |
+ #' .stats = "unique_count"+ |
+
| 181 | ++ |
+ #' ) %>%+ |
+
| 182 | ++ |
+ #' split_rows_by(+ |
+
| 183 | ++ |
+ #' "abn_dir",+ |
+
| 184 | ++ |
+ #' split_fun = trim_levels_in_group("abn_dir")
+ |
+
| 185 | ++ |
+ #' ) %>%+ |
+
| 186 | ++ |
+ #' count_abnormal_by_marked(+ |
+
| 187 | ++ |
+ #' var = "AVALCAT1",+ |
+
| 188 | ++ |
+ #' variables = list(+ |
+
| 189 | ++ |
+ #' id = "USUBJID",+ |
+
| 190 | ++ |
+ #' param = "PARAMCD",+ |
+
| 191 | ++ |
+ #' direction = "abn_dir"+ |
+
| 192 | ++ |
+ #' )+ |
+
| 193 | ++ |
+ #' ) %>%+ |
+
| 194 | ++ |
+ #' build_table(df = df)+ |
+
| 195 | ++ |
+ #'+ |
+
| 196 | ++ |
+ #' @export+ |
+
| 197 | ++ |
+ count_abnormal_by_marked <- function(lyt,+ |
+
| 198 | ++ |
+ var,+ |
+
| 199 | ++ |
+ na_str = NA_character_,+ |
+
| 200 | ++ |
+ nested = TRUE,+ |
+
| 201 | ++ |
+ ...,+ |
+
| 202 | ++ |
+ .stats = NULL,+ |
+
| 203 | ++ |
+ .formats = NULL,+ |
+
| 204 | ++ |
+ .labels = NULL,+ |
+
| 205 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 206 | +1x | +
+ checkmate::assert_string(var)+ |
+
| 207 | ++ | + + | +
| 208 | +1x | +
+ afun <- make_afun(+ |
+
| 209 | +1x | +
+ a_count_abnormal_by_marked,+ |
+
| 210 | +1x | +
+ .stats = .stats,+ |
+
| 211 | +1x | +
+ .formats = .formats,+ |
+
| 212 | +1x | +
+ .labels = .labels,+ |
+
| 213 | +1x | +
+ .indent_mods = .indent_mods,+ |
+
| 214 | +1x | +
+ .ungroup_stats = "count_fraction"+ |
+
| 215 | ++ |
+ )+ |
+
| 216 | ++ | + + | +
| 217 | +1x | +
+ lyt <- analyze(+ |
+
| 218 | +1x | +
+ lyt = lyt,+ |
+
| 219 | +1x | +
+ vars = var,+ |
+
| 220 | +1x | +
+ afun = afun,+ |
+
| 221 | +1x | +
+ na_str = na_str,+ |
+
| 222 | +1x | +
+ nested = nested,+ |
+
| 223 | +1x | +
+ show_labels = "hidden",+ |
+
| 224 | +1x | +
+ extra_args = c(list(...))+ |
+
| 225 | ++ |
+ )+ |
+
| 226 | +1x | +
+ lyt+ |
+
| 227 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Patient Counts with the Most Extreme Post-baseline Toxicity Grade per Direction of Abnormality+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Primary analysis variable `.var` indicates the toxicity grade (`factor`), and additional+ |
+
| 6 | ++ |
+ #' analysis variables are `id` (`character` or `factor`), `param` (`factor`) and `grade_dir` (`factor`).+ |
+
| 7 | ++ |
+ #' The pre-processing steps are crucial when using this function.+ |
+
| 8 | ++ |
+ #' For a certain direction (e.g. high or low) this function counts+ |
+
| 9 | ++ |
+ #' patients in the denominator as number of patients with at least one valid measurement during treatment,+ |
+
| 10 | ++ |
+ #' and patients in the numerator as follows:+ |
+
| 11 | ++ |
+ #' * `1` to `4`: Numerator is number of patients with worst grades 1-4 respectively;+ |
+
| 12 | ++ |
+ #' * `Any`: Numerator is number of patients with at least one abnormality, which means grade is different from 0.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @details The pre-processing steps are crucial when using this function. From the standard lab grade variable+ |
+
| 17 | ++ |
+ #' `ATOXGR`, derive the following two variables:+ |
+
| 18 | ++ |
+ #' * A grade direction variable (e.g. `GRADE_DIR`) is required in order to obtain+ |
+
| 19 | ++ |
+ #' the correct denominators when building the layout as it is used to define row splitting.+ |
+
| 20 | ++ |
+ #' * A toxicity grade variable (e.g. `GRADE_ANL`) where all negative values from+ |
+
| 21 | ++ |
+ #' `ATOXGR` are replaced by their absolute values.+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @note Prior to tabulation, `df` must be filtered to include only post-baseline records with worst grade flags.+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @name abnormal_by_worst_grade+ |
+
| 26 | ++ |
+ NULL+ |
+
| 27 | ++ | + + | +
| 28 | ++ |
+ #' @describeIn abnormal_by_worst_grade Statistics function which counts patients by worst grade.+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' @return+ |
+
| 31 | ++ |
+ #' * `s_count_abnormal_by_worst_grade()` returns the single statistic `count_fraction` with grades 1 to 4 and+ |
+
| 32 | ++ |
+ #' "Any" results.+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' @examples+ |
+
| 35 | ++ |
+ #' library(dplyr)+ |
+
| 36 | ++ |
+ #' library(forcats)+ |
+
| 37 | ++ |
+ #' adlb <- tern_ex_adlb+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' # Data is modified in order to have some parameters with grades only in one direction+ |
+
| 40 | ++ |
+ #' # and simulate the real data.+ |
+
| 41 | ++ |
+ #' adlb$ATOXGR[adlb$PARAMCD == "ALT" & adlb$ATOXGR %in% c("1", "2", "3", "4")] <- "-1"
+ |
+
| 42 | ++ |
+ #' adlb$ANRIND[adlb$PARAMCD == "ALT" & adlb$ANRIND == "HIGH"] <- "LOW"+ |
+
| 43 | ++ |
+ #' adlb$WGRHIFL[adlb$PARAMCD == "ALT"] <- ""+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' adlb$ATOXGR[adlb$PARAMCD == "IGA" & adlb$ATOXGR %in% c("-1", "-2", "-3", "-4")] <- "1"
+ |
+
| 46 | ++ |
+ #' adlb$ANRIND[adlb$PARAMCD == "IGA" & adlb$ANRIND == "LOW"] <- "HIGH"+ |
+
| 47 | ++ |
+ #' adlb$WGRLOFL[adlb$PARAMCD == "IGA"] <- ""+ |
+
| 48 | ++ |
+ #'+ |
+
| 49 | ++ |
+ #' # Here starts the real pre-processing.+ |
+
| 50 | ++ |
+ #' adlb_f <- adlb %>%+ |
+
| 51 | ++ |
+ #' filter(!AVISIT %in% c("SCREENING", "BASELINE")) %>%
+ |
+
| 52 | ++ |
+ #' mutate(+ |
+
| 53 | ++ |
+ #' GRADE_DIR = factor(+ |
+
| 54 | ++ |
+ #' case_when(+ |
+
| 55 | ++ |
+ #' ATOXGR %in% c("-1", "-2", "-3", "-4") ~ "LOW",
+ |
+
| 56 | ++ |
+ #' ATOXGR == "0" ~ "ZERO",+ |
+
| 57 | ++ |
+ #' ATOXGR %in% c("1", "2", "3", "4") ~ "HIGH"
+ |
+
| 58 | ++ |
+ #' ),+ |
+
| 59 | ++ |
+ #' levels = c("LOW", "ZERO", "HIGH")
+ |
+
| 60 | ++ |
+ #' ),+ |
+
| 61 | ++ |
+ #' GRADE_ANL = fct_relevel(+ |
+
| 62 | ++ |
+ #' fct_recode(ATOXGR, `1` = "-1", `2` = "-2", `3` = "-3", `4` = "-4"),+ |
+
| 63 | ++ |
+ #' c("0", "1", "2", "3", "4")
+ |
+
| 64 | ++ |
+ #' )+ |
+
| 65 | ++ |
+ #' ) %>%+ |
+
| 66 | ++ |
+ #' filter(WGRLOFL == "Y" | WGRHIFL == "Y") %>%+ |
+
| 67 | ++ |
+ #' droplevels()+ |
+
| 68 | ++ |
+ #'+ |
+
| 69 | ++ |
+ #' adlb_f_alt <- adlb_f %>%+ |
+
| 70 | ++ |
+ #' filter(PARAMCD == "ALT") %>%+ |
+
| 71 | ++ |
+ #' droplevels()+ |
+
| 72 | ++ |
+ #' full_parent_df <- list(adlb_f_alt, "not_needed")+ |
+
| 73 | ++ |
+ #' cur_col_subset <- list(rep(TRUE, nrow(adlb_f_alt)), "not_needed")+ |
+
| 74 | ++ |
+ #'+ |
+
| 75 | ++ |
+ #' # This mimics a split structure on PARAM and GRADE_DIR for a total column+ |
+
| 76 | ++ |
+ #' spl_context <- data.frame(+ |
+
| 77 | ++ |
+ #' split = c("PARAM", "GRADE_DIR"),
+ |
+
| 78 | ++ |
+ #' full_parent_df = I(full_parent_df),+ |
+
| 79 | ++ |
+ #' cur_col_subset = I(cur_col_subset)+ |
+
| 80 | ++ |
+ #' )+ |
+
| 81 | ++ |
+ #'+ |
+
| 82 | ++ |
+ #' @keywords internal+ |
+
| 83 | ++ |
+ s_count_abnormal_by_worst_grade <- function(df, # nolint+ |
+
| 84 | ++ |
+ .var = "GRADE_ANL",+ |
+
| 85 | ++ |
+ .spl_context,+ |
+
| 86 | ++ |
+ variables = list(+ |
+
| 87 | ++ |
+ id = "USUBJID",+ |
+
| 88 | ++ |
+ param = "PARAM",+ |
+
| 89 | ++ |
+ grade_dir = "GRADE_DIR"+ |
+
| 90 | ++ |
+ )) {
+ |
+
| 91 | +1x | +
+ checkmate::assert_string(.var)+ |
+
| 92 | +1x | +
+ assert_valid_factor(df[[.var]])+ |
+
| 93 | +1x | +
+ assert_valid_factor(df[[variables$param]])+ |
+
| 94 | +1x | +
+ assert_valid_factor(df[[variables$grade_dir]])+ |
+
| 95 | +1x | +
+ assert_df_with_variables(df, c(a = .var, variables))+ |
+
| 96 | +1x | +
+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ |
+
| 97 | ++ | + + | +
| 98 | ++ |
+ # To verify that the `split_rows_by` are performed with correct variables.+ |
+
| 99 | +1x | +
+ checkmate::assert_subset(c(variables[["param"]], variables[["grade_dir"]]), .spl_context$split)+ |
+
| 100 | +1x | +
+ first_row <- .spl_context[.spl_context$split == variables[["param"]], ]+ |
+
| 101 | +1x | +
+ x_lvls <- c(setdiff(levels(df[[.var]]), "0"), "Any")+ |
+
| 102 | +1x | +
+ result <- split(numeric(0), factor(x_lvls))+ |
+
| 103 | ++ | + + | +
| 104 | +1x | +
+ subj <- first_row$full_parent_df[[1]][[variables[["id"]]]]+ |
+
| 105 | +1x | +
+ subj_cur_col <- subj[first_row$cur_col_subset[[1]]]+ |
+
| 106 | ++ |
+ # Some subjects may have a record for high and low directions but+ |
+
| 107 | ++ |
+ # should be counted only once.+ |
+
| 108 | +1x | +
+ denom <- length(unique(subj_cur_col))+ |
+
| 109 | ++ | + + | +
| 110 | +1x | +
+ for (lvl in x_lvls) {
+ |
+
| 111 | +5x | +
+ if (lvl != "Any") {
+ |
+
| 112 | +4x | +
+ df_lvl <- df[df[[.var]] == lvl, ]+ |
+
| 113 | ++ |
+ } else {
+ |
+
| 114 | +1x | +
+ df_lvl <- df[df[[.var]] != 0, ]+ |
+
| 115 | ++ |
+ }+ |
+
| 116 | +5x | +
+ num <- length(unique(df_lvl[[variables[["id"]]]]))+ |
+
| 117 | +5x | +
+ fraction <- ifelse(denom == 0, 0, num / denom)+ |
+
| 118 | +5x | +
+ result[[lvl]] <- formatters::with_label(c(count = num, fraction = fraction), lvl)+ |
+
| 119 | ++ |
+ }+ |
+
| 120 | ++ | + + | +
| 121 | +1x | +
+ result <- list(count_fraction = result)+ |
+
| 122 | +1x | +
+ result+ |
+
| 123 | ++ |
+ }+ |
+
| 124 | ++ | + + | +
| 125 | ++ |
+ #' @describeIn abnormal_by_worst_grade Formatted analysis function which is used as `afun`+ |
+
| 126 | ++ |
+ #' in `count_abnormal_by_worst_grade()`.+ |
+
| 127 | ++ |
+ #'+ |
+
| 128 | ++ |
+ #' @return+ |
+
| 129 | ++ |
+ #' * `a_count_abnormal_by_worst_grade()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 130 | ++ |
+ #'+ |
+
| 131 | ++ |
+ #'+ |
+
| 132 | ++ |
+ #' @keywords internal+ |
+
| 133 | ++ |
+ a_count_abnormal_by_worst_grade <- make_afun( # nolint+ |
+
| 134 | ++ |
+ s_count_abnormal_by_worst_grade,+ |
+
| 135 | ++ |
+ .formats = c(count_fraction = format_count_fraction)+ |
+
| 136 | ++ |
+ )+ |
+
| 137 | ++ | + + | +
| 138 | ++ |
+ #' @describeIn abnormal_by_worst_grade Layout-creating function which can take statistics function arguments+ |
+
| 139 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 140 | ++ |
+ #'+ |
+
| 141 | ++ |
+ #' @return+ |
+
| 142 | ++ |
+ #' * `count_abnormal_by_worst_grade()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 143 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 144 | ++ |
+ #' the statistics from `s_count_abnormal_by_worst_grade()` to the table layout.+ |
+
| 145 | ++ |
+ #'+ |
+
| 146 | ++ |
+ #' @examples+ |
+
| 147 | ++ |
+ #' # Map excludes records without abnormal grade since they should not be displayed+ |
+
| 148 | ++ |
+ #' # in the table.+ |
+
| 149 | ++ |
+ #' map <- unique(adlb_f[adlb_f$GRADE_DIR != "ZERO", c("PARAM", "GRADE_DIR", "GRADE_ANL")]) %>%
+ |
+
| 150 | ++ |
+ #' lapply(as.character) %>%+ |
+
| 151 | ++ |
+ #' as.data.frame() %>%+ |
+
| 152 | ++ |
+ #' arrange(PARAM, desc(GRADE_DIR), GRADE_ANL)+ |
+
| 153 | ++ |
+ #'+ |
+
| 154 | ++ |
+ #' basic_table() %>%+ |
+
| 155 | ++ |
+ #' split_cols_by("ARMCD") %>%
+ |
+
| 156 | ++ |
+ #' split_rows_by("PARAM") %>%
+ |
+
| 157 | ++ |
+ #' split_rows_by("GRADE_DIR", split_fun = trim_levels_to_map(map)) %>%
+ |
+
| 158 | ++ |
+ #' count_abnormal_by_worst_grade(+ |
+
| 159 | ++ |
+ #' var = "GRADE_ANL",+ |
+
| 160 | ++ |
+ #' variables = list(id = "USUBJID", param = "PARAM", grade_dir = "GRADE_DIR")+ |
+
| 161 | ++ |
+ #' ) %>%+ |
+
| 162 | ++ |
+ #' build_table(df = adlb_f)+ |
+
| 163 | ++ |
+ #'+ |
+
| 164 | ++ |
+ #' @export+ |
+
| 165 | ++ |
+ count_abnormal_by_worst_grade <- function(lyt,+ |
+
| 166 | ++ |
+ var,+ |
+
| 167 | ++ |
+ na_str = NA_character_,+ |
+
| 168 | ++ |
+ nested = TRUE,+ |
+
| 169 | ++ |
+ ...,+ |
+
| 170 | ++ |
+ .stats = NULL,+ |
+
| 171 | ++ |
+ .formats = NULL,+ |
+
| 172 | ++ |
+ .labels = NULL,+ |
+
| 173 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 174 | +2x | +
+ afun <- make_afun(+ |
+
| 175 | +2x | +
+ a_count_abnormal_by_worst_grade,+ |
+
| 176 | +2x | +
+ .stats = .stats,+ |
+
| 177 | +2x | +
+ .formats = .formats,+ |
+
| 178 | +2x | +
+ .labels = .labels,+ |
+
| 179 | +2x | +
+ .indent_mods = .indent_mods,+ |
+
| 180 | +2x | +
+ .ungroup_stats = "count_fraction"+ |
+
| 181 | ++ |
+ )+ |
+
| 182 | +2x | +
+ analyze(+ |
+
| 183 | +2x | +
+ lyt = lyt,+ |
+
| 184 | +2x | +
+ vars = var,+ |
+
| 185 | +2x | +
+ afun = afun,+ |
+
| 186 | +2x | +
+ na_str = na_str,+ |
+
| 187 | +2x | +
+ nested = nested,+ |
+
| 188 | +2x | +
+ extra_args = list(...),+ |
+
| 189 | +2x | +
+ show_labels = "hidden"+ |
+
| 190 | ++ |
+ )+ |
+
| 191 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Helper Function to create a map dataframe that can be used in `trim_levels_to_map` split function.+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Helper Function to create a map dataframe from the input dataset, which can be used as an argument in the+ |
+
| 6 | ++ |
+ #' `trim_levels_to_map` split function. Based on different method, the map is constructed differently.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #' @param abnormal (named `list`)\cr identifying the abnormal range level(s) in `df`. Based on the levels of+ |
+
| 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"))`+ |
+
| 12 | ++ |
+ #' @param method (`string`)\cr indicates how the returned map will be constructed. Can be `"default"` or `"range"`.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @return A map `data.frame`.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @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 | ++ |
+ #' `"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 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @examples+ |
+
| 22 | ++ |
+ #' adlb <- df_explicit_na(tern_ex_adlb)+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' h_map_for_count_abnormal(+ |
+
| 25 | ++ |
+ #' df = adlb,+ |
+
| 26 | ++ |
+ #' variables = list(anl = "ANRIND", split_rows = c("LBCAT", "PARAM")),
+ |
+
| 27 | ++ |
+ #' abnormal = list(low = c("LOW"), high = c("HIGH")),
+ |
+
| 28 | ++ |
+ #' method = "default",+ |
+
| 29 | ++ |
+ #' na_str = "<Missing>"+ |
+
| 30 | ++ |
+ #' )+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' df <- data.frame(+ |
+
| 33 | ++ |
+ #' USUBJID = c(rep("1", 4), rep("2", 4), rep("3", 4)),
+ |
+
| 34 | ++ |
+ #' AVISIT = c(+ |
+
| 35 | ++ |
+ #' rep("WEEK 1", 2),
+ |
+
| 36 | ++ |
+ #' rep("WEEK 2", 2),
+ |
+
| 37 | ++ |
+ #' rep("WEEK 1", 2),
+ |
+
| 38 | ++ |
+ #' rep("WEEK 2", 2),
+ |
+
| 39 | ++ |
+ #' rep("WEEK 1", 2),
+ |
+
| 40 | ++ |
+ #' rep("WEEK 2", 2)
+ |
+
| 41 | ++ |
+ #' ),+ |
+
| 42 | ++ |
+ #' PARAM = rep(c("ALT", "CPR"), 6),
+ |
+
| 43 | ++ |
+ #' ANRIND = c(+ |
+
| 44 | ++ |
+ #' "NORMAL", "NORMAL", "LOW",+ |
+
| 45 | ++ |
+ #' "HIGH", "LOW", "LOW", "HIGH", "HIGH", rep("NORMAL", 4)
+ |
+
| 46 | ++ |
+ #' ),+ |
+
| 47 | ++ |
+ #' ANRLO = rep(5, 12),+ |
+
| 48 | ++ |
+ #' ANRHI = rep(20, 12)+ |
+
| 49 | ++ |
+ #' )+ |
+
| 50 | ++ |
+ #' df$ANRIND <- factor(df$ANRIND, levels = c("LOW", "HIGH", "NORMAL"))
+ |
+
| 51 | ++ |
+ #' h_map_for_count_abnormal(+ |
+
| 52 | ++ |
+ #' df = df,+ |
+
| 53 | ++ |
+ #' variables = list(+ |
+
| 54 | ++ |
+ #' anl = "ANRIND",+ |
+
| 55 | ++ |
+ #' split_rows = c("PARAM"),
+ |
+
| 56 | ++ |
+ #' range_low = "ANRLO",+ |
+
| 57 | ++ |
+ #' range_high = "ANRHI"+ |
+
| 58 | ++ |
+ #' ),+ |
+
| 59 | ++ |
+ #' abnormal = list(low = c("LOW"), high = c("HIGH")),
+ |
+
| 60 | ++ |
+ #' method = "range",+ |
+
| 61 | ++ |
+ #' na_str = "<Missing>"+ |
+
| 62 | ++ |
+ #' )+ |
+
| 63 | ++ |
+ #'+ |
+
| 64 | ++ |
+ #' @export+ |
+
| 65 | ++ |
+ h_map_for_count_abnormal <- function(df,+ |
+
| 66 | ++ |
+ variables = list(+ |
+
| 67 | ++ |
+ anl = "ANRIND",+ |
+
| 68 | ++ |
+ split_rows = c("PARAM"),
+ |
+
| 69 | ++ |
+ range_low = "ANRLO",+ |
+
| 70 | ++ |
+ range_high = "ANRHI"+ |
+
| 71 | ++ |
+ ),+ |
+
| 72 | ++ |
+ abnormal = list(low = c("LOW", "LOW LOW"), high = c("HIGH", "HIGH HIGH")),
+ |
+
| 73 | ++ |
+ method = c("default", "range"),
+ |
+
| 74 | ++ |
+ na_level = lifecycle::deprecated(),+ |
+
| 75 | ++ |
+ na_str = "<Missing>") {
+ |
+
| 76 | +7x | +
+ if (lifecycle::is_present(na_level)) {
+ |
+
| 77 | +! | +
+ lifecycle::deprecate_warn("0.9.1", "h_map_for_count_abnormal(na_level)", "h_map_for_count_abnormal(na_str)")
+ |
+
| 78 | +! | +
+ na_str <- na_level+ |
+
| 79 | ++ |
+ }+ |
+
| 80 | ++ | + + | +
| 81 | +7x | +
+ method <- match.arg(method)+ |
+
| 82 | +7x | +
+ checkmate::assert_subset(c("anl", "split_rows"), names(variables))
+ |
+
| 83 | +7x | +
+ checkmate::assert_false(anyNA(df[variables$split_rows]))+ |
+
| 84 | +7x | +
+ assert_df_with_variables(df,+ |
+
| 85 | +7x | +
+ variables = list(anl = variables$anl, split_rows = variables$split_rows),+ |
+
| 86 | +7x | +
+ na_level = na_str+ |
+
| 87 | ++ |
+ )+ |
+
| 88 | +7x | +
+ assert_df_with_factors(df, list(val = variables$anl))+ |
+
| 89 | +7x | +
+ assert_valid_factor(df[[variables$anl]], any.missing = FALSE)+ |
+
| 90 | +7x | +
+ assert_list_of_variables(variables)+ |
+
| 91 | +7x | +
+ checkmate::assert_list(abnormal, types = "character", len = 2)+ |
+
| 92 | ++ | + + | +
| 93 | ++ |
+ # Drop usued levels from df as they are not supposed to be in the final map+ |
+
| 94 | +7x | +
+ df <- droplevels(df)+ |
+
| 95 | ++ | + + | +
| 96 | +7x | +
+ normal_value <- setdiff(levels(df[[variables$anl]]), unlist(abnormal))+ |
+
| 97 | ++ | + + | +
| 98 | ++ |
+ # Based on the understanding of clinical data, there should only be one level of normal which is "NORMAL"+ |
+
| 99 | +7x | +
+ checkmate::assert_vector(normal_value, len = 1)+ |
+
| 100 | ++ | + + | +
| 101 | ++ |
+ # Default method will only have what is observed in the df, and records with all normal values will be excluded to+ |
+
| 102 | ++ |
+ # avoid error in layout building.+ |
+
| 103 | +7x | +
+ if (method == "default") {
+ |
+
| 104 | +3x | +
+ df_abnormal <- subset(df, df[[variables$anl]] %in% unlist(abnormal))+ |
+
| 105 | +3x | +
+ map <- unique(df_abnormal[c(variables$split_rows, variables$anl)])+ |
+
| 106 | +3x | +
+ map_normal <- unique(subset(map, select = variables$split_rows))+ |
+
| 107 | +3x | +
+ map_normal[[variables$anl]] <- normal_value+ |
+
| 108 | +3x | +
+ map <- rbind(map, map_normal)+ |
+
| 109 | +4x | +
+ } else if (method == "range") {
+ |
+
| 110 | ++ |
+ # range method follows the rule that at least one observation with ANRLO > 0 for low+ |
+
| 111 | ++ |
+ # direction and at least one observation with ANRHI is not missing for high direction.+ |
+
| 112 | +4x | +
+ checkmate::assert_subset(c("range_low", "range_high"), names(variables))
+ |
+
| 113 | +4x | +
+ checkmate::assert_subset(c("LOW", "HIGH"), toupper(names(abnormal)))
+ |
+
| 114 | ++ | + + | +
| 115 | +4x | +
+ assert_df_with_variables(df,+ |
+
| 116 | +4x | +
+ variables = list(+ |
+
| 117 | +4x | +
+ range_low = variables$range_low,+ |
+
| 118 | +4x | +
+ range_high = variables$range_high+ |
+
| 119 | ++ |
+ )+ |
+
| 120 | ++ |
+ )+ |
+
| 121 | ++ | + + | +
| 122 | ++ |
+ # Define low direction of map+ |
+
| 123 | +4x | +
+ df_low <- subset(df, df[[variables$range_low]] > 0)+ |
+
| 124 | +4x | +
+ map_low <- unique(df_low[variables$split_rows])+ |
+
| 125 | +4x | +
+ low_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "LOW"]))+ |
+
| 126 | +4x | +
+ low_levels_df <- as.data.frame(low_levels)+ |
+
| 127 | +4x | +
+ colnames(low_levels_df) <- variables$anl+ |
+
| 128 | +4x | +
+ low_levels_df <- do.call("rbind", replicate(nrow(map_low), low_levels_df, simplify = FALSE))
+ |
+
| 129 | +4x | +
+ rownames(map_low) <- NULL # Just to avoid strange row index in case upstream functions changed+ |
+
| 130 | +4x | +
+ map_low <- map_low[rep(seq_len(nrow(map_low)), each = length(low_levels)), , drop = FALSE]+ |
+
| 131 | +4x | +
+ map_low <- cbind(map_low, low_levels_df)+ |
+
| 132 | ++ | + + | +
| 133 | ++ |
+ # Define high direction of map+ |
+
| 134 | +4x | +
+ df_high <- subset(df, df[[variables$range_high]] != na_str | !is.na(df[[variables$range_high]]))+ |
+
| 135 | +4x | +
+ map_high <- unique(df_high[variables$split_rows])+ |
+
| 136 | +4x | +
+ high_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "HIGH"]))+ |
+
| 137 | +4x | +
+ high_levels_df <- as.data.frame(high_levels)+ |
+
| 138 | +4x | +
+ colnames(high_levels_df) <- variables$anl+ |
+
| 139 | +4x | +
+ high_levels_df <- do.call("rbind", replicate(nrow(map_high), high_levels_df, simplify = FALSE))
+ |
+
| 140 | +4x | +
+ rownames(map_high) <- NULL+ |
+
| 141 | +4x | +
+ map_high <- map_high[rep(seq_len(nrow(map_high)), each = length(high_levels)), , drop = FALSE]+ |
+
| 142 | +4x | +
+ map_high <- cbind(map_high, high_levels_df)+ |
+
| 143 | ++ | + + | +
| 144 | ++ |
+ # Define normal of map+ |
+
| 145 | +4x | +
+ map_normal <- unique(rbind(map_low, map_high)[variables$split_rows])+ |
+
| 146 | +4x | +
+ map_normal[variables$anl] <- normal_value+ |
+
| 147 | ++ | + + | +
| 148 | +4x | +
+ map <- rbind(map_low, map_high, map_normal)+ |
+
| 149 | ++ |
+ }+ |
+
| 150 | ++ | + + | +
| 151 | ++ |
+ # map should be all characters+ |
+
| 152 | +7x | +
+ map <- data.frame(lapply(map, as.character), stringsAsFactors = FALSE)+ |
+
| 153 | ++ | + + | +
| 154 | ++ |
+ # sort the map final output by split_rows variables+ |
+
| 155 | +7x | +
+ for (i in rev(seq_len(length(variables$split_rows)))) {
+ |
+
| 156 | +7x | +
+ map <- map[order(map[[i]]), ]+ |
+
| 157 | ++ |
+ }+ |
+
| 158 | +7x | +
+ map+ |
+
| 159 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Control Function for `CoxPH` Model+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' This is an auxiliary function for controlling arguments for `CoxPH` model, typically used internally to specify+ |
+
| 6 | ++ |
+ #' details of `CoxPH` model for [s_coxph_pairwise()]. `conf_level` refers to Hazard Ratio estimation.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #' @param pval_method (`string`)\cr p-value method for testing hazard ratio = 1.+ |
+
| 10 | ++ |
+ #' Default method is `"log-rank"`, can also be set to `"wald"` or `"likelihood"`.+ |
+
| 11 | ++ |
+ #' @param ties (`string`)\cr specifying the method for tie handling. Default is `"efron"`,+ |
+
| 12 | ++ |
+ #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()].+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @return A list of components with the same names as the arguments+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @export+ |
+
| 17 | ++ |
+ control_coxph <- function(pval_method = c("log-rank", "wald", "likelihood"),
+ |
+
| 18 | ++ |
+ ties = c("efron", "breslow", "exact"),
+ |
+
| 19 | ++ |
+ conf_level = 0.95) {
+ |
+
| 20 | +40x | +
+ pval_method <- match.arg(pval_method)+ |
+
| 21 | +39x | +
+ ties <- match.arg(ties)+ |
+
| 22 | +39x | +
+ assert_proportion_value(conf_level)+ |
+
| 23 | ++ | + + | +
| 24 | +38x | +
+ list(pval_method = pval_method, ties = ties, conf_level = conf_level)+ |
+
| 25 | ++ |
+ }+ |
+
| 26 | ++ | + + | +
| 27 | ++ |
+ #' Control Function for `survfit` Model for Survival Time+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' This is an auxiliary function for controlling arguments for `survfit` model, typically used internally to specify+ |
+
| 32 | ++ |
+ #' details of `survfit` model for [s_surv_time()]. `conf_level` refers to survival time estimation.+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 35 | ++ |
+ #' @param conf_type (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log",+ |
+
| 36 | ++ |
+ #' see more in [survival::survfit()]. Note option "none" is no longer supported.+ |
+
| 37 | ++ |
+ #' @param quantiles (`numeric`)\cr of length two to specify the quantiles of survival time.+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' @return A list of components with the same names as the arguments+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' @export+ |
+
| 42 | ++ |
+ control_surv_time <- function(conf_level = 0.95,+ |
+
| 43 | ++ |
+ conf_type = c("plain", "log", "log-log"),
+ |
+
| 44 | ++ |
+ quantiles = c(0.25, 0.75)) {
+ |
+
| 45 | +154x | +
+ conf_type <- match.arg(conf_type)+ |
+
| 46 | +153x | +
+ checkmate::assert_numeric(quantiles, lower = 0, upper = 1, len = 2, unique = TRUE, sorted = TRUE)+ |
+
| 47 | +152x | +
+ nullo <- lapply(quantiles, assert_proportion_value)+ |
+
| 48 | +152x | +
+ assert_proportion_value(conf_level)+ |
+
| 49 | +151x | +
+ list(conf_level = conf_level, conf_type = conf_type, quantiles = quantiles)+ |
+
| 50 | ++ |
+ }+ |
+
| 51 | ++ | + + | +
| 52 | ++ |
+ #' Control Function for `survfit` Model for Patient's Survival Rate at time point+ |
+
| 53 | ++ |
+ #'+ |
+
| 54 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' This is an auxiliary function for controlling arguments for `survfit` model, typically used internally to specify+ |
+
| 57 | ++ |
+ #' details of `survfit` model for [s_surv_timepoint()]. `conf_level` refers to patient risk estimation at a time point.+ |
+
| 58 | ++ |
+ #'+ |
+
| 59 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 60 | ++ |
+ #' @inheritParams control_surv_time+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' @return A list of components with the same names as the arguments+ |
+
| 63 | ++ |
+ #'+ |
+
| 64 | ++ |
+ #' @export+ |
+
| 65 | ++ |
+ control_surv_timepoint <- function(conf_level = 0.95,+ |
+
| 66 | ++ |
+ conf_type = c("plain", "log", "log-log")) {
+ |
+
| 67 | +30x | +
+ conf_type <- match.arg(conf_type)+ |
+
| 68 | +29x | +
+ assert_proportion_value(conf_level)+ |
+
| 69 | +28x | +
+ list(+ |
+
| 70 | +28x | +
+ conf_level = conf_level,+ |
+
| 71 | +28x | +
+ conf_type = conf_type+ |
+
| 72 | ++ |
+ )+ |
+
| 73 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Multivariate Logistic Regression Table+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Layout-creating function which summarizes a logistic variable regression for binary outcome with+ |
+
| 6 | ++ |
+ #' categorical/continuous covariates in model statement. For each covariate category (if categorical)+ |
+
| 7 | ++ |
+ #' or specified values (if continuous), present degrees of freedom, regression parameter estimate and+ |
+
| 8 | ++ |
+ #' standard error (SE) relative to reference group or category. Report odds ratios for each covariate+ |
+
| 9 | ++ |
+ #' category or specified values and corresponding Wald confidence intervals as default but allow user+ |
+
| 10 | ++ |
+ #' to specify other confidence levels. Report p-value for Wald chi-square test of the null hypothesis+ |
+
| 11 | ++ |
+ #' that covariate has no effect on response in model containing all specified covariates.+ |
+
| 12 | ++ |
+ #' Allow option to include one two-way interaction and present similar output for+ |
+
| 13 | ++ |
+ #' each interaction degree of freedom.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 16 | ++ |
+ #' @param drop_and_remove_str (`character`)\cr string to be dropped and removed.+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @return A layout object suitable for passing to further layouting functions, or to [rtables::build_table()].+ |
+
| 19 | ++ |
+ #' Adding this function to an `rtable` layout will add a logistic regression variable summary to the table layout.+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @note For the formula, the variable names need to be standard `data.frame` column names without+ |
+
| 22 | ++ |
+ #' special characters.+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @examples+ |
+
| 25 | ++ |
+ #' library(dplyr)+ |
+
| 26 | ++ |
+ #' library(broom)+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' adrs_f <- tern_ex_adrs %>%+ |
+
| 29 | ++ |
+ #' filter(PARAMCD == "BESRSPI") %>%+ |
+
| 30 | ++ |
+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ |
+
| 31 | ++ |
+ #' mutate(+ |
+
| 32 | ++ |
+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ |
+
| 33 | ++ |
+ #' RACE = factor(RACE),+ |
+
| 34 | ++ |
+ #' SEX = factor(SEX)+ |
+
| 35 | ++ |
+ #' )+ |
+
| 36 | ++ |
+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ |
+
| 37 | ++ |
+ #' mod1 <- fit_logistic(+ |
+
| 38 | ++ |
+ #' data = adrs_f,+ |
+
| 39 | ++ |
+ #' variables = list(+ |
+
| 40 | ++ |
+ #' response = "Response",+ |
+
| 41 | ++ |
+ #' arm = "ARMCD",+ |
+
| 42 | ++ |
+ #' covariates = c("AGE", "RACE")
+ |
+
| 43 | ++ |
+ #' )+ |
+
| 44 | ++ |
+ #' )+ |
+
| 45 | ++ |
+ #' mod2 <- fit_logistic(+ |
+
| 46 | ++ |
+ #' data = adrs_f,+ |
+
| 47 | ++ |
+ #' variables = list(+ |
+
| 48 | ++ |
+ #' response = "Response",+ |
+
| 49 | ++ |
+ #' arm = "ARMCD",+ |
+
| 50 | ++ |
+ #' covariates = c("AGE", "RACE"),
+ |
+
| 51 | ++ |
+ #' interaction = "AGE"+ |
+
| 52 | ++ |
+ #' )+ |
+
| 53 | ++ |
+ #' )+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' df <- tidy(mod1, conf_level = 0.99)+ |
+
| 56 | ++ |
+ #' df2 <- tidy(mod2, conf_level = 0.99)+ |
+
| 57 | ++ |
+ #'+ |
+
| 58 | ++ |
+ #' # flagging empty strings with "_"+ |
+
| 59 | ++ |
+ #' df <- df_explicit_na(df, na_level = "_")+ |
+
| 60 | ++ |
+ #' df2 <- df_explicit_na(df2, na_level = "_")+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' result1 <- basic_table() %>%+ |
+
| 63 | ++ |
+ #' summarize_logistic(+ |
+
| 64 | ++ |
+ #' conf_level = 0.95,+ |
+
| 65 | ++ |
+ #' drop_and_remove_str = "_"+ |
+
| 66 | ++ |
+ #' ) %>%+ |
+
| 67 | ++ |
+ #' build_table(df = df)+ |
+
| 68 | ++ |
+ #' result1+ |
+
| 69 | ++ |
+ #'+ |
+
| 70 | ++ |
+ #' result2 <- basic_table() %>%+ |
+
| 71 | ++ |
+ #' summarize_logistic(+ |
+
| 72 | ++ |
+ #' conf_level = 0.95,+ |
+
| 73 | ++ |
+ #' drop_and_remove_str = "_"+ |
+
| 74 | ++ |
+ #' ) %>%+ |
+
| 75 | ++ |
+ #' build_table(df = df2)+ |
+
| 76 | ++ |
+ #' result2+ |
+
| 77 | ++ |
+ #'+ |
+
| 78 | ++ |
+ #' @export+ |
+
| 79 | ++ |
+ summarize_logistic <- function(lyt,+ |
+
| 80 | ++ |
+ conf_level,+ |
+
| 81 | ++ |
+ drop_and_remove_str = "",+ |
+
| 82 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 83 | ++ |
+ # checks+ |
+
| 84 | +3x | +
+ checkmate::assert_string(drop_and_remove_str)+ |
+
| 85 | ++ | + + | +
| 86 | +3x | +
+ sum_logistic_variable_test <- logistic_summary_by_flag("is_variable_summary")
+ |
+
| 87 | +3x | +
+ sum_logistic_term_estimates <- logistic_summary_by_flag("is_term_summary", .indent_mods = .indent_mods)
+ |
+
| 88 | +3x | +
+ sum_logistic_odds_ratios <- logistic_summary_by_flag("is_reference_summary", .indent_mods = .indent_mods)
+ |
+
| 89 | +3x | +
+ split_fun <- drop_and_remove_levels(drop_and_remove_str)+ |
+
| 90 | ++ | + + | +
| 91 | +3x | +
+ lyt <- logistic_regression_cols(lyt, conf_level = conf_level)+ |
+
| 92 | +3x | +
+ lyt <- split_rows_by(lyt, var = "variable", labels_var = "variable_label", split_fun = split_fun)+ |
+
| 93 | +3x | +
+ lyt <- sum_logistic_variable_test(lyt)+ |
+
| 94 | +3x | +
+ lyt <- split_rows_by(lyt, var = "term", labels_var = "term_label", split_fun = split_fun)+ |
+
| 95 | +3x | +
+ lyt <- sum_logistic_term_estimates(lyt)+ |
+
| 96 | +3x | +
+ lyt <- split_rows_by(lyt, var = "interaction", labels_var = "interaction_label", split_fun = split_fun)+ |
+
| 97 | +3x | +
+ lyt <- split_rows_by(lyt, var = "reference", labels_var = "reference_label", split_fun = split_fun)+ |
+
| 98 | +3x | +
+ lyt <- sum_logistic_odds_ratios(lyt)+ |
+
| 99 | +3x | +
+ lyt+ |
+
| 100 | ++ |
+ }+ |
+
| 101 | ++ | + + | +
| 102 | ++ |
+ #' Fit for Logistic Regression+ |
+
| 103 | ++ |
+ #'+ |
+
| 104 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 105 | ++ |
+ #'+ |
+
| 106 | ++ |
+ #' Fit a (conditional) logistic regression model.+ |
+
| 107 | ++ |
+ #'+ |
+
| 108 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 109 | ++ |
+ #' @param data (`data.frame`)\cr the data frame on which the model was fit.+ |
+
| 110 | ++ |
+ #' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`.+ |
+
| 111 | ++ |
+ #' This will be used when fitting the (conditional) logistic regression model on the left hand+ |
+
| 112 | ++ |
+ #' side of the formula.+ |
+
| 113 | ++ |
+ #'+ |
+
| 114 | ++ |
+ #' @return A fitted logistic regression model.+ |
+
| 115 | ++ |
+ #'+ |
+
| 116 | ++ |
+ #' @section Model Specification:+ |
+
| 117 | ++ |
+ #'+ |
+
| 118 | ++ |
+ #' The `variables` list needs to include the following elements:+ |
+
| 119 | ++ |
+ #' * `arm`: Treatment arm variable name.+ |
+
| 120 | ++ |
+ #' * `response`: The response arm variable name. Usually this is a 0/1 variable.+ |
+
| 121 | ++ |
+ #' * `covariates`: This is either `NULL` (no covariates) or a character vector of covariate variable names.+ |
+
| 122 | ++ |
+ #' * `interaction`: This is either `NULL` (no interaction) or a string of a single covariate variable name already+ |
+
| 123 | ++ |
+ #' included in `covariates`. Then the interaction with the treatment arm is included in the model.+ |
+
| 124 | ++ |
+ #'+ |
+
| 125 | ++ |
+ #' @examples+ |
+
| 126 | ++ |
+ #' library(dplyr)+ |
+
| 127 | ++ |
+ #'+ |
+
| 128 | ++ |
+ #' adrs_f <- tern_ex_adrs %>%+ |
+
| 129 | ++ |
+ #' filter(PARAMCD == "BESRSPI") %>%+ |
+
| 130 | ++ |
+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ |
+
| 131 | ++ |
+ #' mutate(+ |
+
| 132 | ++ |
+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ |
+
| 133 | ++ |
+ #' RACE = factor(RACE),+ |
+
| 134 | ++ |
+ #' SEX = factor(SEX)+ |
+
| 135 | ++ |
+ #' )+ |
+
| 136 | ++ |
+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ |
+
| 137 | ++ |
+ #' mod1 <- fit_logistic(+ |
+
| 138 | ++ |
+ #' data = adrs_f,+ |
+
| 139 | ++ |
+ #' variables = list(+ |
+
| 140 | ++ |
+ #' response = "Response",+ |
+
| 141 | ++ |
+ #' arm = "ARMCD",+ |
+
| 142 | ++ |
+ #' covariates = c("AGE", "RACE")
+ |
+
| 143 | ++ |
+ #' )+ |
+
| 144 | ++ |
+ #' )+ |
+
| 145 | ++ |
+ #' mod2 <- fit_logistic(+ |
+
| 146 | ++ |
+ #' data = adrs_f,+ |
+
| 147 | ++ |
+ #' variables = list(+ |
+
| 148 | ++ |
+ #' response = "Response",+ |
+
| 149 | ++ |
+ #' arm = "ARMCD",+ |
+
| 150 | ++ |
+ #' covariates = c("AGE", "RACE"),
+ |
+
| 151 | ++ |
+ #' interaction = "AGE"+ |
+
| 152 | ++ |
+ #' )+ |
+
| 153 | ++ |
+ #' )+ |
+
| 154 | ++ |
+ #'+ |
+
| 155 | ++ |
+ #' @export+ |
+
| 156 | ++ |
+ fit_logistic <- function(data,+ |
+
| 157 | ++ |
+ variables = list(+ |
+
| 158 | ++ |
+ response = "Response",+ |
+
| 159 | ++ |
+ arm = "ARMCD",+ |
+
| 160 | ++ |
+ covariates = NULL,+ |
+
| 161 | ++ |
+ interaction = NULL,+ |
+
| 162 | ++ |
+ strata = NULL+ |
+
| 163 | ++ |
+ ),+ |
+
| 164 | ++ |
+ response_definition = "response") {
+ |
+
| 165 | +62x | +
+ assert_df_with_variables(data, variables)+ |
+
| 166 | +62x | +
+ checkmate::assert_subset(names(variables), c("response", "arm", "covariates", "interaction", "strata"))
+ |
+
| 167 | +62x | +
+ checkmate::assert_string(response_definition)+ |
+
| 168 | +62x | +
+ checkmate::assert_true(grepl("response", response_definition))
+ |
+
| 169 | ++ | + + | +
| 170 | +62x | +
+ response_definition <- sub(+ |
+
| 171 | +62x | +
+ pattern = "response",+ |
+
| 172 | +62x | +
+ replacement = variables$response,+ |
+
| 173 | +62x | +
+ x = response_definition,+ |
+
| 174 | +62x | +
+ fixed = TRUE+ |
+
| 175 | ++ |
+ )+ |
+
| 176 | +62x | +
+ form <- paste0(response_definition, " ~ ", variables$arm)+ |
+
| 177 | +62x | +
+ if (!is.null(variables$covariates)) {
+ |
+
| 178 | +28x | +
+ form <- paste0(form, " + ", paste(variables$covariates, collapse = " + "))+ |
+
| 179 | ++ |
+ }+ |
+
| 180 | +62x | +
+ if (!is.null(variables$interaction)) {
+ |
+
| 181 | +17x | +
+ checkmate::assert_string(variables$interaction)+ |
+
| 182 | +17x | +
+ checkmate::assert_subset(variables$interaction, variables$covariates)+ |
+
| 183 | +17x | +
+ form <- paste0(form, " + ", variables$arm, ":", variables$interaction)+ |
+
| 184 | ++ |
+ }+ |
+
| 185 | +62x | +
+ if (!is.null(variables$strata)) {
+ |
+
| 186 | +14x | +
+ strata_arg <- if (length(variables$strata) > 1) {
+ |
+
| 187 | +7x | +
+ paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
+ |
+
| 188 | ++ |
+ } else {
+ |
+
| 189 | +7x | +
+ variables$strata+ |
+
| 190 | ++ |
+ }+ |
+
| 191 | +14x | +
+ form <- paste0(form, "+ strata(", strata_arg, ")")
+ |
+
| 192 | ++ |
+ }+ |
+
| 193 | +62x | +
+ formula <- stats::as.formula(form)+ |
+
| 194 | +62x | +
+ if (is.null(variables$strata)) {
+ |
+
| 195 | +48x | +
+ stats::glm(+ |
+
| 196 | +48x | +
+ formula = formula,+ |
+
| 197 | +48x | +
+ data = data,+ |
+
| 198 | +48x | +
+ family = stats::binomial("logit")
+ |
+
| 199 | ++ |
+ )+ |
+
| 200 | ++ |
+ } else {
+ |
+
| 201 | +14x | +
+ clogit_with_tryCatch(+ |
+
| 202 | +14x | +
+ formula = formula,+ |
+
| 203 | +14x | +
+ data = data,+ |
+
| 204 | +14x | +
+ x = TRUE+ |
+
| 205 | ++ |
+ )+ |
+
| 206 | ++ |
+ }+ |
+
| 207 | ++ |
+ }+ |
+
| 208 | ++ | + + | +
| 209 | ++ |
+ #' Custom Tidy Method for Binomial GLM Results+ |
+
| 210 | ++ |
+ #'+ |
+
| 211 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 212 | ++ |
+ #'+ |
+
| 213 | ++ |
+ #' Helper method (for [broom::tidy()]) to prepare a data frame from a `glm` object+ |
+
| 214 | ++ |
+ #' with `binomial` family.+ |
+
| 215 | ++ |
+ #'+ |
+
| 216 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 217 | ++ |
+ #' @param at (`NULL` or `numeric`)\cr optional values for the interaction variable. Otherwise the median is used.+ |
+
| 218 | ++ |
+ #' @param x logistic regression model fitted by [stats::glm()] with "binomial" family.+ |
+
| 219 | ++ |
+ #'+ |
+
| 220 | ++ |
+ #' @return A `data.frame` containing the tidied model.+ |
+
| 221 | ++ |
+ #'+ |
+
| 222 | ++ |
+ #' @method tidy glm+ |
+
| 223 | ++ |
+ #'+ |
+
| 224 | ++ |
+ #' @seealso [h_logistic_regression] for relevant helper functions.+ |
+
| 225 | ++ |
+ #'+ |
+
| 226 | ++ |
+ #' @examples+ |
+
| 227 | ++ |
+ #' library(dplyr)+ |
+
| 228 | ++ |
+ #' library(broom)+ |
+
| 229 | ++ |
+ #'+ |
+
| 230 | ++ |
+ #' adrs_f <- tern_ex_adrs %>%+ |
+
| 231 | ++ |
+ #' filter(PARAMCD == "BESRSPI") %>%+ |
+
| 232 | ++ |
+ #' filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
+ |
+
| 233 | ++ |
+ #' mutate(+ |
+
| 234 | ++ |
+ #' Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ |
+
| 235 | ++ |
+ #' RACE = factor(RACE),+ |
+
| 236 | ++ |
+ #' SEX = factor(SEX)+ |
+
| 237 | ++ |
+ #' )+ |
+
| 238 | ++ |
+ #' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")+ |
+
| 239 | ++ |
+ #' mod1 <- fit_logistic(+ |
+
| 240 | ++ |
+ #' data = adrs_f,+ |
+
| 241 | ++ |
+ #' variables = list(+ |
+
| 242 | ++ |
+ #' response = "Response",+ |
+
| 243 | ++ |
+ #' arm = "ARMCD",+ |
+
| 244 | ++ |
+ #' covariates = c("AGE", "RACE")
+ |
+
| 245 | ++ |
+ #' )+ |
+
| 246 | ++ |
+ #' )+ |
+
| 247 | ++ |
+ #' mod2 <- fit_logistic(+ |
+
| 248 | ++ |
+ #' data = adrs_f,+ |
+
| 249 | ++ |
+ #' variables = list(+ |
+
| 250 | ++ |
+ #' response = "Response",+ |
+
| 251 | ++ |
+ #' arm = "ARMCD",+ |
+
| 252 | ++ |
+ #' covariates = c("AGE", "RACE"),
+ |
+
| 253 | ++ |
+ #' interaction = "AGE"+ |
+
| 254 | ++ |
+ #' )+ |
+
| 255 | ++ |
+ #' )+ |
+
| 256 | ++ |
+ #'+ |
+
| 257 | ++ |
+ #' df <- tidy(mod1, conf_level = 0.99)+ |
+
| 258 | ++ |
+ #' df2 <- tidy(mod2, conf_level = 0.99)+ |
+
| 259 | ++ |
+ #'+ |
+
| 260 | ++ |
+ #' @export+ |
+
| 261 | ++ |
+ tidy.glm <- function(x, # nolint+ |
+
| 262 | ++ |
+ conf_level = 0.95,+ |
+
| 263 | ++ |
+ at = NULL,+ |
+
| 264 | ++ |
+ ...) {
+ |
+
| 265 | +5x | +
+ checkmate::assert_class(x, "glm")+ |
+
| 266 | +5x | +
+ checkmate::assert_set_equal(x$family$family, "binomial")+ |
+
| 267 | ++ | + + | +
| 268 | +5x | +
+ terms_name <- attr(stats::terms(x), "term.labels")+ |
+
| 269 | +5x | +
+ xs_class <- attr(x$terms, "dataClasses")+ |
+
| 270 | +5x | +
+ interaction <- terms_name[which(!terms_name %in% names(xs_class))]+ |
+
| 271 | +5x | +
+ df <- if (length(interaction) == 0) {
+ |
+
| 272 | +2x | +
+ h_logistic_simple_terms(+ |
+
| 273 | +2x | +
+ x = terms_name,+ |
+
| 274 | +2x | +
+ fit_glm = x,+ |
+
| 275 | +2x | +
+ conf_level = conf_level+ |
+
| 276 | ++ |
+ )+ |
+
| 277 | ++ |
+ } else {
+ |
+
| 278 | +3x | +
+ h_logistic_inter_terms(+ |
+
| 279 | +3x | +
+ x = terms_name,+ |
+
| 280 | +3x | +
+ fit_glm = x,+ |
+
| 281 | +3x | +
+ conf_level = conf_level,+ |
+
| 282 | +3x | +
+ at = at+ |
+
| 283 | ++ |
+ )+ |
+
| 284 | ++ |
+ }+ |
+
| 285 | +5x | +
+ for (var in c("variable", "term", "interaction", "reference")) {
+ |
+
| 286 | +20x | +
+ df[[var]] <- factor(df[[var]], levels = unique(df[[var]]))+ |
+
| 287 | ++ |
+ }+ |
+
| 288 | +5x | +
+ df+ |
+
| 289 | ++ |
+ }+ |
+
| 290 | ++ | + + | +
| 291 | ++ |
+ #' Logistic Regression Multivariate Column Layout Function+ |
+
| 292 | ++ |
+ #'+ |
+
| 293 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 294 | ++ |
+ #'+ |
+
| 295 | ++ |
+ #' Layout-creating function which creates a multivariate column layout summarizing logistic+ |
+
| 296 | ++ |
+ #' regression results. This function is a wrapper for [rtables::split_cols_by_multivar()].+ |
+
| 297 | ++ |
+ #'+ |
+
| 298 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 299 | ++ |
+ #'+ |
+
| 300 | ++ |
+ #' @return A layout object suitable for passing to further layouting functions. Adding this+ |
+
| 301 | ++ |
+ #' function to an `rtable` layout will split the table into columns corresponding to+ |
+
| 302 | ++ |
+ #' statistics `df`, `estimate`, `std_error`, `odds_ratio`, `ci`, and `pvalue`.+ |
+
| 303 | ++ |
+ #'+ |
+
| 304 | ++ |
+ #' @export+ |
+
| 305 | ++ |
+ logistic_regression_cols <- function(lyt,+ |
+
| 306 | ++ |
+ conf_level = 0.95) {
+ |
+
| 307 | +4x | +
+ vars <- c("df", "estimate", "std_error", "odds_ratio", "ci", "pvalue")
+ |
+
| 308 | +4x | +
+ var_labels <- c(+ |
+
| 309 | +4x | +
+ df = "Degrees of Freedom",+ |
+
| 310 | +4x | +
+ estimate = "Parameter Estimate",+ |
+
| 311 | +4x | +
+ std_error = "Standard Error",+ |
+
| 312 | +4x | +
+ odds_ratio = "Odds Ratio",+ |
+
| 313 | +4x | +
+ ci = paste("Wald", f_conf_level(conf_level)),
+ |
+
| 314 | +4x | +
+ pvalue = "p-value"+ |
+
| 315 | ++ |
+ )+ |
+
| 316 | +4x | +
+ split_cols_by_multivar(+ |
+
| 317 | +4x | +
+ lyt = lyt,+ |
+
| 318 | +4x | +
+ vars = vars,+ |
+
| 319 | +4x | +
+ varlabels = var_labels+ |
+
| 320 | ++ |
+ )+ |
+
| 321 | ++ |
+ }+ |
+
| 322 | ++ | + + | +
| 323 | ++ |
+ #' Logistic Regression Summary Table Constructor Function+ |
+
| 324 | ++ |
+ #'+ |
+
| 325 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 326 | ++ |
+ #'+ |
+
| 327 | ++ |
+ #' Constructor for content functions to be used in [`summarize_logistic()`] to summarize+ |
+
| 328 | ++ |
+ #' logistic regression results. This function is a wrapper for [rtables::summarize_row_groups()].+ |
+
| 329 | ++ |
+ #'+ |
+
| 330 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 331 | ++ |
+ #' @param flag_var (`string`)\cr variable name identifying which row should be used in this+ |
+
| 332 | ++ |
+ #' content function.+ |
+
| 333 | ++ |
+ #'+ |
+
| 334 | ++ |
+ #' @return A content function.+ |
+
| 335 | ++ |
+ #'+ |
+
| 336 | ++ |
+ #' @export+ |
+
| 337 | ++ |
+ logistic_summary_by_flag <- function(flag_var, na_str = NA_character_, .indent_mods = NULL) {
+ |
+
| 338 | +10x | +
+ checkmate::assert_string(flag_var)+ |
+
| 339 | +10x | +
+ function(lyt) {
+ |
+
| 340 | +10x | +
+ cfun_list <- list(+ |
+
| 341 | +10x | +
+ df = cfun_by_flag("df", flag_var, format = "xx.", .indent_mods = .indent_mods),
+ |
+
| 342 | +10x | +
+ estimate = cfun_by_flag("estimate", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
+ |
+
| 343 | +10x | +
+ std_error = cfun_by_flag("std_error", flag_var, format = "xx.xxx", .indent_mods = .indent_mods),
+ |
+
| 344 | +10x | +
+ odds_ratio = cfun_by_flag("odds_ratio", flag_var, format = ">999.99", .indent_mods = .indent_mods),
+ |
+
| 345 | +10x | +
+ ci = cfun_by_flag("ci", flag_var, format = format_extreme_values_ci(2L), .indent_mods = .indent_mods),
+ |
+
| 346 | +10x | +
+ pvalue = cfun_by_flag("pvalue", flag_var, format = "x.xxxx | (<0.0001)", .indent_mods = .indent_mods)
+ |
+
| 347 | ++ |
+ )+ |
+
| 348 | +10x | +
+ summarize_row_groups(+ |
+
| 349 | +10x | +
+ lyt = lyt,+ |
+
| 350 | +10x | +
+ cfun = cfun_list,+ |
+
| 351 | +10x | +
+ na_str = na_str+ |
+
| 352 | ++ |
+ )+ |
+
| 353 | ++ |
+ }+ |
+
| 354 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Subgroup Treatment Effect Pattern (STEP) Fit for Survival Outcome+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' This fits the Subgroup Treatment Effect Pattern models for a survival outcome. The treatment arm+ |
+
| 6 | ++ |
+ #' variable must have exactly 2 levels, where the first one is taken as reference and the estimated+ |
+
| 7 | ++ |
+ #' hazard ratios are for the comparison of the second level vs. the first one.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' The model which is fit is:+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' `Surv(time, event) ~ arm * poly(biomarker, degree) + covariates + strata(strata)`+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' where `degree` is specified by `control_step()`.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 16 | ++ |
+ #' @param variables (named `list` of `character`)\cr list of analysis variables: needs `time`, `event`,+ |
+
| 17 | ++ |
+ #' `arm`, `biomarker`, and optional `covariates` and `strata`.+ |
+
| 18 | ++ |
+ #' @param control (named `list`)\cr combined control list from [control_step()] and [control_coxph()].+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @return A matrix of class `step`. The first part of the columns describe the subgroup intervals used+ |
+
| 21 | ++ |
+ #' for the biomarker variable, including where the center of the intervals are and their bounds. The+ |
+
| 22 | ++ |
+ #' second part of the columns contain the estimates for the treatment arm comparison.+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @note For the default degree 0 the `biomarker` variable is not included in the model.+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' @seealso [control_step()] and [control_coxph()] for the available customization options.+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @examples+ |
+
| 29 | ++ |
+ #' # Testing dataset with just two treatment arms.+ |
+
| 30 | ++ |
+ #' library(dplyr)+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' adtte_f <- tern_ex_adtte %>%+ |
+
| 33 | ++ |
+ #' filter(+ |
+
| 34 | ++ |
+ #' PARAMCD == "OS",+ |
+
| 35 | ++ |
+ #' ARM %in% c("B: Placebo", "A: Drug X")
+ |
+
| 36 | ++ |
+ #' ) %>%+ |
+
| 37 | ++ |
+ #' mutate(+ |
+
| 38 | ++ |
+ #' # Reorder levels of ARM to display reference arm before treatment arm.+ |
+
| 39 | ++ |
+ #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")),+ |
+
| 40 | ++ |
+ #' is_event = CNSR == 0+ |
+
| 41 | ++ |
+ #' )+ |
+
| 42 | ++ |
+ #' labels <- c("ARM" = "Treatment Arm", "is_event" = "Event Flag")
+ |
+
| 43 | ++ |
+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' variables <- list(+ |
+
| 46 | ++ |
+ #' arm = "ARM",+ |
+
| 47 | ++ |
+ #' biomarker = "BMRKR1",+ |
+
| 48 | ++ |
+ #' covariates = c("AGE", "BMRKR2"),
+ |
+
| 49 | ++ |
+ #' event = "is_event",+ |
+
| 50 | ++ |
+ #' time = "AVAL"+ |
+
| 51 | ++ |
+ #' )+ |
+
| 52 | ++ |
+ #'+ |
+
| 53 | ++ |
+ #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup.+ |
+
| 54 | ++ |
+ #' step_matrix <- fit_survival_step(+ |
+
| 55 | ++ |
+ #' variables = variables,+ |
+
| 56 | ++ |
+ #' data = adtte_f+ |
+
| 57 | ++ |
+ #' )+ |
+
| 58 | ++ |
+ #' dim(step_matrix)+ |
+
| 59 | ++ |
+ #' head(step_matrix)+ |
+
| 60 | ++ |
+ #'+ |
+
| 61 | ++ |
+ #' # Specify different polynomial degree for the biomarker interaction to use more flexible local+ |
+
| 62 | ++ |
+ #' # models. Or specify different Cox regression options.+ |
+
| 63 | ++ |
+ #' step_matrix2 <- fit_survival_step(+ |
+
| 64 | ++ |
+ #' variables = variables,+ |
+
| 65 | ++ |
+ #' data = adtte_f,+ |
+
| 66 | ++ |
+ #' control = c(control_coxph(conf_level = 0.9), control_step(degree = 2))+ |
+
| 67 | ++ |
+ #' )+ |
+
| 68 | ++ |
+ #'+ |
+
| 69 | ++ |
+ #' # Use a global model with cubic interaction and only 5 points.+ |
+
| 70 | ++ |
+ #' step_matrix3 <- fit_survival_step(+ |
+
| 71 | ++ |
+ #' variables = variables,+ |
+
| 72 | ++ |
+ #' data = adtte_f,+ |
+
| 73 | ++ |
+ #' control = c(control_coxph(), control_step(bandwidth = NULL, degree = 3, num_points = 5L))+ |
+
| 74 | ++ |
+ #' )+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ #' @export+ |
+
| 77 | ++ |
+ fit_survival_step <- function(variables,+ |
+
| 78 | ++ |
+ data,+ |
+
| 79 | ++ |
+ control = c(control_step(), control_coxph())) {
+ |
+
| 80 | +4x | +
+ checkmate::assert_list(control)+ |
+
| 81 | +4x | +
+ assert_df_with_variables(data, variables)+ |
+
| 82 | +4x | +
+ data <- data[!is.na(data[[variables$biomarker]]), ]+ |
+
| 83 | +4x | +
+ window_sel <- h_step_window(x = data[[variables$biomarker]], control = control)+ |
+
| 84 | +4x | +
+ interval_center <- window_sel$interval[, "Interval Center"]+ |
+
| 85 | +4x | +
+ form <- h_step_survival_formula(variables = variables, control = control)+ |
+
| 86 | +4x | +
+ estimates <- if (is.null(control$bandwidth)) {
+ |
+
| 87 | +1x | +
+ h_step_survival_est(+ |
+
| 88 | +1x | +
+ formula = form,+ |
+
| 89 | +1x | +
+ data = data,+ |
+
| 90 | +1x | +
+ variables = variables,+ |
+
| 91 | +1x | +
+ x = interval_center,+ |
+
| 92 | +1x | +
+ control = control+ |
+
| 93 | ++ |
+ )+ |
+
| 94 | ++ |
+ } 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 | +3x | +
+ control = control+ |
+
| 104 | ++ |
+ )+ |
+
| 105 | ++ |
+ )+ |
+
| 106 | ++ |
+ # Maybe we find a more elegant solution than this.+ |
+
| 107 | +3x | +
+ rownames(tmp) <- c("n", "events", "loghr", "se", "ci_lower", "ci_upper")
+ |
+
| 108 | +3x | +
+ t(tmp)+ |
+
| 109 | ++ |
+ }+ |
+
| 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 | ++ |
+ )+ |
+
| 117 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Horizontal Waterfall Plot+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' This basic waterfall plot visualizes a quantity `height` ordered by value with some markup.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param height (`numeric``)\cr vector containing values to be plotted as the waterfall bars.+ |
+
| 8 | ++ |
+ #' @param id (`character`)\cr vector containing IDs to use as the x-axis label for the waterfall bars.+ |
+
| 9 | ++ |
+ #' @param col (`character`)\cr colors.+ |
+
| 10 | ++ |
+ #' @param col_var (`factor`, `character` or `NULL`)\cr categorical variable for bar coloring. `NULL` by default.+ |
+
| 11 | ++ |
+ #' @param xlab (`character`)\cr x label. Default is `"ID"`.+ |
+
| 12 | ++ |
+ #' @param ylab (`character`)\cr y label. Default is `"Value"`.+ |
+
| 13 | ++ |
+ #' @param title (`character`)\cr text to be displayed as plot title.+ |
+
| 14 | ++ |
+ #' @param col_legend_title (`character`)\cr text to be displayed as legend title.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @return A `ggplot` waterfall plot.+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @examples+ |
+
| 19 | ++ |
+ #' library(dplyr)+ |
+
| 20 | ++ |
+ #' library(nestcolor)+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' g_waterfall(height = c(3, 5, -1), id = letters[1:3])+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' g_waterfall(+ |
+
| 25 | ++ |
+ #' height = c(3, 5, -1),+ |
+
| 26 | ++ |
+ #' id = letters[1:3],+ |
+
| 27 | ++ |
+ #' col_var = letters[1:3]+ |
+
| 28 | ++ |
+ #' )+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' adsl_f <- tern_ex_adsl %>%+ |
+
| 31 | ++ |
+ #' select(USUBJID, STUDYID, ARM, ARMCD, SEX)+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' adrs_f <- tern_ex_adrs %>%+ |
+
| 34 | ++ |
+ #' filter(PARAMCD == "OVRINV") %>%+ |
+
| 35 | ++ |
+ #' mutate(pchg = rnorm(n(), 10, 50))+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' adrs_f <- head(adrs_f, 30)+ |
+
| 38 | ++ |
+ #' adrs_f <- adrs_f[!duplicated(adrs_f$USUBJID), ]+ |
+
| 39 | ++ |
+ #' head(adrs_f)+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' g_waterfall(+ |
+
| 42 | ++ |
+ #' height = adrs_f$pchg,+ |
+
| 43 | ++ |
+ #' id = adrs_f$USUBJID,+ |
+
| 44 | ++ |
+ #' col_var = adrs_f$AVALC+ |
+
| 45 | ++ |
+ #' )+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ #' g_waterfall(+ |
+
| 48 | ++ |
+ #' height = adrs_f$pchg,+ |
+
| 49 | ++ |
+ #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
+ |
+
| 50 | ++ |
+ #' col_var = adrs_f$SEX+ |
+
| 51 | ++ |
+ #' )+ |
+
| 52 | ++ |
+ #'+ |
+
| 53 | ++ |
+ #' g_waterfall(+ |
+
| 54 | ++ |
+ #' height = adrs_f$pchg,+ |
+
| 55 | ++ |
+ #' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
+ |
+
| 56 | ++ |
+ #' xlab = "ID",+ |
+
| 57 | ++ |
+ #' ylab = "Percentage Change",+ |
+
| 58 | ++ |
+ #' title = "Waterfall plot"+ |
+
| 59 | ++ |
+ #' )+ |
+
| 60 | ++ |
+ #'+ |
+
| 61 | ++ |
+ #' @export+ |
+
| 62 | ++ |
+ g_waterfall <- function(height,+ |
+
| 63 | ++ |
+ id,+ |
+
| 64 | ++ |
+ col_var = NULL,+ |
+
| 65 | ++ |
+ col = getOption("ggplot2.discrete.colour"),
+ |
+
| 66 | ++ |
+ xlab = NULL,+ |
+
| 67 | ++ |
+ ylab = NULL,+ |
+
| 68 | ++ |
+ col_legend_title = NULL,+ |
+
| 69 | ++ |
+ title = NULL) {
+ |
+
| 70 | +2x | +
+ if (!is.null(col_var)) {
+ |
+
| 71 | +1x | +
+ check_same_n(height = height, id = id, col_var = col_var)+ |
+
| 72 | ++ |
+ } else {
+ |
+
| 73 | +1x | +
+ check_same_n(height = height, id = id)+ |
+
| 74 | ++ |
+ }+ |
+
| 75 | ++ | + + | +
| 76 | +2x | +
+ checkmate::assert_multi_class(col_var, c("character", "factor"), null.ok = TRUE)
+ |
+
| 77 | +2x | +
+ checkmate::assert_character(col, null.ok = TRUE)+ |
+
| 78 | ++ | + + | +
| 79 | +2x | +
+ xlabel <- deparse(substitute(id))+ |
+
| 80 | +2x | +
+ ylabel <- deparse(substitute(height))+ |
+
| 81 | ++ | + + | +
| 82 | +2x | +
+ col_label <- if (!missing(col_var)) {
+ |
+
| 83 | +1x | +
+ deparse(substitute(col_var))+ |
+
| 84 | ++ |
+ }+ |
+
| 85 | ++ | + + | +
| 86 | +2x | +
+ xlab <- if (is.null(xlab)) xlabel else xlab+ |
+
| 87 | +2x | +
+ ylab <- if (is.null(ylab)) ylabel else ylab+ |
+
| 88 | +2x | +
+ col_legend_title <- if (is.null(col_legend_title)) col_label else col_legend_title+ |
+
| 89 | ++ | + + | +
| 90 | +2x | +
+ plot_data <- data.frame(+ |
+
| 91 | +2x | +
+ height = height,+ |
+
| 92 | +2x | +
+ id = as.character(id),+ |
+
| 93 | +2x | +
+ col_var = if (is.null(col_var)) "x" else to_n(col_var, length(height)),+ |
+
| 94 | +2x | +
+ stringsAsFactors = FALSE+ |
+
| 95 | ++ |
+ )+ |
+
| 96 | ++ | + + | +
| 97 | +2x | +
+ plot_data_ord <- plot_data[order(plot_data$height, decreasing = TRUE), ]+ |
+
| 98 | ++ | + + | +
| 99 | +2x | +
+ p <- ggplot2::ggplot(plot_data_ord, ggplot2::aes(x = factor(id, levels = id), y = height)) ++ |
+
| 100 | +2x | +
+ ggplot2::geom_col() ++ |
+
| 101 | +2x | +
+ ggplot2::geom_text(+ |
+
| 102 | +2x | +
+ label = format(plot_data_ord$height, digits = 2),+ |
+
| 103 | +2x | +
+ vjust = ifelse(plot_data_ord$height >= 0, -0.5, 1.5)+ |
+
| 104 | ++ |
+ ) ++ |
+
| 105 | +2x | +
+ ggplot2::xlab(xlab) ++ |
+
| 106 | +2x | +
+ ggplot2::ylab(ylab) ++ |
+
| 107 | +2x | +
+ ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 0, vjust = .5))+ |
+
| 108 | ++ | + + | +
| 109 | +2x | +
+ if (!is.null(col_var)) {
+ |
+
| 110 | +1x | +
+ p <- p ++ |
+
| 111 | +1x | +
+ ggplot2::aes(fill = col_var) ++ |
+
| 112 | +1x | +
+ ggplot2::labs(fill = col_legend_title) ++ |
+
| 113 | +1x | +
+ ggplot2::theme(+ |
+
| 114 | +1x | +
+ legend.position = "bottom",+ |
+
| 115 | +1x | +
+ legend.background = ggplot2::element_blank(),+ |
+
| 116 | +1x | +
+ legend.title = ggplot2::element_text(face = "bold"),+ |
+
| 117 | +1x | +
+ legend.box.background = ggplot2::element_rect(colour = "black")+ |
+
| 118 | ++ |
+ )+ |
+
| 119 | ++ |
+ }+ |
+
| 120 | ++ | + + | +
| 121 | +2x | +
+ if (!is.null(col)) {
+ |
+
| 122 | +1x | +
+ p <- p ++ |
+
| 123 | +1x | +
+ ggplot2::scale_fill_manual(values = col)+ |
+
| 124 | ++ |
+ }+ |
+
| 125 | ++ | + + | +
| 126 | +2x | +
+ if (!is.null(title)) {
+ |
+
| 127 | +1x | +
+ p <- p ++ |
+
| 128 | +1x | +
+ ggplot2::labs(title = title) ++ |
+
| 129 | +1x | +
+ ggplot2::theme(plot.title = ggplot2::element_text(face = "bold"))+ |
+
| 130 | ++ |
+ }+ |
+
| 131 | ++ | + + | +
| 132 | +2x | +
+ p+ |
+
| 133 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Create a STEP Graph+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Based on the STEP results, creates a `ggplot` graph showing the estimated HR or OR+ |
+
| 6 | ++ |
+ #' along the continuous biomarker value subgroups.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @param df (`tibble`)\cr result of [tidy.step()].+ |
+
| 9 | ++ |
+ #' @param use_percentile (`flag`)\cr whether to use percentiles for the x axis or actual+ |
+
| 10 | ++ |
+ #' biomarker values.+ |
+
| 11 | ++ |
+ #' @param est (named `list`)\cr `col` and `lty` settings for estimate line.+ |
+
| 12 | ++ |
+ #' @param ci_ribbon (named `list` or `NULL`)\cr `fill` and `alpha` settings for the confidence interval+ |
+
| 13 | ++ |
+ #' ribbon area, or `NULL` to not plot a CI ribbon.+ |
+
| 14 | ++ |
+ #' @param col (`character`)\cr colors.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @return A `ggplot` STEP graph.+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @seealso Custom tidy method [tidy.step()].+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @examples+ |
+
| 21 | ++ |
+ #' library(nestcolor)+ |
+
| 22 | ++ |
+ #' library(survival)+ |
+
| 23 | ++ |
+ #' lung$sex <- factor(lung$sex)+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' # Survival example.+ |
+
| 26 | ++ |
+ #' vars <- list(+ |
+
| 27 | ++ |
+ #' time = "time",+ |
+
| 28 | ++ |
+ #' event = "status",+ |
+
| 29 | ++ |
+ #' arm = "sex",+ |
+
| 30 | ++ |
+ #' biomarker = "age"+ |
+
| 31 | ++ |
+ #' )+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' step_matrix <- fit_survival_step(+ |
+
| 34 | ++ |
+ #' variables = vars,+ |
+
| 35 | ++ |
+ #' data = lung,+ |
+
| 36 | ++ |
+ #' control = c(control_coxph(), control_step(num_points = 10, degree = 2))+ |
+
| 37 | ++ |
+ #' )+ |
+
| 38 | ++ |
+ #' step_data <- broom::tidy(step_matrix)+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' # Default plot.+ |
+
| 41 | ++ |
+ #' g_step(step_data)+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' # Add the reference 1 horizontal line.+ |
+
| 44 | ++ |
+ #' library(ggplot2)+ |
+
| 45 | ++ |
+ #' g_step(step_data) ++ |
+
| 46 | ++ |
+ #' ggplot2::geom_hline(ggplot2::aes(yintercept = 1), linetype = 2)+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ #' # Use actual values instead of percentiles, different color for estimate and no CI,+ |
+
| 49 | ++ |
+ #' # use log scale for y axis.+ |
+
| 50 | ++ |
+ #' g_step(+ |
+
| 51 | ++ |
+ #' step_data,+ |
+
| 52 | ++ |
+ #' use_percentile = FALSE,+ |
+
| 53 | ++ |
+ #' est = list(col = "blue", lty = 1),+ |
+
| 54 | ++ |
+ #' ci_ribbon = NULL+ |
+
| 55 | ++ |
+ #' ) + scale_y_log10()+ |
+
| 56 | ++ |
+ #'+ |
+
| 57 | ++ |
+ #' # Adding another curve based on additional column.+ |
+
| 58 | ++ |
+ #' step_data$extra <- exp(step_data$`Percentile Center`)+ |
+
| 59 | ++ |
+ #' g_step(step_data) ++ |
+
| 60 | ++ |
+ #' ggplot2::geom_line(ggplot2::aes(y = extra), linetype = 2, color = "green")+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' # Response example.+ |
+
| 63 | ++ |
+ #' vars <- list(+ |
+
| 64 | ++ |
+ #' response = "status",+ |
+
| 65 | ++ |
+ #' arm = "sex",+ |
+
| 66 | ++ |
+ #' biomarker = "age"+ |
+
| 67 | ++ |
+ #' )+ |
+
| 68 | ++ |
+ #'+ |
+
| 69 | ++ |
+ #' step_matrix <- fit_rsp_step(+ |
+
| 70 | ++ |
+ #' variables = vars,+ |
+
| 71 | ++ |
+ #' data = lung,+ |
+
| 72 | ++ |
+ #' control = c(+ |
+
| 73 | ++ |
+ #' control_logistic(response_definition = "I(response == 2)"),+ |
+
| 74 | ++ |
+ #' control_step()+ |
+
| 75 | ++ |
+ #' )+ |
+
| 76 | ++ |
+ #' )+ |
+
| 77 | ++ |
+ #' step_data <- broom::tidy(step_matrix)+ |
+
| 78 | ++ |
+ #' g_step(step_data)+ |
+
| 79 | ++ |
+ #'+ |
+
| 80 | ++ |
+ #' @export+ |
+
| 81 | ++ |
+ g_step <- function(df,+ |
+
| 82 | ++ |
+ use_percentile = "Percentile Center" %in% names(df),+ |
+
| 83 | ++ |
+ est = list(col = "blue", lty = 1),+ |
+
| 84 | ++ |
+ ci_ribbon = list(fill = getOption("ggplot2.discrete.colour")[1], alpha = 0.5),
+ |
+
| 85 | ++ |
+ col = getOption("ggplot2.discrete.colour")) {
+ |
+
| 86 | +2x | +
+ checkmate::assert_tibble(df)+ |
+
| 87 | +2x | +
+ checkmate::assert_flag(use_percentile)+ |
+
| 88 | +2x | +
+ checkmate::assert_character(col, null.ok = TRUE)+ |
+
| 89 | +2x | +
+ checkmate::assert_list(est, names = "named")+ |
+
| 90 | +2x | +
+ checkmate::assert_list(ci_ribbon, names = "named", null.ok = TRUE)+ |
+
| 91 | ++ | + + | +
| 92 | +2x | +
+ x_var <- ifelse(use_percentile, "Percentile Center", "Interval Center")+ |
+
| 93 | +2x | +
+ df$x <- df[[x_var]]+ |
+
| 94 | +2x | +
+ attrs <- attributes(df)+ |
+
| 95 | +2x | +
+ df$y <- df[[attrs$estimate]]+ |
+
| 96 | ++ | + + | +
| 97 | ++ |
+ # Set legend names. To be modified also at call level+ |
+
| 98 | +2x | +
+ legend_names <- c("Estimate", "CI 95%")
+ |
+
| 99 | ++ | + + | +
| 100 | +2x | +
+ p <- ggplot2::ggplot(df, ggplot2::aes(x = .data[["x"]], y = .data[["y"]]))+ |
+
| 101 | ++ | + + | +
| 102 | +2x | +
+ if (!is.null(col)) {
+ |
+
| 103 | +2x | +
+ p <- p ++ |
+
| 104 | +2x | +
+ ggplot2::scale_color_manual(values = col)+ |
+
| 105 | ++ |
+ }+ |
+
| 106 | ++ | + + | +
| 107 | +2x | +
+ if (!is.null(ci_ribbon)) {
+ |
+
| 108 | +1x | +
+ if (is.null(ci_ribbon$fill)) {
+ |
+
| 109 | +! | +
+ ci_ribbon$fill <- "lightblue"+ |
+
| 110 | ++ |
+ }+ |
+
| 111 | +1x | +
+ p <- p + ggplot2::geom_ribbon(+ |
+
| 112 | +1x | +
+ ggplot2::aes(+ |
+
| 113 | +1x | +
+ ymin = .data[["ci_lower"]], ymax = .data[["ci_upper"]],+ |
+
| 114 | +1x | +
+ fill = legend_names[2]+ |
+
| 115 | ++ |
+ ),+ |
+
| 116 | +1x | +
+ alpha = ci_ribbon$alpha+ |
+
| 117 | ++ |
+ ) ++ |
+
| 118 | +1x | +
+ scale_fill_manual(+ |
+
| 119 | +1x | +
+ name = "", values = c("CI 95%" = ci_ribbon$fill)
+ |
+
| 120 | ++ |
+ )+ |
+
| 121 | ++ |
+ }+ |
+
| 122 | +2x | +
+ suppressMessages(p <- p ++ |
+
| 123 | +2x | +
+ ggplot2::geom_line(+ |
+
| 124 | +2x | +
+ ggplot2::aes(y = .data[["y"]], color = legend_names[1]),+ |
+
| 125 | +2x | +
+ linetype = est$lty+ |
+
| 126 | ++ |
+ ) ++ |
+
| 127 | +2x | +
+ scale_colour_manual(+ |
+
| 128 | +2x | +
+ name = "", values = c("Estimate" = "blue")
+ |
+
| 129 | ++ |
+ ))+ |
+
| 130 | ++ | + + | +
| 131 | +2x | +
+ p <- p + ggplot2::labs(x = attrs$biomarker, y = attrs$estimate)+ |
+
| 132 | +2x | +
+ if (use_percentile) {
+ |
+
| 133 | +1x | +
+ p <- p + ggplot2::scale_x_continuous(labels = scales::percent)+ |
+
| 134 | ++ |
+ }+ |
+
| 135 | +2x | +
+ p+ |
+
| 136 | ++ |
+ }+ |
+
| 137 | ++ | + + | +
| 138 | ++ |
+ #' Custom Tidy Method for STEP Results+ |
+
| 139 | ++ |
+ #'+ |
+
| 140 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 141 | ++ |
+ #'+ |
+
| 142 | ++ |
+ #' Tidy the STEP results into a `tibble` format ready for plotting.+ |
+
| 143 | ++ |
+ #'+ |
+
| 144 | ++ |
+ #' @param x (`step` matrix)\cr results from [fit_survival_step()].+ |
+
| 145 | ++ |
+ #' @param ... not used here.+ |
+
| 146 | ++ |
+ #'+ |
+
| 147 | ++ |
+ #' @return A `tibble` with one row per STEP subgroup. The estimates and CIs are on the HR or OR scale,+ |
+
| 148 | ++ |
+ #' respectively. Additional attributes carry metadata also used for plotting.+ |
+
| 149 | ++ |
+ #'+ |
+
| 150 | ++ |
+ #' @seealso [g_step()] which consumes the result from this function.+ |
+
| 151 | ++ |
+ #'+ |
+
| 152 | ++ |
+ #' @method tidy step+ |
+
| 153 | ++ |
+ #'+ |
+
| 154 | ++ |
+ #' @examples+ |
+
| 155 | ++ |
+ #' library(survival)+ |
+
| 156 | ++ |
+ #' lung$sex <- factor(lung$sex)+ |
+
| 157 | ++ |
+ #' vars <- list(+ |
+
| 158 | ++ |
+ #' time = "time",+ |
+
| 159 | ++ |
+ #' event = "status",+ |
+
| 160 | ++ |
+ #' arm = "sex",+ |
+
| 161 | ++ |
+ #' biomarker = "age"+ |
+
| 162 | ++ |
+ #' )+ |
+
| 163 | ++ |
+ #' step_matrix <- fit_survival_step(+ |
+
| 164 | ++ |
+ #' variables = vars,+ |
+
| 165 | ++ |
+ #' data = lung,+ |
+
| 166 | ++ |
+ #' control = c(control_coxph(), control_step(num_points = 10, degree = 2))+ |
+
| 167 | ++ |
+ #' )+ |
+
| 168 | ++ |
+ #' broom::tidy(step_matrix)+ |
+
| 169 | ++ |
+ #'+ |
+
| 170 | ++ |
+ #' @export+ |
+
| 171 | ++ |
+ tidy.step <- function(x, ...) { # nolint
+ |
+
| 172 | +7x | +
+ checkmate::assert_class(x, "step")+ |
+
| 173 | +7x | +
+ dat <- as.data.frame(x)+ |
+
| 174 | +7x | +
+ nams <- names(dat)+ |
+
| 175 | +7x | +
+ is_surv <- "loghr" %in% names(dat)+ |
+
| 176 | +7x | +
+ est_var <- ifelse(is_surv, "loghr", "logor")+ |
+
| 177 | +7x | +
+ new_est_var <- ifelse(is_surv, "Hazard Ratio", "Odds Ratio")+ |
+
| 178 | +7x | +
+ new_y_vars <- c(new_est_var, c("ci_lower", "ci_upper"))
+ |
+
| 179 | +7x | +
+ names(dat)[match(est_var, nams)] <- new_est_var+ |
+
| 180 | +7x | +
+ dat[, new_y_vars] <- exp(dat[, new_y_vars])+ |
+
| 181 | +7x | +
+ any_is_na <- any(is.na(dat[, new_y_vars]))+ |
+
| 182 | +7x | +
+ any_is_very_large <- any(abs(dat[, new_y_vars]) > 1e10, na.rm = TRUE)+ |
+
| 183 | +7x | +
+ if (any_is_na) {
+ |
+
| 184 | +2x | +
+ warning(paste(+ |
+
| 185 | +2x | +
+ "Missing values in the point estimate or CI columns,",+ |
+
| 186 | +2x | +
+ "this will lead to holes in the `g_step()` plot"+ |
+
| 187 | ++ |
+ ))+ |
+
| 188 | ++ |
+ }+ |
+
| 189 | +7x | +
+ if (any_is_very_large) {
+ |
+
| 190 | +2x | +
+ warning(paste(+ |
+
| 191 | +2x | +
+ "Very large absolute values in the point estimate or CI columns,",+ |
+
| 192 | +2x | +
+ "consider adding `scale_y_log10()` to the `g_step()` result for plotting"+ |
+
| 193 | ++ |
+ ))+ |
+
| 194 | ++ |
+ }+ |
+
| 195 | +7x | +
+ if (any_is_na || any_is_very_large) {
+ |
+
| 196 | +4x | +
+ warning("Consider using larger `bandwidth`, less `num_points` in `control_step()` settings for fitting")
+ |
+
| 197 | ++ |
+ }+ |
+
| 198 | +7x | +
+ structure(+ |
+
| 199 | +7x | +
+ tibble::as_tibble(dat),+ |
+
| 200 | +7x | +
+ estimate = new_est_var,+ |
+
| 201 | +7x | +
+ biomarker = attr(x, "variables")$biomarker,+ |
+
| 202 | +7x | +
+ ci = f_conf_level(attr(x, "control")$conf_level)+ |
+
| 203 | ++ |
+ )+ |
+
| 204 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Additional Assertions for `checkmate`+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Additional assertion functions which can be used together with the `checkmate` package.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @inheritParams checkmate::assert_factor+ |
+
| 6 | ++ |
+ #' @param x (`any`)\cr object to test.+ |
+
| 7 | ++ |
+ #' @param df (`data.frame`)\cr data set to test.+ |
+
| 8 | ++ |
+ #' @param variables (named `list` of `character`)\cr list of variables to test.+ |
+
| 9 | ++ |
+ #' @param include_boundaries (`logical`)\cr whether to include boundaries when testing+ |
+
| 10 | ++ |
+ #' for proportions.+ |
+
| 11 | ++ |
+ #' @param na_level (`character`)\cr the string you have been using to represent NA or+ |
+
| 12 | ++ |
+ #' missing data. For `NA` values please consider using directly [is.na()] or+ |
+
| 13 | ++ |
+ #' similar approaches.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @return Nothing if assertion passes, otherwise prints the error message.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @name assertions+ |
+
| 18 | ++ |
+ NULL+ |
+
| 19 | ++ | + + | +
| 20 | ++ |
+ check_list_of_variables <- function(x) {
+ |
+
| 21 | ++ |
+ # drop NULL elements in list+ |
+
| 22 | +2190x | +
+ x <- Filter(Negate(is.null), x)+ |
+
| 23 | ++ | + + | +
| 24 | +2190x | +
+ res <- checkmate::check_list(x,+ |
+
| 25 | +2190x | +
+ names = "named",+ |
+
| 26 | +2190x | +
+ min.len = 1,+ |
+
| 27 | +2190x | +
+ any.missing = FALSE,+ |
+
| 28 | +2190x | +
+ types = "character"+ |
+
| 29 | ++ |
+ )+ |
+
| 30 | ++ |
+ # no empty strings allowed+ |
+
| 31 | +2190x | +
+ if (isTRUE(res)) {
+ |
+
| 32 | +2185x | +
+ res <- checkmate::check_character(unlist(x), min.chars = 1)+ |
+
| 33 | ++ |
+ }+ |
+
| 34 | +2190x | +
+ return(res)+ |
+
| 35 | ++ |
+ }+ |
+
| 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 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' @keywords internal+ |
+
| 40 | ++ |
+ assert_list_of_variables <- checkmate::makeAssertionFunction(check_list_of_variables)+ |
+
| 41 | ++ | + + | +
| 42 | ++ |
+ check_df_with_variables <- function(df, variables, na_level = NULL) {
+ |
+
| 43 | +1956x | +
+ checkmate::assert_data_frame(df)+ |
+
| 44 | +1954x | +
+ assert_list_of_variables(variables)+ |
+
| 45 | ++ | + + | +
| 46 | ++ |
+ # flag for equal variables and column names+ |
+
| 47 | +1952x | +
+ err_flag <- all(unlist(variables) %in% colnames(df))+ |
+
| 48 | +1952x | +
+ checkmate::assert_flag(err_flag)+ |
+
| 49 | ++ | + + | +
| 50 | +1952x | +
+ if (isFALSE(err_flag)) {
+ |
+
| 51 | +5x | +
+ vars <- setdiff(unlist(variables), colnames(df))+ |
+
| 52 | +5x | +
+ return(paste(+ |
+
| 53 | +5x | +
+ deparse(substitute(df)),+ |
+
| 54 | +5x | +
+ "does not contain all specified variables as column names. Missing from dataframe:",+ |
+
| 55 | +5x | +
+ paste(vars, collapse = ", ")+ |
+
| 56 | ++ |
+ ))+ |
+
| 57 | ++ |
+ }+ |
+
| 58 | ++ |
+ # checking if na_level is present and in which column+ |
+
| 59 | +1947x | +
+ if (!is.null(na_level)) {
+ |
+
| 60 | +9x | +
+ checkmate::assert_string(na_level)+ |
+
| 61 | +9x | +
+ res <- unlist(lapply(as.list(df)[unlist(variables)], function(x) any(x == na_level)))+ |
+
| 62 | +9x | +
+ if (any(res)) {
+ |
+
| 63 | +1x | +
+ return(paste0(+ |
+
| 64 | +1x | +
+ deparse(substitute(df)), " contains explicit na_level (", na_level,
+ |
+
| 65 | +1x | +
+ ") in the following columns: ", paste0(unlist(variables)[res],+ |
+
| 66 | +1x | +
+ collapse = ", "+ |
+
| 67 | ++ |
+ )+ |
+
| 68 | ++ |
+ ))+ |
+
| 69 | ++ |
+ }+ |
+
| 70 | ++ |
+ }+ |
+
| 71 | +1946x | +
+ return(TRUE)+ |
+
| 72 | ++ |
+ }+ |
+
| 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 | ++ |
+ #'+ |
+
| 77 | ++ |
+ #' @keywords internal+ |
+
| 78 | ++ |
+ assert_df_with_variables <- checkmate::makeAssertionFunction(check_df_with_variables)+ |
+
| 79 | ++ | + + | +
| 80 | ++ |
+ check_valid_factor <- function(x,+ |
+
| 81 | ++ |
+ min.levels = 1, # nolint+ |
+
| 82 | ++ |
+ max.levels = NULL, # nolint+ |
+
| 83 | ++ |
+ null.ok = TRUE, # nolint+ |
+
| 84 | ++ |
+ any.missing = TRUE, # nolint+ |
+
| 85 | ++ |
+ n.levels = NULL, # nolint+ |
+
| 86 | ++ |
+ len = NULL) {
+ |
+
| 87 | ++ |
+ # checks on levels insertion+ |
+
| 88 | +846x | +
+ checkmate::assert_int(min.levels, lower = 1)+ |
+
| 89 | ++ | + + | +
| 90 | ++ |
+ # main factor check+ |
+
| 91 | +846x | +
+ res <- checkmate::check_factor(x,+ |
+
| 92 | +846x | +
+ min.levels = min.levels,+ |
+
| 93 | +846x | +
+ null.ok = null.ok,+ |
+
| 94 | +846x | +
+ max.levels = max.levels,+ |
+
| 95 | +846x | +
+ any.missing = any.missing,+ |
+
| 96 | +846x | +
+ n.levels = n.levels+ |
+
| 97 | ++ |
+ )+ |
+
| 98 | ++ | + + | +
| 99 | ++ |
+ # no empty strings allowed+ |
+
| 100 | +846x | +
+ if (isTRUE(res)) {
+ |
+
| 101 | +832x | +
+ res <- checkmate::check_character(levels(x), min.chars = 1)+ |
+
| 102 | ++ |
+ }+ |
+
| 103 | ++ | + + | +
| 104 | +846x | +
+ return(res)+ |
+
| 105 | ++ |
+ }+ |
+
| 106 | ++ |
+ #' @describeIn assertions Check whether `x` is a valid factor (i.e. has levels and no empty+ |
+
| 107 | ++ |
+ #' string levels). Note that `NULL` and `NA` elements are allowed.+ |
+
| 108 | ++ |
+ #'+ |
+
| 109 | ++ |
+ #' @keywords internal+ |
+
| 110 | ++ |
+ assert_valid_factor <- checkmate::makeAssertionFunction(check_valid_factor)+ |
+
| 111 | ++ | + + | +
| 112 | ++ | + + | +
| 113 | ++ |
+ check_df_with_factors <- function(df,+ |
+
| 114 | ++ |
+ variables,+ |
+
| 115 | ++ |
+ min.levels = 1, # nolint+ |
+
| 116 | ++ |
+ max.levels = NULL, # nolint+ |
+
| 117 | ++ |
+ any.missing = TRUE, # nolint+ |
+
| 118 | ++ |
+ na_level = NULL) {
+ |
+
| 119 | +190x | +
+ res <- check_df_with_variables(df, variables, na_level)+ |
+
| 120 | ++ |
+ # checking if all the columns specified by variables are valid factors+ |
+
| 121 | +189x | +
+ if (isTRUE(res)) {
+ |
+
| 122 | ++ |
+ # searching the data.frame with selected columns (variables) as a list+ |
+
| 123 | +187x | +
+ res <- lapply(+ |
+
| 124 | +187x | +
+ X = as.list(df)[unlist(variables)],+ |
+
| 125 | +187x | +
+ FUN = check_valid_factor,+ |
+
| 126 | +187x | +
+ min.levels = min.levels,+ |
+
| 127 | +187x | +
+ max.levels = max.levels,+ |
+
| 128 | +187x | +
+ any.missing = any.missing+ |
+
| 129 | ++ |
+ )+ |
+
| 130 | +187x | +
+ res_lo <- unlist(vapply(res, Negate(isTRUE), logical(1)))+ |
+
| 131 | +187x | +
+ if (any(res_lo)) {
+ |
+
| 132 | +6x | +
+ return(paste0(+ |
+
| 133 | +6x | +
+ deparse(substitute(df)), " does not contain only factor variables among:",+ |
+
| 134 | +6x | +
+ "\n* Column `", paste0(unlist(variables)[res_lo],+ |
+
| 135 | +6x | +
+ "` of the data.frame -> ", res[res_lo],+ |
+
| 136 | +6x | +
+ collapse = "\n* "+ |
+
| 137 | ++ |
+ )+ |
+
| 138 | ++ |
+ ))+ |
+
| 139 | ++ |
+ } else {
+ |
+
| 140 | +181x | +
+ res <- TRUE+ |
+
| 141 | ++ |
+ }+ |
+
| 142 | ++ |
+ }+ |
+
| 143 | +183x | +
+ return(res)+ |
+
| 144 | ++ |
+ }+ |
+
| 145 | ++ |
+ #' @describeIn assertions Check whether `df` is a data frame where the analysis `variables`+ |
+
| 146 | ++ |
+ #' are all factors. Note that the creation of `NA` by direct call of `factor()` will+ |
+
| 147 | ++ |
+ #' trim `NA` levels out of the vector list itself.+ |
+
| 148 | ++ |
+ #'+ |
+
| 149 | ++ |
+ #' @keywords internal+ |
+
| 150 | ++ |
+ assert_df_with_factors <- checkmate::makeAssertionFunction(check_df_with_factors)+ |
+
| 151 | ++ | + + | +
| 152 | ++ |
+ #' @describeIn assertions Check whether `x` is a proportion: number between 0 and 1.+ |
+
| 153 | ++ |
+ #'+ |
+
| 154 | ++ |
+ #' @keywords internal+ |
+
| 155 | ++ |
+ assert_proportion_value <- function(x, include_boundaries = FALSE) {
+ |
+
| 156 | +6972x | +
+ checkmate::assert_number(x, lower = 0, upper = 1)+ |
+
| 157 | +6960x | +
+ checkmate::assert_flag(include_boundaries)+ |
+
| 158 | +6960x | +
+ if (isFALSE(include_boundaries)) {
+ |
+
| 159 | +3011x | +
+ checkmate::assert_true(x > 0)+ |
+
| 160 | +3009x | +
+ checkmate::assert_true(x < 1)+ |
+
| 161 | ++ |
+ }+ |
+
| 162 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Individual Patient Plots+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Line plot(s) displaying trend in patients' parameter values over time is rendered.+ |
+
| 6 | ++ |
+ #' Patients' individual baseline values can be added to the plot(s) as reference.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #' @param xvar (`string`)\cr time point variable to be plotted on x-axis.+ |
+
| 10 | ++ |
+ #' @param yvar (`string`)\cr continuous analysis variable to be plotted on y-axis.+ |
+
| 11 | ++ |
+ #' @param xlab (`string`)\cr plot label for x-axis.+ |
+
| 12 | ++ |
+ #' @param ylab (`string`)\cr plot label for y-axis.+ |
+
| 13 | ++ |
+ #' @param id_var (`string`)\cr variable used as patient identifier.+ |
+
| 14 | ++ |
+ #' @param title (`string`)\cr title for plot.+ |
+
| 15 | ++ |
+ #' @param subtitle (`string`)\cr subtitle for plot.+ |
+
| 16 | ++ |
+ #' @param add_baseline_hline (`flag`)\cr adds horizontal line at baseline y-value on+ |
+
| 17 | ++ |
+ #' plot when TRUE.+ |
+
| 18 | ++ |
+ #' @param yvar_baseline (`string`)\cr variable with baseline values only.+ |
+
| 19 | ++ |
+ #' Ignored when `add_baseline_hline` is FALSE.+ |
+
| 20 | ++ |
+ #' @param ggtheme (`theme`)\cr optional graphical theme function as provided+ |
+
| 21 | ++ |
+ #' by `ggplot2` to control outlook of plot. Use `ggplot2::theme()` to tweak the display.+ |
+
| 22 | ++ |
+ #' @param plotting_choices (`character`)\cr specifies options for displaying+ |
+
| 23 | ++ |
+ #' plots. Must be one of "all_in_one", "split_by_max_obs", "separate_by_obs".+ |
+
| 24 | ++ |
+ #' @param max_obs_per_plot (`count`)\cr Number of observations to be plotted on one+ |
+
| 25 | ++ |
+ #' plot. Ignored when `plotting_choices` is not "separate_by_obs".+ |
+
| 26 | ++ |
+ #' @param caption (`character` scalar)\cr optional caption below the plot.+ |
+
| 27 | ++ |
+ #' @param col (`character`)\cr lines colors.+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @seealso Relevant helper function [h_g_ipp()].+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' @name individual_patient_plot+ |
+
| 32 | ++ |
+ NULL+ |
+
| 33 | ++ | + + | +
| 34 | ++ |
+ #' Helper Function To Create Simple Line Plot over Time+ |
+
| 35 | ++ |
+ #'+ |
+
| 36 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' Function that generates a simple line plot displaying parameter trends over time.+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 41 | ++ |
+ #' @inheritParams g_ipp+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' @return A `ggplot` line plot.+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' @seealso [g_ipp()] which uses this function.+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ #' @examples+ |
+
| 48 | ++ |
+ #' library(dplyr)+ |
+
| 49 | ++ |
+ #' library(nestcolor)+ |
+
| 50 | ++ |
+ #'+ |
+
| 51 | ++ |
+ #' # Select a small sample of data to plot.+ |
+
| 52 | ++ |
+ #' adlb <- tern_ex_adlb %>%+ |
+
| 53 | ++ |
+ #' filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
+ |
+
| 54 | ++ |
+ #' slice(1:36)+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' p <- h_g_ipp(+ |
+
| 57 | ++ |
+ #' df = adlb,+ |
+
| 58 | ++ |
+ #' xvar = "AVISIT",+ |
+
| 59 | ++ |
+ #' yvar = "AVAL",+ |
+
| 60 | ++ |
+ #' xlab = "Visit",+ |
+
| 61 | ++ |
+ #' id_var = "USUBJID",+ |
+
| 62 | ++ |
+ #' ylab = "SGOT/ALT (U/L)",+ |
+
| 63 | ++ |
+ #' add_baseline_hline = TRUE+ |
+
| 64 | ++ |
+ #' )+ |
+
| 65 | ++ |
+ #' p+ |
+
| 66 | ++ |
+ #'+ |
+
| 67 | ++ |
+ #' @export+ |
+
| 68 | ++ |
+ h_g_ipp <- function(df,+ |
+
| 69 | ++ |
+ xvar,+ |
+
| 70 | ++ |
+ yvar,+ |
+
| 71 | ++ |
+ xlab,+ |
+
| 72 | ++ |
+ ylab,+ |
+
| 73 | ++ |
+ id_var,+ |
+
| 74 | ++ |
+ title = "Individual Patient Plots",+ |
+
| 75 | ++ |
+ subtitle = "",+ |
+
| 76 | ++ |
+ caption = NULL,+ |
+
| 77 | ++ |
+ add_baseline_hline = FALSE,+ |
+
| 78 | ++ |
+ yvar_baseline = "BASE",+ |
+
| 79 | ++ |
+ ggtheme = nestcolor::theme_nest(),+ |
+
| 80 | ++ |
+ col = NULL) {
+ |
+
| 81 | +13x | +
+ checkmate::assert_string(xvar)+ |
+
| 82 | +13x | +
+ checkmate::assert_string(yvar)+ |
+
| 83 | +13x | +
+ checkmate::assert_string(yvar_baseline)+ |
+
| 84 | +13x | +
+ checkmate::assert_string(id_var)+ |
+
| 85 | +13x | +
+ checkmate::assert_string(xlab)+ |
+
| 86 | +13x | +
+ checkmate::assert_string(ylab)+ |
+
| 87 | +13x | +
+ checkmate::assert_string(title)+ |
+
| 88 | +13x | +
+ checkmate::assert_string(subtitle)+ |
+
| 89 | +13x | +
+ checkmate::assert_subset(c(xvar, yvar, yvar_baseline, id_var), colnames(df))+ |
+
| 90 | +13x | +
+ checkmate::assert_data_frame(df)+ |
+
| 91 | +13x | +
+ checkmate::assert_flag(add_baseline_hline)+ |
+
| 92 | +13x | +
+ checkmate::assert_character(col, null.ok = TRUE)+ |
+
| 93 | ++ | + + | +
| 94 | +13x | +
+ p <- ggplot2::ggplot(+ |
+
| 95 | +13x | +
+ data = df,+ |
+
| 96 | +13x | +
+ mapping = ggplot2::aes(+ |
+
| 97 | +13x | +
+ x = .data[[xvar]],+ |
+
| 98 | +13x | +
+ y = .data[[yvar]],+ |
+
| 99 | +13x | +
+ group = .data[[id_var]],+ |
+
| 100 | +13x | +
+ colour = .data[[id_var]]+ |
+
| 101 | ++ |
+ )+ |
+
| 102 | ++ |
+ ) ++ |
+
| 103 | +13x | +
+ ggplot2::geom_line(linewidth = 0.4) ++ |
+
| 104 | +13x | +
+ ggplot2::geom_point(size = 2) ++ |
+
| 105 | +13x | +
+ ggplot2::labs(+ |
+
| 106 | +13x | +
+ x = xlab,+ |
+
| 107 | +13x | +
+ y = ylab,+ |
+
| 108 | +13x | +
+ title = title,+ |
+
| 109 | +13x | +
+ subtitle = subtitle,+ |
+
| 110 | +13x | +
+ caption = caption+ |
+
| 111 | ++ |
+ ) ++ |
+
| 112 | +13x | +
+ ggtheme+ |
+
| 113 | ++ | + + | +
| 114 | +13x | +
+ if (add_baseline_hline) {
+ |
+
| 115 | +12x | +
+ baseline_df <- df[, c(id_var, yvar_baseline)]+ |
+
| 116 | +12x | +
+ baseline_df <- unique(baseline_df)+ |
+
| 117 | ++ | + + | +
| 118 | +12x | +
+ p <- p ++ |
+
| 119 | +12x | +
+ ggplot2::geom_hline(+ |
+
| 120 | +12x | +
+ data = baseline_df,+ |
+
| 121 | +12x | +
+ mapping = ggplot2::aes(+ |
+
| 122 | +12x | +
+ yintercept = .data[[yvar_baseline]],+ |
+
| 123 | +12x | +
+ colour = .data[[id_var]]+ |
+
| 124 | ++ |
+ ),+ |
+
| 125 | +12x | +
+ linetype = "dotdash",+ |
+
| 126 | +12x | +
+ linewidth = 0.4+ |
+
| 127 | ++ |
+ ) ++ |
+
| 128 | +12x | +
+ ggplot2::geom_text(+ |
+
| 129 | +12x | +
+ data = baseline_df,+ |
+
| 130 | +12x | +
+ mapping = ggplot2::aes(+ |
+
| 131 | +12x | +
+ x = 1,+ |
+
| 132 | +12x | +
+ y = .data[[yvar_baseline]],+ |
+
| 133 | +12x | +
+ label = .data[[id_var]],+ |
+
| 134 | +12x | +
+ colour = .data[[id_var]]+ |
+
| 135 | ++ |
+ ),+ |
+
| 136 | +12x | +
+ nudge_y = 0.025 * (max(df[, yvar], na.rm = TRUE) - min(df[, yvar], na.rm = TRUE)),+ |
+
| 137 | +12x | +
+ vjust = "right",+ |
+
| 138 | +12x | +
+ size = 2+ |
+
| 139 | ++ |
+ )+ |
+
| 140 | ++ | + + | +
| 141 | +12x | +
+ if (!is.null(col)) {
+ |
+
| 142 | +1x | +
+ p <- p ++ |
+
| 143 | +1x | +
+ ggplot2::scale_color_manual(values = col)+ |
+
| 144 | ++ |
+ }+ |
+
| 145 | ++ |
+ }+ |
+
| 146 | +13x | +
+ p+ |
+
| 147 | ++ |
+ }+ |
+
| 148 | ++ | + + | +
| 149 | ++ |
+ #' @describeIn individual_patient_plot Plotting function for individual patient plots which, depending on user+ |
+
| 150 | ++ |
+ #' preference, renders a single graphic or compiles a list of graphics that show trends in individual's parameter+ |
+
| 151 | ++ |
+ #' values over time.+ |
+
| 152 | ++ |
+ #'+ |
+
| 153 | ++ |
+ #' @return A `ggplot` object or a list of `ggplot` objects.+ |
+
| 154 | ++ |
+ #'+ |
+
| 155 | ++ |
+ #' @examples+ |
+
| 156 | ++ |
+ #' library(dplyr)+ |
+
| 157 | ++ |
+ #' library(nestcolor)+ |
+
| 158 | ++ |
+ #'+ |
+
| 159 | ++ |
+ #' # Select a small sample of data to plot.+ |
+
| 160 | ++ |
+ #' adlb <- tern_ex_adlb %>%+ |
+
| 161 | ++ |
+ #' filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
+ |
+
| 162 | ++ |
+ #' slice(1:36)+ |
+
| 163 | ++ |
+ #'+ |
+
| 164 | ++ |
+ #' plot_list <- g_ipp(+ |
+
| 165 | ++ |
+ #' df = adlb,+ |
+
| 166 | ++ |
+ #' xvar = "AVISIT",+ |
+
| 167 | ++ |
+ #' yvar = "AVAL",+ |
+
| 168 | ++ |
+ #' xlab = "Visit",+ |
+
| 169 | ++ |
+ #' ylab = "SGOT/ALT (U/L)",+ |
+
| 170 | ++ |
+ #' title = "Individual Patient Plots",+ |
+
| 171 | ++ |
+ #' add_baseline_hline = TRUE,+ |
+
| 172 | ++ |
+ #' plotting_choices = "split_by_max_obs",+ |
+
| 173 | ++ |
+ #' max_obs_per_plot = 5+ |
+
| 174 | ++ |
+ #' )+ |
+
| 175 | ++ |
+ #' plot_list+ |
+
| 176 | ++ |
+ #'+ |
+
| 177 | ++ |
+ #' @export+ |
+
| 178 | ++ |
+ g_ipp <- function(df,+ |
+
| 179 | ++ |
+ xvar,+ |
+
| 180 | ++ |
+ yvar,+ |
+
| 181 | ++ |
+ xlab,+ |
+
| 182 | ++ |
+ ylab,+ |
+
| 183 | ++ |
+ id_var = "USUBJID",+ |
+
| 184 | ++ |
+ title = "Individual Patient Plots",+ |
+
| 185 | ++ |
+ subtitle = "",+ |
+
| 186 | ++ |
+ caption = NULL,+ |
+
| 187 | ++ |
+ add_baseline_hline = FALSE,+ |
+
| 188 | ++ |
+ yvar_baseline = "BASE",+ |
+
| 189 | ++ |
+ ggtheme = nestcolor::theme_nest(),+ |
+
| 190 | ++ |
+ plotting_choices = c("all_in_one", "split_by_max_obs", "separate_by_obs"),
+ |
+
| 191 | ++ |
+ max_obs_per_plot = 4,+ |
+
| 192 | ++ |
+ col = NULL) {
+ |
+
| 193 | +3x | +
+ checkmate::assert_count(max_obs_per_plot)+ |
+
| 194 | +3x | +
+ checkmate::assert_subset(plotting_choices, c("all_in_one", "split_by_max_obs", "separate_by_obs"))
+ |
+
| 195 | +3x | +
+ checkmate::assert_character(col, null.ok = TRUE)+ |
+
| 196 | ++ | + + | +
| 197 | +3x | +
+ plotting_choices <- match.arg(plotting_choices)+ |
+
| 198 | ++ | + + | +
| 199 | +3x | +
+ if (plotting_choices == "all_in_one") {
+ |
+
| 200 | +1x | +
+ p <- h_g_ipp(+ |
+
| 201 | +1x | +
+ df = df,+ |
+
| 202 | +1x | +
+ xvar = xvar,+ |
+
| 203 | +1x | +
+ yvar = yvar,+ |
+
| 204 | +1x | +
+ xlab = xlab,+ |
+
| 205 | +1x | +
+ ylab = ylab,+ |
+
| 206 | +1x | +
+ id_var = id_var,+ |
+
| 207 | +1x | +
+ title = title,+ |
+
| 208 | +1x | +
+ subtitle = subtitle,+ |
+
| 209 | +1x | +
+ caption = caption,+ |
+
| 210 | +1x | +
+ add_baseline_hline = add_baseline_hline,+ |
+
| 211 | +1x | +
+ yvar_baseline = yvar_baseline,+ |
+
| 212 | +1x | +
+ ggtheme = ggtheme,+ |
+
| 213 | +1x | +
+ col = col+ |
+
| 214 | ++ |
+ )+ |
+
| 215 | ++ | + + | +
| 216 | +1x | +
+ return(p)+ |
+
| 217 | +2x | +
+ } else if (plotting_choices == "split_by_max_obs") {
+ |
+
| 218 | +1x | +
+ id_vec <- unique(df[[id_var]])+ |
+
| 219 | +1x | +
+ id_list <- split(+ |
+
| 220 | +1x | +
+ id_vec,+ |
+
| 221 | +1x | +
+ rep(1:ceiling(length(id_vec) / max_obs_per_plot),+ |
+
| 222 | +1x | +
+ each = max_obs_per_plot,+ |
+
| 223 | +1x | +
+ length.out = length(id_vec)+ |
+
| 224 | ++ |
+ )+ |
+
| 225 | ++ |
+ )+ |
+
| 226 | ++ | + + | +
| 227 | +1x | +
+ df_list <- list()+ |
+
| 228 | +1x | +
+ plot_list <- list()+ |
+
| 229 | ++ | + + | +
| 230 | +1x | +
+ for (i in seq_along(id_list)) {
+ |
+
| 231 | +2x | +
+ df_list[[i]] <- df[df[[id_var]] %in% id_list[[i]], ]+ |
+
| 232 | ++ | + + | +
| 233 | +2x | +
+ plots <- h_g_ipp(+ |
+
| 234 | +2x | +
+ df = df_list[[i]],+ |
+
| 235 | +2x | +
+ xvar = xvar,+ |
+
| 236 | +2x | +
+ yvar = yvar,+ |
+
| 237 | +2x | +
+ xlab = xlab,+ |
+
| 238 | +2x | +
+ ylab = ylab,+ |
+
| 239 | +2x | +
+ id_var = id_var,+ |
+
| 240 | +2x | +
+ title = title,+ |
+
| 241 | +2x | +
+ subtitle = subtitle,+ |
+
| 242 | +2x | +
+ caption = caption,+ |
+
| 243 | +2x | +
+ add_baseline_hline = add_baseline_hline,+ |
+
| 244 | +2x | +
+ yvar_baseline = yvar_baseline,+ |
+
| 245 | +2x | +
+ ggtheme = ggtheme,+ |
+
| 246 | +2x | +
+ col = col+ |
+
| 247 | ++ |
+ )+ |
+
| 248 | ++ | + + | +
| 249 | +2x | +
+ plot_list[[i]] <- plots+ |
+
| 250 | ++ |
+ }+ |
+
| 251 | +1x | +
+ return(plot_list)+ |
+
| 252 | ++ |
+ } else {
+ |
+
| 253 | +1x | +
+ ind_df <- split(df, df[[id_var]])+ |
+
| 254 | +1x | +
+ plot_list <- lapply(+ |
+
| 255 | +1x | +
+ ind_df,+ |
+
| 256 | +1x | +
+ function(x) {
+ |
+
| 257 | +8x | +
+ h_g_ipp(+ |
+
| 258 | +8x | +
+ df = x,+ |
+
| 259 | +8x | +
+ xvar = xvar,+ |
+
| 260 | +8x | +
+ yvar = yvar,+ |
+
| 261 | +8x | +
+ xlab = xlab,+ |
+
| 262 | +8x | +
+ ylab = ylab,+ |
+
| 263 | +8x | +
+ id_var = id_var,+ |
+
| 264 | +8x | +
+ title = title,+ |
+
| 265 | +8x | +
+ subtitle = subtitle,+ |
+
| 266 | +8x | +
+ caption = caption,+ |
+
| 267 | +8x | +
+ add_baseline_hline = add_baseline_hline,+ |
+
| 268 | +8x | +
+ yvar_baseline = yvar_baseline,+ |
+
| 269 | +8x | +
+ ggtheme = ggtheme,+ |
+
| 270 | +8x | +
+ col = col+ |
+
| 271 | ++ |
+ )+ |
+
| 272 | ++ |
+ }+ |
+
| 273 | ++ |
+ )+ |
+
| 274 | ++ | + + | +
| 275 | +1x | +
+ return(plot_list)+ |
+
| 276 | ++ |
+ }+ |
+
| 277 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Convert Table into Matrix of Strings+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Helper function to use mostly within tests. `with_spaces`parameter allows+ |
+
| 6 | ++ |
+ #' to test not only for content but also indentation and table structure.+ |
+
| 7 | ++ |
+ #' `print_txt_to_copy` instead facilitate the testing development by returning a well+ |
+
| 8 | ++ |
+ #' formatted text that needs only to be copied and pasted in the expected output.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @param x `rtables` table.+ |
+
| 11 | ++ |
+ #' @param with_spaces Should the tested table keep the indentation and other relevant spaces?+ |
+
| 12 | ++ |
+ #' @param print_txt_to_copy Utility to have a way to copy the input table directly+ |
+
| 13 | ++ |
+ #' into the expected variable instead of copying it too manually.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @return A `matrix` of `string`s.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @export+ |
+
| 18 | ++ |
+ to_string_matrix <- function(x, with_spaces = FALSE, print_txt_to_copy = FALSE) {
+ |
+
| 19 | +5x | +
+ checkmate::assert_flag(with_spaces)+ |
+
| 20 | +5x | +
+ checkmate::assert_flag(print_txt_to_copy)+ |
+
| 21 | ++ | + + | +
| 22 | ++ |
+ # Producing the matrix to test+ |
+
| 23 | +5x | +
+ if (with_spaces) {
+ |
+
| 24 | +! | +
+ out <- strsplit(toString(matrix_form(x, TRUE)), "\\n")[[1]]+ |
+
| 25 | ++ |
+ } else {
+ |
+
| 26 | +5x | +
+ out <- matrix_form(x)$string+ |
+
| 27 | ++ |
+ }+ |
+
| 28 | ++ | + + | +
| 29 | ++ |
+ # Printing to console formatted output that needs to be copied in "expected"+ |
+
| 30 | +5x | +
+ if (print_txt_to_copy) {
+ |
+
| 31 | +! | +
+ out_tmp <- out+ |
+
| 32 | +! | +
+ if (!with_spaces) {
+ |
+
| 33 | +! | +
+ out_tmp <- apply(out, 1, paste0, collapse = '", "')+ |
+
| 34 | ++ |
+ }+ |
+
| 35 | +! | +
+ cat(paste0('c(\n "', paste0(out_tmp, collapse = '",\n "'), '"\n)'))
+ |
+
| 36 | ++ |
+ }+ |
+
| 37 | ++ | + + | +
| 38 | ++ |
+ # Return values+ |
+
| 39 | +5x | +
+ return(out)+ |
+
| 40 | ++ |
+ }+ |
+
| 41 | ++ | + + | +
| 42 | ++ |
+ #' Blank for Missing Input+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' Helper function to use in tabulating model results.+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' @param x (`vector`)\cr input for a cell.+ |
+
| 47 | ++ |
+ #'+ |
+
| 48 | ++ |
+ #' @return An empty `character` vector if all entries in `x` are missing (`NA`), otherwise+ |
+
| 49 | ++ |
+ #' the unlisted version of `x`.+ |
+
| 50 | ++ |
+ #'+ |
+
| 51 | ++ |
+ #' @keywords internal+ |
+
| 52 | ++ |
+ unlist_and_blank_na <- function(x) {
+ |
+
| 53 | +267x | +
+ unl <- unlist(x)+ |
+
| 54 | +267x | +
+ if (all(is.na(unl))) {
+ |
+
| 55 | +161x | +
+ character()+ |
+
| 56 | ++ |
+ } else {
+ |
+
| 57 | +106x | +
+ unl+ |
+
| 58 | ++ |
+ }+ |
+
| 59 | ++ |
+ }+ |
+
| 60 | ++ | + + | +
| 61 | ++ |
+ #' Constructor for Content Functions given Data Frame with Flag Input+ |
+
| 62 | ++ |
+ #'+ |
+
| 63 | ++ |
+ #' This can be useful for tabulating model results.+ |
+
| 64 | ++ |
+ #'+ |
+
| 65 | ++ |
+ #' @param analysis_var (`string`)\cr variable name for the column containing values to be returned by the+ |
+
| 66 | ++ |
+ #' content function.+ |
+
| 67 | ++ |
+ #' @param flag_var (`string`)\cr variable name for the logical column identifying which row should be returned.+ |
+
| 68 | ++ |
+ #' @param format (`string`)\cr `rtables` format to use.+ |
+
| 69 | ++ |
+ #'+ |
+
| 70 | ++ |
+ #' @return A content function which gives `df$analysis_var` at the row identified by+ |
+
| 71 | ++ |
+ #' `.df_row$flag` in the given format.+ |
+
| 72 | ++ |
+ #'+ |
+
| 73 | ++ |
+ #' @keywords internal+ |
+
| 74 | ++ |
+ cfun_by_flag <- function(analysis_var,+ |
+
| 75 | ++ |
+ flag_var,+ |
+
| 76 | ++ |
+ format = "xx",+ |
+
| 77 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 78 | +61x | +
+ checkmate::assert_string(analysis_var)+ |
+
| 79 | +61x | +
+ checkmate::assert_string(flag_var)+ |
+
| 80 | +61x | +
+ function(df, labelstr) {
+ |
+
| 81 | +265x | +
+ row_index <- which(df[[flag_var]])+ |
+
| 82 | +265x | +
+ x <- unlist_and_blank_na(df[[analysis_var]][row_index])+ |
+
| 83 | +265x | +
+ formatters::with_label(+ |
+
| 84 | +265x | +
+ rcell(x, format = format, indent_mod = .indent_mods),+ |
+
| 85 | +265x | +
+ labelstr+ |
+
| 86 | ++ |
+ )+ |
+
| 87 | ++ |
+ }+ |
+
| 88 | ++ |
+ }+ |
+
| 89 | ++ | + + | +
| 90 | ++ |
+ #' Content Row Function to Add Row Total to Labels+ |
+
| 91 | ++ |
+ #'+ |
+
| 92 | ++ |
+ #' This takes the label of the latest row split level and adds the row total from `df` in parentheses.+ |
+
| 93 | ++ |
+ #' This function differs from [c_label_n_alt()] by taking row counts from `df` rather than+ |
+
| 94 | ++ |
+ #' `alt_counts_df`, and is used by [add_rowcounts()] when `alt_counts` is set to `FALSE`.+ |
+
| 95 | ++ |
+ #'+ |
+
| 96 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 97 | ++ |
+ #'+ |
+
| 98 | ++ |
+ #' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label.+ |
+
| 99 | ++ |
+ #'+ |
+
| 100 | ++ |
+ #' @note It is important here to not use `df` but rather `.N_row` in the implementation, because+ |
+
| 101 | ++ |
+ #' the former is already split by columns and will refer to the first column of the data only.+ |
+
| 102 | ++ |
+ #'+ |
+
| 103 | ++ |
+ #' @seealso [c_label_n_alt()] which performs the same function but retrieves row counts from+ |
+
| 104 | ++ |
+ #' `alt_counts_df` instead of `df`.+ |
+
| 105 | ++ |
+ #'+ |
+
| 106 | ++ |
+ #' @keywords internal+ |
+
| 107 | ++ |
+ c_label_n <- function(df,+ |
+
| 108 | ++ |
+ labelstr,+ |
+
| 109 | ++ |
+ .N_row) { # nolint
+ |
+
| 110 | +270x | +
+ label <- paste0(labelstr, " (N=", .N_row, ")")+ |
+
| 111 | +270x | +
+ in_rows(+ |
+
| 112 | +270x | +
+ .list = list(row_count = formatters::with_label(c(.N_row, .N_row), label)),+ |
+
| 113 | +270x | +
+ .formats = c(row_count = function(x, ...) "")+ |
+
| 114 | ++ |
+ )+ |
+
| 115 | ++ |
+ }+ |
+
| 116 | ++ | + + | +
| 117 | ++ |
+ #' Content Row Function to Add `alt_counts_df` Row Total to Labels+ |
+
| 118 | ++ |
+ #'+ |
+
| 119 | ++ |
+ #' This takes the label of the latest row split level and adds the row total from `alt_counts_df`+ |
+
| 120 | ++ |
+ #' in parentheses. This function differs from [c_label_n()] by taking row counts from `alt_counts_df`+ |
+
| 121 | ++ |
+ #' rather than `df`, and is used by [add_rowcounts()] when `alt_counts` is set to `TRUE`.+ |
+
| 122 | ++ |
+ #'+ |
+
| 123 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 124 | ++ |
+ #'+ |
+
| 125 | ++ |
+ #' @return A list with formatted [rtables::CellValue()] with the row count value and the correct label.+ |
+
| 126 | ++ |
+ #'+ |
+
| 127 | ++ |
+ #' @seealso [c_label_n()] which performs the same function but retrieves row counts from `df` instead+ |
+
| 128 | ++ |
+ #' of `alt_counts_df`.+ |
+
| 129 | ++ |
+ #'+ |
+
| 130 | ++ |
+ #' @keywords internal+ |
+
| 131 | ++ |
+ c_label_n_alt <- function(df,+ |
+
| 132 | ++ |
+ labelstr,+ |
+
| 133 | ++ |
+ .alt_df_row) {
+ |
+
| 134 | +7x | +
+ N_row_alt <- nrow(.alt_df_row) # nolint+ |
+
| 135 | +7x | +
+ label <- paste0(labelstr, " (N=", N_row_alt, ")")+ |
+
| 136 | +7x | +
+ in_rows(+ |
+
| 137 | +7x | +
+ .list = list(row_count = formatters::with_label(c(N_row_alt, N_row_alt), label)),+ |
+
| 138 | +7x | +
+ .formats = c(row_count = function(x, ...) "")+ |
+
| 139 | ++ |
+ )+ |
+
| 140 | ++ |
+ }+ |
+
| 141 | ++ | + + | +
| 142 | ++ |
+ #' Layout Creating Function to Add Row Total Counts+ |
+
| 143 | ++ |
+ #'+ |
+
| 144 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 145 | ++ |
+ #'+ |
+
| 146 | ++ |
+ #' This works analogously to [rtables::add_colcounts()] but on the rows. This function+ |
+
| 147 | ++ |
+ #' is a wrapper for [rtables::summarize_row_groups()].+ |
+
| 148 | ++ |
+ #'+ |
+
| 149 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 150 | ++ |
+ #' @param alt_counts (`flag`)\cr whether row counts should be taken from `alt_counts_df` (`TRUE`)+ |
+
| 151 | ++ |
+ #' or from `df` (`FALSE`). Defaults to `FALSE`.+ |
+
| 152 | ++ |
+ #'+ |
+
| 153 | ++ |
+ #' @return A modified layout where the latest row split labels now have the row-wise+ |
+
| 154 | ++ |
+ #' total counts (i.e. without column-based subsetting) attached in parentheses.+ |
+
| 155 | ++ |
+ #'+ |
+
| 156 | ++ |
+ #' @note Row count values are contained in these row count rows but are not displayed+ |
+
| 157 | ++ |
+ #' so that they are not considered zero rows by default when pruning.+ |
+
| 158 | ++ |
+ #'+ |
+
| 159 | ++ |
+ #' @examples+ |
+
| 160 | ++ |
+ #' basic_table() %>%+ |
+
| 161 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 162 | ++ |
+ #' add_colcounts() %>%+ |
+
| 163 | ++ |
+ #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
+ |
+
| 164 | ++ |
+ #' add_rowcounts() %>%+ |
+
| 165 | ++ |
+ #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>%
+ |
+
| 166 | ++ |
+ #' build_table(DM)+ |
+
| 167 | ++ |
+ #'+ |
+
| 168 | ++ |
+ #' @export+ |
+
| 169 | ++ |
+ add_rowcounts <- function(lyt, alt_counts = FALSE) {
+ |
+
| 170 | +6x | +
+ summarize_row_groups(+ |
+
| 171 | +6x | +
+ lyt,+ |
+
| 172 | +6x | +
+ cfun = if (alt_counts) c_label_n_alt else c_label_n+ |
+
| 173 | ++ |
+ )+ |
+
| 174 | ++ |
+ }+ |
+
| 175 | ++ | + + | +
| 176 | ++ |
+ #' Obtain Column Indices+ |
+
| 177 | ++ |
+ #'+ |
+
| 178 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 179 | ++ |
+ #'+ |
+
| 180 | ++ |
+ #' Helper function to extract column indices from a `VTableTree` for a given+ |
+
| 181 | ++ |
+ #' vector of column names.+ |
+
| 182 | ++ |
+ #'+ |
+
| 183 | ++ |
+ #' @param table_tree (`VTableTree`)\cr table to extract the indices from.+ |
+
| 184 | ++ |
+ #' @param col_names (`character`)\cr vector of column names.+ |
+
| 185 | ++ |
+ #'+ |
+
| 186 | ++ |
+ #' @return A vector of column indices.+ |
+
| 187 | ++ |
+ #'+ |
+
| 188 | ++ |
+ #' @export+ |
+
| 189 | ++ |
+ h_col_indices <- function(table_tree, col_names) {
+ |
+
| 190 | +1232x | +
+ checkmate::assert_class(table_tree, "VTableNodeInfo")+ |
+
| 191 | +1232x | +
+ checkmate::assert_subset(col_names, names(attr(col_info(table_tree), "cextra_args")), empty.ok = FALSE)+ |
+
| 192 | +1232x | +
+ match(col_names, names(attr(col_info(table_tree), "cextra_args")))+ |
+
| 193 | ++ |
+ }+ |
+
| 194 | ++ | + + | +
| 195 | ++ |
+ #' Labels or Names of List Elements+ |
+
| 196 | ++ |
+ #'+ |
+
| 197 | ++ |
+ #' Internal helper function for working with nested statistic function results which typically+ |
+
| 198 | ++ |
+ #' don't have labels but names that we can use.+ |
+
| 199 | ++ |
+ #'+ |
+
| 200 | ++ |
+ #' @param x a list+ |
+
| 201 | ++ |
+ #'+ |
+
| 202 | ++ |
+ #' @return A `character` vector with the labels or names for the list elements.+ |
+
| 203 | ++ |
+ #'+ |
+
| 204 | ++ |
+ #' @keywords internal+ |
+
| 205 | ++ |
+ labels_or_names <- function(x) {
+ |
+
| 206 | +119x | +
+ checkmate::assert_multi_class(x, c("data.frame", "list"))
+ |
+
| 207 | +119x | +
+ labs <- sapply(x, obj_label)+ |
+
| 208 | +119x | +
+ nams <- rlang::names2(x)+ |
+
| 209 | +119x | +
+ label_is_null <- sapply(labs, is.null)+ |
+
| 210 | +119x | +
+ result <- unlist(ifelse(label_is_null, nams, labs))+ |
+
| 211 | +119x | +
+ return(result)+ |
+
| 212 | ++ |
+ }+ |
+
| 213 | ++ | + + | +
| 214 | ++ |
+ #' Convert to `rtable`+ |
+
| 215 | ++ |
+ #'+ |
+
| 216 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 217 | ++ |
+ #'+ |
+
| 218 | ++ |
+ #' This is a new generic function to convert objects to `rtable` tables.+ |
+
| 219 | ++ |
+ #'+ |
+
| 220 | ++ |
+ #' @param x the object which should be converted to an `rtable`.+ |
+
| 221 | ++ |
+ #' @param ... additional arguments for methods.+ |
+
| 222 | ++ |
+ #'+ |
+
| 223 | ++ |
+ #' @return An `rtables` table object. Note that the concrete class will depend on the method used.+ |
+
| 224 | ++ |
+ #'+ |
+
| 225 | ++ |
+ #' @export+ |
+
| 226 | ++ |
+ as.rtable <- function(x, ...) { # nolint
+ |
+
| 227 | +3x | +
+ UseMethod("as.rtable", x)
+ |
+
| 228 | ++ |
+ }+ |
+
| 229 | ++ | + + | +
| 230 | ++ |
+ #' @describeIn as.rtable method for converting `data.frame` that contain numeric columns to `rtable`.+ |
+
| 231 | ++ |
+ #'+ |
+
| 232 | ++ |
+ #' @param format the format which should be used for the columns.+ |
+
| 233 | ++ |
+ #'+ |
+
| 234 | ++ |
+ #' @method as.rtable data.frame+ |
+
| 235 | ++ |
+ #'+ |
+
| 236 | ++ |
+ #' @examples+ |
+
| 237 | ++ |
+ #' x <- data.frame(+ |
+
| 238 | ++ |
+ #' a = 1:10,+ |
+
| 239 | ++ |
+ #' b = rnorm(10)+ |
+
| 240 | ++ |
+ #' )+ |
+
| 241 | ++ |
+ #' as.rtable(x)+ |
+
| 242 | ++ |
+ #'+ |
+
| 243 | ++ |
+ #' @export+ |
+
| 244 | ++ |
+ as.rtable.data.frame <- function(x, format = "xx.xx", ...) {
+ |
+
| 245 | +3x | +
+ checkmate::assert_numeric(unlist(x))+ |
+
| 246 | +2x | +
+ do.call(+ |
+
| 247 | +2x | +
+ rtable,+ |
+
| 248 | +2x | +
+ c(+ |
+
| 249 | +2x | +
+ list(+ |
+
| 250 | +2x | +
+ header = labels_or_names(x),+ |
+
| 251 | +2x | +
+ format = format+ |
+
| 252 | ++ |
+ ),+ |
+
| 253 | +2x | +
+ Map(+ |
+
| 254 | +2x | +
+ function(row, row_name) {
+ |
+
| 255 | +20x | +
+ do.call(+ |
+
| 256 | +20x | +
+ rrow,+ |
+
| 257 | +20x | +
+ c(as.list(unname(row)),+ |
+
| 258 | +20x | +
+ row.name = row_name+ |
+
| 259 | ++ |
+ )+ |
+
| 260 | ++ |
+ )+ |
+
| 261 | ++ |
+ },+ |
+
| 262 | +2x | +
+ row = as.data.frame(t(x)),+ |
+
| 263 | +2x | +
+ row_name = rownames(x)+ |
+
| 264 | ++ |
+ )+ |
+
| 265 | ++ |
+ )+ |
+
| 266 | ++ |
+ )+ |
+
| 267 | ++ |
+ }+ |
+
| 268 | ++ | + + | +
| 269 | ++ |
+ #' Split parameters+ |
+
| 270 | ++ |
+ #'+ |
+
| 271 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 272 | ++ |
+ #'+ |
+
| 273 | ++ |
+ #' It divides the data in the vector `param` into the groups defined by `f` based on specified `values`. It is relevant+ |
+
| 274 | ++ |
+ #' in `rtables` layers so as to distribute parameters `.stats` or' `.formats` into lists with items corresponding to+ |
+
| 275 | ++ |
+ #' specific analysis function.+ |
+
| 276 | ++ |
+ #'+ |
+
| 277 | ++ |
+ #' @param param (`vector`)\cr the parameter to be split.+ |
+
| 278 | ++ |
+ #' @param value (`vector`)\cr the value used to split.+ |
+
| 279 | ++ |
+ #' @param f (`list` of `vectors`)\cr the reference to make the split+ |
+
| 280 | ++ |
+ #'+ |
+
| 281 | ++ |
+ #' @return A named `list` with the same element names as `f`, each containing the elements specified in `.stats`.+ |
+
| 282 | ++ |
+ #'+ |
+
| 283 | ++ |
+ #' @examples+ |
+
| 284 | ++ |
+ #' f <- list(+ |
+
| 285 | ++ |
+ #' surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
+ |
+
| 286 | ++ |
+ #' surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
+ |
+
| 287 | ++ |
+ #' )+ |
+
| 288 | ++ |
+ #'+ |
+
| 289 | ++ |
+ #' .stats <- c("pt_at_risk", "rate_diff")
+ |
+
| 290 | ++ |
+ #' h_split_param(.stats, .stats, f = f)+ |
+
| 291 | ++ |
+ #'+ |
+
| 292 | ++ |
+ #' # $surv+ |
+
| 293 | ++ |
+ #' # [1] "pt_at_risk"+ |
+
| 294 | ++ |
+ #' #+ |
+
| 295 | ++ |
+ #' # $surv_diff+ |
+
| 296 | ++ |
+ #' # [1] "rate_diff"+ |
+
| 297 | ++ |
+ #'+ |
+
| 298 | ++ |
+ #' .formats <- c("pt_at_risk" = "xx", "event_free_rate" = "xxx")
+ |
+
| 299 | ++ |
+ #' h_split_param(.formats, names(.formats), f = f)+ |
+
| 300 | ++ |
+ #'+ |
+
| 301 | ++ |
+ #' # $surv+ |
+
| 302 | ++ |
+ #' # pt_at_risk event_free_rate+ |
+
| 303 | ++ |
+ #' # "xx" "xxx"+ |
+
| 304 | ++ |
+ #' #+ |
+
| 305 | ++ |
+ #' # $surv_diff+ |
+
| 306 | ++ |
+ #' # NULL+ |
+
| 307 | ++ |
+ #'+ |
+
| 308 | ++ |
+ #' @export+ |
+
| 309 | ++ |
+ h_split_param <- function(param,+ |
+
| 310 | ++ |
+ value,+ |
+
| 311 | ++ |
+ f) {
+ |
+
| 312 | +21x | +
+ y <- lapply(f, function(x) param[value %in% x])+ |
+
| 313 | +21x | +
+ lapply(y, function(x) if (length(x) == 0) NULL else x)+ |
+
| 314 | ++ |
+ }+ |
+
| 315 | ++ | + + | +
| 316 | ++ |
+ #' Get Selected Statistics Names+ |
+
| 317 | ++ |
+ #'+ |
+
| 318 | ++ |
+ #' Helper function to be used for creating `afun`.+ |
+
| 319 | ++ |
+ #'+ |
+
| 320 | ++ |
+ #' @param .stats (`vector` or `NULL`)\cr input to the layout creating function. Note that `NULL` means+ |
+
| 321 | ++ |
+ #' in this context that all default statistics should be used.+ |
+
| 322 | ++ |
+ #' @param all_stats (`character`)\cr all statistics which can be selected here potentially.+ |
+
| 323 | ++ |
+ #'+ |
+
| 324 | ++ |
+ #' @return A `character` vector with the selected statistics.+ |
+
| 325 | ++ |
+ #'+ |
+
| 326 | ++ |
+ #' @keywords internal+ |
+
| 327 | ++ |
+ afun_selected_stats <- function(.stats, all_stats) {
+ |
+
| 328 | +2x | +
+ checkmate::assert_character(.stats, null.ok = TRUE)+ |
+
| 329 | +2x | +
+ checkmate::assert_character(all_stats)+ |
+
| 330 | +2x | +
+ if (is.null(.stats)) {
+ |
+
| 331 | +1x | +
+ all_stats+ |
+
| 332 | ++ |
+ } else {
+ |
+
| 333 | +1x | +
+ intersect(.stats, all_stats)+ |
+
| 334 | ++ |
+ }+ |
+
| 335 | ++ |
+ }+ |
+
| 336 | ++ | + + | +
| 337 | ++ |
+ #' Add Variable Labels to Top Left Corner in Table+ |
+
| 338 | ++ |
+ #'+ |
+
| 339 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 340 | ++ |
+ #'+ |
+
| 341 | ++ |
+ #' Helper layout creating function to just append the variable labels of a given variables vector+ |
+
| 342 | ++ |
+ #' from a given dataset in the top left corner. If a variable label is not found then the+ |
+
| 343 | ++ |
+ #' variable name itself is used instead. Multiple variable labels are concatenated with slashes.+ |
+
| 344 | ++ |
+ #'+ |
+
| 345 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 346 | ++ |
+ #' @param vars (`character`)\cr variable names of which the labels are to be looked up in `df`.+ |
+
| 347 | ++ |
+ #' @param indent (`integer`)\cr non-negative number of nested indent space, default to 0L which means no indent.+ |
+
| 348 | ++ |
+ #' 1L means two spaces indent, 2L means four spaces indent and so on.+ |
+
| 349 | ++ |
+ #'+ |
+
| 350 | ++ |
+ #' @return A modified layout with the new variable label(s) added to the top-left material.+ |
+
| 351 | ++ |
+ #'+ |
+
| 352 | ++ |
+ #' @note This is not an optimal implementation of course, since we are using here the data set+ |
+
| 353 | ++ |
+ #' itself during the layout creation. When we have a more mature `rtables` implementation then+ |
+
| 354 | ++ |
+ #' this will also be improved or not necessary anymore.+ |
+
| 355 | ++ |
+ #'+ |
+
| 356 | ++ |
+ #' @examples+ |
+
| 357 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 358 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 359 | ++ |
+ #' add_colcounts() %>%+ |
+
| 360 | ++ |
+ #' split_rows_by("SEX") %>%
+ |
+
| 361 | ++ |
+ #' append_varlabels(DM, "SEX") %>%+ |
+
| 362 | ++ |
+ #' analyze("AGE", afun = mean) %>%
+ |
+
| 363 | ++ |
+ #' append_varlabels(DM, "AGE", indent = 1)+ |
+
| 364 | ++ |
+ #' build_table(lyt, DM)+ |
+
| 365 | ++ |
+ #'+ |
+
| 366 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 367 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 368 | ++ |
+ #' split_rows_by("SEX") %>%
+ |
+
| 369 | ++ |
+ #' analyze("AGE", afun = mean) %>%
+ |
+
| 370 | ++ |
+ #' append_varlabels(DM, c("SEX", "AGE"))
+ |
+
| 371 | ++ |
+ #' build_table(lyt, DM)+ |
+
| 372 | ++ |
+ #'+ |
+
| 373 | ++ |
+ #' @export+ |
+
| 374 | ++ |
+ append_varlabels <- function(lyt, df, vars, indent = 0L) {
+ |
+
| 375 | +3x | +
+ if (checkmate::test_flag(indent)) {
+ |
+
| 376 | +! | +
+ warning("indent argument is now accepting integers. Boolean indent will be converted to integers.")
+ |
+
| 377 | +! | +
+ indent <- as.integer(indent)+ |
+
| 378 | ++ |
+ }+ |
+
| 379 | ++ | + + | +
| 380 | +3x | +
+ checkmate::assert_data_frame(df)+ |
+
| 381 | +3x | +
+ checkmate::assert_character(vars)+ |
+
| 382 | +3x | +
+ checkmate::assert_count(indent)+ |
+
| 383 | ++ | + + | +
| 384 | +3x | +
+ lab <- formatters::var_labels(df[vars], fill = TRUE)+ |
+
| 385 | +3x | +
+ lab <- paste(lab, collapse = " / ")+ |
+
| 386 | +3x | +
+ space <- paste(rep(" ", indent * 2), collapse = "")
+ |
+
| 387 | +3x | +
+ lab <- paste0(space, lab)+ |
+
| 388 | ++ | + + | +
| 389 | +3x | +
+ append_topleft(lyt, lab)+ |
+
| 390 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Pairwise `CoxPH` model+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Summarize p-value, HR and CIs from stratified or unstratified `CoxPH` model.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 8 | ++ |
+ #' @inheritParams s_surv_time+ |
+
| 9 | ++ |
+ #' @param strat (`character` or `NULL`)\cr variable names indicating stratification factors.+ |
+
| 10 | ++ |
+ #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function+ |
+
| 11 | ++ |
+ #' [control_coxph()]. Some possible parameter options are:+ |
+
| 12 | ++ |
+ #' * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1. Default method is `"log-rank"` which+ |
+
| 13 | ++ |
+ #' comes from [survival::survdiff()], can also be set to `"wald"` or `"likelihood"` (from [survival::coxph()]).+ |
+
| 14 | ++ |
+ #' * `ties` (`string`)\cr specifying the method for tie handling. Default is `"efron"`,+ |
+
| 15 | ++ |
+ #' can also be set to `"breslow"` or `"exact"`. See more in [survival::coxph()]+ |
+
| 16 | ++ |
+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for HR.+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @name survival_coxph_pairwise+ |
+
| 19 | ++ |
+ NULL+ |
+
| 20 | ++ | + + | +
| 21 | ++ |
+ #' @describeIn survival_coxph_pairwise Statistics function which analyzes HR, CIs of HR and p-value of a `coxph` model.+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @return+ |
+
| 24 | ++ |
+ #' * `s_coxph_pairwise()` returns the statistics:+ |
+
| 25 | ++ |
+ #' * `pvalue`: p-value to test HR = 1.+ |
+
| 26 | ++ |
+ #' * `hr`: Hazard ratio.+ |
+
| 27 | ++ |
+ #' * `hr_ci`: Confidence interval for hazard ratio.+ |
+
| 28 | ++ |
+ #' * `n_tot`: Total number of observations.+ |
+
| 29 | ++ |
+ #' * `n_tot_events`: Total number of events.+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' @examples+ |
+
| 32 | ++ |
+ #' library(dplyr)+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' adtte_f <- tern_ex_adtte %>%+ |
+
| 35 | ++ |
+ #' filter(PARAMCD == "OS") %>%+ |
+
| 36 | ++ |
+ #' mutate(is_event = CNSR == 0)+ |
+
| 37 | ++ |
+ #' df <- adtte_f %>%+ |
+
| 38 | ++ |
+ #' filter(ARMCD == "ARM A")+ |
+
| 39 | ++ |
+ #' df_ref_group <- adtte_f %>%+ |
+
| 40 | ++ |
+ #' filter(ARMCD == "ARM B")+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' @keywords internal+ |
+
| 43 | ++ |
+ s_coxph_pairwise <- function(df,+ |
+
| 44 | ++ |
+ .ref_group,+ |
+
| 45 | ++ |
+ .in_ref_col,+ |
+
| 46 | ++ |
+ .var,+ |
+
| 47 | ++ |
+ is_event,+ |
+
| 48 | ++ |
+ strat = NULL,+ |
+
| 49 | ++ |
+ control = control_coxph()) {
+ |
+
| 50 | +65x | +
+ checkmate::assert_string(.var)+ |
+
| 51 | +65x | +
+ checkmate::assert_numeric(df[[.var]])+ |
+
| 52 | +65x | +
+ checkmate::assert_logical(df[[is_event]])+ |
+
| 53 | +65x | +
+ assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ |
+
| 54 | +65x | +
+ pval_method <- control$pval_method+ |
+
| 55 | +65x | +
+ ties <- control$ties+ |
+
| 56 | +65x | +
+ conf_level <- control$conf_level+ |
+
| 57 | ++ | + + | +
| 58 | +65x | +
+ if (.in_ref_col) {
+ |
+
| 59 | +! | +
+ return(+ |
+
| 60 | +! | +
+ list(+ |
+
| 61 | +! | +
+ pvalue = formatters::with_label("", paste0("p-value (", pval_method, ")")),
+ |
+
| 62 | +! | +
+ hr = formatters::with_label("", "Hazard Ratio"),
+ |
+
| 63 | +! | +
+ hr_ci = formatters::with_label("", f_conf_level(conf_level)),
+ |
+
| 64 | +! | +
+ n_tot = formatters::with_label("", "Total n"),
+ |
+
| 65 | +! | +
+ n_tot_events = formatters::with_label("", "Total events")
+ |
+
| 66 | ++ |
+ )+ |
+
| 67 | ++ |
+ )+ |
+
| 68 | ++ |
+ }+ |
+
| 69 | +65x | +
+ data <- rbind(.ref_group, df)+ |
+
| 70 | +65x | +
+ group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
+ |
+
| 71 | ++ | + + | +
| 72 | +65x | +
+ df_cox <- data.frame(+ |
+
| 73 | +65x | +
+ tte = data[[.var]],+ |
+
| 74 | +65x | +
+ is_event = data[[is_event]],+ |
+
| 75 | +65x | +
+ arm = group+ |
+
| 76 | ++ |
+ )+ |
+
| 77 | +65x | +
+ if (is.null(strat)) {
+ |
+
| 78 | +58x | +
+ formula_cox <- survival::Surv(tte, is_event) ~ arm+ |
+
| 79 | ++ |
+ } else {
+ |
+
| 80 | +7x | +
+ formula_cox <- stats::as.formula(+ |
+
| 81 | +7x | +
+ paste0(+ |
+
| 82 | +7x | +
+ "survival::Surv(tte, is_event) ~ arm + strata(",
+ |
+
| 83 | +7x | +
+ paste(strat, collapse = ","),+ |
+
| 84 | ++ |
+ ")"+ |
+
| 85 | ++ |
+ )+ |
+
| 86 | ++ |
+ )+ |
+
| 87 | +7x | +
+ df_cox <- cbind(df_cox, data[strat])+ |
+
| 88 | ++ |
+ }+ |
+
| 89 | +65x | +
+ cox_fit <- survival::coxph(+ |
+
| 90 | +65x | +
+ formula = formula_cox,+ |
+
| 91 | +65x | +
+ data = df_cox,+ |
+
| 92 | +65x | +
+ ties = ties+ |
+
| 93 | ++ |
+ )+ |
+
| 94 | +65x | +
+ sum_cox <- summary(cox_fit, conf.int = conf_level, extend = TRUE)+ |
+
| 95 | +65x | +
+ orginal_survdiff <- survival::survdiff(+ |
+
| 96 | +65x | +
+ formula_cox,+ |
+
| 97 | +65x | +
+ data = df_cox+ |
+
| 98 | ++ |
+ )+ |
+
| 99 | +65x | +
+ log_rank_pvalue <- 1 - pchisq(orginal_survdiff$chisq, length(orginal_survdiff$n) - 1)+ |
+
| 100 | ++ | + + | +
| 101 | +65x | +
+ pval <- switch(pval_method,+ |
+
| 102 | +65x | +
+ "wald" = sum_cox$waldtest["pvalue"],+ |
+
| 103 | +65x | +
+ "log-rank" = log_rank_pvalue, # pvalue from original log-rank test survival::survdiff()+ |
+
| 104 | +65x | +
+ "likelihood" = sum_cox$logtest["pvalue"]+ |
+
| 105 | ++ |
+ )+ |
+
| 106 | +65x | +
+ list(+ |
+
| 107 | +65x | +
+ pvalue = formatters::with_label(unname(pval), paste0("p-value (", pval_method, ")")),
+ |
+
| 108 | +65x | +
+ hr = formatters::with_label(sum_cox$conf.int[1, 1], "Hazard Ratio"),+ |
+
| 109 | +65x | +
+ hr_ci = formatters::with_label(unname(sum_cox$conf.int[1, 3:4]), f_conf_level(conf_level)),+ |
+
| 110 | +65x | +
+ n_tot = formatters::with_label(sum_cox$n, "Total n"),+ |
+
| 111 | +65x | +
+ n_tot_events = formatters::with_label(sum_cox$nevent, "Total events")+ |
+
| 112 | ++ |
+ )+ |
+
| 113 | ++ |
+ }+ |
+
| 114 | ++ | + + | +
| 115 | ++ |
+ #' @describeIn survival_coxph_pairwise Formatted analysis function which is used as `afun` in `coxph_pairwise()`.+ |
+
| 116 | ++ |
+ #'+ |
+
| 117 | ++ |
+ #' @return+ |
+
| 118 | ++ |
+ #' * `a_coxph_pairwise()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 119 | ++ |
+ #'+ |
+
| 120 | ++ |
+ #'+ |
+
| 121 | ++ |
+ #' @keywords internal+ |
+
| 122 | ++ |
+ a_coxph_pairwise <- make_afun(+ |
+
| 123 | ++ |
+ s_coxph_pairwise,+ |
+
| 124 | ++ |
+ .indent_mods = c(pvalue = 0L, hr = 0L, hr_ci = 1L, n_tot = 0L, n_tot_events = 0L),+ |
+
| 125 | ++ |
+ .formats = c(+ |
+
| 126 | ++ |
+ pvalue = "x.xxxx | (<0.0001)",+ |
+
| 127 | ++ |
+ hr = "xx.xx",+ |
+
| 128 | ++ |
+ hr_ci = "(xx.xx, xx.xx)",+ |
+
| 129 | ++ |
+ n_tot = "xx.xx",+ |
+
| 130 | ++ |
+ n_tot_events = "xx.xx"+ |
+
| 131 | ++ |
+ )+ |
+
| 132 | ++ |
+ )+ |
+
| 133 | ++ | + + | +
| 134 | ++ |
+ #' @describeIn survival_coxph_pairwise Layout-creating function which can take statistics function arguments+ |
+
| 135 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 136 | ++ |
+ #'+ |
+
| 137 | ++ |
+ #' @return+ |
+
| 138 | ++ |
+ #' * `coxph_pairwise()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 139 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 140 | ++ |
+ #' the statistics from `s_coxph_pairwise()` to the table layout.+ |
+
| 141 | ++ |
+ #'+ |
+
| 142 | ++ |
+ #' @examples+ |
+
| 143 | ++ |
+ #' basic_table() %>%+ |
+
| 144 | ++ |
+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ |
+
| 145 | ++ |
+ #' add_colcounts() %>%+ |
+
| 146 | ++ |
+ #' coxph_pairwise(+ |
+
| 147 | ++ |
+ #' vars = "AVAL",+ |
+
| 148 | ++ |
+ #' is_event = "is_event",+ |
+
| 149 | ++ |
+ #' var_labels = "Unstratified Analysis"+ |
+
| 150 | ++ |
+ #' ) %>%+ |
+
| 151 | ++ |
+ #' build_table(df = adtte_f)+ |
+
| 152 | ++ |
+ #'+ |
+
| 153 | ++ |
+ #' basic_table() %>%+ |
+
| 154 | ++ |
+ #' split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%+ |
+
| 155 | ++ |
+ #' add_colcounts() %>%+ |
+
| 156 | ++ |
+ #' coxph_pairwise(+ |
+
| 157 | ++ |
+ #' vars = "AVAL",+ |
+
| 158 | ++ |
+ #' is_event = "is_event",+ |
+
| 159 | ++ |
+ #' var_labels = "Stratified Analysis",+ |
+
| 160 | ++ |
+ #' strat = "SEX",+ |
+
| 161 | ++ |
+ #' control = control_coxph(pval_method = "wald")+ |
+
| 162 | ++ |
+ #' ) %>%+ |
+
| 163 | ++ |
+ #' build_table(df = adtte_f)+ |
+
| 164 | ++ |
+ #'+ |
+
| 165 | ++ |
+ #' @export+ |
+
| 166 | ++ |
+ coxph_pairwise <- function(lyt,+ |
+
| 167 | ++ |
+ vars,+ |
+
| 168 | ++ |
+ na_str = NA_character_,+ |
+
| 169 | ++ |
+ nested = TRUE,+ |
+
| 170 | ++ |
+ ...,+ |
+
| 171 | ++ |
+ var_labels = "CoxPH",+ |
+
| 172 | ++ |
+ show_labels = "visible",+ |
+
| 173 | ++ |
+ table_names = vars,+ |
+
| 174 | ++ |
+ .stats = c("pvalue", "hr", "hr_ci"),
+ |
+
| 175 | ++ |
+ .formats = NULL,+ |
+
| 176 | ++ |
+ .labels = NULL,+ |
+
| 177 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 178 | +4x | +
+ afun <- make_afun(+ |
+
| 179 | +4x | +
+ a_coxph_pairwise,+ |
+
| 180 | +4x | +
+ .stats = .stats,+ |
+
| 181 | +4x | +
+ .formats = .formats,+ |
+
| 182 | +4x | +
+ .labels = .labels,+ |
+
| 183 | +4x | +
+ .indent_mods = .indent_mods+ |
+
| 184 | ++ |
+ )+ |
+
| 185 | +4x | +
+ analyze(+ |
+
| 186 | +4x | +
+ lyt,+ |
+
| 187 | +4x | +
+ vars,+ |
+
| 188 | +4x | +
+ var_labels = var_labels,+ |
+
| 189 | +4x | +
+ show_labels = show_labels,+ |
+
| 190 | +4x | +
+ table_names = table_names,+ |
+
| 191 | +4x | +
+ afun = afun,+ |
+
| 192 | +4x | +
+ na_str = na_str,+ |
+
| 193 | +4x | +
+ nested = nested,+ |
+
| 194 | +4x | +
+ extra_args = list(...)+ |
+
| 195 | ++ |
+ )+ |
+
| 196 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Tabulate Binary Response by Subgroup+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Tabulate statistics such as response rate and odds ratio for population subgroups.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @details These functions create a layout starting from a data frame which contains+ |
+
| 10 | ++ |
+ #' the required statistics. Tables typically used as part of forest plot.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @seealso [extract_rsp_subgroups()]+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @examples+ |
+
| 15 | ++ |
+ #' library(dplyr)+ |
+
| 16 | ++ |
+ #' library(forcats)+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' adrs <- tern_ex_adrs+ |
+
| 19 | ++ |
+ #' adrs_labels <- formatters::var_labels(adrs)+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' adrs_f <- adrs %>%+ |
+
| 22 | ++ |
+ #' filter(PARAMCD == "BESRSPI") %>%+ |
+
| 23 | ++ |
+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+ |
+
| 24 | ++ |
+ #' droplevels() %>%+ |
+
| 25 | ++ |
+ #' mutate(+ |
+
| 26 | ++ |
+ #' # Reorder levels of factor to make the placebo group the reference arm.+ |
+
| 27 | ++ |
+ #' ARM = fct_relevel(ARM, "B: Placebo"),+ |
+
| 28 | ++ |
+ #' rsp = AVALC == "CR"+ |
+
| 29 | ++ |
+ #' )+ |
+
| 30 | ++ |
+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' # Unstratified analysis.+ |
+
| 33 | ++ |
+ #' df <- extract_rsp_subgroups(+ |
+
| 34 | ++ |
+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ |
+
| 35 | ++ |
+ #' data = adrs_f+ |
+
| 36 | ++ |
+ #' )+ |
+
| 37 | ++ |
+ #' df+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' @name response_subgroups+ |
+
| 40 | ++ |
+ NULL+ |
+
| 41 | ++ | + + | +
| 42 | ++ |
+ #' Prepares Response Data for Population Subgroups in Data Frames+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' Prepares response rates and odds ratios for population subgroups in data frames. Simple wrapper+ |
+
| 47 | ++ |
+ #' for [h_odds_ratio_subgroups_df()] and [h_proportion_subgroups_df()]. Result is a list of two+ |
+
| 48 | ++ |
+ #' `data.frames`: `prop` and `or`. `variables` corresponds to the names of variables found in `data`,+ |
+
| 49 | ++ |
+ #' passed as a named `list` and requires elements `rsp`, `arm` and optionally `subgroups` and `strat`.+ |
+
| 50 | ++ |
+ #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ |
+
| 51 | ++ |
+ #'+ |
+
| 52 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 53 | ++ |
+ #' @inheritParams response_subgroups+ |
+
| 54 | ++ |
+ #' @param label_all (`string`)\cr label for the total population analysis.+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' @return A named list of two elements:+ |
+
| 57 | ++ |
+ #' * `prop`: A `data.frame` containing columns `arm`, `n`, `n_rsp`, `prop`, `subgroup`, `var`,+ |
+
| 58 | ++ |
+ #' `var_label`, and `row_type`.+ |
+
| 59 | ++ |
+ #' * `or`: A `data.frame` containing columns `arm`, `n_tot`, `or`, `lcl`, `ucl`, `conf_level`,+ |
+
| 60 | ++ |
+ #' `subgroup`, `var`, `var_label`, and `row_type`.+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' @seealso [response_subgroups]+ |
+
| 63 | ++ |
+ #'+ |
+
| 64 | ++ |
+ #' @examples+ |
+
| 65 | ++ |
+ #' library(dplyr)+ |
+
| 66 | ++ |
+ #' library(forcats)+ |
+
| 67 | ++ |
+ #'+ |
+
| 68 | ++ |
+ #' adrs <- tern_ex_adrs+ |
+
| 69 | ++ |
+ #' adrs_labels <- formatters::var_labels(adrs)+ |
+
| 70 | ++ |
+ #'+ |
+
| 71 | ++ |
+ #' adrs_f <- adrs %>%+ |
+
| 72 | ++ |
+ #' filter(PARAMCD == "BESRSPI") %>%+ |
+
| 73 | ++ |
+ #' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
+ |
+
| 74 | ++ |
+ #' droplevels() %>%+ |
+
| 75 | ++ |
+ #' mutate(+ |
+
| 76 | ++ |
+ #' # Reorder levels of factor to make the placebo group the reference arm.+ |
+
| 77 | ++ |
+ #' ARM = fct_relevel(ARM, "B: Placebo"),+ |
+
| 78 | ++ |
+ #' rsp = AVALC == "CR"+ |
+
| 79 | ++ |
+ #' )+ |
+
| 80 | ++ |
+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ |
+
| 81 | ++ |
+ #'+ |
+
| 82 | ++ |
+ #' # Unstratified analysis.+ |
+
| 83 | ++ |
+ #' df <- extract_rsp_subgroups(+ |
+
| 84 | ++ |
+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ |
+
| 85 | ++ |
+ #' data = adrs_f+ |
+
| 86 | ++ |
+ #' )+ |
+
| 87 | ++ |
+ #' df+ |
+
| 88 | ++ |
+ #'+ |
+
| 89 | ++ |
+ #' # Stratified analysis.+ |
+
| 90 | ++ |
+ #' df_strat <- extract_rsp_subgroups(+ |
+
| 91 | ++ |
+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2"), strat = "STRATA1"),
+ |
+
| 92 | ++ |
+ #' data = adrs_f+ |
+
| 93 | ++ |
+ #' )+ |
+
| 94 | ++ |
+ #' df_strat+ |
+
| 95 | ++ |
+ #'+ |
+
| 96 | ++ |
+ #' # Grouping of the BMRKR2 levels.+ |
+
| 97 | ++ |
+ #' df_grouped <- extract_rsp_subgroups(+ |
+
| 98 | ++ |
+ #' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
+ |
+
| 99 | ++ |
+ #' data = adrs_f,+ |
+
| 100 | ++ |
+ #' groups_lists = list(+ |
+
| 101 | ++ |
+ #' BMRKR2 = list(+ |
+
| 102 | ++ |
+ #' "low" = "LOW",+ |
+
| 103 | ++ |
+ #' "low/medium" = c("LOW", "MEDIUM"),
+ |
+
| 104 | ++ |
+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ |
+
| 105 | ++ |
+ #' )+ |
+
| 106 | ++ |
+ #' )+ |
+
| 107 | ++ |
+ #' )+ |
+
| 108 | ++ |
+ #' df_grouped+ |
+
| 109 | ++ |
+ #'+ |
+
| 110 | ++ |
+ #' @export+ |
+
| 111 | ++ |
+ extract_rsp_subgroups <- function(variables,+ |
+
| 112 | ++ |
+ data,+ |
+
| 113 | ++ |
+ groups_lists = list(),+ |
+
| 114 | ++ |
+ conf_level = 0.95,+ |
+
| 115 | ++ |
+ method = NULL,+ |
+
| 116 | ++ |
+ label_all = "All Patients") {
+ |
+
| 117 | +10x | +
+ df_prop <- h_proportion_subgroups_df(+ |
+
| 118 | +10x | +
+ variables,+ |
+
| 119 | +10x | +
+ data,+ |
+
| 120 | +10x | +
+ groups_lists = groups_lists,+ |
+
| 121 | +10x | +
+ label_all = label_all+ |
+
| 122 | ++ |
+ )+ |
+
| 123 | +10x | +
+ df_or <- h_odds_ratio_subgroups_df(+ |
+
| 124 | +10x | +
+ variables,+ |
+
| 125 | +10x | +
+ data,+ |
+
| 126 | +10x | +
+ groups_lists = groups_lists,+ |
+
| 127 | +10x | +
+ conf_level = conf_level,+ |
+
| 128 | +10x | +
+ method = method,+ |
+
| 129 | +10x | +
+ label_all = label_all+ |
+
| 130 | ++ |
+ )+ |
+
| 131 | ++ | + + | +
| 132 | +10x | +
+ list(prop = df_prop, or = df_or)+ |
+
| 133 | ++ |
+ }+ |
+
| 134 | ++ | + + | +
| 135 | ++ |
+ #' @describeIn response_subgroups Formatted analysis function which is used as `afun` in `tabulate_rsp_subgroups()`.+ |
+
| 136 | ++ |
+ #'+ |
+
| 137 | ++ |
+ #' @return+ |
+
| 138 | ++ |
+ #' * `a_response_subgroups()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 139 | ++ |
+ #'+ |
+
| 140 | ++ |
+ #' @keywords internal+ |
+
| 141 | ++ |
+ a_response_subgroups <- function(.formats = list(+ |
+
| 142 | ++ |
+ n = "xx", # nolint start+ |
+
| 143 | ++ |
+ n_rsp = "xx",+ |
+
| 144 | ++ |
+ prop = "xx.x%",+ |
+
| 145 | ++ |
+ n_tot = "xx",+ |
+
| 146 | ++ |
+ or = list(format_extreme_values(2L)),+ |
+
| 147 | ++ |
+ ci = list(format_extreme_values_ci(2L)),+ |
+
| 148 | ++ |
+ pval = "x.xxxx | (<0.0001)" # nolint end+ |
+
| 149 | ++ |
+ )) {
+ |
+
| 150 | +13x | +
+ checkmate::assert_list(.formats)+ |
+
| 151 | +13x | +
+ checkmate::assert_subset(+ |
+
| 152 | +13x | +
+ names(.formats),+ |
+
| 153 | +13x | +
+ c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
+ |
+
| 154 | ++ |
+ )+ |
+
| 155 | ++ | + + | +
| 156 | +13x | +
+ afun_lst <- Map(+ |
+
| 157 | +13x | +
+ function(stat, fmt) {
+ |
+
| 158 | +86x | +
+ if (stat == "ci") {
+ |
+
| 159 | +12x | +
+ function(df, labelstr = "", ...) {
+ |
+
| 160 | +24x | +
+ in_rows(.list = combine_vectors(df$lcl, df$ucl), .labels = as.character(df$subgroup), .formats = fmt)+ |
+
| 161 | ++ |
+ }+ |
+
| 162 | ++ |
+ } else {
+ |
+
| 163 | +74x | +
+ function(df, labelstr = "", ...) {
+ |
+
| 164 | +142x | +
+ in_rows(.list = as.list(df[[stat]]), .labels = as.character(df$subgroup), .formats = fmt)+ |
+
| 165 | ++ |
+ }+ |
+
| 166 | ++ |
+ }+ |
+
| 167 | ++ |
+ },+ |
+
| 168 | +13x | +
+ stat = names(.formats),+ |
+
| 169 | +13x | +
+ fmt = .formats+ |
+
| 170 | ++ |
+ )+ |
+
| 171 | ++ | + + | +
| 172 | +13x | +
+ afun_lst+ |
+
| 173 | ++ |
+ }+ |
+
| 174 | ++ | + + | +
| 175 | ++ |
+ #' @describeIn response_subgroups Table-creating function which creates a table+ |
+
| 176 | ++ |
+ #' summarizing binary response by subgroup. This function is a wrapper for [rtables::analyze_colvars()]+ |
+
| 177 | ++ |
+ #' and [rtables::summarize_row_groups()].+ |
+
| 178 | ++ |
+ #'+ |
+
| 179 | ++ |
+ #' @param df (`list`)\cr of data frames containing all analysis variables. List should be+ |
+
| 180 | ++ |
+ #' created using [extract_rsp_subgroups()].+ |
+
| 181 | ++ |
+ #' @param vars (`character`)\cr the names of statistics to be reported among:+ |
+
| 182 | ++ |
+ #' * `n`: Total number of observations per group.+ |
+
| 183 | ++ |
+ #' * `n_rsp`: Number of responders per group.+ |
+
| 184 | ++ |
+ #' * `prop`: Proportion of responders.+ |
+
| 185 | ++ |
+ #' * `n_tot`: Total number of observations.+ |
+
| 186 | ++ |
+ #' * `or`: Odds ratio.+ |
+
| 187 | ++ |
+ #' * `ci` : Confidence interval of odds ratio.+ |
+
| 188 | ++ |
+ #' * `pval`: p-value of the effect.+ |
+
| 189 | ++ |
+ #' Note, the statistics `n_tot`, `or` and `ci` are required.+ |
+
| 190 | ++ |
+ #'+ |
+
| 191 | ++ |
+ #' @return An `rtables` table summarizing binary response by subgroup.+ |
+
| 192 | ++ |
+ #'+ |
+
| 193 | ++ |
+ #' @examples+ |
+
| 194 | ++ |
+ #' ## Table with default columns.+ |
+
| 195 | ++ |
+ #' basic_table() %>%+ |
+
| 196 | ++ |
+ #' tabulate_rsp_subgroups(df)+ |
+
| 197 | ++ |
+ #'+ |
+
| 198 | ++ |
+ #' ## Table with selected columns.+ |
+
| 199 | ++ |
+ #' basic_table() %>%+ |
+
| 200 | ++ |
+ #' tabulate_rsp_subgroups(+ |
+
| 201 | ++ |
+ #' df = df,+ |
+
| 202 | ++ |
+ #' vars = c("n_tot", "n", "n_rsp", "prop", "or", "ci")
+ |
+
| 203 | ++ |
+ #' )+ |
+
| 204 | ++ |
+ #'+ |
+
| 205 | ++ |
+ #' @export+ |
+
| 206 | ++ |
+ tabulate_rsp_subgroups <- function(lyt,+ |
+
| 207 | ++ |
+ df,+ |
+
| 208 | ++ |
+ vars = c("n_tot", "n", "prop", "or", "ci")) {
+ |
+
| 209 | +6x | +
+ conf_level <- df$or$conf_level[1]+ |
+
| 210 | +6x | +
+ method <- if ("pval_label" %in% names(df$or)) {
+ |
+
| 211 | +4x | +
+ df$or$pval_label[1]+ |
+
| 212 | ++ |
+ } else {
+ |
+
| 213 | +2x | +
+ NULL+ |
+
| 214 | ++ |
+ }+ |
+
| 215 | ++ | + + | +
| 216 | +6x | +
+ afun_lst <- a_response_subgroups()+ |
+
| 217 | +6x | +
+ colvars <- d_rsp_subgroups_colvars(vars, conf_level = conf_level, method = method)+ |
+
| 218 | ++ | + + | +
| 219 | +6x | +
+ colvars_prop <- list(+ |
+
| 220 | +6x | +
+ vars = colvars$vars[names(colvars$labels) %in% c("n", "prop", "n_rsp")],
+ |
+
| 221 | +6x | +
+ labels = colvars$labels[names(colvars$labels) %in% c("n", "prop", "n_rsp")]
+ |
+
| 222 | ++ |
+ )+ |
+
| 223 | +6x | +
+ colvars_or <- list(+ |
+
| 224 | +6x | +
+ vars = colvars$vars[names(colvars$labels) %in% c("n_tot", "or", "ci", "pval")],
+ |
+
| 225 | +6x | +
+ labels = colvars$labels[names(colvars$labels) %in% c("n_tot", "or", "ci", "pval")]
+ |
+
| 226 | ++ |
+ )+ |
+
| 227 | ++ | + + | +
| 228 | ++ |
+ # Columns from table_prop are optional.+ |
+
| 229 | +6x | +
+ if (length(colvars_prop$vars) > 0) {
+ |
+
| 230 | +6x | +
+ lyt_prop <- split_cols_by(lyt = lyt, var = "arm")+ |
+
| 231 | +6x | +
+ lyt_prop <- split_cols_by_multivar(+ |
+
| 232 | +6x | +
+ lyt = lyt_prop,+ |
+
| 233 | +6x | +
+ vars = colvars_prop$vars,+ |
+
| 234 | +6x | +
+ varlabels = colvars_prop$labels+ |
+
| 235 | ++ |
+ )+ |
+
| 236 | ++ | + + | +
| 237 | ++ |
+ # "All Patients" row+ |
+
| 238 | +6x | +
+ lyt_prop <- split_rows_by(+ |
+
| 239 | +6x | +
+ lyt = lyt_prop,+ |
+
| 240 | +6x | +
+ var = "row_type",+ |
+
| 241 | +6x | +
+ split_fun = keep_split_levels("content"),
+ |
+
| 242 | +6x | +
+ nested = FALSE,+ |
+
| 243 | +6x | +
+ child_labels = "hidden"+ |
+
| 244 | ++ |
+ )+ |
+
| 245 | +6x | +
+ lyt_prop <- analyze_colvars(+ |
+
| 246 | +6x | +
+ lyt = lyt_prop,+ |
+
| 247 | +6x | +
+ afun = afun_lst[names(colvars_prop$labels)]+ |
+
| 248 | ++ |
+ )+ |
+
| 249 | ++ | + + | +
| 250 | +6x | +
+ if ("analysis" %in% df$prop$row_type) {
+ |
+
| 251 | +5x | +
+ lyt_prop <- split_rows_by(+ |
+
| 252 | +5x | +
+ lyt = lyt_prop,+ |
+
| 253 | +5x | +
+ var = "row_type",+ |
+
| 254 | +5x | +
+ split_fun = keep_split_levels("analysis"),
+ |
+
| 255 | +5x | +
+ nested = FALSE,+ |
+
| 256 | +5x | +
+ child_labels = "hidden"+ |
+
| 257 | ++ |
+ )+ |
+
| 258 | +5x | +
+ lyt_prop <- split_rows_by(lyt = lyt_prop, var = "var_label", nested = TRUE)+ |
+
| 259 | +5x | +
+ lyt_prop <- analyze_colvars(+ |
+
| 260 | +5x | +
+ lyt = lyt_prop,+ |
+
| 261 | +5x | +
+ afun = afun_lst[names(colvars_prop$labels)],+ |
+
| 262 | +5x | +
+ inclNAs = TRUE+ |
+
| 263 | ++ |
+ )+ |
+
| 264 | ++ |
+ }+ |
+
| 265 | ++ | + + | +
| 266 | +6x | +
+ table_prop <- build_table(lyt_prop, df = df$prop)+ |
+
| 267 | ++ |
+ } else {
+ |
+
| 268 | +! | +
+ table_prop <- NULL+ |
+
| 269 | ++ |
+ }+ |
+
| 270 | ++ | + + | +
| 271 | ++ |
+ # Columns "n_tot", "or", "ci" in table_or are required.+ |
+
| 272 | +6x | +
+ lyt_or <- split_cols_by(lyt = lyt, var = "arm")+ |
+
| 273 | +6x | +
+ lyt_or <- split_cols_by_multivar(+ |
+
| 274 | +6x | +
+ lyt = lyt_or,+ |
+
| 275 | +6x | +
+ vars = colvars_or$vars,+ |
+
| 276 | +6x | +
+ varlabels = colvars_or$labels+ |
+
| 277 | ++ |
+ )+ |
+
| 278 | ++ | + + | +
| 279 | ++ |
+ # "All Patients" row+ |
+
| 280 | +6x | +
+ lyt_or <- split_rows_by(+ |
+
| 281 | +6x | +
+ lyt = lyt_or,+ |
+
| 282 | +6x | +
+ var = "row_type",+ |
+
| 283 | +6x | +
+ split_fun = keep_split_levels("content"),
+ |
+
| 284 | +6x | +
+ nested = FALSE,+ |
+
| 285 | +6x | +
+ child_labels = "hidden"+ |
+
| 286 | ++ |
+ )+ |
+
| 287 | +6x | +
+ lyt_or <- analyze_colvars(+ |
+
| 288 | +6x | +
+ lyt = lyt_or,+ |
+
| 289 | +6x | +
+ afun = afun_lst[names(colvars_or$labels)]+ |
+
| 290 | ++ |
+ ) %>%+ |
+
| 291 | +6x | +
+ append_topleft("Baseline Risk Factors")
+ |
+
| 292 | ++ | + + | +
| 293 | +6x | +
+ if ("analysis" %in% df$or$row_type) {
+ |
+
| 294 | +5x | +
+ lyt_or <- split_rows_by(+ |
+
| 295 | +5x | +
+ lyt = lyt_or,+ |
+
| 296 | +5x | +
+ var = "row_type",+ |
+
| 297 | +5x | +
+ split_fun = keep_split_levels("analysis"),
+ |
+
| 298 | +5x | +
+ nested = FALSE,+ |
+
| 299 | +5x | +
+ child_labels = "hidden"+ |
+
| 300 | ++ |
+ )+ |
+
| 301 | +5x | +
+ lyt_or <- split_rows_by(lyt = lyt_or, var = "var_label", nested = TRUE)+ |
+
| 302 | +5x | +
+ lyt_or <- analyze_colvars(+ |
+
| 303 | +5x | +
+ lyt = lyt_or,+ |
+
| 304 | +5x | +
+ afun = afun_lst[names(colvars_or$labels)],+ |
+
| 305 | +5x | +
+ inclNAs = TRUE+ |
+
| 306 | ++ |
+ )+ |
+
| 307 | ++ |
+ }+ |
+
| 308 | +6x | +
+ table_or <- build_table(lyt_or, df = df$or)+ |
+
| 309 | ++ | + + | +
| 310 | +6x | +
+ n_tot_id <- match("n_tot", colvars_or$vars)
+ |
+
| 311 | +6x | +
+ if (is.null(table_prop)) {
+ |
+
| 312 | +! | +
+ result <- table_or+ |
+
| 313 | +! | +
+ or_id <- match("or", colvars_or$vars)
+ |
+
| 314 | +! | +
+ ci_id <- match("lcl", colvars_or$vars)
+ |
+
| 315 | ++ |
+ } else {
+ |
+
| 316 | +6x | +
+ result <- cbind_rtables(table_or[, n_tot_id], table_prop, table_or[, -n_tot_id])+ |
+
| 317 | +6x | +
+ or_id <- 1L + ncol(table_prop) + match("or", colvars_or$vars[-n_tot_id])
+ |
+
| 318 | +6x | +
+ ci_id <- 1L + ncol(table_prop) + match("lcl", colvars_or$vars[-n_tot_id])
+ |
+
| 319 | +6x | +
+ n_tot_id <- 1L+ |
+
| 320 | ++ |
+ }+ |
+
| 321 | +6x | +
+ structure(+ |
+
| 322 | +6x | +
+ result,+ |
+
| 323 | +6x | +
+ forest_header = paste0(levels(df$prop$arm), "\nBetter"),+ |
+
| 324 | +6x | +
+ col_x = or_id,+ |
+
| 325 | +6x | +
+ col_ci = ci_id,+ |
+
| 326 | +6x | +
+ col_symbol_size = n_tot_id+ |
+
| 327 | ++ |
+ )+ |
+
| 328 | ++ |
+ }+ |
+
| 329 | ++ | + + | +
| 330 | ++ |
+ #' Labels for Column Variables in Binary Response by Subgroup Table+ |
+
| 331 | ++ |
+ #'+ |
+
| 332 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 333 | ++ |
+ #'+ |
+
| 334 | ++ |
+ #' Internal function to check variables included in [tabulate_rsp_subgroups()] and create column labels.+ |
+
| 335 | ++ |
+ #'+ |
+
| 336 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 337 | ++ |
+ #' @inheritParams tabulate_rsp_subgroups+ |
+
| 338 | ++ |
+ #'+ |
+
| 339 | ++ |
+ #' @return A `list` of variables to tabulate and their labels.+ |
+
| 340 | ++ |
+ #'+ |
+
| 341 | ++ |
+ #' @export+ |
+
| 342 | ++ |
+ d_rsp_subgroups_colvars <- function(vars,+ |
+
| 343 | ++ |
+ conf_level = NULL,+ |
+
| 344 | ++ |
+ method = NULL) {
+ |
+
| 345 | +13x | +
+ checkmate::assert_character(vars)+ |
+
| 346 | +13x | +
+ checkmate::assert_subset(c("n_tot", "or", "ci"), vars)
+ |
+
| 347 | +13x | +
+ checkmate::assert_subset(+ |
+
| 348 | +13x | +
+ vars,+ |
+
| 349 | +13x | +
+ c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
+ |
+
| 350 | ++ |
+ )+ |
+
| 351 | ++ | + + | +
| 352 | +13x | +
+ varlabels <- c(+ |
+
| 353 | +13x | +
+ n = "n",+ |
+
| 354 | +13x | +
+ n_rsp = "Responders",+ |
+
| 355 | +13x | +
+ prop = "Response (%)",+ |
+
| 356 | +13x | +
+ n_tot = "Total n",+ |
+
| 357 | +13x | +
+ or = "Odds Ratio"+ |
+
| 358 | ++ |
+ )+ |
+
| 359 | +13x | +
+ colvars <- vars+ |
+
| 360 | ++ | + + | +
| 361 | +13x | +
+ if ("ci" %in% colvars) {
+ |
+
| 362 | +13x | +
+ checkmate::assert_false(is.null(conf_level))+ |
+
| 363 | ++ | + + | +
| 364 | +13x | +
+ varlabels <- c(+ |
+
| 365 | +13x | +
+ varlabels,+ |
+
| 366 | +13x | +
+ ci = paste0(100 * conf_level, "% CI")+ |
+
| 367 | ++ |
+ )+ |
+
| 368 | ++ | + + | +
| 369 | ++ |
+ # The `lcl`` variable is just a placeholder available in the analysis data,+ |
+
| 370 | ++ |
+ # it is not acutally used in the tabulation.+ |
+
| 371 | ++ |
+ # Variables used in the tabulation are lcl and ucl, see `a_response_subgroups` for details.+ |
+
| 372 | +13x | +
+ colvars[colvars == "ci"] <- "lcl"+ |
+
| 373 | ++ |
+ }+ |
+
| 374 | ++ | + + | +
| 375 | +13x | +
+ if ("pval" %in% colvars) {
+ |
+
| 376 | +10x | +
+ varlabels <- c(+ |
+
| 377 | +10x | +
+ varlabels,+ |
+
| 378 | +10x | +
+ pval = method+ |
+
| 379 | ++ |
+ )+ |
+
| 380 | ++ |
+ }+ |
+
| 381 | ++ | + + | +
| 382 | +13x | +
+ list(+ |
+
| 383 | +13x | +
+ vars = colvars,+ |
+
| 384 | +13x | +
+ labels = varlabels[vars]+ |
+
| 385 | ++ |
+ )+ |
+
| 386 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Number of Patients+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Count the number of unique and non-unique patients in a column (variable).+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 8 | ++ |
+ #' @param x (`character` or `factor`)\cr vector of patient IDs.+ |
+
| 9 | ++ |
+ #' @param count_by (`character` or `factor`)\cr optional vector to be combined with `x` when counting+ |
+
| 10 | ++ |
+ #' `nonunique` records.+ |
+
| 11 | ++ |
+ #' @param unique_count_suffix (`logical`)\cr should `"(n)"` suffix be added to `unique_count` labels.+ |
+
| 12 | ++ |
+ #' Defaults to `TRUE`.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @name summarize_num_patients+ |
+
| 15 | ++ |
+ NULL+ |
+
| 16 | ++ | + + | +
| 17 | ++ |
+ #' @describeIn summarize_num_patients Statistics function which counts the number of+ |
+
| 18 | ++ |
+ #' unique patients, the corresponding percentage taken with respect to the+ |
+
| 19 | ++ |
+ #' total number of patients, and the number of non-unique patients.+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @return+ |
+
| 22 | ++ |
+ #' * `s_num_patients()` returns a named `list` of 3 statistics:+ |
+
| 23 | ++ |
+ #' * `unique`: Vector of counts and percentages.+ |
+
| 24 | ++ |
+ #' * `nonunique`: Vector of counts.+ |
+
| 25 | ++ |
+ #' * `unique_count`: Counts.+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' @examples+ |
+
| 28 | ++ |
+ #' # Use the statistics function to count number of unique and nonunique patients.+ |
+
| 29 | ++ |
+ #' s_num_patients(x = as.character(c(1, 1, 1, 2, 4, NA)), labelstr = "", .N_col = 6L)+ |
+
| 30 | ++ |
+ #' s_num_patients(+ |
+
| 31 | ++ |
+ #' x = as.character(c(1, 1, 1, 2, 4, NA)),+ |
+
| 32 | ++ |
+ #' labelstr = "",+ |
+
| 33 | ++ |
+ #' .N_col = 6L,+ |
+
| 34 | ++ |
+ #' count_by = as.character(c(1, 1, 2, 1, 1, 1))+ |
+
| 35 | ++ |
+ #' )+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' @export+ |
+
| 38 | ++ |
+ s_num_patients <- function(x, labelstr, .N_col, count_by = NULL, unique_count_suffix = TRUE) { # nolint
+ |
+
| 39 | ++ | + + | +
| 40 | +109x | +
+ checkmate::assert_string(labelstr)+ |
+
| 41 | +109x | +
+ checkmate::assert_count(.N_col)+ |
+
| 42 | +109x | +
+ checkmate::assert_multi_class(x, classes = c("factor", "character"))
+ |
+
| 43 | +109x | +
+ checkmate::assert_flag(unique_count_suffix)+ |
+
| 44 | ++ | + + | +
| 45 | +109x | +
+ count1 <- n_available(unique(x))+ |
+
| 46 | +109x | +
+ count2 <- n_available(x)+ |
+
| 47 | ++ | + + | +
| 48 | +109x | +
+ if (!is.null(count_by)) {
+ |
+
| 49 | +10x | +
+ checkmate::assert_vector(count_by, len = length(x))+ |
+
| 50 | +10x | +
+ checkmate::assert_multi_class(count_by, classes = c("factor", "character"))
+ |
+
| 51 | +10x | +
+ count2 <- n_available(unique(interaction(x, count_by)))+ |
+
| 52 | ++ |
+ }+ |
+
| 53 | ++ | + + | +
| 54 | +109x | +
+ out <- list(+ |
+
| 55 | +109x | +
+ unique = formatters::with_label(c(count1, ifelse(count1 == 0 && .N_col == 0, 0, count1 / .N_col)), labelstr),+ |
+
| 56 | +109x | +
+ nonunique = formatters::with_label(count2, labelstr),+ |
+
| 57 | +109x | +
+ unique_count = formatters::with_label(+ |
+
| 58 | +109x | +
+ count1, ifelse(unique_count_suffix, paste0(labelstr, if (nzchar(labelstr)) " ", "(n)"), labelstr)+ |
+
| 59 | ++ |
+ )+ |
+
| 60 | ++ |
+ )+ |
+
| 61 | ++ | + + | +
| 62 | +109x | +
+ out+ |
+
| 63 | ++ |
+ }+ |
+
| 64 | ++ | + + | +
| 65 | ++ |
+ #' @describeIn summarize_num_patients Statistics function which counts the number of unique patients+ |
+
| 66 | ++ |
+ #' in a column (variable), the corresponding percentage taken with respect to the total number of+ |
+
| 67 | ++ |
+ #' patients, and the number of non-unique patients in the column.+ |
+
| 68 | ++ |
+ #'+ |
+
| 69 | ++ |
+ #' @param required (`character` or `NULL`)\cr optional name of a variable that is required to be non-missing.+ |
+
| 70 | ++ |
+ #'+ |
+
| 71 | ++ |
+ #' @return+ |
+
| 72 | ++ |
+ #' * `s_num_patients_content()` returns the same values as `s_num_patients()`.+ |
+
| 73 | ++ |
+ #'+ |
+
| 74 | ++ |
+ #' @examples+ |
+
| 75 | ++ |
+ #' # Count number of unique and non-unique patients.+ |
+
| 76 | ++ |
+ #' df <- data.frame(+ |
+
| 77 | ++ |
+ #' USUBJID = as.character(c(1, 2, 1, 4, NA)),+ |
+
| 78 | ++ |
+ #' EVENT = as.character(c(10, 15, 10, 17, 8))+ |
+
| 79 | ++ |
+ #' )+ |
+
| 80 | ++ |
+ #' s_num_patients_content(df, .N_col = 5, .var = "USUBJID")+ |
+
| 81 | ++ |
+ #'+ |
+
| 82 | ++ |
+ #' df_by_event <- data.frame(+ |
+
| 83 | ++ |
+ #' USUBJID = as.character(c(1, 2, 1, 4, NA)),+ |
+
| 84 | ++ |
+ #' EVENT = as.character(c(10, 15, 10, 17, 8))+ |
+
| 85 | ++ |
+ #' )+ |
+
| 86 | ++ |
+ #' s_num_patients_content(df_by_event, .N_col = 5, .var = "USUBJID")+ |
+
| 87 | ++ |
+ #' s_num_patients_content(df_by_event, .N_col = 5, .var = "USUBJID", count_by = "EVENT")+ |
+
| 88 | ++ |
+ #'+ |
+
| 89 | ++ |
+ #' @export+ |
+
| 90 | ++ |
+ s_num_patients_content <- function(df,+ |
+
| 91 | ++ |
+ labelstr = "",+ |
+
| 92 | ++ |
+ .N_col, # nolint+ |
+
| 93 | ++ |
+ .var,+ |
+
| 94 | ++ |
+ required = NULL,+ |
+
| 95 | ++ |
+ count_by = NULL,+ |
+
| 96 | ++ |
+ unique_count_suffix = TRUE) {
+ |
+
| 97 | +46x | +
+ checkmate::assert_string(.var)+ |
+
| 98 | +46x | +
+ checkmate::assert_data_frame(df)+ |
+
| 99 | +46x | +
+ if (is.null(count_by)) {
+ |
+
| 100 | +43x | +
+ assert_df_with_variables(df, list(id = .var))+ |
+
| 101 | ++ |
+ } else {
+ |
+
| 102 | +3x | +
+ assert_df_with_variables(df, list(id = .var, count_by = count_by))+ |
+
| 103 | ++ |
+ }+ |
+
| 104 | +46x | +
+ if (!is.null(required)) {
+ |
+
| 105 | +! | +
+ checkmate::assert_string(required)+ |
+
| 106 | +! | +
+ assert_df_with_variables(df, list(required = required))+ |
+
| 107 | +! | +
+ df <- df[!is.na(df[[required]]), , drop = FALSE]+ |
+
| 108 | ++ |
+ }+ |
+
| 109 | ++ | + + | +
| 110 | +46x | +
+ x <- df[[.var]]+ |
+
| 111 | +46x | +
+ y <- switch(as.numeric(!is.null(count_by)) + 1,+ |
+
| 112 | +46x | +
+ NULL,+ |
+
| 113 | +46x | +
+ df[[count_by]]+ |
+
| 114 | ++ |
+ )+ |
+
| 115 | ++ | + + | +
| 116 | +46x | +
+ s_num_patients(+ |
+
| 117 | +46x | +
+ x = x,+ |
+
| 118 | +46x | +
+ labelstr = labelstr,+ |
+
| 119 | +46x | +
+ .N_col = .N_col,+ |
+
| 120 | +46x | +
+ count_by = y,+ |
+
| 121 | +46x | +
+ unique_count_suffix = unique_count_suffix+ |
+
| 122 | ++ |
+ )+ |
+
| 123 | ++ |
+ }+ |
+
| 124 | ++ | + + | +
| 125 | ++ |
+ c_num_patients <- make_afun(+ |
+
| 126 | ++ |
+ s_num_patients_content,+ |
+
| 127 | ++ |
+ .stats = c("unique", "nonunique", "unique_count"),
+ |
+
| 128 | ++ |
+ .formats = c(unique = format_count_fraction_fixed_dp, nonunique = "xx", unique_count = "xx")+ |
+
| 129 | ++ |
+ )+ |
+
| 130 | ++ | + + | +
| 131 | ++ |
+ #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments+ |
+
| 132 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::summarize_row_groups()].+ |
+
| 133 | ++ |
+ #'+ |
+
| 134 | ++ |
+ #' @return+ |
+
| 135 | ++ |
+ #' * `summarize_num_patients()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 136 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 137 | ++ |
+ #' the statistics from `s_num_patients_content()` to the table layout.+ |
+
| 138 | ++ |
+ #'+ |
+
| 139 | ++ |
+ #' @export+ |
+
| 140 | ++ |
+ summarize_num_patients <- function(lyt,+ |
+
| 141 | ++ |
+ var,+ |
+
| 142 | ++ |
+ na_str = NA_character_,+ |
+
| 143 | ++ |
+ .stats = NULL,+ |
+
| 144 | ++ |
+ .formats = NULL,+ |
+
| 145 | ++ |
+ .labels = c(+ |
+
| 146 | ++ |
+ unique = "Number of patients with at least one event",+ |
+
| 147 | ++ |
+ nonunique = "Number of events"+ |
+
| 148 | ++ |
+ ),+ |
+
| 149 | ++ |
+ indent_mod = lifecycle::deprecated(),+ |
+
| 150 | ++ |
+ .indent_mods = 0L,+ |
+
| 151 | ++ |
+ riskdiff = FALSE,+ |
+
| 152 | ++ |
+ ...) {
+ |
+
| 153 | +9x | +
+ checkmate::assert_flag(riskdiff)+ |
+
| 154 | ++ | + + | +
| 155 | +9x | +
+ if (lifecycle::is_present(indent_mod)) {
+ |
+
| 156 | +! | +
+ lifecycle::deprecate_warn("0.8.2", "summarize_num_patients(indent_mod)", "summarize_num_patients(.indent_mods)")
+ |
+
| 157 | +! | +
+ .indent_mods <- indent_mod+ |
+
| 158 | ++ |
+ }+ |
+
| 159 | ++ | + + | +
| 160 | +4x | +
+ if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
+ |
+
| 161 | +2x | +
+ if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats]+ |
+
| 162 | ++ | + + | +
| 163 | +9x | +
+ cfun <- make_afun(+ |
+
| 164 | +9x | +
+ c_num_patients,+ |
+
| 165 | +9x | +
+ .stats = .stats,+ |
+
| 166 | +9x | +
+ .formats = .formats,+ |
+
| 167 | +9x | +
+ .labels = .labels+ |
+
| 168 | ++ |
+ )+ |
+
| 169 | ++ | + + | +
| 170 | +9x | +
+ extra_args <- if (isFALSE(riskdiff)) {
+ |
+
| 171 | +8x | +
+ list(...)+ |
+
| 172 | ++ |
+ } else {
+ |
+
| 173 | +1x | +
+ list(+ |
+
| 174 | +1x | +
+ afun = list("s_num_patients_content" = cfun),
+ |
+
| 175 | +1x | +
+ .stats = .stats,+ |
+
| 176 | +1x | +
+ .indent_mods = .indent_mods,+ |
+
| 177 | +1x | +
+ s_args = list(...)+ |
+
| 178 | ++ |
+ )+ |
+
| 179 | ++ |
+ }+ |
+
| 180 | ++ | + + | +
| 181 | +9x | +
+ summarize_row_groups(+ |
+
| 182 | +9x | +
+ lyt = lyt,+ |
+
| 183 | +9x | +
+ var = var,+ |
+
| 184 | +9x | +
+ cfun = ifelse(isFALSE(riskdiff), cfun, afun_riskdiff),+ |
+
| 185 | +9x | +
+ na_str = na_str,+ |
+
| 186 | +9x | +
+ extra_args = extra_args,+ |
+
| 187 | +9x | +
+ indent_mod = .indent_mods+ |
+
| 188 | ++ |
+ )+ |
+
| 189 | ++ |
+ }+ |
+
| 190 | ++ | + + | +
| 191 | ++ |
+ #' @describeIn summarize_num_patients Layout-creating function which can take statistics function arguments+ |
+
| 192 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 193 | ++ |
+ #'+ |
+
| 194 | ++ |
+ #' @return+ |
+
| 195 | ++ |
+ #' * `analyze_num_patients()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 196 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 197 | ++ |
+ #' the statistics from `s_num_patients_content()` to the table layout.+ |
+
| 198 | ++ |
+ #'+ |
+
| 199 | ++ |
+ #' @details In general, functions that starts with `analyze*` are expected to+ |
+
| 200 | ++ |
+ #' work like [rtables::analyze()], while functions that starts with `summarize*`+ |
+
| 201 | ++ |
+ #' are based upon [rtables::summarize_row_groups()]. The latter provides a+ |
+
| 202 | ++ |
+ #' value for each dividing split in the row and column space, but, being it+ |
+
| 203 | ++ |
+ #' bound to the fundamental splits, it is repeated by design in every page+ |
+
| 204 | ++ |
+ #' when pagination is involved.+ |
+
| 205 | ++ |
+ #'+ |
+
| 206 | ++ |
+ #' @note As opposed to [summarize_num_patients()], this function does not repeat the produced rows.+ |
+
| 207 | ++ |
+ #'+ |
+
| 208 | ++ |
+ #' @examples+ |
+
| 209 | ++ |
+ #' df_tmp <- data.frame(+ |
+
| 210 | ++ |
+ #' USUBJID = as.character(c(1, 2, 1, 4, NA, 6, 6, 8, 9)),+ |
+
| 211 | ++ |
+ #' ARM = c("A", "A", "A", "A", "A", "B", "B", "B", "B"),
+ |
+
| 212 | ++ |
+ #' AGE = c(10, 15, 10, 17, 8, 11, 11, 19, 17)+ |
+
| 213 | ++ |
+ #' )+ |
+
| 214 | ++ |
+ #' tbl <- basic_table() %>%+ |
+
| 215 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 216 | ++ |
+ #' add_colcounts() %>%+ |
+
| 217 | ++ |
+ #' analyze_num_patients("USUBJID", .stats = c("unique")) %>%
+ |
+
| 218 | ++ |
+ #' build_table(df_tmp)+ |
+
| 219 | ++ |
+ #' tbl+ |
+
| 220 | ++ |
+ #'+ |
+
| 221 | ++ |
+ #' @export+ |
+
| 222 | ++ |
+ analyze_num_patients <- function(lyt,+ |
+
| 223 | ++ |
+ vars,+ |
+
| 224 | ++ |
+ na_str = NA_character_,+ |
+
| 225 | ++ |
+ nested = TRUE,+ |
+
| 226 | ++ |
+ .stats = NULL,+ |
+
| 227 | ++ |
+ .formats = NULL,+ |
+
| 228 | ++ |
+ .labels = c(+ |
+
| 229 | ++ |
+ unique = "Number of patients with at least one event",+ |
+
| 230 | ++ |
+ nonunique = "Number of events"+ |
+
| 231 | ++ |
+ ),+ |
+
| 232 | ++ |
+ show_labels = c("default", "visible", "hidden"),
+ |
+
| 233 | ++ |
+ indent_mod = lifecycle::deprecated(),+ |
+
| 234 | ++ |
+ .indent_mods = 0L,+ |
+
| 235 | ++ |
+ riskdiff = FALSE,+ |
+
| 236 | ++ |
+ ...) {
+ |
+
| 237 | +3x | +
+ checkmate::assert_flag(riskdiff)+ |
+
| 238 | ++ | + + | +
| 239 | +3x | +
+ if (lifecycle::is_present(indent_mod)) {
+ |
+
| 240 | +! | +
+ lifecycle::deprecate_warn("0.8.2", "analyze_num_patients(indent_mod)", "analyze_num_patients(.indent_mods)")
+ |
+
| 241 | +! | +
+ .indent_mods <- indent_mod+ |
+
| 242 | ++ |
+ }+ |
+
| 243 | ++ | + + | +
| 244 | +! | +
+ if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
+ |
+
| 245 | +! | +
+ if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats]+ |
+
| 246 | ++ | + + | +
| 247 | +3x | +
+ afun <- make_afun(+ |
+
| 248 | +3x | +
+ c_num_patients,+ |
+
| 249 | +3x | +
+ .stats = .stats,+ |
+
| 250 | +3x | +
+ .formats = .formats,+ |
+
| 251 | +3x | +
+ .labels = .labels+ |
+
| 252 | ++ |
+ )+ |
+
| 253 | ++ | + + | +
| 254 | +3x | +
+ extra_args <- if (isFALSE(riskdiff)) {
+ |
+
| 255 | +2x | +
+ list(...)+ |
+
| 256 | ++ |
+ } else {
+ |
+
| 257 | +1x | +
+ list(+ |
+
| 258 | +1x | +
+ afun = list("s_num_patients_content" = afun),
+ |
+
| 259 | +1x | +
+ .stats = .stats,+ |
+
| 260 | +1x | +
+ .indent_mods = .indent_mods,+ |
+
| 261 | +1x | +
+ s_args = list(...)+ |
+
| 262 | ++ |
+ )+ |
+
| 263 | ++ |
+ }+ |
+
| 264 | ++ | + + | +
| 265 | +3x | +
+ analyze(+ |
+
| 266 | +3x | +
+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ |
+
| 267 | +3x | +
+ lyt = lyt,+ |
+
| 268 | +3x | +
+ vars = vars,+ |
+
| 269 | +3x | +
+ na_str = na_str,+ |
+
| 270 | +3x | +
+ nested = nested,+ |
+
| 271 | +3x | +
+ extra_args = extra_args,+ |
+
| 272 | +3x | +
+ show_labels = show_labels,+ |
+
| 273 | +3x | +
+ indent_mod = .indent_mods+ |
+
| 274 | ++ |
+ )+ |
+
| 275 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Formatting Functions+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' See below for the list of formatting functions created in `tern` to work with `rtables`.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' Other available formats can be listed via [`formatters::list_valid_format_labels()`]. Additional+ |
+
| 8 | ++ |
+ #' custom formats can be created via the [`formatters::sprintf_format()`] function.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @family formatting functions+ |
+
| 11 | ++ |
+ #' @name formatting_functions+ |
+
| 12 | ++ |
+ NULL+ |
+
| 13 | ++ | + + | +
| 14 | ++ |
+ #' Formatting Fraction and Percentage+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' Formats a fraction together with ratio in percent.+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @param x (`integer`)\cr with elements `num` and `denom`.+ |
+
| 21 | ++ |
+ #' @param ... required for `rtables` interface.+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`.+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @examples+ |
+
| 26 | ++ |
+ #' format_fraction(x = c(num = 2L, denom = 3L))+ |
+
| 27 | ++ |
+ #' format_fraction(x = c(num = 0L, denom = 3L))+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @family formatting functions+ |
+
| 30 | ++ |
+ #' @export+ |
+
| 31 | ++ |
+ format_fraction <- function(x, ...) {
+ |
+
| 32 | +4x | +
+ attr(x, "label") <- NULL+ |
+
| 33 | ++ | + + | +
| 34 | +4x | +
+ checkmate::assert_vector(x)+ |
+
| 35 | +4x | +
+ checkmate::assert_count(x["num"])+ |
+
| 36 | +2x | +
+ checkmate::assert_count(x["denom"])+ |
+
| 37 | ++ | + + | +
| 38 | +2x | +
+ result <- if (x["num"] == 0) {
+ |
+
| 39 | +1x | +
+ paste0(x["num"], "/", x["denom"])+ |
+
| 40 | ++ |
+ } else {
+ |
+
| 41 | +1x | +
+ paste0(+ |
+
| 42 | +1x | +
+ x["num"], "/", x["denom"],+ |
+
| 43 | +1x | +
+ " (", round(x["num"] / x["denom"] * 100, 1), "%)"
+ |
+
| 44 | ++ |
+ )+ |
+
| 45 | ++ |
+ }+ |
+
| 46 | ++ | + + | +
| 47 | +2x | +
+ return(result)+ |
+
| 48 | ++ |
+ }+ |
+
| 49 | ++ | + + | +
| 50 | ++ |
+ #' Formatting Fraction and Percentage with Fixed Single Decimal Place+ |
+
| 51 | ++ |
+ #'+ |
+
| 52 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 53 | ++ |
+ #'+ |
+
| 54 | ++ |
+ #' Formats a fraction together with ratio in percent with fixed single decimal place.+ |
+
| 55 | ++ |
+ #' Includes trailing zero in case of whole number percentages to always keep one decimal place.+ |
+
| 56 | ++ |
+ #'+ |
+
| 57 | ++ |
+ #' @param x (`integer`)\cr with elements `num` and `denom`.+ |
+
| 58 | ++ |
+ #' @param ... required for `rtables` interface.+ |
+
| 59 | ++ |
+ #'+ |
+
| 60 | ++ |
+ #' @return A string in the format `num / denom (ratio %)`. If `num` is 0, the format is `num / denom`.+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' @examples+ |
+
| 63 | ++ |
+ #' format_fraction_fixed_dp(x = c(num = 1L, denom = 2L))+ |
+
| 64 | ++ |
+ #' format_fraction_fixed_dp(x = c(num = 1L, denom = 4L))+ |
+
| 65 | ++ |
+ #' format_fraction_fixed_dp(x = c(num = 0L, denom = 3L))+ |
+
| 66 | ++ |
+ #'+ |
+
| 67 | ++ |
+ #' @family formatting functions+ |
+
| 68 | ++ |
+ #' @export+ |
+
| 69 | ++ |
+ format_fraction_fixed_dp <- function(x, ...) {
+ |
+
| 70 | +3x | +
+ attr(x, "label") <- NULL+ |
+
| 71 | +3x | +
+ checkmate::assert_vector(x)+ |
+
| 72 | +3x | +
+ checkmate::assert_count(x["num"])+ |
+
| 73 | +3x | +
+ checkmate::assert_count(x["denom"])+ |
+
| 74 | ++ | + + | +
| 75 | +3x | +
+ result <- if (x["num"] == 0) {
+ |
+
| 76 | +1x | +
+ paste0(x["num"], "/", x["denom"])+ |
+
| 77 | ++ |
+ } else {
+ |
+
| 78 | +2x | +
+ paste0(+ |
+
| 79 | +2x | +
+ x["num"], "/", x["denom"],+ |
+
| 80 | +2x | +
+ " (", sprintf("%.1f", round(x["num"] / x["denom"] * 100, 1)), "%)"
+ |
+
| 81 | ++ |
+ )+ |
+
| 82 | ++ |
+ }+ |
+
| 83 | +3x | +
+ return(result)+ |
+
| 84 | ++ |
+ }+ |
+
| 85 | ++ | + + | +
| 86 | ++ |
+ #' Formatting Count and Fraction+ |
+
| 87 | ++ |
+ #'+ |
+
| 88 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 89 | ++ |
+ #'+ |
+
| 90 | ++ |
+ #' Formats a count together with fraction with special consideration when count is `0`.+ |
+
| 91 | ++ |
+ #'+ |
+
| 92 | ++ |
+ #' @param x (`integer`)\cr vector of length 2, count and fraction.+ |
+
| 93 | ++ |
+ #' @param ... required for `rtables` interface.+ |
+
| 94 | ++ |
+ #'+ |
+
| 95 | ++ |
+ #' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`.+ |
+
| 96 | ++ |
+ #'+ |
+
| 97 | ++ |
+ #' @examples+ |
+
| 98 | ++ |
+ #' format_count_fraction(x = c(2, 0.6667))+ |
+
| 99 | ++ |
+ #' format_count_fraction(x = c(0, 0))+ |
+
| 100 | ++ |
+ #'+ |
+
| 101 | ++ |
+ #' @family formatting functions+ |
+
| 102 | ++ |
+ #' @export+ |
+
| 103 | ++ |
+ format_count_fraction <- function(x, ...) {
+ |
+
| 104 | +3x | +
+ attr(x, "label") <- NULL+ |
+
| 105 | ++ | + + | +
| 106 | +3x | +
+ if (any(is.na(x))) {
+ |
+
| 107 | +1x | +
+ return("NA")
+ |
+
| 108 | ++ |
+ }+ |
+
| 109 | ++ | + + | +
| 110 | +2x | +
+ checkmate::assert_vector(x)+ |
+
| 111 | +2x | +
+ checkmate::assert_integerish(x[1])+ |
+
| 112 | +2x | +
+ assert_proportion_value(x[2], include_boundaries = TRUE)+ |
+
| 113 | ++ | + + | +
| 114 | +2x | +
+ result <- if (x[1] == 0) {
+ |
+
| 115 | +1x | +
+ "0"+ |
+
| 116 | ++ |
+ } else {
+ |
+
| 117 | +1x | +
+ paste0(x[1], " (", round(x[2] * 100, 1), "%)")
+ |
+
| 118 | ++ |
+ }+ |
+
| 119 | ++ | + + | +
| 120 | +2x | +
+ return(result)+ |
+
| 121 | ++ |
+ }+ |
+
| 122 | ++ | + + | +
| 123 | ++ |
+ #' Formatting Count and Percentage with Fixed Single Decimal Place+ |
+
| 124 | ++ |
+ #'+ |
+
| 125 | ++ |
+ #' @description `r lifecycle::badge("experimental")`
+ |
+
| 126 | ++ |
+ #'+ |
+
| 127 | ++ |
+ #' Formats a count together with fraction with special consideration when count is `0`.+ |
+
| 128 | ++ |
+ #'+ |
+
| 129 | ++ |
+ #' @param x (`integer`)\cr vector of length 2, count and fraction.+ |
+
| 130 | ++ |
+ #' @param ... required for `rtables` interface.+ |
+
| 131 | ++ |
+ #'+ |
+
| 132 | ++ |
+ #' @return A string in the format `count (fraction %)`. If `count` is 0, the format is `0`.+ |
+
| 133 | ++ |
+ #'+ |
+
| 134 | ++ |
+ #' @examples+ |
+
| 135 | ++ |
+ #' format_count_fraction_fixed_dp(x = c(2, 0.6667))+ |
+
| 136 | ++ |
+ #' format_count_fraction_fixed_dp(x = c(2, 0.5))+ |
+
| 137 | ++ |
+ #' format_count_fraction_fixed_dp(x = c(0, 0))+ |
+
| 138 | ++ |
+ #'+ |
+
| 139 | ++ |
+ #' @family formatting functions+ |
+
| 140 | ++ |
+ #' @export+ |
+
| 141 | ++ |
+ format_count_fraction_fixed_dp <- function(x, ...) {
+ |
+
| 142 | +3x | +
+ attr(x, "label") <- NULL+ |
+
| 143 | ++ | + + | +
| 144 | +3x | +
+ if (any(is.na(x))) {
+ |
+
| 145 | +! | +
+ return("NA")
+ |
+
| 146 | ++ |
+ }+ |
+
| 147 | ++ | + + | +
| 148 | +3x | +
+ checkmate::assert_vector(x)+ |
+
| 149 | +3x | +
+ checkmate::assert_integerish(x[1])+ |
+
| 150 | +3x | +
+ assert_proportion_value(x[2], include_boundaries = TRUE)+ |
+
| 151 | ++ | + + | +
| 152 | +3x | +
+ result <- if (x[1] == 0) {
+ |
+
| 153 | +1x | +
+ "0"+ |
+
| 154 | +3x | +
+ } else if (x[2] == 1) {
+ |
+
| 155 | +! | +
+ sprintf("%d (100%%)", x[1])
+ |
+
| 156 | ++ |
+ } else {
+ |
+
| 157 | +2x | +
+ sprintf("%d (%.1f%%)", x[1], x[2] * 100)
+ |
+
| 158 | ++ |
+ }+ |
+
| 159 | ++ | + + | +
| 160 | +3x | +
+ return(result)+ |
+
| 161 | ++ |
+ }+ |
+
| 162 | ++ | + + | +
| 163 | ++ |
+ #' Formatting Count and Fraction with Special Case for Count < 10+ |
+
| 164 | ++ |
+ #'+ |
+
| 165 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 166 | ++ |
+ #'+ |
+
| 167 | ++ |
+ #' Formats a count together with fraction with special consideration when count is less than 10.+ |
+
| 168 | ++ |
+ #'+ |
+
| 169 | ++ |
+ #' @inheritParams format_count_fraction+ |
+
| 170 | ++ |
+ #'+ |
+
| 171 | ++ |
+ #' @return A string in the format `count (fraction %)`. If `count` is less than 10, only `count` is printed.+ |
+
| 172 | ++ |
+ #'+ |
+
| 173 | ++ |
+ #' @examples+ |
+
| 174 | ++ |
+ #' format_count_fraction_lt10(x = c(275, 0.9673))+ |
+
| 175 | ++ |
+ #' format_count_fraction_lt10(x = c(2, 0.6667))+ |
+
| 176 | ++ |
+ #' format_count_fraction_lt10(x = c(9, 1))+ |
+
| 177 | ++ |
+ #'+ |
+
| 178 | ++ |
+ #' @family formatting functions+ |
+
| 179 | ++ |
+ #' @export+ |
+
| 180 | ++ |
+ format_count_fraction_lt10 <- function(x, ...) {
+ |
+
| 181 | +7x | +
+ attr(x, "label") <- NULL+ |
+
| 182 | ++ | + + | +
| 183 | +7x | +
+ if (any(is.na(x))) {
+ |
+
| 184 | +1x | +
+ return("NA")
+ |
+
| 185 | ++ |
+ }+ |
+
| 186 | ++ | + + | +
| 187 | +6x | +
+ checkmate::assert_vector(x)+ |
+
| 188 | +6x | +
+ checkmate::assert_integerish(x[1])+ |
+
| 189 | +6x | +
+ assert_proportion_value(x[2], include_boundaries = TRUE)+ |
+
| 190 | ++ | + + | +
| 191 | +6x | +
+ result <- if (x[1] < 10) {
+ |
+
| 192 | +3x | +
+ paste0(x[1])+ |
+
| 193 | ++ |
+ } else {
+ |
+
| 194 | +3x | +
+ paste0(x[1], " (", round(x[2] * 100, 1), "%)")
+ |
+
| 195 | ++ |
+ }+ |
+
| 196 | ++ | + + | +
| 197 | +6x | +
+ return(result)+ |
+
| 198 | ++ |
+ }+ |
+
| 199 | ++ | + + | +
| 200 | ++ |
+ #' Formatting: XX as Formatting Function+ |
+
| 201 | ++ |
+ #'+ |
+
| 202 | ++ |
+ #' Translate a string where x and dots are interpreted as number place+ |
+
| 203 | ++ |
+ #' holders, and others as formatting elements.+ |
+
| 204 | ++ |
+ #'+ |
+
| 205 | ++ |
+ #' @param str (`string`)\cr template.+ |
+
| 206 | ++ |
+ #'+ |
+
| 207 | ++ |
+ #' @return An `rtables` formatting function.+ |
+
| 208 | ++ |
+ #'+ |
+
| 209 | ++ |
+ #' @examples+ |
+
| 210 | ++ |
+ #' test <- list(c(1.658, 0.5761), c(1e1, 785.6))+ |
+
| 211 | ++ |
+ #'+ |
+
| 212 | ++ |
+ #' z <- format_xx("xx (xx.x)")
+ |
+
| 213 | ++ |
+ #' sapply(test, z)+ |
+
| 214 | ++ |
+ #'+ |
+
| 215 | ++ |
+ #' z <- format_xx("xx.x - xx.x")
+ |
+
| 216 | ++ |
+ #' sapply(test, z)+ |
+
| 217 | ++ |
+ #'+ |
+
| 218 | ++ |
+ #' z <- format_xx("xx.x, incl. xx.x% NE")
+ |
+
| 219 | ++ |
+ #' sapply(test, z)+ |
+
| 220 | ++ |
+ #'+ |
+
| 221 | ++ |
+ #' @family formatting functions+ |
+
| 222 | ++ |
+ #' @export+ |
+
| 223 | ++ |
+ format_xx <- function(str) {
+ |
+
| 224 | ++ |
+ # Find position in the string.+ |
+
| 225 | +1x | +
+ positions <- gregexpr(pattern = "x+\\.x+|x+", text = str, perl = TRUE)+ |
+
| 226 | +1x | +
+ x_positions <- regmatches(x = str, m = positions)[[1]]+ |
+
| 227 | ++ | + + | +
| 228 | ++ |
+ # Roundings depends on the number of x behind [.].+ |
+
| 229 | +1x | +
+ roundings <- lapply(+ |
+
| 230 | +1x | +
+ X = x_positions,+ |
+
| 231 | +1x | +
+ function(x) {
+ |
+
| 232 | +2x | +
+ y <- strsplit(split = "\\.", x = x)[[1]]+ |
+
| 233 | +2x | +
+ rounding <- function(x) {
+ |
+
| 234 | +4x | +
+ round(x, digits = ifelse(length(y) > 1, nchar(y[2]), 0))+ |
+
| 235 | ++ |
+ }+ |
+
| 236 | +2x | +
+ return(rounding)+ |
+
| 237 | ++ |
+ }+ |
+
| 238 | ++ |
+ )+ |
+
| 239 | ++ | + + | +
| 240 | +1x | +
+ rtable_format <- function(x, output) {
+ |
+
| 241 | +2x | +
+ values <- Map(y = x, fun = roundings, function(y, fun) fun(y))+ |
+
| 242 | +2x | +
+ regmatches(x = str, m = positions)[[1]] <- values+ |
+
| 243 | +2x | +
+ return(str)+ |
+
| 244 | ++ |
+ }+ |
+
| 245 | ++ | + + | +
| 246 | +1x | +
+ return(rtable_format)+ |
+
| 247 | ++ |
+ }+ |
+
| 248 | ++ | + + | +
| 249 | ++ |
+ #' Formatting Numeric Values By Significant Figures+ |
+
| 250 | ++ |
+ #'+ |
+
| 251 | ++ |
+ #' Format numeric values to print with a specified number of significant figures.+ |
+
| 252 | ++ |
+ #'+ |
+
| 253 | ++ |
+ #' @param sigfig (`integer`)\cr number of significant figures to display.+ |
+
| 254 | ++ |
+ #' @param format (`character`)\cr the format label (string) to apply when printing the value. Decimal+ |
+
| 255 | ++ |
+ #' places in string are ignored in favor of formatting by significant figures. Formats options are:+ |
+
| 256 | ++ |
+ #' `"xx"`, `"xx / xx"`, `"(xx, xx)"`, `"xx - xx"`, and `"xx (xx)"`.+ |
+
| 257 | ++ |
+ #' @param num_fmt (`character`)\cr numeric format modifiers to apply to the value. Defaults to `"fg"` for+ |
+
| 258 | ++ |
+ #' standard significant figures formatting - fixed (non-scientific notation) format (`"f"`)+ |
+
| 259 | ++ |
+ #' and `sigfig` equal to number of significant figures instead of decimal places (`"g"`). See the+ |
+
| 260 | ++ |
+ #' [formatC()] `format` argument for more options.+ |
+
| 261 | ++ |
+ #'+ |
+
| 262 | ++ |
+ #' @return An `rtables` formatting function.+ |
+
| 263 | ++ |
+ #'+ |
+
| 264 | ++ |
+ #' @examples+ |
+
| 265 | ++ |
+ #' fmt_3sf <- format_sigfig(3)+ |
+
| 266 | ++ |
+ #' fmt_3sf(1.658)+ |
+
| 267 | ++ |
+ #' fmt_3sf(1e1)+ |
+
| 268 | ++ |
+ #'+ |
+
| 269 | ++ |
+ #' fmt_5sf <- format_sigfig(5)+ |
+
| 270 | ++ |
+ #' fmt_5sf(0.57)+ |
+
| 271 | ++ |
+ #' fmt_5sf(0.000025645)+ |
+
| 272 | ++ |
+ #'+ |
+
| 273 | ++ |
+ #' @family formatting functions+ |
+
| 274 | ++ |
+ #' @export+ |
+
| 275 | ++ |
+ format_sigfig <- function(sigfig, format = "xx", num_fmt = "fg") {
+ |
+
| 276 | +2x | +
+ checkmate::assert_integerish(sigfig)+ |
+
| 277 | +2x | +
+ format <- gsub("xx\\.|xx\\.x+", "xx", format)
+ |
+
| 278 | +2x | +
+ checkmate::assert_choice(format, c("xx", "xx / xx", "(xx, xx)", "xx - xx", "xx (xx)"))
+ |
+
| 279 | +2x | +
+ function(x, ...) {
+ |
+
| 280 | +! | +
+ if (!is.numeric(x)) stop("`format_sigfig` cannot be used for non-numeric values. Please choose another format.")
+ |
+
| 281 | +9x | +
+ num <- formatC(signif(x, digits = sigfig), digits = sigfig, format = num_fmt, flag = "#")+ |
+
| 282 | +9x | +
+ num <- gsub("\\.$", "", num) # remove trailing "."
+ |
+
| 283 | ++ | + + | +
| 284 | +9x | +
+ format_value(num, format)+ |
+
| 285 | ++ |
+ }+ |
+
| 286 | ++ |
+ }+ |
+
| 287 | ++ | + + | +
| 288 | ++ |
+ #' Formatting Fraction with Lower Threshold+ |
+
| 289 | ++ |
+ #'+ |
+
| 290 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 291 | ++ |
+ #'+ |
+
| 292 | ++ |
+ #' Formats a fraction when the second element of the input `x` is the fraction. It applies+ |
+
| 293 | ++ |
+ #' a lower threshold, below which it is just stated that the fraction is smaller than that.+ |
+
| 294 | ++ |
+ #'+ |
+
| 295 | ++ |
+ #' @param threshold (`proportion`)\cr lower threshold.+ |
+
| 296 | ++ |
+ #'+ |
+
| 297 | ++ |
+ #' @return An `rtables` formatting function that takes numeric input `x` where the second+ |
+
| 298 | ++ |
+ #' element is the fraction that is formatted. If the fraction is above or equal to the threshold,+ |
+
| 299 | ++ |
+ #' then it is displayed in percentage. If it is positive but below the threshold, it returns,+ |
+
| 300 | ++ |
+ #' e.g. "<1" if the threshold is `0.01`. If it is zero, then just "0" is returned.+ |
+
| 301 | ++ |
+ #'+ |
+
| 302 | ++ |
+ #' @examples+ |
+
| 303 | ++ |
+ #' format_fun <- format_fraction_threshold(0.05)+ |
+
| 304 | ++ |
+ #' format_fun(x = c(20, 0.1))+ |
+
| 305 | ++ |
+ #' format_fun(x = c(2, 0.01))+ |
+
| 306 | ++ |
+ #' format_fun(x = c(0, 0))+ |
+
| 307 | ++ |
+ #'+ |
+
| 308 | ++ |
+ #' @family formatting functions+ |
+
| 309 | ++ |
+ #' @export+ |
+
| 310 | ++ |
+ format_fraction_threshold <- function(threshold) {
+ |
+
| 311 | +1x | +
+ assert_proportion_value(threshold)+ |
+
| 312 | +1x | +
+ string_below_threshold <- paste0("<", round(threshold * 100))
+ |
+
| 313 | +1x | +
+ function(x, ...) {
+ |
+
| 314 | +3x | +
+ assert_proportion_value(x[2], include_boundaries = TRUE)+ |
+
| 315 | +3x | +
+ ifelse(+ |
+
| 316 | +3x | +
+ x[2] > 0.01,+ |
+
| 317 | +3x | +
+ round(x[2] * 100),+ |
+
| 318 | +3x | +
+ ifelse(+ |
+
| 319 | +3x | +
+ x[2] == 0,+ |
+
| 320 | +3x | +
+ "0",+ |
+
| 321 | +3x | +
+ string_below_threshold+ |
+
| 322 | ++ |
+ )+ |
+
| 323 | ++ |
+ )+ |
+
| 324 | ++ |
+ }+ |
+
| 325 | ++ |
+ }+ |
+
| 326 | ++ | + + | +
| 327 | ++ |
+ #' Formatting Extreme Values+ |
+
| 328 | ++ |
+ #'+ |
+
| 329 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 330 | ++ |
+ #'+ |
+
| 331 | ++ |
+ #' `rtables` formatting functions that handle extreme values.+ |
+
| 332 | ++ |
+ #'+ |
+
| 333 | ++ |
+ #' @param digits (`integer`)\cr number of decimal places to display.+ |
+
| 334 | ++ |
+ #'+ |
+
| 335 | ++ |
+ #' @details For each input, apply a format to the specified number of `digits`. If the value is+ |
+
| 336 | ++ |
+ #' below a threshold, it returns "<0.01" e.g. if the number of `digits` is 2. If the value is+ |
+
| 337 | ++ |
+ #' above a threshold, it returns ">999.99" e.g. if the number of `digits` is 2.+ |
+
| 338 | ++ |
+ #' If it is zero, then returns "0.00".+ |
+
| 339 | ++ |
+ #'+ |
+
| 340 | ++ |
+ #' @family formatting functions+ |
+
| 341 | ++ |
+ #' @name extreme_format+ |
+
| 342 | ++ |
+ NULL+ |
+
| 343 | ++ | + + | +
| 344 | ++ |
+ #' @describeIn extreme_format Internal helper function to calculate the threshold and create formatted strings+ |
+
| 345 | ++ |
+ #' used in Formatting Functions. Returns a list with elements `threshold` and `format_string`.+ |
+
| 346 | ++ |
+ #'+ |
+
| 347 | ++ |
+ #' @return+ |
+
| 348 | ++ |
+ #' * `h_get_format_threshold()` returns a `list` of 2 elements: `threshold`, with `low` and `high` thresholds,+ |
+
| 349 | ++ |
+ #' and `format_string`, with thresholds formatted as strings.+ |
+
| 350 | ++ |
+ #'+ |
+
| 351 | ++ |
+ #' @examples+ |
+
| 352 | ++ |
+ #' h_get_format_threshold(2L)+ |
+
| 353 | ++ |
+ #'+ |
+
| 354 | ++ |
+ #' @export+ |
+
| 355 | ++ |
+ h_get_format_threshold <- function(digits = 2L) {
+ |
+
| 356 | +1022x | +
+ checkmate::assert_integerish(digits)+ |
+
| 357 | ++ | + + | +
| 358 | +1022x | +
+ low_threshold <- 1 / (10 ^ digits) # styler: off+ |
+
| 359 | +1022x | +
+ high_threshold <- 1000 - (1 / (10 ^ digits)) # styler: off+ |
+
| 360 | ++ | + + | +
| 361 | +1022x | +
+ string_below_threshold <- paste0("<", low_threshold)
+ |
+
| 362 | +1022x | +
+ string_above_threshold <- paste0(">", high_threshold)
+ |
+
| 363 | ++ | + + | +
| 364 | +1022x | +
+ list(+ |
+
| 365 | +1022x | +
+ "threshold" = c(low = low_threshold, high = high_threshold),+ |
+
| 366 | +1022x | +
+ "format_string" = c(low = string_below_threshold, high = string_above_threshold)+ |
+
| 367 | ++ |
+ )+ |
+
| 368 | ++ |
+ }+ |
+
| 369 | ++ | + + | +
| 370 | ++ |
+ #' @describeIn extreme_format Internal helper function to apply a threshold format to a value.+ |
+
| 371 | ++ |
+ #' Creates a formatted string to be used in Formatting Functions.+ |
+
| 372 | ++ |
+ #'+ |
+
| 373 | ++ |
+ #' @param x (`number`)\cr value to format.+ |
+
| 374 | ++ |
+ #'+ |
+
| 375 | ++ |
+ #' @return+ |
+
| 376 | ++ |
+ #' * `h_format_threshold()` returns the given value, or if the value is not within the digit threshold the relation+ |
+
| 377 | ++ |
+ #' of the given value to the digit threshold, as a formatted string.+ |
+
| 378 | ++ |
+ #'+ |
+
| 379 | ++ |
+ #' @examples+ |
+
| 380 | ++ |
+ #' h_format_threshold(0.001)+ |
+
| 381 | ++ |
+ #' h_format_threshold(1000)+ |
+
| 382 | ++ |
+ #'+ |
+
| 383 | ++ |
+ #' @export+ |
+
| 384 | ++ |
+ h_format_threshold <- function(x, digits = 2L) {
+ |
+
| 385 | +1025x | +
+ if (is.na(x)) {
+ |
+
| 386 | +4x | +
+ return(x)+ |
+
| 387 | ++ |
+ }+ |
+
| 388 | ++ | + + | +
| 389 | +1021x | +
+ checkmate::assert_numeric(x, lower = 0)+ |
+
| 390 | ++ | + + | +
| 391 | +1021x | +
+ l_fmt <- h_get_format_threshold(digits)+ |
+
| 392 | ++ | + + | +
| 393 | +1021x | +
+ result <- if (x < l_fmt$threshold["low"] && 0 < x) {
+ |
+
| 394 | +25x | +
+ l_fmt$format_string["low"]+ |
+
| 395 | +1021x | +
+ } else if (x > l_fmt$threshold["high"]) {
+ |
+
| 396 | +72x | +
+ l_fmt$format_string["high"]+ |
+
| 397 | ++ |
+ } else {
+ |
+
| 398 | +924x | +
+ sprintf(fmt = paste0("%.", digits, "f"), x)
+ |
+
| 399 | ++ |
+ }+ |
+
| 400 | ++ | + + | +
| 401 | +1021x | +
+ unname(result)+ |
+
| 402 | ++ |
+ }+ |
+
| 403 | ++ | + + | +
| 404 | ++ |
+ #' Formatting a Single Extreme Value+ |
+
| 405 | ++ |
+ #'+ |
+
| 406 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 407 | ++ |
+ #'+ |
+
| 408 | ++ |
+ #' Create Formatting Function for a single extreme value.+ |
+
| 409 | ++ |
+ #'+ |
+
| 410 | ++ |
+ #' @inheritParams extreme_format+ |
+
| 411 | ++ |
+ #'+ |
+
| 412 | ++ |
+ #' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme value.+ |
+
| 413 | ++ |
+ #'+ |
+
| 414 | ++ |
+ #' @examples+ |
+
| 415 | ++ |
+ #' format_fun <- format_extreme_values(2L)+ |
+
| 416 | ++ |
+ #' format_fun(x = 0.127)+ |
+
| 417 | ++ |
+ #' format_fun(x = Inf)+ |
+
| 418 | ++ |
+ #' format_fun(x = 0)+ |
+
| 419 | ++ |
+ #' format_fun(x = 0.009)+ |
+
| 420 | ++ |
+ #'+ |
+
| 421 | ++ |
+ #' @family formatting functions+ |
+
| 422 | ++ |
+ #' @export+ |
+
| 423 | ++ |
+ format_extreme_values <- function(digits = 2L) {
+ |
+
| 424 | +24x | +
+ function(x, ...) {
+ |
+
| 425 | +307x | +
+ checkmate::assert_scalar(x, na.ok = TRUE)+ |
+
| 426 | ++ | + + | +
| 427 | +307x | +
+ h_format_threshold(x = x, digits = digits)+ |
+
| 428 | ++ |
+ }+ |
+
| 429 | ++ |
+ }+ |
+
| 430 | ++ | + + | +
| 431 | ++ |
+ #' Formatting Extreme Values Part of a Confidence Interval+ |
+
| 432 | ++ |
+ #'+ |
+
| 433 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 434 | ++ |
+ #'+ |
+
| 435 | ++ |
+ #' Formatting Function for extreme values part of a confidence interval. Values+ |
+
| 436 | ++ |
+ #' are formatted as e.g. "(xx.xx, xx.xx)" if the number of `digits` is 2.+ |
+
| 437 | ++ |
+ #'+ |
+
| 438 | ++ |
+ #' @inheritParams extreme_format+ |
+
| 439 | ++ |
+ #'+ |
+
| 440 | ++ |
+ #' @return An `rtables` formatting function that uses threshold `digits` to return a formatted extreme+ |
+
| 441 | ++ |
+ #' values confidence interval.+ |
+
| 442 | ++ |
+ #'+ |
+
| 443 | ++ |
+ #' @examples+ |
+
| 444 | ++ |
+ #' format_fun <- format_extreme_values_ci(2L)+ |
+
| 445 | ++ |
+ #' format_fun(x = c(0.127, Inf))+ |
+
| 446 | ++ |
+ #' format_fun(x = c(0, 0.009))+ |
+
| 447 | ++ |
+ #'+ |
+
| 448 | ++ |
+ #' @family formatting functions+ |
+
| 449 | ++ |
+ #' @export+ |
+
| 450 | ++ |
+ format_extreme_values_ci <- function(digits = 2L) {
+ |
+
| 451 | +32x | +
+ function(x, ...) {
+ |
+
| 452 | +356x | +
+ checkmate::assert_vector(x, len = 2)+ |
+
| 453 | +356x | +
+ l_result <- h_format_threshold(x = x[1], digits = digits)+ |
+
| 454 | +356x | +
+ h_result <- h_format_threshold(x = x[2], digits = digits)+ |
+
| 455 | ++ | + + | +
| 456 | +356x | +
+ paste0("(", l_result, ", ", h_result, ")")
+ |
+
| 457 | ++ |
+ }+ |
+
| 458 | ++ |
+ }+ |
+
| 459 | ++ | + + | +
| 460 | ++ |
+ #' Automatic formats from data significant digits+ |
+
| 461 | ++ |
+ #'+ |
+
| 462 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 463 | ++ |
+ #'+ |
+
| 464 | ++ |
+ #' Formatting function for the majority of default methods used in [analyze_vars()].+ |
+
| 465 | ++ |
+ #' For non-derived values, the significant digits of data is used (e.g. range), while derived+ |
+
| 466 | ++ |
+ #' values have one more digits (measure of location and dispersion like mean, standard deviation).+ |
+
| 467 | ++ |
+ #' This function can be called internally with "auto" like, for example,+ |
+
| 468 | ++ |
+ #' `.formats = c("mean" = "auto")`. See details to see how this works with the inner function.
+ |
+
| 469 | ++ |
+ #'+ |
+
| 470 | ++ |
+ #' @param dt_var (`numeric`) \cr all the data the statistics was created upon. Used only to find+ |
+
| 471 | ++ |
+ #' significant digits. In [analyze_vars] this comes from `.df_row` (see+ |
+
| 472 | ++ |
+ #' [rtables::additional_fun_params]), and it is the row data after the above row splits. No+ |
+
| 473 | ++ |
+ #' column split is considered.+ |
+
| 474 | ++ |
+ #' @param x_stat (`string`) \cr string indicating the current statistical method used.+ |
+
| 475 | ++ |
+ #'+ |
+
| 476 | ++ |
+ #' @return A string that `rtables` prints in a table cell.+ |
+
| 477 | ++ |
+ #'+ |
+
| 478 | ++ |
+ #' @details+ |
+
| 479 | ++ |
+ #' The internal function is needed to work with `rtables` default structure for+ |
+
| 480 | ++ |
+ #' format functions, i.e. `function(x, ...)`, where is x are results from statistical evaluation.+ |
+
| 481 | ++ |
+ #' It can be more than one element (e.g. for `.stats = "mean_sd"`).+ |
+
| 482 | ++ |
+ #'+ |
+
| 483 | ++ |
+ #' @examples+ |
+
| 484 | ++ |
+ #' x_todo <- c(0.001, 0.2, 0.0011000, 3, 4)+ |
+
| 485 | ++ |
+ #' res <- c(mean(x_todo[1:3]), sd(x_todo[1:3]))+ |
+
| 486 | ++ |
+ #'+ |
+
| 487 | ++ |
+ #' # x is the result coming into the formatting function -> res!!+ |
+
| 488 | ++ |
+ #' format_auto(dt_var = x_todo, x_stat = "mean_sd")(x = res)+ |
+
| 489 | ++ |
+ #' format_auto(x_todo, "range")(x = range(x_todo))+ |
+
| 490 | ++ |
+ #' no_sc_x <- c(0.0000001, 1)+ |
+
| 491 | ++ |
+ #' format_auto(no_sc_x, "range")(x = no_sc_x)+ |
+
| 492 | ++ |
+ #'+ |
+
| 493 | ++ |
+ #' @family formatting functions+ |
+
| 494 | ++ |
+ #' @export+ |
+
| 495 | ++ |
+ format_auto <- function(dt_var, x_stat) {
+ |
+
| 496 | +7x | +
+ function(x = "", ...) {
+ |
+
| 497 | +11x | +
+ checkmate::assert_numeric(x, min.len = 1)+ |
+
| 498 | +11x | +
+ checkmate::assert_numeric(dt_var, min.len = 1)+ |
+
| 499 | ++ |
+ # Defaults - they may be a param in the future+ |
+
| 500 | +11x | +
+ der_stats <- c(+ |
+
| 501 | +11x | +
+ "mean", "sd", "se", "median", "geom_mean", "quantiles", "iqr",+ |
+
| 502 | +11x | +
+ "mean_sd", "mean_se", "mean_se", "mean_ci", "mean_sei", "mean_sdi"+ |
+
| 503 | ++ |
+ )+ |
+
| 504 | +11x | +
+ nonder_stats <- c("n", "range", "min", "max")
+ |
+
| 505 | ++ | + + | +
| 506 | ++ |
+ # Safenet for miss-modifications+ |
+
| 507 | +11x | +
+ stopifnot(length(intersect(der_stats, nonder_stats)) == 0) # nolint+ |
+
| 508 | +11x | +
+ checkmate::assert_choice(x_stat, c(der_stats, nonder_stats))+ |
+
| 509 | ++ | + + | +
| 510 | ++ |
+ # Finds the max number of digits in data+ |
+
| 511 | +11x | +
+ detect_dig <- vapply(dt_var, count_decimalplaces, FUN.VALUE = numeric(1)) %>%+ |
+
| 512 | +11x | +
+ max()+ |
+
| 513 | ++ | + + | +
| 514 | +11x | +
+ if (x_stat %in% der_stats) {
+ |
+
| 515 | +4x | +
+ detect_dig <- detect_dig + 1+ |
+
| 516 | ++ |
+ }+ |
+
| 517 | ++ | + + | +
| 518 | ++ |
+ # Render input+ |
+
| 519 | +11x | +
+ str_vals <- formatC(x, digits = detect_dig, format = "f")+ |
+
| 520 | +11x | +
+ def_fmt <- get_formats_from_stats(x_stat)[[x_stat]]+ |
+
| 521 | +11x | +
+ str_fmt <- str_extract(def_fmt, invert = FALSE)[[1]]+ |
+
| 522 | +11x | +
+ if (length(str_fmt) != length(str_vals)) {
+ |
+
| 523 | +2x | +
+ stop(+ |
+
| 524 | +2x | +
+ "Number of inserted values as result (", length(str_vals),
+ |
+
| 525 | +2x | +
+ ") is not the same as there should be in the default tern formats for ",+ |
+
| 526 | +2x | +
+ x_stat, " (-> ", def_fmt, " needs ", length(str_fmt), " values). ",+ |
+
| 527 | +2x | +
+ "See tern_default_formats to check all of them."+ |
+
| 528 | ++ |
+ )+ |
+
| 529 | ++ |
+ }+ |
+
| 530 | ++ | + + | +
| 531 | ++ |
+ # Squashing them together+ |
+
| 532 | +9x | +
+ inv_str_fmt <- str_extract(def_fmt, invert = TRUE)[[1]]+ |
+
| 533 | +9x | +
+ stopifnot(length(inv_str_fmt) == length(str_vals) + 1) # nolint+ |
+
| 534 | ++ | + + | +
| 535 | +9x | +
+ out <- vector("character", length = length(inv_str_fmt) + length(str_vals))
+ |
+
| 536 | +9x | +
+ is_even <- seq_along(out) %% 2 == 0+ |
+
| 537 | +9x | +
+ out[is_even] <- str_vals+ |
+
| 538 | +9x | +
+ out[!is_even] <- inv_str_fmt+ |
+
| 539 | ++ | + + | +
| 540 | +9x | +
+ return(paste0(out, collapse = ""))+ |
+
| 541 | ++ |
+ }+ |
+
| 542 | ++ |
+ }+ |
+
| 543 | ++ | + + | +
| 544 | ++ |
+ # Utility function that could be useful in general+ |
+
| 545 | ++ |
+ str_extract <- function(string, pattern = "xx|xx\\.|xx\\.x+", invert = FALSE) {
+ |
+
| 546 | +20x | +
+ regmatches(string, gregexpr(pattern, string), invert = invert)+ |
+
| 547 | ++ |
+ }+ |
+
| 548 | ++ | + + | +
| 549 | ++ |
+ # Helper function+ |
+
| 550 | ++ |
+ count_decimalplaces <- function(dec) {
+ |
+
| 551 | +52x | +
+ if (abs(dec - round(dec)) > .Machine$double.eps^0.5) { # For precision
+ |
+
| 552 | +31x | +
+ nchar(strsplit(format(dec, scientific = FALSE, trim = FALSE), ".", fixed = TRUE)[[1]][[2]])+ |
+
| 553 | ++ |
+ } else {
+ |
+
| 554 | +21x | +
+ return(0)+ |
+
| 555 | ++ |
+ }+ |
+
| 556 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Stack Multiple Grobs+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Stack grobs as a new grob with 1 column and multiple rows layout.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param ... grobs.+ |
+
| 8 | ++ |
+ #' @param grobs list of grobs.+ |
+
| 9 | ++ |
+ #' @param padding unit of length 1, space between each grob.+ |
+
| 10 | ++ |
+ #' @param vp a [viewport()] object (or `NULL`).+ |
+
| 11 | ++ |
+ #' @param name a character identifier for the grob.+ |
+
| 12 | ++ |
+ #' @param gp A [gpar()] object.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @return A `grob`.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @examples+ |
+
| 17 | ++ |
+ #' library(grid)+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' g1 <- circleGrob(gp = gpar(col = "blue"))+ |
+
| 20 | ++ |
+ #' g2 <- circleGrob(gp = gpar(col = "red"))+ |
+
| 21 | ++ |
+ #' g3 <- textGrob("TEST TEXT")
+ |
+
| 22 | ++ |
+ #' grid.newpage()+ |
+
| 23 | ++ |
+ #' grid.draw(stack_grobs(g1, g2, g3))+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' showViewport()+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' grid.newpage()+ |
+
| 28 | ++ |
+ #' pushViewport(viewport(layout = grid.layout(1, 2)))+ |
+
| 29 | ++ |
+ #' vp1 <- viewport(layout.pos.row = 1, layout.pos.col = 2)+ |
+
| 30 | ++ |
+ #' grid.draw(stack_grobs(g1, g2, g3, vp = vp1, name = "test"))+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' showViewport()+ |
+
| 33 | ++ |
+ #' grid.ls(grobs = TRUE, viewports = TRUE, print = FALSE)+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' @export+ |
+
| 36 | ++ |
+ stack_grobs <- function(...,+ |
+
| 37 | ++ |
+ grobs = list(...),+ |
+
| 38 | ++ |
+ padding = grid::unit(2, "line"),+ |
+
| 39 | ++ |
+ vp = NULL,+ |
+
| 40 | ++ |
+ gp = NULL,+ |
+
| 41 | ++ |
+ name = NULL) {
+ |
+
| 42 | +4x | +
+ checkmate::assert_true(+ |
+
| 43 | +4x | +
+ all(vapply(grobs, grid::is.grob, logical(1)))+ |
+
| 44 | ++ |
+ )+ |
+
| 45 | ++ | + + | +
| 46 | +4x | +
+ if (length(grobs) == 1) {
+ |
+
| 47 | +1x | +
+ return(grobs[[1]])+ |
+
| 48 | ++ |
+ }+ |
+
| 49 | ++ | + + | +
| 50 | +3x | +
+ n_layout <- 2 * length(grobs) - 1+ |
+
| 51 | +3x | +
+ hts <- lapply(+ |
+
| 52 | +3x | +
+ seq(1, n_layout),+ |
+
| 53 | +3x | +
+ function(i) {
+ |
+
| 54 | +39x | +
+ if (i %% 2 != 0) {
+ |
+
| 55 | +21x | +
+ grid::unit(1, "null")+ |
+
| 56 | ++ |
+ } else {
+ |
+
| 57 | +18x | +
+ padding+ |
+
| 58 | ++ |
+ }+ |
+
| 59 | ++ |
+ }+ |
+
| 60 | ++ |
+ )+ |
+
| 61 | +3x | +
+ hts <- do.call(grid::unit.c, hts)+ |
+
| 62 | ++ | + + | +
| 63 | +3x | +
+ main_vp <- grid::viewport(+ |
+
| 64 | +3x | +
+ layout = grid::grid.layout(nrow = n_layout, ncol = 1, heights = hts)+ |
+
| 65 | ++ |
+ )+ |
+
| 66 | ++ | + + | +
| 67 | +3x | +
+ nested_grobs <- Map(function(g, i) {
+ |
+
| 68 | +21x | +
+ grid::gTree(+ |
+
| 69 | +21x | +
+ children = grid::gList(g),+ |
+
| 70 | +21x | +
+ vp = grid::viewport(layout.pos.row = i, layout.pos.col = 1)+ |
+
| 71 | ++ |
+ )+ |
+
| 72 | +3x | +
+ }, grobs, seq_along(grobs) * 2 - 1)+ |
+
| 73 | ++ | + + | +
| 74 | +3x | +
+ grobs_mainvp <- grid::gTree(+ |
+
| 75 | +3x | +
+ children = do.call(grid::gList, nested_grobs),+ |
+
| 76 | +3x | +
+ vp = main_vp+ |
+
| 77 | ++ |
+ )+ |
+
| 78 | ++ | + + | +
| 79 | +3x | +
+ grid::gTree(+ |
+
| 80 | +3x | +
+ children = grid::gList(grobs_mainvp),+ |
+
| 81 | +3x | +
+ vp = vp,+ |
+
| 82 | +3x | +
+ gp = gp,+ |
+
| 83 | +3x | +
+ name = name+ |
+
| 84 | ++ |
+ )+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | ++ | + + | +
| 87 | ++ |
+ #' Arrange Multiple Grobs+ |
+
| 88 | ++ |
+ #'+ |
+
| 89 | ++ |
+ #' Arrange grobs as a new grob with \verb{n*m (rows*cols)} layout.
+ |
+
| 90 | ++ |
+ #'+ |
+
| 91 | ++ |
+ #' @inheritParams stack_grobs+ |
+
| 92 | ++ |
+ #' @param ncol number of columns in layout.+ |
+
| 93 | ++ |
+ #' @param nrow number of rows in layout.+ |
+
| 94 | ++ |
+ #' @param padding_ht unit of length 1, vertical space between each grob.+ |
+
| 95 | ++ |
+ #' @param padding_wt unit of length 1, horizontal space between each grob.+ |
+
| 96 | ++ |
+ #'+ |
+
| 97 | ++ |
+ #' @return A `grob`.+ |
+
| 98 | ++ |
+ #' @examples+ |
+
| 99 | ++ |
+ #' library(grid)+ |
+
| 100 | ++ |
+ #'+ |
+
| 101 | ++ |
+ #' \donttest{
+ |
+
| 102 | ++ |
+ #' num <- lapply(1:9, textGrob)+ |
+
| 103 | ++ |
+ #' grid::grid.newpage()+ |
+
| 104 | ++ |
+ #' grid.draw(arrange_grobs(grobs = num, ncol = 2))+ |
+
| 105 | ++ |
+ #'+ |
+
| 106 | ++ |
+ #' showViewport()+ |
+
| 107 | ++ |
+ #'+ |
+
| 108 | ++ |
+ #' g1 <- circleGrob(gp = gpar(col = "blue"))+ |
+
| 109 | ++ |
+ #' g2 <- circleGrob(gp = gpar(col = "red"))+ |
+
| 110 | ++ |
+ #' g3 <- textGrob("TEST TEXT")
+ |
+
| 111 | ++ |
+ #' grid::grid.newpage()+ |
+
| 112 | ++ |
+ #' grid.draw(arrange_grobs(g1, g2, g3, nrow = 2))+ |
+
| 113 | ++ |
+ #'+ |
+
| 114 | ++ |
+ #' showViewport()+ |
+
| 115 | ++ |
+ #'+ |
+
| 116 | ++ |
+ #' grid::grid.newpage()+ |
+
| 117 | ++ |
+ #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 3))+ |
+
| 118 | ++ |
+ #'+ |
+
| 119 | ++ |
+ #' grid::grid.newpage()+ |
+
| 120 | ++ |
+ #' grid::pushViewport(grid::viewport(layout = grid::grid.layout(1, 2)))+ |
+
| 121 | ++ |
+ #' vp1 <- grid::viewport(layout.pos.row = 1, layout.pos.col = 2)+ |
+
| 122 | ++ |
+ #' grid.draw(arrange_grobs(g1, g2, g3, ncol = 2, vp = vp1))+ |
+
| 123 | ++ |
+ #'+ |
+
| 124 | ++ |
+ #' showViewport()+ |
+
| 125 | ++ |
+ #' }+ |
+
| 126 | ++ |
+ #' @export+ |
+
| 127 | ++ |
+ arrange_grobs <- function(...,+ |
+
| 128 | ++ |
+ grobs = list(...),+ |
+
| 129 | ++ |
+ ncol = NULL, nrow = NULL,+ |
+
| 130 | ++ |
+ padding_ht = grid::unit(2, "line"),+ |
+
| 131 | ++ |
+ padding_wt = grid::unit(2, "line"),+ |
+
| 132 | ++ |
+ vp = NULL,+ |
+
| 133 | ++ |
+ gp = NULL,+ |
+
| 134 | ++ |
+ name = NULL) {
+ |
+
| 135 | +5x | +
+ checkmate::assert_true(+ |
+
| 136 | +5x | +
+ all(vapply(grobs, grid::is.grob, logical(1)))+ |
+
| 137 | ++ |
+ )+ |
+
| 138 | ++ | + + | +
| 139 | +5x | +
+ if (length(grobs) == 1) {
+ |
+
| 140 | +1x | +
+ return(grobs[[1]])+ |
+
| 141 | ++ |
+ }+ |
+
| 142 | ++ | + + | +
| 143 | +4x | +
+ if (is.null(ncol) && is.null(nrow)) {
+ |
+
| 144 | +1x | +
+ ncol <- 1+ |
+
| 145 | +1x | +
+ nrow <- ceiling(length(grobs) / ncol)+ |
+
| 146 | +3x | +
+ } else if (!is.null(ncol) && is.null(nrow)) {
+ |
+
| 147 | +1x | +
+ nrow <- ceiling(length(grobs) / ncol)+ |
+
| 148 | +2x | +
+ } else if (is.null(ncol) && !is.null(nrow)) {
+ |
+
| 149 | +! | +
+ ncol <- ceiling(length(grobs) / nrow)+ |
+
| 150 | ++ |
+ }+ |
+
| 151 | ++ | + + | +
| 152 | +4x | +
+ if (ncol * nrow < length(grobs)) {
+ |
+
| 153 | +1x | +
+ stop("specififed ncol and nrow are not enough for arranging the grobs ")
+ |
+
| 154 | ++ |
+ }+ |
+
| 155 | ++ | + + | +
| 156 | +3x | +
+ if (ncol == 1) {
+ |
+
| 157 | +2x | +
+ return(stack_grobs(grobs = grobs, padding = padding_ht, vp = vp, gp = gp, name = name))+ |
+
| 158 | ++ |
+ }+ |
+
| 159 | ++ | + + | +
| 160 | +1x | +
+ n_col <- 2 * ncol - 1+ |
+
| 161 | +1x | +
+ n_row <- 2 * nrow - 1+ |
+
| 162 | +1x | +
+ hts <- lapply(+ |
+
| 163 | +1x | +
+ seq(1, n_row),+ |
+
| 164 | +1x | +
+ function(i) {
+ |
+
| 165 | +5x | +
+ if (i %% 2 != 0) {
+ |
+
| 166 | +3x | +
+ grid::unit(1, "null")+ |
+
| 167 | ++ |
+ } else {
+ |
+
| 168 | +2x | +
+ padding_ht+ |
+
| 169 | ++ |
+ }+ |
+
| 170 | ++ |
+ }+ |
+
| 171 | ++ |
+ )+ |
+
| 172 | +1x | +
+ hts <- do.call(grid::unit.c, hts)+ |
+
| 173 | ++ | + + | +
| 174 | +1x | +
+ wts <- lapply(+ |
+
| 175 | +1x | +
+ seq(1, n_col),+ |
+
| 176 | +1x | +
+ function(i) {
+ |
+
| 177 | +5x | +
+ if (i %% 2 != 0) {
+ |
+
| 178 | +3x | +
+ grid::unit(1, "null")+ |
+
| 179 | ++ |
+ } else {
+ |
+
| 180 | +2x | +
+ padding_wt+ |
+
| 181 | ++ |
+ }+ |
+
| 182 | ++ |
+ }+ |
+
| 183 | ++ |
+ )+ |
+
| 184 | +1x | +
+ wts <- do.call(grid::unit.c, wts)+ |
+
| 185 | ++ | + + | +
| 186 | +1x | +
+ main_vp <- grid::viewport(+ |
+
| 187 | +1x | +
+ layout = grid::grid.layout(nrow = n_row, ncol = n_col, widths = wts, heights = hts)+ |
+
| 188 | ++ |
+ )+ |
+
| 189 | ++ | + + | +
| 190 | +1x | +
+ nested_grobs <- list()+ |
+
| 191 | +1x | +
+ k <- 0+ |
+
| 192 | +1x | +
+ for (i in seq(nrow) * 2 - 1) {
+ |
+
| 193 | +3x | +
+ for (j in seq(ncol) * 2 - 1) {
+ |
+
| 194 | +9x | +
+ k <- k + 1+ |
+
| 195 | +9x | +
+ if (k <= length(grobs)) {
+ |
+
| 196 | +9x | +
+ nested_grobs <- c(+ |
+
| 197 | +9x | +
+ nested_grobs,+ |
+
| 198 | +9x | +
+ list(grid::gTree(+ |
+
| 199 | +9x | +
+ children = grid::gList(grobs[[k]]),+ |
+
| 200 | +9x | +
+ vp = grid::viewport(layout.pos.row = i, layout.pos.col = j)+ |
+
| 201 | ++ |
+ ))+ |
+
| 202 | ++ |
+ )+ |
+
| 203 | ++ |
+ }+ |
+
| 204 | ++ |
+ }+ |
+
| 205 | ++ |
+ }+ |
+
| 206 | +1x | +
+ grobs_mainvp <- grid::gTree(+ |
+
| 207 | +1x | +
+ children = do.call(grid::gList, nested_grobs),+ |
+
| 208 | +1x | +
+ vp = main_vp+ |
+
| 209 | ++ |
+ )+ |
+
| 210 | ++ | + + | +
| 211 | +1x | +
+ grid::gTree(+ |
+
| 212 | +1x | +
+ children = grid::gList(grobs_mainvp),+ |
+
| 213 | +1x | +
+ vp = vp,+ |
+
| 214 | +1x | +
+ gp = gp,+ |
+
| 215 | +1x | +
+ name = name+ |
+
| 216 | ++ |
+ )+ |
+
| 217 | ++ |
+ }+ |
+
| 218 | ++ | + + | +
| 219 | ++ |
+ #' Draw `grob`+ |
+
| 220 | ++ |
+ #'+ |
+
| 221 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 222 | ++ |
+ #'+ |
+
| 223 | ++ |
+ #' Draw grob on device page.+ |
+
| 224 | ++ |
+ #'+ |
+
| 225 | ++ |
+ #' @param grob grid object+ |
+
| 226 | ++ |
+ #' @param newpage draw on a new page+ |
+
| 227 | ++ |
+ #' @param vp a [viewport()] object (or `NULL`).+ |
+
| 228 | ++ |
+ #'+ |
+
| 229 | ++ |
+ #' @return A `grob`.+ |
+
| 230 | ++ |
+ #'+ |
+
| 231 | ++ |
+ #' @examples+ |
+
| 232 | ++ |
+ #' library(dplyr)+ |
+
| 233 | ++ |
+ #' library(grid)+ |
+
| 234 | ++ |
+ #'+ |
+
| 235 | ++ |
+ #' \donttest{
+ |
+
| 236 | ++ |
+ #' rect <- rectGrob(width = grid::unit(0.5, "npc"), height = grid::unit(0.5, "npc"))+ |
+
| 237 | ++ |
+ #' rect %>% draw_grob(vp = grid::viewport(angle = 45))+ |
+
| 238 | ++ |
+ #'+ |
+
| 239 | ++ |
+ #' num <- lapply(1:10, textGrob)+ |
+
| 240 | ++ |
+ #' num %>%+ |
+
| 241 | ++ |
+ #' arrange_grobs(grobs = .) %>%+ |
+
| 242 | ++ |
+ #' draw_grob()+ |
+
| 243 | ++ |
+ #' showViewport()+ |
+
| 244 | ++ |
+ #' }+ |
+
| 245 | ++ |
+ #'+ |
+
| 246 | ++ |
+ #' @export+ |
+
| 247 | ++ |
+ draw_grob <- function(grob, newpage = TRUE, vp = NULL) {
+ |
+
| 248 | +3x | +
+ if (newpage) {
+ |
+
| 249 | +3x | +
+ grid::grid.newpage()+ |
+
| 250 | ++ |
+ }+ |
+
| 251 | +3x | +
+ if (!is.null(vp)) {
+ |
+
| 252 | +1x | +
+ grid::pushViewport(vp)+ |
+
| 253 | ++ |
+ }+ |
+
| 254 | +3x | +
+ grid::grid.draw(grob)+ |
+
| 255 | ++ |
+ }+ |
+
| 256 | ++ | + + | +
| 257 | ++ |
+ tern_grob <- function(x) {
+ |
+
| 258 | +! | +
+ class(x) <- unique(c("ternGrob", class(x)))
+ |
+
| 259 | +! | +
+ x+ |
+
| 260 | ++ |
+ }+ |
+
| 261 | ++ | + + | +
| 262 | ++ |
+ print.ternGrob <- function(x, ...) {
+ |
+
| 263 | +! | +
+ grid::grid.newpage()+ |
+
| 264 | +! | +
+ grid::grid.draw(x)+ |
+
| 265 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Tabulate Biomarker Effects on Binary Response by Subgroup+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Tabulate the estimated effects of multiple continuous biomarker variables+ |
+
| 6 | ++ |
+ #' on a binary response endpoint across population subgroups.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #' @param df (`data.frame`)\cr containing all analysis variables, as returned by+ |
+
| 10 | ++ |
+ #' [extract_rsp_biomarkers()].+ |
+
| 11 | ++ |
+ #' @param vars (`character`)\cr the names of statistics to be reported among:+ |
+
| 12 | ++ |
+ #' * `n_tot`: Total number of patients per group.+ |
+
| 13 | ++ |
+ #' * `n_rsp`: Total number of responses per group.+ |
+
| 14 | ++ |
+ #' * `prop`: Total response proportion per group.+ |
+
| 15 | ++ |
+ #' * `or`: Odds ratio.+ |
+
| 16 | ++ |
+ #' * `ci`: Confidence interval of odds ratio.+ |
+
| 17 | ++ |
+ #' * `pval`: p-value of the effect.+ |
+
| 18 | ++ |
+ #' Note, the statistics `n_tot`, `or` and `ci` are required.+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @return An `rtables` table summarizing biomarker effects on binary response by subgroup.+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @details These functions create a layout starting from a data frame which contains+ |
+
| 23 | ++ |
+ #' the required statistics. The tables are then typically used as input for forest plots.+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @note In contrast to [tabulate_rsp_subgroups()] this tabulation function does+ |
+
| 26 | ++ |
+ #' not start from an input layout `lyt`. This is because internally the table is+ |
+
| 27 | ++ |
+ #' created by combining multiple subtables.+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @seealso [h_tab_rsp_one_biomarker()] which is used internally, [extract_rsp_biomarkers()].+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' @examples+ |
+
| 32 | ++ |
+ #' library(dplyr)+ |
+
| 33 | ++ |
+ #' library(forcats)+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' adrs <- tern_ex_adrs+ |
+
| 36 | ++ |
+ #' adrs_labels <- formatters::var_labels(adrs)+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' adrs_f <- adrs %>%+ |
+
| 39 | ++ |
+ #' filter(PARAMCD == "BESRSPI") %>%+ |
+
| 40 | ++ |
+ #' mutate(rsp = AVALC == "CR")+ |
+
| 41 | ++ |
+ #' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' df <- extract_rsp_biomarkers(+ |
+
| 44 | ++ |
+ #' variables = list(+ |
+
| 45 | ++ |
+ #' rsp = "rsp",+ |
+
| 46 | ++ |
+ #' biomarkers = c("BMRKR1", "AGE"),
+ |
+
| 47 | ++ |
+ #' covariates = "SEX",+ |
+
| 48 | ++ |
+ #' subgroups = "BMRKR2"+ |
+
| 49 | ++ |
+ #' ),+ |
+
| 50 | ++ |
+ #' data = adrs_f+ |
+
| 51 | ++ |
+ #' )+ |
+
| 52 | ++ |
+ #'+ |
+
| 53 | ++ |
+ #' \donttest{
+ |
+
| 54 | ++ |
+ #' ## Table with default columns.+ |
+
| 55 | ++ |
+ #' tabulate_rsp_biomarkers(df)+ |
+
| 56 | ++ |
+ #'+ |
+
| 57 | ++ |
+ #' ## Table with a manually chosen set of columns: leave out "pval", reorder.+ |
+
| 58 | ++ |
+ #' tab <- tabulate_rsp_biomarkers(+ |
+
| 59 | ++ |
+ #' df = df,+ |
+
| 60 | ++ |
+ #' vars = c("n_rsp", "ci", "n_tot", "prop", "or")
+ |
+
| 61 | ++ |
+ #' )+ |
+
| 62 | ++ |
+ #'+ |
+
| 63 | ++ |
+ #' ## Finally produce the forest plot.+ |
+
| 64 | ++ |
+ #' g_forest(tab, xlim = c(0.7, 1.4))+ |
+
| 65 | ++ |
+ #' }+ |
+
| 66 | ++ |
+ #'+ |
+
| 67 | ++ |
+ #' @export+ |
+
| 68 | ++ |
+ #' @name response_biomarkers_subgroups+ |
+
| 69 | ++ |
+ tabulate_rsp_biomarkers <- function(df,+ |
+
| 70 | ++ |
+ vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval"),
+ |
+
| 71 | ++ |
+ .indent_mods = 0L) {
+ |
+
| 72 | +3x | +
+ checkmate::assert_data_frame(df)+ |
+
| 73 | +3x | +
+ checkmate::assert_character(df$biomarker)+ |
+
| 74 | +3x | +
+ checkmate::assert_character(df$biomarker_label)+ |
+
| 75 | +3x | +
+ checkmate::assert_subset(vars, c("n_tot", "n_rsp", "prop", "or", "ci", "pval"))
+ |
+
| 76 | ++ | + + | +
| 77 | +3x | +
+ df_subs <- split(df, f = df$biomarker)+ |
+
| 78 | +3x | +
+ tabs <- lapply(df_subs, FUN = function(df_sub) {
+ |
+
| 79 | +5x | +
+ tab_sub <- h_tab_rsp_one_biomarker(+ |
+
| 80 | +5x | +
+ df = df_sub,+ |
+
| 81 | +5x | +
+ vars = vars,+ |
+
| 82 | +5x | +
+ .indent_mods = .indent_mods+ |
+
| 83 | ++ |
+ )+ |
+
| 84 | ++ |
+ # Insert label row as first row in table.+ |
+
| 85 | +5x | +
+ label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1]+ |
+
| 86 | +5x | +
+ tab_sub+ |
+
| 87 | ++ |
+ })+ |
+
| 88 | +3x | +
+ result <- do.call(rbind, tabs)+ |
+
| 89 | ++ | + + | +
| 90 | +3x | +
+ n_id <- grep("n_tot", vars)
+ |
+
| 91 | +3x | +
+ or_id <- match("or", vars)
+ |
+
| 92 | +3x | +
+ ci_id <- match("ci", vars)
+ |
+
| 93 | +3x | +
+ structure(+ |
+
| 94 | +3x | +
+ result,+ |
+
| 95 | +3x | +
+ forest_header = paste0(c("Lower", "Higher"), "\nBetter"),
+ |
+
| 96 | +3x | +
+ col_x = or_id,+ |
+
| 97 | +3x | +
+ col_ci = ci_id,+ |
+
| 98 | +3x | +
+ col_symbol_size = n_id+ |
+
| 99 | ++ |
+ )+ |
+
| 100 | ++ |
+ }+ |
+
| 101 | ++ | + + | +
| 102 | ++ |
+ #' Prepares Response Data Estimates for Multiple Biomarkers in a Single Data Frame+ |
+
| 103 | ++ |
+ #'+ |
+
| 104 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 105 | ++ |
+ #'+ |
+
| 106 | ++ |
+ #' Prepares estimates for number of responses, patients and overall response rate,+ |
+
| 107 | ++ |
+ #' as well as odds ratio estimates, confidence intervals and p-values,+ |
+
| 108 | ++ |
+ #' for multiple biomarkers across population subgroups in a single data frame.+ |
+
| 109 | ++ |
+ #' `variables` corresponds to the names of variables found in `data`, passed as a+ |
+
| 110 | ++ |
+ #' named list and requires elements `rsp` and `biomarkers` (vector of continuous+ |
+
| 111 | ++ |
+ #' biomarker variables) and optionally `covariates`, `subgroups` and `strat`.+ |
+
| 112 | ++ |
+ #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ |
+
| 113 | ++ |
+ #'+ |
+
| 114 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 115 | ++ |
+ #' @inheritParams response_subgroups+ |
+
| 116 | ++ |
+ #' @param control (named `list`)\cr controls for the response definition and the+ |
+
| 117 | ++ |
+ #' confidence level produced by [control_logistic()].+ |
+
| 118 | ++ |
+ #'+ |
+
| 119 | ++ |
+ #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_rsp`,+ |
+
| 120 | ++ |
+ #' `prop`, `or`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`,+ |
+
| 121 | ++ |
+ #' `var_label`, and `row_type`.+ |
+
| 122 | ++ |
+ #'+ |
+
| 123 | ++ |
+ #' @note You can also specify a continuous variable in `rsp` and then use the+ |
+
| 124 | ++ |
+ #' `response_definition` control to convert that internally to a logical+ |
+
| 125 | ++ |
+ #' variable reflecting binary response.+ |
+
| 126 | ++ |
+ #'+ |
+
| 127 | ++ |
+ #' @seealso [h_logistic_mult_cont_df()] which is used internally.+ |
+
| 128 | ++ |
+ #'+ |
+
| 129 | ++ |
+ #' @examples+ |
+
| 130 | ++ |
+ #' library(dplyr)+ |
+
| 131 | ++ |
+ #' library(forcats)+ |
+
| 132 | ++ |
+ #'+ |
+
| 133 | ++ |
+ #' adrs <- tern_ex_adrs+ |
+
| 134 | ++ |
+ #' adrs_labels <- formatters::var_labels(adrs)+ |
+
| 135 | ++ |
+ #'+ |
+
| 136 | ++ |
+ #' adrs_f <- adrs %>%+ |
+
| 137 | ++ |
+ #' filter(PARAMCD == "BESRSPI") %>%+ |
+
| 138 | ++ |
+ #' mutate(rsp = AVALC == "CR")+ |
+
| 139 | ++ |
+ #'+ |
+
| 140 | ++ |
+ #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`,+ |
+
| 141 | ++ |
+ #' # in logistic regression models with one covariate `RACE`. The subgroups+ |
+
| 142 | ++ |
+ #' # are defined by the levels of `BMRKR2`.+ |
+
| 143 | ++ |
+ #' df <- extract_rsp_biomarkers(+ |
+
| 144 | ++ |
+ #' variables = list(+ |
+
| 145 | ++ |
+ #' rsp = "rsp",+ |
+
| 146 | ++ |
+ #' biomarkers = c("BMRKR1", "AGE"),
+ |
+
| 147 | ++ |
+ #' covariates = "SEX",+ |
+
| 148 | ++ |
+ #' subgroups = "BMRKR2"+ |
+
| 149 | ++ |
+ #' ),+ |
+
| 150 | ++ |
+ #' data = adrs_f+ |
+
| 151 | ++ |
+ #' )+ |
+
| 152 | ++ |
+ #' df+ |
+
| 153 | ++ |
+ #'+ |
+
| 154 | ++ |
+ #' # Here we group the levels of `BMRKR2` manually, and we add a stratification+ |
+
| 155 | ++ |
+ #' # variable `STRATA1`. We also here use a continuous variable `EOSDY`+ |
+
| 156 | ++ |
+ #' # which is then binarized internally (response is defined as this variable+ |
+
| 157 | ++ |
+ #' # being larger than 500).+ |
+
| 158 | ++ |
+ #' df_grouped <- extract_rsp_biomarkers(+ |
+
| 159 | ++ |
+ #' variables = list(+ |
+
| 160 | ++ |
+ #' rsp = "EOSDY",+ |
+
| 161 | ++ |
+ #' biomarkers = c("BMRKR1", "AGE"),
+ |
+
| 162 | ++ |
+ #' covariates = "SEX",+ |
+
| 163 | ++ |
+ #' subgroups = "BMRKR2",+ |
+
| 164 | ++ |
+ #' strat = "STRATA1"+ |
+
| 165 | ++ |
+ #' ),+ |
+
| 166 | ++ |
+ #' data = adrs_f,+ |
+
| 167 | ++ |
+ #' groups_lists = list(+ |
+
| 168 | ++ |
+ #' BMRKR2 = list(+ |
+
| 169 | ++ |
+ #' "low" = "LOW",+ |
+
| 170 | ++ |
+ #' "low/medium" = c("LOW", "MEDIUM"),
+ |
+
| 171 | ++ |
+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ |
+
| 172 | ++ |
+ #' )+ |
+
| 173 | ++ |
+ #' ),+ |
+
| 174 | ++ |
+ #' control = control_logistic(+ |
+
| 175 | ++ |
+ #' response_definition = "I(response > 500)"+ |
+
| 176 | ++ |
+ #' )+ |
+
| 177 | ++ |
+ #' )+ |
+
| 178 | ++ |
+ #' df_grouped+ |
+
| 179 | ++ |
+ #'+ |
+
| 180 | ++ |
+ #' @export+ |
+
| 181 | ++ |
+ extract_rsp_biomarkers <- function(variables,+ |
+
| 182 | ++ |
+ data,+ |
+
| 183 | ++ |
+ groups_lists = list(),+ |
+
| 184 | ++ |
+ control = control_logistic(),+ |
+
| 185 | ++ |
+ label_all = "All Patients") {
+ |
+
| 186 | +4x | +
+ assert_list_of_variables(variables)+ |
+
| 187 | +4x | +
+ checkmate::assert_string(variables$rsp)+ |
+
| 188 | +4x | +
+ checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ |
+
| 189 | +4x | +
+ checkmate::assert_string(label_all)+ |
+
| 190 | ++ | + + | +
| 191 | ++ |
+ # Start with all patients.+ |
+
| 192 | +4x | +
+ result_all <- h_logistic_mult_cont_df(+ |
+
| 193 | +4x | +
+ variables = variables,+ |
+
| 194 | +4x | +
+ data = data,+ |
+
| 195 | +4x | +
+ control = control+ |
+
| 196 | ++ |
+ )+ |
+
| 197 | +4x | +
+ result_all$subgroup <- label_all+ |
+
| 198 | +4x | +
+ result_all$var <- "ALL"+ |
+
| 199 | +4x | +
+ result_all$var_label <- label_all+ |
+
| 200 | +4x | +
+ result_all$row_type <- "content"+ |
+
| 201 | +4x | +
+ if (is.null(variables$subgroups)) {
+ |
+
| 202 | ++ |
+ # Only return result for all patients.+ |
+
| 203 | +1x | +
+ result_all+ |
+
| 204 | ++ |
+ } else {
+ |
+
| 205 | ++ |
+ # Add subgroups results.+ |
+
| 206 | +3x | +
+ l_data <- h_split_by_subgroups(+ |
+
| 207 | +3x | +
+ data,+ |
+
| 208 | +3x | +
+ variables$subgroups,+ |
+
| 209 | +3x | +
+ groups_lists = groups_lists+ |
+
| 210 | ++ |
+ )+ |
+
| 211 | +3x | +
+ l_result <- lapply(l_data, function(grp) {
+ |
+
| 212 | +15x | +
+ result <- h_logistic_mult_cont_df(+ |
+
| 213 | +15x | +
+ variables = variables,+ |
+
| 214 | +15x | +
+ data = grp$df,+ |
+
| 215 | +15x | +
+ control = control+ |
+
| 216 | ++ |
+ )+ |
+
| 217 | +15x | +
+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ |
+
| 218 | +15x | +
+ cbind(result, result_labels)+ |
+
| 219 | ++ |
+ })+ |
+
| 220 | +3x | +
+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ |
+
| 221 | +3x | +
+ result_subgroups$row_type <- "analysis"+ |
+
| 222 | +3x | +
+ rbind(+ |
+
| 223 | +3x | +
+ result_all,+ |
+
| 224 | +3x | +
+ result_subgroups+ |
+
| 225 | ++ |
+ )+ |
+
| 226 | ++ |
+ }+ |
+
| 227 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Tabulate Biomarker Effects on Survival by Subgroup+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Tabulate the estimated effects of multiple continuous biomarker variables+ |
+
| 6 | ++ |
+ #' across population subgroups.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #' @inheritParams fit_coxreg_multivar+ |
+
| 10 | ++ |
+ #' @inheritParams survival_duration_subgroups+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @details These functions create a layout starting from a data frame which contains+ |
+
| 13 | ++ |
+ #' the required statistics. The tables are then typically used as input for forest plots.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @examples+ |
+
| 16 | ++ |
+ #' library(dplyr)+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' adtte <- tern_ex_adtte+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' # Save variable labels before data processing steps.+ |
+
| 21 | ++ |
+ #' adtte_labels <- formatters::var_labels(adtte)+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' adtte_f <- adtte %>%+ |
+
| 24 | ++ |
+ #' filter(PARAMCD == "OS") %>%+ |
+
| 25 | ++ |
+ #' mutate(+ |
+
| 26 | ++ |
+ #' AVALU = as.character(AVALU),+ |
+
| 27 | ++ |
+ #' is_event = CNSR == 0+ |
+
| 28 | ++ |
+ #' )+ |
+
| 29 | ++ |
+ #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
+ |
+
| 30 | ++ |
+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' df <- extract_survival_biomarkers(+ |
+
| 33 | ++ |
+ #' variables = list(+ |
+
| 34 | ++ |
+ #' tte = "AVAL",+ |
+
| 35 | ++ |
+ #' is_event = "is_event",+ |
+
| 36 | ++ |
+ #' biomarkers = c("BMRKR1", "AGE"),
+ |
+
| 37 | ++ |
+ #' strata = "STRATA1",+ |
+
| 38 | ++ |
+ #' covariates = "SEX",+ |
+
| 39 | ++ |
+ #' subgroups = "BMRKR2"+ |
+
| 40 | ++ |
+ #' ),+ |
+
| 41 | ++ |
+ #' data = adtte_f+ |
+
| 42 | ++ |
+ #' )+ |
+
| 43 | ++ |
+ #' df+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' @name survival_biomarkers_subgroups+ |
+
| 46 | ++ |
+ NULL+ |
+
| 47 | ++ | + + | +
| 48 | ++ |
+ #' Prepares Survival Data Estimates for Multiple Biomarkers in a Single Data Frame+ |
+
| 49 | ++ |
+ #'+ |
+
| 50 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 51 | ++ |
+ #'+ |
+
| 52 | ++ |
+ #' Prepares estimates for number of events, patients and median survival times, as well as hazard ratio estimates,+ |
+
| 53 | ++ |
+ #' confidence intervals and p-values, for multiple biomarkers across population subgroups in a single data frame.+ |
+
| 54 | ++ |
+ #' `variables` corresponds to the names of variables found in `data`, passed as a named `list` and requires elements+ |
+
| 55 | ++ |
+ #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables), and optionally `subgroups` and `strat`.+ |
+
| 56 | ++ |
+ #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ |
+
| 57 | ++ |
+ #'+ |
+
| 58 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 59 | ++ |
+ #' @inheritParams fit_coxreg_multivar+ |
+
| 60 | ++ |
+ #' @inheritParams survival_duration_subgroups+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' @return A `data.frame` with columns `biomarker`, `biomarker_label`, `n_tot`, `n_tot_events`,+ |
+
| 63 | ++ |
+ #' `median`, `hr`, `lcl`, `ucl`, `conf_level`, `pval`, `pval_label`, `subgroup`, `var`,+ |
+
| 64 | ++ |
+ #' `var_label`, and `row_type`.+ |
+
| 65 | ++ |
+ #'+ |
+
| 66 | ++ |
+ #' @seealso [h_coxreg_mult_cont_df()] which is used internally, [tabulate_survival_biomarkers()].+ |
+
| 67 | ++ |
+ #'+ |
+
| 68 | ++ |
+ #' @examples+ |
+
| 69 | ++ |
+ #' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`,+ |
+
| 70 | ++ |
+ #' # in multiple regression models containing one covariate `RACE`,+ |
+
| 71 | ++ |
+ #' # as well as one stratification variable `STRATA1`. The subgroups+ |
+
| 72 | ++ |
+ #' # are defined by the levels of `BMRKR2`.+ |
+
| 73 | ++ |
+ #'+ |
+
| 74 | ++ |
+ #' library(dplyr)+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ #' adtte <- tern_ex_adtte+ |
+
| 77 | ++ |
+ #' adtte_labels <- formatters::var_labels(adtte)+ |
+
| 78 | ++ |
+ #'+ |
+
| 79 | ++ |
+ #' adtte_f <- adtte %>%+ |
+
| 80 | ++ |
+ #' filter(PARAMCD == "OS") %>%+ |
+
| 81 | ++ |
+ #' mutate(+ |
+
| 82 | ++ |
+ #' AVALU = as.character(AVALU),+ |
+
| 83 | ++ |
+ #' is_event = CNSR == 0+ |
+
| 84 | ++ |
+ #' )+ |
+
| 85 | ++ |
+ #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
+ |
+
| 86 | ++ |
+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ |
+
| 87 | ++ |
+ #'+ |
+
| 88 | ++ |
+ #' df <- extract_survival_biomarkers(+ |
+
| 89 | ++ |
+ #' variables = list(+ |
+
| 90 | ++ |
+ #' tte = "AVAL",+ |
+
| 91 | ++ |
+ #' is_event = "is_event",+ |
+
| 92 | ++ |
+ #' biomarkers = c("BMRKR1", "AGE"),
+ |
+
| 93 | ++ |
+ #' strata = "STRATA1",+ |
+
| 94 | ++ |
+ #' covariates = "SEX",+ |
+
| 95 | ++ |
+ #' subgroups = "BMRKR2"+ |
+
| 96 | ++ |
+ #' ),+ |
+
| 97 | ++ |
+ #' data = adtte_f+ |
+
| 98 | ++ |
+ #' )+ |
+
| 99 | ++ |
+ #' df+ |
+
| 100 | ++ |
+ #'+ |
+
| 101 | ++ |
+ #' # Here we group the levels of `BMRKR2` manually.+ |
+
| 102 | ++ |
+ #' df_grouped <- extract_survival_biomarkers(+ |
+
| 103 | ++ |
+ #' variables = list(+ |
+
| 104 | ++ |
+ #' tte = "AVAL",+ |
+
| 105 | ++ |
+ #' is_event = "is_event",+ |
+
| 106 | ++ |
+ #' biomarkers = c("BMRKR1", "AGE"),
+ |
+
| 107 | ++ |
+ #' strata = "STRATA1",+ |
+
| 108 | ++ |
+ #' covariates = "SEX",+ |
+
| 109 | ++ |
+ #' subgroups = "BMRKR2"+ |
+
| 110 | ++ |
+ #' ),+ |
+
| 111 | ++ |
+ #' data = adtte_f,+ |
+
| 112 | ++ |
+ #' groups_lists = list(+ |
+
| 113 | ++ |
+ #' BMRKR2 = list(+ |
+
| 114 | ++ |
+ #' "low" = "LOW",+ |
+
| 115 | ++ |
+ #' "low/medium" = c("LOW", "MEDIUM"),
+ |
+
| 116 | ++ |
+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ |
+
| 117 | ++ |
+ #' )+ |
+
| 118 | ++ |
+ #' )+ |
+
| 119 | ++ |
+ #' )+ |
+
| 120 | ++ |
+ #' df_grouped+ |
+
| 121 | ++ |
+ #'+ |
+
| 122 | ++ |
+ #' @export+ |
+
| 123 | ++ |
+ extract_survival_biomarkers <- function(variables,+ |
+
| 124 | ++ |
+ data,+ |
+
| 125 | ++ |
+ groups_lists = list(),+ |
+
| 126 | ++ |
+ control = control_coxreg(),+ |
+
| 127 | ++ |
+ label_all = "All Patients") {
+ |
+
| 128 | +4x | +
+ checkmate::assert_list(variables)+ |
+
| 129 | +4x | +
+ checkmate::assert_character(variables$subgroups, null.ok = TRUE)+ |
+
| 130 | +4x | +
+ checkmate::assert_string(label_all)+ |
+
| 131 | ++ | + + | +
| 132 | ++ |
+ # Start with all patients.+ |
+
| 133 | +4x | +
+ result_all <- h_coxreg_mult_cont_df(+ |
+
| 134 | +4x | +
+ variables = variables,+ |
+
| 135 | +4x | +
+ data = data,+ |
+
| 136 | +4x | +
+ control = control+ |
+
| 137 | ++ |
+ )+ |
+
| 138 | +4x | +
+ result_all$subgroup <- label_all+ |
+
| 139 | +4x | +
+ result_all$var <- "ALL"+ |
+
| 140 | +4x | +
+ result_all$var_label <- label_all+ |
+
| 141 | +4x | +
+ result_all$row_type <- "content"+ |
+
| 142 | +4x | +
+ if (is.null(variables$subgroups)) {
+ |
+
| 143 | ++ |
+ # Only return result for all patients.+ |
+
| 144 | +1x | +
+ result_all+ |
+
| 145 | ++ |
+ } else {
+ |
+
| 146 | ++ |
+ # Add subgroups results.+ |
+
| 147 | +3x | +
+ l_data <- h_split_by_subgroups(+ |
+
| 148 | +3x | +
+ data,+ |
+
| 149 | +3x | +
+ variables$subgroups,+ |
+
| 150 | +3x | +
+ groups_lists = groups_lists+ |
+
| 151 | ++ |
+ )+ |
+
| 152 | +3x | +
+ l_result <- lapply(l_data, function(grp) {
+ |
+
| 153 | +15x | +
+ result <- h_coxreg_mult_cont_df(+ |
+
| 154 | +15x | +
+ variables = variables,+ |
+
| 155 | +15x | +
+ data = grp$df,+ |
+
| 156 | +15x | +
+ control = control+ |
+
| 157 | ++ |
+ )+ |
+
| 158 | +15x | +
+ result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]+ |
+
| 159 | +15x | +
+ cbind(result, result_labels)+ |
+
| 160 | ++ |
+ })+ |
+
| 161 | +3x | +
+ result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))+ |
+
| 162 | +3x | +
+ result_subgroups$row_type <- "analysis"+ |
+
| 163 | +3x | +
+ rbind(+ |
+
| 164 | +3x | +
+ result_all,+ |
+
| 165 | +3x | +
+ result_subgroups+ |
+
| 166 | ++ |
+ )+ |
+
| 167 | ++ |
+ }+ |
+
| 168 | ++ |
+ }+ |
+
| 169 | ++ | + + | +
| 170 | ++ |
+ #' @describeIn survival_biomarkers_subgroups Table-creating function which creates a table+ |
+
| 171 | ++ |
+ #' summarizing biomarker effects on survival by subgroup.+ |
+
| 172 | ++ |
+ #'+ |
+
| 173 | ++ |
+ #' @param df (`data.frame`)\cr containing all analysis variables, as returned by+ |
+
| 174 | ++ |
+ #' [extract_survival_biomarkers()].+ |
+
| 175 | ++ |
+ #' @param vars (`character`)\cr the names of statistics to be reported among:+ |
+
| 176 | ++ |
+ #' * `n_tot_events`: Total number of events per group.+ |
+
| 177 | ++ |
+ #' * `n_tot`: Total number of observations per group.+ |
+
| 178 | ++ |
+ #' * `median`: Median survival time.+ |
+
| 179 | ++ |
+ #' * `hr`: Hazard ratio.+ |
+
| 180 | ++ |
+ #' * `ci`: Confidence interval of hazard ratio.+ |
+
| 181 | ++ |
+ #' * `pval`: p-value of the effect.+ |
+
| 182 | ++ |
+ #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` are required.+ |
+
| 183 | ++ |
+ #'+ |
+
| 184 | ++ |
+ #' @return An `rtables` table summarizing biomarker effects on survival by subgroup.+ |
+
| 185 | ++ |
+ #'+ |
+
| 186 | ++ |
+ #' @note In contrast to [tabulate_survival_subgroups()] this tabulation function does+ |
+
| 187 | ++ |
+ #' not start from an input layout `lyt`. This is because internally the table is+ |
+
| 188 | ++ |
+ #' created by combining multiple subtables.+ |
+
| 189 | ++ |
+ #'+ |
+
| 190 | ++ |
+ #' @seealso [h_tab_surv_one_biomarker()] which is used internally, [extract_survival_biomarkers()].+ |
+
| 191 | ++ |
+ #'+ |
+
| 192 | ++ |
+ #' @examples+ |
+
| 193 | ++ |
+ #' ## Table with default columns.+ |
+
| 194 | ++ |
+ #' tabulate_survival_biomarkers(df)+ |
+
| 195 | ++ |
+ #'+ |
+
| 196 | ++ |
+ #' ## Table with a manually chosen set of columns: leave out "pval", reorder.+ |
+
| 197 | ++ |
+ #' tab <- tabulate_survival_biomarkers(+ |
+
| 198 | ++ |
+ #' df = df,+ |
+
| 199 | ++ |
+ #' vars = c("n_tot_events", "ci", "n_tot", "median", "hr"),
+ |
+
| 200 | ++ |
+ #' time_unit = as.character(adtte_f$AVALU[1])+ |
+
| 201 | ++ |
+ #' )+ |
+
| 202 | ++ |
+ #'+ |
+
| 203 | ++ |
+ #' ## Finally produce the forest plot.+ |
+
| 204 | ++ |
+ #' \donttest{
+ |
+
| 205 | ++ |
+ #' g_forest(tab, xlim = c(0.8, 1.2))+ |
+
| 206 | ++ |
+ #' }+ |
+
| 207 | ++ |
+ #'+ |
+
| 208 | ++ |
+ #' @export+ |
+
| 209 | ++ |
+ tabulate_survival_biomarkers <- function(df,+ |
+
| 210 | ++ |
+ vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
+ |
+
| 211 | ++ |
+ time_unit = NULL,+ |
+
| 212 | ++ |
+ .indent_mods = 0L) {
+ |
+
| 213 | +3x | +
+ checkmate::assert_data_frame(df)+ |
+
| 214 | +3x | +
+ checkmate::assert_character(df$biomarker)+ |
+
| 215 | +3x | +
+ checkmate::assert_character(df$biomarker_label)+ |
+
| 216 | +3x | +
+ checkmate::assert_subset(vars, c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"))
+ |
+
| 217 | ++ | + + | +
| 218 | +3x | +
+ df_subs <- split(df, f = df$biomarker)+ |
+
| 219 | +3x | +
+ tabs <- lapply(df_subs, FUN = function(df_sub) {
+ |
+
| 220 | +5x | +
+ tab_sub <- h_tab_surv_one_biomarker(+ |
+
| 221 | +5x | +
+ df = df_sub,+ |
+
| 222 | +5x | +
+ vars = vars,+ |
+
| 223 | +5x | +
+ time_unit = time_unit,+ |
+
| 224 | +5x | +
+ .indent_mods = .indent_mods+ |
+
| 225 | ++ |
+ )+ |
+
| 226 | ++ |
+ # Insert label row as first row in table.+ |
+
| 227 | +5x | +
+ label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1]+ |
+
| 228 | +5x | +
+ tab_sub+ |
+
| 229 | ++ |
+ })+ |
+
| 230 | +3x | +
+ result <- do.call(rbind, tabs)+ |
+
| 231 | ++ | + + | +
| 232 | +3x | +
+ n_tot_ids <- grep("^n_tot", vars)
+ |
+
| 233 | +3x | +
+ hr_id <- match("hr", vars)
+ |
+
| 234 | +3x | +
+ ci_id <- match("ci", vars)
+ |
+
| 235 | +3x | +
+ structure(+ |
+
| 236 | +3x | +
+ result,+ |
+
| 237 | +3x | +
+ forest_header = paste0(c("Higher", "Lower"), "\nBetter"),
+ |
+
| 238 | +3x | +
+ col_x = hr_id,+ |
+
| 239 | +3x | +
+ col_ci = ci_id,+ |
+
| 240 | +3x | +
+ col_symbol_size = n_tot_ids[1]+ |
+
| 241 | ++ |
+ )+ |
+
| 242 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Counting Patients Summing Exposure Across All Patients in Columns+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Counting the number of patients and summing analysis value (i.e exposure values) across all patients+ |
+
| 6 | ++ |
+ #' when a column table layout is required.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @name summarize_patients_exposure_in_cols+ |
+
| 11 | ++ |
+ NULL+ |
+
| 12 | ++ | + + | +
| 13 | ++ |
+ #' @describeIn summarize_patients_exposure_in_cols Statistics function which counts numbers+ |
+
| 14 | ++ |
+ #' of patients and the sum of exposure across all patients.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @param ex_var (`character`)\cr name of the variable within `df` containing exposure values.+ |
+
| 17 | ++ |
+ #' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will be used as label.+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @return+ |
+
| 20 | ++ |
+ #' * `s_count_patients_sum_exposure()` returns a named `list` with the statistics:+ |
+
| 21 | ++ |
+ #' * `n_patients`: Number of unique patients in `df`.+ |
+
| 22 | ++ |
+ #' * `sum_exposure`: Sum of `ex_var` across all patients in `df`.+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @examples+ |
+
| 25 | ++ |
+ #' set.seed(1)+ |
+
| 26 | ++ |
+ #' df <- data.frame(+ |
+
| 27 | ++ |
+ #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
+ |
+
| 28 | ++ |
+ #' ARMCD = c(rep("ARM A", 6), rep("ARM B", 6)),
+ |
+
| 29 | ++ |
+ #' SEX = c(rep("Female", 6), rep("Male", 6)),
+ |
+
| 30 | ++ |
+ #' AVAL = as.numeric(sample(seq(1, 20), 12)),+ |
+
| 31 | ++ |
+ #' stringsAsFactors = TRUE+ |
+
| 32 | ++ |
+ #' )+ |
+
| 33 | ++ |
+ #' adsl <- data.frame(+ |
+
| 34 | ++ |
+ #' USUBJID = c(paste("id", seq(1, 12), sep = "")),
+ |
+
| 35 | ++ |
+ #' ARMCD = c(rep("ARM A", 2), rep("ARM B", 2)),
+ |
+
| 36 | ++ |
+ #' SEX = c(rep("Female", 2), rep("Male", 2)),
+ |
+
| 37 | ++ |
+ #' stringsAsFactors = TRUE+ |
+
| 38 | ++ |
+ #' )+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' @keywords internal+ |
+
| 41 | ++ |
+ s_count_patients_sum_exposure <- function(df,+ |
+
| 42 | ++ |
+ ex_var = "AVAL",+ |
+
| 43 | ++ |
+ id = "USUBJID",+ |
+
| 44 | ++ |
+ labelstr = "",+ |
+
| 45 | ++ |
+ .stats = c("n_patients", "sum_exposure"),
+ |
+
| 46 | ++ |
+ .N_col, # nolint+ |
+
| 47 | ++ |
+ custom_label = NULL) {
+ |
+
| 48 | +56x | +
+ assert_df_with_variables(df, list(ex_var = ex_var, id = id))+ |
+
| 49 | +56x | +
+ checkmate::assert_string(id)+ |
+
| 50 | +56x | +
+ checkmate::assert_string(labelstr)+ |
+
| 51 | +56x | +
+ checkmate::assert_string(custom_label, null.ok = TRUE)+ |
+
| 52 | +56x | +
+ checkmate::assert_numeric(df[[ex_var]])+ |
+
| 53 | +56x | +
+ checkmate::assert_true(all(.stats %in% c("n_patients", "sum_exposure")))
+ |
+
| 54 | ++ | + + | +
| 55 | +56x | +
+ row_label <- if (labelstr != "") {
+ |
+
| 56 | +! | +
+ labelstr+ |
+
| 57 | +56x | +
+ } else if (!is.null(custom_label)) {
+ |
+
| 58 | +48x | +
+ custom_label+ |
+
| 59 | ++ |
+ } else {
+ |
+
| 60 | +8x | +
+ "Total patients numbers/person time"+ |
+
| 61 | ++ |
+ }+ |
+
| 62 | ++ | + + | +
| 63 | +56x | +
+ y <- list()+ |
+
| 64 | ++ | + + | +
| 65 | +56x | +
+ if ("n_patients" %in% .stats) {
+ |
+
| 66 | +23x | +
+ y$n_patients <-+ |
+
| 67 | +23x | +
+ formatters::with_label(+ |
+
| 68 | +23x | +
+ s_num_patients_content(+ |
+
| 69 | +23x | +
+ df = df,+ |
+
| 70 | +23x | +
+ .N_col = .N_col, # nolint+ |
+
| 71 | +23x | +
+ .var = id,+ |
+
| 72 | +23x | +
+ labelstr = ""+ |
+
| 73 | +23x | +
+ )$unique,+ |
+
| 74 | +23x | +
+ row_label+ |
+
| 75 | ++ |
+ )+ |
+
| 76 | ++ |
+ }+ |
+
| 77 | +56x | +
+ if ("sum_exposure" %in% .stats) {
+ |
+
| 78 | +34x | +
+ y$sum_exposure <- formatters::with_label(sum(df[[ex_var]]), row_label)+ |
+
| 79 | ++ |
+ }+ |
+
| 80 | +56x | +
+ y+ |
+
| 81 | ++ |
+ }+ |
+
| 82 | ++ | + + | +
| 83 | ++ |
+ #' @describeIn summarize_patients_exposure_in_cols Analysis function which is used as `afun` in+ |
+
| 84 | ++ |
+ #' [rtables::analyze_colvars()] within `analyze_patients_exposure_in_cols()` and as `cfun` in+ |
+
| 85 | ++ |
+ #' [rtables::summarize_row_groups()] within `summarize_patients_exposure_in_cols()`.+ |
+
| 86 | ++ |
+ #'+ |
+
| 87 | ++ |
+ #' @return+ |
+
| 88 | ++ |
+ #' * `a_count_patients_sum_exposure()` returns formatted [rtables::CellValue()].+ |
+
| 89 | ++ |
+ #'+ |
+
| 90 | ++ |
+ #' @examples+ |
+
| 91 | ++ |
+ #' a_count_patients_sum_exposure(+ |
+
| 92 | ++ |
+ #' df = df,+ |
+
| 93 | ++ |
+ #' var = "SEX",+ |
+
| 94 | ++ |
+ #' .N_col = nrow(df),+ |
+
| 95 | ++ |
+ #' .stats = "n_patients"+ |
+
| 96 | ++ |
+ #' )+ |
+
| 97 | ++ |
+ #'+ |
+
| 98 | ++ |
+ #' @export+ |
+
| 99 | ++ |
+ a_count_patients_sum_exposure <- function(df,+ |
+
| 100 | ++ |
+ var = NULL,+ |
+
| 101 | ++ |
+ ex_var = "AVAL",+ |
+
| 102 | ++ |
+ id = "USUBJID",+ |
+
| 103 | ++ |
+ labelstr = "",+ |
+
| 104 | ++ |
+ add_total_level = FALSE,+ |
+
| 105 | ++ |
+ .N_col, # nolint+ |
+
| 106 | ++ |
+ .stats,+ |
+
| 107 | ++ |
+ .formats = list(n_patients = "xx (xx.x%)", sum_exposure = "xx"),+ |
+
| 108 | ++ |
+ custom_label = NULL) {
+ |
+
| 109 | +32x | +
+ checkmate::assert_flag(add_total_level)+ |
+
| 110 | ++ | + + | +
| 111 | +32x | +
+ if (!is.null(var)) {
+ |
+
| 112 | +21x | +
+ assert_df_with_variables(df, list(var = var))+ |
+
| 113 | +21x | +
+ df[[var]] <- as.factor(df[[var]])+ |
+
| 114 | ++ |
+ }+ |
+
| 115 | ++ | + + | +
| 116 | +32x | +
+ y <- list()+ |
+
| 117 | +32x | +
+ if (is.null(var)) {
+ |
+
| 118 | +11x | +
+ y[[.stats]] <- list(Total = s_count_patients_sum_exposure(+ |
+
| 119 | +11x | +
+ df = df,+ |
+
| 120 | +11x | +
+ ex_var = ex_var,+ |
+
| 121 | +11x | +
+ id = id,+ |
+
| 122 | +11x | +
+ labelstr = labelstr,+ |
+
| 123 | +11x | +
+ .N_col = .N_col,+ |
+
| 124 | +11x | +
+ .stats = .stats,+ |
+
| 125 | +11x | +
+ custom_label = custom_label+ |
+
| 126 | +11x | +
+ )[[.stats]])+ |
+
| 127 | ++ |
+ } else {
+ |
+
| 128 | +21x | +
+ for (lvl in levels(df[[var]])) {
+ |
+
| 129 | +42x | +
+ y[[.stats]][[lvl]] <- s_count_patients_sum_exposure(+ |
+
| 130 | +42x | +
+ df = subset(df, get(var) == lvl),+ |
+
| 131 | +42x | +
+ ex_var = ex_var,+ |
+
| 132 | +42x | +
+ id = id,+ |
+
| 133 | +42x | +
+ labelstr = labelstr,+ |
+
| 134 | +42x | +
+ .N_col = .N_col,+ |
+
| 135 | +42x | +
+ .stats = .stats,+ |
+
| 136 | +42x | +
+ custom_label = lvl+ |
+
| 137 | +42x | +
+ )[[.stats]]+ |
+
| 138 | ++ |
+ }+ |
+
| 139 | +21x | +
+ if (add_total_level) {
+ |
+
| 140 | +2x | +
+ y[[.stats]][["Total"]] <- s_count_patients_sum_exposure(+ |
+
| 141 | +2x | +
+ df = df,+ |
+
| 142 | +2x | +
+ ex_var = ex_var,+ |
+
| 143 | +2x | +
+ id = id,+ |
+
| 144 | +2x | +
+ labelstr = labelstr,+ |
+
| 145 | +2x | +
+ .N_col = .N_col,+ |
+
| 146 | +2x | +
+ .stats = .stats,+ |
+
| 147 | +2x | +
+ custom_label = custom_label+ |
+
| 148 | +2x | +
+ )[[.stats]]+ |
+
| 149 | ++ |
+ }+ |
+
| 150 | ++ |
+ }+ |
+
| 151 | ++ | + + | +
| 152 | +32x | +
+ in_rows(.list = y[[.stats]], .formats = .formats[[.stats]])+ |
+
| 153 | ++ |
+ }+ |
+
| 154 | ++ | + + | +
| 155 | ++ |
+ #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics+ |
+
| 156 | ++ |
+ #' function arguments and additional format arguments. This function is a wrapper for+ |
+
| 157 | ++ |
+ #' [rtables::split_cols_by_multivar()] and [rtables::summarize_row_groups()].+ |
+
| 158 | ++ |
+ #'+ |
+
| 159 | ++ |
+ #' @return+ |
+
| 160 | ++ |
+ #' * `summarize_patients_exposure_in_cols()` returns a layout object suitable for passing to further+ |
+
| 161 | ++ |
+ #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will+ |
+
| 162 | ++ |
+ #' add formatted content rows, with the statistics from `s_count_patients_sum_exposure()` arranged in+ |
+
| 163 | ++ |
+ #' columns, to the table layout.+ |
+
| 164 | ++ |
+ #'+ |
+
| 165 | ++ |
+ #' @examples+ |
+
| 166 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 167 | ++ |
+ #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE)+ |
+
| 168 | ++ |
+ #' result <- build_table(lyt, df = df, alt_counts_df = adsl)+ |
+
| 169 | ++ |
+ #' result+ |
+
| 170 | ++ |
+ #'+ |
+
| 171 | ++ |
+ #' lyt2 <- basic_table() %>%+ |
+
| 172 | ++ |
+ #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE, .stats = "sum_exposure")+ |
+
| 173 | ++ |
+ #' result2 <- build_table(lyt2, df = df, alt_counts_df = adsl)+ |
+
| 174 | ++ |
+ #' result2+ |
+
| 175 | ++ |
+ #'+ |
+
| 176 | ++ |
+ #' @export+ |
+
| 177 | ++ |
+ summarize_patients_exposure_in_cols <- function(lyt, # nolint+ |
+
| 178 | ++ |
+ var,+ |
+
| 179 | ++ |
+ na_str = NA_character_,+ |
+
| 180 | ++ |
+ ...,+ |
+
| 181 | ++ |
+ .stats = c("n_patients", "sum_exposure"),
+ |
+
| 182 | ++ |
+ .labels = c(n_patients = "Patients", sum_exposure = "Person time"),+ |
+
| 183 | ++ |
+ .indent_mods = NULL,+ |
+
| 184 | ++ |
+ col_split = TRUE) {
+ |
+
| 185 | +3x | +
+ if (col_split) {
+ |
+
| 186 | +3x | +
+ lyt <- split_cols_by_multivar(+ |
+
| 187 | +3x | +
+ lyt = lyt,+ |
+
| 188 | +3x | +
+ vars = rep(var, length(.stats)),+ |
+
| 189 | +3x | +
+ varlabels = .labels[.stats],+ |
+
| 190 | +3x | +
+ extra_args = list(.stats = .stats)+ |
+
| 191 | ++ |
+ )+ |
+
| 192 | ++ |
+ }+ |
+
| 193 | +3x | +
+ summarize_row_groups(+ |
+
| 194 | +3x | +
+ lyt = lyt,+ |
+
| 195 | +3x | +
+ var = var,+ |
+
| 196 | +3x | +
+ cfun = a_count_patients_sum_exposure,+ |
+
| 197 | +3x | +
+ na_str = na_str,+ |
+
| 198 | +3x | +
+ extra_args = list(...)+ |
+
| 199 | ++ |
+ )+ |
+
| 200 | ++ |
+ }+ |
+
| 201 | ++ | + + | +
| 202 | ++ |
+ #' @describeIn summarize_patients_exposure_in_cols Layout-creating function which can take statistics+ |
+
| 203 | ++ |
+ #' function arguments and additional format arguments. This function is a wrapper for+ |
+
| 204 | ++ |
+ #' [rtables::split_cols_by_multivar()] and [rtables::analyze_colvars()].+ |
+
| 205 | ++ |
+ #'+ |
+
| 206 | ++ |
+ #' @param col_split (`flag`)\cr whether the columns should be split. Set to `FALSE` when the required+ |
+
| 207 | ++ |
+ #' column split has been done already earlier in the layout pipe.+ |
+
| 208 | ++ |
+ #'+ |
+
| 209 | ++ |
+ #' @return+ |
+
| 210 | ++ |
+ #' * `analyze_patients_exposure_in_cols()` returns a layout object suitable for passing to further+ |
+
| 211 | ++ |
+ #' layouting functions, or to [rtables::build_table()]. Adding this function to an `rtable` layout will+ |
+
| 212 | ++ |
+ #' add formatted data rows, with the statistics from `s_count_patients_sum_exposure()` arranged in+ |
+
| 213 | ++ |
+ #' columns, to the table layout.+ |
+
| 214 | ++ |
+ #'+ |
+
| 215 | ++ |
+ #' @note As opposed to [summarize_patients_exposure_in_cols()] which generates content rows,+ |
+
| 216 | ++ |
+ #' `analyze_patients_exposure_in_cols()` generates data rows which will _not_ be repeated on multiple+ |
+
| 217 | ++ |
+ #' pages when pagination is used.+ |
+
| 218 | ++ |
+ #'+ |
+
| 219 | ++ |
+ #' @examples+ |
+
| 220 | ++ |
+ #' lyt3 <- basic_table() %>%+ |
+
| 221 | ++ |
+ #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
+ |
+
| 222 | ++ |
+ #' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) %>%+ |
+
| 223 | ++ |
+ #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE)+ |
+
| 224 | ++ |
+ #' result3 <- build_table(lyt3, df = df, alt_counts_df = adsl)+ |
+
| 225 | ++ |
+ #' result3+ |
+
| 226 | ++ |
+ #'+ |
+
| 227 | ++ |
+ #' lyt4 <- basic_table() %>%+ |
+
| 228 | ++ |
+ #' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
+ |
+
| 229 | ++ |
+ #' summarize_patients_exposure_in_cols(+ |
+
| 230 | ++ |
+ #' var = "AVAL", col_split = TRUE,+ |
+
| 231 | ++ |
+ #' .stats = "n_patients", custom_label = "some custom label"+ |
+
| 232 | ++ |
+ #' ) %>%+ |
+
| 233 | ++ |
+ #' analyze_patients_exposure_in_cols(var = "SEX", col_split = FALSE, ex_var = "AVAL")+ |
+
| 234 | ++ |
+ #' result4 <- build_table(lyt4, df = df, alt_counts_df = adsl)+ |
+
| 235 | ++ |
+ #' result4+ |
+
| 236 | ++ |
+ #'+ |
+
| 237 | ++ |
+ #' lyt5 <- basic_table() %>%+ |
+
| 238 | ++ |
+ #' analyze_patients_exposure_in_cols(var = "SEX", col_split = TRUE, ex_var = "AVAL")+ |
+
| 239 | ++ |
+ #' result5 <- build_table(lyt5, df = df, alt_counts_df = adsl)+ |
+
| 240 | ++ |
+ #' result5+ |
+
| 241 | ++ |
+ #'+ |
+
| 242 | ++ |
+ #' # Adding total levels and custom label+ |
+
| 243 | ++ |
+ #' lyt <- basic_table(+ |
+
| 244 | ++ |
+ #' show_colcounts = TRUE+ |
+
| 245 | ++ |
+ #' ) %>%+ |
+
| 246 | ++ |
+ #' analyze_patients_exposure_in_cols(+ |
+
| 247 | ++ |
+ #' var = "ARMCD",+ |
+
| 248 | ++ |
+ #' col_split = TRUE,+ |
+
| 249 | ++ |
+ #' add_total_level = TRUE,+ |
+
| 250 | ++ |
+ #' custom_label = "TOTAL"+ |
+
| 251 | ++ |
+ #' ) %>%+ |
+
| 252 | ++ |
+ #' append_topleft(c("", "Sex"))
+ |
+
| 253 | ++ |
+ #'+ |
+
| 254 | ++ |
+ #' tbl <- build_table(lyt, df = df, alt_counts_df = adsl)+ |
+
| 255 | ++ |
+ #' tbl+ |
+
| 256 | ++ |
+ #'+ |
+
| 257 | ++ |
+ #' @export+ |
+
| 258 | ++ |
+ analyze_patients_exposure_in_cols <- function(lyt, # nolint+ |
+
| 259 | ++ |
+ var = NULL,+ |
+
| 260 | ++ |
+ ex_var = "AVAL",+ |
+
| 261 | ++ |
+ col_split = TRUE,+ |
+
| 262 | ++ |
+ add_total_level = FALSE,+ |
+
| 263 | ++ |
+ .stats = c("n_patients", "sum_exposure"),
+ |
+
| 264 | ++ |
+ .labels = c(n_patients = "Patients", sum_exposure = "Person time"),+ |
+
| 265 | ++ |
+ .indent_mods = 0L,+ |
+
| 266 | ++ |
+ ...) {
+ |
+
| 267 | +6x | +
+ if (col_split) {
+ |
+
| 268 | +4x | +
+ lyt <- split_cols_by_multivar(+ |
+
| 269 | +4x | +
+ lyt = lyt,+ |
+
| 270 | +4x | +
+ vars = rep(ex_var, length(.stats)),+ |
+
| 271 | +4x | +
+ varlabels = .labels[.stats],+ |
+
| 272 | +4x | +
+ extra_args = list(.stats = .stats)+ |
+
| 273 | ++ |
+ )+ |
+
| 274 | ++ |
+ }+ |
+
| 275 | +6x | +
+ lyt <- lyt %>% analyze_colvars(+ |
+
| 276 | +6x | +
+ afun = a_count_patients_sum_exposure,+ |
+
| 277 | +6x | +
+ indent_mod = .indent_mods,+ |
+
| 278 | +6x | +
+ extra_args = c(+ |
+
| 279 | +6x | +
+ list(+ |
+
| 280 | +6x | +
+ var = var,+ |
+
| 281 | +6x | +
+ ex_var = ex_var,+ |
+
| 282 | +6x | +
+ add_total_level = add_total_level+ |
+
| 283 | ++ |
+ ),+ |
+
| 284 | ++ |
+ ...+ |
+
| 285 | ++ |
+ )+ |
+
| 286 | ++ |
+ )+ |
+
| 287 | +6x | +
+ lyt+ |
+
| 288 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Helper Function to create a new `SMQ` variable in `ADAE` by stacking `SMQ` and/or `CQ` records.+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Helper Function to create a new `SMQ` variable in `ADAE` that consists of all adverse events belonging to+ |
+
| 6 | ++ |
+ #' selected Standardized/Customized queries. The new dataset will only contain records of the adverse events+ |
+
| 7 | ++ |
+ #' belonging to any of the selected baskets. Remember that `na_str` must match the needed pre-processing+ |
+
| 8 | ++ |
+ #' done with [df_explicit_na()] to have the desired output.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 11 | ++ |
+ #' @param baskets (`character`)\cr variable names of the selected Standardized/Customized queries.+ |
+
| 12 | ++ |
+ #' @param smq_varlabel (`string`)\cr a label for the new variable created.+ |
+
| 13 | ++ |
+ #' @param keys (`character`)\cr names of the key variables to be returned along with the new variable created.+ |
+
| 14 | ++ |
+ #' @param aag_summary (`data.frame`)\cr containing the `SMQ` baskets and the levels of interest for the final `SMQ`+ |
+
| 15 | ++ |
+ #' variable. This is useful when there are some levels of interest that are not observed in the `df` dataset.+ |
+
| 16 | ++ |
+ #' The two columns of this dataset should be named `basket` and `basket_name`.+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @return `data.frame` with variables in `keys` taken from `df` and new variable `SMQ` containing+ |
+
| 19 | ++ |
+ #' records belonging to the baskets selected via the `baskets` argument.+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @examples+ |
+
| 22 | ++ |
+ #' adae <- tern_ex_adae[1:20, ] %>% df_explicit_na()+ |
+
| 23 | ++ |
+ #' h_stack_by_baskets(df = adae)+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' aag <- data.frame(+ |
+
| 26 | ++ |
+ #' NAMVAR = c("CQ01NAM", "CQ02NAM", "SMQ01NAM", "SMQ02NAM"),
+ |
+
| 27 | ++ |
+ #' REFNAME = c(+ |
+
| 28 | ++ |
+ #' "D.2.1.5.3/A.1.1.1.1 AESI", "X.9.9.9.9/Y.8.8.8.8 AESI",+ |
+
| 29 | ++ |
+ #' "C.1.1.1.3/B.2.2.3.1 AESI", "C.1.1.1.3/B.3.3.3.3 AESI"+ |
+
| 30 | ++ |
+ #' ),+ |
+
| 31 | ++ |
+ #' SCOPE = c("", "", "BROAD", "BROAD"),
+ |
+
| 32 | ++ |
+ #' stringsAsFactors = FALSE+ |
+
| 33 | ++ |
+ #' )+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' basket_name <- character(nrow(aag))+ |
+
| 36 | ++ |
+ #' cq_pos <- grep("^(CQ).+NAM$", aag$NAMVAR)
+ |
+
| 37 | ++ |
+ #' smq_pos <- grep("^(SMQ).+NAM$", aag$NAMVAR)
+ |
+
| 38 | ++ |
+ #' basket_name[cq_pos] <- aag$REFNAME[cq_pos]+ |
+
| 39 | ++ |
+ #' basket_name[smq_pos] <- paste0(+ |
+
| 40 | ++ |
+ #' aag$REFNAME[smq_pos], "(", aag$SCOPE[smq_pos], ")"
+ |
+
| 41 | ++ |
+ #' )+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' aag_summary <- data.frame(+ |
+
| 44 | ++ |
+ #' basket = aag$NAMVAR,+ |
+
| 45 | ++ |
+ #' basket_name = basket_name,+ |
+
| 46 | ++ |
+ #' stringsAsFactors = TRUE+ |
+
| 47 | ++ |
+ #' )+ |
+
| 48 | ++ |
+ #'+ |
+
| 49 | ++ |
+ #' result <- h_stack_by_baskets(df = adae, aag_summary = aag_summary)+ |
+
| 50 | ++ |
+ #' all(levels(aag_summary$basket_name) %in% levels(result$SMQ))+ |
+
| 51 | ++ |
+ #'+ |
+
| 52 | ++ |
+ #' h_stack_by_baskets(+ |
+
| 53 | ++ |
+ #' df = adae,+ |
+
| 54 | ++ |
+ #' aag_summary = NULL,+ |
+
| 55 | ++ |
+ #' keys = c("STUDYID", "USUBJID", "AEDECOD", "ARM"),
+ |
+
| 56 | ++ |
+ #' baskets = "SMQ01NAM"+ |
+
| 57 | ++ |
+ #' )+ |
+
| 58 | ++ |
+ #'+ |
+
| 59 | ++ |
+ #' @export+ |
+
| 60 | ++ |
+ h_stack_by_baskets <- function(df,+ |
+
| 61 | ++ |
+ baskets = grep("^(SMQ|CQ).+NAM$", names(df), value = TRUE),
+ |
+
| 62 | ++ |
+ smq_varlabel = "Standardized MedDRA Query",+ |
+
| 63 | ++ |
+ keys = c("STUDYID", "USUBJID", "ASTDTM", "AEDECOD", "AESEQ"),
+ |
+
| 64 | ++ |
+ aag_summary = NULL,+ |
+
| 65 | ++ |
+ na_level = lifecycle::deprecated(),+ |
+
| 66 | ++ |
+ na_str = "<Missing>") {
+ |
+
| 67 | +5x | +
+ if (lifecycle::is_present(na_level)) {
+ |
+
| 68 | +! | +
+ lifecycle::deprecate_warn("0.9.1", "h_stack_by_baskets(na_level)", "h_stack_by_baskets(na_str)")
+ |
+
| 69 | +! | +
+ na_str <- na_level+ |
+
| 70 | ++ |
+ }+ |
+
| 71 | ++ | + + | +
| 72 | +5x | +
+ smq_nam <- baskets[startsWith(baskets, "SMQ")]+ |
+
| 73 | ++ |
+ # SC corresponding to NAM+ |
+
| 74 | +5x | +
+ smq_sc <- gsub(pattern = "NAM", replacement = "SC", x = smq_nam, fixed = TRUE)+ |
+
| 75 | +5x | +
+ smq <- stats::setNames(smq_sc, smq_nam)+ |
+
| 76 | ++ | + + | +
| 77 | +5x | +
+ checkmate::assert_character(baskets)+ |
+
| 78 | +5x | +
+ checkmate::assert_string(smq_varlabel)+ |
+
| 79 | +5x | +
+ checkmate::assert_data_frame(df)+ |
+
| 80 | +5x | +
+ checkmate::assert_true(all(startsWith(baskets, "SMQ") | startsWith(baskets, "CQ")))+ |
+
| 81 | +4x | +
+ checkmate::assert_true(all(endsWith(baskets, "NAM")))+ |
+
| 82 | +3x | +
+ checkmate::assert_subset(baskets, names(df))+ |
+
| 83 | +3x | +
+ checkmate::assert_subset(keys, names(df))+ |
+
| 84 | +3x | +
+ checkmate::assert_subset(smq_sc, names(df))+ |
+
| 85 | +3x | +
+ checkmate::assert_string(na_str)+ |
+
| 86 | ++ | + + | +
| 87 | +3x | +
+ if (!is.null(aag_summary)) {
+ |
+
| 88 | +1x | +
+ assert_df_with_variables(+ |
+
| 89 | +1x | +
+ df = aag_summary,+ |
+
| 90 | +1x | +
+ variables = list(val = c("basket", "basket_name"))
+ |
+
| 91 | ++ |
+ )+ |
+
| 92 | ++ |
+ # Warning in case there is no match between `aag_summary$basket` and `baskets` argument.+ |
+
| 93 | ++ |
+ # Honestly, I think those should completely match. Target baskets should be the same.+ |
+
| 94 | +1x | +
+ if (length(intersect(baskets, unique(aag_summary$basket))) == 0) {
+ |
+
| 95 | +! | +
+ warning("There are 0 baskets in common between aag_summary$basket and `baskets` argument.")
+ |
+
| 96 | ++ |
+ }+ |
+
| 97 | ++ |
+ }+ |
+
| 98 | ++ | + + | +
| 99 | +3x | +
+ var_labels <- c(formatters::var_labels(df[, keys]), "SMQ" = smq_varlabel)+ |
+
| 100 | ++ | + + | +
| 101 | ++ |
+ # convert `na_str` records from baskets to NA for the later loop and from wide to long steps+ |
+
| 102 | +3x | +
+ df[, c(baskets, smq_sc)][df[, c(baskets, smq_sc)] == na_str] <- NA+ |
+
| 103 | ++ | + + | +
| 104 | +3x | +
+ if (all(is.na(df[, baskets]))) { # in case there is no level for the target baskets
+ |
+
| 105 | +1x | +
+ df_long <- df[-seq_len(nrow(df)), keys] # we just need an empty dataframe keeping all factor levels+ |
+
| 106 | ++ |
+ } else {
+ |
+
| 107 | ++ |
+ # Concatenate SMQxxxNAM with corresponding SMQxxxSC+ |
+
| 108 | +2x | +
+ df_cnct <- df[, c(keys, baskets[startsWith(baskets, "CQ")])]+ |
+
| 109 | ++ | + + | +
| 110 | +2x | +
+ for (nam in names(smq)) {
+ |
+
| 111 | +4x | +
+ sc <- smq[nam] # SMQxxxSC corresponding to SMQxxxNAM+ |
+
| 112 | +4x | +
+ nam_notna <- !is.na(df[[nam]])+ |
+
| 113 | +4x | +
+ new_colname <- paste(nam, sc, sep = "_")+ |
+
| 114 | +4x | +
+ df_cnct[nam_notna, new_colname] <- paste0(df[[nam]], "(", df[[sc]], ")")[nam_notna]
+ |
+
| 115 | ++ |
+ }+ |
+
| 116 | ++ | + + | +
| 117 | +2x | +
+ df_cnct$unique_id <- seq(1, nrow(df_cnct))+ |
+
| 118 | +2x | +
+ var_cols <- names(df_cnct)[!(names(df_cnct) %in% c(keys, "unique_id"))]+ |
+
| 119 | ++ |
+ # have to convert df_cnct from tibble to dataframe+ |
+
| 120 | ++ |
+ # as it throws a warning otherwise about rownames.+ |
+
| 121 | ++ |
+ # tibble do not support rownames and reshape creates rownames+ |
+
| 122 | ++ | + + | +
| 123 | +2x | +
+ df_long <- stats::reshape(+ |
+
| 124 | +2x | +
+ data = as.data.frame(df_cnct),+ |
+
| 125 | +2x | +
+ varying = var_cols,+ |
+
| 126 | +2x | +
+ v.names = "SMQ",+ |
+
| 127 | +2x | +
+ idvar = names(df_cnct)[names(df_cnct) %in% c(keys, "unique_id")],+ |
+
| 128 | +2x | +
+ direction = "long",+ |
+
| 129 | +2x | +
+ new.row.names = seq(prod(length(var_cols), nrow(df_cnct)))+ |
+
| 130 | ++ |
+ )+ |
+
| 131 | ++ | + + | +
| 132 | +2x | +
+ df_long <- df_long[!is.na(df_long[, "SMQ"]), !(names(df_long) %in% c("time", "unique_id"))]
+ |
+
| 133 | +2x | +
+ df_long$SMQ <- as.factor(df_long$SMQ)+ |
+
| 134 | ++ |
+ }+ |
+
| 135 | ++ | + + | +
| 136 | +3x | +
+ smq_levels <- setdiff(levels(df_long[["SMQ"]]), na_str)+ |
+
| 137 | ++ | + + | +
| 138 | +3x | +
+ if (!is.null(aag_summary)) {
+ |
+
| 139 | ++ |
+ # A warning in case there is no match between df and aag_summary records+ |
+
| 140 | +1x | +
+ if (length(intersect(smq_levels, unique(aag_summary$basket_name))) == 0) {
+ |
+
| 141 | +1x | +
+ warning("There are 0 basket levels in common between aag_summary$basket_name and df.")
+ |
+
| 142 | ++ |
+ }+ |
+
| 143 | +1x | +
+ df_long[["SMQ"]] <- factor(+ |
+
| 144 | +1x | +
+ df_long[["SMQ"]],+ |
+
| 145 | +1x | +
+ levels = sort(+ |
+
| 146 | +1x | +
+ c(+ |
+
| 147 | +1x | +
+ smq_levels,+ |
+
| 148 | +1x | +
+ setdiff(unique(aag_summary$basket_name), smq_levels)+ |
+
| 149 | ++ |
+ )+ |
+
| 150 | ++ |
+ )+ |
+
| 151 | ++ |
+ )+ |
+
| 152 | ++ |
+ } else {
+ |
+
| 153 | +2x | +
+ all_na_basket_flag <- vapply(df[, baskets], function(x) {
+ |
+
| 154 | +6x | +
+ all(is.na(x))+ |
+
| 155 | +2x | +
+ }, FUN.VALUE = logical(1))+ |
+
| 156 | +2x | +
+ all_na_basket <- baskets[all_na_basket_flag]+ |
+
| 157 | ++ | + + | +
| 158 | +2x | +
+ df_long[["SMQ"]] <- factor(+ |
+
| 159 | +2x | +
+ df_long[["SMQ"]],+ |
+
| 160 | +2x | +
+ levels = sort(c(smq_levels, all_na_basket))+ |
+
| 161 | ++ |
+ )+ |
+
| 162 | ++ |
+ }+ |
+
| 163 | +3x | +
+ formatters::var_labels(df_long) <- var_labels+ |
+
| 164 | +3x | +
+ tibble::tibble(df_long)+ |
+
| 165 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Sort Data by `PK PARAM` Variable+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @param pk_data (`data.frame`)\cr `Pharmacokinetics` dataframe+ |
+
| 6 | ++ |
+ #' @param key_var (`character`)\cr key variable used to merge pk_data and metadata created by `d_pkparam()`+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @return A PK `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 | ++ |
+ #' pk_ordered_data <- h_pkparam_sort(adpp)+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @export+ |
+
| 17 | ++ |
+ 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 | ++ | + + | +
| 21 | +4x | +
+ ordered_pk_data <- d_pkparam()+ |
+
| 22 | ++ | + + | +
| 23 | ++ |
+ # Add the numeric values from ordered_pk_data to pk_data+ |
+
| 24 | +4x | +
+ joined_data <- merge(pk_data, ordered_pk_data, by = "PARAMCD", suffix = c("", ".y"))
+ |
+
| 25 | ++ | + + | +
| 26 | +4x | +
+ joined_data <- joined_data[, -grep(".*.y$", colnames(joined_data))]
+ |
+
| 27 | ++ | + + | +
| 28 | +4x | +
+ joined_data$TLG_ORDER <- as.numeric(joined_data$TLG_ORDER)+ |
+
| 29 | ++ | + + | +
| 30 | ++ |
+ # Then order PARAM based on this column+ |
+
| 31 | +4x | +
+ joined_data$PARAM <- factor(joined_data$PARAM,+ |
+
| 32 | +4x | +
+ levels = unique(joined_data$PARAM[order(joined_data$TLG_ORDER)]),+ |
+
| 33 | +4x | +
+ ordered = TRUE+ |
+
| 34 | ++ |
+ )+ |
+
| 35 | ++ | + + | +
| 36 | +4x | +
+ 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+ |
+
| 39 | ++ |
+ )+ |
+
| 40 | ++ | + + | +
| 41 | +4x | +
+ joined_data+ |
+
| 42 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Apply 1/3 or 1/2 Imputation Rule to Data+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 6 | ++ |
+ #' @param x_stats (`named list`)\cr a named list of statistics, typically the results of [s_summary()].+ |
+
| 7 | ++ |
+ #' @param stat (`character`)\cr statistic to return the value/NA level of according to the imputation+ |
+
| 8 | ++ |
+ #' rule applied.+ |
+
| 9 | ++ |
+ #' @param imp_rule (`character`)\cr imputation rule setting. Set to `"1/3"` to implement 1/3 imputation+ |
+
| 10 | ++ |
+ #' rule or `"1/2"` to implement 1/2 imputation rule.+ |
+
| 11 | ++ |
+ #' @param post (`flag`)\cr whether the data corresponds to a post-dose time-point (defaults to `FALSE`).+ |
+
| 12 | ++ |
+ #' This parameter is only used when `imp_rule` is set to `"1/3"`.+ |
+
| 13 | ++ |
+ #' @param avalcat_var (`character`)\cr name of variable that indicates whether a row in `df` corresponds+ |
+
| 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 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @return A `list` containing statistic value (`val`) and NA level (`na_str`) that should be displayed+ |
+
| 18 | ++ |
+ #' according to the specified imputation rule.+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @seealso [analyze_vars_in_cols()] where this function can be implemented by setting the `imp_rule`+ |
+
| 21 | ++ |
+ #' argument.+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @examples+ |
+
| 24 | ++ |
+ #' set.seed(1)+ |
+
| 25 | ++ |
+ #' df <- data.frame(+ |
+
| 26 | ++ |
+ #' AVAL = runif(50, 0, 1),+ |
+
| 27 | ++ |
+ #' AVALCAT1 = sample(c(1, "BLQ"), 50, replace = TRUE)+ |
+
| 28 | ++ |
+ #' )+ |
+
| 29 | ++ |
+ #' x_stats <- s_summary(df$AVAL)+ |
+
| 30 | ++ |
+ #' imputation_rule(df, x_stats, "max", "1/3")+ |
+
| 31 | ++ |
+ #' imputation_rule(df, x_stats, "geom_mean", "1/3")+ |
+
| 32 | ++ |
+ #' imputation_rule(df, x_stats, "mean", "1/2")+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' @export+ |
+
| 35 | ++ |
+ imputation_rule <- function(df, x_stats, stat, imp_rule, post = FALSE, avalcat_var = "AVALCAT1") {
+ |
+
| 36 | +42x | +
+ checkmate::assert_choice(avalcat_var, names(df))+ |
+
| 37 | +42x | +
+ checkmate::assert_choice(imp_rule, c("1/3", "1/2"))
+ |
+
| 38 | +42x | +
+ n_blq <- sum(grepl("BLQ|LTR|<[1-9]|<PCLLOQ", df[[avalcat_var]]))
+ |
+
| 39 | +42x | +
+ ltr_blq_ratio <- n_blq / max(1, nrow(df))+ |
+
| 40 | ++ | + + | +
| 41 | ++ |
+ # defaults+ |
+
| 42 | +42x | +
+ val <- x_stats[[stat]]+ |
+
| 43 | +42x | +
+ na_str <- "NE"+ |
+
| 44 | ++ | + + | +
| 45 | +42x | +
+ if (imp_rule == "1/3") {
+ |
+
| 46 | +1x | +
+ if (!post && stat == "geom_mean") val <- NA # 1/3_pre_LT, 1/3_pre_GT+ |
+
| 47 | +41x | +
+ if (ltr_blq_ratio > 1 / 3) {
+ |
+
| 48 | +29x | +
+ if (stat != "geom_mean") na_str <- "ND" # 1/3_pre_GT, 1/3_post_GT+ |
+
| 49 | +4x | +
+ if (!post && !stat %in% c("median", "max")) val <- NA # 1/3_pre_GT
+ |
+
| 50 | +18x | +
+ if (post && !stat %in% c("median", "max", "geom_mean")) val <- NA # 1/3_post_GT
+ |
+
| 51 | ++ |
+ }+ |
+
| 52 | +1x | +
+ } else if (imp_rule == "1/2") {
+ |
+
| 53 | +1x | +
+ if (ltr_blq_ratio > 1 / 2 && !stat == "max") {
+ |
+
| 54 | +! | +
+ val <- NA # 1/2_GT+ |
+
| 55 | +! | +
+ na_str <- "ND" # 1/2_GT+ |
+
| 56 | ++ |
+ }+ |
+
| 57 | ++ |
+ }+ |
+
| 58 | ++ | + + | +
| 59 | +42x | +
+ list(val = val, na_str = na_str)+ |
+
| 60 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Tabulate Survival Duration by Subgroup+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Tabulate statistics such as median survival time and hazard ratio for population subgroups.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 8 | ++ |
+ #' @inheritParams survival_coxph_pairwise+ |
+
| 9 | ++ |
+ #' @param time_unit (`string`)\cr label with unit of median survival time. Default `NULL` skips displaying unit.+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @details These functions create a layout starting from a data frame which contains+ |
+
| 12 | ++ |
+ #' the required statistics. Tables typically used as part of forest plot.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @seealso [extract_survival_subgroups()]+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @examples+ |
+
| 17 | ++ |
+ #' library(dplyr)+ |
+
| 18 | ++ |
+ #' library(forcats)+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' adtte <- tern_ex_adtte+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' # Save variable labels before data processing steps.+ |
+
| 23 | ++ |
+ #' adtte_labels <- formatters::var_labels(adtte)+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' adtte_f <- adtte %>%+ |
+
| 26 | ++ |
+ #' filter(+ |
+
| 27 | ++ |
+ #' PARAMCD == "OS",+ |
+
| 28 | ++ |
+ #' ARM %in% c("B: Placebo", "A: Drug X"),
+ |
+
| 29 | ++ |
+ #' SEX %in% c("M", "F")
+ |
+
| 30 | ++ |
+ #' ) %>%+ |
+
| 31 | ++ |
+ #' mutate(+ |
+
| 32 | ++ |
+ #' # Reorder levels of ARM to display reference arm before treatment arm.+ |
+
| 33 | ++ |
+ #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),+ |
+
| 34 | ++ |
+ #' SEX = droplevels(SEX),+ |
+
| 35 | ++ |
+ #' AVALU = as.character(AVALU),+ |
+
| 36 | ++ |
+ #' is_event = CNSR == 0+ |
+
| 37 | ++ |
+ #' )+ |
+
| 38 | ++ |
+ #' labels <- c(+ |
+
| 39 | ++ |
+ #' "ARM" = adtte_labels[["ARM"]],+ |
+
| 40 | ++ |
+ #' "SEX" = adtte_labels[["SEX"]],+ |
+
| 41 | ++ |
+ #' "AVALU" = adtte_labels[["AVALU"]],+ |
+
| 42 | ++ |
+ #' "is_event" = "Event Flag"+ |
+
| 43 | ++ |
+ #' )+ |
+
| 44 | ++ |
+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' df <- extract_survival_subgroups(+ |
+
| 47 | ++ |
+ #' variables = list(+ |
+
| 48 | ++ |
+ #' tte = "AVAL",+ |
+
| 49 | ++ |
+ #' is_event = "is_event",+ |
+
| 50 | ++ |
+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ |
+
| 51 | ++ |
+ #' ),+ |
+
| 52 | ++ |
+ #' data = adtte_f+ |
+
| 53 | ++ |
+ #' )+ |
+
| 54 | ++ |
+ #' df+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' @name survival_duration_subgroups+ |
+
| 57 | ++ |
+ NULL+ |
+
| 58 | ++ | + + | +
| 59 | ++ |
+ #' Prepares Survival Data for Population Subgroups in Data Frames+ |
+
| 60 | ++ |
+ #'+ |
+
| 61 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 62 | ++ |
+ #'+ |
+
| 63 | ++ |
+ #' Prepares estimates of median survival times and treatment hazard ratios for population subgroups in+ |
+
| 64 | ++ |
+ #' data frames. Simple wrapper for [h_survtime_subgroups_df()] and [h_coxph_subgroups_df()]. Result is a `list`+ |
+
| 65 | ++ |
+ #' of two `data.frame`s: `survtime` and `hr`. `variables` corresponds to the names of variables found in `data`,+ |
+
| 66 | ++ |
+ #' passed as a named `list` and requires elements `tte`, `is_event`, `arm` and optionally `subgroups` and `strat`.+ |
+
| 67 | ++ |
+ #' `groups_lists` optionally specifies groupings for `subgroups` variables.+ |
+
| 68 | ++ |
+ #'+ |
+
| 69 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 70 | ++ |
+ #' @inheritParams survival_duration_subgroups+ |
+
| 71 | ++ |
+ #' @inheritParams survival_coxph_pairwise+ |
+
| 72 | ++ |
+ #'+ |
+
| 73 | ++ |
+ #' @return A named `list` of two elements:+ |
+
| 74 | ++ |
+ #' * `survtime`: A `data.frame` containing columns `arm`, `n`, `n_events`, `median`, `subgroup`, `var`,+ |
+
| 75 | ++ |
+ #' `var_label`, and `row_type`.+ |
+
| 76 | ++ |
+ #' * `hr`: A `data.frame` containing columns `arm`, `n_tot`, `n_tot_events`, `hr`, `lcl`, `ucl`, `conf_level`,+ |
+
| 77 | ++ |
+ #' `pval`, `pval_label`, `subgroup`, `var`, `var_label`, and `row_type`.+ |
+
| 78 | ++ |
+ #'+ |
+
| 79 | ++ |
+ #' @seealso [survival_duration_subgroups]+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ #' @examples+ |
+
| 82 | ++ |
+ #' library(dplyr)+ |
+
| 83 | ++ |
+ #' library(forcats)+ |
+
| 84 | ++ |
+ #'+ |
+
| 85 | ++ |
+ #' adtte <- tern_ex_adtte+ |
+
| 86 | ++ |
+ #' adtte_labels <- formatters::var_labels(adtte)+ |
+
| 87 | ++ |
+ #'+ |
+
| 88 | ++ |
+ #' adtte_f <- adtte %>%+ |
+
| 89 | ++ |
+ #' filter(+ |
+
| 90 | ++ |
+ #' PARAMCD == "OS",+ |
+
| 91 | ++ |
+ #' ARM %in% c("B: Placebo", "A: Drug X"),
+ |
+
| 92 | ++ |
+ #' SEX %in% c("M", "F")
+ |
+
| 93 | ++ |
+ #' ) %>%+ |
+
| 94 | ++ |
+ #' mutate(+ |
+
| 95 | ++ |
+ #' # Reorder levels of ARM to display reference arm before treatment arm.+ |
+
| 96 | ++ |
+ #' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),+ |
+
| 97 | ++ |
+ #' SEX = droplevels(SEX),+ |
+
| 98 | ++ |
+ #' AVALU = as.character(AVALU),+ |
+
| 99 | ++ |
+ #' is_event = CNSR == 0+ |
+
| 100 | ++ |
+ #' )+ |
+
| 101 | ++ |
+ #' labels <- c(+ |
+
| 102 | ++ |
+ #' "ARM" = adtte_labels[["ARM"]],+ |
+
| 103 | ++ |
+ #' "SEX" = adtte_labels[["SEX"]],+ |
+
| 104 | ++ |
+ #' "AVALU" = adtte_labels[["AVALU"]],+ |
+
| 105 | ++ |
+ #' "is_event" = "Event Flag"+ |
+
| 106 | ++ |
+ #' )+ |
+
| 107 | ++ |
+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ |
+
| 108 | ++ |
+ #'+ |
+
| 109 | ++ |
+ #' df <- extract_survival_subgroups(+ |
+
| 110 | ++ |
+ #' variables = list(+ |
+
| 111 | ++ |
+ #' tte = "AVAL",+ |
+
| 112 | ++ |
+ #' is_event = "is_event",+ |
+
| 113 | ++ |
+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ |
+
| 114 | ++ |
+ #' ),+ |
+
| 115 | ++ |
+ #' data = adtte_f+ |
+
| 116 | ++ |
+ #' )+ |
+
| 117 | ++ |
+ #' df+ |
+
| 118 | ++ |
+ #'+ |
+
| 119 | ++ |
+ #' df_grouped <- extract_survival_subgroups(+ |
+
| 120 | ++ |
+ #' variables = list(+ |
+
| 121 | ++ |
+ #' tte = "AVAL",+ |
+
| 122 | ++ |
+ #' is_event = "is_event",+ |
+
| 123 | ++ |
+ #' arm = "ARM", subgroups = c("SEX", "BMRKR2")
+ |
+
| 124 | ++ |
+ #' ),+ |
+
| 125 | ++ |
+ #' data = adtte_f,+ |
+
| 126 | ++ |
+ #' groups_lists = list(+ |
+
| 127 | ++ |
+ #' BMRKR2 = list(+ |
+
| 128 | ++ |
+ #' "low" = "LOW",+ |
+
| 129 | ++ |
+ #' "low/medium" = c("LOW", "MEDIUM"),
+ |
+
| 130 | ++ |
+ #' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
+ |
+
| 131 | ++ |
+ #' )+ |
+
| 132 | ++ |
+ #' )+ |
+
| 133 | ++ |
+ #' )+ |
+
| 134 | ++ |
+ #' df_grouped+ |
+
| 135 | ++ |
+ #'+ |
+
| 136 | ++ |
+ #' @export+ |
+
| 137 | ++ |
+ extract_survival_subgroups <- function(variables,+ |
+
| 138 | ++ |
+ data,+ |
+
| 139 | ++ |
+ groups_lists = list(),+ |
+
| 140 | ++ |
+ control = control_coxph(),+ |
+
| 141 | ++ |
+ label_all = "All Patients") {
+ |
+
| 142 | +8x | +
+ df_survtime <- h_survtime_subgroups_df(+ |
+
| 143 | +8x | +
+ variables,+ |
+
| 144 | +8x | +
+ data,+ |
+
| 145 | +8x | +
+ groups_lists = groups_lists,+ |
+
| 146 | +8x | +
+ label_all = label_all+ |
+
| 147 | ++ |
+ )+ |
+
| 148 | +8x | +
+ df_hr <- h_coxph_subgroups_df(+ |
+
| 149 | +8x | +
+ variables,+ |
+
| 150 | +8x | +
+ data,+ |
+
| 151 | +8x | +
+ groups_lists = groups_lists,+ |
+
| 152 | +8x | +
+ control = control,+ |
+
| 153 | +8x | +
+ label_all = label_all+ |
+
| 154 | ++ |
+ )+ |
+
| 155 | ++ | + + | +
| 156 | +8x | +
+ list(survtime = df_survtime, hr = df_hr)+ |
+
| 157 | ++ |
+ }+ |
+
| 158 | ++ | + + | +
| 159 | ++ |
+ #' @describeIn survival_duration_subgroups Formatted analysis function which is used as+ |
+
| 160 | ++ |
+ #' `afun` in `tabulate_survival_subgroups()`.+ |
+
| 161 | ++ |
+ #'+ |
+
| 162 | ++ |
+ #' @return+ |
+
| 163 | ++ |
+ #' * `a_survival_subgroups()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 164 | ++ |
+ #'+ |
+
| 165 | ++ |
+ #' @keywords internal+ |
+
| 166 | ++ |
+ a_survival_subgroups <- function(.formats = list( # nolint start+ |
+
| 167 | ++ |
+ n = "xx",+ |
+
| 168 | ++ |
+ n_events = "xx",+ |
+
| 169 | ++ |
+ n_tot_events = "xx",+ |
+
| 170 | ++ |
+ median = "xx.x",+ |
+
| 171 | ++ |
+ n_tot = "xx",+ |
+
| 172 | ++ |
+ hr = list(format_extreme_values(2L)),+ |
+
| 173 | ++ |
+ ci = list(format_extreme_values_ci(2L)),+ |
+
| 174 | ++ |
+ pval = "x.xxxx | (<0.0001)"+ |
+
| 175 | ++ |
+ )) { # nolint end
+ |
+
| 176 | +12x | +
+ checkmate::assert_list(.formats)+ |
+
| 177 | +12x | +
+ checkmate::assert_subset(+ |
+
| 178 | +12x | +
+ names(.formats),+ |
+
| 179 | +12x | +
+ c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
+ |
+
| 180 | ++ |
+ )+ |
+
| 181 | ++ | + + | +
| 182 | +12x | +
+ afun_lst <- Map(+ |
+
| 183 | +12x | +
+ function(stat, fmt) {
+ |
+
| 184 | +90x | +
+ if (stat == "ci") {
+ |
+
| 185 | +11x | +
+ function(df, labelstr = "", ...) {
+ |
+
| 186 | +20x | +
+ in_rows(+ |
+
| 187 | +20x | +
+ .list = combine_vectors(df$lcl, df$ucl),+ |
+
| 188 | +20x | +
+ .labels = as.character(df$subgroup),+ |
+
| 189 | +20x | +
+ .formats = fmt+ |
+
| 190 | ++ |
+ )+ |
+
| 191 | ++ |
+ }+ |
+
| 192 | ++ |
+ } else {
+ |
+
| 193 | +79x | +
+ function(df, labelstr = "", ...) {
+ |
+
| 194 | +111x | +
+ in_rows(+ |
+
| 195 | +111x | +
+ .list = as.list(df[[stat]]),+ |
+
| 196 | +111x | +
+ .labels = as.character(df$subgroup),+ |
+
| 197 | +111x | +
+ .formats = fmt+ |
+
| 198 | ++ |
+ )+ |
+
| 199 | ++ |
+ }+ |
+
| 200 | ++ |
+ }+ |
+
| 201 | ++ |
+ },+ |
+
| 202 | +12x | +
+ stat = names(.formats),+ |
+
| 203 | +12x | +
+ fmt = .formats+ |
+
| 204 | ++ |
+ )+ |
+
| 205 | ++ | + + | +
| 206 | +12x | +
+ afun_lst+ |
+
| 207 | ++ |
+ }+ |
+
| 208 | ++ | + + | +
| 209 | ++ |
+ #' @describeIn survival_duration_subgroups Table-creating function which creates a table+ |
+
| 210 | ++ |
+ #' summarizing survival by subgroup. This function is a wrapper for [rtables::analyze_colvars()]+ |
+
| 211 | ++ |
+ #' and [rtables::summarize_row_groups()].+ |
+
| 212 | ++ |
+ #'+ |
+
| 213 | ++ |
+ #' @param df (`list`)\cr of data frames containing all analysis variables. List should be+ |
+
| 214 | ++ |
+ #' created using [extract_survival_subgroups()].+ |
+
| 215 | ++ |
+ #' @param vars (`character`)\cr the name of statistics to be reported among:+ |
+
| 216 | ++ |
+ #' * `n_tot_events`: Total number of events per group.+ |
+
| 217 | ++ |
+ #' * `n_events`: Number of events per group.+ |
+
| 218 | ++ |
+ #' * `n_tot`: Total number of observations per group.+ |
+
| 219 | ++ |
+ #' * `n`: Number of observations per group.+ |
+
| 220 | ++ |
+ #' * `median`: Median survival time.+ |
+
| 221 | ++ |
+ #' * `hr`: Hazard ratio.+ |
+
| 222 | ++ |
+ #' * `ci`: Confidence interval of hazard ratio.+ |
+
| 223 | ++ |
+ #' * `pval`: p-value of the effect.+ |
+
| 224 | ++ |
+ #' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci`+ |
+
| 225 | ++ |
+ #' are required.+ |
+
| 226 | ++ |
+ #'+ |
+
| 227 | ++ |
+ #' @return An `rtables` table summarizing survival by subgroup.+ |
+
| 228 | ++ |
+ #'+ |
+
| 229 | ++ |
+ #' @examples+ |
+
| 230 | ++ |
+ #' ## Table with default columns.+ |
+
| 231 | ++ |
+ #' basic_table() %>%+ |
+
| 232 | ++ |
+ #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1])+ |
+
| 233 | ++ |
+ #'+ |
+
| 234 | ++ |
+ #' ## Table with a manually chosen set of columns: adding "pval".+ |
+
| 235 | ++ |
+ #' basic_table() %>%+ |
+
| 236 | ++ |
+ #' tabulate_survival_subgroups(+ |
+
| 237 | ++ |
+ #' df = df,+ |
+
| 238 | ++ |
+ #' vars = c("n_tot_events", "n_events", "median", "hr", "ci", "pval"),
+ |
+
| 239 | ++ |
+ #' time_unit = adtte_f$AVALU[1]+ |
+
| 240 | ++ |
+ #' )+ |
+
| 241 | ++ |
+ #'+ |
+
| 242 | ++ |
+ #' @export+ |
+
| 243 | ++ |
+ tabulate_survival_subgroups <- function(lyt,+ |
+
| 244 | ++ |
+ df,+ |
+
| 245 | ++ |
+ vars = c("n_tot_events", "n_events", "median", "hr", "ci"),
+ |
+
| 246 | ++ |
+ time_unit = NULL,+ |
+
| 247 | ++ |
+ na_str = NA_character_) {
+ |
+
| 248 | +5x | +
+ conf_level <- df$hr$conf_level[1]+ |
+
| 249 | +5x | +
+ method <- df$hr$pval_label[1]+ |
+
| 250 | ++ | + + | +
| 251 | +5x | +
+ afun_lst <- a_survival_subgroups()+ |
+
| 252 | +5x | +
+ colvars <- d_survival_subgroups_colvars(+ |
+
| 253 | +5x | +
+ vars,+ |
+
| 254 | +5x | +
+ conf_level = conf_level,+ |
+
| 255 | +5x | +
+ method = method,+ |
+
| 256 | +5x | +
+ time_unit = time_unit+ |
+
| 257 | ++ |
+ )+ |
+
| 258 | ++ | + + | +
| 259 | +5x | +
+ colvars_survtime <- list(+ |
+
| 260 | +5x | +
+ vars = colvars$vars[names(colvars$labels) %in% c("n", "n_events", "median")],
+ |
+
| 261 | +5x | +
+ labels = colvars$labels[names(colvars$labels) %in% c("n", "n_events", "median")]
+ |
+
| 262 | ++ |
+ )+ |
+
| 263 | +5x | +
+ colvars_hr <- list(+ |
+
| 264 | +5x | +
+ vars = colvars$vars[names(colvars$labels) %in% c("n_tot", "n_tot_events", "hr", "ci", "pval")],
+ |
+
| 265 | +5x | +
+ labels = colvars$labels[names(colvars$labels) %in% c("n_tot", "n_tot_events", "hr", "ci", "pval")]
+ |
+
| 266 | ++ |
+ )+ |
+
| 267 | ++ | + + | +
| 268 | ++ |
+ # Columns from table_survtime are optional.+ |
+
| 269 | +5x | +
+ if (length(colvars_survtime$vars) > 0) {
+ |
+
| 270 | +4x | +
+ lyt_survtime <- split_cols_by(lyt = lyt, var = "arm")+ |
+
| 271 | +4x | +
+ lyt_survtime <- split_rows_by(+ |
+
| 272 | +4x | +
+ lyt = lyt_survtime,+ |
+
| 273 | +4x | +
+ var = "row_type",+ |
+
| 274 | +4x | +
+ split_fun = keep_split_levels("content"),
+ |
+
| 275 | +4x | +
+ nested = FALSE+ |
+
| 276 | ++ |
+ )+ |
+
| 277 | +4x | +
+ lyt_survtime <- summarize_row_groups(+ |
+
| 278 | +4x | +
+ lyt = lyt_survtime,+ |
+
| 279 | +4x | +
+ var = "var_label",+ |
+
| 280 | +4x | +
+ cfun = afun_lst[names(colvars_survtime$labels)],+ |
+
| 281 | +4x | +
+ na_str = na_str+ |
+
| 282 | ++ |
+ )+ |
+
| 283 | +4x | +
+ lyt_survtime <- split_cols_by_multivar(+ |
+
| 284 | +4x | +
+ lyt = lyt_survtime,+ |
+
| 285 | +4x | +
+ vars = colvars_survtime$vars,+ |
+
| 286 | +4x | +
+ varlabels = colvars_survtime$labels+ |
+
| 287 | ++ |
+ )+ |
+
| 288 | ++ | + + | +
| 289 | +4x | +
+ if ("analysis" %in% df$survtime$row_type) {
+ |
+
| 290 | +3x | +
+ lyt_survtime <- split_rows_by(+ |
+
| 291 | +3x | +
+ lyt = lyt_survtime,+ |
+
| 292 | +3x | +
+ var = "row_type",+ |
+
| 293 | +3x | +
+ split_fun = keep_split_levels("analysis"),
+ |
+
| 294 | +3x | +
+ nested = FALSE,+ |
+
| 295 | +3x | +
+ child_labels = "hidden"+ |
+
| 296 | ++ |
+ )+ |
+
| 297 | +3x | +
+ lyt_survtime <- split_rows_by(lyt = lyt_survtime, var = "var_label", nested = TRUE)+ |
+
| 298 | +3x | +
+ lyt_survtime <- analyze_colvars(+ |
+
| 299 | +3x | +
+ lyt = lyt_survtime,+ |
+
| 300 | +3x | +
+ afun = afun_lst[names(colvars_survtime$labels)],+ |
+
| 301 | +3x | +
+ inclNAs = TRUE+ |
+
| 302 | ++ |
+ )+ |
+
| 303 | ++ |
+ }+ |
+
| 304 | ++ | + + | +
| 305 | +4x | +
+ table_survtime <- build_table(lyt_survtime, df = df$survtime)+ |
+
| 306 | ++ |
+ } else {
+ |
+
| 307 | +1x | +
+ table_survtime <- NULL+ |
+
| 308 | ++ |
+ }+ |
+
| 309 | ++ | + + | +
| 310 | ++ |
+ # Columns "n_tot_events" or "n_tot", and "hr", "ci" in table_hr are required.+ |
+
| 311 | +5x | +
+ lyt_hr <- split_cols_by(lyt = lyt, var = "arm")+ |
+
| 312 | +5x | +
+ lyt_hr <- split_rows_by(+ |
+
| 313 | +5x | +
+ lyt = lyt_hr,+ |
+
| 314 | +5x | +
+ var = "row_type",+ |
+
| 315 | +5x | +
+ split_fun = keep_split_levels("content"),
+ |
+
| 316 | +5x | +
+ nested = FALSE+ |
+
| 317 | ++ |
+ )+ |
+
| 318 | +5x | +
+ lyt_hr <- summarize_row_groups(+ |
+
| 319 | +5x | +
+ lyt = lyt_hr,+ |
+
| 320 | +5x | +
+ var = "var_label",+ |
+
| 321 | +5x | +
+ cfun = afun_lst[names(colvars_hr$labels)],+ |
+
| 322 | +5x | +
+ na_str = na_str+ |
+
| 323 | ++ |
+ )+ |
+
| 324 | +5x | +
+ lyt_hr <- split_cols_by_multivar(+ |
+
| 325 | +5x | +
+ lyt = lyt_hr,+ |
+
| 326 | +5x | +
+ vars = colvars_hr$vars,+ |
+
| 327 | +5x | +
+ varlabels = colvars_hr$labels+ |
+
| 328 | ++ |
+ ) %>%+ |
+
| 329 | +5x | +
+ append_topleft("Baseline Risk Factors")
+ |
+
| 330 | ++ | + + | +
| 331 | +5x | +
+ if ("analysis" %in% df$survtime$row_type) {
+ |
+
| 332 | +4x | +
+ lyt_hr <- split_rows_by(+ |
+
| 333 | +4x | +
+ lyt = lyt_hr,+ |
+
| 334 | +4x | +
+ var = "row_type",+ |
+
| 335 | +4x | +
+ split_fun = keep_split_levels("analysis"),
+ |
+
| 336 | +4x | +
+ nested = FALSE,+ |
+
| 337 | +4x | +
+ child_labels = "hidden"+ |
+
| 338 | ++ |
+ )+ |
+
| 339 | +4x | +
+ lyt_hr <- split_rows_by(lyt = lyt_hr, var = "var_label", nested = TRUE)+ |
+
| 340 | +4x | +
+ lyt_hr <- analyze_colvars(+ |
+
| 341 | +4x | +
+ lyt = lyt_hr,+ |
+
| 342 | +4x | +
+ afun = afun_lst[names(colvars_hr$labels)],+ |
+
| 343 | +4x | +
+ inclNAs = TRUE+ |
+
| 344 | ++ |
+ )+ |
+
| 345 | ++ |
+ }+ |
+
| 346 | +5x | +
+ table_hr <- build_table(lyt_hr, df = df$hr)+ |
+
| 347 | ++ | + + | +
| 348 | ++ |
+ # There can be one or two vars starting with "n_tot".+ |
+
| 349 | +5x | +
+ n_tot_ids <- grep("^n_tot", colvars_hr$vars)
+ |
+
| 350 | +5x | +
+ if (is.null(table_survtime)) {
+ |
+
| 351 | +1x | +
+ result <- table_hr+ |
+
| 352 | +1x | +
+ hr_id <- match("hr", colvars_hr$vars)
+ |
+
| 353 | +1x | +
+ ci_id <- match("lcl", colvars_hr$vars)
+ |
+
| 354 | ++ |
+ } else {
+ |
+
| 355 | ++ |
+ # Reorder the table.+ |
+
| 356 | +4x | +
+ result <- cbind_rtables(table_hr[, n_tot_ids], table_survtime, table_hr[, -n_tot_ids])+ |
+
| 357 | ++ |
+ # And then calculate column indices accordingly.+ |
+
| 358 | +4x | +
+ hr_id <- length(n_tot_ids) + ncol(table_survtime) + match("hr", colvars_hr$vars[-n_tot_ids])
+ |
+
| 359 | +4x | +
+ ci_id <- length(n_tot_ids) + ncol(table_survtime) + match("lcl", colvars_hr$vars[-n_tot_ids])
+ |
+
| 360 | +4x | +
+ n_tot_ids <- seq_along(n_tot_ids)+ |
+
| 361 | ++ |
+ }+ |
+
| 362 | ++ | + + | +
| 363 | +5x | +
+ structure(+ |
+
| 364 | +5x | +
+ result,+ |
+
| 365 | +5x | +
+ forest_header = paste0(rev(levels(df$survtime$arm)), "\nBetter"),+ |
+
| 366 | +5x | +
+ col_x = hr_id,+ |
+
| 367 | +5x | +
+ col_ci = ci_id,+ |
+
| 368 | ++ |
+ # Take the first one for scaling the symbol sizes in graph.+ |
+
| 369 | +5x | +
+ col_symbol_size = n_tot_ids[1]+ |
+
| 370 | ++ |
+ )+ |
+
| 371 | ++ |
+ }+ |
+
| 372 | ++ | + + | +
| 373 | ++ |
+ #' Labels for Column Variables in Survival Duration by Subgroup Table+ |
+
| 374 | ++ |
+ #'+ |
+
| 375 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 376 | ++ |
+ #'+ |
+
| 377 | ++ |
+ #' Internal function to check variables included in [tabulate_survival_subgroups()] and create column labels.+ |
+
| 378 | ++ |
+ #'+ |
+
| 379 | ++ |
+ #' @inheritParams tabulate_survival_subgroups+ |
+
| 380 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 381 | ++ |
+ #' @param method (`character`)\cr p-value method for testing hazard ratio = 1.+ |
+
| 382 | ++ |
+ #'+ |
+
| 383 | ++ |
+ #' @return A `list` of variables and their labels to tabulate.+ |
+
| 384 | ++ |
+ #'+ |
+
| 385 | ++ |
+ #' @note At least one of `n_tot` and `n_tot_events` must be provided in `vars`.+ |
+
| 386 | ++ |
+ #'+ |
+
| 387 | ++ |
+ #' @export+ |
+
| 388 | ++ |
+ d_survival_subgroups_colvars <- function(vars,+ |
+
| 389 | ++ |
+ conf_level,+ |
+
| 390 | ++ |
+ method,+ |
+
| 391 | ++ |
+ time_unit = NULL) {
+ |
+
| 392 | +12x | +
+ checkmate::assert_character(vars)+ |
+
| 393 | +12x | +
+ checkmate::assert_string(time_unit, null.ok = TRUE)+ |
+
| 394 | +12x | +
+ checkmate::assert_subset(c("hr", "ci"), vars)
+ |
+
| 395 | +12x | +
+ checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
+ |
+
| 396 | +12x | +
+ checkmate::assert_subset(+ |
+
| 397 | +12x | +
+ vars,+ |
+
| 398 | +12x | +
+ c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
+ |
+
| 399 | ++ |
+ )+ |
+
| 400 | ++ | + + | +
| 401 | +12x | +
+ propcase_time_label <- if (!is.null(time_unit)) {
+ |
+
| 402 | +11x | +
+ paste0("Median (", time_unit, ")")
+ |
+
| 403 | ++ |
+ } else {
+ |
+
| 404 | +1x | +
+ "Median"+ |
+
| 405 | ++ |
+ }+ |
+
| 406 | ++ | + + | +
| 407 | +12x | +
+ varlabels <- c(+ |
+
| 408 | +12x | +
+ n = "n",+ |
+
| 409 | +12x | +
+ n_events = "Events",+ |
+
| 410 | +12x | +
+ median = propcase_time_label,+ |
+
| 411 | +12x | +
+ n_tot = "Total n",+ |
+
| 412 | +12x | +
+ n_tot_events = "Total Events",+ |
+
| 413 | +12x | +
+ hr = "Hazard Ratio",+ |
+
| 414 | +12x | +
+ ci = paste0(100 * conf_level, "% Wald CI"),+ |
+
| 415 | +12x | +
+ pval = method+ |
+
| 416 | ++ |
+ )+ |
+
| 417 | ++ | + + | +
| 418 | +12x | +
+ colvars <- vars+ |
+
| 419 | ++ | + + | +
| 420 | ++ |
+ # The `lcl` variable is just a placeholder available in the analysis data,+ |
+
| 421 | ++ |
+ # it is not acutally used in the tabulation.+ |
+
| 422 | ++ |
+ # Variables used in the tabulation are lcl and ucl, see `a_survival_subgroups` for details.+ |
+
| 423 | +12x | +
+ colvars[colvars == "ci"] <- "lcl"+ |
+
| 424 | ++ | + + | +
| 425 | +12x | +
+ list(+ |
+
| 426 | +12x | +
+ vars = colvars,+ |
+
| 427 | +12x | +
+ labels = varlabels[vars]+ |
+
| 428 | ++ |
+ )+ |
+
| 429 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Control Function for Subgroup Treatment Effect Pattern (STEP) Calculations+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' This is an auxiliary function for controlling arguments for STEP calculations.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param biomarker (`numeric` or `NULL`)\cr optional provision of the numeric biomarker variable, which+ |
+
| 8 | ++ |
+ #' could be used to infer `bandwidth`, see below.+ |
+
| 9 | ++ |
+ #' @param use_percentile (`flag`)\cr if `TRUE`, the running windows are created according to+ |
+
| 10 | ++ |
+ #' quantiles rather than actual values, i.e. the bandwidth refers to the percentage of data+ |
+
| 11 | ++ |
+ #' covered in each window. Suggest `TRUE` if the biomarker variable is not uniformly+ |
+
| 12 | ++ |
+ #' distributed.+ |
+
| 13 | ++ |
+ #' @param bandwidth (`number` or `NULL`)\cr indicating the bandwidth of each window.+ |
+
| 14 | ++ |
+ #' Depending on the argument `use_percentile`, it can be either the length of actual-value+ |
+
| 15 | ++ |
+ #' windows on the real biomarker scale, or percentage windows.+ |
+
| 16 | ++ |
+ #' If `use_percentile = TRUE`, it should be a number between 0 and 1.+ |
+
| 17 | ++ |
+ #' If `NULL`, treat the bandwidth to be infinity, which means only one global model will be fitted.+ |
+
| 18 | ++ |
+ #' By default, `0.25` is used for percentage windows and one quarter of the range of the `biomarker`+ |
+
| 19 | ++ |
+ #' variable for actual-value windows.+ |
+
| 20 | ++ |
+ #' @param degree (`count`)\cr the degree of polynomial function of the biomarker as an interaction term+ |
+
| 21 | ++ |
+ #' with the treatment arm fitted at each window. If 0 (default), then the biomarker variable+ |
+
| 22 | ++ |
+ #' is not included in the model fitted in each biomarker window.+ |
+
| 23 | ++ |
+ #' @param num_points (`count`)\cr the number of points at which the hazard ratios are estimated. The+ |
+
| 24 | ++ |
+ #' smallest number is 2.+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' @return A list of components with the same names as the arguments, except `biomarker` which is+ |
+
| 27 | ++ |
+ #' just used to calculate the `bandwidth` in case that actual biomarker windows are requested.+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @examples+ |
+
| 30 | ++ |
+ #' # Provide biomarker values and request actual values to be used,+ |
+
| 31 | ++ |
+ #' # so that bandwidth is chosen from range.+ |
+
| 32 | ++ |
+ #' control_step(biomarker = 1:10, use_percentile = FALSE)+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' # Use a global model with quadratic biomarker interaction term.+ |
+
| 35 | ++ |
+ #' control_step(bandwidth = NULL, degree = 2)+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' # Reduce number of points to be used.+ |
+
| 38 | ++ |
+ #' control_step(num_points = 10)+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' @export+ |
+
| 41 | ++ |
+ control_step <- function(biomarker = NULL,+ |
+
| 42 | ++ |
+ use_percentile = TRUE,+ |
+
| 43 | ++ |
+ bandwidth,+ |
+
| 44 | ++ |
+ degree = 0L,+ |
+
| 45 | ++ |
+ 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)+ |
+
| 50 | ++ | + + | +
| 51 | +29x | +
+ if (missing(bandwidth)) {
+ |
+
| 52 | ++ |
+ # 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 | ++ |
+ } else {
+ |
+
| 58 | +! | +
+ NULL+ |
+
| 59 | ++ |
+ }+ |
+
| 60 | ++ |
+ } else {
+ |
+
| 61 | ++ |
+ # Check bandwidth+ |
+
| 62 | +8x | +
+ if (!is.null(bandwidth)) {
+ |
+
| 63 | +5x | +
+ if (use_percentile) {
+ |
+
| 64 | +4x | +
+ assert_proportion_value(bandwidth)+ |
+
| 65 | ++ |
+ } else {
+ |
+
| 66 | +1x | +
+ checkmate::assert_scalar(bandwidth)+ |
+
| 67 | +1x | +
+ checkmate::assert_true(bandwidth > 0)+ |
+
| 68 | ++ |
+ }+ |
+
| 69 | ++ |
+ }+ |
+
| 70 | ++ |
+ }+ |
+
| 71 | +28x | +
+ list(+ |
+
| 72 | +28x | +
+ use_percentile = use_percentile,+ |
+
| 73 | +28x | +
+ bandwidth = bandwidth,+ |
+
| 74 | +28x | +
+ degree = as.integer(degree),+ |
+
| 75 | +28x | +
+ num_points = as.integer(num_points)+ |
+
| 76 | ++ |
+ )+ |
+
| 77 | ++ |
+ }+ |
+
| 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 | +28x | +
+ checkmate::assert_true(grepl("response", response_definition))
+ |
+
| 31 | +27x | +
+ checkmate::assert_string(response_definition)+ |
+
| 32 | +27x | +
+ assert_proportion_value(conf_level)+ |
+
| 33 | +26x | +
+ list(+ |
+
| 34 | +26x | +
+ response_definition = response_definition,+ |
+
| 35 | +26x | +
+ conf_level = conf_level+ |
+
| 36 | ++ |
+ )+ |
+
| 37 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Survival Time Analysis+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Summarize median survival time and CIs, percentiles of survival times, survival+ |
+
| 6 | ++ |
+ #' time range of censored/event patients.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #' @param control (`list`)\cr parameters for comparison details, specified by using the helper function+ |
+
| 10 | ++ |
+ #' [control_surv_time()]. Some possible parameter options are:+ |
+
| 11 | ++ |
+ #' * `conf_level` (`proportion`)\cr confidence level of the interval for survival time.+ |
+
| 12 | ++ |
+ #' * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", or "log-log",+ |
+
| 13 | ++ |
+ #' see more in [survival::survfit()]. Note option "none" is not supported.+ |
+
| 14 | ++ |
+ #' * `quantiles` (`numeric`)\cr vector of length two to specify the quantiles of survival time.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @name survival_time+ |
+
| 17 | ++ |
+ NULL+ |
+
| 18 | ++ | + + | +
| 19 | ++ |
+ #' @describeIn survival_time Statistics function which analyzes survival times.+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @return+ |
+
| 22 | ++ |
+ #' * `s_surv_time()` returns the statistics:+ |
+
| 23 | ++ |
+ #' * `median`: Median survival time.+ |
+
| 24 | ++ |
+ #' * `median_ci`: Confidence interval for median time.+ |
+
| 25 | ++ |
+ #' * `quantiles`: Survival time for two specified quantiles.+ |
+
| 26 | ++ |
+ #' * `range_censor`: Survival time range for censored observations.+ |
+
| 27 | ++ |
+ #' * `range_event`: Survival time range for observations with events.+ |
+
| 28 | ++ |
+ #' * `range`: Survival time range for all observations.+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' @examples+ |
+
| 31 | ++ |
+ #' library(dplyr)+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' adtte_f <- tern_ex_adtte %>%+ |
+
| 34 | ++ |
+ #' filter(PARAMCD == "OS") %>%+ |
+
| 35 | ++ |
+ #' mutate(+ |
+
| 36 | ++ |
+ #' AVAL = day2month(AVAL),+ |
+
| 37 | ++ |
+ #' is_event = CNSR == 0+ |
+
| 38 | ++ |
+ #' )+ |
+
| 39 | ++ |
+ #' df <- adtte_f %>% filter(ARMCD == "ARM A")+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' @keywords internal+ |
+
| 42 | ++ |
+ s_surv_time <- function(df,+ |
+
| 43 | ++ |
+ .var,+ |
+
| 44 | ++ |
+ is_event,+ |
+
| 45 | ++ |
+ control = control_surv_time()) {
+ |
+
| 46 | +146x | +
+ checkmate::assert_string(.var)+ |
+
| 47 | +146x | +
+ assert_df_with_variables(df, list(tte = .var, is_event = is_event))+ |
+
| 48 | +146x | +
+ checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE)+ |
+
| 49 | +146x | +
+ checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)+ |
+
| 50 | ++ | + + | +
| 51 | +146x | +
+ conf_type <- control$conf_type+ |
+
| 52 | +146x | +
+ conf_level <- control$conf_level+ |
+
| 53 | +146x | +
+ quantiles <- control$quantiles+ |
+
| 54 | ++ | + + | +
| 55 | +146x | +
+ formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
+ |
+
| 56 | +146x | +
+ srv_fit <- survival::survfit(+ |
+
| 57 | +146x | +
+ formula = formula,+ |
+
| 58 | +146x | +
+ data = df,+ |
+
| 59 | +146x | +
+ conf.int = conf_level,+ |
+
| 60 | +146x | +
+ conf.type = conf_type+ |
+
| 61 | ++ |
+ )+ |
+
| 62 | +146x | +
+ srv_tab <- summary(srv_fit, extend = TRUE)$table+ |
+
| 63 | +146x | +
+ srv_qt_tab <- stats::quantile(srv_fit, probs = quantiles)$quantile+ |
+
| 64 | +146x | +
+ range_censor <- range_noinf(df[[.var]][!df[[is_event]]], na.rm = TRUE)+ |
+
| 65 | +146x | +
+ range_event <- range_noinf(df[[.var]][df[[is_event]]], na.rm = TRUE)+ |
+
| 66 | +146x | +
+ range <- range_noinf(df[[.var]], na.rm = TRUE)+ |
+
| 67 | +146x | +
+ list(+ |
+
| 68 | +146x | +
+ median = formatters::with_label(unname(srv_tab["median"]), "Median"),+ |
+
| 69 | +146x | +
+ median_ci = formatters::with_label(+ |
+
| 70 | +146x | +
+ unname(srv_tab[paste0(srv_fit$conf.int, c("LCL", "UCL"))]), f_conf_level(conf_level)
+ |
+
| 71 | ++ |
+ ),+ |
+
| 72 | +146x | +
+ quantiles = formatters::with_label(+ |
+
| 73 | +146x | +
+ unname(srv_qt_tab), paste0(quantiles[1] * 100, "% and ", quantiles[2] * 100, "%-ile")+ |
+
| 74 | ++ |
+ ),+ |
+
| 75 | +146x | +
+ range_censor = formatters::with_label(range_censor, "Range (censored)"),+ |
+
| 76 | +146x | +
+ range_event = formatters::with_label(range_event, "Range (event)"),+ |
+
| 77 | +146x | +
+ range = formatters::with_label(range, "Range")+ |
+
| 78 | ++ |
+ )+ |
+
| 79 | ++ |
+ }+ |
+
| 80 | ++ | + + | +
| 81 | ++ |
+ #' @describeIn survival_time Formatted analysis function which is used as `afun` in `surv_time()`.+ |
+
| 82 | ++ |
+ #'+ |
+
| 83 | ++ |
+ #' @return+ |
+
| 84 | ++ |
+ #' * `a_surv_time()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 85 | ++ |
+ #'+ |
+
| 86 | ++ |
+ #' @keywords internal+ |
+
| 87 | ++ |
+ a_surv_time <- make_afun(+ |
+
| 88 | ++ |
+ s_surv_time,+ |
+
| 89 | ++ |
+ .formats = c(+ |
+
| 90 | ++ |
+ "median" = "xx.x",+ |
+
| 91 | ++ |
+ "median_ci" = "(xx.x, xx.x)",+ |
+
| 92 | ++ |
+ "quantiles" = "xx.x, xx.x",+ |
+
| 93 | ++ |
+ "range_censor" = "xx.x to xx.x",+ |
+
| 94 | ++ |
+ "range_event" = "xx.x to xx.x",+ |
+
| 95 | ++ |
+ "range" = "xx.x to xx.x"+ |
+
| 96 | ++ |
+ )+ |
+
| 97 | ++ |
+ )+ |
+
| 98 | ++ | + + | +
| 99 | ++ |
+ #' @describeIn survival_time Layout-creating function which can take statistics function arguments+ |
+
| 100 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 101 | ++ |
+ #'+ |
+
| 102 | ++ |
+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ |
+
| 103 | ++ |
+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ |
+
| 104 | ++ |
+ #' for that statistic's row label.+ |
+
| 105 | ++ |
+ #'+ |
+
| 106 | ++ |
+ #' @return+ |
+
| 107 | ++ |
+ #' * `surv_time()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 108 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 109 | ++ |
+ #' the statistics from `s_surv_time()` to the table layout.+ |
+
| 110 | ++ |
+ #'+ |
+
| 111 | ++ |
+ #' @examples+ |
+
| 112 | ++ |
+ #' basic_table() %>%+ |
+
| 113 | ++ |
+ #' split_cols_by(var = "ARMCD") %>%+ |
+
| 114 | ++ |
+ #' add_colcounts() %>%+ |
+
| 115 | ++ |
+ #' surv_time(+ |
+
| 116 | ++ |
+ #' vars = "AVAL",+ |
+
| 117 | ++ |
+ #' var_labels = "Survival Time (Months)",+ |
+
| 118 | ++ |
+ #' is_event = "is_event",+ |
+
| 119 | ++ |
+ #' control = control_surv_time(conf_level = 0.9, conf_type = "log-log")+ |
+
| 120 | ++ |
+ #' ) %>%+ |
+
| 121 | ++ |
+ #' build_table(df = adtte_f)+ |
+
| 122 | ++ |
+ #'+ |
+
| 123 | ++ |
+ #' @export+ |
+
| 124 | ++ |
+ surv_time <- function(lyt,+ |
+
| 125 | ++ |
+ vars,+ |
+
| 126 | ++ |
+ na_str = NA_character_,+ |
+
| 127 | ++ |
+ nested = TRUE,+ |
+
| 128 | ++ |
+ ...,+ |
+
| 129 | ++ |
+ var_labels = "Time to Event",+ |
+
| 130 | ++ |
+ table_names = vars,+ |
+
| 131 | ++ |
+ .stats = c("median", "median_ci", "quantiles", "range_censor", "range_event"),
+ |
+
| 132 | ++ |
+ .formats = NULL,+ |
+
| 133 | ++ |
+ .labels = NULL,+ |
+
| 134 | ++ |
+ .indent_mods = c(+ |
+
| 135 | ++ |
+ "median" = 0L, "median_ci" = 1L, "quantiles" = 0L,+ |
+
| 136 | ++ |
+ "range_censor" = 0L, "range_event" = 0L, "range" = 0L+ |
+
| 137 | ++ |
+ )) {
+ |
+
| 138 | +2x | +
+ afun <- make_afun(+ |
+
| 139 | +2x | +
+ a_surv_time,+ |
+
| 140 | +2x | +
+ .stats = .stats,+ |
+
| 141 | +2x | +
+ .formats = .formats,+ |
+
| 142 | +2x | +
+ .labels = .labels,+ |
+
| 143 | +2x | +
+ .indent_mods = extract_by_name(.indent_mods, .stats)+ |
+
| 144 | ++ |
+ )+ |
+
| 145 | +2x | +
+ analyze(+ |
+
| 146 | +2x | +
+ lyt,+ |
+
| 147 | +2x | +
+ vars,+ |
+
| 148 | +2x | +
+ na_str = na_str,+ |
+
| 149 | +2x | +
+ nested = nested,+ |
+
| 150 | +2x | +
+ var_labels = var_labels,+ |
+
| 151 | +2x | +
+ show_labels = "visible",+ |
+
| 152 | +2x | +
+ table_names = table_names,+ |
+
| 153 | +2x | +
+ afun = afun,+ |
+
| 154 | +2x | +
+ extra_args = list(...)+ |
+
| 155 | ++ |
+ )+ |
+
| 156 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Counting Specific Values+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' We can count the occurrence of specific values in a variable of interest.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @note+ |
+
| 10 | ++ |
+ #' * For `factor` variables, `s_count_values` checks whether `values` are all included in the levels of `x`+ |
+
| 11 | ++ |
+ #' and fails otherwise.+ |
+
| 12 | ++ |
+ #' * For `count_values()`, variable labels are shown when there is more than one element in `vars`,+ |
+
| 13 | ++ |
+ #' otherwise they are hidden.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @name count_values_funs+ |
+
| 16 | ++ |
+ NULL+ |
+
| 17 | ++ | + + | +
| 18 | ++ |
+ #' @describeIn count_values_funs S3 generic function to count values.+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @inheritParams s_summary.logical+ |
+
| 21 | ++ |
+ #' @param values (`character`)\cr specific values that should be counted.+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @return+ |
+
| 24 | ++ |
+ #' * `s_count_values()` returns output of [s_summary()] for specified values of a non-numeric variable.+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' @export+ |
+
| 27 | ++ |
+ s_count_values <- function(x,+ |
+
| 28 | ++ |
+ values,+ |
+
| 29 | ++ |
+ na.rm = TRUE, # nolint+ |
+
| 30 | ++ |
+ .N_col, # nolint+ |
+
| 31 | ++ |
+ .N_row, # nolint+ |
+
| 32 | ++ |
+ denom = c("n", "N_row", "N_col")) {
+ |
+
| 33 | +110x | +
+ UseMethod("s_count_values", x)
+ |
+
| 34 | ++ |
+ }+ |
+
| 35 | ++ | + + | +
| 36 | ++ |
+ #' @describeIn count_values_funs Method for `character` class.+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' @method s_count_values character+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' @examples+ |
+
| 41 | ++ |
+ #' # `s_count_values.character`+ |
+
| 42 | ++ |
+ #' s_count_values(x = c("a", "b", "a"), values = "a")
+ |
+
| 43 | ++ |
+ #' s_count_values(x = c("a", "b", "a", NA, NA), values = "b", na.rm = FALSE)
+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' @export+ |
+
| 46 | ++ |
+ s_count_values.character <- function(x,+ |
+
| 47 | ++ |
+ values = "Y",+ |
+
| 48 | ++ |
+ na.rm = TRUE, # nolint+ |
+
| 49 | ++ |
+ ...) {
+ |
+
| 50 | +108x | +
+ checkmate::assert_character(values)+ |
+
| 51 | ++ | + + | +
| 52 | +108x | +
+ if (na.rm) {
+ |
+
| 53 | +108x | +
+ x <- x[!is.na(x)]+ |
+
| 54 | ++ |
+ }+ |
+
| 55 | ++ | + + | +
| 56 | +108x | +
+ is_in_values <- x %in% values+ |
+
| 57 | ++ | + + | +
| 58 | +108x | +
+ s_summary(is_in_values, ...)+ |
+
| 59 | ++ |
+ }+ |
+
| 60 | ++ | + + | +
| 61 | ++ |
+ #' @describeIn count_values_funs Method for `factor` class. This makes an automatic+ |
+
| 62 | ++ |
+ #' conversion to `character` and then forwards to the method for characters.+ |
+
| 63 | ++ |
+ #'+ |
+
| 64 | ++ |
+ #' @method s_count_values factor+ |
+
| 65 | ++ |
+ #'+ |
+
| 66 | ++ |
+ #' @examples+ |
+
| 67 | ++ |
+ #' # `s_count_values.factor`+ |
+
| 68 | ++ |
+ #' s_count_values(x = factor(c("a", "b", "a")), values = "a")
+ |
+
| 69 | ++ |
+ #'+ |
+
| 70 | ++ |
+ #' @export+ |
+
| 71 | ++ |
+ s_count_values.factor <- function(x,+ |
+
| 72 | ++ |
+ values = "Y",+ |
+
| 73 | ++ |
+ ...) {
+ |
+
| 74 | +3x | +
+ s_count_values(as.character(x), values = as.character(values), ...)+ |
+
| 75 | ++ |
+ }+ |
+
| 76 | ++ | + + | +
| 77 | ++ |
+ #' @describeIn count_values_funs Method for `logical` class.+ |
+
| 78 | ++ |
+ #'+ |
+
| 79 | ++ |
+ #' @method s_count_values logical+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ #' @examples+ |
+
| 82 | ++ |
+ #' # `s_count_values.logical`+ |
+
| 83 | ++ |
+ #' s_count_values(x = c(TRUE, FALSE, TRUE))+ |
+
| 84 | ++ |
+ #'+ |
+
| 85 | ++ |
+ #' @export+ |
+
| 86 | ++ |
+ s_count_values.logical <- function(x, values = TRUE, ...) {
+ |
+
| 87 | +3x | +
+ checkmate::assert_logical(values)+ |
+
| 88 | +3x | +
+ s_count_values(as.character(x), values = as.character(values), ...)+ |
+
| 89 | ++ |
+ }+ |
+
| 90 | ++ | + + | +
| 91 | ++ |
+ #' @describeIn count_values_funs Formatted analysis function which is used as `afun`+ |
+
| 92 | ++ |
+ #' in `count_values()`.+ |
+
| 93 | ++ |
+ #'+ |
+
| 94 | ++ |
+ #' @return+ |
+
| 95 | ++ |
+ #' * `a_count_values()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 96 | ++ |
+ #'+ |
+
| 97 | ++ |
+ #' @examples+ |
+
| 98 | ++ |
+ #' # `a_count_values`+ |
+
| 99 | ++ |
+ #' a_count_values(x = factor(c("a", "b", "a")), values = "a", .N_col = 10, .N_row = 10)
+ |
+
| 100 | ++ |
+ #'+ |
+
| 101 | ++ |
+ #' @export+ |
+
| 102 | ++ |
+ a_count_values <- make_afun(+ |
+
| 103 | ++ |
+ s_count_values,+ |
+
| 104 | ++ |
+ .formats = c(count_fraction = "xx (xx.xx%)", count = "xx")+ |
+
| 105 | ++ |
+ )+ |
+
| 106 | ++ | + + | +
| 107 | ++ |
+ #' @describeIn count_values_funs Layout-creating function which can take statistics function arguments+ |
+
| 108 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 109 | ++ |
+ #'+ |
+
| 110 | ++ |
+ #' @return+ |
+
| 111 | ++ |
+ #' * `count_values()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 112 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 113 | ++ |
+ #' the statistics from `s_count_values()` to the table layout.+ |
+
| 114 | ++ |
+ #'+ |
+
| 115 | ++ |
+ #' @examples+ |
+
| 116 | ++ |
+ #' # `count_values`+ |
+
| 117 | ++ |
+ #' basic_table() %>%+ |
+
| 118 | ++ |
+ #' count_values("Species", values = "setosa") %>%
+ |
+
| 119 | ++ |
+ #' build_table(iris)+ |
+
| 120 | ++ |
+ #'+ |
+
| 121 | ++ |
+ #' @export+ |
+
| 122 | ++ |
+ count_values <- function(lyt,+ |
+
| 123 | ++ |
+ vars,+ |
+
| 124 | ++ |
+ values,+ |
+
| 125 | ++ |
+ na_str = NA_character_,+ |
+
| 126 | ++ |
+ nested = TRUE,+ |
+
| 127 | ++ |
+ ...,+ |
+
| 128 | ++ |
+ table_names = vars,+ |
+
| 129 | ++ |
+ .stats = "count_fraction",+ |
+
| 130 | ++ |
+ .formats = NULL,+ |
+
| 131 | ++ |
+ .labels = c(count_fraction = paste(values, collapse = ", ")),+ |
+
| 132 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 133 | +3x | +
+ afun <- make_afun(+ |
+
| 134 | +3x | +
+ a_count_values,+ |
+
| 135 | +3x | +
+ .stats = .stats,+ |
+
| 136 | +3x | +
+ .formats = .formats,+ |
+
| 137 | +3x | +
+ .labels = .labels,+ |
+
| 138 | +3x | +
+ .indent_mods = .indent_mods+ |
+
| 139 | ++ |
+ )+ |
+
| 140 | +3x | +
+ analyze(+ |
+
| 141 | +3x | +
+ lyt,+ |
+
| 142 | +3x | +
+ vars,+ |
+
| 143 | +3x | +
+ afun = afun,+ |
+
| 144 | +3x | +
+ na_str = na_str,+ |
+
| 145 | +3x | +
+ nested = nested,+ |
+
| 146 | +3x | +
+ extra_args = c(list(values = values), list(...)),+ |
+
| 147 | +3x | +
+ show_labels = ifelse(length(vars) > 1, "visible", "hidden"),+ |
+
| 148 | +3x | +
+ table_names = table_names+ |
+
| 149 | ++ |
+ )+ |
+
| 150 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Subgroup Treatment Effect Pattern (STEP) Fit for Binary (Response) Outcome+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' This fits the Subgroup Treatment Effect Pattern logistic regression models for a binary+ |
+
| 6 | ++ |
+ #' (response) outcome. The treatment arm variable must have exactly 2 levels,+ |
+
| 7 | ++ |
+ #' where the first one is taken as reference and the estimated odds ratios are+ |
+
| 8 | ++ |
+ #' for the comparison of the second level vs. the first one.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' The (conditional) logistic regression model which is fit is:+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' `response ~ arm * poly(biomarker, degree) + covariates + strata(strata)`+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' where `degree` is specified by `control_step()`.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 17 | ++ |
+ #' @param variables (named `list` of `character`)\cr list of analysis variables:+ |
+
| 18 | ++ |
+ #' needs `response`, `arm`, `biomarker`, and optional `covariates` and `strata`.+ |
+
| 19 | ++ |
+ #' @param control (named `list`)\cr combined control list from [control_step()]+ |
+
| 20 | ++ |
+ #' and [control_logistic()].+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @return A matrix of class `step`. The first part of the columns describe the+ |
+
| 23 | ++ |
+ #' subgroup intervals used for the biomarker variable, including where the+ |
+
| 24 | ++ |
+ #' center of the intervals are and their bounds. The second part of the+ |
+
| 25 | ++ |
+ #' columns contain the estimates for the treatment arm comparison.+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' @note For the default degree 0 the `biomarker` variable is not included in the model.+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @seealso [control_step()] and [control_logistic()] for the available+ |
+
| 30 | ++ |
+ #' customization options.+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @examples+ |
+
| 33 | ++ |
+ #' # Testing dataset with just two treatment arms.+ |
+
| 34 | ++ |
+ #' library(survival)+ |
+
| 35 | ++ |
+ #' library(dplyr)+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' adrs_f <- tern_ex_adrs %>%+ |
+
| 38 | ++ |
+ #' filter(+ |
+
| 39 | ++ |
+ #' PARAMCD == "BESRSPI",+ |
+
| 40 | ++ |
+ #' ARM %in% c("B: Placebo", "A: Drug X")
+ |
+
| 41 | ++ |
+ #' ) %>%+ |
+
| 42 | ++ |
+ #' mutate(+ |
+
| 43 | ++ |
+ #' # Reorder levels of ARM to have Placebo as reference arm for Odds Ratio calculations.+ |
+
| 44 | ++ |
+ #' ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")),+ |
+
| 45 | ++ |
+ #' RSP = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
+ |
+
| 46 | ++ |
+ #' SEX = factor(SEX)+ |
+
| 47 | ++ |
+ #' )+ |
+
| 48 | ++ |
+ #'+ |
+
| 49 | ++ |
+ #' variables <- list(+ |
+
| 50 | ++ |
+ #' arm = "ARM",+ |
+
| 51 | ++ |
+ #' biomarker = "BMRKR1",+ |
+
| 52 | ++ |
+ #' covariates = "AGE",+ |
+
| 53 | ++ |
+ #' response = "RSP"+ |
+
| 54 | ++ |
+ #' )+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup.+ |
+
| 57 | ++ |
+ #' # We use a large enough bandwidth to avoid too small subgroups and linear separation in those.+ |
+
| 58 | ++ |
+ #' step_matrix <- fit_rsp_step(+ |
+
| 59 | ++ |
+ #' variables = variables,+ |
+
| 60 | ++ |
+ #' data = adrs_f,+ |
+
| 61 | ++ |
+ #' control = c(control_logistic(), control_step(bandwidth = 0.5))+ |
+
| 62 | ++ |
+ #' )+ |
+
| 63 | ++ |
+ #' dim(step_matrix)+ |
+
| 64 | ++ |
+ #' head(step_matrix)+ |
+
| 65 | ++ |
+ #'+ |
+
| 66 | ++ |
+ #' # Specify different polynomial degree for the biomarker interaction to use more flexible local+ |
+
| 67 | ++ |
+ #' # models. Or specify different logistic regression options, including confidence level.+ |
+
| 68 | ++ |
+ #' step_matrix2 <- fit_rsp_step(+ |
+
| 69 | ++ |
+ #' variables = variables,+ |
+
| 70 | ++ |
+ #' data = adrs_f,+ |
+
| 71 | ++ |
+ #' control = c(control_logistic(conf_level = 0.9), control_step(bandwidth = 0.6, degree = 1))+ |
+
| 72 | ++ |
+ #' )+ |
+
| 73 | ++ |
+ #'+ |
+
| 74 | ++ |
+ #' # Use a global constant model. This is helpful as a reference for the subgroup models.+ |
+
| 75 | ++ |
+ #' step_matrix3 <- fit_rsp_step(+ |
+
| 76 | ++ |
+ #' variables = variables,+ |
+
| 77 | ++ |
+ #' data = adrs_f,+ |
+
| 78 | ++ |
+ #' control = c(control_logistic(), control_step(bandwidth = NULL, num_points = 2L))+ |
+
| 79 | ++ |
+ #' )+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ #' # It is also possible to use strata, i.e. use conditional logistic regression models.+ |
+
| 82 | ++ |
+ #' variables2 <- list(+ |
+
| 83 | ++ |
+ #' arm = "ARM",+ |
+
| 84 | ++ |
+ #' biomarker = "BMRKR1",+ |
+
| 85 | ++ |
+ #' covariates = "AGE",+ |
+
| 86 | ++ |
+ #' response = "RSP",+ |
+
| 87 | ++ |
+ #' strata = c("STRATA1", "STRATA2")
+ |
+
| 88 | ++ |
+ #' )+ |
+
| 89 | ++ |
+ #'+ |
+
| 90 | ++ |
+ #' step_matrix4 <- fit_rsp_step(+ |
+
| 91 | ++ |
+ #' variables = variables2,+ |
+
| 92 | ++ |
+ #' data = adrs_f,+ |
+
| 93 | ++ |
+ #' control = c(control_logistic(), control_step(bandwidth = 0.6))+ |
+
| 94 | ++ |
+ #' )+ |
+
| 95 | ++ |
+ #'+ |
+
| 96 | ++ |
+ #' @export+ |
+
| 97 | ++ |
+ fit_rsp_step <- function(variables,+ |
+
| 98 | ++ |
+ data,+ |
+
| 99 | ++ |
+ control = c(control_step(), control_logistic())) {
+ |
+
| 100 | +5x | +
+ assert_df_with_variables(data, variables)+ |
+
| 101 | +5x | +
+ checkmate::assert_list(control, names = "named")+ |
+
| 102 | +5x | +
+ data <- data[!is.na(data[[variables$biomarker]]), ]+ |
+
| 103 | +5x | +
+ window_sel <- h_step_window(x = data[[variables$biomarker]], control = control)+ |
+
| 104 | +5x | +
+ interval_center <- window_sel$interval[, "Interval Center"]+ |
+
| 105 | +5x | +
+ form <- h_step_rsp_formula(variables = variables, control = control)+ |
+
| 106 | +5x | +
+ estimates <- if (is.null(control$bandwidth)) {
+ |
+
| 107 | +1x | +
+ h_step_rsp_est(+ |
+
| 108 | +1x | +
+ formula = form,+ |
+
| 109 | +1x | +
+ data = data,+ |
+
| 110 | +1x | +
+ variables = variables,+ |
+
| 111 | +1x | +
+ x = interval_center,+ |
+
| 112 | +1x | +
+ control = control+ |
+
| 113 | ++ |
+ )+ |
+
| 114 | ++ |
+ } else {
+ |
+
| 115 | +4x | +
+ tmp <- mapply(+ |
+
| 116 | +4x | +
+ FUN = h_step_rsp_est,+ |
+
| 117 | +4x | +
+ x = interval_center,+ |
+
| 118 | +4x | +
+ subset = as.list(as.data.frame(window_sel$sel)),+ |
+
| 119 | +4x | +
+ MoreArgs = list(+ |
+
| 120 | +4x | +
+ formula = form,+ |
+
| 121 | +4x | +
+ data = data,+ |
+
| 122 | +4x | +
+ variables = variables,+ |
+
| 123 | +4x | +
+ control = control+ |
+
| 124 | ++ |
+ )+ |
+
| 125 | ++ |
+ )+ |
+
| 126 | ++ |
+ # Maybe we find a more elegant solution than this.+ |
+
| 127 | +4x | +
+ rownames(tmp) <- c("n", "logor", "se", "ci_lower", "ci_upper")
+ |
+
| 128 | +4x | +
+ t(tmp)+ |
+
| 129 | ++ |
+ }+ |
+
| 130 | +5x | +
+ result <- cbind(window_sel$interval, estimates)+ |
+
| 131 | +5x | +
+ structure(+ |
+
| 132 | +5x | +
+ result,+ |
+
| 133 | +5x | +
+ class = c("step", "matrix"),
+ |
+
| 134 | +5x | +
+ variables = variables,+ |
+
| 135 | +5x | +
+ control = control+ |
+
| 136 | ++ |
+ )+ |
+
| 137 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Occurrence Counts+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Functions for analyzing frequencies and fractions of occurrences for patients with occurrence+ |
+
| 6 | ++ |
+ #' data. Primary analysis variables are the dictionary terms. All occurrences are counted for total+ |
+
| 7 | ++ |
+ #' counts. Multiple occurrences within patient at the lowest term level displayed in the table are+ |
+
| 8 | ++ |
+ #' counted only once.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @note By default, occurrences which don't appear in a given row split are dropped from the table and+ |
+
| 13 | ++ |
+ #' the occurrences in the table are sorted alphabetically per row split. Therefore, the corresponding layout+ |
+
| 14 | ++ |
+ #' needs to use `split_fun = drop_split_levels` in the `split_rows_by` calls. Use `drop = FALSE` if you would+ |
+
| 15 | ++ |
+ #' like to show all occurrences.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @name count_occurrences+ |
+
| 18 | ++ |
+ NULL+ |
+
| 19 | ++ | + + | +
| 20 | ++ |
+ #' @describeIn count_occurrences Statistics function which counts number of patients that report an+ |
+
| 21 | ++ |
+ #' occurrence.+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @param denom (`string`)\cr choice of denominator for patient proportions. Can be:+ |
+
| 24 | ++ |
+ #' - `N_col`: total number of patients in this column across rows+ |
+
| 25 | ++ |
+ #' - `n`: number of patients with any occurrences+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' @return+ |
+
| 28 | ++ |
+ #' * `s_count_occurrences()` returns a list with:+ |
+
| 29 | ++ |
+ #' * `count`: list of counts with one element per occurrence.+ |
+
| 30 | ++ |
+ #' * `count_fraction`: list of counts and fractions with one element per occurrence.+ |
+
| 31 | ++ |
+ #' * `fraction`: list of numerators and denominators with one element per occurrence.+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' @examples+ |
+
| 34 | ++ |
+ #' df <- data.frame(+ |
+
| 35 | ++ |
+ #' USUBJID = as.character(c(1, 1, 2, 4, 4, 4)),+ |
+
| 36 | ++ |
+ #' MHDECOD = c("MH1", "MH2", "MH1", "MH1", "MH1", "MH3")
+ |
+
| 37 | ++ |
+ #' )+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' N_per_col <- 4L+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' # Count unique occurrences per subject.+ |
+
| 42 | ++ |
+ #' s_count_occurrences(+ |
+
| 43 | ++ |
+ #' df,+ |
+
| 44 | ++ |
+ #' .N_col = N_per_col,+ |
+
| 45 | ++ |
+ #' .df_row = df,+ |
+
| 46 | ++ |
+ #' .var = "MHDECOD",+ |
+
| 47 | ++ |
+ #' id = "USUBJID"+ |
+
| 48 | ++ |
+ #' )+ |
+
| 49 | ++ |
+ #'+ |
+
| 50 | ++ |
+ #' @export+ |
+
| 51 | ++ |
+ s_count_occurrences <- function(df,+ |
+
| 52 | ++ |
+ denom = c("N_col", "n"),
+ |
+
| 53 | ++ |
+ .N_col, # nolint+ |
+
| 54 | ++ |
+ .df_row,+ |
+
| 55 | ++ |
+ drop = TRUE,+ |
+
| 56 | ++ |
+ .var = "MHDECOD",+ |
+
| 57 | ++ |
+ id = "USUBJID") {
+ |
+
| 58 | +7x | +
+ checkmate::assert_flag(drop)+ |
+
| 59 | +7x | +
+ assert_df_with_variables(df, list(range = .var, id = id))+ |
+
| 60 | +7x | +
+ checkmate::assert_count(.N_col)+ |
+
| 61 | +7x | +
+ checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
+ |
+
| 62 | +7x | +
+ checkmate::assert_multi_class(df[[id]], classes = c("factor", "character"))
+ |
+
| 63 | +7x | +
+ denom <- match.arg(denom)+ |
+
| 64 | ++ | + + | +
| 65 | +7x | +
+ occurrences <- if (drop) {
+ |
+
| 66 | ++ |
+ # Note that we don't try to preserve original level order here since a) that would required+ |
+
| 67 | ++ |
+ # more time to look up in large original levels and b) that would fail for character input variable.+ |
+
| 68 | +6x | +
+ occurrence_levels <- sort(unique(.df_row[[.var]]))+ |
+
| 69 | +6x | +
+ if (length(occurrence_levels) == 0) {
+ |
+
| 70 | +1x | +
+ stop(+ |
+
| 71 | +1x | +
+ "no empty `.df_row` input allowed when `drop = TRUE`,",+ |
+
| 72 | +1x | +
+ " please use `split_fun = drop_split_levels` in the `rtables` `split_rows_by` calls"+ |
+
| 73 | ++ |
+ )+ |
+
| 74 | ++ |
+ }+ |
+
| 75 | +5x | +
+ factor(df[[.var]], levels = occurrence_levels)+ |
+
| 76 | ++ |
+ } else {
+ |
+
| 77 | +1x | +
+ df[[.var]]+ |
+
| 78 | ++ |
+ }+ |
+
| 79 | +6x | +
+ ids <- factor(df[[id]])+ |
+
| 80 | +6x | +
+ dn <- switch(denom,+ |
+
| 81 | +6x | +
+ n = nlevels(ids),+ |
+
| 82 | +6x | +
+ N_col = .N_col+ |
+
| 83 | ++ |
+ )+ |
+
| 84 | +6x | +
+ has_occurrence_per_id <- table(occurrences, ids) > 0+ |
+
| 85 | +6x | +
+ n_ids_per_occurrence <- as.list(rowSums(has_occurrence_per_id))+ |
+
| 86 | +6x | +
+ list(+ |
+
| 87 | +6x | +
+ count = n_ids_per_occurrence,+ |
+
| 88 | +6x | +
+ count_fraction = lapply(+ |
+
| 89 | +6x | +
+ n_ids_per_occurrence,+ |
+
| 90 | +6x | +
+ function(i, denom) {
+ |
+
| 91 | +33x | +
+ if (i == 0 && denom == 0) {
+ |
+
| 92 | +! | +
+ c(0, 0)+ |
+
| 93 | ++ |
+ } else {
+ |
+
| 94 | +33x | +
+ c(i, i / denom)+ |
+
| 95 | ++ |
+ }+ |
+
| 96 | ++ |
+ },+ |
+
| 97 | +6x | +
+ denom = dn+ |
+
| 98 | ++ |
+ ),+ |
+
| 99 | +6x | +
+ fraction = lapply(+ |
+
| 100 | +6x | +
+ n_ids_per_occurrence,+ |
+
| 101 | +6x | +
+ function(i, denom) c("num" = i, "denom" = denom),
+ |
+
| 102 | +6x | +
+ denom = dn+ |
+
| 103 | ++ |
+ )+ |
+
| 104 | ++ |
+ )+ |
+
| 105 | ++ |
+ }+ |
+
| 106 | ++ | + + | +
| 107 | ++ |
+ #' @describeIn count_occurrences Formatted analysis function which is used as `afun`+ |
+
| 108 | ++ |
+ #' in `count_occurrences()`.+ |
+
| 109 | ++ |
+ #'+ |
+
| 110 | ++ |
+ #' @return+ |
+
| 111 | ++ |
+ #' * `a_count_occurrences()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 112 | ++ |
+ #'+ |
+
| 113 | ++ |
+ #' @examples+ |
+
| 114 | ++ |
+ #' # We need to ungroup `count_fraction` first so that the `rtables` formatting+ |
+
| 115 | ++ |
+ #' # function `format_count_fraction()` can be applied correctly.+ |
+
| 116 | ++ |
+ #' afun <- make_afun(a_count_occurrences, .ungroup_stats = c("count", "count_fraction", "fraction"))
+ |
+
| 117 | ++ |
+ #' afun(+ |
+
| 118 | ++ |
+ #' df,+ |
+
| 119 | ++ |
+ #' .N_col = N_per_col,+ |
+
| 120 | ++ |
+ #' .df_row = df,+ |
+
| 121 | ++ |
+ #' .var = "MHDECOD",+ |
+
| 122 | ++ |
+ #' id = "USUBJID"+ |
+
| 123 | ++ |
+ #' )+ |
+
| 124 | ++ |
+ #'+ |
+
| 125 | ++ |
+ #' @export+ |
+
| 126 | ++ |
+ a_count_occurrences <- make_afun(+ |
+
| 127 | ++ |
+ s_count_occurrences,+ |
+
| 128 | ++ |
+ .formats = c(count = "xx", count_fraction = format_count_fraction_fixed_dp, fraction = format_fraction_fixed_dp)+ |
+
| 129 | ++ |
+ )+ |
+
| 130 | ++ | + + | +
| 131 | ++ |
+ #' @describeIn count_occurrences Layout-creating function which can take statistics function arguments+ |
+
| 132 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 133 | ++ |
+ #'+ |
+
| 134 | ++ |
+ #' @return+ |
+
| 135 | ++ |
+ #' * `count_occurrences()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 136 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 137 | ++ |
+ #' the statistics from `s_count_occurrences()` to the table layout.+ |
+
| 138 | ++ |
+ #'+ |
+
| 139 | ++ |
+ #' @examples+ |
+
| 140 | ++ |
+ #' library(dplyr)+ |
+
| 141 | ++ |
+ #' df <- data.frame(+ |
+
| 142 | ++ |
+ #' USUBJID = as.character(c(+ |
+
| 143 | ++ |
+ #' 1, 1, 2, 4, 4, 4,+ |
+
| 144 | ++ |
+ #' 6, 6, 6, 7, 7, 8+ |
+
| 145 | ++ |
+ #' )),+ |
+
| 146 | ++ |
+ #' MHDECOD = c(+ |
+
| 147 | ++ |
+ #' "MH1", "MH2", "MH1", "MH1", "MH1", "MH3",+ |
+
| 148 | ++ |
+ #' "MH2", "MH2", "MH3", "MH1", "MH2", "MH4"+ |
+
| 149 | ++ |
+ #' ),+ |
+
| 150 | ++ |
+ #' ARM = rep(c("A", "B"), each = 6)
+ |
+
| 151 | ++ |
+ #' )+ |
+
| 152 | ++ |
+ #' df_adsl <- df %>%+ |
+
| 153 | ++ |
+ #' select(USUBJID, ARM) %>%+ |
+
| 154 | ++ |
+ #' unique()+ |
+
| 155 | ++ |
+ #'+ |
+
| 156 | ++ |
+ #' # Create table layout+ |
+
| 157 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 158 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 159 | ++ |
+ #' add_colcounts() %>%+ |
+
| 160 | ++ |
+ #' count_occurrences(vars = "MHDECOD", .stats = c("count_fraction"))
+ |
+
| 161 | ++ |
+ #'+ |
+
| 162 | ++ |
+ #' # Apply table layout to data and produce `rtable` object+ |
+
| 163 | ++ |
+ #' lyt %>%+ |
+
| 164 | ++ |
+ #' build_table(df, alt_counts_df = df_adsl) %>%+ |
+
| 165 | ++ |
+ #' prune_table()+ |
+
| 166 | ++ |
+ #'+ |
+
| 167 | ++ |
+ #' @export+ |
+
| 168 | ++ |
+ count_occurrences <- function(lyt,+ |
+
| 169 | ++ |
+ vars,+ |
+
| 170 | ++ |
+ var_labels = vars,+ |
+
| 171 | ++ |
+ show_labels = "hidden",+ |
+
| 172 | ++ |
+ riskdiff = FALSE,+ |
+
| 173 | ++ |
+ na_str = NA_character_,+ |
+
| 174 | ++ |
+ nested = TRUE,+ |
+
| 175 | ++ |
+ ...,+ |
+
| 176 | ++ |
+ table_names = vars,+ |
+
| 177 | ++ |
+ .stats = "count_fraction",+ |
+
| 178 | ++ |
+ .formats = NULL,+ |
+
| 179 | ++ |
+ .labels = NULL,+ |
+
| 180 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 181 | +7x | +
+ checkmate::assert_flag(riskdiff)+ |
+
| 182 | ++ | + + | +
| 183 | +7x | +
+ afun <- make_afun(+ |
+
| 184 | +7x | +
+ a_count_occurrences,+ |
+
| 185 | +7x | +
+ .stats = .stats,+ |
+
| 186 | +7x | +
+ .formats = .formats,+ |
+
| 187 | +7x | +
+ .labels = .labels,+ |
+
| 188 | +7x | +
+ .indent_mods = .indent_mods,+ |
+
| 189 | +7x | +
+ .ungroup_stats = .stats+ |
+
| 190 | ++ |
+ )+ |
+
| 191 | ++ | + + | +
| 192 | +7x | +
+ extra_args <- if (isFALSE(riskdiff)) {
+ |
+
| 193 | +6x | +
+ list(...)+ |
+
| 194 | ++ |
+ } else {
+ |
+
| 195 | +1x | +
+ list(+ |
+
| 196 | +1x | +
+ afun = list("s_count_occurrences" = afun),
+ |
+
| 197 | +1x | +
+ .stats = .stats,+ |
+
| 198 | +1x | +
+ .indent_mods = .indent_mods,+ |
+
| 199 | +1x | +
+ s_args = list(...)+ |
+
| 200 | ++ |
+ )+ |
+
| 201 | ++ |
+ }+ |
+
| 202 | ++ | + + | +
| 203 | +7x | +
+ analyze(+ |
+
| 204 | +7x | +
+ lyt = lyt,+ |
+
| 205 | +7x | +
+ vars = vars,+ |
+
| 206 | +7x | +
+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ |
+
| 207 | +7x | +
+ var_labels = var_labels,+ |
+
| 208 | +7x | +
+ show_labels = show_labels,+ |
+
| 209 | +7x | +
+ table_names = table_names,+ |
+
| 210 | +7x | +
+ na_str = na_str,+ |
+
| 211 | +7x | +
+ nested = nested,+ |
+
| 212 | +7x | +
+ extra_args = extra_args+ |
+
| 213 | ++ |
+ )+ |
+
| 214 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Summarize Variables in Columns+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' This analyze function uses the S3 generic function [s_summary()] to summarize different variables+ |
+
| 6 | ++ |
+ #' that are arranged in columns. Additional standard formatting arguments are available. It is a+ |
+
| 7 | ++ |
+ #' minimal wrapper for [rtables::analyze_colvars()]. The latter function is meant to add different+ |
+
| 8 | ++ |
+ #' analysis methods for each column variables as different rows. To have the analysis methods as+ |
+
| 9 | ++ |
+ #' column labels, please refer to [analyze_vars_in_cols()].+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 12 | ++ |
+ #' @param ... arguments passed to `s_summary()`.+ |
+
| 13 | ++ |
+ #' @param .indent_mods (named `vector` of `integer`)\cr indent modifiers for the labels. Each element of the vector+ |
+
| 14 | ++ |
+ #' should be a name-value pair with name corresponding to a statistic specified in `.stats` and value the indentation+ |
+
| 15 | ++ |
+ #' for that statistic's row label.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @return+ |
+
| 18 | ++ |
+ #' A layout object suitable for passing to further layouting functions, or to [rtables::build_table()].+ |
+
| 19 | ++ |
+ #' Adding this function to an `rtable` layout will summarize the given variables, arrange the output+ |
+
| 20 | ++ |
+ #' in columns, and add it to the table layout.+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @seealso [rtables::split_cols_by_multivar()] and [`analyze_colvars_functions`].+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @examples+ |
+
| 25 | ++ |
+ #' dta_test <- data.frame(+ |
+
| 26 | ++ |
+ #' USUBJID = rep(1:6, each = 3),+ |
+
| 27 | ++ |
+ #' PARAMCD = rep("lab", 6 * 3),
+ |
+
| 28 | ++ |
+ #' AVISIT = rep(paste0("V", 1:3), 6),
+ |
+
| 29 | ++ |
+ #' ARM = rep(LETTERS[1:3], rep(6, 3)),+ |
+
| 30 | ++ |
+ #' AVAL = c(9:1, rep(NA, 9)),+ |
+
| 31 | ++ |
+ #' CHG = c(1:9, rep(NA, 9))+ |
+
| 32 | ++ |
+ #' )+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' ## Default output within a `rtables` pipeline.+ |
+
| 35 | ++ |
+ #' basic_table() %>%+ |
+
| 36 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 37 | ++ |
+ #' split_rows_by("AVISIT") %>%
+ |
+
| 38 | ++ |
+ #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
+ |
+
| 39 | ++ |
+ #' summarize_colvars() %>%+ |
+
| 40 | ++ |
+ #' build_table(dta_test)+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' ## Selection of statistics, formats and labels also work.+ |
+
| 43 | ++ |
+ #' basic_table() %>%+ |
+
| 44 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 45 | ++ |
+ #' split_rows_by("AVISIT") %>%
+ |
+
| 46 | ++ |
+ #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
+ |
+
| 47 | ++ |
+ #' summarize_colvars(+ |
+
| 48 | ++ |
+ #' .stats = c("n", "mean_sd"),
+ |
+
| 49 | ++ |
+ #' .formats = c("mean_sd" = "xx.x, xx.x"),
+ |
+
| 50 | ++ |
+ #' .labels = c(n = "n", mean_sd = "Mean, SD")+ |
+
| 51 | ++ |
+ #' ) %>%+ |
+
| 52 | ++ |
+ #' build_table(dta_test)+ |
+
| 53 | ++ |
+ #'+ |
+
| 54 | ++ |
+ #' ## Use arguments interpreted by `s_summary`.+ |
+
| 55 | ++ |
+ #' basic_table() %>%+ |
+
| 56 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 57 | ++ |
+ #' split_rows_by("AVISIT") %>%
+ |
+
| 58 | ++ |
+ #' split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
+ |
+
| 59 | ++ |
+ #' summarize_colvars(na.rm = FALSE) %>%+ |
+
| 60 | ++ |
+ #' build_table(dta_test)+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' @export+ |
+
| 63 | ++ |
+ summarize_colvars <- function(lyt,+ |
+
| 64 | ++ |
+ ...,+ |
+
| 65 | ++ |
+ na_level = lifecycle::deprecated(),+ |
+
| 66 | ++ |
+ na_str = NA_character_,+ |
+
| 67 | ++ |
+ .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
+ |
+
| 68 | ++ |
+ .formats = NULL,+ |
+
| 69 | ++ |
+ .labels = NULL,+ |
+
| 70 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 71 | +3x | +
+ if (lifecycle::is_present(na_level)) {
+ |
+
| 72 | +! | +
+ lifecycle::deprecate_warn("0.9.1", "summarize_colvars(na_level)", "summarize_colvars(na_str)")
+ |
+
| 73 | +! | +
+ na_str <- na_level+ |
+
| 74 | ++ |
+ }+ |
+
| 75 | ++ | + + | +
| 76 | +3x | +
+ extra_args <- list(.stats = .stats, na_str = na_str, ...)+ |
+
| 77 | +1x | +
+ if (!is.null(.formats)) extra_args[[".formats"]] <- .formats+ |
+
| 78 | +1x | +
+ if (!is.null(.labels)) extra_args[[".labels"]] <- .labels+ |
+
| 79 | +1x | +
+ if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods+ |
+
| 80 | ++ | + + | +
| 81 | +3x | +
+ analyze_colvars(+ |
+
| 82 | +3x | +
+ lyt,+ |
+
| 83 | +3x | +
+ afun = a_summary,+ |
+
| 84 | +3x | +
+ extra_args = extra_args+ |
+
| 85 | ++ |
+ )+ |
+
| 86 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Occurrence Table Sorting+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Functions to score occurrence table subtables and rows which can be used in the+ |
+
| 6 | ++ |
+ #' sorting of occurrence tables.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @name score_occurrences+ |
+
| 9 | ++ |
+ NULL+ |
+
| 10 | ++ | + + | +
| 11 | ++ |
+ #' @describeIn score_occurrences Scoring function which sums the counts across all+ |
+
| 12 | ++ |
+ #' columns. It will fail if anything else but counts are used.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @inheritParams rtables_access+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @return+ |
+
| 17 | ++ |
+ #' * `score_occurrences()` returns the sum of counts across all columns of a table row.+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @seealso [h_row_first_values()]+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @examples+ |
+
| 22 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 23 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 24 | ++ |
+ #' add_colcounts() %>%+ |
+
| 25 | ++ |
+ #' analyze_num_patients(+ |
+
| 26 | ++ |
+ #' vars = "USUBJID",+ |
+
| 27 | ++ |
+ #' .stats = c("unique"),
+ |
+
| 28 | ++ |
+ #' .labels = c("Total number of patients with at least one event")
+ |
+
| 29 | ++ |
+ #' ) %>%+ |
+
| 30 | ++ |
+ #' split_rows_by("AEBODSYS", child_labels = "visible", nested = FALSE) %>%
+ |
+
| 31 | ++ |
+ #' summarize_num_patients(+ |
+
| 32 | ++ |
+ #' var = "USUBJID",+ |
+
| 33 | ++ |
+ #' .stats = c("unique", "nonunique"),
+ |
+
| 34 | ++ |
+ #' .labels = c(+ |
+
| 35 | ++ |
+ #' "Total number of patients with at least one event",+ |
+
| 36 | ++ |
+ #' "Total number of events"+ |
+
| 37 | ++ |
+ #' )+ |
+
| 38 | ++ |
+ #' ) %>%+ |
+
| 39 | ++ |
+ #' count_occurrences(vars = "AEDECOD")+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' tbl <- build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl) %>%+ |
+
| 42 | ++ |
+ #' prune_table()+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' tbl_sorted <- tbl %>%+ |
+
| 45 | ++ |
+ #' sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_occurrences)
+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ #' tbl_sorted+ |
+
| 48 | ++ |
+ #'+ |
+
| 49 | ++ |
+ #' @export+ |
+
| 50 | ++ |
+ score_occurrences <- function(table_row) {
+ |
+
| 51 | +37x | +
+ row_counts <- h_row_counts(table_row)+ |
+
| 52 | +37x | +
+ sum(row_counts)+ |
+
| 53 | ++ |
+ }+ |
+
| 54 | ++ | + + | +
| 55 | ++ |
+ #' @describeIn score_occurrences Scoring functions can be produced by this constructor to only include+ |
+
| 56 | ++ |
+ #' specific columns in the scoring. See [h_row_counts()] for further information.+ |
+
| 57 | ++ |
+ #'+ |
+
| 58 | ++ |
+ #' @inheritParams has_count_in_cols+ |
+
| 59 | ++ |
+ #'+ |
+
| 60 | ++ |
+ #' @return+ |
+
| 61 | ++ |
+ #' * `score_occurrences_cols()` returns a function that sums counts across all specified columns+ |
+
| 62 | ++ |
+ #' of a table row.+ |
+
| 63 | ++ |
+ #'+ |
+
| 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"))
+ |
+
| 68 | ++ |
+ #'+ |
+
| 69 | ++ |
+ #' # Note that this here just sorts the AEDECOD inside the AEBODSYS. The AEBODSYS are not sorted.+ |
+
| 70 | ++ |
+ #' # That would require a second pass of `sort_at_path`.+ |
+
| 71 | ++ |
+ #' tbl_sorted <- tbl %>%+ |
+
| 72 | ++ |
+ #' sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_cols_a_and_b)
+ |
+
| 73 | ++ |
+ #'+ |
+
| 74 | ++ |
+ #' tbl_sorted+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ #' @export+ |
+
| 77 | ++ |
+ score_occurrences_cols <- function(...) {
+ |
+
| 78 | +4x | +
+ function(table_row) {
+ |
+
| 79 | +20x | +
+ row_counts <- h_row_counts(table_row, ...)+ |
+
| 80 | +20x | +
+ sum(row_counts)+ |
+
| 81 | ++ |
+ }+ |
+
| 82 | ++ |
+ }+ |
+
| 83 | ++ | + + | +
| 84 | ++ |
+ #' @describeIn score_occurrences Scoring functions produced by this constructor can be used on+ |
+
| 85 | ++ |
+ #' subtables: They sum up all specified column counts in the subtable. This is useful when+ |
+
| 86 | ++ |
+ #' there is no available content row summing up these counts.+ |
+
| 87 | ++ |
+ #'+ |
+
| 88 | ++ |
+ #' @return+ |
+
| 89 | ++ |
+ #' * `score_occurrences_subtable()` returns a function that sums counts in each subtable+ |
+
| 90 | ++ |
+ #' across all specified columns.+ |
+
| 91 | ++ |
+ #'+ |
+
| 92 | ++ |
+ #' @examples+ |
+
| 93 | ++ |
+ #' score_subtable_all <- score_occurrences_subtable(col_names = names(tbl))+ |
+
| 94 | ++ |
+ #'+ |
+
| 95 | ++ |
+ #' # Note that this code just sorts the AEBODSYS, not the AEDECOD within AEBODSYS. That+ |
+
| 96 | ++ |
+ #' # would require a second pass of `sort_at_path`.+ |
+
| 97 | ++ |
+ #' tbl_sorted <- tbl %>%+ |
+
| 98 | ++ |
+ #' sort_at_path(path = c("AEBODSYS"), scorefun = score_subtable_all, decreasing = FALSE)
+ |
+
| 99 | ++ |
+ #'+ |
+
| 100 | ++ |
+ #' tbl_sorted+ |
+
| 101 | ++ |
+ #'+ |
+
| 102 | ++ |
+ #' @export+ |
+
| 103 | ++ |
+ score_occurrences_subtable <- function(...) {
+ |
+
| 104 | +1x | +
+ score_table_row <- score_occurrences_cols(...)+ |
+
| 105 | +1x | +
+ function(table_tree) {
+ |
+
| 106 | +2x | +
+ table_rows <- collect_leaves(table_tree)+ |
+
| 107 | +2x | +
+ counts <- vapply(table_rows, score_table_row, numeric(1))+ |
+
| 108 | +2x | +
+ sum(counts)+ |
+
| 109 | ++ |
+ }+ |
+
| 110 | ++ |
+ }+ |
+
| 111 | ++ | + + | +
| 112 | ++ |
+ #' @describeIn score_occurrences Produce score function for sorting table by summing the first content row in+ |
+
| 113 | ++ |
+ #' specified columns. Note that this is extending [rtables::cont_n_onecol()] and [rtables::cont_n_allcols()].+ |
+
| 114 | ++ |
+ #'+ |
+
| 115 | ++ |
+ #' @return+ |
+
| 116 | ++ |
+ #' * `score_occurrences_cont_cols()` returns a function that sums counts in the first content row in+ |
+
| 117 | ++ |
+ #' specified columns.+ |
+
| 118 | ++ |
+ #'+ |
+
| 119 | ++ |
+ #' @export+ |
+
| 120 | ++ |
+ score_occurrences_cont_cols <- function(...) {
+ |
+
| 121 | +1x | +
+ score_table_row <- score_occurrences_cols(...)+ |
+
| 122 | +1x | +
+ function(table_tree) {
+ |
+
| 123 | +2x | +
+ if (inherits(table_tree, "ContentRow")) {
+ |
+
| 124 | +! | +
+ return(NA)+ |
+
| 125 | ++ |
+ }+ |
+
| 126 | +2x | +
+ content_row <- h_content_first_row(table_tree)+ |
+
| 127 | +2x | +
+ score_table_row(content_row)+ |
+
| 128 | ++ |
+ }+ |
+
| 129 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Patient Counts with Abnormal Range Values by Baseline Status+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Primary analysis variable `.var` indicates the abnormal range result (`character` or `factor`), and additional+ |
+
| 6 | ++ |
+ #' analysis variables are `id` (`character` or `factor`) and `baseline` (`character` or `factor`). For each+ |
+
| 7 | ++ |
+ #' direction specified in `abnormal` (e.g. high or low) we condition on baseline range result and count+ |
+
| 8 | ++ |
+ #' patients in the numerator and denominator as follows:+ |
+
| 9 | ++ |
+ #' * `Not <Abnormal>`+ |
+
| 10 | ++ |
+ #' * `denom`: the number of patients without abnormality at baseline (excluding those with missing baseline)+ |
+
| 11 | ++ |
+ #' * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline+ |
+
| 12 | ++ |
+ #' * `<Abnormal>`+ |
+
| 13 | ++ |
+ #' * `denom`: the number of patients with abnormality at baseline+ |
+
| 14 | ++ |
+ #' * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline+ |
+
| 15 | ++ |
+ #' * `Total`+ |
+
| 16 | ++ |
+ #' * `denom`: the number of patients with at least one valid measurement post-baseline+ |
+
| 17 | ++ |
+ #' * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 20 | ++ |
+ #' @param abnormal (`character`)\cr identifying the abnormal range level(s) in `.var`.+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @note+ |
+
| 23 | ++ |
+ #' * `df` should be filtered to include only post-baseline records.+ |
+
| 24 | ++ |
+ #' * If the baseline variable or analysis variable contains `NA`, it is expected that `NA` has been+ |
+
| 25 | ++ |
+ #' conveyed to `na_level` appropriately beforehand with [df_explicit_na()] or [explicit_na()].+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' @seealso Relevant description function [d_count_abnormal_by_baseline()].+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @name abnormal_by_baseline+ |
+
| 30 | ++ |
+ NULL+ |
+
| 31 | ++ | + + | +
| 32 | ++ |
+ #' Description Function for [s_count_abnormal_by_baseline()]+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 35 | ++ |
+ #'+ |
+
| 36 | ++ |
+ #' Description function that produces the labels for [s_count_abnormal_by_baseline()].+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' @inheritParams abnormal_by_baseline+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' @return Abnormal category labels for [s_count_abnormal_by_baseline()].+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' @examples+ |
+
| 43 | ++ |
+ #' d_count_abnormal_by_baseline("LOW")
+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' @export+ |
+
| 46 | ++ |
+ d_count_abnormal_by_baseline <- function(abnormal) {
+ |
+
| 47 | +7x | +
+ not_abn_name <- paste("Not", tolower(abnormal))
+ |
+
| 48 | +7x | +
+ abn_name <- paste0(toupper(substr(abnormal, 1, 1)), tolower(substring(abnormal, 2)))+ |
+
| 49 | +7x | +
+ total_name <- "Total"+ |
+
| 50 | ++ | + + | +
| 51 | +7x | +
+ list(+ |
+
| 52 | +7x | +
+ not_abnormal = not_abn_name,+ |
+
| 53 | +7x | +
+ abnormal = abn_name,+ |
+
| 54 | +7x | +
+ total = total_name+ |
+
| 55 | ++ |
+ )+ |
+
| 56 | ++ |
+ }+ |
+
| 57 | ++ | + + | +
| 58 | ++ |
+ #' @describeIn abnormal_by_baseline Statistics function for a single `abnormal` level.+ |
+
| 59 | ++ |
+ #'+ |
+
| 60 | ++ |
+ #' @param na_str (`string`)\cr the explicit `na_level` argument you used in the pre-processing steps (maybe with+ |
+
| 61 | ++ |
+ #' [df_explicit_na()]). The default is `"<Missing>"`.+ |
+
| 62 | ++ |
+ #'+ |
+
| 63 | ++ |
+ #' @return+ |
+
| 64 | ++ |
+ #' * `s_count_abnormal_by_baseline()` returns statistic `fraction` which is a named list with 3 labeled elements:+ |
+
| 65 | ++ |
+ #' `not_abnormal`, `abnormal`, and `total`. Each element contains a vector with `num` and `denom` patient counts.+ |
+
| 66 | ++ |
+ #'+ |
+
| 67 | ++ |
+ #'+ |
+
| 68 | ++ |
+ #' @keywords internal+ |
+
| 69 | ++ |
+ s_count_abnormal_by_baseline <- function(df,+ |
+
| 70 | ++ |
+ .var,+ |
+
| 71 | ++ |
+ abnormal,+ |
+
| 72 | ++ |
+ na_level = lifecycle::deprecated(),+ |
+
| 73 | ++ |
+ na_str = "<Missing>",+ |
+
| 74 | ++ |
+ variables = list(id = "USUBJID", baseline = "BNRIND")) {
+ |
+
| 75 | +5x | +
+ if (lifecycle::is_present(na_level)) {
+ |
+
| 76 | +! | +
+ lifecycle::deprecate_warn("0.9.1", "s_count_abnormal_by_baseline(na_level)", "s_count_abnormal_by_baseline(na_str)")
+ |
+
| 77 | +! | +
+ na_str <- na_level+ |
+
| 78 | ++ |
+ }+ |
+
| 79 | ++ | + + | +
| 80 | +5x | +
+ checkmate::assert_string(.var)+ |
+
| 81 | +5x | +
+ checkmate::assert_string(abnormal)+ |
+
| 82 | +5x | +
+ checkmate::assert_string(na_str)+ |
+
| 83 | +5x | +
+ assert_df_with_variables(df, c(range = .var, variables))+ |
+
| 84 | +5x | +
+ checkmate::assert_subset(names(variables), c("id", "baseline"))
+ |
+
| 85 | +5x | +
+ checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
+ |
+
| 86 | +5x | +
+ checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
+ |
+
| 87 | +5x | +
+ checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
+ |
+
| 88 | ++ | + + | +
| 89 | ++ |
+ # If input is passed as character, changed to factor+ |
+
| 90 | +5x | +
+ df[[.var]] <- as_factor_keep_attributes(df[[.var]], na_level = na_str)+ |
+
| 91 | +5x | +
+ df[[variables$baseline]] <- as_factor_keep_attributes(df[[variables$baseline]], na_level = na_str)+ |
+
| 92 | ++ | + + | +
| 93 | +5x | +
+ assert_valid_factor(df[[.var]], any.missing = FALSE)+ |
+
| 94 | +4x | +
+ assert_valid_factor(df[[variables$baseline]], any.missing = FALSE)+ |
+
| 95 | ++ | + + | +
| 96 | ++ |
+ # Keep only records with valid analysis value.+ |
+
| 97 | +3x | +
+ df <- df[df[[.var]] != na_str, ]+ |
+
| 98 | ++ | + + | +
| 99 | +3x | +
+ anl <- data.frame(+ |
+
| 100 | +3x | +
+ id = df[[variables$id]],+ |
+
| 101 | +3x | +
+ var = df[[.var]],+ |
+
| 102 | +3x | +
+ baseline = df[[variables$baseline]],+ |
+
| 103 | +3x | +
+ stringsAsFactors = FALSE+ |
+
| 104 | ++ |
+ )+ |
+
| 105 | ++ | + + | +
| 106 | ++ |
+ # Total:+ |
+
| 107 | ++ |
+ # - Patients in denominator: have at least one valid measurement post-baseline.+ |
+
| 108 | ++ |
+ # - Patients in numerator: have at least one abnormality.+ |
+
| 109 | +3x | +
+ total_denom <- length(unique(anl$id))+ |
+
| 110 | +3x | +
+ total_num <- length(unique(anl$id[anl$var == abnormal]))+ |
+
| 111 | ++ | + + | +
| 112 | ++ |
+ # Baseline NA records are counted only in total rows.+ |
+
| 113 | +3x | +
+ anl <- anl[anl$baseline != na_str, ]+ |
+
| 114 | ++ | + + | +
| 115 | ++ |
+ # Abnormal:+ |
+
| 116 | ++ |
+ # - Patients in denominator: have abnormality at baseline.+ |
+
| 117 | ++ |
+ # - Patients in numerator: have abnormality at baseline AND+ |
+
| 118 | ++ |
+ # have at least one abnormality post-baseline.+ |
+
| 119 | +3x | +
+ abn_denom <- length(unique(anl$id[anl$baseline == abnormal]))+ |
+
| 120 | +3x | +
+ abn_num <- length(unique(anl$id[anl$baseline == abnormal & anl$var == abnormal]))+ |
+
| 121 | ++ | + + | +
| 122 | ++ |
+ # Not abnormal:+ |
+
| 123 | ++ |
+ # - Patients in denominator: do not have abnormality at baseline.+ |
+
| 124 | ++ |
+ # - Patients in numerator: do not have abnormality at baseline AND+ |
+
| 125 | ++ |
+ # have at least one abnormality post-baseline.+ |
+
| 126 | +3x | +
+ not_abn_denom <- length(unique(anl$id[anl$baseline != abnormal]))+ |
+
| 127 | +3x | +
+ not_abn_num <- length(unique(anl$id[anl$baseline != abnormal & anl$var == abnormal]))+ |
+
| 128 | ++ | + + | +
| 129 | +3x | +
+ labels <- d_count_abnormal_by_baseline(abnormal)+ |
+
| 130 | +3x | +
+ list(fraction = list(+ |
+
| 131 | +3x | +
+ not_abnormal = formatters::with_label(c(num = not_abn_num, denom = not_abn_denom), labels$not_abnormal),+ |
+
| 132 | +3x | +
+ abnormal = formatters::with_label(c(num = abn_num, denom = abn_denom), labels$abnormal),+ |
+
| 133 | +3x | +
+ total = formatters::with_label(c(num = total_num, denom = total_denom), labels$total)+ |
+
| 134 | ++ |
+ ))+ |
+
| 135 | ++ |
+ }+ |
+
| 136 | ++ | + + | +
| 137 | ++ |
+ #' @describeIn abnormal_by_baseline Formatted analysis function which is used as `afun`+ |
+
| 138 | ++ |
+ #' in `count_abnormal_by_baseline()`.+ |
+
| 139 | ++ |
+ #'+ |
+
| 140 | ++ |
+ #' @return+ |
+
| 141 | ++ |
+ #' * `a_count_abnormal_by_baseline()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 142 | ++ |
+ #'+ |
+
| 143 | ++ |
+ #'+ |
+
| 144 | ++ |
+ #' @keywords internal+ |
+
| 145 | ++ |
+ a_count_abnormal_by_baseline <- make_afun(+ |
+
| 146 | ++ |
+ s_count_abnormal_by_baseline,+ |
+
| 147 | ++ |
+ .formats = c(fraction = format_fraction)+ |
+
| 148 | ++ |
+ )+ |
+
| 149 | ++ | + + | +
| 150 | ++ |
+ #' @describeIn abnormal_by_baseline Layout-creating function which can take statistics function arguments+ |
+
| 151 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 152 | ++ |
+ #'+ |
+
| 153 | ++ |
+ #' @return+ |
+
| 154 | ++ |
+ #' * `count_abnormal_by_baseline()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 155 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 156 | ++ |
+ #' the statistics from `s_count_abnormal_by_baseline()` to the table layout.+ |
+
| 157 | ++ |
+ #'+ |
+
| 158 | ++ |
+ #' @examples+ |
+
| 159 | ++ |
+ #' df <- data.frame(+ |
+
| 160 | ++ |
+ #' USUBJID = as.character(c(1:6)),+ |
+
| 161 | ++ |
+ #' ANRIND = factor(c(rep("LOW", 4), "NORMAL", "HIGH")),
+ |
+
| 162 | ++ |
+ #' BNRIND = factor(c("LOW", "NORMAL", "HIGH", NA, "LOW", "NORMAL"))
+ |
+
| 163 | ++ |
+ #' )+ |
+
| 164 | ++ |
+ #' df <- df_explicit_na(df)+ |
+
| 165 | ++ |
+ #'+ |
+
| 166 | ++ |
+ #' # Layout creating function.+ |
+
| 167 | ++ |
+ #' basic_table() %>%+ |
+
| 168 | ++ |
+ #' count_abnormal_by_baseline(var = "ANRIND", abnormal = c(High = "HIGH")) %>%+ |
+
| 169 | ++ |
+ #' build_table(df)+ |
+
| 170 | ++ |
+ #'+ |
+
| 171 | ++ |
+ #' # Passing of statistics function and formatting arguments.+ |
+
| 172 | ++ |
+ #' df2 <- data.frame(+ |
+
| 173 | ++ |
+ #' ID = as.character(c(1, 2, 3, 4)),+ |
+
| 174 | ++ |
+ #' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
+ |
+
| 175 | ++ |
+ #' BLRANGE = factor(c("LOW", "HIGH", "HIGH", "NORMAL"))
+ |
+
| 176 | ++ |
+ #' )+ |
+
| 177 | ++ |
+ #'+ |
+
| 178 | ++ |
+ #' basic_table() %>%+ |
+
| 179 | ++ |
+ #' count_abnormal_by_baseline(+ |
+
| 180 | ++ |
+ #' var = "RANGE",+ |
+
| 181 | ++ |
+ #' abnormal = c(Low = "LOW"),+ |
+
| 182 | ++ |
+ #' variables = list(id = "ID", baseline = "BLRANGE"),+ |
+
| 183 | ++ |
+ #' .formats = c(fraction = "xx / xx"),+ |
+
| 184 | ++ |
+ #' .indent_mods = c(fraction = 2L)+ |
+
| 185 | ++ |
+ #' ) %>%+ |
+
| 186 | ++ |
+ #' build_table(df2)+ |
+
| 187 | ++ |
+ #'+ |
+
| 188 | ++ |
+ #' @export+ |
+
| 189 | ++ |
+ count_abnormal_by_baseline <- function(lyt,+ |
+
| 190 | ++ |
+ var,+ |
+
| 191 | ++ |
+ abnormal,+ |
+
| 192 | ++ |
+ na_str = "<Missing>",+ |
+
| 193 | ++ |
+ nested = TRUE,+ |
+
| 194 | ++ |
+ ...,+ |
+
| 195 | ++ |
+ table_names = abnormal,+ |
+
| 196 | ++ |
+ .stats = NULL,+ |
+
| 197 | ++ |
+ .formats = NULL,+ |
+
| 198 | ++ |
+ .labels = NULL,+ |
+
| 199 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 200 | +2x | +
+ checkmate::assert_character(abnormal, len = length(table_names), names = "named")+ |
+
| 201 | +2x | +
+ checkmate::assert_string(var)+ |
+
| 202 | +2x | +
+ afun <- make_afun(+ |
+
| 203 | +2x | +
+ a_count_abnormal_by_baseline,+ |
+
| 204 | +2x | +
+ .stats = .stats,+ |
+
| 205 | +2x | +
+ .formats = .formats,+ |
+
| 206 | +2x | +
+ .labels = .labels,+ |
+
| 207 | +2x | +
+ .indent_mods = .indent_mods,+ |
+
| 208 | +2x | +
+ .ungroup_stats = "fraction"+ |
+
| 209 | ++ |
+ )+ |
+
| 210 | +2x | +
+ for (i in seq_along(abnormal)) {
+ |
+
| 211 | +4x | +
+ abn <- abnormal[i]+ |
+
| 212 | +4x | +
+ lyt <- analyze(+ |
+
| 213 | +4x | +
+ lyt = lyt,+ |
+
| 214 | +4x | +
+ vars = var,+ |
+
| 215 | +4x | +
+ var_labels = names(abn),+ |
+
| 216 | +4x | +
+ afun = afun,+ |
+
| 217 | +4x | +
+ na_str = na_str,+ |
+
| 218 | +4x | +
+ nested = nested,+ |
+
| 219 | +4x | +
+ table_names = table_names[i],+ |
+
| 220 | +4x | +
+ extra_args = c(list(abnormal = abn, na_str = na_str), list(...)),+ |
+
| 221 | +4x | +
+ show_labels = "visible"+ |
+
| 222 | ++ |
+ )+ |
+
| 223 | ++ |
+ }+ |
+
| 224 | +2x | +
+ lyt+ |
+
| 225 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Count the Number of Patients with a Particular Event+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' The primary analysis variable `.var` denotes the unique patient identifier.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @seealso [count_patients_with_flags]+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @name count_patients_with_event+ |
+
| 12 | ++ |
+ NULL+ |
+
| 13 | ++ | + + | +
| 14 | ++ |
+ #' @describeIn count_patients_with_event Statistics function which counts the number of patients for which+ |
+
| 15 | ++ |
+ #' the defined event has occurred.+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @inheritParams analyze_variables+ |
+
| 18 | ++ |
+ #' @param .var (`character`)\cr name of the column that contains the unique identifier.+ |
+
| 19 | ++ |
+ #' @param filters (`character`)\cr a character vector specifying the column names and flag variables+ |
+
| 20 | ++ |
+ #' to be used for counting the number of unique identifiers satisfying such conditions.+ |
+
| 21 | ++ |
+ #' Multiple column names and flags are accepted in this format+ |
+
| 22 | ++ |
+ #' `c("column_name1" = "flag1", "column_name2" = "flag2")`.
+ |
+
| 23 | ++ |
+ #' Note that only equality is being accepted as condition.+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @return+ |
+
| 26 | ++ |
+ #' * `s_count_patients_with_event()` returns the count and fraction of unique identifiers with the defined event.+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @examples+ |
+
| 29 | ++ |
+ #' library(dplyr)+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' # `s_count_patients_with_event()`+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' s_count_patients_with_event(+ |
+
| 34 | ++ |
+ #' tern_ex_adae,+ |
+
| 35 | ++ |
+ #' .var = "SUBJID",+ |
+
| 36 | ++ |
+ #' filters = c("TRTEMFL" = "Y")
+ |
+
| 37 | ++ |
+ #' )+ |
+
| 38 | ++ |
+ #' s_count_patients_with_event(+ |
+
| 39 | ++ |
+ #' tern_ex_adae,+ |
+
| 40 | ++ |
+ #' .var = "SUBJID",+ |
+
| 41 | ++ |
+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL")
+ |
+
| 42 | ++ |
+ #' )+ |
+
| 43 | ++ |
+ #' s_count_patients_with_event(+ |
+
| 44 | ++ |
+ #' tern_ex_adae,+ |
+
| 45 | ++ |
+ #' .var = "SUBJID",+ |
+
| 46 | ++ |
+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
+ |
+
| 47 | ++ |
+ #' denom = "N_col",+ |
+
| 48 | ++ |
+ #' .N_col = 456+ |
+
| 49 | ++ |
+ #' )+ |
+
| 50 | ++ |
+ #'+ |
+
| 51 | ++ |
+ #' @export+ |
+
| 52 | ++ |
+ s_count_patients_with_event <- function(df,+ |
+
| 53 | ++ |
+ .var,+ |
+
| 54 | ++ |
+ filters,+ |
+
| 55 | ++ |
+ .N_col, # nolint+ |
+
| 56 | ++ |
+ .N_row, # nolint+ |
+
| 57 | ++ |
+ denom = c("n", "N_row", "N_col")) {
+ |
+
| 58 | +30x | +
+ col_names <- names(filters)+ |
+
| 59 | +30x | +
+ filter_values <- filters+ |
+
| 60 | ++ | + + | +
| 61 | +30x | +
+ checkmate::assert_subset(col_names, colnames(df))+ |
+
| 62 | ++ | + + | +
| 63 | +30x | +
+ temp <- Map(+ |
+
| 64 | +30x | +
+ function(x, y) which(df[[x]] == y),+ |
+
| 65 | +30x | +
+ col_names,+ |
+
| 66 | +30x | +
+ filter_values+ |
+
| 67 | ++ |
+ )+ |
+
| 68 | +30x | +
+ position_satisfy_filters <- Reduce(intersect, temp)+ |
+
| 69 | +30x | +
+ id_satisfy_filters <- as.character(unique(df[position_satisfy_filters, ][[.var]]))+ |
+
| 70 | +30x | +
+ result <- s_count_values(+ |
+
| 71 | +30x | +
+ as.character(unique(df[[.var]])),+ |
+
| 72 | +30x | +
+ id_satisfy_filters,+ |
+
| 73 | +30x | +
+ denom = denom,+ |
+
| 74 | +30x | +
+ .N_col = .N_col,+ |
+
| 75 | +30x | +
+ .N_row = .N_row+ |
+
| 76 | ++ |
+ )+ |
+
| 77 | +30x | +
+ result+ |
+
| 78 | ++ |
+ }+ |
+
| 79 | ++ | + + | +
| 80 | ++ |
+ #' @describeIn count_patients_with_event Formatted analysis function which is used as `afun`+ |
+
| 81 | ++ |
+ #' in `count_patients_with_event()`.+ |
+
| 82 | ++ |
+ #'+ |
+
| 83 | ++ |
+ #' @return+ |
+
| 84 | ++ |
+ #' * `a_count_patients_with_event()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 85 | ++ |
+ #'+ |
+
| 86 | ++ |
+ #' @examples+ |
+
| 87 | ++ |
+ #' # `a_count_patients_with_event()`+ |
+
| 88 | ++ |
+ #'+ |
+
| 89 | ++ |
+ #' a_count_patients_with_event(+ |
+
| 90 | ++ |
+ #' tern_ex_adae,+ |
+
| 91 | ++ |
+ #' .var = "SUBJID",+ |
+
| 92 | ++ |
+ #' filters = c("TRTEMFL" = "Y"),
+ |
+
| 93 | ++ |
+ #' .N_col = 100,+ |
+
| 94 | ++ |
+ #' .N_row = 100+ |
+
| 95 | ++ |
+ #' )+ |
+
| 96 | ++ |
+ #'+ |
+
| 97 | ++ |
+ #' @export+ |
+
| 98 | ++ |
+ a_count_patients_with_event <- make_afun(+ |
+
| 99 | ++ |
+ s_count_patients_with_event,+ |
+
| 100 | ++ |
+ .formats = c(count_fraction = format_count_fraction_fixed_dp)+ |
+
| 101 | ++ |
+ )+ |
+
| 102 | ++ | + + | +
| 103 | ++ |
+ #' @describeIn count_patients_with_event Layout-creating function which can take statistics function+ |
+
| 104 | ++ |
+ #' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 105 | ++ |
+ #'+ |
+
| 106 | ++ |
+ #' @return+ |
+
| 107 | ++ |
+ #' * `count_patients_with_event()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 108 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 109 | ++ |
+ #' the statistics from `s_count_patients_with_event()` to the table layout.+ |
+
| 110 | ++ |
+ #'+ |
+
| 111 | ++ |
+ #' @examples+ |
+
| 112 | ++ |
+ #' # `count_patients_with_event()`+ |
+
| 113 | ++ |
+ #'+ |
+
| 114 | ++ |
+ #' lyt <- basic_table() %>%+ |
+
| 115 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 116 | ++ |
+ #' add_colcounts() %>%+ |
+
| 117 | ++ |
+ #' count_values(+ |
+
| 118 | ++ |
+ #' "STUDYID",+ |
+
| 119 | ++ |
+ #' values = "AB12345",+ |
+
| 120 | ++ |
+ #' .stats = "count",+ |
+
| 121 | ++ |
+ #' .labels = c(count = "Total AEs")+ |
+
| 122 | ++ |
+ #' ) %>%+ |
+
| 123 | ++ |
+ #' count_patients_with_event(+ |
+
| 124 | ++ |
+ #' "SUBJID",+ |
+
| 125 | ++ |
+ #' filters = c("TRTEMFL" = "Y"),
+ |
+
| 126 | ++ |
+ #' .labels = c(count_fraction = "Total number of patients with at least one adverse event"),+ |
+
| 127 | ++ |
+ #' table_names = "tbl_all"+ |
+
| 128 | ++ |
+ #' ) %>%+ |
+
| 129 | ++ |
+ #' count_patients_with_event(+ |
+
| 130 | ++ |
+ #' "SUBJID",+ |
+
| 131 | ++ |
+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
+ |
+
| 132 | ++ |
+ #' .labels = c(count_fraction = "Total number of patients with fatal AEs"),+ |
+
| 133 | ++ |
+ #' table_names = "tbl_fatal"+ |
+
| 134 | ++ |
+ #' ) %>%+ |
+
| 135 | ++ |
+ #' count_patients_with_event(+ |
+
| 136 | ++ |
+ #' "SUBJID",+ |
+
| 137 | ++ |
+ #' filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL", "AEREL" = "Y"),
+ |
+
| 138 | ++ |
+ #' .labels = c(count_fraction = "Total number of patients with related fatal AEs"),+ |
+
| 139 | ++ |
+ #' .indent_mods = c(count_fraction = 2L),+ |
+
| 140 | ++ |
+ #' table_names = "tbl_rel_fatal"+ |
+
| 141 | ++ |
+ #' )+ |
+
| 142 | ++ |
+ #' build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl)+ |
+
| 143 | ++ |
+ #'+ |
+
| 144 | ++ |
+ #' @export+ |
+
| 145 | ++ |
+ count_patients_with_event <- function(lyt,+ |
+
| 146 | ++ |
+ vars,+ |
+
| 147 | ++ |
+ riskdiff = FALSE,+ |
+
| 148 | ++ |
+ na_str = NA_character_,+ |
+
| 149 | ++ |
+ nested = TRUE,+ |
+
| 150 | ++ |
+ ...,+ |
+
| 151 | ++ |
+ table_names = vars,+ |
+
| 152 | ++ |
+ .stats = "count_fraction",+ |
+
| 153 | ++ |
+ .formats = NULL,+ |
+
| 154 | ++ |
+ .labels = NULL,+ |
+
| 155 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 156 | +6x | +
+ checkmate::assert_flag(riskdiff)+ |
+
| 157 | ++ | + + | +
| 158 | +6x | +
+ afun <- make_afun(+ |
+
| 159 | +6x | +
+ a_count_patients_with_event,+ |
+
| 160 | +6x | +
+ .stats = .stats,+ |
+
| 161 | +6x | +
+ .formats = .formats,+ |
+
| 162 | +6x | +
+ .labels = .labels,+ |
+
| 163 | +6x | +
+ .indent_mods = .indent_mods+ |
+
| 164 | ++ |
+ )+ |
+
| 165 | ++ | + + | +
| 166 | +6x | +
+ extra_args <- if (isFALSE(riskdiff)) {
+ |
+
| 167 | +5x | +
+ list(...)+ |
+
| 168 | ++ |
+ } else {
+ |
+
| 169 | +1x | +
+ list(+ |
+
| 170 | +1x | +
+ afun = list("s_count_patients_with_event" = afun),
+ |
+
| 171 | +1x | +
+ .stats = .stats,+ |
+
| 172 | +1x | +
+ .indent_mods = .indent_mods,+ |
+
| 173 | +1x | +
+ s_args = list(...)+ |
+
| 174 | ++ |
+ )+ |
+
| 175 | ++ |
+ }+ |
+
| 176 | ++ | + + | +
| 177 | +6x | +
+ analyze(+ |
+
| 178 | +6x | +
+ lyt,+ |
+
| 179 | +6x | +
+ vars,+ |
+
| 180 | +6x | +
+ afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),+ |
+
| 181 | +6x | +
+ na_str = na_str,+ |
+
| 182 | +6x | +
+ nested = nested,+ |
+
| 183 | +6x | +
+ extra_args = extra_args,+ |
+
| 184 | +6x | +
+ show_labels = ifelse(length(vars) > 1, "visible", "hidden"),+ |
+
| 185 | +6x | +
+ table_names = table_names+ |
+
| 186 | ++ |
+ )+ |
+
| 187 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Cumulative Counts with Thresholds+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Summarize cumulative counts of a (`numeric`) vector that is less than, less or equal to,+ |
+
| 6 | ++ |
+ #' greater than, or greater or equal to user-specific thresholds.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams h_count_cumulative+ |
+
| 9 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @seealso Relevant helper function [h_count_cumulative()], and descriptive function [d_count_cumulative()].+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' @name count_cumulative+ |
+
| 14 | ++ |
+ NULL+ |
+
| 15 | ++ | + + | +
| 16 | ++ |
+ #' Helper Function for [s_count_cumulative()]+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' Helper function to calculate count and fraction of `x` values in the lower or upper tail given a threshold.+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 23 | ++ |
+ #' @param threshold (`number`)\cr a cutoff value as threshold to count values of `x`.+ |
+
| 24 | ++ |
+ #' @param lower_tail (`logical`)\cr whether to count lower tail, default is `TRUE`.+ |
+
| 25 | ++ |
+ #' @param include_eq (`logical`)\cr whether to include value equal to the `threshold` in+ |
+
| 26 | ++ |
+ #' count, default is `TRUE`.+ |
+
| 27 | ++ |
+ #' @param .N_col (`count`)\cr denominator for fraction calculation.+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @return A named vector with items:+ |
+
| 30 | ++ |
+ #' * `count`: the count of values less than, less or equal to, greater than, or greater or equal to a threshold+ |
+
| 31 | ++ |
+ #' of user specification.+ |
+
| 32 | ++ |
+ #' * `fraction`: the fraction of the count.+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' @seealso [count_cumulative]+ |
+
| 35 | ++ |
+ #'+ |
+
| 36 | ++ |
+ #' @examples+ |
+
| 37 | ++ |
+ #' set.seed(1, kind = "Mersenne-Twister")+ |
+
| 38 | ++ |
+ #' x <- c(sample(1:10, 10), NA)+ |
+
| 39 | ++ |
+ #' .N_col <- length(x)+ |
+
| 40 | ++ |
+ #' h_count_cumulative(x, 5, .N_col = .N_col)+ |
+
| 41 | ++ |
+ #' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na.rm = FALSE, .N_col = .N_col)+ |
+
| 42 | ++ |
+ #' h_count_cumulative(x, 0, lower_tail = FALSE, .N_col = .N_col)+ |
+
| 43 | ++ |
+ #' h_count_cumulative(x, 100, lower_tail = FALSE, .N_col = .N_col)+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' @export+ |
+
| 46 | ++ |
+ h_count_cumulative <- function(x,+ |
+
| 47 | ++ |
+ threshold,+ |
+
| 48 | ++ |
+ lower_tail = TRUE,+ |
+
| 49 | ++ |
+ include_eq = TRUE,+ |
+
| 50 | ++ |
+ na.rm = TRUE, # nolint+ |
+
| 51 | ++ |
+ .N_col) { # nolint
+ |
+
| 52 | +20x | +
+ checkmate::assert_numeric(x)+ |
+
| 53 | +20x | +
+ checkmate::assert_numeric(threshold)+ |
+
| 54 | +20x | +
+ checkmate::assert_numeric(.N_col)+ |
+
| 55 | +20x | +
+ checkmate::assert_flag(lower_tail)+ |
+
| 56 | +20x | +
+ checkmate::assert_flag(include_eq)+ |
+
| 57 | +20x | +
+ checkmate::assert_flag(na.rm)+ |
+
| 58 | ++ | + + | +
| 59 | +20x | +
+ is_keep <- if (na.rm) !is.na(x) else rep(TRUE, length(x))+ |
+
| 60 | +20x | +
+ count <- if (lower_tail && include_eq) {
+ |
+
| 61 | +7x | +
+ length(x[is_keep & x <= threshold])+ |
+
| 62 | +20x | +
+ } else if (lower_tail && !include_eq) {
+ |
+
| 63 | +! | +
+ length(x[is_keep & x < threshold])+ |
+
| 64 | +20x | +
+ } else if (!lower_tail && include_eq) {
+ |
+
| 65 | +6x | +
+ length(x[is_keep & x >= threshold])+ |
+
| 66 | +20x | +
+ } else if (!lower_tail && !include_eq) {
+ |
+
| 67 | +7x | +
+ length(x[is_keep & x > threshold])+ |
+
| 68 | ++ |
+ }+ |
+
| 69 | ++ | + + | +
| 70 | +20x | +
+ result <- c(count = count, fraction = count / .N_col)+ |
+
| 71 | +20x | +
+ result+ |
+
| 72 | ++ |
+ }+ |
+
| 73 | ++ | + + | +
| 74 | ++ |
+ #' Description of Cumulative Count+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 77 | ++ |
+ #'+ |
+
| 78 | ++ |
+ #' This is a helper function that describes the analysis in [s_count_cumulative()].+ |
+
| 79 | ++ |
+ #'+ |
+
| 80 | ++ |
+ #' @inheritParams h_count_cumulative+ |
+
| 81 | ++ |
+ #'+ |
+
| 82 | ++ |
+ #' @return Labels for [s_count_cumulative()].+ |
+
| 83 | ++ |
+ #'+ |
+
| 84 | ++ |
+ #' @export+ |
+
| 85 | ++ |
+ d_count_cumulative <- function(threshold, lower_tail, include_eq) {
+ |
+
| 86 | +18x | +
+ checkmate::assert_numeric(threshold)+ |
+
| 87 | +18x | +
+ lg <- if (lower_tail) "<" else ">"+ |
+
| 88 | +18x | +
+ eq <- if (include_eq) "=" else ""+ |
+
| 89 | +18x | +
+ paste0(lg, eq, " ", threshold)+ |
+
| 90 | ++ |
+ }+ |
+
| 91 | ++ | + + | +
| 92 | ++ |
+ #' @describeIn count_cumulative Statistics function that produces a named list given a numeric vector of thresholds.+ |
+
| 93 | ++ |
+ #'+ |
+
| 94 | ++ |
+ #' @param thresholds (`numeric`)\cr vector of cutoff value for the counts.+ |
+
| 95 | ++ |
+ #'+ |
+
| 96 | ++ |
+ #' @return+ |
+
| 97 | ++ |
+ #' * `s_count_cumulative()` returns a named list of `count_fraction`s: a list with each `thresholds` value as a+ |
+
| 98 | ++ |
+ #' component, each component containing a vector for the count and fraction.+ |
+
| 99 | ++ |
+ #'+ |
+
| 100 | ++ |
+ #' @keywords internal+ |
+
| 101 | ++ |
+ s_count_cumulative <- function(x,+ |
+
| 102 | ++ |
+ thresholds,+ |
+
| 103 | ++ |
+ lower_tail = TRUE,+ |
+
| 104 | ++ |
+ include_eq = TRUE,+ |
+
| 105 | ++ |
+ .N_col, # nolint+ |
+
| 106 | ++ |
+ ...) {
+ |
+
| 107 | +5x | +
+ checkmate::assert_numeric(thresholds, min.len = 1, any.missing = FALSE)+ |
+
| 108 | ++ | + + | +
| 109 | +5x | +
+ count_fraction_list <- Map(function(thres) {
+ |
+
| 110 | +10x | +
+ result <- h_count_cumulative(x, thres, lower_tail, include_eq, .N_col = .N_col, ...)+ |
+
| 111 | +10x | +
+ label <- d_count_cumulative(thres, lower_tail, include_eq)+ |
+
| 112 | +10x | +
+ formatters::with_label(result, label)+ |
+
| 113 | +5x | +
+ }, thresholds)+ |
+
| 114 | ++ | + + | +
| 115 | +5x | +
+ names(count_fraction_list) <- thresholds+ |
+
| 116 | +5x | +
+ list(count_fraction = count_fraction_list)+ |
+
| 117 | ++ |
+ }+ |
+
| 118 | ++ | + + | +
| 119 | ++ |
+ #' @describeIn count_cumulative Formatted analysis function which is used as `afun`+ |
+
| 120 | ++ |
+ #' in `count_cumulative()`.+ |
+
| 121 | ++ |
+ #'+ |
+
| 122 | ++ |
+ #' @return+ |
+
| 123 | ++ |
+ #' * `a_count_cumulative()` returns the corresponding list with formatted [rtables::CellValue()].+ |
+
| 124 | ++ |
+ #'+ |
+
| 125 | ++ |
+ #' @keywords internal+ |
+
| 126 | ++ |
+ a_count_cumulative <- make_afun(+ |
+
| 127 | ++ |
+ s_count_cumulative,+ |
+
| 128 | ++ |
+ .formats = c(count_fraction = format_count_fraction)+ |
+
| 129 | ++ |
+ )+ |
+
| 130 | ++ | + + | +
| 131 | ++ |
+ #' @describeIn count_cumulative Layout-creating function which can take statistics function arguments+ |
+
| 132 | ++ |
+ #' and additional format arguments. This function is a wrapper for [rtables::analyze()].+ |
+
| 133 | ++ |
+ #'+ |
+
| 134 | ++ |
+ #' @return+ |
+
| 135 | ++ |
+ #' * `count_cumulative()` returns a layout object suitable for passing to further layouting functions,+ |
+
| 136 | ++ |
+ #' or to [rtables::build_table()]. Adding this function to an `rtable` layout will add formatted rows containing+ |
+
| 137 | ++ |
+ #' the statistics from `s_count_cumulative()` to the table layout.+ |
+
| 138 | ++ |
+ #'+ |
+
| 139 | ++ |
+ #' @examples+ |
+
| 140 | ++ |
+ #' basic_table() %>%+ |
+
| 141 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+
| 142 | ++ |
+ #' add_colcounts() %>%+ |
+
| 143 | ++ |
+ #' count_cumulative(+ |
+
| 144 | ++ |
+ #' vars = "AGE",+ |
+
| 145 | ++ |
+ #' thresholds = c(40, 60)+ |
+
| 146 | ++ |
+ #' ) %>%+ |
+
| 147 | ++ |
+ #' build_table(tern_ex_adsl)+ |
+
| 148 | ++ |
+ #'+ |
+
| 149 | ++ |
+ #' @export+ |
+
| 150 | ++ |
+ count_cumulative <- function(lyt,+ |
+
| 151 | ++ |
+ vars,+ |
+
| 152 | ++ |
+ var_labels = vars,+ |
+
| 153 | ++ |
+ show_labels = "visible",+ |
+
| 154 | ++ |
+ na_str = NA_character_,+ |
+
| 155 | ++ |
+ nested = TRUE,+ |
+
| 156 | ++ |
+ ...,+ |
+
| 157 | ++ |
+ table_names = vars,+ |
+
| 158 | ++ |
+ .stats = NULL,+ |
+
| 159 | ++ |
+ .formats = NULL,+ |
+
| 160 | ++ |
+ .labels = NULL,+ |
+
| 161 | ++ |
+ .indent_mods = NULL) {
+ |
+
| 162 | +2x | +
+ afun <- make_afun(+ |
+
| 163 | +2x | +
+ a_count_cumulative,+ |
+
| 164 | +2x | +
+ .stats = .stats,+ |
+
| 165 | +2x | +
+ .formats = .formats,+ |
+
| 166 | +2x | +
+ .labels = .labels,+ |
+
| 167 | +2x | +
+ .indent_mods = .indent_mods,+ |
+
| 168 | +2x | +
+ .ungroup_stats = "count_fraction"+ |
+
| 169 | ++ |
+ )+ |
+
| 170 | +2x | +
+ analyze(+ |
+
| 171 | +2x | +
+ lyt,+ |
+
| 172 | +2x | +
+ vars,+ |
+
| 173 | +2x | +
+ afun = afun,+ |
+
| 174 | +2x | +
+ na_str = na_str,+ |
+
| 175 | +2x | +
+ table_names = table_names,+ |
+
| 176 | +2x | +
+ var_labels = var_labels,+ |
+
| 177 | +2x | +
+ show_labels = show_labels,+ |
+
| 178 | +2x | +
+ nested = nested,+ |
+
| 179 | +2x | +
+ extra_args = list(...)+ |
+
| 180 | ++ |
+ )+ |
+
| 181 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Helper Function for Deriving Analysis Datasets for `LBT13` and `LBT14`+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Helper function that merges `ADSL` and `ADLB` datasets so that missing lab test records are inserted in the+ |
+
| 6 | ++ |
+ #' output dataset. Remember that `na_level` must match the needed pre-processing+ |
+
| 7 | ++ |
+ #' done with [df_explicit_na()] to have the desired output.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @param adsl (`data.frame`)\cr `ADSL` dataframe.+ |
+
| 10 | ++ |
+ #' @param adlb (`data.frame`)\cr `ADLB` dataframe.+ |
+
| 11 | ++ |
+ #' @param worst_flag (named `vector`)\cr Worst post-baseline lab flag variable.+ |
+
| 12 | ++ |
+ #' @param by_visit (`logical`)\cr defaults to `FALSE` to generate worst grade per patient.+ |
+
| 13 | ++ |
+ #' If worst grade per patient per visit is specified for `worst_flag`, then+ |
+
| 14 | ++ |
+ #' `by_visit` should be `TRUE` to generate worst grade patient per visit.+ |
+
| 15 | ++ |
+ #' @param no_fillin_visits (named `character`)\cr Visits that are not considered for post-baseline worst toxicity+ |
+
| 16 | ++ |
+ #' grade. Defaults to `c("SCREENING", "BASELINE")`.
+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @return `df` containing variables shared between `adlb` and `adsl` along with variables `PARAM`, `PARAMCD`,+ |
+
| 19 | ++ |
+ #' `ATOXGR`, and `BTOXGR` relevant for analysis. Optionally, `AVISIT` are `AVISITN` are included when+ |
+
| 20 | ++ |
+ #' `by_visit = TRUE` and `no_fillin_visits = c("SCREENING", "BASELINE")`.
+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @details In the result data missing records will be created for the following situations:+ |
+
| 23 | ++ |
+ #' * Patients who are present in `adsl` but have no lab data in `adlb` (both baseline and post-baseline).+ |
+
| 24 | ++ |
+ #' * Patients who do not have any post-baseline lab values.+ |
+
| 25 | ++ |
+ #' * Patients without any post-baseline values flagged as the worst.+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' @examples+ |
+
| 28 | ++ |
+ #' # `h_adsl_adlb_merge_using_worst_flag`+ |
+
| 29 | ++ |
+ #' adlb_out <- h_adsl_adlb_merge_using_worst_flag(+ |
+
| 30 | ++ |
+ #' tern_ex_adsl,+ |
+
| 31 | ++ |
+ #' tern_ex_adlb,+ |
+
| 32 | ++ |
+ #' worst_flag = c("WGRHIFL" = "Y")
+ |
+
| 33 | ++ |
+ #' )+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' # `h_adsl_adlb_merge_using_worst_flag` by visit example+ |
+
| 36 | ++ |
+ #' adlb_out_by_visit <- h_adsl_adlb_merge_using_worst_flag(+ |
+
| 37 | ++ |
+ #' tern_ex_adsl,+ |
+
| 38 | ++ |
+ #' tern_ex_adlb,+ |
+
| 39 | ++ |
+ #' worst_flag = c("WGRLOVFL" = "Y"),
+ |
+
| 40 | ++ |
+ #' by_visit = TRUE+ |
+
| 41 | ++ |
+ #' )+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' @export+ |
+
| 44 | ++ |
+ h_adsl_adlb_merge_using_worst_flag <- function(adsl, # nolint+ |
+
| 45 | ++ |
+ adlb,+ |
+
| 46 | ++ |
+ worst_flag = c("WGRHIFL" = "Y"),
+ |
+
| 47 | ++ |
+ by_visit = FALSE,+ |
+
| 48 | ++ |
+ no_fillin_visits = c("SCREENING", "BASELINE")) {
+ |
+
| 49 | +5x | +
+ col_names <- names(worst_flag)+ |
+
| 50 | +5x | +
+ filter_values <- worst_flag+ |
+
| 51 | ++ | + + | +
| 52 | +5x | +
+ temp <- Map(+ |
+
| 53 | +5x | +
+ function(x, y) which(adlb[[x]] == y),+ |
+
| 54 | +5x | +
+ col_names,+ |
+
| 55 | +5x | +
+ filter_values+ |
+
| 56 | ++ |
+ )+ |
+
| 57 | ++ | + + | +
| 58 | +5x | +
+ position_satisfy_filters <- Reduce(intersect, temp)+ |
+
| 59 | ++ | + + | +
| 60 | +5x | +
+ adsl_adlb_common_columns <- intersect(colnames(adsl), colnames(adlb))+ |
+
| 61 | +5x | +
+ columns_from_adlb <- c("USUBJID", "PARAM", "PARAMCD", "AVISIT", "AVISITN", "ATOXGR", "BTOXGR")
+ |
+
| 62 | ++ | + + | +
| 63 | +5x | +
+ adlb_f <- adlb[position_satisfy_filters, ] %>%+ |
+
| 64 | +5x | +
+ dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits)+ |
+
| 65 | +5x | +
+ adlb_f <- adlb_f[, columns_from_adlb]+ |
+
| 66 | ++ | + + | +
| 67 | +5x | +
+ avisits_grid <- adlb %>%+ |
+
| 68 | +5x | +
+ dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) %>%+ |
+
| 69 | +5x | +
+ dplyr::pull(.data[["AVISIT"]]) %>%+ |
+
| 70 | +5x | +
+ unique()+ |
+
| 71 | ++ | + + | +
| 72 | +5x | +
+ if (by_visit) {
+ |
+
| 73 | +1x | +
+ adsl_lb <- expand.grid(+ |
+
| 74 | +1x | +
+ USUBJID = unique(adsl$USUBJID),+ |
+
| 75 | +1x | +
+ AVISIT = avisits_grid,+ |
+
| 76 | +1x | +
+ PARAMCD = unique(adlb$PARAMCD)+ |
+
| 77 | ++ |
+ )+ |
+
| 78 | ++ | + + | +
| 79 | +1x | +
+ adsl_lb <- adsl_lb %>%+ |
+
| 80 | +1x | +
+ dplyr::left_join(unique(adlb[c("AVISIT", "AVISITN")]), by = "AVISIT") %>%
+ |
+
| 81 | +1x | +
+ dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
+ |
+
| 82 | ++ | + + | +
| 83 | +1x | +
+ adsl1 <- adsl[, adsl_adlb_common_columns]+ |
+
| 84 | +1x | +
+ adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID")+ |
+
| 85 | ++ | + + | +
| 86 | +1x | +
+ by_variables_from_adlb <- c("USUBJID", "AVISIT", "AVISITN", "PARAMCD", "PARAM")
+ |
+
| 87 | ++ | + + | +
| 88 | +1x | +
+ adlb_btoxgr <- adlb %>%+ |
+
| 89 | +1x | +
+ dplyr::select(c("USUBJID", "PARAMCD", "BTOXGR")) %>%
+ |
+
| 90 | +1x | +
+ unique() %>%+ |
+
| 91 | +1x | +
+ dplyr::rename("BTOXGR_MAP" = "BTOXGR")
+ |
+
| 92 | ++ | + + | +
| 93 | +1x | +
+ adlb_out <- merge(+ |
+
| 94 | +1x | +
+ adlb_f,+ |
+
| 95 | +1x | +
+ adsl_lb,+ |
+
| 96 | +1x | +
+ by = by_variables_from_adlb,+ |
+
| 97 | +1x | +
+ all = TRUE,+ |
+
| 98 | +1x | +
+ sort = FALSE+ |
+
| 99 | ++ |
+ )+ |
+
| 100 | +1x | +
+ adlb_out <- adlb_out %>%+ |
+
| 101 | +1x | +
+ dplyr::left_join(adlb_btoxgr, by = c("USUBJID", "PARAMCD")) %>%
+ |
+
| 102 | +1x | +
+ dplyr::mutate(BTOXGR = .data$BTOXGR_MAP) %>%+ |
+
| 103 | +1x | +
+ dplyr::select(-"BTOXGR_MAP")+ |
+
| 104 | ++ | + + | +
| 105 | +1x | +
+ adlb_var_labels <- c(+ |
+
| 106 | +1x | +
+ formatters::var_labels(adlb[by_variables_from_adlb]),+ |
+
| 107 | +1x | +
+ formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]),+ |
+
| 108 | +1x | +
+ formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]])+ |
+
| 109 | ++ |
+ )+ |
+
| 110 | ++ |
+ } else {
+ |
+
| 111 | +4x | +
+ adsl_lb <- expand.grid(+ |
+
| 112 | +4x | +
+ USUBJID = unique(adsl$USUBJID),+ |
+
| 113 | +4x | +
+ PARAMCD = unique(adlb$PARAMCD)+ |
+
| 114 | ++ |
+ )+ |
+
| 115 | ++ | + + | +
| 116 | +4x | +
+ adsl_lb <- adsl_lb %>% dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")
+ |
+
| 117 | ++ | + + | +
| 118 | +4x | +
+ adsl1 <- adsl[, adsl_adlb_common_columns]+ |
+
| 119 | +4x | +
+ adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID")+ |
+
| 120 | ++ | + + | +
| 121 | +4x | +
+ by_variables_from_adlb <- c("USUBJID", "PARAMCD", "PARAM")
+ |
+
| 122 | ++ | + + | +
| 123 | +4x | +
+ adlb_out <- merge(+ |
+
| 124 | +4x | +
+ adlb_f,+ |
+
| 125 | +4x | +
+ adsl_lb,+ |
+
| 126 | +4x | +
+ by = by_variables_from_adlb,+ |
+
| 127 | +4x | +
+ all = TRUE,+ |
+
| 128 | +4x | +
+ sort = FALSE+ |
+
| 129 | ++ |
+ )+ |
+
| 130 | ++ | + + | +
| 131 | +4x | +
+ adlb_var_labels <- c(+ |
+
| 132 | +4x | +
+ formatters::var_labels(adlb[by_variables_from_adlb]),+ |
+
| 133 | +4x | +
+ formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]),+ |
+
| 134 | +4x | +
+ formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]])+ |
+
| 135 | ++ |
+ )+ |
+
| 136 | ++ |
+ }+ |
+
| 137 | ++ | + + | +
| 138 | +5x | +
+ adlb_out$ATOXGR <- as.factor(adlb_out$ATOXGR)+ |
+
| 139 | +5x | +
+ adlb_out$BTOXGR <- as.factor(adlb_out$BTOXGR)+ |
+
| 140 | ++ | + + | +
| 141 | +5x | +
+ formatters::var_labels(adlb_out) <- adlb_var_labels+ |
+
| 142 | ++ | + + | +
| 143 | +5x | +
+ adlb_out+ |
+
| 144 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Generate PK reference dataset+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @return `data.frame` of PK parameters+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @examples+ |
+
| 8 | ++ |
+ #' pk_reference_dataset <- d_pkparam()+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @export+ |
+
| 11 | ++ |
+ d_pkparam <- function() {
+ |
+
| 12 | +4x | +
+ pk_dataset <- as.data.frame(matrix(+ |
+
| 13 | +4x | +
+ c(+ |
+
| 14 | +4x | +
+ "TMAX", "Time of CMAX", "Tmax", "Plasma/Blood/Serum", "1",+ |
+
| 15 | +4x | +
+ "CMAX", "Max Conc", "Cmax", "Plasma/Blood/Serum", "2",+ |
+
| 16 | +4x | +
+ "CMAXD", "Max Conc Norm by Dose", "Cmax/D", "Plasma/Blood/Serum", "3",+ |
+
| 17 | +4x | +
+ "AUCIFO", "AUC Infinity Obs", "AUCinf obs", "Plasma/Blood/Serum", "4",+ |
+
| 18 | +4x | +
+ "AUCIFP", "AUC Infinity Pred", "AUCinf pred", "Plasma/Blood/Serum", "5",+ |
+
| 19 | +4x | +
+ "AUCIFOD", "AUC Infinity Obs Norm by Dose", "AUCinf/D obs", "Plasma/Blood/Serum", "6",+ |
+
| 20 | +4x | +
+ "AUCIFD", "AUC Infinity Pred Norm by Dose", "AUCinf/D pred", "Plasma/Blood/Serum", "7",+ |
+
| 21 | +4x | +
+ "AUCPEO", "AUC %Extrapolation Obs", "AUCinf extrap obs", "Plasma/Blood/Serum", "8",+ |
+
| 22 | +4x | +
+ "AUCPEP", "AUC %Extrapolation Pred", "AUCinf extrap pred", "Plasma/Blood/Serum", "9",+ |
+
| 23 | +4x | +
+ "AUCINT", "AUC from T1 to T2", "AUCupper-lower ", "Plasma/Blood/Serum", "10",+ |
+
| 24 | +4x | +
+ "AUCTAU", "AUC Over Dosing Interval", "AUCtau", "Plasma/Blood/Serum", "11",+ |
+
| 25 | +4x | +
+ "AUCLST", "AUC to Last Nonzero Conc", "AUClast", "Plasma/Blood/Serum", "12",+ |
+
| 26 | +4x | +
+ "AUCALL", "AUC All", "AUCall", "Plasma/Blood/Serum", "13",+ |
+
| 27 | +4x | +
+ "AUMCIFO", "AUMC Infinity Obs", "AUMCinf obs", "Plasma/Blood/Serum", "14",+ |
+
| 28 | +4x | +
+ "AUMCIFP", "AUMC Infinity Pred", "AUMCinf pred", "Plasma/Blood/Serum", "15",+ |
+
| 29 | +4x | +
+ "AUMCPEO", "AUMC % Extrapolation Obs", "AUMC extrap obs", "Plasma/Blood/Serum", "16",+ |
+
| 30 | +4x | +
+ "AUMCPEP", "AUMC % Extrapolation Pred", "AUMC extrap pred", "Plasma/Blood/Serum", "17",+ |
+
| 31 | +4x | +
+ "AUMCTAU", "AUMC Over Dosing Interval", "AUMCtau", "Plasma/Blood/Serum", "18",+ |
+
| 32 | +4x | +
+ "AUMCLST", "AUMC to Last Nonzero Conc", "AUMClast", "Plasma/Blood/Serum", "19",+ |
+
| 33 | +4x | +
+ "AURCIFO", "AURC Infinity Obs", "AURCinf obs", "Plasma/Blood/Serum", "20",+ |
+
| 34 | +4x | +
+ "AURCIFP", "AURC Infinity Pred", "AURCinf pred", "Plasma/Blood/Serum", "21",+ |
+
| 35 | +4x | +
+ "AURCPEO", "AURC % Extrapolation Obs", "AURC extrap obs", "Plasma/Blood/Serum", "22",+ |
+
| 36 | +4x | +
+ "AURCPEP", "AURC % Extrapolation Pred", "AURC extrap pred", "Plasma/Blood/Serum", "23",+ |
+
| 37 | +4x | +
+ "AURCLST", "AURC Dosing to Last Conc", "AURClast", "Plasma/Blood/Serum", "24",+ |
+
| 38 | +4x | +
+ "AURCALL", "AURC All", "AURCall", "Plasma/Blood/Serum", "25",+ |
+
| 39 | +4x | +
+ "TLST", "Time of Last Nonzero Conc", "Tlast", "Plasma/Blood/Serum", "26",+ |
+
| 40 | +4x | +
+ "CO", "Initial Conc", "CO", "Plasma/Blood/Serum", "27",+ |
+
| 41 | +4x | +
+ "C0", "Initial Conc", "C0", "Plasma/Blood/Serum", "28",+ |
+
| 42 | +4x | +
+ "CAVG", "Average Conc", "Cavg", "Plasma/Blood/Serum", "29",+ |
+
| 43 | +4x | +
+ "CLST", "Last Nonzero Conc", "Clast", "Plasma/Blood/Serum", "30",+ |
+
| 44 | +4x | +
+ "CMIN", "Min Conc", "Cmin", "Plasma/Blood/Serum", "31",+ |
+
| 45 | +4x | +
+ "LAMZHL", "Half-Life Lambda z", "t1/2", "Plasma/Blood/Serum", "32",+ |
+
| 46 | +4x | +
+ "CLFO", "Total CL Obs by F", "CL/F obs", "Plasma/Blood/Serum", "33",+ |
+
| 47 | +4x | +
+ "CLFP", "Total CL Pred by F", "CL/F pred", "Plasma/Blood/Serum", "34",+ |
+
| 48 | +4x | +
+ "CLO", "Total CL Obs", "CL obs", "Plasma/Blood/Serum", "35",+ |
+
| 49 | +4x | +
+ "CLP", "Total CL Pred", "CL pred", "Plasma/Blood/Serum", "36",+ |
+
| 50 | +4x | +
+ "CLSS", "Total CL Steady State Pred", "CLss", "Plasma/Blood/Serum", "37",+ |
+
| 51 | +4x | +
+ "CLSSF", "Total CL Steady State Pred by F", "CLss/F", "Plasma/Blood/Serum", "38",+ |
+
| 52 | +4x | +
+ "VZFO", "Vz Obs by F", "Vz/F obs", "Plasma/Blood/Serum", "39",+ |
+
| 53 | +4x | +
+ "VZFP", "Vz Pred by F", "Vz/F pred", "Plasma/Blood/Serum", "40",+ |
+
| 54 | +4x | +
+ "VZO", "Vz Obs", "Vz obs", "Plasma/Blood/Serum", "41",+ |
+
| 55 | +4x | +
+ "VZP", "Vz Pred", "Vz pred", "Plasma/Blood/Serum", "42",+ |
+
| 56 | +4x | +
+ "VSSO", "Vol Dist Steady State Obs", "Vss obs", "Plasma/Blood/Serum", "43",+ |
+
| 57 | +4x | +
+ "VSSP", "Vol Dist Steady State Pred", "Vss pred", "Plasma/Blood/Serum", "44",+ |
+
| 58 | +4x | +
+ "LAMZ", "Lambda z", "Lambda z", "Plasma/Blood/Serum", "45",+ |
+
| 59 | +4x | +
+ "LAMZLL", "Lambda z Lower Limit", "Lambda z lower", "Plasma/Blood/Serum", "46",+ |
+
| 60 | +4x | +
+ "LAMZUL", "Lambda z Upper Limit", "Lambda z upper", "Plasma/Blood/Serum", "47",+ |
+
| 61 | +4x | +
+ "LAMZNPT", "Number of Points for Lambda z", "No points Lambda z", "Plasma/Blood/Serum", "48",+ |
+
| 62 | +4x | +
+ "MRTIFO", "MRT Infinity Obs", "MRTinf obs", "Plasma/Blood/Serum", "49",+ |
+
| 63 | +4x | +
+ "MRTIFP", "MRT Infinity Pred", "MRTinf pred", "Plasma/Blood/Serum", "50",+ |
+
| 64 | +4x | +
+ "MRTLST", "MRT to Last Nonzero Conc", "MRTlast", "Plasma/Blood/Serum", "51",+ |
+
| 65 | +4x | +
+ "R2", "R Squared", "Rsq", "Plasma/Blood/Serum", "52",+ |
+
| 66 | +4x | +
+ "R2ADJ", "R Squared Adjusted", "Rsq adjusted", "Plasma/Blood/Serum", "53",+ |
+
| 67 | +4x | +
+ "TLAG", "Time Until First Nonzero Conc", "TIag", "Plasma/Blood/Serum", "54",+ |
+
| 68 | +4x | +
+ "TMIN", "Time of CMIN Observation", "Tmin", "Plasma/Blood/Serum", "55",+ |
+
| 69 | +4x | +
+ "ACCI", "Accumulation Index", "Accumulation Index", "Plasma/Blood/Serum/Urine", "56",+ |
+
| 70 | +4x | +
+ "FLUCP", "Fluctuation%", "Fluctuation", "Plasma/Blood/Serum", "57",+ |
+
| 71 | +4x | +
+ "CORRXY", "Correlation Between TimeX and Log ConcY", "Corr xy", "Plasma/Blood/Serum", "58",+ |
+
| 72 | +4x | +
+ "RCAMINT", "Amt Rec from T1 to T2", "Ae", "Urine", "59",+ |
+
| 73 | +4x | +
+ "RCPCINT", "Pct Rec from T1 to T2", "Fe", "Urine", "60",+ |
+
| 74 | +4x | +
+ "VOLPK", "Sum of Urine Vol", "Urine volume", "Urine", "61",+ |
+
| 75 | +4x | +
+ "RENALCL", "Renal CL", "CLR", "Plasma/Blood/Serum/Urine", "62",+ |
+
| 76 | +4x | +
+ "ERTMAX", "Time of Max Excretion Rate", "Tmax Rate", "Urine", "63",+ |
+
| 77 | +4x | +
+ "RMAX", "Time of Maximum Response", "Rmax", "Matrix of PD", "64",+ |
+
| 78 | +4x | +
+ "RMIN", "Time of Minimum Response", "Rmin", "Matrix of PD", "65",+ |
+
| 79 | +4x | +
+ "ERMAX", "Max Excretion Rate", "Max excretion rate", "Urine", "66",+ |
+
| 80 | +4x | +
+ "MIDPTLST", "Midpoint of Collection Interval", "Midpoint last", "Urine", "67",+ |
+
| 81 | +4x | +
+ "ERLST", "Last Meas Excretion Rate", "Rate last", "Urine", "68",+ |
+
| 82 | +4x | +
+ "TON", "Time to Onset", "Tonset", "Matrix of PD", "69",+ |
+
| 83 | +4x | +
+ "TOFF", "Time to Offset", "Toffset", "Matrix of PD", "70",+ |
+
| 84 | +4x | +
+ "TBBLP", "Time Below Baseline %", "Time %Below Baseline", "Matrix of PD", "71",+ |
+
| 85 | +4x | +
+ "TBTP", "Time Below Threshold %", "Time %Below Threshold", "Matrix of PD", "72",+ |
+
| 86 | +4x | +
+ "TABL", "Time Above Baseline", "Time Above Baseline", "Matrix of PD", "73",+ |
+
| 87 | +4x | +
+ "TAT", "Time Above Threshold", "Time Above Threshold", "Matrix of PD", "74",+ |
+
| 88 | +4x | +
+ "TBT", "Time Below Threshold", "Time Below Threshold", "Matrix of PD", "75",+ |
+
| 89 | +4x | +
+ "TBLT", "Time Between Baseline and Threshold", "Time Between Baseline Threshold", "Matrix of PD", "76",+ |
+
| 90 | +4x | +
+ "BLRSP", "Baseline Response", "Baseline", "Matrix of PD", "77",+ |
+
| 91 | +4x | +
+ "TSHDRSP", "Response Threshold", "Threshold", "Matrix of PD", "78",+ |
+
| 92 | +4x | +
+ "AUCABL", "AUC Above Baseline", "AUC above baseline", "Matrix of PD", "79",+ |
+
| 93 | +4x | +
+ "AUCAT", "AUC Above Threshold", "AUC above threshold", "Matrix of PD", "80",+ |
+
| 94 | +4x | +
+ "AUCBBL", "AUC Below Baseline", "AUC below baseline", "Matrix of PD", "81",+ |
+
| 95 | +4x | +
+ "AUCBT", "AUC Below Threshold", "AUC below threshold", "Matrix of PD", "82",+ |
+
| 96 | +4x | +
+ "AUCBLDIF", "Diff AUC Above Base and AUC Below Base", "AUC diff baseline", "Matrix of PD", "83",+ |
+
| 97 | +4x | +
+ "AUCTDIF", "Diff AUC Above Thr and AUC Below Thr", "AUCnet threshold", "Matrix of PD", "84",+ |
+
| 98 | +4x | +
+ "TDIFF", "Diff Time to Offset and Time to Onset", "Diff toffset-tonset", "Matrix of PD", "85",+ |
+
| 99 | +4x | +
+ "AUCPBEO", "AUC %Back Extrapolation Obs", "AUC%Back extrap obs", "Plasma/Blood/Serum", "86",+ |
+
| 100 | +4x | +
+ "AUCPBEP", "AUC %Back Extrapolation Pred", "AUC%Back extrap pred", "Plasma/Blood/Serum", "87",+ |
+
| 101 | +4x | +
+ "TSLP1L", "Lower Time Limit Slope 1st", "Slope1 lower", "Matrix of PD", "88",+ |
+
| 102 | +4x | +
+ "TSLP1U", "Upper Time Limit Slope 1st Segment", "Slope1 upper", "Matrix of PD", "89",+ |
+
| 103 | +4x | +
+ "TSLP2L", "Lower Time Limit Slope 2nd Segment", "Slope2 lower", "Matrix of PD", "90",+ |
+
| 104 | +4x | +
+ "TSLP2U", "Upper Time Limit Slope 2nd Segment", "Slope2 upper", "Matrix of PD", "91",+ |
+
| 105 | +4x | +
+ "SLP1", "Slope, 1st Segment", "Slope1", "Matrix of PD", "92",+ |
+
| 106 | +4x | +
+ "SLP2", "Slope, 2nd Segment", "Slope2", "Matrix of PD", "93",+ |
+
| 107 | +4x | +
+ "SLP1PT", "Number of Points for Slope 1st Segment", "No points slope1", "Matrix of PD", "94",+ |
+
| 108 | +4x | +
+ "SLP2PT", "Number of Points for Slope 2nd Segment", "No points slope2", "Matrix of PD", "95",+ |
+
| 109 | +4x | +
+ "R2ADJS1", "R-Squared Adjusted Slope, 1st Segment", "Rsq adjusted slope1", "Matrix of PD", "96",+ |
+
| 110 | +4x | +
+ "R2ADJS2", "R-Squared Adjusted Slope, 2nd Segment", "Rsq adjusted slope2", "Matrix of PD", "97",+ |
+
| 111 | +4x | +
+ "R2SLP1", "R Squared, Slope, 1st Segment", "Rsq slope1", "Matrix of PD", "98",+ |
+
| 112 | +4x | +
+ "R2SLP2", "R Squared, Slope, 2nd Segment", "Rsq slope2", "Matrix of PD", "99",+ |
+
| 113 | +4x | +
+ "CORRXYS1", "Corr Btw TimeX and Log ConcY, Slope 1st", "Corr xy slope1", "Plasma/Blood/Serum", "100",+ |
+
| 114 | +4x | +
+ "CORRXYS2", "Corr Btw TimeX and Log ConcY, Slope 1st Slope 2nd", "Corr xy slope2", "Plasma/Blood/Serum", "101",+ |
+
| 115 | +4x | +
+ "AILAMZ", "Accumulation Index using Lambda z", "AILAMZ", "Plasma/Blood/Serum", "102",+ |
+
| 116 | +4x | +
+ "ARAUC", "Accumulation Ratio AUCTAU", "ARAUC", "Plasma/Blood/Serum", "103",+ |
+
| 117 | +4x | +
+ "ARAUCD", "Accum Ratio AUCTAU norm by dose", "ARAUCD", "Plasma/Blood/Serum", "104",+ |
+
| 118 | +4x | +
+ "ARAUCIFO", "Accum Ratio AUC Infinity Obs", "ARAUCIFO", "Plasma/Blood/Serum", "105",+ |
+
| 119 | +4x | +
+ "ARAUCIFP", "Accum Ratio AUC Infinity Pred", "ARAUCIFP", "Plasma/Blood/Serum", "106",+ |
+
| 120 | +4x | +
+ "ARAUCIND", "Accum Ratio AUC T1 to T2 norm by dose", "ARAUCIND_T1_T2_UNIT", "Plasma/Blood/Serum", "107",+ |
+
| 121 | +4x | +
+ "ARAUCINT", "Accumulation Ratio AUC from T1 to T2", "ARAUCINT_T1_T2_UNIT", "Plasma/Blood/Serum", "108",+ |
+
| 122 | +4x | +
+ "ARAUCIOD", "Accum Ratio AUCIFO Norm by Dose", "ARAUCIOD", "Plasma/Blood/Serum", "109",+ |
+
| 123 | +4x | +
+ "ARAUCIPD", "Accum Ratio AUCIFP Norm by Dose", "ARAUCIPD", "Plasma/Blood/Serum", "110",+ |
+
| 124 | +4x | +
+ "ARAUCLST", "Accum Ratio AUC to Last Nonzero Conc", "ARAUCLST", "Plasma/Blood/Serum", "111",+ |
+
| 125 | +4x | +
+ "ARCMAX", "Accumulation Ratio Cmax", "ARCMAX", "Plasma/Blood/Serum", "112",+ |
+
| 126 | +4x | +
+ "ARCMAXD", "Accum Ratio Cmax norm by dose", "ARCMAXD", "Plasma/Blood/Serum", "113",+ |
+
| 127 | +4x | +
+ "ARCMIN", "Accumulation Ratio Cmin", "ARCMIN", "Plasma/Blood/Serum", "114",+ |
+
| 128 | +4x | +
+ "ARCMIND", "Accum Ratio Cmin norm by dose", "ARCMIND", "Plasma/Blood/Serum", "115",+ |
+
| 129 | +4x | +
+ "ARCTROUD", "Accum Ratio Ctrough norm by dose", "ARCTROUD", "Plasma/Blood/Serum", "116",+ |
+
| 130 | +4x | +
+ "ARCTROUG", "Accumulation Ratio Ctrough", "ARCTROUG", "Plasma/Blood/Serum", "117",+ |
+
| 131 | +4x | +
+ "AUCALLB", "AUC All Norm by BMI", "AUCall_B", "Plasma/Blood/Serum", "118",+ |
+
| 132 | +4x | +
+ "AUCALLD", "AUC All Norm by Dose", "AUCall_D", "Plasma/Blood/Serum", "119",+ |
+
| 133 | +4x | +
+ "AUCALLS", "AUC All Norm by SA", "AUCall_S", "Plasma/Blood/Serum", "120",+ |
+
| 134 | +4x | +
+ "AUCALLW", "AUC All Norm by WT", "AUCall_W", "Plasma/Blood/Serum", "121",+ |
+
| 135 | +4x | +
+ "AUCIFOB", "AUC Infinity Obs Norm by BMI", "AUCINF_obs_B", "Plasma/Blood/Serum", "122",+ |
+
| 136 | +4x | +
+ "AUCIFOLN", "AUC Infinity Obs LN Transformed", "AUCIFOLN", "Plasma/Blood/Serum", "123",+ |
+
| 137 | +4x | +
+ "AUCIFOS", "AUC Infinity Obs Norm by SA", "AUCINF_obs_S", "Plasma/Blood/Serum", "124",+ |
+
| 138 | +4x | +
+ "AUCIFOUB", "AUC Infinity Obs, Unbound Drug", "AUCIFOUB", "Plasma/Blood/Serum", "125",+ |
+
| 139 | +4x | +
+ "AUCIFOW", "AUC Infinity Obs Norm by WT", "AUCINF_obs_W", "Plasma/Blood/Serum", "126",+ |
+
| 140 | +4x | +
+ "AUCIFPB", "AUC Infinity Pred Norm by BMI", "AUCINF_pred_B", "Plasma/Blood/Serum", "127",+ |
+
| 141 | +4x | +
+ "AUCIFPD", "AUC Infinity Pred Norm by Dose", "AUCINF_pred_D", "Plasma/Blood/Serum", "128",+ |
+
| 142 | +4x | +
+ "AUCIFPS", "AUC Infinity Pred Norm by SA", "AUCINF_pred_S", "Plasma/Blood/Serum", "129",+ |
+
| 143 | +4x | +
+ "AUCIFPUB", "AUC Infinity Pred, Unbound Drug", "AUCIFPUB", "Plasma/Blood/Serum", "130",+ |
+
| 144 | +4x | +
+ "AUCIFPW", "AUC Infinity Pred Norm by WT", "AUCINF_pred_W", "Plasma/Blood/Serum", "131",+ |
+
| 145 | +4x | +
+ "AUCINTB", "AUC from T1 to T2 Norm by BMI", "AUC_B_T1_T2_UNIT", "Plasma/Blood/Serum", "132",+ |
+
| 146 | +4x | +
+ "AUCINTD", "AUC from T1 to T2 Norm by Dose", "AUC_D_T1_T2_UNIT", "Plasma/Blood/Serum", "133",+ |
+
| 147 | +4x | +
+ "AUCINTS", "AUC from T1 to T2 Norm by SA", "AUC_S_T1_T2_UNIT", "Plasma/Blood/Serum", "134",+ |
+
| 148 | +4x | +
+ "AUCINTW", "AUC from T1 to T2 Norm by WT", "AUC_W_T1_T2_UNIT", "Plasma/Blood/Serum", "135",+ |
+
| 149 | +4x | +
+ "AUCLSTB", "AUC to Last Nonzero Conc Norm by BMI", "AUClast_B", "Plasma/Blood/Serum", "136",+ |
+
| 150 | +4x | +
+ "AUCLSTD", "AUC to Last Nonzero Conc Norm by Dose", "AUClast_D", "Plasma/Blood/Serum", "137",+ |
+
| 151 | +4x | +
+ "AUCLSTLN", "AUC to Last Nonzero Conc LN Transformed", "AUCLSTLN", "Plasma/Blood/Serum", "138",+ |
+
| 152 | +4x | +
+ "AUCLSTS", "AUC to Last Nonzero Conc Norm by SA", "AUClast_S", "Plasma/Blood/Serum", "139",+ |
+
| 153 | +4x | +
+ "AUCLSTUB", "AUC to Last Nonzero Conc, Unbound Drug", "AUCLSTUB", "Plasma/Blood/Serum", "140",+ |
+
| 154 | +4x | +
+ "AUCLSTW", "AUC to Last Nonzero Conc Norm by WT", "AUClast_W", "Plasma/Blood/Serum", "141",+ |
+
| 155 | +4x | +
+ "AUCTAUB", "AUC Over Dosing Interval Norm by BMI", "AUC_TAU_B", "Plasma/Blood/Serum", "142",+ |
+
| 156 | +4x | +
+ "AUCTAUD", "AUC Over Dosing Interval Norm by Dose", "AUC_TAU_D", "Plasma/Blood/Serum", "143",+ |
+
| 157 | +4x | +
+ "AUCTAUS", "AUC Over Dosing Interval Norm by SA", "AUC_TAU_S", "Plasma/Blood/Serum", "144",+ |
+
| 158 | +4x | +
+ "AUCTAUW", "AUC Over Dosing Interval Norm by WT", "AUC_TAU_W", "Plasma/Blood/Serum", "145",+ |
+
| 159 | +4x | +
+ "AUMCIFOB", "AUMC Infinity Obs Norm by BMI", "AUMCINF_obs_B", "Plasma/Blood/Serum", "146",+ |
+
| 160 | +4x | +
+ "AUMCIFOD", "AUMC Infinity Obs Norm by Dose", "AUMCINF_obs_D", "Plasma/Blood/Serum", "147",+ |
+
| 161 | +4x | +
+ "AUMCIFOS", "AUMC Infinity Obs Norm by SA", "AUMCINF_obs_S", "Plasma/Blood/Serum", "148",+ |
+
| 162 | +4x | +
+ "AUMCIFOW", "AUMC Infinity Obs Norm by WT", "AUMCINF_obs_W", "Plasma/Blood/Serum", "149",+ |
+
| 163 | +4x | +
+ "AUMCIFPB", "AUMC Infinity Pred Norm by BMI", "AUMCINF_pred_B", "Plasma/Blood/Serum", "150",+ |
+
| 164 | +4x | +
+ "AUMCIFPD", "AUMC Infinity Pred Norm by Dose", "AUMCINF_pred_D", "Plasma/Blood/Serum", "151",+ |
+
| 165 | +4x | +
+ "AUMCIFPS", "AUMC Infinity Pred Norm by SA", "AUMCINF_pred_S", "Plasma/Blood/Serum", "152",+ |
+
| 166 | +4x | +
+ "AUMCIFPW", "AUMC Infinity Pred Norm by WT", "AUMCINF_pred_W", "Plasma/Blood/Serum", "153",+ |
+
| 167 | +4x | +
+ "AUMCLSTB", "AUMC to Last Nonzero Conc Norm by BMI", "AUMClast_B", "Plasma/Blood/Serum", "154",+ |
+
| 168 | +4x | +
+ "AUMCLSTD", "AUMC to Last Nonzero Conc Norm by Dose", "AUMClast_D", "Plasma/Blood/Serum", "155",+ |
+
| 169 | +4x | +
+ "AUMCLSTS", "AUMC to Last Nonzero Conc Norm by SA", "AUMClast_S", "Plasma/Blood/Serum", "156",+ |
+
| 170 | +4x | +
+ "AUMCLSTW", "AUMC to Last Nonzero Conc Norm by WT", "AUMClast_W", "Plasma/Blood/Serum", "157",+ |
+
| 171 | +4x | +
+ "AUMCTAUB", "AUMC Over Dosing Interval Norm by BMI", "AUMCTAUB", "Plasma/Blood/Serum", "158",+ |
+
| 172 | +4x | +
+ "AUMCTAUD", "AUMC Over Dosing Interval Norm by Dose", "AUMCTAUD", "Plasma/Blood/Serum", "159",+ |
+
| 173 | +4x | +
+ "AUMCTAUS", "AUMC Over Dosing Interval Norm by SA", "AUMCTAUS", "Plasma/Blood/Serum", "160",+ |
+
| 174 | +4x | +
+ "AUMCTAUW", "AUMC Over Dosing Interval Norm by WT", "AUMCTAUW", "Plasma/Blood/Serum", "161",+ |
+
| 175 | +4x | +
+ "AURCALLB", "AURC All Norm by BMI", "AURCALLB", "Plasma/Blood/Serum", "162",+ |
+
| 176 | +4x | +
+ "AURCALLD", "AURC All Norm by Dose", "AURCALLD", "Plasma/Blood/Serum", "163",+ |
+
| 177 | +4x | +
+ "AURCALLS", "AURC All Norm by SA", "AURCALLS", "Plasma/Blood/Serum", "164",+ |
+
| 178 | +4x | +
+ "AURCALLW", "AURC All Norm by WT", "AURCALLW", "Plasma/Blood/Serum", "165",+ |
+
| 179 | +4x | +
+ "AURCIFOB", "AURC Infinity Obs Norm by BMI", "AURCIFOB", "Plasma/Blood/Serum", "166",+ |
+
| 180 | +4x | +
+ "AURCIFOD", "AURC Infinity Obs Norm by Dose", "AURCIFOD", "Plasma/Blood/Serum", "167",+ |
+
| 181 | +4x | +
+ "AURCIFOS", "AURC Infinity Obs Norm by SA", "AURCIFOS", "Plasma/Blood/Serum", "168",+ |
+
| 182 | +4x | +
+ "AURCIFOW", "AURC Infinity Obs Norm by WT", "AURCIFOW", "Plasma/Blood/Serum", "169",+ |
+
| 183 | +4x | +
+ "AURCIFPB", "AURC Infinity Pred Norm by BMI", "AURCIFPB", "Plasma/Blood/Serum", "170",+ |
+
| 184 | +4x | +
+ "AURCIFPD", "AURC Infinity Pred Norm by Dose", "AURCIFPD", "Plasma/Blood/Serum", "171",+ |
+
| 185 | +4x | +
+ "AURCIFPS", "AURC Infinity Pred Norm by SA", "AURCIFPS", "Plasma/Blood/Serum", "172",+ |
+
| 186 | +4x | +
+ "AURCIFPW", "AURC Infinity Pred Norm by WT", "AURCIFPW", "Plasma/Blood/Serum", "173",+ |
+
| 187 | +4x | +
+ "AURCINT", "AURC from T1 to T2", "AURCINT_T1_T2_UNIT", "Plasma/Blood/Serum", "174",+ |
+
| 188 | +4x | +
+ "AURCINTB", "AURC from T1 to T2 Norm by BMI", "AURCINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "175",+ |
+
| 189 | +4x | +
+ "AURCINTD", "AURC from T1 to T2 Norm by Dose", "AURCINTD_T1_T2_UNIT", "Plasma/Blood/Serum", "176",+ |
+
| 190 | +4x | +
+ "AURCINTS", "AURC from T1 to T2 Norm by SA", "AURCINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "177",+ |
+
| 191 | +4x | +
+ "AURCINTW", "AURC from T1 to T2 Norm by WT", "AURCINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "178",+ |
+
| 192 | +4x | +
+ "AURCLSTB", "AURC to Last Nonzero Rate Norm by BMI", "AURCLSTB", "Plasma/Blood/Serum", "179",+ |
+
| 193 | +4x | +
+ "AURCLSTD", "AURC to Last Nonzero Rate Norm by Dose", "AURCLSTD", "Plasma/Blood/Serum", "180",+ |
+
| 194 | +4x | +
+ "AURCLSTS", "AURC to Last Nonzero Rate Norm by SA", "AURCLSTS", "Plasma/Blood/Serum", "181",+ |
+
| 195 | +4x | +
+ "AURCLSTW", "AURC to Last Nonzero Rate Norm by WT", "AURCLSTW", "Plasma/Blood/Serum", "182",+ |
+
| 196 | +4x | +
+ "C0B", "Initial Conc Norm by BMI", "C0B", "Plasma/Blood/Serum", "183",+ |
+
| 197 | +4x | +
+ "C0D", "Initial Conc Norm by Dose", "C0D", "Plasma/Blood/Serum", "184",+ |
+
| 198 | +4x | +
+ "C0S", "Initial Conc Norm by SA", "C0S", "Plasma/Blood/Serum", "185",+ |
+
| 199 | +4x | +
+ "C0W", "Initial Conc Norm by WT", "C0W", "Plasma/Blood/Serum", "186",+ |
+
| 200 | +4x | +
+ "CAVGB", "Average Conc Norm by BMI", "CAVGB", "Plasma/Blood/Serum", "187",+ |
+
| 201 | +4x | +
+ "CAVGD", "Average Conc Norm by Dose", "CAVGD", "Plasma/Blood/Serum", "188",+ |
+
| 202 | +4x | +
+ "CAVGINT", "Average Conc from T1 to T2", "CAVGINT_T1_T2_UNIT", "Plasma/Blood/Serum", "189",+ |
+
| 203 | +4x | +
+ "CAVGINTB", "Average Conc from T1 to T2 Norm by BMI", "CAVGINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "190",+ |
+
| 204 | +4x | +
+ "CAVGINTD", "Average Conc from T1 to T2 Norm by Dose", "CAVGINTD_T1_T2_UNIT", "Plasma/Blood/Serum", "191",+ |
+
| 205 | +4x | +
+ "CAVGINTS", "Average Conc from T1 to T2 Norm by SA", "CAVGINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "192",+ |
+
| 206 | +4x | +
+ "CAVGINTW", "Average Conc from T1 to T2 Norm by WT", "CAVGINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "193",+ |
+
| 207 | +4x | +
+ "CAVGS", "Average Conc Norm by SA", "CAVGS", "Plasma/Blood/Serum", "194",+ |
+
| 208 | +4x | +
+ "CAVGW", "Average Conc Norm by WT", "CAVGW", "Plasma/Blood/Serum", "195",+ |
+
| 209 | +4x | +
+ "CHTMAX", "Concentration at Half Tmax", "CHTMAX", "Plasma/Blood/Serum", "196",+ |
+
| 210 | +4x | +
+ "CLFOB", "Total CL Obs by F Norm by BMI", "CLFOB", "Plasma/Blood/Serum", "197",+ |
+
| 211 | +4x | +
+ "CLFOD", "Total CL Obs by F Norm by Dose", "CLFOD", "Plasma/Blood/Serum", "198",+ |
+
| 212 | +4x | +
+ "CLFOS", "Total CL Obs by F Norm by SA", "CLFOS", "Plasma/Blood/Serum", "199",+ |
+
| 213 | +4x | +
+ "CLFOW", "Total CL Obs by F Norm by WT", "CLFOW", "Plasma/Blood/Serum", "200",+ |
+
| 214 | +4x | +
+ "CLFPB", "Total CL Pred by F Norm by BMI", "CLFPB", "Plasma/Blood/Serum", "201",+ |
+
| 215 | +4x | +
+ "CLFPD", "Total CL Pred by F Norm by Dose", "CLFPD", "Plasma/Blood/Serum", "202",+ |
+
| 216 | +4x | +
+ "CLFPS", "Total CL Pred by F Norm by SA", "CLFPS", "Plasma/Blood/Serum", "203",+ |
+
| 217 | +4x | +
+ "CLFPW", "Total CL Pred by F Norm by WT", "CLFPW", "Plasma/Blood/Serum", "204",+ |
+
| 218 | +4x | +
+ "CLFTAU", "Total CL by F for Dose Int", "CLFTAU", "Plasma/Blood/Serum", "205",+ |
+
| 219 | +4x | +
+ "CLFTAUB", "Total CL by F for Dose Int Norm by BMI", "CLFTAUB", "Plasma/Blood/Serum", "206",+ |
+
| 220 | +4x | +
+ "CLFTAUD", "Total CL by F for Dose Int Norm by Dose", "CLFTAUD", "Plasma/Blood/Serum", "207",+ |
+
| 221 | +4x | +
+ "CLFTAUS", "Total CL by F for Dose Int Norm by SA", "CLFTAUS", "Plasma/Blood/Serum", "208",+ |
+
| 222 | +4x | +
+ "CLFTAUW", "Total CL by F for Dose Int Norm by WT", "CLFTAUW", "Plasma/Blood/Serum", "209",+ |
+
| 223 | +4x | +
+ "CLFUB", "Apparent CL for Unbound Drug", "CLFUB", "Plasma/Blood/Serum", "210",+ |
+
| 224 | +4x | +
+ "CLOB", "Total CL Obs Norm by BMI", "CLOB", "Plasma/Blood/Serum", "211",+ |
+
| 225 | +4x | +
+ "CLOD", "Total CL Obs Norm by Dose", "CLOD", "Plasma/Blood/Serum", "212",+ |
+
| 226 | +4x | +
+ "CLOS", "Total CL Obs Norm by SA", "CLOS", "Plasma/Blood/Serum", "213",+ |
+
| 227 | +4x | +
+ "CLOUB", "Total CL Obs for Unbound Drug", "CLOUB", "Plasma/Blood/Serum", "214",+ |
+
| 228 | +4x | +
+ "CLOW", "Total CL Obs Norm by WT", "CLOW", "Plasma/Blood/Serum", "215",+ |
+
| 229 | +4x | +
+ "CLPB", "Total CL Pred Norm by BMI", "CLPB", "Plasma/Blood/Serum", "216",+ |
+
| 230 | +4x | +
+ "CLPD", "Total CL Pred Norm by Dose", "CLPD", "Plasma/Blood/Serum", "217",+ |
+
| 231 | +4x | +
+ "CLPS", "Total CL Pred Norm by SA", "CLPS", "Plasma/Blood/Serum", "218",+ |
+
| 232 | +4x | +
+ "CLPUB", "Total CL Pred for Unbound Drug", "CLPUB", "Plasma/Blood/Serum", "219",+ |
+
| 233 | +4x | +
+ "CLPW", "Total CL Pred Norm by WT", "CLPW", "Plasma/Blood/Serum", "220",+ |
+
| 234 | +4x | +
+ "CLRPCLEV", "Renal CL as Pct CL EV", "CLRPCLEV", "Urine", "221",+ |
+
| 235 | +4x | +
+ "CLRPCLIV", "Renal CL as Pct CL IV", "CLRPCLIV", "Urine", "222",+ |
+
| 236 | +4x | +
+ "CLSTB", "Last Nonzero Conc Norm by BMI", "CLSTB", "Plasma/Blood/Serum", "223",+ |
+
| 237 | +4x | +
+ "CLSTD", "Last Nonzero Conc Norm by Dose", "CLSTD", "Plasma/Blood/Serum", "224",+ |
+
| 238 | +4x | +
+ "CLSTS", "Last Nonzero Conc Norm by SA", "CLSTS", "Plasma/Blood/Serum", "225",+ |
+
| 239 | +4x | +
+ "CLSTW", "Last Nonzero Conc Norm by WT", "CLSTW", "Plasma/Blood/Serum", "226",+ |
+
| 240 | +4x | +
+ "CLTAU", "Total CL for Dose Int", "CLTAU", "Plasma/Blood/Serum", "227",+ |
+
| 241 | +4x | +
+ "CLTAUB", "Total CL for Dose Int Norm by BMI", "CLTAUB", "Plasma/Blood/Serum", "228",+ |
+
| 242 | +4x | +
+ "CLTAUD", "Total CL for Dose Int Norm by Dose", "CLTAUD", "Plasma/Blood/Serum", "229",+ |
+
| 243 | +4x | +
+ "CLTAUS", "Total CL for Dose Int Norm by SA", "CLTAUS", "Plasma/Blood/Serum", "230",+ |
+
| 244 | +4x | +
+ "CLTAUW", "Total CL for Dose Int Norm by WT", "CLTAUW", "Plasma/Blood/Serum", "231",+ |
+
| 245 | +4x | +
+ "CMAXB", "Max Conc Norm by BMI", "CMAX_B", "Plasma/Blood/Serum", "232",+ |
+
| 246 | +4x | +
+ "CMAXLN", "Max Conc LN Transformed", "CMAXLN", "Plasma/Blood/Serum", "233",+ |
+
| 247 | +4x | +
+ "CMAXS", "Max Conc Norm by SA", "CMAXS", "Plasma/Blood/Serum", "234",+ |
+
| 248 | +4x | +
+ "CMAXUB", "Max Conc, Unbound Drug", "CMAXUB", "Plasma/Blood/Serum", "235",+ |
+
| 249 | +4x | +
+ "CMAXW", "Max Conc Norm by WT", "CMAXW", "Plasma/Blood/Serum", "236",+ |
+
| 250 | +4x | +
+ "CMINB", "Min Conc Norm by BMI", "CMINB", "Plasma/Blood/Serum", "237",+ |
+
| 251 | +4x | +
+ "CMIND", "Min Conc Norm by Dose", "CMIND", "Plasma/Blood/Serum", "238",+ |
+
| 252 | +4x | +
+ "CMINS", "Min Conc Norm by SA", "CMINS", "Plasma/Blood/Serum", "239",+ |
+
| 253 | +4x | +
+ "CMINW", "Min Conc Norm by WT", "CMINW", "Plasma/Blood/Serum", "240",+ |
+
| 254 | +4x | +
+ "CONC", "Concentration", "CONC", "Plasma/Blood/Serum", "241",+ |
+
| 255 | +4x | +
+ "CONCB", "Conc by BMI", "CONCB", "Plasma/Blood/Serum", "242",+ |
+
| 256 | +4x | +
+ "CONCD", "Conc by Dose", "CONCD", "Plasma/Blood/Serum", "243",+ |
+
| 257 | +4x | +
+ "CONCS", "Conc by SA", "CONCS", "Plasma/Blood/Serum", "244",+ |
+
| 258 | +4x | +
+ "CONCW", "Conc by WT", "CONCW", "Plasma/Blood/Serum", "245",+ |
+
| 259 | +4x | +
+ "CTROUGH", "Conc Trough", "CTROUGH", "Plasma/Blood/Serum", "246",+ |
+
| 260 | +4x | +
+ "CTROUGHB", "Conc Trough by BMI", "CTROUGHB", "Plasma/Blood/Serum", "247",+ |
+
| 261 | +4x | +
+ "CTROUGHD", "Conc Trough by Dose", "CTROUGHD", "Plasma/Blood/Serum", "248",+ |
+
| 262 | +4x | +
+ "CTROUGHS", "Conc Trough by SA", "CTROUGHS", "Plasma/Blood/Serum", "249",+ |
+
| 263 | +4x | +
+ "CTROUGHW", "Conc Trough by WT", "CTROUGHW", "Plasma/Blood/Serum", "250",+ |
+
| 264 | +4x | +
+ "EFFHL", "Effective Half-Life", "EFFHL", "Plasma/Blood/Serum", "251",+ |
+
| 265 | +4x | +
+ "ERINT", "Excret Rate from T1 to T2", "ERINT_T1_T2_UNIT", "Plasma/Blood/Serum", "252",+ |
+
| 266 | +4x | +
+ "ERINTB", "Excret Rate from T1 to T2 Norm by BMI", "ERINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "253",+ |
+
| 267 | +4x | +
+ "ERINTD", "Excret Rate from T1 to T2 Norm by Dose", "ERINTD_T1_T2_UNIT", "Plasma/Blood/Serum", "254",+ |
+
| 268 | +4x | +
+ "ERINTS", "Excret Rate from T1 to T2 Norm by SA", "ERINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "255",+ |
+
| 269 | +4x | +
+ "ERINTW", "Excret Rate from T1 to T2 Norm by WT", "ERINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "256",+ |
+
| 270 | +4x | +
+ "ERLSTB", "Last Meas Excretion Rate Norm by BMI", "ERLSTB", "Plasma/Blood/Serum", "257",+ |
+
| 271 | +4x | +
+ "ERLSTD", "Last Meas Excretion Rate Norm by Dose", "ERLSTD", "Plasma/Blood/Serum", "258",+ |
+
| 272 | +4x | +
+ "ERLSTS", "Last Meas Excretion Rate Norm by SA", "ERLSTS", "Plasma/Blood/Serum", "259",+ |
+
| 273 | +4x | +
+ "ERLSTW", "Last Meas Excretion Rate Norm by WT", "ERLSTW", "Plasma/Blood/Serum", "260",+ |
+
| 274 | +4x | +
+ "ERMAXB", "Max Excretion Rate Norm by BMI", "ERMAXB", "Plasma/Blood/Serum", "261",+ |
+
| 275 | +4x | +
+ "ERMAXD", "Max Excretion Rate Norm by Dose", "ERMAXD", "Plasma/Blood/Serum", "262",+ |
+
| 276 | +4x | +
+ "ERMAXS", "Max Excretion Rate Norm by SA", "ERMAXS", "Plasma/Blood/Serum", "263",+ |
+
| 277 | +4x | +
+ "ERMAXW", "Max Excretion Rate Norm by WT", "ERMAXW", "Plasma/Blood/Serum", "264",+ |
+
| 278 | +4x | +
+ "ERTLST", "Midpoint of Interval of Last Nonzero ER", "ERTLST", "Plasma/Blood/Serum", "265",+ |
+
| 279 | +4x | +
+ "FABS", "Absolute Bioavailability", "FABS", "Plasma/Blood/Serum", "266",+ |
+
| 280 | +4x | +
+ "FB", "Fraction Bound", "FB", "Plasma/Blood/Serum", "267",+ |
+
| 281 | +4x | +
+ "FREL", "Relative Bioavailability", "FREL", "Plasma/Blood/Serum", "268",+ |
+
| 282 | +4x | +
+ "FREXINT", "Fract Excr from T1 to T2", "FREXINT_T1_T2_UNIT", "Plasma/Blood/Serum", "269",+ |
+
| 283 | +4x | +
+ "FU", "Fraction Unbound", "FU", "Plasma/Blood/Serum", "270",+ |
+
| 284 | +4x | +
+ "HDCL", "Hemodialysis Clearance", "HDCL", "Plasma/Blood/Serum", "271",+ |
+
| 285 | +4x | +
+ "HDER", "Hemodialysis Extraction Ratio", "HDER", "Plasma/Blood/Serum", "272",+ |
+
| 286 | +4x | +
+ "HTMAX", "Half Tmax", "HTMAX", "Plasma/Blood/Serum", "273",+ |
+
| 287 | +4x | +
+ "LAMZLTAU", "Lambda z Lower Limit TAU", "LAMZLTAU", "Plasma/Blood/Serum", "274",+ |
+
| 288 | +4x | +
+ "LAMZNTAU", "Number of Points for Lambda z TAU", "LAMZNTAU", "Plasma/Blood/Serum", "275",+ |
+
| 289 | +4x | +
+ "LAMZSPN", "Lambda z Span", "LAMZSPN", "Plasma/Blood/Serum", "276",+ |
+
| 290 | +4x | +
+ "LAMZTAU", "Lambda z TAU", "LAMZTAU", "Plasma/Blood/Serum", "277",+ |
+
| 291 | +4x | +
+ "LAMZUTAU", "Lambda z Upper Limit TAU", "LAMZUTAU", "Plasma/Blood/Serum", "278",+ |
+
| 292 | +4x | +
+ "MAT", "Mean Absorption Time", "MAT", "Plasma/Blood/Serum", "279",+ |
+
| 293 | +4x | +
+ "MRAUCIFO", "Metabolite Ratio for AUC Infinity Obs", "MRAUCIFO", "Plasma/Blood/Serum", "280",+ |
+
| 294 | +4x | +
+ "MRAUCIFP", "Metabolite Ratio for AUC Infinity Pred", "MRAUCIFP", "Plasma/Blood/Serum", "281",+ |
+
| 295 | +4x | +
+ "MRAUCINT", "Metabolite Ratio AUC from T1 to T2", "MRAUCINT_T1_T2_UNIT", "Plasma/Blood/Serum", "282",+ |
+
| 296 | +4x | +
+ "MRAUCLST", "Metabolite Ratio AUC Last Nonzero Conc", "MRAUCLST", "Plasma/Blood/Serum", "283",+ |
+
| 297 | +4x | +
+ "MRAUCTAU", "Metabolite Ratio for AUC Dosing Interval", "MRAUCTAU", "Plasma/Blood/Serum", "284",+ |
+
| 298 | +4x | +
+ "MRCMAX", "Metabolite Ratio for Max Conc", "MRCMAX", "Plasma/Blood/Serum", "285",+ |
+
| 299 | +4x | +
+ "MRTEVIFO", "MRT Extravasc Infinity Obs", "MRTEVIFO", "Plasma/Blood/Serum", "286",+ |
+
| 300 | +4x | +
+ "MRTEVIFP", "MRT Extravasc Infinity Pred", "MRTEVIFP", "Plasma/Blood/Serum", "287",+ |
+
| 301 | +4x | +
+ "MRTEVLST", "MRT Extravasc to Last Nonzero Conc", "MRTEVLST", "Plasma/Blood/Serum", "288",+ |
+
| 302 | +4x | +
+ "MRTIVIFO", "MRT Intravasc Infinity Obs", "MRTIVIFO", "Plasma/Blood/Serum", "289",+ |
+
| 303 | +4x | +
+ "MRTIVIFP", "MRT Intravasc Infinity Pred", "MRTIVIFP", "Plasma/Blood/Serum", "290",+ |
+
| 304 | +4x | +
+ "MRTIVLST", "MRT Intravasc to Last Nonzero Conc", "MRTIVLST", "Plasma/Blood/Serum", "291",+ |
+
| 305 | +4x | +
+ "NRENALCL", "Nonrenal CL", "NRENALCL", "Urine", "292",+ |
+
| 306 | +4x | +
+ "NRENLCLB", "Nonrenal CL Norm by BMI", "NRENLCLB", "Urine", "293",+ |
+
| 307 | +4x | +
+ "NRENLCLD", "Nonrenal CL Norm by Dose", "NRENLCLD", "Urine", "294",+ |
+
| 308 | +4x | +
+ "NRENLCLS", "Nonrenal CL Norm by SA", "NRENLCLS", "Urine", "295",+ |
+
| 309 | +4x | +
+ "NRENLCLW", "Nonrenal CL Norm by WT", "NRENLCLW", "Urine", "296",+ |
+
| 310 | +4x | +
+ "PTROUGHR", "Peak Trough Ratio", "PTROUGHR", "Plasma/Blood/Serum", "297",+ |
+
| 311 | +4x | +
+ "RAAUC", "Ratio AUC", "RAAUC", "Plasma/Blood/Serum", "298",+ |
+
| 312 | +4x | +
+ "RAAUCIFO", "Ratio AUC Infinity Obs", "RAAUCIFO", "Plasma/Blood/Serum", "299",+ |
+
| 313 | +4x | +
+ "RAAUCIFP", "Ratio AUC Infinity Pred", "RAAUCIFP", "Plasma/Blood/Serum", "300",+ |
+
| 314 | +4x | +
+ "RACMAX", "Ratio CMAX", "RACMAX", "Plasma/Blood/Serum", "301",+ |
+
| 315 | +4x | +
+ "RAMAXMIN", "Ratio of CMAX to CMIN", "RAMAXMIN", "Plasma/Blood/Serum", "302",+ |
+
| 316 | +4x | +
+ "RCAMIFO", "Amt Rec Infinity Obs", "RCAMIFO", "Plasma/Blood/Serum", "303",+ |
+
| 317 | +4x | +
+ "RCAMIFOB", "Amt Rec Infinity Obs Norm by BMI", "RCAMIFOB", "Plasma/Blood/Serum", "304",+ |
+
| 318 | +4x | +
+ "RCAMIFOS", "Amt Rec Infinity Obs Norm by SA", "RCAMIFOS", "Plasma/Blood/Serum", "305",+ |
+
| 319 | +4x | +
+ "RCAMIFOW", "Amt Rec Infinity Obs Norm by WT", "RCAMIFOW", "Plasma/Blood/Serum", "306",+ |
+
| 320 | +4x | +
+ "RCAMIFP", "Amt Rec Infinity Pred", "RCAMIFP", "Plasma/Blood/Serum", "307",+ |
+
| 321 | +4x | +
+ "RCAMIFPB", "Amt Rec Infinity Pred Norm by BMI", "RCAMIFPB", "Plasma/Blood/Serum", "308",+ |
+
| 322 | +4x | +
+ "RCAMIFPS", "Amt Rec Infinity Pred Norm by SA", "RCAMIFPS", "Plasma/Blood/Serum", "309",+ |
+
| 323 | +4x | +
+ "RCAMIFPW", "Amt Rec Infinity Pred Norm by WT", "RCAMIFPW", "Plasma/Blood/Serum", "310",+ |
+
| 324 | +4x | +
+ "RCAMINTB", "Amt Rec from T1 to T2 Norm by BMI", "RCAMINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "311",+ |
+
| 325 | +4x | +
+ "RCAMINTS", "Amt Rec from T1 to T2 Norm by SA", "RCAMINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "312",+ |
+
| 326 | +4x | +
+ "RCAMINTW", "Amt Rec from T1 to T2 Norm by WT", "RCAMINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "313",+ |
+
| 327 | +4x | +
+ "RCAMTAU", "Amt Rec Over Dosing Interval", "RCAMTAU", "Plasma/Blood/Serum", "314",+ |
+
| 328 | +4x | +
+ "RCAMTAUB", "Amt Rec Over Dosing Interval Norm by BMI", "RCAMTAUB", "Plasma/Blood/Serum", "315",+ |
+
| 329 | +4x | +
+ "RCAMTAUS", "Amt Rec Over Dosing Interval Norm by SA", "RCAMTAUS", "Plasma/Blood/Serum", "316",+ |
+
| 330 | +4x | +
+ "RCAMTAUW", "Amt Rec Over Dosing Interval Norm by WT", "RCAMTAUW", "Plasma/Blood/Serum", "317",+ |
+
| 331 | +4x | +
+ "RCPCIFO", "Pct Rec Infinity Obs", "RCPCIFO", "Plasma/Blood/Serum", "318",+ |
+
| 332 | +4x | +
+ "RCPCIFOB", "Pct Rec Infinity Obs Norm by BMI", "RCPCIFOB", "Plasma/Blood/Serum", "319",+ |
+
| 333 | +4x | +
+ "RCPCIFOS", "Pct Rec Infinity Obs Norm by SA", "RCPCIFOS", "Plasma/Blood/Serum", "320",+ |
+
| 334 | +4x | +
+ "RCPCIFOW", "Pct Rec Infinity Obs Norm by WT", "RCPCIFOW", "Plasma/Blood/Serum", "321",+ |
+
| 335 | +4x | +
+ "RCPCIFP", "Pct Rec Infinity Pred", "RCPCIFP", "Plasma/Blood/Serum", "322",+ |
+
| 336 | +4x | +
+ "RCPCIFPB", "Pct Rec Infinity Pred Norm by BMI", "RCPCIFPB", "Plasma/Blood/Serum", "323",+ |
+
| 337 | +4x | +
+ "RCPCIFPS", "Pct Rec Infinity Pred Norm by SA", "RCPCIFPS", "Plasma/Blood/Serum", "324",+ |
+
| 338 | +4x | +
+ "RCPCIFPW", "Pct Rec Infinity Pred Norm by WT", "RCPCIFPW", "Plasma/Blood/Serum", "325",+ |
+
| 339 | +4x | +
+ "RCPCINTB", "Pct Rec from T1 to T2 Norm by BMI", "RCPCINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "326",+ |
+
| 340 | +4x | +
+ "RCPCINTS", "Pct Rec from T1 to T2 Norm by SA", "RCPCINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "327",+ |
+
| 341 | +4x | +
+ "RCPCINTW", "Pct Rec from T1 to T2 Norm by WT", "RCPCINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "328",+ |
+
| 342 | +4x | +
+ "RCPCLST", "Pct Rec to Last Nonzero Conc", "RCPCLST", "Plasma/Blood/Serum", "329",+ |
+
| 343 | +4x | +
+ "RCPCTAU", "Pct Rec Over Dosing Interval", "RCPCTAU", "Plasma/Blood/Serum", "330",+ |
+
| 344 | +4x | +
+ "RCPCTAUB", "Pct Rec Over Dosing Interval Norm by BMI", "RCPCTAUB", "Plasma/Blood/Serum", "331",+ |
+
| 345 | +4x | +
+ "RCPCTAUS", "Pct Rec Over Dosing Interval Norm by SA", "RCPCTAUS", "Plasma/Blood/Serum", "332",+ |
+
| 346 | +4x | +
+ "RCPCTAUW", "Pct Rec Over Dosing Interval Norm by WT", "RCPCTAUW", "Plasma/Blood/Serum", "333",+ |
+
| 347 | +4x | +
+ "RENALCLB", "Renal CL Norm by BMI", "RENALCLB", "Urine", "334",+ |
+
| 348 | +4x | +
+ "RENALCLD", "Renal CL Norm by Dose", "RENALCLD", "Urine", "335",+ |
+
| 349 | +4x | +
+ "RENALCLS", "Renal CL Norm by SA", "RENALCLS", "Urine", "336",+ |
+
| 350 | +4x | +
+ "RENALCLW", "Renal CL Norm by WT", "RENALCLW", "Urine", "337",+ |
+
| 351 | +4x | +
+ "RENCLTAU", "Renal CL for Dose Int", "RENCLTAU", "Urine", "338",+ |
+
| 352 | +4x | +
+ "RNCLINT", "Renal CL from T1 to T2", "RNCLINT_T1_T2_UNIT", "Urine", "339",+ |
+
| 353 | +4x | +
+ "RNCLINTB", "Renal CL from T1 to T2 Norm by BMI", "RNCLINTB_T1_T2_UNIT", "Urine", "340",+ |
+
| 354 | +4x | +
+ "RNCLINTD", "Renal CL from T1 to T2 Norm by Dose", "RNCLINTD_T1_T2_UNIT", "Urine", "341",+ |
+
| 355 | +4x | +
+ "RNCLINTS", "Renal CL from T1 to T2 Norm by SA", "RNCLINTS_T1_T2_UNIT", "Urine", "342",+ |
+
| 356 | +4x | +
+ "RNCLINTW", "Renal CL from T1 to T2 Norm by WT", "RNCLINTW_T1_T2_UNIT", "Urine", "343",+ |
+
| 357 | +4x | +
+ "RNCLTAUB", "Renal CL for Dose Int Norm by BMI", "RNCLTAUB", "Urine", "344",+ |
+
| 358 | +4x | +
+ "RNCLTAUD", "Renal CL for Dose Int Norm by Dose", "RNCLTAUD", "Urine", "345",+ |
+
| 359 | +4x | +
+ "RNCLTAUS", "Renal CL for Dose Int Norm by SA", "RNCLTAUS", "Urine", "346",+ |
+
| 360 | +4x | +
+ "RNCLTAUW", "Renal CL for Dose Int Norm by WT", "RNCLTAUW", "Urine", "347",+ |
+
| 361 | +4x | +
+ "RNCLUB", "Renal CL for Unbound Drug", "RNCLUB", "Urine", "348",+ |
+
| 362 | +4x | +
+ "SRAUC", "Stationarity Ratio AUC", "SRAUC", "Plasma/Blood/Serum", "349",+ |
+
| 363 | +4x | +
+ "SWING", "Swing", "SWING", "Plasma/Blood/Serum", "350",+ |
+
| 364 | +4x | +
+ "TAUHL", "Half-Life TAU", "TAUHL", "Plasma/Blood/Serum", "351",+ |
+
| 365 | +4x | +
+ "TBBL", "Time Below Baseline", "Time_Below_B", "Plasma/Blood/Serum", "352",+ |
+
| 366 | +4x | +
+ "TROUGHPR", "Trough Peak Ratio", "TROUGHPR", "Plasma/Blood/Serum", "353",+ |
+
| 367 | +4x | +
+ "V0", "Vol Dist Initial", "V0", "Plasma/Blood/Serum", "354",+ |
+
| 368 | +4x | +
+ "V0B", "Vol Dist Initial Norm by BMI", "V0B", "Plasma/Blood/Serum", "355",+ |
+
| 369 | +4x | +
+ "V0D", "Vol Dist Initial Norm by Dose", "V0D", "Plasma/Blood/Serum", "356",+ |
+
| 370 | +4x | +
+ "V0S", "Vol Dist Initial Norm by SA", "V0S", "Plasma/Blood/Serum", "357",+ |
+
| 371 | +4x | +
+ "V0W", "Vol Dist Initial Norm by WT", "V0W", "Plasma/Blood/Serum", "358",+ |
+
| 372 | +4x | +
+ "VSSOB", "Vol Dist Steady State Obs Norm by BMI", "VSSOB", "Plasma/Blood/Serum", "359",+ |
+
| 373 | +4x | +
+ "VSSOBD", "Vol Dist Steady State Obs by B", "VSSOBD", "Plasma/Blood/Serum", "360",+ |
+
| 374 | +4x | +
+ "VSSOD", "Vol Dist Steady State Obs Norm by Dose", "VSSOD", "Plasma/Blood/Serum", "361",+ |
+
| 375 | +4x | +
+ "VSSOF", "Vol Dist Steady State Obs by F", "VSSOF", "Plasma/Blood/Serum", "362",+ |
+
| 376 | +4x | +
+ "VSSOS", "Vol Dist Steady State Obs Norm by SA", "VSSOS", "Plasma/Blood/Serum", "363",+ |
+
| 377 | +4x | +
+ "VSSOUB", "Vol Dist Steady State Obs by UB", "VSSOUB", "Plasma/Blood/Serum", "364",+ |
+
| 378 | +4x | +
+ "VSSOW", "Vol Dist Steady State Obs Norm by WT", "VSSOW", "Plasma/Blood/Serum", "365",+ |
+
| 379 | +4x | +
+ "VSSPB", "Vol Dist Steady State Pred Norm by BMI", "VSSPB", "Plasma/Blood/Serum", "366",+ |
+
| 380 | +4x | +
+ "VSSPBD", "Vol Dist Steady State Pred by B", "VSSPBD", "Plasma/Blood/Serum", "367",+ |
+
| 381 | +4x | +
+ "VSSPD", "Vol Dist Steady State Pred Norm by Dose", "VSSPD", "Plasma/Blood/Serum", "368",+ |
+
| 382 | +4x | +
+ "VSSPF", "Vol Dist Steady State Pred by F", "VSSPF", "Plasma/Blood/Serum", "369",+ |
+
| 383 | +4x | +
+ "VSSPS", "Vol Dist Steady State Pred Norm by SA", "VSSPS", "Plasma/Blood/Serum", "370",+ |
+
| 384 | +4x | +
+ "VSSPUB", "Vol Dist Steady State Pred by UB", "VSSPUB", "Plasma/Blood/Serum", "371",+ |
+
| 385 | +4x | +
+ "VSSPW", "Vol Dist Steady State Pred Norm by WT", "VSSPW", "Plasma/Blood/Serum", "372",+ |
+
| 386 | +4x | +
+ "VZ", "Vol Z", "Vz", "Plasma/Blood/Serum", "373",+ |
+
| 387 | +4x | +
+ "VZF", "Vol Z by F", "Vz_F", "Plasma/Blood/Serum", "374",+ |
+
| 388 | +4x | +
+ "VZFOB", "Vz Obs by F Norm by BMI", "VZFOB", "Plasma/Blood/Serum", "375",+ |
+
| 389 | +4x | +
+ "VZFOD", "Vz Obs by F Norm by Dose", "VZFOD", "Plasma/Blood/Serum", "376",+ |
+
| 390 | +4x | +
+ "VZFOS", "Vz Obs by F Norm by SA", "VZFOS", "Plasma/Blood/Serum", "377",+ |
+
| 391 | +4x | +
+ "VZFOUB", "Vz Obs by F for UB", "VZFOUB", "Plasma/Blood/Serum", "378",+ |
+
| 392 | +4x | +
+ "VZFOW", "Vz Obs by F Norm by WT", "VZFOW", "Plasma/Blood/Serum", "379",+ |
+
| 393 | +4x | +
+ "VZFPB", "Vz Pred by F Norm by BMI", "VZFPB", "Plasma/Blood/Serum", "380",+ |
+
| 394 | +4x | +
+ "VZFPD", "Vz Pred by F Norm by Dose", "VZFPD", "Plasma/Blood/Serum", "381",+ |
+
| 395 | +4x | +
+ "VZFPS", "Vz Pred by F Norm by SA", "VZFPS", "Plasma/Blood/Serum", "382",+ |
+
| 396 | +4x | +
+ "VZFPUB", "Vz Pred by F for UB", "VZFPUB", "Plasma/Blood/Serum", "383",+ |
+
| 397 | +4x | +
+ "VZFPW", "Vz Pred by F Norm by WT", "VZFPW", "Plasma/Blood/Serum", "384",+ |
+
| 398 | +4x | +
+ "VZFTAU", "Vz for Dose Int by F", "VZFTAU", "Plasma/Blood/Serum", "385",+ |
+
| 399 | +4x | +
+ "VZFTAUB", "Vz for Dose Int by F Norm by BMI", "VZFTAUB", "Plasma/Blood/Serum", "386",+ |
+
| 400 | +4x | +
+ "VZFTAUD", "Vz for Dose Int by F Norm by Dose", "VZFTAUD", "Plasma/Blood/Serum", "387",+ |
+
| 401 | +4x | +
+ "VZFTAUS", "Vz for Dose Int by F Norm by SA", "VZFTAUS", "Plasma/Blood/Serum", "388",+ |
+
| 402 | +4x | +
+ "VZFTAUW", "Vz for Dose Int by F Norm by WT", "VZFTAUW", "Plasma/Blood/Serum", "389",+ |
+
| 403 | +4x | +
+ "VZOB", "Vz Obs Norm by BMI", "VZOB", "Plasma/Blood/Serum", "390",+ |
+
| 404 | +4x | +
+ "VZOD", "Vz Obs Norm by Dose", "VZOD", "Plasma/Blood/Serum", "391",+ |
+
| 405 | +4x | +
+ "VZOS", "Vz Obs Norm by SA", "VZOS", "Plasma/Blood/Serum", "392",+ |
+
| 406 | +4x | +
+ "VZOUB", "Vz Obs for UB", "VZOUB", "Plasma/Blood/Serum", "393",+ |
+
| 407 | +4x | +
+ "VZOW", "Vz Obs Norm by WT", "VZOW", "Plasma/Blood/Serum", "394",+ |
+
| 408 | +4x | +
+ "VZPB", "Vz Pred Norm by BMI", "VZPB", "Plasma/Blood/Serum", "395",+ |
+
| 409 | +4x | +
+ "VZPD", "Vz Pred Norm by Dose", "VZPD", "Plasma/Blood/Serum", "396",+ |
+
| 410 | +4x | +
+ "VZPS", "Vz Pred Norm by SA", "VZPS", "Plasma/Blood/Serum", "397",+ |
+
| 411 | +4x | +
+ "VZPUB", "Vz Pred for UB", "VZPUB", "Plasma/Blood/Serum", "398"+ |
+
| 412 | ++ |
+ ),+ |
+
| 413 | +4x | +
+ ncol = 5,+ |
+
| 414 | +4x | +
+ byrow = TRUE+ |
+
| 415 | ++ |
+ ))+ |
+
| 416 | +4x | +
+ colnames(pk_dataset) <- c("PARAMCD", "PARAM", "TLG_DISPLAY", "MATRIX", "TLG_ORDER")
+ |
+
| 417 | +4x | +
+ pk_dataset+ |
+
| 418 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Helper Functions for Tabulating Biomarker Effects on Survival by Subgroup+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' Helper functions which are documented here separately to not confuse the user+ |
+
| 6 | ++ |
+ #' when reading about the user-facing functions.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams survival_biomarkers_subgroups+ |
+
| 9 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 10 | ++ |
+ #' @inheritParams fit_coxreg_multivar+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @examples+ |
+
| 13 | ++ |
+ #' library(dplyr)+ |
+
| 14 | ++ |
+ #' library(forcats)+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' adtte <- tern_ex_adtte+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' # Save variable labels before data processing steps.+ |
+
| 19 | ++ |
+ #' adtte_labels <- formatters::var_labels(adtte, fill = FALSE)+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' adtte_f <- adtte %>%+ |
+
| 22 | ++ |
+ #' filter(PARAMCD == "OS") %>%+ |
+
| 23 | ++ |
+ #' mutate(+ |
+
| 24 | ++ |
+ #' AVALU = as.character(AVALU),+ |
+
| 25 | ++ |
+ #' is_event = CNSR == 0+ |
+
| 26 | ++ |
+ #' )+ |
+
| 27 | ++ |
+ #' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
+ |
+
| 28 | ++ |
+ #' formatters::var_labels(adtte_f)[names(labels)] <- labels+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' @name h_survival_biomarkers_subgroups+ |
+
| 31 | ++ |
+ NULL+ |
+
| 32 | ++ | + + | +
| 33 | ++ |
+ #' @describeIn h_survival_biomarkers_subgroups helps with converting the "survival" function variable list+ |
+
| 34 | ++ |
+ #' to the "Cox regression" variable list. The reason is that currently there is an inconsistency between the variable+ |
+
| 35 | ++ |
+ #' names accepted by `extract_survival_subgroups()` and `fit_coxreg_multivar()`.+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' @param biomarker (`string`)\cr the name of the biomarker variable.+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' @return+ |
+
| 40 | ++ |
+ #' * `h_surv_to_coxreg_variables()` returns a named `list` of elements `time`, `event`, `arm`,+ |
+
| 41 | ++ |
+ #' `covariates`, and `strata`.+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' @examples+ |
+
| 44 | ++ |
+ #' # This is how the variable list is converted internally.+ |
+
| 45 | ++ |
+ #' h_surv_to_coxreg_variables(+ |
+
| 46 | ++ |
+ #' variables = list(+ |
+
| 47 | ++ |
+ #' tte = "AVAL",+ |
+
| 48 | ++ |
+ #' is_event = "EVNT",+ |
+
| 49 | ++ |
+ #' covariates = c("A", "B"),
+ |
+
| 50 | ++ |
+ #' strata = "D"+ |
+
| 51 | ++ |
+ #' ),+ |
+
| 52 | ++ |
+ #' biomarker = "AGE"+ |
+
| 53 | ++ |
+ #' )+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' @export+ |
+
| 56 | ++ |
+ h_surv_to_coxreg_variables <- function(variables, biomarker) {
+ |
+
| 57 | +41x | +
+ checkmate::assert_list(variables)+ |
+
| 58 | +41x | +
+ checkmate::assert_string(variables$tte)+ |
+
| 59 | +41x | +
+ checkmate::assert_string(variables$is_event)+ |
+
| 60 | +41x | +
+ checkmate::assert_string(biomarker)+ |
+
| 61 | +41x | +
+ list(+ |
+
| 62 | +41x | +
+ time = variables$tte,+ |
+
| 63 | +41x | +
+ event = variables$is_event,+ |
+
| 64 | +41x | +
+ arm = biomarker,+ |
+
| 65 | +41x | +
+ covariates = variables$covariates,+ |
+
| 66 | +41x | +
+ strata = variables$strata+ |
+
| 67 | ++ |
+ )+ |
+
| 68 | ++ |
+ }+ |
+
| 69 | ++ | + + | +
| 70 | ++ |
+ #' @describeIn h_survival_biomarkers_subgroups prepares estimates for number of events, patients and median survival+ |
+
| 71 | ++ |
+ #' times, as well as hazard ratio estimates, confidence intervals and p-values, for multiple biomarkers+ |
+
| 72 | ++ |
+ #' in a given single data set.+ |
+
| 73 | ++ |
+ #' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements+ |
+
| 74 | ++ |
+ #' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables) and optionally `subgroups` and `strat`.+ |
+
| 75 | ++ |
+ #'+ |
+
| 76 | ++ |
+ #' @return+ |
+
| 77 | ++ |
+ #' * `h_coxreg_mult_cont_df()` returns a `data.frame` containing estimates and statistics for the selected biomarkers.+ |
+
| 78 | ++ |
+ #'+ |
+
| 79 | ++ |
+ #' @examples+ |
+
| 80 | ++ |
+ #' # For a single population, estimate separately the effects+ |
+
| 81 | ++ |
+ #' # of two biomarkers.+ |
+
| 82 | ++ |
+ #' df <- h_coxreg_mult_cont_df(+ |
+
| 83 | ++ |
+ #' variables = list(+ |
+
| 84 | ++ |
+ #' tte = "AVAL",+ |
+
| 85 | ++ |
+ #' is_event = "is_event",+ |
+
| 86 | ++ |
+ #' biomarkers = c("BMRKR1", "AGE"),
+ |
+
| 87 | ++ |
+ #' covariates = "SEX",+ |
+
| 88 | ++ |
+ #' strata = c("STRATA1", "STRATA2")
+ |
+
| 89 | ++ |
+ #' ),+ |
+
| 90 | ++ |
+ #' data = adtte_f+ |
+
| 91 | ++ |
+ #' )+ |
+
| 92 | ++ |
+ #' df+ |
+
| 93 | ++ |
+ #'+ |
+
| 94 | ++ |
+ #' # If the data set is empty, still the corresponding rows with missings are returned.+ |
+
| 95 | ++ |
+ #' h_coxreg_mult_cont_df(+ |
+
| 96 | ++ |
+ #' variables = list(+ |
+
| 97 | ++ |
+ #' tte = "AVAL",+ |
+
| 98 | ++ |
+ #' is_event = "is_event",+ |
+
| 99 | ++ |
+ #' biomarkers = c("BMRKR1", "AGE"),
+ |
+
| 100 | ++ |
+ #' covariates = "REGION1",+ |
+
| 101 | ++ |
+ #' strata = c("STRATA1", "STRATA2")
+ |
+
| 102 | ++ |
+ #' ),+ |
+
| 103 | ++ |
+ #' data = adtte_f[NULL, ]+ |
+
| 104 | ++ |
+ #' )+ |
+
| 105 | ++ |
+ #'+ |
+
| 106 | ++ |
+ #' @export+ |
+
| 107 | ++ |
+ h_coxreg_mult_cont_df <- function(variables,+ |
+
| 108 | ++ |
+ data,+ |
+
| 109 | ++ |
+ control = control_coxreg()) {
+ |
+
| 110 | +21x | +
+ assert_df_with_variables(data, variables)+ |
+
| 111 | +21x | +
+ checkmate::assert_list(control, names = "named")+ |
+
| 112 | +21x | +
+ checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE)+ |
+
| 113 | +21x | +
+ conf_level <- control[["conf_level"]]+ |
+
| 114 | +21x | +
+ pval_label <- paste0(+ |
+
| 115 | ++ |
+ # the regex capitalizes the first letter of the string / senetence.+ |
+
| 116 | +21x | +
+ "p-value (", gsub("(^[a-z])", "\\U\\1", trimws(control[["pval_method"]]), perl = TRUE), ")"
+ |
+
| 117 | ++ |
+ )+ |
+
| 118 | ++ |
+ # If there is any data, run model, otherwise return empty results.+ |
+
| 119 | +21x | +
+ if (nrow(data) > 0) {
+ |
+
| 120 | +20x | +
+ bm_cols <- match(variables$biomarkers, names(data))+ |
+
| 121 | +20x | +
+ l_result <- lapply(variables$biomarkers, function(bm) {
+ |
+
| 122 | +40x | +
+ coxreg_list <- fit_coxreg_multivar(+ |
+
| 123 | +40x | +
+ variables = h_surv_to_coxreg_variables(variables, bm),+ |
+
| 124 | +40x | +
+ data = data,+ |
+
| 125 | +40x | +
+ control = control+ |
+
| 126 | ++ |
+ )+ |
+
| 127 | +40x | +
+ result <- do.call(+ |
+
| 128 | +40x | +
+ h_coxreg_multivar_extract,+ |
+
| 129 | +40x | +
+ c(list(var = bm), coxreg_list[c("mod", "data", "control")])
+ |
+
| 130 | ++ |
+ )+ |
+
| 131 | +40x | +
+ data_fit <- as.data.frame(as.matrix(coxreg_list$mod$y))+ |
+
| 132 | +40x | +
+ data_fit$status <- as.logical(data_fit$status)+ |
+
| 133 | +40x | +
+ median <- s_surv_time(+ |
+
| 134 | +40x | +
+ df = data_fit,+ |
+
| 135 | +40x | +
+ .var = "time",+ |
+
| 136 | +40x | +
+ is_event = "status"+ |
+
| 137 | +40x | +
+ )$median+ |
+
| 138 | +40x | +
+ data.frame(+ |
+
| 139 | ++ |
+ # Dummy column needed downstream to create a nested header.+ |
+
| 140 | +40x | +
+ biomarker = bm,+ |
+
| 141 | +40x | +
+ biomarker_label = formatters::var_labels(data[bm], fill = TRUE),+ |
+
| 142 | +40x | +
+ n_tot = coxreg_list$mod$n,+ |
+
| 143 | +40x | +
+ n_tot_events = coxreg_list$mod$nevent,+ |
+
| 144 | +40x | +
+ median = as.numeric(median),+ |
+
| 145 | +40x | +
+ result[1L, c("hr", "lcl", "ucl")],
+ |
+
| 146 | +40x | +
+ conf_level = conf_level,+ |
+
| 147 | +40x | +
+ pval = result[1L, "pval"],+ |
+
| 148 | +40x | +
+ pval_label = pval_label,+ |
+
| 149 | +40x | +
+ stringsAsFactors = FALSE+ |
+
| 150 | ++ |
+ )+ |
+
| 151 | ++ |
+ })+ |
+
| 152 | +20x | +
+ do.call(rbind, args = c(l_result, make.row.names = FALSE))+ |
+
| 153 | ++ |
+ } else {
+ |
+
| 154 | +1x | +
+ data.frame(+ |
+
| 155 | +1x | +
+ biomarker = variables$biomarkers,+ |
+
| 156 | +1x | +
+ biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE),+ |
+
| 157 | +1x | +
+ n_tot = 0L,+ |
+
| 158 | +1x | +
+ n_tot_events = 0L,+ |
+
| 159 | +1x | +
+ median = NA,+ |
+
| 160 | +1x | +
+ hr = NA,+ |
+
| 161 | +1x | +
+ lcl = NA,+ |
+
| 162 | +1x | +
+ ucl = NA,+ |
+
| 163 | +1x | +
+ conf_level = conf_level,+ |
+
| 164 | +1x | +
+ pval = NA,+ |
+
| 165 | +1x | +
+ pval_label = pval_label,+ |
+
| 166 | +1x | +
+ row.names = seq_along(variables$biomarkers),+ |
+
| 167 | +1x | +
+ stringsAsFactors = FALSE+ |
+
| 168 | ++ |
+ )+ |
+
| 169 | ++ |
+ }+ |
+
| 170 | ++ |
+ }+ |
+
| 171 | ++ | + + | +
| 172 | ++ |
+ #' @describeIn h_survival_biomarkers_subgroups prepares a single sub-table given a `df_sub` containing+ |
+
| 173 | ++ |
+ #' the results for a single biomarker.+ |
+
| 174 | ++ |
+ #'+ |
+
| 175 | ++ |
+ #' @param df (`data.frame`)\cr results for a single biomarker, as part of what is+ |
+
| 176 | ++ |
+ #' returned by [extract_survival_biomarkers()] (it needs a couple of columns which are+ |
+
| 177 | ++ |
+ #' added by that high-level function relative to what is returned by [h_coxreg_mult_cont_df()],+ |
+
| 178 | ++ |
+ #' see the example).+ |
+
| 179 | ++ |
+ #'+ |
+
| 180 | ++ |
+ #' @return+ |
+
| 181 | ++ |
+ #' * `h_tab_surv_one_biomarker()` returns an `rtables` table object with the given statistics arranged in columns.+ |
+
| 182 | ++ |
+ #'+ |
+
| 183 | ++ |
+ #' @examples+ |
+
| 184 | ++ |
+ #' # Starting from above `df`, zoom in on one biomarker and add required columns.+ |
+
| 185 | ++ |
+ #' df1 <- df[1, ]+ |
+
| 186 | ++ |
+ #' df1$subgroup <- "All patients"+ |
+
| 187 | ++ |
+ #' df1$row_type <- "content"+ |
+
| 188 | ++ |
+ #' df1$var <- "ALL"+ |
+
| 189 | ++ |
+ #' df1$var_label <- "All patients"+ |
+
| 190 | ++ |
+ #' h_tab_surv_one_biomarker(+ |
+
| 191 | ++ |
+ #' df1,+ |
+
| 192 | ++ |
+ #' vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
+ |
+
| 193 | ++ |
+ #' time_unit = "days"+ |
+
| 194 | ++ |
+ #' )+ |
+
| 195 | ++ |
+ #'+ |
+
| 196 | ++ |
+ #' @export+ |
+
| 197 | ++ |
+ h_tab_surv_one_biomarker <- function(df,+ |
+
| 198 | ++ |
+ vars,+ |
+
| 199 | ++ |
+ time_unit,+ |
+
| 200 | ++ |
+ .indent_mods = 0L) {
+ |
+
| 201 | +6x | +
+ afuns <- a_survival_subgroups()[vars]+ |
+
| 202 | +6x | +
+ colvars <- d_survival_subgroups_colvars(+ |
+
| 203 | +6x | +
+ vars,+ |
+
| 204 | +6x | +
+ conf_level = df$conf_level[1],+ |
+
| 205 | +6x | +
+ method = df$pval_label[1],+ |
+
| 206 | +6x | +
+ time_unit = time_unit+ |
+
| 207 | ++ |
+ )+ |
+
| 208 | +6x | +
+ h_tab_one_biomarker(+ |
+
| 209 | +6x | +
+ df = df,+ |
+
| 210 | +6x | +
+ afuns = afuns,+ |
+
| 211 | +6x | +
+ colvars = colvars,+ |
+
| 212 | +6x | +
+ .indent_mods = .indent_mods+ |
+
| 213 | ++ |
+ )+ |
+
| 214 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Combination Functions Class+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description `r lifecycle::badge("stable")`
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' `CombinationFunction` is an S4 class which extends standard functions. These are special functions that+ |
+
| 6 | ++ |
+ #' can be combined and negated with the logical operators.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @param e1 (`CombinationFunction`)\cr left hand side of logical operator.+ |
+
| 9 | ++ |
+ #' @param e2 (`CombinationFunction`)\cr right hand side of logical operator.+ |
+
| 10 | ++ |
+ #' @param x (`CombinationFunction`)\cr the function which should be negated.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @return Returns a logical value indicating whether the left hand side of the equation equals the right hand side.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @exportClass CombinationFunction+ |
+
| 15 | ++ |
+ #' @export CombinationFunction+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @examples+ |
+
| 18 | ++ |
+ #' higher <- function(a) {
+ |
+
| 19 | ++ |
+ #' force(a)+ |
+
| 20 | ++ |
+ #' CombinationFunction(+ |
+
| 21 | ++ |
+ #' function(x) {
+ |
+
| 22 | ++ |
+ #' x > a+ |
+
| 23 | ++ |
+ #' }+ |
+
| 24 | ++ |
+ #' )+ |
+
| 25 | ++ |
+ #' }+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' lower <- function(b) {
+ |
+
| 28 | ++ |
+ #' force(b)+ |
+
| 29 | ++ |
+ #' CombinationFunction(+ |
+
| 30 | ++ |
+ #' function(x) {
+ |
+
| 31 | ++ |
+ #' x < b+ |
+
| 32 | ++ |
+ #' }+ |
+
| 33 | ++ |
+ #' )+ |
+
| 34 | ++ |
+ #' }+ |
+
| 35 | ++ |
+ #'+ |
+
| 36 | ++ |
+ #' c1 <- higher(5)+ |
+
| 37 | ++ |
+ #' c2 <- lower(10)+ |
+
| 38 | ++ |
+ #' c3 <- higher(5) & lower(10)+ |
+
| 39 | ++ |
+ #' c3(7)+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' @aliases CombinationFunction-class+ |
+
| 42 | ++ |
+ #' @name combination_function+ |
+
| 43 | ++ |
+ CombinationFunction <- methods::setClass("CombinationFunction", contains = "function") # nolint
+ |
+
| 44 | ++ | + + | +
| 45 | ++ |
+ #' @describeIn combination_function Logical "AND" combination of `CombinationFunction` functions.+ |
+
| 46 | ++ |
+ #' The resulting object is of the same class, and evaluates the two argument functions. The result+ |
+
| 47 | ++ |
+ #' is then the "AND" of the two individual results.+ |
+
| 48 | ++ |
+ #'+ |
+
| 49 | ++ |
+ #' @export+ |
+
| 50 | ++ |
+ methods::setMethod(+ |
+
| 51 | ++ |
+ "&",+ |
+
| 52 | ++ |
+ signature = c(e1 = "CombinationFunction", e2 = "CombinationFunction"),+ |
+
| 53 | ++ |
+ definition = function(e1, e2) {
+ |
+
| 54 | +4x | +
+ CombinationFunction(function(...) {
+ |
+
| 55 | +490x | +
+ e1(...) && e2(...)+ |
+
| 56 | ++ |
+ })+ |
+
| 57 | ++ |
+ }+ |
+
| 58 | ++ |
+ )+ |
+
| 59 | ++ | + + | +
| 60 | ++ |
+ #' @describeIn combination_function Logical "OR" combination of `CombinationFunction` functions.+ |
+
| 61 | ++ |
+ #' The resulting object is of the same class, and evaluates the two argument functions. The result+ |
+
| 62 | ++ |
+ #' is then the "OR" of the two individual results.+ |
+
| 63 | ++ |
+ #'+ |
+
| 64 | ++ |
+ #' @export+ |
+
| 65 | ++ |
+ methods::setMethod(+ |
+
| 66 | ++ |
+ "|",+ |
+
| 67 | ++ |
+ signature = c(e1 = "CombinationFunction", e2 = "CombinationFunction"),+ |
+
| 68 | ++ |
+ definition = function(e1, e2) {
+ |
+
| 69 | +2x | +
+ CombinationFunction(function(...) {
+ |
+
| 70 | +4x | +
+ e1(...) || e2(...)+ |
+
| 71 | ++ |
+ })+ |
+
| 72 | ++ |
+ }+ |
+
| 73 | ++ |
+ )+ |
+
| 74 | ++ | + + | +
| 75 | ++ |
+ #' @describeIn combination_function Logical negation of `CombinationFunction` functions.+ |
+
| 76 | ++ |
+ #' The resulting object is of the same class, and evaluates the original function. The result+ |
+
| 77 | ++ |
+ #' is then the opposite of this results.+ |
+
| 78 | ++ |
+ #'+ |
+
| 79 | ++ |
+ #' @export+ |
+
| 80 | ++ |
+ methods::setMethod(+ |
+
| 81 | ++ |
+ "!",+ |
+
| 82 | ++ |
+ signature = c(x = "CombinationFunction"),+ |
+
| 83 | ++ |
+ definition = function(x) {
+ |
+
| 84 | +2x | +
+ CombinationFunction(function(...) {
+ |
+
| 85 | +305x | +
+ !x(...)+ |
+
| 86 | ++ |
+ })+ |
+
| 87 | ++ |
+ }+ |
+
| 88 | ++ |
+ )+ |
+
| 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 | ++ |
+ #' internally to specify details in `s_incidence_rate()`.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams argument_convention+ |
+
| 9 | ++ |
+ #' @param conf_type (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`+ |
+
| 10 | ++ |
+ #' for confidence interval type.+ |
+
| 11 | ++ |
+ #' @param input_time_unit (`string`)\cr `day`, `week`, `month`, or `year` (default)+ |
+
| 12 | ++ |
+ #' indicating time unit for data input.+ |
+
| 13 | ++ |
+ #' @param num_pt_year (`numeric`)\cr number of patient-years to use when calculating adverse event rates.+ |
+
| 14 | ++ |
+ #' @param time_unit_input `r lifecycle::badge("deprecated")` Please use the `input_time_unit` argument instead.
+ |
+
| 15 | ++ |
+ #' @param time_unit_output `r lifecycle::badge("deprecated")` Please use the `num_pt_year` argument instead.
+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @return A list of components with the same names as the arguments.+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @seealso [incidence_rate]+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @examples+ |
+
| 22 | ++ |
+ #' control_incidence_rate(0.9, "exact", "month", 100)+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @export+ |
+
| 25 | ++ |
+ control_incidence_rate <- function(conf_level = 0.95,+ |
+
| 26 | ++ |
+ conf_type = c("normal", "normal_log", "exact", "byar"),
+ |
+
| 27 | ++ |
+ input_time_unit = c("year", "day", "week", "month"),
+ |
+
| 28 | ++ |
+ num_pt_year = 100,+ |
+
| 29 | ++ |
+ time_unit_input = lifecycle::deprecated(),+ |
+
| 30 | ++ |
+ time_unit_output = lifecycle::deprecated()) {
+ |
+
| 31 | +8x | +
+ if (lifecycle::is_present(time_unit_input)) {
+ |
+
| 32 | +! | +
+ lifecycle::deprecate_warn(+ |
+
| 33 | +! | +
+ "0.8.3", "control_incidence_rate(time_unit_input)", "control_incidence_rate(input_time_unit)"+ |
+
| 34 | ++ |
+ )+ |
+
| 35 | +! | +
+ input_time_unit <- time_unit_input+ |
+
| 36 | ++ |
+ }+ |
+
| 37 | +8x | +
+ if (lifecycle::is_present(time_unit_output)) {
+ |
+
| 38 | +! | +
+ lifecycle::deprecate_warn(+ |
+
| 39 | +! | +
+ "0.8.3", "control_incidence_rate(time_unit_output)", "control_incidence_rate(num_pt_year)"+ |
+
| 40 | ++ |
+ )+ |
+
| 41 | +! | +
+ num_pt_year <- time_unit_output+ |
+
| 42 | ++ |
+ }+ |
+
| 43 | ++ | + + | +
| 44 | +8x | +
+ conf_type <- match.arg(conf_type)+ |
+
| 45 | +7x | +
+ input_time_unit <- match.arg(input_time_unit)+ |
+
| 46 | +6x | +
+ checkmate::assert_number(num_pt_year)+ |
+
| 47 | +5x | +
+ assert_proportion_value(conf_level)+ |
+
| 48 | ++ | + + | +
| 49 | +4x | +
+ list(+ |
+
| 50 | +4x | +
+ conf_level = conf_level,+ |
+
| 51 | +4x | +
+ conf_type = conf_type,+ |
+
| 52 | +4x | +
+ input_time_unit = input_time_unit,+ |
+
| 53 | +4x | +
+ num_pt_year = num_pt_year+ |
+
| 54 | ++ |
+ )+ |
+
| 55 | ++ |
+ }+ |
+
"+y.value+"