From 7a10d3fca6da48fd7df4d2158a9e1138b131e31d Mon Sep 17 00:00:00 2001 From: Melkiades Date: Fri, 28 Feb 2025 18:55:05 +0100 Subject: [PATCH 01/12] init --- R/incidence_rate.R | 4 +- R/prop_diff.R | 138 ++++++++++++++++++++++++++++++++++++--------- R/prop_diff_test.R | 136 ++++++++++++++++++++++++++++++++++++-------- R/utils_factor.R | 62 ++++++++++---------- 4 files changed, 257 insertions(+), 83 deletions(-) diff --git a/R/incidence_rate.R b/R/incidence_rate.R index c517c35e8c..383fcd7784 100644 --- a/R/incidence_rate.R +++ b/R/incidence_rate.R @@ -155,10 +155,10 @@ a_incidence_rate <- function(df, # Fill in with defaults formats_def <- formals()$.formats %>% eval() .formats <- c(.formats, formats_def)[!duplicated(names(c(.formats, formats_def)))] - labels_def <- sapply(x_stats, \(x) attributes(x)$label) + labels_def <- sapply(x_stats, function(x) attributes(x)$label) .labels <- c(.labels, labels_def)[!duplicated(names(c(.labels, labels_def)))] if (nzchar(labelstr) > 0) { - .labels <- sapply(.labels, \(x) gsub("%.labels", x, gsub("%s", labelstr, label_fmt))) + .labels <- sapply(.labels, function(x) gsub("%.labels", x, gsub("%s", labelstr, label_fmt))) } # Fill in with formatting defaults if needed diff --git a/R/prop_diff.R b/R/prop_diff.R index bcf28c6272..e5d045b707 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -64,7 +64,8 @@ s_proportion_diff <- function(df, "ha", "newcombe", "newcombecc", "strat_newcombe", "strat_newcombecc" ), - weights_method = "cmh") { + weights_method = "cmh", + ...) { method <- match.arg(method) if (is.null(variables$strata) && checkmate::test_subset(method, c("cmh", "strat_newcombe", "strat_newcombecc"))) { stop(paste( @@ -72,7 +73,7 @@ s_proportion_diff <- function(df, "permitted. Please choose a different method." )) } - y <- list(diff = "", diff_ci = "") + y <- list(diff = character(), diff_ci = character()) if (!.in_ref_col) { rsp <- c(.ref_group[[.var]], df[[.var]]) @@ -151,6 +152,7 @@ s_proportion_diff <- function(df, #' @examples #' a_proportion_diff( #' df = subset(dta, grp == "A"), +#' .stats = c("diff"), #' .var = "rsp", #' .ref_group = subset(dta, grp == "B"), #' .in_ref_col = FALSE, @@ -159,11 +161,75 @@ s_proportion_diff <- function(df, #' ) #' #' @export -a_proportion_diff <- make_afun( - s_proportion_diff, - .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"), - .indent_mods = c(diff = 0L, diff_ci = 1L) -) +a_proportion_diff <- function(df, + ..., + .stats = NULL, + .stat_names = NULL, + .formats = NULL, + .labels = NULL, + .indent_mods = NULL) { + dots_extra_args <- list(...) + + # Check if there are user-defined functions + default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) + .stats <- default_and_custom_stats_list$default_stats + custom_stat_functions <- default_and_custom_stats_list$custom_stats + + # Adding automatically extra parameters to the statistic function (see ?rtables::additional_fun_params) + extra_afun_params <- retrieve_extra_afun_params( + names(dots_extra_args$.additional_fun_parameters) + ) + dots_extra_args$.additional_fun_parameters <- NULL # After extraction we do not need them anymore + + # Main statistical functions application + x_stats <- .apply_stat_functions( + default_stat_fnc = s_proportion_diff, + custom_stat_fnc_list = custom_stat_functions, + args_list = c( + df = list(df), + extra_afun_params, + dots_extra_args + ) + ) + + # Fill in with stats defaults if needed + .stats <- c( + get_stats("estimate_proportion_diff", stats_in = .stats), + names(custom_stat_functions) + ) + + x_stats <- x_stats[.stats] + + # Fill in formats/indents/labels with custom input and defaults + .formats <- get_formats_from_stats(.stats, .formats) + .indent_mods <- get_indents_from_stats(.stats, .indent_mods) + if (is.null(.labels)) { + .labels <- sapply(x_stats, attr, "label") + .labels <- .labels[nzchar(.labels)] + } + .labels <- get_labels_from_stats(.stats, .labels) + + # Auto format handling + .formats <- apply_auto_formatting( + .formats, + x_stats, + extra_afun_params$.df_row, + extra_afun_params$.var + ) + + # Get and check statistical names from defaults + .stat_names <- get_stat_names(x_stats, .stat_names) # note is x_stats + .stat_names <- paste0(.stat_names, "_", dots_extra_args$method) + + in_rows( + .list = x_stats, + .formats = .formats, + .names = names(.labels), + .stat_names = .stat_names, + .labels = .labels %>% .unlist_keep_nulls(), + .indent_mods = .indent_mods %>% .unlist_keep_nulls() + ) +} #' @describeIn prop_diff Layout-creating function which can take statistics function arguments #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. @@ -198,6 +264,14 @@ a_proportion_diff <- make_afun( #' @order 2 estimate_proportion_diff <- function(lyt, vars, + var_labels = vars, + na_str = default_na_str(), + nested = TRUE, + show_labels = "default", + table_names = vars, + section_div = NA_character_, + ..., + na_rm = TRUE, variables = list(strata = NULL), conf_level = 0.95, method = c( @@ -206,38 +280,48 @@ estimate_proportion_diff <- function(lyt, "strat_newcombe", "strat_newcombecc" ), weights_method = "cmh", - na_str = default_na_str(), - nested = TRUE, - ..., - var_labels = vars, - show_labels = "hidden", - table_names = vars, - .stats = NULL, - .formats = NULL, + .stats = c("diff", "diff_ci"), + .stat_names = NULL, + .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"), .labels = NULL, - .indent_mods = NULL) { + .indent_mods = c(diff = 0L, diff_ci = 1L)) { + # Depending on main functions extra_args <- list( - variables = variables, conf_level = conf_level, method = method, weights_method = weights_method, ... + "na_rm" = na_rm, + "variables" = variables, + "conf_level" = conf_level, + "method" = method, + "weights_method" = weights_method, + ... ) - afun <- make_afun( - a_proportion_diff, - .stats = .stats, - .formats = .formats, - .labels = .labels, - .indent_mods = .indent_mods + # Needed defaults + if (!is.null(.stats)) extra_args[[".stats"]] <- .stats + if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names + if (!is.null(.formats)) extra_args[[".formats"]] <- .formats + if (!is.null(.labels)) extra_args[[".labels"]] <- .labels + if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods + + # Adding all additional information from layout to analysis functions (see ?rtables::additional_fun_params) + extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) + formals(a_proportion_diff) <- c( + formals(a_proportion_diff), + extra_args[[".additional_fun_parameters"]] ) + # Main {rtables} structural call analyze( - lyt, - vars, - afun = afun, + lyt = lyt, + vars = vars, var_labels = var_labels, + afun = a_proportion_diff, na_str = na_str, + inclNAs = !na_rm, nested = nested, extra_args = extra_args, show_labels = show_labels, - table_names = table_names + table_names = table_names, + section_div = section_div ) } diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index 5af48ada18..ac97846dd6 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -32,9 +32,10 @@ s_test_proportion_diff <- function(df, .ref_group, .in_ref_col, variables = list(strata = NULL), - method = c("chisq", "schouten", "fisher", "cmh")) { + method = c("chisq", "schouten", "fisher", "cmh"), + ...) { method <- match.arg(method) - y <- list(pval = "") + y <- list(pval = character()) if (!.in_ref_col) { assert_df_with_variables(df, list(rsp = .var)) @@ -103,11 +104,74 @@ d_test_proportion_diff <- function(method) { #' * `a_test_proportion_diff()` returns the corresponding list with formatted [rtables::CellValue()]. #' #' @keywords internal -a_test_proportion_diff <- make_afun( - s_test_proportion_diff, - .formats = c(pval = "x.xxxx | (<0.0001)"), - .indent_mods = c(pval = 1L) -) +a_test_proportion_diff <- function(df, + ..., + .stats = NULL, + .stat_names = NULL, + .formats = NULL, + .labels = NULL, + .indent_mods = NULL) { + dots_extra_args <- list(...) + + # Check if there are user-defined functions + default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) + .stats <- default_and_custom_stats_list$default_stats + custom_stat_functions <- default_and_custom_stats_list$custom_stats + + # Adding automatically extra parameters to the statistic function (see ?rtables::additional_fun_params) + extra_afun_params <- retrieve_extra_afun_params( + names(dots_extra_args$.additional_fun_parameters) + ) + dots_extra_args$.additional_fun_parameters <- NULL # After extraction we do not need them anymore + + # Main statistical functions application + x_stats <- .apply_stat_functions( + default_stat_fnc = s_test_proportion_diff, + custom_stat_fnc_list = custom_stat_functions, + args_list = c( + df = list(df), + extra_afun_params, + dots_extra_args + ) + ) + + # Fill in with stats defaults if needed + .stats <- c( + get_stats("test_proportion_diff", stats_in = .stats), + names(custom_stat_functions) + ) + + x_stats <- x_stats[.stats] + + # Fill in formats/indents/labels with custom input and defaults + .formats <- get_formats_from_stats(.stats, .formats) + .indent_mods <- get_indents_from_stats(.stats, .indent_mods) + if (is.null(.labels)) { + .labels <- sapply(x_stats, attr, "label") + } + .labels <- get_labels_from_stats(.stats, .labels) + + # Auto format handling + .formats <- apply_auto_formatting( + .formats, + x_stats, + extra_afun_params$.df_row, + extra_afun_params$.var + ) + + # Get and check statistical names from defaults + .stat_names <- get_stat_names(x_stats, .stat_names) # note is x_stats + .stat_names <- paste0(.stat_names, "_", dots_extra_args$method) + + in_rows( + .list = x_stats, + .formats = .formats, + .names = names(.labels), + .stat_names = .stat_names, + .labels = .labels %>% .unlist_keep_nulls(), + .indent_mods = .indent_mods %>% .unlist_keep_nulls() + ) +} #' @describeIn prop_diff_test Layout-creating function which can take statistics function arguments #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. @@ -138,37 +202,59 @@ a_test_proportion_diff <- make_afun( #' @order 2 test_proportion_diff <- function(lyt, vars, - variables = list(strata = NULL), - method = c("chisq", "schouten", "fisher", "cmh"), + var_labels = vars, na_str = default_na_str(), nested = TRUE, - ..., - var_labels = vars, show_labels = "hidden", table_names = vars, - .stats = NULL, - .formats = NULL, + section_div = NA_character_, + ..., + na_rm = TRUE, + variables = list(strata = NULL), + # conf_level = 0.95, + method = c("chisq", "schouten", "fisher", "cmh"), + .stats = c("pval"), + # .stats = c("diff", "diff_ci"), + .stat_names = NULL, + .formats = c(pval = "x.xxxx | (<0.0001)"), .labels = NULL, - .indent_mods = NULL) { - extra_args <- list(variables = variables, method = method, ...) + .indent_mods = c(pval = 1L)) { + # Depending on main functions + extra_args <- list( + "na_rm" = na_rm, + "variables" = variables, + # "conf_level" = conf_level, + "method" = method, + ... + ) - afun <- make_afun( - a_test_proportion_diff, - .stats = .stats, - .formats = .formats, - .labels = .labels, - .indent_mods = .indent_mods + # Needed defaults + if (!is.null(.stats)) extra_args[[".stats"]] <- .stats + if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names + if (!is.null(.formats)) extra_args[[".formats"]] <- .formats + if (!is.null(.labels)) extra_args[[".labels"]] <- .labels + if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods + + # Adding all additional information from layout to analysis functions (see ?rtables::additional_fun_params) + extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) + formals(a_test_proportion_diff) <- c( + formals(a_test_proportion_diff), + extra_args[[".additional_fun_parameters"]] ) + + # Main {rtables} structural call analyze( - lyt, - vars, - afun = afun, + lyt = lyt, + vars = vars, var_labels = var_labels, + afun = a_test_proportion_diff, na_str = na_str, + inclNAs = !na_rm, nested = nested, extra_args = extra_args, show_labels = show_labels, - table_names = table_names + table_names = table_names, + section_div = section_div ) } diff --git a/R/utils_factor.R b/R/utils_factor.R index 669bb93279..0e64704a24 100644 --- a/R/utils_factor.R +++ b/R/utils_factor.R @@ -1,14 +1,23 @@ -#' Combine factor levels +#' Factor utilities #' #' @description `r lifecycle::badge("stable")` #' -#' Combine specified old factor Levels in a single new level. +#' A collection of utility functions for factors. +#' +#' @param x (`factor`)\cr factor variable or object to convert (for `as_factor_keep_attributes`). +#' +#' @seealso [cut_quantile_bins()] for splitting numeric vectors into quantile bins. +#' +#' @name factor_utils +NULL + +#' @describeIn factor_utils Combine specified old factor Levels in a single new level. #' -#' @param x (`factor`)\cr factor variable. #' @param levels (`character`)\cr level names to be combined. #' @param new_level (`string`)\cr name of new level. #' -#' @return A `factor` with the new levels. +#' @return +#' * `combine_levels`: A `factor` with the new levels. #' #' @examples #' x <- factor(letters[1:5], levels = letters[5:1]) @@ -32,18 +41,23 @@ combine_levels <- function(x, levels, new_level = paste(levels, collapse = "/")) #' Conversion of a vector to a factor #' -#' Converts `x` to a factor and keeps its attributes. Warns appropriately such that the user +#' @describeIn factor_utils Converts `x` to a factor and keeps its attributes. Warns appropriately such that the user #' can decide whether they prefer converting to factor manually (e.g. for full control of #' factor levels). #' -#' @param x (`vector`)\cr object to convert. #' @param x_name (`string`)\cr name of `x`. #' @param na_level (`string`)\cr the explicit missing level which should be used when converting a character vector. #' @param verbose (`flag`)\cr defaults to `TRUE`. It prints out warnings and messages. #' -#' @return A `factor` with same attributes (except class) as `x`. Does not modify `x` if already a `factor`. +#' @return +#' * `as_factor_keep_attributes`: A `factor` with same attributes (except class) as `x`. Does not modify `x` if already a `factor`. #' -#' @keywords internal +#' @examples +#' a_chr_with_labels <- c("a", "b", NA) +#' attr(a_chr_with_labels, "label") <- "A character vector with labels" +#' as_factor_keep_attributes(a_chr_with_labels) +#' +#' @export as_factor_keep_attributes <- function(x, x_name = deparse(substitute(x)), na_level = "", @@ -132,7 +146,8 @@ bins_percent_labels <- function(probs, #' @param type (`integer(1)`)\cr type of quantiles to use, see [stats::quantile()] for details. #' @param ordered (`flag`)\cr should the result be an ordered factor. #' -#' @return A `factor` variable with appropriately-labeled bins as levels. +#' @return +#' * `cut_quantile_bins`: A `factor` variable with appropriately-labeled bins as levels. #' #' @note Intervals are closed on the right side. That is, the first bin is the interval #' `[-Inf, q1]` where `q1` is the first quantile, the second bin is then `(q1, q2]`, etc., @@ -192,16 +207,12 @@ cut_quantile_bins <- function(x, ) } -#' Discard specified levels of a factor +#' @describeIn factor_utils This discards the observations as well as the levels specified from a factor. #' -#' @description `r lifecycle::badge("stable")` -#' -#' This discards the observations as well as the levels specified from a factor. -#' -#' @param x (`factor`)\cr the original factor. #' @param discard (`character`)\cr levels to discard. #' -#' @return A modified `factor` with observations as well as levels from `discard` dropped. +#' @return +#' * `fct_discard`: A modified `factor` with observations as well as levels from `discard` dropped. #' #' @examples #' fct_discard(factor(c("a", "b", "c")), "c") @@ -215,18 +226,14 @@ fct_discard <- function(x, discard) { factor(new_obs, levels = new_levels) } -#' Insertion of explicit missing values in a factor -#' -#' @description `r lifecycle::badge("stable")` -#' -#' This inserts explicit missing values in a factor based on a condition. Additionally, +#' @describeIn factor_utils This inserts explicit missing values in a factor based on a condition. Additionally, #' existing `NA` values will be explicitly converted to given `na_level`. #' -#' @param x (`factor`)\cr the original factor. #' @param condition (`logical`)\cr positions at which to insert missing values. #' @param na_level (`string`)\cr which level to use for missing values. #' -#' @return A modified `factor` with inserted and existing `NA` converted to `na_level`. +#' @return +#' * `fct_explicit_na_if`: A modified `factor` with inserted and existing `NA` converted to `na_level`. #' #' @seealso [forcats::fct_na_value_to_level()] which is used internally. #' @@ -242,11 +249,7 @@ fct_explicit_na_if <- function(x, condition, na_level = "") { forcats::fct_drop(x, only = na_level) } -#' Collapse factor levels and keep only those new group levels -#' -#' @description `r lifecycle::badge("stable")` -#' -#' This collapses levels and only keeps those new group levels, in the order provided. +#' @describeIn factor_utils This collapses levels and only keeps those new group levels, in the order provided. #' The returned factor has levels in the order given, with the possible missing level last (this will #' only be included if there are missing values). #' @@ -256,7 +259,8 @@ fct_explicit_na_if <- function(x, condition, na_level = "") { #' @param .na_level (`string`)\cr which level to use for other levels, which should be missing in the #' new factor. Note that this level must not be contained in the new levels specified in `...`. #' -#' @return A modified `factor` with collapsed levels. Values and levels which are not included +#' @return +#' * `fct_collapse_only`: A modified `factor` with collapsed levels. Values and levels which are not included #' in the given `character` vector input will be set to the missing level `.na_level`. #' #' @note Any existing `NA`s in the input vector will not be replaced by the missing level. If needed, From b9975963340996a3fb0f94acbe1be520c2b6eda1 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Fri, 28 Feb 2025 18:56:51 +0100 Subject: [PATCH 02/12] test correction --- tests/testthat/test-prop_diff.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-prop_diff.R b/tests/testthat/test-prop_diff.R index c6cdcc92db..c5296fecfa 100644 --- a/tests/testthat/test-prop_diff.R +++ b/tests/testthat/test-prop_diff.R @@ -262,7 +262,7 @@ testthat::test_that("`estimate_proportion_diff` and cmh is compatible with `rtab vars = "rsp", variables = list(strata = c("f1", "f2")), conf_level = 0.90, - .formats = c("xx.xxxx", "(xx.xxxx, xx.xxxx)"), + .formats = c(diff = "xx.xxxx", diff_ci = "(xx.xxxx, xx.xxxx)"), method = "cmh" ) @@ -292,7 +292,7 @@ testthat::test_that("`estimate_proportion_diff` and strat_newcombe is compatible vars = "rsp", variables = list(strata = c("f1", "f2")), conf_level = 0.95, - .formats = c("xx.xx", "(xx.xx, xx.xx)"), + .formats = c(diff = "xx.xx", diff_ci = "(xx.xx, xx.xx)"), method = "strat_newcombe" ) result <- build_table(l, df = dta) From 41450d6a8476b98a33e02b505a1b49542ed9db24 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 28 Feb 2025 18:02:38 +0000 Subject: [PATCH 03/12] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/as_factor_keep_attributes.Rd | 31 -------- man/combine_levels.Rd | 30 -------- man/cut_quantile_bins.Rd | 4 +- man/factor_utils.Rd | 124 +++++++++++++++++++++++++++++++ man/fct_collapse_only.Rd | 39 ---------- man/fct_discard.Rd | 25 ------- man/fct_explicit_na_if.Rd | 31 -------- man/prop_diff.Rd | 71 ++++++++++-------- man/prop_diff_test.Rd | 55 ++++++++------ 9 files changed, 202 insertions(+), 208 deletions(-) delete mode 100644 man/as_factor_keep_attributes.Rd delete mode 100644 man/combine_levels.Rd create mode 100644 man/factor_utils.Rd delete mode 100644 man/fct_collapse_only.Rd delete mode 100644 man/fct_discard.Rd delete mode 100644 man/fct_explicit_na_if.Rd diff --git a/man/as_factor_keep_attributes.Rd b/man/as_factor_keep_attributes.Rd deleted file mode 100644 index 02094fcd74..0000000000 --- a/man/as_factor_keep_attributes.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils_factor.R -\name{as_factor_keep_attributes} -\alias{as_factor_keep_attributes} -\title{Conversion of a vector to a factor} -\usage{ -as_factor_keep_attributes( - x, - x_name = deparse(substitute(x)), - na_level = "", - verbose = TRUE -) -} -\arguments{ -\item{x}{(\code{vector})\cr object to convert.} - -\item{x_name}{(\code{string})\cr name of \code{x}.} - -\item{na_level}{(\code{string})\cr the explicit missing level which should be used when converting a character vector.} - -\item{verbose}{(\code{flag})\cr defaults to \code{TRUE}. It prints out warnings and messages.} -} -\value{ -A \code{factor} with same attributes (except class) as \code{x}. Does not modify \code{x} if already a \code{factor}. -} -\description{ -Converts \code{x} to a factor and keeps its attributes. Warns appropriately such that the user -can decide whether they prefer converting to factor manually (e.g. for full control of -factor levels). -} -\keyword{internal} diff --git a/man/combine_levels.Rd b/man/combine_levels.Rd deleted file mode 100644 index b6d6fde6dc..0000000000 --- a/man/combine_levels.Rd +++ /dev/null @@ -1,30 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils_factor.R -\name{combine_levels} -\alias{combine_levels} -\title{Combine factor levels} -\usage{ -combine_levels(x, levels, new_level = paste(levels, collapse = "/")) -} -\arguments{ -\item{x}{(\code{factor})\cr factor variable.} - -\item{levels}{(\code{character})\cr level names to be combined.} - -\item{new_level}{(\code{string})\cr name of new level.} -} -\value{ -A \code{factor} with the new levels. -} -\description{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} - -Combine specified old factor Levels in a single new level. -} -\examples{ -x <- factor(letters[1:5], levels = letters[5:1]) -combine_levels(x, levels = c("a", "b")) - -combine_levels(x, c("e", "b")) - -} diff --git a/man/cut_quantile_bins.Rd b/man/cut_quantile_bins.Rd index d2d7687fd0..7d60a208d8 100644 --- a/man/cut_quantile_bins.Rd +++ b/man/cut_quantile_bins.Rd @@ -29,7 +29,9 @@ probabilities in \code{probs}, then this must be \code{n + 1} long.} \item{ordered}{(\code{flag})\cr should the result be an ordered factor.} } \value{ -A \code{factor} variable with appropriately-labeled bins as levels. +\itemize{ +\item \code{cut_quantile_bins}: A \code{factor} variable with appropriately-labeled bins as levels. +} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} diff --git a/man/factor_utils.Rd b/man/factor_utils.Rd new file mode 100644 index 0000000000..ce6cf1a829 --- /dev/null +++ b/man/factor_utils.Rd @@ -0,0 +1,124 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils_factor.R +\name{factor_utils} +\alias{factor_utils} +\alias{combine_levels} +\alias{as_factor_keep_attributes} +\alias{fct_discard} +\alias{fct_explicit_na_if} +\alias{fct_collapse_only} +\title{Factor utilities} +\usage{ +combine_levels(x, levels, new_level = paste(levels, collapse = "/")) + +as_factor_keep_attributes( + x, + x_name = deparse(substitute(x)), + na_level = "", + verbose = TRUE +) + +fct_discard(x, discard) + +fct_explicit_na_if(x, condition, na_level = "") + +fct_collapse_only(.f, ..., .na_level = "") +} +\arguments{ +\item{x}{(\code{factor})\cr factor variable or object to convert (for \code{as_factor_keep_attributes}).} + +\item{levels}{(\code{character})\cr level names to be combined.} + +\item{new_level}{(\code{string})\cr name of new level.} + +\item{x_name}{(\code{string})\cr name of \code{x}.} + +\item{na_level}{(\code{string})\cr which level to use for missing values.} + +\item{verbose}{(\code{flag})\cr defaults to \code{TRUE}. It prints out warnings and messages.} + +\item{discard}{(\code{character})\cr levels to discard.} + +\item{condition}{(\code{logical})\cr positions at which to insert missing values.} + +\item{.f}{(\code{factor} or \code{character})\cr original vector.} + +\item{...}{(named \code{character})\cr levels in each vector provided will be collapsed into +the new level given by the respective name.} + +\item{.na_level}{(\code{string})\cr which level to use for other levels, which should be missing in the +new factor. Note that this level must not be contained in the new levels specified in \code{...}.} +} +\value{ +\itemize{ +\item \code{combine_levels}: A \code{factor} with the new levels. +} + +\itemize{ +\item \code{as_factor_keep_attributes}: A \code{factor} with same attributes (except class) as \code{x}. Does not modify \code{x} if already a \code{factor}. +} + +\itemize{ +\item \code{fct_discard}: A modified \code{factor} with observations as well as levels from \code{discard} dropped. +} + +\itemize{ +\item \code{fct_explicit_na_if}: A modified \code{factor} with inserted and existing \code{NA} converted to \code{na_level}. +} + +\itemize{ +\item \code{fct_collapse_only}: A modified \code{factor} with collapsed levels. Values and levels which are not included +in the given \code{character} vector input will be set to the missing level \code{.na_level}. +} +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} + +A collection of utility functions for factors. +} +\section{Functions}{ +\itemize{ +\item \code{combine_levels()}: Combine specified old factor Levels in a single new level. + +\item \code{as_factor_keep_attributes()}: Converts \code{x} to a factor and keeps its attributes. Warns appropriately such that the user +can decide whether they prefer converting to factor manually (e.g. for full control of +factor levels). + +\item \code{fct_discard()}: This discards the observations as well as the levels specified from a factor. + +\item \code{fct_explicit_na_if()}: This inserts explicit missing values in a factor based on a condition. Additionally, +existing \code{NA} values will be explicitly converted to given \code{na_level}. + +\item \code{fct_collapse_only()}: This collapses levels and only keeps those new group levels, in the order provided. +The returned factor has levels in the order given, with the possible missing level last (this will +only be included if there are missing values). + +}} +\note{ +Any existing \code{NA}s in the input vector will not be replaced by the missing level. If needed, +\code{\link[=explicit_na]{explicit_na()}} can be called separately on the result. +} +\examples{ +x <- factor(letters[1:5], levels = letters[5:1]) +combine_levels(x, levels = c("a", "b")) + +combine_levels(x, c("e", "b")) + +a_chr_with_labels <- c("a", "b", NA) +attr(a_chr_with_labels, "label") <- "A character vector with labels" +as_factor_keep_attributes(a_chr_with_labels) + +fct_discard(factor(c("a", "b", "c")), "c") + +fct_explicit_na_if(factor(c("a", "b", NA)), c(TRUE, FALSE, FALSE)) + +fct_collapse_only(factor(c("a", "b", "c", "d")), TRT = "b", CTRL = c("c", "d")) + +} +\seealso{ +\code{\link[=cut_quantile_bins]{cut_quantile_bins()}} for splitting numeric vectors into quantile bins. + +\code{\link[forcats:fct_na_value_to_level]{forcats::fct_na_value_to_level()}} which is used internally. + +\code{\link[forcats:fct_collapse]{forcats::fct_collapse()}}, \code{\link[forcats:fct_relevel]{forcats::fct_relevel()}} which are used internally. +} diff --git a/man/fct_collapse_only.Rd b/man/fct_collapse_only.Rd deleted file mode 100644 index fb4785c099..0000000000 --- a/man/fct_collapse_only.Rd +++ /dev/null @@ -1,39 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils_factor.R -\name{fct_collapse_only} -\alias{fct_collapse_only} -\title{Collapse factor levels and keep only those new group levels} -\usage{ -fct_collapse_only(.f, ..., .na_level = "") -} -\arguments{ -\item{.f}{(\code{factor} or \code{character})\cr original vector.} - -\item{...}{(named \code{character})\cr levels in each vector provided will be collapsed into -the new level given by the respective name.} - -\item{.na_level}{(\code{string})\cr which level to use for other levels, which should be missing in the -new factor. Note that this level must not be contained in the new levels specified in \code{...}.} -} -\value{ -A modified \code{factor} with collapsed levels. Values and levels which are not included -in the given \code{character} vector input will be set to the missing level \code{.na_level}. -} -\description{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} - -This collapses levels and only keeps those new group levels, in the order provided. -The returned factor has levels in the order given, with the possible missing level last (this will -only be included if there are missing values). -} -\note{ -Any existing \code{NA}s in the input vector will not be replaced by the missing level. If needed, -\code{\link[=explicit_na]{explicit_na()}} can be called separately on the result. -} -\examples{ -fct_collapse_only(factor(c("a", "b", "c", "d")), TRT = "b", CTRL = c("c", "d")) - -} -\seealso{ -\code{\link[forcats:fct_collapse]{forcats::fct_collapse()}}, \code{\link[forcats:fct_relevel]{forcats::fct_relevel()}} which are used internally. -} diff --git a/man/fct_discard.Rd b/man/fct_discard.Rd deleted file mode 100644 index 31b0fd13c8..0000000000 --- a/man/fct_discard.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils_factor.R -\name{fct_discard} -\alias{fct_discard} -\title{Discard specified levels of a factor} -\usage{ -fct_discard(x, discard) -} -\arguments{ -\item{x}{(\code{factor})\cr the original factor.} - -\item{discard}{(\code{character})\cr levels to discard.} -} -\value{ -A modified \code{factor} with observations as well as levels from \code{discard} dropped. -} -\description{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} - -This discards the observations as well as the levels specified from a factor. -} -\examples{ -fct_discard(factor(c("a", "b", "c")), "c") - -} diff --git a/man/fct_explicit_na_if.Rd b/man/fct_explicit_na_if.Rd deleted file mode 100644 index d38677d05a..0000000000 --- a/man/fct_explicit_na_if.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils_factor.R -\name{fct_explicit_na_if} -\alias{fct_explicit_na_if} -\title{Insertion of explicit missing values in a factor} -\usage{ -fct_explicit_na_if(x, condition, na_level = "") -} -\arguments{ -\item{x}{(\code{factor})\cr the original factor.} - -\item{condition}{(\code{logical})\cr positions at which to insert missing values.} - -\item{na_level}{(\code{string})\cr which level to use for missing values.} -} -\value{ -A modified \code{factor} with inserted and existing \code{NA} converted to \code{na_level}. -} -\description{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} - -This inserts explicit missing values in a factor based on a condition. Additionally, -existing \code{NA} values will be explicitly converted to given \code{na_level}. -} -\examples{ -fct_explicit_na_if(factor(c("a", "b", NA)), c(TRUE, FALSE, FALSE)) - -} -\seealso{ -\code{\link[forcats:fct_na_value_to_level]{forcats::fct_na_value_to_level()}} which is used internally. -} diff --git a/man/prop_diff.Rd b/man/prop_diff.Rd index 658a31c49d..46f416893a 100644 --- a/man/prop_diff.Rd +++ b/man/prop_diff.Rd @@ -10,21 +10,24 @@ estimate_proportion_diff( lyt, vars, + var_labels = vars, + na_str = default_na_str(), + nested = TRUE, + show_labels = "default", + table_names = vars, + section_div = NA_character_, + ..., + na_rm = TRUE, variables = list(strata = NULL), conf_level = 0.95, method = c("waldcc", "wald", "cmh", "ha", "newcombe", "newcombecc", "strat_newcombe", "strat_newcombecc"), weights_method = "cmh", - na_str = default_na_str(), - nested = TRUE, - ..., - var_labels = vars, - show_labels = "hidden", - table_names = vars, - .stats = NULL, - .formats = NULL, + .stats = c("diff", "diff_ci"), + .stat_names = NULL, + .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"), .labels = NULL, - .indent_mods = NULL + .indent_mods = c(diff = 0L, diff_ci = 1L) ) s_proportion_diff( @@ -36,19 +39,18 @@ s_proportion_diff( conf_level = 0.95, method = c("waldcc", "wald", "cmh", "ha", "newcombe", "newcombecc", "strat_newcombe", "strat_newcombecc"), - weights_method = "cmh" + weights_method = "cmh", + ... ) a_proportion_diff( df, - .var, - .ref_group, - .in_ref_col, - variables = list(strata = NULL), - conf_level = 0.95, - method = c("waldcc", "wald", "cmh", "ha", "newcombe", "newcombecc", "strat_newcombe", - "strat_newcombecc"), - weights_method = "cmh" + ..., + .stats = NULL, + .stat_names = NULL, + .formats = NULL, + .labels = NULL, + .indent_mods = NULL ) } \arguments{ @@ -56,14 +58,7 @@ a_proportion_diff( \item{vars}{(\code{character})\cr variable names for the primary analysis variable to be iterated over.} -\item{variables}{(named \code{list} of \code{string})\cr list of additional analysis variables.} - -\item{conf_level}{(\code{proportion})\cr confidence level of the interval.} - -\item{method}{(\code{string})\cr the method used for the confidence interval estimation.} - -\item{weights_method}{(\code{string})\cr weights method. Can be either \code{"cmh"} or \code{"heuristic"} -and directs the way weights are estimated.} +\item{var_labels}{(\code{character})\cr variable labels.} \item{na_str}{(\code{string})\cr string used to replace all \code{NA} or empty values in the output.} @@ -71,19 +66,34 @@ and directs the way weights are estimated.} possible (\code{TRUE}, the default) or as a new top-level element (\code{FALSE}). Ignored if it would nest a split. underneath analyses, which is not allowed.} -\item{...}{additional arguments for the lower level functions.} - -\item{var_labels}{(\code{character})\cr variable labels.} - \item{show_labels}{(\code{string})\cr label visibility: one of "default", "visible" and "hidden".} \item{table_names}{(\code{character})\cr this can be customized in the case that the same \code{vars} are analyzed multiple times, to avoid warnings from \code{rtables}.} +\item{section_div}{(\code{string})\cr string which should be repeated as a section divider after each group +defined by this split instruction, or \code{NA_character_} (the default) for no section divider.} + +\item{...}{additional arguments for the lower level functions.} + +\item{na_rm}{(\code{flag})\cr whether \code{NA} values should be removed from \code{x} prior to analysis.} + +\item{variables}{(named \code{list} of \code{string})\cr list of additional analysis variables.} + +\item{conf_level}{(\code{proportion})\cr confidence level of the interval.} + +\item{method}{(\code{string})\cr the method used for the confidence interval estimation.} + +\item{weights_method}{(\code{string})\cr weights method. Can be either \code{"cmh"} or \code{"heuristic"} +and directs the way weights are estimated.} + \item{.stats}{(\code{character})\cr statistics to select for the table. Options are: \verb{'diff', 'diff_ci'}} +\item{.stat_names}{(\code{character})\cr names of the statistics that are passed directly to name single statistics +(\code{.stats}). This option is visible when producing \code{\link[rtables:data.frame_export]{rtables::as_result_df()}} with \code{make_ard = TRUE}.} + \item{.formats}{(named \code{character} or \code{list})\cr formats for the statistics. See Details in \code{analyze_vars} for more information on the \code{"auto"} setting.} @@ -183,6 +193,7 @@ s_proportion_diff( a_proportion_diff( df = subset(dta, grp == "A"), + .stats = c("diff"), .var = "rsp", .ref_group = subset(dta, grp == "B"), .in_ref_col = FALSE, diff --git a/man/prop_diff_test.Rd b/man/prop_diff_test.Rd index 5eb9264ff0..8aa9cb3f56 100644 --- a/man/prop_diff_test.Rd +++ b/man/prop_diff_test.Rd @@ -10,18 +10,21 @@ test_proportion_diff( lyt, vars, - variables = list(strata = NULL), - method = c("chisq", "schouten", "fisher", "cmh"), + var_labels = vars, na_str = default_na_str(), nested = TRUE, - ..., - var_labels = vars, show_labels = "hidden", table_names = vars, - .stats = NULL, - .formats = NULL, + section_div = NA_character_, + ..., + na_rm = TRUE, + variables = list(strata = NULL), + method = c("chisq", "schouten", "fisher", "cmh"), + .stats = c("pval"), + .stat_names = NULL, + .formats = c(pval = "x.xxxx | (<0.0001)"), .labels = NULL, - .indent_mods = NULL + .indent_mods = c(pval = 1L) ) s_test_proportion_diff( @@ -30,16 +33,18 @@ s_test_proportion_diff( .ref_group, .in_ref_col, variables = list(strata = NULL), - method = c("chisq", "schouten", "fisher", "cmh") + method = c("chisq", "schouten", "fisher", "cmh"), + ... ) a_test_proportion_diff( df, - .var, - .ref_group, - .in_ref_col, - variables = list(strata = NULL), - method = c("chisq", "schouten", "fisher", "cmh") + ..., + .stats = NULL, + .stat_names = NULL, + .formats = NULL, + .labels = NULL, + .indent_mods = NULL ) } \arguments{ @@ -47,10 +52,7 @@ a_test_proportion_diff( \item{vars}{(\code{character})\cr variable names for the primary analysis variable to be iterated over.} -\item{variables}{(named \code{list} of \code{string})\cr list of additional analysis variables.} - -\item{method}{(\code{string})\cr one of \code{chisq}, \code{cmh}, \code{fisher}, or \code{schouten}; specifies the test used -to calculate the p-value.} +\item{var_labels}{(\code{character})\cr variable labels.} \item{na_str}{(\code{string})\cr string used to replace all \code{NA} or empty values in the output.} @@ -58,19 +60,30 @@ to calculate the p-value.} possible (\code{TRUE}, the default) or as a new top-level element (\code{FALSE}). Ignored if it would nest a split. underneath analyses, which is not allowed.} -\item{...}{additional arguments for the lower level functions.} - -\item{var_labels}{(\code{character})\cr variable labels.} - \item{show_labels}{(\code{string})\cr label visibility: one of "default", "visible" and "hidden".} \item{table_names}{(\code{character})\cr this can be customized in the case that the same \code{vars} are analyzed multiple times, to avoid warnings from \code{rtables}.} +\item{section_div}{(\code{string})\cr string which should be repeated as a section divider after each group +defined by this split instruction, or \code{NA_character_} (the default) for no section divider.} + +\item{...}{additional arguments for the lower level functions.} + +\item{na_rm}{(\code{flag})\cr whether \code{NA} values should be removed from \code{x} prior to analysis.} + +\item{variables}{(named \code{list} of \code{string})\cr list of additional analysis variables.} + +\item{method}{(\code{string})\cr one of \code{chisq}, \code{cmh}, \code{fisher}, or \code{schouten}; specifies the test used +to calculate the p-value.} + \item{.stats}{(\code{character})\cr statistics to select for the table. Options are: \code{'pval'}} +\item{.stat_names}{(\code{character})\cr names of the statistics that are passed directly to name single statistics +(\code{.stats}). This option is visible when producing \code{\link[rtables:data.frame_export]{rtables::as_result_df()}} with \code{make_ard = TRUE}.} + \item{.formats}{(named \code{character} or \code{list})\cr formats for the statistics. See Details in \code{analyze_vars} for more information on the \code{"auto"} setting.} From 15c0fd6a5dd481ecabb24ecc937007c34620fc71 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Fri, 28 Feb 2025 19:08:49 +0100 Subject: [PATCH 04/12] news --- NEWS.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS.md b/NEWS.md index cd93f5552b..ec355b3660 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,7 @@ * Refactored `count_abnormal()`, `count_abnormal_by_baseline()`, `count_abnormal_by_marked()`, `count_abnormal_by_worst_grade()`, `count_abnormal_lab_worsen_by_baseline()`, `coxph_pairwise()`, `estimate_multinomial_rsp()`, `estimate_proportion()`, `estimate_odds_ratio()`, `summarize_ancova()`, `summarize_glm_count()`, and `surv_timepoint()` to work without `make_afun()`. * Added `geom_sd` and `geom_mean_sd` to `s_summary()` default available statistics. * Refactored `count_abnormal()`, `count_abnormal_by_baseline()`, `count_abnormal_by_marked()`, `count_abnormal_by_worst_grade()`, `count_abnormal_lab_worsen_by_baseline()` to work without `make_afun()`. +* `as_factor_keep_attributes()` is now an exported function. ### Bug Fixes * Fixed bug in `a_count_patients_with_flags()` preventing select custom label and indentation specification formats from being applied. @@ -15,6 +16,7 @@ * Began deprecation of the unused `table_names` argument to `count_abnormal_lab_worsen_by_baseline()`. * Added warnings for `geom_mean` statistical output. * Began deprecation of the unused `h_split_param()` function. +* Reorganized the utility documentation related to factors (`utils_factor.R`) into a single file. # tern 0.9.7 From 35efe39bec31500dd8235fee9ea4839d896a203f Mon Sep 17 00:00:00 2001 From: Melkiades Date: Fri, 28 Feb 2025 19:48:47 +0100 Subject: [PATCH 05/12] fixes --- NAMESPACE | 1 + R/prop_diff.R | 7 +++---- R/prop_diff_test.R | 4 ---- R/utils_factor.R | 3 ++- man/factor_utils.Rd | 3 ++- 5 files changed, 8 insertions(+), 10 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index a2ea4dbd23..4b6ea88c32 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -45,6 +45,7 @@ export(analyze_vars_in_cols) export(append_varlabels) export(arrange_grobs) export(as.rtable) +export(as_factor_keep_attributes) export(combine_counts) export(combine_groups) export(combine_levels) diff --git a/R/prop_diff.R b/R/prop_diff.R index e5d045b707..1c854bf71c 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -131,8 +131,8 @@ s_proportion_diff <- function(df, "cmh" = prop_diff_cmh(rsp, grp, strata, conf_level)[c("diff", "diff_ci")] ) - y$diff <- y$diff * 100 - y$diff_ci <- y$diff_ci * 100 + y$diff <- setNames(y$diff * 100, paste0("diff_", method)) + y$diff_ci <- setNames(y$diff_ci * 100, paste0("diff_ci_", method, c("_l", "_u"))) } attr(y$diff, "label") <- "Difference in Response rate (%)" @@ -197,7 +197,7 @@ a_proportion_diff <- function(df, get_stats("estimate_proportion_diff", stats_in = .stats), names(custom_stat_functions) ) - + browser() x_stats <- x_stats[.stats] # Fill in formats/indents/labels with custom input and defaults @@ -219,7 +219,6 @@ a_proportion_diff <- function(df, # Get and check statistical names from defaults .stat_names <- get_stat_names(x_stats, .stat_names) # note is x_stats - .stat_names <- paste0(.stat_names, "_", dots_extra_args$method) in_rows( .list = x_stats, diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index ac97846dd6..f6d2d70971 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -161,7 +161,6 @@ a_test_proportion_diff <- function(df, # Get and check statistical names from defaults .stat_names <- get_stat_names(x_stats, .stat_names) # note is x_stats - .stat_names <- paste0(.stat_names, "_", dots_extra_args$method) in_rows( .list = x_stats, @@ -211,10 +210,8 @@ test_proportion_diff <- function(lyt, ..., na_rm = TRUE, variables = list(strata = NULL), - # conf_level = 0.95, method = c("chisq", "schouten", "fisher", "cmh"), .stats = c("pval"), - # .stats = c("diff", "diff_ci"), .stat_names = NULL, .formats = c(pval = "x.xxxx | (<0.0001)"), .labels = NULL, @@ -223,7 +220,6 @@ test_proportion_diff <- function(lyt, extra_args <- list( "na_rm" = na_rm, "variables" = variables, - # "conf_level" = conf_level, "method" = method, ... ) diff --git a/R/utils_factor.R b/R/utils_factor.R index 0e64704a24..23531e3181 100644 --- a/R/utils_factor.R +++ b/R/utils_factor.R @@ -50,7 +50,8 @@ combine_levels <- function(x, levels, new_level = paste(levels, collapse = "/")) #' @param verbose (`flag`)\cr defaults to `TRUE`. It prints out warnings and messages. #' #' @return -#' * `as_factor_keep_attributes`: A `factor` with same attributes (except class) as `x`. Does not modify `x` if already a `factor`. +#' * `as_factor_keep_attributes`: A `factor` with same attributes (except class) as `x`. +#' Does not modify `x` if already a `factor`. #' #' @examples #' a_chr_with_labels <- c("a", "b", NA) diff --git a/man/factor_utils.Rd b/man/factor_utils.Rd index ce6cf1a829..01dbb6582d 100644 --- a/man/factor_utils.Rd +++ b/man/factor_utils.Rd @@ -55,7 +55,8 @@ new factor. Note that this level must not be contained in the new levels specifi } \itemize{ -\item \code{as_factor_keep_attributes}: A \code{factor} with same attributes (except class) as \code{x}. Does not modify \code{x} if already a \code{factor}. +\item \code{as_factor_keep_attributes}: A \code{factor} with same attributes (except class) as \code{x}. +Does not modify \code{x} if already a \code{factor}. } \itemize{ From 8775e8194def7008ddb5a5b52f4bfd253017c26c Mon Sep 17 00:00:00 2001 From: Melkiades Date: Fri, 28 Feb 2025 19:50:43 +0100 Subject: [PATCH 06/12] fix snaps --- R/prop_diff.R | 2 +- tests/testthat/_snaps/prop_diff.md | 12 ++++++++---- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/R/prop_diff.R b/R/prop_diff.R index 1c854bf71c..ae652d2ea7 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -197,7 +197,7 @@ a_proportion_diff <- function(df, get_stats("estimate_proportion_diff", stats_in = .stats), names(custom_stat_functions) ) - browser() + x_stats <- x_stats[.stats] # Fill in formats/indents/labels with custom input and defaults diff --git a/tests/testthat/_snaps/prop_diff.md b/tests/testthat/_snaps/prop_diff.md index ce544f63b8..675f4ee530 100644 --- a/tests/testthat/_snaps/prop_diff.md +++ b/tests/testthat/_snaps/prop_diff.md @@ -224,12 +224,14 @@ res Output $diff - [1] 14.69622 + diff_ha + 14.69622 attr(,"label") [1] "Difference in Response rate (%)" $diff_ci - [1] -3.118966 32.511412 + diff_ci_ha_l diff_ci_ha_u + -3.118966 32.511412 attr(,"label") [1] "90% CI (Anderson-Hauck)" @@ -240,12 +242,14 @@ res Output $diff - [1] 13.76866 + diff_cmh + 13.76866 attr(,"label") [1] "Difference in Response rate (%)" $diff_ci - [1] -0.9989872 28.5363076 + diff_ci_cmh_l diff_ci_cmh_u + -0.9989872 28.5363076 attr(,"label") [1] "90% CI (CMH, without correction)" From 5c7130092761befd05ca582bf49997a3ebd9a749 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Mon, 3 Mar 2025 16:34:12 +0100 Subject: [PATCH 07/12] fix --- R/prop_diff.R | 2 +- man/prop_diff.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/prop_diff.R b/R/prop_diff.R index ae652d2ea7..3bc156bc57 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -266,7 +266,7 @@ estimate_proportion_diff <- function(lyt, var_labels = vars, na_str = default_na_str(), nested = TRUE, - show_labels = "default", + show_labels = "hidden", table_names = vars, section_div = NA_character_, ..., diff --git a/man/prop_diff.Rd b/man/prop_diff.Rd index 46f416893a..226f59e02b 100644 --- a/man/prop_diff.Rd +++ b/man/prop_diff.Rd @@ -13,7 +13,7 @@ estimate_proportion_diff( var_labels = vars, na_str = default_na_str(), nested = TRUE, - show_labels = "default", + show_labels = "hidden", table_names = vars, section_div = NA_character_, ..., From 41e827fc1e7aa089b343f5349d37332c7b7b00ba Mon Sep 17 00:00:00 2001 From: Melkiades Date: Tue, 4 Mar 2025 11:47:36 +0100 Subject: [PATCH 08/12] add --- NEWS.md | 1 + R/count_cumulative.R | 146 ++++++++++++++++---- R/count_missed_doses.R | 141 ++++++++++++++----- R/estimate_proportion.R | 2 + R/prop_diff.R | 10 +- R/prop_diff_test.R | 9 +- R/utils_default_stats_formats_labels.R | 4 +- man/count_cumulative.Rd | 57 ++++---- man/count_missed_doses.Rd | 37 ++--- man/h_count_cumulative.Rd | 22 +-- tests/testthat/_snaps/count_missed_doses.md | 18 --- tests/testthat/test-count_cumulative.R | 9 +- tests/testthat/test-count_missed_doses.R | 19 --- 13 files changed, 310 insertions(+), 165 deletions(-) diff --git a/NEWS.md b/NEWS.md index 16e1ec2d21..555b528a8b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -20,6 +20,7 @@ * Began deprecation of the no longer used helper functions `h_tab_one_biomarker()`, `h_tab_rsp_one_biomarker()`, and `h_tab_surv_one_biomarker()`. * Moved helper functions `h_tab_rsp_one_biomarker()` and `h_tab_surv_one_biomarker()` into `h_biomarkers_subgroups.R`. * Reorganized the utility documentation related to factors (`utils_factor.R`) into a single file. +* Removed `s_count_nonmissing()` as it is a non-repeated small and internal function. # tern 0.9.7 diff --git a/R/count_cumulative.R b/R/count_cumulative.R index 52c3733116..133411ecff 100644 --- a/R/count_cumulative.R +++ b/R/count_cumulative.R @@ -48,26 +48,26 @@ NULL #' x <- c(sample(1:10, 10), NA) #' .N_col <- length(x) #' -#' h_count_cumulative(x, 5, .N_col = .N_col) -#' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na.rm = FALSE, .N_col = .N_col) -#' h_count_cumulative(x, 0, lower_tail = FALSE, .N_col = .N_col) -#' h_count_cumulative(x, 100, lower_tail = FALSE, .N_col = .N_col) +#' h_count_cumulative(x, 5, denom = .N_col) +#' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na_rm = FALSE, denom = .N_col) +#' h_count_cumulative(x, 0, lower_tail = FALSE, denom = .N_col) +#' h_count_cumulative(x, 100, lower_tail = FALSE, denom = .N_col) #' #' @export h_count_cumulative <- function(x, threshold, lower_tail = TRUE, include_eq = TRUE, - na.rm = TRUE, # nolint - .N_col) { # nolint + na_rm = TRUE, + denom) { checkmate::assert_numeric(x) checkmate::assert_numeric(threshold) - checkmate::assert_numeric(.N_col) + checkmate::assert_numeric(denom) checkmate::assert_flag(lower_tail) checkmate::assert_flag(include_eq) - checkmate::assert_flag(na.rm) + checkmate::assert_flag(na_rm) - is_keep <- if (na.rm) !is.na(x) else rep(TRUE, length(x)) + is_keep <- if (na_rm) !is.na(x) else rep(TRUE, length(x)) count <- if (lower_tail && include_eq) { length(x[is_keep & x <= threshold]) } else if (lower_tail && !include_eq) { @@ -80,7 +80,7 @@ h_count_cumulative <- function(x, result <- c( count = count, - fraction = if (count == 0 && .N_col == 0) 0 else count / .N_col + fraction = if (count == 0 && denom == 0) 0 else count / denom ) result } @@ -114,9 +114,10 @@ s_count_cumulative <- function(x, thresholds, lower_tail = TRUE, include_eq = TRUE, - .N_col, # nolint - .N_row, # nolint denom = c("N_col", "n", "N_row"), + .N_col, + .N_row, + na_rm = TRUE, ...) { checkmate::assert_numeric(thresholds, min.len = 1, any.missing = FALSE) @@ -128,7 +129,7 @@ s_count_cumulative <- function(x, ) count_fraction_list <- Map(function(thres) { - result <- h_count_cumulative(x, thres, lower_tail, include_eq, .N_col = denom, ...) + result <- h_count_cumulative(x, thres, lower_tail, include_eq, na_rm = na_rm, denom = denom) label <- d_count_cumulative(thres, lower_tail, include_eq) formatters::with_label(result, label) }, thresholds) @@ -144,10 +145,80 @@ s_count_cumulative <- function(x, #' * `a_count_cumulative()` returns the corresponding list with formatted [rtables::CellValue()]. #' #' @keywords internal -a_count_cumulative <- make_afun( - s_count_cumulative, - .formats = c(count_fraction = format_count_fraction) -) +a_count_cumulative <- function(x, + ..., + .stats = NULL, + .stat_names = NULL, + .formats = NULL, + .labels = NULL, + .indent_mods = NULL) { + dots_extra_args <- list(...) + + # Check if there are user-defined functions + default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) + .stats <- default_and_custom_stats_list$all_stats + custom_stat_functions <- default_and_custom_stats_list$custom_stats + + # Adding automatically extra parameters to the statistic function (see ?rtables::additional_fun_params) + extra_afun_params <- retrieve_extra_afun_params( + names(dots_extra_args$.additional_fun_parameters) + ) + dots_extra_args$.additional_fun_parameters <- NULL # After extraction we do not need them anymore + + # Main statistical functions application + x_stats <- .apply_stat_functions( + default_stat_fnc = s_count_cumulative, + custom_stat_fnc_list = custom_stat_functions, + args_list = c( + x = list(x), + extra_afun_params, + dots_extra_args + ) + ) + + # Fill in with stats defaults if needed + .stats <- get_stats("count_cumulative", + stats_in = .stats, + custom_stats_in = names(custom_stat_functions) + ) + + x_stats <- x_stats[.stats] + levels_per_stats <- lapply(x_stats, names) + + # Fill in formats/indents/labels with custom input and defaults + .formats <- get_formats_from_stats(.stats, .formats, levels_per_stats) + .indent_mods <- get_indents_from_stats(.stats, .indent_mods, levels_per_stats) + if (is.null(.labels)) { + .labels <- sapply(.unlist_keep_nulls(x_stats), attr, "label") + .labels <- .labels[nzchar(.labels) & !sapply(.labels, is.null) & !is.na(.labels)] + } + .labels <- get_labels_from_stats(.stats, .labels, levels_per_stats) + + # Unlist stats + x_stats <- x_stats %>% + .unlist_keep_nulls() %>% + setNames(names(.formats)) + + # Auto format handling + .formats <- apply_auto_formatting( + .formats, + x_stats, + extra_afun_params$.df_row, + extra_afun_params$.var + ) + + # Get and check statistical names from defaults + .stat_names <- get_stat_names(x_stats, .stat_names) # note is x_stats + + in_rows( + .list = x_stats, + .formats = .formats, + .names = names(.labels), + .stat_names = .stat_names, + .labels = .labels %>% .unlist_keep_nulls(), + .indent_mods = .indent_mods %>% .unlist_keep_nulls() + ) +} #' @describeIn count_cumulative Layout-creating function which can take statistics function arguments #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. @@ -172,33 +243,50 @@ a_count_cumulative <- make_afun( count_cumulative <- function(lyt, vars, thresholds, - lower_tail = TRUE, - include_eq = TRUE, var_labels = vars, show_labels = "visible", na_str = default_na_str(), nested = TRUE, - ..., table_names = vars, + ..., + na_rm = TRUE, + lower_tail = TRUE, + include_eq = TRUE, .stats = NULL, + .stat_names = NULL, .formats = NULL, .labels = NULL, .indent_mods = NULL) { - extra_args <- list(thresholds = thresholds, lower_tail = lower_tail, include_eq = include_eq, ...) + # Depending on main functions + extra_args <- list( + "na_rm" = na_rm, + "thresholds" = thresholds, + "lower_tail" = lower_tail, + "include_eq" = include_eq, + ... + ) - afun <- make_afun( - a_count_cumulative, - .stats = .stats, - .formats = .formats, - .labels = .labels, - .indent_mods = .indent_mods, - .ungroup_stats = "count_fraction" + # Needed defaults + if (!is.null(.stats)) extra_args[[".stats"]] <- .stats + if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names + if (!is.null(.formats)) extra_args[[".formats"]] <- .formats + if (!is.null(.labels)) extra_args[[".labels"]] <- .labels + if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods + + # Adding all additional information from layout to analysis functions (see ?rtables::additional_fun_params) + extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) + formals(a_count_cumulative) <- c( + formals(a_count_cumulative), + extra_args[[".additional_fun_parameters"]] ) + + # Main {rtables} structural call analyze( lyt, vars, - afun = afun, + afun = a_count_cumulative, na_str = na_str, + inclNAs = !na_rm, table_names = table_names, var_labels = var_labels, show_labels = show_labels, diff --git a/R/count_missed_doses.R b/R/count_missed_doses.R index 2c98950ebf..3bcdacf68d 100644 --- a/R/count_missed_doses.R +++ b/R/count_missed_doses.R @@ -25,16 +25,6 @@ #' @order 1 NULL -#' @describeIn count_missed_doses Statistics function to count non-missing values. -#' -#' @return -#' * `s_count_nonmissing()` returns the statistic `n` which is the count of non-missing values in `x`. -#' -#' @keywords internal -s_count_nonmissing <- function(x) { - list(n = n_available(x)) -} - #' Description function that calculates labels for `s_count_missed_doses()` #' #' @description `r lifecycle::badge("stable")` @@ -60,7 +50,8 @@ s_count_missed_doses <- function(x, thresholds, .N_col, # nolint .N_row, # nolint - denom = c("N_col", "n", "N_row")) { + denom = c("N_col", "n", "N_row"), + ...) { stat <- s_count_cumulative( x = x, thresholds = thresholds, @@ -68,14 +59,15 @@ s_count_missed_doses <- function(x, include_eq = TRUE, .N_col = .N_col, .N_row = .N_row, - denom = denom + denom = denom, + ... ) labels <- d_count_missed_doses(thresholds) for (i in seq_along(stat$count_fraction)) { stat$count_fraction[[i]] <- formatters::with_label(stat$count_fraction[[i]], label = labels[i]) } - n_stat <- s_count_nonmissing(x) - c(n_stat, stat) + + c(list(n = n_available(x)), stat) } #' @describeIn count_missed_doses Formatted analysis function which is used as `afun` @@ -85,10 +77,80 @@ s_count_missed_doses <- function(x, #' * `a_count_missed_doses()` returns the corresponding list with formatted [rtables::CellValue()]. #' #' @keywords internal -a_count_missed_doses <- make_afun( - s_count_missed_doses, - .formats = c(n = "xx", count_fraction = format_count_fraction) -) +a_count_missed_doses <- function(x, + ..., + .stats = NULL, + .stat_names = NULL, + .formats = NULL, + .labels = NULL, + .indent_mods = NULL) { + dots_extra_args <- list(...) + + # Check if there are user-defined functions + default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) + .stats <- default_and_custom_stats_list$all_stats + custom_stat_functions <- default_and_custom_stats_list$custom_stats + + # Adding automatically extra parameters to the statistic function (see ?rtables::additional_fun_params) + extra_afun_params <- retrieve_extra_afun_params( + names(dots_extra_args$.additional_fun_parameters) + ) + dots_extra_args$.additional_fun_parameters <- NULL # After extraction we do not need them anymore + + # Main statistical functions application + x_stats <- .apply_stat_functions( + default_stat_fnc = s_count_missed_doses, + custom_stat_fnc_list = custom_stat_functions, + args_list = c( + x = list(x), + extra_afun_params, + dots_extra_args + ) + ) + + # Fill in with stats defaults if needed + .stats <- get_stats("count_missed_doses", + stats_in = .stats, + custom_stats_in = names(custom_stat_functions) + ) + + x_stats <- x_stats[.stats] + levels_per_stats <- lapply(x_stats, names) + + # Fill in formats/indents/labels with custom input and defaults + .formats <- get_formats_from_stats(.stats, .formats, levels_per_stats) + .indent_mods <- get_indents_from_stats(.stats, .indent_mods, levels_per_stats) + if (is.null(.labels)) { + .labels <- sapply(.unlist_keep_nulls(x_stats), attr, "label") + .labels <- .labels[nzchar(.labels) & !sapply(.labels, is.null) & !is.na(.labels)] + } + .labels <- get_labels_from_stats(.stats, .labels, levels_per_stats) + + # Unlist stats + x_stats <- x_stats %>% + .unlist_keep_nulls() %>% + setNames(names(.formats)) + + # Auto format handling + .formats <- apply_auto_formatting( + .formats, + x_stats, + extra_afun_params$.df_row, + extra_afun_params$.var + ) + + # Get and check statistical names from defaults + .stat_names <- get_stat_names(x_stats, .stat_names) # note is x_stats + + in_rows( + .list = x_stats, + .formats = .formats, + .names = names(.labels), + .stat_names = .stat_names, + .labels = .labels %>% .unlist_keep_nulls(), + .indent_mods = .indent_mods %>% .unlist_keep_nulls() + ) +} #' @describeIn count_missed_doses Layout-creating function which can take statistics function arguments #' and additional format arguments. This function is a wrapper for [rtables::analyze()]. @@ -125,30 +187,45 @@ count_missed_doses <- function(lyt, show_labels = "visible", na_str = default_na_str(), nested = TRUE, - ..., table_names = vars, + ..., + na_rm = TRUE, .stats = NULL, + .stat_names = NULL, .formats = NULL, .labels = NULL, .indent_mods = NULL) { - extra_args <- list(thresholds = thresholds, ...) + # Depending on main functions + extra_args <- list( + "na_rm" = na_rm, + "thresholds" = thresholds, + ... + ) - afun <- make_afun( - a_count_missed_doses, - .stats = .stats, - .formats = .formats, - .labels = .labels, - .indent_mods = .indent_mods, - .ungroup_stats = "count_fraction" + # Needed defaults + if (!is.null(.stats)) extra_args[[".stats"]] <- .stats + if (!is.null(.stat_names)) extra_args[[".stat_names"]] <- .stat_names + if (!is.null(.formats)) extra_args[[".formats"]] <- .formats + if (!is.null(.labels)) extra_args[[".labels"]] <- .labels + if (!is.null(.indent_mods)) extra_args[[".indent_mods"]] <- .indent_mods + + # Adding all additional information from layout to analysis functions (see ?rtables::additional_fun_params) + extra_args[[".additional_fun_parameters"]] <- get_additional_afun_params(add_alt_df = FALSE) + formals(a_count_missed_doses) <- c( + formals(a_count_missed_doses), + extra_args[[".additional_fun_parameters"]] ) + + # Main {rtables} structural call analyze( - lyt = lyt, - vars = vars, - afun = afun, - var_labels = var_labels, + lyt, + vars, + afun = a_count_missed_doses, + na_str = na_str, + inclNAs = !na_rm, table_names = table_names, + var_labels = var_labels, show_labels = show_labels, - na_str = na_str, nested = nested, extra_args = extra_args ) diff --git a/R/estimate_proportion.R b/R/estimate_proportion.R index 33f5289b04..dd9bffe221 100644 --- a/R/estimate_proportion.R +++ b/R/estimate_proportion.R @@ -94,6 +94,8 @@ s_proportion <- function(df, } else if (checkmate::test_subset(method, c("strat_wilson", "strat_wilsonc"))) { stop("To use stratified methods you need to specify the strata variables.") } + + # Finding the Responders if (checkmate::test_atomic_vector(df)) { rsp <- as.logical(df) } else { diff --git a/R/prop_diff.R b/R/prop_diff.R index 3bc156bc57..7fc65987d1 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -172,7 +172,7 @@ a_proportion_diff <- function(df, # Check if there are user-defined functions default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) - .stats <- default_and_custom_stats_list$default_stats + .stats <- default_and_custom_stats_list$all_stats custom_stat_functions <- default_and_custom_stats_list$custom_stats # Adding automatically extra parameters to the statistic function (see ?rtables::additional_fun_params) @@ -193,9 +193,9 @@ a_proportion_diff <- function(df, ) # Fill in with stats defaults if needed - .stats <- c( - get_stats("estimate_proportion_diff", stats_in = .stats), - names(custom_stat_functions) + .stats <- get_stats("estimate_proportion_diff", + stats_in = .stats, + custom_stats_in = names(custom_stat_functions) ) x_stats <- x_stats[.stats] @@ -205,7 +205,7 @@ a_proportion_diff <- function(df, .indent_mods <- get_indents_from_stats(.stats, .indent_mods) if (is.null(.labels)) { .labels <- sapply(x_stats, attr, "label") - .labels <- .labels[nzchar(.labels)] + .labels <- .labels[nzchar(.labels) & !sapply(.labels, is.null) & !is.na(.labels)] } .labels <- get_labels_from_stats(.stats, .labels) diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index f6d2d70971..44cd907a20 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -115,7 +115,7 @@ a_test_proportion_diff <- function(df, # Check if there are user-defined functions default_and_custom_stats_list <- .split_std_from_custom_stats(.stats) - .stats <- default_and_custom_stats_list$default_stats + .stats <- default_and_custom_stats_list$all_stats custom_stat_functions <- default_and_custom_stats_list$custom_stats # Adding automatically extra parameters to the statistic function (see ?rtables::additional_fun_params) @@ -136,9 +136,9 @@ a_test_proportion_diff <- function(df, ) # Fill in with stats defaults if needed - .stats <- c( - get_stats("test_proportion_diff", stats_in = .stats), - names(custom_stat_functions) + .stats <- get_stats("test_proportion_diff", + stats_in = .stats, + custom_stats_in = names(custom_stat_functions) ) x_stats <- x_stats[.stats] @@ -148,6 +148,7 @@ a_test_proportion_diff <- function(df, .indent_mods <- get_indents_from_stats(.stats, .indent_mods) if (is.null(.labels)) { .labels <- sapply(x_stats, attr, "label") + .labels <- .labels[nzchar(.labels) & !sapply(.labels, is.null) & !is.na(.labels)] } .labels <- get_labels_from_stats(.stats, .labels) diff --git a/R/utils_default_stats_formats_labels.R b/R/utils_default_stats_formats_labels.R index 667d163668..661d0b63d8 100644 --- a/R/utils_default_stats_formats_labels.R +++ b/R/utils_default_stats_formats_labels.R @@ -513,8 +513,8 @@ tern_default_stats <- list( "median_ci_3d", "mean_ci_3d", "geom_mean_ci_3d" ), - count_cumulative = c("count_fraction", "count_fraction_fixed_dp"), - count_missed_doses = c("n", "count_fraction", "count_fraction_fixed_dp"), + count_cumulative = c("count_fraction"), + count_missed_doses = c("n", "count_fraction"), count_occurrences = c("count", "count_fraction", "count_fraction_fixed_dp", "fraction"), count_occurrences_by_grade = c("count_fraction", "count_fraction_fixed_dp"), count_patients_with_event = c("n", "count", "count_fraction", "count_fraction_fixed_dp", "n_blq"), diff --git a/man/count_cumulative.Rd b/man/count_cumulative.Rd index 86d3cfb773..cdf595d2ef 100644 --- a/man/count_cumulative.Rd +++ b/man/count_cumulative.Rd @@ -10,15 +10,17 @@ count_cumulative( lyt, vars, thresholds, - lower_tail = TRUE, - include_eq = TRUE, var_labels = vars, show_labels = "visible", na_str = default_na_str(), nested = TRUE, - ..., table_names = vars, + ..., + na_rm = TRUE, + lower_tail = TRUE, + include_eq = TRUE, .stats = NULL, + .stat_names = NULL, .formats = NULL, .labels = NULL, .indent_mods = NULL @@ -29,21 +31,21 @@ s_count_cumulative( thresholds, lower_tail = TRUE, include_eq = TRUE, + denom = c("N_col", "n", "N_row"), .N_col, .N_row, - denom = c("N_col", "n", "N_row"), + na_rm = TRUE, ... ) a_count_cumulative( x, - thresholds, - lower_tail = TRUE, - include_eq = TRUE, - .N_col, - .N_row, - denom = c("N_col", "n", "N_row"), - ... + ..., + .stats = NULL, + .stat_names = NULL, + .formats = NULL, + .labels = NULL, + .indent_mods = NULL ) } \arguments{ @@ -53,11 +55,6 @@ a_count_cumulative( \item{thresholds}{(\code{numeric})\cr vector of cutoff values for the counts.} -\item{lower_tail}{(\code{flag})\cr whether to count lower tail, default is \code{TRUE}.} - -\item{include_eq}{(\code{flag})\cr whether to include value equal to the \code{threshold} in -count, default is \code{TRUE}.} - \item{var_labels}{(\code{character})\cr variable labels.} \item{show_labels}{(\code{string})\cr label visibility: one of "default", "visible" and "hidden".} @@ -68,14 +65,24 @@ count, default is \code{TRUE}.} possible (\code{TRUE}, the default) or as a new top-level element (\code{FALSE}). Ignored if it would nest a split. underneath analyses, which is not allowed.} -\item{...}{additional arguments for the lower level functions.} - \item{table_names}{(\code{character})\cr this can be customized in the case that the same \code{vars} are analyzed multiple times, to avoid warnings from \code{rtables}.} +\item{...}{additional arguments for the lower level functions.} + +\item{na_rm}{(\code{flag})\cr whether \code{NA} values should be removed from \code{x} prior to analysis.} + +\item{lower_tail}{(\code{flag})\cr whether to count lower tail, default is \code{TRUE}.} + +\item{include_eq}{(\code{flag})\cr whether to include value equal to the \code{threshold} in +count, default is \code{TRUE}.} + \item{.stats}{(\code{character})\cr statistics to select for the table. -Options are: \verb{'count_fraction', 'count_fraction_fixed_dp'}} +Options are: \code{'count_fraction'}} + +\item{.stat_names}{(\code{character})\cr names of the statistics that are passed directly to name single statistics +(\code{.stats}). This option is visible when producing \code{\link[rtables:data.frame_export]{rtables::as_result_df()}} with \code{make_ard = TRUE}.} \item{.formats}{(named \code{character} or \code{list})\cr formats for the statistics. See Details in \code{analyze_vars} for more information on the \code{"auto"} setting.} @@ -87,18 +94,18 @@ unmodified default behavior. Can be negative.} \item{x}{(\code{numeric})\cr vector of numbers we want to analyze.} -\item{.N_col}{(\code{integer(1)})\cr column-wise N (column count) for the full column being analyzed that is typically -passed by \code{rtables}.} - -\item{.N_row}{(\code{integer(1)})\cr row-wise N (row group count) for the group of observations being analyzed -(i.e. with no column-based subsetting) that is typically passed by \code{rtables}.} - \item{denom}{(\code{string})\cr choice of denominator for proportion. Options are: \itemize{ \item \code{n}: number of values in this row and column intersection. \item \code{N_row}: total number of values in this row across columns. \item \code{N_col}: total number of values in this column across rows. }} + +\item{.N_col}{(\code{integer(1)})\cr column-wise N (column count) for the full column being analyzed that is typically +passed by \code{rtables}.} + +\item{.N_row}{(\code{integer(1)})\cr row-wise N (row group count) for the group of observations being analyzed +(i.e. with no column-based subsetting) that is typically passed by \code{rtables}.} } \value{ \itemize{ diff --git a/man/count_missed_doses.Rd b/man/count_missed_doses.Rd index 262c573a49..f32792e69f 100644 --- a/man/count_missed_doses.Rd +++ b/man/count_missed_doses.Rd @@ -2,7 +2,6 @@ % Please edit documentation in R/count_missed_doses.R \name{count_missed_doses} \alias{count_missed_doses} -\alias{s_count_nonmissing} \alias{s_count_missed_doses} \alias{a_count_missed_doses} \title{Count number of patients with missed doses by thresholds} @@ -15,30 +14,33 @@ count_missed_doses( show_labels = "visible", na_str = default_na_str(), nested = TRUE, - ..., table_names = vars, + ..., + na_rm = TRUE, .stats = NULL, + .stat_names = NULL, .formats = NULL, .labels = NULL, .indent_mods = NULL ) -s_count_nonmissing(x) - s_count_missed_doses( x, thresholds, .N_col, .N_row, - denom = c("N_col", "n", "N_row") + denom = c("N_col", "n", "N_row"), + ... ) a_count_missed_doses( x, - thresholds, - .N_col, - .N_row, - denom = c("N_col", "n", "N_row") + ..., + .stats = NULL, + .stat_names = NULL, + .formats = NULL, + .labels = NULL, + .indent_mods = NULL ) } \arguments{ @@ -58,14 +60,19 @@ a_count_missed_doses( possible (\code{TRUE}, the default) or as a new top-level element (\code{FALSE}). Ignored if it would nest a split. underneath analyses, which is not allowed.} -\item{...}{additional arguments for the lower level functions.} - \item{table_names}{(\code{character})\cr this can be customized in the case that the same \code{vars} are analyzed multiple times, to avoid warnings from \code{rtables}.} +\item{...}{additional arguments for the lower level functions.} + +\item{na_rm}{(\code{flag})\cr whether \code{NA} values should be removed from \code{x} prior to analysis.} + \item{.stats}{(\code{character})\cr statistics to select for the table. -Options are: \verb{'n', 'count_fraction', 'count_fraction_fixed_dp'}} +Options are: \verb{'n', 'count_fraction'}} + +\item{.stat_names}{(\code{character})\cr names of the statistics that are passed directly to name single statistics +(\code{.stats}). This option is visible when producing \code{\link[rtables:data.frame_export]{rtables::as_result_df()}} with \code{make_ard = TRUE}.} \item{.formats}{(named \code{character} or \code{list})\cr formats for the statistics. See Details in \code{analyze_vars} for more information on the \code{"auto"} setting.} @@ -97,10 +104,6 @@ or to \code{\link[rtables:build_table]{rtables::build_table()}}. Adding this fun the statistics from \code{s_count_missed_doses()} to the table layout. } -\itemize{ -\item \code{s_count_nonmissing()} returns the statistic \code{n} which is the count of non-missing values in \code{x}. -} - \itemize{ \item \code{s_count_missed_doses()} returns the statistics \code{n} and \code{count_fraction} with one element for each threshold. } @@ -124,8 +127,6 @@ assumes that every row of the given data frame corresponds to a unique patient. \item \code{count_missed_doses()}: Layout-creating function which can take statistics function arguments and additional format arguments. This function is a wrapper for \code{\link[rtables:analyze]{rtables::analyze()}}. -\item \code{s_count_nonmissing()}: Statistics function to count non-missing values. - \item \code{s_count_missed_doses()}: Statistics function to count patients with missed doses. \item \code{a_count_missed_doses()}: Formatted analysis function which is used as \code{afun} diff --git a/man/h_count_cumulative.Rd b/man/h_count_cumulative.Rd index b4440eca55..89829b119c 100644 --- a/man/h_count_cumulative.Rd +++ b/man/h_count_cumulative.Rd @@ -9,8 +9,8 @@ h_count_cumulative( threshold, lower_tail = TRUE, include_eq = TRUE, - na.rm = TRUE, - .N_col + na_rm = TRUE, + denom ) } \arguments{ @@ -23,10 +23,14 @@ h_count_cumulative( \item{include_eq}{(\code{flag})\cr whether to include value equal to the \code{threshold} in count, default is \code{TRUE}.} -\item{na.rm}{(\code{flag})\cr whether \code{NA} values should be removed from \code{x} prior to analysis.} +\item{na_rm}{(\code{flag})\cr whether \code{NA} values should be removed from \code{x} prior to analysis.} -\item{.N_col}{(\code{integer(1)})\cr column-wise N (column count) for the full column being analyzed that is typically -passed by \code{rtables}.} +\item{denom}{(\code{string})\cr choice of denominator for proportion. Options are: +\itemize{ +\item \code{n}: number of values in this row and column intersection. +\item \code{N_row}: total number of values in this row across columns. +\item \code{N_col}: total number of values in this column across rows. +}} } \value{ A named vector with items: @@ -46,10 +50,10 @@ set.seed(1, kind = "Mersenne-Twister") x <- c(sample(1:10, 10), NA) .N_col <- length(x) -h_count_cumulative(x, 5, .N_col = .N_col) -h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na.rm = FALSE, .N_col = .N_col) -h_count_cumulative(x, 0, lower_tail = FALSE, .N_col = .N_col) -h_count_cumulative(x, 100, lower_tail = FALSE, .N_col = .N_col) +h_count_cumulative(x, 5, denom = .N_col) +h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na_rm = FALSE, denom = .N_col) +h_count_cumulative(x, 0, lower_tail = FALSE, denom = .N_col) +h_count_cumulative(x, 100, lower_tail = FALSE, denom = .N_col) } \seealso{ diff --git a/tests/testthat/_snaps/count_missed_doses.md b/tests/testthat/_snaps/count_missed_doses.md index 34981b9674..13a241e4f4 100644 --- a/tests/testthat/_snaps/count_missed_doses.md +++ b/tests/testthat/_snaps/count_missed_doses.md @@ -1,21 +1,3 @@ -# s_count_nonmissing works with numeric input - - Code - res - Output - $n - [1] 10 - - -# s_count_nonmissing also works with character input - - Code - res - Output - $n - [1] 4 - - # d_count_missed_doses works as expected Code diff --git a/tests/testthat/test-count_cumulative.R b/tests/testthat/test-count_cumulative.R index 49c20ebbdd..9dbbe046fa 100644 --- a/tests/testthat/test-count_cumulative.R +++ b/tests/testthat/test-count_cumulative.R @@ -5,7 +5,7 @@ testthat::test_that("h_count_cumulative works with healthy input and default arg result <- h_count_cumulative( x = x, threshold = 5, - .N_col = length(x) + denom = length(x) ) res <- testthat::expect_silent(result) @@ -22,8 +22,8 @@ testthat::test_that("h_count_cumulative works with customized arguments", { threshold = 5, lower_tail = FALSE, include_eq = FALSE, - na.rm = FALSE, - .N_col = length(x) + na_rm = FALSE, + denom = length(x) ) res <- testthat::expect_silent(result) @@ -54,7 +54,8 @@ testthat::test_that("s_count_cumulative works with customized arguments", { thresholds = c(4, 7), lower_tail = FALSE, include_eq = FALSE, - na.rm = FALSE, + na_rm = FALSE, + denom = "N_col", .N_col = length(x) ) diff --git a/tests/testthat/test-count_missed_doses.R b/tests/testthat/test-count_missed_doses.R index ea46ec1eb2..c0d9125366 100644 --- a/tests/testthat/test-count_missed_doses.R +++ b/tests/testthat/test-count_missed_doses.R @@ -1,22 +1,3 @@ -testthat::test_that("s_count_nonmissing works with numeric input", { - set.seed(1) - x <- c(sample(1:10, 10), NA) - - result <- s_count_nonmissing(x = x) - - res <- testthat::expect_silent(result) - testthat::expect_snapshot(res) -}) - -testthat::test_that("s_count_nonmissing also works with character input", { - x <- c("a", "b", NA, "c", "d") - - result <- s_count_nonmissing(x = x) - - res <- testthat::expect_silent(result) - testthat::expect_snapshot(res) -}) - testthat::test_that("d_count_missed_doses works as expected", { result <- d_count_missed_doses(c(1, 5)) From f8c7434f858ea08c9fc8038a7b1407c504e49ad6 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Tue, 4 Mar 2025 11:57:02 +0100 Subject: [PATCH 09/12] fix lint --- R/count_cumulative.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/count_cumulative.R b/R/count_cumulative.R index 133411ecff..efd22be18c 100644 --- a/R/count_cumulative.R +++ b/R/count_cumulative.R @@ -115,8 +115,8 @@ s_count_cumulative <- function(x, lower_tail = TRUE, include_eq = TRUE, denom = c("N_col", "n", "N_row"), - .N_col, - .N_row, + .N_col, # nolint + .N_row, # nolint na_rm = TRUE, ...) { checkmate::assert_numeric(thresholds, min.len = 1, any.missing = FALSE) From 441d0f4d2f828636ab8c74dc2ae8b1c0462751a6 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Tue, 4 Mar 2025 12:01:41 +0100 Subject: [PATCH 10/12] fix --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index 555b528a8b..6514b385ba 100644 --- a/NEWS.md +++ b/NEWS.md @@ -5,6 +5,7 @@ * Added `geom_sd` and `geom_mean_sd` to `s_summary()` default available statistics. * Refactored `h_tab_one_biomarker()`, `tabulate_rsp_subgroups()`, `tabulate_survival_subgroups()`, `tabulate_rsp_biomarkers()`, and `tabulate_survival_biomarkers()` to align with new analysis function style. * `as_factor_keep_attributes()` is now an exported function. +* Refactored `count_cumulative()`, `count_missed_doses()`, `estimate_proportion_diff()`, and `test_proportion_diff()` to work without `make_afun()`. ### Bug Fixes * Fixed bug in `a_count_patients_with_flags()` preventing select custom label and indentation specification formats from being applied. From 17f435b9554fe1384087319e1071f20fdb53abe7 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Wed, 5 Mar 2025 10:06:01 +0100 Subject: [PATCH 11/12] changes after review --- R/count_cumulative.R | 6 +++--- R/count_missed_doses.R | 2 +- R/prop_diff.R | 18 +++++++++--------- R/prop_diff_test.R | 6 +++--- man/count_cumulative.Rd | 16 ++++++++-------- man/count_missed_doses.Rd | 2 +- man/prop_diff.Rd | 28 ++++++++++++++-------------- man/prop_diff_test.Rd | 14 +++++++------- 8 files changed, 46 insertions(+), 46 deletions(-) diff --git a/R/count_cumulative.R b/R/count_cumulative.R index efd22be18c..e1ba1ea677 100644 --- a/R/count_cumulative.R +++ b/R/count_cumulative.R @@ -243,6 +243,8 @@ a_count_cumulative <- function(x, count_cumulative <- function(lyt, vars, thresholds, + lower_tail = TRUE, + include_eq = TRUE, var_labels = vars, show_labels = "visible", na_str = default_na_str(), @@ -250,9 +252,7 @@ count_cumulative <- function(lyt, table_names = vars, ..., na_rm = TRUE, - lower_tail = TRUE, - include_eq = TRUE, - .stats = NULL, + .stats = c("count_fraction"), .stat_names = NULL, .formats = NULL, .labels = NULL, diff --git a/R/count_missed_doses.R b/R/count_missed_doses.R index 3bcdacf68d..9bee040c82 100644 --- a/R/count_missed_doses.R +++ b/R/count_missed_doses.R @@ -190,7 +190,7 @@ count_missed_doses <- function(lyt, table_names = vars, ..., na_rm = TRUE, - .stats = NULL, + .stats = c("n", "count_fraction"), .stat_names = NULL, .formats = NULL, .labels = NULL, diff --git a/R/prop_diff.R b/R/prop_diff.R index 7fc65987d1..01825471fa 100644 --- a/R/prop_diff.R +++ b/R/prop_diff.R @@ -73,7 +73,7 @@ s_proportion_diff <- function(df, "permitted. Please choose a different method." )) } - y <- list(diff = character(), diff_ci = character()) + y <- list(diff = numeric(), diff_ci = numeric()) if (!.in_ref_col) { rsp <- c(.ref_group[[.var]], df[[.var]]) @@ -263,14 +263,6 @@ a_proportion_diff <- function(df, #' @order 2 estimate_proportion_diff <- function(lyt, vars, - var_labels = vars, - na_str = default_na_str(), - nested = TRUE, - show_labels = "hidden", - table_names = vars, - section_div = NA_character_, - ..., - na_rm = TRUE, variables = list(strata = NULL), conf_level = 0.95, method = c( @@ -279,6 +271,14 @@ estimate_proportion_diff <- function(lyt, "strat_newcombe", "strat_newcombecc" ), weights_method = "cmh", + var_labels = vars, + na_str = default_na_str(), + nested = TRUE, + show_labels = "hidden", + table_names = vars, + section_div = NA_character_, + ..., + na_rm = TRUE, .stats = c("diff", "diff_ci"), .stat_names = NULL, .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"), diff --git a/R/prop_diff_test.R b/R/prop_diff_test.R index 44cd907a20..6c25de55c3 100644 --- a/R/prop_diff_test.R +++ b/R/prop_diff_test.R @@ -35,7 +35,7 @@ s_test_proportion_diff <- function(df, method = c("chisq", "schouten", "fisher", "cmh"), ...) { method <- match.arg(method) - y <- list(pval = character()) + y <- list(pval = numeric()) if (!.in_ref_col) { assert_df_with_variables(df, list(rsp = .var)) @@ -202,6 +202,8 @@ a_test_proportion_diff <- function(df, #' @order 2 test_proportion_diff <- function(lyt, vars, + variables = list(strata = NULL), + method = c("chisq", "schouten", "fisher", "cmh"), var_labels = vars, na_str = default_na_str(), nested = TRUE, @@ -210,8 +212,6 @@ test_proportion_diff <- function(lyt, section_div = NA_character_, ..., na_rm = TRUE, - variables = list(strata = NULL), - method = c("chisq", "schouten", "fisher", "cmh"), .stats = c("pval"), .stat_names = NULL, .formats = c(pval = "x.xxxx | (<0.0001)"), diff --git a/man/count_cumulative.Rd b/man/count_cumulative.Rd index cdf595d2ef..370a988d94 100644 --- a/man/count_cumulative.Rd +++ b/man/count_cumulative.Rd @@ -10,6 +10,8 @@ count_cumulative( lyt, vars, thresholds, + lower_tail = TRUE, + include_eq = TRUE, var_labels = vars, show_labels = "visible", na_str = default_na_str(), @@ -17,9 +19,7 @@ count_cumulative( table_names = vars, ..., na_rm = TRUE, - lower_tail = TRUE, - include_eq = TRUE, - .stats = NULL, + .stats = c("count_fraction"), .stat_names = NULL, .formats = NULL, .labels = NULL, @@ -55,6 +55,11 @@ a_count_cumulative( \item{thresholds}{(\code{numeric})\cr vector of cutoff values for the counts.} +\item{lower_tail}{(\code{flag})\cr whether to count lower tail, default is \code{TRUE}.} + +\item{include_eq}{(\code{flag})\cr whether to include value equal to the \code{threshold} in +count, default is \code{TRUE}.} + \item{var_labels}{(\code{character})\cr variable labels.} \item{show_labels}{(\code{string})\cr label visibility: one of "default", "visible" and "hidden".} @@ -72,11 +77,6 @@ times, to avoid warnings from \code{rtables}.} \item{na_rm}{(\code{flag})\cr whether \code{NA} values should be removed from \code{x} prior to analysis.} -\item{lower_tail}{(\code{flag})\cr whether to count lower tail, default is \code{TRUE}.} - -\item{include_eq}{(\code{flag})\cr whether to include value equal to the \code{threshold} in -count, default is \code{TRUE}.} - \item{.stats}{(\code{character})\cr statistics to select for the table. Options are: \code{'count_fraction'}} diff --git a/man/count_missed_doses.Rd b/man/count_missed_doses.Rd index f32792e69f..b6e1176df3 100644 --- a/man/count_missed_doses.Rd +++ b/man/count_missed_doses.Rd @@ -17,7 +17,7 @@ count_missed_doses( table_names = vars, ..., na_rm = TRUE, - .stats = NULL, + .stats = c("n", "count_fraction"), .stat_names = NULL, .formats = NULL, .labels = NULL, diff --git a/man/prop_diff.Rd b/man/prop_diff.Rd index 226f59e02b..ac251c1599 100644 --- a/man/prop_diff.Rd +++ b/man/prop_diff.Rd @@ -10,6 +10,11 @@ estimate_proportion_diff( lyt, vars, + variables = list(strata = NULL), + conf_level = 0.95, + method = c("waldcc", "wald", "cmh", "ha", "newcombe", "newcombecc", "strat_newcombe", + "strat_newcombecc"), + weights_method = "cmh", var_labels = vars, na_str = default_na_str(), nested = TRUE, @@ -18,11 +23,6 @@ estimate_proportion_diff( section_div = NA_character_, ..., na_rm = TRUE, - variables = list(strata = NULL), - conf_level = 0.95, - method = c("waldcc", "wald", "cmh", "ha", "newcombe", "newcombecc", "strat_newcombe", - "strat_newcombecc"), - weights_method = "cmh", .stats = c("diff", "diff_ci"), .stat_names = NULL, .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"), @@ -58,6 +58,15 @@ a_proportion_diff( \item{vars}{(\code{character})\cr variable names for the primary analysis variable to be iterated over.} +\item{variables}{(named \code{list} of \code{string})\cr list of additional analysis variables.} + +\item{conf_level}{(\code{proportion})\cr confidence level of the interval.} + +\item{method}{(\code{string})\cr the method used for the confidence interval estimation.} + +\item{weights_method}{(\code{string})\cr weights method. Can be either \code{"cmh"} or \code{"heuristic"} +and directs the way weights are estimated.} + \item{var_labels}{(\code{character})\cr variable labels.} \item{na_str}{(\code{string})\cr string used to replace all \code{NA} or empty values in the output.} @@ -78,15 +87,6 @@ defined by this split instruction, or \code{NA_character_} (the default) for no \item{na_rm}{(\code{flag})\cr whether \code{NA} values should be removed from \code{x} prior to analysis.} -\item{variables}{(named \code{list} of \code{string})\cr list of additional analysis variables.} - -\item{conf_level}{(\code{proportion})\cr confidence level of the interval.} - -\item{method}{(\code{string})\cr the method used for the confidence interval estimation.} - -\item{weights_method}{(\code{string})\cr weights method. Can be either \code{"cmh"} or \code{"heuristic"} -and directs the way weights are estimated.} - \item{.stats}{(\code{character})\cr statistics to select for the table. Options are: \verb{'diff', 'diff_ci'}} diff --git a/man/prop_diff_test.Rd b/man/prop_diff_test.Rd index 8aa9cb3f56..135ecdc060 100644 --- a/man/prop_diff_test.Rd +++ b/man/prop_diff_test.Rd @@ -10,6 +10,8 @@ test_proportion_diff( lyt, vars, + variables = list(strata = NULL), + method = c("chisq", "schouten", "fisher", "cmh"), var_labels = vars, na_str = default_na_str(), nested = TRUE, @@ -18,8 +20,6 @@ test_proportion_diff( section_div = NA_character_, ..., na_rm = TRUE, - variables = list(strata = NULL), - method = c("chisq", "schouten", "fisher", "cmh"), .stats = c("pval"), .stat_names = NULL, .formats = c(pval = "x.xxxx | (<0.0001)"), @@ -52,6 +52,11 @@ a_test_proportion_diff( \item{vars}{(\code{character})\cr variable names for the primary analysis variable to be iterated over.} +\item{variables}{(named \code{list} of \code{string})\cr list of additional analysis variables.} + +\item{method}{(\code{string})\cr one of \code{chisq}, \code{cmh}, \code{fisher}, or \code{schouten}; specifies the test used +to calculate the p-value.} + \item{var_labels}{(\code{character})\cr variable labels.} \item{na_str}{(\code{string})\cr string used to replace all \code{NA} or empty values in the output.} @@ -72,11 +77,6 @@ defined by this split instruction, or \code{NA_character_} (the default) for no \item{na_rm}{(\code{flag})\cr whether \code{NA} values should be removed from \code{x} prior to analysis.} -\item{variables}{(named \code{list} of \code{string})\cr list of additional analysis variables.} - -\item{method}{(\code{string})\cr one of \code{chisq}, \code{cmh}, \code{fisher}, or \code{schouten}; specifies the test used -to calculate the p-value.} - \item{.stats}{(\code{character})\cr statistics to select for the table. Options are: \code{'pval'}} From 659b8b56a8fd4534ce0458c4e8d79533d4e7f003 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Fri, 7 Mar 2025 12:56:49 +0100 Subject: [PATCH 12/12] fix --- NEWS.md | 1 + R/count_cumulative.R | 9 ++-- R/count_missed_doses.R | 9 ++-- R/utils_default_stats_formats_labels.R | 27 ++++++++--- man/default_stats_formats_labels.Rd | 5 +++ tests/testthat/_snaps/count_cumulative.md | 27 +++++++++++ tests/testthat/test-count_cumulative.R | 55 +++++++++++++++++++++++ 7 files changed, 117 insertions(+), 16 deletions(-) diff --git a/NEWS.md b/NEWS.md index ba204e47aa..102797f667 100644 --- a/NEWS.md +++ b/NEWS.md @@ -10,6 +10,7 @@ * Fixed bug in `a_count_patients_with_flags()` preventing select custom label and indentation specification formats from being applied. * Fixed bug in `tabulate_rsp_subgroups` and `tabulate_survival_subgroups` preventing the `pct` option from having an effect when adding a risk difference column. * Fixed bug with the order of `.stats` when adding custom statistical functions. +* Fixed bug with multiple custom functions not being represented correctly as a list of output stats. ### Miscellaneous * Removed internal function `ungroup_stats()` and replaced its usage with the `get_*_from_stats()` functions. diff --git a/R/count_cumulative.R b/R/count_cumulative.R index e1ba1ea677..dc71d3a833 100644 --- a/R/count_cumulative.R +++ b/R/count_cumulative.R @@ -188,11 +188,10 @@ a_count_cumulative <- function(x, # Fill in formats/indents/labels with custom input and defaults .formats <- get_formats_from_stats(.stats, .formats, levels_per_stats) .indent_mods <- get_indents_from_stats(.stats, .indent_mods, levels_per_stats) - if (is.null(.labels)) { - .labels <- sapply(.unlist_keep_nulls(x_stats), attr, "label") - .labels <- .labels[nzchar(.labels) & !sapply(.labels, is.null) & !is.na(.labels)] - } - .labels <- get_labels_from_stats(.stats, .labels, levels_per_stats) + .labels <- get_labels_from_stats( + .stats, .labels, levels_per_stats, + label_attr_from_stats = sapply(.unlist_keep_nulls(x_stats), attr, "label") + ) # Unlist stats x_stats <- x_stats %>% diff --git a/R/count_missed_doses.R b/R/count_missed_doses.R index 9bee040c82..4c1d362636 100644 --- a/R/count_missed_doses.R +++ b/R/count_missed_doses.R @@ -120,11 +120,10 @@ a_count_missed_doses <- function(x, # Fill in formats/indents/labels with custom input and defaults .formats <- get_formats_from_stats(.stats, .formats, levels_per_stats) .indent_mods <- get_indents_from_stats(.stats, .indent_mods, levels_per_stats) - if (is.null(.labels)) { - .labels <- sapply(.unlist_keep_nulls(x_stats), attr, "label") - .labels <- .labels[nzchar(.labels) & !sapply(.labels, is.null) & !is.na(.labels)] - } - .labels <- get_labels_from_stats(.stats, .labels, levels_per_stats) + .labels <- get_labels_from_stats( + .stats, .labels, levels_per_stats, + label_attr_from_stats = sapply(.unlist_keep_nulls(x_stats), attr, "label") + ) # Unlist stats x_stats <- x_stats %>% diff --git a/R/utils_default_stats_formats_labels.R b/R/utils_default_stats_formats_labels.R index 661d0b63d8..743e8eecbf 100644 --- a/R/utils_default_stats_formats_labels.R +++ b/R/utils_default_stats_formats_labels.R @@ -221,13 +221,12 @@ get_stat_names <- function(stat_results, stat_names_in = NULL) { } } - # Merging - stat_fnc_list <- c(default_stat_fnc, custom_stat_fnc_list) - # Applying - out <- unlist(lapply(stat_fnc_list, function(fnc) do.call(fnc, args = args_list)), recursive = FALSE) + out_defalt <- do.call(default_stat_fnc, args = args_list) + out_custom <- lapply(custom_stat_fnc_list, function(fnc) do.call(fnc, args = args_list)) - out + # Merging + c(out_defalt, out_custom) } #' @describeIn default_stats_formats_labels Get formats corresponding to a list of statistics. @@ -278,7 +277,8 @@ get_formats_from_stats <- function(stats, out <- .fill_in_vals_by_stats(levels_per_stats, formats_in, tern_defaults) # Default to NULL if no format - out[names(out) == out] <- list(NULL) + weird_case_to_check <- unlist(out, use.names = FALSE) == unlist(levels_per_stats, use.names = FALSE) + out[names(out) == out | weird_case_to_check] <- list(NULL) out } @@ -288,6 +288,9 @@ get_formats_from_stats <- function(stats, #' #' @param labels_in (named `character`)\cr custom labels to use instead of defaults. If no value is provided, the #' variable level (if rows correspond to levels of a variable) or statistic name will be used as label. +#' @param label_attr_from_stats (named `list`)\cr if `labels_in = NULL`, then this will be used instead. It is a list +#' of values defined in statistical functions as default labels. Values are ignored if `labels_in` is provided or `""` +#' values are provided. #' #' @return #' * `get_labels_from_stats()` returns a named list of labels as strings. @@ -307,8 +310,20 @@ get_formats_from_stats <- function(stats, get_labels_from_stats <- function(stats, labels_in = NULL, levels_per_stats = NULL, + label_attr_from_stats = NULL, tern_defaults = tern_default_labels) { checkmate::assert_character(stats, min.len = 1) + + # If labels_in is NULL, use label_attr_from_stats + if (is.null(labels_in)) { + labels_in <- label_attr_from_stats + labels_in <- label_attr_from_stats[ + nzchar(label_attr_from_stats) & + !sapply(label_attr_from_stats, is.null) & + !is.na(label_attr_from_stats) + ] + } + # It may be a list if (checkmate::test_list(labels_in, null.ok = TRUE)) { checkmate::assert_list(labels_in, null.ok = TRUE) diff --git a/man/default_stats_formats_labels.Rd b/man/default_stats_formats_labels.Rd index ff8194a312..5a16e2f64f 100644 --- a/man/default_stats_formats_labels.Rd +++ b/man/default_stats_formats_labels.Rd @@ -51,6 +51,7 @@ get_labels_from_stats( stats, labels_in = NULL, levels_per_stats = NULL, + label_attr_from_stats = NULL, tern_defaults = tern_default_labels ) @@ -109,6 +110,10 @@ Must be of the same type as the values that are being filled in (e.g. indentatio \item{labels_in}{(named \code{character})\cr custom labels to use instead of defaults. If no value is provided, the variable level (if rows correspond to levels of a variable) or statistic name will be used as label.} +\item{label_attr_from_stats}{(named \code{list})\cr if \code{labels_in = NULL}, then this will be used instead. It is a list +of values defined in statistical functions as default labels. Values are ignored if \code{labels_in} is provided or \code{""} +values are provided.} + \item{indents_in}{(named \code{integer})\cr custom row indent modifiers to use instead of defaults. Defaults to \code{0L} for all values.} diff --git a/tests/testthat/_snaps/count_cumulative.md b/tests/testthat/_snaps/count_cumulative.md index 928125ec98..83cbdbca48 100644 --- a/tests/testthat/_snaps/count_cumulative.md +++ b/tests/testthat/_snaps/count_cumulative.md @@ -92,3 +92,30 @@ > 3 0 3 (75%) > 7 0 1 (25%) +# Testing label behavior when s_* forecasts label attributes + + Code + row.names(result) + Output + [1] "<= 3" "<= 7" + +--- + + Code + row.names(result) + Output + [1] "argh" "7" + +--- + + Code + res + Output + A B + ————————————————————————————— + <= 3 2 (40%) 1 (16.7%) + <= 7 4 (80%) 3 (50%) + a 1 1 + b 3 3 + min-max 1, 2 1, 2 + diff --git a/tests/testthat/test-count_cumulative.R b/tests/testthat/test-count_cumulative.R index 9dbbe046fa..2f35f25453 100644 --- a/tests/testthat/test-count_cumulative.R +++ b/tests/testthat/test-count_cumulative.R @@ -129,3 +129,58 @@ testthat::test_that("count_cumulative works with denom argument specified", { res <- testthat::expect_silent(result) testthat::expect_snapshot(res) }) +testthat::test_that("Testing label behavior when s_* forecasts label attributes", { + set.seed(1, kind = "Mersenne-Twister") + df <- data.frame( + a = c(sample(1:10, 10), NA), + type = factor(sample(c("x", "y"), 11, replace = TRUE)), + grp = factor(c(rep("A", 5), rep("B", 6)), levels = c("A", "B")) + ) + + result <- basic_table() %>% + split_cols_by("grp") %>% + count_cumulative( + vars = "a", + thresholds = c(3, 7), + show_labels = "hidden" + ) %>% + build_table(df) + + testthat::expect_snapshot(row.names(result)) + + result <- basic_table() %>% + split_cols_by("grp") %>% + count_cumulative( + vars = "a", + thresholds = c(3, 7), + show_labels = "hidden", + .labels = c("3" = "argh") + ) %>% + build_table(df) + + testthat::expect_snapshot(row.names(result)) + + result <- basic_table() %>% + split_cols_by("grp") %>% + count_cumulative( + vars = "a", + thresholds = c(3, 7), + show_labels = "hidden", + .stats = c("count_fraction", + "my_output" = function(x, ...) { + out <- list("a" = 1, "b" = 3) + attr(out, "label") <- "stat_function decides" + out + }, + "my_output2" = function(x, ...) { + out <- list("min-max" = c("min" = 1, "max" = 2)) + attr(out, "label") <- "stat_function is great" + out + } + ) + ) %>% + build_table(df) + + res <- testthat::expect_silent(result) + testthat::expect_snapshot(res) +})