cards/0000755000176200001440000000000014776310352011356 5ustar liggesuserscards/tests/0000755000176200001440000000000014776255604012530 5ustar liggesuserscards/tests/testthat/0000755000176200001440000000000014776310352014360 5ustar liggesuserscards/tests/testthat/test-ard_continuous.R0000644000176200001440000003244014754213432020514 0ustar liggesuserstest_that("ard_continuous() works", { expect_error( ard_test <- ard_continuous(mtcars, variables = c(mpg, hp), by = c(am, vs)), NA ) expect_snapshot(class(ard_test)) expect_equal( get_ard_statistics( ard_test, group1_level %in% 0, group2_level %in% 0, variable %in% "mpg", stat_name %in% c("N", "mean") ), list( N = with(mtcars, length(mpg[am %in% 0 & vs %in% 0])), mean = with(mtcars, mean(mpg[am %in% 0 & vs %in% 0])) ), ignore_attr = TRUE ) expect_equal( ard_continuous( mtcars, variables = starts_with("xxxxx") ), dplyr::tibble() |> as_card() ) }) test_that("ard_continuous(fmt_fn) argument works", { ard_continuous( ADSL, variables = "AGE", statistic = list(AGE = continuous_summary_fns(c("N", "mean", "median"))), fmt_fn = list( AGE = list( mean = function(x) round5(x, digits = 3) |> as.character(), N = function(x) format(round5(x, digits = 2), nsmall = 2), N_obs = function(x) format(round5(x, digits = 2), nsmall = 2) ) ) ) |> apply_fmt_fn() |> dplyr::select(variable, stat_name, stat, stat_fmt) |> as.data.frame() |> expect_snapshot() ard_continuous( ADSL, variables = c("AGE", "BMIBL"), statistic = ~ continuous_summary_fns("mean"), fmt_fn = list( AGE = list( mean = function(x) round5(x, digits = 3) |> as.character() ) ) ) |> apply_fmt_fn() |> dplyr::select(variable, stat_name, stat, stat_fmt) |> as.data.frame() |> expect_snapshot() # tidyselect works ard_continuous( ADSL, variables = c("AGE", "BMIBL"), statistic = ~ continuous_summary_fns(c("mean", "sd")), fmt_fn = ~ list(~ function(x) round(x, 4)) ) |> apply_fmt_fn() |> dplyr::select(variable, stat_name, stat, stat_fmt) |> as.data.frame() |> expect_snapshot() }) test_that("ard_continuous() messaging", { # proper error message when statistic argument mis-specified expect_snapshot( ard_continuous(mtcars, variables = "mpg", statistic = ~ list(mean = "this is a string")), error = TRUE ) # proper error message when non-data frame passed expect_snapshot( ard_continuous(letters, variables = "mpg"), error = TRUE ) # proper error message when variables not passed expect_snapshot( ard_continuous(mtcars), error = TRUE ) }) test_that("ard_continuous(stat_label) argument works", { # formula expect_snapshot( ard_continuous( data = ADSL, by = "ARM", variables = c("AGE", "BMIBL"), stat_label = everything() ~ list(c("min", "max") ~ "min - max") ) |> as.data.frame() |> dplyr::select(stat_name, stat_label) |> dplyr::filter(stat_name %in% c("min", "max")) |> unique() ) # list expect_snapshot( ard_continuous( data = ADSL, by = "ARM", variables = c("AGE", "BMIBL"), stat_label = everything() ~ list(p25 = "25th %ile", p75 = "75th %ile") ) |> as.data.frame() |> dplyr::select(stat_name, stat_label) |> dplyr::filter(stat_name %in% c("p25", "p75")) |> unique() ) # variable-specific expect_snapshot( ard_continuous( data = ADSL, by = "ARM", variables = c("AGE", "BMIBL"), stat_label = AGE ~ list(p25 = "25th %ile", p75 = "75th %ile") ) |> as.data.frame() |> dplyr::filter(stat_name %in% c("p25", "p75")) |> dplyr::select(variable, stat_name, stat_label) |> unique() ) # statistics returns a named list of summaries conf_int <- function(x) { t.test(x)[["conf.int"]] |> as.list() |> rlang::set_names(c("conf.low", "conf.high")) } ard1 <- ard_continuous( ADSL, variables = "AGE", statistic = ~ list(conf.int = conf_int), stat_label = ~ list(conf.low = "LB", conf.high = "UB") ) |> dplyr::select(variable, stat_name, stat_label) |> as.data.frame() expect_snapshot(ard1) ard2 <- ard_continuous( ADSL, variables = "AGE", statistic = ~ list(conf.int = conf_int), stat_label = ~ list("conf.low" ~ "LB", "conf.high" ~ "UB") ) |> dplyr::select(variable, stat_name, stat_label) |> as.data.frame() expect_equal(ard1, ard2) }) test_that("ard_continuous() and ARD column names", { ard_colnames <- c( "group1", "group1_level", "variable", "variable_level", "context", "stat_name", "stat_label", "statistic", "fmt_fn", "warning", "error" ) # no errors when these variables are the summary vars expect_error( { df <- mtcars names(df) <- ard_colnames ard_continuous( data = suppressMessages(cbind(mtcars["am"], df)), variables = all_of(ard_colnames), by = "am" ) }, NA ) # no errors when these vars are the by var expect_error( { lapply( ard_colnames, function(byvar) { df <- mtcars[c("am", "mpg")] names(df) <- c(byvar, "mpg") ard_continuous( data = df, by = all_of(byvar), variables = "mpg" ) } ) }, NA ) }) test_that("ard_continuous() with grouped data works", { expect_equal( ADSL |> dplyr::group_by(ARM) |> ard_continuous(variables = AGE), ard_continuous(data = ADSL, by = ARM, variables = AGE) ) }) test_that("ard_continuous() with dates works and displays as expected", { ard_date <- ADSL |> ard_continuous( variables = DISONSDT, statistic = ~ continuous_summary_fns(c("min", "max", "sd")) ) expect_snapshot(ard_date) expect_equal(ard_date$stat[[1]], as.Date("1998-06-13")) }) test_that("ard_continuous() with empty/missing dates works, and preserves Date class", { empty_date <- data.frame(dt = as.Date(NA)) |> ard_continuous( variables = dt, statistic = ~ continuous_summary_fns(c("min")) ) expect_equal(inherits(empty_date$stat[[1]], "Date"), TRUE) }) test_that("ard_continuous() works with non-syntactic names", { expect_equal( ADSL |> dplyr::mutate(`BMI base` = BMIBL, `Age` = AGE) |> ard_continuous( variables = `BMI base`, statistic = ~ continuous_summary_fns(c("min", "max", "sd")) ) |> dplyr::select(stat, error), ADSL |> ard_continuous( variables = BMIBL, statistic = ~ continuous_summary_fns(c("min", "max", "sd")) ) |> dplyr::select(stat, error) ) expect_equal( ADSL |> dplyr::mutate(`BMI base` = BMIBL, `Age` = AGE) |> ard_continuous( variables = "BMI base", statistic = ~ continuous_summary_fns(c("min", "max", "sd")) ) |> dplyr::select(stat, error), ADSL |> ard_continuous( variables = BMIBL, statistic = ~ continuous_summary_fns(c("min", "max", "sd")) ) |> dplyr::select(stat, error) ) `mean error` <- function(x) { stop("There was an error calculating the mean.") mean(x) } expect_snapshot(ADSL |> dplyr::mutate(`BMI base` = BMIBL, `Age` = AGE, `Arm Var` = ARM) |> ard_continuous( variables = c("BMI base", `Age`), statistic = ~ list("mean lbl" = `mean error`), stat_label = everything() ~ list(`mean lbl` = "Test lbl") ) |> as.data.frame()) }) # - test if function parameters can be used as variable names without error test_that("ard_continuous() works when using generic names ", { mtcars2 <- mtcars %>% dplyr::rename("variable_level" = mpg, "variable" = cyl, "median" = disp, "p25" = gear) expect_equal( ard_continuous(mtcars, variables = c(mpg, cyl), by = disp) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(variable_level, variable), by = median) |> dplyr::select(stat) ) expect_equal( ard_continuous(mtcars, variables = c(disp, gear), by = mpg) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(median, p25), by = variable_level) |> dplyr::select(stat) ) expect_equal( ard_continuous(mtcars, variables = c(disp, gear), by = cyl) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(median, p25), by = variable) |> dplyr::select(stat) ) expect_equal( ard_continuous(mtcars, variables = c(disp, mpg), by = gear) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(median, variable_level), by = p25) |> dplyr::select(stat) ) # rename vars mtcars2 <- mtcars %>% dplyr::rename("by" = mpg, "statistic" = cyl, "weights" = disp, "p75" = gear) expect_equal( ard_continuous(mtcars, variables = c(mpg, cyl), by = disp) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(by, statistic), by = weights) |> dplyr::select(stat) ) expect_equal( ard_continuous(mtcars, variables = c(cyl, disp), by = mpg) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(statistic, weights), by = by) |> dplyr::select(stat) ) expect_equal( ard_continuous(mtcars, variables = c(mpg, gear), by = cyl) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(by, p75), by = statistic) |> dplyr::select(stat) ) expect_equal( ard_continuous(mtcars, variables = c(mpg, cyl), by = gear) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(by, statistic), by = p75) |> dplyr::select(stat) ) expect_equal( ard_continuous(mtcars, variables = c(mpg, gear), by = cyl) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(by, p75), by = statistic) |> dplyr::select(stat) ) # rename vars mtcars2 <- mtcars %>% dplyr::rename("mean" = mpg, "sd" = cyl, "var" = disp, "sum" = gear) expect_equal( ard_continuous(mtcars, variables = c(mpg, cyl), by = disp) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(mean, sd), by = var) |> dplyr::select(stat) ) expect_equal( ard_continuous(mtcars, variables = c(cyl, disp), by = mpg) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(sd, var), by = mean) |> dplyr::select(stat) ) expect_equal( ard_continuous(mtcars, variables = c(mpg, disp), by = cyl) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(mean, var), by = sd) |> dplyr::select(stat) ) expect_equal( ard_continuous(mtcars, variables = c(mpg, cyl), by = gear) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(mean, sd), by = sum) |> dplyr::select(stat) ) expect_equal( ard_continuous(mtcars, variables = c(mpg, gear), by = cyl) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(mean, sum), by = sd) |> dplyr::select(stat) ) # rename vars mtcars2 <- mtcars %>% dplyr::rename("deff" = mpg, "min" = cyl, "max" = disp, "mean.std.error" = gear) expect_equal( ard_continuous(mtcars, variables = c(mpg, cyl), by = disp) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(deff, min), by = max) |> dplyr::select(stat) ) expect_equal( ard_continuous(mtcars, variables = c(cyl, disp), by = mpg) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(min, max), by = deff) |> dplyr::select(stat) ) expect_equal( ard_continuous(mtcars, variables = c(mpg, disp), by = cyl) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(deff, max), by = min) |> dplyr::select(stat) ) expect_equal( ard_continuous(mtcars, variables = c(mpg, cyl), by = gear) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(deff, min), by = mean.std.error) |> dplyr::select(stat) ) expect_equal( ard_continuous(mtcars, variables = c(mpg, gear), by = cyl) |> dplyr::select(stat), ard_continuous(mtcars2, variables = c(deff, mean.std.error), by = min) |> dplyr::select(stat) ) }) test_that("ard_continuous() follows ard structure", { expect_silent( ard_continuous(mtcars, variables = c(mpg, gear), by = cyl) |> check_ard_structure(method = FALSE) ) }) test_that("ard_continuous() errors with incomplete factor columns", { # Check error when factors have no levels expect_snapshot( error = TRUE, mtcars |> dplyr::mutate(am = factor(am, levels = character(0))) |> ard_continuous( by = am, variables = mpg ) ) # Check error when factor has NA level expect_snapshot( error = TRUE, mtcars |> dplyr::mutate(am = factor(am, levels = c(0, 1, NA), exclude = NULL)) |> ard_continuous( by = am, variables = mpg ) ) }) test_that("ard_continuous() with `as_cards_fn()` inputs", { ttest_works <- as_cards_fn( \(x) t.test(x)[c("statistic", "p.value")], stat_names = c("statistic", "p.value") ) ttest_error <- as_cards_fn( \(x) { t.test(x)[c("statistic", "p.value")] stop("Intentional Error") }, stat_names = c("statistic", "p.value") ) # the result is the same when there is no error expect_equal( ard_continuous(mtcars, variables = mpg, statistic = ~ list(ttest = ttest_works)), ard_continuous(mtcars, variables = mpg, statistic = ~ list(ttest = \(x) t.test(x)[c("statistic", "p.value")])) ) # when there is an error, we get the same structure back expect_equal( ard_continuous(mtcars, variables = mpg, statistic = ~ list(ttest = ttest_error)) |> dplyr::pull("stat_name"), ard_continuous(mtcars, variables = mpg, statistic = ~ list(ttest = \(x) t.test(x)[c("statistic", "p.value")])) |> dplyr::pull("stat_name") ) }) cards/tests/testthat/test-shuffle_ard.R0000644000176200001440000001317014776252447017756 0ustar liggesusersskip_if_not(is_pkg_installed("withr")) test_that("shuffle/trim works", { withr::local_options(list(width = 200)) # shuffle without group/var levels ard_simple <- ard_continuous(ADSL, variables = "AGE") ard_simple_shuffled <- ard_simple |> shuffle_ard(trim = FALSE) |> as.data.frame() expect_snapshot(ard_simple_shuffled) # shuffle back-fills groupings ard_grp <- bind_ard( ard_categorical(ADSL, variables = "ARM"), ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") ) ard_grp_shuffled <- ard_grp |> shuffle_ard(trim = FALSE) |> dplyr::filter(!stat_name == "N") expect_true(all(!is.na(ard_grp_shuffled$ARM))) ard_hier <- ard_hierarchical_count( data = ADAE, variables = c(AESOC, AEDECOD), by = TRTA ) ard_hier_shuff <- ard_hier |> shuffle_ard(trim = FALSE) |> as.data.frame() expect_true(all(!is.na(ard_hier_shuff$AESOC))) # shuffle many different formats ard_test <- bind_ard( ard_categorical(ADSL, variables = "ARM"), ard_continuous(ADSL, by = "ARM", variables = "AGE", stat_label = ~ list(c("mean", "sd") ~ "Mean(SD)")), ard_categorical(ADSL, by = "ARM", variables = "AGEGR1"), ard_missing(ADSL, by = "ARM", variables = c("AGEGR1", "AGE")) ) ard_shuffled <- ard_test |> shuffle_ard() |> as.data.frame() expect_snapshot(ard_shuffled[1:5, ]) # shuffle & trim ard_shuff_trim <- ard_test |> shuffle_ard() |> as.data.frame() expect_snapshot(ard_shuff_trim[1:5, ]) # only numeric stats expect_type(ard_shuff_trim$stat, "double") # no list columns expect_true(!any(map_lgl(ard_shuff_trim, is.list))) }) test_that("shuffle_ard handles protected names", { ard_test <- ard_categorical( ADSL |> dplyr::rename(stat = ARM), by = "stat", variables = "AGEGR1" ) |> shuffle_ard() expect_equal(names(ard_test)[1], "stat.1") }) test_that("shuffle_ard notifies user about warnings/errors before dropping", { withr::local_options(list(width = 200)) expect_snapshot( ard_continuous( ADSL, variables = AGEGR1 ) |> shuffle_ard() ) }) test_that("shuffle_ard fills missing group levels if the group is meaningful", { withr::local_options(list(width = 200)) # mix of missing/nonmissing group levels present before shuffle expect_snapshot( bind_ard( ard_continuous(ADSL, by = "ARM", variables = "AGE", statistic = ~ continuous_summary_fns("mean")), dplyr::tibble(group1 = "ARM", variable = "AGE", stat_name = "p", stat_label = "p", stat = list(0.05)) ) |> dplyr::filter(dplyr::row_number() <= 5L) |> shuffle_ard() ) # no group levels present before shuffle expect_snapshot( bind_ard( ard_continuous(ADSL, variables = "AGE", statistic = ~ continuous_summary_fns("mean")), dplyr::tibble(group1 = "ARM", variable = "AGE", stat_name = "p", stat_label = "p", stat = list(0.05)) ) |> dplyr::filter(dplyr::row_number() <= 5L) |> shuffle_ard() ) # mix of group variables - fills overall only if variable has been calculated by group elsewhere expect_snapshot( bind_ard( ard_categorical(ADSL, by = ARM, variables = AGEGR1) |> dplyr::slice(1), ard_categorical(ADSL, variables = AGEGR1) |> dplyr::slice(1), ard_continuous(ADSL, by = SEX, variables = AGE) |> dplyr::slice(1), ard_continuous(ADSL, variables = AGE) |> dplyr::slice(1) ) |> shuffle_ard() |> as.data.frame() ) }) test_that("shuffle_ard doesn't trim off NULL/NA values", { # mix of char NA, NULL values res <- suppressMessages( data.frame(x = rep_len(NA, 10)) |> ard_continuous( variables = x, statistic = ~ continuous_summary_fns(c("median", "p25", "p75")) ) |> shuffle_ard() |> dplyr::pull(stat) ) # check that all rows present expect_length(res, 3) }) test_that("shuffle_ard coerces all factor groups/variables to character", { adsl_ <- ADSL |> dplyr::mutate(RACE = factor(RACE)) res <- ard_categorical( data = adsl_, by = TRT01A, variables = c(RACE, ETHNIC) ) |> shuffle_ard() res_classes <- res |> dplyr::select(-stat) |> sapply(class) # all are character expect_true(all(res_classes == "character")) # correct coersion expect_equal( sort(unique(res$variable_level)), sort(unique(c(as.character(adsl_$RACE), adsl_$ETHNIC))) ) }) test_that("shuffle_ard fills missing group levels if the group is meaningful for cardx output", { withr::local_options(list(width = 200)) # cardx ARD: this is a dput() of a cardx result (see commented out code below) SAVED 2024-08-30 ard_cardx <- structure(list( group1 = c("ARM", "ARM", "SEX", "SEX"), variable = c( "AGEGR1", "AGEGR1", "AGEGR1", "AGEGR1" ), context = c( "stats_chisq_test", "stats_chisq_test", "stats_chisq_test", "stats_chisq_test" ), stat_name = c("statistic", "p.value", "statistic", "p.value"), stat_label = c( "X-squared Statistic", "p-value", "X-squared Statistic", "p-value" ), stat = list( statistic = c(`X-squared` = 5.07944166638125), p.value = 0.0788884197453486, statistic = c(`X-squared` = 1.03944199945198), p.value = 0.594686442507218 ), fmt_fn = list( statistic = 1L, p.value = 1L, statistic = 1L, p.value = 1L ), warning = list( warning = NULL, warning = NULL, warning = NULL, warning = NULL ), error = list(error = NULL, error = NULL, error = NULL, error = NULL) ), row.names = c( NA, -4L ), class = c("card", "tbl_df", "tbl", "data.frame")) expect_snapshot( ard_cardx |> shuffle_ard() |> as.data.frame() ) }) cards/tests/testthat/test-print.R0000644000176200001440000000172614567176413016630 0ustar liggesuserstest_that("print.card() works", { expect_snapshot( ard_continuous(ADSL, by = "ARM", variables = "AGE") ) expect_snapshot( ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") ) expect_snapshot( ard_continuous(ADSL, variables = "AGE", fmt_fn = AGE ~ list(~ \(x) round(x, 3))) ) # checking the print of Dates expect_snapshot( ard_continuous( data = data.frame(x = seq(as.Date("2000-01-01"), length.out = 10L, by = "day")), variables = x, statistic = ~ continuous_summary_fns(c("min", "max", "sd")) ) |> dplyr::select(-fmt_fn) ) # checking the print of a complex matrix statistic result expect_snapshot( bind_ard( ard_attributes(mtcars, variables = mpg), ard_continuous( mtcars, variables = mpg, statistic = ~ continuous_summary_fns( "mean", other_stats = list(vcov = \(x) lm(mpg ~ am, mtcars) |> vcov()) ) ) ) ) }) cards/tests/testthat/test-rename_ard_groups.R0000644000176200001440000000217214754404230021151 0ustar liggesuserstest_that("rename_ard_groups_shift()", { # no errors when no grouping variables expect_equal( ard_continuous(ADSL, variables = AGE) |> rename_ard_groups_shift(), ard_continuous(ADSL, variables = AGE) ) # works under normal circumstances expect_snapshot( ard_continuous(ADSL, variables = AGE, by = c(SEX, ARM)) |> rename_ard_groups_shift(shift = 1L) |> dplyr::select(all_ard_groups()) %>% `[`(1L, ) ) }) test_that("rename_ard_groups_shift() messaging", { expect_snapshot( ard_continuous(ADSL, variables = AGE, by = c(SEX, ARM)) |> rename_ard_groups_shift(shift = -1L) |> dplyr::select(all_ard_groups()) %>% `[`(1L, ) ) }) test_that("rename_ard_groups_reverse()", { # no errors when no grouping variables expect_equal( ard_continuous(ADSL, variables = AGE) |> rename_ard_groups_reverse(), ard_continuous(ADSL, variables = AGE) ) # works under normal circumstances expect_snapshot( ard_continuous(ADSL, variables = AGE, by = c(SEX, ARM)) |> rename_ard_groups_reverse() |> dplyr::select(all_ard_groups()) %>% `[`(1L, ) ) }) cards/tests/testthat/test-replace_null_statistic.R0000644000176200001440000000073714567176413022231 0ustar liggesuserstest_that("replace_null_statistic() works", { expect_error( ard_with_missing_stats <- data.frame(x = rep_len(NA_character_, 10)) |> ard_continuous( variables = x, statistic = ~ continuous_summary_fns(c("median", "p25", "p75")) ) |> replace_null_statistic(rows = !is.null(error)), NA ) # all results should now be NA_character expect_equal( ard_with_missing_stats$stat |> unlist() |> unique(), NA_character_ ) }) cards/tests/testthat/test-check_ard_structure.R0000644000176200001440000000040414620764501021476 0ustar liggesuserstest_that("check_ard_structure() works", { expect_snapshot( ard_continuous(ADSL, variables = "AGE") |> dplyr::mutate(stat = unlist(stat)) |> dplyr::select(-error) |> structure(class = "data.frame") |> check_ard_structure() ) }) cards/tests/testthat/test-nest_for_ard.R0000644000176200001440000000114514767020064020124 0ustar liggesuserstest_that("nest_for_ard() works", { expect_equal( nest_for_ard(mtcars, strata = c("cyl", "gear"), rename = TRUE) |> nrow(), 8L ) expect_equal( nest_for_ard(mtcars, rename = TRUE) |> nrow(), 1L ) expect_equal( nest_for_ard(mtcars, by = "am", strata = c("cyl", "gear"), rename = TRUE) |> nrow(), 16L ) # check order of lgl variables (see Issue #411) expect_equal( mtcars |> dplyr::mutate(am = as.logical(am)) |> nest_for_ard(by = "am", include_data = FALSE) |> dplyr::pull(group1_level) |> unlist(), c(FALSE, TRUE) ) }) cards/tests/testthat/test-print_ard_conditions.R0000644000176200001440000000734414752441547021710 0ustar liggesuserstest_that("print_ard_conditions() works", { # nothing prints with no errors/warnings expect_snapshot( ard_continuous(ADSL, variables = AGE) |> print_ard_conditions() ) # expected messaging without by variable expect_snapshot( ard_continuous( ADSL, variables = AGE, statistic = ~ list( mean = \(x) mean(x), mean_warning = \(x) { warning("warn1") warning("warn2") mean(x) }, err_fn = \(x) stop("'tis an error") ) ) |> print_ard_conditions() ) # expected messaging with by variable expect_snapshot( ard_continuous( ADSL, variables = AGE, by = ARM, statistic = ~ list( mean = \(x) mean(x), mean_warning = \(x) { warning("warn1") warning("warn2") mean(x) }, err_fn = \(x) stop("'tis an error") ) ) |> print_ard_conditions() ) # expected messaging when the same error appears for all stats (consolidated correctly) expect_snapshot( ard_continuous(ADSL, variables = AGE) |> dplyr::mutate(error = list("repeated error")) |> print_ard_conditions() ) # calling function name prints correctly expect_snapshot({ tbl_summary <- function() { set_cli_abort_call() ard <- ard_continuous( ADSL, variables = AGE, statistic = ~ list(err_fn = \(x) stop("'tis an error")) ) print_ard_conditions(ard) } tbl_summary() }) }) test_that("print_ard_conditions(condition_type)", { # expected warnings as warnings expect_snapshot( ard_continuous( ADSL, variables = AGE, statistic = ~ list(mean_warning = \(x) { warning("warn1") warning("warn2") mean(x) }) ) |> print_ard_conditions(condition_type = "identity") ) # expected warnings as warnings expect_snapshot( error = TRUE, ard_continuous( ADSL, variables = AGE, statistic = ~ list( mean = \(x) mean(x), err_fn = \(x) stop("'tis an error") ) ) |> print_ard_conditions(condition_type = "identity") ) }) test_that("print_ard_conditions() no error when 'error'/'warning' columns not present", { expect_snapshot( ard_continuous( ADSL, variables = AGE ) |> dplyr::select(-warning, -error) |> print_ard_conditions() ) }) test_that("print_ard_conditions() no error when factors are present", { ard <- structure(list( group1 = c("by_var", "by_var"), group1_level = list( structure(1L, levels = c("cohort_1", "cohort_2"), class = "factor"), structure(1L, levels = c("cohort_1", "cohort_2"), class = "factor") ), variable = c("continuous_var", "continuous_var"), variable_level = list( NULL, NULL ), context = c("continuous", "continuous"), stat_name = c("min", "max"), stat_label = c("Min", "Max"), stat = list(Inf, -Inf), fmt_fn = list(1L, 1L), warning = list( "no non-missing arguments to min; returning Inf", "no non-missing arguments to max; returning -Inf" ), error = list( NULL, NULL ) ), row.names = c(NA, -2L), class = c( "card", "tbl_df", "tbl", "data.frame" )) expect_snapshot( print_ard_conditions(ard) ) }) # See issue #309 test_that("print_ard_conditions() works when curly brackets appear in condition message", { # add a warning message that has curly brackets in it ard <- ard_continuous(ADSL, variables = AGE, statistic = ~ continuous_summary_fns("mean")) |> dplyr::mutate( warning = list("warning with {curly} brackets"), error = list("error with {curly} brackets") ) expect_snapshot( print_ard_conditions(ard) ) }) cards/tests/testthat/test-rename_ard_columns.R0000644000176200001440000000231114776252447021324 0ustar liggesuserstest_that("rename_ard_columns(columns)", { expect_equal( ADSL |> ard_categorical(by = ARM, variables = AGEGR1) |> rename_ard_columns() %>% `[`(1:2) |> names(), c("ARM", "AGEGR1") ) # testing stack output expect_silent( ard_stack <- ard_stack( ADSL, ard_categorical(variables = AGEGR1), .by = ARM ) |> rename_ard_columns() ) # check the overall ARM tabulations expect_equal( ard_stack |> dplyr::filter(is.na(AGEGR1)) |> dplyr::select(-AGEGR1), ard_categorical(ADSL, variables = ARM) |> rename_ard_columns() ) }) test_that("rename_ard_columns(columns) messsaging", { expect_snapshot( error = TRUE, ADSL |> ard_categorical(by = ARM, variables = AGEGR1) |> rename_ard_columns(columns = all_ard_groups()) ) expect_snapshot( error = TRUE, ADSL |> dplyr::rename(stat = AGEGR1) |> ard_categorical(by = ARM, variables = stat) |> rename_ard_columns() ) }) test_that("rename_ard_columns(unlist) lifecycle", { lifecycle::expect_deprecated( ADSL |> ard_categorical(by = ARM, variables = AGEGR1) |> rename_ard_columns(unlist = "stat") ) }) cards/tests/testthat/test-as_cards_fn.R0000644000176200001440000000035314721245334017720 0ustar liggesuserstest_that("as_cards_fn() works", { expect_silent( fn <- as_cards_fn(\(x) list(one = 1, two = 2), stat_names = c("one", "two")) ) expect_s3_class(fn, "cards_fn") expect_equal(get_cards_fn_stat_names(fn), c("one", "two")) }) cards/tests/testthat/test-ard_attributes.R0000644000176200001440000000160714677313136020503 0ustar liggesusersskip_if_not(is_pkg_installed("withr")) test_that("ard_attributes() works", { withr::local_options(list(width = 120)) expect_snapshot({ df <- dplyr::tibble(var1 = letters, var2 = LETTERS) attr(df$var1, "label") <- "Lowercase Letters" ard_attributes(df, variables = everything(), label = list(var2 = "UPPERCASE LETTERS")) |> as.data.frame() }) }) test_that("ard_attributes() errors when there is no dataframe", { expect_error( ard_attributes("test"), "There is no method for objects of class ." ) }) test_that("ard_attributes() follows ard structure", { expect_silent( ard_attributes(ADSL[c("AGE", "AGEGR1")]) |> check_ard_structure(method = FALSE) ) }) test_that("ard_attributes() requires label as a named list", { expect_snapshot( error = TRUE, ard_attributes(ADSL[c("AGE", "AGEGR1")], label = list("test") ) ) }) cards/tests/testthat/test-options.R0000644000176200001440000000227614753417324017164 0ustar liggesusersskip_if_not(is_pkg_installed("withr")) test_that("options(cards.round_type)", { # test that the p is rounded to zero (ie rounded to even) for aliases called by `apply_fmt_fn()` withr::local_options(list(cards.round_type = "round-to-even")) expect_equal( data.frame(x = c(T, F)) |> ard_categorical(variables = everything(), statistic = ~"p") |> update_ard_fmt_fn(stat_names = "p", fmt_fn = 0) |> apply_fmt_fn() |> dplyr::pull("stat_fmt") |> unique() |> unlist(), "0" ) # test that the p is rounded to zero (ie rounded to even) for default fmt functions expect_equal( data.frame(x = rep_len(TRUE, 1999) |> c(FALSE)) |> ard_categorical(variables = everything(), statistic = ~"p") |> apply_fmt_fn() |> dplyr::filter(variable_level %in% FALSE) |> dplyr::pull("stat_fmt") |> unlist(), "0.0" ) }) test_that("options(cards.round_type) messaging", { # test message when the option is the wrong value expect_snapshot( error = TRUE, withr::with_options( list(cards.round_type = "NOT-CORRECT"), data.frame(x = c(T, F)) |> ard_categorical(variables = everything(), statistic = ~"p") ) ) }) cards/tests/testthat/test-get_ard_statistics.R0000644000176200001440000000064514567176413021352 0ustar liggesuserstest_that("get_ard_statistics() works", { ard <- ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") expect_snapshot( get_ard_statistics( ard, group1_level %in% "Placebo", variable_level %in% "65-80" ) ) expect_snapshot( get_ard_statistics( ard, group1_level %in% "Placebo", variable_level %in% "65-80", .attributes = c("warning", "error") ) ) }) cards/tests/testthat/test-unlist_ard_columns.R0000644000176200001440000000276214776242611021375 0ustar liggesuserstest_that("unlist_ard_columns()", { expect_equal( ard_categorical(ADSL, variables = AGEGR1) |> unlist_ard_columns() |> dplyr::pull("stat") |> class(), "numeric" ) expect_equal( ard_categorical(ADSL, variables = AGEGR1) |> unlist_ard_columns() |> dplyr::pull("variable_level") |> class(), "character" ) expect_equal( ard_categorical(ADSL, variables = AGEGR1) |> unlist_ard_columns(columns = "error") |> dplyr::pull("error") |> unique(), NA ) }) test_that("unlist_ard_columns() messaging", { expect_message( ard_categorical(ADSL, variables = AGEGR1) |> dplyr::mutate( stat = ifelse(dplyr::row_number() == 1L, list(matrix(1:4)), stat) ) |> unlist_ard_columns(columns = "stat"), "Cannot unlist column" ) }) test_that("unlist_ard_columns(fct_as_chr)", { # check that a mixed-type column has factors converted to character by default. expect_true( cards::ADSL |> dplyr::mutate(ARM = factor(ARM)) |> ard_stack( ard_continuous(variables = AGE), .by = ARM ) |> unlist_ard_columns() |> dplyr::pull("group1_level") |> is.character() ) # check fct_to_chr = FALSE expect_true( cards::ADSL |> dplyr::mutate(ARM = factor(ARM)) |> ard_stack( ard_continuous(variables = AGE), .by = ARM ) |> unlist_ard_columns(fct_as_chr = FALSE) |> dplyr::pull("group1_level") |> is.integer() ) }) cards/tests/testthat/test-add_calculated_row.R0000644000176200001440000000172514721231721021255 0ustar liggesuserstest_that("add_calculated_row(x)", { expect_snapshot( ard_continuous(mtcars, variables = mpg) |> add_calculated_row(expr = max - min, stat_name = "range") |> apply_fmt_fn() ) expect_snapshot( ard_continuous(mtcars, variables = mpg) |> add_calculated_row( expr = dplyr::case_when( mean > median ~ "Right Skew", mean < median ~ "Left Skew", .default = "Symmetric" ), stat_name = "skew" ) |> apply_fmt_fn() ) }) test_that("add_calculated_row(expr) messaging", { expect_snapshot( ard_continuous(mtcars, variables = mpg) |> add_calculated_row(expr = not_a_stat * 2, stat_name = "this_doesnt_work"), error = TRUE ) }) test_that("add_calculated_row(by) messaging", { expect_snapshot( ard_continuous(mtcars, variables = mpg, by = cyl) |> add_calculated_row(expr = max - min, stat_name = "range", by = "context"), error = TRUE ) }) cards/tests/testthat/test-label_round.R0000644000176200001440000000056714753417324017760 0ustar liggesuserstest_that("label_round() works", { expect_equal( label_round(scale = 100, digits = 2)(9:10), c("900.00", "1000.00") ) expect_equal( label_round(digits = 2, width = 5)(9:10), c(" 9.00", "10.00") ) expect_equal( label_round()(NA), NA_character_ ) expect_equal( label_round(width = 5)(c(NA, 1)), c(NA_character_, " 1.0") ) }) cards/tests/testthat/test-mock.R0000644000176200001440000000515714754217517016426 0ustar liggesuserstest_that("mock_categorical()", { withr::local_options(list(width = 130)) expect_snapshot( mock_categorical( variables = list(AGEGR1 = factor(c("<65", "65-80", ">80"), levels = c("<65", "65-80", ">80"))), by = list(TRTA = c("Placebo", "Xanomeline High Dose", "Xanomeline Low Dose")) ) |> apply_fmt_fn() ) }) test_that("mock_categorical() messaging", { # incorrect specification of the statistic argument expect_snapshot( error = TRUE, mock_categorical( variables = list(AGEGR1 = factor(c("<65", "65-80", ">80"), levels = c("<65", "65-80", ">80"))), statistic = ~ c("NOTASTATISTIC") ) ) }) test_that("mock_continuous()", { withr::local_options(list(width = 130)) expect_snapshot( mock_continuous( variables = c("AGE", "BMIBL") ) |> apply_fmt_fn() ) }) test_that("mock_continuous() messaging", { # incorrect specification of the statistic argument expect_snapshot( error = TRUE, mock_continuous( variables = c("AGE", "BMIBL"), statistic = ~t.test ) ) }) test_that("mock_dichotomous()", { withr::local_options(list(width = 130)) expect_snapshot( mock_dichotomous( variables = list(AGEGR1 = factor("65-80", levels = c("<65", "65-80", ">80"))), by = list(TRTA = c("Placebo", "Xanomeline High Dose", "Xanomeline Low Dose")) ) |> apply_fmt_fn() ) }) test_that("mock_dichotomous() messaging", { # Specifying more than one value to summarize expect_snapshot( error = TRUE, mock_dichotomous( variables = list(AGEGR1 = factor(c("<65", "65-80", ">80"), levels = c("<65", "65-80", ">80"))), by = list(TRTA = c("Placebo", "Xanomeline High Dose", "Xanomeline Low Dose")) ) ) }) test_that("mock_missing()", { withr::local_options(list(width = 130)) expect_snapshot( mock_missing( variables = c("AGE", "BMIBL") ) |> apply_fmt_fn() ) }) test_that("mock_missing() messaging", { # incorrect specification of the statistic argument expect_snapshot( error = TRUE, mock_missing( variables = c("AGE", "BMIBL"), statistic = ~letters ) ) }) test_that("mock_attributes()", { withr::local_options(list(width = 130)) expect_snapshot( mock_attributes( label = list(AGE = "Age", BMIBL = "Baseline BMI") ) ) }) test_that("mock_attributes() messaging", { # incorrect specification of the label argument expect_snapshot( error = TRUE, mock_attributes(label = c("AGE", "BMIBL")) ) }) test_that("mock_total_n()", { withr::local_options(list(width = 130)) expect_snapshot( mock_total_n() |> apply_fmt_fn() ) }) cards/tests/testthat/test-as_nested_list.R0000644000176200001440000000022314567176413020463 0ustar liggesuserstest_that("as_nested_list() works", { expect_snapshot( ard_continuous(mtcars, by = "cyl", variables = "hp") |> as_nested_list() ) }) cards/tests/testthat/test-filter_ard_hierarchical.R0000644000176200001440000001207514767020056022275 0ustar liggesusersskip_on_cran() ADAE_subset <- cards::ADAE |> dplyr::filter(AETERM %in% unique(cards::ADAE$AETERM)[1:5]) ard <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL |> dplyr::mutate(TRTA = ARM), id = USUBJID, over_variables = TRUE ) test_that("filter_ard_hierarchical() works", { withr::local_options(width = 200) expect_silent(ard_f <- filter_ard_hierarchical(ard, n > 10)) expect_snapshot(ard_f) expect_equal(nrow(ard_f), 39) expect_silent(ard_f <- filter_ard_hierarchical(ard, p > 0.05)) expect_equal(nrow(ard_f), 171) }) test_that("filter_ard_hierarchical() works with non-standard filters", { expect_silent(ard_f <- filter_ard_hierarchical(ard, n == 2 & p < 0.05)) expect_equal(nrow(ard_f), 45) expect_silent(ard_f <- filter_ard_hierarchical(ard, sum(n) > 4)) expect_equal(nrow(ard_f), 144) expect_silent(ard_f <- filter_ard_hierarchical(ard, mean(n) > 4 | n > 3)) expect_equal(nrow(ard_f), 108) expect_silent(ard_f <- filter_ard_hierarchical(ard, any(n > 5 & TRTA == "Xanomeline High Dose"))) expect_equal(nrow(ard_f), 90) }) test_that("filter_ard_hierarchical() works with ard_stack_hierarchical_count() results", { withr::local_options(width = 200) ard <- ard_stack_hierarchical_count( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL |> dplyr::mutate(TRTA = ARM), over_variables = TRUE ) expect_silent(ard_f <- filter_ard_hierarchical(ard, n > 10)) expect_equal(nrow(ard_f), 32) expect_silent(ard_f <- filter_ard_hierarchical(ard, sum(n) > 15)) expect_equal(nrow(ard_f), 42) }) test_that("filter_ard_hierarchical() returns only summary rows when all rows filtered out", { ard <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, include = "AETERM", denominator = cards::ADSL |> dplyr::mutate(TRTA = ARM), id = USUBJID ) expect_silent(ard_f <- filter_ard_hierarchical(ard, n > 200)) expect_equal( ard_f, ard |> dplyr::filter(variable != "AETERM") ) expect_true(all(ard_f$variable == "TRTA")) }) test_that("filter_ard_hierarchical(keep_empty) works", { ard <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AEBODSYS, AETERM), by = TRTA, denominator = cards::ADSL |> dplyr::mutate(TRTA = ARM), id = USUBJID ) # keep summary rows expect_silent(ard_f <- filter_ard_hierarchical(ard, sum(n) > 10, keep_empty = TRUE)) expect_equal(nrow(ard_f), 270) # remove summary rows expect_silent(ard_f <- filter_ard_hierarchical(ard, sum(n) > 10)) expect_equal(nrow(ard_f), 153) # all inner rows removed (only header rows remain) expect_silent(ard_f <- filter_ard_hierarchical(ard, sum(n) > 1000)) expect_equal(nrow(ard_f), 9) ard_noincl <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AEBODSYS, AETERM), by = TRTA, denominator = cards::ADSL |> dplyr::mutate(TRTA = ARM), id = USUBJID, include = AETERM ) # no summary rows to remove expect_silent(ard_f <- filter_ard_hierarchical(ard_noincl, sum(n) > 10)) expect_silent(ard_f_keep <- filter_ard_hierarchical(ard_noincl, sum(n) > 10, keep_empty = TRUE)) expect_equal(nrow(ard_f), 72) expect_identical(ard_f, ard_f_keep) }) test_that("filter_ard_hierarchical() works with only one variable in x", { ard_single <- ard_stack_hierarchical( data = ADAE_subset, variables = AETERM, by = TRTA, denominator = cards::ADSL |> dplyr::mutate(TRTA = ARM), id = USUBJID ) expect_silent(ard_single <- filter_ard_hierarchical(ard_single, n > 20)) expect_equal(nrow(ard_single), 15) }) test_that("filter_ard_hierarchical() works when some variables not included in x", { ard <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL |> dplyr::mutate(TRTA = ARM), id = USUBJID, include = c(SEX, AETERM), over_variables = TRUE ) expect_silent(filter_ard_hierarchical(ard, n > 10)) }) test_that("filter_ard_hierarchical() works with overall data", { ard_overall <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL |> dplyr::mutate(TRTA = ARM), id = USUBJID, over_variables = TRUE, overall = TRUE ) expect_equal( ard_overall |> filter_ard_hierarchical(n > 5) |> nrow(), ard |> filter_ard_hierarchical(n > 5) |> nrow() ) }) test_that("filter_ard_hierarchical() error messaging works", { # invalid x input expect_snapshot( filter_ard_hierarchical(ard_categorical(ADSL, by = "ARM", variables = "AGEGR1"), n > 10), error = TRUE ) # invalid filter input expect_snapshot( filter_ard_hierarchical(ard, 10), error = TRUE ) # invalid filter parameters expect_snapshot( filter_ard_hierarchical(ard, A > 5), error = TRUE ) # invalid keep_empty input expect_snapshot( filter_ard_hierarchical(ard, n > 1, keep_empty = NULL), error = TRUE ) }) cards/tests/testthat/test-ard_dichotomous.R0000644000176200001440000000520614675616454020660 0ustar liggesuserstest_that("ard_dichotomous() works", { expect_error( ard_dich <- ard_dichotomous( mtcars |> dplyr::mutate(gear = factor(gear), am = as.logical(am)), variables = c("cyl", "am", "gear"), value = list(cyl = 4) ), NA ) expect_snapshot(class(ard_dich)) expect_equal( ard_categorical( mtcars, variables = cyl ) |> dplyr::filter(variable_level %in% 4) |> dplyr::select(-context), ard_dich |> dplyr::filter(variable %in% "cyl", variable_level %in% 4) |> dplyr::select(-context) ) expect_equal( ard_categorical( mtcars |> dplyr::mutate(am = as.logical(am)), variables = am ) |> dplyr::filter(variable_level %in% TRUE) |> dplyr::select(-context), ard_dich |> dplyr::filter(variable %in% "am", variable_level %in% TRUE) |> dplyr::select(-context) ) expect_snapshot( ard_dich |> dplyr::select(-c(fmt_fn, warning, error)) |> as.data.frame() ) }) test_that("ard_dichotomous() works", { expect_snapshot( ard_dichotomous( mtcars, variables = c("cyl", "am", "gear"), value = list(cyl = letters) ), error = TRUE ) expect_snapshot( ard_dichotomous( iris, variables = everything(), value = list(Species = "not_a_species") ), error = TRUE ) expect_snapshot( ard_dichotomous( mtcars, variables = c("cyl", "am", "gear"), value = list(cyl = 100) ), error = TRUE ) }) test_that("ard_dichotomous() with grouped data works", { expect_equal( mtcars |> dplyr::group_by(vs) |> ard_dichotomous(variables = c(cyl, am), value = list(cyl = 4)), ard_dichotomous( data = mtcars, by = vs, variables = c(cyl, am), value = list(cyl = 4) ) ) }) test_that("ard_dichotomous() follows ard structure", { expect_silent( mtcars |> dplyr::group_by(vs) |> ard_dichotomous(variables = c(cyl, am), value = list(cyl = 4)) |> check_ard_structure(method = FALSE) ) }) test_that("ard_dichotomous() errors with incomplete factor columns", { # Check error when factors have no levels expect_snapshot( error = TRUE, mtcars |> dplyr::mutate(am = factor(am, levels = character(0))) |> ard_dichotomous( variables = c(cyl, vs), by = am, value = list(cyl = 4) ) ) # Check error when factor has NA level expect_snapshot( error = TRUE, mtcars |> dplyr::mutate(am = factor(am, levels = c(0, 1, NA), exclude = NULL)) |> ard_dichotomous( variables = c(cyl, am), value = list(cyl = 4) ) ) }) cards/tests/testthat/test-ard_hierarchical.R0000644000176200001440000002206014754702430020722 0ustar liggesusers# ard_hierarchical() ----------------------------------------------------------- test_that("ard_hierarchical() works without by variables", { expect_error( ard_heir_no_by <- ard_hierarchical( data = ADAE, variables = c(AESOC, AEDECOD), denominator = ADSL ), NA ) expect_snapshot(class(ard_heir_no_by)) expect_equal( ard_heir_no_by |> dplyr::filter(group1_level == "CARDIAC DISORDERS", variable_level == "ATRIAL FIBRILLATION") |> get_ard_statistics(.attributes = NULL), dplyr::tibble( n = ADAE |> dplyr::filter(AESOC == "CARDIAC DISORDERS", AEDECOD == "ATRIAL FIBRILLATION") |> nrow(), N = nrow(ADSL), p = n / N ) |> as.list() ) }) test_that("ard_hierarchical() works with by variable", { expect_error( ard_heir_with_by <- ard_hierarchical( data = ADAE, variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL |> dplyr::rename(TRTA = ARM) ), NA ) expect_equal( ard_heir_with_by |> dplyr::filter(group1_level == "Placebo", group2_level == "CARDIAC DISORDERS", variable_level == "ATRIAL FIBRILLATION") |> get_ard_statistics(.attributes = NULL), dplyr::tibble( n = ADAE |> dplyr::filter(TRTA == "Placebo", AESOC == "CARDIAC DISORDERS", AEDECOD == "ATRIAL FIBRILLATION") |> nrow(), N = ADSL |> dplyr::filter(ARM == "Placebo") |> nrow(), p = n / N ) |> as.list() ) }) test_that("ard_hierarchical() works with by variable not present in 'denominator'", { expect_error( ard_heir_with_by <- ard_hierarchical( data = ADAE, variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV), denominator = ADSL |> dplyr::rename(TRTA = ARM) ), NA ) expect_equal( ard_heir_with_by |> dplyr::filter( group1_level == "Placebo", group2_level == "MILD", group3_level == "CARDIAC DISORDERS", variable_level == "ATRIAL HYPERTROPHY" ) |> get_ard_statistics(.attributes = NULL), dplyr::tibble( n = ADAE |> dplyr::filter( TRTA == "Placebo", AESEV == "MILD", AESOC == "CARDIAC DISORDERS", AEDECOD == "ATRIAL HYPERTROPHY" ) |> nrow(), N = ADSL |> dplyr::filter(ARM == "Placebo") |> nrow(), p = n / N ) |> as.list() ) }) test_that("ard_hierarchical() works without any variables", { expect_snapshot( ard_hierarchical( data = ADAE, variables = starts_with("xxxx"), by = c(TRTA, AESEV) ) ) }) test_that("ard_hierarchical(id) argument works", { expect_snapshot( ard_hierarchical( data = ADAE, variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV), denominator = ADSL |> dplyr::rename(TRTA = ARM), id = USUBJID ) |> head(1L) ) # testing pluralization works in warning message expect_snapshot( ard_hierarchical( data = ADAE, variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV), denominator = ADSL |> dplyr::rename(TRTA = ARM), id = c(USUBJID, SITEID) ) |> head(1L) ) }) # ard_hierarchical_count() ----------------------------------------------------- test_that("ard_hierarchical_count() works without by variables", { expect_error( ard_heir_no_by <- ard_hierarchical_count( data = ADAE, variables = c(AESOC, AEDECOD) ), NA ) expect_snapshot(class(ard_heir_no_by)) expect_equal( ard_heir_no_by |> dplyr::filter(group1_level == "CARDIAC DISORDERS", variable_level == "ATRIAL FIBRILLATION") |> get_ard_statistics(.attributes = NULL), list( n = ADAE |> dplyr::filter(AESOC == "CARDIAC DISORDERS", AEDECOD == "ATRIAL FIBRILLATION") |> nrow() ) ) expect_equal( ard_hierarchical_count( data = ADAE, variables = AESOC ) |> dplyr::filter(variable == "AESOC", variable_level == "CARDIAC DISORDERS") |> get_ard_statistics(.attributes = NULL), list( n = ADAE |> dplyr::filter(AESOC == "CARDIAC DISORDERS") |> nrow() ) ) }) test_that("ard_hierarchical_count() works with by variable", { expect_error( ard_heir_with_by <- ard_hierarchical_count( data = ADAE, variables = c(AESOC, AEDECOD), by = TRTA ), NA ) expect_equal( ard_heir_with_by |> dplyr::filter( group1_level == "Placebo", group2_level == "CARDIAC DISORDERS", variable_level == "ATRIAL HYPERTROPHY" ) |> get_ard_statistics(.attributes = NULL), list( n = ADAE |> dplyr::filter(TRTA == "Placebo", AESOC == "CARDIAC DISORDERS", AEDECOD == "ATRIAL HYPERTROPHY") |> nrow() ) ) }) test_that("ard_hierarchical_count() works with by variable not present in 'denominator'", { expect_error( ard_heir_with_by <- ard_hierarchical_count( data = ADAE, variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV) ), NA ) expect_equal( ard_heir_with_by |> dplyr::filter( group1_level == "Placebo", group2_level == "MILD", group3_level == "CARDIAC DISORDERS", variable_level == "ATRIAL HYPERTROPHY" ) |> get_ard_statistics(.attributes = NULL), list( n = ADAE |> dplyr::filter( TRTA == "Placebo", AESEV == "MILD", AESOC == "CARDIAC DISORDERS", AEDECOD == "ATRIAL HYPERTROPHY" ) |> nrow() ) ) }) test_that("ard_hierarchical_count() works without any variables", { expect_snapshot( ard_hierarchical_count( data = ADAE, variables = starts_with("xxxx"), by = c(TRTA, AESEV) ) ) }) test_that("ard_hierarchical() and ard_hierarchical_count() with grouped data works", { expect_equal( ADAE |> dplyr::group_by(TRTA) |> ard_hierarchical( variables = c(AESOC, AEDECOD), denominator = ADSL |> dplyr::rename(TRTA = ARM) ), ard_hierarchical( data = ADAE, by = TRTA, variables = c(AESOC, AEDECOD), denominator = ADSL |> dplyr::rename(TRTA = ARM) ) ) expect_equal( ADAE |> dplyr::group_by(TRTA) |> ard_hierarchical_count( variables = c(AESOC, AEDECOD) ), ard_hierarchical_count( data = ADAE, by = TRTA, variables = c(AESOC, AEDECOD) ) ) }) test_that("ard_hierarchical() follows ard structure", { expect_silent( ADAE |> dplyr::group_by(TRTA) |> ard_hierarchical_count( variables = c(AESOC, AETERM) ) |> check_ard_structure(method = FALSE) ) }) test_that("ard_hierarchical() errors with incomplete factor columns", { # Check error when factors have no levels expect_snapshot( error = TRUE, mtcars |> dplyr::mutate(am = factor(am, levels = character(0))) |> ard_hierarchical( variables = c(vs, am) ) ) # Check error when factor has NA level expect_snapshot( error = TRUE, mtcars |> dplyr::mutate(am = factor(am, levels = c(0, 1, NA), exclude = NULL)) |> ard_hierarchical( variables = c(vs, am) ) ) }) test_that("ard_hierarchical_count() errors with incomplete factor columns", { # Check error when factors have no levels expect_snapshot( error = TRUE, mtcars |> dplyr::mutate(am = factor(am, levels = character(0))) |> ard_hierarchical_count( variables = c(vs, am) ) ) # Check error when factor has NA level expect_snapshot( error = TRUE, mtcars |> dplyr::mutate(am = factor(am, levels = c(0, 1, NA), exclude = NULL)) |> ard_hierarchical_count( variables = c(vs, am) ) ) }) test_that("ard_hierarchical_count() provides correct results with 10+ groups", { skip_if_not(is_pkg_installed("withr")) withr::local_seed(1) expect_silent( ard <- data.frame( x1 = sample(LETTERS[1:2], 30, replace = TRUE), x2 = sample(LETTERS[3:4], 30, replace = TRUE), x3 = sample(LETTERS[5:6], 30, replace = TRUE), x4 = sample(LETTERS[7:8], 30, replace = TRUE), x5 = sample(LETTERS[9:10], 30, replace = TRUE), x6 = sample(LETTERS[11:12], 30, replace = TRUE), x7 = sample(LETTERS[13:14], 30, replace = TRUE), x8 = sample(LETTERS[15:16], 30, replace = TRUE), x9 = sample(LETTERS[17:18], 30, replace = TRUE), x10 = sample(LETTERS[19:20], 30, replace = TRUE) ) %>% ard_hierarchical_count(data = ., variables = names(.)) ) expect_equal( dplyr::select(ard, all_ard_groups(), all_ard_variables()) |> names(), c( "group1", "group1_level", "group2", "group2_level", "group3", "group3_level", "group4", "group4_level", "group5", "group5_level", "group6", "group6_level", "group7", "group7_level", "group8", "group8_level", "group9", "group9_level", "variable", "variable_level" ) ) expect_equal(ard[["variable"]][[1]], "x10") }) cards/tests/testthat/test-ard_total_n.R0000644000176200001440000000047614675422777017772 0ustar liggesuserstest_that("ard_total_n() works", { expect_snapshot( ard_total_n(ADSL) |> as.data.frame() ) expect_snapshot( error = TRUE, ard_total_n(letters) ) }) test_that("ard_total_n() follows ard structure", { expect_silent( ard_total_n(ADSL) |> check_ard_structure(method = FALSE) ) }) cards/tests/testthat/test-tidy_ard_column_order.R0000644000176200001440000000246714754702430022036 0ustar liggesuserstest_that("tidy_ard_column_order() works", { skip_if_not(is_pkg_installed("withr")) withr::local_seed(1) # ensure 10+ groups are ordered correctly expect_equal( data.frame( x1 = sample(LETTERS[1:2], 30, replace = TRUE), x2 = sample(LETTERS[3:4], 30, replace = TRUE), x3 = sample(LETTERS[5:6], 30, replace = TRUE), x4 = sample(LETTERS[7:8], 30, replace = TRUE), x5 = sample(LETTERS[9:10], 30, replace = TRUE), x6 = sample(LETTERS[11:12], 30, replace = TRUE), x7 = sample(LETTERS[13:14], 30, replace = TRUE), x8 = sample(LETTERS[15:16], 30, replace = TRUE), x9 = sample(LETTERS[17:18], 30, replace = TRUE), x10 = sample(LETTERS[19:20], 30, replace = TRUE), dummy = 1L ) |> ard_categorical( variables = "dummy", strata = x1:x10, statistic = everything() ~ "n" ) |> dplyr::select(all_ard_groups(), all_ard_variables()) |> names(), c( "group1", "group1_level", "group2", "group2_level", "group3", "group3_level", "group4", "group4_level", "group5", "group5_level", "group6", "group6_level", "group7", "group7_level", "group8", "group8_level", "group9", "group9_level", "group10", "group10_level", "variable", "variable_level" ) ) }) cards/tests/testthat/test-ard_strata.R0000644000176200001440000000162314754224633017610 0ustar liggesuserstest_that("ard_strata() works", { expect_snapshot( ard_strata( ADSL, .by = ARM, .f = ~ ard_continuous(.x, variables = AGE) ) ) expect_snapshot( ard_strata( ADSL, .strata = ARM, .f = ~ ard_continuous(.x, variables = AGE, by = AGEGR1) ) ) expect_equal( ard_strata(ADSL, .by = ARM, .f = ~ ard_continuous(.x, by = c(SEX, AGEGR1), variables = AGE)) |> tidy_ard_column_order() |> tidy_ard_row_order(), ard_continuous(ADSL, by = c(SEX, AGEGR1, ARM), variables = AGE) |> tidy_ard_row_order() ) }) test_that("ard_strata(by,strata) when both empty", { expect_equal( ard_strata(ADSL, .f = ~ ard_continuous(.x, variables = AGE)), ard_continuous(ADSL, variables = AGE) ) expect_equal( ard_strata(ADSL, .f = ~ ard_continuous(.x, by = ARM, variables = AGE)), ard_continuous(ADSL, by = ARM, variables = AGE) ) }) cards/tests/testthat/test-tidy_ard_row_order.R0000644000176200001440000000120514754404330021333 0ustar liggesuserstest_that("tidy_ard_row_order() works", { skip_if_not(is_pkg_installed("withr")) withr::local_options(list(width = 120)) withr::local_seed(1) # ensure rows are ordered within descending groups but not variables expect_snapshot( data.frame( x1 = sample(LETTERS[1:5], 30, replace = TRUE), x2 = sample(LETTERS[6:10], 30, replace = TRUE), x3 = sample(LETTERS[11:15], 30, replace = TRUE), zz = 1L, aa = 1L ) |> ard_categorical( by = x1:x3, variables = c(zz, aa), statistic = everything() ~ "n" ) |> dplyr::select(all_ard_groups(), all_ard_variables()) ) }) cards/tests/testthat/test-ard_complex.R0000644000176200001440000001155414721250550017754 0ustar liggesuserstest_that("ard_complex() works", { # we can replicate `ard_continuous()` for univariate analysis # using the `x` arg in the mean function expect_equal( ard_complex( ADSL, by = "ARM", variables = "AGE", statistic = list(AGE = list(mean = \(x, ...) mean(x))) ) |> dplyr::select(all_ard_groups(), all_ard_variables(), stat), ard_continuous( ADSL, by = "ARM", variables = "AGE", statistic = ~ continuous_summary_fns("mean") ) |> dplyr::select(all_ard_groups(), all_ard_variables(), stat) ) # using the `data` and `variable` args in the mean function expect_equal( ard_complex( ADSL, by = "ARM", variables = "AGE", statistic = list(AGE = list(mean = \(data, variable, ...) mean(data[[variable]]))) ) |> dplyr::select(all_ard_groups(), all_ard_variables(), stat), ard_continuous( ADSL, by = "ARM", variables = "AGE", statistic = ~ continuous_summary_fns("mean") ) |> dplyr::select(all_ard_groups(), all_ard_variables(), stat) ) # test a function using `data` and `full_data` arguments expect_error( { grand_mean <- function(data, full_data, variable, ...) { list( mean = mean(data[[variable]], na.rm = TRUE), grand_mean = mean(full_data[[variable]], na.rm = TRUE) ) } ard_grand_mean <- ard_complex( ADSL, by = "ARM", variables = "AGE", statistic = list(AGE = list(means = grand_mean)) ) |> as.data.frame() |> dplyr::select(all_ard_groups(), all_ard_variables(), stat_name, stat) }, NA ) expect_equal( ard_grand_mean |> dplyr::filter(stat_name %in% "grand_mean") |> dplyr::pull(stat) |> unique() |> getElement(1L), mean(ADSL$AGE) ) expect_equal( ard_grand_mean |> as.data.frame() |> dplyr::filter(stat_name %in% "mean") |> dplyr::mutate(across(c(group1_level, stat), unlist)) |> dplyr::select(group1_level, stat), ADSL |> dplyr::summarise( .by = "ARM", stat = mean(AGE) ) |> dplyr::rename(group1_level = ARM) |> as.data.frame(), ignore_attr = TRUE ) }) test_that("ard_complex() messaging", { # correct messaging when BMIBL doesn't have any summary fns expect_snapshot( error = TRUE, ard_complex( ADSL, by = "ARM", variables = c("AGE", "BMIBL"), statistic = list(AGE = list(mean = \(x, ...) mean(x))) ) ) }) test_that("ard_complex() with grouped data works", { expect_equal( ADSL |> dplyr::group_by(ARM) |> ard_complex( variables = c("AGE", "BMIBL"), statistic = ~ list(mean = \(x, ...) mean(x)) ), ard_complex( data = ADSL, by = "ARM", variables = c("AGE", "BMIBL"), statistic = ~ list(mean = \(x, ...) mean(x)) ) ) }) test_that("ard_complex() follows ard structure", { expect_silent( ard_complex( ADSL, by = "ARM", variables = "AGE", statistic = list(AGE = list(mean = \(x, ...) mean(x))) ) |> check_ard_structure(method = FALSE) ) }) test_that("ard_complex() errors with incorrect factor columns", { # Check error when factors have no levels expect_snapshot( error = TRUE, mtcars |> dplyr::mutate(am = factor(am, levels = character(0))) |> ard_complex( by = "am", variables = "mpg", statistic = list(mpg = list(mean = \(x, ...) mean(x))) ) ) # Check error when factor has NA level expect_snapshot( error = TRUE, mtcars |> dplyr::mutate(am = factor(am, levels = c(0, 1, NA), exclude = NULL)) |> ard_complex( by = "am", variables = "mpg", statistic = list(mpg = list(mean = \(x, ...) mean(x))) ) ) }) test_that("ard_complex() with `as_cards_fn()` inputs", { ttest_works <- as_cards_fn( \(x, data, ...) t.test(x ~ data$am)[c("statistic", "p.value")], stat_names = c("statistic", "p.value") ) ttest_error <- as_cards_fn( \(x, data, ...) { t.test(x ~ data$am)[c("statistic", "p.value")] stop("Intentional Error") }, stat_names = c("statistic", "p.value") ) # the result is the same when there is no error expect_equal( ard_complex(mtcars, variables = mpg, statistic = ~ list(ttest = ttest_works)), ard_complex(mtcars, variables = mpg, statistic = ~ list(ttest = \(x, data, ...) t.test(x ~ data$am)[c("statistic", "p.value")])) ) # when there is an error, we get the same structure back expect_equal( ard_complex(mtcars, variables = mpg, statistic = ~ list(ttest = ttest_error)) |> dplyr::pull("stat_name"), ard_complex(mtcars, variables = mpg, statistic = ~ list(ttest = \(x, data, ...) t.test(x ~ data$am)[c("statistic", "p.value")])) |> dplyr::pull("stat_name") ) }) cards/tests/testthat/test-ard_stack.R0000644000176200001440000001635414776252447017436 0ustar liggesuserstest_that("ard_stack() works", { # with by variable expect_error( ard1 <- ard_stack( data = mtcars, .by = "cyl", ard_continuous(variables = "mpg"), ard_dichotomous(variables = "vs") ), NA ) expect_equal( ard1, bind_ard( ard_continuous(data = mtcars, by = "cyl", variables = "mpg"), ard_dichotomous(data = mtcars, by = "cyl", variables = "vs"), ard_categorical(data = mtcars, variables = "cyl"), .order = TRUE ), ignore_function_env = TRUE ) # check equivalency NSE expect_equal( ard1, ard_stack( data = mtcars, .by = cyl, ard_continuous(variables = mpg), ard_dichotomous(variables = vs) ), ignore_function_env = TRUE ) # check equivalency tidyselect mtcars2 <- mtcars by <- "cyl" var_cont <- "mpg" var_cat <- "vs" expect_equal( ard1, ard_stack( data = mtcars2, .by = all_of(by), ard_continuous(variables = all_of(var_cont)), ard_dichotomous(variables = all_of(var_cat)) ) ) # without by variable expect_error( ard2 <- ard_stack( data = mtcars, .by = NULL, ard_continuous(variables = "mpg"), ard_dichotomous(variables = "vs") ), NA ) expect_equal( ard2, bind_ard( ard_continuous(data = mtcars, variables = "mpg"), ard_dichotomous(data = mtcars, variables = "vs"), .order = TRUE ), ignore_function_env = TRUE ) expect_equal( ard2, ard_stack( data = mtcars2, ard_continuous(variables = all_of(var_cont)), ard_dichotomous(variables = all_of(var_cat)) ) ) }) test_that("ard_stack() adding overalls", { expect_error( ard_test <- ard_stack( data = mtcars, .by = "cyl", ard_continuous(variables = "mpg"), ard_dichotomous(variables = "vs"), .overall = TRUE ), NA ) expect_equal( ard_test, bind_ard( ard_continuous(data = mtcars, by = "cyl", variables = "mpg"), ard_dichotomous(data = mtcars, by = "cyl", variables = "vs"), ard_continuous(data = mtcars, variables = "mpg"), ard_dichotomous(data = mtcars, variables = "vs"), ard_categorical(data = mtcars, variables = "cyl"), .update = TRUE, .order = TRUE ) ) }) test_that("ard_stack() adding missing/attributes", { expect_error( ard_test <- ard_stack( data = mtcars, .by = "cyl", ard_continuous(variables = "mpg"), ard_dichotomous(variables = "vs"), .missing = TRUE, .attributes = TRUE ), NA ) expect_equal( ard_test, bind_ard( ard_continuous(data = mtcars, by = "cyl", variables = "mpg"), ard_dichotomous(data = mtcars, by = "cyl", variables = "vs"), ard_missing(data = mtcars, by = "cyl", variables = c("mpg", "vs")), ard_categorical(data = mtcars, variables = "cyl"), ard_attributes(mtcars, variables = c("mpg", "vs", "cyl")), .update = TRUE, .order = TRUE ) ) # including `.overall=TRUE` expect_error( ard_test_overall <- ard_stack( data = mtcars, .by = "cyl", ard_continuous(variables = "mpg"), ard_dichotomous(variables = "vs"), .missing = TRUE, .overall = TRUE, .attributes = TRUE ), NA ) expect_equal( ard_test_overall, bind_ard( ard_continuous(data = mtcars, by = "cyl", variables = "mpg"), ard_dichotomous(data = mtcars, by = "cyl", variables = "vs"), ard_missing(data = mtcars, by = "cyl", variables = c("mpg", "vs")), ard_continuous(data = mtcars, variables = "mpg"), ard_dichotomous(data = mtcars, variables = "vs"), ard_categorical(data = mtcars, variables = "cyl"), ard_missing(data = mtcars, variables = c("mpg", "vs")), ard_attributes(mtcars, variables = c("mpg", "vs", "cyl")), .update = TRUE, .order = TRUE ) ) }) test_that("ard_stack() .shuffle argument", { expect_error( ard_test <- ard_stack( data = mtcars, .by = "cyl", ard_continuous(variables = "mpg"), ard_dichotomous(variables = "vs"), .shuffle = TRUE ), NA ) expect_equal( ard_test, bind_ard( ard_continuous(data = mtcars, by = "cyl", variables = "mpg"), ard_dichotomous(data = mtcars, by = "cyl", variables = "vs"), ard_categorical(data = mtcars, variables = "cyl"), .order = TRUE ) |> shuffle_ard() ) # with overalls expect_error( ard_test <- ard_stack( data = mtcars, .by = "cyl", ard_continuous(variables = "mpg"), ard_dichotomous(variables = "vs"), .shuffle = TRUE, .overall = TRUE ), NA ) expect_equal( ard_test, bind_ard( ard_continuous(data = mtcars, by = "cyl", variables = "mpg"), ard_dichotomous(data = mtcars, by = "cyl", variables = "vs"), ard_continuous(data = mtcars, variables = "mpg"), ard_dichotomous(data = mtcars, variables = "vs"), ard_categorical(data = mtcars, variables = "cyl") ) |> shuffle_ard() ) }) test_that("ard_stack() adding total N", { expect_equal( ard_stack( mtcars, .by = am, ard_continuous(variables = mpg), .total_n = TRUE ) |> tail(n = 1) |> dplyr::select(-all_ard_groups(), -all_ard_variables("levels")), ard_total_n(mtcars) ) }) test_that("ard_stack() works with namespaced functions", { expect_equal( ard_stack( data = mtcars, cards::ard_continuous(variables = "mpg") ), ard_stack( data = mtcars, ard_continuous(variables = "mpg") ) ) }) test_that("ard_stack() messaging", { withr::local_options(list(width = 150)) expect_snapshot( ard_stack( data = mtcars, ard_continuous(variables = "mpg"), .overall = TRUE ) |> head(1L) ) # by argument doesn't include period in front expect_snapshot( error = TRUE, ard_stack(ADSL, by = "ARM", ard_continuous(variables = AGE)) ) }) test_that("ard_stack() complex call error", { withr::local_options(list(width = 150)) expect_snapshot( { complex_call <- list() complex_call$ard_continuous <- ard_continuous ard_stack( data = mtcars, .by = am, complex_call$ard_continuous(variables = "mpg"), ) }, error = TRUE ) }) test_that("ard_stack() follows ard structure", { expect_silent( ard_stack( data = mtcars, .by = "cyl", ard_continuous(variables = "mpg"), ard_dichotomous(variables = "vs") ) |> check_ard_structure(method = FALSE) ) }) test_that("ard_stack(.by) messaging", { withr::local_options(list(width = 150)) mtcars2 <- mtcars mtcars2$am[1] <- NA mtcars2$vs[1] <- NA expect_snapshot( mtcars2 |> ard_stack( ard_continuous(variables = "mpg", statistic = ~ continuous_summary_fns("N")), .by = c(am, vs), .total_n = TRUE, .overall = TRUE ) |> dplyr::filter(stat_name %in% "N") ) mtcars3 <- mtcars mtcars3$am[1] <- NA mtcars3$vs[2] <- NaN expect_snapshot( mtcars3 |> ard_stack( ard_continuous(variables = "mpg", statistic = ~ continuous_summary_fns("N")), .by = c(am, vs), .total_n = TRUE, .overall = TRUE ) |> dplyr::filter(stat_name %in% "N") ) }) cards/tests/testthat/test-ard_formals.R0000644000176200001440000000051114770630401017740 0ustar liggesuserstest_that("ard_formals() works", { expect_snapshot( ard_formals(fun = mcnemar.test, arg_names = "correct") ) expect_snapshot( ard_formals( fun = asNamespace("stats")[["t.test.default"]], arg_names = c("mu", "paired", "var.equal", "conf.level"), passed_args = list(conf.level = 0.90) ) ) }) cards/tests/testthat/test-update_ard.R0000644000176200001440000000524614752422675017605 0ustar liggesuserstest_that("update_ard_fmt_fn()", { expect_equal( ard_continuous(ADSL, variables = AGE) |> update_ard_fmt_fn(stat_names = c("mean", "sd"), fmt_fn = 8L) |> apply_fmt_fn() |> dplyr::filter(stat_name %in% c("mean", "sd")) |> dplyr::pull("stat_fmt") |> unlist(), c("75.08661417", "8.24623390") ) expect_snapshot( error = TRUE, ard_continuous(ADSL, variables = AGE) |> update_ard_fmt_fn(stat_names = c("mean", "sd"), fmt_fn = -8L) ) }) test_that("update_ard_fmt_fn(filter)", { # apply update to the Placebo level expect_snapshot( ard_continuous(ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean"))) |> update_ard_fmt_fn(stat_names = "mean", fmt_fn = 8L, filter = group1_level == "Placebo") |> apply_fmt_fn() ) }) test_that("update_ard_fmt_fn(filter) messaging", { # test error messaging expect_snapshot( error = TRUE, ard_continuous(ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean"))) |> update_ard_fmt_fn(stat_names = "mean", fmt_fn = 8L, filter = group99999999_level == "Placebo") ) expect_snapshot( error = TRUE, ard_continuous(ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean"))) |> update_ard_fmt_fn(stat_names = "mean", fmt_fn = 8L, filter = c(TRUE, FALSE)) ) }) test_that("update_ard_stat_label()", { expect_equal( ard_continuous(ADSL, variables = AGE) |> update_ard_stat_label(stat_names = c("mean", "sd"), stat_label = "Mean (SD)") |> apply_fmt_fn() |> dplyr::filter(stat_name %in% c("mean", "sd")) |> dplyr::pull("stat_label") |> unlist() |> unique(), "Mean (SD)" ) }) test_that("update_ard_stat_label(filter)", { # apply update to the Placebo level expect_snapshot( ard_continuous(ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean", "sd"))) |> update_ard_stat_label(stat_names = c("mean", "sd"), stat_label = "Mean (SD)", filter = group1_level == "Placebo") ) }) test_that("update_ard_stat_label(filter) messaging", { # test error messaging expect_snapshot( error = TRUE, ard_continuous(ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean", "sd"))) |> update_ard_stat_label(stat_names = c("mean", "sd"), stat_label = "Mean (SD)", filter = group99999999_level == "Placebo") ) expect_snapshot( error = TRUE, ard_continuous(ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean", "sd"))) |> update_ard_stat_label(stat_names = c("mean", "sd"), stat_label = "Mean (SD)", filter = c(TRUE, FALSE)) ) }) cards/tests/testthat/test-round5.R0000644000176200001440000000076114567176413016706 0ustar liggesuserstest_that("round5() works", { expect_snapshot({ x <- seq.int(-10L, 10L, by = 1L) / 2 x <- x[x %% 1 != 0] # remove integers round5(x) |> setNames(nm = x) }) expect_snapshot({ x <- seq.int(-100000L, 100000L, by = 10000L) - 1L / 2L x <- x[x %% 1 != 0] # remove integers round5(x) |> setNames(nm = x) }) expect_snapshot({ x <- seq.int(-100000L, 100000L, by = 10000L) + 1L / 2L x <- x[x %% 1 != 0] # remove integers round5(x) |> setNames(nm = x) }) }) cards/tests/testthat/test-ard_pairwise.R0000644000176200001440000000604014721513741020126 0ustar liggesusersttest_fn <- \(x, data, ...) t.test(x ~ data$ARM)[c("statistic", "p.value")] test_that("ard_pairwise() works", { expect_silent( lst_ard <- ard_pairwise( ADSL, variable = ARM, .f = \(df) ard_complex(df, variables = AGE, statistic = ~ list(ttest = ttest_fn)), include = "Placebo" # only include comparisons to the "Placebo" group ) ) expect_length(lst_ard, 2L) expect_equal( lst_ard[["'Placebo' vs. 'Xanomeline High Dose'"]], ard_complex( ADSL |> dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")), variables = AGE, statistic = ~ list(ttest = ttest_fn) ) ) expect_equal( lst_ard[["'Placebo' vs. 'Xanomeline Low Dose'"]], ard_complex( ADSL |> dplyr::filter(ARM %in% c("Placebo", "Xanomeline Low Dose")), variables = AGE, statistic = ~ list(ttest = ttest_fn) ) ) }) test_that("ard_pairwise(variable)", { # we get expected results with unobserved factor levels expect_silent( lst_ard <- data.frame( ARM = rep_len("Placebo", 20L) |> factor(levels = c("Placebo", "Unobserved Level")), AGE = 1:20 ) |> ard_pairwise( variable = ARM, .f = \(df) ard_complex(df, variables = AGE, statistic = ~ list(ttest = ttest_fn)) ) ) expect_equal(names(lst_ard), "'Placebo' vs. 'Unobserved Level'") expect_s3_class(lst_ard[[1]], "card") expect_equal(nrow(lst_ard[[1]]), 1L) }) test_that("ard_pairwise(variable) messaging", { # only works with a single variable expect_snapshot( error = TRUE, ard_pairwise( ADSL, variable = c(ARM, AGEGR1), .f = \(df) ard_complex(df, variables = AGE, statistic = ~ list(ttest = ttest_fn)) ) ) expect_snapshot( error = TRUE, ard_pairwise( ADSL, variable = NOT_A_COLUMN, .f = \(df) ard_complex(df, variables = AGE, statistic = ~ list(ttest = ttest_fn)) ) ) }) test_that("ard_pairwise(include)", { expect_silent( lst_ard <- ard_pairwise( ADSL, variable = ARM, .f = \(df) ard_complex(df, variables = AGE, statistic = ~ list(ttest = ttest_fn)), include = "Placebo" # only include comparisons to the "Placebo" group ) ) expect_equal( names(lst_ard), c("'Placebo' vs. 'Xanomeline High Dose'", "'Placebo' vs. 'Xanomeline Low Dose'") ) }) test_that("ard_pairwise(.f) messaging", { expect_snapshot( error = TRUE, ard_pairwise(ADSL, variable = ARM, .f = \(df) stop("I MADE THIS ERROR")) ) }) test_that("ard_pairwise(include) messaging", { # include is not a level of the variable expect_snapshot( error = TRUE, ard_pairwise( ADSL, variable = ARM, .f = \(df) ard_complex(df, variables = AGE, statistic = ~ list(ttest = ttest_fn)), include = "NOT_A_LEVEL" ) ) # include input is not a vector expect_snapshot( error = TRUE, ard_pairwise( ADSL, variable = ARM, .f = \(df) ard_complex(df, variables = AGE, statistic = ~ list(ttest = ttest_fn)), include = mtcars ) ) }) cards/tests/testthat/test-ard_missing.R0000644000176200001440000000407514675422777020002 0ustar liggesuserstest_that("ard_missing() works", { expect_error( ard <- ard_missing(ADSL, by = "ARM", variables = "BMIBL"), NA ) expect_snapshot( ard |> dplyr::select(-"fmt_fn") |> as.data.frame() ) # confirm missing rate is correct expect_equal( ard |> dplyr::filter(stat_name %in% "p_miss") |> dplyr::pull(stat) |> unlist(), ADSL |> dplyr::mutate(BMIBL = is.na(BMIBL)) |> dplyr::summarise( .by = ARM, stat = mean(BMIBL) ) |> dplyr::pull(stat) ) }) test_that("ard_missing(stat_label) argument works", { # formula expect_snapshot( ard_missing( data = ADSL, by = "ARM", variables = c("AGE", "BMIBL"), stat_label = everything() ~ list(c("N_obs", "N_miss") ~ "N, miss") ) |> as.data.frame() |> dplyr::select(stat_name, stat_label) |> dplyr::filter(stat_name %in% c("N_obs", "N_miss")) |> unique() ) # list expect_snapshot( ard_missing( data = ADSL, by = "ARM", variables = c("AGEGR1", "SEX"), stat_label = everything() ~ list(p_miss = "% miss", p_nonmiss = "% non miss") ) |> as.data.frame() |> dplyr::select(stat_name, stat_label) |> dplyr::filter(stat_name %in% c("p_miss", "p_nonmiss")) |> unique() ) # variable-specific expect_snapshot( ard_missing( data = ADSL, by = "ARM", variables = c("AGE", "BMIBL"), stat_label = AGE ~ list(N_obs = "Number of Obs") ) |> as.data.frame() |> dplyr::select(variable, stat_name, stat_label) |> dplyr::filter(stat_name == "N_obs") |> unique() ) }) test_that("ard_missing() with grouped data works", { expect_equal( ADSL |> dplyr::group_by(ARM) |> ard_missing(variables = "BMIBL"), ard_missing( data = ADSL, by = "ARM", variables = "BMIBL" ) ) }) test_that("ard_missing() follows ard structure", { expect_silent( ADSL |> dplyr::group_by(ARM) |> ard_missing(variables = "BMIBL") |> check_ard_structure(method = FALSE) ) }) cards/tests/testthat/test-ard_categorical.R0000644000176200001440000007437314754213343020577 0ustar liggesuserstest_that("ard_categorical() univariate", { expect_error( ard_cat_uni <- ard_categorical(mtcars, variables = "am"), NA ) expect_snapshot(class(ard_cat_uni)) expect_equal( ard_cat_uni |> dplyr::filter(stat_name %in% "n") |> dplyr::pull(stat) |> as.integer(), table(mtcars$am) |> as.integer() ) expect_equal( ard_cat_uni |> dplyr::filter(stat_name %in% "p") |> dplyr::pull(stat) |> as.numeric(), table(mtcars$am) |> prop.table() |> as.numeric() ) expect_equal( dplyr::filter(ard_cat_uni, stat_name %in% "N")$stat[[1]], sum(!is.na(mtcars$am)) ) expect_equal( ard_categorical( mtcars, variables = starts_with("xxxxx") ), dplyr::tibble() |> as_card() ) # works for ordered factors expect_equal( ard_categorical( mtcars |> dplyr::mutate(cyl = factor(cyl, ordered = TRUE)), variables = cyl ) |> dplyr::select(stat_name, stat_label, stat), ard_categorical( mtcars |> dplyr::mutate(cyl = factor(cyl, ordered = FALSE)), variables = cyl ) |> dplyr::select(stat_name, stat_label, stat) ) expect_equal( ard_categorical( mtcars |> dplyr::mutate(cyl = factor(cyl, ordered = TRUE)), by = vs, variables = cyl ) |> dplyr::select(stat_name, stat_label, stat), ard_categorical( mtcars |> dplyr::mutate(cyl = factor(cyl, ordered = FALSE)), by = vs, variables = cyl ) |> dplyr::select(stat_name, stat_label, stat) ) }) test_that("ard_categorical() univariate & specified denomiator", { expect_error( ard_cat_new_denom <- ard_categorical( mtcars, variables = "am", denominator = list(mtcars) |> rep_len(100) |> dplyr::bind_rows() ), NA ) expect_snapshot(class(ard_cat_new_denom)) expect_equal( ard_cat_new_denom |> dplyr::filter(stat_name %in% "n") |> dplyr::pull(stat) |> as.integer(), table(mtcars$am) |> as.integer() ) expect_equal( ard_cat_new_denom |> dplyr::filter(stat_name %in% "p") |> dplyr::pull(stat) |> as.numeric(), table(mtcars$am) |> prop.table() |> as.numeric() %>% `/`(100) # styler: off ) expect_equal( dplyr::filter(ard_cat_new_denom, stat_name %in% "N")$stat[[1]], sum(!is.na(mtcars$am)) * 100L ) }) test_that("ard_continuous(fmt_fn) argument works", { ard_categorical( mtcars, variables = "am", fmt_fn = list( am = list( p = function(x) round5(x * 100, digits = 3) |> as.character(), N = function(x) format(round5(x, digits = 2), nsmall = 2), N_obs = function(x) format(round5(x, digits = 2), nsmall = 2) ) ) ) |> apply_fmt_fn() |> dplyr::select(variable, variable_level, stat_name, stat, stat_fmt) |> as.data.frame() |> expect_snapshot() ard_categorical( mtcars, variables = c("am", "vs"), fmt_fn = list( am = list(p = function(x) round5(x * 100, digits = 3)), vs = list(p = function(x) round5(x * 100, digits = 1)) ) ) |> apply_fmt_fn() |> dplyr::select(variable, variable_level, stat_name, stat, stat_fmt) |> as.data.frame() |> expect_snapshot() }) test_that("ard_categorical() with strata and by arguments", { ADAE_small <- ADAE |> dplyr::filter(AESOC %in% c("EYE DISORDERS", "INVESTIGATIONS")) |> dplyr::slice_head(by = AESOC, n = 3) expect_error( card_ae_strata <- ard_categorical( data = ADAE_small, strata = c(AESOC, AELLT), by = TRTA, variables = AESEV, denominator = ADSL |> dplyr::rename(TRTA = ARM) ), NA ) # check that all combinations of AESOC and AELLT are NOT present expect_equal( card_ae_strata |> dplyr::filter( group2_level %in% "EYE DISORDERS", group3_level %in% "NASAL MUCOSA BIOPSY" ) |> nrow(), 0L ) # check the rate calculations in the first SOC/LLT combination expect_equal( card_ae_strata |> dplyr::filter( group1_level %in% "Placebo", group2_level %in% "EYE DISORDERS", group3_level %in% "EYES SWOLLEN", variable_level %in% "MILD", stat_name %in% "n" ) |> dplyr::pull(stat) |> getElement(1), ADAE_small |> dplyr::filter( AESOC %in% "EYE DISORDERS", AELLT %in% "EYES SWOLLEN", TRTA %in% "Placebo", AESEV %in% "MILD" ) |> nrow() ) expect_equal( card_ae_strata |> dplyr::filter( group1_level %in% "Placebo", group2_level %in% "EYE DISORDERS", group3_level %in% "EYES SWOLLEN", variable_level %in% "MILD", stat_name %in% "p" ) |> dplyr::pull(stat) |> getElement(1), (ADAE_small |> dplyr::filter( AESOC %in% "EYE DISORDERS", AELLT %in% "EYES SWOLLEN", TRTA %in% "Placebo", AESEV %in% "MILD" ) |> nrow()) / (ADSL |> dplyr::filter(ARM %in% "Placebo") |> nrow()) ) expect_equal( card_ae_strata |> dplyr::filter( group1_level %in% "Placebo", stat_name %in% "N" ) |> dplyr::pull(stat) |> getElement(1), ADSL |> dplyr::filter(ARM %in% "Placebo") |> nrow() ) # check for messaging about missing by/strata combos in denominator arg expect_snapshot( error = TRUE, ard_categorical( ADSL, by = "ARM", variables = "AGEGR1", denominator = ADSL |> dplyr::filter(ARM %in% "Placebo") ) ) # addressing a sort edge case reported here: https://github.com/ddsjoberg/gtsummary/issues/1889 expect_silent( ard_sort_test <- iris |> dplyr::mutate( trt = rep_len(c("Bladder + RP LN", "Bladder + Renal Fossa"), length.out = dplyr::n()) ) |> ard_categorical(variables = trt, by = Species) ) expect_s3_class(ard_sort_test$group1_level[[1]], "factor") }) test_that("ard_categorical(stat_label) argument works", { # formula expect_snapshot( ard_categorical( data = ADSL, by = "ARM", variables = c("AGEGR1", "SEX"), stat_label = everything() ~ list(c("n", "p") ~ "n (pct)") ) |> as.data.frame() |> dplyr::filter(stat_name %in% c("n", "p")) |> dplyr::select(stat_name, stat_label) |> unique() ) # list expect_snapshot( ard_categorical( data = ADSL, by = "ARM", variables = c("AGEGR1", "SEX"), stat_label = everything() ~ list(n = "num", p = "pct") ) |> as.data.frame() |> dplyr::filter(stat_name %in% c("n", "p")) |> dplyr::select(stat_name, stat_label) |> unique() ) # variable-specific expect_snapshot( ard_categorical( data = ADSL, by = "ARM", variables = c("AGEGR1", "SEX"), stat_label = AGEGR1 ~ list(c("n", "p") ~ "n (pct)") ) |> as.data.frame() |> dplyr::filter(stat_name %in% c("n", "p")) |> dplyr::select(variable, stat_name, stat_label) |> unique() ) }) test_that("ard_categorical(denominator='cell') works", { expect_error( ard_crosstab <- ard_categorical(ADSL, variables = "AGEGR1", by = "ARM", denominator = "cell"), NA ) mtrx_conts <- with(ADSL, table(AGEGR1, ARM)) |> unclass() mtrx_percs <- mtrx_conts / sum(mtrx_conts) expect_equal( ard_crosstab |> dplyr::filter(group1_level %in% "Placebo", variable_level %in% "<65", stat_name %in% "n") |> dplyr::pull(stat) |> getElement(1), mtrx_conts["<65", "Placebo"] ) expect_equal( ard_crosstab |> dplyr::filter(group1_level %in% "Placebo", variable_level %in% "<65", stat_name %in% "p") |> dplyr::pull(stat) |> getElement(1), mtrx_percs["<65", "Placebo"] ) # works with an all missing variable df_missing <- dplyr::tibble( all_na_lgl = c(NA, NA), all_na_fct = factor(all_na_lgl, levels = letters[1:2]), letters = letters[1:2] ) expect_equal( ard_categorical( data = df_missing, variables = c(all_na_lgl, all_na_fct), statistic = ~ c("n", "N"), denominator = "cell" ) |> dplyr::pull(stat) |> unlist(), rep_len(0L, length.out = 8L) ) expect_equal( ard_categorical( data = df_missing, variables = c(all_na_lgl, all_na_fct), by = letters, statistic = ~ c("n", "N"), denominator = "cell" ) |> dplyr::pull(stat) |> unlist(), rep_len(0L, length.out = 16L) ) }) test_that("ard_categorical(denominator='row') works", { withr::local_options(list(width = 120)) expect_error( ard_crosstab_row <- ard_categorical(ADSL, variables = "AGEGR1", by = "ARM", denominator = "row"), NA ) xtab_count <- with(ADSL, table(AGEGR1, ARM)) xtab_percent <- proportions(xtab_count, margin = 1) expect_equal( xtab_count[rownames(xtab_count) %in% "<65", colnames(xtab_count) %in% "Placebo"], ard_crosstab_row |> dplyr::filter(variable_level %in% "<65", group1_level %in% "Placebo", stat_name %in% "n") |> dplyr::pull(stat) |> unlist(), ignore_attr = TRUE ) expect_equal( xtab_percent[rownames(xtab_percent) %in% "<65", colnames(xtab_percent) %in% "Placebo"], ard_crosstab_row |> dplyr::filter(variable_level %in% "<65", group1_level %in% "Placebo", stat_name %in% "p") |> dplyr::pull(stat) |> unlist(), ignore_attr = TRUE ) expect_equal( xtab_count[rownames(xtab_count) %in% ">80", colnames(xtab_count) %in% "Xanomeline Low Dose"], ard_crosstab_row |> dplyr::filter(variable_level %in% ">80", group1_level %in% "Xanomeline Low Dose", stat_name %in% "n") |> dplyr::pull(stat) |> unlist(), ignore_attr = TRUE ) expect_equal( xtab_percent[rownames(xtab_percent) %in% ">80", colnames(xtab_percent) %in% "Xanomeline Low Dose"], ard_crosstab_row |> dplyr::filter(variable_level %in% ">80", group1_level %in% "Xanomeline Low Dose", stat_name %in% "p") |> dplyr::pull(stat) |> unlist(), ignore_attr = TRUE ) # testing the arguments work properly expect_error( ard_with_args <- ard_categorical( ADSL, variables = "AGEGR1", by = "ARM", denominator = "row", statistic = list(AGEGR1 = c("n", "N")), fmt_fn = list(AGEGR1 = list("n" = 2)) ), NA ) expect_snapshot( ard_with_args |> apply_fmt_fn() |> dplyr::select(-fmt_fn, -warning, -error) |> as.data.frame() ) # works with an all missing variable df_missing <- dplyr::tibble(all_na_lgl = c(NA, NA), letters = letters[1:2]) expect_equal( ard_categorical( data = df_missing, variable = all_na_lgl, statistic = ~ c("n", "N"), denominator = "row" ) |> dplyr::pull(stat) |> unlist(), rep_len(0L, length.out = 4L) ) expect_equal( ard_categorical( data = df_missing, variable = all_na_lgl, by = letters, statistic = ~ c("n", "N"), denominator = "row" ) |> dplyr::pull(stat) |> unlist(), rep_len(0L, length.out = 8L) ) }) test_that("ard_categorical(denominator='column') works", { expect_equal( ard_categorical(ADSL, variables = "AGEGR1", by = "ARM", denominator = "column") |> dplyr::select(all_ard_groups(), all_ard_variables(), stat_name, stat), ard_categorical(ADSL, variables = "AGEGR1", by = "ARM") |> dplyr::select(all_ard_groups(), all_ard_variables(), stat_name, stat) ) # works with an all missing variable df_missing <- dplyr::tibble(all_na_lgl = c(NA, NA), letters = letters[1:2]) expect_equal( ard_categorical( data = df_missing, variable = all_na_lgl, statistic = ~ c("n", "N"), denominator = "column" ) |> dplyr::pull(stat) |> unlist(), rep_len(0L, length.out = 4L) ) expect_equal( ard_categorical( data = df_missing, variable = all_na_lgl, by = letters, statistic = ~ c("n", "N"), denominator = "column" ) |> dplyr::pull(stat) |> unlist(), rep_len(0L, length.out = 8L) ) # works with an all missing variable df_missing <- dplyr::tibble(all_na_lgl = c(NA, NA), letters = letters[1:2]) expect_equal( ard_categorical( data = df_missing, variable = all_na_lgl, statistic = ~ c("n", "N"), denominator = "column" ) |> dplyr::pull(stat) |> unlist(), rep_len(0L, length.out = 4L) ) expect_equal( ard_categorical( data = df_missing, variable = all_na_lgl, by = letters, statistic = ~ c("n", "N"), denominator = "column" ) |> dplyr::pull(stat) |> unlist(), rep_len(0L, length.out = 8L) ) }) test_that("ard_categorical(denominator=integer()) works", { expect_equal( ard_categorical(ADSL, variables = AGEGR1, denominator = 1000) |> get_ard_statistics(variable_level %in% "<65", .attributes = NULL), list(n = 33, N = 1000, p = 33 / 1000) ) }) test_that("ard_categorical(denominator=) works", { expect_snapshot( error = TRUE, ard_categorical( ADSL, by = ARM, variables = AGEGR1, denominator = data.frame( ARM = c("Placebo", "Placebo", "Xanomeline High Dose", "Xanomeline Low Dose"), ...ard_N... = c(86, 86, 84, 84) ) ) ) expect_snapshot( error = TRUE, ard_categorical( ADSL, by = ARM, variables = AGEGR1, denominator = data.frame(ARM = "Placebo", ...ard_N... = 86) ) ) expect_equal( ard_categorical( ADSL, by = ARM, variables = AGEGR1, denominator = data.frame( ARM = c("Placebo", "Xanomeline High Dose", "Xanomeline Low Dose"), ...ard_N... = c(86, 84, 84) ) ) |> dplyr::select(-fmt_fn), ard_categorical( ADSL, by = ARM, variables = AGEGR1 ) |> dplyr::select(-fmt_fn) ) }) test_that("ard_categorical(denominator=) works", { expect_equal( ADSL |> dplyr::mutate(AGEGR1 = NA) |> ard_categorical( variables = AGEGR1, statistic = ~ c("n", "p"), denominator = rep_len(list(ADSL), 10L) |> dplyr::bind_rows() ) |> dplyr::pull(stat) |> unlist() |> unique(), 0L ) expect_equal( ADSL |> dplyr::mutate(AGEGR1 = NA) |> ard_categorical( variables = AGEGR1, by = ARM, statistic = ~ c("n", "p"), denominator = rep_len(list(ADSL), 10L) |> dplyr::bind_rows() ) |> dplyr::pull(stat) |> unlist() |> unique(), 0L ) }) test_that("ard_categorical() and ARD column names", { ard_colnames <- c( "group1", "group1_level", "variable", "variable_level", "context", "stat_name", "stat_label", "stat", "fmt_fn", "warning", "error" ) # no errors when these variables are the summary vars expect_error( { lapply( ard_colnames, function(var) { df <- mtcars[c("am", "cyl")] names(df) <- c("am", var) ard_categorical( data = df, by = "am", variables = all_of(var) ) } ) }, NA ) # no errors when these vars are the by var expect_error( { lapply( ard_colnames, function(byvar) { df <- mtcars[c("am", "cyl")] names(df) <- c(byvar, "cyl") ard_continuous( data = df, by = all_of(byvar), variables = "cyl" ) } ) }, NA ) }) test_that("ard_categorical() with grouped data works", { expect_equal( ADSL |> dplyr::group_by(ARM) |> ard_categorical(variables = AGEGR1), ard_categorical(data = ADSL, by = "ARM", variables = "AGEGR1") ) }) test_that("ard_categorical() and all NA columns", { expect_snapshot( error = TRUE, ADSL |> dplyr::mutate(AGEGR1 = NA_character_) |> ard_categorical(variables = AGEGR1) ) }) test_that("ard_categorical() can handle non-syntactic column names", { expect_equal( ADSL |> dplyr::mutate(`Age Group` = AGEGR1) |> ard_categorical(variables = `Age Group`) |> dplyr::select(stat), ADSL |> ard_categorical(variables = AGEGR1) |> dplyr::select(stat) ) expect_equal( ADSL |> dplyr::mutate(`Age Group` = AGEGR1) |> ard_categorical(variables = "Age Group") |> dplyr::select(stat, error), ADSL |> ard_categorical(variables = AGEGR1) |> dplyr::select(stat, error) ) expect_equal( ADSL |> dplyr::mutate(`Arm Var` = ARM, `Age Group` = AGEGR1) |> ard_categorical(by = `Arm Var`, variables = "Age Group") |> dplyr::select(stat, error), ADSL |> ard_categorical(by = ARM, variables = AGEGR1) |> dplyr::select(stat, error) ) expect_equal( ADSL |> dplyr::mutate(`Arm Var` = ARM, `Age Group` = AGEGR1) |> ard_categorical(strata = "Arm Var", variables = `Age Group`) |> dplyr::select(stat, error), ADSL |> ard_categorical(strata = ARM, variables = AGEGR1) |> dplyr::select(stat, error) ) }) test_that("ard_categorical(strata) returns results in proper order", { expect_equal( ard_categorical( ADAE |> dplyr::arrange(AESEV != "SEVERE") |> # put SEVERE at the top dplyr::mutate(AESEV = factor(AESEV, levels = c("MILD", "MODERATE", "SEVERE"))) |> dplyr::mutate(ANY_AE = 1L), by = TRTA, strata = AESEV, variables = ANY_AE, denominator = ADSL |> dplyr::rename(TRTA = ARM) ) |> dplyr::select(group2_level) |> unlist() |> unique() |> as.character(), c("MILD", "MODERATE", "SEVERE") ) }) test_that("ard_categorical(by) messages about protected names", { mtcars2 <- mtcars |> dplyr::mutate( variable = am, variable_level = cyl, by = am, by_level = cyl ) expect_snapshot( error = TRUE, ard_categorical(mtcars2, by = variable, variables = gear) ) expect_error( ard_categorical(mtcars2, by = variable_level, variables = gear), 'The `by` argument cannot include variables named "variable" and "variable_level".' ) }) # - test if function parameters can be used as variable names without error test_that("ard_categorical() works when using generic names ", { # rename some variables mtcars2 <- mtcars %>% dplyr::rename("variable" = am, "variable_level" = cyl, "by" = disp, "group1_level" = gear) expect_equal( ard_categorical(mtcars, variables = c(am, cyl), by = disp, denominator = "row") |> dplyr::select(stat), ard_categorical(mtcars2, variables = c(variable, variable_level), by = by, denominator = "row") |> dplyr::select(stat) ) expect_equal( ard_categorical(mtcars, variables = c(cyl, am), by = gear, denominator = "row") |> dplyr::select(stat), ard_categorical(mtcars2, variables = c(variable_level, variable), by = group1_level, denominator = "row") |> dplyr::select(stat) ) expect_equal( ard_categorical(mtcars, variables = c(gear, am), by = disp, denominator = "row") |> dplyr::select(stat), ard_categorical(mtcars2, variables = c(group1_level, variable), by = by, denominator = "row") |> dplyr::select(stat) ) # rename vars mtcars2 <- mtcars %>% dplyr::rename("N" = am, "p" = cyl, "name" = disp, "group1_level" = gear) expect_equal( ard_categorical(mtcars, variables = c(am, cyl), by = disp, denominator = "row") |> dplyr::select(stat), ard_categorical(mtcars2, variables = c(N, p), by = name, denominator = "row") |> dplyr::select(stat) ) expect_equal( ard_categorical(mtcars, variables = c(disp, gear), by = am, denominator = "row") |> dplyr::select(stat), ard_categorical(mtcars2, variables = c(name, group1_level), by = N, denominator = "row") |> dplyr::select(stat) ) expect_equal( ard_categorical(mtcars, variables = c(am, disp), by = gear, denominator = "row") |> dplyr::select(stat), ard_categorical(mtcars2, variables = c(N, name), by = group1_level, denominator = "row") |> dplyr::select(stat) ) expect_equal( ard_categorical(mtcars, variables = c(am, disp), by = cyl, denominator = "row") |> dplyr::select(stat), ard_categorical(mtcars2, variables = c(N, name), by = p, denominator = "row") |> dplyr::select(stat) ) # rename vars mtcars2 <- mtcars %>% dplyr::rename("n" = am, "mean" = cyl, "p.std.error" = disp, "n_unweighted" = gear) expect_equal( ard_categorical(mtcars, variables = c(gear, cyl), by = disp, denominator = "row") |> dplyr::select(stat), ard_categorical(mtcars2, variables = c(n_unweighted, mean), by = p.std.error, denominator = "row") |> dplyr::select(stat) ) expect_equal( ard_categorical(mtcars, variables = c(gear, cyl), by = am, denominator = "row") |> dplyr::select(stat), ard_categorical(mtcars2, variables = c(n_unweighted, mean), by = n, denominator = "row") |> dplyr::select(stat) ) expect_equal( ard_categorical(mtcars, variables = c(am, disp), by = cyl, denominator = "row") |> dplyr::select(stat), ard_categorical(mtcars2, variables = c(n, p.std.error), by = mean, denominator = "row") |> dplyr::select(stat) ) expect_equal( ard_categorical(mtcars, variables = c(am, disp), by = gear, denominator = "row") |> dplyr::select(stat), ard_categorical(mtcars2, variables = c(n, p.std.error), by = n_unweighted, denominator = "row") |> dplyr::select(stat) ) # rename vars mtcars2 <- mtcars %>% dplyr::rename("N_unweighted" = am, "p_unweighted" = cyl, "column" = disp, "row" = gear) expect_equal( ard_categorical(mtcars, variables = c(am, cyl), by = disp, denominator = "row") |> dplyr::select(stat), ard_categorical(mtcars2, variables = c(N_unweighted, p_unweighted), by = column, denominator = "row") |> dplyr::select(stat) ) expect_equal( ard_categorical(mtcars, variables = c(disp, gear), by = am, denominator = "row") |> dplyr::select(stat), ard_categorical(mtcars2, variables = c(column, row), by = N_unweighted, denominator = "row") |> dplyr::select(stat) ) expect_equal( ard_categorical(mtcars, variables = c(am, disp), by = cyl, denominator = "row") |> dplyr::select(stat), ard_categorical(mtcars2, variables = c(N_unweighted, column), by = p_unweighted, denominator = "row") |> dplyr::select(stat) ) expect_equal( ard_categorical(mtcars, variables = c(am, disp), by = gear, denominator = "row") |> dplyr::select(stat), ard_categorical(mtcars2, variables = c(N_unweighted, column), by = row, denominator = "row") |> dplyr::select(stat) ) }) test_that("ard_categorical(by) messages about protected names", { mtcars2 <- mtcars %>% dplyr::rename("variable" = am, "variable_level" = cyl, "by" = disp, "group1_level" = gear) expect_snapshot( error = TRUE, ard_categorical(mtcars2, by = variable, variables = by) ) expect_error( ard_categorical(mtcars2, by = variable_level, variables = by), 'The `by` argument cannot include variables named "variable" and "variable_level".' ) }) test_that("ard_categorical() follows ard structure", { expect_silent( ard_categorical(mtcars, variables = "am") |> check_ard_structure(method = FALSE) ) }) test_that("ard_categorical() with hms times", { # originally reported in https://github.com/ddsjoberg/gtsummary/issues/1893 skip_if_not_installed("hms") withr::local_package("hms") ADSL2 <- ADSL |> dplyr::mutate(time_hms = hms(seconds = 15)) expect_silent( ard <- ard_categorical(ADSL2, by = ARM, variables = time_hms) ) expect_equal( ard$stat, ard_categorical( ADSL2 |> dplyr::mutate(time_hms = as.numeric(time_hms)), by = ARM, variables = time_hms )$stat ) }) test_that("ard_categorical() errors with incomplete factor columns", { # Check error when factors have no levels expect_snapshot( error = TRUE, mtcars |> dplyr::mutate(am = factor(am, levels = character(0))) |> ard_categorical(variables = am) ) # Check error when factor has NA level expect_snapshot( error = TRUE, mtcars |> dplyr::mutate(am = factor(am, levels = c(0, 1, NA), exclude = NULL)) |> ard_categorical(variables = am) ) }) test_that("ard_categorical(denominator='column') with cumulative counts", { # check cumulative stats work without `by/strata` expect_silent( ard <- ard_categorical( ADSL, variables = "AGEGR1", statistic = everything() ~ c("n", "p", "n_cum", "p_cum") ) ) # test the final cum n matches the nrow() expect_equal( ard |> dplyr::filter(stat_name == "n_cum", variable_level %in% dplyr::last(.unique_and_sorted(ADSL$AGEGR1))) |> dplyr::pull(stat) |> unlist(), nrow(ADSL) ) # test the final cum p is 1 expect_equal( ard |> dplyr::filter(stat_name == "p_cum", variable_level %in% dplyr::last(.unique_and_sorted(ADSL$AGEGR1))) |> dplyr::pull(stat) |> unlist(), 1 ) # check the cum n is correct expect_equal( ard |> dplyr::filter(stat_name %in% "n_cum") |> dplyr::select(variable_level, stat) |> deframe(), table(ADSL$AGEGR1) |> cumsum() |> as.list() ) # check the cum p is correct expect_equal( ard |> dplyr::filter(stat_name %in% "p_cum") |> dplyr::select(variable_level, stat) |> deframe(), table(ADSL$AGEGR1) |> prop.table() |> cumsum() |> as.list() ) # check cumulative stats work with `by` expect_silent( ard <- ard_categorical( ADSL, variables = "AGEGR1", by = ARM, statistic = everything() ~ c("n", "p", "n_cum", "p_cum") ) ) # check the cum n is correct expect_equal( ard |> dplyr::filter(stat_name %in% "n_cum", group1_level == "Placebo") |> dplyr::select(variable_level, stat) |> deframe(), table(ADSL$AGEGR1[ADSL$ARM == "Placebo"]) |> cumsum() |> as.list() ) # check the cum p is correct expect_equal( ard |> dplyr::filter(stat_name %in% "p_cum", group1_level == "Placebo") |> dplyr::select(variable_level, stat) |> deframe(), table(ADSL$AGEGR1[ADSL$ARM == "Placebo"]) |> prop.table() |> cumsum() |> as.list() ) # check with by & strata expect_silent( ard <- ard_categorical( ADSL, variables = "AGEGR1", by = ARM, strata = SEX, statistic = everything() ~ c("n", "p", "n_cum", "p_cum") ) ) # check the cum n is correct expect_equal( ard |> dplyr::filter(stat_name %in% "n_cum", group1_level == "Placebo", group2_level == "F") |> dplyr::select(variable_level, stat) |> deframe(), table(ADSL$AGEGR1[ADSL$ARM == "Placebo" & ADSL$SEX == "F"]) |> cumsum() |> as.list() ) # check the cum p is correct expect_equal( ard |> dplyr::filter(stat_name %in% "p_cum", group1_level == "Placebo", group2_level == "F") |> dplyr::select(variable_level, stat) |> deframe(), table(ADSL$AGEGR1[ADSL$ARM == "Placebo" & ADSL$SEX == "F"]) |> prop.table() |> cumsum() |> as.list() ) # function works when only `n_cum` requested expect_equal( ard_categorical( ADSL, variables = "AGEGR1", statistic = everything() ~ "n_cum" ), ard_categorical( ADSL, variables = "AGEGR1", statistic = everything() ~ c("n", "p", "n_cum", "p_cum") ) |> dplyr::filter(stat_name == "n_cum") ) # function works when only `p_cum` requested expect_equal( ard_categorical( ADSL, variables = "AGEGR1", statistic = everything() ~ "p_cum" ), ard_categorical( ADSL, variables = "AGEGR1", statistic = everything() ~ c("n", "p", "n_cum", "p_cum") ) |> dplyr::filter(stat_name == "p_cum") ) }) test_that("ard_categorical(denominator='row') with cumulative counts", { # check cumulative stats work without `by/strata` expect_silent( ard <- ard_categorical( ADSL, variables = "AGEGR1", statistic = everything() ~ c("n", "p", "n_cum", "p_cum"), denominator = "row" ) ) # when no by, the n and n_cum should be the same expect_true( ard |> dplyr::filter(stat_name %in% c("n", "n_cum")) |> dplyr::mutate( .by = all_ard_variables(), check_equal = unlist(stat) == unlist(stat)[1] ) |> dplyr::pull(check_equal) |> unique() ) # when no by, the p and p_cum should be the same and equal to 1 expect_equal( ard |> dplyr::filter(stat_name %in% c("p", "p_cum")) |> dplyr::pull(stat) |> unlist() |> unique(), 1 ) # check cumulative stats work with `by` expect_silent( ard <- ard_categorical( ADSL, variables = "AGEGR1", by = SEX, statistic = everything() ~ c("n", "p", "n_cum", "p_cum"), denominator = "row" ) ) # check row n_cum expect_equal( ard |> dplyr::filter(variable_level %in% "<65", stat_name == "n_cum") |> dplyr::select(group1_level, stat) |> deframe(), table(ADSL$SEX[ADSL$AGEGR1 == "<65"]) |> cumsum() |> as.list() ) # check row p_cum expect_equal( ard |> dplyr::filter(variable_level %in% "<65", stat_name == "p_cum") |> dplyr::select(group1_level, stat) |> deframe(), table(ADSL$SEX[ADSL$AGEGR1 == "<65"]) |> prop.table() |> cumsum() |> as.list() ) }) test_that("ard_categorical() with cumulative counts messaging", { # cumulative counts/percents only available when `denominator=c('column', 'row')` expect_snapshot( error = TRUE, ard_categorical( ADSL, variables = "AGEGR1", by = SEX, statistic = everything() ~ c("n", "p", "n_cum", "p_cum"), denominator = NULL ) ) }) test_that("ard_categorical() ordering for multiple strata", { adae_mini <- ADAE |> dplyr::select(USUBJID, TRTA, AESOC, AEDECOD) |> dplyr::filter(AESOC %in% unique(AESOC)[1:4]) |> dplyr::group_by(AESOC) |> dplyr::filter(AEDECOD %in% unique(AEDECOD)[1:5]) |> dplyr::ungroup() res_actual <- ard_categorical( adae_mini |> unique() |> dplyr::mutate(any_ae = TRUE), strata = c(AESOC, AEDECOD), by = TRTA, variables = any_ae ) |> dplyr::select(group2_level, group3_level) |> tidyr::unnest(everything()) |> unique() expect_equal( res_actual, adae_mini |> dplyr::select(group2_level = AESOC, group3_level = AEDECOD) |> unique() |> dplyr::arrange(group2_level, group3_level), ignore_attr = TRUE ) }) cards/tests/testthat/_snaps/0000755000176200001440000000000014776252447015655 5ustar liggesuserscards/tests/testthat/_snaps/round5.md0000644000176200001440000000263014770617006017402 0ustar liggesusers# round5() works Code x <- seq.int(-10L, 10L, by = 1L) / 2 x <- x[x %% 1 != 0] setNames(round5(x), nm = x) Output -4.5 -3.5 -2.5 -1.5 -0.5 0.5 1.5 2.5 3.5 4.5 -5 -4 -3 -2 -1 1 2 3 4 5 --- Code x <- seq.int(-100000L, 100000L, by = 10000L) - 1L / 2L x <- x[x %% 1 != 0] setNames(round5(x), nm = x) Output -100000.5 -90000.5 -80000.5 -70000.5 -60000.5 -50000.5 -40000.5 -30000.5 -100001 -90001 -80001 -70001 -60001 -50001 -40001 -30001 -20000.5 -10000.5 -0.5 9999.5 19999.5 29999.5 39999.5 49999.5 -20001 -10001 -1 10000 20000 30000 40000 50000 59999.5 69999.5 79999.5 89999.5 99999.5 60000 70000 80000 90000 100000 --- Code x <- seq.int(-100000L, 100000L, by = 10000L) + 1L / 2L x <- x[x %% 1 != 0] setNames(round5(x), nm = x) Output -99999.5 -89999.5 -79999.5 -69999.5 -59999.5 -49999.5 -39999.5 -29999.5 -100000 -90000 -80000 -70000 -60000 -50000 -40000 -30000 -19999.5 -9999.5 0.5 10000.5 20000.5 30000.5 40000.5 50000.5 -20000 -10000 1 10001 20001 30001 40001 50001 60000.5 70000.5 80000.5 90000.5 100000.5 60001 70001 80001 90001 100001 cards/tests/testthat/_snaps/ard_strata.md0000644000176200001440000000435414770617003020314 0ustar liggesusers# ard_strata() works Code ard_strata(ADSL, .by = ARM, .f = ~ ard_continuous(.x, variables = AGE)) Message {cards} data frame: 24 x 10 Output group1 group1_level variable stat_name stat_label stat 1 ARM Placebo AGE N N 86 2 ARM Placebo AGE mean Mean 75.209 3 ARM Placebo AGE sd SD 8.59 4 ARM Placebo AGE median Median 76 5 ARM Placebo AGE p25 Q1 69 6 ARM Placebo AGE p75 Q3 82 7 ARM Placebo AGE min Min 52 8 ARM Placebo AGE max Max 89 9 ARM Xanomeli… AGE N N 84 10 ARM Xanomeli… AGE mean Mean 74.381 Message i 14 more rows i Use `print(n = ...)` to see more rows i 4 more variables: context, fmt_fn, warning, error --- Code ard_strata(ADSL, .strata = ARM, .f = ~ ard_continuous(.x, variables = AGE, by = AGEGR1)) Message {cards} data frame: 72 x 12 Output group2 group2_level group1 group1_level variable stat_name stat_label stat 1 ARM Placebo AGEGR1 65-80 AGE N N 42 2 ARM Placebo AGEGR1 65-80 AGE mean Mean 73.595 3 ARM Placebo AGEGR1 65-80 AGE sd SD 4.173 4 ARM Placebo AGEGR1 65-80 AGE median Median 74 5 ARM Placebo AGEGR1 65-80 AGE p25 Q1 70 6 ARM Placebo AGEGR1 65-80 AGE p75 Q3 77 7 ARM Placebo AGEGR1 65-80 AGE min Min 65 8 ARM Placebo AGEGR1 65-80 AGE max Max 80 9 ARM Placebo AGEGR1 <65 AGE N N 14 10 ARM Placebo AGEGR1 <65 AGE mean Mean 61.143 Message i 62 more rows i Use `print(n = ...)` to see more rows i 4 more variables: context, fmt_fn, warning, error cards/tests/testthat/_snaps/ard_categorical.md0000644000176200001440000002117414770616762021305 0ustar liggesusers# ard_categorical() univariate Code class(ard_cat_uni) Output [1] "card" "tbl_df" "tbl" "data.frame" # ard_categorical() univariate & specified denomiator Code class(ard_cat_new_denom) Output [1] "card" "tbl_df" "tbl" "data.frame" # ard_continuous(fmt_fn) argument works Code as.data.frame(dplyr::select(apply_fmt_fn(ard_categorical(mtcars, variables = "am", fmt_fn = list(am = list(p = function(x) as.character(round5(x * 100, digits = 3)), N = function(x) format(round5(x, digits = 2), nsmall = 2), N_obs = function(x) format(round5(x, digits = 2), nsmall = 2))))), variable, variable_level, stat_name, stat, stat_fmt)) Output variable variable_level stat_name stat stat_fmt 1 am 0 n 19 19 2 am 0 N 32 32.00 3 am 0 p 0.59375 59.375 4 am 1 n 13 13 5 am 1 N 32 32.00 6 am 1 p 0.40625 40.625 --- Code as.data.frame(dplyr::select(apply_fmt_fn(ard_categorical(mtcars, variables = c( "am", "vs"), fmt_fn = list(am = list(p = function(x) round5(x * 100, digits = 3)), vs = list(p = function(x) round5(x * 100, digits = 1))))), variable, variable_level, stat_name, stat, stat_fmt)) Output variable variable_level stat_name stat stat_fmt 1 am 0 n 19 19 2 am 0 N 32 32 3 am 0 p 0.59375 59.375 4 am 1 n 13 13 5 am 1 N 32 32 6 am 1 p 0.40625 40.625 7 vs 0 n 18 18 8 vs 0 N 32 32 9 vs 0 p 0.5625 56.3 10 vs 1 n 14 14 11 vs 1 N 32 32 12 vs 1 p 0.4375 43.8 # ard_categorical() with strata and by arguments Code ard_categorical(ADSL, by = "ARM", variables = "AGEGR1", denominator = dplyr::filter( ADSL, ARM %in% "Placebo")) Condition Error in `ard_categorical()`: ! The following `by/strata` combinations are missing from the `denominator` data frame: ARM (Xanomeline High Dose) and ARM (Xanomeline Low Dose). # ard_categorical(stat_label) argument works Code unique(dplyr::select(dplyr::filter(as.data.frame(ard_categorical(data = ADSL, by = "ARM", variables = c("AGEGR1", "SEX"), stat_label = everything() ~ list( c("n", "p") ~ "n (pct)"))), stat_name %in% c("n", "p")), stat_name, stat_label)) Output stat_name stat_label 1 n n (pct) 2 p n (pct) --- Code unique(dplyr::select(dplyr::filter(as.data.frame(ard_categorical(data = ADSL, by = "ARM", variables = c("AGEGR1", "SEX"), stat_label = everything() ~ list( n = "num", p = "pct"))), stat_name %in% c("n", "p")), stat_name, stat_label)) Output stat_name stat_label 1 n num 2 p pct --- Code unique(dplyr::select(dplyr::filter(as.data.frame(ard_categorical(data = ADSL, by = "ARM", variables = c("AGEGR1", "SEX"), stat_label = AGEGR1 ~ list(c("n", "p") ~ "n (pct)"))), stat_name %in% c("n", "p")), variable, stat_name, stat_label)) Output variable stat_name stat_label 1 AGEGR1 n n (pct) 2 AGEGR1 p n (pct) 7 SEX n n 8 SEX p % # ard_categorical(denominator='row') works Code as.data.frame(dplyr::select(apply_fmt_fn(ard_with_args), -fmt_fn, -warning, -error)) Output group1 group1_level variable variable_level context stat_name stat_label stat stat_fmt 1 ARM Placebo AGEGR1 65-80 categorical n n 42 42.00 2 ARM Placebo AGEGR1 65-80 categorical N N 144 144 3 ARM Placebo AGEGR1 <65 categorical n n 14 14.00 4 ARM Placebo AGEGR1 <65 categorical N N 33 33 5 ARM Placebo AGEGR1 >80 categorical n n 30 30.00 6 ARM Placebo AGEGR1 >80 categorical N N 77 77 7 ARM Xanomeline High Dose AGEGR1 65-80 categorical n n 55 55.00 8 ARM Xanomeline High Dose AGEGR1 65-80 categorical N N 144 144 9 ARM Xanomeline High Dose AGEGR1 <65 categorical n n 11 11.00 10 ARM Xanomeline High Dose AGEGR1 <65 categorical N N 33 33 11 ARM Xanomeline High Dose AGEGR1 >80 categorical n n 18 18.00 12 ARM Xanomeline High Dose AGEGR1 >80 categorical N N 77 77 13 ARM Xanomeline Low Dose AGEGR1 65-80 categorical n n 47 47.00 14 ARM Xanomeline Low Dose AGEGR1 65-80 categorical N N 144 144 15 ARM Xanomeline Low Dose AGEGR1 <65 categorical n n 8 8.00 16 ARM Xanomeline Low Dose AGEGR1 <65 categorical N N 33 33 17 ARM Xanomeline Low Dose AGEGR1 >80 categorical n n 29 29.00 18 ARM Xanomeline Low Dose AGEGR1 >80 categorical N N 77 77 # ard_categorical(denominator=) works Code ard_categorical(ADSL, by = ARM, variables = AGEGR1, denominator = data.frame( ARM = c("Placebo", "Placebo", "Xanomeline High Dose", "Xanomeline Low Dose"), ...ard_N... = c(86, 86, 84, 84))) Condition Error in `ard_categorical()`: ! Specified counts in column "'...ard_N...'" are not unique in the `denominator` argument across the `by` and `strata` columns. --- Code ard_categorical(ADSL, by = ARM, variables = AGEGR1, denominator = data.frame( ARM = "Placebo", ...ard_N... = 86)) Condition Error in `ard_categorical()`: ! The following `by/strata` combinations are missing from the `denominator` data frame: ARM (Xanomeline High Dose) and ARM (Xanomeline Low Dose). # ard_categorical() and all NA columns Code ard_categorical(dplyr::mutate(ADSL, AGEGR1 = NA_character_), variables = AGEGR1) Condition Error in `ard_categorical()`: ! Column "AGEGR1" is all missing and cannot by tabulated. i Only columns of class and can be tabulated when all values are missing. # ard_categorical(by) messages about protected names Code ard_categorical(mtcars2, by = variable, variables = gear) Condition Error in `ard_categorical()`: ! The `by` argument cannot include variables named "variable" and "variable_level". --- Code ard_categorical(mtcars2, by = variable, variables = by) Condition Error in `ard_categorical()`: ! The `by` argument cannot include variables named "variable" and "variable_level". # ard_categorical() errors with incomplete factor columns Code ard_categorical(dplyr::mutate(mtcars, am = factor(am, levels = character(0))), variables = am) Condition Error in `ard_categorical()`: ! Factors with empty "levels" attribute are not allowed, which was identified in column "am". --- Code ard_categorical(dplyr::mutate(mtcars, am = factor(am, levels = c(0, 1, NA), exclude = NULL)), variables = am) Condition Error in `ard_categorical()`: ! Factors with NA levels are not allowed, which are present in column "am". # ard_categorical() with cumulative counts messaging Code ard_categorical(ADSL, variables = "AGEGR1", by = SEX, statistic = everything() ~ c("n", "p", "n_cum", "p_cum"), denominator = NULL) Condition Error in `ard_categorical()`: ! The `denominator` argument must be one of "column" and "row" when cumulative statistics "n_cum" or "p_cum" are specified, which were requested for variable `AGEGR1`. cards/tests/testthat/_snaps/filter_ard_hierarchical.md0000644000176200001440000000535314776242611023006 0ustar liggesusers# filter_ard_hierarchical() works Code ard_f Message {cards} data frame: 39 x 15 Output group1 group1_level group2 group2_level group3 group3_level variable variable_level stat_name stat_label stat 1 TRTA Placebo n n 86 2 TRTA Placebo N N 254 3 TRTA Placebo p % 0.339 4 TRTA Xanomeli… n n 84 5 TRTA Xanomeli… N N 254 6 TRTA Xanomeli… p % 0.331 7 TRTA Xanomeli… n n 84 8 TRTA Xanomeli… N N 254 9 TRTA Xanomeli… p % 0.331 10 TRTA Placebo ..ard_hierarchical_overall.. TRUE n n 26 Message i 29 more rows i Use `print(n = ...)` to see more rows i 4 more variables: context, fmt_fn, warning, error # filter_ard_hierarchical() error messaging works Code filter_ard_hierarchical(ard_categorical(ADSL, by = "ARM", variables = "AGEGR1"), n > 10) Condition Error in `filter_ard_hierarchical()`: ! Filtering is only available for stacked hierarchical ARDs created using `ard_stack_hierarchical()` or `ard_stack_hierarchical_count()`. --- Code filter_ard_hierarchical(ard, 10) Condition Error in `filter_ard_hierarchical()`: ! The `filter` argument must be an expression. --- Code filter_ard_hierarchical(ard, A > 5) Condition Error in `filter_ard_hierarchical()`: ! The expression provided as `filter` includes condition for statistic or `by` variable "A" which is not present in the ARD. --- Code filter_ard_hierarchical(ard, n > 1, keep_empty = NULL) Condition Error in `filter_ard_hierarchical()`: ! The `keep_empty` argument must be a scalar with class , not NULL. cards/tests/testthat/_snaps/bind_ard.md0000644000176200001440000001246414770617003017733 0ustar liggesusers# ARD helpers messaging Code bind_ard(ard, ard, .update = letters) Condition Error in `bind_ard()`: ! The `.update` argument must be a scalar with class , not a character vector. --- Code bind_ard(ard, ard, .distinct = FALSE, .update = FALSE) Condition Error in `bind_ard()`: ! 27 rows with duplicated statistic names have been found. i See cards::bind_ard(.update) (`?cards::bind_ard()`) for details. # bind_ard() .order argument works Code dplyr::select(as.data.frame(bind_ard(ard_categorical(ADSL, by = "ARM", variables = "SEX") %>% { dplyr::slice(., sample.int(nrow(.))) }, .order = TRUE)), -c(context, fmt_fn, warning, error)) Output group1 group1_level variable variable_level stat_name stat_label stat 1 ARM Xanomeline Low Dose SEX M n n 34 2 ARM Xanomeline Low Dose SEX M p % 0.4047619 3 ARM Xanomeline Low Dose SEX F p % 0.5952381 4 ARM Xanomeline Low Dose SEX M N N 84 5 ARM Xanomeline Low Dose SEX F n n 50 6 ARM Xanomeline Low Dose SEX F N N 84 7 ARM Placebo SEX M p % 0.3837209 8 ARM Placebo SEX M n n 33 9 ARM Placebo SEX F n n 53 10 ARM Placebo SEX F N N 86 11 ARM Placebo SEX F p % 0.6162791 12 ARM Placebo SEX M N N 86 13 ARM Xanomeline High Dose SEX M N N 84 14 ARM Xanomeline High Dose SEX M p % 0.5238095 15 ARM Xanomeline High Dose SEX F p % 0.4761905 16 ARM Xanomeline High Dose SEX F N N 84 17 ARM Xanomeline High Dose SEX F n n 40 18 ARM Xanomeline High Dose SEX M n n 44 --- Code dplyr::select(as.data.frame(bind_ard(ard_categorical(ADSL, by = "ARM", variables = "SEX") %>% { dplyr::slice(., sample.int(nrow(.))) }, .order = FALSE)), -c(context, fmt_fn, warning, error)) Output group1 group1_level variable variable_level stat_name stat_label stat 1 ARM Placebo SEX F p % 0.6162791 2 ARM Xanomeline Low Dose SEX F N N 84 3 ARM Placebo SEX M n n 33 4 ARM Xanomeline High Dose SEX F n n 40 5 ARM Xanomeline High Dose SEX F p % 0.4761905 6 ARM Placebo SEX F n n 53 7 ARM Xanomeline High Dose SEX M n n 44 8 ARM Xanomeline High Dose SEX M N N 84 9 ARM Placebo SEX M p % 0.3837209 10 ARM Placebo SEX M N N 86 11 ARM Xanomeline Low Dose SEX F p % 0.5952381 12 ARM Placebo SEX F N N 86 13 ARM Xanomeline Low Dose SEX M p % 0.4047619 14 ARM Xanomeline High Dose SEX M p % 0.5238095 15 ARM Xanomeline High Dose SEX F N N 84 16 ARM Xanomeline Low Dose SEX F n n 50 17 ARM Xanomeline Low Dose SEX M N N 84 18 ARM Xanomeline Low Dose SEX M n n 34 # bind_ard(.distinct) Code ard_continuous(ADSL, variables = AGE) %>% { bind_ard(., ., .update = FALSE) } Message i 8 rows with duplicated statistic values have been removed. * See cards::bind_ard(.distinct) (`?cards::bind_ard()`) for details. {cards} data frame: 8 x 8 Output variable context stat_name stat_label stat fmt_fn 1 AGE continuo… N N 254 0 2 AGE continuo… mean Mean 75.087 1 3 AGE continuo… sd SD 8.246 1 4 AGE continuo… median Median 77 1 5 AGE continuo… p25 Q1 70 1 6 AGE continuo… p75 Q3 81 1 7 AGE continuo… min Min 51 1 8 AGE continuo… max Max 89 1 Message i 2 more variables: warning, error cards/tests/testthat/_snaps/ard_formals.md0000644000176200001440000000117714776252447020476 0ustar liggesusers# ard_formals() works Code ard_formals(fun = mcnemar.test, arg_names = "correct") Message {cards} data frame: 1 x 3 Output stat_name stat_label stat 1 correct correct TRUE --- Code ard_formals(fun = asNamespace("stats")[["t.test.default"]], arg_names = c("mu", "paired", "var.equal", "conf.level"), passed_args = list(conf.level = 0.9)) Message {cards} data frame: 4 x 3 Output stat_name stat_label stat 1 mu mu 0 2 paired paired FALSE 3 var.equal var.equal FALSE 4 conf.level conf.lev… 0.9 cards/tests/testthat/_snaps/tidy_ard_row_order.md0000644000176200001440000000277114770617010022050 0ustar liggesusers# tidy_ard_row_order() works Code dplyr::select(ard_categorical(data.frame(x1 = sample(LETTERS[1:5], 30, replace = TRUE), x2 = sample(LETTERS[6:10], 30, replace = TRUE), x3 = sample(LETTERS[11:15], 30, replace = TRUE), zz = 1L, aa = 1L), by = x1:x3, variables = c(zz, aa), statistic = everything() ~ "n"), all_ard_groups(), all_ard_variables()) Message {cards} data frame: 250 x 8 Output group1 group1_level group2 group2_level group3 group3_level variable variable_level 1 x1 A x2 F x3 K zz 1 2 x1 A x2 F x3 K aa 1 3 x1 A x2 F x3 L zz 1 4 x1 A x2 F x3 L aa 1 5 x1 A x2 F x3 M zz 1 6 x1 A x2 F x3 M aa 1 7 x1 A x2 F x3 N zz 1 8 x1 A x2 F x3 N aa 1 9 x1 A x2 F x3 O zz 1 10 x1 A x2 F x3 O aa 1 Message i 240 more rows i Use `print(n = ...)` to see more rows cards/tests/testthat/_snaps/add_calculated_row.md0000644000176200001440000000527514770616754022007 0ustar liggesusers# add_calculated_row(x) Code apply_fmt_fn(add_calculated_row(ard_continuous(mtcars, variables = mpg), expr = max - min, stat_name = "range")) Message {cards} data frame: 9 x 9 Output variable context stat_name stat_label stat stat_fmt 1 mpg continuo… N N 32 32 2 mpg continuo… mean Mean 20.091 20.1 3 mpg continuo… sd SD 6.027 6.0 4 mpg continuo… median Median 19.2 19.2 5 mpg continuo… p25 Q1 15.35 15.4 6 mpg continuo… p75 Q3 22.8 22.8 7 mpg continuo… min Min 10.4 10.4 8 mpg continuo… max Max 33.9 33.9 9 mpg continuo… range range 23.5 23.5 Message i 3 more variables: fmt_fn, warning, error --- Code apply_fmt_fn(add_calculated_row(ard_continuous(mtcars, variables = mpg), expr = dplyr::case_when( mean > median ~ "Right Skew", mean < median ~ "Left Skew", .default = "Symmetric"), stat_name = "skew")) Message {cards} data frame: 9 x 9 Output variable context stat_name stat_label stat stat_fmt 1 mpg continuo… N N 32 32 2 mpg continuo… mean Mean 20.091 20.1 3 mpg continuo… sd SD 6.027 6.0 4 mpg continuo… median Median 19.2 19.2 5 mpg continuo… p25 Q1 15.35 15.4 6 mpg continuo… p75 Q3 22.8 22.8 7 mpg continuo… min Min 10.4 10.4 8 mpg continuo… max Max 33.9 33.9 9 mpg continuo… skew skew Right Sk… Right Skew Message i 3 more variables: fmt_fn, warning, error # add_calculated_row(expr) messaging Code add_calculated_row(ard_continuous(mtcars, variables = mpg), expr = not_a_stat * 2, stat_name = "this_doesnt_work") Condition Error in `add_calculated_row()`: ! There was an error calculating the new statistic. See below: x object 'not_a_stat' not found # add_calculated_row(by) messaging Code add_calculated_row(ard_continuous(mtcars, variables = mpg, by = cyl), expr = max - min, stat_name = "range", by = "context") Condition Error in `add_calculated_row()`: ! Duplicate statistics present within `by` groups: "N", "mean", "sd", "median", "p25", "p75", "min", "max", "N", "mean", "sd", "median", "p25", "p75", "min", and "max" cards/tests/testthat/_snaps/print.md0000644000176200001440000001037214770617005017323 0ustar liggesusers# print.card() works Code ard_continuous(ADSL, by = "ARM", variables = "AGE") Message {cards} data frame: 24 x 10 Output group1 group1_level variable stat_name stat_label stat 1 ARM Placebo AGE N N 86 2 ARM Placebo AGE mean Mean 75.209 3 ARM Placebo AGE sd SD 8.59 4 ARM Placebo AGE median Median 76 5 ARM Placebo AGE p25 Q1 69 6 ARM Placebo AGE p75 Q3 82 7 ARM Placebo AGE min Min 52 8 ARM Placebo AGE max Max 89 9 ARM Xanomeli… AGE N N 84 10 ARM Xanomeli… AGE mean Mean 74.381 Message i 14 more rows i Use `print(n = ...)` to see more rows i 4 more variables: context, fmt_fn, warning, error --- Code ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") Message {cards} data frame: 27 x 11 Output group1 group1_level variable variable_level stat_name stat_label stat 1 ARM Placebo AGEGR1 65-80 n n 42 2 ARM Placebo AGEGR1 65-80 N N 86 3 ARM Placebo AGEGR1 65-80 p % 0.488 4 ARM Placebo AGEGR1 <65 n n 14 5 ARM Placebo AGEGR1 <65 N N 86 6 ARM Placebo AGEGR1 <65 p % 0.163 7 ARM Placebo AGEGR1 >80 n n 30 8 ARM Placebo AGEGR1 >80 N N 86 9 ARM Placebo AGEGR1 >80 p % 0.349 10 ARM Xanomeli… AGEGR1 65-80 n n 55 Message i 17 more rows i Use `print(n = ...)` to see more rows i 4 more variables: context, fmt_fn, warning, error --- Code ard_continuous(ADSL, variables = "AGE", fmt_fn = AGE ~ list(~ function(x) round( x, 3))) Message {cards} data frame: 8 x 8 Output variable context stat_name stat_label stat fmt_fn 1 AGE continuo… N N 254 2 AGE continuo… mean Mean 75.087 3 AGE continuo… sd SD 8.246 4 AGE continuo… median Median 77 5 AGE continuo… p25 Q1 70 6 AGE continuo… p75 Q3 81 7 AGE continuo… min Min 51 8 AGE continuo… max Max 89 Message i 2 more variables: warning, error --- Code dplyr::select(ard_continuous(data = data.frame(x = seq(as.Date("2000-01-01"), length.out = 10L, by = "day")), variables = x, statistic = ~ continuous_summary_fns(c("min", "max", "sd"))), -fmt_fn) Message {cards} data frame: 3 x 7 Output variable context stat_name stat_label stat error 1 x continuo… min Min 2000-01-… 2 x continuo… max Max 2000-01-… 3 x continuo… sd SD 3.028 Message i 1 more variable: warning --- Code bind_ard(ard_attributes(mtcars, variables = mpg), ard_continuous(mtcars, variables = mpg, statistic = ~ continuous_summary_fns("mean", other_stats = list( vcov = function(x) vcov(lm(mpg ~ am, mtcars)))))) Message {cards} data frame: 4 x 8 Output variable context stat_name stat_label stat fmt_fn 1 mpg attribut… label Variable… mpg 2 mpg attribut… class Variable… numeric NULL 3 mpg continuo… mean Mean 20.091 1 4 mpg continuo… vcov vcov 1.265, -1.265, -1.265, 3.113 1 Message i 2 more variables: warning, error cards/tests/testthat/_snaps/print_ard_conditions.md0000644000176200001440000001136214770617005022402 0ustar liggesusers# print_ard_conditions() works Code print_ard_conditions(ard_continuous(ADSL, variables = AGE)) --- Code print_ard_conditions(ard_continuous(ADSL, variables = AGE, statistic = ~ list( mean = function(x) mean(x), mean_warning = function(x) { warning("warn1") warning("warn2") mean(x) }, err_fn = function(x) stop("'tis an error")))) Message The following errors were returned during `print_ard_conditions()`: x For variable `AGE` and "err_fn" statistic: 'tis an error The following warnings were returned during `print_ard_conditions()`: ! For variable `AGE` and "mean_warning" statistic: warn1 ! For variable `AGE` and "mean_warning" statistic: warn2 --- Code print_ard_conditions(ard_continuous(ADSL, variables = AGE, by = ARM, statistic = ~ list(mean = function(x) mean(x), mean_warning = function(x) { warning("warn1") warning("warn2") mean(x) }, err_fn = function(x) stop("'tis an error")))) Message The following errors were returned during `print_ard_conditions()`: x For variable `AGE` (`ARM = "Placebo"`) and "err_fn" statistic: 'tis an error x For variable `AGE` (`ARM = "Xanomeline High Dose"`) and "err_fn" statistic: 'tis an error x For variable `AGE` (`ARM = "Xanomeline Low Dose"`) and "err_fn" statistic: 'tis an error The following warnings were returned during `print_ard_conditions()`: ! For variable `AGE` (`ARM = "Placebo"`) and "mean_warning" statistic: warn1 ! For variable `AGE` (`ARM = "Placebo"`) and "mean_warning" statistic: warn2 ! For variable `AGE` (`ARM = "Xanomeline High Dose"`) and "mean_warning" statistic: warn1 ! For variable `AGE` (`ARM = "Xanomeline High Dose"`) and "mean_warning" statistic: warn2 ! For variable `AGE` (`ARM = "Xanomeline Low Dose"`) and "mean_warning" statistic: warn1 ! For variable `AGE` (`ARM = "Xanomeline Low Dose"`) and "mean_warning" statistic: warn2 --- Code print_ard_conditions(dplyr::mutate(ard_continuous(ADSL, variables = AGE), error = list("repeated error"))) Message The following errors were returned during `print_ard_conditions()`: x For variable `AGE` and "N", "mean", "sd", "median", "p25", "p75", "min", and "max" statistics: repeated error --- Code tbl_summary <- (function() { set_cli_abort_call() ard <- ard_continuous(ADSL, variables = AGE, statistic = ~ list(err_fn = function( x) stop("'tis an error"))) print_ard_conditions(ard) }) tbl_summary() Message The following errors were returned during `tbl_summary()`: x For variable `AGE` and "err_fn" statistic: 'tis an error # print_ard_conditions(condition_type) Code print_ard_conditions(ard_continuous(ADSL, variables = AGE, statistic = ~ list( mean_warning = function(x) { warning("warn1") warning("warn2") mean(x) })), condition_type = "identity") Message The following warnings were returned during `print_ard_conditions()`: Condition Warning: ! For variable `AGE` and "mean_warning" statistic: warn1 Warning: ! For variable `AGE` and "mean_warning" statistic: warn2 --- Code print_ard_conditions(ard_continuous(ADSL, variables = AGE, statistic = ~ list( mean = function(x) mean(x), err_fn = function(x) stop("'tis an error"))), condition_type = "identity") Message The following errors were returned during `print_ard_conditions()`: Condition Error in `print_ard_conditions()`: x For variable `AGE` and "err_fn" statistic: 'tis an error # print_ard_conditions() no error when 'error'/'warning' columns not present Code print_ard_conditions(dplyr::select(ard_continuous(ADSL, variables = AGE), -warning, -error)) # print_ard_conditions() no error when factors are present Code print_ard_conditions(ard) Message The following warnings were returned during `print_ard_conditions()`: ! For variable `continuous_var` (`by_var = "cohort_1"`) and "min" statistic: no non-missing arguments to min; returning Inf ! For variable `continuous_var` (`by_var = "cohort_1"`) and "max" statistic: no non-missing arguments to max; returning -Inf # print_ard_conditions() works when curly brackets appear in condition message Code print_ard_conditions(ard) Message The following errors were returned during `print_ard_conditions()`: x For variable `AGE` and "mean" statistic: error with {curly} brackets The following warnings were returned during `print_ard_conditions()`: ! For variable `AGE` and "mean" statistic: warning with {curly} brackets cards/tests/testthat/_snaps/rename_ard_columns.md0000644000176200001440000000122214776252447022031 0ustar liggesusers# rename_ard_columns(columns) messsaging Code rename_ard_columns(ard_categorical(ADSL, by = ARM, variables = AGEGR1), columns = all_ard_groups()) Condition Error in `rename_ard_columns()`: ! The `column` argument may only select columns using `all_ard_groups("names")` and `all_ard_variables("names")` i Column "group1_level" is not a valid selection. --- Code rename_ard_columns(ard_categorical(dplyr::rename(ADSL, stat = AGEGR1), by = ARM, variables = stat)) Condition Error in `rename_ard_columns()`: ! New column name(s) "stat" cannot be added, because they are already present. cards/tests/testthat/_snaps/rename_ard_groups.md0000644000176200001440000000217314770617006021664 0ustar liggesusers# rename_ard_groups_shift() Code dplyr::select(rename_ard_groups_shift(ard_continuous(ADSL, variables = AGE, by = c( SEX, ARM)), shift = 1L), all_ard_groups()) %>% 1L[] Message {cards} data frame: 1 x 4 Output group2 group2_level group3 group3_level 1 SEX F ARM Placebo # rename_ard_groups_shift() messaging Code dplyr::select(rename_ard_groups_shift(ard_continuous(ADSL, variables = AGE, by = c( SEX, ARM)), shift = -1L), all_ard_groups()) %>% 1L[] Message There are now non-standard group column names: "group0" and "group0_level". i Is this the shift you had planned? {cards} data frame: 1 x 4 Output group0 group0_level group1 group1_level 1 SEX F ARM Placebo # rename_ard_groups_reverse() Code dplyr::select(rename_ard_groups_reverse(ard_continuous(ADSL, variables = AGE, by = c(SEX, ARM))), all_ard_groups()) %>% 1L[] Message {cards} data frame: 1 x 4 Output group1 group1_level group2 group2_level 1 ARM Placebo SEX F cards/tests/testthat/_snaps/as_card.md0000644000176200001440000000075014770617002017557 0ustar liggesusers# as_card() works Code as_card(data.frame(stat_name = c("N", "mean"), stat_label = c("N", "Mean"), stat = c(10, 0.5))) Message {cards} data frame: 2 x 3 Output stat_name stat_label stat 1 N N 10 2 mean Mean 0.5 # as_card() error catching works correctly Code as_card("notadataframe") Condition Error in `as_card()`: ! The `x` argument must be class , not a string. cards/tests/testthat/_snaps/ard_stack.md0000644000176200001440000001024414770617001020114 0ustar liggesusers# ard_stack() messaging Code head(ard_stack(data = mtcars, ard_continuous(variables = "mpg"), .overall = TRUE), 1L) Message The `.by` argument should be specified when using `.overall=TRUE`. i Setting `ard_stack(.overall=FALSE)`. {cards} data frame: 1 x 8 Output variable context stat_name stat_label stat fmt_fn 1 mpg continuo… N N 32 0 Message i 2 more variables: warning, error --- Code ard_stack(ADSL, by = "ARM", ard_continuous(variables = AGE)) Condition Error in `ard_stack()`: ! Cannot evaluate expression `by = ARM`. i Did you mean `.by = ARM`? # ard_stack() complex call error Code complex_call <- list() complex_call$ard_continuous <- ard_continuous ard_stack(data = mtcars, .by = am, complex_call$ard_continuous(variables = "mpg"), ) Condition Error in `ard_stack()`: ! `cards::ard_stack()` works with simple calls (`?rlang::call_name()`) and `complex_call$ard_continuous(variables = "mpg")` is not simple. # ard_stack(.by) messaging Code dplyr::filter(ard_stack(mtcars2, ard_continuous(variables = "mpg", statistic = ~ continuous_summary_fns("N")), .by = c(am, vs), .total_n = TRUE, .overall = TRUE), stat_name %in% "N") Message * Removing 1 row with NA or NaN values in "am" and "vs" columns. {cards} data frame: 10 x 13 Output group1 group1_level group2 group2_level variable variable_level stat_name stat_label stat 1 am 0 vs 0 mpg N N 12 2 am 0 vs 1 mpg N N 7 3 am 1 vs 0 mpg N N 5 4 am 1 vs 1 mpg N N 7 5 mpg N N 31 6 am 0 N N 31 7 am 1 N N 31 8 vs 0 N N 31 9 vs 1 N N 31 10 ..ard_total_n.. N N 31 Message i 4 more variables: context, fmt_fn, warning, error --- Code dplyr::filter(ard_stack(mtcars3, ard_continuous(variables = "mpg", statistic = ~ continuous_summary_fns("N")), .by = c(am, vs), .total_n = TRUE, .overall = TRUE), stat_name %in% "N") Message * Removing 2 rows with NA or NaN values in "am" and "vs" columns. {cards} data frame: 10 x 13 Output group1 group1_level group2 group2_level variable variable_level stat_name stat_label stat 1 am 0 vs 0 mpg N N 12 2 am 0 vs 1 mpg N N 7 3 am 1 vs 0 mpg N N 4 4 am 1 vs 1 mpg N N 7 5 mpg N N 30 6 am 0 N N 30 7 am 1 N N 30 8 vs 0 N N 30 9 vs 1 N N 30 10 ..ard_total_n.. N N 30 Message i 4 more variables: context, fmt_fn, warning, error cards/tests/testthat/_snaps/tidy_as_ard.md0000644000176200001440000001477214770617010020455 0ustar liggesusers# tidy_as_ard() works Code as.data.frame(tidy_as_ard(lst_tidy = eval_capture_conditions(dplyr::as_tibble( stats::fisher.test(x = mtcars[["am"]], y = mtcars[["vs"]])[c("estimate", "p.value", "method")])), tidy_result_names = c("estimate", "p.value", "method"), fun_args_to_record = c("workspace", "hybrid", "hybridPars", "control", "or", "conf.int", "conf.level", "simulate.p.value", "B"), formals = formals( stats::fisher.test), passed_args = list(), lst_ard_columns = list(context = "fishertest", group1 = "am", variable = "vs"))) Output group1 variable context stat_name 1 am vs fishertest estimate 2 am vs fishertest p.value 3 am vs fishertest method 4 am vs fishertest workspace 5 am vs fishertest hybrid 6 am vs fishertest hybridPars 7 am vs fishertest control 8 am vs fishertest or 9 am vs fishertest conf.int 10 am vs fishertest conf.level 11 am vs fishertest simulate.p.value 12 am vs fishertest B stat fmt_fn warning error 1 1.956055 1 NULL NULL 2 0.4726974 1 NULL NULL 3 Fisher's Exact Test for Count Data NULL NULL NULL 4 2e+05 1 NULL NULL 5 FALSE NULL NULL NULL 6 c(expect = 5, percent = 80, Emin = 1) NULL NULL NULL 7 list() NULL NULL NULL 8 1 1 NULL NULL 9 TRUE NULL NULL NULL 10 0.95 1 NULL NULL 11 FALSE NULL NULL NULL 12 2000 1 NULL NULL --- Code as.data.frame(tidy_as_ard(lst_tidy = eval_capture_conditions(stop( "Planned unit testing error!")), tidy_result_names = c("estimate", "p.value", "conf.low", "conf.high", "method", "alternative"), fun_args_to_record = c( "workspace", "hybrid", "hybridPars", "control", "or", "conf.int", "conf.level", "simulate.p.value", "B"), formals = formals(stats::fisher.test), passed_args = list(), lst_ard_columns = list(context = "fishertest", group1 = "am", variable = "vs"))) Output group1 variable context stat_name 1 am vs fishertest estimate 2 am vs fishertest p.value 3 am vs fishertest conf.low 4 am vs fishertest conf.high 5 am vs fishertest method 6 am vs fishertest alternative 7 am vs fishertest workspace 8 am vs fishertest hybrid 9 am vs fishertest hybridPars 10 am vs fishertest control 11 am vs fishertest or 12 am vs fishertest conf.int 13 am vs fishertest conf.level 14 am vs fishertest simulate.p.value 15 am vs fishertest B stat fmt_fn warning 1 NULL NULL NULL 2 NULL NULL NULL 3 NULL NULL NULL 4 NULL NULL NULL 5 NULL NULL NULL 6 NULL NULL NULL 7 2e+05 1 NULL 8 FALSE NULL NULL 9 c(expect = 5, percent = 80, Emin = 1) NULL NULL 10 list() NULL NULL 11 1 1 NULL 12 TRUE NULL NULL 13 0.95 1 NULL 14 FALSE NULL NULL 15 2000 1 NULL error 1 Planned unit testing error! 2 Planned unit testing error! 3 Planned unit testing error! 4 Planned unit testing error! 5 Planned unit testing error! 6 Planned unit testing error! 7 Planned unit testing error! 8 Planned unit testing error! 9 Planned unit testing error! 10 Planned unit testing error! 11 Planned unit testing error! 12 Planned unit testing error! 13 Planned unit testing error! 14 Planned unit testing error! 15 Planned unit testing error! --- Code dplyr::select(as.data.frame(tidy_as_ard(lst_tidy = eval_capture_conditions( dplyr::as_tibble(stats::fisher.test(x = mtcars[["am"]], y = mtcars[["vs"]])[c( "estimate", "p.value", "method")])), tidy_result_names = c("estimate", "p.value", "conf.low", "conf.high", "method", "alternative"), formals = formals( stats::fisher.test), passed_args = list(), lst_ard_columns = list(context = "fishertest", group1 = "am", variable = "vs"))), c(group1, variable, stat)) Output group1 variable stat 1 am vs 1.956055 2 am vs 0.4726974 3 am vs Fisher's Exact Test for Count Data --- Code dplyr::select(as.data.frame(tidy_as_ard(lst_tidy = eval_capture_conditions( dplyr::as_tibble(stats::fisher.test(x = mtcars[["am"]], y = mtcars[["vs"]])[c( "estimate", "p.value", "method")])), tidy_result_names = c("estimate", "p.value", "conf.low", "conf.high", "method", "alternative"), passed_args = list(), lst_ard_columns = list(context = "fishertest", group1 = "am", variable = "vs"))), c(group1, variable, stat)) Output group1 variable stat 1 am vs 1.956055 2 am vs 0.4726974 3 am vs Fisher's Exact Test for Count Data cards/tests/testthat/_snaps/options.md0000644000176200001440000000066514770617004017665 0ustar liggesusers# options(cards.round_type) messaging Code withr::with_options(list(cards.round_type = "NOT-CORRECT"), ard_categorical( data.frame(x = c(T, F)), variables = everything(), statistic = ~"p")) Condition Error in `dplyr::mutate()`: i In argument: `fmt_fn = pmap(...)`. Caused by error in `ard_categorical()`: ! The `cards.round_type` option must be one of "round-half-up" and "round-to-even". cards/tests/testthat/_snaps/ard_continuous.md0000644000176200001440000001312614770617002021220 0ustar liggesusers# ard_continuous() works Code class(ard_test) Output [1] "card" "tbl_df" "tbl" "data.frame" # ard_continuous(fmt_fn) argument works Code as.data.frame(dplyr::select(apply_fmt_fn(ard_continuous(ADSL, variables = "AGE", statistic = list(AGE = continuous_summary_fns(c("N", "mean", "median"))), fmt_fn = list(AGE = list(mean = function(x) as.character(round5(x, digits = 3)), N = function(x) format(round5(x, digits = 2), nsmall = 2), N_obs = function(x) format(round5(x, digits = 2), nsmall = 2))))), variable, stat_name, stat, stat_fmt)) Output variable stat_name stat stat_fmt 1 AGE N 254 254.00 2 AGE mean 75.08661 75.087 3 AGE median 77 77.0 --- Code as.data.frame(dplyr::select(apply_fmt_fn(ard_continuous(ADSL, variables = c( "AGE", "BMIBL"), statistic = ~ continuous_summary_fns("mean"), fmt_fn = list( AGE = list(mean = function(x) as.character(round5(x, digits = 3)))))), variable, stat_name, stat, stat_fmt)) Output variable stat_name stat stat_fmt 1 AGE mean 75.08661 75.087 2 BMIBL mean 24.67233 24.7 --- Code as.data.frame(dplyr::select(apply_fmt_fn(ard_continuous(ADSL, variables = c( "AGE", "BMIBL"), statistic = ~ continuous_summary_fns(c("mean", "sd")), fmt_fn = ~ list(~ function(x) round(x, 4)))), variable, stat_name, stat, stat_fmt)) Output variable stat_name stat stat_fmt 1 AGE mean 75.08661 75.0866 2 AGE sd 8.246234 8.2462 3 BMIBL mean 24.67233 24.6723 4 BMIBL sd 4.092185 4.0922 # ard_continuous() messaging Code ard_continuous(mtcars, variables = "mpg", statistic = ~ list(mean = "this is a string")) Condition Error in `ard_continuous()`: ! Error in the argument `statistic` for variable "mpg". i Value must be a named list of functions. --- Code ard_continuous(letters, variables = "mpg") Condition Error in `UseMethod()`: ! no applicable method for 'ard_continuous' applied to an object of class "character" --- Code ard_continuous(mtcars) Condition Error in `ard_continuous()`: ! The `variables` argument cannot be missing. # ard_continuous(stat_label) argument works Code unique(dplyr::filter(dplyr::select(as.data.frame(ard_continuous(data = ADSL, by = "ARM", variables = c("AGE", "BMIBL"), stat_label = everything() ~ list(c( "min", "max") ~ "min - max"))), stat_name, stat_label), stat_name %in% c( "min", "max"))) Output stat_name stat_label 1 min min - max 2 max min - max --- Code unique(dplyr::filter(dplyr::select(as.data.frame(ard_continuous(data = ADSL, by = "ARM", variables = c("AGE", "BMIBL"), stat_label = everything() ~ list( p25 = "25th %ile", p75 = "75th %ile"))), stat_name, stat_label), stat_name %in% c("p25", "p75"))) Output stat_name stat_label 1 p25 25th %ile 2 p75 75th %ile --- Code unique(dplyr::select(dplyr::filter(as.data.frame(ard_continuous(data = ADSL, by = "ARM", variables = c("AGE", "BMIBL"), stat_label = AGE ~ list(p25 = "25th %ile", p75 = "75th %ile"))), stat_name %in% c("p25", "p75")), variable, stat_name, stat_label)) Output variable stat_name stat_label 1 AGE p25 25th %ile 2 AGE p75 75th %ile 3 BMIBL p25 Q1 4 BMIBL p75 Q3 --- Code ard1 Output variable stat_name stat_label 1 AGE conf.low LB 2 AGE conf.high UB # ard_continuous() with dates works and displays as expected Code ard_date Message {cards} data frame: 3 x 8 Output variable context stat_name stat_label stat fmt_fn 1 DISONSDT continuo… min Min 1998-06-… 2 DISONSDT continuo… max Max 2013-09-… 3 DISONSDT continuo… sd SD 878.558 1 Message i 2 more variables: warning, error # ard_continuous() works with non-syntactic names Code as.data.frame(ard_continuous(dplyr::mutate(ADSL, `BMI base` = BMIBL, Age = AGE, `Arm Var` = ARM), variables = c("BMI base", Age), statistic = ~ list( `mean lbl` = `mean error`), stat_label = everything() ~ list(`mean lbl` = "Test lbl"))) Output variable context stat_name stat_label stat fmt_fn 1 BMI base continuous mean lbl Test lbl NULL .Primitive("as.character") 2 Age continuous mean lbl Test lbl NULL .Primitive("as.character") warning error 1 NULL There was an error calculating the mean. 2 NULL There was an error calculating the mean. # ard_continuous() errors with incomplete factor columns Code ard_continuous(dplyr::mutate(mtcars, am = factor(am, levels = character(0))), by = am, variables = mpg) Condition Error in `ard_continuous()`: ! Factors with empty "levels" attribute are not allowed, which was identified in column "am". --- Code ard_continuous(dplyr::mutate(mtcars, am = factor(am, levels = c(0, 1, NA), exclude = NULL)), by = am, variables = mpg) Condition Error in `ard_continuous()`: ! Factors with NA levels are not allowed, which are present in column "am". cards/tests/testthat/_snaps/get_ard_statistics.md0000644000176200001440000000133214770617003022040 0ustar liggesusers# get_ard_statistics() works Code get_ard_statistics(ard, group1_level %in% "Placebo", variable_level %in% "65-80") Output $n [1] 42 $N [1] 86 $p [1] 0.4883721 --- Code get_ard_statistics(ard, group1_level %in% "Placebo", variable_level %in% "65-80", .attributes = c("warning", "error")) Output $n [1] 42 attr(,"warning") [1] "ARM" attr(,"error") [1] "Placebo" $N [1] 86 attr(,"warning") [1] "ARM" attr(,"error") [1] "Placebo" $p [1] 0.4883721 attr(,"warning") [1] "ARM" attr(,"error") [1] "Placebo" cards/tests/testthat/_snaps/sort_ard_hierarchical.md0000644000176200001440000001537314770617012022506 0ustar liggesusers# sort_ard_hierarchical() works Code print(dplyr::select(ard_s, all_ard_groups(), all_ard_variables()), n = 50) Message {cards} data frame: 234 x 8 Output group1 group1_level group2 group2_level group3 group3_level variable variable_level 1 TRTA Placebo 2 TRTA Placebo 3 TRTA Placebo 4 TRTA Xanomeli… 5 TRTA Xanomeli… 6 TRTA Xanomeli… 7 TRTA Xanomeli… 8 TRTA Xanomeli… 9 TRTA Xanomeli… 10 TRTA Placebo ..ard_hierarchical_overall.. TRUE 11 TRTA Placebo ..ard_hierarchical_overall.. TRUE 12 TRTA Placebo ..ard_hierarchical_overall.. TRUE 13 TRTA Xanomeli… ..ard_hierarchical_overall.. TRUE 14 TRTA Xanomeli… ..ard_hierarchical_overall.. TRUE 15 TRTA Xanomeli… ..ard_hierarchical_overall.. TRUE 16 TRTA Xanomeli… ..ard_hierarchical_overall.. TRUE 17 TRTA Xanomeli… ..ard_hierarchical_overall.. TRUE 18 TRTA Xanomeli… ..ard_hierarchical_overall.. TRUE 19 TRTA Placebo SEX F 20 TRTA Placebo SEX F 21 TRTA Placebo SEX F 22 TRTA Xanomeli… SEX F 23 TRTA Xanomeli… SEX F 24 TRTA Xanomeli… SEX F 25 TRTA Xanomeli… SEX F 26 TRTA Xanomeli… SEX F 27 TRTA Xanomeli… SEX F 28 TRTA Placebo SEX F RACE WHITE 29 TRTA Placebo SEX F RACE WHITE 30 TRTA Placebo SEX F RACE WHITE 31 TRTA Xanomeli… SEX F RACE WHITE 32 TRTA Xanomeli… SEX F RACE WHITE 33 TRTA Xanomeli… SEX F RACE WHITE 34 TRTA Xanomeli… SEX F RACE WHITE 35 TRTA Xanomeli… SEX F RACE WHITE 36 TRTA Xanomeli… SEX F RACE WHITE 37 TRTA Placebo SEX F RACE WHITE AETERM APPLICAT… 38 TRTA Placebo SEX F RACE WHITE AETERM APPLICAT… 39 TRTA Placebo SEX F RACE WHITE AETERM APPLICAT… 40 TRTA Xanomeli… SEX F RACE WHITE AETERM APPLICAT… 41 TRTA Xanomeli… SEX F RACE WHITE AETERM APPLICAT… 42 TRTA Xanomeli… SEX F RACE WHITE AETERM APPLICAT… 43 TRTA Xanomeli… SEX F RACE WHITE AETERM APPLICAT… 44 TRTA Xanomeli… SEX F RACE WHITE AETERM APPLICAT… 45 TRTA Xanomeli… SEX F RACE WHITE AETERM APPLICAT… 46 TRTA Placebo SEX F RACE WHITE AETERM ERYTHEMA 47 TRTA Placebo SEX F RACE WHITE AETERM ERYTHEMA 48 TRTA Placebo SEX F RACE WHITE AETERM ERYTHEMA 49 TRTA Xanomeli… SEX F RACE WHITE AETERM ERYTHEMA 50 TRTA Xanomeli… SEX F RACE WHITE AETERM ERYTHEMA Message i 184 more rows i Use `print(n = ...)` to see more rows # sort_ard_hierarchical() error messaging works Code sort_ard_hierarchical(ard_categorical(ADSL, by = "ARM", variables = "AGEGR1")) Condition Error in `sort_ard_hierarchical()`: ! Sorting is only available for stacked hierarchical ARDs created using `ard_stack_hierarchical()` or `ard_stack_hierarchical_count()`. --- Code sort_ard_hierarchical(ard, sort = "no_sorting") Condition Error in `sort_ard_hierarchical()`: ! `sort` must be one of "descending" or "alphanumeric", not "no_sorting". --- Code sort_ard_hierarchical(ard) Condition Error in `sort_ard_hierarchical()`: ! If `sort='descending'` then either "n" or "p" must be present in `x` for all variables in order to calculate the count sums used for sorting. cards/tests/testthat/_snaps/ard_missing.md0000644000176200001440000000606414770616771020502 0ustar liggesusers# ard_missing() works Code as.data.frame(dplyr::select(ard, -"fmt_fn")) Output group1 group1_level variable context stat_name stat_label 1 ARM Placebo BMIBL missing N_obs Vector Length 2 ARM Placebo BMIBL missing N_miss N Missing 3 ARM Placebo BMIBL missing N_nonmiss N Non-missing 4 ARM Placebo BMIBL missing p_miss % Missing 5 ARM Placebo BMIBL missing p_nonmiss % Non-missing 6 ARM Xanomeline High Dose BMIBL missing N_obs Vector Length 7 ARM Xanomeline High Dose BMIBL missing N_miss N Missing 8 ARM Xanomeline High Dose BMIBL missing N_nonmiss N Non-missing 9 ARM Xanomeline High Dose BMIBL missing p_miss % Missing 10 ARM Xanomeline High Dose BMIBL missing p_nonmiss % Non-missing 11 ARM Xanomeline Low Dose BMIBL missing N_obs Vector Length 12 ARM Xanomeline Low Dose BMIBL missing N_miss N Missing 13 ARM Xanomeline Low Dose BMIBL missing N_nonmiss N Non-missing 14 ARM Xanomeline Low Dose BMIBL missing p_miss % Missing 15 ARM Xanomeline Low Dose BMIBL missing p_nonmiss % Non-missing stat warning error 1 86 NULL NULL 2 0 NULL NULL 3 86 NULL NULL 4 0 NULL NULL 5 1 NULL NULL 6 84 NULL NULL 7 0 NULL NULL 8 84 NULL NULL 9 0 NULL NULL 10 1 NULL NULL 11 84 NULL NULL 12 1 NULL NULL 13 83 NULL NULL 14 0.01190476 NULL NULL 15 0.9880952 NULL NULL # ard_missing(stat_label) argument works Code unique(dplyr::filter(dplyr::select(as.data.frame(ard_missing(data = ADSL, by = "ARM", variables = c("AGE", "BMIBL"), stat_label = everything() ~ list(c("N_obs", "N_miss") ~ "N, miss"))), stat_name, stat_label), stat_name %in% c("N_obs", "N_miss"))) Output stat_name stat_label 1 N_obs N, miss 2 N_miss N, miss --- Code unique(dplyr::filter(dplyr::select(as.data.frame(ard_missing(data = ADSL, by = "ARM", variables = c("AGEGR1", "SEX"), stat_label = everything() ~ list(p_miss = "% miss", p_nonmiss = "% non miss"))), stat_name, stat_label), stat_name %in% c( "p_miss", "p_nonmiss"))) Output stat_name stat_label 1 p_miss % miss 2 p_nonmiss % non miss --- Code unique(dplyr::filter(dplyr::select(as.data.frame(ard_missing(data = ADSL, by = "ARM", variables = c("AGE", "BMIBL"), stat_label = AGE ~ list(N_obs = "Number of Obs"))), variable, stat_name, stat_label), stat_name == "N_obs")) Output variable stat_name stat_label 1 AGE N_obs Number of Obs 2 BMIBL N_obs Vector Length cards/tests/testthat/_snaps/ard_stack_hierarchical.md0000644000176200001440000001665314776242611022633 0ustar liggesusers# ard_stack_hierarchical(variables) messaging removed obs Code ard <- ard_stack_hierarchical(dplyr::mutate(ADAE_small, AESOC = ifelse(dplyr::row_number() == 1L, NA, AESOC)), variables = c(AESOC, AEDECOD), id = USUBJID, denominator = dplyr::rename( ADSL, TRTA = TRT01A)) Message * Removing 1 row from `data` with NA or NaN values in "AESOC" and "AEDECOD" columns. --- Code ard <- ard_stack_hierarchical(ADAE_small, variables = c(AESOC, AEDECOD), id = USUBJID, by = TRTA, denominator = dplyr::mutate(dplyr::rename(ADSL, TRTA = TRT01A), TRTA = ifelse(dplyr::row_number() == 1L, NA, TRTA))) Message * Removing 1 row from `denominator` with NA or NaN values in "TRTA" column. # ard_stack_hierarchical(variables) messaging Code ard_stack_hierarchical(ADAE_small, variables = starts_with("xxxxx"), id = USUBJID, denominator = dplyr::rename(ADSL, TRTA = TRT01A)) Condition Error in `ard_stack_hierarchical()`: ! Arguments `variables` and `include` cannot be empty. --- Code ard_stack_hierarchical(ADAE_small, variables = c(AESOC, AEDECOD), id = starts_with( "xxxxx"), denominator = dplyr::rename(ADSL, TRTA = TRT01A)) Condition Error in `ard_stack_hierarchical()`: ! Argument `id` cannot be empty. # ard_stack_hierarchical(by) messaging Code ard <- ard_stack_hierarchical(dplyr::mutate(ADAE_small, TRTA = ifelse(dplyr::row_number() == 1L, NA, TRTA)), variables = c(AESOC, AEDECOD), by = TRTA, id = USUBJID, denominator = dplyr::rename(ADSL, TRTA = TRT01A)) Message * Removing 1 row from `data` with NA or NaN values in "TRTA", "AESOC", and "AEDECOD" columns. # ard_stack_hierarchical(denominator) messaging Code ard_stack_hierarchical(ADAE_small, variables = c(AESOC, AEDECOD), by = TRTA, id = USUBJID, denominator = character()) Condition Error in `ard_stack_hierarchical()`: ! The `denominator` argument must be a or an , not an empty character vector. --- Code ard_stack_hierarchical(ADAE, variables = c(AESOC, AEDECOD), by = TRTA, id = USUBJID) Condition Error in `ard_stack_hierarchical()`: ! The `denominator` argument cannot be missing. # ard_stack_hierarchical(variables, include) messaging Code ard_stack_hierarchical(ADAE_small, variables = c(AESOC, AEDECOD), include = AESOC, by = TRTA, denominator = dplyr::rename(ADSL, TRTA = ARM), id = USUBJID) Condition Error in `ard_stack_hierarchical()`: ! The last column specified in the `variables` (i.e. "AEDECOD") must be in the `include` argument. # ard_stack_hierarchical(by, overall) messaging Code ard <- ard_stack_hierarchical(ADAE_small, variables = c(AESOC, AEDECOD), denominator = dplyr::rename(ADSL, TRTA = ARM), id = USUBJID, overall = TRUE) Message The `by` argument must be specified when using `overall=TRUE`. i Setting `overall=FALSE`. # ard_stack_hierarchical_count(denominator) messaging Code ard_stack_hierarchical_count(ADAE_small, variables = c(AESOC, AEDECOD), by = TRTA, denominator = letters) Condition Error in `ard_stack_hierarchical_count()`: ! The `denominator` argument must be empty, a , or an , not a character vector. # ard_stack_hierarchical_count(denominator,total_n) messaging Code ard <- ard_stack_hierarchical_count(ADAE_small, variables = c(AESOC, AEDECOD), total_n = TRUE) Message The `denominator` argument must be specified when using `total_n=TRUE`. i Setting `total_n=FALSE`. # ard_stack_hierarchical_count(overall, denominator) messaging Code ard <- ard_stack_hierarchical_count(ADAE_small, variables = c(AESOC, AEDECOD), by = TRTA, overall = TRUE) Message The `denominator` argument must be specified as a data frame when using `overall=TRUE`. i Setting `overall=FALSE`. # ard_stack_hierarchical_count(overall) Code dplyr::filter(ard_stack_hierarchical_count(ADAE_small, variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV), denominator = dplyr::rename(ADSL, TRTA = ARM), overall = TRUE), !group1 %in% "TRTA" & !group2 %in% "TRTA" & !group3 %in% "TRTA" & !variable %in% "TRTA") Message {cards} data frame: 18 x 15 Output group1 group1_level group2 group2_level group3 group3_level variable variable_level stat_name stat_label stat 1 AESEV MILD AESOC GENERAL … n n 4 2 AESEV MODERATE AESOC GENERAL … n n 0 3 AESOC GENERAL … n n 4 4 AESEV MILD AESOC GENERAL … AEDECOD APPLICAT… n n 2 5 AESEV MODERATE AESOC GENERAL … AEDECOD APPLICAT… n n 0 6 AESOC GENERAL … AEDECOD APPLICAT… n n 2 7 AESEV MILD AESOC GENERAL … AEDECOD APPLICAT… n n 2 8 AESEV MODERATE AESOC GENERAL … AEDECOD APPLICAT… n n 0 9 AESOC GENERAL … AEDECOD APPLICAT… n n 2 10 AESEV MILD AESOC SKIN AND… n n 1 11 AESEV MODERATE AESOC SKIN AND… n n 1 12 AESOC SKIN AND… n n 2 13 AESEV MILD AESOC SKIN AND… AEDECOD ERYTHEMA n n 1 14 AESEV MODERATE AESOC SKIN AND… AEDECOD ERYTHEMA n n 0 15 AESOC SKIN AND… AEDECOD ERYTHEMA n n 1 16 AESEV MILD AESOC SKIN AND… AEDECOD PRURITUS… n n 0 17 AESEV MODERATE AESOC SKIN AND… AEDECOD PRURITUS… n n 1 18 AESOC SKIN AND… AEDECOD PRURITUS… n n 1 Message i 4 more variables: context, fmt_fn, warning, error # ard_stack_hierarchical_count(overall,over_variables) Code as.data.frame(dplyr::select(dplyr::filter(ard_stack_hierarchical_count( ADAE_small, variables = AESOC, by = TRTA, denominator = dplyr::rename(ADSL, TRTA = ARM), over_variables = TRUE, overall = TRUE), variable == "..ard_hierarchical_overall.."), all_ard_groups(), "variable", "stat_name", "stat")) Output group1 group1_level variable stat_name stat 1 TRTA Placebo ..ard_hierarchical_overall.. n 2 2 TRTA Xanomeline High Dose ..ard_hierarchical_overall.. n 2 3 TRTA Xanomeline Low Dose ..ard_hierarchical_overall.. n 2 4 NULL ..ard_hierarchical_overall.. n 6 cards/tests/testthat/_snaps/eval_capture_conditions.md0000644000176200001440000000473414770617003023075 0ustar liggesusers# eval_capture_conditions() works Code eval_capture_conditions(expr(TRUE)) Output $result [1] TRUE $warning NULL $error NULL attr(,"class") [1] "captured_condition" "list" --- Code eval_capture_conditions(expr(cli::cli_abort("BIG ERROR"))) Output $result NULL $warning NULL $error [1] "BIG ERROR" attr(,"class") [1] "captured_condition" "list" --- Code one_warn_foo <- (function() { cli::cli_warn("BIG WARNING") TRUE }) eval_capture_conditions(expr(one_warn_foo())) Output $result [1] TRUE $warning [1] "BIG WARNING" $error NULL attr(,"class") [1] "captured_condition" "list" --- Code two_warn_foo <- (function() { cli::cli_warn("{.emph BIG} WARNING1") cli::cli_warn("{.emph BIG} WARNING2") TRUE }) eval_capture_conditions(expr(two_warn_foo())) Output $result [1] TRUE $warning [1] "BIG WARNING1" "BIG WARNING2" $error NULL attr(,"class") [1] "captured_condition" "list" # captured_condition_as_message() works Code captured_condition_as_message(eval_capture_conditions(stop( "This is an {error}!"))) Message The following error occured: x This is an {error}! Output NULL --- Code captured_condition_as_message(eval_capture_conditions({ warning("This is a {warning} 1") warning("This is a {warning} 2") NULL }), type = "warning") Message The following warning occured: x This is a {warning} 1 and This is a {warning} 2 Output NULL # captured_condition_as_error() works Code captured_condition_as_error(eval_capture_conditions(stop("This is an {error}!"))) Condition Error in `captured_condition_as_error()`: ! The following error occured: x This is an {error}! --- Code captured_condition_as_error(eval_capture_conditions({ warning("This is a {warning} 1") warning("This is a {warning} 2") NULL }), type = "warning") Condition Error in `captured_condition_as_error()`: ! The following warning occured: x This is a {warning} 1 and This is a {warning} 2 cards/tests/testthat/_snaps/update_ard.md0000644000176200001440000001004514770617011020271 0ustar liggesusers# update_ard_fmt_fn() Code update_ard_fmt_fn(ard_continuous(ADSL, variables = AGE), stat_names = c("mean", "sd"), fmt_fn = -8L) Condition Error in `update_ard_fmt_fn()`: ! The value in `fmt_fn` cannot be converted into a function. i Value must be a function, a non-negative integer, or a formatting string, e.g. "xx.x". * See `?cards::alias_as_fmt_fn()` for details. # update_ard_fmt_fn(filter) Code apply_fmt_fn(update_ard_fmt_fn(ard_continuous(ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean"))), stat_names = "mean", fmt_fn = 8L, filter = group1_level == "Placebo")) Message {cards} data frame: 6 x 11 Output group1 group1_level variable stat_name stat_label stat stat_fmt 1 ARM Placebo AGE N N 86 86 2 ARM Placebo AGE mean Mean 75.209 75.20930233 3 ARM Xanomeli… AGE N N 84 84 4 ARM Xanomeli… AGE mean Mean 74.381 74.4 5 ARM Xanomeli… AGE N N 84 84 6 ARM Xanomeli… AGE mean Mean 75.667 75.7 Message i 4 more variables: context, fmt_fn, warning, error # update_ard_fmt_fn(filter) messaging Code update_ard_fmt_fn(ard_continuous(ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean"))), stat_names = "mean", fmt_fn = 8L, filter = group99999999_level == "Placebo") Condition Error in `update_ard_fmt_fn()`: ! There was an error evaluating the `filter` argument. See below: x object 'group99999999_level' not found --- Code update_ard_fmt_fn(ard_continuous(ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean"))), stat_names = "mean", fmt_fn = 8L, filter = c(TRUE, FALSE)) Condition Error in `update_ard_fmt_fn()`: ! The `filter` argument must be an expression that evaluates to a vector of length 1 or 6. # update_ard_stat_label(filter) Code update_ard_stat_label(ard_continuous(ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean", "sd"))), stat_names = c( "mean", "sd"), stat_label = "Mean (SD)", filter = group1_level == "Placebo") Message {cards} data frame: 9 x 10 Output group1 group1_level variable stat_name stat_label stat 1 ARM Placebo AGE N N 86 2 ARM Placebo AGE mean Mean (SD) 75.209 3 ARM Placebo AGE sd Mean (SD) 8.59 4 ARM Xanomeli… AGE N N 84 5 ARM Xanomeli… AGE mean Mean 74.381 6 ARM Xanomeli… AGE sd SD 7.886 7 ARM Xanomeli… AGE N N 84 8 ARM Xanomeli… AGE mean Mean 75.667 9 ARM Xanomeli… AGE sd SD 8.286 Message i 4 more variables: context, fmt_fn, warning, error # update_ard_stat_label(filter) messaging Code update_ard_stat_label(ard_continuous(ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean", "sd"))), stat_names = c( "mean", "sd"), stat_label = "Mean (SD)", filter = group99999999_level == "Placebo") Condition Error in `value[[3L]]()`: ! There was an error evaluating the `filter` argument. See below: x object 'group99999999_level' not found --- Code update_ard_stat_label(ard_continuous(ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean", "sd"))), stat_names = c( "mean", "sd"), stat_label = "Mean (SD)", filter = c(TRUE, FALSE)) Condition Error in `update_ard_stat_label()`: ! The `filter` argument must be an expression that evaluates to a vector of length 1 or 9. cards/tests/testthat/_snaps/check_ard_structure.md0000644000176200001440000000070614770617003022210 0ustar liggesusers# check_ard_structure() works Code check_ard_structure(structure(dplyr::select(dplyr::mutate(ard_continuous(ADSL, variables = "AGE"), stat = unlist(stat)), -error), class = "data.frame")) Message Object is not of class . The following columns are not present: "error". Expecting a row with `stat_name = 'method'`, but it is not present. The following columns are expected to be list columns: "stat". cards/tests/testthat/_snaps/shuffle_ard.md0000644000176200001440000001330614776252447020464 0ustar liggesusers# shuffle/trim works Code ard_simple_shuffled Output variable context stat_name stat_label stat fmt_fn warning error 1 AGE continuous N N 254.000000 0 NULL NULL 2 AGE continuous mean Mean 75.086614 1 NULL NULL 3 AGE continuous sd SD 8.246234 1 NULL NULL 4 AGE continuous median Median 77.000000 1 NULL NULL 5 AGE continuous p25 Q1 70.000000 1 NULL NULL 6 AGE continuous p75 Q3 81.000000 1 NULL NULL 7 AGE continuous min Min 51.000000 1 NULL NULL 8 AGE continuous max Max 89.000000 1 NULL NULL --- Code ard_shuffled[1:5, ] Output ARM variable variable_level context stat_name stat_label stat 1 Placebo ARM Placebo categorical n n 86.0000000 2 Placebo ARM Placebo categorical N N 254.0000000 3 Placebo ARM Placebo categorical p % 0.3385827 4 Xanomeline High Dose ARM Xanomeline High Dose categorical n n 84.0000000 5 Xanomeline High Dose ARM Xanomeline High Dose categorical N N 254.0000000 --- Code ard_shuff_trim[1:5, ] Output ARM variable variable_level context stat_name stat_label stat 1 Placebo ARM Placebo categorical n n 86.0000000 2 Placebo ARM Placebo categorical N N 254.0000000 3 Placebo ARM Placebo categorical p % 0.3385827 4 Xanomeline High Dose ARM Xanomeline High Dose categorical n n 84.0000000 5 Xanomeline High Dose ARM Xanomeline High Dose categorical N N 254.0000000 # shuffle_ard notifies user about warnings/errors before dropping Code shuffle_ard(ard_continuous(ADSL, variables = AGEGR1)) Message "warning" column contains messages that will be removed. Output # A tibble: 8 x 5 variable context stat_name stat_label stat 1 AGEGR1 continuous N N 254 2 AGEGR1 continuous mean Mean 3 AGEGR1 continuous sd SD 4 AGEGR1 continuous median Median 5 AGEGR1 continuous p25 Q1 65-80 6 AGEGR1 continuous p75 Q3 >80 7 AGEGR1 continuous min Min 65-80 8 AGEGR1 continuous max Max >80 # shuffle_ard fills missing group levels if the group is meaningful Code shuffle_ard(dplyr::filter(bind_ard(ard_continuous(ADSL, by = "ARM", variables = "AGE", statistic = ~ continuous_summary_fns("mean")), dplyr::tibble(group1 = "ARM", variable = "AGE", stat_name = "p", stat_label = "p", stat = list(0.05))), dplyr::row_number() <= 5L)) Output # A tibble: 4 x 6 ARM variable context stat_name stat_label stat 1 Placebo AGE continuous mean Mean 75.2 2 Xanomeline High Dose AGE continuous mean Mean 74.4 3 Xanomeline Low Dose AGE continuous mean Mean 75.7 4 Overall ARM AGE p p 0.05 --- Code shuffle_ard(dplyr::filter(bind_ard(ard_continuous(ADSL, variables = "AGE", statistic = ~ continuous_summary_fns("mean")), dplyr::tibble(group1 = "ARM", variable = "AGE", stat_name = "p", stat_label = "p", stat = list(0.05))), dplyr::row_number() <= 5L)) Output # A tibble: 2 x 6 ARM variable context stat_name stat_label stat 1 AGE continuous mean Mean 75.1 2 Overall ARM AGE p p 0.05 --- Code as.data.frame(shuffle_ard(bind_ard(dplyr::slice(ard_categorical(ADSL, by = ARM, variables = AGEGR1), 1), dplyr::slice(ard_categorical(ADSL, variables = AGEGR1), 1), dplyr::slice(ard_continuous(ADSL, by = SEX, variables = AGE), 1), dplyr::slice(ard_continuous(ADSL, variables = AGE), 1)))) Output ARM SEX variable variable_level context stat_name stat_label stat 1 Placebo AGEGR1 65-80 categorical n n 42 2 Overall ARM AGEGR1 65-80 categorical n n 144 3 Overall SEX AGE continuous N N 254 4 F AGE continuous N N 143 # shuffle_ard fills missing group levels if the group is meaningful for cardx output Code as.data.frame(shuffle_ard(ard_cardx)) Output ARM SEX variable context stat_name stat_label stat 1 Overall ARM AGEGR1 stats_chisq_test statistic X-squared Statistic 5.07944167 2 Overall ARM AGEGR1 stats_chisq_test p.value p-value 0.07888842 3 Overall SEX AGEGR1 stats_chisq_test statistic X-squared Statistic 1.03944200 4 Overall SEX AGEGR1 stats_chisq_test p.value p-value 0.59468644 cards/tests/testthat/_snaps/mock.md0000644000176200001440000001606114770617004017120 0ustar liggesusers# mock_categorical() Code apply_fmt_fn(mock_categorical(variables = list(AGEGR1 = factor(c("<65", "65-80", ">80"), levels = c("<65", "65-80", ">80"))), by = list( TRTA = c("Placebo", "Xanomeline High Dose", "Xanomeline Low Dose")))) Message {cards} data frame: 27 x 12 Output group1 group1_level variable variable_level stat_name stat_label stat stat_fmt 1 TRTA Placebo AGEGR1 <65 n n xx 2 TRTA Placebo AGEGR1 <65 p % xx.x 3 TRTA Placebo AGEGR1 <65 N N xx 4 TRTA Placebo AGEGR1 65-80 n n xx 5 TRTA Placebo AGEGR1 65-80 p % xx.x 6 TRTA Placebo AGEGR1 65-80 N N xx 7 TRTA Placebo AGEGR1 >80 n n xx 8 TRTA Placebo AGEGR1 >80 p % xx.x 9 TRTA Placebo AGEGR1 >80 N N xx 10 TRTA Xanomeli… AGEGR1 <65 n n xx Message i 17 more rows i Use `print(n = ...)` to see more rows i 4 more variables: context, fmt_fn, warning, error # mock_categorical() messaging Code mock_categorical(variables = list(AGEGR1 = factor(c("<65", "65-80", ">80"), levels = c("<65", "65-80", ">80"))), statistic = ~ c("NOTASTATISTIC")) Condition Error in `mock_categorical()`: ! The elements of the `statistic` argument must be vector with one or more of "n", "p", and "N". # mock_continuous() Code apply_fmt_fn(mock_continuous(variables = c("AGE", "BMIBL"))) Message {cards} data frame: 16 x 9 Output variable context stat_name stat_label stat stat_fmt 1 AGE continuo… N N xx 2 AGE continuo… mean Mean xx.x 3 AGE continuo… sd SD xx.x 4 AGE continuo… median Median xx.x 5 AGE continuo… p25 Q1 xx.x 6 AGE continuo… p75 Q3 xx.x 7 AGE continuo… min Min xx.x 8 AGE continuo… max Max xx.x 9 BMIBL continuo… N N xx 10 BMIBL continuo… mean Mean xx.x 11 BMIBL continuo… sd SD xx.x 12 BMIBL continuo… median Median xx.x 13 BMIBL continuo… p25 Q1 xx.x 14 BMIBL continuo… p75 Q3 xx.x 15 BMIBL continuo… min Min xx.x 16 BMIBL continuo… max Max xx.x Message i 3 more variables: fmt_fn, warning, error # mock_continuous() messaging Code mock_continuous(variables = c("AGE", "BMIBL"), statistic = ~t.test) Condition Error in `mock_continuous()`: ! The elements of the `statistic` argument must be vector of statistic names. # mock_dichotomous() Code apply_fmt_fn(mock_dichotomous(variables = list(AGEGR1 = factor("65-80", levels = c("<65", "65-80", ">80"))), by = list(TRTA = c( "Placebo", "Xanomeline High Dose", "Xanomeline Low Dose")))) Message {cards} data frame: 9 x 12 Output group1 group1_level variable variable_level stat_name stat_label stat stat_fmt 1 TRTA Placebo AGEGR1 65-80 n n xx 2 TRTA Placebo AGEGR1 65-80 p % xx.x 3 TRTA Placebo AGEGR1 65-80 N N xx 4 TRTA Xanomeli… AGEGR1 65-80 n n xx 5 TRTA Xanomeli… AGEGR1 65-80 p % xx.x 6 TRTA Xanomeli… AGEGR1 65-80 N N xx 7 TRTA Xanomeli… AGEGR1 65-80 n n xx 8 TRTA Xanomeli… AGEGR1 65-80 p % xx.x 9 TRTA Xanomeli… AGEGR1 65-80 N N xx Message i 4 more variables: context, fmt_fn, warning, error # mock_dichotomous() messaging Code mock_dichotomous(variables = list(AGEGR1 = factor(c("<65", "65-80", ">80"), levels = c("<65", "65-80", ">80"))), by = list(TRTA = c("Placebo", "Xanomeline High Dose", "Xanomeline Low Dose"))) Condition Error in `mock_dichotomous()`: ! The list values of `variables` argument must be length 1. # mock_missing() Code apply_fmt_fn(mock_missing(variables = c("AGE", "BMIBL"))) Message {cards} data frame: 10 x 9 Output variable context stat_name stat_label stat stat_fmt 1 AGE missing N_obs Vector L… xx 2 AGE missing N_miss N Missing xx 3 AGE missing N_nonmiss N Non-mi… xx 4 AGE missing p_miss % Missing xx.x 5 AGE missing p_nonmiss % Non-mi… xx.x 6 BMIBL missing N_obs Vector L… xx 7 BMIBL missing N_miss N Missing xx 8 BMIBL missing N_nonmiss N Non-mi… xx 9 BMIBL missing p_miss % Missing xx.x 10 BMIBL missing p_nonmiss % Non-mi… xx.x Message i 3 more variables: fmt_fn, warning, error # mock_missing() messaging Code mock_missing(variables = c("AGE", "BMIBL"), statistic = ~letters) Condition Error in `mock_missing()`: ! The elements of the `statistic` argument must be vector with one or more of "N_obs", "N_miss", "N_nonmiss", "p_miss", and "p_nonmiss". # mock_attributes() Code mock_attributes(label = list(AGE = "Age", BMIBL = "Baseline BMI")) Message {cards} data frame: 4 x 8 Output variable context stat_name stat_label stat fmt_fn 1 AGE attribut… label Variable… Age 2 AGE attribut… class Variable… logical NULL 3 BMIBL attribut… label Variable… Baseline… 4 BMIBL attribut… class Variable… logical NULL Message i 2 more variables: warning, error # mock_attributes() messaging Code mock_attributes(label = c("AGE", "BMIBL")) Condition Error in `mock_attributes()`: ! The `label` argument must be a named list. # mock_total_n() Code apply_fmt_fn(mock_total_n()) Message {cards} data frame: 1 x 9 Output variable context stat_name stat_label stat stat_fmt 1 ..ard_total_n.. total_n N N xx Message i 3 more variables: fmt_fn, warning, error cards/tests/testthat/_snaps/ard_hierarchical.md0000644000176200001440000000700314770616770021440 0ustar liggesusers# ard_hierarchical() works without by variables Code class(ard_heir_no_by) Output [1] "card" "tbl_df" "tbl" "data.frame" # ard_hierarchical() works without any variables Code ard_hierarchical(data = ADAE, variables = starts_with("xxxx"), by = c(TRTA, AESEV)) Message {cards} data frame: 0 x 0 Output data frame with 0 columns and 0 rows # ard_hierarchical(id) argument works Code head(ard_hierarchical(data = ADAE, variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV), denominator = dplyr::rename(ADSL, TRTA = ARM), id = USUBJID), 1L) Condition Warning: Duplicate rows found in data for the "USUBJID" column. i Percentages/Denominators are not correct. Message {cards} data frame: 1 x 15 Output group1 group1_level group2 group2_level group3 group3_level variable 1 TRTA Placebo AESEV MILD AESOC CARDIAC … AEDECOD variable_level stat_name stat_label stat 1 ATRIAL F… n n 0 Message i 4 more variables: context, fmt_fn, warning, error --- Code head(ard_hierarchical(data = ADAE, variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV), denominator = dplyr::rename(ADSL, TRTA = ARM), id = c(USUBJID, SITEID)), 1L) Condition Warning: Duplicate rows found in data for the "USUBJID" and "SITEID" columns. i Percentages/Denominators are not correct. Message {cards} data frame: 1 x 15 Output group1 group1_level group2 group2_level group3 group3_level variable 1 TRTA Placebo AESEV MILD AESOC CARDIAC … AEDECOD variable_level stat_name stat_label stat 1 ATRIAL F… n n 0 Message i 4 more variables: context, fmt_fn, warning, error # ard_hierarchical_count() works without by variables Code class(ard_heir_no_by) Output [1] "card" "tbl_df" "tbl" "data.frame" # ard_hierarchical_count() works without any variables Code ard_hierarchical_count(data = ADAE, variables = starts_with("xxxx"), by = c( TRTA, AESEV)) Message {cards} data frame: 0 x 0 Output data frame with 0 columns and 0 rows # ard_hierarchical() errors with incomplete factor columns Code ard_hierarchical(dplyr::mutate(mtcars, am = factor(am, levels = character(0))), variables = c(vs, am)) Condition Error in `ard_hierarchical()`: ! Factors with empty "levels" attribute are not allowed, which was identified in column "am". --- Code ard_hierarchical(dplyr::mutate(mtcars, am = factor(am, levels = c(0, 1, NA), exclude = NULL)), variables = c(vs, am)) Condition Error in `ard_hierarchical()`: ! Factors with NA levels are not allowed, which are present in column "am". # ard_hierarchical_count() errors with incomplete factor columns Code ard_hierarchical_count(dplyr::mutate(mtcars, am = factor(am, levels = character( 0))), variables = c(vs, am)) Condition Error in `ard_hierarchical_count()`: ! Factors with empty "levels" attribute are not allowed, which was identified in column "am". --- Code ard_hierarchical_count(dplyr::mutate(mtcars, am = factor(am, levels = c(0, 1, NA), exclude = NULL)), variables = c(vs, am)) Condition Error in `ard_hierarchical_count()`: ! Factors with NA levels are not allowed, which are present in column "am". cards/tests/testthat/_snaps/apply_fmt_fn.md0000644000176200001440000000544314770616754020662 0ustar liggesusers# apply_fmt_fn() error messaging Code apply_fmt_fn(letters) Condition Error in `apply_fmt_fn()`: ! The `x` argument must be class , not a character vector. --- Code apply_fmt_fn(dplyr::mutate(ard_fmt_checks, fmt_fn = list("xoxo", "xoxo"))) Condition Error in `dplyr::mutate()`: i In argument: `stat_fmt = pmap(...)`. Caused by error in `apply_fmt_fn()`: ! There was an error applying the formatting function to statistic "mean" for variable "mpg". i Perhaps try formmatting function `as.character()`? See error message below: x The format "xoxo" for `fmt_fn` is not valid for the variable "mpg" for the statistic "mean". String must begin with 'x' and only consist of x's, a single period or none, and may end with a percent symbol. --- Code apply_fmt_fn(dplyr::mutate(ard_fmt_checks, fmt_fn = list(1L, -1L))) Condition Error in `dplyr::mutate()`: i In argument: `stat_fmt = pmap(...)`. Caused by error in `apply_fmt_fn()`: ! There was an error applying the formatting function to statistic "sd" for variable "mpg". i Perhaps try formmatting function `as.character()`? See error message below: x The value in `fmt_fn` cannot be converted into a function for statistic "sd" and variable "mpg". i Value must be a function, a non-negative integer, or a formatting string, e.g. "xx.x". * See `?cards::alias_as_fmt_fn()` for details. --- Code as.data.frame(apply_fmt_fn(dplyr::mutate(ard_fmt_checks, stat = lapply(stat, function(x) x * 1000), fmt_fn = list("xx", "xx")))) Output variable context stat_name stat_label stat stat_fmt fmt_fn warning 1 mpg continuous mean Mean 20090.62 20091 xx NULL 2 mpg continuous sd SD 6026.948 6027 xx NULL error 1 NULL 2 NULL # apply_fmt_fn(replace) Code apply_fmt_fn(ard, replace = FALSE) Message {cards} data frame: 3 x 10 Output variable variable_level stat_name stat_label stat stat_fmt 1 AGEGR1 65-80 n n 144 144.000000 2 AGEGR1 <65 n n 33 33 3 AGEGR1 >80 n n 77 77 Message i 4 more variables: context, fmt_fn, warning, error --- Code apply_fmt_fn(ard, replace = TRUE) Message {cards} data frame: 3 x 10 Output variable variable_level stat_name stat_label stat stat_fmt 1 AGEGR1 65-80 n n 144 144 2 AGEGR1 <65 n n 33 33 3 AGEGR1 >80 n n 77 77 Message i 4 more variables: context, fmt_fn, warning, error cards/tests/testthat/_snaps/ard_total_n.md0000644000176200001440000000064014770617002020447 0ustar liggesusers# ard_total_n() works Code as.data.frame(ard_total_n(ADSL)) Output variable context stat_name stat_label stat fmt_fn warning error 1 ..ard_total_n.. total_n N N 254 0 NULL NULL --- Code ard_total_n(letters) Condition Error in `UseMethod()`: ! no applicable method for 'ard_total_n' applied to an object of class "character" cards/tests/testthat/_snaps/ard_pairwise.md0000644000176200001440000000346514770616771020656 0ustar liggesusers# ard_pairwise(variable) messaging Code ard_pairwise(ADSL, variable = c(ARM, AGEGR1), .f = function(df) ard_complex(df, variables = AGE, statistic = ~ list(ttest = ttest_fn))) Condition Error in `ard_pairwise()`: ! The `variable` argument must be length 1. --- Code ard_pairwise(ADSL, variable = NOT_A_COLUMN, .f = function(df) ard_complex(df, variables = AGE, statistic = ~ list(ttest = ttest_fn))) Condition Error in `ard_pairwise()`: ! Error processing `variable` argument. ! Can't select columns that don't exist. x Column `NOT_A_COLUMN` doesn't exist. i Select among columns "STUDYID", "USUBJID", "SUBJID", "SITEID", "SITEGR1", "ARM", "TRT01P", "TRT01PN", "TRT01A", "TRT01AN", "TRTSDT", "TRTEDT", "TRTDUR", "AVGDD", "CUMDOSE", "AGE", "AGEGR1", "AGEGR1N", ..., "DCREASCD", and "MMSETOT" # ard_pairwise(.f) messaging Code ard_pairwise(ADSL, variable = ARM, .f = function(df) stop("I MADE THIS ERROR")) Condition Error in `ard_pairwise()`: ! The following error occurred for 'Placebo' vs. 'Xanomeline High Dose'. See message below. x I MADE THIS ERROR # ard_pairwise(include) messaging Code ard_pairwise(ADSL, variable = ARM, .f = function(df) ard_complex(df, variables = AGE, statistic = ~ list(ttest = ttest_fn)), include = "NOT_A_LEVEL") Condition Error in `ard_pairwise()`: ! The `include` argument must be NULL or one or more of "Placebo", "Xanomeline High Dose", and "Xanomeline Low Dose". --- Code ard_pairwise(ADSL, variable = ARM, .f = function(df) ard_complex(df, variables = AGE, statistic = ~ list(ttest = ttest_fn)), include = mtcars) Condition Error in `ard_pairwise()`: ! The `include` argument must be a simple vector, not a data frame. cards/tests/testthat/_snaps/ard_attributes.md0000644000176200001440000000207214770616754021213 0ustar liggesusers# ard_attributes() works Code df <- dplyr::tibble(var1 = letters, var2 = LETTERS) attr(df$var1, "label") <- "Lowercase Letters" as.data.frame(ard_attributes(df, variables = everything(), label = list(var2 = "UPPERCASE LETTERS"))) Output variable context stat_name stat_label stat fmt_fn warning error 1 var1 attributes label Variable Label Lowercase Letters .Primitive("as.character") NULL NULL 2 var1 attributes class Variable Class character NULL NULL NULL 3 var2 attributes label Variable Label UPPERCASE LETTERS .Primitive("as.character") NULL NULL 4 var2 attributes class Variable Class character NULL NULL NULL # ard_attributes() requires label as a named list Code ard_attributes(ADSL[c("AGE", "AGEGR1")], label = list("test")) Condition Error in `ard_attributes()`: ! The `label` argument must be a named list with each element a string. cards/tests/testthat/_snaps/ard_dichotomous.md0000644000176200001440000000515114770616763021363 0ustar liggesusers# ard_dichotomous() works Code class(ard_dich) Output [1] "card" "tbl_df" "tbl" "data.frame" --- Code as.data.frame(dplyr::select(ard_dich, -c(fmt_fn, warning, error))) Output variable variable_level context stat_name stat_label stat 1 cyl 4 dichotomous n n 11 2 cyl 4 dichotomous N N 32 3 cyl 4 dichotomous p % 0.34375 4 am TRUE dichotomous n n 13 5 am TRUE dichotomous N N 32 6 am TRUE dichotomous p % 0.40625 7 gear 3 dichotomous n n 5 8 gear 3 dichotomous N N 32 9 gear 3 dichotomous p % 0.15625 --- Code ard_dichotomous(mtcars, variables = c("cyl", "am", "gear"), value = list(cyl = letters)) Condition Error in `ard_dichotomous()`: ! Error in argument `value` for variable "cyl". i The value must be one of 4, 6, and 8. --- Code ard_dichotomous(iris, variables = everything(), value = list(Species = "not_a_species")) Condition Error in `ard_dichotomous()`: ! Error in argument `value` for variable "Species". i A value of "not_a_species" was passed, but must be one of setosa, versicolor, and virginica. i To summarize this value, use `forcats::fct_expand()` to add "not_a_species" as a level. --- Code ard_dichotomous(mtcars, variables = c("cyl", "am", "gear"), value = list(cyl = 100)) Condition Error in `ard_dichotomous()`: ! Error in argument `value` for variable "cyl". i A value of 100 was passed, but must be one of 4, 6, and 8. i To summarize this value, make the column a factor and include 100 as a level. # ard_dichotomous() errors with incomplete factor columns Code ard_dichotomous(dplyr::mutate(mtcars, am = factor(am, levels = character(0))), variables = c(cyl, vs), by = am, value = list(cyl = 4)) Condition Error in `ard_dichotomous()`: ! Factors with empty "levels" attribute are not allowed, which was identified in column "am". --- Code ard_dichotomous(dplyr::mutate(mtcars, am = factor(am, levels = c(0, 1, NA), exclude = NULL)), variables = c(cyl, am), value = list(cyl = 4)) Condition Error in `ard_dichotomous()`: ! Factors with NA levels are not allowed, which are present in column "am". cards/tests/testthat/_snaps/ard_complex.md0000644000176200001440000000200714770616754020472 0ustar liggesusers# ard_complex() messaging Code ard_complex(ADSL, by = "ARM", variables = c("AGE", "BMIBL"), statistic = list( AGE = list(mean = function(x, ...) mean(x)))) Condition Error in `ard_complex()`: ! The following columns do not have `statistic` defined: "BMIBL". # ard_complex() errors with incorrect factor columns Code ard_complex(dplyr::mutate(mtcars, am = factor(am, levels = character(0))), by = "am", variables = "mpg", statistic = list(mpg = list(mean = function(x, ...) mean(x)))) Condition Error in `ard_complex()`: ! Factors with empty "levels" attribute are not allowed, which was identified in column "am". --- Code ard_complex(dplyr::mutate(mtcars, am = factor(am, levels = c(0, 1, NA), exclude = NULL)), by = "am", variables = "mpg", statistic = list(mpg = list( mean = function(x, ...) mean(x)))) Condition Error in `ard_complex()`: ! Factors with NA levels are not allowed, which are present in column "am". cards/tests/testthat/_snaps/as_nested_list.md0000644000176200001440000003156514770617003021174 0ustar liggesusers# as_nested_list() works Code as_nested_list(ard_continuous(mtcars, by = "cyl", variables = "hp")) Output $variable $variable$hp $variable$hp$group1 $variable$hp$group1$cyl $variable$hp$group1$cyl$group1_level $variable$hp$group1$cyl$group1_level$`4` $variable$hp$group1$cyl$group1_level$`4`$stat_name $variable$hp$group1$cyl$group1_level$`4`$stat_name$N $variable$hp$group1$cyl$group1_level$`4`$stat_name$N$stat [1] 11 $variable$hp$group1$cyl$group1_level$`4`$stat_name$N$stat_fmt [1] "11" $variable$hp$group1$cyl$group1_level$`4`$stat_name$N$warning NULL $variable$hp$group1$cyl$group1_level$`4`$stat_name$N$error NULL $variable$hp$group1$cyl$group1_level$`4`$stat_name$N$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`4`$stat_name$mean $variable$hp$group1$cyl$group1_level$`4`$stat_name$mean$stat [1] 82.63636 $variable$hp$group1$cyl$group1_level$`4`$stat_name$mean$stat_fmt [1] "82.6" $variable$hp$group1$cyl$group1_level$`4`$stat_name$mean$warning NULL $variable$hp$group1$cyl$group1_level$`4`$stat_name$mean$error NULL $variable$hp$group1$cyl$group1_level$`4`$stat_name$mean$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`4`$stat_name$sd $variable$hp$group1$cyl$group1_level$`4`$stat_name$sd$stat [1] 20.93453 $variable$hp$group1$cyl$group1_level$`4`$stat_name$sd$stat_fmt [1] "20.9" $variable$hp$group1$cyl$group1_level$`4`$stat_name$sd$warning NULL $variable$hp$group1$cyl$group1_level$`4`$stat_name$sd$error NULL $variable$hp$group1$cyl$group1_level$`4`$stat_name$sd$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`4`$stat_name$median $variable$hp$group1$cyl$group1_level$`4`$stat_name$median$stat [1] 91 $variable$hp$group1$cyl$group1_level$`4`$stat_name$median$stat_fmt [1] "91.0" $variable$hp$group1$cyl$group1_level$`4`$stat_name$median$warning NULL $variable$hp$group1$cyl$group1_level$`4`$stat_name$median$error NULL $variable$hp$group1$cyl$group1_level$`4`$stat_name$median$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`4`$stat_name$p25 $variable$hp$group1$cyl$group1_level$`4`$stat_name$p25$stat [1] 65 $variable$hp$group1$cyl$group1_level$`4`$stat_name$p25$stat_fmt [1] "65.0" $variable$hp$group1$cyl$group1_level$`4`$stat_name$p25$warning NULL $variable$hp$group1$cyl$group1_level$`4`$stat_name$p25$error NULL $variable$hp$group1$cyl$group1_level$`4`$stat_name$p25$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`4`$stat_name$p75 $variable$hp$group1$cyl$group1_level$`4`$stat_name$p75$stat [1] 97 $variable$hp$group1$cyl$group1_level$`4`$stat_name$p75$stat_fmt [1] "97.0" $variable$hp$group1$cyl$group1_level$`4`$stat_name$p75$warning NULL $variable$hp$group1$cyl$group1_level$`4`$stat_name$p75$error NULL $variable$hp$group1$cyl$group1_level$`4`$stat_name$p75$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`4`$stat_name$min $variable$hp$group1$cyl$group1_level$`4`$stat_name$min$stat [1] 52 $variable$hp$group1$cyl$group1_level$`4`$stat_name$min$stat_fmt [1] "52.0" $variable$hp$group1$cyl$group1_level$`4`$stat_name$min$warning NULL $variable$hp$group1$cyl$group1_level$`4`$stat_name$min$error NULL $variable$hp$group1$cyl$group1_level$`4`$stat_name$min$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`4`$stat_name$max $variable$hp$group1$cyl$group1_level$`4`$stat_name$max$stat [1] 113 $variable$hp$group1$cyl$group1_level$`4`$stat_name$max$stat_fmt [1] "113.0" $variable$hp$group1$cyl$group1_level$`4`$stat_name$max$warning NULL $variable$hp$group1$cyl$group1_level$`4`$stat_name$max$error NULL $variable$hp$group1$cyl$group1_level$`4`$stat_name$max$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`6` $variable$hp$group1$cyl$group1_level$`6`$stat_name $variable$hp$group1$cyl$group1_level$`6`$stat_name$N $variable$hp$group1$cyl$group1_level$`6`$stat_name$N$stat [1] 7 $variable$hp$group1$cyl$group1_level$`6`$stat_name$N$stat_fmt [1] "7" $variable$hp$group1$cyl$group1_level$`6`$stat_name$N$warning NULL $variable$hp$group1$cyl$group1_level$`6`$stat_name$N$error NULL $variable$hp$group1$cyl$group1_level$`6`$stat_name$N$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`6`$stat_name$mean $variable$hp$group1$cyl$group1_level$`6`$stat_name$mean$stat [1] 122.2857 $variable$hp$group1$cyl$group1_level$`6`$stat_name$mean$stat_fmt [1] "122.3" $variable$hp$group1$cyl$group1_level$`6`$stat_name$mean$warning NULL $variable$hp$group1$cyl$group1_level$`6`$stat_name$mean$error NULL $variable$hp$group1$cyl$group1_level$`6`$stat_name$mean$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`6`$stat_name$sd $variable$hp$group1$cyl$group1_level$`6`$stat_name$sd$stat [1] 24.26049 $variable$hp$group1$cyl$group1_level$`6`$stat_name$sd$stat_fmt [1] "24.3" $variable$hp$group1$cyl$group1_level$`6`$stat_name$sd$warning NULL $variable$hp$group1$cyl$group1_level$`6`$stat_name$sd$error NULL $variable$hp$group1$cyl$group1_level$`6`$stat_name$sd$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`6`$stat_name$median $variable$hp$group1$cyl$group1_level$`6`$stat_name$median$stat [1] 110 $variable$hp$group1$cyl$group1_level$`6`$stat_name$median$stat_fmt [1] "110.0" $variable$hp$group1$cyl$group1_level$`6`$stat_name$median$warning NULL $variable$hp$group1$cyl$group1_level$`6`$stat_name$median$error NULL $variable$hp$group1$cyl$group1_level$`6`$stat_name$median$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`6`$stat_name$p25 $variable$hp$group1$cyl$group1_level$`6`$stat_name$p25$stat [1] 110 $variable$hp$group1$cyl$group1_level$`6`$stat_name$p25$stat_fmt [1] "110.0" $variable$hp$group1$cyl$group1_level$`6`$stat_name$p25$warning NULL $variable$hp$group1$cyl$group1_level$`6`$stat_name$p25$error NULL $variable$hp$group1$cyl$group1_level$`6`$stat_name$p25$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`6`$stat_name$p75 $variable$hp$group1$cyl$group1_level$`6`$stat_name$p75$stat [1] 123 $variable$hp$group1$cyl$group1_level$`6`$stat_name$p75$stat_fmt [1] "123.0" $variable$hp$group1$cyl$group1_level$`6`$stat_name$p75$warning NULL $variable$hp$group1$cyl$group1_level$`6`$stat_name$p75$error NULL $variable$hp$group1$cyl$group1_level$`6`$stat_name$p75$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`6`$stat_name$min $variable$hp$group1$cyl$group1_level$`6`$stat_name$min$stat [1] 105 $variable$hp$group1$cyl$group1_level$`6`$stat_name$min$stat_fmt [1] "105.0" $variable$hp$group1$cyl$group1_level$`6`$stat_name$min$warning NULL $variable$hp$group1$cyl$group1_level$`6`$stat_name$min$error NULL $variable$hp$group1$cyl$group1_level$`6`$stat_name$min$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`6`$stat_name$max $variable$hp$group1$cyl$group1_level$`6`$stat_name$max$stat [1] 175 $variable$hp$group1$cyl$group1_level$`6`$stat_name$max$stat_fmt [1] "175.0" $variable$hp$group1$cyl$group1_level$`6`$stat_name$max$warning NULL $variable$hp$group1$cyl$group1_level$`6`$stat_name$max$error NULL $variable$hp$group1$cyl$group1_level$`6`$stat_name$max$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`8` $variable$hp$group1$cyl$group1_level$`8`$stat_name $variable$hp$group1$cyl$group1_level$`8`$stat_name$N $variable$hp$group1$cyl$group1_level$`8`$stat_name$N$stat [1] 14 $variable$hp$group1$cyl$group1_level$`8`$stat_name$N$stat_fmt [1] "14" $variable$hp$group1$cyl$group1_level$`8`$stat_name$N$warning NULL $variable$hp$group1$cyl$group1_level$`8`$stat_name$N$error NULL $variable$hp$group1$cyl$group1_level$`8`$stat_name$N$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`8`$stat_name$mean $variable$hp$group1$cyl$group1_level$`8`$stat_name$mean$stat [1] 209.2143 $variable$hp$group1$cyl$group1_level$`8`$stat_name$mean$stat_fmt [1] "209.2" $variable$hp$group1$cyl$group1_level$`8`$stat_name$mean$warning NULL $variable$hp$group1$cyl$group1_level$`8`$stat_name$mean$error NULL $variable$hp$group1$cyl$group1_level$`8`$stat_name$mean$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`8`$stat_name$sd $variable$hp$group1$cyl$group1_level$`8`$stat_name$sd$stat [1] 50.97689 $variable$hp$group1$cyl$group1_level$`8`$stat_name$sd$stat_fmt [1] "51.0" $variable$hp$group1$cyl$group1_level$`8`$stat_name$sd$warning NULL $variable$hp$group1$cyl$group1_level$`8`$stat_name$sd$error NULL $variable$hp$group1$cyl$group1_level$`8`$stat_name$sd$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`8`$stat_name$median $variable$hp$group1$cyl$group1_level$`8`$stat_name$median$stat [1] 192.5 $variable$hp$group1$cyl$group1_level$`8`$stat_name$median$stat_fmt [1] "192.5" $variable$hp$group1$cyl$group1_level$`8`$stat_name$median$warning NULL $variable$hp$group1$cyl$group1_level$`8`$stat_name$median$error NULL $variable$hp$group1$cyl$group1_level$`8`$stat_name$median$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`8`$stat_name$p25 $variable$hp$group1$cyl$group1_level$`8`$stat_name$p25$stat [1] 175 $variable$hp$group1$cyl$group1_level$`8`$stat_name$p25$stat_fmt [1] "175.0" $variable$hp$group1$cyl$group1_level$`8`$stat_name$p25$warning NULL $variable$hp$group1$cyl$group1_level$`8`$stat_name$p25$error NULL $variable$hp$group1$cyl$group1_level$`8`$stat_name$p25$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`8`$stat_name$p75 $variable$hp$group1$cyl$group1_level$`8`$stat_name$p75$stat [1] 245 $variable$hp$group1$cyl$group1_level$`8`$stat_name$p75$stat_fmt [1] "245.0" $variable$hp$group1$cyl$group1_level$`8`$stat_name$p75$warning NULL $variable$hp$group1$cyl$group1_level$`8`$stat_name$p75$error NULL $variable$hp$group1$cyl$group1_level$`8`$stat_name$p75$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`8`$stat_name$min $variable$hp$group1$cyl$group1_level$`8`$stat_name$min$stat [1] 150 $variable$hp$group1$cyl$group1_level$`8`$stat_name$min$stat_fmt [1] "150.0" $variable$hp$group1$cyl$group1_level$`8`$stat_name$min$warning NULL $variable$hp$group1$cyl$group1_level$`8`$stat_name$min$error NULL $variable$hp$group1$cyl$group1_level$`8`$stat_name$min$context [1] "continuous" $variable$hp$group1$cyl$group1_level$`8`$stat_name$max $variable$hp$group1$cyl$group1_level$`8`$stat_name$max$stat [1] 335 $variable$hp$group1$cyl$group1_level$`8`$stat_name$max$stat_fmt [1] "335.0" $variable$hp$group1$cyl$group1_level$`8`$stat_name$max$warning NULL $variable$hp$group1$cyl$group1_level$`8`$stat_name$max$error NULL $variable$hp$group1$cyl$group1_level$`8`$stat_name$max$context [1] "continuous" cards/tests/testthat/_snaps/process_selectors.md0000644000176200001440000000111314770617006021722 0ustar liggesusers# process_formula_selectors() error messaging Code process_formula_selectors(mtcars, variables = list(letters)) Condition Error: ! The `variables` argument must be a named list, list of formulas, a single formula, or empty. i Review ?syntax (`?cards::syntax()`) for examples and details. # compute_formula_selector() selects the last assignment when multiple appear Code lapply(lst_compute_test, function(x) structure(x, .Environment = NULL)) Output $hp [1] "THE DEFAULT" $mpg [1] "Special for MPG" cards/tests/testthat/test-tidy_as_ard.R0000644000176200001440000000523414567176413017754 0ustar liggesuserstest_that("tidy_as_ard() works", { # function works with standard use expect_snapshot( tidy_as_ard( lst_tidy = eval_capture_conditions( # this mimics a tidier stats::fisher.test(x = mtcars[["am"]], y = mtcars[["vs"]])[c("estimate", "p.value", "method")] |> dplyr::as_tibble() ), tidy_result_names = c("estimate", "p.value", "method"), fun_args_to_record = c( "workspace", "hybrid", "hybridPars", "control", "or", "conf.int", "conf.level", "simulate.p.value", "B" ), formals = formals(stats::fisher.test), passed_args = list(), lst_ard_columns = list(context = "fishertest", group1 = "am", variable = "vs") ) |> as.data.frame() ) # function works when primary stats function errors expect_snapshot( tidy_as_ard( lst_tidy = eval_capture_conditions( stop("Planned unit testing error!") ), tidy_result_names = c("estimate", "p.value", "conf.low", "conf.high", "method", "alternative"), fun_args_to_record = c( "workspace", "hybrid", "hybridPars", "control", "or", "conf.int", "conf.level", "simulate.p.value", "B" ), formals = formals(stats::fisher.test), passed_args = list(), lst_ard_columns = list(context = "fishertest", group1 = "am", variable = "vs") ) |> as.data.frame() ) # function works when `fun_args_to_record` argument is not passed. expect_snapshot( tidy_as_ard( lst_tidy = eval_capture_conditions( stats::fisher.test(x = mtcars[["am"]], y = mtcars[["vs"]])[c("estimate", "p.value", "method")] |> dplyr::as_tibble() ), tidy_result_names = c("estimate", "p.value", "conf.low", "conf.high", "method", "alternative"), formals = formals(stats::fisher.test), passed_args = list(), lst_ard_columns = list(context = "fishertest", group1 = "am", variable = "vs") ) |> as.data.frame() |> dplyr::select(c(group1, variable, stat)) ) # function works when `formals` argument is not passed. expect_snapshot( tidy_as_ard( lst_tidy = eval_capture_conditions( stats::fisher.test(x = mtcars[["am"]], y = mtcars[["vs"]])[c("estimate", "p.value", "method")] |> dplyr::as_tibble() ), tidy_result_names = c("estimate", "p.value", "conf.low", "conf.high", "method", "alternative"), passed_args = list(), lst_ard_columns = list(context = "fishertest", group1 = "am", variable = "vs") ) |> as.data.frame() |> dplyr::select(c(group1, variable, stat)) ) }) cards/tests/testthat/test-process_selectors.R0000644000176200001440000000656114645244422021230 0ustar liggesuserstest_that("process_selectors() works", { # works with a single argument expect_equal( { process_selectors(mtcars, variables = starts_with("a")) list(variables = variables) }, list(variables = "am") ) # works with more than on argument # styler: off expect_equal( {process_selectors(mtcars, variables = starts_with("a"), by = "am") list(variables = variables, by = by)}, list(variables = "am", by = "am") ) # styler: on # proper error messaging expect_error( process_selectors(mtcars, variables = not_a_column), "Select among*" ) }) test_that("process_formula_selectors() works", { # works with a single argument # styler: off expect_equal({ process_formula_selectors(mtcars, variables = starts_with("a") ~ 1L, include_env = TRUE) list(variables = variables)}, list(variables = list(am = 1L)), ignore_attr = TRUE ) # styler: on # works with more than on argument # styler: off expect_equal({ process_formula_selectors( mtcars, variables = starts_with("a") ~ 1L, by = list(am = 1L), include_env = TRUE ) list(variables = variables, by = by)}, list(variables = list(am = 1L), by = list(am = 1L)), ignore_attr = TRUE ) # styler: on }) test_that("process_formula_selectors() error messaging", { expect_snapshot( process_formula_selectors(mtcars, variables = list(letters)), error = TRUE ) expect_error( process_formula_selectors(mtcars, variables = list(not_a_column ~ letters)), "Select among*" ) }) test_that("compute_formula_selector() selects the last assignment when multiple appear", { formula_selcect_test <- everything() ~ "THE DEFAULT" expect_error( lst_compute_test <- compute_formula_selector( data = mtcars[c("mpg", "hp")], x = list(formula_selcect_test, mpg = "Special for MPG"), include_env = TRUE ), NA ) # test the formula env is the same as the attached attr env expect_equal( formula_selcect_test |> attr(".Environment"), lst_compute_test[["hp"]] |> attr(".Environment") ) # remove the env from the snapshot as it changes with each run. # just testing the values expect_snapshot( lst_compute_test |> lapply(\(x) structure(x, .Environment = NULL)) ) # named list elements that are not in `data` are removed from returned result expect_equal( compute_formula_selector( data = mtcars[c("mpg", "hp")], x = list(everything() ~ "THE DEFAULT", not_present = "Special for MPG") ), list(mpg = "THE DEFAULT", hp = "THE DEFAULT"), ignore_attr = TRUE ) expect_equal( compute_formula_selector( data = mtcars[c("mpg", "hp")], x = list(mpg = "THE DEFAULT", not_present = "Special for MPG") ), list(mpg = "THE DEFAULT") ) expect_equal( compute_formula_selector( data = mtcars[c("mpg", "hp")], x = list(not_present = "Special for MPG") ), list(NAME = NULL) |> compact() ) # styler: off expect_equal({ label <- list(ARM = "treatment", ARM = "TREATMENT") compute_formula_selector( ADSL, x = label )}, list(ARM = "TREATMENT") ) # styler: on }) # This check for `vars()` usage can be removed after Jan 1, 2025 test_that("cards_select() deprecation error with vars()", { expect_error( cards_select(vars(mpg), data = mtcars), class = "deprecated" ) }) cards/tests/testthat/test-ard_stack_hierarchical.R0000644000176200001440000004141614776242611022121 0ustar liggesusersADAE_small <- ADAE |> dplyr::filter(.by = TRTA, dplyr::row_number() <= 2L) |> dplyr::select("USUBJID", "TRTA", "AESOC", "AEDECOD", "AESEV") |> dplyr::mutate(AESEV = factor(AESEV)) # ard_stack_hierarchical() ----------------------------------------------------- test_that("ard_stack_hierarchical(variables)", { # ensure that all nested variables appear in resulting ARD expect_silent( ard <- ard_stack_hierarchical( ADAE_small, variables = c(AESOC, AEDECOD), id = USUBJID, denominator = ADSL |> dplyr::rename(TRTA = TRT01A) ) ) # check the number of rows is expected expect_equal( nrow(ard), (length(unique(ADAE_small$AESOC)) + length(unique(ADAE_small$AEDECOD))) * 3L # multiply by three for n, N, and p ) # check AEDECOD match expect_equal( ard |> dplyr::filter(!is.na(group1)), ard_hierarchical( ADAE_small, variables = c(AESOC, AEDECOD), id = USUBJID, denominator = ADSL |> dplyr::rename(TRTA = TRT01A) ), ignore_attr = TRUE ) # check AESOC match expect_equal( ard |> dplyr::filter(is.na(group1)) |> dplyr::select(-all_ard_group_n(1L)), ard_hierarchical( ADAE_small |> dplyr::slice_tail(n = 1L, by = c("USUBJID", "TRTA", "AESOC")), variables = AESOC, id = USUBJID, denominator = ADSL |> dplyr::rename(TRTA = TRT01A) ), ignore_attr = TRUE ) }) test_that("ard_stack_hierarchical(variables) messaging removed obs", { # missing rows are removed expect_snapshot( ard <- ADAE_small |> dplyr::mutate(AESOC = ifelse(dplyr::row_number() == 1L, NA, AESOC)) |> ard_stack_hierarchical( variables = c(AESOC, AEDECOD), id = USUBJID, denominator = ADSL |> dplyr::rename(TRTA = TRT01A) ) ) expect_snapshot( ard <- ADAE_small |> ard_stack_hierarchical( variables = c(AESOC, AEDECOD), id = USUBJID, by = TRTA, denominator = ADSL |> dplyr::rename(TRTA = TRT01A) |> dplyr::mutate(TRTA = ifelse(dplyr::row_number() == 1L, NA, TRTA)) ) ) }) test_that("ard_stack_hierarchical(variables) messaging", { # no variables selected expect_snapshot( error = TRUE, ADAE_small |> ard_stack_hierarchical( variables = starts_with("xxxxx"), id = USUBJID, denominator = ADSL |> dplyr::rename(TRTA = TRT01A) ) ) # no id selected expect_snapshot( error = TRUE, ADAE_small |> ard_stack_hierarchical( variables = c(AESOC, AEDECOD), id = starts_with("xxxxx"), denominator = ADSL |> dplyr::rename(TRTA = TRT01A) ) ) }) test_that("ard_stack_hierarchical(by)", { # ensure that all nested variables appear in resulting ARD expect_silent( ard <- ard_stack_hierarchical( ADAE_small, variables = c(AESOC, AEDECOD), by = TRTA, id = USUBJID, denominator = ADSL |> dplyr::rename(TRTA = TRT01A) ) ) # check AEDECOD match ard_match <- ard_hierarchical( ADAE_small, variables = c(AESOC, AEDECOD), by = TRTA, id = USUBJID, denominator = ADSL |> dplyr::rename(TRTA = TRT01A) ) |> cards::tidy_ard_row_order() attr(ard_match, "args") <- list(by = "TRTA", variables = c("AESOC", "AEDECOD"), include = c("AESOC", "AEDECOD")) expect_equal( ard |> dplyr::filter(!is.na(group2)), ard_match |> sort_ard_hierarchical("alphanumeric"), ignore_attr = TRUE ) # check AESOC match ard_match <- ard_hierarchical( ADAE_small |> dplyr::slice_tail(n = 1L, by = c("USUBJID", "TRTA", "AESOC")), variables = AESOC, by = TRTA, id = USUBJID, denominator = ADSL |> dplyr::rename(TRTA = TRT01A) ) |> cards::tidy_ard_row_order() attr(ard_match, "args") <- list(by = "TRTA", variables = c("AESOC"), include = c("AESOC")) expect_equal( ard |> dplyr::filter(variable %in% "AESOC") |> dplyr::select(-all_ard_group_n(2L)), ard_match |> sort_ard_hierarchical("alphanumeric"), ignore_attr = TRUE ) }) test_that("ard_stack_hierarchical(by) messaging", { # missing rows are removed expect_snapshot( ard <- ADAE_small |> dplyr::mutate(TRTA = ifelse(dplyr::row_number() == 1L, NA, TRTA)) |> ard_stack_hierarchical( variables = c(AESOC, AEDECOD), by = TRTA, id = USUBJID, denominator = ADSL |> dplyr::rename(TRTA = TRT01A) ) ) }) test_that("ard_stack_hierarchical(denominator) messaging", { # when the wrong type is passed to the argument expect_snapshot( error = TRUE, ADAE_small |> ard_stack_hierarchical( variables = c(AESOC, AEDECOD), by = TRTA, id = USUBJID, denominator = character() ) ) # denominator arg must be specified expect_snapshot( error = TRUE, ard_stack_hierarchical( ADAE, variables = c(AESOC, AEDECOD), by = TRTA, id = USUBJID ) ) }) # test the rates are correct for items like AESEV, where we want to tabulate the most severe AE within the hierarchies test_that("ard_stack_hierarchical(by) with columns not in `denominator`", { expect_message( ard_stack_hierarchical( ADAE_small, variables = c(AESOC, AEDECOD), by = c(AESEV), id = USUBJID, denominator = ADSL |> dplyr::rename(TRTA = TRT01A) ), 'Denominator set by number of rows in.*denominator.*data frame.' # styler: off ) expect_message( ard <- ard_stack_hierarchical( ADAE_small, variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV), id = USUBJID, denominator = ADSL |> dplyr::rename(TRTA = TRT01A) ), 'Denominator set by.*"TRTA".*column in .*denominator.*data frame.' # styler: off ) # check the rates for AEDECOD are correct ard_match <- ADAE_small |> dplyr::arrange(USUBJID, TRTA, AESOC, AEDECOD, AESEV) |> dplyr::filter(.by = c(USUBJID, TRTA, AESOC, AEDECOD), dplyr::n() == dplyr::row_number()) |> ard_hierarchical( variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV), denominator = ADSL |> dplyr::rename(TRTA = TRT01A) ) |> tidy_ard_row_order() attr(ard_match, "args") <- list(by = "TRTA", variables = c("AESOC", "AEDECOD", "AESEV"), include = c("AESOC", "AEDECOD", "AESEV")) expect_equal( ard |> dplyr::filter(variable == "AEDECOD"), ard_match |> sort_ard_hierarchical("alphanumeric"), ignore_attr = TRUE, ignore_function_env = TRUE ) # check the rates for AESOC are correct ard_match <- ADAE_small |> dplyr::arrange(USUBJID, TRTA, AESOC, AESEV) |> dplyr::filter(.by = c(USUBJID, TRTA, AESOC), dplyr::n() == dplyr::row_number()) |> ard_hierarchical( variables = AESOC, by = c(TRTA, AESEV), denominator = ADSL |> dplyr::rename(TRTA = TRT01A) ) |> tidy_ard_row_order() attr(ard_match, "args") <- list(by = "TRTA", variables = c("AESOC", "AESEV"), include = c("AESOC", "AESEV")) expect_equal( ard |> dplyr::filter(variable == "AESOC") |> rename_ard_columns(), ard_match |> sort_ard_hierarchical("alphanumeric") |> rename_ard_columns(), ignore_attr = TRUE, ignore_function_env = TRUE ) }) test_that("ard_stack_hierarchical(variables, include) messaging", { expect_snapshot( error = TRUE, ard_stack_hierarchical( ADAE_small, variables = c(AESOC, AEDECOD), include = AESOC, by = TRTA, denominator = ADSL |> dplyr::rename(TRTA = ARM), id = USUBJID ) ) }) test_that("ard_stack_hierarchical(by, overall) messaging", { expect_snapshot( ard <- ard_stack_hierarchical( ADAE_small, variables = c(AESOC, AEDECOD), denominator = ADSL |> dplyr::rename(TRTA = ARM), id = USUBJID, overall = TRUE ) ) }) test_that("ard_stack_hierarchical(statistic)", { expect_equal( ard_stack_hierarchical( ADAE, variables = AESOC, denominator = ADSL |> dplyr::rename(TRTA = ARM), id = USUBJID, statistic = everything() ~ "p" ), ard_stack_hierarchical( ADAE, variables = AESOC, denominator = ADSL |> dplyr::rename(TRTA = ARM), id = USUBJID, statistic = everything() ~ c("n", "N", "p") ) |> dplyr::filter(stat_name %in% "p") ) }) # ard_stack_hierarchical_count() ----------------------------------------------- test_that("ard_stack_hierarchical_count(variables)", { # ensure that all nested variables appear in resulting ARD expect_silent( ard <- ard_stack_hierarchical_count( ADAE_small, variables = c(AESOC, AEDECOD) ) ) # check the number of rows is expected expect_equal( nrow(ard), length(unique(ADAE_small$AESOC)) + length(unique(ADAE_small$AEDECOD)) ) # check AEDECOD match ard_match <- ard_hierarchical_count(ADAE_small, variables = c(AESOC, AEDECOD)) attr(ard_match, "args") <- list(by = NULL, variables = c("AESOC", "AEDECOD"), include = c("AESOC", "AEDECOD")) expect_equal( ard |> dplyr::filter(!is.na(group1)), ard_match |> sort_ard_hierarchical("alphanumeric"), ignore_attr = TRUE ) # check AESOC match ard_match <- ard_hierarchical_count(ADAE_small, variables = AESOC) attr(ard_match, "args") <- list(by = NULL, variables = "AESOC", include = "AESOC") expect_equal( ard |> dplyr::filter(is.na(group1)) |> dplyr::select(-all_ard_group_n(1L)), ard_match |> sort_ard_hierarchical("alphanumeric"), ignore_attr = TRUE ) }) test_that("ard_stack_hierarchical_count(by)", { expect_silent( ard <- ard_stack_hierarchical_count( ADAE_small, variables = c(AESOC, AEDECOD), by = TRTA ) ) # check the number of rows is expected expect_equal( nrow(ard), (length(unique(ADAE_small$AESOC)) + length(unique(ADAE_small$AEDECOD))) * length(unique(ADAE_small$TRTA)) ) # check AEDECOD match ard_match <- ard_hierarchical_count(ADAE_small, variables = c(AESOC, AEDECOD), by = TRTA) |> cards::tidy_ard_row_order() attr(ard_match, "args") <- list(by = "TRTA", variables = c("AESOC", "AEDECOD"), include = c("AESOC", "AEDECOD")) expect_equal( ard |> dplyr::filter(!is.na(group2)), ard_match |> sort_ard_hierarchical("alphanumeric"), ignore_attr = TRUE ) # check AESOC match ard_match <- ard_hierarchical_count(ADAE_small, variables = AESOC, by = TRTA) |> cards::tidy_ard_row_order() attr(ard_match, "args") <- list(by = "TRTA", variables = "AESOC", include = "AESOC") expect_equal( ard |> dplyr::filter(is.na(group2)) |> dplyr::select(-all_ard_group_n(2L)), ard_match |> sort_ard_hierarchical("alphanumeric"), ignore_attr = TRUE ) }) test_that("ard_stack_hierarchical_count(denominator) messaging", { # when the wrong type is passed to the argument expect_snapshot( error = TRUE, ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), by = TRTA, denominator = letters ) ) }) test_that("ard_stack_hierarchical_count(denominator) univariate tabulations", { # test that we get the expected univariate by variable tabulations expect_equal( ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL |> dplyr::rename(TRTA = TRT01A) ) |> dplyr::filter(variable == "TRTA") |> dplyr::select(-all_missing_columns()), ard_categorical(ADSL |> dplyr::rename(TRTA = TRT01A), variables = TRTA) |> dplyr::select(-all_missing_columns()), ignore_attr = TRUE ) # everything still works when the by variable includes vars not in the denom data frame expect_equal( ard <- ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV), denominator = ADSL |> dplyr::rename(TRTA = TRT01A) ) |> dplyr::filter(variable == "TRTA") |> dplyr::select(-all_missing_columns()), ard_categorical(ADSL |> dplyr::rename(TRTA = TRT01A), variables = TRTA) |> dplyr::select(-all_missing_columns()), ignore_attr = TRUE ) expect_true(nrow(dplyr::filter(ard, variable == "AESEV")) == 0L) }) test_that("ard_stack_hierarchical_count(denominator,total_n)", { # check N is correct when denom is a data frame expect_equal( ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), denominator = ADSL |> dplyr::rename(TRTA = TRT01A), total_n = TRUE ) |> dplyr::filter(variable == "..ard_total_n..") |> dplyr::select(-all_missing_columns()), ard_total_n(ADSL) |> dplyr::select(-all_missing_columns()), ignore_attr = TRUE ) # check N is correct when denom is an integer expect_equal( ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), denominator = nrow(ADSL), total_n = TRUE ) |> dplyr::filter(variable == "..ard_total_n..") |> dplyr::select(-all_missing_columns()), ard_total_n(ADSL) |> dplyr::select(-all_missing_columns()), ignore_attr = TRUE ) }) test_that("ard_stack_hierarchical_count(denominator,total_n) messaging", { # requesting total N without a denominator expect_snapshot( ard <- ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), total_n = TRUE ) ) }) test_that("ard_stack_hierarchical_count(overall, denominator) messaging", { # requesting overall without a data frame denominator expect_snapshot( ard <- ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), by = TRTA, overall = TRUE ) ) }) test_that("ard_stack_hierarchical_count(overall)", { withr::local_options(list(width = 250)) # requesting overall without a data frame denominator expect_equal( ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL |> dplyr::rename(TRTA = ARM), overall = TRUE ) |> dplyr::filter(!group1 %in% "TRTA" & !group2 %in% "TRTA" & !variable %in% "TRTA") |> dplyr::select(-all_missing_columns()), ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), denominator = ADSL |> dplyr::rename(TRTA = ARM) ) |> dplyr::select(-all_missing_columns()), ignore_attr = TRUE ) # when the `by` variable includes columns not in `denominator`, ensure we get two sets of overall (by=AESEV and by=NULL) # IF THIS EVER BREAKS BE VERY CAREFUL WE HAVE ALL 18 ROWS RETURNED!!! expect_snapshot({ ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV), denominator = ADSL |> dplyr::rename(TRTA = ARM), overall = TRUE ) |> dplyr::filter(!group1 %in% "TRTA" & !group2 %in% "TRTA" & !group3 %in% "TRTA" & !variable %in% "TRTA") }) }) test_that("ard_stack_hierarchical_count(over_variables)", { # requesting overall without a data frame denominator expect_equal( ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL |> dplyr::rename(TRTA = ARM), over_variables = TRUE ) |> dplyr::filter(variable %in% "..ard_hierarchical_overall..") |> dplyr::select(-all_missing_columns()), ADAE_small |> dplyr::mutate(..ard_hierarchical_overall.. = TRUE) |> ard_stack_hierarchical_count( variables = ..ard_hierarchical_overall.., by = TRTA, denominator = ADSL |> dplyr::rename(TRTA = ARM) ) |> dplyr::filter(variable %in% "..ard_hierarchical_overall..") |> dplyr::select(-all_missing_columns()), ignore_attr = TRUE ) }) test_that("ard_stack_hierarchical_count(overall,over_variables)", { # ensuring we have an overall row grouped by TRTA, and across TRTA levels (nrow=4) expect_snapshot( ADAE_small |> ard_stack_hierarchical_count( variables = AESOC, by = TRTA, denominator = ADSL |> dplyr::rename(TRTA = ARM), over_variables = TRUE, overall = TRUE ) |> dplyr::filter(variable == "..ard_hierarchical_overall..") |> dplyr::select(all_ard_groups(), "variable", "stat_name", "stat") |> as.data.frame() ) }) test_that("ard_stack_hierarchical_count(attributes)", { # requesting overall without a data frame denominator expect_equal( ADAE_small |> ard_stack_hierarchical_count( variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL |> dplyr::rename(TRTA = ARM), attributes = TRUE ) |> dplyr::filter(context %in% "attributes") |> dplyr::select(-all_missing_columns()), ADAE_small |> ard_attributes(variables = c(TRTA, AESOC, AEDECOD)) |> dplyr::select(-all_missing_columns()) |> dplyr::slice(c(5:6, 1:2, 3:4)), ignore_attr = TRUE ) }) cards/tests/testthat/test-sort_ard_hierarchical.R0000644000176200001440000002112114767020056021767 0ustar liggesusersskip_on_cran() ADAE_subset <- cards::ADAE |> dplyr::filter(AETERM %in% unique(cards::ADAE$AETERM)[1:5]) ard <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL |> dplyr::mutate(TRTA = ARM), id = USUBJID, over_variables = TRUE ) test_that("sort_ard_hierarchical() works", { withr::local_options(width = 200) expect_silent(ard_s <- sort_ard_hierarchical(ard)) expect_snapshot(ard_s |> dplyr::select(all_ard_groups(), all_ard_variables()) |> print(n = 50)) # works after filtering expect_silent(ard_s <- ard |> filter_ard_hierarchical(n > 20) |> sort_ard_hierarchical()) }) test_that("sort_ard_hierarchical(sort = 'descending') works", { # descending count (default) expect_silent(ard <- sort_ard_hierarchical(ard)) expect_equal( ard |> dplyr::filter(variable == "SEX") |> dplyr::select(variable_level) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), c("F", "M") ) expect_equal( ard |> dplyr::filter(variable == "RACE") |> dplyr::select(all_ard_groups("levels"), -"group1_level", all_ard_variables()) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), c("WHITE", "BLACK OR AFRICAN AMERICAN", "WHITE", "BLACK OR AFRICAN AMERICAN", "AMERICAN INDIAN OR ALASKA NATIVE") ) expect_equal( ard |> dplyr::filter(variable == "AETERM") |> dplyr::select(all_ard_groups("levels"), -"group1_level", all_ard_variables()) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), c( "APPLICATION SITE PRURITUS", "ERYTHEMA", "APPLICATION SITE ERYTHEMA", "DIARRHOEA", "APPLICATION SITE PRURITUS", "ERYTHEMA", "ATRIOVENTRICULAR BLOCK SECOND DEGREE", "DIARRHOEA", "APPLICATION SITE PRURITUS", "APPLICATION SITE ERYTHEMA", "ERYTHEMA", "DIARRHOEA", "ATRIOVENTRICULAR BLOCK SECOND DEGREE", "APPLICATION SITE PRURITUS", "DIARRHOEA", "ERYTHEMA", "ERYTHEMA" ) ) }) test_that("sort_ard_hierarchical(sort = 'alphanumeric') works", { expect_silent(ard <- sort_ard_hierarchical(ard, sort = "alphanumeric")) expect_equal( ard |> dplyr::filter(variable == "SEX") |> dplyr::select(variable_level) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), sort(c("F", "M")) ) expect_equal( ard |> dplyr::filter(variable == "RACE") |> dplyr::select(all_ard_groups("levels"), -"group1_level", all_ard_variables()) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), c("BLACK OR AFRICAN AMERICAN", "WHITE", "AMERICAN INDIAN OR ALASKA NATIVE", "BLACK OR AFRICAN AMERICAN", "WHITE") ) expect_equal( ard |> dplyr::filter(variable == "AETERM") |> dplyr::select(all_ard_groups("levels"), -"group1_level", all_ard_variables()) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), c( "APPLICATION SITE PRURITUS", "ATRIOVENTRICULAR BLOCK SECOND DEGREE", "DIARRHOEA", "ERYTHEMA", "APPLICATION SITE ERYTHEMA", "APPLICATION SITE PRURITUS", "DIARRHOEA", "ERYTHEMA", "ERYTHEMA", "APPLICATION SITE PRURITUS", "DIARRHOEA", "ERYTHEMA", "APPLICATION SITE ERYTHEMA", "APPLICATION SITE PRURITUS", "ATRIOVENTRICULAR BLOCK SECOND DEGREE", "DIARRHOEA", "ERYTHEMA" ) ) }) test_that("sort_ard_hierarchical() works when there is no overall row in x", { ard_no_overall <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL |> dplyr::mutate(TRTA = ARM), id = USUBJID, over_variables = FALSE ) # sort = 'descending' expect_silent(ard_no_overall <- sort_ard_hierarchical(ard_no_overall)) expect_equal( ard_no_overall |> dplyr::select(all_ard_groups(), all_ard_variables()), ard |> sort_ard_hierarchical() |> dplyr::select(all_ard_groups(), all_ard_variables()) |> dplyr::filter(variable != "..ard_hierarchical_overall..") ) # sort = 'alphanumeric' expect_silent(ard_no_overall <- sort_ard_hierarchical(ard_no_overall, sort = "alphanumeric")) expect_equal( ard_no_overall |> dplyr::select(all_ard_groups(), all_ard_variables()), ard |> sort_ard_hierarchical("alphanumeric") |> dplyr::select(all_ard_groups(), all_ard_variables()) |> dplyr::filter(variable != "..ard_hierarchical_overall..") ) }) test_that("sort_ard_hierarchical() works with only one variable in x", { ard_single <- ard_stack_hierarchical( data = ADAE_subset, variables = AETERM, by = TRTA, denominator = cards::ADSL |> dplyr::mutate(TRTA = ARM), id = USUBJID, over_variables = TRUE ) # sort = 'descending' expect_silent(ard_single <- sort_ard_hierarchical(ard_single)) expect_equal( ard_single |> dplyr::filter(variable == "AETERM") |> dplyr::pull(variable_level) |> unlist() |> unique(), c( "APPLICATION SITE PRURITUS", "ERYTHEMA", "APPLICATION SITE ERYTHEMA", "DIARRHOEA", "ATRIOVENTRICULAR BLOCK SECOND DEGREE" ) ) # sort = 'alphanumeric' expect_silent(ard_single <- sort_ard_hierarchical(ard_single, sort = "alphanumeric")) expect_equal( ard_single |> dplyr::filter(variable == "AETERM") |> dplyr::pull(variable_level) |> unlist() |> unique(), sort(unique(ADAE_subset$AETERM)) ) }) test_that("sort_ard_hierarchical() works when some variables not included in x", { ard_incl <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL |> dplyr::mutate(TRTA = ARM), id = USUBJID, include = c(SEX, AETERM), over_variables = TRUE ) expect_equal( ard_incl |> sort_ard_hierarchical() |> dplyr::select(all_ard_groups(), all_ard_variables()), ard |> sort_ard_hierarchical() |> dplyr::filter(variable != "RACE") |> dplyr::select(all_ard_groups(), all_ard_variables()), ignore_attr = TRUE ) }) test_that("sort_ard_hierarchical() works when sorting using p instead of n", { ard <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL |> dplyr::mutate(TRTA = ARM), id = USUBJID, statistic = everything() ~ "p" ) expect_silent(ard_p <- sort_ard_hierarchical(ard)) ard <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL |> dplyr::mutate(TRTA = ARM), id = USUBJID, statistic = everything() ~ "p" ) }) test_that("sort_ard_hierarchical() works with overall data", { ard_overall <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL |> dplyr::mutate(TRTA = ARM), id = USUBJID, over_variables = TRUE, overall = TRUE ) expect_silent(ard_overall <- sort_ard_hierarchical(ard_overall)) expect_equal( ard_overall |> dplyr::filter(variable == "RACE") |> dplyr::select(all_ard_groups("levels"), all_ard_variables()) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), rep( c("WHITE", "BLACK OR AFRICAN AMERICAN", "WHITE", "BLACK OR AFRICAN AMERICAN", "AMERICAN INDIAN OR ALASKA NATIVE"), each = 4 ) ) expect_equal( ard_overall |> dplyr::filter(variable == "AETERM") |> dplyr::select(all_ard_groups("levels"), all_ard_variables()) |> dplyr::distinct() |> dplyr::pull(variable_level) |> unlist(), rep( c( "APPLICATION SITE PRURITUS", "ERYTHEMA", "APPLICATION SITE ERYTHEMA", "DIARRHOEA", "APPLICATION SITE PRURITUS", "ERYTHEMA", "ATRIOVENTRICULAR BLOCK SECOND DEGREE", "DIARRHOEA", "APPLICATION SITE PRURITUS", "APPLICATION SITE ERYTHEMA", "ERYTHEMA", "DIARRHOEA", "ATRIOVENTRICULAR BLOCK SECOND DEGREE", "APPLICATION SITE PRURITUS", "DIARRHOEA", "ERYTHEMA", "ERYTHEMA" ), each = 4 ) ) }) test_that("sort_ard_hierarchical() error messaging works", { # invalid x input expect_snapshot( sort_ard_hierarchical(ard_categorical(ADSL, by = "ARM", variables = "AGEGR1")), error = TRUE ) # invalid sort input expect_snapshot( sort_ard_hierarchical(ard, sort = "no_sorting"), error = TRUE ) # no n or p stat in ARD ard <- ard_stack_hierarchical( data = ADAE_subset, variables = c(SEX, RACE, AETERM), by = TRTA, denominator = cards::ADSL |> dplyr::mutate(TRTA = ARM), id = USUBJID, statistic = everything() ~ "N" ) expect_snapshot( sort_ard_hierarchical(ard), error = TRUE ) }) cards/tests/testthat/test-apply_fmt_fn.R0000644000176200001440000000523014760510631020131 0ustar liggesusersard_fmt_checks <- ard_continuous( data = mtcars, variables = mpg, statistic = ~ continuous_summary_fns(c("mean", "sd")) ) test_that("apply_fmt_fn() works", { expect_equal( ard_fmt_checks |> apply_fmt_fn() |> dplyr::pull(stat_fmt) |> unlist(), c("20.1", "6.0") ) # no errors when there is no formatting function expect_equal( ard_fmt_checks |> dplyr::mutate( fmt_fn = list(NULL, 2) ) |> apply_fmt_fn() |> dplyr::pull(stat_fmt), list(NULL, "6.03") ) }) test_that("apply_fmt_fn() works with integer specification", { expect_equal( ard_fmt_checks |> dplyr::mutate( fmt_fn = list(2, 2) ) |> apply_fmt_fn() |> dplyr::pull(stat_fmt) |> unlist(), c("20.09", "6.03") ) }) test_that("apply_fmt_fn() works with xx specification", { expect_equal( ard_fmt_checks |> dplyr::mutate( fmt_fn = list("xx.xx", "xx.xx") ) |> apply_fmt_fn() |> dplyr::pull(stat_fmt) |> unlist(), c("20.09", " 6.03") ) expect_equal( ard_fmt_checks |> dplyr::mutate( fmt_fn = list("xx.xxx", "xx.xxx") ) |> apply_fmt_fn() |> dplyr::pull(stat_fmt) |> unlist(), c("20.091", " 6.027") ) expect_equal( ard_categorical( data = mtcars, variables = am, fmt_fn = list( am = list( n = "xx", N = "xx", p = "xx.xx%" ) ) ) |> apply_fmt_fn() |> dplyr::pull(stat_fmt) |> unlist() |> unname(), c("19", "32", "59.38", "13", "32", "40.63") ) }) test_that("apply_fmt_fn() error messaging", { expect_snapshot( apply_fmt_fn(letters), error = TRUE ) expect_snapshot( ard_fmt_checks |> dplyr::mutate( fmt_fn = list("xoxo", "xoxo") ) |> apply_fmt_fn(), error = TRUE ) expect_snapshot( ard_fmt_checks |> dplyr::mutate( fmt_fn = list(1L, -1L) ) |> apply_fmt_fn(), error = TRUE ) # everything still works when the formatted value is longer than the xxx string expect_snapshot( ard_fmt_checks |> dplyr::mutate( stat = lapply(stat, function(x) x * 1000), fmt_fn = list("xx", "xx") ) |> apply_fmt_fn() |> as.data.frame() ) }) test_that("apply_fmt_fn(replace)", { ard <- ADSL |> ard_categorical(variables = AGEGR1, statistic = ~"n") |> dplyr::mutate( stat_fmt = ifelse(dplyr::row_number() == 1, list("144.000000"), list(NULL)) ) expect_snapshot( apply_fmt_fn(ard, replace = FALSE) ) expect_snapshot( apply_fmt_fn(ard, replace = TRUE) ) }) cards/tests/testthat/test-selectors.R0000644000176200001440000000374014663411551017465 0ustar liggesuserstest_that("selectors work", { ard_testing <- ard_categorical(ADSL, by = ARM, variables = AGE) expect_equal( ard_testing |> dplyr::select(all_ard_groups()) |> names(), c("group1", "group1_level") ) expect_equal( ard_testing |> dplyr::select(all_ard_groups("names")) |> names(), "group1" ) expect_equal( ard_testing |> dplyr::select(all_ard_groups("levels")) |> names(), "group1_level" ) expect_equal( ard_testing |> dplyr::select(all_ard_variables()) |> names(), c("variable", "variable_level") ) expect_equal( ard_testing |> dplyr::select(all_ard_variables("names")) |> names(), "variable" ) expect_equal( ard_testing |> dplyr::select(all_ard_variables("levels")) |> names(), "variable_level" ) # test group selector works for 10+ groups expect_equal( suppressMessages( rep_len(list(mtcars[c("am", "vs")]), length.out = 11) |> dplyr::bind_cols() ) |> ard_categorical( variables = "vs...2", by = starts_with("am"), statistic = ~"n" ) |> dplyr::select(all_ard_groups()) |> names() |> length(), 22L ) # all_ard_group_n() works expect_equal( ard_categorical( mtcars, by = c(am, vs), variables = cyl ) |> dplyr::select(all_ard_group_n(1L)) |> names(), c("group1", "group1_level") ) expect_equal( ard_categorical( mtcars, by = c(am, vs), variables = cyl ) |> dplyr::select(all_ard_group_n(1:2)) |> names(), c("group1", "group1_level", "group2", "group2_level") ) # all_missing_columns() works expect_equal( bind_ard( ard_categorical(mtcars, by = am, variables = cyl), ard_categorical(mtcars, variables = vs) ) |> dplyr::filter(variable == "vs") |> dplyr::select(all_missing_columns()) |> names(), c("group1", "group1_level", "warning", "error") ) }) cards/tests/testthat/test-eval_capture_conditions.R0000644000176200001440000000414614672114773022374 0ustar liggesuserstest_that("eval_capture_conditions() works", { # no errors expect_snapshot( eval_capture_conditions( expr(TRUE) ) ) # capture the error expect_snapshot( eval_capture_conditions( expr(cli::cli_abort("BIG ERROR")) ) ) # capture warning expect_snapshot({ one_warn_foo <- function() { cli::cli_warn("BIG WARNING") TRUE } eval_capture_conditions(expr(one_warn_foo())) }) # capture multiple warning expect_snapshot({ two_warn_foo <- function() { cli::cli_warn("{.emph BIG} WARNING1") cli::cli_warn("{.emph BIG} WARNING2") TRUE } eval_capture_conditions(expr(two_warn_foo())) }) }) # captured_condition_as_message() ---------------------------------------------- test_that("captured_condition_as_message() works", { # we get the result back when there is no error or warning expect_equal( eval_capture_conditions(letters) |> captured_condition_as_message(), letters ) # print error as message with curly brackets in it expect_snapshot( eval_capture_conditions(stop("This is an {error}!")) |> captured_condition_as_message() ) # print multiple warnings expect_snapshot( eval_capture_conditions({ warning("This is a {warning} 1") warning("This is a {warning} 2") NULL }) |> captured_condition_as_message(type = "warning") ) }) # captured_condition_as_error() ---------------------------------------------- test_that("captured_condition_as_error() works", { # we get the result back when there is no error or warning expect_equal( eval_capture_conditions(letters) |> captured_condition_as_error(), letters ) # print error as message with curly brackets in it expect_snapshot( error = TRUE, eval_capture_conditions(stop("This is an {error}!")) |> captured_condition_as_error() ) # print multiple warnings expect_snapshot( error = TRUE, eval_capture_conditions({ warning("This is a {warning} 1") warning("This is a {warning} 2") NULL }) |> captured_condition_as_error(type = "warning") ) }) cards/tests/testthat/test-bind_ard.R0000644000176200001440000000275714746733642017245 0ustar liggesuserstest_that("bind_ard() works", { ard <- ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") expect_error( bind_ard(ard, ard, .update = TRUE), NA ) }) test_that("ARD helpers messaging", { ard <- ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") expect_snapshot( bind_ard(ard, ard, .update = letters), error = TRUE ) expect_snapshot( bind_ard(ard, ard, .distinct = FALSE, .update = FALSE), error = TRUE ) }) test_that("bind_ard() .order argument works", { withr::local_options(list(width = 120)) withr::local_seed(1123) expect_snapshot( bind_ard( ard_categorical(ADSL, by = "ARM", variables = "SEX") %>% # randomly sort data {dplyr::slice(., sample.int(nrow(.)))}, # styler: off .order = TRUE ) |> as.data.frame() |> dplyr::select(-c(context, fmt_fn, warning, error)) ) expect_snapshot( bind_ard( ard_categorical(ADSL, by = "ARM", variables = "SEX") %>% # randomly sort data {dplyr::slice(., sample.int(nrow(.)))}, # styler: off .order = FALSE ) |> as.data.frame() |> dplyr::select(-c(context, fmt_fn, warning, error)) ) }) test_that("bind_ard(.quiet)", { expect_silent( ard_continuous(ADSL, variables = AGE) %>% {bind_ard(., ., .update = TRUE, .quiet = TRUE)} # styler: off ) }) test_that("bind_ard(.distinct)", { expect_snapshot( ard_continuous(ADSL, variables = AGE) %>% {bind_ard(., ., .update = FALSE)} # styler: off ) }) cards/tests/testthat/test-as_card.R0000644000176200001440000000100414661403171017042 0ustar liggesuserstest_that("as_card() works", { expect_snapshot( data.frame( stat_name = c("N", "mean"), stat_label = c("N", "Mean"), stat = c(10, 0.5) ) |> as_card() ) }) test_that("as_card() does not affect 'card' objects", { my_ard <- ard_continuous(ADSL, by = "ARM", variables = "AGE") expect_identical( my_ard |> as_card(), my_ard ) }) test_that("as_card() error catching works correctly", { expect_snapshot( "notadataframe" |> as_card(), error = TRUE ) }) cards/tests/testthat.R0000644000176200001440000000060614752033040014473 0ustar liggesusers# This file is part of the standard setup for testthat. # It is recommended that you do not modify it. # # Where should you do additional test configuration? # Learn more about the roles of various files in: # * https://r-pkgs.org/testing-design.html#sec-tests-files-overview # * https://testthat.r-lib.org/articles/special-files.html library(testthat) library(cards) test_check("cards") cards/MD50000644000176200001440000003346214776310352011676 0ustar liggesusers03e6f6d9a5c56ef276f834557c45dbfa *DESCRIPTION 0b08365083951539643c064d587606fc *NAMESPACE f015f4bb9f50a4f776a6da50c024edcf *NEWS.md c2e9d74c15350256b711e9ab24cad727 *R/add_calculated_row.R 4cc4b46b0aa736d18d9b1aa7ad282865 *R/apply_fmt_fn.R 94f7a27f686c47b17c737dce8f386ed2 *R/ard_attributes.R 1483ea5d3a2bf69ea9eb3730e2d1000c *R/ard_categorical.R 7059f4da6a945ad2753f38123e838c66 *R/ard_complex.R fa57c1c6ecdfb63227597030c42a91bc *R/ard_continuous.R 9c6d39aab84082bdd0c5b5b3307deb8a *R/ard_dichotomous.R 79d9cfea8a8c60c5b9e5f63a2b5ce1df *R/ard_formals.R 423ba2f85fa81f067e1cecc64f64fcd7 *R/ard_hierarchical.R 08eacdf34ae8f7e705e1932c0cab5f95 *R/ard_missing.R c0d6f8cfb010f5f5ac406261b3b5fd83 *R/ard_pairwise.R a451c441ad718ce348520450965a5b84 *R/ard_stack.R 54dabf2f7480c906682433afbd33c5e8 *R/ard_stack_hierarchical.R b13a26cf90442d771c65e07e5d948a79 *R/ard_strata.R 50b6d8762280496e491b72c69d7d58bb *R/ard_total_n.R a199d8fa98aafe4b74c56c40de7835b6 *R/as_card.R d8c57300423b7921a985f06f68fd8daa *R/as_card_fn.R 27ccf719adfa3ed77d88bf68f2b02e70 *R/as_nested_list.R f5916541080a77e0fc66476173cf37da *R/bind_ard.R 7243ef8e4ad4aa1b4005d93d3ffc9050 *R/cards-package.R 56698318fb7622a3e0affd04e7d05254 *R/check_ard_structure.R 1e1723c87265d4b5b767d736c827705e *R/data.R bc9f593fc354bc0d3be1c2edf6ff031e *R/default_stat_labels.R 6f9cd7de72dcee1bb1c5e672dd5efc59 *R/deprecated.R 2d5acb5ca6dc132698c560c47553e64f *R/eval_capture_conditions.R ec9f923a59560a3434ce871c7818683c *R/filter_ard_hierarchical.R acd8dfd2d499ce4452fde32e23f1c0fa *R/get_ard_statistics.R 4875cf4d60c6a34b5d7bcfdadafd61ef *R/import-standalone-check_pkg_installed.R fab17f675f7c139926890c89a2f9fa9d *R/import-standalone-checks.R 25b4af5ffd6bf4dfa3eb5367d5de0408 *R/import-standalone-cli_call_env.R 154fc9ec3cab70a36793c625959ccda8 *R/import-standalone-forcats.R 36f367ef4c5a6cac6b92c2197d958d2b *R/import-standalone-purrr.R 1b30778606ac6a14870cdde9b5fc3bed *R/import-standalone-stringr.R a9c1973b8d8847309ad41e6ce5e0dfa9 *R/import-standalone-tibble.R 5e66c0bc1dbbf33b8c38c6f571eaaa16 *R/mock.R 9ca239a7934b10287e91d8467b621521 *R/nest_for_ard.R 5a64ccb359befc3294607e30fbe0df1f *R/options.R 541567f21c5e60a81cc13d87022fd59a *R/print.R 54fcacadc4697308769d5f79169a1205 *R/print_ard_conditions.R e0deca2ecb0703f2289cf9cc49f4a910 *R/process_selectors.R 2baa216c9dbb73ff1c9896547862d0e2 *R/reexports.R 33a3d153acaeff1dae6e140797f22a5e *R/rename_ard_columns.R 4531aabb8d340e5fdb052481d58c2776 *R/rename_ard_groups.R c7da0fc70c24204ee7dd09578bd28a8e *R/replace_null_statistic.R dc8ed9d371902cd75fc0ee86078706c5 *R/round5.R 9f0f9a75a2611b121d4c263292c6479e *R/selectors.R c66e72118f802103608fa04b3ab300e7 *R/shuffle_ard.R e20afa0f210449d30a95077afc5459a7 *R/sort_ard_hierarchical.R e3336d889b8fc8a292bb84604197ea42 *R/summary_functions.R a02e0e11a24702e15b9585153ae47f3a *R/syntax.R 7488d27e3192b096ffea1987ca14cb29 *R/tidy_ard_order.R a47daa380feab670b42c64e3fc85f67c *R/tidy_as_ard.R 0e730468c88686e0a335feb9c94ba92f *R/unlist_ard_columns.R 26a81d0d682141f01aa918926ebb8777 *R/update_ard.R dd0e98485984008664c996464a79f51d *R/utils.R 68e06789a5923ba4c3a792d2d8a74489 *README.md 9be3ed6d43911aad5ecc307394a2c179 *data/ADAE.rda e36aab825c5346c2bd8cddcc1acdef58 *data/ADSL.rda 01d97bb63b26c9bc4adb45cb6c7d865e *data/ADTTE.rda 38b5f6c928e0a93a71a65d7d30cc43c4 *inst/WORDLIST 12348841294bf8e247ade026da4cb77f *man/adam.Rd 691d071e23898867fbba4ba9c9118eeb *man/add_calculated_row.Rd 68186055b0e34070d14da1333671fc70 *man/alias_as_fmt_fn.Rd 4b80e06a173ac1423aaeecc06a343220 *man/apply_fmt_fn.Rd 9ab1c64c223d673c384f7251cd93ae3d *man/ard_attributes.Rd 9fbe95e34ead1aebf7669f088a54a749 *man/ard_categorical.Rd 7651be83555d7ef92ba8409b9f01ec65 *man/ard_complex.Rd 9e8d058775fe6440eecb77cd1e9c325f *man/ard_continuous.Rd 9a917e1195309311991da9841bd92a09 *man/ard_dichotomous.Rd febb82856fee10591f36aa4a3cc11f09 *man/ard_formals.Rd 4f133a60f8b4937ffface1eb7477fe04 *man/ard_hierarchical.Rd de715258ad0bd567bba63b8d35830c2b *man/ard_missing.Rd b167fc5d7a32795c9ce260b56139ea66 *man/ard_pairwise.Rd c72fa55d1f491c308bdbaf80bcb3d60b *man/ard_stack.Rd 625b0bc8e280c646d67d8d10dcbef537 *man/ard_stack_hierarchical.Rd 941422a2002d5224ae649e05939a665b *man/ard_strata.Rd 2c0622322d9663c28262d6c6cb784d92 *man/ard_total_n.Rd f05ce8d73e04155dfb819d26bfcfee43 *man/as_card.Rd b2b090c68931e5e33f366f29fb2aa3e7 *man/as_cards_fn.Rd bbeb2bcc36c732bda66828ffb14db0fb *man/as_nested_list.Rd ec11c26db214fd0c98bb0900d8b19946 *man/bind_ard.Rd 1befa535b8f4502fc4b12963449836d2 *man/cards-package.Rd 84990427490f4cc280da1dfa12fe2f7f *man/cards.options.Rd 5dd67edecadd8970eb65b84262bd460c *man/check_ard_structure.Rd 7cddd89edc980c298fbe3e1fa16ba78d *man/default_stat_labels.Rd da3552c95644e8950b3fa94a83dd9f70 *man/deprecated.Rd 2cf8bdfbd60a4089cca06779f1030a0f *man/dot-calculate_stats_as_ard.Rd f03bfdb9a49ec14ce4540320aba5e7cb *man/dot-calculate_tabulation_statistics.Rd e3dfd968b72fd4d2a60ad5dcf651b86f *man/dot-check_dichotomous_value.Rd e143c8dccb1113a14737810d386e208b *man/dot-check_fmt_string.Rd 15c68bb51d4b11335f9e22f18828e4a4 *man/dot-check_for_missing_combos_in_denom.Rd 850f44c3deffde502a518081cb634ce9 *man/dot-check_no_ard_columns.Rd 68793867258718abf85922a708710a82 *man/dot-check_var_nms.Rd f7432ef284f888a6b6f8b39d83169e2b *man/dot-cli_condition_messaging.Rd a17e31deeaff72f38bc4bcd2c605e50d *man/dot-cli_groups_and_variable.Rd 2e2baf4339e051883ec32262d0629383 *man/dot-create_list_for_attributes.Rd 2c32144b6d5c77234105588bd794d514 *man/dot-default_fmt_fn.Rd 3658210d6fbe7e013100e61e8212374c *man/dot-detect_msgs.Rd fa794e7d6f97c6a9515f24bcb24a26ad *man/dot-eval_ard_calls.Rd 767d70a2630f00cfba5862d87a517932 *man/dot-fill_grps_from_variables.Rd 1b602be0dc4dc16fd4de574acc1fc739 *man/dot-fill_overall_grp_values.Rd 11a20a555d114d6d8cb4b0fa5c99ac6f *man/dot-is_named_list.Rd 045151e1c2c4f3d17417406e48de29c6 *man/dot-lst_results_as_df.Rd 5b778c671fea9febb85811f039510d1d *man/dot-nesting_rename_ard_columns.Rd 0d9afa98c0fb58053b1f37a950060fa4 *man/dot-one_row_ard_to_nested_list.Rd 3857bf6b243e95033466a93be444ef19 *man/dot-process_denominator.Rd b399af22e2ad49aa595fd4a7e01e6d4d *man/dot-process_nested_list_as_df.Rd 2121482506bb51565c005088b9a222ce *man/dot-purrr_list_flatten.Rd f537352faef3bf4ad6fae0f89deb7e0e *man/dot-rename_last_group_as_variable.Rd 51909e710ff23739ead9126c48186004 *man/dot-table_as_df.Rd 53548c992318c0964d5f4fa325134b4e *man/dot-trim_ard.Rd b68996f635bafda4ccdda88bead7798c *man/dot-unique_and_sorted.Rd 3ca947d6c5be145945d2ac9f1d3554bd *man/eval_capture_conditions.Rd a1cbaf3f328e8d74e747faacf640c7fc *man/figures/lifecycle-archived.svg 6f521fb1819410630e279d1abf88685a *man/figures/lifecycle-defunct.svg 391f696f961e28914508628a7af31b74 *man/figures/lifecycle-deprecated.svg 691b1eb2aec9e1bec96b79d11ba5e631 *man/figures/lifecycle-experimental.svg 405e252e54a79b33522e9699e4e9051c *man/figures/lifecycle-maturing.svg f41ed996be135fb35afe00641621da61 *man/figures/lifecycle-questioning.svg 306bef67d1c636f209024cf2403846fd *man/figures/lifecycle-soft-deprecated.svg ed42e3fbd7cc30bc6ca8fa9b658e24a8 *man/figures/lifecycle-stable.svg bf2f1ad432ecccee3400afe533404113 *man/figures/lifecycle-superseded.svg acaef05532711e67dc193e34f39409a4 *man/figures/logo.png 760a7b0a26c6ca40b17f92833f76c571 *man/filter_ard_hierarchical.Rd 28cf2540396e11585b54f36959d5e66a *man/get_ard_statistics.Rd 15bcd874179f9251a8b766bd04fe8871 *man/label_round.Rd e22783369d586485965531e6a7a7f967 *man/maximum_variable_value.Rd cfec0843821499c3d9c2efa8e48f7cb8 *man/mock.Rd aa6e1648c13523e09bb2ae19f114674f *man/nest_for_ard.Rd fd43008a7be22b409354a0d0fa0cf19b *man/print.card.Rd f878bca12145315092c874be48208535 *man/print_ard_conditions.Rd 12cc12f77d7e6f71d903323fce5079be *man/process_selectors.Rd a9515193a99a4f99c5effa4ee55458c4 *man/reexports.Rd 87eb9a5801c70cfea99335bbe5032d22 *man/rename_ard_columns.Rd f3231a67162b288f992d658489c4414a *man/rename_ard_groups.Rd b5b85c39ee03be552c32a398c24309f2 *man/replace_null_statistic.Rd f88da3966dcf9d64fbfe7c85af54fc06 *man/round5.Rd e08826634974b955157a665b72b7d6f2 *man/selectors.Rd adca5f6a835a24d9d159c15613afc41c *man/shuffle_ard.Rd d88d9729209f796b69ac6b14cb3339bf *man/sort_ard_hierarchical.Rd cc4afc1b96d125a205525717fb2b5683 *man/summary_functions.Rd 5c37a02164ffb7102eedeac0feea5159 *man/syntax.Rd fe6339cd0240fc54bd328e4499493770 *man/tidy_ard_order.Rd 6af6a748d1092595ccd9ebae5658475c *man/tidy_as_ard.Rd 102a6a95aca5a9596f31db869feeb878 *man/unlist_ard_columns.Rd a4babbc605943c8dbdeec1995325266a *man/update_ard.Rd 1307e15c19aed9c5310cced13ab36cd8 *tests/testthat.R cd1dff7e7d065751e01b7612dc478115 *tests/testthat/_snaps/add_calculated_row.md 13635f924c66544b1cfba981de239210 *tests/testthat/_snaps/apply_fmt_fn.md f28f79e2f01bd401774e1dce38d07dbb *tests/testthat/_snaps/ard_attributes.md db3afbc9b795c4db1d4601e4ce3e8760 *tests/testthat/_snaps/ard_categorical.md a838a3e2d956234462ace51e58568544 *tests/testthat/_snaps/ard_complex.md ff2b5f596fbd726bf5ebe3a9b5b402c6 *tests/testthat/_snaps/ard_continuous.md e1a659d3560e74e0271c851488dd8902 *tests/testthat/_snaps/ard_dichotomous.md f442ab3c74a01d326dc50d0b3b6aa658 *tests/testthat/_snaps/ard_formals.md ee0dae4547384d54b4c9b1987beafa76 *tests/testthat/_snaps/ard_hierarchical.md 52d8892d8f0734930c6decaf56ea66a0 *tests/testthat/_snaps/ard_missing.md 3828f007a3d165f849bf9ee589aedb60 *tests/testthat/_snaps/ard_pairwise.md 8111431911899ecbb7c158c1521190ad *tests/testthat/_snaps/ard_stack.md 696b7ba1c599d7a86324ca819c127a07 *tests/testthat/_snaps/ard_stack_hierarchical.md fae44573c60cf3e3ed4458f1f9074e68 *tests/testthat/_snaps/ard_strata.md 792c227dbb5fd5206ad9f3bc0f265cee *tests/testthat/_snaps/ard_total_n.md 5709cb25ae339ae1d3a1f4d6da72dd44 *tests/testthat/_snaps/as_card.md 6fbea1a538d944418e897234df7d9272 *tests/testthat/_snaps/as_nested_list.md 045970221042a295d0d2718f7818acf2 *tests/testthat/_snaps/bind_ard.md 1d3fed2e67ad4c1f47437c61f2d49028 *tests/testthat/_snaps/check_ard_structure.md 91b80b703fe106f2f1ed251a8fc8eb73 *tests/testthat/_snaps/eval_capture_conditions.md d4e161cd725f1070a63ebfd907d1758c *tests/testthat/_snaps/filter_ard_hierarchical.md d6cd7ea361c3b86d1911515ff52853dc *tests/testthat/_snaps/get_ard_statistics.md b3454edede4a74d915b20e9188d35745 *tests/testthat/_snaps/mock.md a37837eb26057d473985b7a03e8ff884 *tests/testthat/_snaps/options.md 8547513eb7004011bc6053424f3541a9 *tests/testthat/_snaps/print.md 1aa6a05a73257ed83ce69c3238257b23 *tests/testthat/_snaps/print_ard_conditions.md 44b7e17ae022b511784d5432380cda25 *tests/testthat/_snaps/process_selectors.md 8fcf6e0a836f06add10d6fb62d324c25 *tests/testthat/_snaps/rename_ard_columns.md 5d6c9a5d2bbe3a9ab7b47880c3e5993a *tests/testthat/_snaps/rename_ard_groups.md 54d57668aa3341c5209b0bc97944cb4c *tests/testthat/_snaps/round5.md 0daf3a614ab69928a0d5e23e62c1f1bf *tests/testthat/_snaps/shuffle_ard.md 3bcf4307995e0391617305e059a76bf7 *tests/testthat/_snaps/sort_ard_hierarchical.md 2c5edddd65c67749815d178bf3baa379 *tests/testthat/_snaps/tidy_ard_row_order.md ed6bc57f4319891ba53421c469d138e0 *tests/testthat/_snaps/tidy_as_ard.md 831ea982e65f6787768bfa6a03b99ba1 *tests/testthat/_snaps/update_ard.md 697c196cd1fa648c38057758ffad18a2 *tests/testthat/test-add_calculated_row.R 5bfbc5fe273dabf0a8eed47b00afcdfd *tests/testthat/test-apply_fmt_fn.R 9aedcdafa29999167bd41b6cd09c0a37 *tests/testthat/test-ard_attributes.R 179f1c0cf06c3fd56bf4e29d9d8b2e6c *tests/testthat/test-ard_categorical.R 11219aa332ed477095092a470e629f42 *tests/testthat/test-ard_complex.R 8c0700a930a0d68f3e01f73952dda5a0 *tests/testthat/test-ard_continuous.R 32fabb6a51abc3b23d05c16fecdef064 *tests/testthat/test-ard_dichotomous.R eef6a12aaa2c1c79c9b0f388211e7df3 *tests/testthat/test-ard_formals.R 9d288a1d4576b1158a20f33840b48ef4 *tests/testthat/test-ard_hierarchical.R c4bd58e09e7c2615c1cdaa4749d61d97 *tests/testthat/test-ard_missing.R 79a1c40e3e3f8e0b72d7bb8bb6cb91a2 *tests/testthat/test-ard_pairwise.R 42d7d9df1f31945669aefb900c19c010 *tests/testthat/test-ard_stack.R 08997d83fec545232db9410f3166b385 *tests/testthat/test-ard_stack_hierarchical.R cf22513052dcb2539a0fab59f7fd99e1 *tests/testthat/test-ard_strata.R b7e46281dd04e3900243bc122cb7a4e3 *tests/testthat/test-ard_total_n.R a7a67dff1394396c7ee7670a3c12d9d4 *tests/testthat/test-as_card.R 909a8414db5ca7360dcdacb104e686d2 *tests/testthat/test-as_cards_fn.R 2c0a024018fba23df50793d94206fe57 *tests/testthat/test-as_nested_list.R a68318aa11e98bb4ae0014b9f8201952 *tests/testthat/test-bind_ard.R 438caae87f213ba447435673db46cbca *tests/testthat/test-check_ard_structure.R cbef190a93c26758b17f0e21db825e3c *tests/testthat/test-eval_capture_conditions.R dff57b949bfbea6b0e19662609fecc15 *tests/testthat/test-filter_ard_hierarchical.R e53208dd8d452187b5d6b2f207bf2e78 *tests/testthat/test-get_ard_statistics.R 478c394225830e4dce894a5e784ef312 *tests/testthat/test-label_round.R 8d886670ef1051ce05117802f76715ca *tests/testthat/test-mock.R 99f13064ddf25f94c0c64163e94871a8 *tests/testthat/test-nest_for_ard.R 26b27d21fa1b5f3495b9351082d5266c *tests/testthat/test-options.R 4d4170d70ea19521bed0256235278b66 *tests/testthat/test-print.R c1f856d6fcef5292e0ab760063ff3056 *tests/testthat/test-print_ard_conditions.R b2e0a96f4a987a5b18ad34b434b8edcc *tests/testthat/test-process_selectors.R a06ce426d45c8b883b4110d24c44d8d0 *tests/testthat/test-rename_ard_columns.R 427bc6701ceb6a79a014a861fab6a2d2 *tests/testthat/test-rename_ard_groups.R bb86b8fea589da80f5992741f6e70ded *tests/testthat/test-replace_null_statistic.R ff7a3a310a49b1e60bdc23682582bff9 *tests/testthat/test-round5.R ac0a236a3930e7ee4a059b70d3ca2cbe *tests/testthat/test-selectors.R 4c402b319bb18a43c1db63705912b6ef *tests/testthat/test-shuffle_ard.R 8b6450c2335d7a6aeb8fa891be001b1b *tests/testthat/test-sort_ard_hierarchical.R d632f0612fb81b2ee6ce5c3478d0aae2 *tests/testthat/test-tidy_ard_column_order.R 816854034ddae04a508bab6309f2245a *tests/testthat/test-tidy_ard_row_order.R 3f097b62ac28bc853f744e81b6e91cad *tests/testthat/test-tidy_as_ard.R b8a460e7d31aa6d2c56a44d607efcfa9 *tests/testthat/test-unlist_ard_columns.R 1f03e7ced200b416e9a723121611c33d *tests/testthat/test-update_ard.R cards/R/0000755000176200001440000000000014776252447011571 5ustar liggesuserscards/R/ard_pairwise.R0000644000176200001440000000655214721513741014360 0ustar liggesusers#' Pairwise ARD #' #' Utility to perform pairwise comparisons. #' #' @param data (`data.frame`)\cr #' a data frame #' @param variable ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' Column to perform pairwise analyses for. #' @param .f (`function`)\cr #' a function that creates ARDs. The function accepts a single argument and #' a subset of `data` will be passed including the two levels of `variable` #' for the pairwise analysis. #' @param include (`vector`)\cr #' a vector of levels of the `variable` column to include in comparisons. #' Pairwise comparisons will only be performed for pairs that have a level #' specified here. Default is `NULL` and all pairwise computations are included. #' #' @return list of ARDs #' @export #' #' @examples #' ard_pairwise( #' ADSL, #' variable = ARM, #' .f = \(df) { #' ard_complex( #' df, #' variables = AGE, #' statistic = ~ list(ttest = \(x, data, ...) t.test(x ~ data$ARM)[c("statistic", "p.value")]) #' ) #' }, #' include = "Placebo" # only include comparisons to the "Placebo" group #' ) ard_pairwise <- function(data, variable, .f, include = NULL) { set_cli_abort_call() # check inputs --------------------------------------------------------------- check_data_frame(data) process_selectors(data, variable = {{ variable }}) check_scalar(variable) if (!is_empty(include) && (!is_vector(include) || is.list(include))) { cli::cli_abort( "The {.arg include} argument must be a simple vector, not {.obj_type_friendly {include}}.", call = get_cli_abort_call() ) } .f <- as_function(.f, call = get_cli_abort_call()) variable_levels <- .unique_and_sorted(data[[variable]]) if (!is_empty(include)) { if (!all(include %in% variable_levels)) { cli::cli_abort( "The {.arg include} argument must be NULL or one or more of {.val {variable_levels}}.", call = get_cli_abort_call() ) } } include <- include %||% variable_levels # if include not specified, default to all levels # identify all pairwise values in `variable` --------------------------------- mtx_pairs <- variable_levels |> utils::combn(m = 2) lst_pairs <- seq_len(ncol(mtx_pairs)) |> lapply(FUN = \(x) mtx_pairs[, x]) lst_pairs <- lst_pairs[map_lgl(lst_pairs, ~ any(.x %in% include))] # exclude pairs that were not requested # create data subsets including the pairs ------------------------------------ lst_df_subsets <- lapply( lst_pairs, FUN = \(x) { df_subset <- data |> dplyr::filter(.data[[variable]] %in% .env$x) if (is.factor(data[[variable]])) { data[[variable]] <- factor(data[[variable]], ordered = is.ordered(data[[variable]])) } df_subset } ) |> # set names for returned list including the pair levels stats::setNames(map_chr(lst_pairs, ~ as.character(.x) |> shQuote(type = "csh") |> paste(collapse = " vs. "))) # perform analysis ----------------------------------------------------------- lst_ard <- imap( lst_df_subsets, \(df, pairs) { eval_capture_conditions(.f(df)) |> captured_condition_as_error( message = c(glue::glue("The following {{type}} occurred for {pairs}. See message below."), x = "{condition}") ) } ) # return result -------------------------------------------------------------- lst_ard } cards/R/rename_ard_groups.R0000644000176200001440000000677114746733642015421 0ustar liggesusers#' Rename ARD Group Columns #' #' Functions for renaming group columns names in ARDs. #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card'. #' @param shift (`integer`)\cr #' an integer specifying how many values to shift the group IDs, #' e.g. `shift=-1` renames `group2` to `group1`. #' #' @return an ARD data frame of class 'card' #' @name rename_ard_groups #' #' @examples #' ard <- ard_continuous(ADSL, by = c(SEX, ARM), variables = AGE) #' #' # Example 1 ---------------------------------- #' rename_ard_groups_shift(ard, shift = -1) #' #' # Example 2 ---------------------------------- #' rename_ard_groups_reverse(ard) NULL #' @rdname rename_ard_groups #' @export rename_ard_groups_shift <- function(x, shift = -1) { # check inputs --------------------------------------------------------------- set_cli_abort_call() check_class(x, "card") check_integerish(shift) # create data frame with old names and new names ----------------------------- df_group_names <- .group_names_as_df(x) |> dplyr::mutate( new_group_id = .data$old_group_id + as.integer(.env$shift), new_group_name = pmap( list(.data$old_group_name, .data$old_group_id, .data$new_group_id), \(old_group_name, old_group_id, new_group_id) { str_replace( old_group_name, pattern = paste0("^group", old_group_id), replacement = paste0("group", new_group_id) ) } ) |> as.character() ) # warn about bad names if (any(df_group_names$new_group_id < 1L)) { cli::cli_inform(c("There are now non-standard group column names: {.val {df_group_names$new_group_name[df_group_names$new_group_id < 1L]}}.", "i" = "Is this the shift you had planned?" )) } # rename columns and return ARD ---------------------------------------------- x |> dplyr::rename(!!!deframe(df_group_names[c("new_group_name", "old_group_name")])) } #' @rdname rename_ard_groups #' @export rename_ard_groups_reverse <- function(x) { # check inputs --------------------------------------------------------------- set_cli_abort_call() check_class(x, "card") # if no groups, return ARD unaltered ----------------------------------------- if (dplyr::select(x, all_ard_groups()) |> names() |> is_empty()) { return(x) } # create data frame with old names and new names ----------------------------- df_group_names <- .group_names_as_df(x) all_obs_ids <- sort(unique(df_group_names$old_group_id)) df_group_names$new_group_id <- dplyr::recode( df_group_names$old_group_id, !!!set_names(all_obs_ids, rev(all_obs_ids)) ) df_group_names$new_group_name <- pmap( list(df_group_names$old_group_name, df_group_names$old_group_id, df_group_names$new_group_id), \(old_group_name, old_group_id, new_group_id) { str_replace( old_group_name, pattern = paste0("^group", old_group_id), replacement = paste0("group", new_group_id) ) } ) |> as.character() # rename columns and return ARD ---------------------------------------------- x |> dplyr::rename(!!!deframe(df_group_names[c("new_group_name", "old_group_name")])) |> tidy_ard_column_order() } .group_names_as_df <- function(x) { dplyr::tibble( old_group_name = dplyr::select(x, all_ard_groups()) |> names(), old_group_id = str_extract(.data$old_group_name, "^group[0-9]+") |> str_remove("^group") |> as.integer() ) } cards/R/add_calculated_row.R0000644000176200001440000000613514663461604015511 0ustar liggesusers#' Add Calculated Row #' #' @description #' Use this function to add a new statistic row that is a function of the #' other statistics in an ARD. #' #' @param x (`card`)\cr #' data frame of class `'card'` #' @param expr (`expression`)\cr #' an expression #' @param stat_name (`string`)\cr #' string naming the new statistic #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' Grouping variables to calculate statistics within #' @param stat_label (`string`)\cr #' string of the statistic label. Default is the `stat_name`. #' @param fmt_fn (`integer`, `function`, `string`)\cr #' a function of an integer or string that can be converted to a function with #' `alias_as_fmt_fn()`. #' #' @return an ARD data frame of class 'card' #' @export #' #' @examples #' ard_continuous(mtcars, variables = mpg) |> #' add_calculated_row(expr = max - min, stat_name = "range") #' #' ard_continuous(mtcars, variables = mpg) |> #' add_calculated_row( #' expr = #' dplyr::case_when( #' mean > median ~ "Right Skew", #' mean < median ~ "Left Skew", #' .default = "Symmetric" #' ), #' stat_name = "skew" #' ) add_calculated_row <- function(x, expr, stat_name, by = c(all_ard_groups(), all_ard_variables(), any_of("context")), stat_label = stat_name, fmt_fn = NULL) { set_cli_abort_call() expr <- enexpr(expr) # check inputs --------------------------------------------------------------- check_not_missing(x) check_not_missing(expr) check_not_missing(stat_name) check_class(x, "card") check_string(stat_name) check_string(stat_label) process_selectors(x, by = {{ by }}) # calculate additional statistics -------------------------------------------- ard_calculated_stat <- x |> dplyr::group_by(dplyr::pick(any_of(by))) |> dplyr::group_map( \(x_subgroup, df_groups) { if (any(duplicated(x_subgroup$stat_name))) { cli::cli_abort( "Duplicate statistics present within {.arg by} groups: {.val {x_subgroup$stat_name[duplicated(x_subgroup$stat_name)]}}", call = get_cli_abort_call() ) } new_stat <- eval_capture_conditions( eval_tidy(expr, data = get_ard_statistics(x_subgroup)) ) if (!is_empty(new_stat[["error"]])) { cli::cli_abort( c("There was an error calculating the new statistic. See below:", "x" = new_stat[["error"]] ), call = get_cli_abort_call() ) } df_groups |> dplyr::mutate( stat = list(.env$new_stat[["result"]]), stat_name = .env$stat_name, stat_label = .env$stat_label, fmt_fn = list(fmt_fn %||% ifelse(is.numeric(new_stat[["result"]]), 1L, as.character)) ) } ) |> dplyr::bind_rows() # stack passed ARD and new ARD stats ----------------------------------------- dplyr::bind_rows( x, ard_calculated_stat ) } cards/R/print.R0000644000176200001440000001051614752441547013046 0ustar liggesusers#' Print #' #' `r lifecycle::badge('experimental')`\cr #' Print method for objects of class 'card' #' #' @param x (`data.frame`)\cr #' object of class 'card' #' @param n (`integer`)\cr #' integer specifying the number of rows to print #' @param columns (`string`)\cr #' string indicating whether to print a selected number of columns or all. #' @param n_col (`integer`)\cr #' some columns are removed when there are more than a threshold of #' columns present. This argument sets that threshold. This is only used #' when `columns='auto'` and default is `6L`. #' Columns `'error'`, `'warning'`, `'context'`, and `'fmt_fn'` *may* be removed #' from the print. All other columns will be printed, even if more than `n_col` #' columns are present. #' @param ... ([`dynamic-dots`][rlang::dyn-dots])\cr #' not used #' #' @return an ARD data frame of class 'card' (invisibly) #' @export #' @keywords internal #' #' @examples #' ard_categorical(ADSL, variables = AGEGR1) |> #' print() print.card <- function(x, n = NULL, columns = c("auto", "all"), n_col = 6L, ...) { set_cli_abort_call() # convert to a data frame so the list columns print the values in the list --- x_print <- as.data.frame(x) # number of rows to print (modeled after tibbles print) ---------------------- n <- n %||% ifelse(nrow(x_print) > 20L, 10L, nrow(x_print)) x_print <- utils::head(x_print, n = n) # remove columns ------------------------------------------------------------- if (arg_match(columns) %in% "auto") { x_print <- dplyr::select( x_print, all_ard_groups(), all_ard_variables(), any_of(c( "context", "stat_name", "stat_label", "stat", "stat_fmt", "fmt_fn", "warning", "error" )) ) # remove warning and error columns if nothing to report if (ncol(x_print) > n_col && "warning" %in% names(x_print) && every(x_print[["warning"]], is.null)) { x_print[["warning"]] <- NULL } if (ncol(x_print) > n_col && "error" %in% names(x_print) && every(x_print[["error"]], is.null)) { x_print[["error"]] <- NULL } # remove 'fmt_fn' col if there are many cols if (ncol(x_print) > n_col) { x_print[["fmt_fn"]] <- NULL } # remove 'context' col if there are many cols if (ncol(x_print) > n_col) { x_print[["context"]] <- NULL } } # truncate the 'group##_level', 'variable_level', 'stat_label', and 'context' columns ------ x_print <- tryCatch( x_print |> dplyr::mutate( across( c( all_ard_groups("levels"), all_ard_variables("levels"), any_of(c("context", "stat_label", "warning", "error")) ), function(x) { lapply( x, function(e) { e <- as.character(e) |> paste(collapse = ", ") ifelse(nchar(e) > 9, paste0(substr(e, 1, 8), "\u2026"), e) } ) } ) ), error = function(e) x_print ) # for the statistics, round to 3 decimal places ------------------------------ if ("stat" %in% names(x_print)) { x_print$stat <- lapply( x_print$stat, function(x) { if (isTRUE(is.numeric(x))) { res <- round5(x, digits = 3) } else { res <- as.character(x) } if (is_string(res) && nchar(res) > 9) { res <- paste0(substr(res, 1, 8), "\u2026") } res } ) } # for the formatting function column, abbreviate the print of proper functions if ("fmt_fn" %in% names(x_print)) { x_print$fmt_fn <- lapply( x_print$fmt_fn, function(x) { if (isTRUE(is.function(x))) { return("") } x } ) } # final printing -------------------------------------------------------------- cli::cli_text(cli::col_grey("{{cards}} data frame: {nrow(x)} x {ncol(x)}")) print(x_print) if (nrow(x) > n) { cli::cli_alert_info(cli::col_grey("{nrow(x) - n} more rows")) cli::cli_alert_info(cli::col_grey("Use {.code print(n = ...)} to see more rows")) } if (ncol(x) > ncol(x_print)) { missing_cols <- names(x) |> setdiff(names(x_print)) cli::cli_alert_info(cli::col_grey( "{length(missing_cols)} more variable{?s}: {paste(missing_cols, collapse = ', ')}" )) } invisible(x) } cards/R/tidy_ard_order.R0000644000176200001440000000475114754702430014701 0ustar liggesusers#' Standard Order of ARD #' #' @description #' ARD functions for relocating columns and rows to the standard order. #' #' - `tidy_ard_column_order()` relocates columns of the ARD to the standard order. #' #' - `tidy_ard_row_order()` orders rows of ARD according to groups and #' strata (group 1, then group2, etc), while retaining the column order of the input ARD. #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' @param group_order (`string`)\cr #' specifies the ordering of the grouping variables. #' Must be one of `c("ascending", "descending")`. #' Default is `"ascending"`, where grouping variables begin with `"group1"` variables, #' followed by `"group2"` variables, etc. #' #' @return an ARD data frame of class 'card' #' @name tidy_ard_order #' #' @examples #' # order columns #' ard <- #' dplyr::bind_rows( #' ard_continuous(mtcars, variables = "mpg"), #' ard_continuous(mtcars, variables = "mpg", by = "cyl") #' ) #' #' tidy_ard_column_order(ard) |> #' tidy_ard_row_order() NULL #' @rdname tidy_ard_order #' @export tidy_ard_column_order <- function(x, group_order = c("ascending", "descending")) { set_cli_abort_call() group_order <- arg_match(group_order) # specify the ordering the grouping variables group_cols <- data.frame(colname = dplyr::select(x, all_ard_groups()) |> names()) |> dplyr::arrange( case_switch( group_order == "ascending" ~ as.integer(unlist(str_extract_all(.data$colname, "\\d+"))), group_order == "descending" ~ dplyr::desc(as.integer(unlist(str_extract_all(.data$colname, "\\d+")))) ), .data$colname ) |> dplyr::pull("colname") # selecting the columns in the tidy order dplyr::select( x, all_of(group_cols), all_ard_variables(), any_of(c( "context", "stat_name", "stat_label", "stat", "stat_fmt", "fmt_fn", "warning", "error" )), dplyr::everything() ) } #' @rdname tidy_ard_order #' @export tidy_ard_row_order <- function(x) { set_cli_abort_call() # get columns that dictate ordering cols <- x |> dplyr::select(all_ard_groups(c("names", "levels"))) |> names() if (!is_empty(cols)) { max_group_n <- as.integer(unlist(str_extract_all(cols, "\\d+"))) |> max() cols <- map(seq_len(max_group_n), ~ c(paste0("group", .x), paste0("group", .x, "_level"))) |> unlist() |> intersect(cols) } # perform the ordering x |> dplyr::arrange(across(all_of(cols), .fns = function(x) match(x, unique(x)))) } cards/R/update_ard.R0000644000176200001440000001126214752417603014015 0ustar liggesusers#' Update ARDs #' #' @description #' Functions used to update ARD formatting functions and statistic labels. #' #' This is a helper function to streamline the update process. If it does not #' exactly meet your needs, recall that an ARD is just a data frame and it #' can be modified directly. #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' variables in `x$variable` to apply update. Default is `everything()`. #' @param stat_names (`character`)\cr #' character vector of the statistic names (i.e. values from `x$stat_name`) to #' apply the update. #' @param fmt_fn (`function`)\cr #' a function or alias recognized by `alias_as_fmt_fn()`. #' @param stat_label (`function`)\cr #' a string of the updated statistic label. #' @param filter (`expression`)\cr #' an expression that evaluates to a logical vector identifying rows in `x` #' to apply the update to. Default is `TRUE`, and update is applied to #' all rows. #' #' @return an ARD data frame of class 'card' #' @name update_ard #' #' @examples #' ard_continuous(ADSL, variables = AGE) |> #' update_ard_fmt_fn(stat_names = c("mean", "sd"), fmt_fn = 8L) |> #' update_ard_stat_label(stat_names = c("mean", "sd"), stat_label = "Mean (SD)") |> #' apply_fmt_fn() #' #' # same as above, but only apply update to the Placebo level #' ard_continuous( #' ADSL, #' by = ARM, #' variables = AGE, #' statistic = ~ continuous_summary_fns(c("N", "mean")) #' ) |> #' update_ard_fmt_fn(stat_names = "mean", fmt_fn = 8L, filter = group1_level == "Placebo") |> #' apply_fmt_fn() NULL #' @export #' @rdname update_ard update_ard_fmt_fn <- function(x, variables = everything(), stat_names, fmt_fn, filter = TRUE) { set_cli_abort_call() # check and process inputs --------------------------------------------------- check_class(x, "card") process_selectors(data = dplyr::tibble(!!!rep_named(unique(x$variable), NA)), variables = {{ variables }}) check_class(stat_names, "character") check_length(fmt_fn, 1L) # construct lgl index condition ---------------------------------------------- # first evaluate the variable and stat_names idx1 <- eval_tidy(expr(.data$variable %in% variables & .data$stat_name %in% stat_names), data = x) # and then add any additional reqs passed in `filter` idx2 <- tryCatch( eval_tidy(enquo(filter), data = x), error = function(e) { cli::cli_abort( c("There was an error evaluating the {.arg filter} argument. See below:", "x" = "{conditionMessage(e)}" ), call = get_cli_abort_call() ) } ) if (!is.vector(idx2) || !is.logical(idx2) || (length(idx2) != 1L && length(idx2) != nrow(x))) { cli::cli_abort( "The {.arg filter} argument must be an expression that evaluates to a {.cls logical} vector of length {.val {1L}} or {.val {nrow(x)}}.", call = get_cli_abort_call() ) } # update ARD with new fmt_fn ------------------------------------------------- x$fmt_fn[idx1 & idx2] <- list(alias_as_fmt_fn(fmt_fn)) # return ard ----------------------------------------------------------------- x } #' @export #' @rdname update_ard update_ard_stat_label <- function(x, variables = everything(), stat_names, stat_label, filter = TRUE) { # check and process inputs --------------------------------------------------- check_class(x, "card") process_selectors(data = dplyr::tibble(!!!rep_named(unique(x$variable), NA)), variables = {{ variables }}) check_class(stat_names, "character") check_string(stat_label) # construct lgl index condition ---------------------------------------------- # first evaluate the variable and stat_names idx1 <- eval_tidy(expr(.data$variable %in% variables & .data$stat_name %in% stat_names), data = x) # and then add any additional reqs passed in `filter` idx2 <- tryCatch( eval_tidy(enquo(filter), data = x), error = function(e) { cli::cli_abort( c("There was an error evaluating the {.arg filter} argument. See below:", "x" = "{conditionMessage(e)}" ), call = get_cli_abort_call() ) } ) if (!is.vector(idx2) || !is.logical(idx2) || (length(idx2) != 1L && length(idx2) != nrow(x))) { cli::cli_abort( "The {.arg filter} argument must be an expression that evaluates to a {.cls logical} vector of length {.val {1L}} or {.val {nrow(x)}}.", call = get_cli_abort_call() ) } # update ARD with new stat_label --------------------------------------------- x$stat_label[idx1 & idx2] <- stat_label # return ard ----------------------------------------------------------------- x } cards/R/ard_strata.R0000644000176200001440000000613314754702430014027 0ustar liggesusers#' Stratified ARD #' #' @description #' General function for calculating ARD results within subgroups. #' #' While the examples below show use with other functions from the cards package, #' this function would primarily be used with the statistical functions in the #' cardx functions. #' #' @param .data (`data.frame`)\cr #' a data frame #' @param .by,.strata ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' columns to tabulate by/stratify by for calculation. #' Arguments are similar, but with an important distinction: #' #' `.by`: results are tabulated by **all combinations** of the columns specified, #' including unobserved combinations and unobserved factor levels. #' #' `.strata`: results are tabulated by **all _observed_ combinations** of the #' columns specified. #' #' These argument *should not* include any columns that appear in the `.f` argument. #' @param .f (`function`, `formula`)\cr #' a function or a formula that can be coerced to a function with #' `rlang::as_function()` (similar to `purrr::map(.f)`) #' @param ... Additional arguments passed on to the `.f` function. #' #' @return an ARD data frame of class 'card' #' @export #' #' @examples #' ard_strata( #' ADSL, #' .by = ARM, #' .f = ~ ard_continuous(.x, variables = AGE) #' ) ard_strata <- function(.data, .by = NULL, .strata = NULL, .f, ...) { set_cli_abort_call() # check inputs --------------------------------------------------------------- check_not_missing(.data) check_not_missing(.f) check_data_frame(.data) # process inputs ------------------------------------------------------------- .f <- rlang::as_function(x = .f, call = get_cli_abort_call()) process_selectors(.data, .by = {{ .by }}, .strata = {{ .strata }}) # nest the data frame -------------------------------------------------------- df_nested_data <- nest_for_ard(.data, by = .by, strata = .strata) # run fn on nested data frames ----------------------------------------------- df_nested_data <- df_nested_data |> dplyr::mutate(ard = map(.data$data, .f, ...)) |> dplyr::select(-"data") # rename grouping variables -------------------------------------------------- # get the number grouping columns in the calculations max_group_n <- map( df_nested_data$ard, ~ dplyr::select(.x, all_ard_groups("names")) |> names() ) |> unlist() |> unique() |> sort() |> str_remove(pattern = "^group") |> as.integer() %>% # if no grouping variables are present, this will return `-Inf` {suppressWarnings(max(..1 = .))} # styler: off if (!is.infinite(max_group_n) && !is_empty(c(.by, .strata))) { new_group_colnames <- c( paste0("group", seq_along(c(.by, .strata)) + max_group_n), paste0("group", seq_along(c(.by, .strata)) + max_group_n, "_level") ) |> sort() names(df_nested_data)[seq_along(new_group_colnames)] <- new_group_colnames } # unnest ard data frame and return final table ------------------------------- df_nested_data |> tidyr::unnest(cols = all_of("ard")) |> as_card() |> tidy_ard_column_order(group_order = "descending") } cards/R/round5.R0000644000176200001440000000146714747215214013125 0ustar liggesusers#' Rounding of Numbers #' #' Rounds the values in its first argument to the specified number of #' decimal places (default 0). Importantly, `round5()` **does not** use Base R's #' "round to even" default. Standard rounding methods are implemented, for example, #' `cards::round5(0.5) = 1`, whereas `base::round(0.5) = 0`. #' #' @details #' Function inspired by `janitor::round_half_up()`. #' #' @param x (`numeric`)\cr #' a numeric vector #' @param digits (`integer`)\cr #' integer indicating the number of decimal places #' #' @return a numeric vector #' @export #' #' @examples #' x <- 0:4 / 2 #' round5(x) |> setNames(x) #' #' # compare results to Base R #' round(x) |> setNames(x) round5 <- function(x, digits = 0) { trunc(abs(x) * 10^digits + 0.5 + sqrt(.Machine$double.eps)) / 10^digits * sign(as.numeric(x)) } cards/R/apply_fmt_fn.R0000644000176200001440000001720114767676405014377 0ustar liggesusers#' Apply Formatting Functions #' #' Apply the formatting functions to each of the raw statistics. #' Function aliases are converted to functions using [alias_as_fmt_fn()]. #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' @param replace (scalar `logical`)\cr #' logical indicating whether to replace values in the `'stat_fmt'` column (if present). #' Default is `FALSE`. #' #' @return an ARD data frame of class 'card' #' @export #' #' @examples #' ard_continuous(ADSL, variables = "AGE") |> #' apply_fmt_fn() apply_fmt_fn <- function(x, replace = FALSE) { set_cli_abort_call() check_class(x, cls = "card") check_scalar_logical(replace) # add stat_fmt if not already present, if replace is TRUE overwrite existing stat_fmt column if (!"stat_fmt" %in% names(x) || isTRUE(replace)) { x <- x |> dplyr::mutate(.after = "stat", stat_fmt = list(NULL)) } x |> dplyr::mutate( stat_fmt = pmap( list( .data$stat, .data$variable, .data$stat_name, .data$fmt_fn, .data$stat_fmt ), function(stat, variable, stat_name, fn, stat_fmt) { if (!is.null(fn) && is.null(stat_fmt)) { tryCatch( do.call(alias_as_fmt_fn(fn, variable, stat_name), args = list(stat)), error = \(e) { cli::cli_abort( c("There was an error applying the formatting function to statistic {.val {stat_name}} for variable {.val {variable}}.", "i" = "Perhaps try formmatting function {.fun as.character}? See error message below:", "x" = conditionMessage(e) ), call = get_cli_abort_call() ) } ) } else { stat_fmt } } ) ) } #' Convert Alias to Function #' #' @description #' Accepted aliases are non-negative integers and strings. #' #' The integers are converted to functions that round the statistics #' to the number of decimal places to match the integer. #' #' The formatting strings come in the form `"xx"`, `"xx.x"`, `"xx.x%"`, etc. #' The number of `x`s that appear after the decimal place indicate the number of #' decimal places the statistics will be rounded to. #' The number of `x`s that appear before the decimal place indicate the leading #' spaces that are added to the result. #' If the string ends in `"%"`, results are scaled by 100 before rounding. #' #' @param x (`integer`, `string`, or `function`)\cr #' a non-negative integer, string alias, or function #' @param variable (`character`)\cr the variable whose statistic is to be formatted #' @param stat_name (`character`)\cr the name of the statistic that is to be formatted #' #' @return a function #' @export #' #' @examples #' alias_as_fmt_fn(1) #' alias_as_fmt_fn("xx.x") alias_as_fmt_fn <- function(x, variable, stat_name) { set_cli_abort_call() if (is.function(x)) { return(x) } if (is_integerish(x) && x >= 0L) { return(label_round(digits = as.integer(x))) } if (is_string(x)) { .check_fmt_string(x, variable, stat_name) scale <- ifelse(endsWith(x, "%"), 100, 1) decimal_n <- ifelse( !grepl("\\.", x), 0L, gsub("%", "", x) |> # remove percent sign if it is there strsplit(split = ".", fixed = TRUE) |> # split string at decimal place unlist() %>% `[`(2) %>% # get the string after the period {ifelse(is.na(.), 0L, nchar(.))} # styler: off ) width <- nchar(x) - endsWith(x, "%") return(label_round(digits = decimal_n, scale = scale, width = width)) } # if the above conditions are not met, return an error ----------------------- if (!missing(variable) && !missing(stat_name)) { error_message <- c("The value in {.arg fmt_fn} cannot be converted into a function for statistic {.val {stat_name}} and variable {.val {variable}}.", "i" = "Value must be a function, a non-negative integer, or a formatting string, e.g. {.val xx.x}.", "*" = "See {.help cards::alias_as_fmt_fn} for details." ) } else { error_message <- c("The value in {.arg fmt_fn} cannot be converted into a function.", "i" = "Value must be a function, a non-negative integer, or a formatting string, e.g. {.val xx.x}.", "*" = "See {.help cards::alias_as_fmt_fn} for details." ) } cli::cli_abort( message = error_message, call = get_cli_abort_call() ) } #' Generate Formatting Function #' #' Returns a function with the requested rounding and scaling schema. #' #' @param digits (`integer`)\cr #' a non-negative integer specifying the number of decimal places #' round statistics to #' @param scale (`numeric`)\cr #' a scalar real number. Before rounding, the input will be scaled by #' this quantity #' @param width (`integer`)\cr #' a non-negative integer specifying the minimum width of the #' returned formatted values #' #' @return a function #' @export #' #' @examples #' label_round(2)(pi) #' label_round(1, scale = 100)(pi) #' label_round(2, width = 5)(pi) label_round <- function(digits = 1, scale = 1, width = NULL) { round_fun <- .get_round_fun() function(x) { # round and scale vector res <- ifelse( is.na(x), NA_character_, format(round_fun(x * scale, digits = digits), nsmall = digits) |> str_trim() ) # if width provided, pad formatted result if (!is.null(width)) { res <- ifelse( nchar(res) >= width | is.na(res), res, paste0(strrep(" ", width - nchar(res)), res) ) } # return final formatted vector res } } .get_round_fun <- function() { switch(getOption("cards.round_type", default = "round-half-up"), "round-half-up" = round5, "round-to-even" = round ) %||% cli::cli_abort( "The {.arg cards.round_type} {.emph option} must be one of {.val {c('round-half-up', 'round-to-even')}}.", call = get_cli_abort_call() ) } #' Check 'xx' Format Structure #' #' @description #' A function that checks a **single** string for consistency. #' String must begin with 'x' and only consist of x's, a single period or none, #' and may end with a percent symbol. #' #' If string is consistent, `TRUE` is returned. Otherwise an error. #' #' @param x (`string`)\cr #' string to check #' @param variable (`character`)\cr the variable whose statistic is to be formatted #' @param stat_name (`character`)\cr the name of the statistic that is to be formatted #' #' @return a logical #' @keywords internal #' #' @examples #' cards:::.check_fmt_string("xx.x") # TRUE #' cards:::.check_fmt_string("xx.x%") # TRUE .check_fmt_string <- function(x, variable, stat_name) { set_cli_abort_call() # perform checks on the string fmt_is_good <- grepl("^x[x.%]+$", x = x) && # string begins with 'x', and consists of only x, period, or percent sum(unlist(gregexpr("\\.", x)) != -1) %in% c(0L, 1L) && # a period appears 0 or 1 times sum(unlist(gregexpr("%", x)) != -1) %in% c(0L, 1L) && # a percent appears 0 or 1 times (sum(unlist(gregexpr("%", x)) != -1) %in% 0L || grepl(pattern = "%$", x = x)) # if there is a % it appears at the end if (isFALSE(fmt_is_good)) { cli::cli_abort( message = "The format {.val {x}} for `fmt_fn` is not valid for the variable {.val {variable}} for the statistic {.val {stat_name}}. String must begin with 'x' and only consist of x's, a single period or none, and may end with a percent symbol.", call = get_cli_abort_call() ) } fmt_is_good } cards/R/sort_ard_hierarchical.R0000644000176200001440000002242414776242611016223 0ustar liggesusers#' Sort Stacked Hierarchical ARDs #' #' @description `r lifecycle::badge('experimental')`\cr #' #' This function is used to sort stacked hierarchical ARDs. #' #' For the purposes of this function, we define a "variable group" as a combination of ARD rows grouped by the #' combination of all their variable levels, but excluding any `by` variables. #' #' @param x (`card`)\cr #' a stacked hierarchical ARD of class `'card'` created using [ard_stack_hierarchical()] or #' [`ard_stack_hierarchical_count()`]. #' @param sort (`string`)\cr #' type of sorting to perform. Value must be one of: #' - `"alphanumeric"` - within each hierarchical section of the ARD, groups are ordered alphanumerically (i.e. A to Z) #' by `variable_level` text. #' - `"descending"` - within each variable group of the ARD, count sums are calculated for each group and groups are #' sorted in descending order by sum. If `sort = "descending"`, the `n` statistic is used to calculate variable #' group sums if included in `statistic` for all variables, otherwise `p` is used. If neither `n` nor `p` are #' present in `x` for all variables, an error will occur. #' #' Defaults to `"descending"`. #' #' @return an ARD data frame of class 'card' #' @seealso [filter_ard_hierarchical()] #' @name sort_ard_hierarchical #' #' @note #' If overall data is present in `x` (i.e. the ARD was created with `ard_stack_hierarchical(overall=TRUE)`), the #' overall data will be sorted last within each variable group (i.e. after any other rows with the same combination of #' variable levels). #' #' @examplesIf (identical(Sys.getenv("NOT_CRAN"), "true") || identical(Sys.getenv("IN_PKGDOWN"), "true")) #' ard_stack_hierarchical( #' ADAE, #' variables = c(AESOC, AEDECOD), #' by = TRTA, #' denominator = ADSL |> dplyr::rename(TRTA = ARM), #' id = USUBJID #' ) |> #' sort_ard_hierarchical("alphanumeric") #' #' ard_stack_hierarchical_count( #' ADAE, #' variables = c(AESOC, AEDECOD), #' by = TRTA, #' denominator = ADSL |> dplyr::rename(TRTA = ARM) #' ) |> #' sort_ard_hierarchical("descending") NULL #' @rdname sort_ard_hierarchical #' @export sort_ard_hierarchical <- function(x, sort = c("descending", "alphanumeric")) { set_cli_abort_call() # check and process inputs --------------------------------------------------------------------- check_not_missing(x) check_not_missing(sort) check_class(x, "card") if (!"args" %in% names(attributes(x))) { cli::cli_abort( paste( "Sorting is only available for stacked hierarchical ARDs created using", "{.fun ard_stack_hierarchical} or {.fun ard_stack_hierarchical_count}." ), call = get_cli_abort_call() ) } sort <- arg_match(sort, error_call = get_cli_abort_call()) x_args <- attributes(x)$args by_cols <- if (length(x_args$by) > 0) paste0("group", seq_along(length(x_args$by)), c("", "_level")) else NULL # for calculations by highest severity, innermost variable is extracted from by if (length(x_args$by) > 1) { x_args$variables <- c(x_args$variables, x_args$by[-1]) x_args$include <- c(x_args$include, x_args$by[-1]) x_args$by <- x_args$by[-1] } outer_cols <- if (length(x_args$variables) > 1) { x_args$variables |> utils::head(-1) |> stats::setNames(x |> dplyr::select(cards::all_ard_groups("names"), -all_of(by_cols)) |> names()) } else { NULL } # reformat ARD for sorting --------------------------------------------------------------------- x_sort <- x |> dplyr::mutate(idx = dplyr::row_number()) |> .ard_reformat_sort(sort, x_args$by, outer_cols) if (sort == "alphanumeric") { # alphanumeric sort -------------------------------------------------------------------------- sort_cols <- c( x |> dplyr::select(all_ard_groups(), -all_of(by_cols[c(FALSE, TRUE)])) |> names(), "variable", "variable_level" ) # sort alphanumerically and get index order idx_sorted <- x_sort |> dplyr::arrange(dplyr::pick(all_of(sort_cols))) |> dplyr::pull("idx") } else { # descending sort ---------------------------------------------------------------------------- # all variables in x have n or p stat present (not required if filtered out first) n_all <- length(setdiff( intersect(x_args$include, x$variable), x |> dplyr::filter(.data$stat_name == "n") |> dplyr::pull("variable") )) == 0 if (!n_all) { p_all <- length(setdiff( intersect(x_args$include, x$variable), x |> dplyr::filter(.data$stat_name == "p") |> dplyr::pull("variable") )) == 0 if (!p_all) { cli::cli_abort( paste( "If {.code sort='descending'} then either {.val n} or {.val p} must be present in {.arg x} for all", "variables in order to calculate the count sums used for sorting." ), call = get_cli_abort_call() ) } } sort_stat <- if (n_all) "n" else "p" # calculate sums for each hierarchy level section/row x_sort <- x_sort |> .append_hierarchy_sums(by_cols, outer_cols, x_args$include, sort_stat) sort_cols <- c(by_cols[c(TRUE, FALSE)], rbind( x_sort |> dplyr::select(all_ard_groups("names"), -all_of(by_cols)) |> names(), x_sort |> dplyr::select(dplyr::starts_with("sum_group")) |> names(), x_sort |> dplyr::select(all_ard_groups("levels"), -all_of(by_cols)) |> names() ), "variable", "sum_row", "variable_level") # sort by descending row sum and get index order idx_sorted <- x_sort |> dplyr::arrange(across(all_of(sort_cols), .fns = ~ (if (is.numeric(.x)) dplyr::desc(.x) else .x))) |> dplyr::pull("idx") } x <- x[idx_sorted, ] # keep attributes at bottom of ARD idx_attr <- x$context == "attributes" x <- dplyr::bind_rows(x[!idx_attr, ], x[idx_attr, ]) x } # this function reformats a hierarchical ARD for sorting .ard_reformat_sort <- function(x, sort, by, outer_cols) { # reformat data from overall column (if present) is_overall_col <- apply(x, 1, function(x) !isTRUE(any(x %in% by)) || x$context == "attributes") if (sum(is_overall_col) > 0 && length(by) > 0) { x_overall_col <- x[is_overall_col, ] |> cards::rename_ard_groups_shift(shift = length(by)) |> dplyr::mutate( group1 = by[1], group1_level = list("..overall..") ) |> dplyr::select(any_of(names(x))) x <- dplyr::bind_rows(x[!is_overall_col, ], x_overall_col) } x <- x |> dplyr::group_by(.data$variable) |> dplyr::group_split() |> # fill in variable/variable_level in their corresponding grouping columns map(function(dat) { cur_var <- dat$variable |> unique() |> as.character() grp_match <- names(which(outer_cols == cur_var)) if (length(grp_match) > 0) { dat |> dplyr::mutate( !!grp_match := ifelse(is.na(dat[[grp_match]]), cur_var, dat[[grp_match]]), !!paste0(grp_match, "_level") := ifelse( is.na(dat[[grp_match]]), dat$variable_level, dat[[paste0(grp_match, "_level")]] ), variable = if (sort == "alphanumeric") "..empty.." else .data$variable ) } else if (cur_var == "..ard_hierarchical_overall..") { dat |> dplyr::mutate( group1 = "..overall..", variable_level = list("..overall..") ) } else if (cur_var == "..ard_total_n..") { dat |> dplyr::mutate( group1 = "..empty..", group1_level = list(NA), variable = NA, ) } else { dat } }) |> dplyr::bind_rows() |> tidyr::unnest(all_of(c(cards::all_ard_groups("levels"), cards::all_ard_variables("levels")))) |> # summary row groups remain at the top of each sub-section when sorting dplyr::mutate(across(c(all_ard_groups("names")), .fns = ~ tidyr::replace_na(., "..empty.."))) x } # this function calculates and appends n sums for each hierarchy level section/row (across by variables) .append_hierarchy_sums <- function(x, by_cols, outer_cols, include, sort_stat) { g_vars <- c() # calculate sums at each outer hierarchy level for (g in names(outer_cols)) { g_vars <- c(g_vars, g, paste0(g, "_level")) # if variable not in include, use the sums from the next variable available if (outer_cols[g] %in% include) { next_incl <- outer_cols[g] var_nm <- "variable" } else { inner_var <- dplyr::last(include) next_incl <- intersect(c(outer_cols[which(names(outer_cols) == g):length(outer_cols)], inner_var), include)[1] var_nm <- if (next_incl == inner_var) "variable" else names(outer_cols)[which(outer_cols == next_incl)] } g_sums <- x |> dplyr::filter(.data$stat_name == sort_stat, .data[[var_nm]] == next_incl) |> dplyr::group_by(across(all_of(g_vars))) |> dplyr::summarize(!!paste0("sum_", g) := sum(unlist(.data$stat[.data$stat_name == sort_stat]))) # append sums to each row x <- x |> dplyr::left_join(g_sums, by = g_vars) # remove variable name for outer hierarchy variables x$variable[x$variable == outer_cols[g]] <- "..empty.." } # append row sums for every row (across by variables) x <- x |> dplyr::group_by(across(c(all_ard_groups(), all_ard_variables(), -all_of(by_cols)))) |> dplyr::reframe(across(everything()), sum_row = sum(unlist(.data$stat[.data$stat_name == sort_stat]))) x } cards/R/check_ard_structure.R0000644000176200001440000000526014754462404015732 0ustar liggesusers#' Check ARD Structure #' #' Function tests the structure and returns notes when object does not #' conform to expected structure. #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' @param column_order (scalar `logical`)\cr #' check whether ordering of columns adheres to to `cards::tidy_ard_column_order()`. #' @param method (scalar `logical`)\cr #' check whether a `"stat_name"` equal to `"method"` appears in results. #' @return an ARD data frame of class 'card' (invisible) #' @export #' #' @examples #' ard_continuous(ADSL, variables = "AGE") |> #' dplyr::select(-warning, -error) |> #' check_ard_structure() check_ard_structure <- function(x, column_order = TRUE, method = TRUE) { set_cli_abort_call() check_scalar_logical(method) check_scalar_logical(column_order) # check class ---------------------------------------------------------------- if (!inherits(x, "card")) { cli::cli_inform("Object is not of class {.cls card}.") } # exit if not a data frame --------------------------------------------------- if (!inherits(x, "data.frame")) { return(invisible()) } # check expected variables are present --------------------------------------- missing_variables <- c( "variable", "stat_name", "stat_label", "stat", "fmt_fn", "warning", "error" ) |> setdiff(names(x)) if (!is_empty(missing_variables)) { cli::cli_inform("The following columns are not present: {.val {missing_variables}}.") } # check whether AR contains a method stat ------------------------------------ if (isTRUE(method)) { if (!"method" %in% x$stat_name) { cli::cli_inform("Expecting a row with {.code stat_name = 'method'}, but it is not present.") } } # check order of columns ----------------------------------------------------- if (isTRUE(column_order)) { if (!identical(names(x), names(tidy_ard_column_order(x)))) { cli::cli_inform( c("The column order is not in the standard order.", i = "Use {.fun cards::tidy_ard_column_order} for standard ordering." ) ) } } # check columns are list columns as expected --------------------------------- expected_lst_columns <- dplyr::select( x, all_ard_groups(), all_ard_variables(), any_of(c("stat", "fmt_fn", "warning", "error")) ) |> # remove group## and variable columns dplyr::select(-matches("^group[0-9]$"), -"variable") |> names() not_a_lst_columns <- x[expected_lst_columns] |> dplyr::select(-where(is.list)) |> names() if (!is_empty(not_a_lst_columns)) { cli::cli_inform("The following columns are expected to be list columns: {.val {not_a_lst_columns}}.") } invisible(x) } cards/R/summary_functions.R0000644000176200001440000000474214632353606015476 0ustar liggesusers#' Summary Functions #' #' @description #' - `continuous_summary_fns()` returns a named list of summary functions #' for continuous variables. Some functions include slight modifications to #' their base equivalents. For example, the `min()` and `max()` functions #' return `NA` instead of `Inf` when an empty vector is passed. #' Statistics `"p25"` and `"p75"` are calculated with `quantile(type = 2)`, #' which matches #' [SAS's default value](https://psiaims.github.io/CAMIS/Comp/r-sas-summary-stats.html). #' #' @param summaries (`character`)\cr #' a character vector of results to include in output. Select one or more from #' `r eval(formals(continuous_summary_fns)$summaries) %>% {paste(shQuote(., "sh"), collapse = ", ")}`. #' @param other_stats (named `list`)\cr #' named list of other statistic functions to supplement the pre-programmed functions. #' #' @return named list of summary statistics #' @name summary_functions #' #' @examples #' # continuous variable summaries #' ard_continuous( #' ADSL, #' variables = "AGE", #' statistic = ~ continuous_summary_fns(c("N", "median")) #' ) NULL #' @rdname summary_functions #' @export continuous_summary_fns <- function(summaries = c( "N", "mean", "sd", "median", "p25", "p75", "min", "max" ), other_stats = NULL) { set_cli_abort_call() # process the selection of the summary stats to include ---------------------- summaries <- arg_match(summaries, multiple = TRUE) # list all functions available by default ------------------------------------ list_fns <- list( N = function(x) length(x), mean = function(x) mean(x, na.rm = TRUE), sd = function(x) stats::sd(x, na.rm = TRUE), median = function(x) stats::median(x, na.rm = TRUE), p25 = function(x) stats::quantile(x, probs = 0.25, na.rm = TRUE, type = 2) |> unname(), p75 = function(x) stats::quantile(x, probs = 0.75, na.rm = TRUE, type = 2) |> unname(), min = function(x) { if (length(x) == 0L) { return(structure(NA, class = class(x))) } min(x, na.rm = TRUE) }, max = function(x) { if (length(x) == 0L) { return(structure(NA, class = class(x))) } max(x, na.rm = TRUE) } ) # return list of functions --------------------------------------------------- list_fns[summaries] |> c(other_stats) } cards/R/selectors.R0000644000176200001440000000506114754702430013705 0ustar liggesusers#' ARD Selectors #' #' @description #' These selection helpers match variables according to a given pattern. #' #' - `all_ard_groups()`: Function selects grouping columns, e.g. columns #' named `"group##"` or `"group##_level"`. #' #' - `all_ard_variables()`: Function selects variables columns, e.g. columns #' named `"variable"` or `"variable_level"`. #' #' - `all_ard_group_n()`: Function selects `n` grouping columns. #' #' - `all_missing_columns()`: Function selects columns that are all `NA` or empty. #' #' @param types (`character`)\cr #' type(s) of columns to select. `"names"` selects the columns variable name columns, #' and `"levels"` selects the level columns. Default is `c("names", "levels")`. #' @param n (`integer`)\cr #' integer(s) indicating which grouping columns to select. #' #' @return tidyselect output #' @name selectors #' #' @examples #' ard <- ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") #' #' ard |> dplyr::select(all_ard_groups()) #' ard |> dplyr::select(all_ard_variables()) NULL #' @export #' @rdname selectors all_ard_groups <- function(types = c("names", "levels")) { types <- arg_match(types, values = c("names", "levels"), multiple = TRUE) if (setequal(types, c("names", "levels"))) { return(dplyr::matches("^group[0-9]+$|^group[0-9]+_level$")) } if (setequal(types, "names")) { return(dplyr::matches("^group[0-9]+$$")) } if (setequal(types, "levels")) { return(dplyr::matches("^group[0-9]+_level$")) } } #' @export #' @rdname selectors all_ard_variables <- function(types = c("names", "levels")) { types <- arg_match(types, values = c("names", "levels"), multiple = TRUE) if (setequal(types, c("names", "levels"))) { return(dplyr::any_of(c("variable", "variable_level"))) } if (setequal(types, "names")) { return(dplyr::any_of("variable")) } if (setequal(types, "levels")) { return(dplyr::any_of("variable_level")) } } #' @export #' @rdname selectors all_ard_group_n <- function(n, types = c("names", "levels")) { types <- arg_match(types, values = c("names", "levels"), multiple = TRUE) group_cols <- character(0L) if ("names" %in% types) group_cols <- c(group_cols, paste0("group", n)) # styler: off if ("levels" %in% types) group_cols <- c(group_cols, paste0("group", n, "_level")) # styler: off check_integerish(n) any_of(sort(group_cols)) } #' @export #' @rdname selectors all_missing_columns <- function() { where(\(x) case_switch(is.list(x) ~ all_empty(x), .default = all_na(x))) } all_na <- function(x) all(is.na(x)) all_empty <- function(x) all(map_lgl(x, is_empty)) cards/R/deprecated.R0000644000176200001440000000150714776253226014013 0ustar liggesusers#' Deprecated functions #' #' `r lifecycle::badge('deprecated')`\cr #' Some functions have been deprecated and are no longer being actively #' supported. #' #' @name deprecated #' @keywords internal NULL # "soft" deprecation for 6 months: (Sys.Date() - lubridate::dmonths(6)) |> as.Date() # v0.5.1 2025-03-01 # v0.5.0 2025-02-17 # "warn" deprecation for 12 months: (Sys.Date() - lubridate::dmonths(12)) |> as.Date() # "stop" deprecation for 18 months: (Sys.Date() - lubridate::dmonths(18)) |> as.Date() # Deprecated on 2025-02-08: I don't think any users would have utilized this function, and we can do a quick deprecation cycle. #' @rdname deprecated #' @export label_cards <- function(...) { lifecycle::deprecate_soft( when = "0.5.0", what = "cards::label_cards()", with = "label_round()" ) label_round(...) } cards/R/options.R0000644000176200001440000000206614753417324013403 0ustar liggesusers#' Options in \{cards\} #' #' @name cards.options #' @description #' See below for options available in the \{cards\} package #' #' @section cards.round_type: #' There are two types of rounding types in the \{cards\} package that are implemented #' in `label_round()`, `alias_as_fmt_fn()`, and `apply_fmt_fn()` functions' `round_type` #' argument. #' #' - `'round-half-up'` (_default_): rounding method where values exactly halfway #' between two numbers are rounded to the larger in magnitude number. #' Rounding is implemented via [`round5()`]. #' - `'round-to-even'`: base R's default IEC 60559 rounding standard. #' See [`round()`] for details. #' #' To change the default rounding to use IEC 60559, this option must be set **both** #' when the ARDs are created and when `apply_fmt_fn()` is run. This ensures that #' any _default_ formatting functions created with `label_round()` utilize the #' specified rounding method and the method is used what aliases are converted #' into functions (which occurs in `apply_fmt_fn()` when it calls `alias_as_fmt_fn()`). NULL cards/R/import-standalone-forcats.R0000644000176200001440000000442614761122054017001 0ustar liggesusers# Standalone file: do not edit by hand # Source: https://github.com/insightsengineering/standalone/blob/HEAD/R/standalone-forcats.R # Generated by: usethis::use_standalone("insightsengineering/standalone", "forcats") # ---------------------------------------------------------------------- # # --- # repo: insightsengineering/standalone # file: standalone-forcats.R # last-updated: 2025-02-24 # license: https://unlicense.org # imports: # --- # # This file provides a minimal shim to provide a forcats-like API on top of # base R functions. They are not drop-in replacements but allow a similar style # of programming. # # ## Changelog # 2025-02-24 # - `add fct_relevel()` function. # # nocov start # styler: off fct_infreq <- function(f, ordered = NA) { # reorder by frequency factor( f, levels = table(f) |> sort(decreasing = TRUE) |> names(), ordered = ifelse(is.na(ordered), is.ordered(f), ordered) ) } fct_inorder <- function(f, ordered = NA) { factor( f, levels = stats::na.omit(unique(f)) |> union(levels(f)), ordered = ifelse(is.na(ordered), is.ordered(f), ordered) ) } fct_rev <- function(f) { if (!inherits(f, "factor")) f <- factor(f) factor( f, levels = rev(levels(f)), ordered = is.ordered(f) ) } fct_expand <- function(f, ..., after = Inf) { if (!inherits(f, "factor")) f <- factor(f) old_levels <- levels(f) new_levels <- old_levels |> append(values = setdiff(c(...), old_levels), after = after) factor(f, levels = new_levels) } fct_na_value_to_level <- function(f, level = NA) { if (!inherits(f, "factor")) f <- factor(f) # make NA an explicit level f <- addNA(f, ifany = FALSE) # replace NA level with the string passed in `level` argument if (!is.na(level)) levels(f)[is.na(levels(f))] <- level f } fct_relevel <- function(f, ..., after = 0L) { old_levels <- levels(f) # Handle re-leveling function or specified levels first_levels <- if (rlang::dots_n(...) == 1L && (is.function(..1) || rlang::is_formula(..1))) { fun <- rlang::as_function(..1) fun(old_levels) } else { rlang::chr(...) } # Reorder levels new_levels <- append(setdiff(old_levels, first_levels), first_levels, after = after) new_factor <- factor(f, levels = new_levels) return(new_factor) } # nocov end # styler: on cards/R/get_ard_statistics.R0000644000176200001440000000440614643265530015565 0ustar liggesusers#' ARD Statistics as List #' #' Returns the statistics from an ARD as a named list. #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' @param ... ([`dynamic-dots`][rlang::dyn-dots])\cr #' optional arguments indicating rows to subset of the ARD. #' For example, to return only rows where the column `"AGEGR1"` is `"65-80"`, #' pass `AGEGR1 %in% "65-80"`. #' @param .column (`string`)\cr #' string indicating the column that will be returned in the list. #' Default is `"statistic"` #' @param .attributes (`character`)\cr #' character vector of column names that will be returned #' in the list as attributes. #' Default is `NULL` #' #' @return named list #' @export #' #' @examples #' ard <- ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") #' #' get_ard_statistics( #' ard, #' group1_level %in% "Placebo", #' variable_level %in% "65-80", #' .attributes = "stat_label" #' ) get_ard_statistics <- function(x, ..., .column = "stat", .attributes = NULL) { set_cli_abort_call() # subset the ARD ard_subset <- dplyr::filter(x, ...) # return a named list of the selected stats # add attributes for the label, formatting function, warnings, and errors seq_len(nrow(ard_subset)) |> lapply( FUN = function(i) { # styler: off ard_subset[[.column]][[i]] %>% {inject(structure( ., !!!.create_list_for_attributes(ard_subset, .attributes, i) ))} } # styler: on ) |> stats::setNames(ard_subset[["stat_name"]]) } #' Create List for Attributes #' #' @param ard_subset (`data.frame`)\cr #' an ARD data frame of class 'card' #' @param attributes (`character`)\cr #' a character vector of attribute names #' @param i (`integer`)\cr #' a row index number #' #' @return a named list #' @keywords internal #' #' @examples #' ard <- ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") #' #' cards:::.create_list_for_attributes(ard, c("group1", "group1_level"), 1) .create_list_for_attributes <- function(ard_subset, attributes, i) { ret <- list() for (attr in seq_along(attributes)) { ret <- c(ret, list(ard_subset[[attr]][[i]])) } stats::setNames(ret, nm = attributes) } cards/R/as_nested_list.R0000644000176200001440000000662114607274473014715 0ustar liggesusers#' ARD as Nested List #' #' `r lifecycle::badge('experimental')`\cr #' Convert ARDs to nested lists. #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' #' @return a nested list #' @export #' #' @examples #' ard_continuous(mtcars, by = "cyl", variables = c("mpg", "hp")) |> #' as_nested_list() as_nested_list <- function(x) { set_cli_abort_call() # check in inputs ------------------------------------------------------------ check_class(x, cls = "card") # format/round the statistics, if not already done --------------------------- if (!"stat_fmt" %in% names(x)) { x <- apply_fmt_fn(x) } # construct the nested lists to convert to JSON ------------------------------ lst_pre_json <- seq_len(nrow(x)) |> lapply(FUN = function(i) .one_row_ard_to_nested_list(x[i, ])) # construct nested list that will be converted to JSON ----------------------- lst_return <- list() # initialize empty list that will be populated with results for (i in seq_len(nrow(x))) { eval(lst_pre_json[[i]]) } # return nested list result -------------------------------------------------- lst_return } #' Convert One Row to Nested List #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' with one row #' #' @return an expression that represents an element of a nested list #' @keywords internal #' #' @examples #' ard_continuous(mtcars, variables = mpg) |> #' dplyr::filter(dplyr::row_number() %in% 1L) |> #' apply_fmt_fn() |> #' cards:::.one_row_ard_to_nested_list() .one_row_ard_to_nested_list <- function(x) { df_preparation <- x |> # variable levels are originally stored in lists. unlisting here and saving in tibble as a scalar dplyr::mutate( across( # TODO: Does the statistic column need to remain in a list for more complex returns? .cols = where(is.list) & (dplyr::matches("^group[0-9]+_level$") | any_of("variable_level")), .fns = function(x) x[[1]] ) ) %>% # reorder with primary variable first, followed by stratum dplyr::select(., all_of(colnames(.) |> sort())) %>% # styler: off dplyr::select( any_of(c("variable", "variable_level")), starts_with("group"), "stat_name", "stat", "stat_fmt", "warning", "error", "context" # TODO: we could apply a formatting function and add that here ) |> # drop columns that are NA dplyr::select(-(where(function(x) all(is.na(x))) & (starts_with("group") | any_of("variable_level")))) # create a character string of the code, that we later convert to an expression # TODO: converting strings to expressions feels hacky...is there a better way? chr_nested_list_specification <- df_preparation |> dplyr::select(any_of(c("variable", "variable_level")), starts_with("group"), "stat_name") |> as.list() |> imap(function(x, y) glue::glue("[[{shQuote(y)}]][[{shQuote(x)}]]")) |> unlist() %>% paste(collapse = "") %>% # 'lst_return' is the name of the nested list that will be converted to JSON {paste0("lst_return", .)} # styler: off # creating final expression defining the results within the nested list expr( !!parse_expr(chr_nested_list_specification) <- !!dplyr::select( df_preparation, any_of(c("stat", "stat_fmt", "warning", "error", "context")) ) |> # this essentially flattens the nested list one level, while maintaining the names imap(function(x, y) x[[1]]) ) } cards/R/shuffle_ard.R0000644000176200001440000002221414776252447014177 0ustar liggesusers#' Shuffle ARD #' #' This function ingests an ARD object and shuffles the information to prepare for analysis. #' Helpful for streamlining across multiple ARDs. Combines each group/group_level into 1 #' column, back fills missing grouping values from the variable levels where possible, and #' optionally trims statistics-level metadata. #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' @param trim (`logical`)\cr #' logical representing whether or not to trim away statistic-level metadata and filter #' only on numeric statistic values. #' #' @return a tibble #' @export #' #' @examples #' bind_ard( #' ard_categorical(ADSL, by = "ARM", variables = "AGEGR1"), #' ard_categorical(ADSL, variables = "ARM") #' ) |> #' shuffle_ard() shuffle_ard <- function(x, trim = TRUE) { set_cli_abort_call() check_class(x = x, cls = "card") check_scalar_logical(trim) # make sure columns are in order & add index for retaining order dat_cards <- x |> tidy_ard_column_order() |> tidy_ard_row_order() |> dplyr::mutate(.cards_idx = dplyr::row_number()) # fill stat label if missing dat_cards <- dat_cards |> dplyr::mutate(dplyr::across(any_of("stat_label"), ~ dplyr::coalesce(.x, stat_name))) # split up the data into data/variable info & cards info vars_ard <- dat_cards |> dplyr::select(all_ard_groups(), all_ard_variables()) |> names() vars_protected <- setdiff(names(dat_cards), vars_ard) dat_cards_grps <- dat_cards |> dplyr::select(-all_of(vars_protected), ".cards_idx") dat_cards_stats <- dat_cards |> dplyr::select(all_of(vars_protected)) # process the data/variable info dat_cards_grps_processed <- dat_cards_grps |> .check_var_nms(vars_protected = names(dat_cards_stats)) |> rename_ard_columns(columns = all_ard_groups("names"), fill = "Overall {colname}") |> # coerce everything to character dplyr::mutate( dplyr::across( -".cards_idx", ~ lapply(., \(x) if (!is.null(x)) as.character(x) else NA_character_) ) ) # join together again dat_cards_out <- dplyr::left_join( dat_cards_grps_processed, dat_cards_stats, by = ".cards_idx" ) dat_cards_out <- dat_cards_out |> # unlist the list-columns unlist_ard_columns() |> .fill_grps_from_variables() |> .fill_overall_grp_values(vars_protected) |> dplyr::arrange(.data$.cards_idx) |> dplyr::select(-".cards_idx") if (trim) { dat_cards_out |> .trim_ard() } else { dat_cards_out } } #' Trim ARD #' #' This function ingests an ARD object and trims columns and rows for downstream use in #' displays. The resulting data frame contains only numeric results, no supplemental #' information about errors/warnings, and unnested list columns. #' #' @param x (`data.frame`)\cr #' a data frame #' #' @return a tibble #' @keywords internal #' #' @examples #' ard <- bind_ard( #' ard_categorical(ADSL, by = "ARM", variables = "AGEGR1"), #' ard_categorical(ADSL, variables = "ARM") #' ) |> #' shuffle_ard(trim = FALSE) #' #' ard |> cards:::.trim_ard() .trim_ard <- function(x) { check_data_frame(x) # detect any warning/error messages and notify user .detect_msgs(x, "warning", "error") # flatten ard table for easier viewing --------------------------------------- x |> dplyr::select(-c("fmt_fn", "warning", "error")) } #' Detect Columns with Non-Null Contents #' #' Function looks for non-null contents in requested columns and notifies user #' before removal. Specifically used for detecting messages. #' #' @param x (`data.frame`)\cr #' a data frame #' @param ... ([`dynamic-dots`][rlang::dyn-dots])\cr #' columns to search within #' @keywords internal #' #' @examples #' ard <- ard_continuous( #' ADSL, #' by = ARM, #' variables = AGE, #' statistic = ~ list( #' mean = \(x) mean(x), #' mean_warning = \(x) { #' warning("warn1") #' warning("warn2") #' mean(x) #' }, #' err_fn = \(x) stop("'tis an error") #' ) #' ) #' #' cards:::.detect_msgs(ard, "warning", "error") .detect_msgs <- function(x, ...) { dots <- rlang::dots_list(...) lapply(dots, function(var) { if (any(!map_lgl(x[[var]], is.null))) { cli::cli_inform("{.val {var}} column contains messages that will be removed.") } }) } #' Check Variable Names #' #' Checks variable names in a data frame against protected names and modifies #' them if needed #' #' @param x (`data.frame`)\cr #' a data frame #' @param vars_protected (`character`)\cr #' a character vector of protected names #' #' @return a data frame #' @keywords internal #' #' @examples #' data <- data.frame(a = "x", b = "y", c = "z", .cards_idx = 1) #' #' cards:::.check_var_nms(data, vars_protected = c("x", "z")) .check_var_nms <- function(x, vars_protected) { # get all represented variable names from original data var_nms <- x |> dplyr::select(-ends_with("_level"), -".cards_idx") |> unlist(use.names = FALSE) |> unique() # create uniqueness across all variables from original data & cards-specific # variables var_nms_new <- make.unique(c(vars_protected, var_nms)) |> utils::tail(n = length(var_nms)) |> set_names(var_nms) # subset to only the ones needing recoding var_nms_new <- var_nms_new[imap( var_nms_new, function(x, y) { if (is.na(x)) FALSE else !x == y } ) |> unlist(use.names = FALSE)] # perform recodes if needed if (length(var_nms_new) > 0) { x |> dplyr::mutate(dplyr::across( -c(ends_with("_level"), ".cards_idx"), ~ dplyr::recode(.x, !!!var_nms_new) )) } else { x } } #' Back Fill Group Variables #' #' This function back fills the values of group variables using #' variable/variable_levels. The back filling will occur if the value of the #' `variable` column matches the name of a grouping variable, and the grouping #' variable's value is `NA`. #' #' @param x (`data.frame`)\cr #' a data frame #' #' @return data frame #' @keywords internal #' #' @examples #' data <- data.frame( #' variable = c(rep("A", 3), rep("B", 2)), #' variable_level = 1:5, #' A = rep(NA, 5), #' B = rep(NA, 5) #' ) #' #' cards:::.fill_grps_from_variables(data) .fill_grps_from_variables <- function(x) { # within each variable, check if there is a match against one of the grouping cols # if the corresponding value in that grouping col is missing, backfill with the variable level x %>% dplyr::mutate(variable = fct_inorder(.data$variable)) |> dplyr::group_by(.data$variable) |> dplyr::group_split() |> map(function(dat) { grp_match <- names(dat)[names(dat) == unique(dat$variable)] if (length(grp_match) > 0 && "variable_level" %in% names(dat)) { dat |> dplyr::mutate(!!grp_match := ifelse(is.na(.data[[grp_match]]), .data$variable_level, .data[[grp_match]] )) } else { dat } }) |> dplyr::bind_rows() |> dplyr::mutate(variable = as.character(.data$variable)) } #' Fill Overall Group Variables #' #' This function fills the missing values of grouping variables with "Overall #' `variable name`" where relevant. Specifically it will modify grouping values #' from rows with likely overall calculations present (e.g. non-missing #' variable/variable_level, 100 percent missing group variables, and evidence that the #' `variable` has been computed by group in other rows). "Overall" values will #' be populated only for grouping variables that have been used in other calculations #' of the same variable and statistics. #' #' @param x (`data.frame`)\cr #' a data frame #' #' @return data frame #' @keywords internal #' #' @examples #' data <- dplyr::tibble( #' grp = c("AA", "AA", NA, "BB", NA), #' variable = c("A", "B", "A", "C", "C"), #' variable_level = c(1, 2, 1, 3, 3), #' A = rep(NA, 5), #' B = rep(NA, 5), #' .cards_idx = c(1:5) #' ) #' #' cards:::.fill_overall_grp_values(data, vars_protected = ".cards_idx") .fill_overall_grp_values <- function(x, vars_protected) { # determine grouping and merging variables id_vars <- c("variable", "variable_level", "stat_name", "stat_label") id_vars <- id_vars[id_vars %in% names(x)] grp_vars <- setdiff(names(x), unique(c(vars_protected, id_vars))) # replace NA group values with "Overall " where it is likely to be an overall calculation x_missing_by <- x |> dplyr::filter(dplyr::if_all(all_of(grp_vars), ~ is.na(.))) if (nrow(x_missing_by) > 0) { x_missing_by_replaced <- x_missing_by |> # all NA grouping values dplyr::rows_update( x |> dplyr::filter(dplyr::if_any(all_of(grp_vars), ~ !is.na(.))) |> dplyr::mutate(dplyr::across(all_of(grp_vars), function(v, cur_col = dplyr::cur_column()) { overall_val <- make.unique(c( unique(v), paste("Overall", cur_col) )) |> rev() %>% .[1] ifelse(!is.na(v), overall_val, v) })) |> dplyr::select(-any_of(c(setdiff(names(x), c(grp_vars, id_vars))))) |> dplyr::distinct(), by = id_vars, unmatched = "ignore" ) # replace the modified rows based on indices dplyr::rows_update(x, x_missing_by_replaced, by = ".cards_idx") } else { x } } cards/R/bind_ard.R0000644000176200001440000001014014767676341013455 0ustar liggesusers#' Bind ARDs #' #' Wrapper for `dplyr::bind_rows()` with additional checks #' for duplicated statistics. #' #' @param ... ([`dynamic-dots`][rlang::dyn-dots])\cr #' ARDs to combine. Each argument can either be an ARD, #' or a list of ARDs. Columns are matched by name, and any missing #' columns will be filled with `NA`. #' @param .distinct (`logical`)\cr #' logical indicating whether to remove non-distinct values from the ARD. #' Duplicates are checked across grouping variables, primary variables, #' context (if present), the **statistic name and the statistic value**. #' Default is `FALSE`. If a statistic name and value is repeated and `.distinct=TRUE`, #' the more recently added statistics will be retained, and the other(s) omitted. #' @param .update (`logical`)\cr #' logical indicating whether to update ARD and remove duplicated named statistics. #' Duplicates are checked across grouping variables, primary variables, and the #' **statistic name**. #' Default is `FALSE`. If a statistic name is repeated and `.update=TRUE`, #' the more recently added statistics will be retained, and the other(s) omitted. #' @param .order (`logical`)\cr #' logical indicating whether to order the rows of the stacked ARDs, allowing #' statistics that share common group and variable values to appear in #' consecutive rows. Default is `FALSE`. Ordering will be based on the order #' of the group/variable values prior to stacking. #' @param .quiet (`logical`)\cr #' logical indicating whether to suppress any messaging. Default is `FALSE` #' #' @return an ARD data frame of class 'card' #' @export #' #' @examples #' ard <- ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") #' #' bind_ard(ard, ard, .update = TRUE) bind_ard <- function(..., .distinct = TRUE, .update = FALSE, .order = FALSE, .quiet = FALSE) { set_cli_abort_call() # check inputs --------------------------------------------------------------- check_scalar_logical(.distinct) check_scalar_logical(.update) check_scalar_logical(.order) check_scalar_logical(.quiet) # stack ARDs ----------------------------------------------------------------- data <- dplyr::bind_rows(...) # check for non-distinct statistics ------------------------------------------ not_distinct <- dplyr::select(data, all_ard_groups(), all_ard_variables(), any_of("context"), "stat_name", "stat")[seq(nrow(data), 1L), ] |> duplicated() if (any(not_distinct) && isTRUE(.distinct)) { if (isFALSE(.quiet)) { cli::cli_inform(c( "i" = "{sum(not_distinct)} row{?s} with {.emph duplicated statistic values} {?has/have} been removed.", "*" = "See {.help [cards::bind_ard(.distinct)](cards::bind_ard)} for details." )) } data <- dplyr::filter( data, .by = c(all_ard_groups(), all_ard_variables(), "stat_name"), dplyr::row_number() == dplyr::n() ) } # check for duplicate stat_name ---------------------------------------------- dupes <- dplyr::select(data, all_ard_groups(), all_ard_variables(), "stat_name")[seq(nrow(data), 1L), ] |> duplicated() if (any(dupes) && isTRUE(.update)) { if (isFALSE(.quiet)) { cli::cli_inform(c( "i" = "{sum(dupes)} row{?s} with {.emph duplicated statistic names} {?has/have} been removed.", "*" = "See {.help [cards::bind_ard(.update)](cards::bind_ard)} for details." )) } data <- dplyr::filter( data, .by = c(all_ard_groups(), all_ard_variables(), "stat_name"), dplyr::row_number() == dplyr::n() ) } else if (any(dupes) && isFALSE(.update)) { cli::cli_abort( c( "!" = "{sum(dupes)} row{?s} with {.emph duplicated statistic names} {?has/have} been found.", "i" = "See {.help [cards::bind_ard(.update)](cards::bind_ard)} for details." ), call = get_cli_abort_call() ) } # optionally reorder --------------------------------------------------------- if (isTRUE(.order)) { data <- tidy_ard_row_order(data) } # return stacked ARDs -------------------------------------------------------- tidy_ard_column_order(data) |> as_card() } cards/R/as_card.R0000644000176200001440000000124114661403171013267 0ustar liggesusers#' Data Frame as ARD #' #' Convert data frames to ARDs of class 'card'. #' #' @param x (`data.frame`)\cr #' a data frame #' #' @return an ARD data frame of class 'card' #' @export #' #' @examples #' data.frame( #' stat_name = c("N", "mean"), #' stat_label = c("N", "Mean"), #' stat = c(10, 0.5) #' ) |> #' as_card() as_card <- function(x) { set_cli_abort_call() # check in inputs ------------------------------------------------------------ check_class(x, cls = "data.frame") # convert to class "card" ---------------------------------------------------- if (inherits(x, "card")) { x } else { structure(x, class = c("card", class(x))) } } cards/R/nest_for_ard.R0000644000176200001440000001447314767010066014357 0ustar liggesusers#' ARD Nesting #' #' @description #' This function is similar to [tidyr::nest()], except that it retains #' rows for unobserved combinations (and unobserved factor levels) of by #' variables, and unobserved combinations of stratifying variables. #' #' The levels are wrapped in lists so they can be stacked with other types #' of different classes. #' #' @param data (`data.frame`)\cr #' a data frame #' @param by,strata (`character`)\cr #' columns to nest by/stratify by. Arguments are similar, #' but with an important distinction: #' #' `by`: data frame is nested by **all combinations** of the columns specified, #' including unobserved combinations and unobserved factor levels. #' #' `strata`: data frame is nested by **all _observed_ combinations** of the #' columns specified. #' #' Arguments may be used in conjunction with one another. #' @param key (`string`)\cr #' the name of the new column with the nested data frame. Default is `"data"`. #' @param rename_columns (`logical`)\cr #' logical indicating whether to rename the `by` and `strata` variables. #' Default is `TRUE`. #' @param list_columns (`logical`)\cr #' logical indicating whether to put levels of `by` and #' `strata` columns in a list. Default is `TRUE`. #' @param include_data (scalar `logical`)\cr #' logical indicating whether to include the data subsets as a list-column. #' Default is `TRUE`. #' #' @return a nested tibble #' @export #' #' @examples #' nest_for_ard( #' data = #' ADAE |> #' dplyr::left_join(ADSL[c("USUBJID", "ARM")], by = "USUBJID") |> #' dplyr::filter(AOCCSFL %in% "Y"), #' by = "ARM", #' strata = "AESOC" #' ) nest_for_ard <- function(data, by = NULL, strata = NULL, key = "data", rename_columns = TRUE, list_columns = TRUE, include_data = TRUE) { set_cli_abort_call() # if no by/stratifying variables, simply return the data frame if (is_empty(by) && is_empty(strata)) { return((dplyr::tibble("{key}" := list(data)))) } n_missing <- nrow(data) - nrow(tidyr::drop_na(data, all_of(by), all_of(strata))) if (n_missing > 0L) { cli::cli_inform("{n_missing} missing observation{?s} in the {.val {c(by, strata)}} column{?s} have been removed.") } # create nested strata data -------------------------------------------------- if (!is_empty(strata)) { df_strata <- data[strata] |> tidyr::drop_na() |> dplyr::distinct() |> dplyr::arrange(across(all_of(strata))) } # create nested by data -------------------------------------------------- if (!is_empty(by)) { # get a named list of all unique values for each by variable (including unobserved levels) lst_unique_vals <- by |> lapply(FUN = function(x) data[[x]] |> .unique_and_sorted()) |> stats::setNames(nm = by) # convert that list to a data frame with one row per unique combination df_by <- tidyr::expand_grid(!!!lst_unique_vals) } # combining by and strata data sets into one, as needed ---------------------- if (!is_empty(by) && is_empty(strata)) { df_return <- df_by } else if (is_empty(by) && !is_empty(strata)) { df_return <- df_strata } else if (!is_empty(by) && !is_empty(strata)) { df_return <- df_strata |> dplyr::mutate( "{key}" := list(df_by), .before = 0L ) |> tidyr::unnest(cols = all_of(key)) } # we will now add a column to the df_return data frame of the subsetted data # to do so, we'll construct a list of expressions that can be passed to # dplyr::filter() to subset the data frame if (isTRUE(include_data)) { lst_filter_exprs <- seq_len(nrow(df_return)) |> lapply( FUN = function(i) { lapply( X = c(by, strata), FUN = function(z) { expr(!!data_sym(z) %in% df_return[[!!z]][!!i]) } ) } ) # now adding the subsetted data frames to the nested tibble df_return[[key]] <- lapply( seq_len(nrow(df_return)), FUN = function(i) { dplyr::filter(data, !!!lst_filter_exprs[[i]]) |> dplyr::select(-all_of(.env$by), -all_of(.env$strata)) } ) } # put variable levels in list to preserve types when stacked ----------------- if (isTRUE(list_columns)) { df_return <- df_return |> dplyr::mutate(across(.cols = -any_of(key), .fns = as.list)) } # rename by and strata columns to group## and group##_level ------------------ if (isTRUE(rename_columns)) { df_return <- df_return |> .nesting_rename_ard_columns(by = by, strata = strata) } # returning final nested tibble ---------------------------------------------- df_return |> dplyr::as_tibble() } #' Rename ARD Columns #' #' If `variable` is provided, adds the standard `variable` column to `x`. If `by`/`strata` are #' provided, adds the standard `group##` column(s) to `x` and renames the provided columns to #' `group##_level` in `x`, where `##` is determined by the column's position in `c(by, strata)`. #' #' @param x (`data.frame`)\cr #' a data frame #' @param variable (`character`)\cr #' name of `variable` column in `x`. Default is `NULL`. #' @param by (`character`)\cr #' character vector of names of `by` columns in `x`. Default is `NULL`. #' @param strata (`character`)\cr #' character vector of names of `strata` columns in `x`. Default is `NULL`. #' #' @return a tibble #' @keywords internal #' #' @examples #' ard <- nest_for_ard( #' data = #' ADAE |> #' dplyr::left_join(ADSL[c("USUBJID", "ARM")], by = "USUBJID") |> #' dplyr::filter(AOCCSFL %in% "Y"), #' by = "ARM", #' strata = "AESOC", #' rename_columns = FALSE #' ) #' #' cards:::.nesting_rename_ard_columns(ard, by = "ARM", strata = "AESOC") .nesting_rename_ard_columns <- function(x, variable = NULL, by = NULL, strata = NULL) { if (!is_empty(variable)) { x <- x |> dplyr::rename(variable_level = !!sym(variable)) |> dplyr::mutate(variable = .env$variable, .before = 0L) } if (!is_empty(by) || !is_empty(strata)) { x <- x |> dplyr::mutate(!!!(as.list(c(by, strata)) |> stats::setNames(paste0("group", seq_along(c(strata, by))))), .before = 0L) |> dplyr::rename(!!!(as.list(c(by, strata)) |> stats::setNames(paste0("group", seq_along(c(strata, by)), "_level")))) } tidy_ard_column_order(x) } cards/R/ard_formals.R0000644000176200001440000000364614770630311014176 0ustar liggesusers#' Argument Values ARD #' #' Place default and passed argument values to a function into an ARD structure. #' #' @param fun (`function`)\cr #' a [function] passed to `formals(fun)` #' @param arg_names (`character`)\cr #' character vector of argument names to return #' @param passed_args (named `list`)\cr #' a named list of user-passed arguments. Default is `list()`, which returns #' all default values from a function #' @param envir (`environment`)\cr #' an environment passed to `formals(envir)` #' #' @return an partial ARD data frame of class 'card' #' @export #' #' @examples #' # Example 1 ---------------------------------- #' # add the `mcnemar.test(correct)` argument to an ARD structure #' ard_formals(fun = mcnemar.test, arg_names = "correct") #' #' # Example 2 ---------------------------------- #' # S3 Methods need special handling to access the underlying method #' ard_formals( #' fun = asNamespace("stats")[["t.test.default"]], #' arg_names = c("mu", "paired", "var.equal", "conf.level"), #' passed_args = list(conf.level = 0.90) #' ) ard_formals <- function(fun, arg_names, passed_args = list(), envir = parent.frame()) { # check inputs --------------------------------------------------------------- set_cli_abort_call() check_not_missing(fun) check_not_missing(arg_names) check_class(passed_args, "list") check_class(fun, "function") check_class(arg_names, "character") check_class(envir, "environment") # prepare named list of arguments -------------------------------------------- lst_args <- formals(fun = fun, envir = envir)[arg_names] |> utils::modifyList(val = passed_args[intersect(arg_names, names(passed_args))], keep.null = TRUE) # put formals list in ARD structure ------------------------------------------ enframe(lst_args[arg_names], "stat_name", "stat") |> dplyr::mutate(stat_label = .data$stat_name, .after = "stat_name") |> as_card() } cards/R/ard_missing.R0000644000176200001440000000663414761134534014212 0ustar liggesusers#' Missing ARD Statistics #' #' Compute Analysis Results Data (ARD) for statistics related to data missingness. #' #' @inheritParams ard_continuous #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' results are tabulated by **all combinations** of the columns specified. #' #' @return an ARD data frame of class 'card' #' @name ard_missing #' #' @examples #' ard_missing(ADSL, by = "ARM", variables = "AGE") #' #' ADSL |> #' dplyr::group_by(ARM) |> #' ard_missing( #' variables = "AGE", #' statistic = ~"N_miss" #' ) NULL #' @export #' @rdname ard_missing ard_missing <- function(data, ...) { check_not_missing(data) UseMethod("ard_missing") } #' @export #' @rdname ard_missing ard_missing.data.frame <- function(data, variables, by = dplyr::group_vars(data), statistic = everything() ~ c("N_obs", "N_miss", "N_nonmiss", "p_miss", "p_nonmiss"), fmt_fn = NULL, stat_label = everything() ~ default_stat_labels(), ...) { set_cli_abort_call() check_dots_used() # check inputs --------------------------------------------------------------- check_not_missing(variables) # process variable inputs ---------------------------------------------------- process_selectors(data, variables = {{ variables }}) # return empty ARD if no variables selected ---------------------------------- if (is_empty(variables)) { return(dplyr::tibble() |> as_card()) } # convert all variables to T/F whether it's missing -------------------------- data <- data |> dplyr::mutate( across(all_of(variables), Negate(is.na)) ) process_formula_selectors( data[variables], statistic = statistic ) fill_formula_selectors( data[variables], statistic = formals(asNamespace("cards")[["ard_missing.data.frame"]])[["statistic"]] |> eval() ) check_list_elements( x = statistic, predicate = \(x) is.character(x) && all(x %in% c("N_obs", "N_miss", "N_nonmiss", "p_miss", "p_nonmiss")), error_msg = "Elements passed in the {.arg statistic} argument must be one or more of {.val {c('N_obs', 'N_miss', 'N_nonmiss', 'p_miss', 'p_nonmiss')}}" ) # get the summary statistics ------------------------------------------------- ard_continuous( data = data, variables = all_of(variables), by = {{ by }}, statistic = lapply(statistic, \(x) missing_summary_fns(x)), fmt_fn = fmt_fn, stat_label = stat_label ) |> dplyr::mutate( context = "missing" ) } missing_summary_fns <- function(summaries = c("N_obs", "N_miss", "N_nonmiss", "p_miss", "p_nonmiss")) { list( var_level = function(x, stats = summaries) { res <- list() if (any(c("N_obs", "N_nonmiss", "p_miss", "p_nonmiss") %in% stats)) { res[["N_obs"]] <- length(x) } if (any(c("N_miss", "N_nonmiss", "p_miss") %in% stats)) { res[["N_miss"]] <- sum(!x) } if (any(c("N_nonmiss", "p_nonmiss") %in% stats)) { res[["N_nonmiss"]] <- res[["N_obs"]] - res[["N_miss"]] } if ("p_miss" %in% stats) { res[["p_miss"]] <- res[["N_miss"]] / res[["N_obs"]] } if ("p_nonmiss" %in% stats) { res[["p_nonmiss"]] <- res[["N_nonmiss"]] / res[["N_obs"]] } res } ) } cards/R/process_selectors.R0000644000176200001440000002621414645244422015447 0ustar liggesusers#' Process tidyselectors #' #' @description #' Functions process tidyselect arguments passed to functions in the cards package. #' The processed values are saved to the calling environment, by default. #' #' - `process_selectors()`: the arguments will be processed with tidyselect and #' converted to a vector of character column names. #' #' - `process_formula_selectors()`: for arguments that expect named lists or #' lists of formulas (where the LHS of the formula is a tidyselector). This #' function processes these inputs and returns a named list. If a name is #' repeated, the last entry is kept. #' #' - `fill_formula_selectors()`: when users override the default argument values, #' it can be important to ensure that each column from a data frame is assigned #' a value. This function checks that each column in `data` has an assigned #' value, and if not, fills the value in with the default value passed here. #' #' - `compute_formula_selector()`: used in `process_formula_selectors()` to #' evaluate a single argument. #' #' - `check_list_elements()`: used to check the class/type/values of the list #' elements, primarily those processed with `process_formula_selectors()`. #' #' - `cards_select()`: wraps `tidyselect::eval_select() |> names()`, and returns #' better contextual messaging when errors occur. #' #' @param data (`data.frame`)\cr #' a data frame #' @param ... ([`dynamic-dots`][rlang::dyn-dots])\cr #' named arguments where the value of the argument is processed with tidyselect. #' - `process_selectors()`: the values are tidyselect-compatible selectors #' - `process_formula_selectors()`: the values are named lists, list of formulas #' a combination of both, or a single formula. Users may pass `~value` as a #' shortcut for `everything() ~ value`. #' - `check_list_elements()`: named arguments where the name matches an existing #' list in the `env` environment, and the value is a predicate function #' to test each element of the list, e.g. each element must be a string or #' a function. #' @param env (`environment`)\cr #' env to save the results to. Default is the calling environment. #' @param x #' - `compute_formula_selector()`: ([`formula-list-selector`][syntax])\cr #' a named list, list of formulas, or a single formula that will be #' converted to a named list. #' - `check_list_elements()`: (named `list`)\cr #' a named list #' @param predicate (`function`)\cr #' a predicate function that returns `TRUE` or `FALSE` #' @param arg_name (`string`)\cr #' the name of the argument being processed. Used #' in error messaging. Default is `caller_arg(x)`. #' @param error_msg (`character`)\cr #' a character vector that will #' be used in error messaging when mis-specified arguments are passed. Elements #' `"{arg_name}"` and `"{variable}"` are available using glue syntax for messaging. #' @param strict (`logical`)\cr #' whether to throw an error if a variable doesn't exist in the reference data #' (passed to [tidyselect::eval_select()]) #' @param include_env (`logical`)\cr #' whether to include the environment from the formula object in the returned #' named list. Default is `FALSE` #' @param allow_empty (`logical`)\cr #' Logical indicating whether empty result is acceptable while process #' formula-list selectors. Default is `TRUE`. #' @param expr (`expression`)\cr #' Defused R code describing a selection according to the tidyselect syntax. #' #' @return `process_selectors()`, `fill_formula_selectors()`, `process_formula_selectors()` #' and `check_list_elements()` return NULL. `compute_formula_selector()` returns a #' named list. #' @name process_selectors #' #' @examples #' example_env <- rlang::new_environment() #' #' process_selectors(ADSL, variables = starts_with("TRT"), env = example_env) #' get(x = "variables", envir = example_env) #' #' fill_formula_selectors(ADSL, env = example_env) #' #' process_formula_selectors( #' ADSL, #' statistic = list(starts_with("TRT") ~ mean, TRTSDT = min), #' env = example_env #' ) #' get(x = "statistic", envir = example_env) #' #' check_list_elements( #' get(x = "statistic", envir = example_env), #' predicate = function(x) !is.null(x), #' error_msg = c( #' "Error in the argument {.arg {arg_name}} for variable {.val {variable}}.", #' "i" = "Value must be a named list of functions." #' ) #' ) #' #' # process one list #' compute_formula_selector(ADSL, x = starts_with("U") ~ 1L) NULL #' @name process_selectors #' @export process_selectors <- function(data, ...) { UseMethod("process_selectors") } #' @name process_selectors #' @export process_formula_selectors <- function(data, ...) { UseMethod("process_formula_selectors") } #' @name process_selectors #' @export fill_formula_selectors <- function(data, ...) { UseMethod("fill_formula_selectors") } #' @name process_selectors #' @export process_selectors.data.frame <- function(data, ..., env = caller_env()) { set_cli_abort_call() # saved dots as named list of quos dots <- enquos(...) # save named list of character column names selected ret <- imap( dots, function(x, arg_name) { processed_value <- cards_select( expr = x, data = data, allow_rename = FALSE, arg_name = arg_name ) } ) # save processed args to the calling env (well, that is the default env) for (i in seq_along(ret)) { assign(x = names(ret)[i], value = ret[[i]], envir = env) } } #' @name process_selectors #' @export process_formula_selectors.data.frame <- function(data, ..., env = caller_env(), include_env = FALSE, allow_empty = TRUE) { set_cli_abort_call() # saved dots as named list dots <- dots_list(...) # initialize empty list to store results and evaluate each input ret <- rep_named(names(dots), list()) for (i in seq_along(dots)) { ret[[i]] <- compute_formula_selector( data = data, x = dots[[i]], arg_name = names(dots)[i], env = env, include_env = include_env ) } # save processed args to the calling env (well, that is the default env) for (i in seq_along(ret)) { assign(x = names(ret)[i], value = ret[[i]], envir = env) } } #' @name process_selectors #' @export fill_formula_selectors.data.frame <- function(data, ..., env = caller_env()) { set_cli_abort_call() dots <- dots_list(...) ret <- rep_named(names(dots), list(NULL)) data_names <- names(data) dots_names <- names(dots) for (i in seq_along(dots)) { if (!is_empty(setdiff(data_names, names(get(dots_names[i], envir = env))))) { # process the default selector ret[[i]] <- compute_formula_selector( data = data, x = dots[[i]], arg_name = dots_names[i], env = env ) # add the previously specified values and overwrite the default ret[[i]][names(get(dots_names[i], envir = env))] <- get(dots_names[i], envir = env) } } # save processed args to the calling env (well, that is the default env) for (i in seq_along(ret)) { if (!is.null(ret[[i]])) assign(x = names(ret)[i], value = ret[[i]], envir = env) } } #' @name process_selectors #' @export compute_formula_selector <- function(data, x, arg_name = caller_arg(x), env = caller_env(), strict = TRUE, include_env = FALSE, allow_empty = TRUE) { set_cli_abort_call() # check inputs --------------------------------------------------------------- check_formula_list_selector(x, arg_name = arg_name, allow_empty = allow_empty, call = env) # user passed a named list, return unaltered if (.is_named_list(x)) { # remove duplicates (keeping the last one) x <- x[names(x) |> rev() |> Negate(duplicated)() |> rev()] # styler: off return(x[intersect(names(x), names(data))]) } # if user passed a single formula, wrap it in a list if (inherits(x, "formula")) x <- list(x) for (i in seq_along(x)) { # if element is a formula, convert to a named list if (inherits(x[[i]], "formula")) { lhs_quo <- f_lhs_as_quo(x[[i]]) if (!is.null(data)) { lhs_quo <- cards_select( # if nothing found on LHS of formula, using `everything()` expr = lhs_quo %||% dplyr::everything(), data = data, strict = strict, allow_rename = FALSE, arg_name = arg_name ) } colnames <- eval_tidy(lhs_quo) x[i] <- rep_len( list( eval_tidy(f_rhs_as_quo(x[[i]])) |> structure( .Environment = switch(isTRUE(include_env), attr(x[[i]], ".Environment")) # styler: off ) ), length.out = length(colnames) ) |> stats::setNames(nm = colnames) |> list() } } # flatten the list to a top-level list only x <- .purrr_list_flatten(x) # remove duplicates (keeping the last one) x <- x[names(x) |> rev() |> Negate(duplicated)() |> rev()] # styler: off # only keeping names in the data frame x[intersect(names(x), names(data))] } #' @name process_selectors #' @export check_list_elements <- function(x, predicate, error_msg = NULL, arg_name = rlang::caller_arg(x)) { set_cli_abort_call() imap( x, function(lst_element, variable) { if (!isTRUE(predicate(lst_element))) { msg <- error_msg %||% "The value for argument {.arg {arg_name}} and variable {.val {variable}} is not the expected type." cli::cli_abort(message = msg, call = get_cli_abort_call()) } } ) invisible() } #' @name process_selectors #' @export cards_select <- function(expr, data, ..., arg_name = NULL) { set_cli_abort_call() enexpr <- enexpr(expr) # this can be removed when `vars()` check removed tryCatch( tidyselect::eval_select(expr = expr, data = data, ...) |> names(), error = function(e) { # This check for `vars()` usage can be removed after Jan 1, 2025 if (tryCatch(identical(eval(as.list(enexpr)[[1]]), dplyr::vars), error = \(x) FALSE)) { cli::cli_abort( c("Use of {.fun dplyr::vars} in selecting environments is deprecated.", i = "Use {.fun c} instead. See {.help dplyr::dplyr_tidy_select} for details." ), call = get_cli_abort_call(), class = "deprecated" ) } cli::cli_abort( message = c( switch(!is.null(arg_name), "Error processing {.arg {arg_name}} argument." ), "!" = cli::ansi_strip(conditionMessage(e)), i = "Select among columns {.val {names(data)}}" ), call = get_cli_abort_call() ) } ) } # These functions are like rlang::f_lhs(), but they extract the expression # as a quosure with the env from the formula. f_lhs_as_quo <- function(f) { if (is.null(f_lhs(f))) return(NULL) # styler: off quo(!!f_lhs(f)) |> structure(.Environment = attr(f, ".Environment")) } f_rhs_as_quo <- function(f) { if (is.null(f_rhs(f))) return(NULL) # styler: off quo(!!f_rhs(f)) |> structure(.Environment = attr(f, ".Environment")) } cards/R/syntax.R0000644000176200001440000000424714567176413013245 0ustar liggesusers#' Selecting Syntax #' #' @name syntax #' @keywords internal #' #' @description #' # Selectors #' #' The cards package also utilizes selectors: selectors from the tidyselect #' package and custom selectors. Review their help files for details. #' #' - **tidy selectors** #' #' [everything()], [all_of()], [any_of()], [starts_with()], [ends_with()], #' [contains()], [matches()], [num_range()], [last_col()] #' #' - **cards selectors** #' #' [all_ard_groups()], [all_ard_variables()] #' #' # Formula and List Selectors #' #' Some arguments in the cards package accept list and #' formula notation, e.g. `ard_continuous(statistic=)`. #' Below enumerates a few tips and shortcuts for using the list and formulas. #' #' 1. **List of Formulas** #' #' Typical usage includes a list of formulas, where the LHS is a variable #' name or a selector. #' #' ```r #' ard_continuous(statistic = list(age ~ list(N = \(x) length(x)), starts_with("a") ~ list(mean = mean))) #' ``` #' #' 2. **Named List** #' #' You may also pass a named list; however, the tidyselect selectors #' are not supported with this syntax. #' #' ```r #' ard_continuous(statistic = list(age = list(N = \(x) length(x)))) #' ``` #' #' 3. **Hybrid Named List/List of Formulas** #' #' You can pass a combination of formulas and named elements. #' #' ```r #' ard_continuous(statistic = list(age = list(N = \(x) length(x)), starts_with("a") ~ list(mean = mean))) #' ``` #' #' 4. **Shortcuts** #' #' You can pass a single formula, which is equivalent to passing the formula #' in a list. #' #' ```r #' ard_continuous(statistic = starts_with("a") ~ list(mean = mean) #' ``` #' #' As a shortcut to select all variables, you can omit the LHS of the formula. #' The two calls below are equivalent. #' #' ```r #' ard_continuous(statistic = ~list(N = \(x) length(x))) #' ard_continuous(statistic = everything() ~ list(N = \(x) length(x))) #' ``` #' #' 5. **Combination Selectors** #' #' Selectors can be combined using the `c()` function. #' #' ```r #' ard_continuous(statistic = c(everything(), -age) ~ list(N = \(x) length(x))) #' ``` NULL cards/R/print_ard_conditions.R0000644000176200001440000001425414752441547016130 0ustar liggesusers#' Print ARD Condition Messages #' #' Function parses the errors and warnings observed while calculating the #' statistics requested in the ARD and prints them to the console as messages. #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' @param condition_type (`string`)\cr #' indicates how warnings and errors are returned. #' Default is `"inform"` where all are returned as messages. #' When `"identity"`, errors are returned as errors and warnings as warnings. #' #' @return returns invisible if check is successful, throws all condition messages if not. #' @export #' #' @examples #' # passing a character variable for numeric summary #' ard_continuous(ADSL, variables = AGEGR1) |> #' print_ard_conditions() print_ard_conditions <- function(x, condition_type = c("inform", "identity")) { # check inputs --------------------------------------------------------------- set_cli_abort_call() check_class(x, cls = "card") condition_type <- rlang::arg_match(condition_type, call = get_cli_abort_call()) # print condition messages --------------------------------------------------- # styler: off if ("error" %in% names(x)) .cli_condition_messaging(x, msg_type = "error", condition_type = condition_type) if ("warning" %in% names(x)) .cli_condition_messaging(x, msg_type = "warning", condition_type = condition_type) # styler: on invisible() } #' Print Condition Messages Saved in an ARD #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' @param msg_type (`string`)\cr #' message type. Options are `"warning"` and `"error"`. #' #' @return returns invisible if check is successful, throws warning/error messages if not. #' @keywords internal #' #' @examples #' ard <- ard_continuous( #' ADSL, #' by = ARM, #' variables = AGE #' ) #' #' cards:::.cli_condition_messaging(ard, msg_type = "error") .cli_condition_messaging <- function(x, msg_type, condition_type) { set_cli_abort_call() # filter the ARD for the rows with messages to print ard_condition <- x |> dplyr::filter(!map_lgl(.data[[msg_type]], is.null)) # if no messages, quit the function early if (nrow(ard_condition) == 0L) { return(invisible()) } # choose the function for color prints for warnings/errors cli_color_fun <- switch(msg_type, "warning" = cli::col_yellow, "error" = cli::col_red ) # create a data frame that is one row per message to print # also formats the text that will be printed ard_msg <- ard_condition |> dplyr::group_by(dplyr::pick(all_ard_groups(), all_ard_variables(), all_of(msg_type))) |> dplyr::group_map( function(.x, .y) { dplyr::tibble( # this column is the messaging for which groups/variable the message appears in cli_variable_msg = dplyr::select(.y, all_ard_variables("names")) |> dplyr::mutate(across(where(is.list), unlist)) |> dplyr::slice(1L) |> as.list() |> .cli_groups_and_variable() |> list(), cli_group_msg = dplyr::select(.y, all_ard_groups()) |> dplyr::mutate(across(where(is.list), unlist)) |> dplyr::slice(1L) |> as.list() |> .cli_groups_and_variable() |> list(), # character vector of all the stat_names the message applies to all_stat_names = list(.x$stat_name), # grabs the condition message and colors it with the cli color function cond_msg = unlist(.y[[msg_type]]) |> lapply(cli_color_fun) ) } ) |> dplyr::bind_rows() # and finally, print the messages cli::cli_inform( "The following {cli_color_fun(paste0(msg_type, 's'))} were returned during {.fun {error_call(get_cli_abort_call()) |> rlang::call_name()}}:" ) # set cli message function # styler: off if (condition_type == "inform") cli_msg_fn <- cli::cli_inform else if (condition_type == "identity" && msg_type == "warning") cli_msg_fn <- cli::cli_warn else if (condition_type == "identity" && msg_type == "error") { cli_msg_fn <- \(message, ...) cli::cli_abort(message = message, ..., call = get_cli_abort_call()) } # styler: on for (i in seq_len(nrow(ard_msg))) { cli_msg_fn( paste( glue::glue( "For variable {ard_msg$cli_variable_msg[[i]]} ", "{switch(!is.null(ard_msg$cli_group_msg[[i]]), paste0('(', ard_msg$cli_group_msg[[i]], ')')) %||% ''} ", "and {{.val {{ard_msg$all_stat_names[[i]]}}}} statistic{{?s}}" ), "{ard_msg$cond_msg[[i]]}", sep = ": " ) |> stats::setNames(switch(msg_type, "warning" = "!", "error" = "x" )) ) } invisible() } #' Locate Condition Messages in an ARD #' #' Prints a string of all `group##`/`group##_level` column values and #' `variable` column values where condition messages occur, formatted #' using glue syntax. #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' #' @return a string #' @keywords internal #' #' @examples #' ard <- ard_continuous( #' ADSL, #' by = ARM, #' variables = AGE, #' statistic = ~ list( #' mean = \(x) mean(x), #' mean_warning = \(x) { #' warning("warn1") #' warning("warn2") #' mean(x) #' }, #' err_fn = \(x) stop("'tis an error") #' ) #' ) #' #' cards:::.cli_groups_and_variable(ard) .cli_groups_and_variable <- function(x) { names <- names(x) # format the 'values' or levels of the variables levels <- x[endsWith(names, "_level")] |> lapply(\(x) glue::glue("{{.val {{{cli::cli_format(ifelse(is.numeric(x) || is.logical(x), x, as.character(x)))}}}}}")) # rename the levels to remove the '_level' suffix names(levels) <- sub(pattern = "_level$", replacement = "", x = names(levels)) # first subset on the variable names ret <- x[grepl(x = names, pattern = "^group[0-9]+$|^variable$")] |> # add the varname = value where appropriate imap( \(x, colname) { if (rlang::is_empty(levels[[colname]])) { return(glue::glue("{{.var {x}}}")) } glue::glue("{{.code {x} = {levels[[colname]]}}}") } ) |> paste(collapse = ", ") if (ret == "") ret <- NULL ret } cards/R/import-standalone-checks.R0000644000176200001440000005371214705533060016603 0ustar liggesusers# Standalone file: do not edit by hand # Source: # ---------------------------------------------------------------------- # # --- # repo: insightsengineering/standalone # file: standalone-checks.R # last-updated: 2024-05-04 # license: https://unlicense.org # dependencies: standalone-cli_call_env.R # imports: [rlang, cli] # --- # # This file provides a minimal functions to check argument values and types # passed by users to functions in packages. # # ## Changelog # nocov start # styler: off #' Check Class #' #' @param x `(object)`\cr #' object to check #' @param cls (`character`)\cr #' character vector or string indicating accepted classes. #' Passed to `inherits(what=cls)` #' @param message (`character`)\cr #' string passed to `cli::cli_abort(message)` #' @param allow_empty (`logical(1)`)\cr #' Logical indicating whether an empty value will pass the test. #' Default is `FALSE` #' @param arg_name (`string`)\cr #' string indicating the label/symbol of the object being checked. #' Default is `rlang::caller_arg(x)` #' @param envir (`environment`)\cr #' Environment to evaluate the glue expressions in passed in `cli::cli_abort(message)`. #' Default is `rlang::current_env()` #' @inheritParams cli::cli_abort #' @inheritParams rlang::abort #' @keywords internal #' @noRd check_class <- function(x, cls, allow_empty = FALSE, message = ifelse( allow_empty, "The {.arg {arg_name}} argument must be class {.cls {cls}} or empty, not {.obj_type_friendly {x}}.", "The {.arg {arg_name}} argument must be class {.cls {cls}}, not {.obj_type_friendly {x}}." ), arg_name = rlang::caller_arg(x), class = "check_class", call = get_cli_abort_call(), envir = rlang::current_env()) { # if empty, skip test if (isTRUE(allow_empty) && rlang::is_empty(x)) { return(invisible(x)) } if (!inherits(x, cls)) { cli::cli_abort(message, class = c(class, "standalone-checks"), call = call, .envir = envir) } invisible(x) } #' Check Class Data Frame #' #' @inheritParams check_class #' @keywords internal #' @noRd check_data_frame <- function(x, allow_empty = FALSE, message = ifelse( allow_empty, "The {.arg {arg_name}} argument must be class {.cls data.frame} or empty, not {.obj_type_friendly {x}}.", "The {.arg {arg_name}} argument must be class {.cls data.frame}, not {.obj_type_friendly {x}}." ), arg_name = rlang::caller_arg(x), class = "check_data_frame", call = get_cli_abort_call(), envir = rlang::current_env()) { check_class( x = x, cls = "data.frame", allow_empty = allow_empty, message = message, arg_name = arg_name, class = class, call = call, envir = envir ) } #' Check Class Logical #' #' @inheritParams check_class #' @keywords internal #' @noRd check_logical <- function(x, allow_empty = FALSE, message = ifelse( allow_empty, "The {.arg {arg_name}} argument must be class {.cls logical} or empty, not {.obj_type_friendly {x}}.", "The {.arg {arg_name}} argument must be class {.cls logical}, not {.obj_type_friendly {x}}." ), arg_name = rlang::caller_arg(x), class = "check_logical", call = get_cli_abort_call(), envir = rlang::current_env()) { check_class( x = x, cls = "logical", allow_empty = allow_empty, message = message, arg_name = arg_name, class = class, call = call, envir = envir ) } #' Check Class Logical and Scalar #' #' @inheritParams check_class #' @keywords internal #' @noRd check_scalar_logical <- function(x, allow_empty = FALSE, message = ifelse( allow_empty, "The {.arg {arg_name}} argument must be a scalar with class {.cls logical} or empty, not {.obj_type_friendly {x}}.", "The {.arg {arg_name}} argument must be a scalar with class {.cls logical}, not {.obj_type_friendly {x}}." ), arg_name = rlang::caller_arg(x), class = "check_scalar_logical", call = get_cli_abort_call(), envir = rlang::current_env()) { check_logical( x = x, allow_empty = allow_empty, message = message, arg_name = arg_name, class = class, call = call, envir = envir ) check_scalar( x = x, allow_empty = allow_empty, message = message, arg_name = arg_name, call = call, envir = envir ) } #' Check String #' #' @inheritParams check_class #' @keywords internal #' @noRd check_string <- function(x, allow_empty = FALSE, message = ifelse( allow_empty, "The {.arg {arg_name}} argument must be a string or empty, not {.obj_type_friendly {x}}.", "The {.arg {arg_name}} argument must be a string, not {.obj_type_friendly {x}}." ), arg_name = rlang::caller_arg(x), class = "check_string", call = get_cli_abort_call(), envir = rlang::current_env()) { check_class( x = x, cls = "character", allow_empty = allow_empty, message = message, arg_name = arg_name, class = class, call = call, envir = envir ) check_scalar( x = x, allow_empty = allow_empty, message = message, arg_name = arg_name, class = class, call = call, envir = envir ) } #' Check Argument not Missing #' #' @inheritParams check_class #' @keywords internal #' @noRd check_not_missing <- function(x, message = "The {.arg {arg_name}} argument cannot be missing.", arg_name = rlang::caller_arg(x), class = "check_not_missing", call = get_cli_abort_call(), envir = rlang::current_env()) { if (missing(x)) { cli::cli_abort(message, class = c(class, "standalone-checks"), call = call, .envir = envir) } # can't return 'x' because it may be an unevaluable obj, eg a bare tidyselect invisible() } #' Check Length #' #' @param length (`integer(1)`)\cr #' integer specifying the required length #' @inheritParams check_class #' @keywords internal #' @noRd check_length <- function(x, length, message = ifelse( allow_empty, "The {.arg {arg_name}} argument must be length {.val {length}} or empty.", "The {.arg {arg_name}} argument must be length {.val {length}}." ), allow_empty = FALSE, arg_name = rlang::caller_arg(x), class = "check_length", call = get_cli_abort_call(), envir = rlang::current_env()) { # if empty, skip test if (isTRUE(allow_empty) && rlang::is_empty(x)) { return(invisible(x)) } # check length if (length(x) != length) { cli::cli_abort(message, class = c(class, "standalone-checks"), call = call, .envir = envir) } invisible(x) } #' Check is Scalar #' #' @inheritParams check_class #' @keywords internal #' @noRd check_scalar <- function(x, allow_empty = FALSE, message = ifelse( allow_empty, "The {.arg {arg_name}} argument must be length {.val {1}} or empty.", "The {.arg {arg_name}} argument must be length {.val {1}}." ), arg_name = rlang::caller_arg(x), class = "check_scalar", call = get_cli_abort_call(), envir = rlang::current_env()) { check_length( x = x, length = 1L, message = message, allow_empty = allow_empty, arg_name = arg_name, class = class, call = call, envir = envir ) } #' Check Number of Levels #' #' @param n_levels Number of required levels (after NA are removed). #' @inheritParams check_class #' @keywords internal #' @noRd check_n_levels <- function(x, n_levels, message = "The {.arg {arg_name}} argument must have {.val {n_levels}} levels.", arg_name = rlang::caller_arg(x), class = "check_n_levels", call = get_cli_abort_call(), envir = rlang::current_env()) { check_length( x = stats::na.omit(x) |> unique(), length = n_levels, message = message, allow_empty = FALSE, arg_name = arg_name, class = class, call = call, envir = envir ) } #' Check Range #' #' @param x numeric scalar to check #' @param range numeric vector of length two #' @param include_bounds logical of length two indicating whether to allow #' the lower and upper bounds #' @inheritParams check_class #' #' @return invisible #' @keywords internal #' @noRd check_range <- function(x, range, include_bounds = c(FALSE, FALSE), message = "The {.arg {arg_name}} argument must be in the interval {.code {ifelse(include_bounds[1], '[', '(')}{range[1]}, {range[2]}{ifelse(include_bounds[2], ']', ')')}}.", allow_empty = FALSE, arg_name = rlang::caller_arg(x), class = "check_range", call = get_cli_abort_call(), envir = rlang::current_env()) { # if empty, skip test if (isTRUE(allow_empty) && rlang::is_empty(x)) { return(invisible(x)) } print_error <- FALSE # check input is numeric if (!is.numeric(x)) { print_error <- TRUE } # check the lower bound of range if (isFALSE(print_error) && isTRUE(include_bounds[1]) && any(x < range[1])) { print_error <- TRUE } if (isFALSE(print_error) && isFALSE(include_bounds[1]) && any(x <= range[1])) { print_error <- TRUE } # check upper bound of range if (isFALSE(print_error) && isTRUE(include_bounds[2]) && any(x > range[2])) { print_error <- TRUE } if (isFALSE(print_error) && isFALSE(include_bounds[2]) && any(x >= range[2])) { print_error <- TRUE } # print error if (print_error) { cli::cli_abort(message, class = c(class, "standalone-checks"), call = call, .envir = envir) } invisible(x) } #' Check Scalar Range #' #' @param x numeric scalar to check #' @param range numeric vector of length two #' @param include_bounds logical of length two indicating whether to allow #' the lower and upper bounds #' @inheritParams check_class #' #' @return invisible #' @keywords internal #' @noRd check_scalar_range <- function(x, range, include_bounds = c(FALSE, FALSE), allow_empty = FALSE, message = "The {.arg {arg_name}} argument must be in the interval {.code {ifelse(include_bounds[1], '[', '(')}{range[1]}, {range[2]}{ifelse(include_bounds[2], ']', ')')}} and length {.val {1}}.", arg_name = rlang::caller_arg(x), class = "check_scalar_range", call = get_cli_abort_call(), envir = rlang::current_env()) { check_scalar(x, message = message, arg_name = arg_name, allow_empty = allow_empty, class = class, call = call, envir = envir) check_range(x = x, range = range, include_bounds = include_bounds, message = message, allow_empty = allow_empty, arg_name = arg_name, class = class, call = call, envir = envir) } #' Check Binary #' #' Checks if a column in a data frame is binary, #' that is, if the column is class `` or #' `` and coded as `c(0, 1)` #' #' @param x a vector #' @inheritParams check_class #' #' @return invisible #' @keywords internal #' @noRd check_binary <- function(x, allow_empty = FALSE, message = ifelse( allow_empty, "Expecting {.arg {arg_name}} to be either {.cls logical}, {.cls {c('numeric', 'integer')}} coded as {.val {c(0, 1)}}, or empty.", "Expecting {.arg {arg_name}} to be either {.cls logical} or {.cls {c('numeric', 'integer')}} coded as {.val {c(0, 1)}}." ), arg_name = rlang::caller_arg(x), class = "check_binary", call = get_cli_abort_call(), envir = rlang::current_env()) { # if empty, skip test if (isTRUE(allow_empty) && rlang::is_empty(x)) { return(invisible(x)) } # first check x is either logical or numeric check_class(x, cls = c("logical", "numeric", "integer"), arg_name = arg_name, message = message, class = class, call = call, envir = envir) # if "numeric" or "integer", it must be coded as 0, 1 if (!is.logical(x) && !(rlang::is_integerish(x) && rlang::is_empty(setdiff(x, c(0, 1, NA))))) { cli::cli_abort(message, class = c(class, "standalone-checks"), call = call, .envir = envir) } invisible(x) } #' Check Formula-List Selector #' #' Checks the structure of the formula-list selector used throughout the #' cards, cardx, and gtsummary packages. #' #' @param x formula-list selecting object #' @inheritParams check_class #' #' @return invisible #' @keywords internal #' @noRd check_formula_list_selector <- function(x, allow_empty = FALSE, message = c( ifelse( allow_empty, "The {.arg {arg_name}} argument must be a named list, list of formulas, a single formula, or empty.", "The {.arg {arg_name}} argument must be a named list, list of formulas, or a single formula." ), "i" = "Review {.help [?syntax](cards::syntax)} for examples and details." ), arg_name = rlang::caller_arg(x), class = "check_formula_list_selector", call = get_cli_abort_call(), envir = rlang::current_env()) { # if empty, skip test if (isTRUE(allow_empty) && rlang::is_empty(x)) { return(invisible(x)) } # first check the general structure; must be a list or formula check_class( x = x, cls = c("list", "formula"), allow_empty = allow_empty, message = message, arg_name = arg_name, class = class, call = call, envir = envir ) # if it's a list, then check each element is either named or a formula if (inherits(x, "list")) { for (i in seq_along(x)) { if (!rlang::is_named(x[i]) && !inherits(x[[i]], "formula")) { cli::cli_abort(message, class = c(class, "standalone-checks"), call = call, .envir = envir) } } } invisible(x) } #' Check is Integerish #' #' @inheritParams check_class #' @keywords internal #' @noRd check_integerish <- function(x, allow_empty = FALSE, message = ifelse( allow_empty, "The {.arg {arg_name}} argument must an integer vector or empty.", "The {.arg {arg_name}} argument must an integer vector." ), arg_name = rlang::caller_arg(x), class = "check_integerish", call = get_cli_abort_call(), envir = rlang::current_env()) { # if empty, skip test if (isTRUE(allow_empty) && rlang::is_empty(x)) { return(invisible(x)) } if (!rlang::is_integerish(x)) { cli::cli_abort(message, class = c(class, "standalone-checks"), call = call, .envir = envir) } invisible(x) } #' Check is Scalar Integerish #' #' @inheritParams check_class #' @keywords internal #' @noRd check_scalar_integerish <- function(x, allow_empty = FALSE, message = ifelse( allow_empty, "The {.arg {arg_name}} argument must an scalar integer or empty.", "The {.arg {arg_name}} argument must an scalar integer." ), arg_name = rlang::caller_arg(x), class = "check_integerish", call = get_cli_abort_call(), envir = rlang::current_env()) { # if empty, skip test if (isTRUE(allow_empty) && rlang::is_empty(x)) { return(invisible(x)) } if (!rlang::is_scalar_integerish(x)) { cli::cli_abort(message, class = c(class, "standalone-checks"), call = call, .envir = envir) } invisible(x) } #' Check for presence of `NA` factor levels in the data #' #' @param x (`data.frame`)\cr #' a data frame #' @inheritParams check_class #' @keywords internal #' @noRd check_no_na_factor_levels <- function(x, message = "Factors with {.val {NA}} levels are not allowed, which are present in column {.val {variable}}.", arg_name = rlang::caller_arg(x), class = "na_factor_levels", call = get_cli_abort_call(), envir = rlang::current_env()) { check_data_frame(x, arg_name = arg_name, class = class, call = call, envir = envir) for (variable in names(x)) { if (is.factor(x[[variable]]) && any(is.na(levels(x[[variable]])))) { cli::cli_abort(message = message, class = c(class, "standalone-checks"), call = call, .envir = envir) } } invisible(x) } #' Check for levels attribute exists for factor #' #' @param x (`data.frame`)\cr #' a data frame #' @inheritParams check_class #' @keywords internal #' @noRd check_factor_has_levels <- function(x, message = "Factors with empty {.val levels} attribute are not allowed, which was identified in column {.val {variable}}.", arg_name = rlang::caller_arg(x), class = "na_factor_levels", call = get_cli_abort_call(), envir = rlang::current_env()) { check_data_frame(x, arg_name = arg_name, class = class, call = call, envir = envir) for (variable in names(x)) { if (is.factor(x[[variable]]) && rlang::is_empty(levels(x[[variable]]))) { cli::cli_abort(message = message, class = c(class, "standalone-checks"), call = call, .envir = envir) } } invisible(x) } #' Check is Numeric #' #' @inheritParams check_class #' @keywords internal #' @noRd check_numeric <- function(x, allow_empty = FALSE, message = ifelse( allow_empty, "The {.arg {arg_name}} argument must be numeric or empty.", "The {.arg {arg_name}} argument must be numeric." ), arg_name = rlang::caller_arg(x), class = "check_numeric", call = get_cli_abort_call(), envir = rlang::current_env()) { # if empty, skip test if (isTRUE(allow_empty) && rlang::is_empty(x)) { return(invisible(x)) } if (!is.numeric(x)) { cli::cli_abort(message, class = c(class, "standalone-checks"), call = call, .envir = envir) } invisible(x) } # nocov end # styler: on cards/R/ard_hierarchical.R0000644000176200001440000001673414754702430015157 0ustar liggesusers#' Hierarchical ARD Statistics #' #' @description #' _Functions `ard_hierarchical()` and `ard_hierarchical_count()` are primarily helper #' functions for [`ard_stack_hierarchical()`] and [`ard_stack_hierarchical_count()`], #' meaning that it will be rare a user needs to call #' `ard_hierarchical()`/`ard_hierarchical_count()` directly._ #' #' Performs hierarchical or nested tabulations, e.g. tabulates AE terms #' nested within AE system organ class. #' - `ard_hierarchical()` includes summaries for the last variable listed #' in the `variables` argument, nested within the other variables included. #' - `ard_hierarchical_count()` includes summaries for _all_ variables #' listed in the `variables` argument each summary nested within the preceding #' variables, e.g. `variables=c(AESOC, AEDECOD)` summarizes `AEDECOD` nested #' in `AESOC`, and also summarizes the counts of `AESOC`. #' #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' variables to perform the nested/hierarchical tabulations within. #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' variables to perform tabulations by. All combinations of the variables #' specified here appear in results. Default is `dplyr::group_vars(data)`. #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' an optional argument used to assert there are no duplicates within #' the `c(id, variables)` columns. #' @param denominator (`data.frame`, `integer`)\cr #' used to define the denominator and enhance the output. #' The argument is required for `ard_hierarchical()` and optional #' for `ard_hierarchical_count()`. #' - the univariate tabulations of the `by` variables are calculated with `denominator`, #' when a data frame is passed, e.g. tabulation of the treatment assignment #' counts that may appear in the header of a table. #' - the `denominator` argument must be specified when `id` is used to #' calculate the event rates. #' @inheritParams ard_categorical #' #' @return an ARD data frame of class 'card' #' @name ard_hierarchical #' #' @examples #' ard_hierarchical( #' data = ADAE |> #' dplyr::slice_tail(n = 1L, by = c(USUBJID, TRTA, AESOC, AEDECOD)), #' variables = c(AESOC, AEDECOD), #' by = TRTA, #' id = USUBJID, #' denominator = ADSL |> dplyr::rename(TRTA = ARM) #' ) #' #' ard_hierarchical_count( #' data = ADAE, #' variables = c(AESOC, AEDECOD), #' by = TRTA #' ) NULL #' @rdname ard_hierarchical #' @export ard_hierarchical <- function(data, ...) { check_not_missing(data) UseMethod("ard_hierarchical") } #' @rdname ard_hierarchical #' @export ard_hierarchical_count <- function(data, ...) { check_not_missing(data) UseMethod("ard_hierarchical_count") } #' @rdname ard_hierarchical #' @export ard_hierarchical.data.frame <- function(data, variables, by = dplyr::group_vars(data), statistic = everything() ~ c("n", "N", "p"), denominator = NULL, fmt_fn = NULL, stat_label = everything() ~ default_stat_labels(), id = NULL, ...) { set_cli_abort_call() check_dots_used() # check inputs --------------------------------------------------------------- check_not_missing(variables) # process arguments ---------------------------------------------------------- process_selectors( data, variables = {{ variables }}, by = {{ by }}, id = {{ id }} ) data <- dplyr::ungroup(data) if (!is_empty(id) && anyDuplicated(data[c(id, variables)]) > 0L) { cli::cli_warn(c( "Duplicate rows found in data for the {.val {id}} column{?s}.", "i" = "Percentages/Denominators are not correct." )) } # return empty ARD if no variables selected ---------------------------------- if (is_empty(variables)) { return(dplyr::tibble() |> as_card()) } # if denominator doesn't have all by, they need to be added ------------------ if (!is.null(denominator) && is.data.frame(denominator) && !all(by %in% names(denominator))) { by_vars_not_present <- by |> setdiff(names(denominator)) denominator <- data |> dplyr::select(all_of(by_vars_not_present)) |> dplyr::distinct() |> dplyr::mutate( ...ard_data_column... = list(denominator) ) |> tidyr::unnest(cols = "...ard_data_column...") } # add dummy variable for counting -------------------------------------------- data[["...ard_dummy_for_counting..."]] <- 1L # perform tabulations -------------------------------------------------------- df_result <- ard_categorical( data = data, variables = "...ard_dummy_for_counting...", by = all_of(by), strata = all_of(variables), statistic = statistic, denominator = denominator, fmt_fn = fmt_fn, stat_label = stat_label ) # renaming columns ----------------------------------------------------------- df_result <- .rename_last_group_as_variable(df_result, by = by, variables = variables) # return ard ----------------------------------------------------------------- df_result |> dplyr::mutate(context = "hierarchical") } #' @rdname ard_hierarchical #' @export ard_hierarchical_count.data.frame <- function(data, variables, by = dplyr::group_vars(data), fmt_fn = NULL, stat_label = everything() ~ default_stat_labels(), ...) { set_cli_abort_call() check_dots_used() # check inputs --------------------------------------------------------------- check_not_missing(variables) # process arguments ---------------------------------------------------------- process_selectors(data, variables = {{ variables }}, by = {{ by }}) # return empty ARD if no variables selected ---------------------------------- if (is_empty(variables)) { return(dplyr::tibble() |> as_card()) } # add dummy variable for counting -------------------------------------------- data[["...ard_dummy_for_counting..."]] <- 1L # perform tabulations -------------------------------------------------------- ard_categorical( data = data, variables = "...ard_dummy_for_counting...", by = all_of(by), strata = all_of(variables), statistic = everything() ~ "n", fmt_fn = fmt_fn, stat_label = stat_label ) |> .rename_last_group_as_variable(by = by, variables = variables) |> dplyr::mutate(context = "hierarchical_count") |> as_card() } #' Rename Last Group to Variable #' #' In the `ard_hierarchical*()` functions, the last grouping variable is #' renamed to `variable` and `variable_level` before being returned. #' #' @param df_result (`data.frame`)\cr #' an ARD data frame of class 'card' #' #' @return an ARD data frame of class 'card' #' @keywords internal #' #' @examples #' data <- data.frame(x = 1, y = 2, group1 = 3, group2 = 4) #' #' cards:::.rename_last_group_as_variable(data, by = "ARM", variables = "AESOC") .rename_last_group_as_variable <- function(df_result, by, variables) { df_result |> dplyr::select(-all_ard_variables()) |> dplyr::rename( variable = all_ard_group_n(n = length(c(by, variables)), types = "names"), variable_level = all_ard_group_n(n = length(c(by, variables)), types = "levels") ) } cards/R/import-standalone-tibble.R0000644000176200001440000000230314705533060016572 0ustar liggesusers# Standalone file: do not edit by hand # Source: # ---------------------------------------------------------------------- # # --- # repo: insightsengineering/standalone # file: standalone-tibble.R # last-updated: 2024-05-07 # license: https://unlicense.org # imports: [dplyr] # --- # # This file provides a minimal shim to provide a tibble-like API on top of # base R functions. They are not drop-in replacements but allow a similar style # of programming. # # ## Changelog # # nocov start # styler: off deframe <- function(x) { if (ncol(x) == 1L) return(x[[1]]) x[[2]] |> stats::setNames(x[[1]]) } enframe <- function(x, name = "name", value = "value") { if (!is.null(names(x))) { lst <- list(names(x), unname(x)) |> stats::setNames(c(name, value)) } else { lst <- list(seq_along(x), unname(x)) |> stats::setNames(c(name, value)) } dplyr::tibble(!!!lst) } remove_rownames <- function(.data) { rownames(.data) <- NULL .data } rownames_to_column <- function(.data, var = "rowname") { .data[[var]] <- rownames(.data) dplyr::relocate(.data, dplyr::all_of(var), .before = 1L) } # nocov end # styler: on cards/R/mock.R0000644000176200001440000002130614754217347012643 0ustar liggesusers#' Mock ARDs #' #' `r lifecycle::badge('experimental')`\cr #' Create empty ARDs used to create mock tables or table shells. #' Where applicable, the formatting functions are set to return `'xx'` or `'xx.x'`. #' #' @param variables (`character` or named `list`)\cr #' a character vector of variable names for functions `mock_continuous()`, #' `mock_missing()`, and `mock_attributes()`. #' #' a named list for functions `mock_categorical()` and `mock_dichotomous()`, #' where the list element is a vector of variable values. For #' `mock_dichotomous()`, only a single value is allowed for each variable. #' @param statistic ([`formula-list-selector`][syntax])\cr #' a named list, a list of formulas, or a single formula where the list elements #' are character vectors of statistic names to appear in the ARD. #' @param by (named `list`)\cr #' a named list where the list element is a vector of variable values. #' @param label (named `list`)\cr #' named list of variable labels, e.g. `list(cyl = "No. Cylinders")`. #' #' @return an ARD data frame of class 'card' #' @name mock #' #' @examples #' mock_categorical( #' variables = #' list( #' AGEGR1 = factor(c("<65", "65-80", ">80"), levels = c("<65", "65-80", ">80")) #' ), #' by = list(TRTA = c("Placebo", "Xanomeline High Dose", "Xanomeline Low Dose")) #' ) |> #' apply_fmt_fn() #' #' mock_continuous( #' variables = c("AGE", "BMIBL"), #' by = list(TRTA = c("Placebo", "Xanomeline High Dose", "Xanomeline Low Dose")) #' ) |> #' # update the mock to report 'xx.xx' for standard deviations #' update_ard_fmt_fn(variables = c("AGE", "BMIBL"), stat_names = "sd", fmt_fn = \(x) "xx.xx") |> #' apply_fmt_fn() NULL #' @rdname mock #' @export mock_categorical <- function(variables, statistic = everything() ~ c("n", "p", "N"), by = NULL) { set_cli_abort_call() # check/process inputs ------------------------------------------------------- check_named_list_and_vector_elements(variables) check_named_list_and_vector_elements(by) process_formula_selectors( data = .empty_data_frame(names(variables)), statistic = statistic ) check_list_elements( x = statistic, predicate = \(x) is.character(x) && all(x %in% c("n", "p", "N")), error_msg = "The elements of the {.arg statistic} argument must be vector with one or more of {.val {c('n', 'p', 'N')}}." ) # create ARD ----------------------------------------------------------------- # build the ARD for the by variables ard_by <- .construct_by_variable_ard(by) # create ARD for the variables ard_variables <- dplyr::tibble( variable = names(.env$variables), variable_level = map(.data$variable, ~ as.list(.env$variables[[.x]])) ) |> tidyr::unnest(cols = "variable_level") |> dplyr::left_join( enframe(statistic, "variable", "stat_name"), by = "variable" ) |> tidyr::unnest(cols = "stat_name") |> .process_nested_list_as_df( arg = rep_named(names(variables), list(default_stat_labels())), new_column = "stat_label", unlist = TRUE ) |> dplyr::mutate( stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name), context = "categorical", stat = list(NULL), error = list(NULL), warning = list(NULL), fmt_fn = map( .data$stat_name, ~ ifelse(.x %in% c("n", "N", "N_obs", "N_miss", "N_nonmiss"), \(x) "xx", \(x) "xx.x") ) ) # merge the by ARD and the primary variable ARD ------------------------------ merge(ard_by, ard_variables, by = NULL) |> as_card() |> tidy_ard_row_order() |> tidy_ard_column_order() } #' @rdname mock #' @export mock_continuous <- function(variables, statistic = everything() ~ c( "N", "mean", "sd", "median", "p25", "p75", "min", "max" ), by = NULL) { set_cli_abort_call() # check/process inputs ------------------------------------------------------- check_class(variables, "character") if (!is_empty(by)) check_named_list_and_vector_elements(by) # styler: off process_formula_selectors( data = data.frame(matrix(ncol = length(variables), nrow = 0)) |> stats::setNames(variables), statistic = statistic ) check_list_elements( x = statistic, predicate = is.character, error_msg = "The elements of the {.arg statistic} argument must be {.cls character} vector of statistic names." ) # create ARD ----------------------------------------------------------------- # build the ARD for the by variables ard_by <- .construct_by_variable_ard(by) # create ARD for the variables ard_variables <- dplyr::tibble( variable = .env$variables, stat_name = map(.data$variable, ~ .env$statistic[[.x]]) ) |> tidyr::unnest(cols = "stat_name") |> .process_nested_list_as_df( arg = rep_named(variables, list(default_stat_labels())), new_column = "stat_label", unlist = TRUE ) |> dplyr::mutate( stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name), context = "continuous", stat = list(NULL), error = list(NULL), warning = list(NULL), fmt_fn = map( .data$stat_name, ~ ifelse(.x %in% c("n", "N", "N_obs", "N_miss", "N_nonmiss"), \(x) "xx", \(x) "xx.x") ) ) # merge the by ARD and the primary variable ARD ------------------------------ merge(ard_by, ard_variables, by = NULL) |> as_card() |> tidy_ard_row_order() |> tidy_ard_column_order() } #' @rdname mock #' @export mock_dichotomous <- function(variables, statistic = everything() ~ c("n", "p", "N"), by = NULL) { set_cli_abort_call() # check/process inputs ------------------------------------------------------- check_named_list_and_vector_elements(variables) check_list_elements( x = variables, predicate = \(x) length(x) == 1L, error_msg = "The list values of {.arg variables} argument must be length {.val {1}}.", ) mock_categorical(variables = variables, statistic = statistic, by = by) |> dplyr::mutate(context = "dichotomous") } #' @rdname mock #' @export mock_missing <- function(variables, statistic = everything() ~ c("N_obs", "N_miss", "N_nonmiss", "p_miss", "p_nonmiss"), by = NULL) { set_cli_abort_call() # check/process inputs ------------------------------------------------------- check_class(variables, "character") process_formula_selectors( data = data.frame(matrix(ncol = length(variables), nrow = 0)) |> stats::setNames(variables), statistic = statistic ) check_list_elements( x = statistic, predicate = \(x) is.character(x) && all(x %in% c("N_obs", "N_miss", "N_nonmiss", "p_miss", "p_nonmiss")), error_msg = "The elements of the {.arg statistic} argument must be vector with one or more of {.val {c('N_obs', 'N_miss', 'N_nonmiss', 'p_miss', 'p_nonmiss')}}." ) # build ARD ------------------------------------------------------------------ mock_continuous(variables = variables, statistic = statistic, by = by) |> dplyr::mutate(context = "missing") } #' @rdname mock #' @export mock_attributes <- function(label) { set_cli_abort_call() if (!is_named(label) || !is.list(label)) { cli::cli_abort( "The {.arg label} argument must be a named list.", call = get_cli_abort_call() ) } ard_attributes( data = .empty_data_frame(names(label)), label = label ) } #' @rdname mock #' @export mock_total_n <- function() { set_cli_abort_call() ard_total_n(data.frame()) |> dplyr::mutate( stat = list(NULL), fmt_fn = list(\(x) "xx") ) } check_named_list_and_vector_elements <- function( x, message = "The {.arg {arg_name}} argument must be a named list, and each element a vector of values.", arg_name = rlang::caller_arg(x), call = get_cli_abort_call(), envir = rlang::current_env()) { # check input is a named list if (!is_empty(x) && (!is_named(x) || !is.list(x))) { cli::cli_abort(message = message, call = call, .envir = envir) } check_list_elements( x = x, predicate = \(x) is_vector(x) && !is.list(x), error_msg = message, arg_name = arg_name ) } .empty_data_frame <- function(x) { data.frame(matrix(ncol = length(x), nrow = 0)) |> stats::setNames(x) } .construct_by_variable_ard <- function(by) { ard_by <- tidyr::expand_grid(!!!map(by, as.list)) # rename the by variables for (i in seq_along(by)) { ard_by <- ard_by |> dplyr::mutate("group{i}" := names(by)[i]) |> dplyr::rename("group{i}_level" := glue::glue("{names(by)[i]}")) } ard_by } cards/R/eval_capture_conditions.R0000644000176200001440000001204414752441547016613 0ustar liggesusers#' Evaluate and Capture Conditions #' #' @description #' #' **`eval_capture_conditions()`** #' #' Evaluates an expression while also capturing error and warning conditions. #' Function always returns a named list `list(result=, warning=, error=)`. #' If there are no errors or warnings, those elements will be `NULL`. #' If there is an error, the result element will be `NULL`. #' #' Messages are neither saved nor printed to the console. #' #' Evaluation is done via [`rlang::eval_tidy()`]. If errors and warnings are produced #' using the `{cli}` package, the messages are processed with `cli::ansi_strip()` #' to remove styling from the message. #' #' **`captured_condition_as_message()`/`captured_condition_as_error()`** #' #' These functions take the result from `eval_capture_conditions()` and return #' errors or warnings as either messages (via `cli::cli_inform()`) or #' errors (via `cli::cli_abort()`). These functions handle cases where the #' condition messages may include curly brackets, which would typically cause #' issues when processed with the `cli::cli_*()` functions. #' #' Functions return the `"result"` from `eval_capture_conditions()`. #' #' @inheritParams rlang::eval_tidy #' @inheritParams cli::cli_abort #' @param x (`captured_condition`)\cr #' a captured condition created by `eval_capture_conditions()`. #' @param type (`string`)\cr #' the type of condition to return. Must be one of `'error'` or `'warning'`. #' @param message (`character`)\cr #' message passed to `cli::cli_inform()` or `cli::cli_abort()`. The condition #' being printed is saved in an object named `condition`, which should be #' included in this message surrounded by curly brackets. #' @param call (`environment`)\cr #' Execution environment of currently running function. Default is #' `get_cli_abort_call()`. #' @return a named list #' @name eval_capture_conditions #' #' @examples #' # function executes without error or warning #' eval_capture_conditions(letters[1:2]) #' #' # an error is thrown #' res <- eval_capture_conditions(stop("Example Error!")) #' res #' captured_condition_as_message(res) #' #' # if more than one warning is returned, all are saved #' eval_capture_conditions({ #' warning("Warning 1") #' warning("Warning 2") #' letters[1:2] #' }) #' #' # messages are not printed to the console #' eval_capture_conditions({ #' message("A message!") #' letters[1:2] #' }) NULL #' @rdname eval_capture_conditions #' @export eval_capture_conditions <- function(expr, data = NULL, env = caller_env()) { # IF WE EVER NEED TO REWORK/DEBUG REVIEW THE ADVANCED R CONDITIONS CHAPTER # https://adv-r.hadley.nz/conditions.html#conditions # initialize empty list to return lst_result <- list(result = NULL, warning = NULL, error = NULL) # tryCatch() saves error messages # withCallingHandlers() saves the warnings # invokeRestart() suppresses the printing of warnings when code is resumed tryCatch( withCallingHandlers( expr = { lst_result[["result"]] <- suppressMessages(eval_tidy({{ expr }}, data = data, env = env)) }, warning = function(w) { lst_result[["warning"]] <<- # using `c()` to capture all warnings c(lst_result[["warning"]], conditionMessage(w) |> cli::ansi_strip()) invokeRestart("muffleWarning") } ), error = function(e) { lst_result[["error"]] <<- conditionMessage(e) |> cli::ansi_strip() } ) # return named list of results lst_result %>% structure(., class = c("captured_condition", class(.))) } #' @rdname eval_capture_conditions #' @export captured_condition_as_message <- function(x, message = c("The following {type} occured:", "x" = "{condition}" ), type = c("error", "warning"), envir = rlang::current_env()) { check_class(x, "captured_condition") type <- rlang::arg_match(type) # if error/warning is empty, return x invisibly if (is_empty(x[[type]])) return(x[["result"]]) # styler: off condition <- x[[type]] cli::cli_inform(message = message, .envir = envir) x[["result"]] } #' @rdname eval_capture_conditions #' @export captured_condition_as_error <- function(x, message = c("The following {type} occured:", "x" = "{condition}" ), type = c("error", "warning"), call = get_cli_abort_call(), envir = rlang::current_env()) { check_class(x, "captured_condition") type <- rlang::arg_match(type) # if error/warning is empty, return x invisibly if (is_empty(x[[type]])) return(x[["result"]]) # styler: off condition <- x[[type]] cli::cli_abort(message = message, call = call, .envir = envir) } cards/R/unlist_ard_columns.R0000644000176200001440000000450514776252447015624 0ustar liggesusers#' Unlist ARD Columns #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' or any data frame #' @param columns ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' columns to unlist. Default is #' `c(where(is.list), -any_of(c("warning", "error", "fmt_fn")))`. #' @param fill (scalar)\cr #' scalar to fill NULL values with before unlisting (if they are present). #' Default is `NA`. #' @param fct_as_chr (scalar `logical`)\cr #' When `TRUE`, factor elements will be converted to character before unlisting. #' When the column being unlisted contains mixed types of classes, the #' factor elements are often converted to the underlying integer value instead #' of retaining the label. Default is `TRUE`. #' #' #' @returns a data frame #' @export #' #' @examples #' ADSL |> #' ard_categorical(by = ARM, variables = AGEGR1) |> #' apply_fmt_fn() |> #' unlist_ard_columns() #' #' ADSL |> #' ard_continuous(by = ARM, variables = AGE) |> #' apply_fmt_fn() |> #' unlist_ard_columns() unlist_ard_columns <- function(x, columns = c(where(is.list), -any_of(c("warning", "error", "fmt_fn"))), fill = NA, fct_as_chr = TRUE) { # check inputs --------------------------------------------------------------- set_cli_abort_call() check_data_frame(x) process_selectors(x, columns = {{ columns }}) check_scalar(fill) check_scalar_logical(fct_as_chr) # first replace any NULL values with the fill value -------------------------- if (isTRUE(fct_as_chr)) { x <- x |> dplyr::mutate( across( all_of(columns), ~ map(., \(value) { if (inherits(value, "factor")) value <- as.character(value) # styler: off value %||% .env$fill }) ) ) } else { x <- x |> dplyr::mutate( across(all_of(columns), ~ map(., \(value) value %||% .env$fill)) ) } # unlist the columns --------------------------------------------------------- for (var in columns) { var_unlisted <- unlist(x[[var]]) if (length(var_unlisted) != length(x[[var]])) { cli::cli_inform("Cannot unlist column {.val {var}}.") next } x[[var]] <- var_unlisted } # return unlisted object ----------------------------------------------------- x } cards/R/utils.R0000644000176200001440000000436714767007551013060 0ustar liggesusers#' ARD-flavor of unique() #' #' Essentially a wrapper for `unique(x) |> sort()` with `NA` levels removed. #' For factors, all levels are returned even if they are unobserved. #' Similarly, logical vectors always return `c(TRUE, FALSE)`, even if #' both levels are not observed. #' #' @param x (`any`)\cr #' a vector #' #' @return a vector #' @keywords internal #' #' @examples #' cards:::.unique_and_sorted(factor(letters[c(5, 5:1)], levels = letters)) #' #' cards:::.unique_and_sorted(c(FALSE, TRUE, TRUE, FALSE)) #' #' cards:::.unique_and_sorted(c(5, 5:1)) .unique_and_sorted <- function(x, useNA = c("no", "always")) { # styler: off useNA <- match.arg(useNA) # if a factor return a factor that includes the same levels (including unobserved levels) if (inherits(x, "factor")) { return( factor( if (useNA == "no") levels(x) else c(levels(x), NA_character_), levels = levels(x) ) ) } if (inherits(x, "logical")) { if (useNA == "no") return(c(FALSE, TRUE)) else return(c(FALSE, TRUE, NA)) } # otherwise, return a simple unique and sort of the vector if (useNA == "no") return(unique(x) |> sort()) else return(unique(x) |> sort() |> c(NA)) # styler: on } #' Named List Predicate #' #' A predicate function to check whether input is a named list and _not_ a data frame. #' #' @param x (`any`)\cr #' object to check #' #' @return a logical #' @keywords internal #' #' @examples #' cards:::.is_named_list(list(a = 1:3)) .is_named_list <- function(x, allow_df = FALSE) { if (isFALSE(allow_df)) { return(is.list(x) && is_named(x) && !is.data.frame(x)) } if (isTRUE(allow_df)) { return(is.list(x) && is_named(x)) } } #' A list_flatten()-like Function #' #' Function operates similarly to `purrr::list_flatten(x, name_spec = "{inner}")`. #' #' @param x (named `list`)\cr #' a named list #' #' @return a named list #' @keywords internal #' #' @examples #' x <- list(a = 1, b = list(b1 = 2, b2 = 3), c = list(c1 = 4, c2 = list(c2a = 5))) #' #' cards:::.purrr_list_flatten(x) .purrr_list_flatten <- function(x) { ret <- list() for (i in seq_along(x)) { if (.is_named_list(x[[i]])) { ret <- append(ret, values = x[[i]]) } else { ret <- append(ret, values = x[i]) } } ret } cards/R/replace_null_statistic.R0000644000176200001440000000331414675616454016451 0ustar liggesusers#' Replace NULL Statistics with Specified Value #' #' When a statistical summary function errors, the `"stat"` column will be #' `NULL`. It is, however, sometimes useful to replace these values with a #' non-`NULL` value, e.g. `NA`. #' #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' @param value (usually a `scalar`)\cr #' The value to replace `NULL` values with. Default is `NA`. #' @param rows ([`data-masking`][rlang::args_data_masking])\cr #' Expression that return a logical value, and are defined in terms of the variables in `.data`. #' Only rows for which the condition evaluates to `TRUE` are replaced. #' Default is `TRUE`, which applies to all rows. #' #' @return an ARD data frame of class 'card' #' @export #' #' @examples #' # the quantile functions error because the input is character, while the median function returns NA #' data.frame(x = rep_len(NA_character_, 10)) |> #' ard_continuous( #' variables = x, #' statistic = ~ continuous_summary_fns(c("median", "p25", "p75")) #' ) |> #' replace_null_statistic(rows = !is.null(error)) replace_null_statistic <- function(x, value = NA, rows = TRUE) { set_cli_abort_call() # check inputs --------------------------------------------------------------- check_class(x, "card") # replace NULL values -------------------------------------------------------- x |> dplyr::rowwise() |> dplyr::mutate( # styler: off stat = if (is.null(.data$stat) && {{ rows }}) list(.env$value) else list(.data$stat) # styler: on ) |> # restore previous grouping structure and original class of x dplyr::group_by(dplyr::pick(dplyr::group_vars(x))) |> structure(class = class(x)) } cards/R/import-standalone-check_pkg_installed.R0000644000176200001440000001703314760633421021317 0ustar liggesusers# Standalone file: do not edit by hand # Source: https://github.com/insightsengineering/standalone/blob/HEAD/R/standalone-check_pkg_installed.R # Generated by: usethis::use_standalone("insightsengineering/standalone", "check_pkg_installed") # ---------------------------------------------------------------------- # # --- # repo: insightsengineering/standalone # file: standalone-check_pkg_installed.R # last-updated: 2025-02-03 # license: https://unlicense.org # dependencies: standalone-cli_call_env.R # imports: [rlang, dplyr, tidyr] # --- # # This file provides functions to check package installation. # # ## Changelog # 2025-02-03 # - `get_pkg_dependencies()` was updated to use base r equivalents for `str_extract()` and `str_remove_all()`. # nocov start # styler: off #' Check Package Installation #' #' @description #' - `check_pkg_installed()`: checks whether a package is installed and #' returns an error if not available, or interactively asks user to install #' missing dependency. If a package search is provided, #' the function will check whether a minimum version of a package is required and installed. #' #' - `is_pkg_installed()`: checks whether a package is installed and #' returns `TRUE` or `FALSE` depending on availability. If a package search is provided, #' the function will check whether a minimum version of a package is required and installed. #' #' - `get_pkg_dependencies()` returns a tibble with all #' dependencies of a specific package. #' #' - `get_min_version_required()` will return, if any, the minimum version of `pkg` required by `ref`. #' #' @param pkg (`character`)\cr #' vector of package names to check. #' @param call (`environment`)\cr #' frame for error messaging. Default is [get_cli_abort_call()]. #' @param ref (`string`)\cr #' name of the package the function will search for a minimum required version from. #' @param lib.loc (`path`)\cr #' location of `R` library trees to search through, see [utils::packageDescription()]. #' #' @details #' The `ref` argument (`pkg` in `get_pkg_dependencies`) uses `utils::packageName()` as a default, which returns the package in #' which the current environment or function is run from. The current environment is determined via `parent.frame()`. #' #' If, for example, `get_min_version_required("dplyr", ref = utils::packageName())` is run within a `cards` function, and this #' function is then called within a function of the `cardx` package, the minimum version returned by the #' `get_min_version_required` call will return the version required by the `cards` package. If run within a test file, #' `utils::packageName()` returns the package of the current test. Within Roxygen `@examplesIf` calls, `utils::packageName()` will #' returns the package of the current example. #' #' @return `is_pkg_installed()` and `check_pkg_installed()` returns a logical or error, #' `get_min_version_required()` returns a data frame with the minimum version required, #' `get_pkg_dependencies()` returns a tibble. #' #' @examples #' check_pkg_installed("dplyr") #' #' is_pkg_installed("dplyr") #' #' get_pkg_dependencies() #' #' get_min_version_required("dplyr") #' #' @name check_pkg_installed #' @noRd NULL #' @inheritParams check_pkg_installed #' @keywords internal #' @noRd check_pkg_installed <- function(pkg, ref = utils::packageName(), call = get_cli_abort_call()) { if (!is.character(ref) && !is.null(ref)) cli::cli_abort("{.arg ref} must be a string.") # get min version data ------------------------------------------------------- df_pkg_min_version <- get_min_version_required(pkg = pkg, ref = ref) # prompt user to install package --------------------------------------------- rlang::check_installed( pkg = df_pkg_min_version$pkg, version = df_pkg_min_version$version, compare = df_pkg_min_version$compare, call = call ) |> # this can be removed after this issue is resolved https://github.com/r-lib/rlang/issues/1694 suppressWarnings() } #' @inheritParams check_pkg_installed #' @keywords internal #' @noRd is_pkg_installed <- function(pkg, ref = utils::packageName()) { if (!is.character(ref) && !is.null(ref)) cli::cli_abort("{.arg ref} must be a string.") # get min version data ------------------------------------------------------- df_pkg_min_version <- get_min_version_required(pkg = pkg, ref = ref) # check installation TRUE/FALSE ---------------------------------------------- rlang::is_installed( pkg = df_pkg_min_version$pkg, version = df_pkg_min_version$version, compare = df_pkg_min_version$compare ) |> # this can be removed after this issue is resolved https://github.com/r-lib/rlang/issues/1694 suppressWarnings() } #' @inheritParams check_pkg_installed #' @keywords internal #' #' @param pkg (`string`)\cr #' name of the package the function will search for dependencies from. #' #' @noRd get_pkg_dependencies <- function(pkg = utils::packageName(), lib.loc = NULL) { if (!is.character(pkg) && !is.null(pkg)) cli::cli_abort("{.arg pkg} must be a string.") if (rlang::is_empty(pkg)) { return(.empty_pkg_deps_df()) } description <- utils::packageDescription(pkg, lib.loc = lib.loc) |> suppressWarnings() if (identical(description, NA)) { return(.empty_pkg_deps_df()) } description |> unclass() |> dplyr::as_tibble() |> dplyr::select( dplyr::any_of(c( "Package", "Version", "Imports", "Depends", "Suggests", "Enhances", "LinkingTo" )) ) |> dplyr::rename( reference_pkg = "Package", reference_pkg_version = "Version" ) |> tidyr::pivot_longer( -dplyr::all_of(c("reference_pkg", "reference_pkg_version")), values_to = "pkg", names_to = "dependency_type", ) |> tidyr::separate_rows("pkg", sep = ",") |> dplyr::mutate( pkg = trimws( x = gsub(x = .data$pkg, pattern = "\\s+", replacement = " "), which = "both", whitespace = "[ \t\r\n]" ) ) |> dplyr::filter(!is.na(.data$pkg)) |> tidyr::separate( .data$pkg, into = c("pkg", "version"), sep = " ", extra = "merge", fill = "right" ) |> dplyr::mutate( compare = as.character(ifelse(regexpr("[>=<]+", .data$version) > 0, regmatches(.data$version, regexpr("[>=<]+", .data$version)), NA)), version = gsub(pattern = "[\\(\\) >=<]", replacement = "", x = .data$version) ) } .empty_pkg_deps_df <- function() { dplyr::tibble( reference_pkg = character(0L), reference_pkg_version = character(0L), dependency_type = character(0L), pkg = character(0L), version = character(0L), compare = character(0L) ) } #' @inheritParams check_pkg_installed #' @keywords internal #' @noRd get_min_version_required <- function(pkg, ref = utils::packageName(), lib.loc = NULL) { if (!is.character(ref) && !is.null(ref)) cli::cli_abort("{.arg ref} must be a string.") # if no package reference, return a df with just the pkg names if (rlang::is_empty(ref)) { return( .empty_pkg_deps_df() |> dplyr::full_join( dplyr::tibble(pkg = pkg), by = "pkg" ) ) } # get the package_ref deps and subset on requested pkgs, also supplement df with pkgs # that may not be proper deps of the reference package (these pkgs don't have min versions) res <- get_pkg_dependencies(ref, lib.loc = lib.loc) |> dplyr::filter(.data$pkg %in% .env$pkg) |> dplyr::full_join( dplyr::tibble(pkg = pkg), by = "pkg" ) res } # nocov end # styler: on cards/R/import-standalone-stringr.R0000644000176200001440000001075714705533060017035 0ustar liggesusers# Standalone file: do not edit by hand # Source: # ---------------------------------------------------------------------- # # --- # repo: insightsengineering/standalone # file: standalone-stringr.R # last-updated: 2024-06-05 # license: https://unlicense.org # imports: rlang # --- # # This file provides a minimal shim to provide a stringr-like API on top of # base R functions. They are not drop-in replacements but allow a similar style # of programming. # # ## Changelog # # nocov start # styler: off str_trim <- function(string, side = c("both", "left", "right")) { side <- rlang::arg_match(side) trimws(x = string, which = side, whitespace = "[ \t\r\n]") } str_squish <- function(string, fixed = FALSE, perl = !fixed) { string <- gsub("\\s+", " ", string, perl = perl) # Replace multiple white spaces with a single white space string <- gsub("^\\s+|\\s+$", "", string, perl = perl) # Trim leading and trailing white spaces return(string) } str_remove <- function(string, pattern, fixed = FALSE, perl = !fixed) { sub(x = string, pattern = pattern, replacement = "", fixed = fixed, perl = perl) } str_remove_all <- function(string, pattern, fixed = FALSE, perl = !fixed) { gsub(x = string, pattern = pattern, replacement = "", fixed = fixed, perl = perl) } str_extract <- function(string, pattern, fixed = FALSE, perl = !fixed) { res <- rep(NA_character_, length.out = length(string)) res[str_detect(string, pattern, fixed = fixed)] <- regmatches(x = string, m = regexpr(pattern = pattern, text = string, fixed = fixed, perl = perl)) res } str_extract_all <- function(string, pattern, fixed = FALSE, perl = !fixed) { regmatches(x = string, m = gregexpr(pattern = pattern, text = string, fixed = fixed, perl = perl)) } str_detect <- function(string, pattern, fixed = FALSE, perl = !fixed) { grepl(pattern = pattern, x = string, fixed = fixed, perl = perl) } str_replace <- function(string, pattern, replacement, fixed = FALSE, perl = !fixed) { sub(x = string, pattern = pattern, replacement = replacement, fixed = fixed, perl = perl) } str_replace_all <- function(string, pattern, replacement, fixed = FALSE, perl = !fixed) { gsub(x = string, pattern = pattern, replacement = replacement, fixed = fixed, perl = perl) } word <- function(string, start, end = start, sep = " ", fixed = TRUE, perl = !fixed) { # Handle vectorized string input if (length(string) > 1) { return(sapply(string, word, start, end, sep, fixed, USE.NAMES = FALSE)) } words <- unlist(strsplit(string, split = sep, fixed = fixed, perl = perl)) words <- words[words != ""] # Remove empty strings # Adjust negative indices n <- length(words) if (start < 0) { start <- n + start + 1 } if (end < 0) { end <- n + end + 1 } # Validate indices if (start < 1 || end > n || start > end) { return(NA) } else { extracted_words <- words[start:end] return(paste(extracted_words, collapse = sep)) } } str_sub <- function(string, start = 1L, end = -1L) { str_length <- nchar(string) # Adjust start and end indices for negative values if (start < 0) { start <- str_length + start + 1 } if (end < 0) { end <- str_length + end + 1 } substr(x = string, start = start, stop = end) } str_sub_all <- function(string, start = 1L, end = -1L) { lapply(string, function(x) substr(x, start = start, stop = end)) } str_pad <- function(string, width, side = c("left", "right", "both"), pad = " ", use_width = TRUE) { side <- match.arg(side, c("left", "right", "both")) if (side == "both") { pad_left <- (width - nchar(string)) %/% 2 pad_right <- width - nchar(string) - pad_left padded_string <- paste0(strrep(pad, pad_left), string, strrep(pad, pad_right)) } else { format_string <- ifelse(side == "right", paste0("%-", width, "s"), ifelse(side == "left", paste0("%", width, "s"), paste0("%", width, "s"))) padded_string <- sprintf(format_string, string) } return(padded_string) } str_split <- function(string, pattern, n = Inf, fixed = FALSE, perl = !fixed) { if (n == Inf) { return(strsplit(string, split = pattern, fixed = fixed, perl = perl)) } else { parts <- strsplit(string, split = pattern, fixed = fixed, perl = perl) lapply(parts, function(x) { if (length(x) > n) { x <- c(x[1:(n - 1)], paste(x[n:length(x)], collapse = pattern)) } return(x) }) } } # nocov end # styler: on cards/R/ard_stack.R0000644000176200001440000001607414770605564013653 0ustar liggesusers#' Stack ARDs #' #' @description #' Stack multiple ARD calls sharing common input `data` and `by` variables. #' Optionally incorporate additional information on represented variables, e.g. #' overall calculations, rates of missingness, attributes, or transform results #' with `shuffle_ard()`. #' #' If the `ard_stack(by)` argument is specified, a univariate tabulation of the #' by variable will also be returned. #' #' @param data (`data.frame`)\cr #' a data frame #' @param .by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' columns to tabulate by in the series of ARD function calls. #' Any rows with `NA` or `NaN` values are removed from all calculations. #' @param ... ([`dynamic-dots`][rlang::dyn-dots])\cr #' Series of ARD function calls to be run and stacked #' @param .overall (`logical`)\cr logical indicating whether overall statistics #' should be calculated (i.e. re-run all `ard_*()` calls with `by=NULL`). #' Default is `FALSE`. #' @param .missing (`logical`)\cr #' logical indicating whether to include the results of `ard_missing()` for all #' variables represented in the ARD. Default is `FALSE`. #' @param .attributes (`logical`)\cr #' logical indicating whether to include the results of `ard_attributes()` for all #' variables represented in the ARD. Default is `FALSE`. #' @param .shuffle (`logical`)\cr #' logical indicating whether to perform `shuffle_ard()` on the final result. #' Default is `FALSE`. #' @param .total_n (`logical`)\cr #' logical indicating whether to include of `ard_total_n()` in the returned ARD. #' #' @return an ARD data frame of class 'card' #' @export #' #' @examples #' ard_stack( #' data = ADSL, #' ard_categorical(variables = "AGEGR1"), #' ard_continuous(variables = "AGE"), #' .by = "ARM", #' .overall = TRUE, #' .attributes = TRUE #' ) #' #' ard_stack( #' data = ADSL, #' ard_categorical(variables = "AGEGR1"), #' ard_continuous(variables = "AGE"), #' .by = "ARM", #' .shuffle = TRUE #' ) #' ard_stack <- function(data, ..., .by = NULL, .overall = FALSE, .missing = FALSE, .attributes = FALSE, .total_n = FALSE, .shuffle = FALSE) { set_cli_abort_call() # process arguments ---------------------------------------------------------- process_selectors(data, .by = {{ .by }}) # check inputs --------------------------------------------------------------- check_not_missing(data) check_data_frame(data) check_scalar_logical(.overall) check_scalar_logical(.missing) check_scalar_logical(.attributes) check_scalar_logical(.shuffle) check_scalar_logical(.total_n) if (is_empty(.by) && isTRUE(.overall)) { cli::cli_inform( c("The {.arg .by} argument should be specified when using {.code .overall=TRUE}.", i = "Setting {.code ard_stack(.overall=FALSE)}." ) ) .overall <- FALSE } # remove missing `.by` rows -------------------------------------------------- df_na_by <- is.na(data[.by]) | apply(data[.by], MARGIN = 2, is.nan) if (!is_empty(.by) && any(df_na_by)) { rows_with_na <- apply(df_na_by, MARGIN = 1, any) cli::cli_inform(c("*" = "Removing {.val {sum(rows_with_na)}} row{?s} with {.val {NA}} or {.val {NaN}} values in {.val {eval(.by)}} column{?s}.")) data <- data[!rows_with_na, ] } # evaluate the dots using common `data` and `by` ----------------------------- ard_list <- .eval_ard_calls(data, .by, ...) # add overall ---------------------------------------------------------------- if (isTRUE(.overall)) { ard_list <- c( ard_list, .eval_ard_calls(data, .by = character(0), ...) ) } # compute Ns by group / combine main calls ----------------------------------- if (!is_empty(by)) { ard_full <- bind_ard( ard_list, ard_categorical( data = data, variables = all_of(.by) ) ) } else { ard_full <- bind_ard(ard_list, .update = TRUE) } # get all variables represented ---------------------------------------------- variables <- unique(ard_full$variable) |> setdiff(.by) # missingness ---------------------------------------------------------------- if (isTRUE(.missing)) { ard_full <- bind_ard( ard_full, ard_missing(data = data, by = any_of(.by), variables = all_of(variables)) ) if (!is_empty(by) && isTRUE(.overall)) { ard_full <- bind_ard( ard_full, ard_missing(data = data, by = character(0L), variables = all_of(variables)) ) } } # attributes ----------------------------------------------------------------- if (isTRUE(.attributes)) { ard_full <- bind_ard( ard_full, ard_attributes(data, variables = all_of(c(variables, .by))) ) } # total n -------------------------------------------------------------------- if (isTRUE(.total_n)) { ard_full <- bind_ard( ard_full, ard_total_n(data) ) } # order ---------------------------------------------------------------------- ard_full <- tidy_ard_row_order(ard_full) # shuffle -------------------------------------------------------------------- if (isTRUE(.shuffle)) { return(shuffle_ard(ard_full)) } # return final ARD ----------------------------------------------------------- ard_full } #' Evaluate the `ard_*()` function calls #' #' @param data (`data.frame`)\cr #' a data frame #' @param .by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' columns to tabulate by in the series of ARD function calls #' @param ... ([`dynamic-dots`][rlang::dyn-dots])\cr #' Series of ARD function calls to be run and stacked #' #' @return list of ARD data frames of class 'card' #' @keywords internal #' #' @examples #' cards:::.eval_ard_calls( #' data = ADSL, #' .by = "ARM", #' ard_categorical(variables = "AGEGR1"), #' ard_continuous(variables = "AGE") #' ) .eval_ard_calls <- function(data, .by, ...) { # capture quosures ----------------------------------------------------------- dots <- enquos(...) # run the ARD calls ------------------------------------------------------- imap( dots, function(x, y) { if (!is_call_simple(x)) { if (identical(y, "by")) { cli::cli_abort( c("Cannot evaluate expression {.code {y} = {quo_squash(x)}}.", i = "Did you mean {.code .{y} = {quo_squash(x)}}?" ), call = get_cli_abort_call() ) } cli::cli_abort( "{.fun cards::ard_stack} works with {.help [simple calls](rlang::call_name)} and {.code {as_label(x)}} is not simple.", call = get_cli_abort_call() ) } x_ns <- call_ns(x) x_fn <- call_name(x) x_args <- call_args(x) # if a function was namespaced, then grab function from that pkg's Namespace # styler: off final_fn <- if (is.null(x_ns)) x_fn else get(x_fn, envir = asNamespace(x_ns)) # styler: on do.call(final_fn, c(list(data = data, by = .by), x_args), envir = attr(x, ".Environment")) } ) } cards/R/ard_continuous.R0000644000176200001440000003220514767676215014755 0ustar liggesusers#' Continuous ARD Statistics #' #' Compute Analysis Results Data (ARD) for simple continuous summary statistics. #' #' @param data (`data.frame`)\cr #' a data frame #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' columns to include in summaries. #' @param by,strata ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' columns to tabulate by/stratify by for summary statistic #' calculation. Arguments are similar, but with an important distinction: #' #' `by`: results are calculated for **all combinations** of the columns specified, #' including unobserved combinations and unobserved factor levels. #' #' `strata`: results are calculated for **all _observed_ combinations** of the #' columns specified. #' #' Arguments may be used in conjunction with one another. #' @param statistic ([`formula-list-selector`][syntax])\cr #' a named list, a list of formulas, #' or a single formula where the list element is a named list of functions #' (or the RHS of a formula), #' e.g. `list(mpg = list(mean = \(x) mean(x)))`. #' #' The value assigned to each variable must also be a named list, where the names #' are used to reference a function and the element is the function object. #' Typically, this function will return a scalar statistic, but a function that #' returns a named list of results is also acceptable, e.g. #' `list(conf.low = -1, conf.high = 1)`. However, when errors occur, the messaging #' will be less clear in this setting. #' @param fmt_fn ([`formula-list-selector`][syntax])\cr #' a named list, a list of formulas, #' or a single formula where the list element is a named list of functions #' (or the RHS of a formula), #' e.g. `list(mpg = list(mean = \(x) round(x, digits = 2) |> as.character()))`. #' @param stat_label ([`formula-list-selector`][syntax])\cr #' a named list, a list of formulas, or a single formula where #' the list element is either a named list or a list of formulas defining the #' statistic labels, e.g. `everything() ~ list(mean = "Mean", sd = "SD")` or #' `everything() ~ list(mean ~ "Mean", sd ~ "SD")`. #' @inheritParams rlang::args_dots_used #' #' @return an ARD data frame of class 'card' #' @name ard_continuous #' #' @examples #' ard_continuous(ADSL, by = "ARM", variables = "AGE") #' #' # if a single function returns a named list, the named #' # results will be placed in the resulting ARD #' ADSL |> #' dplyr::group_by(ARM) |> #' ard_continuous( #' variables = "AGE", #' statistic = #' ~ list(conf.int = \(x) t.test(x)[["conf.int"]] |> #' as.list() |> #' setNames(c("conf.low", "conf.high"))) #' ) NULL #' @rdname ard_continuous #' @export ard_continuous <- function(data, ...) { check_not_missing(data) UseMethod("ard_continuous") } #' @rdname ard_continuous #' @export ard_continuous.data.frame <- function(data, variables, by = dplyr::group_vars(data), strata = NULL, statistic = everything() ~ continuous_summary_fns(), fmt_fn = NULL, stat_label = everything() ~ default_stat_labels(), ...) { set_cli_abort_call() check_dots_used() # check inputs --------------------------------------------------------------- check_not_missing(variables) .check_no_ard_columns(data) # process arguments ---------------------------------------------------------- process_selectors(data, variables = {{ variables }}, by = {{ by }}, strata = {{ strata }} ) data <- dplyr::ungroup(data) process_formula_selectors( data[variables], statistic = statistic, fmt_fn = fmt_fn, stat_label = stat_label ) fill_formula_selectors( data[variables], statistic = formals(asNamespace("cards")[["ard_continuous.data.frame"]])[["stat_label"]] |> eval(), stat_label = formals(asNamespace("cards")[["ard_continuous.data.frame"]])[["stat_label"]] |> eval() ) check_list_elements( x = statistic, predicate = function(x) is.list(x) && is_named(x) && every(x, is.function), error_msg = c("Error in the argument {.arg {arg_name}} for variable {.val {variable}}.", "i" = "Value must be a named list of functions." ) ) # return empty ARD if no variables selected ---------------------------------- if (is_empty(variables)) { return(dplyr::tibble() |> as_card()) } # check factor levels -------------------------------------------------------- check_no_na_factor_levels(data[c(by, strata)]) check_factor_has_levels(data[c(by, strata)]) # calculate statistics ------------------------------------------------------- df_nested <- data |> nest_for_ard( by = by, strata = strata, key = "...ard_nested_data..." ) # calculate statistics indicated by user in statistics argument df_nested <- .calculate_stats_as_ard( df_nested = df_nested, variables = variables, statistic = statistic, new_col_name = "...ard_all_stats...", by = by, strata = strata, data = data ) # unnest results df_results <- df_nested |> dplyr::select(all_ard_groups(), "...ard_all_stats...") |> tidyr::unnest(cols = "...ard_all_stats...") # final processing of fmt_fn ------------------------------------------------- df_results <- .process_nested_list_as_df( x = df_results, arg = fmt_fn, new_column = "fmt_fn" ) |> .default_fmt_fn() # final processing of stat labels -------------------------------------------- df_results <- .process_nested_list_as_df( x = df_results, arg = stat_label, new_column = "stat_label", unlist = TRUE ) |> dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) # add meta data and class ---------------------------------------------------- df_results |> dplyr::mutate(context = "continuous") |> tidy_ard_column_order() |> tidy_ard_row_order() |> as_card() } #' Check Protected Column Names #' #' Checks that column names in a passed data frame are not protected, that is, #' they do not begin with `"...ard_"` and end with `"..."`. #' #' @param x (`data.frame`)\cr #' a data frame #' @param exceptions (`string`)\cr #' character string of column names to exclude from checks #' #' @return returns invisible if check is successful, throws an error message if not. #' @keywords internal #' #' @examples #' data <- data.frame("ard_x" = 1) #' #' cards:::.check_no_ard_columns(data) .check_no_ard_columns <- function(x, exceptions = "...ard_dummy_for_counting...") { colnames <- names(x) ard_colnames <- colnames[startsWith(colnames, "...ard_") & endsWith(colnames, "...")] |> setdiff(exceptions) if (!is_empty(ard_colnames)) { "Columns beginning with {.val '...ard_'} and ending with {.val '...'} are not allowed." |> cli::cli_abort(call = get_cli_abort_call()) } } #' Calculate Continuous Statistics #' #' Calculate statistics and return in an ARD format #' #' @param df_nested (`data.frame`)\cr #' a nested data frame #' @param variables (`character`)\cr #' character vector of variables #' @param statistic (named `list`)\cr #' named list of statistical functions #' #' @return an ARD data frame of class 'card' #' @keywords internal #' #' @examples #' data_nested <- ADSL |> #' nest_for_ard( #' by = "ARM", #' strata = NULL, #' key = "...ard_nested_data..." #' ) #' #' cards:::.calculate_stats_as_ard( #' df_nested = data_nested, #' variables = "AGE", #' statistic = list(mean = "mean"), #' by = "ARM", #' strata = NULL, #' data = ADSL #' ) .calculate_stats_as_ard <- function(df_nested, variables, statistic, by, strata, data, new_col_name = "...ard_all_stats...") { df_nested[[new_col_name]] <- map( df_nested[["...ard_nested_data..."]], function(nested_data) { map( variables, function(variable) { map2( statistic[[variable]], names(statistic[[variable]]), function(fun, fun_name) { .lst_results_as_df( x = # calculate results, and place in tibble eval_capture_conditions( getOption( "cards.calculate_stats_as_ard.eval_fun", default = expr(do.call(fun, args = list(stats::na.omit(nested_data[[variable]])))) ) ), variable = variable, fun_name = fun_name, fun = fun ) } ) |> unname() } ) |> dplyr::bind_rows() } ) df_nested } #' Prepare Results as Data Frame #' #' Function takes the results from [eval_capture_conditions()], which is a #' named list, e.g. `list(result=, warning=, error=)`, and converts it to a data #' frame. #' #' @param x (named `list`)\cr #' the result from [eval_capture_conditions()] #' @param variable (`string`)\cr #' variable name of the results #' @param fun_name (`string`)\cr #' name of function called to get results in `x` #' #' @return a data frame #' @keywords internal #' #' @examples #' msgs <- eval_capture_conditions({ #' warning("Warning 1") #' warning("Warning 2") #' letters[1:2] #' }) #' #' cards:::.lst_results_as_df(msgs, "result", "mean") .lst_results_as_df <- function(x, variable, fun_name, fun) { # unnesting results if needed if (.is_named_list(x$result, allow_df = TRUE)) { if (is.data.frame(x$result)) x$result <- unclass(x$result) df_ard <- dplyr::tibble( stat_name = names(x$result), result = unname(x$result), warning = list(x$warning), error = list(x$error) ) } # if result is not a nested list, return a single row tibble else { df_ard <- map(x, list) |> dplyr::as_tibble() |> dplyr::mutate( stat_name = # if the function is a "cards_fn" AND the result is missing, use the provided placeholder stat names case_switch( is_empty(.env$x$result) && is_cards_fn(.env$fun) ~ list(get_cards_fn_stat_names(.env$fun)), .default = .env$fun_name ) ) |> tidyr::unnest("stat_name") } df_ard |> dplyr::mutate(variable = .env$variable) |> dplyr::rename(stat = "result") } #' Convert Nested Lists to Column #' #' Some arguments, such as `stat_label`, are passed as nested lists. This #' function properly unnests these lists and adds them to the results data frame. #' #' @param x (`data.frame`)\cr #' result data frame #' @param arg (`list`)\cr #' the nested list #' @param new_column (`string`)\cr #' new column name #' @param unlist (`logical`)\cr #' whether to fully unlist final results #' #' @return a data frame #' @keywords internal #' #' @examples #' ard <- ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") #' #' cards:::.process_nested_list_as_df(ard, NULL, "new_col") .process_nested_list_as_df <- function(x, arg, new_column, unlist = FALSE) { # add fmt_fn column if not already present if (!new_column %in% names(x)) { x[[new_column]] <- list(NULL) } # process argument if not NULL, and update new column if (!is_empty(arg)) { df_argument <- imap( arg, function(enlst_arg, variable) { lst_stat_names <- x[c("variable", "stat_name")] |> dplyr::filter(.data$variable %in% .env$variable) |> unique() %>% {stats::setNames(as.list(.[["stat_name"]]), .[["stat_name"]])} # styler: off compute_formula_selector( data = lst_stat_names, x = enlst_arg ) %>% # styler: off {dplyr::tibble( variable = variable, stat_name = names(.), "{new_column}" := unname(.) )} # styler: on } ) |> dplyr::bind_rows() x <- x |> dplyr::rows_update(df_argument, by = c("variable", "stat_name"), unmatched = "ignore") } if (isTRUE(unlist)) { x[[new_column]] <- lapply(x[[new_column]], function(x) x %||% NA) |> unlist() } x } #' Add Default Formatting Functions #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' #' @return a data frame #' @keywords internal #' #' @examples #' ard <- ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") |> #' dplyr::mutate(fmt_fn = NA) #' #' cards:::.default_fmt_fn(ard) .default_fmt_fn <- function(x) { x |> dplyr::mutate( fmt_fn = pmap( list(.data$stat_name, .data$stat, .data$fmt_fn), function(stat_name, stat, fmt_fn) { if (!is_empty(fmt_fn)) { return(fmt_fn) } if (stat_name %in% c("p", "p_miss", "p_nonmiss")) { return(label_round(digits = 1, scale = 100)) } if (is.integer(stat)) { return(0L) } if (is.numeric(stat)) { return(1L) } return(as.character) } ) ) } cards/R/ard_stack_hierarchical.R0000644000176200001440000004322514776242611016343 0ustar liggesusers#' Stacked Hierarchical ARD Statistics #' #' @description #' Use these functions to calculate multiple summaries of nested or hierarchical data #' in a single call. #' #' - `ard_stack_hierarchical()`: Calculates *rates* of events (e.g. adverse events) #' utilizing the `denominator` and `id` arguments to identify the rows in `data` #' to include in each rate calculation. #' #' - `ard_stack_hierarchical_count()`: Calculates *counts* of events utilizing #' all rows for each tabulation. #' #' @section Subsetting Data for Rate Calculations: #' #' To calculate event rates, the `ard_stack_hierarchical()` function identifies #' rows to include in the calculation. #' First, the primary data frame is sorted by the columns identified in #' the `id`, `by`, and `variables` arguments. #' #' As the function cycles over the variables specified in the `variables` argument, #' the data frame is grouped by `id`, `intersect(by, names(denominator))`, and `variables` #' utilizing the last row within each of the groups. #' #' For example, if the call is #' `ard_stack_hierarchical(data = ADAE, variables = c(AESOC, AEDECOD), id = USUBJID)`, #' then we'd first subset ADAE to be one row within the grouping `c(USUBJID, AESOC, AEDECOD)` #' to calculate the event rates in `'AEDECOD'`. We'd then repeat and #' subset ADAE to be one row within the grouping `c(USUBJID, AESOC)` #' to calculate the event rates in `'AESOC'`. #' #' @section Overall Argument: #' When we set `overall=TRUE`, we wish to re-run our calculations removing the #' stratifying columns. For example, if we ran the code below, we results would #' include results with the code chunk being re-run with `by=NULL`. #' #' ```r #' ard_stack_hierarchical( #' data = ADAE, #' variables = c(AESOC, AEDECOD), #' by = TRTA, #' denominator = ADSL |> dplyr::rename(TRTA = ARM), #' overall = TRUE #' ) #' ``` #' #' But there is another case to be aware of: when the `by` argument includes #' columns that are not present in the `denominator`, for example when tabulating #' results by AE grade or severity in addition to treatment assignment. #' In the example below, we're tabulating results by treatment assignment and #' AE severity. By specifying `overall=TRUE`, we will re-run the to get #' results with `by = AESEV` and again with `by = NULL`. #' #' ```r #' ard_stack_hierarchical( #' data = ADAE, #' variables = c(AESOC, AEDECOD), #' by = c(TRTA, AESEV), #' denominator = ADSL |> dplyr::rename(TRTA = ARM), #' overall = TRUE #' ) #' ``` #' #' @inheritParams ard_hierarchical #' @inheritParams ard_stack #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' Specifies the nested/hierarchical structure of the data. #' The variables that are specified here and in the `include` argument #' will have summary statistics calculated. #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' argument used to subset `data` to identify rows in `data` to calculate #' event rates in `ard_stack_hierarchical()`. See details below. #' @param denominator (`data.frame`, `integer`)\cr #' used to define the denominator and enhance the output. #' The argument is required for `ard_stack_hierarchical()` and optional #' for `ard_stack_hierarchical_count()`. #' - the univariate tabulations of the `by` variables are calculated with `denominator`, #' when a data frame is passed, e.g. tabulation of the treatment assignment #' counts that may appear in the header of a table. #' - the `denominator` argument must be specified when `id` is used to #' calculate the event rates. #' - if `total_n=TRUE`, the `denominator` argument is used to return the total N #' @param include ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' Specify the subset a columns indicated in the `variables` argument for which #' summary statistics will be returned. Default is `everything()`. #' @param overall (scalar `logical`)\cr logical indicating whether overall statistics #' should be calculated (i.e. repeat the operations with `by=NULL` in _most cases_, see below for details). #' Default is `FALSE`. #' @param over_variables (scalar `logical`)\cr #' logical indicating whether summary statistics #' should be calculated over or across the columns listed in the `variables` argument. #' Default is `FALSE`. #' @param attributes (scalar `logical`)\cr #' logical indicating whether to include the results of `ard_attributes()` for all #' variables represented in the ARD. Default is `FALSE`. #' @param total_n (scalar `logical`)\cr #' logical indicating whether to include of `ard_total_n(denominator)` in the returned ARD. #' @param shuffle (scalar `logical`)\cr #' logical indicating whether to perform `shuffle_ard()` on the final result. #' Default is `FALSE`. #' #' @return an ARD data frame of class 'card' #' @name ard_stack_hierarchical #' #' @examples #' ard_stack_hierarchical( #' ADAE, #' variables = c(AESOC, AEDECOD), #' by = TRTA, #' denominator = ADSL |> dplyr::rename(TRTA = ARM), #' id = USUBJID #' ) #' #' ard_stack_hierarchical_count( #' ADAE, #' variables = c(AESOC, AEDECOD), #' by = TRTA, #' denominator = ADSL |> dplyr::rename(TRTA = ARM) #' ) NULL #' @rdname ard_stack_hierarchical #' @export ard_stack_hierarchical <- function(data, variables, by = dplyr::group_vars(data), id, denominator, include = everything(), statistic = everything() ~ c("n", "N", "p"), overall = FALSE, over_variables = FALSE, attributes = FALSE, total_n = FALSE, shuffle = FALSE) { set_cli_abort_call() # check inputs --------------------------------------------------------------- check_not_missing(variables) check_not_missing(id) check_not_missing(denominator) cards::process_selectors(data, id = {{ id }}) # denominator must a data frame, or integer if (!is.data.frame(denominator) && !is_integerish(denominator)) { cli::cli_abort( "The {.arg denominator} argument must be a {.cls data.frame} or an {.cls integer}, not {.obj_type_friendly {denominator}}.", call = get_cli_abort_call() ) } # check the id argument is not empty if (is_empty(id)) { cli::cli_abort("Argument {.arg id} cannot be empty.", call = get_cli_abort_call()) } # create ARD ----------------------------------------------------------------- internal_stack_hierarchical( data = data, variables = {{ variables }}, by = {{ by }}, id = {{ id }}, denominator = denominator, include = {{ include }}, statistic = statistic, overall = overall, over_variables = over_variables, attributes = attributes, total_n = total_n, shuffle = shuffle ) } #' @rdname ard_stack_hierarchical #' @export ard_stack_hierarchical_count <- function(data, variables, by = dplyr::group_vars(data), denominator = NULL, include = everything(), overall = FALSE, over_variables = FALSE, attributes = FALSE, total_n = FALSE, shuffle = FALSE) { set_cli_abort_call() # check inputs --------------------------------------------------------------- check_not_missing(variables) # denominator must be empty, a data frame, or integer if (!is_empty(denominator) && !is.data.frame(denominator) && !is_integerish(denominator)) { cli::cli_abort( "The {.arg denominator} argument must be empty, a {.cls data.frame}, or an {.cls integer}, not {.obj_type_friendly {denominator}}.", call = get_cli_abort_call() ) } # create ARD ----------------------------------------------------------------- internal_stack_hierarchical( data = data, variables = {{ variables }}, by = {{ by }}, id = NULL, denominator = denominator, include = {{ include }}, statistic = NULL, overall = overall, over_variables = over_variables, attributes = attributes, total_n = total_n, shuffle = shuffle ) } internal_stack_hierarchical <- function(data, variables, by = dplyr::group_vars(data), id = NULL, denominator = NULL, include = everything(), statistic = NULL, overall = FALSE, over_variables = FALSE, attributes = FALSE, total_n = FALSE, shuffle = FALSE, include_uni_by_tab = TRUE) { # process inputs ------------------------------------------------------------- check_not_missing(data) check_not_missing(variables) cards::process_selectors(data, variables = {{ variables }}, id = {{ id }}, by = {{ by }}) cards::process_selectors(data[variables], include = {{ include }}) check_scalar_logical(overall) check_scalar_logical(over_variables) check_scalar_logical(attributes) check_scalar_logical(total_n) check_scalar_logical(shuffle) # check inputs --------------------------------------------------------------- # both variables and include must be specified if (is_empty(variables) || is_empty(include)) { cli::cli_abort( "Arguments {.arg variables} and {.arg include} cannot be empty.", call = get_cli_abort_call() ) } # the last `variables` variable should be included if (!utils::tail(variables, 1L) %in% include) { cli::cli_abort( "The last column specified in the {.arg variables} (i.e. {.val {utils::tail(variables, 1L)}}) must be in the {.arg include} argument.", call = get_cli_abort_call() ) } if (is_empty(by) && isTRUE(overall)) { cli::cli_inform( c("The {.arg by} argument must be specified when using {.code overall=TRUE}.", i = "Setting {.code overall=FALSE}." ) ) overall <- FALSE } if (!is.data.frame(denominator) && isTRUE(overall)) { cli::cli_inform( c("The {.arg denominator} argument must be specified as a data frame when using {.code overall=TRUE}.", i = "Setting {.code overall=FALSE}." ) ) overall <- FALSE } if (is_empty(denominator) && isTRUE(total_n)) { cli::cli_inform( c("The {.arg denominator} argument must be specified when using {.code total_n=TRUE}.", i = "Setting {.code total_n=FALSE}." ) ) total_n <- FALSE } # drop missing values -------------------------------------------------------- df_na_nan <- is.na(data[c(by, variables)]) | apply(data[c(by, variables)], MARGIN = 2, is.nan) if (any(df_na_nan)) { rows_with_na <- apply(df_na_nan, MARGIN = 1, any) cli::cli_inform(c("*" = "Removing {.val {sum(rows_with_na)}} row{?s} from {.arg data} with {.val {NA}} or {.val {NaN}} values in {.val {c(by, variables)}} column{?s}.")) data <- data[!rows_with_na, ] } # remove missing by variables from `denominator` if (is.data.frame(denominator) && !is_empty(intersect(by, names(denominator)))) { df_na_nan_denom <- is.na(denominator[intersect(by, names(denominator))]) | apply(denominator[intersect(by, names(denominator))], MARGIN = 2, is.nan) if (any(df_na_nan_denom)) { rows_with_na_denom <- apply(df_na_nan_denom, MARGIN = 1, any) cli::cli_inform(c("*" = "Removing {.val {sum(rows_with_na_denom)}} row{?s} from {.arg denominator} with {.val {NA}} or {.val {NaN}} values in {.val {intersect(by, names(denominator))}} column{?s}.")) denominator <- denominator[!rows_with_na_denom, ] } } # sort data if using `ard_hierarchical(id)` ---------------------------------- if (!is_empty(id)) data <- dplyr::arrange(data, dplyr::pick(all_of(c(id, by, variables)))) # styler: off # print denom columns if not 100% clear which are used if (!is_empty(id) && is.data.frame(denominator)) { denom_cols <- intersect(by, names(denominator)) if (!setequal(by, denom_cols)) { msg <- ifelse( is_empty(denom_cols), "Denominator set by number of rows in {.arg denominator} data frame.", "Denominator set by {.val {denom_cols}} column{?s} in {.arg denominator} data frame." ) cli::cli_inform(c("i" = msg)) } } # go about calculating the statistics within the variables ------------------- # define index in `variables` that also appear in `include` which_include <- which(variables %in% include) lst_results <- list() for (i in which_include) { lst_results <- lst_results |> append( .run_hierarchical_fun( data = data, variables = variables[seq_len(i)], by = by, denominator = denominator, id = id, statistic = statistic ) |> list() ) } # calculate results overall if requested ------------------------------------- if (isTRUE(overall)) { for (i in which_include) { lst_results <- lst_results |> append( .run_hierarchical_fun( data = data, variables = variables[seq_len(i)], by = setdiff(by, names(denominator)), denominator = denominator, id = id, statistic = statistic ) |> list() ) # if there are columns in `by` not present in `denominator`, re-run with `by = NULL` if (!is_empty(setdiff(by, names(denominator)))) { lst_results <- lst_results |> append( .run_hierarchical_fun( data = data, variables = variables[seq_len(i)], by = NULL, denominator = denominator, id = id, statistic = statistic ) |> list() ) } } } # add univariate tabulations of by variables --------------------------------- if (isTRUE(include_uni_by_tab) && is.data.frame(denominator) && !is_empty(intersect(by, names(denominator)))) { lst_results <- lst_results |> append( ard_categorical( data = denominator, variables = all_of(intersect(by, names(denominator))) ) |> list() ) } # add overall row if requested ----------------------------------------------- if (isTRUE(over_variables)) { lst_results <- lst_results |> append( # need to use this call to also re-run for `overall=TRUE` when specified rlang::call2( "internal_stack_hierarchical", data = expr(data |> dplyr::mutate(..ard_hierarchical_overall.. = TRUE)), variables = "..ard_hierarchical_overall..", by = by, id = id, include = "..ard_hierarchical_overall..", denominator = expr(denominator), statistic = statistic, overall = overall, over_variables = FALSE, attributes = FALSE, total_n = FALSE, shuffle = FALSE, include_uni_by_tab = FALSE ) %>% {suppressMessages(eval_tidy(.))} |> # styler: off list() ) } # add attributes if requested ------------------------------------------------ if (isTRUE(attributes)) { lst_results <- lst_results |> append( ard_attributes(dplyr::select(data, any_of(c(by, variables)))) |> list() ) } # add total n if requested --------------------------------------------------- if (isTRUE(total_n) && is.data.frame(denominator)) { lst_results <- lst_results |> append(ard_total_n(denominator) |> list()) } else if (isTRUE(total_n) && is_integerish(denominator)) { lst_results <- lst_results |> append( ard_total_n(data) |> dplyr::mutate(stat = list(as.integer(denominator))) |> list() ) } # combine results ------------------------------------------------------------ result <- lst_results |> dplyr::bind_rows() |> cards::tidy_ard_column_order() |> cards::tidy_ard_row_order() # shuffle if requested ------------------------------------------------------- if (isTRUE(shuffle)) { result <- shuffle_ard(result) } # append attributes used for sorting/filtering ------------------------------- attr(result, "args") <- list(by = by, variables = variables, include = include) # sort ARD alphanumerically -------------------------------------------------- result <- result |> sort_ard_hierarchical(sort = "alphanumeric") # return final result -------------------------------------------------------- result |> as_card() } # this function calculates either the counts or the rates of the events .run_hierarchical_fun <- function(data, variables, by, denominator, id, statistic) { if (is_empty(id)) { ard_hierarchical_count( data = data, variables = all_of(variables), by = all_of(by) ) } else { ard_hierarchical( data = data |> dplyr::slice_tail(n = 1L, by = all_of(c(id, intersect(by, names(denominator)), variables))), variables = all_of(variables), by = all_of(by), denominator = denominator, id = all_of(id), statistic = statistic ) } } cards/R/ard_attributes.R0000644000176200001440000000665214746733642014737 0ustar liggesusers#' ARD Attributes #' #' @description #' Add variable attributes to an ARD data frame. #' - The `label` attribute will be added for all columns, and when no label #' is specified and no label has been set for a column using the `label=` argument, #' the column name will be placed in the label statistic. #' - The `class` attribute will also be returned for all columns. #' - Any other attribute returned by `attributes()` will also be added, e.g. factor levels. #' #' @rdname ard_attributes #' @param data (`data.frame`)\cr #' a data frame #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' variables to include #' @param label (named `list`)\cr #' named list of variable labels, e.g. `list(cyl = "No. Cylinders")`. #' Default is `NULL` #' @inheritParams rlang::args_dots_empty #' #' @return an ARD data frame of class 'card' #' @name ard_attributes #' #' @examples #' df <- dplyr::tibble(var1 = letters, var2 = LETTERS) #' attr(df$var1, "label") <- "Lowercase Letters" #' #' ard_attributes(df, variables = everything()) NULL #' @rdname ard_attributes #' @export ard_attributes <- function(data, ...) { UseMethod("ard_attributes") } #' @rdname ard_attributes #' @export ard_attributes.data.frame <- function(data, variables = everything(), label = NULL, ...) { set_cli_abort_call() check_dots_used() # check inputs --------------------------------------------------------------- check_not_missing(data) check_not_missing(variables) check_dots_empty() # process arguments ---------------------------------------------------------- data <- dplyr::ungroup(data) process_selectors(data, variables = {{ variables }}) # return empty ARD if no variables selected ---------------------------------- if (is_empty(variables)) { return(dplyr::tibble() |> as_card()) } # check label is a named list ------------------------------------------------ if (!is_empty(label)) { if (!is.list(label) || !is_named(label) || some(label, \(x) !is_string(x))) { cli::cli_abort( "The {.arg label} argument must be a named list with each element a string.", call = get_cli_abort_call() ) } } variables |> lapply( FUN = function(y) { attr <- attributes(data[[y]]) # add/update variable label attr[["label"]] <- label[[y]] %||% attr[["label"]] %||% y # attributes() doesn't always return class, adding it if not already present attr[["class"]] <- attr[["class"]] %||% class(data[[y]]) dplyr::tibble( variable = .env$y, stat_name = names(attr), stat = unname(attr) ) } ) |> dplyr::bind_rows() |> dplyr::mutate( stat_label = dplyr::case_when( .data$stat_name %in% "label" ~ "Variable Label", .data$stat_name %in% "class" ~ "Variable Class", TRUE ~ .data$stat_name ), context = "attributes", fmt_fn = ifelse(.data$stat_name %in% "label", list(as.character), list(NULL)), warning = list(NULL), error = list(NULL) ) |> cards::tidy_ard_column_order() |> tidy_ard_row_order() |> as_card() } #' @rdname ard_attributes #' @export ard_attributes.default <- function(data, ...) { set_cli_abort_call() cli::cli_abort("There is no method for objects of class {.cls {class(data)}}.", call = get_cli_abort_call()) } cards/R/import-standalone-cli_call_env.R0000644000176200001440000000316614705533060017753 0ustar liggesusers# Standalone file: do not edit by hand # Source: # ---------------------------------------------------------------------- # # --- # repo: insightsengineering/standalone # file: standalone-cli_call_env.R # last-updated: 2024-04-10 # license: https://unlicense.org # imports: [rlang, cli] # --- # # This file provides functions to set and access the call environment to use in cli::cli_abort() in check functions. # # ## Changelog # nocov start # styler: off #' Set Call Environment for [cli::cli_abort()] #' #' Set a call environment to be used as the `call` parameter in [cli::cli_abort()] for package checks. This function #' is used to ensure that the correct user-facing function is reported for errors generated by internal checks that #' use [cli::cli_abort()]. #' #' @param env (`enviroment`)\cr #' call environment used as the `call` parameter in [cli::cli_abort()] for package checks #' #' @seealso [get_cli_abort_call()] #' #' @keywords internal #' @noRd set_cli_abort_call <- function(env = rlang::caller_env()) { if (getOption("cli_abort_call") |> is.null()) { options(cli_abort_call = env) set_call <- as.call(list(function() options(cli_abort_call = NULL))) do.call(on.exit, list(expr = set_call, add = TRUE, after = FALSE), envir = env) } invisible() } #' Get Call Environment for [cli::cli_abort()] #' #' @inheritParams set_cli_abort_call #' @seealso [set_cli_abort_call()] #' #' @keywords internal #' @noRd get_cli_abort_call <- function() { getOption("cli_abort_call", default = parent.frame()) } # nocov end # styler: on cards/R/default_stat_labels.R0000644000176200001440000000115014746733642015710 0ustar liggesusers#' Defaults for Statistical Arguments #' #' Returns a named list of statistics labels #' #' @return named list #' @export #' #' @examples #' # stat labels #' default_stat_labels() default_stat_labels <- function() { list( mean = "Mean", sd = "SD", var = "Variance", median = "Median", p25 = "Q1", p75 = "Q3", min = "Min", max = "Max", n = "n", N = "N", p = "%", n_cum = "Cumulative n", p_cum = "Cumulative %", N_obs = "Vector Length", N_miss = "N Missing", N_nonmiss = "N Non-missing", p_miss = "% Missing", p_nonmiss = "% Non-missing" ) } cards/R/data.R0000644000176200001440000000035214567176413012621 0ustar liggesusers#' Example ADaM Data #' #' Data frame imported from the [CDISC SDTM/ADaM Pilot Project](https://github.com/cdisc-org/sdtm-adam-pilot-project) #' @name adam #' @keywords datasets "ADSL" #' @rdname adam "ADAE" #' @rdname adam "ADTTE" cards/R/filter_ard_hierarchical.R0000644000176200001440000002211614767020056016514 0ustar liggesusers#' Filter Stacked Hierarchical ARDs #' #' @description `r lifecycle::badge('experimental')`\cr #' #' This function is used to filter stacked hierarchical ARDs. #' #' For the purposes of this function, we define a "variable group" as a combination of ARD rows #' grouped by the combination of all their variable levels, but excluding any `by` variables. #' #' @param x (`card`)\cr #' a stacked hierarchical ARD of class `'card'` created using [`ard_stack_hierarchical()`] or #' [`ard_stack_hierarchical_count()`]. #' @param filter (`expression`)\cr #' an expression that is used to filter variable groups of the hierarchical ARD. See the #' Details section below. #' @param keep_empty (scalar `logical`)\cr #' Logical argument indicating whether to retain summary rows corresponding to hierarchy #' sections that have had all rows filtered out. Default is `FALSE`. #' #' @details #' The `filter` argument can be used to filter out variable groups of a hierarchical #' ARD which do not meet the requirements provided as an expression. #' Variable groups can be filtered on the values of any of the possible #' statistics (`n`, `p`, and `N`) provided they are included at least once #' in the ARD, as well as the values of any `by` variables. #' #' To illustrate how the function works, consider the typical example below #' where the AE summaries are provided by treatment group. #' #' ```r #' ADAE |> #' dplyr::filter(AESOC == "GASTROINTESTINAL DISORDERS", #' AEDECOD %in% c("VOMITING", "DIARRHOEA")) |> #' ard_stack_hierarchical( #' variables = c(AESOC, AEDECOD), #' by = TRTA, #' denominator = ADSL |> dplyr::rename(TRTA = ARM), #' id = USUBJID #' ) #' ``` #' #' |**SOC** / AE | Placebo | Xanomeline High Dose | Xanomeline Low Dose | #' |:------------------------------|----------:|----------------------:|---------------------:| #' |__GASTROINTESTINAL DISORDERS__ | 11 (13%) | 10 (12%) | 8 (9.5%) | #' |DIARRHOEA | 9 (10%) | 4 (4.8%) | 5 (6.0%) | #' |VOMITING | 3 (3.5%) | 7 (8.3%) | 3 (3.6%) | #' #' Filters are applied to the summary statistics of the innermost variable in the hierarchy---`AEDECOD` #' in this case. #' If any of the summary statistics meet the filter requirement for any of the treatment groups, #' the entire row is retained. #' For example, if `filter = n >= 9` were passed, the criteria would be met for DIARRHOEA #' as the Placebo group observed 9 AEs and as a result the summary statistics for the other #' treatment groups would be retained as well. #' Conversely, no treatment groups' summary statistics satisfy the filter requirement #' for VOMITING so all rows associated with this AE would be removed. #' #' In addition to filtering on individual statistic values, filters can be applied #' across the treatment groups (i.e. across all `by` variable values) by using #' aggregate functions such as `sum()` and `mean()`. #' A value of `filter = sum(n) >= 18` retains AEs where the sum of the number #' of AEs across the treatment groups is greater than or equal to 18. #' #' If `ard_stack_hierarchical(overall=TRUE)` was run, the overall column is #' __not__ considered in any filtering. #' #' If `ard_stack_hierarchical(over_variables=TRUE)` was run, any overall statistics are kept regardless #' of filtering. #' #' Some examples of possible filters: #' - `filter = n > 5`: keep AEs where one of the treatment groups observed more than 5 AEs #' - `filter = n == 2 & p < 0.05`: keep AEs where one of the treatment groups observed exactly 2 #' AEs _and_ one of the treatment groups observed a proportion less than 5% #' - `filter = sum(n) >= 4`: keep AEs where there were 4 or more AEs observed across the treatment groups #' - `filter = mean(n) > 4 | n > 3`: keep AEs where the mean number of AEs is 4 or more across the #' treatment groups _or_ one of the treatment groups observed more than 3 AEs #' - `filter = any(n > 2 & TRTA == "Xanomeline High Dose")`: keep AEs where the #' `"Xanomeline High Dose"` treatment group observed more than 2 AEs #' #' #' @return an ARD data frame of class 'card' #' @seealso [sort_ard_hierarchical()] #' @name filter_ard_hierarchical #' #' @examplesIf (identical(Sys.getenv("NOT_CRAN"), "true") || identical(Sys.getenv("IN_PKGDOWN"), "true")) #' # create a base AE ARD #' ard <- ard_stack_hierarchical( #' ADAE, #' variables = c(AESOC, AEDECOD), #' by = TRTA, #' denominator = ADSL |> dplyr::rename(TRTA = ARM), #' id = USUBJID #' ) #' #' # Example 1 ---------------------------------- #' # Keep AEs from TRTA groups where more than 3 AEs are observed across the group #' filter_ard_hierarchical(ard, sum(n) > 3) #' #' # Example 2 ---------------------------------- #' # Keep AEs where at least one level in the TRTA group has more than 3 AEs observed #' filter_ard_hierarchical(ard, n > 3) #' #' # Example 3 ---------------------------------- #' # Keep AEs that have an overall prevalence of greater than 5% #' filter_ard_hierarchical(ard, sum(n) / sum(N) > 0.05) NULL #' @rdname filter_ard_hierarchical #' @export filter_ard_hierarchical <- function(x, filter, keep_empty = FALSE) { set_cli_abort_call() # check and process inputs --------------------------------------------------------------------- check_not_missing(x) check_not_missing(filter) check_scalar_logical(keep_empty) check_class(x, "card") if (!"args" %in% names(attributes(x))) { cli::cli_abort( paste( "Filtering is only available for stacked hierarchical ARDs created using", "{.fun ard_stack_hierarchical} or {.fun ard_stack_hierarchical_count}." ), call = get_cli_abort_call() ) } ard_args <- attributes(x)$args filter <- enquo(filter) if (!quo_is_call(filter)) { cli::cli_abort( "The {.arg filter} argument must be an expression.", call = get_cli_abort_call() ) } by_cols <- if (length(ard_args$by) > 0) paste0("group", seq_along(ard_args$by), c("", "_level")) else NULL if (!all(all.vars(filter) %in% c(x$stat_name, ard_args$by))) { var_miss <- setdiff(all.vars(filter), c(x$stat_name, ard_args$by)) cli::cli_abort( paste( "The expression provided as {.arg filter} includes condition{?s} for statistic{?s} or `by` variable{?s}", "{.val {var_miss}} which {?is/are} not present in the ARD." ), call = get_cli_abort_call() ) } # ignore "overall" data is_overall <- apply(x, 1, function(x) !isTRUE(any(x %in% ard_args$by))) if (length(ard_args$by) > 0 && sum(is_overall) > 0) { x <- x[!is_overall, ] } # reshape ARD so each stat is in its own column ------------------------------------------------ x_f <- x |> dplyr::mutate(idx = dplyr::row_number()) |> dplyr::select(all_ard_groups(), all_ard_variables(), "stat_name", "stat", "idx") |> tidyr::pivot_wider( id_cols = c(all_ard_groups(), all_ard_variables()), names_from = "stat_name", values_from = "stat", values_fn = unlist, unused_fn = list ) # apply filter --------------------------------------------------------------------------------- f_idx <- x_f |> dplyr::group_by(across(c(all_ard_groups(), all_ard_variables(), -all_of(by_cols)))) |> dplyr::group_map(\(.df, .g) { # allow filtering on `by` variable levels if (length(ard_args$by) > 0) names(.df)[names(.df) == by_cols[c(FALSE, TRUE)]] <- ard_args$by # only filter rows for innermost variable if (.g$variable == dplyr::last(attributes(x)$args$variables)) { .df[["idx"]][eval_tidy(filter, data = .df)] } else { .df[["idx"]] } }) |> unlist() |> sort() x <- x[f_idx, ] # remove summary rows from empty sections if requested if (!keep_empty && length(ard_args$include) > 1) { outer_cols <- ard_args$variables |> utils::head(-1) # if all rows filtered out remove all summary rows - only overall/header rows left if (!dplyr::last(ard_args$variables) %in% x$variable) { x <- x |> dplyr::filter(!.data$variable %in% outer_cols) } else { names(outer_cols) <- x |> dplyr::select(all_ard_groups("names"), -all_of(by_cols)) |> names() x_no_sum <- x |> dplyr::mutate(idx = dplyr::row_number()) |> .ard_reformat_sort("no_sort", ard_args$by, outer_cols) # check if each hierarchy section (from innermost to outermost) is empty and if so remove its summary row for (i in rev(seq_along(outer_cols))) { x_no_sum <- x_no_sum |> dplyr::group_by(across(c(all_ard_group_n((length(ard_args$by):i) + 1), -all_of(by_cols)))) |> dplyr::group_map( function(.df, .y) { cur_var <- .y[[ncol(.y) - 1]] if (cur_var == "..empty..") { .df } else { inner_rows <- .df |> dplyr::filter(.data$variable != cur_var) if (nrow(inner_rows) > 0) .df else NULL } }, .keep = TRUE ) |> dplyr::bind_rows() } idx_no_sum <- sort(x_no_sum$idx) x <- x[idx_no_sum, ] } } x } cards/R/ard_complex.R0000644000176200001440000001073714763462404014211 0ustar liggesusers#' Complex ARD Summaries #' #' Function is similar to [ard_continuous()], but allows for more complex #' summaries. While `ard_continuous(statistic)` only allows for a univariable #' function, `ard_complex(statistic)` can handle more complex data summaries. #' #' @inheritParams ard_continuous #' @param statistic ([`formula-list-selector`][syntax])\cr #' The form of the statistics argument is identical to `ard_continuous(statistic)` #' argument, except the summary function _must_ accept the following arguments: #' - `x`: a vector #' - `data`: the data frame that has been subset such that the `by`/`strata` columns #' and rows in which `"variable"` is `NA` have been removed. #' - `full_data`: the full data frame #' - `by`: character vector of the `by` variables #' - `strata`: character vector of the `strata` variables #' It is unlikely any one function will need _all_ of the above elements, #' and it's recommended the function passed accepts `...` so that any unused #' arguments will be properly ignored. The `...` also allows this function #' to perhaps be updated in the future with more passed arguments. For example, #' if one needs a second variable from the data frame, the function inputs #' may look like: `foo(x, data, ...)` #' #' @return an ARD data frame of class 'card' #' @name ard_complex #' #' @examples #' # example how to mimic behavior of `ard_continuous()` #' ard_complex( #' ADSL, #' by = "ARM", #' variables = "AGE", #' statistic = list(AGE = list(mean = \(x, ...) mean(x))) #' ) #' #' # return the grand mean and the mean within the `by` group #' grand_mean <- function(data, full_data, variable, ...) { #' list( #' mean = mean(data[[variable]], na.rm = TRUE), #' grand_mean = mean(full_data[[variable]], na.rm = TRUE) #' ) #' } #' #' ADSL |> #' dplyr::group_by(ARM) |> #' ard_complex( #' variables = "AGE", #' statistic = list(AGE = list(means = grand_mean)) #' ) NULL #' @rdname ard_complex #' @export ard_complex <- function(data, ...) { check_not_missing(data) UseMethod("ard_complex") } #' @rdname ard_complex #' @export ard_complex.data.frame <- function(data, variables, by = dplyr::group_vars(data), strata = NULL, statistic, fmt_fn = NULL, stat_label = everything() ~ default_stat_labels(), ...) { set_cli_abort_call() check_dots_used() # check inputs --------------------------------------------------------------- check_not_missing(variables) check_not_missing(statistic) # process inputs ------------------------------------------------------------- process_selectors(data, variables = {{ variables }}) process_formula_selectors(data[variables], statistic = statistic, allow_empty = FALSE) # return empty ARD if no variables selected ---------------------------------- if (is_empty(variables)) { return(dplyr::tibble() |> as_card()) } missing_statistics_vars <- setdiff(variables, names(statistic)) if (!is_empty(missing_statistics_vars)) { "The following columns do not have {.arg statistic} defined: {.val {missing_statistics_vars}}." |> cli::cli_abort(call = get_cli_abort_call()) } # calculate statistics ------------------------------------------------------- # first set an option to be used internally within `ard_continuous()` # to calculate the statistics and pass multiple arguments to the # user-supplied functions in the `statistics` argument old_option <- getOption("cards.calculate_stats_as_ard.eval_fun") on.exit(options(cards.calculate_stats_as_ard.eval_fun = old_option), add = TRUE) options( cards.calculate_stats_as_ard.eval_fun = # putting the expr in quotes to avoid note about global variables "do.call(fun, args = list(x = stats::na.omit(nested_data[[variable]]), data = tidyr::drop_na(nested_data, any_of(variable)), full_data = data, variable = variable, by = by, strata = strata))" |> parse_expr() ) ard_continuous( data = data, variables = all_of(variables), by = {{ by }}, strata = {{ strata }}, statistic = statistic, fmt_fn = fmt_fn, stat_label = stat_label ) |> dplyr::mutate(context = "complex") } cards/R/cards-package.R0000644000176200001440000000043414776253240014372 0ustar liggesusers#' @keywords internal #' @import rlang #' @importFrom dplyr across "_PACKAGE" ## usethis namespace: start ## usethis namespace: end NULL utils::globalVariables(c(".", "!<-", "parse_expr<-")) release_bullets <- function() { c("Install package and re-build `pkgdown/index.Rmd`") } cards/R/tidy_as_ard.R0000644000176200001440000001057714761460732014200 0ustar liggesusers#' Build ARD from Tidier #' #' @description #' `r lifecycle::badge("questioning")`\cr #' *Function is questioning because we think a better solution may be `ard_continuous()` + `ard_formals()`.* #' #' Function converts a model's one-row tidy data frame into an ARD structure. #' The tidied data frame must have been constructed with #' [eval_capture_conditions()]. #' #' This function is primarily for developers and few consistency checks have #' been included. #' #' @param lst_tidy (named `list`)\cr #' list of tidied results constructed with [eval_capture_conditions()], #' e.g. `eval_capture_conditions(t.test(mtcars$mpg ~ mtcars$am) |> broom::tidy())`. #' @param tidy_result_names (`character`)\cr #' character vector of column names expected by the #' tidier method. This is used to construct blank results in the event of an error. #' @param fun_args_to_record (`character`)\cr #' character vector of function argument names that are added to the ARD. #' @param formals (`pairlist`)\cr #' the results from `formals()`, e.g. `formals(fisher.test)`. #' This is used to get the default argument values from unspecified arguments. #' @param passed_args (named `list`)\cr #' named list of additional arguments passed to the modeling function. #' @param lst_ard_columns (named `list`)\cr #' named list of values that will be added to the ARD data frame. #' #' @return an ARD data frame of class 'card' #' @export #' @keywords internal #' #' @examples #' # example how one may create a fisher.test() ARD function #' my_ard_fishertest <- function(data, by, variable, ...) { #' # perform fisher test and format results ----------------------------------- #' lst_tidy_fisher <- #' eval_capture_conditions( #' # this manipulation is similar to `fisher.test(...) |> broom::tidy()` #' stats::fisher.test(x = data[[variable]], y = data[[by]], ...)[c("p.value", "method")] |> #' as.data.frame() #' ) #' #' # build ARD ------------------------------------------------------------------ #' tidy_as_ard( #' lst_tidy = lst_tidy_fisher, #' tidy_result_names = c("p.value", "method"), #' fun_args_to_record = #' c( #' "workspace", "hybrid", "hybridPars", "control", "or", #' "conf.int", "conf.level", "simulate.p.value", "B" #' ), #' formals = formals(stats::fisher.test), #' passed_args = dots_list(...), #' lst_ard_columns = list(group1 = by, variable = variable, context = "fishertest") #' ) #' } #' #' my_ard_fishertest(mtcars, by = "am", variable = "vs") tidy_as_ard <- function(lst_tidy, tidy_result_names, fun_args_to_record = character(0L), formals = list(), passed_args = list(), lst_ard_columns) { set_cli_abort_call() # used argument values ------------------------------------------------------- lst_used_fun_args <- tryCatch( utils::modifyList( x = # missing() is TRUE if the arg is not specified, # not actually missing (ie it can still have its default value) if (missing(formals)) formals else formals[fun_args_to_record], val = passed_args, keep.null = TRUE ), error = function(e) list() ) # if there are results, put them in the ARD format --------------------------- if (!is.null(lst_tidy[["result"]])) { # combine results and function argument lst_all_results <- c(unclass(lst_tidy[["result"]]), lst_used_fun_args) } # if there was an error calculating results, tidy up what we can ------------- else { # combine empty results and function arguments lst_all_results <- utils::modifyList( x = rep_len( x = list(NULL), length.out = length(c(tidy_result_names, fun_args_to_record)) ) |> stats::setNames(nm = c(tidy_result_names, fun_args_to_record)), val = lst_used_fun_args, keep.null = TRUE ) } # add results to tibble ------------------------------------------------------ dplyr::tibble( stat_name = names(lst_all_results), stat = lst_all_results, fmt_fn = lapply(.data$stat, function(x) { switch(is.numeric(x), 1L ) }), warning = lst_tidy["warning"], error = lst_tidy["error"], !!!lst_ard_columns, ) |> tidy_ard_column_order() |> tidy_ard_row_order() |> as_card() } cards/R/reexports.R0000644000176200001440000000145414567176413013747 0ustar liggesusers# dplyr ------------------------------------------------------------------------ #' @export #' @importFrom dplyr %>% dplyr::`%>%` #' @importFrom dplyr starts_with #' @export dplyr::starts_with #' @importFrom dplyr ends_with #' @export dplyr::ends_with #' @importFrom dplyr contains #' @export dplyr::contains #' @importFrom dplyr matches #' @export dplyr::matches #' @importFrom dplyr num_range #' @export dplyr::num_range #' @importFrom dplyr all_of #' @export dplyr::all_of #' @importFrom dplyr any_of #' @export dplyr::any_of #' @importFrom dplyr everything #' @export dplyr::everything #' @importFrom dplyr where #' @export dplyr::where #' @importFrom dplyr last_col #' @export dplyr::last_col #' @importFrom dplyr one_of #' @export dplyr::one_of #' @importFrom dplyr vars #' @export dplyr::vars cards/R/ard_categorical.R0000644000176200001440000006007714754213320015010 0ustar liggesusers#' Categorical ARD Statistics #' #' Compute Analysis Results Data (ARD) for categorical summary statistics. #' #' @param data (`data.frame`)\cr #' a data frame #' @param by,strata ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' columns to use for grouping or stratifying the table output. #' Arguments are similar, but with an important distinction: #' #' `by`: results are tabulated by **all combinations** of the columns specified, #' including unobserved combinations and unobserved factor levels. #' #' `strata`: results are tabulated by **all _observed_ combinations** of the #' columns specified. #' #' Arguments may be used in conjunction with one another. #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' columns to include in summaries. Default is `everything()`. #' @param denominator (`string`, `data.frame`, `integer`)\cr #' Specify this argument to change the denominator, #' e.g. the `"N"` statistic. Default is `'column'`. See below for details. #' @param statistic ([`formula-list-selector`][syntax])\cr #' a named list, a list of formulas, #' or a single formula where the list element one or more of `c("n", "N", "p", "n_cum", "p_cum")` #' (on the RHS of a formula). #' @param stat_label ([`formula-list-selector`][syntax])\cr #' a named list, a list of formulas, or a single formula where #' the list element is either a named list or a list of formulas defining the #' statistic labels, e.g. `everything() ~ list(n = "n", p = "pct")` or #' `everything() ~ list(n ~ "n", p ~ "pct")`. #' @inheritParams ard_continuous #' #' @section Denominators: #' By default, the `ard_categorical()` function returns the statistics `"n"`, `"N"`, and #' `"p"`, where little `"n"` are the counts for the variable levels, and big `"N"` is #' the number of non-missing observations. The default calculation for the #' percentage is merely `p = n/N`. #' #' However, it is sometimes necessary to provide a different `"N"` to use #' as the denominator in this calculation. For example, in a calculation #' of the rates of various observed adverse events, you may need to update the #' denominator to the number of enrolled subjects. #' #' In such cases, use the `denominator` argument to specify a new definition #' of `"N"`, and subsequently `"p"`. #' The argument expects one of the following inputs: #' - a string: one of `"column"`, `"row"`, or `"cell"`. #' - `"column"`, the default, returns percentages where the sum is equal to #' one within the variable after the data frame has been subset with `by`/`strata`. #' - `"row"` gives 'row' percentages where `by`/`strata` columns are the 'top' #' of a cross table, and the variables are the rows. This is well-defined #' for a single `by` or `strata` variable, and care must be taken when there #' are more to ensure the the results are as you expect. #' - `"cell"` gives percentages where the denominator is the number of non-missing #' rows in the source data frame. #' - a data frame. Any columns in the data frame that overlap with the `by`/`strata` #' columns will be used to calculate the new `"N"`. #' - an integer. This single integer will be used as the new `"N"` #' - a structured data frame. The data frame will include columns from `by`/`strata`. #' The last column must be named `"...ard_N..."`. The integers in this column will #' be used as the updated `"N"` in the calculations. #' #' Lastly, when the `p` statistic is returned, the proportion is returned---bounded by `[0, 1]`. #' However, the default function to format the statistic scales the proportion by 100 #' and the percentage is returned which matches the default statistic label of `'%'`. #' To get the formatted values, pass the ARD to `apply_fmt_fn()`. #' #' @section Other Statistics: #' In some cases, you may need other kinds of statistics for categorical variables. #' Despite the name, `ard_continuous()` can be used to obtain these statistics. #' #' In the example below, we calculate the mode of a categorical variable. #' #' ```{r} #' get_mode <- function(x) { #' table(x) |> sort(decreasing = TRUE) |> names() |> getElement(1L) #' } #' #' ADSL |> #' ard_continuous( #' variables = AGEGR1, #' statistic = list(AGEGR1 = list(mode = get_mode)) #' ) #' ``` #' #' #' @return an ARD data frame of class 'card' #' @name ard_categorical #' #' @examples #' ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") #' #' ADSL |> #' dplyr::group_by(ARM) |> #' ard_categorical( #' variables = "AGEGR1", #' statistic = everything() ~ "n" #' ) NULL #' @rdname ard_categorical #' @export ard_categorical <- function(data, ...) { check_not_missing(data) UseMethod("ard_categorical") } #' @rdname ard_categorical #' @export ard_categorical.data.frame <- function(data, variables, by = dplyr::group_vars(data), strata = NULL, statistic = everything() ~ c("n", "p", "N"), denominator = "column", fmt_fn = NULL, stat_label = everything() ~ default_stat_labels(), ...) { set_cli_abort_call() check_dots_used() # check inputs --------------------------------------------------------------- check_not_missing(variables) .check_no_ard_columns(data) # process arguments ---------------------------------------------------------- process_selectors( data, variables = {{ variables }}, by = {{ by }}, strata = {{ strata }} ) data <- dplyr::ungroup(data) .check_whether_na_counts(data[variables]) process_formula_selectors( data[variables], statistic = statistic, stat_label = stat_label, fmt_fn = fmt_fn ) fill_formula_selectors( data[variables], statistic = formals(asNamespace("cards")[["ard_categorical.data.frame"]])[["statistic"]] |> eval() ) check_list_elements( x = statistic, predicate = \(x) is.character(x) && all(x %in% c("n", "p", "N", "n_cum", "p_cum")), error_msg = "Elements passed in the {.arg statistic} argument must be one or more of {.val {c('n', 'p', 'N', 'n_cum', 'p_cum')}}" ) # return empty ARD if no variables selected ---------------------------------- if (is_empty(variables)) { return(dplyr::tibble() |> as_card()) } # return note about column names that result in errors ----------------------- if (any(by %in% c("variable", "variable_level"))) { cli::cli_abort( "The {.arg by} argument cannot include variables named {.val {c('variable', 'variable_level')}}.", call = get_cli_abort_call() ) } # check factor levels -------------------------------------------------------- check_no_na_factor_levels(data[c(variables, by, strata)]) check_factor_has_levels(data[c(variables, by, strata)]) # calculating summary stats -------------------------------------------------- # calculate tabulation statistics df_result_tabulation <- .calculate_tabulation_statistics( data, variables = variables, by = by, strata = strata, denominator = denominator, statistic = lapply(statistic, \(x) list(tabulation = x)) ) # final processing of fmt_fn ------------------------------------------------- df_result_final <- df_result_tabulation |> .process_nested_list_as_df( arg = fmt_fn, new_column = "fmt_fn" ) |> .default_fmt_fn() # final processing of stat labels -------------------------------------------- df_result_final <- .process_nested_list_as_df( x = df_result_final, arg = stat_label, new_column = "stat_label", unlist = TRUE ) |> dplyr::mutate( stat_label = map2_chr( .data$stat_label, .data$stat_name, function(stat_label, stat_name) dplyr::coalesce(stat_label, default_stat_labels()[[stat_name]], stat_name) ) ) # merge in stat labels and format ARD for return ----------------------------- df_result_final |> dplyr::mutate(context = "categorical") |> tidy_ard_column_order() |> tidy_ard_row_order() |> as_card() } #' Calculate Tabulation Statistics #' #' Function takes the summary instructions from the #' `statistic = list(variable_name = list(tabulation=c("n", "N", "p")))` #' argument, and returns the tabulations in an ARD structure. #' #' @inheritParams ard_categorical #' @return an ARD data frame of class 'card' #' @keywords internal #' #' @examples #' cards:::.calculate_tabulation_statistics( #' ADSL, #' variables = "ARM", #' by = NULL, #' strata = NULL, #' denominator = "cell", #' statistic = list(ARM = list(tabulation = c("N"))) #' ) .calculate_tabulation_statistics <- function(data, variables, by, strata, denominator, statistic) { # extract the "tabulation" statistics. statistics_tabulation <- lapply(statistic, function(x) x["tabulation"] |> compact()) |> compact() if (is_empty(statistics_tabulation)) { return(dplyr::tibble()) } # first process the denominator lst_denominator <- .process_denominator( data = data, variables = imap( statistics_tabulation, function(x, variable) { if (any(c("N", "p", "p_cum") %in% x[["tabulation"]])) { TRUE } else { NULL } } ) |> compact() |> names(), denominator = denominator, by = by, strata = strata ) # perform other counts df_result_tabulation <- imap( statistics_tabulation, function(tab_stats, variable) { df_result_tabulation <- .table_as_df(data, variable = variable, by = by, strata = strata, count_column = "...ard_n...") if (!is_empty(lst_denominator[[variable]])) { df_result_tabulation <- if (is_empty(intersect(names(df_result_tabulation), names(lst_denominator[[variable]])))) { dplyr::cross_join( df_result_tabulation, lst_denominator[[variable]] ) } else { suppressMessages(dplyr::left_join( df_result_tabulation, lst_denominator[[variable]] )) } } if (any(c("p", "p_cum") %in% tab_stats[["tabulation"]])) { df_result_tabulation <- df_result_tabulation |> dplyr::mutate( ...ard_p... = .data$...ard_n... / .data$...ard_N... ) } df_result_tabulation <- .add_cum_count_stats( df_result_tabulation, variable = variable, by = by, strata = strata, denominator = denominator, tab_stats = tab_stats ) df_result_tabulation |> .nesting_rename_ard_columns(variable = variable, by = by, strata = strata) |> dplyr::mutate( across(any_of(c("...ard_n...", "...ard_N...", "...ard_p...", "...ard_n_cum...", "...ard_p_cum...")), as.list), across(c(matches("^group[0-9]+_level$"), any_of("variable_level")), as.list) ) |> tidyr::pivot_longer( cols = any_of(c("...ard_n...", "...ard_N...", "...ard_p...", "...ard_n_cum...", "...ard_p_cum...")), names_to = "stat_name", values_to = "stat" ) |> dplyr::mutate( stat_name = gsub(pattern = "^...ard_", replacement = "", x = .data$stat_name) %>% gsub(pattern = "...$", replacement = "", x = .) ) |> dplyr::filter(.data$stat_name %in% tab_stats[["tabulation"]]) } ) |> dplyr::bind_rows() df_result_tabulation |> dplyr::mutate( warning = list(NULL), error = list(NULL) ) } .check_whether_na_counts <- function(data) { walk( names(data), function(x) { if (all(is.na(data[[x]])) && !inherits(data[[x]], c("logical", "factor"))) { cli::cli_abort( c("Column {.val {x}} is all missing and cannot by tabulated.", i = "Only columns of class {.cls logical} and {.cls factor} can be tabulated when all values are missing." ), call = get_cli_abort_call() ) } } ) } .add_cum_count_stats <- function(x, variable, by, strata, denominator, tab_stats) { # if no cumulative stats were requested, return the object if (!any(c("p_cum", "n_cum") %in% tab_stats[["tabulation"]])) { return(x) } # to return cumulative stats, the denominator must be 'column' or 'row' if (!is_string(denominator) || !denominator %in% c("column", "row")) { cli::cli_abort( "The {.arg denominator} argument must be one of {.val {c(\"column\", \"row\")}} when cumulative statistics {.val n_cum} or {.val p_cum} are specified, which were requested for variable {.var {variable}}.", call = get_cli_abort_call() ) } # calculate the cumulative statistics if (denominator %in% "column") { x <- x |> dplyr::mutate( .by = any_of(c(by, strata)), ...ard_n_cum... = switch("n_cum" %in% tab_stats[["tabulation"]], cumsum(.data$...ard_n...) ), ...ard_p_cum... = switch("p_cum" %in% tab_stats[["tabulation"]], cumsum(.data$...ard_p...) ) ) } else if (denominator %in% "row") { x <- x |> dplyr::mutate( .by = any_of(variable), ...ard_n_cum... = switch("n_cum" %in% tab_stats[["tabulation"]], cumsum(.data$...ard_n...) ), ...ard_p_cum... = switch("p_cum" %in% tab_stats[["tabulation"]], cumsum(.data$...ard_p...) ) ) } x } #' Results from `table()` as Data Frame #' #' Takes the results from [table()] and returns them as a data frame. #' After the [table()] results are made into a data frame, all the variables #' are made into character columns, and the function also restores the #' column types to their original classes. For `strata` columns, #' only observed combinations are returned. #' #' @param data (`data.frame`)\cr #' a data frame #' @param variable (`string`)\cr #' a string indicating a column in data #' @param by (`character`)\cr #' a character vector indicating columns in data #' @param strata (`character`)\cr #' a character vector indicating columns in data #' @param useNA (`string`)\cr #' one of `"no"` and `"always"`. Will be passed to `table(useNA)`. #' #' @keywords internal #' @return data frame #' #' @examples #' cards:::.table_as_df(ADSL, variable = "ARM", by = "AGEGR1", strata = NULL) .table_as_df <- function(data, variable = NULL, by = NULL, strata = NULL, useNA = c("no", "always"), count_column = "...ard_n...") { useNA <- match.arg(useNA) # tabulate results and save in data frame ...ard_tab_vars... <- c(by, strata, variable) df_table <- data[...ard_tab_vars...] |> dplyr::mutate(across(where(is.logical), ~ factor(., levels = c("FALSE", "TRUE")))) |> with(inject(table(!!!syms(...ard_tab_vars...), useNA = !!useNA))) |> dplyr::as_tibble(n = count_column) # construct a matching data frame with the variables in their original type/class df_original_types <- lapply( c(by, strata, variable), function(x) .unique_and_sorted(data[[x]], useNA = useNA) ) |> stats::setNames(c(by, strata, variable)) %>% {tidyr::expand_grid(!!!.)} |> # styler: off arrange_using_order(rev(...ard_tab_vars...)) # if all columns match, then replace the coerced character cols with their original type/class all_cols_equal <- every( c(by, strata, variable), ~ all( df_table[[.x]] == as.character(df_original_types[[.x]]) | (is.na(df_table[[.x]]) & is.na(df_original_types[[.x]])) ) ) if (isTRUE(all_cols_equal)) { df_table <- dplyr::bind_cols(df_original_types, df_table[count_column], .name_repair = "minimal") } # I hope this message is never triggered! else { cli::cli_inform(c( "If you see this message, the order of the sorted variables in the tabulaton is unexpected, which could cause downstream issues.", "*" = "Please post a reproducible example to {.url https://github.com/insightsengineering/cards/issues/new}, so we can address in the next release.", "i" = "You can create a minimal reproducible example with {.fun reprex::reprex}." )) } # if strata is present, remove unobserved rows if (!is_empty(strata)) { # if we were not able to maintain the original type, convert strata to character if (!isTRUE(all_cols_equal)) { df_original_strata <- dplyr::distinct(data[strata]) |> apply(MARGIN = 2, FUN = as.character) } else { df_original_strata <- dplyr::distinct(data[strata]) } df_table <- dplyr::left_join( df_original_strata |> dplyr::arrange(across(all_of(strata))), df_table, by = strata ) |> dplyr::select(all_of(names(df_table))) } df_table } # like `dplyr::arrange()`, but uses base R's `order()` to keep consistency in some edge cases arrange_using_order <- function(data, columns) { inject(data[with(data, order(!!!syms(columns))), ]) } #' Process `denominator` Argument #' #' Function takes the `ard_categorical(denominator)` argument and returns a #' structured data frame that is merged with the count data and used as the #' denominator in percentage calculations. #' #' @inheritParams ard_categorical #' #' @return a data frame #' @keywords internal #' #' @examples #' cards:::.process_denominator(mtcars, denominator = 1000, variables = "cyl", by = "gear") .process_denominator <- function(data, variables, denominator, by, strata) { if (is_empty(variables)) { return(list()) } # if no by/strata and no denominator (or column), then use number of non-missing in variable if ((is.null(denominator) || isTRUE(denominator %in% "column")) && is_empty(c(by, strata))) { lst_denominator <- lapply( variables, function(variable) dplyr::tibble(...ard_N... = sum(!is.na(data[[variable]]))) ) |> stats::setNames(variables) } # if by/strata present and no denominator (or denominator="column"), then use number of non-missing variables else if (is.null(denominator) || isTRUE(denominator %in% "column")) { lst_denominator <- lapply( variables, function(variable) { .table_as_df( data, variable = variable, by = by, strata = strata, count_column = "...ard_N...", useNA = "always" ) |> tidyr::drop_na(all_of(c(by, strata, variable))) |> dplyr::summarise( .by = all_of(c(by, strata)), ...ard_N... = sum(.data$...ard_N...) ) } ) |> stats::setNames(variables) } # if user passed a data frame WITHOUT the counts pre-specified and no by/strata else if (is.data.frame(denominator) && !"...ard_N..." %in% names(denominator) && is_empty(intersect(c(by, strata), names(denominator)))) { lst_denominator <- rep_named( variables, list(dplyr::tibble(...ard_N... = nrow(denominator))) ) } # if user passed a data frame WITHOUT the counts pre-specified with by/strata else if (is.data.frame(denominator) && !"...ard_N..." %in% names(denominator)) { .check_for_missing_combos_in_denom( data, denominator = denominator, by = by, strata = strata ) lst_denominator <- rep_named( variables, list( .table_as_df( denominator, by = intersect(by, names(denominator)), strata = intersect(strata, names(denominator)), count_column = "...ard_N...", useNA = "always" ) |> tidyr::drop_na(any_of(c(by, strata))) ) ) } # if user requested cell percentages else if (isTRUE(denominator %in% "cell")) { lst_denominator <- lapply( variables, function(variable) { dplyr::tibble( ...ard_N... = tidyr::drop_na(data, all_of(c(by, strata, variable))) |> nrow() ) } ) |> stats::setNames(variables) } # if user requested row percentages else if (isTRUE(denominator %in% "row")) { lst_denominator <- lapply( variables, function(variable) { .table_as_df( data, variable = variable, by = by, strata = strata, count_column = "...ard_N...", useNA = "always" ) |> tidyr::drop_na(all_of(c(by, strata, variable))) |> dplyr::summarise( .by = all_of(variable), ...ard_N... = sum(.data$...ard_N...) ) } ) |> stats::setNames(variables) } # if user passed a single integer else if (is_scalar_integerish(denominator)) { lst_denominator <- rep_named( variables, list(dplyr::tibble(...ard_N... = as.integer(denominator))) ) } # if user passed a data frame WITH the counts pre-specified else if (is.data.frame(denominator) && "...ard_N..." %in% names(denominator)) { # check there are no duplicates in by/strata variables if ( (any(c(by, strata) %in% names(denominator)) && any(duplicated(denominator[c(by, strata)]))) || (!any(c(by, strata) %in% names(denominator)) && nrow(denominator) > 1L) ) { paste( "Specified counts in column {.val '...ard_N...'} are not unique in", "the {.arg denominator} argument across the {.arg by} and {.arg strata} columns." ) |> cli::cli_abort(call = get_cli_abort_call()) } .check_for_missing_combos_in_denom( data, denominator = denominator, by = by, strata = strata ) # making the by/strata columns character to merge them with the count data frames df_denom <- denominator |> dplyr::select(any_of(c(by, strata, "...ard_N..."))) |> tidyr::drop_na() |> dplyr::mutate(across(any_of(c(by, strata)), as.character)) lst_denominator <- rep_named(variables, list(df_denom)) } else { cli::cli_abort("The {.arg denominator} argument has been mis-specified.", call = get_cli_abort_call()) } lst_denominator } #' Check for Missing Levels in `denominator` #' #' When a user passes a data frame in the `denominator` argument, this function #' checks that the data frame contains all the same levels of the `by` #' and `strata` variables that appear in `data`. #' #' @param data (`data.frame`)\cr #' a data frame #' @param denominator (`data.frame`)\cr #' denominator data frame #' @param by (`character`)\cr #' character vector of by column names #' @param strata (`character`)\cr #' character vector of strata column names #' #' @return returns invisible if check is successful, throws an error message if not. #' @keywords internal #' #' @examples #' cards:::.check_for_missing_combos_in_denom(ADSL, denominator = "col", by = "ARM", strata = "AGEGR1") .check_for_missing_combos_in_denom <- function(data, denominator, by, strata) { by_vars_to_check <- c(by, strata) |> intersect(names(data)) |> intersect(names(denominator)) if (is_empty(by_vars_to_check)) { return(invisible()) } # find missing combinations df_denom_level_check <- dplyr::anti_join( data[by_vars_to_check] |> unique(), denominator[by_vars_to_check] |> unique(), by_vars_to_check ) # message users of missing combination if (nrow(df_denom_level_check) > 0L) { missing_combos <- df_denom_level_check |> unique() |> imap(~ glue::glue("{.y} ({.x})")) |> dplyr::bind_cols() |> as.matrix() |> apply( MARGIN = 1, FUN = function(x) paste(x, collapse = "/"), simplify = FALSE ) paste( "The following {.arg by/strata} combinations are missing from the", "{.arg denominator} data frame: {.val {missing_combos}}." ) |> cli::cli_abort(call = get_cli_abort_call()) } } cards/R/import-standalone-purrr.R0000644000176200001440000001305414567176413016523 0ustar liggesusers# Standalone file: do not edit by hand # Source: # ---------------------------------------------------------------------- # # --- # repo: r-lib/rlang # file: standalone-purrr.R # last-updated: 2023-02-23 # license: https://unlicense.org # imports: rlang # --- # # This file provides a minimal shim to provide a purrr-like API on top of # base R functions. They are not drop-in replacements but allow a similar style # of programming. # # ## Changelog # # 2023-02-23: # * Added `list_c()` # # 2022-06-07: # * `transpose()` is now more consistent with purrr when inner names # are not congruent (#1346). # # 2021-12-15: # * `transpose()` now supports empty lists. # # 2021-05-21: # * Fixed "object `x` not found" error in `imap()` (@mgirlich) # # 2020-04-14: # * Removed `pluck*()` functions # * Removed `*_cpl()` functions # * Used `as_function()` to allow use of `~` # * Used `.` prefix for helpers # # nocov start map <- function(.x, .f, ...) { .f <- as_function(.f, env = global_env()) lapply(.x, .f, ...) } walk <- function(.x, .f, ...) { map(.x, .f, ...) invisible(.x) } map_lgl <- function(.x, .f, ...) { .rlang_purrr_map_mold(.x, .f, logical(1), ...) } map_int <- function(.x, .f, ...) { .rlang_purrr_map_mold(.x, .f, integer(1), ...) } map_dbl <- function(.x, .f, ...) { .rlang_purrr_map_mold(.x, .f, double(1), ...) } map_chr <- function(.x, .f, ...) { .rlang_purrr_map_mold(.x, .f, character(1), ...) } .rlang_purrr_map_mold <- function(.x, .f, .mold, ...) { .f <- as_function(.f, env = global_env()) out <- vapply(.x, .f, .mold, ..., USE.NAMES = FALSE) names(out) <- names(.x) out } map2 <- function(.x, .y, .f, ...) { .f <- as_function(.f, env = global_env()) out <- mapply(.f, .x, .y, MoreArgs = list(...), SIMPLIFY = FALSE) if (length(out) == length(.x)) { set_names(out, names(.x)) } else { set_names(out, NULL) } } map2_lgl <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "logical") } map2_int <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "integer") } map2_dbl <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "double") } map2_chr <- function(.x, .y, .f, ...) { as.vector(map2(.x, .y, .f, ...), "character") } imap <- function(.x, .f, ...) { map2(.x, names(.x) %||% seq_along(.x), .f, ...) } pmap <- function(.l, .f, ...) { .f <- as.function(.f) args <- .rlang_purrr_args_recycle(.l) do.call("mapply", c( FUN = list(quote(.f)), args, MoreArgs = quote(list(...)), SIMPLIFY = FALSE, USE.NAMES = FALSE )) } .rlang_purrr_args_recycle <- function(args) { lengths <- map_int(args, length) n <- max(lengths) stopifnot(all(lengths == 1L | lengths == n)) to_recycle <- lengths == 1L args[to_recycle] <- map(args[to_recycle], function(x) rep.int(x, n)) args } keep <- function(.x, .f, ...) { .x[.rlang_purrr_probe(.x, .f, ...)] } discard <- function(.x, .p, ...) { sel <- .rlang_purrr_probe(.x, .p, ...) .x[is.na(sel) | !sel] } map_if <- function(.x, .p, .f, ...) { matches <- .rlang_purrr_probe(.x, .p) .x[matches] <- map(.x[matches], .f, ...) .x } .rlang_purrr_probe <- function(.x, .p, ...) { if (is_logical(.p)) { stopifnot(length(.p) == length(.x)) .p } else { .p <- as_function(.p, env = global_env()) map_lgl(.x, .p, ...) } } compact <- function(.x) { Filter(length, .x) } transpose <- function(.l) { if (!length(.l)) { return(.l) } inner_names <- names(.l[[1]]) if (is.null(inner_names)) { fields <- seq_along(.l[[1]]) } else { fields <- set_names(inner_names) .l <- map(.l, function(x) { if (is.null(names(x))) { set_names(x, inner_names) } else { x } }) } # This way missing fields are subsetted as `NULL` instead of causing # an error .l <- map(.l, as.list) map(fields, function(i) { map(.l, .subset2, i) }) } every <- function(.x, .p, ...) { .p <- as_function(.p, env = global_env()) for (i in seq_along(.x)) { if (!rlang::is_true(.p(.x[[i]], ...))) { return(FALSE) } } TRUE } some <- function(.x, .p, ...) { .p <- as_function(.p, env = global_env()) for (i in seq_along(.x)) { if (rlang::is_true(.p(.x[[i]], ...))) { return(TRUE) } } FALSE } negate <- function(.p) { .p <- as_function(.p, env = global_env()) function(...) !.p(...) } reduce <- function(.x, .f, ..., .init) { f <- function(x, y) .f(x, y, ...) Reduce(f, .x, init = .init) } reduce_right <- function(.x, .f, ..., .init) { f <- function(x, y) .f(y, x, ...) Reduce(f, .x, init = .init, right = TRUE) } accumulate <- function(.x, .f, ..., .init) { f <- function(x, y) .f(x, y, ...) Reduce(f, .x, init = .init, accumulate = TRUE) } accumulate_right <- function(.x, .f, ..., .init) { f <- function(x, y) .f(y, x, ...) Reduce(f, .x, init = .init, right = TRUE, accumulate = TRUE) } detect <- function(.x, .f, ..., .right = FALSE, .p = is_true) { .p <- as_function(.p, env = global_env()) .f <- as_function(.f, env = global_env()) for (i in .rlang_purrr_index(.x, .right)) { if (.p(.f(.x[[i]], ...))) { return(.x[[i]]) } } NULL } detect_index <- function(.x, .f, ..., .right = FALSE, .p = is_true) { .p <- as_function(.p, env = global_env()) .f <- as_function(.f, env = global_env()) for (i in .rlang_purrr_index(.x, .right)) { if (.p(.f(.x[[i]], ...))) { return(i) } } 0L } .rlang_purrr_index <- function(x, right = FALSE) { idx <- seq_along(x) if (right) { idx <- rev(idx) } idx } list_c <- function(x) { inject(c(!!!x)) } # nocov end cards/R/rename_ard_columns.R0000644000176200001440000001112514776252672015551 0ustar liggesusers#' Rename ARD Variables #' #' Rename the grouping and variable columns to their original column names. #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' @param columns ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' columns to rename, e.g. selecting columns `c('group1', 'group2', 'variable')` #' will rename `'group1_level'` to the name of the variable found in `'group1'`. #' When, for example, the `'group1_level'` does not exist, the values of the #' new column are filled with the values in the `fill` argument. #' Default is `c(all_ard_groups("names"), all_ard_variables("names"))`. #' @param fill (scalar/glue)\cr #' a scalar to fill column values when the variable does not have levels. #' If a character is passed, then it is processed with `glue::glue()` #' where the `colname` element is available to inject into the string, #' e.g. `'Overall {colname}'` may resolve to `'Overall AGE'` for an AGE column. #' Default is `'{colname}'`. #' @param unlist `r lifecycle::badge("deprecated")` #' #' @return data frame #' @export #' #' @examples #' # Example 1 ---------------------------------- #' ADSL |> #' ard_categorical(by = ARM, variables = AGEGR1) |> #' apply_fmt_fn() |> #' rename_ard_columns() |> #' unlist_ard_columns() #' #' # Example 2 ---------------------------------- #' ADSL |> #' ard_continuous(by = ARM, variables = AGE) |> #' apply_fmt_fn() |> #' rename_ard_columns(fill = "Overall {colname}") |> #' unlist_ard_columns() rename_ard_columns <- function(x, columns = c(all_ard_groups("names"), all_ard_variables("names")), fill = "{colname}", unlist = NULL) { # check inputs --------------------------------------------------------------- if (!missing(unlist)) { lifecycle::deprecate_warn( when = "0.6.0", what = "cards::rename_ard_columns(unlist)", with = "unlist_ard_columns()", details = "Argument has been ignored." ) } set_cli_abort_call() check_not_missing(x) check_class(x, "card") process_selectors(x, columns = {{ columns }}) check_scalar(fill) if (!is_empty(setdiff(columns, dplyr::select(x, all_ard_groups("names"), all_ard_variables("names")) |> names()))) { bad_columns <- setdiff(columns, dplyr::select(x, all_ard_groups("names"), all_ard_variables("names")) |> names()) cli::cli_abort( c("The {.arg column} argument may only select columns using {.code all_ard_groups(\"names\")} and {.code all_ard_variables(\"names\")}", "i" = "{cli::qty(bad_columns)} Column{?s} {.val {bad_columns}} {?is/are} not a valid selection." ), call = get_cli_abort_call() ) } # separate selected names from levels column_names <- x |> dplyr::select( intersect( c(all_ard_groups("names"), all_ard_variables("names")), all_of(columns) ) ) |> names() all_new_names <- x[column_names] |> unlist() |> unique() |> discard(is.na) |> unname() if (any(all_new_names %in% names(x))) { protected_names <- all_new_names[all_new_names %in% names(x)] cli::cli_abort( "New column name(s) {.val {protected_names}} cannot be added, because they are already present.", call = get_cli_abort_call() ) } x |> dplyr::mutate(...ard_row_order... = dplyr::row_number()) |> dplyr::group_by(dplyr::pick(all_of(column_names))) |> dplyr::group_map( \(df, df_group) { lst_group <- as.list(df_group) |> discard(is.na) names_group <- names(lst_group) # cycle over all columns for (v in names_group) { # if level column does not exist, adding it if (!paste0(v, "_level") %in% names(df)) { df[[paste0(v, "_level")]] <- list(NULL) } fill_glued <- case_switch( is.character(fill) ~ glue::glue_data(.x = lst_group[v] |> set_names("colname"), fill) |> as.character(), .default = fill ) # replace null values df[[lst_group[[v]]]] <- df[[paste0(v, "_level")]] |> map(~ .x %||% fill_glued) df[[paste0(v, "_level")]] <- NULL } df |> dplyr::select(-any_of(c(columns, paste0(columns, "_level")))) } ) |> dplyr::bind_rows() |> dplyr::arrange(!!sym("...ard_row_order...")) |> dplyr::relocate(all_of(all_new_names), .before = 1L) |> dplyr::select(-"...ard_row_order...") |> dplyr::mutate( # replace NULL values with NA, then unlist across(all_of(all_new_names), ~ map(., \(value) value %||% NA) |> unlist()) ) } cards/R/ard_dichotomous.R0000644000176200001440000001253214742035422015063 0ustar liggesusers#' Dichotomous ARD Statistics #' #' Compute Analysis Results Data (ARD) for dichotomous summary statistics. #' #' @inheritParams ard_categorical #' @param value (named `list`)\cr #' named list of dichotomous values to tabulate. Default is `maximum_variable_value(data)`, #' which returns the largest/last value after a sort. #' #' @return an ARD data frame of class 'card' #' @name ard_dichotomous #' #' @inheritSection ard_categorical Denominators #' #' @examples #' ard_dichotomous(mtcars, by = vs, variables = c(cyl, am), value = list(cyl = 4)) #' #' mtcars |> #' dplyr::group_by(vs) |> #' ard_dichotomous( #' variables = c(cyl, am), #' value = list(cyl = 4), #' statistic = ~"p" #' ) NULL #' @rdname ard_dichotomous #' @export ard_dichotomous <- function(data, ...) { check_not_missing(data) UseMethod("ard_dichotomous") } #' @rdname ard_dichotomous #' @export ard_dichotomous.data.frame <- function(data, variables, by = dplyr::group_vars(data), strata = NULL, value = maximum_variable_value(data[variables]), statistic = everything() ~ c("n", "N", "p"), denominator = NULL, fmt_fn = NULL, stat_label = everything() ~ default_stat_labels(), ...) { set_cli_abort_call() # check inputs --------------------------------------------------------------- check_not_missing(variables) # process inputs ------------------------------------------------------------- process_selectors(data, variables = {{ variables }}) process_formula_selectors(data[variables], value = value) fill_formula_selectors( data[variables], value = formals(asNamespace("cards")[["ard_dichotomous.data.frame"]])[["value"]] |> eval() ) .check_dichotomous_value(data, value) # return empty ARD if no variables selected ---------------------------------- if (is_empty(variables)) { return(dplyr::tibble() |> as_card()) } # calculate summary statistics ----------------------------------------------- ard_categorical( data = data, variables = all_of(variables), by = {{ by }}, strata = {{ strata }}, statistic = statistic, denominator = denominator, fmt_fn = fmt_fn, stat_label = stat_label ) |> dplyr::filter( pmap( list(.data$variable, .data$variable_level), function(variable, variable_level) { variable_level %in% .env$value[[variable]] } ) |> unlist() ) |> dplyr::mutate(context = "dichotomous") } #' Maximum Value #' #' For each column in the passed data frame, the function returns a named list #' with the value being the largest/last element after a sort. #' For factors, the last level is returned, and for logical vectors `TRUE` is returned. #' This is used as the default value in `ard_dichotomous(value)` if not specified by #' the user. #' #' @param data (`data.frame`)\cr #' a data frame #' #' @return a named list #' @export #' #' @examples #' ADSL[c("AGEGR1", "BMIBLGR1")] |> maximum_variable_value() maximum_variable_value <- function(data) { data |> lapply( function(x) { if (inherits(x, "factor")) { return(levels(x) |> dplyr::last()) } if (inherits(x, "logical")) { return(TRUE) } stats::na.omit(x) |> unique() |> sort() |> dplyr::last() } ) } #' Perform Value Checks #' #' Check the validity of the values passed in `ard_dichotomous(value)`. #' #' @param data (`data.frame`)\cr #' a data frame #' @param value (named `list`)\cr #' a named list #' #' @return returns invisible if check is successful, throws an error message if not. #' @keywords internal #' #' @examples #' cards:::.check_dichotomous_value(mtcars, list(cyl = 4)) .check_dichotomous_value <- function(data, value) { imap( value, function(value, column) { accepted_values <- .unique_and_sorted(data[[column]]) if (length(value) != 1L || !value %in% accepted_values) { message <- "Error in argument {.arg value} for variable {.val {column}}." message <- case_switch( length(value) != 1L ~ c(message, "i" = "The value must be one of {.val {accepted_values}}."), .default = c(message, "i" = "A value of {.val {value}} was passed, but must be one of {.val {accepted_values}}.") ) if (length(value) == 1L) { message <- case_switch( inherits(data[[column]], "factor") ~ c(message, i = "To summarize this value, use {.fun forcats::fct_expand} to add {.val {value}} as a level."), .default = c(message, i = "To summarize this value, make the column a factor and include {.val {value}} as a level.") ) } cli::cli_abort( message = message, call = get_cli_abort_call() ) } } ) |> invisible() } case_switch <- function(..., .default = NULL) { dots <- dots_list(...) for (f in dots) { if (isTRUE(eval(f_lhs(f), envir = attr(f, ".Environment")))) { return(eval(f_rhs(f), envir = attr(f, ".Environment"))) } } return(.default) } cards/R/as_card_fn.R0000644000176200001440000000432214721250550013753 0ustar liggesusers#' As card function #' #' Add attributes to a function that specify the expected results. #' It is used when `ard_continuous()` or `ard_complex()` errors and constructs #' an ARD with the correct structure when the results cannot be calculated. #' #' @param f (`function`)\cr #' a function #' @param stat_names (`character`)\cr #' a character vector of the expected statistic names returned by function `f` #' #' @return an ARD data frame of class 'card' #' @name as_cards_fn #' #' @examples #' # When there is no error, everything works as if we hadn't used `as_card_fn()` #' ttest_works <- #' as_cards_fn( #' \(x) t.test(x)[c("statistic", "p.value")], #' stat_names = c("statistic", "p.value") #' ) #' ard_continuous( #' mtcars, #' variables = mpg, #' statistic = ~ list(ttest = ttest_works) #' ) #' #' # When there is an error and we use `as_card_fn()`, #' # we will see the same structure as when there is no error #' ttest_error <- #' as_cards_fn( #' \(x) { #' t.test(x)[c("statistic", "p.value")] #' stop("Intentional Error") #' }, #' stat_names = c("statistic", "p.value") #' ) #' ard_continuous( #' mtcars, #' variables = mpg, #' statistic = ~ list(ttest = ttest_error) #' ) #' #' # if we don't use `as_card_fn()` and there is an error, #' # the returned result is only one row #' ard_continuous( #' mtcars, #' variables = mpg, #' statistic = ~ list(ttest = \(x) { #' t.test(x)[c("statistic", "p.value")] #' stop("Intentional Error") #' }) #' ) NULL #' @rdname as_cards_fn #' @export as_cards_fn <- function(f, stat_names) { set_cli_abort_call() # check inputs --------------------------------------------------------------- check_class(f, "function") check_class(stat_names, "character") # add attribute -------------------------------------------------------------- attr(f, "stat_names") <- stat_names # return function and add a class -------------------------------------------- structure(f, class = c("cards_fn", class(f))) } #' @rdname as_cards_fn #' @export is_cards_fn <- function(f) { inherits(f, "cards_fn") } #' @rdname as_cards_fn #' @export get_cards_fn_stat_names <- function(f) { check_class(f, "cards_fn") attr(f, "stat_names") } cards/R/ard_total_n.R0000644000176200001440000000176514661011726014175 0ustar liggesusers#' ARD Total N #' #' Returns the total N for the data frame. #' The placeholder variable name returned in the object is `"..ard_total_n.."` #' #' @inheritParams ard_dichotomous #' @inheritParams rlang::args_dots_empty #' #' @return an ARD data frame of class 'card' #' @name ard_total_n #' #' @examples #' ard_total_n(ADSL) NULL #' @rdname ard_total_n #' @export ard_total_n <- function(data, ...) { check_not_missing(data) UseMethod("ard_total_n") } #' @rdname ard_total_n #' @export ard_total_n.data.frame <- function(data, ...) { # process inputs ------------------------------------------------------------- set_cli_abort_call() check_dots_empty() check_data_frame(data) # calculate total N ---------------------------------------------------------- data |> dplyr::mutate(..ard_total_n.. = TRUE) |> ard_dichotomous(variables = "..ard_total_n..", statistic = list(..ard_total_n.. = "N")) |> dplyr::mutate(context = "total_n") |> dplyr::select(-all_ard_variables("levels")) } cards/data/0000755000176200001440000000000014567176413012275 5ustar liggesuserscards/data/ADTTE.rda0000644000176200001440000001262314567176413013632 0ustar liggesusersBZh91AY&SY^cÝM{’ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿßÿ¿ÿÿÿÿþÿÿÿÿàßaèàî3sgXÁl*«x0â‹ ¸6iÅkBv@(ΰHRR””g€wzÝÜvªžDÓI†“ÈÍšõ=2hhÂ=CFSO&£CПªzI Ú2bšbmM h )ˆýQú¦¨òžš&e6)èÑ6F¦™‰¦§¦š24©‰êf)å¿‚Rà ϤŽuߦýœî—wƒÂ‚‡IO) ÒÑ‘Mu×]!uôÜãWP-©ç¾ó²é #@F4‘PA>ôKµØÄws’‹JTïyç^Ïë}w^óø(Ú9>¨ŠÆ¦K°FÒ£°Ê•±*I¤Še›Õpñö*Ú•´¿(¤ØÙIúvi\QJ¿R•"ÅŽ=·Mï-JL©Ûä¾&uJ_V¦µh}XÝûV·¨iwµVþ©K;îEÁýnïÎs¥‚cËŸ‡?k_ìO™šîwÙËÆïªËf†<5\Ѧ;LÚ8åÊìâ÷Ü>ÝÌîrÞs–m;wš1‘ô§`î#Lá`}ÜìÒ—§"–EáT²„ ôÞö°yÙâØÝ⹟!ä7›¼Ç™p®÷Ìsþç £[äÔJðä©;Ú´ï®è#•Xèô[Áæ È™ …Špú™€wFöàœF}¥¯½*›…I˜¹îó!1WºâªÛ©¾Ãƒ\PxºZÀPšZzwfú¯¥°(¦º`FâêÖ>œ¨jà6»Ú›²2Œ·Ìn•|r&¾¢[±Ð„íVU3*y)ͧÂd S‹›Ü‘Köcuô‹-k•p—}¦õJÓQŠãc]Kfy…šâó”íç'¤y¿Î, 40ŸJX±tIÄÍjN¬7.¬ÖzÂb`HªO”‹`-tù "6ÌâÈæ¸;Ķ&Öç Qˆ}C×ÁC7<¸$ÙY«îx÷wµf®ªüÙÌä˜äNo šŒ,±2ñÈ—¥…™ò @ãuLK"³_Ñ㜶Z3Öòm›¸{íÿìž2ÑYËfnï²›MÒ÷ Ë:wêœ_/†æºtï÷­å#Êã¾<åSÀ¶uêÑvPW`–5;2f†™}+Çã…Àä¹=œÕë7wŸ3w‘3ßýƅ𜬯‡¯€Ó”3f’-l—®pðXà´ÃVêRVÐHZD^6çwÎO'ÂìëÜ÷yÊgÏݲb˜pøjö¶÷ûváÁ¯¹¿ŒÛ3UÓt\¡±§ÛlF"2$RT¢JQFD̘‘Š#‡X’CH¡ù¼ÅË8*-nùsSL™eË&“b©@ ‘„#Nõw­áóv{åÍÝ{ÊJøj³ê®xÔpønÛ A8Jj–Ì©8Vq€I55"˜råòȆ{oîlåFÄË…5MY®¦Ä’@dCh¶JH·‹Ö±UVMªµ+\mF¤Òk¾o+ñns–âãhÜð|é\Eqßû×x´QmŠÞ±mXS€" A£DH@ôÂŒC¾»LÊ®!‡ÿrE8P^cÝMcards/data/ADAE.rda0000644000176200001440000006346514567176413013475 0ustar liggesusersBZh91AY&SYêH<¢Yÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ÷ÿÿÿÿÿ¿ÿÿÿÿà¬Þîóèœø}áßs^Ï@½×OW€cX°Ù­nîY@h€+˜¦’‘'$Ú ÀFÚsPÛP@¼,$©`Úª“N”Çc£\´ GCq‚вŒ01`7†‘8ÜX*€>€Ò¨ðúê€B#T&ƽtxÞèÈP¢CZ,”„lfk2( ÂmE šVZV  ”TL‘ 1 €’Ô(а4éI+MfZ¸}$PàDŒ= Ë»5ðÉ#@ „ÐÔÂdi¦@6š5=Ld4Ñ'èF§€Bf†ƒ@AO"žÑ=4žLi¦“Ñ¢Ÿ£BOÓIš§”b¢Bj6©½)¦†ž¦€h4ò¨•£@4€hÐÐ €Ð¦F™4A @ 0€24IꔤšŒ¤Ù42ž(ô& õ€Ð@)$hM§Êa6¦ši=@hÈȈРhÓF€@ 4@ ‰ˆšô 2j16¤c&†ˆ3$Ó@ €ÐÐh€€ÿx•úª…‰”Dºè¥QŸŒT±Œö…½ÛV\¹ "tdáKj®NA¶Áa\°K&Zþ ñîÁ$ 0‚ãDùt|›½lôóÍ êo¢ôiçPV¹è«Û-x#ÑWž¾ÛÅ¢±ÍwD™%£,²‹`ņY2ùî`nͽÆÕ«Öï;6R;ÆÛÕéÕzKîNw¯®Þ nVrÖîš Šææ±%Û¹lîÜÚº¹W54mu®T†¬èt‚åcnUW5p«Š¹Ë[›ShÕÊŠéÎTîó»V1­Iµµâ«›m¶.î«5nmnkE®ÜÕËbsN»s®¹EÊܺ©Ý£©šFF‹Q&L%€ÂZʸXKY`…XE‚±´Æ LD"›€E²lZ§–X ›9„D¥ LFÅÑ!Í*,Z‡hLØfìËF‹A•–š*d0ÃMS f3·ŸÇÕC*5ù“2y8OB¾ƒ;5ÐgÒóÖL#áB£ÍØu, ëú°mºÕîu¢¥Aø¡i ÷ñ‰W^@Òt<d;?–<„=¿rÝö½ñ<õ?ƒãÜè¼SúÚ2ë´o¿òùpDb·šth@>—œ<òé¹H4<9¥d:K-÷©ðzÜë ÞÊ–ˆtáx÷þþ0–E꽞Ëûô/Sj³ª÷>íæTÍÉíØIŒÄxI;È q(¨‡näËO|”=üó›–_·ø9–¾×òºà:Ä2[8ãi±é¹>Êòì±A é¹»­‘"Ïã‘8ïE˜ûÕ¿üDýóÔ¨M>ζ¶»‰BT< &»•ø´Ù=³~¾Ô¿Êìí-Py(fïòè~ÆrƒœJ7bHR>˜Ð:×rÕźmÀÉÊ¡vƒG5)}ÏÒšˆ6çª  GÒýÑ&Î ‘•ö7 ÛŠa7(sëüU e³ù Ò{ü@‚B£Ru§2¡œB7vYýÞkµ¤…þׇ¿Áû²è¨îI¨Ø†úÀ3ýëD褩¤#ÃÇÉ@$ÿDËþŸxH”Þ¡=êrhÏ^ d"††÷œM*_—Cs ÚÆÀáœÅ«Eª¶ÖIb„Sÿ“ùSá@?Iü?E-CÓŽ¡̪üg¿Bxu°qxˆ’0¢<@ÿê7‰7‡ß{¾ßL´„zìˆ“Ž þ9_Zhm+X¾÷)âÏPôÈ#Ó@⌄fñOQë=G},jrÇp“Ð]oÜJ<”´B3ø ¿í=R9þ¸Å»#Ùë+ü_r¹d¼»tÿ çPðª3œ» ~øG|ße‡|Õ@/ñý¾ƒP9×íùQ#q œ‡²¢CƒÂ½D öµÚsW ´ù»ÿs˜ón„ ^äsk#äà{¯tŽÚ¨˜„‹äŽ -ï ²y¤6ŸÜqúîÀ ºWá”/4^{&t(iPñÇÀå£[ž9†,õ²9’6 Äò=´yFäË»`ýpå<®_dFÓ¤éuRóÃy]É®'‚{ÄïT®â f—.?a›™„Ú€‹UWqØðvÄî¸ëݾÚ?Ï(jøØßʱ#ËËl@É­9²#I›Óh:Y@×Ó€e ×í’9ÝL›èЮUC C;;N@äw8T˜~÷êö¾°ó0ŸxçiûÝý˜ëˆž„x ‹J? ë¥Má+wíý¹•êÁ”@ÕrÚ ÁáOТ­?÷¡‡/æhÿ>{Z2o@À_BD@NýŽ:ư‰Üü`xĺûÇWb×4UÞ*¾Ï z*G+ànê†{7Jæ€Ô6œ‹äiñ:Ý„Þ;¶|ßÏÁoñÿM{œ¾¿ñp"nu@äóÇL…ÐPt<»% þmî4nH>”Ói}qyUCWXùÁ'ª¼á½ƒðß!þZ@5[pF‹Akçç´ñÁ”d$ä¦bn÷Ä IJþþ~ñЍ,ù1¹-GýøQ]ûp<Ž–ÊFï¹ ›úh-›ðÑtÕÖ ‰ò"™ExDC $yqU×bY‰}‡ú9Tm‘øØÝ”¶£wt±ý§ø~z·R¬‘l{üG¿×¯K×þȵÒÏb°>Û± #íÒ~û¾à =¢gN×wÝéZg³¸ŸG“Ü1×4ÔÝDQ ži]fú}â¾G/hövdÝ2N¼çŸ–o3ríÇ+Õ;W—ŽÊЫ·9Õ !¡]yÉ[ïn\õ•Õný}®“€åuÜš ¥®¡£±ˆKòÚŽüÈí‘¥ºîÔHzS”Din¬‡ÜQž€HW»n~½–¶½•ë>ç×1c Ó1J¶Él¶W¥Ÿ/›s_ù_}}®°Ž[dAùëúõgÜwö=ý=žy¼“ô5ëÖAÔŠ°OM}ÒÃ:Ã3 “:ƒï“M' -$@‚š•!R¡P ƒ)¯C¦îþÎOû»êë"|~Ÿ…sy>ÅÂH½[×oêÍüî­úžz¦9n¸õ?²àZa)4¨Œ+ÕJä.£H )؂ŒØPJ. D8«$°P]X+Bg•ÈUŠ0HÕ->K! –³QáZ"Lê‚;mÂòeCìÈ~†?¿èäw¼` ¤BZ+”“•c¢e¼–úE¡f*Çxžj8ˆ@IH‚qÔ%èÔ'4 E+ú(Ë’†32i°@bÅ/×fê…Üëh¢rLÕÂ¸î¨ qT¤È«; F%TÞO[a8Òž«¸­… ØDµ©wj§i<ÔR#ËX¢P¨ØU{*E•8•è cÕEŠêblÅ#ÒÑ »1ÆüFL¨±‹²[KVÙ—Y¹Ì{fŒ.„jŒÀÚ„5ìB¦Â@€5e­s&² ψcE|V´sÕAY©¶È/d]ˆÍ2ã×K £5Õ¤‰âU*ä¢ãªõwνú‹¥*êÁ±5Õ?m *,浉­ªÖŒ 2ƒL—ˆb Z 3Üœ§@#²úë:å(ñ­Þ†”Å.sR_Ÿ_]&ÝÛKWñÚg¢°Ä«+˜V#ËdO@+ìUëÅ'.ÊS=ò…FŸ®…€©‹a‡E:Q؉\°i„@ˆÜÚl:–ôY¤T3”%Gd\ÎtäÁ. —®î MedNaÈ÷*fB ”^š‹J£”á+š˜óM$@nKVs,›¾Ÿ=¸d-h-bÐvÎñ‹a%Á˜¨-Ô¹j‚Äjr&Y‹¸—Ôê¨ÊˆÍ¬ßCH*ʰbÁp¶AmBj…€L2ö®ÍäÆÃN›7O\-vw`€Am$–Ð Ò®ª½lõ¤T¹@* ИÈÞñêÌ Qo—"”ìDZfÑi °Ê&þÝU h¤T6ûbýûBMD-Û•bÕŠ¤®U{P" ‰  ºÕV-'¥M5§çÊ«< "2 (ZB T7ÒÛe´eÙ.XúH¥ˆˆô«[»µ.¬iXSð.áÔ‘n• S³@i‚ ê@Ú4ÓXh¸;.í²i D—aP®eC¶hYQ±n4’DÑ\àøz|vZàd¤ *â|ŒH¯@Æ Wá¿’Ý‚Z[ÝÙX!¶CogÇ>w¦1p±5@‘102 ê]PÃEsˆ‘¦eˆ—‘±A·t¦ž˜UI3çZª÷ )äXa°’%;JÐcdÿ3WÜNÑ´ÀnÍ yƘ]h‚s"{,3ŠÂJ¡€ª¯Â¼LDp¿Œ°Kºfïí.”Doiö-Ï¡ƒeŒ=ÜÇéZE—+—‚åJͽedÄ{ôqq*¬TŠ£rý*̹jíV*;Aw”RÊ2DßíkêöòpØœ]I•(Ì]þ «|tÛT•G cu Aº ¤Ë×N„ê3£<û…ØTVum„¼s²Ÿ¬»&£Y^Ö¯¹eÁ*úEüT6w5[~ÒÕUEÂ5M‰W*Dµ[{ò¨?ŽI/_oôˆf›­a:ÚþwÚNà’Q D©*Ì,c2Œ|]Ÿ.çþBTV}I“R’üRëÍm¶Ûuv(ÖÛ=ÔäeŒb-*_’¨¬‘_¦ÉT¨ÿO ݆è$²2IL“ý¼µ%QŒ*$Á*+$E3©“!Q?A•E~¥¬¬Èý»)5°MÖ%&V…Œ’)†Ì(LÊJËGë8ì  ¤½Ñü~}ï迵ú¿­Ó¯Aub~êô}’þÞË‹ûrÆ¥Òxú¤³¨éÛýÿÄQªOµ•¤J£Ô¥“GÍ¢ˆ‚°*qÐŽ#âd‘„gѦ?1m‘RÛo! Ò#-5ާwWˆUGþžòŒ d )~·UÊu]ÓZµdvàËŒYX”¤«!Y„˜(*)"ÄÖ©ZÔVªÊªÉ`“l©ãlC !*A³èˆýqRÕµe²KJÖŠKFبڂ¶6Æ¢ÑI´ZÆØÑEŠ6£‚ÛFŠÅDh¶-{ ÊØ+3V5D[e‹±¶IhÚ¨4kc&Å´FÚ-ÐZÉTm"Ôl†mcTTlZ"£X1j6 Æf2YÜ!Ã&e¬ÄHfP™£1 ›¬I™*5fR+1&°T5S2ˆÄBÑZ[e I¬‚ÌRÌŠfIŒ*‹­±­bÖ±Z¨ÛljÕÔhÛb¨¶5Z#A³%•£Q ¤À ´m«tÖµjìj1d³ hƤ´µdTF¶ØÚÚåµ¹¶±¨©6­¶‹j(ÕTTlmŠÑmQ­‹m‹mE·*Û•´Z6-kÅmhµ±mŒ[QªŠÖ`³*3*¨4óªW>ä«ód_•KÓ' zT^ÂUëÊÊåIÈNUrRrŠä”Î;«03 ™’Ä^ÊÚåE¨Ö1±™•˜1S2¥˜fUK¯ÉÙDgõŸ¼ý3nºýþý=øŸUú»äè¯Í¾ëm\}ú¼w bÚcÅ´jÚ1´–+6Цm±ILLRF1BT˜Å¡1hŠ6À½ÏW-h¢,3Z(Å&™“dÌѱ@QŠ“LÐhŒIF(Ú@L"QIb2ؤ¦X£!¢™H@JB¢4b0b61(ªµíï…²lŠÈàì#¶aŽÉa.˜±ÀqbÀ-]+m1ãÆ1fædÜÓW…/Y鮬וm]Ç'·;øÆ„¶[²Ù$5‹[c[hÚÖ4RV²¢É--¶"z÷ðçØß¯7Ÿ±ç»ÓgÛ\ãø£{ˆŠ!8(8B„Å0 P»€7›3\uÌß»|ëeý‹Ó¹ã-æº$µÓæ±å¶¢µ‹TZÕbÖÔe™VbfR³ fPâécÇù^;{ýý=|zNNöij^ææ™4ø4ÉÞ6¼ù,Ò«àoI×zäj7.šjy[e[Ke•*Õ¥¶[<úþSzwîü¿äëî÷í¦2cÕ¶ÆÞÏ-¾±ðuð•5öžtçÜÛΔyä¡I.â¹ Ú¦T¡4Wc“)"§Of!7Øý{'Nž5ÛkŸ‹üí[J¢Ûm´«ˆ“˜¨·»t«Ú6Ä’mQ±lF¤É`Å*ZKe¨«l“·›öºšw<ч¯Rǯ›$>ã±ÝîBÁ:c¹ÇB”¤¨÷m ”UXbCwk»"Á‰OÑ–Œ,…`ÀÐGšÍÏ:iǹ½¼`ò­*•Ö•©Û¨¡B¡‹ãŠÎÁ3Z‚ á€Ç%„AÌÇ:`¸‹¸‘f@õ˜a ”0Ç] Á޽ G“ø>H|w‰ŸÆÊiðп§NП¬æ©cŒ’Å6 ºXèÙjiòìRÌË Zï)qh„BBÏ9I] sG6oB£Ê“Í)= %<ˆ×3 g9³¹½ÞX s‰Í—¼Í¦ÕÕŒ»›IQ›å ›x›Ì3sµG—¹y—DrFØ•XMg—jÚu6‘Bë/›Vwjd„ª¦Êa‚<™y³œ·x«[ e½JYÉ’8tŠ1d­nP4N=âf"’Í^‹ÞsDY¸¾]Íjžg‰^˜FÈzË–ÃŽ—¤ 8n©Å‰ …ÝN[F˜±gYªâNÎÝ1¼ºàÛ"\ÔBy³É¾MJîxfùC’¹rXámÔÙÙnìf*j÷QVí$™n¹¶*wF$ªC)›æÖm+,hâ¸*ê³*¦rŽRá„§fD¬C ذÔ-5YAfƒœ”²7.ç:eXåh|L5¯2̰µ!Ä) } ɧӥ^)ÇÉÐyy§„öSŽà||6yT7™n¹™¸óò®¹ËÓ³Ä-ÝìÖU\ñé‘$—x¬“ÀH/G9œ| ™¬3jjÁVpÎ Ó€#͘‘|'1f^pðÞåÎÃ%=¡‚Uo(Üæhg£³e*!)†­£&ñt&,<»ÁNJ—&ö¡¼@ØåafHÕrHÊFJ§·TA,¶y¦]ã<ÝéÓ¯;åëåìùžù~,O©¯žªØ™†LR $³6hƒ3# 2’F0³)S$ÑŠ2dˆD!FI Aˆ#ˆPa2d!1¢’$ÈÓAPÛÂÀƒëX’ÒbË0É_#e’ãO¥³çm“Œc)X}OUM›˜Ç‡Liº­:i4iv¥JÓqL1D‹$ µÑS"ÈYHU»cËk¬YÔÆ,g¦æ¹,êrifçu‘öšÛXén¹w¬iîx8ÛÝßâ4˜¯ xz½Îªy+¥4uÖšž“¾Íž%k1½ (Tk ‚Œ!b†‚"aÆ„©p8#° .ü.ôwûÝðûþ+¾;ó¯,<…(S©¶®ì%áp•hëìú+‰Æ>ߎ÷¹ÇL}O s Íú$"F§&þdž§‹xðéfÞgLž€Ä\R‚<] 2;fvÃæý#»<=GÅøÙî~jŸ™#Ÿ-¥‡Š¥«õ°ù8z¾dðß¹ á=ù“Nì“ôß©]êÚï¥ó6‰:…›³)‹DžMOY¹‰Ï8ðnbØ}ÿUŸ›:®§Ù¹4ÇålÉb©'פÊ[$Nã%Yïw8~9ð_†<Ê1Œ>Ë¥4ÅŠªÂª•U¦ŠðÆ4`Û¦›VÒ©¶16ãm>ËWF+ b±UX¦Œt­*¶ÓI¦FÛVÔã#‰³ÓIXÓb´¦&šaEUm³Cm»hÅRš+µcm¶ÛŽ6Ò«M;V6ªcXÆ6ÇjâšN0éÑÇM:tÆœt­ª«1+Œ1î*xSƒn˜ŒtmUµ4ãqÓi‡ 0ª+ŒiMS `Æ+¦Õ¶Ó¥clb1Ž•¥URiQ‰Ó + ˜¦ži%i…1ˆ¥vV•%SŠb¡UŽ0š)¥F(ÅIŠU%QÅJшiT¤ªªiZT¬aTÒ˜®*mQ£l‡l6ÛlLiF++ V•ÛLM±±‰JªÛ 6­”ÃCE+L1Za‡JÒ¶•XÆ1´ÓF)‚¼4«ŽªãR˜¬TvÙµ6­¦Œb´é$®Üq¦Ý4ƘÙXÐÃJÑM%QD!íK{ï}{ûáþ—ïÛð"€LSDF¶‹Q¨Ñ¶ÁEŠŠŠÆ5´ZMcZ+E&’¶‹h±µ•ª6Ô[ ‚6صFƒlm±X´mQmF6*M£T ææc±¦¨t<š¨xŽÉJ¸O±’ñ¼jiÝçwæiéžÃ6~}y·çt›—síšïFPdÁpK™BCÑX²¼Åã«Ä „tÍ‚Äx|Ýýqwô>·5O®ñÝÒiöäöGlÖqk²¡^î˜õñÕén§&ýGfcsÆcn4›œ›õ«S×<ÚÓ)¤¬¬™†VYjÖŠÊÖ1iR†4„9$ö¥RõîÌÔÌ2lË&ÌÓ6FÉLId©IµoUe´|>®×»Ž‹ ±ßluºuç­ìÝyž.Ê)y°;I^'¶ÔxxGf3<µwïwÙ˜W¯×ºéÍ–µ3Ãmœ|g‚S…]*ö=ìðáÞ»íNyV¥i¥_k5õnrsRæ¸Æ9gÛ“ÜÆÇžíØìFÑÕ+ÀiÕ¢®iŽ÷£u'›òŒaf)3Ïéôù=ß?>>küõ•q½$Õ‡¿Wâ“P²#߀ï¹n¢SŒ«Æ·Ý<ýû‘⸣šçc.qàêN·[ÇâÒõ‹™otÜÎÄédl7âïÚ4IŒ(à --Òx–öþ£W'Ô=¯7xöÛÕèÞò÷üŽº¦CêôaŒÚSj21l‹l­‘´¦25Ù[JCj2^–Ò_¢-ɵŽñ¥oEÁ–úÙ5Uw®ÌDÆóz¿øTa~)ñ‡ÒL¥ÆÍŸ™œK&6™ëN¤§PûèYÜMê2N#¢¦“S­,šÎß~i6•6áÔðC‰‰¸ñ+Èèw˜˜Jðx›27 Ò:1¦W&£#Âm;N÷¨d“´S§‹¡ÂÉ_.œùŽ»ismÔ¦UØ$›Rj¤¦€hÞK³bÆ]‰IPA7à»wƒR$íV]-«Ñ{ŒíÁ”]d®ª¤Zš+¼ÕØ×"ļ( ººU6&¤¡F‚žRÂ&›Vó Y‘ ŽVØ®^—ÎM÷ƒPñ;‡Hð›ÆG yF–S|¡¿M²-£‰þ V™\r«5F¨ÕM ÓF“V­U‹÷ü¼P\\fk“e½DSz¥~²¢Fêç.™& V¥iŠY«RZ K–²&Z𒾝Wîߎªš\\÷¦­ŽU–A†X©­-TÖ«RÓF¥Œª˜'-Ò¯nxöïš{Xô7œ‰'oHÝÆa$•Š-5ZªhÐÓtÜEÅ¿§Žz£Ÿ-s¦N1¨±‘¢Õh,©%I)`™Œ;‘7è¼ÊîêM½22•q2DÈìIUeHbÊc!5”m'>#ƒŒq-òqm¢d+U’Ô™šM&´jZS‰&†s¾ºb›ô1;Bo&BÖ´XȵeUš­@Ö¦¢š±2i!5Årgu50ã¾’f•`¢¥£$ôÌ‚ÓI¹'fÆÑ$Ý4c,¬Gˆ¼HuîÜ2©XWÃÌéÑ€YDI >‹ºdŽÉ¦ ˜°`Ì#¤ ÐP”ˆŠCDÙwôP1"h‚­ÅÓ,SbXt¢ ‹*±Èr[šHI º/(PsÉ‘mÛ˜ÀË9F$ÈÍÖe Ლ€C&p“ÄlÃ'Gfø6•!õ­ÉdS b±ReHÚPäçË5—,ղ׌Í\—.·I§Q ÌLU­-BÖ¦ªÖ † šµK0d%$çz³ÍV¡ÑÂN¤ãƒJY©¢š­F¨š¦´« ‰á¯T«Ò£‰ÀÅI,«L1afUdÉ d)5Ž8ã—;ùpo¤Ú¹QZ2¥£U‚d0È2ÀÉSB;·WÃÅÔi±C¨6PÌŒ„©,BÈȈ@q˜Ê&Ü † ˆYEK,Ó0«P’ˆ°dÀ-5Vú˜çÁ1‡³9ËzäÇ ªü‹ÃK›Ëe£VbóÌåœL‹,°²Æk5;,Ée…«)E‘T̉’qé£e†åJ-‰½w¬3b4°±lã§–õ^®õm2¦¦¥“66¼åsg*[&¡¨Z7nðηzf2ww²É8Å‹Ie’[%MÆñ¹;0Ž[(IK ›Ö¬µ ®3J*Æe•“,Ř3®~;%ÙSâÊɺRrD{ï£ÅzÝ{󓌹–ê²ëžÛuŰö¢+ÜŒÀÃ$™@*H)¬U@@EíøÐîØ´ù%¾`JÞr¹<½À¸òs•sÔÏÎgFŒwå<#Áц]I9<¥ÊÊçιM2â1,3*à ±•Š¡c—œÞi­d’©%XZt̶qñb`¥[ ’Íf\LÑijY"¢¥xï§RÝ–pÄ¥U’ÈEo»×\9D–,"É8êÖ±Ù•¶ù7 ¢¬µlJ¤¨Öò-ÝŠ«2L7"ÉJךּHÉY­Ö¬ÄàØÙ,%E¢Ë6ۜΗŒr:Ržà÷"a ¡xÉ“Ó×{•D6,R/„3A²$“s²ãBI [·X”ßXAêâBÊdpÈ åWÍN¨"‘@"@’p¤¥£k[†ÒÊ;ªmLÜÒš¡Lk Qo𨗮x`.³<[|1<šºŽçaÏ Clju;œs£’Ý8FÕ\k)‘”d`Qm]K—<ܽ3&[“ž3:L‹(ªVUiՉőÕrŒÜcPèÞI1*¢ŽäêήôÅ®×7™Nºu,¹mz¸Ú’I=W¯×z­½5UYl­Î¯-X™SDhrdRqV,-Ч\œÚ'NYÈ[y“3'R5A{åÚìàä`n#˜j]U±.u’k†Ý–>›DG\uɵ.•qªMsÛn®{tÍîœ7îã˜Qv™© à‰+«œÌuY‡vUMMÛ2$!”¹†a b“v`#ÊzpÖð&ÈÇM` Yf0ÍÊĶo7×3²y’T½öé:F1|ùK'rhdC±×”ó»–ZKT¯1""šóœÇˆ–÷+´nG"F·ÝÛ1#V%8pšKMµ¶DßwSŒœMåÞáZd7$\­Ûr&¢^ên¬™.$åX²ÀÈ!S–(oÕc…´&ý™7m”Ê:“ª«m¤Þ @Â2 ëªcªq†Hh©Ò¦‘¥V -ÈG£KËnjŠH³q¹Œbæ(¦iR;NtÀrP›a4R@’‰e ’ ʲ2ˆ¥H|HÔ‘® („#˜gÀÑÊ´å[©Éap›Û«œléBʰ’¢¤nÞcË¥º\ît8¥°î¦Ö]5¬¬·XÖ°”¦G,Ô‹t¦´\6ßÁn‰· ŒooŠü¹$Fu¬2«wÇkœGêQ""£Fóâ2 ¶-20±åŸž ½x”½¦Ñ#Øö$÷ïcÂ$Ö²ß7ßUË Ä>vÛ"Ìk¶¢[ ¥ Ä£@Š$Œº›wbˆá‰"à„Ð4Óê©éŠràëìržÞ@¨v¹/ æàÙÜÜòZæKÍZ2vx.è L@Z¶MÔàqœŽ;Îg9¿”Ú8Õʇ•6Ã&f–Í–¿R±OYR´˜™*Ö¥Z"Â,¥©ªZ“$ÁƒX¢Ä«Ri*ÜäÛ‹i«¢á(p”0¬+)6­RhMhMU­U¥&¦”šJɈ“$HÌ‘"öçŠN¶¯ùÍqIgJ®V¥„ë†-¹Î,“›’I{ÕâjÛ‹.ña œÔÔrÂGKaËLÌÍ­j›ërŪµvÓ¶–Û€ ˆû0<(içLqT™Ê¢ðÒ 7eÁ0 µm¼AQíƒÎ4b€•yŠ„’8 P|,Ìiµ jÝcEÈe" ”ÀLðË$$¢›£I="°%åK ˜4LC[&  Âe—s4iÚ²,½ATÕÄTæåXµ‰€D˜„Y@–H8Ê“Áœ,ÈŽD¶6“©6òž$êhðvbu <¥ò&[¶VmIfÙ´©©[)­6¦U6øM¾Ù)$FÑE´Í± ¨ØÚˆÅI©-”ÕIŠ5,Å ´m&±U¢Ñ¨Ø“l[cVlm£Z-­Å£EcF¬m1¶+Dh­ÅbØE¶¥±lº'ê²2¯^ëx¹ysYV¹4ô­zí¤hÛ”é×Z´µ&wÕ½:ÝçX‰¬Æ¬ÅDΣt9RtÜï;M Ko1›&¶nY."…("E–Á°Pd –Ã( ¡jÌ-·c®œ‡.Ù…½F¯T[e0ö‰ì‰ò³òg”I:zwâÍ_†òz¬ÔÞõ2´›êdD43¸¦‰a© * hSoT(‚Ú#‡5 "žLÆQCN£JªhÀ%Ý8¸6d½À&¨š*„Ž“Îž‘ä47#’M:ty’lðž<¶9;˜‰&¹ß‡†•QœmŽ3w¨lãwVæÚ¶UMLêI©l¢ÔÌ…¹qzëC«m¶õ‹,ŒœçY!ªqc«heÔ’ºYï‘þ%Oyd’Õ+%2/Rjš¨ÈÅMR&š©†¿8Vb Ãò²E¬TŠÖ-QkTm­cjűTZ ªV-£m¨ØÚ+b¶ ­ÊÕõ‰[x­®Fŵʊºh·-cd¶æ£R]wQáæë4„ñžvر±lo(¯Nê,QRbÁbM"Kb€Ôl†¢Ežu¬=æ£È·]ÕrˆyÛ‰¹|oÕ>Kå}}‘¸çZLÎou\óœS.dT|ã¡QxpûmK b0¸_>ÁÕKã7|茰¸ÎóuÌÔMY QºÎVë\ÔƒV!kw?WëZ·ªI ¢!­uš˜5FìÖõ=|Ç=SäóÓ¯J|>3¶F¢Áy<ôgP¹ÅÈ c€ÈTÜhÏÇE°èj3 Lièh’O«ßW½‘{湋lÅb,„[$Qb±±I[)AŠ1RcEˆªƒZ¢±¶Å £RX ¨ÛmŒZ¨±Q¤ª+F¨ØÛVŒm½ÿqmnï”yÁžtôóyZlQ¢¬Ûh­´›»Žw:ï.òéÀ——s&õ[]\L²ˆ¨‹F׋œ6åAˆÑ£EclQ%ŠØ´¥£6(Ñ´m¢ÑhÅdÆ6ÏO<´måª-kyÑ\¯.lÎívÕxáÎòïµ»ÇV rµÜêáÍm®±®‰ÝÛX¶ Z’-F¼W™m±WƒTx‹‰«C»Äx¹¸x­xóº¶8$ksm\]ç—wo¼w]ËmÒ·1lî®îeq-¹¶æ#r¹Wu×7îµÝ×4ë´›šåŠ×6ó»\מvÛÆÜ³¼¼Åž]A%ËW6§v×%ÝW7(ׯ%àÜѹÊr®w]DTï<åx$ÕÍÍvír››»’6+;,‡:F®jåÎ ºÆÜ®Ë®îî©Ý\¹c]6æ¢×wIyçX ^Nî±Nì¹Û]+"h¶4‰ºūž0N\XÚ9«šÇ1›³Žî¹GA¥ÎÞ\ïåÜ’î눦뎡]Ü4iÜçg.wvá™p;$ÕÎFwrgN‡7L\»›¦LÝÍ:އ]Ô¤ŸÓü_[Å£E¼\Ñ÷E¼j¼m|‚ú²¼Z‚ßgZ¾€¯ú=WæÚÞ6$4WßÜÑžß¾!âµì*ÞÙ[î w³Öõ+Fƾ\¹Uì5ÍE|ƒcë×áÐùY?F±Rɯ£F©‹dµFææ ¤¼íÄCås7h’ÁÛ•"s£»mʵÝÖ9º)ÎkÝ·(ÒÆÅ¤Ôiyu×9ÝÚ±NtÛ‘V9ÛLØ¢Æ51ªæ’Ƹh •smË\+›Ñ¯¼íÉMjæ®±lFµ¡+Eªkœ¬%ŠBÑ´]u®UY5©MŒTk9nZ5]4U‹&‹b¦¢ƒIb)l‹QjbæeËR<úçÆ£v'½¬Vå6Ôd7ÚÞáom”Žÿ;’nµôáªö¿‘±éd=l“ºuVÁQ³Úëäëo˜½=ïson×+A«Ý9Zz:ŵó¶ßL^2Z5½×v5m¬[®•ÊJ®Qhµ&5BC¸»|?^#jwjÜ‹S%9rîÝ$Œ7i)eçvK•×rææç åÇu¹Ãšiw] “q×.ë–î뻫¤b8wu»º7.¹Ñ®—&ré¤URT@¨°Œ#))‚uÜåÔÐîí3§Pî¢»Ž‚×Þ9‚ÒEÚhä¹s›æ»okæÞ¢„¥´£OWnÔîî»®ºé™Ã°«—%G]ÖhÙnêê¥L›J¹Ì̶ca»“:êFbe‹6KšìÃQ0ÚwewrfD–dÙQpêîæ\ëWtîL-Œ‹šà›Mˉ(Ûlr»d–ç1\æ²$š›RZ3ÅK‹FŒ¢S]*ëaj+&MË—uuY“hÔK`ÜÕɲCI4€wtÄ1w\»wWjK(æ×)¬åsJ&k,ëGwsL’´R™ÍvåÕ(ånÛ‡T©-wWr⤃$–&ÚJÜ»\åÌrÑ9s#%\Ó®³—EBRXÔÅÎ1%"ÀUËwL’,RuÝŒjg«º¼n”È̱R¡c;·m»Û»©4Nçn°ÊxÚ¹˜žgS+»®ëª’îìT3J)ªŠÝÛrÝÝ(Ý¥¥£b6I‰©FµÍÚçi”Ò$´g:lææ×):ÒV.îwu\Úå28·2íÀ9ÆÙÝ]i0–tµÚ.L™eE´­/»ÇlcFE ´îÕØËb¬Œ•$Ä9Ò›Fl¥Ý¢èTSRÅ3ºì-g:Í.î“×\Ýv»b¨œã]uÓC;ºÉ&¢u×*¹jæ‰0®NëšKÆÅ›`M&ZIc4§6¹¶ÝN[ çh–k"ÁÉumÝÎÑnY´îªèLËsH¦£i¦M$¬’C,59º²´Tª…ïèó«•;«•” ªFÄ7usIL‹;®h¨¥¡ u«»­ºuÎ'c»u*Nê8²¢wnÔ€ œ9M# .•Û;·s†c3s]HŽt ©ÉÅsXPÝÖÜÇ*éÜë¶™$Ë4#–îmÆÌI™14,¹¸’ZŠwnÇ;M¥INërîéE<ë¢cSh¡kÇ-GK©µ›×tÔ\ºÉ³:sX“»­[oRI•Ÿb~À²ÃîXi£÷w4±‰véKvºvÒÊí3®ÝL”ì“&ëfêí²YJ¤®µ62©S0fÖL‘e5XdÅ2f—n·]wd²ët™›­$—V0Óh«+M2V˜Œ\•‚È”—.ï<¼•æ›´ë­u”ç[›¦’ÒZºY-×]S,ºIuÕ۴΋ ¤²Y]×Ç[4~Ьiænýï7é!¾é)ù2Ñ_žÿ‹ßš.©ëþzfôý–]ø&ds.–©Á)Õ&kFûª÷lnXËðZÌÙW\n ý'F£xˆô±`@Ú÷þ•^?øÿU6O­Ž£Ø„@¨Âo† 6zÜÒž/ÌÞÿEpçÁ³zô–ØóÞX,o×mOu>h}ÇÓ3ß­?9(÷V£s†¬¦Ÿ;I\WçÓd·unoc†1+ÉSW Ñ”lBOS‰'£§JôºÚv¤4ÄÕÆàn™N&.‰«‚ظczéW®¼U~‚çqO²Å˜à¯e¢ÜºêÖ¬^¿'„¿]û[ÐÝ7?5è^Ãμ•Ô—žåä½7C{qŽß.P^j·. e¹¼·E×°Ù³zòñ·R»ÚºKë=÷>óØÞç¸_Ü_§+õâ?C}{ýïK‚K|¥ÂQûÆ7J‘°0¸ÆÞ½5x¹‰…‚1—™lz²…=«ÖŽ [Q¾=K'’•ä_—Õ'á—ð8°ŸNøSTu†*|M¹.•âliQÂöÂYX¹š«¢Á¹½'Eñû9í.I.©)М#¼Ýå³Áw8weXe"ʰ;ÎÇ9ºœ Õ5|’t³â¦©liZ|X=JŠUTä¨jÇÁ¥ç¶ÍVÕîLN+rº©¥onšF|™[–_/ÈožôΗ¹4¬LRÆMÍ#ÅzI%…ˆDlÚÉñ¡¥11UX³¦1Š˜ªÂ©S V1ªiR¨ª&ŠªŠÆ1X©JSb”ÄÆŒVUX©È#u\š”«Ìúœ’M²Á¾Ý?~Vb÷ãàlÇxM?ž?†/"Ú®õÒê²âmuU_ðMïfLS½yÒ)èü××úÝ«/¿¯7‡Ç³íIö¨Æø¿n÷¢SâNf¹y_V$9IÁå>¯éëaºõZu=6èå};}î}vï2SÞ^϶ÄP"Èæ¦0S¦ÆKF42T`#A¢e#MM¢Œm!‹b‰±¶(ˆÑ¬Y5"‘†Y"ÉJLÒ5-‘&ÁŒPÈÂ(˜ÄF„0j Ö+0lm%b³q§×,˜dÃåxÆÊ=ö‡éÀ_ç°Å«ª_ÎðlVöd¯;!ŒÌ”Æ0˽…²ÂÅåtõçÐð^¶È躻=¡íS#ë»$$Æ*KZZ’R¥I%¥$²I%%$•$¥I$””¥$–JI,¥5µ«Ò¾Û ä0œ¹·ÆÁóåܾÛßqRŽB8Ñç{fÖʪ˜;úòü‰#¿ŒÊcŠÞC´ó½ÜçßËÁ©´Ûóhôôh((àï1z=ÿ OYÔîÛÕoíñÖ_iM*"|ÓCïSÃëFÓ®–Å«TX¥‚ÅÐw­Åmô‡?3Óæ¾í×™™e™þ=7]ßd{ŽëÖ{—4®Ù0D}5¸¸þBÝ+…íú‹d®»ªÒè­}Æ¥è/Wyzõ÷ìJëi??­ù¹ÄÛâækromõf÷ŽUUG3*ÎXÔ£W%)&–-ÝQ"EPЄ.ÔL‘‰¼D˜*•1+dÄ!h ´†*$ÁDA[B±Í #uUµå>„Šy­ÎvŽëŽSÙ-ëP{—…y%}{Ðà½Q…ªwîaw¥Su#ÝuŸ¥\U@n°Vö¢WŽ®ÍÐìIØJâäàãvÛÖ’õp“¢FN8R}ÈDsU<4]GBžIê“­âº=©‹’à‡¨÷Ý{¸çO‹Å™º[%n±;{pÞÜIèä¯"öÏo¹–}_sGåüÚ•R÷SÝ,e]î=Ëç^룱lQQY(0Z$Ú6´[F½/D¢""FÒC»¤ngtîìÆC¥ÐÇwsuÝqÝÓ» H19ÝwÛ››tÅî’r:[”ç;Ý,;»&Ç]Ñwq†šw_¾3|‡Þç9Ü9pĪ}Ü¢“îëW±ÎÜÚåmi×—Â:ìÍ×eÒÜN»©9sucJ HÀ ‘i)ZMîéwwvéÒºáì±0MlrrzyÉ,ÆÝ:yuÓŸfu“ǹàÝ¢ [%¬[F²m±¬ö»Úâ»»S!,š ås]BæwÜææŒhá\ÜÛ›;ºmÔÚé\·$¹¶Ž•4•Ë‘s'6áìîÎä¢(ææŠwÚîë.s‘k²É·wnW –¹Q¤·7Jæ±±ÌX·uÑTn\Üä\—u wvŽ\¹tMP'w[œ´sw;rŽlPdÙ6‚Ü£×z÷µz½[ÙÔÐG 8ÀAu‰×S1 ‡Ä:Æð1pù:FEŒŠ ‚20DÇ"¡Á°Üc–.6È‘ç±ÑÃk]XéAWB$H©0Àà&žZtÇM'‡‰^‰5:vô{NäîtñrGaaR5¹ÂÙÜd'kfζJJ’Ö’¶JI-’¬…#¥;ÜùqIqnÇ5µŒ·5Z¶«9 -º[,Ö£¨a72)v¹­í­Ì«Šp\šJÚ;­­(áz–_\Ædc2\\KŒ“dÆ Qjfa“bÌÃ$¥“ÝÈnå÷#®šûEí²¸IÅÍd£®qä¶Z¯uuö¦þ2p"Fªh<ѲĪñ%}"^N—†—>öO&ÖnÙ¦&cmo„­0߃16ª)ƒß¾³Il3èj5¶ãáHD>mõÄÄzä®ÅÀíÊfLÁ˜³'?\†…ãåãCˆè\î×’ÝçA¸'6În1ÔqÆOÇ*ÒµQãp]â š¹I²<•>[ã^“QãÂÆUfDÅHhÑ¡Maœ\މC¡¨c¥SÝw[jý@û÷¹}n¸ŸÃ…ííW¾Ë¥y]æž-]¾ŸÄ—› Ök a³Ö6Âr Þb‹ñQÒ#Äù>Aê.»®ÔÍ]ͬî;|¥^™ã\Лt÷Ï5éñ³¦õ]éRÙ–e«Þ³UmUg3smÛWÒ×9‰“lÒ›±”µ­æU¦¥4Ó#V9ÇzÝqgM"K’ÏÀ³k·Èɉ÷dDq~©+kCç—·çà_.Z·¬½›õ.*¨sèc.$®l:­þTr‰q~9YÊ3‘“ÎeŒ«Õ:â¸Iñˆæ•:iºÙéZ5CÛJ§sµmwGSO»m·#Kz –øÐíYƒ‹¢ås^Òõ—Ì•æ¹Ü;>»0c+2˜Èõǯw®"HÏ¿¥«wü[+lË…XÑŒ³²NVÌÑj¢ÒY$­IY6Jf¨ÛØW,ÍóunÍh´ÌL’ɵ–JU&Mb­&Öö¢F¤´–Yµ–ôU[²ÛÙ)¡!¢ße 1X5aµYPÛ#cUiê¬Ø!2°f_xØhlÆôµE,o\÷«j§ÇSÚ^űñ¤ÄñÕÎüz«ª—R[[êõzõoVÄFa èŦ"Á$Õº"6-ëvýöo š«zú¾ƒcÈ8‰£•):EÎöN.W¸ÔŒÉIE¾/5®2u×Ã7ã–V*Z´ª›É%¾4™*4¨üf:q|«ð×ŠèŒ 2T;!²ÙRM2iT÷Iáöé)£ÑÉø•léZinXô^K}[%s­í’¶¼ÅП Æù%ÀzÏyütJ|JuÔ°s,¡ÉNÊ755±ˆc6ŠMnLŒÚ’HÔÌ[$†+kM•ÊÊ©²1Úo[Æ÷»Ou#ôºÒxךô¯§æ”§¥ëÛ£ÖTÜ–®óv[(i±ë]Ïcô¥S¾ôr–:Òò0±†0{'ÒF÷+Š:>nÉJºîIJë~%Ì)ì¥v²Ç†»‰ä&õ𮳡\fî•r]Ç¥ÜDŽ}¾Êî¹-£Í'ÚTÓɤcWЉ¯+UNL• ÆÆ .—Kœ©è'Gsj—5Ôæ•´G:€drÊŸ%Âëd`ñVû¡ÂÙ™eV<r›Ã­ÂwuGCÛwt‰rpv¤¶ué׊ÓNýt-®¹uÓto}ƒtoY"õ7“SPÈy|L”)[¥•]IXp­Nê’eµ[ ¸¨”ÝQ#”puéÊ y#IÞâèïâÑKO"E㉠Þ+8#™9S›œú<‰ðç°^ÄŸÞj³Pºú—[.ÌMÒ6¸ü ©c2§©ø~¾ÿOÙ_ŒâÃmŒ¸¶úëëcuøWzî»ÝPl7»V“ÙŠø[ÎëBpGf¢Ôy£Qp­Æäâi'gU-/‡u›“ªÊçQ#iÂU1zëg¬·Ž¬…1Uò®KšWqƒºøï%I? ~+pnŠï*SîßräñÒËœJa­lšŸEö-ëF(ÆKRÆRR$¤©e-’”¥HšJU&«IK%‹©;Ýc«ñã#íüg=ÐÞãê²üù9)wÕÏØÏ³ùZøT¾•vûMDüObÛ®œ$,–IO‚È–)e²Ê¡‹+î²g‰‘-¨mŠ˜ÓU¬™—»³eµ–YdÉVFX_]ÁOñx¤OÀ¨’”x~RIø$F›=ÿ‚éÚ‡cnÔ­„F6µÑn-QÚ—ˆê.«o7É­{S$mMQ[)™¤Ádبš‹L–Éeó:ø•óâr\‰Ñ*ŸC’»[54Íg}µV‘]C‰ìüh|Sä²…½Ê’¢&X–?Q¸œìŒ±Xn±[™uG£¬°Õž¨DŸmO¾N÷Üü³sЄCsî«ÚÜc+*ÂËyoî]óîA7ýô¿ =NÀâÇÂý ׊1 Š1)!3dÙ& )‚ˆ1¤4@F„ ˆiC¦B4B2%"$ˆH,ÅÌ$ŒÐ@)""ŒdÈÀ’˜‚AK¡̆š)J#”š4TQ …$–‚-³F !LI 6‹ˆHÀQE””dˆÐBY1LÀŒDƒ@LQEE"LRTRQLM‰¤Ó1²FÌ™aD¢4QŒ¤E"Dµ2Å™hƒ#"1Q&e’ÄR’F4„T{ÞÚ¾Z×–µ½‹mï«å¦½Ú®ûV«/ZCä|ãa[¦ó 1<‘;‹qJw¥2­J¶»cÖ“ŒV÷Qc‚=KTtUMêÜVKÛ³æ¨SÓuÆ×T±U ³e¹¥‚Þx¢SŠXC½’Ò)½n:.»·}Í˳ Át9UÅlm½tŽ¢ë¦ê1‰ŒÄcJ©ºŠ²†–Ѱc›Sf,“F¤NHi4¨Þ¹:ÉÉö ò¥L¢\é9ŒÀÌbÅdÂÆ+IZIiK`F½¿‰ùßÍüÿñ(±•W™ã•OÚúZjŸ.4ÊcŸ áôm©ù:ÆÙ‹‡zÆæ,ãÅG iÖ~´oð4×rã¼ÊSºkÆ1ÛÒ¼ÕÛŠM*w˜ŠÉLU>}M4ÉÏ-&íSè©…o¶rVXêÕ1ЕЬfê±·æ6âíJV:}4µÓgiÑãŸoS)˜+ L™cN3zV<2mîIXéx錞™5¾%)UQJŠ¥R”ªŠtÕ8œacÏŒlß0«1“'ØÛUéäy(ÉI$•’½rºR’’YU"ª©Tª’•*Ž;u-qK§¦¦JöÇn=ÚË<Šª4º÷Á!àÆm£I\rïßㆻ¯g…mZ˜ðžU*•Q*ª•J¥S›˜+ej³]êKaºÒqTªªª[$¤¥)iJJJJK%%%IY$•$µ**´pª7Rb¢±XÌqR¥cM)¢iŠªi¥héNë6võÊ’¬²”’RI%”ª‘U)JP¥)EUS½¼4´¬Tª­)UŽªi¶&So|ÇiÒ”QU*©R©Ò±QYd«,¤’É%)]+”T©]uÆ*Öѵ6i²°òô²T’We·JÉZI))$ªJK$•’Éd’Ô•%%²T¤²’²RT–¤¬•%K*¤¶I%)-)%d¤²J–ÕQT¥ITR¤UEQ\qÕ䥒I%•%IiiRYJR’¤¤’IR²VRYe•Idµ*Yd’ÉI-”²RYe,”¥’R¤©*JZI)$ª¥QTÒ± ”¥b°¡K)I-,¥II%i%’K,’RVY%RV’YRIu×JRJK%-*’*¥Rª“ID!ˆCÈàÛÈăƒ¶‘âÈèÓG=Ün’©³S¬xo·|Àü$õûžœï]Y'ZÂ×KU9¥¸ ݹ¸ß‹Ã+“Y¬*1,ÌÆ¤’i>§˜(ûÔîê‘–a•‘K U¨˜™ ožá¡‡F££ß›8^=|TŸœ÷·Õ'sú®ç±ø£{¤cÑßRL+À¿ ò'‚ú7ݬ˓oìnl^s†î/,ª¶•µV™É£m§¤õè–Ò÷>‚“JÚÈÅ“%&“Ô#ÃÌÄãW­çìbCê;O¢Qä¾+{épü`å—G‹ÉUãÙÚw+¾¶á™ÜÏ™„HñÞV'Q29:’·ÚI¨82ÕÓšà:‹eŽhåI4²M³23(³%в¤˜Yd8¡F[XܰâY]"×¼å²ÌY ‘— Í)måƒrÒ“Å))IT–’¤¤’J¥,’ÊÒ–Éi%¤¶J–I*JRI+*^çynÖ·ÛÍ[1g±<Ž¿[¢Ý{n"#ªJl>¯¢èù8_g˜õý7™ 9î}ä÷–ëkí'açÚ<ÓÁf+Õg¹JdzºÊöí—ɉKÌO{†Þœu|_sSãD|ÙJvý/z=ÿq__¾~+§ãÿ$ðÓí×á¶óM÷ŸfW๘pxxº90ÄâaŠŒs½§â¥ê¦ú82F‹f–ÙÁ[ÔJiYç®ÁäÇœéÉÊ¢GP5îÇq_ ä¾Z»V¼SzW{ËoÕr\üO(ä5UºÂÄ1˜IŒ |áäxo„o¸÷eTb¬ÚŠ *´ªXCV˜²Å0̱FX"1”©‹,º¬•hÝ=ÞM=Κë¤H™õv÷µ)R£9$«U±UiìñølÒU˜>¯öÆ-Åϲâ¼pÑ7»,Ivœ,“F-ɲéM[QŽ7ì·A²P§™ÈŒ³ßMY&¥[[Ÿwø_)“I¹«Kânëy»]ºšÝÙu‹&ÊPeT¥K1êhh¨Ó&%¨R«»v$$W]»24–LÍ˦·“W5&–f¥²žut¢M®ìçåÌ®–ò]yuy-ÙM)-’´Õ&¤šîé0“"H"‹4¤˜ªTª­$¶W.ÒÉ,¬’Yd•-,¥d¬–YK,•)2VI-%d•*ZK%©),”²’Ê”¥Ie$ªZIK$’K,’RR’’KIRRZ’©)I)-d©*Kl•%©$µd­$•i-R[¬Fë䶪N´(à. ½’Æ%u.*LœjàEYY|©}œh‹«µhé¶qgsM¬.”®ÛòlÜøËq4"6Ñ‘VéV#À®Io’š]Iôþ“ég2©ÏÕjf³˜ÑË!ãéM÷:ËQ…°”ÃÂNJñ’dZ¥1×Ö3îjÈ[+bU%ŠPÖ“b±©6Û)E)-–T²•L¥*(ÒKRÊ&´¶ÐЦÍ4–k*–d’¶É4ÖÒ˜‰iYeIEµ62Òai0jĶÙM%,¨a›KV™-cf[j`¶¥¶¡k5³Li Yifˆ%•I4Li©4¦JKY«%lFÊÑfi*fT‰Ll¥im´«6l–jY™ªÓ(›%’Ö‰‘´¨Ì6ÒV´ÛMl©d,ŶlËT´ÒJRÕŠl¶¦Y·.Oô¸òŽ¥Ôf|( AäD!@Þô¤Xžz[â8e!ÀL(W èWãÛ&ERà8Oß?^ÜäñÔ+‹(¥Ã«õ6ÞÇsª3Ó‹iHáðzžÇo<å‡røhH-ƒ@DB¸ÈËeZI.VHÏÑ.6Ð †°"@XºŠØ\^œBÝ`_ÐJê¼F@¡±Q¾"Ç•¨à'p{Xi†+Ý·k™Ek„¾G ÚÛØ{ŠÆìõ·CcÀz¼×O7+ç¤WŸÙïy}Ô $%€K%}f Dg €[ìÙ)ø*ƸK@+Ëæ<›·+Õ­?aƒÛß¿Kù>Hó'wÍz9>õQ$‰çîî·rOSÚŸ(v·µßmÈ’KȾÆÍ¾nn–fM›®z:{ëàñnç¼qèåJ¥½ïïû¹8¥RÚœ²Íºg„¤v¼SÛ¨ "M½)ˆ$\K´g« Bˆ*ÛY $Ëv†ŠZÇ…8òÚf|~Ùëü>¯Õ½?8ç˜/nÛÝ«fGPùzµ_ür|gÒ²z~Jwµ9úIù}½ü§y­Oiù ×ËyýÎjöÚV²XYi¥.ÕòA$ƒt¥EÀÑÁÌ’ëeÖŠAxX¡/„Œ„¤ñx_ãÿr™”-¶Tê-dÁÙémuÏ·Ç¬ÔøW´‡ÌÝŸœ~»~÷Óð¾sôFžá±Ýññö¼õÛ••w]ëð-úúo'—•Éf2¬Ìu¤HŸCCE[c¿,šØöùåú|úîé]ZÙõö^{”>÷Q¶&Fg×e«!‘&š…ÄÕ÷-¯‘À—Ç®rÜɱÎã¶ç.]×xá3DÜéŒIçW-wnwW4¼òç2YݺF\ä ÝÄ‚H1,HF"ÁB2Wvwqšî‹´Wnì]6çMÌ.î'quääWˆ.Ïjç‚ J JH)#j$H‘Š$XÐB,¢ ØÇ-Ì%ÈæawsÒhîì9u¼Ò$ÞŽËW‹¯‘ë¥!»¯<ÕÝÕÍw]¹’2DˆQkÅ Ä#JÈ•J9!p¨îv㺺§-Ê⻹uÜhÎæNë±ÎƯW™D^5ÊÞ“%Ëž¥â¼`Ñ®é0‰®Eºrák»·4o<ç‡Tjônk‰;¸îçwlî¹W™§wtÝèᢱâ4W]v¹c2½<íráÈÈRlî׈×4W £!ÝwuÒÞ:lgu¼=9ܧn†ó¹—zI×nuö¼”s^M¼˜Åâ+oGŠñ­s†ÞyÛÑ­‚˜ $’ †HêçÇÐÏǃøç?sýq%êû¶69)Ü~1˜™,G_#‡~CylèŠÅÙÄÉÇóÁ“åar]éÎüËÓ¼Ôl µŠÅòZ¾ezžøpÀl€Ú£»#¢Ôší§Cqé~€ -Ÿûß6 è™’×/ûË€µ?IÀül‘gaöúľٱVL¨i= >»A³ïX_ûÂt[-ÏËð€.rÃÚÆäÇÖÆ°Ž@>èüC¬d7’‡ülÞ!Ê¿ccgÅoœæC?'?Í}‚ó¬(Ôºå¾+¨{4‡÷Ì'ÛI‘ÂìÀ¶@´…Z¸XÚØâA ÷Yd"œˆõzþ—ç'oó˜¿Ç»‹Ýo“\ Ô!´ "'’„îx&Wnö@HàöÚÂ1P ©ˆƒE ÈsÛ¿Àj@4þu<%!} ³V°°›m˜îsi¬Áû#xÞtÛ>¦žß»ów2$×îót­Â;M²Væßkª“âñ¿)ÍŽòýÅèÔÚŽ.Ðw¶+9êª@M§Ãüü­îÐ>E·€íÂåó5à®,›òn´4½nÇßcÀ“÷":yÓuÀì» Üÿ‰CÚw×A´Úg{Õ’·Ë–OCí@ãÏã@ôÿ6W¯¶‰õ3É ?Œ­M@Ÿ.†à°ã\zÝ/çíÅí` ½ùÐu2.d÷YÈÕ†«ÂVÅÈèóWÛï‹#º# ´|=Ïý+À&ùצ vi€8dõÍ2ËT\×P6-Z×7m ‡S¦aÈ’hÚôÎEÍçóýæƒaDŽFèm“o©ì+¦ÓÓàøàãSQqÑ®Üvîwþyé!W3ÿ]I5Ö{+DÜî-öŒë5µ}<¿Ð–úÏ ôs=Jù)zøf‡¼„õ:%¶Þé‹“Å–xÑn4ÿ s ÂѯÆhAlŽÇ¹¡m¶+²:ßNt\¼îÈ n“‰Ð€moî¶–¨þzßüýs£œèp|YšÏÕRßu†ˆ:-^ŠóQâj5y±ŸÍù^PÏÑî¦W÷Ìô˜¦`á½5ŒœnW£™ázºÏG+¦Î|_E¿É¾ën8yº~7„Ὧc’Ÿ.£›¶‡Ùû1Yn7^þ–ÿ­à•/ß÷~Wèhì`õs9H\ò#ùÃðŽó^|)£ðe7äÄõ´º8¯©‹ Dòå7%S>„ý¯]}.“št÷SëYù¥ïSﳓj{ìÊwwõ¿?lj¯‰("€{Oœƒ¾%ˆ+î!”–€J.#óQ½qˆ0¡äÀ…ÖØ”DD"T*#ѽmßs¡80Gj}^Á-àÍê÷€Ü½p;-.’}gÊ·ÊB€<Ð8:W˜sl»Ûµkdæ3j½ï7˜<ô€Aòh\ŠZ Pdûï¸ÐDÀòæ½ñ÷Þ½öåM®ø|úé¢*x‰¢bdc@¦ÄÄÓh4h†LѦ¦Ê,\-¥ ߌ¢ÿ²EÒǃf ̵R‰)6`¨W3tx¦—‚òd=J1DƒJÔI¡Ý¢k‡21oŠŸ ªØ¸R"wÙãµ%GPå­@-}LVõ´ÈqÏøN7ÒªÇä¼JÌ'¸üþ ˆ?To*ˆ`Ý0s¬º„„ŒwÖ{•·Œ\Õ‰‰»¦ÅËñ[ˆd÷L¤´¶/ÈËâHŒ[øÞŒ2fvÎYÿV§W'Wë”Û¾K^£ªwƒô~,݃3:ñØ»]ÔGè %3Ztpóž~¼–_i2˜O ‡Œcãf~r·n¸¿T§ƒ|÷m€ªËSD¯âéq²ñBûOûcSÙb%ký"5ÃùøåÖ®vÌ=)¹`Ë•½´óÝü²{éV{ÃWlUþœp*{ý]ÍÚ§ ’=ì›Ó®%Œ÷£{¬O áu­6³ãjšr¶µ]ãþ {×nK‹ŽÝ­æËùàãVÙ±Áóa÷éDóþZë•÷ÐùÁOI%‰Ïºÿ/!æ\kÕ5Œy•pV ºýW›· ¤–׸°È2jvM·MªDßBfW|4¡Ô%î²Q?Ün3ž ½ÿ¤<{ÿE½­Í7(S/ oNÈ&vñ²Ê€Îqá€ÚÞûPý‚îÑíGwöOW:DZËÒvöDŠˆÌ¹ÜqÛ‘?f?´Ù9‹¤þB’HíÓ«u%ÄÅæü£ÆEÖ‡z[pñã\#íäÛŸä•h›}œëV·¿{q’c€ùêžKÕbÕöÉKÃ`/KhëöžWO`ܯ]n¢#†4»¶J™ê0ÇG¬F‘¼Š+ðdß”ò—fí0‡Ñ®¾‚xxç®òÓÏŽÁ·¹ºçõÎ:)C‚æ[UB´5ê?¶ ²LtÂëÏǧMÒjöÔ´¡G[½iÖ…iÿŽV¼#‘N1[ÑÝ’žÙ,CPÒ ›:AÓP?ƒ§syÿ*rå?P&CÂö šÒ=h+Øø0«„ c4€ lhÑ Àhˆ¦m˜D@ŒIÒZ" d«÷¾ùWò|ä/8JMø›Á_£*€HDßÔWôü®Æ:åí ¸äº˜Ç$a%Qüâæ©4˜®6‚þ)MG`_zh•&J ‘Ç1Ž)nEÞÅ0w"Èß+öúï©Þ­ðÛ9àºÜOqå3²[ƒ×ÕßìCž®Ýtz;kµN4HÒ8=“Ï¥+¾Nr…"õvJ 9ßP’š¾"g,‡ ¥êÑ 9u¡Ìƒ¤ßs±”59Äž)Ež|×=RhëõqQ××ü›Ì¿,ê~UÚìr/Ï3£¨ö:ÄÇL¿D9ÓÑ˘éÎ ~ÓÑÕKžß.´â¸’ö*zêÞâ/ü\HÁÓˆªPÜp8ÎÄ#ʆµQÕÕ£]‡bÂñ¼^+pYÝhfÚ=G×zZúI“À¦[Úz{žÏ&m¯ÖÚñµnrôtðôÿ¿‡ƒ[|ëú7wÇŸó•Ü~ïð°:Wkqü9â¬ôiê>Ò9ÝY±èœºyÃ<úc ˜GÉ ç!M«ÙË%\€ÑæßZ À,@0ô8©š?”~çÓ"ïO†ôž®~yx$7Ìü¿yá½9Ùˆ†#J­ KM‰±m€1Õœý§ÚU—× 0alDET‹î‰‘%Vliϳ£hRǪð)Ã÷0No”Üÿ¯}•’I‡øƈ’úO‰4ÿ—p^Kï««§¥Q Ä:ê·Uâƒyž7zÿ¾²zßàZI«E 4ƒÙŠ0Zœx~G®âífáãøy{y“!¡¥qÿ+ÈŠª~)É" AøäUœx"ŠŸ Š  TÁÓ@ !€ªÅ€ÀŠ(¤DH «æ`ŠÉQ ºŠ…`‰5JjË[TUj¢l«3T@õ—h*¨zðêøž =ý%>Ãé< –Ò§qd_'½,Ë ÓøïÉrç¶ÃvíÉ¡œ ”‘±˜@Z ž^PQ5•H…™D©„§oJçN§O¿ÃèzDïEƒo›ÅrÙ>>õâÌD·.®v…˜P@ÂEPêA/6ÅDC¤Hd`¦"e(’TF‘! ÀhL Ó›‘4†Y™¡34ÂHÄb$‰ ëŒÑ)…K†‘¦@Ñ4RÊ4Lɳ"¤H²Q“"hLÊ62)&¤IJQ(-&(ˆ‰ µ³6R)‘DÓ)˜Ì¡D˜")‰“®åÂÁ‚‚1ÂÁF4ÃE’Ú‚ŒÅ–FL4f(˜¤¡!“`¶Ì£Jh¤´P“5Lˆ-™´Eˆ­‰4˜D¬¨´ڒج&ÔF(Ö-E¢ªÜZãƒ@¾€™3w‡b æU繋t‰H®Ð›6À/b©°vÝk@šì[¹Ý­Êë¬E$&LÉ BD… %ŒÊ1&LM2#w—„´€HŒ 2(žvî~IòX±ãÃw%²bË%éB›5Y¦j/&t˾š€­îvö®cIWJÄí•K¶Ž$áªÝrçhq4FîÉ£b¬lfÔMXÊÕ‹,š…“†jòwNë¼bÈšPêð},í\V«ÛÜ1jâciZ&ñn *eöç*%\R—šš—­P(ÊۜʀÁƒE™…vWh$1";ÿ¯etµÕAcVBŠKQ´Q±@ÂHø¼+Њõz^* "²+ dˆ'bÑmɵѪñÛmÓ½»þüŒƒ`(™Ñ̘vx/®ï»ùãýny—†ð;{9sÈ·×Y©š™jïós335+3*³6Ë-L³53Zf¥™¼'ogí~ƒÓ»‹Âø/ îõéÙwqŒ0!0^FÞÿnê#œ²…¸øZd.//ÝadOx|c ’ònã7]‹!jeïoÍó28ÂL,$‘Œ’n:çK¯×ë]Jì±Ç^ŽÁÒÓYЬë.ï&Ü ¬NÕ·/s‡œ¸O4æ±î¶A¨|…j§3hËr"îIRû4©*Šz‰„ó-ZôU§»{¡sSŒêäÌ\K¼n+*!ä< ­zÅ™Qpã,=’V¾ ó«]aYVméá9}Ë2æ5Ù±Q;qWƒ)öÓ…#uÍ«¹w©‰9Oy¥ê" »wØ™S/‰ÍÆšVɽ02÷ #r’­ÊÀ‚껥–ïog*øá*/» ²/*³r3'LLù¯Z*ÛÔnÞFê.5nÁœ¨¼×¹ÕT¢ÅpncæðömkÎ^#“|¼!å1È×ÀÌò®nŸ¡ùÃïFpô”ÆXš‹—²5ž&*6d“…ÌLŒ£Sµ¯[4à­£oBÞ6"DlÛÔFQ»’ˆug1áR’û6ô×xºÝ®¯2"ösu<—îèð#4I-¤¼§ÊÕ”–=É ES¼Ä—/b ØÓWµÒŃ33sív˜’ʼn%»‰¤©LqDSɨpUvÈO&atç#¹á°ÌxÏ8¹ÎfH±ã\äкspA'<=Üî<Ÿ¯kÊÇ8ço7nïmËÄø ^=×½•àû{îêç/oYYš™–fVY™¶YY𙩩¶jU™fffjY–[’ÜÔ«,³5,µ++3S55,ÔËRÌÖ™f¦¦Yn]ÍÜh§‹¹»Ö­·Tñg@$¤Ç4©xC0¨)ÛÀõ**±ýT<Ú •PogܾQA ƒr¡D(„!%V-Š6IHÓ)*)JŒ$´ÅC‹‘eXÖ"ÉQ¨”¨åPØÉUdER-8Ð ™Œäf(E`H´‰cŽcÎÖN0¬Ž ˜#„•DÃX.d• ŽFN,Qƒc+’Õ†ffC™˜¡âä•MX.5ŠBÉ8*ÌTåD’E$#F5‘$ʈÌäY"Ñ•0̤9Y46 T$@¨ ¢'¥ÉëÛ]€zí{ú Ø"(mŠ(ÉpF "FÛÛqŶ9- Ú¸¬ä“†V$Õ2YD°¨ŠâE(RcY Š †`T—JɱUÆÛ´m¹Ç9(B@ªª‰"HªÏ6Påx/Xª£»’®­)àk±ª¨«Ij4E EIdR”ÌD‘KIH“FŒ 1’’³ 3E"’¤‘a&†‰¢ST6µjhÅKH¨Fb#BS „ 2XÅ"Ö¬l¦˜ )ÚÛY°¡Z¢4FÕ†VÑmLÛlˆª œ0ùXi©ULL] ’ %@¸@ŒQ!{ëè•TNWk±¥K3¤(ëªÊð¹EBÐ1@vë-QF>kõÍëkƒ"‡u $@Ô­'»–i•2ŸçÅôsc;‹Íí3«¹ƒR—}º˜Ã(Š“o»Ñ*ì+°•ð¬.í˜h ݈¥„DèQBŽõß1ÃÛ&ˆªçtÞµUvÝ"ÃüèZ8Ĩú‚:+Vö52«|?ï™”˜v”zzyy)P Sž6p…K[9Ç$Ï  M'˜5ƒVN4ŒGŠ"Ñ“)Ð餕!ÓôX~ÏÔ«°££×îÏ_qœì§MiÅmÞÁ­¡CÛüá׺Ç'ýé{¡~áÔ|ÅþH:¡YÞü©ÄÜTѼà7׺Q¯¸Q¸æ®>û¹‰ I¥HXj†ï¬³lË5,ÍL³53,ÌÌÌÛ,Ë5532Ë,Öš–f¥™™Y›fYf¥™efjYfffjYšš–hŒ„c ÀbÖ#D/ÞKRùåJáźR³œ ¬EW:^Å4EU¿`*µyxß F÷œVîP—cäñáî„ :ð§O Ærg‹²8=·x•½Ów`1¸,UõºÁ†Í+‘†·‰©Ð8çiÜÓBµÜD£ÒÖJ—-éÀ©×ý=KD 8¼./6Ý]I8›ÞD­Þfå}]¶ÕåeÂÈû¸,âðIJ6Ž÷@®·WÕ½Ú¹¸ˆyÝMÁ6mx¬h I ÌÐw¼…$“+mû¦ñÏËÊì:è×Åzs§;îË··µ3d#"c ×¹Û>Ú¦ãn¤Æ)‹Ý‘M A‚‰‚@‹1&)8µ9'*¨&HLX± ±$‚DC»ÕÛש׻Α³!F$A —‘µ¡ì›¸ÇŒX† $Õ¯M´°d0$‚ ˆÃqP!·1©€", ‰%‘H‡wŠ÷vwaUe²0€Ä³Q¬y·/nïT+"1ŠÈÒâ¡@C‹ví×]êæöï±"È$’ID’@ ’ f-€ÞDÎÑw‡ªFçAÈJÊ«.ôåÄf»Ü©«ŒƒkŒrØQ ± I€@îkâ¼Â%ä(g¤öðjCfC¬°¼œ™ÕEÄ$ήþõÜpÜAQTW{G8Û‡Ñu¦6eâ!¨LAt"SÛTÍB˜¢7^'j„À3•·*ŠJÌŠF`«w…© ¥fTŒPÓâ©¥Fì=ínȨÛzª¬¹EíQ-Z¸§ª«½J.TKÎNiÓ¨ˆ·|·{5IÅÄ#+t(´><ÌEe†[%\Jɯ†kÛÒÚX ãåÙ”$B–™9³U”åìb¹‹G%Qµ” .UÎD<¨vEõö(i· M\ÔT„Öw3·5U{ºq'Òñ±RC332™ƒxOOùaÕÞÅ ¤ëã\âz¿p÷f9z|ýqTP«Õä爬‘j `}•òòéŒc—:Ö¸Æ5Æ9úƒ\Ç0ÿP½ñr\phŠ(RU›ši®†˜ÍÝì3­íÄÐD: ³2A{3§ ‚lÆvþ²†.ñ¢*ºšªÂ"È$Ñ «ÑEV—³PWj€ˆP!4ÏUº¼`\¡$!!h„,I¤aDŠ-´I¦ AŒ€é›ÓMÍ^s”4#"% EÖ˜îì‘RÀ(AÆ—¦Q1Œc T‚B&kLåx¹Y ’(М|aÆúziCiÀQ('m7·÷NN ñÖq²®ä² éˆ œ›ûf/—qUzgM4Ó@ÌÎÃãôµ-`Ë%UR21NPI×/s­ÝÇ®ÎÛë·ë=b"ª3I&©6“RdÖ‘XšÀÑâÛR¡åÁU`³UX6 »@ª°v]á]òd9;!TÆt°T ^? 5È„«%V%@n± »À·Ì¼ebñ‘xƒ’!Ýt­° A ˆi©ÑêosuçsµÖ£bVÖfØÑ„ Š(&H‚RILJD” èØÝY4ïvÔ2Îî(`À3pã4Z¦mdÖkdÕEXÚÄËh›X¶ð•ã«D cNtçK HÈ’$aˆÄmZ²¬µ% .¸.ªðˆ-‘_Íôß_ãAK…NñDøTðaÁ)×ÕU2šN“*RPD«O"$)ͧJpþƒDú¥&$86â)Þ‘\?!vrõnäBXšS#³äüwûw]×t|•ïÏÝ –Ùè÷å»ÎŒ/}Ç ²ÝóT{ÛV¦¤¤&‘²;{rPZJmï˫Ń+U¡­JĺµÏ‘íšÝ&fo§òü¬7³Ç »ïjﺎã LE‰IˆH„À’Jˆ&Žäމׄõs»1¦ç\ìQŒ@Œ„@ŒFEDÍš#FˆÖ».UÇN÷W:õê„óM·0‘C¤.q­ÝÒÖQu%f±%^ Uªè¤TÚŽ¸Â‹•Ê£Žä&«.æåè0ÁËj)eEHƒR51×z»ýÝ»©¬*ÝUÔnž@bA‰  İ€ Á˜«ß;µoYÎrjX¥j•X¹0<;©^ûı±_M«´†Îfÿ3N4ÎÎx[ÝÝÛ¿ÝÝÂ4%¥q,YÊÇ Äss1]ã˼ 4ëcgLbI`ňÅ Iw,˜¼bª½UÀIæ™É*fJ²ôí{ùGwÆR<ÞÊ‘†Í¤^«äÇðiÉÛvÙ7:U¾ÔÎV‚ 6Š(’JQ„Q!$AniÊSy3Wwwr/6µø€y$H[N÷ö[V¼ÏV…jZ–¬Õ•R©™%«5e­0˜¼nª»È«•X „B 0,X#Îq%f¤Ð«Æ%UµET—u.åÕÉWæA¯þ><`tt` ˆ%Ï£®&:cªtLuælîÚÛ’D¢@‚’,ˆH‚ UÅÌ9z“S{Ÿ¾îs·§uÝî÷¯6ë­u“ƒF’«Âm唠ăd™¢) „V];z] €Ä”E4#"ÄdÅÄQUÝå,WîîîÅwaº§%ŽmUjî®ìîéâzÀð„0@·aAƒ 5}|æg®zc®®«+%ìM¿]µ¸ ”# $$b’6Rsn»žuÞçxU¼KÕ\fmÄß&;LÌ×RŠ„L²pbV¹»º›°ÜÃÉ<5åþ¥ä¤mëÙêŽaØÃÌ¿l¦5Z*SîaX|¸¶ „ótx¯‹=C8ÙóT+Þ=êΟ¨?w»Ý¿âcsœ4?Äë‡9:–==~ôôxû‡'•UéqüK}ohUå½M›ùA«—>êÍibÜÑtC‰B‚u ê_éµEæï°*$c½õ´dØ0Š«q*!òÍéZó™Û«(J«cQó3·s&ûåùåCpAUí *sÁUmx|[G !#®ëq.1(Ré°tTivåÿ+›C¢:”NFu4[á¸VäƒÕ-Ò½‹N¯@HcìŒW’Ĩ‚ßU¡¬q8:Æq'Èkp´¬ºd›ó£ŒWUhPAsñß„¨ŒGw˜äàU×N®b*­õ%òªùšP l ÏL@‰9ÑÈxÁsNÄê@*½°fxKÓ¼ \^>XÊœ—LÛÇ’.m TÈ œ[B抎Uh{ÏØ>j·%Ëå|K K¨réJÒ³_Šæ¼Üg¼øµ¶C¤LÈ–DX1š„±΂]’¸µç²{-`ÏÑ"™®7õ~žªSÍäÿÁí'ü^×rÝÙ ¢ÕÌjzøí™•\8µ.c®…¥ÓÌÒü®þþ½ú݃¼_j ³æRIöþÌ%ž/º .,]/ú>+6è»Äúçï+Ny>Mƒ6‚ƒ!Žcƒƒ¢ÑTnþjs¶ì­Æ=—•–ê“× µóI Hˆ®ëÍoŽ_^«ðÿ”íw;æ;û3–…ìè$zO`9Si‘¼2Xà)†Ée9å*õŸºˆ€'ÊÇ»˜BÊ…k<ù³ ssóp÷ß”L»µÙfÆb`‰'P}%˜Á^RSç*‚¡D9{Žç½éxû®óÙûÓ|ß:%saÍ.¸ó!ö½…¼ddA#¸N!Ýù.¾Ñ$x6–è°¿Ôrd_Ä /~Tª…!ñà(ÙÁxÀö‡kðÂÒ/‰s¨exê›\·byËŠúÎû…Lɇ©D/ »»§_¿8Ay>šð¼Å8à0­ÚÙЈ°ðU½.çÄùïDõ¿xö"þÀëÅøÕŸããÁÔgŽ€‹!P']ä®SA|²õ¨Ád|Pƒr :mM °€„™@1³$B""Á²PQcQ£Rd6¨Ûuë×Årñ¾œ§¡ùog]Ô#ӥυ/[^ƒæ¤8Ç7¸¡a䣟ìîÕðsûs /ä©ÛèTâñ/8=9'Ÿå¼ãŒZ¸Yár馪¥,¯pòK§Ô=px¹õù)äroÂäÜv!ÙÂA$Põ´Ý¢ð™³|Éàð¥ÜÐ3z_-¸˜6dö PB9#A54·7æ˜NbuJ74Ú#ÄJâRçNºŠÀ‚-–uúK$-]ŒÙ ,‹^qžKßÄ|¢ƒÉï)u$† Æîä;O+Øs×Hòz™îVoC~µ©ô°À`žL-Ìg÷Ѥǔ°¼Rò#Ä÷žéå;kòýŸ ;^™ë+ÀFL÷•Ø¥á±+w Db^¥5K¨¸üC}Œ;èº&¦ S‡0#Ž:OOŠox".ÿ¨ð&§?Ÿ8z&@åéÕ–5*꩜„iALä™áêc{çnt<<Ù‚mL™×Ç9½fùeÄ#Et]‰"Œ)¥â1ŒyëD0  "úüú xÚõ„uÀ«0“‰8q¿7zç+¯‰ŽÝs®v)8•32ȱR䞌DÉyJA·ê9ã?×cfñlwºë]Cº¯CÏOMÿ—äø¿N4"v|'òA¶¢{<ºú1ÅA–¨x_m)f¡8&• Úî¹ ÁiÓè|?O©yÍ}?Ú½wfÚzò1 JP‰‰`2”&%! ÉlRP[$X‹6±Í·—øžU®ssV¤µ*H#Ȉ¢oYÌëîZ1åÝ¢[ ÙcÌçïÚŸï;º˜É’¶4Ž8û¨V'iñ\¼âlN—ks­n…Ë6%léaœtB€ÉÝb<cëÛq<„ãr¢n@¤ö¾öBITÁ_…µŒ³ðxu>ßïåË’z¼{vX~]úE^F[…‰ÑÙµ1†ã6B´F!Ô² ècu(èÁ§_ž1"bBCª¤8^g48Ÿ-(Æ,*¥B)Úoòi€ÌÔžwOaö½ ô!äúBD7¼sÝ÷áJ|2çÿ‹¹"œ(H_<) €cards/NAMESPACE0000644000176200001440000000543014774774700012610 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(ard_attributes,data.frame) S3method(ard_attributes,default) S3method(ard_categorical,data.frame) S3method(ard_complex,data.frame) S3method(ard_continuous,data.frame) S3method(ard_dichotomous,data.frame) S3method(ard_hierarchical,data.frame) S3method(ard_hierarchical_count,data.frame) S3method(ard_missing,data.frame) S3method(ard_total_n,data.frame) S3method(fill_formula_selectors,data.frame) S3method(print,card) S3method(process_formula_selectors,data.frame) S3method(process_selectors,data.frame) export("%>%") export(add_calculated_row) export(alias_as_fmt_fn) export(all_ard_group_n) export(all_ard_groups) export(all_ard_variables) export(all_missing_columns) export(all_of) export(any_of) export(apply_fmt_fn) export(ard_attributes) export(ard_categorical) export(ard_complex) export(ard_continuous) export(ard_dichotomous) export(ard_formals) export(ard_hierarchical) export(ard_hierarchical_count) export(ard_missing) export(ard_pairwise) export(ard_stack) export(ard_stack_hierarchical) export(ard_stack_hierarchical_count) export(ard_strata) export(ard_total_n) export(as_card) export(as_cards_fn) export(as_nested_list) export(bind_ard) export(captured_condition_as_error) export(captured_condition_as_message) export(cards_select) export(check_ard_structure) export(check_list_elements) export(compute_formula_selector) export(contains) export(continuous_summary_fns) export(default_stat_labels) export(ends_with) export(eval_capture_conditions) export(everything) export(fill_formula_selectors) export(filter_ard_hierarchical) export(get_ard_statistics) export(get_cards_fn_stat_names) export(is_cards_fn) export(label_cards) export(label_round) export(last_col) export(matches) export(maximum_variable_value) export(mock_attributes) export(mock_categorical) export(mock_continuous) export(mock_dichotomous) export(mock_missing) export(mock_total_n) export(nest_for_ard) export(num_range) export(one_of) export(print_ard_conditions) export(process_formula_selectors) export(process_selectors) export(rename_ard_columns) export(rename_ard_groups_reverse) export(rename_ard_groups_shift) export(replace_null_statistic) export(round5) export(shuffle_ard) export(sort_ard_hierarchical) export(starts_with) export(tidy_ard_column_order) export(tidy_ard_row_order) export(tidy_as_ard) export(unlist_ard_columns) export(update_ard_fmt_fn) export(update_ard_stat_label) export(vars) export(where) import(rlang) importFrom(dplyr,"%>%") importFrom(dplyr,across) importFrom(dplyr,all_of) importFrom(dplyr,any_of) importFrom(dplyr,contains) importFrom(dplyr,ends_with) importFrom(dplyr,everything) importFrom(dplyr,last_col) importFrom(dplyr,matches) importFrom(dplyr,num_range) importFrom(dplyr,one_of) importFrom(dplyr,starts_with) importFrom(dplyr,vars) importFrom(dplyr,where) cards/NEWS.md0000644000176200001440000002465514776255572012504 0ustar liggesusers# cards 0.6.0 ## New Features and Functions * Added functions `sort_ard_hierarchical()` and `filter_ard_hierarchical()` to sort & filter ARDs created using `ard_stack_hierarchical()` and `ard_stack_hierarchical_count()`. (#301) * Updated `ard_stack_hierarchical()` and `ard_stack_hierarchical_count()` to automatically sort results alphanumerically. (#423) * Added new function `unlist_ard_columns()`. (#391) * Updated function `rename_ard_columns()`. (#380) * The function no longer coerces values to character. * The `fill` argument has been added to specify a value to fill in the new column when there are no levels associated with the variables (e.g. continuous summaries). * The `unlist` argument has been deprecated in favor of using the new `unlist_ard_columns()` function. * The function no longer accepts generic data frames: inputs must be a data frame of class `card`. * Added function `ard_formals()` to assist in adding a function's formals, that is, the arguments with their default values, along with user-passed arguments into an ARD structure. ## Bug Fixes * Fixed sorting order of logical variables in `nest_for_ard()`. (#411) ## Lifecycle Changes * The `shuffle_ard()` function no longer outputs a `'label'` column, and instead retains the original `'variable'` level from the cards object. It also no longer trims rows with non-numeric stats values. (#416) # cards 0.5.1 * Small update to account for a change in R-devel. # cards 0.5.0 ## New Features and Functions * Added functions `rename_ard_groups_shift()` and `rename_ard_groups_reverse()` for renaming the grouping variables in the ARD. (#344) * Added an option to specify the default rounding in the package: `cards.round_type`. See `?cards.options` for details. (#384) * Added the `print_ard_conditions(condition_type)` argument, which allows users to select to return conditions as messages (the default), or have warnings returned as warnings and errors as errors. (#386) * Added the `all_ard_group_n(types)` argument to allow separate selection of `groupX` and `groupX_level` columns. * Added the `tidy_ard_column_order(group_order)` argument that allows users to specify whether the grouping variables are listed in ascending order (the default) or descending order. The output of `ard_strata()` now calls `tidy_ard_column_order(group_order="descending")`. ## Other Updates * A new article has been added detailing how to create new ARD functions. * Results are now sorted in a consistent manner, by descending groups and strata. (#342, #326) ## Lifecycle Updates * Function `label_cards()` has been renamed to `label_round()`, which more clearly communicates that is returns a rounding function. # cards 0.4.0 ## New Features and Functions * Added functions `as_cards_fn()`, `is_cards_fn()`, and `get_cards_fn_stat_names()`. These functions assist is creating functions with attributes enumerating the expected results. * Updated `ard_continuous()` and `ard_complex()` to return full ARDs when functions passed are created with `as_cards_fn()`: instead of a single row output, we get a long ARD with rows for each of the expected statistic names. (#316) * Added function `ard_pairwise()` to ease the calculations of pairwise analyses. (#359) ## Other Updates * Improved messaging in `print_ard_conditions()` when the calling function is namespaced. (#348) * Updated print method for `'card'` objects so extraneous columns are never printed by default. ## Lifecycle Changes * No longer exporting functions `check_pkg_installed()`, `is_pkg_installed()`, `get_min_version_required()`, `get_pkg_dependencies()`. These functions are now internal-only. (#330) ## Bug Fixes * The `tidy_ard_column_order()` now correctly orders grouping columns when there are 10+ groups. This also corrects an issue in the hierarchical functions where the ordering of the variables matters. (#352) # cards 0.3.0 ## New Features & Updates * Added functions `ard_stack_hierarchical()` and `ard_stack_hierarchical_count()` that ease the creation of ARDs for multiple nested or hierarchical structures. (#314) * Added functions `update_ard_fmt_fn()` and `update_ard_stat_label()` to update an ARD's formatting function and statistic label, respectively. (#253) * Added `rename_ard_columns(unlist)` argument, which unlists specified columns in the ARD data frame. (#313) * Added `ard_strata()` function to ease the task of calculating ARDs stratified by one or more other categorical variables. (#273) * Added functions `mock_continuous()`, `mock_categorical()`, `mock_dichotomous()`, `mock_missing()`, `mock_attributes()` to build ARDs in the absence of a data frame. Where applicable, the formatting functions are set to return `'xx'` or `'xx.x'` to aid in the construction of mock tables or table shells. (#256) * Added functions for printing results from `eval_capture_conditions()`. Captured conditions can be printed as either errors or messages with `captured_condition_as_error()` and `captured_condition_as_message()`, respectively. (#282) ## Other Updates * The `ard_hierarchical_count()` function has been updated to match the behavior of `ard_hierarchical()` and results are now only returned for the last column listed in the `variables` arguments, rather than recursively counting all variables. * Add columns `'fmt_fn'`, `'warning'`, and `'errors'` to `ard_attributes()` output. (#327) * Add checks for factors with no levels, or any levels that are `NA` into `ard_*` functions (#255) * Any rows with `NA` or `NaN` values in the `.by` columns specified in `ard_stack()` are now removed from all calculations. (#320) # cards 0.2.2 ## New Features & Updates * Converted `ard_total_n()` to an S3 generic and added method `ard_total_n.data.frame()`. * Added the `bind_ard(.quiet)` argument to suppress messaging. (#299) * Improved ability of `shuffle_ard()` to populate missing group values where possible. (#306) * Added `apply_fmt_fn(replace)` argument. Use `replace=FALSE` to retain any previously formatted statistics in the `stat_fmt` column. (#285) * Added `bind_ard(.distinct)` argument, which can remove non-distinct rows from the ARD across grouping variables, primary variables, context, statistic name and value. (#286) ## Bug Fixes * Fix in `print_ard_conditions()` when the variables were factors, which did not render properly in `cli::cli_format()`. * Bug fix in `print_ard_conditions()` and we can now print condition messages that contain curly brace pairs. (#309) # cards 0.2.1 * Update in `ard_categorical()` to use `base::order()` instead of `dplyr::arrange()`, so the ordering of variables match the results from `base::table()` in some edge cases where sorted order was inconsistent. * Update in `ard_categorical()` to run `base::table()` output checks against coerced character columns. Previously, we relied on R to perform checks on the type it decided to check against (e.g. when it coerces to a common type). While the initial strategy worked in cases of Base R classes, there were some bespoke classes, such as times from {hms}, where Base R does not coerce as we expected. * Adding selectors `all_group_n()` and `all_missing_columns()`. (#272, #274) * Added new function `add_calculated_row()` for adding a new row of calculated statistic(s) that are a function of the other statistics in the ARD. (#275) # cards 0.2.0 ## New Features & Updates * Converting `ard_*()` functions and other helpers to S3 generics to make them extendable. (#227) * Added helper `rename_ard_columns()` for renaming/coalescing group/variable columns. (#213). * Added new function `ard_total_n()` for calculating the total N in a data frame. (#236) * Added the `nest_for_ard(include_data)` argument to either include or exclude the subsetted data frames in a list-column in the returned tibble. * Added `check_ard_structure(column_order, method)` arguments to the function to check for column ordering and whether result contains a `stat_name='method'` row. * Added the optional `ard_hierarchical(id)` argument. When provided we check for duplicates across the column(s) supplied here. If duplicates are found, the user is warned that the percentages and denominators are not correct. (#214) * Improved messaging in `check_pkg_installed()` that incorporates the calling function name in the case of an error. (#205) * Updated `is_pkg_installed()` and `check_pkg_installed()` to allow checks for more than package at a time. The `get_min_version_required()` function has also been updated to return a tibble instead of a list with attributes. (#201) * Styling from the {cli} package are now removed from errors and warnings when they are captured with `eval_capture_conditions()`. Styling is removed with `cli::ansi_strip()`. (#129) ## Bug Fixes * Bug fix in `ard_stack()` when calls to functions were namespaced. (#242) * The `print_ard_conditions()` function has been updated to no longer error out if the ARD object does not have `"error"` or `"warning"` columns. (#240) * Bug fix in `shuffle_ard()` where factors were coerced to integers instead of their labels. (#232) ## Lifecycle Changes * Corrected order that `ard_categorical` (strata) columns would appear in the ARD results. Previously, they appeared in the order they appeared in the original data, and now they are sorted properly. (#221) * The API for `ard_continuous(statistic)` and `ard_missing(statistic)` arguments has been updated. Previously, the RHS of these argument's passed lists would be either `continuous_summary_fns()` and `missing_summary_fns()`. Now these arguments accept simple character vectors of the statistic names. For example, `ard_categorical(statistic = everything() ~ c("n", "p", "N"))` and `ard_missing(statistic = everything() ~ c("N_obs", "N_miss", "N_nonmiss", "p_miss", "p_nonmiss"))`. (#223) * Updated `ard_stack()` to return `n`, `p`, and `N` for the `by` variable when specified. Previously, it only returned `N` which is the same for all levels of the by variable. (#219) * Bug fix where `ard_stack(by)` argument was not passed to `ard_missing()` when `ard_stack(.missing=TRUE)`. (#244) * The `ard_stack(by)` argument has been renamed to `".by"` and its location moved to after the dots inputs, e.g. `ard_stack(..., .by)`. (#243) * A messaging overhaul to utilize the scripts in `https://github.com/ddsjoberg/standalone/blob/main/R/standalone-cli_call_env.R`. This allows clear error messaging across functions and packages. (#42) - The `print_ard_conditions(call)`, `check_list_elements(env)`, `cards_select(.call)` arguments have been removed. # cards 0.1.0 * Initial release. cards/inst/0000755000176200001440000000000014776242611012335 5ustar liggesuserscards/inst/WORDLIST0000644000176200001440000000057314776242611013534 0ustar liggesusersADAE ADaM AE AEs ARD ARD's ARDs CDISC CMD Codecov DIARRHOEA GlaxoSmithKline Hoffmann IEC JSON Lifecycle ORCID Pre Rua SAS's SDTM Unlist Xanomeline YAML ata cardx cli de env esult ets funder hms httr jsonlite mis nalysis namespaced pre quosures reproducibility reusability sd tibble tibbles tidyselect tidyselector tidyselectors univariable unlist unlists unnested unnests wilcox cards/README.md0000644000176200001440000000703214776253420012641 0ustar liggesusers # cards cards website [![CRAN status](https://www.r-pkg.org/badges/version/cards)](https://CRAN.R-project.org/package=cards) [![Codecov test coverage](https://codecov.io/gh/insightsengineering/cards/graph/badge.svg)](https://app.codecov.io/gh/insightsengineering/cards) [![Downloads](https://cranlogs.r-pkg.org/badges/cards)](https://cran.r-project.org/package=cards) [![R-CMD-check](https://github.com/insightsengineering/cards/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/insightsengineering/cards/actions/workflows/R-CMD-check.yaml) The [CDISC Analysis Results Standard](https://www.cdisc.org/standards/foundational/analysis-results-standard) aims to facilitate automation, reproducibility, reusability, and traceability of analysis results data (ARD). The {cards} package creates these **C**DISC **A**nalysis **R**esult **D**ata **S**ets. Use cases: 1. Quality Control (QC) of existing tables and figures. 2. Pre-calculate statistics to be summarized in tables and figures. 3. Medical writers may easily access statistics and place in reports without copying and pasting from reports. 4. Provides a consistent format for results and lends results to be combined across studies for re-use and re-analysis. ## Installation Install cards from CRAN with: ``` r install.packages("cards") ``` You can install the development version of cards from [GitHub](https://github.com/) with: ``` r # install.packages("devtools") devtools::install_github("insightsengineering/cards") ``` ## Extensions [cardx website](https://insightsengineering.github.io/cardx/) The {cards} package exports three types of functions: 1. Functions to create basic ARD objects. 2. Utilities to create new ARD objects. 3. Functions to work with existing ARD objects. The [{cardx}](https://github.com/insightsengineering/cardx/) R package is an extension to {cards} that uses the utilities from {cards} and exports functions for creating additional ARD objects––including functions to summarize t-tests, Wilcoxon Rank-Sum tests, regression models, and more. ## Getting Started Review the [Getting Started](https://insightsengineering.github.io/cards//main/articles/getting-started.html) page for examples using ARDs to calculate statistics to later include in tables. ``` r library(cards) ard_continuous(ADSL, by = "ARM", variables = "AGE") #> {cards} data frame: 24 x 10 #> group1 group1_level variable stat_name stat_label stat #> 1 ARM Placebo AGE N N 86 #> 2 ARM Placebo AGE mean Mean 75.209 #> 3 ARM Placebo AGE sd SD 8.59 #> 4 ARM Placebo AGE median Median 76 #> 5 ARM Placebo AGE p25 Q1 69 #> 6 ARM Placebo AGE p75 Q3 82 #> 7 ARM Placebo AGE min Min 52 #> 8 ARM Placebo AGE max Max 89 #> 9 ARM Xanomeli… AGE N N 84 #> 10 ARM Xanomeli… AGE mean Mean 74.381 #> ℹ 14 more rows #> ℹ Use `print(n = ...)` to see more rows #> ℹ 4 more variables: context, fmt_fn, warning, error ``` cards/man/0000755000176200001440000000000014776255604012141 5ustar liggesuserscards/man/ard_categorical.Rd0000644000176200001440000001302614752441547015532 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_categorical.R \name{ard_categorical} \alias{ard_categorical} \alias{ard_categorical.data.frame} \title{Categorical ARD Statistics} \usage{ ard_categorical(data, ...) \method{ard_categorical}{data.frame}( data, variables, by = dplyr::group_vars(data), strata = NULL, statistic = everything() ~ c("n", "p", "N"), denominator = "column", fmt_fn = NULL, stat_label = everything() ~ default_stat_labels(), ... ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{...}{Arguments passed to methods.} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to include in summaries. Default is \code{everything()}.} \item{by, strata}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to use for grouping or stratifying the table output. Arguments are similar, but with an important distinction: \code{by}: results are tabulated by \strong{all combinations} of the columns specified, including unobserved combinations and unobserved factor levels. \code{strata}: results are tabulated by \strong{all \emph{observed} combinations} of the columns specified. Arguments may be used in conjunction with one another.} \item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element one or more of \code{c("n", "N", "p", "n_cum", "p_cum")} (on the RHS of a formula).} \item{denominator}{(\code{string}, \code{data.frame}, \code{integer})\cr Specify this argument to change the denominator, e.g. the \code{"N"} statistic. Default is \code{'column'}. See below for details.} \item{fmt_fn}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element is a named list of functions (or the RHS of a formula), e.g. \verb{list(mpg = list(mean = \\(x) round(x, digits = 2) |> as.character()))}.} \item{stat_label}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element is either a named list or a list of formulas defining the statistic labels, e.g. \code{everything() ~ list(n = "n", p = "pct")} or \code{everything() ~ list(n ~ "n", p ~ "pct")}.} } \value{ an ARD data frame of class 'card' } \description{ Compute Analysis Results Data (ARD) for categorical summary statistics. } \section{Denominators}{ By default, the \code{ard_categorical()} function returns the statistics \code{"n"}, \code{"N"}, and \code{"p"}, where little \code{"n"} are the counts for the variable levels, and big \code{"N"} is the number of non-missing observations. The default calculation for the percentage is merely \code{p = n/N}. However, it is sometimes necessary to provide a different \code{"N"} to use as the denominator in this calculation. For example, in a calculation of the rates of various observed adverse events, you may need to update the denominator to the number of enrolled subjects. In such cases, use the \code{denominator} argument to specify a new definition of \code{"N"}, and subsequently \code{"p"}. The argument expects one of the following inputs: \itemize{ \item a string: one of \code{"column"}, \code{"row"}, or \code{"cell"}. \itemize{ \item \code{"column"}, the default, returns percentages where the sum is equal to one within the variable after the data frame has been subset with \code{by}/\code{strata}. \item \code{"row"} gives 'row' percentages where \code{by}/\code{strata} columns are the 'top' of a cross table, and the variables are the rows. This is well-defined for a single \code{by} or \code{strata} variable, and care must be taken when there are more to ensure the the results are as you expect. \item \code{"cell"} gives percentages where the denominator is the number of non-missing rows in the source data frame. } \item a data frame. Any columns in the data frame that overlap with the \code{by}/\code{strata} columns will be used to calculate the new \code{"N"}. \item an integer. This single integer will be used as the new \code{"N"} \item a structured data frame. The data frame will include columns from \code{by}/\code{strata}. The last column must be named \code{"...ard_N..."}. The integers in this column will be used as the updated \code{"N"} in the calculations. } Lastly, when the \code{p} statistic is returned, the proportion is returned---bounded by \verb{[0, 1]}. However, the default function to format the statistic scales the proportion by 100 and the percentage is returned which matches the default statistic label of \code{'\%'}. To get the formatted values, pass the ARD to \code{apply_fmt_fn()}. } \section{Other Statistics}{ In some cases, you may need other kinds of statistics for categorical variables. Despite the name, \code{ard_continuous()} can be used to obtain these statistics. In the example below, we calculate the mode of a categorical variable. \if{html}{\out{
}}\preformatted{get_mode <- function(x) \{ table(x) |> sort(decreasing = TRUE) |> names() |> getElement(1L) \} ADSL |> ard_continuous( variables = AGEGR1, statistic = list(AGEGR1 = list(mode = get_mode)) ) #> \{cards\} data frame: 1 x 8 #> variable context stat_name stat_label stat fmt_fn #> 1 AGEGR1 continuo… mode mode 65-80 #> i 2 more variables: warning, error }\if{html}{\out{
}} } \examples{ ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") ADSL |> dplyr::group_by(ARM) |> ard_categorical( variables = "AGEGR1", statistic = everything() ~ "n" ) } cards/man/ard_continuous.Rd0000644000176200001440000000572514753417324015467 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_continuous.R \name{ard_continuous} \alias{ard_continuous} \alias{ard_continuous.data.frame} \title{Continuous ARD Statistics} \usage{ ard_continuous(data, ...) \method{ard_continuous}{data.frame}( data, variables, by = dplyr::group_vars(data), strata = NULL, statistic = everything() ~ continuous_summary_fns(), fmt_fn = NULL, stat_label = everything() ~ default_stat_labels(), ... ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{...}{Arguments passed to methods.} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to include in summaries.} \item{by, strata}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to tabulate by/stratify by for summary statistic calculation. Arguments are similar, but with an important distinction: \code{by}: results are calculated for \strong{all combinations} of the columns specified, including unobserved combinations and unobserved factor levels. \code{strata}: results are calculated for \strong{all \emph{observed} combinations} of the columns specified. Arguments may be used in conjunction with one another.} \item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element is a named list of functions (or the RHS of a formula), e.g. \verb{list(mpg = list(mean = \\(x) mean(x)))}. The value assigned to each variable must also be a named list, where the names are used to reference a function and the element is the function object. Typically, this function will return a scalar statistic, but a function that returns a named list of results is also acceptable, e.g. \code{list(conf.low = -1, conf.high = 1)}. However, when errors occur, the messaging will be less clear in this setting.} \item{fmt_fn}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element is a named list of functions (or the RHS of a formula), e.g. \verb{list(mpg = list(mean = \\(x) round(x, digits = 2) |> as.character()))}.} \item{stat_label}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element is either a named list or a list of formulas defining the statistic labels, e.g. \code{everything() ~ list(mean = "Mean", sd = "SD")} or \code{everything() ~ list(mean ~ "Mean", sd ~ "SD")}.} } \value{ an ARD data frame of class 'card' } \description{ Compute Analysis Results Data (ARD) for simple continuous summary statistics. } \examples{ ard_continuous(ADSL, by = "ARM", variables = "AGE") # if a single function returns a named list, the named # results will be placed in the resulting ARD ADSL |> dplyr::group_by(ARM) |> ard_continuous( variables = "AGE", statistic = ~ list(conf.int = \(x) t.test(x)[["conf.int"]] |> as.list() |> setNames(c("conf.low", "conf.high"))) ) } cards/man/ard_dichotomous.Rd0000644000176200001440000001207614752441547015616 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_dichotomous.R \name{ard_dichotomous} \alias{ard_dichotomous} \alias{ard_dichotomous.data.frame} \title{Dichotomous ARD Statistics} \usage{ ard_dichotomous(data, ...) \method{ard_dichotomous}{data.frame}( data, variables, by = dplyr::group_vars(data), strata = NULL, value = maximum_variable_value(data[variables]), statistic = everything() ~ c("n", "N", "p"), denominator = NULL, fmt_fn = NULL, stat_label = everything() ~ default_stat_labels(), ... ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{...}{Arguments passed to methods.} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to include in summaries. Default is \code{everything()}.} \item{by, strata}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to use for grouping or stratifying the table output. Arguments are similar, but with an important distinction: \code{by}: results are tabulated by \strong{all combinations} of the columns specified, including unobserved combinations and unobserved factor levels. \code{strata}: results are tabulated by \strong{all \emph{observed} combinations} of the columns specified. Arguments may be used in conjunction with one another.} \item{value}{(named \code{list})\cr named list of dichotomous values to tabulate. Default is \code{maximum_variable_value(data)}, which returns the largest/last value after a sort.} \item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element one or more of \code{c("n", "N", "p", "n_cum", "p_cum")} (on the RHS of a formula).} \item{denominator}{(\code{string}, \code{data.frame}, \code{integer})\cr Specify this argument to change the denominator, e.g. the \code{"N"} statistic. Default is \code{'column'}. See below for details.} \item{fmt_fn}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element is a named list of functions (or the RHS of a formula), e.g. \verb{list(mpg = list(mean = \\(x) round(x, digits = 2) |> as.character()))}.} \item{stat_label}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element is either a named list or a list of formulas defining the statistic labels, e.g. \code{everything() ~ list(n = "n", p = "pct")} or \code{everything() ~ list(n ~ "n", p ~ "pct")}.} } \value{ an ARD data frame of class 'card' } \description{ Compute Analysis Results Data (ARD) for dichotomous summary statistics. } \section{Denominators}{ By default, the \code{ard_categorical()} function returns the statistics \code{"n"}, \code{"N"}, and \code{"p"}, where little \code{"n"} are the counts for the variable levels, and big \code{"N"} is the number of non-missing observations. The default calculation for the percentage is merely \code{p = n/N}. However, it is sometimes necessary to provide a different \code{"N"} to use as the denominator in this calculation. For example, in a calculation of the rates of various observed adverse events, you may need to update the denominator to the number of enrolled subjects. In such cases, use the \code{denominator} argument to specify a new definition of \code{"N"}, and subsequently \code{"p"}. The argument expects one of the following inputs: \itemize{ \item a string: one of \code{"column"}, \code{"row"}, or \code{"cell"}. \itemize{ \item \code{"column"}, the default, returns percentages where the sum is equal to one within the variable after the data frame has been subset with \code{by}/\code{strata}. \item \code{"row"} gives 'row' percentages where \code{by}/\code{strata} columns are the 'top' of a cross table, and the variables are the rows. This is well-defined for a single \code{by} or \code{strata} variable, and care must be taken when there are more to ensure the the results are as you expect. \item \code{"cell"} gives percentages where the denominator is the number of non-missing rows in the source data frame. } \item a data frame. Any columns in the data frame that overlap with the \code{by}/\code{strata} columns will be used to calculate the new \code{"N"}. \item an integer. This single integer will be used as the new \code{"N"} \item a structured data frame. The data frame will include columns from \code{by}/\code{strata}. The last column must be named \code{"...ard_N..."}. The integers in this column will be used as the updated \code{"N"} in the calculations. } Lastly, when the \code{p} statistic is returned, the proportion is returned---bounded by \verb{[0, 1]}. However, the default function to format the statistic scales the proportion by 100 and the percentage is returned which matches the default statistic label of \code{'\%'}. To get the formatted values, pass the ARD to \code{apply_fmt_fn()}. } \examples{ ard_dichotomous(mtcars, by = vs, variables = c(cyl, am), value = list(cyl = 4)) mtcars |> dplyr::group_by(vs) |> ard_dichotomous( variables = c(cyl, am), value = list(cyl = 4), statistic = ~"p" ) } cards/man/selectors.Rd0000644000176200001440000000265714754702430014433 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/selectors.R \name{selectors} \alias{selectors} \alias{all_ard_groups} \alias{all_ard_variables} \alias{all_ard_group_n} \alias{all_missing_columns} \title{ARD Selectors} \usage{ all_ard_groups(types = c("names", "levels")) all_ard_variables(types = c("names", "levels")) all_ard_group_n(n, types = c("names", "levels")) all_missing_columns() } \arguments{ \item{types}{(\code{character})\cr type(s) of columns to select. \code{"names"} selects the columns variable name columns, and \code{"levels"} selects the level columns. Default is \code{c("names", "levels")}.} \item{n}{(\code{integer})\cr integer(s) indicating which grouping columns to select.} } \value{ tidyselect output } \description{ These selection helpers match variables according to a given pattern. \itemize{ \item \code{all_ard_groups()}: Function selects grouping columns, e.g. columns named \code{"group##"} or \code{"group##_level"}. \item \code{all_ard_variables()}: Function selects variables columns, e.g. columns named \code{"variable"} or \code{"variable_level"}. \item \code{all_ard_group_n()}: Function selects \code{n} grouping columns. \item \code{all_missing_columns()}: Function selects columns that are all \code{NA} or empty. } } \examples{ ard <- ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") ard |> dplyr::select(all_ard_groups()) ard |> dplyr::select(all_ard_variables()) } cards/man/ard_pairwise.Rd0000644000176200001440000000235014721513741015066 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_pairwise.R \name{ard_pairwise} \alias{ard_pairwise} \title{Pairwise ARD} \usage{ ard_pairwise(data, variable, .f, include = NULL) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{variable}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Column to perform pairwise analyses for.} \item{.f}{(\code{function})\cr a function that creates ARDs. The function accepts a single argument and a subset of \code{data} will be passed including the two levels of \code{variable} for the pairwise analysis.} \item{include}{(\code{vector})\cr a vector of levels of the \code{variable} column to include in comparisons. Pairwise comparisons will only be performed for pairs that have a level specified here. Default is \code{NULL} and all pairwise computations are included.} } \value{ list of ARDs } \description{ Utility to perform pairwise comparisons. } \examples{ ard_pairwise( ADSL, variable = ARM, .f = \(df) { ard_complex( df, variables = AGE, statistic = ~ list(ttest = \(x, data, ...) t.test(x ~ data$ARM)[c("statistic", "p.value")]) ) }, include = "Placebo" # only include comparisons to the "Placebo" group ) } cards/man/rename_ard_columns.Rd0000644000176200001440000000357314776252447016277 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rename_ard_columns.R \name{rename_ard_columns} \alias{rename_ard_columns} \title{Rename ARD Variables} \usage{ rename_ard_columns( x, columns = c(all_ard_groups("names"), all_ard_variables("names")), fill = "{colname}", unlist = NULL ) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} \item{columns}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to rename, e.g. selecting columns \code{c('group1', 'group2', 'variable')} will rename \code{'group1_level'} to the name of the variable found in \code{'group1'}. When, for example, the \code{'group1_level'} does not exist, the values of the new column are filled with the values in the \code{fill} argument. Default is \code{c(all_ard_groups("names"), all_ard_variables("names"))}.} \item{fill}{(scalar/glue)\cr a scalar to fill column values when the variable does not have levels. If a character is passed, then it is processed with \code{glue::glue()} where the \code{colname} element is available to inject into the string, e.g. \code{'Overall {colname}'} may resolve to \code{'Overall AGE'} for an AGE column. Default is \code{'{colname}'}.} \item{unlist}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} } \value{ data frame } \description{ Rename the grouping and variable columns to their original column names. } \examples{ # Example 1 ---------------------------------- ADSL |> ard_categorical(by = ARM, variables = AGEGR1) |> apply_fmt_fn() |> rename_ard_columns() |> unlist_ard_columns() # Example 2 ---------------------------------- ADSL |> ard_continuous(by = ARM, variables = AGE) |> apply_fmt_fn() |> rename_ard_columns(fill = "Overall {colname}") |> unlist_ard_columns() } cards/man/dot-check_for_missing_combos_in_denom.Rd0000644000176200001440000000201214607274473022073 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_categorical.R \name{.check_for_missing_combos_in_denom} \alias{.check_for_missing_combos_in_denom} \title{Check for Missing Levels in \code{denominator}} \usage{ .check_for_missing_combos_in_denom(data, denominator, by, strata) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{denominator}{(\code{data.frame})\cr denominator data frame} \item{by}{(\code{character})\cr character vector of by column names} \item{strata}{(\code{character})\cr character vector of strata column names} } \value{ returns invisible if check is successful, throws an error message if not. } \description{ When a user passes a data frame in the \code{denominator} argument, this function checks that the data frame contains all the same levels of the \code{by} and \code{strata} variables that appear in \code{data}. } \examples{ cards:::.check_for_missing_combos_in_denom(ADSL, denominator = "col", by = "ARM", strata = "AGEGR1") } \keyword{internal} cards/man/ard_missing.Rd0000644000176200001440000000457014753417324014727 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_missing.R \name{ard_missing} \alias{ard_missing} \alias{ard_missing.data.frame} \title{Missing ARD Statistics} \usage{ ard_missing(data, ...) \method{ard_missing}{data.frame}( data, variables, by = dplyr::group_vars(data), statistic = everything() ~ c("N_obs", "N_miss", "N_nonmiss", "p_miss", "p_nonmiss"), fmt_fn = NULL, stat_label = everything() ~ default_stat_labels(), ... ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{...}{Arguments passed to methods.} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to include in summaries.} \item{by}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr results are tabulated by \strong{all combinations} of the columns specified.} \item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element is a named list of functions (or the RHS of a formula), e.g. \verb{list(mpg = list(mean = \\(x) mean(x)))}. The value assigned to each variable must also be a named list, where the names are used to reference a function and the element is the function object. Typically, this function will return a scalar statistic, but a function that returns a named list of results is also acceptable, e.g. \code{list(conf.low = -1, conf.high = 1)}. However, when errors occur, the messaging will be less clear in this setting.} \item{fmt_fn}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element is a named list of functions (or the RHS of a formula), e.g. \verb{list(mpg = list(mean = \\(x) round(x, digits = 2) |> as.character()))}.} \item{stat_label}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element is either a named list or a list of formulas defining the statistic labels, e.g. \code{everything() ~ list(mean = "Mean", sd = "SD")} or \code{everything() ~ list(mean ~ "Mean", sd ~ "SD")}.} } \value{ an ARD data frame of class 'card' } \description{ Compute Analysis Results Data (ARD) for statistics related to data missingness. } \examples{ ard_missing(ADSL, by = "ARM", variables = "AGE") ADSL |> dplyr::group_by(ARM) |> ard_missing( variables = "AGE", statistic = ~"N_miss" ) } cards/man/apply_fmt_fn.Rd0000644000176200001440000000135514752044433015100 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/apply_fmt_fn.R \name{apply_fmt_fn} \alias{apply_fmt_fn} \title{Apply Formatting Functions} \usage{ apply_fmt_fn(x, replace = FALSE) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} \item{replace}{(scalar \code{logical})\cr logical indicating whether to replace values in the \code{'stat_fmt'} column (if present). Default is \code{FALSE}.} } \value{ an ARD data frame of class 'card' } \description{ Apply the formatting functions to each of the raw statistics. Function aliases are converted to functions using \code{\link[=alias_as_fmt_fn]{alias_as_fmt_fn()}}. } \examples{ ard_continuous(ADSL, variables = "AGE") |> apply_fmt_fn() } cards/man/dot-cli_groups_and_variable.Rd0000644000176200001440000000152314607117341020036 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/print_ard_conditions.R \name{.cli_groups_and_variable} \alias{.cli_groups_and_variable} \title{Locate Condition Messages in an ARD} \usage{ .cli_groups_and_variable(x) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} } \value{ a string } \description{ Prints a string of all \code{group##}/\code{group##_level} column values and \code{variable} column values where condition messages occur, formatted using glue syntax. } \examples{ ard <- ard_continuous( ADSL, by = ARM, variables = AGE, statistic = ~ list( mean = \(x) mean(x), mean_warning = \(x) { warning("warn1") warning("warn2") mean(x) }, err_fn = \(x) stop("'tis an error") ) ) cards:::.cli_groups_and_variable(ard) } \keyword{internal} cards/man/ard_total_n.Rd0000644000176200001440000000110114661006010014661 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_total_n.R \name{ard_total_n} \alias{ard_total_n} \alias{ard_total_n.data.frame} \title{ARD Total N} \usage{ ard_total_n(data, ...) \method{ard_total_n}{data.frame}(data, ...) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{...}{Arguments passed to methods.} } \value{ an ARD data frame of class 'card' } \description{ Returns the total N for the data frame. The placeholder variable name returned in the object is \code{"..ard_total_n.."} } \examples{ ard_total_n(ADSL) } cards/man/tidy_ard_order.Rd0000644000176200001440000000242714754702430015415 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_ard_order.R \name{tidy_ard_order} \alias{tidy_ard_order} \alias{tidy_ard_column_order} \alias{tidy_ard_row_order} \title{Standard Order of ARD} \usage{ tidy_ard_column_order(x, group_order = c("ascending", "descending")) tidy_ard_row_order(x) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} \item{group_order}{(\code{string})\cr specifies the ordering of the grouping variables. Must be one of \code{c("ascending", "descending")}. Default is \code{"ascending"}, where grouping variables begin with \code{"group1"} variables, followed by \code{"group2"} variables, etc.} } \value{ an ARD data frame of class 'card' } \description{ ARD functions for relocating columns and rows to the standard order. \itemize{ \item \code{tidy_ard_column_order()} relocates columns of the ARD to the standard order. \item \code{tidy_ard_row_order()} orders rows of ARD according to groups and strata (group 1, then group2, etc), while retaining the column order of the input ARD. } } \examples{ # order columns ard <- dplyr::bind_rows( ard_continuous(mtcars, variables = "mpg"), ard_continuous(mtcars, variables = "mpg", by = "cyl") ) tidy_ard_column_order(ard) |> tidy_ard_row_order() } cards/man/alias_as_fmt_fn.Rd0000644000176200001440000000230714752044433015525 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/apply_fmt_fn.R \name{alias_as_fmt_fn} \alias{alias_as_fmt_fn} \title{Convert Alias to Function} \usage{ alias_as_fmt_fn(x, variable, stat_name) } \arguments{ \item{x}{(\code{integer}, \code{string}, or \code{function})\cr a non-negative integer, string alias, or function} \item{variable}{(\code{character})\cr the variable whose statistic is to be formatted} \item{stat_name}{(\code{character})\cr the name of the statistic that is to be formatted} } \value{ a function } \description{ Accepted aliases are non-negative integers and strings. The integers are converted to functions that round the statistics to the number of decimal places to match the integer. The formatting strings come in the form \code{"xx"}, \code{"xx.x"}, \code{"xx.x\%"}, etc. The number of \code{x}s that appear after the decimal place indicate the number of decimal places the statistics will be rounded to. The number of \code{x}s that appear before the decimal place indicate the leading spaces that are added to the result. If the string ends in \code{"\%"}, results are scaled by 100 before rounding. } \examples{ alias_as_fmt_fn(1) alias_as_fmt_fn("xx.x") } cards/man/print.card.Rd0000644000176200001440000000252014752441547014470 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/print.R \name{print.card} \alias{print.card} \title{Print} \usage{ \method{print}{card}(x, n = NULL, columns = c("auto", "all"), n_col = 6L, ...) } \arguments{ \item{x}{(\code{data.frame})\cr object of class 'card'} \item{n}{(\code{integer})\cr integer specifying the number of rows to print} \item{columns}{(\code{string})\cr string indicating whether to print a selected number of columns or all.} \item{n_col}{(\code{integer})\cr some columns are removed when there are more than a threshold of columns present. This argument sets that threshold. This is only used when \code{columns='auto'} and default is \code{6L}. Columns \code{'error'}, \code{'warning'}, \code{'context'}, and \code{'fmt_fn'} \emph{may} be removed from the print. All other columns will be printed, even if more than \code{n_col} columns are present.} \item{...}{(\code{\link[rlang:dyn-dots]{dynamic-dots}})\cr not used} } \value{ an ARD data frame of class 'card' (invisibly) } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}\cr Print method for objects of class 'card' } \examples{ ard_categorical(ADSL, variables = AGEGR1) |> print() } \keyword{internal} cards/man/dot-check_dichotomous_value.Rd0000644000176200001440000000114614607274473020102 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_dichotomous.R \name{.check_dichotomous_value} \alias{.check_dichotomous_value} \title{Perform Value Checks} \usage{ .check_dichotomous_value(data, value) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{value}{(named \code{list})\cr a named list} } \value{ returns invisible if check is successful, throws an error message if not. } \description{ Check the validity of the values passed in \code{ard_dichotomous(value)}. } \examples{ cards:::.check_dichotomous_value(mtcars, list(cyl = 4)) } \keyword{internal} cards/man/label_round.Rd0000644000176200001440000000143214753417324014710 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/apply_fmt_fn.R \name{label_round} \alias{label_round} \title{Generate Formatting Function} \usage{ label_round(digits = 1, scale = 1, width = NULL) } \arguments{ \item{digits}{(\code{integer})\cr a non-negative integer specifying the number of decimal places round statistics to} \item{scale}{(\code{numeric})\cr a scalar real number. Before rounding, the input will be scaled by this quantity} \item{width}{(\code{integer})\cr a non-negative integer specifying the minimum width of the returned formatted values} } \value{ a function } \description{ Returns a function with the requested rounding and scaling schema. } \examples{ label_round(2)(pi) label_round(1, scale = 100)(pi) label_round(2, width = 5)(pi) } cards/man/print_ard_conditions.Rd0000644000176200001440000000171414752441547016643 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/print_ard_conditions.R \name{print_ard_conditions} \alias{print_ard_conditions} \title{Print ARD Condition Messages} \usage{ print_ard_conditions(x, condition_type = c("inform", "identity")) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} \item{condition_type}{(\code{string})\cr indicates how warnings and errors are returned. Default is \code{"inform"} where all are returned as messages. When \code{"identity"}, errors are returned as errors and warnings as warnings.} } \value{ returns invisible if check is successful, throws all condition messages if not. } \description{ Function parses the errors and warnings observed while calculating the statistics requested in the ARD and prints them to the console as messages. } \examples{ # passing a character variable for numeric summary ard_continuous(ADSL, variables = AGEGR1) |> print_ard_conditions() } cards/man/maximum_variable_value.Rd0000644000176200001440000000131214567176413017141 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_dichotomous.R \name{maximum_variable_value} \alias{maximum_variable_value} \title{Maximum Value} \usage{ maximum_variable_value(data) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} } \value{ a named list } \description{ For each column in the passed data frame, the function returns a named list with the value being the largest/last element after a sort. For factors, the last level is returned, and for logical vectors \code{TRUE} is returned. This is used as the default value in \code{ard_dichotomous(value)} if not specified by the user. } \examples{ ADSL[c("AGEGR1", "BMIBLGR1")] |> maximum_variable_value() } cards/man/ard_strata.Rd0000644000176200001440000000266414752441547014561 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_strata.R \name{ard_strata} \alias{ard_strata} \title{Stratified ARD} \usage{ ard_strata(.data, .by = NULL, .strata = NULL, .f, ...) } \arguments{ \item{.data}{(\code{data.frame})\cr a data frame} \item{.by, .strata}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to tabulate by/stratify by for calculation. Arguments are similar, but with an important distinction: \code{.by}: results are tabulated by \strong{all combinations} of the columns specified, including unobserved combinations and unobserved factor levels. \code{.strata}: results are tabulated by \strong{all \emph{observed} combinations} of the columns specified. These argument \emph{should not} include any columns that appear in the \code{.f} argument.} \item{.f}{(\code{function}, \code{formula})\cr a function or a formula that can be coerced to a function with \code{rlang::as_function()} (similar to \code{purrr::map(.f)})} \item{...}{Additional arguments passed on to the \code{.f} function.} } \value{ an ARD data frame of class 'card' } \description{ General function for calculating ARD results within subgroups. While the examples below show use with other functions from the cards package, this function would primarily be used with the statistical functions in the cardx functions. } \examples{ ard_strata( ADSL, .by = ARM, .f = ~ ard_continuous(.x, variables = AGE) ) } cards/man/ard_stack.Rd0000644000176200001440000000432114675616454014365 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_stack.R \name{ard_stack} \alias{ard_stack} \title{Stack ARDs} \usage{ ard_stack( data, ..., .by = NULL, .overall = FALSE, .missing = FALSE, .attributes = FALSE, .total_n = FALSE, .shuffle = FALSE ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{...}{(\code{\link[rlang:dyn-dots]{dynamic-dots}})\cr Series of ARD function calls to be run and stacked} \item{.by}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to tabulate by in the series of ARD function calls. Any rows with \code{NA} or \code{NaN} values are removed from all calculations.} \item{.overall}{(\code{logical})\cr logical indicating whether overall statistics should be calculated (i.e. re-run all \verb{ard_*()} calls with \code{by=NULL}). Default is \code{FALSE}.} \item{.missing}{(\code{logical})\cr logical indicating whether to include the results of \code{ard_missing()} for all variables represented in the ARD. Default is \code{FALSE}.} \item{.attributes}{(\code{logical})\cr logical indicating whether to include the results of \code{ard_attributes()} for all variables represented in the ARD. Default is \code{FALSE}.} \item{.total_n}{(\code{logical})\cr logical indicating whether to include of \code{ard_total_n()} in the returned ARD.} \item{.shuffle}{(\code{logical})\cr logical indicating whether to perform \code{shuffle_ard()} on the final result. Default is \code{FALSE}.} } \value{ an ARD data frame of class 'card' } \description{ Stack multiple ARD calls sharing common input \code{data} and \code{by} variables. Optionally incorporate additional information on represented variables, e.g. overall calculations, rates of missingness, attributes, or transform results with \code{shuffle_ard()}. If the \code{ard_stack(by)} argument is specified, a univariate tabulation of the by variable will also be returned. } \examples{ ard_stack( data = ADSL, ard_categorical(variables = "AGEGR1"), ard_continuous(variables = "AGE"), .by = "ARM", .overall = TRUE, .attributes = TRUE ) ard_stack( data = ADSL, ard_categorical(variables = "AGEGR1"), ard_continuous(variables = "AGE"), .by = "ARM", .shuffle = TRUE ) } cards/man/dot-create_list_for_attributes.Rd0000644000176200001440000000132514574702654020625 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_ard_statistics.R \name{.create_list_for_attributes} \alias{.create_list_for_attributes} \title{Create List for Attributes} \usage{ .create_list_for_attributes(ard_subset, attributes, i) } \arguments{ \item{ard_subset}{(\code{data.frame})\cr an ARD data frame of class 'card'} \item{attributes}{(\code{character})\cr a character vector of attribute names} \item{i}{(\code{integer})\cr a row index number} } \value{ a named list } \description{ Create List for Attributes } \examples{ ard <- ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") cards:::.create_list_for_attributes(ard, c("group1", "group1_level"), 1) } \keyword{internal} cards/man/summary_functions.Rd0000644000176200001440000000253214632353606016207 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/summary_functions.R \name{summary_functions} \alias{summary_functions} \alias{continuous_summary_fns} \title{Summary Functions} \usage{ continuous_summary_fns( summaries = c("N", "mean", "sd", "median", "p25", "p75", "min", "max"), other_stats = NULL ) } \arguments{ \item{summaries}{(\code{character})\cr a character vector of results to include in output. Select one or more from 'N', 'mean', 'sd', 'median', 'p25', 'p75', 'min', 'max'.} \item{other_stats}{(named \code{list})\cr named list of other statistic functions to supplement the pre-programmed functions.} } \value{ named list of summary statistics } \description{ \itemize{ \item \code{continuous_summary_fns()} returns a named list of summary functions for continuous variables. Some functions include slight modifications to their base equivalents. For example, the \code{min()} and \code{max()} functions return \code{NA} instead of \code{Inf} when an empty vector is passed. Statistics \code{"p25"} and \code{"p75"} are calculated with \code{quantile(type = 2)}, which matches \href{https://psiaims.github.io/CAMIS/Comp/r-sas-summary-stats.html}{SAS's default value}. } } \examples{ # continuous variable summaries ard_continuous( ADSL, variables = "AGE", statistic = ~ continuous_summary_fns(c("N", "median")) ) } cards/man/ard_complex.Rd0000644000176200001440000000715014753417324014722 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_complex.R \name{ard_complex} \alias{ard_complex} \alias{ard_complex.data.frame} \title{Complex ARD Summaries} \usage{ ard_complex(data, ...) \method{ard_complex}{data.frame}( data, variables, by = dplyr::group_vars(data), strata = NULL, statistic, fmt_fn = NULL, stat_label = everything() ~ default_stat_labels(), ... ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{...}{Arguments passed to methods.} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to include in summaries.} \item{by, strata}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to tabulate by/stratify by for summary statistic calculation. Arguments are similar, but with an important distinction: \code{by}: results are calculated for \strong{all combinations} of the columns specified, including unobserved combinations and unobserved factor levels. \code{strata}: results are calculated for \strong{all \emph{observed} combinations} of the columns specified. Arguments may be used in conjunction with one another.} \item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr The form of the statistics argument is identical to \code{ard_continuous(statistic)} argument, except the summary function \emph{must} accept the following arguments: \itemize{ \item \code{x}: a vector \item \code{data}: the data frame that has been subset such that the \code{by}/\code{strata} columns and rows in which \code{"variable"} is \code{NA} have been removed. \item \code{full_data}: the full data frame \item \code{by}: character vector of the \code{by} variables \item \code{strata}: character vector of the \code{strata} variables It is unlikely any one function will need \emph{all} of the above elements, and it's recommended the function passed accepts \code{...} so that any unused arguments will be properly ignored. The \code{...} also allows this function to perhaps be updated in the future with more passed arguments. For example, if one needs a second variable from the data frame, the function inputs may look like: \code{foo(x, data, ...)} }} \item{fmt_fn}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element is a named list of functions (or the RHS of a formula), e.g. \verb{list(mpg = list(mean = \\(x) round(x, digits = 2) |> as.character()))}.} \item{stat_label}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element is either a named list or a list of formulas defining the statistic labels, e.g. \code{everything() ~ list(mean = "Mean", sd = "SD")} or \code{everything() ~ list(mean ~ "Mean", sd ~ "SD")}.} } \value{ an ARD data frame of class 'card' } \description{ Function is similar to \code{\link[=ard_continuous]{ard_continuous()}}, but allows for more complex summaries. While \code{ard_continuous(statistic)} only allows for a univariable function, \code{ard_complex(statistic)} can handle more complex data summaries. } \examples{ # example how to mimic behavior of `ard_continuous()` ard_complex( ADSL, by = "ARM", variables = "AGE", statistic = list(AGE = list(mean = \(x, ...) mean(x))) ) # return the grand mean and the mean within the `by` group grand_mean <- function(data, full_data, variable, ...) { list( mean = mean(data[[variable]], na.rm = TRUE), grand_mean = mean(full_data[[variable]], na.rm = TRUE) ) } ADSL |> dplyr::group_by(ARM) |> ard_complex( variables = "AGE", statistic = list(AGE = list(means = grand_mean)) ) } cards/man/rename_ard_groups.Rd0000644000176200001440000000163314746733642016127 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rename_ard_groups.R \name{rename_ard_groups} \alias{rename_ard_groups} \alias{rename_ard_groups_shift} \alias{rename_ard_groups_reverse} \title{Rename ARD Group Columns} \usage{ rename_ard_groups_shift(x, shift = -1) rename_ard_groups_reverse(x) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'.} \item{shift}{(\code{integer})\cr an integer specifying how many values to shift the group IDs, e.g. \code{shift=-1} renames \code{group2} to \code{group1}.} } \value{ an ARD data frame of class 'card' } \description{ Functions for renaming group columns names in ARDs. } \examples{ ard <- ard_continuous(ADSL, by = c(SEX, ARM), variables = AGE) # Example 1 ---------------------------------- rename_ard_groups_shift(ard, shift = -1) # Example 2 ---------------------------------- rename_ard_groups_reverse(ard) } cards/man/sort_ard_hierarchical.Rd0000644000176200001440000000513514767020056016736 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sort_ard_hierarchical.R \name{sort_ard_hierarchical} \alias{sort_ard_hierarchical} \title{Sort Stacked Hierarchical ARDs} \usage{ sort_ard_hierarchical(x, sort = c("descending", "alphanumeric")) } \arguments{ \item{x}{(\code{card})\cr a stacked hierarchical ARD of class \code{'card'} created using \code{\link[=ard_stack_hierarchical]{ard_stack_hierarchical()}} or \code{\link[=ard_stack_hierarchical_count]{ard_stack_hierarchical_count()}}.} \item{sort}{(\code{string})\cr type of sorting to perform. Value must be one of: \itemize{ \item \code{"alphanumeric"} - within each hierarchical section of the ARD, groups are ordered alphanumerically (i.e. A to Z) by \code{variable_level} text. \item \code{"descending"} - within each variable group of the ARD, count sums are calculated for each group and groups are sorted in descending order by sum. If \code{sort = "descending"}, the \code{n} statistic is used to calculate variable group sums if included in \code{statistic} for all variables, otherwise \code{p} is used. If neither \code{n} nor \code{p} are present in \code{x} for all variables, an error will occur. } Defaults to \code{"descending"}.} } \value{ an ARD data frame of class 'card' } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}\cr This function is used to sort stacked hierarchical ARDs. For the purposes of this function, we define a "variable group" as a combination of ARD rows grouped by the combination of all their variable levels, but excluding any \code{by} variables. } \note{ If overall data is present in \code{x} (i.e. the ARD was created with \code{ard_stack_hierarchical(overall=TRUE)}), the overall data will be sorted last within each variable group (i.e. after any other rows with the same combination of variable levels). } \examples{ \dontshow{if ((identical(Sys.getenv("NOT_CRAN"), "true") || identical(Sys.getenv("IN_PKGDOWN"), "true"))) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} ard_stack_hierarchical( ADAE, variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL |> dplyr::rename(TRTA = ARM), id = USUBJID ) |> sort_ard_hierarchical("alphanumeric") ard_stack_hierarchical_count( ADAE, variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL |> dplyr::rename(TRTA = ARM) ) |> sort_ard_hierarchical("descending") \dontshow{\}) # examplesIf} } \seealso{ \code{\link[=filter_ard_hierarchical]{filter_ard_hierarchical()}} } cards/man/as_card.Rd0000644000176200001440000000070614661403171014012 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/as_card.R \name{as_card} \alias{as_card} \title{Data Frame as ARD} \usage{ as_card(x) } \arguments{ \item{x}{(\code{data.frame})\cr a data frame} } \value{ an ARD data frame of class 'card' } \description{ Convert data frames to ARDs of class 'card'. } \examples{ data.frame( stat_name = c("N", "mean"), stat_label = c("N", "Mean"), stat = c(10, 0.5) ) |> as_card() } cards/man/dot-table_as_df.Rd0000644000176200001440000000233514574702654015440 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_categorical.R \name{.table_as_df} \alias{.table_as_df} \title{Results from \code{table()} as Data Frame} \usage{ .table_as_df( data, variable = NULL, by = NULL, strata = NULL, useNA = c("no", "always"), count_column = "...ard_n..." ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{variable}{(\code{string})\cr a string indicating a column in data} \item{by}{(\code{character})\cr a character vector indicating columns in data} \item{strata}{(\code{character})\cr a character vector indicating columns in data} \item{useNA}{(\code{string})\cr one of \code{"no"} and \code{"always"}. Will be passed to \code{table(useNA)}.} } \value{ data frame } \description{ Takes the results from \code{\link[=table]{table()}} and returns them as a data frame. After the \code{\link[=table]{table()}} results are made into a data frame, all the variables are made into character columns, and the function also restores the column types to their original classes. For \code{strata} columns, only observed combinations are returned. } \examples{ cards:::.table_as_df(ADSL, variable = "ARM", by = "AGEGR1", strata = NULL) } \keyword{internal} cards/man/cards.options.Rd0000644000176200001440000000234014753417324015207 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/options.R \name{cards.options} \alias{cards.options} \title{Options in \{cards\}} \description{ See below for options available in the \{cards\} package } \section{cards.round_type}{ There are two types of rounding types in the \{cards\} package that are implemented in \code{label_round()}, \code{alias_as_fmt_fn()}, and \code{apply_fmt_fn()} functions' \code{round_type} argument. \itemize{ \item \code{'round-half-up'} (\emph{default}): rounding method where values exactly halfway between two numbers are rounded to the larger in magnitude number. Rounding is implemented via \code{\link[=round5]{round5()}}. \item \code{'round-to-even'}: base R's default IEC 60559 rounding standard. See \code{\link[=round]{round()}} for details. } To change the default rounding to use IEC 60559, this option must be set \strong{both} when the ARDs are created and when \code{apply_fmt_fn()} is run. This ensures that any \emph{default} formatting functions created with \code{label_round()} utilize the specified rounding method and the method is used what aliases are converted into functions (which occurs in \code{apply_fmt_fn()} when it calls \code{alias_as_fmt_fn()}). } cards/man/dot-check_var_nms.Rd0000644000176200001440000000117514574702654016020 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/shuffle_ard.R \name{.check_var_nms} \alias{.check_var_nms} \title{Check Variable Names} \usage{ .check_var_nms(x, vars_protected) } \arguments{ \item{x}{(\code{data.frame})\cr a data frame} \item{vars_protected}{(\code{character})\cr a character vector of protected names} } \value{ a data frame } \description{ Checks variable names in a data frame against protected names and modifies them if needed } \examples{ data <- data.frame(a = "x", b = "y", c = "z", .cards_idx = 1) cards:::.check_var_nms(data, vars_protected = c("x", "z")) } \keyword{internal} cards/man/update_ard.Rd0000644000176200001440000000367314752417404014541 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/update_ard.R \name{update_ard} \alias{update_ard} \alias{update_ard_fmt_fn} \alias{update_ard_stat_label} \title{Update ARDs} \usage{ update_ard_fmt_fn( x, variables = everything(), stat_names, fmt_fn, filter = TRUE ) update_ard_stat_label( x, variables = everything(), stat_names, stat_label, filter = TRUE ) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr variables in \code{x$variable} to apply update. Default is \code{everything()}.} \item{stat_names}{(\code{character})\cr character vector of the statistic names (i.e. values from \code{x$stat_name}) to apply the update.} \item{fmt_fn}{(\code{function})\cr a function or alias recognized by \code{alias_as_fmt_fn()}.} \item{filter}{(\code{expression})\cr an expression that evaluates to a logical vector identifying rows in \code{x} to apply the update to. Default is \code{TRUE}, and update is applied to all rows.} \item{stat_label}{(\code{function})\cr a string of the updated statistic label.} } \value{ an ARD data frame of class 'card' } \description{ Functions used to update ARD formatting functions and statistic labels. This is a helper function to streamline the update process. If it does not exactly meet your needs, recall that an ARD is just a data frame and it can be modified directly. } \examples{ ard_continuous(ADSL, variables = AGE) |> update_ard_fmt_fn(stat_names = c("mean", "sd"), fmt_fn = 8L) |> update_ard_stat_label(stat_names = c("mean", "sd"), stat_label = "Mean (SD)") |> apply_fmt_fn() # same as above, but only apply update to the Placebo level ard_continuous( ADSL, by = ARM, variables = AGE, statistic = ~ continuous_summary_fns(c("N", "mean")) ) |> update_ard_fmt_fn(stat_names = "mean", fmt_fn = 8L, filter = group1_level == "Placebo") |> apply_fmt_fn() } cards/man/process_selectors.Rd0000644000176200001440000001272114643265534016170 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/process_selectors.R \name{process_selectors} \alias{process_selectors} \alias{process_formula_selectors} \alias{fill_formula_selectors} \alias{process_selectors.data.frame} \alias{process_formula_selectors.data.frame} \alias{fill_formula_selectors.data.frame} \alias{compute_formula_selector} \alias{check_list_elements} \alias{cards_select} \title{Process tidyselectors} \usage{ process_selectors(data, ...) process_formula_selectors(data, ...) fill_formula_selectors(data, ...) \method{process_selectors}{data.frame}(data, ..., env = caller_env()) \method{process_formula_selectors}{data.frame}( data, ..., env = caller_env(), include_env = FALSE, allow_empty = TRUE ) \method{fill_formula_selectors}{data.frame}(data, ..., env = caller_env()) compute_formula_selector( data, x, arg_name = caller_arg(x), env = caller_env(), strict = TRUE, include_env = FALSE, allow_empty = TRUE ) check_list_elements( x, predicate, error_msg = NULL, arg_name = rlang::caller_arg(x) ) cards_select(expr, data, ..., arg_name = NULL) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{...}{(\code{\link[rlang:dyn-dots]{dynamic-dots}})\cr named arguments where the value of the argument is processed with tidyselect. \itemize{ \item \code{process_selectors()}: the values are tidyselect-compatible selectors \item \code{process_formula_selectors()}: the values are named lists, list of formulas a combination of both, or a single formula. Users may pass \code{~value} as a shortcut for \code{everything() ~ value}. \item \code{check_list_elements()}: named arguments where the name matches an existing list in the \code{env} environment, and the value is a predicate function to test each element of the list, e.g. each element must be a string or a function. }} \item{env}{(\code{environment})\cr env to save the results to. Default is the calling environment.} \item{include_env}{(\code{logical})\cr whether to include the environment from the formula object in the returned named list. Default is \code{FALSE}} \item{allow_empty}{(\code{logical})\cr Logical indicating whether empty result is acceptable while process formula-list selectors. Default is \code{TRUE}.} \item{x}{\itemize{ \item \code{compute_formula_selector()}: (\code{\link[=syntax]{formula-list-selector}})\cr a named list, list of formulas, or a single formula that will be converted to a named list. \item \code{check_list_elements()}: (named \code{list})\cr a named list }} \item{arg_name}{(\code{string})\cr the name of the argument being processed. Used in error messaging. Default is \code{caller_arg(x)}.} \item{strict}{(\code{logical})\cr whether to throw an error if a variable doesn't exist in the reference data (passed to \code{\link[tidyselect:eval_select]{tidyselect::eval_select()}})} \item{predicate}{(\code{function})\cr a predicate function that returns \code{TRUE} or \code{FALSE}} \item{error_msg}{(\code{character})\cr a character vector that will be used in error messaging when mis-specified arguments are passed. Elements \code{"{arg_name}"} and \code{"{variable}"} are available using glue syntax for messaging.} \item{expr}{(\code{expression})\cr Defused R code describing a selection according to the tidyselect syntax.} } \value{ \code{process_selectors()}, \code{fill_formula_selectors()}, \code{process_formula_selectors()} and \code{check_list_elements()} return NULL. \code{compute_formula_selector()} returns a named list. } \description{ Functions process tidyselect arguments passed to functions in the cards package. The processed values are saved to the calling environment, by default. \itemize{ \item \code{process_selectors()}: the arguments will be processed with tidyselect and converted to a vector of character column names. \item \code{process_formula_selectors()}: for arguments that expect named lists or lists of formulas (where the LHS of the formula is a tidyselector). This function processes these inputs and returns a named list. If a name is repeated, the last entry is kept. \item \code{fill_formula_selectors()}: when users override the default argument values, it can be important to ensure that each column from a data frame is assigned a value. This function checks that each column in \code{data} has an assigned value, and if not, fills the value in with the default value passed here. \item \code{compute_formula_selector()}: used in \code{process_formula_selectors()} to evaluate a single argument. \item \code{check_list_elements()}: used to check the class/type/values of the list elements, primarily those processed with \code{process_formula_selectors()}. \item \code{cards_select()}: wraps \code{tidyselect::eval_select() |> names()}, and returns better contextual messaging when errors occur. } } \examples{ example_env <- rlang::new_environment() process_selectors(ADSL, variables = starts_with("TRT"), env = example_env) get(x = "variables", envir = example_env) fill_formula_selectors(ADSL, env = example_env) process_formula_selectors( ADSL, statistic = list(starts_with("TRT") ~ mean, TRTSDT = min), env = example_env ) get(x = "statistic", envir = example_env) check_list_elements( get(x = "statistic", envir = example_env), predicate = function(x) !is.null(x), error_msg = c( "Error in the argument {.arg {arg_name}} for variable {.val {variable}}.", "i" = "Value must be a named list of functions." ) ) # process one list compute_formula_selector(ADSL, x = starts_with("U") ~ 1L) } cards/man/filter_ard_hierarchical.Rd0000644000176200001440000001263314767020056017235 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/filter_ard_hierarchical.R \name{filter_ard_hierarchical} \alias{filter_ard_hierarchical} \title{Filter Stacked Hierarchical ARDs} \usage{ filter_ard_hierarchical(x, filter, keep_empty = FALSE) } \arguments{ \item{x}{(\code{card})\cr a stacked hierarchical ARD of class \code{'card'} created using \code{\link[=ard_stack_hierarchical]{ard_stack_hierarchical()}} or \code{\link[=ard_stack_hierarchical_count]{ard_stack_hierarchical_count()}}.} \item{filter}{(\code{expression})\cr an expression that is used to filter variable groups of the hierarchical ARD. See the Details section below.} \item{keep_empty}{(scalar \code{logical})\cr Logical argument indicating whether to retain summary rows corresponding to hierarchy sections that have had all rows filtered out. Default is \code{FALSE}.} } \value{ an ARD data frame of class 'card' } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}\cr This function is used to filter stacked hierarchical ARDs. For the purposes of this function, we define a "variable group" as a combination of ARD rows grouped by the combination of all their variable levels, but excluding any \code{by} variables. } \details{ The \code{filter} argument can be used to filter out variable groups of a hierarchical ARD which do not meet the requirements provided as an expression. Variable groups can be filtered on the values of any of the possible statistics (\code{n}, \code{p}, and \code{N}) provided they are included at least once in the ARD, as well as the values of any \code{by} variables. To illustrate how the function works, consider the typical example below where the AE summaries are provided by treatment group. \if{html}{\out{
}}\preformatted{ADAE |> dplyr::filter(AESOC == "GASTROINTESTINAL DISORDERS", AEDECOD \%in\% c("VOMITING", "DIARRHOEA")) |> ard_stack_hierarchical( variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL |> dplyr::rename(TRTA = ARM), id = USUBJID ) }\if{html}{\out{
}}\tabular{lrrr}{ \strong{SOC} / AE \tab Placebo \tab Xanomeline High Dose \tab Xanomeline Low Dose \cr \strong{GASTROINTESTINAL DISORDERS} \tab 11 (13\%) \tab 10 (12\%) \tab 8 (9.5\%) \cr DIARRHOEA \tab 9 (10\%) \tab 4 (4.8\%) \tab 5 (6.0\%) \cr VOMITING \tab 3 (3.5\%) \tab 7 (8.3\%) \tab 3 (3.6\%) \cr } Filters are applied to the summary statistics of the innermost variable in the hierarchy---\code{AEDECOD} in this case. If any of the summary statistics meet the filter requirement for any of the treatment groups, the entire row is retained. For example, if \code{filter = n >= 9} were passed, the criteria would be met for DIARRHOEA as the Placebo group observed 9 AEs and as a result the summary statistics for the other treatment groups would be retained as well. Conversely, no treatment groups' summary statistics satisfy the filter requirement for VOMITING so all rows associated with this AE would be removed. In addition to filtering on individual statistic values, filters can be applied across the treatment groups (i.e. across all \code{by} variable values) by using aggregate functions such as \code{sum()} and \code{mean()}. A value of \code{filter = sum(n) >= 18} retains AEs where the sum of the number of AEs across the treatment groups is greater than or equal to 18. If \code{ard_stack_hierarchical(overall=TRUE)} was run, the overall column is \strong{not} considered in any filtering. If \code{ard_stack_hierarchical(over_variables=TRUE)} was run, any overall statistics are kept regardless of filtering. Some examples of possible filters: \itemize{ \item \code{filter = n > 5}: keep AEs where one of the treatment groups observed more than 5 AEs \item \code{filter = n == 2 & p < 0.05}: keep AEs where one of the treatment groups observed exactly 2 AEs \emph{and} one of the treatment groups observed a proportion less than 5\% \item \code{filter = sum(n) >= 4}: keep AEs where there were 4 or more AEs observed across the treatment groups \item \code{filter = mean(n) > 4 | n > 3}: keep AEs where the mean number of AEs is 4 or more across the treatment groups \emph{or} one of the treatment groups observed more than 3 AEs \item \code{filter = any(n > 2 & TRTA == "Xanomeline High Dose")}: keep AEs where the \code{"Xanomeline High Dose"} treatment group observed more than 2 AEs } } \examples{ \dontshow{if ((identical(Sys.getenv("NOT_CRAN"), "true") || identical(Sys.getenv("IN_PKGDOWN"), "true"))) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} # create a base AE ARD ard <- ard_stack_hierarchical( ADAE, variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL |> dplyr::rename(TRTA = ARM), id = USUBJID ) # Example 1 ---------------------------------- # Keep AEs from TRTA groups where more than 3 AEs are observed across the group filter_ard_hierarchical(ard, sum(n) > 3) # Example 2 ---------------------------------- # Keep AEs where at least one level in the TRTA group has more than 3 AEs observed filter_ard_hierarchical(ard, n > 3) # Example 3 ---------------------------------- # Keep AEs that have an overall prevalence of greater than 5\% filter_ard_hierarchical(ard, sum(n) / sum(N) > 0.05) \dontshow{\}) # examplesIf} } \seealso{ \code{\link[=sort_ard_hierarchical]{sort_ard_hierarchical()}} } cards/man/eval_capture_conditions.Rd0000644000176200001440000000705014752441547017332 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/eval_capture_conditions.R \name{eval_capture_conditions} \alias{eval_capture_conditions} \alias{captured_condition_as_message} \alias{captured_condition_as_error} \title{Evaluate and Capture Conditions} \usage{ eval_capture_conditions(expr, data = NULL, env = caller_env()) captured_condition_as_message( x, message = c("The following {type} occured:", x = "{condition}"), type = c("error", "warning"), envir = rlang::current_env() ) captured_condition_as_error( x, message = c("The following {type} occured:", x = "{condition}"), type = c("error", "warning"), call = get_cli_abort_call(), envir = rlang::current_env() ) } \arguments{ \item{expr}{An \link[rlang:topic-defuse]{expression} or \link[rlang:topic-quosure]{quosure} to evaluate.} \item{data}{A data frame, or named list or vector. Alternatively, a data mask created with \code{\link[rlang:as_data_mask]{as_data_mask()}} or \code{\link[rlang:new_data_mask]{new_data_mask()}}. Objects in \code{data} have priority over those in \code{env}. See the section about data masking.} \item{env}{The environment in which to evaluate \code{expr}. This environment is not applicable for quosures because they have their own environments.} \item{x}{(\code{captured_condition})\cr a captured condition created by \code{eval_capture_conditions()}.} \item{message}{(\code{character})\cr message passed to \code{cli::cli_inform()} or \code{cli::cli_abort()}. The condition being printed is saved in an object named \code{condition}, which should be included in this message surrounded by curly brackets.} \item{type}{(\code{string})\cr the type of condition to return. Must be one of \code{'error'} or \code{'warning'}.} \item{envir}{Environment to evaluate the glue expressions in.} \item{call}{(\code{environment})\cr Execution environment of currently running function. Default is \code{get_cli_abort_call()}.} } \value{ a named list } \description{ \strong{\code{eval_capture_conditions()}} Evaluates an expression while also capturing error and warning conditions. Function always returns a named list \code{list(result=, warning=, error=)}. If there are no errors or warnings, those elements will be \code{NULL}. If there is an error, the result element will be \code{NULL}. Messages are neither saved nor printed to the console. Evaluation is done via \code{\link[rlang:eval_tidy]{rlang::eval_tidy()}}. If errors and warnings are produced using the \code{{cli}} package, the messages are processed with \code{cli::ansi_strip()} to remove styling from the message. \strong{\code{captured_condition_as_message()}/\code{captured_condition_as_error()}} These functions take the result from \code{eval_capture_conditions()} and return errors or warnings as either messages (via \code{cli::cli_inform()}) or errors (via \code{cli::cli_abort()}). These functions handle cases where the condition messages may include curly brackets, which would typically cause issues when processed with the \verb{cli::cli_*()} functions. Functions return the \code{"result"} from \code{eval_capture_conditions()}. } \examples{ # function executes without error or warning eval_capture_conditions(letters[1:2]) # an error is thrown res <- eval_capture_conditions(stop("Example Error!")) res captured_condition_as_message(res) # if more than one warning is returned, all are saved eval_capture_conditions({ warning("Warning 1") warning("Warning 2") letters[1:2] }) # messages are not printed to the console eval_capture_conditions({ message("A message!") letters[1:2] }) } cards/man/dot-check_no_ard_columns.Rd0000644000176200001440000000140214607274473017346 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_continuous.R \name{.check_no_ard_columns} \alias{.check_no_ard_columns} \title{Check Protected Column Names} \usage{ .check_no_ard_columns(x, exceptions = "...ard_dummy_for_counting...") } \arguments{ \item{x}{(\code{data.frame})\cr a data frame} \item{exceptions}{(\code{string})\cr character string of column names to exclude from checks} } \value{ returns invisible if check is successful, throws an error message if not. } \description{ Checks that column names in a passed data frame are not protected, that is, they do not begin with \code{"...ard_"} and end with \code{"..."}. } \examples{ data <- data.frame("ard_x" = 1) cards:::.check_no_ard_columns(data) } \keyword{internal} cards/man/dot-default_fmt_fn.Rd0000644000176200001440000000101214574702654016161 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_continuous.R \name{.default_fmt_fn} \alias{.default_fmt_fn} \title{Add Default Formatting Functions} \usage{ .default_fmt_fn(x) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} } \value{ a data frame } \description{ Add Default Formatting Functions } \examples{ ard <- ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") |> dplyr::mutate(fmt_fn = NA) cards:::.default_fmt_fn(ard) } \keyword{internal} cards/man/dot-calculate_stats_as_ard.Rd0000644000176200001440000000172214574702654017700 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_continuous.R \name{.calculate_stats_as_ard} \alias{.calculate_stats_as_ard} \title{Calculate Continuous Statistics} \usage{ .calculate_stats_as_ard( df_nested, variables, statistic, by, strata, data, new_col_name = "...ard_all_stats..." ) } \arguments{ \item{df_nested}{(\code{data.frame})\cr a nested data frame} \item{variables}{(\code{character})\cr character vector of variables} \item{statistic}{(named \code{list})\cr named list of statistical functions} } \value{ an ARD data frame of class 'card' } \description{ Calculate statistics and return in an ARD format } \examples{ data_nested <- ADSL |> nest_for_ard( by = "ARM", strata = NULL, key = "...ard_nested_data..." ) cards:::.calculate_stats_as_ard( df_nested = data_nested, variables = "AGE", statistic = list(mean = "mean"), by = "ARM", strata = NULL, data = ADSL ) } \keyword{internal} cards/man/ard_stack_hierarchical.Rd0000644000176200001440000001454514752441547017067 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_stack_hierarchical.R \name{ard_stack_hierarchical} \alias{ard_stack_hierarchical} \alias{ard_stack_hierarchical_count} \title{Stacked Hierarchical ARD Statistics} \usage{ ard_stack_hierarchical( data, variables, by = dplyr::group_vars(data), id, denominator, include = everything(), statistic = everything() ~ c("n", "N", "p"), overall = FALSE, over_variables = FALSE, attributes = FALSE, total_n = FALSE, shuffle = FALSE ) ard_stack_hierarchical_count( data, variables, by = dplyr::group_vars(data), denominator = NULL, include = everything(), overall = FALSE, over_variables = FALSE, attributes = FALSE, total_n = FALSE, shuffle = FALSE ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Specifies the nested/hierarchical structure of the data. The variables that are specified here and in the \code{include} argument will have summary statistics calculated.} \item{by}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr variables to perform tabulations by. All combinations of the variables specified here appear in results. Default is \code{dplyr::group_vars(data)}.} \item{id}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr argument used to subset \code{data} to identify rows in \code{data} to calculate event rates in \code{ard_stack_hierarchical()}. See details below.} \item{denominator}{(\code{data.frame}, \code{integer})\cr used to define the denominator and enhance the output. The argument is required for \code{ard_stack_hierarchical()} and optional for \code{ard_stack_hierarchical_count()}. \itemize{ \item the univariate tabulations of the \code{by} variables are calculated with \code{denominator}, when a data frame is passed, e.g. tabulation of the treatment assignment counts that may appear in the header of a table. \item the \code{denominator} argument must be specified when \code{id} is used to calculate the event rates. \item if \code{total_n=TRUE}, the \code{denominator} argument is used to return the total N }} \item{include}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Specify the subset a columns indicated in the \code{variables} argument for which summary statistics will be returned. Default is \code{everything()}.} \item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element one or more of \code{c("n", "N", "p", "n_cum", "p_cum")} (on the RHS of a formula).} \item{overall}{(scalar \code{logical})\cr logical indicating whether overall statistics should be calculated (i.e. repeat the operations with \code{by=NULL} in \emph{most cases}, see below for details). Default is \code{FALSE}.} \item{over_variables}{(scalar \code{logical})\cr logical indicating whether summary statistics should be calculated over or across the columns listed in the \code{variables} argument. Default is \code{FALSE}.} \item{attributes}{(scalar \code{logical})\cr logical indicating whether to include the results of \code{ard_attributes()} for all variables represented in the ARD. Default is \code{FALSE}.} \item{total_n}{(scalar \code{logical})\cr logical indicating whether to include of \code{ard_total_n(denominator)} in the returned ARD.} \item{shuffle}{(scalar \code{logical})\cr logical indicating whether to perform \code{shuffle_ard()} on the final result. Default is \code{FALSE}.} } \value{ an ARD data frame of class 'card' } \description{ Use these functions to calculate multiple summaries of nested or hierarchical data in a single call. \itemize{ \item \code{ard_stack_hierarchical()}: Calculates \emph{rates} of events (e.g. adverse events) utilizing the \code{denominator} and \code{id} arguments to identify the rows in \code{data} to include in each rate calculation. \item \code{ard_stack_hierarchical_count()}: Calculates \emph{counts} of events utilizing all rows for each tabulation. } } \section{Subsetting Data for Rate Calculations}{ To calculate event rates, the \code{ard_stack_hierarchical()} function identifies rows to include in the calculation. First, the primary data frame is sorted by the columns identified in the \code{id}, \code{by}, and \code{variables} arguments. As the function cycles over the variables specified in the \code{variables} argument, the data frame is grouped by \code{id}, \code{intersect(by, names(denominator))}, and \code{variables} utilizing the last row within each of the groups. For example, if the call is \code{ard_stack_hierarchical(data = ADAE, variables = c(AESOC, AEDECOD), id = USUBJID)}, then we'd first subset ADAE to be one row within the grouping \code{c(USUBJID, AESOC, AEDECOD)} to calculate the event rates in \code{'AEDECOD'}. We'd then repeat and subset ADAE to be one row within the grouping \code{c(USUBJID, AESOC)} to calculate the event rates in \code{'AESOC'}. } \section{Overall Argument}{ When we set \code{overall=TRUE}, we wish to re-run our calculations removing the stratifying columns. For example, if we ran the code below, we results would include results with the code chunk being re-run with \code{by=NULL}. \if{html}{\out{
}}\preformatted{ard_stack_hierarchical( data = ADAE, variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL |> dplyr::rename(TRTA = ARM), overall = TRUE ) }\if{html}{\out{
}} But there is another case to be aware of: when the \code{by} argument includes columns that are not present in the \code{denominator}, for example when tabulating results by AE grade or severity in addition to treatment assignment. In the example below, we're tabulating results by treatment assignment and AE severity. By specifying \code{overall=TRUE}, we will re-run the to get results with \code{by = AESEV} and again with \code{by = NULL}. \if{html}{\out{
}}\preformatted{ard_stack_hierarchical( data = ADAE, variables = c(AESOC, AEDECOD), by = c(TRTA, AESEV), denominator = ADSL |> dplyr::rename(TRTA = ARM), overall = TRUE ) }\if{html}{\out{
}} } \examples{ ard_stack_hierarchical( ADAE, variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL |> dplyr::rename(TRTA = ARM), id = USUBJID ) ard_stack_hierarchical_count( ADAE, variables = c(AESOC, AEDECOD), by = TRTA, denominator = ADSL |> dplyr::rename(TRTA = ARM) ) } cards/man/get_ard_statistics.Rd0000644000176200001440000000217114643265534016304 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_ard_statistics.R \name{get_ard_statistics} \alias{get_ard_statistics} \title{ARD Statistics as List} \usage{ get_ard_statistics(x, ..., .column = "stat", .attributes = NULL) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} \item{...}{(\code{\link[rlang:dyn-dots]{dynamic-dots}})\cr optional arguments indicating rows to subset of the ARD. For example, to return only rows where the column \code{"AGEGR1"} is \code{"65-80"}, pass \code{AGEGR1 \%in\% "65-80"}.} \item{.column}{(\code{string})\cr string indicating the column that will be returned in the list. Default is \code{"statistic"}} \item{.attributes}{(\code{character})\cr character vector of column names that will be returned in the list as attributes. Default is \code{NULL}} } \value{ named list } \description{ Returns the statistics from an ARD as a named list. } \examples{ ard <- ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") get_ard_statistics( ard, group1_level \%in\% "Placebo", variable_level \%in\% "65-80", .attributes = "stat_label" ) } cards/man/dot-unique_and_sorted.Rd0000644000176200001440000000137614574702654016731 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{.unique_and_sorted} \alias{.unique_and_sorted} \title{ARD-flavor of unique()} \usage{ .unique_and_sorted(x, useNA = c("no", "always")) } \arguments{ \item{x}{(\code{any})\cr a vector} } \value{ a vector } \description{ Essentially a wrapper for \code{unique(x) |> sort()} with \code{NA} levels removed. For factors, all levels are returned even if they are unobserved. Similarly, logical vectors always return \code{c(TRUE, FALSE)}, even if both levels are not observed. } \examples{ cards:::.unique_and_sorted(factor(letters[c(5, 5:1)], levels = letters)) cards:::.unique_and_sorted(c(FALSE, TRUE, TRUE, FALSE)) cards:::.unique_and_sorted(c(5, 5:1)) } \keyword{internal} cards/man/dot-purrr_list_flatten.Rd0000644000176200001440000000103614574702654017134 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{.purrr_list_flatten} \alias{.purrr_list_flatten} \title{A list_flatten()-like Function} \usage{ .purrr_list_flatten(x) } \arguments{ \item{x}{(named \code{list})\cr a named list} } \value{ a named list } \description{ Function operates similarly to \code{purrr::list_flatten(x, name_spec = "{inner}")}. } \examples{ x <- list(a = 1, b = list(b1 = 2, b2 = 3), c = list(c1 = 4, c2 = list(c2a = 5))) cards:::.purrr_list_flatten(x) } \keyword{internal} cards/man/reexports.Rd0000644000176200001440000000206214567176413014461 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reexports.R \docType{import} \name{reexports} \alias{reexports} \alias{\%>\%} \alias{starts_with} \alias{ends_with} \alias{contains} \alias{matches} \alias{num_range} \alias{all_of} \alias{any_of} \alias{everything} \alias{where} \alias{last_col} \alias{one_of} \alias{vars} \title{Objects exported from other packages} \keyword{internal} \description{ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ \item{dplyr}{\code{\link[dplyr:reexports]{\%>\%}}, \code{\link[dplyr:reexports]{all_of}}, \code{\link[dplyr:reexports]{any_of}}, \code{\link[dplyr:reexports]{contains}}, \code{\link[dplyr:reexports]{ends_with}}, \code{\link[dplyr:reexports]{everything}}, \code{\link[dplyr:reexports]{last_col}}, \code{\link[dplyr:reexports]{matches}}, \code{\link[dplyr:reexports]{num_range}}, \code{\link[dplyr:reexports]{one_of}}, \code{\link[dplyr:reexports]{starts_with}}, \code{\link[dplyr]{vars}}, \code{\link[dplyr:reexports]{where}}} }} cards/man/unlist_ard_columns.Rd0000644000176200001440000000243214776242611016327 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/unlist_ard_columns.R \name{unlist_ard_columns} \alias{unlist_ard_columns} \title{Unlist ARD Columns} \usage{ unlist_ard_columns( x, columns = c(where(is.list), -any_of(c("warning", "error", "fmt_fn"))), fill = NA, fct_as_chr = TRUE ) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card' or any data frame} \item{columns}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to unlist. Default is \code{c(where(is.list), -any_of(c("warning", "error", "fmt_fn")))}.} \item{fill}{(scalar)\cr scalar to fill NULL values with before unlisting (if they are present). Default is \code{NA}.} \item{fct_as_chr}{(scalar \code{logical})\cr When \code{TRUE}, factor elements will be converted to character before unlisting. When the column being unlisted contains mixed types of classes, the factor elements are often converted to the underlying integer value instead of retaining the label. Default is \code{TRUE}.} } \value{ a data frame } \description{ Unlist ARD Columns } \examples{ ADSL |> ard_categorical(by = ARM, variables = AGEGR1) |> apply_fmt_fn() |> unlist_ard_columns() ADSL |> ard_continuous(by = ARM, variables = AGE) |> apply_fmt_fn() |> unlist_ard_columns() } cards/man/add_calculated_row.Rd0000644000176200001440000000265414663461604016231 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/add_calculated_row.R \name{add_calculated_row} \alias{add_calculated_row} \title{Add Calculated Row} \usage{ add_calculated_row( x, expr, stat_name, by = c(all_ard_groups(), all_ard_variables(), any_of("context")), stat_label = stat_name, fmt_fn = NULL ) } \arguments{ \item{x}{(\code{card})\cr data frame of class \code{'card'}} \item{expr}{(\code{expression})\cr an expression} \item{stat_name}{(\code{string})\cr string naming the new statistic} \item{by}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Grouping variables to calculate statistics within} \item{stat_label}{(\code{string})\cr string of the statistic label. Default is the \code{stat_name}.} \item{fmt_fn}{(\code{integer}, \code{function}, \code{string})\cr a function of an integer or string that can be converted to a function with \code{alias_as_fmt_fn()}.} } \value{ an ARD data frame of class 'card' } \description{ Use this function to add a new statistic row that is a function of the other statistics in an ARD. } \examples{ ard_continuous(mtcars, variables = mpg) |> add_calculated_row(expr = max - min, stat_name = "range") ard_continuous(mtcars, variables = mpg) |> add_calculated_row( expr = dplyr::case_when( mean > median ~ "Right Skew", mean < median ~ "Left Skew", .default = "Symmetric" ), stat_name = "skew" ) } cards/man/default_stat_labels.Rd0000644000176200001440000000054614567176413016434 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/default_stat_labels.R \name{default_stat_labels} \alias{default_stat_labels} \title{Defaults for Statistical Arguments} \usage{ default_stat_labels() } \value{ named list } \description{ Returns a named list of statistics labels } \examples{ # stat labels default_stat_labels() } cards/man/replace_null_statistic.Rd0000644000176200001440000000247214675616454017173 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/replace_null_statistic.R \name{replace_null_statistic} \alias{replace_null_statistic} \title{Replace NULL Statistics with Specified Value} \usage{ replace_null_statistic(x, value = NA, rows = TRUE) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} \item{value}{(usually a \code{scalar})\cr The value to replace \code{NULL} values with. Default is \code{NA}.} \item{rows}{(\code{\link[rlang:args_data_masking]{data-masking}})\cr Expression that return a logical value, and are defined in terms of the variables in \code{.data}. Only rows for which the condition evaluates to \code{TRUE} are replaced. Default is \code{TRUE}, which applies to all rows.} } \value{ an ARD data frame of class 'card' } \description{ When a statistical summary function errors, the \code{"stat"} column will be \code{NULL}. It is, however, sometimes useful to replace these values with a non-\code{NULL} value, e.g. \code{NA}. } \examples{ # the quantile functions error because the input is character, while the median function returns NA data.frame(x = rep_len(NA_character_, 10)) |> ard_continuous( variables = x, statistic = ~ continuous_summary_fns(c("median", "p25", "p75")) ) |> replace_null_statistic(rows = !is.null(error)) } cards/man/dot-lst_results_as_df.Rd0000644000176200001440000000166314721232376016730 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_continuous.R \name{.lst_results_as_df} \alias{.lst_results_as_df} \title{Prepare Results as Data Frame} \usage{ .lst_results_as_df(x, variable, fun_name, fun) } \arguments{ \item{x}{(named \code{list})\cr the result from \code{\link[=eval_capture_conditions]{eval_capture_conditions()}}} \item{variable}{(\code{string})\cr variable name of the results} \item{fun_name}{(\code{string})\cr name of function called to get results in \code{x}} } \value{ a data frame } \description{ Function takes the results from \code{\link[=eval_capture_conditions]{eval_capture_conditions()}}, which is a named list, e.g. \code{list(result=, warning=, error=)}, and converts it to a data frame. } \examples{ msgs <- eval_capture_conditions({ warning("Warning 1") warning("Warning 2") letters[1:2] }) cards:::.lst_results_as_df(msgs, "result", "mean") } \keyword{internal} cards/man/cards-package.Rd0000644000176200001440000000246514746733642015124 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cards-package.R \docType{package} \name{cards-package} \alias{cards} \alias{cards-package} \title{cards: Analysis Results Data} \description{ \if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}} Construct CDISC (Clinical Data Interchange Standards Consortium) compliant Analysis Results Data objects. These objects are used and re-used to construct summary tables, visualizations, and written reports. The package also exports utilities for working with these objects and creating new Analysis Results Data objects. } \seealso{ Useful links: \itemize{ \item \url{https://github.com/insightsengineering/cards} \item \url{https://insightsengineering.github.io/cards/} \item Report bugs at \url{https://github.com/insightsengineering/cards/issues} } } \author{ \strong{Maintainer}: Daniel D. Sjoberg \email{danield.sjoberg@gmail.com} (\href{https://orcid.org/0000-0003-0862-2018}{ORCID}) Authors: \itemize{ \item Becca Krouse \email{becca.z.krouse@gsk.com} \item Emily de la Rua \email{emily.de_la_rua@contractors.roche.com} } Other contributors: \itemize{ \item F. Hoffmann-La Roche AG [copyright holder, funder] \item GlaxoSmithKline Research & Development Limited [copyright holder] } } \keyword{internal} cards/man/figures/0000755000176200001440000000000014746733642013605 5ustar liggesuserscards/man/figures/lifecycle-questioning.svg0000644000176200001440000000244414567176413020632 0ustar liggesusers lifecycle: questioning lifecycle questioning cards/man/figures/lifecycle-stable.svg0000644000176200001440000000247214567176413017540 0ustar liggesusers lifecycle: stable lifecycle stable cards/man/figures/lifecycle-experimental.svg0000644000176200001440000000245014567176413020757 0ustar liggesusers lifecycle: experimental lifecycle experimental cards/man/figures/lifecycle-deprecated.svg0000644000176200001440000000244014567176413020361 0ustar liggesusers lifecycle: deprecated lifecycle deprecated cards/man/figures/lifecycle-superseded.svg0000644000176200001440000000244014567176413020424 0ustar liggesusers lifecycle: superseded lifecycle superseded cards/man/figures/logo.png0000644000176200001440000013111314746733642015253 0ustar liggesusers‰PNG  IHDRðð>Ué’ cHRMz&€„ú€èu0ê`:˜pœºQ<bKGDÿÿÿ ½§“ pHYs.#.#x¥?vtIMEè;!a·æõ€IDATxÚì½u˜]çuïÿÙxp˜Å,K¶Ø"3ÄvªÚ¤½MÚ4½¹÷×ÞÞÞBÚÞ¶· µahtÀ1e1˲˜if4Òg4:¸é÷dž9gæ É#pªõ-—Š"¡¬¬’]O˜?øÁo÷­Ý•qévßÀ]_yê©çðû­POøŒ,óyIâ|>!Ë4µ3«W/ï-,¬çԩ÷û6ïÊ8ÉÝø·Dž|ò9 äPˆû$‰O  û[Á4Mkiò¹d’Ÿûýô< ‡}ÿvßö]y‹rWßæòÄÏÑÒb &’ÄEžŠ„”7kY‚–%Ä-‹_ŸM$Ø)Šè?ÿù]%~;Ë]~›J}ýs,^ ==È2ω"& #¼QË Ã4ùžaðåmÛ¤Ó3gšÖúõß»ÝtWn@î*ðÛPÞñŽç°,ŠÂƒ¢ÈŸ ‹yôg°°,Ëâ´iò%Ãà{²LG2 ¯½vwG~;É]~Éã?‡¦!…BÌEþDy‡ ¾ñ3ZX–`X;M“Ï$“üF–‰½üò]%~»È]~ÈSO=Gi©ÉåËb,óQQäC@ÙÈæ²m/ #ý°,"¦Ék¦Éçb1öJÆ/~qW‘ït¹›FºƒeÕªç™?ºNn<.¼_–ù¼(òŒ 5åuFVbA@fˆ¢õ„Ï'ÔÕU·ìرµ«¾~:¯¼ò“Û=we¹»ß¡òÎw~ATAÐW‚ù§‚Àý‚`©#½2Wqý~?3gÍ$;;›½{örýúuAQ‘툵`SÁ`èß“Ióû[¶l¿¾}ûŠŠŠn÷°Ü•rWï0yì±çH$1+Ëš!Ëü‘(ò.Ë"{´;®$IÔ7Ô³råJ¦N›†¢(´¶¶²yã&:H4Q‘Ý[EÝçóoóùüŸin¾ôzV–?q×?¾³ä®ß!òøãÏ‘ Ñ(å²Ì‡E‘€U #›¿®ò–––°tÙýÌ¿w>YYYž"J’ˆ$Šœ:u’_ýò×?~Ã0F¥ÈÎ÷=†ÁK†Áb1á¢XæÝüñ!wø6ˇa ø|,–$þTxPðtœ« ªª2mú4V¬\I}}=’$¥)¯û[[DQ"‹#W¯\aëÖ­ì~c7===£ò´“iY4M>¯ë¼,Iôtw ܂ܹ«À·A}ô9"„ü|&IEÞäÖÏE‘šÚV¬XÉÌY3ñù|ƒv]`K’ˆa˜H¢ˆ hºNss37làè‘£$‰Q*2X Ëbað™D‚m²LòÕWïšÕ·Zî*ð-”%KÞOm­Ao¯P¬(¼ ü Ð0 }ñ´°¨¥K—²`áB²³³¥‹€4eM=>õûÔ'“IZšÎ°nÝzŽ;Žiš£ŒXpÝ4yÑ0ø÷«W…ã99–õ«_ÝUä[%wøÈC=G0ºNPUyLù¤ p¯ Œœ‡w4 qϼ{¸ÿþû©®©vOóvWU‘Ijº÷·»gÚEQÀ4ME&à÷áS®u^gíÚõlݲ•ööö±ìÆX-–ÅW4ÿ,(°®œ?/°ví]E¾ÙrWo²<ñÄs$“È¡ó2¿ÇûËü†WùEaÒäɬ\µ’ & ˲§”©ÊðûH$“i»®û]êoTEÁÂBÓtdIBUedYF¢±8mçÛØ¶m»ßØM_o‚8jE6-‹ÝNÙâ/ÅŠœ?/óæ›ß¹Ý¯á·Vî"±n’<ôÐs\¼Ø Lšäkø3Iâÿ:»®2Üq©¾lUu5?ñ>ö(eeeiþ­+îgºa¸&mÚΩÈ2‚(`šö9}>C7Ð4’"Ëè†A"©!  ø)ÈÏgö¬™”WV‰DèììÄ0 ïÜC‰sÙJAà1Yfºe TÕº4eÊLó.‰ÀÍ‘»;ð8Ë=÷<Ïôé&]]B,ó^Qäã¢Èd°-Š*??Ÿ…‹²hñbòóó™Â²,!šndTh÷\¢è*¨‰aH¢ˆßï#cšXÃVxçßYá¢(bš&}‘8=½½!Š<=š2?W‘dY¦±±‘•«W1yòdEA, 1•zŒ+’$’ ‰ÅÑÝ8m””àVªÈ²„,Kˆ‚ˆ( èºmF[–…OUPU…¾HlPP¬­­M7²ß~b±‘a™Î]cY‚nYì0M>“HðºÏGìÔ)‘Ç¿{»_ßÛZî*ð[‡~žiÓ4ššäjYæ#¢È‡òѦ…ÊÊÊX¶ü~-\@nNÑxÃ03Ÿ`pn7°#Èšn‰Æ1MÓû]ªÙ­*ý¦4ØÊ/K>ŸŠeZDb1Ϭ–$ YÓ¢Ú©Š¬i'Oœ`Æ œ>u]×Ç¢È}¦É«¦Éç¢Qa¿,[wËß‚Ü bÝ€Lú~~xšfåXVÖ ‚`|ÌgìÑâ–srrXvÿ2ž}׳̞=‹@ÀO"© Š"ƒ­€®ß9pGÔuÓùÌHÙ…]å•e I1L Ë4mO\°ƒZ†a’ÔôAé'Ó4½EÄ}žÔ…C’$JJK˜>}ùùùtvvÒÛÛ ÌøÁ"¸e‹3E‘'…ù¦‰ªª,—$>)ЬÔ‘‚T®âú|>fÌœÁŠ•+©­­u‚H`šƒs¶îq’$¡È’gâeRŽ,¢é:@ZÎwà¹SiÇÏô<®‚wtt°më6ÞØµ‹®®®±øÇ–eqÄ4ù7]ç'²lu½ôÒnÏ‹}›Ê]¥<úèstw bq±5M’ì2?°r¶G†š¯©ðÇúúzV¬ZÉôéÓQUuTE÷é ;ò"1ÐÄ+‡}Ÿ~¿Ši˜ŒL×swíÖÖV6nØÀ¡C‡HÄÇËLZ›XæFŸÏJ:$sæÌÝüñHrׄA¾ûÝñòË?eÁ‚Eå~òã²Ì¿ +¿=9GVÞ’’~äaž|Ç“ÔÖÙ»nêän¢E 3ývôJÔŸV üøTÅñ™Í!wíÔ¿A //iÓ§S^QAOw]]]Cîüé÷4ˆ"OÈ2u¦)œÍʲڧL™iÝÍ/wx±,‹+Wºðù|ÙÓ¦Íx_,ùœah¿#äÆÏ5M“¬¬,–,]Â;ßù,3gÍ´w]ÓµR¹2–ß§þv,”:¢h—†A,žÄpÀ!MöL »xH’DYYÓgÌ ''›k×®Ñ××7â=Ø‹"s%‰ÇT•pæ±Ç¦öšæ\.\¸ëg’»&tyê©÷kÊ„ KãñØF#«u]µŸ«ª*S§Ne媕Lœ8AÐu)È3~Ò¯hn.vøk»ß‡CDAðRS™v_Q´¡›’$¡ë:±x2£ù.W®\aËæ-¼¹{7½½½c1«MËb¿iòyMãY¦÷g?»­(w8EyäyÚÚD¡±Ñ˜(Iü¡¢ˆÏ›¦™?šÉïúÕÕÕ¬X¹‚™³fá÷ûñûtÝ ©é·LyÝ{UM‡NŽtŒ,ÛF™a˜ö>€YÀ=¯,K(²Œ¦ëhš0j§6 Ã.[\¿£G’L&Ç¢ÈqËb­ão—$´»ÜÕýrW±Á øŠM3ùœ ð‡‚@£½ãŽEUPXÀâÅKXºt yùy躎$ŠèŽ"Œ´ÜlÍõÝÝÕ§ÚftÒQÌc0ÚHuêuA sèÐ!6nØHkkëXË;M“_ììädVÖÝüñ]æé§ŸsËü‘$> ,K nÙ4M¯ÌoÅŠ”—— EÞHŸiŽ'ƒ|É[%cBû| ²$'0T–>Ê|¤s»ÊÚÝÕÅ®]»Ø¶míc…e6™&_Öu¾›•e]½xQdÆÿºl ÿeøñÇŸÃ0æ‰"ŸEž+hÏ£Ñås'LœÀŠ+˜1c:>ŸAY’°°ˆDâH’ˆÏ§ÒÛMÃ4ß©â¡ÜÛ4 ŸOE7 ÏLvåFŸÅu5,ËâÒÅ‹lÚ´™}{÷éëCp +F8ƒÛMâ Ó䳚ƯD‘è+¯ü×ÜïìudõêçY·NžzJ«•eþ@ùP2šùè*aeU%?ü0Ó¦OÃçó#’(áó)ÄâI°,ɤæU vÒe×oh»âúÓ6úK÷ÊßÊ5DQD×uNŸ>͆õë9yâ$š¦eGŽš&¿4M>ò¦¢ü×ë¶ø_FßñŽçeÐuòÜ2?A`Š XÂhËüòòò¼2¿‚‚‚Œ@ —ÊÆ-åKjú˜v_·AŒÛ¼k»1wŸª È2ªjý÷öEI$µº7wövyg!ˆEcìß¿ŸM›6Òv¾-Íäþ|\5M¾c|ùå—Ã-O<ÑgýWQäÿ ì–ù©*«öÇe‚`É£îrð3kÖlV¬XáÑÙ Åþ¨*2ºn`˜ý˜æ±Ltw‚K¢ ‡|«~çÜCÿñáP€€ß&Ë4L“žÞHÆÓXžÏ¶ZÒ A ³³“Û·³sÇÎ1”-zÝO˜&ÿ®ëü0;Ûêø ÓgL' ë†WO+K¦³;»L‘eTE&OÜÑ º‹…eZH²„išiõÇ€·Dcãó\é°K‰xB³1í#õ·î¿EQ@DŒ×Å-[<Ûr–6pøðaâñøXüã¤e±Áenþmè&qgμQÈÊ•ÏÑØhqù2¥€üAQä C¯ñlðÇâ’b–,YÊÂE (.*Bð¢È=}Q~Ÿƒ¦Jb¹8 ï4qïÍ Çœ'UÒÜ)1r´`t×W™PÐo›ê¦9dNܲ,TEö¬QQ‰dr0­(ŠhZ’ǰmËN:•FÚ7ü=ÐešüØ0ø·ÎNáX0h™¿þõÛS‘ïÌ™7Œ””|ˆ‡–H&Åß/¼#éûXóq´t6áp˜yóçsÿòû)))qð¿ †i!;yÜx"™q’ äf¾ÙÊûVümWü>Õ_¸øæL«ñöí]Ó<ð£¥æeº&àHHNž8žÔJxUSÁŠ"Ó××ÇÖ­ÛØ°a#mmÆ Ëlµ,¾ªë|»´Ô¼´w¯Ì›o¾½HöÞV üÄÏ¡iÈÁ $‰OJ’ø¨e™þњˊ¢0eêV®\Eã„F$Iò Î]qÙ S'³;ÙÝsÝ,¥I†Ú¹\ô vÆÕæ~Ð Ã3—cή8Öçê>‡¢ê'™·©kÍ!b `+qNVØæ¥ŽÆlž/ûÇŠ"ãWUìráÂvlßÁöíÛ¹~½k”fµ×mq¯ÓMâ5Ÿ¾óçá7Þ;òÛ¢ ÿÁŸ#™-ÔÔXü~þB’øA°î±,K†a&<`™¦Wæ÷Ä;žä‘G¡´´Ô;ÆÆ.Û’‰ÑBlD•…… ˆ7M’Õá@ü>Õëž0ðYS}ÌL5¿xçòûTºhxßZŒ½Jjà}¦E¹¥Éd©ØïÃòhlMÓB‘e|>µ¿tð©*ª*cñ„F0hCU%QD”Ä´sZ–Mû“Ô4Bá0Ó§O£ºº†X4Fgg§“«΢°Ūá1Yf¦irI’¸0mÚLóäÉ;Ÿ äŽVà¯|廈¢ˆªÊ…55ÖG$‰ÏŠ" ‚‰ŠÆ+ó+(`ÕêÕ<õÌÓL˜0Áë¡ }L(€i˜i¥m™]å¹Ùé#Ù)$HS*Áæ†v-€×·jƨnÿoü~Š,y$wÚý÷TÅ |È’ä)ž{¿OAUä1p<%IB’%;0hÚQIÑ ÝöM¥7 ÃF³9ï àSñ©ŠCboß‘B×cš&ºiRPPÀôÓ)//£·g´´>‚€ LEžTUÊ€ædrvç¼y3hn¾sùŽ4¡óò^`Õ*ƒHÄäæú±,㓦i,°yt~n0dÎÜ9,_¾œŠÊÊA;Bj—Ó´F4%mTáÍ5Ÿ‡ŠÈB¿)oç«Óƒ:²$y‹ÌPç–e ¿O%™ÔÐSc´e†v0LEp,ÛÄMç¡ö© ª"Ó‰¶¢»ñ¿OÅïW‰Ç“N/&; 5pÌ$v;Áé5tNÚÍ,„‚~ºººX¿~#Û¶nãÚµkc…ež1M¾¤ë|¯°Ðjß°A¢¥åÎóï8~ì±çÐ4¤p˜¹¢ÈŸˆ"ïB£õseYfâĉ¬\µ’I“'{ÝüÆê?ÞIUVwÁpE–$QHÙmÛ6Cí]o¸¨xjßH‹…wþVdÙiÁb§Ùܯ¯“ªÈ^°*•LÞí"O$=…N}6QœÛ`’@˲ŸÓ²,OÙ%QtÆÃÌxߢ(Úÿ9þñºuëØ·wÑht,ŠlX;M“Ï&“üZ–‰½üòåßþYëÈ’%ϳeK/Ï<®•e>*Š|({En¼Ýݳ¼¢œåË—3wî=CÁaWô;Y.Un4YIÍû\lßV–$"±øˆ»jêðÛ>q,–H3E%ÇÏL%vïw9ìŸÞ1¢(ð©h†AÒ¹·Lþo0à'à÷ÑÓI‹,µ˜ ”ÔÀi # JK¥Þ«$J¶å"‰D£1N<Ɇõ8yòäºI€e1M~nš|®·WØXÆBësÛø¡‡ž';Û$™òd™w‰"$L@Å”QÜš››Ë‚… X¼d ………i»Œk^ÞÉùÚLÏ嚤š¦Û~â€hlºlG˜Qàµ=×aÀ&‰"¦“öq;3¸¦¨»cúT…h,>È—e Ó0ûú+4ûƒS ¢(:eˆƒ‰ì3ño ¼ïÔç¸ë†‚~A §•a¦geÿ¾}lݲ•¶óç1œ çÈï€+¦É· ƒ¯¾ü²ïìC%­5kn/šë6ÎèðôÓ4Mð©*+œ2¿å‚`)£.óóû™9k¦SæW3ÈDtKÖn–Ü,|`¤×m÷éFT-ÓòÚ©Ø,˜ ª,‰ÅGµPeò!ýª‚$KÄIá÷©H¢H$÷@.Ø%‘ÔÒÙ=Wëk¬Ø.]·McU‘1 ¿_õÐ^ª"£ª ñxò†Ê'ÝúiÉi¹ª§$YJkÁê.tEÙµs'¯¿¾ŽÎÎα¤,Ëâ¸ÓMâG~¿u}çN?çÎ}kÜÞÿXä¶D¡{ì9êê4QU…™ªÊßJ%L¤Ñø¹’$1ažzúixðŠŠ‹á–ÁŽzšÖÍ!”sC’( [bx#2Ð\ì7e;€d¥ï´¦i9JÒüHçOýÏèz´[‘eoÇ´a¤ö±nÔÛŽ÷·Ïg³î†ƒ~4]G–$ïþÜçpa©¦i!K¡` 2¶HÍ;»£ÿp- É%§ä½}~;Âmøý~êëhhlD‘%®]ë `V»i'ŠÁzH’„¹¹ù]ï~÷}çî»o‘¾qãºqyÿcš+·òb=ô<ÅÅ&½½B…,óaQä#@ÕHï,u"Ûe~˘7>ÙÙÙ€i™i»ŽéOÝ,¶kd}ôöE‡$}{«©§L>âh«£ÆJh—*¢H“EÐ4`À‡îD•S­`Àß§O$ñ©2±x’Xd§J7 TEA𠲡€]slûË"Ìž5‹P8̵kôõöŽp_絚L&gZ–ñDw÷µ<¿_mÚ¶ms÷k¯­á‡?¼ùþñMWà÷½ï#„B!%;;°Â²’ÿ"æ'DQ¨)Hå¾\UU™;w/¼ðú±]k¸×V|ß}£»›•6LYQd™x"™Fhç Ýhœw#ˆöÉÎ"k68#õ9F ÝÙ" ~§¶Ù†nš$’6tTì€_"©á÷Ù;q"©!Šõ õÌš9Qioo'ûîÜ…È4ͬd2±4‘ˆ¯¾ÿþ•ú•+íM>ø`Ê9{öæµ…¹i&ô³Ïþ‚ ãÚdI>.IÂû,ËÌK™_mm­×å  "8i”Ôâô¨c2‰¢£"‚»ÑÝPtRH#oÍ„ve Ù,9»ûÀgî¯Ú»y:°Ä0ð!Jn¡R,–ðòÍîo²ÃAQ ·7jCN± ©é(Šì)ørie¼Ü¾eUUH$’^‡ 7·ìó)^àðZ¹ÆIZZZؾu+Uþ8%V¡°.™4þuÒ¤©[¯]ëH~å+Ÿ¹)Ï;î#yÿýÏS_oÒÙI‰Ï'½æ€Uï]PYy‹ŠŠX¼d . ''ÇÉK©(²ì!y†B eöGáFçÎH5#w#×sŸÃMí ŒúºßLžc´×”lè*‰d?›¦äF÷qcéè,w§‹'’(²„ä¯V÷f" Gà÷)(Š‚®ëDc OyA O¤`ÄûÇÖïS8|ø¯½ösšššGå§,n]~ð'‰„þùx÷¸šÐO?ýŠBP×…§eYø¼ X/núc$Ür8fÁÂ<û®w1ïž{ÈÊ £ë†]pàød®_eš¦—Jq_”$ÙlŽn¾t(Ÿ´?-3ú‰”b*y'©© ±Š[Ð.Ë2àäYSvRE–+í37…`èºcºÊ¶ë ¡ÜgÏtŸne–,Iø|ªæe‰P(€î˜¿©z"I"á`ÐQZ»Œ¦éº}-7mZ£K·½kE’DoA“D AQÅãð‚ôfç²$ðÛ…"¢ ê]%ŠA§[yy9÷Ì›K äZG‘HdØûL‰#øu]»Ç²ÌG!îK$’MóçÏì+/ŸÉ™3ワ–Çå,ŽƒHð§¢Èÿ|ýæòðŠ«( óæÍåþåË©¨¬²'žà¤íƒÙ´,b?Lω"ºƒ/ŠYá ·ŒÆÁõ^óFäF&–,õ÷GîØçñW¹7`ûwÁ X¼?_«iÝÝÝ\ºx‘Ö³­\½zË2©«o ++ÌñãÇI$äææQSSMeUùùùø|>/wî–ê†A¯CfàJ"ÅÄLÝI-ÓrÆÙ²IètÝ ÆI„¤à,Dý ÐpPOÁI ¬fÍbéS}¨Šì¸SvÅ“}»gIxh1'÷ëd|>•¤¦{¾zo_Y‘ädç°jÕj¦M›ÎÆ yóÍ7éíí6Üÿ V­( ÿWUY‰ð|0HÏ MÀLók¼N Ëš&4>ç†p÷%ÕÔÔ°jõJæÏŸ,+hÎî¡™&†iy&¢eY`¤—ùéN €eÚJ”í•?Sºe,“â­Jkl´Ôã’šÝùO Å‚"‘8Ý==\¹|…ÖÖV.´µ‰ô‡©©©fæÌ¼úêÏI&“<òÈCäååÑÖvææföîÙƒ¬(”––RS[KEEùyyÞ•ÊIm8M¾>ƒ‹×Öu¿_E–eÌh€ÊçP0à*"‘F†ÅÓyüê L÷hÁ8‰dÒÞm5Ã4 ˜¦á1hºïÁp\.Ý…~ xQsÃ˸b˜&–}‘˜·¸ó̳ïdöÜ9ìܾ‹Å†Tä”Ï`‚(ºº1>2® ì(ì°ãí*o~~>‹/béÒ¥yÝðRW_×ßp}¬ÔSÜa-lÊM7¼HtÆ;¼…pÊTóÖ^ÕQ«iÑh=ƒ®it^¿Îùsçhi9˵ŽvU¥¢¼ŒùóçRSSMAAªêCmÈ`(äïx‚Ù³g0mÚT à§§‡¶¶ œ9ÓÄ}ûضe ÁPˆŠŠJjjk(--±[Æd€-~ãš&¢*¶Õ¤i~Ÿ¶L‹dRóÞ­9Ìy|ªB0à'jÅ=ÖM5ê"Ã0I&5‡mSöÌwˆ’úþÝŠ.ÝБ—ÁïMOï¥È2Š"§Q €ßïcö¬Ì=ƒò«_ý†S§N{nÊpS¾‡ñ›cã¬ÀË œ=g6ËW¬ ªªÊƧÆÒCõé€Û1Œþ¨'0ˆICÑ^¯S£Ä·³âȽþ‰ã'8°¿—’UèÐË=ÙÏFé¼Öé™myy¹ÑÛÛˇؿÿ g ƒ@$AÓ4ÒN+Iyyyäåå1cÆt’IÎÎNZ[[i:ÓÌÖÍ›‰Çãv Ê‰(+Š‚êS½¼º7¦ÎÿI²èº4ÝÀçSihhä¾ûîEú«“†ÛM“šN x¥Î—Ôˆ÷Pe–î8»~¬O±wbÝ\z˜:/l’=£¿0b@7Ó4½Ö2ñDI üÁ‚ªÈÜ{ï|Ù¾m;¯¿¾ŽŽŽŽ[:×n™›¦IQQï|׳LMér`¦$ú}ªJ,‘Hº[iBO$Ñ Ø «i:‚bƒæЃ$Š£ú—¤î¼‡b˦Í,^¼òò²·tÞô ˜5(*íŠ(Šlß¾Ó!, {NUU(--¡´´„{ïO<çêÕvZZZ8yòÍÍ-ôôô’——Gcc½·Óû|>ïY*IOO/Û·o§§§›'Ÿ|‚€ß‡a$’: ¨çuŸÇ0 úú¢ƒØQ<|5 ¢âq„T¥´,‹h<‘Æâþ^uÀ0®KàZy-#ïžœ\q(äG× |>II$“ÄãIⲄeÚµç>ô u ü쥟qìèÑß>¶,‹²²2¦M›–ÆEå"TUAtÒ4}ј}vŠÐãñ¤—.Ò ÃQF|¦I,žð®cŸË¢·/Ú¿ÜÔ’†Á¹Z7ʉDؽë ~ø,¸ïV 5¦i²mÛv&L˜0æH{  ¦¦šššj–-[J$áÒ¥Ë477söl+{öì# PUUEcc•••dgg 2ëêjùú׿Iss ¥eåiÊäB] ÓÆ^‹¢è´wøôH7àUÅb t]·!ž’]Æhpôß¿û>R)ˆ\Ä^0è'‘ЂiZ””ÓÞÞAuu÷Þ;ÞÞ>víÚÍáC‡X¾â~¦O›ŠiA4w>Lo'¶+‹4®);A,ÏqpoÝÀ0Ó Æ<¼÷ãÄâv¤3àn'æ iš$’ÃgLˤ/sZ°fnbߟÍu=žrKx๻¥»3»yÀTp†û[I´ªjãqmeæè¤›'6ãæXniÌ÷ïFÈ{{ûxs÷nŸë×»xã7†7M“ðý{÷¢iµµµ<ñÄ<úè£dggsõêUöíÛǃ>H^^Þ˜¯ÝÔÔÌ©S§ùÝßýW”IDQ¤±±êê*<Äo~ó:k~³†‚‚êꙤšÛŠ,!;9Z]7𫊠ØHñ‘Sýd?íæu‡ªµ<˜h&wM–$ü~·>’J ?Æ*ovÝØdo© ÅÅÁ¦B†SäþôAOO/—/]¦µõ,/\$‹’MMM5÷ο‡ŠŠr²²²Òv¯áï;³i–Í¢E‹Æuœššš©©©N›H¦iòâ‹/òçþçdgg³zõjòòòhnnæÿüŸÿ믾Êç>÷9Ž?Ε+WFô}3I2™díÚõÌ;gÔùnUU™?“'Obûö¬Y³–=oîáÊåËìܹ EQ((,¤±±‘Ɔ:ü cÒRʽŠ)ú†asš¤…C¯ç± ëÔÑtÞ>Óë|Ñ xgés&ˆ$õ÷v—’F€p+äm£À€—:J8¬ #—¨õs&™NÄ:u‡u£ŒÑh”öövΟ;Ç… èº~ŸÏGee÷ß¿„êê*òòòPe\Ÿ' QX8öHñPǹpá"?ü`Úç[¶láSŸú+V¬àÿñ©ªªlÅ>xð ò'Âßþíß’››KVVÖ˜ý_€ÒÛÛÃÒ¥‹3ÞW"‘  eÜ¡²²²x衘={6l¤©©™úú:ªªª¸zõ {Þ|“-›7 …©©®¦º¦š¼üÂá°·ˆ*ŠŒ¦ëDcñ~<¹n"¦×á!5Ö8fxÒ+t?sIò2ù䮨*ŠÓ4L“ÞHŒ,2{«Cð6R`wµÕ€¿kJ»­6Jê*ij¿Ò& :;;i;žÖÖV®ut Š"%%%̘>ººZŠŠl?öf½ˆT”ÑxI{{;𖤢¢Âû,‘HðÅ/~‘¢¢"þáþÁS^°MÙ9sæðÙÏ~–}èC\½z•¹sçRYY9¦ëööö²iÓî¿ÙÙÙißmذý×õRfÏ>û,=ôápxÐû---á=ïy§OŸaݺõ´µ]`åÊå<øàôôôpöl+gÎ4±~ÝzÉ$¹¹¹TWWSU]Mqq~ s*iŽ Õ”6 ‡œP’û¡”ÎŽnŠÖøu!­_´»ôEbôôö ÷ÖÞÎ[–;JGƒ[EÑ é§vªò(ÈaààþýhšF~~>õõµ¬\q?ee¥„B¡[Ž—Oii9K~~>ÙÙYÞgçÎc×®]üÞïý555›5k3gÎä{ßû‹/súiÛ¶í„ÃaæÌ™öùÙ³gùÄ'>ANNï}ï{9qâögÆOúSþáþ!#ÀE’$&OžDmm {÷îã׿þ »wïáÁW3þ<æÏŸ—÷ljjæè‘#‚@}C# .  âó)@©©9Lï(ÉÉV¸bšýíe3ùÄ©ðËT‹ÎM{e×—*O|£rG)°[—é>ðÊä¬x‚Sãi“’§Óœú}*‚€ s@ûöîcïž7yè¡hll ;;{T~ìÛA,ËòLÏÔ]ýÒ¥KD"fΜ9ä±’$QUUE `áÂ…cºî¥K—Ø»wïyÏ»MΣGrùòeþíßþåË—cš&ûöíãSŸúðÀ·¾õ­4k!Uü~?‹/bÚ´©lÞ¼•ï|ç{L:…+î'??ܳ­ík×®gÝÚµ¼ûÝÏ Ú),Ÿnx(—_ vȲìòTŸª¤ä¢GGE4hÓæç¢( ÀØsóÃÉøÙooQ,ËBì¢ü`Àg“ÁYC¯f΀ôû<³TÑ4=­*)sðÀ{ôæÏŸG^^ÞÊëæV<ÝÉÒ××ÇÕ«íÔ×§ïj’$h¦[–ÅÕ«W©©©aÊ”)£¾¦iš¬_¿Ñ2 ¨z(++Ãï÷ÓÚÚ ØïkÞ¼y|ãß ««‹Ïþó#¦UrssyòÉÇùà_ §§‡¯|åëlÞ¼•X,æ3++‹)S&ó¾÷½‡Ë—.ÑÞÞîíž6l²ž›ª_¢h÷kÊÎ È ÉÉ 9¹ç”ñ¡Âë¬BA?áPŸªxõçÉÓ­ÎÎ.:;»Æí½ßQ;°…]?šŠ9õ¾³ú)V5M÷VÕX<1ˆ²ÅEê¤Ú“É$º¡S\R<äõ;;;Ù±c[·n¥©© UUY¼x1ï|ç;)--×g>}:>ø YYYoýdÀ¥K—’’’´Ï+++ÉÍÍåàÁƒ<ýôÓ½páÛ·oçÞ{兩¸x4—àäÉS´¶¶ò‘ünÆ ÉÿñsàÀòóóÑu¿û»¿ã…^àܹsãúÌ<ò_þò—ÉÍÍ—ó57·PZZ2¨|°²²’Çœï~÷»A%ñxœ/~ñ‹œ>}šeË–:¨'X·nðJ¯( ÿóþOJJJøÃ?üCNž<é}·dÉ>øÁŽÉ…‘e™3¦óû¿ÿfÍšÉk¯ýœï~÷û´µ] ¯/Bçõët÷ô ë±XÂÆ[K’·«¦*²$ÚxèÊm3žªN•‘ŸP0@V(@NVˆœ¬’$ÒÓ¥/#™ÔH$´-‰›%·MSM臾¹|P^Z×Óx‰]¬«›ÿKí$K’×mÏÅíž9Ó4è^Ö¬Yç>õ)fÍšÅË/¿Ì«¯¾Ê×¾ö5~øÃòÍo~“Çóïÿþïãú’$IÂï÷KÐÌ0 ZZZhhlÆJ’Ä'?ùIª««ùà?È7¿ùMΜ9ãø®{ùïÿý¿ó…/|¼¼<î¹çžQ_sïÞ½$“‰AͶ¶6Ö¬Yƒæ°¢TVVò¥/} AøÄ'>Á¥K—ÞòóƒV¬¸Ÿßÿý‡ùÿøO~ùË_süø ‰Éd’d2I,‘$ÓÓÍÕÕtƒžÞHZ§ WE&Ûqç‚>ŸÚÏoíD Sÿ»]ÁÏÛ¦Àî.™¦ˆ^¡õÐǸâ¶®ÐÝð,,DAô”ZU}477“L¦ÓñLž<™oûÛ|ö³ŸeÖ¬Y^V’$~øažyæ^yå.\¸p»†kXéî«›ÚÚÌQæšš¾ýíoóÀðOÿôO<þøã<úè£|ààêÕ«ÔÕÕ1yòdêëëGu½®®.¶nÝÆŠË ‡Ówü³gÏò'ò'ìÙ³'m|¿ô¥/qîÜ9>ó™ÏŒ‰Zh8)((à™gžâù燋/òãÿÄ£aÒuáùéOùdÊRNE\_4F$O „J)-z\±, Ó¸sÚÖÞV|i ìþwX9æôÒRþ?+ú¢\ Ú+—/ó³—~ƑǸ~½‹k×®¥ÝKcc#÷ß¿E5 ƒË—/sèÐ!ZZZX¼x1W¯^åС›Ç°ÿV¤­í~¿XPHMM ŸùÌgøÍo~þðþú¯ÿšüà|ö³ŸÅçó±hÑ¢A9Ü¡dóæ­0cÆŒAßÍ;—Ù³góéOšË—/{ŸÏš5‹|àüìg?×…PEêêjùà_à…ÞOQa!ö ­í¼×¯j¨"IÁ‚dRGU»ñ™Ó$.“µ•Š¿vÛÝ dþ¸Õr[Ë í³Ås; ¸|Ä¢ "¨s‡å¬§P¤¤¤(ŠôööòæîÝ=z”)“'ñäû}^~ùZZZ)++ËxO{öìá›ßü&û÷ïðvãh4Ê®]»xôÑGo× )gÎ4QUUawFdY¦¾¾>m§Õ4Ï}îs£®‚:þ<‡æùçE<}‚Á Ÿþô§ùèG?ʇ?üaþò/ÿ’9sæ W¯^½ic ( sçÎfâÄ ìܹ“_þâ—”•—³xÉÏG¸ »Í× ¿6]Eb%¢Èi<^nëQ´É(ü>»Kc<ž¸Éœ/CËmUàônóxXd°Ù8L1½½¦k™N‚‘4­|6UJ’£GŽòÆ®]äççòüsïóò£µµµ455±hÑàr»—_~™?ÿó?gÞ¼yüÍßü “'Oì» .°cÇ¢Ñ(Á`ðv Û I&“œ?žeË–ÞÐñŠ¢°téèŽ5 ƒuë60uê”!Íu°-šo}ë[üó?ÿ3ùÈG¨®®Æ0 öîÝËÇ>ö±!s¿ã!ápˆÕ«W1sæLÖ¯ßÀ_|‘é3f0oþ|ÂápšÏš «Ô4{3q¿‹Dã„B›ìÎi•%Å~Ó:‰¥qr ‚psRgÛZ<ÐÜM- 4L†èùãþÛ=ûÿ¦ir¶¥…­[·’L$xðÁUÌš53 `ÐÐPÏ‘#G)â… ø›¿ùV¬XÁg?ûÙ´ZÖÚÚZöïßÏüÇÐÚÚ:¦\éÍ–k×:‰F£iÉ›%GãÒ¥Ë<ùäã#mjkkùÜç>ÇÁƒÙ²e |ô£åᇾéà;VÌ{ßûnšššxýõu|ÿ»ßcÑâE̘1A‘%‘@Àï5ˆÅ`Y6¥eÇSâñ„£è’hG²Ý.!ñdÒ® v®©ÈÒ-/d€ÛœÎTÜ^@ýŒ•Á€Ã0ûéI”… ‚Àµkר±};çZ[™?K–,ʘc-++Å4M®\¹’å;þò‘ߥ´´dÈ•0STTDssKš’••Åúõëy衇ÈÊÊBÓ4NŸ>;ð,Ëbþüùƒ`oU’1¶£×蹿Œ?¤Êõ‘WÂTY©ÒÔÔDmmÍMßÕÞxc7‚ pß}·Gߊø|>,¸—)S&³uë6^}åyðÁÕ: Øœàx¬§.ÌÒEæÅâI‡ ÂÄç³»ÙlÐP$=(I2ápñ´³ï8Xòå~†×YÐÞ}5Mãĉìܱƒp(È{Þó,&4Ž ÕÓÐPÏ©S§Y±Âô€ õõõüñÿ1ÿôOÿÄÉ“'illôÏ.\È¿ýÛ¿ašæˆ<Ëc•ËM]|ëO6Ò|¤Ãž(–EAIˆ¬ÝÈ”e$"†aqýbñ>΋}t´õnÑz¨ã».QT—ž4Lì@—0¸:σ?pÓîñСÃtv^çÝï~×-Ÿ[-yyy<õÔ“Ü3w¯¯]Ǿ÷}-^ÈìÙ³ ‡Cƒ¶ò&ƒ™0¯ða8^è›QtÇ(°÷ˆÎÓµµ]`û¶m\ëè`É’EÜ{ïüq  ÔÔT³nÝ®_¿NQQÑ-Æp¾Ÿp~Jq÷=%ƒ~·ûÕ3Äãþìr´„N2¦ïÓˆöh?vœÈå Å7éÞûúúظq3Ë–-¹!7åí(‚ P]SÍ?øGcýú 9|„eË–Ñ8¡Q‡ä7 »G—ÛŠô¿'Vª ÒÝÝÍ»vqòäIfLŸÆ»ž}†‚‚üA¿D"´··cYEEE„Ãá1 Z~~>ápˆsçÎßr­H¢@y}¡<‚Îäp¶÷µáê›Þ±c~¿ï¦G¸ïD‘e™Y³fÒØØÈ®]oð‹_ü‚â’–,]JYYV у6MDÁzÜÒ{½Ýƒý>ðáC‡Ù¶u+¥¥Å|ð狀ºjP}jWW/¾ø"/¾ø"/^D×uêëëùìg?›\?”(ŠBuu5MMÍ·u’ötĈõ$°,¼ü¯â·_‹¤Hr|˜`ZÍÍg™7ïæÜ÷•+WؽûMž}ö¯èE …‚¬ZµÂé&±‘ŸüèÇÌœ5“…‹yíqAðúpiº1¨ñ|ºÜá@;ñmzùÚшKöuêäI6oÚÈã?ʬY™Ó6/^䓟ü$o¼ñï|ç;ùøÇ?N<çĉ7äÇ64Ô³víz‰Äm›¨§w]bûOOÑu5‚ªÊ¬þðtæ=i×õ^:}Ií_Ñ»¯Fyõÿí%ïábà*5ÏÖÜèe‡Ó4Ù°auuµLœ8~„ó™$r=Ž(‰²Ç—èm¼¥¨¨w½ë´´´ðÒK/c+V®ì¯]"Ñþ\q&ñ”]–¸ckÖlfÕªÕÂÀzÛ¡ÄU^€ýûö³hÑBæÍË\TÇùË¿üK8Àw¾ó–.]ú–ýŒÊÊ ‰ííTVÞ<€ýp2ëÁ&-.GO$£:¡Üþ…Ä ô›Èl•ûžndï›ûˆ&³)ÈÏ¿‘K+gÎ4ÑÔÔÌïþî‡Æ•òv èIƒ×þe/S–U0û¡Ú›vñQihhàé§ŸâÅý„ùóï%+; Ã0H&ML‡Ozø}K¶cÅ Ý×x?äXQ&vM¦Ý¯§°phŒí®]»øå/Éÿù?ÿ‡eË–K ''‡¼¼<ΞmÓq.}èx jdU"œç'·$Dq]¡<¿w¶S$ý¨4_@aòârÕ êÆ\’H$Y·n=óæÝCYÙør€ ”«ÍݘIƒº9£ç຤  Ë4‰Æ¢€]bè‚<†ÛM4I$’$ãöW~à¥$Ik´ÛeN@(-+娱ãC2Anß¾¬¬¬qY¸ÅàMMMc:®ïZœu_=D¼÷æ¡n,Óâú•(Š?=(’L&im=OCÃèØ3Æ"û÷ï'‰°xñبeÇ*ºf°ççÍ4.,#§øÎ)Í455Ó‰ÐÛÛ;$ÿÚÐ"àBÇKÆU7l؎ϧ 7rƒ÷Ì›GSSsFÎ*€«W¯ …†­Å5M“½{÷röìÙQ_·¡¡Ž+W®‰Œ¾í£¡›œÙ}™žöب«º…ž4ÉÊO2··wÇÇÝäïîîaóæ­,_¾|DdW¼/I×•È [ Í{¯pfß&/¹=nËJ__ë×o¤¨¨ˆX,Š[þ;œï{³e\xâÄ>±,‹ââb¦Ï˜ÁÚµë2šeeettt ËêÐÝÝÍýÑñÊ+¯ŒúÚ¥¥¥X–Å¥K—G}L K¥§;Îõ+ãÛë5Ulà†L8/=}ÔÚÚJnnnàô—8¶¥í†¯·uë6rr²™={房Ýñ£“ì~ę́vÓ°ØùÓSìûe³ ZÑM¯;Ïœ‡jßv»ïŽ;é¼~Òò2¯ï°À踷o–ŒëU+*J1McÔ&´+î 6oþ|º»{=:›TY²d ±XlXåÜ·ogÏžeâĉ£¾v(¢¤¤˜–––Q£ø%Jër‰v½5:ÚàÜá.œèärS½±þâ Í$Ñ¥~%1t“Ó§›¨««E’$QX]ˆ¾ã¥S\:Óåý6Ó9¾¥dLñ>.\¸ÈþýxàÕƒüjÓ´ˆõö7U¿~±}¿>Ký£ó‘ÛŽ]ãWÿ~€7_mâû¾Ÿf/gö^fÎ#µoiìnµ\¹r…-[¶Q][C0¤´¤U±£çŠœâæÜâx\¸¿•æØLh7‡Y°p!›6m¡»»;í7óæÍãÉ'ŸäsŸû¯¼òÊ _ùĉ|úÓŸæ¾ûî5EŒ{톆zš›[F݉A”DÊsß²Üq®—µ_9Ä÷ÿ÷6¾öñõüâsûж“Œë €?Ë!ÚÓL^ýüÜ~’Æ ¶ÿ{dãy¾òÑu¼úÿöpí\ÁlÍ z]:}-?8žì·ˆ.ºNÇùÞ´{pir&Mš8¨«ÀÙWùïþ9¿þ⺮DØójÅu9ÔÎüb›¿wœ{ŸlàCŸ[ÎŒªi;~ Yi;r ->òâr'ˆÛQ$??Ÿââ"Š‹‹eÑã›vçŽ$ÿr@¿O6•DZuëv¼Ÿ@Îï÷óWõW´µµñ{¿÷{üÎïü<ð~¿Ÿ={öð½ï}ââbþþïÿ~ÌÕ9µµµlÛ¶ƒîîžQ3[D{“\¿á­t÷­šVÀsÿ´]3Т$ ;yßdÌnÜæ ¸ ‘Ò~r»íÕ`ê²JrŠ‚ìÿu ­GÚQü'v\$”ã#r=A(Ïçë Ýäõ¯búò* «úÇçĉ“´µµñÑþÞ “ØÐM¶ýðe¹ô¶Çøü ¿æú¥ùÂJ$e䵿yß®ïå‘ÍB *Ì¢+ª9¾¥?9ÅŽŸžâé?»—¢šÑ±aÞ.9s¦‰ý2qò$BÁUUU¦‰O ø=2Áé¯ô_¶?°eYÉÚÏ_{9sfSQQî}_[[Ë·¿ým¾øÅ/òòË/óÓŸþY–)((àÙgŸå£ýè ¦¢ª*.\µUeqz÷å·„{DX§ƒâ}Á,ÕCeÄå.ªë+cȾ_µ‹iC¦zN¿q™xo’…ï\ìˆj¬ùÚADàjKþ’æÇ_këeϯšyö݇(ßqûGÿ»¹p‘í;vR][C  ºªº?÷;Üî:ÄWN|GÈËËW¾cGв,‚Á ‹/fëÖítvŽng¼Q‘e™šššQÃ*eY¤¯7IçÅáÁý©µ ßÑž±Þ$—ÎtqùL——oÍÊöQ=Ù.VÐu³gÏel¢=PžÅ'¡ë:ëÖ­gúôiÔÔ ^yz¯ÅØùÒ)V}p:ÁœÁZ‰ˆÆÕ¦.üý™n;UŽmnCQeæ?ÙÀ/?¿oüÑÞxé4]èe÷+g¨™ZȤ…åÜLy+è(Ã0X»v=ªª’——GII‰×6S/¯±\GÅq}ܱ;°kJOš4‰Ã±yóž~ú7õš õüæ7¯ÇGÜédŸ„?[åúÕáØ~ß™_påÔÞóW™Q=1² ì{èì¼N__/ÕÕo½û‘#G¹zµgžy*ã÷o¾ÖDV^€9CTíûu gu°ø¹Éƒ¾ë»gÓcñ{'qïSÜûŽFNíºÄžŸ7³õ‡'˜po)ç^ãÿcÒMÞ}Oî¼DÇù–¼gò˜=qâ$GŽeÊ´©„B!*+*50I±°ì6@£ð{MӲƳî€x¤JY–Y²l)‡÷&Û¥¼¬ŒD,‘± x&É+ rýbß¿º±`FëñkĠùsç‡Ãäå½µòÁH$ʆ Y²dyyyƒ¾ïi±ãǧ˜¼´ôùå¼ãSó8²é<% 9TL½¹‘çdTãȺsdå=¸‹Åyýõµ‡©¨°Óvî Mm‹+Š’( úí¶*0l¸Ã4íFhãÓ¹í ¾ÝA¨Èî¿-Ë¢¢¢‚ÆÆ ¬]»Þkÿ8Þbh&›¿u†Ó[;iåBQX•Mוèßßh$Ò4,Œ¤I–S ÜÔÔLuuuÆn€c‘]»Þ@–eæÏŸ—ñû7_;ƒ¡›œÜ~‘Mÿy”΋}iïdçÏN“•`Öƒ‰LÃ>.3¸ÒÜÌQý2Á\’"²à†an´ÅîÁkÞ° ||ÛE°,&/»™¾gÏ.^¼Lye9Ù9T”WØ}†±ß§ß§’âSeÏ'N&5‚¡P`È‘‚àväÔo¨^`(¹í ¾ƒ?Š"£*Š×8Ê ø}ª×¿fÁ¢…\ºt…£GÝ”ûé¾å7_?Dû1“Ó'ÏŒjòäHFu -3³Q›"š©›„óü$µ$.\¸aÿוöövízƒÕ«Wet:ÎõpdÃyÞû7‹xìæpîÈ5¾þ±õüêßÐu9Bǹvýì4~dj`ðB"J"OýÙ|î)æ{¾•Ÿ~zíg»½1ØôÝcÔÍ.¦r»ï•ænvþø”‹Dº¬ÿÖêæ– 2J:;¯³~Ã&*«+ TUWáSUdIò˜$Eö:i>Tgî†éü—Y9-«¿iøxõßX‘e»M¨ÓsÆÐ QÀJ±?dY§*DcqLÓ$//yóç±~ý&Lh÷Ÿá|? kdÛÚΞi#‰‡‡=&§$H_w-¡#)ãG ch¦]Vého'™ÔÒic˲ظqUU•Lš”X±û•&f­ªfâ‚2Qà¹ÿ»„æ}WY÷Ãìûu Á°Jýœb&Ü7tî½ 2‹'þôf®®áË]KëÁv¦Þ_IÕÔÎêàÿrÿˆV‰eY´ì½B(LJxýÀš³ÈªÈÔåcç±Þ¼y ‰D‚¢" ),(Ä0Mâɤ×B%‹c9dšn kºÓÇËê¯oÏ nAÿhÙjF+·eÖ Ã4mŸ ‘´q¥ºá¹ƒ ŒDã^‹Ó4™1s&†a±k×îq¿'5 ó;¿˜¿úéïÈRGU^Î÷éNíß—bš¡lÁ,•ææ³äçç‘}ãpÃææNž<ŪU+3®þNv²û—MÔß[êB$Yd½¥|ô‹«Xü®‰´í`éû&|=aP7£ˆ‡>6‹Ž ½üìw3ëÊ'å1’\<Ñɑ穘:v?Ñhzã2÷??…@ÖØÔÖÖsìzc75uµƒÁ´´‘á˜ó®‚Îæ“Lj˜)ßÛùüöñ"ªª ªãǤrËw`É ¡jM‘ò»×¯…‰áýmY~¿ŸÅK—°aÝ:fΜNaaáX.=¢¨™ªI%”W”ÑÔÜÌ„ Ãþ>”íÃç“éëŒ{pÃ"ŒÙÈ É˜Ž¤J¨!™3MMÔÕÕÝpêAÓ4Ö®]Çܹ³3îâ–e±ë'§™t_U`‚$ÐÙÖÇ’wO¢júÈãŒëüê‹û™º´’™«j˜¾¼ŠËgº†¬ý½ÚÒMÓÞ+L]VIva€­/ž¤¸!—¢Ú‘¹¨O¿q‰®«Q¦ß_E [åð†s„ò|LY6¶ÝW×u^}Á`ÜÜ\JKK½s ÅðVVŠ" 999oÿçÏ\¢»gøVT‰‚ò0=í™#ÑmG¯qýR„±¨dxǟΣ;Ò ”––ŒíŽôöö²iÓ&î¿99™MðPžŸ‡?6›“;.ño~/"渆nòæÏ›™²´’ÂQT i ƒÝ?ofîcu£bÛhÙw•¦}Wxá_îçÑÍæü±kœ;zS;/’ŒQ=¼îáÿýÅÇYøìŽln£½¥‡Ë§»è¼Ð7j%‹D"¬Y³–âÒRBáU•UYþÀf`–d¬`E‘…ÂÂ< Fv%F+·e6Mó†LwU,++cÊ”)¬]»M yh9¶å_ùoëØñ“S˜†½¸Ì^:‘¼âlÚÎ_þ~Dì¢@F4–ž4ÙñÓS$":  @ss3¥¥%7Ü“xûö„B!æÎ=äo$EdÚŠ*^ø—e×dñã¿ÙÅ×þp={~ÞÄ5g9²é<÷>5ºø‰íh;ÙÉœGF¶ô¤Á†ÿ8ÂŒ•Õ”6æ2iqþÂJþØlvüø/ÿã›\=›yõ$8²á÷¿0•œ’ s«çcßxãA.Ÿéâ ú þã(¦1²RíÚµ›öŽÊÊËÈͱÍgÌÊ*>ŸŠß§z æUEFÅ~kq˜Kjšf]½zööÎzŸ™ä¶9Æ*î`Þ{ß}´·_ãСÃ7|®DTã'ÿ°‹µß8Ì‹½ƒklPFV^ˆÆIµCì¥J0Ûǵ `ŽCk[i=ÚANIð†L.Ã0ii9{Ãì“—/_fÏž}¬^½ U9 £% :Îõò¾¿]Äâ÷Ldó÷Žóƒ¿ÜÎÒ÷N¦ rd‚Ó0Ùû‹f–<;qT»oÓ›Wè鈱ðÙ~ú#Haþ“ ¼çoqtKçz3{f÷eLâ>¥Ÿ”™¸°œßù¿K˜²¨œ³Gã´··³iÓfªkl¼sMM ù¹Ù„ÃA$IrÒ›rš'K¢÷·(„‚dIħ*ø† N¹›?,à ¥N,Ë";;›{ï» 62iÒÄS>^±©qZö_¥jJþPÿ hhh`Ë–m#–æ—‡¸túº­¤\iéæèÆóì|é }t&û/uÞP+îîn®_¶vÌÇš¦Éºuih¨uþøÍ_4¡øef?T‹™º¬’+ÍÝ”M­¹'°òCÓ)ªYÙõ„Á†ÿ<ÊŒUÕä• ¶.Zö_¥~v12ðn%c:»^:Ãô•UøB™‰:Ï÷±ìýSÒ*´ŠeYlذ Ó‚‚ÂŠŠŠÈËËÃ4-|>çOhƒvâÔ~Ã4‰ÄìL‰ª*ø}¾t~¬[ o«8•‡×²,f̘Ž$)lß¾ó†Î')¿ó·‹ùÔ‹óáÏ­ðOUU•D£Q®]ÞÜÉ- íI¢'M¶ÿä$ßøã ´ëäÙ¿¸¹Ô;Ê;v nkkÃï÷ Kv?”œ:uš³gϲråŠQE¯»®DØþã“,}ß$¤ÌñQ7§8mQNDI zF!ì‘[Ô4í¹ŒªH,zv0ù`÷Õ(Û|’{ž¨O«bòŽ}ó2X3Ve.;¸¶•¾Þ ó†47·°wï>jëj¼Z_Q‰ÆãôEb^jÈ d¦1¤ÎÁdRÃ0L’I»í¨ß?ÔóÛ€ž±ñHbÜÇíL·H$QD’ìªÏÇ’eKyãÝ\¹rå†Î—U`ÆÊj «²èºáÒ©ëš ÉÎΦµuxXenq#apéÔuÖÿÇýø^ø×eL^RŽ rÃ˦¦f*++Çܳ)‘H°nÝzî½w>%%£ëzpj×%Êês™¾â­KŒ$Z\gÓwSo Y…ƒ±Ê‡^o%¿,ÌäŃS^zÒ`ý·ÒÑÖË©]—ˆt%Ò¾OÆtv¼|Š{ŸlÀÚmÐ’kÖ¬%+'‡¬ìl*Ê+()*DUdLÓVÊDRó”u¨@Uª"jºA_$6äû¶,ðùT¡ººœÊÊñ#¢xÛ)°aÚ5{P,êêê(¯¨dýú£f•Ì$W[ºùü ¿æ/Vý˜í?9‰$IÔÖVX^Ìñ‘UàÒéë„süL^\ža…ÛŠ«içλ!ÿwïÞ}Äã -Z0êc¦,©àq_Æ…ñ–CëÏÑu)’±Ú©¯3Îþ5g¹ï™ÆÌ»ïž+t´õ2ûá:6}÷ßüã ¬ýúa®µÙ¾òéÝ—IöéÌ~°vØ{8xðÍÍ-TUW‘McC>U% “"';LvVÐcœ@ÀG8ðÀ®¤íÆšŽ1L€V–erssÈÍ?°;R‡[ñR#‚.ýÎâ%‹9}ú gΜ¹ák^nêâøî‹´_ìáĨ¯¯çâÅKÄbCw`d©²ú®Ç™ÿdØ@™äÚµkD£Ñ1—vuu³eË6V®\>¦˜@VA€Ü’‹tE’1­/žàÚ¥>~ö»9´#íû¿n!·$Èăw(Ó0ÙôýãÌz †G>>›?üƃ¬úÐtμÊ÷ÿ×6~ú÷»Xÿ‡™ûÈð„ñ½½½¼¾vee¶é\Y‰…Hwo±xÂëï'ÑtÝN]Š"ŸÏÃêÃà4’$‰ü÷ÖvZ¼ üÖÀ©m3%Ó3;ì®3V¡#û.GXÿ­#ÙtÞKÕßSÂ#Í’§'±âwl Ayyº®sõêÐMÙ'ëÓÈ+ ±ì¹)ãâß´¶ž#;;Û+"­lÙ²•üü¦ãn•\× |â;PP™ÅÚ¯âµÝCǹº¯F9°¶•ïœq÷m9ØÎ…S,z§í7²T¦­¨âw?·‚§ÿ¿{¹ÒÜÍ¥ã×™3Âî»}ûº{z()-%?/Ÿ¢¢b—oZÄIâñÑXœDRÃ4-DQ ð!I¢gVû}*¡ Ÿ‹TY¶›{Çâ‰!¯í–& ÆKÆÕf²MØ_Ò”ÕJÿ<“b¤–#οw>ßûÎ öïßÏ‚÷ {Wþu¯|f¥u9ü¯Wž¢zz!áóP¢ª*¥¥E”–Ž™ß8·V‰©ÖÑõa%QDtÄÚ/ ™›"[NCeŸªHj$“S§M% ²uë¶¡/*<õ§óøèçWò_ZMÕ€úT˲øõ—ðŸÿ{+ßüÔ&ÄH×:¯ÑÛ;4óF^YhØÂþ±È•+WÑu#x$9~ü/^dùò‘Ëõn‡ôuÆ9¾å+>8mPîVzÚ£L[^ɔřŸùØ–6’q-®c胕»_;CI]53‡VŒS§Nsðà!jjkÈ ‡i¨¯÷QqÀ¦ u+äÀŽ›¦…¦^e’»¹€MìžÔl_9‘Ô†õ Ý㇪¾W~öÙ§‰D¢c²DA@”l¢/QÓv^À+×r -¸%ØÑ®©iwuXÆÞ½û¹páâ×,¨Êâ±Ïaî#u˜Vzó.A(¬ ùÈ/ RÛP‰(ˆ\ºtiÈóå•„HôiNáB&ý´´œ¥°°€ììѵ‡‰Åb¬[·E‹ÞPÎøVÈ®—O“Ô &dN]¿áКVV~`ÚQð¹Ö1}y?þë|ûO7qrçEo¬{;bìý,‹ß5iÈRÇD"Áš××’WOVVeeåÈŠêe-R*Õ-sÿ¶, Ÿª øE¾HŒ¸k‘% Ã0H$’Þ<Jâñ¸ÕÜÜJsóùqÛqõC¡ ±Xú %î@醆“hävMgÂ&aZ&¢ b˜¦3°6‡)&vuM5µµµ¬[·žçŸÿ´®%ÑøÑßîäðæó¼ã“óXò»Øýþ¦QT›M~y˜†Ù¥”+¥©¹™I“2w=Ì.Ð{=F¼/‰$û1tÓ°ˆõ¸ ÃèvE˲hnn¦¾¾~Ô;éîÝoÚÐÒ{ïÏW9nÒu%›¯5ñøÏͨ`{^k"˜çËèûºRTÍ3~/ÿó(?ùÇ7¸ÒÒM¸0ÀªLãrK7þ°ÂäEC[,{÷îãüù6¯»BeJû{Wâñ$Á€h,á…ø“Z:®TEÓÕ!U®¶ö°æ;‡¹r¹›¬ï¸ï©ŸL(×Çü'm*5È ÓÒ|Ã02.ÙEAz®ÅùêÇÖ£¨ñ¸Ž¥[$Œ>úªúF]ÔÛÛK{{«V­Õï¯]ëdûö<ñÄ£ƒãßb<äø– Äû’‹ù¯_ìc÷Ï›xúαCC"¢±oÍYÞù?îeÞãõìzù4k¾|ˆ–£í¼ï¯ IŸÓÕÕźõ¨¨¬$ ÒPWGQañD’h,ápU¥s°¹â¬$ID× z#Qyò,¢Ñ¸ (R~Ÿ—jñµ}àb,ëÆñ å–c¡ Ó² TEFQd[j?óPÊo3!˜‹Gª™#‰ý;rjW‡9sæ°nÝzꇤˆ-¨sïCõÙÜÆü‡ëQL¢XO‚oþéfön>Fáƒt÷t“Ÿ2§8Àûÿ~ ‘®j@F Êøü ‘D/¿ØxŽÑ¾¯‹/!IÒ¨ˆå6mÚLYY)S§Ž\?{»¤ff!õ³KØüí£”O)`ÆÊ*¯6xÛO’[ʘ÷(Ö¶¢Åuî{º‘pžŸ‡~ ß9‘¶ãר›3ôxmÙ²h4FÄ äŸ_@,žô”,à÷£;&°½ëÚsJw8®zú¢ˆ¢àY|®‚€é`£I Õ‰üGc±!£Ð±XÜjn_fÕ[ªÀ‚ ¢i:²,£FZ0@H H¹å†î@H¢HRÓÁVx@U›(UÜ¿çÌ˱cÃwuæøøý_E¤;INqÀ¥Ïðäú¥»s†«¢$ªº¹páBF–‰+§™:;U”£õ›››)//ÕnÚÒr–cÇŽóÁ¾0¬›p»¥|R>ïÿç¥ìøÉ)þóÿÛLÍŒ"V~`53 9´þOý‘wßXO‚ß=Ê’wO"œB ]`êÒ¡Ù7ÚÚÚØ±s—G“ÓP_çÌ¡¸<•DYB‘mÂ{Ó´wSY–ÐÙÞ4úÏ™ÉÅsé DQáU[ãÀ‚[ŒÄRIñ§ÔTzfYhN4o ¦IÀï#ô;ÚàSTUNÛ}SÕíê°e„®þ°JAE#irdÃ9Nî¼è5Å.¬Êâ¡ÎdîÒ'Öª¼p Ø3²?kg϶Ž*}ävW˜9sUUc'o»Õ"ˆ—N]gá3Yþþ©l{ñ_øÀo(ªÎfÒ‘wß=¿hì`ÖhÅ0 ^}=~¿ß¦É))%+;ÇÓ/ŸªBmUV8H8ÀïW¼µ<•fà|uçª,Kd;ÇO+‹gEŽ—ÜRN$“Îjeû’RJ>Ͳ¬AèÔü¯iš¦½Ê†I_4–b~æ-r»:äææ²yó–ïíWÎð÷O¿Êß?ý ǶڅüjPá½½ˆßÿ·UäJ8u´™¤6¾v®tuuÑÝÝMMM͈¿=tè0×®]ãþû—Þœ5ÎÒÞÚCÛñNVÿît<3ßÿÊ<ùßïáñOÌEV†ß}£Ý ¶¿tŠÏO%8ŠJ'WŽ?αãÇ©®­!² ÚSÝ/,è‹ÆˆÅ“$ñ„=?E"ð§Í¿ÐIY’¼Ü¯€@B³-GyÈrB°ÞÞ ìŽ¦ôöEIjú .“2š¦I4–°#}£haáz àgùòåUAE/7 ýH@QìÿÏçS øU²Â!dY"O‰Æ‰DbÃÜ™Íü6ž¹úÛVÐï®bÁ ŸdRórGµ,¼U ð£éº<BTE¦¦¦š &°nÝz>ð÷ O\üžI$â:Á•éË«9¼ñ¿úâDQà™?¿—ÆûJøÆ7Ïsölë¸ö%våÌ™&ª««FdÏØ±cªêãž{î¹Y¯f\åìþ«œÙs™?øòê1kè&W[{XüîIøÃ£‡‡îÞý&—¯\e欙6MNI:1€àسnŠÈm˜n ÊökSã3®Ûga7†Ao_Ì6¹Éd’óçÛFô¯^½ÊîÝ»Y½zå0…ãw–ô´ÇXòîI׎½„N”ÿ“¹c¢‰½ví6l¢²ºŠ@0Hmm ªª¦Í·jH–%BA¿—*2-“¤¦Ñݱ ÜSŽqw^IDEUðûTâñ¤×uá­6Þ¨Œël‡ÛÍRB¶¸Šjè†×óǧ*6ÃÁ‰îÔȴ椕ÜúÌLÌ nç‡ÜÜ\î™7uë†îê銳å'ØñÓSL¼¯ŒãAŠp74Ôqôè1¢Ñè¸v†èèè QY9ôDu)`jjj†”܉2cUµ‹Òó±‚ dlã2ÜmÚ´M×)**¢¨°üü|ï\®èºAÔL JªbsYÙx¶kšVñ¢K¥“Hhv̲%0LÍiB7žmCG+ãzÅ£GO£(²0Z_, ©Ù>HÂaºñ¦Ô’ ôó=zÿ/ôc[]º˲˜5{6¦e±k׃ÎwêK|áCk8¶õÏ}z1ÏýÝâAÊ PVVŽa\¹ru\_ÂÙ³­äææ’›;4™ù… ijjfåÊå·e¢Ü¨HŠxÓ[‰ºröl+»w®ÖîmTU… ˆƒ ðÝß \™¦E(à#ðÙ»é€ózé"à ÀŠøUÝ0=`Çí ëÈîÞýƨÓnÀQDE‘GEæš*.K7lPH»ŠôÈ¡»3/YÂŽ»hoO/$ï»gá3øØ×`òâŠ!{òde…)**>êTijj¦¶¶vØ|îåË—ÉÉɦ¤äÆ8¢ÛEÓ4^}-¡p˜œœÊÊÊÈÊê7ÛV½Y–]ÿÛÛ¥»·h,aïÌN;Ÿ3SÔ0Mâ í†é‘ÇSÆUW®\1êbew`ÜT’]oidô3çŠ v…GŠÿ10L/ v•Scc#Eº:Ì}´ŽåïŸ:,’{­††ºË Ç"‘H”Ë—/èÿ†Ãa"‘(ÑèøT=ý¶ÉáÃG8}ú U5Õv_ßòŠ´xŠOµáŽîg’d㜧_7 âɤgº¿±¡¿öߊlw"4MË© N/x°ÿ¸µÏ=® ¼aÃÆaÁÜ©â>¼»“ºíCA?JJ‘uª¤Ö §žmÚØJ›Êäáš6¦ó·«Ã±ã'hn¾±]´®®–ŽŽkôöŽOýoGG;¦iQVV:ìïjkkÉÉÉæ¥—^æÚµ›“Êz»J__¯¯]GIY¡Pw»A¼Íï,I’7G$I$ð EÁ‰b&p@²wŒ,K¾´õÔy¦ªÊÛŸVv,þ™›J’% ŬþZÌÁJ,K’xQ|>;’(:&¸ hšî½(÷å¸ç²,‹Ò²2¦OŸ~Ã]Š‹‹‘eiØrűH"‘tòŽÃ§Iü~ï~÷³ˆ¢ÈW¾òu6nÜ|w7vdçÎ7èì¼NYYy¹yiXrQÈ í+6¿UV(ˆ"ËD¢q’šN_4Žnd…žºñMÓ øUr²Ãü*†a"K"¡ ß«S{žÉ’D(4¾moG’qWà‘j"]ȶ¡ÑXÜ+œÎ$‚  ‘h ýd;‰tÃ0æÉý»3^Þ½&À½÷ÝKǵkÛr |hºáíž‘XÜSjÓ4‘DÙ3™ÁFö÷°¶û ¹ólvŽÑn`ã%ãº77Ÿ Š,{f2€€C¡#®45 à6þvÅ0L¯z$µôcñ„×,<³Ýc ä·/ê ¼ú™ñí®3…;vŒù9kjªééé¡««k”G Ù˜7ï>ô¡ÈÍÍe÷îÝ|ë[ßæË_þ*¯¼ò‡áúõ®AU,@€eË–òðrssùö·¿Ãk¯ýb ÷ôö—¦¦föí?@M]-YYa&M˜à°fˆžÕeš6ÕkqÿEÇíÂvË,ú?i‹`JÄÚ­ÿµ,Ë›w®(Ž+w«e\wà††š4…(š®£é:Š¢xé ÃPºQ¿Tؤ–‚•vÍÂ&¢s!”‚³ØåÒ,]ÓÜý;¾–e¡ª*K–.å7¿ú³fÍS Ï‚‚‚Á çεØd|´ –ªª*ªªªÐuë×»8wîüápäÈQÖ­ÛÀ¾}ûY½z'N¸£ë…oTöï?ÀÙÖVfÌœéå}û¢qY´4t‡Ç0L‰$š.ze‚î.šÔ4DQ@Ó4DID‘e’N`3•L1µ™iôÃy±@–mÒ÷ÞHô¶lÆU—/¿Ÿhtèj ;&c×$Xý9àe^ޏ9^÷{õ´¼ó˜®â2pU´ý“TT×À*&wå]´x1?úዜ>}fLÅÆÆÖ¯ß@"‘²‘$I˜¦A2yc%ˆv?Z••TVV°xñ"¢Ñ(—.]¦¹¹…£G±uëv|>åL˜ÐHMM ùȇٳg¯¼òUU•¬Zµ’ÒÒ’ßÿ¸§§‡uëÖSVQN0dòÄ  kvqKÂé*èÖž ‚=wÔ€‚æ þR}â¾h<-ø 8$‹‚‡Ìr ÞÁvý4]'‹#‰IÍ&°,ÓÛá3‹›c¿±WÞµkï~wÃ,ADÑc€T›™ÓtȲdó5;ôž’d¢‹Œqë-~ŸmŽkºÇâ‘V—$p ”n3´UKî.\TTÄŒ™3X»v=µµ5£n&VYYA<ž £ã™ Õ\bøÝ»÷ðøã¾å€— „B!hllÀ²,z{{ik»@SS3;wîbíÚõdggSWWÃÒ¥‹9~üßøÆ·¸÷Þù,Z´€¬¬Ñ±]Þɲuëvzzû¨©¯§´¤˜ÊŠ tG1L¼iÚ¦°,IvÑŒa 2qSY5Rc$’$y8{UQÐ4¥eaód†e¹@$›dÂî(’ùÛf¹"äæŽ½ îp2® ÷¢ªÊ ìæ|“¦íoØ…~ÖÓÉ ûÓ²Ãþ’$á÷©ô¦ÔYŠ¢]Þ¥i†aL¿ŽK à40€¢'uPæÍ›Ç÷Nœ`ß¾ý,\8º¦`999äæærölë ,I<ò?üáùÊW¾NQQ¿¿Q@ ÝÚH&“ôõöqõʾúÕ¯sÏ=sY¹rEšep'ËÉ“§8täS¦M% QYY噺²bã”ÝÖ­BÓ4]È ½¦y>Uñü`WDQ@²À.µ8ßtÒ™²,áó)Äã6z.‹Ûý„5»ŠNÓ ’Úp›…yÃñ¡dœ›› Ow'èî‰xfŸe™¦á™Àºax+U‘1L‹x2iC-Ôs‚“{Óƒš®#Ë’“ˆ3šÎ©â­ÀŠÂ’¥Kùùk¯2gÎl*RÈ¿‡’²²R,ËâÊ•+Ô×½—ïHb§/â\¹r•––ššZèììÄ4M:;;¹|ù …̘5‹ü‚|›ÁS’ðù|dee‘••åE eIB×4:¯wQU]ÉÕ«í<|„#G޲|ùý,Xpß-‡ŽEâñ8kÖ¬¥ °À+V…Bˆ‚M9¬é11d7°-;Ã0H&õþœºk a+X0 ‰¡ZRCw0Ò±xÒ ¦ZZt &LÛ_¶LkH^ó~¼ËŽ—ÜRJ›¾Ä°ónŽŸê®x–e‹%D{•”e #a¯lºe¸$Š6Îõi±‹Â!?}}1ôN×|tq;ÐUÕTS[WǺuFìê …(..¢¹¹e\ØÞ14®]뤵µ•¦¦f.^¼„aÑØX 4pàÀA»ÆyÎlJKKdEQ().±y Â!ü>¿g‚ˆ'ºNçõëÔ×ÕqüÄ ~³æuöîÝÇC=À´iSßr°ífÈž={¹pñ"3gÏ"'ÛN‰ÎŽjY>ŸêÆ $u°,‹D"IªsçbÝ ”‹ò³~’šFRÓ‚;ÙKI%5ÝÎ˶%©*Š3qdâ°@¦›!·ôMɲLV8ˆªª$“±x2½¦RÀá赣Цg ˜†•æ »ÀÀRºå\–ƒˆÉ\Ë™I Ó´S‚ÀÂE‹xq]Üó64ÔsâÄ)LÓ¼!Ò0 º»»9¾¦¦fÎ;O,%''‡ÚÚæÍ»‡ŠŠr‰[¶lãÝo …˜6s~¿Ñ-(,¤ª²ŠÜÜÜu«ýÁ¼„cºÉNI\‰ê£°°ˆ¢âb*++9yâ$ßùî÷™–/_æµà¼²yóâ‰ÅE›—‡iZ‚I@–°ÑXܦxp§„Å {5µ ßõ‰%IB7L¡¿'°,ËèºA_$æ¡MÓrÚ±$S ™v¬ÛA¾Å ™[ªÀªª"+²ãØ>ª!¤ƒ8\sÇïSÉÑtM{ß Nq¾ë/[)»´¤ÑÓåÃõöH$Ÿª8¾”Áœ¹s9~ì8o¾¹‡eË–0œ¡( mmmØöc´·_¥¥ÅFSµ·w Š"¥¥%Ìž=‹šš <ˆ)ØäíGŽeÍš×¹|å*UÕU!Š"¡Pêª*ŠŠJðûíŽyŠéSd»e]yãÞNÄÔîJ ;& îTp©ªB~neÔÖTsüø Þxsbժ̛7oÔuÞã-çÎc×®ÝÔ6Ô ¨ª¬Âe]1 ›Ö4- CO«.¼òA=¥vWr(cí±’‡‚èºí›†‰( Ñ¢Ó‘¤þZáþê6Áéä ÛÇ:;v(¸¥–Ë-Uàx"A$CUT ç]IÝY ÓDE5ãŠÍ¢ x¿IWü~ì´‹˜q;ÈÙÈ,Ái@e‹'Ó¢ÖáPE–¼^¯vW‡ElÙ¼™éÓ§zÄh™Äï÷3qâ¶mÛA]]¡PMÓèì줵õMMÍ\¸p]×)(ȧ¾¾ž+¤„@`ð˶,‹ .ðúëë8vìE%EÌœ= EQe™ªÊJ&66 ‰D]p‚möiº($I¯l3=‹Û#ªânLÓÂTQ?²H) ¸°Úêjªª«8~쯾ö öìÙËC=ȤIo),S×u^}þ`œœJKË<7¡ß5èÇÄ+²4ÀçÒÚ÷€Ý’'àWÑuŸÏf«t‘Xºn8ýª$QB,²BOÉ$>Ÿbû½¦‰$Ú»s"©Û¼ÐÑØ°ASÛµ¿1º¥ ì,Khq=-êS,ìܦ(ˆÄ•ÕJI ج‚€®Ç3Å“) Tpº‹²qk9æ”ÜàY\À£ªµ,‹‰“&qèÐ!6oÞÂÓO?5ìs-[¶Œ_ü_þòW(..¦««‹H$JVV˜šš{ìaÊËËÉÊÊÖOîêêbË–mìØ¹ ¿ßÏ´Ó8E TWUSTXˆ,Û¹L·É¹èöûqú+{þœCrHj$5UQüDcqÇgô;é%Í‹ÔJ¢HQQ÷øTVTpòä)N?Á·¾õmf̘ΫWQV^vKv™£GqâÄ)¦Í˜fGž+*PU… _%O’LjiÇTUA±d;M©Øp[wœ\±‘SBJËr0Ó†×ÂVÓû !ìl‰E,žDQHéà # ¡iö\VU%­ÛÈ`¾[nÔúNHßu]:OI´«@4ÍfÌOõ}uà O 9 {û ¼ï-ìI8°iš{ W‘ÇïqsI-½Â†½É,Yº”—ö3æÎKMMõÏ”““Í /<ÏÉ“§èèè`úôiTUU‘——;ªˆn"‘`ïÞ}¬[·h,Nm]9¹9‚@Nv6555”#Š‚(¤Wmáb¾û£÷‚ #:¸àÔÝ*O &ú«j’š˜¶ˆZ–…†“•eŠ‹KÉÉÉ¥¢²’“'OrêÄINüû—X¼xK—.!'gì\Ï£•h4Ê믯£¸¤˜P8LUe¥k·l쀋O¶y:ºaÃl-ÓÂ46Û†ãû»>¿"Ë @o_ÔÆÄ-²Ã!;lYø|Š¿ÅÙaûÁ ©Á©TZtZg¦1 IDAT ›+ÇQh˲PU(,Ì7>5¸®àvûP›,̈Ø¿3E‘u]ÇLYåÒƒX¢7XÚý[Qd'­y/îqL˜0µk×óÁ¾Xe Ìž=kLc`§OŸaÍš×9ßvŠªJ'MDEü>åT”Wà÷Û;¥ ÚÎ ̓h¸Á<°+ºâEäì©“Å0 Œ×ÏôÜ.8ßÞU|ÔÖÔ’Ÿ—OEE§Ob˶í8pÕ«W1gάQãÇÇ"»víæj{;3gÏ"?/ÒÒ2Ûo×u¯O/@"aW©aDSP€6ù¿Ìt\ËôvOÀiMk8Ä ’w|8püZ Qu*Ñ+Š~¿ï·CSEp¢¦ýƒj¸Y²WJú+j%I"ôÓ{>o*ÌRUä¢îÁÊéNö‘RL®â/X¸|ïû9rtÌ :”X–ÅåËWX·n=‡&¯ €™³g¡ª*’$Ù¥‚uuäååz ÜÒq€ÿŸ)=¢gPNÙ¦™Ñ÷ö"³’„!8´1ŽuTPO8¦²¢‚ÚÚZŽ=ÊO~úo¾¹‡‡~€†††qƒe¶·w°iÓfªjª ÔÖÖ¢(ŠGÌ`švA¾Ë&©iýõãŠÃ®á’<¸n‘›åœÒ.PˆDãX¦å¸f6ZÊíÊ øí 'M§ï¤‘\³Ý4M‡[ÚD2M≄Ëå”ñ½Ûxêß2v.µRIJÀÄ©,Iù˼¡ ß®@1úSšnx5Ÿ’$¡*²K]GòáÜó¹]Ö¯ßÈ„ Þ2Z©··—mÛv°uÛv$Yf² ¼Ü<ªª«()*&+$žH¢È6˜ÞÝ9¦ÍRÇÏV>ÑÕžçSTU! ²L\Æý,ð‹'ìÒɃJNYiI ùùÑÜÔÌÉ'øÚ׾ɜ9³Yµj%ÅÅEoÉ?¶,‹7a˜&………‘““›îÇJ’W'îuøpfMÓ |˜¦•V6˜úN%QÄï÷!Ivä:iêNž\  xÑ턦§X:‹'<Ü´…mÁÄ“I‚~•x"‰OU91‹Ló)™LZ/^yû"±†§öGºïö‹iZ „B>° OoŠ–êÓ‰ªË…à¸ìCv¾%û·³fÏâèÑ#ìÚõ«V­¸¡ÇK&“UqHÝm3:™Ô<~r]³1 ªjg>ú"1Ü¡½‘˜SÁá%·]™˜³{g²p~«|àA☪bçr‡{H]7ˆDâ^r 0Ã0¼ÚãÔô‚)fãзeá÷ûYºt)ëÖ®eæÌcÿ›¦Iss kÖ¬¥¥å,eå̬¯·­U¥¼¬Œ ‡ƽ€é[îÛra`/J®«æbR9Ùâ‰$²"ƒ“wEÑÉ;ÛJtòãñ¸Ý(>L±‚ àÕ—Ür$ÖÀž«© xÊ›)•Ú×FVo‡R@Ý0ÑÁ=…EÁNG„—î‡ÚYLœ4‘ãDZqã&Þõ®wŽh&Z–EGGë×odß¾ýdçæ0cöL|>¢“ª©®ª&;;Û[PDQô”Et ÅVZN Åýw*ç—é@B5³?DŸÊ–þ.ÒÇ>übÈÝ2Œ‹›wÎÍÍcÆô,JKK©¬ªâä‰|ÿ/2¡±‘‡z€ššêQùÇ¢©©™é³f΢¢¼"-˜i§uÇ÷´ÙYDÁnP&k¤i›ÈIMCÏÀ™ ưACnàOpX5ìk¹þ®æ´[1ì™L¦äÅIB?Á ÍÃ5c¼³oãš•Ÿ={&ºÎ;€9™nÔfÀ(¤ °Ð‹èUd/8L•v8sЄ3ÍþUÔý,} Ò™óSÏ+;H%É¡Mª.WvªÜ¼j^^›6m¦ºªŠüü¡!†‘H„-[¶ñãÿ”«ííÔOh¤´¬Y–ÉÍÉeÂÄ ÔÖÔz@×/sk}C;êìWUÀf„p©K ³¿LÀïK›xn‡ä¤2úÑ ü|à˜ …ds­Q ‡Ã”–”PQ^N àìÙVvlßIOO%%ÅÃvtìííåÅLN^.…E…4Ôד——?èƒ~Ÿ!w>tLi›yR–l¤•ÐÊÜ»HEdIÄ ‰¸&³,Éþ^QdBÁ€vüiû™ÝÅCpLtÓ¶„tƒÖÖV¶mÙÆÕ«W‡Râvð¾LjÑö2rËX¢Ñ(G¥££¼ü|rrr­Ì©.•@l` "ur U28ð;÷{Ï|„þðG9z”ŠÊJjêjñù|„ƒaêjëhhh ¸¨ALßõLǬSUŸÏÆÔŠ’ HQU»¦â’úa§:~ŸMX ëi¥œ¢h¸™ÖHåmé2ÐÒq-ƒÔχR~÷xI’)..¢ºº’ìÜŽ=Æ›oîEl"ûLfõ¦M›9vü )*,¤®®Þ À¹×rI·ø@u”LUìÐ]Ü3QÄZN$9²Ý•HÔvÃìMÂJƒ`À[Ë‚¤®y‚Ôyhwýèììdݺõ¼üÒÏ8{ölÆqr,¤Žx<ùíd2=~üð¸èÜ-ÝA@×uΟ?ϱ£G‰Åâz+s¦ $8Á­L ‚(ö“–C¬¶îîàSO1ûÓ-)ᤧ„´Ž«à², È/,`çŽ]ƒA*++¼ßk=ÇO_ú7n&+'›Æ g…QU•ŠŠ &MšDyY)¢$¡ý gód÷Ãëܶ—IM·}8Ó´Ÿ¼®Œ.ØÞ4L‡YÑ&1pÇ,àW½b¨€Š;†?Sd»Ó£Wá(ŒÏ)Ÿð©v.]IáñNØ>Ÿ‚$ÉädçRTTD^^ñDœÝ»÷püø ‡+,ß[¼/^¼ÄOú3ªª«ÈËËcBãÂápÊ=I~o§õzA‹¦e¢k6ú̽÷Þ3ÍŸOEUewÍ糡¤I­h?ƒê¥4“I=­c¡‹ŽD¢ìݳ‡Ÿýìg¼¹{7±XlP}úé°,¾ Ü© <]ç)`öPá~‹Å8sú4§NB’eŠŠŠ<ž¦æšä˜±MÍÉïý›Œ¯Þ)Ш«­µ­ ³tl‹DKié‰í»¦æ¼‡œ©sÔQLÛm‘WÅ2íEÑ=‡áDøeIâÿoïKƒ«:Ï4Ÿï;ë]$Œ›Ù1»cDÛØl¤à8Æà´'•Ô$²33ÎL&ét“J95Jª«¦«&?ºìÄ“tÏô¤ÓÝY\2bv HƒYŒÁ6±ƒ1˜U ¤»{Îù¾ùñ-÷Ü«+éÊ Â÷ýƒîrî¹ç=ïö<ÏkD„.œ?·víÂolEggg‘¨`9‹§Ô8’H$=ί¨Ý5ÀÓ§7À÷ÉnBÐñn%„Óþ™1†óçΡ­­ W®\Áˆº:ÔÔÔôhD•{nßw[h¼°jRˆ¯\×w]@.'=ê¦(ðƒÝÃ9ÇØ1cO$‘¨IbÔèQp‰x3gÌÀÜ;>…úú¥˜õ 0„ ©cD]—ˆ¹°Q犦‰‡|>ˆ0jDÓʱ,íœQ§œÕP3µ¢ç©ôœQIr/×ÝW‘€d‹²Q‘JDXÞkÙâaQJªÎ%!·Ür F…áuu¨V‹Q£Gá–áÃaš&¦L™‚[o Û4‹S5颙Vi/¤ô³öv½i½,ù;KÊ[¶¨wƒ’<¡"2wvvbËæ-Xµröî}ù|¾¿tY—o†a¾ü…!ýŸ¯¿¾éòSO}kÖ¬º&>wÍ)%‹=‰©StvÒQ–…¯‚o‚©•ôRÔ2räHÜ¿p!î½ï^ 6¬W'®äõþYG ëIÆÁ9Ä–ºˆCè£SgRÔíV¨%Ë2ÑՕ™3gÐêF"žÀ­·ŽEmm-l)°–Îdµ*b"î"dLSžY¡¹¤vB©ycÞJg‹R\Ó0P[›@.—G&[ÌÏ/fS•×õ5JŠþ½´)H©ÈX ?Ê+MÃKÁ4Ñ׋¾'c 8á!ø!è—¾¢.Û¶qû§nGcS¦JS¥PÈÂÅV›U£UªÇ©ÔÚ÷>V=Îõ‘-kG±ŸIbhƒ hŤc[:º®-Çv8õ^´ÓY¦  ¥ÒYÑÒi¬Hå(-4hq®ckåL6§ëÑxÌA SW¨I ¥ !óѸØÑ »…ôTéÕ>"Bj“qdržÖê‹€Qî¦\΢ÏSü]Æz¿Ñ”þ\úw%*¡ösÎ_Àö7·aûöºÎ­Ðq9çx‡1üÜ÷±Ú4yו+Z[û‘Î%vÝåÚ‡iÓæ2ËÂIßÇŸÁ“Œ!¤÷ˆºÛ…aˆ³gÏ¢m_º»»0¢¾¾gk[¦Tì9÷+¤Ÿ¦¤¢0ÅÊiE7¢ã+QÁøè¸G‘ ôX!²ŠCSɽ­NÙ€Ñ SDqרç0 2UÿÚ¶…0`ÈåóÚi ƒ"B¬¤¶3 *Ä{©Sû3 2êG£h¹ÞC)DQEdžB4á=Úᦑ)C¡n¤ºy© ò;SÄ µ#Z­¬-z ySU“ŠÒk€Vµ„T×H¥RxsÛ6¬\¹ï¼ónEu®ø,€ÓŒá¹ À3wÞÉß8y’xk×¾€“'¯M·¹W?¹®¯^b?üFŽdH¥È­¦‰¯SŠÿ `â@êã1cÆ`Ñ‹p÷=÷HbaÙT_i´ê:FTêᔈšØ”óÀ”ä›j””a,¬¼-Sà˜ÅE(y§L*;Dv«åZ–e"›õ0Ã59!šfÅd ÄNdÉd yÉ÷UN¢ðÜ–Ô/X]¢¡ Û¬¿ìþ.Dyb¢uw<æ ëå{P7ûJK•>™P)ݯ©q±²h¹]Q•kz|®,¯Têc(‰á¨•Öìù|í ¥¥ÇŽÕåS…ŽÛÅV…!žO§ñžmƒýéO¿¿FÓ¿ Šnè£>ßM$ø†ïPŠ/¨­´>6 So›Š‡zóæ5€R£WE|õ< ï:Yɧ”C•Ké « ]Z ('´,qׇˆÊ‰¸ Î8ºR™HŠL`¦Œ”кÖJGÕ°JêÔ4 ì£xÌ•À< Ó‹Ü(E&çõ™æ–=·‘‹¡´1Uîöu®c®ƒ˜ë Éêl¡ô<ª¨Ê8Ó(§ÒïK=®7&–™JŠÊ#õ¦aè}H´†´’vbŒáÔ©Sx½µï¾ó.r¹Ü@ê\Ÿsl C<ëûØdðÖ¬ùøWŸ‡ýµ}?Þß'¶m£IÖÇÂíþK9²ëº˜Û0˜8i’' ´KÙ×…ÚÛ㕬Mo Í‹îòάT2YO³®b® ǶÑ΀sGâŸ3YO E0Ƚ=¦ÚdB7¼Túš÷ý"@ç<²Æ†õ9ÕHÊB}ƒQxpµõÀ¶-!œ×˾)õ~‚/ËÊ:¾2!Kµhxïõp_óèËÒÏ£Î! Ä Åÿ;.u`Û¶­ØþævtvvV踜Î90†_þ`ÛüÊÞ½q=ú«Š¯·kiƒ¸ùy7܇)SÂXŒÍçÉZBp SŒ¬¤>‚gNŸÁþ¶ýÈdÒ¨¯¯×;ŠêÄb %í5Í.g墜ÐD"%i#‘’¥†+ W MòšÒIÕœBAÑÑH(刀(Á?ó¬§çÅ¥pTÆ+O£MÓгfË2‘LÄ$ •éC4-.}M"‰sË4ä\»Ôá8Ph †¡Pþ(Y…S¸Q–g¯õ‡P€Â1 <þÎ;±êŕػg/r¹Üê\rŽ1ü2 ñƒ—^r7Mžf_~ù÷¸|yOÅ×Ùµ¶A_Ý~ìØ{8p`ÆŽmÈ57{o·µ™ë A–LPÓ×yU_b6›Å±cÇpèà!BQ?²Ž+ÿ}¦Q †d™¨Á¾Þ)?7-­£“(ýMý]5™¸dP…Œéù°-m©ý´! µ£^«©ÑCÑn«¦·q)íRÒ™W` •V÷×ÌŠÎgUDwdïåý¢ˆª;¸‘†Ték+­mË0õœ‚d"¦ËœÐyÚ3=§Ãrǜ墵š8„aˆööv¬^õ6¿¾YGÝÊPT$Í^ C|/•"¿§—úW;v}T•Ø ¦ÐåíÑG›0 ÜI)ž¦_xè?­Ãs3fÌ@ãg›0kæ,˜e÷ÑçØr—¬ŠK&ã „ +•Ñ)§%±½=‘Z\ÏiUÝÊ8/›V—«å”(‡)=¾DÀ_n,íÆzù@Bò~ Ç]¡®ïKë̾Îcé¹.;«5„ž¶/ËÍçKÿ/¶Ü»b¿PØÛ×ܹÜk–wÑë“êÌ™3ØÜú:öìÙƒL&S1Ã0 FÝ‘ËùçûäUÓDvõê¿ÎíË=—Ú‘#ûpêÔ|ölöa.‡WáïQJÇ‚ñœsÚ+l2‚ºxñ"ö·µ¡ãÒ%Ù«­-Üiå—«.Ó04XPã‚Ò£¨5ãºTïycÍUé«ú×¶,Ñ`aåɶeêí /­œRw_e Ê"QIg"÷ÐMÛXê(cGÕÆ•–å"Zô3EÔËÓí—Mq{6ŸˆÀG>_oiqÔ,IÛë«q¦YT CM:¯\Áë­­X½ê%:tH—}Ÿ Î 8Ç‘X,ñÓ‰'ÿèî»§ì^¹ò|°cÇï®Ý…~솋ÀQ›7¯<2çÎuÕg2©fÆ‚¿$„Ì ¤¼^VÔÔERWW‡ûÞû,ÀðáÃ{\<¥°¿¨ç\/†V   |'6ÊòçzA´ÂO—‹*ÑÍÑ©g¤rN­æ”ŠÜ¡fË¢nؼÔoR‚lZ”œñ¢ô:zü½·èã¢M õwJ )*§ºº½Á4‹•sÄb®·ô7ˆBXKÏwéïÕºUR½ûλhmmŧN þè` ¿ Cüýž=ôÈŒŒoØpcEÝ¢ó<ØP‰=ôÐعÓ$Ÿý¬?Í0ð-Jñ$ÀëÅ÷Ñ÷GP_Þĉ±¸q1æÍC,&ˆ†AËÊêè ¥p]žç÷¹÷†ã ¥Ý H·J™Bb•≣ïo™¢‰¤íÕøCÉÁ «I€*‚À{ß4 ÉqÝ—ÑGí•R_ôšær¦,:µ\÷8¸X”.SgÓ04ZMJ„.•<þ¼ïÕì®cë-A/PuƒŠÖÞ•Ül¢ ŸcG¢¥¥íhX…Ýåçx5 ñl:펃àå—o\ÇUvÃ¥Ðåìøñ÷àyï`úô¹—s9l2 l3 c8ç˜L·úrbõåuvvâÀþ8sú4jjkôö?Kn3€ºÈÎ%‘Q†K””ú]ô¢1µtHµcræëG€Ž\"¦;ª€~-‰2Ñ»dàûÈ{~¡œIÔ—e‰(èyy¹Ï6³UÑà ÂX>¢‡:"Ad´Yô-ò®ŒR!½ª¨—†Ì8LÓ„c‰~BéX+SÛ®9Ú.ž9­]ýþÊ͆uçϞūë_ÁÚµkñÁ©ô9ª ]fœ“ÝŒáx~jY8zþçø¿A€5ŠÝ³ÇÄîÝ×·|=lÈ9°²¦¦fLÊqécšø!ø&!˜2úx̘ÑXºô,Xp/lÇI„ÀumM|Ïû>ºSÙ¢‹S5½zÔ‹‘š:­!€®I£sNEiva\U ;TÇÞ[G[³çåA(‘‹Î¡ JÌ-JŒWûlïs„A?ù| UK?Wo()×±‹9BÛZnËPÙIÎËÃ4¨ÞY:ó».gz#EôóÅ\GÔ‚ÀǾ÷ö¡eS Ž?>Ð:·“1ü! ñ‹Žr çìÕW‡FÄ-µ!ëÀÊy¤W®€Œ‹Ùɤó½|>ÿeÎÙ-•Œ ,sÖ¬™hljÄ´é3ÇQ›µcȘ†>êt1"ݧs*•^à¦lø”v±õÅ‹‚ø€Òï*zQP‰:–¨0žú,J‚GÈx$….׸SbéQ©!…-Z妢¡—÷¥MaL¥¢r,æHm/_ÖÀB4A¥×B¥˜Ô`Ib %Ýélh¬à'NœÀ¶7ÞÀÞ½{‘Íþ˜ç›ÂÏy6òC¡Î툼+ûò—ÿ &L˜hŸÛ„3¦ ¤l¾d¥äMìu\% T‚X­«â´°8}.íÀö6ûC7°”Ä\„ÐsYBУ£ @wn‹™A¤¼Ž 8r7‘êv”¢+•Ñ+[JÓa[ÖÑÑßÞW"Ö¢A¨›n¹¼@¤A¨?+ n4—.^BKK+víÜÎΫ¥ù½Çž÷}¬ŠÅøÕ (Z[o¼±Ð@í¦q`¸ûî'1aC Ö²ð(Å÷AC_°LeÊ‘kkkqÏü{°pÑ"Œw+b1ÙœWDŽ/JýäŒYa”“ñXW7úøèû©º3{Ž€Þ Ê I³…¢X ˆPŽèZ]¼gÜua˜T‹¤T4íÙ‚Hä”’ìÉû><ÏGÌuÐÎè¨kHé±—f#ê†ç:6lËD*“E.——)²èø—Jç¤R)ìyûmlÙ¼~øasÓûw 8Ãþ)ð«Q£ø'O¼öÚÐŽºQ»©XÙ’%Oà¯ÿ:ƒçŸÐÇÅv9ã²»1fìX<ðàƒ˜?_ÐU5æÚ0¨L.×£n¹¶¬çb¯Š,J~&úÞE8ëþËv=VráL¹\^ð]MÝ©LeN½‡m –“mYpéLŽmÁql©æ!¶Î3Æáº6LÃ@&›C.')‹D*?ÊÑQ†¿Êd{”*=/­“õy…b!Z˜A‹Ìé4¸p2|ßG{{;Z7µàÈ‘#Óüdw¹›1¬f ?O¥È»¶ÍÓæ÷qÙMéÀÊ}´¾Oh"Áç¾g䋯éè­o›6 MMM˜=g¶–½UÈ©R­`ÜPÏ0„ôÊZ*¶â¹lé1)~1çbSž™z½¥2ÝÌÊûrÄS`Õ$b€äPt§²ÂPêk+v/’ÛU³c•†'1ø~ 3E!td*DJ±ÉÕÈ=>uä÷]ÆqüÄ MóËf³qÜ€s¼ÁžÍç±RxüãÍç¸úÜ ö|öøãÍH§}gòäQwww?†þBB`)Èco­æ5 ±±&N,RPë+eTtBÆŠwÓàx:µ4…Vâ¾¥ðˆBe¨„(RžTk@â1Q¿f=OÖßLJ¿ eLH˺”‚a5 -õÓÊj“ ä}_në& Œ¦ÞîWÚQï {_¾|on݆7ß|W®\èX¨]Òüþ­¶–_>uŠbóæ¡_çöeCÈñ﵃÷¡¡áÎ0“Éò}þ2@>ÈTJI=çœô‡¯‚§OŸFÛþýÈf²¨YL[ D£ ä{ ÐBí¦in°„hª‹¢ì)… õÚÑcc¼ `9E©9 ¢}<æ6<ÊãŠ9bRäNE[EgŒvÊã1Gl±—³pJĆ…÷ý@ÿ‚¬Œú¥7±¨è\i*…TFi~‚™Å[»vaå‹+ñöÛoWu#l¡ „ÐC|ÕªW7LŸ>-»rå xÿýÁg ]oûD80´·¿‡öö}?¾!·nÝŽ·çÌ™´¾¦&†a81–P닲–ÍfqìèQ>t†AQ?r$G4ºy©¸šln™ÒYƒ cA6PNCæU÷7:ŠOwHõbÄSd½„ˆš†Ø&¡jNÓ0àyù`BŠÉ+€…Z—¢‘P²C.GbmiŠú> ÅßIä•R£çN+dŠŒQèÀ:xPÓüTÔ­DsÙ0Œ¥æš|>ün*…ßè8|x'¾6kK†‚}"Rèrö“Ÿüõõ#Ì­[·~W˜&}, ÃX¥(mqÖ¬YxøócÊ”)0ÌbÚ¢™N©SYB„r%õ^<æèÇûA€îT¶ ¢ÞSý¿7 ¶b[QJ"µ,tú¬ÄÛò2ŠÚ–"Û3tu¥åž\S9ä(G™F_ɨ®èz¤ä¼D­\š¬êa@€=Žuîž·÷ JT4âàœ„œóŽûÙ´iÓ×IÿøÇ?ìKjPìëÀÊž~úd³Aܲø²K—.}—1v/!0*uäd2‰yŸž‡/Ƹqãz ±4%P Îq °Ú”¸2}†ü½”£æõQ ³¨” €BŠ (]l…‡îNe`™"-ç\ü?”Ûÿ% YÑ̹7Vê.÷ÆÀ"„ ëêUìܱ[¶¼K—. ´Î=Æþ!ðÛš~áÃ)ZZnî:·/ûĤнَÛ0vìTß÷Óû³Y¶6w/2ƦrÎëúb;i²A>SïŸÂýû‘Ïç1räHÄbÉeb¯êX+2 õ“5I5vQ€ Ó4ˆ»èPÐȶLS+kú‘Åd”RÔ&ãÚa}©ü¡ˆ ¦L·•Fu„ð$ÔÒP3ã€ÁDíW”s:%[JRO{÷ìÁÊWbçÎH§Ó?^f ¿ C¬èèÀŸ, é•+_À‰7Û—}â#pÔ}ôk¸z5IF޼:Ý0ð—”â #ú ˆ!´Å¦F444 #æŠÑS*Õ£hzk†³”ÊÀa™(\h©q•A M#¡—lè®rÔc®X šóòÈæ<ÝqÎûÇB6ëP×¶õH6 S¦LAcS#æ6ÌÅÈËֈÐikÔAÔkÂQÕÒ2ÏóaZ& ŒÔ¬T ¿[– ×¶ÄZ—œõU«ZZIÞ"{[¦ˆÔœñ¨GjR«ÏÐÎê¥ÞÊ ƒ"saš&NŸþZ÷ vîØ5€-œ“<çx]Ö¹­®Ëó»vYøàƒì¯ý†·ªÐ{¬ŒÁ¶m<(·I4»¿ç)'pw̽KZ‚É“&±‡ú’PU› ÃÐaâ,Z´÷Þ;Éd™^G4è0 µü­ª{s2Mæœ#d!,Ët¤T»”cHe²z”e “‚3D€I†:ªï½T qäðalÚ¸ ííÈͦË)ư†1ü<“!{Móæ¤ù}\Vuàk`Ë–5#›%´¶–Íss…aǃ HTJ[4MsçÞE<€Û¦Mƒ%)uÅ)5¨¥Ö…¹³idgl© ™ó|!ã P"ÎU|¤„ ‘ˆi5Å^R]åDBLÎR)ÙÄ¢Οdž °û­ÝÈd2QÅ8Ç6Æð¬çá5ÇAîÀŠöö¡%"w£YÕ¯¡ýð‡?¥vÌóRŸ¿|ùòŠL&s!ܬ$­fŒ!cÞ¼yXܸ&N,‹}î ­,Úî C]Ìa¦šû[,/+$nZ^çÏ_ÄöíÛ±cûvœ={®ÂTYÕöäcøeà…xGŽ»wW£îµ°ª_cÛ¸q7–,¹ O=õW#®^½ò)Å_‚Y; ¯Ž `Áý÷£®®®G4îí¹¦ih ¯ÞàŽEh)ýSô –™+Œ¶çyØ»÷¬]»G+Â4÷÷YLÓê0 ó·ÝÝÙ_nßnkh`üf’³¹¬êÀ×É~¸»wòÀ|Šaà›”â?ÕŸ¬OÔYÇÅ‹ñé;ïD,ëÁvR¯£~v‰¸‹®î ü XKº¡¾T Hm«„pß±cDZ~ý«Ø³gr9o Ýå,c|ãÄ~ö¹Ï=¼ëüùsþ3Ï|w°¿’›Òª|mùòfø>ÌxwSЧ ƒ,x¼Òúز,Ìœ5MMM˜>cLI[Tì"qd[ ô¶®E‰Þ9Ž¥·=†a5 í¸œs\¸p6l–-[qåʕԹŒsìb ÏåóXgY<}℉½{3Ø_ÃMkUþ졇šQS¤Ó~|âÄ‘Ës¹ì ÏËÝ%h‹•‰îüÌgðàâ1nÜ8š*UÅPVŠâr ®Ü U~Œ¹ŽFmuw§ðæ›ÛñÚkpúôÝ(ëëØ ?“ãœãÿø>~SWÇÏðÁÆÕtùz[Õ?F{ñÅøÒ—–à‰'¾1:—K?A¾EnH}\__…‹â¾ûîCí°aEz¥FˆXÏ¢4¦…2e®°+‰¸ŽJ€û`ý+¯ ½ýP…c!1Z²,û*!ôߺ»³?¿p¼åðõ뫎ûqYÕÁ–.mF*2bf¾M)¾ ð: 2‘=J)&Mš„Æ¦&Ì{וÑVÂÉV“G*…iZ‘C‘ÚÛaÓÆhkÛ_ÑXH½çð¡ÇŒóüìÙŸÚÜÑqÉûÑ~0اögUD{ì±f„!,Çá÷Û¶ñ}BÈÃŒ…v¥j ¶mãöÛoGcSfÏž CB=ÏkO(‘ #®WµØ–DZpµ³­­¯cÓ¦VtvvVä¸@)åŒñwÂ?ó}¬6MtwulÜXEQ †UxmÙ²§0þ4\½š­íììx¼«ëêwþi@l[¬$"×ÔÖ`áÂ…X°`¦N„ ‘ÏH$\„aˆT:§#www7v¿õ¶nÝŠ³~ˆJ¤u ÇAN»nì×aˆÿ÷7óàéo~óÕªã²Uø±åË›‘HpäräVÓÄS¦I¿ð ¥ÚR嬰mq –-[Šùóïi á:ÏóÁ˜H©>ŒuëÖãÈ‘£Ñü «P¬T<žX“χÏîØqðÝéÓDZµk«uî`U¾Álùò'qòäºhÑœ¹W¯^ùŽïç¿`PY4¶, sæÌÆÂ… 1{Θ–‰Ë—.býúW±wï;С⠔Ý<|øðŸ54ÌÛÔÑq1û£=3ا¨j«:ð j‚¶Èm×¥‰„ûŒïçÃ@ zû©cp]s0lX-öîÙ‹ŽŽŽ8çü€ã¸¿H&‡ý!³¯œ8qkÖT£îfU¾í7¿Y…]»¶`üøIugÏ~ø•K—.}Ë÷ósH¨ŠÒñÒh~çÃ?‡!þqõê[ß_²ä,¯Ö¹7®UxXKËëhl||å+_Ÿž¤-bl%°Ì¾þ^üX¤ÃËŒá¹l{ Ušß°ª![¶¬¾#‘À§)ÅÓ¦Iþ‚sÞ/m±wÓÛü¶Ëm~6 d«©òбªAûšáû¡;yò˜GS©î¹\v>!è—¶5œ0†_ú>~oÛ¸”ËÕîòвªQÛ·ï æÎ½ _ýêWës¹ôW(Å· ÁÌþEö—Ãï#ÿî»uG§L¹Â7n¬뇢UxˆÛòåÍ8q‚“éÓÉm†oQŠ'>(ËÎqŽWÂÏy¶SŠ q‡¶Uø&±Çk†çÁL$0ß4É J±”1¬$0α[ÒüÖº.ÒûöUw¨[Õo2ûÆ7¾‹0d‰l6½Ì÷½„zÆð« À¿Äb8×ÕTÅÒo«:ðMh‹=‰»îòqü¸1š$‹¤”±5k~=؇VµªU­jU«ZÕªVµªU­jU«ZÕªö‘ìÿÃuµƒŽ0lIEND®B`‚cards/man/figures/lifecycle-archived.svg0000644000176200001440000000243014567176413020045 0ustar liggesusers lifecycle: archived lifecycle archived cards/man/figures/lifecycle-defunct.svg0000644000176200001440000000242414567176413017713 0ustar liggesusers lifecycle: defunct lifecycle defunct cards/man/figures/lifecycle-soft-deprecated.svg0000644000176200001440000000246614567176413021342 0ustar liggesusers lifecycle: soft-deprecated lifecycle soft-deprecated cards/man/figures/lifecycle-maturing.svg0000644000176200001440000000243014567176413020106 0ustar liggesusers lifecycle: maturing lifecycle maturing cards/man/check_ard_structure.Rd0000644000176200001440000000156014620761756016453 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/check_ard_structure.R \name{check_ard_structure} \alias{check_ard_structure} \title{Check ARD Structure} \usage{ check_ard_structure(x, column_order = TRUE, method = TRUE) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} \item{column_order}{(scalar \code{logical})\cr check whether ordering of columns adheres to to \code{cards::tidy_ard_column_order()}.} \item{method}{(scalar \code{logical})\cr check whether a \code{"stat_name"} equal to \code{"method"} appears in results.} } \value{ an ARD data frame of class 'card' (invisible) } \description{ Function tests the structure and returns notes when object does not conform to expected structure. } \examples{ ard_continuous(ADSL, variables = "AGE") |> dplyr::select(-warning, -error) |> check_ard_structure() } cards/man/ard_formals.Rd0000644000176200001440000000237014761136755014722 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_formals.R \name{ard_formals} \alias{ard_formals} \title{Argument Values ARD} \usage{ ard_formals(fun, arg_names, passed_args = list(), envir = parent.frame()) } \arguments{ \item{fun}{(\code{function})\cr a \link{function} passed to \code{formals(fun)}} \item{arg_names}{(\code{character})\cr character vector of argument names to return} \item{passed_args}{(named \code{list})\cr a named list of user-passed arguments. Default is \code{list()}, which returns all default values from a function} \item{envir}{(\code{environment})\cr an environment passed to \code{formals(envir)}} } \value{ an partial ARD data frame of class 'card' } \description{ Place default and passed argument values to a function into an ARD structure. } \examples{ # Example 1 ---------------------------------- # add the `mcnemar.test(correct)` argument to an ARD structure ard_formals(fun = mcnemar.test, arg_names = "correct") # Example 2 ---------------------------------- # S3 Methods need special handling to access the underlying method ard_formals( fun = asNamespace("stats")[["t.test.default"]], arg_names = c("mu", "paired", "var.equal", "conf.level"), passed_args = list(conf.level = 0.90) ) } cards/man/dot-process_nested_list_as_df.Rd0000644000176200001440000000153714574702654020427 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_continuous.R \name{.process_nested_list_as_df} \alias{.process_nested_list_as_df} \title{Convert Nested Lists to Column} \usage{ .process_nested_list_as_df(x, arg, new_column, unlist = FALSE) } \arguments{ \item{x}{(\code{data.frame})\cr result data frame} \item{arg}{(\code{list})\cr the nested list} \item{new_column}{(\code{string})\cr new column name} \item{unlist}{(\code{logical})\cr whether to fully unlist final results} } \value{ a data frame } \description{ Some arguments, such as \code{stat_label}, are passed as nested lists. This function properly unnests these lists and adds them to the results data frame. } \examples{ ard <- ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") cards:::.process_nested_list_as_df(ard, NULL, "new_col") } \keyword{internal} cards/man/bind_ard.Rd0000644000176200001440000000365114664374337014200 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bind_ard.R \name{bind_ard} \alias{bind_ard} \title{Bind ARDs} \usage{ bind_ard( ..., .distinct = TRUE, .update = FALSE, .order = FALSE, .quiet = FALSE ) } \arguments{ \item{...}{(\code{\link[rlang:dyn-dots]{dynamic-dots}})\cr ARDs to combine. Each argument can either be an ARD, or a list of ARDs. Columns are matched by name, and any missing columns will be filled with \code{NA}.} \item{.distinct}{(\code{logical})\cr logical indicating whether to remove non-distinct values from the ARD. Duplicates are checked across grouping variables, primary variables, context (if present), the \strong{statistic name and the statistic value}. Default is \code{FALSE}. If a statistic name and value is repeated and \code{.distinct=TRUE}, the more recently added statistics will be retained, and the other(s) omitted.} \item{.update}{(\code{logical})\cr logical indicating whether to update ARD and remove duplicated named statistics. Duplicates are checked across grouping variables, primary variables, and the \strong{statistic name}. Default is \code{FALSE}. If a statistic name is repeated and \code{.update=TRUE}, the more recently added statistics will be retained, and the other(s) omitted.} \item{.order}{(\code{logical})\cr logical indicating whether to order the rows of the stacked ARDs, allowing statistics that share common group and variable values to appear in consecutive rows. Default is \code{FALSE}. Ordering will be based on the order of the group/variable values prior to stacking.} \item{.quiet}{(\code{logical})\cr logical indicating whether to suppress any messaging. Default is \code{FALSE}} } \value{ an ARD data frame of class 'card' } \description{ Wrapper for \code{dplyr::bind_rows()} with additional checks for duplicated statistics. } \examples{ ard <- ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") bind_ard(ard, ard, .update = TRUE) } cards/man/dot-one_row_ard_to_nested_list.Rd0000644000176200001440000000120014574702654020600 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/as_nested_list.R \name{.one_row_ard_to_nested_list} \alias{.one_row_ard_to_nested_list} \title{Convert One Row to Nested List} \usage{ .one_row_ard_to_nested_list(x) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card' with one row} } \value{ an expression that represents an element of a nested list } \description{ Convert One Row to Nested List } \examples{ ard_continuous(mtcars, variables = mpg) |> dplyr::filter(dplyr::row_number() \%in\% 1L) |> apply_fmt_fn() |> cards:::.one_row_ard_to_nested_list() } \keyword{internal} cards/man/as_cards_fn.Rd0000644000176200001440000000322414721252100014645 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/as_card_fn.R \name{as_cards_fn} \alias{as_cards_fn} \alias{is_cards_fn} \alias{get_cards_fn_stat_names} \title{As card function} \usage{ as_cards_fn(f, stat_names) is_cards_fn(f) get_cards_fn_stat_names(f) } \arguments{ \item{f}{(\code{function})\cr a function} \item{stat_names}{(\code{character})\cr a character vector of the expected statistic names returned by function \code{f}} } \value{ an ARD data frame of class 'card' } \description{ Add attributes to a function that specify the expected results. It is used when \code{ard_continuous()} or \code{ard_complex()} errors and constructs an ARD with the correct structure when the results cannot be calculated. } \examples{ # When there is no error, everything works as if we hadn't used `as_card_fn()` ttest_works <- as_cards_fn( \(x) t.test(x)[c("statistic", "p.value")], stat_names = c("statistic", "p.value") ) ard_continuous( mtcars, variables = mpg, statistic = ~ list(ttest = ttest_works) ) # When there is an error and we use `as_card_fn()`, # we will see the same structure as when there is no error ttest_error <- as_cards_fn( \(x) { t.test(x)[c("statistic", "p.value")] stop("Intentional Error") }, stat_names = c("statistic", "p.value") ) ard_continuous( mtcars, variables = mpg, statistic = ~ list(ttest = ttest_error) ) # if we don't use `as_card_fn()` and there is an error, # the returned result is only one row ard_continuous( mtcars, variables = mpg, statistic = ~ list(ttest = \(x) { t.test(x)[c("statistic", "p.value")] stop("Intentional Error") }) ) } cards/man/adam.Rd0000644000176200001440000000131314567176413013326 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data.R \docType{data} \name{adam} \alias{adam} \alias{ADSL} \alias{ADAE} \alias{ADTTE} \title{Example ADaM Data} \format{ An object of class \code{tbl_df} (inherits from \code{tbl}, \code{data.frame}) with 254 rows and 48 columns. An object of class \code{tbl_df} (inherits from \code{tbl}, \code{data.frame}) with 1191 rows and 55 columns. An object of class \code{tbl_df} (inherits from \code{tbl}, \code{data.frame}) with 254 rows and 26 columns. } \usage{ ADSL ADAE ADTTE } \description{ Data frame imported from the \href{https://github.com/cdisc-org/sdtm-adam-pilot-project}{CDISC SDTM/ADaM Pilot Project} } \keyword{datasets} cards/man/dot-cli_condition_messaging.Rd0000644000176200001440000000137114752441547020065 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/print_ard_conditions.R \name{.cli_condition_messaging} \alias{.cli_condition_messaging} \title{Print Condition Messages Saved in an ARD} \usage{ .cli_condition_messaging(x, msg_type, condition_type) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} \item{msg_type}{(\code{string})\cr message type. Options are \code{"warning"} and \code{"error"}.} } \value{ returns invisible if check is successful, throws warning/error messages if not. } \description{ Print Condition Messages Saved in an ARD } \examples{ ard <- ard_continuous( ADSL, by = ARM, variables = AGE ) cards:::.cli_condition_messaging(ard, msg_type = "error") } \keyword{internal} cards/man/ard_hierarchical.Rd0000644000176200001440000001011614753751432015666 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_hierarchical.R \name{ard_hierarchical} \alias{ard_hierarchical} \alias{ard_hierarchical_count} \alias{ard_hierarchical.data.frame} \alias{ard_hierarchical_count.data.frame} \title{Hierarchical ARD Statistics} \usage{ ard_hierarchical(data, ...) ard_hierarchical_count(data, ...) \method{ard_hierarchical}{data.frame}( data, variables, by = dplyr::group_vars(data), statistic = everything() ~ c("n", "N", "p"), denominator = NULL, fmt_fn = NULL, stat_label = everything() ~ default_stat_labels(), id = NULL, ... ) \method{ard_hierarchical_count}{data.frame}( data, variables, by = dplyr::group_vars(data), fmt_fn = NULL, stat_label = everything() ~ default_stat_labels(), ... ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{...}{Arguments passed to methods.} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr variables to perform the nested/hierarchical tabulations within.} \item{by}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr variables to perform tabulations by. All combinations of the variables specified here appear in results. Default is \code{dplyr::group_vars(data)}.} \item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element one or more of \code{c("n", "N", "p", "n_cum", "p_cum")} (on the RHS of a formula).} \item{denominator}{(\code{data.frame}, \code{integer})\cr used to define the denominator and enhance the output. The argument is required for \code{ard_hierarchical()} and optional for \code{ard_hierarchical_count()}. \itemize{ \item the univariate tabulations of the \code{by} variables are calculated with \code{denominator}, when a data frame is passed, e.g. tabulation of the treatment assignment counts that may appear in the header of a table. \item the \code{denominator} argument must be specified when \code{id} is used to calculate the event rates. }} \item{fmt_fn}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element is a named list of functions (or the RHS of a formula), e.g. \verb{list(mpg = list(mean = \\(x) round(x, digits = 2) |> as.character()))}.} \item{stat_label}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element is either a named list or a list of formulas defining the statistic labels, e.g. \code{everything() ~ list(n = "n", p = "pct")} or \code{everything() ~ list(n ~ "n", p ~ "pct")}.} \item{id}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr an optional argument used to assert there are no duplicates within the \code{c(id, variables)} columns.} } \value{ an ARD data frame of class 'card' } \description{ \emph{Functions \code{ard_hierarchical()} and \code{ard_hierarchical_count()} are primarily helper functions for \code{\link[=ard_stack_hierarchical]{ard_stack_hierarchical()}} and \code{\link[=ard_stack_hierarchical_count]{ard_stack_hierarchical_count()}}, meaning that it will be rare a user needs to call \code{ard_hierarchical()}/\code{ard_hierarchical_count()} directly.} Performs hierarchical or nested tabulations, e.g. tabulates AE terms nested within AE system organ class. \itemize{ \item \code{ard_hierarchical()} includes summaries for the last variable listed in the \code{variables} argument, nested within the other variables included. \item \code{ard_hierarchical_count()} includes summaries for \emph{all} variables listed in the \code{variables} argument each summary nested within the preceding variables, e.g. \code{variables=c(AESOC, AEDECOD)} summarizes \code{AEDECOD} nested in \code{AESOC}, and also summarizes the counts of \code{AESOC}. } } \examples{ ard_hierarchical( data = ADAE |> dplyr::slice_tail(n = 1L, by = c(USUBJID, TRTA, AESOC, AEDECOD)), variables = c(AESOC, AEDECOD), by = TRTA, id = USUBJID, denominator = ADSL |> dplyr::rename(TRTA = ARM) ) ard_hierarchical_count( data = ADAE, variables = c(AESOC, AEDECOD), by = TRTA ) } cards/man/dot-fill_grps_from_variables.Rd0000644000176200001440000000140414574702654020245 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/shuffle_ard.R \name{.fill_grps_from_variables} \alias{.fill_grps_from_variables} \title{Back Fill Group Variables} \usage{ .fill_grps_from_variables(x) } \arguments{ \item{x}{(\code{data.frame})\cr a data frame} } \value{ data frame } \description{ This function back fills the values of group variables using variable/variable_levels. The back filling will occur if the value of the \code{variable} column matches the name of a grouping variable, and the grouping variable's value is \code{NA}. } \examples{ data <- data.frame( variable = c(rep("A", 3), rep("B", 2)), variable_level = 1:5, A = rep(NA, 5), B = rep(NA, 5) ) cards:::.fill_grps_from_variables(data) } \keyword{internal} cards/man/dot-is_named_list.Rd0000644000176200001440000000071114574702654016023 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{.is_named_list} \alias{.is_named_list} \title{Named List Predicate} \usage{ .is_named_list(x, allow_df = FALSE) } \arguments{ \item{x}{(\code{any})\cr object to check} } \value{ a logical } \description{ A predicate function to check whether input is a named list and \emph{not} a data frame. } \examples{ cards:::.is_named_list(list(a = 1:3)) } \keyword{internal} cards/man/nest_for_ard.Rd0000644000176200001440000000362014624213512015056 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nest_for_ard.R \name{nest_for_ard} \alias{nest_for_ard} \title{ARD Nesting} \usage{ nest_for_ard( data, by = NULL, strata = NULL, key = "data", rename_columns = TRUE, list_columns = TRUE, include_data = TRUE ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{by, strata}{(\code{character})\cr columns to nest by/stratify by. Arguments are similar, but with an important distinction: \code{by}: data frame is nested by \strong{all combinations} of the columns specified, including unobserved combinations and unobserved factor levels. \code{strata}: data frame is nested by \strong{all \emph{observed} combinations} of the columns specified. Arguments may be used in conjunction with one another.} \item{key}{(\code{string})\cr the name of the new column with the nested data frame. Default is \code{"data"}.} \item{rename_columns}{(\code{logical})\cr logical indicating whether to rename the \code{by} and \code{strata} variables. Default is \code{TRUE}.} \item{list_columns}{(\code{logical})\cr logical indicating whether to put levels of \code{by} and \code{strata} columns in a list. Default is \code{TRUE}.} \item{include_data}{(scalar \code{logical})\cr logical indicating whether to include the data subsets as a list-column. Default is \code{TRUE}.} } \value{ a nested tibble } \description{ This function is similar to \code{\link[tidyr:nest]{tidyr::nest()}}, except that it retains rows for unobserved combinations (and unobserved factor levels) of by variables, and unobserved combinations of stratifying variables. The levels are wrapped in lists so they can be stacked with other types of different classes. } \examples{ nest_for_ard( data = ADAE |> dplyr::left_join(ADSL[c("USUBJID", "ARM")], by = "USUBJID") |> dplyr::filter(AOCCSFL \%in\% "Y"), by = "ARM", strata = "AESOC" ) } cards/man/shuffle_ard.Rd0000644000176200001440000000162014567176413014707 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/shuffle_ard.R \name{shuffle_ard} \alias{shuffle_ard} \title{Shuffle ARD} \usage{ shuffle_ard(x, trim = TRUE) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} \item{trim}{(\code{logical})\cr logical representing whether or not to trim away statistic-level metadata and filter only on numeric statistic values.} } \value{ a tibble } \description{ This function ingests an ARD object and shuffles the information to prepare for analysis. Helpful for streamlining across multiple ARDs. Combines each group/group_level into 1 column, back fills missing grouping values from the variable levels where possible, and optionally trims statistics-level metadata. } \examples{ bind_ard( ard_categorical(ADSL, by = "ARM", variables = "AGEGR1"), ard_categorical(ADSL, variables = "ARM") ) |> shuffle_ard() } cards/man/dot-rename_last_group_as_variable.Rd0000644000176200001440000000135314754702430021242 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_hierarchical.R \name{.rename_last_group_as_variable} \alias{.rename_last_group_as_variable} \title{Rename Last Group to Variable} \usage{ .rename_last_group_as_variable(df_result, by, variables) } \arguments{ \item{df_result}{(\code{data.frame})\cr an ARD data frame of class 'card'} } \value{ an ARD data frame of class 'card' } \description{ In the \verb{ard_hierarchical*()} functions, the last grouping variable is renamed to \code{variable} and \code{variable_level} before being returned. } \examples{ data <- data.frame(x = 1, y = 2, group1 = 3, group2 = 4) cards:::.rename_last_group_as_variable(data, by = "ARM", variables = "AESOC") } \keyword{internal} cards/man/dot-nesting_rename_ard_columns.Rd0000644000176200001440000000253314632350734020572 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nest_for_ard.R \name{.nesting_rename_ard_columns} \alias{.nesting_rename_ard_columns} \title{Rename ARD Columns} \usage{ .nesting_rename_ard_columns(x, variable = NULL, by = NULL, strata = NULL) } \arguments{ \item{x}{(\code{data.frame})\cr a data frame} \item{variable}{(\code{character})\cr name of \code{variable} column in \code{x}. Default is \code{NULL}.} \item{by}{(\code{character})\cr character vector of names of \code{by} columns in \code{x}. Default is \code{NULL}.} \item{strata}{(\code{character})\cr character vector of names of \code{strata} columns in \code{x}. Default is \code{NULL}.} } \value{ a tibble } \description{ If \code{variable} is provided, adds the standard \code{variable} column to \code{x}. If \code{by}/\code{strata} are provided, adds the standard \code{group##} column(s) to \code{x} and renames the provided columns to \code{group##_level} in \code{x}, where \verb{##} is determined by the column's position in \code{c(by, strata)}. } \examples{ ard <- nest_for_ard( data = ADAE |> dplyr::left_join(ADSL[c("USUBJID", "ARM")], by = "USUBJID") |> dplyr::filter(AOCCSFL \%in\% "Y"), by = "ARM", strata = "AESOC", rename_columns = FALSE ) cards:::.nesting_rename_ard_columns(ard, by = "ARM", strata = "AESOC") } \keyword{internal} cards/man/dot-trim_ard.Rd0000644000176200001440000000127714574702654015022 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/shuffle_ard.R \name{.trim_ard} \alias{.trim_ard} \title{Trim ARD} \usage{ .trim_ard(x) } \arguments{ \item{x}{(\code{data.frame})\cr a data frame} } \value{ a tibble } \description{ This function ingests an ARD object and trims columns and rows for downstream use in displays. The resulting data frame contains only numeric results, no supplemental information about errors/warnings, and unnested list columns. } \examples{ ard <- bind_ard( ard_categorical(ADSL, by = "ARM", variables = "AGEGR1"), ard_categorical(ADSL, variables = "ARM") ) |> shuffle_ard(trim = FALSE) ard |> cards:::.trim_ard() } \keyword{internal} cards/man/dot-fill_overall_grp_values.Rd0000644000176200001440000000220514671705567020116 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/shuffle_ard.R \name{.fill_overall_grp_values} \alias{.fill_overall_grp_values} \title{Fill Overall Group Variables} \usage{ .fill_overall_grp_values(x, vars_protected) } \arguments{ \item{x}{(\code{data.frame})\cr a data frame} } \value{ data frame } \description{ This function fills the missing values of grouping variables with "Overall \verb{variable name}" where relevant. Specifically it will modify grouping values from rows with likely overall calculations present (e.g. non-missing variable/variable_level, 100 percent missing group variables, and evidence that the \code{variable} has been computed by group in other rows). "Overall" values will be populated only for grouping variables that have been used in other calculations of the same variable and statistics. } \examples{ data <- dplyr::tibble( grp = c("AA", "AA", NA, "BB", NA), variable = c("A", "B", "A", "C", "C"), variable_level = c(1, 2, 1, 3, 3), A = rep(NA, 5), B = rep(NA, 5), .cards_idx = c(1:5) ) cards:::.fill_overall_grp_values(data, vars_protected = ".cards_idx") } \keyword{internal} cards/man/syntax.Rd0000644000176200001440000000541714567176413013763 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/syntax.R \name{syntax} \alias{syntax} \title{Selecting Syntax} \description{ Selecting Syntax } \section{Selectors}{ The cards package also utilizes selectors: selectors from the tidyselect package and custom selectors. Review their help files for details. \itemize{ \item \strong{tidy selectors} \code{\link[=everything]{everything()}}, \code{\link[=all_of]{all_of()}}, \code{\link[=any_of]{any_of()}}, \code{\link[=starts_with]{starts_with()}}, \code{\link[=ends_with]{ends_with()}}, \code{\link[=contains]{contains()}}, \code{\link[=matches]{matches()}}, \code{\link[=num_range]{num_range()}}, \code{\link[=last_col]{last_col()}} \item \strong{cards selectors} \code{\link[=all_ard_groups]{all_ard_groups()}}, \code{\link[=all_ard_variables]{all_ard_variables()}} } } \section{Formula and List Selectors}{ Some arguments in the cards package accept list and formula notation, e.g. \code{ard_continuous(statistic=)}. Below enumerates a few tips and shortcuts for using the list and formulas. \enumerate{ \item \strong{List of Formulas} Typical usage includes a list of formulas, where the LHS is a variable name or a selector. \if{html}{\out{
}}\preformatted{ard_continuous(statistic = list(age ~ list(N = \\(x) length(x)), starts_with("a") ~ list(mean = mean))) }\if{html}{\out{
}} \item \strong{Named List} You may also pass a named list; however, the tidyselect selectors are not supported with this syntax. \if{html}{\out{
}}\preformatted{ard_continuous(statistic = list(age = list(N = \\(x) length(x)))) }\if{html}{\out{
}} \item \strong{Hybrid Named List/List of Formulas} You can pass a combination of formulas and named elements. \if{html}{\out{
}}\preformatted{ard_continuous(statistic = list(age = list(N = \\(x) length(x)), starts_with("a") ~ list(mean = mean))) }\if{html}{\out{
}} \item \strong{Shortcuts} You can pass a single formula, which is equivalent to passing the formula in a list. \if{html}{\out{
}}\preformatted{ard_continuous(statistic = starts_with("a") ~ list(mean = mean) }\if{html}{\out{
}} As a shortcut to select all variables, you can omit the LHS of the formula. The two calls below are equivalent. \if{html}{\out{
}}\preformatted{ard_continuous(statistic = ~list(N = \\(x) length(x))) ard_continuous(statistic = everything() ~ list(N = \\(x) length(x))) }\if{html}{\out{
}} \item \strong{Combination Selectors} Selectors can be combined using the \code{c()} function. \if{html}{\out{
}}\preformatted{ard_continuous(statistic = c(everything(), -age) ~ list(N = \\(x) length(x))) }\if{html}{\out{
}} } } \keyword{internal} cards/man/as_nested_list.Rd0000644000176200001440000000116014567176413015424 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/as_nested_list.R \name{as_nested_list} \alias{as_nested_list} \title{ARD as Nested List} \usage{ as_nested_list(x) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} } \value{ a nested list } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}\cr Convert ARDs to nested lists. } \examples{ ard_continuous(mtcars, by = "cyl", variables = c("mpg", "hp")) |> as_nested_list() } cards/man/tidy_as_ard.Rd0000644000176200001440000000561414761173352014711 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tidy_as_ard.R \name{tidy_as_ard} \alias{tidy_as_ard} \title{Build ARD from Tidier} \usage{ tidy_as_ard( lst_tidy, tidy_result_names, fun_args_to_record = character(0L), formals = list(), passed_args = list(), lst_ard_columns ) } \arguments{ \item{lst_tidy}{(named \code{list})\cr list of tidied results constructed with \code{\link[=eval_capture_conditions]{eval_capture_conditions()}}, e.g. \code{eval_capture_conditions(t.test(mtcars$mpg ~ mtcars$am) |> broom::tidy())}.} \item{tidy_result_names}{(\code{character})\cr character vector of column names expected by the tidier method. This is used to construct blank results in the event of an error.} \item{fun_args_to_record}{(\code{character})\cr character vector of function argument names that are added to the ARD.} \item{formals}{(\code{pairlist})\cr the results from \code{formals()}, e.g. \code{formals(fisher.test)}. This is used to get the default argument values from unspecified arguments.} \item{passed_args}{(named \code{list})\cr named list of additional arguments passed to the modeling function.} \item{lst_ard_columns}{(named \code{list})\cr named list of values that will be added to the ARD data frame.} } \value{ an ARD data frame of class 'card' } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#questioning}{\figure{lifecycle-questioning.svg}{options: alt='[Questioning]'}}}{\strong{[Questioning]}}\cr \emph{Function is questioning because we think a better solution may be \code{ard_continuous()} + \code{ard_formals()}.} Function converts a model's one-row tidy data frame into an ARD structure. The tidied data frame must have been constructed with \code{\link[=eval_capture_conditions]{eval_capture_conditions()}}. This function is primarily for developers and few consistency checks have been included. } \examples{ # example how one may create a fisher.test() ARD function my_ard_fishertest <- function(data, by, variable, ...) { # perform fisher test and format results ----------------------------------- lst_tidy_fisher <- eval_capture_conditions( # this manipulation is similar to `fisher.test(...) |> broom::tidy()` stats::fisher.test(x = data[[variable]], y = data[[by]], ...)[c("p.value", "method")] |> as.data.frame() ) # build ARD ------------------------------------------------------------------ tidy_as_ard( lst_tidy = lst_tidy_fisher, tidy_result_names = c("p.value", "method"), fun_args_to_record = c( "workspace", "hybrid", "hybridPars", "control", "or", "conf.int", "conf.level", "simulate.p.value", "B" ), formals = formals(stats::fisher.test), passed_args = dots_list(...), lst_ard_columns = list(group1 = by, variable = variable, context = "fishertest") ) } my_ard_fishertest(mtcars, by = "am", variable = "vs") } \keyword{internal} cards/man/dot-process_denominator.Rd0000644000176200001440000000300714746733642017271 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_categorical.R \name{.process_denominator} \alias{.process_denominator} \title{Process \code{denominator} Argument} \usage{ .process_denominator(data, variables, denominator, by, strata) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to include in summaries. Default is \code{everything()}.} \item{denominator}{(\code{string}, \code{data.frame}, \code{integer})\cr Specify this argument to change the denominator, e.g. the \code{"N"} statistic. Default is \code{'column'}. See below for details.} \item{by, strata}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to use for grouping or stratifying the table output. Arguments are similar, but with an important distinction: \code{by}: results are tabulated by \strong{all combinations} of the columns specified, including unobserved combinations and unobserved factor levels. \code{strata}: results are tabulated by \strong{all \emph{observed} combinations} of the columns specified. Arguments may be used in conjunction with one another.} } \value{ a data frame } \description{ Function takes the \code{ard_categorical(denominator)} argument and returns a structured data frame that is merged with the count data and used as the denominator in percentage calculations. } \examples{ cards:::.process_denominator(mtcars, denominator = 1000, variables = "cyl", by = "gear") } \keyword{internal} cards/man/dot-eval_ard_calls.Rd0000644000176200001440000000145014643265410016134 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_stack.R \name{.eval_ard_calls} \alias{.eval_ard_calls} \title{Evaluate the \verb{ard_*()} function calls} \usage{ .eval_ard_calls(data, .by, ...) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{.by}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to tabulate by in the series of ARD function calls} \item{...}{(\code{\link[rlang:dyn-dots]{dynamic-dots}})\cr Series of ARD function calls to be run and stacked} } \value{ list of ARD data frames of class 'card' } \description{ Evaluate the \verb{ard_*()} function calls } \examples{ cards:::.eval_ard_calls( data = ADSL, .by = "ARM", ard_categorical(variables = "AGEGR1"), ard_continuous(variables = "AGE") ) } \keyword{internal} cards/man/deprecated.Rd0000644000176200001440000000075314753417324014527 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/deprecated.R \name{deprecated} \alias{deprecated} \alias{label_cards} \title{Deprecated functions} \usage{ label_cards(...) } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}\cr Some functions have been deprecated and are no longer being actively supported. } \keyword{internal} cards/man/mock.Rd0000644000176200001440000000500614675616454013364 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mock.R \name{mock} \alias{mock} \alias{mock_categorical} \alias{mock_continuous} \alias{mock_dichotomous} \alias{mock_missing} \alias{mock_attributes} \alias{mock_total_n} \title{Mock ARDs} \usage{ mock_categorical( variables, statistic = everything() ~ c("n", "p", "N"), by = NULL ) mock_continuous( variables, statistic = everything() ~ c("N", "mean", "sd", "median", "p25", "p75", "min", "max"), by = NULL ) mock_dichotomous( variables, statistic = everything() ~ c("n", "p", "N"), by = NULL ) mock_missing( variables, statistic = everything() ~ c("N_obs", "N_miss", "N_nonmiss", "p_miss", "p_nonmiss"), by = NULL ) mock_attributes(label) mock_total_n() } \arguments{ \item{variables}{(\code{character} or named \code{list})\cr a character vector of variable names for functions \code{mock_continuous()}, \code{mock_missing()}, and \code{mock_attributes()}. a named list for functions \code{mock_categorical()} and \code{mock_dichotomous()}, where the list element is a vector of variable values. For \code{mock_dichotomous()}, only a single value is allowed for each variable.} \item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list elements are character vectors of statistic names to appear in the ARD.} \item{by}{(named \code{list})\cr a named list where the list element is a vector of variable values.} \item{label}{(named \code{list})\cr named list of variable labels, e.g. \code{list(cyl = "No. Cylinders")}.} } \value{ an ARD data frame of class 'card' } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}\cr Create empty ARDs used to create mock tables or table shells. Where applicable, the formatting functions are set to return \code{'xx'} or \code{'xx.x'}. } \examples{ mock_categorical( variables = list( AGEGR1 = factor(c("<65", "65-80", ">80"), levels = c("<65", "65-80", ">80")) ), by = list(TRTA = c("Placebo", "Xanomeline High Dose", "Xanomeline Low Dose")) ) |> apply_fmt_fn() mock_continuous( variables = c("AGE", "BMIBL"), by = list(TRTA = c("Placebo", "Xanomeline High Dose", "Xanomeline Low Dose")) ) |> # update the mock to report 'xx.xx' for standard deviations update_ard_fmt_fn(variables = c("AGE", "BMIBL"), stat_names = "sd", fmt_fn = \(x) "xx.xx") |> apply_fmt_fn() } cards/man/dot-calculate_tabulation_statistics.Rd0000644000176200001440000000361614746733642021653 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_categorical.R \name{.calculate_tabulation_statistics} \alias{.calculate_tabulation_statistics} \title{Calculate Tabulation Statistics} \usage{ .calculate_tabulation_statistics( data, variables, by, strata, denominator, statistic ) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to include in summaries. Default is \code{everything()}.} \item{by, strata}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr columns to use for grouping or stratifying the table output. Arguments are similar, but with an important distinction: \code{by}: results are tabulated by \strong{all combinations} of the columns specified, including unobserved combinations and unobserved factor levels. \code{strata}: results are tabulated by \strong{all \emph{observed} combinations} of the columns specified. Arguments may be used in conjunction with one another.} \item{denominator}{(\code{string}, \code{data.frame}, \code{integer})\cr Specify this argument to change the denominator, e.g. the \code{"N"} statistic. Default is \code{'column'}. See below for details.} \item{statistic}{(\code{\link[=syntax]{formula-list-selector}})\cr a named list, a list of formulas, or a single formula where the list element one or more of \code{c("n", "N", "p", "n_cum", "p_cum")} (on the RHS of a formula).} } \value{ an ARD data frame of class 'card' } \description{ Function takes the summary instructions from the \code{statistic = list(variable_name = list(tabulation=c("n", "N", "p")))} argument, and returns the tabulations in an ARD structure. } \examples{ cards:::.calculate_tabulation_statistics( ADSL, variables = "ARM", by = NULL, strata = NULL, denominator = "cell", statistic = list(ARM = list(tabulation = c("N"))) ) } \keyword{internal} cards/man/round5.Rd0000644000176200001440000000150614746733642013646 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/round5.R \name{round5} \alias{round5} \title{Rounding of Numbers} \usage{ round5(x, digits = 0) } \arguments{ \item{x}{(\code{numeric})\cr a numeric vector} \item{digits}{(\code{integer})\cr integer indicating the number of decimal places} } \value{ a numeric vector } \description{ Rounds the values in its first argument to the specified number of decimal places (default 0). Importantly, \code{round5()} \strong{does not} use Base R's "round to even" default. Standard rounding methods are implemented, for example, \code{cards::round5(0.5) = 1}, whereas \code{base::round(0.5) = 0}. } \details{ Function inspired by \code{janitor::round_half_up()}. } \examples{ x <- 0:4 / 2 round5(x) |> setNames(x) # compare results to Base R round(x) |> setNames(x) } cards/man/ard_attributes.Rd0000644000176200001440000000262214620757352015441 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ard_attributes.R \name{ard_attributes} \alias{ard_attributes} \alias{ard_attributes.data.frame} \alias{ard_attributes.default} \title{ARD Attributes} \usage{ ard_attributes(data, ...) \method{ard_attributes}{data.frame}(data, variables = everything(), label = NULL, ...) \method{ard_attributes}{default}(data, ...) } \arguments{ \item{data}{(\code{data.frame})\cr a data frame} \item{...}{These dots are for future extensions and must be empty.} \item{variables}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr variables to include} \item{label}{(named \code{list})\cr named list of variable labels, e.g. \code{list(cyl = "No. Cylinders")}. Default is \code{NULL}} } \value{ an ARD data frame of class 'card' } \description{ Add variable attributes to an ARD data frame. \itemize{ \item The \code{label} attribute will be added for all columns, and when no label is specified and no label has been set for a column using the \verb{label=} argument, the column name will be placed in the label statistic. \item The \code{class} attribute will also be returned for all columns. \item Any other attribute returned by \code{attributes()} will also be added, e.g. factor levels. } } \examples{ df <- dplyr::tibble(var1 = letters, var2 = LETTERS) attr(df$var1, "label") <- "Lowercase Letters" ard_attributes(df, variables = everything()) } cards/man/dot-check_fmt_string.Rd0000644000176200001440000000154614613620742016520 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/apply_fmt_fn.R \name{.check_fmt_string} \alias{.check_fmt_string} \title{Check 'xx' Format Structure} \usage{ .check_fmt_string(x, variable, stat_name) } \arguments{ \item{x}{(\code{string})\cr string to check} \item{variable}{(\code{character})\cr the variable whose statistic is to be formatted} \item{stat_name}{(\code{character})\cr the name of the statistic that is to be formatted} } \value{ a logical } \description{ A function that checks a \strong{single} string for consistency. String must begin with 'x' and only consist of x's, a single period or none, and may end with a percent symbol. If string is consistent, \code{TRUE} is returned. Otherwise an error. } \examples{ cards:::.check_fmt_string("xx.x") # TRUE cards:::.check_fmt_string("xx.x\%") # TRUE } \keyword{internal} cards/man/dot-detect_msgs.Rd0000644000176200001440000000150114776252447015514 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/shuffle_ard.R \name{.detect_msgs} \alias{.detect_msgs} \title{Detect Columns with Non-Null Contents} \usage{ .detect_msgs(x, ...) } \arguments{ \item{x}{(\code{data.frame})\cr a data frame} \item{...}{(\code{\link[rlang:dyn-dots]{dynamic-dots}})\cr columns to search within} } \description{ Function looks for non-null contents in requested columns and notifies user before removal. Specifically used for detecting messages. } \examples{ ard <- ard_continuous( ADSL, by = ARM, variables = AGE, statistic = ~ list( mean = \(x) mean(x), mean_warning = \(x) { warning("warn1") warning("warn2") mean(x) }, err_fn = \(x) stop("'tis an error") ) ) cards:::.detect_msgs(ard, "warning", "error") } \keyword{internal} cards/DESCRIPTION0000644000176200001440000000367414776310352013076 0ustar liggesusersPackage: cards Title: Analysis Results Data Version: 0.6.0 Authors@R: c( person("Daniel D.", "Sjoberg", , "danield.sjoberg@gmail.com", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-0862-2018")), person("Becca", "Krouse", , "becca.z.krouse@gsk.com", role = "aut"), person("Emily", "de la Rua", , "emily.de_la_rua@contractors.roche.com", role = "aut"), person("F. Hoffmann-La Roche AG", role = c("cph", "fnd")), person("GlaxoSmithKline Research & Development Limited", role = "cph") ) Description: Construct CDISC (Clinical Data Interchange Standards Consortium) compliant Analysis Results Data objects. These objects are used and re-used to construct summary tables, visualizations, and written reports. The package also exports utilities for working with these objects and creating new Analysis Results Data objects. License: Apache License 2.0 URL: https://github.com/insightsengineering/cards, https://insightsengineering.github.io/cards/ BugReports: https://github.com/insightsengineering/cards/issues Depends: R (>= 4.1) Imports: cli (>= 3.6.1), dplyr (>= 1.1.2), glue (>= 1.6.2), lifecycle (>= 1.0.3), rlang (>= 1.1.1), tidyr (>= 1.3.0), tidyselect (>= 1.2.0) Suggests: testthat (>= 3.2.0), withr (>= 3.0.0) Config/Needs/coverage: hms Config/Needs/website: rmarkdown, jsonlite, yaml, gtsummary, tfrmt, cardx, gt, fontawesome, insightsengineering/nesttemplate Config/testthat/edition: 3 Config/testthat/parallel: true Encoding: UTF-8 Language: en-US LazyData: true RoxygenNote: 7.3.2 NeedsCompilation: no Packaged: 2025-04-11 18:12:21 UTC; sjobergd Author: Daniel D. Sjoberg [aut, cre] (), Becca Krouse [aut], Emily de la Rua [aut], F. Hoffmann-La Roche AG [cph, fnd], GlaxoSmithKline Research & Development Limited [cph] Maintainer: Daniel D. Sjoberg Repository: CRAN Date/Publication: 2025-04-11 22:00:10 UTC