Skip to content

Commit

Permalink
Refactor a_count_occurrences_by_grade()
Browse files Browse the repository at this point in the history
  • Loading branch information
@edelarua
edelarua committed Oct 18, 2024
1 parent d89bba0 commit e4a7829
Show file tree
Hide file tree
Showing 5 changed files with 288 additions and 63 deletions.
3 changes: 3 additions & 0 deletions NEWS.md
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,8 @@
# tern 0.9.6.9006

### Enhancements
* Refactored `a_count_occurrences_by_grade()` to no longer use `make_afun()`.

### Bug Fixes
* Fixed bug in `a_summary()` causing non-unique `row_name` values to occur when multiple statistics are selected for count variables.

Expand Down
149 changes: 111 additions & 38 deletions R/count_occurrences_by_grade.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,6 +16,7 @@
#' row/column context and operates on the level of the latest row split or the root of the table if no row splits have
#' occurred.
#'
#' @inheritParams count_occurrences
#' @inheritParams argument_convention
#' @param grade_groups (named `list` of `character`)\cr list containing groupings of grades.
#' @param remove_single (`flag`)\cr `TRUE` to not include the elements of one-element grade groups
Expand Down Expand Up @@ -148,15 +149,24 @@ h_append_grade_groups <- function(grade_groups, refs, remove_single = TRUE, only
#' @export
s_count_occurrences_by_grade <- function(df,
.var,
.N_row, # nolint
.N_col, # nolint
id = "USUBJID",
grade_groups = list(),
remove_single = TRUE,
only_grade_groups = FALSE,
denom = c("N_col", "n", "N_row"),
labelstr = "") {
assert_valid_factor(df[[.var]])
assert_df_with_variables(df, list(grade = .var, id = id))

denom <- match.arg(denom) %>%
switch(
n = nlevels(factor(df[[id]])),
N_row = .N_row,
N_col = .N_col
)

if (nrow(df) < 1) {
grade_levels <- levels(df[[.var]])
l_count <- as.list(rep(0, length(grade_levels)))
Expand Down Expand Up @@ -200,7 +210,17 @@ s_count_occurrences_by_grade <- function(df,
l_count <- h_append_grade_groups(grade_groups, l_count, remove_single, only_grade_groups)
}

l_count_fraction <- lapply(l_count, function(i, denom) c(i, i / denom), denom = .N_col)
l_count_fraction <- lapply(
l_count,
function(i, denom) {
if (i == 0 && denom == 0) {
c(0, 0)
} else {
c(i, i / denom)
}
},
denom = denom
)

list(
count_fraction = l_count_fraction
Expand All @@ -214,22 +234,71 @@ s_count_occurrences_by_grade <- function(df,
#' * `a_count_occurrences_by_grade()` returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#' # We need to ungroup `count_fraction` first so that the `rtables` formatting
#' # function `format_count_fraction()` can be applied correctly.
#' afun <- make_afun(a_count_occurrences_by_grade, .ungroup_stats = "count_fraction")
#' afun(
#' a_count_occurrences_by_grade(
#' df,
#' .N_col = 10L,
#' .N_row = 10L,
#' .var = "AETOXGR",
#' id = "USUBJID",
#' grade_groups = list("ANY" = levels(df$AETOXGR))
#' )
#'
#' @export
a_count_occurrences_by_grade <- make_afun(
s_count_occurrences_by_grade,
.formats = c("count_fraction" = format_count_fraction_fixed_dp)
)
a_count_occurrences_by_grade <- function(df,
labelstr = "",
id = "USUBJID",
grade_groups = list(),
remove_single = TRUE,
only_grade_groups = FALSE,
denom = c("N_col", "n", "N_row"),
.N_col, # nolint
.N_row, # nolint
.var = NULL,
.stats = NULL,
.formats = NULL,
.labels = NULL,
.indent_mods = NULL,
na_str = default_na_str()) {
x_stats <- s_count_occurrences_by_grade(
df = df, .var = .var, .N_row = .N_row, .N_col = .N_col, id = id,
grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups,
denom = denom, labelstr = labelstr
)

if (is.null(unlist(x_stats))) {
return(NULL)
}
x_lvls <- names(x_stats[[1]])

# Fill in with formatting defaults if needed
.stats <- get_stats("count_occurrences_by_grade", stats_in = .stats)
if (length(.formats) == 1 && is.null(names(.formats))) {
.formats <- rep(.formats, length(.stats)) %>% setNames(.stats)
}
.formats <- get_formats_from_stats(.stats, .formats)
.labels <- get_labels_from_stats(.stats, .labels, row_nms = x_lvls)
.indent_mods <- get_indents_from_stats(.stats, .indent_mods, row_nms = x_lvls)

if ("count_fraction_fixed_dp" %in% .stats) x_stats[["count_fraction_fixed_dp"]] <- x_stats[["count_fraction"]]
x_stats <- x_stats[.stats]

# Ungroup statistics with values for each level of x
x_ungrp <- ungroup_stats(x_stats, .formats, .labels, list())
x_stats <- x_ungrp[["x"]]
.formats <- x_ungrp[[".formats"]]

# Auto format handling
.formats <- apply_auto_formatting(.formats, x_stats, .df_row, .var)

in_rows(
.list = x_stats,
.formats = .formats,
.names = unlist(.labels),
.labels = unlist(.labels),
.indent_mods = .indent_mods,
.format_na_strs = na_str
)
}

#' @describeIn count_occurrences_by_grade Layout-creating function which can take statistics function
#' arguments and additional format arguments. This function is a wrapper for [rtables::analyze()].
Expand Down Expand Up @@ -299,40 +368,36 @@ count_occurrences_by_grade <- function(lyt,
nested = TRUE,
...,
table_names = var,
.stats = NULL,
.formats = NULL,
.stats = "count_fraction",
.formats = list(count_fraction = format_count_fraction_fixed_dp),
.indent_mods = NULL,
.labels = NULL) {
checkmate::assert_flag(riskdiff)
extra_args <- list(
.stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str
)
s_args <- list(
id = id, grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups, ...
)

afun <- make_afun(
a_count_occurrences_by_grade,
.stats = .stats,
.formats = .formats,
.indent_mods = .indent_mods,
.ungroup_stats = "count_fraction"
)

extra_args <- if (isFALSE(riskdiff)) {
s_args
if (isFALSE(riskdiff)) {
extra_args <- c(extra_args, s_args)
} else {
list(
afun = list("s_count_occurrences_by_grade" = afun),
.stats = .stats,
.indent_mods = .indent_mods,
s_args = s_args
extra_args <- c(
extra_args,
list(
afun = list("s_count_occurrences_by_grade" = a_count_occurrences_by_grade),
s_args = s_args
)
)
}

analyze(
lyt = lyt,
vars = var,
afun = ifelse(isFALSE(riskdiff), a_count_occurrences_by_grade, afun_riskdiff),
var_labels = var_labels,
show_labels = show_labels,
afun = ifelse(isFALSE(riskdiff), afun, afun_riskdiff),
table_names = table_names,
na_str = na_str,
nested = nested,
Expand Down Expand Up @@ -376,29 +441,37 @@ summarize_occurrences_by_grade <- function(lyt,
grade_groups = list(),
remove_single = TRUE,
only_grade_groups = FALSE,
riskdiff = FALSE,
na_str = default_na_str(),
...,
.stats = NULL,
.formats = NULL,
.stats = "count_fraction",
.formats = list(count_fraction = format_count_fraction_fixed_dp),
.indent_mods = NULL,
.labels = NULL) {
checkmate::assert_flag(riskdiff)
extra_args <- list(
.stats = .stats, .formats = .formats, .labels = .labels, .indent_mods = .indent_mods, na_str = na_str
)
s_args <- list(
id = id, grade_groups = grade_groups, remove_single = remove_single, only_grade_groups = only_grade_groups, ...
)

cfun <- make_afun(
a_count_occurrences_by_grade,
.stats = .stats,
.formats = .formats,
.labels = .labels,
.indent_mods = .indent_mods,
.ungroup_stats = "count_fraction"
)
if (isFALSE(riskdiff)) {
extra_args <- c(extra_args, s_args)
} else {
extra_args <- c(
extra_args,
list(
afun = list("s_count_occurrences_by_grade" = a_count_occurrences_by_grade),
s_args = s_args
)
)
}

summarize_row_groups(
lyt = lyt,
var = var,
cfun = cfun,
cfun = ifelse(isFALSE(riskdiff), a_count_occurrences_by_grade, afun_riskdiff),
na_str = na_str,
extra_args = extra_args
)
Expand Down
39 changes: 28 additions & 11 deletions man/count_occurrences_by_grade.Rd
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

Loading

0 comments on commit e4a7829

Please sign in to comment.