Skip to content

Commit

Permalink
Allowing dichotomous rows in tbl_continuous() (#1983)
Browse files Browse the repository at this point in the history 
* in progress

* adding unit tests

* adding more tests

* Update tbl_continuous.R

* in progress

* Update tbl_ard_continuous.R

* Update tbl_ard_continuous.Rd

* doc updates

* updates

* doc update

* doc update

---------

Co-authored-by: Davide Garolini <[email protected]>
  • Loading branch information
@ddsjoberg @Melkiades
ddsjoberg and Melkiades authored Sep 19, 2024
1 parent d754535 commit a93e56f
Show file tree
Hide file tree
Showing 10 changed files with 375 additions and 95 deletions.
7 changes: 4 additions & 3 deletions R/brdg_continuous.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,10 +29,11 @@
#' brdg_continuous(
#' variable = "age",
#' include = "grade",
#' statistic = list(grade = "{median} ({p25}, {p75})")
#' statistic = list(grade = "{median} ({p25}, {p75})"),
#' type = list(grade = "categorical")
#' ) |>
#' as_tibble()
brdg_continuous <- function(cards, by = NULL, statistic, include, variable) {
brdg_continuous <- function(cards, by = NULL, statistic, include, variable, type) {
set_cli_abort_call()

# prepare the cards object for `brdg_summary()` ------------------------------
Expand All @@ -43,7 +44,7 @@ brdg_continuous <- function(cards, by = NULL, statistic, include, variable) {
cards = cards,
statistic = statistic,
by = by,
type = rep_named(include, list("categorical")),
type = type,
variables = include,
missing = "no"
)
Expand Down
120 changes: 84 additions & 36 deletions R/tbl_ard_continuous.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,50 +13,44 @@
#' Specifies summary statistics to display for each variable. The default is
#' `everything() ~ "{median} ({p25}, {p75})"`.
#' @inheritParams tbl_ard_summary
#' @inheritParams tbl_continuous
#'
#' @return a gtsummary table of class `"tbl_ard_summary"`
#' @export
#'
#' @examples
#' library(cards)
#'
#' bind_ard(
#' # the primary ARD with the results
#' ard_continuous(
#' trial,
#' # the order variables are passed here is important.
#' # 'trt' is the column stratifying variable and needs to be listed first.
#' by = c(trt, grade),
#' variables = age
#' ),
#' # add univariate trt tabulation
#' ard_categorical(
#' trial,
#' variables = trt
#' ),
#' # add missing and attributes ARD
#' ard_missing(
#' trial,
#' by = c(trt, grade),
#' variables = age
#' ),
#' ard_attributes(
#' trial,
#' variables = c(trt, grade, age)
#' )
#' # Example 1 ----------------------------------
#' # the primary ARD with the results
#' ard_continuous(
#' # the order variables are passed is important for the `by` variable.
#' # 'trt' is the column stratifying variable and needs to be listed first.
#' trial, by = c(trt, grade), variables = age
#' ) |>
#' # adding OPTIONAL information about the summary variables
#' bind_ard(
#' # add univariate trt tabulation
#' ard_categorical(trial, variables = trt),
#' # add missing and attributes ARD
#' ard_missing(trial, by = c(trt, grade), variables = age),
#' ard_attributes(trial, variables = c(trt, grade, age))
#' ) |>
#' tbl_ard_continuous(by = "trt", variable = "age", include = "grade")
#'
#' bind_ard(
#' # the primary ARD with the results
#' ard_continuous(trial, by = grade, variables = age),
#' # add missing and attributes ARD
#' ard_missing(trial, by = grade, variables = age),
#' ard_attributes(trial, variables = c(grade, age))
#' ) |>
#' # Example 2 ----------------------------------
#' # the primary ARD with the results
#' ard_continuous(trial, by = grade, variables = age) |>
#' # adding OPTIONAL information about the summary variables
#' bind_ard(
#' # add missing and attributes ARD
#' ard_missing(trial, by = grade, variables = age),
#' ard_attributes(trial, variables = c(grade, age))
#' ) |>
#' tbl_ard_continuous(variable = "age", include = "grade")
tbl_ard_continuous <- function(cards, variable, include, by = NULL, label = NULL,
statistic = everything() ~ "{median} ({p25}, {p75})") {
statistic = everything() ~ "{median} ({p25}, {p75})",
value = NULL) {
set_cli_abort_call()
check_not_missing(cards)
check_not_missing(variable)
Expand All @@ -81,6 +75,11 @@ tbl_ard_continuous <- function(cards, variable, include, by = NULL, label = NULL
)
)

# process type and value arguments
cards::process_formula_selectors(data[include], value = value)
type <- rep_named(include, list("categorical")) |>
utils::modifyList(rep_named(names(compact(value)), list("dichotomous")))

# check the structure of the cards object ------------------------------------
# check that the continuous variable appears somewhere in `cards$variable`
if (!"variable" %in% names(cards) || !variable %in% cards$variable) {
Expand Down Expand Up @@ -112,13 +111,21 @@ tbl_ard_continuous <- function(cards, variable, include, by = NULL, label = NULL
)
}

cards::check_list_elements(
x = value,
predicate = \(x) length(x) == 1L,
error_msg =
c("Error in argument {.arg {arg_name}} for variable {.val {variable}}.",
"i" = "Elements values must be a scalar.")
)

cards::process_formula_selectors(
data[include],
data = scope_table_body(.list2tb(type, "var_type"), data[include]),
statistic = statistic,
include_env = TRUE
)
cards::process_formula_selectors(
data[include],
data = scope_table_body(.list2tb(type, "var_type"), data[c(include, variable)]),
label = label
)

Expand All @@ -133,12 +140,16 @@ tbl_ard_continuous <- function(cards, variable, include, by = NULL, label = NULL
# save processed function inputs ---------------------------------------------
tbl_ard_continuous_inputs <- as.list(environment())
tbl_ard_continuous_inputs$data <- NULL
tbl_ard_continuous_inputs$type <- NULL
call <- match.call()

# subsetting ARD based on passed value ---------------------------------------
cards <- .subset_card_based_on_value(cards, value, by)

# add/update attributes ------------------------------------------------------
cards <-
cards::bind_ard(
cards::ard_attributes(data, variables = all_of(include)),
cards::ard_attributes(data, variables = all_of(c(include, variable))),
cards,
cards::ard_attributes(data, variables = all_of(names(label)), label = label),
.update = TRUE,
Expand All @@ -164,7 +175,8 @@ tbl_ard_continuous <- function(cards, variable, include, by = NULL, label = NULL
)

# prepare the base table via `brdg_continuous()` -----------------------------
x <- brdg_continuous(cards, by = by, statistic = statistic, include = include, variable = variable)
x <- brdg_continuous(cards, by = by, statistic = statistic, include = include,
variable = variable, type = type)

# adding styling -------------------------------------------------------------
x <- x |>
Expand All @@ -190,3 +202,39 @@ tbl_ard_continuous <- function(cards, variable, include, by = NULL, label = NULL
x |>
structure(class = c("tbl_ard_continuous", "gtsummary"))
}

.subset_card_based_on_value <- function(cards, value, by) {
if (is_empty(value)) return(cards)

if (is_empty(by)) {
group <- "group1"
group_level <- "group1_level"
}
else {
group <- "group2"
group_level <- "group2_level"
}

# every dichotomous variable, remove the levels we are not reporting
for (varname in names(compact(value))) {
# check value appears in ARD
varlevels <- dplyr::filter(cards, .data[[group]] %in% .env$varname) |>
dplyr::pull(all_of(group_level)) |>
unlist() |>
unique()
if (!value[[varname]] %in% varlevels) {
cli::cli_abort(
c("There was an error in the {.arg value} argument for variable {.val {varname}}.",
"The list value must be one of {.val {varlevels}}."),
call = get_cli_abort_call()
)
}

# removing other levels from the ARD for the variable
cards <- cards |>
dplyr::filter(!(.data[[group]] %in% .env$varname &
!map_lgl(.data[[group_level]], ~ !is.null(.x) && .x %in% .env$value[[.env$varname]])))
}

cards
}
55 changes: 42 additions & 13 deletions R/tbl_continuous.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,10 @@
#' @param statistic ([`formula-list-selector`][syntax])\cr
#' Specifies summary statistics to display for each variable. The default is
#' `everything() ~ "{median} ({p25}, {p75})"`.
#' @param value ([`formula-list-selector`][syntax])\cr
#' Supply a value to display a variable on a single row, printing the
#' results for the variable associated with the value (similar to a
#' `'dichotomous'` display in `tbl_summary()`).
#' @inheritParams tbl_summary
#'
#' @return a gtsummary table
Expand All @@ -26,20 +30,24 @@
#' )
#'
#' # Example 2 ----------------------------------
#' tbl_continuous(
#' data = trial,
#' variable = age,
#' statistic = ~"{mean} ({sd})",
#' by = trt,
#' include = c(stage, grade)
#' )
#' trial |>
#' dplyr::mutate(all_subjects = 1) |>
#' tbl_continuous(
#' variable = age,
#' statistic = ~"{mean} ({sd})",
#' by = trt,
#' include = c(all_subjects, stage, grade),
#' value = all_subjects ~ 1,
#' label = list(all_subjects = "All Subjects")
#' )
tbl_continuous <- function(data,
variable,
include = everything(),
digits = NULL,
by = NULL,
statistic = everything() ~ "{median} ({p25}, {p75})",
label = NULL) {
label = NULL,
value = NULL) {
set_cli_abort_call()

# data argument checks -------------------------------------------------------
Expand All @@ -61,9 +69,23 @@ tbl_continuous <- function(data,
include <- setdiff(include, c(by, variable)) # remove by and variable columns from list vars included
data <- dplyr::ungroup(data) |> .drop_missing_by_obs(by = by) # styler: off

# assign types and values
cards::process_formula_selectors(data[include], value = value)
type <- rep_named(include, list("categorical")) |>
utils::modifyList(rep_named(names(compact(value)), list("dichotomous")))

cards::check_list_elements(
x = value,
predicate = \(x) length(x) == 1L,
error_msg =
c("Error in argument {.arg {arg_name}} for variable {.val {variable}}.",
"i" = "Elements values must be a scalar.")
)


# processed arguments are saved into this env
cards::process_formula_selectors(
data = scope_table_body(.list2tb(rep_named(include, list("categorical")), "var_type"), data[include]),
data = scope_table_body(.list2tb(type, "var_type"), data[include]),
statistic = statistic,
include_env = TRUE
)
Expand All @@ -78,6 +100,10 @@ tbl_continuous <- function(data,
i = "For example {.code statistic = list(colname = '{{mean}} ({{sd}})')}, to report the {.field mean} and {.field standard deviation}.")
)

cards::process_formula_selectors(
data = scope_table_body(.list2tb(type, "var_type"), data[c(include, variable)]),
label = label
)
cards::check_list_elements(
label,
predicate = \(x) is_string(x),
Expand All @@ -86,16 +112,15 @@ tbl_continuous <- function(data,
)

cards::process_formula_selectors(
data = scope_table_body(.list2tb(rep_named(include, list("categorical")), "var_type"), data[include]),
data = scope_table_body(.list2tb(type, "var_type"), data[include]),
digits = digits
)


# save processed function inputs ---------------------------------------------
tbl_continuous_inputs <- as.list(environment())
tbl_continuous_inputs$type <- NULL
call <- match.call()


# prepare the ARD data frame -------------------------------------------------
cards <-
map(
Expand Down Expand Up @@ -142,6 +167,9 @@ tbl_continuous <- function(data,
cards::ard_total_n(data)
)

# subsetting ARD based on passed value ---------------------------------------
cards <- .subset_card_based_on_value(cards, value, by)

# fill NULL stats with NA
cards <- cards::replace_null_statistic(cards)

Expand All @@ -155,7 +183,8 @@ tbl_continuous <- function(data,
cards <- .add_gts_column_to_cards_continuous(cards, include, by)

# prepare the base table via `brdg_continuous()` -----------------------------
x <- brdg_continuous(cards, by = by, statistic = statistic, include = include, variable = variable)
x <- brdg_continuous(cards, by = by, statistic = statistic, include = include,
variable = variable, type = type)

# adding styling -------------------------------------------------------------
x <- x |>
Expand Down
8 changes: 6 additions & 2 deletions man/brdg_continuous.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 a93e56f

Please sign in to comment.