cards/0000755000176200001440000000000014721540432011350 5ustar liggesuserscards/tests/0000755000176200001440000000000014721522651012515 5ustar liggesuserscards/tests/testthat/0000755000176200001440000000000014721540432014352 5ustar liggesuserscards/tests/testthat/test-ard_continuous.R0000644000176200001440000003244014721250550020510 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.R0000644000176200001440000001404214664463007017745 0ustar liggesuserstest_that("shuffle/trim works", { # 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) # shuffle & trim ard_shuff_trim <- ard_test |> shuffle_ard() |> as.data.frame() expect_snapshot(ard_shuff_trim) # 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", { expect_snapshot( ard_continuous( ADSL, variables = AGEGR1 ) |> shuffle_ard() ) }) test_that("shuffle_ard fills missing group levels if the group is meaningful", { # 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)) ) |> 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)) ) |> shuffle_ard() ) # mix of group variables - fills overall only if variable has been calculated by group elsewhere withr::local_options(list(width = 90)) expect_snapshot( bind_ard( ard_categorical(ADSL, by = ARM, variables = AGEGR1), ard_categorical(ADSL, variables = AGEGR1), ard_continuous(ADSL, by = SEX, variables = AGE), ard_continuous(ADSL, variables = AGE) ) |> 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_character_, 10)) |> ard_continuous( variables = x, statistic = ~ continuous_summary_fns(c("median", "p25", "p75")) ) |> shuffle_ard() |> dplyr::pull(stat) ) # check that all rows present and result is a numeric vector expect_length(res, 3) expect_equal(class(res), "numeric") }) test_that("shuffle_ard trims statistics with length > 1", { expect_equal( ard_continuous( ADSL, variables = AGE, statistic = list(AGE = list( long_result = \(x) 1:3, long_list_result = \(x) list(1:3) )) ) |> shuffle_ard() |> nrow(), 0L ) }) 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$label)), 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", { # 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() ) # adsl_sub <- ADSL |> dplyr::filter(ARM %in% unique(ARM)[1:2]) # bind_ard( # cardx::ard_stats_chisq_test( # data = adsl_sub, # by = "ARM", # variables = "AGEGR1" # ), # cardx::ard_stats_chisq_test( # data = adsl_sub, # by = "SEX", # variables = "AGEGR1" # ) # ) |> # dplyr::filter(stat_name %in% c("statistic", "p.value")) |> # dput() }) 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-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.R0000644000176200001440000000054714567176413020141 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 ) }) cards/tests/testthat/test-print_ard_conditions.R0000644000176200001440000000612214671705567021706 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() 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.R0000644000176200001440000000167214675616454021335 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") ) }) test_that("rename_ard_columns(unlist)", { expect_snapshot( ADSL |> ard_categorical(by = ARM, variables = AGEGR1) |> apply_fmt_fn() |> rename_ard_columns(unlist = c(stat, stat_fmt)) ) }) test_that("rename_ard_columns(unlist) messaging", { expect_snapshot( ADSL |> ard_categorical(by = ARM, variables = AGEGR1) |> dplyr::mutate(stat = ifelse(dplyr::row_number() == 1L, list(median), stat)) |> rename_ard_columns(unlist = stat) |> head(1L) ) expect_snapshot( error = TRUE, ADSL |> ard_categorical(by = ARM, variables = AGEGR1) |> dplyr::mutate(stat = ifelse(dplyr::row_number() == 1L, list(NULL), stat)) |> 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-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-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-mock.R0000644000176200001440000000515714675616454016433 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-label_cards.R0000644000176200001440000000056714567176413017731 0ustar liggesuserstest_that("label_cards() works", { expect_equal( label_cards(scale = 100, digits = 2)(9:10), c("900.00", "1000.00") ) expect_equal( label_cards(digits = 2, width = 5)(9:10), c(" 9.00", "10.00") ) expect_equal( label_cards()(NA), NA_character_ ) expect_equal( label_cards(width = 5)(c(NA, 1)), c(NA_character_, " 1.0") ) }) 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-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.R0000644000176200001440000002201414721205552020716 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.R0000644000176200001440000000241514721205552022024 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.R0000644000176200001440000000162314677313045017610 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-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.R0000644000176200001440000001640114675616454017427 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_categorical(data = mtcars, variables = "cyl"), ard_continuous(data = mtcars, variables = "mpg"), ard_dichotomous(data = mtcars, variables = "vs"), .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_categorical(data = mtcars, variables = "cyl"), ard_missing(data = mtcars, by = "cyl", variables = c("mpg", "vs")), ard_attributes(mtcars, variables = c("cyl", "mpg", "vs")), .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_missing(data = mtcars, variables = c("mpg", "vs")), ard_categorical(data = mtcars, variables = "cyl"), ard_attributes(mtcars, variables = c("cyl", "mpg", "vs")), .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_categorical(data = mtcars, variables = "cyl"), ard_continuous(data = mtcars, variables = "mpg"), ard_dichotomous(data = mtcars, variables = "vs"), .order = TRUE ) |> 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-update_ard.R0000644000176200001440000000524614672114773017603 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.R0000644000176200001440000005757214675616454020615 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", { 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) ) }) cards/tests/testthat/_snaps/0000755000176200001440000000000014721513741015640 5ustar liggesuserscards/tests/testthat/_snaps/round5.md0000644000176200001440000000263014721245611017375 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.md0000644000176200001440000000435414721245606020316 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 group1 group1_level group2 group2_level variable stat_name stat_label stat 1 AGEGR1 65-80 ARM Placebo AGE N N 42 2 AGEGR1 65-80 ARM Placebo AGE mean Mean 73.595 3 AGEGR1 65-80 ARM Placebo AGE sd SD 4.173 4 AGEGR1 65-80 ARM Placebo AGE median Median 74 5 AGEGR1 65-80 ARM Placebo AGE p25 Q1 70 6 AGEGR1 65-80 ARM Placebo AGE p75 Q3 77 7 AGEGR1 65-80 ARM Placebo AGE min Min 65 8 AGEGR1 65-80 ARM Placebo AGE max Max 80 9 AGEGR1 <65 ARM Placebo AGE N N 14 10 AGEGR1 <65 ARM Placebo 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.md0000644000176200001440000002060014721245571021266 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) 19 SEX n n 20 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 1 ARM Placebo AGEGR1 65-80 categorical n 2 ARM Placebo AGEGR1 65-80 categorical N 3 ARM Xanomeline High Dose AGEGR1 65-80 categorical n 4 ARM Xanomeline High Dose AGEGR1 65-80 categorical N 5 ARM Xanomeline Low Dose AGEGR1 65-80 categorical n 6 ARM Xanomeline Low Dose AGEGR1 65-80 categorical N 7 ARM Placebo AGEGR1 <65 categorical n 8 ARM Placebo AGEGR1 <65 categorical N 9 ARM Xanomeline High Dose AGEGR1 <65 categorical n 10 ARM Xanomeline High Dose AGEGR1 <65 categorical N 11 ARM Xanomeline Low Dose AGEGR1 <65 categorical n 12 ARM Xanomeline Low Dose AGEGR1 <65 categorical N 13 ARM Placebo AGEGR1 >80 categorical n 14 ARM Placebo AGEGR1 >80 categorical N 15 ARM Xanomeline High Dose AGEGR1 >80 categorical n 16 ARM Xanomeline High Dose AGEGR1 >80 categorical N 17 ARM Xanomeline Low Dose AGEGR1 >80 categorical n 18 ARM Xanomeline Low Dose AGEGR1 >80 categorical N stat_label stat stat_fmt 1 n 42 42.00 2 N 144 144 3 n 55 55.00 4 N 144 144 5 n 47 47.00 6 N 144 144 7 n 14 14.00 8 N 33 33 9 n 11 11.00 10 N 33 33 11 n 8 8.00 12 N 33 33 13 n 30 30.00 14 N 77 77 15 n 18 18.00 16 N 77 77 17 n 29 29.00 18 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". cards/tests/testthat/_snaps/bind_ard.md0000644000176200001440000001323214721245607017730 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 1 ARM Xanomeline Low Dose SEX M n n 2 ARM Xanomeline Low Dose SEX M p % 3 ARM Xanomeline Low Dose SEX F p % 4 ARM Xanomeline Low Dose SEX F N N 5 ARM Xanomeline Low Dose SEX F n n 6 ARM Xanomeline Low Dose SEX M N N 7 ARM Xanomeline High Dose SEX F p % 8 ARM Xanomeline High Dose SEX F n n 9 ARM Xanomeline High Dose SEX M p % 10 ARM Xanomeline High Dose SEX M n n 11 ARM Xanomeline High Dose SEX M N N 12 ARM Xanomeline High Dose SEX F N N 13 ARM Placebo SEX M N N 14 ARM Placebo SEX M p % 15 ARM Placebo SEX F n n 16 ARM Placebo SEX F N N 17 ARM Placebo SEX F p % 18 ARM Placebo SEX M n n stat 1 34 2 0.4047619 3 0.5952381 4 84 5 50 6 84 7 0.4761905 8 40 9 0.5238095 10 44 11 84 12 84 13 86 14 0.3837209 15 53 16 86 17 0.6162791 18 33 --- 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 1 ARM Placebo SEX F p % 2 ARM Xanomeline High Dose SEX M N N 3 ARM Xanomeline High Dose SEX F n n 4 ARM Xanomeline Low Dose SEX F n n 5 ARM Xanomeline Low Dose SEX F p % 6 ARM Placebo SEX F n n 7 ARM Placebo SEX M n n 8 ARM Placebo SEX M N N 9 ARM Xanomeline High Dose SEX F p % 10 ARM Xanomeline High Dose SEX F N N 11 ARM Xanomeline High Dose SEX M p % 12 ARM Placebo SEX F N N 13 ARM Xanomeline Low Dose SEX M p % 14 ARM Placebo SEX M p % 15 ARM Xanomeline Low Dose SEX F N N 16 ARM Xanomeline High Dose SEX M n n 17 ARM Xanomeline Low Dose SEX M N N 18 ARM Xanomeline Low Dose SEX M n n stat 1 0.6162791 2 84 3 40 4 50 5 0.5952381 6 53 7 33 8 86 9 0.4761905 10 84 11 0.5238095 12 86 13 0.4047619 14 0.3837209 15 84 16 44 17 84 18 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/shift_ard_columns.md0000644000176200001440000002176214721245612021674 0ustar liggesusers# rename_ard_columns() works Code as.data.frame(dplyr::slice(dplyr::select(res_rnm_var, -c(fmt_fn, warning, error)), 1:20)) Output group1 group1_level AGE BMIBL HEIGHTBL context stat_name 1 TRT01A Placebo Overall AGE continuous N 2 TRT01A Placebo Overall AGE continuous mean 3 TRT01A Placebo Overall AGE continuous sd 4 TRT01A Placebo Overall AGE continuous median 5 TRT01A Placebo Overall AGE continuous p25 6 TRT01A Placebo Overall AGE continuous p75 7 TRT01A Placebo Overall AGE continuous min 8 TRT01A Placebo Overall AGE continuous max 9 TRT01A Xanomeline High Dose Overall AGE continuous N 10 TRT01A Xanomeline High Dose Overall AGE continuous mean 11 TRT01A Xanomeline High Dose Overall AGE continuous sd 12 TRT01A Xanomeline High Dose Overall AGE continuous median 13 TRT01A Xanomeline High Dose Overall AGE continuous p25 14 TRT01A Xanomeline High Dose Overall AGE continuous p75 15 TRT01A Xanomeline High Dose Overall AGE continuous min 16 TRT01A Xanomeline High Dose Overall AGE continuous max 17 TRT01A Xanomeline Low Dose Overall AGE continuous N 18 TRT01A Xanomeline Low Dose Overall AGE continuous mean 19 TRT01A Xanomeline Low Dose Overall AGE continuous sd 20 TRT01A Xanomeline Low Dose Overall AGE continuous median stat_label stat 1 N 86 2 Mean 75.2093 3 SD 8.590167 4 Median 76 5 Q1 69 6 Q3 82 7 Min 52 8 Max 89 9 N 84 10 Mean 74.38095 11 SD 7.886094 12 Median 76 13 Q1 70.5 14 Q3 80 15 Min 56 16 Max 88 17 N 84 18 Mean 75.66667 19 SD 8.286051 20 Median 77.5 --- Code as.data.frame(dplyr::slice(dplyr::select(res_multi_1, -c(fmt_fn, warning, error)), 1:20)) Output TRT01A SEX RACE ETHNIC AGE 1 Placebo F AMERICAN INDIAN OR ALASKA NATIVE 2 Placebo F AMERICAN INDIAN OR ALASKA NATIVE 3 Placebo F AMERICAN INDIAN OR ALASKA NATIVE 4 Placebo F BLACK OR AFRICAN AMERICAN 5 Placebo F BLACK OR AFRICAN AMERICAN 6 Placebo F BLACK OR AFRICAN AMERICAN 7 Placebo F WHITE 8 Placebo F WHITE 9 Placebo F WHITE 10 Placebo M AMERICAN INDIAN OR ALASKA NATIVE 11 Placebo M AMERICAN INDIAN OR ALASKA NATIVE 12 Placebo M AMERICAN INDIAN OR ALASKA NATIVE 13 Placebo M BLACK OR AFRICAN AMERICAN 14 Placebo M BLACK OR AFRICAN AMERICAN 15 Placebo M BLACK OR AFRICAN AMERICAN 16 Placebo M WHITE 17 Placebo M WHITE 18 Placebo M WHITE 19 Xanomeline High Dose F AMERICAN INDIAN OR ALASKA NATIVE 20 Xanomeline High Dose F AMERICAN INDIAN OR ALASKA NATIVE context stat_name stat_label stat 1 categorical n n 0 2 categorical N N 53 3 categorical p % 0 4 categorical n n 5 5 categorical N N 53 6 categorical p % 0.09433962 7 categorical n n 48 8 categorical N N 53 9 categorical p % 0.9056604 10 categorical n n 0 11 categorical N N 33 12 categorical p % 0 13 categorical n n 3 14 categorical N N 33 15 categorical p % 0.09090909 16 categorical n n 30 17 categorical N N 33 18 categorical p % 0.9090909 19 categorical n n 0 20 categorical N N 40 --- Code as.data.frame(dplyr::slice(rename_ard_columns(res_shuffle, c(variable, label)), 1:20)) Output TRT01A RACE ETHNIC AGE 1 Placebo AMERICAN INDIAN OR ALASKA NATIVE 2 Placebo AMERICAN INDIAN OR ALASKA NATIVE 3 Placebo AMERICAN INDIAN OR ALASKA NATIVE 4 Placebo BLACK OR AFRICAN AMERICAN 5 Placebo BLACK OR AFRICAN AMERICAN 6 Placebo BLACK OR AFRICAN AMERICAN 7 Placebo WHITE 8 Placebo WHITE 9 Placebo WHITE 10 Xanomeline High Dose AMERICAN INDIAN OR ALASKA NATIVE 11 Xanomeline High Dose AMERICAN INDIAN OR ALASKA NATIVE 12 Xanomeline High Dose AMERICAN INDIAN OR ALASKA NATIVE 13 Xanomeline High Dose BLACK OR AFRICAN AMERICAN 14 Xanomeline High Dose BLACK OR AFRICAN AMERICAN 15 Xanomeline High Dose BLACK OR AFRICAN AMERICAN 16 Xanomeline High Dose WHITE 17 Xanomeline High Dose WHITE 18 Xanomeline High Dose WHITE 19 Xanomeline Low Dose AMERICAN INDIAN OR ALASKA NATIVE 20 Xanomeline Low Dose AMERICAN INDIAN OR ALASKA NATIVE context stat_name stat 1 categorical n 0.00000000 2 categorical N 86.00000000 3 categorical p 0.00000000 4 categorical n 8.00000000 5 categorical N 86.00000000 6 categorical p 0.09302326 7 categorical n 78.00000000 8 categorical N 86.00000000 9 categorical p 0.90697674 10 categorical n 1.00000000 11 categorical N 84.00000000 12 categorical p 0.01190476 13 categorical n 9.00000000 14 categorical N 84.00000000 15 categorical p 0.10714286 16 categorical n 74.00000000 17 categorical N 84.00000000 18 categorical p 0.88095238 19 categorical n 0.00000000 20 categorical N 84.00000000 --- Code rename_ard_columns(dplyr::select(res_var, -group1), "group1_level") Message ! The following `*_level` columns do not have a match and will not be renamed: "group1_level" {cards} data frame: 72 x 9 Output group1_level variable context stat_name stat_label stat 1 Placebo AGE continuo… N N 86 2 Placebo AGE continuo… mean Mean 75.209 3 Placebo AGE continuo… sd SD 8.59 4 Placebo AGE continuo… median Median 76 5 Placebo AGE continuo… p25 Q1 69 6 Placebo AGE continuo… p75 Q3 82 7 Placebo AGE continuo… min Min 52 8 Placebo AGE continuo… max Max 89 9 Placebo BMIBL continuo… N N 86 10 Placebo BMIBL continuo… mean Mean 23.636 Message i 62 more rows i Use `print(n = ...)` to see more rows i 3 more variables: fmt_fn, warning, error cards/tests/testthat/_snaps/add_calculated_row.md0000644000176200001440000000527514721245563021777 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.md0000644000176200001440000001040414721245611017313 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 Xanomeli… AGEGR1 65-80 n n 55 5 ARM Xanomeli… AGEGR1 65-80 N N 84 6 ARM Xanomeli… AGEGR1 65-80 p % 0.655 7 ARM Xanomeli… AGEGR1 65-80 n n 47 8 ARM Xanomeli… AGEGR1 65-80 N N 84 9 ARM Xanomeli… AGEGR1 65-80 p % 0.56 10 ARM Placebo AGEGR1 <65 n n 14 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.md0000644000176200001440000000745314721245611022404 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() 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.md0000644000176200001440000000466014721245611022023 0ustar liggesusers# rename_ard_columns(unlist) Code rename_ard_columns(apply_fmt_fn(ard_categorical(ADSL, by = ARM, variables = AGEGR1)), unlist = c(stat, stat_fmt)) Output # A tibble: 27 x 10 ARM AGEGR1 context stat_name stat_label stat stat_fmt fmt_fn warning 1 Placebo 65-80 catego~ n n 42 42 2 Placebo 65-80 catego~ N N 86 86 3 Placebo 65-80 catego~ p % 0.488 48.8 4 Xanomelin~ 65-80 catego~ n n 55 55 5 Xanomelin~ 65-80 catego~ N N 84 84 6 Xanomelin~ 65-80 catego~ p % 0.655 65.5 7 Xanomelin~ 65-80 catego~ n n 47 47 8 Xanomelin~ 65-80 catego~ N N 84 84 9 Xanomelin~ 65-80 catego~ p % 0.560 56.0 10 Placebo <65 catego~ n n 14 14 # i 17 more rows # i 1 more variable: error # rename_ard_columns(unlist) messaging Code head(rename_ard_columns(dplyr::mutate(ard_categorical(ADSL, by = ARM, variables = AGEGR1), stat = ifelse(dplyr::row_number() == 1L, list(median), stat)), unlist = stat), 1L) Message Unable to unlist column "stat". i This often occurs when a list column contains elements that cannot coerced to a common type. Output # A tibble: 1 x 9 ARM AGEGR1 context stat_name stat_label stat fmt_fn warning error 1 Placebo 65-80 categorical n n --- Code rename_ard_columns(dplyr::mutate(ard_categorical(ADSL, by = ARM, variables = AGEGR1), stat = ifelse(dplyr::row_number() == 1L, list(NULL), stat)), unlist = stat) Condition Error in `rename_ard_columns()`: ! Cannot unlist column "stat". The unlisted result is not the same length as the original. i This often occurs when the column contains `NULL` values. * Run `cards::replace_null_statistic()` to replace `NULL` values with NA. cards/tests/testthat/_snaps/as_card.md0000644000176200001440000000075014721245607017563 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.md0000644000176200001440000001024414721245605020117 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.md0000644000176200001440000001477214721245613020457 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/ard_continuous.md0000644000176200001440000001312614721245611021217 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.md0000644000176200001440000000133214721245610022035 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/ard_missing.md0000644000176200001440000000606414721245576020477 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.md0000644000176200001440000001665314721245602022624 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 MILD AESOC SKIN AND… n n 1 3 AESEV MODERATE AESOC GENERAL … n n 0 4 AESEV MODERATE AESOC SKIN AND… n n 1 5 AESOC GENERAL … n n 4 6 AESOC SKIN AND… n n 2 7 AESEV MILD AESOC GENERAL … AEDECOD APPLICAT… n n 2 8 AESEV MILD AESOC GENERAL … AEDECOD APPLICAT… n n 2 9 AESEV MILD AESOC SKIN AND… AEDECOD ERYTHEMA n n 1 10 AESEV MILD AESOC SKIN AND… AEDECOD PRURITUS… n n 0 11 AESEV MODERATE AESOC GENERAL … AEDECOD APPLICAT… n n 0 12 AESEV MODERATE AESOC GENERAL … AEDECOD APPLICAT… n n 0 13 AESEV MODERATE AESOC SKIN AND… AEDECOD ERYTHEMA n n 0 14 AESEV MODERATE AESOC SKIN AND… AEDECOD PRURITUS… n n 1 15 AESOC GENERAL … AEDECOD APPLICAT… n n 2 16 AESOC GENERAL … AEDECOD APPLICAT… n n 2 17 AESOC SKIN AND… AEDECOD ERYTHEMA 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.md0000644000176200001440000000473414721245610023072 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.md0000644000176200001440000001004514721245613020272 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.md0000644000176200001440000000070614721245607022213 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.md0000644000176200001440000006624214721245613020456 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 0 NULL NULL 2 AGE continuous mean Mean 75.08661 1 NULL NULL 3 AGE continuous sd SD 8.246234 1 NULL NULL 4 AGE continuous median Median 77 1 NULL NULL 5 AGE continuous p25 Q1 70 1 NULL NULL 6 AGE continuous p75 Q3 81 1 NULL NULL 7 AGE continuous min Min 51 1 NULL NULL 8 AGE continuous max Max 89 1 NULL NULL --- Code ard_shuffled Output ARM variable label context stat_name 1 Placebo AGE N continuous N 2 Placebo AGE Mean(SD) continuous mean 3 Placebo AGE Mean(SD) continuous sd 4 Placebo AGE median continuous median 5 Placebo AGE p25 continuous p25 6 Placebo AGE p75 continuous p75 7 Placebo AGE min continuous min 8 Placebo AGE max continuous max 9 Placebo AGE Vector Length missing N_obs 10 Placebo AGE N Missing missing N_miss 11 Placebo AGE N Non-missing missing N_nonmiss 12 Placebo AGE % Missing missing p_miss 13 Placebo AGE % Non-missing missing p_nonmiss 14 Xanomeline High Dose AGE N continuous N 15 Xanomeline High Dose AGE Mean(SD) continuous mean 16 Xanomeline High Dose AGE Mean(SD) continuous sd 17 Xanomeline High Dose AGE median continuous median 18 Xanomeline High Dose AGE p25 continuous p25 19 Xanomeline High Dose AGE p75 continuous p75 20 Xanomeline High Dose AGE min continuous min 21 Xanomeline High Dose AGE max continuous max 22 Xanomeline High Dose AGE Vector Length missing N_obs 23 Xanomeline High Dose AGE N Missing missing N_miss 24 Xanomeline High Dose AGE N Non-missing missing N_nonmiss 25 Xanomeline High Dose AGE % Missing missing p_miss 26 Xanomeline High Dose AGE % Non-missing missing p_nonmiss 27 Xanomeline Low Dose AGE N continuous N 28 Xanomeline Low Dose AGE Mean(SD) continuous mean 29 Xanomeline Low Dose AGE Mean(SD) continuous sd 30 Xanomeline Low Dose AGE median continuous median 31 Xanomeline Low Dose AGE p25 continuous p25 32 Xanomeline Low Dose AGE p75 continuous p75 33 Xanomeline Low Dose AGE min continuous min 34 Xanomeline Low Dose AGE max continuous max 35 Xanomeline Low Dose AGE Vector Length missing N_obs 36 Xanomeline Low Dose AGE N Missing missing N_miss 37 Xanomeline Low Dose AGE N Non-missing missing N_nonmiss 38 Xanomeline Low Dose AGE % Missing missing p_miss 39 Xanomeline Low Dose AGE % Non-missing missing p_nonmiss 40 Placebo AGEGR1 65-80 categorical n 41 Placebo AGEGR1 65-80 categorical N 42 Placebo AGEGR1 65-80 categorical p 43 Placebo AGEGR1 <65 categorical n 44 Placebo AGEGR1 <65 categorical N 45 Placebo AGEGR1 <65 categorical p 46 Placebo AGEGR1 >80 categorical n 47 Placebo AGEGR1 >80 categorical N 48 Placebo AGEGR1 >80 categorical p 49 Placebo AGEGR1 Vector Length missing N_obs 50 Placebo AGEGR1 N Missing missing N_miss 51 Placebo AGEGR1 N Non-missing missing N_nonmiss 52 Placebo AGEGR1 % Missing missing p_miss 53 Placebo AGEGR1 % Non-missing missing p_nonmiss 54 Xanomeline High Dose AGEGR1 65-80 categorical n 55 Xanomeline High Dose AGEGR1 65-80 categorical N 56 Xanomeline High Dose AGEGR1 65-80 categorical p 57 Xanomeline High Dose AGEGR1 <65 categorical n 58 Xanomeline High Dose AGEGR1 <65 categorical N 59 Xanomeline High Dose AGEGR1 <65 categorical p 60 Xanomeline High Dose AGEGR1 >80 categorical n 61 Xanomeline High Dose AGEGR1 >80 categorical N 62 Xanomeline High Dose AGEGR1 >80 categorical p 63 Xanomeline High Dose AGEGR1 Vector Length missing N_obs 64 Xanomeline High Dose AGEGR1 N Missing missing N_miss 65 Xanomeline High Dose AGEGR1 N Non-missing missing N_nonmiss 66 Xanomeline High Dose AGEGR1 % Missing missing p_miss 67 Xanomeline High Dose AGEGR1 % Non-missing missing p_nonmiss 68 Xanomeline Low Dose AGEGR1 65-80 categorical n 69 Xanomeline Low Dose AGEGR1 65-80 categorical N 70 Xanomeline Low Dose AGEGR1 65-80 categorical p 71 Xanomeline Low Dose AGEGR1 <65 categorical n 72 Xanomeline Low Dose AGEGR1 <65 categorical N 73 Xanomeline Low Dose AGEGR1 <65 categorical p 74 Xanomeline Low Dose AGEGR1 >80 categorical n 75 Xanomeline Low Dose AGEGR1 >80 categorical N 76 Xanomeline Low Dose AGEGR1 >80 categorical p 77 Xanomeline Low Dose AGEGR1 Vector Length missing N_obs 78 Xanomeline Low Dose AGEGR1 N Missing missing N_miss 79 Xanomeline Low Dose AGEGR1 N Non-missing missing N_nonmiss 80 Xanomeline Low Dose AGEGR1 % Missing missing p_miss 81 Xanomeline Low Dose AGEGR1 % Non-missing missing p_nonmiss 82 Placebo ARM Placebo categorical n 83 Placebo ARM Placebo categorical N 84 Placebo ARM Placebo categorical p 85 Xanomeline High Dose ARM Xanomeline High Dose categorical n 86 Xanomeline High Dose ARM Xanomeline High Dose categorical N 87 Xanomeline High Dose ARM Xanomeline High Dose categorical p 88 Xanomeline Low Dose ARM Xanomeline Low Dose categorical n 89 Xanomeline Low Dose ARM Xanomeline Low Dose categorical N 90 Xanomeline Low Dose ARM Xanomeline Low Dose categorical p stat 1 86.0000000 2 75.2093023 3 8.5901671 4 76.0000000 5 69.0000000 6 82.0000000 7 52.0000000 8 89.0000000 9 86.0000000 10 0.0000000 11 86.0000000 12 0.0000000 13 1.0000000 14 84.0000000 15 74.3809524 16 7.8860938 17 76.0000000 18 70.5000000 19 80.0000000 20 56.0000000 21 88.0000000 22 84.0000000 23 0.0000000 24 84.0000000 25 0.0000000 26 1.0000000 27 84.0000000 28 75.6666667 29 8.2860506 30 77.5000000 31 71.0000000 32 82.0000000 33 51.0000000 34 88.0000000 35 84.0000000 36 0.0000000 37 84.0000000 38 0.0000000 39 1.0000000 40 42.0000000 41 86.0000000 42 0.4883721 43 14.0000000 44 86.0000000 45 0.1627907 46 30.0000000 47 86.0000000 48 0.3488372 49 86.0000000 50 0.0000000 51 86.0000000 52 0.0000000 53 1.0000000 54 55.0000000 55 84.0000000 56 0.6547619 57 11.0000000 58 84.0000000 59 0.1309524 60 18.0000000 61 84.0000000 62 0.2142857 63 84.0000000 64 0.0000000 65 84.0000000 66 0.0000000 67 1.0000000 68 47.0000000 69 84.0000000 70 0.5595238 71 8.0000000 72 84.0000000 73 0.0952381 74 29.0000000 75 84.0000000 76 0.3452381 77 84.0000000 78 0.0000000 79 84.0000000 80 0.0000000 81 1.0000000 82 86.0000000 83 254.0000000 84 0.3385827 85 84.0000000 86 254.0000000 87 0.3307087 88 84.0000000 89 254.0000000 90 0.3307087 --- Code ard_shuff_trim Output ARM variable label context stat_name 1 Placebo AGE N continuous N 2 Placebo AGE Mean(SD) continuous mean 3 Placebo AGE Mean(SD) continuous sd 4 Placebo AGE median continuous median 5 Placebo AGE p25 continuous p25 6 Placebo AGE p75 continuous p75 7 Placebo AGE min continuous min 8 Placebo AGE max continuous max 9 Placebo AGE Vector Length missing N_obs 10 Placebo AGE N Missing missing N_miss 11 Placebo AGE N Non-missing missing N_nonmiss 12 Placebo AGE % Missing missing p_miss 13 Placebo AGE % Non-missing missing p_nonmiss 14 Xanomeline High Dose AGE N continuous N 15 Xanomeline High Dose AGE Mean(SD) continuous mean 16 Xanomeline High Dose AGE Mean(SD) continuous sd 17 Xanomeline High Dose AGE median continuous median 18 Xanomeline High Dose AGE p25 continuous p25 19 Xanomeline High Dose AGE p75 continuous p75 20 Xanomeline High Dose AGE min continuous min 21 Xanomeline High Dose AGE max continuous max 22 Xanomeline High Dose AGE Vector Length missing N_obs 23 Xanomeline High Dose AGE N Missing missing N_miss 24 Xanomeline High Dose AGE N Non-missing missing N_nonmiss 25 Xanomeline High Dose AGE % Missing missing p_miss 26 Xanomeline High Dose AGE % Non-missing missing p_nonmiss 27 Xanomeline Low Dose AGE N continuous N 28 Xanomeline Low Dose AGE Mean(SD) continuous mean 29 Xanomeline Low Dose AGE Mean(SD) continuous sd 30 Xanomeline Low Dose AGE median continuous median 31 Xanomeline Low Dose AGE p25 continuous p25 32 Xanomeline Low Dose AGE p75 continuous p75 33 Xanomeline Low Dose AGE min continuous min 34 Xanomeline Low Dose AGE max continuous max 35 Xanomeline Low Dose AGE Vector Length missing N_obs 36 Xanomeline Low Dose AGE N Missing missing N_miss 37 Xanomeline Low Dose AGE N Non-missing missing N_nonmiss 38 Xanomeline Low Dose AGE % Missing missing p_miss 39 Xanomeline Low Dose AGE % Non-missing missing p_nonmiss 40 Placebo AGEGR1 65-80 categorical n 41 Placebo AGEGR1 65-80 categorical N 42 Placebo AGEGR1 65-80 categorical p 43 Placebo AGEGR1 <65 categorical n 44 Placebo AGEGR1 <65 categorical N 45 Placebo AGEGR1 <65 categorical p 46 Placebo AGEGR1 >80 categorical n 47 Placebo AGEGR1 >80 categorical N 48 Placebo AGEGR1 >80 categorical p 49 Placebo AGEGR1 Vector Length missing N_obs 50 Placebo AGEGR1 N Missing missing N_miss 51 Placebo AGEGR1 N Non-missing missing N_nonmiss 52 Placebo AGEGR1 % Missing missing p_miss 53 Placebo AGEGR1 % Non-missing missing p_nonmiss 54 Xanomeline High Dose AGEGR1 65-80 categorical n 55 Xanomeline High Dose AGEGR1 65-80 categorical N 56 Xanomeline High Dose AGEGR1 65-80 categorical p 57 Xanomeline High Dose AGEGR1 <65 categorical n 58 Xanomeline High Dose AGEGR1 <65 categorical N 59 Xanomeline High Dose AGEGR1 <65 categorical p 60 Xanomeline High Dose AGEGR1 >80 categorical n 61 Xanomeline High Dose AGEGR1 >80 categorical N 62 Xanomeline High Dose AGEGR1 >80 categorical p 63 Xanomeline High Dose AGEGR1 Vector Length missing N_obs 64 Xanomeline High Dose AGEGR1 N Missing missing N_miss 65 Xanomeline High Dose AGEGR1 N Non-missing missing N_nonmiss 66 Xanomeline High Dose AGEGR1 % Missing missing p_miss 67 Xanomeline High Dose AGEGR1 % Non-missing missing p_nonmiss 68 Xanomeline Low Dose AGEGR1 65-80 categorical n 69 Xanomeline Low Dose AGEGR1 65-80 categorical N 70 Xanomeline Low Dose AGEGR1 65-80 categorical p 71 Xanomeline Low Dose AGEGR1 <65 categorical n 72 Xanomeline Low Dose AGEGR1 <65 categorical N 73 Xanomeline Low Dose AGEGR1 <65 categorical p 74 Xanomeline Low Dose AGEGR1 >80 categorical n 75 Xanomeline Low Dose AGEGR1 >80 categorical N 76 Xanomeline Low Dose AGEGR1 >80 categorical p 77 Xanomeline Low Dose AGEGR1 Vector Length missing N_obs 78 Xanomeline Low Dose AGEGR1 N Missing missing N_miss 79 Xanomeline Low Dose AGEGR1 N Non-missing missing N_nonmiss 80 Xanomeline Low Dose AGEGR1 % Missing missing p_miss 81 Xanomeline Low Dose AGEGR1 % Non-missing missing p_nonmiss 82 Placebo ARM Placebo categorical n 83 Placebo ARM Placebo categorical N 84 Placebo ARM Placebo categorical p 85 Xanomeline High Dose ARM Xanomeline High Dose categorical n 86 Xanomeline High Dose ARM Xanomeline High Dose categorical N 87 Xanomeline High Dose ARM Xanomeline High Dose categorical p 88 Xanomeline Low Dose ARM Xanomeline Low Dose categorical n 89 Xanomeline Low Dose ARM Xanomeline Low Dose categorical N 90 Xanomeline Low Dose ARM Xanomeline Low Dose categorical p stat 1 86.0000000 2 75.2093023 3 8.5901671 4 76.0000000 5 69.0000000 6 82.0000000 7 52.0000000 8 89.0000000 9 86.0000000 10 0.0000000 11 86.0000000 12 0.0000000 13 1.0000000 14 84.0000000 15 74.3809524 16 7.8860938 17 76.0000000 18 70.5000000 19 80.0000000 20 56.0000000 21 88.0000000 22 84.0000000 23 0.0000000 24 84.0000000 25 0.0000000 26 1.0000000 27 84.0000000 28 75.6666667 29 8.2860506 30 77.5000000 31 71.0000000 32 82.0000000 33 51.0000000 34 88.0000000 35 84.0000000 36 0.0000000 37 84.0000000 38 0.0000000 39 1.0000000 40 42.0000000 41 86.0000000 42 0.4883721 43 14.0000000 44 86.0000000 45 0.1627907 46 30.0000000 47 86.0000000 48 0.3488372 49 86.0000000 50 0.0000000 51 86.0000000 52 0.0000000 53 1.0000000 54 55.0000000 55 84.0000000 56 0.6547619 57 11.0000000 58 84.0000000 59 0.1309524 60 18.0000000 61 84.0000000 62 0.2142857 63 84.0000000 64 0.0000000 65 84.0000000 66 0.0000000 67 1.0000000 68 47.0000000 69 84.0000000 70 0.5595238 71 8.0000000 72 84.0000000 73 0.0952381 74 29.0000000 75 84.0000000 76 0.3452381 77 84.0000000 78 0.0000000 79 84.0000000 80 0.0000000 81 1.0000000 82 86.0000000 83 254.0000000 84 0.3385827 85 84.0000000 86 254.0000000 87 0.3307087 88 84.0000000 89 254.0000000 90 0.3307087 # 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: 4 x 4 variable context stat_name stat 1 AGEGR1 continuous N 254 2 AGEGR1 continuous mean NA 3 AGEGR1 continuous sd NA 4 AGEGR1 continuous median NA # shuffle_ard fills missing group levels if the group is meaningful Code shuffle_ard(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)))) Output # A tibble: 4 x 5 ARM variable context stat_name stat 1 Placebo AGE continuous mean 75.2 2 Xanomeline High Dose AGE continuous mean 74.4 3 Xanomeline Low Dose AGE continuous mean 75.7 4 Overall ARM AGE p 0.05 --- Code shuffle_ard(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)))) Output # A tibble: 2 x 5 ARM variable context stat_name stat 1 Overall ARM AGE p 0.05 2 AGE continuous mean 75.1 --- Code as.data.frame(shuffle_ard(bind_ard(ard_categorical(ADSL, by = ARM, variables = AGEGR1), ard_categorical(ADSL, variables = AGEGR1), ard_continuous(ADSL, by = SEX, variables = AGE), ard_continuous(ADSL, variables = AGE)))) Output ARM SEX variable label context stat_name stat 1 Placebo AGEGR1 65-80 categorical n 42.0000000 2 Placebo AGEGR1 65-80 categorical N 86.0000000 3 Placebo AGEGR1 65-80 categorical p 0.4883721 4 Placebo AGEGR1 <65 categorical n 14.0000000 5 Placebo AGEGR1 <65 categorical N 86.0000000 6 Placebo AGEGR1 <65 categorical p 0.1627907 7 Placebo AGEGR1 >80 categorical n 30.0000000 8 Placebo AGEGR1 >80 categorical N 86.0000000 9 Placebo AGEGR1 >80 categorical p 0.3488372 10 Xanomeline High Dose AGEGR1 65-80 categorical n 55.0000000 11 Xanomeline High Dose AGEGR1 65-80 categorical N 84.0000000 12 Xanomeline High Dose AGEGR1 65-80 categorical p 0.6547619 13 Xanomeline High Dose AGEGR1 <65 categorical n 11.0000000 14 Xanomeline High Dose AGEGR1 <65 categorical N 84.0000000 15 Xanomeline High Dose AGEGR1 <65 categorical p 0.1309524 16 Xanomeline High Dose AGEGR1 >80 categorical n 18.0000000 17 Xanomeline High Dose AGEGR1 >80 categorical N 84.0000000 18 Xanomeline High Dose AGEGR1 >80 categorical p 0.2142857 19 Xanomeline Low Dose AGEGR1 65-80 categorical n 47.0000000 20 Xanomeline Low Dose AGEGR1 65-80 categorical N 84.0000000 21 Xanomeline Low Dose AGEGR1 65-80 categorical p 0.5595238 22 Xanomeline Low Dose AGEGR1 <65 categorical n 8.0000000 23 Xanomeline Low Dose AGEGR1 <65 categorical N 84.0000000 24 Xanomeline Low Dose AGEGR1 <65 categorical p 0.0952381 25 Xanomeline Low Dose AGEGR1 >80 categorical n 29.0000000 26 Xanomeline Low Dose AGEGR1 >80 categorical N 84.0000000 27 Xanomeline Low Dose AGEGR1 >80 categorical p 0.3452381 28 Overall ARM AGEGR1 65-80 categorical n 144.0000000 29 Overall ARM AGEGR1 65-80 categorical N 254.0000000 30 Overall ARM AGEGR1 65-80 categorical p 0.5669291 31 Overall ARM AGEGR1 <65 categorical n 33.0000000 32 Overall ARM AGEGR1 <65 categorical N 254.0000000 33 Overall ARM AGEGR1 <65 categorical p 0.1299213 34 Overall ARM AGEGR1 >80 categorical n 77.0000000 35 Overall ARM AGEGR1 >80 categorical N 254.0000000 36 Overall ARM AGEGR1 >80 categorical p 0.3031496 37 F AGE N continuous N 143.0000000 38 F AGE Mean continuous mean 75.6503497 39 F AGE SD continuous sd 8.1933146 40 F AGE Median continuous median 77.0000000 41 F AGE Q1 continuous p25 72.0000000 42 F AGE Q3 continuous p75 81.0000000 43 F AGE Min continuous min 54.0000000 44 F AGE Max continuous max 89.0000000 45 M AGE N continuous N 111.0000000 46 M AGE Mean continuous mean 74.3603604 47 M AGE SD continuous sd 8.2943494 48 M AGE Median continuous median 77.0000000 49 M AGE Q1 continuous p25 69.0000000 50 M AGE Q3 continuous p75 81.0000000 51 M AGE Min continuous min 51.0000000 52 M AGE Max continuous max 88.0000000 53 Overall SEX AGE N continuous N 254.0000000 54 Overall SEX AGE Mean continuous mean 75.0866142 55 Overall SEX AGE SD continuous sd 8.2462339 56 Overall SEX AGE Median continuous median 77.0000000 57 Overall SEX AGE Q1 continuous p25 70.0000000 58 Overall SEX AGE Q3 continuous p75 81.0000000 59 Overall SEX AGE Min continuous min 51.0000000 60 Overall SEX AGE Max continuous max 89.0000000 # 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 1 Overall ARM AGEGR1 stats_chisq_test statistic 5.07944167 2 Overall ARM AGEGR1 stats_chisq_test p.value 0.07888842 3 Overall SEX AGEGR1 stats_chisq_test statistic 1.03944200 4 Overall SEX AGEGR1 stats_chisq_test p.value 0.59468644 cards/tests/testthat/_snaps/mock.md0000644000176200001440000001606114721245610017114 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.md0000644000176200001440000000700314721245576021436 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 GASTROIN… AEDECOD variable_level stat_name stat_label stat 1 ABDOMINA… 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 GASTROIN… AEDECOD variable_level stat_name stat_label stat 1 ABDOMINA… 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.md0000644000176200001440000000544314721245563020652 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.md0000644000176200001440000000064014721245607020453 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.md0000644000176200001440000000346514721513741020643 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.md0000644000176200001440000000207214721245563021203 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.md0000644000176200001440000000515114721245571021352 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.md0000644000176200001440000000200714721245564020463 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.md0000644000176200001440000003156514721245607021177 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.md0000644000176200001440000000111314721245611021715 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.R0000644000176200001440000003607214675616454022133 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) ) ) # 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) ) ) }) 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 expect_equal( ard |> dplyr::filter(!is.na(group2)), ard_hierarchical( ADAE_small, variables = c(AESOC, AEDECOD), by = TRTA, id = USUBJID, denominator = ADSL |> dplyr::rename(TRTA = TRT01A) ) |> cards::tidy_ard_row_order() ) # check AESOC match expect_equal( ard |> dplyr::filter(variable %in% "AESOC") |> dplyr::select(-all_ard_group_n(2L)), 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() ) }) 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 expect_equal( ard |> dplyr::filter(variable == "AEDECOD"), 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(), ignore_attr = TRUE, ignore_function_env = TRUE ) # check the rates for AESOC are correct expect_equal( ard |> dplyr::filter(variable == "AESOC") |> rename_ard_columns(), 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() |> 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 expect_equal( ard |> dplyr::filter(!is.na(group1)), ard_hierarchical_count(ADAE_small, variables = c(AESOC, AEDECOD)) ) # check AESOC match expect_equal( ard |> dplyr::filter(is.na(group1)) |> dplyr::select(-all_ard_group_n(1L)), ard_hierarchical_count(ADAE_small, variables = AESOC) ) }) 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 expect_equal( ard |> dplyr::filter(!is.na(group2)), ard_hierarchical_count(ADAE_small, variables = c(AESOC, AEDECOD), by = TRTA) |> cards::tidy_ard_row_order() ) # check AESOC match expect_equal( ard |> dplyr::filter(is.na(group2)) |> dplyr::select(-all_ard_group_n(2L)), ard_hierarchical_count(ADAE_small, variables = AESOC, by = TRTA) |> cards::tidy_ard_row_order() ) }) 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()) ) # 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()) ) 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()) ) # 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()) ) }) 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()) ) # 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()) ) }) 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(AESOC, AEDECOD, TRTA)) |> dplyr::select(-all_missing_columns()) ) }) cards/tests/testthat/test-apply_fmt_fn.R0000644000176200001440000000470214667651631020150 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_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-shift_ard_columns.R0000644000176200001440000000350514632350734021165 0ustar liggesuserstest_that("rename_ard_columns() works", { # no variable level res_var <- ard_continuous(data = ADSL, by = TRT01A, variables = c(AGE, BMIBL, HEIGHTBL)) res_rnm_var <- rename_ard_columns(res_var, all_ard_variables()) expect_equal(nrow(res_var), nrow(res_rnm_var)) expect_snapshot(res_rnm_var |> dplyr::select(-c(fmt_fn, warning, error)) |> dplyr::slice(1:20) |> as.data.frame()) # multiple variables and levels res_multi <- ard_stack( data = ADSL, .by = c(TRT01A, SEX), ard_categorical(variables = c(RACE, ETHNIC)), ard_continuous(variables = AGE) ) res_rnm_multi <- rename_ard_columns(res_multi, all_ard_variables()) expect_equal(nrow(res_multi), nrow(res_rnm_multi)) res_multi_1 <- rename_ard_columns(res_multi, c(all_ard_groups(), all_ard_variables())) # rename groups and variables expect_snapshot( res_multi_1 |> dplyr::select(-c(fmt_fn, warning, error)) |> dplyr::slice(1:20) |> as.data.frame() ) # robust to order and NSE expect_equal( res_multi_1, res_multi |> rename_ard_columns(c( variable, group1, group2_level, variable_level, group2, group1_level )) ) # rename variables after shuffle # include case where one of the variables is already present as a group res_shuffle <- ard_stack( data = ADSL, .by = TRT01A, ard_categorical(variables = c(RACE, ETHNIC)), ard_continuous(variables = AGE), .shuffle = TRUE ) expect_snapshot( res_shuffle |> rename_ard_columns(c(variable, label)) |> dplyr::slice(1:20) |> as.data.frame() ) # _level doesn't have a match res_var <- ard_continuous(data = ADSL, by = TRT01A, variables = c(AGE, BMIBL, HEIGHTBL)) expect_snapshot( rename_ard_columns( res_var |> dplyr::select(-group1), "group1_level" ) ) }) 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.R0000644000176200001440000000270514664372617017236 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_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.R0000644000176200001440000000060614567176413014513 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/tests/spelling.R0000644000176200001440000000023114571403231014444 0ustar liggesusersif (requireNamespace("spelling", quietly = TRUE)) { spelling::spell_check_test( vignettes = TRUE, error = FALSE, skip_on_cran = TRUE ) } cards/MD50000644000176200001440000003073514721540432011670 0ustar liggesusersc3fe69f5d8b3a84946bd66343b499020 *DESCRIPTION 4266744a39c93a31970fd97d2b139d55 *NAMESPACE 9b77ec76615234c69b7eb143848b3d69 *NEWS.md c2e9d74c15350256b711e9ab24cad727 *R/add_calculated_row.R 6fef035b9bd339715bf07cf3aace70a3 *R/apply_fmt_fn.R 3f7a24343d644b6cb20e55fcf07097df *R/ard_attributes.R 5e3214261a1f3b865099c8591410c18e *R/ard_categorical.R eba7bdbe3d9b8bbf9bbb5f62dbf8390a *R/ard_complex.R 9d2c111358e0d4101fb498110befc9ee *R/ard_continuous.R 9c6d39aab84082bdd0c5b5b3307deb8a *R/ard_dichotomous.R a5d6b5f670eb9e7bfe2708368aa26d11 *R/ard_hierarchical.R 08eacdf34ae8f7e705e1932c0cab5f95 *R/ard_missing.R c0d6f8cfb010f5f5ac406261b3b5fd83 *R/ard_pairwise.R a451c441ad718ce348520450965a5b84 *R/ard_stack.R 219c738a001a234457e7cc1f93717ea1 *R/ard_stack_hierarchical.R 47b10bd191d12597dcf2392a94eaba79 *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 88192440732ed07ae162f3310cd57575 *R/cards-package.R 56698318fb7622a3e0affd04e7d05254 *R/check_ard_structure.R 1e1723c87265d4b5b767d736c827705e *R/data.R aa190f84380a3c9050aac2689e374842 *R/default_stat_labels.R 4f206ec13b9023de18e14682b89dc115 *R/eval_capture_conditions.R acd8dfd2d499ce4452fde32e23f1c0fa *R/get_ard_statistics.R 5f27ab24b8fad841aed00f28fe415f6c *R/import-standalone-check_pkg_installed.R fab17f675f7c139926890c89a2f9fa9d *R/import-standalone-checks.R 25b4af5ffd6bf4dfa3eb5367d5de0408 *R/import-standalone-cli_call_env.R 189068ad6b3a2f0b309f45d067d20359 *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 40bd5f160147660164d64feb0569fe9a *R/print.R bbc1f138d63fac82b728a21e34ada359 *R/print_ard_conditions.R e0deca2ecb0703f2289cf9cc49f4a910 *R/process_selectors.R 2baa216c9dbb73ff1c9896547862d0e2 *R/reexports.R c7da0fc70c24204ee7dd09578bd28a8e *R/replace_null_statistic.R 34eb1ad181c28455220db38e4fad5329 *R/round5.R 47d0bc2974b3011db924e4b985811e4e *R/selectors.R 7ff71b0106a7456b13cb7e9eec459468 *R/shift_ard_columns.R 484f641780ad1aa70643fd4441202469 *R/shuffle_ard.R e3336d889b8fc8a292bb84604197ea42 *R/summary_functions.R a02e0e11a24702e15b9585153ae47f3a *R/syntax.R 2d652be3d49ba4a3a08702f940bfa7e3 *R/tidy_ard_order.R 9ad4324bfffa289560a0b291e7cfc256 *R/tidy_as_ard.R 26a81d0d682141f01aa918926ebb8777 *R/update_ard.R 674aaadb1f9236bb7b84609d0397b155 *R/utils.R 47ec800dc1021baddb135b03632c21cf *README.md 9be3ed6d43911aad5ecc307394a2c179 *data/ADAE.rda e36aab825c5346c2bd8cddcc1acdef58 *data/ADSL.rda 01d97bb63b26c9bc4adb45cb6c7d865e *data/ADTTE.rda 12e458de8b7b5562ec187329c88cb5f5 *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 33df2794f43806fb912b0cf4432625cc *man/ard_categorical.Rd 600f0732e45da63d5a7bd7c36d4ef6b2 *man/ard_complex.Rd 11b19b7bf3468cf791276f9b8a591055 *man/ard_continuous.Rd 20aaf17166b8cdb5abeffac2752ed292 *man/ard_dichotomous.Rd be7d3ce73076be77cf76eaa2f65897fe *man/ard_hierarchical.Rd 84cf171b31321eb0b87a2238b5f2b628 *man/ard_missing.Rd b167fc5d7a32795c9ce260b56139ea66 *man/ard_pairwise.Rd c72fa55d1f491c308bdbaf80bcb3d60b *man/ard_stack.Rd 22a192cf5219abcf0498a059db2bd30b *man/ard_stack_hierarchical.Rd 28ff43f6b3e7ce76ee523a3607f738d4 *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 5dd67edecadd8970eb65b84262bd460c *man/check_ard_structure.Rd 7cddd89edc980c298fbe3e1fa16ba78d *man/default_stat_labels.Rd 2cf8bdfbd60a4089cca06779f1030a0f *man/dot-calculate_stats_as_ard.Rd feb509c0972a471ce660ab301907c293 *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 ebbef972d7e3e230089838aae1070d45 *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 930c9fc11c41015927e65c4c7ab9923a *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 205e18fe095b6794cbde9298247bba07 *man/dot-is_list_column_of_scalars.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 547de058571958099f2e381945eb82ad *man/dot-pair_columns.Rd 99f600fbb745d1d480016fda971f3906 *man/dot-process_denominator.Rd b399af22e2ad49aa595fd4a7e01e6d4d *man/dot-process_nested_list_as_df.Rd 2121482506bb51565c005088b9a222ce *man/dot-purrr_list_flatten.Rd 6799ec626bc78f1dd817803424051c01 *man/dot-rename_last_group_as_variable.Rd 9038b3a7ed05abb95fd39a6afd164a0b *man/dot-shift_column_pair.Rd 51909e710ff23739ead9126c48186004 *man/dot-table_as_df.Rd 53548c992318c0964d5f4fa325134b4e *man/dot-trim_ard.Rd b68996f635bafda4ccdda88bead7798c *man/dot-unique_and_sorted.Rd d48215ac9a210e57d1799d836677fd0d *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 28cf2540396e11585b54f36959d5e66a *man/get_ard_statistics.Rd 139751f688067f47809e8f957329d2d6 *man/label_cards.Rd e22783369d586485965531e6a7a7f967 *man/maximum_variable_value.Rd cfec0843821499c3d9c2efa8e48f7cb8 *man/mock.Rd aa6e1648c13523e09bb2ae19f114674f *man/nest_for_ard.Rd 479948ab0d6b64b0c24e33631cb08b4f *man/print.card.Rd 97b0f315ab342b4921c3cd477c6e805d *man/print_ard_conditions.Rd 12cc12f77d7e6f71d903323fce5079be *man/process_selectors.Rd a9515193a99a4f99c5effa4ee55458c4 *man/reexports.Rd 61b5a0c0c62927e5a4dd38a9460d65d3 *man/rename_ard_columns.Rd b5b85c39ee03be552c32a398c24309f2 *man/replace_null_statistic.Rd 9409134fcb1d6e02702cd7a7eb121b41 *man/round5.Rd 053ee276dec85df59d7b227184472807 *man/selectors.Rd adca5f6a835a24d9d159c15613afc41c *man/shuffle_ard.Rd cc4afc1b96d125a205525717fb2b5683 *man/summary_functions.Rd 5c37a02164ffb7102eedeac0feea5159 *man/syntax.Rd 9adff83e0ddbbd2bff7bd2e7cb92061b *man/tidy_ard_order.Rd 14e87778eb403fc0bc4c9cf77240b7d1 *man/tidy_as_ard.Rd a4babbc605943c8dbdeec1995325266a *man/update_ard.Rd 6286c40603df000aaae222467ae8cd76 *tests/spelling.R 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 50c8025ad402f2e4375d14af88795628 *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 cd7a1c122dedb82f7a858c4dc2b08e9c *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 fccbdd668a03c8655aa7290a970aa263 *tests/testthat/_snaps/ard_stack_hierarchical.md 7be053ab3d6ffadb6ba4e969738a10f0 *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 6f2c33a16a7e93784a3736b576fd651a *tests/testthat/_snaps/bind_ard.md 1d3fed2e67ad4c1f47437c61f2d49028 *tests/testthat/_snaps/check_ard_structure.md 91b80b703fe106f2f1ed251a8fc8eb73 *tests/testthat/_snaps/eval_capture_conditions.md d6cd7ea361c3b86d1911515ff52853dc *tests/testthat/_snaps/get_ard_statistics.md b3454edede4a74d915b20e9188d35745 *tests/testthat/_snaps/mock.md e2c67c46fcd1aeacde503556afa94499 *tests/testthat/_snaps/print.md 925794a15675fdb52b5a8bbcff86ce99 *tests/testthat/_snaps/print_ard_conditions.md 44b7e17ae022b511784d5432380cda25 *tests/testthat/_snaps/process_selectors.md 0272efa707f13e12223d363d025436d9 *tests/testthat/_snaps/rename_ard_columns.md 54d57668aa3341c5209b0bc97944cb4c *tests/testthat/_snaps/round5.md 0d934343aaabae2a440c5facd54c3a30 *tests/testthat/_snaps/shift_ard_columns.md ac93ecf4d859660d18e64a54eda58671 *tests/testthat/_snaps/shuffle_ard.md ed6bc57f4319891ba53421c469d138e0 *tests/testthat/_snaps/tidy_as_ard.md 831ea982e65f6787768bfa6a03b99ba1 *tests/testthat/_snaps/update_ard.md 697c196cd1fa648c38057758ffad18a2 *tests/testthat/test-add_calculated_row.R 2d3a3d98afc26b77a1106506e3859d15 *tests/testthat/test-apply_fmt_fn.R 9aedcdafa29999167bd41b6cd09c0a37 *tests/testthat/test-ard_attributes.R d984ba3820bddc23b8770fcb81ed7021 *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 9ec243921daedab70fa82eb047fbec42 *tests/testthat/test-ard_hierarchical.R c4bd58e09e7c2615c1cdaa4749d61d97 *tests/testthat/test-ard_missing.R 79a1c40e3e3f8e0b72d7bb8bb6cb91a2 *tests/testthat/test-ard_pairwise.R e7404f149a4c9144f9fa7fb8407ebd2b *tests/testthat/test-ard_stack.R 1546a52876852068a82072d3deca6386 *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 2186501d6f98869e6c20bf1b4069ae61 *tests/testthat/test-bind_ard.R 438caae87f213ba447435673db46cbca *tests/testthat/test-check_ard_structure.R cbef190a93c26758b17f0e21db825e3c *tests/testthat/test-eval_capture_conditions.R e53208dd8d452187b5d6b2f207bf2e78 *tests/testthat/test-get_ard_statistics.R 5ba981628b047e584c0e8421ce2ff44f *tests/testthat/test-label_cards.R 8d886670ef1051ce05117802f76715ca *tests/testthat/test-mock.R a9861f5e22bf3c0c729556bf2db97655 *tests/testthat/test-nest_for_ard.R 4d4170d70ea19521bed0256235278b66 *tests/testthat/test-print.R db3e4f023ef562ada3ad562b381e4f9f *tests/testthat/test-print_ard_conditions.R b2e0a96f4a987a5b18ad34b434b8edcc *tests/testthat/test-process_selectors.R 68a68b646757110c59994e127e1932a0 *tests/testthat/test-rename_ard_columns.R bb86b8fea589da80f5992741f6e70ded *tests/testthat/test-replace_null_statistic.R ff7a3a310a49b1e60bdc23682582bff9 *tests/testthat/test-round5.R ac0a236a3930e7ee4a059b70d3ca2cbe *tests/testthat/test-selectors.R 443aab2cd2260b357ec689c52bd63b39 *tests/testthat/test-shift_ard_columns.R d6ea53be6d5eb8a4a05aff293ce1857d *tests/testthat/test-shuffle_ard.R 8d6e36bf558a47dcf18e72b0ec9b9e99 *tests/testthat/test-tidy_ard_column_order.R 3f097b62ac28bc853f744e81b6e91cad *tests/testthat/test-tidy_as_ard.R 1f03e7ced200b416e9a723121611c33d *tests/testthat/test-update_ard.R cards/R/0000755000176200001440000000000014721513741011554 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/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.R0000644000176200001440000001047014721205552013033 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 #' #' @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.R0000644000176200001440000000322514712252321014665 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 variables, groups, and #' strata, while retaining the order of the input ARD. #' #' @param x (`data.frame`)\cr #' an ARD data frame of class 'card' #' #' @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) { set_cli_abort_call() group_cols <- dplyr::select(x, all_ard_groups()) |> names() |> sort() group_cols <- group_cols[order(str_extract_all(group_cols, "\\d+") |> unlist() |> as.integer())] 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() check_class(x, cls = "card") # get columns that dictate ordering cols <- x |> dplyr::select( all_ard_variables("names"), all_ard_groups("names"), all_ard_groups("levels") ) |> names() # perform the ordering x |> dplyr::arrange(across(all_of(cols), .fns = function(x) match(x, unique(x)))) } cards/R/update_ard.R0000644000176200001440000001126214672114773014020 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.R0000644000176200001440000000615414721513741014031 0ustar liggesusers#' Stratified ARD #' #' @description #' `r lifecycle::badge('experimental')`\cr #' 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() } cards/R/round5.R0000644000176200001440000000142014567176413013121 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, #' `round5(0.5) = 1`. #' #' @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/shift_ard_columns.R0000644000176200001440000001666114675616454015431 0ustar liggesusers#' Rename ARD Columns #' #' This function combines a pair of `group`/`group_level` or `variable`/`variable_level` columns into a #' single column. The `group_level` or `variable_level` column is renamed according to the value of #' the `group` or `variable` column, respectively. #' #' @param x (`data.frame`)\cr #' a data frame #' @param columns ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' Name of columns to coalesce together and rename. #' @param unlist ([`tidy-select`][dplyr::dplyr_tidy_select])\cr #' Columns to unlist. Often useful when performing visual inspection #' of the results where the list-columns are more difficult to work with. #' #' @return data frame #' @export #' #' @examples #' ADSL |> #' ard_categorical(by = ARM, variables = AGEGR1) |> #' apply_fmt_fn() |> #' rename_ard_columns(unlist = c(stat, stat_fmt)) rename_ard_columns <- function(x, columns = c(all_ard_groups(), all_ard_variables()), unlist = NULL) { set_cli_abort_call() # check inputs --------------------------------------------------------------- check_not_missing(col) # process arguments ---------------------------------------------------------- process_selectors(x, columns = {{ columns }}, unlist = {{ unlist }}) if (is_empty(columns) && is_empty(unlist)) { return(x) } # unlist columns ------------------------------------------------------------- if (!is_empty(unlist)) { for (unlist_var in unlist) { unlisted <- eval_capture_conditions(unlist(x[[unlist_var]])) |> captured_condition_as_error( message = c( "!" = "The following error occured while unlisting column {.val {unlist_var}}.", "x" = "{condition}" ) ) if (is.list(unlisted)) { cli::cli_inform(c("Unable to unlist column {.val {unlist_var}}.", "i" = "This often occurs when a list column contains elements that cannot coerced to a common type." )) } if (length(unlisted) != length(x[[unlist_var]])) { cli::cli_abort( c("Cannot unlist column {.val {unlist_var}}. The unlisted result is not the same length as the original.", "i" = "This often occurs when the column contains {.code NULL} values.", if (unlist_var == "stat") c("*" = "Run {.fun cards::replace_null_statistic} to replace {.code NULL} values with {.val {NA}}.") # styler: off ), call = get_cli_abort_call() ) } x[[unlist_var]] <- unlisted } } # rename columns ------------------------------------------------------------- if (!is_empty(columns)) { # determine pairs of variables and levels column_pairs <- .pair_columns(x, columns) # Sequentially coalesce/rename for (col_pair in column_pairs) { x <- .shift_column_pair(x, col_pair) } } # return final ARD ----------------------------------------------------------- x } #' Pair columns #' #' This function ingests an ARD object and finds pairs of columns based on those requested for coalescing/renaming #' #' @param x (`data.frame`)\cr #' a data frame #' @param columns (`character`)\cr #' all columns to consider for coalescing/renaming #' #' @return a list of column pairs (as character vectors) #' @keywords internal #' #' @examples #' ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") |> #' cards:::.pair_columns(columns = c("group1", "group1_level", "variable", "variable_level")) .pair_columns <- function(x, columns) { # if `x` is the result of `shuffle_ard` then only columns to be coalesced/renamed will be variable/label if (identical(sort(columns), c("label", "variable"))) { list(c("variable", "label")) } else { col_vars <- columns[!grepl(".*_level$", columns)] # determine if any of the columns of variables do not have a matching column of levels col_levs <- columns[grepl(".*_level$", columns)] unmatched_lev <- setdiff(col_levs, paste0(col_vars, "_level")) if (length(unmatched_lev) > 0) { cli::cli_alert_warning("The following `*_level` columns do not have a match and will not be renamed: {.val {unmatched_lev}}") } # return a pair of columns (ok if the _level doesn't actually exist) lapply(col_vars, function(col) { col_lev <- paste0(col, "_level") c(col, col_lev) }) } } #' Shift column pair #' #' This function ingests an ARD object and coalesces/renames a given pair of columns (variable and levels) #' #' @param x (`data.frame`)\cr #' a data frame #' @param col_pair (`character`)\cr #' character vector containing the column names for variables (first element) and their corresponding levels (second element) #' #' @return a tibble #' @keywords internal #' #' @examples #' ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") |> #' cards:::.shift_column_pair(col_pair = c("group1", "group1_level")) #' .shift_column_pair <- function(x, col_pair) { col <- col_pair[1] col_lev <- col_pair[2] col_vals <- unique(x[[col]]) |> stats::na.omit() |> as.character() col_vals_new <- setdiff(col_vals, names(x)) # rename as the variable level within the unique levels of the grouping variable x <- x |> # unlist the list-columns & convert NULL to NA dplyr::mutate( dplyr::across( any_of(c(col, col_lev)), ~ lapply(., \(x) if (!is.null(x)) as.character(x) else NA_character_) |> unlist() ) ) |> dplyr::mutate(!!col := fct_inorder(.data[[col]])) |> dplyr::group_by(.data[[col]]) |> dplyr::group_split() |> map(function(dat) { col_new <- unique(dat[[col]]) |> as.character() # drop if no grouping values if (is.na(col_new)) { dplyr::select(dat, -any_of(c(col_lev, col))) } else { # create _level var if it does not exist if (is.null(dat[[col_lev]])) { dat <- dat |> dplyr::mutate(!!col_lev := NA_character_, .after = all_of(col)) } # fill any NA _level col_new_fill <- make.unique(c( unique(dat[[col_lev]]) |> unlist(), paste("Overall", col_new) )) |> dplyr::last() # rename _level var & drop source dat_rnm <- dat %>% dplyr::mutate(across(any_of(c(col, col_lev)), as.character)) |> dplyr::mutate(!!col_lev := tidyr::replace_na(.data[[col_lev]], col_new_fill)) if (col_new %in% names(dat_rnm)) { # if there are any mismatches between the an existing column and the column-to-be, notify user that column-to-be will take precedence if (!all(is.na(dat_rnm[[col_new]])) && !all(is.na(dat_rnm[[col_lev]])) && any(dat_rnm[[col_new]] != dat_rnm[[col_lev]])) { cli::cli_alert_warning("Original values of {.val {col_new}} will be overwritten by those from {.val {col_lev}}.") } dat_rnm <- dat_rnm |> dplyr::mutate(!!col_new := ifelse(!is.na(.data[[col_lev]]), .data[[col_lev]], .data[[col_new]] )) |> dplyr::relocate(all_of(col_new), .after = all_of(col_lev)) |> dplyr::select(-all_of(c(col, col_lev))) } else { dat_rnm <- dat_rnm |> dplyr::rename(!!col_new := all_of(col_lev)) |> dplyr::select(-all_of(col)) } } }) x_combined <- dplyr::bind_rows(x) # ensure all the newly created appear in sequence if (length(col_vals_new) > 1) { x_combined <- x_combined |> dplyr::relocate(all_of(col_vals_new[-1]), .after = all_of(col_vals_new[1])) } x_combined } cards/R/apply_fmt_fn.R0000644000176200001440000001641114672114773014367 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_cards(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("xx.xx", 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_cards(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_cards(2)(pi) #' label_cards(1, scale = 100)(pi) #' label_cards(2, width = 5)(pi) label_cards <- function(digits = 1, scale = 1, width = NULL) { function(x) { # round and scale vector res <- ifelse( is.na(x), NA_character_, format(round5(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 } } #' 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/check_ard_structure.R0000644000176200001440000000526014620764025015726 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.R0000644000176200001440000000442514663411551013710 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) { check_integerish(n) any_of(sort(c(paste0("group", n), paste0("group", n, "_level")))) } #' @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/import-standalone-forcats.R0000644000176200001440000000325114705533060016775 0ustar liggesusers# Standalone file: do not edit by hand # Source: # ---------------------------------------------------------------------- # # --- # repo: insightsengineering/standalone # file: standalone-forcats.R # last-updated: 2024-06-05 # 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 # # 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 } # 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.R0000644000176200001440000002433614671705567014206 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 |> # unlist the list-columns dplyr::mutate( dplyr::across( where(.is_list_column_of_scalars), ~ lapply(., \(x) if (!is.null(x)) as.character(x) else NA_character_) |> unlist() ) ) |> .check_var_nms(vars_protected = names(dat_cards_stats)) |> rename_ard_columns(columns = all_ard_groups()) |> .fill_grps_from_variables() # join together again dat_cards_out <- dplyr::left_join( dat_cards_grps_processed, dat_cards_stats, by = ".cards_idx" ) # fill stat_label -> variable_level if exists if ("stat_label" %in% names(dat_cards_out)) { dat_cards_out <- dat_cards_out |> dplyr::mutate(dplyr::across(any_of("variable_level"), ~ dplyr::coalesce(.x, stat_label))) } dat_cards_out <- dat_cards_out |> .fill_overall_grp_values(vars_protected) |> dplyr::rename(any_of(c(label = "variable_level"))) |> dplyr::arrange(".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) # flatten ard table for easier viewing --------------------------------------- x |> # detect any warning/error messages and notify user .detect_msgs("warning", "error") |> # filter to numeric statistic values dplyr::filter(map_lgl( .data$stat, \(x) is.null(x) || (length(x) == 1L && (is.numeric(x) || is.na(x))) )) |> # unlist the list-columns dplyr::mutate(stat = lapply( .data$stat, \(x) if (!is.null(x) && !is.na(x)) x else NA_real_ ) |> unlist() |> unname()) |> # remove the formatting functions / warning / error dplyr::select(-where(is.list), -any_of("stat_label")) } #' 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 #' #' @return a data frame #' @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.") } }) x } #' 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 } } #' List Column as a Vector Predicate #' #' A predicate function to check whether a column is a list and can be #' represented as a vector. #' #' @param x (`any`)\cr #' column to check #' #' @return a logical #' @keywords internal #' #' @examples #' cards:::.is_list_column_of_scalars(as.list(1:5)) .is_list_column_of_scalars <- function(x) { is.list(x) && all(unlist(lapply(x, FUN = function(x) length(x) == 1L || is.null(x)))) } cards/R/bind_ard.R0000644000176200001440000001014014664372711013443 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.R0000644000176200001440000001447314632350734014357 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_missing.R0000644000176200001440000000663414661403171014205 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.R0000644000176200001440000001244014712255415016114 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' #' #' @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) { set_cli_abort_call() check_class(x, cls = "card") # print condition messages --------------------------------------------------- # styler: off if ("error" %in% names(x)) .cli_condition_messaging(x, msg_type = "error") if ("warning" %in% names(x)) .cli_condition_messaging(x, msg_type = "warning") # 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) { 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()}}:" ) for (i in seq_len(nrow(ard_msg))) { cli::cli_inform( 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.R0000644000176200001440000001524114712243152015142 0ustar liggesusers#' Hierarchical ARD Statistics #' #' `r lifecycle::badge('experimental')`\cr #' 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. #' @inheritParams ard_categorical #' #' @return an ARD data frame of class 'card' #' @name ard_hierarchical #' #' @inheritSection ard_categorical Denominators #' #' @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) # 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() |> 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) .rename_last_group_as_variable <- function(df_result) { df_result <- dplyr::select(df_result, -all_ard_variables()) last_two_grouping_columns <- dplyr::select(df_result, all_ard_groups()) |> names() |> utils::tail(n = 2L) |> stats::setNames(c("variable", "variable_level")) dplyr::rename(df_result, !!!last_two_grouping_columns) } 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.R0000644000176200001440000002130614675616454012647 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.R0000644000176200001440000001211714675616454016621 0ustar liggesusers#' Evaluate and Capture Conditions #' #' @description #' #' `r lifecycle::badge('experimental')`\cr #' **`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/utils.R0000644000176200001440000000436714655030740013050 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(TRUE, FALSE)) else return(c(TRUE, FALSE, 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.R0000644000176200001440000001627214705533060021320 0ustar liggesusers# Standalone file: do not edit by hand # Source: # ---------------------------------------------------------------------- # # --- # repo: insightsengineering/standalone # file: standalone-check_pkg_installed.R # last-updated: 2024-04-19 # license: https://unlicense.org # dependencies: standalone-cli_call_env.R # imports: [rlang, dplyr, tidyr] # --- # # This file provides functions to check package installation. # # ## Changelog # 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 = .data$version |> str_extract(pattern = "[>=<]+"), version = .data$version |> str_remove_all(pattern = "[\\(\\) >=<]") ) } .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.R0000644000176200001440000001607414675616454013657 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.R0000644000176200001440000003220414721250547014736 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. Default is `everything()`. #' @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() |> 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_cards(digits = 1, scale = 100)) } if (is.integer(stat)) { return(0L) } if (is.numeric(stat)) { return(1L) } return(as.character) } ) ) } cards/R/ard_stack_hierarchical.R0000644000176200001440000004257414677312124016346 0ustar liggesusers#' Stacked Hierarchical ARD Statistics #' #' @description #' `r lifecycle::badge('experimental')`\cr #' 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) } # return final result -------------------------------------------------------- result } # 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.R0000644000176200001440000000661614677313136014732 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() |> 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.R0000644000176200001440000000106014645246060015677 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_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/ard_complex.R0000644000176200001440000001101214675540317014176 0ustar liggesusers#' Complex ARD Summaries #' #' `r lifecycle::badge('experimental')`\cr #' 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.R0000644000176200001440000000030114664170603014360 0ustar liggesusers#' @keywords internal #' @import rlang #' @importFrom dplyr across "_PACKAGE" ## usethis namespace: start ## usethis namespace: end NULL utils::globalVariables(c(".", "!<-", "parse_expr<-")) cards/R/tidy_as_ard.R0000644000176200001440000001026314661403171014161 0ustar liggesusers#' Build ARD from Tidier #' #' @description #' 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 #' #' @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() |> 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.R0000644000176200001440000005300114721205552014777 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 (`data.frame`, `integer`)\cr #' Specify this *optional* argument to change the denominator, #' e.g. the `"N"` statistic. Default is `NULL`. 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")` #' (or 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 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 string: one of `"column"`, `"row"`, or `"cell"`. `"column"` is equivalent #' to `denominator=NULL`. `"row"` gives 'row' percentages where `by`/`strata` #' columns are the 'top' of a cross table, and the variables are the rows. #' `"cell"` gives percentages where the denominator is the number of non-missing #' rows in the source data frame. #' - 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. #' #' @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 = NULL, 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")), error_msg = "Elements passed in the {.arg statistic} argument must be one or more of {.val {c('n', 'p', 'N')}}" ) # 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() |> 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") %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 ("p" %in% tab_stats[["tabulation"]]) { df_result_tabulation <- df_result_tabulation |> dplyr::mutate( ...ard_p... = .data$...ard_n... / .data$...ard_N... ) } 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...")), 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...")), 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() ) } } ) } #' 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::right_join( df_table, df_original_strata, by = strata ) } 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/ard_dichotomous.R0000644000176200001440000001253214661403171015063 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/NAMESPACE0000644000176200001440000000512514721513741012575 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_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(get_ard_statistics) export(get_cards_fn_stat_names) export(is_cards_fn) export(label_cards) 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(replace_null_statistic) export(round5) export(shuffle_ard) export(starts_with) export(tidy_ard_column_order) export(tidy_ard_row_order) export(tidy_as_ard) 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.md0000644000176200001440000001740314721517545012464 0ustar liggesusers# 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/0000755000176200001440000000000014675616454012345 5ustar liggesuserscards/inst/WORDLIST0000644000176200001440000000053714675616454013544 0ustar liggesusersADAE ADaM AE AEs ARD ARD's ARDs CDISC CMD Codecov GlaxoSmithKline Hoffmann JSON Lifecycle ORCID Pharma Pre Rua SAS's SDTM YAML ata cardx cli de env esult ets funder hms httr jsonlite mis nalysis namespaced pharmaverse pre quosures reproducibility reusability sd tibble tidyselect tidyselector tidyselectors univariable unlist unlists unnested unnests cards/README.md0000644000176200001440000001001514721514511012623 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/branch/main/graph/badge.svg)](https://app.codecov.io/gh/insightsengineering/cards?branch=main) [![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) [![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#experimental) 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 ``` ## Other Resources - [Posit 2024 pharmaverse Workshop](https://posit-conf-2024.github.io/pharmaverse/#schedule): Follow the link for “Analysis Results Datasets†in the schedule. - [2024 China Pharma R User Conference Keynote Address](https://www.danieldsjoberg.com/china-pharma-keynote-2024/material.html) cards/man/0000755000176200001440000000000014721522651012126 5ustar liggesuserscards/man/ard_categorical.Rd0000644000176200001440000001157214721232376015530 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 = 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{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")} (or the RHS of a formula).} \item{denominator}{(\code{data.frame}, \code{integer})\cr Specify this \emph{optional} argument to change the denominator, e.g. the \code{"N"} statistic. Default is \code{NULL}. 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 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 string: one of \code{"column"}, \code{"row"}, or \code{"cell"}. \code{"column"} is equivalent to \code{denominator=NULL}. \code{"row"} gives 'row' percentages where \code{by}/\code{strata} columns are the 'top' of a cross table, and the variables are the rows. \code{"cell"} gives percentages where the denominator is the number of non-missing rows in the source data frame. \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. } } \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.Rd0000644000176200001440000000576514620751407015467 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. Default is \code{everything()}.} \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.Rd0000644000176200001440000001064614721205552015605 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")} (or the RHS of a formula).} \item{denominator}{(\code{data.frame}, \code{integer})\cr Specify this \emph{optional} argument to change the denominator, e.g. the \code{"N"} statistic. Default is \code{NULL}. 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 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 string: one of \code{"column"}, \code{"row"}, or \code{"cell"}. \code{"column"} is equivalent to \code{denominator=NULL}. \code{"row"} gives 'row' percentages where \code{by}/\code{strata} columns are the 'top' of a cross table, and the variables are the rows. \code{"cell"} gives percentages where the denominator is the number of non-missing rows in the source data frame. \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. } } \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.Rd0000644000176200001440000000262114663411551014422 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) 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.Rd0000644000176200001440000000216414675616454016272 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/shift_ard_columns.R \name{rename_ard_columns} \alias{rename_ard_columns} \title{Rename ARD Columns} \usage{ rename_ard_columns( x, columns = c(all_ard_groups(), all_ard_variables()), unlist = NULL ) } \arguments{ \item{x}{(\code{data.frame})\cr a data frame} \item{columns}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Name of columns to coalesce together and rename.} \item{unlist}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr Columns to unlist. Often useful when performing visual inspection of the results where the list-columns are more difficult to work with.} } \value{ data frame } \description{ This function combines a pair of \code{group}/\code{group_level} or \code{variable}/\code{variable_level} columns into a single column. The \code{group_level} or \code{variable_level} column is renamed according to the value of the \code{group} or \code{variable} column, respectively. } \examples{ ADSL |> ard_categorical(by = ARM, variables = AGEGR1) |> apply_fmt_fn() |> rename_ard_columns(unlist = c(stat, stat_fmt)) } 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.Rd0000644000176200001440000000463014674337337014733 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. Default is \code{everything()}.} \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.Rd0000644000176200001440000000135514664374002015100 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.Rd0000644000176200001440000000167414567176413015430 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) tidy_ard_row_order(x) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} } \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 variables, groups, and strata, while retaining the 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.Rd0000644000176200001440000000230714613620742015524 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.Rd0000644000176200001440000000247514643265534014500 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() } 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/print_ard_conditions.Rd0000644000176200001440000000127014614452256016634 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) } \arguments{ \item{x}{(\code{data.frame})\cr an ARD data frame of class 'card'} } \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.Rd0000644000176200001440000000315014714500747014544 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{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}\cr 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.Rd0000644000176200001440000000747414625733031014725 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. Default is \code{everything()}.} \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{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}\cr 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/dot-shift_column_pair.Rd0000644000176200001440000000134614632350734016714 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/shift_ard_columns.R \name{.shift_column_pair} \alias{.shift_column_pair} \title{Shift column pair} \usage{ .shift_column_pair(x, col_pair) } \arguments{ \item{x}{(\code{data.frame})\cr a data frame} \item{col_pair}{(\code{character})\cr character vector containing the column names for variables (first element) and their corresponding levels (second element)} } \value{ a tibble } \description{ This function ingests an ARD object and coalesces/renames a given pair of columns (variable and levels) } \examples{ ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") |> cards:::.shift_column_pair(col_pair = c("group1", "group1_level")) } \keyword{internal} 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/label_cards.Rd0000644000176200001440000000143214567176413014661 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/apply_fmt_fn.R \name{label_cards} \alias{label_cards} \title{Generate Formatting Function} \usage{ label_cards(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_cards(2)(pi) label_cards(1, scale = 100)(pi) label_cards(2, width = 5)(pi) } 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/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.Rd0000644000176200001440000000367314672114773014545 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/eval_capture_conditions.Rd0000644000176200001440000000733414675616454017344 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{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}\cr \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/dot-pair_columns.Rd0000644000176200001440000000131114632350734015672 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/shift_ard_columns.R \name{.pair_columns} \alias{.pair_columns} \title{Pair columns} \usage{ .pair_columns(x, columns) } \arguments{ \item{x}{(\code{data.frame})\cr a data frame} \item{columns}{(\code{character})\cr all columns to consider for coalescing/renaming} } \value{ a list of column pairs (as character vectors) } \description{ This function ingests an ARD object and finds pairs of columns based on those requested for coalescing/renaming } \examples{ ard_categorical(ADSL, by = "ARM", variables = "AGEGR1") |> cards:::.pair_columns(columns = c("group1", "group1_level", "variable", "variable_level")) } \keyword{internal} cards/man/ard_stack_hierarchical.Rd0000644000176200001440000001500714675616454017066 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")} (or 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{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}\cr 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/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.Rd0000644000176200001440000000246514705542357015120 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/0000755000176200001440000000000014567176413013603 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.png0000644000176200001440000013111314641615505015242 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•Ã‡±uë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/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.Rd0000644000176200001440000000135114607274473020064 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) } \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.Rd0000644000176200001440000001216214675616454015700 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")} (or the RHS of a formula).} \item{denominator}{(\code{data.frame}, \code{integer})\cr Specify this \emph{optional} argument to change the denominator, e.g. the \code{"N"} statistic. Default is \code{NULL}. 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")}.} \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{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}\cr 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}. } } \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 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 string: one of \code{"column"}, \code{"row"}, or \code{"cell"}. \code{"column"} is equivalent to \code{denominator=NULL}. \code{"row"} gives 'row' percentages where \code{by}/\code{strata} columns are the 'top' of a cross table, and the variables are the rows. \code{"cell"} gives percentages where the denominator is the number of non-missing rows in the source data frame. \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. } } \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.Rd0000644000176200001440000000127314574702654021253 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) } \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) } \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.Rd0000644000176200001440000000511714567176413014714 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{ 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") } cards/man/dot-process_denominator.Rd0000644000176200001440000000300414721205552017251 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{data.frame}, \code{integer})\cr Specify this \emph{optional} argument to change the denominator, e.g. the \code{"N"} statistic. Default is \code{NULL}. 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/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-is_list_column_of_scalars.Rd0000644000176200001440000000077514574702654020442 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/shuffle_ard.R \name{.is_list_column_of_scalars} \alias{.is_list_column_of_scalars} \title{List Column as a Vector Predicate} \usage{ .is_list_column_of_scalars(x) } \arguments{ \item{x}{(\code{any})\cr column to check} } \value{ a logical } \description{ A predicate function to check whether a column is a list and can be represented as a vector. } \examples{ cards:::.is_list_column_of_scalars(as.list(1:5)) } \keyword{internal} cards/man/dot-calculate_tabulation_statistics.Rd0000644000176200001440000000357114721205552021636 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{data.frame}, \code{integer})\cr Specify this \emph{optional} argument to change the denominator, e.g. the \code{"N"} statistic. Default is \code{NULL}. 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")} (or 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.Rd0000644000176200001440000000143214567176413013642 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{round5(0.5) = 1}. } \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.Rd0000644000176200001440000000153014643265534015510 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} } \value{ a data frame } \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/DESCRIPTION0000644000176200001440000000363014721540432013060 0ustar liggesusersPackage: cards Title: Analysis Results Data Version: 0.4.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), rlang (>= 1.1.1), tidyr (>= 1.3.0), tidyselect (>= 1.2.0) Suggests: spelling (>= 2.2.0), testthat (>= 3.2.0), withr (>= 3.0.0) Config/Needs/check: hms Config/Needs/website: rmarkdown, jsonlite, yaml, gtsummary, tfrmt, 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: 2024-11-27 04:52:57 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: 2024-11-27 06:50:02 UTC