#' @keywords internal2
split_and_summ_num_patients <- function(lyt, var, label, stats, summarize_labels, split_indent, ...) { 3 13x
assert_string(var)4 13x
assert_string(label)5 13x
lyt <- lyt %>%6 13x
split_rows_by(7 13x
var,8 13x
child_labels = "visible",9 13x
nested = TRUE,10 13x
split_fun = rtables::drop_split_levels,11 13x
label_pos = "topleft",12 13x
split_label = label,13 13x
indent_mod = split_indent14
)15 13x
if (length(stats) > 0) { 16 13x
lyt <- lyt %>%17 13x
summarize_num_patients(18 13x
var = "USUBJID",19 13x
.stats = stats,20 13x
.labels = setNames(summarize_labels, stats),21
...22
)23
}24 13x
lyt25
}26
#' @keywords internal27
get_sort_path <- function(x) { 28 46x
assert_character(x, null.ok = TRUE)29 46x
x2 <- as.character(rbind(x, rep("*", length(x)))) 30 46x
x2[-length(x2)]31
}32
#' @keywords internal33
tlg_sort_by_vars <- function(tlg, vars, scorefun = cont_n_allcols, ...) { 34 18x
purrr::reduce(35 18x
.x = lapply(seq_len(length(vars)), function(i) vars[seq_len(i)]),36 18x
.f = tlg_sort_by_var,37 18x
.init = tlg,38 18x
scorefun = scorefun,39
...40
)41
}42
#' @keywords internal43
tlg_sort_by_var <- function(tlg, var, scorefun = cont_n_allcols, ...) { 44 38x
assert_character(var)45 38x
if (length(var) == 0) { 46 !
return(tlg)47
}48 38x
var_path <- get_sort_path(var)49 38x
tlg %>%50 38x
valid_sort_at_path(51 38x
path = var_path,52 38x
scorefun = scorefun,53
...54
)55
}56
#' @keywords internal57
valid_sort_at_path <- function(tt, path, scorefun, ...) { 58 46x
if (valid_row_path(tt, path)) { 59 39x
tryCatch(60 39x
sort_at_path(tt, path, scorefun, ...),61 39x
error = function(e) { 62 !
tt63
}64
)65
} else { 66 7x
tt67
}68
}69
#' @keywords internal70
valid_row_path <- function(tlg, row_path) { 71 46x
if (nrow(tlg) == 0) { 72 2x
return(TRUE)73
}74 44x
rpaths <- row_paths(tlg)75 44x
non_star <- which(row_path != "*") + 176 44x
rpaths_choice <- unique(lapply(rpaths, `[`, non_star))77 44x
any(vapply(rpaths_choice, identical, FUN.VALUE = TRUE, y = row_path[non_star - 1]))78
}79 80
#' Count patients recursively81
#' @param lyt (`PreDataTableLayouts`) `rtable` layout.82
#' @param anl_vars Named (`list`) of analysis variables.83
#' @param anl_lbls (`character`) of labels.84
#' @param lbl_vars Named (`list`) of analysis labels.85
#' @keywords internal86
count_patients_recursive <- function(lyt, anl_vars, anl_lbls, lbl_vars) { 87 6x
assert_list(anl_vars, names = "unique", types = "character")88 6x
assert_character(anl_lbls, min.chars = 1L, len = length(anl_vars))89 6x
nms <- names(anl_vars)90 6x
for (k in seq_len(length(anl_vars))) { 91 7x
lyt <- lyt %>%92 7x
count_patients_with_flags(93 7x
var = "USUBJID",94 7x
flag_variables = setNames(lbl_vars[[k]], anl_vars[[k]]),95 7x
denom = "N_col",96 7x
var_labels = anl_lbls[k],97 7x
show_labels = "visible",98 7x
table_names = nms[k],99 7x
.indent_mods = 0L100
)101
}102 6x
lyt103
}104
#' @keywords internal105
score_all_sum <- function(tt) { 106 102x
cleaf <- collect_leaves(tt)[[1]]107 102x
if (NROW(cleaf) == 0) { 108 !
stop("score_all_sum score function used at subtable [", obj_name(tt), "] that has no content.") 109
}110 102x
sum(sapply(row_values(cleaf), function(cv) cv[1]))111
}112
#' @keywords internal113
summarize_row <- function(lyt, vars, afun, ...) { 114 2x
summarize_row_groups(lyt = lyt, var = vars, cfun = afun, ...)115
}116 117
#' Summary factor allowing NA118
#' @param x (`factor`) input.119
#' @param denom (`string`) denominator choice.120
#' @param .N_row (`integer`) number of rows in row-split dataset.121
#' @param .N_col (`integer`) number of rows in column-split dataset.122
#' @param ... Not used123
#' @keywords internal124
s_summary_na <- function(x, labelstr, denom = c("n", "N_row", "N_col"), .N_row, .N_col, ...) { # nolint 125 210x
denom <- match.arg(denom)126 210x
y <- list()127 210x
y$n <- length(x)128 210x
y$count <- as.list(table(x, useNA = "no"))129 210x
dn <- switch(denom,130 210x
n = length(x),131 210x
N_row = .N_row,132 210x
N_col = .N_col133
)134 210x
y$count_fraction <- lapply(y$count, function(x) { 135 714x
c(x, ifelse(dn > 0, x / dn, 0))136
})137 210x
y$n_blq <- sum(grepl("BLQ|LTR|<[1-9]", x)) 138 210x
y139
}140
#' Summarize variables allow `NA`141
#' @keywords internal142
summarize_vars_allow_na <- function(143
lyt, vars, var_labels = vars,144
nested = TRUE, ..., show_labels = "default", table_names = vars,145
section_div = NA_character_, .stats = c("n", "count_fraction"), 146
.formats = list(count_fraction = format_count_fraction_fixed_dp), .labels = NULL, .indent_mods = NULL, inclNAs = TRUE) { # nolint 147 7x
afun <- make_afun(s_summary_na, .stats, .formats, .labels, .indent_mods, .ungroup_stats = c("count_fraction")) 148 7x
analyze(149 7x
lyt = lyt, vars = vars, var_labels = var_labels,150 7x
afun = afun, nested = nested, extra_args = list(...),151 7x
inclNAs = inclNAs, show_labels = show_labels, table_names = table_names,152 7x
section_div = section_div153
)154
}155 156
#' Count or summarize by groups157
#' @param lyt (`PreDataTableLayouts`) `rtable` layout.158
#' @param var (`string`) of analysis variable.159
#' @param level (`string`) level to be displayed.160
#' @param detail_vars (`character`) of variables for detail information.161
#' @keywords internal162
count_or_summarize <- function(lyt, var, level, detail_vars, indent_mod = 0L, ...) { 163 27x
assert_string(level)164 27x
if (is.null(detail_vars)) { 165 20x
lyt <- lyt %>%166 20x
count_values(167 20x
var,168 20x
values = level,169 20x
table_names = paste(var, level, sep = "_"),170 20x
.formats = list(count_fraction = format_count_fraction_fixed_dp),171 20x
.indent_mods = indent_mod,172
...173
)174
} else { 175 7x
lyt <- lyt %>%176 7x
split_rows_by(var, split_fun = keep_split_levels(level), indent_mod = indent_mod) %>%177 7x
summarize_row_groups(178 7x
format = format_count_fraction_fixed_dp179
) %>%180 7x
split_rows_by_recurive(detail_vars[-length(detail_vars)], split_fun = drop_split_levels) %>%181 7x
summarize_vars(182 7x
detail_vars[length(detail_vars)],183 7x
.stats = "count_fraction",184 7x
denom = "N_col",185 7x
show_labels = "hidden",186 7x
.formats = list(count_fraction = format_count_fraction_fixed_dp),187
...188
)189
}190 27x
lyt191
}192 193
#' Count or summarize by groups194
#' @param lyt (`PreDataTableLayouts`) `rtable` layout.195
#' @param row_split_var (`character`) variable to split rows by.196
#' @param ... Further arguments for `split_rows_by`197
#' @keywords internal198
split_rows_by_recurive <- function(lyt, row_split_var, ...) { 199 41x
args <- list(...)200 41x
for (i in seq_len(length(row_split_var))) { 201 22x
args_i <- lapply(args, obtain_value, index = i)202 22x
lyt <- do_call(203 22x
split_rows_by,204 22x
c(205 22x
list(206 22x
lyt = lyt,207 22x
row_split_var208
),209 22x
args_i210
)211
)212
}213 41x
lyt214
}215 216
#' Obtain value from a vector217
#' @keywords internal218
obtain_value <- function(obj, index) { 219 62x
if (is.list(obj)) { 220 !
return(obj[[index]])221
}222 62x
if (is.vector(obj) && length(obj) >= index) { 223 60x
return(obj[index])224
}225 2x
return(obj)226
}227 228
#' Get page by value229
#' @keywords internal230
get_page_by <- function(var, vars) { 231 34x
assert_character(vars, null.ok = TRUE)232 34x
assert_character(var, null.ok = TRUE, max.len = 1L)233 34x
ret <- rep(FALSE, length(vars))234 34x
if (is.null(var) || length(var) == 0) { 235 15x
return(ret)236
}237 19x
index <- match(var, vars)238 19x
assert_int(index, na.ok = TRUE)239 19x
if (is.na(index)) { 240 !
return(ret)241
}242 19x
ret[seq_len(index)] <- TRUE243 19x
return(ret)244
}245 246
#' Proportion layout247
#'248
#' @inheritParams rspt01_main249
#' @param lyt layout created by `rtables`250
#'251
#' @keywords internal252
proportion_lyt <- function(lyt, arm_var, methods, strata, conf_level, odds_ratio = TRUE, rsp_var = "IS_RSP") { 253 8x
non_stratified <- length(strata) == 0L254 8x
lyt <- lyt %>%255 8x
estimate_proportion_diff(256 8x
vars = rsp_var,257 8x
show_labels = "visible",258 8x
var_labels = if (non_stratified) "Unstratified Analysis" else "Stratified Analysis",259 8x
conf_level = conf_level,260 8x
method = if (non_stratified) { 261 6x
methods[["diff_conf_method"]] %||% "waldcc"262
} else { 263 2x
methods[["strat_diff_conf_method"]] %||% "cmh"264
},265 8x
variables = list(strata = strata),266 8x
table_names = if (non_stratified) "est_prop_diff" else "est_prop_diff_strat"267
) %>%268 8x
test_proportion_diff(269 8x
vars = rsp_var,270 8x
method = if (non_stratified) { 271 6x
methods[["diff_pval_method"]] %||% "chisq"272
} else { 273 2x
methods[["strat_diff_pval_method"]] %||% "cmh"274
},275 8x
variables = list(strata = strata),276 8x
table_names = if (non_stratified) "test_prop_diff" else "test_prop_diff_strat"277
)278 279 8x
if (odds_ratio) { 280 4x
lyt <- lyt %>%281 4x
estimate_odds_ratio(282 4x
vars = rsp_var,283 4x
variables = if (non_stratified) list(strata = strata, arm = arm_var),284 4x
table_names = if (non_stratified) "est_or" else "est_or_strat"285
)286
}287 288 8x
lyt289
}290 291
#' Helper function to add a row split if specified292
#'293
#' @param lyt (`PreDataTableLayouts`) object.294
#' @param var (`string`) the name of the variable initiating a new row split.295
#' @param lbl_var (`string`)the label of the variable `var`.296
#'297
#' @keywords internal298
#'299
#' @return `PreDataTableLayouts` object.300
#'301
ifneeded_split_row <- function(lyt, var, lbl_var) { 302 2x
if (is.null(var)) { 303 1x
lyt304
} else { 305 1x
split_rows_by(lyt, var,306 1x
label_pos = "topleft",307 1x
split_label = lbl_var308
)309
}310
}311 312
#' Helper function to add a column split if specified313
#'314
#' @param lyt (`rtables`) object.315
#' @param var (`string`) the name of the variable initiating a new column split.316
#' @param ... Additional arguments for `split_cols_by`.317
#'318
#' @keywords internal319
#'320
#' @return `rtables` object.321
#'322
ifneeded_split_col <- function(lyt, var, ...) { 323 16x
if (is.null(var)) { 324 11x
lyt325
} else { 326 5x
split_cols_by(327 5x
lyt = lyt,328 5x
var = var,329
...330
)331
}332
}333 334
#' Create a Null Report335
#' @rdname report_null336
#' @aliases null_report337
#' @param tlg (`TableTree`) object.338
#' @param ... not used. Important to be used directly as post processing function.339
#'340
#' @export341
#'342
#' @return original `TableTree` or a null report if no observation are found in the table.343
#'344
report_null <- function(tlg, ...) { 345 167x
assert_true(is.null(tlg) || rtables::is_rtable(tlg))346 347 167x
if (is.null(tlg) || nrow(tlg) == 0L) { 348 25x
return(null_report)349
}350 142x
if (count_children(tlg) == 0) { 351 1x
return(null_report)352
}353 141x
tlg354
}355 356
#' Count Children357
#' @keywords internal358
count_children <- function(x) { 359 2540x
assert_true(rtables::is_rtable(x))360 2540x
if (is(x, "ElementaryTable")) { 361 1069x
return(length(x@children))362
}363 1471x
sum(vapply(364 1471x
tree_children(x),365 1471x
count_children,366 1471x
FUN.VALUE = 0367
))368
}369 370
#' @export371
#' @rdname report_null372
null_report <- rtables::rtable(373
header = "",374
rrow("", "Null Report: No observations met the reporting criteria for inclusion in this output.") 375
)376 377
#' @export378
#' @rdname report_null379
null_listing <- rlistings::as_listing(380
df = data.frame(x = formatters::with_label(381
"Null Report: No observations met the reporting criteria for inclusion in this output.", ""382
))383
)384 385
has_overall_col <- function(lbl_overall) { 386 128x
!is.null(lbl_overall) && !identical(lbl_overall, "")387
}388 389
ifneeded_add_overall_col <- function(lyt, lbl_overall) { 390 128x
if (has_overall_col(lbl_overall)) { 391 14x
add_overall_col(lyt, label = lbl_overall)392
} else { 393 114x
lyt394
}395
}396 397
#' Analyze skip baseline398
#' @param x value to analyze399
#' @param .var variable name.400
#' @param .spl_context split context.401
#' @param paramcdvar (`string`) name of parameter code.402
#' @param visitvar (`string`) name of the visit variable.403
#' @param skip Named (`character`) indicating the pairs to skip in analyze.404
#' @param .stats (`character`) See `tern::summarize_variables`.405
#' @param .label (`character`) See `tern::summarize_variables`.406
#' @param .indent_mods (`integer`) See `tern::summarize_variables`.407
#' @param .N_col (`int`) See `tern::summarize_variables`.408
#' @param .N_row (`int`) See `tern::summarize_variables`.409
#' @param ... additional arguments for `tern::a_summary`.410
#' @inheritParams cfbt01_main411
#' @keywords internal412
afun_skip <- function(413
x, .var, .spl_context, paramcdvar, visitvar, skip,414
precision, .stats, .labels = NULL, .indent_mods = NULL, .N_col, .N_row, ...) { # nolint 415 1452x
param_val <- .spl_context$value[which(.spl_context$split == paramcdvar)]416
# Identify context417 1452x
split_level <- .spl_context$value[which(.spl_context$split == visitvar)]418 1452x
pcs <- if (.var %in% names(skip) && split_level %in% skip[[.var]]) { 419 1452x
NA420
} else { 421 1341x
precision[[param_val]] %||% precision[["default"]] %||% 2422
}423 424 1452x
fmts <- lapply(.stats, summary_formats, pcs = pcs, FALSE)425 1452x
names(fmts) <- .stats426 1452x
fmts_na <- lapply(.stats, summary_formats, pcs = pcs, ne = TRUE)427 1452x
ret <- tern::a_summary(428 1452x
.stats = .stats, .formats = fmts, .labels = .labels, .indent_mods = .indent_mods,429 1452x
x = x, .var = .var, .spl_context = .spl_context, .N_col = .N_col, .N_row = .N_row, ...430
)431 1452x
for (i in seq_len(length(ret))) { 432 5808x
attr(ret[[i]], "format_na_str") <- fmts_na[[i]]()433
}434 1452x
ret435
}436 437
summary_formats <- function(x, pcs, ne = FALSE) { 438 11616x
assert_int(pcs, lower = 0, na.ok = TRUE)439 11616x
switch(x,440 2904x
n = h_format_dec(format = "%s", digits = pcs - pcs, ne = ne),441
min = ,442
max = ,443 !
sum = h_format_dec(format = "%s", digits = pcs, ne = ne),444
mean = ,445
sd = ,446
median = ,447
mad = ,448
iqr = ,449
cv = ,450
geom_mean = ,451
geom_cv = ,452 2904x
se = h_format_dec(format = "%s", digits = pcs + 1, ne = ne),453
mean_sd = ,454 2904x
mean_se = h_format_dec(format = "%s (%s)", digits = rep(pcs + 1, 2), ne = ne),455
mean_ci = ,456
mean_sei = ,457
median_ci = ,458 !
mean_sdi = h_format_dec(format = "(%s, %s)", digits = rep(pcs + 1, 2), ne = ne),459 !
mean_pval = h_format_dec(format = "%s", digits = 2, ne = ne),460 !
quantiles = h_format_dec(format = "(%s - %s)", digits = rep(pcs + 1, 2), ne = ne),461 2904x
range = h_format_dec(format = "%s - %s", digits = rep(pcs, 2), ne = ne),462 !
median_range = h_format_dec(format = "%s (%s - %s)", digits = c(pcs, pcs + 1, pcs + 1), ne = ne)463
)464
}465 466
split_fun_map <- function(map) { 467 9x
if (is.null(map)) { 468 6x
drop_split_levels469
} else { 470 3x
trim_levels_to_map(map = map)471
}472
}473 474
infer_mapping <- function(map_df, df) { 475 3x
assert_data_frame(df)476 3x
vars <- colnames(map_df)477 3x
assert_names(names(df), must.include = vars)478 3x
for (x in vars) { 479 7x
if (!test_subset(map_df[[x]], lvls(df[[x]]))) { 480 !
rlang::abort(481 !
paste0(482 !
"Provided map should only contain valid levels in dataset in variable ", x,483 !
". Consider convert ", x, " to factor first and add",484 !
toString(setdiff(map_df[[x]], lvls(df[[x]]))), "levels to it."485
)486
)487
}488
}489 3x
res <- df[vars] %>%490 3x
unique() %>%491 3x
arrange(across(everything())) %>%492 3x
mutate(across(everything(), as.character))493 3x
if (!is.null(map_df)) { 494 3x
dplyr::full_join(map_df, res, by = colnames(map_df))[vars]495
} else { 496 !
res497
}498
}499 500 501
#' Occurrence Layout502
#'503
#' @inheritParams gen_args504
#' @inheritParams cmt01a_main505
#' @param lbl_medname_var (`string`) label for the variable defining the medication name.506
#' @keywords internal507
#'508
occurrence_lyt <- function(arm_var,509
lbl_overall,510
row_split_var,511
lbl_row_split,512
medname_var,513
lbl_medname_var,514
summary_labels,515
count_by) { 516 17x
split_indent <- vapply(c("TOTAL", row_split_var), function(x) { 517 !
if (length(summary_labels[[x]]) > 0L) -1L else 0L518 17x
}, FUN.VALUE = 0L)519 17x
split_indent[1L] <- 0L520 17x
lyt <- basic_table() %>%521 17x
split_cols_by(var = arm_var) %>%522 17x
add_colcounts() %>%523 17x
ifneeded_add_overall_col(lbl_overall)524 17x
if (length(summary_labels$TOTAL) > 0) { 525 17x
lyt <- lyt %>%526 17x
analyze_num_patients(527 17x
vars = "USUBJID",528 17x
count_by = count_by,529 17x
.stats = names(summary_labels$TOTAL),530 17x
show_labels = "hidden",531 17x
.labels = render_safe(summary_labels$TOTAL)532
)533
}534 17x
for (k in seq_len(length(row_split_var))) { 535 13x
lyt <- split_and_summ_num_patients(536 13x
lyt = lyt,537 13x
count_by = count_by,538 13x
var = row_split_var[k],539 13x
label = lbl_row_split[k],540 13x
split_indent = split_indent[k],541 13x
stats = names(summary_labels[[row_split_var[k]]]),542 13x
summarize_labels = render_safe(summary_labels[[row_split_var[k]]])543
)544
}545 17x
lyt %>%546 17x
count_occurrences(547 17x
vars = medname_var,548 17x
drop = length(row_split_var) > 0,549 17x
.indent_mods = unname(tail(split_indent, 1L))550
) %>%551 17x
append_topleft(paste0(stringr::str_dup(" ", 2 * length(row_split_var)), lbl_medname_var)) 552
}
RetroSearch is an open source project built by @garambo | Open a GitHub Issue
Search and Browse the WWW like it's 1997 | Search results from DuckDuckGo
HTML:
3.2
| Encoding:
UTF-8
| Version:
0.7.4